From ae80e57f4dd214af10112e1a9188fb5b90ab6143 Mon Sep 17 00:00:00 2001
From: Jan Nieuwenhuizen <janneke@gnu.org>
Date: Fri, 11 Mar 2016 14:58:09 +0100
Subject: [PATCH] Skip invalid compiled file found, continue searching path.

* libguile/vm.c (scm_load_compiled_with_vm): Add argument
  FALSE_ON_ERROR.
* libguile/objcodes.c (make_objcode_from_file, scm_load_objcode):
  (verify_cookie): Add argument nonzero_on_error.
* libguile/load.c (search_path): Take optional output argument
  PATH_REMAINING.
  (scm_primitive_load_path): Use it.  Take optional argument
  LOAD_COMPILED_PATH.  Skip any invalid compiled file found and
  continue searching scm_loc_load_compiled_path.
  (internal_scm_init_eval_in_scheme): New function.  Implementation
  of scm_init_eval_in_scheme, taking path parameter to implement
  skipping any invalid eval.go's in path.
  (scm_init_eval_in_scheme): Use it.
---
 libguile/load.c     | 106 ++++++++++++++++++++++++++++++++++++++++++----------
 libguile/objcodes.c |  57 ++++++++++++++++++----------
 libguile/objcodes.h |   2 +-
 libguile/vm.c       |  11 ++++--
 libguile/vm.h       |   2 +-
 5 files changed, 134 insertions(+), 44 deletions(-)

diff --git a/libguile/load.c b/libguile/load.c
index 0a49066..36a9c49 100644
--- a/libguile/load.c
+++ b/libguile/load.c
@@ -548,10 +548,12 @@ is_absolute_file_name (SCM filename)
    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.
+   If PATH_REMAINING is not NULL, it is set to the tail of PATH that was
+   not skipped.  */
 static SCM
 search_path (SCM path, SCM filename, SCM extensions, SCM require_exts,
-             struct stat *stat_buf)
+             struct stat *stat_buf, SCM *path_remaining)
 {
   struct stringbuf buf;
   char *filename_chars;
@@ -669,6 +671,8 @@ search_path (SCM path, SCM filename, SCM extensions, SCM require_exts,
 
  end:
   scm_dynwind_end ();
+  if (path_remaining)
+    *path_remaining = path;
   return result;
 }
 
@@ -725,7 +729,7 @@ SCM_DEFINE (scm_search_path, "search-path", 2, 0, 1,
   if (SCM_UNBNDP (require_exts))
     require_exts = SCM_BOOL_F;
 
-  return search_path (path, filename, extensions, require_exts, &stat_buf);
+  return search_path (path, filename, extensions, require_exts, &stat_buf, NULL);
 }
 #undef FUNC_NAME
 
@@ -750,7 +754,7 @@ SCM_DEFINE (scm_sys_search_load_path, "%search-load-path", 1, 0, 0,
   SCM_VALIDATE_STRING (1, filename);
 
   return search_path (*scm_loc_load_path, filename, *scm_loc_load_extensions,
-                      SCM_BOOL_F, &stat_buf);
+                      SCM_BOOL_F, &stat_buf, NULL);
 }
 #undef FUNC_NAME
 
