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