| 1 | ;;; -*-lisp-*- |
| 2 | ;;; |
| 3 | ;;; Additional streams. |
| 4 | ;;; |
| 5 | ;;; (c) 2009 Straylight/Edgeware |
| 6 | ;;; |
| 7 | |
| 8 | ;;;----- Licensing notice --------------------------------------------------- |
| 9 | ;;; |
| 10 | ;;; This file is part of the Sensible Object Design, an object system for C. |
| 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-parser) |
| 27 | |
| 28 | ;;;-------------------------------------------------------------------------- |
| 29 | ;;; Compatibility hacking. |
| 30 | |
| 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 |
| 61 | (eval-when (:compile-toplevel :load-toplevel :execute) |
| 62 | (if (find-package '#:gray) |
| 63 | (push :sod-ecl-broken-gray-streams *features*))) |
| 64 | |
| 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))) |
| 68 | |
| 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))) |
| 76 | |
| 77 | ;;;-------------------------------------------------------------------------- |
| 78 | ;;; Proxy streams. |
| 79 | |
| 80 | ;; Base classes for proxy streams. |
| 81 | |
| 82 | (defclass proxy-stream (fundamental-stream) |
| 83 | ((ustream :initarg :stream :type stream |
| 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 | |
| 92 | (defmethod close ((stream proxy-stream) &key abort) |
| 93 | (with-slots (ustream) stream |
| 94 | (close ustream :abort abort))) |
| 95 | |
| 96 | (defmethod stream-element-type ((stream proxy-stream)) |
| 97 | (with-slots (ustream) stream |
| 98 | (stream-element-type ustream))) |
| 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 |
| 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))) |
| 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 |
| 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))) |
| 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 | |
| 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)) |
| 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.) |
| 230 | The position can be read using `stream-line-and-column'. |
| 231 | |
| 232 | This is a base class; you probably want `position-aware-input-stream' or |
| 233 | `position-aware-output-stream'.")) |
| 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)) |
| 248 | "Return the pathname corresponding to a `position-aware-stream'. |
| 249 | |
| 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." |
| 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 | |
| 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 |
| 274 | BODY. What won't work well is dynamically nesting `with-position' forms." |
| 275 | |
| 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))))))) |
| 288 | |
| 289 | ;; Input stream. |
| 290 | |
| 291 | (export 'position-aware-input-stream) |
| 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 | |
| 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))) |
| 308 | (call-next-method)) |
| 309 | |
| 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) |
| 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 | |
| 339 | (export 'position-aware-output-stream) |
| 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 |
| 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) |
| 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 -------------------------------------------------- |