shithub: femtolisp

Download patch

ref: 4cb9685266101394b296053de8957ce9407cfe77
parent: fe72c101e29f4f99f42547d3c8b5673e851bb5ef
author: JeffBezanson <jeff.bezanson@gmail.com>
date: Thu Mar 26 23:06:55 EDT 2009

adding support for arbitrarily-long argument lists
argument lists are heap-allocated after a certain cutoff (currently 127)


--- a/femtolisp/cvalues.c
+++ b/femtolisp/cvalues.c
@@ -382,16 +382,6 @@
     return cv;
 }
 
-static void array_init_fromargs(char *dest, value_t *vals, size_t cnt,
-                                fltype_t *eltype, size_t elsize)
-{
-    size_t i;
-    for(i=0; i < cnt; i++) {
-        cvalue_init(eltype, vals[i], dest);
-        dest += elsize;
-    }
-}
-
 static int isarray(value_t v)
 {
     return iscvalue(v) && cv_class((cvalue_t*)ptr(v))->eltype != NULL;
@@ -428,23 +418,23 @@
     sz = elsize * cnt;
 
     if (isvector(arg)) {
-        array_init_fromargs((char*)dest, &vector_elt(arg,0), cnt,
-                            eltype, elsize);
+        for(i=0; i < cnt; i++) {
+            cvalue_init(eltype, vector_elt(arg,i), dest);
+            dest += elsize;
+        }
         return 0;
     }
     else if (iscons(arg) || arg==NIL) {
         i = 0;
         while (iscons(arg)) {
-            if (SP >= N_STACK)
-                break;
-            PUSH(car_(arg));
+            if (i == cnt) { i++; break; } // trigger error
+            cvalue_init(eltype, car_(arg), dest);
             i++;
+            dest += elsize;
             arg = cdr_(arg);
         }
         if (i != cnt)
             lerror(ArgError, "array: size mismatch");
-        array_init_fromargs((char*)dest, &Stack[SP-i], i, eltype, elsize);
-        POPN(i);
         return 0;
     }
     else if (iscvalue(arg)) {
@@ -473,19 +463,25 @@
 
 value_t cvalue_array(value_t *args, u_int32_t nargs)
 {
-    size_t elsize, cnt, sz;
+    size_t elsize, cnt, sz, i;
+    value_t arg;
 
     if (nargs < 1)
         argcount("array", nargs, 1);
 
     cnt = nargs - 1;
+    if (nargs > MAX_ARGS)
+        cnt += llength(args[MAX_ARGS]);
     fltype_t *type = get_array_type(args[0]);
     elsize = type->elsz;
     sz = elsize * cnt;
 
     value_t cv = cvalue(type, sz);
-    array_init_fromargs(cv_data((cvalue_t*)ptr(cv)), &args[1], cnt,
-                        type->eltype, elsize);
+    char *dest = cv_data((cvalue_t*)ptr(cv));
+    FOR_ARGS(i,1,arg,args) {
+        cvalue_init(type->eltype, arg, dest);
+        dest += elsize;
+    }
     return cv;
 }
 
@@ -1040,14 +1036,15 @@
     int64_t Saccum = carryIn;
     double Faccum=0;
     uint32_t i;
+    value_t arg=NIL;
 
-    for(i=0; i < nargs; i++) {
-        if (isfixnum(args[i])) {
-            Saccum += numval(args[i]);
+    FOR_ARGS(i,0,arg,args) {
+        if (isfixnum(arg)) {
+            Saccum += numval(arg);
             continue;
         }
-        else if (iscprim(args[i])) {
-            cprim_t *cp = (cprim_t*)ptr(args[i]);
+        else if (iscprim(arg)) {
+            cprim_t *cp = (cprim_t*)ptr(arg);
             void *a = cp_data(cp);
             int64_t i64;
             switch(cp_numtype(cp)) {
@@ -1073,7 +1070,7 @@
             continue;
         }
     add_type_error:
-        type_error("+", "number", args[i]);
+        type_error("+", "number", arg);
     }
     if (Faccum != 0) {
         Faccum += Uaccum;
@@ -1146,14 +1143,15 @@
     uint64_t Uaccum=1;
     double Faccum=1;
     uint32_t i;
+    value_t arg=NIL;
 
-    for(i=0; i < nargs; i++) {
-        if (isfixnum(args[i])) {
-            Saccum *= numval(args[i]);
+    FOR_ARGS(i,0,arg,args) {
+        if (isfixnum(arg)) {
+            Saccum *= numval(arg);
             continue;
         }
-        else if (iscprim(args[i])) {
-            cprim_t *cp = (cprim_t*)ptr(args[i]);
+        else if (iscprim(arg)) {
+            cprim_t *cp = (cprim_t*)ptr(arg);
             void *a = cp_data(cp);
             int64_t i64;
             switch(cp_numtype(cp)) {
@@ -1179,7 +1177,7 @@
             continue;
         }
     mul_type_error:
-        type_error("*", "number", args[i]);
+        type_error("*", "number", arg);
     }
     if (Faccum != 1) {
         Faccum *= Uaccum;
@@ -1408,14 +1406,11 @@
     if (nargs == 0)
         return fixnum(-1);
     v = args[0];
-    i = 1;
-    while (i < (int)nargs) {
-        e = args[i];
+    FOR_ARGS(i,1,e,args) {
         if (bothfixnums(v, e))
             v = v & e;
         else
             v = fl_bitwise_op(v, e, 0, "logand");
-        i++;
     }
     return v;
 }
@@ -1427,14 +1422,11 @@
     if (nargs == 0)
         return fixnum(0);
     v = args[0];
-    i = 1;
-    while (i < (int)nargs) {
-        e = args[i];
+    FOR_ARGS(i,1,e,args) {
         if (bothfixnums(v, e))
             v = v | e;
         else
             v = fl_bitwise_op(v, e, 1, "logior");
-        i++;
     }
     return v;
 }
@@ -1446,14 +1438,11 @@
     if (nargs == 0)
         return fixnum(0);
     v = args[0];
-    i = 1;
-    while (i < (int)nargs) {
-        e = args[i];
+    FOR_ARGS(i,1,e,args) {
         if (bothfixnums(v, e))
             v = fixnum(numval(v) ^ numval(e));
         else
             v = fl_bitwise_op(v, e, 2, "logxor");
-        i++;
     }
     return v;
 }
--- a/femtolisp/flisp.c
+++ b/femtolisp/flisp.c
@@ -73,7 +73,7 @@
       "vector", "aref", "aset!", "length", "for",
       "", "", "" };
 
-#define N_STACK 98304
+#define N_STACK 131072
 value_t Stack[N_STACK];
 uint32_t SP = 0;
 
@@ -636,7 +636,10 @@
         c->cdr = tagptr(c+1, TAG_CONS);
         c++;
     }
-    (c-1)->cdr = *plastcdr;
+    if (nargs > MAX_ARGS)
+        (c-2)->cdr = (c-1)->car;
+    else
+        (c-1)->cdr = *plastcdr;
     POPN(nargs);
 }
 
@@ -646,6 +649,32 @@
     if (selfevaluating(xpr)) { return (xpr); }  \
     else { e=(xpr); goto eval_top; } } while (0)
 
+/* eval a list of expressions, giving a list of the results */
+static value_t evlis(value_t *pv, uint32_t penv)
+{
+    PUSH(NIL);
+    PUSH(NIL);
+    value_t *rest = &Stack[SP-1];
+    value_t a, v = *pv;
+    while (iscons(v)) {
+        a = car_(v);
+        v = eval(a);
+        PUSH(v);
+        v = mk_cons();
+        car_(v) = Stack[SP-1];
+        cdr_(v) = NIL;
+        (void)POP();
+        if (*rest == NIL)
+            Stack[SP-2] = v;
+        else
+            cdr_(*rest) = v;
+        *rest = v;
+        v = *pv = cdr_(*pv);
+    }
+    (void)POP();
+    return POP();
+}
+
 static value_t do_trycatch(value_t expr, uint32_t penv)
 {
     value_t v;
@@ -659,7 +688,8 @@
             v = FL_F;   // 1-argument form
         }
         else {
-            Stack[SP-1] = eval(car_(v));
+            v = car_(v);
+            Stack[SP-1] = eval(v);
             v = apply1(Stack[SP-1], lasterror);
         }
     }
@@ -719,7 +749,7 @@
             raise(list2(UnboundError, e));
         return v;
     }
-    if (__unlikely(SP >= (N_STACK-64)))
+    if (__unlikely(SP >= (N_STACK-MAX_ARGS)))
         lerror(MemoryError, "eval: stack overflow");
     saveSP = SP;
     v = car_(e);
@@ -740,7 +770,13 @@
         // handle builtin function
         // evaluate argument list, placing arguments on stack
         while (iscons(v)) {
-            v = eval(car_(v));
+            if (SP-saveSP-1 == MAX_ARGS) {
+                v = evlis(&Stack[saveSP], penv);
+                PUSH(v);
+                break;
+            }
+            v = car_(v);
+            v = eval(v);
             PUSH(v);
             v = Stack[saveSP] = cdr_(Stack[saveSP]);
         }
@@ -756,7 +792,8 @@
             break;
         case F_SETQ:
             e = car(Stack[saveSP]);
-            v = eval(car(cdr_(Stack[saveSP])));
+            v = car(cdr_(Stack[saveSP]));
+            v = eval(v);
             pv = &Stack[penv];
             while (1) {
                 f = *pv++;
@@ -843,7 +880,8 @@
                     // evaluate body forms
                     if (iscons(*pv)) {
                         while (iscons(cdr_(*pv))) {
-                            v = eval(car_(*pv));
+                            v = car_(*pv);
+                            v = eval(v);
                             *pv = cdr_(*pv);
                         }
                         tail_eval(car_(*pv));
@@ -899,7 +937,8 @@
             pv = &Stack[saveSP];
             if (iscons(*pv)) {
                 while (iscons(cdr_(*pv))) {
-                    (void)eval(car_(*pv));
+                    v = car_(*pv);
+                    (void)eval(v);
                     *pv = cdr_(*pv);
                 }
                 tail_eval(car_(*pv));
@@ -971,8 +1010,21 @@
             cdr(v=Stack[SP-2]) = Stack[SP-1];
             break;
         case F_VECTOR:
-            v = alloc_vector(nargs, 0);
+            if (nargs > MAX_ARGS) {
+                i = llength(Stack[SP-1]);
+                nargs--;
+            }
+            else i = 0;
+            v = alloc_vector(nargs+i, 0);
             memcpy(&vector_elt(v,0), &Stack[saveSP+1], nargs*sizeof(value_t));
+            if (i > 0) {
+                e = Stack[SP-1];
+                while (iscons(e)) {
+                    vector_elt(v,nargs) = car_(e);
+                    nargs++;
+                    e = cdr_(e);
+                }
+            }
             break;
         case F_LENGTH:
             argcount("length", nargs, 1);
@@ -1084,7 +1136,9 @@
             break;
         case F_ADD:
             s = 0;
-            for (i=saveSP+1; i < (int)SP; i++) {
+            i = saveSP+1;
+            if (nargs > MAX_ARGS) goto add_ovf;
+            for (; i < (int)SP; i++) {
                 if (__likely(isfixnum(Stack[i]))) {
                     s += numval(Stack[i]);
                     if (__unlikely(!fits_fixnum(s))) {
@@ -1125,17 +1179,25 @@
                 }
             }
             else {
-                Stack[i+1] = fl_neg(fl_add_any(&Stack[i+1], nargs-1, 0));
+                // we need to pass the full arglist on to fl_add_any
+                // so it can handle rest args properly
+                PUSH(Stack[i]);
+                Stack[i] = fixnum(0);
+                Stack[i+1] = fl_neg(fl_add_any(&Stack[i], nargs, 0));
+                Stack[i] = POP();
             }
             v = fl_add_any(&Stack[i], 2, 0);
             break;
         case F_MUL:
             accum = 1;
-            for (i=saveSP+1; i < (int)SP; i++) {
+            i = saveSP+1;
+            if (nargs > MAX_ARGS) goto mul_ovf;
+            for (; i < (int)SP; i++) {
                 if (__likely(isfixnum(Stack[i]))) {
                     accum *= numval(Stack[i]);
                 }
                 else {
+                mul_ovf:
                     v = fl_mul_any(&Stack[i], SP-i, accum);
                     SP = saveSP;
                     return v;
@@ -1153,8 +1215,12 @@
                 v = fl_div2(fixnum(1), Stack[i]);
             }
             else {
-                if (nargs > 2)
-                    Stack[i+1] = fl_mul_any(&Stack[i+1], nargs-1, 1);
+                if (nargs > 2) {
+                    PUSH(Stack[i]);
+                    Stack[i] = fixnum(1);
+                    Stack[i+1] = fl_mul_any(&Stack[i], nargs, 1);
+                    Stack[i] = POP();
+                }
                 v = fl_div2(Stack[i], Stack[i+1]);
             }
             break;
@@ -1268,6 +1334,10 @@
                 assert(!isspecial(f));
                 // unpack arglist onto the stack
                 while (iscons(v)) {
+                    if (SP-saveSP-1 == MAX_ARGS) {
+                        PUSH(v);
+                        break;
+                    }
                     PUSH(car_(v));
                     v = cdr_(v);
                 }
@@ -1320,7 +1390,8 @@
                         lerror(ArgError, "apply: too many arguments");
                     break;
                 }
-                v = eval(car_(v));
+                v = car_(v);
+                v = eval(v);
                 PUSH(v);
                 *argsyms = cdr_(*argsyms);
                 v = Stack[saveSP] = cdr_(Stack[saveSP]);
--- a/femtolisp/flisp.h
+++ b/femtolisp/flisp.h
@@ -99,6 +99,21 @@
 #define POP()   (Stack[--SP])
 #define POPN(n) (SP-=(n))
 
+// maximum number of explicit arguments. the 128th arg is a list of rest args.
+// the largest value nargs can have is MAX_ARGS+1
+#define MAX_ARGS 127
+
+// utility for iterating over all arguments in a builtin
+// i=index, i0=start index, arg = var for each arg, args = arg array
+// assumes "nargs" is the argument count
+// modifies args[MAX_ARGS] when nargs==MAX_ARGS+1
+#define FOR_ARGS(i, i0, arg, args)                                      \
+    for(i=i0; (((size_t)i<nargs ||                                      \
+                (i>MAX_ARGS && iscons(args[MAX_ARGS]))) &&              \
+               ((i>=MAX_ARGS?(arg=car_(args[MAX_ARGS]),                 \
+                              args[MAX_ARGS]=cdr_(args[MAX_ARGS])) :    \
+                 (arg = args[i])) || 1)); i++)
+
 enum {
     // special forms
     F_QUOTE=0, F_COND, F_IF, F_AND, F_OR, F_WHILE, F_LAMBDA,
--- a/femtolisp/iostream.c
+++ b/femtolisp/iostream.c
@@ -169,7 +169,7 @@
 
 static void do_ioprint(value_t *args, u_int32_t nargs, int princ, char *fname)
 {
-    if (nargs < 2)
+    if (nargs < 2 || nargs > MAX_ARGS)
         argcount(fname, nargs, 2);
     ios_t *s = toiostream(args[0], fname);
     unsigned i;
--- a/femtolisp/rule30.lsp
+++ b/femtolisp/rule30.lsp
@@ -36,5 +36,5 @@
 (for-each (lambda (n)
 	    (begin
 	      (princ (bin-draw (pad0 (number->string n 2) 63)))
-	      (terpri)))
+	      (newline)))
 	  (nestlist rule30-step (uint64 0x0000000080000000) 32))
--- a/femtolisp/string.c
+++ b/femtolisp/string.c
@@ -107,11 +107,12 @@
 {
     if (nargs == 1 && isstring(args[0]))
         return args[0];
-    value_t buf = fl_buffer(NULL, 0);
+    value_t arg, buf = fl_buffer(NULL, 0);
     ios_t *s = value2c(ios_t*,buf);
     uint32_t i;
-    for (i=0; i < nargs; i++)
+    FOR_ARGS(i,0,arg,args) {
         print(s, args[i], 1);
+    }
     PUSH(buf);
     value_t outp = stream_to_string(&Stack[SP-1]);
     (void)POP();
--- a/femtolisp/system.lsp
+++ b/femtolisp/system.lsp
@@ -486,9 +486,9 @@
 	,expr
 	(princ "Elapsed time: " (- (time.now) ,t0) " seconds\n")))))
 
-(define (terpri) (princ *linefeed*))
+(define (newline) (princ *linefeed*))
 (define (display x) (princ x) #t)
-(define (println . args) (prog1 (apply print args) (terpri)))
+(define (println . args) (prog1 (apply print args) (newline)))
 
 (define (vu8 . elts) (apply array (cons 'uint8 elts)))
 
@@ -591,12 +591,12 @@
 	     (set! that V)
 	     #t))))
   (define (reploop)
-    (when (trycatch (and (prompt) (terpri))
+    (when (trycatch (and (prompt) (newline))
 		    print-exception)
-	  (begin (terpri)
+	  (begin (newline)
 		 (reploop))))
   (reploop)
-  (terpri))
+  (newline))
 
 (define (print-exception e)
   (cond ((and (pair? e)
--- a/femtolisp/table.c
+++ b/femtolisp/table.c
@@ -83,11 +83,14 @@
 
 value_t fl_table(value_t *args, uint32_t nargs)
 {
-    if (nargs & 1)
+    size_t cnt = (size_t)nargs;
+    if (nargs > MAX_ARGS)
+        cnt += llength(args[MAX_ARGS]);
+    if (cnt & 1)
         lerror(ArgError, "table: arguments must come in pairs");
     value_t nt;
     // prevent small tables from being added to finalizer list
-    if (nargs <= HT_N_INLINE) {
+    if (cnt <= HT_N_INLINE) {
         tabletype->vtable->finalize = NULL;
         nt = cvalue(tabletype, sizeof(htable_t));
         tabletype->vtable->finalize = free_htable;
@@ -96,10 +99,15 @@
         nt = cvalue(tabletype, 2*sizeof(void*));
     }
     htable_t *h = (htable_t*)cv_data((cvalue_t*)ptr(nt));
-    htable_new(h, nargs/2);
+    htable_new(h, cnt/2);
     uint32_t i;
-    for(i=0; i < nargs; i+=2)
-        equalhash_put(h, (void*)args[i], (void*)args[i+1]);
+    value_t k=NIL, arg=NIL;
+    FOR_ARGS(i,0,arg,args) {
+        if (i&1)
+            equalhash_put(h, (void*)k, (void*)arg);
+        else
+            k = arg;
+    }
     return nt;
 }
 
--- a/femtolisp/todo
+++ b/femtolisp/todo
@@ -153,6 +153,12 @@
 * prettyprint size measuring is not utf-8 correct
 - stack is too limited. possibly allocate user frames with alloca so the
   only limit is the process stack size.
+* argument list length is too limited.
+  need to fix it for: +,-,*,/,&,|,$,list,vector,apply,string,array
+  . for builtins, make Nth argument list of rest args
+  . 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
 
 
 femtoLisp3...with symbolic C interface
--- a/femtolisp/unittest.lsp
+++ b/femtolisp/unittest.lsp
@@ -51,6 +51,8 @@
 (assert (= (/ 2) 0))
 (assert (= (/ 2.0) 0.5))
 
+(assert (= (- 4999950000 4999941999) 8001))
+
 ; tricky cases involving INT_MIN
 (assert (< (- #uint32(0x80000000)) 0))
 (assert (> (- #int32(0x80000000)) 0))
@@ -69,6 +71,9 @@
 
 ; this crashed once
 (for 1 10 (lambda (i) 0))
+
+; long argument lists
+(assert (= (apply + (iota 100000)) 4999950000))
 
 ; ok, a couple end-to-end tests as well
 (define (fib n) (if (< n 2) n (+ (fib (- n 1)) (fib (- n 2)))))