/[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 by rtoy, Mon Aug 21 15:12:16 2006 UTC revision 1.84 by rtoy, Thu Jun 11 16:03:59 2009 UTC
# Line 289  Line 289 
289      ;; simple-stream      ;; simple-stream
290      (stream::%stream-external-format stream)      (stream::%stream-external-format stream)
291      ;; lisp-stream      ;; lisp-stream
292      :default      (typecase stream
293          (fd-stream (fd-stream-external-format stream))
294          (synonym-stream (stream-external-format
295                           (symbol-value (synonym-stream-symbol stream))))
296          (t :default))
297      ;; fundamental-stream      ;; fundamental-stream
298      :default))      :default))
299    
300    (defun (setf stream-external-format) (extfmt stream)
301      (declare (type stream stream))
302      (stream-dispatch stream
303        ;; simple-stream
304        (error "Loading simple-streams should redefine this")
305        ;; lisp-stream
306        (typecase stream
307          (fd-stream (setf (fd-stream-external-format stream)
308                         (if (eq extfmt :default)
309                             :default
310                             (stream::ef-name
311                              (stream::find-external-format extfmt)))
312                           (fd-stream-oc-state stream) nil
313                           (fd-stream-co-state stream) nil)
314                     extfmt)
315          (synonym-stream (setf (stream-external-format
316                                 (symbol-value (synonym-stream-symbol stream)))
317                              extfmt))
318          (t (error "Don't know how to set external-format for ~S." stream)))
319        ;; fundamental-stream
320        (error "Setting external-format on Gray streams not supported.")))
321    
322  (defun close (stream &key abort)  (defun close (stream &key abort)
323    "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
324    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 655  Line 681 
681  ;;;  ;;;
682  ;;;    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
683  ;;; 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
684  ;;; myst be an n-bin method.  ;;; must be an n-bin method.
685  ;;;  ;;;
686  (defun fast-read-char-refill (stream eof-errorp eof-value)  (defun fast-read-char-refill (stream eof-errorp eof-value)
687    (let* ((ibuf (lisp-stream-in-buffer stream))    (let* ((ibuf (lisp-stream-in-buffer stream))
# Line 898  Line 924 
924             (ignore arg2))             (ignore arg2))
925    (case operation    (case operation
926      (:listen      (:listen
927       ;; Return true is input available, :eof for eof-of-file, otherwise Nil.       ;; Return true if input available, :eof for end-of-file, otherwise Nil.
928       (let ((char (stream-read-char-no-hang stream)))       (let ((char (stream-read-char-no-hang stream)))
929         (when (characterp char)         (when (characterp char)
930           (stream-unread-char stream char))           (stream-unread-char stream char))
# Line 1496  output to Output-stream" Line 1522  output to Output-stream"
1522      (:listen (or (/= (the fixnum (string-input-stream-current stream))      (:listen (or (/= (the fixnum (string-input-stream-current stream))
1523                       (the fixnum (string-input-stream-end stream)))                       (the fixnum (string-input-stream-end stream)))
1524                   :eof))                   :eof))
1525      (:element-type 'base-char)))      (:element-type 'base-char)
1526        (:close
1527         (set-closed-flame stream))))
1528    
1529  (defun make-string-input-stream (string &optional  (defun make-string-input-stream (string &optional
1530                                          (start 0) (end (length string)))                                          (start 0) (end (length string)))
# Line 1635  output to Output-stream" Line 1663  output to Output-stream"
1663              (let* ((new-length (if (zerop current) 1 (* current 2)))              (let* ((new-length (if (zerop current) 1 (* current 2)))
1664                     (new-workspace (make-string new-length)))                     (new-workspace (make-string new-length)))
1665                (declare (simple-string new-workspace))                (declare (simple-string new-workspace))
1666                (%primitive byte-blt workspace start new-workspace 0 current)                (%primitive byte-blt workspace (* vm:char-bytes start)
1667                              new-workspace 0 (* vm:char-bytes current))
1668                (setf workspace new-workspace)                (setf workspace new-workspace)
1669                (setf offset-current current)                (setf offset-current current)
1670                (set-array-header buffer workspace new-length                (set-array-header buffer workspace new-length
# Line 1661  output to Output-stream" Line 1690  output to Output-stream"
1690              (let* ((new-length (+ (the fixnum (* current 2)) string-len))              (let* ((new-length (+ (the fixnum (* current 2)) string-len))
1691                     (new-workspace (make-string new-length)))                     (new-workspace (make-string new-length)))
1692                (declare (simple-string new-workspace))                (declare (simple-string new-workspace))
1693                (%primitive byte-blt workspace dst-start new-workspace 0 current)                (%primitive byte-blt workspace (* vm:char-bytes dst-start)
1694                              new-workspace 0 (* vm:char-bytes current))
1695                (setf workspace new-workspace)                (setf workspace new-workspace)
1696                (setf offset-current current)                (setf offset-current current)
1697                (setf offset-dst-end dst-end)                (setf offset-dst-end dst-end)
1698                (set-array-header buffer workspace new-length                (set-array-header buffer workspace new-length
1699                                  dst-end 0 new-length nil))                                  dst-end 0 new-length nil))
1700              (setf (fill-pointer buffer) dst-end))              (setf (fill-pointer buffer) dst-end))
1701          (%primitive byte-blt string start          (%primitive byte-blt string (* vm:char-bytes start)
1702                      workspace offset-current offset-dst-end)))                      workspace (* vm:char-bytes offset-current)
1703                        (* vm:char-bytes offset-dst-end))))
1704      dst-end))      dst-end))
1705    
1706    
# Line 2051  output to Output-stream" Line 2082  output to Output-stream"
2082    
2083    
2084  ;;; 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.  
2085    
2086  (defun read-sequence (seq stream &key (start 0) (end nil) partial-fill)  (defun read-sequence (seq stream &key (start 0) (end nil) partial-fill)
2087    "Destructively modify SEQ by reading elements from STREAM.    "Destructively modify SEQ by reading elements from STREAM.
# Line 2103  POSITION: an INTEGER greater than or equ Line 2131  POSITION: an INTEGER greater than or equ
2131               (etypecase seq               (etypecase seq
2132                 (list                 (list
2133                  (read-into-list seq stream start end))                  (read-into-list seq stream start end))
                (simple-string  
                 (read-into-simple-string seq stream start end))  
2134                 (string                 (string
2135                  (read-into-string seq stream start end))                  (with-array-data ((seq seq) (start start) (end end))
2136                      (read-into-string seq stream start end partial-fill)))
2137                 (simple-array            ; We also know that it is a 'vector'.                 (simple-array            ; We also know that it is a 'vector'.
2138                  (read-into-simple-array seq stream start end))                  (read-into-simple-array seq stream start end))
2139                 (vector                 (vector
# Line 2131  POSITION: an INTEGER greater than or equ Line 2158  POSITION: an INTEGER greater than or equ
2158                             #'read-byte)))                             #'read-byte)))
2159      (read-into-list-1 (nthcdr start l) start end stream read-function)))      (read-into-list-1 (nthcdr start l) start end stream read-function)))
2160    
2161  #+:recursive  #+recursive
2162  (defun read-into-list-1 (l start end stream read-function)  (defun read-into-list-1 (l start end stream read-function)
2163    (declare (type list l))    (declare (type list l))
2164    (declare (type stream stream))    (declare (type stream stream))
2165    (declare (type (integer 0 *) start end))    (declare (type (integer 0 *) start end))
2166    (if (or (endp l) (= start end))    (if (or (endp l) (= start end))
2167        start        start
2168        (let* ((eof-marker (load-time-value (list 'eof-marker)))        (let* ((el (funcall read-function stream nil stream)))
2169               (el (funcall read-function stream nil eof-marker)))          (cond ((eq el stream) start)
         (cond ((eq el eof-marker) start)  
2170                (t (setf (first l) el)                (t (setf (first l) el)
2171                   (read-into-list-1 (rest l)                   (read-into-list-1 (rest l)
2172                                     (1+ start)                                     (1+ start)
# Line 2150  POSITION: an INTEGER greater than or equ Line 2176  POSITION: an INTEGER greater than or equ
2176        ))        ))
2177    
2178    
2179  #-:iterative  #-recursive
2180  (defun read-into-list-1 (l start end stream read-function)  (defun read-into-list-1 (l start end stream read-function)
2181    (declare (type list l))    (declare (type list l))
2182    (declare (type stream stream))    (declare (type stream stream))
# Line 2165  POSITION: an INTEGER greater than or equ Line 2191  POSITION: an INTEGER greater than or equ
2191         i)         i)
2192      (declare (type list lis))      (declare (type list lis))
2193      (declare (type index i))      (declare (type index i))
2194      (let* ((eof-marker (load-time-value (list 'eof-marker)))      (let* ((el (funcall read-function stream nil stream)))
2195             (el (funcall read-function stream nil eof-marker)))        (when (eq el stream)
       (when (eq el eof-marker)  
2196          (return i))          (return i))
2197        (setf (first lis) el))))        (setf (first lis) el))))
2198    
# Line 2201  POSITION: an INTEGER greater than or equ Line 2226  POSITION: an INTEGER greater than or equ
2226    
2227  ;;; 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
2228  ;;; 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.
2229  (defun read-into-simple-string (s stream start end)  #-unicode
2230    (defun read-into-string (s stream start end partial-fill)
2231    (declare (type simple-string s))    (declare (type simple-string s))
2232    (declare (type stream stream))    (declare (type stream stream))
2233    (declare (type index start end))    (declare (type index start end))
# Line 2218  POSITION: an INTEGER greater than or equ Line 2244  POSITION: an INTEGER greater than or equ
2244      ;; to keep trying.      ;; to keep trying.
2245      (loop while (plusp numbytes) do      (loop while (plusp numbytes) do
2246        (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))  
2247          (incf total-bytes bytes-read)          (incf total-bytes bytes-read)
2248          (incf start bytes-read)          (incf start bytes-read)
2249          (decf numbytes bytes-read)))          (decf numbytes bytes-read)
2250            (when (or partial-fill (zerop bytes-read))
2251              (return-from read-into-string start))))
2252      start))      start))
2253    
2254  (defun read-into-string (s stream start end)  #+unicode
2255    (defun read-into-string (s stream start end partial-fill)
2256    (declare (type string s))    (declare (type string s))
2257    (declare (type stream stream))    (declare (type stream stream))
2258    (declare (type index start end))    (declare (type index start end))
# Line 2240  POSITION: an INTEGER greater than or equ Line 2267  POSITION: an INTEGER greater than or equ
2267             (>= i end))             (>= i end))
2268         i)         i)
2269      (declare (type index i s-len))      (declare (type index i s-len))
2270      (let* ((eof-marker (load-time-value (list 'eof-marker)))      (let* ((el (read-char stream nil stream)))
            (el (read-char stream nil eof-marker)))  
2271        (declare (type (or character stream) el))        (declare (type (or character stream) el))
2272        (when (eq el eof-marker)        (when (eq el stream)
2273          (return i))          (return i))
2274        (setf (char s i) (the character el)))))        (setf (char s i) (the character el)))))
2275    
   
2276  ;;; READ-INTO-SIMPLE-ARRAY --  ;;; READ-INTO-SIMPLE-ARRAY --
2277  ;;; We definitively know that we are really reading into a vector.  ;;; We definitively know that we are really reading into a vector.
2278    
# Line 2396  POSITION: an INTEGER greater than or equ Line 2421  POSITION: an INTEGER greater than or equ
2421                   ((simple-array (signed-byte *) (*))                   ((simple-array (signed-byte *) (*))
2422                    (read-into-vector s stream start end)))))))))                    (read-into-vector s stream start end)))))))))
2423    
   
