mirror of
https://git.savannah.gnu.org/git/guile.git
synced 2025-07-01 15:20:34 +02:00
f930af2737
* 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.
79 lines
2.6 KiB
Scheme
79 lines
2.6 KiB
Scheme
;;; 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))
|