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

starting to get the javascript-implemented module stuff working

Browse Source
This commit is contained in:
Danny Yoo 2011-06-09 16:13:21 -04:00
parent 47f668832e
commit dbfe7c3d2c
12 changed files with 142 additions and 16 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

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)

34
js-assembler/package.rkt
View File

@ -5,7 +5,9 @@
"../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)
@ -76,6 +78,18 @@
;; 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)]
@ -83,15 +97,23 @@
(get-javascript-implementation (MainModuleSource-source src))]
[(ModuleSource? src)
(let ([name (rewrite-path (ModuleSource-path src))]
[text (query:query `(file ,(path->string (ModuleSource-path src))))])
[text (query:query `(file ,(path->string (ModuleSource-path src))))]
[bytecode (parse-bytecode (ModuleSource-path src))])
(printf "bytecode: ~s\n" bytecode)
(make-UninterpretedSource
(format "
MACHINE.modules[~s] =
new plt.runtime.ModuleRecord(~s,
function(MACHINE) {
if(--MACHINE.callsBeforeTrampoline<0) { throw arguments.callee; }
MACHINE.modules[~s].isInvoked = true;
(function(MACHINE, EXPORTS){~a})(MACHINE, MACHINE.modules[~s].namespace);
var modrec = MACHINE.modules[~s];
var exports = {};
modrec.isInvoked = true;
(function(MACHINE, EXPORTS){~a})(MACHINE, exports);
// FIXME: we need to inject the namespace with the values defined in exports.
~a
return MACHINE.control.pop().label(MACHINE);
});
"
@ -99,12 +121,16 @@ MACHINE.modules[~s] =
(symbol->string name)
(symbol->string name)
text
(symbol->string name))))]
(get-provided-name-code bytecode))))]
[(SexpSource? src)
(error 'get-javascript-implementation)]
[(UninterpretedSource? src)
(error 'get-javascript-implementation)]))

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

@ -531,6 +531,12 @@ if(this['plt'] === undefined) { this['plt'] = {}; }
Primitives[name].displayName = name;
};
var makePrimitiveProcedure = function(name, arity, f) {
f.arity = arity;
f.displayName = name;
return f;
};
var installPrimitiveConstant = function(name, v) {
Primitives[name] = v;
};
@ -1392,6 +1398,7 @@ if(this['plt'] === undefined) { this['plt'] = {}; }
// installing new primitives
exports['installPrimitiveProcedure'] = installPrimitiveProcedure;
exports['makePrimitiveProcedure'] = makePrimitiveProcedure;
exports['Primitives'] = Primitives;
exports['ready'] = ready;

13
lang/js/js.rkt
View File

@ -20,7 +20,8 @@
(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,10 +44,13 @@
[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-implementation

12
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/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))])))

1
make/make.rkt
View File

@ -85,6 +85,7 @@
(and path (? ModuleLocator?))
prefix
requires
provides
code))))
path]
[else

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

@ -162,12 +162,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]))
@ -368,6 +370,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)])
@ -378,6 +381,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)]))]))]))
@ -406,6 +410,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))]))))

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');
});

3
world/kernel.js
View File

@ -1,8 +1,9 @@
var world = {};
world.Kernel = {};
EXPORTS['kernel'] = world.Kernel;
EXPORTS['_kernel'] = world.Kernel;
var types = plt.types;

9
world/main.rkt
View File

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