Newer
Older
;;; 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)
2007
2008
2009
2010
2011
2012
2013
2014
2015
2016
2017
2018
2019
2020
2021
2022
2023
2024
2025
2026
2027
2028
2029
2030
2031
(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))))))
(declaim (maybe-inline read-char unread-char read-byte listen))
;;;; Case frobbing streams, used by format ~(...~).
(defstruct (case-frob-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
2048
2049
2050
2051
2052
2053
2054
2055
2056
2057
2058
2059
2060
2061
2062
2063
2064
2065
2066
2067
2068
2069
2070
2071
2072
2073
2074
2075
2076
2077
2078
2079
2080
2081
2082
2083
2084
2085
2086
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)
(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)
(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)
(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))))))
2157
2158
2159
2160
2161
2162
2163
2164
2165
2166
2167
2168
2169
2170
2171
2172
2173
2174
2175
2176
2177
2178
2179
2180
(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)
(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))
2198
2199
2200
2201
2202
2203
2204
2205
2206
2207
2208
2209
2210
2211
2212
2213
2214
2215
2216
2217
2218
2219
2220
2221
2222
2223
2224
2225
(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)
(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))))))
2247
2248
2249
2250
2251
2252
2253
2254
2255
2256
2257
2258
2259
2260
2261
2262
2263
2264
2265
2266
2267
(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))))
;;;; 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
;;; 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
text appears before a command, this returns nil, and otherwise it returns
a command."
(let ((cmdp (funcall (lisp-stream-misc stream) stream :get-command)))
(cond (cmdp)
((listen stream)
nil)
(t
;; This waits for input and returns nil when it arrives.
(unread-char (read-char stream) stream)))))
;;; READ-SEQUENCE --
(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))
:format-control (intl:gettext "The stream is not open.")))
((not (input-stream-p stream))
: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)))
(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))))
))
(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)
;;; READ-INTO-SIMPLE-STRING --
(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))))
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.")))
(do ((i start (1+ i))
(s-len (length s)))
((or (>= i s-len)
(>= i end))
i)
(declare (type index i s-len))
(let* ((el (read-char stream nil stream)))
;;; 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*
'(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
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))
#+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
2581
2582
2583
2584
2585
2586
2587
2588
2589
2590
2591
2592
2593
2594
2595
2596
2597
2598
2599
2600
2601
2602
2603
2604
2605
2606
2607
2608
(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)))
)
2610
2611
2612
2613
2614
2615
2616
2617
2618
2619
2620
2621
2622
2623
2624
2625
2626
2627
2628
2629
2630
2631
2632
;; 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
(do ((i start (1+ i))
(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)
;(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))
:format-control (intl:gettext "The stream is not open.")))
((not (output-stream-p stream))
: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)
2738
2739
2740
2741
2742
2743
2744
2745
2746
2747
2748
2749
2750
2751
2752
2753
2754
2755
2756
2757
2758
2759
2760
2761
2762
2763
;;; 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."))))))
2765
2766
2767
2768
2769
2770
2771
2772
2773
2774
2775
2776
2777
2778
2779
2780
2781
2782
2783
2784
2785
2786
2787
2788
2789
2790
2791
2792
2793
2794
2795
2796
(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))))
))
(defun write-string-out (seq stream start end)
(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.")))
2807
2808
2809
2810
2811
2812
2813
2814
2815
2816
2817
2818
2819
2820
2821
2822
2823
2824
2825
2826
2827
2828
(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))
: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)))))
2850
2851
2852
2853
2854
2855
2856
2857
2858
2859
2860
2861
2862
2863
2864
2865
2866
2867
2868
2869
2870
2871
(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))
(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)
(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))
(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) (*))
simple-string)
(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))
(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