From 05fd5f5db29b68d9ada97945f8ecf5e5b12d667b Mon Sep 17 00:00:00 2001 From: Dane Johnson Date: Fri, 23 Jan 2026 09:10:50 -0600 Subject: [PATCH] Struggling here a bit, removing env from cps until scope issues are fixed --- scmvm/language/scheme.scm | 90 +++++++++++++++++---------------------- 1 file changed, 39 insertions(+), 51 deletions(-) diff --git a/scmvm/language/scheme.scm b/scmvm/language/scheme.scm index 128f32a..4a7e982 100644 --- a/scmvm/language/scheme.scm +++ b/scmvm/language/scheme.scm @@ -75,8 +75,8 @@ ;; Desugaring ;; Transforms to simplify the language -;; - lambdas and lets can only have 1 expression in body position -;; - defines are decomposed to lets that bind their values and wrap their continuations +;; - lambdas, lets and letrecs can only have 1 expression in body position +;; - defines are decomposed to letrecs that bind their values and wrap their continuations ;; ::= ... ;; ::= (lambda ( ...) ) ;; | (if ) @@ -96,9 +96,9 @@ (define (desugar-define def cont) (match def [`(define ,(name params ...) . ,e*) - `(letrec ([,name ,(desugar-exp `(lambda ,params ,@e*))]) ,@(desugar-top cont))] + `(letrec ([,name ,(desugar-exp `(lambda ,params ,@e*))]) (begin ,@(desugar-top cont)))] [`(define ,name ,exp) - `(letrec ([,name ,(desugar-exp exp)]) ,@(desugar-top cont))])) + `(letrec ([,name ,(desugar-exp exp)]) (begin ,@(desugar-top cont)))])) (define (desugar-exp exp) (match exp @@ -155,82 +155,76 @@ (define (ref-uniq r v*) (map (lambda (n) (cdr (environment-assq r n))) v*)) -(define (M expr r) +(define (M expr) ;; M dispatches to the appropriate transformer ;; expr -> aexp (match expr [('lambda (v* ...) e) - (let ([$k (gensym "$k-")] - [r0 (extend-uniq r v*)]) - `(lambda (,@(ref-uniq r0 v*) ,$k) ,(T-c e $k r0)))] + (let ([$k (gensym "$k-")]) + `(lambda (,@v* ,$k) ,(T-c e $k)))] [(? primitive?) `(cps-prim ,expr)] - [(? symbol?) (cdr (environment-assq r expr))] + [(? symbol?) expr] [(? atomic?) expr])) -(define (T-c expr c r) +(define (T-c expr c) ;; T-c takes a symbolic continuation, and uses it to construct CPS ;; (expr * aexp) -> cexp (match expr - [`(lambda . ,_) `(,c ,(M expr r))] - [ (? atomic?) `(,c ,(M expr r))] - [ ('define v e) - (let ([r0 (extend-uniq r (list v))]) - (T-k e (lambda ($e) `(letrec ([,@(ref-uniq r0 (list v)) ,$e]) ,c)) r0))] - [ ('begin e) (T-c e c r)] + [`(lambda . ,_) `(,c ,(M expr))] + [ (? atomic?) `(,c ,(M expr))] + [ ('letrec ([v e]) body) + (T-k e (lambda ($e) + (T-k body (lambda ($body) `(letrec ([,v ,$e]) (,c ,$body))))))] + [ ('begin e) (T-c e c)] [ ('begin e e* ...) (T-k e (lambda _ - (T-c `(begin ,@e*) c r)) r)] + (T-c `(begin ,@e*) c)))] [ ('let ([v* e*] ...) body) - (let ([r0 (extend-uniq r v*)]) - (T-c `((lambda (,@(ref-uniq r0 v*)) ,body) ,@e*) c r0))] + (T-c `((lambda (,@v*) ,body) ,@e*) c)] [ ('if exp1 exp2 exp3) (let ([$k (gensym "$k-")]) ;; Bind cont to avoid blow up `((lambda (,$k) ,(T-k exp1 (lambda (aexp) `(if ,aexp - ,(T-c exp2 $k r) - ,(T-c exp3 $k r))) r)) + ,(T-c exp2 $k) + ,(T-c exp3 $k))))) ,c))] [ ('set! var expr) (T-k expr (lambda ($expr) - `(set-then! ,var ,$expr (,c ,undefined-value))) r)] + `(set-then! ,var ,$expr (,c ,undefined-value))))] [ (f e* ...) (T-k f (lambda ($f) (T*-k e* (lambda ($e*) - `(,$f ,@$e* ,c)) r)) r)])) + `(,$f ,@$e* ,c)))))])) -(define (T-k expr k r) +(define (T-k expr k) ;; T-k takes an explicit continuation and calls it when done ;; As an invariant, T-k cannot nest a T-c call directly ;; (expr * (aexp -> cexp) -> cexp) (match expr - [`(lambda . ,_) (k (M expr r))] - [(? atomic?) (k (M expr r))] - [('define v e) - (let ([r0 (extend-uniq r (list v))]) - (T-k e - (lambda ($e) `(letrec ([,@(ref-uniq r0 (list v)) ,$e]) ,(k))) - r0))] - [('begin e) (T-k e k r)] + [`(lambda . ,_) (k (M expr))] + [(? atomic?) (k (M expr))] + [('letrec ([v e]) body) + (T-k e + (lambda ($e) + (T-k body + (lambda ($body) `(letrec ([,v ,$e]) ,(k $body))))))] + [('begin e) (T-k e k)] [('begin e e* ...) (T-k e (lambda _ - (T-k `(begin ,@e*) k r)) - r)] + (T-k `(begin ,@e*) k)))] [('let ([v* e*] ...) body) - (let ([r0 (extend-uniq r v*)]) - (T-k `((lambda (,@(ref-uniq r0 v*)) ,body) ,@e*) k r0))] + (T-k `((lambda (,@v*) ,body) ,@e*) k)] [('if exp1 exp2 exp3) (T-k exp1 (lambda ($exp1) `(if ,$exp1 - ,(T-k exp2 k r) - ,(T-k exp3 k r))) - r)] + ,(T-k exp2 k) + ,(T-k exp3 k))))] [('set! var expr) (T-k expr (lambda ($expr) - `(set-then! ,var ,$expr ,(k undefined-value))) - r)] + `(set-then! ,var ,$expr ,(k undefined-value))))] [(f e* ...) (let* ([$rv (gensym "$rv-")] [cont `(lambda (,$rv) ,(k $rv))]) @@ -238,24 +232,18 @@ (lambda ($f) (T*-k e* (lambda ($e*) - `(,$f ,@$e* ,cont)) - r)) - r))])) + `(,$f ,@$e* ,cont))))))])) ;; (expr* * (aexp* -> cexp) -> cexp) -(define (T*-k v* k r) +(define (T*-k v* k) (if (null? v*) (k '()) (T-k (car v*) (lambda (t) (T*-k (cdr v*) - (lambda (t*) (k (cons t t*))) - r)) - r))) - + (lambda (t*) (k (cons t t*)))))))) (define (cps-convert-prgm prgm tail) - (let ([r (make-environment)]) - (T-c `(begin ,@prgm) tail (environment-extend r (list (cons tail tail)))))) + (T-c prgm tail)) (define* (ir-convert prgm #:optional (tail 'ktail)) (cps-convert-prgm (desugar-top prgm) tail))