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