/[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.83.6.4.2.3 by rtoy, Mon May 25 20:08:28 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 2054  output to Output-stream" Line 2080  output to Output-stream"
2080    
2081    
2082  ;;; 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.  
2083    
2084  (defun read-sequence (seq stream &key (start 0) (end nil) partial-fill)  (defun read-sequence (seq stream &key (start 0) (end nil) partial-fill)
2085    "Destructively modify SEQ by reading elements from STREAM.    "Destructively modify SEQ by reading elements from STREAM.
# Line 2106  POSITION: an INTEGER greater than or equ Line 2129  POSITION: an INTEGER greater than or equ
2129               (etypecase seq               (etypecase seq
2130                 (list                 (list
2131                  (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))  
2132                 (string                 (string
2133                  (read-into-string seq stream start end))                  (with-array-data ((seq seq) (start start) (end end))
2134                 (simple-array            ; We also know that it is a 'vector'.                    (read-into-string seq stream start end partial-fill)))
                 (read-into-simple-array seq stream start end))  
2135                 (vector                 (vector
2136                  (read-into-vector seq stream start end))))))                  (with-array-data ((seq seq) (start start) (end end))
2137                      (read-into-simple-array seq stream start end)))))))
2138      ;; fundamental-stream      ;; fundamental-stream
2139      (stream-read-sequence stream seq start end)))      (stream-read-sequence stream seq start end)))
2140    
# Line 2135  POSITION: an INTEGER greater than or equ Line 2155  POSITION: an INTEGER greater than or equ
2155                             #'read-byte)))                             #'read-byte)))
2156      (read-into-list-1 (nthcdr start l) start end stream read-function)))      (read-into-list-1 (nthcdr start l) start end stream read-function)))
2157    
2158  #+:recursive  #+recursive
2159  (defun read-into-list-1 (l start end stream read-function)  (defun read-into-list-1 (l start end stream read-function)
2160    (declare (type list l))    (declare (type list l))
2161    (declare (type stream stream))    (declare (type stream stream))
2162    (declare (type (integer 0 *) start end))    (declare (type (integer 0 *) start end))
2163    (if (or (endp l) (= start end))    (if (or (endp l) (= start end))
2164        start        start
2165        (let* ((eof-marker (load-time-value (list 'eof-marker)))        (let* ((el (funcall read-function stream nil stream)))
2166               (el (funcall read-function stream nil eof-marker)))          (cond ((eq el stream) start)
         (cond ((eq el eof-marker) start)  
2167                (t (setf (first l) el)                (t (setf (first l) el)
2168                   (read-into-list-1 (rest l)                   (read-into-list-1 (rest l)
2169                                     (1+ start)                                     (1+ start)
# Line 2154  POSITION: an INTEGER greater than or equ Line 2173  POSITION: an INTEGER greater than or equ
2173        ))        ))
2174    
2175    
2176  #-:iterative  #-recursive
2177  (defun read-into-list-1 (l start end stream read-function)  (defun read-into-list-1 (l start end stream read-function)
2178    (declare (type list l))    (declare (type list l))
2179    (declare (type stream stream))    (declare (type stream stream))
# Line 2169  POSITION: an INTEGER greater than or equ Line 2188  POSITION: an INTEGER greater than or equ
2188         i)         i)
2189      (declare (type list lis))      (declare (type list lis))
2190      (declare (type index i))      (declare (type index i))
2191      (let* ((eof-marker (load-time-value (list 'eof-marker)))      (let* ((el (funcall read-function stream nil stream)))
2192             (el (funcall read-function stream nil eof-marker)))        (when (eq el stream)
       (when (eq el eof-marker)  
2193          (return i))          (return i))
2194        (setf (first lis) el))))        (setf (first lis) el))))
2195    
# Line 2205  POSITION: an INTEGER greater than or equ Line 2223  POSITION: an INTEGER greater than or equ
2223    
2224  ;;; 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
2225  ;;; 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.
2226  (defun read-into-simple-string (s stream start end)  #-unicode
2227    (defun read-into-string (s stream start end partial-fill)
2228    (declare (type simple-string s))    (declare (type simple-string s))
2229    (declare (type stream stream))    (declare (type stream stream))
2230    (declare (type index start end))    (declare (type index start end))
# Line 2222  POSITION: an INTEGER greater than or equ Line 2241  POSITION: an INTEGER greater than or equ
2241      ;; to keep trying.      ;; to keep trying.
2242      (loop while (plusp numbytes) do      (loop while (plusp numbytes) do
2243        (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))  
2244          (incf total-bytes bytes-read)          (incf total-bytes bytes-read)
2245          (incf start bytes-read)          (incf start bytes-read)
2246          (decf numbytes bytes-read)))          (decf numbytes bytes-read)
2247            (when (or partial-fill (zerop bytes-read))
2248              (return-from read-into-string start))))
2249      start))      start))
2250    
2251  (defun read-into-string (s stream start end)  #+unicode
2252    (defun read-into-string (s stream start end partial-fill)
2253    (declare (type string s))    (declare (type string s))
2254    (declare (type stream stream))    (declare (type stream stream))
2255    (declare (type index start end))    (declare (type index start end))
# Line 2244  POSITION: an INTEGER greater than or equ Line 2264  POSITION: an INTEGER greater than or equ
2264             (>= i end))             (>= i end))
2265         i)         i)
2266      (declare (type index i s-len))      (declare (type index i s-len))
2267      (let* ((eof-marker (load-time-value (list 'eof-marker)))      (let* ((el (read-char stream nil stream)))
            (el (read-char stream nil eof-marker)))  
2268        (declare (type (or character stream) el))        (declare (type (or character stream) el))
2269        (when (eq el eof-marker)        (when (eq el stream)
2270          (return i))          (return i))
2271        (setf (char s i) (the character el)))))        (setf (char s i) (the character el)))))
2272    
   
