From f930af273764120c9ef758c17878444fc2b10d26 Mon Sep 17 00:00:00 2001 From: Andy Wingo Date: Mon, 16 Jun 2025 12:30:59 +0200 Subject: [PATCH] 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 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(-) delete mode 100644 libguile/hooks.c delete mode 100644 libguile/hooks.h create mode 100644 module/ice-9/hooks.scm 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" @@ -470,6 +471,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 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 - . */ - - - - -#ifdef HAVE_CONFIG_H -# include -#endif - -#include - -#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 ("#', 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 - . */ - - - -#include -#include - -/* - * 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 +;;; . + +;;; 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 + (make-record-type ' '(procs) + (lambda (hook port) (print-hook hook port)))) + +(define %make-hook (record-constructor )) +(define* (make-hook #:optional nargs) + "Create a hook containing an ordered list of procedures." + (%make-hook '())) + +(define hook? (record-predicate )) + +(define hook-procs (record-accessor 'procs)) +(define set-hook-procs! (record-modifier '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. - + @@ -3537,7 +3537,6 @@ var{initargs}." (define (find-subclass ')) (define (find-subclass ')) -(define (find-subclass ')) (define (find-subclass ')) (define (find-subclass ')) (define (find-subclass ')) 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 ( 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)) ;;;