Skip incompatible .go files

* libguile/load.c (load_thunk_from_path, try_load_thunk_from_file):
  New functions.
  (search_path): Simplify.
  (scm_primitive_load_path, scm_init_eval_in_scheme): Use the new
  functions to load compiled files.
* module/ice-9/boot-9.scm (load-in-vicinity): Skip invalid .go files.

Inspired by a patch from Jan Nieuwenhuizen <janneke@gnu.org>.

libguile/load.c

@@ -28,26 +28,27 @@
 #include <stdio.h>
 
 #include "libguile/_scm.h"
-#include "libguile/private-gc.h" /* scm_getenv_int */
-#include "libguile/libpath.h"
-#include "libguile/fports.h"
-#include "libguile/read.h"
-#include "libguile/eval.h"
-#include "libguile/throw.h"
 #include "libguile/alist.h"
-#include "libguile/dynwind.h"
-#include "libguile/root.h"
-#include "libguile/strings.h"
-#include "libguile/modules.h"
 #include "libguile/chars.h"
-#include "libguile/srfi-13.h"
+#include "libguile/dynwind.h"
-
+#include "libguile/eval.h"
-#include "libguile/validate.h"
-#include "libguile/load.h"
 #include "libguile/fluids.h"
-
+#include "libguile/fports.h"
+#include "libguile/libpath.h"
+#include "libguile/modules.h"
+#include "libguile/objcodes.h"
+#include "libguile/private-gc.h" /* scm_getenv_int */
+#include "libguile/programs.h"
+#include "libguile/read.h"
+#include "libguile/root.h"
+#include "libguile/srfi-13.h"
+#include "libguile/strings.h"
+#include "libguile/throw.h"
+#include "libguile/validate.h"
 #include "libguile/vm.h" /* for load-compiled/vm */
 
+#include "libguile/load.h"
+
 #include <sys/types.h>
 #include <sys/stat.h>
 #include <unistd.h>
@@ -542,13 +543,259 @@ is_absolute_file_name (SCM filename)
   return 0;
 }
 
