diff --git a/assemble-open-coded.rkt b/assemble-open-coded.rkt index 8ef2ccf..5c4e733 100644 --- a/assemble-open-coded.rkt +++ b/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)) -(define (assemble-domain-check domain operand-string pos) +(: assemble-domain-check (Symbol OperandDomain String Natural -> String)) +(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])) diff --git a/assemble.rkt b/assemble.rkt index 81fb2b6..249464a 100644 --- a/assemble.rkt +++ b/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")] diff --git a/racket-expander.rkt b/racket-expander.rkt index f6746f5..9cdfd42 100644 --- a/racket-expander.rkt +++ b/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 diff --git a/runtime.js b/runtime.js index f0ac2d5..3413052 100644 --- a/runtime.js +++ b/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; diff --git a/test-browser-evaluate.rkt b/test-browser-evaluate.rkt index 64c4ab9..a6df336 100644 --- a/test-browser-evaluate.rkt +++ b/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")