@@ -942,7 +946,10 @@ SCM_DEFINE (scm_primitive_load_path, "primitive-load-path", 0, 0, 1,
             "depending on the optional second argument,\n"
             "@var{exception_on_not_found}.  If it is @code{#f}, @code{#f}\n"
             "will be returned.  If it is a procedure, it will be called\n"
-            "with no arguments.  Otherwise an error is signalled.")
+            "with no arguments.  Otherwise an error is signalled."
+            "If the optional third argument,\n"
+            "@var{load_compiled_path} is given, use it to search for compiled files\n"
+            "instead of @var{*scm_loc_load_compiled_path}.")
 #define FUNC_NAME s_scm_primitive_load_path
 {
   SCM filename, exception_on_not_found;
@@ -950,6 +957,8 @@ SCM_DEFINE (scm_primitive_load_path, "primitive-load-path", 0, 0, 1,
   int compiled_is_fallback = 0;
   SCM hook = *scm_loc_load_hook;
   struct stat stat_source, stat_compiled;
+  SCM load_compiled_path;
+  SCM load_compiled_path_remaining = SCM_EOL;
 
   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",
@@ -961,21 +970,27 @@ SCM_DEFINE (scm_primitive_load_path, "primitive-load-path", 0, 0, 1,
 	 single argument (the file name).  */
       filename = args;
       exception_on_not_found = SCM_UNDEFINED;
+      load_compiled_path = *scm_loc_load_compiled_path;
     }
   else
     {
-      /* Starting from 1.9, this function takes 1 required and 1 optional
-	 argument.  */
+      /* Starting from 1.9, this function takes 1 required and 1
+	 optional argument. 
+
+         Starting from 2.1.2, this function takes 1 required and 2
+	 optional arguments.  */
       long len;
 
       SCM_VALIDATE_LIST_COPYLEN (SCM_ARG1, args, len);
-      if (len < 1 || len > 2)
+      if (len < 1 || len > 3)
 	scm_error_num_args_subr (FUNC_NAME);
 
       filename = SCM_CAR (args);
       SCM_VALIDATE_STRING (SCM_ARG1, filename);
 
       exception_on_not_found = len > 1 ? SCM_CADR (args) : SCM_UNDEFINED;
+      load_compiled_path = len < 3 ? *scm_loc_load_compiled_path
+        : SCM_CADDR (args);
     }
 
   if (SCM_UNBNDP (exception_on_not_found))
@@ -983,12 +998,12 @@ SCM_DEFINE (scm_primitive_load_path, "primitive-load-path", 0, 0, 1,
 
   full_filename = search_path (*scm_loc_load_path, filename,
                                *scm_loc_load_extensions, SCM_BOOL_F,
-                               &stat_source);
+                               &stat_source, NULL);
 
   compiled_filename =
-    search_path (*scm_loc_load_compiled_path, filename,
+    search_path (load_compiled_path, filename,
                  *scm_loc_load_compiled_extensions, SCM_BOOL_T,
-                 &stat_compiled);
+                 &stat_compiled, &load_compiled_path_remaining);
 
   if (scm_is_false (compiled_filename)
       && scm_is_true (full_filename)
@@ -1033,7 +1048,32 @@ SCM_DEFINE (scm_primitive_load_path, "primitive-load-path", 0, 0, 1,
       || (scm_is_true (compiled_filename)
           && compiled_is_fresh (full_filename, compiled_filename,
                                 &stat_source, &stat_compiled)))
-    return scm_load_compiled_with_vm (compiled_filename);
+    {
+      SCM module = scm_load_compiled_with_vm (compiled_filename, SCM_BOOL_T);
+      if (scm_is_false (module) && getenv ("GUILE_DEBUG_GO"))
+        {
+          scm_puts (";;; note: found broken .go ",
+                    scm_current_warning_port ());
+          scm_display (compiled_filename, scm_current_warning_port ());
+          scm_newline (scm_current_warning_port ());
+        }
+      if (!scm_is_false (module) || scm_is_false (exception_on_not_found))
+        return module;
+      if (scm_is_pair (load_compiled_path_remaining))
+        load_compiled_path_remaining = SCM_CDR (load_compiled_path_remaining);
+      if (scm_is_false (module) && getenv ("GUILE_DEBUG_GO"))
+        {
+          scm_puts (";;; skipping, continue on path ",
+                    scm_current_warning_port ());
+          scm_display (load_compiled_path_remaining,
+                       scm_current_warning_port ());
+          scm_newline (scm_current_warning_port ());
+        }
+      return scm_primitive_load_path (scm_list_3
+                                      (filename,
+                                       exception_on_not_found,
+                                       load_compiled_path_remaining));
+    }
 
   /* 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. */
@@ -1063,7 +1103,7 @@ SCM_DEFINE (scm_primitive_load_path, "primitive-load-path", 0, 0, 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 ());
-          return scm_load_compiled_with_vm (fallback);
+          return scm_load_compiled_with_vm (fallback, SCM_BOOL_T);
         }
     }
 
@@ -1072,7 +1112,7 @@ SCM_DEFINE (scm_primitive_load_path, "primitive-load-path", 0, 0, 1,
     SCM freshly_compiled = scm_try_auto_compile (full_filename);
 
     if (scm_is_true (freshly_compiled))
-      return scm_load_compiled_with_vm (freshly_compiled);
+      return scm_load_compiled_with_vm (freshly_compiled, SCM_BOOL_F);
     else
       return scm_primitive_load (full_filename);
   }
@@ -1085,28 +1125,56 @@ scm_c_primitive_load_path (const char *filename)
   return scm_primitive_load_path (scm_from_locale_string (filename));
 }
 