2273  ;;; READ-INTO-SIMPLE-ARRAY --  ;;; READ-INTO-SIMPLE-ARRAY --
2274  ;;; We definitively know that we are really reading into a vector.  ;;; We definitively know that we are really reading into a vector.
2275    
# Line 2269  POSITION: an INTEGER greater than or equ Line 2287  POSITION: an INTEGER greater than or equ
2287                                          ; to support simple-stream                                          ; to support simple-stream
2288                                          ; semantics for read-vector                                          ; semantics for read-vector
2289      character      character
2290        bit
2291        (unsigned-byte 2)
2292        (unsigned-byte 4)
2293      (unsigned-byte 8)      (unsigned-byte 8)
2294      (unsigned-byte 16)      (unsigned-byte 16)
2295      (unsigned-byte 32)      (unsigned-byte 32)
# Line 2287  POSITION: an INTEGER greater than or equ Line 2308  POSITION: an INTEGER greater than or equ
2308    ;; quite constrain the array element type.    ;; quite constrain the array element type.
2309    ;; (declare (type (simple-array (or unsigned-byte signed-byte) (*)) s))    ;; (declare (type (simple-array (or unsigned-byte signed-byte) (*)) s))
2310    ;; (declare (type (simple-array * (*)) s))    ;; (declare (type (simple-array * (*)) s))
2311    (declare (type (or (simple-array (unsigned-byte 8) (*))    (declare (type (or (simple-array bit (*))
2312                         (simple-array (unsigned-byte 2) (*))
2313                         (simple-array (unsigned-byte 4) (*))
2314                         (simple-array (unsigned-byte 8) (*))
2315                       (simple-array (signed-byte 8) (*))                       (simple-array (signed-byte 8) (*))
2316                       (simple-array (unsigned-byte 16) (*))                       (simple-array (unsigned-byte 16) (*))
2317                       (simple-array (signed-byte 16) (*))                       (simple-array (signed-byte 16) (*))
# Line 2366  POSITION: an INTEGER greater than or equ Line 2390  POSITION: an INTEGER greater than or equ
2390               ;; operation on a binary stream.               ;; operation on a binary stream.
2391               (with-array-data ((data s) (offset-start start) (offset-end end))               (with-array-data ((data s) (offset-start start) (offset-end end))
2392                 (etypecase data                 (etypecase data
2393                     ((simple-array bit (*))
2394                      (read-n-x8-bytes stream data
2395                                       (ceiling offset-start 8)
2396                                       (ceiling offset-end 8)
2397                                       8))
2398    
2399                     ((simple-array (unsigned-byte 2) (*))
2400                      (read-n-x8-bytes stream data
2401                                       (ceiling offset-start 4)
2402                                       (ceiling offset-end 4)
2403                                       8))
2404    
2405                     ((simple-array (unsigned-byte 4) (*))
2406                      (read-n-x8-bytes stream data
2407                                       (ceiling offset-start 2)
2408                                       (ceiling offset-end 2)
2409                                       8))
2410    
2411                   ((simple-array (unsigned-byte 8) (*))                   ((simple-array (unsigned-byte 8) (*))
2412                    (read-n-x8-bytes stream data offset-start offset-end 8))                    (read-n-x8-bytes stream data offset-start offset-end 8))
2413    
# Line 2400  POSITION: an INTEGER greater than or equ Line 2442  POSITION: an INTEGER greater than or equ
2442                   ((simple-array (signed-byte *) (*))                   ((simple-array (signed-byte *) (*))
2443                    (read-into-vector s stream start end)))))))))                    (read-into-vector s stream start end)))))))))
2444    
   