+/* Return true if COMPILED_FILENAME is newer than source file
+   FULL_FILENAME, false otherwise.  */
+static int
+compiled_is_fresh (SCM full_filename, SCM compiled_filename,
+                   struct stat *stat_source, struct stat *stat_compiled)
+{
+  int compiled_is_newer;
+  struct timespec source_mtime, compiled_mtime;
+
+  source_mtime = get_stat_mtime (stat_source);
+  compiled_mtime = get_stat_mtime (stat_compiled);
+
+  if (source_mtime.tv_sec < compiled_mtime.tv_sec
+      || (source_mtime.tv_sec == compiled_mtime.tv_sec
+          && source_mtime.tv_nsec <= compiled_mtime.tv_nsec))
+    compiled_is_newer = 1;
+  else
+    {
+      compiled_is_newer = 0;
+      scm_puts (";;; note: source file ", scm_current_warning_port ());
+      scm_display (full_filename, scm_current_warning_port ());
+      scm_puts ("\n;;;       newer than compiled ", scm_current_warning_port ());
+      scm_display (compiled_filename, scm_current_warning_port ());
+      scm_puts ("\n", scm_current_warning_port ());
+    }
+
+  return compiled_is_newer;
+}
+
+static SCM
+load_thunk_from_file (SCM file)
+{
+  return scm_make_program (scm_load_objcode (file), SCM_BOOL_F, SCM_BOOL_F);
+}
+
+static SCM
+do_load_thunk_from_file (void *data)
+{
+  return load_thunk_from_file (PTR2SCM (data));
+}
+
+static SCM
+load_thunk_from_file_catch_handler (void *data, SCM tag, SCM throw_args)
+{
+  SCM filename = PTR2SCM (data);
+  SCM oport, lines;
+
+  oport = scm_open_output_string ();
+  scm_print_exception (oport, SCM_BOOL_F, tag, throw_args);
+
+  scm_puts (";;; WARNING: loading compiled file ",
+            scm_current_warning_port ());
+  scm_display (filename, scm_current_warning_port ());
+  scm_puts (" failed:\n", scm_current_warning_port ());
+
+  lines = scm_string_split (scm_get_output_string (oport),
+                            SCM_MAKE_CHAR ('\n'));
+  for (; scm_is_pair (lines); lines = scm_cdr (lines))
+    if (scm_c_string_length (scm_car (lines)))
+      {
+        scm_puts (";;; ", scm_current_warning_port ());
+        scm_display (scm_car (lines), scm_current_warning_port ());
+        scm_newline (scm_current_warning_port ());
+      }
+
+  scm_close_port (oport);
+
+  return SCM_BOOL_F;
+}
+
+static SCM
+try_load_thunk_from_file (SCM filename)
+{
+  return scm_c_catch (SCM_BOOL_T,
+                      do_load_thunk_from_file,
+                      PTR2SCM (filename),
+                      load_thunk_from_file_catch_handler,
+                      PTR2SCM (filename),
+                      NULL, NULL);
+}
+
+/* Search the %load-compiled-path for a directory containing a file
+   named FILENAME.  The file must be readable, and not a directory.  If
+   we don't find one, return #f.  If we do fine one, treat it as a
+   compiled file and try to load it as a thunk.  If that fails, continue
+   looking in the path.
+
+   If given, EXTENSIONS is a list of strings; for each directory in
+   PATH, we search for FILENAME concatenated with each EXTENSION.
+
+   If SOURCE_FILE_NAME is true, then only try to load compiled files
+   that are newer than SOURCE_STAT_BUF.  If they are older, otherwise issuing a warning if
+   we see a stale file earlier in the path, setting *FOUND_STALE_FILE to
+   1.
+  */
+static SCM
+load_thunk_from_path (SCM filename, SCM source_file_name,
+                      struct stat *source_stat_buf,
+                      int *found_stale_file)
+{
+  struct stringbuf buf;
+  struct stat stat_buf;
+  char *filename_chars;
+  size_t filename_len;
+  SCM path, extensions;
+  SCM result = SCM_BOOL_F;
+  char initial_buffer[256];
+
+  path = *scm_loc_load_compiled_path;
+  if (scm_ilength (path) < 0)
+    scm_misc_error ("%search-path", "path is not a proper list: ~a",
+                    scm_list_1 (path));
+
+  extensions = *scm_loc_load_compiled_extensions;
+  if (scm_ilength (extensions) < 0)
+    scm_misc_error ("%search-path", "bad extensions list: ~a",
+                    scm_list_1 (extensions));
+
+  scm_dynwind_begin (0);
+
+  filename_chars = scm_to_locale_string (filename);
+  filename_len = strlen (filename_chars);
+  scm_dynwind_free (filename_chars);
+
+  /* If FILENAME is absolute and is still valid, return it unchanged.  */
+  if (is_absolute_file_name (filename))
+    {
+      if (string_has_an_ext (filename, extensions)
+          && stat (filename_chars, &stat_buf) == 0
+          && !(stat_buf.st_mode & S_IFDIR))
+        result = load_thunk_from_file (filename);
+      goto end;
+    }
+
+  /* If FILENAME has an extension, don't try to add EXTENSIONS to it.  */
+  {
+    char *endp;
+
+    for (endp = filename_chars + filename_len - 1;
+	 endp >= filename_chars;
+	 endp--)
+      {
+	if (*endp == '.')
+	  {
+            if (!string_has_an_ext (filename, extensions))
+              {
+                /* This filename has an extension, but not one of the right
+                   ones... */
+                goto end;
+              }
+	    /* This filename already has an extension, so cancel the
+               list of extensions.  */
+	    extensions = SCM_EOL;
+	    break;
+	  }
+	else if (is_file_name_separator (SCM_MAKE_CHAR (*endp)))
+	  /* This filename has no extension, so keep the current list
+             of extensions.  */
+	  break;
+      }
+  }
+
+  /* This simplifies the loop below a bit.
+   */
+  if (scm_is_null (extensions))
+    extensions = scm_listofnullstr;
+
+  buf.buf_len = sizeof initial_buffer;
+  buf.buf = initial_buffer;
+
+  /* Try every path element.
+   */
+  for (; scm_is_pair (path); path = SCM_CDR (path))
+    {
+      SCM dir = SCM_CAR (path);
+      SCM exts;
+      size_t sans_ext_len;
+
+      buf.ptr = buf.buf;
+      stringbuf_cat_locale_string (&buf, dir);
+	
+      /* Concatenate the path name and the filename. */
+      
+      if (buf.ptr > buf.buf
+          && !is_file_name_separator (SCM_MAKE_CHAR (buf.ptr[-1])))
+	stringbuf_cat (&buf, FILE_NAME_SEPARATOR_STRING);
+
+      stringbuf_cat (&buf, filename_chars);
+      sans_ext_len = buf.ptr - buf.buf;
+
+      /* Try every extension. */
+      for (exts = extensions; scm_is_pair (exts); exts = SCM_CDR (exts))
+	{
+	  SCM ext = SCM_CAR (exts);
+	  
+	  buf.ptr = buf.buf + sans_ext_len;
+	  stringbuf_cat_locale_string (&buf, ext);
+	  
+	  /* If the file exists at all, we should return it.  If the
+	     file is inaccessible, then that's an error.  */
+
+	  if (stat (buf.buf, &stat_buf) == 0
+	      && ! (stat_buf.st_mode & S_IFDIR))
+	    {
+	      SCM found =
+		scm_from_locale_string (scm_i_mirror_backslashes (buf.buf));
+
+              if (scm_is_true (source_file_name) &&
+                  !compiled_is_fresh (source_file_name, found,
+                                      source_stat_buf, &stat_buf))
+                {
+                  if (found_stale_file)
+                    *found_stale_file = 1;
+                  continue;
+                }
+
+              result = try_load_thunk_from_file (found);
+              if (scm_is_false (result))
+                /* Already warned.  */
+                continue;
+
+              if (found_stale_file && *found_stale_file)
+                {
+                  scm_puts (";;; found fresh compiled file at ",
+                                     scm_current_warning_port ());
+                  scm_display (found, scm_current_warning_port ());
+                  scm_newline (scm_current_warning_port ());
+                }
+
+	      goto end;
+	    }
+	}
+      
+      if (!SCM_NULL_OR_NIL_P (exts))
+	scm_wrong_type_arg_msg (NULL, 0, extensions, "proper list");
+    }
+
+  if (!SCM_NULL_OR_NIL_P (path))
+    scm_wrong_type_arg_msg (NULL, 0, path, "proper list");
+
+ end:
+  scm_dynwind_end ();
+  return result;
+}
+
 /* Search PATH for a directory containing a file named FILENAME.
    The file must be readable, and not a directory.
    If we find one, return its full pathname; otherwise, return #f.
    If FILENAME is absolute, return it unchanged.
    We also fill *stat_buf corresponding to the returned pathname.
    If given, EXTENSIONS is a list of strings; for each directory 
-   in PATH, we search for FILENAME concatenated with each EXTENSION.  */
+   in PATH, we search for FILENAME concatenated with each EXTENSION.
+  */
 static SCM
 search_path (SCM path, SCM filename, SCM extensions, SCM require_exts,
              struct stat *stat_buf)
