From 890140aaa5d44a4e0962ccb7f708026662bcb8ca Mon Sep 17 00:00:00 2001 From: Jan Moringen Date: Wed, 13 Apr 2016 16:01:21 +0200 Subject: [PATCH] Fix STREAM-ELEMENT-MODE for non-fd ANSI-STREAMs The previous strategy, converting the stream element-type to an element mode for all non-fd streams, didn't work: there are non-fd ANSI streams which return element-type CHARACTER even if they actually are bivalent. --- src/code/fd-stream.lisp | 2 + src/code/stream.lisp | 26 ++- src/code/target-stream.lisp | 9 +- tests/bivalent-stream.impure.lisp | 342 ++++++++++++++++++++++---------------- 4 files changed, 229 insertions(+), 150 deletions(-) rewrite tests/bivalent-stream.impure.lisp (62%) diff --git a/src/code/fd-stream.lisp b/src/code/fd-stream.lisp index 7d75e4e00..f54f9d18d 100644 --- a/src/code/fd-stream.lisp +++ b/src/code/fd-stream.lisp @@ -2077,6 +2077,8 @@ (finish-fd-stream-output fd-stream)) (:element-type (fd-stream-element-type fd-stream)) + (:element-mode + (fd-stream-element-mode fd-stream)) (:external-format (fd-stream-external-format fd-stream)) (:interactive-p diff --git a/src/code/stream.lisp b/src/code/stream.lisp index d5bae2398..afa1c28c2 100644 --- a/src/code/stream.lisp +++ b/src/code/stream.lisp @@ -768,6 +768,9 @@ (finish-output stream)) (:element-type (stream-element-type stream)) + (:element-mode + (stream-element-type-stream-element-mode + (stream-element-type stream))) (:stream-external-format (stream-external-format stream)) (:interactive-p @@ -845,6 +848,9 @@ (if last (stream-element-type (car last)) t))) + (:element-mode + (awhen (last streams) + (stream-element-mode (car it)))) (:external-format (let ((last (last streams))) (if last @@ -999,7 +1005,13 @@ (let ((in-type (stream-element-type in)) (out-type (stream-element-type out))) (if (equal in-type out-type) - in-type `(and ,in-type ,out-type)))) + in-type + `(and ,in-type ,out-type)))) + (:element-mode + (let ((in-mode (stream-element-mode in)) + (out-mode (stream-element-mode out))) + (when (equal in-mode out-mode) + in-mode))) (:close (set-closed-flame stream)) (t @@ -1988,10 +2000,14 @@ benefit of the function GET-OUTPUT-STREAM-STRING." (defun stream-element-mode (stream) (declare (type stream stream)) - (if (fd-stream-p stream) - (fd-stream-element-mode stream) - (stream-element-type-stream-element-mode - (stream-element-type stream)))) + (cond + ((fd-stream-p stream) + (fd-stream-element-mode stream)) + ((and (ansi-stream-p stream) + (funcall (ansi-stream-misc stream) stream :element-mode))) + (t + (stream-element-type-stream-element-mode + (stream-element-type stream))))) (defun stream-compute-io-function (stream stream-element-mode sequence-element-type diff --git a/src/code/target-stream.lisp b/src/code/target-stream.lisp index d7f18c647..15043dc6c 100644 --- a/src/code/target-stream.lisp +++ b/src/code/target-stream.lisp @@ -126,7 +126,13 @@ (let ((in-type (stream-element-type in)) (out-type (stream-element-type out))) (if (equal in-type out-type) - in-type `(and ,in-type ,out-type)))) + in-type + `(and ,in-type ,out-type)))) + (:element-mode + (let ((in-mode (stream-element-mode in)) + (out-mode (stream-element-mode out))) + (when (equal in-mode out-mode) + in-mode))) (:close (set-closed-flame stream)) (:peek-char @@ -171,4 +177,3 @@ (if (ansi-stream-p out) (funcall (ansi-stream-misc out) out operation arg1 arg2) (stream-misc-dispatch out operation arg1 arg2))))))) - diff --git a/tests/bivalent-stream.impure.lisp b/tests/bivalent-stream.impure.lisp dissimilarity index 62% index d1b1aa2bd..6b702ab25 100644 --- a/tests/bivalent-stream.impure.lisp +++ b/tests/bivalent-stream.impure.lisp @@ -1,143 +1,199 @@ -;;;; This file is for testing bivalent stream functionality, using -;;;; test machinery which might have side effects (e.g. executing -;;;; DEFUN, writing files). Note that the tests here might reach into -;;;; unexported functionality, and should not be used as a guide for -;;;; users. - -;;;; This software is part of the SBCL system. See the README file for -;;;; more information. -;;;; -;;;; While most of SBCL is derived from the CMU CL system, the test -;;;; files (like this one) were written from scratch after the fork -;;;; from CMU CL. -;;;; -;;;; This software is in the public domain and is provided with -;;;; absolutely no warranty. See the COPYING and CREDITS files for -;;;; more information. - -;;; Test character decode restarts. - -(defun bvector (&rest elements) - (make-array (length elements) :element-type '(unsigned-byte 8) - :initial-contents elements)) - -(defun cvector (&rest elements) - (make-array (length elements) :element-type 'character - :initial-contents elements)) - -(defmacro with-bivalent-io-setup ((file) &body body) - (let ((file-var (gensym))) - `(let ((,file-var ,file)) - (unwind-protect - (macrolet - ((with-stream ((stream &rest args &key &allow-other-keys) &body body) - `(with-open-file (,stream ,',file-var ,@args - :element-type :default :external-format :utf-8) - ,@body))) - ,@body) - (when (probe-file ,file-var) - (delete-file ,file-var)))))) - -(defun assert-roundtrip (write-call read-call result expected) - (unless (equalp result expected) - (error "~@" - write-call read-call result expected))) - -(with-test (:name (stream :bivalent :roundtrip :element)) - (let ((pairs '((write-byte 65 read-char #\A) - (write-char #\B read-byte 66) - (write-byte #xe0 read-byte #xe0) - (write-char #\C read-char #\C)))) - (with-bivalent-io-setup ("bivalent-stream-test.txt") - (with-stream (stream :direction :output :if-exists :supersede) - (loop :for (function argument) :in pairs - :do (funcall function argument stream))) - - (with-stream (stream :direction :input) - (loop :for (write-function write-arg read-function expected) :in pairs - :do (let ((result (funcall read-function stream))) - (assert-roundtrip `(,write-function ,write-arg) - `(,read-function) - result expected))))))) - -(with-test (:name (stream :bivalent :roundtrip sequence)) - (let ((pairs - `(;; List source and destination sequence. - ((65) () ,(list 0) () 1 (#\A)) - ((#\B) () ,(list 0) () 1 (#\B)) - ((#x7e) () ,(list 0) () 1 (,(code-char #x7e))) - ((66 #\C) () ,(list 0 0) () 2 (#\B #\C)) - ((#\B 67) () ,(list 0 0) () 2 (#\B #\C)) - ((#\B #\C) (:start 1) ,(list 0) () 1 (#\C)) - ((#\B #\C) (:end 1) ,(list 0) () 1 (#\B)) - ((#\B) () ,(list 0 0) (:start 1) 2 (0 #\B)) - ((#\B) () ,(list 0 0) (:end 1) 1 (#\B 0)) - ;; Vector source sequence. - (#(65) () ,(list 0) () 1 (#\A)) - (#(#\B) () ,(list 0) () 1 (#\B)) - (#(#x7e) () ,(list 0) () 1 (,(code-char #x7e))) - (#(66 #\C) () ,(list 0 0) () 2 (#\B #\C)) - (#(#\B 67) () ,(list 0 0) () 2 (#\B #\C)) - (#(#\B #\C) (:end 1) ,(list 0) () 1 (#\B)) - (#(#\B #\C) (:start 1) ,(list 0) () 1 (#\C)) - ;; String source sequence. - ("A" () ,(list 0) () 1 (#\A)) - ("B" () ,(list 0) () 1 (#\B)) - ("BC" (:start 1) ,(list 0) () 1 (#\C)) - ("BC" (:end 1) ,(list 0) () 1 (#\B)) - ;; Generic vector destination sequence. - (#(65) () ,(vector 0) () 1 #(#\A)) - (#(#\B) () ,(vector 0) () 1 #(#\B)) - (#(#x7e) () ,(vector 0) () 1 #(,(code-char #x7e))) - (#(66 #\C) () ,(vector 0 0) () 2 #(#\B #\C)) - (#(#\B 67) () ,(vector 0 0) () 2 #(#\B #\C)) - (#(#\B) () ,(vector 0 0) (:end 1) 1 #(#\B 0)) - (#(#\B) () ,(vector 0 0) (:start 1) 2 #(0 #\B)) - ;; Byte-vector destination sequence. - (#(65) () ,(bvector 0) () 1 #(65)) - (#(#\B) () ,(bvector 0) () 1 #(66)) - (#(#xe0) () ,(bvector 0) () 1 #(#xe0)) - (#(66 #\C) () ,(bvector 0 0) () 2 #(66 67)) - (#(#\B 67) () ,(bvector 0 0) () 2 #(66 67)) - (#(#\B) () ,(bvector 0 0) (:end 1) 1 #(66 0)) - (#(#\B) () ,(bvector 0 0) (:start 1) 2 #(0 66)) - ;; Character-vector destination sequence. - (#(65) () ,(cvector #\_) () 1 #(#\A)) - (#(#\B) () ,(cvector #\_) () 1 #(#\B)) - (#(#x7e) () ,(cvector #\_) () 1 #(,(code-char #x7e))) - (#(66 #\C) () ,(cvector #\_ #\_) () 2 #(#\B #\C)) - (#(#\B 67) () ,(cvector #\_ #\_) () 2 #(#\B #\C)) - (#(#\B) () ,(cvector #\_ #\_) (:end 1) 1 #(#\B #\_)) - (#(#\B) () ,(cvector #\_ #\_) (:start 1) 2 #(#\_ #\B)) - ;; String destination sequence. - (#(65) () ,(make-string 1) () 1 "A") - (#(#\B) () ,(make-string 1) () 1 "B") - (#(66 #\C) () ,(make-string 2) () 2 "BC") - (#(#\B 67) () ,(make-string 2) () 2 "BC") - (#(#\B) () ,(make-string 2) (:end 1) 1 ,(coerce '(#\B #\Nul) 'string)) - (#(#\B) () ,(make-string 2) (:start 1) 2 ,(coerce '(#\Nul #\B) 'string))))) - (with-bivalent-io-setup ("bivalent-stream-test.txt") - ;; Write sequence. - (with-stream (stream :direction :output :if-exists :supersede) - (loop :for (sequence args) :in pairs - :do (apply #'write-sequence sequence stream args))) - ;; Read sequence and compare. - (with-stream (stream :direction :input) - (loop :for (source source-args into into-args - expected-position expected-sequence) :in pairs - :do (let ((into/old (copy-seq into)) - (position (apply #'read-sequence into stream into-args))) - (unless (= position expected-position) - (error "~@<~S returned ~S, expected ~S.~@:>" - `(read-sequence ,into/old ,@into-args) - position expected-position)) - (assert-roundtrip `(write-sequence ,source ,@source-args) - `(read-sequence ,into/old ,@into-args) - into expected-sequence))))))) - -(with-test (:name (stream :bivalent :no-unknown-type-condition)) - (assert-no-signal - (with-bivalent-io-setup ("bivalent-stream-test.txt") - (with-stream (stream :direction :output :if-exists :supersede))) - sb-kernel:parse-unknown-type)) +;;;; This file is for testing bivalent stream functionality, using +;;;; test machinery which might have side effects (e.g. executing +;;;; DEFUN, writing files). Note that the tests here might reach into +;;;; unexported functionality, and should not be used as a guide for +;;;; users. + +;;;; This software is part of the SBCL system. See the README file for +;;;; more information. +;;;; +;;;; While most of SBCL is derived from the CMU CL system, the test +;;;; files (like this one) were written from scratch after the fork +;;;; from CMU CL. +;;;; +;;;; This software is in the public domain and is provided with +;;;; absolutely no warranty. See the COPYING and CREDITS files for +;;;; more information. + +;;; Test character decode restarts. + +(defun bvector (&rest elements) + (make-array (length elements) :element-type '(unsigned-byte 8) + :initial-contents elements)) + +(defun cvector (&rest elements) + (make-array (length elements) :element-type 'character + :initial-contents elements)) + +(defmacro with-bivalent-io-setup ((file) &body body) + (let ((file-var (gensym))) + `(let ((,file-var ,file)) + (unwind-protect + (macrolet + ((with-stream ((stream &rest args &key &allow-other-keys) &body body) + `(with-open-file (,stream ,',file-var ,@args + :element-type :default :external-format :utf-8) + ,@body))) + ,@body) + (when (probe-file ,file-var) + (delete-file ,file-var)))))) + +(defun assert-roundtrip (write-call read-call result expected) + (unless (equalp result expected) + (error "~@" + write-call read-call result expected))) + +(defvar *read/write-sequence-pairs* + `(;; List source and destination sequence. + ((65) () ,(list 0) () 1 (#\A)) + ((#\B) () ,(list 0) () 1 (#\B)) + ((#x7e) () ,(list 0) () 1 (,(code-char #x7e))) + ((66 #\C) () ,(list 0 0) () 2 (#\B #\C)) + ((#\B 67) () ,(list 0 0) () 2 (#\B #\C)) + ((#\B #\C) (:start 1) ,(list 0) () 1 (#\C)) + ((#\B #\C) (:end 1) ,(list 0) () 1 (#\B)) + ((#\B) () ,(list 0 0) (:start 1) 2 (0 #\B)) + ((#\B) () ,(list 0 0) (:end 1) 1 (#\B 0)) + ;; Vector source sequence. + (#(65) () ,(list 0) () 1 (#\A)) + (#(#\B) () ,(list 0) () 1 (#\B)) + (#(#x7e) () ,(list 0) () 1 (,(code-char #x7e))) + (#(66 #\C) () ,(list 0 0) () 2 (#\B #\C)) + (#(#\B 67) () ,(list 0 0) () 2 (#\B #\C)) + (#(#\B #\C) (:end 1) ,(list 0) () 1 (#\B)) + (#(#\B #\C) (:start 1) ,(list 0) () 1 (#\C)) + ;; String source sequence. + ("A" () ,(list 0) () 1 (#\A)) + ("B" () ,(list 0) () 1 (#\B)) + ("BC" (:start 1) ,(list 0) () 1 (#\C)) + ("BC" (:end 1) ,(list 0) () 1 (#\B)) + ;; Generic vector destination sequence. + (#(65) () ,(vector 0) () 1 #(#\A)) + (#(#\B) () ,(vector 0) () 1 #(#\B)) + (#(#x7e) () ,(vector 0) () 1 #(,(code-char #x7e))) + (#(66 #\C) () ,(vector 0 0) () 2 #(#\B #\C)) + (#(#\B 67) () ,(vector 0 0) () 2 #(#\B #\C)) + (#(#\B) () ,(vector 0 0) (:end 1) 1 #(#\B 0)) + (#(#\B) () ,(vector 0 0) (:start 1) 2 #(0 #\B)) + ;; Byte-vector destination sequence. + (#(65) () ,(bvector 0) () 1 #(65)) + (#(#\B) () ,(bvector 0) () 1 #(66)) + (#(#xe0) () ,(bvector 0) () 1 #(#xe0)) + (#(66 #\C) () ,(bvector 0 0) () 2 #(66 67)) + (#(#\B 67) () ,(bvector 0 0) () 2 #(66 67)) + (#(#\B) () ,(bvector 0 0) (:end 1) 1 #(66 0)) + (#(#\B) () ,(bvector 0 0) (:start 1) 2 #(0 66)) + ;; Character-vector destination sequence. + (#(65) () ,(cvector #\_) () 1 #(#\A)) + (#(#\B) () ,(cvector #\_) () 1 #(#\B)) + (#(#x7e) () ,(cvector #\_) () 1 #(,(code-char #x7e))) + (#(66 #\C) () ,(cvector #\_ #\_) () 2 #(#\B #\C)) + (#(#\B 67) () ,(cvector #\_ #\_) () 2 #(#\B #\C)) + (#(#\B) () ,(cvector #\_ #\_) (:end 1) 1 #(#\B #\_)) + (#(#\B) () ,(cvector #\_ #\_) (:start 1) 2 #(#\_ #\B)) + ;; String destination sequence. + (#(65) () ,(make-string 1) () 1 "A") + (#(#\B) () ,(make-string 1) () 1 "B") + (#(66 #\C) () ,(make-string 2) () 2 "BC") + (#(#\B 67) () ,(make-string 2) () 2 "BC") + (#(#\B) () ,(make-string 2) (:end 1) 1 ,(coerce '(#\B #\Nul) 'string)) + (#(#\B) () ,(make-string 2) (:start 1) 2 ,(coerce '(#\Nul #\B) 'string)))) + +(defun do-writes (stream pairs) + (loop :for (sequence args) :in pairs + :do (apply #'write-sequence sequence stream args))) + +(defun do-reads (stream pairs) + (loop :for (source source-args into into-args + expected-position expected-sequence) :in pairs + :do (let ((into/old (copy-seq into)) + (position (apply #'read-sequence into stream into-args))) + (unless (= position expected-position) + (error "~@<~S returned ~S, expected ~S.~@:>" + `(read-sequence ,into/old ,@into-args) + position expected-position)) + (assert-roundtrip `(write-sequence ,source ,@source-args) + `(read-sequence ,into/old ,@into-args) + into expected-sequence)))) + +(with-test (:name (stream :bivalent :roundtrip :element)) + (let ((pairs '((write-byte 65 read-char #\A) + (write-char #\B read-byte 66) + (write-byte #xe0 read-byte #xe0) + (write-char #\C read-char #\C)))) + (with-bivalent-io-setup ("bivalent-stream-test.txt") + (with-stream (stream :direction :output :if-exists :supersede) + (loop :for (function argument) :in pairs + :do (funcall function argument stream))) + + (with-stream (stream :direction :input) + (loop :for (write-function write-arg read-function expected) :in pairs + :do (let ((result (funcall read-function stream))) + (assert-roundtrip `(,write-function ,write-arg) + `(,read-function) + result expected))))))) + +(with-test (:name (stream :bivalent :roundtrip sequence)) + (with-bivalent-io-setup ("bivalent-stream-test.txt") + ;; Write sequence. + (with-stream (stream :direction :output :if-exists :supersede) + (do-writes stream *read/write-sequence-pairs*)) + ;; Read sequence and compare. + (with-stream (stream :direction :input) + (do-reads stream *read/write-sequence-pairs*)))) + +(defvar *synonym-stream-stream*) +(with-test (:name (stream :bivalent :roundtrip sequence synonym-stream)) + (with-bivalent-io-setup ("bivalent-stream-test.txt") + ;; Write sequence. + (with-stream (stream :direction :output :if-exists :supersede) + (let ((*synonym-stream-stream* stream) + (stream (make-synonym-stream '*synonym-stream-stream*))) + (do-writes stream *read/write-sequence-pairs*))) + ;; Read sequence and compare. + (with-stream (stream :direction :input) + (let ((*synonym-stream-stream* stream) + (stream (make-synonym-stream '*synonym-stream-stream*))) + (do-reads stream *read/write-sequence-pairs*))))) + +(with-test (:name (stream :bivalent :roundtrip sequence broadcast-stream)) + (with-bivalent-io-setup ("bivalent-stream-test.txt") + ;; Write sequence. + (with-stream (stream :direction :output :if-exists :supersede) + (let ((stream (make-broadcast-stream stream))) + (do-writes stream *read/write-sequence-pairs*))) + ;; Read sequence and compare. + (with-stream (stream :direction :input) + (do-reads stream *read/write-sequence-pairs*)))) + +(with-test (:name (stream :bivalent :roundtrip sequence echo-stream)) + (with-bivalent-io-setup ("bivalent-stream-test.txt") + ;; Write sequence. + (with-stream (stream :direction :output :if-exists :supersede) + (do-writes stream *read/write-sequence-pairs*)) + ;; Read sequence and compare. + (with-stream (stream :direction :input) + (let ((stream (make-echo-stream stream (make-broadcast-stream)))) + (do-reads stream *read/write-sequence-pairs*))))) + +(with-test (:name (stream :bivalent :roundtrip sequence two-way-stream)) + (with-bivalent-io-setup ("bivalent-stream-test.txt") + ;; Write sequence. + (with-stream (stream :direction :output :if-exists :supersede) + (let ((stream (make-two-way-stream (make-concatenated-stream) stream))) + (do-writes stream *read/write-sequence-pairs*))) + ;; Read sequence and compare. + (with-stream (stream :direction :input) + (let ((stream (make-two-way-stream stream (make-broadcast-stream)))) + (do-reads stream *read/write-sequence-pairs*))))) + +(with-test (:name (stream :bivalent synonym-stream *standard-input* *standard-output*)) + (assert (eq (sb-impl::stream-element-mode *standard-input*) :bivalent)) + (assert (eq (sb-impl::stream-element-mode *standard-output*) :bivalent))) + +(with-test (:name (stream :bivalent :no-unknown-type-condition)) + (assert-no-signal + (with-bivalent-io-setup ("bivalent-stream-test.txt") + (with-stream (stream :direction :output :if-exists :supersede))) + sb-kernel:parse-unknown-type)) -- 2.11.4.GIT