Skip to content
Snippets Groups Projects
stream.lisp 108 KiB
Newer Older
ram's avatar
ram committed
;;; Indenting-Misc just treats just the :Line-Length message differently.
;;; Indenting-Charpos says the charpos is the charpos of the base stream minus
;;; the stream's indentation.

(defun indenting-misc (stream operation &optional arg1 arg2)
dtc's avatar
dtc committed
  (let ((sub-stream (indenting-stream-stream stream)))
    (if (lisp-stream-p sub-stream)
	(let ((method (lisp-stream-misc sub-stream)))
	  (case operation
	    (:line-length
	     (let ((line-length (funcall method sub-stream operation)))
	       (if line-length
		   (- line-length (indenting-stream-indentation stream)))))
	    (:charpos
	     (let ((charpos (funcall method sub-stream operation)))
	       (if charpos
		   (- charpos (indenting-stream-indentation stream)))))       
	    (t
	     (funcall method sub-stream operation arg1 arg2))))
	;; Fundamental-stream.
	(case operation
	  (:line-length
	   (let ((line-length (stream-line-length sub-stream)))
	     (if line-length
		 (- line-length (indenting-stream-indentation stream)))))
	  (:charpos
	   (let ((charpos (stream-line-column sub-stream)))
	     (if charpos
		 (- charpos (indenting-stream-indentation stream)))))
	  (t
	   (stream-misc-dispatch sub-stream operation arg1 arg2))))))
dtc's avatar
dtc committed

ram's avatar
ram committed

pw's avatar
pw committed
(declaim (maybe-inline read-char unread-char read-byte listen))



;;;; Case frobbing streams, used by format ~(...~).

