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

finishing initial implementation of keyword arguments 

fixing up interpreter so it can be used for bootstrapping again
removing let/copyenv optimization because it really didn't seem to help much
This commit is contained in:
JeffBezanson 2009-08-02 04:06:07 +00:00
parent adb702cdf8
commit 15c8cb327d
7 changed files with 162 additions and 110 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

133
femtolisp/compiler.lsp
View File

@ -22,11 +22,11 @@
setg setg.l setg setg.l
seta seta.l setc setc.l seta seta.l setc setc.l
closure argc vargc trycatch copyenv let for tapply closure argc vargc trycatch for tapply
add2 sub2 neg largc lvargc add2 sub2 neg largc lvargc
loada0 loada1 loadc00 loadc01 call.l tcall.l loada0 loada1 loadc00 loadc01 call.l tcall.l
brne brne.l cadr brnn brnn.l brn brn.l brne brne.l cadr brnn brnn.l brn brn.l
optargs brbound optargs brbound keyargs
dummy_t dummy_f dummy_nil])) dummy_t dummy_f dummy_nil]))
(for 0 (1- (length keys)) (for 0 (1- (length keys))
@ -101,15 +101,18 @@
(let ((lasti (if (pair? (aref e 0)) (let ((lasti (if (pair? (aref e 0))
(car (aref e 0)) ())) (car (aref e 0)) ()))
(bc (aref e 0))) (bc (aref e 0)))
(cond ((and (eq? inst 'brf) (eq? lasti 'not) (cond ((and
(eq? (cadr bc) 'null?)) (eq? inst 'brf)
(aset! e 0 (cons (car args) (cons 'brn (cddr bc))))) (cond ((and (eq? lasti 'not)
((and (eq? inst 'brf) (eq? lasti 'not)) (eq? (cadr bc) 'null?))
(aset! e 0 (cons (car args) (cons 'brt (cdr bc))))) (aset! e 0 (cons (car args) (cons 'brn (cddr bc)))))
((and (eq? inst 'brf) (eq? lasti 'eq?)) ((eq? lasti 'not)
(aset! e 0 (cons (car args) (cons 'brne (cdr bc))))) (aset! e 0 (cons (car args) (cons 'brt (cdr bc)))))
((and (eq? inst 'brf) (eq? lasti 'null?)) ((eq? lasti 'eq?)
(aset! e 0 (cons (car args) (cons 'brnn (cdr bc))))) (aset! e 0 (cons (car args) (cons 'brne (cdr bc)))))
((eq? lasti 'null?)
(aset! e 0 (cons (car args) (cons 'brnn (cdr bc)))))
(else #f))))
((and (eq? inst 'brt) (eq? lasti 'null?)) ((and (eq? inst 'brt) (eq? lasti 'null?))
(aset! e 0 (cons (car args) (cons 'brn (cdr bc))))) (aset! e 0 (cons (car args) (cons 'brn (cdr bc)))))
(else (else
@ -182,11 +185,14 @@
(io.write bcode (uint8 (aref v i))) (io.write bcode (uint8 (aref v i)))
(set! i (+ i 1))) (set! i (+ i 1)))
((loadc.l setc.l optargs) ; 2 int32 args ((loadc.l setc.l optargs keyargs) ; 2 int32 args
(io.write bcode (int32 nxt)) (io.write bcode (int32 nxt))
(set! i (+ i 1)) (set! i (+ i 1))
(io.write bcode (int32 (aref v i))) (io.write bcode (int32 (aref v i)))
(set! i (+ i 1))) (set! i (+ i 1))
(if (eq? vi 'keyargs)
(begin (io.write bcode (int32 (aref v i)))
(set! i (+ i 1)))))
(else (else
; other number arguments are always uint8 ; other number arguments are always uint8
@ -343,26 +349,7 @@
" arguments."))) " arguments.")))
(define (compile-app g env tail? x) (define (compile-app g env tail? x)
(let ((head (car x))) (compile-call g env tail? x))
(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))))
(define (compile-let g env tail? x)
(let ((head (car x))
(args (cdr x)))
(unless (length= args (length (cadr head)))
(error "apply: incorrect number of arguments to " head))
(receive (the-f dept) (compile-f- env head #t)
(emit g 'loadv the-f)
(bcode:cdepth g dept))
(let ((nargs (compile-arglist g env args)))
(emit g 'copyenv)
(emit g (if tail? 'tcall 'call) (+ 1 nargs)))))
(define builtin->instruction (define builtin->instruction
(let ((b2i (table number? 'number? cons 'cons (let ((b2i (table number? 'number? cons 'cons
@ -485,9 +472,9 @@
(emit g 'trycatch)) (emit g 'trycatch))
(else (compile-app g env tail? x)))))) (else (compile-app g env tail? x))))))
(define (compile-f env f . let?) (define (compile-f env f)
(receive (ff ignore) (receive (ff ignore)
(apply compile-f- env f let?) (compile-f- env f)
ff)) ff))
(define get-defined-vars (define get-defined-vars
@ -507,6 +494,13 @@
(else ()))))) (else ())))))
(lambda (expr) (delete-duplicates (get-defined-vars- expr))))) (lambda (expr) (delete-duplicates (get-defined-vars- expr)))))
(define (keyword-arg? x) (and (pair? x) (keyword? (car x))))
(define (keyword->symbol k)
(if (keyword? k)
(symbol (let ((s (string k)))
(string.sub s 0 (string.dec s (length s)))))
k))
(define (lambda-vars l) (define (lambda-vars l)
(define (check-formals l o) (define (check-formals l o)
(or (or
@ -517,7 +511,12 @@
(and (pair? (car l)) (and (pair? (car l))
(or (every pair? (cdr l)) (or (every pair? (cdr l))
(error "compile error: invalid argument list " (error "compile error: invalid argument list "
o ". optional arguments must come last."))) o ". optional arguments must come after required."))
(if (keyword? (caar l))
(or (every keyword-arg? (cdr l))
(error "compile error: invalid argument list "
o ". keyword arguments must come last."))
#t))
(error "compile error: invalid formal argument " (car l) (error "compile error: invalid formal argument " (car l)
" in list " o)) " in list " o))
(check-formals (cdr l) o)) (check-formals (cdr l) o))
@ -525,8 +524,8 @@
(error "compile error: invalid argument list " o) (error "compile error: invalid argument list " o)
(error "compile error: invalid formal argument " l " in list " o)))) (error "compile error: invalid formal argument " l " in list " o))))
(check-formals l l) (check-formals l l)
(map (lambda (s) (if (pair? s) (car s) s)) (map! (lambda (s) (if (pair? s) (keyword->symbol (car s)) s))
(to-proper l))) (to-proper l)))
(define (emit-optional-arg-inits g env opta vars i) (define (emit-optional-arg-inits g env opta vars i)
; i is the lexical var index of the opt arg to process next ; i is the lexical var index of the opt arg to process next
@ -547,7 +546,7 @@
(lambda (expr) (lambda (expr)
(compile `(lambda () ,expr . ,*defines-processed-token*)))) (compile `(lambda () ,expr . ,*defines-processed-token*))))
(lambda (env f . let?) (lambda (env f)
; convert lambda to one body expression and process internal defines ; convert lambda to one body expression and process internal defines
(define (lambda-body e) (define (lambda-body e)
(let ((B (if (pair? (cddr e)) (let ((B (if (pair? (cddr e))
@ -570,15 +569,25 @@
'lambda 'lambda
(lastcdr f)))) (lastcdr f))))
(let* ((nargs (if (atom? args) 0 (length args))) (let* ((nargs (if (atom? args) 0 (length args)))
(nreq (- nargs (length opta)))) (nreq (- nargs (length opta)))
(kwa (filter keyword-arg? opta)))
; emit argument checking prologue ; emit argument checking prologue
(if (not (null? opta)) (if (not (null? opta))
(begin (emit g 'optargs nreq (if (null? atail) nargs (- nargs))) (begin
(emit-optional-arg-inits g env opta vars nreq))) (if (null? kwa)
(emit g 'optargs nreq
(if (null? atail) nargs (- nargs)))
(begin
(bcode:indexfor g (make-perfect-hash-table
(map cons
(map car kwa)
(iota (length kwa)))))
(emit g 'keyargs nreq (length kwa)
(if (null? atail) nargs (- nargs)))))
(emit-optional-arg-inits g env opta vars nreq)))
(cond ((not (null? let?)) (emit g 'let)) (cond ((> nargs 255) (emit g (if (null? atail)
((> nargs 255) (emit g (if (null? atail)
'largc 'lvargc) 'largc 'lvargc)
nargs)) nargs))
((not (null? atail)) (emit g 'vargc nargs)) ((not (null? atail)) (emit g 'vargc nargs))
@ -661,11 +670,16 @@
(princ (number->string (aref code i))) (princ (number->string (aref code i)))
(set! i (+ i 1))) (set! i (+ i 1)))
((loadc.l setc.l optargs) ((loadc.l setc.l optargs keyargs)
(princ (number->string (ref-int32-LE code i)) " ") (princ (number->string (ref-int32-LE code i)) " ")
(set! i (+ i 4)) (set! i (+ i 4))
(princ (number->string (ref-int32-LE code i))) (princ (number->string (ref-int32-LE code i)))
(set! i (+ i 4))) (set! i (+ i 4))
(if (eq? inst 'keyargs)
(begin
(princ " ")
(princ (number->string (ref-int32-LE code i)) " ")
(set! i (+ i 4)))))
((brbound) ((brbound)
(princ (number->string (ref-int32-LE code i)) " ") (princ (number->string (ref-int32-LE code i)) " ")
@ -683,4 +697,31 @@
(else #f))))))) (else #f)))))))
; From SRFI 89 by Marc Feeley (http://srfi.schemers.org/srfi-89/srfi-89.html)
; Copyright (C) Marc Feeley 2006. All Rights Reserved.
;
; "alist" is a list of pairs of the form "(keyword . value)"
; The result is a perfect hash-table represented as a vector of
; length 2*N, where N is the hash modulus. If the keyword K is in
; the hash-table it is at index
;
; X = (* 2 ($hash-keyword K N))
;
; and the associated value is at index X+1.
(define (make-perfect-hash-table alist)
(define ($hash-keyword key n) (mod0 (abs (hash key)) n))
(let loop1 ((n (length alist)))
(let ((v (vector.alloc (* 2 n) #f)))
(let loop2 ((lst alist))
(if (pair? lst)
(let ((key (caar lst)))
(let ((x (* 2 ($hash-keyword key n))))
(if (aref v x)
(loop1 (+ n 1))
(begin
(aset! v x key)
(aset! v (+ x 1) (cdar lst))
(loop2 (cdr lst))))))
v)))))
#t #t

2
femtolisp/flisp.boot
View File

File diff suppressed because one or more lines are too long

107
femtolisp/flisp.c
View File

@ -391,7 +391,7 @@ void fl_gc_handle(value_t *pv)
GCHandleStack[N_GCHND++] = pv; GCHandleStack[N_GCHND++] = pv;
} }
void fl_free_gc_handles(int n) void fl_free_gc_handles(uint32_t n)
{ {
assert(N_GCHND >= n); assert(N_GCHND >= n);
N_GCHND -= n; N_GCHND -= n;
@ -826,11 +826,11 @@ static uint32_t process_keys(value_t kwtable,
lerrorf(ArgError, "keyword %s requires an argument", lerrorf(ArgError, "keyword %s requires an argument",
symbol_name(v)); symbol_name(v));
value_t hv = fixnum(((symbol_t*)ptr(v))->hash); value_t hv = fixnum(((symbol_t*)ptr(v))->hash);
uint32_t x = 2*(numval(hv) % n); uint32_t x = 2*(abs(numval(hv)) % n);
if (vector_elt(kwtable, x) == v) { if (vector_elt(kwtable, x) == v) {
uint32_t idx = numval(vector_elt(kwtable, x+1)); uint32_t idx = numval(vector_elt(kwtable, x+1));
assert(idx < nkw); assert(idx < nkw);
idx += (nreq+nopt); idx += nopt;
if (args[idx] == UNBOUND) { if (args[idx] == UNBOUND) {
// if duplicate key, keep first value // if duplicate key, keep first value
args[idx] = Stack[bp+i]; args[idx] = Stack[bp+i];
@ -995,40 +995,6 @@ static value_t apply_cl(uint32_t nargs)
OP(OP_LVARGC) OP(OP_LVARGC)
i = GET_INT32(ip); ip+=4; i = GET_INT32(ip); ip+=4;
goto do_vargc; goto do_vargc;
OP(OP_LET)
// last arg is closure environment to use
nargs--;
Stack[SP-5] = Stack[SP-4];
Stack[SP-4] = nargs;
POPN(1);
Stack[SP-1] = 0;
curr_frame = SP;
NEXT_OP;
OP(OP_OPTARGS)
i = GET_INT32(ip); ip+=4;
n = GET_INT32(ip); ip+=4;
if (nargs < i)
lerror(ArgError, "apply: too few arguments");
if ((int32_t)n > 0) {
if (nargs > n)
lerror(ArgError, "apply: too many arguments");
}
else n = -n;
if (n > nargs) {
n -= nargs;
SP += n;
Stack[SP-1] = Stack[SP-n-1];
Stack[SP-2] = Stack[SP-n-2];
Stack[SP-3] = nargs+n;
Stack[SP-4] = Stack[SP-n-4];
Stack[SP-5] = Stack[SP-n-5];
curr_frame = SP;
for(i=0; i < n; i++) {
Stack[bp+nargs+i] = UNBOUND;
}
nargs += n;
}
NEXT_OP;
OP(OP_BRBOUND) OP(OP_BRBOUND)
i = GET_INT32(ip); ip+=4; i = GET_INT32(ip); ip+=4;
if (captured) if (captured)
@ -1038,7 +1004,6 @@ static value_t apply_cl(uint32_t nargs)
if (v != UNBOUND) ip += (ptrint_t)GET_INT32(ip); if (v != UNBOUND) ip += (ptrint_t)GET_INT32(ip);
else ip += 4; else ip += 4;
NEXT_OP; NEXT_OP;
OP(OP_NOP) NEXT_OP;
OP(OP_DUP) SP++; Stack[SP-1] = Stack[SP-2]; NEXT_OP; OP(OP_DUP) SP++; Stack[SP-1] = Stack[SP-2]; NEXT_OP;
OP(OP_POP) POPN(1); NEXT_OP; OP(OP_POP) POPN(1); NEXT_OP;
OP(OP_TCALL) OP(OP_TCALL)
@ -1716,7 +1681,6 @@ static value_t apply_cl(uint32_t nargs)
NEXT_OP; NEXT_OP;
OP(OP_CLOSURE) OP(OP_CLOSURE)
OP(OP_COPYENV)
// build a closure (lambda args body . env) // build a closure (lambda args body . env)
if (nargs > 0 && !captured) { if (nargs > 0 && !captured) {
// save temporary environment to the heap // save temporary environment to the heap
@ -1737,17 +1701,15 @@ static value_t apply_cl(uint32_t nargs)
else { else {
PUSH(Stack[bp]); // env has already been captured; share PUSH(Stack[bp]); // env has already been captured; share
} }
if (ip[-1] == OP_CLOSURE) { pv = alloc_words(4);
pv = alloc_words(4); e = Stack[SP-2]; // closure to copy
e = Stack[SP-2]; // closure to copy assert(isfunction(e));
assert(isfunction(e)); pv[0] = ((value_t*)ptr(e))[0];
pv[0] = ((value_t*)ptr(e))[0]; pv[1] = ((value_t*)ptr(e))[1];
pv[1] = ((value_t*)ptr(e))[1]; pv[2] = Stack[SP-1]; // env
pv[2] = Stack[SP-1]; // env pv[3] = ((value_t*)ptr(e))[3];
pv[3] = ((value_t*)ptr(e))[3]; POPN(1);
POPN(1); Stack[SP-1] = tagptr(pv, TAG_FUNCTION);
Stack[SP-1] = tagptr(pv, TAG_FUNCTION);
}
NEXT_OP; NEXT_OP;
OP(OP_TRYCATCH) OP(OP_TRYCATCH)
@ -1756,6 +1718,40 @@ static value_t apply_cl(uint32_t nargs)
Stack[SP-1] = v; Stack[SP-1] = v;
NEXT_OP; NEXT_OP;
OP(OP_OPTARGS)
i = GET_INT32(ip); ip+=4;
n = GET_INT32(ip); ip+=4;
if (nargs < i)
lerror(ArgError, "apply: too few arguments");
if ((int32_t)n > 0) {
if (nargs > n)
lerror(ArgError, "apply: too many arguments");
}
else n = -n;
if (n > nargs) {
n -= nargs;
SP += n;
Stack[SP-1] = Stack[SP-n-1];
Stack[SP-2] = Stack[SP-n-2];
Stack[SP-3] = nargs+n;
Stack[SP-4] = Stack[SP-n-4];
Stack[SP-5] = Stack[SP-n-5];
curr_frame = SP;
for(i=0; i < n; i++) {
Stack[bp+nargs+i] = UNBOUND;
}
nargs += n;
}
NEXT_OP;
OP(OP_KEYARGS)
v = fn_vals(Stack[bp-1]);
v = vector_elt(v, 0);
i = GET_INT32(ip); ip+=4;
n = GET_INT32(ip); ip+=4;
s = GET_INT32(ip); ip+=4;
nargs = process_keys(v, i, n, abs(s)-(i+n), bp, nargs, s<0);
NEXT_OP;
#ifndef USE_COMPUTED_GOTO #ifndef USE_COMPUTED_GOTO
default: default:
goto dispatch; goto dispatch;
@ -1794,10 +1790,15 @@ static uint32_t compute_maxstack(uint8_t *code, size_t len)
n = GET_INT32(ip); ip+=4; n = GET_INT32(ip); ip+=4;
sp += (n+2); sp += (n+2);
break; break;
case OP_LET: break;
case OP_OPTARGS: case OP_OPTARGS:
i = abs(GET_INT32(ip)); ip+=4; i = GET_INT32(ip); ip+=4;
n = abs(GET_INT32(ip)); ip+=4;
sp += (n-i);
break;
case OP_KEYARGS:
i = GET_INT32(ip); ip+=4;
n = GET_INT32(ip); ip+=4; n = GET_INT32(ip); ip+=4;
n = abs(GET_INT32(ip)); ip+=4;
sp += (n-i); sp += (n-i);
break; break;
case OP_BRBOUND: case OP_BRBOUND:
@ -1854,7 +1855,7 @@ static uint32_t compute_maxstack(uint8_t *code, size_t len)
case OP_LOADT: case OP_LOADF: case OP_LOADNIL: case OP_LOAD0: case OP_LOADT: case OP_LOADF: case OP_LOADNIL: case OP_LOAD0:
case OP_LOAD1: case OP_LOADA0: case OP_LOADA1: case OP_LOADC00: case OP_LOAD1: case OP_LOADA0: case OP_LOADA1: case OP_LOADC00:
case OP_LOADC01: case OP_COPYENV: case OP_DUP: case OP_LOADC01: case OP_DUP:
sp++; sp++;
break; break;

2
femtolisp/flisp.h
View File

@ -101,7 +101,7 @@ typedef struct _symbol_t {
#define iscbuiltin(x) (iscvalue(x) && (cv_class((cvalue_t*)ptr(x))==builtintype)) #define iscbuiltin(x) (iscvalue(x) && (cv_class((cvalue_t*)ptr(x))==builtintype))
void fl_gc_handle(value_t *pv); void fl_gc_handle(value_t *pv);
void fl_free_gc_handles(int n); void fl_free_gc_handles(uint32_t n);
#include "opcodes.h" #include "opcodes.h"

4
femtolisp/mkboot0.lsp
View File

@ -1,7 +1,7 @@
; -*- scheme -*- ; -*- scheme -*-
;(if (not (bound? 'top-level-value)) (set! top-level-value %eval)) (if (not (bound? 'top-level-value)) (set! top-level-value %eval))
;(if (not (bound? 'set-top-level-value!)) (set! set-top-level-value! set)) (if (not (bound? 'set-top-level-value!)) (set! set-top-level-value! set))
;(load "compiler.lsp") ;(load "compiler.lsp")

13
femtolisp/opcodes.h
View File

@ -23,11 +23,11 @@ enum {
OP_SETG, OP_SETGL, OP_SETG, OP_SETGL,
OP_SETA, OP_SETAL, OP_SETC, OP_SETCL, OP_SETA, OP_SETAL, OP_SETC, OP_SETCL,
OP_CLOSURE, OP_ARGC, OP_VARGC, OP_TRYCATCH, OP_COPYENV, OP_LET, OP_FOR, OP_CLOSURE, OP_ARGC, OP_VARGC, OP_TRYCATCH, OP_FOR,
OP_TAPPLY, OP_ADD2, OP_SUB2, OP_NEG, OP_LARGC, OP_LVARGC, 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_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_BRNE, OP_BRNEL, OP_CADR, OP_BRNN, OP_BRNNL, OP_BRN, OP_BRNL,
OP_OPTARGS, OP_BRBOUND, OP_OPTARGS, OP_BRBOUND, OP_KEYARGS,
OP_BOOL_CONST_T, OP_BOOL_CONST_F, OP_THE_EMPTY_LIST, OP_BOOL_CONST_T, OP_BOOL_CONST_F, OP_THE_EMPTY_LIST,
@ -37,7 +37,7 @@ enum {
#ifdef USE_COMPUTED_GOTO #ifdef USE_COMPUTED_GOTO
#define VM_LABELS \ #define VM_LABELS \
static void *vm_labels[] = { \ static void *vm_labels[] = { \
&&L_OP_NOP, &&L_OP_DUP, &&L_OP_POP, &&L_OP_CALL, &&L_OP_TCALL, &&L_OP_JMP, \ NULL, &&L_OP_DUP, &&L_OP_POP, &&L_OP_CALL, &&L_OP_TCALL, &&L_OP_JMP, \
&&L_OP_BRF, &&L_OP_BRT, \ &&L_OP_BRF, &&L_OP_BRT, \
&&L_OP_JMPL, &&L_OP_BRFL, &&L_OP_BRTL, &&L_OP_RET, \ &&L_OP_JMPL, &&L_OP_BRFL, &&L_OP_BRTL, &&L_OP_RET, \
\ \
@ -64,19 +64,18 @@ enum {
&&L_OP_SETA, &&L_OP_SETAL, &&L_OP_SETC, &&L_OP_SETCL, \ &&L_OP_SETA, &&L_OP_SETAL, &&L_OP_SETC, &&L_OP_SETCL, \
\ \
&&L_OP_CLOSURE, &&L_OP_ARGC, &&L_OP_VARGC, &&L_OP_TRYCATCH, \ &&L_OP_CLOSURE, &&L_OP_ARGC, &&L_OP_VARGC, &&L_OP_TRYCATCH, \
&&L_OP_COPYENV, \ &&L_OP_FOR, \
&&L_OP_LET, &&L_OP_FOR, \
&&L_OP_TAPPLY, &&L_OP_ADD2, &&L_OP_SUB2, &&L_OP_NEG, &&L_OP_LARGC, \ &&L_OP_TAPPLY, &&L_OP_ADD2, &&L_OP_SUB2, &&L_OP_NEG, &&L_OP_LARGC, \
&&L_OP_LVARGC, \ &&L_OP_LVARGC, \
&&L_OP_LOADA0, &&L_OP_LOADA1, &&L_OP_LOADC00, &&L_OP_LOADC01, \ &&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_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, &&L_OP_BRBOUND \ &&L_OP_OPTARGS, &&L_OP_BRBOUND, &&L_OP_KEYARGS \
} }
#define VM_APPLY_LABELS \ #define VM_APPLY_LABELS \
static void *vm_apply_labels[] = { \ static void *vm_apply_labels[] = { \
&&L_OP_NOP, &&L_OP_DUP, &&L_OP_POP, &&L_OP_CALL, &&L_OP_TCALL, &&L_OP_JMP, \ NULL, &&L_OP_DUP, &&L_OP_POP, &&L_OP_CALL, &&L_OP_TCALL, &&L_OP_JMP, \
&&L_OP_BRF, &&L_OP_BRT, \ &&L_OP_BRF, &&L_OP_BRT, \
&&L_OP_JMPL, &&L_OP_BRFL, &&L_OP_BRTL, &&L_OP_RET, \ &&L_OP_JMPL, &&L_OP_BRFL, &&L_OP_BRTL, &&L_OP_RET, \
\ \

11
femtolisp/unittest.lsp
View File

@ -126,6 +126,17 @@
(assert (equal? ((lambda ((x 0) . r) (list x r))) '(0 ()))) (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)))) (assert (equal? ((lambda ((x 0) . r) (list x r)) 1 2 3) '(1 (2 3))))
; keyword arguments
(assert (equal? ((lambda (x (a 2) (b: a) . r) (list x a b r)) 1 0 8 4 5)
'(1 0 0 (8 4 5))))
(assert (equal? ((lambda (x (a 2) (b: a) . r) (list x a b r)) 0 b: 3 1)
'(0 2 3 (1))))
(define (keys4 (a: 8) (b: 3) (c: 7) (d: 6)) (list a b c d))
(assert (equal? (keys4 a: 10) '(10 3 7 6)))
(assert (equal? (keys4 b: 10) '(8 10 7 6)))
(assert (equal? (keys4 c: 10) '(8 3 10 6)))
(assert (equal? (keys4 d: 10) '(8 3 7 10)))
; ok, a couple end-to-end tests as well ; ok, a couple end-to-end tests as well
(define (fib n) (if (< n 2) n (+ (fib (- n 1)) (fib (- n 2))))) (define (fib n) (if (< n 2) n (+ (fib (- n 1)) (fib (- n 2)))))
(assert (equal? (fib 20) 6765)) (assert (equal? (fib 20) 6765))