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