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