2424  ;;; READ-INTO-VECTOR --  ;;; READ-INTO-VECTOR --
2425    
2426  (defun read-into-vector (v stream start end)  (defun read-into-vector (v stream start end)
# Line 2412  POSITION: an INTEGER greater than or equ Line 2436  POSITION: an INTEGER greater than or equ
2436          ((or (>= i a-len) (>= i end))          ((or (>= i a-len) (>= i end))
2437           i)           i)
2438        (declare (type index i a-len))        (declare (type index i a-len))
2439        (let* ((eof-marker (load-time-value (list 'eof-marker)))        (let* ((el (funcall read-function stream nil stream)))
2440               (el (funcall read-function stream nil eof-marker)))          (when (eq el stream)
         (when (eq el eof-marker)  
2441            (return i))            (return i))
2442          (setf (aref v i) el)))))          (setf (aref v i) el)))))
2443    
# Line 2470  SEQ:   a proper SEQUENCE Line 2493  SEQ:   a proper SEQUENCE
2493               (etypecase seq               (etypecase seq
2494                 (list                 (list
2495                  (write-list-out seq stream start end))                  (write-list-out seq stream start end))
                (simple-string  
                 (write-simple-string-out seq stream start end))  
2496                 (string                 (string
2497                  (write-string-out seq stream start end))                  (with-array-data ((seq seq) (start start) (end end))
2498                      (write-string-out seq stream start end)))
2499                 (simple-vector           ; This is necessary because of                 (simple-vector           ; This is necessary because of
2500                                          ; the underlying behavior of                                          ; the underlying behavior of
2501                                          ; OUTPUT-RAW-BYTES.  A vector                                          ; OUTPUT-RAW-BYTES.  A vector
# Line 2483  SEQ:   a proper SEQUENCE Line 2505  SEQ:   a proper SEQUENCE
2505                 (simple-array            ; We know it is also a vector!                 (simple-array            ; We know it is also a vector!
2506                  (write-simple-array-out seq stream start end))                  (write-simple-array-out seq stream start end))
2507                 (vector                 (vector
2508                  (write-vector-out seq stream start end)))                  (write-vector-out seq stream start end))))))
              )))  
