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

Update the implementation of step-sc so it errors when unsaturated

Browse source
This commit is contained in:
Yiyun Liu 2025-06-04 23:33:02 -04:00
parent 7f457c1bbd
commit 13c730f9d8
1 changed files with 16 additions and 20 deletions
Download patch file Download diff file Expand all files Collapse all files

36
semantics.rkt
View file

@ -90,33 +90,29 @@
(let ([stack (State-stack state)]) (let ([stack (State-stack state)])
(match stack (match stack
[(cons addr rstack) [(cons addr rstack)
(step-node state (lookup-node (State-heap state) addr))] (step-node rstack state (lookup-node (State-heap state) addr))]
['() (error "Invalid state")]))) ['() (error "Invalid state")])))
(: step-node (-> State Node State)) (: step-node (-> Stack State Node State))
(define (step-node st n) (define (step-node rstack st n)
(match n (match n
[(? integer?) (error "A number cannot be stepped any further!")] [(? integer?) (error "A number cannot be stepped any further!")]
[(list a _) (update-stack (λ (x) (cons a x)) st)] [(list a _) (update-stack (λ (x) (cons a x)) st)]
[(list 'define (list name args ...) body) [(list 'define (list name args ...) body)
(step-sc st args body)])) (step-sc rstack st args body)]))
(: step-sc (-> State (Listof Name) CoreExpr State)) (: step-sc (-> Stack State (Listof Name) CoreExpr State))
(define (step-sc state arg-names body) (define (step-sc rstack state arg-names body)
(let* ([stack (State-stack state)] (let ([heap (State-heap state)])
[heap (State-heap state)] (let*-values ([(new-env new-stack)
[new-env : Globals (for/fold ([globals : Globals (State-globals state)]
(for/fold ([globals : Globals (State-globals state)]) [stack : Stack rstack])
([arg-name : Name arg-names] ([arg-name : Name arg-names])
[addr : Addr (if (null? stack) (if (null? stack)
(error "impossible") (error "Not enough arguments to apply the supercombinator")
(cdr stack))]) (values (update-globals globals arg-name (car stack)) (cdr stack))))]
(update-globals globals arg-name addr))] [(new-heap addr) (instantiate-body body new-env heap)])
;; [new-stack : Stack (let ([new-stack (cons addr new-stack)])
;; (drop stack (add1 (length arg-names)))]
)
(let-values ([(new-heap addr) (instantiate-body body new-env heap)])
(let ([new-stack (cons addr (drop stack (add1 (length arg-names))))])
(struct-copy State state [stack new-stack] [heap new-heap]))))) (struct-copy State state [stack new-stack] [heap new-heap])))))
(: instantiate-body (-> CoreExpr Globals Heap (Values Heap Addr))) (: instantiate-body (-> CoreExpr Globals Heap (Values Heap Addr)))