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

fixing arity checks

Browse Source
This commit is contained in:
Danny Yoo 2011-04-08 23:29:32 -04:00
parent 05c37fe6d0
commit 398de4c1b0
9 changed files with 165 additions and 41 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

14
assemble-helpers.rkt
View File

@ -12,7 +12,8 @@
assemble-whole-prefix-reference
assemble-reg
assemble-label
assemble-input)
assemble-input
assemble-listof-assembled-values)
(: assemble-oparg (OpArg -> String))
@ -41,6 +42,8 @@
"MACHINE.proc"]
[(eq? target 'val)
"MACHINE.val"]
[(eq? target 'argcount)
"MACHINE.argcount"]
[(EnvLexicalReference? target)
(assemble-lexical-reference target)]
[(EnvPrefixReference? target)
@ -71,6 +74,15 @@
[else
(format "~s" val)])))
(: assemble-listof-assembled-values ((Listof String) -> String))
(define (assemble-listof-assembled-values vals)
(let loop ([vals vals])
(cond
[(empty? vals)
"RUNTIME.NULL"]
[else
(format "[~a, ~a]" (first vals) (loop (rest vals)))])))

36
assemble.rkt
View File

@ -156,6 +156,8 @@ EOF
empty]
[(CheckClosureArity!? op)
empty]
[(CheckPrimitiveArity!? op)
empty]
[(ExtendEnvironment/Prefix!? op)
empty]
[(InstallClosureValues!? op)
@ -337,7 +339,7 @@ EOF
[(MakeCompiledProcedure? op)
(format "new RUNTIME.Closure(~a, ~a, [~a], ~a)"
(MakeCompiledProcedure-label op)
(MakeCompiledProcedure-arity op)
(assemble-arity (MakeCompiledProcedure-arity op))
(string-join (map assemble-env-reference/closure-capture
;; The closure values are in reverse order
;; to make it easier to push, in bulk, into
@ -350,7 +352,7 @@ EOF
[(MakeCompiledProcedureShell? op)
(format "new RUNTIME.Closure(~a, ~a, undefined, ~a)"
(MakeCompiledProcedureShell-label op)
(MakeCompiledProcedureShell-arity op)
(assemble-arity (MakeCompiledProcedureShell-arity op))
(assemble-display-name (MakeCompiledProcedureShell-display-name op)))]
[(ApplyPrimitiveProcedure? op)
@ -382,6 +384,28 @@ EOF
(open-code-kernel-primitive-procedure op)]))
(define-predicate natural? Natural)
(: assemble-arity (Arity -> String))
(define (assemble-arity an-arity)
(cond
[(natural? an-arity)
(format "~a" an-arity)]
[(ArityAtLeast? an-arity)
(format "(new RUNTIME.ArityAtLeast(~a))" (ArityAtLeast-value an-arity))]
[(listof-atomic-arity? an-arity)
(assemble-listof-assembled-values
(map (lambda: ([atomic-arity : (U Natural ArityAtLeast)])
(cond
[(natural? atomic-arity)
(format "~a" an-arity)]
[(ArityAtLeast? an-arity)
(format "(new RUNTIME.ArityAtLeast(~a))" (ArityAtLeast-value an-arity))]
;; Can't seem to make the type checker happy without this...
[else (error 'assemble-arity)]))
an-arity))]))
(: assemble-default-continuation-prompt-tag (-> String))
(define (assemble-default-continuation-prompt-tag)
"RUNTIME.DEFAULT_CONTINUATION_PROMPT_TAG")
@ -402,7 +426,13 @@ EOF
(CheckToplevelBound!-pos op))]
[(CheckClosureArity!? op)
(format "if (! (MACHINE.proc instanceof RUNTIME.Closure && MACHINE.proc.arity === MACHINE.val)) { if (! (MACHINE.proc instanceof RUNTIME.Closure)) { throw new Error(\"not a closure\"); } else { throw new Error(\"arity failure\"); } }")]
(format "if (! (MACHINE.proc instanceof RUNTIME.Closure && RUNTIME.isArityMatching(MACHINE.proc.arity, ~a))) { if (! (MACHINE.proc instanceof RUNTIME.Closure)) { throw new Error(\"not a closure\"); } else { throw new Error(\"arity failure:\" + MACHINE.proc.displayName); } }"
(assemble-oparg (CheckClosureArity!-arity op)))]
[(CheckPrimitiveArity!? op)
(format "if (! (typeof(MACHINE.proc) === 'function' && RUNTIME.isArityMatching(MACHINE.proc.arity, ~a))) { if (! (typeof(MACHINE.proc) === 'function')) { throw new Error(\"not a primitive procedure\"); } else { throw new Error(\"arity failure:\" + MACHINE.proc.displayName); } }"
(assemble-oparg (CheckPrimitiveArity!-arity op)))]
[(ExtendEnvironment/Prefix!? op)
(let: ([names : (Listof (U Symbol False ModuleVariable)) (ExtendEnvironment/Prefix!-names op)])

8
il-structs.rkt
View File

@ -365,13 +365,13 @@
(define-type Arity (U Natural
ArityAtLeast
(Listof (U Natural ArityAtLeast))))
(define-type Arity (U Natural ArityAtLeast (Listof (U Natural ArityAtLeast))))
(define-struct: ArityAtLeast ([value : Natural])
#:transparent)
(define-predicate listof-atomic-arity? (Listof (U Natural ArityAtLeast)))
(define-predicate OpArg? OpArg)

92
runtime.js
View File

@ -29,14 +29,16 @@
var isNumber = function(x) { return typeof(x) === 'number'; };
var isPair = function(x) { return (typeof(x) == 'object' &&
x.length === 2) }
x.length === 2) };
var isVector = function(x) { return (typeof(x) == 'object' &&
x.length !== undefined) }
x.length !== undefined) };
var Machine = function() {
this.callsBeforeTrampoline = 100;
this.val = undefined;
this.proc = undefined;
this.argcount = undefined;
this.env = [];
this.control = []; // Arrayof (U CallFrame PromptFrame)
this.running = false;
@ -234,10 +236,33 @@
}
// An arity is either a primitive number, an ArityAtLeast instance,
// or a list of either primitive numbers or ArityAtLeast instances.
var ArityAtLeast = function(n) {
this.value = n;
};
// isArityMatching: arity natural -> boolean
// Produces true if n satisfies the arity.
var isArityMatching = function(arity, n) {
if (typeof(arity) === 'number') {
return arity === n;
} else if (arity instanceof ArityAtLeast) {
return n >= arity.value;
} else {
while (arity !== NULL) {
if (typeof(arity[0]) === 'number') {
if (arity[0] === n) { return true; }
} else if (arity instanceof ArityAtLeast) {
if (n >= arity[0].value) { return true; }
}
arity = arity[1];
}
return false;
}
}
@ -248,40 +273,39 @@
// the bootstrapping code.
var Primitives = {};
Primitives['display'] = function(MACHINE, arity) {
testArity('display', arity, 1, 2);
var firstArg = MACHINE.env[MACHINE.env.length-1];
var outputPort = MACHINE.params.currentOutputPort;
if (arity == 2) {
if (arity === 2) {
outputPort = MACHINE.env[MACHINE.env.length-2];
}
outputPort.write(MACHINE, firstArg);
};
// FIXME: need to make a case dispatch here on arity.
Primitives['display'].arity = 1; //new ArityAtLeast(1);
Primitives['display'].arity = [1, [2, NULL]];
Primitives['display'].displayName = 'display';
Primitives['newline'] = function(MACHINE, arity) {
testArity('newline', arity, 0, 1);
var outputPort = MACHINE.params.currentOutputPort;
if (arity == 1) {
if (arity === 1) {
outputPort = MACHINE.env[MACHINE.env.length-1];
}
outputPort.write(MACHINE, "\n");
};
Primitives['newline'].arity = 1; //new ArityAtLeast(1);
Primitives['newline'].arity = [0, [1, NULL]];
Primitives['newline'].displayName = 'newline';
Primitives['displayln'] = function(MACHINE, arity){
testArity('displayln', arity, 1, 2);
var firstArg = MACHINE.env[MACHINE.env.length-1];
var outputPort = MACHINE.params.currentOutputPort;
if (arity == 2) {
if (arity === 2) {
outputPort = MACHINE.env[MACHINE.env.length-2];
}
outputPort.write(MACHINE, firstArg);
outputPort.write(MACHINE, "\n");
};
Primitives['displayln'].arity = 1; //new ArityAtLeast(1);
Primitives['displayln'].arity = [1, [2, NULL]];
Primitives['displayln'].displayName = 'displayln';
Primitives['pi'] = Math.PI;
@ -304,6 +328,7 @@
return true;
};
Primitives['='].arity = new ArityAtLeast(2);
Primitives['='].displayName = '=';
Primitives['<'] = function(MACHINE, arity) {
@ -323,6 +348,7 @@
return true;
};
Primitives['<'].arity = new ArityAtLeast(2);
Primitives['<'].displayName = '<';
Primitives['>'] = function(MACHINE, arity) {
var firstArg = MACHINE.env[MACHINE.env.length-1];
@ -341,6 +367,7 @@
return true;
};
Primitives['>'].arity = new ArityAtLeast(2);
Primitives['>'].displayName = '>';
Primitives['<='] = function(MACHINE, arity) {
var firstArg = MACHINE.env[MACHINE.env.length-1];
@ -359,6 +386,7 @@
return true;
};
Primitives['<='].arity = new ArityAtLeast(2);
Primitives['<='].displayName = '<=';
Primitives['>='] = function(MACHINE, arity) {
@ -378,6 +406,7 @@
return true;
};
Primitives['>='].arity = new ArityAtLeast(2);
Primitives['>='].displayName = '>=';
Primitives['+'] = function(MACHINE, arity) {
@ -395,6 +424,7 @@
return result;
};
Primitives['+'].arity = new ArityAtLeast(0);
Primitives['+'].displayName = '+';
Primitives['*'] = function(MACHINE, arity) {
@ -412,6 +442,7 @@
return result;
};
Primitives['*'].arity = new ArityAtLeast(0);
Primitives['*'].displayName = '*';
Primitives['-'] = function(MACHINE, arity) {
if (arity === 1) {
@ -434,6 +465,7 @@
return result;
};
Primitives['-'].arity = new ArityAtLeast(1);
Primitives['-'].displayName = '-';
Primitives['/'] = function(MACHINE, arity) {
testArgument('number',
@ -448,6 +480,8 @@
return result;
};
Primitives['/'].arity = new ArityAtLeast(1);
Primitives['/'].displayName = '/';
Primitives['cons'] = function(MACHINE, arity) {
var firstArg = MACHINE.env[MACHINE.env.length-1];
@ -455,6 +489,7 @@
return [firstArg, secondArg];
};
Primitives['cons'].arity = 2;
Primitives['cons'].displayName = 'cons';
Primitives['list'] = function(MACHINE, arity) {
@ -466,6 +501,7 @@
return result;
};
Primitives['list'].arity = new ArityAtLeast(0);
Primitives['list'].displayName = 'list';
Primitives['car'] = function(MACHINE, arity) {
testArgument('pair',
@ -477,6 +513,7 @@
return firstArg[0];
};
Primitives['car'].arity = 1;
Primitives['car'].displayName = 'car';
Primitives['cdr'] = function(MACHINE, arity) {
testArgument('pair',
@ -488,12 +525,14 @@
return firstArg[1];
};
Primitives['cdr'].arity = 1;
Primitives['cdr'].displayName = 'cdr';
Primitives['pair?'] = function(MACHINE, arity) {
var firstArg = MACHINE.env[MACHINE.env.length-1];
return isPair(firstArg);
};
Primitives['pair?'].arity = 1;
Primitives['pair?'].displayName = 'pair?';
Primitives['set-car!'] = function(MACHINE, arity) {
testArgument('pair',
@ -505,7 +544,8 @@
var secondArg = MACHINE.env[MACHINE.env.length-2];
firstArg[0] = secondArg;
};
Primitives['set-car!'].arity = 1;
Primitives['set-car!'].arity = 2;
Primitives['set-car!'].displayName = 'set-car!';
Primitives['set-cdr!'] = function(MACHINE, arity) {
testArgument('pair',
@ -517,13 +557,15 @@
var secondArg = MACHINE.env[MACHINE.env.length-2];
firstArg[1] = secondArg;
};
Primitives['set-cdr!'].arity = 1;
Primitives['set-cdr!'].arity = 2;
Primitives['set-cdr!'].displayName = 'set-cdr!';
Primitives['not'] = function(MACHINE, arity) {
var firstArg = MACHINE.env[MACHINE.env.length-1];
return (!firstArg);
};
Primitives['not'].arity = 1;
Primitives['not'].displayName = 'not';
Primitives['null'] = NULL;
@ -532,6 +574,7 @@
return firstArg === NULL;
};
Primitives['null?'].arity = 1;
Primitives['null?'].displayName = 'null?';
Primitives['add1'] = function(MACHINE, arity) {
testArgument('number',
@ -543,6 +586,7 @@
return firstArg + 1;
};
Primitives['add1'].arity = 1;
Primitives['add1'].displayName = 'add1';
Primitives['sub1'] = function(MACHINE, arity) {
testArgument('number',
@ -554,12 +598,14 @@
return firstArg - 1;
};
Primitives['sub1'].arity = 1;
Primitives['sub1'].displayName = 'sub1';
Primitives['zero?'] = function(MACHINE, arity) {
var firstArg = MACHINE.env[MACHINE.env.length-1];
return firstArg === 0;
};
Primitives['zero?'].arity = 1;
Primitives['zero?'].displayName = 'zero?';
Primitives['vector'] = function(MACHINE, arity) {
var i;
@ -570,6 +616,7 @@
return result;
};
Primitives['vector'].arity = new ArityAtLeast(0);
Primitives['vector'].displayName = 'vector';
Primitives['vector->list'] = function(MACHINE, arity) {
testArgument('vector',
@ -586,6 +633,7 @@
return result;
};
Primitives['vector->list'].arity = 1;
Primitives['vector->list'].displayName = 'vector->list';
Primitives['list->vector'] = function(MACHINE, arity) {
var firstArg = MACHINE.env[MACHINE.env.length-1];
@ -597,6 +645,7 @@
return result;
};
Primitives['list->vector'].arity = 1;
Primitives['list->vector'].displayName = 'list->vector';
Primitives['vector-ref'] = function(MACHINE, arity) {
testArgument('vector',
@ -609,6 +658,7 @@
return firstArg[secondArg];
};
Primitives['vector-ref'].arity = 2;
Primitives['vector-ref'].displayName = 'vector-ref';
Primitives['vector-set!'] = function(MACHINE, arity) {
testArgument('vector',
@ -623,18 +673,21 @@
return null;
};
Primitives['vector-set!'].arity = 3;
Primitives['vector-set!'].displayName = 'vector-set!';
Primitives['symbol?'] = function(MACHINE, arity) {
var firstArg = MACHINE.env[MACHINE.env.length-1];
return typeof(firstArg) === 'string';
};
Primitives['symbol?'].arity = 1;
Primitives['symbol?'].displayName = 'symbol?';
Primitives['symbol->string'] = function(MACHINE, arity) {
var firstArg = MACHINE.env[MACHINE.env.length-1];
return firstArg;
};
Primitives['symbol->string'].arity = 1;
Primitives['symbol->string'].displayName = 'symbol->string';
Primitives['string-append'] = function(MACHINE, arity) {
var buffer = [];
@ -645,12 +698,14 @@
return buffer.join('');
};
Primitives['string-append'].arity = new ArityAtLeast(0);
Primitives['string-append'].displayName = 'string-append';
Primitives['string-length'] = function(MACHINE, arity) {
var firstArg = MACHINE.env[MACHINE.env.length-1];
return firstArg.length;
};
Primitives['string-length'].arity = 1;
Primitives['string-length'].displayName = 'string-length';
Primitives['box'] = function(MACHINE, arity) {
var firstArg = MACHINE.env[MACHINE.env.length-1];
@ -658,12 +713,14 @@
return result;
};
Primitives['box'].arity = 1;
Primitives['box'].displayName = 'box';
Primitives['unbox'] = function(MACHINE, arity) {
var firstArg = MACHINE.env[MACHINE.env.length-1];
return firstArg[0];
};
Primitives['unbox'].arity = 1;
Primitives['unbox'].displayName = 'unbox';
Primitives['set-box!'] = function(MACHINE, arity) {
var firstArg = MACHINE.env[MACHINE.env.length-1];
@ -672,11 +729,13 @@
return;
};
Primitives['set-box!'].arity = 2;
Primitives['set-box!'].displayName = 'set-box!';
Primitives['void'] = function(MACHINE, arity) {
return;
};
Primitives['void'].arity = new ArityAtLeast(0);
Primitives['void'].displayName = 'void';
Primitives['eq?'] = function(MACHINE, arity) {
var firstArg = MACHINE.env[MACHINE.env.length-1];
@ -684,6 +743,7 @@
return firstArg === secondArg;
};
Primitives['eq?'].arity = 2;
Primitives['eq?'].displayName = 'eq?';
Primitives['equal?'] = function(MACHINE, arity) {
var firstArg = MACHINE.env[MACHINE.env.length-1];
@ -708,6 +768,7 @@
return true;
};
Primitives['equal?'].arity = 2;
Primitives['equal?'].displayName = 'equal?';
@ -793,6 +854,9 @@
exports['isOutputPort'] = isOutputPort;
exports['isOutputStringPort'] = isOutputStringPort;
exports['ArityAtLeast'] = ArityAtLeast;
exports['isArityMatching'] = isArityMatching;
exports['heir'] = heir;
exports['makeClassPredicate'] = makeClassPredicate;

1
simulator-primitives.rkt
View File

@ -1,5 +1,6 @@
#lang racket/base
(require "simulator-structs.rkt"
"il-structs.rkt"
racket/math
(for-syntax racket/base))

1
simulator-structs.rkt
View File

@ -39,6 +39,7 @@
(define-struct: machine ([val : SlotValue]
[proc : SlotValue]
[argcount : SlotValue]
[env : (Listof SlotValue)]
[control : (Listof frame)]

39
simulator.rkt
View File

@ -49,6 +49,7 @@
[else
program-text])])
(let: ([m : machine (make-machine (make-undefined)
(make-undefined)
(make-undefined)
'()
'()
@ -126,7 +127,9 @@
(cond [(eq? reg 'val)
(jump! m (ensure-symbol (machine-val m)))]
[(eq? reg 'proc)
(jump! m (ensure-symbol (machine-proc m)))])]))])))
(jump! m (ensure-symbol (machine-proc m)))]
[(eq? reg 'argcount)
(error 'goto "argcount misused as jump source")])]))])))
(: step-assign-immediate! (machine AssignImmediateStatement -> 'ok))
(define (step-assign-immediate! m stmt)
@ -194,7 +197,9 @@
(cond [(eq? reg 'val)
(machine-val m)]
[(eq? reg 'proc)
(machine-proc m)]))
(machine-proc m)]
[(eq? reg 'argcount)
(machine-argcount m)]))
(: lookup-env-reference/closure-capture (machine EnvReference -> SlotValue))
@ -339,6 +344,8 @@
proc-update!]
[(eq? t 'val)
val-update!]
[(eq? t 'argcount)
argcount-update!]
[(EnvLexicalReference? t)
(lambda: ([m : machine] [v : SlotValue])
(if (EnvLexicalReference-unbox? t)
@ -562,7 +569,9 @@
[(eq? n 'proc)
(machine-proc m)]
[(eq? n 'val)
(machine-val m)]))]
(machine-val m)]
[(eq? n 'argcount)
(machine-argcount m)]))]
[(EnvLexicalReference? an-oparg)
(let*: ([v : SlotValue
@ -704,7 +713,7 @@
(: current-instruction (machine -> Statement))
(define (current-instruction m)
(match m
[(struct machine (val proc env control pc text
[(struct machine (val proc argcount env control pc text
stack-size jump-table))
(vector-ref text pc)]))
@ -715,6 +724,10 @@
(set-machine-val! m v)
'ok)
(: argcount-update! (machine SlotValue -> 'ok))
(define (argcount-update! m v)
(set-machine-argcount! m v)
'ok)
(: proc-update! (machine SlotValue -> 'ok))
(define (proc-update! m v)
@ -725,7 +738,7 @@
(: env-push! (machine SlotValue -> 'ok))
(define (env-push! m v)
(match m
[(struct machine (val proc env control pc text stack-size jump-table))
[(struct machine (val proc argcount env control pc text stack-size jump-table))
(set-machine-env! m (cons v env))
(set-machine-stack-size! m (add1 stack-size))
'ok]))
@ -733,7 +746,7 @@
(: env-push-many! (machine (Listof SlotValue) -> 'ok))
(define (env-push-many! m vs)
(match m
[(struct machine (val proc env control pc text stack-size jump-table))
[(struct machine (val proc argcount env control pc text stack-size jump-table))
(set-machine-env! m (append vs env))
(set-machine-stack-size! m (+ stack-size (length vs)))
'ok]))
@ -742,13 +755,13 @@
(: env-ref (machine Natural -> SlotValue))
(define (env-ref m i)
(match m
[(struct machine (val proc env control pc text stack-size jump-table))
[(struct machine (val proc argcount env control pc text stack-size jump-table))
(list-ref env i)]))
(: env-mutate! (machine Natural SlotValue -> 'ok))
(define (env-mutate! m i v)
(match m
[(struct machine (val proc env control pc text stack-size jump-table))
[(struct machine (val proc argcount env control pc text stack-size jump-table))
(set-machine-env! m (list-replace env i v))
'ok]))
@ -766,7 +779,7 @@
(: env-pop! (machine Natural Natural -> 'ok))
(define (env-pop! m n skip)
(match m
[(struct machine (val proc env control pc text stack-size jump-table))
[(struct machine (val proc argcount env control pc text stack-size jump-table))
(set-machine-env! m (append (take env skip)
(drop env (+ skip n))))
(set-machine-stack-size! m (ensure-natural (- stack-size n)))
@ -776,7 +789,7 @@
(: control-push! (machine frame -> 'ok))
(define (control-push! m a-frame)
(match m
[(struct machine (val proc env control pc text stack-size jump-table))
[(struct machine (val proc argcount env control pc text stack-size jump-table))
(set-machine-control! m (cons a-frame control))
'ok]))
@ -784,14 +797,14 @@
(: control-pop! (machine -> 'ok))
(define (control-pop! m)
(match m
[(struct machine (val proc env control pc text stack-size jump-table))
[(struct machine (val proc argcount env control pc text stack-size jump-table))
(set-machine-control! m (rest control))
'ok]))
(: control-top (machine -> frame))
(define (control-top m)
(match m
[(struct machine (val proc env control pc text stack-size jump-table))
[(struct machine (val proc argcount env control pc text stack-size jump-table))
(first control)]))
@ -807,7 +820,7 @@
;; Jumps directly to the instruction at the given label.
(define (jump! m l)
(match m
[(struct machine (val proc env control pc text stack-size jump-table))
[(struct machine (val proc argcount env control pc text stack-size jump-table))
(set-machine-pc! m (hash-ref jump-table l))
'ok]))

4
test-assemble.rkt
View File

@ -250,7 +250,7 @@
(list 0 1)
'closureStart))
(make-PopEnvironment 2 0)
(make-PerformStatement (make-CheckClosureArity! 5)))))
(make-PerformStatement (make-CheckClosureArity! (make-Const 5))))))
;; this should fail, since the check is for 1, but the closure expects 5.
(let/ec return
@ -272,7 +272,7 @@
(list 0 1)
'closureStart))
(make-PopEnvironment 2 0)
(make-PerformStatement (make-CheckClosureArity! 1)))))
(make-PerformStatement (make-CheckClosureArity! (make-Const 1))))))
(error 'expected-failure))

11
test-simulator.rkt
View File

@ -323,10 +323,12 @@
;; install-closure-values
(let ([m
(make-machine (make-undefined) (make-closure 'procedure-entry
0
(list 1 2 3)
'procedure-entry)
(make-machine (make-undefined)
(make-closure 'procedure-entry
0
(list 1 2 3)
'procedure-entry)
(make-undefined)
(list true false) ;; existing environment holds true, false
'()
0
@ -343,6 +345,7 @@
(let ([m
(make-machine (make-undefined)
(make-closure 'procedure-entry 0 (list 1 2 3) 'procedure-entry)
(make-undefined)
(list true false) ;; existing environment holds true, false
'()
0