moved the type check stuff into the compiler

assemble-open-coded.rkt

@@ -13,135 +13,82 @@
 
 (: open-code-kernel-primitive-procedure (CallKernelPrimitiveProcedure -> String))
 (define (open-code-kernel-primitive-procedure op)
-  (let: ([operator : KernelPrimitiveName (CallKernelPrimitiveProcedure-operator op)]
+  (let*: ([operator : KernelPrimitiveName (CallKernelPrimitiveProcedure-operator op)]
-         [rand-knowledge : (Listof CompileTimeEnvironmentEntry)
+          [operands : (Listof String) (map assemble-input (CallKernelPrimitiveProcedure-operands op))]
-                        (CallKernelPrimitiveProcedure-operands-knowledge op)]
+          [checked-operands : (Listof String)
-         [rand-vals : (Listof String) (map assemble-input (CallKernelPrimitiveProcedure-operands op))])
+                            (map maybe-typecheck-operand
+                                 (CallKernelPrimitiveProcedure-expected-operand-types op)
+                                 (build-list (length operands) (lambda: ([i : Natural]) i))
+                                 operands
+                                 (CallKernelPrimitiveProcedure-typechecks? op))])
         (case operator
-          
           [(+)
-           (let ([checked-rands (maybe-typecheck-operands (repeat 'number (length rand-vals))
+           (cond [(empty? checked-operands)
-                                                          rand-vals 
+                  "0"]
-                                                          rand-knowledge)])
+                 [else
-                 (cond [(empty? rand-vals)
+                  (string-append "(" (string-join checked-operands " + ") ")")])]
-                        "0"]
-                       [else
-                        (string-append "(" (string-join checked-rands " + ") ")")]))]
           
           [(-)
-           (let ([checked-rands (maybe-typecheck-operands (repeat 'number (length rand-vals))
+           (cond [(empty? (rest checked-operands))
-                                                          rand-vals 
+                  (format "(-(~a))" (first checked-operands))]
-                                                          rand-knowledge)])
+                 [else
-             (cond [(empty? rand-vals)
+                  (string-append "(" (string-join checked-operands "-") ")")])]
-                    (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))
+           (cond [(empty? checked-operands)
-                                                          rand-vals 
+                  "1"]
-                                                          rand-knowledge)])
+                 [else
-             (cond [(empty? rand-vals)
+                  (string-append "(" (string-join checked-operands "*") ")")])]
-                    "1"]
-                   [else
-                    (string-append "(" (string-join checked-rands "*") ")")]))]
 
           [(/)
-           (let ([checked-rands (maybe-typecheck-operands (repeat 'number (length rand-vals))
+           (string-append "(" (string-join checked-operands "/") ")")]
-                                                          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))
+           (format "(~a + 1)" (first checked-operands))]
-             (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))
+           (format "(~a - 1)" (first checked-operands))]
-             (error 'sub1 "Expected one argument"))
-           (format "(~a - 1)" 
-                   (maybe-typecheck-operand 'number 0 (first rand-vals) (first rand-knowledge)))]
           
           [(<)
-           (unless (> (length rand-vals) 0)
+           (assemble-chain "<" checked-operands)]
-             (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)
+           (assemble-chain "<=" checked-operands)]
-             (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)
+           (assemble-chain "===" checked-operands)]
-             (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)
+           (assemble-chain ">" checked-operands)]
-             (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)
+           (assemble-chain ">=" checked-operands)]
-             (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)
+           (format "[~a, ~a]" (first checked-operands) (second checked-operands))]
-             (error 'cons "Expected two arguments"))
-           (format "[~a, ~a]" (first rand-vals) (second rand-vals))]
 
           [(car)
-           (unless (= (length rand-vals) 1)
+           (format "(~a)[0]" (first checked-operands))]
-             (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)
+           (format "(~a)[1]" (first checked-operands))]
-             (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])
+           (let loop ([checked-operands checked-operands])
              (cond
-               [(empty? rand-vals)
+               [(empty? checked-operands)
                 "Primitives.null"]
                [else
-                (format "[~a,~a]" (first rand-vals) (loop (rest rand-vals)))]))]
+                (format "[~a,~a]" (first checked-operands) (loop (rest checked-operands)))]))]
           
           [(null?)
-           (unless (= (length rand-vals) 1)
+           (format "(~a === Primitives.null)" (first checked-operands))]
-             (error 'null? "Expected one argument"))
+
-           (format "(~a === Primitives.null)"
-                   (first rand-vals))]
           [(not)
-           (unless (= (length rand-vals) 1)
+           (format "(!(~a))" (first checked-operands))]
-             (error 'not? "Expected one argument"))
-           (format "(!~a)" (first rand-vals))]
           
           [(eq?)
-           (unless (= (length rand-vals) 2)
+           (format "(~a === ~a)" (first checked-operands) (second checked-operands))])))
-             (error 'eq? "Expected 2 arguments"))
-           (format "(~a === ~a)" (first rand-vals) (second rand-vals))])))
 
 
 (: assemble-chain (String (Listof String) -> String))
