Commit | Line | Data |
---|---|---|
abdf50aa MW |
1 | ;;; -*-lisp-*- |
2 | ;;; | |
dea4d055 | 3 | ;;; Additional streams. |
abdf50aa MW |
4 | ;;; |
5 | ;;; (c) 2009 Straylight/Edgeware | |
6 | ;;; | |
7 | ||
8 | ;;;----- Licensing notice --------------------------------------------------- | |
9 | ;;; | |
e0808c47 | 10 | ;;; This file is part of the Sensible Object Design, an object system for C. |
abdf50aa MW |
11 | ;;; |
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. | |
16 | ;;; | |
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. | |
21 | ;;; | |
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. | |
25 | ||
dea4d055 | 26 | (cl:in-package #:sod-parser) |
abdf50aa MW |
27 | |
28 | ;;;-------------------------------------------------------------------------- | |
29 | ;;; Compatibility hacking. | |
30 | ||
dea4d055 MW |
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. | |
40 | ;; | |
41 | ;; The right thing to, then, seems to be as follows. | |
42 | ;; | |
43 | ;; * ECL is the weird system, so we'll hack it to be less weird. Hacking | |
44 | ;; non-weird platforms seems wrong-headed. | |
45 | ;; | |
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. | |
48 | ;; | |
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. | |
52 | ;; | |
53 | ;; * We'll do something similar for STREAM-ELEMENT-TYPE. | |
54 | ;; | |
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. | |
59 | ||
60 | #+ecl | |
abdf50aa | 61 | (eval-when (:compile-toplevel :load-toplevel :execute) |
dea4d055 MW |
62 | (if (find-package '#:gray) |
63 | (push :sod-ecl-broken-gray-streams *features*))) | |
abdf50aa | 64 | |
dea4d055 MW |
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))) | |
1f1d88f5 | 68 | |
dea4d055 MW |
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))) | |
abdf50aa MW |
76 | |
77 | ;;;-------------------------------------------------------------------------- | |
78 | ;;; Proxy streams. | |
79 | ||
80 | ;; Base classes for proxy streams. | |
81 | ||
82 | (defclass proxy-stream (fundamental-stream) | |
77027cca | 83 | ((ustream :initarg :stream :type stream |
abdf50aa MW |
84 | :reader position-aware-stream-underlying-stream)) |
85 | (:documentation | |
86 | "Base class for proxy streams. | |
87 | ||
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 | |
90 | classes.")) | |
91 | ||
dea4d055 | 92 | (defmethod close ((stream proxy-stream) &key abort) |
abdf50aa MW |
93 | (with-slots (ustream) stream |
94 | (close ustream :abort abort))) | |
95 | ||
dea4d055 | 96 | (defmethod stream-element-type ((stream proxy-stream)) |
abdf50aa | 97 | (with-slots (ustream) stream |
dea4d055 | 98 | (stream-element-type ustream))) |
abdf50aa MW |
99 | |
100 | (defmethod stream-file-position | |
101 | ((stream proxy-stream) &optional (position nil posp)) | |
102 | (with-slots (ustream) stream | |
103 | (if posp | |
104 | (file-position ustream position) | |
105 | (file-position ustream)))) | |
106 | ||
107 | (defmethod stream-pathname ((stream proxy-stream)) | |
108 | (with-slots (ustream) stream | |
109 | (stream-pathname ustream))) | |
110 | ||
111 | ;; Base class for input streams. | |
112 | ||
113 | (defclass proxy-input-stream (proxy-stream fundamental-input-stream) | |
114 | () | |
115 | (:documentation | |
116 | "Base class for proxy input streams.")) | |
117 | ||
118 | (defmethod stream-clear-input ((stream proxy-input-stream)) | |
119 | (with-slots (ustream) stream | |
120 | (clear-input ustream))) | |
121 | ||
122 | (defmethod stream-read-sequence | |
1d8cc67a MW |
123 | ((stream proxy-input-stream) seq |
124 | #+clisp &key #-clisp &optional (start 0) end) | |
abdf50aa MW |
125 | (with-slots (ustream) stream |
126 | (read-sequence seq ustream :start start :end end))) | |
127 | ||
128 | ;; Base class for output streams. | |
129 | ||
130 | (defclass proxy-output-stream (proxy-stream fundamental-output-stream) | |
131 | () | |
132 | (:documentation | |
133 | "Base class for proxy output streams.")) | |
134 | ||
135 | (defmethod stream-clear-output ((stream proxy-output-stream)) | |
136 | (with-slots (ustream) stream | |
137 | (clear-output ustream))) | |
138 | ||
139 | (defmethod stream-finish-output ((stream proxy-output-stream)) | |
140 | (with-slots (ustream) stream | |
141 | (finish-output ustream))) | |
142 | ||
143 | (defmethod stream-force-output ((stream proxy-output-stream)) | |
144 | (with-slots (ustream) stream | |
145 | (force-output ustream))) | |
146 | ||
147 | (defmethod stream-write-sequence | |
1d8cc67a MW |
148 | ((stream proxy-output-stream) seq |
149 | #+clisp &key #-clisp &optional (start 0) end) | |
abdf50aa MW |
150 | (with-slots (ustream) stream |
151 | (write-sequence seq ustream :start start :end end))) | |
152 | ||
153 | ;; Character input streams. | |
154 | ||
155 | (defclass proxy-character-input-stream | |
156 | (proxy-input-stream fundamental-character-input-stream) | |
157 | () | |
158 | (:documentation | |
159 | "A character-input-stream which is a proxy for an existing stream. | |
160 | ||
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 | |
163 | classes.")) | |
164 | ||
165 | (defmethod stream-read-char ((stream proxy-character-input-stream)) | |
166 | (with-slots (ustream) stream | |
167 | (read-char ustream nil :eof nil))) | |
168 | ||
169 | (defmethod stream-read-line ((stream proxy-character-input-stream)) | |
170 | (with-slots (ustream) stream | |
171 | (read-line ustream nil "" nil))) | |
172 | ||
173 | (defmethod stream-unread-char ((stream proxy-character-input-stream) char) | |
174 | (with-slots (ustream) stream | |
175 | (unread-char char ustream))) | |
176 | ||
177 | ;; Character output streams. | |
178 | ||
179 | (defclass proxy-character-output-stream | |
180 | (proxy-stream fundamental-character-output-stream) | |
181 | () | |
182 | (:documentation | |
183 | "A character-output-stream which is a proxy for an existing stream. | |
184 | ||
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 | |
187 | classes.")) | |
188 | ||
189 | (defmethod stream-line-column ((stream proxy-character-output-stream)) | |
190 | nil) | |
191 | ||
192 | (defmethod stream-line-length ((stream proxy-character-output-stream)) | |
193 | nil) | |
194 | ||
195 | (defmethod stream-terpri ((stream proxy-character-output-stream)) | |
196 | (with-slots (ustream) stream | |
197 | (terpri ustream))) | |
198 | ||
199 | (defmethod stream-write-char ((stream proxy-character-output-stream) char) | |
200 | (with-slots (ustream) stream | |
201 | (write-char char ustream))) | |
202 | ||
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))) | |
207 | ||
208 | ;;;-------------------------------------------------------------------------- | |
209 | ;;; The position-aware stream. | |
210 | ||
211 | ;; Base class. | |
212 | ||
dea4d055 MW |
213 | (export '(position-aware-stream |
214 | position-aware-stream-line position-aware-stream-column)) | |
abdf50aa | 215 | (defclass position-aware-stream (proxy-stream) |
77027cca | 216 | ((file :initarg :file :initform nil |
1645e433 | 217 | :type (or pathname null) :accessor position-aware-stream-file) |
77027cca MW |
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)) | |
abdf50aa MW |
222 | (:documentation |
223 | "Character stream which keeps track of the line and column position. | |
224 | ||
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.) | |
3109662a | 230 | The position can be read using `stream-line-and-column'. |
abdf50aa | 231 | |
3109662a MW |
232 | This is a base class; you probably want `position-aware-input-stream' or |
233 | `position-aware-output-stream'.")) | |
abdf50aa MW |
234 | |
235 | (defgeneric stream-line-and-column (stream) | |
236 | (:documentation | |
237 | "Returns the current stream position of STREAM as line/column numbers. | |
238 | ||
239 | Returns two values: the line and column numbers of STREAM's input | |
240 | position.") | |
241 | (:method ((stream stream)) | |
242 | (values nil nil)) | |
243 | (:method ((stream position-aware-stream)) | |
244 | (with-slots (line column) stream | |
245 | (values line column)))) | |
246 | ||
247 | (defmethod stream-pathname ((stream position-aware-stream)) | |
3109662a | 248 | "Return the pathname corresponding to a `position-aware-stream'. |
abdf50aa | 249 | |
3109662a | 250 | A `position-aware-stream' can be given an explicit pathname, which is |
abdf50aa MW |
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 | |
3109662a | 253 | stream will have been subjected to `truename', and may be less pleasant to |
abdf50aa MW |
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." | |
256 | ||
257 | (with-slots (file) stream | |
258 | (or file (call-next-method)))) | |
259 | ||
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))) | |
263 | ||
264 | ;; Utilities. | |
265 | ||
abdf50aa MW |
266 | (defmacro with-position ((stream) &body body) |
267 | "Convenience macro for tracking the read position. | |
268 | ||
269 | Within the BODY, the macro (update CHAR) is defined to update the STREAM's | |
270 | position according to the character CHAR. | |
271 | ||
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 | |
3109662a | 274 | BODY. What won't work well is dynamically nesting `with-position' forms." |
abdf50aa | 275 | |
dea4d055 MW |
276 | (with-gensyms (line column char) |
277 | (once-only (stream) | |
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)))) | |
284 | (unwind-protect | |
285 | (progn ,@body) | |
286 | (setf (position-aware-stream-line ,stream) ,line | |
287 | (position-aware-stream-column ,stream) ,column))))))) | |
abdf50aa MW |
288 | |
289 | ;; Input stream. | |
290 | ||
dea4d055 | 291 | (export 'position-aware-input-stream) |
abdf50aa MW |
292 | (defclass position-aware-input-stream |
293 | (position-aware-stream proxy-character-input-stream) | |
294 | () | |
295 | (:documentation | |
296 | "A character input stream which tracks the input position. | |
297 | ||
298 | This is particularly useful for parsers and suchlike, which want to | |
299 | produce accurate error-location information.")) | |
300 | ||
301 | (defmethod stream-unread-char ((stream position-aware-input-stream) char) | |
302 | ||
dea4d055 MW |
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. | |
abdf50aa | 306 | (with-slots (line column) stream |
dea4d055 | 307 | (setf (values line column) (backtrack-position char line column))) |
abdf50aa MW |
308 | (call-next-method)) |
309 | ||
310 | (defmethod stream-read-sequence | |
1d8cc67a MW |
311 | ((stream position-aware-input-stream) seq |
312 | #+clisp &key #-clisp &optional (start 0) end) | |
abdf50aa MW |
313 | (declare (ignore end)) |
314 | (let ((pos (call-next-method))) | |
315 | (with-position (stream) | |
316 | (dosequence (ch seq :start start :end pos) | |
317 | (update ch))) | |
318 | pos)) | |
319 | ||
320 | (defmethod stream-read-char ((stream position-aware-input-stream)) | |
321 | (let ((char (call-next-method))) | |
322 | (with-position (stream) | |
323 | (update char)) | |
324 | char)) | |
325 | ||
326 | (defmethod stream-read-line ((stream position-aware-input-stream)) | |
327 | (multiple-value-bind (line eofp) (call-next-method) | |
328 | (if eofp | |
329 | (with-position (stream) | |
330 | (dotimes (i (length line)) | |
331 | (update (char line i)))) | |
332 | (with-slots (line column) stream | |
333 | (incf line) | |
334 | (setf column 0))) | |
335 | (values line eofp))) | |
336 | ||
337 | ;; Output stream. | |
338 | ||
dea4d055 | 339 | (export 'position-aware-output-stream) |
abdf50aa MW |
340 | (defclass position-aware-output-stream |
341 | (position-aware-stream proxy-character-output-stream) | |
342 | () | |
343 | (:documentation | |
344 | "A character output stream which tracks the output position. | |
345 | ||
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.")) | |
349 | ||
350 | (defmethod stream-write-sequence | |
1d8cc67a MW |
351 | ((stream position-aware-output-stream) seq |
352 | #+clisp &key #-clisp &optional (start 0) end) | |
abdf50aa MW |
353 | (with-position (stream) |
354 | (dosequence (ch seq :start start :end end) | |
355 | (update ch)) | |
356 | (call-next-method))) | |
357 | ||
358 | (defmethod stream-line-column ((stream position-aware-output-stream)) | |
359 | (with-slots (column) stream | |
360 | column)) | |
361 | ||
362 | (defmethod stream-start-line-p ((stream position-aware-output-stream)) | |
363 | (with-slots (column) stream | |
364 | (zerop column))) | |
365 | ||
366 | (defmethod stream-terpri ((stream position-aware-output-stream)) | |
367 | (with-slots (line column) stream | |
368 | (incf line) | |
369 | (setf column 0)) | |
370 | (call-next-method)) | |
371 | ||
372 | (defmethod stream-write-char ((stream position-aware-output-stream) char) | |
373 | (with-position (stream) | |
374 | (update char)) | |
375 | (call-next-method)) | |
376 | ||
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)))) | |
382 | ((>= i end)) | |
383 | (update (char string i)))) | |
384 | (call-next-method)) | |
385 | ||
386 | ;;;----- That's all, folks -------------------------------------------------- |