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