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