From e1acf5eb12aceda7aa838df031c1da1129d0fa5d Mon Sep 17 00:00:00 2001 From: Keith Packard Date: Fri, 17 Nov 2017 22:14:19 -0800 Subject: [PATCH] altos/lisp: Add apply And all of the library routines that use it, map, string-map and friends. Signed-off-by: Keith Packard --- src/lisp/ao_lisp.h | 7 ++- src/lisp/ao_lisp_builtin.c | 40 ++++++++++--- src/lisp/ao_lisp_builtin.txt | 106 +++++++++++++++++----------------- src/lisp/ao_lisp_cons.c | 30 +++++++--- src/lisp/ao_lisp_const.lisp | 74 ++++++++++++++++++++---- src/lisp/ao_lisp_eval.c | 57 ++++++++++++++---- src/lisp/ao_lisp_make_builtin | 14 ++--- src/lisp/ao_lisp_read.c | 2 +- 8 files changed, 230 insertions(+), 100 deletions(-) diff --git a/src/lisp/ao_lisp.h b/src/lisp/ao_lisp.h index 77a94cf1..a445dddd 100644 --- a/src/lisp/ao_lisp.h +++ b/src/lisp/ao_lisp.h @@ -54,14 +54,14 @@ extern uint8_t ao_lisp_const[AO_LISP_POOL_CONST] __attribute__((aligned(4))); #define ao_lisp_pool ao_lisp_const #define AO_LISP_POOL AO_LISP_POOL_CONST -#define _atom(n) ao_lisp_atom_poly(ao_lisp_atom_intern(#n)) +#define _atom(n) ao_lisp_atom_poly(ao_lisp_atom_intern(n)) #define _bool(v) ao_lisp_bool_poly(ao_lisp_bool_get(v)) #define _ao_lisp_bool_true _bool(1) #define _ao_lisp_bool_false _bool(0) -#define _ao_lisp_atom_eof _atom(eof) -#define _ao_lisp_atom_else _atom(else) +#define _ao_lisp_atom_eof _atom("eof") +#define _ao_lisp_atom_else _atom("else") #define AO_LISP_BUILTIN_ATOMS #include "ao_lisp_builtin.h" @@ -184,6 +184,7 @@ enum eval_state { eval_val, /* Value computed */ eval_formal, /* Formal computed */ eval_exec, /* Start a lambda evaluation */ + eval_apply, /* Execute apply */ eval_cond, /* Start next cond clause */ eval_cond_test, /* Check cond condition */ eval_progn, /* Start next progn entry */ diff --git a/src/lisp/ao_lisp_builtin.c b/src/lisp/ao_lisp_builtin.c index b2941d58..d37d0284 100644 --- a/src/lisp/ao_lisp_builtin.c +++ b/src/lisp/ao_lisp_builtin.c @@ -13,6 +13,7 @@ */ #include "ao_lisp.h" +#include static int builtin_size(void *addr) @@ -44,15 +45,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 "???"; } } @@ -282,6 +281,7 @@ ao_lisp_math(struct ao_lisp_cons *cons, enum ao_lisp_builtin_id op) while (cons) { ao_poly car = cons->car; + ao_poly cdr; uint8_t rt = ao_lisp_poly_type(ret); uint8_t ct = ao_lisp_poly_type(car); @@ -358,7 +358,10 @@ ao_lisp_math(struct ao_lisp_cons *cons, enum ao_lisp_builtin_id op) else return ao_lisp_error(AO_LISP_INVALID, "invalid args"); - cons = ao_lisp_poly_cons(cons->cdr); + cdr = cons->cdr; + if (cdr != AO_LISP_NIL && ao_lisp_poly_type(cdr) != AO_LISP_CONS) + return ao_lisp_error(AO_LISP_INVALID, "improper list"); + cons = ao_lisp_poly_cons(cdr); } return ret; } @@ -573,6 +576,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) { @@ -652,6 +664,20 @@ 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 */ diff --git a/src/lisp/ao_lisp_builtin.txt b/src/lisp/ao_lisp_builtin.txt index 6cb4fdae..ba6455ab 100644 --- a/src/lisp/ao_lisp_builtin.txt +++ b/src/lisp/ao_lisp_builtin.txt @@ -1,52 +1,54 @@ -lambda eval -lambda read -nlambda lambda -nlambda lexpr -nlambda nlambda -nlambda macro -lambda car -lambda cdr -lambda cons -lambda last -lambda length -nlambda quote -lambda set -macro setq set! -nlambda cond -nlambda progn -nlambda while -lexpr print -lexpr patom -lexpr plus + -lexpr minus - -lexpr times * -lexpr divide / -lexpr modulo modulo % -lexpr remainder -lexpr quotient -lexpr equal = eq? eqv? -lexpr less < -lexpr greater > -lexpr less_equal <= -lexpr greater_equal >= -lambda list_to_string list->string -lambda string_to_list string->list -lambda flush -lambda delay -lexpr led -lambda save -lambda restore -lambda call_cc call/cc -lambda collect -lambda nullp null? -lambda not -lambda listp list? -lambda pairp pair? -lambda numberp number? integer? -lambda booleanp boolean? -lambda set_car set-car! -lambda set_cdr set-cdr! -lambda symbolp symbol? -lambda symbol_to_string symbol->string -lambda string_to_symbol string->symbol -lambda stringp string? +f_lambda eval +f_lambda read +nlambda lambda +nlambda lexpr +nlambda nlambda +nlambda macro +f_lambda car +f_lambda cdr +f_lambda cons +f_lambda last +f_lambda length +nlambda quote +f_lambda set +macro setq set! +nlambda cond +nlambda progn +nlambda while +f_lexpr print +f_lexpr patom +f_lexpr plus + +f_lexpr minus - +f_lexpr times * +f_lexpr divide / +f_lexpr modulo modulo % +f_lexpr remainder +f_lexpr quotient +f_lexpr equal = eq? eqv? +f_lexpr less < +f_lexpr greater > +f_lexpr less_equal <= +f_lexpr greater_equal >= +f_lambda list_to_string list->string +f_lambda string_to_list string->list +f_lambda flush +f_lambda delay +f_lexpr led +f_lambda save +f_lambda restore +f_lambda call_cc call-with-current-continuation call/cc +f_lambda collect +f_lambda nullp null? +f_lambda not +f_lambda listp list? +f_lambda pairp pair? +f_lambda numberp number? integer? +f_lambda booleanp boolean? +f_lambda set_car set-car! +f_lambda set_cdr set-cdr! +f_lambda symbolp symbol? +f_lambda symbol_to_string symbol->string +f_lambda string_to_symbol string->symbol +f_lambda stringp string? +f_lambda procedurep procedure? +lexpr apply diff --git a/src/lisp/ao_lisp_cons.c b/src/lisp/ao_lisp_cons.c index 81a16a7a..8d607372 100644 --- a/src/lisp/ao_lisp_cons.c +++ b/src/lisp/ao_lisp_cons.c @@ -19,10 +19,16 @@ static void cons_mark(void *addr) struct ao_lisp_cons *cons = addr; for (;;) { + ao_poly cdr = cons->cdr; + ao_lisp_poly_mark(cons->car, 1); - cons = ao_lisp_poly_cons(cons->cdr); - if (!cons) + if (!cdr) break; + if (ao_lisp_poly_type(cdr) != AO_LISP_CONS) { + ao_lisp_poly_mark(cdr, 1); + break; + } + cons = ao_lisp_poly_cons(cdr); if (ao_lisp_mark_memory(&ao_lisp_cons_type, cons)) break; } @@ -42,23 +48,29 @@ static void cons_move(void *addr) return; for (;;) { - struct ao_lisp_cons *cdr; - int ret; + ao_poly cdr; + struct ao_lisp_cons *c; + int ret; MDBG_MOVE("cons_move start %d (%d, %d)\n", MDBG_OFFSET(cons), MDBG_OFFSET(ao_lisp_ref(cons->car)), MDBG_OFFSET(ao_lisp_ref(cons->cdr))); (void) ao_lisp_poly_move(&cons->car, 1); - cdr = ao_lisp_poly_cons(cons->cdr); + cdr = cons->cdr; if (!cdr) break; - ret = ao_lisp_move_memory(&ao_lisp_cons_type, (void **) &cdr); - if (cdr != ao_lisp_poly_cons(cons->cdr)) - cons->cdr = ao_lisp_cons_poly(cdr); + if (ao_lisp_poly_type(cdr) != AO_LISP_CONS) { + (void) ao_lisp_poly_move(&cons->cdr, 1); + break; + } + c = ao_lisp_poly_cons(cdr); + ret = ao_lisp_move_memory(&ao_lisp_cons_type, (void **) &c); + if (c != ao_lisp_poly_cons(cons->cdr)) + cons->cdr = ao_lisp_cons_poly(c); MDBG_MOVE("cons_move end %d (%d, %d)\n", MDBG_OFFSET(cons), MDBG_OFFSET(ao_lisp_ref(cons->car)), MDBG_OFFSET(ao_lisp_ref(cons->cdr))); if (ret) break; - cons = cdr; + cons = c; } } diff --git a/src/lisp/ao_lisp_const.lisp b/src/lisp/ao_lisp_const.lisp index 17509044..d9b1c1f2 100644 --- a/src/lisp/ao_lisp_const.lisp +++ b/src/lisp/ao_lisp_const.lisp @@ -219,16 +219,18 @@ ; expressions to evaluate (set! make-exprs (lambda (vars exprs) - (cond ((not (null? vars)) (cons - (list set - (list quote - (car (car vars)) - ) - (cadr (car vars)) - ) - (make-exprs (cdr vars) exprs) - ) - ) + (cond ((not (null? vars)) + (cons + (list set + (list quote + (car (car vars)) + ) + (cond ((null? (cdr (car vars))) ()) + (else (cadr (car vars)))) + ) + (make-exprs (cdr vars) exprs) + ) + ) (exprs) ) ) @@ -461,6 +463,58 @@ (define string (lexpr (chars) (list->string chars))) +(patom "apply\n") +(apply cons '(a b)) + +(define save ()) + +(define map (lexpr (proc lists) + (let ((args (lambda (lists) + (if (null? lists) () + (cons (caar lists) (args (cdr lists)))))) + (next (lambda (lists) + (if (null? lists) () + (cons (cdr (car lists)) (next (cdr lists)))))) + (domap (lambda (lists) + (if (null? (car lists)) () + (cons (apply proc (args lists)) (domap (next lists))) + ))) + ) + (domap lists)))) + +(map cadr '((a b) (d e) (g h))) + +(define for-each (lexpr (proc lists) + (apply map proc lists) + #t)) + +(for-each patom '("hello" " " "world" "\n")) + +(define string-map (lexpr (proc strings) + (let ((make-lists (lambda (strings) + (if (null? strings) () + (cons (string->list (car strings)) (make-lists (cdr strings)))))) + ) + (list->string (apply map proc (make-lists strings)))))) + +(string-map 1+ "HAL") + +(define string-for-each (lexpr (proc strings) + (apply string-map proc strings) + #t)) + +(string-for-each patom "IBM") + + +(call-with-current-continuation + (lambda (exit) + (for-each (lambda (x) + (print "test" x) + (if (negative? x) + (exit x))) + '(54 0 37 -3 245 19)) + #t)) + ;(define number->string (lexpr (arg opt) ; (let ((base (if (null? opt) 10 (car opt))) ; diff --git a/src/lisp/ao_lisp_eval.c b/src/lisp/ao_lisp_eval.c index 57227e93..844e7ce7 100644 --- a/src/lisp/ao_lisp_eval.c +++ b/src/lisp/ao_lisp_eval.c @@ -17,6 +17,7 @@ struct ao_lisp_stack *ao_lisp_stack; ao_poly ao_lisp_v; +uint8_t ao_lisp_skip_cons_free; ao_poly ao_lisp_set_cond(struct ao_lisp_cons *c) @@ -269,7 +270,7 @@ ao_lisp_eval_exec(void) DBGI("set "); DBG_POLY(atom); DBG(" = "); DBG_POLY(val); DBG("\n"); }); builtin = ao_lisp_poly_builtin(ao_lisp_v); - if (builtin->args & AO_LISP_FUNC_FREE_ARGS && !ao_lisp_stack_marked(ao_lisp_stack)) + if (builtin->args & AO_LISP_FUNC_FREE_ARGS && !ao_lisp_stack_marked(ao_lisp_stack) && !ao_lisp_skip_cons_free) ao_lisp_cons_free(ao_lisp_poly_cons(ao_lisp_stack->values)); ao_lisp_v = v; @@ -295,6 +296,38 @@ ao_lisp_eval_exec(void) DBGI(".. frame "); DBG_POLY(ao_lisp_frame_poly(ao_lisp_frame_current)); DBG("\n"); break; } + ao_lisp_skip_cons_free = 0; + return 1; +} + +/* + * Finish setting up the apply evaluation + * + * The value is the list to execute + */ +static int +ao_lisp_eval_apply(void) +{ + struct ao_lisp_cons *cons = ao_lisp_poly_cons(ao_lisp_v); + struct ao_lisp_cons *cdr, *prev; + + /* Glue the arguments into the right shape. That's all but the last + * concatenated onto the last + */ + cdr = cons; + for (;;) { + prev = cdr; + cdr = ao_lisp_poly_cons(prev->cdr); + if (cdr->cdr == AO_LISP_NIL) + break; + } + DBGI("before mangling: "); DBG_POLY(ao_lisp_v); DBG("\n"); + prev->cdr = cdr->car; + ao_lisp_stack->values = ao_lisp_v; + ao_lisp_v = ao_lisp_poly_cons(ao_lisp_stack->values)->car; + DBGI("apply: "); DBG_POLY(ao_lisp_stack->values); DBG ("\n"); + ao_lisp_stack->state = eval_exec; + ao_lisp_skip_cons_free = 1; return 1; } @@ -478,6 +511,7 @@ static int (*const evals[])(void) = { [eval_val] = ao_lisp_eval_val, [eval_formal] = ao_lisp_eval_formal, [eval_exec] = ao_lisp_eval_exec, + [eval_apply] = ao_lisp_eval_apply, [eval_cond] = ao_lisp_eval_cond, [eval_cond_test] = ao_lisp_eval_cond_test, [eval_progn] = ao_lisp_eval_progn, @@ -487,16 +521,17 @@ static int (*const evals[])(void) = { }; const char *ao_lisp_state_names[] = { - "sexpr", - "val", - "formal", - "exec", - "cond", - "cond_test", - "progn", - "while", - "while_test", - "macro", + [eval_sexpr] = "sexpr", + [eval_val] = "val", + [eval_formal] = "formal", + [eval_exec] = "exec", + [eval_apply] = "apply", + [eval_cond] = "cond", + [eval_cond_test] = "cond_test", + [eval_progn] = "progn", + [eval_while] = "while", + [eval_while_test] = "while_test", + [eval_macro] = "macro", }; /* diff --git a/src/lisp/ao_lisp_make_builtin b/src/lisp/ao_lisp_make_builtin index ddc9a0b3..11838e33 100644 --- a/src/lisp/ao_lisp_make_builtin +++ b/src/lisp/ao_lisp_make_builtin @@ -7,10 +7,12 @@ typedef struct { } builtin_t; string[string] type_map = { - "lambda" => "F_LAMBDA", + "lambda" => "LAMBDA", "nlambda" => "NLAMBDA", - "lexpr" => "F_LEXPR", + "lexpr" => "LEXPR", "macro" => "MACRO", + "f_lambda" => "F_LAMBDA", + "f_lexpr" => "F_LEXPR", }; string[*] @@ -67,8 +69,8 @@ dump_casename(builtin_t[*] builtins) { printf("static char *ao_lisp_builtin_name(enum ao_lisp_builtin_id b) {\n"); printf("\tswitch(b) {\n"); for (int i = 0; i < dim(builtins); i++) - printf("\tcase builtin_%s: return ao_lisp_poly_atom(_atom(%s))->name;\n", - builtins[i].c_name, builtins[i].c_name); + printf("\tcase builtin_%s: return ao_lisp_poly_atom(_atom(\"%s\"))->name;\n", + builtins[i].c_name, builtins[i].lisp_names[0]); printf("\tdefault: return \"???\";\n"); printf("\t}\n"); printf("}\n"); @@ -150,9 +152,7 @@ dump_atoms(builtin_t[*] builtins) { for (int j = 0; j < dim(builtins[i].lisp_names); j++) { printf("#define _ao_lisp_atom_"); cify_lisp(builtins[i].lisp_names[j]); - printf(" _atom("); - cify_lisp(builtins[i].lisp_names[j]); - printf(")\n"); + printf(" _atom(\"%s\")\n", builtins[i].lisp_names[j]); } } printf("#endif /* AO_LISP_BUILTIN_ATOMS */\n"); diff --git a/src/lisp/ao_lisp_read.c b/src/lisp/ao_lisp_read.c index bcd23ce1..8c06e198 100644 --- a/src/lisp/ao_lisp_read.c +++ b/src/lisp/ao_lisp_read.c @@ -516,7 +516,7 @@ ao_lisp_read(void) if (!push_read_stack(cons, read_state)) return AO_LISP_NIL; cons++; - read_state |= READ_IN_QUOTE; + read_state = READ_IN_QUOTE; v = _ao_lisp_atom_quote; break; case CLOSE: -- 2.30.2