ref: ecfd81148fe6a4d77924b8201051fadc36c3e42b
parent: eceeddf6d218e12cefb36fb9594c29be37852dd2
author: JeffBezanson <[email protected]>
date: Tue Jul 28 00:16:20 EDT 2009
changing optional args to allow default values to be computed from preceding arguments tidying some stuff with keywords
--- a/femtolisp/builtins.c
+++ b/femtolisp/builtins.c
@@ -135,8 +135,7 @@
{ argcount("keyword?", nargs, 1);symbol_t *sym = tosymbol(args[0], "keyword?");
- char *str = sym->name;
- return fl_is_keyword_name(str, strlen(str)) ? FL_T : FL_F;
+ return iskeyword(sym) ? FL_T : FL_F;
}
static value_t fl_top_level_value(value_t *args, u_int32_t nargs)
@@ -152,7 +151,7 @@
{ argcount("set-top-level-value!", nargs, 2);symbol_t *sym = tosymbol(args[0], "set-top-level-value!");
- if (!sym->isconst)
+ if (!isconstant(sym))
sym->binding = args[1];
return args[1];
}
@@ -187,7 +186,7 @@
{ argcount("constant?", nargs, 1);if (issymbol(args[0]))
- return (isconstant(args[0]) ? FL_T : FL_F);
+ return (isconstant((symbol_t*)ptr(args[0])) ? FL_T : FL_F);
if (iscons(args[0])) {if (car_(args[0]) == QUOTE)
return FL_T;
--- a/femtolisp/compiler.lsp
+++ b/femtolisp/compiler.lsp
@@ -3,30 +3,30 @@
(define Instructions
(let ((e (table))
(keys
- [:nop :dup :pop :call :tcall :jmp :brf :brt :jmp.l :brf.l :brt.l :ret
+ [nop dup pop call tcall jmp brf brt jmp.l brf.l brt.l ret
- :eq? :eqv? :equal? :atom? :not :null? :boolean? :symbol?
- :number? :bound? :pair? :builtin? :vector? :fixnum? :function?
+ eq? eqv? equal? atom? not null? boolean? symbol?
+ number? bound? pair? builtin? vector? fixnum? function?
- :cons :list :car :cdr :set-car! :set-cdr!
- :apply
+ cons list car cdr set-car! set-cdr!
+ apply
- :+ :- :* :/ :div0 := :< :compare
+ + - * / div0 = < compare
- :vector :aref :aset!
+ vector aref aset!
- :loadt :loadf :loadnil :load0 :load1 :loadi8
- :loadv :loadv.l
- :loadg :loadg.l
- :loada :loada.l :loadc :loadc.l
- :setg :setg.l
- :seta :seta.l :setc :setc.l
+ loadt loadf loadnil load0 load1 loadi8
+ loadv loadv.l
+ loadg loadg.l
+ loada loada.l loadc loadc.l
+ setg setg.l
+ seta seta.l setc setc.l
- :closure :argc :vargc :trycatch :copyenv :let :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
+ closure argc vargc trycatch copyenv let 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
dummy_t dummy_f dummy_nil]))
(for 0 (1- (length keys))
@@ -34,19 +34,19 @@
(put! e (aref keys i) i)))))
(define arg-counts
- (table :eq? 2 :eqv? 2
- :equal? 2 :atom? 1
- :not 1 :null? 1
- :boolean? 1 :symbol? 1
- :number? 1 :bound? 1
- :pair? 1 :builtin? 1
- :vector? 1 :fixnum? 1
- :cons 2 :car 1
- :cdr 1 :set-car! 2
- :set-cdr! 2 := 2
- :< 2 :compare 2
- :aref 2 :aset! 3
- :div0 2))
+ (table eq? 2 eqv? 2
+ equal? 2 atom? 1
+ not 1 null? 1
+ boolean? 1 symbol? 1
+ number? 1 bound? 1
+ pair? 1 builtin? 1
+ vector? 1 fixnum? 1
+ cons 2 car 1
+ cdr 1 set-car! 2
+ set-cdr! 2 = 2
+ < 2 compare 2
+ aref 2 aset! 3
+ div0 2))
(define (make-code-emitter) (vector () (table) 0 +inf.0))
(define (bcode:code b) (aref b 0))
@@ -64,60 +64,60 @@
(aset! b 2 (+ nconst 1)))))))
(define (emit e inst . args)
(if (null? args)
- (if (and (eq? inst :car) (pair? (aref e 0))
- (eq? (car (aref e 0)) :cdr))
- (set-car! (aref e 0) :cadr)
+ (if (and (eq? inst 'car) (pair? (aref e 0))
+ (eq? (car (aref e 0)) 'cdr))
+ (set-car! (aref e 0) 'cadr)
(aset! e 0 (cons inst (aref e 0))))
(begin
- (if (memq inst '(:loadv :loadg :setg))
+ (if (memq inst '(loadv loadg setg))
(set! args (list (bcode:indexfor e (car args)))))
(let ((longform
- (assq inst '((:loadv :loadv.l) (:loadg :loadg.l) (:setg :setg.l)
- (:loada :loada.l) (:seta :seta.l)))))
+ (assq inst '((loadv loadv.l) (loadg loadg.l) (setg setg.l)
+ (loada loada.l) (seta seta.l)))))
(if (and longform
(> (car args) 255))
(set! inst (cadr longform))))
(let ((longform
- (assq inst '((:loadc :loadc.l) (:setc :setc.l)))))
+ (assq inst '((loadc loadc.l) (setc setc.l)))))
(if (and longform
(or (> (car args) 255)
(> (cadr args) 255)))
(set! inst (cadr longform))))
- (if (eq? inst :loada)
+ (if (eq? inst 'loada)
(cond ((equal? args '(0))
- (set! inst :loada0)
+ (set! inst 'loada0)
(set! args ()))
((equal? args '(1))
- (set! inst :loada1)
+ (set! inst 'loada1)
(set! args ()))))
- (if (eq? inst :loadc)
+ (if (eq? inst 'loadc)
(cond ((equal? args '(0 0))
- (set! inst :loadc00)
+ (set! inst 'loadc00)
(set! args ()))
((equal? args '(0 1))
- (set! inst :loadc01)
+ (set! inst 'loadc01)
(set! args ()))))
(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)))))
- ((and (eq? inst :brt) (eq? lasti :null?))
- (aset! e 0 (cons (car args) (cons :brn (cdr bc)))))
+ (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)))))
+ ((and (eq? inst 'brt) (eq? lasti 'null?))
+ (aset! e 0 (cons (car args) (cons 'brn (cdr bc)))))
(else
(aset! e 0 (nreconc (cons inst args) bc)))))))
e)
(define (make-label e) (gensym))
-(define (mark-label e l) (emit e :label l))
+(define (mark-label e l) (emit e 'label l))
; convert symbolic bytecode representation to a byte array.
; labels are fixed-up.
@@ -127,13 +127,7 @@
(long? (>= (+ (length v) ; 1 byte for each entry, plus...
; at most half the entries in this vector can be
; instructions accepting 32-bit arguments
- (* 3 (div0 (length v) 2))
- #;(* 3 (count (lambda (i)
- (memq i '(:loadv.l :loadg.l :setg.l
- :loada.l :seta.l :loadc.l
- :setc.l :jmp :brt :brf
- :largc :lvargc)))
- cl)))
+ (* 3 (div0 (length v) 2)))
65536)))
(let ((n (length v))
(i 0)
@@ -146,7 +140,7 @@
(while (< i n)
(begin
(set! vi (aref v i))
- (if (eq? vi :label)
+ (if (eq? vi 'label)
(begin (put! label-to-loc (aref v (+ i 1)) (sizeof bcode))
(set! i (+ i 2)))
(begin
@@ -155,34 +149,40 @@
(get Instructions
(if long?
(case vi
- (:jmp :jmp.l)
- (:brt :brt.l)
- (:brf :brf.l)
- (:brne :brne.l)
- (:brnn :brnn.l)
- (:brn :brn.l)
+ (jmp 'jmp.l)
+ (brt 'brt.l)
+ (brf 'brf.l)
+ (brne 'brne.l)
+ (brnn 'brnn.l)
+ (brn 'brn.l)
(else vi))
vi))))
(set! i (+ i 1))
(set! nxt (if (< i n) (aref v i) #f))
- (cond ((memq vi '(:jmp :brf :brt :brne :brnn :brn))
+ (cond ((memq vi '(jmp brf brt brne brnn brn))
(put! fixup-to-label (sizeof bcode) nxt)
(io.write bcode ((if long? int32 int16) 0))
(set! i (+ i 1)))
+ ((eq? vi 'brbound)
+ (io.write bcode (int32 nxt))
+ (set! i (+ i 1))
+ (put! fixup-to-label (sizeof bcode) (aref v i))
+ (io.write bcode (int32 0))
+ (set! i (+ i 1)))
((number? nxt)
(case vi
- ((:loadv.l :loadg.l :setg.l :loada.l :seta.l
- :largc :lvargc :call.l :tcall.l :optargs)
+ ((loadv.l loadg.l setg.l loada.l seta.l
+ largc lvargc call.l tcall.l)
(io.write bcode (int32 nxt))
(set! i (+ i 1)))
- ((:loadc :setc) ; 2 uint8 args
+ ((loadc setc) ; 2 uint8 args
(io.write bcode (uint8 nxt))
(set! i (+ i 1))
(io.write bcode (uint8 (aref v i)))
(set! i (+ i 1)))
- ((:loadc.l :setc.l) ; 2 int32 args
+ ((loadc.l setc.l optargs) ; 2 int32 args
(io.write bcode (int32 nxt))
(set! i (+ i 1))
(io.write bcode (int32 (aref v i)))
@@ -245,7 +245,7 @@
(else
(if (and (constant? s)
(printable? (top-level-value s)))
- (emit g :loadv (top-level-value s))
+ (emit g 'loadv (top-level-value s))
(emit g (aref Is 2) s))))))
(define (compile-if g env tail? x)
@@ -262,11 +262,11 @@
(compile-in g env tail? else))
(else
(compile-in g env #f test)
- (emit g :brf elsel)
+ (emit g 'brf elsel)
(compile-in g env tail? then)
(if tail?
- (emit g :ret)
- (emit g :jmp endl))
+ (emit g 'ret)
+ (emit g 'jmp endl))
(mark-label g elsel)
(compile-in g env tail? else)
(mark-label g endl)))))
@@ -277,7 +277,7 @@
(compile-in g env tail? (car forms)))
(else
(compile-in g env #f (car forms))
- (emit g :pop)
+ (emit g 'pop)
(compile-begin g env tail? (cdr forms)))))
(define (compile-prog1 g env x)
@@ -284,7 +284,7 @@
(compile-in g env #f (cadr x))
(if (pair? (cddr x))
(begin (compile-begin g env #f (cddr x))
- (emit g :pop))))
+ (emit g 'pop))))
(define (compile-while g env cond body)
(let ((top (make-label g))
@@ -292,10 +292,10 @@
(compile-in g env #f #f)
(mark-label g top)
(compile-in g env #f cond)
- (emit g :brf end)
- (emit g :pop)
+ (emit g 'brf end)
+ (emit g 'pop)
(compile-in g env #f body)
- (emit g :jmp top)
+ (emit g 'jmp top)
(mark-label g end)))
(define (1arg-lambda? func)
@@ -310,7 +310,7 @@
(begin (compile-in g env #f lo)
(compile-in g env #f hi)
(compile-in g env #f func)
- (emit g :for))
+ (emit g 'for))
(error "for: third form must be a 1-argument lambda")))
(define (compile-short-circuit g env tail? forms default branch)
@@ -319,16 +319,16 @@
(else
(let ((end (make-label g)))
(compile-in g env #f (car forms))
- (emit g :dup)
+ (emit g 'dup)
(emit g branch end)
- (emit g :pop)
+ (emit g 'pop)
(compile-short-circuit g env tail? (cdr forms) default branch)
(mark-label g end)))))
(define (compile-and g env tail? forms)
- (compile-short-circuit g env tail? forms #t :brf))
+ (compile-short-circuit g env tail? forms #t 'brf))
(define (compile-or g env tail? forms)
- (compile-short-circuit g env tail? forms #f :brt))
+ (compile-short-circuit g env tail? forms #f 'brt))
(define (compile-arglist g env lst)
(for-each (lambda (a)
@@ -337,10 +337,10 @@
(length lst))
(define (argc-error head count)
- (error (string "compile error: " head " expects " count
- (if (= count 1)
- " argument."
- " arguments."))))
+ (error "compile error: " head " expects " count
+ (if (= count 1)
+ " argument."
+ " arguments.")))
(define (compile-app g env tail? x)
(let ((head (car x)))
@@ -356,28 +356,28 @@
(let ((head (car x))
(args (cdr x)))
(unless (length= args (length (cadr head)))
- (error (string "apply: incorrect number of arguments to " head)))
+ (error "apply: incorrect number of arguments to " head))
(receive (the-f dept) (compile-f- env head #t)
- (emit g :loadv the-f)
+ (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)))))
+ (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?
- eq? :eq? symbol? :symbol?
- div0 :div0 builtin? :builtin?
- aset! :aset! - :- boolean? :boolean? not :not
- apply :apply atom? :atom?
- set-cdr! :set-cdr! / :/
- function? :function? vector :vector
- list :list bound? :bound?
- < :< * :* cdr :cdr null? :null?
- + :+ eqv? :eqv? compare :compare aref :aref
- set-car! :set-car! car :car
- pair? :pair? = := vector? :vector?)))
+ (let ((b2i (table number? 'number? cons 'cons
+ fixnum? 'fixnum? equal? 'equal?
+ eq? 'eq? symbol? 'symbol?
+ div0 'div0 builtin? 'builtin?
+ aset! 'aset! - '- boolean? 'boolean? not 'not
+ apply 'apply atom? 'atom?
+ set-cdr! 'set-cdr! / '/
+ function? 'function? vector 'vector
+ list 'list bound? 'bound?
+ < '< * '* cdr 'cdr null? 'null?
+ + '+ eqv? 'eqv? compare 'compare aref 'aref
+ set-car! 'set-car! car 'car
+ pair? 'pair? = '= vector? 'vector?)))
(lambda (b)
(get b2i b #f))))
@@ -387,25 +387,25 @@
(not (length= (cdr x) count)))
(argc-error head count))
(case b ; handle special cases of vararg builtins
- (:list (if (= nargs 0) (emit g :loadnil) (emit g b nargs)))
- (:+ (cond ((= nargs 0) (emit g :load0))
- ((= nargs 2) (emit g :add2))
- (else (emit g b nargs))))
- (:- (cond ((= nargs 0) (argc-error head 1))
- ((= nargs 1) (emit g :neg))
- ((= nargs 2) (emit g :sub2))
- (else (emit g b nargs))))
- (:* (if (= nargs 0) (emit g :load1)
- (emit g b nargs)))
- (:/ (if (= nargs 0)
- (argc-error head 1)
- (emit g b nargs)))
- (:vector (if (= nargs 0)
- (emit g :loadv [])
- (emit g b nargs)))
- (:apply (if (< nargs 2)
- (argc-error head 2)
- (emit g (if tail? :tapply :apply) nargs)))
+ (list (if (= nargs 0) (emit g 'loadnil) (emit g b nargs)))
+ (+ (cond ((= nargs 0) (emit g 'load0))
+ ((= nargs 2) (emit g 'add2))
+ (else (emit g b nargs))))
+ (- (cond ((= nargs 0) (argc-error head 1))
+ ((= nargs 1) (emit g 'neg))
+ ((= nargs 2) (emit g 'sub2))
+ (else (emit g b nargs))))
+ (* (if (= nargs 0) (emit g 'load1)
+ (emit g b nargs)))
+ (/ (if (= nargs 0)
+ (argc-error head 1)
+ (emit g b nargs)))
+ (vector (if (= nargs 0)
+ (emit g 'loadv [])
+ (emit g b nargs)))
+ (apply (if (< nargs 2)
+ (argc-error head 2)
+ (emit g (if tail? 'tapply 'apply) nargs)))
(else (emit g b)))))
(define (compile-call g env tail? x)
@@ -422,7 +422,7 @@
; more than 255 arguments, need long versions of instructions
(begin (compile-in g env #f head)
(let ((nargs (compile-arglist g env (cdr x))))
- (emit g (if tail? :tcall.l :call.l) nargs)))
+ (emit g (if tail? 'tcall.l 'call.l) nargs)))
(let ((b (and (builtin? head)
(builtin->instruction head))))
(if (and (eq? head 'cadr)
@@ -430,7 +430,7 @@
(equal? (top-level-value 'cadr) cadr)
(length= x 2))
(begin (compile-in g env #f (cadr x))
- (emit g :cadr))
+ (emit g 'cadr))
(begin
(if (not b)
(compile-in g env #f head))
@@ -437,7 +437,7 @@
(let ((nargs (compile-arglist g env (cdr x))))
(if b
(compile-builtin-call g env tail? x head b nargs)
- (emit g (if tail? :tcall :call) nargs))))))))))
+ (emit g (if tail? 'tcall 'call) nargs))))))))))
(define (expand-define form body)
(if (symbol? form)
@@ -448,34 +448,34 @@
(define (fits-i8 x) (and (fixnum? x) (>= x -128) (<= x 127)))
(define (compile-in g env tail? x)
- (cond ((symbol? x) (compile-sym g env x [:loada :loadc :loadg]))
+ (cond ((symbol? x) (compile-sym g env x [loada loadc loadg]))
((atom? x)
- (cond ((eq? x 0) (emit g :load0))
- ((eq? x 1) (emit g :load1))
- ((eq? x #t) (emit g :loadt))
- ((eq? x #f) (emit g :loadf))
- ((eq? x ()) (emit g :loadnil))
- ((fits-i8 x) (emit g :loadi8 x))
- (else (emit g :loadv x))))
+ (cond ((eq? x 0) (emit g 'load0))
+ ((eq? x 1) (emit g 'load1))
+ ((eq? x #t) (emit g 'loadt))
+ ((eq? x #f) (emit g 'loadf))
+ ((eq? x ()) (emit g 'loadnil))
+ ((fits-i8 x) (emit g 'loadi8 x))
+ (else (emit g 'loadv x))))
(else
(case (car x)
- (quote (emit g :loadv (cadr x)))
+ (quote (emit g 'loadv (cadr x)))
(if (compile-if g env tail? x))
(begin (compile-begin g env tail? (cdr x)))
(prog1 (compile-prog1 g env x))
(lambda (receive (the-f dept) (compile-f- env x)
- (begin (emit g :loadv the-f)
+ (begin (emit g 'loadv the-f)
(bcode:cdepth g dept)
(if (< dept (nnn env))
- (emit g :closure)))))
+ (emit g 'closure)))))
(and (compile-and g env tail? (cdr x)))
(or (compile-or g env tail? (cdr x)))
(while (compile-while g env (cadr x) (cons 'begin (cddr x))))
(for (compile-for g env (cadr x) (caddr x) (cadddr x)))
(return (compile-in g env #t (cadr x))
- (emit g :ret))
+ (emit g 'ret))
(set! (compile-in g env #f (caddr x))
- (compile-sym g env (cadr x) [:seta :setc :setg]))
+ (compile-sym g env (cadr x) [seta setc setg]))
(define (compile-in g env tail?
(expand-define (cadr x) (cddr x))))
(trycatch (compile-in g env #f `(lambda () ,(cadr x)))
@@ -482,7 +482,7 @@
(unless (1arg-lambda? (caddr x))
(error "trycatch: second form must be a 1-argument lambda"))
(compile-in g env #f (caddr x))
- (emit g :trycatch))
+ (emit g 'trycatch))
(else (compile-app g env tail? x))))))
(define (compile-f env f . let?)
@@ -516,19 +516,29 @@
(or (symbol? (car l))
(and (pair? (car l))
(or (every pair? (cdr l))
- (error (string "compile error: invalid argument list "
- o ". optional arguments must come last."))))
- (error (string "compile error: invalid formal argument " (car l)
- " in list " o)))
+ (error "compile error: invalid argument list "
+ o ". optional arguments must come last.")))
+ (error "compile error: invalid formal argument " (car l)
+ " in list " o))
(check-formals (cdr l) o))
(if (eq? l o)
- (error (string "compile error: invalid argument list " o))
- (error (string "compile error: invalid formal argument " l
- " in list " o)))))
+ (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)))
+(define (emit-optional-arg-inits g env opta vars i)
+ ; i is the lexical var index of the opt arg to process next
+ (if (pair? opta)
+ (let ((nxt (make-label g)))
+ (emit g 'brbound i nxt)
+ (compile-in g (cons (list-head vars i) env) #f (cadar opta))
+ (emit g 'seta i)
+ (emit g 'pop)
+ (mark-label g nxt)
+ (emit-optional-arg-inits g env (cdr opta) vars (+ i 1)))))
+
(define compile-f-
(let ((*defines-processed-token* (gensym)))
; to eval a top-level expression we need to avoid internal define
@@ -553,24 +563,26 @@
(let ((g (make-code-emitter))
(args (cadr f))
+ (atail (lastcdr (cadr f)))
(vars (lambda-vars (cadr f)))
(opta (filter pair? (cadr f)))
(name (if (eq? (lastcdr f) *defines-processed-token*)
'lambda
(lastcdr f))))
- (let ((nargs (if (atom? args) 0 (length args))))
+ (let* ((nargs (if (atom? args) 0 (length args)))
+ (nreq (- nargs (length opta))))
; emit argument checking prologue
(if (not (null? opta))
- (begin (bcode:indexfor g (list->vector (map cadr opta)))
- (emit g :optargs (- nargs (length opta)))))
+ (begin (emit g 'optargs (if (null? atail) nreq (- nreq)) nargs)
+ (emit-optional-arg-inits g env opta vars nreq)))
- (cond ((not (null? let?)) (emit g :let))
- ((> nargs 255) (emit g (if (null? (lastcdr args))
- :largc :lvargc)
+ (cond ((not (null? let?)) (emit g 'let))
+ ((> nargs 255) (emit g (if (null? atail)
+ 'largc 'lvargc)
nargs))
- ((null? (lastcdr args)) (emit g :argc nargs))
- (else (emit g :vargc nargs)))
+ ((not (null? atail)) (emit g 'vargc nargs))
+ ((null? opta) (emit g 'argc nargs)))
; compile body and return
(compile-in g (cons vars env) #t
@@ -577,7 +589,7 @@
(if (eq? (lastcdr f) *defines-processed-token*)
(caddr f)
(lambda-body f)))
- (emit g :ret)
+ (emit g 'ret)
(values (function (encode-byte-code (bcode:code g))
(const-to-idx-vec g) name)
(aref g 3)))))))
@@ -623,43 +635,49 @@
(if (> i 4) (newline))
(dotimes (xx lev) (princ "\t"))
(princ (hex5 (- i 4)) ": "
- (string.tail (string inst) 1) "\t")
+ (string inst) "\t")
(set! i (+ i 1))
(case inst
- ((:loadv.l :loadg.l :setg.l)
+ ((loadv.l loadg.l setg.l)
(print-val (aref vals (ref-int32-LE code i)))
(set! i (+ i 4)))
- ((:loadv :loadg :setg)
+ ((loadv loadg setg)
(print-val (aref vals (aref code i)))
(set! i (+ i 1)))
- ((:loada :seta :call :tcall :list :+ :- :* :/ :vector
- :argc :vargc :loadi8 :apply :tapply)
+ ((loada seta call tcall list + - * / vector
+ argc vargc loadi8 apply tapply)
(princ (number->string (aref code i)))
(set! i (+ i 1)))
- ((:loada.l :seta.l :largc :lvargc :call.l :tcall.l :optargs)
+ ((loada.l seta.l largc lvargc call.l tcall.l)
(princ (number->string (ref-int32-LE code i)))
(set! i (+ i 4)))
-
- ((:loadc :setc)
+
+ ((loadc setc)
(princ (number->string (aref code i)) " ")
(set! i (+ i 1))
(princ (number->string (aref code i)))
(set! i (+ i 1)))
- ((:loadc.l :setc.l)
+ ((loadc.l setc.l optargs)
(princ (number->string (ref-int32-LE code i)) " ")
(set! i (+ i 4))
(princ (number->string (ref-int32-LE code i)))
(set! i (+ i 4)))
- ((:jmp :brf :brt :brne :brnn :brn)
+ ((brbound)
+ (princ (number->string (ref-int32-LE code i)) " ")
+ (set! i (+ i 4))
+ (princ "@" (hex5 (+ i -4 (ref-int32-LE code i))))
+ (set! i (+ i 4)))
+
+ ((jmp brf brt brne brnn brn)
(princ "@" (hex5 (+ i -4 (ref-int16-LE code i))))
(set! i (+ i 2)))
- ((:jmp.l :brf.l :brt.l :brne.l :brnn.l :brn.l)
+ ((jmp.l brf.l brt.l brne.l brnn.l brn.l)
(princ "@" (hex5 (+ i -4 (ref-int32-LE code i))))
(set! i (+ i 4)))
--- 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(:sub2 74 :nop 0 :set-cdr! 32 :/ 37 :setc 63 :tapply 72 :lvargc 77 :cons 27 :loada1 79 :tcall.l 83 dummy_nil 94 :equal? 14 :cdr 30 :call 3 :eqv? 13 := 39 :setg.l 60 :list 28 :atom? 15 :aref 43 :load0 48 :let 70 dummy_t 92 :argc 66 :brne.l 85 :< 40 :null? 17 :loadg 53 :load1 49 :car 29 :brt.l 10 :vargc 67 :loada 55 :set-car! 31 :setg 59 :aset! 44 :loadc01 81 :bound? 21 :optargs 91 :pair? 22 :symbol? 19 :brn 89 :fixnum? 25 :loadi8 50 :not 16 :* 36 :neg 75 :pop 2 :largc 76 :loadnil 47 :brf 6 :vector 42 :- 35 :loadv 51 :loada.l 56 :seta.l 62 :closure 65 :loadc00 80 :number? 2\ 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\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
--- a/femtolisp/flisp.c
+++ b/femtolisp/flisp.c
@@ -237,13 +237,14 @@
sym = (symbol_t*)malloc(sizeof(symbol_t)-sizeof(void*) + len + 1);
assert(((uptrint_t)sym & 0x7) == 0); // make sure malloc aligns 8
sym->left = sym->right = NULL;
+ sym->flags = 0;
if (fl_is_keyword_name(str, len)) {value_t s = tagptr(sym, TAG_SYM);
setc(s, s);
+ sym->flags |= 0x2;
}
else {sym->binding = UNBOUND;
- sym->isconst = 0;
}
sym->type = sym->dlcache = NULL;
sym->hash = memhash32(str, len)^0xAAAAAAAA;
@@ -932,29 +933,42 @@
curr_frame = SP;
NEXT_OP;
OP(OP_OPTARGS)
+ i = GET_INT32(ip); ip+=4;
n = GET_INT32(ip); ip+=4;
- v = fn_vals(Stack[bp-1]);
- v = vector_elt(v, 0);
- if (nargs >= n) { // if we have all required args- s = vector_size(v);
- n += s;
- if (nargs < n) { // but not all optional args- i = n - nargs;
- SP += i;
- Stack[SP-1] = Stack[SP-i-1];
- Stack[SP-2] = Stack[SP-i-2];
- Stack[SP-3] = Stack[SP-i-3];
- Stack[SP-4] = Stack[SP-i-4];
- Stack[SP-5] = Stack[SP-i-5];
- curr_frame = SP;
- s = s - i;
- for(n=0; n < i; n++) {- Stack[bp+nargs+n] = vector_elt(v, s+n);
- }
- nargs += i;
+ if ((int32_t)i < 0) {+ if (nargs < -i)
+ lerror(ArgError, "apply: too few arguments");
+ }
+ else if (nargs < i) {+ lerror(ArgError, "apply: too few arguments");
+ }
+ else if (nargs > n) {+ lerror(ArgError, "apply: too many arguments");
+ }
+ 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)
+ v = vector_elt(Stack[bp], i);
+ else
+ v = Stack[bp+i];
+ 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;
@@ -1525,7 +1539,7 @@
assert(issymbol(v));
sym = (symbol_t*)ptr(v);
v = Stack[SP-1];
- if (!sym->isconst)
+ if (!isconstant(sym))
sym->binding = v;
NEXT_OP;
@@ -1686,11 +1700,11 @@
#endif
}
-static uint32_t compute_maxstack(uint8_t *code, size_t len, value_t vals)
+static uint32_t compute_maxstack(uint8_t *code, size_t len)
{uint8_t *ip = code+4, *end = code+len;
uint8_t op;
- uint32_t n, sp = 0, maxsp = 0;
+ uint32_t i, n, sp = 0, maxsp = 0;
while (1) {if ((int32_t)sp > (int32_t)maxsp) maxsp = sp;
@@ -1713,11 +1727,13 @@
break;
case OP_LET: break;
case OP_OPTARGS:
- ip += 4;
- assert(isvector(vals));
- if (vector_size(vals) > 0)
- sp += vector_size(vector_elt(vals, 0));
+ i = abs(GET_INT32(ip)); ip+=4;
+ n = GET_INT32(ip); ip+=4;
+ sp += (n-i);
break;
+ case OP_BRBOUND:
+ ip+=8;
+ break;
case OP_TCALL: case OP_CALL:
n = *ip++; // nargs
@@ -1848,13 +1864,13 @@
cvalue_t *arr = (cvalue_t*)ptr(args[0]);
cv_pin(arr);
char *data = cv_data(arr);
- if (data[4] >= N_OPCODES) {+ if ((uint8_t)data[4] >= N_OPCODES) {// read syntax, shifted 48 for compact text representation
size_t i, sz = cv_len(arr);
for(i=0; i < sz; i++)
data[i] -= 48;
}
- uint32_t ms = compute_maxstack((uint8_t*)data, cv_len(arr), args[1]);
+ uint32_t ms = compute_maxstack((uint8_t*)data, cv_len(arr));
PUT_INT32(data, ms);
function_t *fn = (function_t*)alloc_words(4);
value_t fv = tagptr(fn, TAG_FUNCTION);
--- a/femtolisp/flisp.h
+++ b/femtolisp/flisp.h
@@ -15,7 +15,7 @@
} cons_t;
typedef struct _symbol_t {- value_t isconst;
+ uptrint_t flags;
value_t binding; // global value binding
struct _fltype_t *type;
uint32_t hash;
@@ -87,9 +87,10 @@
#define fn_name(f) (((value_t*)ptr(f))[3])
#define set(s, v) (((symbol_t*)ptr(s))->binding = (v))
-#define setc(s, v) do { ((symbol_t*)ptr(s))->isconst = 1; \+#define setc(s, v) do { ((symbol_t*)ptr(s))->flags |= 1; \((symbol_t*)ptr(s))->binding = (v); } while (0)
-#define isconstant(s) (((symbol_t*)ptr(s))->isconst)
+#define isconstant(s) ((s)->flags&0x1)
+#define iskeyword(s) ((s)->flags&0x2)
#define symbol_value(s) (((symbol_t*)ptr(s))->binding)
#define ismanaged(v) ((((unsigned char*)ptr(v)) >= fromspace) && \
(((unsigned char*)ptr(v)) < fromspace+heapsize))
--- a/femtolisp/opcodes.h
+++ b/femtolisp/opcodes.h
@@ -27,7 +27,7 @@
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_OPTARGS, OP_BRBOUND,
OP_BOOL_CONST_T, OP_BOOL_CONST_F, OP_THE_EMPTY_LIST,
@@ -70,7 +70,8 @@
&&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_BRNN, &&L_OP_BRNNL, &&L_OP_BRN, &&L_OP_BRNL, \
+ &&L_OP_OPTARGS, &&L_OP_BRBOUND \
}
#define VM_APPLY_LABELS \
--- a/femtolisp/print.c
+++ b/femtolisp/print.c
@@ -424,7 +424,7 @@
break;
case TAG_CVALUE:
case TAG_CPRIM:
- if (v == UNBOUND) { outs("#<undefined>", f); break; }+ if (v == UNBOUND) { outs("#<undefined>", f); break; }case TAG_VECTOR:
case TAG_CONS:
if (print_circle_prefix(f, v)) return;
--- a/femtolisp/test.lsp
+++ b/femtolisp/test.lsp
@@ -280,3 +280,17 @@
lastcdr to-proper reverse reverse! list->vector
table.foreach list-head list-tail assq memq assoc member
assv memv nreconc bq-process))
+
+(define (filt1 pred lst)
+ (define (filt1- pred lst accum)
+ (if (null? lst) accum
+ (if (pred (car lst))
+ (filt1- pred (cdr lst) (cons (car lst) accum))
+ (filt1- pred (cdr lst) accum))))
+ (filt1- pred lst ()))
+
+(define (filto pred lst (accum ()))
+ (if (atom? lst) accum
+ (if (pred (car lst))
+ (filto pred (cdr lst) (cons (car lst) accum))
+ (filto pred (cdr lst) accum))))
--- a/femtolisp/todo
+++ b/femtolisp/todo
@@ -1128,3 +1128,25 @@
uint32_t SP;
uint32_t curr_frame;
} stackseg_t;
+
+-----------------------------------------------------------------------------
+
+optional and keyword args:
+
+check nargs >= #required
+grow frame by ntotal-nargs ; ntotal = #req+#opt+#kw
+(sort keyword args into their places)
+branch if arg bound around initializer for each opt arg
+
+example: (lambda (a (b 0) (c b)))
+
+minargs 1
+framesize 3
+brbound 1 L1
+load0
+seta 0
+L1:
+brbound 2 L2
+loada 1
+seta 2
+L2: