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

improvements and bug fixes to CPS converter

This commit is contained in:
JeffBezanson 2008-12-29 00:00:45 +00:00
parent dc50df083c
commit 5bff23e790
1 changed files with 112 additions and 11 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

123
femtolisp/cps.lsp
View File

@ -34,11 +34,14 @@
(cond ((atom form) `(,k ,(reverse argsyms))) (cond ((atom form) `(,k ,(reverse argsyms)))
(T (rest->cps prim->cps form k argsyms)))) (T (rest->cps prim->cps form k argsyms))))
(define *top-k* (gensym))
(set *top-k* identity)
(define (cps form) (define (cps form)
(η-reduce (η-reduce
(β-reduce (β-reduce
(macroexpand (macroexpand
(cps- (macroexpand form) 'identity))))) (cps- (macroexpand form) *top-k*)))))
(define (cps- form k) (define (cps- form k)
(let ((g (gensym))) (let ((g (gensym)))
(cond ((or (atom form) (constantp form)) (cond ((or (atom form) (constantp form))
@ -65,19 +68,57 @@
`(let ((,g ,k)) `(let ((,g ,k))
,(cps- form g))))) ,(cps- form g)))))
((eq (car form) 'and)
(cond ((atom (cdr form)) `(,k T))
((atom (cddr form)) (cps- (cadr form) k))
(T
(if (atom k)
(cps- (cadr form)
`(lambda (,g)
(if ,g ,(cps- `(and ,@(cddr form)) k)
(,k ,g))))
`(let ((,g ,k))
,(cps- form g))))))
((eq (car form) 'or)
(cond ((atom (cdr form)) `(,k ()))
((atom (cddr form)) (cps- (cadr form) k))
(T
(if (atom k)
(cps- (cadr form)
`(lambda (,g)
(if ,g (,k ,g)
,(cps- `(or ,@(cddr form)) k))))
`(let ((,g ,k))
,(cps- form g))))))
((eq (car form) 'while)
(let ((test (cadr form))
(body (caddr form))
(lastval (gensym)))
(cps- (macroexpand
`(let ((,lastval nil))
((label ,g (lambda ()
(if ,test
(progn (setq ,lastval ,body)
(,g))
,lastval))))))
k)))
((eq (car form) 'setq) ((eq (car form) 'setq)
(let ((var (cadr form)) (let ((var (cadr form))
(E (caddr form))) (E (caddr form)))
(cps- E `(lambda (,g) (,k (setq ,var ,g)))))) (cps- E `(lambda (,g) (,k (setq ,var ,g))))))
((eq (car form) 'reset) ((eq (car form) 'reset)
`(,k ,(cps- (cadr form) 'identity))) `(,k ,(cps- (cadr form) *top-k*)))
((eq (car form) 'shift) ((eq (car form) 'shift)
(let ((v (cadr form)) (let ((v (cadr form))
(E (caddr form))) (E (caddr form))
`(let ((,v (lambda (ignored-k val) (,k val)))) (val (gensym)))
,(cps- E 'identity)))) `(let ((,v (lambda (,g ,val) (,g (,k ,val)))))
,(cps- E *top-k*))))
((and (constantp (car form)) ((and (constantp (car form))
(builtinp (eval (car form)))) (builtinp (eval (car form))))
@ -99,34 +140,72 @@
(app->cps form k ()))))) (app->cps form k ())))))
; (lambda (args...) (f args...)) => f ; (lambda (args...) (f args...)) => f
; but only for constant, builtin f
(define (η-reduce form) (define (η-reduce form)
(cond ((or (atom form) (constantp form)) form) (cond ((or (atom form) (constantp form)) form)
((and (eq (car form) 'lambda) ((and (eq (car form) 'lambda)
(let ((body (caddr form)) (let ((body (caddr form))
(args (cadr form))) (args (cadr form))
(func (car (caddr form))))
(and (consp body) (and (consp body)
(equal (cdr body) args)))) (equal (cdr body) args)
(constantp func))))
(η-reduce (car (caddr form)))) (η-reduce (car (caddr form))))
(T (map η-reduce form)))) (T (map η-reduce form))))
; ((lambda (f) (f arg)) X) => (X arg) (define (contains x form)
(or (eq form x)
(any (lambda (p) (contains x p)) form)))
(define (β-reduce form) (define (β-reduce form)
(cond ((or (atom form) (constantp form)) form) (cond ((or (atom form) (constantp form)) form)
; ((lambda (f) (f arg)) X) => (X arg)
((and (= (length form) 2) ((and (= (length form) 2)
(consp (car form)) (consp (car form))
(eq (caar form) 'lambda) (eq (caar form) 'lambda)
(let ((args (cadr (car form))) (let ((args (cadr (car form)))
(body (caddr (car form)))) (body (caddr (car form))))
(and (= (length body) 2) (and (consp body)
(= (length body) 2)
(= (length args) 1) (= (length args) 1)
(eq (car body) (car args)) (eq (car body) (car args))
(not (eq (cadr body) (car args))) (not (eq (cadr body) (car args)))
(symbolp (cadr body))))) (symbolp (cadr body)))))
`(,(β-reduce (cadr form)) `(,(β-reduce (cadr form))
,(cadr (caddr (car form))))) ,(cadr (caddr (car form)))))
; (identity x) => x
((eq (car form) *top-k*)
(β-reduce (cadr form)))
; uncurry:
; ((lambda (p1) ((lambda (args...) body) exprs...)) s) =>
; ((lambda (p1 args...) body) s exprs...)
; where exprs... doesn't contain p1
((and (= (length form) 2)
(consp (car form))
(eq (caar form) 'lambda)
(or (atom (cadr form)) (constantp (cadr form)))
(let ((args (cadr (car form)))
(s (cadr form))
(body (β-reduce (caddr (car form)))))
(and (= (length args) 1)
(consp body)
(consp (car body))
(eq (caar body) 'lambda)
(let ((innerargs (cadr (car body)))
(innerbody (caddr (car body)))
(params (cdr body)))
(and (not (contains (car args) params))
`((lambda ,(cons (car args) innerargs)
,innerbody)
,s
,@params)))))))
(T (map β-reduce form)))) (T (map β-reduce form))))
(defmacro with-delimited-continuations (exp) (cps exp)) (defmacro with-delimited-continuations code (cps (f-body code)))
(defmacro defgenerator (name args . body) (defmacro defgenerator (name args . body)
(let ((ko (gensym)) (let ((ko (gensym))
@ -155,6 +234,12 @@
(loop (+ 1 i)))))) (loop (+ 1 i))))))
lo)) lo))
; example from Chung-chieh Shan's paper
(assert (equal
(with-delimited-continuations
(cons 'a (reset (cons 'b (shift f (cons 1 (f (f (cons 'c ())))))))))
'(a 1 b b c)))
T T
#| #|
@ -163,5 +248,21 @@ todo:
calls to calls to funcall/cc that does the right thing for both calls to calls to funcall/cc that does the right thing for both
cc-lambdas and normal lambdas cc-lambdas and normal lambdas
- handle while, and, or - handle dotted arglists in lambda
here's an alternate way to transform a while loop:
(let ((x 0))
(while (< x 10)
(progn (#.print x) (setq x (+ 1 x)))))
=>
(let ((x 0))
(reset
(let ((l nil))
(let ((k (shift k (k k))))
(if (< x 10)
(progn (setq l (progn (#.print x)
(setq x (+ 1 x))))
(k k))
l)))))
|# |#