yiyunliu/core-in-racket
1
0
Fork 0
Code Issues Pull requests Projects Releases Packages Wiki Activity Actions

Minor

Browse source
This commit is contained in:
Yiyun Liu 2025-06-06 16:35:19 -04:00
parent ad1ca1d796
commit 6655004082
2 changed files with 24 additions and 8 deletions
Download patch file Download diff file Expand all files Collapse all files

31
semantics.rkt
View file

@ -34,6 +34,17 @@
(: incr-stats (-> Stats Stats)) (: incr-stats (-> Stats Stats))
(define incr-stats add1) (define incr-stats add1)
(: update-heap-undef (-> Heap Addr Node Heap))
(define (update-heap-undef heap addr node)
(if (eq? (treelist-ref heap addr) 'Undef)
(update-heap heap addr node)
(error "Address in heap is not undefined")))
(: update-heap (-> Heap Addr Node Heap))
(define (update-heap heap addr node)
(treelist-set heap addr node))
(: update-globals (-> Globals Name Addr Globals)) (: update-globals (-> Globals Name Addr Globals))
(define (update-globals globals name addr) (define (update-globals globals name addr)
(hash-set globals name addr)) (hash-set globals name addr))
@ -121,18 +132,21 @@
(if (null? stack) (if (null? stack)
(error "Not enough arguments to apply the supercombinator") (error "Not enough arguments to apply the supercombinator")
(values (update-globals globals arg-name (get-arg heap (car stack))) (cdr stack))))] (values (update-globals globals arg-name (get-arg heap (car stack))) (cdr stack))))]
[(new-heap addr) (instantiate-body body new-env heap)]) [(heap node) (instantiate-body body new-env heap)]
[(heap addr) (allocate-node heap node)])
(let ([new-stack (cons addr new-stack)]) (let ([new-stack (cons addr new-stack)])
(struct-copy State state [stack new-stack] [heap new-heap]))))) (struct-copy State state [stack new-stack] [heap heap])))))
(: instantiate-body (-> CoreExpr Globals Heap (Values Heap Addr))) (: instantiate-body (-> CoreExpr Globals Heap (∪ Addr (-> Addr Heap))))
(define (instantiate-body e env heap) (define (instantiate-body e env heap)
(match e (match e
[(? integer?) (allocate-node heap e)] [(? integer?) (λ (x : Addr) (update-heap-undef heap x e))]
[(list f a) [(list f a)
(let*-values ([(heap0 addr-f) (instantiate-body f env heap)] (let*-values ([(heap node0) (instantiate-body f env heap)]
[(heap1 addr-a) (instantiate-body a env heap0)]) [(heap node1) (instantiate-body a env heap)]
(allocate-node heap1 (list addr-f addr-a)))] [(heap addr-f) (allocate-node heap node0)]
[(heap addr-a) (allocate-node heap node1)])
(allocate-node heap (list addr-f addr-a)))]
[(? symbol?) (values heap (lookup-globals env e))] [(? symbol?) (values heap (lookup-globals env e))]
[(list 'let binds e) [(list 'let binds e)
(let-values ([(env heap) (instantiate-binds binds env heap)]) (let-values ([(env heap) (instantiate-binds binds env heap)])
@ -151,7 +165,8 @@
(define (instantiate-bind bind old-env new-env heap) (define (instantiate-bind bind old-env new-env heap)
(let ([x (first bind)] (let ([x (first bind)]
[e (second bind)]) [e (second bind)])
(let-values ([(heap addr) (instantiate-body e old-env heap)]) (let*-values ([(heap node) (instantiate-body e old-env heap)]
[(heap addr) (allocate-node heap node)])
(values (update-globals new-env x addr) heap)))) (values (update-globals new-env x addr) heap))))

1
tests/eval.rkt
View file

@ -1,6 +1,7 @@
#lang typed/racket #lang typed/racket
(require "../semantics.rkt") (require "../semantics.rkt")
(require "../ast.rkt") (require "../ast.rkt")
(require "../printer.rkt")
(require typed/rackunit) (require typed/rackunit)
(: exp->program (-> CoreExpr CoreProgram)) (: exp->program (-> CoreExpr CoreProgram))