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

need to do something about the linkage and describe tail behavior separately from environment/clearing behavior

Browse Source
This commit is contained in:
Danny Yoo 2011-04-14 00:54:09 -04:00
parent 53a9889822
commit d959ecf9ae
4 changed files with 124 additions and 15 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

52
compiler.rkt
View File

@ -1267,8 +1267,11 @@
(: compile-with-cont-mark (WithContMark CompileTimeEnvironment Target Linkage -> InstructionSequence))
(define (compile-with-cont-mark exp cenv target linkage)
(cond
[(ReturnLinkage? linkage)
(append-instruction-sequences
(compile (WithContMark-key exp) cenv 'val next-linkage)
(make-instruction-sequence `(,(make-AssignImmediateStatement
@ -1277,11 +1280,52 @@
(compile (WithContMark-value exp) cenv 'val next-linkage)
(make-instruction-sequence `(,(make-PerformStatement
(make-InstallContinuationMarkEntry!))))
(compile (WithContMark-body exp) cenv target linkage)))
(compile (WithContMark-body exp) cenv target linkage))]
[(or (NextLinkage? linkage)
(PromptLinkage? linkage)
(LabelLinkage? linkage))
(let* ([after-key-multiple (make-label 'afterKeyMultiple)]
[after-key (make-LinkedLabel (make-label 'afterKey) after-key-multiple)]
[after-value-multiple (make-label 'afterValueMultiple)]
[after-value (make-LinkedLabel (make-label 'afterValue) after-value-multiple)]
[after-body-multiple (make-label 'afterBody)]
[after-body (make-LinkedLabel (make-label 'afterBody) after-body-multiple)])
(end-with-linkage
linkage cenv
(append-instruction-sequences
(make-instruction-sequence
`(,(make-AssignImmediateStatement 'proc (make-Const #f))
,(make-PushControlFrame after-key)))
(compile (WithContMark-key exp) cenv 'val prompt-linkage)
after-key-multiple
;; Fixme: we should error out here instead
(make-instruction-sequence
`(,(make-PopEnvironment (make-Reg 'argcount) (make-Const 0))))
after-key
(make-instruction-sequence `(,(make-AssignImmediateStatement
(make-ControlFrameTemporary 'pendingContinuationMarkKey)
(make-Reg 'val))))
(make-instruction-sequence
`(,(make-AssignImmediateStatement 'proc (make-Const #f))
,(make-PushControlFrame after-value)))
(compile (WithContMark-value exp) cenv 'val prompt-linkage)
after-value-multiple
;; Fixme: we should error out here instead
(make-instruction-sequence
`(,(make-PopEnvironment (make-Reg 'argcount) (make-Const 0))))
after-value
(make-instruction-sequence `(,(make-PerformStatement
(make-InstallContinuationMarkEntry!))))
(make-instruction-sequence
`(,(make-AssignImmediateStatement 'proc (make-Const #f))
,(make-PushControlFrame after-body)))
(compile (WithContMark-body exp) cenv target prompt-linkage)
after-body-multiple
;; Fixme: we should error out here instead
(make-instruction-sequence
`(,(make-PopEnvironment (make-Reg 'argcount) (make-Const 0))))
after-body)))]))

19
simulator-primitives.rkt
View File

@ -154,6 +154,22 @@
'current-continuation-marks)))
(define continuation-mark-set->list
;; not quite correct: ContinuationMarkSets need to preserve frame structure a bit more.
;; At the very least, we need to keep track of prompt tags somewhere.
(let ([f (lambda (a-machine mark-set key)
(let ([marks (ContinuationMarkSet-marks mark-set)])
(foldr make-MutablePair
null
(map cdr (filter (lambda (k+v)
(eq? (car k+v) key))
marks)))))])
(make-primitive-proc (lambda (machine . args) (apply f machine args))
'2 ;; fixme: should deal with prompt tags too
'current-continuation-marks)))
(define lookup-primitive (make-lookup #:functions (+ - * / = < <= > >=
@ -206,6 +222,7 @@
symbol?)
#:constants (null pi e
current-continuation-marks)))
current-continuation-marks
continuation-mark-set->list)))

2
simulator.rkt
View File

@ -740,7 +740,7 @@
(define (ensure-closure-or-false v)
(if (or (closure? v) (eq? v #f))
v
(error 'ensure-closure)))
(error 'ensure-closure-or-false)))
(: ensure-closure (SlotValue -> closure))
(define (ensure-closure v)

48
test-compiler.rkt
View File

@ -1087,6 +1087,54 @@
(make-ContinuationMarkSet (list (cons 'name "danny"))))
(test '(begin (define (extract-current-continuation-marks key)
(continuation-mark-set->list
(current-continuation-marks)
key))
(with-continuation-mark 'key 'mark
(extract-current-continuation-marks 'key)))
'(mark))
(test '(begin (define (extract-current-continuation-marks key)
(continuation-mark-set->list
(current-continuation-marks)
key))
(with-continuation-mark 'key1 'mark1
(with-continuation-mark 'key2 'mark2
(list
(extract-current-continuation-marks 'key1)
(extract-current-continuation-marks 'key2)))))
'((mark1) (mark2)))
(test '(begin (define (extract-current-continuation-marks key)
(continuation-mark-set->list
(current-continuation-marks)
key))
(with-continuation-mark 'key 'mark1
(with-continuation-mark 'key 'mark2 ; replaces previous mark
(extract-current-continuation-marks 'key))))
'(mark2))
;; Hmm... something is failing here.
#;(test '(begin (define (extract-current-continuation-marks key)
(continuation-mark-set->list
(current-continuation-marks)
key))
(with-continuation-mark 'key 'mark1
(list ; continuation extended to evaluate the argument
(with-continuation-mark 'key 'mark2
(extract-current-continuation-marks 'key)))))
'((mark2 mark1)))
#;(test (read (open-input-file "tests/conform/program0.sch"))
(port->string (open-input-file "tests/conform/expected0.txt")))