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

Merge commit 'origin/exp' into exp

Browse Source 
Conflicts:

	test-simulator.rkt
This commit is contained in:
Danny Yoo 2011-03-16 13:37:22 -04:00
commit af698ab59b
16 changed files with 499 additions and 239 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

8
assemble.rkt
View File

@ -260,7 +260,7 @@ EOF
(build-list (PushEnvironment-n stmt)
(lambda: ([i : Natural])
(if (PushEnvironment-unbox? stmt)
"[]"
"[undefined]"
"undefined")))
", "))]
[(PopEnvironment? stmt)
@ -281,7 +281,9 @@ EOF
[(EnvLexicalReference? target)
(assemble-lexical-reference target)]
[(EnvPrefixReference? target)
(assemble-prefix-reference target)]))
(assemble-prefix-reference target)]
[(PrimitivesReference? target)
(format "Primitives[~s]" (symbol->string (PrimitivesReference-name target)))]))
@ -299,7 +301,7 @@ EOF
[(boolean? val)
(if val "true" "false")]
[(empty? val)
(format "Primitives.NULL")]
(format "Primitives.null")]
[else
(format "~s" val)])))

162
bootstrapped-primitives.rkt Normal file
View File

@ -0,0 +1,162 @@
#lang typed/racket/base
(require "expression-structs.rkt"
"lexical-structs.rkt"
"il-structs.rkt"
"lexical-env.rkt"
"helpers.rkt"
"find-toplevel-variables.rkt"
"sets.rkt"
"compile.rkt"
"typed-parse.rkt"
racket/list)
(provide get-bootstrapping-code)
;; The primitive code necessary to do call/cc
(: call/cc-label Symbol)
(define call/cc-label 'callCCEntry)
(define call/cc-closure-entry 'callCCClosureEntry)
;; (call/cc f)
;; Tail-calls f, providing it a special object that knows how to do the low-level
;; manipulation of the environment and control stack.
(define (make-call/cc-code)
(statements
(append-instruction-sequences
(make-instruction-sequence
`(,call/cc-label
;; Precondition: the environment holds the f function that we want to jump into.
;; First, move f to the proc register
,(make-AssignImmediateStatement 'proc (make-EnvLexicalReference 0 #f))
;; Next, capture the envrionment and the current continuation closure,.
,(make-PushEnvironment 2 #f)
,(make-AssignPrimOpStatement (make-EnvLexicalReference 0 #f)
(make-CaptureControl 0))
,(make-AssignPrimOpStatement (make-EnvLexicalReference 1 #f)
;; When capturing, skip over f and the two slots we just added.
(make-CaptureEnvironment 3))
,(make-AssignPrimOpStatement (adjust-target-depth (make-EnvLexicalReference 0 #f) 2)
(make-MakeCompiledProcedure call/cc-closure-entry
1 ;; the continuation consumes a single value
(list (make-EnvLexicalReference 0 #f)
(make-EnvLexicalReference 1 #f))
'call/cc))
,(make-PopEnvironment 2 0)))
;; Finally, do a tail call into f.
(compile-procedure-call '()
(extend-lexical-environment/placeholders '() 1)
1
'val
'return)
;; The code for the continuation coe follows. It's supposed to
;; abandon the current continuation, initialize the control and environment, and then jump.
(make-instruction-sequence `(,call/cc-closure-entry
,(make-AssignImmediateStatement 'val (make-EnvLexicalReference 0 #f))
,(make-PerformStatement (make-InstallClosureValues!))
,(make-PerformStatement (make-RestoreControl!))
,(make-PerformStatement (make-RestoreEnvironment!))
,(make-AssignPrimOpStatement 'proc (make-GetControlStackLabel))
,(make-PopControlFrame)
,(make-GotoStatement (make-Reg 'proc)))))))
(: make-bootstrapped-primitive-code (Symbol Any -> (Listof Statement)))
(define (make-bootstrapped-primitive-code name src)
(parameterize ([current-defined-name name])
(append
(compile (parse src) (make-PrimitivesReference name) 'next)
;; Remove the prefix after the Primitives assignment.
`(,(make-PopEnvironment 1 0)))))
(: get-bootstrapping-code (-> (Listof Statement)))
(define (get-bootstrapping-code)
(append
(make-bootstrapped-primitive-code
'map
'(letrec ([map (lambda (f l)
(if (null? l)
null
(cons (f (car l))
(map f (cdr l)))))])
map))
(make-bootstrapped-primitive-code
'for-each
'(letrec ([for-each (lambda (f l)
(if (null? l)
null
(begin (f (car l))
(for-each f (cdr l)))))])
for-each))
(make-bootstrapped-primitive-code
'caar
'(lambda (x)
(car (car x))))
(make-bootstrapped-primitive-code
'memq
'(letrec ([memq (lambda (x l)
(if (null? l)
#f
(if (eq? x (car l))
l
(memq x (cdr l)))))])
memq))
(make-bootstrapped-primitive-code
'assq
'(letrec ([assq (lambda (x l)
(if (null? l)
#f
(if (eq? x (caar l))
(car l)
(assq x (cdr l)))))])
assq))
(make-bootstrapped-primitive-code
'length
'(letrec ([length-iter (lambda (l i)
(if (null? l)
i
(length-iter (cdr l) (add1 i))))])
(lambda (l) (length-iter l 0))))
(make-bootstrapped-primitive-code
'append
'(letrec ([append (lambda (l1 l2)
(if (null? l1)
l2
(cons (car l1) (append (cdr l1) l2))))])
append))
;; The call/cc code is special:
(let ([after-call/cc-code (make-label 'afterCallCCImplementation)])
(append
`(,(make-AssignPrimOpStatement (make-PrimitivesReference 'call/cc)
(make-MakeCompiledProcedure call/cc-label 1 '() 'call/cc))
,(make-AssignPrimOpStatement (make-PrimitivesReference 'call-with-current-continuation)
(make-MakeCompiledProcedure call/cc-label 1 '() 'call/cc))
,(make-GotoStatement (make-Label after-call/cc-code)))
(make-call/cc-code)
`(,after-call/cc-code)))))

8
browser-evaluate.rkt
View File

@ -216,7 +216,13 @@ var comet = function() {
var invoke = eval(req.responseText)();
var output = [];
var startTime, endTime;
var params = { currentDisplayer: function(v) { output.push(String(v)); } };
var params = { currentDisplayer: function(v) {
var pNode = document.createElement("span");
pNode.style.whiteSpace = 'pre';
pNode.appendChild(document.createTextNode(String(v)));
document.body.appendChild(pNode);
//console.log(v);
output.push(String(v)); } };
var onSuccess = function(v) {
endTime = new Date();

72
compile.rkt
View File

@ -12,9 +12,8 @@
(provide (rename-out [-compile compile])
compile-procedure-call
append-instruction-sequences
call/cc-label
make-call/cc-code)
current-defined-name
adjust-target-depth)
(: current-defined-name (Parameterof (U Symbol False)))
@ -32,10 +31,7 @@
exp)
(list)
target
linkage)
(make-instruction-sequence `(,(make-GotoStatement (make-Label end))))
(make-call/cc-code)
end))))
linkage)))))
@ -625,7 +621,9 @@
(EnvLexicalReference-unbox? target))]
[(EnvPrefixReference? target)
(make-EnvPrefixReference (+ n (EnvPrefixReference-depth target))
(EnvPrefixReference-pos target))]))
(EnvPrefixReference-pos target))]
[(PrimitivesReference? target)
target]))
@ -652,61 +650,3 @@
(error 'ensure-natural "Not a natural: ~s\n" n)))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; The primitive code necessary to do call/cc
(: call/cc-label Symbol)
(define call/cc-label 'callCCEntry)
(define call/cc-closure-entry 'callCCClosureEntry)
;; (call/cc f)
;; Tail-calls f, providing it a special object that knows how to do the low-level
;; manipulation of the environment and control stack.
(define (make-call/cc-code)
(append-instruction-sequences
(make-instruction-sequence
`(,call/cc-label
;; Precondition: the environment holds the f function that we want to jump into.
;; First, move f to the proc register
,(make-AssignImmediateStatement 'proc (make-EnvLexicalReference 0 #f))
;; Next, capture the envrionment and the current continuation closure,.
,(make-PushEnvironment 2 #f)
,(make-AssignPrimOpStatement (make-EnvLexicalReference 0 #f)
(make-CaptureControl 0))
,(make-AssignPrimOpStatement (make-EnvLexicalReference 1 #f)
;; When capturing, skip over f and the two slots we just added.
(make-CaptureEnvironment 3))
,(make-AssignPrimOpStatement (adjust-target-depth (make-EnvLexicalReference 0 #f) 2)
(make-MakeCompiledProcedure call/cc-closure-entry
1 ;; the continuation consumes a single value
(list (make-EnvLexicalReference 0 #f)
(make-EnvLexicalReference 1 #f))
(current-defined-name)))
,(make-PopEnvironment 2 0)))
;; Finally, do a tail call into f.
(compile-procedure-call '()
(extend-lexical-environment/placeholders '() 1)
1
'val
'return)
;; The code for the continuation coe follows. It's supposed to
;; abandon the current continuation, initialize the control and environment, and then jump.
(make-instruction-sequence `(,call/cc-closure-entry
,(make-AssignImmediateStatement 'val (make-EnvLexicalReference 0 #f))
,(make-PerformStatement (make-InstallClosureValues!))
,(make-PerformStatement (make-RestoreControl!))
,(make-PerformStatement (make-RestoreEnvironment!))
,(make-AssignPrimOpStatement 'proc (make-GetControlStackLabel))
,(make-PopControlFrame)
,(make-GotoStatement (make-Reg 'proc))))))

5
expression-structs.rkt
View File

@ -37,11 +37,6 @@
#:transparent)
#;(define-struct: Letrec ([names : (Listof Symbol)]
[procs : (Listof Lam)]
[body : ExpressionCore]))
(: last-exp? ((Listof Expression) -> Boolean))
(define (last-exp? seq)
(null? (cdr seq)))

7
il-structs.rkt
View File

@ -29,7 +29,8 @@
;; Targets: these are the allowable lhs's for an assignment.
(define-type Target (U AtomicRegisterSymbol
EnvLexicalReference
EnvPrefixReference))
EnvPrefixReference
PrimitivesReference))
@ -49,6 +50,10 @@
#:transparent)
(define-struct: PrimitivesReference ([name : Symbol])
#:transparent)
;; An environment reference is either lexical or referring to a whole prefix.
(define-type EnvReference (U EnvLexicalReference

15
package.rkt
View File

@ -4,6 +4,7 @@
"assemble.rkt"
"typed-parse.rkt"
"il-structs.rkt"
"bootstrapped-primitives.rkt"
racket/runtime-path
racket/port)
@ -17,13 +18,6 @@
;; package: s-expression output-port -> void
(define (package source-code op)
;; The support code for call/cc
(for-each (lambda (code)
(displayln code op))
(map assemble-basic-block
(fracture (statements
(make-call/cc-code)))))
;; The runtime code
(call-with-input-file* runtime.js
(lambda (ip)
@ -32,9 +26,10 @@
(newline op)
(fprintf op "var invoke = ")
(assemble/write-invoke (compile (parse source-code)
'val
'next)
(assemble/write-invoke (append (get-bootstrapping-code)
(compile (parse source-code)
'val
'next))
op)
(fprintf op ";\n"))

196
runtime.js
View File

@ -129,6 +129,24 @@ var Primitives = (function() {
var firstArg = MACHINE.env[MACHINE.env.length-1];
return firstArg[1];
},
'pair?': function(arity, returnLabel) {
var firstArg = MACHINE.env[MACHINE.env.length-1];
return (typeof(firstArg) == 'object' &&
firstArg.length === 2);
},
'set-car!': function(arity, returnLabel) {
var firstArg = MACHINE.env[MACHINE.env.length-1];
var secondArg = MACHINE.env[MACHINE.env.length-2];
firstArg[0] = secondArg;
},
'set-cdr!': function(arity, returnLabel) {
var firstArg = MACHINE.env[MACHINE.env.length-1];
var secondArg = MACHINE.env[MACHINE.env.length-2];
firstArg[1] = secondArg;
},
'not': function(arity, returnLabel) {
var firstArg = MACHINE.env[MACHINE.env.length-1];
@ -166,6 +184,26 @@ var Primitives = (function() {
return result;
},
'vector->list': function(arity, returnLabel) {
var firstArg = MACHINE.env[MACHINE.env.length-1];
var i;
var result = NULL;
for (i = 0; i < firstArg.length; i++) {
result = [firstArg[firstArg.length - 1 - i], result];
}
return result;
},
'list->vector': function(arity, returnLabel) {
var firstArg = MACHINE.env[MACHINE.env.length-1];
var result = [];
while (firstArg !== NULL) {
result.push(firstArg[0]);
firstArg = firstArg[1];
}
return result;
},
'vector-ref': function(arity, returnLabel) {
var firstArg = MACHINE.env[MACHINE.env.length-1];
var secondArg = MACHINE.env[MACHINE.env.length-2];
@ -185,14 +223,86 @@ var Primitives = (function() {
return typeof(firstArg) === 'string';
},
'call/cc': new Closure(callCCEntry,
1,
[],
"call/cc"),
'call-with-current-continuation': new Closure(callCCEntry,
1,
[],
"call-with-current-continuation")
'symbol->string': function(arity, returnLabel) {
var firstArg = MACHINE.env[MACHINE.env.length-1];
return firstArg;
},
'string-append': function(arity, returnLabel) {
var buffer = [];
var i;
for (i = 0; i < arity; i++) {
buffer.push(MACHINE.env[MACHINE.env.length - 1 - i]);
}
return buffer.join('');
},
'string-length': function(arity, returnLabel) {
var firstArg = MACHINE.env[MACHINE.env.length-1];
return firstArg.length;
},
'box': function(arity, returnLabel) {
var firstArg = MACHINE.env[MACHINE.env.length-1];
var result = [firstArg];
return result;
},
'unbox': function(arity, returnLabel) {
var firstArg = MACHINE.env[MACHINE.env.length-1];
return firstArg[0];
},
'set-box!': function(arity, returnLabel) {
var firstArg = MACHINE.env[MACHINE.env.length-1];
var secondArg = MACHINE.env[MACHINE.env.length-2];
firstArg[0] = secondArg;
return;
},
'void': function(arity, returnLabel) {
return;
},
'eq?': function(arity, returnLabel) {
var firstArg = MACHINE.env[MACHINE.env.length-1];
var secondArg = MACHINE.env[MACHINE.env.length-2];
return firstArg === secondArg;
},
'equal?': function(arity, returnLabel) {
var firstArg = MACHINE.env[MACHINE.env.length-1];
var secondArg = MACHINE.env[MACHINE.env.length-2];
var lset = [firstArg], rset = [secondArg];
while (lset.length !== 0 && rset.length !== 0) {
var lhs = lset.pop();
var rhs = rset.pop();
if (lhs === rhs) {
continue;
} else if (typeof(lhs) === 'object' &&
typeof(rhs) === 'object' &&
typeof(lhs.length) === 'number' &&
typeof(rhs.length) === 'number' &&
lhs.length === rhs.length) {
lset.push.apply(lset, lhs);
rset.push.apply(rset, rhs);
} else {
return false;
}
}
return true;
}
// ,
// 'call/cc': new Closure(callCCEntry,
// 1,
// [],
// "call/cc"),
// 'call-with-current-continuation': new Closure(callCCEntry,
// 1,
// [],
// "call-with-current-continuation")
};
})();
@ -242,19 +352,60 @@ var Primitives = (function() {
var MACHINE={callsBeforeTrampoline: 100,
val:undefined,
proc:undefined,
env: [],
control : [],
params: { currentDisplayer: function(v) {},
currentErrorHandler: function(e) {},
currentNamespace: {}}};
var MACHINE = { callsBeforeTrampoline: 100,
val:undefined,
proc:undefined,
env: [],
control : [],
running : false,
params: { currentDisplayer: function(v) {},
currentErrorHandler: function(e) {},
currentNamespace: {},
// These parameters control how often
// control yields back to the browser
// for response. The implementation is a
// simple PID controller.
//
// To tune this, adjust desiredYieldsPerSecond.
// Do no touch numBouncesBeforeYield or
// maxNumBouncesBeforeYield, because those
// are adjusted automatically by the
// recomputeMaxNumBouncesBeforeYield
// procedure.
desiredYieldsPerSecond: 5,
numBouncesBeforeYield: 2000, // self-adjusting
maxNumBouncesBeforeYield: 2000 // self-adjusting
}
};
// recomputeGas: state number -> number
var recomputeMaxNumBouncesBeforeYield = function(observedDelay) {
// We'd like to see a delay of DESIRED_DELAY_BETWEEN_BOUNCES so
// that we get MACHINE.params.desiredYieldsPerSecond bounces per
// second.
var DESIRED_DELAY_BETWEEN_BOUNCES =
(1000 / MACHINE.params.desiredYieldsPerSecond);
var ALPHA = 256;
var delta = (ALPHA * ((DESIRED_DELAY_BETWEEN_BOUNCES -
observedDelay) /
DESIRED_DELAY_BETWEEN_BOUNCES));
MACHINE.params.maxNumBouncesBeforeYield =
Math.max(MACHINE.params.maxNumBouncesBeforeYield + delta,
1);
};
var trampoline = function(initialJump, success, fail) {
var thunk = initialJump;
var startTime = (new Date()).valueOf();
MACHINE.callsBeforeTrampoline = 100;
MACHINE.params.numBouncesBeforeYield =
MACHINE.params.maxNumBouncesBeforeYield;
MACHINE.running = true;
while(thunk) {
try {
thunk();
@ -263,10 +414,23 @@ var trampoline = function(initialJump, success, fail) {
if (typeof(e) === 'function') {
thunk = e;
MACHINE.callsBeforeTrampoline = 100;
if (MACHINE.params.numBouncesBeforeYield-- < 0) {
recomputeMaxNumBouncesBeforeYield(
(new Date()).valueOf() - startTime);
setTimeout(
function() {
trampoline(thunk, success, fail);
},
0);
return;
}
} else {
MACHINE.running = false;
return fail(e);
}
}
}
MACHINE.running = false;
return success();
};

25
simulator-primitives.rkt
View File

@ -1,10 +1,15 @@
#lang racket/base
(require "simulator-structs.rkt"
"compile.rkt"
"bootstrapped-primitives.rkt"
racket/math
(for-syntax racket/base))
(provide lookup-primitive)
(provide lookup-primitive set-primitive!)
(define mutated-primitives (make-hasheq))
(define (set-primitive! n p)
(hash-set! mutated-primitives n p))
(define-syntax (make-lookup stx)
@ -28,6 +33,8 @@
...)
(lambda (n)
(cond
[(hash-has-key? mutated-primitives n)
(hash-ref mutated-primitives n)]
[(eq? n 'exported-name)
prim-name]
...
@ -38,12 +45,12 @@
(make-undefined)]
)))))]))
(define call/cc
(make-closure call/cc-label
1
'()
'call/cc))
(define call-with-current-continuation call/cc)
;(define call/cc
; (make-closure call/cc-label
; 1
; '()
; 'call/cc))
;(define call-with-current-continuation call/cc)
(define e (exp 1))
@ -147,7 +154,7 @@
symbol?)
#:constants (null pi e
call/cc
call-with-current-continuation)))
#;call/cc
#;call-with-current-continuation)))

67
simulator.rkt
View File

@ -7,12 +7,14 @@
(require "il-structs.rkt"
"simulator-structs.rkt"
"bootstrapped-primitives.rkt"
racket/list
racket/match
(for-syntax racket/base))
(require/typed "simulator-primitives.rkt"
[lookup-primitive (Symbol -> PrimitiveValue)])
[lookup-primitive (Symbol -> PrimitiveValue)]
[set-primitive! (Symbol PrimitiveValue -> Void)])
(require/typed "simulator-helpers.rkt"
[ensure-primitive-value-box (SlotValue -> (Boxof PrimitiveValue))]
@ -28,17 +30,36 @@
(define current-simulated-output-port (make-parameter (current-output-port)))
(: new-machine ((Listof Statement) -> machine))
(define (new-machine program-text)
(let: ([m : machine (make-machine (make-undefined) (make-undefined) '() '() 0 (list->vector program-text) 0
((inst make-hash Symbol Natural)))])
(let: loop : Void ([i : Natural 0])
(when (< i (vector-length (machine-text m)))
(let: ([stmt : Statement (vector-ref (machine-text m) i)])
(when (symbol? stmt)
(hash-set! (machine-jump-table m) stmt i))
(loop (add1 i)))))
m))
(: new-machine (case-lambda [(Listof Statement) -> machine]
[(Listof Statement) Boolean -> machine]))
(define new-machine
(case-lambda:
[([program-text : (Listof Statement)])
(new-machine program-text #t)]
[([program-text : (Listof Statement)]
[with-bootstrapping-code? : Boolean])
(let*: ([after-bootstrapping : Symbol (make-label 'afterBootstrapping)]
[program-text : (Listof Statement)
(cond [with-bootstrapping-code?
(append (get-bootstrapping-code)
program-text)]
[else
program-text])])
(let: ([m : machine (make-machine (make-undefined)
(make-undefined)
'()
'()
0
(list->vector program-text)
0
((inst make-hash Symbol Natural)))])
(let: loop : Void ([i : Natural 0])
(when (< i (vector-length (machine-text m)))
(let: ([stmt : Statement (vector-ref (machine-text m) i)])
(when (symbol? stmt)
(hash-set! (machine-jump-table m) stmt i))
(loop (add1 i)))))
m))]))
@ -103,20 +124,7 @@
(define (step-assign-immediate! m stmt)
(let: ([t : Target (AssignImmediateStatement-target stmt)]
[v : SlotValue (evaluate-oparg m (AssignImmediateStatement-value stmt))])
(cond [(eq? t 'proc)
(proc-update! m v)]
[(eq? t 'val)
(val-update! m v)]
[(EnvLexicalReference? t)
(if (EnvLexicalReference-unbox? t)
(begin (set-box! (ensure-primitive-value-box (env-ref m (EnvLexicalReference-depth t)))
(ensure-primitive-value v))
'ok)
(env-mutate! m (EnvLexicalReference-depth t) v))]
[(EnvPrefixReference? t)
(toplevel-mutate! (ensure-toplevel (env-ref m (EnvPrefixReference-depth t)))
(EnvPrefixReference-pos t)
(ensure-primitive-value v))])))
((get-target-updater t) m v)))
(: step-push-environment! (machine PushEnvironment -> 'ok))
@ -251,7 +259,12 @@
(lambda: ([m : machine] [v : SlotValue])
(toplevel-mutate! (ensure-toplevel (env-ref m (EnvPrefixReference-depth t)))
(EnvPrefixReference-pos t)
(ensure-primitive-value v)))]))
(ensure-primitive-value v)))]
[(PrimitivesReference? t)
(lambda: ([m : machine] [v : SlotValue])
(set-primitive! (PrimitivesReference-name t)
(ensure-primitive-value v))
'ok)]))
(: step-assign-primitive-operation! (machine AssignPrimOpStatement -> 'ok))

19
test-assemble.rkt
View File

@ -43,16 +43,10 @@
(string-append
"(function() { "
;; The support code for call/cc
(string-join (map assemble-basic-block
(fracture (statements
(make-call/cc-code))))
"\n")
runtime
"return function(success, fail, params){" snippet
"return function(success, fail, params){"
snippet
(format "success(String(~a)); };" inspector)
"});")])
(displayln snippet)
@ -68,13 +62,6 @@
(display "(function() { " op)
(display
(string-join (map assemble-basic-block
(fracture (statements
(make-call/cc-code))))
"\n")
op)
(display runtime op)
(display "var myInvoke = " op)

1
test-browser-evaluate.rkt
View File

@ -20,7 +20,6 @@
#'stx)))
(printf " ok (~a milliseconds)\n" (evaluated-t result))))))]))
(test '(begin (define (f x)
(if (= x 0)
0

24
test-conform-browser.rkt Normal file
View File

@ -0,0 +1,24 @@
#lang racket
(require "browser-evaluate.rkt"
"package.rkt")
(define evaluate (make-evaluate package-anonymous))
(define-syntax (test stx)
(syntax-case stx ()
[(_ s exp)
(with-syntax ([stx stx])
(syntax/loc #'stx
(begin
(printf "running test...")
(let ([result (evaluate s)])
(let ([output (evaluated-stdout result)])
(unless (string=? output exp)
(printf " error!\n")
(raise-syntax-error #f (format "Expected ~s, got ~s" exp output)
#'stx)))
(printf " ok (~a milliseconds)\n" (evaluated-t result))))))]))
(test (read (open-input-file "tests/conform/program0.sch"))
(port->string (open-input-file "tests/conform/expected0.txt")))

18
test-simulator.rkt
View File

@ -42,7 +42,8 @@
;; Infinite loop
(let ([m (new-machine `(hello world ,(make-GotoStatement (make-Label 'hello))))])
(let ([m (new-machine `(hello world ,(make-GotoStatement (make-Label 'hello)))
#f)])
(test (machine-pc (step-n m 0)) 0)
(test (machine-pc (step-n m 1)) 1)
(test (machine-pc (step-n m 1)) 2)
@ -52,13 +53,15 @@
;; Assigning to val
(let ([m (new-machine `(,(make-AssignImmediateStatement 'val (make-Const 42))))])
(let ([m (new-machine `(,(make-AssignImmediateStatement 'val (make-Const 42)))
#f)])
(test (machine-val m) (make-undefined))
(step! m)
(test (machine-val m) 42))
;; Assigning to proc
(let ([m (new-machine `(,(make-AssignImmediateStatement 'proc (make-Const 42))))])
(let ([m (new-machine `(,(make-AssignImmediateStatement 'proc (make-Const 42)))
#f)])
(test (machine-proc m) (make-undefined))
(step! m)
(test (machine-proc m) 42))
@ -66,7 +69,8 @@
;; Assigning to a environment reference
(let* ([m (new-machine `(,(make-PushEnvironment 1 #f)
,(make-AssignImmediateStatement (make-EnvLexicalReference 0 #f) (make-Const 42))))]
,(make-AssignImmediateStatement (make-EnvLexicalReference 0 #f) (make-Const 42)))
#f)]
[m (run m)])
(test (machine-env m) '(42)))
@ -375,7 +379,8 @@
end
))])
(test (machine-val (run m))
(make-closure 'procedure-entry 0 (list 'larry 'moe) 'procedure-entry)))
(make-closure 'procedure-entry 0 (list 'larry 'moe)
'procedure-entry)))
;; make-compiled-procedure: Capturing a toplevel.
(let ([m (new-machine `(,(make-PerformStatement (make-ExtendEnvironment/Prefix! '(x y z)))
@ -396,7 +401,8 @@
end
))])
(test (machine-val (run m))
(make-closure 'procedure-entry 0 (list (make-toplevel (list "x" "y" "z"))) 'procedure-entry)))
(make-closure 'procedure-entry 0 (list (make-toplevel (list "x" "y" "z")))
'procedure-entry)))
;; make-compiled-procedure: Capturing both a toplevel and some lexical values
(let ([m (new-machine `(,(make-PerformStatement (make-ExtendEnvironment/Prefix! '(x y z)))

45
tests/conform/expected0.txt
View File

@ -3,48 +3,3 @@
30 -> 374 -> 31
31 -> 119
ok.
6 -> 26 -> 16
16 -> 132 -> 30
30 -> 374 -> 31
31 -> 119
ok.
6 -> 26 -> 16
16 -> 132 -> 30
30 -> 374 -> 31
31 -> 119
ok.
6 -> 26 -> 16
16 -> 132 -> 30
30 -> 374 -> 31
31 -> 119
ok.
6 -> 26 -> 16
16 -> 132 -> 30
30 -> 374 -> 31
31 -> 119
ok.
6 -> 26 -> 16
16 -> 132 -> 30
30 -> 374 -> 31
31 -> 119
ok.
6 -> 26 -> 16
16 -> 132 -> 30
30 -> 374 -> 31
31 -> 119
ok.
6 -> 26 -> 16
16 -> 132 -> 30
30 -> 374 -> 31
31 -> 119
ok.
6 -> 26 -> 16
16 -> 132 -> 30
30 -> 374 -> 31
31 -> 119
ok.
6 -> 26 -> 16
16 -> 132 -> 30
30 -> 374 -> 31
31 -> 119
ok.

66
tests/conform/program0.sch
View File

@ -1,46 +1,46 @@
(begin
(define (caar l)
(car (car l)))
;; (define (caar l)
;; (car (car l)))
(define (map f l)
(if (null? l)
null
(cons (f (car l))
(map f (cdr l)))))
;; (define (map f l)
;; (if (null? l)
;; null
;; (cons (f (car l))
;; (map f (cdr l)))))
(define (for-each f l)
(if (null? l)
null
(begin (f (car l))
(for-each f (cdr l)))))
;; (define (for-each f l)
;; (if (null? l)
;; null
;; (begin (f (car l))
;; (for-each f (cdr l)))))
(define (memq x l)
(if (null? l)
#f
(if (eq? x (car l))
l
(memq x (cdr l)))))
;; (define (memq x l)
;; (if (null? l)
;; #f
;; (if (eq? x (car l))
;; l
;; (memq x (cdr l)))))
(define (assq x l)
(if (null? l)
#f
(if (eq? x (caar l))
(car l)
(assq x (cdr l)))))
;; (define (assq x l)
;; (if (null? l)
;; #f
;; (if (eq? x (caar l))
;; (car l)
;; (assq x (cdr l)))))
(define (length l)
(if (null? l)
0
(add1 (length (cdr l)))))
;; (define (length l)
;; (if (null? l)
;; 0
;; (add1 (length (cdr l)))))
(define (append l1 l2)
(if (null? l1)
l2
(cons (car l1) (append (cdr l1) l2))))
;; (define (append l1 l2)
;; (if (nullb? l1)
;; l2
;; (cons (car l1) (append (cdr l1) l2))))
(define vector-copy
@ -513,4 +513,4 @@
(newline))))
(void ((letrec ((loop (lambda (n) (if (zero? n) 'done (begin (go) (loop (- n '1))))))) loop) '10)))
(void ((letrec ((loop (lambda (n) (if (zero? n) 'done (begin (go) (loop (- n '1))))))) loop) 1)))