From 515d23b52baacc62bebdf5986292303596674d16 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/loader.c (load_thunk_from_memory, scm_load_thunk_from_file,
  map_file_contents): Idem.
* 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   | 107 ++++++++++++++++++++++++++++++++++++++++++++----------
 libguile/loader.c |  42 +++++++++++++--------
 libguile/loader.h |   2 +-
 libguile/vm.c     |   8 ++--
 libguile/vm.h     |   2 +-
 5 files changed, 122 insertions(+), 39 deletions(-)

diff --git a/libguile/load.c b/libguile/load.c
index d26f9fc..b9db988 100644
--- a/libguile/load.c
+++ b/libguile/load.c
@@ -582,12 +582,15 @@ compiled_is_fresh (SCM full_filename, SCM compiled_filename,
    file name that we find in the path.  Otherwise only return a file if
    it is newer than SOURCE_STAT_BUF, otherwise issuing a warning if we
    see a stale file earlier in the path, setting *FOUND_STALE_FILE to 1.
-  */
+
+   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,
              SCM source_file_name, struct stat *source_stat_buf,
-             int *found_stale_file)
+             int *found_stale_file,
+             SCM *path_remaining)
 {
   struct stringbuf buf;
   char *filename_chars;
@@ -724,6 +727,8 @@ search_path (SCM path, SCM filename, SCM extensions, SCM require_exts,
 
  end:
   scm_dynwind_end ();
+  if (path_remaining)
+    *path_remaining = path;
   return result;
 }
 
@@ -781,7 +786,7 @@ SCM_DEFINE (scm_search_path, "search-path", 2, 0, 1,
     require_exts = SCM_BOOL_F;
 
   return search_path (path, filename, extensions, require_exts, &stat_buf,
-                      SCM_BOOL_F, NULL, NULL);
+                      SCM_BOOL_F, NULL, NULL, NULL);
 }
 #undef FUNC_NAME
 
@@ -806,7 +811,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, NULL, NULL);
+                      SCM_BOOL_F, &stat_buf, SCM_BOOL_F, NULL, NULL, NULL);
 }
 #undef FUNC_NAME
 
@@ -969,14 +974,19 @@ 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;
   SCM full_filename, compiled_filename;
   SCM hook = *scm_loc_load_hook;
   struct stat stat_source, stat_compiled;
+  SCM load_compiled_path;
   int found_stale_compiled_file = 0;
+  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",
@@ -988,21 +998,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))
@@ -1010,13 +1026,13 @@ 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, SCM_BOOL_F, NULL, NULL);
+                               &stat_source, SCM_BOOL_F, NULL, NULL, 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, full_filename, &stat_source,
-                 &found_stale_compiled_file);
+                 &found_stale_compiled_file, &load_compiled_path_remaining);
 
   if (scm_is_false (compiled_filename)
       && scm_is_true (full_filename)
@@ -1066,13 +1082,38 @@ SCM_DEFINE (scm_primitive_load_path, "primitive-load-path", 0, 0, 1,
                        ? full_filename : compiled_filename));
 
   if (scm_is_true (compiled_filename))
-    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_unlocked (";;; 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_unlocked (";;; 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));
+    }
   else
     {
       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,30 +1126,58 @@ 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;
   int found_stale_eval_go = 0;
+  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_BOOL_F, NULL, NULL);
-  eval_go = search_path (*scm_loc_load_compiled_path,
+                          SCM_BOOL_F, NULL, NULL, NULL);
+  eval_go = search_path (load_compiled_path,
                          scm_from_locale_string ("ice-9/eval.go"),
                          SCM_EOL, SCM_BOOL_F, &stat_compiled,
-                         eval_scm, &stat_source, &found_stale_eval_go);
+                         eval_scm, &stat_source, &found_stale_eval_go,
+                         &load_compiled_path_remaining);
   
   if (scm_is_true (eval_go))
