suzanne.soy/whalesong
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

kernel domain checks have caller

Browse Source
This commit is contained in:
Danny Yoo 2011-04-13 14:33:02 -04:00
parent f43f43f2b1
commit 1f5738cd20
5 changed files with 88 additions and 15 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

19
assemble-open-coded.rkt
View File

@ -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]))

2
assemble.rkt
View File

@ -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")]

11
racket-expander.rkt
View File

@ -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

57
runtime.js
View File

@ -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;

14
test-browser-evaluate.rkt
View File

@ -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")