| 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 | (defmethod stream-line-and-column ((stream position-aware-stream)) |
| 214 | (with-slots (line column) stream |
| 215 | (values line column))) |
| 216 | |
| 217 | (defmethod stream-pathname ((stream position-aware-stream)) |
| 218 | "Return the pathname corresponding to a `position-aware-stream'. |
| 219 | |
| 220 | A `position-aware-stream' can be given an explicit pathname, which is |
| 221 | returned in preference to the pathname of the underlying stream. This is |
| 222 | useful in two circumstances. Firstly, the pathname associated with a file |
| 223 | stream will have been subjected to `truename', and may be less pleasant to |
| 224 | present back to a user. Secondly, a name can be attached to a stream |
| 225 | which doesn't actually have a file backing it." |
| 226 | |
| 227 | (with-slots (file) stream |
| 228 | (or file (call-next-method)))) |
| 229 | |
| 230 | (defmethod file-location ((stream position-aware-stream)) |
| 231 | (multiple-value-bind (line column) (stream-line-and-column stream) |
| 232 | (make-file-location (stream-pathname stream) line column))) |
| 233 | |
| 234 | ;; Utilities. |
| 235 | |
| 236 | (defmacro with-position ((stream) &body body) |
| 237 | "Convenience macro for tracking the read position. |
| 238 | |
| 239 | Within the BODY, the macro (update CHAR) is defined to update the STREAM's |
| 240 | position according to the character CHAR. |
| 241 | |
| 242 | The position is actually cached in local variables, but will be written |
| 243 | back to the stream even in the case of non-local control transfer from the |
| 244 | BODY. What won't work well is dynamically nesting `with-position' forms." |
| 245 | |
| 246 | (with-gensyms (line column char) |
| 247 | (once-only (stream) |
| 248 | `(let* ((,line (position-aware-stream-line ,stream)) |
| 249 | (,column (position-aware-stream-column ,stream))) |
| 250 | (macrolet ((update (,char) |
| 251 | ;; This gets a little hairy. Hold tight. |
| 252 | `(multiple-value-setq (,',line ,',column) |
| 253 | (update-position ,,char ,',line ,',column)))) |
| 254 | (unwind-protect |
| 255 | (progn ,@body) |
| 256 | (setf (position-aware-stream-line ,stream) ,line |
| 257 | (position-aware-stream-column ,stream) ,column))))))) |
| 258 | |
| 259 | ;; Input stream. |
| 260 | |
| 261 | (defmethod stream-unread-char ((stream position-aware-input-stream) char) |
| 262 | |
| 263 | ;; I could have written this as a :before or :after method, but I think |
| 264 | ;; this is the right answer. All of the other methods have to be primary |
| 265 | ;; (or around) methods, so at least it's consistent. |
| 266 | (with-slots (line column) stream |
| 267 | (setf (values line column) (backtrack-position char line column))) |
| 268 | (call-next-method)) |
| 269 | |
| 270 | (defmethod stream-read-sequence |
| 271 | ((stream position-aware-input-stream) seq |
| 272 | #+clisp &key #-clisp &optional (start 0) end) |
| 273 | (declare (ignore end)) |
| 274 | (let ((pos (call-next-method))) |
| 275 | (with-position (stream) |
| 276 | (dosequence (ch seq :start start :end pos) |
| 277 | (update ch))) |
| 278 | pos)) |
| 279 | |
| 280 | (defmethod stream-read-char ((stream position-aware-input-stream)) |
| 281 | (let ((char (call-next-method))) |
| 282 | (with-position (stream) |
| 283 | (update char)) |
| 284 | char)) |
| 285 | |
| 286 | (defmethod stream-read-line ((stream position-aware-input-stream)) |
| 287 | (multiple-value-bind (line eofp) (call-next-method) |
| 288 | (if eofp |
| 289 | (with-position (stream) |
| 290 | (dotimes (i (length line)) |
| 291 | (update (char line i)))) |
| 292 | (with-slots (line column) stream |
| 293 | (incf line) |
| 294 | (setf column 0))) |
| 295 | (values line eofp))) |
| 296 | |
| 297 | ;; Output stream. |
| 298 | |
| 299 | (defmethod stream-write-sequence |
| 300 | ((stream position-aware-output-stream) seq |
| 301 | #+clisp &key #-clisp &optional (start 0) end) |
| 302 | (with-position (stream) |
| 303 | (dosequence (ch seq :start start :end end) |
| 304 | (update ch)) |
| 305 | (call-next-method))) |
| 306 | |
| 307 | (defmethod stream-line-column ((stream position-aware-output-stream)) |
| 308 | (with-slots (column) stream |
| 309 | column)) |
| 310 | |
| 311 | (defmethod stream-start-line-p ((stream position-aware-output-stream)) |
| 312 | (with-slots (column) stream |
| 313 | (zerop column))) |
| 314 | |
| 315 | (defmethod stream-terpri ((stream position-aware-output-stream)) |
| 316 | (with-slots (line column) stream |
| 317 | (incf line) |
| 318 | (setf column 0)) |
| 319 | (call-next-method)) |
| 320 | |
| 321 | (defmethod stream-write-char ((stream position-aware-output-stream) char) |
| 322 | (with-position (stream) |
| 323 | (update char)) |
| 324 | (call-next-method)) |
| 325 | |
| 326 | (defmethod stream-write-string |
| 327 | ((stream position-aware-output-stream) string &optional (start 0) end) |
| 328 | (with-position (stream) |
| 329 | (do ((i start (1+ i)) |
| 330 | (end (or end (length string)))) |
| 331 | ((>= i end)) |
| 332 | (update (char string i)))) |
| 333 | (call-next-method)) |
| 334 | |
| 335 | ;;;----- That's all, folks -------------------------------------------------- |