adjusted the automatic compilation to make it more disableable
svn: r12397
This commit is contained in:
Robby Findler
parent
fd6dfdbbc4
commit
256182ecbd
|
|
@ -10,15 +10,14 @@
|
|||
make-caching-managed-compile-zo
|
||||
trust-existing-zos
|
||||
manager-compile-notify-handler
|
||||
current-path->compilation-dir
|
||||
;manager-skip-file-handler ;; not yet tested, so not yet exported
|
||||
(rename-out [trace manager-trace-handler]))
|
||||
|
||||
(define manager-compile-notify-handler (make-parameter void))
|
||||
(define trace (make-parameter void))
|
||||
(define indent (make-parameter ""))
|
||||
(define trust-existing-zos (make-parameter #f))
|
||||
|
||||
(define current-path->compilation-dir (make-parameter #f))
|
||||
(define manager-skip-file-handler (make-parameter (λ (x) #f)))
|
||||
|
||||
(define (trace-printf fmt . args)
|
||||
(let ([t (trace)])
|
||||
|
|
@ -35,9 +34,6 @@
|
|||
(let-values ([(base name must-be-dir?) (split-path path)])
|
||||
(values
|
||||
(cond
|
||||
[(current-path->compilation-dir)
|
||||
=>
|
||||
(λ (f) (f path))]
|
||||
[(eq? 'relative base) mode]
|
||||
[else (build-path base mode)])
|
||||
name)))
|
||||
|
|
@ -214,16 +210,16 @@
|
|||
(let* ([zo-name (path-add-suffix (get-compilation-path mode path) #".zo")]
|
||||
[zo-exists? (file-exists? zo-name)])
|
||||
(if (and zo-exists? (trust-existing-zos))
|
||||
(touch zo-name)
|
||||
(begin (when zo-exists? (delete-file zo-name))
|
||||
(with-handlers
|
||||
([exn:get-module-code?
|
||||
(lambda (ex)
|
||||
(compilation-failure mode path zo-name
|
||||
(exn:get-module-code-path ex)
|
||||
(exn-message ex))
|
||||
(raise ex))])
|
||||
(compile-zo* mode path read-src-syntax zo-name))))))
|
||||
(touch zo-name)
|
||||
(begin (when zo-exists? (delete-file zo-name))
|
||||
(with-handlers
|
||||
([exn:get-module-code?
|
||||
(lambda (ex)
|
||||
(compilation-failure mode path zo-name
|
||||
(exn:get-module-code-path ex)
|
||||
(exn-message ex))
|
||||
(raise ex))])
|
||||
(compile-zo* mode path read-src-syntax zo-name))))))
|
||||
(trace-printf "end compile: ~a" path))
|
||||
|
||||
(define (get-compiled-time mode path)
|
||||
|
|
@ -279,6 +275,7 @@
|
|||
(hash-set! up-to-date path stamp)
|
||||
stamp)]))
|
||||
(or (and up-to-date (hash-ref up-to-date path #f))
|
||||
((manager-skip-file-handler) path)
|
||||
(begin (trace-printf "checking: ~a" path)
|
||||
(do-check))))
|
||||
|
||||
|
|
@ -304,7 +301,6 @@
|
|||
[orig-load (current-load)]
|
||||
[orig-registry (namespace-module-registry (current-namespace))]
|
||||
[default-handler (current-load/use-compiled)]
|
||||
[orig-path->compilation-dir-handler (current-path->compilation-dir)]
|
||||
[modes (use-compiled-file-paths)])
|
||||
(define (compilation-manager-load-handler path mod-name)
|
||||
(cond [(not mod-name)
|
||||
|
|
@ -331,11 +327,6 @@
|
|||
(trace-printf "skipping: ~a orig-registry ~s current-registry ~s"
|
||||
path orig-registry
|
||||
(namespace-module-registry (current-namespace)))]
|
||||
[(not (eq? (current-path->compilation-dir)
|
||||
orig-path->compilation-dir-handler))
|
||||
(trace-printf "skipping: ~a orig path->compilation-dir-handler ~s current path->compilation-dir-handler ~s"
|
||||
orig-path->compilation-dir-handler
|
||||
(current-path->compilation-dir))]
|
||||
[else
|
||||
(trace-printf "processing: ~a" path)
|
||||
(compile-root (car modes) path cache read-syntax)
|
||||
|
|
|
|||
|
|
@ -202,7 +202,9 @@
|
|||
;; -> (case-> (-> settings) (settings -> void))
|
||||
(define (simple-module-based-language-config-panel
|
||||
_parent
|
||||
#:case-sensitive [*case-sensitive '?])
|
||||
#:case-sensitive [*case-sensitive '?]
|
||||
#:annotations-callback [annotations-callback void]
|
||||
#:dynamic-panel-extras [dynamic-panel-extras void])
|
||||
(letrec ([parent (instantiate vertical-panel% ()
|
||||
(parent _parent)
|
||||
(alignment '(center center)))]
|
||||
|
|
@ -228,7 +230,7 @@
|
|||
(string-constant case-sensitive-label)
|
||||
input-panel
|
||||
void))]
|
||||
[debugging (instantiate radio-box% ()
|
||||
[debugging (new radio-box%
|
||||
(label #f)
|
||||
(choices
|
||||
(list (string-constant no-debugging-or-profiling)
|
||||
|
|
@ -236,7 +238,7 @@
|
|||
(string-constant debugging-and-profiling)
|
||||
(string-constant test-coverage)))
|
||||
(parent dynamic-panel)
|
||||
(callback void))]
|
||||
(callback (λ (x y) (annotations-callback x y))))]
|
||||
[output-style (make-object radio-box%
|
||||
(string-constant output-style-label)
|
||||
(list (string-constant constructor-printing-style)
|
||||
|
|
@ -262,6 +264,8 @@
|
|||
output-panel
|
||||
void)])
|
||||
|
||||
(dynamic-panel-extras dynamic-panel)
|
||||
|
||||
(case-lambda
|
||||
[()
|
||||
(make-simple-settings
|
||||
|
|
|
|||
|
|
@ -6,6 +6,7 @@
|
|||
scheme/list
|
||||
mred
|
||||
compiler/embed
|
||||
compiler/cm
|
||||
launcher
|
||||
framework
|
||||
string-constants
|
||||
|
|
@ -43,7 +44,10 @@
|
|||
;; command-line-args : (vectorof string)
|
||||
;; auto-text : string
|
||||
(define-struct (module-language-settings drscheme:language:simple-settings)
|
||||
(collection-paths command-line-args auto-text))
|
||||
(collection-paths command-line-args auto-text compilation-on?))
|
||||
|
||||
(define default-compilation-on? #t)
|
||||
(define default-auto-text "#lang scheme\n")
|
||||
|
||||
;; module-mixin : (implements drscheme:language:language<%>)
|
||||
;; -> (implements drscheme:language:language<%>)
|
||||
|
|
@ -70,7 +74,8 @@
|
|||
(vector->list (drscheme:language:simple-settings->vector super-defaults))
|
||||
(list '(default)
|
||||
#()
|
||||
default-auto-text)))))
|
||||
default-auto-text
|
||||
default-compilation-on?)))))
|
||||
|
||||
;; default-settings? : -> boolean
|
||||
(define/override (default-settings? settings)
|
||||
|
|
@ -83,36 +88,46 @@
|
|||
;; auto-text
|
||||
;; (equal? (module-language-settings-auto-text settings)
|
||||
;; default-auto-text)
|
||||
))
|
||||
(equal? (module-language-settings-compilation-on? settings)
|
||||
default-compilation-on?)))
|
||||
|
||||
(define/override (marshall-settings settings)
|
||||
(let ([super-marshalled (super marshall-settings settings)])
|
||||
(list super-marshalled
|
||||
(module-language-settings-collection-paths settings)
|
||||
(module-language-settings-command-line-args settings)
|
||||
(module-language-settings-auto-text settings))))
|
||||
(module-language-settings-auto-text settings)
|
||||
(module-language-settings-compilation-on? settings))))
|
||||
|
||||
(define/override (unmarshall-settings marshalled)
|
||||
(and (list? marshalled)
|
||||
;; older formats had no auto-text
|
||||
(<= 3 (length marshalled) 4)
|
||||
(list? (cadr marshalled))
|
||||
(andmap (λ (x) (or (string? x) (symbol? x)))
|
||||
(cadr marshalled))
|
||||
(vector? (caddr marshalled))
|
||||
(andmap string? (vector->list (caddr marshalled)))
|
||||
(or (= 3 (length marshalled))
|
||||
(string? (cadddr marshalled)))
|
||||
(let ([super (super unmarshall-settings (car marshalled))])
|
||||
(and super
|
||||
(apply make-module-language-settings
|
||||
(append
|
||||
(vector->list (drscheme:language:simple-settings->vector super))
|
||||
(list (cadr marshalled)
|
||||
(caddr marshalled)
|
||||
(if (= 3 (length marshalled))
|
||||
default-auto-text
|
||||
(cadddr marshalled)))))))))
|
||||
(let ([marshalled-len (length marshalled)])
|
||||
;; older formats had no auto-text or compilation disabling
|
||||
(and (<= 3 (length marshalled))
|
||||
(let ([collection-paths (list-ref marshalled 1)]
|
||||
[command-line-args (list-ref marshalled 2)]
|
||||
[auto-text (if (<= marshalled-len 3)
|
||||
default-auto-text
|
||||
(list-ref marshalled 3))]
|
||||
[compilation-on? (if (<= marshalled-len 4)
|
||||
default-compilation-on?
|
||||
(list-ref marshalled 4))])
|
||||
(and (list? collection-paths)
|
||||
(andmap (λ (x) (or (string? x) (symbol? x)))
|
||||
collection-paths)
|
||||
(vector? command-line-args)
|
||||
(andmap string? (vector->list command-line-args))
|
||||
(string? auto-text)
|
||||
(boolean? compilation-on?)
|
||||
(let ([super (super unmarshall-settings (car marshalled))])
|
||||
(and super
|
||||
(apply make-module-language-settings
|
||||
(append
|
||||
(vector->list (drscheme:language:simple-settings->vector super))
|
||||
(list collection-paths
|
||||
command-line-args
|
||||
auto-text
|
||||
compilation-on?)))))))))))
|
||||
|
||||
(define/override (on-execute settings run-in-user-thread)
|
||||
(super on-execute settings run-in-user-thread)
|
||||
|
|
@ -127,12 +142,17 @@
|
|||
(when (null? cpaths)
|
||||
(fprintf (current-error-port)
|
||||
"Warning: your collection paths are empty!\n"))
|
||||
(current-library-collection-paths cpaths)))))
|
||||
(current-library-collection-paths cpaths))
|
||||
|
||||
(when (and (module-language-settings-compilation-on? settings)
|
||||
(eq? (drscheme:language:simple-settings-annotations settings) 'none))
|
||||
(current-load/use-compiled (make-compilation-manager-load/use-compiled-handler)))
|
||||
;[manager-trace-handler (λ (x) (display x) (newline))]
|
||||
)))
|
||||
|
||||
(define/override (get-one-line-summary)
|
||||
(string-constant module-language-one-line-summary))
|
||||
|
||||
(define default-auto-text "#lang scheme\n")
|
||||
(define/public (get-auto-text settings)
|
||||
(module-language-settings-auto-text settings))
|
||||
|
||||
|
|
@ -320,9 +340,20 @@
|
|||
[alignment '(center center)]
|
||||
[stretchable-height #f]
|
||||
[stretchable-width #f]))
|
||||
(define compilation-on-radio-box #f)
|
||||
(define annotations-radio-box #f)
|
||||
(define simple-case-lambda
|
||||
(drscheme:language:simple-module-based-language-config-panel
|
||||
new-parent #:case-sensitive #t))
|
||||
new-parent
|
||||
#:case-sensitive #t
|
||||
#:annotations-callback
|
||||
(λ (cb evt) (update-compilation-on-radio-box-visibility))
|
||||
#:dynamic-panel-extras
|
||||
(λ (dynamic-panel)
|
||||
(set! annotations-radio-box (car (send dynamic-panel get-children)))
|
||||
(set! compilation-on-radio-box (new check-box%
|
||||
[label (string-constant automatically-compile?)]
|
||||
[parent dynamic-panel])))))
|
||||
(define cp-panel (new group-box-panel%
|
||||
[parent new-parent]
|
||||
[label (string-constant ml-cp-collection-paths)]))
|
||||
|
|
@ -377,7 +408,8 @@
|
|||
(send remove-button enable lb-selection)
|
||||
(send raise-button enable (and lb-selection (not (= lb-selection 0))))
|
||||
(send lower-button enable
|
||||
(and lb-selection (not (= lb-selection (- lb-tot 1)))))))
|
||||
(and lb-selection (not (= lb-selection (- lb-tot 1)))))
|
||||
(update-compilation-on-radio-box-visibility)))
|
||||
|
||||
(define (add-callback)
|
||||
(let ([dir (get-directory (string-constant ml-cp-choose-a-collection-path)
|
||||
|
|
@ -463,6 +495,9 @@
|
|||
(define (install-auto-text str)
|
||||
(send auto-text-text-box set-value (regexp-replace #rx"\n$" str "")))
|
||||
|
||||
(define (update-compilation-on-radio-box-visibility)
|
||||
(send compilation-on-radio-box enable (equal? 0 (send annotations-radio-box get-selection))))
|
||||
|
||||
(send collection-paths-lb set '())
|
||||
(update-buttons)
|
||||
|
||||
|
|
@ -474,12 +509,14 @@
|
|||
(vector->list (drscheme:language:simple-settings->vector simple-settings))
|
||||
(list (get-collection-paths)
|
||||
(get-command-line-args)
|
||||
(get-auto-text)))))]
|
||||
(get-auto-text)
|
||||
(send compilation-on-radio-box get-value)))))]
|
||||
[(settings)
|
||||
(simple-case-lambda settings)
|
||||
(install-collection-paths (module-language-settings-collection-paths settings))
|
||||
(install-command-line-args (module-language-settings-command-line-args settings))
|
||||
(install-auto-text (module-language-settings-auto-text settings))
|
||||
(send compilation-on-radio-box set-value (module-language-settings-compilation-on? settings))
|
||||
(update-buttons)]))
|
||||
|
||||
;; transform-module : (union #f path) syntax
|
||||
|
|
|
|||
|
|
@ -31,8 +31,7 @@ TODO
|
|||
scheme/gui/base
|
||||
framework
|
||||
browser/external
|
||||
"drsig.ss"
|
||||
"zo-cache.ss")
|
||||
"drsig.ss")
|
||||
|
||||
(provide rep@ with-stacktrace-name)
|
||||
|
||||
|
|
@ -1293,10 +1292,6 @@ TODO
|
|||
(update-running #f)
|
||||
(send context set-breakables #f #f)
|
||||
|
||||
;; set this relatively late, so that the
|
||||
;; setup code for the language doesn't use it
|
||||
(current-load/use-compiled drscheme-load/use-compiled-handler)
|
||||
|
||||
;; after this returns, future event dispatches
|
||||
;; will use the user's break parameterization
|
||||
(initialize-dispatch-handler)
|
||||
|
|
@ -1701,24 +1696,6 @@ TODO
|
|||
|
||||
(define input-delta (make-object style-delta%))
|
||||
(send input-delta set-delta-foreground (make-object color% 0 150 0))
|
||||
|
||||
(define drscheme-load/use-compiled-handler
|
||||
(let ([ol (current-load/use-compiled)])
|
||||
(λ (path mod) ;; =User=
|
||||
|
||||
(parameterize ([current-eventspace drscheme:init:system-eventspace])
|
||||
(let ([s (make-semaphore 0)])
|
||||
(queue-callback
|
||||
(λ () ;; =Kernel= =Handler=
|
||||
(let ([frame (send (group:get-the-frame-group) locate-file path)])
|
||||
(when frame
|
||||
(send frame offer-to-save-file path)))
|
||||
(semaphore-post s)))
|
||||
(semaphore-wait s)))
|
||||
|
||||
(build-and-load-zo-file ol path mod))))
|
||||
|
||||
|
||||
|
||||
;; insert-error-in-text : (is-a?/c text%)
|
||||
;; (union #f (is-a?/c drscheme:rep:text<%>))
|
||||
|
|
|
|||
|
|
@ -21,39 +21,11 @@ All of this code runs on the user's parameterization/thread
|
|||
(original-load/use-compiled-handler path mod)]
|
||||
[else
|
||||
;; otherwise do some managed compilation
|
||||
(parameterize ([current-path->compilation-dir path->cache-path])
|
||||
(parameterize ([manager-skip-file-handler (λ (x)
|
||||
(printf "considering ~s\n" x)
|
||||
#f)])
|
||||
(managed-compile-zo path))
|
||||
;; and then load the compiled file
|
||||
(let-values ([(base name dir) (split-path path)])
|
||||
(original-load/use-compiled-handler
|
||||
(build-path (path->cache-path path) (compiled-name name #".zo"))
|
||||
mod))]))
|
||||
|
||||
;; path->cache-path : path[w/extension] -> path
|
||||
;; returns the location of the cached zo file that corresponds to its input
|
||||
(define (path->cache-path path)
|
||||
(cond
|
||||
[(already-a-compiled-file? path)
|
||||
(let ([mode (car (use-compiled-file-paths))])
|
||||
(let-values ([(base name must-be-dir?) (split-path path)])
|
||||
(cond
|
||||
[(eq? 'relative base) mode]
|
||||
[else (build-path base mode)])))]
|
||||
[else
|
||||
(apply build-path
|
||||
(find-system-path 'addon-dir)
|
||||
(version)
|
||||
"drscheme-zo-cache"
|
||||
(remove-last (cdr (explode-path (normalize-path path))))
|
||||
#;(replace-last-with-zo (cdr (explode-path (normalize-path path)))))]))
|
||||
|
||||
(define (remove-last lst) (reverse (cdr (reverse lst))))
|
||||
|
||||
(define (replace-last-with-zo lst)
|
||||
(cond
|
||||
[(null? (cdr lst))
|
||||
(list (compiled-name (car lst)))]
|
||||
[else (cons (car lst) (replace-last-with-zo (cdr lst)))]))
|
||||
(original-load/use-compiled-handler path mod)]))
|
||||
|
||||
(define (exists-and-is-newer? orig-path candidate-path)
|
||||
(and (file-exists? candidate-path)
|
||||
|
|
|
|||
|
|
@ -183,13 +183,17 @@
|
|||
(when current-stepper-director
|
||||
(send current-stepper-director add-obsoleted-warning)
|
||||
(set! current-stepper-director #f))
|
||||
(run-in-evaluation-thread
|
||||
(lambda ()
|
||||
(let-values ([(e mnr)
|
||||
(make-handlers (current-eval)
|
||||
(current-module-name-resolver))])
|
||||
(current-eval e)
|
||||
(current-module-name-resolver mnr)))))
|
||||
|
||||
;; setting the eval handler at this point disables CM,
|
||||
;; so only do it when we are debugging
|
||||
(when debugging?
|
||||
(run-in-evaluation-thread
|
||||
(lambda ()
|
||||
(let-values ([(e mnr)
|
||||
(make-handlers (current-eval)
|
||||
(current-module-name-resolver))])
|
||||
(current-eval e)
|
||||
(current-module-name-resolver mnr))))))
|
||||
|
||||
(define/private (make-stepper filename)
|
||||
(new drscheme-macro-stepper-director% (filename filename)))
|
||||
|
|
|
|||
|
|
@ -241,13 +241,20 @@ A parameter for a procedure of one argument that is called to report
|
|||
compilation-manager actions, such as checking a file. The argument to
|
||||
the procedure is a string.}
|
||||
|
||||
@defparam[current-path->compilation-dir path->compilation-dir (or/c #f (-> path? path?))]{
|
||||
@;{
|
||||
@defparam[manager-skip-file-handler proc (-> path? (or/c number? #f))]{
|
||||
This handler is consulted for each file that is loaded. If it
|
||||
returns a number, then the file is skipped (ie, not compiled),
|
||||
and the number is used as the timestamp. If it returns @scheme[#f],
|
||||
then the file is compiled (if necessary) as usual.
|
||||
|
||||
This parameter controls the location where compiled .zo files are
|
||||
saved. It is called with the path of a @tt{.ss} file and is expected
|
||||
to return a path where the @tt{.zo} and @tt{.dep} file can be saved.
|
||||
@;{Defaults to a function that checks to see if the module in the file
|
||||
has already been loaded in the filesystem and, if it has, it
|
||||
returns the timestamp of the .zo file for that file (or the .ss file
|
||||
if the .zo file does not exist).}
|
||||
|
||||
If it is @scheme[#f], then @scheme[use-compiled-file-paths] is used.
|
||||
Defaults to @scheme[(λ (x) #f)].
|
||||
}
|
||||
}
|
||||
|
||||
@; ----------------------------------------------------------------------
|
||||
|
|
|
|||
|
|
@ -999,7 +999,8 @@ please adhere to these guidelines:
|
|||
(decimal-notation-for-rationals "Use decimal notation for rationals")
|
||||
(enforce-primitives-group-box-label "Initial Bindings")
|
||||
(enforce-primitives-check-box-label "Disallow redefinition of initial bindings")
|
||||
|
||||
(automatically-compile? "Automatically compile source files?")
|
||||
|
||||
; used in the bottom left of the drscheme frame
|
||||
; used the popup menu from the just above; greyed out and only
|
||||
; visible when some languages are in the history
|
||||
|
|
|
|||
Loading…
Reference in New Issue
Block a user