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

Put a lid on the T-k issues

Browse Source
This commit is contained in:
Dane Johnson
2026-02-04 11:15:44 -06:00
parent ec017b57fa
commit 9de16cfd3a
1 changed files with 66 additions and 6 deletions
Download Patch File Download Diff File Expand all files Collapse all files

70
scmvm/language/scheme.scm
View File

@@ -111,7 +111,7 @@
[(define? (car prgm))
(let-values ([(bindings cont) (collect-bindings prgm)])
`(letrec ,bindings ,(desugar-body cont)))]
[else (cons (desugar-exp (car prgm)) (desugar-top (cdr exp)))]))
[else (cons (desugar-exp (car prgm)) (desugar-top (cdr prgm)))]))
(define (desugar-exp exp)
(match exp
@@ -170,6 +170,66 @@
(let ([v0 (uniq-var v)])
(values (environment-extend r (list (cons v v0))) v0)))
(define (cps-aexp expr r)
(match expr
[('lambda (v* ...) e)
(let-values
([($k) (gensym "$k-")]
[(r0 v*0) (uniq-names r v*)])
`(lambda (,@v*0 ,$k) ,(cps-cexp-fo e $k r0)))]
[(? primitive?) `(cps-prim ,expr)]
((? symbol?)
(let ([kons (environment-assq r expr)])
(if kons (cdr kons) (signal-exception "Undefined variable:" expr))))
[(? atomic?) expr]))
(define (cps-cexp-fo expr c r)
(match expr
[ ('quote _) `(,c ,expr)]
[`(lambda . ,_) `(,c ,(cps-aexp expr r))]
[ (? atomic?) `(,c ,(cps-aexp expr r))]
[ (f e* ...)
(cps-cexp-ho
f
(lambda ($f)
(cps-cexp-map
e*
(lambda ($e*)
`(,$f ,@$e* ,c))
r))
r)]))
(define (cps-cexp-ho expr k r)
(match expr
[ ('quote _) (k expr)]
[`(lambda . ,_) (k (cps-aexp expr r))]
[ (? atomic?) (k (cps-aexp expr r))]
[ (f e* ...)
(let ([$rv (gensym "$rv-")])
(cps-cexp-ho
f
(lambda ($f)
(cps-cexp-map
e*
(lambda ($e*)
`(,$f ,@$e* (lambda (,$rv) ,(k $rv))))
r))
r))]))
(define (cps-cexp-map exprs k r)
;; exp* * (aexp -> cexp) -> cexp
(if (pair? exprs)
(cps-cexp-ho
(car exprs)
(lambda ($e)
(cps-cexp-map
(cdr exprs)
(lambda ($e*)
(k (cons $e $e*)))
r))
r)
(k '())))
(define (M expr r)
;; M dispatches to the appropriate transformer
;; expr -> aexp
@@ -195,7 +255,8 @@
[ ('letrec ([v* e*] ...) body)
(let-values ([(r0 v*0) (uniq-names r v*)])
(T*-k e* (lambda ($e*)
(T-k body (lambda ($body) `(letrec ,(zip v*0 $e*) (,c ,$body))) r0))
`(letrec ,(zip v*0 $e*)
,(T-c body c r0)))
r0))]
[ ('begin e) (T-c e c r)]
[ ('begin e e* ...)
@@ -257,13 +318,12 @@
(T-k e (lambda ($e)
`(set-then! ,v0 ,$e ,(k undefined-value))) r))]
[(f e* ...)
(let* ([$rv (gensym "$rv-")]
[$k (gensym "$k-")])
(let ([$rv (gensym "$rv-")])
(T-k f
(lambda ($f)
(T*-k e*
(lambda ($e*)
(k `((lambda (,$k) (,$f ,@$e* ,$k)) (lambda (,$rv) ,$rv))))
`(,$f ,@$e* (lambda (,$rv) ,(k $rv))))
r))
r))]))