/[cmucl]/src/code/stream.lisp
ViewVC logotype

Diff of /src/code/stream.lisp

Parent Directory Parent Directory | Revision Log Revision Log | View Patch Patch

revision 1.83.6.4 by rtoy, Fri May 30 19:30:36 2008 UTC revision 1.102 by rtoy, Wed Jun 29 00:55:04 2011 UTC
# Line 18  Line 18 
18  ;;;  ;;;
19  (in-package "LISP")  (in-package "LISP")
20    
21    (intl:textdomain "cmucl")
22    
23  (export '(broadcast-stream make-broadcast-stream broadcast-stream-streams  (export '(broadcast-stream make-broadcast-stream broadcast-stream-streams
24            synonym-stream make-synonym-stream synonym-stream-symbol            synonym-stream make-synonym-stream synonym-stream-symbol
25            concatenated-stream make-concatenated-stream            concatenated-stream make-concatenated-stream
# Line 66  Line 68 
68    (error 'simple-type-error    (error 'simple-type-error
69           :datum stream           :datum stream
70           :expected-type '(satisfies input-stream-p)           :expected-type '(satisfies input-stream-p)
71           :format-control "~S is not an input stream."           :format-control (intl:gettext "~S is not an input stream.")
72           :format-arguments (list stream)))           :format-arguments (list stream)))
73  (defun ill-out-any (stream &rest ignore)  (defun ill-out-any (stream &rest ignore)
74    (declare (ignore ignore))    (declare (ignore ignore))
75    (error 'simple-type-error    (error 'simple-type-error
76           :datum stream           :datum stream
77           :expected-type '(satisfies output-stream-p)           :expected-type '(satisfies output-stream-p)
78           :format-control "~S is not an output stream."           :format-control (intl:gettext "~S is not an output stream.")
79           :format-arguments (list stream)))           :format-arguments (list stream)))
80  (defun ill-in (stream &rest ignore)  (defun ill-in (stream &rest ignore)
81    (declare (ignore ignore))    (declare (ignore ignore))
82    (error 'simple-type-error    (error 'simple-type-error
83           :datum stream           :datum stream
84           :expected-type '(satisfies input-stream-p)           :expected-type '(satisfies input-stream-p)
85           :format-control "~S is not a character input stream."           :format-control (intl:gettext "~S is not a character input stream.")
86           :format-arguments (list stream)))           :format-arguments (list stream)))
87  (defun ill-out (stream &rest ignore)  (defun ill-out (stream &rest ignore)
88    (declare (ignore ignore))    (declare (ignore ignore))
89    (error 'simple-type-error    (error 'simple-type-error
90           :datum stream           :datum stream
91           :expected-type '(satisfies output-stream-p)           :expected-type '(satisfies output-stream-p)
92           :format-control "~S is not a character output stream."           :format-control (intl:gettext "~S is not a character output stream.")
93           :format-arguments (list stream)))           :format-arguments (list stream)))
94  (defun ill-bin (stream &rest ignore)  (defun ill-bin (stream &rest ignore)
95    (declare (ignore ignore))    (declare (ignore ignore))
96    (error 'simple-type-error    (error 'simple-type-error
97           :datum stream           :datum stream
98           :expected-type '(satisfies input-stream-p)           :expected-type '(satisfies input-stream-p)
99           :format-control "~S is not a binary input stream."           :format-control (intl:gettext "~S is not a binary input stream.")
100           :format-arguments (list stream)))           :format-arguments (list stream)))
101  (defun ill-n-bin (stream &rest ignore)  (defun ill-n-bin (stream &rest ignore)
102    (declare (ignore ignore))    (declare (ignore ignore))
103    (error 'simple-type-error    (error 'simple-type-error
104           :datum stream           :datum stream
105           :expected-type '(satisfies input-stream-p)           :expected-type '(satisfies input-stream-p)
106           :format-control "~S is not a binary input stream ~           :format-control (intl:gettext "~S is not a binary input stream ~
107                            or does not support multi-byte read operations."                            or does not support multi-byte read operations.")
108           :format-arguments (list stream)))           :format-arguments (list stream)))
109  (defun ill-bout (stream &rest ignore)  (defun ill-bout (stream &rest ignore)
110    (declare (ignore ignore))    (declare (ignore ignore))
111    (error 'simple-type-error    (error 'simple-type-error
112           :datum stream           :datum stream
113           :expected-type '(satisfies output-stream-p)           :expected-type '(satisfies output-stream-p)
114           :format-control "~S is not a binary output stream."           :format-control (intl:gettext "~S is not a binary output stream.")
115           :format-arguments (list stream)))           :format-arguments (list stream)))
116  (defun closed-flame (stream &rest ignore)  (defun closed-flame (stream &rest ignore)
117    (declare (ignore ignore))    (declare (ignore ignore))
118    (error "~S is closed." stream))    (error (intl:gettext "~S is closed.") stream))
119  (defun do-nothing (&rest ignore)  (defun do-nothing (&rest ignore)
120    (declare (ignore ignore)))    (declare (ignore ignore)))
121  (defun no-gray-streams (stream)  (defun no-gray-streams (stream)
122    (error 'simple-type-error    (error 'simple-type-error
123           :datum stream           :datum stream
124           :expected-type 'stream           :expected-type 'stream
125           :format-control "~S is an unsupported Gray stream."           :format-control (intl:gettext "~S is an unsupported Gray stream.")
126           :format-arguments (list stream)))           :format-arguments (list stream)))
127    
128  (defun %print-stream (structure stream d)  (defun %print-stream (structure stream d)
# Line 279  Line 281 
281      (error 'simple-type-error      (error 'simple-type-error
282             :datum stream             :datum stream
283             :expected-type 'stream:simple-stream             :expected-type 'stream:simple-stream
284             :format-control "Can't set interactive flag on ~S."             :format-control (intl:gettext "Can't set interactive flag on ~S.")
285             :format-arguments (list stream))))             :format-arguments (list stream))))
286    
287  (defun stream-external-format (stream)  (defun stream-external-format (stream)
# Line 289  Line 291 
291      ;; simple-stream      ;; simple-stream
292      (stream::%stream-external-format stream)      (stream::%stream-external-format stream)
293      ;; lisp-stream      ;; lisp-stream
294      :default      (typecase stream
295          #+unicode
296          (fd-stream (fd-stream-external-format stream))
297          (synonym-stream (stream-external-format
298                           (symbol-value (synonym-stream-symbol stream))))
299          (t :default))
300      ;; fundamental-stream      ;; fundamental-stream
301      :default))      :default))
302    
303    ;; This is only used while building; it's reimplemented in
304    ;; fd-stream-extfmt.lisp
305    #+unicode
306    (defun %set-fd-stream-external-format (stream extfmt &optional (updatep t))
307      extfmt)
308    
309    
310    ;; This is only used while building; it's reimplemented in
311    ;; fd-stream-extfmt.lisp
312    (defun (setf stream-external-format) (extfmt stream)
313      (declare (ignore stream))
314      extfmt)
315    
316  (defun close (stream &key abort)  (defun close (stream &key abort)
317    "Closes the given Stream.  No more I/O may be performed, but inquiries    "Closes the given Stream.  No more I/O may be performed, but inquiries
318    may still be made.  If :Abort is non-nil, an attempt is made to clean    may still be made.  If :Abort is non-nil, an attempt is made to clean
# Line 344  Line 364 
364        (t        (t
365         (let ((res (funcall (lisp-stream-misc stream) stream         (let ((res (funcall (lisp-stream-misc stream) stream
366                             :file-position nil)))                             :file-position nil)))
367             ;; For Unicode, the LISP-STREAM-MISC function handles
368             ;; everything, so we can just return the result.
369             #-unicode
370           (when res           (when res
371             (- res (- in-buffer-length (lisp-stream-in-index stream)))))))))             (- res (- in-buffer-length (lisp-stream-in-index stream))))
372             #+unicode
373             res)))))
374    
375    
376  ;;; File-Length  --  Public  ;;; File-Length  --  Public
# Line 434  Line 459 
459        ;; simple-stream        ;; simple-stream
460        (stream::%unread-char stream character)        (stream::%unread-char stream character)
461        ;; lisp-stream        ;; lisp-stream
462          #-unicode
463        (let ((index (1- (lisp-stream-in-index stream)))        (let ((index (1- (lisp-stream-in-index stream)))
464              (buffer (lisp-stream-in-buffer stream)))              (buffer (lisp-stream-in-buffer stream)))
465          (declare (fixnum index))          (declare (fixnum index))
466          (when (minusp index) (error "Nothing to unread."))          (when (minusp index) (error (intl:gettext "Nothing to unread.")))
467          (cond (buffer          (cond (buffer
468                 (setf (aref buffer index) (char-code character))                 (setf (aref buffer index) (char-code character))
469                 (setf (lisp-stream-in-index stream) index))                 (setf (lisp-stream-in-index stream) index))
470                (t                (t
471                 (funcall (lisp-stream-misc stream) stream                 (funcall (lisp-stream-misc stream) stream
472                          :unread character))))                          :unread character))))
473          #+unicode
474          (let ((sbuf (lisp-stream-string-buffer stream))
475                (ibuf (lisp-stream-in-buffer stream)))
476            (cond (sbuf
477                   (let ((index (1- (lisp-stream-string-index stream))))
478                     (when (minusp index)
479                       (error (intl:gettext "Nothing to unread.")))
480                     (setf (aref sbuf index) character)
481                     (setf (lisp-stream-string-index stream) index)))
482                  (ibuf
483                   (let ((index (1- (lisp-stream-in-index stream))))
484                     (when (minusp index)
485                       (error (intl:gettext "Nothing to unread.")))
486                     ;; This only works for iso8859-1!
487                     (setf (aref ibuf index) (char-code character))
488                     (setf (lisp-stream-in-index stream) index)))
489                  (t
490                   (funcall (lisp-stream-misc stream) stream
491                            :unread character))))
492        ;; fundamental-stream        ;; fundamental-stream
493        (stream-unread-char stream character)))        (stream-unread-char stream character)))
494    nil)    nil)
# Line 501  Line 546 
546                    eof-detected-form))                    eof-detected-form))
547             ,char-var)             ,char-var)
548            (t            (t
549             (error "Impossible case reached in PEEK-CHAR")))))             (error (intl:gettext "Impossible case reached in PEEK-CHAR"))))))
550    
551  (defun peek-char (&optional (peek-type nil) (stream *standard-input*)  (defun peek-char (&optional (peek-type nil) (stream *standard-input*)
552                              (eof-errorp t) eof-value recursive-p)                              (eof-errorp t) eof-value recursive-p)
# Line 515  Line 560 
560      (error 'simple-type-error      (error 'simple-type-error
561             :datum peek-type             :datum peek-type
562             :expected-type '(or character boolean)             :expected-type '(or character boolean)
563             :format-control "~@<bad PEEK-TYPE=~S, ~_expected ~S~:>"             :format-control (intl:gettext "~@<bad PEEK-TYPE=~S, ~_expected ~S~:>")
564             :format-arguments (list peek-type '(or character boolean))))             :format-arguments (list peek-type '(or character boolean))))
565    (let ((stream (in-synonym-of stream)))    (let ((stream (in-synonym-of stream)))
566      (if (typep stream 'echo-stream)      (if (typep stream 'echo-stream)
# Line 655  Line 700 
700  ;;;  ;;;
701  ;;;    This function is called by the fast-read-char expansion to refill the  ;;;    This function is called by the fast-read-char expansion to refill the
702  ;;; in-buffer for text streams.  There is definitely an in-buffer, and hence  ;;; in-buffer for text streams.  There is definitely an in-buffer, and hence
703  ;;; myst be an n-bin method.  ;;; must be an n-bin method.
704  ;;;  ;;;
705  (defun fast-read-char-refill (stream eof-errorp eof-value)  (defun fast-read-char-refill (stream eof-errorp eof-value)
706    (let* ((ibuf (lisp-stream-in-buffer stream))    (let* ((ibuf (lisp-stream-in-buffer stream))
# Line 678  Line 723 
723             (setf (lisp-stream-in-index stream) (1+ start))             (setf (lisp-stream-in-index stream) (1+ start))
724             (code-char (aref ibuf start))))))             (code-char (aref ibuf start))))))
725    
726    ;;; FAST-READ-CHAR-STRING-REFILL  --  Interface
727    ;;;
728    ;;;    This function is called by the fast-read-char expansion to refill the
729    ;;; string-buffer for text streams.  There is definitely a
730    ;;; string-buffer and an in-buffer, which implies there must be an
731    ;;; n-bin method.
732    ;;;
733    #+unicode
734    (defun fast-read-char-string-refill (stream eof-errorp eof-value)
735      ;; Like fast-read-char-refill, but we don't need or want the
736      ;; in-buffer-extra.
737      (let* ((ibuf (lisp-stream-in-buffer stream))
738             (index (lisp-stream-in-index stream))
739             (in-length (fd-stream-in-length stream)))
740        (declare (type (integer 0 #.in-buffer-length) index in-length))
741    
742        #+(or debug-frc-sr)
743        (progn
744          (format t "index = ~A~%" index)
745          (format t "in-length = ~A~%" in-length)
746          (format t "ibuf before = ~A~%" ibuf)
747          (format t "sbuf before = ~S~%" (subseq (lisp-stream-string-buffer stream) 0
748                                                 (lisp-stream-string-buffer-len stream))))
749    
750        ;; For debugging, clear out the stuff we've already read so we can
751        ;; see what's happening.
752        #+(or debug-frc-sr)
753        (fill ibuf 0 :start 0 :end index)
754    
755        ;; Copy the stuff we haven't read from in-buffer to the beginning
756        ;; of the buffer.
757        (if (< index in-length)
758            (replace ibuf ibuf
759                     :start1 0
760                     :start2 index :end2 in-length)
761            (setf index in-length))
762    
763        ;; For debugging, clear out the stuff we've already read so we can
764        ;; see what's happening.
765        #+(or debug-frc-sr)
766        (when (< index (1- in-buffer-length))
767          (fill ibuf 0 :start (1+ index) :end in-buffer-length))
768    
769        (setf index (- in-length index))
770    
771        #+(or debug-frc-sr)
772        (format t "ibuf after  = ~A~%" ibuf)
773    
774        (flet
775            ((get-octets (start)
776               (funcall (lisp-stream-n-bin stream) stream
777                        ibuf start
778                        (- in-buffer-length start)
779                        nil))
780             (handle-eof ()
781               ;; Nothing left in the stream, so update our pointers to
782               ;; indicate we've read everything and call the stream-in
783               ;; function so that we do the right thing for eof.
784               (setf (lisp-stream-in-index stream) in-buffer-length)
785               (setf (lisp-stream-string-index stream)
786                     (lisp-stream-string-buffer-len stream))
787               (funcall (lisp-stream-in stream) stream eof-errorp eof-value)))
788          (let ((count (get-octets index)))
789            (declare (type (integer 0 #.in-buffer-length) count))
790    
791            #+(or debug-frc-sr)
792            (progn
793              (format t "count = ~D~%" count)
794              (format t "new ibuf = ~A~%" ibuf))
795    
796            (cond ((zerop count)
797                   (handle-eof))
798                  (t
799                   (let ((sbuf (lisp-stream-string-buffer stream))
800                         (slen (lisp-stream-string-buffer-len stream)))
801                     (declare (simple-string sbuf)
802                              (type (integer 0 #.(1+ in-buffer-length)) slen)
803                              (optimize (speed 3)))
804    
805                     ;; Update in-length.  This is needed if we change the
806                     ;; external-format of the stream because we need to
807                     ;; know how many octets are valid (in case
808                     ;; end-of-file was reached)
809                     (setf (fd-stream-in-length stream) (+ count index))
810                     #+(or debug-frc-sr)
811                     (format t "in-length = ~D~%" (fd-stream-in-length stream))
812    
813                     #+(or debug-frc-sr)
814                     (format t "slen = ~A~%" slen)
815    
816                     ;; Copy the last read character to the beginning of the
817                     ;; buffer to support unreading.
818                     (when (plusp slen)
819                       (setf (schar sbuf 0) (schar sbuf (1- slen))))
820    
821                     #+(or debug-frc-sr)
822                     (progn
823                       (format t "sbuf[0] = ~S~%" (schar sbuf 0))
824                       (format t "index = ~S~%" index))
825    
826    
827                     ;; Convert all the octets, including the ones that we
828                     ;; haven't processed yet and the ones we just read in.
829                     (flet
830                         ((convert-buffer ()
831                            (multiple-value-bind (s char-count octet-count new-state)
832                                (stream::octets-to-string-counted
833                                 ibuf
834                                 (fd-stream-octet-count stream)
835                                 :start 0
836                                 :end (fd-stream-in-length stream)
837                                 :state (fd-stream-oc-state stream)
838                                 :string sbuf
839                                 :s-start 1
840                                 :external-format (fd-stream-external-format stream)
841                                 :error (fd-stream-octets-to-char-error stream))
842                              (declare (ignore s)
843                                       (type (integer 0 #.in-buffer-length) char-count octet-count))
844                              #+(or debug-frc-sr)
845                              (progn
846                                (format t "char-count = ~A~%" char-count)
847                                (format t "octet-count = ~A~%" octet-count)
848                                (format t "in-index = ~A~%" (lisp-stream-in-index stream)))
849                              (when (> char-count 0)
850                                (setf (fd-stream-oc-state stream) new-state)
851                                (setf (lisp-stream-string-buffer-len stream) (1+ char-count))
852                                (setf (lisp-stream-string-index stream) 2)
853                                (setf (lisp-stream-in-index stream) octet-count)
854                                #+(or debug-frc-sr)
855                                (progn
856                                  (format t "new in-index = ~A~%" (lisp-stream-in-index stream))
857                                  (format t "new sbuf = ~S~%"
858                                          (subseq sbuf 0 (1+ char-count))))
859                                (schar sbuf 1)))))
860                       (let ((out (convert-buffer)))
861                         (or out
862                             ;; There weren't enough octets to convert at
863                             ;; least one character.  Try to read some more
864                             ;; octets and try again.  (If we still fail,
865                             ;; what should we do then?  Currently, just
866                             ;; just return NIL and let other parts of Lisp
867                             ;; catch that.)
868                             ;;
869                             ;; The in buffer holds unread octets up to
870                             ;; index in-length.  So start reading octets there.
871                             (let* ((index (fd-stream-in-length stream))
872                                    (count (get-octets index)))
873                               (declare (type (integer 0 #.in-buffer-length) count index))
874                               (cond ((zerop count)
875                                      (handle-eof))
876                                     (t
877                                      ;; Adjust in-length to the total
878                                      ;; number of octets that are now in
879                                      ;; the buffer.
880                                      (setf (fd-stream-in-length stream) (+ count index))
881                                      (convert-buffer))))))))))))))
882    
883  ;;; FAST-READ-BYTE-REFILL  --  Interface  ;;; FAST-READ-BYTE-REFILL  --  Interface
884  ;;;  ;;;
# Line 898  Line 1099 
1099             (ignore arg2))             (ignore arg2))
1100    (case operation    (case operation
1101      (:listen      (:listen
1102       ;; Return true is input available, :eof for eof-of-file, otherwise Nil.       ;; Return true if input available, :eof for end-of-file, otherwise Nil.
1103       (let ((char (stream-read-char-no-hang stream)))       (let ((char (stream-read-char-no-hang stream)))
1104         (when (characterp char)         (when (characterp char)
1105           (stream-unread-char stream char))           (stream-unread-char stream char))
# Line 1032  streams." Line 1233  streams."
1233    (format stream "#<Synonym Stream to ~S>" (synonym-stream-symbol s)))    (format stream "#<Synonym Stream to ~S>" (synonym-stream-symbol s)))
1234    
1235  (setf (documentation 'make-synonym-stream 'function)  (setf (documentation 'make-synonym-stream 'function)
1236    "Returns a stream which performs its operations on the stream which is the    _N"Returns a stream which performs its operations on the stream which is the
1237     value of the dynamic variable named by Symbol.")     value of the dynamic variable named by Symbol.")
1238    
1239  ;;; The output simple output methods just call the corresponding method  ;;; The output simple output methods just call the corresponding method
# Line 1403  output to Output-stream" Line 1604  output to Output-stream"
1604            (two-way-stream-output-stream s)))            (two-way-stream-output-stream s)))
1605    
1606  (setf (documentation 'make-echo-stream 'function)  (setf (documentation 'make-echo-stream 'function)
1607    "Returns a bidirectional stream which gets its input from Input-Stream and    _N"Returns a bidirectional stream which gets its input from Input-Stream and
1608     sends its output to Output-Stream.  In addition, all input is echoed to     sends its output to Output-Stream.  In addition, all input is echoed to
1609     the output stream")     the output stream")
1610    
# Line 1496  output to Output-stream" Line 1697  output to Output-stream"
1697      (:listen (or (/= (the fixnum (string-input-stream-current stream))      (:listen (or (/= (the fixnum (string-input-stream-current stream))
1698                       (the fixnum (string-input-stream-end stream)))                       (the fixnum (string-input-stream-end stream)))
1699                   :eof))                   :eof))
1700      (:element-type 'base-char)))      (:element-type 'base-char)
1701        (:close
1702         (set-closed-flame stream))))
1703    
1704  (defun make-string-input-stream (string &optional  (defun make-string-input-stream (string &optional
1705                                          (start 0) (end (length string)))                                          (start 0) (end (length string)))
# Line 1705  output to Output-stream" Line 1908  output to Output-stream"
1908    (indentation 0))    (indentation 0))
1909    
1910  (setf (documentation 'make-indenting-stream 'function)  (setf (documentation 'make-indenting-stream 'function)
1911   "Returns an output stream which indents its output by some amount.")   _N"Returns an output stream which indents its output by some amount.")
1912    
1913  (defun %print-indenting-stream (s stream d)  (defun %print-indenting-stream (s stream d)
1914    (declare (ignore s d))    (declare (ignore s d))
# Line 2054  output to Output-stream" Line 2257  output to Output-stream"
2257    
2258    
2259  ;;; READ-SEQUENCE --  ;;; READ-SEQUENCE --
 ;;; Note:  the multi-byte operation SYSTEM:READ-N-BYTES operates on  
 ;;; subtypes of SIMPLE-ARRAY.  Hence the distinction between simple  
 ;;; and non simple input functions.  
2260    
2261  (defun read-sequence (seq stream &key (start 0) (end nil) partial-fill)  (defun read-sequence (seq stream &key (start 0) (end nil) partial-fill)
2262    "Destructively modify SEQ by reading elements from STREAM.    "Destructively modify SEQ by reading elements from STREAM.
2263  SEQ is bounded by START and END. SEQ is destructively modified by  
2264  copying successive elements into it from STREAM. If the end of file    Seq is bounded by Start and End. Seq is destructively modified by
2265  for STREAM is reached before copying all elements of the subsequence,    copying successive elements into it from Stream. If the end of file
2266  then the extra elements near the end of sequence are not updated.    for Stream is reached before copying all elements of the subsequence,
2267      then the extra elements near the end of sequence are not updated.
2268  Argument(s):  
2269  SEQ:    a proper SEQUENCE    Argument(s):
2270  STREAM: an input STREAM    SEQ:      a proper SEQUENCE
2271  START:  a bounding index designator of type '(INTEGER 0 *)' (default 0)    STREAM:   an input STREAM
2272  END:    a bounding index designator which be NIL or an INTEGER of    START:    a bounding index designator of type '(INTEGER 0 *)' (default 0)
2273          type '(INTEGER 0 *)' (default NIL)    END:      a bounding index designator which be NIL or an INTEGER of
2274                type '(INTEGER 0 *)' (default NIL)
2275  Value(s):  
2276  POSITION: an INTEGER greater than or equal to zero, and less than or    Value(s):
2277            equal to the length of the SEQ. POSITION is the index of    POSITION: an INTEGER greater than or equal to zero, and less than or
2278            the first element of SEQ that was not updated, which might be              equal to the length of the SEQ. POSITION is the index of
2279            less than END because the end of file was reached."              the first element of SEQ that was not updated, which might be
2280                less than END because the end of file was reached."
2281    
2282    (declare (type (or list vector) seq)) ; could be (type sequence seq)    (declare (type (or list vector) seq)) ; could be (type sequence seq)
2283    (declare (type stream stream))    (declare (type stream stream))
# Line 2095  POSITION: an INTEGER greater than or equ Line 2296  POSITION: an INTEGER greater than or equ
2296        (cond ((not (open-stream-p stream))        (cond ((not (open-stream-p stream))
2297               (error 'simple-stream-error               (error 'simple-stream-error
2298                      :stream stream                      :stream stream
2299                      :format-control "The stream is not open."))                      :format-control (intl:gettext "The stream is not open.")))
2300              ((not (input-stream-p stream))              ((not (input-stream-p stream))
2301               (error 'simple-stream-error               (error 'simple-stream-error
2302                      :stream stream                      :stream stream
2303                      :format-control "The stream is not open for input."))                      :format-control (intl:gettext "The stream is not open for input.")))
2304              ((and seq (>= start end) 0))              ((and seq (>= start end) 0))
2305              (t              (t
2306               ;; So much for object-oriented programming!               ;; So much for object-oriented programming!
2307               (etypecase seq               (etypecase seq
2308                 (list                 (list
2309                  (read-into-list seq stream start end))                  (read-into-list seq stream start end))
                #-unicode  
                (simple-string  
                 (read-into-simple-string seq stream start end))  
2310                 (string                 (string
2311                  (read-into-string seq stream start end))                  (with-array-data ((seq seq) (start start) (end end))
2312                      (read-into-string seq stream start end partial-fill)))
2313                 (simple-array            ; We also know that it is a 'vector'.                 (simple-array            ; We also know that it is a 'vector'.
2314                  (read-into-simple-array seq stream start end))                  (read-into-simple-array seq stream start end))
2315                 (vector                 (vector
# Line 2135  POSITION: an INTEGER greater than or equ Line 2334  POSITION: an INTEGER greater than or equ
2334                             #'read-byte)))                             #'read-byte)))
2335      (read-into-list-1 (nthcdr start l) start end stream read-function)))      (read-into-list-1 (nthcdr start l) start end stream read-function)))
2336    
2337  #+:recursive  #+recursive
2338  (defun read-into-list-1 (l start end stream read-function)  (defun read-into-list-1 (l start end stream read-function)
2339    (declare (type list l))    (declare (type list l))
2340    (declare (type stream stream))    (declare (type stream stream))
2341    (declare (type (integer 0 *) start end))    (declare (type (integer 0 *) start end))
2342    (if (or (endp l) (= start end))    (if (or (endp l) (= start end))
2343        start        start
2344        (let* ((eof-marker (load-time-value (list 'eof-marker)))        (let* ((el (funcall read-function stream nil stream)))
2345               (el (funcall read-function stream nil eof-marker)))          (cond ((eq el stream) start)
         (cond ((eq el eof-marker) start)  
2346                (t (setf (first l) el)                (t (setf (first l) el)
2347                   (read-into-list-1 (rest l)                   (read-into-list-1 (rest l)
2348                                     (1+ start)                                     (1+ start)
# Line 2154  POSITION: an INTEGER greater than or equ Line 2352  POSITION: an INTEGER greater than or equ
2352        ))        ))
2353    
2354    
2355  #-:iterative  #-recursive
2356  (defun read-into-list-1 (l start end stream read-function)  (defun read-into-list-1 (l start end stream read-function)
2357    (declare (type list l))    (declare (type list l))
2358    (declare (type stream stream))    (declare (type stream stream))
# Line 2169  POSITION: an INTEGER greater than or equ Line 2367  POSITION: an INTEGER greater than or equ
2367         i)         i)
2368      (declare (type list lis))      (declare (type list lis))
2369      (declare (type index i))      (declare (type index i))
2370      (let* ((eof-marker (load-time-value (list 'eof-marker)))      (let* ((el (funcall read-function stream nil stream)))
2371             (el (funcall read-function stream nil eof-marker)))        (when (eq el stream)
       (when (eq el eof-marker)  
2372          (return i))          (return i))
2373        (setf (first lis) el))))        (setf (first lis) el))))
2374    
# Line 2187  POSITION: an INTEGER greater than or equ Line 2384  POSITION: an INTEGER greater than or equ
2384      (error 'type-error      (error 'type-error
2385             :datum (read-char stream nil #\Null)             :datum (read-char stream nil #\Null)
2386             :expected-type (stream-element-type stream)             :expected-type (stream-element-type stream)
2387             :format-control "Trying to read characters from a binary stream."))             :format-control (intl:gettext "Trying to read characters from a binary stream.")))
2388    ;; Let's go as low level as it seems reasonable.    ;; Let's go as low level as it seems reasonable.
2389    (let* ((numbytes (- end start))    (let* ((numbytes (- end start))
2390           (total-bytes 0))           (total-bytes 0))
# Line 2205  POSITION: an INTEGER greater than or equ Line 2402  POSITION: an INTEGER greater than or equ
2402    
2403  ;;; read-into-simple-string hacked to allow (unsigned-byte 8) stream-element-type  ;;; read-into-simple-string hacked to allow (unsigned-byte 8) stream-element-type
2404  ;;; For some reason applying this change to read-into-simple-string causes CMUCL to die.  ;;; For some reason applying this change to read-into-simple-string causes CMUCL to die.
2405  (defun read-into-simple-string (s stream start end)  #-unicode
2406    (defun read-into-string (s stream start end partial-fill)
2407    (declare (type simple-string s))    (declare (type simple-string s))
2408    (declare (type stream stream))    (declare (type stream stream))
2409    (declare (type index start end))    (declare (type index start end))
# Line 2214  POSITION: an INTEGER greater than or equ Line 2412  POSITION: an INTEGER greater than or equ
2412      (error 'type-error      (error 'type-error
2413             :datum (read-char stream nil #\Null)             :datum (read-char stream nil #\Null)
2414             :expected-type (stream-element-type stream)             :expected-type (stream-element-type stream)
2415             :format-control "Trying to read characters from a binary stream."))             :format-control (intl:gettext "Trying to read characters from a binary stream.")))
2416    ;; Let's go as low level as it seems reasonable.    ;; Let's go as low level as it seems reasonable.
2417    (let* ((numbytes (- end start))    (let* ((numbytes (- end start))
2418           (total-bytes 0))           (total-bytes 0))
# Line 2222  POSITION: an INTEGER greater than or equ Line 2420  POSITION: an INTEGER greater than or equ
2420      ;; to keep trying.      ;; to keep trying.
2421      (loop while (plusp numbytes) do      (loop while (plusp numbytes) do
2422        (let ((bytes-read (system:read-n-bytes stream s start numbytes nil)))        (let ((bytes-read (system:read-n-bytes stream s start numbytes nil)))
         (when (zerop bytes-read)  
           (return-from read-into-simple-string start))  
2423          (incf total-bytes bytes-read)          (incf total-bytes bytes-read)
2424          (incf start bytes-read)          (incf start bytes-read)
2425          (decf numbytes bytes-read)))          (decf numbytes bytes-read)
2426            (when (or partial-fill (zerop bytes-read))
2427              (return-from read-into-string start))))
2428      start))      start))
2429    
2430  (defun read-into-string (s stream start end)  #+unicode
2431    (defun read-into-string (s stream start end partial-fill)
2432    (declare (type string s))    (declare (type string s))
2433    (declare (type stream stream))    (declare (type stream stream))
2434    (declare (type index start end))    (declare (type index start end))
# Line 2237  POSITION: an INTEGER greater than or equ Line 2436  POSITION: an INTEGER greater than or equ
2436      (error 'type-error      (error 'type-error
2437             :datum (read-char stream nil #\Null)             :datum (read-char stream nil #\Null)
2438             :expected-type (stream-element-type stream)             :expected-type (stream-element-type stream)
2439             :format-control "Trying to read characters from a binary stream."))             :format-control (intl:gettext "Trying to read characters from a binary stream.")))
2440    (do ((i start (1+ i))    (do ((i start (1+ i))
2441         (s-len (length s)))         (s-len (length s)))
2442        ((or (>= i s-len)        ((or (>= i s-len)
2443             (>= i end))             (>= i end))
2444         i)         i)
2445      (declare (type index i s-len))      (declare (type index i s-len))
2446      (let* ((eof-marker (load-time-value (list 'eof-marker)))      (let* ((el (read-char stream nil stream)))
            (el (read-char stream nil eof-marker)))  
2447        (declare (type (or character stream) el))        (declare (type (or character stream) el))
2448        (when (eq el eof-marker)        (when (eq el stream)
2449          (return i))          (return i))
2450        (setf (char s i) (the character el)))))        (setf (char s i) (the character el)))))
2451    
   
2452  ;;; READ-INTO-SIMPLE-ARRAY --  ;;; READ-INTO-SIMPLE-ARRAY --
2453  ;;; We definitively know that we are really reading into a vector.  ;;; We definitively know that we are really reading into a vector.
2454    
# Line 2312  POSITION: an INTEGER greater than or equ Line 2509  POSITION: an INTEGER greater than or equ
2509                    :datum (read-byte stream nil 0)                    :datum (read-byte stream nil 0)
2510                    :expected-type (stream-element-type stream) ; Bogus?!?                    :expected-type (stream-element-type stream) ; Bogus?!?
2511                    :format-control                    :format-control
2512                    "Trying to read binary data from a text stream."))                    (intl:gettext "Trying to read binary data from a text stream.")))
2513    
2514            ;; Let's go as low level as it seems reasonable.            ;; Let's go as low level as it seems reasonable.
2515            ((not (member stream-et            ((not (member stream-et
# Line 2400  POSITION: an INTEGER greater than or equ Line 2597  POSITION: an INTEGER greater than or equ
2597                   ((simple-array (signed-byte *) (*))                   ((simple-array (signed-byte *) (*))
2598                    (read-into-vector s stream start end)))))))))                    (read-into-vector s stream start end)))))))))
2599    
   
2600  ;;; READ-INTO-VECTOR --  ;;; READ-INTO-VECTOR --
2601    
2602  (defun read-into-vector (v stream start end)  (defun read-into-vector (v stream start end)
# Line 2416  POSITION: an INTEGER greater than or equ Line 2612  POSITION: an INTEGER greater than or equ
2612          ((or (>= i a-len) (>= i end))          ((or (>= i a-len) (>= i end))
2613           i)           i)
2614        (declare (type index i a-len))        (declare (type index i a-len))
2615        (let* ((eof-marker (load-time-value (list 'eof-marker)))        (let* ((el (funcall read-function stream nil stream)))
2616               (el (funcall read-function stream nil eof-marker)))          (when (eq el stream)
         (when (eq el eof-marker)  
2617            (return i))            (return i))
2618          (setf (aref v i) el)))))          (setf (aref v i) el)))))
2619    
# Line 2432  POSITION: an INTEGER greater than or equ Line 2627  POSITION: an INTEGER greater than or equ
2627  ;;; will always puzzle me.  ;;; will always puzzle me.
2628    
2629  (defun write-sequence (seq stream &key (start 0) (end nil))  (defun write-sequence (seq stream &key (start 0) (end nil))
2630    "Writes the elements of the of SEQ bounded by START and END to STREAM.    "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)  
2631    
2632  Value(s):    Argument(s):
2633  SEQ:    a proper SEQUENCE    SEQ:     a proper SEQUENCE
2634      STREAM:  an output STREAM
2635      START:   a bounding index designator of type '(INTEGER 0 *)' (default 0)
2636      END:     a bounding index designator which be NIL or an INTEGER of
2637               type '(INTEGER 0 *)' (default NIL)
2638    
2639      Value(s):
2640      SEQ:  a proper SEQUENCE
2641  "  "
2642    (declare (type (or list vector) seq))    (declare (type (or list vector) seq))
2643    (declare (type stream stream))    (declare (type stream stream))
# Line 2460  SEQ:   a proper SEQUENCE Line 2656  SEQ:   a proper SEQUENCE
2656        (cond ((not (open-stream-p stream))        (cond ((not (open-stream-p stream))
2657               (error 'simple-stream-error               (error 'simple-stream-error
2658                      :stream stream                      :stream stream
2659                      :format-control "The stream is not open."))                      :format-control (intl:gettext "The stream is not open.")))
2660              ((not (output-stream-p stream))              ((not (output-stream-p stream))
2661               (error 'simple-stream-error               (error 'simple-stream-error
2662                      :stream stream                      :stream stream
2663                      :format-control "The stream is not open for output."))                      :format-control (intl:gettext "The stream is not open for output.")))
2664              ((and seq (>= start end)) seq)              ((and seq (>= start end)) seq)
2665              (t              (t
2666               ;; So much for object-oriented programming!               ;; So much for object-oriented programming!
# Line 2474  SEQ:   a proper SEQUENCE Line 2670  SEQ:   a proper SEQUENCE
2670               (etypecase seq               (etypecase seq
2671                 (list                 (list
2672                  (write-list-out seq stream start end))                  (write-list-out seq stream start end))
                (simple-string  
                 (write-simple-string-out seq stream start end))  
2673                 (string                 (string
2674                  (write-string-out seq stream start end))                  (with-array-data ((seq seq) (start start) (end end))
2675                      (write-string-out seq stream start end)))
2676                 (simple-vector           ; This is necessary because of                 (simple-vector           ; This is necessary because of
2677                                          ; the underlying behavior of                                          ; the underlying behavior of
2678                                          ; OUTPUT-RAW-BYTES.  A vector                                          ; OUTPUT-RAW-BYTES.  A vector
# Line 2487  SEQ:   a proper SEQUENCE Line 2682  SEQ:   a proper SEQUENCE
2682                 (simple-array            ; We know it is also a vector!                 (simple-array            ; We know it is also a vector!
2683                  (write-simple-array-out seq stream start end))                  (write-simple-array-out seq stream start end))
2684                 (vector                 (vector
2685                  (write-vector-out seq stream start end)))                  (write-vector-out seq stream start end))))))
              )))  
2686      ;; fundamental-stream      ;; fundamental-stream
2687      (stream-write-sequence stream seq start end))      (stream-write-sequence stream seq start end))
2688    seq)    seq)
# Line 2518  SEQ:   a proper SEQUENCE Line 2712  SEQ:   a proper SEQUENCE
2712                        :datum e                        :datum e
2713                        :expected-type type                        :expected-type type
2714                        :format-control                        :format-control
2715                        "Trying to output an element of unproper type to a stream.")))))                        (intl:gettext "Trying to output an element of unproper type to a stream."))))))
2716      (let ((stream-et (stream-element-type stream)))      (let ((stream-et (stream-element-type stream)))
2717    
2718        (check-list-element-types seq stream-et)        (check-list-element-types seq stream-et)
# Line 2551  SEQ:   a proper SEQUENCE Line 2745  SEQ:   a proper SEQUENCE
2745      ))      ))
2746    
2747    
2748  ;;; WRITE-SIMPLE-STRING-OUT, WRITE-STRING-OUT  ;;; WRITE-STRING-OUT
 ;;; These functions are really the same, since they rely on  
 ;;; WRITE-STRING (which should be pretty efficient by itself.)  The  
 ;;; only difference is in the declaration. Maybe the duplication is an  
 ;;; overkill, but it makes things a little more logical.  
   
 (defun write-simple-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 "Trying to output a string to a binary stream."))  
   (write-string seq stream :start start :end end)  
   seq)  
   
