/[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.17 by wlott, Fri Feb 12 20:21:44 1993 UTC revision 1.17.1.1 by ram, Tue Feb 23 16:13:06 1993 UTC
# Line 37  Line 37 
37            *standard-input* *standard-output*            *standard-input* *standard-output*
38            *error-output* *query-io* *debug-io* *terminal-io* *trace-output*))            *error-output* *query-io* *debug-io* *terminal-io* *trace-output*))
39    
40  (in-package 'system)  (in-package "SYSTEM")
41  (export '(make-indenting-stream read-n-bytes))  (export '(make-indenting-stream read-n-bytes))
42  (in-package 'lisp)  
43    (in-package "EXT")
44    
45    (export '(get-stream-command
46              stream-command stream-command-p stream-command-name
47              stream-command-args make-stream-command make-case-frob-stream))
48    
49    (in-package "LISP")
50    
51  (deftype string-stream ()  (deftype string-stream ()
52    '(or string-input-stream string-output-stream    '(or string-input-stream string-output-stream
# Line 101  Line 108 
108  ;;; are handled by just one function, the Misc method.  This function  ;;; are handled by just one function, the Misc method.  This function
109  ;;; is passed a keyword which indicates the operation to perform.  ;;; is passed a keyword which indicates the operation to perform.
110  ;;; The following keywords are used:  ;;; The following keywords are used:
 ;;;  :read-line         - Do a read-line.  
111  ;;;  :listen            - Return the following values:  ;;;  :listen            - Return the following values:
112  ;;;                          t if any input waiting.  ;;;                          t if any input waiting.
113  ;;;                          :eof if at eof.  ;;;                          :eof if at eof.
# Line 115  Line 121 
121  ;;;  :finish-output,  ;;;  :finish-output,
122  ;;;  :force-output      - Cause output to happen  ;;;  :force-output      - Cause output to happen
123  ;;;  :clear-output      - Clear any undone output  ;;;  :clear-output      - Clear any undone output
124  ;;;  :element-type      - Return the type of element the stream deals with.  ;;;  :element-type      - Return the type of element the stream deals wit<h.
125  ;;;  :line-length       - Return the length of a line of output.  ;;;  :line-length       - Return the length of a line of output.
126  ;;;  :charpos           - Return current output position on the line.  ;;;  :charpos           - Return current output position on the line.
127  ;;;  :file-length       - Return the file length of a file stream.  ;;;  :file-length       - Return the file length of a file stream.
# Line 153  Line 159 
159  ;;;    If a stream does not have an In-Buffer, then the In-Buffer slot  ;;;    If a stream does not have an In-Buffer, then the In-Buffer slot
160  ;;; must be nil, and the In-Index must be In-Buffer-Length.  These are  ;;; must be nil, and the In-Index must be In-Buffer-Length.  These are
161  ;;; the default values for the slots.  ;;; the default values for the slots.
162    
163    
164  ;;; Stream manipulation functions.  ;;; Stream manipulation functions.
165    
# Line 208  Line 215 
215    (setf (stream-bout stream) #'closed-flame)    (setf (stream-bout stream) #'closed-flame)
216    (setf (stream-sout stream) #'closed-flame)    (setf (stream-sout stream) #'closed-flame)
217    (setf (stream-misc stream) #'closed-flame))    (setf (stream-misc stream) #'closed-flame))
218    
219    
220    ;;;; File position and file length.
221    
222    ;;; File-Position  --  Public
223    ;;;
224    ;;;    Call the misc method with the :file-position operation.
225    ;;;
226    (defun file-position (stream &optional position)
227      "With one argument returns the current position within the file
228      File-Stream is open to.  If the second argument is supplied, then
229      this becomes the new file position.  The second argument may also
230      be :start or :end for the start and end of the file, respectively."
231      (declare (stream stream) (type (or index null) position))
232      (cond
233       (position
234        (setf (stream-in-index stream) in-buffer-length)
235        (funcall (stream-misc stream) stream :file-position position))
236       (t
237        (let ((res (funcall (stream-misc stream) stream :file-position nil)))
238          (when res (+ res (- in-buffer-length (stream-in-index stream))))))))
239    
240    
241    ;;; File-Length  --  Public
242    ;;;
243    ;;;    Like File-Position, only use :file-length.
244    ;;;
245    (defun file-length (stream)
246      "This function returns the length of the file that File-Stream is open to."
247      (declare (stream stream))
248      (funcall (stream-misc stream) stream :file-length))
249    
250    
251  ;;; Input functions:  ;;; Input functions:
252    
# Line 216  Line 255 
255    "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
256    newline character."    newline character."
257    (declare (ignore recursive-p))    (declare (ignore recursive-p))
258    (let* ((stream (in-synonym-of stream))    (prepare-for-fast-read-char stream
259           (buffer (stream-in-buffer stream))      (let ((res (make-string 80))
260           (index (stream-in-index stream)))            (len 80)
261      (declare (fixnum index))            (index 0))
262      (if (simple-string-p buffer)        (loop
263          (let ((nl (%sp-find-character buffer index in-buffer-length          (let ((ch (fast-read-char nil nil)))
264                                        #\newline)))            (cond (ch
265            (if nl                   (when (char= ch #\newline)
266                (values (prog1 (subseq (the simple-string buffer) index nl)                     (return (values (shrink-vector res index) nil)))
267                               (setf (stream-in-index stream)                   (when (= index len)
268                                     (1+ (the fixnum nl))))                     (setq len (* len 2))
269                        nil)                     (let ((new (make-string len)))
270                (multiple-value-bind (str eofp)                       (replace new res)
271                                     (funcall (stream-misc stream) stream                       (setq res new)))
272                                              :read-line eof-errorp eof-value)                   (setf (schar res index) ch)
273                  (if (= index in-buffer-length)                   (incf index))
274                      (values str eofp)                  ((zerop index)
275                      (let ((first (subseq buffer index in-buffer-length)))                   (done-with-fast-read-char)
276                        (setf (stream-in-index stream) in-buffer-length)                   (return (funcall (stream-in stream) stream
277                        (if (eq str eof-value)                                    eof-errorp eof-value)))
278                            (values first t)                  (t
279                            (values (concatenate 'simple-string first                   (done-with-fast-read-char)
280                                                 (the simple-string str))                   (return (values (shrink-vector res index) t)))))))))
                                   eofp)))))))  
         (funcall (stream-misc stream) stream :read-line eof-errorp  
                  eof-value))))  
281    
282    
283  ;;; We proclaim them inline here, then proclaim them notinline at EOF,  ;;; We proclaim them inline here, then proclaim them notinline at EOF,
# Line 252  Line 288 
288                              recursive-p)                              recursive-p)
289    "Inputs a character from Stream and returns it."    "Inputs a character from Stream and returns it."
290    (declare (ignore recursive-p))    (declare (ignore recursive-p))
291    (let* ((stream (in-synonym-of stream))    (prepare-for-fast-read-char stream
292           (index (stream-in-index stream)))      (prog1
293      (declare (fixnum index))          (fast-read-char eof-errorp eof-value)
294      (if (eql index in-buffer-length)        (done-with-fast-read-char))))
         (funcall (stream-in stream) stream eof-errorp eof-value)  
         (prog1 (aref (stream-in-buffer stream) index)  
                (setf (stream-in-index stream) (1+ index))))))  
295    
296  (defun unread-char (character &optional (stream *standard-input*))  (defun unread-char (character &optional (stream *standard-input*))
297    "Puts the Character back on the front of the input Stream."    "Puts the Character back on the front of the input Stream."
298    (let* ((stream (in-synonym-of stream))    (let* ((stream (in-synonym-of stream))
299           (index (1- (the fixnum (stream-in-index stream))))           (index (1- (stream-in-index stream)))
300           (buffer (stream-in-buffer stream)))           (buffer (stream-in-buffer stream)))
301      (declare (fixnum index))      (declare (fixnum index))
302      (when (minusp index) (error "Nothing to unread."))      (when (minusp index) (error "Nothing to unread."))
303      (if buffer      (cond (buffer
304          (setf (aref (the simple-array buffer) index) character             (setf (aref buffer index) (char-code character))
305                (stream-in-index stream) index)             (setf (stream-in-index stream) index))
306          (funcall (stream-misc stream) stream :unread character)))            (t
307               (funcall (stream-misc stream) stream :unread character))))
308    nil)    nil)
309    
310  (defun peek-char (&optional (peek-type nil) (stream *standard-input*)  (defun peek-char (&optional (peek-type nil) (stream *standard-input*)
# Line 322  Line 356 
356    
357  (defun read-byte (stream &optional (eof-errorp t) eof-value)  (defun read-byte (stream &optional (eof-errorp t) eof-value)
358    "Returns the next byte of the Stream."    "Returns the next byte of the Stream."
359    (let* ((stream (in-synonym-of stream))    (prepare-for-fast-read-byte stream
360           (index (stream-in-index stream)))      (prog1
361      (declare (fixnum index))          (fast-read-byte eof-errorp eof-value)
362      (if (eql index in-buffer-length)        (done-with-fast-read-byte))))
         (funcall (stream-bin stream) stream eof-errorp eof-value)  
         (prog1 (aref (stream-in-buffer stream) index)  
                (setf (stream-in-index stream) (1+ index))))))  
363    
364  (defun read-n-bytes (stream buffer start numbytes &optional (eof-errorp t))  (defun read-n-bytes (stream buffer start numbytes &optional (eof-errorp t))
365    "Reads Numbytes bytes into the Buffer starting at Start, and returns    "Reads Numbytes bytes into the Buffer starting at Start, and returns
366    the number of bytes actually read if the end of file was hit before Numbytes     the number of bytes actually read if the end of file was hit before Numbytes
367    bytes were read (and Eof-Errorp is false)."     bytes were read (and Eof-Errorp is false)."
368    (declare (fixnum numbytes))    (declare (type index numbytes start)
369               (type (or simple-string (simple-array (unsigned-byte 8) (*)))
370                     buffer))
371    (let* ((stream (in-synonym-of stream))    (let* ((stream (in-synonym-of stream))
372           (in-buffer (stream-in-buffer stream))           (in-buffer (stream-in-buffer stream))
373           (index (stream-in-index stream))           (index (stream-in-index stream))
# Line 342  Line 375 
375      (declare (fixnum index num-buffered))      (declare (fixnum index num-buffered))
376      (cond      (cond
377       ((not in-buffer)       ((not in-buffer)
378        (with-in-stream stream stream-n-bin buffer start numbytes eof-errorp))        (funcall (stream-n-bin stream) stream buffer start numbytes eof-errorp))
      ((not (typep in-buffer  
                   '(or simple-string (simple-array (unsigned-byte 8) (*)))))  
       (error "N-Bin only works on 8-bit-like streams."))  
379       ((<= numbytes num-buffered)       ((<= numbytes num-buffered)
380        (%primitive byte-blt in-buffer index buffer start (+ start numbytes))        (%primitive byte-blt in-buffer index buffer start (+ start numbytes))
381        (setf (stream-in-index stream) (+ index numbytes))        (setf (stream-in-index stream) (+ index numbytes))
# Line 354  Line 384 
384        (let ((end (+ start num-buffered)))        (let ((end (+ start num-buffered)))
385          (%primitive byte-blt in-buffer index buffer start end)          (%primitive byte-blt in-buffer index buffer start end)
386          (setf (stream-in-index stream) in-buffer-length)          (setf (stream-in-index stream) in-buffer-length)
387          (+ (with-in-stream stream stream-n-bin buffer end          (+ (funcall (stream-n-bin stream) stream buffer end
388                                     (- numbytes num-buffered)                      (- numbytes num-buffered)
389                                     eof-errorp)                      eof-errorp)
390             num-buffered))))))             num-buffered))))))
391    
392    
393    ;;; Amount of space we leave at the start of the in-buffer for unreading.  4
394    ;;; instead of 1 to allow word-aligned copies.
395    ;;;
396    (defconstant in-buffer-extra 4)
397    
398    ;;; FAST-READ-CHAR-REFILL  --  Interface
399    ;;;
400    ;;;    This function is called by the fast-read-char expansion to refill the
401    ;;; in-buffer for text streams.  There is definitely an in-buffer, and hence
402    ;;; myst be an n-bin method.
403    ;;;
404    (defun fast-read-char-refill (stream eof-errorp eof-value)
405      (let* ((ibuf (stream-in-buffer stream))
406             (count (funcall (stream-n-bin stream) stream
407                             ibuf in-buffer-extra
408                             (- in-buffer-length in-buffer-extra)
409                             nil))
410             (start (- in-buffer-length count)))
411        (declare (type index start count))
412        (cond ((zerop count)
413               (funcall (stream-in stream) stream eof-errorp eof-value))
414              (t
415               (when (/= start in-buffer-extra)
416                 (%primitive byte-blt ibuf in-buffer-extra ibuf start count))
417               (prog1
418                   (code-char (aref ibuf start))
419                 (setf (stream-in-index stream) (1+ start)))))))
420    
421    
422    ;;; FAST-READ-BYTE-REFILL  --  Interface
423    ;;;
424    ;;;    Similar to FAST-READ-CHAR-REFILL, but we don't have to leave room for
425    ;;; unreading.
426    ;;;
427    (defun fast-read-byte-refill (stream eof-errorp eof-value)
428      (let* ((ibuf (stream-in-buffer stream))
429             (count (funcall (stream-n-bin stream) stream
430                             ibuf 0 in-buffer-length
431                             nil))
432             (start (- in-buffer-length count)))
433        (declare (type index start count))
434        (cond ((zerop count)
435               (funcall (stream-bin stream) stream eof-errorp eof-value))
436              (t
437               (unless (zerop start)
438                 (%primitive byte-blt ibuf 0 ibuf start count))
439               (prog1
440                   (aref ibuf start)
441                 (setf (stream-in-index stream) (1+ start)))))))
442    
443    
444  ;;; Output functions:  ;;; Output functions:
445    
# Line 555  Line 637 
637    (let ((syn (symbol-value (synonym-stream-symbol stream)))    (let ((syn (symbol-value (synonym-stream-symbol stream)))
638          (*previous-stream* stream))          (*previous-stream* stream))
639      (case operation      (case operation
       (:read-line (read-line syn))  
640        (:listen (or (/= (the fixnum (stream-in-index syn)) in-buffer-length)        (:listen (or (/= (the fixnum (stream-in-index syn)) in-buffer-length)
641                     (funcall (stream-misc syn) syn :listen)))                     (funcall (stream-misc syn) syn :listen)))
642        (t        (t
# Line 613  Line 694 
694      (case operation      (case operation
695        (:listen (or (/= (the fixnum (stream-in-index in)) in-buffer-length)        (:listen (or (/= (the fixnum (stream-in-index in)) in-buffer-length)
696                     (funcall in-method in :listen)))                     (funcall in-method in :listen)))
       (:read-line  
        (force-output out)  
        (read-line in arg1 arg2))  
697        ((:finish-output :force-output :clear-output)        ((:finish-output :force-output :clear-output)
698         (funcall out-method out operation arg1 arg2))         (funcall out-method out operation arg1 arg2))
699        ((:clear-input :unread)        ((:clear-input :unread)
# Line 669  Line 747 
747                    (setf (concatenated-stream-current stream) current)))))                    (setf (concatenated-stream-current stream) current)))))
748    (in-fun concatenated-in read-char)    (in-fun concatenated-in read-char)
749    (in-fun concatenated-bin read-byte))    (in-fun concatenated-bin read-byte))
   
 ;;;    Concatenated-Readline is somewhat hairy, since we may need to  
 ;;; do several readlines and concatenate the result if the lines are  
 ;;; terminated by eof.  
 ;;;  
 (defun concatenated-readline (stream eof-errorp eof-value)  
   ;; Loop until we find a stream that will give us something or we error  
   ;; out.  
   (do ((current (concatenated-stream-current stream) (cdr current)))  
       ((null current)  
        (eof-or-lose stream eof-errorp eof-value))  
     (setf (concatenated-stream-current stream) current)  
     (let ((this (car current)))  
       (multiple-value-bind (result eofp)  
                            (read-line this nil :eof)  
         (declare (type (or simple-string (member :eof)) result))  
         ;; Once we have found some input, we loop until we either find a  
         ;; line not terminated by eof or hit eof on the last stream.  
         (unless (eq result :eof)  
           (do ((current (cdr current) (cdr current))  
                (new ""))  
               ((or (not eofp) (null current))  
                (return-from concatenated-readline (values result eofp)))  
             (declare (type (or simple-string (member :eof)) new))  
             (setf (concatenated-stream-current stream) current)  
             (let ((this (car current)))  
               (multiple-value-setq (new eofp)  
                 (read-line this nil :eof))  
               (if (eq new :eof)  
                   (setq eofp t)  
                   (setq result (concatenate 'simple-string result new))))))))))  
750    
751  (defun concatenated-misc (stream operation &optional arg1 arg2)  (defun concatenated-misc (stream operation &optional arg1 arg2)
752    (if (eq operation :read-line)    (let ((left (concatenated-stream-current stream)))
753        (concatenated-readline stream arg1 arg2)      (when left
754        (let ((left (concatenated-stream-current stream)))        (let* ((current (car left))
755          (when left               (misc (stream-misc current)))
756            (let* ((current (car left))          (case operation
757                   (misc (stream-misc current)))            (:listen
758              (case operation             (loop
759                (:listen               (let ((stuff (funcall misc current :listen)))
760                 (loop                 (cond ((eq stuff :eof)
761                   (let ((stuff (funcall misc current :listen)))                        ;; Advance current, and try again.
762                     (cond ((eq stuff :eof)                        (pop (concatenated-stream-current stream))
763                            ;; Advance current, and try again.                        (setf current
764                            (pop (concatenated-stream-current stream))                              (car (concatenated-stream-current stream)))
765                            (setf current                        (unless current
766                                  (car (concatenated-stream-current stream)))                          ;; No further streams.  EOF.
767                            (unless current                          (return :eof))
768                              ;; No further streams.  EOF.                        (setf misc (stream-misc current)))
769                              (return :eof))                       (stuff
770                            (setf misc (stream-misc current)))                        ;; Stuff's available.
771                           (stuff                        (return t))
772                            ;; Stuff's available.                       (t
773                            (return t))                        ;; Nothing available yet.
774                           (t                        (return nil))))))
775                            ;; Nothing available yet.            (:close
776                            (return nil))))))             (dolist (stream (concatenated-stream-streams stream))
777                (:close               (funcall (stream-misc stream) stream :close arg1))
778                 (dolist (stream (concatenated-stream-streams stream))             (set-closed-flame stream))
779                   (funcall (stream-misc stream) stream :close arg1))            (t
780                 (set-closed-flame stream))             (funcall misc current operation arg1 arg2)))))))
               (t  
                (funcall misc current operation arg1 arg2))))))))  
781    
782  ;;;; Echo Streams:  ;;;; Echo Streams:
783    
# Line 768  Line 813 
813                     (/= (the fixnum (stream-in-index in)) in-buffer-length)                     (/= (the fixnum (stream-in-index in)) in-buffer-length)
814                     (funcall in-method in :listen)))                     (funcall in-method in :listen)))
815        (:unread (push arg1 (echo-stream-unread-stuff stream)))        (:unread (push arg1 (echo-stream-unread-stuff stream)))
       (:read-line  
        (let* ((stuff (echo-stream-unread-stuff stream))  
               (newline-pos (position #\newline stuff)))  
          (if newline-pos  
              (progn  
                (setf (echo-stream-unread-stuff stream)  
                      (subseq stuff (1+ newline-pos)))  
                (values (coerce (subseq stuff 0 newline-pos) 'simple-string)  
                        nil))  
              (multiple-value-bind (result eofp)  
                                   (read-line in arg1 arg2)  
                (if eofp  
                    (write-string result out)  
                    (write-line result out))  
                (setf (echo-stream-unread-stuff stream) nil)  
                (values (if stuff  
                            (concatenate 'simple-string stuff result)  
                            result)  
                        eofp)))))  
816        (:element-type        (:element-type
817         (let ((in-type (funcall in-method in :element-type))         (let ((in-type (funcall in-method in :element-type))
818               (out-type (funcall out-method out :element-type)))               (out-type (funcall out-method out :element-type)))
# Line 840  Line 866 
866             (aref string index)))))             (aref string index)))))
867    
868  (defun string-in-misc (stream operation &optional arg1 arg2)  (defun string-in-misc (stream operation &optional arg1 arg2)
869      (declare (ignore arg2))
870    (case operation    (case operation
871      (:file-position      (:file-position
872       (if arg1       (if arg1
873           (setf (string-input-stream-current stream) arg1)           (setf (string-input-stream-current stream) arg1)
874           (string-input-stream-current stream)))           (string-input-stream-current stream)))
875      (:file-length (length (string-input-stream-string stream)))      (:file-length (length (string-input-stream-string stream)))
     (:read-line  
      (let ((string (string-input-stream-string stream))  
            (current (string-input-stream-current stream))  
            (end (string-input-stream-end stream)))  
        (declare (simple-string string) (fixnum current end))  
        (if (= current end)  
            (eof-or-lose stream arg1 arg2)  
            (let ((pos (position #\newline string :start current :end end)))  
              (if pos  
                  (let* ((res-length (- (the fixnum pos) current))  
                         (result (make-string res-length)))  
                    (%primitive byte-blt string current result 0 res-length)  
                    (setf (string-input-stream-current stream)  
                          (1+ (the fixnum pos)))  
                    (values result nil))  
                  (let* ((res-length (- end current))  
                         (result (make-string res-length)))  
                    (%primitive byte-blt string current result 0 res-length)  
                    (setf (string-input-stream-current stream) end)  
                    (values result t)))))))  
876      (:unread (decf (string-input-stream-current stream)))      (:unread (decf (string-input-stream-current stream)))
877      (:listen (or (/= (the fixnum (string-input-stream-current stream))      (:listen (or (/= (the fixnum (string-input-stream-current stream))
878                       (the fixnum (string-input-stream-end stream)))                       (the fixnum (string-input-stream-end stream)))
# Line 878  Line 885 
885    Start and End in order."    Start and End in order."
886    (declare (type string string)    (declare (type string string)
887             (type index start)             (type index start)
888             (or (index null) end))             (type (or index null) end))
889    (internal-make-string-input-stream (coerce string 'simple-string)    (internal-make-string-input-stream (coerce string 'simple-string)
890                                       start end))                                       start end))
891    
# Line 1137  Line 1144 
1144    
1145  ;;;; Case frobbing streams, used by format ~(...~).  ;;;; Case frobbing streams, used by format ~(...~).
1146    
 (in-package "EXT")  
 (export '(make-case-frob-stream))  
 (in-package "LISP")  
   
1147  (defstruct (case-frob-stream  (defstruct (case-frob-stream
1148              (:include stream              (:include stream
1149                        (:misc #'case-frob-misc))                        (:misc #'case-frob-misc))
# Line 1344  Line 1347 
1347            (return))))            (return))))
1348      (funcall (stream-sout target) target str 0 len)))      (funcall (stream-sout target) target str 0 len)))
1349    
   
1350    
1351  ;;;; Public interface from "EXTENSIONS" package.  ;;;; Public interface from "EXTENSIONS" package.
1352    
 (in-package "EXT")  
   
 (export '(get-stream-command stream-command stream-command-p stream-command-name  
           stream-command-args make-stream-command))  
   
1353  (defstruct (stream-command (:print-function print-stream-command)  (defstruct (stream-command (:print-function print-stream-command)
1354                             (:constructor make-stream-command                             (:constructor make-stream-command
1355                                           (name &optional args)))                                           (name &optional args)))

Legend:
Removed from v.1.17  
changed lines
  Added in v.1.17.1.1

  ViewVC Help
Powered by ViewVC 1.1.5