@@ -755,35 +1002,6 @@ SCM_DEFINE (scm_sys_search_load_path, "%search-load-path", 1, 0, 0,
 #undef FUNC_NAME
 
 
-/* Return true if COMPILED_FILENAME is newer than source file
-   FULL_FILENAME, false otherwise.  */
-static int
-compiled_is_fresh (SCM full_filename, SCM compiled_filename,
-                   struct stat *stat_source, struct stat *stat_compiled)
-{
-  int compiled_is_newer;
-  struct timespec source_mtime, compiled_mtime;
-
-  source_mtime = get_stat_mtime (stat_source);
-  compiled_mtime = get_stat_mtime (stat_compiled);
-
-  if (source_mtime.tv_sec < compiled_mtime.tv_sec
-      || (source_mtime.tv_sec == compiled_mtime.tv_sec
-          && source_mtime.tv_nsec <= compiled_mtime.tv_nsec))
-    compiled_is_newer = 1;
-  else
-    {
-      compiled_is_newer = 0;
-      scm_puts (";;; note: source file ", scm_current_error_port ());
-      scm_display (full_filename, scm_current_error_port ());
-      scm_puts ("\n;;;       newer than compiled ", scm_current_error_port ());
-      scm_display (compiled_filename, scm_current_error_port ());
-      scm_puts ("\n", scm_current_error_port ());
-    }
-
-  return compiled_is_newer;
-}
-
 SCM_KEYWORD (kw_env, "env");
 SCM_KEYWORD (kw_opts, "opts");
 
@@ -946,10 +1164,10 @@ SCM_DEFINE (scm_primitive_load_path, "primitive-load-path", 0, 0, 1,
 #define FUNC_NAME s_scm_primitive_load_path
 {
   SCM filename, exception_on_not_found;
-  SCM full_filename, compiled_filename;
+  SCM full_filename, compiled_thunk;
-  int compiled_is_fallback = 0;
   SCM hook = *scm_loc_load_hook;
   struct stat stat_source, stat_compiled;
+  int found_stale_compiled_file = 0;
 
   if (scm_is_true (hook) && scm_is_false (scm_procedure_p (hook)))
     SCM_MISC_ERROR ("value of %load-hook is neither a procedure nor #f",
@@ -985,12 +1203,10 @@ SCM_DEFINE (scm_primitive_load_path, "primitive-load-path", 0, 0, 1,
                                *scm_loc_load_extensions, SCM_BOOL_F,
                                &stat_source);
 
-  compiled_filename =
+  compiled_thunk = load_thunk_from_path (filename, full_filename, &stat_source,
-    search_path (*scm_loc_load_compiled_path, filename,
+                                         &found_stale_compiled_file);
-                 *scm_loc_load_compiled_extensions, SCM_BOOL_T,
-                 &stat_compiled);
 
-  if (scm_is_false (compiled_filename)
+  if (scm_is_false (compiled_thunk)
       && scm_is_true (full_filename)
       && scm_is_true (*scm_loc_compile_fallback_path)
       && scm_is_false (*scm_loc_fresh_auto_compile)
@@ -1006,15 +1222,23 @@ SCM_DEFINE (scm_primitive_load_path, "primitive-load-path", 0, 0, 1,
                      scm_car (*scm_loc_load_compiled_extensions)));
 
       fallback_chars = scm_to_locale_string (fallback);
-      if (stat (fallback_chars, &stat_compiled) == 0)
+      if (stat (fallback_chars, &stat_compiled) == 0
+          && compiled_is_fresh (full_filename, fallback,
+                                &stat_source, &stat_compiled))
         {
-          compiled_filename = fallback;
+          if (found_stale_compiled_file)
-          compiled_is_fallback = 1;
+            {
+              scm_puts (";;; found fresh local cache at ",
+                                 scm_current_warning_port ());
+              scm_display (fallback, scm_current_warning_port ());
+              scm_newline (scm_current_warning_port ());
+            }
+          compiled_thunk = try_load_thunk_from_file (fallback);
         }
       free (fallback_chars);
     }
   
-  if (scm_is_false (full_filename) && scm_is_false (compiled_filename))
+  if (scm_is_false (full_filename) && scm_is_false (compiled_thunk))
     {
       if (scm_is_true (scm_procedure_p (exception_on_not_found)))
         return scm_call_0 (exception_on_not_found);
@@ -1026,56 +1250,19 @@ SCM_DEFINE (scm_primitive_load_path, "primitive-load-path", 0, 0, 1,
     }
 
   if (!scm_is_false (hook))
-    scm_call_1 (hook, (scm_is_true (full_filename)
+    scm_call_1 (hook, full_filename);
-                       ? full_filename : compiled_filename));
 
-  if (scm_is_false (full_filename)
+  if (scm_is_true (compiled_thunk))
-      || (scm_is_true (compiled_filename)
+    return scm_call_0 (compiled_thunk);
-          && compiled_is_fresh (full_filename, compiled_filename,
+  else
-                                &stat_source, &stat_compiled)))
-    return scm_load_compiled_with_vm (compiled_filename);
-
-  /* Perhaps there was the installed .go that was stale, but our fallback is
-     fresh. Let's try that. Duplicating code, but perhaps that's OK. */
-
-  if (!compiled_is_fallback
-      && scm_is_true (*scm_loc_compile_fallback_path)
-      && scm_is_false (*scm_loc_fresh_auto_compile)
-      && scm_is_pair (*scm_loc_load_compiled_extensions)
-      && scm_is_string (scm_car (*scm_loc_load_compiled_extensions)))
     {
-      SCM fallback;
+      SCM freshly_compiled = scm_try_auto_compile (full_filename);
-      char *fallback_chars;
-      int stat_ret;
 
-      fallback = scm_string_append
+      if (scm_is_true (freshly_compiled))
-        (scm_list_3 (*scm_loc_compile_fallback_path,
+        return scm_load_compiled_with_vm (freshly_compiled);
-                     canonical_suffix (full_filename),
+      else
-                     scm_car (*scm_loc_load_compiled_extensions)));
+        return scm_primitive_load (full_filename);
-
-      fallback_chars = scm_to_locale_string (fallback);
-      stat_ret = stat (fallback_chars, &stat_compiled);
-      free (fallback_chars);
-
-      if (stat_ret == 0 && compiled_is_fresh (full_filename, fallback,
-                                              &stat_source, &stat_compiled))
-        {
-          scm_puts (";;; found fresh local cache at ", scm_current_warning_port ());
-          scm_display (fallback, scm_current_warning_port ());
-          scm_newline (scm_current_warning_port ());
-          return scm_load_compiled_with_vm (fallback);
-        }
     }
-
-  /* Otherwise, we bottom out here. */
-  {
-    SCM freshly_compiled = scm_try_auto_compile (full_filename);
-
-    if (scm_is_true (freshly_compiled))
-      return scm_load_compiled_with_vm (freshly_compiled);
-    else
-      return scm_primitive_load (full_filename);
-  }
 }
 #undef FUNC_NAME
 
@@ -1088,20 +1275,19 @@ scm_c_primitive_load_path (const char *filename)
 void
 scm_init_eval_in_scheme (void)
 {
-  SCM eval_scm, eval_go;
+  SCM eval_scm, eval_thunk;
-  struct stat stat_source, stat_compiled;
+  struct stat stat_source;
+  int found_stale_eval_go = 0;
 
   eval_scm = search_path (*scm_loc_load_path,
                           scm_from_locale_string ("ice-9/eval.scm"),
                           SCM_EOL, SCM_BOOL_F, &stat_source);
-  eval_go = search_path (*scm_loc_load_compiled_path,
+  eval_thunk =
-                         scm_from_locale_string ("ice-9/eval.go"),
+    load_thunk_from_path (scm_from_locale_string ("ice-9/eval.go"),
-                         SCM_EOL, SCM_BOOL_F, &stat_compiled);
+                          eval_scm, &stat_source, &found_stale_eval_go);
   
-  if (scm_is_true (eval_scm) && scm_is_true (eval_go)
+  if (scm_is_true (eval_thunk))
-      && compiled_is_fresh (eval_scm, eval_go,
+    scm_call_0 (eval_thunk);
-                            &stat_source, &stat_compiled))
-    scm_load_compiled_with_vm (eval_go);
   else
     /* if we have no eval.go, we shouldn't load any compiled code at all */
     *scm_loc_load_compiled_path = SCM_EOL;

module/ice-9/boot-9.scm

@@ -3970,19 +3970,25 @@ when none is available, reading FILE-NAME with READER."
      #:opts %auto-compilation-options
      #:env (current-module)))
 
-  ;; Returns the .go file corresponding to `name'.  Does not search load
+  (define (load-thunk-from-file file)
-  ;; paths, only the fallback path.  If the .go file is missing or out
+    (let ((objcode (resolve-interface '(system vm objcode)))
-  ;; of date, and auto-compilation is enabled, will try
+          (program (resolve-interface '(system vm program))))
-  ;; auto-compilation, just as primitive-load-path does internally.
+      ((module-ref program 'make-program)
-  ;; primitive-load is unaffected.  Returns #f if auto-compilation
+       ((module-ref objcode 'load-objcode) file))))
-  ;; failed or was disabled.
+
+  ;; Returns a thunk loaded from 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 as primitive-load-path does
+  ;; internally.  primitive-load is unaffected.  Returns #f if
+  ;; auto-compilation failed or was disabled.
   ;;
   ;; 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 (fresh-compiled-file-name name scmstat go-file-name)
+  (define (fresh-compiled-thunk name scmstat go-file-name)
     ;; Return GO-FILE-NAME after making sure that it contains a freshly
     ;; compiled version of source file NAME with stat SCMSTAT; return #f
     ;; on failure.
@@ -3990,19 +3996,19 @@ when none is available, reading FILE-NAME with READER."
      (let ((gostat (and (not %fresh-auto-compile)
                         (stat go-file-name #f))))
        (if (and gostat (more-recent? gostat scmstat))
-           go-file-name
+           (load-thunk-from-file go-file-name)
            (begin
-             (if gostat
+             (when gostat
-                 (format (current-warning-port)
+               (format (current-warning-port)
-                         ";;; note: source file ~a\n;;;       newer than compiled ~a\n"
+                       ";;; note: source file ~a\n;;;       newer than compiled ~a\n"
-                         name go-file-name))
+                       name go-file-name))
              (cond
               (%load-should-auto-compile
                (%warn-auto-compilation-enabled)
                (format (current-warning-port) ";;; compiling ~a\n" name)
                (let ((cfn (compile name)))
                  (format (current-warning-port) ";;; compiled ~a\n" cfn)
-                 cfn))
+                 (load-thunk-from-file cfn)))
               (else #f)))))
      #:warning "WARNING: compilation of ~a failed:\n" name))
 
@@ -4021,28 +4027,36 @@ when none is available, reading FILE-NAME with READER."
        #:warning "Stat of ~a failed:\n" abs-file-name))
 
     (define (pre-compiled)
-      (and=> (search-path %load-compiled-path (sans-extension file-name)
+      (or-map
-                          %load-compiled-extensions #t)
+       (lambda (dir)
-             (lambda (go-file-name)
+         (or-map
-               (let ((gostat (stat go-file-name #f)))
+          (lambda (ext)
-                 (and gostat (more-recent? gostat scmstat)
+            (let ((candidate (string-append (in-vicinity dir file-name) ext)))
-                      go-file-name)))))
+              (let ((gostat (stat candidate #f)))
+                (and gostat
+                     (more-recent? gostat scmstat)
+                     (false-if-exception
+                      (load-thunk-from-file candidate)
+                      #:warning "WARNING: failed to load compiled file ~a:\n"
+                      candidate)))))
+          %load-compiled-extensions))
+       %load-compiled-path))
 
     (define (fallback)
       (and=> (false-if-exception (canonicalize-path abs-file-name))
              (lambda (canon)
                (and=> (fallback-file-name canon)
                       (lambda (go-file-name)
-                        (fresh-compiled-file-name abs-file-name
+                        (fresh-compiled-thunk abs-file-name
-                                                  scmstat
+                                              scmstat
-                                                  go-file-name))))))
+                                              go-file-name))))))
 
     (let ((compiled (and scmstat (or (pre-compiled) (fallback)))))
       (if compiled
           (begin
             (if %load-hook
                 (%load-hook abs-file-name))
-            (load-compiled compiled))
+            (compiled))
           (start-stack 'load-stack
                        (primitive-load abs-file-name)))))