nybble
/
rosella
1
0
Fork 0
Code Issues Pull Requests Releases Wiki Activity

Implement support for (call/cc), and shorthand form (let/cc). 

Adds support for non-local returns, among other control-flow structures.
This commit is contained in:
Jesse D. McDonald 2010-04-16 14:05:14 -05:00
parent 14b2a1570a
commit b899f0c3b0
1 changed files with 81 additions and 24 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

105
compiler.ss
View File

@ -16,12 +16,15 @@
[(lambda) (simplify-lambda form)]
[(begin) (simplify-form `(let () ,@(cdr form)))]
[(set!) (simplify-set! form)]
[(car cdr cons) (simplify-primitive (case (first form)
[(car) '%car]
[(cdr) '%cdr]
[(cons) '%cons])
(cdr form))]
[(%bind %if %tail-call %apply %lambda %set! %cons %car %cdr quote) form]
[(let/cc) (simplify-form `(call/cc (lambda (,(second form)) ,@(cddr form))))]
[(car cdr cons call/cc)
(simplify-primitive (case (first form)
[(car) '%car]
[(cdr) '%cdr]
[(cons) '%cons]
[(call/cc) '%call/cc])
(cdr form))]
[(%bind %if %tail-call %apply %lambda %set! %cons %car %cdr %call/cc quote) form]
[else (simplify-funcall form)])
(if (eq? form '()) '%nil form)))
@ -34,11 +37,13 @@
(cond
[(pair? after) (cons subform after)]
[(or (not (pair? subform))
(memq (first subform) '(%apply %car %cdr %cons %bind %if quote)))
(memq (first subform) '(%apply %call/cc %car %cdr %cons %bind %if quote)))
`((set! ,(second form) ,subform))]
[(and (pair? subform) (eq? (first subform) '%tail-call))
`(,subform)] ; The %set! wouldn't be executed anyway.
[else (error "set! used with non-value form:" subform)]))
[else
`(,subform
(%set! ,(second form) %void))]))
'()
(cddr value-form))))
`(%set! ,(second form) ,value-form))))
@ -180,7 +185,8 @@
(values '() '() #f)))
(define (add-tail-call k rval form)
`(%bind ,(second form)
(define k-argv (gensym))
`(%bind (,@(second form) ,k-argv)
,@(foldr (lambda (subform after)
(cond
[(pair? after)
@ -193,6 +199,14 @@
(let ([fn (second (third subform))]
[argv (third (third subform))])
`((%tail-call ,fn ,argv ,k)))]
[(and (pair? subform)
(eq? (first subform) '%set!)
(eq? (second subform) rval)
(pair? (third subform))
(eq? (first (third subform)) '%call/cc))
(let ([fn (second (third subform))])
`((%set! ,k-argv (%cons %k %nil))
(%tail-call ,fn ,k-argv %k)))]
[(and (pair? subform)
(eq? (first subform) '%tail-call))
`(,subform)]
@ -201,6 +215,11 @@
`((%tail-call ,(second subform)
,(third subform)
,k))]
[(and (pair? subform)
(eq? (first subform) '%set!)
(eq? (second subform) rval)
(eq? (third subform) '%void))
`((%tail-call ,k %nil #f))]
[(and (pair? subform)
(eq? (first subform) '%set!)
(eq? (second subform) rval))
@ -267,11 +286,22 @@
; @after))
; (%tail-call x y k)))
; <= (%bind (var...)
; @before
; (call/cc l)
; @after)
; => (%bind (var... k k2)
; @before
; (%set! k (lambda _ @after))
; (%set! k-argv (%cons k %nil))
; (%tail-call l k-argv k))
(define (transform-to-cps form)
(flatten-binds
`(%bind ,(second form)
,@(foldr (lambda (subform after)
(cond
; (%set! v (%apply x y))
[(and (pair? subform)
(eq? (first subform) '%set!)
(pair? (third subform))
@ -280,12 +310,13 @@
[x (gensym)])
`((%bind (,k ,x)
(%set! ,k ,(simplify-form
`(lambda (,x)
`(lambda (,x . ,(gensym))
(%set! ,(second subform) ,x)
,@after)))
(%tail-call ,(second (third subform))
,(third (third subform))
,k))))]
; (%apply x y)
[(and (pair? subform)
(eq? (first subform) '%apply))
(let ([k (gensym)])
@ -296,6 +327,36 @@
(%tail-call ,(second subform)
,(third subform)
,k))))]
; (%set! v (%call/cc x))
[(and (pair? subform)
(eq? (first subform) '%set!)
(pair? (third subform))
(eq? (first (third subform)) '%call/cc))
(let ([k (gensym)]
[k-argv (gensym)]
[x (gensym)])
`((%bind (,k ,k-argv)
(%set! ,k ,(simplify-form
`(lambda (,x . ,(gensym))
(%set! ,(second subform) ,x)
,@after)))
(%set! ,k-argv (%cons ,k %nil))
(%tail-call ,(second (third subform))
,k-argv
,k))))]
; (%call/cc x)
[(and (pair? subform)
(eq? (first subform) '%call/cc))
(let ([k (gensym)]
[k-argv (gensym)])
`((%bind (,k ,k-argv)
(%set! ,k ,(simplify-form
`(lambda ,(gensym)
,@after)))
(%set! ,k-argv (%cons ,k %nil))
(%tail-call ,(second subform)
,k-argv
,k))))]
[else (cons subform after)]))
'()
(cddr form)))))
@ -332,7 +393,7 @@
form
`(%bind ,(second form) ,@(map recurse (cddr form))))]
[(quote) form]
[(%if %tail-call %apply %lambda %set! %cons %car %cdr)
[(%if %tail-call %apply %lambda %set! %cons %car %cdr %call/cc)
`(,(first form) ,@(map recurse (cdr form)))]
[else (error "Unsimplified form:" form)])
(if (eq? form old-var)
@ -353,7 +414,7 @@
frm
(map cons (second form) new-vars)))
(cddr form))))]
[(%if %tail-call %apply %lambda %set! %cons %car %cdr quote) form]
[(%if %tail-call %apply %lambda %set! %cons %car %cdr %call/cc quote) form]
[else (error "Unsimplified form:" form)])
form))
@ -371,13 +432,10 @@
(list new-form)))
(map flatten-binds (cddr form)))])
`(%bind ,bound-vars ,@subforms))]
[(%if %tail-call %apply %set! %lambda %cons %car %cdr quote) form]
[(%if %tail-call %apply %set! %lambda %cons %car %cdr %call/cc quote) form]
[else (error "Unsimplified form:" form)])
form))
(define (compile form)
(simplify-form `(lambda () ,form)))
(define (free-variables form [input? #t] [output? #t])
(define (recurse form) (free-variables form input? output?))
(if (pair? form)
@ -389,7 +447,7 @@
(cons (second form) (recurse (third form)))
(recurse (third form)))]
[(quote) '()]
[(%if %tail-call %apply %lambda %cons %car %cdr)
[(%if %tail-call %apply %lambda %cons %car %cdr %call/cc)
(remove-duplicates (append-map recurse (cdr form)))]
[else
(error "Unsimplified form:" form)])
@ -414,7 +472,7 @@
`(%bind ,(filter (lambda (x) (memq x ref-vars)) (second form))
,@(map reduce-variables (cddr form))))]
[(quote) form]
[(%if %tail-call %apply %set! %lambda %cons %car %cdr)
[(%if %tail-call %apply %set! %lambda %cons %car %cdr %call/cc)
`(,(first form) ,@(map reduce-variables (cdr form)))]
[else (error "Unsimplified form:" form)])
form))
@ -436,9 +494,8 @@
(cons subform after)))
'()
(map reduce-set! (cddr form)))))]
[(quote) form]
[(%if %tail-call %apply %set! %lambda %cons %car %cdr)
`(,(first form) ,@(map reduce-set! (cdr form)))]
[(%if %tail-call %apply %cons %car %cdr %call/cc quote) form]
[(%set! %lambda) `(,(first form) ,@(map reduce-set! (cdr form)))]
[else (error "Unsimplified form:" form)])
form))
@ -447,8 +504,8 @@
(reduce-set!
form)))
(pretty-print (optimize (compile (read))))
;(pretty-print (compile (read)))
;(pretty-print (optimize (trace compile (read))))
(pretty-print (optimize (simplify-form `(lambda () ,(read)))))
;(pretty-print (simplify-form (read)))
;(pretty-print (optimize (trace simplify-form (read))))
; vim:set sw=2 expandtab: