shithub: femtolisp

Info  •  Files  •  Log  •  Branches

fixing a bug in optional args + rest args with no required arguments
adding some code for keyword argument processing

--- a/femtolisp/Makefile

+++ b/femtolisp/Makefile

@@ -12,7 +12,7 @@

 LIBS = $(LLT) -lm

 DEBUGFLAGS = -g -DDEBUG $(FLAGS)

-SHIPFLAGS = -O3 -DNDEBUG $(FLAGS)

+SHIPFLAGS = -O2 -DNDEBUG $(FLAGS)

 default: release test

--- a/femtolisp/compiler.lsp

+++ b/femtolisp/compiler.lsp

@@ -574,7 +574,7 @@

 	  ; emit argument checking prologue

 	  (if (not (null? opta))

-	      (begin (emit g 'optargs (if (null? atail) nreq (- nreq)) nargs)

+	      (begin (emit g 'optargs nreq (if (null? atail) nargs (- nargs)))

 		     (emit-optional-arg-inits g env opta vars nreq)))

 	  (cond ((not (null? let?))      (emit g 'let))

--- a/femtolisp/flisp.c

+++ b/femtolisp/flisp.c

@@ -790,6 +790,78 @@

     return v;

 }

+/*

+  argument layout on stack is

+  |--required args--|--opt args--|--kw args--|--rest args...

+ */

+static uint32_t process_keys(value_t kwtable,

+                             uint32_t nreq, uint32_t nkw, uint32_t nopt,

+                             uint32_t bp, uint32_t nargs, int va)

+{

+    uint32_t extr = nopt+nkw;

+    uint32_t ntot = nreq+extr;

+    value_t args[extr], v;

+    uint32_t i, a = 0, nrestargs;

+    value_t s1 = Stack[SP-1];

+    value_t s2 = Stack[SP-2];

+    value_t s4 = Stack[SP-4];

+    value_t s5 = Stack[SP-5];

+    if (nargs < nreq)

+        lerror(ArgError, "apply: too few arguments");

+    for (i=0; i < extr; i++) args[i] = UNBOUND;

+    for (i=nreq; i < nargs; i++) {

+        v = Stack[bp+i];

+        if (issymbol(v) && iskeyword((symbol_t*)ptr(v)))

+            break;

+        if (a >= nopt)

+            goto no_kw;

+        args[a++] = v;

+    }

+    if (i >= nargs) goto no_kw;

+    // now process keywords

+    uint32_t n = vector_size(kwtable)/2;

+    do {

+        i++;

+        if (i >= nargs)

+            lerrorf(ArgError, "keyword %s requires an argument",

+                    symbol_name(v));

+        value_t hv = fixnum(((symbol_t*)ptr(v))->hash);

+        uint32_t x = 2*(numval(hv) % n);

+        if (vector_elt(kwtable, x) == v) {

+            uint32_t idx = numval(vector_elt(kwtable, x+1));

+            assert(idx < nkw);

+            idx += (nreq+nopt);

+            if (args[idx] == UNBOUND) {

+                // if duplicate key, keep first value

+                args[idx] = Stack[bp+i];

+            }

+        }

+        else {

+            lerrorf(ArgError, "unsupported keyword %s", symbol_name(v));

+        }

+        i++;

+        if (i >= nargs) break;

+        v = Stack[bp+i];

+    } while (issymbol(v) && iskeyword((symbol_t*)ptr(v)));

+ no_kw:

+    nrestargs = nargs - i;

+    if (!va && nrestargs > 0)

+        lerror(ArgError, "apply: too many arguments");

+    nargs = ntot + nrestargs;

+    if (nrestargs)

+        memmove(&Stack[bp+ntot], &Stack[bp+i], nrestargs*sizeof(value_t));

+    memcpy(&Stack[bp+nreq], args, extr*sizeof(value_t));

+    SP = bp + nargs;

+    assert(SP < N_STACK-5);

+    PUSH(s5);

+    PUSH(s4);

+    PUSH(nargs);

+    PUSH(s2);

+    PUSH(s1);

+    curr_frame = SP;

+    return nargs;

+}

+

 #if _BYTE_ORDER == __BIG_ENDIAN

 #define GET_INT32(a)                            \

     ((((int32_t)a[0])<<0)  |                    \

@@ -935,16 +1007,13 @@

         OP(OP_OPTARGS)

             i = GET_INT32(ip); ip+=4;

             n = GET_INT32(ip); ip+=4;

-            if ((int32_t)i < 0) {

-                if (nargs < -i)

-                    lerror(ArgError, "apply: too few arguments");

-            }

-            else if (nargs < i) {

+            if (nargs < i)

                 lerror(ArgError, "apply: too few arguments");

+            if ((int32_t)n > 0) {

+                if (nargs > n)

+                    lerror(ArgError, "apply: too many arguments");

             }

-            else if (nargs > n) {

-                lerror(ArgError, "apply: too many arguments");

-            }

+            else n = -n;

             if (n > nargs) {

                 n -= nargs;

                 SP += n;

--- a/femtolisp/unittest.lsp

+++ b/femtolisp/unittest.lsp

@@ -123,6 +123,8 @@

 (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)))

+(assert (equal? ((lambda ((x 0) . r) (list x r))) '(0 ())))

+(assert (equal? ((lambda ((x 0) . r) (list x r)) 1 2 3) '(1 (2 3))))

 ; ok, a couple end-to-end tests as well

 (define (fib n) (if (< n 2) n (+ (fib (- n 1)) (fib (- n 2)))))