altos/lisp: Lots more scheme bits

* Arithmetic functions and tests
* append, reverse and list-tail
* set-car! and set-cdr!

Signed-off-by: Keith Packard <keithp@keithp.com>

diff --git a/src/lisp/ao_lisp.h b/src/lisp/ao_lisp.h
index 9a48a44554d119249559ca8993855353894d2897..341996c0c2e6d1acaa99a905fc5a22a6d7cd38a0 100644 (file)
--- a/src/lisp/ao_lisp.h
+++ b/src/lisp/ao_lisp.h
@@ -136,7 +136,7 @@ ao_lisp_is_const(ao_poly poly) {
 
 #define AO_LISP_IS_CONST(a)    (ao_lisp_const <= ((uint8_t *) (a)) && ((uint8_t *) (a)) < ao_lisp_const + AO_LISP_POOL_CONST)
 #define AO_LISP_IS_POOL(a)     (ao_lisp_pool <= ((uint8_t *) (a)) && ((uint8_t *) (a)) < ao_lisp_pool + AO_LISP_POOL)
-#define AO_LISP_IS_INT(p)      (ao_lisp_base_type(p) == AO_LISP_INT);
+#define AO_LISP_IS_INT(p)      (ao_lisp_poly_base_type(p) == AO_LISP_INT)
 
 void *
 ao_lisp_ref(ao_poly poly);

diff --git a/src/lisp/ao_lisp_builtin.c b/src/lisp/ao_lisp_builtin.c
index d89404dcca93185dac78f8aafb5df98045bff61e..2c5608e7266dcae23016467db2fb2b5ddd94cdd6 100644 (file)
--- a/src/lisp/ao_lisp_builtin.c
+++ b/src/lisp/ao_lisp_builtin.c
@@ -277,6 +277,7 @@ ao_lisp_do_patom(struct ao_lisp_cons *cons)
 ao_poly
 ao_lisp_math(struct ao_lisp_cons *cons, enum ao_lisp_builtin_id op)
 {
+       struct ao_lisp_cons *orig_cons = cons;
        ao_poly ret = AO_LISP_NIL;
 
        while (cons) {
@@ -284,12 +285,29 @@ ao_lisp_math(struct ao_lisp_cons *cons, enum ao_lisp_builtin_id op)
                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) {
+                       if (cons->cdr == AO_LISP_NIL && ct == AO_LISP_INT) {
+                               switch (op) {
+                               case builtin_minus:
+                                       ret = ao_lisp_int_poly(-ao_lisp_poly_int(ret));
+                                       break;
+                               case builtin_divide:
+                                       switch (ao_lisp_poly_int(ret)) {
+                                       case 0:
+                                               return ao_lisp_error(AO_LISP_DIVIDE_BY_ZERO, "divide by zero");
+                                       case 1:
+                                               break;
+                                       default:
+                                               ret = ao_lisp_int_poly(0);
+                                               break;
+                                       }
+                                       break;
+                               default:
+                                       break;
+                               }
+                       }
+               } else if (rt == AO_LISP_INT && ct == AO_LISP_INT) {
                        int     r = ao_lisp_poly_int(ret);
                        int     c = ao_lisp_poly_int(car);
 
@@ -308,11 +326,26 @@ ao_lisp_math(struct ao_lisp_cons *cons, enum ao_lisp_builtin_id op)
                                        return ao_lisp_error(AO_LISP_DIVIDE_BY_ZERO, "divide by zero");
                                r /= c;
                                break;
-                       case builtin_mod:
+                       case builtin_quotient:
                                if (c == 0)
-                                       return ao_lisp_error(AO_LISP_DIVIDE_BY_ZERO, "mod by zero");
+                                       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_remainder:
+                               if (c == 0)
+                                       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;
                        }
@@ -324,6 +357,8 @@ ao_lisp_math(struct ao_lisp_cons *cons, enum ao_lisp_builtin_id op)
                                                                     ao_lisp_poly_string(car)));
                else
                        return ao_lisp_error(AO_LISP_INVALID, "invalid args");
+
+               cons = ao_lisp_poly_cons(cons->cdr);
        }
        return ret;
 }
@@ -353,9 +388,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_quotient);
+}
+
+ao_poly
+ao_lisp_do_modulo(struct ao_lisp_cons *cons)
 {
-       return ao_lisp_math(cons, builtin_mod);
+       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
@@ -593,5 +640,45 @@ ao_lisp_do_pairp(struct ao_lisp_cons *cons)
        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;
+       if (AO_LISP_IS_INT(ao_lisp_arg(cons, 0)))
+               return _ao_lisp_bool_true;
+       return _ao_lisp_bool_false;
+}
+
+ao_poly
+ao_lisp_do_booleanp(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)) == AO_LISP_BOOL)
+               return _ao_lisp_bool_true;
+       return _ao_lisp_bool_false;
+}
+
+ao_poly
+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);
+}
+
 #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 2b891dbab571ca48330d8326c58771edcd4d0c64..b27985ff66a2dd55a55ec91cea31b8d547731241 100644 (file)
