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

Merge remote-tracking branch 'origin/master'

Browse Source
This commit is contained in:
Danny Yoo 2011-06-09 18:27:34 -04:00
commit 55a95d3c54
54 changed files with 4072 additions and 771 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

62
NOTES
View File

@ -683,4 +683,64 @@ circularity between helpers and types.
The parameters I'm using to control bounce are too high for Firefox,
leading it to raise the dialog about an out of control jva process. Not good.
leading it to raise the dialog about an out of control jva process. Not good.
----------------------------------------------------------------------
Working out the type mappings between values in Racket and values in JavaScript
Racket JavaScript Switched over?
number jsnums.SchemeNumber yes
immutable strings JavaScript string
mutable strings types.Str
vector
regular-expressions
path
bytes
box
placeholder
character
symbol
keyword
pair yes
empty yes
eq-hashtable
equal-hashtable
struct-type
struct
path
continuation-mark-set
primitive-procedure
closure
case-lambda
undefined undefined
void plt.runtime.VOID
----------------------------------------------------------------------
I should add the functions:
get-viewport-width
get-viewport-height
Other notes from Shriram: too slow, inconsistent positioning from jsworld.
----------------------------------------------------------------------
Added base as the default planet language.

19
README
View File

@ -3,6 +3,7 @@ Whalesong: a compiler from Racket to JavaScript.
Danny Yoo (dyoo@cs.wpi.edu)
======================================================================
@ -16,9 +17,25 @@ amount of time.
Example usage
[FIXME]
Create a simple, standalong executable of your program. At the
moment, the program must be written in the base language of whalesong.
(This restriction currently prevents arbitrary racket/base programs
from compiling, and we'll be working to remove this restriction.)
$ cat hello.rkt
#lang planet dyoo/whalesong
(display "hello world")
(newline)
$ ./whalesong.rkt build hello.rkt
$ ls -l hello.xhtml
-rw-rw-r-- 1 dyoo nogroup 692213 Jun 7 18:00 hello.xhtml
[FIXME: add more examples]
======================================================================

3
compiler/compiler.rkt
View File

@ -321,7 +321,7 @@
;; that has not yet been invoked.
;; fixme: This also needs to generate code for the requires and provides.
(match mod
[(struct Module (name path prefix requires code))
[(struct Module (name path prefix requires provides code))
(let*: ([after-module-body (make-label 'afterModuleBody)]
[module-entry (make-label 'module-entry)]
[names : (Listof (U False Symbol GlobalBucket ModuleVariable))
@ -2156,6 +2156,7 @@
(Module-path exp)
(Module-prefix exp)
(Module-requires exp)
(Module-provides exp)
(adjust-expression-depth (Module-code exp) n (add1 skip)))]
[(Constant? exp)

8
compiler/expression-structs.rkt
View File

@ -37,10 +37,18 @@
[path : ModuleLocator]
[prefix : Prefix]
[requires : (Listof ModuleLocator)]
[provides : (Listof ModuleProvide)]
[code : Expression])
#:transparent)
(define-struct: ModuleProvide ([internal-name : Symbol]
[external-name : Symbol]
[source : ModuleLocator])
#:transparent)
(define-struct: Top ([prefix : Prefix]
[code : Expression]) #:transparent)

6
compiler/il-structs.rkt
View File

@ -334,10 +334,10 @@
#:transparent)
;; Check the closure procedure value in 'proc and make sure it can accept the
;; # of arguments (stored as a number in the val register.).
(define-struct: CheckClosureArity! ([arity : OpArg])
;; # of arguments (stored as a number in the argcount register.).
(define-struct: CheckClosureArity! ([num-args : OpArg])
#:transparent)
(define-struct: CheckPrimitiveArity! ([arity : OpArg])
(define-struct: CheckPrimitiveArity! ([num-args : OpArg])
#:transparent)

3
examples/alert.rkt Normal file
View File

@ -0,0 +1,3 @@
#lang planet dyoo/whalesong
(require (planet dyoo/whalesong/js))
(alert "hello world")

37
examples/dom-play.rkt Normal file
View File

@ -0,0 +1,37 @@
#lang planet dyoo/whalesong
(require (planet dyoo/whalesong/js))
;; insert-break: -> void
(define (insert-break)
(call ($ "<br/>") "appendTo" body)
(void))
(define (write-message msg)
(void (call (call (call ($ "<span/>") "text" msg)
"css" "white-space" "pre")
"appendTo"
body)))
;; Set the background green.
(void (call body "css" "background-color" "lightgreen"))
(void (call ($ "<h1>Hello World</h1>") "appendTo" body))
(write-message "Hello, this is a test!")
(insert-break)
(let loop ([i 0])
(cond
[(= i 10)
(void)]
[else
(write-message "iteration ") (write-message i)
(insert-break)
(loop (add1 i))]))
(write-message "viewport-width: ") (write-message (viewport-width))
(insert-break)
(write-message "viewport-height: ") (write-message (viewport-height))
(insert-break)

4
examples/hello.rkt Normal file
View File

@ -0,0 +1,4 @@
#lang planet dyoo/whalesong
(display "hello world")
(newline)

9
examples/simple-world-program.rkt Normal file
View File

@ -0,0 +1,9 @@
#lang planet dyoo/whalesong
(require (planet dyoo/whalesong/world))
(display "hello again")
(newline)
(is-color? "red")
(is-color? "blue")
(is-color? 42)

7
examples/window-size.rkt Normal file
View File

@ -0,0 +1,7 @@
#lang planet dyoo/whalesong
(when (in-javascript-context?)
(viewport-width))
(when (in-javascript-context?)
(viewport-height))

6
js-assembler/assemble-helpers.rkt
View File

@ -101,13 +101,13 @@
(cond [(symbol? val)
(format "~s" (symbol->string val))]
[(pair? val)
(format "[~a, ~a]"
(format "RUNTIME.makePair(~a, ~a)"
(loop (car val))
(loop (cdr val)))]
[(boolean? val)
(if val "true" "false")]
[(void? val)
"null"]
"RUNTIME.VOID"]
[(empty? val)
(format "RUNTIME.NULL")]
[(number? val)
@ -122,7 +122,7 @@
[(empty? vals)
"RUNTIME.NULL"]
[else
(format "[~a, ~a]" (first vals) (loop (rest vals)))])))
(format "RUNTIME.makePair(~a, ~a)" (first vals) (loop (rest vals)))])))

25
js-assembler/assemble-open-coded.rkt
View File

@ -68,26 +68,21 @@
[(>=)
(assemble-boolean-chain "jsnums.greaterThanOrEqual" checked-operands)]
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
[(cons)
(format "[~a, ~a]" (first checked-operands) (second checked-operands))]
(format "RUNTIME.makePair(~a, ~a)"
(first checked-operands)
(second checked-operands))]
[(car)
(format "(~a)[0]" (first checked-operands))]
(format "(~a).first" (first checked-operands))]
[(cdr)
(format "(~a)[1]" (first checked-operands))]
(format "(~a).rest" (first checked-operands))]
[(list)
(let loop ([checked-operands checked-operands])
(cond
[(empty? checked-operands)
"RUNTIME.NULL"]
[else
(format "[~a,~a]" (first checked-operands) (loop (rest checked-operands)))]))]
(assemble-listof-assembled-values checked-operands))]
[(null?)
(format "(~a === RUNTIME.NULL)" (first checked-operands))]
@ -151,17 +146,15 @@
(let: ([test-string : String
(case domain
[(number)
(format "(jsnums.isSchemeNumber(~a))"
(format "jsnums.isSchemeNumber(~a)"
operand-string)]
[(string)
(format "(typeof(~a) === 'string')"
operand-string)]
[(list)
(format "(~a === [] || (typeof(~a) === 'object' && (~a).length === 2))"
operand-string operand-string operand-string)]
(format "RUNTIME.isList(~a)" operand-string)]
[(pair)
(format "(typeof(~a) === 'object' && (~a).length === 2)"
operand-string operand-string)]
(format "RUNTIME.isPair(~a)" operand-string)]
[(box)
(format "(typeof(~a) === 'object' && (~a).length === 1)"
operand-string operand-string)])])

14
js-assembler/assemble-perform-statement.rkt
View File

@ -27,13 +27,14 @@
RUNTIME.raiseOperatorIsNotClosure(MACHINE, MACHINE.proc);
}
if (! RUNTIME.isArityMatching(MACHINE.proc.arity, ~a)) {
RUNTIME.raiseArityMismatchError(MACHINE.proc,
RUNTIME.raiseArityMismatchError(MACHINE,
MACHINE.proc,
MACHINE.proc.arity,
~a);
}
EOF
(assemble-oparg (CheckClosureArity!-arity op))
(assemble-oparg (CheckClosureArity!-arity op)))]
(assemble-oparg (CheckClosureArity!-num-args op))
(assemble-oparg (CheckClosureArity!-num-args op)))]
[(CheckPrimitiveArity!? op)
@ -42,13 +43,14 @@ EOF
RUNTIME.raiseOperatorIsNotPrimitiveProcedure(MACHINE, MACHINE.proc);
}
if (! RUNTIME.isArityMatching(MACHINE.proc.arity, ~a)) {
RUNTIME.raiseArityMismatchError(MACHINE.proc,
RUNTIME.raiseArityMismatchError(MACHINE,
MACHINE.proc,
MACHINE.proc.arity,
~a);
}
EOF
(assemble-oparg (CheckPrimitiveArity!-arity op))
(assemble-oparg (CheckPrimitiveArity!-arity op)))]
(assemble-oparg (CheckPrimitiveArity!-num-args op))
(assemble-oparg (CheckPrimitiveArity!-num-args op)))]
[(ExtendEnvironment/Prefix!? op)

2
js-assembler/assemble.rkt
View File

@ -186,7 +186,7 @@ EOF
"")
(cond
[(DebugPrint? stmt)
(format "MACHINE.params.currentOutputPort.write(MACHINE, ~a);" (assemble-oparg (DebugPrint-value stmt)))]
(format "MACHINE.params.currentOutputPort.writeDomNode(MACHINE, $('<span/>').text(~a));" (assemble-oparg (DebugPrint-value stmt)))]
[(AssignImmediateStatement? stmt)
(let: ([t : String (assemble-target (AssignImmediateStatement-target stmt))]
[v : OpArg (AssignImmediateStatement-value stmt)])

188
js-assembler/package.rkt
View File

@ -2,8 +2,14 @@
(require "assemble.rkt"
"quote-cdata.rkt"
"../make.rkt"
"../make-structs.rkt"
"../make/make.rkt"
"../make/make-structs.rkt"
"../parameters.rkt"
"../compiler/expression-structs.rkt"
"../parser/path-rewriter.rkt"
"../parser/parse-bytecode.rkt"
racket/match
(prefix-in query: "../lang/js/query.rkt")
(planet dyoo/closure-compile:1:1)
(prefix-in runtime: "get-runtime.rkt")
(prefix-in racket: racket/base))
@ -21,52 +27,172 @@
write-runtime)
;; notify: string (listof any)* -> void
;; Print out log message during the build process.
(define (notify msg . args)
(displayln (apply format msg args)))
(define-struct js-impl (name ;; symbol
real-path ;; path
src ;; string
)
#:transparent)
;; Packager: produce single .js files to be included to execute a
;; program.
(define (package-anonymous source-code
#:should-follow? should-follow?
#:should-follow-children? should-follow?
#:output-port op)
(fprintf op "(function() {\n")
(package source-code
#:should-follow? should-follow?
#:should-follow-children? should-follow?
#:output-port op)
(fprintf op " return invoke; })\n"))
;; source-is-javascript-module?: Source -> boolean
;; Returns true if the source looks like a Javascript-implemented module.
(define (source-is-javascript-module? src)
(cond
[(StatementsSource? src)
#f]
[(MainModuleSource? src)
(source-is-javascript-module? (MainModuleSource-source src))]
[(ModuleSource? src)
(query:has-javascript-implementation? `(file ,(path->string (ModuleSource-path src))))]
[(SexpSource? src)
#f]
[(UninterpretedSource? src)
#f]))
;; get-javascript-implementation: source -> UninterpretedSource
(define (get-javascript-implementation src)
(define (get-provided-name-code bytecode)
(match bytecode
[(struct Top [_ (struct Module (name path prefix requires provides code))])
(apply string-append
(map (lambda (p)
(format "modrec.namespace[~s] = exports[~s];\n"
(symbol->string (ModuleProvide-internal-name p))
(symbol->string (ModuleProvide-external-name p))))
provides))]
[else
""]))
(cond
[(StatementsSource? src)
(error 'get-javascript-implementation src)]
[(MainModuleSource? src)
(get-javascript-implementation (MainModuleSource-source src))]
[(ModuleSource? src)
(let ([name (rewrite-path (ModuleSource-path src))]
[text (query:query `(file ,(path->string (ModuleSource-path src))))]
[bytecode (parse-bytecode (ModuleSource-path src))])
(make-UninterpretedSource
(format "
MACHINE.modules[~s] =
new plt.runtime.ModuleRecord(~s,
function(MACHINE) {
if(--MACHINE.callsBeforeTrampoline<0) { throw arguments.callee; }
var modrec = MACHINE.modules[~s];
var exports = {};
modrec.isInvoked = true;
(function(MACHINE, RUNTIME, EXPORTS){~a})(MACHINE, plt.runtime, exports);
// FIXME: we need to inject the namespace with the values defined in exports.
~a
return MACHINE.control.pop().label(MACHINE);
});
"
(symbol->string name)
(symbol->string name)
(symbol->string name)
text
(get-provided-name-code bytecode))))]
[(SexpSource? src)
(error 'get-javascript-implementation)]
[(UninterpretedSource? src)
(error 'get-javascript-implementation)]))
;; package: Source (path -> boolean) output-port -> void
;; Compile package for the given source program. should-follow?
;; indicates whether we should continue following module paths.
;; Compile package for the given source program.
;;
;; should-follow-children? indicates whether we should continue
;; following module paths of a source's dependencies.
;;
;; The generated output defines a function called 'invoke' with
;; four arguments (MACHINE, SUCCESS, FAIL, PARAMS). When called, it will
;; execute the code to either run standalone expressions or
;; load in modules.
(define (package source-code
#:should-follow? should-follow?
#:should-follow-children? should-follow?
#:output-port op)
;; wrap-source: source -> source
;; Translate all JavaScript-implemented sources into uninterpreted sources;
;; we'll leave its interpretation to on-visit-src.
(define (wrap-source src)
(cond
[(source-is-javascript-module? src)
(get-javascript-implementation src)]
[else
src]))
(define (on-visit-src src ast stmts)
(cond
[(UninterpretedSource? src)
(fprintf op (UninterpretedSource-datum src))]
[else
(assemble/write-invoke stmts op)
(fprintf op "(MACHINE, function() { ")]))
(define (after-visit-src src ast stmts)
(cond
[(UninterpretedSource? src)
(void)]
[else
(fprintf op " }, FAIL, PARAMS);")]))
(define (on-last-src)
(fprintf op "SUCCESS();"))
(define packaging-configuration
(make-Configuration
wrap-source
should-follow?
;; on
(lambda (src ast stmts)
(assemble/write-invoke stmts op)
(fprintf op "(MACHINE, function() { "))
on-visit-src
;; after
(lambda (src ast stmts)
(fprintf op " }, FAIL, PARAMS);"))
after-visit-src
;; last
(lambda ()
(fprintf op "SUCCESS();"))))
on-last-src))
(fprintf op "var invoke = (function(MACHINE, SUCCESS, FAIL, PARAMS) {")
@ -90,10 +216,15 @@
;; write-runtime: output-port -> void
(define (write-runtime op)
(define (wrap-source src) src)
(let ([packaging-configuration
(make-Configuration
;; should-follow?
(lambda (src p) #t)
wrap-source
;; should-follow-children?
(lambda (src) #t)
;; on
(lambda (src ast stmts)
(assemble/write-invoke stmts op)
@ -114,12 +245,19 @@
(make (list only-bootstrapped-code) packaging-configuration)
(fprintf op "})(plt.runtime.currentMachine,\nfunction(){ plt.runtime.setReadyTrue(); },\nfunction(){},\n{});\n")))
(define (compress x)
(if (current-compress-javascript?)
(closure-compile x)
x))
(define *the-runtime*
(let ([buffer (open-output-string)])
(write-runtime buffer)
(closure-compile
(compress
(get-output-string buffer))))
@ -150,9 +288,9 @@ EOF
(define (get-code source-code)
(let ([buffer (open-output-string)])
(package source-code
#:should-follow? (lambda (src p) #t)
#:should-follow-children? (lambda (src) #t)
#:output-port buffer)
(closure-compile
(compress
(get-output-string buffer))))
@ -161,14 +299,14 @@ EOF
(define (get-standalone-code source-code)
(let ([buffer (open-output-string)])
(write-standalone-code source-code buffer)
(closure-compile
(compress
(get-output-string buffer))))
;; write-standalone-code: source output-port -> void
(define (write-standalone-code source-code op)
(package-anonymous source-code
#:should-follow? (lambda (src p) #t)
#:should-follow-children? (lambda (src) #t)
#:output-port op)
(fprintf op "()(plt.runtime.currentMachine, function() {}, function() {}, {});\n"))
@ -193,6 +331,8 @@ var invokeMainModule = function() {
if (console && console.log) {
console.log(e.stack || e);
}
MACHINE.params.currentErrorDisplayer(
MACHINE, $(plt.helpers.toDomNode(e.stack || e)).css('color', 'red'));
})},
function() {
// On module loading failure

226
js-assembler/runtime-src/helpers.js
View File

@ -549,8 +549,8 @@ if (! this['plt']) { this['plt'] = {}; }
var makeLowLevelEqHash = function() {
return new _Hashtable(function(x) { return getEqHashCode(x); },
function(x, y) { return x === y; });
return new Hashtable(function(x) { return getEqHashCode(x); },
function(x, y) { return x === y; });
};
@ -570,14 +570,15 @@ if (! this['plt']) { this['plt'] = {}; }
if (! cache) {
cache = makeLowLevelEqHash();
}
if (x === null) {
return "null";
}
if (typeof(x) === 'object') {
if (cache.containsKey(x)) {
return "...";
}
}
if (x == undefined || x == null) {
if (x == undefined) {
return "#<undefined>";
}
if (typeof(x) == 'string') {
@ -606,12 +607,14 @@ if (! this['plt']) { this['plt'] = {}; }
if (! cache) {
cache = makeLowLevelEqHash();
}
if (x === null) {
return "null";
}
if (typeof(x) === 'object') {
if (cache.containsKey(x)) {
return "...";
}
}
if (x == undefined || x == null) {
return "#<undefined>";
}
@ -635,24 +638,74 @@ if (! this['plt']) { this['plt'] = {}; }
};
// toDomNode: scheme-value -> dom-node
var toDomNode = function(x, cache) {
if (! cache) {
cache = makeLowLevelEqHash();
var ToDomNodeParameters = function(params) {
if (! params) { params = {}; }
this.cache = makeLowLevelEqHash();
for (var k in params) {
if (params.hasOwnProperty(k)) {
this[k] = params[k];
}
}
this.objectCounter = 0;
};
// getMode: -> (U "print" "display" "write")
ToDomNodeParameters.prototype.getMode = function() {
if (this.mode) {
return this.mode;
}
return 'print';
};
ToDomNodeParameters.prototype.containsKey = function(x) {
return this.cache.containsKey(x);
};
ToDomNodeParameters.prototype.get = function(x) {
return this.cache.get(x);
};
ToDomNodeParameters.prototype.remove = function(x) {
return this.cache.remove(x);
};
ToDomNodeParameters.prototype.put = function(x) {
this.objectCounter++;
return this.cache.put(x, this.objectCounter);
};
// toDomNode: scheme-value -> dom-node
var toDomNode = function(x, params) {
if (params === 'write') {
params = new ToDomNodeParameters({'mode' : 'write'});
} else if (params === 'print') {
params = new ToDomNodeParameters({'mode' : 'print'});
} else if (params === 'display') {
params = new ToDomNodeParameters({'mode' : 'display'});
} else {
params = params || new ToDomNodeParameters({'mode' : 'display'});
}
if (jsnums.isSchemeNumber(x)) {
return numberToDomNode(x);
return numberToDomNode(x, params);
}
if (x === null) {
var node = document.createElement("span");
node.appendChild(document.createTextNode("null"));
return node;
}
if (typeof(x) == 'object') {
if (cache.containsKey(x)) {
if (params.containsKey(x)) {
var node = document.createElement("span");
node.appendChild(document.createTextNode("..."));
node.appendChild(document.createTextNode("#" + params.get(x)));
return node;
}
}
if (x == undefined || x == null) {
var node = document.createElement("span");
node.appendChild(document.createTextNode("#<undefined>"));
@ -661,11 +714,17 @@ if (! this['plt']) { this['plt'] = {}; }
if (typeof(x) == 'string') {
var wrapper = document.createElement("span");
wrapper.style["white-space"] = "pre";
var node = document.createTextNode(toWrittenString(x));
wrapper.style["white-space"] = "pre";
var node;
if (params.getMode() === 'write' || params.getMode() === 'print') {
node = document.createTextNode(toWrittenString(x));
} else {
node = document.createTextNode(toDisplayedString(x));
}
wrapper.appendChild(node);
return wrapper;
}
if (typeof(x) != 'object' && typeof(x) != 'function') {
var node = document.createElement("span");
node.appendChild(document.createTextNode(x.toString()));
@ -676,22 +735,23 @@ if (! this['plt']) { this['plt'] = {}; }
if (x.nodeType) {
returnVal = x;
} else if (typeof(x.toDomNode) !== 'undefined') {
returnVal = x.toDomNode(cache);
} else if (typeof(x.toWrittenString) !== 'undefined') {
returnVal = x.toDomNode(params);
} else if (params.getMode() === 'write' &&
typeof(x.toWrittenString) !== 'undefined') {
var node = document.createElement("span");
node.appendChild(document.createTextNode(x.toWrittenString(cache)));
node.appendChild(document.createTextNode(x.toWrittenString(params)));
returnVal = node;
} else if (typeof(x.toDisplayedString) !== 'undefined') {
} else if (params.getMode() === 'display' &&
typeof(x.toDisplayedString) !== 'undefined') {
var node = document.createElement("span");
node.appendChild(document.createTextNode(x.toDisplayedString(cache)));
node.appendChild(document.createTextNode(x.toDisplayedString(params)));
returnVal = node;
} else {
var node = document.createElement("span");
node.appendChild(document.createTextNode(x.toString()));
returnVal = node;
}
cache.remove(x);
params.remove(x);
return returnVal;
};
@ -699,7 +759,7 @@ if (! this['plt']) { this['plt'] = {}; }
// numberToDomNode: jsnum -> dom
// Given a jsnum, produces a dom-node representation.
var numberToDomNode = function(n) {
var numberToDomNode = function(n, params) {
var node;
if (jsnums.isExact(n)) {
if (jsnums.isInteger(n)) {
@ -726,16 +786,49 @@ if (! this['plt']) { this['plt'] = {}; }
// rationalToDomNode: rational -> dom-node
var rationalToDomNode = function(n) {
var node = document.createElement("span");
var repeatingDecimalNode = document.createElement("span");
var chunks = jsnums.toRepeatingDecimal(jsnums.numerator(n),
jsnums.denominator(n));
node.appendChild(document.createTextNode(chunks[0] + '.'))
node.appendChild(document.createTextNode(chunks[1]));
var overlineSpan = document.createElement("span");
overlineSpan.style.textDecoration = 'overline';
overlineSpan.appendChild(document.createTextNode(chunks[2]));
node.appendChild(overlineSpan);
return node;
jsnums.denominator(n),
{limit: 25});
repeatingDecimalNode.appendChild(document.createTextNode(chunks[0] + '.'))
repeatingDecimalNode.appendChild(document.createTextNode(chunks[1]));
if (chunks[2] === '...') {
repeatingDecimalNode.appendChild(
document.createTextNode(chunks[2]));
} else if (chunks[2] !== '0') {
var overlineSpan = document.createElement("span");
overlineSpan.style.textDecoration = 'overline';
overlineSpan.appendChild(document.createTextNode(chunks[2]));
repeatingDecimalNode.appendChild(overlineSpan);
}
var fractionalNode = document.createElement("span");
var numeratorNode = document.createElement("sup");
numeratorNode.appendChild(document.createTextNode(String(jsnums.numerator(n))));
var denominatorNode = document.createElement("sub");
denominatorNode.appendChild(document.createTextNode(String(jsnums.denominator(n))));
fractionalNode.appendChild(numeratorNode);
fractionalNode.appendChild(document.createTextNode("/"));
fractionalNode.appendChild(denominatorNode);
var numberNode = document.createElement("span");
numberNode.appendChild(repeatingDecimalNode);
numberNode.appendChild(fractionalNode);
fractionalNode.style['display'] = 'none';
var showingRepeating = true;
numberNode.onclick = function(e) {
showingRepeating = !showingRepeating;
repeatingDecimalNode.style['display'] =
(showingRepeating ? 'inline' : 'none')
fractionalNode.style['display'] =
(!showingRepeating ? 'inline' : 'none')
};
numberNode.style['cursor'] = 'pointer';
return numberNode;
}
@ -743,6 +836,62 @@ if (! this['plt']) { this['plt'] = {}; }
var escapeString = function(s) {
return '"' + replaceUnprintableStringChars(s) + '"';
};
var replaceUnprintableStringChars = function(s) {
var ret = [];
for (var i = 0; i < s.length; i++) {
var val = s.charCodeAt(i);
switch(val) {
case 7: ret.push('\\a'); break;
case 8: ret.push('\\b'); break;
case 9: ret.push('\\t'); break;
case 10: ret.push('\\n'); break;
case 11: ret.push('\\v'); break;
case 12: ret.push('\\f'); break;
case 13: ret.push('\\r'); break;
case 34: ret.push('\\"'); break;
case 92: ret.push('\\\\'); break;
default: if (val >= 32 && val <= 126) {
ret.push( s.charAt(i) );
}
else {
var numStr = val.toString(16).toUpperCase();
while (numStr.length < 4) {
numStr = '0' + numStr;
}
ret.push('\\u' + numStr);
}
break;
}
}
return ret.join('');
};
// clone: object -> object
// Copies an object. The new object should respond like the old
// object, including to things like instanceof
var clone = function(obj) {
var C = function() {}
C.prototype = obj;
var c = new C();
for (property in obj) {
if (obj.hasOwnProperty(property)) {
c[property] = obj[property];
}
}
return c;
};
@ -783,15 +932,16 @@ if (! this['plt']) { this['plt'] = {}; }
helpers.makeLowLevelEqHash = makeLowLevelEqHash;
helpers.heir = heir;
helpers.escapeString = escapeString;
helpers.toWrittenString = toWrittenString;
helpers.toDisplayedString = toDisplayedString;
helpers.toDomNode = toDomNode;
helpers.toDomNode = toDomNode;
helpers.ToDomNodeParameters = ToDomNodeParameters;
helpers.clone = clone;
scope.link.announceReady('helpers');
})(this['plt']);

238
js-assembler/runtime-src/primitives.js
View File

@ -195,7 +195,7 @@ That way, we can do a simple grep.
var length = function(lst) {
checkList(lst, 'length', 1, [lst]);
var ret = 0;
for (; !lst.isEmpty(); lst = lst.rest()) {
for (; !lst.isEmpty(); lst = lst.rest) {
ret = ret+1;
}
return ret;
@ -224,8 +224,8 @@ That way, we can do a simple grep.
var fArgs = [];
var argsRest = [];
for (var i = 0; i < args.length; i++) {
fArgs.push(args[i].first());
argsRest.push(args[i].rest());
fArgs.push(args[i].first);
argsRest.push(args[i].rest);
}
fArgs.push(acc);
return CALL(f, fArgs,
@ -246,20 +246,20 @@ That way, we can do a simple grep.
}
var compYes = new PrimProc('compYes', 1, false, false,
function(x) { return CALL(comp, [x, lst.first()], id); });
function(x) { return CALL(comp, [x, lst.first], id); });
var compNo = new PrimProc('compNo', 1, false, false,
function(x) { return CALL(comp, [x, lst.first()],
function(x) { return CALL(comp, [x, lst.first],
function(res) { return !res; });
});
return CALL(PRIMITIVES['filter'],
[compYes, lst.rest()],
[compYes, lst.rest],
quicksortHelp(function(sorted1) {
return CALL(PRIMITIVES['filter'],
[compNo, lst.rest()],
[compNo, lst.rest],
quicksortHelp(function(sorted2) {
return k( append([sorted1,
types.list([lst.first()]),
types.list([lst.first]),
sorted2]) );
}));
}));
@ -487,7 +487,7 @@ That way, we can do a simple grep.
var isAssocList = function(x) {
return isPair(x) && isPair(x.rest()) && isEmpty(x.rest().rest());
return isPair(x) && isPair(x.rest) && isEmpty(x.rest.rest);
};
@ -725,8 +725,8 @@ That way, we can do a simple grep.
var argsFirst = [];
var argsRest = [];
for (var i = 0; i < args.length; i++) {
argsFirst.push(args[i].first());
argsRest.push(args[i].rest());
argsFirst.push(args[i].first);
argsRest.push(args[i].rest);
}
return CALL(f, argsFirst,
@ -1109,11 +1109,11 @@ That way, we can do a simple grep.
return CALL(new PrimProc('', 1, false, false,
function(args) {
return callWithValues(fList.first(), args);
return callWithValues(fList.first, args);
}),
[x],
function(result) {
return composeHelp(result, fList.rest());
return composeHelp(result, fList.rest);
});
}
return new PrimProc('', 0, true, false,
@ -2032,9 +2032,9 @@ That way, we can do a simple grep.
var nextResult = parse(child);
if (isString(nextResult) &&
!result.isEmpty() &&
isString(result.first())) {
result = types.cons(result.first() + nextResult,
result.rest());
isString(result.first)) {
result = types.cons(result.first + nextResult,
result.rest);
} else {
result = types.cons(nextResult, result);
}
@ -2219,7 +2219,7 @@ That way, we can do a simple grep.
false, false,
function(lst) {
check(lst, isPair, 'car', 'pair', 1);
return lst.first();
return lst.first;
});
PRIMITIVES['cdr'] =
@ -2228,7 +2228,7 @@ That way, we can do a simple grep.
false, false,
function (lst) {
check(lst, isPair, 'cdr', 'pair', 1);
return lst.rest();
return lst.rest;
});
PRIMITIVES['caar'] =
@ -2236,9 +2236,9 @@ That way, we can do a simple grep.
1,
false, false,
function(lst) {
check(lst, function(x) { return (isPair(x) && isPair(x.first())); },
check(lst, function(x) { return (isPair(x) && isPair(x.first)); },
'caar', 'caarable value', 1);
return lst.first().first();
return lst.first.first;
});
PRIMITIVES['cadr'] =
@ -2246,9 +2246,9 @@ That way, we can do a simple grep.
1,
false, false,
function(lst) {
check(lst, function(x) { return isPair(x) && isPair(x.rest()); },
check(lst, function(x) { return isPair(x) && isPair(x.rest); },
'cadr', 'cadrable value', 1);
return lst.rest().first();
return lst.rest.first;
});
PRIMITIVES['cdar'] =
@ -2256,9 +2256,9 @@ That way, we can do a simple grep.
1,
false, false,
function(lst) {
check(lst, function(x) { return isPair(x) && isPair(x.first()); },
check(lst, function(x) { return isPair(x) && isPair(x.first); },
'cdar', 'cdarable value', 1);
return lst.first().rest();
return lst.first.rest;
});
PRIMITIVES['cddr'] =
@ -2266,9 +2266,9 @@ That way, we can do a simple grep.
1,
false, false,
function(lst) {
check(lst, function(x) { return isPair(x) && isPair(x.rest()); },
check(lst, function(x) { return isPair(x) && isPair(x.rest); },
'cddr', 'cddrable value', 1);
return lst.rest().rest();
return lst.rest.rest;
});
PRIMITIVES['caaar'] =
@ -2277,10 +2277,10 @@ That way, we can do a simple grep.
false, false,
function(lst) {
check(lst, function(x) { return ( isPair(x) &&
isPair(x.first()) &&
isPair(x.first().first()) ); },
isPair(x.first) &&
isPair(x.first.first) ); },
'caaar', 'caaarable value', 1);
return lst.first().first().first();
return lst.first.first.first;
});
PRIMITIVES['caadr'] =
@ -2289,10 +2289,10 @@ That way, we can do a simple grep.
false, false,
function(lst) {
check(lst, function(x) { return ( isPair(x) &&
isPair(x.rest()) &&
isPair(x.rest().first()) ); },
isPair(x.rest) &&
isPair(x.rest.first) ); },
'caadr', 'caadrable value', 1);
return lst.rest().first().first();
return lst.rest.first.first;
});
PRIMITIVES['cadar'] =
@ -2301,10 +2301,10 @@ That way, we can do a simple grep.
false, false,
function(lst) {
check(lst, function(x) { return ( isPair(x) &&
isPair(x.first()) &&
isPair(x.first().rest()) ); },
isPair(x.first) &&
isPair(x.first.rest) ); },
'cadar', 'cadarable value', 1);
return lst.first().rest().first();
return lst.first.rest.first;
});
PRIMITIVES['cdaar'] =
@ -2313,10 +2313,10 @@ That way, we can do a simple grep.
false, false,
function(lst) {
check(lst, function(x) { return ( isPair(x) &&
isPair(x.first()) &&
isPair(x.first().first()) ); },
isPair(x.first) &&
isPair(x.first.first) ); },
'cdaar', 'cdaarable value', 1);
return lst.first().first().rest();
return lst.first.first.rest;
});
PRIMITIVES['cdadr'] =
@ -2325,10 +2325,10 @@ That way, we can do a simple grep.
false, false,
function(lst) {
check(lst, function(x) { return ( isPair(x) &&
isPair(x.rest()) &&
isPair(x.rest().first()) ); },
isPair(x.rest) &&
isPair(x.rest.first) ); },
'cdadr', 'cdadrable value', 1);
return lst.rest().first().rest();
return lst.rest.first.rest;
});
PRIMITIVES['cddar'] =
@ -2337,10 +2337,10 @@ That way, we can do a simple grep.
false, false,
function(lst) {
check(lst, function(x) { return ( isPair(x) &&
isPair(x.first()) &&
isPair(x.first().rest()) ); },
isPair(x.first) &&
isPair(x.first.rest) ); },
'cddar', 'cddarable value', 1);
return lst.first().rest().rest();
return lst.first.rest.rest;
});
PRIMITIVES['caddr'] =
@ -2349,10 +2349,10 @@ That way, we can do a simple grep.
false, false,
function(lst) {
check(lst, function(x) { return ( isPair(x) &&
isPair(x.rest()) &&
isPair(x.rest().rest()) ); },
isPair(x.rest) &&
isPair(x.rest.rest) ); },
'caddr', 'caddrable value', 1);
return lst.rest().rest().first();
return lst.rest.rest.first;
});
PRIMITIVES['cdddr'] =
@ -2361,10 +2361,10 @@ That way, we can do a simple grep.
false, false,
function(lst) {
check(lst, function(x) { return ( isPair(x) &&
isPair(x.rest()) &&
isPair(x.rest().rest()) ); },
isPair(x.rest) &&
isPair(x.rest.rest) ); },
'cdddr', 'cdddrable value', 1);
return lst.rest().rest().rest();
return lst.rest.rest.rest;
});
PRIMITIVES['cadddr'] =
@ -2373,11 +2373,11 @@ That way, we can do a simple grep.
false, false,
function(lst) {
check(lst, function(x) { return ( isPair(x) &&
isPair(x.rest()) &&
isPair(x.rest().rest()) &&
isPair(x.rest().rest().rest()) ); },
isPair(x.rest) &&
isPair(x.rest.rest) &&
isPair(x.rest.rest.rest) ); },
'cadddr', 'cadddrable value', 1);
return lst.rest().rest().rest().first();
return lst.rest.rest.rest.first;
});
@ -2388,7 +2388,7 @@ That way, we can do a simple grep.
function(lst) {
check(lst, function(x) { return isList(x) && !isEmpty(x); },
'rest', 'non-empty list', 1);
return lst.rest();
return lst.rest;
});
PRIMITIVES['first'] =
@ -2398,7 +2398,7 @@ That way, we can do a simple grep.
function(lst) {
check(lst, function(x) { return isList(x) && !isEmpty(x); },
'first', 'non-empty list', 1);
return lst.first();
return lst.first;
});
PRIMITIVES['second'] =
@ -2407,7 +2407,7 @@ That way, we can do a simple grep.
false, false,
function(lst) {
checkListOfLength(lst, 2, 'second', 1);
return lst.rest().first();
return lst.rest.first;
});
PRIMITIVES['third'] =
@ -2416,7 +2416,7 @@ That way, we can do a simple grep.
false, false,
function(lst) {
checkListOfLength(lst, 3, 'third', 1);
return lst.rest().rest().first();
return lst.rest.rest.first;
});
PRIMITIVES['fourth'] =
@ -2425,7 +2425,7 @@ That way, we can do a simple grep.
false, false,
function(lst) {
checkListOfLength(lst, 4, 'fourth', 1);
return lst.rest().rest().rest().first();
return lst.rest.rest.rest.first;
});
PRIMITIVES['fifth'] =
@ -2434,7 +2434,7 @@ That way, we can do a simple grep.
false, false,
function(lst) {
checkListOfLength(lst, 5, 'fifth', 1);
return lst.rest().rest().rest().rest().first();
return lst.rest.rest.rest.rest.first;
});
PRIMITIVES['sixth'] =
@ -2443,7 +2443,7 @@ That way, we can do a simple grep.
false, false,
function(lst) {
checkListOfLength(lst, 6, 'sixth', 1);
return lst.rest().rest().rest().rest().rest().first();
return lst.rest.rest.rest.rest.rest.first;
});
PRIMITIVES['seventh'] =
@ -2453,7 +2453,7 @@ That way, we can do a simple grep.
false, false,
function(lst) {
checkListOfLength(lst, 7, 'seventh', 1);
return lst.rest().rest().rest().rest().rest().rest().first();
return lst.rest.rest.rest.rest.rest.rest.first;
});
PRIMITIVES['eighth'] =
@ -2462,7 +2462,7 @@ That way, we can do a simple grep.
false, false,
function(lst) {
checkListOfLength(lst, 8, 'eighth', 1);
return lst.rest().rest().rest().rest().rest().rest().rest().first();
return lst.rest.rest.rest.rest.rest.rest.rest.first;
});
@ -2536,7 +2536,7 @@ That way, we can do a simple grep.
helpers.toDisplayedString(origList));
raise( types.incompleteExn(types.exnFailContract, msg, []) );
}
lst = lst.rest();
lst = lst.rest;
}
@ -2548,7 +2548,7 @@ That way, we can do a simple grep.
msg,
[]) );
}
return lst.first();
return lst.first;
});
PRIMITIVES['list-tail'] =
@ -2578,7 +2578,7 @@ That way, we can do a simple grep.
helpers.toDisplayedString(origList));
raise( types.incompleteExn(types.exnFailContract, msg, []) );
}
lst = lst.rest();
lst = lst.rest;
}
return lst;
});
@ -2622,8 +2622,8 @@ That way, we can do a simple grep.
var argsFirst = [];
var argsRest = [];
for (var i = 0; i < args.length; i++) {
argsFirst.push(args[i].first());
argsRest.push(args[i].rest());
argsFirst.push(args[i].first);
argsRest.push(args[i].rest);
}
var result = CALL(f, argsFirst,
function(result) {
@ -2658,8 +2658,8 @@ That way, we can do a simple grep.
var argsFirst = [];
var argsRest = [];
for (var i = 0; i < args.length; i++) {
argsFirst.push(args[i].first());
argsRest.push(args[i].rest());
argsFirst.push(args[i].first);
argsRest.push(args[i].rest);
}
return CALL(f, argsFirst,
@ -2699,8 +2699,8 @@ That way, we can do a simple grep.
var argsFirst = [];
var argsRest = [];
for (var i = 0; i < args.length; i++) {
argsFirst.push(args[i].first());
argsRest.push(args[i].rest());
argsFirst.push(args[i].first);
argsRest.push(args[i].rest);
}
return CALL(f, argsFirst,
@ -2734,10 +2734,10 @@ That way, we can do a simple grep.
}
while ( !lst.isEmpty() ) {
if ( isEq(item, lst.first()) ) {
if ( isEq(item, lst.first) ) {
return lst;
}
lst = lst.rest();
lst = lst.rest;
if (! isPair(lst) && lst !== types.EMPTY) {
var msg = ('memq: not a proper list: ' +
helpers.toDisplayedString(origList));
@ -2764,10 +2764,10 @@ That way, we can do a simple grep.
[]) );
}
while ( !lst.isEmpty() ) {
if ( isEqv(item, lst.first()) ) {
if ( isEqv(item, lst.first) ) {
return lst;
}
lst = lst.rest();
lst = lst.rest;
if (! isPair(lst) && lst !== types.EMPTY) {
var msg = ('memv: not a proper list: ' +
helpers.toDisplayedString(origList));
@ -2795,10 +2795,10 @@ That way, we can do a simple grep.
[]) );
}
while ( !lst.isEmpty() ) {
if ( isEqual(item, lst.first()) ) {
if ( isEqual(item, lst.first) ) {
return lst;
}
lst = lst.rest();
lst = lst.rest;
if (! isPair(lst) && lst !== types.EMPTY) {
var msg = ('member: not a proper list: ' +
@ -2825,12 +2825,12 @@ That way, we can do a simple grep.
return false;
}
return CALL(f, [lst.first()],
return CALL(f, [lst.first],
function(result) {
if (result) {
return lst;
}
return memfHelp(lst.rest());
return memfHelp(lst.rest);
});
}
return memfHelp(initList);
@ -2852,18 +2852,18 @@ That way, we can do a simple grep.
[]) );
}
while ( !lst.isEmpty() ) {
if (! isPair(lst.first())) {
if (! isPair(lst.first)) {
var msg = ('assq: non-pair found in list: ' +
helpers.toDisplayedString(lst.first()) +' in ' +
helpers.toDisplayedString(lst.first) +' in ' +
helpers.toDisplayedString(origList));
raise( types.incompleteExn(types.exnFailContract,
msg,
[]) );
}
if ( isEq(item, lst.first().first()) ) {
return lst.first();
if ( isEq(item, lst.first.first) ) {
return lst.first;
}
lst = lst.rest();
lst = lst.rest;
if (! isPair(lst) && lst !== types.EMPTY) {
var msg = ('assq: not a proper list: ' +
@ -2892,18 +2892,18 @@ That way, we can do a simple grep.
[]) );
}
while ( !lst.isEmpty() ) {
if (! isPair(lst.first())) {
if (! isPair(lst.first)) {
var msg = ('assv: non-pair found in list: ' +
helpers.toDisplayedString(lst.first()) +' in ' +
helpers.toDisplayedString(lst.first) +' in ' +
helpers.toDisplayedString(origList));
raise( types.incompleteExn(types.exnFailContract,
msg,
[]) );
}
if ( isEqv(item, lst.first().first()) ) {
return lst.first();
if ( isEqv(item, lst.first.first) ) {
return lst.first;
}
lst = lst.rest();
lst = lst.rest;
if (! isPair(lst) && lst !== types.EMPTY) {
var msg = ('assv: not a proper list: ' +
helpers.toDisplayedString(origList));
@ -2931,18 +2931,18 @@ That way, we can do a simple grep.
[]) );
}
while ( !lst.isEmpty() ) {
if (! isPair(lst.first())) {
if (! isPair(lst.first)) {
var msg = ('assoc: non-pair found in list: ' +
helpers.toDisplayedString(lst.first()) +' in ' +
helpers.toDisplayedString(lst.first) +' in ' +
helpers.toDisplayedString(origList));
raise( types.incompleteExn(types.exnFailContract,
msg,
[]) );
}
if ( isEqual(item, lst.first().first()) ) {
return lst.first();
if ( isEqual(item, lst.first.first) ) {
return lst.first;
}
lst = lst.rest();
lst = lst.rest;
if (! isPair(lst) && lst !== types.EMPTY) {
var msg = ('assoc: not a proper list: ' +
@ -2965,11 +2965,11 @@ That way, we can do a simple grep.
var originalLst = lst;
var result = types.EMPTY;
while ( !lst.isEmpty() ) {
if ( isEqual(item, lst.first()) ) {
return append([result.reverse(), lst.rest()]);
if ( isEqual(item, lst.first) ) {
return append([result.reverse(), lst.rest]);
} else {
result = types.cons(lst.first(), result);
lst = lst.rest();
result = types.cons(lst.first, result);
lst = lst.rest;
}
}
return originalLst;
@ -2989,14 +2989,14 @@ That way, we can do a simple grep.
return acc.reverse();
}
return CALL(f, [lst.first()],
return CALL(f, [lst.first],
function(result) {
if (result) {
return filterHelp(f, lst.rest(),
types.cons(lst.first(), acc));
return filterHelp(f, lst.rest,
types.cons(lst.first, acc));
}
else {
return filterHelp(f, lst.rest(), acc);
return filterHelp(f, lst.rest, acc);
}
});
}
@ -3055,22 +3055,22 @@ That way, we can do a simple grep.
return curMaxElt;
}
return CALL(f, [lst.first()],
return CALL(f, [lst.first],
function(result) {
check(result, isReal, 'argmax',
'procedure that returns real numbers', 1, args);
if (jsnums.greaterThan(result, curMaxVal)) {
return argmaxHelp(lst.rest(), result, lst.first());
return argmaxHelp(lst.rest, result, lst.first);
}
else {
return argmaxHelp(lst.rest(), curMaxVal, curMaxElt);
return argmaxHelp(lst.rest, curMaxVal, curMaxElt);
}
});
}
return CALL(f, [initList.first()],
return CALL(f, [initList.first],
function(result) {
check(result, isReal, 'argmax', 'procedure that returns real numbers', 1, args);
return argmaxHelp(initList.rest(), result, initList.first());
return argmaxHelp(initList.rest, result, initList.first);
});
});
@ -3089,22 +3089,22 @@ That way, we can do a simple grep.
return curMaxElt;
}
return CALL(f, [lst.first()],
return CALL(f, [lst.first],
function(result) {
check(result, isReal, 'argmin',
'procedure that returns real numbers', 1, args);
if (jsnums.lessThan(result, curMaxVal)) {
return argminHelp(lst.rest(), result, lst.first());
return argminHelp(lst.rest, result, lst.first);
}
else {
return argminHelp(lst.rest(), curMaxVal, curMaxElt);
return argminHelp(lst.rest, curMaxVal, curMaxElt);
}
});
}
return CALL(f, [initList.first()],
return CALL(f, [initList.first],
function(result) {
check(result, isReal, 'argmin', 'procedure that returns real numbers', 1, args);
return argminHelp(initList.rest(), result, initList.first());
return argminHelp(initList.rest, result, initList.first);
});
});
@ -3614,8 +3614,8 @@ That way, we can do a simple grep.
var ret = [];
while( !lst.isEmpty() ) {
ret.push(lst.first().val);
lst = lst.rest();
ret.push(lst.first.val);
lst = lst.rest;
}
return types.string(ret);
});
@ -3728,8 +3728,8 @@ That way, we can do a simple grep.
'implode', 'list of 1-letter strings', 1);
var ret = [];
while ( !lst.isEmpty() ) {
ret.push( lst.first().toString() );
lst = lst.rest();
ret.push( lst.first.toString() );
lst = lst.rest;
}
return types.string(ret);
});
@ -4139,8 +4139,8 @@ That way, we can do a simple grep.
var ret = [];
while ( !lst.isEmpty() ) {
ret.push(lst.first());
lst = lst.rest();
ret.push(lst.first);
lst = lst.rest;
}
return types.bytes(ret, true);
});

