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

emptied the namespace when executing a module

Browse Source 
svn: r9923
This commit is contained in:
Robby Findler 2008-05-21 17:43:14 +00:00
parent c5ef53525a
commit c5f4bc9e20
5 changed files with 579 additions and 561 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

26
collects/drscheme/private/language.ss
View File

@ -567,7 +567,7 @@
(super-new))) (super-new)))
;; create-module-based-language-executable : ;; create-module-based-language-executable :
;; (is-a?/c area-container<%>) string module-spec module-spec sexp (union boolean? 'ask) boolean? ;; (is-a?/c area-container<%>) string (or #f module-spec) module-spec sexp (union boolean? 'ask) boolean?
;; -> void ;; -> void
(define (create-module-based-language-executable parent (define (create-module-based-language-executable parent
program-filename program-filename
@ -890,11 +890,13 @@
(call-with-output-file bootstrap-tmp-filename (call-with-output-file bootstrap-tmp-filename
(λ (port) (λ (port)
(write `(let () ;; cannot use begin, since it gets flattened to top-level (and re-compiled!) (write `(let () ;; cannot use begin, since it gets flattened to top-level (and re-compiled!)
,@(if use-copy? ,@(if module-language-spec
(if use-copy?
(list (list
`(namespace-require/copy ',module-language-spec)) `(namespace-require/copy ',module-language-spec))
(list (list
`(namespace-require/constant ',module-language-spec))) `(namespace-require/constant ',module-language-spec)))
'())
,@(if transformer-module-language-spec ,@(if transformer-module-language-spec
(list `(namespace-require `(for-syntax ,transformer-module-language-spec))) (list `(namespace-require `(for-syntax ,transformer-module-language-spec)))
(list)) (list))
@ -914,11 +916,16 @@
#:exists 'truncate #:mode 'text))) #:exists 'truncate #:mode 'text)))
(let* ([pre-to-be-embedded-module-specs0 (let* ([pre-to-be-embedded-module-specs0
(if (or (not transformer-module-language-spec) (cond
(equal? module-language-spec transformer-module-language-spec)) [(and module-language-spec transformer-module-language-spec)
(if (equal? module-language-spec transformer-module-language-spec)
(list module-language-spec) (list module-language-spec)
(list module-language-spec (list module-language-spec transformer-module-language-spec))]
transformer-module-language-spec))] [module-language-spec
(list module-language-spec)]
[transformer-module-language-spec
(list transformer-module-language-spec)]
[else '()])]
[pre-to-be-embedded-module-specs1 [pre-to-be-embedded-module-specs1
(if gui? (if gui?
(cons '(lib "mred/mred.ss") (cons '(lib "mred/mred.ss")
@ -969,7 +976,7 @@
gui? gui?
use-copy?)))) use-copy?))))
;; create-module-based-distribution : ... -> void (see docs) ;; create-distribution-for-executable : ... -> void (see docs)
(define (create-distribution-for-executable distribution-filename (define (create-distribution-for-executable distribution-filename
gui? gui?
make-executable) make-executable)
@ -1116,7 +1123,7 @@
(path->string executable-filename) (path->string executable-filename)
executable-filename)))) executable-filename))))
;; initialize-module-based-language : boolean module-spec module-spec ((-> void) -> void) ;; initialize-module-based-language : boolean (or #f module-spec) module-spec ((-> void) -> void)
(define (initialize-module-based-language use-copy? (define (initialize-module-based-language use-copy?
module-spec module-spec
transformer-module-spec transformer-module-spec
@ -1127,9 +1134,10 @@
(λ (x) (λ (x)
(display (exn-message x)) (display (exn-message x))
(newline))]) (newline))])
(when module-spec
(if use-copy? (if use-copy?
(namespace-require/copy module-spec) (namespace-require/copy module-spec)
(namespace-require/constant module-spec)) (namespace-require/constant module-spec)))
(when transformer-module-spec (when transformer-module-spec
(namespace-require `(for-syntax ,transformer-module-spec))))))) (namespace-require `(for-syntax ,transformer-module-spec)))))))

3
collects/drscheme/private/launcher-bootstrap.ss
View File

@ -41,7 +41,8 @@
to-be-copied-module-names) to-be-copied-module-names)
(namespace-set-variable-value! 'argv program-argv) (namespace-set-variable-value! 'argv program-argv)
(current-command-line-arguments program-argv) (current-command-line-arguments program-argv)
(namespace-require language-module-spec) (when language-module-spec
(namespace-require language-module-spec))
(when use-require/copy? (when use-require/copy?
(namespace-require/copy language-module-spec)) (namespace-require/copy language-module-spec))
(when transformer-module-spec (when transformer-module-spec

31
collects/drscheme/private/module-language.ss
View File

@ -1,15 +1,15 @@
#lang scheme/base
(module module-language mzscheme
(provide module-language@) (provide module-language@)
(require mzlib/unit (require scheme/unit
mzlib/class scheme/class
mred mred
compiler/embed compiler/embed
launcher launcher
framework framework
string-constants string-constants
"drsig.ss" "drsig.ss"
mzlib/contract) scheme/contract)
(define op (current-output-port)) (define op (current-output-port))
(define (oprintf . args) (apply fprintf op args)) (define (oprintf . args) (apply fprintf op args))
@ -128,10 +128,10 @@
[get-require-module-name [get-require-module-name
(λ () (λ ()
;; "clearing out" the module-name via datum->syntax-object ensures ;; "clearing out" the module-name via datum->syntax ensures
;; that check syntax doesn't think the original module name ;; that check syntax doesn't think the original module name
;; is being used in this require (so it doesn't get turned red) ;; is being used in this require (so it doesn't get turned red)
(datum->syntax-object #'here (syntax-e module-name)))]) (datum->syntax #'here (syntax-e module-name)))])
(λ () (λ ()
(set! iteration-number (+ iteration-number 1)) (set! iteration-number (+ iteration-number 1))
(cond (cond
@ -213,7 +213,7 @@
#f ;; verbose? #f ;; verbose?
(list (list #f program-filename)) (list (list #f program-filename))
null null
(parameterize ([current-namespace (make-namespace 'empty)]) (parameterize ([current-namespace (make-empty-namespace)])
(namespace-require 'mzscheme) (namespace-require 'mzscheme)
(compile (compile
`(namespace-require '',(string->symbol (path->string short-program-name))))) `(namespace-require '',(string->symbol (path->string short-program-name)))))
@ -223,7 +223,7 @@
executable-filename)))))))) executable-filename))))))))
(super-new (super-new
(module 'scheme/base) (module #f)
(language-position (list "Module")) (language-position (list "Module"))
(language-numbers (list -32768))))) (language-numbers (list -32768)))))
@ -414,14 +414,17 @@
;; is the fully path-expanded name with a directory prefix, ;; is the fully path-expanded name with a directory prefix,
;; if the file has been saved ;; if the file has been saved
(define (transform-module filename stx) (define (transform-module filename stx)
(syntax-case stx (module) (syntax-case* stx (module) (λ (x y) (eq? (syntax-e x) (syntax-e y)))
[(module name lang bodies ...) [(module name lang bodies ...)
(let ([v-name (syntax name)]) (let ([v-name (syntax name)])
(when filename (when filename
(check-filename-matches filename (check-filename-matches filename
(syntax-object->datum (syntax name)) (syntax->datum (syntax name))
stx)) stx))
(values v-name stx))] ;; rewrite the module to use the scheme/base version of `module'
(values v-name
#`(#,(datum->syntax #'here 'module)
name lang bodies ...)))]
[else [else
(raise-syntax-error 'module-language (raise-syntax-error 'module-language
"only module expressions are allowed" "only module expressions are allowed"
@ -433,12 +436,12 @@
(define (get-module-name-prefix path) (define (get-module-name-prefix path)
(and path (and path
(let-values ([(base name dir) (let-values ([(base name dir)
(split-path (normal-case-path (simplify-path (expand-path path) #f)))]) (split-path (normal-case-path (simplify-path (expand-user-path path) #f)))])
(string->symbol (format ",~a" (bytes->string/latin-1 (path->bytes base))))))) (string->symbol (format ",~a" (bytes->string/latin-1 (path->bytes base)))))))
;; build-name : path -> symbol ;; build-name : path -> symbol
(define (build-name pre-path) (define (build-name pre-path)
(let ([path (normal-case-path (simplify-path (expand-path pre-path) #f))]) (let ([path (normal-case-path (simplify-path (expand-user-path pre-path) #f))])
(let-values ([(base name dir) (split-path path)]) (let-values ([(base name dir) (split-path path)])
(string->symbol (format ",~a" (string->symbol (format ",~a"
(bytes->string/latin-1 (bytes->string/latin-1
@ -563,4 +566,4 @@
[else [else
(loop (+ pos 1))])))) (loop (+ pos 1))]))))
(super-new))))) (super-new))))

3
collects/drscheme/tool-lib.ss
View File

@ -1198,7 +1198,8 @@ all of the names in the tools library, for use defining keybindings
@scheme[module-language-spec] and @scheme[module-language-spec] and
@scheme[transformer-module-language-spec] specify the @scheme[transformer-module-language-spec] specify the
settings of the initial namespace, both the transformer settings of the initial namespace, both the transformer
portion and the regular portion. portion and the regular portion. Both may be @scheme[#f]
to indicate there are no initial bindings.
The @scheme[init-code] argument is an s-expression representing The @scheme[init-code] argument is an s-expression representing
the code for a module. This module is expected to provide the code for a module. This module is expected to provide

5
collects/tests/drscheme/module-lang-test.ss
View File

@ -120,6 +120,11 @@
"x" "x"
"2") "2")
(make-test
"#lang scheme\n(eval 'cons)"
#f
". compile: bad syntax; reference to top-level identifier is not allowed, because no #%top syntax transformer is bound in: cons")
(make-test (make-test
(format "~s" `(module m (file ,(path->string (build-path this-dir "module-lang-test-tmp.ss"))) 1 2 3)) (format "~s" `(module m (file ,(path->string (build-path this-dir "module-lang-test-tmp.ss"))) 1 2 3))
"1" ;; just make sure no errors. "1" ;; just make sure no errors.