Commit eca0176a authored by rtoy's avatar rtoy
Browse files

Revert change allowing READ/WRITE-SEQUENCE to operate on 1, 2, and 

4-bit vectors.  This breaks some ansi-tests.  READ/WRITE-VECTOR
updated appropriately.

CMUCL can still read and write unidata.bin correctly with these changes.

code/stream.lisp:
o Remove support for 1, 2, and 4-bit vectors for READ-SEQUENCE and
  WRITE-SEQUENCE.

code/fd-stream.lisp:
o Change VECTOR-ELT-WIDTH to return fractional values for arrays of 1,
  2 and 4 bits.  (The result is the number of octets (fractional) per
  element.)

code/stream-vector-io.lisp:
o Replace the calls to READ/WRITE-SEQUENCE with calls to new routines
  that implement the desired operations.
parent c4db47ac

code/fd-stream.lisp

+4 −4
Original line number Diff line number Diff line
@@ -5,7 +5,7 @@ 
;;; Carnegie Mellon University, and has been placed in the public domain.

;;;

(ext:file-comment

  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/fd-stream.lisp,v 1.85.4.1.2.13 2009/05/28 18:52:35 rtoy Exp $")

  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/fd-stream.lisp,v 1.85.4.1.2.14 2009/06/02 18:26:33 rtoy Exp $")

;;;

;;; **********************************************************************

;;;
@@ -97,9 +97,9 @@ 
  (etypecase vector

    ;; (simple-array fixnum (*)) not supported

    ;; (simple-array base-char (*)) treated specially; don't call this

    ((simple-array bit (*)) 1)

    ((simple-array (unsigned-byte 2) (*)) 1)

    ((simple-array (unsigned-byte 4) (*)) 1)

    ((simple-array bit (*)) 1/8)

    ((simple-array (unsigned-byte 2) (*)) 1/4)

    ((simple-array (unsigned-byte 4) (*)) 1/2)

    ((simple-array (signed-byte 8) (*)) 1)

    ((simple-array (unsigned-byte 8) (*)) 1)

    ((simple-array (signed-byte 16) (*)) 2)

code/stream-vector-io.lisp

+63 −23
Original line number Diff line number Diff line
@@ -5,7 +5,7 @@ 
;;; Carnegie Mellon University, and has been placed in the public domain.

;;;

(ext:file-comment

  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/stream-vector-io.lisp,v 1.3.6.5 2009/05/29 16:52:31 rtoy Exp $")

  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/stream-vector-io.lisp,v 1.3.6.6 2009/06/02 18:26:33 rtoy Exp $")

;;;

;;; **********************************************************************

;;;
@@ -128,6 +128,36 @@ 
       (simple-array double-float (*))	; not previously supported by read-sequence

       ))



;; Read from stream into vector.  Start and End are byte offsets into

;; the vector.

(defun read-vector* (vector stream start end)

  (labels ((get-n-bytes (stream data offset numbytes)

	       ;; Handle case of read-n-bytes reading short.

	       (let ((need numbytes))

		 (loop

		     (let ((n (read-n-bytes stream data offset need nil)))

		       (decf need n)

		       (cond ((or (zerop need) ; Complete

				  (zerop n)) ; EOF

			      (return (- numbytes need)))

			     (t (incf offset n)))))))

	     (read-n-x8-bytes (stream data offset-start offset-end byte-size)

	       (let* ((x8-mult (truncate byte-size 8))

		      (numbytes (* (- offset-end offset-start) x8-mult))

		      (bytes-read (get-n-bytes

				   stream

				   data

				   offset-start

				   numbytes)))

		 ;; A check should probably be made here in order to

		 ;; be sure that we actually read the right amount

		 ;; of bytes. (I.e. (truncate bytes-read x8-mult)

		 ;; should return a 0 second value.

		 (if (< bytes-read numbytes)

		     (+ offset-start (truncate bytes-read x8-mult))

		     offset-end))))

    (read-n-x8-bytes stream vector start end 8)))



;;; New versions of READ-VECTOR and WRITE-VECTOR that deal with octet positions

;;; rather than element-positions, for compatibility with Allegro.
@@ -154,14 +184,27 @@ 
  (unless (typep vector '(or string simple-numeric-vector))

    (error "Wrong vector type ~a for read-vector on stream ~a." (type-of vector) stream))

  (let* ((octets-per-element (vector-elt-width vector))

	 ;; read-sequence is parameterized by element position.

	 (next-index (read-sequence vector stream

				    :start (floor (or start 0) octets-per-element)

				    :end (and end (floor end octets-per-element)))))

    (declare (fixnum octets-per-element next-index))

    (endian-swap-vector vector (or start 0) next-index

	 (start-elt (truncate start octets-per-element))

	 (end-octet (or end (truncate (* (length vector) octets-per-element))))

	 (end-elt  (if end

		       (truncate end octets-per-element)

		       (length vector)))

	 (next-index (read-vector* vector stream

				   start

				   end-octet)))

    (endian-swap-vector vector start-elt end-elt

			(endian-swap-value vector endian-swap))

    (* next-index octets-per-element)))

    next-index))



