From 2e58b6c380bc6440490c47650fbf11d45b3f2e72 Mon Sep 17 00:00:00 2001 From: Keith Packard Date: Thu, 16 Nov 2017 18:46:03 -0800 Subject: [PATCH] altos/lisp: More schemisms Add 'if'. setq -> set!, but doesn't define new variables def -> define Add pair? and list? Add eq? and eqv? as aliases for = Signed-off-by: Keith Packard --- src/lisp/ao_lisp_builtin.c | 36 ++++++++++++++- src/lisp/ao_lisp_builtin.txt | 6 ++- src/lisp/ao_lisp_const.lisp | 87 ++++++++++++++++++++++++----------- src/lisp/ao_lisp_make_builtin | 22 +++++++-- 4 files changed, 117 insertions(+), 34 deletions(-) diff --git a/src/lisp/ao_lisp_builtin.c b/src/lisp/ao_lisp_builtin.c index 6fc28820..d89404dc 100644 --- a/src/lisp/ao_lisp_builtin.c +++ b/src/lisp/ao_lisp_builtin.c @@ -210,11 +210,17 @@ ao_lisp_do_set(struct ao_lisp_cons *cons) 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)) 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__cons(_ao_lisp_atom_set, ao_lisp__cons(ao_lisp__cons(_ao_lisp_atom_quote, - ao_lisp__cons(cons->car, AO_LISP_NIL)), + ao_lisp__cons(name, AO_LISP_NIL)), cons->cdr)); } @@ -559,5 +565,33 @@ ao_lisp_do_not(struct ao_lisp_cons *cons) return _ao_lisp_bool_false; } +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_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 (ao_lisp_poly_type(v) == AO_LISP_CONS) + return _ao_lisp_bool_true; + return _ao_lisp_bool_false; +} + #define AO_LISP_BUILTIN_FUNCS #include "ao_lisp_builtin.h" diff --git a/src/lisp/ao_lisp_builtin.txt b/src/lisp/ao_lisp_builtin.txt index 02320df0..2b891dba 100644 --- a/src/lisp/ao_lisp_builtin.txt +++ b/src/lisp/ao_lisp_builtin.txt @@ -11,7 +11,7 @@ lambda last lambda length nlambda quote lambda set -macro setq +macro setq set! nlambda cond nlambda progn nlambda while @@ -22,7 +22,7 @@ lexpr minus - lexpr times * lexpr divide / lexpr mod % -lexpr equal = +lexpr equal = eq? eqv? lexpr less < lexpr greater > lexpr less_equal <= @@ -38,3 +38,5 @@ lambda call_cc call/cc lambda collect lambda nullp null? lambda not +lambda listp list? +lambda pairp pair? diff --git a/src/lisp/ao_lisp_const.lisp b/src/lisp/ao_lisp_const.lisp index df277fce..37307a68 100644 --- a/src/lisp/ao_lisp_const.lisp +++ b/src/lisp/ao_lisp_const.lisp @@ -23,17 +23,17 @@ ; having lots of output generated ; -(setq def (macro (name val rest) - (list - 'progn - (list - 'set - (list 'quote name) - val) - (list 'quote name) - ) - ) - ) +(set (quote define) (macro (name val rest) + (list + 'progn + (list + 'set + (list 'quote name) + val) + (list 'quote name) + ) + ) + ) ; ; A slightly more convenient form @@ -42,9 +42,9 @@ ; (defun () s-exprs) ; -(def defun (macro (name args exprs) +(define defun (macro (name args exprs) (list - def + define name (cons 'lambda (cons args exprs)) ) @@ -69,6 +69,28 @@ (defun 1+ (x) (+ x 1)) (defun 1- (x) (- x 1)) +(define if (macro (test args) + (cond ((null? (cdr args)) + (list + cond + (list test (car args))) + ) + (else + (list + cond + (list test (car args)) + (list 'else (cadr args)) + ) + ) + ) + ) + ) + +(if (> 3 2) 'yes) +(if (> 3 2) 'yes 'no) +(if (> 2 3) 'no 'yes) +(if (> 2 3) 'no) + ; define a set of local ; variables and then evaluate ; a list of sexprs @@ -85,16 +107,16 @@ ; ; e.g. ; - ; (let ((x 1) (y)) (setq y (+ x 1)) y) + ; (let ((x 1) (y)) (set! y (+ x 1)) y) -(def let (macro (vars exprs) +(define let (macro (vars exprs) ((lambda (make-names make-exprs make-nils) ; ; make the list of names in the let ; - (setq make-names (lambda (vars) + (set! make-names (lambda (vars) (cond ((not (null? vars)) (cons (car (car vars)) (make-names (cdr vars)))) @@ -107,7 +129,7 @@ ; pre-pended to the ; expressions to evaluate - (setq make-exprs (lambda (vars exprs) + (set! make-exprs (lambda (vars exprs) (cond ((not (null? vars)) (cons (list set (list quote @@ -126,7 +148,7 @@ ; the parameters to the lambda is a list ; of nils of the right length - (setq make-nils (lambda (vars) + (set! make-nils (lambda (vars) (cond ((not (null? vars)) (cons () (make-nils (cdr vars)))) ) ) @@ -134,7 +156,7 @@ ; prepend the set operations ; to the expressions - (setq exprs (make-exprs vars exprs)) + (set! exprs (make-exprs vars exprs)) ; build the lambda. @@ -153,11 +175,11 @@ ; boolean operators -(def or (lexpr (l) +(define or (lexpr (l) (let ((ret #f)) (while (not (null? l)) - (cond ((car l) (setq ret #t) (setq l ())) - ((setq l (cdr l))))) + (cond ((car l) (set! ret #t) (set! l ())) + ((set! l (cdr l))))) ret ) ) @@ -167,14 +189,14 @@ (or #f #t) -(def and (lexpr (l) +(define and (lexpr (l) (let ((ret #t)) (while (not (null? l)) (cond ((car l) - (setq l (cdr l))) + (set! l (cdr l))) (#t - (setq ret #f) - (setq l ())) + (set! ret #f) + (set! l ())) ) ) ret @@ -185,3 +207,16 @@ ; execute to resolve macros (and #t #f) + +(defun equal? (a b) + (cond ((eq? a b) #t) + ((and (pair? a) (pair? b)) + (and (equal? (car a) (car b)) + (equal? (cdr a) (cdr b))) + ) + (else #f) + ) + ) + +(equal? '(a b c) '(a b c)) +(equal? '(a b c) '(a b b)) diff --git a/src/lisp/ao_lisp_make_builtin b/src/lisp/ao_lisp_make_builtin index 5e98516c..b7b17cf4 100644 --- a/src/lisp/ao_lisp_make_builtin +++ b/src/lisp/ao_lisp_make_builtin @@ -3,7 +3,7 @@ typedef struct { string type; string c_name; - string lisp_name; + string[*] lisp_names; } builtin_t; string[string] type_map = { @@ -13,6 +13,16 @@ string[string] type_map = { "macro" => "MACRO", }; +string[*] +make_lisp(string[*] tokens) +{ + string[...] lisp = {}; + + if (dim(tokens) < 3) + return (string[1]) { tokens[dim(tokens) - 1] }; + return (string[dim(tokens)-2]) { [i] = tokens[i+2] }; +} + builtin_t read_builtin(file f) { string line = File::fgets(f); @@ -21,7 +31,7 @@ read_builtin(file f) { return (builtin_t) { .type = dim(tokens) > 0 ? type_map[tokens[0]] : "#", .c_name = dim(tokens) > 1 ? tokens[1] : "#", - .lisp_name = dim(tokens) > 2 ? tokens[2] : tokens[1] + .lisp_names = make_lisp(tokens), }; } @@ -84,7 +94,7 @@ dump_arrayname(builtin_t[*] builtins) { for (int i = 0; i < dim(builtins); i++) { printf("\t[builtin_%s] = _ao_lisp_atom_", builtins[i].c_name); - cify_lisp(builtins[i].lisp_name); + cify_lisp(builtins[i].lisp_names[0]); printf(",\n"); } printf("};\n"); @@ -123,8 +133,10 @@ dump_consts(builtin_t[*] builtins) { printf("#undef AO_LISP_BUILTIN_CONSTS\n"); printf("struct builtin_func funcs[] = {\n"); for (int i = 0; i < dim(builtins); i++) { - printf ("\t{ .name = \"%s\", .args = AO_LISP_FUNC_%s, .func = builtin_%s },\n", - builtins[i].lisp_name, builtins[i].type, builtins[i].c_name); + for (int j = 0; j < dim(builtins[i].lisp_names); j++) { + printf ("\t{ .name = \"%s\", .args = AO_LISP_FUNC_%s, .func = builtin_%s },\n", + builtins[i].lisp_names[j], builtins[i].type, builtins[i].c_name); + } } printf("};\n"); printf("#endif /* AO_LISP_BUILTIN_CONSTS */\n"); -- 2.30.2