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

changing optional args to allow default values to be computed from 

preceding arguments
tidying some stuff with keywords
This commit is contained in:
JeffBezanson 2009-07-28 04:16:20 +00:00
parent eceeddf6d2
commit ecfd81148f
9 changed files with 285 additions and 214 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

7
femtolisp/builtins.c
View File

@ -135,8 +135,7 @@ static value_t fl_keywordp(value_t *args, u_int32_t nargs)
{ {
argcount("keyword?", nargs, 1); argcount("keyword?", nargs, 1);
symbol_t *sym = tosymbol(args[0], "keyword?"); symbol_t *sym = tosymbol(args[0], "keyword?");
char *str = sym->name; return iskeyword(sym) ? FL_T : FL_F;
return fl_is_keyword_name(str, strlen(str)) ? FL_T : FL_F;
} }
static value_t fl_top_level_value(value_t *args, u_int32_t nargs) static value_t fl_top_level_value(value_t *args, u_int32_t nargs)
@ -152,7 +151,7 @@ static value_t fl_set_top_level_value(value_t *args, u_int32_t nargs)
{ {
argcount("set-top-level-value!", nargs, 2); argcount("set-top-level-value!", nargs, 2);
symbol_t *sym = tosymbol(args[0], "set-top-level-value!"); symbol_t *sym = tosymbol(args[0], "set-top-level-value!");
if (!sym->isconst) if (!isconstant(sym))
sym->binding = args[1]; sym->binding = args[1];
return args[1]; return args[1];
} }
@ -187,7 +186,7 @@ static value_t fl_constantp(value_t *args, u_int32_t nargs)
{ {
argcount("constant?", nargs, 1); argcount("constant?", nargs, 1);
if (issymbol(args[0])) 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 (iscons(args[0])) {
if (car_(args[0]) == QUOTE) if (car_(args[0]) == QUOTE)
return FL_T; return FL_T;

362
femtolisp/compiler.lsp
View File

@ -3,30 +3,30 @@
(define Instructions (define Instructions
(let ((e (table)) (let ((e (table))
(keys (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? eq? eqv? equal? atom? not null? boolean? symbol?
:number? :bound? :pair? :builtin? :vector? :fixnum? :function? number? bound? pair? builtin? vector? fixnum? function?
:cons :list :car :cdr :set-car! :set-cdr! cons list car cdr set-car! set-cdr!
:apply apply
:+ :- :* :/ :div0 := :< :compare + - * / div0 = < compare
:vector :aref :aset! vector aref aset!
:loadt :loadf :loadnil :load0 :load1 :loadi8 loadt loadf loadnil load0 load1 loadi8
:loadv :loadv.l loadv loadv.l
:loadg :loadg.l loadg loadg.l
:loada :loada.l :loadc :loadc.l loada loada.l loadc loadc.l
: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 copyenv let 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 optargs brbound
dummy_t dummy_f dummy_nil])) dummy_t dummy_f dummy_nil]))
(for 0 (1- (length keys)) (for 0 (1- (length keys))
@ -34,19 +34,19 @@
(put! e (aref keys i) i))))) (put! e (aref keys i) i)))))
(define arg-counts (define arg-counts
(table :eq? 2 :eqv? 2 (table eq? 2 eqv? 2
:equal? 2 :atom? 1 equal? 2 atom? 1
:not 1 :null? 1 not 1 null? 1
:boolean? 1 :symbol? 1 boolean? 1 symbol? 1
:number? 1 :bound? 1 number? 1 bound? 1
:pair? 1 :builtin? 1 pair? 1 builtin? 1
:vector? 1 :fixnum? 1 vector? 1 fixnum? 1
:cons 2 :car 1 cons 2 car 1
:cdr 1 :set-car! 2 cdr 1 set-car! 2
:set-cdr! 2 := 2 set-cdr! 2 = 2
:< 2 :compare 2 < 2 compare 2
:aref 2 :aset! 3 aref 2 aset! 3
:div0 2)) div0 2))
(define (make-code-emitter) (vector () (table) 0 +inf.0)) (define (make-code-emitter) (vector () (table) 0 +inf.0))
(define (bcode:code b) (aref b 0)) (define (bcode:code b) (aref b 0))
@ -64,60 +64,60 @@
(aset! b 2 (+ nconst 1))))))) (aset! b 2 (+ nconst 1)))))))
(define (emit e inst . args) (define (emit e inst . args)
(if (null? args) (if (null? args)
(if (and (eq? inst :car) (pair? (aref e 0)) (if (and (eq? inst 'car) (pair? (aref e 0))
(eq? (car (aref e 0)) :cdr)) (eq? (car (aref e 0)) 'cdr))
(set-car! (aref e 0) :cadr) (set-car! (aref e 0) 'cadr)
(aset! e 0 (cons inst (aref e 0)))) (aset! e 0 (cons inst (aref e 0))))
(begin (begin
(if (memq inst '(:loadv :loadg :setg)) (if (memq inst '(loadv loadg setg))
(set! args (list (bcode:indexfor e (car args))))) (set! args (list (bcode:indexfor e (car args)))))
(let ((longform (let ((longform
(assq inst '((:loadv :loadv.l) (:loadg :loadg.l) (:setg :setg.l) (assq inst '((loadv loadv.l) (loadg loadg.l) (setg setg.l)
(:loada :loada.l) (:seta :seta.l))))) (loada loada.l) (seta seta.l)))))
(if (and longform (if (and longform
(> (car args) 255)) (> (car args) 255))
(set! inst (cadr longform)))) (set! inst (cadr longform))))
(let ((longform (let ((longform
(assq inst '((:loadc :loadc.l) (:setc :setc.l))))) (assq inst '((loadc loadc.l) (setc setc.l)))))
(if (and longform (if (and longform
(or (> (car args) 255) (or (> (car args) 255)
(> (cadr args) 255))) (> (cadr args) 255)))
(set! inst (cadr longform)))) (set! inst (cadr longform))))
(if (eq? inst :loada) (if (eq? inst 'loada)
(cond ((equal? args '(0)) (cond ((equal? args '(0))
(set! inst :loada0) (set! inst 'loada0)
(set! args ())) (set! args ()))
((equal? args '(1)) ((equal? args '(1))
(set! inst :loada1) (set! inst 'loada1)
(set! args ())))) (set! args ()))))
(if (eq? inst :loadc) (if (eq? inst 'loadc)
(cond ((equal? args '(0 0)) (cond ((equal? args '(0 0))
(set! inst :loadc00) (set! inst 'loadc00)
(set! args ())) (set! args ()))
((equal? args '(0 1)) ((equal? args '(0 1))
(set! inst :loadc01) (set! inst 'loadc01)
(set! args ())))) (set! args ()))))
(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? inst 'brf) (eq? lasti 'not)
(eq? (cadr bc) :null?)) (eq? (cadr bc) 'null?))
(aset! e 0 (cons (car args) (cons :brn (cddr bc))))) (aset! e 0 (cons (car args) (cons 'brn (cddr bc)))))
((and (eq? inst :brf) (eq? lasti :not)) ((and (eq? inst 'brf) (eq? lasti 'not))
(aset! e 0 (cons (car args) (cons :brt (cdr bc))))) (aset! e 0 (cons (car args) (cons 'brt (cdr bc)))))
((and (eq? inst :brf) (eq? lasti :eq?)) ((and (eq? inst 'brf) (eq? lasti 'eq?))
(aset! e 0 (cons (car args) (cons :brne (cdr bc))))) (aset! e 0 (cons (car args) (cons 'brne (cdr bc)))))
((and (eq? inst :brf) (eq? lasti :null?)) ((and (eq? inst 'brf) (eq? lasti 'null?))
(aset! e 0 (cons (car args) (cons :brnn (cdr bc))))) (aset! e 0 (cons (car args) (cons 'brnn (cdr bc)))))
((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
(aset! e 0 (nreconc (cons inst args) bc))))))) (aset! e 0 (nreconc (cons inst args) bc)))))))
e) e)
(define (make-label e) (gensym)) (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. ; convert symbolic bytecode representation to a byte array.
; labels are fixed-up. ; labels are fixed-up.
@ -127,13 +127,7 @@
(long? (>= (+ (length v) ; 1 byte for each entry, plus... (long? (>= (+ (length v) ; 1 byte for each entry, plus...
; at most half the entries in this vector can be ; at most half the entries in this vector can be
; instructions accepting 32-bit arguments ; instructions accepting 32-bit arguments
(* 3 (div0 (length v) 2)) (* 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)))
65536))) 65536)))
(let ((n (length v)) (let ((n (length v))
(i 0) (i 0)
@ -146,7 +140,7 @@
(while (< i n) (while (< i n)
(begin (begin
(set! vi (aref v i)) (set! vi (aref v i))
(if (eq? vi :label) (if (eq? vi 'label)
(begin (put! label-to-loc (aref v (+ i 1)) (sizeof bcode)) (begin (put! label-to-loc (aref v (+ i 1)) (sizeof bcode))
(set! i (+ i 2))) (set! i (+ i 2)))
(begin (begin
@ -155,34 +149,40 @@
(get Instructions (get Instructions
(if long? (if long?
(case vi (case vi
(:jmp :jmp.l) (jmp 'jmp.l)
(:brt :brt.l) (brt 'brt.l)
(:brf :brf.l) (brf 'brf.l)
(:brne :brne.l) (brne 'brne.l)
(:brnn :brnn.l) (brnn 'brnn.l)
(:brn :brn.l) (brn 'brn.l)
(else vi)) (else vi))
vi)))) vi))))
(set! i (+ i 1)) (set! i (+ i 1))
(set! nxt (if (< i n) (aref v i) #f)) (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) (put! fixup-to-label (sizeof bcode) nxt)
(io.write bcode ((if long? int32 int16) 0)) (io.write bcode ((if long? int32 int16) 0))
(set! i (+ i 1))) (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) ((number? nxt)
(case vi (case vi
((:loadv.l :loadg.l :setg.l :loada.l :seta.l ((loadv.l loadg.l setg.l loada.l seta.l
:largc :lvargc :call.l :tcall.l :optargs) largc lvargc call.l tcall.l)
(io.write bcode (int32 nxt)) (io.write bcode (int32 nxt))
(set! i (+ i 1))) (set! i (+ i 1)))
((:loadc :setc) ; 2 uint8 args ((loadc setc) ; 2 uint8 args
(io.write bcode (uint8 nxt)) (io.write bcode (uint8 nxt))
(set! i (+ i 1)) (set! i (+ i 1))
(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) ; 2 int32 args ((loadc.l setc.l optargs) ; 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)))
@ -245,7 +245,7 @@
(else (else
(if (and (constant? s) (if (and (constant? s)
(printable? (top-level-value 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)))))) (emit g (aref Is 2) s))))))
(define (compile-if g env tail? x) (define (compile-if g env tail? x)
@ -262,11 +262,11 @@
(compile-in g env tail? else)) (compile-in g env tail? else))
(else (else
(compile-in g env #f test) (compile-in g env #f test)
(emit g :brf elsel) (emit g 'brf elsel)
(compile-in g env tail? then) (compile-in g env tail? then)
(if tail? (if tail?
(emit g :ret) (emit g 'ret)
(emit g :jmp endl)) (emit g 'jmp endl))
(mark-label g elsel) (mark-label g elsel)
(compile-in g env tail? else) (compile-in g env tail? else)
(mark-label g endl))))) (mark-label g endl)))))
@ -277,14 +277,14 @@
(compile-in g env tail? (car forms))) (compile-in g env tail? (car forms)))
(else (else
(compile-in g env #f (car forms)) (compile-in g env #f (car forms))
(emit g :pop) (emit g 'pop)
(compile-begin g env tail? (cdr forms))))) (compile-begin g env tail? (cdr forms)))))
(define (compile-prog1 g env x) (define (compile-prog1 g env x)
(compile-in g env #f (cadr x)) (compile-in g env #f (cadr x))
(if (pair? (cddr x)) (if (pair? (cddr x))
(begin (compile-begin g env #f (cddr x)) (begin (compile-begin g env #f (cddr x))
(emit g :pop)))) (emit g 'pop))))
(define (compile-while g env cond body) (define (compile-while g env cond body)
(let ((top (make-label g)) (let ((top (make-label g))
@ -292,10 +292,10 @@
(compile-in g env #f #f) (compile-in g env #f #f)
(mark-label g top) (mark-label g top)
(compile-in g env #f cond) (compile-in g env #f cond)
(emit g :brf end) (emit g 'brf end)
(emit g :pop) (emit g 'pop)
(compile-in g env #f body) (compile-in g env #f body)
(emit g :jmp top) (emit g 'jmp top)
(mark-label g end))) (mark-label g end)))
(define (1arg-lambda? func) (define (1arg-lambda? func)
@ -310,7 +310,7 @@
(begin (compile-in g env #f lo) (begin (compile-in g env #f lo)
(compile-in g env #f hi) (compile-in g env #f hi)
(compile-in g env #f func) (compile-in g env #f func)
(emit g :for)) (emit g 'for))
(error "for: third form must be a 1-argument lambda"))) (error "for: third form must be a 1-argument lambda")))
(define (compile-short-circuit g env tail? forms default branch) (define (compile-short-circuit g env tail? forms default branch)
@ -319,16 +319,16 @@
(else (else
(let ((end (make-label g))) (let ((end (make-label g)))
(compile-in g env #f (car forms)) (compile-in g env #f (car forms))
(emit g :dup) (emit g 'dup)
(emit g branch end) (emit g branch end)
(emit g :pop) (emit g 'pop)
(compile-short-circuit g env tail? (cdr forms) default branch) (compile-short-circuit g env tail? (cdr forms) default branch)
(mark-label g end))))) (mark-label g end)))))
(define (compile-and g env tail? forms) (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) (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) (define (compile-arglist g env lst)
(for-each (lambda (a) (for-each (lambda (a)
@ -337,10 +337,10 @@
(length lst)) (length lst))
(define (argc-error head count) (define (argc-error head count)
(error (string "compile error: " head " expects " count (error "compile error: " head " expects " count
(if (= count 1) (if (= count 1)
" argument." " argument."
" arguments.")))) " arguments.")))
(define (compile-app g env tail? x) (define (compile-app g env tail? x)
(let ((head (car x))) (let ((head (car x)))
@ -356,28 +356,28 @@
(let ((head (car x)) (let ((head (car x))
(args (cdr x))) (args (cdr x)))
(unless (length= args (length (cadr head))) (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) (receive (the-f dept) (compile-f- env head #t)
(emit g :loadv the-f) (emit g 'loadv the-f)
(bcode:cdepth g dept)) (bcode:cdepth g dept))
(let ((nargs (compile-arglist g env args))) (let ((nargs (compile-arglist g env args)))
(emit g :copyenv) (emit g 'copyenv)
(emit g (if tail? :tcall :call) (+ 1 nargs))))) (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
fixnum? :fixnum? equal? :equal? fixnum? 'fixnum? equal? 'equal?
eq? :eq? symbol? :symbol? eq? 'eq? symbol? 'symbol?
div0 :div0 builtin? :builtin? div0 'div0 builtin? 'builtin?
aset! :aset! - :- boolean? :boolean? not :not aset! 'aset! - '- boolean? 'boolean? not 'not
apply :apply atom? :atom? apply 'apply atom? 'atom?
set-cdr! :set-cdr! / :/ set-cdr! 'set-cdr! / '/
function? :function? vector :vector function? 'function? vector 'vector
list :list bound? :bound? list 'list bound? 'bound?
< :< * :* cdr :cdr null? :null? < '< * '* cdr 'cdr null? 'null?
+ :+ eqv? :eqv? compare :compare aref :aref + '+ eqv? 'eqv? compare 'compare aref 'aref
set-car! :set-car! car :car set-car! 'set-car! car 'car
pair? :pair? = := vector? :vector?))) pair? 'pair? = '= vector? 'vector?)))
(lambda (b) (lambda (b)
(get b2i b #f)))) (get b2i b #f))))
@ -387,25 +387,25 @@
(not (length= (cdr x) count))) (not (length= (cdr x) count)))
(argc-error head count)) (argc-error head count))
(case b ; handle special cases of vararg builtins (case b ; handle special cases of vararg builtins
(:list (if (= nargs 0) (emit g :loadnil) (emit g b nargs))) (list (if (= nargs 0) (emit g 'loadnil) (emit g b nargs)))
(:+ (cond ((= nargs 0) (emit g :load0)) (+ (cond ((= nargs 0) (emit g 'load0))
((= nargs 2) (emit g :add2)) ((= nargs 2) (emit g 'add2))
(else (emit g b nargs)))) (else (emit g b nargs))))
(:- (cond ((= nargs 0) (argc-error head 1)) (- (cond ((= nargs 0) (argc-error head 1))
((= nargs 1) (emit g :neg)) ((= nargs 1) (emit g 'neg))
((= nargs 2) (emit g :sub2)) ((= nargs 2) (emit g 'sub2))
(else (emit g b nargs)))) (else (emit g b nargs))))
(:* (if (= nargs 0) (emit g :load1) (* (if (= nargs 0) (emit g 'load1)
(emit g b nargs))) (emit g b nargs)))
(:/ (if (= nargs 0) (/ (if (= nargs 0)
(argc-error head 1) (argc-error head 1)
(emit g b nargs))) (emit g b nargs)))
(:vector (if (= nargs 0) (vector (if (= nargs 0)
(emit g :loadv []) (emit g 'loadv [])
(emit g b nargs))) (emit g b nargs)))
(:apply (if (< nargs 2) (apply (if (< nargs 2)
(argc-error head 2) (argc-error head 2)
(emit g (if tail? :tapply :apply) nargs))) (emit g (if tail? 'tapply 'apply) nargs)))
(else (emit g b))))) (else (emit g b)))))
(define (compile-call g env tail? x) (define (compile-call g env tail? x)
@ -422,7 +422,7 @@
; more than 255 arguments, need long versions of instructions ; more than 255 arguments, need long versions of instructions
(begin (compile-in g env #f head) (begin (compile-in g env #f head)
(let ((nargs (compile-arglist g env (cdr x)))) (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) (let ((b (and (builtin? head)
(builtin->instruction head)))) (builtin->instruction head))))
(if (and (eq? head 'cadr) (if (and (eq? head 'cadr)
@ -430,14 +430,14 @@
(equal? (top-level-value 'cadr) cadr) (equal? (top-level-value 'cadr) cadr)
(length= x 2)) (length= x 2))
(begin (compile-in g env #f (cadr x)) (begin (compile-in g env #f (cadr x))
(emit g :cadr)) (emit g 'cadr))
(begin (begin
(if (not b) (if (not b)
(compile-in g env #f head)) (compile-in g env #f head))
(let ((nargs (compile-arglist g env (cdr x)))) (let ((nargs (compile-arglist g env (cdr x))))
(if b (if b
(compile-builtin-call g env tail? x head b nargs) (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) (define (expand-define form body)
(if (symbol? form) (if (symbol? form)
@ -448,41 +448,41 @@
(define (fits-i8 x) (and (fixnum? x) (>= x -128) (<= x 127))) (define (fits-i8 x) (and (fixnum? x) (>= x -128) (<= x 127)))
(define (compile-in g env tail? x) (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) ((atom? x)
(cond ((eq? x 0) (emit g :load0)) (cond ((eq? x 0) (emit g 'load0))
((eq? x 1) (emit g :load1)) ((eq? x 1) (emit g 'load1))
((eq? x #t) (emit g :loadt)) ((eq? x #t) (emit g 'loadt))
((eq? x #f) (emit g :loadf)) ((eq? x #f) (emit g 'loadf))
((eq? x ()) (emit g :loadnil)) ((eq? x ()) (emit g 'loadnil))
((fits-i8 x) (emit g :loadi8 x)) ((fits-i8 x) (emit g 'loadi8 x))
(else (emit g :loadv x)))) (else (emit g 'loadv x))))
(else (else
(case (car x) (case (car x)
(quote (emit g :loadv (cadr x))) (quote (emit g 'loadv (cadr x)))
(if (compile-if g env tail? x)) (if (compile-if g env tail? x))
(begin (compile-begin g env tail? (cdr x))) (begin (compile-begin g env tail? (cdr x)))
(prog1 (compile-prog1 g env x)) (prog1 (compile-prog1 g env x))
(lambda (receive (the-f dept) (compile-f- 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) (bcode:cdepth g dept)
(if (< dept (nnn env)) (if (< dept (nnn env))
(emit g :closure))))) (emit g 'closure)))))
(and (compile-and g env tail? (cdr x))) (and (compile-and g env tail? (cdr x)))
(or (compile-or g env tail? (cdr x))) (or (compile-or g env tail? (cdr x)))
(while (compile-while g env (cadr x) (cons 'begin (cddr x)))) (while (compile-while g env (cadr x) (cons 'begin (cddr x))))
(for (compile-for g env (cadr x) (caddr x) (cadddr x))) (for (compile-for g env (cadr x) (caddr x) (cadddr x)))
(return (compile-in g env #t (cadr x)) (return (compile-in g env #t (cadr x))
(emit g :ret)) (emit g 'ret))
(set! (compile-in g env #f (caddr x)) (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? (define (compile-in g env tail?
(expand-define (cadr x) (cddr x)))) (expand-define (cadr x) (cddr x))))
(trycatch (compile-in g env #f `(lambda () ,(cadr x))) (trycatch (compile-in g env #f `(lambda () ,(cadr x)))
(unless (1arg-lambda? (caddr x)) (unless (1arg-lambda? (caddr x))
(error "trycatch: second form must be a 1-argument lambda")) (error "trycatch: second form must be a 1-argument lambda"))
(compile-in g env #f (caddr x)) (compile-in g env #f (caddr x))
(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 . let?)
@ -516,19 +516,29 @@
(or (symbol? (car l)) (or (symbol? (car l))
(and (pair? (car l)) (and (pair? (car l))
(or (every pair? (cdr l)) (or (every pair? (cdr l))
(error (string "compile error: invalid argument list " (error "compile error: invalid argument list "
o ". optional arguments must come last.")))) o ". optional arguments must come last.")))
(error (string "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))
(if (eq? l o) (if (eq? l o)
(error (string "compile error: invalid argument list " o)) (error "compile error: invalid argument list " o)
(error (string "compile error: invalid formal argument " l (error "compile error: invalid formal argument " l " in list " o))))
" 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) (car s) s))
(to-proper l))) (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- (define compile-f-
(let ((*defines-processed-token* (gensym))) (let ((*defines-processed-token* (gensym)))
; to eval a top-level expression we need to avoid internal define ; to eval a top-level expression we need to avoid internal define
@ -553,31 +563,33 @@
(let ((g (make-code-emitter)) (let ((g (make-code-emitter))
(args (cadr f)) (args (cadr f))
(atail (lastcdr (cadr f)))
(vars (lambda-vars (cadr f))) (vars (lambda-vars (cadr f)))
(opta (filter pair? (cadr f))) (opta (filter pair? (cadr f)))
(name (if (eq? (lastcdr f) *defines-processed-token*) (name (if (eq? (lastcdr f) *defines-processed-token*)
'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))))
; emit argument checking prologue ; emit argument checking prologue
(if (not (null? opta)) (if (not (null? opta))
(begin (bcode:indexfor g (list->vector (map cadr opta))) (begin (emit g 'optargs (if (null? atail) nreq (- nreq)) nargs)
(emit g :optargs (- nargs (length opta))))) (emit-optional-arg-inits g env opta vars nreq)))
(cond ((not (null? let?)) (emit g :let)) (cond ((not (null? let?)) (emit g 'let))
((> nargs 255) (emit g (if (null? (lastcdr args)) ((> nargs 255) (emit g (if (null? atail)
:largc :lvargc) 'largc 'lvargc)
nargs)) nargs))
((null? (lastcdr args)) (emit g :argc nargs)) ((not (null? atail)) (emit g 'vargc nargs))
(else (emit g :vargc nargs))) ((null? opta) (emit g 'argc nargs)))
; compile body and return ; compile body and return
(compile-in g (cons vars env) #t (compile-in g (cons vars env) #t
(if (eq? (lastcdr f) *defines-processed-token*) (if (eq? (lastcdr f) *defines-processed-token*)
(caddr f) (caddr f)
(lambda-body f))) (lambda-body f)))
(emit g :ret) (emit g 'ret)
(values (function (encode-byte-code (bcode:code g)) (values (function (encode-byte-code (bcode:code g))
(const-to-idx-vec g) name) (const-to-idx-vec g) name)
(aref g 3))))))) (aref g 3)))))))
@ -623,43 +635,49 @@
(if (> i 4) (newline)) (if (> i 4) (newline))
(dotimes (xx lev) (princ "\t")) (dotimes (xx lev) (princ "\t"))
(princ (hex5 (- i 4)) ": " (princ (hex5 (- i 4)) ": "
(string.tail (string inst) 1) "\t") (string inst) "\t")
(set! i (+ i 1)) (set! i (+ i 1))
(case inst (case inst
((:loadv.l :loadg.l :setg.l) ((loadv.l loadg.l setg.l)
(print-val (aref vals (ref-int32-LE code i))) (print-val (aref vals (ref-int32-LE code i)))
(set! i (+ i 4))) (set! i (+ i 4)))
((:loadv :loadg :setg) ((loadv loadg setg)
(print-val (aref vals (aref code i))) (print-val (aref vals (aref code i)))
(set! i (+ i 1))) (set! i (+ i 1)))
((:loada :seta :call :tcall :list :+ :- :* :/ :vector ((loada seta call tcall list + - * / vector
:argc :vargc :loadi8 :apply :tapply) argc vargc loadi8 apply tapply)
(princ (number->string (aref code i))) (princ (number->string (aref code i)))
(set! i (+ i 1))) (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))) (princ (number->string (ref-int32-LE code i)))
(set! i (+ i 4))) (set! i (+ i 4)))
((:loadc :setc) ((loadc setc)
(princ (number->string (aref code i)) " ") (princ (number->string (aref code i)) " ")
(set! i (+ i 1)) (set! i (+ i 1))
(princ (number->string (aref code i))) (princ (number->string (aref code i)))
(set! i (+ i 1))) (set! i (+ i 1)))
((:loadc.l :setc.l) ((loadc.l setc.l optargs)
(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)))
((: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)))) (princ "@" (hex5 (+ i -4 (ref-int16-LE code i))))
(set! i (+ i 2))) (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)))) (princ "@" (hex5 (+ i -4 (ref-int32-LE code i))))
(set! i (+ i 4))) (set! i (+ i 4)))

2
femtolisp/flisp.boot
View File

File diff suppressed because one or more lines are too long

76
femtolisp/flisp.c
View File

@ -237,13 +237,14 @@ static symbol_t *mk_symbol(char *str)
sym = (symbol_t*)malloc(sizeof(symbol_t)-sizeof(void*) + len + 1); sym = (symbol_t*)malloc(sizeof(symbol_t)-sizeof(void*) + len + 1);
assert(((uptrint_t)sym & 0x7) == 0); // make sure malloc aligns 8 assert(((uptrint_t)sym & 0x7) == 0); // make sure malloc aligns 8
sym->left = sym->right = NULL; sym->left = sym->right = NULL;
sym->flags = 0;
if (fl_is_keyword_name(str, len)) { if (fl_is_keyword_name(str, len)) {
value_t s = tagptr(sym, TAG_SYM); value_t s = tagptr(sym, TAG_SYM);
setc(s, s); setc(s, s);
sym->flags |= 0x2;
} }
else { else {
sym->binding = UNBOUND; sym->binding = UNBOUND;
sym->isconst = 0;
} }
sym->type = sym->dlcache = NULL; sym->type = sym->dlcache = NULL;
sym->hash = memhash32(str, len)^0xAAAAAAAA; sym->hash = memhash32(str, len)^0xAAAAAAAA;
@ -932,28 +933,41 @@ static value_t apply_cl(uint32_t nargs)
curr_frame = SP; curr_frame = SP;
NEXT_OP; NEXT_OP;
OP(OP_OPTARGS) OP(OP_OPTARGS)
i = GET_INT32(ip); ip+=4;
n = GET_INT32(ip); ip+=4; n = GET_INT32(ip); ip+=4;
v = fn_vals(Stack[bp-1]); if ((int32_t)i < 0) {
v = vector_elt(v, 0); if (nargs < -i)
if (nargs >= n) { // if we have all required args lerror(ArgError, "apply: too few arguments");
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;
}
} }
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; NEXT_OP;
OP(OP_NOP) 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;
@ -1525,7 +1539,7 @@ static value_t apply_cl(uint32_t nargs)
assert(issymbol(v)); assert(issymbol(v));
sym = (symbol_t*)ptr(v); sym = (symbol_t*)ptr(v);
v = Stack[SP-1]; v = Stack[SP-1];
if (!sym->isconst) if (!isconstant(sym))
sym->binding = v; sym->binding = v;
NEXT_OP; NEXT_OP;
@ -1686,11 +1700,11 @@ static value_t apply_cl(uint32_t nargs)
#endif #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 *ip = code+4, *end = code+len;
uint8_t op; uint8_t op;
uint32_t n, sp = 0, maxsp = 0; uint32_t i, n, sp = 0, maxsp = 0;
while (1) { while (1) {
if ((int32_t)sp > (int32_t)maxsp) maxsp = sp; if ((int32_t)sp > (int32_t)maxsp) maxsp = sp;
@ -1713,10 +1727,12 @@ static uint32_t compute_maxstack(uint8_t *code, size_t len, value_t vals)
break; break;
case OP_LET: break; case OP_LET: break;
case OP_OPTARGS: case OP_OPTARGS:
ip += 4; i = abs(GET_INT32(ip)); ip+=4;
assert(isvector(vals)); n = GET_INT32(ip); ip+=4;
if (vector_size(vals) > 0) sp += (n-i);
sp += vector_size(vector_elt(vals, 0)); break;
case OP_BRBOUND:
ip+=8;
break; break;
case OP_TCALL: case OP_CALL: case OP_TCALL: case OP_CALL:
@ -1848,13 +1864,13 @@ static value_t fl_function(value_t *args, uint32_t nargs)
cvalue_t *arr = (cvalue_t*)ptr(args[0]); cvalue_t *arr = (cvalue_t*)ptr(args[0]);
cv_pin(arr); cv_pin(arr);
char *data = cv_data(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 // read syntax, shifted 48 for compact text representation
size_t i, sz = cv_len(arr); size_t i, sz = cv_len(arr);
for(i=0; i < sz; i++) for(i=0; i < sz; i++)
data[i] -= 48; 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); PUT_INT32(data, ms);
function_t *fn = (function_t*)alloc_words(4); function_t *fn = (function_t*)alloc_words(4);
value_t fv = tagptr(fn, TAG_FUNCTION); value_t fv = tagptr(fn, TAG_FUNCTION);

7
femtolisp/flisp.h
View File

@ -15,7 +15,7 @@ typedef struct {
} cons_t; } cons_t;
typedef struct _symbol_t { typedef struct _symbol_t {
value_t isconst; uptrint_t flags;
value_t binding; // global value binding value_t binding; // global value binding
struct _fltype_t *type; struct _fltype_t *type;
uint32_t hash; uint32_t hash;
@ -87,9 +87,10 @@ typedef struct _symbol_t {
#define fn_name(f) (((value_t*)ptr(f))[3]) #define fn_name(f) (((value_t*)ptr(f))[3])
#define set(s, v) (((symbol_t*)ptr(s))->binding = (v)) #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) ((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 symbol_value(s) (((symbol_t*)ptr(s))->binding)
#define ismanaged(v) ((((unsigned char*)ptr(v)) >= fromspace) && \ #define ismanaged(v) ((((unsigned char*)ptr(v)) >= fromspace) && \
(((unsigned char*)ptr(v)) < fromspace+heapsize)) (((unsigned char*)ptr(v)) < fromspace+heapsize))

5
femtolisp/opcodes.h
View File

@ -27,7 +27,7 @@ enum {
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_OPTARGS, OP_BRBOUND,
OP_BOOL_CONST_T, OP_BOOL_CONST_F, OP_THE_EMPTY_LIST, OP_BOOL_CONST_T, OP_BOOL_CONST_F, OP_THE_EMPTY_LIST,
@ -70,7 +70,8 @@ enum {
&&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_OPTARGS \ &&L_OP_BRNN, &&L_OP_BRNNL, &&L_OP_BRN, &&L_OP_BRNL, \
&&L_OP_OPTARGS, &&L_OP_BRBOUND \
} }
#define VM_APPLY_LABELS \ #define VM_APPLY_LABELS \

2
femtolisp/print.c
View File

@ -424,7 +424,7 @@ void fl_print_child(ios_t *f, value_t v)
break; break;
case TAG_CVALUE: case TAG_CVALUE:
case TAG_CPRIM: case TAG_CPRIM:
if (v == UNBOUND) { outs("#<undefined>", f); break; } if (v == UNBOUND) { outs("#<undefined>", f); break; }
case TAG_VECTOR: case TAG_VECTOR:
case TAG_CONS: case TAG_CONS:
if (print_circle_prefix(f, v)) return; if (print_circle_prefix(f, v)) return;

14
femtolisp/test.lsp
View File

@ -280,3 +280,17 @@
lastcdr to-proper reverse reverse! list->vector lastcdr to-proper reverse reverse! list->vector
table.foreach list-head list-tail assq memq assoc member table.foreach list-head list-tail assq memq assoc member
assv memv nreconc bq-process)) 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))))

22
femtolisp/todo
View File

@ -1128,3 +1128,25 @@ typedef struct {
uint32_t SP; uint32_t SP;
uint32_t curr_frame; uint32_t curr_frame;
} stackseg_t; } 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: