X-Git-Url: https://git.gag.com/?a=blobdiff_plain;f=src%2Flisp%2Fao_lisp_builtin.c;h=fdca020849177c9d2684bc22cfd91ef2c7c20b0a;hb=ed6967cef5d82baacafe1c23229f44d58c838326;hp=902f60e2e9b6f83b355264e875ad865096a1ab48;hpb=d1956000ba2e6260977aa669475d3ff725578b55;p=fw%2Faltos diff --git a/src/lisp/ao_lisp_builtin.c b/src/lisp/ao_lisp_builtin.c index 902f60e2..fdca0208 100644 --- a/src/lisp/ao_lisp_builtin.c +++ b/src/lisp/ao_lisp_builtin.c @@ -13,6 +13,8 @@ */ #include "ao_lisp.h" +#include +#include static int builtin_size(void *addr) @@ -40,61 +42,24 @@ const struct ao_lisp_type ao_lisp_builtin_type = { }; #ifdef AO_LISP_MAKE_CONST -char *ao_lisp_builtin_name(enum ao_lisp_builtin_id b) { - (void) b; - return "???"; -} + +#define AO_LISP_BUILTIN_CASENAME +#include "ao_lisp_builtin.h" + char *ao_lisp_args_name(uint8_t args) { - (void) args; - return "???"; + args &= AO_LISP_FUNC_MASK; + switch (args) { + case AO_LISP_FUNC_LAMBDA: return ao_lisp_poly_atom(_ao_lisp_atom_lambda)->name; + case AO_LISP_FUNC_LEXPR: return ao_lisp_poly_atom(_ao_lisp_atom_lexpr)->name; + case AO_LISP_FUNC_NLAMBDA: return ao_lisp_poly_atom(_ao_lisp_atom_nlambda)->name; + case AO_LISP_FUNC_MACRO: return ao_lisp_poly_atom(_ao_lisp_atom_macro)->name; + default: return "???"; + } } #else -static const ao_poly builtin_names[] = { - [builtin_eval] = _ao_lisp_atom_eval, - [builtin_read] = _ao_lisp_atom_read, - [builtin_lambda] = _ao_lisp_atom_lambda, - [builtin_lexpr] = _ao_lisp_atom_lexpr, - [builtin_nlambda] = _ao_lisp_atom_nlambda, - [builtin_macro] = _ao_lisp_atom_macro, - [builtin_car] = _ao_lisp_atom_car, - [builtin_cdr] = _ao_lisp_atom_cdr, - [builtin_cons] = _ao_lisp_atom_cons, - [builtin_last] = _ao_lisp_atom_last, - [builtin_length] = _ao_lisp_atom_length, - [builtin_quote] = _ao_lisp_atom_quote, - [builtin_set] = _ao_lisp_atom_set, - [builtin_setq] = _ao_lisp_atom_setq, - [builtin_cond] = _ao_lisp_atom_cond, - [builtin_progn] = _ao_lisp_atom_progn, - [builtin_while] = _ao_lisp_atom_while, - [builtin_print] = _ao_lisp_atom_print, - [builtin_patom] = _ao_lisp_atom_patom, - [builtin_plus] = _ao_lisp_atom_2b, - [builtin_minus] = _ao_lisp_atom_2d, - [builtin_times] = _ao_lisp_atom_2a, - [builtin_divide] = _ao_lisp_atom_2f, - [builtin_mod] = _ao_lisp_atom_25, - [builtin_equal] = _ao_lisp_atom_3d, - [builtin_less] = _ao_lisp_atom_3c, - [builtin_greater] = _ao_lisp_atom_3e, - [builtin_less_equal] = _ao_lisp_atom_3c3d, - [builtin_greater_equal] = _ao_lisp_atom_3e3d, - [builtin_pack] = _ao_lisp_atom_pack, - [builtin_unpack] = _ao_lisp_atom_unpack, - [builtin_flush] = _ao_lisp_atom_flush, - [builtin_delay] = _ao_lisp_atom_delay, - [builtin_led] = _ao_lisp_atom_led, - [builtin_save] = _ao_lisp_atom_save, - [builtin_restore] = _ao_lisp_atom_restore, - [builtin_call_cc] = _ao_lisp_atom_call2fcc, - [builtin_collect] = _ao_lisp_atom_collect, -#if 0 - [builtin_symbolp] = _ao_lisp_atom_symbolp, - [builtin_listp] = _ao_lisp_atom_listp, - [builtin_stringp] = _ao_lisp_atom_stringp, - [builtin_numberp] = _ao_lisp_atom_numberp, -#endif -}; + +#define AO_LISP_BUILTIN_ARRAYNAME +#include "ao_lisp_builtin.h" static char * ao_lisp_builtin_name(enum ao_lisp_builtin_id b) { @@ -121,7 +86,7 @@ ao_lisp_args_name(uint8_t args) #endif void -ao_lisp_builtin_print(ao_poly b) +ao_lisp_builtin_write(ao_poly b) { struct ao_lisp_builtin *builtin = ao_lisp_poly_builtin(b); printf("%s", ao_lisp_builtin_name(builtin->func)); @@ -134,11 +99,11 @@ ao_lisp_check_argc(ao_poly name, struct ao_lisp_cons *cons, int min, int max) while (cons && argc <= max) { argc++; - cons = ao_lisp_poly_cons(cons->cdr); + cons = ao_lisp_cons_cdr(cons); } if (argc < min || argc > max) return ao_lisp_error(AO_LISP_INVALID, "%s: invalid arg count", ao_lisp_poly_atom(name)->name); - return _ao_lisp_atom_t; + return _ao_lisp_bool_true; } ao_poly @@ -149,7 +114,7 @@ ao_lisp_arg(struct ao_lisp_cons *cons, int argc) while (argc--) { if (!cons) return AO_LISP_NIL; - cons = ao_lisp_poly_cons(cons->cdr); + cons = ao_lisp_cons_cdr(cons); } return cons->car; } @@ -160,12 +125,12 @@ ao_lisp_check_argt(ao_poly name, struct ao_lisp_cons *cons, int argc, int type, ao_poly car = ao_lisp_arg(cons, argc); if ((!car && !nil_ok) || ao_lisp_poly_type(car) != type) - return ao_lisp_error(AO_LISP_INVALID, "%s: invalid type for arg %d", ao_lisp_poly_atom(name)->name, argc); - return _ao_lisp_atom_t; + return ao_lisp_error(AO_LISP_INVALID, "%s: arg %d invalid type %v", ao_lisp_poly_atom(name)->name, argc, car); + return _ao_lisp_bool_true; } ao_poly -ao_lisp_car(struct ao_lisp_cons *cons) +ao_lisp_do_car(struct ao_lisp_cons *cons) { if (!ao_lisp_check_argc(_ao_lisp_atom_car, cons, 1, 1)) return AO_LISP_NIL; @@ -175,7 +140,7 @@ ao_lisp_car(struct ao_lisp_cons *cons) } ao_poly -ao_lisp_cdr(struct ao_lisp_cons *cons) +ao_lisp_do_cdr(struct ao_lisp_cons *cons) { if (!ao_lisp_check_argc(_ao_lisp_atom_cdr, cons, 1, 1)) return AO_LISP_NIL; @@ -185,38 +150,36 @@ ao_lisp_cdr(struct ao_lisp_cons *cons) } ao_poly -ao_lisp_cons(struct ao_lisp_cons *cons) +ao_lisp_do_cons(struct ao_lisp_cons *cons) { ao_poly car, cdr; if(!ao_lisp_check_argc(_ao_lisp_atom_cons, cons, 2, 2)) return AO_LISP_NIL; - if (!ao_lisp_check_argt(_ao_lisp_atom_cons, cons, 1, AO_LISP_CONS, 1)) - return AO_LISP_NIL; car = ao_lisp_arg(cons, 0); cdr = ao_lisp_arg(cons, 1); - return ao_lisp_cons_poly(ao_lisp_cons_cons(car, ao_lisp_poly_cons(cdr))); + return ao_lisp__cons(car, cdr); } ao_poly -ao_lisp_last(struct ao_lisp_cons *cons) +ao_lisp_do_last(struct ao_lisp_cons *cons) { - ao_poly l; + struct ao_lisp_cons *list; if (!ao_lisp_check_argc(_ao_lisp_atom_last, cons, 1, 1)) return AO_LISP_NIL; if (!ao_lisp_check_argt(_ao_lisp_atom_last, cons, 0, AO_LISP_CONS, 1)) return AO_LISP_NIL; - l = ao_lisp_arg(cons, 0); - while (l) { - struct ao_lisp_cons *list = ao_lisp_poly_cons(l); + for (list = ao_lisp_poly_cons(ao_lisp_arg(cons, 0)); + list; + list = ao_lisp_cons_cdr(list)) + { if (!list->cdr) return list->car; - l = list->cdr; } return AO_LISP_NIL; } ao_poly -ao_lisp_length(struct ao_lisp_cons *cons) +ao_lisp_do_length(struct ao_lisp_cons *cons) { if (!ao_lisp_check_argc(_ao_lisp_atom_length, cons, 1, 1)) return AO_LISP_NIL; @@ -226,7 +189,7 @@ ao_lisp_length(struct ao_lisp_cons *cons) } ao_poly -ao_lisp_quote(struct ao_lisp_cons *cons) +ao_lisp_do_quote(struct ao_lisp_cons *cons) { if (!ao_lisp_check_argc(_ao_lisp_atom_quote, cons, 1, 1)) return AO_LISP_NIL; @@ -234,7 +197,7 @@ ao_lisp_quote(struct ao_lisp_cons *cons) } ao_poly -ao_lisp_set(struct ao_lisp_cons *cons) +ao_lisp_do_set(struct ao_lisp_cons *cons) { if (!ao_lisp_check_argc(_ao_lisp_atom_set, cons, 2, 2)) return AO_LISP_NIL; @@ -245,35 +208,50 @@ ao_lisp_set(struct ao_lisp_cons *cons) } ao_poly -ao_lisp_setq(struct ao_lisp_cons *cons) +ao_lisp_do_def(struct ao_lisp_cons *cons) +{ + if (!ao_lisp_check_argc(_ao_lisp_atom_def, cons, 2, 2)) + return AO_LISP_NIL; + if (!ao_lisp_check_argt(_ao_lisp_atom_def, cons, 0, AO_LISP_ATOM, 0)) + return AO_LISP_NIL; + + return ao_lisp_atom_def(ao_lisp_arg(cons, 0), ao_lisp_arg(cons, 1)); +} + +ao_poly +ao_lisp_do_setq(struct ao_lisp_cons *cons) { - struct ao_lisp_cons *expand = 0; - if (!ao_lisp_check_argc(_ao_lisp_atom_setq, cons, 2, 2)) + ao_poly name; + if (!ao_lisp_check_argc(_ao_lisp_atom_set21, cons, 2, 2)) return AO_LISP_NIL; - expand = ao_lisp_cons_cons(_ao_lisp_atom_set, - ao_lisp_cons_cons(ao_lisp_cons_poly(ao_lisp_cons_cons(_ao_lisp_atom_quote, - ao_lisp_cons_cons(cons->car, NULL))), - ao_lisp_poly_cons(cons->cdr))); - return ao_lisp_cons_poly(expand); + name = cons->car; + if (ao_lisp_poly_type(name) != AO_LISP_ATOM) + return ao_lisp_error(AO_LISP_INVALID, "set! of non-atom %v", name); + if (!ao_lisp_atom_ref(name)) + return ao_lisp_error(AO_LISP_INVALID, "atom %v not defined", name); + return ao_lisp__cons(_ao_lisp_atom_set, + ao_lisp__cons(ao_lisp__cons(_ao_lisp_atom_quote, + ao_lisp__cons(name, AO_LISP_NIL)), + cons->cdr)); } ao_poly -ao_lisp_cond(struct ao_lisp_cons *cons) +ao_lisp_do_cond(struct ao_lisp_cons *cons) { ao_lisp_set_cond(cons); return AO_LISP_NIL; } ao_poly -ao_lisp_progn(struct ao_lisp_cons *cons) +ao_lisp_do_begin(struct ao_lisp_cons *cons) { - ao_lisp_stack->state = eval_progn; + ao_lisp_stack->state = eval_begin; ao_lisp_stack->sexprs = ao_lisp_cons_poly(cons); return AO_LISP_NIL; } ao_poly -ao_lisp_while(struct ao_lisp_cons *cons) +ao_lisp_do_while(struct ao_lisp_cons *cons) { ao_lisp_stack->state = eval_while; ao_lisp_stack->sexprs = ao_lisp_cons_poly(cons); @@ -281,75 +259,143 @@ ao_lisp_while(struct ao_lisp_cons *cons) } ao_poly -ao_lisp_print(struct ao_lisp_cons *cons) +ao_lisp_do_write(struct ao_lisp_cons *cons) { ao_poly val = AO_LISP_NIL; while (cons) { val = cons->car; - ao_lisp_poly_print(val); - cons = ao_lisp_poly_cons(cons->cdr); + ao_lisp_poly_write(val); + cons = ao_lisp_cons_cdr(cons); if (cons) printf(" "); } printf("\n"); - return val; + return _ao_lisp_bool_true; } ao_poly -ao_lisp_patom(struct ao_lisp_cons *cons) +ao_lisp_do_display(struct ao_lisp_cons *cons) { ao_poly val = AO_LISP_NIL; while (cons) { val = cons->car; - ao_lisp_poly_patom(val); - cons = ao_lisp_poly_cons(cons->cdr); + ao_lisp_poly_display(val); + cons = ao_lisp_cons_cdr(cons); } - return val; + return _ao_lisp_bool_true; } ao_poly -ao_lisp_math(struct ao_lisp_cons *cons, enum ao_lisp_builtin_id op) +ao_lisp_math(struct ao_lisp_cons *orig_cons, enum ao_lisp_builtin_id op) { + struct ao_lisp_cons *cons = cons; ao_poly ret = AO_LISP_NIL; - while (cons) { + for (cons = orig_cons; cons; cons = ao_lisp_cons_cdr(cons)) { ao_poly car = cons->car; uint8_t rt = ao_lisp_poly_type(ret); uint8_t ct = ao_lisp_poly_type(car); - cons = ao_lisp_poly_cons(cons->cdr); - - if (rt == AO_LISP_NIL) + if (cons == orig_cons) { ret = car; - - else if (rt == AO_LISP_INT && ct == AO_LISP_INT) { - int r = ao_lisp_poly_int(ret); - int c = ao_lisp_poly_int(car); + if (cons->cdr == AO_LISP_NIL) { + switch (op) { + case builtin_minus: + if (ao_lisp_integer_typep(ct)) + ret = ao_lisp_integer_poly(-ao_lisp_poly_integer(ret)); + else if (ct == AO_LISP_FLOAT) + ret = ao_lisp_float_get(-ao_lisp_poly_number(ret)); + break; + case builtin_divide: + if (ao_lisp_integer_typep(ct) && ao_lisp_poly_integer(ret) == 1) + ; + else if (ao_lisp_number_typep(ct)) { + float v = ao_lisp_poly_number(ret); + ret = ao_lisp_float_get(1/v); + } + break; + default: + break; + } + } + } else if (ao_lisp_integer_typep(rt) && ao_lisp_integer_typep(ct)) { + int32_t r = ao_lisp_poly_integer(ret); + int32_t c = ao_lisp_poly_integer(car); + int64_t t; switch(op) { case builtin_plus: r += c; + check_overflow: + if (r < AO_LISP_MIN_BIGINT || AO_LISP_MAX_BIGINT < r) + goto inexact; break; case builtin_minus: r -= c; + goto check_overflow; break; case builtin_times: - r *= c; + t = (int64_t) r * (int64_t) c; + if (t < AO_LISP_MIN_BIGINT || AO_LISP_MAX_BIGINT < t) + goto inexact; + r = (int32_t) t; break; case builtin_divide: + if (c != 0 && (r % c) == 0) + r /= c; + else + goto inexact; + break; + case builtin_quotient: if (c == 0) - return ao_lisp_error(AO_LISP_DIVIDE_BY_ZERO, "divide by zero"); - r /= c; + return ao_lisp_error(AO_LISP_DIVIDE_BY_ZERO, "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_lisp_error(AO_LISP_DIVIDE_BY_ZERO, "remainder by zero"); + r %= c; break; - case builtin_mod: + case builtin_modulo: if (c == 0) - return ao_lisp_error(AO_LISP_DIVIDE_BY_ZERO, "mod by zero"); + return ao_lisp_error(AO_LISP_DIVIDE_BY_ZERO, "modulo by zero"); r %= c; + if ((r < 0) != (c < 0)) + r += c; break; default: break; } - ret = ao_lisp_int_poly(r); + ret = ao_lisp_integer_poly(r); + } else if (ao_lisp_number_typep(rt) && ao_lisp_number_typep(ct)) { + float r, c; + inexact: + r = ao_lisp_poly_number(ret); + c = ao_lisp_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_remainder: + case builtin_modulo: + return ao_lisp_error(AO_LISP_INVALID, "non-integer value in integer divide"); + default: + break; + } + ret = ao_lisp_float_get(r); } else if (rt == AO_LISP_STRING && ct == AO_LISP_STRING && op == builtin_plus) @@ -362,33 +408,45 @@ ao_lisp_math(struct ao_lisp_cons *cons, enum ao_lisp_builtin_id op) } ao_poly -ao_lisp_plus(struct ao_lisp_cons *cons) +ao_lisp_do_plus(struct ao_lisp_cons *cons) { return ao_lisp_math(cons, builtin_plus); } ao_poly -ao_lisp_minus(struct ao_lisp_cons *cons) +ao_lisp_do_minus(struct ao_lisp_cons *cons) { return ao_lisp_math(cons, builtin_minus); } ao_poly -ao_lisp_times(struct ao_lisp_cons *cons) +ao_lisp_do_times(struct ao_lisp_cons *cons) { return ao_lisp_math(cons, builtin_times); } ao_poly -ao_lisp_divide(struct ao_lisp_cons *cons) +ao_lisp_do_divide(struct ao_lisp_cons *cons) { return ao_lisp_math(cons, builtin_divide); } ao_poly -ao_lisp_mod(struct ao_lisp_cons *cons) +ao_lisp_do_quotient(struct ao_lisp_cons *cons) +{ + return ao_lisp_math(cons, builtin_quotient); +} + +ao_poly +ao_lisp_do_modulo(struct ao_lisp_cons *cons) { - return ao_lisp_math(cons, builtin_mod); + return ao_lisp_math(cons, builtin_modulo); +} + +ao_poly +ao_lisp_do_remainder(struct ao_lisp_cons *cons) +{ + return ao_lisp_math(cons, builtin_remainder); } ao_poly @@ -397,39 +455,38 @@ ao_lisp_compare(struct ao_lisp_cons *cons, enum ao_lisp_builtin_id op) ao_poly left; if (!cons) - return _ao_lisp_atom_t; + return _ao_lisp_bool_true; left = cons->car; - cons = ao_lisp_poly_cons(cons->cdr); - while (cons) { + for (cons = ao_lisp_cons_cdr(cons); cons; cons = ao_lisp_cons_cdr(cons)) { ao_poly right = cons->car; if (op == builtin_equal) { if (left != right) - return AO_LISP_NIL; + return _ao_lisp_bool_false; } else { uint8_t lt = ao_lisp_poly_type(left); uint8_t rt = ao_lisp_poly_type(right); - if (lt == AO_LISP_INT && rt == AO_LISP_INT) { - int l = ao_lisp_poly_int(left); - int r = ao_lisp_poly_int(right); + if (ao_lisp_integer_typep(lt) && ao_lisp_integer_typep(rt)) { + int32_t l = ao_lisp_poly_integer(left); + int32_t r = ao_lisp_poly_integer(right); switch (op) { case builtin_less: if (!(l < r)) - return AO_LISP_NIL; + return _ao_lisp_bool_false; break; case builtin_greater: if (!(l > r)) - return AO_LISP_NIL; + return _ao_lisp_bool_false; break; case builtin_less_equal: if (!(l <= r)) - return AO_LISP_NIL; + return _ao_lisp_bool_false; break; case builtin_greater_equal: if (!(l >= r)) - return AO_LISP_NIL; + return _ao_lisp_bool_false; break; default: break; @@ -440,19 +497,19 @@ ao_lisp_compare(struct ao_lisp_cons *cons, enum ao_lisp_builtin_id op) switch (op) { case builtin_less: if (!(c < 0)) - return AO_LISP_NIL; + return _ao_lisp_bool_false; break; case builtin_greater: if (!(c > 0)) - return AO_LISP_NIL; + return _ao_lisp_bool_false; break; case builtin_less_equal: if (!(c <= 0)) - return AO_LISP_NIL; + return _ao_lisp_bool_false; break; case builtin_greater_equal: if (!(c >= 0)) - return AO_LISP_NIL; + return _ao_lisp_bool_false; break; default: break; @@ -460,72 +517,71 @@ ao_lisp_compare(struct ao_lisp_cons *cons, enum ao_lisp_builtin_id op) } } left = right; - cons = ao_lisp_poly_cons(cons->cdr); } - return _ao_lisp_atom_t; + return _ao_lisp_bool_true; } ao_poly -ao_lisp_equal(struct ao_lisp_cons *cons) +ao_lisp_do_equal(struct ao_lisp_cons *cons) { return ao_lisp_compare(cons, builtin_equal); } ao_poly -ao_lisp_less(struct ao_lisp_cons *cons) +ao_lisp_do_less(struct ao_lisp_cons *cons) { return ao_lisp_compare(cons, builtin_less); } ao_poly -ao_lisp_greater(struct ao_lisp_cons *cons) +ao_lisp_do_greater(struct ao_lisp_cons *cons) { return ao_lisp_compare(cons, builtin_greater); } ao_poly -ao_lisp_less_equal(struct ao_lisp_cons *cons) +ao_lisp_do_less_equal(struct ao_lisp_cons *cons) { return ao_lisp_compare(cons, builtin_less_equal); } ao_poly -ao_lisp_greater_equal(struct ao_lisp_cons *cons) +ao_lisp_do_greater_equal(struct ao_lisp_cons *cons) { return ao_lisp_compare(cons, builtin_greater_equal); } ao_poly -ao_lisp_pack(struct ao_lisp_cons *cons) +ao_lisp_do_list_to_string(struct ao_lisp_cons *cons) { - if (!ao_lisp_check_argc(_ao_lisp_atom_pack, cons, 1, 1)) + if (!ao_lisp_check_argc(_ao_lisp_atom_list2d3estring, cons, 1, 1)) return AO_LISP_NIL; - if (!ao_lisp_check_argt(_ao_lisp_atom_pack, cons, 0, AO_LISP_CONS, 1)) + if (!ao_lisp_check_argt(_ao_lisp_atom_list2d3estring, cons, 0, AO_LISP_CONS, 1)) return AO_LISP_NIL; return ao_lisp_string_pack(ao_lisp_poly_cons(ao_lisp_arg(cons, 0))); } ao_poly -ao_lisp_unpack(struct ao_lisp_cons *cons) +ao_lisp_do_string_to_list(struct ao_lisp_cons *cons) { - if (!ao_lisp_check_argc(_ao_lisp_atom_unpack, cons, 1, 1)) + if (!ao_lisp_check_argc(_ao_lisp_atom_string2d3elist, cons, 1, 1)) return AO_LISP_NIL; - if (!ao_lisp_check_argt(_ao_lisp_atom_unpack, cons, 0, AO_LISP_STRING, 0)) + if (!ao_lisp_check_argt(_ao_lisp_atom_string2d3elist, cons, 0, AO_LISP_STRING, 0)) return AO_LISP_NIL; return ao_lisp_string_unpack(ao_lisp_poly_string(ao_lisp_arg(cons, 0))); } ao_poly -ao_lisp_flush(struct ao_lisp_cons *cons) +ao_lisp_do_flush_output(struct ao_lisp_cons *cons) { - if (!ao_lisp_check_argc(_ao_lisp_atom_flush, cons, 0, 0)) + if (!ao_lisp_check_argc(_ao_lisp_atom_flush2doutput, cons, 0, 0)) return AO_LISP_NIL; ao_lisp_os_flush(); - return _ao_lisp_atom_t; + return _ao_lisp_bool_true; } ao_poly -ao_lisp_led(struct ao_lisp_cons *cons) +ao_lisp_do_led(struct ao_lisp_cons *cons) { ao_poly led; if (!ao_lisp_check_argc(_ao_lisp_atom_led, cons, 1, 1)) @@ -538,7 +594,7 @@ ao_lisp_led(struct ao_lisp_cons *cons) } ao_poly -ao_lisp_delay(struct ao_lisp_cons *cons) +ao_lisp_do_delay(struct ao_lisp_cons *cons) { ao_poly delay; if (!ao_lisp_check_argc(_ao_lisp_atom_led, cons, 1, 1)) @@ -559,6 +615,15 @@ ao_lisp_do_eval(struct ao_lisp_cons *cons) return cons->car; } +ao_poly +ao_lisp_do_apply(struct ao_lisp_cons *cons) +{ + if (!ao_lisp_check_argc(_ao_lisp_atom_apply, cons, 2, INT_MAX)) + return AO_LISP_NIL; + ao_lisp_stack->state = eval_apply; + return ao_lisp_cons_poly(cons); +} + ao_poly ao_lisp_do_read(struct ao_lisp_cons *cons) { @@ -576,44 +641,230 @@ ao_lisp_do_collect(struct ao_lisp_cons *cons) return ao_lisp_int_poly(free); } -const ao_lisp_func_t ao_lisp_builtins[] = { - [builtin_eval] = ao_lisp_do_eval, - [builtin_read] = ao_lisp_do_read, - [builtin_lambda] = ao_lisp_lambda, - [builtin_lexpr] = ao_lisp_lexpr, - [builtin_nlambda] = ao_lisp_nlambda, - [builtin_macro] = ao_lisp_macro, - [builtin_car] = ao_lisp_car, - [builtin_cdr] = ao_lisp_cdr, - [builtin_cons] = ao_lisp_cons, - [builtin_last] = ao_lisp_last, - [builtin_length] = ao_lisp_length, - [builtin_quote] = ao_lisp_quote, - [builtin_set] = ao_lisp_set, - [builtin_setq] = ao_lisp_setq, - [builtin_cond] = ao_lisp_cond, - [builtin_progn] = ao_lisp_progn, - [builtin_while] = ao_lisp_while, - [builtin_print] = ao_lisp_print, - [builtin_patom] = ao_lisp_patom, - [builtin_plus] = ao_lisp_plus, - [builtin_minus] = ao_lisp_minus, - [builtin_times] = ao_lisp_times, - [builtin_divide] = ao_lisp_divide, - [builtin_mod] = ao_lisp_mod, - [builtin_equal] = ao_lisp_equal, - [builtin_less] = ao_lisp_less, - [builtin_greater] = ao_lisp_greater, - [builtin_less_equal] = ao_lisp_less_equal, - [builtin_greater_equal] = ao_lisp_greater_equal, - [builtin_pack] = ao_lisp_pack, - [builtin_unpack] = ao_lisp_unpack, - [builtin_flush] = ao_lisp_flush, - [builtin_led] = ao_lisp_led, - [builtin_delay] = ao_lisp_delay, - [builtin_save] = ao_lisp_save, - [builtin_restore] = ao_lisp_restore, - [builtin_call_cc] = ao_lisp_call_cc, - [builtin_collect] = ao_lisp_do_collect, -}; +ao_poly +ao_lisp_do_nullp(struct ao_lisp_cons *cons) +{ + if (!ao_lisp_check_argc(_ao_lisp_atom_led, cons, 1, 1)) + return AO_LISP_NIL; + if (ao_lisp_arg(cons, 0) == AO_LISP_NIL) + return _ao_lisp_bool_true; + else + return _ao_lisp_bool_false; +} + +ao_poly +ao_lisp_do_not(struct ao_lisp_cons *cons) +{ + if (!ao_lisp_check_argc(_ao_lisp_atom_led, cons, 1, 1)) + return AO_LISP_NIL; + if (ao_lisp_arg(cons, 0) == _ao_lisp_bool_false) + return _ao_lisp_bool_true; + else + return _ao_lisp_bool_false; +} + +static ao_poly +ao_lisp_do_typep(int type, struct ao_lisp_cons *cons) +{ + if (!ao_lisp_check_argc(_ao_lisp_atom_led, cons, 1, 1)) + return AO_LISP_NIL; + if (ao_lisp_poly_type(ao_lisp_arg(cons, 0)) == type) + return _ao_lisp_bool_true; + return _ao_lisp_bool_false; +} + +ao_poly +ao_lisp_do_pairp(struct ao_lisp_cons *cons) +{ + ao_poly v; + if (!ao_lisp_check_argc(_ao_lisp_atom_led, cons, 1, 1)) + return AO_LISP_NIL; + v = ao_lisp_arg(cons, 0); + if (v != AO_LISP_NIL && ao_lisp_poly_type(v) == AO_LISP_CONS) + return _ao_lisp_bool_true; + return _ao_lisp_bool_false; +} + +ao_poly +ao_lisp_do_integerp(struct ao_lisp_cons *cons) +{ + if (!ao_lisp_check_argc(_ao_lisp_atom_led, cons, 1, 1)) + return AO_LISP_NIL; + switch (ao_lisp_poly_type(ao_lisp_arg(cons, 0))) { + case AO_LISP_INT: + case AO_LISP_BIGINT: + return _ao_lisp_bool_true; + default: + return _ao_lisp_bool_false; + } +} + +ao_poly +ao_lisp_do_numberp(struct ao_lisp_cons *cons) +{ + if (!ao_lisp_check_argc(_ao_lisp_atom_led, cons, 1, 1)) + return AO_LISP_NIL; + switch (ao_lisp_poly_type(ao_lisp_arg(cons, 0))) { + case AO_LISP_INT: + case AO_LISP_BIGINT: + case AO_LISP_FLOAT: + return _ao_lisp_bool_true; + default: + return _ao_lisp_bool_false; + } +} + +ao_poly +ao_lisp_do_stringp(struct ao_lisp_cons *cons) +{ + return ao_lisp_do_typep(AO_LISP_STRING, cons); +} + +ao_poly +ao_lisp_do_symbolp(struct ao_lisp_cons *cons) +{ + return ao_lisp_do_typep(AO_LISP_ATOM, cons); +} + +ao_poly +ao_lisp_do_booleanp(struct ao_lisp_cons *cons) +{ + return ao_lisp_do_typep(AO_LISP_BOOL, cons); +} + +ao_poly +ao_lisp_do_procedurep(struct ao_lisp_cons *cons) +{ + if (!ao_lisp_check_argc(_ao_lisp_atom_led, cons, 1, 1)) + return AO_LISP_NIL; + switch (ao_lisp_poly_type(ao_lisp_arg(cons, 0))) { + case AO_LISP_BUILTIN: + case AO_LISP_LAMBDA: + return _ao_lisp_bool_true; + default: + return _ao_lisp_bool_false; + } +} + +/* This one is special -- a list is either nil or + * a 'proper' list with only cons cells + */ +ao_poly +ao_lisp_do_listp(struct ao_lisp_cons *cons) +{ + ao_poly v; + if (!ao_lisp_check_argc(_ao_lisp_atom_led, cons, 1, 1)) + return AO_LISP_NIL; + v = ao_lisp_arg(cons, 0); + for (;;) { + if (v == AO_LISP_NIL) + return _ao_lisp_bool_true; + if (ao_lisp_poly_type(v) != AO_LISP_CONS) + return _ao_lisp_bool_false; + v = ao_lisp_poly_cons(v)->cdr; + } +} + +ao_poly +ao_lisp_do_set_car(struct ao_lisp_cons *cons) +{ + if (!ao_lisp_check_argc(_ao_lisp_atom_led, cons, 2, 2)) + return AO_LISP_NIL; + if (!ao_lisp_check_argt(_ao_lisp_atom_led, cons, 0, AO_LISP_CONS, 0)) + return AO_LISP_NIL; + return ao_lisp_poly_cons(ao_lisp_arg(cons, 0))->car = ao_lisp_arg(cons, 1); +} + +ao_poly +ao_lisp_do_set_cdr(struct ao_lisp_cons *cons) +{ + if (!ao_lisp_check_argc(_ao_lisp_atom_led, cons, 2, 2)) + return AO_LISP_NIL; + if (!ao_lisp_check_argt(_ao_lisp_atom_led, cons, 0, AO_LISP_CONS, 0)) + return AO_LISP_NIL; + return ao_lisp_poly_cons(ao_lisp_arg(cons, 0))->cdr = ao_lisp_arg(cons, 1); +} + +ao_poly +ao_lisp_do_symbol_to_string(struct ao_lisp_cons *cons) +{ + if (!ao_lisp_check_argc(_ao_lisp_atom_led, cons, 1, 1)) + return AO_LISP_NIL; + if (!ao_lisp_check_argt(_ao_lisp_atom_led, cons, 0, AO_LISP_ATOM, 0)) + return AO_LISP_NIL; + return ao_lisp_string_poly(ao_lisp_string_copy(ao_lisp_poly_atom(ao_lisp_arg(cons, 0))->name)); +} + +ao_poly +ao_lisp_do_string_to_symbol(struct ao_lisp_cons *cons) +{ + if (!ao_lisp_check_argc(_ao_lisp_atom_led, cons, 1, 1)) + return AO_LISP_NIL; + if (!ao_lisp_check_argt(_ao_lisp_atom_led, cons, 0, AO_LISP_STRING, 0)) + return AO_LISP_NIL; + + return ao_lisp_atom_poly(ao_lisp_atom_intern(ao_lisp_poly_string(ao_lisp_arg(cons, 0)))); +} + +ao_poly +ao_lisp_do_read_char(struct ao_lisp_cons *cons) +{ + int c; + if (!ao_lisp_check_argc(_ao_lisp_atom_led, cons, 0, 0)) + return AO_LISP_NIL; + c = getchar(); + return ao_lisp_int_poly(c); +} + +ao_poly +ao_lisp_do_write_char(struct ao_lisp_cons *cons) +{ + if (!ao_lisp_check_argc(_ao_lisp_atom_led, cons, 1, 1)) + return AO_LISP_NIL; + if (!ao_lisp_check_argt(_ao_lisp_atom_led, cons, 0, AO_LISP_INT, 0)) + return AO_LISP_NIL; + putchar(ao_lisp_poly_integer(ao_lisp_arg(cons, 0))); + return _ao_lisp_bool_true; +} + +ao_poly +ao_lisp_do_exit(struct ao_lisp_cons *cons) +{ + if (!ao_lisp_check_argc(_ao_lisp_atom_led, cons, 0, 0)) + return AO_LISP_NIL; + ao_lisp_exception |= AO_LISP_EXIT; + return _ao_lisp_bool_true; +} + +ao_poly +ao_lisp_do_current_jiffy(struct ao_lisp_cons *cons) +{ + int jiffy; + + if (!ao_lisp_check_argc(_ao_lisp_atom_led, cons, 0, 0)) + return AO_LISP_NIL; + jiffy = ao_lisp_os_jiffy(); + return (ao_lisp_int_poly(jiffy)); +} + +ao_poly +ao_lisp_do_current_second(struct ao_lisp_cons *cons) +{ + int second; + + if (!ao_lisp_check_argc(_ao_lisp_atom_led, cons, 0, 0)) + return AO_LISP_NIL; + second = ao_lisp_os_jiffy() / AO_LISP_JIFFIES_PER_SECOND; + return (ao_lisp_int_poly(second)); +} + +ao_poly +ao_lisp_do_jiffies_per_second(struct ao_lisp_cons *cons) +{ + if (!ao_lisp_check_argc(_ao_lisp_atom_led, cons, 0, 0)) + return AO_LISP_NIL; + return (ao_lisp_int_poly(AO_LISP_JIFFIES_PER_SECOND)); +} +#define AO_LISP_BUILTIN_FUNCS +#include "ao_lisp_builtin.h"