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

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.
This commit is contained in:
JeffBezanson 2009-07-18 02:16:18 +00:00
parent 2c304edf42
commit 642d1e1bd4
5 changed files with 111 additions and 89 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

2
femtolisp/aliases.scm
View File

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

64
femtolisp/compiler.lsp
View File

@ -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,25 +469,67 @@
(apply compile-f- env f let?)
ff))
(define (compile-f- env f . let?)
(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-
(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*))))
(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)))
(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 (caddr f))
(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) (lastcdr f))
(aref g 3))))
(const-to-idx-vec g) name)
(aref g 3))))))
(define (compile f) (compile-f () f))
(define (compile-thunk expr) (compile `(lambda () ,expr)))
(define (ref-int32-LE a i)
(int32 (+ (ash (aref a (+ i 0)) 0)
(ash (aref a (+ i 1)) 8)

2
femtolisp/flisp.boot
View File

File diff suppressed because one or more lines are too long

99
femtolisp/system.lsp
View File

@ -3,26 +3,18 @@
; by Jeff Bezanson (C) 2009
; Distributed under the BSD License
(set! *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))))))
(if (not (bound? '*syntax-environment*))
(define *syntax-environment* (table)))
(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
(let (lname)
(if (symbol? binds)
(begin (set! lname binds)
(set! binds (car body))
(set! body (cdr body))))
((lambda (thelambda theargs)
(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
(list 'label lname thelambda)
`(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))
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)))))

3
femtolisp/todo
View File

@ -159,6 +159,7 @@ bugs:
. 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 @@ new evaluator todo:
* 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