Commit | Line | Data |
---|---|---|
abdf50aa MW |
1 | ;;; -*-lisp-*- |
2 | ;;; | |
3 | ;;; Position-aware stream type | |
4 | ;;; | |
5 | ;;; (c) 2009 Straylight/Edgeware | |
6 | ;;; | |
7 | ||
8 | ;;;----- Licensing notice --------------------------------------------------- | |
9 | ;;; | |
10 | ;;; This file is part of the Simple Object Definition system. | |
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 | ||
26 | (cl:in-package #:sod) | |
27 | ||
28 | ;;;-------------------------------------------------------------------------- | |
29 | ;;; Compatibility hacking. | |
30 | ||
31 | ;; ECL doesn't clobber the standard CLOSE and STREAM-ELEMENT-TYPE functions | |
32 | ;; with the Gray generic versions. | |
33 | #-ecl | |
34 | (eval-when (:compile-toplevel :load-toplevel :execute) | |
35 | (setf (fdefinition 'stream-close) #'cl:close | |
36 | (fdefinition 'stream-elt-type) #'cl:stream-element-type)) | |
37 | ||
38 | ;;;-------------------------------------------------------------------------- | |
39 | ;;; File names. | |
40 | ||
41 | (defgeneric stream-pathname (stream) | |
42 | (:documentation | |
43 | "Returns the pathname of the file that STREAM is open on. | |
44 | ||
45 | If STREAM is open on a file, then return the pathname of that file. | |
46 | Otherwise return NIL.") | |
47 | ||
48 | ;; Provide some default methods. Most streams don't have a pathname. | |
49 | ;; File-based streams provide a pathname, but it's usually been TRUENAMEd, | |
50 | ;; which isn't ideal. We'll hack around this later. | |
51 | (:method ((stream stream)) | |
52 | nil) | |
53 | (:method ((stream file-stream)) | |
54 | (pathname stream))) | |
55 | ||
56 | ;;;-------------------------------------------------------------------------- | |
57 | ;;; Locations. | |
58 | ||
59 | (defclass file-location () | |
77027cca | 60 | ((pathname :initarg :pathname :type (or pathname null) |
abdf50aa | 61 | :accessor file-location-pathname) |
77027cca MW |
62 | (line :initarg :line :type (or fixnum null) :accessor file-location-line) |
63 | (column :initarg :column :type (or fixnum null) | |
abdf50aa MW |
64 | :accessor file-location-column)) |
65 | (:documentation | |
66 | "A simple structure containing file location information. | |
67 | ||
68 | Construct using MAKE-FILE-LOCATION; the main useful function is | |
69 | ERROR-FILE-LOCATION.")) | |
70 | ||
71 | (defun make-file-location (pathname line column) | |
72 | "Constructor for FILE-LOCATION objects. | |
73 | ||
74 | Returns a FILE-LOCATION object with the given contents." | |
75 | (make-instance 'file-location | |
76 | :pathname (and pathname (pathname pathname)) | |
77 | :line line :column column)) | |
78 | ||
79 | (defgeneric file-location (thing) | |
80 | (:documentation | |
81 | "Convert THING into a FILE-LOCATION, if possible.") | |
82 | (:method ((thing null)) (make-file-location nil nil nil)) | |
83 | (:method ((thing file-location)) thing) | |
84 | (:method ((stream stream)) | |
85 | (make-file-location (stream-pathname stream) nil nil))) | |
86 | ||
87 | (defmethod print-object ((object file-location) stream) | |
1f1d88f5 MW |
88 | (maybe-print-unreadable-object (object stream :type t) |
89 | (with-slots (pathname line column) object | |
90 | (format stream "~:[<unnamed>~;~:*~A~]~@[:~D~]~@[:~D~]" | |
91 | pathname line column)))) | |
92 | ||
93 | (defmethod make-load-form ((object file-location) &optional environment) | |
94 | (make-load-form-saving-slots object :environment environment)) | |
abdf50aa MW |
95 | |
96 | ;;;-------------------------------------------------------------------------- | |
97 | ;;; Proxy streams. | |
98 | ||
99 | ;; Base classes for proxy streams. | |
100 | ||
101 | (defclass proxy-stream (fundamental-stream) | |
77027cca | 102 | ((ustream :initarg :stream :type stream |
abdf50aa MW |
103 | :reader position-aware-stream-underlying-stream)) |
104 | (:documentation | |
105 | "Base class for proxy streams. | |
106 | ||
107 | A proxy stream is one that works by passing most of its work to an | |
108 | underlying stream. We provide some basic functionality for the later | |
109 | classes.")) | |
110 | ||
111 | (defmethod stream-close ((stream proxy-stream) &key abort) | |
112 | (with-slots (ustream) stream | |
113 | (close ustream :abort abort))) | |
114 | ||
115 | (defmethod stream-elt-type ((stream proxy-stream)) | |
116 | (with-slots (ustream) stream | |
117 | (stream-elt-type ustream))) | |
118 | ||
119 | (defmethod stream-file-position | |
120 | ((stream proxy-stream) &optional (position nil posp)) | |
121 | (with-slots (ustream) stream | |
122 | (if posp | |
123 | (file-position ustream position) | |
124 | (file-position ustream)))) | |
125 | ||
126 | (defmethod stream-pathname ((stream proxy-stream)) | |
127 | (with-slots (ustream) stream | |
128 | (stream-pathname ustream))) | |
129 | ||
130 | ;; Base class for input streams. | |
131 | ||
132 | (defclass proxy-input-stream (proxy-stream fundamental-input-stream) | |
133 | () | |
134 | (:documentation | |
135 | "Base class for proxy input streams.")) | |
136 | ||
137 | (defmethod stream-clear-input ((stream proxy-input-stream)) | |
138 | (with-slots (ustream) stream | |
139 | (clear-input ustream))) | |
140 | ||
141 | (defmethod stream-read-sequence | |
142 | ((stream proxy-input-stream) seq &optional (start 0) end) | |
143 | (with-slots (ustream) stream | |
144 | (read-sequence seq ustream :start start :end end))) | |
145 | ||
146 | ;; Base class for output streams. | |
147 | ||
148 | (defclass proxy-output-stream (proxy-stream fundamental-output-stream) | |
149 | () | |
150 | (:documentation | |
151 | "Base class for proxy output streams.")) | |
152 | ||
153 | (defmethod stream-clear-output ((stream proxy-output-stream)) | |
154 | (with-slots (ustream) stream | |
155 | (clear-output ustream))) | |
156 | ||
157 | (defmethod stream-finish-output ((stream proxy-output-stream)) | |
158 | (with-slots (ustream) stream | |
159 | (finish-output ustream))) | |
160 | ||
161 | (defmethod stream-force-output ((stream proxy-output-stream)) | |
162 | (with-slots (ustream) stream | |
163 | (force-output ustream))) | |
164 | ||
165 | (defmethod stream-write-sequence | |
166 | ((stream proxy-output-stream) seq &optional (start 0) end) | |
167 | (with-slots (ustream) stream | |
168 | (write-sequence seq ustream :start start :end end))) | |
169 | ||
170 | ;; Character input streams. | |
171 | ||
172 | (defclass proxy-character-input-stream | |
173 | (proxy-input-stream fundamental-character-input-stream) | |
174 | () | |
175 | (:documentation | |
176 | "A character-input-stream which is a proxy for an existing stream. | |
177 | ||
178 | This doesn't actually change the behaviour of the underlying stream very | |
179 | much, but it's a useful base to work on when writing more interesting | |
180 | classes.")) | |
181 | ||
182 | (defmethod stream-read-char ((stream proxy-character-input-stream)) | |
183 | (with-slots (ustream) stream | |
184 | (read-char ustream nil :eof nil))) | |
185 | ||
186 | (defmethod stream-read-line ((stream proxy-character-input-stream)) | |
187 | (with-slots (ustream) stream | |
188 | (read-line ustream nil "" nil))) | |
189 | ||
190 | (defmethod stream-unread-char ((stream proxy-character-input-stream) char) | |
191 | (with-slots (ustream) stream | |
192 | (unread-char char ustream))) | |
193 | ||
194 | ;; Character output streams. | |
195 | ||
196 | (defclass proxy-character-output-stream | |
197 | (proxy-stream fundamental-character-output-stream) | |
198 | () | |
199 | (:documentation | |
200 | "A character-output-stream which is a proxy for an existing stream. | |
201 | ||
202 | This doesn't actually change the behaviour of the underlying stream very | |
203 | much, but it's a useful base to work on when writing more interesting | |
204 | classes.")) | |
205 | ||
206 | (defmethod stream-line-column ((stream proxy-character-output-stream)) | |
207 | nil) | |
208 | ||
209 | (defmethod stream-line-length ((stream proxy-character-output-stream)) | |
210 | nil) | |
211 | ||
212 | (defmethod stream-terpri ((stream proxy-character-output-stream)) | |
213 | (with-slots (ustream) stream | |
214 | (terpri ustream))) | |
215 | ||
216 | (defmethod stream-write-char ((stream proxy-character-output-stream) char) | |
217 | (with-slots (ustream) stream | |
218 | (write-char char ustream))) | |
219 | ||
220 | (defmethod stream-write-string | |
221 | ((stream proxy-character-output-stream) string &optional (start 0) end) | |
222 | (with-slots (ustream) stream | |
223 | (write-string string ustream :start start :end end))) | |
224 | ||
225 | ;;;-------------------------------------------------------------------------- | |
226 | ;;; The position-aware stream. | |
227 | ||
228 | ;; Base class. | |
229 | ||
230 | (defclass position-aware-stream (proxy-stream) | |
77027cca MW |
231 | ((file :initarg :file :initform nil |
232 | :type pathname :accessor position-aware-stream-file) | |
233 | (line :initarg :line :initform 1 | |
234 | :type fixnum :accessor position-aware-stream-line) | |
235 | (column :initarg :column :initform 0 | |
236 | :type fixnum :accessor position-aware-stream-column)) | |
abdf50aa MW |
237 | (:documentation |
238 | "Character stream which keeps track of the line and column position. | |
239 | ||
240 | A position-aware-stream wraps an existing character stream and tracks the | |
241 | line and column position of the current stream position. A newline | |
242 | character increases the line number by one and resets the column number to | |
243 | zero; most characters advance the column number by one, but tab advances | |
244 | to the next multiple of eight. (This is consistent with Emacs, at least.) | |
245 | The position can be read using STREAM-LINE-AND-COLUMN. | |
246 | ||
247 | This is a base class; you probably want POSITION-AWARE-INPUT-STREAM or | |
248 | POSITION-AWARE-OUTPUT-STREAM.")) | |
249 | ||
250 | (defgeneric stream-line-and-column (stream) | |
251 | (:documentation | |
252 | "Returns the current stream position of STREAM as line/column numbers. | |
253 | ||
254 | Returns two values: the line and column numbers of STREAM's input | |
255 | position.") | |
256 | (:method ((stream stream)) | |
257 | (values nil nil)) | |
258 | (:method ((stream position-aware-stream)) | |
259 | (with-slots (line column) stream | |
260 | (values line column)))) | |
261 | ||
262 | (defmethod stream-pathname ((stream position-aware-stream)) | |
263 | "Return the pathname corresponding to a POSITION-AWARE-STREAM. | |
264 | ||
265 | A POSITION-AWARE-STREAM can be given an explicit pathname, which is | |
266 | returned in preference to the pathname of the underlying stream. This is | |
267 | useful in two circumstances. Firstly, the pathname associated with a file | |
268 | stream will have been subjected to TRUENAME, and may be less pleasant to | |
269 | present back to a user. Secondly, a name can be attached to a stream | |
270 | which doesn't actually have a file backing it." | |
271 | ||
272 | (with-slots (file) stream | |
273 | (or file (call-next-method)))) | |
274 | ||
275 | (defmethod file-location ((stream position-aware-stream)) | |
276 | (multiple-value-bind (line column) (stream-line-and-column stream) | |
277 | (make-file-location (stream-pathname stream) line column))) | |
278 | ||
279 | ;; Utilities. | |
280 | ||
281 | (declaim (inline update-position)) | |
282 | (defun update-position (char line column) | |
283 | "Updates LINE and COLUMN according to the character CHAR. | |
284 | ||
285 | Returns the new LINE and COLUMN numbers resulting from having read CHAR." | |
286 | (case char | |
287 | ((#\newline #\vt #\page) | |
288 | (values (1+ line) 0)) | |
289 | ((#\tab) | |
290 | (values line (logandc2 (+ column 7) 7))) | |
291 | (t | |
292 | (values line (1+ column))))) | |
293 | ||
294 | (defmacro with-position ((stream) &body body) | |
295 | "Convenience macro for tracking the read position. | |
296 | ||
297 | Within the BODY, the macro (update CHAR) is defined to update the STREAM's | |
298 | position according to the character CHAR. | |
299 | ||
300 | The position is actually cached in local variables, but will be written | |
301 | back to the stream even in the case of non-local control transfer from the | |
302 | BODY. What won't work well is dynamically nesting WITH-POSITION forms." | |
303 | ||
304 | (let ((streamvar (gensym "STREAM")) | |
305 | (linevar (gensym "LINE")) | |
306 | (colvar (gensym "COLUMN")) | |
307 | (charvar (gensym "CHAR"))) | |
308 | `(let* ((,streamvar ,stream) | |
309 | (,linevar (position-aware-stream-line ,streamvar)) | |
310 | (,colvar (position-aware-stream-column ,streamvar))) | |
311 | (macrolet ((update (,charvar) | |
312 | ;; This gets a little hairy. Hold tight. | |
313 | `(multiple-value-setq (,',linevar ,',colvar) | |
314 | (update-position ,,charvar ,',linevar ,',colvar)))) | |
315 | (unwind-protect | |
316 | (progn ,@body) | |
317 | (setf (position-aware-stream-line ,streamvar) ,linevar | |
318 | (position-aware-stream-column ,streamvar) ,colvar)))))) | |
319 | ||
320 | ;; Input stream. | |
321 | ||
322 | (defclass position-aware-input-stream | |
323 | (position-aware-stream proxy-character-input-stream) | |
324 | () | |
325 | (:documentation | |
326 | "A character input stream which tracks the input position. | |
327 | ||
328 | This is particularly useful for parsers and suchlike, which want to | |
329 | produce accurate error-location information.")) | |
330 | ||
331 | (defmethod stream-unread-char ((stream position-aware-input-stream) char) | |
332 | ||
333 | ;; Tweak the position so that the next time the character is read, it will | |
334 | ;; end up here. This isn't perfect: if the character doesn't actually | |
335 | ;; match what was really read then it might not actually be possible: for | |
336 | ;; example, if we push back a newline while in the middle of a line, or a | |
337 | ;; tab while not at a tab stop. In that case, we'll just lose, but | |
338 | ;; hopefully not too badly. | |
339 | (with-slots (line column) stream | |
340 | (case char | |
341 | ||
342 | ;; In the absence of better ideas, I'll set the column number to zero. | |
343 | ;; This is almost certainly wrong, but with a little luck nobody will | |
344 | ;; ask and it'll be all right soon. | |
345 | ((#\newline #\vt #\page) | |
346 | (decf line) | |
347 | (setf column 0)) | |
348 | ||
349 | ;; Winding back a single space is sufficient. If the position is | |
350 | ;; currently on a tab stop then it'll advance back here next time. If | |
351 | ;; not, we're going to lose anyway. | |
352 | (#\tab | |
353 | (decf column)) | |
354 | ||
355 | ;; Anything else: just decrement the column and cross fingers. | |
356 | (t | |
357 | (decf column)))) | |
358 | ||
359 | ;; And actually do it. (I could have written this as a :before or :after | |
360 | ;; method, but I think this is the right answer. All of the other methods | |
361 | ;; have to be primary (or around) methods, so at least it's consistent.) | |
362 | (call-next-method)) | |
363 | ||
364 | (defmethod stream-read-sequence | |
365 | ((stream position-aware-input-stream) seq &optional (start 0) end) | |
366 | (declare (ignore end)) | |
367 | (let ((pos (call-next-method))) | |
368 | (with-position (stream) | |
369 | (dosequence (ch seq :start start :end pos) | |
370 | (update ch))) | |
371 | pos)) | |
372 | ||
373 | (defmethod stream-read-char ((stream position-aware-input-stream)) | |
374 | (let ((char (call-next-method))) | |
375 | (with-position (stream) | |
376 | (update char)) | |
377 | char)) | |
378 | ||
379 | (defmethod stream-read-line ((stream position-aware-input-stream)) | |
380 | (multiple-value-bind (line eofp) (call-next-method) | |
381 | (if eofp | |
382 | (with-position (stream) | |
383 | (dotimes (i (length line)) | |
384 | (update (char line i)))) | |
385 | (with-slots (line column) stream | |
386 | (incf line) | |
387 | (setf column 0))) | |
388 | (values line eofp))) | |
389 | ||
390 | ;; Output stream. | |
391 | ||
392 | (defclass position-aware-output-stream | |
393 | (position-aware-stream proxy-character-output-stream) | |
394 | () | |
395 | (:documentation | |
396 | "A character output stream which tracks the output position. | |
397 | ||
398 | This is particularly useful when generating C code: the position can be | |
399 | used to generate `#line' directives referring to the generated code after | |
400 | insertion of some user code.")) | |
401 | ||
402 | (defmethod stream-write-sequence | |
403 | ((stream position-aware-output-stream) seq &optional (start 0) end) | |
404 | (with-position (stream) | |
405 | (dosequence (ch seq :start start :end end) | |
406 | (update ch)) | |
407 | (call-next-method))) | |
408 | ||
409 | (defmethod stream-line-column ((stream position-aware-output-stream)) | |
410 | (with-slots (column) stream | |
411 | column)) | |
412 | ||
413 | (defmethod stream-start-line-p ((stream position-aware-output-stream)) | |
414 | (with-slots (column) stream | |
415 | (zerop column))) | |
416 | ||
417 | (defmethod stream-terpri ((stream position-aware-output-stream)) | |
418 | (with-slots (line column) stream | |
419 | (incf line) | |
420 | (setf column 0)) | |
421 | (call-next-method)) | |
422 | ||
423 | (defmethod stream-write-char ((stream position-aware-output-stream) char) | |
424 | (with-position (stream) | |
425 | (update char)) | |
426 | (call-next-method)) | |
427 | ||
428 | (defmethod stream-write-string | |
429 | ((stream position-aware-output-stream) string &optional (start 0) end) | |
430 | (with-position (stream) | |
431 | (do ((i start (1+ i)) | |
432 | (end (or end (length string)))) | |
433 | ((>= i end)) | |
434 | (update (char string i)))) | |
435 | (call-next-method)) | |
436 | ||
437 | ;;;----- That's all, folks -------------------------------------------------- |