added support for automatic compilation of source files to drscheme

svn: r12356

collects/compiler/cm.ss

@@ -10,6 +10,7 @@
          make-caching-managed-compile-zo
          trust-existing-zos
          manager-compile-notify-handler
+         current-path->compilation-dir
          (rename-out [trace manager-trace-handler]))
 
 (define manager-compile-notify-handler (make-parameter void))
@@ -17,6 +18,8 @@
 (define indent (make-parameter ""))
 (define trust-existing-zos (make-parameter #f))
 
+(define current-path->compilation-dir (make-parameter #f))
+
 (define (trace-printf fmt . args)
   (let ([t (trace)])
     (unless (eq? t void)
@@ -30,16 +33,22 @@
 
 (define (get-compilation-dir+name mode path)
   (let-values ([(base name must-be-dir?) (split-path path)])
-    (values (if (eq? 'relative base) mode (build-path base mode))
+    (values 
-            name)))
+     (cond
+       [(current-path->compilation-dir)
+        =>
+        (λ (f) (f path))]
+       [(eq? 'relative base) mode]
+       [else (build-path base mode)])
+     name)))
 
 (define (get-compilation-path mode path)
   (let-values ([(dir name) (get-compilation-dir+name mode path)])
     (build-path dir name)))
 
 (define (get-compilation-dir mode path)
-  (let-values ([(base name-suffix must-be-dir?) (split-path path)])
+  (let-values ([(dir name) (get-compilation-dir+name mode path)])
-    (if (eq? 'relative base) mode (build-path base mode))))
+    dir))
 
 (define (touch path)
   (close-output-port (open-output-file path #:exists 'append)))
@@ -295,13 +304,18 @@
         [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)
              (trace-printf "skipping:  ~a mod-name ~s" path mod-name)]
-            [(not (member (car modes) (use-compiled-file-paths)))
+            [(or (null? (use-compiled-file-paths))
-             (trace-printf "skipping:  ~a compiled-paths ~s"
+                 (not (equal? (car modes)
-                           path (use-compiled-file-paths))]
+                              (car (use-compiled-file-paths)))))
+             (trace-printf "skipping:  ~a compiled-paths's first element changed; current value ~s, first element was ~s"
+                           path 
+                           (use-compiled-file-paths)
+                           (car modes))]
             [(not (eq? compilation-manager-load-handler
                        (current-load/use-compiled)))
              (trace-printf "skipping:  ~a current-load/use-compiled changed ~s"
@@ -317,6 +331,11 @@
              (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)

collects/drscheme/private/rep.ss

@@ -25,12 +25,14 @@ TODO
          scheme/pretty
          scheme/unit
          scheme/list
-         "drsig.ss"
+         
          string-constants
          setup/xref
          scheme/gui/base
          framework
-         browser/external)
+         browser/external
+         "drsig.ss"
+         "zo-cache.ss")
 
 (provide rep@ with-stacktrace-name)
 
@@ -1293,7 +1295,7 @@ TODO
                  
                  ;; 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)
+                 (current-load/use-compiled drscheme-load/use-compiled-handler)
                  
                  ;; after this returns, future event dispatches
                  ;; will use the user's break parameterization
@@ -1703,65 +1705,19 @@ TODO
   (define drscheme-load/use-compiled-handler
     (let ([ol (current-load/use-compiled)])
       (λ (path mod) ;; =User=
-        (verify-file-saved path)
+        
-        (cond
+        (parameterize ([current-eventspace drscheme:init:system-eventspace])
-          [(already-a-compiled-file? path)
+          (let ([s (make-semaphore 0)])
-           (ol path mod)]
+            (queue-callback
-          [else
+             (λ () ;; =Kernel= =Handler=
-           (error 'drscheme-load/use-compiled-handler
+               (let ([frame (send (group:get-the-frame-group) locate-file path)])
-                  "time to compile! ~s" path)]))))
+                 (when frame
+                   (send frame offer-to-save-file path)))
+               (semaphore-post s)))
+            (semaphore-wait s)))
+        
+        (build-and-load-zo-file ol path mod))))
   
-  ;; =User=
-  (define (verify-file-saved path) 
-    (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))))
-    
-  ;; =User=
-  (define (already-a-compiled-file? path) 
-    (let* ([filename (file-name-from-path path)]
-           [base (path-only path)]
-           [extension (and filename base (filename-extension filename))]
-           [basename (and extension
-                          (let ([pbs (path->bytes filename)])
-                            (subbytes pbs
-                                      0 
-                                      (- (bytes-length pbs)
-                                         (bytes-length extension)
-                                         1 ;; extra one for '.' in there
-                                         ))))]
-           [fm (file-or-directory-modify-seconds path)]
-           [newer-exists?
-            (λ (pot-path)
-              (and (file-exists? pot-path)
-                   (< fm (file-or-directory-modify-seconds pot-path))))])
-      (and basename
-           (ormap 
-            (λ (c-f-p)
-              (or (newer-exists? (build-path base c-f-p 
-                                             (bytes->path
-                                              (bytes-append basename #"_" extension #".zo"))))
-                  (ormap
-                   (λ (ext)
-                     (newer-exists? (build-path base 
-                                                c-f-p 
-                                                "native"
-                                                (system-library-subpath)
-                                                (bytes->path
-                                                 (bytes-append basename #"_" extension ext)))))
-                   '(#".so" #".dll" #".dylib"))))
-            (use-compiled-file-paths)))))
-  
-  (define (path->cache-zo-file-path path)
-    (apply build-path 
-           
-           (cdr (explode-path path))))
   
   
   ;; insert-error-in-text : (is-a?/c text%)

collects/drscheme/private/zo-cache.ss

@@ -0,0 +1,100 @@
+#lang scheme/base
+(require scheme/path
+         scheme/file
+         compiler/cm)
+
+#|
+
+All of this code runs on the user's parameterization/thread
+
+|#
+
+(provide build-and-load-zo-file)
+
+(define (build-and-load-zo-file original-load/use-compiled-handler path mod)
+  (cond
+    [(or (not (filename-extension path))
+         (already-a-compiled-file? path))
+     ;; if there is no extension, just give up.
+     ;; if there is a compiled file that look up to date
+     ;;    in the usual place, use it.
+     (original-load/use-compiled-handler path mod)]
+    [else
+     ;; otherwise do some managed compilation
+     (parameterize ([current-path->compilation-dir path->cache-path])
+       (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)))]))
+
+(define (exists-and-is-newer? orig-path candidate-path)
+  (and (file-exists? candidate-path)
+       (< (file-or-directory-modify-seconds orig-path)
+          (file-or-directory-modify-seconds candidate-path))))
+
+(define (already-a-compiled-file? path) 
+  (let* ([filename (file-name-from-path path)]
+         [base (path-only path)]
+         [file-zo-name (and filename (compiled-name filename #".zo"))]
+         [fm (file-or-directory-modify-seconds path)]
+         [newer-exists?
+          (λ (pot-path)
+            (and (file-exists? pot-path)
+                 (< fm (file-or-directory-modify-seconds pot-path))))])
+    (and file-zo-name
+         (ormap 
+          (λ (c-f-p)
+            (or (newer-exists? (build-path base c-f-p file-zo-name))
+                (newer-exists? (build-path base 
+                                           c-f-p 
+                                           "native"
+                                           (system-library-subpath)
+                                           (compiled-name filename (system-type 'so-suffix))))))
+          (use-compiled-file-paths)))))
+
+
+;; compiled-name : path [bytes] -> path or #f
+;; returns #f if the path does not have an extension.
+;; otherwise, returns an appropriately modified filename, extended with new-extension
+(define (compiled-name path new-extension)
+  (let* ([extension (filename-extension path)]
+         [basename (and extension
+                        (let ([pbs (path->bytes path)])
+                          (subbytes pbs
+                                    0 
+                                    (- (bytes-length pbs)
+                                       (bytes-length extension)
+                                       1 ;; extra one for '.' in there
+                                       ))))])
+    (and basename
+         (bytes->path
+          (bytes-append basename #"_" extension new-extension)))))
+

collects/framework/private/editor.ss

@@ -202,6 +202,7 @@
                        (file-exists? filename)
                        (file-or-directory-modify-seconds filename)))))
         (inner (void) after-load-file success?))
+      
       (define/public (save-file-out-of-date?)
         (and last-saved-file-time
              (let ([fn (get-filename)])

collects/scribblings/mzc/make.scrbl

@@ -241,6 +241,15 @@ 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?))]{
+
+  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.
+
+  If it is @scheme[#f], then @scheme[use-compiled-file-paths] is used.
+}
+
 @; ----------------------------------------------------------------------
 
 @section{Compilation Manager Hook for Syntax Transformers}