ref: 642d1e1bd4dadfade218128bcf3eb6980fe7d501
parent: 2c304edf4228b21e8b12ea737c14a8aa4791b997
author: JeffBezanson <jeff.bezanson@gmail.com>
date: Fri Jul 17 22:16:18 EDT 2009
rewriting some primitives to take advantage of the full language; they do not need to be written in terms of the base language any more moving handling of internal define and multiple-body-lambda to the compiler where it belongs. macroexpand now only handles syntax.
--- a/femtolisp/aliases.scm
+++ b/femtolisp/aliases.scm
@@ -1,6 +1,8 @@
; definitions of standard scheme procedures in terms of
; femtolisp procedures
+(define top-level-bound? bound?)
+
(define vector-ref aref)
(define vector-set! aset!)
(define vector-length length)
--- a/femtolisp/compiler.lsp
+++ b/femtolisp/compiler.lsp
@@ -418,6 +418,12 @@
(else (emit g b))))
(emit g (if tail? :tcall :call) nargs)))))))
+(define (expand-define form body)
+ (if (symbol? form)
+ `(set! ,form ,(car body))
+ `(set! ,(car form)
+ (lambda ,(cdr form) ,@body . ,(car form)))))
+
(define (fits-i8 x) (and (fixnum? x) (>= x -128) (<= x 127)))
(define (compile-in g env tail? x)
@@ -449,6 +455,8 @@
(emit g :ret))
(set! (compile-in g env #f (caddr x))
(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"))
@@ -461,24 +469,66 @@
(apply compile-f- env f let?)
ff))
-(define (compile-f- env f . let?)
- (let ((g (make-code-emitter))
- (args (cadr f)))
- (cond ((not (null? let?)) (emit g :let))
- ((length> args MAX_ARGS) (emit g (if (null? (lastcdr args))
- :largc :lvargc)
- (length args)))
- ((null? (lastcdr args)) (emit g :argc (length args)))
- (else (emit g :vargc (if (atom? args) 0 (length args)))))
- (compile-in g (cons (to-proper args) env) #t (caddr f))
- (emit g :ret)
- (values (function (encode-byte-code (bcode:code g))
- (const-to-idx-vec g) (lastcdr f))
- (aref g 3))))
+(define get-defined-vars
+ (letrec ((get-defined-vars-
+ (lambda (expr)
+ (cond ((atom? expr) ())
+ ((and (eq? (car expr) 'define)
+ (pair? (cdr expr)))
+ (or (and (symbol? (cadr expr))
+ (list (cadr expr)))
+ (and (pair? (cadr expr))
+ (symbol? (caadr expr))
+ (list (caadr expr)))
+ ()))
+ ((eq? (car expr) 'begin)
+ (apply append (map get-defined-vars- (cdr expr))))
+ (else ())))))
+ (lambda (expr) (delete-duplicates (get-defined-vars- expr)))))
-(define (compile f) (compile-f () f))
+(define compile-f-
+ (let ((*defines-processed-token* (gensym)))
+ ; to eval a top-level expression we need to avoid internal define
+ (set-top-level-value!
+ 'compile-thunk
+ (lambda (expr)
+ (compile `(lambda () ,expr . ,*defines-processed-token*))))
-(define (compile-thunk expr) (compile `(lambda () ,expr)))
+ (lambda (env f . let?)
+ ; convert lambda to one body expression and process internal defines
+ (define (lambda-body e)
+ (let ((B (if (pair? (cddr e))
+ (if (pair? (cdddr e))
+ (cons 'begin (cddr e))
+ (caddr e))
+ #f)))
+ (let ((V (get-defined-vars B)))
+ (if (null? V)
+ B
+ (cons (list* 'lambda V B *defines-processed-token*)
+ (map (lambda (x) #f) V))))))
+
+ (let ((g (make-code-emitter))
+ (args (cadr f))
+ (name (if (eq? (lastcdr f) *defines-processed-token*)
+ 'lambda
+ (lastcdr f))))
+ (cond ((not (null? let?)) (emit g :let))
+ ((length> args MAX_ARGS) (emit g (if (null? (lastcdr args))
+ :largc :lvargc)
+ (length args)))
+ ((null? (lastcdr args)) (emit g :argc (length args)))
+ (else (emit g :vargc (if (atom? args) 0 (length args)))))
+ (compile-in g (cons (to-proper args) env) #t
+ (if (eq? (lastcdr f) *defines-processed-token*)
+ (caddr f)
+ (lambda-body f)))
+ (emit g :ret)
+ (values (function (encode-byte-code (bcode:code g))
+ (const-to-idx-vec g) name)
+ (aref g 3))))))
+
+(define (compile f) (compile-f () f))
(define (ref-int32-LE a i)
(int32 (+ (ash (aref a (+ i 0)) 0)
--- a/femtolisp/flisp.boot
+++ b/femtolisp/flisp.boot
@@ -1,1 +1,1 @@
-(zero? #function("7000r1~`W;" [] zero?) vector.map #function("8000r2c0e1\x7f31u42;" [#function("8000vc0e1~31u42;" [#function(":000v`\x80azc0qw2~;" [#function(":000r1\x80~i20i21~[31\\;" [])]) vector.alloc]) length] vector.map) vector->list #function("9000r1c0e1~31_u43;" [#function(":000va~c0qw2\x7f;" [#function("8000r1i10\x80~z[\x81Ko01;" [])]) length] vector->list) values #function("9000s0~F16602~NA650~M;\x80~K;" [] #4=[(values) ()]) untrace #function("8000r1c0e1~31u42;" [#function("9000ve0~316@0e1\x80e2~31b2[42;^;" [traced? set-top-level-value! function:vals]) top-level-value] untrace) traced? #function("8000r1e0~31e0\x8031>;" [function:code] [#function("\xb9000s0e0c1~K312c2~x2;" [println x #.apply]) ()]) trace #function("8000r1c0e1~31u322c2;" [#function("8000vc0e130u42;" [#function("?000ve0\x8031@6a0e1i10e2c3~c4c5c6c7i10L2~L3L2c8c7\x80L2~L3L3L33142;^;" [traced? set-top-level-value! eval lambda begin println cons quote apply]) gensym]) top-level-value ok] trace) to-proper #function("8000r1~A640~;~?660~L1;~Me0~N31K;" [to-proper] to-proper) table.values #function("9000r1e0c1_~43;" [table.foldl #function("7000r3\x7fg2K;" [])] table.values) table.pairs #function("9000r1e0c1_~43;" [table.foldl #function("7000r3~\x7fKg2K;" [])] table.pairs) table.keys #function("9000r1e0c1_~43;" [table.foldl #function("7000r3~g2K;" [])] table.keys) table.invert #function("8000r1c0e130u42;" [#function("9000ve0c1q_\x80332~;" [table.foldl #function("9000r3e0\x80\x7f~43;" [put!])]) table] table.invert) table.foreach #function("9000r2e0c1q_\x7f43;" [table.foldl #function("8000r3\x80~\x7f322];" [])] table.foreach) table.clone #function("8000r1c0e130u42;" [#function("9000ve0c1q_\x80332~;" [table.foldl #function("9000r3e0\x80~\x7f43;" [put!])]) table] table.clone) symbol-syntax #function("9000r1e0e1~^43;" [get *syntax-environment*] symbol-syntax) string.trim #function("9000r3c0^^u43;" [#function("8000vc0qm02c1qm12c2e3\x8031u42;" [#function(";000r4g2g3X16?02e0\x7fe1~g232326A0\x80~\x7fe2~g232g344;g2;" [string.find string.char string.inc] trim-start) #function("<000r3e0g2`3216D02e1\x7fe2~e3~g23232326?0\x81~\x7fe3~g23243;g2;" [> string.find string.char string.dec] trim-end) #function("<000ve0i10\x80i10i11`~34\x81i10i12~3343;" [string.sub]) length])] string.trim) string.tail #function(";000r2e0~e1~`\x7f3342;" [string.sub string.inc] string.tail) string.rpad #function("<000r3e0~e1g2\x7fe2~31z3242;" [string string.rep string.count] string.rpad) string.rep #function(";000r2\x7fb4X6`0e0\x7f`32650c1;\x7faW680e2~41;\x7fb2W690e2~~42;e2~~~43;e3\x7f316@0e2~e4~\x7faz3242;e4e2~~32\x7fb2U242;" [<= "" string odd? string.rep] string.rep) string.map #function("9000r2c0e130e2\x7f31u43;" [#function("8000vc0`u322e1~41;" [#function(";000v^~\x81X6S02e0\x80i10e1i11~3231322e2i11~32m05\x0b/;" [io.putc string.char string.inc]) io.tostring!]) buffer length] string.map) string.lpad #function(";000r3e0e1g2\x7fe2~31z32~42;" [string string.rep string.count] string.lpad) string.join #function("8000r2~A650c0;c1e230u42;" ["" #function("8000ve0~\x80M322e1c2q\x80N322e3~41;" [io.write for-each #function("8000r1e0\x80i11322e0\x80~42;" [io.write]) io.tostring!]) buffer] string.join) simple-sort #function("8000r1~A17602~NA640~;c0~Mu42;" [#function("9000vc0e1c2q\x80N32u42;" [#function(":000ve0e1~M31\x80L1e1~N3143;" [nconc simple-sort]) separate #function("7000r1~\x80X;" [])])] simple-sort) set-syntax! #function("9000r2e0e1~\x7f43;" [put! *syntax-environment*]) separate #function(":000r2\x80~\x7f__44;" [] #0=[#function(";000r4\x7fA680g2g3K;~\x7fM316@0\x80~\x7fN\x7fMg2Kg344;\x80~\x7fNg2\x7fMg3K44;" [] #0#) ()]) self-evaluating? #function("8000r1~?16602~C@17K02e0~3116A02~C16:02~e1~31<;" [constant? top-level-value] self-evaluating?) reverse! #function("8000r1c0_u42;" [#function("9000v^\x80F6C02\x80N\x80~\x80m02P2o005\x1c/2~;" [])] reverse!) reverse #function("9000r1e0e1_~43;" [foldl cons] reverse) revappend #function("8000r2e0e1~31\x7f42;" [nconc reverse] revappend) repl #function("9000r0c0^^u43;" [#function("6000vc0m02c1qm12\x7f302e240;" [#function("8000r0e0c1312e2e3312c4c5c6tu42;" [princ "> " i\ No newline at end of file
+(zero? #function("7000r1~`W;" [] zero?) vector.map #function("8000r2c0e1\x7f31u42;" [#function("8000vc0e1~31u42;" [#function(":000v`\x80azc0qw2~;" [#function(":000r1\x80~i20i21~[31\\;" [])]) vector.alloc]) length] vector.map) vector->list #function("9000r1c0e1~31_u43;" [#function(":000va~c0qw2\x7f;" [#function("8000r1i10\x80~z[\x81Ko01;" [])]) length] vector->list) values #function("9000s0~F16602~NA650~M;\x80~K;" [] #5=[(*values*) ()]) untrace #function("8000r1c0e1~31u42;" [#function("9000ve0~316@0e1\x80e2~31b2[42;^;" [traced? set-top-level-value! function:vals]) top-level-value] untrace) traced? #function("8000r1e0~31e0\x8031>;" [function:code] [#function("\xb9000s0e0c1~K312c2~x2;" [println x #.apply]) ()]) trace #function("8000r1c0e1~31u322c2;" [#function("8000vc0e130u42;" [#function("?000ve0\x8031@6a0e1i10e2c3~c4c5c6c7i10L2~L3L2c8c7\x80L2~L3L3L33142;^;" [traced? set-top-level-value! eval lambda begin println cons quote apply]) gensym]) top-level-value ok] trace) to-proper #function("8000r1~A640~;~?660~L1;~Me0~N31K;" [to-proper] to-proper) table.values #function("9000r1e0c1_~43;" [table.foldl #function("7000r3\x7fg2K;" [])] table.values) table.pairs #function("9000r1e0c1_~43;" [table.foldl #function("7000r3~\x7fKg2K;" [])] table.pairs) table.keys #function("9000r1e0c1_~43;" [table.foldl #function("7000r3~g2K;" [])] table.keys) table.invert #function("8000r1c0e130u42;" [#function("9000ve0c1q_\x80332~;" [table.foldl #function("9000r3e0\x80\x7f~43;" [put!])]) table] table.invert) table.foreach #function("9000r2e0c1q_\x7f43;" [table.foldl #function("8000r3\x80~\x7f322];" [])] table.foreach) table.clone #function("8000r1c0e130u42;" [#function("9000ve0c1q_\x80332~;" [table.foldl #function("9000r3e0\x80~\x7f43;" [put!])]) table] table.clone) symbol-syntax #function("9000r1e0e1~^43;" [get *syntax-environment*] symbol-syntax) string.trim #function("9000r3c0^^u43;" [#function("8000vc0qm02c1qm12c2e3\x8031u42;" [#function(";000r4g2g3X16?02e0\x7fe1~g232326A0\x80~\x7fe2~g232g344;g2;" [string.find string.char string.inc] trim-start) #function("<000r3e0g2`3216D02e1\x7fe2~e3~g23232326?0\x81~\x7fe3~g23243;g2;" [> string.find string.char string.dec] trim-end) #function("<000ve0i10\x80i10i11`~34\x81i10i12~3343;" [string.sub]) length])] string.trim) string.tail #function(";000r2e0~e1~`\x7f3342;" [string.sub string.inc] string.tail) string.rpad #function("<000r3e0~e1g2\x7fe2~31z3242;" [string string.rep string.count] string.rpad) string.rep #function(";000r2\x7fb4X6`0e0\x7f`32650c1;\x7faW680e2~41;\x7fb2W690e2~~42;e2~~~43;e3\x7f316@0e2~e4~\x7faz3242;e4e2~~32\x7fb2U242;" [<= "" string odd? string.rep] string.rep) string.map #function("9000r2c0e130e2\x7f31u43;" [#function("8000vc0`u322e1~41;" [#function(";000v^~\x81X6S02e0\x80i10e1i11~3231322e2i11~32m05\x0b/;" [io.putc string.char string.inc]) io.tostring!]) buffer length] string.map) string.lpad #function(";000r3e0e1g2\x7fe2~31z32~42;" [string string.rep string.count] string.lpad) string.join #function("8000r2~A650c0;c1e230u42;" ["" #function("8000ve0~\x80M322e1c2q\x80N322e3~41;" [io.write for-each #function("8000r1e0\x80i11322e0\x80~42;" [io.write]) io.tostring!]) buffer] string.join) simple-sort #function("8000r1~A17602~NA640~;c0~Mu42;" [#function("9000vc0e1c2q\x80N32u42;" [#function(":000ve0e1~M31\x80L1e1~N3143;" [nconc simple-sort]) separate #function("7000r1~\x80X;" [])])] simple-sort) set-syntax! #function("9000r2e0e1~\x7f43;" [put! *syntax-environment*] set-syntax!) separate #function(":000r2\x80~\x7f__44;" [] #0=[#function(";000r4\x7fA680g2g3K;~\x7fM316@0\x80~\x7fN\x7fMg2Kg344;\x80~\x7fNg2\x7fMg3K44;" [] #0#) ()]) self-evaluating? #function("8000r1~?16602~C@17K02e0~3116A02~C16:02~e1~31<;" [constant? top-level-value] self-evaluating?) reverse! #function("8000r1c0_u42;" [#function("9000v^\x80F6C02\x80N\x80~\x80m02P2o005\x1c/2~;" [])] reverse!) reverse #function("9000r1e0e1_~43;" [foldl cons] reverse) revappend #function("8000r2e0e1~31\x7f42;" [nconc reverse] revappend) repl #function("9000r0c0^^u43;" [#function("6000vc0m02c1qm12\x7f302e240;" [#function("8000r0e0c1312e2e3312c4c5c6tu42;"\ No newline at end of file
--- a/femtolisp/system.lsp
+++ b/femtolisp/system.lsp
@@ -3,26 +3,18 @@
; by Jeff Bezanson (C) 2009
; Distributed under the BSD License
-(set! *syntax-environment* (table))
+(if (not (bound? '*syntax-environment*))
+ (define *syntax-environment* (table)))
-(set! set-syntax!
- (lambda (s v) (put! *syntax-environment* s v)))
-
-(set-syntax! 'define-macro
- (lambda (form . body)
- (list 'set-syntax! (list 'quote (car form))
- (cons 'lambda (cons (cdr form) body)))))
-
-(define-macro (define form . body)
- (if (symbol? form)
- (list 'set! form (car body))
- (list 'set! (car form)
- (list* 'lambda (cdr form) (append body (car form))))))
-
+(define (set-syntax! s v) (put! *syntax-environment* s v))
(define (symbol-syntax s) (get *syntax-environment* s #f))
+(define-macro (define-macro form . body)
+ `(set-syntax! ',(car form)
+ (lambda ,(cdr form) ,@body)))
+
(define-macro (label name fn)
- (list (list 'lambda (list name) (list 'set! name fn)) #f))
+ `((lambda (,name) (set! ,name ,fn)) #f))
(define (map f lst . lsts)
(define (map1 f lst acc)
@@ -42,28 +34,27 @@
(mapn f (cons lst lsts))))
(define-macro (let binds . body)
- ((lambda (lname)
- (begin
- (if (symbol? binds)
- (begin (set! lname binds)
- (set! binds (car body))
- (set! body (cdr body))))
- ((lambda (thelambda theargs)
- (cons (if lname
- (list 'label lname thelambda)
- thelambda)
- theargs))
- (cons 'lambda
- (cons (map (lambda (c) (if (pair? c) (car c) c)) binds)
- body))
- (map (lambda (c) (if (pair? c) (cadr c) #f)) binds))))
- #f))
+ (let (lname)
+ (if (symbol? binds)
+ (begin (set! lname binds)
+ (set! binds (car body))
+ (set! body (cdr body))))
+ (let ((thelambda
+ `(lambda ,(map (lambda (c) (if (pair? c) (car c) c))
+ binds)
+ ,@body))
+ (theargs
+ (map (lambda (c) (if (pair? c) (cadr c) #f)) binds)))
+ (cons (if lname
+ `(label ,lname ,thelambda)
+ thelambda)
+ theargs))))
(define-macro (letrec binds . body)
- (cons (cons 'lambda (cons (map car binds)
- (nconc (map (lambda (b) (cons 'set! b)) binds)
- body)))
- (map (lambda (x) #f) binds)))
+ `((lambda ,(map car binds)
+ ,.(map (lambda (b) `(set! ,@b)) binds)
+ ,@body)
+ ,.(map (lambda (x) #f) binds)))
(define-macro (cond . clauses)
(define (cond-clauses->if lst)
@@ -390,7 +381,7 @@
(else `(memv ,key ',v))))
(let ((g (gensym)))
`(let ((,g ,key))
- (cond ,@(map (lambda (clause)
+ (cond ,.(map (lambda (clause)
(cons (vals->cond g (car clause))
(cdr clause)))
clauses)))))
@@ -411,8 +402,8 @@
,@(cdr test-spec))
(begin
,@commands
- (,loop ,@steps))))))
- (,loop ,@inits))))
+ (,loop ,.steps))))))
+ (,loop ,.inits))))
; SRFI 8
(define-macro (receive formals expr . body)
@@ -618,23 +609,6 @@
; toplevel --------------------------------------------------------------------
-(define get-defined-vars
- (letrec ((get-defined-vars-
- (lambda (expr)
- (cond ((atom? expr) ())
- ((and (eq? (car expr) 'define)
- (pair? (cdr expr)))
- (or (and (symbol? (cadr expr))
- (list (cadr expr)))
- (and (pair? (cadr expr))
- (symbol? (caadr expr))
- (list (caadr expr)))
- ()))
- ((eq? (car expr) 'begin)
- (apply append (map get-defined-vars- (cdr expr))))
- (else ())))))
- (lambda (expr) (delete-duplicates (get-defined-vars- expr)))))
-
(define (macrocall? e) (and (symbol? (car e))
(get *syntax-environment* (car e) #f)))
@@ -645,21 +619,6 @@
e))))
(define (macroexpand e)
- (define (expand-lambda e env)
- (let ((B (if (pair? (cddr e))
- (if (pair? (cdddr e))
- (cons 'begin (cddr e))
- (caddr e))
- #f)))
- (let ((V (get-defined-vars B))
- (Be (macroexpand-in B env)))
- (list* 'lambda
- (cadr e)
- (if (null? V)
- Be
- (cons (list 'lambda V Be)
- (map (lambda (x) #f) V)))
- (lastcdr e)))))
(define (macroexpand-in e env)
(if (atom? e) e
(let ((f (assq (car e) env)))
@@ -669,7 +628,15 @@
(if f
(macroexpand-in (apply f (cdr e)) env)
(cond ((eq (car e) 'quote) e)
- ((eq (car e) 'lambda) (expand-lambda e env))
+ ((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)))))
--- a/femtolisp/todo
+++ b/femtolisp/todo
@@ -159,6 +159,7 @@
. write a function to evaluate directly from list to list, use it for
Nth arg and for user function rest args
. modify vararg builtins accordingly
+- filter should be stable. right now it reverses.
femtoLisp3...with symbolic C interface
@@ -1040,6 +1041,8 @@
* maxstack calculation, make Stack growable
* stack traces and better debugging support
- make maxstack calculation robust against invalid bytecode
+* improve internal define
+- try removing MAX_ARGS trickery
- let eversion
* lambda lifting
* let optimization