2445  ;;; READ-INTO-VECTOR --  ;;; READ-INTO-VECTOR --
2446    
2447  (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 2457  POSITION: an INTEGER greater than or equ
2457          ((or (>= i a-len) (>= i end))          ((or (>= i a-len) (>= i end))
2458           i)           i)
2459        (declare (type index i a-len))        (declare (type index i a-len))
2460        (let* ((eof-marker (load-time-value (list 'eof-marker)))        (let* ((el (funcall read-function stream nil stream)))
2461               (el (funcall read-function stream nil eof-marker)))          (when (eq el stream)
         (when (eq el eof-marker)  
2462            (return i))            (return i))
2463          (setf (aref v i) el)))))          (setf (aref v i) el)))))
2464    
# Line 2474  SEQ:   a proper SEQUENCE Line 2514  SEQ:   a proper SEQUENCE
2514               (etypecase seq               (etypecase seq
2515                 (list                 (list
2516                  (write-list-out seq stream start end))                  (write-list-out seq stream start end))
                (simple-string  
                 (write-simple-string-out seq stream start end))  
2517                 (string                 (string
2518                  (write-string-out seq stream start end))                  (with-array-data ((seq seq) (start start) (end end))
2519                      (write-string-out seq stream start end)))
2520                 (simple-vector           ; This is necessary because of                 (simple-vector           ; This is necessary because of
2521                                          ; the underlying behavior of                                          ; the underlying behavior of
2522                                          ; OUTPUT-RAW-BYTES.  A vector                                          ; OUTPUT-RAW-BYTES.  A vector
2523                                          ; produced by VECTOR has                                          ; produced by VECTOR has
2524                                          ; element-type T in CMUCL.                                          ; element-type T in CMUCL.
2525                  (write-vector-out seq stream start end))                  (write-vector-out seq stream start end))
                (simple-array            ; We know it is also a vector!  
                 (write-simple-array-out seq stream start end))  
2526                 (vector                 (vector
2527                  (write-vector-out seq stream start end)))                  (with-array-data ((seq seq) (start start) (end end))
2528                      (write-simple-array-out seq stream start end))))
2529               )))               )))
2530      ;; fundamental-stream      ;; fundamental-stream
2531      (stream-write-sequence stream seq start end))      (stream-write-sequence stream seq start end))
# Line 2551  SEQ:   a proper SEQUENCE Line 2589  SEQ:   a proper SEQUENCE
2589      ))      ))
2590    
2591    
2592  ;;; 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)  
   
2593    
2594  (defun write-string-out (seq stream start end)  (defun write-string-out (seq stream start end)
2595    (declare (type string seq))    (declare (type simple-string seq))
2596    (when (and (not (subtypep (stream-element-type stream) 'character))    (when (and (not (subtypep (stream-element-type stream) 'character))
2597               (not (equal (stream-element-type stream) '(unsigned-byte 8))))               (not (equal (stream-element-type stream) '(unsigned-byte 8))))
2598      (error 'type-error      (error 'type-error
# Line 2598  SEQ:   a proper SEQUENCE Line 2620  SEQ:   a proper SEQUENCE
2620    ;; quite constrain the array element type.    ;; quite constrain the array element type.
2621    ;; (declare (type (simple-array (or unsigned-byte signed-byte) (*)) s))    ;; (declare (type (simple-array (or unsigned-byte signed-byte) (*)) s))
2622    ;; (declare (type (simple-array * (*)) s))    ;; (declare (type (simple-array * (*)) s))
2623    (declare (type (or (simple-array (unsigned-byte 8) (*))    (declare (type (or (simple-array bit (*))
2624                         (simple-array (unsigned-byte 2) (*))
2625                         (simple-array (unsigned-byte 4) (*))
2626                         (simple-array (unsigned-byte 8) (*))
2627                       (simple-array (signed-byte 8) (*))                       (simple-array (signed-byte 8) (*))
2628                       (simple-array (unsigned-byte 16) (*))                       (simple-array (unsigned-byte 16) (*))
2629                       (simple-array (signed-byte 16) (*))                       (simple-array (signed-byte 16) (*))
# Line 2624  SEQ:   a proper SEQUENCE Line 2649  SEQ:   a proper SEQUENCE
2649                               (start start)                               (start start)
2650                               (end   end))                               (end   end))
2651               (etypecase data               (etypecase data
2652                   ((simple-array bit (*))
2653                    (write-n-x8-bytes stream data
2654                                      (ceiling start 8) (ceiling end 8) 8))
2655    
2656                   ((simple-array (unsigned-byte 2) (*))
2657                    (write-n-x8-bytes stream data
2658                                      (ceiling start 4) (ceiling end 4) 8))
2659    
2660                   ((simple-array (unsigned-byte 4) (*))
2661                    (write-n-x8-bytes stream data
2662                                      (ceiling start 2) (ceiling end 2) 8))
2663    
2664                 ((simple-array (unsigned-byte 8) (*))                 ((simple-array (unsigned-byte 8) (*))
2665                  (write-n-x8-bytes stream data start end 8))                  (write-n-x8-bytes stream data start end 8))
2666    

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

  ViewVC Help
Powered by ViewVC 1.1.5