Generalize textual port operations to handle binary ports.

diff --git a/src/runtime/binary-port.scm b/src/runtime/binary-port.scm
index d648c870c2e98fa9f17f5ef2d3d5e1e172bc5592..d752c0ad5d6cfa5c1357a4709c55c352183e6394 100644 (file)
--- a/src/runtime/binary-port.scm
+++ b/src/runtime/binary-port.scm
@@ -29,11 +29,15 @@ USA.
 
 (declare (usual-integrations))
 \f
+(define (make-binary-port input-buffer output-buffer)
+  (%make-binary-port input-buffer output-buffer (make-alist-metadata-table)))
+
 (define-record-type <binary-port>
-    (make-binary-port input-buffer output-buffer)
+    (%make-binary-port input-buffer output-buffer metadata)
     binary-port?
   (input-buffer port-input-buffer)
-  (output-buffer port-output-buffer))
+  (output-buffer port-output-buffer)
+  (metadata binary-port-metadata))
 
 (define (make-binary-input-port source caller)
   (let ((port

diff --git a/src/runtime/port.scm b/src/runtime/port.scm
index 565faf51dd99fb3820794f064c5efd97dc476413..b64de72faf66363eab3031ac891652f681582230 100644 (file)
--- a/src/runtime/port.scm
+++ b/src/runtime/port.scm
@@ -380,20 +380,21 @@ USA.
 ;;;; Textual ports
 
 (define-record-type <textual-port>
-    (%make-textual-port thread-mutex type state unread? previous properties
-                       transcript)
+    (%make-textual-port thread-mutex type state unread? previous transcript
+                       metadata)
     textual-port?
   (thread-mutex textual-port-thread-mutex)
   (type textual-port-type set-textual-port-type!)
   (state textual-port-state set-textual-port-state!)
   (unread? textual-port-unread? set-textual-port-unread?!)
   (previous textual-port-previous set-textual-port-previous!)
-  (properties textual-port-properties set-textual-port-properties!)
-  (transcript textual-port-transcript set-textual-port-transcript!))
+  (transcript textual-port-transcript set-textual-port-transcript!)
+  (metadata textual-port-metadata))
 
 (define (make-textual-port type state)
   (guarantee textual-port-type? type 'MAKE-TEXTUAL-PORT)
-  (%make-textual-port (make-thread-mutex) type state #f #f '() #f))
+  (%make-textual-port (make-thread-mutex) type state #f #f #f
+                     (make-alist-metadata-table)))
 
 (define (textual-input-port? object)
   (and (textual-port? object)
@@ -510,36 +511,21 @@ USA.
 (define-port-operation flush-output)
 (define-port-operation discretionary-flush-output)
 
-(define (textual-port-property port name default)
+(define (textual-port-property port name #!optional default-value)
   (guarantee symbol? name 'port-property)
-  (let ((p (assq name (textual-port-properties port))))
-    (if p
-       (cdr p)
-       default)))
+  (((port-metadata port) 'get) name default-value))
 
 (define (set-textual-port-property! port name value)
   (guarantee symbol? name 'set-port-property!)
-  (let ((alist (textual-port-properties port)))
-    (let ((p (assq name alist)))
-      (if p
-         (set-cdr! p value)
-         (set-textual-port-properties! port (cons (cons name value) alist))))))
+  (((port-metadata port) 'put!) name value))
 
 (define (intern-textual-port-property! port name get-value)
-  (guarantee symbol? name 'INTERN-PORT-PROPERTY!)
-  (let ((alist (textual-port-properties port)))
-    (let ((p (assq name alist)))
-      (if p
-         (cdr p)
-         (let ((value (get-value)))
-           (set-textual-port-properties! port (cons (cons name value) alist))
-           value)))))
+  (guarantee symbol? name 'intern-port-property!)
+  (((port-metadata port) 'intern!) name get-value))
 
 (define (remove-textual-port-property! port name)
-  (guarantee symbol? name 'REMOVE-PORT-PROPERTY!)
-  (set-textual-port-properties! port
-                               (del-assq! name
-                                          (textual-port-properties port))))
+  (guarantee symbol? name 'remove-port-property!)
+  (((port-metadata port) 'delete!) name))
 
 (define (transcribe-char char port)
   (let ((tport (textual-port-transcript port)))
@@ -660,6 +646,11 @@ USA.
   (cond ((binary-output-port? port) (binary-output-port-channel port))
        ((textual-output-port? port) (textual-output-port-channel port))
        (else (error:not-a output-port? port 'output-port-channel))))
+
+(define (port-metadata port)
+  (cond ((binary-port? port) (binary-port-metadata port))
+       ((textual-port? port) (textual-port-metadata port))
+       (else (error:not-a port? port 'port-metadata))))
 \f
 ;;;; Port modes
 

diff --git a/src/runtime/runtime.pkg b/src/runtime/runtime.pkg
index d4fa461714052a414f9e0d97c7861a919bd772cd..2b144d247ba3f755253efd812875a5adc51a11f5 100644 (file)
--- a/src/runtime/runtime.pkg
+++ b/src/runtime/runtime.pkg
@@ -2498,6 +2498,7 @@ USA.
          binary-input-port:set-buffer-contents!
          binary-output-port-channel
          binary-output-port-open?
+         binary-port-metadata
          close-binary-input-port
          close-binary-output-port
          close-binary-port)