still chasing after browser bug; the simulator is working ok, so I assume I messed up somewhere in assembly
This commit is contained in:
Danny Yoo
parent
868711dae8
commit
c0d18edca8
40
assemble.rkt
40
assemble.rkt
|
|
@ -204,7 +204,11 @@ EOF
|
|||
empty]
|
||||
[(PushControlFrame? stmt)
|
||||
(list (PushControlFrame-label stmt))]
|
||||
[(PushControlFrame/Prompt? stmt)
|
||||
(list (PushControlFrame/Prompt-label stmt))]
|
||||
[(PopControlFrame? stmt)
|
||||
empty]
|
||||
[(PopControlFrame/Prompt? stmt)
|
||||
empty])
|
||||
(loop (rest stmts))))]))))
|
||||
|
||||
|
|
@ -261,9 +265,21 @@ EOF
|
|||
(assemble-jump (GotoStatement-target stmt))]
|
||||
|
||||
[(PushControlFrame? stmt)
|
||||
(format "MACHINE.control.push(new Frame(~a, MACHINE.proc));" (PushControlFrame-label stmt))]
|
||||
(format "MACHINE.control.push(new CallFrame(~a, MACHINE.proc));" (PushControlFrame-label stmt))]
|
||||
[(PushControlFrame/Prompt? stmt)
|
||||
;; fixme: use a different frame structure
|
||||
(format "MACHINE.control.push(new PromptFrame(~a, ~a));"
|
||||
(PushControlFrame/Prompt-label stmt)
|
||||
(let ([tag (PushControlFrame/Prompt-tag stmt)])
|
||||
(cond
|
||||
[(DefaultContinuationPromptTag? tag)
|
||||
(assemble-default-continuation-prompt-tag)]
|
||||
[(OpArg? tag)
|
||||
(assemble-oparg tag)])))]
|
||||
[(PopControlFrame? stmt)
|
||||
"MACHINE.control.pop();"]
|
||||
[(PopControlFrame/Prompt? stmt)
|
||||
"MACHINE.control.pop();"]
|
||||
[(PushEnvironment? stmt)
|
||||
(format "MACHINE.env.push(~a);" (string-join
|
||||
(build-list (PushEnvironment-n stmt)
|
||||
|
|
@ -345,8 +361,14 @@ EOF
|
|||
(CaptureEnvironment-skip op))]
|
||||
|
||||
[(CaptureControl? op)
|
||||
(format "MACHINE.control.slice(0, MACHINE.control.length - ~a)"
|
||||
(CaptureControl-skip op))]
|
||||
(format "captureControl(MACHINE, ~a, ~a)"
|
||||
(CaptureControl-skip op)
|
||||
(let ([tag (CaptureControl-tag op)])
|
||||
(cond [(DefaultContinuationPromptTag? tag)
|
||||
(assemble-default-continuation-prompt-tag)]
|
||||
[(OpArg? tag)
|
||||
(assemble-oparg tag)])))]
|
||||
|
||||
|
||||
[(MakeBoxedEnvironmentValue? op)
|
||||
(format "[MACHINE.env[MACHINE.env.length - 1 - ~a]]"
|
||||
|
|
@ -356,6 +378,10 @@ EOF
|
|||
(open-code-kernel-primitive-procedure op)]))
|
||||
|
||||
|
||||
(: assemble-default-continuation-prompt-tag (-> String))
|
||||
(define (assemble-default-continuation-prompt-tag)
|
||||
"DEFAULT_CONTINUATION_PROMPT_TAG")
|
||||
|
||||
|
||||
|
||||
|
||||
|
|
@ -406,7 +432,13 @@ EOF
|
|||
[(RestoreEnvironment!? op)
|
||||
"MACHINE.env = MACHINE.env[MACHINE.env.length - 2].slice(0);"]
|
||||
[(RestoreControl!? op)
|
||||
"MACHINE.control = MACHINE.env[MACHINE.env.length - 1].slice(0);"]
|
||||
(format "restoreControl(MACHINE, ~a);"
|
||||
(let ([tag (RestoreControl!-tag op)])
|
||||
(cond
|
||||
[(DefaultContinuationPromptTag? tag)
|
||||
(assemble-default-continuation-prompt-tag)]
|
||||
[(OpArg? tag)
|
||||
(assemble-oparg tag)])))]
|
||||
[(FixClosureShellMap!? op)
|
||||
(format "MACHINE.env[MACHINE.env.length - 1 - ~a].closedVals = [~a]"
|
||||
(FixClosureShellMap!-depth op)
|
||||
|
|
|
|||
47
runtime.js
47
runtime.js
|
|
@ -11,11 +11,17 @@
|
|||
// No error trapping at the moment.
|
||||
|
||||
|
||||
var Frame = function(label, proc) {
|
||||
var CallFrame = function(label, proc) {
|
||||
this.label = label;
|
||||
this.proc = proc;
|
||||
};
|
||||
|
||||
var PromptFrame = function(label, tag) {
|
||||
this.label = label;
|
||||
this.tag = tag;
|
||||
};
|
||||
|
||||
|
||||
|
||||
|
||||
// A closure consists of its free variables as well as a label
|
||||
|
|
@ -27,6 +33,14 @@ var Closure = function(label, arity, closedVals, displayName) {
|
|||
this.displayName = displayName;
|
||||
};
|
||||
|
||||
var ContinuationPromptTag = function(name) {
|
||||
this.name = name;
|
||||
};
|
||||
|
||||
var DEFAULT_CONTINUATION_PROMPT_TAG =
|
||||
new ContinuationPromptTag("default-continuation-prompt-tag");
|
||||
|
||||
|
||||
|
||||
|
||||
// A primitive function is just a Javascript function.
|
||||
|
|
@ -51,6 +65,37 @@ var testArgument = function(expectedTypeName,
|
|||
}
|
||||
};
|
||||
|
||||
|
||||
|
||||
|
||||
var captureControl = function(MACHINE, skip, tag) {
|
||||
var i;
|
||||
for (i = MACHINE.control.length - skip - 1; i >= 0; i--) {
|
||||
if (MACHINE.control[i].tag === tag) {
|
||||
return MACHINE.control.slice(i, MACHINE.control.length - skip);
|
||||
}
|
||||
}
|
||||
raise(new Error("captureControl: unable to find tag " + tag));
|
||||
};
|
||||
|
||||
|
||||
var restoreControl = function(MACHINE, tag) {
|
||||
var i;
|
||||
for (i = MACHINE.control.length - 1; i >= 0; i--) {
|
||||
if (MACHINE.control[i].tag === tag) {
|
||||
MACHINE.control =
|
||||
MACHINE.control.slice(0, i+1).concat(
|
||||
MACHINE.env[MACHINE.env.length - 1].slice(0));
|
||||
return;
|
||||
}
|
||||
}
|
||||
raise(new Error("restoreControl: unable to find tag " + tag));
|
||||
|
||||
}
|
||||
|
||||
|
||||
|
||||
|
||||
var isNumber = function(x) { return typeof(x) === 'number'; };
|
||||
|
||||
|
||||
|
|
|
|||
|
|
@ -38,7 +38,7 @@ EOF
|
|||
(with-syntax ([stx stx])
|
||||
(syntax/loc #'stx
|
||||
(begin
|
||||
(printf "running test...")
|
||||
(printf "running test... ~s" (syntax->datum #'stx))
|
||||
(let ([result (evaluate s)])
|
||||
(let ([output (evaluated-stdout result)])
|
||||
(unless (string=? output exp)
|
||||
|
|
|
|||
|
|
@ -892,7 +892,7 @@
|
|||
|
||||
|
||||
|
||||
#;(test '(begin
|
||||
(test '(begin
|
||||
(define (make-gen gen)
|
||||
(let ([cont (box #f)])
|
||||
(lambda ()
|
||||
|
|
@ -913,13 +913,13 @@
|
|||
(list (g1)))
|
||||
|
||||
(list "a")
|
||||
#:with-bootstrapping #t)
|
||||
#:with-bootstrapping? #t)
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
#;(test '(begin (define (f)
|
||||
(test '(begin (define (f)
|
||||
(define cont #f)
|
||||
(define n 0)
|
||||
(call/cc (lambda (x) (set! cont x)))
|
||||
|
|
@ -929,11 +929,12 @@
|
|||
n)
|
||||
(f))
|
||||
10
|
||||
#:with-bootstrapping #t)
|
||||
#:with-bootstrapping? #t)
|
||||
|
||||
|
||||
;; This should produce 0 because there needs to be a continuation prompt around each evaluation.
|
||||
#;(test '(begin
|
||||
;; This should produce 1 because there's a continuation prompt around each evaluation,
|
||||
;; and the call/cc cuts off at the prompt.
|
||||
(test '(begin
|
||||
(define cont #f)
|
||||
(define n 0)
|
||||
(call/cc (lambda (x) (set! cont x)))
|
||||
|
|
@ -941,63 +942,63 @@
|
|||
(if (< n 10)
|
||||
(cont 'dontcare))
|
||||
n)
|
||||
0
|
||||
1
|
||||
#:with-bootstrapping? #t)
|
||||
|
||||
|
||||
|
||||
|
||||
;; FIXME: this test is failing. I think we need prompts to delimit
|
||||
;; the continuation capture.
|
||||
#;(test '(begin
|
||||
(define (make-gen gen)
|
||||
(let ([cont (box #f)])
|
||||
(lambda ()
|
||||
(call/cc (lambda (caller)
|
||||
(if (unbox cont)
|
||||
((unbox cont) caller)
|
||||
(gen (lambda (v)
|
||||
(call/cc (lambda (gen-k)
|
||||
(begin
|
||||
(set-box! cont gen-k)
|
||||
(caller v))))))))))))
|
||||
|
||||
(define g1 (make-gen (lambda (return)
|
||||
(return "a")
|
||||
(return "b")
|
||||
(return "c"))))
|
||||
|
||||
(g1)
|
||||
(g1))
|
||||
"b")
|
||||
(test '(begin
|
||||
(define (make-gen gen)
|
||||
(let ([cont (box #f)])
|
||||
(lambda ()
|
||||
(call/cc (lambda (caller)
|
||||
(if (unbox cont)
|
||||
((unbox cont) caller)
|
||||
(gen (lambda (v)
|
||||
(call/cc (lambda (gen-k)
|
||||
(begin
|
||||
(set-box! cont gen-k)
|
||||
(caller v))))))))))))
|
||||
|
||||
(define g1 (make-gen (lambda (return)
|
||||
(return "a")
|
||||
(return "b")
|
||||
(return "c"))))
|
||||
|
||||
(g1)
|
||||
(g1))
|
||||
"b"
|
||||
#:with-bootstrapping? #t)
|
||||
|
||||
|
||||
|
||||
;; FIXME: this test is failing. I think we need prompts to delimit
|
||||
;; the continuation capture.
|
||||
#;(test '(begin
|
||||
(define (make-gen gen)
|
||||
(let ([cont (box #f)])
|
||||
(lambda ()
|
||||
(call/cc (lambda (caller)
|
||||
(if (unbox cont)
|
||||
((unbox cont) caller)
|
||||
(gen (lambda (v)
|
||||
(call/cc (lambda (gen-k)
|
||||
(begin
|
||||
(set-box! cont gen-k)
|
||||
(caller v))))))))))))
|
||||
|
||||
(define g1 (make-gen (lambda (return)
|
||||
(return "a")
|
||||
(return "b")
|
||||
(return "c"))))
|
||||
|
||||
(displayln (g1))
|
||||
(displayln (g1))
|
||||
(displayln (g1)))
|
||||
"a\nb\nc\n"
|
||||
#:with-bootstrapping #t)
|
||||
(let ([op (open-output-string)])
|
||||
(parameterize ([current-simulated-output-port op])
|
||||
(test '(begin
|
||||
(define (make-gen gen)
|
||||
(let ([cont (box #f)])
|
||||
(lambda ()
|
||||
(call/cc (lambda (caller)
|
||||
(if (unbox cont)
|
||||
((unbox cont) caller)
|
||||
(gen (lambda (v)
|
||||
(call/cc (lambda (gen-k)
|
||||
(begin
|
||||
(set-box! cont gen-k)
|
||||
(caller v))))))))))))
|
||||
|
||||
(define g1 (make-gen (lambda (return)
|
||||
(return "a")
|
||||
(return "b")
|
||||
(return "c"))))
|
||||
|
||||
(displayln (g1))
|
||||
(displayln (g1))
|
||||
(displayln (g1)))
|
||||
(void)
|
||||
#:with-bootstrapping? #t))
|
||||
(unless (string=? (get-output-string op) "a\nb\nc\n")
|
||||
(error 'failure)))
|
||||
|
||||
|
||||
|
||||
|
|
|
|||
Loading…
Reference in New Issue
Block a user