suzanne.soy/whalesong
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

getting call/cc working

Browse Source
This commit is contained in:
Danny Yoo 2011-03-11 19:33:24 -05:00
parent aecc0ad896
commit 0c497bef5c
3 changed files with 28 additions and 10 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

5
simulator-primitives.rkt
View File

@ -34,11 +34,6 @@
1 1
'())) '()))
(define e (exp 1)) (define e (exp 1))
(define lookup-primitive (make-lookup #:functions (+ - * / = < <= > >= cons list car cdr (define lookup-primitive (make-lookup #:functions (+ - * / = < <= > >= cons list car cdr

16
simulator.rkt
View File

@ -16,10 +16,13 @@
(provide new-machine can-step? step! current-instruction (provide new-machine can-step? step! current-instruction
current-simulated-output-port
machine-control-size) machine-control-size)
(define current-simulated-output-port (make-parameter (current-output-port)))
(: new-machine ((Listof Statement) -> machine)) (: new-machine ((Listof Statement) -> machine))
(define (new-machine program-text) (define (new-machine program-text)
(make-machine (make-undefined) (make-undefined) '() '() 0 (list->vector program-text) 0)) (make-machine (make-undefined) (make-undefined) '() '() 0 (list->vector program-text) 0))
@ -247,10 +250,13 @@
(ApplyPrimitiveProcedure-arity op)))]) (ApplyPrimitiveProcedure-arity op)))])
(cond (cond
[(primitive-proc? prim) [(primitive-proc? prim)
(target-updater! m (ensure-primitive-value (apply (primitive-proc-f prim) (target-updater! m (ensure-primitive-value
m (parameterize ([current-output-port
(ApplyPrimitiveProcedure-label op) (current-simulated-output-port)])
args)))] (apply (primitive-proc-f prim)
m
(ApplyPrimitiveProcedure-label op)
args))))]
[else [else
(error 'apply-primitive-procedure)]))] (error 'apply-primitive-procedure)]))]

17
test-compiler.rkt
View File

@ -544,5 +544,22 @@
1) 1)
;; Reference: http://lists.racket-lang.org/users/archive/2009-January/029812.html
(let ([op (open-output-string)])
(parameterize ([current-simulated-output-port op])
(test (begin (define program (lambda ()
(let ((y (call/cc (lambda (c) c))))
(display 1)
(call/cc (lambda (c) (y c)))
(display 2)
(call/cc (lambda (c) (y c)))
(display 3))))
(program))
(void))
(unless (string=? (get-output-string op)
"11213")
(error "puzzle failed: ~s" (get-output-string op)))))
;(simulate (compile (parse '42) 'val 'next)) ;(simulate (compile (parse '42) 'val 'next))
;(compile (parse '(+ 3 4)) 'val 'next) ;(compile (parse '(+ 3 4)) 'val 'next)