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