X-Git-Url: https://git.gag.com/?p=fw%2Faltos;a=blobdiff_plain;f=src%2Flisp%2Fao_lisp_builtin.c;h=fdca020849177c9d2684bc22cfd91ef2c7c20b0a;hp=d89404dcca93185dac78f8aafb5df98045bff61e;hb=ed6967cef5d82baacafe1c23229f44d58c838326;hpb=2e58b6c380bc6440490c47650fbf11d45b3f2e72 diff --git a/src/lisp/ao_lisp_builtin.c b/src/lisp/ao_lisp_builtin.c index d89404dc..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) @@ -44,15 +46,13 @@ const struct ao_lisp_type ao_lisp_builtin_type = { #define AO_LISP_BUILTIN_CASENAME #include "ao_lisp_builtin.h" -#define _atomn(n) ao_lisp_poly_atom(_atom(n)) - char *ao_lisp_args_name(uint8_t args) { args &= AO_LISP_FUNC_MASK; switch (args) { - case AO_LISP_FUNC_LAMBDA: return _atomn(lambda)->name; - case AO_LISP_FUNC_LEXPR: return _atomn(lexpr)->name; - case AO_LISP_FUNC_NLAMBDA: return _atomn(nlambda)->name; - case AO_LISP_FUNC_MACRO: return _atomn(macro)->name; + 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 "???"; } } @@ -86,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)); @@ -99,7 +99,7 @@ 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); @@ -114,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; } @@ -125,7 +125,7 @@ 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_error(AO_LISP_INVALID, "%s: arg %d invalid type %v", ao_lisp_poly_atom(name)->name, argc, car); return _ao_lisp_bool_true; } @@ -163,17 +163,17 @@ ao_lisp_do_cons(struct ao_lisp_cons *cons) ao_poly 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; } @@ -207,17 +207,28 @@ ao_lisp_do_set(struct ao_lisp_cons *cons) return ao_lisp_atom_set(ao_lisp_arg(cons, 0), ao_lisp_arg(cons, 1)); } +ao_poly +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) { ao_poly name; - if (!ao_lisp_check_argc(_ao_lisp_atom_setq, cons, 2, 2)) + if (!ao_lisp_check_argc(_ao_lisp_atom_set21, cons, 2, 2)) return AO_LISP_NIL; name = cons->car; if (ao_lisp_poly_type(name) != AO_LISP_ATOM) - return ao_lisp_error(AO_LISP_INVALID, "set! of non-atom"); - if (!ao_lisp_atom_ref(ao_lisp_frame_current, name)) - return ao_lisp_error(AO_LISP_INVALID, "atom not defined"); + 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)), @@ -232,9 +243,9 @@ ao_lisp_do_cond(struct ao_lisp_cons *cons) } ao_poly -ao_lisp_do_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; } @@ -248,75 +259,143 @@ ao_lisp_do_while(struct ao_lisp_cons *cons) } ao_poly -ao_lisp_do_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_do_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_mod: + case builtin_remainder: if (c == 0) - return ao_lisp_error(AO_LISP_DIVIDE_BY_ZERO, "mod by zero"); + return ao_lisp_error(AO_LISP_DIVIDE_BY_ZERO, "remainder by zero"); r %= c; break; + case builtin_modulo: + if (c == 0) + 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_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_int_poly(r); + ret = ao_lisp_float_get(r); } else if (rt == AO_LISP_STRING && ct == AO_LISP_STRING && op == builtin_plus) @@ -353,9 +432,21 @@ ao_lisp_do_divide(struct ao_lisp_cons *cons) } ao_poly -ao_lisp_do_mod(struct ao_lisp_cons *cons) +ao_lisp_do_quotient(struct ao_lisp_cons *cons) { - return ao_lisp_math(cons, builtin_mod); + return ao_lisp_math(cons, builtin_quotient); +} + +ao_poly +ao_lisp_do_modulo(struct ao_lisp_cons *cons) +{ + 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 @@ -367,8 +458,7 @@ ao_lisp_compare(struct ao_lisp_cons *cons, enum ao_lisp_builtin_id op) 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) { @@ -377,9 +467,9 @@ ao_lisp_compare(struct ao_lisp_cons *cons, enum ao_lisp_builtin_id op) } 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: @@ -427,7 +517,6 @@ 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_bool_true; } @@ -463,29 +552,29 @@ ao_lisp_do_greater_equal(struct ao_lisp_cons *cons) } ao_poly -ao_lisp_do_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_do_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_do_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_bool_true; @@ -526,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) { @@ -565,6 +663,92 @@ ao_lisp_do_not(struct ao_lisp_cons *cons) 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) { @@ -582,15 +766,104 @@ ao_lisp_do_listp(struct ao_lisp_cons *cons) } ao_poly -ao_lisp_do_pairp(struct ao_lisp_cons *cons) +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) { - 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 (ao_lisp_poly_type(v) == AO_LISP_CONS) - return _ao_lisp_bool_true; - return _ao_lisp_bool_false; + 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