From: Chris Hanson <org/chris-hanson/cph>
Date: Mon, 16 Jan 2017 09:51:52 +0000 (-0800)
Subject: Implement real binary I/O to files.
X-Git-Tag: mit-scheme-pucked-9.2.12~227^2~124
X-Git-Url: https://birchwood-abbey.net/git?a=commitdiff_plain;h=e442fc2b25428da30a03e2ae29266f44fd3ce296;p=mit-scheme.git
Implement real binary I/O to files.
---
diff --git a/src/runtime/fileio.scm b/src/runtime/fileio.scm
index e279a2dfc..236ce1203 100644
--- a/src/runtime/fileio.scm
+++ b/src/runtime/fileio.scm
@@ -29,8 +29,10 @@ USA.
(declare (usual-integrations))
+(define input-file-type)
+(define output-file-type)
+(define i/o-file-type)
(define (initialize-package!)
- (set! operation/pathname (generic-i/o-port-accessor 0))
(let ((other-operations
`((LENGTH ,operation/length)
(PATHNAME ,operation/pathname)
@@ -47,10 +49,11 @@ USA.
(set! i/o-file-type (make-type 'CHANNEL 'CHANNEL))))
unspecific)
-(define input-file-type)
-(define output-file-type)
-(define i/o-file-type)
-(define operation/pathname)
+(define (operation/pathname port)
+ (port-property 'pathname))
+
+(define (set-port-pathname! port pathname)
+ (set-port-property! port 'pathname pathname))
(define (operation/length port)
(channel-file-length
@@ -60,7 +63,7 @@ USA.
(define (operation/write-self port output-port)
(write-string " for file: " output-port)
(write (->namestring (operation/pathname port)) output-port))
-
+
(define (operation/position port)
(guarantee-positionable-port port 'OPERATION/POSITION)
(if (output-port? port)
@@ -97,81 +100,115 @@ USA.
(port-output-buffer port))))
(error:bad-range-argument port caller)))
-(define (open-input-file filename)
- (let* ((pathname (merge-pathnames filename))
- (channel (file-open-input-channel (->namestring pathname)))
- (port (make-generic-i/o-port channel #f input-file-type pathname)))
- (set-channel-port! channel port)
- (port/set-line-ending port (file-line-ending pathname))
- port))
-
-(define (open-output-file filename #!optional append?)
- (let* ((pathname (merge-pathnames filename))
- (channel
- (let ((filename (->namestring pathname)))
+(define (input-file-opener caller make-port)
+ (lambda (filename)
+ (let* ((pathname (merge-pathnames filename))
+ (channel (file-open-input-channel (->namestring pathname))))
+ (make-port channel #f pathname caller))))
+
+(define (output-file-opener caller make-port)
+ (lambda (filename #!optional append?)
+ (let* ((pathname (merge-pathnames filename))
+ (filename (->namestring pathname))
+ (channel
(if (if (default-object? append?) #f append?)
(file-open-append-channel filename)
(file-open-output-channel filename))))
- (port (make-generic-i/o-port #f channel output-file-type pathname)))
- (set-channel-port! channel port)
- (port/set-line-ending port (file-line-ending pathname))
- port))
-
-(define (open-exclusive-output-file filename)
- (let* ((pathname (merge-pathnames filename))
- (channel (file-open-exclusive-output-channel (->namestring pathname)))
- (port (make-generic-i/o-port #f channel output-file-type pathname)))
- (set-channel-port! channel port)
- (port/set-line-ending port (file-line-ending pathname))
- port))
-
-(define (open-i/o-file filename)
- (let* ((pathname (merge-pathnames filename))
- (channel (file-open-io-channel (->namestring pathname)))
- (port (make-generic-i/o-port channel channel i/o-file-type pathname)))
- (set-channel-port! channel port)
+ (make-port #f channel pathname caller))))
+
+(define (exclusive-output-file-opener caller make-port)
+ (lambda (filename)
+ (let* ((pathname (merge-pathnames filename))
+ (channel
+ (file-open-exclusive-output-channel (->namestring pathname))))
+ (make-port #f channel pathname caller))))
+
+(define (i/o-file-opener caller make-port)
+ (lambda (filename)
+ (let* ((pathname (merge-pathnames filename))
+ (channel (file-open-io-channel (->namestring pathname))))
+ (make-port channel channel pathname caller))))
+
+(define (make-textual-port input-channel output-channel pathname caller)
+ caller
+ (let ((port (%make-textual-port input-channel output-channel pathname)))
(port/set-line-ending port (file-line-ending pathname))
port))
-(define (open-legacy-binary-input-file filename)
- (let* ((pathname (merge-pathnames filename))
- (channel (file-open-input-channel (->namestring pathname)))
- (port (make-generic-i/o-port channel #f input-file-type pathname)))
- (set-channel-port! channel port)
+(define (make-legacy-binary-port input-channel output-channel pathname caller)
+ caller
+ (let ((port (%make-textual-port input-channel output-channel pathname)))
(port/set-coding port 'BINARY)
(port/set-line-ending port 'BINARY)
port))
-(define (open-legacy-binary-output-file filename #!optional append?)
- (let* ((pathname (merge-pathnames filename))
- (channel
- (let ((filename (->namestring pathname)))
- (if (if (default-object? append?) #f append?)
- (file-open-append-channel filename)
- (file-open-output-channel filename))))
- (port (make-generic-i/o-port #f channel output-file-type pathname)))
- (set-channel-port! channel port)
- (port/set-coding port 'BINARY)
- (port/set-line-ending port 'BINARY)
+(define (%make-textual-port input-channel output-channel pathname)
+ (let ((port
+ (make-generic-i/o-port input-channel
+ output-channel
+ (cond ((not input-channel) output-file-type)
+ ((not output-channel) input-file-type)
+ (else i/o-file-type)))))
+ ;; If both channels are set they are the same.
+ (cond (input-channel (set-channel-port! input-channel port))
+ (output-channel (set-channel-port! output-channel port)))
+ (set-port-pathname! port pathname)
port))
+
+(define open-input-file
+ (input-file-opener 'open-input-file make-textual-port))
-(define (open-exclusive-legacy-binary-output-file filename)
- (let* ((pathname (merge-pathnames filename))
- (channel (file-open-exclusive-output-channel (->namestring pathname)))
- (port (make-generic-i/o-port #f channel output-file-type pathname)))
- (set-channel-port! channel port)
- (port/set-coding port 'BINARY)
- (port/set-line-ending port 'BINARY)
- port))
+(define open-output-file
+ (output-file-opener 'open-output-file make-textual-port))
-(define (open-legacy-binary-i/o-file filename)
- (let* ((pathname (merge-pathnames filename))
- (channel (file-open-io-channel (->namestring pathname)))
- (port (make-generic-i/o-port channel channel i/o-file-type pathname)))
- (set-channel-port! channel port)
- (port/set-coding port 'BINARY)
- (port/set-line-ending port 'BINARY)
+(define open-exclusive-output-file
+ (exclusive-output-file-opener 'open-exclusive-output-file make-textual-port))
+
+(define open-i/o-file
+ (i/o-file-opener 'open-i/o-file make-textual-port))
+
+(define open-legacy-binary-input-file
+ (input-file-opener 'open-legacy-binary-input-file make-legacy-binary-port))
+
+(define open-legacy-binary-output-file
+ (output-file-opener 'open-legacy-binary-output-file make-legacy-binary-port))
+
+(define open-exclusive-legacy-binary-output-file
+ (exclusive-output-file-opener 'open-exclusive-legacy-binary-output-file
+ make-legacy-binary-port))
+
+(define open-legacy-binary-i/o-file
+ (i/o-file-opener 'open-legacy-binary-i/o-file make-legacy-binary-port))
+
+(define (make-binary-port input-channel output-channel pathname caller)
+ (let ((port (%make-binary-port input-channel output-channel caller)))
+ (set-port-pathname! port pathname)
port))
+
+(define (%make-binary-port input-channel output-channel caller)
+ (cond ((not input-channel)
+ (make-binary-output-port (make-channel-output-sink output-channel)
+ caller))
+ ((not output-channel)
+ (make-binary-input-port (make-channel-input-source input-channel)
+ caller))
+ (else
+ (make-binary-i/o-port (make-channel-input-source input-channel)
+ (make-channel-output-sink output-channel)
+ caller))))
+
+(define open-binary-input-file
+ (input-file-opener 'open-binary-input-file make-binary-port))
+
+(define open-binary-output-file
+ (output-file-opener 'open-binary-output-file make-binary-port))
+
+(define open-exclusive-binary-output-file
+ (exclusive-output-file-opener 'open-exclusive-binary-output-file
+ make-binary-port))
+
+(define open-binary-i/o-file
+ (i/o-file-opener 'open-binary-i/o-file make-binary-port))
(define ((make-call-with-file open) input-specifier receiver)
(let ((port (open input-specifier)))
@@ -182,24 +219,39 @@ USA.
(define call-with-input-file
(make-call-with-file open-input-file))
-(define call-with-legacy-binary-input-file
- (make-call-with-file open-legacy-binary-input-file))
-
(define call-with-output-file
(make-call-with-file open-output-file))
(define call-with-exclusive-output-file
(make-call-with-file open-exclusive-output-file))
+(define call-with-append-file
+ (make-call-with-file (lambda (filename) (open-output-file filename #t))))
+
+
+(define call-with-binary-input-file
+ (make-call-with-file open-binary-input-file))
+
+(define call-with-binary-output-file
+ (make-call-with-file open-binary-output-file))
+
+(define call-with-exclusive-binary-output-file
+ (make-call-with-file open-exclusive-binary-output-file))
+
+(define call-with-binary-append-file
+ (make-call-with-file
+ (lambda (filename) (open-binary-output-file filename #t))))
+
+
+(define call-with-legacy-binary-input-file
+ (make-call-with-file open-legacy-binary-input-file))
+
(define call-with-legacy-binary-output-file
(make-call-with-file open-legacy-binary-output-file))
(define call-with-exclusive-legacy-binary-output-file
(make-call-with-file open-exclusive-legacy-binary-output-file))
-(define call-with-append-file
- (make-call-with-file (lambda (filename) (open-output-file filename #t))))
-
(define call-with-legacy-binary-append-file
(make-call-with-file
(lambda (filename) (open-legacy-binary-output-file filename #t))))
@@ -212,7 +264,7 @@ USA.
(define with-input-from-file
(make-with-input-from-file call-with-input-file))
-(define with-input-from-binary-file
+(define with-input-from-legacy-binary-file
(make-with-input-from-file call-with-legacy-binary-input-file))
(define ((make-with-output-to-file call) output-specifier thunk)
@@ -226,7 +278,7 @@ USA.
(define with-output-to-exclusive-file
(make-with-output-to-file call-with-exclusive-output-file))
-(define with-output-to-binary-file
+(define with-output-to-legacy-binary-file
(make-with-output-to-file call-with-legacy-binary-output-file))
(define with-output-to-exclusive-legacy-binary-file
diff --git a/src/runtime/runtime.pkg b/src/runtime/runtime.pkg
index 89a01492b..bf9d8392a 100644
--- a/src/runtime/runtime.pkg
+++ b/src/runtime/runtime.pkg
@@ -2110,20 +2110,28 @@ USA.
open-legacy-binary-i/o-file
open-legacy-binary-input-file
open-legacy-binary-output-file
- with-input-from-binary-file
- with-output-to-binary-file
+ with-input-from-legacy-binary-file
+ with-output-to-legacy-binary-file
+ with-output-to-exclusive-file
with-output-to-exclusive-legacy-binary-file
;; END deprecated bindings
call-with-append-file
+ call-with-binary-append-file
+ call-with-binary-input-file
+ call-with-binary-output-file
+ call-with-exclusive-binary-output-file
call-with-exclusive-output-file
call-with-input-file
call-with-output-file
+ open-binary-i/o-file
+ open-binary-input-file
+ open-binary-output-file
+ open-exclusive-binary-output-file
open-exclusive-output-file
open-i/o-file
open-input-file
open-output-file
with-input-from-file
- with-output-to-exclusive-file
with-output-to-file)
(initialization (initialize-package!)))