kernel domain checks have caller

assemble-open-coded.rkt

@@ -16,7 +16,11 @@
   (let*: ([operator : KernelPrimitiveName (CallKernelPrimitiveProcedure-operator op)]
           [operands : (Listof String) (map assemble-oparg (CallKernelPrimitiveProcedure-operands op))]
           [checked-operands : (Listof String)
-                            (map maybe-typecheck-operand
+                            (map (lambda: ([dom : OperandDomain]
+					   [pos : Natural]
+					   [rand : String]
+					   [typecheck? : Boolean])
+				   (maybe-typecheck-operand operator dom pos rand typecheck?))
                                  (CallKernelPrimitiveProcedure-expected-operand-types op)
                                  (build-list (length operands) (lambda: ([i : Natural]) i))
                                  operands
@@ -110,8 +114,8 @@
 
 
 
-(: assemble-domain-check (OperandDomain String Natural -> String))
+(: assemble-domain-check (Symbol OperandDomain String Natural -> String))
-(define (assemble-domain-check domain operand-string pos)
+(define (assemble-domain-check caller domain operand-string pos)
   (cond
     [(eq? domain 'any)
      operand-string]
@@ -133,19 +137,20 @@
                            [(box)
                             (format "(typeof(~a) === 'object' && (~a).length === 1)"
                                     operand-string operand-string)])])
-           (format "((~a) ? (~a) : RUNTIME.raise(new Error('Expected ' + ~s + ' as argument ' + ~s + ' but received ' + ~a)))"
+           (format "((~a) ? (~a) : RUNTIME.raise(new Error('~a: expected ' + ~s + ' as argument ' + ~s + ' but received ' + ~a)))"
                    test-string
                    operand-string
+		   caller
                    (symbol->string domain)
                    (add1 pos)
                    operand-string))]))
 
 
-(: maybe-typecheck-operand (OperandDomain Natural String Boolean -> String))
+(: maybe-typecheck-operand (Symbol OperandDomain Natural String Boolean -> 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 typecheck?)
+(define (maybe-typecheck-operand caller domain-type position operand-string typecheck?)
   (cond
     [typecheck?
-     (assemble-domain-check domain-type operand-string position)]
+     (assemble-domain-check caller domain-type operand-string position)]
     [else
      operand-string]))

assemble.rkt

@@ -451,7 +451,7 @@ EOF
              (assemble-display-name (MakeCompiledProcedureShell-display-name op)))]
     
     [(ApplyPrimitiveProcedure? op)
-     (format "MACHINE.proc(MACHINE, MACHINE.argcount)")]
+     (format "MACHINE.proc(MACHINE)")]
     
     [(GetControlStackLabel? op)
      (format "MACHINE.control[MACHINE.control.length-1].label")]

racket-expander.rkt

@@ -1,5 +1,16 @@
 #lang racket
 
+
+(define (read-code ip)
+  (parameterize ([current-namespace (make-base-namespace)])
+    (expand `(begin ,@(let loop ()
+                        (let ([next (read ip)])
+                          (cond
+                            [(eof-object? next)
+                             empty]
+                            [else
+                             (cons next (loop))])))))))
+
 (define code
 (parameterize ([current-namespace (make-base-namespace)])
   (expand '(begin

runtime.js

@@ -28,6 +28,11 @@
 
     var isNumber = function(x) { return typeof(x) === 'number'; };
 
+    var isNatural = function(x) { return typeof(x) === 'number' &&
+				  x >= 0 &&
+				  Math.floor(x) === x; };
+
+
     var isPair = function(x) { return (typeof(x) == 'object' && 
 				       x.length === 2) };
     var isList = function(x) {
@@ -715,6 +720,44 @@
     Primitives['vector-set!'].arity = 3;
     Primitives['vector-set!'].displayName = 'vector-set!';
 
+
+    Primitives['vector-length'] = function(MACHINE, arity) {
+	testArgument('vector',
+		     isVector,
+		     MACHINE.env[MACHINE.env.length - 1],
+		     0,
+		     'vector-length');
+	var firstArg = MACHINE.env[MACHINE.env.length-1];
+	return firstArg.length;
+    };
+    Primitives['vector-length'].arity = 1;
+    Primitives['vector-length'].displayName = 'vector-length';
+
+
+    Primitives['make-vector'] = function(MACHINE, arity) {
+	var value = 0;
+	testArgument('natural',
+		     isNatural,
+		     MACHINE.env[MACHINE.env.length - 1],
+		     0,
+		     'make-vector');
+	if (MACHINE.argcount == 2) {
+	    value = MACHINE.env[MACHINE.env.length - 2];
+	}
+	var length = MACHINE.env[MACHINE.env.length-1];
+	var arr = [];
+	for(var i = 0; i < length; i++) {
+	    arr[i] = value;
+	}
+	return arr;
+    };
+    Primitives['make-vector'].arity = [1, [2, NULL]];
+    Primitives['make-vector'].displayName = 'make-vector';
+
+
+    
+
+
     Primitives['symbol?'] = function(MACHINE, arity) {
 	var firstArg = MACHINE.env[MACHINE.env.length-1];
 	return typeof(firstArg) === 'string';
@@ -856,6 +899,19 @@
                      1);
     };
 
+    Primitives['reverse'] = function(MACHINE, arity) {
+	var rev = NULL;
+	var lst = MACHINE.env[MACHINE.env.length-1];
+	while(lst !== NULL) {
+	    testArgument('pair', isPair, lst, 0, 'reverse');
+	    rev = [lst[0], rev];
+	    lst = lst[1];
+	}
+	return rev;
+    };
+    Primitives['reverse'].arity = 1;
+
+
 
     var trampoline = function(MACHINE, initialJump) {
 	var thunk = initialJump;
@@ -921,6 +977,7 @@
 
 
     exports['isNumber'] = isNumber;
+    exports['isNatural'] = isNatural;
     exports['isPair'] = isPair;
     exports['isList'] = isList;
     exports['isVector'] = isVector;

test-browser-evaluate.rkt

@@ -79,20 +79,20 @@ EOF
       "7")
 
 (test/exn (evaluate '(+ "hello" 3))
-          "Error: Expected number as argument 1 but received hello")
+          "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")
+          "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")
+          "Error: -: expected number as argument 1 but received one")
 
 (test '(display (- 5 4))
       "1")
@@ -101,7 +101,7 @@ EOF
       "51")
 
 (test/exn '(* "three" 17)
-          "Error: Expected number as argument 1 but received three")
+          "Error: *: expected number as argument 1 but received three")
 
 (test '(display '#t)
       "true")
@@ -125,13 +125,13 @@ EOF
       "2\n")
 
 (test/exn '(displayln (add1 "0"))
-          "Error: Expected number as argument 1 but received 0")
+          "Error: add1: 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")
+          "Error: sub1: expected number as argument 1 but received 0")
 
 (test '(displayln (< 1 2))
       "true\n")
@@ -322,7 +322,7 @@ EOF
 (test/exn '(let ([x 0])
              (set! x "foo")
              (add1 x))
-          "Error: Expected number as argument 1 but received foo")
+          "Error: add1: expected number as argument 1 but received foo")