-    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_unlocked (";;; note: found broken .go ",
+                                 scm_current_warning_port ());
+              scm_display (eval_go, scm_current_warning_port ());
+              scm_newline (scm_current_warning_port ());
+              scm_puts_unlocked (";;; 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
        because we can't guarantee that tail calls will work.  */
     *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/loader.c b/libguile/loader.c
index 97effb3..bf72805 100644
--- a/libguile/loader.c
+++ b/libguile/loader.c
@@ -340,9 +340,12 @@ process_dynamic_segment (char *base, Elf_Phdr *dyn_phdr,
 }
 
 #define ABORT(msg) do { err_msg = msg; goto cleanup; } while (0)
+#define NULL_ELSE_SCM_SYSERROR(skip_p) {if (skip_p) {errno = 0; return NULL;} SCM_SYSERROR;}
+#define SCM_BOOL_F_ELSE_SCM_SYSERROR(skip_p) {if (skip_p) {errno = 0; return SCM_BOOL_F;} SCM_SYSERROR;}
 
 static SCM
-load_thunk_from_memory (char *data, size_t len, int is_read_only)
+load_thunk_from_memory (char *data, size_t len, int is_read_only,
+                        int false_on_error)
 #define FUNC_NAME "load-thunk-from-memory"
 {
   Elf_Ehdr *header;
@@ -456,10 +459,10 @@ load_thunk_from_memory (char *data, size_t len, int is_read_only)
 
  cleanup:
   {
-    if (errno)
-      SCM_SYSERROR;
-    scm_misc_error (FUNC_NAME, err_msg ? err_msg : "error loading ELF file",
-                    SCM_EOL);
+    if (!errno)
+      scm_misc_error (FUNC_NAME, err_msg ? err_msg : "error loading ELF file",
+                      SCM_EOL);
+    SCM_BOOL_F_ELSE_SCM_SYSERROR (false_on_error);
   }
 }
 #undef FUNC_NAME
@@ -467,7 +470,7 @@ load_thunk_from_memory (char *data, size_t len, int is_read_only)
 #define SCM_PAGE_SIZE 4096
 
 static char*
-map_file_contents (int fd, size_t len, int *is_read_only)
+map_file_contents (int fd, size_t len, int *is_read_only, int false_on_error)
 #define FUNC_NAME "load-thunk-from-file"
 {
   char *data;
@@ -475,7 +478,7 @@ map_file_contents (int fd, size_t len, int *is_read_only)
 #ifdef HAVE_SYS_MMAN_H
   data = mmap (NULL, len, PROT_READ, MAP_PRIVATE, fd, 0);
   if (data == MAP_FAILED)
-    SCM_SYSERROR;
+    NULL_ELSE_SCM_SYSERROR (false_on_error);
   *is_read_only = 1;
 #else
   if (lseek (fd, 0, SEEK_START) < 0)
@@ -483,7 +486,7 @@ map_file_contents (int fd, size_t len, int *is_read_only)
       int errno_save = errno;
       (void) close (fd);
       errno = errno_save;
-      SCM_SYSERROR;
+      NULL_ELSE_SCM_SYSERROR (false_on_error);
     }
 
   /* Given that we are using the read fallback, optimistically assume
@@ -527,8 +530,8 @@ map_file_contents (int fd, size_t len, int *is_read_only)
 }
 #undef FUNC_NAME
 
-SCM_DEFINE (scm_load_thunk_from_file, "load-thunk-from-file", 1, 0, 0,
-	    (SCM filename),
+SCM_DEFINE (scm_load_thunk_from_file, "load-thunk-from-file", 1, 1, 0,
+	    (SCM filename, SCM false_on_error),
 	    "")
 #define FUNC_NAME s_scm_load_thunk_from_file
 {
@@ -539,20 +542,29 @@ SCM_DEFINE (scm_load_thunk_from_file, "load-thunk-from-file", 1, 0, 0,
 
   SCM_VALIDATE_STRING (1, filename);
 
+  if (SCM_UNBNDP (false_on_error))
+    false_on_error = SCM_BOOL_F;
+
   c_filename = scm_to_locale_string (filename);
   fd = open (c_filename, O_RDONLY | O_BINARY | O_CLOEXEC);
   free (c_filename);
-  if (fd < 0) SCM_SYSERROR;
+  if (fd < 0)
+    SCM_BOOL_F_ELSE_SCM_SYSERROR (scm_is_true (false_on_error));
 
   end = lseek (fd, 0, SEEK_END);
   if (end < 0)
-    SCM_SYSERROR;
+    SCM_BOOL_F_ELSE_SCM_SYSERROR (scm_is_true (false_on_error));
 
-  data = map_file_contents (fd, end, &is_read_only);
+  data = map_file_contents (fd, end, &is_read_only,
+                            scm_is_true (false_on_error));
 
   (void) close (fd);
 
-  return load_thunk_from_memory (data, end, is_read_only);
+  if (data == NULL && scm_is_true (false_on_error))
+    return SCM_BOOL_F;
+
+  return load_thunk_from_memory (data, end, is_read_only,
+                                 scm_is_true (false_on_error));
 }
 #undef FUNC_NAME
 
@@ -574,7 +586,7 @@ SCM_DEFINE (scm_load_thunk_from_memory, "load-thunk-from-memory", 1, 0, 0,
 
   data = copy_and_align_elf_data (data, len);
 
-  return load_thunk_from_memory (data, len, 0);
+  return load_thunk_from_memory (data, len, 0, 0);
 }
 #undef FUNC_NAME
 
diff --git a/libguile/loader.h b/libguile/loader.h
index 5c719cb..e332abc 100644
--- a/libguile/loader.h
+++ b/libguile/loader.h
@@ -21,7 +21,7 @@
 
 #include <libguile.h>
 
-SCM_API SCM scm_load_thunk_from_file (SCM filename);
+SCM_API SCM scm_load_thunk_from_file (SCM filename, SCM exception_on_not_found_p);
 SCM_API SCM scm_load_thunk_from_memory (SCM bv);
 
 SCM_INTERNAL const scm_t_uint8 *
diff --git a/libguile/vm.c b/libguile/vm.c
index 33f12b4..d22990d 100644
--- a/libguile/vm.c
+++ b/libguile/vm.c
@@ -1501,12 +1501,14 @@ SCM_DEFINE (scm_call_with_stack_overflow_handler,
  */
 
 SCM
-scm_load_compiled_with_vm (SCM file)
+scm_load_compiled_with_vm (SCM file, SCM false_on_error)
 {
-  return scm_call_0 (scm_load_thunk_from_file (file));
+  SCM thunk = scm_load_thunk_from_file (file, false_on_error);
+  if (scm_is_false (thunk) && scm_is_true (false_on_error))
+    return SCM_BOOL_F;
+  return scm_call_0 (thunk);
 }
 
-  
 void
 scm_init_vm_builtin_properties (void)
 {
diff --git a/libguile/vm.h b/libguile/vm.h
index 2ca4f2a..037b1cb 100644
--- a/libguile/vm.h
+++ b/libguile/vm.h
@@ -93,7 +93,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_i_call_with_current_continuation (SCM proc);
 SCM_INTERNAL SCM scm_i_capture_current_stack (void);
-- 
2.6.3