Reimplement CLOSE-ALL-OPEN-FILES to close only file channels, and also

to close the associated port of a file channel rather than the
channel.  Implement and export two new procedures: ALL-OPEN-CHANNELS
and CLOSE-ALL-OPEN-CHANNELS.

diff --git a/v7/src/runtime/io.scm b/v7/src/runtime/io.scm
index 78f894b22df24890c7e47f612ecbacccf87163ed..eb9f9a46bb49212afe6e01914098b4ea72f906d1 100644 (file)
--- a/v7/src/runtime/io.scm
+++ b/v7/src/runtime/io.scm
@@ -1,6 +1,6 @@
 #| -*-Scheme-*-
 
-$Id: io.scm,v 14.49 1997/01/22 20:44:39 cph Exp $
+$Id: io.scm,v 14.50 1997/05/19 17:37:43 cph Exp $
 
 Copyright (c) 1988-97 Massachusetts Institute of Technology
 
@@ -139,17 +139,37 @@ MIT in each case. |#
   (not (channel-descriptor channel)))
 
 (define (close-all-open-files)
-  (close-all-open-files-internal (ucode-primitive channel-close 1)))
+  (close-all-open-channels channel-type=file?))
+
+(define (close-all-open-channels #!optional filter)
+  (let ((filter (if (default-object? filter) #f filter)))
+    (for-each (lambda (channel)
+               (if (or (not filter) (filter channel))
+                   (let ((port (channel-port channel)))
+                     (if port
+                         (close-port port)
+                         (channel-close channel)))))
+             (all-open-channels))
+    (if (not filter)
+       (close-all-open-channels-internal (ucode-primitive channel-close 1)))))
+
+(define (all-open-channels)
+  (without-interrupts
+   (lambda ()
+     (let loop ((l (cdr open-channels-list)) (result '()))
+       (if (null? l)
+          result
+          (loop (cdr l) (cons (system-pair-car (car l)) result)))))))
 
 (define (primitive-io/reset!)
   ;; This is invoked after disk-restoring.
   ;; It "cleans" the new runtime system.
-  (close-all-open-files-internal (lambda (ignore) ignore))
+  (close-all-open-channels-internal (lambda (ignore) ignore))
   (drop-all-protected-objects open-directories-list)
   (set! have-select? ((ucode-primitive have-select? 0)))
   unspecific)
 
-(define (close-all-open-files-internal action)
+(define (close-all-open-channels-internal action)
   (without-interrupts
    (lambda ()
      (let loop ((l (cdr open-channels-list)))

diff --git a/v7/src/runtime/runtime.pkg b/v7/src/runtime/runtime.pkg
index 2990712cc11687272bfc0c1b26d56cbfb7aa3502..044bac29230de932f9bc7a650551f8d9aa610ed6 100644 (file)
--- a/v7/src/runtime/runtime.pkg
+++ b/v7/src/runtime/runtime.pkg
@@ -1,6 +1,6 @@
 #| -*-Scheme-*-
 
-$Id: runtime.pkg,v 14.278 1997/05/15 00:17:48 cph Exp $
+$Id: runtime.pkg,v 14.279 1997/05/19 17:38:00 cph Exp $
 
 Copyright (c) 1988-97 Massachusetts Institute of Technology
 
@@ -1662,6 +1662,7 @@ MIT in each case. |#
   (parent ())
   (export ()
          add-to-protection-list!
+         all-open-channels
          channel-blocking
          channel-blocking?
          channel-close
@@ -1687,6 +1688,7 @@ MIT in each case. |#
          channel-write-string-block
          channel?
          clean-lost-protected-objects
+         close-all-open-channels
          close-all-open-files
          directory-channel-close
          directory-channel-open

diff --git a/v8/src/runtime/runtime.pkg b/v8/src/runtime/runtime.pkg
index b4fa90a3e25586960b973fbc8cf4690688238e37..e170663f4eb7eb9687f4098ddbc46f0a26c86412 100644 (file)
--- a/v8/src/runtime/runtime.pkg
+++ b/v8/src/runtime/runtime.pkg
@@ -1,6 +1,6 @@
 #| -*-Scheme-*-
 
-$Id: runtime.pkg,v 14.284 1997/05/15 00:18:02 cph Exp $
+$Id: runtime.pkg,v 14.285 1997/05/19 17:37:49 cph Exp $
 
 Copyright (c) 1988-97 Massachusetts Institute of Technology
 
@@ -1662,6 +1662,7 @@ MIT in each case. |#
   (parent ())
   (export ()
          add-to-protection-list!
+         all-open-channels
          channel-blocking
          channel-blocking?
          channel-close
@@ -1687,6 +1688,7 @@ MIT in each case. |#
          channel-write-string-block
          channel?
          clean-lost-protected-objects
+         close-all-open-channels
          close-all-open-files
          directory-channel-close
          directory-channel-open