-void
-scm_init_eval_in_scheme (void)
+static void
+internal_scm_init_eval_in_scheme (SCM load_compiled_path)
 {
   SCM eval_scm, eval_go;
   struct stat stat_source, stat_compiled;
+  SCM load_compiled_path_remaining = SCM_EOL;
 
   eval_scm = search_path (*scm_loc_load_path,
                           scm_from_locale_string ("ice-9/eval.scm"),
-                          SCM_EOL, SCM_BOOL_F, &stat_source);
+                          SCM_EOL, SCM_BOOL_F, &stat_source, NULL);
   eval_go = search_path (*scm_loc_load_compiled_path,
                          scm_from_locale_string ("ice-9/eval.go"),
-                         SCM_EOL, SCM_BOOL_F, &stat_compiled);
+                         SCM_EOL, SCM_BOOL_F, &stat_compiled,
+                         &load_compiled_path_remaining);
   
   if (scm_is_true (eval_scm) && scm_is_true (eval_go)
       && compiled_is_fresh (eval_scm, eval_go,
                             &stat_source, &stat_compiled))
-    scm_load_compiled_with_vm (eval_go);
+    {
+      SCM module = scm_load_compiled_with_vm (eval_go, SCM_BOOL_T);
+      if (scm_is_pair (load_compiled_path_remaining))
+        load_compiled_path_remaining = SCM_CDR (load_compiled_path_remaining);
+      if (scm_is_false (module))
+        {
+          if (getenv ("GUILE_DEBUG_GO"))
+            {
+              scm_puts (";;; note: found broken .go ",
+                        scm_current_warning_port ());
+              scm_display (eval_go, scm_current_warning_port ());
+              scm_newline (scm_current_warning_port ());
+              scm_puts (";;; skipping, continue on path ",
+                        scm_current_warning_port ());
+              scm_display (load_compiled_path_remaining,
+                           scm_current_warning_port ());
+              scm_newline (scm_current_warning_port ());
+            }
+          internal_scm_init_eval_in_scheme (load_compiled_path_remaining);
+        }
+    }
   else
     /* if we have no eval.go, we shouldn't load any compiled code at all */
     *scm_loc_load_compiled_path = SCM_EOL;
 }
 
+void
+scm_init_eval_in_scheme (void)
+{
+  internal_scm_init_eval_in_scheme (*scm_loc_load_compiled_path);
+}
+
 \f
 /* Information about the build environment.  */
 
diff --git a/libguile/objcodes.c b/libguile/objcodes.c
index e315f3e..d59c7b7 100644
--- a/libguile/objcodes.c
+++ b/libguile/objcodes.c
@@ -95,8 +95,8 @@ to_native_order (uint32_t x, char endianness)
     return bswap_32 (x);
 }
 