;; Write vector into stream.  Start and End are byte offsets into the

;; vector.

(defun write-vector* (vector stream start end)

  (flet ((write-n-x8-bytes (stream data start end byte-size)

	   (let ((x8-mult (truncate byte-size 8)))

	     (system:output-raw-bytes stream data

				      (* x8-mult start)

				      (* x8-mult end)))))

    (write-n-x8-bytes stream vector start end 8)))



;;; WRITE VECTOR --

;;; returns the next octet-position in vector.
@@ -177,29 +220,26 @@ 
	   (values unsigned-byte))



  (let* ((octets-per-element (vector-elt-width vector))

	 (end (or end (* octets-per-element (length vector))))

	 (start-elt (truncate start octets-per-element))

	 (end-octet (or end (truncate (* (length vector) octets-per-element))))

	 (end-elt (if end

		      (truncate end octets-per-element)

		      (length vector)))

	 (swap-mask (endian-swap-value vector endian-swap))

	 (next-index end))

    (declare (type fixnum swap-mask end octets-per-element next-index))

	 (next-index end-octet))

    (declare (type fixnum swap-mask next-index))

    (cond ((= swap-mask 0)

	   (write-sequence vector stream

			   :start (floor start octets-per-element)

			   :end (and end (floor end octets-per-element))))



	   (write-vector* vector stream start end-octet))

	  (t

	   ;; In a multiprocessing situation, WITHOUT-INTERRUPTS might be required here

	   ;; otherwise the vector could be seen by another process in the modified state.

	   (unless (typep vector '(or string simple-numeric-vector))

	     (error "Wrong vector type ~a for write-vector on stream ~a." (type-of vector)

		    stream))

	   (let ((start-idx (floor start octets-per-element))

		 (end-idx (floor end octets-per-element)))

	     (endian-swap-vector vector start-idx end-idx swap-mask)

	   (endian-swap-vector vector start-elt end-elt swap-mask)

	   (unwind-protect

		  (write-sequence vector stream

				  :start start-idx

				  :end end-idx)

	       (endian-swap-vector vector start-idx end-idx swap-mask)))

		(write-vector* vector stream start end-octet)

	     (endian-swap-vector vector start-elt end-elt swap-mask))

	   vector))

    next-index))

code/stream.lisp

+4 −43
Original line number Diff line number Diff line
@@ -5,7 +5,7 @@ 
;;; Carnegie Mellon University, and has been placed in the public domain.

;;;