507
js-assembler/runtime-src/runtime.js
View File

@ -8,16 +8,10 @@ if(this['plt'] === undefined) { this['plt'] = {}; }
var runtime = {};
scope['runtime'] = runtime;
var helpers = plt.helpers;
var types = plt.types;
// Type helpers
//
// Defines inheritance between prototypes.
var heir = function(parentPrototype) {
var f = function() {}
f.prototype = parentPrototype;
return new f();
};
// Consumes a class and creates a predicate that recognizes subclasses.
var makeClassPredicate = function(aClass) {
@ -25,27 +19,35 @@ if(this['plt'] === undefined) { this['plt'] = {}; }
};
var isNumber = jsnums.isSchemeNumber;
var isNatural = function(x) { return (jsnums.isInteger(x) &&
jsnums.greaterThanOrEqual(x, 0)); }
var isPair = function(x) { return (typeof(x) == 'object' &&
x.length === 2 &&
x.type !== 'vector') };
var isList = function(x) {
while (x !== NULL) {
if (typeof(x) == 'object' && x.length === 2) {
x = x[1];
} else {
return false;
}
}
return true;
};
var isVector = function(x) { return (typeof(x) == 'object' &&
x.type === 'vector') };
//////////////////////////////////////////////////////////////////////
//////////////////////////////////////////////////////////////////////
// We try to isolate the effect of external modules: all the identifiers we
// pull from external modules should be listed here, and should otherwise not
// show up outside this section!
var isNumber = types.isNumber;
var isNatural = types.isNatural;
var isPair = types.isPair;
var isList = types.isList;
var isVector = types.isVector;
var NULL = types.EMPTY;
var VOID = types.VOID;
var makeVector = types.vector;
var makeList = types.list;
var makePair = types.pair;
var heir = helpers.heir;
var toDomNode = helpers.toDomNode;
var toWrittenString = helpers.toWrittenString;
var toDisplayedString = helpers.toDisplayedString;
//////////////////////////////////////////////////////////////////////]
// This value will be dynamically determined.
@ -67,13 +69,25 @@ if(this['plt'] === undefined) { this['plt'] = {}; }
// currentDisplayer: DomNode -> Void
// currentDisplayer is responsible for displaying to the browser.
'currentDisplayer': function(v) {
$(document.body).append(v);
'currentDisplayer': function(MACHINE, domNode) {
$(domNode).appendTo(document.body);
},
// currentErrorDisplayer: DomNode -> Void
// currentErrorDisplayer is responsible for displaying errors to the browser.
'currentErrorDisplayer': function(MACHINE, domNode) {
$(domNode).appendTo(document.body);
},
'currentOutputPort': new StandardOutputPort(),
'currentErrorPort': new StandardErrorPort(),
'currentSuccessHandler': function(MACHINE) {},
'currentErrorHandler': function(MACHINE, exn) {},
'currentErrorHandler': function(MACHINE, exn) {
MACHINE.params.currentErrorDisplayer(
MACHINE,
exn);
},
'currentNamespace': {},
@ -99,9 +113,9 @@ if(this['plt'] === undefined) { this['plt'] = {}; }
var elt = MACHINE.env.pop();
var outputPort =
MACHINE.params.currentOutputPort;
if (elt !== undefined) {
outputPort.write(MACHINE, elt);
outputPort.write(MACHINE, "\n");
if (elt !== VOID) {
outputPort.writeDomNode(MACHINE, toDomNode(elt, 'print'));
outputPort.writeDomNode(MACHINE, toDomNode("\n", 'display'));
}
var frame = MACHINE.control.pop();
return frame.label(MACHINE);
@ -166,6 +180,9 @@ if(this['plt'] === undefined) { this['plt'] = {}; }
};
// A generic frame just holds marks.
var Frame = function() {
// The set of continuation marks.
@ -218,31 +235,30 @@ if(this['plt'] === undefined) { this['plt'] = {}; }
// Output Ports
var OutputPort = function() {};
var isOutputPort = makeClassPredicate(OutputPort);
var StandardOutputPort = function() {};
StandardOutputPort.prototype = heir(OutputPort.prototype);
StandardOutputPort.prototype.write = function(MACHINE, v) {
var domNode;
// TODO: v must be coerced into a DOMNode in a more systematic way.
// This function may need to be a Closure.
if(typeof(v) === 'string' ||
typeof(v) === 'number' ||
typeof(v) === 'boolean' ||
typeof(v) === 'null' ||
typeof(v) === 'undefined') {
domNode = $('<span/>').text(String(v)).css('white-space', 'pre');
} else {
domNode = $('<span/>').text(String(v)).css('white-space', 'pre');
}
MACHINE.params['currentDisplayer'](domNode);
var StandardOutputPort = function() {
OutputPort.call(this);
};
StandardOutputPort.prototype = heir(OutputPort.prototype);
StandardOutputPort.prototype.writeDomNode = function(MACHINE, domNode) {
MACHINE.params['currentDisplayer'](MACHINE, domNode);
};
var StandardErrorPort = function() {
OutputPort.call(this);
};
StandardErrorPort.prototype = heir(OutputPort.prototype);
StandardErrorPort.prototype.writeDomNode = function(MACHINE, domNode) {
MACHINE.params['currentErrorDisplayer'](MACHINE, domNode);
};
@ -250,8 +266,8 @@ if(this['plt'] === undefined) { this['plt'] = {}; }
this.buf = [];
};
OutputStringPort.prototype = heir(OutputPort.prototype);
OutputStringPort.prototype.write = function(MACHINE, v) {
this.buf.push(String(v));
OutputStringPort.prototype.writeDomNode = function(MACHINE, v) {
this.buf.push($(v).text());
};
OutputStringPort.prototype.getOutputString = function() {
return this.buf.join('');
@ -310,7 +326,6 @@ if(this['plt'] === undefined) { this['plt'] = {}; }
new ContinuationPromptTag("default-continuation-prompt-tag");
var NULL = [];
var raise = function(MACHINE, e) {
@ -348,7 +363,7 @@ if(this['plt'] === undefined) { this['plt'] = {}; }
if (observed < minimum || observed > maximum) {
raise(MACHINE, new Error(callerName + ": expected at least " + minimum
+ " arguments "
+ " but received " + observer));
+ " but received " + observed));
}
};
@ -366,7 +381,7 @@ if(this['plt'] === undefined) { this['plt'] = {}; }
raise(MACHINE,
new Error(callerName + ": expected " + expectedTypeName
+ " as argument " + (argumentOffset + 1)
+ " but received " + actualValue));
+ " but received " + helpers.toWrittenString(actualValue)));
};
var raiseContextExpectedValuesError = function(MACHINE, expected) {
@ -378,23 +393,23 @@ if(this['plt'] === undefined) { this['plt'] = {}; }
var raiseArityMismatchError = function(MACHINE, proc, expected, received) {
raise(MACHINE,
new Error("expected " + expected + " values, received " + received + " values"));
new Error(proc.displayName + ": " + "expected " + expected
+ " value(s), received " + received + " value(s)"));
};
var raiseOperatorApplicationError = function(MACHINE, operator) {
raise(MACHINE,
new Error("not a procedure: " + expected +
operator));
new Error("not a procedure: " + helpers.toWrittenString(operator)));
};
var raiseOperatorIsNotClosure = function(MACHINE, operator) {
raise(MACHINE,
new Error("not a closure: " + operator));
new Error("not a closure: " + helpers.toWrittenString(operator)));
};
var raiseOperatorIsNotPrimitiveProcedure = function(MACHINE, operator) {
raise(MACHINE,
new Error("not a primitive procedure: " + operator));
new Error("not a primitive procedure: " + helpers.toWrittenString(operator)));
};
@ -448,8 +463,8 @@ if(this['plt'] === undefined) { this['plt'] = {}; }
var lst = MACHINE.env[MACHINE.env.length - 1 - depth];
var vals = [];
while(lst !== NULL) {
vals.push(lst[0]);
lst = lst[1];
vals.push(lst.first);
lst = lst.rest;
}
vals.reverse();
MACHINE.env.splice.apply(MACHINE.env,
@ -462,7 +477,8 @@ if(this['plt'] === undefined) { this['plt'] = {}; }
var lst = NULL;
var i;
for (i = 0; i < length; i++) {
lst = [MACHINE.env[MACHINE.env.length - depth - length + i], lst];
lst = makePair(MACHINE.env[MACHINE.env.length - depth - length + i],
lst);
}
MACHINE.env.splice(MACHINE.env.length - depth - length,
length,
@ -488,12 +504,12 @@ if(this['plt'] === undefined) { this['plt'] = {}; }
return n >= arity.value;
} else {
while (arity !== NULL) {
if (typeof(arity[0]) === 'number') {
if (arity[0] === n) { return true; }
if (typeof(arity.first) === 'number') {
if (arity.first === n) { return true; }
} else if (arity instanceof ArityAtLeast) {
if (n >= arity[0].value) { return true; }
if (n >= arity.first.value) { return true; }
}
arity = arity[1];
arity = arity.rest;
}
return false;
}
@ -508,129 +524,119 @@ if(this['plt'] === undefined) { this['plt'] = {}; }
// are coded here; several of them (including call/cc) are injected by
// the bootstrapping code.
var Primitives = {};
Primitives['display'] = function(MACHINE) {
var firstArg = MACHINE.env[MACHINE.env.length-1];
var outputPort = MACHINE.params.currentOutputPort;
if (MACHINE.argcount === 2) {
testArgument(MACHINE,
'isOutputPort',
isOutputPort,
MACHINE.env.length-2,
1,
'display');
outputPort = MACHINE.env[MACHINE.env.length-2];
}
outputPort.write(MACHINE, firstArg);
var installPrimitiveProcedure = function(name, arity, f) {
Primitives[name] = f;
Primitives[name].arity = arity;
Primitives[name].displayName = name;
};
Primitives['display'].arity = [1, [2, NULL]];
Primitives['display'].displayName = 'display';
Primitives['newline'] = function(MACHINE) {
var outputPort = MACHINE.params.currentOutputPort;
if (MACHINE.argcount === 1) {
testArgument(MACHINE,
'isOutputPort',
isOutputPort,
MACHINE.env.length-1,
1,
'newline');
outputPort = MACHINE.env[MACHINE.env.length-1];
}
outputPort.write(MACHINE, "\n");
var makePrimitiveProcedure = function(name, arity, f) {
f.arity = arity;
f.displayName = name;
return f;
};
Primitives['newline'].arity = [0, [1, NULL]];
Primitives['newline'].displayName = 'newline';
Primitives['displayln'] = function(MACHINE){
var firstArg = MACHINE.env[MACHINE.env.length-1];
var outputPort = MACHINE.params.currentOutputPort;
if (MACHINE.argcount === 2) {
testArgument(MACHINE,
'isOutputPort',
isOutputPort,
MACHINE.env.length-2,
1,
'displayln');
outputPort = MACHINE.env[MACHINE.env.length-2];
}
outputPort.write(MACHINE, firstArg);
outputPort.write(MACHINE, "\n");
var installPrimitiveConstant = function(name, v) {
Primitives[name] = v;
};
Primitives['displayln'].arity = [1, [2, NULL]];
Primitives['displayln'].displayName = 'displayln';
installPrimitiveConstant('pi', jsnums.pi);
installPrimitiveConstant('e', jsnums.e);
Primitives['current-print'] = function(MACHINE) {
return MACHINE.params['current-print'];
};
Primitives['current-print'].arity = [0, [1, NULL]];
Primitives['current-print'].displayName = "current-print";
// // This should be attached to the module corresponding for print-values
// Primitives['print-values'] = new Closure(
// function(MACHINE) {
// var outputPort = MACHINE.params.currentOutputPort;
// var prependNewline = false;
// if (MACHINE.argcount > 0) {
// if (MACHINE.val !== undefined) {
// if (prependNewline) {
// outputPort.write(MACHINE, "\n");
// }
// outputPort.write(MACHINE, MACHINE.val);
// prependNewline = true;
// }
// for(var i = 0; i < MACHINE.argcount - 1; i++) {
// if (MACHINE.env[MACHINE.env.length - 1 - i] !== undefined) {
// if (prependNewline) {
// outputPort.write(MACHINE, "\n");
// }
// outputPort.write(MACHINE,
// MACHINE.env[MACHINE.env.length - 1 - i]);
// prependNewline = true;
// }
// }
// outputPort.write(MACHINE, "\n");
// }
// MACHINE.env.length = MACHINE.env.length - MACHINE.argcount;
// var frame = MACHINE.control.pop();
// return frame.label(MACHINE);
// },
// new ArityAtLeast(0),
// [],
// "print-values"
// );
Primitives['pi'] = jsnums.pi;
Primitives['e'] = jsnums.e;
Primitives['='] = function(MACHINE) {
var firstArg = MACHINE.env[MACHINE.env.length-1];
testArgument(MACHINE, 'number', isNumber, firstArg, 0, '=');
for (var i = 0; i < MACHINE.argcount - 1; i++) {
testArgument(MACHINE,
'number',
isNumber,
MACHINE.env[MACHINE.env.length - 1 - i],
i,
'=');
if (! (jsnums.equals(MACHINE.env[MACHINE.env.length - 1 - i],
MACHINE.env[MACHINE.env.length - 1 - i - 1]))) {
return false;
installPrimitiveProcedure(
'display', makeList(1, 2),
function(MACHINE) {
var firstArg = MACHINE.env[MACHINE.env.length-1];
var outputPort = MACHINE.params.currentOutputPort;
if (MACHINE.argcount === 2) {
testArgument(MACHINE,
'isOutputPort',
isOutputPort,
MACHINE.env.length-2,
1,
'display');
outputPort = MACHINE.env[MACHINE.env.length-2];
}
}
return true;
};
Primitives['='].arity = new ArityAtLeast(2);
Primitives['='].displayName = '=';
outputPort.writeDomNode(MACHINE, toDomNode(firstArg, 'display'));
return VOID;
});
installPrimitiveProcedure(
'newline', makeList(0, 1),
function(MACHINE) {
var outputPort = MACHINE.params.currentOutputPort;
if (MACHINE.argcount === 1) {
testArgument(MACHINE,
'isOutputPort',
isOutputPort,
MACHINE.env.length-1,
1,
'newline');
outputPort = MACHINE.env[MACHINE.env.length-1];
}
outputPort.writeDomNode(MACHINE, toDomNode("\n", 'display'));
return VOID;
});
installPrimitiveProcedure(
'displayln',
makeList(1, 2),
function(MACHINE){
var firstArg = MACHINE.env[MACHINE.env.length-1];
var outputPort = MACHINE.params.currentOutputPort;
if (MACHINE.argcount === 2) {
testArgument(MACHINE,
'isOutputPort',
isOutputPort,
MACHINE.env.length-2,
1,
'displayln');
outputPort = MACHINE.env[MACHINE.env.length-2];
}
outputPort.writeDomNode(MACHINE, toDomNode(firstArg, 'display'));
outputPort.writeDomNode(MACHINE, toDomNode("\n", 'display'));
return VOID;
});
installPrimitiveProcedure(
'current-print',
makeList(0, 1),
function(MACHINE) {
if (MACHINE.argcount === 1) {
MACHINE.params['current-print'] = MACHINE.env[MACHINE.env.length - 1];
return VOID;
} else {
return MACHINE.params['current-print'];
}
});
installPrimitiveProcedure(
'=',
new ArityAtLeast(2),
function(MACHINE) {
var firstArg = MACHINE.env[MACHINE.env.length-1];
testArgument(MACHINE, 'number', isNumber, firstArg, 0, '=');
for (var i = 0; i < MACHINE.argcount - 1; i++) {
testArgument(MACHINE,
'number',
isNumber,
MACHINE.env[MACHINE.env.length - 1 - i],
i,
'=');
if (! (jsnums.equals(MACHINE.env[MACHINE.env.length - 1 - i],
MACHINE.env[MACHINE.env.length - 1 - i - 1]))) {
return false;
}
}
return true;
});
// TODO: use installPrimitiveProcedure for the rest...
Primitives['<'] = function(MACHINE) {
var firstArg = MACHINE.env[MACHINE.env.length-1];
@ -845,7 +851,7 @@ if(this['plt'] === undefined) { this['plt'] = {}; }
Primitives['cons'] = function(MACHINE) {
var firstArg = MACHINE.env[MACHINE.env.length-1];
var secondArg = MACHINE.env[MACHINE.env.length-2];
return [firstArg, secondArg];
return makePair(firstArg, secondArg);
};
Primitives['cons'].arity = 2;
Primitives['cons'].displayName = 'cons';
@ -854,8 +860,8 @@ if(this['plt'] === undefined) { this['plt'] = {}; }
Primitives['list'] = function(MACHINE) {
var result = NULL;
for (var i = 0; i < MACHINE.argcount; i++) {
result = [MACHINE.env[MACHINE.env.length - (MACHINE.argcount - i)],
result];
result = makePair(MACHINE.env[MACHINE.env.length - (MACHINE.argcount - i)],
result);
}
return result;
};
@ -870,7 +876,7 @@ if(this['plt'] === undefined) { this['plt'] = {}; }
0,
'car');
var firstArg = MACHINE.env[MACHINE.env.length-1];
return firstArg[0];
return firstArg.first;
};
Primitives['car'].arity = 1;
Primitives['car'].displayName = 'car';
@ -883,7 +889,7 @@ if(this['plt'] === undefined) { this['plt'] = {}; }
0,
'cdr');
var firstArg = MACHINE.env[MACHINE.env.length-1];
return firstArg[1];
return firstArg.rest;
};
Primitives['cdr'].arity = 1;
Primitives['cdr'].displayName = 'cdr';
@ -904,7 +910,8 @@ if(this['plt'] === undefined) { this['plt'] = {}; }
'set-car!');
var firstArg = MACHINE.env[MACHINE.env.length-1];
var secondArg = MACHINE.env[MACHINE.env.length-2];
firstArg[0] = secondArg;
firstArg.first = secondArg;
return VOID;
};
Primitives['set-car!'].arity = 2;
Primitives['set-car!'].displayName = 'set-car!';
@ -918,7 +925,8 @@ if(this['plt'] === undefined) { this['plt'] = {}; }
'set-cdr!');
var firstArg = MACHINE.env[MACHINE.env.length-1];
var secondArg = MACHINE.env[MACHINE.env.length-2];
firstArg[1] = secondArg;
firstArg.rest = secondArg;
return VOID;
};
Primitives['set-cdr!'].arity = 2;
Primitives['set-cdr!'].displayName = 'set-cdr!';
@ -945,8 +953,8 @@ if(this['plt'] === undefined) { this['plt'] = {}; }
for (i = 0; i < MACHINE.argcount; i++) {
result.push(MACHINE.env[MACHINE.env.length-1-i]);
}
result.type = 'vector';
return result;
var newVector = makeVector.apply(null, result);
return newVector;
};
Primitives['vector'].arity = new ArityAtLeast(0);
Primitives['vector'].displayName = 'vector';
@ -958,11 +966,11 @@ if(this['plt'] === undefined) { this['plt'] = {}; }
MACHINE.env[MACHINE.env.length - 1],
0,
'vector->list');
var firstArg = MACHINE.env[MACHINE.env.length-1];
var elts = MACHINE.env[MACHINE.env.length-1].elts;
var i;
var result = NULL;
for (i = 0; i < firstArg.length; i++) {
result = [firstArg[firstArg.length - 1 - i], result];
for (i = 0; i < elts.length; i++) {
result = makePair(elts[elts.length - 1 - i], result);
}
return result;
};
@ -973,11 +981,10 @@ if(this['plt'] === undefined) { this['plt'] = {}; }
var firstArg = MACHINE.env[MACHINE.env.length-1];
var result = [];
while (firstArg !== NULL) {
result.push(firstArg[0]);
firstArg = firstArg[1];
result.push(firstArg.first);
firstArg = firstArg.rest;
}
result.type='vector';
return result;
return makeVector.apply(null, result);
};
Primitives['list->vector'].arity = 1;
Primitives['list->vector'].displayName = 'list->vector';
@ -989,9 +996,9 @@ if(this['plt'] === undefined) { this['plt'] = {}; }
MACHINE.env[MACHINE.env.length - 1],
0,
'vector-ref');
var firstArg = MACHINE.env[MACHINE.env.length-1];
var secondArg = MACHINE.env[MACHINE.env.length-2];
return firstArg[secondArg];
var elts = MACHINE.env[MACHINE.env.length-1].elts;
var index = MACHINE.env[MACHINE.env.length-2];
return elts[index];
};
Primitives['vector-ref'].arity = 2;
Primitives['vector-ref'].displayName = 'vector-ref';
@ -1003,11 +1010,17 @@ if(this['plt'] === undefined) { this['plt'] = {}; }
MACHINE.env[MACHINE.env.length - 1],
0,
'vector-set!');
var firstArg = MACHINE.env[MACHINE.env.length-1];
var secondArg = jsnums.toFixnum(MACHINE.env[MACHINE.env.length-2]);
var thirdArg = MACHINE.env[MACHINE.env.length-3];
firstArg[secondArg] = thirdArg;
return null;
testArgument(MACHINE,
'natural',
isNatural,
MACHINE.env[MACHINE.env.length - 2],
1,
'vector-set!');
var elts = MACHINE.env[MACHINE.env.length-1].elts;
var index = jsnums.toFixnum(MACHINE.env[MACHINE.env.length-2]);
var val = MACHINE.env[MACHINE.env.length-3];
elts[index] = val;
return VOID;
};
Primitives['vector-set!'].arity = 3;
Primitives['vector-set!'].displayName = 'vector-set!';
@ -1020,7 +1033,7 @@ if(this['plt'] === undefined) { this['plt'] = {}; }
MACHINE.env[MACHINE.env.length - 1],
0,
'vector-length');
var firstArg = MACHINE.env[jsnums.toFixnum(MACHINE.env.length-1)];
var firstArg = MACHINE.env[MACHINE.env.length-1].elts;
return firstArg.length;
};
Primitives['vector-length'].arity = 1;
@ -1043,10 +1056,9 @@ if(this['plt'] === undefined) { this['plt'] = {}; }
for(var i = 0; i < length; i++) {
arr[i] = value;
}
arr.type='vector';
return arr;
return makeVector.apply(null, arr);
};
Primitives['make-vector'].arity = [1, [2, NULL]];
Primitives['make-vector'].arity = makeList(1, 2);
Primitives['make-vector'].displayName = 'make-vector';
@ -1104,13 +1116,13 @@ if(this['plt'] === undefined) { this['plt'] = {}; }
var firstArg = MACHINE.env[MACHINE.env.length-1];
var secondArg = MACHINE.env[MACHINE.env.length-2];
firstArg[0] = secondArg;
return;
return VOID;
};
Primitives['set-box!'].arity = 2;
Primitives['set-box!'].displayName = 'set-box!';
Primitives['void'] = function(MACHINE) {
return;
return VOID;
};
Primitives['void'].arity = new ArityAtLeast(0);
Primitives['void'].displayName = 'void';
@ -1132,27 +1144,7 @@ if(this['plt'] === undefined) { this['plt'] = {}; }
Primitives['equal?'].displayName = 'equal?';
var isEqual = function(firstArg, secondArg) {
var lset = [firstArg], rset = [secondArg];
while (lset.length !== 0 && rset.length !== 0) {
var lhs = lset.pop();
var rhs = rset.pop();
if (lhs === rhs) {
continue;
} else if (typeof(lhs) === 'object' &&
typeof(rhs) === 'object' &&
typeof(lhs.length) === 'number' &&
typeof(rhs.length) === 'number' &&
lhs.length === rhs.length) {
lset.push.apply(lset, lhs);
rset.push.apply(rset, rhs);
} else {
return false;
}
}
return true;
};
var isEqual = types.isEqual;
Primitives['member'] = function(MACHINE) {
@ -1168,10 +1160,10 @@ if(this['plt'] === undefined) { this['plt'] = {}; }
if (lst === NULL) {
return false;
}
if (isEqual(x, (lst[0]))) {
if (isEqual(x, (lst.first))) {
return lst;
}
lst = lst[1];
lst = lst.rest;
}
};
Primitives['member'].arity = 2;
@ -1185,8 +1177,8 @@ if(this['plt'] === undefined) { this['plt'] = {}; }
while(lst !== NULL) {
testArgument(MACHINE,
'pair', isPair, lst, 0, 'reverse');
rev = [lst[0], rev];
lst = lst[1];
rev = makePair(lst.first, rev);
lst = lst.rest;
}
return rev;
};
@ -1198,6 +1190,30 @@ if(this['plt'] === undefined) { this['plt'] = {}; }
// Extensions. A small experiment.
installPrimitiveProcedure(
'viewport-width',
0,
function(MACHINE) {
return $(window).width();
});
installPrimitiveProcedure(
'viewport-height',
0,
function(MACHINE) {
return $(window).height();
});
installPrimitiveProcedure(
'in-javascript-context?',
0,
function(MACHINE) {
return true;
});
// recomputeGas: state number -> number
@ -1379,6 +1395,10 @@ if(this['plt'] === undefined) { this['plt'] = {}; }
exports['currentMachine'] = new Machine();
exports['invokeMains'] = invokeMains;
// installing new primitives
exports['installPrimitiveProcedure'] = installPrimitiveProcedure;
exports['makePrimitiveProcedure'] = makePrimitiveProcedure;
exports['Primitives'] = Primitives;
exports['ready'] = ready;
@ -1398,6 +1418,7 @@ if(this['plt'] === undefined) { this['plt'] = {}; }
exports['DEFAULT_CONTINUATION_PROMPT_TAG'] =
DEFAULT_CONTINUATION_PROMPT_TAG;
exports['NULL'] = NULL;
exports['VOID'] = VOID;
exports['testArgument'] = testArgument;
exports['testArity'] = testArity;
@ -1423,6 +1444,7 @@ if(this['plt'] === undefined) { this['plt'] = {}; }
exports['unspliceRestFromStack'] = unspliceRestFromStack;
// Type predicates
exports['isNumber'] = isNumber;
exports['isNatural'] = isNatural;
exports['isPair'] = isPair;
@ -1432,6 +1454,17 @@ if(this['plt'] === undefined) { this['plt'] = {}; }
exports['isOutputStringPort'] = isOutputStringPort;
exports['isEqual'] = isEqual;
exports['toDomNode'] = toDomNode;
exports['toWrittenString'] = toWrittenString;
exports['toDisplayedString'] = toDisplayedString;
// Type constructors
exports['makeList'] = makeList;
exports['makePair'] = makePair;
exports['makeVector'] = makeVector;
exports['ArityAtLeast'] = ArityAtLeast;
exports['isArityMatching'] = isArityMatching;
@ -1441,5 +1474,7 @@ if(this['plt'] === undefined) { this['plt'] = {}; }
exports['HaltError'] = HaltError;
scope.link.announceReady('runtime');
})(this['plt']);

