contrib/sb-simple-streams/cl.lisp

   1 ;;; -*- lisp -*-
   2
   3 ;;; This code is in the public domain.
   4
   5 ;;; The cmucl implementation of simple-streams was done by Paul Foley,
   6 ;;; who placed the code in the public domain.  Sbcl port by Rudi
   7 ;;; Schlatte.
   8
   9 (in-package "SB-SIMPLE-STREAMS")
  10
  11
  12 ;;; Basic functionality for ansi-streams.  These are separate
  13 ;;; functions because they are called in places where we already know
  14 ;;; we operate on an ansi-stream (as opposed to a simple- or
  15 ;;; gray-stream, or the symbols t or nil), so we can evade typecase
  16 ;;; and (in|out)-synonym-of calls.
  17
  18 (declaim (inline %ansi-stream-read-byte %ansi-stream-read-char
  19                  %ansi-stream-unread-char %ansi-stream-read-line
  20                  %ansi-stream-read-sequence))
  21
  22 (defun %ansi-stream-read-byte (stream eof-error-p eof-value blocking)
  23   (declare (ignore blocking))
  24   #+nil
  25   (sb-kernel:ansi-stream-read-byte stream eof-error-p eof-value)
  26   (sb-int:prepare-for-fast-read-byte stream
  27     (prog1
  28         (sb-int:fast-read-byte eof-error-p eof-value t)
  29       (sb-int:done-with-fast-read-byte))))
  30
  31 (defun %ansi-stream-read-char (stream eof-error-p eof-value blocking)
  32   (declare (ignore blocking))
  33   #+nil
  34   (sb-kernel:ansi-stream-read-char stream eof-error-p eof-value)
  35   (sb-int:prepare-for-fast-read-char stream
  36     (prog1
  37         (sb-int:fast-read-char eof-error-p eof-value)
  38       (sb-int:done-with-fast-read-char))))
  39
  40 (defun %ansi-stream-unread-char (character stream)
  41   (let ((index (1- (sb-kernel:ansi-stream-in-index stream)))
  42         (buffer (sb-kernel:ansi-stream-in-buffer stream)))
  43     (declare (fixnum index))
  44     (when (minusp index) (error "nothing to unread"))
  45     (cond (buffer
  46            (setf (aref buffer index) (char-code character))
  47            (setf (sb-kernel:ansi-stream-in-index stream) index))
  48           (t
  49            (funcall (sb-kernel:ansi-stream-misc stream) stream
  50                     :unread character)))))
  51
  52 (defun %ansi-stream-read-line (stream eof-error-p eof-value)
  53   (sb-int:prepare-for-fast-read-char stream
  54     (let ((res (make-string 80))
  55           (len 80)
  56           (index 0))
  57       (loop
  58        (let ((ch (sb-int:fast-read-char nil nil)))
  59          (cond (ch
  60                 (when (char= ch #\newline)
  61                   (sb-int:done-with-fast-read-char)
  62                   (return (values (sb-kernel:shrink-vector res index) nil)))
  63                 (when (= index len)
  64                   (setq len (* len 2))
  65                   (let ((new (make-string len)))
  66                     (replace new res)
  67                     (setq res new)))
  68                 (setf (schar res index) ch)
  69                 (incf index))
  70                ((zerop index)
  71                 (sb-int:done-with-fast-read-char)
  72                 (return (values (sb-impl::eof-or-lose stream eof-error-p
  73                                                       eof-value)
  74                                 t)))
  75                ;; Since FAST-READ-CHAR already hit the eof char, we
  76                ;; shouldn't do another READ-CHAR.
  77                (t
  78                 (sb-int:done-with-fast-read-char)
  79                 (return (values (sb-kernel:shrink-vector res index) t)))))))))
  80
  81 (defun %ansi-stream-read-sequence (seq stream start %end)
  82   (declare (type sequence seq)
  83            (type sb-kernel:ansi-stream stream)
  84            (type sb-int:index start)
  85            (type sb-kernel:sequence-end %end)
  86            (values sb-int:index))
  87   (let ((end (or %end (length seq))))
  88     (declare (type sb-int:index end))
  89     (etypecase seq
  90       (list
  91        (let ((read-function
  92               (if (subtypep (stream-element-type stream) 'character)
  93                   #'%ansi-stream-read-char
  94                   #'%ansi-stream-read-byte)))
  95          (do ((rem (nthcdr start seq) (rest rem))
  96               (i start (1+ i)))
  97              ((or (endp rem) (>= i end)) i)
  98            (declare (type list rem)
  99                     (type sb-int:index i))
 100            (let ((el (funcall read-function stream nil :eof)))
 101              (when (eq el :eof)
 102                (return i))
 103              (setf (first rem) el)))))
 104       (vector
 105        (sb-kernel:with-array-data ((data seq) (offset-start start)
 106                                    (offset-end end))
 107          (typecase data
 108            ((or (simple-array (unsigned-byte 8) (*))
 109                 (simple-array (signed-byte 8) (*))
 110                 simple-string)
 111             (let* ((numbytes (- end start))
 112                    (bytes-read (sb-sys:read-n-bytes stream
 113                                                     data
 114                                                     offset-start
 115                                                     numbytes
 116                                                     nil)))
 117               (if (< bytes-read numbytes)
 118                   (+ start bytes-read)
 119                   end)))
 120            (t
 121             (let ((read-function
 122                    (if (subtypep (stream-element-type stream) 'character)
 123                        #'%ansi-stream-read-char
 124                        #'%ansi-stream-read-byte)))
 125               (do ((i offset-start (1+ i)))
 126                   ((>= i offset-end) end)
 127                 (declare (type sb-int:index i))
 128                 (let ((el (funcall read-function stream nil :eof)))
 129                   (when (eq el :eof)
 130                     (return (+ start (- i offset-start))))
 131                   (setf (aref data i) el)))))))))))
 132
 133
 134 (defun %ansi-stream-write-string (string stream start end)
 135   (declare (type string string)
 136            (type sb-kernel:ansi-stream stream)
 137            (type sb-int:index start end))
 138
 139   ;; Note that even though you might expect, based on the behavior of
 140   ;; things like AREF, that the correct upper bound here is
 141   ;; (ARRAY-DIMENSION STRING 0), the ANSI glossary definitions for
 142   ;; "bounding index" and "length" indicate that in this case (i.e.
 143   ;; for the ANSI-specified functions WRITE-STRING and WRITE-LINE
 144   ;; which are implemented in terms of this function), (LENGTH STRING)
 145   ;; is the required upper bound. A foolish consistency is the
 146   ;; hobgoblin of lesser languages..
 147   (unless (<= 0 start end (length string))
 148     (error "~@<bad bounding indices START=~W END=~W for ~2I~_~S~:>"
 149            start
 150            end
 151            string))
 152
 153   (if (sb-kernel:array-header-p string)
 154       (sb-kernel:with-array-data ((data string) (offset-start start)
 155                                   (offset-end end))
 156         (funcall (sb-kernel:ansi-stream-sout stream)
 157                  stream data offset-start offset-end))
 158       (funcall (sb-kernel:ansi-stream-sout stream) stream string start end))
 159   string)
 160
 161 (defun %ansi-stream-write-sequence (seq stream start %end)
 162   (declare (type sequence seq)
 163            (type sb-kernel:ansi-stream stream)
 164            (type sb-int:index start)
 165            (type sb-kernel:sequence-end %end)
 166            (values sequence))
 167   (let ((end (or %end (length seq))))
 168     (declare (type sb-int:index end))
 169     (etypecase seq
 170       (list
 171        (let ((write-function
 172               (if (subtypep (stream-element-type stream) 'character)
 173                   ;; TODO: Replace these with ansi-stream specific
 174                   ;; functions too.
 175                   #'write-char
 176                   #'write-byte)))
 177          (do ((rem (nthcdr start seq) (rest rem))
 178               (i start (1+ i)))
 179              ((or (endp rem) (>= i end)) seq)
 180            (declare (type list rem)
 181                     (type sb-int:index i))
 182            (funcall write-function (first rem) stream))))
 183       (string
 184        (%ansi-stream-write-string seq stream start end))
 185       (vector
 186        (let ((write-function
 187               (if (subtypep (stream-element-type stream) 'character)
 188                   ;; TODO: Replace these with ansi-stream specific
 189                   ;; functions too.
 190                   #'write-char
 191                   #'write-byte)))
 192          (do ((i start (1+ i)))
 193              ((>= i end) seq)
 194            (declare (type sb-int:index i))
 195            (funcall write-function (aref seq i) stream)))))))
 196
 197
 198 ;;;
 199 ;;; USER-LEVEL FUNCTIONS
 200 ;;;
 201
 202 (defmethod open-stream-p ((stream simple-stream))
 203   (any-stream-instance-flags stream :input :output))
 204
 205 (defmethod input-stream-p ((stream simple-stream))
 206   (any-stream-instance-flags stream :input))
 207
 208 (defmethod output-stream-p ((stream simple-stream))
 209   (any-stream-instance-flags stream :output))
 210
 211 (defmethod stream-element-type ((stream simple-stream))
 212   '(unsigned-byte 8))
 213
 214 (defun interactive-stream-p (stream)
 215   "Return true if Stream does I/O on a terminal or other interactive device."
 216   (declare (type stream stream))
 217   (etypecase stream
 218     (simple-stream
 219      (any-stream-instance-flags stream :interactive))
 220     (ansi-stream
 221      (funcall (sb-kernel:ansi-stream-misc stream) stream :interactive-p))
 222     (fundamental-stream nil)))
 223
 224 (defun (setf interactive-stream-p) (value stream)
 225   (etypecase stream
 226     (simple-stream
 227      (if value
 228          (add-stream-instance-flags stream :interactive)
 229          (remove-stream-instance-flags stream :interactive)))))
 230
 231 (defun stream-external-format (stream)
 232   "Returns Stream's external-format."
 233   (declare (type stream stream))
 234   (etypecase stream
 235     (simple-stream
 236      (with-stream-class (simple-stream)
 237        (sm external-format stream)))
 238     (ansi-stream
 239      :default)
 240     (fundamental-stream #| not defined on Gray streams? |#
 241      :default)))
 242
 243 (defgeneric default-open-class (name &optional element-type)
 244   (:documentation
 245    "Determine the stream class to be created when an attempt is made
 246 to open NAME.  This is a CMUCL- and SBCL-specific extension to Franz's
 247 simple-streams proposal.")
 248   (:method ((name t) &optional element-type)
 249      (declare (ignore element-type))
 250      nil)
 251   (:method ((name pathname) &optional element-type)
 252      (declare (ignore element-type))
 253      'sb-sys::file-stream)
 254   (:method ((name string) &optional element-type)
 255      (declare (ignore element-type))
 256      'sb-sys::file-stream)
 257   (:method ((name stream) &optional element-type)
 258      (declare (ignore element-type))
 259      (class-name (class-of name))))
 260
 261 (defun open (filename &rest options
 262              &key (direction :input)
 263              (element-type 'character element-type-given)
 264              if-exists if-does-not-exist
 265              (external-format :default)
 266              class mapped input-handle output-handle
 267              &allow-other-keys)
 268   "Return a stream which reads from or writes to Filename.
 269   Defined keywords:
 270    :direction - one of :input, :output, :io, or :probe
 271    :element-type - type of object to read or write, default BASE-CHAR
 272    :if-exists - one of :error, :new-version, :rename, :rename-and-delete,
 273                        :overwrite, :append, :supersede or NIL
 274    :if-does-not-exist - one of :error, :create or NIL
 275    :external-format - :default
 276   See the manual for details.
 277
 278   The following are simple-streams-specific additions:
 279    :class - class of stream object to be created
 280    :mapped - T to open a memory-mapped file
 281    :input-handle - a stream or Unix file descriptor to read from
 282    :output-handle - a stream or Unix file descriptor to write to
 283
 284   If Class is NIL or not supplied, DEFAULT-OPEN-CLASS is called on
 285   Filename to determine its value, thus Filename need not be an actual
 286   file name; it could be any arbitrary user-defined object for which a
 287   method of DEFAULT-OPEN-CLASS is applicable."
 288   (declare (ignore if-exists if-does-not-exist external-format
 289                    input-handle output-handle))
 290   (let ((klass class)
 291         (options (copy-list options))
 292         (filespec (if (stringp filename) (parse-filespec filename) filename)))
 293     (unless klass
 294       (setq klass (default-open-class filespec (if element-type-given
 295                                                    element-type
 296                                                    nil))))
 297     (unless klass
 298       (error 'type-error :datum filename
 299              :expected-type '(or pathname stream base-string)))
 300     (cond ((eql klass 'sb-sys::file-stream)
 301            (remf options :class)
 302            (remf options :mapped)
 303            ;; INPUT-HANDLE and OUTPUT-HANDLE must be fixnums or NIL.
 304            ;; If both are given, they must be the same -- or maybe
 305            ;; we should make a TWO-WAY-STREAM in that case??
 306            ;; If they are given, use SYS:MAKE-FD-STREAM to make the
 307            ;; stream.  Direction must be appropriate, too.
 308            (remf options :input-handle)
 309            (remf options :output-handle)
 310            (apply #'open-fd-stream filespec options))
 311           ((subtypep klass 'simple-stream)
 312            (when element-type-given
 313              (error "Can't create simple-streams with an element-type."))
 314            (when (and (eq klass 'file-simple-stream) mapped)
 315              (setq klass 'mapped-file-simple-stream)
 316              (setf (getf options :class) 'mapped-file-simple-stream))
 317            (when (subtypep klass 'file-simple-stream)
 318              (when (eq direction :probe)
 319                (setq klass 'probe-simple-stream)))
 320            (apply #'make-instance klass (list* :filename filespec options)))
 321           ((subtypep klass 'fundamental-stream)
 322            (error "Gray streams are not supported by OPEN."))
 323           (t
 324            (if class
 325                (error "Unable to open streams of class ~S." class)
 326                (error "DEFAULT-OPEN-CLASS method on ~S instances is broken!"
 327                       (class-name (class-of filespec))))))))
 328
 329 (defmacro %check-simple-stream (stream &optional direction)
 330   ;; Check that STREAM is valid and open in the appropriate direction.
 331   `(locally
 332      (declare (optimize (speed 3) (space 2) (safety 0) (debug 0)))
 333      (with-stream-class (simple-stream ,stream)
 334        (let ((flags (sm %flags ,stream)))
 335          (cond ((zerop (logand flags ,(%flags '(:simple))))
 336                 (error "~S is not properly initialized." stream))
 337                ((zerop (logand flags ,(%flags '(:input :output))))
 338                 (error "~S is closed." stream))
 339                ,@(when direction
 340                    `(((zerop (logand flags ,(%flags (list direction))))
 341                       (error ,(format nil "~~S is not an ~(~A~) stream."
 342                                       direction)
 343                              stream)))))))))
 344
 345 (declaim (inline sc-read-byte dc-read-byte))
 346 (defun sc-read-byte (stream eof-error-p eof-value blocking)
 347   (with-stream-class (single-channel-simple-stream stream)
 348     ;; @@1
 349     (let ((ptr (sm buffpos stream)))
 350       (when (>= ptr (sm buffer-ptr stream))
 351         (let ((bytes (device-read stream nil 0 nil blocking)))
 352           (declare (type fixnum bytes))
 353           (if (plusp bytes)
 354               (setf (sm buffer-ptr stream) bytes
 355                     ptr 0)
 356               (return-from sc-read-byte
 357                 (sb-impl::eof-or-lose stream eof-error-p eof-value)))))
 358       (setf (sm buffpos stream) (1+ ptr))
 359       (setf (sm last-char-read-size stream) 0)
 360       (bref (sm buffer stream) ptr))))
 361
 362 (defun dc-read-byte (stream eof-error-p eof-value blocking)
 363   (with-stream-class (dual-channel-simple-stream stream)
 364     (let ((ptr (sm buffpos stream)))
 365       (when (>= ptr (sm buffer-ptr stream))
 366         (let ((bytes (device-read stream nil 0 nil blocking)))
 367           (declare (type fixnum bytes))
 368           (if (plusp bytes)
 369               (setf (sm buffer-ptr stream) bytes
 370                     ptr 0)
 371               (return-from dc-read-byte
 372                 (sb-impl::eof-or-lose stream eof-error-p eof-value)))))
 373       (setf (sm buffpos stream) (1+ ptr))
 374       (setf (sm last-char-read-size stream) 0)
 375       (bref (sm buffer stream) ptr))))
 376
 377 (declaim (inline read-byte read-char read-char-no-hang unread-char))
 378
 379 (defun read-byte (stream &optional (eof-error-p t) eof-value)
 380   "Returns the next byte of the Stream."
 381   (let ((stream (sb-impl::in-synonym-of stream)))
 382     (etypecase stream
 383       (simple-stream
 384        (%check-simple-stream stream :input)
 385        (with-stream-class (simple-stream stream)
 386          (cond ((any-stream-instance-flags stream :eof)
 387                 (sb-impl::eof-or-lose stream eof-error-p eof-value))
 388                ((any-stream-instance-flags stream :string)
 389                 (with-stream-class (string-simple-stream stream)
 390                   (let ((encap (sm input-handle stream)))
 391                     (unless encap
 392                       (error "Can't read-byte on string streams"))
 393                     (prog1
 394                         (locally (declare (notinline read-byte))
 395                           (read-byte encap eof-error-p eof-value))
 396                       (setf (sm last-char-read-size stream) 0
 397                             (sm encapsulated-char-read-size stream) 0)))))
 398                ((any-stream-instance-flags stream :dual)
 399                 (dc-read-byte stream eof-error-p eof-value t))
 400                (t ;; single-channel-simple-stream
 401                 (sc-read-byte stream eof-error-p eof-value t)))))
 402       (ansi-stream
 403        (%ansi-stream-read-byte stream eof-error-p eof-value t))
 404       (fundamental-stream
 405        (let ((char (sb-gray:stream-read-byte stream)))
 406          (if (eq char :eof)
 407              (sb-impl::eof-or-lose stream eof-error-p eof-value)
 408              char))))))
 409
 410 (defun read-char (&optional (stream *standard-input*) (eof-error-p t)
 411                             eof-value recursive-p)
 412   "Inputs a character from Stream and returns it."
 413   (declare (ignore recursive-p))
 414   (let ((stream (sb-impl::in-synonym-of stream)))
 415     (etypecase stream
 416       (simple-stream
 417        (%check-simple-stream stream :input)
 418        (with-stream-class (simple-stream)
 419          (funcall-stm-handler j-read-char stream eof-error-p eof-value t)))
 420       (ansi-stream
 421        (%ansi-stream-read-char stream eof-error-p eof-value t))
 422       (fundamental-stream
 423        (let ((char (sb-gray:stream-read-char stream)))
 424          (if (eq char :eof)
 425              (sb-impl::eof-or-lose stream eof-error-p eof-value)
 426              char))))))
 427
 428 (defun read-char-no-hang (&optional (stream *standard-input*) (eof-error-p t)
 429                                     eof-value recursive-p)
 430   "Returns the next character from the Stream if one is availible, or nil."
 431   (declare (ignore recursive-p))
 432   (let ((stream (sb-impl::in-synonym-of stream)))
 433     (etypecase stream
 434       (simple-stream
 435        (%check-simple-stream stream :input)
 436        (with-stream-class (simple-stream)
 437          (funcall-stm-handler j-read-char stream eof-error-p eof-value nil)))
 438       (ansi-stream
 439        (if (funcall (sb-kernel:ansi-stream-misc stream) stream :listen)
 440            (%ansi-stream-read-char stream eof-error-p eof-value t)
 441            nil))
 442       (fundamental-stream
 443        (let ((char (sb-gray:stream-read-char-no-hang stream)))
 444          (if (eq char :eof)
 445              (sb-impl::eof-or-lose stream eof-error-p eof-value)
 446              char))))))
 447
 448 (defun unread-char (character &optional (stream *standard-input*))
 449   "Puts the Character back on the front of the input Stream."
 450   (let ((stream (sb-impl::in-synonym-of stream)))
 451     (etypecase stream
 452       (simple-stream
 453        (%check-simple-stream stream :input)
 454        (with-stream-class (simple-stream)
 455          (if (zerop (sm last-char-read-size stream))
 456              (error "Nothing to unread.")
 457              (funcall-stm-handler j-unread-char stream nil))))
 458       (ansi-stream
 459        (%ansi-stream-unread-char character stream))
 460       (fundamental-stream
 461        (sb-gray:stream-unread-char stream character))))
 462   nil)
 463
 464 (declaim (notinline read-byte read-char read-char-no-hang unread-char))
 465
 466 (defun peek-char (&optional (peek-type nil) (stream *standard-input*)
 467                             (eof-error-p t) eof-value recursive-p)
 468   "Peeks at the next character in the input Stream.  See manual for details."
 469   (declare (ignore recursive-p))
 470   (let ((stream (sb-impl::in-synonym-of stream)))
 471     (etypecase stream
 472       (simple-stream
 473        (%check-simple-stream stream :input)
 474        (with-stream-class (simple-stream)
 475          (let ((char (funcall-stm-handler j-read-char stream
 476                                           eof-error-p eof-value t)))
 477            (cond ((eq char eof-value) char)
 478                  ((characterp peek-type)
 479                   (do ((char char (funcall-stm-handler j-read-char stream
 480                                                        eof-error-p
 481                                                        eof-value t)))
 482                       ((or (eq char eof-value) (char= char peek-type))
 483                        (unless (eq char eof-value)
 484                          (funcall-stm-handler j-unread-char stream t))
 485                        char)))
 486                  ((eq peek-type t)
 487                   (do ((char char (funcall-stm-handler j-read-char stream
 488                                                        eof-error-p
 489                                                        eof-value t)))
 490                       ((or (eq char eof-value)
 491                            (not (sb-int:whitespace-char-p char)))
 492                        (unless (eq char eof-value)
 493                          (funcall-stm-handler j-unread-char stream t))
 494                        char)))
 495                  (t
 496                   (funcall-stm-handler j-unread-char stream t)
 497                   char)))))
 498       (ansi-stream
 499        (let ((char (%ansi-stream-read-char stream eof-error-p eof-value t)))
 500           (cond ((eq char eof-value) char)
 501                 ((characterp peek-type)
 502                  (do ((char char (%ansi-stream-read-char stream eof-error-p
 503                                                          eof-value t)))
 504                      ((or (eq char eof-value) (char= char peek-type))
 505                       (unless (eq char eof-value)
 506                         (%ansi-stream-unread-char char stream))
 507                       char)))
 508                 ((eq peek-type t)
 509                  (do ((char char (%ansi-stream-read-char stream eof-error-p
 510                                                          eof-value t)))
 511                      ((or (eq char eof-value)
 512                           (not (sb-int:whitespace-char-p char)))
 513                       (unless (eq char eof-value)
 514                         (%ansi-stream-unread-char char stream))
 515                       char)))
 516                 (t
 517                  (%ansi-stream-unread-char char stream)
 518                  char))))
 519       (fundamental-stream
 520        (cond ((characterp peek-type)
 521               (do ((char (sb-gray:stream-read-char stream)
 522                          (sb-gray:stream-read-char stream)))
 523                   ((or (eq char :eof) (char= char peek-type))
 524                    (cond ((eq char :eof)
 525                           (sb-impl::eof-or-lose stream eof-error-p eof-value))
 526                          (t
 527                           (sb-gray:stream-unread-char stream char)
 528                           char)))))
 529              ((eq peek-type t)
 530               (do ((char (sb-gray:stream-read-char stream)
 531                          (sb-gray:stream-read-char stream)))
 532                   ((or (eq char :eof) (not (sb-int:whitespace-char-p char)))
 533                    (cond ((eq char :eof)
 534                           (sb-impl::eof-or-lose stream eof-error-p eof-value))
 535                          (t
 536                           (sb-gray:stream-unread-char stream char)
 537                           char)))))
 538              (t
 539               (let ((char (sb-gray:stream-peek-char stream)))
 540                 (if (eq char :eof)
 541                     (sb-impl::eof-or-lose stream eof-error-p eof-value)
 542                     char))))))))
 543
 544 (defun listen (&optional (stream *standard-input*) (width 1))
 545   "Returns T if Width octets are available on the given Stream.  If Width
 546   is given as 'character, check for a character."
 547   ;; WIDTH is number of octets which must be available; any value
 548   ;; other than 1 is treated as 'character.
 549   (let ((stream (sb-impl::in-synonym-of stream)))
 550     (etypecase stream
 551       (simple-stream
 552        (%check-simple-stream stream :input)
 553        (with-stream-class (simple-stream stream)
 554          (if (not (eql width 1))
 555              (funcall-stm-handler j-listen stream)
 556              (or (< (sm buffpos stream) (sm buffer-ptr stream))
 557                  ;; Note: should try DEVICE-EXTEND for more on buffer streams
 558                  (when (>= (sm mode stream) 0) ;; device-connected
 559                    (incf (sm last-char-read-size stream))
 560                    (let ((ok (refill-buffer stream nil)))
 561                      (decf (sm last-char-read-size stream))
 562                      (plusp ok)))))))
 563       (ansi-stream
 564        (or (/= (the fixnum (sb-kernel:ansi-stream-in-index stream))
 565                sb-impl::+ansi-stream-in-buffer-length+)
 566             ;; Test for T explicitly since misc methods return :EOF sometimes.
 567             (eq (funcall (sb-kernel:ansi-stream-misc stream) stream :listen)
 568                 t)))
 569       (fundamental-stream
 570        (sb-gray:stream-listen stream)))))
 571
 572 (declaim (inline %simple-stream-read-line))
 573 (defun %simple-stream-read-line (stream eof-error-p eof-value)
 574   (declare (type simple-stream stream)
 575            (optimize (speed 3) (space 2) (safety 0) (debug 0)))
 576   (with-stream-class (simple-stream)
 577     (let* ((cbuf (make-string 80))      ; current buffer
 578            (bufs (list cbuf))           ; list of buffers
 579            (tail bufs)                  ; last cons of bufs list
 580            (index 0)                    ; current index in current buffer
 581            (total 0))                   ; total characters
 582       (declare (type simple-base-string cbuf)
 583                (type cons bufs tail)
 584                (type fixnum index total))
 585       (loop
 586         (multiple-value-bind (chars done)
 587             (funcall-stm-handler j-read-chars stream cbuf
 588                                  #\Newline index (length cbuf) t)
 589           (declare (type fixnum chars))
 590           (incf index chars)
 591           (incf total chars)
 592           (when (and (eq done :eof) (zerop index))
 593             (if eof-error-p
 594                 (error 'end-of-file :stream stream)
 595                 (return (values eof-value t))))
 596           (when done
 597             ;; If there's only one buffer in use, return it directly
 598             (when (null (cdr bufs))
 599               (return (values (sb-kernel:shrink-vector cbuf index)
 600                               (eq done :eof))))
 601             ;; If total fits in final buffer, use it
 602             #-ignore
 603             (when (<= total (length cbuf))
 604               (replace cbuf cbuf :start1 (- total index) :end2 index)
 605               (let ((idx 0))
 606                 (declare (type fixnum idx))
 607                 (dolist (buf bufs)
 608                   (declare (type simple-base-string buf))
 609                   (replace cbuf buf :start1 idx)
 610                   (incf idx (length buf))))
 611               (return (values (sb-kernel:shrink-vector cbuf index)
 612                               (eq done :eof))))
 613             ;; Allocate new string of appropriate length
 614             (let ((string (make-string total))
 615                   (index 0))
 616               (declare (type fixnum index))
 617               (dolist (buf bufs)
 618                 (declare (type simple-base-string buf))
 619                 (replace string buf :start1 index)
 620                 (incf index (length buf)))
 621               (return  (values string (eq done :eof)))))
 622           (when (>= index (length cbuf))
 623             (setf cbuf (make-string (the fixnum (* 2 index))))
 624             (setf index 0)
 625             (setf (cdr tail) (cons cbuf nil))
 626             (setf tail (cdr tail))))))))
 627
 628 (defun read-line (&optional (stream *standard-input*) (eof-error-p t)
 629                             eof-value recursive-p)
 630   "Returns a line of text read from the Stream as a string, discarding the
 631   newline character."
 632   (declare (ignore recursive-p))
 633   (let ((stream (sb-impl::in-synonym-of stream)))
 634     (etypecase stream
 635       (simple-stream
 636        (%check-simple-stream stream :input)
 637        (%simple-stream-read-line stream eof-error-p eof-value))
 638       (ansi-stream
 639        (%ansi-stream-read-line stream eof-error-p eof-value))
 640       (fundamental-stream
 641        (multiple-value-bind (string eof) (sb-gray:stream-read-line stream)
 642          (if (and eof (zerop (length string)))
 643              (values (sb-impl::eof-or-lose stream eof-error-p eof-value) t)
 644              (values string eof)))))))
 645
 646 (defun read-sequence (seq stream &key (start 0) (end nil) partial-fill)
 647   "Destructively modify SEQ by reading elements from STREAM.
 648   SEQ is bounded by START and END. SEQ is destructively modified by
 649   copying successive elements into it from STREAM. If the end of file
 650   for STREAM is reached before copying all elements of the subsequence,
 651   then the extra elements near the end of sequence are not updated, and
 652   the index of the next element is returned."
 653   (let ((stream (sb-impl::in-synonym-of stream))
 654         (end (or end (length seq))))
 655     (etypecase stream
 656       (simple-stream
 657        (with-stream-class (simple-stream stream)
 658          (%check-simple-stream stream :input)
 659          (etypecase seq
 660            (string
 661             (funcall-stm-handler j-read-chars stream seq nil start end
 662                                  (if partial-fill :bnb t)))
 663            ((or (simple-array (unsigned-byte 8) (*))
 664                 (simple-array (signed-byte 8) (*)))
 665             ;; TODO: "read-vector" equivalent, but blocking if
 666             ;; partial-fill is NIL
 667             (error "implement me")
 668             ))))
 669       (ansi-stream
 670        (%ansi-stream-read-sequence seq stream start end))
 671       (fundamental-stream
 672        (sb-gray:stream-read-sequence seq stream start end)))))
 673
 674 (defun clear-input (&optional (stream *standard-input*) buffer-only)
 675   "Clears any buffered input associated with the Stream."
 676   (let ((stream (sb-impl::in-synonym-of stream)))
 677     (etypecase stream
 678       (simple-stream
 679        (with-stream-class (simple-stream stream)
 680          (%check-simple-stream stream :input)
 681          (setf (sm buffpos stream) 0
 682                (sm buffer-ptr stream) 0
 683                (sm last-char-read-size stream) 0) ;; ??
 684          (device-clear-input stream buffer-only)))
 685       (ansi-stream
 686        (setf (sb-kernel:ansi-stream-in-index stream)
 687              sb-impl::+ansi-stream-in-buffer-length+)
 688        (funcall (sb-kernel:ansi-stream-misc stream) stream :clear-input))
 689       (fundamental-stream
 690        (sb-gray:stream-clear-input stream))))
 691   nil)
 692
 693 (defun write-byte (integer stream)
 694   "Outputs an octet to the Stream."
 695   (let ((stream (sb-impl::out-synonym-of stream)))
 696     (etypecase stream
 697       (simple-stream
 698        (%check-simple-stream stream :output)
 699        (with-stream-class (simple-stream stream)
 700          (cond ((any-stream-instance-flags stream :string)
 701                 (error "Can't write-byte on string streams"))
 702                ((any-stream-instance-flags stream :dual)
 703                 (let ((ptr (sm outpos stream)))
 704                   (when (>= ptr (sm max-out-pos stream))
 705                     (dc-flush-buffer stream t)
 706                     (setf ptr (1- (sm outpos stream))))
 707                   (setf (sm outpos stream) (1+ ptr))
 708                   (setf (bref (sm out-buffer stream) ptr) integer)))
 709                (t  ;; single-channel-simple-stream
 710                 (let ((ptr (sm buffpos stream)))
 711                   ;; FIXME: Shouldn't this be buf-len, not buffer-ptr?
 712                   (when (>= ptr (sm buffer-ptr stream))
 713                     (sc-flush-buffer stream t)
 714                     (setf ptr (1- (sm buffpos stream))))
 715                   (setf (sm buffpos stream) (1+ ptr))
 716                   (setf (bref (sm buffer stream) ptr) integer))))))
 717       (ansi-stream
 718        (funcall (sb-kernel:ansi-stream-bout stream) stream integer))
 719       (fundamental-stream
 720        (sb-gray:stream-write-byte stream integer))))
 721   integer)
 722
 723 (defun write-char (character &optional (stream *standard-output*))
 724   "Outputs the Character to the Stream."
 725   (let ((stream (sb-impl::out-synonym-of stream)))
 726     (etypecase stream
 727       (simple-stream
 728        (%check-simple-stream stream :output)
 729        (with-stream-class (simple-stream stream)
 730          (funcall-stm-handler-2 j-write-char character stream)))
 731       (ansi-stream
 732        (funcall (sb-kernel:ansi-stream-out stream) stream character))
 733       (fundamental-stream
 734        (sb-gray:stream-write-char stream character))))
 735   character)
 736
 737 (defun write-string (string &optional (stream *standard-output*)
 738                             &key (start 0) (end nil))
 739   "Outputs the String to the given Stream."
 740   (let ((stream (sb-impl::out-synonym-of stream))
 741         (end (or end (length string))))
 742     (etypecase stream
 743       (simple-stream
 744        (%check-simple-stream stream :output)
 745        (with-stream-class (simple-stream stream)
 746          (funcall-stm-handler-2 j-write-chars string stream start end))
 747        string)
 748       (ansi-stream
 749        (%ansi-stream-write-string string stream start end))
 750       (fundamental-stream
 751        (sb-gray:stream-write-string stream string start end)))))
 752
 753 (defun write-line (string &optional (stream *standard-output*)
 754                           &key (start 0) end)
 755   (declare (type string string))
 756   ;; FIXME: Why is there this difference between the treatments of the
 757   ;; STREAM argument in WRITE-STRING and WRITE-LINE?
 758   (let ((stream (sb-impl::out-synonym-of stream))
 759         (end (or end (length string))))
 760     (etypecase stream
 761       (simple-stream
 762        (%check-simple-stream stream :output)
 763        (with-stream-class (simple-stream stream)
 764          (funcall-stm-handler-2 j-write-chars string stream start end)
 765          (funcall-stm-handler-2 j-write-char #\Newline stream)))
 766       (ansi-stream
 767        (%ansi-stream-write-string string stream start end)
 768        (funcall (sb-kernel:ansi-stream-out stream) stream #\Newline))
 769       (fundamental-stream
 770        (sb-gray:stream-write-string stream string start end)
 771        (sb-gray:stream-terpri stream))))
 772   string)
 773
 774 (defun write-sequence (seq stream &key (start 0) (end nil))
 775   "Write the elements of SEQ bounded by START and END to STREAM."
 776   (let ((stream (sb-impl::out-synonym-of stream))
 777         (end (or end (length seq))))
 778     (etypecase stream
 779       (simple-stream
 780        (%check-simple-stream stream :output)
 781        (with-stream-class (simple-stream stream)
 782          (etypecase seq
 783            (string
 784             (funcall-stm-handler-2 j-write-chars seq stream start end))
 785            ((or (simple-array (unsigned-byte 8) (*))
 786                 (simple-array (signed-byte 8) (*)))
 787             ;; TODO: "write-vector" equivalent
 788             (error "implement me")
 789             ))))
 790       (ansi-stream
 791        (%ansi-stream-write-sequence seq stream start end))
 792       (fundamental-stream
 793        (sb-gray:stream-write-sequence seq stream start end)))))
 794
 795 (defun terpri (&optional (stream *standard-output*))
 796   "Outputs a new line to the Stream."
 797   (let ((stream (sb-impl::out-synonym-of stream)))
 798     (etypecase stream
 799       (simple-stream
 800        (%check-simple-stream stream :output)
 801        (with-stream-class (simple-stream stream)
 802          (funcall-stm-handler-2 j-write-char #\Newline stream)))
 803       (ansi-stream
 804        (funcall (sb-kernel:ansi-stream-out stream) stream #\Newline))
 805       (fundamental-stream
 806        (sb-gray:stream-terpri stream))))
 807   nil)
 808
 809 (defun fresh-line (&optional (stream *standard-output*))
 810   "Outputs a new line to the Stream if it is not positioned at the beginning of
 811    a line.  Returns T if it output a new line, nil otherwise."
 812   (let ((stream (sb-impl::out-synonym-of stream)))
 813     (etypecase stream
 814       (simple-stream
 815        (%check-simple-stream stream :output)
 816        (with-stream-class (simple-stream stream)
 817          (when (/= (or (sm charpos stream) 1) 0)
 818            (funcall-stm-handler-2 j-write-char #\Newline stream)
 819            t)))
 820       (ansi-stream
 821        (when (/= (or (sb-kernel:charpos stream) 1) 0)
 822          (funcall (sb-kernel:ansi-stream-out stream) stream #\Newline)
 823          t))
 824       (fundamental-stream
 825        (sb-gray:stream-fresh-line stream)))))
 826
 827 (defun finish-output (&optional (stream *standard-output*))
 828   "Attempts to ensure that all output sent to the Stream has reached its
 829    destination, and only then returns."
 830   (let ((stream (sb-impl::out-synonym-of stream)))
 831     (etypecase stream
 832       (simple-stream
 833        (%check-simple-stream stream :output)
 834        (with-stream-class (simple-stream stream)
 835          (cond ((any-stream-instance-flags stream :string)
 836                 #| nothing to do |#)
 837                ((any-stream-instance-flags stream :dual)
 838                 (dc-flush-buffer stream t))
 839                (t
 840                 (sc-flush-buffer stream t)))))
 841       (ansi-stream
 842        (funcall (sb-kernel:ansi-stream-misc stream) stream :finish-output))
 843       (fundamental-stream
 844        (sb-gray:stream-finish-output stream))))
 845   nil)
 846
 847 (defun force-output (&optional (stream *standard-output*))
 848   "Attempts to force any buffered output to be sent."
 849   (let ((stream (sb-impl::out-synonym-of stream)))
 850     (etypecase stream
 851       (simple-stream
 852        (%check-simple-stream stream :output)
 853        (with-stream-class (simple-stream stream)
 854          (cond ((any-stream-instance-flags stream :string)
 855                 #| nothing to do |#)
 856                ((any-stream-instance-flags stream :dual)
 857                 (dc-flush-buffer stream nil))
 858                (t
 859                 (sc-flush-buffer stream nil)))))
 860       (ansi-stream
 861        (funcall (sb-kernel:ansi-stream-misc stream) stream :force-output))
 862       (fundamental-stream
 863        (sb-gray:stream-force-output stream))))
 864   nil)
 865
 866 (defun clear-output (&optional (stream *standard-output*))
 867   "Clears the given output Stream."
 868   (let ((stream (sb-impl::out-synonym-of stream)))
 869     (etypecase stream
 870       (simple-stream
 871        (%check-simple-stream stream :output)
 872        (with-stream-class (simple-stream stream)
 873          #| clear output buffer |#
 874          (device-clear-output stream)))
 875       (ansi-stream
 876        (funcall (sb-kernel:ansi-stream-misc stream) stream :clear-output))
 877       (fundamental-stream
 878        (sb-gray:stream-clear-output stream))))
 879   nil)
 880
 881 (defun file-position (stream &optional position)
 882   "With one argument returns the current position within the file
 883    File-Stream is open to.  If the second argument is supplied, then
 884    this becomes the new file position.  The second argument may also
 885    be :start or :end for the start and end of the file, respectively."
 886   (etypecase stream
 887     (simple-stream
 888      (%check-simple-stream stream)
 889      (cond (position
 890             ;; set unread to zero
 891             ;; if position is within buffer, just move pointer; else
 892             ;; flush output, if necessary
 893             ;; set buffer pointer to 0, to force a read
 894             (setf (device-file-position stream) position))
 895            (t
 896             (let ((posn (device-file-position stream)))
 897               ;; adjust for buffer position
 898               )))
 899      #| TODO: implement me |#)
 900     (ansi-stream
 901      (cond (position
 902             (setf (sb-kernel:ansi-stream-in-index stream)
 903                   sb-impl::+ansi-stream-in-buffer-length+)
 904             (funcall (sb-kernel:ansi-stream-misc stream)
 905                      stream :file-position position))
 906            (t
 907             (let ((res (funcall (sb-kernel:ansi-stream-misc stream)
 908                                 stream :file-position nil)))
 909               (when res
 910                 (- res
 911                    (- sb-impl::+ansi-stream-in-buffer-length+
 912                       (sb-kernel:ansi-stream-in-index stream))))))))
 913     (fundamental-stream
 914      (error "file-position not supported on Gray streams."))))
 915
 916 (defun file-length (stream)
 917   "This function returns the length of the file that File-Stream is open to."
 918   (etypecase stream
 919     (simple-stream
 920      (%check-simple-stream stream)
 921      (device-file-length stream)
 922      #| implement me |#)
 923     (ansi-stream
 924      (sb-impl::stream-must-be-associated-with-file stream)
 925      (funcall (sb-kernel:ansi-stream-misc stream) stream :file-length))
 926     (fundamental-stream
 927      (error "file-length not supported on Gray streams."))))
 928
 929 (defun line-length (&optional (stream *standard-output*))
 930   "Returns the number of characters that will fit on a line of output on the
 931   given Stream, or Nil if that information is not available."
 932   (let ((stream (sb-impl::out-synonym-of stream)))
 933     (etypecase stream
 934       (simple-stream
 935        (%check-simple-stream stream :output)
 936        #| implement me |#)
 937       (ansi-stream
 938        (funcall (sb-kernel:ansi-stream-misc stream) stream :line-length))
 939       (fundamental-stream
 940        (sb-gray:stream-line-length stream)))))
 941
 942 (defun charpos (&optional (stream *standard-output*))
 943   "Returns the number of characters on the current line of output of the given
 944   Stream, or Nil if that information is not availible."
 945   (let ((stream (sb-impl::out-synonym-of stream)))
 946     (etypecase stream
 947       (simple-stream
 948        (%check-simple-stream stream :output)
 949        (with-stream-class (simple-stream) (sm charpos stream)))
 950       (ansi-stream
 951        (funcall (sb-kernel:ansi-stream-misc stream) stream :charpos))
 952       (fundamental-stream
 953        (sb-gray:stream-line-column stream)))))
 954
 955 (defun line-length (&optional (stream *standard-output*))
 956   "Returns the number of characters in a line of output of the given
 957   Stream, or Nil if that information is not availible."
 958   (let ((stream (sb-impl::out-synonym-of stream)))
 959     (etypecase stream
 960       (simple-stream
 961        (%check-simple-stream stream :output)
 962        ;; TODO (sat 2003-04-02): a way to specify a line length would
 963        ;; be good, I suppose.  Returning nil here means
 964        ;; sb-pretty::default-line-length is used.
 965        nil)
 966       (ansi-stream
 967        (funcall (sb-kernel:ansi-stream-misc stream) stream :line-length))
 968       (fundamental-stream
 969        (sb-gray:stream-line-length stream)))))
 970
 971 (defun wait-for-input-available (stream &optional timeout)
 972   "Waits for input to become available on the Stream and returns T.  If
 973   Timeout expires, Nil is returned."
 974   (let ((stream (sb-impl::in-synonym-of stream)))
 975     (etypecase stream
 976       (fixnum
 977        (sb-sys:wait-until-fd-usable stream :input timeout))
 978       (simple-stream
 979        (%check-simple-stream stream :input)
 980        (with-stream-class (simple-stream stream)
 981          (or (< (sm buffpos stream) (sm buffer-ptr stream))
 982              (wait-for-input-available (sm input-handle stream) timeout))))
 983       (two-way-stream
 984        (wait-for-input-available (two-way-stream-input-stream stream) timeout))
 985       (synonym-stream
 986        (wait-for-input-available (symbol-value (synonym-stream-symbol stream))
 987                                  timeout))
 988       (sb-sys::file-stream
 989        (or (< (sb-impl::fd-stream-in-index stream)
 990               (length (sb-impl::fd-stream-in-buffer stream)))
 991            (wait-for-input-available (sb-sys:fd-stream-fd stream) timeout))))))
 992
 993 ;;;
 994 ;;; SETUP
 995 ;;;
 996
 997 (defmethod shared-initialize :after ((instance simple-stream) slot-names
 998                                      &rest initargs &key &allow-other-keys)
 999   (declare (ignore slot-names))
1000   (unless (slot-boundp instance 'melded-stream)
1001     (setf (slot-value instance 'melded-stream) instance)
1002     (setf (slot-value instance 'melding-base) instance))
1003   (unless (device-open instance initargs)
1004     (device-close instance t)))
1005
1006 ;;; From the simple-streams documentation: "A generic function implies
1007 ;;; a specialization capability that does not exist for
1008 ;;; simple-streams; simple-stream specializations should be on
1009 ;;; device-close."  So don't do it.
1010 (defmethod close ((stream simple-stream) &key abort)
1011   (device-close stream abort))
1012
1013
1014 ;;; bugfix
1015 ;;; sat 2003-01-12: What is this for?
1016 #+nil
1017 (defun cl::stream-misc-dispatch (stream operation &optional arg1 arg2)
1018   (declare (type fundamental-stream stream) ;; this is a lie
1019            (ignore arg2))
1020   (case operation
1021     (:listen
1022      (ext:stream-listen stream))
1023     (:unread
1024      (ext:stream-unread-char stream arg1))
1025     (:close
1026      (close stream))
1027     (:clear-input
1028      (ext:stream-clear-input stream))
1029     (:force-output
1030      (ext:stream-force-output stream))
1031     (:finish-output
1032      (ext:stream-finish-output stream))
1033     (:element-type
1034      (stream-element-type stream))
1035     (:interactive-p
1036      (interactive-stream-p stream))
1037     (:line-length
1038      (ext:stream-line-length stream))
1039     (:charpos
1040      (ext:stream-line-column stream))
1041     (:file-length
1042      (file-length stream))
1043     (:file-position
1044      (file-position stream arg1))))