-static void
-verify_cookie (char *cookie, struct stat *st, int map_fd, void *map_addr)
+static int
+verify_cookie (char *cookie, struct stat *st, int map_fd, void *map_addr, int nonzero_on_error)
 #define FUNC_NAME "make_objcode_from_file"
 {
   /* The cookie ends with a version of the form M.N, where M is the
@@ -116,6 +116,8 @@ verify_cookie (char *cookie, struct stat *st, int map_fd, void *map_addr)
           (void) munmap (map_addr, st->st_size);
 #endif
         }
+      if (nonzero_on_error)
+        return 1;
       scm_misc_error (FUNC_NAME, "bad header on object file: ~s", args);
     }
 
@@ -131,13 +133,15 @@ verify_cookie (char *cookie, struct stat *st, int map_fd, void *map_addr)
             (void) munmap (map_addr, st->st_size);
 #endif
           }
-
+        if (nonzero_on_error)
+          return 1;
         scm_misc_error (FUNC_NAME, "objcode minor version too new (~a > ~a)",
                         scm_list_2 (scm_from_latin1_stringn (&minor_version, 1),
                                     scm_from_latin1_string
                                     (SCM_OBJCODE_MINOR_VERSION_STRING)));
       }
   }
+  return 0;
 }
 #undef FUNC_NAME
 
@@ -149,8 +153,10 @@ verify_cookie (char *cookie, struct stat *st, int map_fd, void *map_addr)
      - "native code" -- not currently used.
  */
 
+#define SCM_BOOL_F_ELSE_SCM_SYSERROR(skip_p) {if (skip_p) {errno = 0; return SCM_BOOL_F;} SCM_SYSERROR;}
+
 static SCM
-make_objcode_from_file (int fd)
+make_objcode_from_file (int fd, int false_on_error)
 #define FUNC_NAME "make_objcode_from_file"
 {
   int ret;
@@ -161,11 +167,15 @@ make_objcode_from_file (int fd)
 
   ret = fstat (fd, &st);
   if (ret < 0)
-    SCM_SYSERROR;
+    SCM_BOOL_F_ELSE_SCM_SYSERROR (false_on_error);
 
   if (st.st_size <= sizeof (struct scm_objcode) + sizeof cookie)
-    scm_misc_error (FUNC_NAME, "object file too small (~a bytes)",
-		    scm_list_1 (SCM_I_MAKINUM (st.st_size)));
+    {
+      if (false_on_error)
+        return SCM_BOOL_F;
+      scm_misc_error (FUNC_NAME, "object file too small (~a bytes)",
+                      scm_list_1 (SCM_I_MAKINUM (st.st_size)));
+    }
 
 #ifdef HAVE_SYS_MMAN_H
   {
@@ -179,7 +189,7 @@ make_objcode_from_file (int fd)
         int errno_save = errno;
         (void) close (fd);
         errno = errno_save;
-        SCM_SYSERROR;
+        SCM_BOOL_F_ELSE_SCM_SYSERROR (false_on_error);
       }
     else
       {
@@ -187,8 +197,9 @@ make_objcode_from_file (int fd)
         data = (struct scm_objcode *) (addr + sizeof cookie);
       }
 
-    verify_cookie (cookie, &st, fd, addr);
-
+    if (verify_cookie (cookie, &st, fd, addr, false_on_error)
+        && false_on_error)
+      return SCM_BOOL_F;
 
     if (data->len + data->metalen
         != (st.st_size - sizeof (*data) - sizeof cookie))
@@ -220,14 +231,16 @@ make_objcode_from_file (int fd)
         int errno_save = errno;
         (void) close (fd);
         errno = errno_save;
-        if (errno)
-          SCM_SYSERROR;
-        scm_misc_error (FUNC_NAME, "file truncated while reading", SCM_EOL);
+        if (!errno)
+          scm_misc_error (FUNC_NAME, "file truncated while reading", SCM_EOL);
+        SCM_BOOL_F_ELSE_SCM_SYSERROR (false_on_error);
       }
 
     (void) close (fd);
 
-    verify_cookie (cookie, &st, -1, NULL);
+    if (verify_cookie (cookie, &st, -1, NULL)
+        && false_on_error)
+      return SCM_BOOL_F;
 
     return scm_bytecode_to_native_objcode (bv);
   }
@@ -235,7 +248,6 @@ make_objcode_from_file (int fd)
 }
 #undef FUNC_NAME
 
-
 SCM
 scm_c_make_objcode_slice (SCM parent, const scm_t_uint8 *ptr)
 #define FUNC_NAME "make-objcode-slice"
