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

diff --git a/src/lisp/ao_lisp.h b/src/lisp/ao_lisp.h
index d32e7dcd8da263f8d96377bd8190ded9469a5b22..b5e03b1ed7c4ee3bf487bd3039ba02ccaa7bb018 100644 (file)
--- 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_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
 
 #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_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;
 
 struct ao_lisp_builtin {
        uint8_t         type;

diff --git a/src/lisp/ao_lisp_builtin.c b/src/lisp/ao_lisp_builtin.c
index fdca020849177c9d2684bc22cfd91ef2c7c20b0a..6af2a6ea52baf052b9dbeee99449bcfe8f5ac8b8 100644 (file)
--- 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;
        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 "???";
        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,
 
 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,
 };
        [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 abed7afec97c924a63f3883702d35afc982d9c9a..cb65e252ce27030b4d973943664185d0121ecbe9 100644 (file)
--- 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
 f_lambda       eval
 f_lambda       read
 nlambda                lambda

-nlambda                lexpr

 nlambda                nlambda
 nlambda                macro
 f_lambda       car
 nlambda                nlambda
 nlambda                macro
 f_lambda       car


@@ -19,25 +18,25 @@ f_lambda    def
 nlambda                cond
 nlambda                begin
 nlambda                while
 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_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
 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?
 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
 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 bb413e7d3d877e5677938c6541bc339f06289458..422bdd635cca897f87cb759518cd20cb494c99d8 100644 (file)
--- 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
 ; 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!)
 
 (def (quote def!)

-     (macro (name value rest)
+     (macro (name value)

            (list
             def
             (list quote name)
            (list
             def
             (list quote name)


@@ -27,7 +27,7 @@
 
 (begin
  (def! append
 
 (begin
  (def! append

-   (lexpr (args)
+   (lambda args

          (def! append-list
            (lambda (a b)
              (cond ((null? a) b)
          (def! append-list
            (lambda (a b)
              (cond ((null? a) b)


@@ -55,7 +55,7 @@
 
 (begin
  (def! or
 
 (begin
  (def! or

-   (macro (l)
+   (macro l

          (def! _or
            (lambda (l)
              (cond ((null? l) #f)
          (def! _or
            (lambda (l)
              (cond ((null? l) #f)


@@ -84,7 +84,7 @@
 
 (begin
  (def! and
 
 (begin
  (def! and

-   (macro (l)
+   (macro l

          (def! _and
            (lambda (l)
              (cond ((null? l) #t)
          (def! _and
            (lambda (l)
              (cond ((null? l) #t)


@@ -102,7 +102,9 @@
                    )
              )
            )
                    )
              )
            )

-         (_and l)))
+         (_and l)
+         )
+   )

  'and)
 
                                        ; execute to resolve macros
  'and)
 
                                        ; execute to resolve macros


@@ -111,7 +113,7 @@
 
 (begin
  (def! quasiquote
 
 (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
          (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)
          )
    )
  'quasiquote)

+

                                        ;
                                        ; Define a variable without returning the value
                                        ; Useful when defining functions to avoid
                                        ;
                                        ; Define a variable without returning the value
                                        ; Useful when defining functions to avoid


@@ -241,7 +245,7 @@
 
 (begin
  (def! define
 
 (begin
  (def! define

-   (macro (first rest)
+   (macro (first . rest)

                                        ; check for alternate lambda definition form
 
          (cond ((list? first)
                                        ; check for alternate lambda definition form
 
          (cond ((list? first)


@@ -257,9 +261,11 @@
                 (set! rest (car rest))
                 )
                )
                 (set! rest (car rest))
                 )
                )

-         `(begin
-           (def (quote ,first) ,rest)
-           (quote ,first))
+         (def! result `(,begin
+                        (,def (,quote ,first) ,rest)
+                        (,quote ,first))
+           )
+         result

          )
    )
  'define
          )
    )
  'define


@@ -275,22 +281,11 @@
 
 (define (caddr l) (car (cdr (cdr l))))
 
 
 (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 <condition> <if-true>)
                                        ; (if <condition> <if-true> <if-false)
 
 (define if
                                        ; (if <condition> <if-true>)
                                        ; (if <condition> <if-true> <if-false)
 
 (define if

-  (macro (test args)
+  (macro (test . args)

         (cond ((null? (cdr args))
                `(cond (,test ,(car args)))
                )
         (cond ((null? (cdr args))
                `(cond (,test ,(car args)))
                )


@@ -309,18 +304,18 @@
 
                                        ; simple math operators
 
 
                                        ; simple math operators
 

-(define zero? (macro (value rest) `(eq? ,value 0)))
+(define zero? (macro (value) `(eq? ,value 0)))

 
 (zero? 1)
 (zero? 0)
 (zero? "hello")
 
 
 (zero? 1)
 (zero? 0)
 (zero? "hello")
 

-(define positive? (macro (value rest) `(> ,value 0)))
+(define positive? (macro (value) `(> ,value 0)))

 
 (positive? 12)
 (positive? -12)
 
 
 (positive? 12)
 (positive? -12)
 

-(define negative? (macro (value rest) `(< ,value 0)))
+(define negative? (macro (value) `(< ,value 0)))

 
 (negative? 12)
 (negative? -12)
 
 (negative? 12)
 (negative? -12)


@@ -330,7 +325,7 @@
 (abs 12)
 (abs -12)
 
 (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)))
                   (while (not (null? rest))
                     (cond ((< first (car rest))
                            (set! first (car rest)))


@@ -343,7 +338,7 @@
 (max 1 2 3)
 (max 3 2 1)
 
 (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)))
                   (while (not (null? rest))
                     (cond ((> first (car rest))
                            (set! first (car rest)))


@@ -371,6 +366,17 @@
 (odd? -1)
 
 
 (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
                                        ; 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
                                        ; (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))
         (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*
                                        ; (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
 
                                        ;
                                        ; make the list of names in the let


@@ -497,11 +503,11 @@
 
 (let* ((x 1) (y x)) (+ x y))
 
 
 (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))
 
 
 (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))
 
 
 (unless #f (write 'unless))
 


@@ -542,7 +548,7 @@
 (equal? '(a b c) '(a b c))
 (equal? '(a b c) '(a b b))
 
 (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
                             )
                      (cond ((null? list)
                             #f
                             )


@@ -651,13 +657,13 @@
 (char-downcase #\0)
 (char-downcase #\space)
 
 (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
 
 (display "apply\n")
 (apply cons '(a b))
 
 (define map

-  (lexpr (proc lists)
+  (lambda (proc . lists)

         (define (args lists)
           (cond ((null? lists) ())
                 (else
         (define (args lists)
           (cond ((null? lists) ())
                 (else


@@ -685,7 +691,7 @@
 
 (map cadr '((a b) (d e) (g h)))
 
 
 (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))
 
                        (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")
 
                          (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")
                               (apply for-each proc (_string-ml strings))))
 
 (string-for-each write-char "IBM\n")


@@ -732,7 +738,7 @@
 
 
 (define repeat
 
 
 (define repeat

-  (macro (count rest)
+  (macro (count . rest)

         (define counter '__count__)
         (cond ((pair? count)
                (set! counter (car count))
         (define counter '__count__)
         (cond ((pair? count)
                (set! counter (car count))


@@ -754,7 +760,7 @@
 (repeat (x 3) (write 'goodbye x))
 
 (define case
 (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)
                                        ; 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"))
 
 
 (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)))
                                        ;
 ;
 ;                            (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 ced182f6aeddfeb9a2b617f0f4b05293c4fc2d04..c3dd2ed23696287f3d47c2364d0ebd1cb2a4274d 100644 (file)
--- 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
  * 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
  * 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:
        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 */
                        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);
                                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;
 
                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 71aebed0d7b55b36435e7d0bb0b967075cae9021..e72281db8391a9c47c24ccff4e41e1d82ab22e1a 100644 (file)
--- 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)
 {
 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);
        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);
        code = ao_lisp_cons_fetch(0);

-       struct ao_lisp_cons     *arg;
-       int                     f;
-

        if (!lambda)
                return AO_LISP_NIL;
 
        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);
        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);
 }
 
        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)
 {
 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_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;
        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");
 
        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;
 
        /* 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_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);
        }
 
                        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);
 
        /* 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);
 
        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);
                        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();
        }
        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 c4ba9d9426bf5c72b9274029d7ee7dfcdd8a5205..783ab378a95c9cfe9fbb7db599aa9d7c434938d4 100644 (file)
--- 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",
 string[string] type_map = {
        "lambda" => "LAMBDA",
        "nlambda" => "NLAMBDA",

-       "lexpr" => "LEXPR",

        "macro" => "MACRO",
        "f_lambda" => "F_LAMBDA",
        "macro" => "MACRO",
        "f_lambda" => "F_LAMBDA",

-       "f_lexpr" => "F_LEXPR",

        "atom" => "atom",
 };
 
        "atom" => "atom",
 };
 

diff --git a/src/lisp/ao_lisp_make_const.c b/src/lisp/ao_lisp_make_const.c
index f3ea6be065151f723f7ef1bf6aa090033e5eb0b1..6e4b411ee351c9882d1b02b9dbf10ad01ad46757 100644 (file)
--- 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;
        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;
 
        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;
 
                if ((p = ao_is_macro(cons->car)))
                        break;
 

-               cons = ao_lisp_poly_cons(cons->cdr);
+               list = cons->cdr;

                p = AO_LISP_NIL;
                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;
                        }
                        m = ao_has_macro(cons->car);
                        if (m) {
                                p = m;
                                break;
                        }

-                       cons = ao_lisp_poly_cons(cons->cdr);
+                       list = cons->cdr;

                }
                break;
 
                }
                break;