`load' autocompiles

* libguile/load.h:
* libguile/load.c (scm_sys_warn_autocompilation_enabled): New primitive,
  not exported. Since `load' autocompiles now, it should warn in the
  same way that the bits hardcoded into C warn.
  (scm_try_autocompile): Use scm_sys_warn_autocompilation_enabled.

* module/ice-9/boot-9.scm (autocompiled-file-name): New helper.
  (load): Try autocompiling the argument, if appropriate. Will
  autocompile files passed on Guile's command line. `primitive-load' is
  unaffected.

diff --git a/libguile/load.c b/libguile/load.c
index 08324c5..8a6fadb 100644 (file)
--- a/libguile/load.c
+++ b/libguile/load.c
@@ -639,14 +639,11 @@ autocompile_catch_handler (void *data, SCM tag, SCM throw_args)
   return SCM_BOOL_F;
 }
 
-static SCM
-scm_try_autocompile (SCM source)
+SCM_DEFINE (scm_sys_warn_autocompilation_enabled, "%warn-autocompilation-enabled", 0, 0, 0,
+           (void), "")
 {
   static int message_shown = 0;
   
-  if (scm_is_false (*scm_loc_load_should_autocompile))
-    return SCM_BOOL_F;
-
   if (!message_shown)
     {
       scm_puts (";;; note: autocompilation is enabled, set GUILE_AUTO_COMPILE=0\n"
@@ -655,6 +652,17 @@ scm_try_autocompile (SCM source)
       message_shown = 1;
     }
 
+  return SCM_UNSPECIFIED;
+}
+
+  
+static SCM
+scm_try_autocompile (SCM source)
+{
+  if (scm_is_false (*scm_loc_load_should_autocompile))
+    return SCM_BOOL_F;
+
+  scm_sys_warn_autocompilation_enabled ();
   return scm_c_catch (SCM_BOOL_T,
                       do_try_autocompile,
                       SCM2PTR (source),

diff --git a/libguile/load.h b/libguile/load.h
index d5bc1b0..1a1a865 100644 (file)
--- a/libguile/load.h
+++ b/libguile/load.h
@@ -36,6 +36,7 @@ SCM_API SCM scm_search_path (SCM path, SCM filename, SCM exts, SCM require_exts)
 SCM_API SCM scm_sys_search_load_path (SCM filename);
 SCM_API SCM scm_primitive_load_path (SCM filename, SCM exception_on_not_found);
 SCM_API SCM scm_c_primitive_load_path (const char *filename);
+SCM_INTERNAL SCM scm_sys_warn_autocompilation_enabled (void);
 SCM_INTERNAL void scm_init_load_path (void);
 SCM_INTERNAL void scm_init_load (void);
 

diff --git a/module/ice-9/boot-9.scm b/module/ice-9/boot-9.scm
index 01569cb..574cb2b 100644 (file)
--- a/module/ice-9/boot-9.scm
+++ b/module/ice-9/boot-9.scm
@@ -867,11 +867,46 @@
 
 (set! %load-hook %load-announce)
 
+;;; 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 autocompilation is enabled, will try autocompilation, just
+;;; as primitive-load-path does internally. primitive-load is
+;;; unaffected. Returns #f if autocompilation failed or was disabled.
+(define (autocompiled-file-name name)
+  (catch #t
+    (lambda ()
+      (let* ((cfn ((@ (system base compile) compiled-file-name) name))
+             (scmstat (stat name))
+             (gostat (stat cfn #f)))
+        (if (and gostat (= (stat:mtime gostat) (stat:mtime scmstat)))
+            cfn
+            (begin
+              (if gostat
+                  (format (current-error-port)
+                    ";;; note: source file ~a\n;;;       newer than compiled ~a\n"
+                    name cfn))
+              (cond
+               (%load-should-autocompile
+                (%warn-autocompilation-enabled)
+                (format (current-error-port) ";;; compiling ~a\n" name)
+                (let ((cfn ((@ (system base compile) compile-file) name)))
+                  (format (current-error-port) ";;; compiled ~a\n" cfn)
+                  cfn))
+               (else #f))))))
+    (lambda (k . args)
+      (format (current-error-port)
+              ";;; WARNING: compilation of ~a failed:\n;;; key ~a, throw_args ~s\n"
+              name k args)
+      #f)))
+
 (define (load name . reader)
   (with-fluid* current-reader (and (pair? reader) (car reader))
     (lambda ()
-      (start-stack 'load-stack
-                  (primitive-load name)))))
+      (let ((cfn (autocompiled-file-name name)))
+        (if cfn
+            (load-compiled cfn)
+            (start-stack 'load-stack
+                         (primitive-load name)))))))
 
 \f