/[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.32 by dtc, Tue May 5 00:14:37 1998 UTC revision 1.33 by dtc, Fri May 15 01:03:18 1998 UTC
# Line 11  Line 11 
11  ;;;  ;;;
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.
15  ;;;  ;;;
16  ;;; This file contains the OS-independent stream functions.  ;;; This file contains the OS-independent stream functions.
17  ;;;  ;;;
# Line 255  Line 256 
256    newline character."    newline character."
257    (declare (ignore recursive-p))    (declare (ignore recursive-p))
258    (let ((stream (in-synonym-of stream)))    (let ((stream (in-synonym-of stream)))
259      (etypecase stream      (if (lisp-stream-p stream)
260        (lisp-stream          (prepare-for-fast-read-char stream
261         (prepare-for-fast-read-char stream            (let ((res (make-string 80))
262           (let ((res (make-string 80))                  (len 80)
263                 (len 80)                  (index 0))
264                 (index 0))              (loop
265             (loop               (let ((ch (fast-read-char nil nil)))
266              (let ((ch (fast-read-char nil nil)))                 (cond (ch
267                (cond (ch                        (when (char= ch #\newline)
268                       (when (char= ch #\newline)                          (done-with-fast-read-char)
269                         (done-with-fast-read-char)                          (return (values (shrink-vector res index) nil)))
270                         (return (values (shrink-vector res index) nil)))                        (when (= index len)
271                       (when (= index len)                          (setq len (* len 2))
272                         (setq len (* len 2))                          (let ((new (make-string len)))
273                         (let ((new (make-string len)))                            (replace new res)
274                           (replace new res)                            (setq res new)))
275                           (setq res new)))                        (setf (schar res index) ch)
276                       (setf (schar res index) ch)                        (incf index))
277                       (incf index))                       ((zerop index)
278                      ((zerop index)                        (done-with-fast-read-char)
279                       (done-with-fast-read-char)                        (return (values (eof-or-lose stream eof-errorp eof-value)
280                       (return (values (eof-or-lose stream eof-errorp eof-value)                                        t)))
281                                       t)))                       ;; since fast-read-char hit already the eof char, we
282                      ;; since fast-read-char hit already the eof char, we                       ;; shouldn't do another read-char
283                      ;; shouldn't do another read-char                       (t
284                      (t                        (done-with-fast-read-char)
285                       (done-with-fast-read-char)                        (return (values (shrink-vector res index) t))))))))
286                       (return (values (shrink-vector res index) t)))))))))          ;; Fundamental-stream.
287        (fundamental-stream          (multiple-value-bind (string eof)
288         (multiple-value-bind (string eof)              (stream-read-line stream)
289             (stream-read-line stream)            (if (and eof (zerop (length string)))
290           (if (and eof (zerop (length string)))                (values (eof-or-lose stream eof-errorp eof-value) t)
291               (values (eof-or-lose stream eof-errorp eof-value) t)                (values string eof))))))
              (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 299  Line 299 
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    (let ((stream (in-synonym-of stream)))    (let ((stream (in-synonym-of stream)))
302      (etypecase stream      (if (lisp-stream-p stream)
303        (lisp-stream          (prepare-for-fast-read-char stream
304         (prepare-for-fast-read-char stream            (prog1
305           (prog1                (fast-read-char eof-errorp eof-value)
306               (fast-read-char eof-errorp eof-value)              (done-with-fast-read-char)))
307             (done-with-fast-read-char))))          ;; Fundamental-stream.
308        (fundamental-stream          (let ((char (stream-read-char stream)))
309         (let ((char (stream-read-char stream)))            (if (eq char :eof)
310           (if (eq char :eof)                (eof-or-lose stream eof-errorp eof-value)
311               (eof-or-lose stream eof-errorp eof-value)                char)))))
              char))))))  
312    
313  (defun unread-char (character &optional (stream *standard-input*))  (defun unread-char (character &optional (stream *standard-input*))
314    "Puts the Character back on the front of the input Stream."    "Puts the Character back on the front of the input Stream."
315    (let ((stream (in-synonym-of stream)))    (let ((stream (in-synonym-of stream)))
316      (etypecase stream      (if (lisp-stream-p stream)
317        (lisp-stream          (let ((index (1- (lisp-stream-in-index stream)))
318         (let ((index (1- (lisp-stream-in-index stream)))                (buffer (lisp-stream-in-buffer stream)))
319               (buffer (lisp-stream-in-buffer stream)))            (declare (fixnum index))
320           (declare (fixnum index))            (when (minusp index) (error "Nothing to unread."))
321           (when (minusp index) (error "Nothing to unread."))            (cond (buffer
322           (cond (buffer                   (setf (aref buffer index) (char-code character))
323                  (setf (aref buffer index) (char-code character))                   (setf (lisp-stream-in-index stream) index))
324                  (setf (lisp-stream-in-index stream) index))                  (t
325                 (t                   (funcall (lisp-stream-misc stream) stream
326                  (funcall (lisp-stream-misc stream) stream                            :unread character))))
327                           :unread character)))))          ;; Fundamental-stream
328        (fundamental-stream          (stream-unread-char stream character)))
        (stream-unread-char stream character))))  
329    nil)    nil)
330    
331  (defun peek-char (&optional (peek-type nil) (stream *standard-input*)  (defun peek-char (&optional (peek-type nil) (stream *standard-input*)
# Line 335  Line 333 
333    "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."
334    (declare (ignore recursive-p))    (declare (ignore recursive-p))
335    (let ((stream (in-synonym-of stream)))    (let ((stream (in-synonym-of stream)))
336      (etypecase stream      (if (lisp-stream-p stream)
337        (lisp-stream          (let ((char (read-char stream eof-errorp eof-value)))
338         (let ((char (read-char stream eof-errorp eof-value)))            (cond ((eq char eof-value) char)
339           (cond ((eq char eof-value) char)                  ((characterp peek-type)
340                 ((characterp peek-type)                   (do ((char char (read-char stream eof-errorp eof-value)))
341                  (do ((char char (read-char stream eof-errorp eof-value)))                       ((or (eq char eof-value) (char= char peek-type))
342                      ((or (eq char eof-value) (char= char peek-type))                        (unless (eq char eof-value)
343                       (unless (eq char eof-value)                          (unread-char char stream))
344                         (unread-char char stream))                        char)))
345                       char)))                  ((eq peek-type t)
346                 ((eq peek-type t)                   (do ((char char (read-char stream eof-errorp eof-value)))
347                  (do ((char char (read-char stream eof-errorp eof-value)))                       ((or (eq char eof-value) (not (whitespace-char-p char)))
348                      ((or (eq char eof-value) (not (whitespace-char-p char)))                        (unless (eq char eof-value)
349                       (unless (eq char eof-value)                          (unread-char char stream))
350                         (unread-char char stream))                        char)))
351                       char)))                  (t
352                 (t                   (unread-char char stream)
353                  (unread-char char stream)                   char)))
354                  char))))          ;; Fundamental-stream.
355        (fundamental-stream          (cond ((characterp peek-type)
356         (cond ((characterp peek-type)                 (do ((char (stream-read-char stream) (stream-read-char stream)))
357                (do ((char (stream-read-char stream) (stream-read-char stream)))                     ((or (eq char :eof) (char= char peek-type))
358                    ((or (eq char :eof) (char= char peek-type))                      (cond ((eq char :eof)
359                     (cond ((eq char :eof)                             (eof-or-lose stream eof-errorp eof-value))
360                            (eof-or-lose stream eof-errorp eof-value))                            (t
361                           (t                             (stream-unread-char stream char)
362                            (stream-unread-char stream char)                             char)))))
363                            char)))))                ((eq peek-type t)
364               ((eq peek-type t)                 (do ((char (stream-read-char stream) (stream-read-char stream)))
365                (do ((char (stream-read-char stream) (stream-read-char stream)))                     ((or (eq char :eof) (not (whitespace-char-p char)))
366                    ((or (eq char :eof) (not (whitespace-char-p char)))                      (cond ((eq char :eof)
367                     (cond ((eq char :eof)                             (eof-or-lose stream eof-errorp eof-value))
368                            (eof-or-lose stream eof-errorp eof-value))                            (t
369                           (t                             (stream-unread-char stream char)
370                            (stream-unread-char stream char)                             char)))))
371                            char)))))                (t
372               (t                 (let ((char (stream-peek-char stream)))
373                (let ((char (stream-peek-char stream)))                   (if (eq char :eof)
374                  (if (eq char :eof)                       (eof-or-lose stream eof-errorp eof-value)
375                      (eof-or-lose stream eof-errorp eof-value)                       char)))))))
                     char))))))))  
376    
377  (defun listen (&optional (stream *standard-input*))  (defun listen (&optional (stream *standard-input*))
378    "Returns T if a character is availible on the given Stream."    "Returns T if a character is availible on the given Stream."
379    (let ((stream (in-synonym-of stream)))    (let ((stream (in-synonym-of stream)))
380      (etypecase stream      (if (lisp-stream-p stream)
381        (lisp-stream          (or (/= (the fixnum (lisp-stream-in-index stream)) in-buffer-length)
382         (or (/= (the fixnum (lisp-stream-in-index stream)) in-buffer-length)              ;; Test for t explicitly since misc methods return :eof sometimes.
383             ;; Test for t explicitly since misc methods return :eof sometimes.              (eq (funcall (lisp-stream-misc stream) stream :listen) t))
384             (eq (funcall (lisp-stream-misc stream) stream :listen) t)))          ;; Fundamental-stream.
385        (fundamental-stream          (stream-listen stream))))
        (stream-listen stream)))))  
386    
387  (defun read-char-no-hang (&optional (stream *standard-input*)  (defun read-char-no-hang (&optional (stream *standard-input*)
388                                      (eof-errorp t) eof-value recursive-p)                                      (eof-errorp t) eof-value recursive-p)
389    "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."
390    (declare (ignore recursive-p))    (declare (ignore recursive-p))
391    (let ((stream (in-synonym-of stream)))    (let ((stream (in-synonym-of stream)))
392      (etypecase stream      (if (lisp-stream-p stream)
393        (lisp-stream          (if (funcall (lisp-stream-misc stream) stream :listen)
394         (if (funcall (lisp-stream-misc stream) stream :listen)              ;; On t or :eof get READ-CHAR to do the work.
395             ;; On t or :eof get READ-CHAR to do the work.              (read-char stream eof-errorp eof-value)
396             (read-char stream eof-errorp eof-value)              nil)
397             nil))          ;; Fundamental-stream.
398        (fundamental-stream          (let ((char (stream-read-char-no-hang stream)))
399         (let ((char (stream-read-char-no-hang stream)))            (if (eq char :eof)
400           (if (eq char :eof)                (eof-or-lose stream eof-errorp eof-value)
401               (eof-or-lose stream eof-errorp eof-value)                char)))))
              char))))))  
402    
403    
404  (defun clear-input (&optional (stream *standard-input*))  (defun clear-input (&optional (stream *standard-input*))
405    "Clears any buffered input associated with the Stream."    "Clears any buffered input associated with the Stream."
406    (let ((stream (in-synonym-of stream)))    (let ((stream (in-synonym-of stream)))
407      (etypecase stream      (cond ((lisp-stream-p stream)
408        (lisp-stream             (setf (lisp-stream-in-index stream) in-buffer-length)
409         (setf (lisp-stream-in-index stream) in-buffer-length)             (funcall (lisp-stream-misc stream) stream :clear-input))
410         (funcall (lisp-stream-misc stream) stream :clear-input))            (t
411        (fundamental-stream             (stream-clear-input stream))))
        (stream-clear-input stream))))  
412    nil)    nil)
413    
414  (defun read-byte (stream &optional (eof-errorp t) eof-value)  (defun read-byte (stream &optional (eof-errorp t) eof-value)
415    "Returns the next byte of the Stream."    "Returns the next byte of the Stream."
416    (let ((stream (in-synonym-of stream)))    (let ((stream (in-synonym-of stream)))
417      (etypecase stream      (if (lisp-stream-p stream)
418        (lisp-stream          (prepare-for-fast-read-byte stream
419         (prepare-for-fast-read-byte stream            (prog1
420           (prog1                (fast-read-byte eof-errorp eof-value t)
421               (fast-read-byte eof-errorp eof-value t)              (done-with-fast-read-byte)))
422             (done-with-fast-read-byte))))          ;; Fundamental-stream.
423        (fundamental-stream          (let ((char (stream-read-byte stream)))
424         (let ((char (stream-read-byte stream)))            (if (eq char :eof)
425           (if (eq char :eof)                (eof-or-lose stream eof-errorp eof-value)
426               (eof-or-lose stream eof-errorp eof-value)                char)))))
              char))))))  
427    
428  (defun read-n-bytes (stream buffer start numbytes &optional (eof-errorp t))  (defun read-n-bytes (stream buffer start numbytes &optional (eof-errorp t))
429    "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 541  Line 534 
534    "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
535     a line.  Returns T if it output a new line, nil otherwise."     a line.  Returns T if it output a new line, nil otherwise."
536    (let ((stream (out-synonym-of stream)))    (let ((stream (out-synonym-of stream)))
537      (etypecase stream      (if (lisp-stream-p stream)
538        (lisp-stream          (when (/= (or (charpos stream) 1) 0)
539         (when (/= (or (charpos stream) 1) 0)            (funcall (lisp-stream-out stream) stream #\newline)
540           (funcall (lisp-stream-out stream) stream #\newline)            t)
541           t))          ;; Fundamental-stream.
542        (fundamental-stream          (stream-fresh-line stream))))
        (stream-fresh-line stream)))))  
543    
544  (defun write-string (string &optional (stream *standard-output*)  (defun write-string (string &optional (stream *standard-output*)
545                              &key (start 0) (end (length (the vector string))))                              &key (start 0) (end (length (the vector string))))
# Line 558  Line 550 
550                               (start 0) (end (length (the vector string))))                               (start 0) (end (length (the vector string))))
551    (declare (fixnum start end))    (declare (fixnum start end))
552    (let ((stream (out-synonym-of stream)))    (let ((stream (out-synonym-of stream)))
553      (etypecase stream      (cond ((lisp-stream-p stream)
554        (lisp-stream             (if (array-header-p string)
555         (if (array-header-p string)                 (with-array-data ((data string) (offset-start start)
556             (with-array-data ((data string) (offset-start start)                                   (offset-end end))
557                               (offset-end end))                   (funcall (lisp-stream-sout stream)
558               (funcall (lisp-stream-sout stream)                            stream data offset-start offset-end))
559                        stream data offset-start offset-end))                 (funcall (lisp-stream-sout stream) stream string start end))
560             (funcall (lisp-stream-sout stream) stream string start end))             string)
561         string)            (t    ; Fundamental-stream.
562        (fundamental-stream             (stream-write-string stream string start end)))))
        (stream-write-string stream string start end)))))  
563    
564  (defun write-line (string &optional (stream *standard-output*)  (defun write-line (string &optional (stream *standard-output*)
565                            &key (start 0) (end (length string)))                            &key (start 0) (end (length string)))
# Line 579  Line 570 
570                             (start 0) (end (length string)))                             (start 0) (end (length string)))
571    (declare (fixnum start end))    (declare (fixnum start end))
572    (let ((stream (out-synonym-of stream)))    (let ((stream (out-synonym-of stream)))
573      (etypecase stream      (cond ((lisp-stream-p stream)
574        (lisp-stream             (if (array-header-p string)
575         (if (array-header-p string)                 (with-array-data ((data string) (offset-start start)
576             (with-array-data ((data string) (offset-start start)                                   (offset-end end))
577                               (offset-end end))                   (with-out-stream stream (lisp-stream-sout data offset-start
578               (with-out-stream stream (lisp-stream-sout data offset-start                                                             offset-end)))
579                                                         offset-end)))                 (with-out-stream stream (lisp-stream-sout string start end)))
580             (with-out-stream stream (lisp-stream-sout string start end)))             (funcall (lisp-stream-out stream) stream #\newline))
581         (funcall (lisp-stream-out stream) stream #\newline))            (t    ; Fundamental-stream.
582        (fundamental-stream             (stream-write-string stream string start end)
583         (stream-write-string stream string start end)             (stream-write-char stream #\Newline)))
        (stream-write-char stream #\Newline)))  
584      string))      string))
585    
586  (defun charpos (&optional (stream *standard-output*))  (defun charpos (&optional (stream *standard-output*))
# Line 628  Line 618 
618    (with-out-stream stream (lisp-stream-bout integer) (stream-write-byte))    (with-out-stream stream (lisp-stream-bout integer) (stream-write-byte))
619    integer)    integer)
620    
621    
622    ;;; Stream-misc-dispatch
623    ;;;
624    ;;; Called from lisp-steam routines that encapsulate CLOS streams to
625    ;;; handle the misc routines and dispatch to the appropriate Gray
626    ;;; stream functions.
627    ;;;
628    (defun stream-misc-dispatch (stream operation &optional arg1 arg2)
629      (declare (type fundamental-stream stream)
630               (ignore arg2))
631      (case operation
632        (:listen
633         ;; Return true is input available, :eof for eof-of-file, otherwise Nil.
634         (let ((char (stream-read-char-no-hang stream)))
635           (when (characterp char)
636             (stream-unread-char stream char))
637           char))
638        (:unread
639         (stream-unread-char stream arg1))
640        (:close
641         (close stream))
642        (:clear-input
643         (stream-clear-input stream))
644        (:force-output
645         (stream-force-output stream))
646        (:finish-output
647         (stream-finish-output stream))
648        (:element-type
649         (stream-element-type stream))
650        (:interactive-p
651         (interactive-stream-p stream))
652        (:line-length
653         (stream-line-length stream))
654        (:charpos
655         (stream-line-column stream))
656        (:file-length
657         (file-length stream))
658        (:file-position
659         (file-position stream arg1))))
660    
661    
662  ;;;; Broadcast streams:  ;;;; Broadcast streams:
663    
664  (defstruct (broadcast-stream (:include lisp-stream  (defstruct (broadcast-stream (:include lisp-stream
# Line 647  Line 678 
678    (declare (ignore s d))    (declare (ignore s d))
679    (write-string "#<Broadcast Stream>" stream))    (write-string "#<Broadcast Stream>" stream))
680    
681  (macrolet ((out-fun (fun method &rest args)  (macrolet ((out-fun (fun method stream-method &rest args)
682               `(defun ,fun (stream ,@args)               `(defun ,fun (stream ,@args)
683                  (dolist (stream (broadcast-stream-streams stream))                  (dolist (stream (broadcast-stream-streams stream))
684                    (funcall (,method stream) stream ,@args)))))                    (if (lisp-stream-p stream)
685    (out-fun broadcast-out lisp-stream-out char)                        (funcall (,method stream) stream ,@args)
686    (out-fun broadcast-bout lisp-stream-bout byte)                        (,stream-method stream ,@args))))))
687    (out-fun broadcast-sout lisp-stream-sout string start end))    (out-fun broadcast-out lisp-stream-out stream-write-char char)
688      (out-fun broadcast-bout lisp-stream-bout stream-write-byte byte)
689      (out-fun broadcast-sout lisp-stream-sout stream-write-string
690               string start end))
691    
692  (defun broadcast-misc (stream operation &optional arg1 arg2)  (defun broadcast-misc (stream operation &optional arg1 arg2)
693    (let ((streams (broadcast-stream-streams stream)))    (let ((streams (broadcast-stream-streams stream)))
694      (case operation      (case operation
695        (:charpos        (:charpos
696         (dolist (stream streams)         (dolist (stream streams)
697           (let ((charpos (funcall (lisp-stream-misc stream) stream :charpos)))           (let ((charpos (charpos stream)))
698             (if charpos (return charpos)))))             (if charpos (return charpos)))))
699        (:line-length        (:line-length
700         (let ((min nil))         (let ((min nil))
701           (dolist (stream streams min)           (dolist (stream streams min)
702             (let ((res (funcall (lisp-stream-misc stream) stream :line-length)))             (let ((res (line-length stream)))
703               (when res (setq min (if min (min res min) res)))))))               (when res (setq min (if min (min res min) res)))))))
704        (:element-type        (:element-type
705         (let (res)         (let (res)
706           (dolist (stream streams (if (> (length res) 1) `(and ,@res) res))           (dolist (stream streams (if (> (length res) 1) `(and ,@res) res))
707             (pushnew (funcall (lisp-stream-misc stream) stream :element-type) res             (pushnew (stream-element-type stream) res :test #'equal))))
                     :test #'equal))))  
708        (:close)        (:close)
709        (t        (t
710         (let ((res nil))         (let ((res nil))
711           (dolist (stream streams res)           (dolist (stream streams res)
712             (setq res (funcall (lisp-stream-misc stream) stream operation             (setq res
713                                arg1 arg2))))))))                   (if (lisp-stream-p stream)
714                         (funcall (lisp-stream-misc stream) stream operation
715                                  arg1 arg2)
716                         (stream-misc-dispatch stream operation arg1 arg2)))))))))
717    
718    
719  ;;;; Synonym Streams:  ;;;; Synonym Streams:
720    
# Line 705  Line 742 
742  ;;; The output simple output methods just call the corresponding method  ;;; The output simple output methods just call the corresponding method
743  ;;; in the synonymed stream.  ;;; in the synonymed stream.
744  ;;;  ;;;
745  (macrolet ((out-fun (name slot &rest args)  (macrolet ((out-fun (name slot stream-method &rest args)
746               `(defun ,name (stream ,@args)               `(defun ,name (stream ,@args)
747                  (declare (optimize (safety 1)))                  (declare (optimize (safety 1)))
748                  (let ((syn (symbol-value (synonym-stream-symbol stream))))                  (let ((syn (symbol-value (synonym-stream-symbol stream))))
749                    (funcall (,slot syn) syn ,@args)))))                    (if (lisp-stream-p syn)
750    (out-fun synonym-out lisp-stream-out ch)                        (funcall (,slot syn) syn ,@args)
751    (out-fun synonym-bout lisp-stream-bout n)                        (,stream-method syn ,@args))))))
752    (out-fun synonym-sout lisp-stream-sout string start end))    (out-fun synonym-out lisp-stream-out stream-write-char ch)
753      (out-fun synonym-bout lisp-stream-bout stream-write-byte n)
754      (out-fun synonym-sout lisp-stream-sout stream-write-string string start end))
755    
756    
757  ;;; 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 743  Line 782 
782    (declare (optimize (safety 1)))    (declare (optimize (safety 1)))
783    (let ((syn (symbol-value (synonym-stream-symbol stream)))    (let ((syn (symbol-value (synonym-stream-symbol stream)))
784          (*previous-stream* stream))          (*previous-stream* stream))
785      (case operation      (if (lisp-stream-p syn)
786        (:listen (or (/= (the fixnum (lisp-stream-in-index syn)) in-buffer-length)          (case operation
787                     (funcall (lisp-stream-misc syn) syn :listen)))            (:listen (or (/= (the fixnum (lisp-stream-in-index syn))
788        (t                             in-buffer-length)
789         (funcall (lisp-stream-misc syn) syn operation arg1 arg2)))))                         (funcall (lisp-stream-misc syn) syn :listen)))
790              (t
791               (funcall (lisp-stream-misc syn) syn operation arg1 arg2)))
792            (stream-misc-dispatch syn operation arg1 arg2))))
793    
794  ;;;; Two-Way streams:  ;;;; Two-Way streams:
795    
# Line 777  Line 819 
819    "Returns a bidirectional stream which gets its input from Input-Stream and    "Returns a bidirectional stream which gets its input from Input-Stream and
820     sends its output to Output-Stream.")     sends its output to Output-Stream.")
821    
822  (macrolet ((out-fun (name slot &rest args)  (macrolet ((out-fun (name slot stream-method &rest args)
823               `(defun ,name (stream ,@args)               `(defun ,name (stream ,@args)
824                  (let ((syn (two-way-stream-output-stream stream)))                  (let ((syn (two-way-stream-output-stream stream)))
825                    (funcall (,slot syn) syn ,@args)))))                    (if (lisp-stream-p syn)
826    (out-fun two-way-out lisp-stream-out ch)                        (funcall (,slot syn) syn ,@args)
827    (out-fun two-way-bout lisp-stream-bout n)                        (,stream-method syn ,@args))))))
828    (out-fun two-way-sout lisp-stream-sout string start end))    (out-fun two-way-out lisp-stream-out stream-write-char ch)
829      (out-fun two-way-bout lisp-stream-bout stream-write-byte n)
830      (out-fun two-way-sout lisp-stream-sout stream-write-string string start end))
831    
832  (macrolet ((in-fun (name fun &rest args)  (macrolet ((in-fun (name fun &rest args)
833               `(defun ,name (stream ,@args)               `(defun ,name (stream ,@args)
# Line 795  Line 839 
839    
840  (defun two-way-misc (stream operation &optional arg1 arg2)  (defun two-way-misc (stream operation &optional arg1 arg2)
841    (let* ((in (two-way-stream-input-stream stream))    (let* ((in (two-way-stream-input-stream stream))
          (in-method (lisp-stream-misc in))  
842           (out (two-way-stream-output-stream stream))           (out (two-way-stream-output-stream stream))
843           (out-method (lisp-stream-misc out)))           (in-lisp-stream-p (lisp-stream-p in))
844             (out-lisp-stream-p (lisp-stream-p out)))
845      (case operation      (case operation
846        (:listen (or (/= (the fixnum (lisp-stream-in-index in)) in-buffer-length)        (:listen
847                     (funcall in-method in :listen)))         (if in-lisp-stream-p
848               (or (/= (the fixnum (lisp-stream-in-index in)) in-buffer-length)
849                   (funcall (lisp-stream-misc in) in :listen))
850               (stream-listen in)))
851        ((:finish-output :force-output :clear-output)        ((:finish-output :force-output :clear-output)
852         (funcall out-method out operation arg1 arg2))         (if out-lisp-stream-p
853               (funcall (lisp-stream-misc out) out operation arg1 arg2)
854               (stream-misc-dispatch out operation arg1 arg2)))
855        ((:clear-input :unread)        ((:clear-input :unread)
856         (funcall in-method in operation arg1 arg2))         (if in-lisp-stream-p
857               (funcall (lisp-stream-misc in) in operation arg1 arg2)
858               (stream-misc-dispatch in operation arg1 arg2)))
859        (:element-type        (:element-type
860         (let ((in-type (funcall in-method in :element-type))         (let ((in-type (stream-element-type in))
861               (out-type (funcall out-method out :element-type)))               (out-type (stream-element-type out)))
862           (if (equal in-type out-type)           (if (equal in-type out-type)
863               in-type `(and ,in-type ,out-type))))               in-type `(and ,in-type ,out-type))))
864        (:close        (:close
865         (set-closed-flame stream))         (set-closed-flame stream))
866        (t        (t
867         (or (funcall in-method in operation arg1 arg2)         (or (if in-lisp-stream-p
868             (funcall out-method out operation arg1 arg2))))))                 (funcall (lisp-stream-misc in) in operation arg1 arg2)
869                   (stream-misc-dispatch in operation arg1 arg2))
870               (if out-lisp-stream-p
871                   (funcall (lisp-stream-misc out) out operation arg1 arg2)
872                   (stream-misc-dispatch out operation arg1 arg2)))))))
873    
874    
875  ;;;; Concatenated Streams:  ;;;; Concatenated Streams:
876    
# Line 856  Line 912 
912  (defun concatenated-misc (stream operation &optional arg1 arg2)  (defun concatenated-misc (stream operation &optional arg1 arg2)
913    (let ((left (concatenated-stream-current stream)))    (let ((left (concatenated-stream-current stream)))
914      (when left      (when left
915        (let* ((current (car left))        (let* ((current (car left)))
              (misc (lisp-stream-misc current)))  
916          (case operation          (case operation
917            (:listen            (:listen
918             (loop             (loop
919               (let ((stuff (funcall misc current :listen)))               (let ((stuff (if (lisp-stream-p current)
920                                  (funcall (lisp-stream-misc current) current
921                                           :listen)
922                                  (stream-misc-dispatch current :listen))))
923                 (cond ((eq stuff :eof)                 (cond ((eq stuff :eof)
924                        ;; Advance current, and try again.                        ;; Advance current, and try again.
925                        (pop (concatenated-stream-current stream))                        (pop (concatenated-stream-current stream))
# Line 869  Line 927 
927                              (car (concatenated-stream-current stream)))                              (car (concatenated-stream-current stream)))
928                        (unless current                        (unless current
929                          ;; No further streams.  EOF.                          ;; No further streams.  EOF.
930                          (return :eof))                          (return :eof)))
                       (setf misc (lisp-stream-misc current)))  
931                       (stuff                       (stuff
932                        ;; Stuff's available.                        ;; Stuff's available.
933                        (return t))                        (return t))
# Line 880  Line 937 
937            (:close            (:close
938             (set-closed-flame stream))             (set-closed-flame stream))
939            (t            (t
940             (funcall misc current operation arg1 arg2)))))))             (if (lisp-stream-p current)
941                   (funcall (lisp-stream-misc current) current operation arg1 arg2)
942                   (stream-misc-dispatch current operation arg1 arg2))))))))
943    
944    
945  ;;;; Echo Streams:  ;;;; Echo Streams:
946    
# Line 895  Line 955 
955    unread-stuff)    unread-stuff)
956    
957    
958  (macrolet ((in-fun (name fun out-slot &rest args)  (macrolet ((in-fun (name fun out-slot stream-method &rest args)
959               `(defun ,name (stream ,@args)               `(defun ,name (stream ,@args)
960                  (or (pop (echo-stream-unread-stuff stream))                  (or (pop (echo-stream-unread-stuff stream))
961                      (let* ((in (echo-stream-input-stream stream))                      (let* ((in (echo-stream-input-stream stream))
962                             (out (echo-stream-output-stream stream))                             (out (echo-stream-output-stream stream))
963                             (result (,fun in ,@args)))                             (result (,fun in ,@args)))
964                        (funcall (,out-slot out) out result)                        (if (lisp-stream-p out)
965                              (funcall (,out-slot out) out result)
966                              (,stream-method out result))
967                        result)))))                        result)))))
968    (in-fun echo-in read-char lisp-stream-out eof-errorp eof-value)    (in-fun echo-in read-char lisp-stream-out stream-write-char
969    (in-fun echo-bin read-byte lisp-stream-bout eof-errorp eof-value))            eof-errorp eof-value)
970      (in-fun echo-bin read-byte lisp-stream-bout stream-write-byte
971              eof-errorp eof-value))
972    
973  (defun echo-misc (stream operation &optional arg1 arg2)  (defun echo-misc (stream operation &optional arg1 arg2)
974    (let* ((in (two-way-stream-input-stream stream))    (let* ((in (two-way-stream-input-stream stream))
975           (in-method (lisp-stream-misc in))           (out (two-way-stream-output-stream stream)))
          (out (two-way-stream-output-stream stream))  
          (out-method (lisp-stream-misc out)))  
976      (case operation      (case operation
977        (:listen (or (not (null (echo-stream-unread-stuff stream)))        (:listen
978                     (/= (the fixnum (lisp-stream-in-index in)) in-buffer-length)         (or (not (null (echo-stream-unread-stuff stream)))
979                     (funcall in-method in :listen)))             (if (lisp-stream-p in)
980                   (or (/= (the fixnum (lisp-stream-in-index in)) in-buffer-length)
981                       (funcall (lisp-stream-misc in) in :listen))
982                   (stream-misc-dispatch in :listen))))
983        (:unread (push arg1 (echo-stream-unread-stuff stream)))        (:unread (push arg1 (echo-stream-unread-stuff stream)))
984        (:element-type        (:element-type
985         (let ((in-type (funcall in-method in :element-type))         (let ((in-type (stream-element-type in))
986               (out-type (funcall out-method out :element-type)))               (out-type (stream-element-type out)))
987           (if (equal in-type out-type)           (if (equal in-type out-type)
988               in-type `(and ,in-type ,out-type))))               in-type `(and ,in-type ,out-type))))
989        (:close        (:close
990         (set-closed-flame stream))         (set-closed-flame stream))
991        (t        (t
992         (or (funcall in-method in operation arg1 arg2)         (or (if (lisp-stream-p in)
993             (funcall out-method out operation arg1 arg2))))))                 (funcall (lisp-stream-misc in) in operation arg1 arg2)
994                   (stream-misc-dispatch in operation arg1 arg2))
995               (if (lisp-stream-p out)
996                   (funcall (lisp-stream-misc out) out operation arg1 arg2)
997                   (stream-misc-dispatch out operation arg1 arg2)))))))
998    
999  (defun %print-echo-stream (s stream d)  (defun %print-echo-stream (s stream d)
1000    (declare (ignore d))    (declare (ignore d))
# Line 1262  Line 1331 
1331    
1332  (defun indenting-misc (stream operation &optional arg1 arg2)  (defun indenting-misc (stream operation &optional arg1 arg2)
1333    (let ((sub-stream (indenting-stream-stream stream)))    (let ((sub-stream (indenting-stream-stream stream)))
1334      (etypecase sub-stream      (if (lisp-stream-p sub-stream)
1335        (lisp-stream          (let ((method (lisp-stream-misc sub-stream)))
1336         (let ((method (lisp-stream-misc sub-stream)))            (case operation
1337           (case operation              (:line-length
1338             (:line-length               (let ((line-length (funcall method sub-stream operation)))
1339              (let ((line-length (funcall method sub-stream operation)))                 (if line-length
1340                (if line-length                     (- line-length (indenting-stream-indentation stream)))))
1341                    (- line-length (indenting-stream-indentation stream)))))              (:charpos
1342             (:charpos               (let ((charpos (funcall method sub-stream operation)))
1343              (let ((charpos (funcall method sub-stream operation)))                 (if charpos
1344                (if charpos                     (- charpos (indenting-stream-indentation stream)))))
1345                    (- charpos (indenting-stream-indentation stream)))))              (t
1346             (t               (funcall method sub-stream operation arg1 arg2))))
1347              (funcall method sub-stream operation arg1 arg2)))))          ;; Fundamental-stream.
1348        (fundamental-stream          (case operation
1349         (case operation            (:line-length
1350           (:line-length             (let ((line-length (stream-line-length sub-stream)))
1351            (let ((line-length (stream-line-length sub-stream)))               (if line-length
1352              (if line-length                   (- line-length (indenting-stream-indentation stream)))))
1353                  (- line-length (indenting-stream-indentation stream)))))            (:charpos
1354           (:charpos             (let ((charpos (stream-line-column sub-stream)))
1355            (let ((charpos (stream-line-column sub-stream)))               (if charpos
1356              (if charpos                   (- charpos (indenting-stream-indentation stream)))))
1357                  (- charpos (indenting-stream-indentation stream)))))            (t
1358           (t             (stream-misc-dispatch sub-stream operation arg1 arg2))))))
           ;; XX TODO  
           (format t "* Warning: ignoring ~s ~s ~s on ~s~%"  
                   operation arg1 arg2 sub-stream)))))))  
1359    
1360    
1361  (proclaim '(maybe-inline read-char unread-char read-byte listen))  (proclaim '(maybe-inline read-char unread-char read-byte listen))
# Line 1345  Line 1411 
1411      (:close)      (:close)
1412      (t      (t
1413       (let ((target (case-frob-stream-target stream)))       (let ((target (case-frob-stream-target stream)))
1414         (funcall (lisp-stream-misc target) target op arg1 arg2)))))         (if (lisp-stream-p target)
1415               (funcall (lisp-stream-misc target) target op arg1 arg2)
1416               (stream-misc-dispatch target op arg1 arg2))))))
1417    
1418  (defun case-frob-upcase-out (stream char)  (defun case-frob-upcase-out (stream char)
1419    (declare (type case-frob-stream stream)    (declare (type case-frob-stream stream)
1420             (type base-char char))             (type base-char char))
1421    (let ((target (case-frob-stream-target stream)))    (let ((target (case-frob-stream-target stream))
1422      (funcall (lisp-stream-out target) target (char-upcase char))))          (char (char-upcase char)))
1423        (if (lisp-stream-p target)
1424            (funcall (lisp-stream-out target) target char)
1425            (stream-write-char target char))))
1426    
1427  (defun case-frob-upcase-sout (stream str start end)  (defun case-frob-upcase-sout (stream str start end)
1428    (declare (type case-frob-stream stream)    (declare (type case-frob-stream stream)
# Line 1361  Line 1431 
1431             (type (or index null) end))             (type (or index null) end))
1432    (let* ((target (case-frob-stream-target stream))    (let* ((target (case-frob-stream-target stream))
1433           (len (length str))           (len (length str))
1434           (end (or end len)))           (end (or end len))
1435      (funcall (lisp-stream-sout target) target           (string (if (and (zerop start) (= len end))
1436               (if (and (zerop start) (= len end))                       (string-upcase str)
1437                   (string-upcase str)                       (nstring-upcase (subseq str start end))))
1438                   (nstring-upcase (subseq str start end)))           (string-len (- end start)))
1439               0      (if (lisp-stream-p target)
1440               (- end start))))          (funcall (lisp-stream-sout target) target string 0 string-len)
1441            (stream-write-string target string 0 string-len))))
1442    
1443  (defun case-frob-downcase-out (stream char)  (defun case-frob-downcase-out (stream char)
1444    (declare (type case-frob-stream stream)    (declare (type case-frob-stream stream)
1445             (type base-char char))             (type base-char char))
1446    (let ((target (case-frob-stream-target stream)))    (let ((target (case-frob-stream-target stream))
1447      (funcall (lisp-stream-out target) target (char-downcase char))))          (char (char-downcase char)))
1448        (if (lisp-stream-p target)
1449            (funcall (lisp-stream-out target) target char)
1450            (stream-write-char target char))))
1451    
1452  (defun case-frob-downcase-sout (stream str start end)  (defun case-frob-downcase-sout (stream str start end)
1453    (declare (type case-frob-stream stream)    (declare (type case-frob-stream stream)
# Line 1382  Line 1456 
1456             (type (or index null) end))             (type (or index null) end))
1457    (let* ((target (case-frob-stream-target stream))    (let* ((target (case-frob-stream-target stream))
1458           (len (length str))           (len (length str))
1459           (end (or end len)))           (end (or end len))
1460      (funcall (lisp-stream-sout target) target           (string (if (and (zerop start) (= len end))
1461               (if (and (zerop start) (= len end))                       (string-downcase str)
1462                   (string-downcase str)                       (nstring-downcase (subseq str start end))))
1463                   (nstring-downcase (subseq str start end)))           (string-len (- end start)))
1464               0      (if (lisp-stream-p target)
1465               (- end start))))          (funcall (lisp-stream-sout target) target string 0 string-len)
1466            (stream-write-string target string 0 string-len))))
1467    
1468  (defun case-frob-capitalize-out (stream char)  (defun case-frob-capitalize-out (stream char)
1469    (declare (type case-frob-stream stream)    (declare (type case-frob-stream stream)
1470             (type base-char char))             (type base-char char))
1471    (let ((target (case-frob-stream-target stream)))    (let ((target (case-frob-stream-target stream)))
1472      (cond ((alphanumericp char)      (cond ((alphanumericp char)
1473             (funcall (lisp-stream-out target) target (char-upcase char))             (let ((char (char-upcase char)))
1474             (setf (case-frob-stream-out stream)               (if (lisp-stream-p target)
1475                   #'case-frob-capitalize-aux-out)                   (funcall (lisp-stream-out target) target char)
1476                     (stream-write-char target char)))
1477               (setf (case-frob-stream-out stream) #'case-frob-capitalize-aux-out)
1478             (setf (case-frob-stream-sout stream)             (setf (case-frob-stream-sout stream)
1479                   #'case-frob-capitalize-aux-sout))                   #'case-frob-capitalize-aux-sout))
1480            (t            (t
1481             (funcall (lisp-stream-out target) target char)))))             (if (lisp-stream-p target)
1482                   (funcall (lisp-stream-out target) target char)
1483                   (stream-write-char target char))))))
1484    
1485  (defun case-frob-capitalize-sout (stream str start end)  (defun case-frob-capitalize-sout (stream str start end)
1486    (declare (type case-frob-stream stream)    (declare (type case-frob-stream stream)
# Line 1426  Line 1505 
1505              #'case-frob-capitalize-aux-out)              #'case-frob-capitalize-aux-out)
1506        (setf (case-frob-stream-sout stream)        (setf (case-frob-stream-sout stream)
1507              #'case-frob-capitalize-aux-sout))              #'case-frob-capitalize-aux-sout))
1508      (funcall (lisp-stream-sout target) target str 0 len)))      (if (lisp-stream-p target)
1509            (funcall (lisp-stream-sout target) target str 0 len)
1510            (stream-write-string target str 0 len))))
1511    
1512  (defun case-frob-capitalize-aux-out (stream char)  (defun case-frob-capitalize-aux-out (stream char)
1513    (declare (type case-frob-stream stream)    (declare (type case-frob-stream stream)
1514             (type base-char char))             (type base-char char))
1515    (let ((target (case-frob-stream-target stream)))    (let ((target (case-frob-stream-target stream)))
1516      (cond ((alphanumericp char)      (cond ((alphanumericp char)
1517             (funcall (lisp-stream-out target) target (char-downcase char)))             (let ((char (char-downcase char)))
1518                 (if (lisp-stream-p target)
1519                     (funcall (lisp-stream-out target) target char)
1520                     (stream-write-char target char))))
1521            (t            (t
1522             (funcall (lisp-stream-out target) target char)             (if (lisp-stream-p target)
1523                   (funcall (lisp-stream-out target) target char)
1524                   (stream-write-char target char))
1525             (setf (case-frob-stream-out stream)             (setf (case-frob-stream-out stream)
1526                   #'case-frob-capitalize-out)                   #'case-frob-capitalize-out)
1527             (setf (case-frob-stream-sout stream)             (setf (case-frob-stream-sout stream)
# Line 1464  Line 1550 
1550              #'case-frob-capitalize-out)              #'case-frob-capitalize-out)
1551        (setf (case-frob-stream-sout stream)        (setf (case-frob-stream-sout stream)
1552              #'case-frob-capitalize-sout))              #'case-frob-capitalize-sout))
1553      (funcall (lisp-stream-sout target) target str 0 len)))      (if (lisp-stream-p target)
1554            (funcall (lisp-stream-sout target) target str 0 len)
1555            (stream-write-string target str 0 len))))
1556    
1557  (defun case-frob-capitalize-first-out (stream char)  (defun case-frob-capitalize-first-out (stream char)
1558    (declare (type case-frob-stream stream)    (declare (type case-frob-stream stream)
1559             (type base-char char))             (type base-char char))
1560    (let ((target (case-frob-stream-target stream)))    (let ((target (case-frob-stream-target stream)))
1561      (cond ((alphanumericp char)      (cond ((alphanumericp char)
1562             (funcall (lisp-stream-out target) target (char-upcase char))             (let ((char (char-upcase char)))
1563                 (if (lisp-stream-p target)
1564                     (funcall (lisp-stream-out target) target char)
1565                     (stream-write-char target char)))
1566             (setf (case-frob-stream-out stream)             (setf (case-frob-stream-out stream)
1567                   #'case-frob-downcase-out)                   #'case-frob-downcase-out)
1568             (setf (case-frob-stream-sout stream)             (setf (case-frob-stream-sout stream)
1569                   #'case-frob-downcase-sout))                   #'case-frob-downcase-sout))
1570            (t            (t
1571             (funcall (lisp-stream-out target) target char)))))             (if (lisp-stream-p target)
1572                   (funcall (lisp-stream-out target) target char)
1573                   (stream-write-char target char))))))
1574    
1575  (defun case-frob-capitalize-first-sout (stream str start end)  (defun case-frob-capitalize-first-sout (stream str start end)
1576    (declare (type case-frob-stream stream)    (declare (type case-frob-stream stream)
# Line 1499  Line 1592 
1592            (setf (case-frob-stream-sout stream)            (setf (case-frob-stream-sout stream)
1593                  #'case-frob-downcase-sout)                  #'case-frob-downcase-sout)
1594            (return))))            (return))))
1595      (funcall (lisp-stream-sout target) target str 0 len)))      (if (lisp-stream-p target)
1596            (funcall (lisp-stream-sout target) target str 0 len)
1597            (stream-write-string target str 0 len))))
1598    
1599    
1600  ;;;; Public interface from "EXTENSIONS" package.  ;;;; Public interface from "EXTENSIONS" package.

Legend:
Removed from v.1.32  
changed lines
  Added in v.1.33

  ViewVC Help
Powered by ViewVC 1.1.5