dane/scm-to-vm
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

Cps conversion for full programs?

Browse Source
This commit is contained in:
Dane Johnson
2025-11-26 15:28:08 -06:00
parent 7eb1ede3d9
commit 69b6ccbce0
1 changed files with 30 additions and 17 deletions
Download Patch File Download Diff File Expand all files Collapse all files

47
scmvm/language/scheme.scm
View File

@@ -101,17 +101,17 @@
(define undefined-value (make-symbol "undefined")) (define undefined-value (make-symbol "undefined"))
(define (hybrid-conversion expr) (define (cps-convert expr ktail)
;; M : expr -> aexp ;; M : expr -> aexp
;; T-k : expr, (aexp -> cexp) -> cexp ;; T-k : expr, (aexp -> cexp) -> cexp
;; T-c : expr, aexp -> cexp ;; T-c : expr, aexp -> cexp
(define (M expr) (define (M expr)
;; M dispatches to the appropriate transformer ;; M dispatches to the appropriate transformer
(match expr (match expr
[`(lambda (,var) ,expr) [('lambda (var ...) e)
(let ([$k (gensym "$k")]) (let ([$k (gensym "$k")])
`(lambda (,var ,$k) ,(T-c expr $k)))] `(lambda (,@var ,$k) ,(T-c e $k)))]
[_ expr])) [(? atomic?) expr]))
(define (T-k expr k) (define (T-k expr k)
;; T-k takes an explicit continuation and calls it when done ;; T-k takes an explicit continuation and calls it when done
@@ -126,9 +126,9 @@
(T-k `((lambda (,@v*) ,body) ,@e*) k)] (T-k `((lambda (,@v*) ,body) ,@e*) k)]
[ ('if exp1 exp2 exp3) [ ('if exp1 exp2 exp3)
(T-k exp1 (lambda ($exp1) (T-k exp1 (lambda ($exp1)
(if $exp1 `(if ,$exp1
(T-k exp2 k) ,(T-k exp2 k)
(T-k exp3 k))))] ,(T-k exp3 k))))]
[ ('set! var expr) [ ('set! var expr)
(T-k expr (lambda ($expr) (T-k expr (lambda ($expr)
`(set-then! ,var ,$expr ,(k undefined-value))))] `(set-then! ,var ,$expr ,(k undefined-value))))]
@@ -151,18 +151,31 @@
(T-c `((lambda (,@v*) ,body) ,@e*) c)] (T-c `((lambda (,@v*) ,body) ,@e*) c)]
[ ('if exp1 exp2 exp3) [ ('if exp1 exp2 exp3)
(let ([$k (gensym "$k")]) ;; Bind cont to avoid blow up (let ([$k (gensym "$k")]) ;; Bind cont to avoid blow up
`((lambda (,$k)) `((lambda (,$k)
,(T-k exp1 (lambda (aexp) ,(T-k exp1 (lambda (aexp)
`(if ,aexp `(if ,aexp
,(T-c exp2 $k) ,(T-c exp2 $k)
,(T-c exp3 $k)))) ,(T-c exp3 $k)))))
,c))] ,c))]
[ ('set! var expr) [ ('set! var expr)
(T-k expr (lambda ($expr) (T-k expr (lambda ($expr)
`(set-then ,var ,$expr (,c ,undefined-value))))] `(set-then! ,var ,$expr (,c ,undefined-value))))]
[ (f e* ...) [ (f e* ...)
(T-k f (lambda ($f) (T-k f (lambda ($f)
(T*-k e* (lambda ($e*) (T*-k e* (lambda ($e*)
`(,$f ,@$e* ,c)))))])) `(,$f ,@$e* ,c)))))]))
(define-cps-loop T*-k T-k) (define-cps-loop T*-k T-k)
(T-c expr 'ktail)) (T-k expr ktail))
(define (cps-convert-prgm prgm)
(if (pair? prgm)
(cons (cps-convert-top (car prgm))
(cps-convert-prgm (cdr prgm)))
'()))
(define (cps-convert-top top)
(match top
[`(define ,v ,e)
(cps-convert e (lambda ($rv) `(define ,v ,$rv)))]
[_
(cps-convert top (lambda _ `(nop)))]))