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