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 <keithp@keithp.com>

diff --git a/src/lisp/ao_lisp_builtin.c b/src/lisp/ao_lisp_builtin.c
index 6fc28820d403f1bd3d44ad77609d00fafa6737d7..d89404dcca93185dac78f8aafb5df98045bff61e 100644 (file)
--- 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 02320df0331973f98881e2e8c6faa45ef13eed47..2b891dbab571ca48330d8326c58771edcd4d0c64 100644 (file)
--- 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 df277fce9b263e6a03b4ba086d1f2fd18d4ea646..37307a6877758938bb1f9258a701940770560c30 100644 (file)
--- 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 <name> (<params>) 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 5e98516c7c2b69247c5e4c411580d61c999a54a2..b7b17cf48009c80673bc6ba3d4b5c7c4eec6ecb9 100644 (file)
--- 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");