changing semantics to respect lexical scope more strictly; now
anything can be shadowed by closer nested variables fixing bugs in let-syntax and expanding optional arg default values improving expansion algorithm on internal define some small optimizations to the compiler maintaining interpreter for bootstrapping
This commit is contained in:
JeffBezanson
parent
97c05e8eb4
commit
332235231c
|
|
@ -220,7 +220,10 @@
|
|||
((eq? item (car lst)) start)
|
||||
(else (index-of item (cdr lst) (+ start 1)))))
|
||||
|
||||
(define (in-env? s env) (any (lambda (e) (memq s e)) env))
|
||||
(define (in-env? s env)
|
||||
(and (pair? env)
|
||||
(or (memq s (car env))
|
||||
(in-env? s (cdr env)))))
|
||||
|
||||
(define (lookup-sym s env lev arg?)
|
||||
(if (null? env)
|
||||
|
|
@ -229,8 +232,8 @@
|
|||
(i (index-of s curr 0)))
|
||||
(if i
|
||||
(if arg?
|
||||
`(arg ,i)
|
||||
`(closed ,lev ,i))
|
||||
i
|
||||
(cons lev i))
|
||||
(lookup-sym s
|
||||
(cdr env)
|
||||
(if (or arg? (null? curr)) lev (+ lev 1))
|
||||
|
|
@ -239,20 +242,20 @@
|
|||
; number of non-nulls
|
||||
(define (nnn e) (count (lambda (x) (not (null? x))) e))
|
||||
|
||||
(define (printable? x) (not (iostream? x)))
|
||||
(define (printable? x) (not (or (iostream? x)
|
||||
(eof-object? x))))
|
||||
|
||||
(define (compile-sym g env s Is)
|
||||
(let ((loc (lookup-sym s env 0 #t)))
|
||||
(case (car loc)
|
||||
(arg (emit g (aref Is 0) (cadr loc)))
|
||||
(closed (emit g (aref Is 1) (cadr loc) (caddr loc))
|
||||
; update index of most distant captured frame
|
||||
(bcode:cdepth g (- (nnn (cdr env)) 1 (cadr loc))))
|
||||
(else
|
||||
(if (and (constant? s)
|
||||
(printable? (top-level-value s)))
|
||||
(emit g 'loadv (top-level-value s))
|
||||
(emit g (aref Is 2) s))))))
|
||||
(cond ((number? loc) (emit g (aref Is 0) loc))
|
||||
((number? (car loc)) (emit g (aref Is 1) (car loc) (cdr loc))
|
||||
; update index of most distant captured frame
|
||||
(bcode:cdepth g (- (nnn (cdr env)) 1 (car loc))))
|
||||
(else
|
||||
(if (and (constant? s)
|
||||
(printable? (top-level-value s)))
|
||||
(emit g 'loadv (top-level-value s))
|
||||
(emit g (aref Is 2) s))))))
|
||||
|
||||
(define (compile-if g env tail? x)
|
||||
(let ((elsel (make-label g))
|
||||
|
|
@ -440,10 +443,16 @@
|
|||
((eq? x #f) (emit g 'loadf))
|
||||
((eq? x ()) (emit g 'loadnil))
|
||||
((fits-i8 x) (emit g 'loadi8 x))
|
||||
((eof-object? x)
|
||||
(compile-in g env tail? (list (top-level-value 'eof-object))))
|
||||
(else (emit g 'loadv x))))
|
||||
((or (not (symbol? (car x))) (bound? (car x)) (in-env? (car x) env))
|
||||
(compile-app g env tail? x))
|
||||
(else
|
||||
(case (car x)
|
||||
(quote (emit g 'loadv (cadr x)))
|
||||
(quote (if (self-evaluating? (cadr x))
|
||||
(compile-in g env tail? (cadr x))
|
||||
(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))
|
||||
|
|
@ -487,7 +496,7 @@
|
|||
(list (caadr expr)))
|
||||
()))
|
||||
((eq? (car expr) 'begin)
|
||||
(apply append (map get-defined-vars- (cdr expr))))
|
||||
(apply nconc (map get-defined-vars- (cdr expr))))
|
||||
(else ())))))
|
||||
(lambda (expr) (delete-duplicates (get-defined-vars- expr)))))
|
||||
|
||||
|
|
|
|||
|
|
@ -66,8 +66,8 @@
|
|||
(define (cps form)
|
||||
(η-reduce
|
||||
(β-reduce
|
||||
(macroexpand
|
||||
(cps- (macroexpand form) *top-k*)))))
|
||||
(expand
|
||||
(cps- (expand form) *top-k*)))))
|
||||
(define (cps- form k)
|
||||
(let ((g (gensym)))
|
||||
(cond ((or (atom? form) (constant? form))
|
||||
|
|
@ -119,7 +119,7 @@
|
|||
(let ((test (cadr form))
|
||||
(body (caddr form))
|
||||
(lastval (gensym)))
|
||||
(cps- (macroexpand
|
||||
(cps- (expand
|
||||
`(let ((,lastval #f))
|
||||
((label ,g (lambda ()
|
||||
(if ,test
|
||||
|
|
|
|||
|
|
@ -945,11 +945,7 @@ static void cvalues_init()
|
|||
ALIGN8 = sizeof(struct { char a; int64_t i; }) - 8;
|
||||
ALIGNPTR = sizeof(struct { char a; void *i; }) - sizeof(void*);
|
||||
|
||||
cv_intern(pointer);
|
||||
cfunctionsym = symbol("c-function");
|
||||
|
||||
builtintype = define_opaque_type(builtinsym, sizeof(builtin_t), NULL,
|
||||
NULL);
|
||||
builtintype = define_opaque_type(builtinsym, sizeof(builtin_t), NULL, NULL);
|
||||
|
||||
ctor_cv_intern(int8);
|
||||
ctor_cv_intern(uint8);
|
||||
|
|
@ -968,9 +964,11 @@ static void cvalues_init()
|
|||
|
||||
ctor_cv_intern(array);
|
||||
ctor_cv_intern(enum);
|
||||
cv_intern(pointer);
|
||||
cv_intern(struct);
|
||||
cv_intern(union);
|
||||
cv_intern(void);
|
||||
cfunctionsym = symbol("c-function");
|
||||
|
||||
assign_global_builtins(cvalues_builtin_info);
|
||||
|
||||
|
|
|
|||
File diff suppressed because one or more lines are too long
|
|
@ -2,6 +2,7 @@
|
|||
|
||||
(if (not (bound? 'top-level-value)) (set! top-level-value %eval))
|
||||
(if (not (bound? 'set-top-level-value!)) (set! set-top-level-value! set))
|
||||
(if (not (bound? 'eof-object?)) (set! eof-object? (lambda (x) #f)))
|
||||
|
||||
;(load "compiler.lsp")
|
||||
|
||||
|
|
|
|||
|
|
@ -12,8 +12,8 @@
|
|||
(set! r (map-int (lambda (x) (mod (+ (* x 9421) 12345) 1024)) 1000))
|
||||
(time (sort r))
|
||||
|
||||
(princ "mexpand: ")
|
||||
(time (dotimes (n 5000) (macroexpand '(dotimes (i 100) body1 body2))))
|
||||
(princ "expand: ")
|
||||
(time (dotimes (n 5000) (expand '(dotimes (i 100) body1 body2))))
|
||||
|
||||
(define (my-append . lsts)
|
||||
(cond ((null? lsts) ())
|
||||
|
|
|
|||
|
|
@ -16,14 +16,15 @@
|
|||
(define-macro (label name fn)
|
||||
`((lambda (,name) (set! ,name ,fn)) #f))
|
||||
|
||||
(define (map1 f lst (acc (list ())))
|
||||
(cdr
|
||||
(prog1 acc
|
||||
(while (pair? lst)
|
||||
(begin (set! acc
|
||||
(cdr (set-cdr! acc (cons (f (car lst)) ()))))
|
||||
(set! lst (cdr lst)))))))
|
||||
|
||||
(define (map f lst . lsts)
|
||||
(define (map1 f lst acc)
|
||||
(cdr
|
||||
(prog1 acc
|
||||
(while (pair? lst)
|
||||
(begin (set! acc
|
||||
(cdr (set-cdr! acc (cons (f (car lst)) ()))))
|
||||
(set! lst (cdr lst)))))))
|
||||
(define (mapn f lsts)
|
||||
(if (null? (car lsts))
|
||||
()
|
||||
|
|
@ -332,8 +333,8 @@
|
|||
(let ((body (bq-process (vector->list x))))
|
||||
(if (eq (car body) 'list)
|
||||
(cons vector (cdr body))
|
||||
(list apply vector body)))
|
||||
x))
|
||||
(list apply vector body)))
|
||||
x))
|
||||
((atom? x) (list 'quote x))
|
||||
((eq (car x) 'backquote) (bq-process (bq-process (cadr x))))
|
||||
((eq (car x) '*comma*) (cadr x))
|
||||
|
|
@ -342,7 +343,9 @@
|
|||
(forms (map bq-bracket1 x)))
|
||||
(if (null? lc)
|
||||
(cons 'list forms)
|
||||
(nconc (cons 'list* forms) (list (bq-process lc))))))
|
||||
(if (null? (cdr forms))
|
||||
(list cons (car forms) (bq-process lc))
|
||||
(nconc (cons 'list* forms) (list (bq-process lc)))))))
|
||||
(#t (let ((p x) (q ()))
|
||||
(while (and (pair? p)
|
||||
(not (eq (car p) '*comma*)))
|
||||
|
|
@ -354,7 +357,11 @@
|
|||
(#t (nreconc q (list (bq-process p)))))))
|
||||
(if (null? (cdr forms))
|
||||
(car forms)
|
||||
(cons 'nconc forms)))))))
|
||||
(if (and (length= forms 2)
|
||||
(length= (car forms) 2)
|
||||
(eq? list (caar forms)))
|
||||
(list cons (cadar forms) (cadr forms))
|
||||
(cons 'nconc forms))))))))
|
||||
|
||||
(define (bq-bracket x)
|
||||
(cond ((atom? x) (list list (bq-process x)))
|
||||
|
|
@ -671,42 +678,135 @@
|
|||
(if f (apply f (cdr e))
|
||||
e))))
|
||||
|
||||
(define (macroexpand e)
|
||||
(define (macroexpand-in e env)
|
||||
(if (atom? e) e
|
||||
(let ((f (assq (car e) env)))
|
||||
(if f
|
||||
(macroexpand-in (apply (cadr f) (cdr e)) (caddr f))
|
||||
(let ((f (macrocall? e)))
|
||||
(if f
|
||||
(macroexpand-in (apply f (cdr e)) env)
|
||||
(cond ((eq (car e) 'quote) e)
|
||||
((eq (car e) 'lambda)
|
||||
`(lambda ,(cadr e)
|
||||
,.(map (lambda (x) (macroexpand-in x env))
|
||||
(cddr e))
|
||||
. ,(lastcdr e)))
|
||||
((eq (car e) 'define)
|
||||
`(define ,(cadr e)
|
||||
,.(map (lambda (x) (macroexpand-in x env))
|
||||
(cddr e))))
|
||||
((eq (car e) 'let-syntax)
|
||||
(let ((binds (cadr e))
|
||||
(body `((lambda () ,@(cddr e)))))
|
||||
(macroexpand-in
|
||||
body
|
||||
(nconc
|
||||
(map (lambda (bind)
|
||||
(list (car bind)
|
||||
(macroexpand-in (cadr bind) env)
|
||||
(define (expand e)
|
||||
; symbol resolves to toplevel; i.e. has no shadowing definition
|
||||
(define (top? s env) (not (or (bound? s) (assq s env))))
|
||||
|
||||
(define (splice-begin body)
|
||||
(cond ((atom? body) body)
|
||||
((equal? body '((begin)))
|
||||
body)
|
||||
((and (pair? (car body))
|
||||
(eq? (caar body) 'begin))
|
||||
(append (splice-begin (cdar body)) (splice-begin (cdr body))))
|
||||
(else
|
||||
(cons (car body) (splice-begin (cdr body))))))
|
||||
|
||||
(define *expanded* (list '*expanded*))
|
||||
|
||||
(define (expand-body body env)
|
||||
(if (atom? body) body
|
||||
(let* ((body (if (top? 'begin env)
|
||||
(splice-begin body)
|
||||
body))
|
||||
(def? (top? 'define env))
|
||||
(dvars (if def? (get-defined-vars body) ()))
|
||||
(env (nconc (map1 list dvars) env)))
|
||||
(if (not def?)
|
||||
(map (lambda (x) (expand-in x env)) body)
|
||||
(let* ((ex-nondefs ; expand non-definitions
|
||||
(let loop ((body body))
|
||||
(cond ((atom? body) body)
|
||||
((and (pair? (car body))
|
||||
(eq? 'define (caar body)))
|
||||
(cons (car body) (loop (cdr body))))
|
||||
(else
|
||||
(let ((form (expand-in (car body) env)))
|
||||
(set! env (nconc
|
||||
(map1 list (get-defined-vars form))
|
||||
env))
|
||||
binds)
|
||||
env))))
|
||||
(else
|
||||
(map (lambda (x) (macroexpand-in x env)) e)))))))))
|
||||
(macroexpand-in e ()))
|
||||
|
||||
(define (expand x) (macroexpand x))
|
||||
(cons
|
||||
(cons *expanded* form)
|
||||
(loop (cdr body))))))))
|
||||
(body ex-nondefs))
|
||||
(while (pair? body) ; now expand deferred definitions
|
||||
(if (not (eq? *expanded* (caar body)))
|
||||
(set-car! body (expand-in (car body) env))
|
||||
(set-car! body (cdar body)))
|
||||
(set! body (cdr body)))
|
||||
ex-nondefs)))))
|
||||
|
||||
(define (expand-lambda-list l env)
|
||||
(nconc
|
||||
(map (lambda (x) (if (and (pair? x) (pair? (cdr x)))
|
||||
(list (car x) (expand-in (cadr x) env))
|
||||
x))
|
||||
l)
|
||||
(lastcdr l)))
|
||||
|
||||
(define (l-vars l)
|
||||
(cond ((atom? l) l)
|
||||
((pair? (car l)) (cons (caar l) (l-vars (cdr l))))
|
||||
(else (cons (car l) (l-vars (cdr l))))))
|
||||
|
||||
(define (expand-lambda e env)
|
||||
(let ((formals (cadr e))
|
||||
(name (lastcdr e))
|
||||
(body (cddr e))
|
||||
(vars (l-vars (cadr e))))
|
||||
(let ((env (nconc (map1 list vars) env)))
|
||||
`(lambda ,(expand-lambda-list formals env)
|
||||
,.(expand-body body env)
|
||||
. ,name))))
|
||||
|
||||
(define (expand-define e env)
|
||||
(if (or (null? (cdr e)) (atom? (cadr e)))
|
||||
(if (null? (cddr e))
|
||||
e
|
||||
`(define ,(cadr e) ,(expand-in (caddr e) env)))
|
||||
(let ((formals (cdadr e))
|
||||
(name (caadr e))
|
||||
(body (cddr e))
|
||||
(vars (l-vars (cdadr e))))
|
||||
(let ((env (nconc (map1 list vars) env)))
|
||||
`(define ,(cons name (expand-lambda-list formals env))
|
||||
,.(expand-body body env))))))
|
||||
|
||||
(define (expand-let-syntax e env)
|
||||
(let ((binds (cadr e)))
|
||||
(cons 'begin
|
||||
(expand-body (cddr e)
|
||||
(nconc
|
||||
(map (lambda (bind)
|
||||
(list (car bind)
|
||||
((compile-thunk
|
||||
(expand-in (cadr bind) env)))
|
||||
env))
|
||||
binds)
|
||||
env)))))
|
||||
|
||||
; given let-syntax definition environment (menv) and environment
|
||||
; at the point of the macro use (lenv), return the environment to
|
||||
; expand the macro use in. TODO
|
||||
(define (local-expansion-env menv lenv) menv)
|
||||
|
||||
(define (expand-in e env)
|
||||
(if (atom? e) e
|
||||
(let* ((head (car e))
|
||||
(bnd (assq head env))
|
||||
(default (lambda ()
|
||||
(let loop ((e e))
|
||||
(if (atom? e) e
|
||||
(cons (expand-in (car e) env)
|
||||
(loop (cdr e))))))))
|
||||
(cond ((and bnd (pair? (cdr bnd))) ; local macro
|
||||
(expand-in (apply (cadr bnd) (cdr e))
|
||||
(local-expansion-env (caddr bnd) env)))
|
||||
((or bnd ; bound lexical or toplevel var
|
||||
(not (symbol? head))
|
||||
(bound? head))
|
||||
(default))
|
||||
(else
|
||||
(let ((f (macrocall? e)))
|
||||
(if f
|
||||
(expand-in (apply f (cdr e)) env)
|
||||
(cond ((eq head 'quote) e)
|
||||
((eq head 'lambda) (expand-lambda e env))
|
||||
((eq head 'define) (expand-define e env))
|
||||
((eq head 'let-syntax) (expand-let-syntax e env))
|
||||
(else
|
||||
(default))))))))))
|
||||
(expand-in e ()))
|
||||
|
||||
(define (eval x) ((compile-thunk (expand x))))
|
||||
|
||||
|
|
|
|||
|
|
@ -272,10 +272,9 @@
|
|||
'(emit encode-byte-code const-to-idx-vec
|
||||
index-of lookup-sym in-env? any every
|
||||
compile-sym compile-if compile-begin
|
||||
list-partition just-compile-args
|
||||
compile-arglist macroexpand builtin->instruction
|
||||
compile-app compile-let compile-call
|
||||
compile-in compile compile-f
|
||||
compile-arglist expand builtin->instruction
|
||||
compile-app separate nconc get-defined-vars
|
||||
compile-in compile compile-f delete-duplicates
|
||||
map length> length= count filter append
|
||||
lastcdr to-proper reverse reverse! list->vector
|
||||
table.foreach list-head list-tail assq memq assoc member
|
||||
|
|
@ -294,3 +293,10 @@
|
|||
(if (pred (car lst))
|
||||
(filto pred (cdr lst) (cons (car lst) accum))
|
||||
(filto pred (cdr lst) accum))))
|
||||
|
||||
; (pairwise? p a b c d) == (and (p a b) (p b c) (p c d))
|
||||
(define (pairwise? pred . args)
|
||||
(or (null? args)
|
||||
(let f ((a (car args)) (d (cdr args)))
|
||||
(or (null? d)
|
||||
(and (pred a (car d)) (f (car d) (cdr d)))))))
|
||||
|
|
|
|||
|
|
@ -1,4 +1,4 @@
|
|||
macroexpand
|
||||
expand
|
||||
append
|
||||
bq-process
|
||||
|
||||
|
|
|
|||
|
|
@ -983,6 +983,19 @@ consolidated todo list as of 7/8:
|
|||
- some kind of record, struct, or object system
|
||||
- improve test coverage
|
||||
|
||||
expansion process bugs:
|
||||
* expand default expressions for opt/keyword args (as if lexically in body)
|
||||
* make bound identifiers (lambda and toplevel) shadow macro keywords
|
||||
* to expand a body:
|
||||
1. splice begins
|
||||
2. add defined vars to env
|
||||
3. expand nondefinitions in the new env
|
||||
. if one expands to a definition, add the var to the env
|
||||
4. expand RHSes of definitions
|
||||
- add different spellings for builtin versions of core forms, like
|
||||
$begin, $define, and $set!. they can be replaced when found during expansion,
|
||||
and used when the compiler needs to generate them with known meanings.
|
||||
|
||||
- special efficient reader for #array
|
||||
- reimplement vectors as (array lispvalue)
|
||||
- implement fast subvectors and subarrays
|
||||
|
|
|
|||
Loading…
Reference in New Issue