ref: 15c8cb327d542607b6faaa90498cdef29a321110
parent: adb702cdf82a2ac6ccadd8f786234086e7c2743a
author: JeffBezanson <jeff.bezanson@gmail.com>
date: Sun Aug 2 00:06:07 EDT 2009
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
--- a/femtolisp/compiler.lsp
+++ b/femtolisp/compiler.lsp
@@ -22,11 +22,11 @@
setg setg.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
loada0 loada1 loadc00 loadc01 call.l tcall.l
brne brne.l cadr brnn brnn.l brn brn.l
- optargs brbound
+ optargs brbound keyargs
dummy_t dummy_f dummy_nil]))
(for 0 (1- (length keys))
@@ -101,15 +101,18 @@
(let ((lasti (if (pair? (aref e 0))
(car (aref e 0)) ()))
(bc (aref e 0)))
- (cond ((and (eq? inst 'brf) (eq? lasti 'not)
- (eq? (cadr bc) 'null?))
- (aset! e 0 (cons (car args) (cons 'brn (cddr bc)))))
- ((and (eq? inst 'brf) (eq? lasti 'not))
- (aset! e 0 (cons (car args) (cons 'brt (cdr bc)))))
- ((and (eq? inst 'brf) (eq? lasti 'eq?))
- (aset! e 0 (cons (car args) (cons 'brne (cdr bc)))))
- ((and (eq? inst 'brf) (eq? lasti 'null?))
- (aset! e 0 (cons (car args) (cons 'brnn (cdr bc)))))
+ (cond ((and
+ (eq? inst 'brf)
+ (cond ((and (eq? lasti 'not)
+ (eq? (cadr bc) 'null?))
+ (aset! e 0 (cons (car args) (cons 'brn (cddr bc)))))
+ ((eq? lasti 'not)
+ (aset! e 0 (cons (car args) (cons 'brt (cdr bc)))))
+ ((eq? lasti 'eq?)
+ (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?))
(aset! e 0 (cons (car args) (cons 'brn (cdr bc)))))
(else
@@ -182,11 +185,14 @@
(io.write bcode (uint8 (aref v i)))
(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))
(set! i (+ i 1))
(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
; other number arguments are always uint8
@@ -343,27 +349,8 @@
" arguments.")))
(define (compile-app g env tail? x)
- (let ((head (car 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))))
+ (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
(let ((b2i (table number? 'number? cons 'cons
fixnum? 'fixnum? equal? 'equal?
@@ -485,9 +472,9 @@
(emit g 'trycatch))
(else (compile-app g env tail? x))))))
-(define (compile-f env f . let?)
+(define (compile-f env f)
(receive (ff ignore)
- (apply compile-f- env f let?)
+ (compile-f- env f)
ff))
(define get-defined-vars
@@ -507,6 +494,13 @@
(else ())))))
(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 (check-formals l o)
(or
@@ -517,7 +511,12 @@
(and (pair? (car l))
(or (every pair? (cdr l))
(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)
" in list " o))
(check-formals (cdr l) o))
@@ -525,8 +524,8 @@
(error "compile error: invalid argument list " o)
(error "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)))
+ (map! (lambda (s) (if (pair? s) (keyword->symbol (car s)) s))
+ (to-proper l)))
(define (emit-optional-arg-inits g env opta vars i)
; i is the lexical var index of the opt arg to process next
@@ -547,7 +546,7 @@
(lambda (expr)
(compile `(lambda () ,expr . ,*defines-processed-token*))))
- (lambda (env f . let?)
+ (lambda (env f)
; convert lambda to one body expression and process internal defines
(define (lambda-body e)
(let ((B (if (pair? (cddr e))
@@ -570,15 +569,25 @@
'lambda
(lastcdr f))))
(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
(if (not (null? opta))
- (begin (emit g 'optargs nreq (if (null? atail) nargs (- nargs)))
- (emit-optional-arg-inits g env opta vars nreq)))
+ (begin
+ (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))
- ((> nargs 255) (emit g (if (null? atail)
+ (cond ((> nargs 255) (emit g (if (null? atail)
'largc 'lvargc)
nargs))
((not (null? atail)) (emit g 'vargc nargs))
@@ -661,11 +670,16 @@
(princ (number->string (aref code i)))
(set! i (+ i 1)))
- ((loadc.l setc.l optargs)
+ ((loadc.l setc.l optargs keyargs)
(princ (number->string (ref-int32-LE code i)) " ")
(set! i (+ i 4))
(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)
(princ (number->string (ref-int32-LE code i)) " ")
@@ -682,5 +696,32 @@
(set! i (+ i 4)))
(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
--- a/femtolisp/flisp.boot
+++ b/femtolisp/flisp.boot
@@ -1,1 +1,1 @@
-(*banner* "; _\n; |_ _ _ |_ _ | . _ _\n; | (-||||_(_)|__|_)|_)\n;-------------------|----------------------------------------------------------\n\n" *syntax-environment* #table(assert #function("<000r1c0~]c1c2c3~L2L2L2L4;" [if raise quote assert-failed]) letrec #function("?000s1e0e0c1L1e2c3~32L1e2c4~32e5\x7f3134L1e2c6~3242;" [nconc lambda map #.car #function("9000r1e0c1L1e2~3142;" [nconc set! copy-list]) copy-list #function("6000r1^;" [])]) backquote #function("7000r1e0~41;" [bq-process]) label #function(":000r2c0~L1c1~\x7fL3L3^L2;" [lambda set!]) do #function("A000s2c0e130\x7fMe2c3~32e2e4~32e2c5~32u46;" [#function("B000vc0~c1g2c2\x7fe3c4L1e5\x81N3132e3c4L1e5i0231e3~L1g432L133L4L3L2L1e3~L1g332L3;" [letrec lambda if nconc begin copy-list]) gensym map #.car cadr #function("7000r1e0~31F680e1~41;~M;" [cddr caddr])]) when #function("<000s1c0~c1\x7fK^L4;" [if begin]) unwind-protect #function("9000r2c0e130e130u43;" [#function("@000vc0\x7fc1_\x81L3L2L1c2c3\x80c1~L1c4\x7fL1c5~L2L3L3L3\x7fL1L3L3;" [let lambda prog1 trycatch begin raise]) gensym]) dotimes #function("<000s1c0~M~\x86u43;" [#function("=000vc0`c1\x7faL3e2c3L1~L1L1e4\x813133L4;" [for - nconc lambda copy-list])]) define-macro #function("?000s1c0c1~ML2e2c3L1~NL1e4\x7f3133L3;" [set-syntax! quote nconc lambda copy-list]) receive #function("@000s2c0c1_\x7fL3e2c1L1~L1e3g23133L3;" [call-with-values lambda nconc copy-list]) unless #function("=000s1c0~^c1\x7fKL4;" [if begin]) let #function(";000s1c0^u42;" [#function("<000v\x80C6D0\x80m02\x81Mo002\x81No01530^2c0e1c2L1e3c4\x8032L1e5\x813133e3c6\x8032u43;" [#function("8000v\x806;0c0\x80~L3530~\x7fK;" [label]) nconc lambda map #function("6000r1~F650~M;~;" []) copy-list #function("6000r1~F650~\x86;^;" [])])]) cond #function(":000s0c0^u42;" [#function("7000vc0qm02~\x8041;" [#function("8000r1~?640^;c0~Mu42;" [#function(";000v~Mc0<17702~M]<6@0~N\x8750~M;c1~NK;~N\x87@0c2~Mi10\x80N31L3;c3~Mc1~NKi10\x80N31L4;" [else begin or if])] cond-clauses->if)])]) throw #function(":000r2c0c1c2c3L2~\x7fL4L2;" [raise list quote thrown-value]) time #function("8000r1c0e130u42;" [#function(">000vc0~c1L1L2L1c2\x80c3c4c5c1L1~L3c6L4L3L3;" [let time.now prog1 princ "Elapsed time: " - " seconds\n"]) gensym]) let* #function("A000s1~?6E0e0c1L1_L1e2\x7f3133L1;e0c1L1e3~31L1L1e2~NF6H0e0c4L1~NL1e2\x7f3133L1530\x7f3133e5~31L2;" [nconc lambda copy-list caar let* cadar]) case #function(";000s1c0^u42;" [#function("8000vc0m02c1e230u42;" [#function(";000r2\x7fc0\x8450c0;\x7f\x8740^;\x7fC6=0c1~e2\x7f31L3;\x7f?6=0c3~e2\x7f31L3;\x7fN\x87>0c3~e2\x7fM31L3;e4c5\x7f326=0c6~c7\x7fL2L3;c8~c7\x7fL2L3;" [else eq? quote-value eqv? every #.symbol? memq quote memv] vals->cond) #function("<000vc0~i10L2L1e1c2L1e3c4qi113232L3;" [let nconc cond map #function("8000r1i10\x80~M32~NK;" [])]) gensym])]) catch #function("8000r2c0e130u42;" [#function("@000vc0\x81c1~L1c2c3c4~L2c5c6~L2c7c8L2L3c5c9~L2\x80L3L4c:~L2c;~L2L4L3L3;" [trycatch lambda if and pair? eq car quote thrown-value cadr caddr raise]) gensym])) *whitespace* "\t\n\v\f\r \u0085 \u2028\u2029 " /= #function("7000r2~\x7fW@;" [] /=) 1+ #function("7000r1~ay;" [] 1+) 1- #function("7000r1~az;" [] 1-) 1arg-lambda? #function("8000r1~F16T02~Mc0<16J02~NF16B02~\x86F16:02e1~\x86a42;" [lambda length=] 1arg-lambda?) <= #function("7000r2~\x7fX17602~\x7fW;" [] <=) > #function("7000r2\x7f~X;" [] >) >= #function("7000r2\x7f~X17602~\x7fW;" [] >=) Instructions #table(not 16 vargc 67 load1 49 = 39 setc.l 64 sub2 74 brne.l 85 largc 76 brnn 87 loadc.l 58 loadi8 50 < 40 nop 0 set-cdr! 32 loada 55 bound? 21 / 37 neg 75 brn.l 90 lvargc 77 brt 7 trycatch 68 null? 17 load0 48 jmp.l 8 loadv 51 seta 61 * 36 function? 26 builtin? 23 aref 43 optargs 91 vector? 24 loadt 45 brf 6 symbol? 19 cdr 30 for 71 loadc00 80 pop 2 pair? 22 cadr 86 closure 65 loadf 46 compare 41 loadv.l 52 setg.l 60 brn 89 eqv? 13 aset! 44 eq? 12 atom? 15 boolean? 18 brt.l 10 tapply 72 dummy_nil 95 loada0 78 brbound 92 list 28 dup 1 apply 33 loadc 57 loadc01 81 dummy_t \ No newline at end of file
+(*banner* "; _\n; |_ _ _ |_ _ | . _ _\n; | (-||||_(_)|__|_)|_)\n;-------------------|----------------------------------------------------------\n\n" *syntax-environment* #table(assert #function("<000r1c0|]c1c2c3|L2L2L2L4;" [if raise quote assert-failed]) letrec #function("?000s1e0e0c1L1e2c3|32L1e2c4|32e5}3134L1e2c6|3242;" [nconc lambda map #.car #function("9000r1e0c1L1e2|3142;" [nconc set! copy-list]) copy-list #function("6000r1^;" [])]) backquote #function("7000r1e0|41;" [bq-process]) label #function(":000r2c0|L1c1|}L3L3^L2;" [lambda set!]) do #function("A000s2c0qe130}Me2c3|32e2e4|32e2c5|3245;" [#function("B000r5c0|c1g2c2}e3c4L1e5\x7fN3132e3c4L1e5i0231e3|L1g432L133L4L3L2L1e3|L1g332L3;" [letrec lambda if nconc begin copy-list]) gensym map #.car cadr #function("7000r1e0|31F680e1|41;|M;" [cddr caddr])]) when #function("<000s1c0|c1}K^L4;" [if begin]) unwind-protect #function("8000r2c0qe130e13042;" [#function("@000r2c0}c1_\x7fL3L2L1c2c3~c1|L1c4}L1c5|L2L3L3L3}L1L3L3;" [let lambda prog1 trycatch begin raise]) gensym]) dotimes #function(";000s1c0q|M|\x8442;" [#function("=000r2c0`c1}aL3e2c3L1|L1L1e4\x7f3133L4;" [for - nconc lambda copy-list])]) define-macro #function("?000s1c0c1|ML2e2c3L1|NL1e4}3133L3;" [set-syntax! quote nconc lambda copy-list]) receive #function("@000s2c0c1_}L3e2c1L1|L1e3g23133L3;" [call-with-values lambda nconc copy-list]) unless #function("=000s1c0|^c1}KL4;" [if begin]) let #function(":000s1c0q^41;" [#function("<000r1~C6D0~m02\x7fMo002\x7fNo01530^2c0qe1c2L1e3c4~32L1e5\x7f3133e3c6~3242;" [#function("8000r2~6;0c0~|L3530|}K;" [label]) nconc lambda map #function("6000r1|F650|M;|;" []) copy-list #function("6000r1|F650|\x84;^;" [])])]) cond #function("9000s0c0q^41;" [#function("7000r1c0qm02|~41;" [#function("7000r1|?640^;c0q|M41;" [#function(";000r1|Mc0<17702|M]<6@0|N\x8550|M;c1|NK;|N\x85@0c2|Mi10~N31L3;c3|Mc1|NKi10~N31L4;" [else begin or if])] cond-clauses->if)])]) throw #function(":000r2c0c1c2c3L2|}L4L2;" [raise list quote thrown-value]) time #function("7000r1c0qe13041;" [#function(">000r1c0|c1L1L2L1c2~c3c4c5c1L1|L3c6L4L3L3;" [let time.now prog1 princ "Elapsed time: " - " seconds\n"]) gensym]) let* #function("A000s1|?6E0e0c1L1_L1e2}3133L1;e0c1L1e3|31L1L1e2|NF6H0e0c4L1|NL1e2}3133L1530}3133e5|31L2;" [nconc lambda copy-list caar let* cadar]) case #function(":000s1c0q^41;" [#function("7000r1c0m02c1qe23041;" [#function(";000r2}c0\x8250c0;}\x8540^;}C6=0c1|e2}31L3;}?6=0c3|e2}31L3;}N\x85>0c3|e2}M31L3;e4c5}326=0c6|c7}L2L3;c8|c7}L2L3;" [else eq? quote-value eqv? every #.symbol? memq quote memv] vals->cond) #function("<000r1c0|i10L2L1e1c2L1e3c4qi113232L3;" [let nconc cond map #function("8000r1i10~|M32|NK;" [])]) gensym])]) catch #function("7000r2c0qe13041;" [#function("@000r1c0\x7fc1|L1c2c3c4|L2c5c6|L2c7c8L2L3c5c9|L2~L3L4c:|L2c;|L2L4L3L3;" [trycatch lambda if and pair? eq car quote thrown-value cadr caddr raise]) gensym])) *whitespace* "\t\n\v\f\r \u0085 \u2028\u2029 " /= #function("7000r2|}W@;" [] /=) 1+ #function("7000r1|aw;" [] 1+) 1- #function("7000r1|ax;" [] 1-) 1arg-lambda? #function("8000r1|F16T02|Mc0<16J02|NF16B02|\x84F16:02e1|\x84a42;" [lambda length=] 1arg-lambda?) <= #function("7000r2|}X17602|}W;" [] <=) > #function("7000r2}|X;" [] >) >= #function("7000r2}|X17602|}W;" [] >=) Instructions #table(not 16 vargc 67 load1 49 = 39 setc.l 64 sub2 72 brne.l 83 largc 74 brnn 85 loadc.l 58 loadi8 50 < 40 nop 0 set-cdr! 32 loada 55 bound? 21 / 37 neg 73 brn.l 88 lvargc 75 brt 7 trycatch 68 null? 17 load0 48 jmp.l 8 loadv 51 seta 61 keyargs 91 * 36 function? 26 builtin? 23 aref 43 optargs 89 vector? 24 loadt 45 brf 6 symbol? 19 cdr 30 for 69 loadc00 78 pop 2 pair? 22 cadr 84 closure 65 loadf 46 compare 41 loadv.l 52 setg.l 60 brn 87 eqv? 13 aset! 44 eq? 12 atom? 15 boolean? 18 brt.l 10 tapply 70 dummy_nil 94 loada0 76 brbound 90 list 28 dup 1 apply 33 loadc 57 loadc01 79 dummy_t 92 setg 59 loada1 77 tcall.l 81 jmp 5 fixnum? 25 cons 27 loadg.l 54 tcall 4 call 3 - 35 brf.l 9 + 34 dumm\ No newline at end of file
--- a/femtolisp/flisp.c
+++ b/femtolisp/flisp.c
@@ -391,7 +391,7 @@
GCHandleStack[N_GCHND++] = pv;
}
-void fl_free_gc_handles(int n)
+void fl_free_gc_handles(uint32_t n)
{assert(N_GCHND >= n);
N_GCHND -= n;
@@ -826,11 +826,11 @@
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);
+ uint32_t x = 2*(abs(numval(hv)) % n);
if (vector_elt(kwtable, x) == v) {uint32_t idx = numval(vector_elt(kwtable, x+1));
assert(idx < nkw);
- idx += (nreq+nopt);
+ idx += nopt;
if (args[idx] == UNBOUND) {// if duplicate key, keep first value
args[idx] = Stack[bp+i];
@@ -995,40 +995,6 @@
OP(OP_LVARGC)
i = GET_INT32(ip); ip+=4;
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)
i = GET_INT32(ip); ip+=4;
if (captured)
@@ -1038,7 +1004,6 @@
if (v != UNBOUND) ip += (ptrint_t)GET_INT32(ip);
else ip += 4;
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;
OP(OP_TCALL)
@@ -1716,7 +1681,6 @@
NEXT_OP;
OP(OP_CLOSURE)
- OP(OP_COPYENV)
// build a closure (lambda args body . env)
if (nargs > 0 && !captured) {// save temporary environment to the heap
@@ -1737,17 +1701,15 @@
else {PUSH(Stack[bp]); // env has already been captured; share
}
- if (ip[-1] == OP_CLOSURE) {- pv = alloc_words(4);
- e = Stack[SP-2]; // closure to copy
- assert(isfunction(e));
- pv[0] = ((value_t*)ptr(e))[0];
- pv[1] = ((value_t*)ptr(e))[1];
- pv[2] = Stack[SP-1]; // env
- pv[3] = ((value_t*)ptr(e))[3];
- POPN(1);
- Stack[SP-1] = tagptr(pv, TAG_FUNCTION);
- }
+ pv = alloc_words(4);
+ e = Stack[SP-2]; // closure to copy
+ assert(isfunction(e));
+ pv[0] = ((value_t*)ptr(e))[0];
+ pv[1] = ((value_t*)ptr(e))[1];
+ pv[2] = Stack[SP-1]; // env
+ pv[3] = ((value_t*)ptr(e))[3];
+ POPN(1);
+ Stack[SP-1] = tagptr(pv, TAG_FUNCTION);
NEXT_OP;
OP(OP_TRYCATCH)
@@ -1756,6 +1718,40 @@
Stack[SP-1] = v;
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
default:
goto dispatch;
@@ -1794,10 +1790,15 @@
n = GET_INT32(ip); ip+=4;
sp += (n+2);
break;
- case OP_LET: break;
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 = abs(GET_INT32(ip)); ip+=4;
sp += (n-i);
break;
case OP_BRBOUND:
@@ -1854,7 +1855,7 @@
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_LOADC01: case OP_COPYENV: case OP_DUP:
+ case OP_LOADC01: case OP_DUP:
sp++;
break;
--- a/femtolisp/flisp.h
+++ b/femtolisp/flisp.h
@@ -101,7 +101,7 @@
#define iscbuiltin(x) (iscvalue(x) && (cv_class((cvalue_t*)ptr(x))==builtintype))
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"
--- a/femtolisp/mkboot0.lsp
+++ b/femtolisp/mkboot0.lsp
@@ -1,7 +1,7 @@
; -*- scheme -*-
-;(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? 'top-level-value)) (set! top-level-value %eval))
+(if (not (bound? 'set-top-level-value!)) (set! set-top-level-value! set))
;(load "compiler.lsp")
--- a/femtolisp/opcodes.h
+++ b/femtolisp/opcodes.h
@@ -23,11 +23,11 @@
OP_SETG, OP_SETGL,
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_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_BRBOUND,
+ OP_OPTARGS, OP_BRBOUND, OP_KEYARGS,
OP_BOOL_CONST_T, OP_BOOL_CONST_F, OP_THE_EMPTY_LIST,
@@ -37,7 +37,7 @@
#ifdef USE_COMPUTED_GOTO
#define 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_JMPL, &&L_OP_BRFL, &&L_OP_BRTL, &&L_OP_RET, \
\
@@ -64,19 +64,18 @@
&&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_COPYENV, \
- &&L_OP_LET, &&L_OP_FOR, \
+ &&L_OP_FOR, \
&&L_OP_TAPPLY, &&L_OP_ADD2, &&L_OP_SUB2, &&L_OP_NEG, &&L_OP_LARGC, \
&&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_OPTARGS, &&L_OP_BRBOUND \
+ &&L_OP_OPTARGS, &&L_OP_BRBOUND, &&L_OP_KEYARGS \
}
#define 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_JMPL, &&L_OP_BRFL, &&L_OP_BRTL, &&L_OP_RET, \
\
--- a/femtolisp/unittest.lsp
+++ b/femtolisp/unittest.lsp
@@ -126,6 +126,17 @@
(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))))
+; 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
(define (fib n) (if (< n 2) n (+ (fib (- n 1)) (fib (- n 2)))))
(assert (equal? (fib 20) 6765))