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 (fmakunbound 'input-stream-p)
  64
  65 (defgeneric input-stream-p (stream)
  66   #+sb-doc
  67   (:documentation "Can STREAM perform input operations?"))
  68
  69 (defmethod input-stream-p ((stream ansi-stream))
  70   (ansi-stream-input-stream-p stream))
  71
  72 (defmethod input-stream-p ((stream fundamental-input-stream))
  73   t)
  74 \f
  75 (fmakunbound 'output-stream-p)
  76
  77 (defgeneric output-stream-p (stream)
  78   #+sb-doc
  79   (:documentation "Can STREAM perform output operations?"))
  80
  81 (defmethod output-stream-p ((stream ansi-stream))
  82   (ansi-stream-output-stream-p stream))
  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    "Read one character from the stream. Return 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-do the last call to STREAM-READ-CHAR, as in UNREAD-CHAR.
 105   Return 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    "This is 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    "This is used by LISTEN. It 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    "This is 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    "This is like CL:CLEAR-INPUT, but for Gray streams, returning NIL.
 179   The default method does nothing."))
 180
 181 (defmethod stream-clear-input ((stream fundamental-character-input-stream))
 182   nil)
 183
 184 (defgeneric stream-read-sequence (stream seq &optional start end)
 185   (:documentation
 186    "This is like CL:READ-SEQUENCE, but for Gray streams."))
 187
 188 ;;; Destructively modify SEQ by reading elements from STREAM. That
 189 ;;; part of SEQ bounded by START and END is destructively modified by
 190 ;;; copying successive elements into it from STREAM. If the end of
 191 ;;; file for STREAM is reached before copying all elements of the
 192 ;;; subsequence, then the extra elements near the end of sequence are
 193 ;;; not updated, and the index of the next element is returned.
 194 (defun basic-io-type-stream-read-sequence (stream seq start end read-fun)
 195   (declare (type sequence seq)
 196            (type stream stream)
 197            (type index start)
 198            (type sequence-end end)
 199            (type function read-fun)
 200            (values index))
 201   (let ((end (or end (length seq))))
 202     (declare (type index end))
 203     (etypecase seq
 204       (list
 205         (do ((rem (nthcdr start seq) (rest rem))
 206              (i start (1+ i)))
 207             ((or (endp rem) (>= i end)) i)
 208           (declare (type list rem)
 209                    (type index i))
 210           (let ((el (funcall read-fun stream)))
 211             (when (eq el :eof)
 212               (return i))
 213             (setf (first rem) el))))
 214       (vector
 215         (with-array-data ((data seq) (offset-start start) (offset-end end))
 216           (do ((i offset-start (1+ i)))
 217               ((>= i offset-end) end)
 218             (declare (type index i))
 219             (let ((el (funcall read-fun stream)))
 220               (when (eq el :eof)
 221                 (return (+ start (- i offset-start))))
 222               (setf (aref data i) el))))))))
 223
 224 (defmethod stream-read-sequence ((stream fundamental-character-input-stream)
 225                                  (seq sequence)
 226                                  &optional (start 0) (end nil))
 227   (basic-io-type-stream-read-sequence stream seq start end
 228                                       #'stream-read-char))
 229 \f
 230 ;;; character output streams
 231 ;;;
 232 ;;; A character output stream can be created by defining a class that
 233 ;;; includes FUNDAMENTAL-CHARACTER-OUTPUT-STREAM and defining methods
 234 ;;; for the generic functions below.
 235
 236 (defgeneric stream-write-char (stream character)
 237   #+sb-doc
 238   (:documentation
 239    "Write CHARACTER to STREAM and return CHARACTER. Every
 240   subclass of FUNDAMENTAL-CHARACTER-OUTPUT-STREAM must have a method
 241   defined for this function."))
 242
 243 (defgeneric stream-line-column (stream)
 244   #+sb-doc
 245   (:documentation
 246    "Return the column number where the next character
 247   will be written, or NIL if that is not meaningful for this stream.
 248   The first column on a line is numbered 0. This function is used in
 249   the implementation of PPRINT and the FORMAT ~T directive. For every
 250   character output stream class that is defined, a method must be
 251   defined for this function, although it is permissible for it to
 252   always return NIL."))
 253
 254 (defmethod stream-line-column ((stream fundamental-character-output-stream))
 255    nil)
 256
 257 ;;; STREAM-LINE-LENGTH is a CMU CL extension to Gray streams.
 258 ;;; FIXME: Should we support it? Probably not..
 259 (defgeneric stream-line-length (stream)
 260   #+sb-doc
 261   (:documentation "Return the stream line length or NIL."))
 262
 263 (defmethod stream-line-length ((stream fundamental-character-output-stream))
 264   nil)
 265
 266 (defgeneric stream-start-line-p (stream)
 267   #+sb-doc
 268   (:documentation
 269    "Is STREAM known to be positioned at the beginning of a line?
 270   It is permissible for an implementation to always return
 271   NIL. This is used in the implementation of FRESH-LINE. Note that
 272   while a value of 0 from STREAM-LINE-COLUMN also indicates the
 273   beginning of a line, there are cases where STREAM-START-LINE-P can be
 274   meaningfully implemented although STREAM-LINE-COLUMN can't be. For
 275   example, for a window using variable-width characters, the column
 276   number isn't very meaningful, but the beginning of the line does have
 277   a clear meaning. The default method for STREAM-START-LINE-P on class
 278   FUNDAMENTAL-CHARACTER-OUTPUT-STREAM uses STREAM-LINE-COLUMN, so if
 279   that is defined to return NIL, then a method should be provided for
 280   either STREAM-START-LINE-P or STREAM-FRESH-LINE."))
 281
 282 (defmethod stream-start-line-p ((stream fundamental-character-output-stream))
 283   (eql (stream-line-column stream) 0))
 284
 285 (defgeneric stream-write-string (stream string &optional start end)
 286   #+sb-doc
 287   (:documentation
 288    "This is used by WRITE-STRING. It writes the string to the stream,
 289   optionally delimited by start and end, which default to 0 and NIL.
 290   The string argument is returned. The default method provided by
 291   FUNDAMENTAL-CHARACTER-OUTPUT-STREAM uses repeated calls to
 292   STREAM-WRITE-CHAR."))
 293
 294 (defmethod stream-write-string ((stream fundamental-character-output-stream)
 295                                 string &optional (start 0) end)
 296   (declare (string string)
 297            (fixnum start))
 298   (let ((end (or end (length string))))
 299     (declare (fixnum end))
 300     (do ((pos start (1+ pos)))
 301         ((>= pos end))
 302       (declare (type index pos))
 303       (stream-write-char stream (aref string pos))))
 304   string)
 305
 306 (defgeneric stream-terpri (stream)
 307   #+sb-doc
 308   (:documentation
 309    "Writes an end of line, as for TERPRI. Returns NIL. The default
 310   method does (STREAM-WRITE-CHAR stream #\NEWLINE)."))
 311
 312 (defmethod stream-terpri ((stream fundamental-character-output-stream))
 313   (stream-write-char stream #\Newline))
 314
 315 (defgeneric stream-fresh-line (stream)
 316   #+sb-doc
 317   (:documentation
 318    "Outputs a new line to the Stream if it is not positioned at the
 319   begining of a line. Returns T if it output a new line, nil
 320   otherwise. Used by FRESH-LINE. The default method uses
 321   STREAM-START-LINE-P and STREAM-TERPRI."))
 322
 323 (defmethod stream-fresh-line ((stream fundamental-character-output-stream))
 324   (unless (stream-start-line-p stream)
 325     (stream-terpri stream)
 326     t))
 327
 328 (defgeneric stream-finish-output (stream)
 329   #+sb-doc
 330   (:documentation
 331    "Attempts to ensure that all output sent to the Stream has reached
 332   its destination, and only then returns false. Implements
 333   FINISH-OUTPUT. The default method does nothing."))
 334
 335 (defmethod stream-finish-output ((stream fundamental-output-stream))
 336   nil)
 337
 338 (defgeneric stream-force-output (stream)
 339   #+sb-doc
 340   (:documentation
 341    "Attempts to force any buffered output to be sent. Implements
 342   FORCE-OUTPUT. The default method does nothing."))
 343
 344 (defmethod stream-force-output ((stream fundamental-output-stream))
 345   nil)
 346
 347 (defgeneric stream-clear-output (stream)
 348   #+sb-doc
 349   (:documentation
 350    "This is like CL:CLEAR-OUTPUT, but for Gray streams: clear the given
 351   output STREAM. The default method does nothing."))
 352
 353 (defmethod stream-clear-output ((stream fundamental-output-stream))
 354   nil)
 355
 356 (defgeneric stream-advance-to-column (stream column)
 357   #+sb-doc
 358   (:documentation
 359    "Write enough blank space so that the next character will be
 360   written at the specified column. Returns true if the operation is
 361   successful, or NIL if it is not supported for this stream. This is
 362   intended for use by by PPRINT and FORMAT ~T. The default method uses
 363   STREAM-LINE-COLUMN and repeated calls to STREAM-WRITE-CHAR with a
 364   #\SPACE character; it returns NIL if STREAM-LINE-COLUMN returns NIL."))
 365
 366 (defmethod stream-advance-to-column ((stream fundamental-character-output-stream)
 367                                      column)
 368   (let ((current-column (stream-line-column stream)))
 369     (when current-column
 370       (let ((fill (- column current-column)))
 371         (dotimes (i fill)
 372           (stream-write-char stream #\Space)))
 373       T)))
 374
 375 (defgeneric stream-write-sequence (stream seq &optional start end)
 376   (:documentation
 377    "This is like CL:WRITE-SEQUENCE, but for Gray streams."))
 378
 379 ;;; Write the elements of SEQ bounded by START and END to STREAM.
 380 (defun basic-io-type-stream-write-sequence (stream seq start end write-fun)
 381   (declare (type sequence seq)
 382            (type stream stream)
 383            (type index start)
 384            (type sequence-end end)
 385            (type function write-fun)
 386            (values sequence))
 387   (let ((end (or end (length seq))))
 388     (declare (type index start end))
 389     (etypecase seq
 390       (list
 391         (do ((rem (nthcdr start seq) (rest rem))
 392              (i start (1+ i)))
 393             ((or (endp rem) (>= i end)) seq)
 394           (declare (type list rem)
 395                    (type index i))
 396           (funcall write-fun stream (first rem))))
 397       (vector
 398         (do ((i start (1+ i)))
 399             ((>= i end) seq)
 400           (declare (type index i))
 401           (funcall write-fun stream (aref seq i)))))))
 402
 403 (defmethod stream-write-sequence ((stream fundamental-character-output-stream)
 404                                   (seq sequence)
 405                                   &optional (start 0) (end nil))
 406   (typecase seq
 407     (string
 408       (stream-write-string stream seq start end))
 409     (t
 410       (basic-io-type-stream-write-sequence stream seq start end
 411                                            #'stream-write-char))))
 412
 413 \f
 414 ;;; binary streams
 415 ;;;
 416 ;;; Binary streams can be created by defining a class that includes
 417 ;;; either FUNDAMENTAL-BINARY-INPUT-STREAM or
 418 ;;; FUNDAMENTAL-BINARY-OUTPUT-STREAM (or both) and defining a method
 419 ;;; for STREAM-ELEMENT-TYPE and for one or both of the following
 420 ;;; generic functions.
 421
 422 (defgeneric stream-read-byte (stream)
 423   #+sb-doc
 424   (:documentation
 425    "Used by READ-BYTE; returns either an integer, or the symbol :EOF
 426   if the stream is at end-of-file."))
 427
 428 (defgeneric stream-write-byte (stream integer)
 429   #+sb-doc
 430   (:documentation
 431    "Implements WRITE-BYTE; writes the integer to the stream and
 432   returns the integer as the result."))
 433 \f
 434 ;;; This is not in the Gray stream proposal, so it is left here
 435 ;;; as example code.
 436 #|
 437 ;;; example character output stream encapsulating a lisp-stream
 438 (defun make-character-output-stream (lisp-stream)
 439   (declare (type lisp-stream lisp-stream))
 440   (make-instance 'character-output-stream :lisp-stream lisp-stream))
 441
 442 (defmethod open-stream-p ((stream character-output-stream))
 443   (open-stream-p (character-output-stream-lisp-stream stream)))
 444
 445 (defmethod close ((stream character-output-stream) &key abort)
 446   (close (character-output-stream-lisp-stream stream) :abort abort))
 447
 448 (defmethod input-stream-p ((stream character-output-stream))
 449   (input-stream-p (character-output-stream-lisp-stream stream)))
 450
 451 (defmethod output-stream-p ((stream character-output-stream))
 452   (output-stream-p (character-output-stream-lisp-stream stream)))
 453
 454 (defmethod stream-write-char ((stream character-output-stream) character)
 455   (write-char character (character-output-stream-lisp-stream stream)))
 456
 457 (defmethod stream-line-column ((stream character-output-stream))
 458   (charpos (character-output-stream-lisp-stream stream)))
 459
 460 (defmethod stream-line-length ((stream character-output-stream))
 461   (line-length (character-output-stream-lisp-stream stream)))
 462
 463 (defmethod stream-finish-output ((stream character-output-stream))
 464   (finish-output (character-output-stream-lisp-stream stream)))
 465
 466 (defmethod stream-force-output ((stream character-output-stream))
 467   (force-output (character-output-stream-lisp-stream stream)))
 468
 469 (defmethod stream-clear-output ((stream character-output-stream))
 470   (clear-output (character-output-stream-lisp-stream stream)))
 471 \f
 472 ;;; example character input stream encapsulating a lisp-stream
 473
 474 (defun make-character-input-stream (lisp-stream)
 475   (declare (type lisp-stream lisp-stream))
 476   (make-instance 'character-input-stream :lisp-stream lisp-stream))
 477
 478 (defmethod open-stream-p ((stream character-input-stream))
 479   (open-stream-p (character-input-stream-lisp-stream stream)))
 480
 481 (defmethod close ((stream character-input-stream) &key abort)
 482   (close (character-input-stream-lisp-stream stream) :abort abort))
 483
 484 (defmethod input-stream-p ((stream character-input-stream))
 485   (input-stream-p (character-input-stream-lisp-stream stream)))
 486
 487 (defmethod output-stream-p ((stream character-input-stream))
 488   (output-stream-p (character-input-stream-lisp-stream stream)))
 489
 490 (defmethod stream-read-char ((stream character-input-stream))
 491   (read-char (character-input-stream-lisp-stream stream) nil :eof))
 492
 493 (defmethod stream-unread-char ((stream character-input-stream) character)
 494   (unread-char character (character-input-stream-lisp-stream stream)))
 495
 496 (defmethod stream-read-char-no-hang ((stream character-input-stream))
 497   (read-char-no-hang (character-input-stream-lisp-stream stream) nil :eof))
 498
 499 #+nil
 500 (defmethod stream-peek-char ((stream character-input-stream))
 501   (peek-char nil (character-input-stream-lisp-stream stream) nil :eof))
 502
 503 #+nil
 504 (defmethod stream-listen ((stream character-input-stream))
 505   (listen (character-input-stream-lisp-stream stream)))
 506
 507 (defmethod stream-clear-input ((stream character-input-stream))
 508   (clear-input (character-input-stream-lisp-stream stream)))
 509 |#