src/code/fd-stream.lisp

   1 ;;;; streams for UNIX file descriptors
   2
   3 ;;;; This software is part of the SBCL system. See the README file for
   4 ;;;; more information.
   5 ;;;;
   6 ;;;; This software is derived from the CMU CL system, which was
   7 ;;;; written at Carnegie Mellon University and released into the
   8 ;;;; public domain. The software is in the public domain and is
   9 ;;;; provided with absolutely no warranty. See the COPYING and CREDITS
  10 ;;;; files for more information.
  11
  12 (in-package "SB!IMPL")
  13
  14 ;;;; buffer manipulation routines
  15
  16 ;;; FIXME: Is it really good to maintain this pool separate from the
  17 ;;; GC and the C malloc logic?
  18 (defvar *available-buffers* ()
  19   #!+sb-doc
  20   "List of available buffers. Each buffer is an sap pointing to
  21   bytes-per-buffer of memory.")
  22
  23 #!+sb-thread
  24 (defvar *available-buffers-mutex* (sb!thread:make-mutex
  25                                    :name "lock for *AVAILABLE-BUFFERS*")
  26   #!+sb-doc
  27   "Mutex for access to *AVAILABLE-BUFFERS*.")
  28
  29 (defmacro with-available-buffers-lock ((&optional) &body body)
  30   ;; WITHOUT-INTERRUPTS because streams are low-level enough to be
  31   ;; async signal safe, and in particular a C-c that brings up the
  32   ;; debugger while holding the mutex would lose badly
  33   `(without-interrupts
  34     (sb!thread:with-mutex (*available-buffers-mutex*)
  35       ,@body)))
  36
  37 (defconstant bytes-per-buffer (* 4 1024)
  38   #!+sb-doc
  39   "Number of bytes per buffer.")
  40
  41 ;;; Return the next available buffer, creating one if necessary.
  42 #!-sb-fluid (declaim (inline next-available-buffer))
  43 (defun next-available-buffer ()
  44   (with-available-buffers-lock ()
  45     (if *available-buffers*
  46         (pop *available-buffers*)
  47         (allocate-system-memory bytes-per-buffer))))
  48 \f
  49 ;;;; the FD-STREAM structure
  50
  51 (defstruct (fd-stream
  52             (:constructor %make-fd-stream)
  53             (:conc-name fd-stream-)
  54             (:predicate fd-stream-p)
  55             (:include ansi-stream
  56                       (misc #'fd-stream-misc-routine))
  57             (:copier nil))
  58
  59   ;; the name of this stream
  60   (name nil)
  61   ;; the file this stream is for
  62   (file nil)
  63   ;; the backup file namestring for the old file, for :IF-EXISTS
  64   ;; :RENAME or :RENAME-AND-DELETE.
  65   (original nil :type (or simple-string null))
  66   (delete-original nil)       ; for :if-exists :rename-and-delete
  67   ;;; the number of bytes per element
  68   (element-size 1 :type index)
  69   ;; the type of element being transfered
  70   (element-type 'base-char)
  71   ;; the Unix file descriptor
  72   (fd -1 :type fixnum)
  73   ;; controls when the output buffer is flushed
  74   (buffering :full :type (member :full :line :none))
  75   ;; controls whether the input buffer must be cleared before output
  76   ;; (must be done for files, not for sockets, pipes and other data
  77   ;; sources where input and output aren't related).  non-NIL means
  78   ;; don't clear input buffer.
  79   (dual-channel-p nil)
  80   ;; character position (if known)
  81   (char-pos nil :type (or index null))
  82   ;; T if input is waiting on FD. :EOF if we hit EOF.
  83   (listen nil :type (member nil t :eof))
  84
  85   ;; the input buffer
  86   (unread nil)
  87   (ibuf-sap nil :type (or system-area-pointer null))
  88   (ibuf-length nil :type (or index null))
  89   (ibuf-head 0 :type index)
  90   (ibuf-tail 0 :type index)
  91
  92   ;; the output buffer
  93   (obuf-sap nil :type (or system-area-pointer null))
  94   (obuf-length nil :type (or index null))
  95   (obuf-tail 0 :type index)
  96
  97   ;; output flushed, but not written due to non-blocking io?
  98   (output-later nil)
  99   (handler nil)
 100   ;; timeout specified for this stream, or NIL if none
 101   (timeout nil :type (or index null))
 102   ;; pathname of the file this stream is opened to (returned by PATHNAME)
 103   (pathname nil :type (or pathname null))
 104   (external-format :default)
 105   (output-bytes #'ill-out :type function))
 106 (def!method print-object ((fd-stream fd-stream) stream)
 107   (declare (type stream stream))
 108   (print-unreadable-object (fd-stream stream :type t :identity t)
 109     (format stream "for ~S" (fd-stream-name fd-stream))))
 110 \f
 111 ;;;; output routines and related noise
 112
 113 (defvar *output-routines* ()
 114   #!+sb-doc
 115   "List of all available output routines. Each element is a list of the
 116   element-type output, the kind of buffering, the function name, and the number
 117   of bytes per element.")
 118
 119 ;;; common idioms for reporting low-level stream and file problems
 120 (defun simple-stream-perror (note-format stream errno)
 121   (error 'simple-stream-error
 122          :stream stream
 123          :format-control "~@<~?: ~2I~_~A~:>"
 124          :format-arguments (list note-format (list stream) (strerror errno))))
 125 (defun simple-file-perror (note-format pathname errno)
 126   (error 'simple-file-error
 127          :pathname pathname
 128          :format-control "~@<~?: ~2I~_~A~:>"
 129          :format-arguments
 130          (list note-format (list pathname) (strerror errno))))
 131
 132 (defun stream-decoding-error (stream octets)
 133   (error 'stream-decoding-error
 134          :stream stream
 135          ;; FIXME: dunno how to get at OCTETS currently, or even if
 136          ;; that's the right thing to report.
 137          :octets octets))
 138 (defun stream-encoding-error (stream code)
 139   (error 'stream-encoding-error
 140          :stream stream
 141          :code code))
 142
 143 (defun c-string-encoding-error (external-format code)
 144   (error 'c-string-encoding-error
 145          :external-format external-format
 146          :code code))
 147
 148 (defun c-string-decoding-error (external-format octets)
 149   (error 'c-string-decoding-error
 150          :external-format external-format
 151          :octets octets))
 152
 153 ;;; Returning true goes into end of file handling, false will enter another
 154 ;;; round of input buffer filling followed by re-entering character decode.
 155 (defun stream-decoding-error-and-handle (stream octet-count)
 156   (restart-case
 157       (stream-decoding-error stream
 158                              (let ((sap (fd-stream-ibuf-sap stream))
 159                                    (head (fd-stream-ibuf-head stream)))
 160                                (loop for i from 0 below octet-count
 161                                      collect (sap-ref-8 sap (+ head i)))))
 162     (attempt-resync ()
 163       :report (lambda (stream)
 164                 (format stream
 165                         "~@<Attempt to resync the stream at a character ~
 166                         character boundary and continue.~@:>"))
 167       (fd-stream-resync stream)
 168       nil)
 169     (force-end-of-file ()
 170       :report (lambda (stream)
 171                 (format stream "~@<Force an end of file.~@:>"))
 172       t)))
 173
 174 (defun stream-encoding-error-and-handle (stream code)
 175   (restart-case
 176       (stream-encoding-error stream code)
 177     (output-nothing ()
 178       :report (lambda (stream)
 179                 (format stream "~@<Skip output of this character.~@:>"))
 180       (throw 'output-nothing nil))))
 181
 182 (defun external-format-encoding-error (stream code)
 183   (if (streamp stream)
 184     (stream-encoding-error-and-handle stream code)
 185     (c-string-encoding-error stream code)))
 186
 187 (defun external-format-decoding-error (stream octet-count)
 188   (if (streamp stream)
 189     (stream-decoding-error stream octet-count)
 190     (c-string-decoding-error stream octet-count)))
 191
 192 ;;; This is called by the server when we can write to the given file
 193 ;;; descriptor. Attempt to write the data again. If it worked, remove
 194 ;;; the data from the OUTPUT-LATER list. If it didn't work, something
 195 ;;; is wrong.
 196 (defun frob-output-later (stream)
 197   (let* ((stuff (pop (fd-stream-output-later stream)))
 198          (base (car stuff))
 199          (start (cadr stuff))
 200          (end (caddr stuff))
 201          (reuse-sap (cadddr stuff))
 202          (length (- end start)))
 203     (declare (type index start end length))
 204     (multiple-value-bind (count errno)
 205         (sb!unix:unix-write (fd-stream-fd stream)
 206                             base
 207                             start
 208                             length)
 209       (cond ((not count)
 210              (if #!-win32 (= errno sb!unix:ewouldblock) #!+win32 t #!-win32
 211                  (error "Write would have blocked, but SERVER told us to go.")
 212                  (simple-stream-perror "couldn't write to ~S" stream errno)))
 213             ((eql count length) ; Hot damn, it worked.
 214              (when reuse-sap
 215                (with-available-buffers-lock ()
 216                  (push base *available-buffers*))))
 217             ((not (null count)) ; sorta worked..
 218              (push (list base
 219                          (the index (+ start count))
 220                          end)
 221                    (fd-stream-output-later stream))))))
 222   (unless (fd-stream-output-later stream)
 223     (sb!sys:remove-fd-handler (fd-stream-handler stream))
 224     (setf (fd-stream-handler stream) nil)))
 225
 226 ;;; Arange to output the string when we can write on the file descriptor.
 227 (defun output-later (stream base start end reuse-sap)
 228   (cond ((null (fd-stream-output-later stream))
 229          (setf (fd-stream-output-later stream)
 230                (list (list base start end reuse-sap)))
 231          (setf (fd-stream-handler stream)
 232                (sb!sys:add-fd-handler (fd-stream-fd stream)
 233                                       :output
 234                                       (lambda (fd)
 235                                         (declare (ignore fd))
 236                                         (frob-output-later stream)))))
 237         (t
 238          (nconc (fd-stream-output-later stream)
 239                 (list (list base start end reuse-sap)))))
 240   (when reuse-sap
 241     (let ((new-buffer (next-available-buffer)))
 242       (setf (fd-stream-obuf-sap stream) new-buffer)
 243       (setf (fd-stream-obuf-length stream) bytes-per-buffer))))
 244
 245 ;;; Output the given noise. Check to see whether there are any pending
 246 ;;; writes. If so, just queue this one. Otherwise, try to write it. If
 247 ;;; this would block, queue it.
 248 (defun frob-output (stream base start end reuse-sap)
 249   (declare (type fd-stream stream)
 250            (type (or system-area-pointer (simple-array * (*))) base)
 251            (type index start end))
 252   (if (not (null (fd-stream-output-later stream))) ; something buffered.
 253       (progn
 254         (output-later stream base start end reuse-sap)
 255         ;; ### check to see whether any of this noise can be output
 256         )
 257       (let ((length (- end start)))
 258         (multiple-value-bind (count errno)
 259             (sb!unix:unix-write (fd-stream-fd stream) base start length)
 260           (cond ((not count)
 261                  (if #!-win32 (= errno sb!unix:ewouldblock) #!+win32 t #!-win32
 262                      (output-later stream base start end reuse-sap)
 263                      (simple-stream-perror "couldn't write to ~S"
 264                                            stream
 265                                            errno)))
 266                 ((not (eql count length))
 267                  (output-later stream base (the index (+ start count))
 268                                end reuse-sap)))))))
 269
 270 ;;; Flush any data in the output buffer.
 271 (defun flush-output-buffer (stream)
 272   (let ((length (fd-stream-obuf-tail stream)))
 273     (unless (= length 0)
 274       (frob-output stream (fd-stream-obuf-sap stream) 0 length t)
 275       (setf (fd-stream-obuf-tail stream) 0))))
 276
 277 (defmacro output-wrapper/variable-width ((stream size buffering restart)
 278                                          &body body)
 279   (let ((stream-var (gensym)))
 280     `(let ((,stream-var ,stream)
 281            (size ,size))
 282       ,(unless (eq (car buffering) :none)
 283          `(when (< (fd-stream-obuf-length ,stream-var)
 284                    (+ (fd-stream-obuf-tail ,stream-var)
 285                        size))
 286             (flush-output-buffer ,stream-var)))
 287       ,(unless (eq (car buffering) :none)
 288          `(when (and (not (fd-stream-dual-channel-p ,stream-var))
 289                      (> (fd-stream-ibuf-tail ,stream-var)
 290                         (fd-stream-ibuf-head ,stream-var)))
 291             (file-position ,stream-var (file-position ,stream-var))))
 292       ,(if restart
 293            `(catch 'output-nothing
 294               ,@body
 295               (incf (fd-stream-obuf-tail ,stream-var) size))
 296            `(progn
 297              ,@body
 298              (incf (fd-stream-obuf-tail ,stream-var) size)))
 299       ,(ecase (car buffering)
 300          (:none
 301           `(flush-output-buffer ,stream-var))
 302          (:line
 303           `(when (eq (char-code byte) (char-code #\Newline))
 304              (flush-output-buffer ,stream-var)))
 305          (:full))
 306     (values))))
 307
 308 (defmacro output-wrapper ((stream size buffering restart) &body body)
 309   (let ((stream-var (gensym)))
 310     `(let ((,stream-var ,stream))
 311       ,(unless (eq (car buffering) :none)
 312          `(when (< (fd-stream-obuf-length ,stream-var)
 313                    (+ (fd-stream-obuf-tail ,stream-var)
 314                        ,size))
 315             (flush-output-buffer ,stream-var)))
 316       ,(unless (eq (car buffering) :none)
 317          `(when (and (not (fd-stream-dual-channel-p ,stream-var))
 318                      (> (fd-stream-ibuf-tail ,stream-var)
 319                         (fd-stream-ibuf-head ,stream-var)))
 320             (file-position ,stream-var (file-position ,stream-var))))
 321       ,(if restart
 322            `(catch 'output-nothing
 323               ,@body
 324               (incf (fd-stream-obuf-tail ,stream-var) ,size))
 325            `(progn
 326              ,@body
 327              (incf (fd-stream-obuf-tail ,stream-var) ,size)))
 328       ,(ecase (car buffering)
 329          (:none
 330           `(flush-output-buffer ,stream-var))
 331          (:line
 332           `(when (eq (char-code byte) (char-code #\Newline))
 333              (flush-output-buffer ,stream-var)))
 334          (:full))
 335     (values))))
 336
 337 (defmacro def-output-routines/variable-width
 338     ((name-fmt size restart external-format &rest bufferings)
 339      &body body)
 340   (declare (optimize (speed 1)))
 341   (cons 'progn
 342         (mapcar
 343             (lambda (buffering)
 344               (let ((function
 345                      (intern (format nil name-fmt (string (car buffering))))))
 346                 `(progn
 347                    (defun ,function (stream byte)
 348                      (declare (ignorable byte))
 349                      (output-wrapper/variable-width (stream ,size ,buffering ,restart)
 350                        ,@body))
 351                    (setf *output-routines*
 352                          (nconc *output-routines*
 353                                 ',(mapcar
 354                                    (lambda (type)
 355                                      (list type
 356                                            (car buffering)
 357                                            function
 358                                            1
 359                                            external-format))
 360                                    (cdr buffering)))))))
 361             bufferings)))
 362
 363 ;;; Define output routines that output numbers SIZE bytes long for the
 364 ;;; given bufferings. Use BODY to do the actual output.
 365 (defmacro def-output-routines ((name-fmt size restart &rest bufferings)
 366                                &body body)
 367   (declare (optimize (speed 1)))
 368   (cons 'progn
 369         (mapcar
 370             (lambda (buffering)
 371               (let ((function
 372                      (intern (format nil name-fmt (string (car buffering))))))
 373                 `(progn
 374                    (defun ,function (stream byte)
 375                      (output-wrapper (stream ,size ,buffering ,restart)
 376                        ,@body))
 377                    (setf *output-routines*
 378                          (nconc *output-routines*
 379                                 ',(mapcar
 380                                    (lambda (type)
 381                                      (list type
 382                                            (car buffering)
 383                                            function
 384                                            size
 385                                            nil))
 386                                    (cdr buffering)))))))
 387             bufferings)))
 388
 389 ;;; FIXME: is this used anywhere any more?
 390 (def-output-routines ("OUTPUT-CHAR-~A-BUFFERED"
 391                       1
 392                       t
 393                       (:none character)
 394                       (:line character)
 395                       (:full character))
 396   (if (char= byte #\Newline)
 397       (setf (fd-stream-char-pos stream) 0)
 398       (incf (fd-stream-char-pos stream)))
 399   (setf (sap-ref-8 (fd-stream-obuf-sap stream) (fd-stream-obuf-tail stream))
 400         (char-code byte)))
 401
 402 (def-output-routines ("OUTPUT-UNSIGNED-BYTE-~A-BUFFERED"
 403                       1
 404                       nil
 405                       (:none (unsigned-byte 8))
 406                       (:full (unsigned-byte 8)))
 407   (setf (sap-ref-8 (fd-stream-obuf-sap stream) (fd-stream-obuf-tail stream))
 408         byte))
 409
 410 (def-output-routines ("OUTPUT-SIGNED-BYTE-~A-BUFFERED"
 411                       1
 412                       nil
 413                       (:none (signed-byte 8))
 414                       (:full (signed-byte 8)))
 415   (setf (signed-sap-ref-8 (fd-stream-obuf-sap stream)
 416                           (fd-stream-obuf-tail stream))
 417         byte))
 418
 419 (def-output-routines ("OUTPUT-UNSIGNED-SHORT-~A-BUFFERED"
 420                       2
 421                       nil
 422                       (:none (unsigned-byte 16))
 423                       (:full (unsigned-byte 16)))
 424   (setf (sap-ref-16 (fd-stream-obuf-sap stream) (fd-stream-obuf-tail stream))
 425         byte))
 426
 427 (def-output-routines ("OUTPUT-SIGNED-SHORT-~A-BUFFERED"
 428                       2
 429                       nil
 430                       (:none (signed-byte 16))
 431                       (:full (signed-byte 16)))
 432   (setf (signed-sap-ref-16 (fd-stream-obuf-sap stream)
 433                            (fd-stream-obuf-tail stream))
 434         byte))
 435
 436 (def-output-routines ("OUTPUT-UNSIGNED-LONG-~A-BUFFERED"
 437                       4
 438                       nil
 439                       (:none (unsigned-byte 32))
 440                       (:full (unsigned-byte 32)))
 441   (setf (sap-ref-32 (fd-stream-obuf-sap stream) (fd-stream-obuf-tail stream))
 442         byte))
 443
 444 (def-output-routines ("OUTPUT-SIGNED-LONG-~A-BUFFERED"
 445                       4
 446                       nil
 447                       (:none (signed-byte 32))
 448                       (:full (signed-byte 32)))
 449   (setf (signed-sap-ref-32 (fd-stream-obuf-sap stream)
 450                            (fd-stream-obuf-tail stream))
 451         byte))
 452
 453 #+#.(cl:if (cl:= sb!vm:n-word-bits 64) '(and) '(or))
 454 (progn
 455   (def-output-routines ("OUTPUT-UNSIGNED-LONG-LONG-~A-BUFFERED"
 456                         8
 457                         nil
 458                         (:none (unsigned-byte 64))
 459                         (:full (unsigned-byte 64)))
 460     (setf (sap-ref-64 (fd-stream-obuf-sap stream) (fd-stream-obuf-tail stream))
 461           byte))
 462   (def-output-routines ("OUTPUT-SIGNED-LONG-LONG-~A-BUFFERED"
 463                         8
 464                         nil
 465                         (:none (signed-byte 64))
 466                         (:full (signed-byte 64)))
 467     (setf (signed-sap-ref-64 (fd-stream-obuf-sap stream)
 468                              (fd-stream-obuf-tail stream))
 469           byte)))
 470
 471 ;;; Do the actual output. If there is space to buffer the string,
 472 ;;; buffer it. If the string would normally fit in the buffer, but
 473 ;;; doesn't because of other stuff in the buffer, flush the old noise
 474 ;;; out of the buffer and put the string in it. Otherwise we have a
 475 ;;; very long string, so just send it directly (after flushing the
 476 ;;; buffer, of course).
 477 (defun output-raw-bytes (fd-stream thing &optional start end)
 478   #!+sb-doc
 479   "Output THING to FD-STREAM. THING can be any kind of vector or a SAP. If
 480   THING is a SAP, END must be supplied (as length won't work)."
 481   (let ((start (or start 0))
 482         (end (or end (length (the (simple-array * (*)) thing)))))
 483     (declare (type index start end))
 484     (when (and (not (fd-stream-dual-channel-p fd-stream))
 485                (> (fd-stream-ibuf-tail fd-stream)
 486                   (fd-stream-ibuf-head fd-stream)))
 487       (file-position fd-stream (file-position fd-stream)))
 488     (let* ((len (fd-stream-obuf-length fd-stream))
 489            (tail (fd-stream-obuf-tail fd-stream))
 490            (space (- len tail))
 491            (bytes (- end start))
 492            (newtail (+ tail bytes)))
 493       (cond ((minusp bytes) ; error case
 494              (error ":END before :START!"))
 495             ((zerop bytes)) ; easy case
 496             ((<= bytes space)
 497              (if (system-area-pointer-p thing)
 498                  (system-area-ub8-copy thing start
 499                                        (fd-stream-obuf-sap fd-stream)
 500                                        tail
 501                                        bytes)
 502                  ;; FIXME: There should be some type checking somewhere to
 503                  ;; verify that THING here is a vector, not just <not a SAP>.
 504                  (copy-ub8-to-system-area thing start
 505                                           (fd-stream-obuf-sap fd-stream)
 506                                           tail
 507                                           bytes))
 508              (setf (fd-stream-obuf-tail fd-stream) newtail))
 509             ((<= bytes len)
 510              (flush-output-buffer fd-stream)
 511              (if (system-area-pointer-p thing)
 512                  (system-area-ub8-copy thing
 513                                        start
 514                                        (fd-stream-obuf-sap fd-stream)
 515                                        0
 516                                        bytes)
 517                  ;; FIXME: There should be some type checking somewhere to
 518                  ;; verify that THING here is a vector, not just <not a SAP>.
 519                  (copy-ub8-to-system-area thing
 520                                           start
 521                                           (fd-stream-obuf-sap fd-stream)
 522                                           0
 523                                           bytes))
 524              (setf (fd-stream-obuf-tail fd-stream) bytes))
 525             (t
 526              (flush-output-buffer fd-stream)
 527              (frob-output fd-stream thing start end nil))))))
 528
 529 ;;; the routine to use to output a string. If the stream is
 530 ;;; unbuffered, slam the string down the file descriptor, otherwise
 531 ;;; use OUTPUT-RAW-BYTES to buffer the string. Update charpos by
 532 ;;; checking to see where the last newline was.
 533 ;;;
 534 ;;; Note: some bozos (the FASL dumper) call write-string with things
 535 ;;; other than strings. Therefore, we must make sure we have a string
 536 ;;; before calling POSITION on it.
 537 ;;; KLUDGE: It would be better to fix the bozos instead of trying to
 538 ;;; cover for them here. -- WHN 20000203
 539 (defun fd-sout (stream thing start end)
 540   (let ((start (or start 0))
 541         (end (or end (length (the vector thing)))))
 542     (declare (fixnum start end))
 543     (if (stringp thing)
 544         (let ((last-newline
 545                (string-dispatch (simple-base-string
 546                                  #!+sb-unicode
 547                                  (simple-array character)
 548                                  string)
 549                    thing
 550                  (and (find #\newline thing :start start :end end)
 551                       ;; FIXME why do we need both calls?
 552                       ;; Is find faster forwards than
 553                       ;; position is backwards?
 554                       (position #\newline thing
 555                                 :from-end t
 556                                 :start start
 557                                 :end end)))))
 558           (if (and (typep thing 'base-string)
 559                    (eq (fd-stream-external-format stream) :latin-1))
 560               (ecase (fd-stream-buffering stream)
 561                 (:full
 562                  (output-raw-bytes stream thing start end))
 563                 (:line
 564                  (output-raw-bytes stream thing start end)
 565                  (when last-newline
 566                    (flush-output-buffer stream)))
 567                 (:none
 568                  (frob-output stream thing start end nil)))
 569               (ecase (fd-stream-buffering stream)
 570                 (:full (funcall (fd-stream-output-bytes stream)
 571                                 stream thing nil start end))
 572                 (:line (funcall (fd-stream-output-bytes stream)
 573                                 stream thing last-newline start end))
 574                 (:none (funcall (fd-stream-output-bytes stream)
 575                                 stream thing t start end))))
 576           (if last-newline
 577               (setf (fd-stream-char-pos stream)
 578                     (- end last-newline 1))
 579               (incf (fd-stream-char-pos stream)
 580                     (- end start))))
 581         (ecase (fd-stream-buffering stream)
 582           ((:line :full)
 583            (output-raw-bytes stream thing start end))
 584           (:none
 585            (frob-output stream thing start end nil))))))
 586
 587 (defvar *external-formats* ()
 588   #!+sb-doc
 589   "List of all available external formats. Each element is a list of the
 590   element-type, string input function name, character input function name,
 591   and string output function name.")
 592
 593 (defun get-external-format (external-format)
 594   (dolist (entry *external-formats*)
 595     (when (member external-format (first entry))
 596       (return entry))))
 597
 598 (defun get-external-format-function (external-format index)
 599   (let ((entry (get-external-format external-format)))
 600     (when entry (nth index entry))))
 601
 602 ;;; Find an output routine to use given the type and buffering. Return
 603 ;;; as multiple values the routine, the real type transfered, and the
 604 ;;; number of bytes per element.
 605 (defun pick-output-routine (type buffering &optional external-format)
 606   (when (subtypep type 'character)
 607     (let ((entry (get-external-format external-format)))
 608       (when entry
 609         (return-from pick-output-routine
 610           (values (symbol-function (nth (ecase buffering
 611                                           (:none 4)
 612                                           (:line 5)
 613                                           (:full 6))
 614                                         entry))
 615                   'character
 616                   1
 617                   (symbol-function (fourth entry))
 618                   (first (first entry)))))))
 619   (dolist (entry *output-routines*)
 620     (when (and (subtypep type (first entry))
 621                (eq buffering (second entry))
 622                (or (not (fifth entry))
 623                    (eq external-format (fifth entry))))
 624       (return-from pick-output-routine
 625         (values (symbol-function (third entry))
 626                 (first entry)
 627                 (fourth entry)))))
 628   ;; KLUDGE: dealing with the buffering here leads to excessive code
 629   ;; explosion.
 630   ;;
 631   ;; KLUDGE: also see comments in PICK-INPUT-ROUTINE
 632   (loop for i from 40 by 8 to 1024 ; ARB (KLUDGE)
 633         if (subtypep type `(unsigned-byte ,i))
 634         do (return-from pick-output-routine
 635              (values
 636               (ecase buffering
 637                 (:none
 638                  (lambda (stream byte)
 639                    (output-wrapper (stream (/ i 8) (:none) nil)
 640                      (loop for j from 0 below (/ i 8)
 641                            do (setf (sap-ref-8
 642                                      (fd-stream-obuf-sap stream)
 643                                      (+ j (fd-stream-obuf-tail stream)))
 644                                     (ldb (byte 8 (- i 8 (* j 8))) byte))))))
 645                 (:full
 646                  (lambda (stream byte)
 647                    (output-wrapper (stream (/ i 8) (:full) nil)
 648                      (loop for j from 0 below (/ i 8)
 649                            do (setf (sap-ref-8
 650                                      (fd-stream-obuf-sap stream)
 651                                      (+ j (fd-stream-obuf-tail stream)))
 652                                     (ldb (byte 8 (- i 8 (* j 8))) byte)))))))
 653               `(unsigned-byte ,i)
 654               (/ i 8))))
 655   (loop for i from 40 by 8 to 1024 ; ARB (KLUDGE)
 656         if (subtypep type `(signed-byte ,i))
 657         do (return-from pick-output-routine
 658              (values
 659               (ecase buffering
 660                 (:none
 661                  (lambda (stream byte)
 662                    (output-wrapper (stream (/ i 8) (:none) nil)
 663                      (loop for j from 0 below (/ i 8)
 664                            do (setf (sap-ref-8
 665                                      (fd-stream-obuf-sap stream)
 666                                      (+ j (fd-stream-obuf-tail stream)))
 667                                     (ldb (byte 8 (- i 8 (* j 8))) byte))))))
 668                 (:full
 669                  (lambda (stream byte)
 670                    (output-wrapper (stream (/ i 8) (:full) nil)
 671                      (loop for j from 0 below (/ i 8)
 672                            do (setf (sap-ref-8
 673                                      (fd-stream-obuf-sap stream)
 674                                      (+ j (fd-stream-obuf-tail stream)))
 675                                     (ldb (byte 8 (- i 8 (* j 8))) byte)))))))
 676               `(signed-byte ,i)
 677               (/ i 8)))))
 678 \f
 679 ;;;; input routines and related noise
 680
 681 ;;; a list of all available input routines. Each element is a list of
 682 ;;; the element-type input, the function name, and the number of bytes
 683 ;;; per element.
 684 (defvar *input-routines* ())
 685
 686 ;;; Return whether a primitive partial read operation on STREAM's FD
 687 ;;; would (probably) block.  Signal a `simple-stream-error' if the
 688 ;;; system call implementing this operation fails.
 689 ;;;
 690 ;;; It is "may" instead of "would" because "would" is not quite
 691 ;;; correct on win32.  However, none of the places that use it require
 692 ;;; further assurance than "may" versus "will definitely not".
 693 (defun sysread-may-block-p (stream)
 694   #+win32
 695   ;; This answers T at EOF on win32, I think.
 696   (not (sb!win32:fd-listen (fd-stream-fd stream)))
 697   #-win32
 698   (sb!unix:with-restarted-syscall (count errno)
 699     (sb!alien:with-alien ((read-fds (sb!alien:struct sb!unix:fd-set)))
 700       (sb!unix:fd-zero read-fds)
 701       (sb!unix:fd-set (fd-stream-fd stream) read-fds)
 702       (sb!unix:unix-fast-select (1+ (fd-stream-fd stream))
 703                                 (sb!alien:addr read-fds)
 704                                 nil nil 0 0))
 705     (case count
 706       ((1) nil)
 707       ((0) t)
 708       (otherwise
 709        (simple-stream-perror "couldn't check whether ~S is readable"
 710                              stream
 711                              errno)))))
 712
 713 ;;; Fill the input buffer, and return the number of bytes read. Throw
 714 ;;; to EOF-INPUT-CATCHER if the eof was reached. Drop into
 715 ;;; SYSTEM:SERVER if necessary.
 716 (defun refill-buffer/fd (stream)
 717   (let ((fd (fd-stream-fd stream))
 718         (ibuf-sap (fd-stream-ibuf-sap stream))
 719         (buflen (fd-stream-ibuf-length stream))
 720         (head (fd-stream-ibuf-head stream))
 721         (tail (fd-stream-ibuf-tail stream)))
 722     (declare (type index head tail))
 723     (unless (zerop head)
 724       (cond ((eql head tail)
 725              (setf head 0)
 726              (setf tail 0)
 727              (setf (fd-stream-ibuf-head stream) 0)
 728              (setf (fd-stream-ibuf-tail stream) 0))
 729             (t
 730              (decf tail head)
 731              (system-area-ub8-copy ibuf-sap head
 732                                    ibuf-sap 0 tail)
 733              (setf head 0)
 734              (setf (fd-stream-ibuf-head stream) 0)
 735              (setf (fd-stream-ibuf-tail stream) tail))))
 736     (setf (fd-stream-listen stream) nil)
 737     ;;This isn't quite the same on win32.  Then again, neither was
 738     ;;(not (sb!win32:fd-listen fd)), as was originally here.  See
 739     ;;comment in `sysread-may-block-p'.
 740     (when (sysread-may-block-p stream)
 741       (unless (sb!sys:wait-until-fd-usable
 742                fd :input (fd-stream-timeout stream))
 743         (error 'io-timeout :stream stream :direction :read)))
 744     (multiple-value-bind (count errno)
 745         (sb!unix:unix-read fd
 746                            (sb!sys:int-sap (+ (sb!sys:sap-int ibuf-sap) tail))
 747                            (- buflen tail))
 748       (cond ((null count)
 749              (if #!-win32 (eql errno sb!unix:ewouldblock) #!+win32 t #!-win32
 750                  (progn
 751                    (unless (sb!sys:wait-until-fd-usable
 752                             fd :input (fd-stream-timeout stream))
 753                      (error 'io-timeout :stream stream :direction :read))
 754                    (refill-buffer/fd stream))
 755                  (simple-stream-perror "couldn't read from ~S" stream errno)))
 756             ((zerop count)
 757              (setf (fd-stream-listen stream) :eof)
 758              (/show0 "THROWing EOF-INPUT-CATCHER")
 759              (throw 'eof-input-catcher nil))
 760             (t
 761              (incf (fd-stream-ibuf-tail stream) count)
 762              count)))))
 763
 764 ;;; Make sure there are at least BYTES number of bytes in the input
 765 ;;; buffer. Keep calling REFILL-BUFFER/FD until that condition is met.
 766 (defmacro input-at-least (stream bytes)
 767   (let ((stream-var (gensym))
 768         (bytes-var (gensym)))
 769     `(let ((,stream-var ,stream)
 770            (,bytes-var ,bytes))
 771        (loop
 772          (when (>= (- (fd-stream-ibuf-tail ,stream-var)
 773                       (fd-stream-ibuf-head ,stream-var))
 774                    ,bytes-var)
 775            (return))
 776          (refill-buffer/fd ,stream-var)))))
 777
 778 (defmacro input-wrapper/variable-width ((stream bytes eof-error eof-value)
 779                                         &body read-forms)
 780   (let ((stream-var (gensym))
 781         (retry-var (gensym))
 782         (element-var (gensym)))
 783     `(let ((,stream-var ,stream)
 784            (size nil))
 785        (if (fd-stream-unread ,stream-var)
 786            (prog1
 787                (fd-stream-unread ,stream-var)
 788              (setf (fd-stream-unread ,stream-var) nil)
 789              (setf (fd-stream-listen ,stream-var) nil))
 790            (let ((,element-var nil)
 791                  (decode-break-reason nil))
 792              (do ((,retry-var t))
 793                  ((not ,retry-var))
 794                (unless
 795                    (catch 'eof-input-catcher
 796                      (setf decode-break-reason
 797                            (block decode-break-reason
 798                              (input-at-least ,stream-var 1)
 799                              (let* ((byte (sap-ref-8 (fd-stream-ibuf-sap
 800                                                       ,stream-var)
 801                                                      (fd-stream-ibuf-head
 802                                                       ,stream-var))))
 803                                (declare (ignorable byte))
 804                                (setq size ,bytes)
 805                                (input-at-least ,stream-var size)
 806                                (setq ,element-var (locally ,@read-forms))
 807                                (setq ,retry-var nil))
 808                              nil))
 809                      (when decode-break-reason
 810                        (stream-decoding-error-and-handle stream
 811                                                          decode-break-reason))
 812                      t)
 813                  (let ((octet-count (- (fd-stream-ibuf-tail ,stream-var)
 814                                       (fd-stream-ibuf-head ,stream-var))))
 815                    (when (or (zerop octet-count)
 816                              (and (not ,element-var)
 817                                   (not decode-break-reason)
 818                                   (stream-decoding-error-and-handle
 819                                    stream octet-count)))
 820                      (setq ,retry-var nil)))))
 821              (cond (,element-var
 822                     (incf (fd-stream-ibuf-head ,stream-var) size)
 823                     ,element-var)
 824                    (t
 825                     (eof-or-lose ,stream-var ,eof-error ,eof-value))))))))
 826
 827 ;;; a macro to wrap around all input routines to handle EOF-ERROR noise
 828 (defmacro input-wrapper ((stream bytes eof-error eof-value) &body read-forms)
 829   (let ((stream-var (gensym))
 830         (element-var (gensym)))
 831     `(let ((,stream-var ,stream))
 832        (if (fd-stream-unread ,stream-var)
 833            (prog1
 834                (fd-stream-unread ,stream-var)
 835              (setf (fd-stream-unread ,stream-var) nil)
 836              (setf (fd-stream-listen ,stream-var) nil))
 837            (let ((,element-var
 838                   (catch 'eof-input-catcher
 839                     (input-at-least ,stream-var ,bytes)
 840                     (locally ,@read-forms))))
 841              (cond (,element-var
 842                     (incf (fd-stream-ibuf-head ,stream-var) ,bytes)
 843                     ,element-var)
 844                    (t
 845                     (eof-or-lose ,stream-var ,eof-error ,eof-value))))))))
 846
 847 (defmacro def-input-routine/variable-width (name
 848                                             (type external-format size sap head)
 849                                             &rest body)
 850   `(progn
 851      (defun ,name (stream eof-error eof-value)
 852        (input-wrapper/variable-width (stream ,size eof-error eof-value)
 853          (let ((,sap (fd-stream-ibuf-sap stream))
 854                (,head (fd-stream-ibuf-head stream)))
 855            ,@body)))
 856      (setf *input-routines*
 857            (nconc *input-routines*
 858                   (list (list ',type ',name 1 ',external-format))))))
 859
 860 (defmacro def-input-routine (name
 861                              (type size sap head)
 862                              &rest body)
 863   `(progn
 864      (defun ,name (stream eof-error eof-value)
 865        (input-wrapper (stream ,size eof-error eof-value)
 866          (let ((,sap (fd-stream-ibuf-sap stream))
 867                (,head (fd-stream-ibuf-head stream)))
 868            ,@body)))
 869      (setf *input-routines*
 870            (nconc *input-routines*
 871                   (list (list ',type ',name ',size nil))))))
 872
 873 ;;; STREAM-IN routine for reading a string char
 874 (def-input-routine input-character
 875                    (character 1 sap head)
 876   (code-char (sap-ref-8 sap head)))
 877
 878 ;;; STREAM-IN routine for reading an unsigned 8 bit number
 879 (def-input-routine input-unsigned-8bit-byte
 880                    ((unsigned-byte 8) 1 sap head)
 881   (sap-ref-8 sap head))
 882
 883 ;;; STREAM-IN routine for reading a signed 8 bit number
 884 (def-input-routine input-signed-8bit-number
 885                    ((signed-byte 8) 1 sap head)
 886   (signed-sap-ref-8 sap head))
 887
 888 ;;; STREAM-IN routine for reading an unsigned 16 bit number
 889 (def-input-routine input-unsigned-16bit-byte
 890                    ((unsigned-byte 16) 2 sap head)
 891   (sap-ref-16 sap head))
 892
 893 ;;; STREAM-IN routine for reading a signed 16 bit number
 894 (def-input-routine input-signed-16bit-byte
 895                    ((signed-byte 16) 2 sap head)
 896   (signed-sap-ref-16 sap head))
 897
 898 ;;; STREAM-IN routine for reading a unsigned 32 bit number
 899 (def-input-routine input-unsigned-32bit-byte
 900                    ((unsigned-byte 32) 4 sap head)
 901   (sap-ref-32 sap head))
 902
 903 ;;; STREAM-IN routine for reading a signed 32 bit number
 904 (def-input-routine input-signed-32bit-byte
 905                    ((signed-byte 32) 4 sap head)
 906   (signed-sap-ref-32 sap head))
 907
 908 #+#.(cl:if (cl:= sb!vm:n-word-bits 64) '(and) '(or))
 909 (progn
 910   (def-input-routine input-unsigned-64bit-byte
 911       ((unsigned-byte 64) 8 sap head)
 912     (sap-ref-64 sap head))
 913   (def-input-routine input-signed-64bit-byte
 914       ((signed-byte 64) 8 sap head)
 915     (signed-sap-ref-64 sap head)))
 916
 917 ;;; Find an input routine to use given the type. Return as multiple
 918 ;;; values the routine, the real type transfered, and the number of
 919 ;;; bytes per element (and for character types string input routine).
 920 (defun pick-input-routine (type &optional external-format)
 921   (when (subtypep type 'character)
 922     (dolist (entry *external-formats*)
 923       (when (member external-format (first entry))
 924         (return-from pick-input-routine
 925           (values (symbol-function (third entry))
 926                   'character
 927                   1
 928                   (symbol-function (second entry))
 929                   (first (first entry)))))))
 930   (dolist (entry *input-routines*)
 931     (when (and (subtypep type (first entry))
 932                (or (not (fourth entry))
 933                    (eq external-format (fourth entry))))
 934       (return-from pick-input-routine
 935         (values (symbol-function (second entry))
 936                 (first entry)
 937                 (third entry)))))
 938   ;; FIXME: let's do it the hard way, then (but ignore things like
 939   ;; endianness, efficiency, and the necessary coupling between these
 940   ;; and the output routines).  -- CSR, 2004-02-09
 941   (loop for i from 40 by 8 to 1024 ; ARB (well, KLUDGE really)
 942         if (subtypep type `(unsigned-byte ,i))
 943         do (return-from pick-input-routine
 944              (values
 945               (lambda (stream eof-error eof-value)
 946                 (input-wrapper (stream (/ i 8) eof-error eof-value)
 947                   (let ((sap (fd-stream-ibuf-sap stream))
 948                         (head (fd-stream-ibuf-head stream)))
 949                     (loop for j from 0 below (/ i 8)
 950                           with result = 0
 951                           do (setf result
 952                                    (+ (* 256 result)
 953                                       (sap-ref-8 sap (+ head j))))
 954                           finally (return result)))))
 955               `(unsigned-byte ,i)
 956               (/ i 8))))
 957   (loop for i from 40 by 8 to 1024 ; ARB (well, KLUDGE really)
 958         if (subtypep type `(signed-byte ,i))
 959         do (return-from pick-input-routine
 960              (values
 961               (lambda (stream eof-error eof-value)
 962                 (input-wrapper (stream (/ i 8) eof-error eof-value)
 963                   (let ((sap (fd-stream-ibuf-sap stream))
 964                         (head (fd-stream-ibuf-head stream)))
 965                     (loop for j from 0 below (/ i 8)
 966                           with result = 0
 967                           do (setf result
 968                                    (+ (* 256 result)
 969                                       (sap-ref-8 sap (+ head j))))
 970                           finally (return (if (logbitp (1- i) result)
 971                                               (dpb result (byte i 0) -1)
 972                                               result))))))
 973               `(signed-byte ,i)
 974               (/ i 8)))))
 975
 976 ;;; Return a string constructed from SAP, START, and END.
 977 (defun string-from-sap (sap start end)
 978   (declare (type index start end))
 979   (let* ((length (- end start))
 980          (string (make-string length)))
 981     (copy-ub8-from-system-area sap start
 982                                string 0
 983                                length)
 984     string))
 985
 986 ;;; the N-BIN method for FD-STREAMs
 987 ;;;
 988 ;;; Note that this blocks in UNIX-READ. It is generally used where
 989 ;;; there is a definite amount of reading to be done, so blocking
 990 ;;; isn't too problematical.
 991 (defun fd-stream-read-n-bytes (stream buffer start requested eof-error-p
 992                                &aux (total-copied 0))
 993   (declare (type fd-stream stream))
 994   (declare (type index start requested total-copied))
 995   (let ((unread (fd-stream-unread stream)))
 996     (when unread
 997       ;; AVERs designed to fail when we have more complicated
 998       ;; character representations.
 999       (aver (typep unread 'base-char))
1000       (aver (= (fd-stream-element-size stream) 1))
1001       ;; KLUDGE: this is a slightly-unrolled-and-inlined version of
1002       ;; %BYTE-BLT
1003       (etypecase buffer
1004         (system-area-pointer
1005          (setf (sap-ref-8 buffer start) (char-code unread)))
1006         ((simple-unboxed-array (*))
1007          (setf (aref buffer start) unread)))
1008       (setf (fd-stream-unread stream) nil)
1009       (setf (fd-stream-listen stream) nil)
1010       (incf total-copied)))
1011   (do ()
1012       (nil)
1013     (let* ((remaining-request (- requested total-copied))
1014            (head (fd-stream-ibuf-head stream))
1015            (tail (fd-stream-ibuf-tail stream))
1016            (available (- tail head))
1017            (n-this-copy (min remaining-request available))
1018            (this-start (+ start total-copied))
1019            (this-end (+ this-start n-this-copy))
1020            (sap (fd-stream-ibuf-sap stream)))
1021       (declare (type index remaining-request head tail available))
1022       (declare (type index n-this-copy))
1023       ;; Copy data from stream buffer into user's buffer.
1024       (%byte-blt sap head buffer this-start this-end)
1025       (incf (fd-stream-ibuf-head stream) n-this-copy)
1026       (incf total-copied n-this-copy)
1027       ;; Maybe we need to refill the stream buffer.
1028       (cond (;; If there were enough data in the stream buffer, we're done.
1029              (= total-copied requested)
1030              (return total-copied))
1031             (;; If EOF, we're done in another way.
1032              (null (catch 'eof-input-catcher (refill-buffer/fd stream)))
1033              (if eof-error-p
1034                  (error 'end-of-file :stream stream)
1035                  (return total-copied)))
1036             ;; Otherwise we refilled the stream buffer, so fall
1037             ;; through into another pass of the loop.
1038             ))))
1039
1040 (defun fd-stream-resync (stream)
1041   (dolist (entry *external-formats*)
1042     (when (member (fd-stream-external-format stream) (first entry))
1043       (return-from fd-stream-resync
1044         (funcall (symbol-function (eighth entry)) stream)))))
1045
1046 (defun get-fd-stream-character-sizer (stream)
1047   (dolist (entry *external-formats*)
1048     (when (member (fd-stream-external-format stream) (first entry))
1049       (return-from get-fd-stream-character-sizer (ninth entry)))))
1050
1051 (defun fd-stream-character-size (stream char)
1052   (let ((sizer (get-fd-stream-character-sizer stream)))
1053     (when sizer (funcall sizer char))))
1054
1055 (defun fd-stream-string-size (stream string)
1056   (let ((sizer (get-fd-stream-character-sizer stream)))
1057     (when sizer
1058       (loop for char across string summing (funcall sizer char)))))
1059
1060 (defun find-external-format (external-format)
1061   (when external-format
1062     (find external-format *external-formats* :test #'member :key #'car)))
1063
1064 (defun variable-width-external-format-p (ef-entry)
1065   (when (eighth ef-entry) t))
1066
1067 (defun bytes-for-char-fun (ef-entry)
1068   (if ef-entry (symbol-function (ninth ef-entry)) (constantly 1)))
1069
1070 ;;; FIXME: OAOOM here vrt. *EXTERNAL-FORMAT-FUNCTIONS* in fd-stream.lisp
1071 (defmacro define-external-format (external-format size output-restart
1072                                   out-expr in-expr)
1073   (let* ((name (first external-format))
1074          (out-function (symbolicate "OUTPUT-BYTES/" name))
1075          (format (format nil "OUTPUT-CHAR-~A-~~A-BUFFERED" (string name)))
1076          (in-function (symbolicate "FD-STREAM-READ-N-CHARACTERS/" name))
1077          (in-char-function (symbolicate "INPUT-CHAR/" name))
1078          (size-function (symbolicate "BYTES-FOR-CHAR/" name))
1079          (read-c-string-function (symbolicate "READ-FROM-C-STRING/" name))
1080          (output-c-string-function (symbolicate "OUTPUT-TO-C-STRING/" name)))
1081     `(progn
1082       (defun ,size-function (byte)
1083         (declare (ignore byte))
1084         ,size)
1085       (defun ,out-function (stream string flush-p start end)
1086         (let ((start (or start 0))
1087               (end (or end (length string))))
1088           (declare (type index start end))
1089           (when (and (not (fd-stream-dual-channel-p stream))
1090                      (> (fd-stream-ibuf-tail stream)
1091                         (fd-stream-ibuf-head stream)))
1092             (file-position stream (file-position stream)))
1093           (unless (<= 0 start end (length string))
1094             (signal-bounding-indices-bad-error string start end))
1095           (do ()
1096               ((= end start))
1097             (setf (fd-stream-obuf-tail stream)
1098                   (string-dispatch (simple-base-string
1099                                     #!+sb-unicode
1100                                     (simple-array character)
1101                                     string)
1102                       string
1103                     (let ((len (fd-stream-obuf-length stream))
1104                           (sap (fd-stream-obuf-sap stream))
1105                           (tail (fd-stream-obuf-tail stream)))
1106                       (declare (type index tail)
1107                                ;; STRING bounds have already been checked.
1108                                (optimize (safety 0)))
1109                       (loop
1110                          (,@(if output-restart
1111                                 `(catch 'output-nothing)
1112                                 `(progn))
1113                             (do* ()
1114                                  ((or (= start end) (< (- len tail) 4)))
1115                               (let* ((byte (aref string start))
1116                                      (bits (char-code byte)))
1117                                 ,out-expr
1118                                 (incf tail ,size)
1119                                 (incf start)))
1120                             ;; Exited from the loop normally
1121                             (return tail))
1122                          ;; Exited via CATCH. Skip the current character
1123                          ;; and try the inner loop again.
1124                          (incf start)))))
1125             (when (< start end)
1126               (flush-output-buffer stream)))
1127           (when flush-p
1128             (flush-output-buffer stream))))
1129       (def-output-routines (,format
1130                             ,size
1131                             ,output-restart
1132                             (:none character)
1133                             (:line character)
1134                             (:full character))
1135           (if (char= byte #\Newline)
1136               (setf (fd-stream-char-pos stream) 0)
1137               (incf (fd-stream-char-pos stream)))
1138         (let ((bits (char-code byte))
1139               (sap (fd-stream-obuf-sap stream))
1140               (tail (fd-stream-obuf-tail stream)))
1141           ,out-expr))
1142       (defun ,in-function (stream buffer start requested eof-error-p
1143                            &aux (index start) (end (+ start requested)))
1144         (declare (type fd-stream stream))
1145         (declare (type index start requested index end))
1146         (declare (type (simple-array character (#.+ansi-stream-in-buffer-length+)) buffer))
1147         (let ((unread (fd-stream-unread stream)))
1148           (when unread
1149             (setf (aref buffer index) unread)
1150             (setf (fd-stream-unread stream) nil)
1151             (setf (fd-stream-listen stream) nil)
1152             (incf index)))
1153         (do ()
1154             (nil)
1155           (let* ((head (fd-stream-ibuf-head stream))
1156                  (tail (fd-stream-ibuf-tail stream))
1157                  (sap (fd-stream-ibuf-sap stream)))
1158             (declare (type index head tail)
1159                      (type system-area-pointer sap))
1160             ;; Copy data from stream buffer into user's buffer.
1161             (dotimes (i (min (truncate (- tail head) ,size)
1162                              (- end index)))
1163               (declare (optimize speed))
1164               (let* ((byte (sap-ref-8 sap head)))
1165                 (setf (aref buffer index) ,in-expr)
1166                 (incf index)
1167                 (incf head ,size)))
1168             (setf (fd-stream-ibuf-head stream) head)
1169             ;; Maybe we need to refill the stream buffer.
1170             (cond ( ;; If there was enough data in the stream buffer, we're done.
1171                    (= index end)
1172                    (return (- index start)))
1173                   ( ;; If EOF, we're done in another way.
1174                    (null (catch 'eof-input-catcher (refill-buffer/fd stream)))
1175                    (if eof-error-p
1176                        (error 'end-of-file :stream stream)
1177                        (return (- index start))))
1178                   ;; Otherwise we refilled the stream buffer, so fall
1179                   ;; through into another pass of the loop.
1180                   ))))
1181       (def-input-routine ,in-char-function (character ,size sap head)
1182         (let ((byte (sap-ref-8 sap head)))
1183           ,in-expr))
1184       (defun ,read-c-string-function (sap element-type)
1185         (declare (type system-area-pointer sap)
1186                  (type (member character base-char) element-type))
1187         (locally
1188             (declare (optimize (speed 3) (safety 0)))
1189           (let* ((stream ,name)
1190                  (length (loop for head of-type index upfrom 0 by ,size
1191                             for count of-type index upto (1- ARRAY-DIMENSION-LIMIT)
1192                             for byte = (sap-ref-8 sap head)
1193                             for char of-type character = ,in-expr
1194                             until (zerop (char-code char))
1195                             finally (return count)))
1196                  (string (make-string length :element-type element-type)))
1197             (declare (ignorable stream)
1198                      (type index length)
1199                      (type string string))
1200             (/show0 before-copy-loop)
1201             (loop for head of-type index upfrom 0 by ,size
1202                for index of-type index below length
1203                for byte = (sap-ref-8 sap head)
1204                for char of-type character = ,in-expr
1205                do (setf (aref string index) char))
1206             string))) ;; last loop rewrite to dotimes?
1207         (defun ,output-c-string-function (string)
1208           (declare (type simple-string string))
1209           (locally
1210               (declare (optimize (speed 3) (safety 0)))
1211             (let* ((length (length string))
1212                    (buffer (make-array (* (1+ length) ,size) :element-type '(unsigned-byte 8)))
1213                    (sap (sb!sys:vector-sap buffer))
1214                    (tail 0)
1215                    (stream ,name))
1216               (declare (type index length tail)
1217                        (type system-area-pointer sap))
1218               (dotimes (i length)
1219                 (let* ((byte (aref string i))
1220                        (bits (char-code byte)))
1221                   (declare (ignorable byte bits))
1222                   ,out-expr)
1223                 (incf tail ,size))
1224               (let* ((bits 0)
1225                      (byte (code-char bits)))
1226                 (declare (ignorable bits byte))
1227                 ,out-expr)
1228               buffer)))
1229       (setf *external-formats*
1230        (cons '(,external-format ,in-function ,in-char-function ,out-function
1231                ,@(mapcar #'(lambda (buffering)
1232                              (intern (format nil format (string buffering))))
1233                          '(:none :line :full))
1234                nil ; no resync-function
1235                ,size-function ,read-c-string-function ,output-c-string-function)
1236         *external-formats*)))))
1237
1238 (defmacro define-external-format/variable-width
1239     (external-format output-restart out-size-expr
1240      out-expr in-size-expr in-expr)
1241   (let* ((name (first external-format))
1242          (out-function (symbolicate "OUTPUT-BYTES/" name))
1243          (format (format nil "OUTPUT-CHAR-~A-~~A-BUFFERED" (string name)))
1244          (in-function (symbolicate "FD-STREAM-READ-N-CHARACTERS/" name))
1245          (in-char-function (symbolicate "INPUT-CHAR/" name))
1246          (resync-function (symbolicate "RESYNC/" name))
1247          (size-function (symbolicate "BYTES-FOR-CHAR/" name))
1248          (read-c-string-function (symbolicate "READ-FROM-C-STRING/" name))
1249          (output-c-string-function (symbolicate "OUTPUT-TO-C-STRING/" name)))
1250     `(progn
1251       (defun ,size-function (byte)
1252         (declare (ignorable byte))
1253         ,out-size-expr)
1254       (defun ,out-function (stream string flush-p start end)
1255         (let ((start (or start 0))
1256               (end (or end (length string))))
1257           (declare (type index start end))
1258           (when (and (not (fd-stream-dual-channel-p stream))
1259                      (> (fd-stream-ibuf-tail stream)
1260                         (fd-stream-ibuf-head stream)))
1261             (file-position stream (file-position stream)))
1262           (unless (<= 0 start end (length string))
1263             (signal-bounding-indices-bad-error string start end))
1264           (do ()
1265               ((= end start))
1266             (setf (fd-stream-obuf-tail stream)
1267                   (string-dispatch (simple-base-string
1268                                     #!+sb-unicode
1269                                     (simple-array character)
1270                                     string)
1271                       string
1272                     (let ((len (fd-stream-obuf-length stream))
1273                           (sap (fd-stream-obuf-sap stream))
1274                           (tail (fd-stream-obuf-tail stream)))
1275                       (declare (type index tail)
1276                                ;; STRING bounds have already been checked.
1277                                (optimize (safety 0)))
1278                       (loop
1279                          (,@(if output-restart
1280                                 `(catch 'output-nothing)
1281                                 `(progn))
1282                             (do* ()
1283                                  ((or (= start end) (< (- len tail) 4)))
1284                               (let* ((byte (aref string start))
1285                                      (bits (char-code byte))
1286                                      (size ,out-size-expr))
1287                                 ,out-expr
1288                                 (incf tail size)
1289                                 (incf start)))
1290                             ;; Exited from the loop normally
1291                             (return tail))
1292                          ;; Exited via CATCH. Skip the current character
1293                          ;; and try the inner loop again.
1294                          (incf start)))))
1295             (when (< start end)
1296               (flush-output-buffer stream)))
1297           (when flush-p
1298             (flush-output-buffer stream))))
1299       (def-output-routines/variable-width (,format
1300                                            ,out-size-expr
1301                                            ,output-restart
1302                                            ,external-format
1303                                            (:none character)
1304                                            (:line character)
1305                                            (:full character))
1306           (if (char= byte #\Newline)
1307               (setf (fd-stream-char-pos stream) 0)
1308               (incf (fd-stream-char-pos stream)))
1309         (let ((bits (char-code byte))
1310               (sap (fd-stream-obuf-sap stream))
1311               (tail (fd-stream-obuf-tail stream)))
1312           ,out-expr))
1313       (defun ,in-function (stream buffer start requested eof-error-p
1314                            &aux (total-copied 0))
1315         (declare (type fd-stream stream))
1316         (declare (type index start requested total-copied))
1317         (declare (type (simple-array character (#.+ansi-stream-in-buffer-length+)) buffer))
1318         (let ((unread (fd-stream-unread stream)))
1319           (when unread
1320             (setf (aref buffer start) unread)
1321             (setf (fd-stream-unread stream) nil)
1322             (setf (fd-stream-listen stream) nil)
1323             (incf total-copied)))
1324         (do ()
1325             (nil)
1326           (let* ((head (fd-stream-ibuf-head stream))
1327                  (tail (fd-stream-ibuf-tail stream))
1328                  (sap (fd-stream-ibuf-sap stream))
1329                  (decode-break-reason nil))
1330             (declare (type index head tail))
1331             ;; Copy data from stream buffer into user's buffer.
1332             (do ((size nil nil))
1333                 ((or (= tail head) (= requested total-copied)))
1334               (setf decode-break-reason
1335                     (block decode-break-reason
1336                       (let ((byte (sap-ref-8 sap head)))
1337                         (declare (ignorable byte))
1338                         (setq size ,in-size-expr)
1339                         (when (> size (- tail head))
1340                           (return))
1341                         (setf (aref buffer (+ start total-copied)) ,in-expr)
1342                         (incf total-copied)
1343                         (incf head size))
1344                       nil))
1345               (setf (fd-stream-ibuf-head stream) head)
1346               (when decode-break-reason
1347                 ;; If we've already read some characters on when the invalid
1348                 ;; code sequence is detected, we return immediately. The
1349                 ;; handling of the error is deferred until the next call
1350                 ;; (where this check will be false). This allows establishing
1351                 ;; high-level handlers for decode errors (for example
1352                 ;; automatically resyncing in Lisp comments).
1353                 (when (plusp total-copied)
1354                   (return-from ,in-function total-copied))
1355                 (when (stream-decoding-error-and-handle
1356                        stream decode-break-reason)
1357                   (if eof-error-p
1358                       (error 'end-of-file :stream stream)
1359                       (return-from ,in-function total-copied)))
1360                 (setf head (fd-stream-ibuf-head stream))
1361                 (setf tail (fd-stream-ibuf-tail stream))))
1362             (setf (fd-stream-ibuf-head stream) head)
1363             ;; Maybe we need to refill the stream buffer.
1364             (cond ( ;; If there were enough data in the stream buffer, we're done.
1365                    (= total-copied requested)
1366                    (return total-copied))
1367                   ( ;; If EOF, we're done in another way.
1368                    (or (eq decode-break-reason 'eof)
1369                        (null (catch 'eof-input-catcher
1370                                (refill-buffer/fd stream))))
1371                    (if eof-error-p
1372                        (error 'end-of-file :stream stream)
1373                        (return total-copied)))
1374                   ;; Otherwise we refilled the stream buffer, so fall
1375                   ;; through into another pass of the loop.
1376                   ))))
1377       (def-input-routine/variable-width ,in-char-function (character
1378                                                            ,external-format
1379                                                            ,in-size-expr
1380                                                            sap head)
1381         (let ((byte (sap-ref-8 sap head)))
1382           (declare (ignorable byte))
1383           ,in-expr))
1384       (defun ,resync-function (stream)
1385         (loop (input-at-least stream 2)
1386               (incf (fd-stream-ibuf-head stream))
1387               (unless (block decode-break-reason
1388                         (let* ((sap (fd-stream-ibuf-sap stream))
1389                                (head (fd-stream-ibuf-head stream))
1390                                (byte (sap-ref-8 sap head))
1391                                (size ,in-size-expr))
1392                           (declare (ignorable byte))
1393                           (input-at-least stream size)
1394                           (let ((sap (fd-stream-ibuf-sap stream))
1395                                 (head (fd-stream-ibuf-head stream)))
1396                             ,in-expr))
1397                         nil)
1398                 (return))))
1399       (defun ,read-c-string-function (sap element-type)
1400         (declare (type system-area-pointer sap))
1401         (locally
1402             (declare (optimize (speed 3) (safety 0)))
1403           (let* ((stream ,name)
1404                  (size 0) (head 0) (byte 0) (char nil)
1405                  (decode-break-reason nil)
1406                  (length (dotimes (count (1- ARRAY-DIMENSION-LIMIT) count)
1407                            (setf decode-break-reason
1408                                  (block decode-break-reason
1409                                    (setf byte (sap-ref-8 sap head)
1410                                          size ,in-size-expr
1411                                          char ,in-expr)
1412                                    (incf head size)
1413                                    nil))
1414                            (when decode-break-reason
1415                              (c-string-decoding-error ,name decode-break-reason))
1416                            (when (zerop (char-code char))
1417                              (return count))))
1418                  (string (make-string length :element-type element-type)))
1419             (declare (ignorable stream)
1420                      (type index head length) ;; size
1421                      (type (unsigned-byte 8) byte)
1422                      (type (or null character) char)
1423                      (type string string))
1424             (setf head 0)
1425             (dotimes (index length string)
1426               (setf decode-break-reason
1427                     (block decode-break-reason
1428                       (setf byte (sap-ref-8 sap head)
1429                             size ,in-size-expr
1430                             char ,in-expr)
1431                       (incf head size)
1432                       nil))
1433               (when decode-break-reason
1434                 (c-string-decoding-error ,name decode-break-reason))
1435               (setf (aref string index) char)))))
1436
1437       (defun ,output-c-string-function (string)
1438         (declare (type simple-string string))
1439         (locally
1440             (declare (optimize (speed 3) (safety 0)))
1441           (let* ((length (length string))
1442                  (char-length (make-array (1+ length) :element-type 'index))
1443                  (buffer-length
1444                   (+ (loop for i of-type index below length
1445                         for byte of-type character = (aref string i)
1446                         for bits = (char-code byte)
1447                         sum (setf (aref char-length i)
1448                                   (the index ,out-size-expr)))
1449                      (let* ((byte (code-char 0))
1450                             (bits (char-code byte)))
1451                        (declare (ignorable byte bits))
1452                        (setf (aref char-length length)
1453                              (the index ,out-size-expr)))))
1454                  (tail 0)
1455                  (buffer (make-array buffer-length :element-type '(unsigned-byte 8)))
1456                  (sap (sb!sys:vector-sap buffer))
1457                  stream)
1458             (declare (type index length buffer-length tail)
1459                      (type system-area-pointer sap)
1460                      (type null stream)
1461                      (ignorable stream))
1462             (loop for i of-type index below length
1463                for byte of-type character = (aref string i)
1464                for bits = (char-code byte)
1465                for size of-type index = (aref char-length i)
1466                do (prog1
1467                       ,out-expr
1468                     (incf tail size)))
1469             (let* ((bits 0)
1470                    (byte (code-char bits))
1471                    (size (aref char-length length)))
1472               (declare (ignorable bits byte size))
1473               ,out-expr)
1474             buffer)))
1475
1476       (setf *external-formats*
1477        (cons '(,external-format ,in-function ,in-char-function ,out-function
1478                ,@(mapcar #'(lambda (buffering)
1479                              (intern (format nil format (string buffering))))
1480                          '(:none :line :full))
1481                ,resync-function
1482                ,size-function ,read-c-string-function ,output-c-string-function)
1483         *external-formats*)))))
1484
1485 ;;; Multiple names for the :ISO{,-}8859-* families are needed because on
1486 ;;; FreeBSD (and maybe other BSD systems), nl_langinfo("LATIN-1") will
1487 ;;; return "ISO8859-1" instead of "ISO-8859-1".
1488 (define-external-format (:latin-1 :latin1 :iso-8859-1 :iso8859-1)
1489     1 t
1490   (if (>= bits 256)
1491       (external-format-encoding-error stream bits)
1492       (setf (sap-ref-8 sap tail) bits))
1493   (code-char byte))
1494
1495 (define-external-format (:ascii :us-ascii :ansi_x3.4-1968
1496                          :iso-646 :iso-646-us :|646|)
1497     1 t
1498   (if (>= bits 128)
1499       (external-format-encoding-error stream bits)
1500       (setf (sap-ref-8 sap tail) bits))
1501   (code-char byte))
1502
1503 (let* ((table (let ((s (make-string 256)))
1504                 (map-into s #'code-char
1505                           '(#x00 #x01 #x02 #x03 #x9c #x09 #x86 #x7f #x97 #x8d #x8e #x0b #x0c #x0d #x0e #x0f
1506                             #x10 #x11 #x12 #x13 #x9d #x85 #x08 #x87 #x18 #x19 #x92 #x8f #x1c #x1d #x1e #x1f
1507                             #x80 #x81 #x82 #x83 #x84 #x0a #x17 #x1b #x88 #x89 #x8a #x8b #x8c #x05 #x06 #x07
1508                             #x90 #x91 #x16 #x93 #x94 #x95 #x96 #x04 #x98 #x99 #x9a #x9b #x14 #x15 #x9e #x1a
1509                             #x20 #xa0 #xe2 #xe4 #xe0 #xe1 #xe3 #xe5 #xe7 #xf1 #xa2 #x2e #x3c #x28 #x2b #x7c
1510                             #x26 #xe9 #xea #xeb #xe8 #xed #xee #xef #xec #xdf #x21 #x24 #x2a #x29 #x3b #xac
1511                             #x2d #x2f #xc2 #xc4 #xc0 #xc1 #xc3 #xc5 #xc7 #xd1 #xa6 #x2c #x25 #x5f #x3e #x3f
1512                             #xf8 #xc9 #xca #xcb #xc8 #xcd #xce #xcf #xcc #x60 #x3a #x23 #x40 #x27 #x3d #x22
1513                             #xd8 #x61 #x62 #x63 #x64 #x65 #x66 #x67 #x68 #x69 #xab #xbb #xf0 #xfd #xfe #xb1
1514                             #xb0 #x6a #x6b #x6c #x6d #x6e #x6f #x70 #x71 #x72 #xaa #xba #xe6 #xb8 #xc6 #xa4
1515                             #xb5 #x7e #x73 #x74 #x75 #x76 #x77 #x78 #x79 #x7a #xa1 #xbf #xd0 #xdd #xde #xae
1516                             #x5e #xa3 #xa5 #xb7 #xa9 #xa7 #xb6 #xbc #xbd #xbe #x5b #x5d #xaf #xa8 #xb4 #xd7
1517                             #x7b #x41 #x42 #x43 #x44 #x45 #x46 #x47 #x48 #x49 #xad #xf4 #xf6 #xf2 #xf3 #xf5
1518                             #x7d #x4a #x4b #x4c #x4d #x4e #x4f #x50 #x51 #x52 #xb9 #xfb #xfc #xf9 #xfa #xff
1519                             #x5c #xf7 #x53 #x54 #x55 #x56 #x57 #x58 #x59 #x5a #xb2 #xd4 #xd6 #xd2 #xd3 #xd5
1520                             #x30 #x31 #x32 #x33 #x34 #x35 #x36 #x37 #x38 #x39 #xb3 #xdb #xdc #xd9 #xda #x9f))
1521                 s))
1522        (reverse-table (let ((rt (make-array 256 :element-type '(unsigned-byte 8) :initial-element 0)))
1523                           (loop for char across table for i from 0
1524                                do (aver (= 0 (aref rt (char-code char))))
1525                                do (setf (aref rt (char-code char)) i))
1526                           rt)))
1527   (define-external-format (:ebcdic-us :ibm-037 :ibm037)
1528       1 t
1529     (if (>= bits 256)
1530         (external-format-encoding-error stream bits)
1531         (setf (sap-ref-8 sap tail) (aref reverse-table bits)))
1532     (aref table byte)))
1533
1534
1535 #!+sb-unicode
1536 (let ((latin-9-table (let ((table (make-string 256)))
1537                        (do ((i 0 (1+ i)))
1538                            ((= i 256))
1539                          (setf (aref table i) (code-char i)))
1540                        (setf (aref table #xa4) (code-char #x20ac))
1541                        (setf (aref table #xa6) (code-char #x0160))
1542                        (setf (aref table #xa8) (code-char #x0161))
1543                        (setf (aref table #xb4) (code-char #x017d))
1544                        (setf (aref table #xb8) (code-char #x017e))
1545                        (setf (aref table #xbc) (code-char #x0152))
1546                        (setf (aref table #xbd) (code-char #x0153))
1547                        (setf (aref table #xbe) (code-char #x0178))
1548                        table))
1549       (latin-9-reverse-1 (make-array 16
1550                                      :element-type '(unsigned-byte 21)
1551                                      :initial-contents '(#x0160 #x0161 #x0152 #x0153 0 0 0 0 #x0178 0 0 0 #x20ac #x017d #x017e 0)))
1552       (latin-9-reverse-2 (make-array 16
1553                                      :element-type '(unsigned-byte 8)
1554                                      :initial-contents '(#xa6 #xa8 #xbc #xbd 0 0 0 0 #xbe 0 0 0 #xa4 #xb4 #xb8 0))))
1555   (define-external-format (:latin-9 :latin9 :iso-8859-15 :iso8859-15)
1556       1 t
1557     (setf (sap-ref-8 sap tail)
1558           (if (< bits 256)
1559               (if (= bits (char-code (aref latin-9-table bits)))
1560                   bits
1561                   (external-format-encoding-error stream byte))
1562               (if (= (aref latin-9-reverse-1 (logand bits 15)) bits)
1563                   (aref latin-9-reverse-2 (logand bits 15))
1564                   (external-format-encoding-error stream byte))))
1565     (aref latin-9-table byte)))
1566
1567 (define-external-format/variable-width (:utf-8 :utf8) nil
1568   (let ((bits (char-code byte)))
1569     (cond ((< bits #x80) 1)
1570           ((< bits #x800) 2)
1571           ((< bits #x10000) 3)
1572           (t 4)))
1573   (ecase size
1574     (1 (setf (sap-ref-8 sap tail) bits))
1575     (2 (setf (sap-ref-8 sap tail) (logior #xc0 (ldb (byte 5 6) bits))
1576              (sap-ref-8 sap (1+ tail)) (logior #x80 (ldb (byte 6 0) bits))))
1577     (3 (setf (sap-ref-8 sap tail) (logior #xe0 (ldb (byte 4 12) bits))
1578              (sap-ref-8 sap (1+ tail)) (logior #x80 (ldb (byte 6 6) bits))
1579              (sap-ref-8 sap (+ 2 tail)) (logior #x80 (ldb (byte 6 0) bits))))
1580     (4 (setf (sap-ref-8 sap tail) (logior #xf0 (ldb (byte 3 18) bits))
1581              (sap-ref-8 sap (1+ tail)) (logior #x80 (ldb (byte 6 12) bits))
1582              (sap-ref-8 sap (+ 2 tail)) (logior #x80 (ldb (byte 6 6) bits))
1583              (sap-ref-8 sap (+ 3 tail)) (logior #x80 (ldb (byte 6 0) bits)))))
1584   (cond ((< byte #x80) 1)
1585         ((< byte #xc2) (return-from decode-break-reason 1))
1586         ((< byte #xe0) 2)
1587         ((< byte #xf0) 3)
1588         (t 4))
1589   (code-char (ecase size
1590                (1 byte)
1591                (2 (let ((byte2 (sap-ref-8 sap (1+ head))))
1592                     (unless (<= #x80 byte2 #xbf)
1593                       (return-from decode-break-reason 2))
1594                     (dpb byte (byte 5 6) byte2)))
1595                (3 (let ((byte2 (sap-ref-8 sap (1+ head)))
1596                         (byte3 (sap-ref-8 sap (+ 2 head))))
1597                     (unless (and (<= #x80 byte2 #xbf)
1598                                  (<= #x80 byte3 #xbf))
1599                       (return-from decode-break-reason 3))
1600                     (dpb byte (byte 4 12) (dpb byte2 (byte 6 6) byte3))))
1601                (4 (let ((byte2 (sap-ref-8 sap (1+ head)))
1602                         (byte3 (sap-ref-8 sap (+ 2 head)))
1603                         (byte4 (sap-ref-8 sap (+ 3 head))))
1604                     (unless (and (<= #x80 byte2 #xbf)
1605                                  (<= #x80 byte3 #xbf)
1606                                  (<= #x80 byte4 #xbf))
1607                       (return-from decode-break-reason 4))
1608                     (dpb byte (byte 3 18)
1609                          (dpb byte2 (byte 6 12)
1610                               (dpb byte3 (byte 6 6) byte4))))))))
1611 \f
1612 ;;;; utility functions (misc routines, etc)
1613
1614 ;;; Fill in the various routine slots for the given type. INPUT-P and
1615 ;;; OUTPUT-P indicate what slots to fill. The buffering slot must be
1616 ;;; set prior to calling this routine.
1617 (defun set-fd-stream-routines (fd-stream element-type external-format
1618                                input-p output-p buffer-p)
1619   (let* ((target-type (case element-type
1620                         (unsigned-byte '(unsigned-byte 8))
1621                         (signed-byte '(signed-byte 8))
1622                         (:default 'character)
1623                         (t element-type)))
1624          (character-stream-p (subtypep target-type 'character))
1625          (bivalent-stream-p (eq element-type :default))
1626          normalized-external-format
1627          (bin-routine #'ill-bin)
1628          (bin-type nil)
1629          (bin-size nil)
1630          (cin-routine #'ill-in)
1631          (cin-type nil)
1632          (cin-size nil)
1633          (input-type nil)           ;calculated from bin-type/cin-type
1634          (input-size nil)           ;calculated from bin-size/cin-size
1635          (read-n-characters #'ill-in)
1636          (bout-routine #'ill-bout)
1637          (bout-type nil)
1638          (bout-size nil)
1639          (cout-routine #'ill-out)
1640          (cout-type nil)
1641          (cout-size nil)
1642          (output-type nil)
1643          (output-size nil)
1644          (output-bytes #'ill-bout))
1645
1646     ;; drop buffers when direction changes
1647     (when (and (fd-stream-obuf-sap fd-stream) (not output-p))
1648       (with-available-buffers-lock ()
1649         (push (fd-stream-obuf-sap fd-stream) *available-buffers*)
1650         (setf (fd-stream-obuf-sap fd-stream) nil)))
1651     (when (and (fd-stream-ibuf-sap fd-stream) (not input-p))
1652       (with-available-buffers-lock ()
1653         (push (fd-stream-ibuf-sap fd-stream) *available-buffers*)
1654         (setf (fd-stream-ibuf-sap fd-stream) nil)))
1655     (when input-p
1656       (setf (fd-stream-ibuf-sap fd-stream) (next-available-buffer))
1657       (setf (fd-stream-ibuf-length fd-stream) bytes-per-buffer)
1658       (setf (fd-stream-ibuf-tail fd-stream) 0))
1659     (when output-p
1660       (setf (fd-stream-obuf-sap fd-stream) (next-available-buffer))
1661       (setf (fd-stream-obuf-length fd-stream) bytes-per-buffer)
1662       (setf (fd-stream-obuf-tail fd-stream) 0)
1663       (setf (fd-stream-char-pos fd-stream) 0))
1664
1665     (when (and character-stream-p
1666                (eq external-format :default))
1667       (/show0 "/getting default external format")
1668       (setf external-format (default-external-format)))
1669
1670     (when input-p
1671       (when (or (not character-stream-p) bivalent-stream-p)
1672         (multiple-value-setq (bin-routine bin-type bin-size read-n-characters
1673                                           normalized-external-format)
1674           (pick-input-routine (if bivalent-stream-p '(unsigned-byte 8)
1675                                   target-type)
1676                               external-format))
1677         (unless bin-routine
1678           (error "could not find any input routine for ~S" target-type)))
1679       (when character-stream-p
1680         (multiple-value-setq (cin-routine cin-type cin-size read-n-characters
1681                                           normalized-external-format)
1682           (pick-input-routine target-type external-format))
1683         (unless cin-routine
1684           (error "could not find any input routine for ~S" target-type)))
1685       (setf (fd-stream-in fd-stream) cin-routine
1686             (fd-stream-bin fd-stream) bin-routine)
1687       ;; character type gets preferential treatment
1688       (setf input-size (or cin-size bin-size))
1689       (setf input-type (or cin-type bin-type))
1690       (when normalized-external-format
1691         (setf (fd-stream-external-format fd-stream)
1692               normalized-external-format))
1693       (when (= (or cin-size 1) (or bin-size 1) 1)
1694         (setf (fd-stream-n-bin fd-stream) ;XXX
1695               (if (and character-stream-p (not bivalent-stream-p))
1696                   read-n-characters
1697                   #'fd-stream-read-n-bytes))
1698         ;; Sometimes turn on fast-read-char/fast-read-byte.  Switch on
1699         ;; for character and (unsigned-byte 8) streams.  In these
1700         ;; cases, fast-read-* will read from the
1701         ;; ansi-stream-(c)in-buffer, saving function calls.
1702         ;; Otherwise, the various data-reading functions in the stream
1703         ;; structure will be called.
1704         (when (and buffer-p
1705                    (not bivalent-stream-p)
1706                    ;; temporary disable on :io streams
1707                    (not output-p))
1708           (cond (character-stream-p
1709                  (setf (ansi-stream-cin-buffer fd-stream)
1710                        (make-array +ansi-stream-in-buffer-length+
1711                                    :element-type 'character)))
1712                 ((equal target-type '(unsigned-byte 8))
1713                  (setf (ansi-stream-in-buffer fd-stream)
1714                        (make-array +ansi-stream-in-buffer-length+
1715                                    :element-type '(unsigned-byte 8))))))))
1716
1717     (when output-p
1718       (when (or (not character-stream-p) bivalent-stream-p)
1719         (multiple-value-setq (bout-routine bout-type bout-size output-bytes
1720                                            normalized-external-format)
1721           (pick-output-routine (if bivalent-stream-p
1722                                    '(unsigned-byte 8)
1723                                    target-type)
1724                                (fd-stream-buffering fd-stream)
1725                                external-format))
1726         (unless bout-routine
1727           (error "could not find any output routine for ~S buffered ~S"
1728                  (fd-stream-buffering fd-stream)
1729                  target-type)))
1730       (when character-stream-p
1731         (multiple-value-setq (cout-routine cout-type cout-size output-bytes
1732                                            normalized-external-format)
1733           (pick-output-routine target-type
1734                                (fd-stream-buffering fd-stream)
1735                                external-format))
1736         (unless cout-routine
1737           (error "could not find any output routine for ~S buffered ~S"
1738                  (fd-stream-buffering fd-stream)
1739                  target-type)))
1740       (when normalized-external-format
1741         (setf (fd-stream-external-format fd-stream)
1742               normalized-external-format))
1743       (when character-stream-p
1744         (setf (fd-stream-output-bytes fd-stream) output-bytes))
1745       (setf (fd-stream-out fd-stream) cout-routine
1746             (fd-stream-bout fd-stream) bout-routine
1747             (fd-stream-sout fd-stream) (if (eql cout-size 1)
1748                                            #'fd-sout #'ill-out))
1749       (setf output-size (or cout-size bout-size))
1750       (setf output-type (or cout-type bout-type)))
1751
1752     (when (and input-size output-size
1753                (not (eq input-size output-size)))
1754       (error "Element sizes for input (~S:~S) and output (~S:~S) differ?"
1755              input-type input-size
1756              output-type output-size))
1757     (setf (fd-stream-element-size fd-stream)
1758           (or input-size output-size))
1759
1760     (setf (fd-stream-element-type fd-stream)
1761           (cond ((equal input-type output-type)
1762                  input-type)
1763                 ((null output-type)
1764                  input-type)
1765                 ((null input-type)
1766                  output-type)
1767                 ((subtypep input-type output-type)
1768                  input-type)
1769                 ((subtypep output-type input-type)
1770                  output-type)
1771                 (t
1772                  (error "Input type (~S) and output type (~S) are unrelated?"
1773                         input-type
1774                         output-type))))))
1775
1776 ;;; Handle miscellaneous operations on FD-STREAM.
1777 (defun fd-stream-misc-routine (fd-stream operation &optional arg1 arg2)
1778   (declare (ignore arg2))
1779   (case operation
1780     (:listen
1781      (labels ((do-listen ()
1782                 (or (not (eql (fd-stream-ibuf-head fd-stream)
1783                               (fd-stream-ibuf-tail fd-stream)))
1784                     (fd-stream-listen fd-stream)
1785                     #!+win32
1786                     (sb!win32:fd-listen (fd-stream-fd fd-stream))
1787                     #!-win32
1788                     ;; If the read can block, LISTEN will certainly return NIL.
1789                     (if (sysread-may-block-p fd-stream)
1790                         nil
1791                         ;; Otherwise select(2) and CL:LISTEN have slightly
1792                         ;; different semantics.  The former returns that an FD
1793                         ;; is readable when a read operation wouldn't block.
1794                         ;; That includes EOF.  However, LISTEN must return NIL
1795                         ;; at EOF.
1796                         (progn (catch 'eof-input-catcher
1797                                  ;; r-b/f too calls select, but it shouldn't
1798                                  ;; block as long as read can return once w/o
1799                                  ;; blocking
1800                                  (refill-buffer/fd fd-stream))
1801                                ;; At this point either IBUF-HEAD != IBUF-TAIL
1802                                ;; and FD-STREAM-LISTEN is NIL, in which case
1803                                ;; we should return T, or IBUF-HEAD ==
1804                                ;; IBUF-TAIL and FD-STREAM-LISTEN is :EOF, in
1805                                ;; which case we should return :EOF for this
1806                                ;; call and all future LISTEN call on this stream.
1807                                ;; Call ourselves again to determine which case
1808                                ;; applies.
1809                                (do-listen))))))
1810        (do-listen)))
1811     (:unread
1812      (setf (fd-stream-unread fd-stream) arg1)
1813      (setf (fd-stream-listen fd-stream) t))
1814     (:close
1815      (cond (arg1                    ; We got us an abort on our hands.
1816             (when (fd-stream-handler fd-stream)
1817               (sb!sys:remove-fd-handler (fd-stream-handler fd-stream))
1818               (setf (fd-stream-handler fd-stream) nil))
1819             ;; We can't do anything unless we know what file were
1820             ;; dealing with, and we don't want to do anything
1821             ;; strange unless we were writing to the file.
1822             (when (and (fd-stream-file fd-stream)
1823                        (fd-stream-obuf-sap fd-stream))
1824               (if (fd-stream-original fd-stream)
1825                   ;; If the original is EQ to file we are appending
1826                   ;; and can just close the file without renaming.
1827                   (unless (eq (fd-stream-original fd-stream)
1828                               (fd-stream-file fd-stream))
1829                     ;; We have a handle on the original, just revert.
1830                     (multiple-value-bind (okay err)
1831                         (sb!unix:unix-rename (fd-stream-original fd-stream)
1832                                              (fd-stream-file fd-stream))
1833                       (unless okay
1834                         (simple-stream-perror
1835                          "couldn't restore ~S to its original contents"
1836                          fd-stream
1837                          err))))
1838                   ;; We can't restore the original, and aren't
1839                   ;; appending, so nuke that puppy.
1840                   ;;
1841                   ;; FIXME: This is currently the fate of superseded
1842                   ;; files, and according to the CLOSE spec this is
1843                   ;; wrong. However, there seems to be no clean way to
1844                   ;; do that that doesn't involve either copying the
1845                   ;; data (bad if the :abort resulted from a full
1846                   ;; disk), or renaming the old file temporarily
1847                   ;; (probably bad because stream opening becomes more
1848                   ;; racy).
1849                   (multiple-value-bind (okay err)
1850                       (sb!unix:unix-unlink (fd-stream-file fd-stream))
1851                     (unless okay
1852                       (error 'simple-file-error
1853                              :pathname (fd-stream-file fd-stream)
1854                              :format-control
1855                              "~@<couldn't remove ~S: ~2I~_~A~:>"
1856                              :format-arguments (list (fd-stream-file fd-stream)
1857                                                      (strerror err))))))))
1858            (t
1859             (fd-stream-misc-routine fd-stream :finish-output)
1860             (when (and (fd-stream-original fd-stream)
1861                        (fd-stream-delete-original fd-stream))
1862               (multiple-value-bind (okay err)
1863                   (sb!unix:unix-unlink (fd-stream-original fd-stream))
1864                 (unless okay
1865                   (error 'simple-file-error
1866                          :pathname (fd-stream-original fd-stream)
1867                          :format-control
1868                          "~@<couldn't delete ~S during close of ~S: ~
1869                           ~2I~_~A~:>"
1870                          :format-arguments
1871                          (list (fd-stream-original fd-stream)
1872                                fd-stream
1873                                (strerror err))))))))
1874      (when (fboundp 'cancel-finalization)
1875        (cancel-finalization fd-stream))
1876      (sb!unix:unix-close (fd-stream-fd fd-stream))
1877      (when (fd-stream-obuf-sap fd-stream)
1878        (with-available-buffers-lock ()
1879          (push (fd-stream-obuf-sap fd-stream) *available-buffers*)
1880          (setf (fd-stream-obuf-sap fd-stream) nil)))
1881      (when (fd-stream-ibuf-sap fd-stream)
1882        (with-available-buffers-lock ()
1883          (push (fd-stream-ibuf-sap fd-stream) *available-buffers*)
1884          (setf (fd-stream-ibuf-sap fd-stream) nil)))
1885      (sb!impl::set-closed-flame fd-stream))
1886     (:clear-input
1887      (setf (fd-stream-unread fd-stream) nil)
1888      (setf (fd-stream-ibuf-head fd-stream) 0)
1889      (setf (fd-stream-ibuf-tail fd-stream) 0)
1890      #!+win32
1891      (progn
1892        (sb!win32:fd-clear-input (fd-stream-fd fd-stream))
1893        (setf (fd-stream-listen fd-stream) nil))
1894      #!-win32
1895      (catch 'eof-input-catcher
1896        (loop until (sysread-may-block-p fd-stream)
1897              do
1898              (refill-buffer/fd fd-stream)
1899              (setf (fd-stream-ibuf-head fd-stream) 0)
1900              (setf (fd-stream-ibuf-tail fd-stream) 0))
1901        t))
1902     (:force-output
1903      (flush-output-buffer fd-stream))
1904     (:finish-output
1905      (flush-output-buffer fd-stream)
1906      (do ()
1907          ((null (fd-stream-output-later fd-stream)))
1908        (sb!sys:serve-all-events)))
1909     (:element-type
1910      (fd-stream-element-type fd-stream))
1911     (:external-format
1912      (fd-stream-external-format fd-stream))
1913     (:interactive-p
1914      (= 1 (the (member 0 1)
1915             (sb!unix:unix-isatty (fd-stream-fd fd-stream)))))
1916     (:line-length
1917      80)
1918     (:charpos
1919      (fd-stream-char-pos fd-stream))
1920     (:file-length
1921      (unless (fd-stream-file fd-stream)
1922        ;; This is a TYPE-ERROR because ANSI's species FILE-LENGTH
1923        ;; "should signal an error of type TYPE-ERROR if stream is not
1924        ;; a stream associated with a file". Too bad there's no very
1925        ;; appropriate value for the EXPECTED-TYPE slot..
1926        (error 'simple-type-error
1927               :datum fd-stream
1928               :expected-type 'fd-stream
1929               :format-control "~S is not a stream associated with a file."
1930               :format-arguments (list fd-stream)))
1931      (multiple-value-bind (okay dev ino mode nlink uid gid rdev size
1932                                 atime mtime ctime blksize blocks)
1933          (sb!unix:unix-fstat (fd-stream-fd fd-stream))
1934        (declare (ignore ino nlink uid gid rdev
1935                         atime mtime ctime blksize blocks))
1936        (unless okay
1937          (simple-stream-perror "failed Unix fstat(2) on ~S" fd-stream dev))
1938        (if (zerop mode)
1939            nil
1940            (truncate size (fd-stream-element-size fd-stream)))))
1941     (:file-string-length
1942      (etypecase arg1
1943        (character (fd-stream-character-size fd-stream arg1))
1944        (string (fd-stream-string-size fd-stream arg1))))
1945     (:file-position
1946      (fd-stream-file-position fd-stream arg1))))
1947
1948 (defun fd-stream-file-position (stream &optional newpos)
1949   (declare (type fd-stream stream)
1950            (type (or (alien sb!unix:off-t) (member nil :start :end)) newpos))
1951   (if (null newpos)
1952       (sb!sys:without-interrupts
1953         ;; First, find the position of the UNIX file descriptor in the file.
1954         (multiple-value-bind (posn errno)
1955             (sb!unix:unix-lseek (fd-stream-fd stream) 0 sb!unix:l_incr)
1956           (declare (type (or (alien sb!unix:off-t) null) posn))
1957           (cond ((integerp posn)
1958                  ;; Adjust for buffered output: If there is any output
1959                  ;; buffered, the *real* file position will be larger
1960                  ;; than reported by lseek() because lseek() obviously
1961                  ;; cannot take into account output we have not sent
1962                  ;; yet.
1963                  (dolist (later (fd-stream-output-later stream))
1964                    (incf posn (- (caddr later)
1965                                  (cadr later))))
1966                  (incf posn (fd-stream-obuf-tail stream))
1967                  ;; Adjust for unread input: If there is any input
1968                  ;; read from UNIX but not supplied to the user of the
1969                  ;; stream, the *real* file position will smaller than
1970                  ;; reported, because we want to look like the unread
1971                  ;; stuff is still available.
1972                  (decf posn (- (fd-stream-ibuf-tail stream)
1973                                (fd-stream-ibuf-head stream)))
1974                  (when (fd-stream-unread stream)
1975                    (decf posn))
1976                  ;; Divide bytes by element size.
1977                  (truncate posn (fd-stream-element-size stream)))
1978                 ((eq errno sb!unix:espipe)
1979                  nil)
1980                 (t
1981                  (sb!sys:with-interrupts
1982                    (simple-stream-perror "failure in Unix lseek() on ~S"
1983                                          stream
1984                                          errno))))))
1985       (let ((offset 0) origin)
1986         (declare (type (alien sb!unix:off-t) offset))
1987         ;; Make sure we don't have any output pending, because if we
1988         ;; move the file pointer before writing this stuff, it will be
1989         ;; written in the wrong location.
1990         (flush-output-buffer stream)
1991         (do ()
1992             ((null (fd-stream-output-later stream)))
1993           (sb!sys:serve-all-events))
1994         ;; Clear out any pending input to force the next read to go to
1995         ;; the disk.
1996         (setf (fd-stream-unread stream) nil)
1997         (setf (fd-stream-ibuf-head stream) 0)
1998         (setf (fd-stream-ibuf-tail stream) 0)
1999         ;; Trash cached value for listen, so that we check next time.
2000         (setf (fd-stream-listen stream) nil)
2001         ;; Now move it.
2002         (cond ((eq newpos :start)
2003                (setf offset 0 origin sb!unix:l_set))
2004               ((eq newpos :end)
2005                (setf offset 0 origin sb!unix:l_xtnd))
2006               ((typep newpos '(alien sb!unix:off-t))
2007                (setf offset (* newpos (fd-stream-element-size stream))
2008                      origin sb!unix:l_set))
2009               (t
2010                (error "invalid position given to FILE-POSITION: ~S" newpos)))
2011         (multiple-value-bind (posn errno)
2012             (sb!unix:unix-lseek (fd-stream-fd stream) offset origin)
2013           (cond ((typep posn '(alien sb!unix:off-t))
2014                  t)
2015                 ((eq errno sb!unix:espipe)
2016                  nil)
2017                 (t
2018                  (simple-stream-perror "error in Unix lseek() on ~S"
2019                                        stream
2020                                        errno)))))))
2021 \f
2022 ;;;; creation routines (MAKE-FD-STREAM and OPEN)
2023
2024 ;;; Create a stream for the given Unix file descriptor.
2025 ;;;
2026 ;;; If INPUT is non-NIL, allow input operations. If OUTPUT is non-nil,
2027 ;;; allow output operations. If neither INPUT nor OUTPUT is specified,
2028 ;;; default to allowing input.
2029 ;;;
2030 ;;; ELEMENT-TYPE indicates the element type to use (as for OPEN).
2031 ;;;
2032 ;;; BUFFERING indicates the kind of buffering to use.
2033 ;;;
2034 ;;; TIMEOUT (if true) is the number of seconds to wait for input. If
2035 ;;; NIL (the default), then wait forever. When we time out, we signal
2036 ;;; IO-TIMEOUT.
2037 ;;;
2038 ;;; FILE is the name of the file (will be returned by PATHNAME).
2039 ;;;
2040 ;;; NAME is used to identify the stream when printed.
2041 (defun make-fd-stream (fd
2042                        &key
2043                        (input nil input-p)
2044                        (output nil output-p)
2045                        (element-type 'base-char)
2046                        (buffering :full)
2047                        (external-format :default)
2048                        timeout
2049                        file
2050                        original
2051                        delete-original
2052                        pathname
2053                        input-buffer-p
2054                        dual-channel-p
2055                        (name (if file
2056                                  (format nil "file ~A" file)
2057                                  (format nil "descriptor ~W" fd)))
2058                        auto-close)
2059   (declare (type index fd) (type (or index null) timeout)
2060            (type (member :none :line :full) buffering))
2061   (cond ((not (or input-p output-p))
2062          (setf input t))
2063         ((not (or input output))
2064          (error "File descriptor must be opened either for input or output.")))
2065   (let ((stream (%make-fd-stream :fd fd
2066                                  :name name
2067                                  :file file
2068                                  :original original
2069                                  :delete-original delete-original
2070                                  :pathname pathname
2071                                  :buffering buffering
2072                                  :dual-channel-p dual-channel-p
2073                                  :external-format external-format
2074                                  :timeout timeout)))
2075     (set-fd-stream-routines stream element-type external-format
2076                             input output input-buffer-p)
2077     (when (and auto-close (fboundp 'finalize))
2078       (finalize stream
2079                 (lambda ()
2080                   (sb!unix:unix-close fd)
2081                   #!+sb-show
2082                   (format *terminal-io* "** closed file descriptor ~W **~%"
2083                           fd))))
2084     stream))
2085
2086 ;;; Pick a name to use for the backup file for the :IF-EXISTS
2087 ;;; :RENAME-AND-DELETE and :RENAME options.
2088 (defun pick-backup-name (name)
2089   (declare (type simple-string name))
2090   (concatenate 'simple-string name ".bak"))
2091
2092 ;;; Ensure that the given arg is one of the given list of valid
2093 ;;; things. Allow the user to fix any problems.
2094 (defun ensure-one-of (item list what)
2095   (unless (member item list)
2096     (error 'simple-type-error
2097            :datum item
2098            :expected-type `(member ,@list)
2099            :format-control "~@<~S is ~_invalid for ~S; ~_need one of~{ ~S~}~:>"
2100            :format-arguments (list item what list))))
2101
2102 ;;; Rename NAMESTRING to ORIGINAL. First, check whether we have write
2103 ;;; access, since we don't want to trash unwritable files even if we
2104 ;;; technically can. We return true if we succeed in renaming.
2105 (defun rename-the-old-one (namestring original)
2106   (unless (sb!unix:unix-access namestring sb!unix:w_ok)
2107     (error "~@<The file ~2I~_~S ~I~_is not writable.~:>" namestring))
2108   (multiple-value-bind (okay err) (sb!unix:unix-rename namestring original)
2109     (if okay
2110         t
2111         (error 'simple-file-error
2112                :pathname namestring
2113                :format-control
2114                "~@<couldn't rename ~2I~_~S ~I~_to ~2I~_~S: ~4I~_~A~:>"
2115                :format-arguments (list namestring original (strerror err))))))
2116
2117 (defun open (filename
2118              &key
2119              (direction :input)
2120              (element-type 'base-char)
2121              (if-exists nil if-exists-given)
2122              (if-does-not-exist nil if-does-not-exist-given)
2123              (external-format :default)
2124              &aux ; Squelch assignment warning.
2125              (direction direction)
2126              (if-does-not-exist if-does-not-exist)
2127              (if-exists if-exists))
2128   #!+sb-doc
2129   "Return a stream which reads from or writes to FILENAME.
2130   Defined keywords:
2131    :DIRECTION - one of :INPUT, :OUTPUT, :IO, or :PROBE
2132    :ELEMENT-TYPE - the type of object to read or write, default BASE-CHAR
2133    :IF-EXISTS - one of :ERROR, :NEW-VERSION, :RENAME, :RENAME-AND-DELETE,
2134                        :OVERWRITE, :APPEND, :SUPERSEDE or NIL
2135    :IF-DOES-NOT-EXIST - one of :ERROR, :CREATE or NIL
2136   See the manual for details."
2137
2138   ;; Calculate useful stuff.
2139   (multiple-value-bind (input output mask)
2140       (case direction
2141         (:input  (values   t nil sb!unix:o_rdonly))
2142         (:output (values nil   t sb!unix:o_wronly))
2143         (:io     (values   t   t sb!unix:o_rdwr))
2144         (:probe  (values   t nil sb!unix:o_rdonly)))
2145     (declare (type index mask))
2146     (let* ((pathname (merge-pathnames filename))
2147            (namestring
2148             (cond ((unix-namestring pathname input))
2149                   ((and input (eq if-does-not-exist :create))
2150                    (unix-namestring pathname nil))
2151                   ((and (eq direction :io) (not if-does-not-exist-given))
2152                    (unix-namestring pathname nil)))))
2153       ;; Process if-exists argument if we are doing any output.
2154       (cond (output
2155              (unless if-exists-given
2156                (setf if-exists
2157                      (if (eq (pathname-version pathname) :newest)
2158                          :new-version
2159                          :error)))
2160              (ensure-one-of if-exists
2161                             '(:error :new-version :rename
2162                                      :rename-and-delete :overwrite
2163                                      :append :supersede nil)
2164                             :if-exists)
2165              (case if-exists
2166                ((:new-version :error nil)
2167                 (setf mask (logior mask sb!unix:o_excl)))
2168                ((:rename :rename-and-delete)
2169                 (setf mask (logior mask sb!unix:o_creat)))
2170                ((:supersede)
2171                 (setf mask (logior mask sb!unix:o_trunc)))
2172                (:append
2173                 (setf mask (logior mask sb!unix:o_append)))))
2174             (t
2175              (setf if-exists :ignore-this-arg)))
2176
2177       (unless if-does-not-exist-given
2178         (setf if-does-not-exist
2179               (cond ((eq direction :input) :error)
2180                     ((and output
2181                           (member if-exists '(:overwrite :append)))
2182                      :error)
2183                     ((eq direction :probe)
2184                      nil)
2185                     (t
2186                      :create))))
2187       (ensure-one-of if-does-not-exist
2188                      '(:error :create nil)
2189                      :if-does-not-exist)
2190       (if (eq if-does-not-exist :create)
2191         (setf mask (logior mask sb!unix:o_creat)))
2192
2193       (let ((original (case if-exists
2194                         ((:rename :rename-and-delete)
2195                          (pick-backup-name namestring))
2196                         ((:append :overwrite)
2197                          ;; KLUDGE: Provent CLOSE from deleting
2198                          ;; appending streams when called with :ABORT T
2199                          namestring)))
2200             (delete-original (eq if-exists :rename-and-delete))
2201             (mode #o666))
2202         (when (and original (not (eq original namestring)))
2203           ;; We are doing a :RENAME or :RENAME-AND-DELETE. Determine
2204           ;; whether the file already exists, make sure the original
2205           ;; file is not a directory, and keep the mode.
2206           (let ((exists
2207                  (and namestring
2208                       (multiple-value-bind (okay err/dev inode orig-mode)
2209                           (sb!unix:unix-stat namestring)
2210                         (declare (ignore inode)
2211                                  (type (or index null) orig-mode))
2212                         (cond
2213                          (okay
2214                           (when (and output (= (logand orig-mode #o170000)
2215                                                #o40000))
2216                             (error 'simple-file-error
2217                                    :pathname namestring
2218                                    :format-control
2219                                    "can't open ~S for output: is a directory"
2220                                    :format-arguments (list namestring)))
2221                           (setf mode (logand orig-mode #o777))
2222                           t)
2223                          ((eql err/dev sb!unix:enoent)
2224                           nil)
2225                          (t
2226                           (simple-file-perror "can't find ~S"
2227                                               namestring
2228                                               err/dev)))))))
2229             (unless (and exists
2230                          (rename-the-old-one namestring original))
2231               (setf original nil)
2232               (setf delete-original nil)
2233               ;; In order to use :SUPERSEDE instead, we have to make
2234               ;; sure SB!UNIX:O_CREAT corresponds to
2235               ;; IF-DOES-NOT-EXIST. SB!UNIX:O_CREAT was set before
2236               ;; because of IF-EXISTS being :RENAME.
2237               (unless (eq if-does-not-exist :create)
2238                 (setf mask
2239                       (logior (logandc2 mask sb!unix:o_creat)
2240                               sb!unix:o_trunc)))
2241               (setf if-exists :supersede))))
2242
2243         ;; Now we can try the actual Unix open(2).
2244         (multiple-value-bind (fd errno)
2245             (if namestring
2246                 (sb!unix:unix-open namestring mask mode)
2247                 (values nil sb!unix:enoent))
2248           (labels ((open-error (format-control &rest format-arguments)
2249                      (error 'simple-file-error
2250                             :pathname pathname
2251                             :format-control format-control
2252                             :format-arguments format-arguments))
2253                    (vanilla-open-error ()
2254                      (simple-file-perror "error opening ~S" pathname errno)))
2255             (cond ((numberp fd)
2256                    (case direction
2257                      ((:input :output :io)
2258                       (make-fd-stream fd
2259                                       :input input
2260                                       :output output
2261                                       :element-type element-type
2262                                       :external-format external-format
2263                                       :file namestring
2264                                       :original original
2265                                       :delete-original delete-original
2266                                       :pathname pathname
2267                                       :dual-channel-p nil
2268                                       :input-buffer-p t
2269                                       :auto-close t))
2270                      (:probe
2271                       (let ((stream
2272                              (%make-fd-stream :name namestring
2273                                               :fd fd
2274                                               :pathname pathname
2275                                               :element-type element-type)))
2276                         (close stream)
2277                         stream))))
2278                   ((eql errno sb!unix:enoent)
2279                    (case if-does-not-exist
2280                      (:error (vanilla-open-error))
2281                      (:create
2282                       (open-error "~@<The path ~2I~_~S ~I~_does not exist.~:>"
2283                                   pathname))
2284                      (t nil)))
2285                   ((and (eql errno sb!unix:eexist) (null if-exists))
2286                    nil)
2287                   (t
2288                    (vanilla-open-error)))))))))
2289 \f
2290 ;;;; initialization
2291
2292 ;;; the stream connected to the controlling terminal, or NIL if there is none
2293 (defvar *tty*)
2294
2295 ;;; the stream connected to the standard input (file descriptor 0)
2296 (defvar *stdin*)
2297
2298 ;;; the stream connected to the standard output (file descriptor 1)
2299 (defvar *stdout*)
2300
2301 ;;; the stream connected to the standard error output (file descriptor 2)
2302 (defvar *stderr*)
2303
2304 ;;; This is called when the cold load is first started up, and may also
2305 ;;; be called in an attempt to recover from nested errors.
2306 (defun stream-cold-init-or-reset ()
2307   (stream-reinit)
2308   (setf *terminal-io* (make-synonym-stream '*tty*))
2309   (setf *standard-output* (make-synonym-stream '*stdout*))
2310   (setf *standard-input* (make-synonym-stream '*stdin*))
2311   (setf *error-output* (make-synonym-stream '*stderr*))
2312   (setf *query-io* (make-synonym-stream '*terminal-io*))
2313   (setf *debug-io* *query-io*)
2314   (setf *trace-output* *standard-output*)
2315   (values))
2316
2317 ;;; This is called whenever a saved core is restarted.
2318 (defun stream-reinit ()
2319   (setf *available-buffers* nil)
2320   (with-output-to-string (*error-output*)
2321     (setf *stdin*
2322           (make-fd-stream 0 :name "standard input" :input t :buffering :line
2323                             #!+win32 :external-format #!+win32 (sb!win32::console-input-codepage)))
2324     (setf *stdout*
2325           (make-fd-stream 1 :name "standard output" :output t :buffering :line
2326                             #!+win32 :external-format #!+win32 (sb!win32::console-output-codepage)))
2327     (setf *stderr*
2328           (make-fd-stream 2 :name "standard error" :output t :buffering :line
2329                             #!+win32 :external-format #!+win32 (sb!win32::console-output-codepage)))
2330     (let* ((ttyname #.(coerce "/dev/tty" 'simple-base-string))
2331            (tty (sb!unix:unix-open ttyname sb!unix:o_rdwr #o666)))
2332       (if tty
2333           (setf *tty*
2334                 (make-fd-stream tty
2335                                 :name "the terminal"
2336                                 :input t
2337                                 :output t
2338                                 :buffering :line
2339                                 :auto-close t))
2340           (setf *tty* (make-two-way-stream *stdin* *stdout*))))
2341     (princ (get-output-stream-string *error-output*) *stderr*))
2342   (values))
2343 \f
2344 ;;;; miscellany
2345
2346 ;;; the Unix way to beep
2347 (defun beep (stream)
2348   (write-char (code-char bell-char-code) stream)
2349   (finish-output stream))
2350
2351 ;;; This is kind of like FILE-POSITION, but is an internal hack used
2352 ;;; by the filesys stuff to get and set the file name.
2353 ;;;
2354 ;;; FIXME: misleading name, screwy interface
2355 (defun file-name (stream &optional new-name)
2356   (when (typep stream 'fd-stream)
2357       (cond (new-name
2358              (setf (fd-stream-pathname stream) new-name)
2359              (setf (fd-stream-file stream)
2360                    (unix-namestring new-name nil))
2361              t)
2362             (t
2363              (fd-stream-pathname stream)))))