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

update compiliation steps to use the letrecs (fix combinators)

Browse Source
This commit is contained in:
Dane Johnson
2026-01-27 14:46:18 -06:00
parent 67d7cd8e3e
commit 01721cc9c2
1 changed files with 19 additions and 22 deletions
Download Patch File Download Diff File Expand all files Collapse all files

41
scmvm/language/scheme.scm
View File

@@ -52,7 +52,7 @@
(next environment-next) (next environment-next)
(values environment-values)) (values environment-values))
(define (make-environment) (define (null-environment)
(make-environment* #f '())) (make-environment* #f '()))
(define (environment-extend env values) (define (environment-extend env values)
@@ -62,9 +62,9 @@
(let loop ([r r] (let loop ([r r]
[j 0]) [j 0])
(cond (cond
[(not r) #f] [(not r) (values #f #f)]
[(list-index (lambda (n0) (eq? n n0)) (environment-values r)) => (lambda (i) (values i j))] [(list-index (lambda (n0) (eq? n n0)) (environment-values r)) => (lambda (i) (values i j))]
[else (loop (+ j 1) (environment-next r))]))) [else (loop (environment-next r) (+ j 1))])))
(define (environment-assq r n) (define (environment-assq r n)
(let loop ([r r]) (let loop ([r r])
@@ -275,7 +275,7 @@
(lambda (t*) (k (cons t t*))) r)) r))) (lambda (t*) (k (cons t t*))) r)) r)))
(define (cps-convert-prgm prgm tail) (define (cps-convert-prgm prgm tail)
(T-c prgm tail (make-environment))) (T-c prgm tail (null-environment)))
(define* (ir-convert prgm #:optional (tail 'ktail)) (define* (ir-convert prgm #:optional (tail 'ktail))
(cps-convert-prgm (desugar-top prgm) tail)) (cps-convert-prgm (desugar-top prgm) tail))
@@ -307,8 +307,8 @@
(meaning-assignment v e r k)] (meaning-assignment v e r k)]
[('if e k1 k2) [('if e k1 k2)
(meaning-alternative e r k1 k2)] (meaning-alternative e r k1 k2)]
[('letrec ([v e]) k) [('letrec ([v* e*] ...) k)
(meaning-definition v e r k)] (meaning-definition v* e* r k)]
[(f e* ... k) [(f e* ... k)
(meaning-application f e* r k)] (meaning-application f e* r k)]
[_ (signal-exception "Unrecognized cps" e)])) [_ (signal-exception "Unrecognized cps" e)]))
@@ -373,37 +373,34 @@
(let* ([m (meaning e r)] (let* ([m (meaning e r)]
[r0 (r-extend r v)] [r0 (r-extend r v)]
[mk (meaning k r0)]) [mk (meaning k r0)])
(meaning-append
m mk)))
(define (meaning-definition v e r k)
(let* ([r0 (r-extend r v)]
[m (meaning e r0)]
[mk (meaning k r0)])
(meaning-append m mk))) (meaning-append m mk)))
(define (meaning-definition v* e* r k)
(let* ([r0 (r-extend* r v*)]
[m* (meaning* e* r0)]
[mk (meaning k r0)])
(meaning-append m* mk)))
(define (meaning* e* r) (define (meaning* e* r)
(map (lambda (e) (meaning e r)) e*)) (apply append (map (lambda (e) (meaning e r)) e*)))
(define meaning-append append) (define meaning-append append)
(define signal-exception error) (define signal-exception error)
(define (r-extend r v) (define (r-extend r v)
(cons (list v) r)) (environment-extend r (list v)))
(define (r-extend* r v*) (define (r-extend* r v*)
(cons v* r)) (environment-extend r v*))
(define (locate-local-reference n j r) (define (locate-local-reference n r)
(cond (let-values ([(i j) (environment-lookup r n)])
[(null? r) #f] (and i j `(local ,j ,i))))
[(list-index (lambda (n0) (eq? n n0)) (car r)) => (lambda (i) `(local ,j ,i))]
[else (locate-local-reference n (+ j 1) (cdr r))]))
(define (locate-reference n r) (define (locate-reference n r)
(cond (cond
[(locate-local-reference n 0 r) => identity])) [(locate-local-reference n r) => identity]))
(define-syntax define-combinator (define-syntax define-combinator
(syntax-rules () (syntax-rules ()