mdw@git.distorted.org.uk Git - 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 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   (or (position-aware-stream-file stream)
 228       (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 --------------------------------------------------