From d1406b6a40cd68139c468ff7905ecc2a45a3c62d Mon Sep 17 00:00:00 2001 From: Mikael Djurfeldt Date: Wed, 25 Nov 1998 15:17:12 +0000 Subject: [PATCH] * boot-9.scm (run-hooks, add-hook!, remove-hook!): Added temporary code for backward compatibility until people have had time to adapt to the new hooks. --- ice-9/boot-9.scm | 43 +++++++++++++++++++++++++++++++++++++++++++ 1 file changed, 43 insertions(+) diff --git a/ice-9/boot-9.scm b/ice-9/boot-9.scm index 6600ff8c9..09c72ae21 100644 --- a/ice-9/boot-9.scm +++ b/ice-9/boot-9.scm @@ -552,6 +552,49 @@ (and (not (null? l)) (loop (f (car l)) (cdr l)))))) + +;;; {Hooks} +;;; +;;; Warning: Hooks are now first class objects and add-hook! and remove-hook! +;;; procedures. This interface is only provided for backward compatibility +;;; and will be removed. +;;; +(if (not (defined? 'new-run-hooks)) + (begin + (define new-run-hooks run-hooks) + (define new-add-hook! add-hook!) + (define new-remove-hook! remove-hook!))) + +(define (run-hooks hook) + (if (and (pair? hook) (eq? (car hook) 'hook)) + (new-run-hooks hook) + (for-each (lambda (thunk) (thunk)) hook))) + +(define add-hook! + (procedure->memoizing-macro + (lambda (exp env) + (let ((hook (local-eval (cadr exp) env))) + (if (and (pair? hook) (eq? (car hook) 'hook)) + `(new-add-hook! ,@(cdr exp)) + (begin + (display "Warning: Old style hooks\n" (current-error-port)) + `(let ((thunk ,(caddr exp))) + (if (not (memq thunk ,(cadr exp))) + (set! ,(cadr exp) + (cons thunk ,(cadr exp))))))))))) + +(define remove-hook! + (procedure->memoizing-macro + (lambda (exp env) + (let ((hook (local-eval (cadr exp) env))) + (if (and (pair? hook) (eq? (car hook) 'hook)) + `(new-remove-hook! ,@(cdr exp)) + (begin + (display "Warning: Old style hooks\n" (current-error-port)) + `(let ((thunk ,(caddr exp))) + (set! ,(cadr exp) + (delq! thunk ,(cadr exp)))))))))) + ;;; {Files} ;;;