2509      ;; fundamental-stream      ;; fundamental-stream
2510      (stream-write-sequence stream seq start end))      (stream-write-sequence stream seq start end))
2511    seq)    seq)
# Line 2547  SEQ:   a proper SEQUENCE Line 2568  SEQ:   a proper SEQUENCE
2568      ))      ))
2569    
2570    
2571  ;;; 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)  
   
2572    
2573  (defun write-string-out (seq stream start end)  (defun write-string-out (seq stream start end)
2574    (declare (type string seq))    (declare (type simple-string seq))
2575    (when (and (not (subtypep (stream-element-type stream) 'character))    (when (and (not (subtypep (stream-element-type stream) 'character))
2576               (not (equal (stream-element-type stream) '(unsigned-byte 8))))               (not (equal (stream-element-type stream) '(unsigned-byte 8))))
2577      (error 'type-error      (error 'type-error
# Line 2606  SEQ:   a proper SEQUENCE Line 2611  SEQ:   a proper SEQUENCE
2611                       (simple-array double-float (*)))                       (simple-array double-float (*)))
2612                      seq))                      seq))
2613    (when (not (subtypep (stream-element-type stream) 'integer))    (when (not (subtypep (stream-element-type stream) 'integer))
2614      (error 'type-error      (error 'simple-type-error
2615             :datum (elt seq 0)             :datum (elt seq 0)
2616             :expected-type (stream-element-type stream)             :expected-type (stream-element-type stream)
2617             :format-control "Trying to output binary data to a text stream."))             :format-control "Trying to output binary data to a text stream."))

Legend:
Removed from v.1.83  
changed lines
  Added in v.1.84

  ViewVC Help
Powered by ViewVC 1.1.5