From: Chris Hanson <org/chris-hanson/cph>
Date: Tue, 10 Apr 1990 20:05:26 +0000 (+0000)
Subject: Add optional second argument to `open-output-file': if supplied and
X-Git-Tag: 20090517-FFI~11444
X-Git-Url: https://birchwood-abbey.net/git?a=commitdiff_plain;h=e24607c3134f0183ea76c37b90e1ea4768bffa71;p=mit-scheme.git

Add optional second argument to `open-output-file': if supplied and
not false, the file is opened for append.
---

diff --git a/v7/src/runtime/io.scm b/v7/src/runtime/io.scm
index 2bec879a4..a8ac79277 100644
--- a/v7/src/runtime/io.scm
+++ b/v7/src/runtime/io.scm
@@ -1,8 +1,8 @@
 #| -*-Scheme-*-
 
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/io.scm,v 14.4 1990/02/27 19:39:34 markf Exp $
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/io.scm,v 14.5 1990/04/10 20:05:13 cph Exp $
 
-Copyright (c) 1988, 1989 Massachusetts Institute of Technology
+Copyright (c) 1988, 1989, 1990 Massachusetts Institute of Technology
 
 This material was developed by the Scheme project at the Massachusetts
 Institute of Technology, Department of Electrical Engineering and
@@ -38,8 +38,6 @@ MIT in each case. |#
 (declare (usual-integrations))
 
 (define (initialize-package!)
-  (set! open-input-channel (open-channel-wrapper false))
-  (set! open-output-channel (open-channel-wrapper true))
   (set! close-all-open-files (close-files file-close-channel))
   (set! primitive-io/reset! (close-files (lambda (ignore) ignore)))
   (set! open-files-list (list 'OPEN-FILES-LIST))
@@ -80,22 +78,38 @@ MIT in each case. |#
 ;;;; Open/Close Files
 
 ;;;  Direction is one of the following:
-;;;     - true:   output channel
-;;;	- false:  input channel
-;;;	- 0:	  closed channel
+;;;	- #f:		input channel
+;;;     - #t:		output channel
+;;;     - 'append:	append output channel
+;;;	- 0:		closed channel
 
-(define ((open-channel-wrapper direction) filename-or-process)
+(define (open-channel filename-or-process direction)
   (without-interrupts
    (lambda ()
      (let ((channel
-	    (make-physical-channel
-	     (if (process? filename-or-process)
-		 (if direction
-		     (process-get-input-channel filename-or-process)
-		     (process-get-output-channel filename-or-process))
-		 (file-open-channel filename-or-process direction))
-	     filename-or-process
-	     direction)))
+	    (case direction
+	      ((#F)
+	       (make-physical-channel
+		(if (process? filename-or-process)
+		    (process-get-input-channel filename-or-process)
+		    (file-open-channel filename-or-process direction))
+		filename-or-process
+		direction))
+	      ((#T)
+	       (make-physical-channel
+		(if (process? filename-or-process)
+		    (process-get-output-channel filename-or-process)
+		    (file-open-channel filename-or-process direction))
+		filename-or-process
+		direction))
+	      (else
+	       (if (process? filename-or-process)
+		   (error "Can't open process channel for append"
+			  filename-or-process))
+	       (make-physical-channel
+		(file-open-channel filename-or-process 'APPEND)
+		filename-or-process
+		#T)))))
        (with-absolutely-no-interrupts
 	(lambda ()
 	  (set-cdr! open-files-list
@@ -105,8 +119,14 @@ MIT in each case. |#
 			  (cdr open-files-list)))))
        channel))))
 
-(define open-input-channel)
-(define open-output-channel)
+(define (open-input-channel filename-or-process)
+  (open-channel filename-or-process false))
+
+(define (open-output-channel filename-or-process)
+  (open-channel filename-or-process true))
+
+(define (open-append-channel filename)
+  (open-channel filename 'APPEND))
 
 ;;; This is locked from interrupts, but GC can occur since the
 ;;; procedure itself hangs on to the channel until the last moment,
diff --git a/v7/src/runtime/runtime.pkg b/v7/src/runtime/runtime.pkg
index cb1ffabc6..ba305bd03 100644
--- a/v7/src/runtime/runtime.pkg
+++ b/v7/src/runtime/runtime.pkg
@@ -1,6 +1,6 @@
 #| -*-Scheme-*-
 
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/runtime.pkg,v 14.63 1990/03/26 19:38:29 jinx Exp $
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/runtime.pkg,v 14.64 1990/04/10 20:05:18 cph Exp $
 
 Copyright (c) 1988, 1989, 1990 Massachusetts Institute of Technology
 
@@ -1268,6 +1268,7 @@ MIT in each case. |#
   (export (runtime file-output)
 	  channel-name
 	  close-physical-channel
+	  open-append-channel
 	  open-output-channel)
   (export (runtime subprocesses input)
 	  close-physical-channel
diff --git a/v7/src/runtime/version.scm b/v7/src/runtime/version.scm
index bc36138a4..6f89fdb89 100644
--- a/v7/src/runtime/version.scm
+++ b/v7/src/runtime/version.scm
@@ -1,6 +1,6 @@
 #| -*-Scheme-*-
 
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/version.scm,v 14.77 1990/03/02 20:24:46 markf Exp $
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/version.scm,v 14.78 1990/04/10 20:05:26 cph Exp $
 
 Copyright (c) 1988, 1989, 1990 Massachusetts Institute of Technology
 
@@ -45,7 +45,7 @@ MIT in each case. |#
 		     '()))
   (add-system! microcode-system)
   (add-event-receiver! event:after-restore snarf-microcode-version!)
-  (add-identification! "Runtime" 14 77))
+  (add-identification! "Runtime" 14 78))
 
 (define microcode-system)
 
diff --git a/v8/src/runtime/runtime.pkg b/v8/src/runtime/runtime.pkg
index b3987bf6c..483cf1343 100644
--- a/v8/src/runtime/runtime.pkg
+++ b/v8/src/runtime/runtime.pkg
@@ -1,6 +1,6 @@
 #| -*-Scheme-*-
 
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v8/src/runtime/runtime.pkg,v 14.63 1990/03/26 19:38:29 jinx Exp $
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v8/src/runtime/runtime.pkg,v 14.64 1990/04/10 20:05:18 cph Exp $
 
 Copyright (c) 1988, 1989, 1990 Massachusetts Institute of Technology
 
@@ -1268,6 +1268,7 @@ MIT in each case. |#
   (export (runtime file-output)
 	  channel-name
 	  close-physical-channel
+	  open-append-channel
 	  open-output-channel)
   (export (runtime subprocesses input)
 	  close-physical-channel