src/code/fd-stream.lisp

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