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