adding support for optional arguments

error checking formal argument lists
making filter preserve the order of elements in the input list

femtolisp/compiler.lsp

@@ -26,6 +26,7 @@
 	  :add2 :sub2 :neg :largc :lvargc
 	  :loada0 :loada1 :loadc00 :loadc01 :call.l :tcall.l
 	  :brne :brne.l :cadr :brnn :brnn.l :brn :brn.l
+	  :optargs
 	  
 	  dummy_t dummy_f dummy_nil]))
     (for 0 (1- (length keys))
@@ -171,7 +172,7 @@
 		      ((number? nxt)
 		       (case vi
 			 ((:loadv.l :loadg.l :setg.l :loada.l :seta.l
-			   :largc :lvargc :call.l :tcall.l)
+			   :largc :lvargc :call.l :tcall.l :optargs)
 			  (io.write bcode (int32 nxt))
 			  (set! i (+ i 1)))
 			 
@@ -346,6 +347,7 @@
     (if (and (pair? head)
 	     (eq? (car head) 'lambda)
 	     (list? (cadr head))
+	     (every symbol? (cadr head))
 	     (not (length> (cadr head) 255)))
 	(compile-let  g env tail? x)
 	(compile-call g env tail? x))))
@@ -505,6 +507,28 @@
 		    (else ())))))
     (lambda (expr) (delete-duplicates (get-defined-vars- expr)))))
 
+(define (lambda-vars l)
+  (define (check-formals l o)
+    (or
+     (null? l) (symbol? l)
+     (and
+      (pair? l)
+      (or (symbol? (car l))
+	  (and (pair? (car l))
+	       (or (every pair? (cdr l))
+		   (error (string "compile error: invalid argument list "
+				  o ". optional arguments must come last."))))
+	  (error (string "compile error: invalid formal argument " (car l)
+			 " in list " o)))
+      (check-formals (cdr l) o))
+     (if (eq? l o)
+	 (error (string "compile error: invalid argument list " o))
+	 (error (string "compile error: invalid formal argument " l
+			" in list " o)))))
+  (check-formals l l)
+  (map (lambda (s) (if (pair? s) (car s) s))
+       (to-proper l)))
+
 (define compile-f-
   (let ((*defines-processed-token* (gensym)))
     ; to eval a top-level expression we need to avoid internal define
@@ -529,23 +553,34 @@
       
       (let ((g    (make-code-emitter))
 	    (args (cadr f))
+	    (vars (lambda-vars (cadr f)))
+	    (opta (filter pair? (cadr f)))
 	    (name (if (eq? (lastcdr f) *defines-processed-token*)
 		      'lambda
 		      (lastcdr f))))
-	(cond ((not (null? let?))      (emit g :let))
+	(let ((nargs (if (atom? args) 0 (length args))))
-	      ((length> args 255)      (emit g (if (null? (lastcdr args))
+
-						   :largc :lvargc)
+	  ; emit argument checking prologue
-					     (length args)))
+	  (if (not (null? opta))
-	      ((null? (lastcdr args))  (emit g :argc  (length args)))
+	      (begin (bcode:indexfor g (list->vector (map cadr opta)))
-	      (else  (emit g :vargc (if (atom? args) 0 (length args)))))
+		     (emit g :optargs (- nargs (length opta)))))
-	(compile-in g (cons (to-proper args) env) #t
+
-		    (if (eq? (lastcdr f) *defines-processed-token*)
+	  (cond ((not (null? let?))      (emit g :let))
-			(caddr f)
+		((> nargs 255)           (emit g (if (null? (lastcdr args))
-			(lambda-body f)))
+						     :largc :lvargc)
-	(emit g :ret)
+					       nargs))
-	(values (function (encode-byte-code (bcode:code g))
+		((null? (lastcdr args))  (emit g :argc  nargs))
-			  (const-to-idx-vec g) name)
+		(else  (emit g :vargc nargs)))
-		(aref g 3))))))
+
+	  ; compile body and return
+	  (compile-in g (cons vars env) #t
+		      (if (eq? (lastcdr f) *defines-processed-token*)
+			  (caddr f)
+			  (lambda-body f)))
+	  (emit g :ret)
+	  (values (function (encode-byte-code (bcode:code g))
+			    (const-to-idx-vec g) name)
+		  (aref g 3)))))))
 
 (define (compile f) (compile-f () f))
 