148
js-assembler/runtime-src/types.js
View File

@ -47,8 +47,6 @@ if (! this['plt']) { this['plt'] = {}; }
// Union/find for circular equality testing.
var UnionFind = function() {
@ -85,7 +83,7 @@ if (! this['plt']) { this['plt'] = {}; }
//////////////////////////////////////////////////////////////////////
StructType = function(name, type, numberOfArgs, numberOfFields, firstField,
var StructType = function(name, type, numberOfArgs, numberOfFields, firstField,
applyGuard, constructor, predicate, accessor, mutator) {
this.name = name;
this.type = type;
@ -698,17 +696,24 @@ if (! this['plt']) { this['plt'] = {}; }
return b;
};
Cons = function(f, r) {
this.f = f;
this.r = r;
//////////////////////////////////////////////////////////////////////
// Cons Pairs
var Cons = function(f, r) {
this.first = f;
this.rest = r;
};
Cons.prototype.reverse = function() {
var lst = this;
var ret = Empty.EMPTY;
while (!lst.isEmpty()){
ret = Cons.makeInstance(lst.first(), ret);
lst = lst.rest();
ret = Cons.makeInstance(lst.first, ret);
lst = lst.rest;
}
return ret;
};
@ -717,28 +722,21 @@ if (! this['plt']) { this['plt'] = {}; }
return new Cons(f, r);
};
// FIXME: can we reduce the recursion on this?
Cons.prototype.isEqual = function(other, aUnionFind) {
if (! (other instanceof Cons)) {
return Logic.FALSE;
}
return (isEqual(this.first(), other.first(), aUnionFind) &&
isEqual(this.rest(), other.rest(), aUnionFind));
};
Cons.prototype.first = function() {
return this.f;
};
Cons.prototype.rest = function() {
return this.r;
return (isEqual(this.first, other.first, aUnionFind) &&
isEqual(this.rest, other.rest, aUnionFind));
};
Cons.prototype.isEmpty = function() {
return false;
};
// Cons.append: (listof X) -> (listof X)
Cons.prototype.append = function(b){
if (b === Empty.EMPTY)
@ -746,8 +744,8 @@ if (! this['plt']) { this['plt'] = {}; }
var ret = b;
var lst = this.reverse();
while ( !lst.isEmpty() ) {
ret = Cons.makeInstance(lst.first(), ret);
lst = lst.rest();
ret = Cons.makeInstance(lst.first, ret);
lst = lst.rest;
}
return ret;
@ -759,8 +757,8 @@ if (! this['plt']) { this['plt'] = {}; }
var texts = [];
var p = this;
while ( p instanceof Cons ) {
texts.push(toWrittenString(p.first(), cache));
p = p.rest();
texts.push(toWrittenString(p.first, cache));
p = p.rest;
if (typeof(p) === 'object' && cache.containsKey(p)) {
break;
}
@ -779,8 +777,8 @@ if (! this['plt']) { this['plt'] = {}; }
var texts = [];
var p = this;
while ( p instanceof Cons ) {
texts.push(toDisplayedString(p.first(), cache));
p = p.rest();
texts.push(toDisplayedString(p.first, cache));
p = p.rest;
if (typeof(p) === 'object' && cache.containsKey(p)) {
break;
}
@ -789,17 +787,6 @@ if (! this['plt']) { this['plt'] = {}; }
texts.push('.');
texts.push(toDisplayedString(p, cache));
}
// while (true) {
// if ((!(p instanceof Cons)) && (!(p instanceof Empty))) {
// texts.push(".");
// texts.push(toDisplayedString(p, cache));
// break;
// }
// if (p.isEmpty())
// break;
// texts.push(toDisplayedString(p.first(), cache));
// p = p.rest();
// }
return "(" + texts.join(" ") + ")";
};
@ -811,8 +798,8 @@ if (! this['plt']) { this['plt'] = {}; }
node.appendChild(document.createTextNode("("));
var p = this;
while ( p instanceof Cons ) {
appendChild(node, toDomNode(p.first(), cache));
p = p.rest();
appendChild(node, toDomNode(p.first, cache));
p = p.rest;
if ( p !== Empty.EMPTY ) {
appendChild(node, document.createTextNode(" "));
}
@ -825,27 +812,27 @@ if (! this['plt']) { this['plt'] = {}; }
appendChild(node, document.createTextNode(" "));
appendChild(node, toDomNode(p, cache));
}
// while (true) {
// if ((!(p instanceof Cons)) && (!(p instanceof Empty))) {
// appendChild(node, document.createTextNode(" "));
// appendChild(node, document.createTextNode("."));
// appendChild(node, document.createTextNode(" "));
// appendChild(node, toDomNode(p, cache));
// break;
// }
// if (p.isEmpty())
// break;
// appendChild(node, toDomNode(p.first(), cache));
// p = p.rest();
// if (! p.isEmpty()) {
// appendChild(node, document.createTextNode(" "));
// }
// }
node.appendChild(document.createTextNode(")"));
return node;
};
// isList: Any -> Boolean
// Returns true if x is a list (a chain of pairs terminated by EMPTY).
var isList = function(x) {
while (x !== Empty.EMPTY) {
if (x instanceof Cons){
x = x.rest;
} else {
return false;
}
}
return true;
};
//////////////////////////////////////////////////////////////////////
@ -1955,22 +1942,22 @@ String.prototype.toDisplayedString = function(cache) {
var makeList = function(args) {
var makeList = function() {
var result = Empty.EMPTY;
for(var i = args.length-1; i >= 0; i--) {
result = Cons.makeInstance(args[i], result);
for(var i = arguments.length-1; i >= 0; i--) {
result = Cons.makeInstance(arguments[i], result);
}
return result;
};
var makeVector = function(args) {
return Vector.makeInstance(args.length, args);
var makeVector = function() {
return Vector.makeInstance(arguments.length, arguments);
};
var makeVectorImmutable = function(args) {
var v = Vector.makeInstance(args.length, args);
var makeVectorImmutable = function() {
var v = Vector.makeInstance(arguments.length, arguments);
v.mutable = false;
return v;
};
@ -1996,27 +1983,27 @@ String.prototype.toDisplayedString = function(cache) {
' given ' + s.toString(),
false);
}
}
};
var makeHashEq = function(lst) {
var newHash = new EqHashTable();
while ( !lst.isEmpty() ) {
newHash.hash.put(lst.first().first(), lst.first().rest());
lst = lst.rest();
newHash.hash.put(lst.first.first, lst.first.rest);
lst = lst.rest;
}
return newHash;
}
};
var makeHashEqual = function(lst) {
var newHash = new EqualHashTable();
while ( !lst.isEmpty() ) {
newHash.hash.put(lst.first().first(), lst.first().rest());
lst = lst.rest();
newHash.hash.put(lst.first.first, lst.first.rest);
lst = lst.rest;
}
return newHash;
}
};
var Color = makeStructureType('color', false, 3, 0, false, false);
@ -2042,10 +2029,10 @@ String.prototype.toDisplayedString = function(cache) {
}
if (types.isPair(x)) {
var consPair = types.cons(x.first(), x.rest());
var consPair = types.cons(x.first, x.rest);
objectHash.put(x, consPair);
consPair.f = readerGraph(x.first(), objectHash, n+1);
consPair.r = readerGraph(x.rest(), objectHash, n+1);
consPair.f = readerGraph(x.first, objectHash, n+1);
consPair.r = readerGraph(x.rest, objectHash, n+1);
return consPair;
}
@ -2071,7 +2058,7 @@ String.prototype.toDisplayedString = function(cache) {
}
if (types.isStruct(x)) {
var aStruct = clone(x);
var aStruct = helpers.clone(x);
objectHash.put(x, aStruct);
for(var i = 0 ;i < x._fields.length; i++) {
x._fields[i] = readerGraph(x._fields[i], objectHash, n+1);
@ -2088,22 +2075,6 @@ String.prototype.toDisplayedString = function(cache) {
// clone: object -> object
// Copies an object. The new object should respond like the old
// object, including to things like instanceof
var clone = function(obj) {
var C = function() {}
C.prototype = obj;
var c = new C();
for (property in obj) {
if (obj.hasOwnProperty(property)) {
c[property] = obj[property];
}
}
return c;
};
//////////////////////////////////////////////////////////////////////
@ -2170,6 +2141,7 @@ String.prototype.toDisplayedString = function(cache) {
types.isChar = function(x) { return x instanceof Char; };
types.isString = isString;
types.isPair = function(x) { return x instanceof Cons; };
types.isList = isList;
types.isEmpty = function(x) { return x === Empty.EMPTY; };
types.isVector = function(x) { return x instanceof Vector; };
types.isBox = function(x) { return x instanceof Box; };

3
js.rkt Normal file
View File

@ -0,0 +1,3 @@
#lang s-exp "lang/base.rkt"
(require "js/main.rkt")
(provide (all-from-out "js/main.rkt"))

36
js/js-impl.js Normal file
View File

@ -0,0 +1,36 @@
EXPORTS['alert'] =
RUNTIME.makePrimitiveProcedure(
'is-color?',
1,
function(MACHINE) {
var elt = MACHINE.env[MACHINE.env.length - 1];
alert(String(elt));
return RUNTIME.VOID;
});
EXPORTS['body'] = $(document.body);
EXPORTS['$'] =
RUNTIME.makePrimitiveProcedure(
'$',
1,
function(MACHINE) {
var obj = MACHINE.env[MACHINE.env.length - 1];
return $(obj);
});
EXPORTS['call'] =
RUNTIME.makePrimitiveProcedure(
'call',
new RUNTIME.ArityAtLeast(2),
function(MACHINE) {
var obj = MACHINE.env[MACHINE.env.length - 1];
var methodName = MACHINE.env[MACHINE.env.length - 2];
var args = [];
for (var i = 0; i < MACHINE.argcount - 2; i++) {
args.push(MACHINE.env[MACHINE.env.length -1 - 2 - i]);
}
var result = obj[methodName].apply(obj, args);
return result;
});

9
js/main.rkt Normal file
View File

@ -0,0 +1,9 @@
#lang s-exp "../lang/js/js.rkt"
(declare-implementation
#:racket "racket-impl.rkt"
#:javascript ("js-impl.js")
#:provided-values (alert
body
call
$))

15
js/racket-impl.rkt Normal file
View File

@ -0,0 +1,15 @@
#lang s-exp "../lang/base.rkt"
(provide alert body call $)
(define (alert x)
(display x)
(newline))
(define body 'blah)
(define (call object method . args)
'not-done-yet)
(define ($ name)
'not-done-yet)

9
lang/base/reader.rkt Normal file
View File

@ -0,0 +1,9 @@
#lang s-exp syntax/module-reader
;; http://docs.racket-lang.org/planet/hash-lang-planet.html
#:language (lambda (ip)
`(file ,(path->string base-lang-path)))
(require racket/runtime-path)
(define-runtime-path base-lang-path "../base.rkt")

57
lang/js-impl/js-impl.rkt
View File

@ -1,57 +0,0 @@
#lang racket/base
;; Special language level where implementation is done in Javascript.
(require (for-syntax racket/base)
(for-syntax racket/file)
(for-syntax syntax/modresolve)
(for-syntax "record.rkt"))
(define-for-syntax (read-implementation a-module-path)
(let ([a-path (parameterize ([current-directory (or (current-load-relative-directory)
(current-directory))])
(resolve-module-path a-module-path #f))])
(file->string a-path)))
(define-syntax (require-js stx)
(syntax-case stx ()
[(_ path ...)
(andmap (compose string? syntax-e) (syntax->list #'(path ...)))
(with-syntax
([(impl ...) (map (compose read-implementation syntax-e)
(syntax->list #'(path ...)))])
(syntax/loc stx
(begin
(begin-for-syntax
(let* ([this-module (variable-reference->resolved-module-path (#%variable-reference))]
[key (resolved-module-path-name this-module)])
(record-implementations! key (list (#%datum . impl) ...))))
(void))))]))
(define-syntax (-provide stx)
(syntax-case stx ()
[(_ name ...)
(andmap (compose symbol? syntax-e) (syntax->list #'(name ...)))
(syntax/loc stx
(begin
(begin-for-syntax
(let* ([this-module (variable-reference->resolved-module-path (#%variable-reference))]
[key (resolved-module-path-name this-module)])
(record-exports! key (list (#%datum . name) ...))))
(provide name ...)
(begin (define name (lambda args
(error (quote name)
"Must be evaluated within Javascript"))) ...)))]))
(provide require-js
require
planet
(rename-out (-provide provide)
(#%plain-module-begin #%module-begin)))

39
lang/js-impl/query.rkt
View File

@ -1,39 +0,0 @@
#lang racket/base
(require racket/contract
racket/runtime-path
racket/list
syntax/modresolve)
(define-struct js-module (impls exports))
(provide/contract [query
(module-path? . -> . (or/c js-module? false/c))]
[struct js-module ([impls (listof string?)]
[exports (listof symbol?)])])
(define-runtime-path record.rkt "record.rkt")
(define ns (make-base-empty-namespace))
;; query: module-path -> (listof string)
;; Given a module, see if it's implemented via Javascript.
(define (query a-module-path)
(let ([resolved-path (resolve-module-path a-module-path #f)])
(parameterize ([current-namespace ns])
(dynamic-require a-module-path (void)) ;; get the compile-time code running.
(let ([result
((dynamic-require-for-syntax record.rkt 'lookup-implementations) resolved-path)])
(cond
[(empty? result)
#f]
[else
(make-js-module result
((dynamic-require-for-syntax record.rkt 'lookup-exports) resolved-path))])))))

61
lang/js-impl/record.rkt
View File

@ -1,61 +0,0 @@
#lang racket/base
(provide record-implementations!
record-exports!
lookup-implementations
lookup-exports)
(define-struct record (path impls))
(define-struct export (path exports))
(define records '())
(define exports '())
;; record!: path (listof string) -> void
(define (record-implementations! a-path impls)
(set! records (cons (make-record a-path impls)
records)))
;; record-exports!: path (listof symbol) -> void
(define (record-exports! a-path export-names)
(set! exports (cons (make-export a-path export-names)
exports)))
(define (my-foldl f acc lst)
(cond
[(null? lst)
acc]
[else
(my-foldl f (f (car lst) acc) (cdr lst))]))
(define (my-filter f lst)
(cond
[(null? lst)
'()]
[(f (car lst))
(cons (car lst) (my-filter f (cdr lst)))]
[else
(my-filter f (cdr lst))]))
;; lookup-implementations: path -> (listof string)
(define (lookup-implementations a-path)
(my-foldl (lambda (a-record perms)
(append (record-impls a-record) perms))
'()
(my-filter (lambda (a-record)
(equal? a-path (record-path a-record)))
records)))
;; lookup-exports: path -> (listof symbol)
(define (lookup-exports a-path)
(my-foldl (lambda (an-export exports)
(append (export-exports an-export) exports))
'()
(my-filter (lambda (an-export)
(equal? a-path (export-path an-export)))
exports)))

17
lang/js-conditional/js-conditional.rkt → lang/js/js.rkt
View File

@ -17,10 +17,11 @@
(file->string a-path)))
(define-syntax (declare-conditional-implementation stx)
(define-syntax (declare-implementation stx)
(syntax-parse stx
[(_ #:racket racket-module-name
#:javascript (javascript-module-name ...))
#:javascript (javascript-module-name ...)
#:provided-values (provided-name ...))
(with-syntax
([resolved-racket-module-name
(my-resolve-path (syntax-e #'racket-module-name))]
@ -28,7 +29,8 @@
(string-join
(map (compose read-implementation syntax-e)
(syntax->list #'(javascript-module-name ...)))
"\n")])
"\n")]
[(internal-name ...) (generate-temporaries #'(provided-name ...))])
(syntax/loc stx
(begin
@ -42,11 +44,14 @@
[key (resolved-module-path-name this-module)])
(record-redirection! (#%datum . resolved-racket-module-name)
key)
(record-javascript-implementation! key (#%datum . impl))))
(record-javascript-implementation! key (#%datum . impl))
;;(record-exported-name! key 'internal-name 'provided-name) ...
))
(require racket-module-name)
(provide (all-from-out racket-module-name)))))]))
(define internal-name provided-name) ...
(provide (rename-out [internal-name provided-name] ...)))))]))
(provide declare-conditional-implementation
(provide declare-implementation
(rename-out [#%plain-module-begin #%module-begin]))

12
lang/js-conditional/query.rkt → lang/js/query.rkt
View File

@ -9,7 +9,8 @@
[has-javascript-implementation? (module-path? . -> . boolean?)]
[redirected? (path? . -> . boolean?)]
[follow-redirection (path? . -> . path?)])
[follow-redirection (path? . -> . path?)]
[collect-redirections-to (path? . -> . (listof path?))])
(define-runtime-path record.rkt "record.rkt")
(define ns (make-base-empty-namespace))
@ -49,3 +50,12 @@
((dynamic-require-for-syntax record.rkt 'follow-redirection)
resolved-path))))
;; collect-redirections-to: module-path -> (listof path)
(define (collect-redirections-to a-module-path)
(let ([resolved-path (resolve-module-path a-module-path #f)])
(parameterize ([current-namespace ns])
(dynamic-require a-module-path (void)) ;; get the compile-time code running.
((dynamic-require-for-syntax record.rkt 'collect-redirections-to)
resolved-path))))

25
lang/js-conditional/record.rkt → lang/js/record.rkt
View File

@ -5,7 +5,11 @@
lookup-javascript-implementation
record-redirection!
follow-redirection)
follow-redirection
record-exported-name!
collect-redirections-to)
(define-struct record (path impl))
@ -59,4 +63,21 @@
[(equal? (redirection-from (car redirections)) a-path)
(redirection-to (car redirections))]
[else
(loop (cdr redirections))])))
(loop (cdr redirections))])))
(define (record-exported-name! a-path internal-name external-name)
(printf "I need to remember to export ~s as ~s\n" internal-name external-name)
(void))
;; collect-redirections-to: path -> (listof path)
(define (collect-redirections-to a-path)
(let loop ([redirections redirections])
(cond
[(null? redirections)
'()]
[(equal? (redirection-to (car redirections)) a-path)
(redirection-from (car redirections))]
[else
(loop (cdr redirections))])))

38
lang/kernel.rkt
View File

@ -148,7 +148,7 @@
display
newline
#;displayln
;; displayln
;; current-print
;; current-continuation-marks
@ -175,7 +175,7 @@
;; compose
;; current-inexact-milliseconds
;; current-seconds
;; void
void
;; random
;; sleep
;; (identity -identity)
@ -394,6 +394,36 @@
;; make-reader-graph
;; make-placeholder
;; placeholder-set!
)
(provide
;; FIXME:
;; Extensions: these may need to be hidden in a JavaScript-implemented module
in-javascript-context?
viewport-width
viewport-height)
;; in-javascript-context: -> boolean
;; Produces true if we're in a JavaScript context.
(define (in-javascript-context?)
#f)
;; viewport-width: -> natural
;; The viewport width in pixels.
(define (viewport-width)
(error 'viewport-width "Not available outside JavaScript context."))
;; viewport-height: -> natural
;; The viewport height in pixels.
(define (viewport-height)
(error 'viewport-width "Not available outside JavaScript context."))

9
lang/reader.rkt Normal file
View File

@ -0,0 +1,9 @@
#lang s-exp syntax/module-reader
;; http://docs.racket-lang.org/planet/hash-lang-planet.html
#:language (lambda (ip)
`(file ,(path->string base-lang-path)))
(require racket/runtime-path)
(define-runtime-path base-lang-path "base.rkt")

6
get-dependencies.rkt → make/get-dependencies.rkt
View File

@ -1,7 +1,7 @@
#lang typed/racket/base
(require "compiler/expression-structs.rkt"
"compiler/lexical-structs.rkt"
"sets.rkt")
(require "../compiler/expression-structs.rkt"
"../compiler/lexical-structs.rkt"
"../sets.rkt")
;; Collect the complete list of dependencies for a module.

19
make-structs.rkt → make/make-structs.rkt
View File

@ -1,8 +1,8 @@
#lang typed/racket/base
(require "compiler/il-structs.rkt"
"compiler/bootstrapped-primitives.rkt"
"compiler/expression-structs.rkt"
(require "../compiler/il-structs.rkt"
"../compiler/bootstrapped-primitives.rkt"
"../compiler/expression-structs.rkt"
"get-dependencies.rkt")
@ -13,7 +13,9 @@
(define-type Source (U StatementsSource
MainModuleSource
ModuleSource
SexpSource))
SexpSource
UninterpretedSource
))
(define-struct: StatementsSource ([stmts : (Listof Statement)])
#:transparent)
@ -23,10 +25,14 @@
#:transparent)
(define-struct: SexpSource ([sexp : Any])
#:transparent)
(define-struct: UninterpretedSource ([datum : String])
#:transparent)
(define-struct: Configuration
([should-follow? : (Source Path -> Boolean)]
([wrap-source : (Source -> Source)]
[should-follow-children? : (Source -> Boolean)]
[on-module-statements : (Source
(U Expression #f)
(Listof Statement)
@ -40,7 +46,8 @@
(define debug-configuration
(make-Configuration
(lambda (src p) #t)
(lambda (src) src)
(lambda (src) #t)
(lambda (src ast stmt)
(when (and ast (expression-module-path ast))
(printf "debug build configuration: visiting ~s\n"

39
make.rkt → make/make.rkt
View File

@ -1,22 +1,22 @@
#lang typed/racket/base
(require "compiler/compiler.rkt"
"compiler/il-structs.rkt"
"compiler/lexical-structs.rkt"
"compiler/compiler-structs.rkt"
"compiler/expression-structs.rkt"
(require "../compiler/compiler.rkt"
"../compiler/il-structs.rkt"
"../compiler/lexical-structs.rkt"
"../compiler/compiler-structs.rkt"
"../compiler/expression-structs.rkt"
"../parameters.rkt"
"../sets.rkt"
"get-dependencies.rkt"
"parameters.rkt"
"sets.rkt"
"make-structs.rkt"
racket/list
racket/match)
(require/typed "parser/parse-bytecode.rkt"
(require/typed "../parser/parse-bytecode.rkt"
[parse-bytecode (Any -> Expression)])
(require/typed "get-module-bytecode.rkt"
(require/typed "../get-module-bytecode.rkt"
[get-module-bytecode ((U String Path Input-Port) -> Bytes)])
@ -41,6 +41,9 @@
[(StatementsSource? a-source)
(values #f (StatementsSource-stmts a-source))]
[(UninterpretedSource? a-source)
(values #f '())]
[(MainModuleSource? a-source)
(let-values ([(ast stmts)
(get-ast-and-statements (MainModuleSource-source a-source))])
@ -82,6 +85,7 @@
(and path (? ModuleLocator?))
prefix
requires
provides
code))))
path]
[else
@ -96,7 +100,8 @@
((inst new-seteq Symbol))])
(match config
[(struct Configuration (should-follow?
[(struct Configuration (wrap-source
should-follow-children?
on-module-statements
after-module-statements
after-last))
@ -112,20 +117,19 @@
(cond
[(eq? ast #f)
empty]
[(not (should-follow-children? this-source))
empty]
[else
(let* ([dependent-module-names (get-dependencies ast)]
[paths
(foldl (lambda: ([mp : ModuleLocator]
[acc : (Listof Source)])
(let ([rp [ModuleLocator-real-path mp]])
(cond [((current-kernel-module-locator?)
mp)
acc]
[(and (path? rp)
(should-follow? this-source rp)
(cons (make-ModuleSource rp)
acc))]
[(path? rp)
(cons (make-ModuleSource rp) acc)]
[else
acc])))
'()
@ -146,9 +150,8 @@
[(ast stmts)
(get-ast-and-statements this-source)])
(on-module-statements this-source ast stmts)
(loop (append (collect-new-dependencies this-source ast)
(loop (append (map wrap-source (collect-new-dependencies this-source ast))
(rest sources)))
(after-module-statements this-source ast stmts))])))
(follow-dependencies sources)])))
(follow-dependencies (map wrap-source sources))])))

6
parameters.rkt
View File

@ -11,7 +11,8 @@
current-root-path
current-warn-unimplemented-kernel-primitive
current-seen-unimplemented-kernel-primitives
current-kernel-module-locator?)
current-kernel-module-locator?
current-compress-javascript?)
@ -47,6 +48,9 @@
(: current-compress-javascript? (Parameterof Boolean))
(define current-compress-javascript? (make-parameter #f))

32
parser/parse-bytecode-5.1.1.rkt
View File

@ -163,12 +163,14 @@
(struct ModuleLocator ('self 'self))
module-prefix
module-requires
module-provides
module-code))))
(make-Top top-prefix
(make-Module name
(make-ModuleLocator name name) (current-module-path)
module-prefix
module-requires
module-provides
module-code))]
[else
exp]))
@ -369,6 +371,7 @@
(make-ModuleLocator self-path self-path)
(parse-prefix prefix)
(parse-mod-requires self-modidx requires)
(parse-mod-provides self-modidx provides)
(parse-mod-body body))]
[else
(let ([rewritten-path (rewrite-path self-path)])
@ -379,6 +382,7 @@
(normalize-path self-path))
(parse-prefix prefix)
(parse-mod-requires self-modidx requires)
(parse-mod-provides self-modidx provides)
(parse-mod-body body))]
[else
(error 'parse-mod "Internal error: unable to resolve module path ~s" self-path)]))]))]))
@ -407,6 +411,34 @@
(define (parse-mod-provides enclosing-module-path-index provides)
(let* ([resolver
(current-module-path-index-resolver)]
[enclosing-path
(resolver enclosing-module-path-index (current-module-path))]
[subresolver
(lambda (p)
(cond
[(symbol? enclosing-path)
(wrap-module-name (resolver p (current-module-path)))]
[(path? enclosing-path)
(wrap-module-name (resolver p enclosing-path))]))])
(let loop ([provides provides])
(cond
[(empty? provides)
empty]
[(= (first (first provides)) 0)
(let ([provided-values (second (first provides))])
(for/list ([v provided-values])
(match v
[(struct provided (name src src-name nom-mod
src-phase protected? insp))
(make-ModuleProvide src-name name (subresolver src))])))]
[else
(loop (rest provides))]))))

8
simulator/simulator.rkt
View File

@ -312,10 +312,10 @@
(cond
[(closure? clos)
(if (arity-match? (closure-arity clos)
(ensure-natural (evaluate-oparg m (CheckClosureArity!-arity op))))
(ensure-natural (evaluate-oparg m (CheckClosureArity!-num-args op))))
'ok
(error 'check-closure-arity "arity mismatch: passed ~s args to ~s"
(ensure-natural (evaluate-oparg m (CheckClosureArity!-arity op)))
(ensure-natural (evaluate-oparg m (CheckClosureArity!-num-args op)))
(closure-display-name clos)))]
[else
(error 'check-closure-arity "not a closure: ~s" clos)]))]
@ -325,10 +325,10 @@
(cond
[(primitive-proc? clos)
(if (arity-match? (primitive-proc-arity clos)
(ensure-natural (evaluate-oparg m (CheckPrimitiveArity!-arity op))))
(ensure-natural (evaluate-oparg m (CheckPrimitiveArity!-num-args op))))
'ok
(error 'check-primitive-arity "arity mismatch: passed ~s args to ~s"
(ensure-natural (evaluate-oparg m (CheckPrimitiveArity!-arity op)))
(ensure-natural (evaluate-oparg m (CheckPrimitiveArity!-num-args op)))
(primitive-proc-display-name clos)))]
[else
(error 'check-primitive-arity "not a primitive: ~s" clos)]))]

5
tests/browser-evaluate.rkt
View File

@ -85,6 +85,7 @@
[program (second javascript-compiler+program)])
(with-handlers ([exn:fail? (lambda (exn)
(displayln exn)
(let ([sentinel
(format
#<<EOF
@ -220,7 +221,7 @@ var comet = function() {
}
var output = [];
var startTime, endTime;
var params = { currentDisplayer: function(v) {
var params = { currentDisplayer: function(MACHINE, v) {
$(document.body).append(v);
output.push($(v).text()); } };
@ -236,7 +237,7 @@ var comet = function() {
var onFail = function(machine, e) {
endTime = new Date();
sendRequest("/eval", function(req) { setTimeout(comet, 0); },
"e=" + encodeURIComponent(String(e)) +
"e=" + encodeURIComponent(String(e.stack || e)) +
"&t=" + encodeURIComponent(String(endTime - startTime)));
};
startTime = new Date();

826
tests/earley/earley.rkt Normal file
View File

@ -0,0 +1,826 @@
#lang s-exp "../../lang/base.rkt"
(begin
(define make-parser
(lambda (grammar lexer)
(letrec ((non-terminals
(lambda (grammar)
(letrec ((add-nt (lambda (nt nts) (if (member nt nts) nts (cons nt nts)))))
((letrec ((def-loop
(lambda (defs nts)
(if (pair? defs)
(let ((def (car defs)))
(let ((head (car def)))
((letrec ((rule-loop
(lambda (rules nts)
(if (pair? rules)
(let ((rule (car rules)))
((letrec ((loop
(lambda (l nts)
(if (pair? l)
(let ((nt (car l)))
(loop (cdr l) (add-nt nt nts)))
(rule-loop (cdr rules) nts)))))
loop)
rule
nts))
(def-loop (cdr defs) nts)))))
rule-loop)
(cdr def)
(add-nt head nts))))
(list->vector (reverse nts))))))
def-loop)
grammar
'()))))
(ind
(lambda (nt nts)
((letrec ((loop
(lambda (i)
(if (>= i '0) (if (equal? (vector-ref nts i) nt) i (loop (- i '1))) '#f))))
loop)
(- (vector-length nts) '1))))
(nb-configurations
(lambda (grammar)
((letrec ((def-loop
(lambda (defs nb-confs)
(if (pair? defs)
(let ((def (car defs)))
((letrec ((rule-loop
(lambda (rules nb-confs)
(if (pair? rules)
(let ((rule (car rules)))
((letrec ((loop
(lambda (l nb-confs)
(if (pair? l)
(loop (cdr l) (+ nb-confs '1))
(rule-loop (cdr rules) (+ nb-confs '1))))))
loop)
rule
nb-confs))
(def-loop (cdr defs) nb-confs)))))
rule-loop)
(cdr def)
nb-confs))
nb-confs))))
def-loop)
grammar
'0))))
(let ((nts (non-terminals grammar)))
(let ((nb-nts (vector-length nts)))
(let ((nb-confs (+ (nb-configurations grammar) nb-nts)))
(let ((starters (make-vector nb-nts '())))
(let ((enders (make-vector nb-nts '())))
(let ((predictors (make-vector nb-nts '())))
(let ((steps (make-vector nb-confs '#f)))
(let ((names (make-vector nb-confs '#f)))
(letrec ((setup-tables
(lambda (grammar nts starters enders predictors steps names)
(letrec ((add-conf
(lambda (conf nt nts class)
(let ((i (ind nt nts)))
(vector-set! class i (cons conf (vector-ref class i)))))))
(let ((nb-nts (vector-length nts)))
((letrec ((nt-loop
(lambda (i)
(if (>= i '0)
(begin
(vector-set! steps i (- i nb-nts))
(vector-set! names i (list (vector-ref nts i) '0))
(vector-set! enders i (list i))
(nt-loop (- i '1)))
'#f))))
nt-loop)
(- nb-nts '1))
((letrec ((def-loop
(lambda (defs conf)
(if (pair? defs)
(let ((def (car defs)))
(let ((head (car def)))
((letrec ((rule-loop
(lambda (rules conf rule-num)
(if (pair? rules)
(let ((rule (car rules)))
(vector-set!
names
conf
(list head rule-num))
(add-conf conf head nts starters)
((letrec ((loop
(lambda (l conf)
(if (pair? l)
(let ((nt (car l)))
(vector-set!
steps
conf
(ind nt nts))
(add-conf
conf
nt
nts
predictors)
(loop
(cdr l)
(+ conf '1)))
(begin
(vector-set!
steps
conf
(-
(ind head nts)
nb-nts))
(add-conf
conf
head
nts
enders)
(rule-loop
(cdr rules)
(+ conf '1)
(+ rule-num '1)))))))
loop)
rule
conf))
(def-loop (cdr defs) conf)))))
rule-loop)
(cdr def)
conf
'1)))
'#f))))
def-loop)
grammar
(vector-length nts)))))))
(setup-tables grammar nts starters enders predictors steps names)
(let ((parser-descr (vector lexer nts starters enders predictors steps names)))
(lambda (input)
(letrec ((ind
(lambda (nt nts)
((letrec ((loop
(lambda (i)
(if (>= i '0)
(if (equal? (vector-ref nts i) nt) i (loop (- i '1)))
'#f))))
loop)
(- (vector-length nts) '1))))
(comp-tok
(lambda (tok nts)
((letrec ((loop
(lambda (l1 l2)
(if (pair? l1)
(let ((i (ind (car l1) nts)))
(if i (loop (cdr l1) (cons i l2)) (loop (cdr l1) l2)))
(cons (car tok) (reverse l2))))))
loop)
(cdr tok)
'())))
(input->tokens
(lambda (input lexer nts)
(list->vector (map (lambda (tok) (comp-tok tok nts)) (lexer input)))))
(make-states
(lambda (nb-toks nb-confs)
(let ((states (make-vector (+ nb-toks '1) '#f)))
((letrec ((loop
(lambda (i)
(if (>= i '0)
(let ((v (make-vector (+ nb-confs '1) '#f)))
(vector-set! v '0 '-1)
(vector-set! states i v)
(loop (- i '1)))
states))))
loop)
nb-toks))))
(conf-set-get (lambda (state conf) (vector-ref state (+ conf '1))))
(conf-set-get*
(lambda (state state-num conf)
(let ((conf-set (conf-set-get state conf)))
(if conf-set
conf-set
(let ((conf-set (make-vector (+ state-num '6) '#f)))
(vector-set! conf-set '1 '-3)
(vector-set! conf-set '2 '-1)
(vector-set! conf-set '3 '-1)
(vector-set! conf-set '4 '-1)
(vector-set! state (+ conf '1) conf-set)
conf-set)))))
(conf-set-merge-new!
(lambda (conf-set)
(vector-set!
conf-set
(+ (vector-ref conf-set '1) '5)
(vector-ref conf-set '4))
(vector-set! conf-set '1 (vector-ref conf-set '3))
(vector-set! conf-set '3 '-1)
(vector-set! conf-set '4 '-1)))
(conf-set-head (lambda (conf-set) (vector-ref conf-set '2)))
(conf-set-next (lambda (conf-set i) (vector-ref conf-set (+ i '5))))
(conf-set-member?
(lambda (state conf i)
(let ((conf-set (vector-ref state (+ conf '1))))
(if conf-set (conf-set-next conf-set i) '#f))))
(conf-set-adjoin
(lambda (state conf-set conf i)
(let ((tail (vector-ref conf-set '3)))
(vector-set! conf-set (+ i '5) '-1)
(vector-set! conf-set (+ tail '5) i)
(vector-set! conf-set '3 i)
(if (< tail '0)
(begin
(vector-set! conf-set '0 (vector-ref state '0))
(vector-set! state '0 conf))
'#f))))
(conf-set-adjoin*
(lambda (states state-num l i)
(let ((state (vector-ref states state-num)))
((letrec ((loop
(lambda (l1)
(if (pair? l1)
(let ((conf (car l1)))
(let ((conf-set (conf-set-get* state state-num conf)))
(if (not (conf-set-next conf-set i))
(begin
(conf-set-adjoin state conf-set conf i)
(loop (cdr l1)))
(loop (cdr l1)))))
'#f))))
loop)
l))))
(conf-set-adjoin**
(lambda (states states* state-num conf i)
(let ((state (vector-ref states state-num)))
(if (conf-set-member? state conf i)
(let ((state* (vector-ref states* state-num)))
(let ((conf-set* (conf-set-get* state* state-num conf)))
(if (not (conf-set-next conf-set* i))
(conf-set-adjoin state* conf-set* conf i)
'#f)
'#t))
'#f))))
(conf-set-union
(lambda (state conf-set conf other-set)
((letrec ((loop
(lambda (i)
(if (>= i '0)
(if (not (conf-set-next conf-set i))
(begin
(conf-set-adjoin state conf-set conf i)
(loop (conf-set-next other-set i)))
(loop (conf-set-next other-set i)))
'#f))))
loop)
(conf-set-head other-set))))
(forw
(lambda (states state-num starters enders predictors steps nts)
(letrec ((predict
(lambda (state state-num conf-set conf nt starters enders)
((letrec ((loop1
(lambda (l)
(if (pair? l)
(let ((starter (car l)))
(let ((starter-set
(conf-set-get*
state
state-num
starter)))
(if (not
(conf-set-next
starter-set
state-num))
(begin
(conf-set-adjoin
state
starter-set
starter
state-num)
(loop1 (cdr l)))
(loop1 (cdr l)))))
'#f))))
loop1)
(vector-ref starters nt))
((letrec ((loop2
(lambda (l)
(if (pair? l)
(let ((ender (car l)))
(if (conf-set-member? state ender state-num)
(let ((next (+ conf '1)))
(let ((next-set
(conf-set-get*
state
state-num
next)))
(conf-set-union
state
next-set
next
conf-set)
(loop2 (cdr l))))
(loop2 (cdr l))))
'#f))))
loop2)
(vector-ref enders nt))))
(reduce
(lambda (states state state-num conf-set head preds)
((letrec ((loop1
(lambda (l)
(if (pair? l)
(let ((pred (car l)))
((letrec ((loop2
(lambda (i)
(if (>= i '0)
(let ((pred-set
(conf-set-get
(vector-ref states i)
pred)))
(if pred-set
(let ((next (+ pred '1)))
(let ((next-set
(conf-set-get*
state
state-num
next)))
(conf-set-union
state
next-set
next
pred-set)))
'#f)
(loop2
(conf-set-next
conf-set
i)))
(loop1 (cdr l))))))
loop2)
head))
'#f))))
loop1)
preds))))
(let ((state (vector-ref states state-num))
(nb-nts (vector-length nts)))
((letrec ((loop
(lambda ()
(let ((conf (vector-ref state '0)))
(if (>= conf '0)
(let ((step (vector-ref steps conf)))
(let ((conf-set (vector-ref state (+ conf '1))))
(let ((head (vector-ref conf-set '4)))
(vector-set!
state
'0
(vector-ref conf-set '0))
(conf-set-merge-new! conf-set)
(if (>= step '0)
(predict
state
state-num
conf-set
conf
step
starters
enders)
(let ((preds
(vector-ref
predictors
(+ step nb-nts))))
(reduce
states
state
state-num
conf-set
head
preds)))
(loop))))
'#f)))))
loop))))))
(forward
(lambda (starters enders predictors steps nts toks)
(let ((nb-toks (vector-length toks)))
(let ((nb-confs (vector-length steps)))
(let ((states (make-states nb-toks nb-confs)))
(let ((goal-starters (vector-ref starters '0)))
(conf-set-adjoin* states '0 goal-starters '0)
(forw states '0 starters enders predictors steps nts)
((letrec ((loop
(lambda (i)
(if (< i nb-toks)
(let ((tok-nts (cdr (vector-ref toks i))))
(conf-set-adjoin* states (+ i '1) tok-nts i)
(forw
states
(+ i '1)
starters
enders
predictors
steps
nts)
(loop (+ i '1)))
'#f))))
loop)
'0)
states))))))
(produce
(lambda (conf i j enders steps toks states states* nb-nts)
(let ((prev (- conf '1)))
(if (if (>= conf nb-nts) (>= (vector-ref steps prev) '0) '#f)
((letrec ((loop1
(lambda (l)
(if (pair? l)
(let ((ender (car l)))
(let ((ender-set
(conf-set-get (vector-ref states j) ender)))
(if ender-set
((letrec ((loop2
(lambda (k)
(if (>= k '0)
(begin
(if (>= k i)
(if (conf-set-adjoin**
states
states*
k
prev
i)
(conf-set-adjoin**
states
states*
j
ender
k)
'#f)
'#f)
(loop2
(conf-set-next ender-set k)))
(loop1 (cdr l))))))
loop2)
(conf-set-head ender-set))
(loop1 (cdr l)))))
'#f))))
loop1)
(vector-ref enders (vector-ref steps prev)))
'#f))))
(back
(lambda (states states* state-num enders steps nb-nts toks)
(let ((state* (vector-ref states* state-num)))
((letrec ((loop1
(lambda ()
(let ((conf (vector-ref state* '0)))
(if (>= conf '0)
(let ((conf-set (vector-ref state* (+ conf '1))))
(let ((head (vector-ref conf-set '4)))
(vector-set! state* '0 (vector-ref conf-set '0))
(conf-set-merge-new! conf-set)
((letrec ((loop2
(lambda (i)
(if (>= i '0)
(begin
(produce
conf
i
state-num
enders
steps
toks
states
states*
nb-nts)
(loop2
(conf-set-next conf-set i)))
(loop1)))))
loop2)
head)))
'#f)))))
loop1)))))
(backward
(lambda (states enders steps nts toks)
(let ((nb-toks (vector-length toks)))
(let ((nb-confs (vector-length steps)))
(let ((nb-nts (vector-length nts)))
(let ((states* (make-states nb-toks nb-confs)))
(let ((goal-enders (vector-ref enders '0)))
((letrec ((loop1
(lambda (l)
(if (pair? l)
(let ((conf (car l)))
(conf-set-adjoin**
states
states*
nb-toks
conf
'0)
(loop1 (cdr l)))
'#f))))
loop1)
goal-enders)
((letrec ((loop2
(lambda (i)
(if (>= i '0)
(begin
(back
states
states*
i
enders
steps
nb-nts
toks)
(loop2 (- i '1)))
'#f))))
loop2)
nb-toks)
states*)))))))
(parsed?
(lambda (nt i j nts enders states)
(let ((nt* (ind nt nts)))
(if nt*
(let ((nb-nts (vector-length nts)))
((letrec ((loop
(lambda (l)
(if (pair? l)
(let ((conf (car l)))
(if (conf-set-member?
(vector-ref states j)
conf
i)
'#t
(loop (cdr l))))
'#f))))
loop)
(vector-ref enders nt*)))
'#f))))
(deriv-trees
(lambda (conf i j enders steps names toks states nb-nts)
(let ((name (vector-ref names conf)))
(if name
(if (< conf nb-nts)
(list (list name (car (vector-ref toks i))))
(list (list name)))
(let ((prev (- conf '1)))
((letrec ((loop1
(lambda (l1 l2)
(if (pair? l1)
(let ((ender (car l1)))
(let ((ender-set
(conf-set-get
(vector-ref states j)
ender)))
(if ender-set
((letrec ((loop2
(lambda (k l2)
(if (>= k '0)
(if (if (>= k i)
(conf-set-member?
(vector-ref states k)
prev
i)
'#f)
(let ((prev-trees
(deriv-trees
prev
i
k
enders
steps
names
toks
states
nb-nts))
(ender-trees
(deriv-trees
ender
k
j
enders
steps
names
toks
states
nb-nts)))
((letrec ((loop3
(lambda (l3 l2)
(if (pair? l3)
(let ((ender-tree
(list
(car
l3))))
((letrec ((loop4
(lambda (l4
l2)
(if (pair?
l4)
(loop4
(cdr
l4)
(cons
(append
(car
l4)
ender-tree)
l2))
(loop3
(cdr
l3)
l2)))))
loop4)
prev-trees
l2))
(loop2
(conf-set-next
ender-set
k)
l2)))))
loop3)
ender-trees
l2))
(loop2
(conf-set-next ender-set k)
l2))
(loop1 (cdr l1) l2)))))
loop2)
(conf-set-head ender-set)
l2)
(loop1 (cdr l1) l2))))
l2))))
loop1)
(vector-ref enders (vector-ref steps prev))
'()))))))
(deriv-trees*
(lambda (nt i j nts enders steps names toks states)
(let ((nt* (ind nt nts)))
(if nt*
(let ((nb-nts (vector-length nts)))
((letrec ((loop
(lambda (l trees)
(if (pair? l)
(let ((conf (car l)))
(if (conf-set-member?
(vector-ref states j)
conf
i)
(loop
(cdr l)
(append
(deriv-trees
conf
i
j
enders
steps
names
toks
states
nb-nts)
trees))
(loop (cdr l) trees)))
trees))))
loop)
(vector-ref enders nt*)
'()))
'#f))))
(nb-deriv-trees
(lambda (conf i j enders steps toks states nb-nts)
(let ((prev (- conf '1)))
(if (let ((or-part (< conf nb-nts)))
(if or-part or-part (< (vector-ref steps prev) '0)))
'1
((letrec ((loop1
(lambda (l n)
(if (pair? l)
(let ((ender (car l)))
(let ((ender-set
(conf-set-get (vector-ref states j) ender)))
(if ender-set
((letrec ((loop2
(lambda (k n)
(if (>= k '0)
(if (if (>= k i)
(conf-set-member?
(vector-ref states k)
prev
i)
'#f)
(let ((nb-prev-trees
(nb-deriv-trees
prev
i
k
enders
steps
toks
states
nb-nts))
(nb-ender-trees
(nb-deriv-trees
ender
k
j
enders
steps
toks
states
nb-nts)))
(loop2
(conf-set-next ender-set k)
(+
n
(*
nb-prev-trees
nb-ender-trees))))
(loop2
(conf-set-next ender-set k)
n))
(loop1 (cdr l) n)))))
loop2)
(conf-set-head ender-set)
n)
(loop1 (cdr l) n))))
n))))
loop1)
(vector-ref enders (vector-ref steps prev))
'0)))))
(nb-deriv-trees*
(lambda (nt i j nts enders steps toks states)
(let ((nt* (ind nt nts)))
(if nt*
(let ((nb-nts (vector-length nts)))
((letrec ((loop
(lambda (l nb-trees)
(if (pair? l)
(let ((conf (car l)))
(if (conf-set-member?
(vector-ref states j)
conf
i)
(loop
(cdr l)
(+
(nb-deriv-trees
conf
i
j
enders
steps
toks
states
nb-nts)
nb-trees))
(loop (cdr l) nb-trees)))
nb-trees))))
loop)
(vector-ref enders nt*)
'0))
'#f)))))
(let ((lexer (vector-ref parser-descr '0)))
(let ((nts (vector-ref parser-descr '1)))
(let ((starters (vector-ref parser-descr '2)))
(let ((enders (vector-ref parser-descr '3)))
(let ((predictors (vector-ref parser-descr '4)))
(let ((steps (vector-ref parser-descr '5)))
(let ((names (vector-ref parser-descr '6)))
(let ((toks (input->tokens input lexer nts)))
(vector
nts
starters
enders
predictors
steps
names
toks
(backward
(forward starters enders predictors steps nts toks)
enders
steps
nts
toks)
parsed?
deriv-trees*
nb-deriv-trees*))))))))))))))))))))))))
(define parse->parsed?
(lambda (parse nt i j)
(let ((nts (vector-ref parse '0)))
(let ((enders (vector-ref parse '2)))
(let ((states (vector-ref parse '7)))
(let ((parsed? (vector-ref parse '8))) (parsed? nt i j nts enders states)))))))
(define parse->trees
(lambda (parse nt i j)
(let ((nts (vector-ref parse '0)))
(let ((enders (vector-ref parse '2)))
(let ((steps (vector-ref parse '4)))
(let ((names (vector-ref parse '5)))
(let ((toks (vector-ref parse '6)))
(let ((states (vector-ref parse '7)))
(let ((deriv-trees* (vector-ref parse '9)))
(deriv-trees* nt i j nts enders steps names toks states))))))))))
(define parse->nb-trees
(lambda (parse nt i j)
(let ((nts (vector-ref parse '0)))
(let ((enders (vector-ref parse '2)))
(let ((steps (vector-ref parse '4)))
(let ((toks (vector-ref parse '6)))
(let ((states (vector-ref parse '7)))
(let ((nb-deriv-trees* (vector-ref parse '10)))
(nb-deriv-trees* nt i j nts enders steps toks states)))))))))
(define test
(lambda (k)
(let ((p (make-parser '((s (a) (s s)))
(lambda (l)
(map (lambda (x) (list x x)) l)))))
(let ((x (p (vector->list (make-vector k 'a)))))
(display (length (parse->trees x 's '0 k)))
(newline)))))
(test '12))

18
tests/test-assemble.rkt
View File

@ -45,11 +45,12 @@
"(function() { "
runtime
"var RUNTIME = plt.runtime;"
"var MACHINE = new plt.runtime.Machine();\n"
"return function(success, fail, params){"
snippet
(format "success(String(~a)); };" inspector)
(format "success(plt.runtime.toDisplayedString(~a)); };" inspector)
"});")])
(displayln snippet)
(display code op))))))
@ -63,6 +64,7 @@
[inspector (cdr a-statement+inspector)])
(display runtime op)
"var RUNTIME = plt.runtime;"
(display "var MACHINE = new plt.runtime.Machine();\n" op)
(display "(function() { " op)
(display "var myInvoke = " op)
@ -70,7 +72,7 @@
(display ";" op)
(fprintf op
"return function(succ, fail, params) { myInvoke(MACHINE, function(v) { succ(String(~a));}, fail, params); }"
"return function(succ, fail, params) { myInvoke(MACHINE, function(v) { succ(plt.runtime.toDisplayedString(~a));}, fail, params); }"
inspector)
(display "})" op))))))
(define (E-many stmts (inspector "MACHINE.val"))
@ -91,13 +93,13 @@
"Danny")
;; Assigning a cons
(test (E-single (make-AssignImmediateStatement 'val (make-Const (cons 1 2))))
"1,2")
"(1 . 2)")
;; Assigning a void
(test (E-single (make-AssignImmediateStatement 'val (make-Const (void))))
"null")
"#<void>")
;; Assigning to proc means val should still be uninitialized.
(test (E-single (make-AssignImmediateStatement 'proc (make-Const "Danny")))
"undefined")
"#<undefined>")
;; But we should see the assignment if we inspect MACHINE.proc.
(test (E-single (make-AssignImmediateStatement 'proc (make-Const "Danny"))
"MACHINE.proc")
@ -133,7 +135,7 @@
(make-AssignImmediateStatement (make-EnvLexicalReference 0 #f)
(make-Const 12345)))
"MACHINE.env[0]")
"undefined")
"#<undefined>")
(test (E-many (list (make-PushEnvironment 2 #f)
(make-AssignImmediateStatement (make-EnvLexicalReference 1 #f)
(make-Const 12345)))
@ -143,7 +145,7 @@
;; Toplevel Environment loading
(test (E-single (make-PerformStatement (make-ExtendEnvironment/Prefix! '(pi)))
"String(MACHINE.env[0]).slice(0, 5)")
"plt.runtime.toWrittenString(MACHINE.env[0]).slice(0, 5)")
"3.141")
@ -210,7 +212,7 @@
(make-Const 0))
(make-GotoStatement (make-Label 'closureStart))
'theEnd)
"String(MACHINE.env.length) + ',' + MACHINE.env[1] + ',' + MACHINE.env[0]")
"plt.runtime.toWrittenString(MACHINE.env.length) + ',' + MACHINE.env[1] + ',' + MACHINE.env[0]")
"2,hello,world")

48
tests/test-browser-evaluate.rkt
View File

@ -1,12 +1,12 @@
#lang racket
(require "browser-evaluate.rkt"
"../js-assembler/package.rkt"
"../make-structs.rkt")
"../make/make-structs.rkt")
(printf "test-browser-evaluate.rkt\n")
(define should-follow? (lambda (src p) #t))
(define should-follow? (lambda (src) #t))
(define evaluate (make-evaluate
(lambda (program op)
@ -20,7 +20,7 @@
(fprintf op "var innerInvoke = ")
(package-anonymous (make-SexpSource program)
#:should-follow? should-follow?
#:should-follow-children? should-follow?
#:output-port op)
(fprintf op "();\n")
@ -63,7 +63,7 @@ EOF
(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))
(unless (regexp-match (regexp-quote 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))
@ -99,20 +99,21 @@ 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")
;; fixme: symbols need to be represented separately from strings.
(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")
@ -121,7 +122,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")
@ -154,13 +155,13 @@ EOF
(test/exn '(displayln (add1 "0"))
"Error: add1: 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: sub1: expected number as argument 1 but received 0")
"Error: sub1: expected number as argument 1 but received \"0\"")
(test '(displayln (< 1 2))
"true\n")
@ -381,7 +382,7 @@ EOF
(test/exn '(let ([x 0])
(set! x "foo")
(add1 x))
"Error: add1: expected number as argument 1 but received foo")
"Error: add1: expected number as argument 1 but received \"foo\"")
@ -479,6 +480,31 @@ EOF
"false\n")
;;(test '(displayln 2/3)
;; "2/3\n")
;;(test '(displayln -2/3)
;; "-2/3\n")
(test '(displayln -0.0)
"-0.0\n")
(test '(displayln +nan.0)
"+nan.0\n")
(test '(displayln +inf.0)
"+inf.0\n")
(test '(displayln -inf.0)
"-inf.0\n")
;; Knuth's Man-or-boy-test.

2
tests/test-compiler.rkt
View File

@ -1368,7 +1368,6 @@
20116)
(test '(let () (define (f x y z)
(values y x z))
(call-with-values (lambda () (f 3 1 4))
@ -1376,6 +1375,7 @@
'((1 3 4))
#:with-bootstrapping? #t)
(test '(let () (define (f x y z)
(begin0 (values y x z)
(display "")))

4
tests/test-conform-browser.rkt
View File

@ -1,7 +1,7 @@
#lang racket
(require "browser-evaluate.rkt"
"../js-assembler/package.rkt"
"../make-structs.rkt"
"../make/make-structs.rkt"
racket/port
racket/runtime-path)
@ -21,7 +21,7 @@
(fprintf op "var innerInvoke = ")
(package-anonymous (make-SexpSource program)
#:should-follow? (lambda (src p) #t)
#:should-follow-children? (lambda (src) #t)
#:output-port op)
(fprintf op "();\n")

4
tests/test-earley-browser.rkt
View File

@ -1,7 +1,7 @@
#lang racket
(require "browser-evaluate.rkt"
"../js-assembler/package.rkt"
"../make-structs.rkt"
"../make/make-structs.rkt"
racket/port
racket/runtime-path
racket/runtime-path
@ -23,7 +23,7 @@
(fprintf op "var innerInvoke = ")
(package-anonymous (make-SexpSource program)
#:should-follow? (lambda (src path) #t)
#:should-follow-children? (lambda (src) #t)
#:output-port op)
(fprintf op "();\n")

4
tests/test-get-dependencies.rkt
View File

@ -1,5 +1,5 @@
#lang racket
(require "../get-dependencies.rkt"
(require "../make/get-dependencies.rkt"
"../get-module-bytecode.rkt"
"../parser/parse-bytecode.rkt"
"../compiler/lexical-structs.rkt"
@ -11,7 +11,7 @@
(define-runtime-path get-dependencies-path
(build-path ".." "get-dependencies.rkt"))
(build-path ".." "make" "get-dependencies.rkt"))
(define-runtime-path get-module-bytecode-path
(build-path ".." "get-module-bytecode.rkt"))

6
tests/test-package.rkt
View File

@ -1,17 +1,17 @@
#lang racket/base
(require "../js-assembler/package.rkt"
"../make-structs.rkt")
"../make/make-structs.rkt")
(printf "test-package.rkt\n")
(define (follow? src p)
(define (follow? src)
#t)
(define (test s-exp)
(package (make-SexpSource s-exp)
#:should-follow? follow?
#:should-follow-children? follow?
#:output-port (open-output-string) #;(current-output-port)))

2
whalesong.rkt
View File

@ -3,7 +3,7 @@
(require racket/list
racket/string
"make-structs.rkt"
"make/make-structs.rkt"
"js-assembler/package.rkt")

3
world.rkt Normal file
View File

@ -0,0 +1,3 @@
#lang s-exp "lang/base.rkt"
(require "world/main.rkt")
(provide (all-from-out "world/main.rkt"))

205
world/colordb.js Normal file
View File

@ -0,0 +1,205 @@
// Color database
var ColorDb = function() {
this.colors = {};
};
var types = plt.types;
ColorDb.prototype.put = function(name, color) {
this.colors[name] = color;
};
ColorDb.prototype.get = function(name) {
return this.colors[name.toString().toUpperCase()];
};
// FIXME: update toString to handle the primitive field values.
var colorDb = new ColorDb();
colorDb.put("ORANGE", types.color(255, 165, 0));
colorDb.put("RED", types.color(255, 0, 0));
colorDb.put("ORANGERED", types.color(255, 69, 0));
colorDb.put("TOMATO", types.color(255, 99, 71));
colorDb.put("DARKRED", types.color(139, 0, 0));
colorDb.put("RED", types.color(255, 0, 0));
colorDb.put("FIREBRICK", types.color(178, 34, 34));
colorDb.put("CRIMSON", types.color(220, 20, 60));
colorDb.put("DEEPPINK", types.color(255, 20, 147));
colorDb.put("MAROON", types.color(176, 48, 96));
colorDb.put("INDIAN RED", types.color(205, 92, 92));
colorDb.put("INDIANRED", types.color(205, 92, 92));
colorDb.put("MEDIUM VIOLET RED", types.color(199, 21, 133));
colorDb.put("MEDIUMVIOLETRED", types.color(199, 21, 133));
colorDb.put("VIOLET RED", types.color(208, 32, 144));
colorDb.put("VIOLETRED", types.color(208, 32, 144));
colorDb.put("LIGHTCORAL", types.color(240, 128, 128));
colorDb.put("HOTPINK", types.color(255, 105, 180));
colorDb.put("PALEVIOLETRED", types.color(219, 112, 147));
colorDb.put("LIGHTPINK", types.color(255, 182, 193));
colorDb.put("ROSYBROWN", types.color(188, 143, 143));
colorDb.put("PINK", types.color(255, 192, 203));
colorDb.put("ORCHID", types.color(218, 112, 214));
colorDb.put("LAVENDERBLUSH", types.color(255, 240, 245));
colorDb.put("SNOW", types.color(255, 250, 250));
colorDb.put("CHOCOLATE", types.color(210, 105, 30));
colorDb.put("SADDLEBROWN", types.color(139, 69, 19));
colorDb.put("BROWN", types.color(132, 60, 36));
colorDb.put("DARKORANGE", types.color(255, 140, 0));
colorDb.put("CORAL", types.color(255, 127, 80));
colorDb.put("SIENNA", types.color(160, 82, 45));
colorDb.put("ORANGE", types.color(255, 165, 0));
colorDb.put("SALMON", types.color(250, 128, 114));
colorDb.put("PERU", types.color(205, 133, 63));
colorDb.put("DARKGOLDENROD", types.color(184, 134, 11));
colorDb.put("GOLDENROD", types.color(218, 165, 32));
colorDb.put("SANDYBROWN", types.color(244, 164, 96));
colorDb.put("LIGHTSALMON", types.color(255, 160, 122));
colorDb.put("DARKSALMON", types.color(233, 150, 122));
colorDb.put("GOLD", types.color(255, 215, 0));
colorDb.put("YELLOW", types.color(255, 255, 0));
colorDb.put("OLIVE", types.color(128, 128, 0));
colorDb.put("BURLYWOOD", types.color(222, 184, 135));
colorDb.put("TAN", types.color(210, 180, 140));
colorDb.put("NAVAJOWHITE", types.color(255, 222, 173));
colorDb.put("PEACHPUFF", types.color(255, 218, 185));
colorDb.put("KHAKI", types.color(240, 230, 140));
colorDb.put("DARKKHAKI", types.color(189, 183, 107));
colorDb.put("MOCCASIN", types.color(255, 228, 181));
colorDb.put("WHEAT", types.color(245, 222, 179));
colorDb.put("BISQUE", types.color(255, 228, 196));
colorDb.put("PALEGOLDENROD", types.color(238, 232, 170));
colorDb.put("BLANCHEDALMOND", types.color(255, 235, 205));
colorDb.put("MEDIUM GOLDENROD", types.color(234, 234, 173));
colorDb.put("MEDIUMGOLDENROD", types.color(234, 234, 173));
colorDb.put("PAPAYAWHIP", types.color(255, 239, 213));
colorDb.put("MISTYROSE", types.color(255, 228, 225));
colorDb.put("LEMONCHIFFON", types.color(255, 250, 205));
colorDb.put("ANTIQUEWHITE", types.color(250, 235, 215));
colorDb.put("CORNSILK", types.color(255, 248, 220));
colorDb.put("LIGHTGOLDENRODYELLOW", types.color(250, 250, 210));
colorDb.put("OLDLACE", types.color(253, 245, 230));
colorDb.put("LINEN", types.color(250, 240, 230));
colorDb.put("LIGHTYELLOW", types.color(255, 255, 224));
colorDb.put("SEASHELL", types.color(255, 245, 238));
colorDb.put("BEIGE", types.color(245, 245, 220));
colorDb.put("FLORALWHITE", types.color(255, 250, 240));
colorDb.put("IVORY", types.color(255, 255, 240));
colorDb.put("GREEN", types.color(0, 255, 0));
colorDb.put("LAWNGREEN", types.color(124, 252, 0));
colorDb.put("CHARTREUSE", types.color(127, 255, 0));
colorDb.put("GREEN YELLOW", types.color(173, 255, 47));
colorDb.put("GREENYELLOW", types.color(173, 255, 47));
colorDb.put("YELLOW GREEN", types.color(154, 205, 50));
colorDb.put("YELLOWGREEN", types.color(154, 205, 50));
colorDb.put("MEDIUM FOREST GREEN", types.color(107, 142, 35));
colorDb.put("OLIVEDRAB", types.color(107, 142, 35));
colorDb.put("MEDIUMFORESTGREEN", types.color(107, 142, 35));
colorDb.put("DARK OLIVE GREEN", types.color(85, 107, 47));
colorDb.put("DARKOLIVEGREEN", types.color(85, 107, 47));
colorDb.put("DARKSEAGREEN", types.color(143, 188, 139));
colorDb.put("LIME", types.color(0, 255, 0));
colorDb.put("DARK GREEN", types.color(0, 100, 0));
colorDb.put("DARKGREEN", types.color(0, 100, 0));
colorDb.put("LIME GREEN", types.color(50, 205, 50));
colorDb.put("LIMEGREEN", types.color(50, 205, 50));
colorDb.put("FOREST GREEN", types.color(34, 139, 34));
colorDb.put("FORESTGREEN", types.color(34, 139, 34));
colorDb.put("SPRING GREEN", types.color(0, 255, 127));
colorDb.put("SPRINGGREEN", types.color(0, 255, 127));
colorDb.put("MEDIUM SPRING GREEN", types.color(0, 250, 154));
colorDb.put("MEDIUMSPRINGGREEN", types.color(0, 250, 154));
colorDb.put("SEA GREEN", types.color(46, 139, 87));
colorDb.put("SEAGREEN", types.color(46, 139, 87));
colorDb.put("MEDIUM SEA GREEN", types.color(60, 179, 113));
colorDb.put("MEDIUMSEAGREEN", types.color(60, 179, 113));
colorDb.put("AQUAMARINE", types.color(112, 216, 144));
colorDb.put("LIGHTGREEN", types.color(144, 238, 144));
colorDb.put("PALE GREEN", types.color(152, 251, 152));
colorDb.put("PALEGREEN", types.color(152, 251, 152));
colorDb.put("MEDIUM AQUAMARINE", types.color(102, 205, 170));
colorDb.put("MEDIUMAQUAMARINE", types.color(102, 205, 170));
colorDb.put("TURQUOISE", types.color(64, 224, 208));
colorDb.put("LIGHTSEAGREEN", types.color(32, 178, 170));
colorDb.put("MEDIUM TURQUOISE", types.color(72, 209, 204));
colorDb.put("MEDIUMTURQUOISE", types.color(72, 209, 204));
colorDb.put("HONEYDEW", types.color(240, 255, 240));
colorDb.put("MINTCREAM", types.color(245, 255, 250));
colorDb.put("ROYALBLUE", types.color(65, 105, 225));
colorDb.put("DODGERBLUE", types.color(30, 144, 255));
colorDb.put("DEEPSKYBLUE", types.color(0, 191, 255));
colorDb.put("CORNFLOWERBLUE", types.color(100, 149, 237));
colorDb.put("STEEL BLUE", types.color(70, 130, 180));
colorDb.put("STEELBLUE", types.color(70, 130, 180));
colorDb.put("LIGHTSKYBLUE", types.color(135, 206, 250));
colorDb.put("DARK TURQUOISE", types.color(0, 206, 209));
colorDb.put("DARKTURQUOISE", types.color(0, 206, 209));
colorDb.put("CYAN", types.color(0, 255, 255));
colorDb.put("AQUA", types.color(0, 255, 255));
colorDb.put("DARKCYAN", types.color(0, 139, 139));
colorDb.put("TEAL", types.color(0, 128, 128));
colorDb.put("SKY BLUE", types.color(135, 206, 235));
colorDb.put("SKYBLUE", types.color(135, 206, 235));
colorDb.put("CADET BLUE", types.color(96, 160, 160));
colorDb.put("CADETBLUE", types.color(95, 158, 160));
colorDb.put("DARK SLATE GRAY", types.color(47, 79, 79));
colorDb.put("DARKSLATEGRAY", types.color(47, 79, 79));
colorDb.put("LIGHTSLATEGRAY", types.color(119, 136, 153));
colorDb.put("SLATEGRAY", types.color(112, 128, 144));
colorDb.put("LIGHT STEEL BLUE", types.color(176, 196, 222));
colorDb.put("LIGHTSTEELBLUE", types.color(176, 196, 222));
colorDb.put("LIGHT BLUE", types.color(173, 216, 230));
colorDb.put("LIGHTBLUE", types.color(173, 216, 230));
colorDb.put("POWDERBLUE", types.color(176, 224, 230));
colorDb.put("PALETURQUOISE", types.color(175, 238, 238));
colorDb.put("LIGHTCYAN", types.color(224, 255, 255));
colorDb.put("ALICEBLUE", types.color(240, 248, 255));
colorDb.put("AZURE", types.color(240, 255, 255));
colorDb.put("MEDIUM BLUE", types.color(0, 0, 205));
colorDb.put("MEDIUMBLUE", types.color(0, 0, 205));
colorDb.put("DARKBLUE", types.color(0, 0, 139));
colorDb.put("MIDNIGHT BLUE", types.color(25, 25, 112));
colorDb.put("MIDNIGHTBLUE", types.color(25, 25, 112));
colorDb.put("NAVY", types.color(36, 36, 140));
colorDb.put("BLUE", types.color(0, 0, 255));
colorDb.put("INDIGO", types.color(75, 0, 130));
colorDb.put("BLUE VIOLET", types.color(138, 43, 226));
colorDb.put("BLUEVIOLET", types.color(138, 43, 226));
colorDb.put("MEDIUM SLATE BLUE", types.color(123, 104, 238));
colorDb.put("MEDIUMSLATEBLUE", types.color(123, 104, 238));
colorDb.put("SLATE BLUE", types.color(106, 90, 205));
colorDb.put("SLATEBLUE", types.color(106, 90, 205));
colorDb.put("PURPLE", types.color(160, 32, 240));
colorDb.put("DARK SLATE BLUE", types.color(72, 61, 139));
colorDb.put("DARKSLATEBLUE", types.color(72, 61, 139));
colorDb.put("DARKVIOLET", types.color(148, 0, 211));
colorDb.put("DARK ORCHID", types.color(153, 50, 204));
colorDb.put("DARKORCHID", types.color(153, 50, 204));
colorDb.put("MEDIUMPURPLE", types.color(147, 112, 219));
colorDb.put("CORNFLOWER BLUE", types.color(68, 64, 108));
colorDb.put("MEDIUM ORCHID", types.color(186, 85, 211));
colorDb.put("MEDIUMORCHID", types.color(186, 85, 211));
colorDb.put("MAGENTA", types.color(255, 0, 255));
colorDb.put("FUCHSIA", types.color(255, 0, 255));
colorDb.put("DARKMAGENTA", types.color(139, 0, 139));
colorDb.put("VIOLET", types.color(238, 130, 238));
colorDb.put("PLUM", types.color(221, 160, 221));
colorDb.put("LAVENDER", types.color(230, 230, 250));
colorDb.put("THISTLE", types.color(216, 191, 216));
colorDb.put("GHOSTWHITE", types.color(248, 248, 255));
colorDb.put("WHITE", types.color(255, 255, 255));
colorDb.put("WHITESMOKE", types.color(245, 245, 245));
colorDb.put("GAINSBORO", types.color(220, 220, 220));
colorDb.put("LIGHT GRAY", types.color(211, 211, 211));
colorDb.put("LIGHTGRAY", types.color(211, 211, 211));
colorDb.put("SILVER", types.color(192, 192, 192));
colorDb.put("GRAY", types.color(190, 190, 190));
colorDb.put("DARK GRAY", types.color(169, 169, 169));
colorDb.put("DARKGRAY", types.color(169, 169, 169));
colorDb.put("DIM GRAY", types.color(105, 105, 105));
colorDb.put("DIMGRAY", types.color(105, 105, 105));
colorDb.put("BLACK", types.color(0, 0, 0));
EXPORTS['_colorDb'] = colorDb;

11
world/js-impl.js Normal file
View File

@ -0,0 +1,11 @@
EXPORTS['is-color?'] =
plt.runtime.makePrimitiveProcedure(
'is-color?',
1,
function(MACHINE) {
var elt = MACHINE.env[MACHINE.env.length - 1];
return (//(plt.runtime.isString(elt) || plt.runtime.isSymbol(elt)) &&
typeof(colorDb.get(elt)) != 'undefined');
});

1739
world/kernel.js Normal file
View File

File diff suppressed because it is too large Load Diff

8
world/main.rkt Normal file
View File

@ -0,0 +1,8 @@
#lang s-exp "../lang/js/js.rkt"
(declare-implementation
#:racket "racket-impl.rkt"
#:javascript ("colordb.js"
"kernel.js"
"js-impl.js")
#:provided-values (is-color?))

6
world/racket-impl.rkt Normal file
View File

@ -0,0 +1,6 @@
#lang s-exp "../lang/base.rkt"
(provide is-color?)
(define (is-color? x)
true)