src/pcl/gray-streams.lisp

   1 ;;;; Gray streams implementation for SBCL, based on the Gray streams
   2 ;;;; implementation for CMU CL, based on the stream-definition-by-user proposal
   3 ;;;; by David N. Gray.
   4
   5 ;;;; This software is part of the SBCL system. See the README file for
   6 ;;;; more information.
   7
   8 ;;;; This software is in the public domain and is provided with absolutely no
   9 ;;;; warranty. See the COPYING and CREDITS files for more information.
  10
  11 (in-package "SB-GRAY")
  12
  13 (sb-int:file-comment
  14   "$Header$")
  15 \f
  16 (fmakunbound 'stream-element-type)
  17
  18 (defgeneric stream-element-type (stream)
  19   #+sb-doc
  20   (:documentation
  21    "Returns a type specifier for the kind of object returned by the
  22   Stream. Class FUNDAMENTAL-CHARACTER-STREAM provides a default method
  23   which returns CHARACTER."))
  24
  25 (defmethod stream-element-type ((stream lisp-stream))
  26   (funcall (lisp-stream-misc stream) stream :element-type))
  27
  28 (defmethod stream-element-type ((stream fundamental-character-stream))
  29   'character)
  30 \f
  31 (defgeneric pcl-open-stream-p (stream)
  32   #+sb-doc
  33   (:documentation
  34    "Return true if Stream is not closed. A default method is provided
  35   by class FUNDAMENTAL-STREAM which returns true if CLOSE has not been
  36   called on the stream."))
  37
  38 (defmethod pcl-open-stream-p ((stream lisp-stream))
  39   (not (eq (sb-impl::lisp-stream-in stream) #'sb-impl::closed-flame)))
  40
  41 (defmethod pcl-open-stream-p ((stream fundamental-stream))
  42   nil)
  43
  44 ;;; bootstrapping hack
  45 (pcl-open-stream-p (make-string-output-stream))
  46 (setf (fdefinition 'open-stream-p) #'pcl-open-stream-p)
  47 \f
  48 (defgeneric pcl-close (stream &key abort)
  49   #+sb-doc
  50   (:documentation
  51    "Closes the given Stream. No more I/O may be performed, but
  52   inquiries may still be made. If :Abort is non-nil, an attempt is made
  53   to clean up the side effects of having created the stream."))
  54
  55 (defmethod pcl-close ((stream lisp-stream) &key abort)
  56   (when (open-stream-p stream)
  57     (funcall (lisp-stream-misc stream) stream :close abort))
  58   t)
  59
  60 (setf (fdefinition 'close) #'pcl-close)
  61 \f
  62 (fmakunbound 'input-stream-p)
  63
  64 (defgeneric input-stream-p (stream)
  65   #+sb-doc
  66   (:documentation "Returns non-nil if the given Stream can perform input operations."))
  67
  68 (defmethod input-stream-p ((stream lisp-stream))
  69   (and (not (eq (sb-impl::lisp-stream-in stream) #'sb-impl::closed-flame))
  70        (or (not (eq (sb-impl::lisp-stream-in stream) #'ill-in))
  71            (not (eq (lisp-stream-bin stream) #'ill-bin)))))
  72
  73 (defmethod input-stream-p ((stream fundamental-input-stream))
  74   t)
  75 \f
  76 (fmakunbound 'output-stream-p)
  77
  78 (defgeneric output-stream-p (stream)
  79   #+sb-doc
  80   (:documentation "Returns non-nil if the given Stream can perform output operations."))
  81
  82 (defmethod output-stream-p ((stream lisp-stream))
  83   (and (not (eq (sb-impl::lisp-stream-in stream) #'sb-impl::closed-flame))
  84        (or (not (eq (lisp-stream-out stream) #'ill-out))
  85            (not (eq (lisp-stream-bout stream) #'ill-bout)))))
  86
  87 (defmethod output-stream-p ((stream fundamental-output-stream))
  88   t)
  89 \f
  90 ;;; character input streams
  91 ;;;
  92 ;;; A character input stream can be created by defining a class that
  93 ;;; includes FUNDAMENTAL-CHARACTER-INPUT-STREAM and defining methods
  94 ;;; for the generic functions below.
  95
  96 (defgeneric stream-read-char (stream)
  97   #+sb-doc
  98   (:documentation
  99    "This reads one character from the stream. It returns either a
 100   character object, or the symbol :EOF if the stream is at end-of-file.
 101   Every subclass of FUNDAMENTAL-CHARACTER-INPUT-STREAM must define a
 102   method for this function."))
 103
 104 (defgeneric stream-unread-char (stream character)
 105   #+sb-doc
 106   (:documentation
 107    "Un-does the last call to STREAM-READ-CHAR, as in UNREAD-CHAR.
 108   Returns NIL. Every subclass of FUNDAMENTAL-CHARACTER-INPUT-STREAM
 109   must define a method for this function."))
 110
 111 (defgeneric stream-read-char-no-hang (stream)
 112   #+sb-doc
 113   (:documentation
 114    "This is used to implement READ-CHAR-NO-HANG. It returns either a
 115   character, or NIL if no input is currently available, or :EOF if
 116   end-of-file is reached. The default method provided by
 117   FUNDAMENTAL-CHARACTER-INPUT-STREAM simply calls STREAM-READ-CHAR; this
 118   is sufficient for file streams, but interactive streams should define
 119   their own method."))
 120
 121 (defmethod stream-read-char-no-hang ((stream fundamental-character-input-stream))
 122   (stream-read-char stream))
 123
 124 (defgeneric stream-peek-char (stream)
 125   #+sb-doc
 126   (:documentation
 127    "Used to implement PEEK-CHAR; this corresponds to peek-type of NIL.
 128   It returns either a character or :EOF. The default method calls
 129   STREAM-READ-CHAR and STREAM-UNREAD-CHAR."))
 130
 131 (defmethod stream-peek-char ((stream fundamental-character-input-stream))
 132   (let ((char (stream-read-char stream)))
 133     (unless (eq char :eof)
 134       (stream-unread-char stream char))
 135     char))
 136
 137 (defgeneric stream-listen (stream)
 138   #+sb-doc
 139   (:documentation
 140    "Used by LISTEN. Returns true or false. The default method uses
 141   STREAM-READ-CHAR-NO-HANG and STREAM-UNREAD-CHAR. Most streams should
 142   define their own method since it will usually be trivial and will
 143   always be more efficient than the default method."))
 144
 145 (defmethod stream-listen ((stream fundamental-character-input-stream))
 146   (let ((char (stream-read-char-no-hang stream)))
 147     (when (characterp char)
 148       (stream-unread-char stream char)
 149       t)))
 150
 151 (defgeneric stream-read-line (stream)
 152   #+sb-doc
 153   (:documentation
 154    "Used by READ-LINE. A string is returned as the first value. The
 155   second value is true if the string was terminated by end-of-file
 156   instead of the end of a line. The default method uses repeated
 157   calls to STREAM-READ-CHAR."))
 158
 159 (defmethod stream-read-line ((stream fundamental-character-input-stream))
 160   (let ((res (make-string 80))
 161         (len 80)
 162         (index 0))
 163     (loop
 164      (let ((ch (stream-read-char stream)))
 165        (cond ((eq ch :eof)
 166               (return (values (shrink-vector res index) t)))
 167              (t
 168               (when (char= ch #\newline)
 169                 (return (values (shrink-vector res index) nil)))
 170               (when (= index len)
 171                 (setq len (* len 2))
 172                 (let ((new (make-string len)))
 173                   (replace new res)
 174                   (setq res new)))
 175               (setf (schar res index) ch)
 176               (incf index)))))))
 177
 178 (defgeneric stream-clear-input (stream)
 179   #+sb-doc
 180   (:documentation
 181    "Implements CLEAR-INPUT for the stream, returning NIL. The default
 182   method does nothing."))
 183
 184 (defmethod stream-clear-input ((stream fundamental-character-input-stream))
 185   nil)
 186 \f
 187 ;;; character output streams
 188 ;;;
 189 ;;; A character output stream can be created by defining a class that
 190 ;;; includes FUNDAMENTAL-CHARACTER-OUTPUT-STREAM and defining methods
 191 ;;; for the generic functions below.
 192
 193 (defgeneric stream-write-char (stream character)
 194   #+sb-doc
 195   (:documentation
 196    "Writes character to the stream and returns the character. Every
 197   subclass of FUNDAMENTAL-CHARACTER-OUTPUT-STREAM must have a method
 198   defined for this function."))
 199
 200 (defgeneric stream-line-column (stream)
 201   #+sb-doc
 202   (:documentation
 203    "This function returns the column number where the next character
 204   will be written, or NIL if that is not meaningful for this stream.
 205   The first column on a line is numbered 0. This function is used in
 206   the implementation of PPRINT and the FORMAT ~T directive. For every
 207   character output stream class that is defined, a method must be
 208   defined for this function, although it is permissible for it to
 209   always return NIL."))
 210
 211 ;;; STREAM-LINE-LENGTH is a CMU CL extension to Gray streams.
 212 ;;; FIXME: Should we support it? Probably not..
 213 (defgeneric stream-line-length (stream)
 214   #+sb-doc
 215   (:documentation "Return the stream line length or Nil."))
 216
 217 (defmethod stream-line-length ((stream fundamental-character-output-stream))
 218   nil)
 219
 220 (defgeneric stream-start-line-p (stream)
 221   #+sb-doc
 222   (:documentation
 223    "This is a predicate which returns T if the stream is positioned at
 224   the beginning of a line, else NIL. It is permissible to always return
 225   NIL. This is used in the implementation of FRESH-LINE. Note that
 226   while a value of 0 from STREAM-LINE-COLUMN also indicates the
 227   beginning of a line, there are cases where STREAM-START-LINE-P can be
 228   meaningfully implemented although STREAM-LINE-COLUMN can't be. For
 229   example, for a window using variable-width characters, the column
 230   number isn't very meaningful, but the beginning of the line does have
 231   a clear meaning. The default method for STREAM-START-LINE-P on class
 232   FUNDAMENTAL-CHARACTER-OUTPUT-STREAM uses STREAM-LINE-COLUMN, so if
 233   that is defined to return NIL, then a method should be provided for
 234   either STREAM-START-LINE-P or STREAM-FRESH-LINE."))
 235
 236 (defmethod stream-start-line-p ((stream fundamental-character-output-stream))
 237   (eql (stream-line-column stream) 0))
 238
 239 (defgeneric stream-write-string (stream string &optional (start 0) end)
 240   #+sb-doc
 241   (:documentation
 242    "This is used by WRITE-STRING. It writes the string to the stream,
 243   optionally delimited by start and end, which default to 0 and NIL.
 244   The string argument is returned. The default method provided by
 245   FUNDAMENTAL-CHARACTER-OUTPUT-STREAM uses repeated calls to
 246   STREAM-WRITE-CHAR."))
 247
 248 (defmethod stream-write-string ((stream fundamental-character-output-stream)
 249                                 string &optional (start 0) end)
 250   (declare (string string)
 251            (fixnum start))
 252   (let ((end (or end (length string))))
 253     (declare (fixnum end))
 254     (do ((pos start (1+ pos)))
 255         ((>= pos end))
 256       (declare (type index pos))
 257       (stream-write-char stream (aref string pos))))
 258   string)
 259
 260 (defgeneric stream-terpri (stream)
 261   #+sb-doc
 262   (:documentation
 263    "Writes an end of line, as for TERPRI. Returns NIL. The default
 264   method does (STREAM-WRITE-CHAR stream #\NEWLINE)."))
 265
 266 (defmethod stream-terpri ((stream fundamental-character-output-stream))
 267   (stream-write-char stream #\Newline))
 268
 269 (defgeneric stream-fresh-line (stream)
 270   #+sb-doc
 271   (:documentation
 272    "Outputs a new line to the Stream if it is not positioned at the
 273   begining of a line. Returns T if it output a new line, nil
 274   otherwise. Used by FRESH-LINE. The default method uses
 275   STREAM-START-LINE-P and STREAM-TERPRI."))
 276
 277 (defmethod stream-fresh-line ((stream fundamental-character-output-stream))
 278   (unless (stream-start-line-p stream)
 279     (stream-terpri stream)
 280     t))
 281
 282 (defgeneric stream-finish-output (stream)
 283   #+sb-doc
 284   (:documentation
 285    "Attempts to ensure that all output sent to the Stream has reached
 286   its destination, and only then returns false. Implements
 287   FINISH-OUTPUT. The default method does nothing."))
 288
 289 (defmethod stream-finish-output ((stream fundamental-output-stream))
 290   nil)
 291
 292 (defgeneric stream-force-output (stream)
 293   #+sb-doc
 294   (:documentation
 295    "Attempts to force any buffered output to be sent. Implements
 296   FORCE-OUTPUT. The default method does nothing."))
 297
 298 (defmethod stream-force-output ((stream fundamental-output-stream))
 299   nil)
 300
 301 (defgeneric stream-clear-output (stream)
 302   #+sb-doc
 303   (:documentation
 304    "Clears the given output Stream. Implements CLEAR-OUTPUT. The
 305   default method does nothing."))
 306
 307 (defmethod stream-clear-output ((stream fundamental-output-stream))
 308   nil)
 309
 310 (defgeneric stream-advance-to-column (stream column)
 311   #+sb-doc
 312   (:documentation
 313    "Writes enough blank space so that the next character will be
 314   written at the specified column. Returns true if the operation is
 315   successful, or NIL if it is not supported for this stream. This is
 316   intended for use by by PPRINT and FORMAT ~T. The default method uses
 317   STREAM-LINE-COLUMN and repeated calls to STREAM-WRITE-CHAR with a
 318   #\SPACE character; it returns NIL if STREAM-LINE-COLUMN returns NIL."))
 319
 320 (defmethod stream-advance-to-column ((stream fundamental-character-output-stream)
 321                                      column)
 322   (let ((current-column (stream-line-column stream)))
 323     (when current-column
 324       (let ((fill (- column current-column)))
 325         (dotimes-fixnum (i fill)
 326           (stream-write-char stream #\Space)))
 327       T)))
 328 \f
 329 ;;; binary streams
 330 ;;;
 331 ;;; Binary streams can be created by defining a class that includes
 332 ;;; either FUNDAMENTAL-BINARY-INPUT-STREAM or
 333 ;;; FUNDAMENTAL-BINARY-OUTPUT-STREAM (or both) and defining a method
 334 ;;; for STREAM-ELEMENT-TYPE and for one or both of the following
 335 ;;; generic functions.
 336
 337 (defgeneric stream-read-byte (stream)
 338   #+sb-doc
 339   (:documentation
 340    "Used by READ-BYTE; returns either an integer, or the symbol :EOF
 341   if the stream is at end-of-file."))
 342
 343 (defgeneric stream-write-byte (stream integer)
 344   #+sb-doc
 345   (:documentation
 346    "Implements WRITE-BYTE; writes the integer to the stream and
 347   returns the integer as the result."))
 348 \f
 349 ;;; example character output stream encapsulating a lisp-stream
 350 (defun make-character-output-stream (lisp-stream)
 351   (declare (type lisp-stream lisp-stream))
 352   (make-instance 'character-output-stream :lisp-stream lisp-stream))
 353
 354 (defmethod open-stream-p ((stream character-output-stream))
 355   (open-stream-p (character-output-stream-lisp-stream stream)))
 356
 357 (defmethod close ((stream character-output-stream) &key abort)
 358   (close (character-output-stream-lisp-stream stream) :abort abort))
 359
 360 (defmethod input-stream-p ((stream character-output-stream))
 361   (input-stream-p (character-output-stream-lisp-stream stream)))
 362
 363 (defmethod output-stream-p ((stream character-output-stream))
 364   (output-stream-p (character-output-stream-lisp-stream stream)))
 365
 366 (defmethod stream-write-char ((stream character-output-stream) character)
 367   (write-char character (character-output-stream-lisp-stream stream)))
 368
 369 (defmethod stream-line-column ((stream character-output-stream))
 370   (charpos (character-output-stream-lisp-stream stream)))
 371
 372 (defmethod stream-line-length ((stream character-output-stream))
 373   (line-length (character-output-stream-lisp-stream stream)))
 374
 375 (defmethod stream-finish-output ((stream character-output-stream))
 376   (finish-output (character-output-stream-lisp-stream stream)))
 377
 378 (defmethod stream-force-output ((stream character-output-stream))
 379   (force-output (character-output-stream-lisp-stream stream)))
 380
 381 (defmethod stream-clear-output ((stream character-output-stream))
 382   (clear-output (character-output-stream-lisp-stream stream)))
 383 \f
 384 ;;; example character input stream encapsulating a lisp-stream
 385
 386 (defun make-character-input-stream (lisp-stream)
 387   (declare (type lisp-stream lisp-stream))
 388   (make-instance 'character-input-stream :lisp-stream lisp-stream))
 389
 390 (defmethod open-stream-p ((stream character-input-stream))
 391   (open-stream-p (character-input-stream-lisp-stream stream)))
 392
 393 (defmethod close ((stream character-input-stream) &key abort)
 394   (close (character-input-stream-lisp-stream stream) :abort abort))
 395
 396 (defmethod input-stream-p ((stream character-input-stream))
 397   (input-stream-p (character-input-stream-lisp-stream stream)))
 398
 399 (defmethod output-stream-p ((stream character-input-stream))
 400   (output-stream-p (character-input-stream-lisp-stream stream)))
 401
 402 (defmethod stream-read-char ((stream character-input-stream))
 403   (read-char (character-input-stream-lisp-stream stream)))
 404
 405 (defmethod stream-unread-char ((stream character-input-stream) character)
 406   (unread-char character (character-input-stream-lisp-stream stream)))
 407
 408 (defmethod stream-read-char-no-hang ((stream character-input-stream))
 409   (read-char-no-hang (character-input-stream-lisp-stream stream) nil :eof))
 410
 411 #+nil
 412 (defmethod stream-peek-char ((stream character-input-stream))
 413   (peek-char nil (character-input-stream-lisp-stream stream) nil :eof))
 414
 415 #+nil
 416 (defmethod stream-listen ((stream character-input-stream))
 417   (listen (character-input-stream-lisp-stream stream)))
 418
 419 (defmethod stream-clear-input ((stream character-input-stream))
 420   (clear-input (character-input-stream-lisp-stream stream)))