mirror/guile
mirror/guile
1
Fork 0
mirror of https://git.savannah.gnu.org/git/guile.git synced 2025-05-30 00:40:20 +02:00
Code Activity

* boot-9.scm (run-hooks, add-hook!, remove-hook!): Added temporary

Browse source 
code for backward compatibility until people have had time to
adapt to the new hooks.
This commit is contained in:
Mikael Djurfeldt 1998-11-25 15:17:12 +00:00
parent 69c6acbb74
commit d1406b6a40
1 changed files with 43 additions and 0 deletions
Download patch file Download diff file Expand all files Collapse all files

43
ice-9/boot-9.scm
View file

@ -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}
;;;