diff --git a/compiler.rkt b/compiler.rkt index a9e01f3..ff3ca72 100644 --- a/compiler.rkt +++ b/compiler.rkt @@ -6,6 +6,7 @@ "compiler-structs.rkt" "kernel-primitives.rkt" "optimize-il.rkt" + racket/match racket/bool racket/list) @@ -308,40 +309,44 @@ ;; fixme: this is not right yet. This should instead install a module record ;; that has not yet been invoked. ;; fixme: This also needs to generate code for the requires and provides. - (let*: ([after-module-body (make-label 'afterModuleBody)] - [module-entry (make-label 'module-entry)] - [names : (Listof (U False Symbol GlobalBucket ModuleVariable)) - (Prefix-names (Module-prefix mod))] - [module-cenv : CompileTimeEnvironment (list (Module-prefix mod))]) - - (end-with-linkage - linkage cenv - (append-instruction-sequences - (make-instruction-sequence - `(,(make-GotoStatement (make-Label after-module-body)))) - - ;; Module body definition - (apply append-instruction-sequences - (map compile-module-invoke (Module-requires mod))) - - (make-instruction-sequence - `(,module-entry - ,(make-PerformStatement (make-ExtendEnvironment/Prefix! names)))) - ;; TODO: we need to sequester the prefix of the module with the record. - (compile (Module-code mod) - (cons (Module-prefix mod) module-cenv) - target - next-linkage/drop-multiple) - - ;; Cleanup - (make-instruction-sequence - `(,(make-PopEnvironment (make-Const 1) - (make-Const 0)) - ,(make-AssignImmediateStatement 'proc (make-ControlStackLabel)) - ,(make-PopControlFrame) - ,(make-GotoStatement (make-Reg 'proc)))) - - after-module-body)))) + (match mod + [(struct Module (name path prefix requires code)) + (let*: ([after-module-body (make-label 'afterModuleBody)] + [module-entry (make-label 'module-entry)] + [names : (Listof (U False Symbol GlobalBucket ModuleVariable)) + (Prefix-names prefix)] + [module-cenv : CompileTimeEnvironment (list prefix)]) + + (end-with-linkage + linkage cenv + (append-instruction-sequences + (make-instruction-sequence + `(,(make-PerformStatement (make-InstallModuleEntry! name path module-entry)) + ,(make-GotoStatement (make-Label after-module-body)))) + + + module-entry + ;; Module body definition: + ;; 1. First invoke all the modules that this requires. + (apply append-instruction-sequences (map compile-module-invoke (Module-requires mod))) + + ;; 2. Next, evaluate the module body. + (make-instruction-sequence + `(,(make-PerformStatement (make-ExtendEnvironment/Prefix! names)))) + ;; TODO: we need to sequester the prefix of the module with the record. + (compile (Module-code mod) + (cons (Module-prefix mod) module-cenv) + 'val + next-linkage/drop-multiple) + + ;; 3. Finally, cleanup and return. + (make-instruction-sequence + `(,(make-PopEnvironment (make-Const 1) (make-Const 0)) + ,(make-AssignImmediateStatement 'proc (make-ControlStackLabel)) + ,(make-PopControlFrame) + ,(make-GotoStatement (make-Reg 'proc)))) + + after-module-body)))])) (: compile-require (Require CompileTimeEnvironment Target Linkage -> InstructionSequence)) (define (compile-require exp cenv target linkage) @@ -2097,7 +2102,6 @@ (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/expression-structs.rkt b/expression-structs.rkt index a78ba2d..d3707d7 100644 --- a/expression-structs.rkt +++ b/expression-structs.rkt @@ -33,16 +33,10 @@ Require)) - -(define-struct: Provided ([name : Symbol] - [src-name : Symbol]) - #:transparent) - (define-struct: Module ([name : Symbol] [path : ModuleName] [prefix : Prefix] [requires : (Listof ModuleName)] - [provides : (Listof Provided)] [code : Expression]) #:transparent) diff --git a/parameters.rkt b/parameters.rkt index 4d3747a..954f132 100644 --- a/parameters.rkt +++ b/parameters.rkt @@ -1,7 +1,19 @@ #lang typed/racket/base -(require "expression-structs.rkt") -(provide current-defined-name) +(require "expression-structs.rkt" + racket/path) +(provide current-defined-name + current-module-path + current-root-path) (: current-defined-name (Parameterof (U Symbol LamPositionalName))) -(define current-defined-name (make-parameter 'unknown)) \ No newline at end of file +(define current-defined-name (make-parameter 'unknown)) + + +(: current-module-path (Parameterof (U False Path))) +(define current-module-path (make-parameter #f)) + + +(: current-root-path (Parameterof Path)) +(define current-root-path + (make-parameter (normalize-path (current-directory)))) diff --git a/parse-bytecode-5.1.1.rkt b/parse-bytecode-5.1.1.rkt index 9ec38a8..49ef116 100644 --- a/parse-bytecode-5.1.1.rkt +++ b/parse-bytecode-5.1.1.rkt @@ -4,6 +4,7 @@ "lexical-structs.rkt" "typed-module-path.rkt" "path-rewriter.rkt" + "parameters.rkt" syntax/modresolve) @@ -15,14 +16,10 @@ (provide parse-bytecode - ;current-module-path-index-resolver - ;current-module-path-resolver - current-module-path + parse-bytecode/single-module reset-lam-label-counter!/unit-testing) -(define current-module-path (make-parameter #f)) - ;; current-module-path-index-resolver: (module-path-index (U Path #f) -> (U Symbol Path)) -> void ;; The module path index resolver figures out how to translate module path indices to module names. @@ -30,6 +27,8 @@ (make-parameter (lambda (mpi relative-to) (cond + [(eq? mpi #f) + 'self] [(self-module-path-index? mpi) 'self] [else @@ -112,6 +111,29 @@ (parse-top compilation-top)))) + +;; Similar to parse-bytecode, but does a little cleanup to make +;; sure the name is as expected. +(define (parse-bytecode/single-module in path-name) + (let ([parsed (parse-bytecode in)]) + (match parsed + [(struct Top + (prefix + (struct Module (name (struct ModuleName ('self 'self)) + prefix + requires + body)))) + (make-Top prefix + (make-Module name + (make-ModuleName path-name 'self) + prefix + requires + body))]))) + + + + + (define (parse-top a-top) (match a-top [(struct compilation-top (max-let-depth prefix code)) @@ -313,7 +335,6 @@ (make-ModuleName self-path self-path) (parse-prefix prefix) (parse-mod-requires self-modidx requires) - (parse-mod-provides provides) (parse-mod-body body))] [else (let ([rewritten-path (rewrite-path self-path)]) @@ -323,7 +344,6 @@ (make-ModuleName rewritten-path self-path) (parse-prefix prefix) (parse-mod-requires self-modidx requires) - (parse-mod-provides provides) (parse-mod-body body))] [else (error 'parse-mod "Internal error: unable to resolve module path ~s" self-path)]))]))])) @@ -351,21 +371,6 @@ (loop (rest requires))])))) -(define (parse-mod-provides provides) - (let* ([resolver (current-module-path-index-resolver)] - [parse-provided (lambda (a-provided) - (match a-provided - [(struct provided (name src src-name nom-mod src-phase protected? insp)) - ;; fixme: we're not considering all of the fields here... - (make-Provided name src-name)]))]) - (let loop ([provides provides]) - (cond - [(empty? provides) - empty] - [(= (first (first provides)) 0) - (map parse-provided (second (first provides)))] - [else - (loop (rest provides))])))) diff --git a/path-rewriter.rkt b/path-rewriter.rkt index 165d27a..8678384 100644 --- a/path-rewriter.rkt +++ b/path-rewriter.rkt @@ -1,16 +1,14 @@ #lang racket/base -(require racket/path +(require "parameters.rkt" + racket/path racket/contract racket/list racket/runtime-path) -(provide/contract [rewrite-path (complete-path? . -> . (or/c symbol? false/c))] - [current-root-path parameter?]) - - +(provide/contract [rewrite-path (complete-path? . -> . (or/c symbol? false/c))]) @@ -21,9 +19,6 @@ -(define current-root-path - (make-parameter (normalize-path (current-directory)))) - ;; The path rewriter takes paths and provides a canonical symbol for it. ;; Paths located within collects get remapped to collects, those within diff --git a/test-parse-bytecode-5.1.1.rkt b/test-parse-bytecode-5.1.1.rkt index 517bffe..2069297 100644 --- a/test-parse-bytecode-5.1.1.rkt +++ b/test-parse-bytecode-5.1.1.rkt @@ -4,6 +4,7 @@ rackunit racket/match (for-syntax racket/base) + "parameters.rkt" "parse-bytecode-5.1.1.rkt" "lexical-structs.rkt" "expression-structs.rkt") @@ -335,7 +336,6 @@ (? ModuleName?) (? Prefix?) ;; the prefix will include a reference to print-values. _ ;; requires - _ ;; provides (struct Splice ((list (struct ApplyValues ((struct ToplevelRef ('0 '0)) (struct Constant ('42))))))))))) #t])) @@ -350,7 +350,6 @@ (? ModuleName?) (? Prefix?) ;; the prefix will include a reference to print-values. _ ;; requires - (list (struct Provided ('x 'x))) ;; provides (struct Splice ((list (struct DefValues ((list (struct ToplevelRef ('0 '0))) (struct Constant ("x"))))))))))) @@ -391,11 +390,28 @@ +(void + (run-my-parse #'(module foo '#%kernel + (define-values (f) 42) + (#%provide f)))) + - - - - +(check-true + (match (parameterize ([current-root-path (build-path "/blah")] + [current-module-path (build-path "/blah" "foo" "bar.rkt")]) + (run-my-parse '(module foo '#%kernel + (define-values (f) 'ok) + (#%provide f)))) + [(struct Top ((struct Prefix ((list '#f))) + (struct Module ('foo + (struct ModuleName ('self _ #;(build-path "root/foo/bar.rkt"))) + (struct Prefix ((list 'f))) + (list (struct ModuleName ('#%kernel '#%kernel))) + (struct Splice ((list (struct DefValues ((list (struct ToplevelRef (0 0))) + (struct Constant ('ok))))))))))) + '#t])) + + #;(parameterize ([current-module-path "/home/dyoo/local/racket-5.1.1/lib/racket/collects/racket/private/foo.rkt"]) (run-my-parse/file "/home/dyoo/local/racket-5.1.1/lib/racket/collects/racket/private/for.rkt"))