@@ -604,7 +639,7 @@
 		  (princ (number->string (aref code i)))
 		  (set! i (+ i 1)))
 		 
-		 ((:loada.l :seta.l :largc :lvargc :call.l :tcall.l)
+		 ((:loada.l :seta.l :largc :lvargc :call.l :tcall.l :optargs)
 		  (princ (number->string (ref-int32-LE code i)))
 		  (set! i (+ i 4)))
 

femtolisp/flisp.c

@@ -931,6 +931,30 @@ static value_t apply_cl(uint32_t nargs)
             Stack[SP-1] = 0;
             curr_frame = SP;
             NEXT_OP;
+        OP(OP_OPTARGS)
+            n = GET_INT32(ip); ip+=4;
+            v = fn_vals(Stack[bp-1]);
+            v = vector_elt(v, 0);
+            if (nargs >= n) {  // if we have all required args
+                s = vector_size(v);
+                n += s;
+                if (nargs < n) {  // but not all optional args
+                    i = n - nargs;
+                    SP += i;
+                    Stack[SP-1] = Stack[SP-i-1];
+                    Stack[SP-2] = Stack[SP-i-2];
+                    Stack[SP-3] = Stack[SP-i-3];
+                    Stack[SP-4] = Stack[SP-i-4];
+                    Stack[SP-5] = Stack[SP-i-5];
+                    curr_frame = SP;
+                    s = s - i;
+                    for(n=0; n < i; n++) {
+                        Stack[bp+nargs+n] = vector_elt(v, s+n);
+                    }
+                    nargs += i;
+                }
+            }
+            NEXT_OP;
         OP(OP_NOP) NEXT_OP;
         OP(OP_DUP) SP++; Stack[SP-1] = Stack[SP-2]; NEXT_OP;
         OP(OP_POP) POPN(1); NEXT_OP;
@@ -1662,7 +1686,7 @@ static value_t apply_cl(uint32_t nargs)
 #endif
 }
 
-static uint32_t compute_maxstack(uint8_t *code, size_t len)
+static uint32_t compute_maxstack(uint8_t *code, size_t len, value_t vals)
 {
     uint8_t *ip = code+4, *end = code+len;
     uint8_t op;
@@ -1688,6 +1712,12 @@ static uint32_t compute_maxstack(uint8_t *code, size_t len)
             sp += (n+2);
             break;
         case OP_LET: break;
+        case OP_OPTARGS:
+            ip += 4;
+            assert(isvector(vals));
+            if (vector_size(vals) > 0)
+                sp += vector_size(vector_elt(vals, 0));
+            break;
 
         case OP_TCALL: case OP_CALL:
             n = *ip++;  // nargs
@@ -1824,7 +1854,7 @@ static value_t fl_function(value_t *args, uint32_t nargs)
         for(i=0; i < sz; i++)
             data[i] -= 48;
     }
-    uint32_t ms = compute_maxstack((uint8_t*)data, cv_len(arr));
+    uint32_t ms = compute_maxstack((uint8_t*)data, cv_len(arr), args[1]);
     PUT_INT32(data, ms);
     function_t *fn = (function_t*)alloc_words(4);
     value_t fv = tagptr(fn, TAG_FUNCTION);

femtolisp/opcodes.h

