Split `load-in-vicinity' into small procedures.

* module/ice-9/boot-9.scm (load-in-vicinity)[compiled-extension]: New
  variable.
  [compiled-file-name]: Rename to...
  [fallback-file-name]: ... this; update caller.  Use COMPILED-EXTENSION.
  [more-recent?, compile, warn-about-exception]: New procedures.
  [fresh-compiled-file-name]: Use them.

diff --git a/module/ice-9/boot-9.scm b/module/ice-9/boot-9.scm
index f097a69..edae9b8 100644 (file)
--- a/module/ice-9/boot-9.scm
+++ b/module/ice-9/boot-9.scm
@@ -3569,6 +3569,10 @@ module '(ice-9 q) '(make-q q-length))}."
                 duplicate-case-datum bad-case-datum)))
 
 (define* (load-in-vicinity dir path #:optional reader)
+  "Load source file PATH in vicinity of directory DIR.  Use a pre-compiled
+version of PATH when available, and auto-compile one when none is available,
+reading PATH with READER."
+
   (define (canonical->suffix canon)
     (cond
      ((string-prefix? "/" canon) canon)
@@ -3578,6 +3582,49 @@ module '(ice-9 q) '(make-q q-length))}."
       (string-append "/" (substring canon 0 1) (substring canon 2)))
      (else canon)))
 
+  (define compiled-extension
+    ;; File name extension of compiled files.
+    (cond ((or (null? %load-compiled-extensions)
+               (string-null? (car %load-compiled-extensions)))
+           (warn "invalid %load-compiled-extensions"
+                 %load-compiled-extensions)
+           ".go")
+          (else (car %load-compiled-extensions))))
+
+  (define (more-recent? stat1 stat2)
+    ;; Return #t when STAT1 has an mtime greater than that of STAT2.
+    (or (> (stat:mtime stat1) (stat:mtime stat2))
+        (and (= (stat:mtime stat1) (stat:mtime stat2))
+             (>= (stat:mtimensec stat1)
+                 (stat:mtimensec stat2)))))
+
+  (define (fallback-file-name canon-path)
+    ;; Return the in-cache compiled file name for source file CANON-PATH.
+
+    ;; FIXME: would probably be better just to append SHA1(canon-path)
+    ;; to the %compile-fallback-path, to avoid deep directory stats.
+    (and %compile-fallback-path
+         (string-append %compile-fallback-path
+                        (canonical->suffix canon-path)
+                        compiled-extension)))
+
+  (define (compile file)
+    ;; Compile source FILE, lazily loading the compiler.
+    ((module-ref (resolve-interface '(system base compile))
+                 'compile-file)
+     file
+     #:opts %auto-compilation-options
+     #:env (current-module)))
+
+  (define (warn-about-exception key args)
+    (for-each (lambda (s)
+                (if (not (string-null? s))
+                    (format (current-warning-port) ";;; ~a\n" s)))
+              (string-split
+               (call-with-output-string
+                (lambda (port) (print-exception port #f key args)))
+               #\newline)))
+
   ;; Returns the .go file corresponding to `name'. Does not search load
   ;; paths, only the fallback path. If the .go file is missing or out of
   ;; date, and auto-compilation is enabled, will try auto-compilation, just
@@ -3587,32 +3634,16 @@ module '(ice-9 q) '(make-q q-length))}."
   ;; NB: Unless we need to compile the file, this function should not cause
   ;; (system base compile) to be loaded up. For that reason compiled-file-name
   ;; partially duplicates functionality from (system base compile).
-  ;;
-  (define (compiled-file-name canon-path)
-    ;; FIXME: would probably be better just to append SHA1(canon-path)
-    ;; to the %compile-fallback-path, to avoid deep directory stats.
-    (and %compile-fallback-path
-         (string-append
-          %compile-fallback-path
-          (canonical->suffix canon-path)
-          (cond ((or (null? %load-compiled-extensions)
-                     (string-null? (car %load-compiled-extensions)))
-                 (warn "invalid %load-compiled-extensions"
-                       %load-compiled-extensions)
-                 ".go")
-                (else (car %load-compiled-extensions))))))
 
   (define (fresh-compiled-file-name name go-path)
+    ;; Return GO-PATH after making sure that it contains a freshly compiled
+    ;; version of source file NAME; return #f on failure.
     (catch #t
       (lambda ()
         (let* ((scmstat (stat name))
                (gostat  (and (not %fresh-auto-compile)
                              (stat go-path #f))))
-          (if (and gostat
-                   (or (> (stat:mtime gostat) (stat:mtime scmstat))
-                       (and (= (stat:mtime gostat) (stat:mtime scmstat))
-                            (>= (stat:mtimensec gostat)
-                                (stat:mtimensec scmstat)))))
+          (if (and gostat (more-recent? gostat scmstat))
               go-path
               (begin
                 (if gostat
@@ -3623,26 +3654,14 @@ module '(ice-9 q) '(make-q q-length))}."
                  (%load-should-auto-compile
                   (%warn-auto-compilation-enabled)
                   (format (current-warning-port) ";;; compiling ~a\n" name)
-                  (let ((cfn
-                         ((module-ref
-                               (resolve-interface '(system base compile))
-                               'compile-file)
-                              name
-                              #:opts %auto-compilation-options
-                              #:env (current-module))))
+                  (let ((cfn (compile name)))
                     (format (current-warning-port) ";;; compiled ~a\n" cfn)
                     cfn))
                  (else #f))))))
       (lambda (k . args)
         (format (current-warning-port)
                 ";;; WARNING: compilation of ~a failed:\n" name)
-        (for-each (lambda (s)
-                    (if (not (string-null? s))
-                        (format (current-warning-port) ";;; ~a\n" s)))
-                  (string-split
-                   (call-with-output-string
-                    (lambda (port) (print-exception port #f k args)))
-                   #\newline))
+        (warn-about-exception k args)
         #f)))
 
   (define (absolute-path? path)
@@ -3651,7 +3670,7 @@ module '(ice-9 q) '(make-q q-length))}."
   (define (load-absolute abs-path)
     (let ((cfn (let ((canon (false-if-exception (canonicalize-path abs-path))))
                  (and canon
-                      (let ((go-path (compiled-file-name canon)))
+                      (let ((go-path (fallback-file-name canon)))
                         (and go-path
                              (fresh-compiled-file-name abs-path go-path)))))))
       (if cfn
@@ -3667,7 +3686,7 @@ module '(ice-9 q) '(make-q q-length))}."
      (with-fluids ((current-reader reader)
                    (%file-port-name-canonicalization 'relative))
        (cond
-        ((or (absolute-path? path))
+        ((absolute-path? path)
          (load-absolute path))
         ((absolute-path? dir)
          (load-absolute (in-vicinity dir path)))