add src-filter to create-exembedding-executable

svn: r6028

collects/compiler/doc.txt

@@ -408,7 +408,8 @@ _embedr-sig.ss_ library provides the signature, _compiler:embed^_.
                                [#:launcher? launcher?]
                                [#:verbose? verbose?]
                                [#:compiler compile-proc]
-                               [#:expand-namespace expand-namespace])
+                               [#:expand-namespace expand-namespace]
+                               [#:src-filter src-filter-proc])
   - Copies the MzScheme (if `mred?' is #f) or MrEd (otherwise) binary,
   embedding code into the copied executable to be loaded on startup.
   (Under Unix, the binary is actually a wrapper executable that execs
@@ -601,6 +602,13 @@ _embedr-sig.ss_ library provides the signature, _compiler:embed^_.
    be directed to the current locations (and, unltimately, redirected
    to copies in a distribution).
 
+   The `src-filter-proc' takes a path and returns true if the
+   corresponding file source be included in the embedding executable
+   in source form (insteda of compiled form), #f otherwise. The
+   default returns #f for all paths. Beware that the current output
+   port may be redirected to the result executable when the filter
+   procedure is called.
+
 > (make-embedding-executable dest mred? verbose? mod-list literal-file-list literal-sexpr cmdline-list [aux launcher? variant])
 
    Old (keywordless) interface to `create-embedding-executable'.

collects/compiler/embed-unit.ss

@@ -329,6 +329,10 @@
             (make-directory* base)
             p))))
 
+    (define (file-date f)
+      (with-handlers ([exn:fail:filesystem? (lambda (x) -inf.0)])
+        (file-or-directory-modify-seconds f)))
+    
     (define-struct extension (path))
     
     ;; Loads module code, using .zo if there, compiling from .scm if not
@@ -365,8 +369,15 @@
                                                             "cannot use a _loader extension: ~e"
                                                             file)
                                                      (make-extension file))))
-					   ;; Prefer extensions if we're handling them:
+                                           #:choose
-					   (not on-extension))]
+                                           ;; Prefer extensions, if we're handling them:
+                                           (lambda (src zo so)
+                                             (if on-extension
+                                                 #f
+                                                 (if (and (file-exists? so)
+                                                          ((file-date so) . >= . (file-date zo)))
+                                                     'so
+                                                     #f))))]
                     [name (let-values ([(base name dir?) (split-path filename)])
                             (path->string (path-replace-suffix name #"")))]
                     [prefix (let ([a (assoc filename prefixes)])
@@ -549,7 +560,7 @@
     ;; Write a module bundle that can be loaded with 'load' (do not embed it
     ;; into an executable). The bundle is written to the current output port.
     (define (write-module-bundle verbose? modules literal-files literal-expression collects-dest
-                                 on-extension program-name compiler expand-namespace)
+                                 on-extension program-name compiler expand-namespace src-filter)
       (let* ([module-paths (map cadr modules)]
              [files (map
                      (lambda (mp)
@@ -676,7 +687,11 @@
                (when verbose?
                  (fprintf (current-error-port) "Writing module from ~s~n" (mod-file nc)))
                (write `(current-module-name-prefix ',(string->symbol (mod-prefix nc))))
-               (write (mod-code nc))))
+               (if (src-filter (mod-file nc))
+                   (with-input-from-file (mod-file nc)
+                     (lambda ()
+                       (copy-port (current-input-port) (current-output-port))))
+                   (write (mod-code nc)))))
            l))
         (write '(current-module-name-prefix #f))
         (newline)
@@ -729,7 +744,8 @@
                                             [expand-namespace (current-namespace)]
                                             [compiler (lambda (expr)
                                                         (parameterize ([current-namespace expand-namespace])
-                                                          (compile expr)))])
+                                                          (compile expr)))]
+                                            [src-filter (lambda (filename) #f)])
       (define keep-exe? (and launcher?
                              (let ([m (assq 'forget-exe? aux)])
                                (or (not m)
@@ -828,7 +844,8 @@
                                           on-extension
                                           (file-name-from-path dest)
                                           compiler
-                                          expand-namespace))])
+                                          expand-namespace
+                                          src-filter))])
               (let-values ([(start end)
                             (if (and (eq? (system-type) 'macosx)
                                      (not unix-starter?))

collects/syntax/doc.txt

@@ -323,7 +323,8 @@ _modread.ss_: reading module source code
 _modcode.ss_: getting module compiled code
 ======================================================================
 
-> (get-module-code path [compiled-subdir compile-proc ext-proc prefer-ext?]) -
+> (get-module-code path [compiled-subdir compile-proc ext-proc]
+                   [#:choose choose-proc]) -
   returns a compiled expression for the declaration of the module
   specified by `module-path-v'. The `module-path-v' argument is a
   quoted module path, as for MzScheme's `dynamic-require' using the
@@ -337,21 +338,29 @@ _modcode.ss_: getting module compiled code
   available.
 
   The `ext-proc' argument defaults to #f. If it is not #f, it must be
-  a procedure of two arguments that is used when `path' does not exist
+  a procedure of two arguments that is called when a native-code
-  and no ".zo" version of `path' can be found, but an extension
+  version of `path' is should be used. In that case, the arguments to
-  implementing `path' is found. In that case, the arguments to
   `ext-proc' are the path for the extension, and a boolean indicating
   whether the extension is a _loader file (#t) or not (#f).
 
-  If a ".zo" version of `path' is available and newer than var `path'
+  The `choose-proc' argument is a procedure that takes three paths: a
-  (in one of the directories specified by `compiled-subdir'), then it
+  source path, a .zo file path, and an extension path (for a
-  is used instead of the source. Native-code versions of `path' are
+  non-_loader extension). Some of the paths may not exist. The result
-  ignored --- unless only a native-code version exists (i.e., `path'
+  should be either 'src, 'zo, 'so, or #f, indicating which variant
-  itself does not exist), or `prefer-ext?' is true and the native-code
+  should be used or (in the case of #f) that the default choice should
-  file is not a _loader variant. If a native-code version is prefer or
+  be used.
-  is the only file that exists, it is supplied to `ext-proc' when
+
-  `ext-proc' is #f, or an exception is raised (to report that an
+  The default choice is computed as follows: if a ".zo" version of
-  extension file cannot be used) when `ext-proc' is #f.
+  `path' is available and newer than `path' itself (in one of the
+  directories specified by `compiled-subdir'), then it is used instead
+  of the source. Native-code versions of `path' are ignored, unless
+  only a native-code non_loader version exists (i.e., `path' itself
+  does not exist). A _loader extension is selected a last resort.
+
+  If an extension is prefered or is the only file that exists, it is
+  supplied to `ext-proc' when `ext-proc' is #f, or an exception is
+  raised (to report that an extension file cannot be used) when
+  `ext-proc' is #f.
 
 > moddep-current-open-input-file
  

collects/syntax/modcode.ss

@@ -9,7 +9,10 @@
            exn:get-module-code
            exn:get-module-code?
            exn:get-module-code-path
-           make-exn:get-module-code)
+           make-exn:get-module-code
+           get-module-code)
+  #;
+  ;; Contracts don't yet play well with keyword arguments:
   (provide/contract
    [get-module-code ([path-string?]
                      [(and/c path-string? relative-path?)
@@ -65,7 +68,9 @@
 
   (define/kw (get-module-code path
                #:optional
-               [sub-path "compiled"] [compiler compile] [extension-handler #f] [prefer-so? #f])
+               [sub-path "compiled"] [compiler compile] [extension-handler #f] 
+               #:key
+               [choose (lambda (src zo so) #f)])
     (unless (path-string? path)
       (raise-type-error 'get-module-code "path or string (sans nul)" path))
     (let*-values ([(path) (resolve path)]
@@ -87,13 +92,19 @@
                                          (if (path? base)
                                            base
                                            (current-directory))])
-                           (t)))])
+                           (t)))]
+             [prefer (choose path zo so)])
         (cond
           ;; Use .zo, if it's new enough
-          [(date>=? zo path-d) (read-one zo #f)]
+          [(or (eq? prefer 'zo)
+               (and (not prefer)
+                    (date>=? zo path-d)))
+           (read-one zo #f)]
           ;; Maybe there's an .so? Use it only if we don't prefer source.
-          [(and (or (not path-d) prefer-so?)
+          [(or (eq? prefer 'so)
-		(date>=? so path-d))
+               (and (not prefer)
+                    (or (not path-d)
+                        (date>=? so path-d))))
            (if extension-handler
              (extension-handler so #f)
              (raise (make-exn:get-module-code
@@ -101,7 +112,9 @@
                      (current-continuation-marks)
                      so)))]
           ;; Use source if it exists
-          [path-d (with-dir (lambda () (compiler (read-one path #t))))]
+          [(or (eq? prefer 'src)
+               path-d)
+           (with-dir (lambda () (compiler (read-one path #t))))]
           ;; Or maybe even a _loader.so?
           [(and (not path-d)
                 (date>=? _loader-so path-d)