diff options
Diffstat (limited to 'src/scheme/ao_scheme_builtin.c')
| -rw-r--r-- | src/scheme/ao_scheme_builtin.c | 1008 |
1 files changed, 0 insertions, 1008 deletions
diff --git a/src/scheme/ao_scheme_builtin.c b/src/scheme/ao_scheme_builtin.c deleted file mode 100644 index 2b0c394b..00000000 --- a/src/scheme/ao_scheme_builtin.c +++ /dev/null @@ -1,1008 +0,0 @@ -/* - * Copyright © 2016 Keith Packard <keithp@keithp.com> - * - * This program is free software; you can redistribute it and/or modify - * it under the terms of the GNU General Public License as published by - * the Free Software Foundation, either version 2 of the License, or - * (at your option) any later version. - * - * This program is distributed in the hope that it will be useful, but - * WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU - * General Public License for more details. - */ - -#define _GNU_SOURCE -#include "ao_scheme.h" -#include <limits.h> -#include <math.h> -#include <stdarg.h> - -static int -builtin_size(void *addr) -{ - (void) addr; - return sizeof (struct ao_scheme_builtin); -} - -static void -builtin_mark(void *addr) -{ - (void) addr; -} - -static void -builtin_move(void *addr) -{ - (void) addr; -} - -const struct ao_scheme_type ao_scheme_builtin_type = { - .size = builtin_size, - .mark = builtin_mark, - .move = builtin_move -}; - -#ifdef AO_SCHEME_MAKE_CONST - -#define AO_SCHEME_BUILTIN_CASENAME -#include "ao_scheme_builtin.h" - -char *ao_scheme_args_name(uint8_t args) { - args &= AO_SCHEME_FUNC_MASK; - switch (args) { - case AO_SCHEME_FUNC_LAMBDA: return ao_scheme_poly_atom(_ao_scheme_atom_lambda)->name; - case AO_SCHEME_FUNC_NLAMBDA: return ao_scheme_poly_atom(_ao_scheme_atom_nlambda)->name; - case AO_SCHEME_FUNC_MACRO: return ao_scheme_poly_atom(_ao_scheme_atom_macro)->name; - default: return (char *) "???"; - } -} -#else - -#define AO_SCHEME_BUILTIN_ARRAYNAME -#include "ao_scheme_builtin.h" - -static char * -ao_scheme_builtin_name(enum ao_scheme_builtin_id b) { - if (b < _builtin_last) - return ao_scheme_poly_atom(builtin_names[b])->name; - return (char *) "???"; -} - -static const ao_poly ao_scheme_args_atoms[] = { - [AO_SCHEME_FUNC_LAMBDA] = _ao_scheme_atom_lambda, - [AO_SCHEME_FUNC_NLAMBDA] = _ao_scheme_atom_nlambda, - [AO_SCHEME_FUNC_MACRO] = _ao_scheme_atom_macro, -}; - -char * -ao_scheme_args_name(uint8_t args) -{ - args &= AO_SCHEME_FUNC_MASK; - if (args < sizeof ao_scheme_args_atoms / sizeof ao_scheme_args_atoms[0]) - return ao_scheme_poly_atom(ao_scheme_args_atoms[args])->name; - return (char *) "(unknown)"; -} -#endif - -void -ao_scheme_builtin_write(FILE *out, ao_poly b, bool write) -{ - struct ao_scheme_builtin *builtin = ao_scheme_poly_builtin(b); - (void) write; - fputs(ao_scheme_builtin_name(builtin->func), out); -} - -static bool -ao_scheme_typecheck(ao_poly actual, int formal_type) { - int actual_type; - - if ((formal_type & AO_SCHEME_ARG_MASK) == AO_SCHEME_POLY) - return true; - - /* allow nil? */ - if (actual == AO_SCHEME_NIL) - return (formal_type & AO_SCHEME_ARG_NIL_OK) != 0; - - actual_type = ao_scheme_poly_type(actual); - formal_type &= AO_SCHEME_ARG_MASK; - - if (actual_type == formal_type) - return true; - if (actual_type == AO_SCHEME_BUILTIN && formal_type == AO_SCHEME_LAMBDA) - return true; - -#ifdef AO_SCHEME_FEATURE_BIGINT - if (ao_scheme_integer_typep(actual_type) && formal_type == AO_SCHEME_INT) - return true; -#endif -#ifdef AO_SCHEME_FEATURE_FLOAT - if (ao_scheme_number_typep(actual_type) && formal_type == AO_SCHEME_FLOAT) - return true; -#endif - return false; -} - -int -ao_scheme_parse_args(ao_poly name, struct ao_scheme_cons *cons, ...) -{ - va_list ap; - int formal; - int argc = 0; - ao_poly car; - - va_start(ap, cons); - while ((formal = va_arg(ap, int)) != AO_SCHEME_ARG_END) { - if (formal & AO_SCHEME_ARG_OPTIONAL) - car = (ao_poly) va_arg(ap, int); - if (cons) { - car = cons->car; - cons = ao_scheme_cons_cdr(cons); - if (!ao_scheme_typecheck(car, formal)) { - ao_scheme_error(AO_SCHEME_INVALID, "%v: arg %d invalid type %v", name, argc, car); - return 0; - } - } else if (!(formal & AO_SCHEME_ARG_OPTIONAL)) { - goto bad_args; - } - if (formal & AO_SCHEME_ARG_RET_POLY) - formal = AO_SCHEME_POLY; - - switch (formal & AO_SCHEME_ARG_MASK) { - case AO_SCHEME_INT: -#ifdef AO_SCHEME_FEATURE_BIGINT - case AO_SCHEME_BIGINT: -#endif - *(va_arg(ap, int32_t *)) = ao_scheme_poly_integer(car); - break; -#ifdef AO_SCHEME_FEATURE_FLOAT - case AO_SCHEME_FLOAT: - *(va_arg(ap, float *)) = ao_scheme_poly_number(car); - break; -#endif - case AO_SCHEME_POLY: - *(va_arg(ap, ao_poly *)) = car; - break; - default: - *(va_arg(ap, void **)) = ao_scheme_ref(car); - break; - } - argc++; - } - if (cons) { - bad_args: - ao_scheme_error(AO_SCHEME_INVALID, "%v: invalid arg count", name); - return 0; - } - return 1; -} - -ao_poly -ao_scheme_arg(struct ao_scheme_cons *cons, int argc) -{ - for (;;) { - if (!cons) - return AO_SCHEME_NIL; - if (argc == 0) - return cons->car; - cons = ao_scheme_cons_cdr(cons); - argc--; - } -} - -ao_poly -ao_scheme_do_quote(struct ao_scheme_cons *cons) -{ - ao_poly val; - - if (!ao_scheme_parse_args(_ao_scheme_atom_quote, cons, - AO_SCHEME_POLY, &val, - AO_SCHEME_ARG_END)) - return AO_SCHEME_NIL; - return val; -} - -ao_poly -ao_scheme_do_cond(struct ao_scheme_cons *cons) -{ - ao_scheme_set_cond(cons); - return AO_SCHEME_NIL; -} - -ao_poly -ao_scheme_do_begin(struct ao_scheme_cons *cons) -{ - ao_scheme_stack->state = eval_begin; - ao_scheme_stack->sexprs = ao_scheme_cons_poly(cons); - return AO_SCHEME_NIL; -} - -ao_poly -ao_scheme_do_while(struct ao_scheme_cons *cons) -{ - ao_scheme_stack->state = eval_while; - ao_scheme_stack->sexprs = ao_scheme_cons_poly(cons); - return AO_SCHEME_NIL; -} - -static ao_poly -ao_scheme_do_display_or_write(ao_poly proc, struct ao_scheme_cons *cons, bool write) -{ -#ifndef AO_SCHEME_FEATURE_PORT - ao_poly val; - ao_poly port; - - if (!ao_scheme_parse_args(proc, cons, - AO_SCHEME_POLY, &val, - AO_SCHEME_POLY | AO_SCHEME_ARG_OPTIONAL, AO_SCHEME_NIL, &port, - AO_SCHEME_ARG_END)) - return AO_SCHEME_NIL; - ao_scheme_poly_write(stdout, val, write); -#else - ao_poly val; - struct ao_scheme_port *port; - FILE *file = stdout; - - if (!ao_scheme_parse_args(proc, cons, - AO_SCHEME_POLY, &val, - AO_SCHEME_PORT | AO_SCHEME_ARG_OPTIONAL, AO_SCHEME_NIL, &port, - AO_SCHEME_ARG_END)) - return AO_SCHEME_NIL; - if (port) { - file = port->file; - if (!file) - return _ao_scheme_bool_true; - } - ao_scheme_poly_write(file, val, write); -#endif - return _ao_scheme_bool_true; -} - -ao_poly -ao_scheme_do_write(struct ao_scheme_cons *cons) -{ - return ao_scheme_do_display_or_write(_ao_scheme_atom_write, cons, true); -} - -ao_poly -ao_scheme_do_display(struct ao_scheme_cons *cons) -{ - return ao_scheme_do_display_or_write(_ao_scheme_atom_display, cons, false); -} - -static ao_poly -ao_scheme_math(struct ao_scheme_cons *orig_cons, enum ao_scheme_builtin_id op) -{ - struct ao_scheme_cons *cons; - ao_poly ret = AO_SCHEME_NIL; - - for (cons = orig_cons; cons; cons = ao_scheme_cons_cdr(cons)) { - ao_poly car = cons->car; - uint8_t rt = ao_scheme_poly_type(ret); - uint8_t ct = ao_scheme_poly_type(car); - - if (cons == orig_cons) { - ret = car; - ao_scheme_cons_stash(cons); - if (cons->cdr == AO_SCHEME_NIL) { - switch (op) { - case builtin_minus: - if (ao_scheme_integer_typep(ct)) - ret = ao_scheme_integer_poly(-ao_scheme_poly_integer(ret)); -#ifdef AO_SCHEME_FEATURE_FLOAT - else if (ct == AO_SCHEME_FLOAT) - ret = ao_scheme_float_get(-ao_scheme_poly_number(ret)); -#endif - break; - case builtin_divide: - if (ao_scheme_poly_integer(ret) == 1) { - } else { -#ifdef AO_SCHEME_FEATURE_FLOAT - if (ao_scheme_number_typep(ct)) { - float v = ao_scheme_poly_number(ret); - ret = ao_scheme_float_get(1/v); - } -#else - ret = ao_scheme_integer_poly(0); -#endif - } - break; - default: - break; - } - } - cons = ao_scheme_cons_fetch(); - } else if (ao_scheme_integer_typep(rt) && ao_scheme_integer_typep(ct)) { - int32_t r = ao_scheme_poly_integer(ret); - int32_t c = ao_scheme_poly_integer(car); -#ifdef AO_SCHEME_FEATURE_FLOAT - int64_t t; -#endif - - switch(op) { - case builtin_plus: - r += c; - check_overflow: -#ifdef AO_SCHEME_FEATURE_FLOAT - if (r < AO_SCHEME_MIN_BIGINT || AO_SCHEME_MAX_BIGINT < r) - goto inexact; -#endif - break; - case builtin_minus: - r -= c; - goto check_overflow; - break; - case builtin_times: -#ifdef AO_SCHEME_FEATURE_FLOAT - t = (int64_t) r * (int64_t) c; - if (t < AO_SCHEME_MIN_BIGINT || AO_SCHEME_MAX_BIGINT < t) - goto inexact; - r = (int32_t) t; -#else - r = r * c; -#endif - break; - case builtin_divide: -#ifdef AO_SCHEME_FEATURE_FLOAT - if (c != 0 && (r % c) == 0) - r /= c; - else - goto inexact; -#else - r /= c; -#endif - break; - case builtin_quotient: - if (c == 0) - return ao_scheme_error(AO_SCHEME_DIVIDE_BY_ZERO, "quotient by zero"); - r = r / c; - break; - case builtin_floor_quotient: - if (c == 0) - return ao_scheme_error(AO_SCHEME_DIVIDE_BY_ZERO, "floor-quotient by zero"); - if (r % c != 0 && (c < 0) != (r < 0)) - r = r / c - 1; - else - r = r / c; - break; - case builtin_remainder: - if (c == 0) - return ao_scheme_error(AO_SCHEME_DIVIDE_BY_ZERO, "remainder by zero"); - r %= c; - break; - case builtin_modulo: - if (c == 0) - return ao_scheme_error(AO_SCHEME_DIVIDE_BY_ZERO, "modulo by zero"); - r %= c; - if ((r < 0) != (c < 0)) - r += c; - break; - default: - break; - } - ao_scheme_cons_stash(cons); - ret = ao_scheme_integer_poly(r); - cons = ao_scheme_cons_fetch(); -#ifdef AO_SCHEME_FEATURE_FLOAT - } else if (ao_scheme_number_typep(rt) && ao_scheme_number_typep(ct)) { - float r, c; - inexact: - r = ao_scheme_poly_number(ret); - c = ao_scheme_poly_number(car); - switch(op) { - case builtin_plus: - r += c; - break; - case builtin_minus: - r -= c; - break; - case builtin_times: - r *= c; - break; - case builtin_divide: - r /= c; - break; - case builtin_quotient: - case builtin_floor_quotient: - case builtin_remainder: - case builtin_modulo: - return ao_scheme_error(AO_SCHEME_INVALID, "non-integer value in integer divide"); - default: - break; - } - ao_scheme_cons_stash(cons); - ret = ao_scheme_float_get(r); - cons = ao_scheme_cons_fetch(); -#endif - } - else if (rt == AO_SCHEME_STRING && ct == AO_SCHEME_STRING && op == builtin_plus) { - ao_scheme_cons_stash(cons); - ret = ao_scheme_string_poly(ao_scheme_string_cat(ao_scheme_poly_string(ret), - ao_scheme_poly_string(car))); - cons = ao_scheme_cons_fetch(); - if (!ret) - return ret; - } - else - return ao_scheme_error(AO_SCHEME_INVALID, "invalid args"); - } - return ret; -} - -ao_poly -ao_scheme_do_plus(struct ao_scheme_cons *cons) -{ - return ao_scheme_math(cons, builtin_plus); -} - -ao_poly -ao_scheme_do_minus(struct ao_scheme_cons *cons) -{ - return ao_scheme_math(cons, builtin_minus); -} - -ao_poly -ao_scheme_do_times(struct ao_scheme_cons *cons) -{ - return ao_scheme_math(cons, builtin_times); -} - -ao_poly -ao_scheme_do_divide(struct ao_scheme_cons *cons) -{ - return ao_scheme_math(cons, builtin_divide); -} - -ao_poly -ao_scheme_do_quotient(struct ao_scheme_cons *cons) -{ - return ao_scheme_math(cons, builtin_quotient); -} - -ao_poly -ao_scheme_do_floor_quotient(struct ao_scheme_cons *cons) -{ - return ao_scheme_math(cons, builtin_floor_quotient); -} - -ao_poly -ao_scheme_do_modulo(struct ao_scheme_cons *cons) -{ - return ao_scheme_math(cons, builtin_modulo); -} - -ao_poly -ao_scheme_do_remainder(struct ao_scheme_cons *cons) -{ - return ao_scheme_math(cons, builtin_remainder); -} - -static ao_poly -ao_scheme_compare(struct ao_scheme_cons *cons, enum ao_scheme_builtin_id op) -{ - ao_poly left; - - if (!cons) - return _ao_scheme_bool_true; - - left = cons->car; - for (cons = ao_scheme_cons_cdr(cons); cons; cons = ao_scheme_cons_cdr(cons)) { - ao_poly right = cons->car; - - if (op == builtin_equal && left == right) { - ; - } else { - uint8_t lt = ao_scheme_poly_type(left); - uint8_t rt = ao_scheme_poly_type(right); - if (ao_scheme_integer_typep(lt) && ao_scheme_integer_typep(rt)) { - int32_t l = ao_scheme_poly_integer(left); - int32_t r = ao_scheme_poly_integer(right); - - switch (op) { - case builtin_less: - if (!(l < r)) - return _ao_scheme_bool_false; - break; - case builtin_greater: - if (!(l > r)) - return _ao_scheme_bool_false; - break; - case builtin_less_equal: - if (!(l <= r)) - return _ao_scheme_bool_false; - break; - case builtin_greater_equal: - if (!(l >= r)) - return _ao_scheme_bool_false; - break; - case builtin_equal: - if (!(l == r)) - return _ao_scheme_bool_false; - default: - break; - } -#ifdef AO_SCHEME_FEATURE_FLOAT - } else if (ao_scheme_number_typep(lt) && ao_scheme_number_typep(rt)) { - float l, r; - - l = ao_scheme_poly_number(left); - r = ao_scheme_poly_number(right); - - switch (op) { - case builtin_less: - if (!(l < r)) - return _ao_scheme_bool_false; - break; - case builtin_greater: - if (!(l > r)) - return _ao_scheme_bool_false; - break; - case builtin_less_equal: - if (!(l <= r)) - return _ao_scheme_bool_false; - break; - case builtin_greater_equal: - if (!(l >= r)) - return _ao_scheme_bool_false; - break; - case builtin_equal: - if (!(l == r)) - return _ao_scheme_bool_false; - default: - break; - } -#endif /* AO_SCHEME_FEATURE_FLOAT */ - } else if (lt == AO_SCHEME_STRING && rt == AO_SCHEME_STRING) { - int c = strcmp(ao_scheme_poly_string(left)->val, - ao_scheme_poly_string(right)->val); - switch (op) { - case builtin_less: - if (!(c < 0)) - return _ao_scheme_bool_false; - break; - case builtin_greater: - if (!(c > 0)) - return _ao_scheme_bool_false; - break; - case builtin_less_equal: - if (!(c <= 0)) - return _ao_scheme_bool_false; - break; - case builtin_greater_equal: - if (!(c >= 0)) - return _ao_scheme_bool_false; - break; - case builtin_equal: - if (!(c == 0)) - return _ao_scheme_bool_false; - break; - default: - break; - } - } else - return _ao_scheme_bool_false; - } - left = right; - } - return _ao_scheme_bool_true; -} - -ao_poly -ao_scheme_do_equal(struct ao_scheme_cons *cons) -{ - return ao_scheme_compare(cons, builtin_equal); -} - -ao_poly -ao_scheme_do_less(struct ao_scheme_cons *cons) -{ - return ao_scheme_compare(cons, builtin_less); -} - -ao_poly -ao_scheme_do_greater(struct ao_scheme_cons *cons) -{ - return ao_scheme_compare(cons, builtin_greater); -} - -ao_poly -ao_scheme_do_less_equal(struct ao_scheme_cons *cons) -{ - return ao_scheme_compare(cons, builtin_less_equal); -} - -ao_poly -ao_scheme_do_greater_equal(struct ao_scheme_cons *cons) -{ - return ao_scheme_compare(cons, builtin_greater_equal); -} - -ao_poly -ao_scheme_do_flush_output(struct ao_scheme_cons *cons) -{ -#ifndef AO_SCHEME_FEATURE_PORT - ao_poly port; - if (!ao_scheme_parse_args(_ao_scheme_atom_flush2doutput, cons, - AO_SCHEME_POLY|AO_SCHEME_ARG_OPTIONAL, AO_SCHEME_NIL, &port, - AO_SCHEME_ARG_END)) - return AO_SCHEME_NIL; - fflush(stdout); -#else - struct ao_scheme_port *port; - - if (!ao_scheme_parse_args(_ao_scheme_atom_flush2doutput, cons, - AO_SCHEME_PORT|AO_SCHEME_ARG_OPTIONAL, AO_SCHEME_NIL, &port, - AO_SCHEME_ARG_END)) - return AO_SCHEME_NIL; - fflush(stdout); - if (port) { - if (port->file) - fflush(port->file); - } else - fflush(stdout); -#endif - return _ao_scheme_bool_true; -} - -#ifdef AO_SCHEME_FEATURE_GPIO - -ao_poly -ao_scheme_do_led(struct ao_scheme_cons *cons) -{ - int32_t led; - if (!ao_scheme_parse_args(_ao_scheme_atom_led, cons, - AO_SCHEME_INT, &led, - AO_SCHEME_ARG_END)) - return AO_SCHEME_NIL; - ao_scheme_os_led(led); - return _ao_scheme_bool_true; -} - -#endif - -ao_poly -ao_scheme_do_eval(struct ao_scheme_cons *cons) -{ - ao_poly expr; - ao_poly env; - - if (!ao_scheme_parse_args(_ao_scheme_atom_eval, cons, - AO_SCHEME_POLY, &expr, - AO_SCHEME_POLY|AO_SCHEME_ARG_OPTIONAL, AO_SCHEME_NIL, &env, - AO_SCHEME_ARG_END)) - return AO_SCHEME_NIL; - ao_scheme_stack->state = eval_sexpr; - ao_scheme_stack->frame = AO_SCHEME_NIL; - ao_scheme_frame_current = NULL; - return expr; -} - -ao_poly -ao_scheme_do_apply(struct ao_scheme_cons *cons) -{ - ao_scheme_stack->state = eval_apply; - return ao_scheme_cons_poly(cons); -} - -ao_poly -ao_scheme_do_read(struct ao_scheme_cons *cons) -{ - FILE *file = stdin; -#ifndef AO_SCHEME_FEATURE_PORT - ao_poly port; - if (!ao_scheme_parse_args(_ao_scheme_atom_read, cons, - AO_SCHEME_POLY|AO_SCHEME_ARG_OPTIONAL, AO_SCHEME_NIL, &port, - AO_SCHEME_ARG_END)) - return AO_SCHEME_NIL; -#else - struct ao_scheme_port *port; - - if (!ao_scheme_parse_args(_ao_scheme_atom_read, cons, - AO_SCHEME_PORT|AO_SCHEME_ARG_OPTIONAL, AO_SCHEME_NIL, &port, - AO_SCHEME_ARG_END)) - return AO_SCHEME_NIL; - if (port) { - file = port->file; - if (!file) - return _ao_scheme_atom_eof; - } -#endif - return ao_scheme_read(file); -} - -ao_poly -ao_scheme_do_collect(struct ao_scheme_cons *cons) -{ - int free; - (void) cons; - free = ao_scheme_collect(AO_SCHEME_COLLECT_FULL); - return ao_scheme_integer_poly(free); -} - -ao_poly -ao_scheme_do_nullp(struct ao_scheme_cons *cons) -{ - ao_poly val; - - if (!ao_scheme_parse_args(_ao_scheme_atom_not, cons, - AO_SCHEME_POLY, &val, - AO_SCHEME_ARG_END)) - return AO_SCHEME_NIL; - if (val == AO_SCHEME_NIL) - return _ao_scheme_bool_true; - else - return _ao_scheme_bool_false; -} - -ao_poly -ao_scheme_do_not(struct ao_scheme_cons *cons) -{ - ao_poly val; - - if (!ao_scheme_parse_args(_ao_scheme_atom_not, cons, - AO_SCHEME_POLY, &val, - AO_SCHEME_ARG_END)) - return AO_SCHEME_NIL; - if (val == _ao_scheme_bool_false) - return _ao_scheme_bool_true; - else - return _ao_scheme_bool_false; -} - -ao_poly -ao_scheme_do_typep(ao_poly proc, int type, struct ao_scheme_cons *cons) -{ - ao_poly val; - - if (!ao_scheme_parse_args(proc, cons, - AO_SCHEME_POLY, &val, - AO_SCHEME_ARG_END)) - return AO_SCHEME_NIL; - if (ao_scheme_poly_type(val) == type) - return _ao_scheme_bool_true; - return _ao_scheme_bool_false; -} - -ao_poly -ao_scheme_do_procedurep(struct ao_scheme_cons *cons) -{ - ao_poly val; - - if (!ao_scheme_parse_args(_ao_scheme_atom_pair3f, cons, - AO_SCHEME_POLY, &val, - AO_SCHEME_ARG_END)) - return AO_SCHEME_NIL; - switch (ao_scheme_poly_type(val)) { - case AO_SCHEME_BUILTIN: - case AO_SCHEME_LAMBDA: - return _ao_scheme_bool_true; - default: - return _ao_scheme_bool_false; - } -} - -ao_poly -ao_scheme_do_read_char(struct ao_scheme_cons *cons) -{ - int c; -#ifndef AO_SCHEME_FEATURE_PORT - ao_poly port; - if (!ao_scheme_parse_args(_ao_scheme_atom_read2dchar, cons, - AO_SCHEME_POLY|AO_SCHEME_ARG_OPTIONAL, AO_SCHEME_NIL, &port, - AO_SCHEME_ARG_END)) - return AO_SCHEME_NIL; - c = getchar(); -#else - struct ao_scheme_port *port; - - if (!ao_scheme_parse_args(_ao_scheme_atom_read2dchar, cons, - AO_SCHEME_PORT|AO_SCHEME_ARG_OPTIONAL, AO_SCHEME_NIL, &port, - AO_SCHEME_ARG_END)) - return AO_SCHEME_NIL; - if (port) - c = ao_scheme_port_getc(port); - else - c = getchar(); -#endif - if (c == EOF) - return _ao_scheme_atom_eof; - return ao_scheme_integer_poly(c); -} - -ao_poly -ao_scheme_do_write_char(struct ao_scheme_cons *cons) -{ - int32_t c; -#ifndef AO_SCHEME_FEATURE_PORT - ao_poly port; - if (!ao_scheme_parse_args(_ao_scheme_atom_write2dchar, cons, - AO_SCHEME_INT, &c, - AO_SCHEME_POLY|AO_SCHEME_ARG_OPTIONAL, AO_SCHEME_NIL, &port, - AO_SCHEME_ARG_END)) - return AO_SCHEME_NIL; - putchar(c); -#else - struct ao_scheme_port *port; - if (!ao_scheme_parse_args(_ao_scheme_atom_write2dchar, cons, - AO_SCHEME_INT, &c, - AO_SCHEME_PORT|AO_SCHEME_ARG_OPTIONAL, AO_SCHEME_NIL, &port, - AO_SCHEME_ARG_END)) - return AO_SCHEME_NIL; - if (port) - ao_scheme_port_putc(port, c); - else - putchar(c); -#endif - return _ao_scheme_bool_true; -} - -ao_poly -ao_scheme_do_exit(struct ao_scheme_cons *cons) -{ - ao_poly val; - - if (!ao_scheme_parse_args(_ao_scheme_atom_exit, cons, - AO_SCHEME_POLY|AO_SCHEME_ARG_OPTIONAL, _ao_scheme_bool_true, &val, - AO_SCHEME_ARG_END)) - return AO_SCHEME_NIL; - ao_scheme_exception |= AO_SCHEME_EXIT; - return val; -} - -#ifdef AO_SCHEME_FEATURE_TIME - -ao_poly -ao_scheme_do_current_jiffy(struct ao_scheme_cons *cons) -{ - if (!ao_scheme_parse_args(_ao_scheme_atom_current2djiffy, cons, - AO_SCHEME_ARG_END)) - return AO_SCHEME_NIL; - return ao_scheme_integer_poly(ao_scheme_os_jiffy()); -} - -ao_poly -ao_scheme_do_jiffies_per_second(struct ao_scheme_cons *cons) -{ - if (!ao_scheme_parse_args(_ao_scheme_atom_jiffies2dper2dsecond, cons, - AO_SCHEME_ARG_END)) - return AO_SCHEME_NIL; - return ao_scheme_integer_poly(AO_SCHEME_JIFFIES_PER_SECOND); -} - -ao_poly -ao_scheme_do_delay(struct ao_scheme_cons *cons) -{ - int32_t delay; - - if (!ao_scheme_parse_args(_ao_scheme_atom_delay, cons, - AO_SCHEME_INT, &delay, - AO_SCHEME_ARG_END)) - return AO_SCHEME_NIL; - ao_scheme_os_delay(delay); - return cons->car; -} -#endif - -#ifdef AO_SCHEME_FEATURE_POSIX - -#include <unistd.h> - -static char **ao_scheme_argv; - -void -ao_scheme_set_argv(char **argv) -{ - ao_scheme_argv = argv; -} - -ao_poly -ao_scheme_do_command_line(struct ao_scheme_cons *cons) -{ - ao_poly args = AO_SCHEME_NIL; - ao_poly arg; - int i; - - if (!ao_scheme_parse_args(_ao_scheme_atom_command2dline, cons, - AO_SCHEME_ARG_END)) - return AO_SCHEME_NIL; - - for (i = 0; ao_scheme_argv[i]; i++); - - while (--i >= 0) { - ao_scheme_poly_stash(args); - arg = ao_scheme_string_poly(ao_scheme_string_new(ao_scheme_argv[i])); - args = ao_scheme_poly_fetch(); - if (!arg) - return AO_SCHEME_NIL; - args = ao_scheme_cons(arg, args); - if (!args) - return AO_SCHEME_NIL; - } - return args; -} - -ao_poly -ao_scheme_do_get_environment_variables(struct ao_scheme_cons *cons) -{ - ao_poly envs = AO_SCHEME_NIL; - ao_poly env; - int i; - - if (!ao_scheme_parse_args(_ao_scheme_atom_get2denvironment2dvariables, cons, - AO_SCHEME_ARG_END)) - return AO_SCHEME_NIL; - for (i = 0; environ[i]; i++); - - while (--i >= 0) { - ao_scheme_poly_stash(envs); - env = ao_scheme_string_poly(ao_scheme_string_new(environ[i])); - envs = ao_scheme_poly_fetch(); - if (!env) - return AO_SCHEME_NIL; - envs = ao_scheme_cons(env, envs); - if (!envs) - return AO_SCHEME_NIL; - } - return envs; -} - -ao_poly -ao_scheme_do_get_environment_variable(struct ao_scheme_cons *cons) -{ - struct ao_scheme_string *name; - char *val; - - if (!ao_scheme_parse_args(_ao_scheme_atom_get2denvironment2dvariable, cons, - AO_SCHEME_STRING, &name, - AO_SCHEME_ARG_END)) - return AO_SCHEME_NIL; - val = secure_getenv(name->val); - if (!val) - return _ao_scheme_bool_false; - return ao_scheme_string_poly(ao_scheme_string_new(val)); -} - -ao_poly -ao_scheme_do_file_existsp(struct ao_scheme_cons *cons) -{ - struct ao_scheme_string *name; - - if (!ao_scheme_parse_args(_ao_scheme_atom_file2dexists3f, cons, - AO_SCHEME_STRING, &name, - AO_SCHEME_ARG_END)) - return AO_SCHEME_NIL; - if (access(name->val, F_OK) == 0) - return _ao_scheme_bool_true; - return _ao_scheme_bool_false; -} - -ao_poly -ao_scheme_do_delete_file(struct ao_scheme_cons *cons) -{ - struct ao_scheme_string *name; - - if (!ao_scheme_parse_args(_ao_scheme_atom_delete2dfile, cons, - AO_SCHEME_STRING, &name, - AO_SCHEME_ARG_END)) - return AO_SCHEME_NIL; - if (unlink(name->val) == 0) - return _ao_scheme_bool_true; - return _ao_scheme_bool_false; -} - -ao_poly -ao_scheme_do_current_second(struct ao_scheme_cons *cons) -{ - int32_t second; - - if (!ao_scheme_parse_args(_ao_scheme_atom_current2dsecond, cons, - AO_SCHEME_ARG_END)) - return AO_SCHEME_NIL; - second = (int32_t) time(NULL); - return ao_scheme_integer_poly(second); -} - -#endif /* AO_SCHEME_FEATURE_POSIX */ - -#define AO_SCHEME_BUILTIN_FUNCS -#include "ao_scheme_builtin.h" |