From a3f323a6878590c09f1fd34622d8e95d436f82f6 Mon Sep 17 00:00:00 2001 From: Danny Yoo Date: Tue, 29 Mar 2011 18:18:21 -0400 Subject: [PATCH] adding type checks --- assemble-helpers.rkt | 123 ++++++++++++++++++++++ assemble-open-coded.rkt | 225 ++++++++++++++++++++++++++++++++++++++++ assemble.rkt | 199 +---------------------------------- compile.rkt | 87 +++++++--------- il-structs.rkt | 31 +++++- runtime.js | 16 ++- 6 files changed, 432 insertions(+), 249 deletions(-) create mode 100644 assemble-helpers.rkt create mode 100644 assemble-open-coded.rkt diff --git a/assemble-helpers.rkt b/assemble-helpers.rkt new file mode 100644 index 0000000..7f15740 --- /dev/null +++ b/assemble-helpers.rkt @@ -0,0 +1,123 @@ +#lang typed/racket/base + +(require "il-structs.rkt" + "lexical-structs.rkt" + racket/list) + +(provide assemble-oparg + assemble-target + assemble-const + assemble-lexical-reference + assemble-prefix-reference + assemble-whole-prefix-reference + assemble-reg + assemble-label + assemble-input) + + +(: assemble-oparg (OpArg -> String)) +(define (assemble-oparg v) + (cond + [(Reg? v) + (assemble-reg v)] + [(Label? v) + (assemble-label v)] + [(Const? v) + (assemble-const v)] + [(EnvLexicalReference? v) + (assemble-lexical-reference v)] + [(EnvPrefixReference? v) + (assemble-prefix-reference v)] + [(EnvWholePrefixReference? v) + (assemble-whole-prefix-reference v)])) + + + + +(: assemble-target (Target -> String)) +(define (assemble-target target) + (cond + [(eq? target 'proc) + "MACHINE.proc"] + [(eq? target 'val) + "MACHINE.val"] + [(EnvLexicalReference? target) + (assemble-lexical-reference target)] + [(EnvPrefixReference? target) + (assemble-prefix-reference target)] + [(PrimitivesReference? target) + (format "Primitives[~s]" (symbol->string (PrimitivesReference-name target)))])) + + + +;; fixme: use js->string +(: assemble-const (Const -> String)) +(define (assemble-const stmt) + (let: loop : String ([val : Any (Const-const stmt)]) + (cond [(symbol? val) + (format "~s" (symbol->string val))] + [(pair? val) + (format "[~a, ~a]" + (loop (car val)) + (loop (cdr val)))] + [(boolean? val) + (if val "true" "false")] + [(void? val) + "null"] + [(empty? val) + (format "Primitives.null")] + [(number? val) + (format "(~s)" val)] + [else + (format "~s" val)]))) + + + + +(: assemble-lexical-reference (EnvLexicalReference -> String)) +(define (assemble-lexical-reference a-lex-ref) + (if (EnvLexicalReference-unbox? a-lex-ref) + (format "MACHINE.env[MACHINE.env.length - 1 - ~a][0]" + (EnvLexicalReference-depth a-lex-ref)) + (format "MACHINE.env[MACHINE.env.length - 1 - ~a]" + (EnvLexicalReference-depth a-lex-ref)))) + +(: assemble-prefix-reference (EnvPrefixReference -> String)) +(define (assemble-prefix-reference a-ref) + (format "MACHINE.env[MACHINE.env.length - 1 - ~a][~a]" + (EnvPrefixReference-depth a-ref) + (EnvPrefixReference-pos a-ref))) + +(: assemble-whole-prefix-reference (EnvWholePrefixReference -> String)) +(define (assemble-whole-prefix-reference a-prefix-ref) + (format "MACHINE.env[MACHINE.env.length - 1 - ~a]" + (EnvWholePrefixReference-depth a-prefix-ref))) + + +(: assemble-reg (Reg -> String)) +(define (assemble-reg a-reg) + (string-append "MACHINE." (symbol->string (Reg-name a-reg)))) + + + +(: assemble-label (Label -> String)) +(define (assemble-label a-label) + (symbol->string (Label-name a-label))) + + + +(: assemble-input (OpArg -> String)) +(define (assemble-input an-input) + (cond + [(Reg? an-input) + (assemble-reg an-input)] + [(Const? an-input) + (assemble-const an-input)] + [(Label? an-input) + (assemble-label an-input)] + [(EnvLexicalReference? an-input) + (assemble-lexical-reference an-input)] + [(EnvPrefixReference? an-input) + (assemble-prefix-reference an-input)] + [(EnvWholePrefixReference? an-input) + (assemble-whole-prefix-reference an-input)])) diff --git a/assemble-open-coded.rkt b/assemble-open-coded.rkt new file mode 100644 index 0000000..8287462 --- /dev/null +++ b/assemble-open-coded.rkt @@ -0,0 +1,225 @@ +#lang typed/racket/base + +(require "il-structs.rkt" + "lexical-structs.rkt" + "assemble-helpers.rkt" + racket/string + racket/list) + +(provide open-code-kernel-primitive-procedure) + + + +(: open-code-kernel-primitive-procedure (CallKernelPrimitiveProcedure -> String)) +(define (open-code-kernel-primitive-procedure op) + (let: ([operator : KernelPrimitiveName (CallKernelPrimitiveProcedure-operator op)] + [rand-knowledge : (Listof CompileTimeEnvironmentEntry) + (CallKernelPrimitiveProcedure-operands-knowledge op)] + [rand-vals : (Listof String) (map assemble-input (CallKernelPrimitiveProcedure-operands op))]) + (case operator + + [(+) + (let ([checked-rands (maybe-typecheck-operands (repeat 'number (length rand-vals)) + rand-vals + rand-knowledge)]) + (cond [(empty? rand-vals) + "0"] + [else + (string-append "(" (string-join checked-rands " + ") ")")]))] + + [(-) + (let ([checked-rands (maybe-typecheck-operands (repeat 'number (length rand-vals)) + rand-vals + rand-knowledge)]) + (cond [(empty? rand-vals) + (error '- "Expects at least 1 argument, given 0")] + [(empty? (rest rand-vals)) + (format "(-(~a))" (first rand-vals))] + [else + (string-append "(" (string-join checked-rands "-") ")")]))] + + [(*) + (let ([checked-rands (maybe-typecheck-operands (repeat 'number (length rand-vals)) + rand-vals + rand-knowledge)]) + (cond [(empty? rand-vals) + "1"] + [else + (string-append "(" (string-join checked-rands "*") ")")]))] + + [(/) + (let ([checked-rands (maybe-typecheck-operands (repeat 'number (length rand-vals)) + rand-vals + rand-knowledge)]) + (cond [(empty? rand-vals) + (error '/ "Expects at least 1 argument, given 0")] + [else + (string-append "(" (string-join checked-rands "/") ")")]))] + + [(add1) + (unless (= 1 (length rand-vals)) + (error 'add1 "Expected one argument")) + (format "(~a + 1)" + (maybe-typecheck-operand 'number 0 (first rand-vals) (first rand-knowledge)))] + + [(sub1) + (unless (= 1 (length rand-vals)) + (error 'sub1 "Expected one argument")) + (format "(~a - 1)" + (maybe-typecheck-operand 'number 0 (first rand-vals) (first rand-knowledge)))] + + [(<) + (unless (> (length rand-vals) 0) + (error '< "Expected at least one argument")) + (assemble-chain "<" (maybe-typecheck-operands (repeat 'number (length rand-vals)) + rand-vals + rand-knowledge))] + [(<=) + (unless (> (length rand-vals) 0) + (error '<= "Expected at least one argument")) + (assemble-chain "<=" (maybe-typecheck-operands (repeat 'number (length rand-vals)) + rand-vals + rand-knowledge))] + + [(=) + (unless (> (length rand-vals) 0) + (error '= "Expected at least one argument")) + (assemble-chain "==" (maybe-typecheck-operands (repeat 'number (length rand-vals)) + rand-vals + rand-knowledge))] + + [(>) + (unless (> (length rand-vals) 0) + (error '> "Expected at least one argument")) + (assemble-chain ">" (maybe-typecheck-operands (repeat 'number (length rand-vals)) + rand-vals + rand-knowledge))] + + [(>=) + (unless (> (length rand-vals) 0) + (error '>= "Expected at least one argument")) + (assemble-chain ">=" (maybe-typecheck-operands (repeat 'number (length rand-vals)) + rand-vals + rand-knowledge))] + + [(cons) + (unless (= (length rand-vals) 2) + (error 'cons "Expected two arguments")) + (format "[~a, ~a]" (first rand-vals) (second rand-vals))] + + [(car) + (unless (= (length rand-vals) 1) + (error 'car "Expected one argument")) + (format "(~a)[0]" (maybe-typecheck-operand 'pair 0 (first rand-vals) + (first rand-knowledge)))] + + [(cdr) + (unless (= (length rand-vals) 1) + (error 'cdr "Expected one argument")) + (format "(~a)[1]" (maybe-typecheck-operand 'pair 0 (first rand-vals) + (first rand-knowledge)))] + + [(list) + (let loop ([rand-vals rand-vals]) + (cond + [(empty? rand-vals) + "Primitives.null"] + [else + (format "[~a,~a]" (first rand-vals) (loop (rest rand-vals)))]))] + + [(null?) + (unless (= (length rand-vals) 1) + (error 'null? "Expected one argument")) + (format "(~a === Primitives.null)" + (first rand-vals))] + [(not) + (unless (= (length rand-vals) 1) + (error 'not? "Expected one argument")) + (format "(!~a)" (first rand-vals))] + + [(eq?) + (unless (= (length rand-vals) 2) + (error 'eq? "Expected 2 arguments")) + (format "(~a === ~a)" (first rand-vals) (second rand-vals))]))) + + +(: assemble-chain (String (Listof String) -> String)) +(define (assemble-chain rator rands) + (string-append "(" + (string-join (let: loop : (Listof String) ([rands : (Listof String) rands]) + (cond + [(empty? rands) + '()] + [(empty? (rest rands)) + '()] + [else + (cons (format "(~a ~a ~a)" (first rands) rator (second rands)) + (loop (rest rands)))])) + "&&") + ")")) + + + +(define-type OperandDomain (U 'number + 'string + 'box + 'list + 'pair)) + + +(: assemble-domain-check (OperandDomain String Natural -> String)) +(define (assemble-domain-check domain operand-string pos) + (let ([test-string + (case domain + [(number) + (format "typeof(~a) === 'number'" + operand-string)] + [(string) + (format "typeof(~a) === 'string'" + operand-string)] + [(list) + (format "(~a === [] || (typeof(~a) === 'object' && (~a).length === 2))" + operand-string operand-string operand-string)] + [(pair) + (format "(typeof(~a) === 'object' && (~a).length === 2)" + operand-string operand-string)])]) + (format "(~a ? ~a : raise(new Error('Expected ' + ~a + ' as argument ' + ~s + ' but received ' + ~a)))" + test-string + operand-string + domain + pos + operand-string))) + +(: maybe-typecheck-operands ((Listof OperandDomain) + (Listof String) + (Listof CompileTimeEnvironmentEntry) -> (Listof String))) +(define (maybe-typecheck-operands expected-domains rand-vals rand-knowledge) + (map (lambda: ([rand : String] + [expected-domain : OperandDomain] + [knowledge : CompileTimeEnvironmentEntry] + [position : Natural]) + (maybe-typecheck-operand expected-domain position rand knowledge)) + rand-vals + expected-domains + rand-knowledge + (build-list (length rand-vals) + (lambda: ([i : Natural]) i)))) + + +(: maybe-typecheck-operand (OperandDomain Natural String CompileTimeEnvironmentEntry -> String)) +(define (maybe-typecheck-operand domain-type position operand-string knowledge) + (cond + [(redundant-check? domain-type knowledge) + operand-string] + [else + (assemble-domain-check domain-type operand-string position)])) + + +(: redundant-check? (OperandDomain CompileTimeEnvironmentEntry -> Boolean)) +(define (redundant-check? domain-type knowledge) + #f) + + + (: repeat (All (A) (A Natural -> (Listof A)))) +(define (repeat x n) + (build-list n (lambda (i) x))) \ No newline at end of file diff --git a/assemble.rkt b/assemble.rkt index 1cf0537..f4f7bb2 100644 --- a/assemble.rkt +++ b/assemble.rkt @@ -2,6 +2,8 @@ (require "il-structs.rkt" "lexical-structs.rkt" "helpers.rkt" + "assemble-helpers.rkt" + "assemble-open-coded.rkt" racket/string racket/list) @@ -218,21 +220,7 @@ EOF (string-join (map assemble-statement (BasicBlock-stmts a-basic-block)) "\n"))) -(: assemble-oparg (OpArg -> String)) -(define (assemble-oparg v) - (cond - [(Reg? v) - (assemble-reg v)] - [(Label? v) - (assemble-label v)] - [(Const? v) - (assemble-const v)] - [(EnvLexicalReference? v) - (assemble-lexical-reference v)] - [(EnvPrefixReference? v) - (assemble-prefix-reference v)] - [(EnvWholePrefixReference? v) - (assemble-whole-prefix-reference v)])) + (: assemble-statement (UnlabeledStatement -> String)) @@ -300,64 +288,10 @@ EOF -(: assemble-target (Target -> String)) -(define (assemble-target target) - (cond - [(eq? target 'proc) - "MACHINE.proc"] - [(eq? target 'val) - "MACHINE.val"] - [(EnvLexicalReference? target) - (assemble-lexical-reference target)] - [(EnvPrefixReference? target) - (assemble-prefix-reference target)] - [(PrimitivesReference? target) - (format "Primitives[~s]" (symbol->string (PrimitivesReference-name target)))])) -;; fixme: use js->string -(: assemble-const (Const -> String)) -(define (assemble-const stmt) - (let: loop : String ([val : Any (Const-const stmt)]) - (cond [(symbol? val) - (format "~s" (symbol->string val))] - [(pair? val) - (format "[~a, ~a]" - (loop (car val)) - (loop (cdr val)))] - [(boolean? val) - (if val "true" "false")] - [(void? val) - "null"] - [(empty? val) - (format "Primitives.null")] - [(number? val) - (format "(~s)" val)] - [else - (format "~s" val)]))) - - -(: assemble-lexical-reference (EnvLexicalReference -> String)) -(define (assemble-lexical-reference a-lex-ref) - (if (EnvLexicalReference-unbox? a-lex-ref) - (format "MACHINE.env[MACHINE.env.length - 1 - ~a][0]" - (EnvLexicalReference-depth a-lex-ref)) - (format "MACHINE.env[MACHINE.env.length - 1 - ~a]" - (EnvLexicalReference-depth a-lex-ref)))) - -(: assemble-prefix-reference (EnvPrefixReference -> String)) -(define (assemble-prefix-reference a-ref) - (format "MACHINE.env[MACHINE.env.length - 1 - ~a][~a]" - (EnvPrefixReference-depth a-ref) - (EnvPrefixReference-pos a-ref))) - -(: assemble-whole-prefix-reference (EnvWholePrefixReference -> String)) -(define (assemble-whole-prefix-reference a-prefix-ref) - (format "MACHINE.env[MACHINE.env.length - 1 - ~a]" - (EnvWholePrefixReference-depth a-prefix-ref))) - (: assemble-env-reference/closure-capture (Natural -> String)) ;; When we're capturing the values for a closure, we need to not unbox @@ -423,112 +357,6 @@ EOF -;; FIXME: this needs to check that the domains are good! -(: open-code-kernel-primitive-procedure (CallKernelPrimitiveProcedure -> String)) -(define (open-code-kernel-primitive-procedure op) - (let: ([operator : KernelPrimitiveName (CallKernelPrimitiveProcedure-operator op)] - [rand-vals : (Listof String) (map assemble-input (CallKernelPrimitiveProcedure-operands op))]) - (case operator - [(+) - (cond [(empty? rand-vals) - "0"] - [else - (string-append "(" - (string-join rand-vals " + ") - ")")])] - [(-) - (cond [(empty? rand-vals) - (error '- "Expects at least 1 argument, given 0")] - [(empty? (rest rand-vals)) - (format "(-(~a))" (first rand-vals))] - [else - (string-append "(" (string-join rand-vals "-") ")")])] - [(*) - (cond [(empty? rand-vals) - "1"] - [else - (string-append "(" (string-join rand-vals "*") ")")])] - [(/) - (cond [(empty? rand-vals) - (error '/ "Expects at least 1 argument, given 0")] - [else - (string-append "(" (string-join rand-vals "/") ")")])] - [(add1) - (unless (= 1 (length rand-vals)) - (error 'add1 "Expected one argument")) - (format "(~a + 1)" (first rand-vals))] - [(sub1) - (unless (= 1 (length rand-vals)) - (error 'sub1 "Expected one argument")) - (format "(~a - 1)" (first rand-vals))] - [(<) - (unless (> (length rand-vals) 0) - (error '< "Expected at least one argument")) - (assemble-chain "<" rand-vals)] - [(<=) - (unless (> (length rand-vals) 0) - (error '<= "Expected at least one argument")) - (assemble-chain "<=" rand-vals)] - [(=) - (unless (> (length rand-vals) 0) - (error '= "Expected at least one argument")) - (assemble-chain "==" rand-vals)] - [(>) - (unless (> (length rand-vals) 0) - (error '> "Expected at least one argument")) - (assemble-chain ">" rand-vals)] - [(>=) - (unless (> (length rand-vals) 0) - (error '>= "Expected at least one argument")) - (assemble-chain ">=" rand-vals)] - [(cons) - (unless (= (length rand-vals) 2) - (error 'cons "Expected two arguments")) - (format "[~a, ~a]" (first rand-vals) (second rand-vals))] - [(car) - (unless (= (length rand-vals) 1) - (error 'car "Expected one argument")) - (format "(~a)[0]" (first rand-vals))] - [(cdr) - (unless (= (length rand-vals) 1) - (error 'cdr "Expected one argument")) - (format "(~a)[1]" (first rand-vals))] - [(list) - (let loop ([rand-vals rand-vals]) - (cond - [(empty? rand-vals) - "Primitives.null"] - [else - (format "[~a,~a]" (first rand-vals) (loop (rest rand-vals)))]))] - [(null?) - (unless (= (length rand-vals) 1) - (error 'null? "Expected one argument")) - (format "(~a === Primitives.null)" - (first rand-vals))] - [(not) - (unless (= (length rand-vals) 1) - (error 'not? "Expected one argument")) - (format "(!~a)" (first rand-vals))] - [(eq?) - (unless (= (length rand-vals) 2) - (error 'eq? "Expected 2 arguments")) - (format "(~a === ~a)" (first rand-vals) (second rand-vals))]))) - - -(: assemble-chain (String (Listof String) -> String)) -(define (assemble-chain rator rands) - (string-append "(" - (string-join (let: loop : (Listof String) ([rands : (Listof String) rands]) - (cond - [(empty? rands) - '()] - [(empty? (rest rands)) - '()] - [else - (cons (format "(~a ~a ~a)" (first rands) rator (second rands)) - (loop (rest rands)))])) - "&&") - ")")) @@ -591,21 +419,6 @@ EOF ", "))])) -(: assemble-input (OpArg -> String)) -(define (assemble-input an-input) - (cond - [(Reg? an-input) - (assemble-reg an-input)] - [(Const? an-input) - (assemble-const an-input)] - [(Label? an-input) - (assemble-label an-input)] - [(EnvLexicalReference? an-input) - (assemble-lexical-reference an-input)] - [(EnvPrefixReference? an-input) - (assemble-prefix-reference an-input)] - [(EnvWholePrefixReference? an-input) - (assemble-whole-prefix-reference an-input)])) (: assemble-location ((U Reg Label) -> String)) (define (assemble-location a-location) @@ -615,10 +428,4 @@ EOF [(Label? a-location) (assemble-label a-location)])) -(: assemble-reg (Reg -> String)) -(define (assemble-reg a-reg) - (string-append "MACHINE." (symbol->string (Reg-name a-reg)))) -(: assemble-label (Label -> String)) -(define (assemble-label a-label) - (symbol->string (Label-name a-label))) \ No newline at end of file diff --git a/compile.rkt b/compile.rkt index 19d99ef..6689e97 100644 --- a/compile.rkt +++ b/compile.rkt @@ -13,19 +13,6 @@ -;; We try to keep at compile time a mapping from environment positions to -;; statically known things, to generate better code. -(define-struct: StaticallyKnownLam ([name : (U Symbol False)] - [entry-point : Symbol] - [arity : Natural]) #:transparent) - -(define-type CompileTimeEnvironmentEntry - (U '? Prefix StaticallyKnownLam ModuleVariable)) - -(define-type CompileTimeEnvironment (Listof CompileTimeEnvironmentEntry)) - - - (: -compile (ExpressionCore Target Linkage -> (Listof Statement))) @@ -450,17 +437,11 @@ ;; of hardcoded primitives. (define (compile-kernel-primitive-application kernel-op exp cenv extended-cenv target linkage) (let* ([n (length (App-operands exp))] - [operand-poss - (build-list (length (App-operands exp)) - (lambda: ([i : Natural]) - (make-EnvLexicalReference i #f)))] - [operand-codes (map (lambda: ([operand : Expression] - [target : Target]) - (compile operand extended-cenv target next-linkage)) - (App-operands exp) - operand-poss)]) + [operand-knowledge (map (lambda: ([arg : ExpressionCore]) + (extract-static-knowledge arg extended-cenv)) + (App-operands exp))]) (cond - ;; Special case optimization: we can avoid pushing the stack altogether + ;; Special case optimization: we can avoid touching the stack altogether [(all-operands-are-constant-or-stack-references (App-operands exp)) => (lambda (opargs) (end-with-linkage @@ -468,31 +449,43 @@ (make-instruction-sequence `(,(make-AssignPrimOpStatement target - (make-CallKernelPrimitiveProcedure kernel-op (map (lambda: ([arg : OpArg]) - (adjust-oparg-depth arg (- n))) - opargs)))))))] + (make-CallKernelPrimitiveProcedure kernel-op + (map (lambda: ([arg : OpArg]) + (adjust-oparg-depth arg (- n))) + opargs) + operand-knowledge))))))] [else - (end-with-linkage - linkage cenv - (append-instruction-sequences - - (if (not (empty? (App-operands exp))) - (make-instruction-sequence `(,(make-PushEnvironment (length (App-operands exp)) #f))) - empty-instruction-sequence) - - (apply append-instruction-sequences operand-codes) - - (make-instruction-sequence - `(,(make-AssignPrimOpStatement - ;; Optimization: we put the result directly in the registers, or in - ;; the appropriate spot on the stack. This takes into account the popenviroment - ;; that happens right afterwards. - (adjust-target-depth target n) - (make-CallKernelPrimitiveProcedure kernel-op operand-poss)))) - - (if (> n 0) - (make-instruction-sequence `(,(make-PopEnvironment n 0))) - empty-instruction-sequence)))]))) + (let* ([operand-poss + (build-list (length (App-operands exp)) + (lambda: ([i : Natural]) + (make-EnvLexicalReference i #f)))] + [operand-codes (map (lambda: ([operand : Expression] + [target : Target]) + (compile operand extended-cenv target next-linkage)) + (App-operands exp) + operand-poss)]) + (end-with-linkage + linkage cenv + (append-instruction-sequences + + (if (not (empty? (App-operands exp))) + (make-instruction-sequence `(,(make-PushEnvironment (length (App-operands exp)) #f))) + empty-instruction-sequence) + + (apply append-instruction-sequences operand-codes) + + (make-instruction-sequence + `(,(make-AssignPrimOpStatement + ;; Optimization: we put the result directly in the registers, or in + ;; the appropriate spot on the stack. This takes into account the popenviroment + ;; that happens right afterwards. + (adjust-target-depth target n) + (make-CallKernelPrimitiveProcedure kernel-op + operand-poss + operand-knowledge)))) + (if (> n 0) + (make-instruction-sequence `(,(make-PopEnvironment n 0))) + empty-instruction-sequence))))]))) diff --git a/il-structs.rkt b/il-structs.rkt index b157e42..299ae63 100644 --- a/il-structs.rkt +++ b/il-structs.rkt @@ -181,7 +181,8 @@ (define-struct: CallKernelPrimitiveProcedure ([operator : KernelPrimitiveName] - [operands : (Listof OpArg)]) + [operands : (Listof OpArg)] + [operands-knowledge : (Listof CompileTimeEnvironmentEntry)]) #:transparent) @@ -304,6 +305,34 @@ + + + + + + + +;; Static knowledge about a value + +;; We try to keep at compile time a mapping from environment positions to +;; statically known things, to generate better code. +(define-struct: StaticallyKnownLam ([name : (U Symbol False)] + [entry-point : Symbol] + [arity : Natural]) #:transparent) + +(define-type CompileTimeEnvironmentEntry + (U '? ;; no knowledge + Prefix ;; placeholder: necessary since the toplevel lives in the environment too + StaticallyKnownLam ;; The value is a known lam + ModuleVariable ;; The value is a known module variable + )) + +(define-type CompileTimeEnvironment (Listof CompileTimeEnvironmentEntry)) + + + + + ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; Assembly diff --git a/runtime.js b/runtime.js index 5b6f48a..808713b 100644 --- a/runtime.js +++ b/runtime.js @@ -27,6 +27,8 @@ var Closure = function(label, arity, closedVals, displayName) { this.displayName = displayName; }; + + // A primitive function is just a Javascript function. @@ -42,14 +44,18 @@ var testArgument = function(expectedTypeName, if (predicate(val)) { return true; } - throw new Error(callerName + ": expected " + expectedTypeName - + " as argument #" + position - + " but received " + val + " instead"); + else { + raise(new Error(callerName + ": expected " + expectedTypeName + + " as argument #" + position + + " but received " + val + " instead")); + } }; var isNumber = function(x) { return typeof(x) === 'number'; }; +var raise = function(e) { throw e; } + var Primitives = (function() { var NULL = []; @@ -144,7 +150,7 @@ var Primitives = (function() { }, '-': function(MACHINE, arity) { - if (arity === 0) { throw new Error(); } + if (arity === 0) { raise(new Error()); } if (arity === 1) { testArgument('number', isNumber, @@ -166,7 +172,7 @@ var Primitives = (function() { }, '/': function(MACHINE, arity) { - if (arity === 0) { throw new Error(); } + if (arity === 0) { raise(new Error();) } testArgument('number', isNumber, MACHINE.env[MACHINE.env.length - 1],