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

more submodule repairs for `raco exe'

Browse Source
This commit is contained in:
Matthew Flatt 2012-07-16 09:49:39 -06:00
parent 9dac995e36
commit a605183a0a
8 changed files with 96 additions and 14 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

54
collects/compiler/embed-unit.rkt
View File

@ -371,6 +371,10 @@
[just-filename (if (pair? filename) [just-filename (if (pair? filename)
(cadr filename) (cadr filename)
filename)] filename)]
[root-module-path (if (and (pair? module-path)
(eq? 'submod (car module-path)))
(cadr module-path)
module-path)]
[actual-filename just-filename] ; `set!'ed below to adjust file suffix [actual-filename just-filename] ; `set!'ed below to adjust file suffix
[name (let-values ([(base name dir?) (split-path just-filename)]) [name (let-values ([(base name dir?) (split-path just-filename)])
(path->string (path-replace-suffix name #"")))] (path->string (path-replace-suffix name #"")))]
@ -468,9 +472,13 @@
null) null)
#t #t
null)]) null)])
(let ([sub-files (map (lambda (i) (normalize (resolve-module-path-index i filename))) (let ([sub-files (map (lambda (i)
;; use `just-filename', because i has submod name embedded
(normalize (resolve-module-path-index i just-filename)))
all-file-imports)] all-file-imports)]
[sub-paths (map (lambda (i) (collapse-module-path-index i module-path)) [sub-paths (map (lambda (i)
;; use `root-module-path', because i has submod name embedded
(collapse-module-path-index i root-module-path))
all-file-imports)] all-file-imports)]
[normalized-extra-paths (map (lambda (i) (collapse-module-path i module-path)) [normalized-extra-paths (map (lambda (i) (collapse-module-path i module-path))
(append extra-runtime-paths extra-paths))] (append extra-runtime-paths extra-paths))]
@ -628,7 +636,7 @@
[(library-table) (quote [(library-table) (quote
,(filter values ,(filter values
(map (lambda (m) (map (lambda (m)
(let ([path (mod-mod-path m)]) (let loop ([path (mod-mod-path m)])
(cond (cond
[(and (pair? path) [(and (pair? path)
(eq? 'lib (car path))) (eq? 'lib (car path)))
@ -639,6 +647,12 @@
;; Normalize planet path ;; Normalize planet path
(cons (collapse-module-path path current-directory) (cons (collapse-module-path path current-directory)
(mod-full-name m))] (mod-full-name m))]
[(and (pair? path)
(eq? 'submod (car path)))
(define m (loop (cadr path)))
(and m
(cons `(submod ,(car m) ,@(cddr path))
(cdr m)))]
[else #f]))) [else #f])))
code-l)))]) code-l)))])
(hash-set! regs (hash-set! regs
@ -701,9 +715,16 @@
(let-values ([(lname) (let-values ([(lname)
;; normalize `lib' to single string (same as lib-path->string): ;; normalize `lib' to single string (same as lib-path->string):
(let-values ([(name) (let-values ([(name)
(let-values ([(name)
;; remove submod path; added back at end
(if (pair? name)
(if (eq? 'submod (car name))
(cadr name)
name)
name)])
(if (symbol? name) (if (symbol? name)
(list 'lib (symbol->string name)) (list 'lib (symbol->string name))
name)]) name))])
(if (pair? name) (if (pair? name)
(if (eq? 'lib (car name)) (if (eq? 'lib (car name))
(if (null? (cddr name)) (if (null? (cddr name))
@ -803,18 +824,39 @@
#t #t
#f) #f)
#f)) #f))
#f))]) #f))]
[(restore-submod) (lambda (lname)
(if (pair? name)
(if (eq? (car name) 'submod)
(list* 'submod lname (cddr name))
lname)
lname))])
;; A library mapping that we have? ;; A library mapping that we have?
(let-values ([(a3) (if lname (let-values ([(a3) (if lname
(if (string? lname) (if (string? lname)
;; lib ;; lib
(assoc lname library-table) (assoc (restore-submod lname) library-table)
;; planet ;; planet
(ormap (lambda (e) (ormap (lambda (e)
(let-values ([(e)
;; handle submodule matching first:
(if (pair? name)
(if (eq? (car name) 'submod)
(if (pair? (car e))
(if (eq? (caar e) 'submod)
(if (equal? (cddar e) (cddr name))
(cons (cadar e) (cdr e))
#f)
#f)
#f)
e)
e)])
(if e
(if (string? (car e)) (if (string? (car e))
#f #f
(if (planet-match? (cdar e) (cdr lname)) (if (planet-match? (cdar e) (cdr lname))
e e
#f))
#f))) #f)))
library-table)) library-table))
#f)]) #f)])

2
collects/tests/racket/embed-me17.rkt Normal file
View File

@ -0,0 +1,2 @@
#lang racket/base
(require (submod "embed-me17a.rkt" sub))

9
collects/tests/racket/embed-me17a.rkt Normal file
View File

@ -0,0 +1,9 @@
#lang racket
(define print-17
(lambda () (printf "This is 17.\n")))
(module+ sub
(with-output-to-file "stdout"
print-17
#:exists 'append))

5
collects/tests/racket/embed-me18.rkt Normal file
View File

@ -0,0 +1,5 @@
#lang racket/base
(require (submod tests/racket/embed-me18a sub))
(with-output-to-file "stdout"
(dynamic-require '(submod tests/racket/embed-me18a sub) 'print-18)
#:exists 'append)

9
collects/tests/racket/embed-me18a.rkt Normal file
View File

@ -0,0 +1,9 @@
#lang racket/base
(module sub racket/base
(provide print-18)
(define (print-18)
(printf "This is 18.\n")))

8
collects/tests/racket/embed-planet-1/dyn-sub.rkt Normal file
View File

@ -0,0 +1,8 @@
#lang racket/base
(require (submod (planet racket-tester/p1/has-sub) the-sub))
(with-output-to-file "stdout"
#:exists 'append
(lambda () (displayln (dynamic-require
'(submod (planet racket-tester/p1/has-sub) the-sub)
'out))))

5
collects/tests/racket/embed-planet-1/has-sub.rkt
View File

@ -1,3 +1,6 @@
#lang racket/base #lang racket/base
(module+ the-sub) (module+ the-sub
(provide out)
(define out 'out))

4
collects/tests/racket/embed.rktl
View File

@ -224,6 +224,8 @@
(one-mz-test "embed-me13.rkt" "This is 14\n" #f) (one-mz-test "embed-me13.rkt" "This is 14\n" #f)
(one-mz-test "embed-me14.rkt" "This is 14\n" #f) (one-mz-test "embed-me14.rkt" "This is 14\n" #f)
(one-mz-test "embed-me15.rkt" "This is 15.\n" #f) (one-mz-test "embed-me15.rkt" "This is 15.\n" #f)
(one-mz-test "embed-me17.rkt" "This is 17.\n" #f)
(one-mz-test "embed-me18.rkt" "This is 18.\n" #f)
;; Try unicode expr and cmdline: ;; Try unicode expr and cmdline:
(prepare dest "unicode") (prepare dest "unicode")
@ -501,6 +503,8 @@
(go '(planet "private/sub.ss" ("racket-tester" "p2.plt" 2 0)) "two\nsub\n") (go '(planet "private/sub.ss" ("racket-tester" "p2.plt" 2 0)) "two\nsub\n")
(go '(planet "main.ss" ("racket-tester" "p2.plt" 2 0)) "two\n") (go '(planet "main.ss" ("racket-tester" "p2.plt" 2 0)) "two\n")
(go '(planet racket-tester/p1/dyn-sub) "out\n")
(void)) (void))
(system* planet "unlink" "racket-tester" "p1.plt" "1" "0") (system* planet "unlink" "racket-tester" "p1.plt" "1" "0")