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
  14 ;;; See minor rant in call-next-method about this EVAL-WHEN.
  15 (eval-when (:compile-toplevel :load-toplevel :execute)
  16 (defclass stream-function (standard-generic-function) ()
  17   (:metaclass sb-mop:funcallable-standard-class)))
  18 (defmacro !def-stream-generic (name ll &rest rest)
  19   `(progn (fmakunbound ',name)
  20           (defgeneric ,name ,ll (:generic-function-class stream-function) ,@rest)
  21           (sb-pcl::!install-cross-compiled-methods ',name)))
  22 (defmethod no-applicable-method ((function stream-function) &rest args)
  23   (let ((stream (car args)))
  24     (if (streamp stream)
  25         (call-next-method)
  26         (error 'type-error :datum stream :expected-type 'stream))))
  27 \f
  28 (!def-stream-generic stream-element-type (stream)
  29   (:documentation
  30    "Return a type specifier for the kind of object returned by the
  31   STREAM. The class FUNDAMENTAL-CHARACTER-STREAM provides a default method
  32   which returns CHARACTER."))
  33
  34 (defmethod stream-element-type ((stream fundamental-character-stream))
  35   'character)
  36 \f
  37 (!def-stream-generic open-stream-p (stream)
  38   (:documentation
  39    "Return true if STREAM is not closed. A default method is provided
  40   by class FUNDAMENTAL-STREAM which returns true if CLOSE has not been
  41   called on the stream."))
  42
  43 (defmethod open-stream-p ((stream fundamental-stream))
  44   (stream-open-p stream))
  45 \f
  46 (!def-stream-generic close (stream &key abort)
  47   (:documentation
  48    "Close the given STREAM. No more I/O may be performed, but
  49   inquiries may still be made. If :ABORT is true, an attempt is made
  50   to clean up the side effects of having created the stream."))
  51
  52 (defmethod close ((stream fundamental-stream) &key abort)
  53   (declare (ignore abort))
  54   (setf (stream-open-p stream) nil)
  55   t)
  56 \f
  57 (progn
  58   (!def-stream-generic input-stream-p (stream)
  59     (:documentation "Can STREAM perform input operations?"))
  60
  61   (defmethod input-stream-p ((stream fundamental-stream))
  62     nil)
  63
  64   (defmethod input-stream-p ((stream fundamental-input-stream))
  65     t))
  66 \f
  67 (progn
  68   (!def-stream-generic interactive-stream-p (stream)
  69     (:documentation "Is STREAM an interactive stream?"))
  70
  71   (defmethod interactive-stream-p ((stream fundamental-stream))
  72     nil))
  73 \f
  74 (progn
  75   (!def-stream-generic output-stream-p (stream)
  76     (:documentation "Can STREAM perform output operations?"))
  77
  78   (defmethod output-stream-p ((stream fundamental-stream))
  79     nil)
  80
  81   (defmethod output-stream-p ((stream fundamental-output-stream))
  82     t))
  83 \f
  84 ;;; character input streams
  85 ;;;
  86 ;;; A character input stream can be created by defining a class that
  87 ;;; includes FUNDAMENTAL-CHARACTER-INPUT-STREAM and defining methods
  88 ;;; for the generic functions below.
  89
  90 (defgeneric stream-read-char (stream)
  91   (:documentation
  92    "Read one character from the stream. Return either a
  93   character object, or the symbol :EOF if the stream is at end-of-file.
  94   Every subclass of FUNDAMENTAL-CHARACTER-INPUT-STREAM must define a
  95   method for this function."))
  96
  97 (defgeneric stream-unread-char (stream character)
  98   (:documentation
  99    "Undo the last call to STREAM-READ-CHAR, as in UNREAD-CHAR.
 100   Return NIL. Every subclass of FUNDAMENTAL-CHARACTER-INPUT-STREAM
 101   must define a method for this function."))
 102
 103 (defgeneric stream-read-char-no-hang (stream)
 104   (:documentation
 105    "This is used to implement READ-CHAR-NO-HANG. It returns either a
 106   character, or NIL if no input is currently available, or :EOF if
 107   end-of-file is reached. The default method provided by
 108   FUNDAMENTAL-CHARACTER-INPUT-STREAM simply calls STREAM-READ-CHAR; this
 109   is sufficient for file streams, but interactive streams should define
 110   their own method."))
 111
 112 (defmethod stream-read-char-no-hang ((stream fundamental-character-input-stream))
 113   (stream-read-char stream))
 114
 115 (defgeneric stream-peek-char (stream)
 116   (:documentation
 117    "This is used to implement PEEK-CHAR; this corresponds to PEEK-TYPE of NIL.
 118   It returns either a character or :EOF. The default method calls
 119   STREAM-READ-CHAR and STREAM-UNREAD-CHAR."))
 120
 121 (defmethod stream-peek-char ((stream fundamental-character-input-stream))
 122   (let ((char (stream-read-char stream)))
 123     (unless (eq char :eof)
 124       (stream-unread-char stream char))
 125     char))
 126
 127 (defgeneric stream-listen (stream)
 128   (:documentation
 129    "This is used by LISTEN. It returns true or false. The default method uses
 130   STREAM-READ-CHAR-NO-HANG and STREAM-UNREAD-CHAR. Most streams should
 131   define their own method since it will usually be trivial and will
 132   always be more efficient than the default method."))
 133
 134 (defmethod stream-listen ((stream fundamental-character-input-stream))
 135   (let ((char (stream-read-char-no-hang stream)))
 136     (when (characterp char)
 137       (stream-unread-char stream char)
 138       t)))
 139
 140 (defgeneric stream-read-line (stream)
 141   (:documentation
 142    "This is used by READ-LINE. A string is returned as the first value. The
 143   second value is true if the string was terminated by end-of-file
 144   instead of the end of a line. The default method uses repeated
 145   calls to STREAM-READ-CHAR."))
 146
 147 (defmethod stream-read-line ((stream fundamental-character-input-stream))
 148   (let (eof)
 149     ;; This loop is simpler than the one in ansi-stream-read-line
 150     ;; because here we always return a string for the primary value,
 151     ;; and the caller tests for a 0-length string.
 152     ;; Writing to a string-output-stream adds negligible overhead
 153     ;; versus the method dispatch for each input character.
 154     (values (with-output-to-string (s)
 155               (let ((ouch (sb-kernel:ansi-stream-cout s)))
 156                 (loop (let ((ch (stream-read-char stream)))
 157                         (case ch
 158                           (#\newline (return))
 159                           (:eof (return (setq eof t)))
 160                           (t (funcall ouch s ch)))))))
 161             eof)))
 162
 163 (defgeneric stream-clear-input (stream)
 164   (:documentation
 165    "This is like CL:CLEAR-INPUT, but for Gray streams, returning NIL.
 166   The default method does nothing."))
 167
 168 (defmethod stream-clear-input ((stream fundamental-character-input-stream))
 169   nil)
 170
 171 (defgeneric stream-read-sequence (stream seq &optional start end)
 172   (:documentation
 173    "This is like CL:READ-SEQUENCE, but for Gray streams."))
 174
 175 (defmethod stream-read-sequence ((stream fundamental-character-input-stream)
 176                                  (seq sequence)
 177                                  &optional (start 0) (end nil))
 178   (sb-impl::read-sequence/read-function
 179    seq stream start end 'character
 180    (lambda (stream eof-error-p eof-value recursive-p)
 181      (aver (null eof-error-p))
 182      (aver (eq :eof eof-value))
 183      (aver (not recursive-p))
 184      (stream-read-char stream))
 185    #'sb-kernel:ill-bin))
 186
 187 (defmethod stream-read-sequence ((stream fundamental-binary-input-stream)
 188                                  (seq sequence)
 189                                  &optional (start 0) (end nil))
 190   (let ((stream-element-mode (sb-impl::stream-element-type-stream-element-mode
 191                               (stream-element-type stream))))
 192     (sb-impl::read-sequence/read-function
 193      seq stream start end stream-element-mode
 194      #'sb-kernel:ill-in
 195      (lambda (stream eof-error-p eof-value recursive-p)
 196        (aver (null eof-error-p))
 197        (aver (eq :eof eof-value))
 198        (aver (not recursive-p))
 199        (stream-read-byte stream)))))
 200
 201 \f
 202 ;;; character output streams
 203 ;;;
 204 ;;; A character output stream can be created by defining a class that
 205 ;;; includes FUNDAMENTAL-CHARACTER-OUTPUT-STREAM and defining methods
 206 ;;; for the generic functions below.
 207
 208 (defgeneric stream-write-char (stream character)
 209   (:documentation
 210    "Write CHARACTER to STREAM and return CHARACTER. Every
 211   subclass of FUNDAMENTAL-CHARACTER-OUTPUT-STREAM must have a method
 212   defined for this function."))
 213
 214 (defgeneric stream-line-column (stream)
 215   (:method ((stream sb-int:form-tracking-stream))
 216     (cdr (sb-int:line/col-from-charpos stream)))
 217   (:documentation
 218    "Return the column number where the next character
 219   will be written, or NIL if that is not meaningful for this stream.
 220   The first column on a line is numbered 0. This function is used in
 221   the implementation of PPRINT and the FORMAT ~T directive. For every
 222   character output stream class that is defined, a method must be
 223   defined for this function, although it is permissible for it to
 224   always return NIL."))
 225
 226 (defmethod stream-line-column ((stream fundamental-character-output-stream))
 227    nil)
 228
 229 ;;; STREAM-LINE-LENGTH is a CMU CL extension to Gray streams.
 230 ;;; FIXME: Should we support it? Probably not..
 231 (defgeneric stream-line-length (stream)
 232   (:documentation "Return the stream line length or NIL."))
 233
 234 (defmethod stream-line-length ((stream fundamental-character-output-stream))
 235   nil)
 236
 237 (defgeneric stream-start-line-p (stream)
 238   (:documentation
 239    "Is STREAM known to be positioned at the beginning of a line?
 240   It is permissible for an implementation to always return
 241   NIL. This is used in the implementation of FRESH-LINE. Note that
 242   while a value of 0 from STREAM-LINE-COLUMN also indicates the
 243   beginning of a line, there are cases where STREAM-START-LINE-P can be
 244   meaningfully implemented although STREAM-LINE-COLUMN can't be. For
 245   example, for a window using variable-width characters, the column
 246   number isn't very meaningful, but the beginning of the line does have
 247   a clear meaning. The default method for STREAM-START-LINE-P on class
 248   FUNDAMENTAL-CHARACTER-OUTPUT-STREAM uses STREAM-LINE-COLUMN, so if
 249   that is defined to return NIL, then a method should be provided for
 250   either STREAM-START-LINE-P or STREAM-FRESH-LINE."))
 251
 252 (defmethod stream-start-line-p ((stream fundamental-character-output-stream))
 253   (eql (stream-line-column stream) 0))
 254
 255 (defgeneric stream-write-string (stream string &optional start end)
 256   (:documentation
 257    "This is used by WRITE-STRING. It writes the string to the stream,
 258   optionally delimited by start and end, which default to 0 and NIL.
 259   The string argument is returned. The default method provided by
 260   FUNDAMENTAL-CHARACTER-OUTPUT-STREAM uses repeated calls to
 261   STREAM-WRITE-CHAR."))
 262
 263 (defmethod stream-write-string ((stream fundamental-character-output-stream)
 264                                 string &optional (start 0) end)
 265   (sb-kernel:with-array-data ((data string) (offset-start start) (offset-end end)
 266                               :check-fill-pointer t)
 267     (sb-impl::write-sequence/vector
 268      (data simple-string) stream offset-start offset-end #'stream-write-char))
 269   string)
 270
 271 (defgeneric stream-terpri (stream)
 272   (:documentation
 273    "Writes an end of line, as for TERPRI. Returns NIL. The default
 274   method does (STREAM-WRITE-CHAR stream #\NEWLINE)."))
 275
 276 (defmethod stream-terpri ((stream fundamental-character-output-stream))
 277   (stream-write-char stream #\Newline))
 278
 279 (defgeneric stream-fresh-line (stream)
 280   (:documentation
 281    "Outputs a new line to the Stream if it is not positioned at the
 282   beginning of a line. Returns T if it output a new line, nil
 283   otherwise. Used by FRESH-LINE. The default method uses
 284   STREAM-START-LINE-P and STREAM-TERPRI."))
 285
 286 (defmethod stream-fresh-line ((stream fundamental-character-output-stream))
 287   (unless (stream-start-line-p stream)
 288     (stream-terpri stream)
 289     t))
 290
 291 (defgeneric stream-finish-output (stream)
 292   (:documentation
 293    "Attempts to ensure that all output sent to the Stream has reached
 294   its destination, and only then returns false. Implements
 295   FINISH-OUTPUT. The default method does nothing."))
 296
 297 (defmethod stream-finish-output ((stream fundamental-output-stream))
 298   nil)
 299
 300 (defgeneric stream-force-output (stream)
 301   (:documentation
 302    "Attempts to force any buffered output to be sent. Implements
 303   FORCE-OUTPUT. The default method does nothing."))
 304
 305 (defmethod stream-force-output ((stream fundamental-output-stream))
 306   nil)
 307
 308 (defgeneric stream-clear-output (stream)
 309   (:documentation
 310    "This is like CL:CLEAR-OUTPUT, but for Gray streams: clear the given
 311   output STREAM. The default method does nothing."))
 312
 313 (defmethod stream-clear-output ((stream fundamental-output-stream))
 314   nil)
 315
 316 (defgeneric stream-advance-to-column (stream column)
 317   (:documentation
 318    "Write enough blank space so that the next character will be
 319   written at the specified column. Returns true if the operation is
 320   successful, or NIL if it is not supported for this stream. This is
 321   intended for use by by PPRINT and FORMAT ~T. The default method uses
 322   STREAM-LINE-COLUMN and repeated calls to STREAM-WRITE-CHAR with a
 323   #\SPACE character; it returns NIL if STREAM-LINE-COLUMN returns NIL."))
 324
 325 (defmethod stream-advance-to-column ((stream fundamental-character-output-stream)
 326                                      column)
 327   (let ((current-column (stream-line-column stream)))
 328     (when current-column
 329       (let ((fill (- column current-column)))
 330         (dotimes (i fill)
 331           (stream-write-char stream #\Space)))
 332       T)))
 333
 334 (defgeneric stream-write-sequence (stream seq &optional start end)
 335   (:documentation
 336    "This is like CL:WRITE-SEQUENCE, but for Gray streams."))
 337
 338 (defmethod stream-write-sequence ((stream fundamental-character-output-stream)
 339                                   (seq sequence)
 340                                   &optional (start 0) (end nil))
 341   (sb-impl::write-sequence/write-function
 342    seq stream start end 'character #'stream-write-char #'sb-kernel:ill-bout))
 343
 344 ;; Provide a reasonable default for binary Gray streams.  We might be
 345 ;; able to do better by specializing on the sequence type, but at
 346 ;; least the behaviour is reasonable. --tony 2003/05/08.
 347 (defmethod stream-write-sequence ((stream fundamental-binary-output-stream)
 348                                   (seq sequence)
 349                                   &optional (start 0) (end nil))
 350   (let ((stream-element-mode (sb-impl::stream-element-type-stream-element-mode
 351                               (stream-element-type stream))))
 352     (sb-impl::write-sequence/write-function
 353      seq stream start end stream-element-mode
 354      #'sb-kernel:ill-out #'stream-write-byte)))
 355
 356 \f
 357 ;;; binary streams
 358 ;;;
 359 ;;; Binary streams can be created by defining a class that includes
 360 ;;; either FUNDAMENTAL-BINARY-INPUT-STREAM or
 361 ;;; FUNDAMENTAL-BINARY-OUTPUT-STREAM (or both) and defining a method
 362 ;;; for STREAM-ELEMENT-TYPE and for one or both of the following
 363 ;;; generic functions.
 364
 365 (defgeneric stream-read-byte (stream)
 366   (:documentation
 367    "Used by READ-BYTE; returns either an integer, or the symbol :EOF
 368   if the stream is at end-of-file."))
 369
 370 (defgeneric stream-write-byte (stream integer)
 371   (:documentation
 372    "Implements WRITE-BYTE; writes the integer to the stream and
 373   returns the integer as the result."))
 374
 375 (defgeneric stream-file-position (stream &optional position-spec)
 376   (:documentation
 377    "Used by FILE-POSITION. Returns or changes the current position within STREAM."))
 378 (sb-pcl::!install-cross-compiled-methods 'stream-file-position)
 379
 380 (defmethod stream-file-position ((stream fundamental-stream) &optional position-spec)
 381   (declare (ignore stream position-spec))
 382   nil)
 383 \f
 384 ;;; This is not in the Gray stream proposal, so it is left here
 385 ;;; as example code.
 386 #|
 387 ;;; example character output stream encapsulating a lisp-stream
 388 (defun make-character-output-stream (lisp-stream)
 389   (declare (type lisp-stream lisp-stream))
 390   (make-instance 'character-output-stream :lisp-stream lisp-stream))
 391
 392 (defmethod open-stream-p ((stream character-output-stream))
 393   (open-stream-p (character-output-stream-lisp-stream stream)))
 394
 395 (defmethod close ((stream character-output-stream) &key abort)
 396   (close (character-output-stream-lisp-stream stream) :abort abort))
 397
 398 (defmethod input-stream-p ((stream character-output-stream))
 399   (input-stream-p (character-output-stream-lisp-stream stream)))
 400
 401 (defmethod output-stream-p ((stream character-output-stream))
 402   (output-stream-p (character-output-stream-lisp-stream stream)))
 403
 404 (defmethod stream-write-char ((stream character-output-stream) character)
 405   (write-char character (character-output-stream-lisp-stream stream)))
 406
 407 (defmethod stream-line-column ((stream character-output-stream))
 408   (charpos (character-output-stream-lisp-stream stream)))
 409
 410 (defmethod stream-line-length ((stream character-output-stream))
 411   (line-length (character-output-stream-lisp-stream stream)))
 412
 413 (defmethod stream-finish-output ((stream character-output-stream))
 414   (finish-output (character-output-stream-lisp-stream stream)))
 415
 416 (defmethod stream-force-output ((stream character-output-stream))
 417   (force-output (character-output-stream-lisp-stream stream)))
 418
 419 (defmethod stream-clear-output ((stream character-output-stream))
 420   (clear-output (character-output-stream-lisp-stream stream)))
 421 \f
 422 ;;; example character input stream encapsulating a lisp-stream
 423
 424 (defun make-character-input-stream (lisp-stream)
 425   (declare (type lisp-stream lisp-stream))
 426   (make-instance 'character-input-stream :lisp-stream lisp-stream))
 427
 428 (defmethod open-stream-p ((stream character-input-stream))
 429   (open-stream-p (character-input-stream-lisp-stream stream)))
 430
 431 (defmethod close ((stream character-input-stream) &key abort)
 432   (close (character-input-stream-lisp-stream stream) :abort abort))
 433
 434 (defmethod input-stream-p ((stream character-input-stream))
 435   (input-stream-p (character-input-stream-lisp-stream stream)))
 436
 437 (defmethod output-stream-p ((stream character-input-stream))
 438   (output-stream-p (character-input-stream-lisp-stream stream)))
 439
 440 (defmethod stream-read-char ((stream character-input-stream))
 441   (read-char (character-input-stream-lisp-stream stream) nil :eof))
 442
 443 (defmethod stream-unread-char ((stream character-input-stream) character)
 444   (unread-char character (character-input-stream-lisp-stream stream)))
 445
 446 (defmethod stream-read-char-no-hang ((stream character-input-stream))
 447   (read-char-no-hang (character-input-stream-lisp-stream stream) nil :eof))
 448
 449 #+nil
 450 (defmethod stream-peek-char ((stream character-input-stream))
 451   (peek-char nil (character-input-stream-lisp-stream stream) nil :eof))
 452
 453 #+nil
 454 (defmethod stream-listen ((stream character-input-stream))
 455   (listen (character-input-stream-lisp-stream stream)))
 456
 457 (defmethod stream-clear-input ((stream character-input-stream))
 458   (clear-input (character-input-stream-lisp-stream stream)))
 459 |#
 460
 461 #|
 462 A small change to INVOKE-FAST-METHOD-CALL/MORE was able to get an easy 10% speedup
 463  in STREAM-WRITE-STRING as shown below.
 464 ----
 465 (defclass sink-stream (fundamental-character-output-stream) ())
 466
 467 (defvar *callcount* 0)
 468 (defmethod sb-gray:stream-write-string ((stream sink-stream) string &optional start end)
 469   (declare (ignore start end))
 470   (incf *callcount*))
 471
 472 (defun time-this (&optional (n-iter 30000000))
 473   (declare (fixnum n-iter))
 474   (let ((stream (make-instance 'sink-stream)))
 475     (dotimes (i n-iter)
 476       (write-string "zook" stream :start 0 :end 4)))
 477   (format t "Calls: ~s~%" *callcount*))
 478 ----
 479
 480 Taking the best out of 3 runs each for old and new:
 481 perf stat ... --noinform --eval '(setq *evaluator-mode* :compile)' --load foo.lisp --eval '(time-this)' --quit
 482 Old:
 483        1.272560994 seconds time elapsed
 484 New:
 485        1.136901160 seconds time elapsed
 486
 487 Of course a dumb thing about this particular GF is that you probably never
 488 invoke it directly, but only through WRITE-STRING or WRITE-LINE
 489 in which case it always receives 4 args. So the small patch in src/pcl/boot
 490 handles that afficiently, even if it was a little bit ad-hoc.
 491 I don't think it was too ad-hoc though, because it's valid for any GF.
 492 |#