ripping out provides, since we don't need it.
This commit is contained in:
Danny Yoo
parent
fee35c3860
commit
1f9b870b91
74
compiler.rkt
74
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)
|
||||
|
|
|
|||
|
|
@ -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)
|
||||
|
||||
|
|
|
|||
|
|
@ -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))
|
||||
(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))))
|
||||
|
|
|
|||
|
|
@ -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))]))))
|
||||
|
||||
|
||||
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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"))
|
||||
|
|
|
|||
Loading…
Reference in New Issue
Block a user