summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorMikael Djurfeldt <djurfeldt@nada.kth.se>1999-08-24 02:22:18 +0000
committerMikael Djurfeldt <djurfeldt@nada.kth.se>1999-08-24 02:22:18 +0000
commit8a30733e8d6b4ea8cabdb2eb4a18b47bdd994bd5 (patch)
tree618c1faaa55c1b5bc519532f5625cee77adee396
parent079100140fdb5f062fa643dbce149350ce0cf55c (diff)
downloadguile-8a30733e8d6b4ea8cabdb2eb4a18b47bdd994bd5.tar.gz
* boot-9.scm: Removed old style hooks.
(inherit-print-state): Rwwritten to use port-with-print-state.
-rw-r--r--ice-9/boot-9.scm51
1 files changed, 2 insertions, 49 deletions
diff --git a/ice-9/boot-9.scm b/ice-9/boot-9.scm
index 3118966a8..198862ad4 100644
--- a/ice-9/boot-9.scm
+++ b/ice-9/boot-9.scm
@@ -359,9 +359,8 @@
;; It should print OBJECT to PORT.
(define (inherit-print-state old-port new-port)
- (if (pair? old-port)
- (cons (if (pair? new-port) (car new-port) new-port)
- (cdr old-port))
+ (if (get-print-state old-port)
+ (port-with-print-state new-port (get-print-state old-port))
new-port))
;; 0: type-name, 1: fields
@@ -565,52 +564,6 @@
(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}
;;;
;;; If no one can explain this comment to me by 31 Jan 1998, I will