chiark - git - mdw - sod/blob - src/parser/streams-impl.lisp

   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 Sensble 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 &optional (start 0) end)
 124   (with-slots (ustream) stream
 125     (read-sequence seq ustream :start start :end end)))
 126
 127 ;; Base class for output streams.
 128
 129 (defclass proxy-output-stream (proxy-stream fundamental-output-stream)
 130   ()
 131   (:documentation
 132    "Base class for proxy output streams."))
 133
 134 (defmethod stream-clear-output ((stream proxy-output-stream))
 135   (with-slots (ustream) stream
 136     (clear-output ustream)))
 137
 138 (defmethod stream-finish-output ((stream proxy-output-stream))
 139   (with-slots (ustream) stream
 140     (finish-output ustream)))
 141
 142 (defmethod stream-force-output ((stream proxy-output-stream))
 143   (with-slots (ustream) stream
 144     (force-output ustream)))
 145
 146 (defmethod stream-write-sequence
 147     ((stream proxy-output-stream) seq &optional (start 0) end)
 148   (with-slots (ustream) stream
 149     (write-sequence seq ustream :start start :end end)))
 150
 151 ;; Character input streams.
 152
 153 (defclass proxy-character-input-stream
 154     (proxy-input-stream fundamental-character-input-stream)
 155   ()
 156   (:documentation
 157    "A character-input-stream which is a proxy for an existing stream.
 158
 159    This doesn't actually change the behaviour of the underlying stream very
 160    much, but it's a useful base to work on when writing more interesting
 161    classes."))
 162
 163 (defmethod stream-read-char ((stream proxy-character-input-stream))
 164   (with-slots (ustream) stream
 165     (read-char ustream nil :eof nil)))
 166
 167 (defmethod stream-read-line ((stream proxy-character-input-stream))
 168   (with-slots (ustream) stream
 169     (read-line ustream nil "" nil)))
 170
 171 (defmethod stream-unread-char ((stream proxy-character-input-stream) char)
 172   (with-slots (ustream) stream
 173     (unread-char char ustream)))
 174
 175 ;; Character output streams.
 176
 177 (defclass proxy-character-output-stream
 178     (proxy-stream fundamental-character-output-stream)
 179   ()
 180   (:documentation
 181    "A character-output-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-line-column ((stream proxy-character-output-stream))
 188   nil)
 189
 190 (defmethod stream-line-length ((stream proxy-character-output-stream))
 191   nil)
 192
 193 (defmethod stream-terpri ((stream proxy-character-output-stream))
 194   (with-slots (ustream) stream
 195     (terpri ustream)))
 196
 197 (defmethod stream-write-char ((stream proxy-character-output-stream) char)
 198   (with-slots (ustream) stream
 199     (write-char char ustream)))
 200
 201 (defmethod stream-write-string
 202     ((stream proxy-character-output-stream) string &optional (start 0) end)
 203   (with-slots (ustream) stream
 204     (write-string string ustream :start start :end end)))
 205
 206 ;;;--------------------------------------------------------------------------
 207 ;;; The position-aware stream.
 208
 209 ;; Base class.
 210
 211 (export '(position-aware-stream
 212           position-aware-stream-line position-aware-stream-column))
 213 (defclass position-aware-stream (proxy-stream)
 214   ((file :initarg :file :initform nil
 215          :type pathname :accessor position-aware-stream-file)
 216    (line :initarg :line :initform 1
 217          :type fixnum :accessor position-aware-stream-line)
 218    (column :initarg :column :initform 0
 219            :type fixnum :accessor position-aware-stream-column))
 220   (:documentation
 221    "Character stream which keeps track of the line and column position.
 222
 223    A position-aware-stream wraps an existing character stream and tracks the
 224    line and column position of the current stream position.  A newline
 225    character increases the line number by one and resets the column number to
 226    zero; most characters advance the column number by one, but tab advances
 227    to the next multiple of eight.  (This is consistent with Emacs, at least.)
 228    The position can be read using STREAM-LINE-AND-COLUMN.
 229
 230    This is a base class; you probably want POSITION-AWARE-INPUT-STREAM or
 231    POSITION-AWARE-OUTPUT-STREAM."))
 232
 233 (defgeneric stream-line-and-column (stream)
 234   (:documentation
 235    "Returns the current stream position of STREAM as line/column numbers.
 236
 237    Returns two values: the line and column numbers of STREAM's input
 238    position.")
 239   (:method ((stream stream))
 240     (values nil nil))
 241   (:method ((stream position-aware-stream))
 242     (with-slots (line column) stream
 243       (values line column))))
 244
 245 (defmethod stream-pathname ((stream position-aware-stream))
 246   "Return the pathname corresponding to a POSITION-AWARE-STREAM.
 247
 248    A POSITION-AWARE-STREAM can be given an explicit pathname, which is
 249    returned in preference to the pathname of the underlying stream.  This is
 250    useful in two circumstances.  Firstly, the pathname associated with a file
 251    stream will have been subjected to TRUENAME, and may be less pleasant to
 252    present back to a user.  Secondly, a name can be attached to a stream
 253    which doesn't actually have a file backing it."
 254
 255   (with-slots (file) stream
 256     (or file (call-next-method))))
 257
 258 (defmethod file-location ((stream position-aware-stream))
 259   (multiple-value-bind (line column) (stream-line-and-column stream)
 260     (make-file-location (stream-pathname stream) line column)))
 261
 262 ;; Utilities.
 263
 264 (defmacro with-position ((stream) &body body)
 265   "Convenience macro for tracking the read position.
 266
 267    Within the BODY, the macro (update CHAR) is defined to update the STREAM's
 268    position according to the character CHAR.
 269
 270    The position is actually cached in local variables, but will be written
 271    back to the stream even in the case of non-local control transfer from the
 272    BODY.  What won't work well is dynamically nesting WITH-POSITION forms."
 273
 274   (with-gensyms (line column char)
 275     (once-only (stream)
 276       `(let* ((,line (position-aware-stream-line ,stream))
 277               (,column (position-aware-stream-column ,stream)))
 278          (macrolet ((update (,char)
 279                       ;; This gets a little hairy.  Hold tight.
 280                       `(multiple-value-setq (,',line ,',column)
 281                          (update-position ,,char ,',line ,',column))))
 282            (unwind-protect
 283                 (progn ,@body)
 284              (setf (position-aware-stream-line ,stream) ,line
 285                    (position-aware-stream-column ,stream) ,column)))))))
 286
 287 ;; Input stream.
 288
 289 (export 'position-aware-input-stream)
 290 (defclass position-aware-input-stream
 291     (position-aware-stream proxy-character-input-stream)
 292   ()
 293   (:documentation
 294    "A character input stream which tracks the input position.
 295
 296    This is particularly useful for parsers and suchlike, which want to
 297    produce accurate error-location information."))
 298
 299 (defmethod stream-unread-char ((stream position-aware-input-stream) char)
 300
 301   ;; I could have written this as a :before or :after method, but I think
 302   ;; this is the right answer.  All of the other methods have to be primary
 303   ;; (or around) methods, so at least it's consistent.
 304   (with-slots (line column) stream
 305     (setf (values line column) (backtrack-position char line column)))
 306   (call-next-method))
 307
 308 (defmethod stream-read-sequence
 309     ((stream position-aware-input-stream) seq &optional (start 0) end)
 310   (declare (ignore end))
 311   (let ((pos (call-next-method)))
 312     (with-position (stream)
 313       (dosequence (ch seq :start start :end pos)
 314         (update ch)))
 315     pos))
 316
 317 (defmethod stream-read-char ((stream position-aware-input-stream))
 318   (let ((char (call-next-method)))
 319     (with-position (stream)
 320       (update char))
 321     char))
 322
 323 (defmethod stream-read-line ((stream position-aware-input-stream))
 324   (multiple-value-bind (line eofp) (call-next-method)
 325     (if eofp
 326         (with-position (stream)
 327           (dotimes (i (length line))
 328             (update (char line i))))
 329         (with-slots (line column) stream
 330           (incf line)
 331           (setf column 0)))
 332     (values line eofp)))
 333
 334 ;; Output stream.
 335
 336 (export 'position-aware-output-stream)
 337 (defclass position-aware-output-stream
 338     (position-aware-stream proxy-character-output-stream)
 339   ()
 340   (:documentation
 341    "A character output stream which tracks the output position.
 342
 343    This is particularly useful when generating C code: the position can be
 344    used to generate `#line' directives referring to the generated code after
 345    insertion of some user code."))
 346
 347 (defmethod stream-write-sequence
 348     ((stream position-aware-output-stream) seq &optional (start 0) end)
 349   (with-position (stream)
 350     (dosequence (ch seq :start start :end end)
 351       (update ch))
 352     (call-next-method)))
 353
 354 (defmethod stream-line-column ((stream position-aware-output-stream))
 355   (with-slots (column) stream
 356     column))
 357
 358 (defmethod stream-start-line-p ((stream position-aware-output-stream))
 359   (with-slots (column) stream
 360     (zerop column)))
 361
 362 (defmethod stream-terpri ((stream position-aware-output-stream))
 363   (with-slots (line column) stream
 364     (incf line)
 365     (setf column 0))
 366   (call-next-method))
 367
 368 (defmethod stream-write-char ((stream position-aware-output-stream) char)
 369   (with-position (stream)
 370     (update char))
 371   (call-next-method))
 372
 373 (defmethod stream-write-string
 374     ((stream position-aware-output-stream) string &optional (start 0) end)
 375   (with-position (stream)
 376     (do ((i start (1+ i))
 377          (end (or end (length string))))
 378         ((>= i end))
 379       (update (char string i))))
 380   (call-next-method))
 381
 382 ;;;----- That's all, folks --------------------------------------------------