@@ -27,6 +27,7 @@ enum {
     OP_TAPPLY, OP_ADD2, OP_SUB2, OP_NEG, OP_LARGC, OP_LVARGC,
     OP_LOADA0, OP_LOADA1, OP_LOADC00, OP_LOADC01, OP_CALLL, OP_TCALLL,
     OP_BRNE, OP_BRNEL, OP_CADR, OP_BRNN, OP_BRNNL, OP_BRN, OP_BRNL,
+    OP_OPTARGS,
 
     OP_BOOL_CONST_T, OP_BOOL_CONST_F, OP_THE_EMPTY_LIST,
 
@@ -69,7 +70,7 @@ enum {
     &&L_OP_LVARGC,                                                      \
     &&L_OP_LOADA0, &&L_OP_LOADA1, &&L_OP_LOADC00, &&L_OP_LOADC01,       \
     &&L_OP_CALLL, &&L_OP_TCALLL, &&L_OP_BRNE, &&L_OP_BRNEL, &&L_OP_CADR,\
-    &&L_OP_BRNN, &&L_OP_BRNNL, &&L_OP_BRN, &&L_OP_BRNL                  \
+    &&L_OP_BRNN, &&L_OP_BRNNL, &&L_OP_BRN, &&L_OP_BRNL, &&L_OP_OPTARGS  \
     }
 
 #define VM_APPLY_LABELS                                                 \

femtolisp/system.lsp

@@ -224,15 +224,16 @@
 		(set-car! lst (f (car lst)))
 		(set! lst (cdr lst)))))
 
-(define filter
+(define (filter pred lst)
-  (letrec ((filter-
+  (define (filter- f lst acc)
-	    (lambda (pred lst accum)
+    (cdr
-	      (cond ((null? lst) accum)
+     (prog1 acc
-		    ((pred (car lst))
+      (while (pair? lst)
-		     (filter- pred (cdr lst) (cons (car lst) accum)))
+	     (begin (if (pred (car lst))
-		    (#t
+			(set! acc
-		     (filter- pred (cdr lst) accum))))))
+			      (cdr (set-cdr! acc (cons (car lst) ())))))
-    (lambda (pred lst) (filter- pred lst ()))))
+		    (set! lst (cdr lst)))))))
+  (filter- pred lst (list ())))
 
 (define separate
   (letrec ((separate-

femtolisp/todo

@@ -159,7 +159,7 @@ bugs:
   . write a function to evaluate directly from list to list, use it for
     Nth arg and for user function rest args
   . modify vararg builtins accordingly
-- filter should be stable. right now it reverses.
+* filter should be stable. right now it reverses.
 
 
 femtoLisp3...with symbolic C interface
@@ -975,7 +975,8 @@ consolidated todo list as of 7/8:
 - remaining c types
 - remaining cvalues functions
 - finish ios
-- optional and keyword arguments
+* optional arguments
+- keyword arguments
 - some kind of record, struct, or object system
 
 - special efficient reader for #array
@@ -1042,6 +1043,8 @@ new evaluator todo:
 * try removing MAX_ARGS trickery
 - apply optimization, avoid redundant list copying calling vararg fns
 - let eversion
+- variable analysis - avoid holding references to values in frames
+  captured by closures but not used inside them
 * lambda lifting
 * let optimization
 * fix equal? on functions

femtolisp/unittest.lsp

@@ -116,6 +116,14 @@
 (assert (equal? (apply f (iota 995))  '(994)))
 (assert (equal? (apply f (iota 1000)) '(994 995 996 997 998 999)))
 
+; optional arguments
+(assert (equal? ((lambda ((b 0)) b)) 0))
+(assert (equal? ((lambda (a (b 2)) (list a b)) 1) '(1 2)))
+(assert (equal? ((lambda (a (b 2)) (list a b)) 1 3) '(1 3)))
+(assert (equal? ((lambda (a (b 2) (c 3)) (list a b c)) 1) '(1 2 3)))
+(assert (equal? ((lambda (a (b 2) (c 3)) (list a b c)) 1 8) '(1 8 3)))
+(assert (equal? ((lambda (a (b 2) (c 3)) (list a b c)) 1 8 9) '(1 8 9)))
+
 ; ok, a couple end-to-end tests as well
 (define (fib n) (if (< n 2) n (+ (fib (- n 1)) (fib (- n 2)))))
 (assert (equal? (fib 20) 6765))