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