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 ansi-stream))
  24   (ansi-stream-element-type stream))
  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 ansi-stream))
  37   (ansi-stream-open-stream-p stream))
  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 ansi-stream) &key abort)
  54   (ansi-stream-close stream abort))
  55
  56 (defmethod pcl-close ((stream fundamental-stream) &key abort)
  57   (declare (ignore abort))
  58   (setf (stream-open-p stream) nil)
  59   t)
  60
  61 (setf (fdefinition 'close) #'pcl-close)
  62 \f
  63 (let ()
  64   (fmakunbound 'input-stream-p)
  65
  66   (defgeneric input-stream-p (stream)
  67     #+sb-doc
  68     (:documentation "Can STREAM perform input operations?"))
  69
  70   (defmethod input-stream-p ((stream ansi-stream))
  71     (ansi-stream-input-stream-p stream))
  72
  73   (defmethod input-stream-p ((stream fundamental-input-stream))
  74     t))
  75 \f
  76 (let ()
  77   (fmakunbound 'output-stream-p)
  78
  79   (defgeneric output-stream-p (stream)
  80     #+sb-doc
  81     (:documentation "Can STREAM perform output operations?"))
  82
  83   (defmethod output-stream-p ((stream ansi-stream))
  84     (ansi-stream-output-stream-p stream))
  85
  86   (defmethod output-stream-p ((stream fundamental-output-stream))
  87     t))
  88 \f
  89 ;;; character input streams
  90 ;;;
  91 ;;; A character input stream can be created by defining a class that
  92 ;;; includes FUNDAMENTAL-CHARACTER-INPUT-STREAM and defining methods
  93 ;;; for the generic functions below.
  94
  95 (defgeneric stream-read-char (stream)
  96   #+sb-doc
  97   (:documentation
  98    "Read one character from the stream. Return either a
  99   character object, or the symbol :EOF if the stream is at end-of-file.
 100   Every subclass of FUNDAMENTAL-CHARACTER-INPUT-STREAM must define a
 101   method for this function."))
 102
 103 (defgeneric stream-unread-char (stream character)
 104   #+sb-doc
 105   (:documentation
 106    "Un-do the last call to STREAM-READ-CHAR, as in UNREAD-CHAR.
 107   Return NIL. Every subclass of FUNDAMENTAL-CHARACTER-INPUT-STREAM
 108   must define a method for this function."))
 109
 110 (defgeneric stream-read-char-no-hang (stream)
 111   #+sb-doc
 112   (:documentation
 113    "This is used to implement READ-CHAR-NO-HANG. It returns either a
 114   character, or NIL if no input is currently available, or :EOF if
 115   end-of-file is reached. The default method provided by
 116   FUNDAMENTAL-CHARACTER-INPUT-STREAM simply calls STREAM-READ-CHAR; this
 117   is sufficient for file streams, but interactive streams should define
 118   their own method."))
 119
 120 (defmethod stream-read-char-no-hang ((stream fundamental-character-input-stream))
 121   (stream-read-char stream))
 122
 123 (defgeneric stream-peek-char (stream)
 124   #+sb-doc
 125   (:documentation
 126    "This is used to implement PEEK-CHAR; this corresponds to PEEK-TYPE of NIL.
 127   It returns either a character or :EOF. The default method calls
 128   STREAM-READ-CHAR and STREAM-UNREAD-CHAR."))
 129
 130 (defmethod stream-peek-char ((stream fundamental-character-input-stream))
 131   (let ((char (stream-read-char stream)))
 132     (unless (eq char :eof)
 133       (stream-unread-char stream char))
 134     char))
 135
 136 (defgeneric stream-listen (stream)
 137   #+sb-doc
 138   (:documentation
 139    "This is used by LISTEN. It returns true or false. The default method uses
 140   STREAM-READ-CHAR-NO-HANG and STREAM-UNREAD-CHAR. Most streams should
 141   define their own method since it will usually be trivial and will
 142   always be more efficient than the default method."))
 143
 144 (defmethod stream-listen ((stream fundamental-character-input-stream))
 145   (let ((char (stream-read-char-no-hang stream)))
 146     (when (characterp char)
 147       (stream-unread-char stream char)
 148       t)))
 149
 150 (defgeneric stream-read-line (stream)
 151   #+sb-doc
 152   (:documentation
 153    "This is used by READ-LINE. A string is returned as the first value. The
 154   second value is true if the string was terminated by end-of-file
 155   instead of the end of a line. The default method uses repeated
 156   calls to STREAM-READ-CHAR."))
 157
 158 (defmethod stream-read-line ((stream fundamental-character-input-stream))
 159   (let ((res (make-string 80))
 160         (len 80)
 161         (index 0))
 162     (loop
 163      (let ((ch (stream-read-char stream)))
 164        (cond ((eq ch :eof)
 165               (return (values (shrink-vector res index) t)))
 166              (t
 167               (when (char= ch #\newline)
 168                 (return (values (shrink-vector res index) nil)))
 169               (when (= index len)
 170                 (setq len (* len 2))
 171                 (let ((new (make-string len)))
 172                   (replace new res)
 173                   (setq res new)))
 174               (setf (schar res index) ch)
 175               (incf index)))))))
 176
 177 (defgeneric stream-clear-input (stream)
 178   #+sb-doc
 179   (:documentation
 180    "This is like CL:CLEAR-INPUT, but for Gray streams, returning NIL.
 181   The default method does nothing."))
 182
 183 (defmethod stream-clear-input ((stream fundamental-character-input-stream))
 184   nil)
 185
 186 (defgeneric stream-read-sequence (stream seq &optional start end)
 187   (:documentation
 188    "This is like CL:READ-SEQUENCE, but for Gray streams."))
 189
 190 ;;; Destructively modify SEQ by reading elements from STREAM. That
 191 ;;; part of SEQ bounded by START and END is destructively modified by
 192 ;;; copying successive elements into it from STREAM. If the end of
 193 ;;; file for STREAM is reached before copying all elements of the
 194 ;;; subsequence, then the extra elements near the end of sequence are
 195 ;;; not updated, and the index of the next element is returned.
 196 (defun basic-io-type-stream-read-sequence (stream seq start end read-fun)
 197   (declare (type sequence seq)
 198            (type stream stream)
 199            (type index start)
 200            (type sequence-end end)
 201            (type function read-fun)
 202            (values index))
 203   (let ((end (or end (length seq))))
 204     (declare (type index end))
 205     (etypecase seq
 206       (list
 207         (do ((rem (nthcdr start seq) (rest rem))
 208              (i start (1+ i)))
 209             ((or (endp rem) (>= i end)) i)
 210           (declare (type list rem)
 211                    (type index i))
 212           (let ((el (funcall read-fun stream)))
 213             (when (eq el :eof)
 214               (return i))
 215             (setf (first rem) el))))
 216       (vector
 217         (with-array-data ((data seq) (offset-start start) (offset-end end))
 218           (do ((i offset-start (1+ i)))
 219               ((>= i offset-end) end)
 220             (declare (type index i))
 221             (let ((el (funcall read-fun stream)))
 222               (when (eq el :eof)
 223                 (return (+ start (- i offset-start))))
 224               (setf (aref data i) el))))))))
 225
 226 (defmethod stream-read-sequence ((stream fundamental-character-input-stream)
 227                                  (seq sequence)
 228                                  &optional (start 0) (end nil))
 229   (basic-io-type-stream-read-sequence stream seq start end
 230                                       #'stream-read-char))
 231
 232 (defmethod stream-read-sequence ((stream fundamental-binary-input-stream)
 233                                  (seq sequence)
 234                                  &optional (start 0) (end nil))
 235   (basic-io-type-stream-read-sequence stream seq start end
 236                                       #'stream-read-byte))
 237
 238 \f
 239 ;;; character output streams
 240 ;;;
 241 ;;; A character output stream can be created by defining a class that
 242 ;;; includes FUNDAMENTAL-CHARACTER-OUTPUT-STREAM and defining methods
 243 ;;; for the generic functions below.
 244
 245 (defgeneric stream-write-char (stream character)
 246   #+sb-doc
 247   (:documentation
 248    "Write CHARACTER to STREAM and return CHARACTER. Every
 249   subclass of FUNDAMENTAL-CHARACTER-OUTPUT-STREAM must have a method
 250   defined for this function."))
 251
 252 (defgeneric stream-line-column (stream)
 253   #+sb-doc
 254   (:documentation
 255    "Return the column number where the next character
 256   will be written, or NIL if that is not meaningful for this stream.
 257   The first column on a line is numbered 0. This function is used in
 258   the implementation of PPRINT and the FORMAT ~T directive. For every
 259   character output stream class that is defined, a method must be
 260   defined for this function, although it is permissible for it to
 261   always return NIL."))
 262
 263 (defmethod stream-line-column ((stream fundamental-character-output-stream))
 264    nil)
 265
 266 ;;; STREAM-LINE-LENGTH is a CMU CL extension to Gray streams.
 267 ;;; FIXME: Should we support it? Probably not..
 268 (defgeneric stream-line-length (stream)
 269   #+sb-doc
 270   (:documentation "Return the stream line length or NIL."))
 271
 272 (defmethod stream-line-length ((stream fundamental-character-output-stream))
 273   nil)
 274
 275 (defgeneric stream-start-line-p (stream)
 276   #+sb-doc
 277   (:documentation
 278    "Is STREAM known to be positioned at the beginning of a line?
 279   It is permissible for an implementation to always return
 280   NIL. This is used in the implementation of FRESH-LINE. Note that
 281   while a value of 0 from STREAM-LINE-COLUMN also indicates the
 282   beginning of a line, there are cases where STREAM-START-LINE-P can be
 283   meaningfully implemented although STREAM-LINE-COLUMN can't be. For
 284   example, for a window using variable-width characters, the column
 285   number isn't very meaningful, but the beginning of the line does have
 286   a clear meaning. The default method for STREAM-START-LINE-P on class
 287   FUNDAMENTAL-CHARACTER-OUTPUT-STREAM uses STREAM-LINE-COLUMN, so if
 288   that is defined to return NIL, then a method should be provided for
 289   either STREAM-START-LINE-P or STREAM-FRESH-LINE."))
 290
 291 (defmethod stream-start-line-p ((stream fundamental-character-output-stream))
 292   (eql (stream-line-column stream) 0))
 293
 294 (defgeneric stream-write-string (stream string &optional start end)
 295   #+sb-doc
 296   (:documentation
 297    "This is used by WRITE-STRING. It writes the string to the stream,
 298   optionally delimited by start and end, which default to 0 and NIL.
 299   The string argument is returned. The default method provided by
 300   FUNDAMENTAL-CHARACTER-OUTPUT-STREAM uses repeated calls to
 301   STREAM-WRITE-CHAR."))
 302
 303 (defmethod stream-write-string ((stream fundamental-character-output-stream)
 304                                 string &optional (start 0) end)
 305   (declare (string string)
 306            (fixnum start))
 307   (let ((end (or end (length string))))
 308     (declare (fixnum end))
 309     (do ((pos start (1+ pos)))
 310         ((>= pos end))
 311       (declare (type index pos))
 312       (stream-write-char stream (aref string pos))))
 313   string)
 314
 315 (defgeneric stream-terpri (stream)
 316   #+sb-doc
 317   (:documentation
 318    "Writes an end of line, as for TERPRI. Returns NIL. The default
 319   method does (STREAM-WRITE-CHAR stream #\NEWLINE)."))
 320
 321 (defmethod stream-terpri ((stream fundamental-character-output-stream))
 322   (stream-write-char stream #\Newline))
 323
 324 (defgeneric stream-fresh-line (stream)
 325   #+sb-doc
 326   (:documentation
 327    "Outputs a new line to the Stream if it is not positioned at the
 328   begining of a line. Returns T if it output a new line, nil
 329   otherwise. Used by FRESH-LINE. The default method uses
 330   STREAM-START-LINE-P and STREAM-TERPRI."))
 331
 332 (defmethod stream-fresh-line ((stream fundamental-character-output-stream))
 333   (unless (stream-start-line-p stream)
 334     (stream-terpri stream)
 335     t))
 336
 337 (defgeneric stream-finish-output (stream)
 338   #+sb-doc
 339   (:documentation
 340    "Attempts to ensure that all output sent to the Stream has reached
 341   its destination, and only then returns false. Implements
 342   FINISH-OUTPUT. The default method does nothing."))
 343
 344 (defmethod stream-finish-output ((stream fundamental-output-stream))
 345   nil)
 346
 347 (defgeneric stream-force-output (stream)
 348   #+sb-doc
 349   (:documentation
 350    "Attempts to force any buffered output to be sent. Implements
 351   FORCE-OUTPUT. The default method does nothing."))
 352
 353 (defmethod stream-force-output ((stream fundamental-output-stream))
 354   nil)
 355
 356 (defgeneric stream-clear-output (stream)
 357   #+sb-doc
 358   (:documentation
 359    "This is like CL:CLEAR-OUTPUT, but for Gray streams: clear the given
 360   output STREAM. The default method does nothing."))
 361
 362 (defmethod stream-clear-output ((stream fundamental-output-stream))
 363   nil)
 364
 365 (defgeneric stream-advance-to-column (stream column)
 366   #+sb-doc
 367   (:documentation
 368    "Write enough blank space so that the next character will be
 369   written at the specified column. Returns true if the operation is
 370   successful, or NIL if it is not supported for this stream. This is
 371   intended for use by by PPRINT and FORMAT ~T. The default method uses
 372   STREAM-LINE-COLUMN and repeated calls to STREAM-WRITE-CHAR with a
 373   #\SPACE character; it returns NIL if STREAM-LINE-COLUMN returns NIL."))
 374
 375 (defmethod stream-advance-to-column ((stream fundamental-character-output-stream)
 376                                      column)
 377   (let ((current-column (stream-line-column stream)))
 378     (when current-column
 379       (let ((fill (- column current-column)))
 380         (dotimes (i fill)
 381           (stream-write-char stream #\Space)))
 382       T)))
 383
 384 (defgeneric stream-write-sequence (stream seq &optional start end)
 385   (:documentation
 386    "This is like CL:WRITE-SEQUENCE, but for Gray streams."))
 387
 388 ;;; Write the elements of SEQ bounded by START and END to STREAM.
 389 (defun basic-io-type-stream-write-sequence (stream seq start end write-fun)
 390   (declare (type sequence seq)
 391            (type stream stream)
 392            (type index start)
 393            (type sequence-end end)
 394            (type function write-fun)
 395            (values sequence))
 396   (let ((end (or end (length seq))))
 397     (declare (type index start end))
 398     (etypecase seq
 399       (list
 400         (do ((rem (nthcdr start seq) (rest rem))
 401              (i start (1+ i)))
 402             ((or (endp rem) (>= i end)) seq)
 403           (declare (type list rem)
 404                    (type index i))
 405           (funcall write-fun stream (first rem))))
 406       (vector
 407         (do ((i start (1+ i)))
 408             ((>= i end) seq)
 409           (declare (type index i))
 410           (funcall write-fun stream (aref seq i)))))))
 411
 412 (defmethod stream-write-sequence ((stream fundamental-character-output-stream)
 413                                   (seq sequence)
 414                                   &optional (start 0) (end nil))
 415   (typecase seq
 416     (string
 417       (stream-write-string stream seq start end))
 418     (t
 419       (basic-io-type-stream-write-sequence stream seq start end
 420                                            #'stream-write-char))))
 421
 422 \f
 423 ;;; binary streams
 424 ;;;
 425 ;;; Binary streams can be created by defining a class that includes
 426 ;;; either FUNDAMENTAL-BINARY-INPUT-STREAM or
 427 ;;; FUNDAMENTAL-BINARY-OUTPUT-STREAM (or both) and defining a method
 428 ;;; for STREAM-ELEMENT-TYPE and for one or both of the following
 429 ;;; generic functions.
 430
 431 (defgeneric stream-read-byte (stream)
 432   #+sb-doc
 433   (:documentation
 434    "Used by READ-BYTE; returns either an integer, or the symbol :EOF
 435   if the stream is at end-of-file."))
 436
 437 (defgeneric stream-write-byte (stream integer)
 438   #+sb-doc
 439   (:documentation
 440    "Implements WRITE-BYTE; writes the integer to the stream and
 441   returns the integer as the result."))
 442
 443 ;; Provide a reasonable default for binary Gray streams.  We might be
 444 ;; able to do better by specializing on the sequence type, but at
 445 ;; least the behaviour is reasonable. --tony 2003/05/08.
 446 (defmethod stream-write-sequence ((stream fundamental-binary-output-stream)
 447                                   (seq sequence)
 448                                   &optional (start 0) (end nil))
 449   (basic-io-type-stream-write-sequence stream seq start end
 450                                        #'stream-write-byte))
 451
 452 \f
 453 ;;; This is not in the Gray stream proposal, so it is left here
 454 ;;; as example code.
 455 #|
 456 ;;; example character output stream encapsulating a lisp-stream
 457 (defun make-character-output-stream (lisp-stream)
 458   (declare (type lisp-stream lisp-stream))
 459   (make-instance 'character-output-stream :lisp-stream lisp-stream))
 460
 461 (defmethod open-stream-p ((stream character-output-stream))
 462   (open-stream-p (character-output-stream-lisp-stream stream)))
 463
 464 (defmethod close ((stream character-output-stream) &key abort)
 465   (close (character-output-stream-lisp-stream stream) :abort abort))
 466
 467 (defmethod input-stream-p ((stream character-output-stream))
 468   (input-stream-p (character-output-stream-lisp-stream stream)))
 469
 470 (defmethod output-stream-p ((stream character-output-stream))
 471   (output-stream-p (character-output-stream-lisp-stream stream)))
 472
 473 (defmethod stream-write-char ((stream character-output-stream) character)
 474   (write-char character (character-output-stream-lisp-stream stream)))
 475
 476 (defmethod stream-line-column ((stream character-output-stream))
 477   (charpos (character-output-stream-lisp-stream stream)))
 478
 479 (defmethod stream-line-length ((stream character-output-stream))
 480   (line-length (character-output-stream-lisp-stream stream)))
 481
 482 (defmethod stream-finish-output ((stream character-output-stream))
 483   (finish-output (character-output-stream-lisp-stream stream)))
 484
 485 (defmethod stream-force-output ((stream character-output-stream))
 486   (force-output (character-output-stream-lisp-stream stream)))
 487
 488 (defmethod stream-clear-output ((stream character-output-stream))
 489   (clear-output (character-output-stream-lisp-stream stream)))
 490 \f
 491 ;;; example character input stream encapsulating a lisp-stream
 492
 493 (defun make-character-input-stream (lisp-stream)
 494   (declare (type lisp-stream lisp-stream))
 495   (make-instance 'character-input-stream :lisp-stream lisp-stream))
 496
 497 (defmethod open-stream-p ((stream character-input-stream))
 498   (open-stream-p (character-input-stream-lisp-stream stream)))
 499
 500 (defmethod close ((stream character-input-stream) &key abort)
 501   (close (character-input-stream-lisp-stream stream) :abort abort))
 502
 503 (defmethod input-stream-p ((stream character-input-stream))
 504   (input-stream-p (character-input-stream-lisp-stream stream)))
 505
 506 (defmethod output-stream-p ((stream character-input-stream))
 507   (output-stream-p (character-input-stream-lisp-stream stream)))
 508
 509 (defmethod stream-read-char ((stream character-input-stream))
 510   (read-char (character-input-stream-lisp-stream stream) nil :eof))
 511
 512 (defmethod stream-unread-char ((stream character-input-stream) character)
 513   (unread-char character (character-input-stream-lisp-stream stream)))
 514
 515 (defmethod stream-read-char-no-hang ((stream character-input-stream))
 516   (read-char-no-hang (character-input-stream-lisp-stream stream) nil :eof))
 517
 518 #+nil
 519 (defmethod stream-peek-char ((stream character-input-stream))
 520   (peek-char nil (character-input-stream-lisp-stream stream) nil :eof))
 521
 522 #+nil
 523 (defmethod stream-listen ((stream character-input-stream))
 524   (listen (character-input-stream-lisp-stream stream)))
 525
 526 (defmethod stream-clear-input ((stream character-input-stream))
 527   (clear-input (character-input-stream-lisp-stream stream)))
 528 |#