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

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 2009-08-12 04:56:32 +00:00
parent 97c05e8eb4
commit 332235231c
10 changed files with 205 additions and 78 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

41
femtolisp/compiler.lsp
View File

@ -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)))))

6
femtolisp/cps.lsp
View File

@ -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

8
femtolisp/cvalues.c
View File

@ -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);

2
femtolisp/flisp.boot
View File

File diff suppressed because one or more lines are too long

1
femtolisp/mkboot0.lsp
View File

@ -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")

4
femtolisp/perf.lsp
View File

@ -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) ())

192
femtolisp/system.lsp
View File

@ -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))))

14
femtolisp/test.lsp
View File

@ -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)))))))

2
femtolisp/tests/printcases.lsp
View File

@ -1,4 +1,4 @@
macroexpand
expand
append
bq-process

13
femtolisp/todo
View File

@ -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