| 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 :type (or pathname null) |
| 61 | :accessor file-location-pathname) |
| 62 | (line :initarg :line :type (or fixnum null) :accessor file-location-line) |
| 63 | (column :initarg :column :type (or fixnum null) |
| 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) |
| 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)) |
| 95 | |
| 96 | ;;;-------------------------------------------------------------------------- |
| 97 | ;;; Proxy streams. |
| 98 | |
| 99 | ;; Base classes for proxy streams. |
| 100 | |
| 101 | (defclass proxy-stream (fundamental-stream) |
| 102 | ((ustream :initarg :stream :type stream |
| 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) |
| 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)) |
| 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 -------------------------------------------------- |