2749    
2750  (defun write-string-out (seq stream start end)  (defun write-string-out (seq stream start end)
2751    (declare (type string seq))    (declare (type simple-string seq))
2752    (when (and (not (subtypep (stream-element-type stream) 'character))    (when (and (not (subtypep (stream-element-type stream) 'character))
2753               (not (equal (stream-element-type stream) '(unsigned-byte 8))))               (not (equal (stream-element-type stream) '(unsigned-byte 8))))
2754      (error 'type-error      (error 'type-error
2755             :datum seq             :datum seq
2756             :expected-type (stream-element-type stream)             :expected-type (stream-element-type stream)
2757             :format-control "Trying to output a string to a binary stream."))             :format-control (intl:gettext "Trying to output a string to a binary stream.")))
2758    (write-string seq stream :start start :end end)    (write-string seq stream :start start :end end)
2759    seq)    seq)
2760    
# Line 2610  SEQ:   a proper SEQUENCE Line 2788  SEQ:   a proper SEQUENCE
2788                       (simple-array double-float (*)))                       (simple-array double-float (*)))
2789                      seq))                      seq))
2790    (when (not (subtypep (stream-element-type stream) 'integer))    (when (not (subtypep (stream-element-type stream) 'integer))
2791      (error 'type-error      (error 'simple-type-error
2792             :datum (elt seq 0)             :datum (elt seq 0)
2793             :expected-type (stream-element-type stream)             :expected-type (stream-element-type stream)
2794             :format-control "Trying to output binary data to a text stream."))             :format-control (intl:gettext "Trying to output binary data to a text stream.")))
2795    (cond ((system:fd-stream-p stream)    (cond ((system:fd-stream-p stream)
2796           (flet ((write-n-x8-bytes (stream data start end byte-size)           (flet ((write-n-x8-bytes (stream data start end byte-size)
2797                    (let ((x8-mult (truncate byte-size 8)))                    (let ((x8-mult (truncate byte-size 8)))
# Line 2684  SEQ:   a proper SEQUENCE Line 2862  SEQ:   a proper SEQUENCE
2862  ;;; READ-SEQUENCE -- Public  ;;; READ-SEQUENCE -- Public
2863  ;;;  ;;;
2864  (defun read-sequence (seq stream &key (start 0) (end nil))  (defun read-sequence (seq stream &key (start 0) (end nil))
2865    "Destructively modify SEQ by reading elements from STREAM.    _N"Destructively modify SEQ by reading elements from STREAM.
2866    SEQ is bounded by START and END. SEQ is destructively modified by    SEQ is bounded by START and END. SEQ is destructively modified by
2867    copying successive elements into it from STREAM. If the end of file    copying successive elements into it from STREAM. If the end of file
2868    for STREAM is reached before copying all elements of the subsequence,    for STREAM is reached before copying all elements of the subsequence,
# Line 2747  SEQ:   a proper SEQUENCE Line 2925  SEQ:   a proper SEQUENCE
2925  ;;; WRITE-SEQUENCE -- Public  ;;; WRITE-SEQUENCE -- Public
2926  ;;;  ;;;
2927  (defun write-sequence (seq stream &key (start 0) (end nil))  (defun write-sequence (seq stream &key (start 0) (end nil))
2928    "Write the elements of SEQ bounded by START and END to STREAM."    _N"Write the elements of SEQ bounded by START and END to STREAM."
2929    (declare (type sequence seq)    (declare (type sequence seq)
2930             (type stream stream)             (type stream stream)
2931             (type index start)             (type index start)

Legend:
Removed from v.1.83.6.4  
changed lines
  Added in v.1.102

  ViewVC Help
Powered by ViewVC 1.1.5