src/code/fd-stream.lisp

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