Implement hooks-list datatype.

diff --git a/v7/src/runtime/global.scm b/v7/src/runtime/global.scm
index 0320449fa9f24e8708b2b34c22c2d7e46f00afec..284664c6a02f158a4d49a8cc9901dca820162265 100644 (file)
--- 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)))))
 \f
 (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))))
+\f
+;;;; 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 44113480eb071b2e32219a312585ee56246c69ee..7ab4b3f192d58d4656e647a2b7766589ebef1c5c 100644 (file)
--- 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!