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