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

* boot-9.scm: Removed old style hooks.

Browse source 
(inherit-print-state): Rwwritten to use port-with-print-state.
This commit is contained in:
Mikael Djurfeldt 1999-08-24 02:22:18 +00:00
parent 079100140f
commit 8a30733e8d
1 changed files with 2 additions and 49 deletions
Download patch file Download diff file Expand all files Collapse all files

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

@ -359,9 +359,8 @@
;; It should print OBJECT to PORT. ;; It should print OBJECT to PORT.
(define (inherit-print-state old-port new-port) (define (inherit-print-state old-port new-port)
(if (pair? old-port) (if (get-print-state old-port)
(cons (if (pair? new-port) (car new-port) new-port) (port-with-print-state new-port (get-print-state old-port))
(cdr old-port))
new-port)) new-port))
;; 0: type-name, 1: fields ;; 0: type-name, 1: fields
@ -564,52 +563,6 @@
(and (not (null? l)) (and (not (null? l))
(loop (f (car l)) (cdr 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-add-hook!))
(begin
(define new-add-hook! add-hook!)
(define new-remove-hook! remove-hook!)))
(define (run-hooks hook)
(if (and (pair? hook) (eq? (car hook) 'hook))
(run-hook hook)
(for-each (lambda (thunk) (thunk)) hook)))
(define *suppress-old-style-hook-warning* #f)
(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
(or *suppress-old-style-hook-warning*
(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
(or *suppress-old-style-hook-warning*
(display "Warning: Old style hooks\n" (current-error-port)))
`(let ((thunk ,(caddr exp)))
(set! ,(cadr exp)
(delq! thunk ,(cadr exp))))))))))
;;; {Files} ;;; {Files}
;;; ;;;