--- a/src/lisp/ao_lisp_builtin.txt
+++ b/src/lisp/ao_lisp_builtin.txt
@@ -21,7 +21,9 @@ lexpr plus            +
 lexpr  minus           -
 lexpr  times           *
 lexpr  divide          /
-lexpr  mod             %
+lexpr  modulo          modulo  %
+lexpr  remainder
+lexpr  quotient
 lexpr  equal           =       eq?     eqv?
 lexpr  less            <
 lexpr  greater         >
@@ -40,3 +42,7 @@ 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!

diff --git a/src/lisp/ao_lisp_const.lisp b/src/lisp/ao_lisp_const.lisp
index 37307a6877758938bb1f9258a701940770560c30..3ba6aaf50fa6990c4534577eb15d554fb7f276ce 100644 (file)
--- a/src/lisp/ao_lisp_const.lisp
+++ b/src/lisp/ao_lisp_const.lisp
@@ -69,6 +69,93 @@
 (defun 1+ (x) (+ x 1))
 (defun 1- (x) (- x 1))
 
+(define zero? (macro (value rest)
+                    (list
+                     eq?
+                     value
+                     0)
+                    )
+  )
+
+(zero? 1)
+(zero? 0)
+(zero? "hello")
+
+(define positive? (macro (value rest)
+                        (list
+                         >
+                         value
+                         0)
+                        )
+  )
+
+(positive? 12)
+(positive? -12)
+
+(define negative? (macro (value rest)
+                        (list
+                         <
+                         value
+                         0)
+                        )
+  )
+
+(negative? 12)
+(negative? -12)
+
+(defun abs (x) (cond ((>= x 0) x)
+                    (else (- x)))
+       )
+
+(abs 12)
+(abs -12)
+
+(define max (lexpr (first rest)
+                  (while (not (null? rest))
+                    (cond ((< first (car rest))
+                           (set! first (car rest)))
+                          )
+                    (set! rest (cdr rest))
+                    )
+                  first)
+  )
+
+(max 1 2 3)
+(max 3 2 1)
+
+(define min (lexpr (first rest)
+                  (while (not (null? rest))
+                    (cond ((> first (car rest))
+                           (set! first (car rest)))
+                          )
+                    (set! rest (cdr rest))
+                    )
+                  first)
+  )
+
+(min 1 2 3)
+(min 3 2 1)
+
+(defun even? (x) (zero? (% x 2)))
+
+(even? 2)
+(even? -2)
+(even? 3)
+(even? -1)
+
+(defun odd? (x) (not (even? x)))
+
+(odd? 2)
+(odd? -2)
+(odd? 3)
+(odd? -1)
+
+(define exact? number?)
+(defun inexact? (x) #f)
+
+                                       ; (if <condition> <if-true>)
+                                       ; (if <condition> <if-true> <if-false)
+
 (define if (macro (test args)
               (cond ((null? (cdr args))
                      (list
@@ -208,6 +295,49 @@
 
 (and #t #f)
 
+
+(define append (lexpr (args)
+                     (let ((append-list (lambda (a b)
+                                          (cond ((null? a) b)
+                                                (else (cons (car a) (append-list (cdr a) b)))
+                                                )
+                                          )
+                                        )
+                           (append-lists (lambda (lists)
+                                           (cond ((null? lists) lists)
+                                                 ((null? (cdr lists)) (car lists))
+                                                 (else (append-list (car lists) (append-lists (cdr lists))))
+                                                 )
+                                           )
+                                         )
+                           )
+                       (append-lists args)
+                       )
+                     )
+  )
+
+(append '(a b c) '(d e f) '(g h i))
+
+(defun reverse (list)
+  (let ((result ()))
+    (while (not (null? list))
+      (set! result (cons (car list) result))
+      (set! list (cdr list))
+      )
+    result)
+  )
+
+(reverse '(1 2 3))
+
+(define list-tail
+  (lambda (x k)
+    (if (zero? k)
+       x
+      (list-tail (cdr x) (- k 1)))))
+
+(list-tail '(1 2 3) 2)
+                                       ; recursive equality
+
 (defun equal? (a b)
   (cond ((eq? a b) #t)
        ((and (pair? a) (pair? b))
@@ -220,3 +350,9 @@
 
 (equal? '(a b c) '(a b c))
 (equal? '(a b c) '(a b b))
+
+;(define number->string (lexpr (arg opt)
+;                            (let ((base (if (null? opt) 10 (car opt)))
+                                       ;
+;
+