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

Prefer letrec to define-then!, basically the same thing but one is real. Need to redo denotation

Browse Source
This commit is contained in:
Dane Johnson
2026-01-14 13:42:08 -06:00
parent 37bacda095
commit 244cd5e967
1 changed files with 19 additions and 157 deletions
Download Patch File Download Diff File Expand all files Collapse all files

176
scmvm/language/scheme.scm
View File

@@ -28,6 +28,12 @@
(symbol? x) (symbol? x)
(boolean? 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-syntax-rule (define-cps-loop name unit)
(define (name v* k) (define (name v* k)
(if (null? v*) (if (null? v*)
@@ -116,6 +122,7 @@
[('lambda (var ...) e) [('lambda (var ...) e)
(let ([$k (gensym "$k-")]) (let ([$k (gensym "$k-")])
`(lambda (,@var ,$k) ,(T-c e $k)))] `(lambda (,@var ,$k) ,(T-c e $k)))]
[(? primitive?) `(cps-prim ,expr)]
[(? atomic?) expr])) [(? atomic?) expr]))
(define (T-k expr k) (define (T-k expr k)
@@ -124,7 +131,7 @@
(match expr (match expr
[`(lambda . ,_) (k (M expr))] [`(lambda . ,_) (k (M expr))]
[ (? atomic?) (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) (T-k e k)]
[ ('begin e e* ...) [ ('begin e e* ...)
(T-k e (lambda _ (T-k `(begin ,@e*) k)))] (T-k e (lambda _ (T-k `(begin ,@e*) k)))]
@@ -150,7 +157,7 @@
(match expr (match expr
[`(lambda . ,_) `(,c ,(M expr))] [`(lambda . ,_) `(,c ,(M expr))]
[ (? atomic?) `(,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) (T-c e c)]
[ ('begin e e* ...) [ ('begin e e* ...)
(T-k e (lambda _ (T-c `(begin ,@e*) c)))] (T-k e (lambda _ (T-c `(begin ,@e*) c)))]
@@ -172,162 +179,17 @@
(T*-k e* (lambda ($e*) (T*-k e* (lambda ($e*)
`(,$f ,@$e* ,c)))))])) `(,$f ,@$e* ,c)))))]))
(define (cps-convert-prgm prgm) (define (cps-convert-prgm prgm tail)
(T-c `(begin ,@prgm) 'ktail)) (T-c `(begin ,@prgm) tail))
(define-cps-loop T*-k T-k) (define-cps-loop T*-k T-k)
(define (ir-convert prgm) (define* (ir-convert prgm #:optional (tail 'ktail))
(cps-convert-prgm (desugar-prgm prgm))) (cps-convert-prgm (desugar-prgm prgm) tail))
;; 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) '())))
;; For testing
(define (cps-prim x)
(if (procedure? x)
(match-lambda*
[(args ... k) (k (apply x args))])
x))