* NEWS: Update news.
* THANKS: Add myself.
* doc/guile-api.alist (%load-announce, %load-hook): Add DEPTH argument.
* doc/ref/api-evaluation.texi (Loading): Document new
DEPTH argument for the primitive-load, primitive-load-path and
%load-hook procedures. Update %load-hook example. Document
%load-verbosely.
* libguile/load.c (scm_loc_load_hook): Update doc.
(call_hook): New procedure.
(scm_primitive_load): Modify to accept a single list of arguments, like
for scm_primitive_load_path, so to accept an optional DEPTH argument.
Call hook via the 'call_hook' procedure.
(scm_primitive_load_path): Accept a third optional DEPTH argument. Call
hook via the 'call_hook' procedure. Pass depth to the
'scm_primitive_load' procedure call.
* libguile/load.h (scm_primitive_load)
(scm_primitive_load_path): Add 'depth' to argument name.
* module/ice-9/boot-9.scm (%load-announce): Accept a DEPTH keyword
argument, and use it to display the modules loaded hierarchically. Use
format instead of display.
(%current-module-load-depth): New parameter.
(resolve-module): Use it.
(try-module-autoload): Call primitive-load-path with it.
(load-in-vicinity): Invoke %load-hook with it.
Reviewed-by: Maxime Devos <maximede...@telenet.be>
---
Changes in v5:
- Introduce the usage of keywords for %load-hooks, breaking backward
compatibility at the benefit of future stability and extensibility
Changes in v4:
- Remove with-output-to-port in %load-announce and adjust doc
Changes in v3:
- Replace PAD-COUNT with DEPTH in VISUAL-DEPTH guard.
Changes in v2:
- Guard against negative pad count when computing 'visual-depth'
NEWS | 13 ++++++++
THANKS | 1 +
doc/guile-api.alist | 4 +--
doc/ref/api-evaluation.texi | 66 +++++++++++++++++++++++++++++--------
libguile/load.c | 64 +++++++++++++++++++++++++++--------
libguile/load.h | 4 +--
module/ice-9/boot-9.scm | 37 +++++++++++++--------
7 files changed, 145 insertions(+), 44 deletions(-)
diff --git a/NEWS b/NEWS
index c9a713c1e..68a10555a 100644
--- a/NEWS
+++ b/NEWS
@@ -41,6 +41,19 @@ files. See "Random Access" in the manual for details.
A list of superclasses can now be provided via #:super.
+** The %load-hook procedure is now applied with an extra 'depth' argument
+
+This is a *backward incompatible* change that affects current
+user-defined load hooks. New hooks should be defined using a signature
+like:
+
+(define* (my-hook file #:key (depth 0) #:allow-other-keys) ...)
+
+The newly introduced DEPTH argument is used to show the depth level of
+the module being load in the output when setting %load-verbosely to
+#t, which makes it easier to inspect which module caused others to be
+loaded.
+
* Bug fixes
** Fix incorrect comparison between exact and inexact numbers
diff --git a/THANKS b/THANKS
index aa4877e95..546f79b45 100644
--- a/THANKS
+++ b/THANKS
@@ -5,6 +5,7 @@ Contributors since the last release:
Rob Browning
Tristan Colgate-McFarlane
Aleix Conchillo Flaqué
+ Maxim Cournoyer
Ludovic Courtès
Jason Earl
Paul Eggert
diff --git a/doc/guile-api.alist b/doc/guile-api.alist
index a1616149f..20c900166 100644
--- a/doc/guile-api.alist
+++ b/doc/guile-api.alist
@@ -37,9 +37,9 @@
(%init-rdelim-builtins (groups Scheme) (scan-data "#<primitive-procedure
%init-rdelim-builtins>"))
(%init-rw-builtins (groups Scheme) (scan-data "#<primitive-procedure
%init-rw-builtins>"))
(%library-dir (groups Scheme) (scan-data "#<primitive-procedure
%library-dir>"))
-(%load-announce (groups Scheme) (scan-data "#<procedure %load-announce
(file)>"))
+(%load-announce (groups Scheme) (scan-data "#<procedure %load-announce (file
depth)>"))
(%load-extensions (groups Scheme) (scan-data ""))
-(%load-hook (groups Scheme) (scan-data "#<procedure %load-announce (file)>"))
+(%load-hook (groups Scheme) (scan-data "#<procedure %load-announce (file
depth)>"))
(%load-path (groups Scheme) (scan-data ""))
(%load-verbosely (groups Scheme) (scan-data ""))
(%make-void-port (groups Scheme) (scan-data "#<primitive-procedure
%make-void-port>"))
diff --git a/doc/ref/api-evaluation.texi b/doc/ref/api-evaluation.texi
index 68bf38e54..48a811395 100644
--- a/doc/ref/api-evaluation.texi
+++ b/doc/ref/api-evaluation.texi
@@ -865,14 +865,20 @@ calling @code{load-compiled} on the resulting file is
equivalent to
calling @code{load} on the source file.
@end deffn
-@deffn {Scheme Procedure} primitive-load filename
+@deffn {Scheme Procedure} primitive-load filename [depth]
@deffnx {C Function} scm_primitive_load (filename)
Load the file named @var{filename} and evaluate its contents in the
top-level environment. @var{filename} must either be a full pathname or
be a pathname relative to the current directory. If the variable
@code{%load-hook} is defined, it should be bound to a procedure that
will be called before any code is loaded. See the documentation for
-@code{%load-hook} later in this section.
+@code{%load-hook} later in this section. An optional keyword argument,
+@var{#:depth}, can be specified to track the depth at which modules are
+loaded.
+
+For compatibility with Guile 3.9 and earlier, the C function takes only
+one argument, which can be either a string (the file name) or an
+argument list.
@end deffn
@deftypefn {C Function} SCM scm_c_primitive_load (const char *filename)
@@ -905,20 +911,52 @@ change occurs at the right time.
@end defvar
@defvar %load-hook
-A procedure to be called @code{(%load-hook @var{filename})} whenever a
-file is loaded, or @code{#f} for no such call. @code{%load-hook} is
-used by all of the loading functions (@code{load} and
-@code{primitive-load}, and @code{load-from-path} and
+A procedure to be called @code{(%load-hook @var{filename} #:depth @var{depth})}
+whenever a file is loaded, or @code{#f} for no such call.
+@code{%load-hook} is used by all of the loading functions (@code{load}
+and @code{primitive-load}, and @code{load-from-path} and
@code{primitive-load-path} documented in the next section).
-For example an application can set this to show what's loaded,
+The default @code{%load-hook} is bound to a procedure that does
+something like:
@example
-(set! %load-hook (lambda (filename)
- (format #t "Loading ~a ...\n" filename)))
-(load-from-path "foo.scm")
-@print{} Loading /usr/local/share/guile/site/foo.scm ...
+(define* (%load-hook file #:key (depth 0) #:allow-other-keys)
+ (when %load-verbosely
+ (let* ((pad-count (- 3 (string-length (number->string depth))))
+ (pad (if (> pad-count 0)
+ (make-string pad-count #\space)
+ ""))
+ (visual-depth (if (> depth 0)
+ (make-string depth #\space)
+ "")))
+ (format (current-warning-port)
+ ";;; loading ~a~a ~a~a~%" pad depth visual-depth file)
+ (force-output (current-warning-port)))))
@end example
+
+It is important to define your @code{%load-hook} with at least the
+@code{#:depth} keyword argument as well as the @code{#:allow-other-keys}
+modifier, which allows for future backward compatibility of hooks.
+
+@vindex %load-verbosely, to enable default %load-hook output
+As you can see from the above procedure, an application can thus set the
+@code{%load-verbosely} variable to @code{#t} to enable the default load
+hook output, which produces something like:
+
+@example
+@print{};;; loading 0 guix/gnu/packages/abiword.scm
+@print{};;; loading 1 guix/build-system/glib-or-gtk.scm
+@print{};;; loading 2 guix/build/glib-or-gtk-build-system.scm
+@print{};;; loading 3 guix/build/gnu-build-system.scm
+@print{};;; loading 4 guix/build/gremlin.scm
+@print{};;; loading 5 guix/elf.scm
+@end example
+
+The number corresponds to the depth at which the module was loaded,
+which is a recursive process. The indentation of the file name loaded
+corresponds to that depth value, to make it easy to visually discern
+which module caused others to be loaded.
@end defvar
@deffn {Scheme Procedure} current-load-port
@@ -969,7 +1007,7 @@ It's better to use @code{add-to-load-path} than to modify
@code{%load-path} directly, because @code{add-to-load-path} takes care
of modifying the path both at compile-time and at run-time.
-@deffn {Scheme Procedure} primitive-load-path filename [exception-on-not-found]
+@deffn {Scheme Procedure} primitive-load-path filename
[exception-on-not-found] [depth]
@deffnx {C Function} scm_primitive_load_path (filename)
Search @code{%load-path} for the file named @var{filename} and
load it into the top-level environment. If @var{filename} is a
@@ -983,7 +1021,9 @@ second argument, @var{exception-on-not-found}. If it is
@code{#f},
@code{#f} will be returned. If it is a procedure, it will be called
with no arguments. (This allows a distinction to be made between
exceptions raised by loading a file, and exceptions related to the
-loader itself.) Otherwise an error is signaled.
+loader itself.) Otherwise an error is signaled. An optional third
+argument, @var{depth}, can be specified to track the depth at which modules are
+loaded.
For compatibility with Guile 1.8 and earlier, the C function takes only
one argument, which can be either a string (the file name) or an
diff --git a/libguile/load.c b/libguile/load.c
index 34e7934b9..77320d7dc 100644
--- a/libguile/load.c
+++ b/libguile/load.c
@@ -72,35 +72,67 @@
/* Loading a file, given an absolute filename. */
-/* Hook to run when we load a file, perhaps to announce the fact somewhere.
- Applied to the full name of the file. */
+/* Hook to run when we load a file, perhaps to announce the fact
+ somewhere. Applied to the full name of the file and (since 3.10) an
+ optional depth counter. */
static SCM *scm_loc_load_hook;
/* The current reader (a fluid). */
static SCM the_reader = SCM_BOOL_F;
+/* Helper to call %load-hook with the correct number of arguments. */
+static void call_hook (SCM hook, SCM filename, SCM depth) {
+ if (scm_is_false (hook))
+ return;
-SCM_DEFINE (scm_primitive_load, "primitive-load", 1, 0, 0,
- (SCM filename),
+ scm_call_3(hook, filename, scm_from_utf8_keyword("depth"), depth);
+}
+
+SCM_DEFINE (scm_primitive_load, "primitive-load", 0, 0, 1,
+ (SCM args),
"Load the file named @var{filename} and evaluate its contents in\n"
"the top-level environment. The load paths are not searched;\n"
"@var{filename} must either be a full pathname or be a pathname\n"
"relative to the current directory. If the variable\n"
"@code{%load-hook} is defined, it should be bound to a procedure\n"
"that will be called before any code is loaded. See the\n"
- "documentation for @code{%load-hook} later in this section.")
+ "documentation for @code{%load-hook} later in this section.\n"
+ "A second optional argument can be used to specify the depth\n"
+ "at which the module was loaded.")
#define FUNC_NAME s_scm_primitive_load
{
+ SCM filename;
+ SCM depth;
SCM hook = *scm_loc_load_hook;
SCM ret = SCM_UNSPECIFIED;
+ if (scm_is_string (args)) {
+ /* C code written for 3.9 and earlier expects this function to
+ take a single argument (the file name). */
+ filename = args;
+ depth = scm_from_int(0);
+ }
+ else {
+ /* Starting from 3.10, this function takes 1 required and 1 optional
+ arguments. */
+ long len;
+
+ SCM_VALIDATE_LIST_COPYLEN (SCM_ARG1, args, len);
+ if (len < 1 || len > 2)
+ scm_error_num_args_subr (FUNC_NAME);
+
+ filename = SCM_CAR (args);
+ SCM_VALIDATE_STRING (SCM_ARG1, filename);
+
+ depth = len > 1 ? SCM_CADR (args) : scm_from_int(0);
+ }
+
SCM_VALIDATE_STRING (1, filename);
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",
SCM_EOL);
- if (!scm_is_false (hook))
- scm_call_1 (hook, filename);
+ call_hook (hook, filename, depth);
{
SCM port;
@@ -1163,11 +1195,13 @@ 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 signaled.")
+ "with no arguments. Otherwise an error is signaled.\n\n"
+ "A third optional argument may be provided to track module depth.")
#define FUNC_NAME s_scm_primitive_load_path
{
SCM filename, exception_on_not_found;
SCM full_filename, compiled_thunk;
+ SCM depth;
SCM hook = *scm_loc_load_hook;
struct stat stat_source, stat_compiled;
int found_stale_compiled_file = 0;
@@ -1182,21 +1216,24 @@ 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;
+ depth = scm_from_int (0);
}
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 arguments. From 3.10, 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;
+ depth = len > 2 ? SCM_CADDR (args) : scm_from_int (0);
}
if (SCM_UNBNDP (exception_on_not_found))
@@ -1252,8 +1289,7 @@ SCM_DEFINE (scm_primitive_load_path,
"primitive-load-path", 0, 0, 1,
scm_list_1 (filename));
}
- if (!scm_is_false (hook))
- scm_call_1 (hook, full_filename);
+ call_hook(hook, full_filename, depth);
if (scm_is_true (compiled_thunk))
return scm_call_0 (compiled_thunk);
@@ -1264,7 +1300,7 @@ SCM_DEFINE (scm_primitive_load_path,
"primitive-load-path", 0, 0, 1,
if (scm_is_true (freshly_compiled))
return scm_call_0 (scm_load_thunk_from_file (freshly_compiled));
else
- return scm_primitive_load (full_filename);
+ return scm_primitive_load (scm_list_2 (full_filename, depth));
}
}
#undef FUNC_NAME
diff --git a/libguile/load.h b/libguile/load.h
index 25f67b87b..d03019b44 100644
--- a/libguile/load.h
+++ b/libguile/load.h
@@ -27,7 +27,7 @@
SCM_API SCM scm_parse_path (SCM path, SCM tail);
SCM_API SCM scm_parse_path_with_ellipsis (SCM path, SCM base);
-SCM_API SCM scm_primitive_load (SCM filename);
+SCM_API SCM scm_primitive_load (SCM filename_and_depth);
SCM_API SCM scm_c_primitive_load (const char *filename);
SCM_API SCM scm_sys_package_data_dir (void);
SCM_API SCM scm_sys_library_dir (void);
@@ -36,7 +36,7 @@ SCM_API SCM scm_sys_global_site_dir (void);
SCM_API SCM scm_sys_site_ccache_dir (void);
SCM_API SCM scm_search_path (SCM path, SCM filename, SCM rest);
SCM_API SCM scm_sys_search_load_path (SCM filename);
-SCM_API SCM scm_primitive_load_path (SCM filename_and_exception_on_not_found);
+SCM_API SCM scm_primitive_load_path (SCM
filename_and_exception_on_not_found_and_depth);
SCM_API SCM scm_c_primitive_load_path (const char *filename);
SCM_INTERNAL SCM scm_sys_warn_auto_compilation_enabled (void);
SCM_INTERNAL void scm_init_load_path (void);
diff --git a/module/ice-9/boot-9.scm b/module/ice-9/boot-9.scm
index 10423d35e..fb3d245bd 100644
--- a/module/ice-9/boot-9.scm
+++ b/module/ice-9/boot-9.scm
@@ -2236,15 +2236,18 @@ name extensions listed in %load-extensions."
(define %load-verbosely #f)
(define (assert-load-verbosity v) (set! %load-verbosely v))
-(define (%load-announce file)
- (if %load-verbosely
- (with-output-to-port (current-warning-port)
- (lambda ()
- (display ";;; ")
- (display "loading ")
- (display file)
- (newline)
- (force-output)))))
+(define* (%load-announce file #:key (depth 0) #:allow-other-keys)
+ (when %load-verbosely
+ (let* ((pad-count (- 3 (string-length (number->string depth))))
+ (pad (if (> pad-count 0)
+ (make-string pad-count #\space)
+ ""))
+ (visual-depth (if (> depth 0)
+ (make-string depth #\space)
+ "")))
+ (format (current-warning-port)
+ ";;; loading ~a~a ~a~a~%" pad depth visual-depth file)
+ (force-output (current-warning-port)))))
(set! %load-hook %load-announce)
@@ -3250,6 +3253,10 @@ deterministic."
(set-module-declarative?! m (user-modules-declarative?))
m))
+;;; This parameter is used to track the depth at which modules are
+;;; loaded.
+(define %current-module-load-depth (make-parameter -1))
+
;; NOTE: This binding is used in libguile/modules.c.
;;
(define resolve-module
@@ -3272,8 +3279,10 @@ deterministic."
already)
(autoload
;; Try to autoload the module, and recurse.
- (try-load-module name version)
- (resolve-module name #f #:ensure ensure))
+ (parameterize ((%current-module-load-depth
+ (1+ (%current-module-load-depth))))
+ (try-load-module name version)
+ (resolve-module name #f #:ensure ensure)))
(else
;; No module found (or if one was, it had no public interface),
and
;; we're not autoloading. Make an empty module if #:ensure is
true.
@@ -3584,7 +3593,8 @@ but it fails to load."
(call/ec
(lambda (abort)
(primitive-load-path (in-vicinity dir-hint name)
- abort)
+ abort
+ (%current-module-load-depth))
(set! didit #t)))))))
(lambda () (set-autoloaded! dir-hint name didit)))
didit))))))
@@ -4406,7 +4416,8 @@ when none is available, reading FILE-NAME with READER."
(if compiled
(begin
(if %load-hook
- (%load-hook abs-file-name))
+ (%load-hook abs-file-name
+ #:depth (%current-module-load-depth)))
(compiled))
(start-stack 'load-stack
(primitive-load abs-file-name)))))
--
2.41.0