(ext:file-comment

  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/stream.lisp,v 1.83.6.4.2.4 2009/05/29 19:15:00 rtoy Exp $")

  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/stream.lisp,v 1.83.6.4.2.5 2009/06/02 18:26:33 rtoy Exp $")

;;;

;;; **********************************************************************

;;;
@@ -2288,9 +2288,6 @@ POSITION: an INTEGER greater than or equal to zero, and less than or 
					; to support simple-stream

					; semantics for read-vector

    character

    bit

    (unsigned-byte 2)

    (unsigned-byte 4)

    (unsigned-byte 8)

    (unsigned-byte 16)

    (unsigned-byte 32)
@@ -2309,10 +2306,7 @@ POSITION: an INTEGER greater than or equal to zero, and less than or 
  ;; quite constrain the array element type.

  ;; (declare (type (simple-array (or unsigned-byte signed-byte) (*)) s))

  ;; (declare (type (simple-array * (*)) s))

  (declare (type (or (simple-array bit (*))

		     (simple-array (unsigned-byte 2) (*))

		     (simple-array (unsigned-byte 4) (*))

		     (simple-array (unsigned-byte 8) (*))

  (declare (type (or (simple-array (unsigned-byte 8) (*))

		     (simple-array (signed-byte 8) (*))

		     (simple-array (unsigned-byte 16) (*))

		     (simple-array (signed-byte 16) (*))
@@ -2391,24 +2385,6 @@ POSITION: an INTEGER greater than or equal to zero, and less than or 
	     ;; operation on a binary stream.

	     (with-array-data ((data s) (offset-start start) (offset-end end))

	       (etypecase data

		 ((simple-array bit (*))

		  (read-n-x8-bytes stream data

				   (ceiling offset-start 8)

				   (ceiling offset-end 8)

				   8))



		 ((simple-array (unsigned-byte 2) (*))

		  (read-n-x8-bytes stream data

				   (ceiling offset-start 4)

				   (ceiling offset-end 4)

				   8))



		 ((simple-array (unsigned-byte 4) (*))

		  (read-n-x8-bytes stream data

				   (ceiling offset-start 2)

				   (ceiling offset-end 2)

				   8))



		 ((simple-array (unsigned-byte 8) (*))

		  (read-n-x8-bytes stream data offset-start offset-end 8))
@@ -2621,10 +2597,7 @@ SEQ: a proper SEQUENCE 
  ;; quite constrain the array element type.

  ;; (declare (type (simple-array (or unsigned-byte signed-byte) (*)) s))

  ;; (declare (type (simple-array * (*)) s))

  (declare (type (or (simple-array bit (*))

		     (simple-array (unsigned-byte 2) (*))

		     (simple-array (unsigned-byte 4) (*))

		     (simple-array (unsigned-byte 8) (*))

  (declare (type (or (simple-array (unsigned-byte 8) (*))

		     (simple-array (signed-byte 8) (*))

		     (simple-array (unsigned-byte 16) (*))

		     (simple-array (signed-byte 16) (*))
@@ -2636,7 +2609,7 @@ SEQ: a proper SEQUENCE 
		     (simple-array double-float (*)))		 

		    seq))

  (when (not (subtypep (stream-element-type stream) 'integer))

    (error 'type-error

    (error 'simple-type-error

	   :datum (elt seq 0)

	   :expected-type (stream-element-type stream)

	   :format-control "Trying to output binary data to a text stream."))
@@ -2650,18 +2623,6 @@ SEQ: a proper SEQUENCE 
			     (start start)

			     (end   end))

	     (etypecase data

	       ((simple-array bit (*))

		(write-n-x8-bytes stream data

				  (ceiling start 8) (ceiling end 8) 8))



	       ((simple-array (unsigned-byte 2) (*))

		(write-n-x8-bytes stream data

				  (ceiling start 4) (ceiling end 4) 8))



	       ((simple-array (unsigned-byte 4) (*))

		(write-n-x8-bytes stream data

				  (ceiling start 2) (ceiling end 2) 8))



	       ((simple-array (unsigned-byte 8) (*))

		(write-n-x8-bytes stream data start end 8))