changing optional args to allow default values to be computed from
preceding arguments tidying some stuff with keywords
This commit is contained in:
JeffBezanson
parent
eceeddf6d2
commit
ecfd81148f
|
|
@ -135,8 +135,7 @@ static value_t fl_keywordp(value_t *args, u_int32_t nargs)
|
|||
{
|
||||
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 @@ static value_t fl_set_top_level_value(value_t *args, u_int32_t nargs)
|
|||
{
|
||||
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 @@ static value_t fl_constantp(value_t *args, u_int32_t nargs)
|
|||
{
|
||||
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;
|
||||
|
|
|
|||
|
|
@ -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,14 +277,14 @@
|
|||
(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)
|
||||
(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,14 +430,14 @@
|
|||
(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))
|
||||
(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,41 +448,41 @@
|
|||
(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)))
|
||||
(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,31 +563,33 @@
|
|||
|
||||
(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
|
||||
(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)))
|
||||
|
||||
|
|
|
|||
File diff suppressed because one or more lines are too long
|
|
@ -237,13 +237,14 @@ static symbol_t *mk_symbol(char *str)
|
|||
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,28 +933,41 @@ static value_t apply_cl(uint32_t nargs)
|
|||
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;
|
||||
|
|
@ -1525,7 +1539,7 @@ static value_t apply_cl(uint32_t nargs)
|
|||
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 @@ static value_t apply_cl(uint32_t nargs)
|
|||
#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,10 +1727,12 @@ static uint32_t compute_maxstack(uint8_t *code, size_t len, value_t vals)
|
|||
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:
|
||||
|
|
@ -1848,13 +1864,13 @@ static value_t fl_function(value_t *args, uint32_t nargs)
|
|||
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);
|
||||
|
|
|
|||
|
|
@ -15,7 +15,7 @@ typedef struct {
|
|||
} 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 @@ typedef struct _symbol_t {
|
|||
#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))
|
||||
|
|
|
|||
|
|
@ -27,7 +27,7 @@ enum {
|
|||
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 @@ enum {
|
|||
&&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 \
|
||||
|
|
|
|||
|
|
@ -424,7 +424,7 @@ void fl_print_child(ios_t *f, value_t v)
|
|||
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;
|
||||
|
|
|
|||
|
|
@ -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))))
|
||||
|
|
|
|||
|
|
@ -1128,3 +1128,25 @@ typedef struct {
|
|||
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:
|
||||
|
|
|
|||
Loading…
Reference in New Issue