From e7dc41bb0e683c1ea329ce720cddd148da6e92e1 Mon Sep 17 00:00:00 2001 From: Juho Snellman Date: Fri, 29 Dec 2006 01:41:11 +0000 Subject: [PATCH] 1.0.1.6: Better error checking for incompatible stream / sequence types in READ-SEQUENCE and WRITE-SEQUENCE. (Patch by Tony Martinez, sbcl-devel 2006-12-05). --- NEWS | 5 ++ src/code/stream.lisp | 60 ++++++++++---------- tests/stream.impure.lisp | 136 ++++++++++++++++++++++++++++++++++++++++++++++ version.lisp-expr | 2 +- 4 files changed, 173 insertions(+), 30 deletions(-) diff --git a/NEWS b/NEWS index dc40d99..0c8219f 100644 --- a/NEWS +++ b/NEWS @@ -5,6 +5,11 @@ changes in sbcl-1.0.2 relative to sbcl-1.0.1: to use. * improvement: support for GBK external format. (thanks to Chun Tian (binghe)) + * bug fix: an error is signaled for attempts to use READ-SEQUENCE + for a (SIGNED-BYTE 8) stream and (UNSIGNED-BYTE 8) vector, or vice versa. + (thanks to Tony Martinez) + * bug fix: the initforms for DEFMETHOD &AUX parameters are only + evaluated once (reported by Kevin Reid) changes in sbcl-1.0.1 relative to sbcl-1.0: * new platform: FreeBSD/x86-64, including support for threading. diff --git a/src/code/stream.lisp b/src/code/stream.lisp index 5d339b7..db0b3e7 100644 --- a/src/code/stream.lisp +++ b/src/code/stream.lisp @@ -1778,6 +1778,15 @@ ;; must be Gray streams FUNDAMENTAL-STREAM (stream-read-sequence stream seq start end))) +(declaim (inline compatible-vector-and-stream-element-types-p)) +(defun compatible-vector-and-stream-element-types-p (vector stream) + (declare (type vector vector) + (type ansi-stream stream)) + (or (and (typep vector '(simple-array (unsigned-byte 8) (*))) + (subtypep (stream-element-type stream) '(unsigned-byte 8))) + (and (typep vector '(simple-array (signed-byte 8) (*))) + (subtypep (stream-element-type stream) '(signed-byte 8))))) + (defun ansi-stream-read-sequence (seq stream start %end) (declare (type sequence seq) (type ansi-stream stream) @@ -1803,27 +1812,24 @@ (setf (first rem) el))))) (vector (with-array-data ((data seq) (offset-start start) (offset-end end)) - (typecase data - ((or (simple-array (unsigned-byte 8) (*)) - (simple-array (signed-byte 8) (*))) - (let* ((numbytes (- end start)) - (bytes-read (read-n-bytes stream data offset-start - numbytes nil))) - (if (< bytes-read numbytes) - (+ start bytes-read) - end))) - (t - (let ((read-function - (if (subtypep (stream-element-type stream) 'character) - #'ansi-stream-read-char - #'ansi-stream-read-byte))) - (do ((i offset-start (1+ i))) - ((>= i offset-end) end) - (declare (type index i)) - (let ((el (funcall read-function stream nil :eof nil))) - (when (eq el :eof) - (return (+ start (- i offset-start)))) - (setf (aref data i) el))))))))))) + (if (compatible-vector-and-stream-element-types-p data stream) + (let* ((numbytes (- end start)) + (bytes-read (read-n-bytes stream data offset-start + numbytes nil))) + (if (< bytes-read numbytes) + (+ start bytes-read) + end)) + (let ((read-function + (if (subtypep (stream-element-type stream) 'character) + #'ansi-stream-read-char + #'ansi-stream-read-byte))) + (do ((i offset-start (1+ i))) + ((>= i offset-end) end) + (declare (type index i)) + (let ((el (funcall read-function stream nil :eof nil))) + (when (eq el :eof) + (return (+ start (- i offset-start)))) + (setf (aref data i) el)))))))))) ;;;; WRITE-SEQUENCE @@ -1874,14 +1880,10 @@ ((>= i offset-end)) (declare (type index i)) (funcall write-function stream (aref data i)))))) - (typecase data - ((or (simple-array (unsigned-byte 8) (*)) - (simple-array (signed-byte 8) (*))) - (if (fd-stream-p stream) - (output-raw-bytes stream data offset-start offset-end) - (output-seq-in-loop))) - (t - (output-seq-in-loop)))))))) + (if (and (fd-stream-p stream) + (compatible-vector-and-stream-element-types-p data stream)) + (output-raw-bytes stream data offset-start offset-end) + (output-seq-in-loop))))))) seq) ;;;; etc. diff --git a/tests/stream.impure.lisp b/tests/stream.impure.lisp index da980b0..78e331b 100644 --- a/tests/stream.impure.lisp +++ b/tests/stream.impure.lisp @@ -178,5 +178,141 @@ (by-out size byte) (by-out size nb)))))) (delete-file file-name))) (loop for size from 2 to 40 do (bin-stream-test :size size :type 'signed-byte)) + +;;; Check READ-SEQUENCE signals a TYPE-ERROR when the sequence can't +;;; contain a stream element. +;;; +;;; These tests check READ-SEQUENCE correctness, not whether the fast +;;; or slow paths are being taken for each element type. To check the +;;; fast or slow paths, trace ANSI-STREAM-READ-BYTE (slow path) and/or +;;; READ-N-BYTES: +;;; +;;; (trace sb-impl::ansi-stream-read-byte sb-impl::read-n-bytes) +;;; +;;; The order should be ANSI-STREAM-READ-BYTE, READ-N-BYTES, +;;; READ-N-BYTES, ANSI-STREAM-READ-BYTE, ANSI-STREAM-READ-BYTE. + +(let ((pathname "read-sequence.data")) + + ;; Create the binary data. + (with-open-file (stream pathname + :direction :output + :if-exists :supersede + :element-type '(unsigned-byte 8)) + (write-byte 255 stream)) + + ;; Check the slow path for generic vectors. + (let ((sequence (make-array 1))) + (with-open-file (stream pathname + :direction :input + :element-type '(unsigned-byte 8)) + (read-sequence sequence stream) + (assert (equalp sequence #(255))))) + + ;; Check the fast path works for (UNSIGNED-BYTE 8) and (SIGNED-BYTE + ;; 8) vectors. + (let ((sequence (make-array 1 :element-type '(unsigned-byte 8)))) + (with-open-file (stream pathname + :direction :input + :element-type '(unsigned-byte 8)) + (read-sequence sequence stream) + (assert (equalp sequence #(255))))) + + (let ((sequence (make-array 1 :element-type '(signed-byte 8)))) + (with-open-file (stream pathname + :direction :input + :element-type '(signed-byte 8)) + (read-sequence sequence stream) + (assert (equalp sequence #(-1))))) + + ;; Check that a TYPE-ERROR is signalled for incompatible (sequence, + ;; stream) pairs. + + (let ((sequence (make-array 1 :element-type '(signed-byte 8)))) + (with-open-file (stream pathname + :direction :input + :element-type '(unsigned-byte 8)) + (handler-case (progn + (read-sequence sequence stream) + (error "READ-SEQUENCE didn't signal an error")) + (type-error (condition) + (assert (= (type-error-datum condition) 255)) + (assert (subtypep (type-error-expected-type condition) + '(signed-byte 8))))))) + + (let ((sequence (make-array 1 :element-type '(unsigned-byte 8)))) + (with-open-file (stream pathname + :direction :input + :element-type '(signed-byte 8)) + (handler-case (progn + (read-sequence sequence stream) + (error "READ-SEQUENCE didn't signal an error")) + (type-error (condition) + (assert (= (type-error-datum condition) -1)) + (assert (subtypep (type-error-expected-type condition) + '(unsigned-byte 8)))))))) + +;;; Check WRITE-SEQUENCE signals a TYPE-ERROR when the stream can't +;;; write a sequence element. +;;; +;;; These tests check WRITE-SEQUENCE correctness, not whether the fast +;;; or slow paths are being taken for each element type. See the +;;; READ-SEQUENCE tests above for more information. +;;; +;;; (trace sb-impl::output-unsigned-byte-full-buffered sb-impl::output-signed-byte-full-buffered sb-impl::output-raw-bytes) + +(let ((pathname "write-sequence.data") + (generic-sequence (make-array 1 :initial-contents '(255))) + (unsigned-sequence (make-array 1 + :element-type '(unsigned-byte 8) + :initial-contents '(255))) + (signed-sequence (make-array 1 + :element-type '(signed-byte 8) + :initial-contents '(-1)))) + ;; Check the slow path for generic vectors. + (with-open-file (stream pathname + :direction :output + :if-exists :supersede + :element-type '(unsigned-byte 8)) + (write-sequence generic-sequence stream)) + + ;; Check the fast path for unsigned and signed vectors. + (with-open-file (stream pathname + :direction :output + :if-exists :supersede + :element-type '(unsigned-byte 8)) + (write-sequence unsigned-sequence stream)) + + (with-open-file (stream pathname + :direction :output + :if-exists :supersede + :element-type '(signed-byte 8)) + (write-sequence signed-sequence stream)) + + ;; Check a TYPE-ERROR is signalled for unsigned and signed vectors + ;; which are incompatible with the stream element type. + (with-open-file (stream pathname + :direction :output + :if-exists :supersede + :element-type '(signed-byte 8)) + (handler-case (progn + (write-sequence unsigned-sequence stream) + (error "WRITE-SEQUENCE didn't signal an error")) + (type-error (condition) + (assert (= (type-error-datum condition) 255)) + (assert (subtypep (type-error-expected-type condition) + '(signed-byte 8)))))) + + (with-open-file (stream pathname + :direction :output + :if-exists :supersede + :element-type '(unsigned-byte 8)) + (handler-case (progn + (write-sequence signed-sequence stream) + (error "WRITE-SEQUENCE didn't signal an error")) + (type-error (condition) + (assert (= (type-error-datum condition) -1)) + (assert (subtypep (type-error-expected-type condition) + '(unsigned-byte 8))))))) ;;; success diff --git a/version.lisp-expr b/version.lisp-expr index 372f495..49adfa8 100644 --- a/version.lisp-expr +++ b/version.lisp-expr @@ -17,4 +17,4 @@ ;;; checkins which aren't released. (And occasionally for internal ;;; versions, especially for internal versions off the main CVS ;;; branch, it gets hairier, e.g. "0.pre7.14.flaky4.13".) -"1.0.1.5" +"1.0.1.6" -- 1.7.10.4