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