mirror of
https://git.savannah.gnu.org/git/guile.git
synced 2025-05-02 13:00:26 +02:00
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>.
This commit is contained in:
Andy Wingo
parent
abc003fb45
commit
04359b42b9
2 changed files with 334 additions and 134 deletions
408
libguile/load.c
408
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/validate.h"
|
||||
#include "libguile/load.h"
|
||||
#include "libguile/dynwind.h"
|
||||
#include "libguile/eval.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;
|
||||
int compiled_is_fallback = 0;
|
||||
SCM full_filename, compiled_thunk;
|
||||
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 =
|
||||
search_path (*scm_loc_load_compiled_path, filename,
|
||||
*scm_loc_load_compiled_extensions, SCM_BOOL_T,
|
||||
&stat_compiled);
|
||||
compiled_thunk = load_thunk_from_path (filename, full_filename, &stat_source,
|
||||
&found_stale_compiled_file);
|
||||
|
||||
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;
|
||||
compiled_is_fallback = 1;
|
||||
if (found_stale_compiled_file)
|
||||
{
|
||||
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)
|
||||
? full_filename : compiled_filename));
|
||||
scm_call_1 (hook, full_filename);
|
||||
|
||||
if (scm_is_false (full_filename)
|
||||
|| (scm_is_true (compiled_filename)
|
||||
&& compiled_is_fresh (full_filename, compiled_filename,
|
||||
&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)))
|
||||
if (scm_is_true (compiled_thunk))
|
||||
return scm_call_0 (compiled_thunk);
|
||||
else
|
||||
{
|
||||
SCM fallback;
|
||||
char *fallback_chars;
|
||||
int stat_ret;
|
||||
|
||||
fallback = scm_string_append
|
||||
(scm_list_3 (*scm_loc_compile_fallback_path,
|
||||
canonical_suffix (full_filename),
|
||||
scm_car (*scm_loc_load_compiled_extensions)));
|
||||
SCM freshly_compiled = scm_try_auto_compile (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);
|
||||
}
|
||||
if (scm_is_true (freshly_compiled))
|
||||
return scm_load_compiled_with_vm (freshly_compiled);
|
||||
else
|
||||
return scm_primitive_load (full_filename);
|
||||
}
|
||||
|
||||
/* 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;
|
||||
struct stat stat_source, stat_compiled;
|
||||
SCM eval_scm, eval_thunk;
|
||||
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,
|
||||
scm_from_locale_string ("ice-9/eval.go"),
|
||||
SCM_EOL, SCM_BOOL_F, &stat_compiled);
|
||||
eval_thunk =
|
||||
load_thunk_from_path (scm_from_locale_string ("ice-9/eval.go"),
|
||||
eval_scm, &stat_source, &found_stale_eval_go);
|
||||
|
||||
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);
|
||||
if (scm_is_true (eval_thunk))
|
||||
scm_call_0 (eval_thunk);
|
||||
else
|
||||
/* if we have no eval.go, we shouldn't load any compiled code at all */
|
||||
*scm_loc_load_compiled_path = SCM_EOL;
|
||||
|
|
|
|||
Loading…
Add table
Add a link
Reference in a new issue