From 5561a45e0fff0bd39fd5e32e433054534798522f Mon Sep 17 00:00:00 2001
From: Chris Hanson <org/chris-hanson/cph>
Date: Sat, 30 Oct 2004 03:56:39 +0000
Subject: [PATCH] Implement hooks-list datatype.

---
 v7/src/runtime/global.scm  | 62 +++++++++++++++++++++++++++++++++++---
 v7/src/runtime/runtime.pkg | 10 +++++-
 2 files changed, 66 insertions(+), 6 deletions(-)

diff --git a/v7/src/runtime/global.scm b/v7/src/runtime/global.scm
index 0320449fa..284664c6a 100644
--- a/v7/src/runtime/global.scm
+++ b/v7/src/runtime/global.scm
@@ -1,6 +1,6 @@
 #| -*-Scheme-*-
 
-$Id: global.scm,v 14.68 2004/10/01 02:47:51 cph Exp $
+$Id: global.scm,v 14.69 2004/10/30 03:56:14 cph Exp $
 
 Copyright 1988,1989,1991,1992,1993,1995 Massachusetts Institute of Technology
 Copyright 1998,2000,2001,2003,2004 Massachusetts Institute of Technology
@@ -162,9 +162,8 @@ USA.
       (with-output-to-truncated-string max (lambda () (write object)))))
 
 (define (pa procedure)
-  (cond ((not (procedure? procedure))
-	 (error "Must be a procedure" procedure))
-	((procedure-lambda procedure)
+  (guarantee-procedure procedure 'PA)
+  (cond ((procedure-lambda procedure)
 	 => (lambda (scode)
 	      (pp (unsyntax-lambda-list scode))))
 	((and (primitive-procedure? procedure)
@@ -378,4 +377,57 @@ USA.
 		 (lambda ()
 		   (write-string " -- done" port)
 		   (newline port))))
-	(do-it no-print no-print))))
\ No newline at end of file
+	(do-it no-print no-print))))
+
+;;;; Hook lists
+
+(define-record-type <hook-list>
+    (%make-hook-list hooks)
+    hook-list?
+  (hooks hook-list-hooks set-hook-list-hooks!))
+
+(define (make-hook-list)
+  (%make-hook-list '()))
+
+(define (guarantee-hook-list object caller)
+  (if (not (hook-list? object))
+      (error:not-hook-list object caller)))
+
+(define (error:not-hook-list object caller)
+  (error:wrong-type-argument object "hook list" caller))
+
+(define (append-hook-to-list hook-list key hook)
+  (guarantee-hook-list hook-list 'APPEND-HOOK-TO-LIST)
+  (let loop ((alist (hook-list-hooks hook-list)) (prev #f))
+    (if (pair? alist)
+	(loop (cdr alist)
+	      (if (eq? (caar alist) key)
+		  (begin
+		    (if prev
+			(set-cdr! prev (cdr alist))
+			(set-hook-list-hooks! hook-list (cdr alist)))
+		    prev)
+		  alist))
+	(let ((tail (list (cons key hook))))
+	  (if prev
+	      (set-cdr! prev tail)
+	      (set-hook-list-hooks! hook-list tail))))))
+
+(define (remove-hook-from-list hook-list key)
+  (guarantee-hook-list hook-list 'REMOVE-HOOK-FROM-LIST)
+  (let loop ((alist (hook-list-hooks hook-list)) (prev #f))
+    (if (pair? alist)
+	(loop (cdr alist)
+	      (if (eq? (caar alist) key)
+		  (begin
+		    (if prev
+			(set-cdr! prev (cdr alist))
+			(set-hook-list-hooks! hook-list (cdr alist)))
+		    prev)
+		  alist)))))
+
+(define (run-hooks-in-list hook-list . arguments)
+  (guarantee-hook-list hook-list 'RUN-HOOKS-IN-LIST)
+  (for-each (lambda (p)
+	      (apply (cdr p) arguments))
+	    (hook-list-hooks hook-list)))
\ No newline at end of file
diff --git a/v7/src/runtime/runtime.pkg b/v7/src/runtime/runtime.pkg
index 44113480e..7ab4b3f19 100644
--- a/v7/src/runtime/runtime.pkg
+++ b/v7/src/runtime/runtime.pkg
@@ -1,6 +1,6 @@
 #| -*-Scheme-*-
 
-$Id: runtime.pkg,v 14.504 2004/10/28 22:53:20 cph Exp $
+$Id: runtime.pkg,v 14.505 2004/10/30 03:56:39 cph Exp $
 
 Copyright 1988,1989,1990,1991,1992,1993 Massachusetts Institute of Technology
 Copyright 1994,1995,1996,1997,1998,1999 Massachusetts Institute of Technology
@@ -272,6 +272,8 @@ USA.
 	  %exit
 	  %quit
 	  *the-non-printing-object*
+	  <hook-list>
+	  append-hook-to-list
 	  apply
 	  bind-cell-contents!
 	  call-with-values
@@ -283,12 +285,15 @@ USA.
 	  environment-link-name
 	  eq?
 	  error-procedure
+	  error:not-hook-list
 	  eval
 	  exit
 	  false-procedure
 	  fasdump
 	  get-fixed-objects-vector
 	  get-interrupt-enables
+	  guarantee-hook-list
+	  hook-list?
 	  hook/exit
 	  hook/quit
 	  hook/scode-eval
@@ -305,6 +310,7 @@ USA.
 	  link-variables
 	  local-assignment
 	  make-cell
+	  make-hook-list
 	  make-non-pointer-object
 	  non-pointer-type-code?
 	  null-procedure
@@ -323,6 +329,8 @@ USA.
 	  primitive-procedure-documentation
 	  pwd
 	  quit
+	  remove-hook-from-list
+	  run-hooks-in-list
 	  scode-eval
 	  set-cell-contents!
 	  set-interrupt-enables!
-- 
2.25.1