From: Keith Packard Date: Mon, 4 Dec 2017 03:54:18 +0000 (-0800) Subject: altos/lisp: Switch to scheme formal syntax for varargs X-Git-Tag: 1.8.3~1^2~22^2~5 X-Git-Url: https://git.gag.com/?p=fw%2Faltos;a=commitdiff_plain;h=9dbc686ad7d3289dc0f9bcf4a973f71100e02ded altos/lisp: Switch to scheme formal syntax for varargs Scheme uses bare symbols to indicate a varargs parameter; any bare (i.e., not wrapped in a cons cell) parameter will get the 'rest' of the parameter list. This works for lambdas, nlambdas and macros. As a result, the 'lexpr' form has been removed as it is equivalent to a lambda with a varargs formal. Signed-off-by: Keith Packard --- diff --git a/src/lisp/ao_lisp.h b/src/lisp/ao_lisp.h index d32e7dcd..b5e03b1e 100644 --- a/src/lisp/ao_lisp.h +++ b/src/lisp/ao_lisp.h @@ -297,7 +297,6 @@ extern ao_poly ao_lisp_v; #define AO_LISP_FUNC_LAMBDA 0 #define AO_LISP_FUNC_NLAMBDA 1 #define AO_LISP_FUNC_MACRO 2 -#define AO_LISP_FUNC_LEXPR 3 #define AO_LISP_FUNC_FREE_ARGS 0x80 #define AO_LISP_FUNC_MASK 0x7f @@ -305,7 +304,6 @@ extern ao_poly ao_lisp_v; #define AO_LISP_FUNC_F_LAMBDA (AO_LISP_FUNC_FREE_ARGS | AO_LISP_FUNC_LAMBDA) #define AO_LISP_FUNC_F_NLAMBDA (AO_LISP_FUNC_FREE_ARGS | AO_LISP_FUNC_NLAMBDA) #define AO_LISP_FUNC_F_MACRO (AO_LISP_FUNC_FREE_ARGS | AO_LISP_FUNC_MACRO) -#define AO_LISP_FUNC_F_LEXPR (AO_LISP_FUNC_FREE_ARGS | AO_LISP_FUNC_LEXPR) struct ao_lisp_builtin { uint8_t type; diff --git a/src/lisp/ao_lisp_builtin.c b/src/lisp/ao_lisp_builtin.c index fdca0208..6af2a6ea 100644 --- a/src/lisp/ao_lisp_builtin.c +++ b/src/lisp/ao_lisp_builtin.c @@ -50,7 +50,6 @@ char *ao_lisp_args_name(uint8_t args) { 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 "???"; @@ -70,7 +69,6 @@ ao_lisp_builtin_name(enum ao_lisp_builtin_id b) { static const ao_poly ao_lisp_args_atoms[] = { [AO_LISP_FUNC_LAMBDA] = _ao_lisp_atom_lambda, - [AO_LISP_FUNC_LEXPR] = _ao_lisp_atom_lexpr, [AO_LISP_FUNC_NLAMBDA] = _ao_lisp_atom_nlambda, [AO_LISP_FUNC_MACRO] = _ao_lisp_atom_macro, }; diff --git a/src/lisp/ao_lisp_builtin.txt b/src/lisp/ao_lisp_builtin.txt index abed7afe..cb65e252 100644 --- a/src/lisp/ao_lisp_builtin.txt +++ b/src/lisp/ao_lisp_builtin.txt @@ -1,7 +1,6 @@ f_lambda eval f_lambda read nlambda lambda -nlambda lexpr nlambda nlambda nlambda macro f_lambda car @@ -19,25 +18,25 @@ f_lambda def nlambda cond nlambda begin nlambda while -f_lexpr write -f_lexpr display -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 write +f_lambda display +f_lambda plus + +f_lambda minus - +f_lambda times * +f_lambda divide / +f_lambda modulo modulo % +f_lambda remainder +f_lambda quotient +f_lambda equal = eq? eqv? +f_lambda less < +f_lambda greater > +f_lambda less_equal <= +f_lambda greater_equal >= f_lambda list_to_string list->string f_lambda string_to_list string->list f_lambda flush_output flush-output f_lambda delay -f_lexpr led +f_lambda led f_lambda save f_lambda restore f_lambda call_cc call-with-current-continuation call/cc @@ -56,7 +55,7 @@ f_lambda symbol_to_string symbol->string f_lambda string_to_symbol string->symbol f_lambda stringp string? f_lambda procedurep procedure? -lexpr apply +lambda apply f_lambda read_char read-char f_lambda write_char write-char f_lambda exit diff --git a/src/lisp/ao_lisp_const.lisp b/src/lisp/ao_lisp_const.lisp index bb413e7d..422bdd63 100644 --- a/src/lisp/ao_lisp_const.lisp +++ b/src/lisp/ao_lisp_const.lisp @@ -14,10 +14,10 @@ ; Lisp code placed in ROM ; return a list containing all of the arguments -(def (quote list) (lexpr (l) l)) +(def (quote list) (lambda l l)) (def (quote def!) - (macro (name value rest) + (macro (name value) (list def (list quote name) @@ -27,7 +27,7 @@ (begin (def! append - (lexpr (args) + (lambda args (def! append-list (lambda (a b) (cond ((null? a) b) @@ -55,7 +55,7 @@ (begin (def! or - (macro (l) + (macro l (def! _or (lambda (l) (cond ((null? l) #f) @@ -84,7 +84,7 @@ (begin (def! and - (macro (l) + (macro l (def! _and (lambda (l) (cond ((null? l) #t) @@ -102,7 +102,9 @@ ) ) ) - (_and l))) + (_and l) + ) + ) 'and) ; execute to resolve macros @@ -111,7 +113,7 @@ (begin (def! quasiquote - (macro (x rest) + (macro (x) (def! constant? ; A constant value is either a pair starting with quote, ; or anything which is neither a pair nor a symbol @@ -225,10 +227,12 @@ ) ) ) - (expand-quasiquote x 0) + (def! result (expand-quasiquote x 0)) + result ) ) 'quasiquote) + ; ; Define a variable without returning the value ; Useful when defining functions to avoid @@ -241,7 +245,7 @@ (begin (def! define - (macro (first rest) + (macro (first . rest) ; check for alternate lambda definition form (cond ((list? first) @@ -257,9 +261,11 @@ (set! rest (car rest)) ) ) - `(begin - (def (quote ,first) ,rest) - (quote ,first)) + (def! result `(,begin + (,def (,quote ,first) ,rest) + (,quote ,first)) + ) + result ) ) 'define @@ -275,22 +281,11 @@ (define (caddr l) (car (cdr (cdr l)))) -(define (list-tail x k) - (if (zero? k) - x - (list-tail (cdr x (- k 1))) - ) - ) - -(define (list-ref x k) - (car (list-tail x k)) - ) - ; (if ) ; (if ,value 0))) +(define positive? (macro (value) `(> ,value 0))) (positive? 12) (positive? -12) -(define negative? (macro (value rest) `(< ,value 0))) +(define negative? (macro (value) `(< ,value 0))) (negative? 12) (negative? -12) @@ -330,7 +325,7 @@ (abs 12) (abs -12) -(define max (lexpr (first rest) +(define max (lambda (first . rest) (while (not (null? rest)) (cond ((< first (car rest)) (set! first (car rest))) @@ -343,7 +338,7 @@ (max 1 2 3) (max 3 2 1) -(define min (lexpr (first rest) +(define min (lambda (first . rest) (while (not (null? rest)) (cond ((> first (car rest)) (set! first (car rest))) @@ -371,6 +366,17 @@ (odd? -1) +(define (list-tail x k) + (if (zero? k) + x + (list-tail (cdr x (- k 1))) + ) + ) + +(define (list-ref x k) + (car (list-tail x k)) + ) + ; define a set of local ; variables all at once and ; then evaluate a list of @@ -391,7 +397,7 @@ ; (let ((x 1) (y)) (set! y (+ x 1)) y) (define let - (macro (vars exprs) + (macro (vars . exprs) (define (make-names vars) (cond ((not (null? vars)) (cons (car (car vars)) @@ -445,7 +451,7 @@ ; (let* ((x 1) (y)) (set! y (+ x 1)) y) (define let* - (macro (vars exprs) + (macro (vars . exprs) ; ; make the list of names in the let @@ -497,11 +503,11 @@ (let* ((x 1) (y x)) (+ x y)) -(define when (macro (test l) `(cond (,test ,@l)))) +(define when (macro (test . l) `(cond (,test ,@l)))) (when #t (write 'when)) -(define unless (macro (test l) `(cond ((not ,test) ,@l)))) +(define unless (macro (test . l) `(cond ((not ,test) ,@l)))) (unless #f (write 'unless)) @@ -542,7 +548,7 @@ (equal? '(a b c) '(a b c)) (equal? '(a b c) '(a b b)) -(define member (lexpr (obj list test?) +(define member (lambda (obj list . test?) (cond ((null? list) #f ) @@ -651,13 +657,13 @@ (char-downcase #\0) (char-downcase #\space) -(define string (lexpr (chars) (list->string chars))) +(define string (lambda chars (list->string chars))) (display "apply\n") (apply cons '(a b)) (define map - (lexpr (proc lists) + (lambda (proc . lists) (define (args lists) (cond ((null? lists) ()) (else @@ -685,7 +691,7 @@ (map cadr '((a b) (d e) (g h))) -(define for-each (lexpr (proc lists) +(define for-each (lambda (proc . lists) (apply map proc lists) #t)) @@ -697,12 +703,12 @@ ) ) -(define string-map (lexpr (proc strings) +(define string-map (lambda (proc . strings) (list->string (apply map proc (_string-ml strings)))))) (string-map (lambda (x) (+ 1 x)) "HAL") -(define string-for-each (lexpr (proc strings) +(define string-for-each (lambda (proc . strings) (apply for-each proc (_string-ml strings)))) (string-for-each write-char "IBM\n") @@ -732,7 +738,7 @@ (define repeat - (macro (count rest) + (macro (count . rest) (define counter '__count__) (cond ((pair? count) (set! counter (car count)) @@ -754,7 +760,7 @@ (repeat (x 3) (write 'goodbye x)) (define case - (macro (test l) + (macro (test . l) ; construct the body of the ; case, dealing with the ; lambda version ( => lambda) @@ -800,7 +806,7 @@ (case 12 (1 "one") (2 "two") (3 => (lambda (x) (write "the value is" x))) (12 "twelve") (else "else")) -;(define number->string (lexpr (arg opt) +;(define number->string (lambda (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 ced182f6..c3dd2ed2 100644 --- a/src/lisp/ao_lisp_eval.c +++ b/src/lisp/ao_lisp_eval.c @@ -152,9 +152,9 @@ ao_lisp_eval_val(void) * A formal has been computed. * * If this is the first formal, then check to see if we've got a - * lamda/lexpr or macro/nlambda. + * lamda, macro or nlambda. * - * For lambda/lexpr, go compute another formal. This will terminate + * For lambda, go compute another formal. This will terminate * when the sexpr state sees nil. * * For macro/nlambda, we're done, so move the sexprs into the values @@ -177,8 +177,7 @@ ao_lisp_eval_formal(void) if (!ao_lisp_stack->values) { switch (func_type(ao_lisp_v)) { case AO_LISP_FUNC_LAMBDA: - case AO_LISP_FUNC_LEXPR: - DBGI(".. lambda or lexpr\n"); + DBGI(".. lambda\n"); break; case AO_LISP_FUNC_MACRO: /* Evaluate the result once more */ @@ -272,8 +271,11 @@ 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 && 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)); + if (builtin && (builtin->args & AO_LISP_FUNC_FREE_ARGS) && !ao_lisp_stack_marked(ao_lisp_stack) && !ao_lisp_skip_cons_free) { + struct ao_lisp_cons *cons = ao_lisp_poly_cons(ao_lisp_stack->values); + ao_lisp_stack->values = AO_LISP_NIL; + ao_lisp_cons_free(cons); + } ao_lisp_v = v; ao_lisp_stack->values = AO_LISP_NIL; diff --git a/src/lisp/ao_lisp_lambda.c b/src/lisp/ao_lisp_lambda.c index 71aebed0..e72281db 100644 --- a/src/lisp/ao_lisp_lambda.c +++ b/src/lisp/ao_lisp_lambda.c @@ -68,26 +68,33 @@ ao_lisp_lambda_write(ao_poly poly) ao_poly ao_lisp_lambda_alloc(struct ao_lisp_cons *code, int args) { + struct ao_lisp_lambda *lambda; + ao_poly formal; + struct ao_lisp_cons *cons; + + formal = ao_lisp_arg(code, 0); + while (formal != AO_LISP_NIL) { + switch (ao_lisp_poly_type(formal)) { + case AO_LISP_CONS: + cons = ao_lisp_poly_cons(formal); + if (ao_lisp_poly_type(cons->car) != AO_LISP_ATOM) + return ao_lisp_error(AO_LISP_INVALID, "formal %p is not atom", cons->car); + formal = cons->cdr; + break; + case AO_LISP_ATOM: + formal = AO_LISP_NIL; + break; + default: + return ao_lisp_error(AO_LISP_INVALID, "formal %p is not atom", formal); + } + } + ao_lisp_cons_stash(0, code); - struct ao_lisp_lambda *lambda = ao_lisp_alloc(sizeof (struct ao_lisp_lambda)); + lambda = ao_lisp_alloc(sizeof (struct ao_lisp_lambda)); code = ao_lisp_cons_fetch(0); - struct ao_lisp_cons *arg; - int f; - if (!lambda) return AO_LISP_NIL; - if (!ao_lisp_check_argt(_ao_lisp_atom_lambda, code, 0, AO_LISP_CONS, 1)) - return AO_LISP_NIL; - f = 0; - arg = ao_lisp_poly_cons(ao_lisp_arg(code, 0)); - while (arg) { - if (ao_lisp_poly_type(arg->car) != AO_LISP_ATOM) - return ao_lisp_error(AO_LISP_INVALID, "formal %d is not an atom", f); - arg = ao_lisp_poly_cons(arg->cdr); - f++; - } - lambda->type = AO_LISP_LAMBDA; lambda->args = args; lambda->code = ao_lisp_cons_poly(code); @@ -103,12 +110,6 @@ ao_lisp_do_lambda(struct ao_lisp_cons *cons) return ao_lisp_lambda_alloc(cons, AO_LISP_FUNC_LAMBDA); } -ao_poly -ao_lisp_do_lexpr(struct ao_lisp_cons *cons) -{ - return ao_lisp_lambda_alloc(cons, AO_LISP_FUNC_LEXPR); -} - ao_poly ao_lisp_do_nlambda(struct ao_lisp_cons *cons) { @@ -127,67 +128,78 @@ ao_lisp_lambda_eval(void) struct ao_lisp_lambda *lambda = ao_lisp_poly_lambda(ao_lisp_v); struct ao_lisp_cons *cons = ao_lisp_poly_cons(ao_lisp_stack->values); struct ao_lisp_cons *code = ao_lisp_poly_cons(lambda->code); - struct ao_lisp_cons *args = ao_lisp_poly_cons(ao_lisp_arg(code, 0)); + ao_poly formals; struct ao_lisp_frame *next_frame; int args_wanted; + ao_poly varargs = AO_LISP_NIL; int args_provided; int f; struct ao_lisp_cons *vals; DBGI("lambda "); DBG_POLY(ao_lisp_lambda_poly(lambda)); DBG("\n"); - args_wanted = ao_lisp_cons_length(args); + args_wanted = 0; + for (formals = ao_lisp_arg(code, 0); + ao_lisp_is_pair(formals); + formals = ao_lisp_poly_cons(formals)->cdr) + ++args_wanted; + if (formals != AO_LISP_NIL) { + if (ao_lisp_poly_type(formals) != AO_LISP_ATOM) + return ao_lisp_error(AO_LISP_INVALID, "bad lambda form"); + varargs = formals; + } /* Create a frame to hold the variables */ args_provided = ao_lisp_cons_length(cons) - 1; - if (lambda->args == AO_LISP_FUNC_LAMBDA) { + if (varargs == AO_LISP_NIL) { if (args_wanted != args_provided) return ao_lisp_error(AO_LISP_INVALID, "need %d args, got %d", args_wanted, args_provided); } else { - if (args_provided < args_wanted - 1) + if (args_provided < args_wanted) return ao_lisp_error(AO_LISP_INVALID, "need at least %d args, got %d", args_wanted, args_provided); } - next_frame = ao_lisp_frame_new(args_wanted); + ao_lisp_poly_stash(1, varargs); + next_frame = ao_lisp_frame_new(args_wanted + (varargs != AO_LISP_NIL)); + varargs = ao_lisp_poly_fetch(1); + if (!next_frame) + return AO_LISP_NIL; /* Re-fetch all of the values in case something moved */ lambda = ao_lisp_poly_lambda(ao_lisp_v); cons = ao_lisp_poly_cons(ao_lisp_stack->values); code = ao_lisp_poly_cons(lambda->code); - args = ao_lisp_poly_cons(ao_lisp_arg(code, 0)); + formals = ao_lisp_arg(code, 0); vals = ao_lisp_poly_cons(cons->cdr); next_frame->prev = lambda->frame; ao_lisp_frame_current = next_frame; ao_lisp_stack->frame = ao_lisp_frame_poly(ao_lisp_frame_current); - switch (lambda->args) { - case AO_LISP_FUNC_LAMBDA: - for (f = 0; f < args_wanted; f++) { - DBGI("bind "); DBG_POLY(args->car); DBG(" = "); DBG_POLY(vals->car); DBG("\n"); - ao_lisp_frame_bind(next_frame, f, args->car, vals->car); - args = ao_lisp_poly_cons(args->cdr); - vals = ao_lisp_poly_cons(vals->cdr); - } - if (!ao_lisp_stack_marked(ao_lisp_stack)) + for (f = 0; f < args_wanted; f++) { + struct ao_lisp_cons *arg = ao_lisp_poly_cons(formals); + DBGI("bind "); DBG_POLY(arg->car); DBG(" = "); DBG_POLY(vals->car); DBG("\n"); + ao_lisp_frame_bind(next_frame, f, arg->car, vals->car); + formals = arg->cdr; + vals = ao_lisp_poly_cons(vals->cdr); + } + if (varargs) { + DBGI("bind "); DBG_POLY(varargs); DBG(" = "); DBG_POLY(ao_lisp_cons_poly(vals)); DBG("\n"); + /* + * Bind the rest of the arguments to the final parameter + */ + ao_lisp_frame_bind(next_frame, f, varargs, ao_lisp_cons_poly(vals)); + } else { + /* + * Mark the cons cells from the actuals as freed for immediate re-use, unless + * the actuals point into the source function (nlambdas and macros), or if the + * stack containing them was copied as a part of a continuation + */ + if (lambda->args == AO_LISP_FUNC_LAMBDA && !ao_lisp_stack_marked(ao_lisp_stack)) { + ao_lisp_stack->values = AO_LISP_NIL; ao_lisp_cons_free(cons); - cons = NULL; - break; - case AO_LISP_FUNC_LEXPR: - case AO_LISP_FUNC_NLAMBDA: - case AO_LISP_FUNC_MACRO: - for (f = 0; f < args_wanted - 1; f++) { - DBGI("bind "); DBG_POLY(args->car); DBG(" = "); DBG_POLY(vals->car); DBG("\n"); - ao_lisp_frame_bind(next_frame, f, args->car, vals->car); - args = ao_lisp_poly_cons(args->cdr); - vals = ao_lisp_poly_cons(vals->cdr); } - DBGI("bind "); DBG_POLY(args->car); DBG(" = "); DBG_POLY(ao_lisp_cons_poly(vals)); DBG("\n"); - ao_lisp_frame_bind(next_frame, f, args->car, ao_lisp_cons_poly(vals)); - break; - default: - break; } DBGI("eval frame: "); DBG_POLY(ao_lisp_frame_poly(next_frame)); DBG("\n"); DBG_STACK(); diff --git a/src/lisp/ao_lisp_make_builtin b/src/lisp/ao_lisp_make_builtin index c4ba9d94..783ab378 100644 --- a/src/lisp/ao_lisp_make_builtin +++ b/src/lisp/ao_lisp_make_builtin @@ -9,10 +9,8 @@ typedef struct { string[string] type_map = { "lambda" => "LAMBDA", "nlambda" => "NLAMBDA", - "lexpr" => "LEXPR", "macro" => "MACRO", "f_lambda" => "F_LAMBDA", - "f_lexpr" => "F_LEXPR", "atom" => "atom", }; diff --git a/src/lisp/ao_lisp_make_const.c b/src/lisp/ao_lisp_make_const.c index f3ea6be0..6e4b411e 100644 --- a/src/lisp/ao_lisp_make_const.c +++ b/src/lisp/ao_lisp_make_const.c @@ -191,6 +191,7 @@ ao_has_macro(ao_poly p) struct ao_lisp_cons *cons; struct ao_lisp_lambda *lambda; ao_poly m; + ao_poly list; if (p == AO_LISP_NIL) return AO_LISP_NIL; @@ -206,15 +207,16 @@ ao_has_macro(ao_poly p) if ((p = ao_is_macro(cons->car))) break; - cons = ao_lisp_poly_cons(cons->cdr); + list = cons->cdr; p = AO_LISP_NIL; - while (cons) { + while (list != AO_LISP_NIL && ao_lisp_poly_type(list) == AO_LISP_CONS) { + cons = ao_lisp_poly_cons(list); m = ao_has_macro(cons->car); if (m) { p = m; break; } - cons = ao_lisp_poly_cons(cons->cdr); + list = cons->cdr; } break;