From: Chris Hanson <org/chris-hanson/cph>
Date: Mon, 19 May 1997 17:38:00 +0000 (+0000)
Subject: Reimplement CLOSE-ALL-OPEN-FILES to close only file channels, and also
X-Git-Tag: 20090517-FFI~5173
X-Git-Url: https://birchwood-abbey.net/git?a=commitdiff_plain;h=2b28512876799eb2bff0ec69ed3beaec12c22a4b;p=mit-scheme.git

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 78f894b22..eb9f9a46b 100644
--- 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 2990712cc..044bac292 100644
--- 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 b4fa90a3e..e170663f4 100644
--- 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