diff --git a/libguile/load.c b/libguile/load.c index 08324c587..8a6fadb33 100644 --- a/libguile/load.c +++ b/libguile/load.c @@ -639,14 +639,11 @@ autocompile_catch_handler (void *data, SCM tag, SCM throw_args) return SCM_BOOL_F; } -static SCM -scm_try_autocompile (SCM source) +SCM_DEFINE (scm_sys_warn_autocompilation_enabled, "%warn-autocompilation-enabled", 0, 0, 0, + (void), "") { static int message_shown = 0; - if (scm_is_false (*scm_loc_load_should_autocompile)) - return SCM_BOOL_F; - if (!message_shown) { scm_puts (";;; note: autocompilation is enabled, set GUILE_AUTO_COMPILE=0\n" @@ -655,6 +652,17 @@ scm_try_autocompile (SCM source) message_shown = 1; } + return SCM_UNSPECIFIED; +} + + +static SCM +scm_try_autocompile (SCM source) +{ + if (scm_is_false (*scm_loc_load_should_autocompile)) + return SCM_BOOL_F; + + scm_sys_warn_autocompilation_enabled (); return scm_c_catch (SCM_BOOL_T, do_try_autocompile, SCM2PTR (source), diff --git a/libguile/load.h b/libguile/load.h index d5bc1b066..1a1a86528 100644 --- a/libguile/load.h +++ b/libguile/load.h @@ -36,6 +36,7 @@ SCM_API SCM scm_search_path (SCM path, SCM filename, SCM exts, SCM require_exts) SCM_API SCM scm_sys_search_load_path (SCM filename); SCM_API SCM scm_primitive_load_path (SCM filename, SCM exception_on_not_found); SCM_API SCM scm_c_primitive_load_path (const char *filename); +SCM_INTERNAL SCM scm_sys_warn_autocompilation_enabled (void); SCM_INTERNAL void scm_init_load_path (void); SCM_INTERNAL void scm_init_load (void); diff --git a/module/ice-9/boot-9.scm b/module/ice-9/boot-9.scm index 01569cbf9..574cb2b1a 100644 --- a/module/ice-9/boot-9.scm +++ b/module/ice-9/boot-9.scm @@ -867,11 +867,46 @@ (set! %load-hook %load-announce) +;;; Returns the .go file corresponding to `name'. Does not search load +;;; paths, only the fallback path. If the .go file is missing or out of +;;; date, and autocompilation is enabled, will try autocompilation, just +;;; as primitive-load-path does internally. primitive-load is +;;; unaffected. Returns #f if autocompilation failed or was disabled. +(define (autocompiled-file-name name) + (catch #t + (lambda () + (let* ((cfn ((@ (system base compile) compiled-file-name) name)) + (scmstat (stat name)) + (gostat (stat cfn #f))) + (if (and gostat (= (stat:mtime gostat) (stat:mtime scmstat))) + cfn + (begin + (if gostat + (format (current-error-port) + ";;; note: source file ~a\n;;; newer than compiled ~a\n" + name cfn)) + (cond + (%load-should-autocompile + (%warn-autocompilation-enabled) + (format (current-error-port) ";;; compiling ~a\n" name) + (let ((cfn ((@ (system base compile) compile-file) name))) + (format (current-error-port) ";;; compiled ~a\n" cfn) + cfn)) + (else #f)))))) + (lambda (k . args) + (format (current-error-port) + ";;; WARNING: compilation of ~a failed:\n;;; key ~a, throw_args ~s\n" + name k args) + #f))) + (define (load name . reader) (with-fluid* current-reader (and (pair? reader) (car reader)) (lambda () - (start-stack 'load-stack - (primitive-load name))))) + (let ((cfn (autocompiled-file-name name))) + (if cfn + (load-compiled cfn) + (start-stack 'load-stack + (primitive-load name)))))))