/[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.29 by pw, Mon Apr 27 10:06:43 1998 UTC revision 1.30 by dtc, Mon May 4 01:27:16 1998 UTC
# Line 163  Line 163 
163    
164  (defun input-stream-p (stream)  (defun input-stream-p (stream)
165    "Returns non-nil if the given Stream can perform input operations."    "Returns non-nil if the given Stream can perform input operations."
166    (and (streamp stream)    (and (lisp-stream-p stream)
167         (not (eq (stream-in stream) #'closed-flame))         (not (eq (lisp-stream-in stream) #'closed-flame))
168         (or (not (eq (stream-in stream) #'ill-in))         (or (not (eq (lisp-stream-in stream) #'ill-in))
169             (not (eq (stream-bin stream) #'ill-bin)))))             (not (eq (lisp-stream-bin stream) #'ill-bin)))))
170    
171  (defun output-stream-p (stream)  (defun output-stream-p (stream)
172    "Returns non-nil if the given Stream can perform output operations."    "Returns non-nil if the given Stream can perform output operations."
173    (and (streamp stream)    (and (lisp-stream-p stream)
174         (not (eq (stream-in stream) #'closed-flame))         (not (eq (lisp-stream-in stream) #'closed-flame))
175         (or (not (eq (stream-out stream) #'ill-out))         (or (not (eq (lisp-stream-out stream) #'ill-out))
176             (not (eq (stream-bout stream) #'ill-bout)))))             (not (eq (lisp-stream-bout stream) #'ill-bout)))))
177    
178  (defun open-stream-p (stream)  (defun open-stream-p (stream)
179    "Return true if Stream is not closed."    "Return true if Stream is not closed."
180    (declare (type stream stream))    (declare (type stream stream))
181    (not (eq (stream-in stream) #'closed-flame)))    (not (eq (lisp-stream-in stream) #'closed-flame)))
182    
183  (defun stream-element-type (stream)  (defun stream-element-type (stream)
184    "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."
185    (declare (type stream stream))    (declare (type stream stream))
186    (funcall (stream-misc stream) stream :element-type))    (funcall (lisp-stream-misc stream) stream :element-type))
187    
188  (defun interactive-stream-p (stream)  (defun interactive-stream-p (stream)
189    "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."
190    (declare (type stream stream))    (declare (type stream stream))
191    (funcall (stream-misc stream) stream :interactive-p))    (funcall (lisp-stream-misc stream) stream :interactive-p))
192    
193  (defun open-stream-p (stream)  (defun open-stream-p (stream)
194    "Return true if and only if STREAM has not been closed."    "Return true if and only if STREAM has not been closed."
195    (declare (type stream stream))    (declare (type stream stream))
196    (not (eq (stream-in stream) #'closed-flame)))    (not (eq (lisp-stream-in stream) #'closed-flame)))
197    
198  (defun close (stream &key abort)  (defun close (stream &key abort)
199    "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
# Line 201  Line 201 
201    up the side effects of having created the stream."    up the side effects of having created the stream."
202    (declare (type stream stream))    (declare (type stream stream))
203    (when (open-stream-p stream)    (when (open-stream-p stream)
204      (funcall (stream-misc stream) stream :close abort))      (funcall (lisp-stream-misc stream) stream :close abort))
205    t)    t)
206    
207  (defun set-closed-flame (stream)  (defun set-closed-flame (stream)
208    (setf (stream-in stream) #'closed-flame)    (setf (lisp-stream-in stream) #'closed-flame)
209    (setf (stream-bin stream) #'closed-flame)    (setf (lisp-stream-bin stream) #'closed-flame)
210    (setf (stream-n-bin stream) #'closed-flame)    (setf (lisp-stream-n-bin stream) #'closed-flame)
211    (setf (stream-in stream) #'closed-flame)    (setf (lisp-stream-in stream) #'closed-flame)
212    (setf (stream-out stream) #'closed-flame)    (setf (lisp-stream-out stream) #'closed-flame)
213    (setf (stream-bout stream) #'closed-flame)    (setf (lisp-stream-bout stream) #'closed-flame)
214    (setf (stream-sout stream) #'closed-flame)    (setf (lisp-stream-sout stream) #'closed-flame)
215    (setf (stream-misc stream) #'closed-flame))    (setf (lisp-stream-misc stream) #'closed-flame))
216    
217    
218  ;;;; File position and file length.  ;;;; File position and file length.
# Line 230  Line 230 
230             (type (or index (member nil :start :end)) position))             (type (or index (member nil :start :end)) position))
231    (cond    (cond
232     (position     (position
233      (setf (stream-in-index stream) in-buffer-length)      (setf (lisp-stream-in-index stream) in-buffer-length)
234      (funcall (stream-misc stream) stream :file-position position))      (funcall (lisp-stream-misc stream) stream :file-position position))
235     (t     (t
236      (let ((res (funcall (stream-misc stream) stream :file-position nil)))      (let ((res (funcall (lisp-stream-misc stream) stream :file-position nil)))
237        (when res (- res (- in-buffer-length (stream-in-index stream))))))))        (when res (- res (- in-buffer-length (lisp-stream-in-index stream))))))))
238    
239    
240  ;;; File-Length  --  Public  ;;; File-Length  --  Public
# Line 244  Line 244 
244  (defun file-length (stream)  (defun file-length (stream)
245    "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."
246    (declare (stream stream))    (declare (stream stream))
247    (funcall (stream-misc stream) stream :file-length))    (funcall (lisp-stream-misc stream) stream :file-length))
248    
249    
250  ;;; Input functions:  ;;; Input functions:
# Line 254  Line 254 
254    "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
255    newline character."    newline character."
256    (declare (ignore recursive-p))    (declare (ignore recursive-p))
257    (prepare-for-fast-read-char stream    (let ((stream (stream-synonym-of stream)))
258      (let ((res (make-string 80))      (etypecase stream
259            (len 80)        (lisp-stream
260            (index 0))         (prepare-for-fast-read-char stream
261        (loop           (let ((res (make-string 80))
262          (let ((ch (fast-read-char nil nil)))                 (len 80)
263            (cond (ch                 (index 0))
264                   (when (char= ch #\newline)             (loop
265                     (done-with-fast-read-char)              (let ((ch (fast-read-char nil nil)))
266                     (return (values (shrink-vector res index) nil)))                (cond (ch
267                   (when (= index len)                       (when (char= ch #\newline)
268                     (setq len (* len 2))                         (done-with-fast-read-char)
269                     (let ((new (make-string len)))                         (return (values (shrink-vector res index) nil)))
270                       (replace new res)                       (when (= index len)
271                       (setq res new)))                         (setq len (* len 2))
272                   (setf (schar res index) ch)                         (let ((new (make-string len)))
273                   (incf index))                           (replace new res)
274                  ((zerop index)                           (setq res new)))
275                   (done-with-fast-read-char)                       (setf (schar res index) ch)
276                   (return (values (eof-or-lose (in-synonym-of stream)                       (incf index))
277                                                eof-errorp eof-value)                      ((zerop index)
278                                   t)))                       (done-with-fast-read-char)
279                  ;; since fast-read-char hit already the eof char, we                       (return (values (eof-or-lose stream eof-errorp eof-value)
280                  ;; shouldn't do another read-char                                       t)))
281                  (t                      ;; since fast-read-char hit already the eof char, we
282                   (done-with-fast-read-char)                      ;; shouldn't do another read-char
283                   (return (values (shrink-vector res index) t)))))))))                      (t
284                         (done-with-fast-read-char)
285                         (return (values (shrink-vector res index) t)))))))))
286          (fundamental-stream
287           (multiple-value-bind (string eof)
288               (stream-read-line stream)
289             (if (and eof (zerop (length string)))
290                 (values (eof-or-lose stream eof-errorp eof-value) t)
291                 (values string eof)))))))
292    
293  ;;; We proclaim them inline here, then proclaim them notinline at EOF,  ;;; We proclaim them inline here, then proclaim them notinline at EOF,
294  ;;; 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 291  Line 298 
298                              recursive-p)                              recursive-p)
299    "Inputs a character from Stream and returns it."    "Inputs a character from Stream and returns it."
300    (declare (ignore recursive-p))    (declare (ignore recursive-p))
301    (prepare-for-fast-read-char stream    (let ((stream (stream-synonym-of stream)))
302      (prog1      (etypecase stream
303          (fast-read-char eof-errorp eof-value)        (lisp-stream
304        (done-with-fast-read-char))))         (prepare-for-fast-read-char stream
305             (prog1
306                 (fast-read-char eof-errorp eof-value)
307               (done-with-fast-read-char))))
308          (fundamental-stream
309           (let ((char (stream-read-char stream)))
310             (if (eq char :eof)
311                 (eof-or-lose stream eof-errorp eof-value)
312                 char))))))
313    
314  (defun unread-char (character &optional (stream *standard-input*))  (defun unread-char (character &optional (stream *standard-input*))
315    "Puts the Character back on the front of the input Stream."    "Puts the Character back on the front of the input Stream."
316    (let* ((stream (in-synonym-of stream))    (let ((stream (stream-synonym-of stream)))
317           (index (1- (stream-in-index stream)))      (etypecase stream
318           (buffer (stream-in-buffer stream)))        (lisp-stream
319      (declare (fixnum index))         (let ((index (1- (lisp-stream-in-index stream)))
320      (when (minusp index) (error "Nothing to unread."))               (buffer (lisp-stream-in-buffer stream)))
321      (cond (buffer           (declare (fixnum index))
322             (setf (aref buffer index) (char-code character))           (when (minusp index) (error "Nothing to unread."))
323             (setf (stream-in-index stream) index))           (cond (buffer
324            (t                  (setf (aref buffer index) (char-code character))
325             (funcall (stream-misc stream) stream :unread character))))                  (setf (lisp-stream-in-index stream) index))
326                   (t
327                    (funcall (lisp-stream-misc stream) stream
328                             :unread character)))))
329          (fundamental-stream
330           (stream-unread-char stream character))))
331    nil)    nil)
332    
333  (defun peek-char (&optional (peek-type nil) (stream *standard-input*)  (defun peek-char (&optional (peek-type nil) (stream *standard-input*)
334                              (eof-errorp t) eof-value recursive-p)                              (eof-errorp t) eof-value recursive-p)
335    "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."
336    (declare (ignore recursive-p))    (declare (ignore recursive-p))
337    (let* ((stream (in-synonym-of stream))    (let ((stream (stream-synonym-of stream)))
338           (char (read-char stream eof-errorp eof-value)))      (etypecase stream
339      (cond ((eq char eof-value) char)        (lisp-stream
340            ((characterp peek-type)         (let ((char (read-char stream eof-errorp eof-value)))
341             (do ((char char (read-char stream eof-errorp eof-value)))           (cond ((eq char eof-value) char)
342                 ((or (eq char eof-value) (char= char peek-type))                 ((characterp peek-type)
343                  (unless (eq char eof-value)                  (do ((char char (read-char stream eof-errorp eof-value)))
344                    (unread-char char stream))                      ((or (eq char eof-value) (char= char peek-type))
345                  char)))                       (unless (eq char eof-value)
346            ((eq peek-type t)                         (unread-char char stream))
347             (do ((char char (read-char stream eof-errorp eof-value)))                       char)))
348                 ((or (eq char eof-value) (not (whitespace-char-p char)))                 ((eq peek-type t)
349                  (unless (eq char eof-value)                  (do ((char char (read-char stream eof-errorp eof-value)))
350                    (unread-char char stream))                      ((or (eq char eof-value) (not (whitespace-char-p char)))
351                  char)))                       (unless (eq char eof-value)
352            (t                         (unread-char char stream))
353             (unread-char char stream)                       char)))
354             char))))                 (t
355                    (unread-char char stream)
356                    char))))
357          (fundamental-stream
358           (cond ((characterp peek-type)
359                  (do ((char (stream-read-char stream) (stream-read-char stream)))
360                      ((or (eq char :eof) (char= char peek-type))
361                       (cond ((eq char :eof)
362                              (eof-or-lose stream eof-errorp eof-value))
363                             (t
364                              (stream-unread-char stream char)
365                              char)))))
366                 ((eq peek-type t)
367                  (do ((char (stream-read-char stream) (stream-read-char stream)))
368                      ((or (eq char :eof) (not (whitespace-char-p char)))
369                       (cond ((eq char :eof)
370                              (eof-or-lose stream eof-errorp eof-value))
371                             (t
372                              (stream-unread-char stream char)
373                              char)))))
374                 (t
375                  (let ((char (stream-peek-char stream)))
376                    (if (eq char :eof)
377                        (eof-or-lose stream eof-errorp eof-value)
378                        char))))))))
379    
380  (defun listen (&optional (stream *standard-input*))  (defun listen (&optional (stream *standard-input*))
381    "Returns T if a character is availible on the given Stream."    "Returns T if a character is availible on the given Stream."
382    (let ((stream (in-synonym-of stream)))    (let ((stream (stream-synonym-of stream)))
383      (or (/= (the fixnum (stream-in-index stream)) in-buffer-length)      (etypecase stream
384          ;; Test for t explicitly since misc methods return :eof sometimes.        (lisp-stream
385          (eq (funcall (stream-misc stream) stream :listen) t))))         (or (/= (the fixnum (lisp-stream-in-index stream)) in-buffer-length)
386               ;; Test for t explicitly since misc methods return :eof sometimes.
387               (eq (funcall (lisp-stream-misc stream) stream :listen) t)))
388          (fundamental-stream
389           (stream-listen stream)))))
390    
391  (defun read-char-no-hang (&optional (stream *standard-input*)  (defun read-char-no-hang (&optional (stream *standard-input*)
392                                      (eof-errorp t) eof-value recursive-p)                                      (eof-errorp t) eof-value recursive-p)
393    "Returns the next character from the Stream if one is availible, or nil."    "Returns the next character from the Stream if one is availible, or nil."
394    (declare (ignore recursive-p))    (declare (ignore recursive-p))
395    (let ((stream (in-synonym-of stream)))    (let ((stream (stream-synonym-of stream)))
396      (if (funcall (stream-misc stream) stream :listen)      (etypecase stream
397          ;; On t or :eof get READ-CHAR to do the work.        (lisp-stream
398          (read-char stream eof-errorp eof-value)         (if (funcall (lisp-stream-misc stream) stream :listen)
399          nil)))             ;; On t or :eof get READ-CHAR to do the work.
400               (read-char stream eof-errorp eof-value)
401               nil))
402          (fundamental-stream
403           (let ((char (stream-read-char-no-hang stream)))
404             (if (eq char :eof)
405                 (eof-or-lose stream eof-errorp eof-value)
406                 char))))))
407    
408    
409  (defun clear-input (&optional (stream *standard-input*))  (defun clear-input (&optional (stream *standard-input*))
410    "Clears any buffered input associated with the Stream."    "Clears any buffered input associated with the Stream."
411    (let ((stream (in-synonym-of stream)))    (let ((stream (stream-synonym-of stream)))
412      (setf (stream-in-index stream) in-buffer-length)      (etypecase stream
413      (funcall (stream-misc stream) stream :clear-input)        (lisp-stream
414      nil))         (setf (lisp-stream-in-index stream) in-buffer-length)
415           (funcall (lisp-stream-misc stream) stream :clear-input))
416          (fundamental-stream
417           (stream-clear-input stream))))
418      nil)
419    
420  (defun read-byte (stream &optional (eof-errorp t) eof-value)  (defun read-byte (stream &optional (eof-errorp t) eof-value)
421    "Returns the next byte of the Stream."    "Returns the next byte of the Stream."
422    (prepare-for-fast-read-byte stream    (let ((stream (stream-synonym-of stream)))
423      (prog1      (etypecase stream
424          (fast-read-byte eof-errorp eof-value t)        (lisp-stream
425        (done-with-fast-read-byte))))         (prepare-for-fast-read-byte stream
426             (prog1
427                 (fast-read-byte eof-errorp eof-value t)
428               (done-with-fast-read-byte))))
429          (fundamental-stream
430           (let ((char (stream-read-byte stream)))
431             (if (eq char :eof)
432                 (eof-or-lose stream eof-errorp eof-value)
433                 char))))))
434    
435  (defun read-n-bytes (stream buffer start numbytes &optional (eof-errorp t))  (defun read-n-bytes (stream buffer start numbytes &optional (eof-errorp t))
436    "Reads Numbytes bytes into the Buffer starting at Start, returning the number    "Reads Numbytes bytes into the Buffer starting at Start, returning the number
# Line 373  Line 441 
441        available (up to count bytes.)  On pipes or similar devices, this        available (up to count bytes.)  On pipes or similar devices, this
442        function returns as soon as any adata is available, even if the amount        function returns as soon as any adata is available, even if the amount
443        read is less than Count and eof has not been hit."        read is less than Count and eof has not been hit."
444    (declare (type index numbytes start)    (declare (type lisp-stream stream)
445               (type index numbytes start)
446             (type (or (simple-array * (*)) system-area-pointer) buffer))             (type (or (simple-array * (*)) system-area-pointer) buffer))
447    (let* ((stream (in-synonym-of stream))    (let* ((stream (stream-synonym-of stream lisp-stream))
448           (in-buffer (stream-in-buffer stream))           (in-buffer (lisp-stream-in-buffer stream))
449           (index (stream-in-index stream))           (index (lisp-stream-in-index stream))
450           (num-buffered (- in-buffer-length index)))           (num-buffered (- in-buffer-length index)))
451      (declare (fixnum index num-buffered))      (declare (fixnum index num-buffered))
452      (cond      (cond
453       ((not in-buffer)       ((not in-buffer)
454        (funcall (stream-n-bin stream) stream buffer start numbytes eof-errorp))        (funcall (lisp-stream-n-bin stream) stream buffer start numbytes eof-errorp))
455       ((<= numbytes num-buffered)       ((<= numbytes num-buffered)
456        (%primitive byte-blt in-buffer index buffer start (+ start numbytes))        (%primitive byte-blt in-buffer index buffer start (+ start numbytes))
457        (setf (stream-in-index stream) (+ index numbytes))        (setf (lisp-stream-in-index stream) (+ index numbytes))
458        numbytes)        numbytes)
459       (t       (t
460        (let ((end (+ start num-buffered)))        (let ((end (+ start num-buffered)))
461          (%primitive byte-blt in-buffer index buffer start end)          (%primitive byte-blt in-buffer index buffer start end)
462          (setf (stream-in-index stream) in-buffer-length)          (setf (lisp-stream-in-index stream) in-buffer-length)
463          (+ (funcall (stream-n-bin stream) stream buffer end          (+ (funcall (lisp-stream-n-bin stream) stream buffer end
464                      (- numbytes num-buffered)                      (- numbytes num-buffered)
465                      eof-errorp)                      eof-errorp)
466             num-buffered))))))             num-buffered))))))
# Line 409  Line 478 
478  ;;; myst be an n-bin method.  ;;; myst be an n-bin method.
479  ;;;  ;;;
480  (defun fast-read-char-refill (stream eof-errorp eof-value)  (defun fast-read-char-refill (stream eof-errorp eof-value)
481    (let* ((ibuf (stream-in-buffer stream))    (let* ((ibuf (lisp-stream-in-buffer stream))
482           (count (funcall (stream-n-bin stream) stream           (count (funcall (lisp-stream-n-bin stream) stream
483                           ibuf in-buffer-extra                           ibuf in-buffer-extra
484                           (- in-buffer-length in-buffer-extra)                           (- in-buffer-length in-buffer-extra)
485                           nil))                           nil))
486           (start (- in-buffer-length count)))           (start (- in-buffer-length count)))
487      (declare (type index start count))      (declare (type index start count))
488      (cond ((zerop count)      (cond ((zerop count)
489             (setf (stream-in-index stream) in-buffer-length)             (setf (lisp-stream-in-index stream) in-buffer-length)
490             (funcall (stream-in stream) stream eof-errorp eof-value))             (funcall (lisp-stream-in stream) stream eof-errorp eof-value))
491            (t            (t
492             (when (/= start in-buffer-extra)             (when (/= start in-buffer-extra)
493               (bit-bash-copy ibuf (+ (* in-buffer-extra vm:byte-bits)               (bit-bash-copy ibuf (+ (* in-buffer-extra vm:byte-bits)
# Line 426  Line 495 
495                              ibuf (+ (the index (* start vm:byte-bits))                              ibuf (+ (the index (* start vm:byte-bits))
496                                      (* vm:vector-data-offset vm:word-bits))                                      (* vm:vector-data-offset vm:word-bits))
497                              (* count vm:byte-bits)))                              (* count vm:byte-bits)))
498             (setf (stream-in-index stream) (1+ start))             (setf (lisp-stream-in-index stream) (1+ start))
499             (code-char (aref ibuf start))))))             (code-char (aref ibuf start))))))
500    
501    
# Line 436  Line 505 
505  ;;; unreading.  ;;; unreading.
506  ;;;  ;;;
507  (defun fast-read-byte-refill (stream eof-errorp eof-value)  (defun fast-read-byte-refill (stream eof-errorp eof-value)
508    (let* ((ibuf (stream-in-buffer stream))    (let* ((ibuf (lisp-stream-in-buffer stream))
509           (count (funcall (stream-n-bin stream) stream           (count (funcall (lisp-stream-n-bin stream) stream
510                           ibuf 0 in-buffer-length                           ibuf 0 in-buffer-length
511                           nil))                           nil))
512           (start (- in-buffer-length count)))           (start (- in-buffer-length count)))
513      (declare (type index start count))      (declare (type index start count))
514      (cond ((zerop count)      (cond ((zerop count)
515             (setf (stream-in-index stream) in-buffer-length)             (setf (lisp-stream-in-index stream) in-buffer-length)
516             (funcall (stream-bin stream) stream eof-errorp eof-value))             (funcall (lisp-stream-bin stream) stream eof-errorp eof-value))
517            (t            (t
518             (unless (zerop start)             (unless (zerop start)
519               (bit-bash-copy ibuf (* vm:vector-data-offset vm:word-bits)               (bit-bash-copy ibuf (* vm:vector-data-offset vm:word-bits)
520                              ibuf (+ (the index (* start vm:byte-bits))                              ibuf (+ (the index (* start vm:byte-bits))
521                                      (* vm:vector-data-offset vm:word-bits))                                      (* vm:vector-data-offset vm:word-bits))
522                              (* count vm:byte-bits)))                              (* count vm:byte-bits)))
523             (setf (stream-in-index stream) (1+ start))             (setf (lisp-stream-in-index stream) (1+ start))
524             (aref ibuf start)))))             (aref ibuf start)))))
525    
526    
# Line 459  Line 528 
528    
529  (defun write-char (character &optional (stream *standard-output*))  (defun write-char (character &optional (stream *standard-output*))
530    "Outputs the Character to the Stream."    "Outputs the Character to the Stream."
531    (with-out-stream stream stream-out character)    (with-stream stream (lisp-stream-out character)
532                   (stream-write-char character))
533    character)    character)
534    
535  (defun terpri (&optional (stream *standard-output*))  (defun terpri (&optional (stream *standard-output*))
536    "Outputs a new line to the Stream."    "Outputs a new line to the Stream."
537    (with-out-stream stream stream-out #\newline)    (with-stream stream (lisp-stream-out #\newline) (stream-terpri))
538    nil)    nil)
539    
540  (defun fresh-line (&optional (stream *standard-output*))  (defun fresh-line (&optional (stream *standard-output*))
541    "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 begining of
542     a line.  Returns T if it output a new line, nil otherwise."     a line.  Returns T if it output a new line, nil otherwise."
543    (let ((stream (out-synonym-of stream)))    (let ((stream (stream-synonym-of stream)))
544      (when (/= (or (charpos stream) 1) 0)      (etypecase stream
545        (funcall (stream-out stream) stream #\newline)        (lisp-stream
546        t)))         (when (/= (or (charpos stream) 1) 0)
547             (funcall (lisp-stream-out stream) stream #\newline)
548             t))
549          (fundamental-stream
550           (stream-fresh-line stream)))))
551    
552  (defun write-string (string &optional (stream *standard-output*)  (defun write-string (string &optional (stream *standard-output*)
553                              &key (start 0) (end (length (the vector string))))                              &key (start 0) (end (length (the vector string))))
# Line 483  Line 557 
557  (defun write-string* (string &optional (stream *standard-output*)  (defun write-string* (string &optional (stream *standard-output*)
558                               (start 0) (end (length (the vector string))))                               (start 0) (end (length (the vector string))))
559    (declare (fixnum start end))    (declare (fixnum start end))
560    (if (array-header-p string)    (let ((stream (stream-synonym-of stream)))
561        (with-array-data ((data string) (offset-start start) (offset-end end))      (etypecase stream
562          (with-out-stream stream stream-sout data offset-start offset-end))        (lisp-stream
563        (with-out-stream stream stream-sout string start end))         (if (array-header-p string)
564    string)             (with-array-data ((data string) (offset-start start)
565                                 (offset-end end))
566                 (funcall (lisp-stream-sout stream)
567                          stream data offset-start offset-end))
568               (funcall (lisp-stream-sout stream) stream string start end))
569           string)
570          (fundamental-stream
571           (stream-write-string stream string start end)))))
572    
573  (defun write-line (string &optional (stream *standard-output*)  (defun write-line (string &optional (stream *standard-output*)
574                            &key (start 0) (end (length string)))                            &key (start 0) (end (length string)))
# Line 497  Line 578 
578  (defun write-line* (string &optional (stream *standard-output*)  (defun write-line* (string &optional (stream *standard-output*)
579                             (start 0) (end (length string)))                             (start 0) (end (length string)))
580    (declare (fixnum start end))    (declare (fixnum start end))
581    (let ((stream (out-synonym-of stream)))    (let ((stream (stream-synonym-of stream)))
582      (if (array-header-p string)      (etypecase stream
583          (with-array-data ((data string) (offset-start start) (offset-end end))        (lisp-stream
584            (with-out-stream stream stream-sout data offset-start offset-end))         (if (array-header-p string)
585          (with-out-stream stream stream-sout string start end))             (with-array-data ((data string) (offset-start start)
586      (funcall (stream-out stream) stream #\newline))                               (offset-end end))
587    string)               (with-stream stream (lisp-stream-sout data offset-start
588                                                       offset-end)))
589               (with-stream stream (lisp-stream-sout string start end)))
590           (funcall (lisp-stream-out stream) stream #\newline))
591          (fundamental-stream
592           (stream-write-string stream string start end)
593           (stream-write-char stream #\Newline)))
594        string))
595    
596  (defun charpos (&optional (stream *standard-output*))  (defun charpos (&optional (stream *standard-output*))
597    "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
598    Stream, or Nil if that information is not availible."    Stream, or Nil if that information is not availible."
599    (with-out-stream stream stream-misc :charpos))    (with-stream stream (lisp-stream-misc :charpos) (stream-line-column)))
600    
601  (defun line-length (&optional (stream *standard-output*))  (defun line-length (&optional (stream *standard-output*))
602    "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
603    given Stream, or Nil if that information is not available."    given Stream, or Nil if that information is not available."
604    (with-out-stream stream stream-misc :line-length))    (with-stream stream (lisp-stream-misc :line-length) (stream-line-length)))
605    
606  (defun finish-output (&optional (stream *standard-output*))  (defun finish-output (&optional (stream *standard-output*))
607    "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
608     destination, and only then returns."     destination, and only then returns."
609    (with-out-stream stream stream-misc :finish-output)    (with-stream stream (lisp-stream-misc :finish-output) (stream-finish-output))
610    nil)    nil)
611    
612  (defun force-output (&optional (stream *standard-output*))  (defun force-output (&optional (stream *standard-output*))
613    "Attempts to force any buffered output to be sent."    "Attempts to force any buffered output to be sent."
614    (with-out-stream stream stream-misc :force-output)    (with-stream stream (lisp-stream-misc :force-output) (stream-force-output))
615    nil)    nil)
616    
617  (defun clear-output (&optional (stream *standard-output*))  (defun clear-output (&optional (stream *standard-output*))
618    "Clears the given output Stream."    "Clears the given output Stream."
619    (with-out-stream stream stream-misc :clear-output)    (with-stream stream (lisp-stream-misc :clear-output) (stream-force-output))
620    nil)    nil)
621    
622  (defun write-byte (integer stream)  (defun write-byte (integer stream)
623    "Outputs the Integer to the binary Stream."    "Outputs the Integer to the binary Stream."
624    (with-out-stream stream stream-bout integer)    (with-stream stream (lisp-stream-bout integer) (stream-write-byte))
625    integer)    integer)
626    
627  ;;;; Broadcast streams:  ;;;; Broadcast streams:
628    
629  (defstruct (broadcast-stream (:include stream  (defstruct (broadcast-stream (:include lisp-stream
630                                         (out #'broadcast-out)                                         (out #'broadcast-out)
631                                         (bout #'broadcast-bout)                                         (bout #'broadcast-bout)
632                                         (sout #'broadcast-sout)                                         (sout #'broadcast-sout)
# Line 559  Line 647 
647               `(defun ,fun (stream ,@args)               `(defun ,fun (stream ,@args)
648                  (dolist (stream (broadcast-stream-streams stream))                  (dolist (stream (broadcast-stream-streams stream))
649                    (funcall (,method stream) stream ,@args)))))                    (funcall (,method stream) stream ,@args)))))
650    (out-fun broadcast-out stream-out char)    (out-fun broadcast-out lisp-stream-out char)
651    (out-fun broadcast-bout stream-bout byte)    (out-fun broadcast-bout lisp-stream-bout byte)
652    (out-fun broadcast-sout stream-sout string start end))    (out-fun broadcast-sout lisp-stream-sout string start end))
653    
654  (defun broadcast-misc (stream operation &optional arg1 arg2)  (defun broadcast-misc (stream operation &optional arg1 arg2)
655    (let ((streams (broadcast-stream-streams stream)))    (let ((streams (broadcast-stream-streams stream)))
656      (case operation      (case operation
657        (:charpos        (:charpos
658         (dolist (stream streams)         (dolist (stream streams)
659           (let ((charpos (funcall (stream-misc stream) stream :charpos)))           (let ((charpos (funcall (lisp-stream-misc stream) stream :charpos)))
660             (if charpos (return charpos)))))             (if charpos (return charpos)))))
661        (:line-length        (:line-length
662         (let ((min nil))         (let ((min nil))
663           (dolist (stream streams min)           (dolist (stream streams min)
664             (let ((res (funcall (stream-misc stream) stream :line-length)))             (let ((res (funcall (lisp-stream-misc stream) stream :line-length)))
665               (when res (setq min (if min (min res min) res)))))))               (when res (setq min (if min (min res min) res)))))))
666        (:element-type        (:element-type
667         (let (res)         (let (res)
668           (dolist (stream streams (if (> (length res) 1) `(and ,@res) res))           (dolist (stream streams (if (> (length res) 1) `(and ,@res) res))
669             (pushnew (funcall (stream-misc stream) stream :element-type) res             (pushnew (funcall (lisp-stream-misc stream) stream :element-type) res
670                      :test #'equal))))                      :test #'equal))))
671        (:close)        (:close)
672        (t        (t
673         (let ((res nil))         (let ((res nil))
674           (dolist (stream streams res)           (dolist (stream streams res)
675             (setq res (funcall (stream-misc stream) stream operation             (setq res (funcall (lisp-stream-misc stream) stream operation
676                                arg1 arg2))))))))                                arg1 arg2))))))))
677    
678  ;;;; Synonym Streams:  ;;;; Synonym Streams:
679    
680  (defstruct (synonym-stream (:include stream  (defstruct (synonym-stream (:include lisp-stream
681                                       (in #'synonym-in)                                       (in #'synonym-in)
682                                       (bin #'synonym-bin)                                       (bin #'synonym-bin)
683                                       (n-bin #'synonym-n-bin)                                       (n-bin #'synonym-n-bin)
# Line 618  Line 706 
706                  (declare (optimize (safety 1)))                  (declare (optimize (safety 1)))
707                  (let ((syn (symbol-value (synonym-stream-symbol stream))))                  (let ((syn (symbol-value (synonym-stream-symbol stream))))
708                    (funcall (,slot syn) syn ,@args)))))                    (funcall (,slot syn) syn ,@args)))))
709    (out-fun synonym-out stream-out ch)    (out-fun synonym-out lisp-stream-out ch)
710    (out-fun synonym-bout stream-bout n)    (out-fun synonym-bout lisp-stream-bout n)
711    (out-fun synonym-sout stream-sout string start end))    (out-fun synonym-sout lisp-stream-sout string start end))
712    
713    
714  ;;; Bind synonym stream to this so that SPIO can turn on the right frob in  ;;; Bind synonym stream to this so that SPIO can turn on the right frob in
# Line 652  Line 740 
740    (let ((syn (symbol-value (synonym-stream-symbol stream)))    (let ((syn (symbol-value (synonym-stream-symbol stream)))
741          (*previous-stream* stream))          (*previous-stream* stream))
742      (case operation      (case operation
743        (:listen (or (/= (the fixnum (stream-in-index syn)) in-buffer-length)        (:listen (or (/= (the fixnum (lisp-stream-in-index syn)) in-buffer-length)
744                     (funcall (stream-misc syn) syn :listen)))                     (funcall (lisp-stream-misc syn) syn :listen)))
745        (t        (t
746         (funcall (stream-misc syn) syn operation arg1 arg2)))))         (funcall (lisp-stream-misc syn) syn operation arg1 arg2)))))
747    
748  ;;;; Two-Way streams:  ;;;; Two-Way streams:
749    
750  (defstruct (two-way-stream  (defstruct (two-way-stream
751              (:include stream              (:include lisp-stream
752                        (in #'two-way-in)                        (in #'two-way-in)
753                        (bin #'two-way-bin)                        (bin #'two-way-bin)
754                        (n-bin #'two-way-n-bin)                        (n-bin #'two-way-n-bin)
# Line 689  Line 777 
777               `(defun ,name (stream ,@args)               `(defun ,name (stream ,@args)
778                  (let ((syn (two-way-stream-output-stream stream)))                  (let ((syn (two-way-stream-output-stream stream)))
779                    (funcall (,slot syn) syn ,@args)))))                    (funcall (,slot syn) syn ,@args)))))
780    (out-fun two-way-out stream-out ch)    (out-fun two-way-out lisp-stream-out ch)
781    (out-fun two-way-bout stream-bout n)    (out-fun two-way-bout lisp-stream-bout n)
782    (out-fun two-way-sout stream-sout string start end))    (out-fun two-way-sout lisp-stream-sout string start end))
783    
784  (macrolet ((in-fun (name fun &rest args)  (macrolet ((in-fun (name fun &rest args)
785               `(defun ,name (stream ,@args)               `(defun ,name (stream ,@args)
# Line 703  Line 791 
791    
792  (defun two-way-misc (stream operation &optional arg1 arg2)  (defun two-way-misc (stream operation &optional arg1 arg2)
793    (let* ((in (two-way-stream-input-stream stream))    (let* ((in (two-way-stream-input-stream stream))
794           (in-method (stream-misc in))           (in-method (lisp-stream-misc in))
795           (out (two-way-stream-output-stream stream))           (out (two-way-stream-output-stream stream))
796           (out-method (stream-misc out)))           (out-method (lisp-stream-misc out)))
797      (case operation      (case operation
798        (:listen (or (/= (the fixnum (stream-in-index in)) in-buffer-length)        (:listen (or (/= (the fixnum (lisp-stream-in-index in)) in-buffer-length)
799                     (funcall in-method in :listen)))                     (funcall in-method in :listen)))
800        ((:finish-output :force-output :clear-output)        ((:finish-output :force-output :clear-output)
801         (funcall out-method out operation arg1 arg2))         (funcall out-method out operation arg1 arg2))
# Line 727  Line 815 
815  ;;;; Concatenated Streams:  ;;;; Concatenated Streams:
816    
817  (defstruct (concatenated-stream  (defstruct (concatenated-stream
818              (:include stream              (:include lisp-stream
819                        (in #'concatenated-in)                        (in #'concatenated-in)
820                        (bin #'concatenated-bin)                        (bin #'concatenated-bin)
821                        (misc #'concatenated-misc))                        (misc #'concatenated-misc))
# Line 765  Line 853 
853    (let ((left (concatenated-stream-current stream)))    (let ((left (concatenated-stream-current stream)))
854      (when left      (when left
855        (let* ((current (car left))        (let* ((current (car left))
856               (misc (stream-misc current)))               (misc (lisp-stream-misc current)))
857          (case operation          (case operation
858            (:listen            (:listen
859             (loop             (loop
# Line 778  Line 866 
866                        (unless current                        (unless current
867                          ;; No further streams.  EOF.                          ;; No further streams.  EOF.
868                          (return :eof))                          (return :eof))
869                        (setf misc (stream-misc current)))                        (setf misc (lisp-stream-misc current)))
870                       (stuff                       (stuff
871                        ;; Stuff's available.                        ;; Stuff's available.
872                        (return t))                        (return t))
# Line 811  Line 899 
899                             (result (,fun in ,@args)))                             (result (,fun in ,@args)))
900                        (funcall (,out-slot out) out result)                        (funcall (,out-slot out) out result)
901                        result)))))                        result)))))
902    (in-fun echo-in read-char stream-out eof-errorp eof-value)    (in-fun echo-in read-char lisp-stream-out eof-errorp eof-value)
903    (in-fun echo-bin read-byte stream-bout eof-errorp eof-value))    (in-fun echo-bin read-byte lisp-stream-bout eof-errorp eof-value))
904    
905  (defun echo-misc (stream operation &optional arg1 arg2)  (defun echo-misc (stream operation &optional arg1 arg2)
906    (let* ((in (two-way-stream-input-stream stream))    (let* ((in (two-way-stream-input-stream stream))
907           (in-method (stream-misc in))           (in-method (lisp-stream-misc in))
908           (out (two-way-stream-output-stream stream))           (out (two-way-stream-output-stream stream))
909           (out-method (stream-misc out)))           (out-method (lisp-stream-misc out)))
910      (case operation      (case operation
911        (:listen (or (not (null (echo-stream-unread-stuff stream)))        (:listen (or (not (null (echo-stream-unread-stuff stream)))
912                     (/= (the fixnum (stream-in-index in)) in-buffer-length)                     (/= (the fixnum (lisp-stream-in-index in)) in-buffer-length)
913                     (funcall in-method in :listen)))                     (funcall in-method in :listen)))
914        (:unread (push arg1 (echo-stream-unread-stuff stream)))        (:unread (push arg1 (echo-stream-unread-stuff stream)))
915        (:element-type        (:element-type
# Line 849  Line 937 
937  ;;;; String Input Streams:  ;;;; String Input Streams:
938    
939  (defstruct (string-input-stream  (defstruct (string-input-stream
940               (:include stream               (:include lisp-stream
941                         (in #'string-inch)                         (in #'string-inch)
942                         (bin #'string-binch)                         (bin #'string-binch)
943                         (n-bin #'string-stream-read-n-bytes)                         (n-bin #'string-stream-read-n-bytes)
# Line 934  Line 1022 
1022  ;;;; String Output Streams:  ;;;; String Output Streams:
1023    
1024  (defstruct (string-output-stream  (defstruct (string-output-stream
1025              (:include stream              (:include lisp-stream
1026                        (out #'string-ouch)                        (out #'string-ouch)
1027                        (sout #'string-sout)                        (sout #'string-sout)
1028                        (misc #'string-out-misc))                        (misc #'string-out-misc))
# Line 1016  Line 1104 
1104  (defun dump-output-stream-string (in-stream out-stream)  (defun dump-output-stream-string (in-stream out-stream)
1105    "Dumps the characters buffer up in the In-Stream to the Out-Stream as    "Dumps the characters buffer up in the In-Stream to the Out-Stream as
1106    Get-Output-Stream-String would return them."    Get-Output-Stream-String would return them."
1107    (write-string (string-output-stream-string in-stream) out-stream    (write-string* (string-output-stream-string in-stream) out-stream
1108                  :start 0 :end (string-output-stream-index in-stream))                   0 (string-output-stream-index in-stream))
1109    (setf (string-output-stream-index in-stream) 0))    (setf (string-output-stream-index in-stream) 0))
1110    
1111  ;;;; Fill-pointer streams:  ;;;; Fill-pointer streams:
# Line 1026  Line 1114 
1114  ;;; the CLM, but they are required for the implementation of With-Output-To-String.  ;;; the CLM, but they are required for the implementation of With-Output-To-String.
1115    
1116  (defstruct (fill-pointer-output-stream  (defstruct (fill-pointer-output-stream
1117              (:include stream              (:include lisp-stream
1118                        (out #'fill-pointer-ouch)                        (out #'fill-pointer-ouch)
1119                        (sout #'fill-pointer-sout)                        (sout #'fill-pointer-sout)
1120                        (misc #'fill-pointer-misc))                        (misc #'fill-pointer-misc))
# Line 1107  Line 1195 
1195    
1196  ;;;; Indenting streams:  ;;;; Indenting streams:
1197    
1198  (defstruct (indenting-stream (:include stream  (defstruct (indenting-stream (:include lisp-stream
1199                                         (out #'indenting-out)                                         (out #'indenting-out)
1200                                         (sout #'indenting-sout)                                         (sout #'indenting-sout)
1201                                         (misc #'indenting-misc))                                         (misc #'indenting-misc))
# Line 1132  Line 1220 
1220    `(do ((i 0 (+ i 60))    `(do ((i 0 (+ i 60))
1221          (indentation (indenting-stream-indentation ,stream)))          (indentation (indenting-stream-indentation ,stream)))
1222         ((>= i indentation))         ((>= i indentation))
1223       (funcall (stream-sout ,sub-stream) ,sub-stream       (write-string*
1224                "                                                            "        "                                                            "
1225                0 (min 60 (- indentation i)))))        ,sub-stream 0 (min 60 (- indentation i)))))
1226    
1227  ;;; Indenting-Out writes a character to an indenting stream.  ;;; Indenting-Out writes a character to an indenting stream.
1228    
1229  (defun indenting-out (stream char)  (defun indenting-out (stream char)
1230    (let ((sub-stream (indenting-stream-stream stream)))    (let ((sub-stream (indenting-stream-stream stream)))
1231      (funcall (stream-out sub-stream) sub-stream char)      (write-char char sub-stream)
1232      (if (char= char #\newline)      (if (char= char #\newline)
1233          (indenting-indent stream sub-stream))))          (indenting-indent stream sub-stream))))
1234    
# Line 1153  Line 1241 
1241        ((= i end))        ((= i end))
1242      (let ((newline (position #\newline string :start i :end end)))      (let ((newline (position #\newline string :start i :end end)))
1243        (cond (newline        (cond (newline
1244               (funcall (stream-sout sub-stream) sub-stream string i (1+ newline))               (write-string* string sub-stream i (1+ newline))
1245               (indenting-indent stream sub-stream)               (indenting-indent stream sub-stream)
1246               (setq i (+ newline 1)))               (setq i (+ newline 1)))
1247              (t              (t
1248               (funcall (stream-sout sub-stream) sub-stream string i end)               (write-string* string sub-stream i end)
1249               (setq i end))))))               (setq i end))))))
1250    
1251  ;;; Indenting-Misc just treats just the :Line-Length message differently.  ;;; Indenting-Misc just treats just the :Line-Length message differently.
# Line 1165  Line 1253 
1253  ;;; the stream's indentation.  ;;; the stream's indentation.
1254    
1255  (defun indenting-misc (stream operation &optional arg1 arg2)  (defun indenting-misc (stream operation &optional arg1 arg2)
1256    (let* ((sub-stream (indenting-stream-stream stream))    (let ((sub-stream (indenting-stream-stream stream)))
1257           (method (stream-misc sub-stream)))      (etypecase sub-stream
1258      (case operation        (lisp-stream
1259        (:line-length         (let ((method (lisp-stream-misc sub-stream)))
1260         (let ((line-length (funcall method sub-stream operation)))           (case operation
1261           (if line-length             (:line-length
1262               (- line-length (indenting-stream-indentation stream)))))              (let ((line-length (funcall method sub-stream operation)))
1263        (:charpos                (if line-length
1264         (let* ((sub-stream (indenting-stream-stream stream))                    (- line-length (indenting-stream-indentation stream)))))
1265                (charpos (funcall method sub-stream operation)))             (:charpos
1266           (if charpos              (let ((charpos (funcall method sub-stream operation)))
1267               (- charpos (indenting-stream-indentation stream)))))                (if charpos
1268        (t                    (- charpos (indenting-stream-indentation stream)))))
1269         (funcall method sub-stream operation arg1 arg2)))))             (t
1270                (funcall method sub-stream operation arg1 arg2)))))
1271          (fundamental-stream
1272           (case operation
1273             (:line-length
1274              (let ((line-length (stream-line-length sub-stream)))
1275                (if line-length
1276                    (- line-length (indenting-stream-indentation stream)))))
1277             (:charpos
1278              (let ((charpos (stream-line-column sub-stream)))
1279                (if charpos
1280                    (- charpos (indenting-stream-indentation stream)))))
1281             (t
1282              ;; XX TODO
1283              (format t "* Warning: ignoring ~s ~s ~s on ~s~%"
1284                      operation arg1 arg2 sub-stream)))))))
1285    
1286    
1287  (proclaim '(maybe-inline read-char unread-char read-byte listen))  (proclaim '(maybe-inline read-char unread-char read-byte listen))
1288    
# Line 1187  Line 1291 
1291  ;;;; Case frobbing streams, used by format ~(...~).  ;;;; Case frobbing streams, used by format ~(...~).
1292    
1293  (defstruct (case-frob-stream  (defstruct (case-frob-stream
1294              (:include stream              (:include lisp-stream
1295                        (:misc #'case-frob-misc))                        (:misc #'case-frob-misc))
1296              (:constructor %make-case-frob-stream (target out sout)))              (:constructor %make-case-frob-stream (target out sout)))
1297    (target (required-argument) :type stream))    (target (required-argument) :type stream))
# Line 1233  Line 1337 
1337      (:close)      (:close)
1338      (t      (t
1339       (let ((target (case-frob-stream-target stream)))       (let ((target (case-frob-stream-target stream)))
1340         (funcall (stream-misc target) target op arg1 arg2)))))         (funcall (lisp-stream-misc target) target op arg1 arg2)))))
1341    
1342    
1343  (defun case-frob-upcase-out (stream char)  (defun case-frob-upcase-out (stream char)
1344    (declare (type case-frob-stream stream)    (declare (type case-frob-stream stream)
1345             (type base-char char))             (type base-char char))
1346    (let ((target (case-frob-stream-target stream)))    (let ((target (case-frob-stream-target stream)))
1347      (funcall (stream-out target) target (char-upcase char))))      (funcall (lisp-stream-out target) target (char-upcase char))))
1348    
1349  (defun case-frob-upcase-sout (stream str start end)  (defun case-frob-upcase-sout (stream str start end)
1350    (declare (type case-frob-stream stream)    (declare (type case-frob-stream stream)
# Line 1250  Line 1354 
1354    (let* ((target (case-frob-stream-target stream))    (let* ((target (case-frob-stream-target stream))
1355           (len (length str))           (len (length str))
1356           (end (or end len)))           (end (or end len)))
1357      (funcall (stream-sout target) target      (funcall (lisp-stream-sout target) target
1358               (if (and (zerop start) (= len end))               (if (and (zerop start) (= len end))
1359                   (string-upcase str)                   (string-upcase str)
1360                   (nstring-upcase (subseq str start end)))                   (nstring-upcase (subseq str start end)))
# Line 1261  Line 1365 
1365    (declare (type case-frob-stream stream)    (declare (type case-frob-stream stream)
1366             (type base-char char))             (type base-char char))
1367    (let ((target (case-frob-stream-target stream)))    (let ((target (case-frob-stream-target stream)))
1368      (funcall (stream-out target) target (char-downcase char))))      (funcall (lisp-stream-out target) target (char-downcase char))))
1369    
1370  (defun case-frob-downcase-sout (stream str start end)  (defun case-frob-downcase-sout (stream str start end)
1371    (declare (type case-frob-stream stream)    (declare (type case-frob-stream stream)
# Line 1271  Line 1375 
1375    (let* ((target (case-frob-stream-target stream))    (let* ((target (case-frob-stream-target stream))
1376           (len (length str))           (len (length str))
1377           (end (or end len)))           (end (or end len)))
1378      (funcall (stream-sout target) target      (funcall (lisp-stream-sout target) target
1379               (if (and (zerop start) (= len end))               (if (and (zerop start) (= len end))
1380                   (string-downcase str)                   (string-downcase str)
1381                   (nstring-downcase (subseq str start end)))                   (nstring-downcase (subseq str start end)))
# Line 1283  Line 1387 
1387             (type base-char char))             (type base-char char))
1388    (let ((target (case-frob-stream-target stream)))    (let ((target (case-frob-stream-target stream)))
1389      (cond ((alphanumericp char)      (cond ((alphanumericp char)
1390             (funcall (stream-out target) target (char-upcase char))             (funcall (lisp-stream-out target) target (char-upcase char))
1391             (setf (case-frob-stream-out stream)             (setf (case-frob-stream-out stream)
1392                   #'case-frob-capitalize-aux-out)                   #'case-frob-capitalize-aux-out)
1393             (setf (case-frob-stream-sout stream)             (setf (case-frob-stream-sout stream)
1394                   #'case-frob-capitalize-aux-sout))                   #'case-frob-capitalize-aux-sout))
1395            (t            (t
1396             (funcall (stream-out target) target char)))))             (funcall (lisp-stream-out target) target char)))))
1397    
1398  (defun case-frob-capitalize-sout (stream str start end)  (defun case-frob-capitalize-sout (stream str start end)
1399    (declare (type case-frob-stream stream)    (declare (type case-frob-stream stream)
# Line 1314  Line 1418 
1418              #'case-frob-capitalize-aux-out)              #'case-frob-capitalize-aux-out)
1419        (setf (case-frob-stream-sout stream)        (setf (case-frob-stream-sout stream)
1420              #'case-frob-capitalize-aux-sout))              #'case-frob-capitalize-aux-sout))
1421      (funcall (stream-sout target) target str 0 len)))      (funcall (lisp-stream-sout target) target str 0 len)))
1422    
1423  (defun case-frob-capitalize-aux-out (stream char)  (defun case-frob-capitalize-aux-out (stream char)
1424    (declare (type case-frob-stream stream)    (declare (type case-frob-stream stream)
1425             (type base-char char))             (type base-char char))
1426    (let ((target (case-frob-stream-target stream)))    (let ((target (case-frob-stream-target stream)))
1427      (cond ((alphanumericp char)      (cond ((alphanumericp char)
1428             (funcall (stream-out target) target (char-downcase char)))             (funcall (lisp-stream-out target) target (char-downcase char)))
1429            (t            (t
1430             (funcall (stream-out target) target char)             (funcall (lisp-stream-out target) target char)
1431             (setf (case-frob-stream-out stream)             (setf (case-frob-stream-out stream)
1432                   #'case-frob-capitalize-out)                   #'case-frob-capitalize-out)
1433             (setf (case-frob-stream-sout stream)             (setf (case-frob-stream-sout stream)
# Line 1352  Line 1456 
1456              #'case-frob-capitalize-out)              #'case-frob-capitalize-out)
1457        (setf (case-frob-stream-sout stream)        (setf (case-frob-stream-sout stream)
1458              #'case-frob-capitalize-sout))              #'case-frob-capitalize-sout))
1459      (funcall (stream-sout target) target str 0 len)))      (funcall (lisp-stream-sout target) target str 0 len)))
1460    
1461  (defun case-frob-capitalize-first-out (stream char)  (defun case-frob-capitalize-first-out (stream char)
1462    (declare (type case-frob-stream stream)    (declare (type case-frob-stream stream)
1463             (type base-char char))             (type base-char char))
1464    (let ((target (case-frob-stream-target stream)))    (let ((target (case-frob-stream-target stream)))
1465      (cond ((alphanumericp char)      (cond ((alphanumericp char)
1466             (funcall (stream-out target) target (char-upcase char))             (funcall (lisp-stream-out target) target (char-upcase char))
1467             (setf (case-frob-stream-out stream)             (setf (case-frob-stream-out stream)
1468                   #'case-frob-downcase-out)                   #'case-frob-downcase-out)
1469             (setf (case-frob-stream-sout stream)             (setf (case-frob-stream-sout stream)
1470                   #'case-frob-downcase-sout))                   #'case-frob-downcase-sout))
1471            (t            (t
1472             (funcall (stream-out target) target char)))))             (funcall (lisp-stream-out target) target char)))))
1473    
1474  (defun case-frob-capitalize-first-sout (stream str start end)  (defun case-frob-capitalize-first-sout (stream str start end)
1475    (declare (type case-frob-stream stream)    (declare (type case-frob-stream stream)
# Line 1387  Line 1491 
1491            (setf (case-frob-stream-sout stream)            (setf (case-frob-stream-sout stream)
1492                  #'case-frob-downcase-sout)                  #'case-frob-downcase-sout)
1493            (return))))            (return))))
1494      (funcall (stream-sout target) target str 0 len)))      (funcall (lisp-stream-sout target) target str 0 len)))
1495    
1496    
1497  ;;;; Public interface from "EXTENSIONS" package.  ;;;; Public interface from "EXTENSIONS" package.
# Line 1416  Line 1520 
1520    "This takes a stream and waits for text or a command to appear on it.  If    "This takes a stream and waits for text or a command to appear on it.  If
1521     text appears before a command, this returns nil, and otherwise it returns     text appears before a command, this returns nil, and otherwise it returns
1522     a command."     a command."
1523    (let ((cmdp (funcall (lisp::stream-misc stream) stream :get-command)))    (let ((cmdp (funcall (lisp-stream-misc stream) stream :get-command)))
1524      (cond (cmdp)      (cond (cmdp)
1525            ((listen stream)            ((listen stream)
1526             nil)             nil)
# Line 1504  Line 1608 
1608                      (type index i))                      (type index i))
1609             (funcall write-function (first rem) stream))))             (funcall write-function (first rem) stream))))
1610        (string        (string
1611         (write-string seq stream :start start :end end))         (write-string* seq stream start end))
1612        (vector        (vector
1613         (let ((write-function         (let ((write-function
1614                (if (subtypep (stream-element-type stream) 'character)                (if (subtypep (stream-element-type stream) 'character)

Legend:
Removed from v.1.29  
changed lines
  Added in v.1.30

  ViewVC Help
Powered by ViewVC 1.1.5