/[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.60 by toy, Wed Mar 19 03:31:24 2003 UTC revision 1.61 by toy, Fri Jun 6 16:23:45 2003 UTC
# Line 12  Line 12 
12  ;;; Stream functions for Spice Lisp.  ;;; Stream functions for Spice Lisp.
13  ;;; Written by Skef Wholey and Rob MacLachlan.  ;;; Written by Skef Wholey and Rob MacLachlan.
14  ;;; Gray streams support by Douglas Crosher, 1998.  ;;; Gray streams support by Douglas Crosher, 1998.
15    ;;; Simple-streams support by Paul Foley, 2003.
16  ;;;  ;;;
17  ;;; This file contains the OS-independent stream functions.  ;;; This file contains the OS-independent stream functions.
18  ;;;  ;;;
# Line 100  Line 101 
101    (error 'simple-type-error    (error 'simple-type-error
102           :datum stream           :datum stream
103           :expected-type '(satisfies input-stream-p)           :expected-type '(satisfies input-stream-p)
104           :format-control "~S is not a binary input stream or does not support multi-byte read operations."           :format-control "~S is not a binary input stream ~
105                              or does not support multi-byte read operations."
106           :format-arguments (list stream)))           :format-arguments (list stream)))
107  (defun ill-bout (stream &rest ignore)  (defun ill-bout (stream &rest ignore)
108    (declare (ignore ignore))    (declare (ignore ignore))
# Line 114  Line 116 
116    (error "~S is closed." stream))    (error "~S is closed." stream))
117  (defun do-nothing (&rest ignore)  (defun do-nothing (&rest ignore)
118    (declare (ignore ignore)))    (declare (ignore ignore)))
119    (defun no-gray-streams (stream)
120      (error 'simple-type-error
121             :datum stream
122             :expected-type 'stream
123             :format-control "~S is an unsupported Gray stream."
124             :format-arguments (list stream)))
125    
126  (defun %print-stream (structure stream d)  (defun %print-stream (structure stream d)
127    (declare (ignore d structure))    (declare (ignore d structure))
# Line 140  Line 148 
148  ;;; are handled by just one function, the Misc method.  This function  ;;; are handled by just one function, the Misc method.  This function
149  ;;; is passed a keyword which indicates the operation to perform.  ;;; is passed a keyword which indicates the operation to perform.
150  ;;; The following keywords are used:  ;;; The following keywords are used:
151    ;;;
152  ;;;  :listen            - Return the following values:  ;;;  :listen            - Return the following values:
153  ;;;                          t if any input waiting.  ;;;                          t if any input waiting.
154  ;;;                          :eof if at eof.  ;;;                          :eof if at eof.
# Line 153  Line 162 
162  ;;;  :finish-output,  ;;;  :finish-output,
163  ;;;  :force-output      - Cause output to happen  ;;;  :force-output      - Cause output to happen
164  ;;;  :clear-output      - Clear any undone output  ;;;  :clear-output      - Clear any undone output
165  ;;;  :element-type      - Return the type of element the stream deals wit<h.  ;;;  :element-type      - Return the type of element the stream deals with.
166  ;;;  :line-length       - Return the length of a line of output.  ;;;  :line-length       - Return the length of a line of output.
167  ;;;  :charpos           - Return current output position on the line.  ;;;  :charpos           - Return current output position on the line.
168  ;;;  :file-length       - Return the file length of a file stream.  ;;;  :file-length       - Return the file length of a file stream.
# Line 197  Line 206 
206    
207  (defun input-stream-p (stream)  (defun input-stream-p (stream)
208    "Returns non-nil if the given Stream can perform input operations."    "Returns non-nil if the given Stream can perform input operations."
209    (and (lisp-stream-p stream)    (declare (type stream stream))
210         (not (eq (lisp-stream-in stream) #'closed-flame))    ;; Note: Gray streams redefines this function; any changes made here need
211         (or (not (eq (lisp-stream-in stream) #'ill-in))    ;; to be duplicated in .../pcl/gray-streams.lisp
212             (not (eq (lisp-stream-bin stream) #'ill-bin))    (stream-dispatch stream
213             (not (eq (lisp-stream-n-bin stream) #'ill-n-bin)))))      ;; simple-stream
214        (stream::%input-stream-p stream)
215        ;; lisp-stream
216        (and (not (eq (lisp-stream-in stream) #'closed-flame))
217             (or (not (eq (lisp-stream-in stream) #'ill-in))
218                 (not (eq (lisp-stream-bin stream) #'ill-bin))
219                 (not (eq (lisp-stream-n-bin stream) #'ill-n-bin))))))
220    
221  (defun output-stream-p (stream)  (defun output-stream-p (stream)
222    "Returns non-nil if the given Stream can perform output operations."    "Returns non-nil if the given Stream can perform output operations."
223    (and (lisp-stream-p stream)    (declare (type stream stream))
224         (not (eq (lisp-stream-in stream) #'closed-flame))    ;; Note: Gray streams redefines this function; any changes made here need
225         (or (not (eq (lisp-stream-out stream) #'ill-out))    ;; to be duplicated in .../pcl/gray-streams.lisp
226             (not (eq (lisp-stream-bout stream) #'ill-bout)))))    (stream-dispatch stream
227        ;; simple-stream
228        (stream::%output-stream-p stream)
229        ;; lisp-stream
230        (and (not (eq (lisp-stream-in stream) #'closed-flame))
231             (or (not (eq (lisp-stream-out stream) #'ill-out))
232                 (not (eq (lisp-stream-bout stream) #'ill-bout))))))
233    
234  (defun open-stream-p (stream)  (defun open-stream-p (stream)
235    "Return true if Stream is not closed."    "Return true if Stream is not closed."
236    (declare (type stream stream))    (declare (type stream stream))
237    (not (eq (lisp-stream-in stream) #'closed-flame)))    ;; Note: Gray streams redefines this function; any changes made here need
238      ;; to be duplicated in .../pcl/gray-streams.lisp
239      (stream-dispatch stream
240        ;; simple-stream
241        (stream::%open-stream-p stream)
242        ;; lisp-stream
243        (not (eq (lisp-stream-in stream) #'closed-flame))))
244    
245  (defun stream-element-type (stream)  (defun stream-element-type (stream)
246    "Returns a type specifier for the kind of object returned by the Stream."    "Returns a type specifier for the kind of object returned by the Stream."
247    (declare (type stream stream))    (declare (type stream stream))
248    (funcall (lisp-stream-misc stream) stream :element-type))    ;; Note: Gray streams redefines this function; any changes made here need
249      ;; to be duplicated in .../pcl/gray-streams.lisp
250      (stream-dispatch stream
251        ;; simple-stream
252        '(unsigned-byte 8)
253        ;; lisp-stream
254        (funcall (lisp-stream-misc stream) stream :element-type)))
255    
256  (defun interactive-stream-p (stream)  (defun interactive-stream-p (stream)
257    "Return true if Stream does I/O on a terminal or other interactive device."    "Return true if Stream does I/O on a terminal or other interactive device."
258    (declare (type stream stream))    (declare (type stream stream))
259    (funcall (lisp-stream-misc stream) stream :interactive-p))    (stream-dispatch stream
260        ;; simple-stream
261        (stream::%interactive-stream-p stream)
262        ;; lisp-stream
263        (funcall (lisp-stream-misc stream) stream :interactive-p)))
264    
265  (defun open-stream-p (stream)  (defun (setf interactive-stream-p) (flag stream)
   "Return true if and only if STREAM has not been closed."  
266    (declare (type stream stream))    (declare (type stream stream))
267    (not (eq (lisp-stream-in stream) #'closed-flame)))    (stream-dispatch stream
268        ;; simple-stream
269        (if flag
270            (stream::%interactive-stream-y stream)
271            (stream::%interactive-stream-n stream))
272        ;; lisp-stream
273        (error 'simple-type-error
274               :datum stream
275               :expected-type 'stream:simple-stream
276               :format-control "Can't set interactive flag on ~S."
277               :format-arguments (list stream))))
278    
279    (defun stream-external-format (stream)
280      "Returns the external format used by the given Stream."
281      (declare (type stream stream))
282      (stream-dispatch stream
283        ;; simple-stream
284        (stream::%stream-external-format stream)
285        ;; lisp-stream
286        :default
287        ;; fundamental-stream
288        :default))
289    
290  (defun close (stream &key abort)  (defun close (stream &key abort)
291    "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
292    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
293    up the side effects of having created the stream."    up the side effects of having created the stream."
294    (declare (type stream stream))    (declare (type stream stream))
295    (when (open-stream-p stream)    ;; Note: Gray streams redefines this function; any changes made here need
296      (funcall (lisp-stream-misc stream) stream :close abort))    ;; to be duplicated in .../pcl/gray-streams.lisp
297      (stream-dispatch stream
298        ;; simple-stream
299        (stream:device-close stream abort)
300        ;; lisp-stream
301        (when (open-stream-p stream)
302          (funcall (lisp-stream-misc stream) stream :close abort)))
303    t)    t)
304    
305  (defun set-closed-flame (stream)  (defun set-closed-flame (stream)
306      (declare (type lisp-stream stream))
307    (setf (lisp-stream-in stream) #'closed-flame)    (setf (lisp-stream-in stream) #'closed-flame)
308    (setf (lisp-stream-bin stream) #'closed-flame)    (setf (lisp-stream-bin stream) #'closed-flame)
309    (setf (lisp-stream-n-bin stream) #'closed-flame)    (setf (lisp-stream-n-bin stream) #'closed-flame)
# Line 262  Line 326 
326     this becomes the new file position.  The second argument may also     this becomes the new file position.  The second argument may also
327     be :start or :end for the start and end of the file, respectively."     be :start or :end for the start and end of the file, respectively."
328    (declare (type stream stream)    (declare (type stream stream)
329             (type (or (integer 0) (member nil :start :end)) position))             (type (or (integer 0 *) (member nil :start :end)) position))
330    (cond    (stream-dispatch stream
331     (position      ;; simple-stream
332      (setf (lisp-stream-in-index stream) in-buffer-length)      (stream::%file-position stream position)
333      (funcall (lisp-stream-misc stream) stream :file-position position))      ;; lisp-stream
334     (t      (cond
335      (let ((res (funcall (lisp-stream-misc stream) stream :file-position nil)))        (position
336        (when res (- res (- in-buffer-length (lisp-stream-in-index stream))))))))         (setf (lisp-stream-in-index stream) in-buffer-length)
337           (funcall (lisp-stream-misc stream) stream :file-position position))
338          (t
339           (let ((res (funcall (lisp-stream-misc stream) stream
340                               :file-position nil)))
341             (when res
342               (- res (- in-buffer-length (lisp-stream-in-index stream)))))))))
343    
344    
345  ;;; File-Length  --  Public  ;;; File-Length  --  Public
# Line 278  Line 348 
348  ;;;  ;;;
349  (defun file-length (stream)  (defun file-length (stream)
350    "This function returns the length of the file that File-Stream is open to."    "This function returns the length of the file that File-Stream is open to."
351    (declare (stream stream))    (stream-dispatch stream
352    (funcall (lisp-stream-misc stream) stream :file-length))      ;; simple-stream
353        (stream::%file-length stream)
354        ;; lisp-stream
355        (funcall (lisp-stream-misc stream) stream :file-length)))
356    
357    
358  ;;; Input functions:  ;;; Input functions:
# Line 288  Line 361 
361                              recursive-p)                              recursive-p)
362    "Returns a line of text read from the Stream as a string, discarding the    "Returns a line of text read from the Stream as a string, discarding the
363    newline character."    newline character."
   (declare (ignore recursive-p))  
364    (let ((stream (in-synonym-of stream)))    (let ((stream (in-synonym-of stream)))
365      (if (lisp-stream-p stream)      (stream-dispatch stream
366          (prepare-for-fast-read-char stream        ;; simple-stream
367            (let ((res (make-string 80))        (stream::%read-line stream eof-errorp eof-value recursive-p)
368                  (len 80)        ;; lisp-stream
369                  (index 0))        (prepare-for-fast-read-char stream
370              (loop          (let ((res (make-string 80))
371               (let ((ch (fast-read-char nil nil)))                (len 80)
372                 (cond (ch                (index 0))
373                        (when (char= ch #\newline)            (loop
374                          (done-with-fast-read-char)              (let ((ch (fast-read-char nil nil)))
375                          (return (values (shrink-vector res index) nil)))                (cond (ch
376                        (when (= index len)                       (when (char= ch #\newline)
377                          (setq len (* len 2))                         (done-with-fast-read-char)
378                          (let ((new (make-string len)))                         (return (values (shrink-vector res index) nil)))
379                            (replace new res)                       (when (= index len)
380                            (setq res new)))                         (setq len (* len 2))
381                        (setf (schar res index) ch)                         (let ((new (make-string len)))
382                        (incf index))                           (replace new res)
383                       ((zerop index)                           (setq res new)))
384                        (done-with-fast-read-char)                       (setf (schar res index) ch)
385                        (return (values (eof-or-lose stream eof-errorp eof-value)                       (incf index))
386                                        t)))                      ((zerop index)
387                       ;; since fast-read-char hit already the eof char, we                       (done-with-fast-read-char)
388                       ;; shouldn't do another read-char                       (return (values (eof-or-lose stream eof-errorp eof-value)
389                       (t                                       t)))
390                        (done-with-fast-read-char)                      ;; since fast-read-char hit already the eof char, we
391                        (return (values (shrink-vector res index) t))))))))                      ;; shouldn't do another read-char
392          ;; Fundamental-stream.                      (t
393          (multiple-value-bind (string eof)                       (done-with-fast-read-char)
394              (stream-read-line stream)                       (return (values (shrink-vector res index) t))))))))
395            (if (and eof (zerop (length string)))        ;; fundamental-stream
396                (values (eof-or-lose stream eof-errorp eof-value) t)        (multiple-value-bind (string eof)
397                (values string eof))))))            (stream-read-line stream)
398            (if (and eof (zerop (length string)))
399                (values (eof-or-lose stream eof-errorp eof-value) t)
400                (values string eof))))))
401    
402  ;;; We proclaim them inline here, then proclaim them notinline at EOF,  ;;; We proclaim them inline here, then proclaim them notinline at EOF,
403  ;;; so, except in this file, they are not inline by default, but they can be.  ;;; so, except in this file, they are not inline by default, but they can be.
# Line 331  Line 406 
406  (defun read-char (&optional (stream *standard-input*) (eof-errorp t) eof-value  (defun read-char (&optional (stream *standard-input*) (eof-errorp t) eof-value
407                              recursive-p)                              recursive-p)
408    "Inputs a character from Stream and returns it."    "Inputs a character from Stream and returns it."
   (declare (ignore recursive-p))  
409    (let ((stream (in-synonym-of stream)))    (let ((stream (in-synonym-of stream)))
410      (if (lisp-stream-p stream)      (stream-dispatch stream
411          (prepare-for-fast-read-char stream        ;; simple-stream
412            (prog1        (stream::%read-char stream eof-errorp eof-value recursive-p t)
413                (fast-read-char eof-errorp eof-value)        ;; lisp-stream
414              (done-with-fast-read-char)))        (prepare-for-fast-read-char stream
415          ;; Fundamental-stream.          (prog1
416          (let ((char (stream-read-char stream)))              (fast-read-char eof-errorp eof-value)
417            (if (eq char :eof)            (done-with-fast-read-char)))
418                (eof-or-lose stream eof-errorp eof-value)        ;; fundamental-stream
419                char)))))        (let ((char (stream-read-char stream)))
420            (if (eq char :eof)
421                (eof-or-lose stream eof-errorp eof-value)
422                char)))))
423    
424  (defun unread-char (character &optional (stream *standard-input*))  (defun unread-char (character &optional (stream *standard-input*))
425    "Puts the Character back on the front of the input Stream."    "Puts the Character back on the front of the input Stream."
426    (let ((stream (in-synonym-of stream)))    (let ((stream (in-synonym-of stream)))
427      (if (lisp-stream-p stream)      (stream-dispatch stream
428          (let ((index (1- (lisp-stream-in-index stream)))        ;; simple-stream
429                (buffer (lisp-stream-in-buffer stream)))        (stream::%unread-char stream character)
430            (declare (fixnum index))        ;; lisp-stream
431            (when (minusp index) (error "Nothing to unread."))        (let ((index (1- (lisp-stream-in-index stream)))
432            (cond (buffer              (buffer (lisp-stream-in-buffer stream)))
433                   (setf (aref buffer index) (char-code character))          (declare (fixnum index))
434                   (setf (lisp-stream-in-index stream) index))          (when (minusp index) (error "Nothing to unread."))
435                  (t          (cond (buffer
436                   (funcall (lisp-stream-misc stream) stream                 (setf (aref buffer index) (char-code character))
437                            :unread character))))                 (setf (lisp-stream-in-index stream) index))
438          ;; Fundamental-stream                (t
439          (stream-unread-char stream character)))                 (funcall (lisp-stream-misc stream) stream
440                            :unread character))))
441          ;; fundamental-stream
442          (stream-unread-char stream character)))
443    nil)    nil)
444    
445  ;;; In the interest of ``once and only once'' this macro contains the  ;;; In the interest of ``once and only once'' this macro contains the
# Line 376  Line 456 
456  ;;; SKIPPED-CHAR-FORM - the form to execute when skipping a character  ;;; SKIPPED-CHAR-FORM - the form to execute when skipping a character
457  ;;; EOF-DETECTED-FORM - the form to execute when EOF has been detected  ;;; EOF-DETECTED-FORM - the form to execute when EOF has been detected
458  ;;;                     (this will default to CHAR-VAR)  ;;;                     (this will default to CHAR-VAR)
459  (defmacro generalized-peeking-mechanism (peek-type eof-value char-var read-form unread-form  (defmacro generalized-peeking-mechanism (peek-type eof-value char-var
460                                                     &optional (skipped-char-form nil)                                           read-form unread-form
461                                             &optional (skipped-char-form nil)
462                                                     (eof-detected-form nil))                                                     (eof-detected-form nil))
463    `(let ((,char-var ,read-form))    `(let ((,char-var ,read-form))
464      (cond ((eql ,char-var ,eof-value)      (cond ((eql ,char-var ,eof-value)
# Line 415  Line 496 
496  (defun peek-char (&optional (peek-type nil) (stream *standard-input*)  (defun peek-char (&optional (peek-type nil) (stream *standard-input*)
497                              (eof-errorp t) eof-value recursive-p)                              (eof-errorp t) eof-value recursive-p)
498    "Peeks at the next character in the input Stream.  See manual for details."    "Peeks at the next character in the input Stream.  See manual for details."
   (declare (ignore recursive-p))  
499    ;; FIXME: The type of PEEK-TYPE is also declared in a DEFKNOWN, but    ;; FIXME: The type of PEEK-TYPE is also declared in a DEFKNOWN, but
500    ;; the compiler doesn't seem to be smart enough to go from there to    ;; the compiler doesn't seem to be smart enough to go from there to
501    ;; imposing a type check. Figure out why (because PEEK-TYPE is an    ;; imposing a type check. Figure out why (because PEEK-TYPE is an
# Line 428  Line 508 
508             :format-control "~@<bad PEEK-TYPE=~S, ~_expected ~S~:>"             :format-control "~@<bad PEEK-TYPE=~S, ~_expected ~S~:>"
509             :format-arguments (list peek-type '(or character boolean))))             :format-arguments (list peek-type '(or character boolean))))
510    (let ((stream (in-synonym-of stream)))    (let ((stream (in-synonym-of stream)))
511      (cond ((typep stream 'echo-stream)      (if (typep stream 'echo-stream)
512             (echo-misc stream          (echo-misc stream :peek-char peek-type (list eof-errorp eof-value))
513                        :peek-char          (stream-dispatch stream
514                        peek-type            ;; simple-stream
515                        (list eof-errorp eof-value)))            (stream::%peek-char stream peek-type eof-errorp eof-value
516            ((lisp-stream-p stream)                                recursive-p)
517             (generalized-peeking-mechanism            ;; lisp-stream
518              peek-type eof-value char            (generalized-peeking-mechanism
519              (read-char stream eof-errorp eof-value)             peek-type eof-value char
520              (unread-char char stream)))             (read-char stream eof-errorp eof-value)
521            (t             (unread-char char stream))
522             ;; by elimination, must be Gray streams FUNDAMENTAL-STREAM            ;; fundamental-stream
523             (generalized-peeking-mechanism            (generalized-peeking-mechanism
524              peek-type :eof char             peek-type :eof char
525              (if (null peek-type)             (if (null peek-type)
526                  (stream-peek-char stream)                 (stream-peek-char stream)
527                  (stream-read-char stream))                 (stream-read-char stream))
528              (if (null peek-type)             (if (null peek-type)
529                  ()                 ()
530                  (stream-unread-char stream char))                 (stream-unread-char stream char))
531              ()             ()
532              (eof-or-lose stream eof-errorp eof-value))))))             (eof-or-lose stream eof-errorp eof-value))))))
533    
534  (defun listen (&optional (stream *standard-input*))  (defun listen (&optional (stream *standard-input*) (width 1))
535    "Returns T if a character is availible on the given Stream."    "Returns T if a character is available on the given Stream."
536      (declare (type streamlike stream))
537    (let ((stream (in-synonym-of stream)))    (let ((stream (in-synonym-of stream)))
538      (if (lisp-stream-p stream)      (stream-dispatch stream
539          (or (/= (the fixnum (lisp-stream-in-index stream)) in-buffer-length)        ;; simple-stream
540              ;; Test for t explicitly since misc methods return :eof sometimes.        (stream::%listen stream width)
541              (eq (funcall (lisp-stream-misc stream) stream :listen) t))        ;; lisp-stream
542          ;; Fundamental-stream.        (or (/= (the fixnum (lisp-stream-in-index stream)) in-buffer-length)
543          (stream-listen stream))))            ;; Test for t explicitly since misc methods return :eof sometimes.
544              (eq (funcall (lisp-stream-misc stream) stream :listen) t))
545          ;; fundamental-stream
546          (stream-listen stream))))
547    
548  (defun read-char-no-hang (&optional (stream *standard-input*)  (defun read-char-no-hang (&optional (stream *standard-input*)
549                                      (eof-errorp t) eof-value recursive-p)                                      (eof-errorp t) eof-value recursive-p)
550    "Returns the next character from the Stream if one is availible, or nil."    "Returns the next character from the Stream if one is available, or nil."
   (declare (ignore recursive-p))  
551    (let ((stream (in-synonym-of stream)))    (let ((stream (in-synonym-of stream)))
552      (if (lisp-stream-p stream)      (stream-dispatch stream
553          (if (funcall (lisp-stream-misc stream) stream :listen)        ;; simple-stream
554              ;; On t or :eof get READ-CHAR to do the work.        (stream::%read-char stream eof-errorp eof-value recursive-p nil)
555              (read-char stream eof-errorp eof-value)        ;; lisp-stream
556              nil)        (if (funcall (lisp-stream-misc stream) stream :listen)
557          ;; Fundamental-stream.            ;; On t or :eof get READ-CHAR to do the work.
558          (let ((char (stream-read-char-no-hang stream)))            (read-char stream eof-errorp eof-value)
559            (if (eq char :eof)            nil)
560                (eof-or-lose stream eof-errorp eof-value)        ;; fundamental-stream
561                char)))))        (let ((char (stream-read-char-no-hang stream)))
562            (if (eq char :eof)
563                (eof-or-lose stream eof-errorp eof-value)
564                char)))))
565    
566    
567  (defun clear-input (&optional (stream *standard-input*))  (defun clear-input (&optional (stream *standard-input*) buffer-only)
568    "Clears any buffered input associated with the Stream."    "Clears any buffered input associated with the Stream."
569    (declare (type streamlike stream))    (declare (type streamlike stream))
570    (let ((stream (in-synonym-of stream)))    (let ((stream (in-synonym-of stream)))
571      (cond ((lisp-stream-p stream)      (stream-dispatch stream
572             (setf (lisp-stream-in-index stream) in-buffer-length)        ;; simple-stream
573             (funcall (lisp-stream-misc stream) stream :clear-input))        (stream::%clear-input stream buffer-only)
574            (t        ;; lisp-stream
575             (stream-clear-input stream))))        (progn
576            (setf (lisp-stream-in-index stream) in-buffer-length)
577            (funcall (lisp-stream-misc stream) stream :clear-input))
578          ;; fundamental-stream
579          (stream-clear-input stream)))
580    nil)    nil)
581    
582  (defun read-byte (stream &optional (eof-errorp t) eof-value)  (defun read-byte (stream &optional (eof-errorp t) eof-value)
583    "Returns the next byte of the Stream."    "Returns the next byte of the Stream."
584    (declare (type stream stream))    (declare (type stream stream))
585    (let ((stream (in-synonym-of stream)))    (let ((stream (in-synonym-of stream)))
586      (if (lisp-stream-p stream)      (stream-dispatch stream
587          (prepare-for-fast-read-byte stream        ;; simple-stream
588            (prog1        (stream::%read-byte stream eof-errorp eof-value)
589                (fast-read-byte eof-errorp eof-value t)        ;; lisp-stream
590              (done-with-fast-read-byte)))        (prepare-for-fast-read-byte stream
591          ;; Fundamental-stream.          (prog1
592          (let ((char (stream-read-byte stream)))              (fast-read-byte eof-errorp eof-value t)
593            (if (eq char :eof)            (done-with-fast-read-byte)))
594                (eof-or-lose stream eof-errorp eof-value)        ;; fundamental-stream
595                char)))))        (let ((char (stream-read-byte stream)))
596            (if (eq char :eof)
597                (eof-or-lose stream eof-errorp eof-value)
598                char)))))
599    
600  (defun read-n-bytes (stream buffer start numbytes &optional (eof-errorp t))  (defun read-n-bytes (stream buffer start numbytes &optional (eof-errorp t))
601    "Reads Numbytes bytes into the Buffer starting at Start, returning the number    "Reads Numbytes bytes into the Buffer starting at Start, returning the number
602     of bytes read.     of bytes read.
603     -- If EOF-ERROR-P is true, an END-OF-FILE condition is signalled if     -- If EOF-ERROR-P is true, an END-OF-FILE condition is signalled if
604        end-of-file is encountered before Count bytes have been read.        end-of-file is encountered before Count bytes have been read.
605     -- If EOF-ERROR-P is false, READ-N-BYTES reads as much data is currently     -- If EOF-ERROR-P is false, READ-N-BYTES reads as much data as is currently
606        available (up to count bytes.)  On pipes or similar devices, this        available (up to count bytes).  On pipes or similar devices, this
607        function returns as soon as any adata is available, even if the amount        function returns as soon as any data is available, even if the amount
608        read is less than Count and eof has not been hit."        read is less than Count and eof has not been hit."
609    (declare (type lisp-stream stream)    (declare (type lisp-stream stream)
610             (type index numbytes start)             (type index numbytes start)
# Line 523  Line 616 
616      (declare (fixnum index num-buffered))      (declare (fixnum index num-buffered))
617      (cond      (cond
618       ((not in-buffer)       ((not in-buffer)
619        (funcall (lisp-stream-n-bin stream) stream buffer start numbytes eof-errorp))        (funcall (lisp-stream-n-bin stream) stream
620                   buffer start numbytes eof-errorp))
621       ((<= numbytes num-buffered)       ((<= numbytes num-buffered)
622        (%primitive byte-blt in-buffer index buffer start (+ start numbytes))        (%primitive byte-blt in-buffer index buffer start (+ start numbytes))
623        (setf (lisp-stream-in-index stream) (+ index numbytes))        (setf (lisp-stream-in-index stream) (+ index numbytes))
# Line 601  Line 695 
695  (defun write-char (character &optional (stream *standard-output*))  (defun write-char (character &optional (stream *standard-output*))
696    "Outputs the Character to the Stream."    "Outputs the Character to the Stream."
697    (declare (type streamlike stream))    (declare (type streamlike stream))
698    (with-out-stream stream (lisp-stream-out character)    (let ((stream (out-synonym-of stream)))
699                     (stream-write-char character))      (stream-dispatch stream
700          ;; simple-stream
701          (progn
702            (stream::%write-char stream character)
703            character)
704          ;; lisp-stream
705          (funcall (lisp-stream-out stream) stream character)
706          ;; fundamental-stream
707          (stream-write-char stream character)))
708    character)    character)
709    
710  (defun terpri (&optional (stream *standard-output*))  (defun terpri (&optional (stream *standard-output*))
711    "Outputs a new line to the Stream."    "Outputs a new line to the Stream."
712    (declare (type streamlike stream))    (declare (type streamlike stream))
713    (with-out-stream stream (lisp-stream-out #\newline) (stream-terpri))    (let ((stream (out-synonym-of stream)))
714        (stream-dispatch stream
715          ;; simple-stream
716          (stream::%write-char stream #\Newline)
717          ;; lisp-stream
718          (funcall (lisp-stream-out stream) stream #\Newline)
719          ;; fundamental-stream
720          (stream-terpri stream)))
721    nil)    nil)
722    
723  (defun fresh-line (&optional (stream *standard-output*))  (defun fresh-line (&optional (stream *standard-output*))
724    "Outputs a new line to the Stream if it is not positioned at the begining of    "Outputs a new line to the Stream if it is not positioned at the beginning of
725     a line.  Returns T if it output a new line, nil otherwise."     a line.  Returns T if it output a new line, nil otherwise."
726    (declare (type streamlike stream))    (declare (type streamlike stream))
727    (let ((stream (out-synonym-of stream)))    (let ((stream (out-synonym-of stream)))
728      (if (lisp-stream-p stream)      (stream-dispatch stream
729          (when (/= (or (charpos stream) 1) 0)        ;; simple-stream
730            (funcall (lisp-stream-out stream) stream #\newline)        (stream::%fresh-line stream)
731            t)        ;; lisp-stream
732          ;; Fundamental-stream.        (when (/= (or (charpos stream) 1) 0)
733          (stream-fresh-line stream))))          (funcall (lisp-stream-out stream) stream #\newline)
734            t)
735          ;; fundamental-stream
736          (stream-fresh-line stream))))
737    
738  (defun write-string (string &optional (stream *standard-output*)  (defun write-string (string &optional (stream *standard-output*)
739                              &key (start 0) end)                              &key (start 0) end)
# Line 630  Line 742 
742    
743  (defun write-string* (string &optional (stream *standard-output*)  (defun write-string* (string &optional (stream *standard-output*)
744                               (start 0) (end (length (the vector string))))                               (start 0) (end (length (the vector string))))
745    (declare (fixnum start end))    (declare (type streamlike stream) (fixnum start end))
746    (let ((stream (out-synonym-of stream)))    (let ((stream (out-synonym-of stream)))
747      (cond ((lisp-stream-p stream)      (stream-dispatch stream
748             (if (array-header-p string)        ;; simple-stream
749                 (with-array-data ((data string) (offset-start start)        (progn
750                                   (offset-end end))          (stream::%write-string stream string start end)
751                   (funcall (lisp-stream-sout stream)          string)
752                            stream data offset-start offset-end))        ;; lisp-stream
753                 (funcall (lisp-stream-sout stream) stream string start end))        (progn
754             string)          (if (array-header-p string)
755            (t    ; Fundamental-stream.              (with-array-data ((data string) (offset-start start)
756             (stream-write-string stream string start end)))))                                (offset-end end))
757                  (funcall (lisp-stream-sout stream)
758                           stream data offset-start offset-end))
759                (funcall (lisp-stream-sout stream) stream string start end))
760            string)
761          ;; fundamental-stream
762          (stream-write-string stream string start end))))
763    
764  (defun write-line (string &optional (stream *standard-output*)  (defun write-line (string &optional (stream *standard-output*)
765                            &key (start 0) (end (length string)))                            &key (start 0) (end (length string)))
# Line 650  Line 768 
768    
769  (defun write-line* (string &optional (stream *standard-output*)  (defun write-line* (string &optional (stream *standard-output*)
770                             (start 0) (end (length string)))                             (start 0) (end (length string)))
771    (declare (fixnum start end))    (declare (type streamlike stream) (fixnum start end))
772    (let ((stream (out-synonym-of stream)))    (let ((stream (out-synonym-of stream)))
773      (cond ((lisp-stream-p stream)      (stream-dispatch stream
774             (if (array-header-p string)        ;; simple-stream
775                 (with-array-data ((data string) (offset-start start)        (progn
776                                   (offset-end end))          (if (array-header-p string)
777                   (with-out-stream stream (lisp-stream-sout data offset-start              (with-array-data ((data string) (offset-start start)
778                                                             offset-end)))                                (offset-end end))
779                 (with-out-stream stream (lisp-stream-sout string start end)))                (stream::%write-string stream data offset-start offset-end))
780             (funcall (lisp-stream-out stream) stream #\newline))              (stream::%write-string stream string start end))
781            (t    ; Fundamental-stream.          (stream::%write-char stream #\Newline))
782             (stream-write-string stream string start end)        ;; lisp-stream
783             (stream-write-char stream #\Newline)))        (progn
784            (if (array-header-p string)
785                (with-array-data ((data string) (offset-start start)
786                                  (offset-end end))
787                  (funcall (lisp-stream-sout stream) stream data offset-start
788                                                            offset-end))
789                (funcall (lisp-stream-sout stream) stream string start end))
790            (funcall (lisp-stream-out stream) stream #\newline))
791          ;; fundamental-stream
792          (progn
793            (stream-write-string stream string start end)
794            (stream-write-char stream #\Newline)))
795      string))      string))
796    
797  (defun charpos (&optional (stream *standard-output*))  (defun charpos (&optional (stream *standard-output*))
798    "Returns the number of characters on the current line of output of the given    "Returns the number of characters on the current line of output of the given
799    Stream, or Nil if that information is not availible."    Stream, or Nil if that information is not availible."
800    (with-out-stream stream (lisp-stream-misc :charpos) (stream-line-column)))    (declare (type streamlike stream))
801      (let ((stream (out-synonym-of stream)))
802        (stream-dispatch stream
803          ;; simple-stream
804          (stream::%charpos stream)
805          ;; lisp-stream
806          (funcall (lisp-stream-misc stream) stream :charpos)
807          ;; fundamental-stream
808          (stream-line-column stream))))
809    
810  (defun line-length (&optional (stream *standard-output*))  (defun line-length (&optional (stream *standard-output*))
811    "Returns the number of characters that will fit on a line of output on the    "Returns the number of characters that will fit on a line of output on the
812    given Stream, or Nil if that information is not available."    given Stream, or Nil if that information is not available."
813    (with-out-stream stream (lisp-stream-misc :line-length)    (declare (type streamlike stream))
814                     (stream-line-length)))    (let ((stream (out-synonym-of stream)))
815        (stream-dispatch stream
816          ;; simple-stream
817          (stream::%line-length stream)
818          ;; lisp-stream
819          (funcall (lisp-stream-misc stream) stream :line-length)
820          ;; fundamental-stream
821          (stream-line-length stream))))
822    
823  (defun finish-output (&optional (stream *standard-output*))  (defun finish-output (&optional (stream *standard-output*))
824    "Attempts to ensure that all output sent to the Stream has reached its    "Attempts to ensure that all output sent to the Stream has reached its
825     destination, and only then returns."     destination, and only then returns."
826    (declare (type streamlike stream))    (declare (type streamlike stream))
827    (with-out-stream stream (lisp-stream-misc :finish-output)    (let ((stream (out-synonym-of stream)))
828                     (stream-finish-output))      (stream-dispatch stream
829          ;; simple-stream
830          (stream::%finish-output stream)
831          ;; lisp-stream
832          (funcall (lisp-stream-misc stream) stream :finish-output)
833          ;; fundamental-stream
834          (stream-finish-output stream)))
835    nil)    nil)
836    
837  (defun force-output (&optional (stream *standard-output*))  (defun force-output (&optional (stream *standard-output*))
838    "Attempts to force any buffered output to be sent."    "Attempts to force any buffered output to be sent."
839    (declare (type streamlike stream))    (declare (type streamlike stream))
840    (with-out-stream stream (lisp-stream-misc :force-output)    (let ((stream (out-synonym-of stream)))
841                     (stream-force-output))      (stream-dispatch stream
842          ;; simple-stream
843          (stream::%force-output stream)
844          ;; lisp-stream-misc
845          (funcall (lisp-stream-misc stream) stream :force-output)
846          ;; fundamental-stream
847          (stream-force-output stream)))
848    nil)    nil)
849    
850  (defun clear-output (&optional (stream *standard-output*))  (defun clear-output (&optional (stream *standard-output*))
851    "Clears the given output Stream."    "Clears the given output Stream."
852    (declare (type streamlike stream))    (declare (type streamlike stream))
853    (with-out-stream stream (lisp-stream-misc :clear-output)    (let ((stream (out-synonym-of stream)))
854                     (stream-force-output))      (stream-dispatch stream
855          ;; simple-stream
856          (stream::%clear-output stream)
857          ;; lisp-stream
858          (funcall (lisp-stream-misc stream) stream :clear-output)
859          ;; fundamental-stream
860          (stream-force-output stream)))
861    nil)    nil)
862    
863  (defun write-byte (integer stream)  (defun write-byte (integer stream)
864    "Outputs the Integer to the binary Stream."    "Outputs the Integer to the binary Stream."
865    (declare (type stream stream))    (declare (type stream stream))
866    (with-out-stream stream (lisp-stream-bout integer)    (let ((stream (out-synonym-of stream)))
867                     (stream-write-byte integer))      (stream-dispatch stream
868          ;; simple-stream
869          (stream::%write-byte stream integer)
870          ;; lisp-stream
871          (funcall (lisp-stream-bout stream) stream integer)
872          ;; fundamental-stream
873          (stream-write-byte stream integer)))
874    integer)    integer)
875    
876    
877  ;;; Stream-misc-dispatch  ;;; Stream-misc-dispatch
878  ;;;  ;;;
879  ;;; Called from lisp-steam routines that encapsulate CLOS streams to  ;;; Called from lisp-stream routines that encapsulate CLOS streams to
880  ;;; handle the misc routines and dispatch to the appropriate Gray  ;;; handle the misc routines and dispatch to the appropriate Gray
881  ;;; stream functions.  ;;; stream functions.
882  ;;;  ;;;
# Line 774  streams." Line 942  streams."
942  (macrolet ((out-fun (fun method stream-method &rest args)  (macrolet ((out-fun (fun method stream-method &rest args)
943               `(defun ,fun (stream ,@args)               `(defun ,fun (stream ,@args)
944                  (dolist (stream (broadcast-stream-streams stream))                  (dolist (stream (broadcast-stream-streams stream))
945                    (if (lisp-stream-p stream)                    (stream-dispatch stream
946                        (funcall (,method stream) stream ,@args)                      ;; simple-stream
947                        (,stream-method stream ,@args))))))                      (,stream-method stream ,@args) ; use gray-compat for now
948                        ;; lisp-stream
949                        (funcall (,method stream) stream ,@args)
950                        ;; fundamental-stream
951                        (,stream-method stream ,@args))))))
952    (out-fun broadcast-out lisp-stream-out stream-write-char char)    (out-fun broadcast-out lisp-stream-out stream-write-char char)
953    (out-fun broadcast-bout lisp-stream-bout stream-write-byte byte)    (out-fun broadcast-bout lisp-stream-bout stream-write-byte byte)
954    (out-fun broadcast-sout lisp-stream-sout stream-write-string    (out-fun broadcast-sout lisp-stream-sout stream-write-string
# Line 1279  output to Output-stream" Line 1451  output to Output-stream"
1451    (write-string "#<String-Output Stream>" stream))    (write-string "#<String-Output Stream>" stream))
1452    
1453  (setf (documentation 'make-string-output-stream 'function)  (setf (documentation 'make-string-output-stream 'function)
1454    "Returns an Output stream which will accumulate all output given it for    "Returns an Output stream which will accumulate all output given to it for
1455     the benefit of the function Get-Output-Stream-String.")     the benefit of the function Get-Output-Stream-String.")
1456    
1457  (defun string-ouch (stream character)  (defun string-ouch (stream character)
# Line 1454  output to Output-stream" Line 1626  output to Output-stream"
1626    (declare (ignore s d))    (declare (ignore s d))
1627    (write-string "#<Indenting Stream>" stream))    (write-string "#<Indenting Stream>" stream))
1628    
1629  ;;; Indenting-Indent writes the right number of spaces needed to indent output on  ;;; Indenting-Indent writes the right number of spaces needed to indent
1630  ;;; the given Stream based on the specified Sub-Stream.  ;;; output on the given Stream based on the specified Sub-Stream.
1631    
1632  (defmacro indenting-indent (stream sub-stream)  (defmacro indenting-indent (stream sub-stream)
1633    `(do ((i 0 (+ i 60))    `(do ((i 0 (+ i 60))
# Line 1801  output to Output-stream" Line 1973  output to Output-stream"
1973  ;;; subtypes of SIMPLE-ARRAY.  Hence the distinction between simple  ;;; subtypes of SIMPLE-ARRAY.  Hence the distinction between simple
1974  ;;; and non simple input functions.  ;;; and non simple input functions.
1975    
1976  (defun read-sequence (seq stream &key (start 0) (end nil))  (defun read-sequence (seq stream &key (start 0) (end nil) partial-fill)
1977    "Destructively modify SEQ by reading elements from STREAM.    "Destructively modify SEQ by reading elements from STREAM.
1978  SEQ is bounded by START and END. SEQ is destructively modified by  SEQ is bounded by START and END. SEQ is destructively modified by
1979  copying successive elements into it from STREAM. If the end of file  copying successive elements into it from STREAM. If the end of file
# Line 1827  POSITION: an INTEGER greater than or equ Line 1999  POSITION: an INTEGER greater than or equ
1999    (declare (type (or null (integer 0 *)) end))    (declare (type (or null (integer 0 *)) end))
2000    (declare (values (integer 0 *)))    (declare (values (integer 0 *)))
2001    
2002    (when (not (cl::lisp-stream-p stream))    (stream-dispatch stream
2003       (return-from read-sequence (stream-read-sequence stream seq start end)))      ;; simple-stream
2004        (stream::%read-sequence stream seq start end partial-fill)
2005    (let ((end (or end (length seq))))      ;; lisp-stream
2006      (declare (type (integer 0 *) start end))      (let ((end (or end (length seq))))
2007          (declare (type (integer 0 *) start end))
2008      ;; Just catch some errors earlier than it would be necessary.  
2009      (cond ((not (open-stream-p stream))        ;; Just catch some errors earlier than it would be necessary.
2010             (error 'stream-error        (cond ((not (open-stream-p stream))
2011                    :stream stream               (error 'stream-error
2012                    :format-control "The stream is not open."))                      :stream stream
2013            ((not (input-stream-p stream))                      :format-control "The stream is not open."))
2014             (error 'stream-error              ((not (input-stream-p stream))
2015                    :stream stream               (error 'stream-error
2016                    :format-control "The stream is not open for input."))                      :stream stream
2017            ((and seq (>= start end) 0))                      :format-control "The stream is not open for input."))
2018            (t              ((and seq (>= start end) 0))
2019             ;; So much for object-oriented programming!              (t
2020             (etypecase seq               ;; So much for object-oriented programming!
2021               (list               (etypecase seq
2022                (read-into-list seq stream start end))                 (list
2023               (simple-string                  (read-into-list seq stream start end))
2024                (read-into-simple-string seq stream start end))                 (simple-string
2025               (string                  (read-into-simple-string seq stream start end))
2026                (read-into-string seq stream start end))                 (string
2027               (simple-array              ; We also know that it is a 'vector'.                  (read-into-string seq stream start end))
2028                (read-into-simple-array seq stream start end))                 (simple-array            ; We also know that it is a 'vector'.
2029               (vector                  (read-into-simple-array seq stream start end))
2030                (read-into-vector seq stream start end)))                 (vector
2031             ))))                  (read-into-vector seq stream start end)))
2032                 )))
2033        ;; fundamental-stream
2034        (stream-read-sequence stream seq start end)))
2035    
2036    
2037  ;;; READ-INTO-LIST, READ-INTO-LIST-1  ;;; READ-INTO-LIST, READ-INTO-LIST-1
# Line 2004  POSITION: an INTEGER greater than or equ Line 2179  POSITION: an INTEGER greater than or equ
2179      ;; What is the purpose of this explicit test for characters?  It      ;; What is the purpose of this explicit test for characters?  It
2180      ;; prevents reading a string-stream into a vector, like the      ;; prevents reading a string-stream into a vector, like the
2181      ;; example in the CLHS.      ;; example in the CLHS.
2182      (cond #+nil      (cond #+(or)
2183            ((subtypep (stream-element-type stream) 'character)            ((subtypep (stream-element-type stream) 'character)
2184             (error 'type-error             (error 'type-error
2185                    :datum (read-byte stream nil 0)                    :datum (read-byte stream nil 0)
# Line 2142  SEQ:   a proper SEQUENCE Line 2317  SEQ:   a proper SEQUENCE
2317    (declare (type (or null (integer 0 *)) end))    (declare (type (or null (integer 0 *)) end))
2318    (declare (values (or list vector)))    (declare (values (or list vector)))
2319    
2320    (when (not (cl::lisp-stream-p stream))    (stream-dispatch stream
2321      (return-from write-sequence (stream-write-sequence stream seq start end)))      ;; simple-stream
2322        (stream::%write-sequence stream seq start end)
2323    (let ((end (or end (length seq))))      ;; lisp-stream
2324      (declare (type (integer 0 *) start end))      (let ((end (or end (length seq))))
2325          (declare (type (integer 0 *) start end))
2326      ;; Just catch some errors earlier than it would be necessary.  
2327      (cond ((not (open-stream-p stream))        ;; Just catch some errors earlier than it would be necessary.
2328             (error 'stream-error        (cond ((not (open-stream-p stream))
2329                    :stream stream               (error 'stream-error
2330                    :format-control "The stream is not open."))                      :stream stream
2331            ((not (output-stream-p stream))                      :format-control "The stream is not open."))
2332             (error 'stream-error              ((not (output-stream-p stream))
2333                    :stream stream               (error 'stream-error
2334                    :format-control "The stream is not open for output."))                      :stream stream
2335            ((and seq (>= start end)) seq)                      :format-control "The stream is not open for output."))
2336            (t              ((and seq (>= start end)) seq)
2337             ;; So much for object-oriented programming!              (t
2338             ;; Note: order of type clauses is very important.  As a               ;; So much for object-oriented programming!
2339             ;; matter of fact it is patterned after the class               ;; Note: order of type clauses is very important.  As a
2340             ;; precedence list of each of the types listed.               ;; matter of fact it is patterned after the class
2341             (etypecase seq               ;; precedence list of each of the types listed.
2342               (list               (etypecase seq
2343                (write-list-out seq stream start end))                 (list
2344               (simple-string                  (write-list-out seq stream start end))
2345                (write-simple-string-out seq stream start end))                 (simple-string
2346               (string                  (write-simple-string-out seq stream start end))
2347                (write-string-out seq stream start end))                 (string
2348               (simple-vector             ; This is necessary because of                  (write-string-out seq stream start end))
2349                   (simple-vector           ; This is necessary because of
2350                                          ; the underlying behavior of                                          ; the underlying behavior of
2351                                          ; OUTPUT-RAW-BYTES.  A vector                                          ; OUTPUT-RAW-BYTES.  A vector
2352                                          ; produced by VECTOR has                                          ; produced by VECTOR has
2353                                          ; element-type T in CMUCL.                                          ; element-type T in CMUCL.
2354                (write-vector-out seq stream start end))                  (write-vector-out seq stream start end))
2355               (simple-array              ; We know it is also a vector!                 (simple-array            ; We know it is also a vector!
2356                (write-simple-array-out seq stream start end))                  (write-simple-array-out seq stream start end))
2357               (vector                 (vector
2358                (write-vector-out seq stream start end)))                  (write-vector-out seq stream start end)))
2359             ))))               )))
2360        ;; fundamental-stream
2361        (stream-write-sequence stream seq start end))
2362      seq)
2363    
2364    
2365  ;;; The following functions operate under one - possibly wrong -  ;;; The following functions operate under one - possibly wrong -

Legend:
Removed from v.1.60  
changed lines
  Added in v.1.61

  ViewVC Help
Powered by ViewVC 1.1.5