lassik
/
upscheme
1
0
Fork 0
Code Issues Pull Requests Projects Releases Wiki Activity

fixing a bug in optional args + rest args with no required arguments 

adding some code for keyword argument processing
This commit is contained in:
JeffBezanson 2009-07-29 04:20:28 +00:00
parent 08787a01cd
commit adb702cdf8
5 changed files with 82 additions and 11 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

2
femtolisp/Makefile
View File

@ -12,7 +12,7 @@ FLAGS = -falign-functions -Wall -Wextra -Wno-strict-aliasing -I$(LLTDIR) $(CFLAG
LIBS = $(LLT) -lm
DEBUGFLAGS = -g -DDEBUG $(FLAGS)
SHIPFLAGS = -O3 -DNDEBUG $(FLAGS)
SHIPFLAGS = -O2 -DNDEBUG $(FLAGS)
default: release test

2
femtolisp/compiler.lsp
View File

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

2
femtolisp/flisp.boot
View File

File diff suppressed because one or more lines are too long

83
femtolisp/flisp.c
View File

@ -790,6 +790,78 @@ static value_t do_trycatch()
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 @@ static value_t apply_cl(uint32_t nargs)
OP(OP_OPTARGS)
i = GET_INT32(ip); ip+=4;
n = GET_INT32(ip); ip+=4;
if ((int32_t)i < 0) {
if (nargs < -i)
if (nargs < i)
lerror(ArgError, "apply: too few arguments");
}
else if (nargs < i) {
lerror(ArgError, "apply: too few arguments");
}
else if (nargs > n) {
if ((int32_t)n > 0) {
if (nargs > n)
lerror(ArgError, "apply: too many arguments");
}
else n = -n;
if (n > nargs) {
n -= nargs;
SP += n;

2
femtolisp/unittest.lsp
View File

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