summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
-rw-r--r--libguile/load.c78
-rw-r--r--module/system/base/compile.scm74
2 files changed, 76 insertions, 76 deletions
diff --git a/libguile/load.c b/libguile/load.c
index 4e127d68c..f54015bc5 100644
--- a/libguile/load.c
+++ b/libguile/load.c
@@ -185,6 +185,9 @@ static SCM *scm_loc_load_compiled_extensions;
/* Whether we should try to auto-compile. */
static SCM *scm_loc_load_should_autocompile;
+/* The fallback path for autocompilation */
+static SCM *scm_loc_compile_fallback_path;
+
SCM_DEFINE (scm_parse_path, "parse-path", 1, 1, 0,
(SCM path, SCM tail),
"Parse @var{path}, which is expected to be a colon-separated\n"
@@ -239,6 +242,10 @@ scm_init_load_path ()
cpath = scm_parse_path (scm_from_locale_string (env), cpath);
else
{
+ /* the idea: if GUILE_SYSTEM_COMPILED_PATH is set, then it seems we're working
+ against an uninstalled Guile, in which case we shouldn't be autocompiling,
+ otherwise offer up the user's home directory as penance for not having
+ up-to-date .go files. */
char *home;
home = getenv ("HOME");
@@ -255,9 +262,9 @@ scm_init_load_path ()
{ char buf[1024];
snprintf (buf, sizeof(buf),
"%s/.guile-ccache/" SCM_EFFECTIVE_VERSION, home);
- cpath = scm_cons (scm_from_locale_string (buf), cpath);
+ *scm_loc_compile_fallback_path = scm_from_locale_string (buf);
}
-
+
cpath = scm_cons (scm_from_locale_string (SCM_CCACHE_DIR), cpath);
}
#endif /* SCM_LIBRARY_DIR */
@@ -624,10 +631,10 @@ autocompile_catch_handler (void *data, SCM tag, SCM throw_args)
}
static SCM
-scm_try_autocompile (SCM source, SCM stale_compiled)
+scm_try_autocompile (SCM source, SCM compiled)
{
static int message_shown = 0;
- SCM comp_mod, compiled_file_name, new_compiled, pair;
+ SCM pair;
if (scm_is_false (*scm_loc_load_should_autocompile))
return SCM_BOOL_F;
@@ -640,36 +647,7 @@ scm_try_autocompile (SCM source, SCM stale_compiled)
message_shown = 1;
}
- comp_mod = scm_c_resolve_module ("system base compile");
- compiled_file_name =
- scm_module_variable (comp_mod,
- scm_from_locale_symbol ("compiled-file-name"));
-
- if (scm_is_false (compiled_file_name))
- {
- scm_puts (";;; it seems ", scm_current_error_port ());
- scm_display (source, scm_current_error_port ());
- scm_puts ("\n;;; is part of the compiler; skipping autocompilation\n",
- scm_current_error_port ());
- return SCM_BOOL_F;
- }
-
- new_compiled = scm_call_1 (scm_variable_ref (compiled_file_name), source);
-
- if (scm_is_false (new_compiled))
- return SCM_BOOL_F;
- else if (!scm_is_true (scm_equal_p (new_compiled, stale_compiled))
- && scm_is_true (scm_stat (new_compiled, SCM_BOOL_F))
- && compiled_is_newer (source, new_compiled))
- {
- scm_puts (";;; found compiled file elsewhere: ",
- scm_current_error_port ());
- scm_display (new_compiled, scm_current_error_port ());
- scm_newline (scm_current_error_port ());
- return new_compiled;
- }
-
- pair = scm_cons (source, new_compiled);
+ pair = scm_cons (source, compiled);
return scm_c_catch (SCM_BOOL_T,
do_try_autocompile,
SCM2PTR (pair),
@@ -699,6 +677,31 @@ SCM_DEFINE (scm_primitive_load_path, "primitive-load-path", 1, 1, 0,
*scm_loc_load_compiled_extensions,
SCM_BOOL_T);
+ if (scm_is_false (compiled_filename)
+ && scm_is_true (full_filename)
+ && scm_is_true (*scm_loc_compile_fallback_path))
+ {
+ SCM comp_mod, compiled_file_name;
+
+ comp_mod = scm_c_resolve_module ("system base compile");
+ compiled_file_name =
+ scm_module_variable (comp_mod,
+ scm_from_locale_symbol ("compiled-file-name"));
+
+ if (scm_is_false (compiled_file_name))
+ {
+ scm_puts (";;; it seems ", scm_current_error_port ());
+ scm_display (full_filename, scm_current_error_port ());
+ scm_puts ("\n;;; is part of the compiler; skipping autocompilation\n",
+ scm_current_error_port ());
+ return SCM_BOOL_F;
+ }
+
+ /* very confusing var names ... */
+ compiled_filename = scm_call_1 (scm_variable_ref (compiled_file_name),
+ full_filename);
+ }
+
if (scm_is_false (full_filename) && scm_is_false (compiled_filename))
{
if (scm_is_true (exception_on_not_found))
@@ -713,7 +716,9 @@ SCM_DEFINE (scm_primitive_load_path, "primitive-load-path", 1, 1, 0,
&& compiled_is_newer (full_filename, compiled_filename)))
return scm_load_compiled_with_vm (compiled_filename);
- compiled_filename = scm_try_autocompile (full_filename, compiled_filename);
+ if (scm_is_true (compiled_filename))
+ compiled_filename = scm_try_autocompile (full_filename, compiled_filename);
+
if (scm_is_true (compiled_filename))
return scm_load_compiled_with_vm (compiled_filename);
else
@@ -765,6 +770,9 @@ scm_init_load ()
scm_list_1 (scm_from_locale_string (".go"))));
scm_loc_load_hook = SCM_VARIABLE_LOC (scm_c_define ("%load-hook", SCM_BOOL_F));
+ scm_loc_compile_fallback_path
+ = SCM_VARIABLE_LOC (scm_c_define ("%compile-fallback-path", SCM_BOOL_F));
+
scm_loc_load_should_autocompile
= SCM_VARIABLE_LOC (scm_c_define ("%load-should-autocompile", SCM_BOOL_F));
diff --git a/module/system/base/compile.scm b/module/system/base/compile.scm
index d5933edad..77a3fe1b5 100644
--- a/module/system/base/compile.scm
+++ b/module/system/base/compile.scm
@@ -108,48 +108,40 @@
(stable-sort (map (lambda (x) (cons (key x) x)) list)
(lambda (x y) (less (car x) (car y))))))
+;;; This function is among the trickiest I've ever written. I tried many
+;;; variants. In the end, simple is best, of course.
+;;;
+;;; After turning this around a number of times, it seems that the the
+;;; desired behavior is that .go files should exist in a path, for
+;;; searching. That is orthogonal to this function. For writing .go
+;;; files, either you know where they should go, in which case you pass
+;;; the path directly, assuming they will end up in the path, as in the
+;;; srcdir != builddir case; or you don't know, in which case this
+;;; function is called, and we just put them in your own ccache dir in
+;;; ~/.guile-ccache.
(define (compiled-file-name file)
- (let ((cext (cond ((or (null? %load-compiled-extensions)
- (string-null? (car %load-compiled-extensions)))
- (warn "invalid %load-compiled-extensions"
- %load-compiled-extensions)
- ".go")
- (else (car %load-compiled-extensions)))))
- (define (strip-source-extension path)
- (let lp ((exts %load-extensions))
- (cond ((null? exts) file)
- ((string-null? (car exts)) (lp (cdr exts)))
- ((string-suffix? (car exts) path)
- (substring path 0
- (- (string-length path)
- (string-length (car exts)))))
- (else (lp (cdr exts))))))
- ;; there is some trickery here. if no %load-compiled-path is a
- ;; prefix of `file', the stability of the sort makes us end up
- ;; trying to write first to last dir in the path, which is usually
- ;; the $HOME ccache dir.
- (let lp ((paths (dsu-sort (reverse %load-compiled-path)
- (lambda (x)
- (if (string-prefix? x file)
- (string-length x)
- 0))
- >)))
- (if (null? paths)
- (error "no writable path when compiling" file)
- (let ((rpath (in-vicinity
- (car paths)
- (string-append
- (strip-source-extension
- (if (string-prefix? (car paths) file)
- (substring file (1+ (string-length (car paths))))
- (substring file 1)))
- cext))))
- (if (and (false-if-exception
- (ensure-writable-dir (dirname rpath)))
- (or (not (file-exists? rpath))
- (access? rpath W_OK)))
- rpath
- (lp (cdr paths))))))))
+ (define (strip-source-extension path)
+ (let lp ((exts %load-extensions))
+ (cond ((null? exts) file)
+ ((string-null? (car exts)) (lp (cdr exts)))
+ ((string-suffix? (car exts) path)
+ (substring path 0
+ (- (string-length path)
+ (string-length (car exts)))))
+ (else (lp (cdr exts))))))
+ (define (compiled-extension)
+ (cond ((or (null? %load-compiled-extensions)
+ (string-null? (car %load-compiled-extensions)))
+ (warn "invalid %load-compiled-extensions"
+ %load-compiled-extensions)
+ ".go")
+ (else (car %load-compiled-extensions))))
+ (and %compile-fallback-path
+ (let ((f (string-append %compile-fallback-path "/"
+ (strip-source-extension file)
+ (compiled-extension))))
+ (and (false-if-exception (ensure-writable-dir (dirname f)))
+ f))))
(define* (compile-file file #:key
(output-file #f)