#lang racket (require "assemble.rkt" "browser-evaluate.rkt" "lexical-structs.rkt" "il-structs.rkt" racket/port racket/promise racket/runtime-path) (define-runtime-path runtime.js "runtime.js") (define runtime (call-with-input-file runtime.js (lambda (ip) (port->string ip)))) ; Test out the compiler, using the simulator. (define-syntax (test stx) (syntax-case stx () [(_ expr expected) (with-syntax ([stx stx]) (syntax/loc #'stx (begin (printf "Running ~s ...\n" (syntax->datum #'expr)) (let ([actual (with-handlers ([void (lambda (exn) (raise-syntax-error #f (format "Runtime error: got ~s" exn) #'stx))]) expr)]) (unless (equal? actual expected) (raise-syntax-error #f (format "Expected ~s, got ~s" expected actual) #'stx)) (printf "ok.\n\n")))))])) ;; evaluating single expression (define -E (delay (make-evaluate (lambda (a-statement+inspector op) (let* ([a-statement (car a-statement+inspector)] [inspector (cdr a-statement+inspector)] [snippet (assemble-statement a-statement)] [code (string-append "(function() { " runtime "var MACHINE = new plt.runtime.Machine();\n" "return function(success, fail, params){" snippet (format "success(String(~a)); };" inspector) "});")]) (displayln snippet) (display code op)))))) (define (E-single a-statement (inspector "MACHINE.val")) (evaluated-value ((force -E) (cons a-statement inspector)))) ;; evaluating many expressions[. (define -E-many (delay (make-evaluate (lambda (a-statement+inspector op) (let* ([a-statement (car a-statement+inspector)] [inspector (cdr a-statement+inspector)]) (display runtime op) (display "var MACHINE = new plt.runtime.Machine();\n" op) (display "(function() { " op) (display "var myInvoke = " op) (assemble/write-invoke a-statement op) (display ";" op) (fprintf op "return function(succ, fail, params) { myInvoke(MACHINE, function(v) { succ(String(~a));}, fail, params); }" inspector) (display "})" op)))))) (define (E-many stmts (inspector "MACHINE.val")) (evaluated-value ((force -E-many) (cons stmts inspector)))) ;; Assigning a number (test (E-single (make-AssignImmediateStatement 'val (make-Const 42))) "42") ;; Assigning a string (test (E-single (make-AssignImmediateStatement 'val (make-Const "Danny"))) "Danny") ;; Assigning a cons (test (E-single (make-AssignImmediateStatement 'val (make-Const (cons 1 2)))) "1,2") ;; Assigning a void (test (E-single (make-AssignImmediateStatement 'val (make-Const (void)))) "null") ;; Assigning to proc means val should still be uninitialized. (test (E-single (make-AssignImmediateStatement 'proc (make-Const "Danny"))) "undefined") ;; But we should see the assignment if we inspect MACHINE.proc. (test (E-single (make-AssignImmediateStatement 'proc (make-Const "Danny")) "MACHINE.proc") "Danny") (test (E-single (make-PushEnvironment 1 #f) "MACHINE.env.length") "1") (test (E-single (make-PushEnvironment 20 #f) "MACHINE.env.length") "20") ;; PopEnvironment (test (E-many (list (make-PushEnvironment 2 #f)) "MACHINE.env.length") "2") (test (E-many (list (make-PushEnvironment 2 #f) (make-PopEnvironment 1 0)) "MACHINE.env.length") "1") ;; Assigning to the environment (test (E-many (list (make-PushEnvironment 2 #f) (make-AssignImmediateStatement (make-EnvLexicalReference 0 #f) (make-Const 12345))) "MACHINE.env[1]") "12345") (test (E-many (list (make-PushEnvironment 2 #f) (make-AssignImmediateStatement (make-EnvLexicalReference 0 #f) (make-Const 12345))) "MACHINE.env[0]") "undefined") (test (E-many (list (make-PushEnvironment 2 #f) (make-AssignImmediateStatement (make-EnvLexicalReference 1 #f) (make-Const 12345))) "MACHINE.env[0]") "12345") ;; Toplevel Environment loading (test (E-single (make-PerformStatement (make-ExtendEnvironment/Prefix! '(pi))) "String(MACHINE.env[0]).slice(0, 5)") "3.141") ;; Simple application (test (E-many (list (make-PerformStatement (make-ExtendEnvironment/Prefix! '(+))) (make-AssignImmediateStatement 'proc (make-EnvPrefixReference 0 0)) (make-PushEnvironment 2 #f) (make-AssignImmediateStatement (make-EnvLexicalReference 0 #f) (make-Const 3)) (make-AssignImmediateStatement (make-EnvLexicalReference 1 #f) (make-Const 4)) (make-AssignPrimOpStatement 'val (make-ApplyPrimitiveProcedure 2)) 'done)) "7") ;; A do-nothing closure (test (E-many (list (make-GotoStatement (make-Label 'afterLambda)) 'closureStart (make-GotoStatement (make-Label 'afterLambda)) 'afterLambda (make-AssignPrimOpStatement 'val (make-MakeCompiledProcedure 'closureStart 0 '() 'closureStart))) "MACHINE.val.displayName") "closureStart") ;; A do-nothing closure with a few values (test (E-many (list (make-GotoStatement (make-Label 'afterLambda)) 'closureStart (make-GotoStatement (make-Label 'afterLambda)) 'afterLambda (make-PushEnvironment 2 #f) (make-AssignImmediateStatement (make-EnvLexicalReference 0 #f) (make-Const "hello")) (make-AssignImmediateStatement (make-EnvLexicalReference 1 #f) (make-Const "world")) (make-AssignPrimOpStatement 'val (make-MakeCompiledProcedure 'closureStart 0 (list 0 1) 'closureStart))) "MACHINE.val.closedVals[1] + ',' + MACHINE.val.closedVals[0]") "hello,world") ;; Let's try to install the closure values. (test (E-many (list (make-GotoStatement (make-Label 'afterLambdaBody)) 'closureStart (make-PerformStatement (make-InstallClosureValues!)) (make-GotoStatement (make-Label 'theEnd)) 'afterLambdaBody (make-PushEnvironment 2 #f) (make-AssignImmediateStatement (make-EnvLexicalReference 0 #f) (make-Const "hello")) (make-AssignImmediateStatement (make-EnvLexicalReference 1 #f) (make-Const "world")) (make-AssignPrimOpStatement 'proc (make-MakeCompiledProcedure 'closureStart 0 (list 0 1) 'closureStart)) (make-PopEnvironment 2 0) (make-GotoStatement (make-Label 'closureStart)) 'theEnd) "String(MACHINE.env.length) + ',' + MACHINE.env[1] + ',' + MACHINE.env[0]") "2,hello,world") ;; get-compiled-procedure-entry (test (E-many (list (make-GotoStatement (make-Label 'afterLambdaBody)) 'closureStart (make-PerformStatement (make-InstallClosureValues!)) (make-GotoStatement (make-Label 'theEnd)) 'afterLambdaBody (make-PushEnvironment 2 #f) (make-AssignImmediateStatement (make-EnvLexicalReference 0 #f) (make-Const "hello")) (make-AssignImmediateStatement (make-EnvLexicalReference 1 #f) (make-Const "world")) (make-AssignPrimOpStatement 'proc (make-MakeCompiledProcedure 'closureStart 0 (list 0 1) 'closureStart)) (make-PopEnvironment 2 0) (make-AssignPrimOpStatement 'val (make-GetCompiledProcedureEntry))) "typeof(MACHINE.val) + ',' + (MACHINE.val === MACHINE.proc.label)") "function,true") ;; check-closure-arity. This should succeed. (void (E-many (list (make-GotoStatement (make-Label 'afterLambdaBody)) 'closureStart (make-PerformStatement (make-InstallClosureValues!)) (make-GotoStatement (make-Label 'theEnd)) 'afterLambdaBody (make-PushEnvironment 2 #f) (make-AssignImmediateStatement (make-EnvLexicalReference 0 #f) (make-Const "hello")) (make-AssignImmediateStatement (make-EnvLexicalReference 1 #f) (make-Const "world")) (make-AssignPrimOpStatement 'proc (make-MakeCompiledProcedure 'closureStart 5 (list 0 1) 'closureStart)) (make-PopEnvironment 2 0) (make-PerformStatement (make-CheckClosureArity! 5))))) ;; this should fail, since the check is for 1, but the closure expects 5. (let/ec return (with-handlers ([void (lambda (exn) (return))]) (E-many (list (make-GotoStatement (make-Label 'afterLambdaBody)) 'closureStart (make-PerformStatement (make-InstallClosureValues!)) (make-GotoStatement (make-Label 'theEnd)) 'afterLambdaBody (make-PushEnvironment 2 #f) (make-AssignImmediateStatement (make-EnvLexicalReference 0 #f) (make-Const "hello")) (make-AssignImmediateStatement (make-EnvLexicalReference 1 #f) (make-Const "world")) (make-AssignPrimOpStatement 'proc (make-MakeCompiledProcedure 'closureStart 5 (list 0 1) 'closureStart)) (make-PopEnvironment 2 0) (make-PerformStatement (make-CheckClosureArity! 1))))) (error 'expected-failure)) (test (E-many `(,(make-AssignImmediateStatement 'val (make-Const 42)) ,(make-TestAndBranchStatement 'false? 'val 'onFalse) ,(make-AssignImmediateStatement 'val (make-Const 'ok)) ,(make-GotoStatement (make-Label 'end)) onFalse ,(make-AssignImmediateStatement 'val (make-Const 'not-ok)) end)) "ok") ;; TestAndBranch: try the false branch (test (E-many `(,(make-AssignImmediateStatement 'val (make-Const #f)) ,(make-TestAndBranchStatement 'false? 'val 'onFalse) ,(make-AssignImmediateStatement 'val (make-Const 'not-ok)) ,(make-GotoStatement (make-Label 'end)) onFalse ,(make-AssignImmediateStatement 'val (make-Const 'ok)) end)) "ok") ;; Test for primitive procedure (test (E-many `(,(make-AssignImmediateStatement 'val (make-Const '+)) ,(make-TestAndBranchStatement 'primitive-procedure? 'val 'onTrue) ,(make-AssignImmediateStatement 'val (make-Const 'ok)) ,(make-GotoStatement (make-Label 'end)) onTrue ,(make-AssignImmediateStatement 'val (make-Const 'not-ok)) end)) "ok") ;; Give a primitive procedure in val (test (E-many `(,(make-PerformStatement (make-ExtendEnvironment/Prefix! '(+))) ,(make-AssignImmediateStatement 'val (make-EnvPrefixReference 0 0)) ,(make-TestAndBranchStatement 'primitive-procedure? 'val 'onTrue) ,(make-AssignImmediateStatement 'val (make-Const 'not-ok)) ,(make-GotoStatement (make-Label 'end)) onTrue ,(make-AssignImmediateStatement 'val (make-Const 'ok)) end)) "ok") ;; Give a primitive procedure in proc, but test val (test (E-many `(,(make-PerformStatement (make-ExtendEnvironment/Prefix! '(+))) ,(make-AssignImmediateStatement 'proc (make-EnvPrefixReference 0 0)) ,(make-TestAndBranchStatement 'primitive-procedure? 'val 'onTrue) ,(make-AssignImmediateStatement 'val (make-Const 'not-a-procedure)) ,(make-GotoStatement (make-Label 'end)) onTrue ,(make-AssignImmediateStatement 'val (make-Const 'a-procedure)) end)) "not-a-procedure") ;; Give a primitive procedure in proc and test proc (test (E-many `(,(make-PerformStatement (make-ExtendEnvironment/Prefix! '(+))) ,(make-AssignImmediateStatement 'proc (make-EnvPrefixReference 0 0)) ,(make-TestAndBranchStatement 'primitive-procedure? 'proc 'onTrue) ,(make-AssignImmediateStatement 'val (make-Const 'not-a-procedure)) ,(make-GotoStatement (make-Label 'end)) onTrue ,(make-AssignImmediateStatement 'val (make-Const 'a-procedure)) end)) "a-procedure") ;; Set-toplevel (test (E-many `(,(make-PerformStatement (make-ExtendEnvironment/Prefix! '(advisor))) ,(make-AssignImmediateStatement 'val (make-Const "Kathi")) ,(make-AssignImmediateStatement (make-EnvPrefixReference 0 0) (make-Reg 'val))) "MACHINE.env[0][0]") "Kathi") ;; check-toplevel-bound (let/ec return (let ([dont-care (with-handlers ([void (lambda (exn) (return))]) (E-many `(,(make-PerformStatement (make-ExtendEnvironment/Prefix! '(some-variable))) ,(make-PerformStatement (make-CheckToplevelBound! 0 0)))))]) (raise "I expected an error"))) ;; check-toplevel-bound shouldn't fail here. (test (E-many `(,(make-PerformStatement (make-ExtendEnvironment/Prefix! '(another-advisor))) ,(make-AssignImmediateStatement 'val (make-Const "Shriram")) ,(make-AssignImmediateStatement (make-EnvPrefixReference 0 0) (make-Reg 'val)) ,(make-PerformStatement (make-CheckToplevelBound! 0 0))) "MACHINE.env[0][0]") "Shriram")