wingo pushed a commit to branch wip-whippet
in repository guile.
commit f930af273764120c9ef758c17878444fc2b10d26
Author: Andy Wingo <wi...@pobox.com>
AuthorDate: Mon Jun 16 12:30:59 2025 +0200
Move implementation of hooks to Scheme module
* module/ice-9/hooks.scm: New file.
* am/bootstrap.am: Add new file.
* module/ice-9/deprecated.scm: Add trampolines to (ice-9 hooks).
* module/ice-9/scm-style-repl.scm:
* module/ice-9/session.scm:
* module/ice-9/top-repl.scm:
* module/scripts/scan-api.scm:
* guile-readline/ice-9/readline.scm:
* benchmark-suite/benchmark-suite/lib.scm:
* module/system/repl/command.scm:
* module/system/repl/common.scm:
* module/system/repl/debug.scm:
* module/system/repl/error-handling.scm:
* module/system/repl/hooks.scm:
* module/system/repl/reader.scm:
* module/system/repl/repl.scm:
* module/ice-9/history.scm:
* test-suite/tests/hooks.test: Use the new module.
* module/oop/goops.scm: Remove <hook> class definition.
* libguile/vm.c:
* libguile/init.c:
* libguile/Makefile.am:
* libguile.h: Remove hooks.h includes.
* libguile/hooks.c:
* libguile/hooks.h: Remove.
* libguile/deprecated.h:
* libguile/deprecated.c: Add deprecation shims for C API.
---
am/bootstrap.am | 1 +
benchmark-suite/benchmark-suite/lib.scm | 3 +-
guile-readline/ice-9/readline.scm | 1 +
libguile.h | 1 -
libguile/Makefile.am | 4 -
libguile/deprecated.c | 113 +++++++++++++++
libguile/deprecated.h | 17 +++
libguile/hooks.c | 234 --------------------------------
libguile/hooks.h | 53 --------
libguile/init.c | 2 -
libguile/vm.c | 1 -
module/ice-9/deprecated.scm | 23 ++++
module/ice-9/history.scm | 1 +
module/ice-9/hooks.scm | 79 +++++++++++
module/ice-9/scm-style-repl.scm | 1 +
module/ice-9/session.scm | 3 +-
module/ice-9/top-repl.scm | 1 +
module/oop/goops.scm | 3 +-
module/scripts/scan-api.scm | 1 +
module/system/repl/command.scm | 1 +
module/system/repl/common.scm | 1 +
module/system/repl/debug.scm | 1 +
module/system/repl/error-handling.scm | 1 +
module/system/repl/hooks.scm | 1 +
module/system/repl/reader.scm | 1 +
module/system/repl/repl.scm | 1 +
test-suite/tests/hooks.test | 3 +-
27 files changed, 252 insertions(+), 300 deletions(-)
diff --git a/am/bootstrap.am b/am/bootstrap.am
index e11ff0ad4..15eec8c0a 100644
--- a/am/bootstrap.am
+++ b/am/bootstrap.am
@@ -151,6 +151,7 @@ SOURCES = \
ice-9/guardians.scm \
ice-9/hash-table.scm \
ice-9/history.scm \
+ ice-9/hooks.scm \
ice-9/i18n.scm \
ice-9/iconv.scm \
ice-9/list.scm \
diff --git a/benchmark-suite/benchmark-suite/lib.scm
b/benchmark-suite/benchmark-suite/lib.scm
index ae57cc02a..d7aa36f9d 100644
--- a/benchmark-suite/benchmark-suite/lib.scm
+++ b/benchmark-suite/benchmark-suite/lib.scm
@@ -1,5 +1,5 @@
;;;; benchmark-suite/lib.scm --- generic support for benchmarking
-;;;; Copyright (C) 2002, 2006, 2011, 2012 Free Software Foundation, Inc.
+;;;; Copyright (C) 2002, 2006, 2011, 2012, 2025 Free Software Foundation, Inc.
;;;;
;;;; This program is free software; you can redistribute it and/or
;;;; modify it under the terms of the GNU Lesser General Public
@@ -17,6 +17,7 @@
;;;; Street, Fifth Floor, Boston, MA 02110-1301 USA
(define-module (benchmark-suite lib)
+ #:use-module (ice-9 hooks)
#:use-module (srfi srfi-9)
#:export (;; Controlling the execution.
iteration-factor
diff --git a/guile-readline/ice-9/readline.scm
b/guile-readline/ice-9/readline.scm
index 3f2a1b7aa..3cfde73d8 100644
--- a/guile-readline/ice-9/readline.scm
+++ b/guile-readline/ice-9/readline.scm
@@ -25,6 +25,7 @@
(define-module (ice-9 readline)
+ #:use-module (ice-9 hooks)
#:use-module (ice-9 session)
#:use-module (ice-9 regex)
#:use-module (ice-9 buffered-input)
diff --git a/libguile.h b/libguile.h
index 2b17052c2..073605c19 100644
--- a/libguile.h
+++ b/libguile.h
@@ -62,7 +62,6 @@ extern "C" {
#include "libguile/gsubr.h"
#include "libguile/hash.h"
#include "libguile/hashtab.h"
-#include "libguile/hooks.h"
#include "libguile/i18n.h"
#include "libguile/init.h"
#include "libguile/ioext.h"
diff --git a/libguile/Makefile.am b/libguile/Makefile.am
index 7a4d4a347..9a6925f4e 100644
--- a/libguile/Makefile.am
+++ b/libguile/Makefile.am
@@ -176,7 +176,6 @@ libguile_@GUILE_EFFECTIVE_VERSION@_la_SOURCES =
\
gsubr.c \
hash.c \
hashtab.c \
- hooks.c \
i18n.c \
init.c \
inline.c \
@@ -289,7 +288,6 @@ DOT_X_FILES = \
gsubr.x \
hash.x \
hashtab.x \
- hooks.x \
i18n.x \
init.x \
instructions.x \
@@ -388,7 +386,6 @@ DOT_DOC_FILES = \
gsubr.doc \
hash.doc \
hashtab.doc \
- hooks.doc \
i18n.doc \
init.doc \
ioext.doc \
@@ -632,7 +629,6 @@ modinclude_HEADERS = \
gsubr.h \
hash.h \
hashtab.h \
- hooks.h \
i18n.h \
init.h \
inline.h \
diff --git a/libguile/deprecated.c b/libguile/deprecated.c
index 2423410f1..520f72b80 100644
--- a/libguile/deprecated.c
+++ b/libguile/deprecated.c
@@ -26,6 +26,7 @@
#include "deprecation.h"
#include "eval.h"
#include "gsubr.h"
+#include "keywords.h"
#include "modules.h"
#include "numbers.h"
#include "symbols.h"
@@ -472,6 +473,118 @@ scm_end_of_char_set_p (SCM cursor)
+static SCM make_hook_var;
+static SCM hook_p_var;
+static SCM hook_empty_p_var;
+static SCM add_hook_x_var;
+static SCM remove_hook_x_var;
+static SCM reset_hook_x_var;
+static SCM run_hook_var;
+static SCM hook_to_list_var;
+
+static void
+init_hook_vars (void)
+{
+ make_hook_var = scm_c_public_lookup ("ice-9 hooks", "make-hook");
+ hook_p_var = scm_c_public_lookup ("ice-9 hooks", "hook?");
+ hook_empty_p_var = scm_c_public_lookup ("ice-9 hooks", "hook-empty?");
+ add_hook_x_var = scm_c_public_lookup ("ice-9 hooks", "add-hook!");
+ remove_hook_x_var = scm_c_public_lookup ("ice-9 hooks", "remove-hook!");
+ reset_hook_x_var = scm_c_public_lookup ("ice-9 hooks", "reset-hook!");
+ run_hook_var = scm_c_public_lookup ("ice-9 hooks", "run-hook");
+ hook_to_list_var = scm_c_public_lookup ("ice-9 hooks", "hook->list");
+}
+
+static void
+init_hook_functions (void)
+{
+ static scm_i_pthread_once_t once = SCM_I_PTHREAD_ONCE_INIT;
+ scm_c_issue_deprecation_warning
+ ("Using the SCM hook functions from C is deprecated. Invoke"
+ "make-hook, etc. from (ice-9 hooks) instead.");
+ scm_i_pthread_once (&once, init_hook_vars);
+}
+
+SCM
+scm_make_hook (SCM arity)
+{
+ init_hook_functions ();
+ return scm_call_0 (scm_variable_ref (make_hook_var));
+}
+
+SCM
+scm_hook_p (SCM x)
+{
+ init_hook_functions ();
+ return scm_call_1 (scm_variable_ref (hook_p_var), x);
+}
+
+SCM
+scm_hook_empty_p (SCM hook)
+{
+ init_hook_functions ();
+ return scm_call_1 (scm_variable_ref (hook_empty_p_var), hook);
+}
+
+SCM_KEYWORD (kw_append_p, "append?");
+
+SCM
+scm_add_hook_x (SCM hook, SCM f, SCM append_p)
+{
+ init_hook_functions ();
+ return scm_call_4 (scm_variable_ref (add_hook_x_var), hook, f,
+ kw_append_p,
+ SCM_UNBNDP (append_p) ? SCM_BOOL_F : append_p);
+}
+
+SCM
+scm_remove_hook_x (SCM hook, SCM f)
+{
+ init_hook_functions ();
+ return scm_call_2 (scm_variable_ref (remove_hook_x_var), hook, f);
+}
+
+SCM
+scm_reset_hook_x (SCM hook)
+{
+ init_hook_functions ();
+ return scm_call_1 (scm_variable_ref (reset_hook_x_var), hook);
+}
+
+SCM
+scm_run_hook (SCM hook, SCM args)
+{
+ init_hook_functions ();
+ return scm_apply_1 (scm_variable_ref (run_hook_var), hook, args);
+}
+
+void
+scm_c_run_hook (SCM hook, SCM args)
+{
+ scm_run_hook (hook, args);
+}
+
+void
+scm_c_run_hookn (SCM hook, SCM *argsv, size_t nargs)
+{
+ init_hook_functions ();
+
+ SCM hook_and_argsv[nargs + 1];
+ hook_and_argsv[0] = hook;
+ memcpy (&hook_and_argsv[1], argsv, nargs * sizeof (SCM));
+ scm_call_n (scm_variable_ref (run_hook_var), hook_and_argsv, nargs + 1);
+}
+
+SCM
+scm_hook_to_list (SCM hook)
+{
+ init_hook_functions ();
+ return scm_call_1 (scm_variable_ref (hook_to_list_var), hook);
+}
+
+
+
+
void
scm_i_init_deprecated ()
{
diff --git a/libguile/deprecated.h b/libguile/deprecated.h
index 905792970..aba973695 100644
--- a/libguile/deprecated.h
+++ b/libguile/deprecated.h
@@ -80,6 +80,23 @@ SCM_DEPRECATED SCM scm_char_set_ref (SCM cs, SCM cursor);
SCM_DEPRECATED SCM scm_char_set_cursor_next (SCM cs, SCM cursor);
SCM_DEPRECATED SCM scm_end_of_char_set_p (SCM cursor);
+#define SCM_HOOKP SCM_HOOKP__Gone__Use_Ice_9_Hooks
+#define SCM_HOOK_ARITY SCM_HOOK_ARITY__Gone__Use_Ice_9_Hooks
+#define SCM_HOOK_PROCEDURES SCM_HOOK_PROCEDURES__Gone__Use_Ice_9_Hooks
+#define SCM_SET_HOOK_PROCEDURES SCM_SET_HOOK_PROCEDURES__Gone__Use_Ice_9_Hooks
+#define SCM_VALIDATE_HOOK SCM_VALIDATE_HOOK__GON__Use_Ice_9_Hooks
+
+SCM_DEPRECATED SCM scm_make_hook (SCM n_args);
+SCM_DEPRECATED SCM scm_hook_p (SCM x);
+SCM_DEPRECATED SCM scm_hook_empty_p (SCM hook);
+SCM_DEPRECATED SCM scm_add_hook_x (SCM hook, SCM thunk, SCM appendp);
+SCM_DEPRECATED SCM scm_remove_hook_x (SCM hook, SCM thunk);
+SCM_DEPRECATED SCM scm_reset_hook_x (SCM hook);
+SCM_DEPRECATED SCM scm_run_hook (SCM hook, SCM args);
+SCM_DEPRECATED void scm_c_run_hook (SCM hook, SCM args);
+SCM_DEPRECATED void scm_c_run_hookn (SCM hook, SCM *argv, size_t nargs);
+SCM_DEPRECATED SCM scm_hook_to_list (SCM hook);
+
/* Deprecated declarations go here. */
void scm_i_init_deprecated (void);
diff --git a/libguile/hooks.c b/libguile/hooks.c
deleted file mode 100644
index bc1bf93e4..000000000
--- a/libguile/hooks.c
+++ /dev/null
@@ -1,234 +0,0 @@
-/* Copyright 1995-1996,1998-2001,2003,2006,2008-2009,2011,2018
- Free Software Foundation, Inc.
-
- This file is part of Guile.
-
- Guile is free software: you can redistribute it and/or modify it
- under the terms of the GNU Lesser General Public License as published
- by the Free Software Foundation, either version 3 of the License, or
- (at your option) any later version.
-
- Guile is distributed in the hope that it will be useful, but WITHOUT
- ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or
- FITNESS FOR A PARTICULAR PURPOSE. See the GNU Lesser General Public
- License for more details.
-
- You should have received a copy of the GNU Lesser General Public
- License along with Guile. If not, see
- <https://www.gnu.org/licenses/>. */
-
-
-
-
-#ifdef HAVE_CONFIG_H
-# include <config.h>
-#endif
-
-#include <stdio.h>
-
-#include "boolean.h"
-#include "eval.h"
-#include "gsubr.h"
-#include "list.h"
-#include "numbers.h"
-#include "pairs.h"
-#include "ports.h"
-#include "procprop.h"
-#include "smob.h"
-#include "strings.h"
-
-#include "hooks.h"
-
-
-
-/* Scheme level hooks
- *
- * A hook is basically a list of procedures to be called at well defined
- * points in time.
- *
- * Hook arity is not a full member of this type and therefore lacks an
- * accessor. It exists to aid debugging and is not intended to be used in
- * programs.
- */
-
-scm_t_bits scm_tc16_hook;
-
-
-static int
-hook_print (SCM hook, SCM port, scm_print_state *pstate)
-{
- SCM ls, name;
- scm_puts ("#<hook ", port);
- scm_intprint (SCM_HOOK_ARITY (hook), 10, port);
- scm_putc (' ', port);
- scm_uintprint (SCM_UNPACK (hook), 16, port);
- ls = SCM_HOOK_PROCEDURES (hook);
- while (scm_is_pair (ls))
- {
- scm_putc (' ', port);
- name = scm_procedure_name (SCM_CAR (ls));
- if (scm_is_true (name))
- scm_iprin1 (name, port, pstate);
- else
- scm_putc ('?', port);
- ls = SCM_CDR (ls);
- }
- scm_putc ('>', port);
- return 1;
-}
-
-
-SCM_DEFINE (scm_make_hook, "make-hook", 0, 1, 0,
- (SCM n_args),
- "Create a hook for storing procedure of arity @var{n_args}.\n"
- "@var{n_args} defaults to zero. The returned value is a hook\n"
- "object to be used with the other hook procedures.")
-#define FUNC_NAME s_scm_make_hook
-{
- unsigned int n;
-
- if (SCM_UNBNDP (n_args))
- n = 0;
- else
- n = scm_to_unsigned_integer (n_args, 0, 16);
-
- SCM_RETURN_NEWSMOB (scm_tc16_hook + (n << 16), SCM_UNPACK (SCM_EOL));
-}
-#undef FUNC_NAME
-
-
-SCM_DEFINE (scm_hook_p, "hook?", 1, 0, 0,
- (SCM x),
- "Return @code{#t} if @var{x} is a hook, @code{#f} otherwise.")
-#define FUNC_NAME s_scm_hook_p
-{
- return scm_from_bool (SCM_HOOKP (x));
-}
-#undef FUNC_NAME
-
-
-SCM_DEFINE (scm_hook_empty_p, "hook-empty?", 1, 0, 0,
- (SCM hook),
- "Return @code{#t} if @var{hook} is an empty hook, @code{#f}\n"
- "otherwise.")
-#define FUNC_NAME s_scm_hook_empty_p
-{
- SCM_VALIDATE_HOOK (1, hook);
- return scm_from_bool (scm_is_null (SCM_HOOK_PROCEDURES (hook)));
-}
-#undef FUNC_NAME
-
-
-SCM_DEFINE (scm_add_hook_x, "add-hook!", 2, 1, 0,
- (SCM hook, SCM proc, SCM append_p),
- "Add the procedure @var{proc} to the hook @var{hook}. The\n"
- "procedure is added to the end if @var{append_p} is true,\n"
- "otherwise it is added to the front. The return value of this\n"
- "procedure is not specified.")
-#define FUNC_NAME s_scm_add_hook_x
-{
- SCM rest;
- int n_args, p_req, p_opt, p_rest;
- SCM_VALIDATE_HOOK (1, hook);
- SCM_ASSERT (scm_i_procedure_arity (proc, &p_req, &p_opt, &p_rest),
- proc, SCM_ARG2, FUNC_NAME);
- n_args = SCM_HOOK_ARITY (hook);
- if (p_req > n_args || (!p_rest && p_req + p_opt < n_args))
- scm_wrong_type_arg (FUNC_NAME, 2, proc);
- rest = scm_delq_x (proc, SCM_HOOK_PROCEDURES (hook));
- SCM_SET_HOOK_PROCEDURES (hook,
- (!SCM_UNBNDP (append_p) && scm_is_true (append_p)
- ? scm_append_x (scm_list_2 (rest, scm_list_1
(proc)))
- : scm_cons (proc, rest)));
- return SCM_UNSPECIFIED;
-}
-#undef FUNC_NAME
-
-
-SCM_DEFINE (scm_remove_hook_x, "remove-hook!", 2, 0, 0,
- (SCM hook, SCM proc),
- "Remove the procedure @var{proc} from the hook @var{hook}. The\n"
- "return value of this procedure is not specified.")
-#define FUNC_NAME s_scm_remove_hook_x
-{
- SCM_VALIDATE_HOOK (1, hook);
- SCM_SET_HOOK_PROCEDURES (hook,
- scm_delq_x (proc, SCM_HOOK_PROCEDURES (hook)));
- return SCM_UNSPECIFIED;
-}
-#undef FUNC_NAME
-
-
-SCM_DEFINE (scm_reset_hook_x, "reset-hook!", 1, 0, 0,
- (SCM hook),
- "Remove all procedures from the hook @var{hook}. The return\n"
- "value of this procedure is not specified.")
-#define FUNC_NAME s_scm_reset_hook_x
-{
- SCM_VALIDATE_HOOK (1, hook);
- SCM_SET_HOOK_PROCEDURES (hook, SCM_EOL);
- return SCM_UNSPECIFIED;
-}
-#undef FUNC_NAME
-
-
-SCM_DEFINE (scm_run_hook, "run-hook", 1, 0, 1,
- (SCM hook, SCM args),
- "Apply all procedures from the hook @var{hook} to the arguments\n"
- "@var{args}. The order of the procedure application is first to\n"
- "last. The return value of this procedure is not specified.")
-#define FUNC_NAME s_scm_run_hook
-{
- SCM_VALIDATE_HOOK (1, hook);
- if (scm_ilength (args) != SCM_HOOK_ARITY (hook))
- SCM_MISC_ERROR ("Hook ~S requires ~A arguments",
- scm_list_2 (hook, scm_from_int (SCM_HOOK_ARITY (hook))));
- scm_c_run_hook (hook, args);
- return SCM_UNSPECIFIED;
-}
-#undef FUNC_NAME
-
-
-void
-scm_c_run_hook (SCM hook, SCM args)
-{
- SCM procs = SCM_HOOK_PROCEDURES (hook);
- while (scm_is_pair (procs))
- {
- scm_apply_0 (SCM_CAR (procs), args);
- procs = SCM_CDR (procs);
- }
-}
-
-void
-scm_c_run_hookn (SCM hook, SCM *argv, size_t nargs)
-{
- SCM procs = SCM_HOOK_PROCEDURES (hook);
- while (scm_is_pair (procs))
- {
- scm_call_n (SCM_CAR (procs), argv, nargs);
- procs = SCM_CDR (procs);
- }
-}
-
-
-SCM_DEFINE (scm_hook_to_list, "hook->list", 1, 0, 0,
- (SCM hook),
- "Convert the procedure list of @var{hook} to a list.")
-#define FUNC_NAME s_scm_hook_to_list
-{
- SCM_VALIDATE_HOOK (1, hook);
- return scm_list_copy (SCM_HOOK_PROCEDURES (hook));
-}
-#undef FUNC_NAME
-
-
-
-
-void
-scm_init_hooks ()
-{
- scm_tc16_hook = scm_make_smob_type ("hook", 0);
- scm_set_smob_print (scm_tc16_hook, hook_print);
-#include "hooks.x"
-}
diff --git a/libguile/hooks.h b/libguile/hooks.h
deleted file mode 100644
index 3cc37bf37..000000000
--- a/libguile/hooks.h
+++ /dev/null
@@ -1,53 +0,0 @@
-#ifndef SCM_HOOKS_H
-#define SCM_HOOKS_H
-
-/* Copyright 1995-1996,1999,2000-2001,2006,2008-2009,2018
- Free Software Foundation, Inc.
-
- This file is part of Guile.
-
- Guile is free software: you can redistribute it and/or modify it
- under the terms of the GNU Lesser General Public License as published
- by the Free Software Foundation, either version 3 of the License, or
- (at your option) any later version.
-
- Guile is distributed in the hope that it will be useful, but WITHOUT
- ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or
- FITNESS FOR A PARTICULAR PURPOSE. See the GNU Lesser General Public
- License for more details.
-
- You should have received a copy of the GNU Lesser General Public
- License along with Guile. If not, see
- <https://www.gnu.org/licenses/>. */
-
-
-
-#include <libguile/error.h>
-#include <libguile/smob.h>
-
-/*
- * Scheme level hooks
- */
-
-SCM_API scm_t_bits scm_tc16_hook;
-
-#define SCM_HOOKP(x) SCM_SMOB_PREDICATE (scm_tc16_hook, x)
-#define SCM_HOOK_ARITY(hook) SCM_SMOB_FLAGS (hook)
-#define SCM_HOOK_PROCEDURES(hook) SCM_SMOB_OBJECT (hook)
-#define SCM_SET_HOOK_PROCEDURES(hook, procs) SCM_SET_SMOB_OBJECT ((hook),
(procs))
-
-#define SCM_VALIDATE_HOOK(pos, a) SCM_MAKE_VALIDATE_MSG (pos, a, HOOKP, "hook")
-
-SCM_API SCM scm_make_hook (SCM n_args);
-SCM_API SCM scm_hook_p (SCM x);
-SCM_API SCM scm_hook_empty_p (SCM hook);
-SCM_API SCM scm_add_hook_x (SCM hook, SCM thunk, SCM appendp);
-SCM_API SCM scm_remove_hook_x (SCM hook, SCM thunk);
-SCM_API SCM scm_reset_hook_x (SCM hook);
-SCM_API SCM scm_run_hook (SCM hook, SCM args);
-SCM_API void scm_c_run_hook (SCM hook, SCM args);
-SCM_API void scm_c_run_hookn (SCM hook, SCM *argv, size_t nargs);
-SCM_API SCM scm_hook_to_list (SCM hook);
-SCM_INTERNAL void scm_init_hooks (void);
-
-#endif /* SCM_HOOKS_H */
diff --git a/libguile/init.c b/libguile/init.c
index e46b39638..768abefb9 100644
--- a/libguile/init.c
+++ b/libguile/init.c
@@ -82,7 +82,6 @@
#include "gsubr.h"
#include "hash.h"
#include "hashtab.h"
-#include "hooks.h"
#include "i18n.h"
#include "instructions.h"
#include "intrinsics.h"
@@ -396,7 +395,6 @@ scm_i_init_guile (struct gc_stack_addr base)
scm_init_hashtab ();
scm_init_deprecation ();
scm_init_promises (); /* requires smob_prehistory */
- scm_init_hooks (); /* Requires smob_prehistory */
scm_init_stime ();
scm_init_gc (); /* Requires hooks and `get_internal_run_time' */
scm_init_gc_protect_object (); /* requires threads_prehistory */
diff --git a/libguile/vm.c b/libguile/vm.c
index af93b5cc7..cad695471 100644
--- a/libguile/vm.c
+++ b/libguile/vm.c
@@ -49,7 +49,6 @@
#include "frames.h"
#include "gc-inline.h"
#include "gsubr-internal.h"
-#include "hooks.h"
#include "instructions.h"
#include "intrinsics.h"
#include "jit.h"
diff --git a/module/ice-9/deprecated.scm b/module/ice-9/deprecated.scm
index f585664bf..e28d20447 100644
--- a/module/ice-9/deprecated.scm
+++ b/module/ice-9/deprecated.scm
@@ -16,6 +16,7 @@
;;;;
(define-module (ice-9 deprecated)
+ #:use-module (ice-9 hooks)
#:use-module (ice-9 guardians)
#:use-module (ice-9 object-properties)
#:use-module (ice-9 source-properties)
@@ -125,6 +126,14 @@
(after-print-hook* . after-print-hook)
(exit-hook* . exit-hook)
(repl-reader* . repl-reader)
+ (make-hook* . make-hook)
+ (hook?* . hook?)
+ (hook-empty?* . hook-empty?)
+ (add-hook!* . add-hook!)
+ (remove-hook!* . remove-hook!)
+ (reset-hook!* . reset-hook!)
+ (run-hook* . run-hook)
+ (hook->list* . hook->list)
module-defined-hook))
(define-syntax define-deprecated/stx
@@ -345,6 +354,20 @@
before-backtrace-hook
after-backtrace-hook)
+(define-deprecated-trampoline (((ice-9 hooks) make-hook) #:optional arity)
+ (make-hook))
+(define-deprecated-trampoline (((ice-9 hooks) add-hook!) hook f #:optional
append?)
+ (add-hook! hook f #:append? append?))
+(define-deprecated-trampoline (((ice-9 hooks) run-hook) hook . args)
+ (apply run-hook hook args))
+
+(define-deprecated-trampolines (ice-9 hooks)
+ (hook? x)
+ (hook-empty? hook)
+ (remove-hook! hook proc)
+ (reset-hook! hook proc)
+ (hook->list hook))
+
(define module-defined-hook (make-hook 1))
(let ((prev (module-definition-observer)))
(module-definition-observer
diff --git a/module/ice-9/history.scm b/module/ice-9/history.scm
index f281c4c0e..bf7ca0832 100644
--- a/module/ice-9/history.scm
+++ b/module/ice-9/history.scm
@@ -18,6 +18,7 @@
;;;; A simple value history support
(define-module (ice-9 history)
+ #:use-module (ice-9 hooks)
#:use-module (system repl hooks)
#:export (value-history-enabled? enable-value-history! disable-value-history!
clear-value-history!))
diff --git a/module/ice-9/hooks.scm b/module/ice-9/hooks.scm
new file mode 100644
index 000000000..59e8481a0
--- /dev/null
+++ b/module/ice-9/hooks.scm
@@ -0,0 +1,79 @@
+;;; Copyright (C) 2025 Free Software Foundation, Inc.
+;;;
+;;; This library is free software: you can redistribute it and/or modify
+;;; it under the terms of the GNU Lesser General Public License as
+;;; published by the Free Software Foundation, either version 3 of the
+;;; License, or (at your option) any later version.
+;;;
+;;; This library is distributed in the hope that it will be useful, but
+;;; WITHOUT ANY WARRANTY; without even the implied warranty of
+;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
+;;; Lesser General Public License for more details.
+;;;
+;;; You should have received a copy of the GNU Lesser General Public
+;;; License along with this program. If not, see
+;;; <http://www.gnu.org/licenses/>.
+
+;;; Commentary:
+;;;
+;;;
+;;; Code:
+
+
+(define-module (ice-9 hooks)
+ ;; FIXME: #:export instead of #:replace when deprecated code is
+ ;; removed.
+ #:replace (make-hook
+ hook?
+ hook-empty?
+ add-hook!
+ remove-hook!
+ reset-hook!
+ run-hook
+ hook->list))
+
+(define <hook>
+ (make-record-type '<hook> '(procs)
+ (lambda (hook port) (print-hook hook port))))
+
+(define %make-hook (record-constructor <hook>))
+(define* (make-hook #:optional nargs)
+ "Create a hook containing an ordered list of procedures."
+ (%make-hook '()))
+
+(define hook? (record-predicate <hook>))
+
+(define hook-procs (record-accessor <hook> 'procs))
+(define set-hook-procs! (record-modifier <hook> 'procs))
+
+(define (hook-empty? hook)
+ "Return @code{#t} if @var{hook} is an empty hook, @code{#f} otherwise."
+ (null? (hook-procs hook)))
+
+(define* (add-hook! hook proc #:optional _append? #:key (append? _append?))
+ "Add the procedure @var{proc} to the hook @var{hook}. The procedure is
+added to the end if @var{append?} is true, otherwise it is added to the
+front."
+ (let ((procs (delq! proc (hook-procs hook))))
+ (set-hook-procs! hook (if append?
+ (append procs (list proc))
+ (cons proc procs))))
+ (values))
+
+(define (remove-hook! hook proc)
+ "Remove the procedure @var{proc} from the hook @var{hook}."
+ (set-hook-procs! hook (delq! proc (hook-procs hook)))
+ (values))
+
+(define (reset-hook! hook)
+ "Remove all procedures from the hook @var{hook}."
+ (set-hook-procs! hook '())
+ (values))
+
+(define (run-hook hook . args)
+ "Apply all procedures from the hook @var{hook} to the arguments
+@var{args}. The order of the procedure application is first to last.
+The return value of this procedure is not specified."
+ (for-each (lambda (proc) (apply proc args))
+ (hook-procs hook))
+ (values))
diff --git a/module/ice-9/scm-style-repl.scm b/module/ice-9/scm-style-repl.scm
index c8c6cb57b..31378f770 100644
--- a/module/ice-9/scm-style-repl.scm
+++ b/module/ice-9/scm-style-repl.scm
@@ -18,6 +18,7 @@
(define-module (ice-9 scm-style-repl)
#:use-module (ice-9 save-stack)
+ #:use-module (ice-9 hooks)
#:use-module (system repl hooks)
#:use-module (system repl reader)
diff --git a/module/ice-9/session.scm b/module/ice-9/session.scm
index 63052e719..66c06b673 100644
--- a/module/ice-9/session.scm
+++ b/module/ice-9/session.scm
@@ -1,5 +1,5 @@
;;;; Copyright (C) 1997, 2000, 2001, 2003, 2006, 2009, 2010, 2011,
-;;;; 2012, 2013 Free Software Foundation, Inc.
+;;;; 2012, 2013, 2025 Free Software Foundation, Inc.
;;;;
;;;; This library is free software; you can redistribute it and/or
;;;; modify it under the terms of the GNU Lesser General Public
@@ -19,6 +19,7 @@
(define-module (ice-9 session)
#:use-module (ice-9 documentation)
+ #:use-module (ice-9 hooks)
#:use-module (ice-9 regex)
#:use-module (ice-9 rdelim)
#:use-module (ice-9 match)
diff --git a/module/ice-9/top-repl.scm b/module/ice-9/top-repl.scm
index 263d2caa8..8e0519e5d 100644
--- a/module/ice-9/top-repl.scm
+++ b/module/ice-9/top-repl.scm
@@ -18,6 +18,7 @@
;;;;
(define-module (ice-9 top-repl)
+ #:use-module (ice-9 hooks)
#:use-module ((system repl repl) #:select (start-repl))
#:use-module (system repl hooks)
#:export (top-repl))
diff --git a/module/oop/goops.scm b/module/oop/goops.scm
index ab56261bb..5d5121652 100644
--- a/module/oop/goops.scm
+++ b/module/oop/goops.scm
@@ -84,7 +84,7 @@
;; once you have an instance. Perhaps FIXME to provide a
;; smob-type-name->class procedure.
<promise>
- <regexp> <hook> <random-state>
+ <regexp> <random-state>
<directory> <array>
<dynamic-object> <macro>
@@ -3537,7 +3537,6 @@ var{initargs}."
(define <promise> (find-subclass <top> '<promise>))
(define <regexp> (find-subclass <top> '<regexp>))
-(define <hook> (find-subclass <top> '<hook>))
(define <bitvector> (find-subclass <top> '<bitvector>))
(define <random-state> (find-subclass <top> '<random-state>))
(define <array> (find-subclass <top> '<array>))
diff --git a/module/scripts/scan-api.scm b/module/scripts/scan-api.scm
index c2b65057f..44ab0bb0b 100644
--- a/module/scripts/scan-api.scm
+++ b/module/scripts/scan-api.scm
@@ -62,6 +62,7 @@
(define-module (scripts scan-api)
#:use-module (ice-9 object-properties)
#:use-module (ice-9 popen)
+ #:use-module (ice-9 hooks)
#:use-module (ice-9 rdelim)
#:use-module (ice-9 regex)
#:export (scan-api))
diff --git a/module/system/repl/command.scm b/module/system/repl/command.scm
index 6390fe6d1..7a611a11b 100644
--- a/module/system/repl/command.scm
+++ b/module/system/repl/command.scm
@@ -38,6 +38,7 @@
#:use-module (ice-9 format)
#:use-module (ice-9 session)
#:use-module (ice-9 documentation)
+ #:use-module (ice-9 hooks)
#:use-module (ice-9 rdelim)
#:use-module (ice-9 control)
#:use-module ((ice-9 pretty-print) #:select ((pretty-print . pp)))
diff --git a/module/system/repl/common.scm b/module/system/repl/common.scm
index d77814d22..4b1a16a54 100644
--- a/module/system/repl/common.scm
+++ b/module/system/repl/common.scm
@@ -27,6 +27,7 @@
#:use-module (ice-9 control)
#:use-module (ice-9 copy-tree)
#:use-module (ice-9 history)
+ #:use-module (ice-9 hooks)
#:export (<repl> make-repl repl-language repl-options
repl-tm-stats repl-gc-stats repl-debug
repl-welcome repl-prompt
diff --git a/module/system/repl/debug.scm b/module/system/repl/debug.scm
index 661b71dc9..9df47ca37 100644
--- a/module/system/repl/debug.scm
+++ b/module/system/repl/debug.scm
@@ -23,6 +23,7 @@
#:use-module (system vm frame)
#:use-module (system vm debug)
#:use-module (ice-9 format)
+ #:use-module (ice-9 hooks)
#:use-module (ice-9 match)
#:use-module (system vm program)
#:use-module (system repl hooks)
diff --git a/module/system/repl/error-handling.scm
b/module/system/repl/error-handling.scm
index ad1444fa3..d0b120524 100644
--- a/module/system/repl/error-handling.scm
+++ b/module/system/repl/error-handling.scm
@@ -24,6 +24,7 @@
#:use-module (system repl debug)
#:use-module (system repl hooks)
#:use-module (ice-9 format)
+ #:use-module (ice-9 hooks)
#:export (call-with-error-handling
with-error-handling))
diff --git a/module/system/repl/hooks.scm b/module/system/repl/hooks.scm
index 2ab3e2fe2..5f8caaea0 100644
--- a/module/system/repl/hooks.scm
+++ b/module/system/repl/hooks.scm
@@ -21,6 +21,7 @@
(define-module (system repl hooks)
+ #:use-module (ice-9 hooks)
;; FIXME: #:export instead of #:replace once deprecated code is
;; removed.
#:replace (before-error-hook
diff --git a/module/system/repl/reader.scm b/module/system/repl/reader.scm
index 86849bc9c..b00410c95 100644
--- a/module/system/repl/reader.scm
+++ b/module/system/repl/reader.scm
@@ -21,6 +21,7 @@
(define-module (system repl reader)
+ #:use-module (ice-9 hooks)
#:use-module (system repl hooks)
;; FIXME: #:export instead of #:replace once deprecated code is
;; removed.
diff --git a/module/system/repl/repl.scm b/module/system/repl/repl.scm
index 4b8a1a7ff..b5f5cc0fd 100644
--- a/module/system/repl/repl.scm
+++ b/module/system/repl/repl.scm
@@ -28,6 +28,7 @@
#:use-module (system repl hooks)
#:use-module (system repl reader)
#:use-module (ice-9 control)
+ #:use-module (ice-9 hooks)
#:export (start-repl run-repl %inhibit-welcome-message))
diff --git a/test-suite/tests/hooks.test b/test-suite/tests/hooks.test
index e6beb491e..08b668bc7 100644
--- a/test-suite/tests/hooks.test
+++ b/test-suite/tests/hooks.test
@@ -1,5 +1,5 @@
;;;; hooks.test --- tests guile's hooks implementation -*- scheme -*-
-;;;; Copyright (C) 1999, 2001, 2006, 2009, 2010 Free Software Foundation, Inc.
+;;;; Copyright (C) 1999, 2001, 2006, 2009, 2010, 2025 Free Software
Foundation, Inc.
;;;;
;;;; This library is free software; you can redistribute it and/or
;;;; modify it under the terms of the GNU Lesser General Public
@@ -16,6 +16,7 @@
;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301
USA
(define-module (test-suite test-hooks)
+ #:use-module (ice-9 hooks)
#:use-module (test-suite lib))
;;;
