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

added in a path rewriter

Browse Source
This commit is contained in:
Danny Yoo 2011-05-13 14:50:25 -04:00
parent cceec4ccd7
commit 2bb4666645
5 changed files with 44 additions and 25 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

1
compiler.rkt
View File

@ -2081,6 +2081,7 @@
[(Module? exp) [(Module? exp)
(make-Module (Module-name exp) (make-Module (Module-name exp)
(Module-path exp)
(Module-prefix exp) (Module-prefix exp)
(Module-requires exp) (Module-requires exp)
(Module-provides exp) (Module-provides exp)

3
expression-structs.rkt
View File

@ -36,7 +36,8 @@
[src-name : Symbol]) [src-name : Symbol])
#:transparent) #:transparent)
(define-struct: Module ([name : ModuleName] (define-struct: Module ([name : Symbol]
[path : ModuleName]
[prefix : Prefix] [prefix : Prefix]
[requires : (Listof ModuleName)] [requires : (Listof ModuleName)]
[provides : (Listof Provided)] [provides : (Listof Provided)]

24
parse-bytecode-5.1.1.rkt
View File

@ -3,6 +3,7 @@
(require "expression-structs.rkt" (require "expression-structs.rkt"
"lexical-structs.rkt" "lexical-structs.rkt"
"typed-module-path.rkt" "typed-module-path.rkt"
"path-rewriter.rkt"
syntax/modresolve) syntax/modresolve)
@ -151,9 +152,8 @@
[(symbol? resolved-path-name) [(symbol? resolved-path-name)
(make-ModuleName resolved-path-name)] (make-ModuleName resolved-path-name)]
[(path? resolved-path-name) [(path? resolved-path-name)
(make-ModuleName (make-ModuleName (rewrite-path resolved-path-name))]))
(string->symbol
(path->string resolved-path-name)))]))
;; parse-form: form -> (U Expression) ;; parse-form: form -> (U Expression)
@ -240,11 +240,25 @@
[(struct mod (name srcname self-modidx prefix provides requires [(struct mod (name srcname self-modidx prefix provides requires
body syntax-body unexported max-let-depth dummy lang-info body syntax-body unexported max-let-depth dummy lang-info
internal-context)) internal-context))
(make-Module (make-ModuleName name) (let ([self-path
((current-module-path-index-resolver)
self-modidx
(current-module-path))])
(cond
[(symbol? self-path)
(make-Module name
(make-ModuleName self-path)
(parse-prefix prefix) (parse-prefix prefix)
(parse-mod-requires self-modidx requires) (parse-mod-requires self-modidx requires)
(parse-mod-provides provides) (parse-mod-provides provides)
(parse-mod-body body))])) (parse-mod-body body))]
[else
(make-Module name
(make-ModuleName (rewrite-path self-path))
(parse-prefix prefix)
(parse-mod-requires self-modidx requires)
(parse-mod-provides provides)
(parse-mod-body body))]))]))
;; parse-mod-requires: module-path-index (listof (pair (U Integer #f) (listof module-path-index))) -> (listof ModuleName) ;; parse-mod-requires: module-path-index (listof (pair (U Integer #f) (listof module-path-index))) -> (listof ModuleName)

5
path-rewriter.rkt
View File

@ -21,8 +21,9 @@
;; Paths located within collects get remapped to collects/.... ;; Paths located within collects get remapped to collects/....
;; rewrite-path: complete-path -> (symbol #f) ;; rewrite-path: path -> (symbol #f)
(define (rewrite-path a-path) (define (rewrite-path a-path)
(let ([a-path (normalize-path a-path)])
(cond (cond
[(within-collects? a-path) [(within-collects? a-path)
(string->symbol (string->symbol
@ -35,7 +36,7 @@
(path->string (path->string
(find-relative-path (current-root-path) a-path))))] (find-relative-path (current-root-path) a-path))))]
[else [else
#f])) #f])))
(define collects (define collects

6
test-parse-bytecode-5.1.1.rkt
View File

@ -331,7 +331,8 @@
(match (run-my-parse #'(module foo racket/base (match (run-my-parse #'(module foo racket/base
42)) 42))
[(struct Top ((struct Prefix (list)) [(struct Top ((struct Prefix (list))
(struct Module ((? ModuleName?) (struct Module ((? symbol?)
(? ModuleName?)
(? Prefix?) ;; the prefix will include a reference to print-values. (? Prefix?) ;; the prefix will include a reference to print-values.
_ ;; requires _ ;; requires
_ ;; provides _ ;; provides
@ -345,7 +346,8 @@
(provide x) (provide x)
(define x "x"))) (define x "x")))
[(struct Top ((struct Prefix ((? list?))) [(struct Top ((struct Prefix ((? list?)))
(struct Module ((? ModuleName?) (struct Module ((? symbol?)
(? ModuleName?)
(? Prefix?) ;; the prefix will include a reference to print-values. (? Prefix?) ;; the prefix will include a reference to print-values.
_ ;; requires _ ;; requires
(list (struct Provided ('x 'x))) ;; provides (list (struct Provided ('x 'x))) ;; provides