From 256182ecbdf0720b010d6b226c3bbc2a6b9b1f34 Mon Sep 17 00:00:00 2001
From: Robby Findler <robby@racket-lang.org>
Date: Tue, 11 Nov 2008 23:56:54 +0000
Subject: [PATCH] adjusted the automatic compilation to make it more
 disableable

svn: r12397
---
 collects/compiler/cm.ss                       | 35 +++----
 collects/drscheme/private/language.ss         | 10 +-
 collects/drscheme/private/module-language.ss  | 93 +++++++++++++------
 collects/drscheme/private/rep.ss              | 25 +----
 collects/drscheme/private/zo-cache.ss         | 36 +------
 collects/macro-debugger/tool.ss               | 18 ++--
 collects/scribblings/mzc/make.scrbl           | 17 +++-
 .../english-string-constants.ss               |  3 +-
 8 files changed, 115 insertions(+), 122 deletions(-)

diff --git a/collects/compiler/cm.ss b/collects/compiler/cm.ss
index fd7912044f..fda77af2bb 100644
--- a/collects/compiler/cm.ss
+++ b/collects/compiler/cm.ss
@@ -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)
diff --git a/collects/drscheme/private/language.ss b/collects/drscheme/private/language.ss
index 0eec3f30e7..02aceb10f5 100644
--- a/collects/drscheme/private/language.ss
+++ b/collects/drscheme/private/language.ss
@@ -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
diff --git a/collects/drscheme/private/module-language.ss b/collects/drscheme/private/module-language.ss
index 5d9b75f51f..425ab57b4e 100644
--- a/collects/drscheme/private/module-language.ss
+++ b/collects/drscheme/private/module-language.ss
@@ -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
diff --git a/collects/drscheme/private/rep.ss b/collects/drscheme/private/rep.ss
index 7c7c659988..08442e7a83 100644
--- a/collects/drscheme/private/rep.ss
+++ b/collects/drscheme/private/rep.ss
@@ -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<%>))
diff --git a/collects/drscheme/private/zo-cache.ss b/collects/drscheme/private/zo-cache.ss
index 850d407e2f..72567d92fe 100644
--- a/collects/drscheme/private/zo-cache.ss
+++ b/collects/drscheme/private/zo-cache.ss
@@ -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)
diff --git a/collects/macro-debugger/tool.ss b/collects/macro-debugger/tool.ss
index 9bae30f5ec..bd8ee29529 100644
--- a/collects/macro-debugger/tool.ss
+++ b/collects/macro-debugger/tool.ss
@@ -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)))
diff --git a/collects/scribblings/mzc/make.scrbl b/collects/scribblings/mzc/make.scrbl
index 2f48e75b4e..cd374d3981 100644
--- a/collects/scribblings/mzc/make.scrbl
+++ b/collects/scribblings/mzc/make.scrbl
@@ -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)].
+}
 }
 
 @; ----------------------------------------------------------------------
diff --git a/collects/string-constants/english-string-constants.ss b/collects/string-constants/english-string-constants.ss
index 2e53a97017..4278e0fb52 100644
--- a/collects/string-constants/english-string-constants.ss
+++ b/collects/string-constants/english-string-constants.ss
@@ -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