@@ -354,22 +366,29 @@ scm_bytecode_to_native_objcode (SCM bytecode)
   return bytecode_to_objcode (bytecode, NATIVE_ENDIANNESS, sizeof (void *));
 }
 
-SCM_DEFINE (scm_load_objcode, "load-objcode", 1, 0, 0,
-	    (SCM file),
+SCM_DEFINE (scm_load_objcode, "load-objcode", 1, 1, 0,
+	    (SCM file, SCM false_on_error),
 	    "")
 #define FUNC_NAME s_scm_load_objcode
 {
   int fd;
   char *c_file;
+  int c_false_on_error;
 
   SCM_VALIDATE_STRING (1, file);
 
+  if (SCM_UNBNDP (false_on_error))
+    false_on_error = SCM_BOOL_F;
+
+  c_false_on_error = scm_is_true (false_on_error);
+
   c_file = scm_to_locale_string (file);
   fd = open (c_file, O_RDONLY | O_BINARY | O_CLOEXEC);
   free (c_file);
-  if (fd < 0) SCM_SYSERROR;
+  if (fd < 0)
+    SCM_BOOL_F_ELSE_SCM_SYSERROR (c_false_on_error);
 
-  return make_objcode_from_file (fd);
+  return make_objcode_from_file (fd, c_false_on_error);
 }
 #undef FUNC_NAME
 
diff --git a/libguile/objcodes.h b/libguile/objcodes.h
index 0cfc8e0..a6d2065 100644
--- a/libguile/objcodes.h
+++ b/libguile/objcodes.h
@@ -61,7 +61,7 @@ struct scm_objcode
 #define SCM_SET_OBJCODE_NATIVE_CODE(x, code) (SCM_SET_CELL_WORD_3 (x, code))
 
 SCM_API SCM scm_c_make_objcode_slice (SCM parent, const scm_t_uint8 *ptr);
-SCM_API SCM scm_load_objcode (SCM file);
+SCM_API SCM scm_load_objcode (SCM file, SCM false_on_error);
 SCM_API SCM scm_objcode_p (SCM obj);
 SCM_API SCM scm_objcode_meta (SCM objcode);
 SCM_API SCM scm_bytecode_to_objcode (SCM bytecode);
diff --git a/libguile/vm.c b/libguile/vm.c
index d4c8b5f..dc8fff9 100644
--- a/libguile/vm.c
+++ b/libguile/vm.c
@@ -1071,11 +1071,14 @@ SCM_DEFINE (scm_call_with_vm, "call-with-vm", 2, 0, 1,
  * Initialize
  */
 
-SCM scm_load_compiled_with_vm (SCM file)
+SCM
+scm_load_compiled_with_vm (SCM file, SCM false_on_error)
 {
-  SCM program = scm_make_program (scm_load_objcode (file),
-                                  SCM_BOOL_F, SCM_BOOL_F);
-  
+  SCM program;
+  SCM objcode = scm_load_objcode (file, false_on_error);
+  if (scm_is_false (objcode) && scm_is_true (false_on_error))
+    return SCM_BOOL_F;
+  program = scm_make_program (objcode, SCM_BOOL_F, SCM_BOOL_F);
   return scm_c_vm_run (scm_the_vm (), program, NULL, 0);
 }
 
diff --git a/libguile/vm.h b/libguile/vm.h
index d354a53..56b05de 100644
--- a/libguile/vm.h
+++ b/libguile/vm.h
@@ -101,7 +101,7 @@ struct scm_vm_cont {
 #define SCM_VM_CONT_PARTIAL_P(CONT) (SCM_VM_CONT_DATA (CONT)->flags & SCM_F_VM_CONT_PARTIAL)
 #define SCM_VM_CONT_REWINDABLE_P(CONT) (SCM_VM_CONT_DATA (CONT)->flags & SCM_F_VM_CONT_REWINDABLE)
 
-SCM_API SCM scm_load_compiled_with_vm (SCM file);
+SCM_API SCM scm_load_compiled_with_vm (SCM file, SCM false_on_error);
 
 SCM_INTERNAL SCM scm_c_vm_run (SCM vm, SCM program, SCM *argv, int nargs);
 
-- 
2.6.3