Fix the bug of not using the get-arg function
This commit is contained in:
parent
13c730f9d8
commit
784d27d564
1 changed files with 14 additions and 1 deletions
|
@ -76,6 +76,13 @@
|
||||||
(State (list (lookup-globals globals 'main)) empty-dump heap globals empty-stats)))
|
(State (list (lookup-globals globals 'main)) empty-dump heap globals empty-stats)))
|
||||||
|
|
||||||
|
|
||||||
|
(: eval-state (-> State (Pairof State (Listof State))))
|
||||||
|
(define (eval-state st)
|
||||||
|
(if (final-state? st)
|
||||||
|
(list st)
|
||||||
|
(let ([next-st (update-stats incr-stats (step st))])
|
||||||
|
(cons st (eval-state next-st)))))
|
||||||
|
|
||||||
(: data-node? (-> Node Boolean))
|
(: data-node? (-> Node Boolean))
|
||||||
(define data-node? integer?)
|
(define data-node? integer?)
|
||||||
|
|
||||||
|
@ -101,6 +108,12 @@
|
||||||
[(list 'define (list name args ...) body)
|
[(list 'define (list name args ...) body)
|
||||||
(step-sc rstack st args body)]))
|
(step-sc rstack st args body)]))
|
||||||
|
|
||||||
|
(: get-arg (-> Heap Addr Addr))
|
||||||
|
(define (get-arg heap addr)
|
||||||
|
(match (lookup-node heap addr)
|
||||||
|
[(list _ a) a]
|
||||||
|
[_ (error "Not an application node")]))
|
||||||
|
|
||||||
(: step-sc (-> Stack State (Listof Name) CoreExpr State))
|
(: step-sc (-> Stack State (Listof Name) CoreExpr State))
|
||||||
(define (step-sc rstack state arg-names body)
|
(define (step-sc rstack state arg-names body)
|
||||||
(let ([heap (State-heap state)])
|
(let ([heap (State-heap state)])
|
||||||
|
@ -110,7 +123,7 @@
|
||||||
([arg-name : Name arg-names])
|
([arg-name : Name arg-names])
|
||||||
(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 (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)])
|
[(new-heap addr) (instantiate-body body new-env heap)])
|
||||||
(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 new-heap])))))
|
||||||
|
|
Loading…
Add table
Add a link
Reference in a new issue