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