3 ;;; Additional streams.
5 ;;; (c) 2009 Straylight/Edgeware
8 ;;;----- Licensing notice ---------------------------------------------------
10 ;;; This file is part of the Sensible Object Design, an object system for C.
12 ;;; SOD is free software; you can redistribute it and/or modify
13 ;;; it under the terms of the GNU General Public License as published by
14 ;;; the Free Software Foundation; either version 2 of the License, or
15 ;;; (at your option) any later version.
17 ;;; SOD is distributed in the hope that it will be useful,
18 ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
19 ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
20 ;;; GNU General Public License for more details.
22 ;;; You should have received a copy of the GNU General Public License
23 ;;; along with SOD; if not, write to the Free Software Foundation,
24 ;;; Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.
26 (cl:in-package #:sod-parser)
28 ;;;--------------------------------------------------------------------------
29 ;;; Compatibility hacking.
31 ;; ECL is different and strange. In early versions (0.9j and thereabouts)
32 ;; the Gray streams functions are in the SI package; CLOSE and STREAM-
33 ;; ELEMENT-TYPE are not generic, and call the generic functions SI:STREAM-
34 ;; CLOSE and SI:STREAM-ELT-TYPE if they find that they can't handle their
35 ;; argument. The STREAM-CLOSE generic function doesn't have a method for the
36 ;; built-in streams. In later versions (9.6.1 and thereabouts) the Gray
37 ;; streams functions are in the GRAY package; CLOSE and STREAM-ELEMENT-TYPE
38 ;; are still not generic, but now they call correspondingly-named generic
39 ;; functions in GRAY, and the generic versions do cover the built-in streams.
41 ;; The right thing to, then, seems to be as follows.
43 ;; * ECL is the weird system, so we'll hack it to be less weird. Hacking
44 ;; non-weird platforms seems wrong-headed.
46 ;; * Since SI:STREAM-CLOSE is missing a method which works on standard
47 ;; streams, we should add one if we're running that version of ECL.
49 ;; * Then we can shadow CLOSE and drop SI:STREAM-CLOSE or GRAY:CLOSE over
50 ;; the top. In the latter case, we can just do a SHADOWING-IMPORT; in
51 ;; the latter, we'll need to mess with FDEFINITION.
53 ;; * We'll do something similar for STREAM-ELEMENT-TYPE.
55 ;; Note that the following are all separate top-level forms so that later
56 ;; ones will be read with different symbols than earlier ones. This also
57 ;; means that we can use the *FEATURES* mechanism and avoid lots of the
58 ;; tedious messing about with FIND-SYMBOL.
61 (eval-when (:compile-toplevel :load-toplevel :execute)
62 (if (find-package '#:gray)
63 (push :sod-ecl-broken-gray-streams *features*)))
65 #+(and ecl (not sod-ecl-broken-gray-streams))
66 (eval-when (:compile-toplevel :load-toplevel :execute)
67 (shadowing-import '(gray:close gray:stream-element-type)))
69 #+(and ecl sod-ecl-broken-gray-streams)
70 (eval-when (:compile-toplevel :load-toplevel :execute)
71 (shadow '(close stream-element-type)))
72 #+(and ecl sod-ecl-broken-gray-streams)
73 (eval-when (:compile-toplevel :load-toplevel :execute)
74 (setf (fdefinition 'close) #'si:stream-close
75 (fdefinition 'stream-element-type #'si:stream-elt-type)))
77 ;;;--------------------------------------------------------------------------
80 ;; Base classes for proxy streams.
82 (defclass proxy-stream (fundamental-stream)
83 ((ustream :initarg :stream :type stream
84 :reader position-aware-stream-underlying-stream))
86 "Base class for proxy streams.
88 A proxy stream is one that works by passing most of its work to an
89 underlying stream. We provide some basic functionality for the later
92 (defmethod close ((stream proxy-stream) &key abort)
93 (with-slots (ustream) stream
94 (close ustream :abort abort)))
96 (defmethod stream-element-type ((stream proxy-stream))
97 (with-slots (ustream) stream
98 (stream-element-type ustream)))
100 (defmethod stream-file-position
101 ((stream proxy-stream) &optional (position nil posp))
102 (with-slots (ustream) stream
104 (file-position ustream position)
105 (file-position ustream))))
107 (defmethod stream-pathname ((stream proxy-stream))
108 (with-slots (ustream) stream
109 (stream-pathname ustream)))
111 ;; Base class for input streams.
113 (defclass proxy-input-stream (proxy-stream fundamental-input-stream)
116 "Base class for proxy input streams."))
118 (defmethod stream-clear-input ((stream proxy-input-stream))
119 (with-slots (ustream) stream
120 (clear-input ustream)))
122 (defmethod stream-read-sequence
123 ((stream proxy-input-stream) seq
124 #+clisp &key #-clisp &optional (start 0) end)
125 (with-slots (ustream) stream
126 (read-sequence seq ustream :start start :end end)))
128 ;; Base class for output streams.
130 (defclass proxy-output-stream (proxy-stream fundamental-output-stream)
133 "Base class for proxy output streams."))
135 (defmethod stream-clear-output ((stream proxy-output-stream))
136 (with-slots (ustream) stream
137 (clear-output ustream)))
139 (defmethod stream-finish-output ((stream proxy-output-stream))
140 (with-slots (ustream) stream
141 (finish-output ustream)))
143 (defmethod stream-force-output ((stream proxy-output-stream))
144 (with-slots (ustream) stream
145 (force-output ustream)))
147 (defmethod stream-write-sequence
148 ((stream proxy-output-stream) seq
149 #+clisp &key #-clisp &optional (start 0) end)
150 (with-slots (ustream) stream
151 (write-sequence seq ustream :start start :end end)))
153 ;; Character input streams.
155 (defclass proxy-character-input-stream
156 (proxy-input-stream fundamental-character-input-stream)
159 "A character-input-stream which is a proxy for an existing stream.
161 This doesn't actually change the behaviour of the underlying stream very
162 much, but it's a useful base to work on when writing more interesting
165 (defmethod stream-read-char ((stream proxy-character-input-stream))
166 (with-slots (ustream) stream
167 (read-char ustream nil :eof nil)))
169 (defmethod stream-read-line ((stream proxy-character-input-stream))
170 (with-slots (ustream) stream
171 (read-line ustream nil "" nil)))
173 (defmethod stream-unread-char ((stream proxy-character-input-stream) char)
174 (with-slots (ustream) stream
175 (unread-char char ustream)))
177 ;; Character output streams.
179 (defclass proxy-character-output-stream
180 (proxy-stream fundamental-character-output-stream)
183 "A character-output-stream which is a proxy for an existing stream.
185 This doesn't actually change the behaviour of the underlying stream very
186 much, but it's a useful base to work on when writing more interesting
189 (defmethod stream-line-column ((stream proxy-character-output-stream))
192 (defmethod stream-line-length ((stream proxy-character-output-stream))
195 (defmethod stream-terpri ((stream proxy-character-output-stream))
196 (with-slots (ustream) stream
199 (defmethod stream-write-char ((stream proxy-character-output-stream) char)
200 (with-slots (ustream) stream
201 (write-char char ustream)))
203 (defmethod stream-write-string
204 ((stream proxy-character-output-stream) string &optional (start 0) end)
205 (with-slots (ustream) stream
206 (write-string string ustream :start start :end end)))
208 ;;;--------------------------------------------------------------------------
209 ;;; The position-aware stream.
213 (export '(position-aware-stream
214 position-aware-stream-line position-aware-stream-column))
215 (defclass position-aware-stream (proxy-stream)
216 ((file :initarg :file :initform nil
217 :type (or pathname null) :accessor position-aware-stream-file)
218 (line :initarg :line :initform 1
219 :type fixnum :accessor position-aware-stream-line)
220 (column :initarg :column :initform 0
221 :type fixnum :accessor position-aware-stream-column))
223 "Character stream which keeps track of the line and column position.
225 A position-aware-stream wraps an existing character stream and tracks the
226 line and column position of the current stream position. A newline
227 character increases the line number by one and resets the column number to
228 zero; most characters advance the column number by one, but tab advances
229 to the next multiple of eight. (This is consistent with Emacs, at least.)
230 The position can be read using `stream-line-and-column'.
232 This is a base class; you probably want `position-aware-input-stream' or
233 `position-aware-output-stream'."))
235 (defgeneric stream-line-and-column (stream)
237 "Returns the current stream position of STREAM as line/column numbers.
239 Returns two values: the line and column numbers of STREAM's input
241 (:method ((stream stream))
243 (:method ((stream position-aware-stream))
244 (with-slots (line column) stream
245 (values line column))))
247 (defmethod stream-pathname ((stream position-aware-stream))
248 "Return the pathname corresponding to a `position-aware-stream'.
250 A `position-aware-stream' can be given an explicit pathname, which is
251 returned in preference to the pathname of the underlying stream. This is
252 useful in two circumstances. Firstly, the pathname associated with a file
253 stream will have been subjected to `truename', and may be less pleasant to
254 present back to a user. Secondly, a name can be attached to a stream
255 which doesn't actually have a file backing it."
257 (with-slots (file) stream
258 (or file (call-next-method))))
260 (defmethod file-location ((stream position-aware-stream))
261 (multiple-value-bind (line column) (stream-line-and-column stream)
262 (make-file-location (stream-pathname stream) line column)))
266 (defmacro with-position ((stream) &body body)
267 "Convenience macro for tracking the read position.
269 Within the BODY, the macro (update CHAR) is defined to update the STREAM's
270 position according to the character CHAR.
272 The position is actually cached in local variables, but will be written
273 back to the stream even in the case of non-local control transfer from the
274 BODY. What won't work well is dynamically nesting `with-position' forms."
276 (with-gensyms (line column char)
278 `(let* ((,line (position-aware-stream-line ,stream))
279 (,column (position-aware-stream-column ,stream)))
280 (macrolet ((update (,char)
281 ;; This gets a little hairy. Hold tight.
282 `(multiple-value-setq (,',line ,',column)
283 (update-position ,,char ,',line ,',column))))
286 (setf (position-aware-stream-line ,stream) ,line
287 (position-aware-stream-column ,stream) ,column)))))))
291 (export 'position-aware-input-stream)
292 (defclass position-aware-input-stream
293 (position-aware-stream proxy-character-input-stream)
296 "A character input stream which tracks the input position.
298 This is particularly useful for parsers and suchlike, which want to
299 produce accurate error-location information."))
301 (defmethod stream-unread-char ((stream position-aware-input-stream) char)
303 ;; I could have written this as a :before or :after method, but I think
304 ;; this is the right answer. All of the other methods have to be primary
305 ;; (or around) methods, so at least it's consistent.
306 (with-slots (line column) stream
307 (setf (values line column) (backtrack-position char line column)))
310 (defmethod stream-read-sequence
311 ((stream position-aware-input-stream) seq
312 #+clisp &key #-clisp &optional (start 0) end)
313 (declare (ignore end))
314 (let ((pos (call-next-method)))
315 (with-position (stream)
316 (dosequence (ch seq :start start :end pos)
320 (defmethod stream-read-char ((stream position-aware-input-stream))
321 (let ((char (call-next-method)))
322 (with-position (stream)
326 (defmethod stream-read-line ((stream position-aware-input-stream))
327 (multiple-value-bind (line eofp) (call-next-method)
329 (with-position (stream)
330 (dotimes (i (length line))
331 (update (char line i))))
332 (with-slots (line column) stream
339 (export 'position-aware-output-stream)
340 (defclass position-aware-output-stream
341 (position-aware-stream proxy-character-output-stream)
344 "A character output stream which tracks the output position.
346 This is particularly useful when generating C code: the position can be
347 used to generate `#line' directives referring to the generated code after
348 insertion of some user code."))
350 (defmethod stream-write-sequence
351 ((stream position-aware-output-stream) seq
352 #+clisp &key #-clisp &optional (start 0) end)
353 (with-position (stream)
354 (dosequence (ch seq :start start :end end)
358 (defmethod stream-line-column ((stream position-aware-output-stream))
359 (with-slots (column) stream
362 (defmethod stream-start-line-p ((stream position-aware-output-stream))
363 (with-slots (column) stream
366 (defmethod stream-terpri ((stream position-aware-output-stream))
367 (with-slots (line column) stream
372 (defmethod stream-write-char ((stream position-aware-output-stream) char)
373 (with-position (stream)
377 (defmethod stream-write-string
378 ((stream position-aware-output-stream) string &optional (start 0) end)
379 (with-position (stream)
380 (do ((i start (1+ i))
381 (end (or end (length string))))
383 (update (char string i))))
386 ;;;----- That's all, folks --------------------------------------------------