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