@@ -165,72 +112,40 @@
 
 (: 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 ' + ~s + ' as argument ' + ~s + ' but received ' + ~a)))"
-            test-string
-            operand-string
-            (symbol->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))
-;; Adds typechecks if we can't prove that the operand is of the required type.
-(define (maybe-typecheck-operand domain-type position operand-string knowledge)
   (cond
-    [(redundant-check? domain-type knowledge)
+    [(eq? domain 'any)
      operand-string]
     [else
-     (assemble-domain-check domain-type operand-string position)]))
+     (let: ([test-string : 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)]
+                           [(box)
+                            (format "(typeof(~a) === 'object' && (~a).length === 1)"
+                                    operand-string operand-string)])])
+           (format "((~a) ? (~a) : raise(new Error('Expected ' + ~s + ' as argument ' + ~s + ' but received ' + ~a)))"
+                   test-string
+                   operand-string
+                   (symbol->string domain)
+                   (add1 pos)
+                   operand-string))]))
 
 
-(: redundant-check? (OperandDomain CompileTimeEnvironmentEntry -> Boolean))
+(: maybe-typecheck-operand (OperandDomain Natural String Boolean -> String))
-;; Produces true if we know the knowledge implies the domain-type.
+;; Adds typechecks if we can't prove that the operand is of the required type.
-(define (redundant-check? domain-type knowledge)
+(define (maybe-typecheck-operand domain-type position operand-string typecheck?)
-  (cond [(Const? knowledge)
+  (cond
-         (case domain-type
+    [typecheck?
-           [(number)
+     (assemble-domain-check domain-type operand-string position)]
-            (number? (Const-const knowledge))]
+    [else
-           [(string)
+     operand-string]))
-            (string? (Const-const knowledge))]
-           [(box)
-            (box? (Const-const knowledge))]
-           [(list)
-            (list? (Const-const knowledge))]
-           [(pair)
-            (pair? (Const-const knowledge))])]
-        [else
-         #f]))
-
-
-(: repeat (All (A) (A Natural -> (Listof A))))
-(define (repeat x n)
-  (build-list n (lambda (i) x)))

browser-evaluate.rkt

@@ -235,7 +235,7 @@ var comet = function() {
                             "&b=" + encodeURIComponent(String(BrowserDetect.browser + ' ' + BrowserDetect.version + '/' + BrowserDetect.OS)));
                     };
 
-                    var onFail = function(e) {
+                    var onFail = function(machine, e) {
                         endTime = new Date();
                         sendRequest("/eval", function(req) { setTimeout(comet, 0); },
                             "e=" + encodeURIComponent(String(e)) +

compile.rkt

@@ -503,22 +503,24 @@
 (: redundant-check? (OperandDomain CompileTimeEnvironmentEntry -> Boolean))
 ;; Produces true if we know the knowledge implies the domain-type.
 (define (redundant-check? domain-type knowledge)
-  (cond [(Const? knowledge)
+  (cond
-         (case domain-type
+    [(eq? domain-type 'any)
-           [(number)
+     #t]
-            (number? (Const-const knowledge))]
+    [else
-           [(string)
+     (cond [(Const? knowledge)
-            (string? (Const-const knowledge))]
+            (case domain-type
-           [(box)
+              [(number)
-            (box? (Const-const knowledge))]
+               (number? (Const-const knowledge))]
-           [(list)
+              [(string)
-            (list? (Const-const knowledge))]
+               (string? (Const-const knowledge))]
-           [(pair)
+              [(box)
-            (pair? (Const-const knowledge))]
+               (box? (Const-const knowledge))]
-           [(any)
+              [(list)
-            #t])]
+               (list? (Const-const knowledge))]
-        [else
+              [(pair)
-         #f]))
+               (pair? (Const-const knowledge))])]
+           [else
+            #f])]))
 
 
 (: all-operands-are-constant-or-stack-references ((Listof Expression) -> (U False (Listof OpArg))))

simulator.rkt

@@ -9,6 +9,7 @@
          "lexical-structs.rkt"
          "simulator-structs.rkt"
          "bootstrapped-primitives.rkt"
+         "kernel-primitives.rkt"
          racket/list
          racket/match
          (for-syntax racket/base))

test-browser-evaluate.rkt

@@ -32,7 +32,6 @@ EOF
                     
                     )))
 
-;; test-find-toplevel-variables
 (define-syntax (test stx)
   (syntax-case stx ()
     [(_ s exp)
@@ -48,12 +47,123 @@ EOF
                                      #'stx)))
              (printf " ok (~a milliseconds)\n" (evaluated-t result))))))]))
 
+(define-syntax (test/exn stx)
+  (syntax-case stx ()
+    [(_ s exp)
+     (with-syntax ([stx stx])
+       (syntax/loc #'stx
+         (begin
+           (printf "running test...")
+           (let ([an-error-happened 
+                  (with-handlers ([error-happened?
+                                   (lambda (exn)
+                                     exn)])
+                    (let ([r (evaluate s)])
+                      (raise-syntax-error #f (format "Expected exception, but got ~s" r)
+                                          #'stx)))]) 
+             (unless (string=? exp (error-happened-str an-error-happened))
+               (printf " error!\n")
+               (raise-syntax-error #f (format "Expected ~s, got ~s" exp (error-happened-str an-error-happened))
+                                   #'stx))
+             (printf " ok (~a milliseconds)\n" (error-happened-t an-error-happened))))))]))
+
+
+
 (test '(display 42)
       "42")
 
 (test '(display (+ 3 4))
       "7")
 
+(test/exn (evaluate '(+ "hello" 3))
+          "Error: Expected number as argument 1 but received hello")
+
+
+(test '(display (/ 100 4))
+      "25")
+(test/exn (evaluate '(/ 3 'four))
+          "Error: Expected number as argument 2 but received four")
+
+
+(test '(display (- 1))
+      "-1")
+
+(test/exn '(- 'one)
+          "Error: Expected number as argument 1 but received one")
+
+(test '(display (- 5 4))
+      "1")
+
+(test '(display (* 3 17))
+      "51")
+
+(test/exn '(* "three" 17)
+          "Error: Expected number as argument 1 but received three")
+
+(test '(display '#t)
+      "true")
+
+(test '(display '#f)
+      "false")
+
+(test '(displayln (not #t))
+      "false\n")
+
+(test '(displayln (not #f))
+      "true\n")
+
+(test '(displayln (not 3))
+      "false\n")
+
+(test '(displayln (not (not 3)))
+      "true\n")
+
+(test '(displayln (add1 1))
+      "2\n")
+
+(test/exn '(displayln (add1 "0"))
+          "Error: Expected number as argument 1 but received 0")
+
+(test '(displayln (sub1 1))
+      "0\n")
+
+(test/exn '(displayln (sub1 "0"))
+          "Error: Expected number as argument 1 but received 0")
+
+(test '(displayln (< 1 2))
+      "true\n")
+
+(test '(displayln (<= 1 2))
+      "true\n")
+
+(test '(displayln (= 1 2))
+      "false\n")
+
+(test '(displayln (> 1 2))
+      "false\n")
+
+(test '(displayln (>= 1 2))
+      "false\n")
+
+(test '(displayln (car (cons 3 4)))
+      "3\n")
+
+(test '(displayln (cdr (cons 3 4)))
+      "4\n")
+
+(test '(displayln (let ([x (cons 5 6)])
+                    (car x)))
+      "5\n")
+
+(test '(displayln (let ([x (cons 5 6)])
+                    (cdr x)))
+      "6\n")
+
+(test '(displayln (length (list 'hello 4 5)))
+      "3\n")
+
+
+
 (test '(begin (define (f x) 
                 (if (= x 0)
                     0