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

raco exe: handle failing submodule search correctly

Browse Source 
An attempt to detect a submodule could trigger the original module
name resolver when the would-be enclosing module would be handled
by the embedding-specific resolver. When a submodule is not found
but its would-be enclosing module is embedded, then assume that
the default resolver wouldn't find the submodule, eithe --- and
therefore avoid a potential "collection not found" error.
This commit is contained in:
Matthew Flatt 2012-09-23 10:47:24 -05:00
parent 909a6fb5c7
commit 3fb12b4ff4
3 changed files with 68 additions and 36 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

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

@ -658,41 +658,8 @@
(hash-set! regs (hash-set! regs
(namespace-module-registry (current-namespace)) (namespace-module-registry (current-namespace))
(vector mapping-table library-table)) (vector mapping-table library-table))
(letrec-values ([(embedded-resolver) (letrec-values ([(lookup)
(case-lambda (lambda (name rel-to stx load? orig)
[(name from-namespace)
;; A notification
(if from-namespace
;; If the source namespace has a mapping for `name',
;; then copy it to the current namespace.
(let-values ([(name) (if name (resolved-module-path-name name) #f)])
(let-values ([(src-vec) (hash-ref regs (namespace-module-registry from-namespace) #f)])
(let-values ([(a) (if src-vec
(assq name (vector-ref src-vec 0))
#f)])
(if a
(let-values ([(vec) (hash-ref regs (namespace-module-registry (current-namespace))
(lambda ()
(let-values ([(vec) (vector null null)])
(hash-set! regs (namespace-module-registry (current-namespace)) vec)
vec)))])
;; add mapping:
(vector-set! vec 0 (cons a (vector-ref vec 0)))
;; add library mappings:
(vector-set! vec 1 (append
(letrec-values ([(loop)
(lambda (l)
(if (null? l)
null
(if (eq? (cdar l) name)
(cons (car l) (loop (cdr l)))
(loop (cdr l)))))])
(loop library-table))
(vector-ref vec 1))))
(void)))))
(void))
(orig name from-namespace)]
[(name rel-to stx load?)
(if (not (module-path? name)) (if (not (module-path? name))
;; Bad input ;; Bad input
(orig name rel-to stx load?) (orig name rel-to stx load?)
@ -867,7 +834,58 @@
;; Have it: ;; Have it:
(make-resolved-module-path (cdr a3)) (make-resolved-module-path (cdr a3))
;; Let default handler try: ;; Let default handler try:
(orig name rel-to stx load?))))))))))])]) (orig name rel-to stx load?)))))))))))]
[(embedded-resolver)
(case-lambda
[(name from-namespace)
;; A notification
(if from-namespace
;; If the source namespace has a mapping for `name',
;; then copy it to the current namespace.
(let-values ([(name) (if name (resolved-module-path-name name) #f)])
(let-values ([(src-vec) (hash-ref regs (namespace-module-registry from-namespace) #f)])
(let-values ([(a) (if src-vec
(assq name (vector-ref src-vec 0))
#f)])
(if a
(let-values ([(vec) (hash-ref regs (namespace-module-registry (current-namespace))
(lambda ()
(let-values ([(vec) (vector null null)])
(hash-set! regs (namespace-module-registry (current-namespace)) vec)
vec)))])
;; add mapping:
(vector-set! vec 0 (cons a (vector-ref vec 0)))
;; add library mappings:
(vector-set! vec 1 (append
(letrec-values ([(loop)
(lambda (l)
(if (null? l)
null
(if (eq? (cdar l) name)
(cons (car l) (loop (cdr l)))
(loop (cdr l)))))])
(loop library-table))
(vector-ref vec 1))))
(void)))))
(void))
(orig name from-namespace)]
[(name rel-to stx load?)
(lookup name rel-to stx load?
(lambda (name rel-to stx load?)
;; For a submodule, if we have a mapping for the base name,
;; then don't try the original handler.
(let-values ([(base)
(if (pair? name)
(if (eq? (car name) 'submod)
(lookup (cadr name) rel-to stx load? (lambda (n r s l?) #f))
#f)
#f)])
(if base
;; don't chain to `orig':
(make-resolved-module-path
(list* 'submod (resolved-module-path-name base) (cddr name)))
;; chain to `orig':
(orig name rel-to stx load?)))))])])
(current-module-name-resolver embedded-resolver)))))) (current-module-name-resolver embedded-resolver))))))
(define (ss<->rkt path) (define (ss<->rkt path)

13
collects/tests/racket/embed-me19.rkt Normal file
View File

@ -0,0 +1,13 @@
#lang racket/base
(require racket/runtime-path)
(define-runtime-module-path plai plai)
(define-runtime-module-path plai-reader plai/lang/reader)
(parameterize ([read-accept-reader #t])
(namespace-require 'racket/base)
(eval (read (open-input-string "#lang plai 10"))))
(with-output-to-file "stdout"
(lambda () (printf "This is 19.\n"))
#:exists 'append)

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

@ -226,6 +226,7 @@
(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-me17.rkt" "This is 17.\n" #f)
(one-mz-test "embed-me18.rkt" "This is 18.\n" #f) (one-mz-test "embed-me18.rkt" "This is 18.\n" #f)
(one-mz-test "embed-me19.rkt" "This is 19.\n" #f)
;; Try unicode expr and cmdline: ;; Try unicode expr and cmdline:
(prepare dest "unicode") (prepare dest "unicode")