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