else if (env)
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;
+ cpath = scm_cons (scm_from_locale_string (SCM_CCACHE_DIR), cpath);
+
+#endif /* SCM_LIBRARY_DIR */
+
+ {
+ char *home;
- home = getenv ("HOME");
+ home = getenv ("HOME");
#ifdef HAVE_GETPWENT
- if (!home)
- {
- struct passwd *pwd;
- pwd = getpwuid (getuid ());
- if (pwd)
- home = pwd->pw_dir;
- }
+ if (!home)
+ {
+ struct passwd *pwd;
+ pwd = getpwuid (getuid ());
+ if (pwd)
+ home = pwd->pw_dir;
+ }
#endif /* HAVE_GETPWENT */
- if (home)
- { char buf[1024];
- snprintf (buf, sizeof(buf),
- "%s/.guile-ccache/" SCM_EFFECTIVE_VERSION, home);
- *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 */
+ if (home)
+ { char buf[1024];
+ snprintf (buf, sizeof(buf),
+ "%s/.guile-ccache/" SCM_EFFECTIVE_VERSION, home);
+ *scm_loc_compile_fallback_path = scm_from_locale_string (buf);
+ }
+ }
env = getenv ("GUILE_LOAD_PATH");
if (env)
scm_puts (compiled, scm_current_error_port ());
scm_puts ("\n", scm_current_error_port ());
res = 0;
-
}
+
free (source);
free (compiled);
return res;
}
-SCM_KEYWORD (k_output_file, "output-file");
-
static SCM
do_try_autocompile (void *data)
{
- SCM pair = PTR2SCM (data);
- SCM comp_mod, compile_file, res;
+ SCM source = PTR2SCM (data);
+ SCM comp_mod, compile_file;
scm_puts (";;; compiling ", scm_current_error_port ());
- scm_display (scm_car (pair), scm_current_error_port ());
+ scm_display (source, scm_current_error_port ());
scm_newline (scm_current_error_port ());
comp_mod = scm_c_resolve_module ("system base compile");
compile_file = scm_c_module_lookup (comp_mod, "compile-file");
- res = scm_call_3 (scm_variable_ref (compile_file), scm_car (pair),
- k_output_file, scm_cdr (pair));
-
- scm_puts (";;; compiled ", scm_current_error_port ());
- scm_display (res, scm_current_error_port ());
- scm_newline (scm_current_error_port ());
- return res;
+ if (scm_is_true (compile_file))
+ {
+ SCM res = scm_call_1 (scm_variable_ref (compile_file), source);
+ scm_puts (";;; compiled ", scm_current_error_port ());
+ scm_display (res, scm_current_error_port ());
+ scm_newline (scm_current_error_port ());
+ return res;
+ }
+ else
+ {
+ 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;
+ }
}
static SCM
autocompile_catch_handler (void *data, SCM tag, SCM throw_args)
{
- SCM pair = PTR2SCM (data);
+ SCM source = PTR2SCM (data);
scm_puts (";;; WARNING: compilation of ", scm_current_error_port ());
- scm_display (scm_car (pair), scm_current_error_port ());
- scm_puts ("\n;;; to ", scm_current_error_port ());
- scm_display (scm_cdr (pair), scm_current_error_port ());
+ scm_display (source, scm_current_error_port ());
scm_puts (" failed:\n", scm_current_error_port ());
scm_puts (";;; key ", scm_current_error_port ());
scm_write (tag, scm_current_error_port ());
}
static SCM
-scm_try_autocompile (SCM source, SCM compiled)
+scm_try_autocompile (SCM source)
{
static int message_shown = 0;
- SCM pair;
if (scm_is_false (*scm_loc_load_should_autocompile))
return SCM_BOOL_F;
message_shown = 1;
}
- pair = scm_cons (source, compiled);
return scm_c_catch (SCM_BOOL_T,
do_try_autocompile,
- SCM2PTR (pair),
+ SCM2PTR (source),
autocompile_catch_handler,
- SCM2PTR (pair),
+ SCM2PTR (source),
NULL, NULL);
}
filename,
*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_is_true (*scm_loc_compile_fallback_path)
+ && scm_is_pair (*scm_loc_load_compiled_extensions)
+ && scm_is_string (scm_car (*scm_loc_load_compiled_extensions)))
{
- 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);
+ SCM fallback = scm_string_append
+ (scm_list_3 (*scm_loc_compile_fallback_path,
+ full_filename,
+ scm_car (*scm_loc_load_compiled_extensions)));
+ if (scm_is_true (scm_stat (fallback, SCM_BOOL_F)))
+ compiled_filename = fallback;
}
if (scm_is_false (full_filename) && scm_is_false (compiled_filename))
|| (scm_is_true (compiled_filename)
&& compiled_is_newer (full_filename, compiled_filename)))
return scm_load_compiled_with_vm (compiled_filename);
+ else
+ {
+ SCM freshly_compiled = scm_try_autocompile (full_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
- return scm_primitive_load (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
;;; 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.
+;;; files, either you know where they should go, in which case you tell
+;;; compile-file explicitly, 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)
- (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)))
".go")
(else (car %load-compiled-extensions))))
(and %compile-fallback-path
- (let ((f (string-append %compile-fallback-path "/"
- (strip-source-extension file)
- (compiled-extension))))
+ (let ((f (string-append
+ %compile-fallback-path "/" file (compiled-extension))))
(and (false-if-exception (ensure-writable-dir (dirname f)))
f))))
HCoop / bpt / guile.git / commitdiff