From 244cd5e967f421f65d52c57c2d8e484c78bdffd3 Mon Sep 17 00:00:00 2001 From: Dane Johnson Date: Wed, 14 Jan 2026 13:42:08 -0600 Subject: [PATCH] Prefer letrec to define-then!, basically the same thing but one is real. Need to redo denotation --- scmvm/language/scheme.scm | 176 ++++---------------------------------- 1 file changed, 19 insertions(+), 157 deletions(-) diff --git a/scmvm/language/scheme.scm b/scmvm/language/scheme.scm index dfcc198..7876c9c 100644 --- a/scmvm/language/scheme.scm +++ b/scmvm/language/scheme.scm @@ -28,6 +28,12 @@ (symbol? x) (boolean? x))) +(define primitives + '(#t #f () cons car cdr = + - / *)) + +(define (primitive? x) + (memq x primitives)) + (define-syntax-rule (define-cps-loop name unit) (define (name v* k) (if (null? v*) @@ -116,6 +122,7 @@ [('lambda (var ...) e) (let ([$k (gensym "$k-")]) `(lambda (,@var ,$k) ,(T-c e $k)))] + [(? primitive?) `(cps-prim ,expr)] [(? atomic?) expr])) (define (T-k expr k) @@ -124,7 +131,7 @@ (match expr [`(lambda . ,_) (k (M expr))] [ (? atomic?) (k (M expr))] - [ ('define v e) (T-k `(define-then! ,v ,e) k)] + [ ('define v e) (T-k e (lambda ($e) `(letrec ([,v ,$e]) ,(k))))] [ ('begin e) (T-k e k)] [ ('begin e e* ...) (T-k e (lambda _ (T-k `(begin ,@e*) k)))] @@ -150,7 +157,7 @@ (match expr [`(lambda . ,_) `(,c ,(M expr))] [ (? atomic?) `(,c ,(M expr))] - [ ('define v e) (T-c `(define-then! ,v ,e) c)] + [ ('define v e) (T-k e (lambda ($e) `(letrec ([,v ,$e]) ,c)))] [ ('begin e) (T-c e c)] [ ('begin e e* ...) (T-k e (lambda _ (T-c `(begin ,@e*) c)))] @@ -172,162 +179,17 @@ (T*-k e* (lambda ($e*) `(,$f ,@$e* ,c)))))])) -(define (cps-convert-prgm prgm) - (T-c `(begin ,@prgm) 'ktail)) +(define (cps-convert-prgm prgm tail) + (T-c `(begin ,@prgm) tail)) (define-cps-loop T*-k T-k) -(define (ir-convert prgm) - (cps-convert-prgm (desugar-prgm prgm))) - - ;; Denotation - -(define *globals* (make-parameter '())) -(define *predefined* (make-parameter '())) - -(define (meaning e r) - (match e - [(? constant?) (meaning-constant e)] - [(? symbol?) (meaning-reference e r)] - [('lambda (vars ...) body) - (meaning-abstraction vars body r)] - [('set-then! var e k) - (meaning-assignment var e k r)] - [('define-then! var e k) - (meaning-definition var e k r)] - [('if e k1 k2) - (meaning-alternative e k1 k2 r)] - [(f e* ... k) - (meaning-application f e* k r)])) - -(define (meaning-reference v r) - (match (locate-variable v r) - [`(local ,i) (+local-reference+ i)] - [`(global ,i) (+global-reference+ i)] - [`(predefined ,p) (+predefined+ p)] - [_ (static-error "Reference to undefined variable" v)])) - -(define (meaning-constant c) - (+constant+ c)) - -(define (meaning-abstraction vars body r) - (let* ([arity (length vars)] - [r0 (r-extend r vars)] - [m+ (meaning body r0)]) - (append-meanings - (+fix-closure+ arity) - m+ - (+return+ arity)))) - -(define (meaning-assignment var e k r) - (let* ([m (meaning e r)] - [ma (match (locate-variable var r) - [`(local ,i) (+set!-local+ i)] - [`(global ,i) (+set!-global+ i)] - [`(predefined ,_) (static-error "Assignment to predefined variable" var)] - [_ (static-error "Assignment to undefined variable" var)])] - [mk (meaning k r)]) - (append-meanings m ma mk))) - -(define (meaning-definition var e k r) - (let* ([m (meaning e r)] - [mv (match (locate-variable var r) - [`(local ,_) (static-error "Definition conflicts local variable" var)] - [`(global ,_) (static-error "Redefinition of global variable" var)] - [`(predefined ,_) (static-error "Redefinition of predefined" var)] - [#f (+global-definition+ var)])] - [mk (meaning k r)]) - (append-meanings m mv mk))) - -(define (meaning-alternative e k1 k2 r) - (let* ([jump-false-label (gensym "jump-false-")] - [endif-label (gensym "endif-")] - [m (meaning e r)] - [mk1 (meaning k1 r)] - [mk2 (meaning k2 r)]) - (append-meanings - m - (+branch+ jump-false-label) mk1 (+goto+ endif-label) - (+label+ jump-false-label) mk2 (+label+ endif-label)))) - -(define (meaning-application f e* k r) - (let* ([arity (length e*)] - [mf (meaning f r)] - [m* (meaning* e* r)] - [mk (meaning k r)]) - (append-meanings - mf - m* (+frame-allocate+ arity) - (+frame-push+ arity) (+function-invoke+) (+frame-pop+ arity) - mk))) - -(define (meaning* e* r) - (if (pair? e*) - (let ([m (meaning (car e*) r)] - [m* (meaning* (cdr e*) r)]) - (append-meanings m m*)) - '())) - -(define (locate-variable v r) - (cond - [(list-index (lambda (v0) (eq? v v0)) r) => - (lambda (i) `(local ,i))] - [(list-index (lambda (v0) (eq? v v0)) (*globals*)) => - (lambda (i) `(global ,i))] - [(list-index (lambda (v0) (eq? v v0)) (*predefined*)) => - (lambda (p) `(predefined ,p))] - [else #f])) - -(define (constant? x) - (or (number? x) - (boolean? x) - (and (pair? x) (eq? 'quote (car x))))) - -(define (drop-environment vars r) - (let ([n (length vars)]) - (assert (equal? vars (take n r))) - (drop n r))) - -(define append-meanings append) - -(define (r-extend r vars) - (append vars r)) - -(define (global-extend! vars) - (*globals* (append vars (*globals*)))) - -(define (static-error . args) - `((+error+ ,@args))) - -(define-syntax define-combinator - (syntax-rules () - [(_ (name args ...)) - (define (name args ...) - `((name ,@(list args ...))))])) - -(define-combinator (+predefined+ i)) -(define-combinator (+global-reference+ i)) -(define-combinator (+local-reference+ i)) -(define-combinator (+constant+ c)) -(define-combinator (+fix-closure+ arity)) -(define-combinator (+return+ arity)) -(define-combinator (+set!-global+ i)) -(define-combinator (+set!-local+ i)) -(define-combinator (+alternative+ i)) -(define-combinator (+global-definition+ v)) -(define-combinator (+branch+ label)) -(define-combinator (+goto+ label)) -(define-combinator (+label+ name)) -(define-combinator (+frame-allocate+ size)) -(define-combinator (+frame-push+ size)) -(define-combinator (+function-invoke+)) -(define-combinator (+frame-pop+ size)) - -(define (std-predefined) - '(cons car cdr eq? pair? null? symbol? = + - * /)) - -(define* (scheme-compile prgm #:key (globals '())) - (parameterize ([*globals* globals] - [*predefined* (std-predefined)]) - (meaning (ir-convert prgm) '()))) +(define* (ir-convert prgm #:optional (tail 'ktail)) + (cps-convert-prgm (desugar-prgm prgm) tail)) +;; For testing +(define (cps-prim x) + (if (procedure? x) + (match-lambda* + [(args ... k) (k (apply x args))]) + x))