(defstruct (case-frob-stream
dtc's avatar
dtc committed
	    (:include lisp-stream
		      (:misc #'case-frob-misc))
	    (:constructor %make-case-frob-stream (target out sout)))
  (target (required-argument) :type stream))

(defun make-case-frob-stream (target kind)
  "Returns a stream that sends all output to the stream TARGET, but modifies
   the case of letters, depending on KIND, which should be one of:
     :upcase - convert to upper case.
     :downcase - convert to lower case.
     :capitalize - convert the first letter of words to upper case and the
        rest of the word to lower case.
     :capitalize-first - convert the first letter of the first word to upper
        case and everything else to lower case."
  (declare (type stream target)
	   (type (member :upcase :downcase :capitalize :capitalize-first)
		 kind)
	   (values stream))
  (if (case-frob-stream-p target)
      ;; If we are going to be writing to a stream that already does case
      ;; frobbing, why bother frobbing the case just so it can frob it
      ;; again?
      target
      (multiple-value-bind
	  (out sout)
	  (ecase kind
	    (:upcase
	     (values #'case-frob-upcase-out
		     #'case-frob-upcase-sout))
	    (:downcase
	     (values #'case-frob-downcase-out
		     #'case-frob-downcase-sout))
	    (:capitalize
	     (values #'case-frob-capitalize-out
		     #'case-frob-capitalize-sout))
	    (:capitalize-first
	     (values #'case-frob-capitalize-first-out
		     #'case-frob-capitalize-first-sout)))
	(%make-case-frob-stream target out sout))))

(defun case-frob-misc (stream op &optional arg1 arg2)
  (declare (type case-frob-stream stream))
  (case op
    (:close)
    (t
     (let ((target (case-frob-stream-target stream)))
       (if (lisp-stream-p target)
	   (funcall (lisp-stream-misc target) target op arg1 arg2)
	   (stream-misc-dispatch target op arg1 arg2))))))

(defun case-frob-upcase-out (stream char)
  (declare (type case-frob-stream stream)
ram's avatar
ram committed
	   (type base-char char))
  (let ((target (case-frob-stream-target stream))
	(char (char-upcase char)))
    (if (lisp-stream-p target)
	(funcall (lisp-stream-out target) target char)
	(stream-write-char target char))))

(defun case-frob-upcase-sout (stream str start end)
  (declare (type case-frob-stream stream)
	   (type simple-base-string str)
	   (type index start)
	   (type (or index null) end))
  (let* ((target (case-frob-stream-target stream))
	 (len (length str))
	 (end (or end len))
	 (string (if (and (zerop start) (= len end))
		     (string-upcase str)
		     (nstring-upcase (subseq str start end))))
	 (string-len (- end start)))
    (if (lisp-stream-p target)
	(funcall (lisp-stream-sout target) target string 0 string-len)
	(stream-write-string target string 0 string-len))))

(defun case-frob-downcase-out (stream char)
  (declare (type case-frob-stream stream)
ram's avatar
ram committed
	   (type base-char char))
  (let ((target (case-frob-stream-target stream))
	(char (char-downcase char)))
    (if (lisp-stream-p target)
	(funcall (lisp-stream-out target) target char)
	(stream-write-char target char))))

(defun case-frob-downcase-sout (stream str start end)
  (declare (type case-frob-stream stream)
	   (type simple-base-string str)
	   (type index start)
	   (type (or index null) end))
  (let* ((target (case-frob-stream-target stream))
	 (len (length str))
	 (end (or end len))
	 (string (if (and (zerop start) (= len end))
		     (string-downcase str)
		     (nstring-downcase (subseq str start end))))
	 (string-len (- end start)))
    (if (lisp-stream-p target)
	(funcall (lisp-stream-sout target) target string 0 string-len)
	(stream-write-string target string 0 string-len))))

(defun case-frob-capitalize-out (stream char)
  (declare (type case-frob-stream stream)
ram's avatar
ram committed
	   (type base-char char))
  (let ((target (case-frob-stream-target stream)))
    (cond ((alphanumericp char)
	   (let ((char (char-upcase char)))
	     (if (lisp-stream-p target)
		 (funcall (lisp-stream-out target) target char)
		 (stream-write-char target char)))
	   (setf (case-frob-stream-out stream) #'case-frob-capitalize-aux-out)
	   (setf (case-frob-stream-sout stream)
		 #'case-frob-capitalize-aux-sout))
	  (t
	   (if (lisp-stream-p target)
	       (funcall (lisp-stream-out target) target char)
	       (stream-write-char target char))))))

(defun case-frob-capitalize-sout (stream str start end)
  (declare (type case-frob-stream stream)
	   (type simple-base-string str)
	   (type index start)
	   (type (or index null) end))
  (let* ((target (case-frob-stream-target stream))
	 (str (subseq str start end))
	 (len (length str))
	 (inside-word nil))
    (dotimes (i len)
      (let ((char (schar str i)))
	(cond ((not (alphanumericp char))
	       (setf inside-word nil))
	      (inside-word
	       (setf (schar str i) (char-downcase char)))
	      (t
	       (setf inside-word t)
	       (setf (schar str i) (char-upcase char))))))
    (when inside-word
      (setf (case-frob-stream-out stream)
	    #'case-frob-capitalize-aux-out)
      (setf (case-frob-stream-sout stream)
	    #'case-frob-capitalize-aux-sout))
    (if (lisp-stream-p target)
	(funcall (lisp-stream-sout target) target str 0 len)
	(stream-write-string target str 0 len))))

(defun case-frob-capitalize-aux-out (stream char)
  (declare (type case-frob-stream stream)
ram's avatar
ram committed
	   (type base-char char))
  (let ((target (case-frob-stream-target stream)))
    (cond ((alphanumericp char)
	   (let ((char (char-downcase char)))
	     (if (lisp-stream-p target)
		 (funcall (lisp-stream-out target) target char)
		 (stream-write-char target char))))
	   (if (lisp-stream-p target)
	       (funcall (lisp-stream-out target) target char)
	       (stream-write-char target char))
	   (setf (case-frob-stream-out stream)
		 #'case-frob-capitalize-out)
	   (setf (case-frob-stream-sout stream)
		 #'case-frob-capitalize-sout)))))

(defun case-frob-capitalize-aux-sout (stream str start end)
  (declare (type case-frob-stream stream)
	   (type simple-base-string str)
	   (type index start)
	   (type (or index null) end))
  (let* ((target (case-frob-stream-target stream))
	 (str (subseq str start end))
	 (len (length str))
	 (inside-word t))
    (dotimes (i len)
      (let ((char (schar str i)))
	(cond ((not (alphanumericp char))
	       (setf inside-word nil))
	      (inside-word
	       (setf (schar str i) (char-downcase char)))
	      (t
	       (setf inside-word t)
	       (setf (schar str i) (char-upcase char))))))
    (unless inside-word
      (setf (case-frob-stream-out stream)
	    #'case-frob-capitalize-out)
      (setf (case-frob-stream-sout stream)
	    #'case-frob-capitalize-sout))
    (if (lisp-stream-p target)
	(funcall (lisp-stream-sout target) target str 0 len)
	(stream-write-string target str 0 len))))

(defun case-frob-capitalize-first-out (stream char)
  (declare (type case-frob-stream stream)
ram's avatar
ram committed
	   (type base-char char))
  (let ((target (case-frob-stream-target stream)))
    (cond ((alphanumericp char)
	   (let ((char (char-upcase char)))
	     (if (lisp-stream-p target)
		 (funcall (lisp-stream-out target) target char)
		 (stream-write-char target char)))
	   (setf (case-frob-stream-out stream)
		 #'case-frob-downcase-out)
	   (setf (case-frob-stream-sout stream)
		 #'case-frob-downcase-sout))
	  (t
	   (if (lisp-stream-p target)
	       (funcall (lisp-stream-out target) target char)
	       (stream-write-char target char))))))

(defun case-frob-capitalize-first-sout (stream str start end)
  (declare (type case-frob-stream stream)
	   (type simple-base-string str)
	   (type index start)
	   (type (or index null) end))
  (let* ((target (case-frob-stream-target stream))
	 (str (subseq str start end))
	 (len (length str)))
    (dotimes (i len)
      (let ((char (schar str i)))
	(when (alphanumericp char)
	  (setf (schar str i) (char-upcase char))
	  (do ((i (1+ i) (1+ i)))
	      ((= i len))
	    (setf (schar str i) (char-downcase (schar str i))))
	  (setf (case-frob-stream-out stream)
		#'case-frob-downcase-out)
	  (setf (case-frob-stream-sout stream)
		#'case-frob-downcase-sout)
	  (return))))
    (if (lisp-stream-p target)
	(funcall (lisp-stream-sout target) target str 0 len)
	(stream-write-string target str 0 len))))
chiles's avatar
 
chiles committed


;;;; Public interface from "EXTENSIONS" package.

(defstruct (stream-command (:print-function print-stream-command)
			   (:constructor make-stream-command
					 (name &optional args)))
  (name nil :type symbol)
  (args nil :type list))

(defun print-stream-command (obj str n)
  (declare (ignore n))
  (format str "#<Stream-Cmd ~S>" (stream-command-name obj)))


;;; GET-STREAM-COMMAND -- Public.
;;;
;;; We can't simply call the stream's misc method because nil is an
chiles's avatar
 
chiles committed
;;; ambiguous return value: does it mean text arrived, or does it mean the
;;; stream's misc method had no :get-command implementation.  We can't return
;;; nil until there is text input.  We don't need to loop because any stream
;;; implementing :get-command would wait until it had some input.  If the
;;; LISTEN fails, then we have some random stream we must wait on.
;;;
(defun get-stream-command (stream)
  "This takes a stream and waits for text or a command to appear on it.  If
chiles's avatar
 
chiles committed
   text appears before a command, this returns nil, and otherwise it returns
   a command."
dtc's avatar
dtc committed
  (let ((cmdp (funcall (lisp-stream-misc stream) stream :get-command)))
chiles's avatar
 
chiles committed
    (cond (cmdp)
	  ((listen stream)
	   nil)
	  (t
	   ;; This waits for input and returns nil when it arrives.
	   (unread-char (read-char stream) stream)))))
(defun read-sequence (seq stream &key (start 0) (end nil) partial-fill)
  "Destructively modify SEQ by reading elements from STREAM.

  Seq is bounded by Start and End. Seq is destructively modified by
  copying successive elements into it from Stream. If the end of file
  for Stream is reached before copying all elements of the subsequence,
  then the extra elements near the end of sequence are not updated.

  Argument(s):
  SEQ:	    a proper SEQUENCE
  STREAM:   an input STREAM
  START:    a bounding index designator of type '(INTEGER 0 *)' (default 0)
  END:      a bounding index designator which be NIL or an INTEGER of
	    type '(INTEGER 0 *)' (default NIL)

  Value(s):
  POSITION: an INTEGER greater than or equal to zero, and less than or
	    equal to the length of the SEQ. POSITION is the index of
	    the first element of SEQ that was not updated, which might be
	    less than END because the end of file was reached."

  (declare (type (or list vector) seq))	; could be (type sequence seq)
  (declare (type stream stream))
  (declare (type (integer 0 *) start))	; a list does not have a limit
  (declare (type (or null (integer 0 *)) end))
  (declare (values (integer 0 *)))

  (stream-dispatch stream
    ;; simple-stream
    (stream::%read-sequence stream seq start end partial-fill)
    ;; lisp-stream
    (let ((end (or end (length seq))))
      (declare (type (integer 0 *) start end))

      ;; Just catch some errors earlier than it would be necessary.
      (cond ((not (open-stream-p stream))
emarsden's avatar
 
emarsden committed
	     (error 'simple-stream-error
		    :format-control (intl:gettext "The stream is not open.")))
	    ((not (input-stream-p stream))
emarsden's avatar
 
emarsden committed
	     (error 'simple-stream-error
		    :format-control (intl:gettext "The stream is not open for input.")))
	    ((and seq (>= start end) 0))
	    (t
	     ;; So much for object-oriented programming!
	     (etypecase seq
	       (list
		(read-into-list seq stream start end))
	       (string
		(with-array-data ((seq seq) (start start) (end end))
		  (read-into-string seq stream start end partial-fill)))
	       (simple-array		; We also know that it is a 'vector'.
		(read-into-simple-array seq stream start end))
	       (vector
		(read-into-vector seq stream start end))))))
    ;; fundamental-stream
    (stream-read-sequence stream seq start end)))


;;; READ-INTO-LIST, READ-INTO-LIST-1
;;; Auxiliary functions for READ-SEQUENCE.  Their semantics is pretty
;;; obvious.  Since lists do not have an attached element type, and
;;; since we cannot do a low-level multi-byte read operation on them,
;;; I simply dispatch on the element type of the stream and then rely
;;; on READ-BYTE and READ-CHAR to to the input.
;;;
;;; NOTE: the use of 'endp' will generate a (desired)
;;; 'type-error' if the sequence is not a "proper list".

(defun read-into-list (l stream start end)
  (let ((read-function (if (subtypep (stream-element-type stream) 'character)
			   #'read-char
			   #'read-byte)))
    (read-into-list-1 (nthcdr start l) start end stream read-function)))

#+recursive
(defun read-into-list-1 (l start end stream read-function)
  (declare (type list l))
  (declare (type stream stream))
  (declare (type (integer 0 *) start end))
  (if (or (endp l) (= start end))
      start
      (let* ((el (funcall read-function stream nil stream)))
	(cond ((eq el stream) start)
	      (t (setf (first l) el)
		 (read-into-list-1 (rest l)
				   (1+ start)
				   end
				   stream
				   read-function))))
      ))


#-recursive
(defun read-into-list-1 (l start end stream read-function)
  (declare (type list l))
  (declare (type stream stream))
  (declare (type (integer 0 *) start end))

  ;; The declaration for I may be too restrictive in the case of
  ;; lists.  But then again, it is still a huge number.
  (do ((lis l (rest lis))
       (i start (1+ i)))
      ((or (endp lis)
	   (>= i end))
       i)
    (declare (type list lis))
    (declare (type index i))
    (let* ((el (funcall read-function stream nil stream)))
      (when (eq el stream)
toy's avatar
toy committed
      (setf (first lis) el))))
(defun read-into-simple-string (s stream start end)
  (declare (type simple-string s))
  (declare (type stream stream))
  (declare (type index start end))
  (unless (subtypep (stream-element-type stream) 'character)
    (error 'type-error
	   :datum (read-char stream nil #\Null)
	   :expected-type (stream-element-type stream)
	   :format-control (intl:gettext "Trying to read characters from a binary stream.")))
  ;; Let's go as low level as it seems reasonable.
  (let* ((numbytes (- end start))
	 (total-bytes 0))
    ;; read-n-bytes may return fewer bytes than requested, so we need
    ;; to keep trying.
    (loop while (plusp numbytes) do
	  (let ((bytes-read (system:read-n-bytes stream s start numbytes nil)))
	    (when (zerop bytes-read)
	      (return-from read-into-simple-string start))
	    (incf total-bytes bytes-read)
	    (incf start bytes-read)
	    (decf numbytes bytes-read)))
;;; read-into-simple-string hacked to allow (unsigned-byte 8) stream-element-type
;;; For some reason applying this change to read-into-simple-string causes CMUCL to die.
#-unicode
(defun read-into-string (s stream start end partial-fill)
  (declare (type simple-string s))
  (declare (type stream stream))
  (declare (type index start end))
  (unless (or (subtypep (stream-element-type stream) 'character)
	      (equal (stream-element-type stream) '(unsigned-byte 8)))
    (error 'type-error
	   :datum (read-char stream nil #\Null)
	   :expected-type (stream-element-type stream)
	   :format-control (intl:gettext "Trying to read characters from a binary stream.")))
  ;; Let's go as low level as it seems reasonable.
  (let* ((numbytes (- end start))
	 (total-bytes 0))
    ;; read-n-bytes may return fewer bytes than requested, so we need
    ;; to keep trying.
    (loop while (plusp numbytes) do
      (let ((bytes-read (system:read-n-bytes stream s start numbytes nil)))
	(incf total-bytes bytes-read)
	(incf start bytes-read)
	(decf numbytes bytes-read)
	(when (or partial-fill (zerop bytes-read))
	  (return-from read-into-string start))))
#+unicode
(defun read-into-string (s stream start end partial-fill)
  (declare (type string s))
  (declare (type stream stream))
  (declare (type index start end))
  (unless (subtypep (stream-element-type stream) 'character)
    (error 'type-error
	   :datum (read-char stream nil #\Null)
	   :expected-type (stream-element-type stream)
	   :format-control (intl:gettext "Trying to read characters from a binary stream.")))
       (s-len (length s)))
      ((or (>= i s-len)
	   (>= i end))
       i)
    (declare (type index i s-len))
    (let* ((el (read-char stream nil stream)))
toy's avatar
toy committed
      (declare (type (or character stream) el))
      (when (eq el stream)
toy's avatar
toy committed
      (setf (char s i) (the character el)))))

;;; READ-INTO-SIMPLE-ARRAY --
;;; We definitively know that we are really reading into a vector.

;;; *read-into-simple-array-recognized-types* --
;;;
;;; Note the new feature :extended-binary-streams.
;;; Up to 18a, CMUCL has a wired in limitation to treat only 8-bits
;;; word binary streams.  'fd-read-n-bytes' is associated to a binary
;;; stream only if the fd-stream has binary type size of 1 (i.e. 1
;;; 8-bits byte).  This is reflected also in the size of the input
;;; buffers.

(defparameter *read-into-simple-array-recognized-types*
rtoy's avatar
rtoy committed
  '(base-char				; Character types are needed
					; to support simple-stream
					; semantics for read-vector
    character
    (unsigned-byte 8)
    (unsigned-byte 16)
    (unsigned-byte 32)
    (signed-byte 8)
    (signed-byte 16)
    (signed-byte 32)
    single-float             ; not previously supported by read-sequence
    double-float             ; not previously supported by read-sequence
    ))

(defun read-into-simple-array (s stream start end)
  ;; The complex declaration is needed to make Python behave.
  ;; The first declaration does not work because of type promotion
  ;; which effectively excises the etypecase below.
  ;; The second declaration does not quite work because it does not
  ;; 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 (unsigned-byte 8) (*))
		     (simple-array (signed-byte 8) (*))
		     (simple-array (unsigned-byte 16) (*))
		     (simple-array (signed-byte 16) (*))
		     (simple-array (unsigned-byte 32) (*))
		     (simple-array (signed-byte 32) (*))
		     (simple-array (unsigned-byte *) (*))
		     (simple-array (signed-byte *) (*))
		     (simple-array single-float (*))  ; not previously supported by read-sequence
		     (simple-array double-float (*))  ; not previously supported by read-sequence
		     simple-bit-vector)
		 s))

  (declare (type stream stream))
  (declare (type index start end))
  (let ((stream-et (stream-element-type stream)))
    ;; What is the purpose of this explicit test for characters?  It
    ;; prevents reading a string-stream into a vector, like the
    ;; example in the CLHS.
	  ((subtypep (stream-element-type stream) 'character)
	   (error 'type-error
		  :datum (read-byte stream nil 0)
		  :expected-type (stream-element-type stream) ; Bogus?!?
		  :format-control
		  (intl:gettext "Trying to read binary data from a text stream.")))

	  ;; Let's go as low level as it seems reasonable.
	  ((not (member stream-et
			*read-into-simple-array-recognized-types*
			:test #'equal))
rtoy's avatar
rtoy committed
	   #+nil
	   (format t ">>> Reading vector from binary stream of type ~S~%"
		   stream-et)
	   
	   ;; We resort to the READ-BYTE based operation.
	   (read-into-vector s stream start end))

	  ((/= vm:byte-bits 8)
	   ;; We must resort to the READ-BYTE based operation
	   ;; also in this case. XXX Unreachable code note.
	   (read-into-vector s stream start end))

	  ;; Otherwise we can do something more interesting.
	  (t
	   (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)))
		)
	     ;; According to the definition of OPEN and READ-N-BYTES,
	     ;; these are the only cases when we can use the multi-byte read
	     ;; operation on a binary stream.
	     (with-array-data ((data s) (offset-start start) (offset-end end))
	       (etypecase data
		 ((simple-array (unsigned-byte 8) (*))
		  (read-n-x8-bytes stream data offset-start offset-end 8))
	    
		 ((simple-array (unsigned-byte 16) (*))
		  (read-n-x8-bytes stream data offset-start offset-end 16))
	    
		 ((simple-array (unsigned-byte 32) (*))
		  (read-n-x8-bytes stream data offset-start offset-end 32))

		 ((simple-array (signed-byte 8) (*))
		  (read-n-x8-bytes stream data offset-start offset-end 8))

		 ((simple-array (signed-byte 16) (*))
		  (read-n-x8-bytes stream data offset-start offset-end 16))

		 ((simple-array (signed-byte 32) (*))
		  (read-n-x8-bytes stream data offset-start offset-end 32))

		 ;; not previously supported by read-sequence
		 ((simple-array single-float (*))
		  (read-n-x8-bytes stream data offset-start offset-end 32))

		 ;; not previously supported by read-sequence
		 ((simple-array double-float (*))
		  (read-n-x8-bytes stream data offset-start offset-end 64))

		 ;; Otherwise we resort to the READ-BYTE based operation.
		 (simple-bit-vector
		  (read-into-vector s stream start end))
		 ((simple-array (unsigned-byte *) (*))
		  (read-into-vector s stream start end))
		 ((simple-array (signed-byte *) (*))
		  (read-into-vector s stream start end)))))))))

;;; READ-INTO-VECTOR --

(defun read-into-vector (v stream start end)
  (declare (type index start end))
  (declare (type stream stream))
  (declare (type vector v))
  (let* ((stream-et (stream-element-type stream))
	 (read-function (if (subtypep stream-et 'character)
			    #'read-char
	 (a-len (length v)))
	((or (>= i a-len) (>= i end))
	 i)
      (declare (type index i a-len))
      (let* ((el (funcall read-function stream nil stream)))
	(when (eq el stream)
toy's avatar
toy committed
	(setf (aref v i) el)))))
;(declaim (end-block))			; READ-SEQUENCE block


(declaim (start-block write-sequence))

;;; WRITE-SEQUENCE
;;; Why the type specifier '(list <type>)' was left out of the standard
;;; will always puzzle me.

(defun write-sequence (seq stream &key (start 0) (end nil))
  "Writes the elements of the Seq bounded by Start and End to Stream.

  Argument(s):
  SEQ:     a proper SEQUENCE
  STREAM:  an output STREAM
  START:   a bounding index designator of type '(INTEGER 0 *)' (default 0)
  END:     a bounding index designator which be NIL or an INTEGER of
           type '(INTEGER 0 *)' (default NIL)

  Value(s):
  SEQ:	a proper SEQUENCE
"
  (declare (type (or list vector) seq))
  (declare (type stream stream))
  (declare (type (integer 0 *) start))	; a list does not have a limit
  (declare (type (or null (integer 0 *)) end))
  (declare (values (or list vector)))
  (stream-dispatch stream
    ;; simple-stream
    (stream::%write-sequence stream seq start end)
    ;; lisp-stream
    (let ((end (or end (length seq))))
      (declare (type (integer 0 *) start end))

      ;; Just catch some errors earlier than it would be necessary.
      (cond ((not (open-stream-p stream))
emarsden's avatar
 
emarsden committed
	     (error 'simple-stream-error
		    :format-control (intl:gettext "The stream is not open.")))
	    ((not (output-stream-p stream))
emarsden's avatar
 
emarsden committed
	     (error 'simple-stream-error
		    :format-control (intl:gettext "The stream is not open for output.")))
	    ((and seq (>= start end)) seq)
	    (t
	     ;; So much for object-oriented programming!
	     ;; Note: order of type clauses is very important.  As a
	     ;; matter of fact it is patterned after the class
	     ;; precedence list of each of the types listed.
	     (etypecase seq
	       (list
		(write-list-out seq stream start end))
	       (string
		(with-array-data ((seq seq) (start start) (end end))
		  (write-string-out seq stream start end)))
	       (simple-vector		; This is necessary because of
					; the underlying behavior of
					; OUTPUT-RAW-BYTES.  A vector
					; produced by VECTOR has
					; element-type T in CMUCL.
		(write-vector-out seq stream start end))
	       (simple-array		; We know it is also a vector!
		(write-simple-array-out seq stream start end))
	       (vector
		(write-vector-out seq stream start end))))))
    ;; fundamental-stream
    (stream-write-sequence stream seq start end))
  seq)


;;; The following functions operate under one - possibly wrong -
;;; assumption.  CMUCL seems smart enough to collapse arrays of
;;; characters onto strings (i.e. it does the right thing.)  Hence,
;;; when each function is called, we are pretty safe in assuming that
;;; the stream element type and the sequence element type are what we
;;; expect.

;;; WRITE-LIST-OUT

(defun write-list-out (seq stream start end)
  ;; I wish I could say
  ;; (declare (type (list (or character (unsigned-byte 32))) seq))
  (declare (type list seq))
  (declare (type (integer 0 *) start end))
  (declare (type stream stream))

  (flet ((check-list-element-types (l type)
	   (declare (list l))
	   (dolist (e l)
	     (unless (typep e type)
	       (error 'type-error
		      :datum e
		      :expected-type type
		      :format-control
		      (intl:gettext "Trying to output an element of unproper type to a stream."))))))
    (let ((stream-et (stream-element-type stream)))

      (check-list-element-types seq stream-et)
      (let ((write-function (if (subtypep stream-et 'character)
				#'write-char
				#'write-byte)))

	;; According to Rob MacLachlan <Rob_MacLachlan@ADDER.SLISP.CS.CMU.EDU>
	;; It would make sense to write everything to a string and
	;; then call 'write-string' no matter what the type of the
	;; stream.
	;; This implementation should be something like:
	;;
	;; (let ((temp-string (format nil "~{~W~}" (subseq seq start end))))
	;;    (write-string temp-string stream)
	;;
	;; Of course this seems a little expensive and a better
	;; iterative solution could be used instead.
	;;
	;; Anyway.  For the time being, the loop seems ok, given that
	;; lists will most likely not used that much for buffered I/O.
	
	(do ((lis (nthcdr start seq) (rest lis))
	     (i start (1+ i))
	     )
	    ((or (endp lis) (>= i end)) seq)
	  (declare (type list lis))
	  (declare (type index i))
	  (funcall write-function (first lis) stream))))
    ))


;;; WRITE-STRING-OUT

(defun write-string-out (seq stream start end)
  (declare (type simple-string seq))
  (when (and (not (subtypep (stream-element-type stream) 'character))
	     (not (equal (stream-element-type stream) '(unsigned-byte 8))))
    (error 'type-error
	   :datum seq
	   :expected-type (stream-element-type stream)
	   :format-control (intl:gettext "Trying to output a string to a binary stream.")))
  (write-string seq stream :start start :end end)
  seq)


;;; WRITE-SIMPLE-ARRAY-OUT, WRITE-VECTOR-OUT --
;;; The main difference is that for simple vectors, we can use the
;;; very efficient SYSTEM:OUTPUT-RAW-BYTES on FD-STREAMS.
;;; (OUTPUT-RAW-BYTES seems to assume to receive a SIMPLE-ARRAY.)
;;;
;;; Again, Rob MacLachlan suggestion would be to first write
;;; everything out to a string and then to use WRITE-STRING. (See comment
;;; within WRITE-LIST-OUT.)

(defun write-simple-array-out (seq stream start end)
   ;; The complex declaration is needed to make Python behave.
  ;; The first declaration does not work because of type promotion
  ;; which effectively excises the etypecase below.
  ;; The second declaration does not quite work because it does not
  ;; 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 (unsigned-byte 8) (*))
		     (simple-array (signed-byte 8) (*))
		     (simple-array (unsigned-byte 16) (*))
		     (simple-array (signed-byte 16) (*))
		     (simple-array (unsigned-byte 32) (*))
		     (simple-array (signed-byte 32) (*))
		     (simple-array (unsigned-byte *) (*))
		     (simple-array (signed-byte *) (*))
		     (simple-array single-float (*))
		     (simple-array double-float (*)))		 
		    seq))
  (when (not (subtypep (stream-element-type stream) 'integer))
    (error 'simple-type-error
	   :datum (elt seq 0)
	   :expected-type (stream-element-type stream)
	   :format-control (intl:gettext "Trying to output binary data to a text stream.")))
  (cond ((system:fd-stream-p stream)
	 (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)))))
	   (with-array-data ((data seq)
			     (start start)
			     (end   end))
	     (etypecase data
	       ((simple-array (unsigned-byte 8) (*))
		(write-n-x8-bytes stream data start end 8))

	       ((simple-array (unsigned-byte 16) (*))
		(write-n-x8-bytes stream data start end 16))

	       ((simple-array (unsigned-byte 32) (*))
		(write-n-x8-bytes stream data start end 32))

	       ((simple-array (signed-byte 8) (*))
		(write-n-x8-bytes stream data start end 8))

	       ((simple-array (signed-byte 16) (*))
		(write-n-x8-bytes stream data start end 16))

	       ((simple-array (signed-byte 32) (*))
		(write-n-x8-bytes stream data start end 32))

	       ((simple-array single-float (*))
		(write-n-x8-bytes stream data start end 32))

	       ((simple-array double-float (*))
		(write-n-x8-bytes stream data start end 64))

	       ;; Otherwise we resort to the READ-BYTE based operation.
	       ((simple-array (unsigned-byte *) (*))
		(write-vector-out seq stream start end))

	       ((simple-array (signed-byte *) (*))
		(write-vector-out seq stream start end))
emarsden's avatar
emarsden committed

	       (bit-vector
		(write-vector-out seq stream start end))
	       )
	     seq)))

	(t (do ((i start (1+ i))
		(sv-len (length seq))
		)
	       ((or (>= i end) (>= i sv-len)) seq)
	     (declare (type index i sv-len))
	     (write-byte (aref seq i) stream)))))

(defun write-vector-out (seq stream start end)
emarsden's avatar
 
emarsden committed
  (let ((write-function
         (if (subtypep (stream-element-type stream) 'character)
             #'write-char
             #'write-byte)))
    (do ((i start (1+ i))
         (a-len (length seq))
         )
        ((or (>= i end) (>= i a-len)) seq)
      (declare (type index i a-len))
      (funcall write-function (aref seq i) stream))))

(declaim (end-block))			; WRITE-SEQUENCE block.
#||
;;; READ-SEQUENCE -- Public
;;;
(defun read-sequence (seq stream &key (start 0) (end nil))
  _N"Destructively modify SEQ by reading elements from STREAM.
  SEQ is bounded by START and END. SEQ is destructively modified by
  copying successive elements into it from STREAM. If the end of file
  for STREAM is reached before copying all elements of the subsequence,
  then the extra elements near the end of sequence are not updated, and
  the index of the next element is returned."
  (declare (type sequence seq)
	   (type stream stream)
	   (type index start)
	   (type sequence-end end)
	   (values index))
  (when (not (lisp::lisp-stream-p stream))
pw's avatar
pw committed
     (return-from read-sequence (stream-read-sequence seq stream start end)))
  (let ((end (or end (length seq))))
    (declare (type index end))
    (etypecase seq
      (list
       (let ((read-function
	      (if (subtypep (stream-element-type stream) 'character)
		  #'read-char
		  #'read-byte)))
	 (do ((rem (nthcdr start seq) (rest rem))
	      (i start (1+ i)))
	     ((or (endp rem) (>= i end)) i)
	   (declare (type list rem)
		    (type index i))
	   (let ((el (funcall read-function stream nil :eof)))
	     (when (eq el :eof)
	       (return i))
	     (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 ((required (- end start)))
	      (loop
	       (let ((bytes-read (system:read-n-bytes stream data offset-start
						      required nil)))
		 (cond ((= bytes-read required)
			(return end))
		       ((zerop bytes-read)
			(return (- end required)))
		       (t
			(decf required bytes-read)
			(incf offset-start bytes-read)))))))
	   (t
	    (let ((read-function
		   (if (subtypep (stream-element-type stream) 'character)
		       #'read-char
		       #'read-byte)))
	      (do ((i offset-start (1+ i)))
		  ((>= i offset-end) end)
		(declare (type index i))
		(let ((el (funcall read-function stream nil :eof)))
		  (when (eq el :eof)
		    (return (+ start (- i offset-start))))
		  (setf (aref data i) el)))))))))))

;;; WRITE-SEQUENCE -- Public
;;;
(defun write-sequence (seq stream &key (start 0) (end nil))
  _N"Write the elements of SEQ bounded by START and END to STREAM."
  (declare (type sequence seq)
	   (type stream stream)
	   (type index start)
	   (type sequence-end end)
	   (values sequence))
  (when (not (lisp::lisp-stream-p stream))
pw's avatar
pw committed
    (return-from write-sequence (stream-write-sequence seq stream start end)))
  (let ((end (or end (length seq))))
    (declare (type index start end))
    (etypecase seq
      (list
       (let ((write-function
	      (if (subtypep (stream-element-type stream) 'character)
		  #'write-char
		  #'write-byte)))
	 (do ((rem (nthcdr start seq) (rest rem))
	      (i start (1+ i)))
	     ((or (endp rem) (>= i end)) seq)
	   (declare (type list rem)
		    (type index i))
	   (funcall write-function (first rem) stream))))
      (string
dtc's avatar
dtc committed
       (write-string* seq stream start end))