0.8.15.7
[sbcl.git] / src / code / target-stream.lisp
1 ;;;; os-independent stream functions requiring reader machinery
2
3 ;;;; This software is part of the SBCL system. See the README file for
4 ;;;; more information.
5 ;;;;
6 ;;;; This software is derived from the CMU CL system, which was
7 ;;;; written at Carnegie Mellon University and released into the
8 ;;;; public domain. The software is in the public domain and is
9 ;;;; provided with absolutely no warranty. See the COPYING and CREDITS
10 ;;;; files for more information.
11
12 (in-package "SB!IMPL")
13
14 ;;; In the interest of ``once and only once'' this macro contains the
15 ;;; framework necessary to implement a peek-char function, which has
16 ;;; two special-cases (one for gray streams and one for echo streams)
17 ;;; in addition to the normal case.
18 ;;;
19 ;;; All arguments are forms which will be used for a specific purpose
20 ;;; PEEK-TYPE - the current peek-type as defined by ANSI CL
21 ;;; EOF-VALUE - the eof-value argument to peek-char
22 ;;; CHAR-VAR - the variable which will be used to store the current character
23 ;;; READ-FORM - the form which will be used to read a character
24 ;;; UNREAD-FORM - ditto for unread-char
25 ;;; SKIPPED-CHAR-FORM - the form to execute when skipping a character
26 ;;; EOF-DETECTED-FORM - the form to execute when EOF has been detected
27 ;;;                     (this will default to CHAR-VAR)
28 (sb!xc:defmacro generalized-peeking-mechanism
29     (peek-type eof-value char-var read-form unread-form
30      &optional (skipped-char-form nil) (eof-detected-form nil))
31   `(let ((,char-var ,read-form))
32     (cond ((eql ,char-var ,eof-value) 
33            ,(if eof-detected-form
34                 eof-detected-form
35                 char-var))
36           ((characterp ,peek-type)
37            (do ((,char-var ,char-var ,read-form))
38                ((or (eql ,char-var ,eof-value) 
39                     (char= ,char-var ,peek-type))
40                 (cond ((eql ,char-var ,eof-value)
41                        ,(if eof-detected-form
42                             eof-detected-form
43                             char-var))
44                       (t ,unread-form
45                          ,char-var)))
46              ,skipped-char-form))
47           ((eql ,peek-type t)
48            (do ((,char-var ,char-var ,read-form))
49                ((or (eql ,char-var ,eof-value)
50                     (not (whitespacep ,char-var)))
51                 (cond ((eql ,char-var ,eof-value)
52                        ,(if eof-detected-form
53                             eof-detected-form
54                             char-var))
55                       (t ,unread-form
56                          ,char-var)))
57              ,skipped-char-form))
58           ((null ,peek-type)
59            ,unread-form
60            ,char-var)
61           (t
62            (bug "Impossible case reached in PEEK-CHAR")))))
63
64 ;;; rudi (2004-08-09): There was an inline declaration for read-char,
65 ;;; unread-char, read-byte, listen here that was removed because these
66 ;;; functions are redefined when simple-streams are loaded.
67
68 #!-sb-fluid (declaim (inline ansi-stream-peek-char))
69 (defun ansi-stream-peek-char (peek-type stream eof-error-p eof-value
70                               recursive-p)
71   (cond ((typep stream 'echo-stream)
72          (echo-misc stream
73                     :peek-char
74                     peek-type
75                     (list eof-error-p eof-value)))
76         (t
77          (generalized-peeking-mechanism
78           peek-type eof-value char
79           (ansi-stream-read-char stream eof-error-p eof-value recursive-p)
80           (ansi-stream-unread-char char stream)))))
81
82 (defun peek-char (&optional (peek-type nil)
83                             (stream *standard-input*)
84                             (eof-error-p t)
85                             eof-value
86                             recursive-p)
87   (the (or character boolean) peek-type)
88   (let ((stream (in-synonym-of stream)))
89     (if (ansi-stream-p stream)
90         (ansi-stream-peek-char peek-type stream eof-error-p eof-value
91                                recursive-p)
92         ;; by elimination, must be Gray streams FUNDAMENTAL-STREAM
93         (generalized-peeking-mechanism
94          peek-type :eof char
95          (if (null peek-type)
96              (stream-peek-char stream)
97              (stream-read-char stream))
98          (if (null peek-type)
99              ()
100              (stream-unread-char stream char))
101          ()
102          (eof-or-lose stream eof-error-p eof-value)))))
103
104 (defun echo-misc (stream operation &optional arg1 arg2)
105   (let* ((in (two-way-stream-input-stream stream))
106          (out (two-way-stream-output-stream stream)))
107     (case operation
108       (:listen
109        (or (not (null (echo-stream-unread-stuff stream)))
110            (if (ansi-stream-p in)
111                (or (/= (the fixnum (ansi-stream-in-index in))
112                        +ansi-stream-in-buffer-length+)
113                    (funcall (ansi-stream-misc in) in :listen))
114                (stream-misc-dispatch in :listen))))
115       (:unread (push arg1 (echo-stream-unread-stuff stream)))
116       (:element-type
117        (let ((in-type (stream-element-type in))
118              (out-type (stream-element-type out)))
119          (if (equal in-type out-type)
120              in-type `(and ,in-type ,out-type))))
121       (:close
122        (set-closed-flame stream))
123       (:peek-char
124        ;; For the special case of peeking into an echo-stream
125        ;; arg1 is PEEK-TYPE, arg2 is (EOF-ERROR-P EOF-VALUE)
126        ;; returns peeked-char, eof-value, or errors end-of-file
127        ;;
128        ;; Note: This code could be moved into PEEK-CHAR if desired.
129        ;; I am unsure whether this belongs with echo-streams because it is
130        ;; echo-stream specific, or PEEK-CHAR because it is peeking code.
131        ;; -- mrd 2002-11-18
132        ;;
133        ;; UNREAD-CHAR-P indicates whether the current character was one
134        ;; that was previously unread.  In that case, we need to ensure that
135        ;; the semantics for UNREAD-CHAR are held; the character should
136        ;; not be echoed again.
137        (let ((unread-char-p nil))
138          (flet ((outfn (c)
139                   (unless unread-char-p
140                     (if (ansi-stream-p out)
141                         (funcall (ansi-stream-out out) out c)
142                         ;; gray-stream
143                         (stream-write-char out c))))
144                 (infn ()
145                   ;; Obtain input from unread buffer or input stream,
146                   ;; and set the flag appropriately.
147                   (cond ((not (null (echo-stream-unread-stuff stream)))
148                          (setf unread-char-p t)
149                          (pop (echo-stream-unread-stuff stream)))
150                         (t
151                          (setf unread-char-p nil)
152                          (read-char in (first arg2) (second arg2))))))
153            (generalized-peeking-mechanism
154             arg1 (second arg2) char
155             (infn)
156             (unread-char char in)
157             (outfn char)))))
158       (t
159        (or (if (ansi-stream-p in)
160                (funcall (ansi-stream-misc in) in operation arg1 arg2)
161                (stream-misc-dispatch in operation arg1 arg2))
162            (if (ansi-stream-p out)
163                (funcall (ansi-stream-misc out) out operation arg1 arg2)
164                (stream-misc-dispatch out operation arg1 arg2)))))))
165