mdw@git.distorted.org.uk Git - sod/blob - posn-stream.lisp

   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
  61              :type (or pathname null)
  62              :accessor file-location-pathname)
  63    (line :initarg :line
  64          :type (or fixnum null)
  65          :accessor file-location-line)
  66    (column :initarg :column
  67            :type (or fixnum null)
  68            :accessor file-location-column))
  69   (:documentation
  70    "A simple structure containing file location information.
  71
  72    Construct using MAKE-FILE-LOCATION; the main useful function is
  73    ERROR-FILE-LOCATION."))
  74
  75 (defun make-file-location (pathname line column)
  76   "Constructor for FILE-LOCATION objects.
  77
  78    Returns a FILE-LOCATION object with the given contents."
  79   (make-instance 'file-location
  80                  :pathname (and pathname (pathname pathname))
  81                  :line line :column column))
  82
  83 (defgeneric file-location (thing)
  84   (:documentation
  85    "Convert THING into a FILE-LOCATION, if possible.")
  86   (:method ((thing null)) (make-file-location nil nil nil))
  87   (:method ((thing file-location)) thing)
  88   (:method ((stream stream))
  89     (make-file-location (stream-pathname stream) nil nil)))
  90
  91 (defmethod print-object ((object file-location) stream)
  92   (if *print-escape*
  93       (call-next-method)
  94       (with-slots (pathname line column) object
  95         (format stream "~:[<unnamed>~;~:*~A~]~@[:~D~]~@[:~D~]"
  96                 pathname line column))))
  97
  98 ;;;--------------------------------------------------------------------------
  99 ;;; Proxy streams.
 100
 101 ;; Base classes for proxy streams.
 102
 103 (defclass proxy-stream (fundamental-stream)
 104   ((ustream :initarg :stream
 105             :type stream
 106             :reader position-aware-stream-underlying-stream))
 107   (:documentation
 108    "Base class for proxy streams.
 109
 110    A proxy stream is one that works by passing most of its work to an
 111    underlying stream.  We provide some basic functionality for the later
 112    classes."))
 113
 114 (defmethod stream-close ((stream proxy-stream) &key abort)
 115   (with-slots (ustream) stream
 116     (close ustream :abort abort)))
 117
 118 (defmethod stream-elt-type ((stream proxy-stream))
 119   (with-slots (ustream) stream
 120     (stream-elt-type ustream)))
 121
 122 (defmethod stream-file-position
 123     ((stream proxy-stream) &optional (position nil posp))
 124   (with-slots (ustream) stream
 125     (if posp
 126         (file-position ustream position)
 127         (file-position ustream))))
 128
 129 (defmethod stream-pathname ((stream proxy-stream))
 130   (with-slots (ustream) stream
 131     (stream-pathname ustream)))
 132
 133 ;; Base class for input streams.
 134
 135 (defclass proxy-input-stream (proxy-stream fundamental-input-stream)
 136   ()
 137   (:documentation
 138    "Base class for proxy input streams."))
 139
 140 (defmethod stream-clear-input ((stream proxy-input-stream))
 141   (with-slots (ustream) stream
 142     (clear-input ustream)))
 143
 144 (defmethod stream-read-sequence
 145     ((stream proxy-input-stream) seq &optional (start 0) end)
 146   (with-slots (ustream) stream
 147     (read-sequence seq ustream :start start :end end)))
 148
 149 ;; Base class for output streams.
 150
 151 (defclass proxy-output-stream (proxy-stream fundamental-output-stream)
 152   ()
 153   (:documentation
 154    "Base class for proxy output streams."))
 155
 156 (defmethod stream-clear-output ((stream proxy-output-stream))
 157   (with-slots (ustream) stream
 158     (clear-output ustream)))
 159
 160 (defmethod stream-finish-output ((stream proxy-output-stream))
 161   (with-slots (ustream) stream
 162     (finish-output ustream)))
 163
 164 (defmethod stream-force-output ((stream proxy-output-stream))
 165   (with-slots (ustream) stream
 166     (force-output ustream)))
 167
 168 (defmethod stream-write-sequence
 169     ((stream proxy-output-stream) seq &optional (start 0) end)
 170   (with-slots (ustream) stream
 171     (write-sequence seq ustream :start start :end end)))
 172
 173 ;; Character input streams.
 174
 175 (defclass proxy-character-input-stream
 176     (proxy-input-stream fundamental-character-input-stream)
 177   ()
 178   (:documentation
 179    "A character-input-stream which is a proxy for an existing stream.
 180
 181    This doesn't actually change the behaviour of the underlying stream very
 182    much, but it's a useful base to work on when writing more interesting
 183    classes."))
 184
 185 (defmethod stream-read-char ((stream proxy-character-input-stream))
 186   (with-slots (ustream) stream
 187     (read-char ustream nil :eof nil)))
 188
 189 (defmethod stream-read-line ((stream proxy-character-input-stream))
 190   (with-slots (ustream) stream
 191     (read-line ustream nil "" nil)))
 192
 193 (defmethod stream-unread-char ((stream proxy-character-input-stream) char)
 194   (with-slots (ustream) stream
 195     (unread-char char ustream)))
 196
 197 ;; Character output streams.
 198
 199 (defclass proxy-character-output-stream
 200     (proxy-stream fundamental-character-output-stream)
 201   ()
 202   (:documentation
 203    "A character-output-stream which is a proxy for an existing stream.
 204
 205    This doesn't actually change the behaviour of the underlying stream very
 206    much, but it's a useful base to work on when writing more interesting
 207    classes."))
 208
 209 (defmethod stream-line-column ((stream proxy-character-output-stream))
 210   nil)
 211
 212 (defmethod stream-line-length ((stream proxy-character-output-stream))
 213   nil)
 214
 215 (defmethod stream-terpri ((stream proxy-character-output-stream))
 216   (with-slots (ustream) stream
 217     (terpri ustream)))
 218
 219 (defmethod stream-write-char ((stream proxy-character-output-stream) char)
 220   (with-slots (ustream) stream
 221     (write-char char ustream)))
 222
 223 (defmethod stream-write-string
 224     ((stream proxy-character-output-stream) string &optional (start 0) end)
 225   (with-slots (ustream) stream
 226     (write-string string ustream :start start :end end)))
 227
 228 ;;;--------------------------------------------------------------------------
 229 ;;; The position-aware stream.
 230
 231 ;; Base class.
 232
 233 (defclass position-aware-stream (proxy-stream)
 234   ((file :initarg :file
 235          :initform nil
 236          :type pathname
 237          :accessor position-aware-stream-file)
 238    (line :initarg :line
 239          :initform 1
 240          :type fixnum
 241          :accessor position-aware-stream-line)
 242    (column :initarg :column
 243            :initform 0
 244            :type fixnum
 245            :accessor position-aware-stream-column))
 246   (:documentation
 247    "Character stream which keeps track of the line and column position.
 248
 249    A position-aware-stream wraps an existing character stream and tracks the
 250    line and column position of the current stream position.  A newline
 251    character increases the line number by one and resets the column number to
 252    zero; most characters advance the column number by one, but tab advances
 253    to the next multiple of eight.  (This is consistent with Emacs, at least.)
 254    The position can be read using STREAM-LINE-AND-COLUMN.
 255
 256    This is a base class; you probably want POSITION-AWARE-INPUT-STREAM or
 257    POSITION-AWARE-OUTPUT-STREAM."))
 258
 259 (defgeneric stream-line-and-column (stream)
 260   (:documentation
 261    "Returns the current stream position of STREAM as line/column numbers.
 262
 263    Returns two values: the line and column numbers of STREAM's input
 264    position.")
 265   (:method ((stream stream))
 266     (values nil nil))
 267   (:method ((stream position-aware-stream))
 268     (with-slots (line column) stream
 269       (values line column))))
 270
 271 (defmethod stream-pathname ((stream position-aware-stream))
 272   "Return the pathname corresponding to a POSITION-AWARE-STREAM.
 273
 274    A POSITION-AWARE-STREAM can be given an explicit pathname, which is
 275    returned in preference to the pathname of the underlying stream.  This is
 276    useful in two circumstances.  Firstly, the pathname associated with a file
 277    stream will have been subjected to TRUENAME, and may be less pleasant to
 278    present back to a user.  Secondly, a name can be attached to a stream
 279    which doesn't actually have a file backing it."
 280
 281   (with-slots (file) stream
 282     (or file (call-next-method))))
 283
 284 (defmethod file-location ((stream position-aware-stream))
 285   (multiple-value-bind (line column) (stream-line-and-column stream)
 286     (make-file-location (stream-pathname stream) line column)))
 287
 288 ;; Utilities.
 289
 290 (declaim (inline update-position))
 291 (defun update-position (char line column)
 292   "Updates LINE and COLUMN according to the character CHAR.
 293
 294    Returns the new LINE and COLUMN numbers resulting from having read CHAR."
 295   (case char
 296     ((#\newline #\vt #\page)
 297      (values (1+ line) 0))
 298     ((#\tab)
 299      (values line (logandc2 (+ column 7) 7)))
 300     (t
 301      (values line (1+ column)))))
 302
 303 (defmacro with-position ((stream) &body body)
 304   "Convenience macro for tracking the read position.
 305
 306    Within the BODY, the macro (update CHAR) is defined to update the STREAM's
 307    position according to the character CHAR.
 308
 309    The position is actually cached in local variables, but will be written
 310    back to the stream even in the case of non-local control transfer from the
 311    BODY.  What won't work well is dynamically nesting WITH-POSITION forms."
 312
 313   (let ((streamvar (gensym "STREAM"))
 314         (linevar (gensym "LINE"))
 315         (colvar (gensym "COLUMN"))
 316         (charvar (gensym "CHAR")))
 317     `(let* ((,streamvar ,stream)
 318             (,linevar (position-aware-stream-line ,streamvar))
 319             (,colvar (position-aware-stream-column ,streamvar)))
 320        (macrolet ((update (,charvar)
 321                     ;; This gets a little hairy.  Hold tight.
 322                     `(multiple-value-setq (,',linevar ,',colvar)
 323                       (update-position ,,charvar ,',linevar ,',colvar))))
 324          (unwind-protect
 325               (progn ,@body)
 326            (setf (position-aware-stream-line ,streamvar) ,linevar
 327                  (position-aware-stream-column ,streamvar) ,colvar))))))
 328
 329 ;; Input stream.
 330
 331 (defclass position-aware-input-stream
 332     (position-aware-stream proxy-character-input-stream)
 333   ()
 334   (:documentation
 335    "A character input stream which tracks the input position.
 336
 337    This is particularly useful for parsers and suchlike, which want to
 338    produce accurate error-location information."))
 339
 340 (defmethod stream-unread-char ((stream position-aware-input-stream) char)
 341
 342   ;; Tweak the position so that the next time the character is read, it will
 343   ;; end up here.  This isn't perfect: if the character doesn't actually
 344   ;; match what was really read then it might not actually be possible: for
 345   ;; example, if we push back a newline while in the middle of a line, or a
 346   ;; tab while not at a tab stop.  In that case, we'll just lose, but
 347   ;; hopefully not too badly.
 348   (with-slots (line column) stream
 349     (case char
 350
 351       ;; In the absence of better ideas, I'll set the column number to zero.
 352       ;; This is almost certainly wrong, but with a little luck nobody will
 353       ;; ask and it'll be all right soon.
 354       ((#\newline #\vt #\page)
 355        (decf line)
 356        (setf column 0))
 357
 358       ;; Winding back a single space is sufficient.  If the position is
 359       ;; currently on a tab stop then it'll advance back here next time.  If
 360       ;; not, we're going to lose anyway.
 361       (#\tab
 362        (decf column))
 363
 364       ;; Anything else: just decrement the column and cross fingers.
 365       (t
 366        (decf column))))
 367
 368   ;; And actually do it.  (I could have written this as a :before or :after
 369   ;; method, but I think this is the right answer.  All of the other methods
 370   ;; have to be primary (or around) methods, so at least it's consistent.)
 371   (call-next-method))
 372
 373 (defmethod stream-read-sequence
 374     ((stream position-aware-input-stream) seq &optional (start 0) end)
 375   (declare (ignore end))
 376   (let ((pos (call-next-method)))
 377     (with-position (stream)
 378       (dosequence (ch seq :start start :end pos)
 379         (update ch)))
 380     pos))
 381
 382 (defmethod stream-read-char ((stream position-aware-input-stream))
 383   (let ((char (call-next-method)))
 384     (with-position (stream)
 385       (update char))
 386     char))
 387
 388 (defmethod stream-read-line ((stream position-aware-input-stream))
 389   (multiple-value-bind (line eofp) (call-next-method)
 390     (if eofp
 391         (with-position (stream)
 392           (dotimes (i (length line))
 393             (update (char line i))))
 394         (with-slots (line column) stream
 395           (incf line)
 396           (setf column 0)))
 397     (values line eofp)))
 398
 399 ;; Output stream.
 400
 401 (defclass position-aware-output-stream
 402     (position-aware-stream proxy-character-output-stream)
 403   ()
 404   (:documentation
 405    "A character output stream which tracks the output position.
 406
 407    This is particularly useful when generating C code: the position can be
 408    used to generate `#line' directives referring to the generated code after
 409    insertion of some user code."))
 410
 411 (defmethod stream-write-sequence
 412     ((stream position-aware-output-stream) seq &optional (start 0) end)
 413   (with-position (stream)
 414     (dosequence (ch seq :start start :end end)
 415       (update ch))
 416     (call-next-method)))
 417
 418 (defmethod stream-line-column ((stream position-aware-output-stream))
 419   (with-slots (column) stream
 420     column))
 421
 422 (defmethod stream-start-line-p ((stream position-aware-output-stream))
 423   (with-slots (column) stream
 424     (zerop column)))
 425
 426 (defmethod stream-terpri ((stream position-aware-output-stream))
 427   (with-slots (line column) stream
 428     (incf line)
 429     (setf column 0))
 430   (call-next-method))
 431
 432 (defmethod stream-write-char ((stream position-aware-output-stream) char)
 433   (with-position (stream)
 434     (update char))
 435   (call-next-method))
 436
 437 (defmethod stream-write-string
 438     ((stream position-aware-output-stream) string &optional (start 0) end)
 439   (with-position (stream)
 440     (do ((i start (1+ i))
 441          (end (or end (length string))))
 442         ((>= i end))
 443       (update (char string i))))
 444   (call-next-method))
 445
 446 ;;;----- That's all, folks --------------------------------------------------