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

fix place and raco exe

Browse Source 
The repair involves making `raco exe` detect a sub-submodule
whose name is `declare-preserve-for-embedding` as an indication
that a submodule should be carried along with its enclosing module.

Normally, `define-runtime-module-path-index` would do that, but
the submodule for `place` is created with `syntax-local-lift-module`,
and the point of `syntax-local-lift-module` is to work in a
nested experssion context where definitions cannot be lifted
to the enclosing module.
This commit is contained in:
Matthew Flatt 2016-01-04 10:59:32 -07:00
parent 5cf748d734
commit d37ee8c5b1
3 changed files with 51 additions and 18 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

8
pkgs/racket-doc/scribblings/raco/exe.scrbl
View File

@ -49,7 +49,10 @@ created executable. Such modules can be explicitly included using the
@racket[define-runtime-path] to embed references to the run-time files
in the executable; the files are then copied and packaged together
with the executable when creating a distribution (as described in
@secref["exe-dist"]).
@secref["exe-dist"]). Finally, a submodule is included if its
enclosing module is included and the submodule contains a
sub-submodule named @racketidfont{declare-preserve-for-embedding}
(where the implementation of the sub-submodule is ignored).
Modules that are implemented directly by extensions---i.e., extensions
that are automatically loaded from @racket[(build-path "compiled"
@ -172,6 +175,9 @@ The @exec{raco exe} command accepts the following command-line flags:
]
@history[#:changed "6.3.0.11" @elem{Added support for
@racketidfont{declare-preserve-for-embedding}.}]
@; ----------------------------------------------------------------------
@include-section["exe-api.scrbl"]

42
racket/collects/compiler/embed.rkt
View File

@ -571,8 +571,9 @@
(if (or (null? use-submods)
use-source?)
null
(for/list ([m l]
#:when (member (cadr (module-compiled-name m)) use-submods))
(for/list ([m (in-list l)]
#:when (or (member (last (module-compiled-name m)) use-submods)
(declares-always-preserved? m)))
m)))]
[pre-submods (extract-submods (module-compiled-submodules renamed-code #t))]
[post-submods (extract-submods (module-compiled-submodules renamed-code #f))]
@ -756,6 +757,12 @@
(apply append
(map accum-from-mod (module-compiled-submodules mod #f))))))
(define (declares-always-preserved? m)
(for/or ([s (in-list
(append (module-compiled-submodules m #t)
(module-compiled-submodules m #f)))])
(eq? (last (module-compiled-name s)) 'declare-preserve-for-embedding)))
;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(define (compile-using-kernel e)
@ -825,7 +832,7 @@
(namespace-module-registry (current-namespace))
(vector mapping-table library-table))
(letrec-values ([(lookup)
(lambda (name rel-to stx load? orig)
(lambda (name rel-to stx load? for-submod? orig)
(if (not (module-path? name))
;; Bad input
(orig name rel-to stx load?)
@ -1018,8 +1025,17 @@
(if a3
;; Have it:
(make-resolved-module-path (cdr a3))
;; Let default handler try:
(orig name rel-to stx load?)))))))))))]
(if (if for-submod?
(if (pair? name)
(if (eq? (car name) 'quote)
(assq (cadr name) mapping-table)
#f)
#f)
#f)
;; Report that we have mappings relative to `name`:
(make-resolved-module-path (cadr name))
;; Let default handler try:
(orig name rel-to stx load?))))))))))))]
[(embedded-resolver)
(case-lambda
[(name from-namespace)
@ -1055,20 +1071,26 @@
(void))
(orig name from-namespace)]
[(name rel-to stx load?)
(lookup name rel-to stx load?
(lookup name rel-to stx load? #f
(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))
;; Pass #t for `for-submod?`, which causes a
;; resolved module name to be returned for a quoted
;; module name if we have any relative mappings for it:
(lookup (cadr name) rel-to stx load? #t (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)))
;; don't chain to `orig'; try `lookup` again with `(submod "." ...)`,
;; and if that still fails, just construct a submodule path:
(lookup (cons 'submod (cons "." (cddr name))) base stx load? #f
(lambda (name rel-to stx load?)
(make-resolved-module-path
(cons (resolved-module-path-name base) (cddr name)))))
;; chain to `orig':
(orig name rel-to stx load?)))))])])
(current-module-name-resolver embedded-resolver))))))

19
racket/collects/racket/place.rkt
View File

@ -11,6 +11,7 @@
racket/place/private/prop
racket/private/streams
racket/match
racket/runtime-path
(for-syntax racket/base
@ -186,7 +187,7 @@
(syntax-case stx ()
[(who ch body1 body ...)
(if (eq? (syntax-local-context) 'module-begin)
;; when a `place' form is the only thing in a module mody:
;; when a `place' form is the only thing in a module body:
#`(begin #,stx)
;; normal case:
(let ()
@ -200,10 +201,14 @@
(string->symbol
(format "place-body-~a" place-body-counter))))
(with-syntax ([internal-def-name
(syntax-local-lift-module #`(module* #,module-name-stx #f
(provide main)
(define (main ch)
body1 body ...)))]
(syntax-local-lift-module
#`(module* #,module-name-stx #f
(provide main)
(define (main ch)
body1 body ...)
;; The existence of this submodule makes the
;; enclosing submodule preserved by `raco exe`:
(module declare-preserve-for-embedding '#%kernel)))]
[in _in]
[out _out]
[err _err]
@ -236,9 +241,9 @@
(error who "the enclosing module's resolved name is not a path or predefined"))
(define submod-ref
(match name
[(? symbol?) `(quote 'name)]
[(? symbol?) `(submod (quote ,name) ,submod-name)]
[(? path?) `(submod ,name ,submod-name)]
[`(,p ,s ...) `(submod ,p ,@s ,submod-name)]))
[`(,p ,s ...) `(submod ,(if (symbol? p) `(quote ,p) p) ,@s ,submod-name)]))
(start-place-func who submod-ref 'main in out err))
(define-syntax (place/context stx)