[Git][cmucl/cmucl][issue-140-stream-element-type-two-way-stream] Allow broadcast-stream and two-way-stream for stream-external-format

[Raymond Toy (@rtoy)]

Raymond Toy pushed to branch issue-140-stream-element-type-two-way-stream at cmucl / cmucl


Commits:
145aa085 by Raymond Toy at 2022-10-18T17:06:58-07:00
Allow broadcast-stream and two-way-stream for stream-external-format

`stream-external-format` for a `broadcast-stream` is `:default`,
according to the CLHS.

For a `two-way-stream`, the CLHS doesn't say, so we'll return the
common external format if there is one, or `:default` if they're
different.

For a `synonym-stream`, the CLHS also doesn't say, so we'll just
return the format of the value of the synonym stream symbol.

Add tests for test different types of streams, except for
`broadcast-stream`.  The ansi-tests have tests for this.

- - - - -


2 changed files:

- src/code/stream.lisp
- tests/issues.lisp


Changes:

=====================================
src/code/stream.lisp
=====================================
@@ -295,8 +295,22 @@
     (etypecase stream
       #+unicode
       (fd-stream (fd-stream-external-format stream))
-      (synonym-stream (stream-external-format
-		       (symbol-value (synonym-stream-symbol stream)))))
+      (broadcast-stream
+       ;; See http://www.lispworks.com/documentation/HyperSpec/Body/t_broadc.htm
+       :default)
+      (synonym-stream
+       ;; What should happen if (synonym-stream-symbol stream) is unbound?
+       (stream-external-format
+	(symbol-value (synonym-stream-symbol stream))))
+      (two-way-stream
+       ;; Not defined by CLHS, but useful to return the common format
+       ;; of the input and output streams when they're the same;
+       ;; otherwise return :default.
+       (let ((in-format (stream-external-format (two-way-stream-input-stream stream)))
+	     (out-format (stream-external-format (two-way-stream-output-stream stream))))
+	 (if (eql in-format out-format)
+	     in-format
+	     :default))))
     ;; fundamental-stream
     :default))
 


=====================================
tests/issues.lisp
=====================================
@@ -670,9 +670,42 @@
 		 (err (relerr value answer)))
 	    (assert-true (<= err eps) base err eps)))))))
 
-(define-test issue.140
+;;; Test stream-external-format for various types of streams.
+
+;; Test two-way-stream where both streams have the same external
+;; format.
+(define-test issue.140.1
+    (:tag :issues)
+  (with-open-file (in (merge-pathnames "issues.lisp" cmucl-test-runner::*load-path*)
+		      :direction :input
+		      :external-format :utf-8)
+    (with-open-file (out "/tmp/output.tst"
+			 :direction :output
+			 :external-format :utf-8
+			 :if-exists :supersede)
+      (let ((two-way-stream (make-two-way-stream in out)))
+	(assert-equal :utf-8 (stream-external-format two-way-stream))))))
+
+;; Test two-way-stream where the two streams have the different
+;; external formats.
+(define-test issue.140.2
     (:tag :issues)
-  (with-output-to-string (out)
-    (with-input-from-string (in "abc")
+  (with-open-file (in (merge-pathnames "issues.lisp" cmucl-test-runner::*load-path*)
+		      :direction :input
+		      :external-format :iso8859-1)
+    (with-open-file (out "/tmp/output.tst"
+			 :direction :output
+			 :external-format :utf-8
+			 :if-exists :supersede)
       (let ((two-way-stream (make-two-way-stream in out)))
-	(assert-error 'type-error (stream-external-format two-way-stream))))))
+	(assert-equal :default (stream-external-format two-way-stream))))))
+
+;; Test synonym-stream returns the format of the underlying stream.
+(define-test issue.140.3
+    (:tag :issues)
+  (with-open-file (s (merge-pathnames "issues.lisp" cmucl-test-runner::*load-path*)
+		     :direction :input
+		     :external-format :iso8859-1)
+    (let ((syn (make-synonym-stream '*syn-stream*)))
+      (setf syn s)
+      (assert-equal :iso8859-1 (stream-external-format syn)))))



View it on GitLab: https://gitlab.common-lisp.net/cmucl/cmucl/-/commit/145aa085a805aa7f20ea45582fa603536865bb30

-- 
View it on GitLab: https://gitlab.common-lisp.net/cmucl/cmucl/-/commit/145aa085a805aa7f20ea45582fa603536865bb30
You're receiving this email because of your account on gitlab.common-lisp.net.


-------------- next part --------------
An HTML attachment was scrubbed...
URL: <https://mailman.common-lisp.net/pipermail/cmucl-cvs/attachments/20221019/18eb8d55/attachment-0001.html>