diff --git a/assemble.rkt b/assemble.rkt index af46367..fa320b2 100644 --- a/assemble.rkt +++ b/assemble.rkt @@ -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)]))) diff --git a/bootstrapped-primitives.rkt b/bootstrapped-primitives.rkt new file mode 100644 index 0000000..572fd25 --- /dev/null +++ b/bootstrapped-primitives.rkt @@ -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))))) \ No newline at end of file diff --git a/browser-evaluate.rkt b/browser-evaluate.rkt index fa2c2de..da6abad 100644 --- a/browser-evaluate.rkt +++ b/browser-evaluate.rkt @@ -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(); diff --git a/compile.rkt b/compile.rkt index b379ef2..ab45d73 100644 --- a/compile.rkt +++ b/compile.rkt @@ -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)))))) diff --git a/expression-structs.rkt b/expression-structs.rkt index 0b6c2d3..ca67e9b 100644 --- a/expression-structs.rkt +++ b/expression-structs.rkt @@ -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))) diff --git a/il-structs.rkt b/il-structs.rkt index 4a2eada..a0e9c10 100644 --- a/il-structs.rkt +++ b/il-structs.rkt @@ -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 diff --git a/package.rkt b/package.rkt index 83aba0d..8849d9d 100644 --- a/package.rkt +++ b/package.rkt @@ -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")) diff --git a/runtime.js b/runtime.js index f3c67db..c5d5595 100644 --- a/runtime.js +++ b/runtime.js @@ -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(); }; diff --git a/simulator-primitives.rkt b/simulator-primitives.rkt index 6eefa7c..7474776 100644 --- a/simulator-primitives.rkt +++ b/simulator-primitives.rkt @@ -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))) diff --git a/simulator.rkt b/simulator.rkt index 1267fec..4c5c311 100644 --- a/simulator.rkt +++ b/simulator.rkt @@ -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)) diff --git a/test-assemble.rkt b/test-assemble.rkt index aed1711..aa8fe24 100644 --- a/test-assemble.rkt +++ b/test-assemble.rkt @@ -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) diff --git a/test-browser-evaluate.rkt b/test-browser-evaluate.rkt index ea555ae..8c5982a 100644 --- a/test-browser-evaluate.rkt +++ b/test-browser-evaluate.rkt @@ -20,7 +20,6 @@ #'stx))) (printf " ok (~a milliseconds)\n" (evaluated-t result))))))])) - (test '(begin (define (f x) (if (= x 0) 0 diff --git a/test-conform-browser.rkt b/test-conform-browser.rkt new file mode 100644 index 0000000..d6dd95e --- /dev/null +++ b/test-conform-browser.rkt @@ -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"))) \ No newline at end of file diff --git a/test-simulator.rkt b/test-simulator.rkt index 012af0c..baafc22 100644 --- a/test-simulator.rkt +++ b/test-simulator.rkt @@ -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))) diff --git a/tests/conform/expected0.txt b/tests/conform/expected0.txt index 7b3ad60..bb84d7d 100644 --- a/tests/conform/expected0.txt +++ b/tests/conform/expected0.txt @@ -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. diff --git a/tests/conform/program0.sch b/tests/conform/program0.sch index 9fbe3d9..aed3119 100644 --- a/tests/conform/program0.sch +++ b/tests/conform/program0.sch @@ -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))) \ No newline at end of file +(void ((letrec ((loop (lambda (n) (if (zero? n) 'done (begin (go) (loop (- n '1))))))) loop) 1))) \ No newline at end of file