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

adjust DrScheme to run #lang-specified runtime configuration

Browse Source 
svn: r18762
This commit is contained in:
Matthew Flatt 2010-04-08 15:32:02 +00:00
parent 8b31b1b552
commit 8fbd16261f
3 changed files with 48 additions and 23 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

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

@ -309,9 +309,24 @@
(parameterize ([current-namespace (current-namespace)]) (parameterize ([current-namespace (current-namespace)])
;; the prompt makes it continue after an error ;; the prompt makes it continue after an error
(call-with-continuation-prompt (call-with-continuation-prompt
(λ () (with-stack-checkpoint (namespace-require modspec))))) (λ () (with-stack-checkpoint
(begin
(*do-module-specified-configuration modspec)
(namespace-require modspec))))))
(current-namespace (module->namespace modspec)) (current-namespace (module->namespace modspec))
(check-interactive-language)) (check-interactive-language))
(define (*do-module-specified-configuration modspec)
(let ([info (module->language-info modspec #t)])
(when info
(let ([get-info
((dynamic-require (vector-ref info 0)
(vector-ref info 1))
(vector-ref info 2))])
(let ([config (get-info 'configure-runtime #f)])
(when config
((dynamic-require (vector-ref config 0)
(vector-ref config 1))
(vector-ref config 2))))))))
;; here's where they're all combined with the module expression ;; here's where they're all combined with the module expression
(expr-getter *pre module-expr *post)) (expr-getter *pre module-expr *post))
@ -350,6 +365,7 @@
#:mred? gui? #:mred? gui?
#:verbose? #f ;; verbose? #:verbose? #f ;; verbose?
#:modules (list (list #f program-filename)) #:modules (list (list #f program-filename))
#:configure-via-first-module? #t
#:literal-expression #:literal-expression
(begin (begin
(parameterize ([current-namespace (make-base-empty-namespace)]) (parameterize ([current-namespace (make-base-empty-namespace)])

51
collects/errortrace/errortrace-lib.ss
View File

@ -44,15 +44,17 @@
(define (add-test-coverage-init-code stx) (define (add-test-coverage-init-code stx)
(syntax-case stx (#%plain-module-begin) (syntax-case stx (#%plain-module-begin)
[(mod name init-import (#%plain-module-begin b1 b2 body ...)) [(mod name init-import (#%plain-module-begin b1 b2 body ...))
#`(#,(namespace-module-identifier) name init-import (copy-props
#,(syntax-recertify stx
#`(#%plain-module-begin #`(#,(namespace-module-identifier) name init-import
b1 b2 ;; the two requires that were introduced earlier #,(syntax-recertify
(#%plain-app init-test-coverage '#,(remove-duplicates test-coverage-state)) #`(#%plain-module-begin
body ...) b1 b2 ;; the two requires that were introduced earlier
(list-ref (syntax->list stx) 3) (#%plain-app init-test-coverage '#,(remove-duplicates test-coverage-state))
orig-inspector body ...)
#f))])) (list-ref (syntax->list stx) 3)
orig-inspector
#f)))]))
(define (annotate-covered-file filename-path [display-string #f]) (define (annotate-covered-file filename-path [display-string #f])
(annotate-file filename-path (annotate-file filename-path
@ -103,6 +105,9 @@
[else [else
(< (list-ref x 1) (list-ref y 1))]))))) (< (list-ref x 1) (list-ref y 1))])))))
(define (copy-props orig new)
(datum->syntax orig (syntax-e new) orig orig))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Profiling run-time support ;; Profiling run-time support
@ -416,19 +421,21 @@
[(mod name init-import (#%plain-module-begin body ...)) [(mod name init-import (#%plain-module-begin body ...))
(add-test-coverage-init-code (add-test-coverage-init-code
(normal (normal
#`(#,(namespace-module-identifier) name init-import (copy-props
#,(syntax-recertify top-e
#`(#%plain-module-begin #`(#,(namespace-module-identifier) name init-import
#,((make-syntax-introducer) #,(syntax-recertify
(syntax/loc (datum->syntax #f 'x #f) #`(#%plain-module-begin
(#%require errortrace/errortrace-key))) #,((make-syntax-introducer)
#,((make-syntax-introducer) (syntax/loc (datum->syntax #f 'x #f)
(syntax/loc (datum->syntax #f 'x #f) (#%require errortrace/errortrace-key)))
(#%require (for-syntax errortrace/errortrace-key)))) #,((make-syntax-introducer)
body ...) (syntax/loc (datum->syntax #f 'x #f)
(list-ref (syntax->list top-e) 3) (#%require (for-syntax errortrace/errortrace-key))))
orig-inspector body ...)
#f))))])))] (list-ref (syntax->list top-e) 3)
orig-inspector
#f)))))])))]
[_else [_else
(normal top-e)]))) (normal top-e)])))

2
collects/errortrace/stacktrace.ss
View File

@ -304,6 +304,7 @@
(datum->syntax (datum->syntax
expr expr
x x
expr
expr)))))] expr)))))]
[else (same-k)]))))) [else (same-k)])))))
@ -312,6 +313,7 @@
[(syntax? expr) [(syntax? expr)
(datum->syntax expr (datum->syntax expr
(append-rebuild (syntax-e expr) end) (append-rebuild (syntax-e expr) end)
expr
expr)] expr)]
[(pair? expr) [(pair? expr)
(cons (car expr) (append-rebuild (cdr expr) end))] (cons (car expr) (append-rebuild (cdr expr) end))]