starting to get the javascript-implemented module stuff working

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)

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)
 

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;
+           var modrec = MACHINE.modules[~s];
-           (function(MACHINE, EXPORTS){~a})(MACHINE, MACHINE.modules[~s].namespace);
+           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,7 +121,7 @@ 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)
@@ -108,6 +130,10 @@ MACHINE.modules[~s] =
         
 
 
+
+
+
+
 ;; package: Source (path -> boolean) output-port -> void
 
 ;; Compile package for the given source program.

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;

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

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

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))
@@ -60,3 +64,20 @@
        (redirection-to (car redirections))]
       [else
        (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))])))

make/make.rkt

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

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

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

world/kernel.js

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

world/main.rkt

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