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

another attempt at PR 8136

Browse Source 
svn: r3448
This commit is contained in:
Robby Findler 2006-06-23 18:44:42 +00:00
parent 8dbab3cfa7
commit 28cab1f45b
1 changed files with 38 additions and 26 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

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

@ -118,14 +118,27 @@
(define/override (get-style-delta) module-language-style-delta) (define/override (get-style-delta) module-language-style-delta)
(define/override (front-end/complete-program port settings teachpack-cache) (define/override (front-end/complete-program port settings teachpack-cache)
(let ([super-thunk (super front-end/complete-program port settings teachpack-cache)] (let* ([super-thunk (super front-end/complete-program port settings teachpack-cache)]
[filename (get-filename port)] [filename (get-filename port)]
[module-name #f]) [module-name #f]
[module-name-prefix (get-module-name-prefix filename)]
[get-full-module-name
(λ ()
;; "clearing out" the module-name via datum->syntax-object ensures
;; that check syntax doesn't think the original module name
;; is being used in this require (so it doesn't get turned red)
(datum->syntax-object #'here
(string->symbol
(format "~a~a"
(or module-name-prefix "")
(syntax-e module-name)))))])
(λ () (λ ()
(set! iteration-number (+ iteration-number 1)) (set! iteration-number (+ iteration-number 1))
(let ([super-result (super-thunk)])
(cond (cond
[(= iteration-number 1) [(= 1 iteration-number)
#`(current-module-name-prefix '#,module-name-prefix)]
[(= 2 iteration-number)
(let ([super-result (super-thunk)])
(if (eof-object? super-result) (if (eof-object? super-result)
(raise-syntax-error (raise-syntax-error
'module-language 'module-language
@ -136,29 +149,19 @@
(expand super-result) (expand super-result)
super-result)]) super-result)])
(set! module-name name) (set! module-name name)
new-module))] new-module)))]
[(= 2 iteration-number) [(= 3 iteration-number)
(let ([super-result (super-thunk)])
(if (eof-object? super-result) (if (eof-object? super-result)
(with-syntax ([name #`(begin
;; "clearing out" the module-name in this fashion ensures (current-module-name-prefix #f)
;; that check syntax doesn't think the original module name (eval '(require #,(get-full-module-name)))
;; is being used in this require (so it doesn't get turned (eval '(current-namespace (module->namespace '#,(get-full-module-name)))))
;; red)
(datum->syntax-object #'here module-name)])
(syntax (require name)))
(raise-syntax-error (raise-syntax-error
'module-language 'module-language
"there can only be one expression in the definitions window" "there can only be one expression in the definitions window"
super-result))] super-result)))]
[(= 3 iteration-number) [else eof]))))
(with-syntax ([name
;; "clearing out" the module-name in this fashion ensures
;; that check syntax doesn't think the original module name
;; is being used in this require (so it doesn't get turned
;; red)
(datum->syntax-object #'here module-name)])
(syntax (current-namespace (module->namespace 'name))))]
[else eof])))))
;; printer settings are just ignored here. ;; printer settings are just ignored here.
(define/override (create-executable setting parent program-filename teachpacks) (define/override (create-executable setting parent program-filename teachpacks)
@ -421,9 +424,18 @@
"only module expressions are allowed" "only module expressions are allowed"
unexpanded-stx)])) unexpanded-stx)]))
;; get-module-name-prefix : path -> string
;; returns the symbol that gets passed the current-module-name-prefix
;; while evaluating/expanding the module.
(define (get-module-name-prefix path)
(and path
(let-values ([(base name dir)
(split-path (normal-case-path (simplify-path (expand-path path) #f)))])
(string->symbol (format ",~a" (path->string base))))))
;; build-name : path -> symbol ;; build-name : path -> symbol
(define (build-name pre-path) (define (build-name pre-path)
(let ([path (normalize-path pre-path)]) (let ([path (normal-case-path (simplify-path (expand-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"
(path->string (path->string