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