From dbfe7c3d2c1de9dbf0a054a4572f105a40363139 Mon Sep 17 00:00:00 2001 From: Danny Yoo Date: Thu, 9 Jun 2011 16:13:21 -0400 Subject: [PATCH] starting to get the javascript-implemented module stuff working --- compiler/compiler.rkt | 3 ++- compiler/expression-structs.rkt | 8 +++++++ js-assembler/package.rkt | 34 +++++++++++++++++++++++++---- js-assembler/runtime-src/runtime.js | 7 ++++++ lang/js/js.rkt | 13 +++++++---- lang/js/query.rkt | 12 +++++++++- lang/js/record.rkt | 25 +++++++++++++++++++-- make/make.rkt | 1 + parser/parse-bytecode-5.1.1.rkt | 32 +++++++++++++++++++++++++++ world/js-impl.js | 11 ++++++++++ world/kernel.js | 3 ++- world/main.rkt | 9 +++++--- 12 files changed, 142 insertions(+), 16 deletions(-) create mode 100644 world/js-impl.js diff --git a/compiler/compiler.rkt b/compiler/compiler.rkt index 867e639..d57af6e 100644 --- a/compiler/compiler.rkt +++ b/compiler/compiler.rkt @@ -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) diff --git a/compiler/expression-structs.rkt b/compiler/expression-structs.rkt index 7407ade..66f2c13 100644 --- a/compiler/expression-structs.rkt +++ b/compiler/expression-structs.rkt @@ -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) diff --git a/js-assembler/package.rkt b/js-assembler/package.rkt index f8a7c96..6f5442a 100644 --- a/js-assembler/package.rkt +++ b/js-assembler/package.rkt @@ -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)])) + + + + diff --git a/js-assembler/runtime-src/runtime.js b/js-assembler/runtime-src/runtime.js index 24a30ea..e1cf282 100644 --- a/js-assembler/runtime-src/runtime.js +++ b/js-assembler/runtime-src/runtime.js @@ -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; diff --git a/lang/js/js.rkt b/lang/js/js.rkt index 1fbe655..19905ee 100644 --- a/lang/js/js.rkt +++ b/lang/js/js.rkt @@ -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 diff --git a/lang/js/query.rkt b/lang/js/query.rkt index ea8731a..f00eaa1 100644 --- a/lang/js/query.rkt +++ b/lang/js/query.rkt @@ -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)))) diff --git a/lang/js/record.rkt b/lang/js/record.rkt index 54452ed..7f3b235 100644 --- a/lang/js/record.rkt +++ b/lang/js/record.rkt @@ -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))]))) \ No newline at end of file + (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))]))) diff --git a/make/make.rkt b/make/make.rkt index 45f02b0..fbde27f 100644 --- a/make/make.rkt +++ b/make/make.rkt @@ -85,6 +85,7 @@ (and path (? ModuleLocator?)) prefix requires + provides code)))) path] [else diff --git a/parser/parse-bytecode-5.1.1.rkt b/parser/parse-bytecode-5.1.1.rkt index c115d65..8579330 100644 --- a/parser/parse-bytecode-5.1.1.rkt +++ b/parser/parse-bytecode-5.1.1.rkt @@ -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))])))) + + + diff --git a/world/js-impl.js b/world/js-impl.js new file mode 100644 index 0000000..b0a2078 --- /dev/null +++ b/world/js-impl.js @@ -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'); + }); diff --git a/world/kernel.js b/world/kernel.js index adacd7d..a8f2642 100644 --- a/world/kernel.js +++ b/world/kernel.js @@ -1,8 +1,9 @@ var world = {}; world.Kernel = {}; -EXPORTS['kernel'] = world.Kernel; +EXPORTS['_kernel'] = world.Kernel; +var types = plt.types; diff --git a/world/main.rkt b/world/main.rkt index a9ec0c1..dc9df3a 100644 --- a/world/main.rkt +++ b/world/main.rkt @@ -1,5 +1,8 @@ #lang s-exp "../lang/js/js.rkt" -(declare-implementation #:racket "racket-impl.rkt" - #:javascript ("colordb.js" - "kernel.js")) \ No newline at end of file +(declare-implementation + #:racket "racket-impl.rkt" + #:javascript ("colordb.js" + "kernel.js" + "js-impl.js") + #:provided-values (is-color?)) \ No newline at end of file