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 FILE-STREAM structure
  35
  36 (defstruct (file-stream
  37             (:constructor %make-fd-stream)
  38             ;; KLUDGE: in an ideal world, maybe we'd rewrite
  39             ;; everything to use FILE-STREAM rather than simply
  40             ;; providing this hack for compatibility with the old
  41             ;; code.  However, CVS doesn't deal terribly well with
  42             ;; file renaming, so for now we use this
  43             ;; backward-compatibility feature.
  44             (:conc-name fd-stream-)
  45             (:predicate fd-stream-p)
  46             (:include ansi-stream
  47                       (misc #'fd-stream-misc-routine))
  48             (:copier nil))
  49
  50   ;; the name of this stream
  51   (name nil)
  52   ;; the file this stream is for
  53   (file nil)
  54   ;; the backup file namestring for the old file, for :IF-EXISTS
  55   ;; :RENAME or :RENAME-AND-DELETE.
  56   (original nil :type (or simple-string null))
  57   (delete-original nil)       ; for :if-exists :rename-and-delete
  58   ;;; the number of bytes per element
  59   (element-size 1 :type index)
  60   ;; the type of element being transfered
  61   (element-type 'base-char)
  62   ;; the Unix file descriptor
  63   (fd -1 :type fixnum)
  64   ;; controls when the output buffer is flushed
  65   (buffering :full :type (member :full :line :none))
  66   ;; character position (if known)
  67   (char-pos nil :type (or index null))
  68   ;; T if input is waiting on FD. :EOF if we hit EOF.
  69   (listen nil :type (member nil t :eof))
  70
  71   ;; the input buffer
  72   (unread nil)
  73   (ibuf-sap nil :type (or system-area-pointer null))
  74   (ibuf-length nil :type (or index null))
  75   (ibuf-head 0 :type index)
  76   (ibuf-tail 0 :type index)
  77
  78   ;; the output buffer
  79   (obuf-sap nil :type (or system-area-pointer null))
  80   (obuf-length nil :type (or index null))
  81   (obuf-tail 0 :type index)
  82
  83   ;; output flushed, but not written due to non-blocking io?
  84   (output-later nil)
  85   (handler nil)
  86   ;; timeout specified for this stream, or NIL if none
  87   (timeout nil :type (or index null))
  88   ;; pathname of the file this stream is opened to (returned by PATHNAME)
  89   (pathname nil :type (or pathname null)))
  90 (def!method print-object ((fd-stream file-stream) stream)
  91   (declare (type stream stream))
  92   (print-unreadable-object (fd-stream stream :type t :identity t)
  93     (format stream "for ~S" (fd-stream-name fd-stream))))
  94 \f
  95 ;;;; output routines and related noise
  96
  97 (defvar *output-routines* ()
  98   #!+sb-doc
  99   "List of all available output routines. Each element is a list of the
 100   element-type output, the kind of buffering, the function name, and the number
 101   of bytes per element.")
 102
 103 ;;; common idioms for reporting low-level stream and file problems
 104 (defun simple-stream-perror (note-format stream errno)
 105   (error 'simple-stream-error
 106          :stream stream
 107          :format-control "~@<~?: ~2I~_~A~:>"
 108          :format-arguments (list note-format (list stream) (strerror errno))))
 109 (defun simple-file-perror (note-format pathname errno)
 110   (error 'simple-file-error
 111          :pathname pathname
 112          :format-control "~@<~?: ~2I~_~A~:>"
 113          :format-arguments
 114          (list note-format (list pathname) (strerror errno))))
 115
 116 ;;; This is called by the server when we can write to the given file
 117 ;;; descriptor. Attempt to write the data again. If it worked, remove
 118 ;;; the data from the OUTPUT-LATER list. If it didn't work, something
 119 ;;; is wrong.
 120 (defun frob-output-later (stream)
 121   (let* ((stuff (pop (fd-stream-output-later stream)))
 122          (base (car stuff))
 123          (start (cadr stuff))
 124          (end (caddr stuff))
 125          (reuse-sap (cadddr stuff))
 126          (length (- end start)))
 127     (declare (type index start end length))
 128     (multiple-value-bind (count errno)
 129         (sb!unix:unix-write (fd-stream-fd stream)
 130                             base
 131                             start
 132                             length)
 133       (cond ((not count)
 134              (if (= errno sb!unix:ewouldblock)
 135                  (error "Write would have blocked, but SERVER told us to go.")
 136                  (simple-stream-perror "couldn't write to ~S" stream errno)))
 137             ((eql count length) ; Hot damn, it worked.
 138              (when reuse-sap
 139                (push base *available-buffers*)))
 140             ((not (null count)) ; sorta worked..
 141              (push (list base
 142                          (the index (+ start count))
 143                          end)
 144                    (fd-stream-output-later stream))))))
 145   (unless (fd-stream-output-later stream)
 146     (sb!sys:remove-fd-handler (fd-stream-handler stream))
 147     (setf (fd-stream-handler stream) nil)))
 148
 149 ;;; Arange to output the string when we can write on the file descriptor.
 150 (defun output-later (stream base start end reuse-sap)
 151   (cond ((null (fd-stream-output-later stream))
 152          (setf (fd-stream-output-later stream)
 153                (list (list base start end reuse-sap)))
 154          (setf (fd-stream-handler stream)
 155                (sb!sys:add-fd-handler (fd-stream-fd stream)
 156                                       :output
 157                                       (lambda (fd)
 158                                         (declare (ignore fd))
 159                                         (frob-output-later stream)))))
 160         (t
 161          (nconc (fd-stream-output-later stream)
 162                 (list (list base start end reuse-sap)))))
 163   (when reuse-sap
 164     (let ((new-buffer (next-available-buffer)))
 165       (setf (fd-stream-obuf-sap stream) new-buffer)
 166       (setf (fd-stream-obuf-length stream) bytes-per-buffer))))
 167
 168 ;;; Output the given noise. Check to see whether there are any pending
 169 ;;; writes. If so, just queue this one. Otherwise, try to write it. If
 170 ;;; this would block, queue it.
 171 (defun frob-output (stream base start end reuse-sap)
 172   (declare (type file-stream stream)
 173            (type (or system-area-pointer (simple-array * (*))) base)
 174            (type index start end))
 175   (if (not (null (fd-stream-output-later stream))) ; something buffered.
 176       (progn
 177         (output-later stream base start end reuse-sap)
 178         ;; ### check to see whether any of this noise can be output
 179         )
 180       (let ((length (- end start)))
 181         (multiple-value-bind (count errno)
 182             (sb!unix:unix-write (fd-stream-fd stream) base start length)
 183           (cond ((not count)
 184                  (if (= errno sb!unix:ewouldblock)
 185                      (output-later stream base start end reuse-sap)
 186                      (simple-stream-perror "couldn't write to ~S"
 187                                            stream
 188                                            errno)))
 189                 ((not (eql count length))
 190                  (output-later stream base (the index (+ start count))
 191                                end reuse-sap)))))))
 192
 193 ;;; Flush any data in the output buffer.
 194 (defun flush-output-buffer (stream)
 195   (let ((length (fd-stream-obuf-tail stream)))
 196     (unless (= length 0)
 197       (frob-output stream (fd-stream-obuf-sap stream) 0 length t)
 198       (setf (fd-stream-obuf-tail stream) 0))))
 199
 200 (defmacro output-wrapper ((stream size buffering) &body body)
 201   (let ((stream-var (gensym)))
 202     `(let ((,stream-var ,stream))
 203       ,(unless (eq (car buffering) :none)
 204          `(when (< (fd-stream-obuf-length ,stream-var)
 205                    (+ (fd-stream-obuf-tail ,stream-var)
 206                        ,size))
 207             (flush-output-buffer ,stream-var)))
 208       ,(unless (eq (car buffering) :none)
 209          `(when (> (fd-stream-ibuf-tail ,stream-var)
 210                    (fd-stream-ibuf-head ,stream-var))
 211             (file-position ,stream-var (file-position ,stream-var))))
 212
 213       ,@body
 214       (incf (fd-stream-obuf-tail ,stream-var) ,size)
 215       ,(ecase (car buffering)
 216          (:none
 217           `(flush-output-buffer ,stream-var))
 218          (:line
 219           `(when (eq (char-code byte) (char-code #\Newline))
 220              (flush-output-buffer ,stream-var)))
 221          (:full))
 222     (values))))
 223
 224 ;;; Define output routines that output numbers SIZE bytes long for the
 225 ;;; given bufferings. Use BODY to do the actual output.
 226 (defmacro def-output-routines ((name-fmt size &rest bufferings) &body body)
 227   (declare (optimize (speed 1)))
 228   (cons 'progn
 229         (mapcar
 230             (lambda (buffering)
 231               (let ((function
 232                      (intern (let ((*print-case* :upcase))
 233                                (format nil name-fmt (car buffering))))))
 234                 `(progn
 235                    (defun ,function (stream byte)
 236                      (output-wrapper (stream ,size ,buffering)
 237                        ,@body))
 238                    (setf *output-routines*
 239                          (nconc *output-routines*
 240                                 ',(mapcar
 241                                    (lambda (type)
 242                                      (list type
 243                                            (car buffering)
 244                                            function
 245                                            size))
 246                                    (cdr buffering)))))))
 247             bufferings)))
 248
 249 (def-output-routines ("OUTPUT-CHAR-~A-BUFFERED"
 250                       1
 251                       (:none character)
 252                       (:line character)
 253                       (:full character))
 254   (if (char= byte #\Newline)
 255       (setf (fd-stream-char-pos stream) 0)
 256       (incf (fd-stream-char-pos stream)))
 257   (setf (sap-ref-8 (fd-stream-obuf-sap stream) (fd-stream-obuf-tail stream))
 258         (char-code byte)))
 259
 260 (def-output-routines ("OUTPUT-UNSIGNED-BYTE-~A-BUFFERED"
 261                       1
 262                       (:none (unsigned-byte 8))
 263                       (:full (unsigned-byte 8)))
 264   (setf (sap-ref-8 (fd-stream-obuf-sap stream) (fd-stream-obuf-tail stream))
 265         byte))
 266
 267 (def-output-routines ("OUTPUT-SIGNED-BYTE-~A-BUFFERED"
 268                       1
 269                       (:none (signed-byte 8))
 270                       (:full (signed-byte 8)))
 271   (setf (signed-sap-ref-8 (fd-stream-obuf-sap stream)
 272                           (fd-stream-obuf-tail stream))
 273         byte))
 274
 275 (def-output-routines ("OUTPUT-UNSIGNED-SHORT-~A-BUFFERED"
 276                       2
 277                       (:none (unsigned-byte 16))
 278                       (:full (unsigned-byte 16)))
 279   (setf (sap-ref-16 (fd-stream-obuf-sap stream) (fd-stream-obuf-tail stream))
 280         byte))
 281
 282 (def-output-routines ("OUTPUT-SIGNED-SHORT-~A-BUFFERED"
 283                       2
 284                       (:none (signed-byte 16))
 285                       (:full (signed-byte 16)))
 286   (setf (signed-sap-ref-16 (fd-stream-obuf-sap stream)
 287                            (fd-stream-obuf-tail stream))
 288         byte))
 289
 290 (def-output-routines ("OUTPUT-UNSIGNED-LONG-~A-BUFFERED"
 291                       4
 292                       (:none (unsigned-byte 32))
 293                       (:full (unsigned-byte 32)))
 294   (setf (sap-ref-32 (fd-stream-obuf-sap stream) (fd-stream-obuf-tail stream))
 295         byte))
 296
 297 (def-output-routines ("OUTPUT-SIGNED-LONG-~A-BUFFERED"
 298                       4
 299                       (:none (signed-byte 32))
 300                       (:full (signed-byte 32)))
 301   (setf (signed-sap-ref-32 (fd-stream-obuf-sap stream)
 302                            (fd-stream-obuf-tail stream))
 303         byte))
 304
 305 ;;; Do the actual output. If there is space to buffer the string,
 306 ;;; buffer it. If the string would normally fit in the buffer, but
 307 ;;; doesn't because of other stuff in the buffer, flush the old noise
 308 ;;; out of the buffer and put the string in it. Otherwise we have a
 309 ;;; very long string, so just send it directly (after flushing the
 310 ;;; buffer, of course).
 311 (defun output-raw-bytes (fd-stream thing &optional start end)
 312   #!+sb-doc
 313   "Output THING to FD-STREAM. THING can be any kind of vector or a SAP. If
 314   THING is a SAP, END must be supplied (as length won't work)."
 315   (let ((start (or start 0))
 316         (end (or end (length (the (simple-array * (*)) thing)))))
 317     (declare (type index start end))
 318     (when (> (fd-stream-ibuf-tail fd-stream)
 319              (fd-stream-ibuf-head fd-stream))
 320       (file-position fd-stream (file-position fd-stream)))
 321     (let* ((len (fd-stream-obuf-length fd-stream))
 322            (tail (fd-stream-obuf-tail fd-stream))
 323            (space (- len tail))
 324            (bytes (- end start))
 325            (newtail (+ tail bytes)))
 326       (cond ((minusp bytes) ; error case
 327              (error ":END before :START!"))
 328             ((zerop bytes)) ; easy case
 329             ((<= bytes space)
 330              (if (system-area-pointer-p thing)
 331                  (system-area-copy thing
 332                                    (* start sb!vm:n-byte-bits)
 333                                    (fd-stream-obuf-sap fd-stream)
 334                                    (* tail sb!vm:n-byte-bits)
 335                                    (* bytes sb!vm:n-byte-bits))
 336                  ;; FIXME: There should be some type checking somewhere to
 337                  ;; verify that THING here is a vector, not just <not a SAP>.
 338                  (copy-to-system-area thing
 339                                       (+ (* start sb!vm:n-byte-bits)
 340                                          (* sb!vm:vector-data-offset
 341                                             sb!vm:n-word-bits))
 342                                       (fd-stream-obuf-sap fd-stream)
 343                                       (* tail sb!vm:n-byte-bits)
 344                                       (* bytes sb!vm:n-byte-bits)))
 345              (setf (fd-stream-obuf-tail fd-stream) newtail))
 346             ((<= bytes len)
 347              (flush-output-buffer fd-stream)
 348              (if (system-area-pointer-p thing)
 349                  (system-area-copy thing
 350                                    (* start sb!vm:n-byte-bits)
 351                                    (fd-stream-obuf-sap fd-stream)
 352                                    0
 353                                    (* bytes sb!vm:n-byte-bits))
 354                  ;; FIXME: There should be some type checking somewhere to
 355                  ;; verify that THING here is a vector, not just <not a SAP>.
 356                  (copy-to-system-area thing
 357                                       (+ (* start sb!vm:n-byte-bits)
 358                                          (* sb!vm:vector-data-offset
 359                                             sb!vm:n-word-bits))
 360                                       (fd-stream-obuf-sap fd-stream)
 361                                       0
 362                                       (* bytes sb!vm:n-byte-bits)))
 363              (setf (fd-stream-obuf-tail fd-stream) bytes))
 364             (t
 365              (flush-output-buffer fd-stream)
 366              (frob-output fd-stream thing start end nil))))))
 367
 368 ;;; the routine to use to output a string. If the stream is
 369 ;;; unbuffered, slam the string down the file descriptor, otherwise
 370 ;;; use OUTPUT-RAW-BYTES to buffer the string. Update charpos by
 371 ;;; checking to see where the last newline was.
 372 ;;;
 373 ;;; Note: some bozos (the FASL dumper) call write-string with things
 374 ;;; other than strings. Therefore, we must make sure we have a string
 375 ;;; before calling POSITION on it.
 376 ;;; KLUDGE: It would be better to fix the bozos instead of trying to
 377 ;;; cover for them here. -- WHN 20000203
 378 (defun fd-sout (stream thing start end)
 379   (let ((start (or start 0))
 380         (end (or end (length (the vector thing)))))
 381     (declare (fixnum start end))
 382     (if (stringp thing)
 383         (let ((last-newline (and (find #\newline (the simple-string thing)
 384                                        :start start :end end)
 385                                  ;; FIXME why do we need both calls?
 386                                  ;; Is find faster forwards than
 387                                  ;; position is backwards?
 388                                  (position #\newline (the simple-string thing)
 389                                            :from-end t
 390                                            :start start
 391                                            :end end))))
 392           (ecase (fd-stream-buffering stream)
 393             (:full
 394              (output-raw-bytes stream thing start end))
 395             (:line
 396              (output-raw-bytes stream thing start end)
 397              (when last-newline
 398                (flush-output-buffer stream)))
 399             (:none
 400              (frob-output stream thing start end nil)))
 401           (if last-newline
 402               (setf (fd-stream-char-pos stream)
 403                     (- end last-newline 1))
 404               (incf (fd-stream-char-pos stream)
 405                     (- end start))))
 406         (ecase (fd-stream-buffering stream)
 407           ((:line :full)
 408            (output-raw-bytes stream thing start end))
 409           (:none
 410            (frob-output stream thing start end nil))))))
 411
 412 ;;; Find an output routine to use given the type and buffering. Return
 413 ;;; as multiple values the routine, the real type transfered, and the
 414 ;;; number of bytes per element.
 415 (defun pick-output-routine (type buffering)
 416   (dolist (entry *output-routines*)
 417     (when (and (subtypep type (car entry))
 418                (eq buffering (cadr entry)))
 419       (return-from pick-output-routine
 420         (values (symbol-function (caddr entry))
 421                 (car entry)
 422                 (cadddr entry)))))
 423   ;; KLUDGE: dealing with the buffering here leads to excessive code
 424   ;; explosion.
 425   ;;
 426   ;; KLUDGE: also see comments in PICK-INPUT-ROUTINE
 427   (loop for i from 40 by 8 to 1024 ; ARB (KLUDGE)
 428         if (subtypep type `(unsigned-byte ,i))
 429         do (return-from pick-output-routine
 430              (values
 431               (ecase buffering
 432                 (:none
 433                  (lambda (stream byte)
 434                    (output-wrapper (stream (/ i 8) (:none))
 435                      (loop for j from 0 below (/ i 8)
 436                            do (setf (sap-ref-8
 437                                      (fd-stream-obuf-sap stream)
 438                                      (+ j (fd-stream-obuf-tail stream)))
 439                                     (ldb (byte 8 (- i 8 (* j 8))) byte))))))
 440                 (:full
 441                  (lambda (stream byte)
 442                    (output-wrapper (stream (/ i 8) (:full))
 443                      (loop for j from 0 below (/ i 8)
 444                            do (setf (sap-ref-8
 445                                      (fd-stream-obuf-sap stream)
 446                                      (+ j (fd-stream-obuf-tail stream)))
 447                                     (ldb (byte 8 (- i 8 (* j 8))) byte)))))))
 448               `(unsigned-byte ,i)
 449               (/ i 8))))
 450   (loop for i from 40 by 8 to 1024 ; ARB (KLUDGE)
 451         if (subtypep type `(signed-byte ,i))
 452         do (return-from pick-output-routine
 453              (values
 454               (ecase buffering
 455                 (:none
 456                  (lambda (stream byte)
 457                    (output-wrapper (stream (/ i 8) (:none))
 458                      (loop for j from 0 below (/ i 8)
 459                            do (setf (sap-ref-8
 460                                      (fd-stream-obuf-sap stream)
 461                                      (+ j (fd-stream-obuf-tail stream)))
 462                                     (ldb (byte 8 (- i 8 (* j 8))) byte))))))
 463                 (:full
 464                  (lambda (stream byte)
 465                    (output-wrapper (stream (/ i 8) (:full))
 466                      (loop for j from 0 below (/ i 8)
 467                            do (setf (sap-ref-8
 468                                      (fd-stream-obuf-sap stream)
 469                                      (+ j (fd-stream-obuf-tail stream)))
 470                                     (ldb (byte 8 (- i 8 (* j 8))) byte)))))))
 471               `(signed-byte ,i)
 472               (/ i 8)))))
 473 \f
 474 ;;;; input routines and related noise
 475
 476 ;;; a list of all available input routines. Each element is a list of
 477 ;;; the element-type input, the function name, and the number of bytes
 478 ;;; per element.
 479 (defvar *input-routines* ())
 480
 481 ;;; Fill the input buffer, and return the first character. Throw to
 482 ;;; EOF-INPUT-CATCHER if the eof was reached. Drop into SYSTEM:SERVER
 483 ;;; if necessary.
 484 (defun frob-input (stream)
 485   (let ((fd (fd-stream-fd stream))
 486         (ibuf-sap (fd-stream-ibuf-sap stream))
 487         (buflen (fd-stream-ibuf-length stream))
 488         (head (fd-stream-ibuf-head stream))
 489         (tail (fd-stream-ibuf-tail stream)))
 490     (declare (type index head tail))
 491     (unless (zerop head)
 492       (cond ((eql head tail)
 493              (setf head 0)
 494              (setf tail 0)
 495              (setf (fd-stream-ibuf-head stream) 0)
 496              (setf (fd-stream-ibuf-tail stream) 0))
 497             (t
 498              (decf tail head)
 499              (system-area-copy ibuf-sap (* head sb!vm:n-byte-bits)
 500                                ibuf-sap 0 (* tail sb!vm:n-byte-bits))
 501              (setf head 0)
 502              (setf (fd-stream-ibuf-head stream) 0)
 503              (setf (fd-stream-ibuf-tail stream) tail))))
 504     (setf (fd-stream-listen stream) nil)
 505     (multiple-value-bind (count errno)
 506         ;; FIXME: Judging from compiler warnings, this WITH-ALIEN form expands
 507         ;; into something which uses the not-yet-defined type
 508         ;;   (SB!ALIEN-INTERNALS:ALIEN (* (SB!ALIEN:STRUCT SB!UNIX:FD-SET))).
 509         ;; This is probably inefficient and unsafe and generally bad, so
 510         ;; try to find some way to make that type known before
 511         ;; this is compiled.
 512         (sb!alien:with-alien ((read-fds (sb!alien:struct sb!unix:fd-set)))
 513           (sb!unix:fd-zero read-fds)
 514           (sb!unix:fd-set fd read-fds)
 515           (sb!unix:unix-fast-select (1+ fd)
 516                                     (sb!alien:addr read-fds)
 517                                     nil
 518                                     nil
 519                                     0
 520                                     0))
 521       (case count
 522         (1)
 523         (0
 524          (unless (sb!sys:wait-until-fd-usable
 525                   fd :input (fd-stream-timeout stream))
 526            (error 'io-timeout :stream stream :direction :read)))
 527         (t
 528          (simple-stream-perror "couldn't check whether ~S is readable"
 529                                stream
 530                                errno))))
 531     (multiple-value-bind (count errno)
 532         (sb!unix:unix-read fd
 533                            (sb!sys:int-sap (+ (sb!sys:sap-int ibuf-sap) tail))
 534                            (- buflen tail))
 535       (cond ((null count)
 536              (if (eql errno sb!unix:ewouldblock)
 537                  (progn
 538                    (unless (sb!sys:wait-until-fd-usable
 539                             fd :input (fd-stream-timeout stream))
 540                      (error 'io-timeout :stream stream :direction :read))
 541                    (frob-input stream))
 542                  (simple-stream-perror "couldn't read from ~S" stream errno)))
 543             ((zerop count)
 544              (setf (fd-stream-listen stream) :eof)
 545              (/show0 "THROWing EOF-INPUT-CATCHER")
 546              (throw 'eof-input-catcher nil))
 547             (t
 548              (incf (fd-stream-ibuf-tail stream) count))))))
 549
 550 ;;; Make sure there are at least BYTES number of bytes in the input
 551 ;;; buffer. Keep calling FROB-INPUT until that condition is met.
 552 (defmacro input-at-least (stream bytes)
 553   (let ((stream-var (gensym))
 554         (bytes-var (gensym)))
 555     `(let ((,stream-var ,stream)
 556            (,bytes-var ,bytes))
 557        (loop
 558          (when (>= (- (fd-stream-ibuf-tail ,stream-var)
 559                       (fd-stream-ibuf-head ,stream-var))
 560                    ,bytes-var)
 561            (return))
 562          (frob-input ,stream-var)))))
 563
 564 ;;; a macro to wrap around all input routines to handle EOF-ERROR noise
 565 (defmacro input-wrapper ((stream bytes eof-error eof-value) &body read-forms)
 566   (let ((stream-var (gensym))
 567         (element-var (gensym)))
 568     `(let ((,stream-var ,stream))
 569        (if (fd-stream-unread ,stream-var)
 570            (prog1
 571                (fd-stream-unread ,stream-var)
 572              (setf (fd-stream-unread ,stream-var) nil)
 573              (setf (fd-stream-listen ,stream-var) nil))
 574            (let ((,element-var
 575                   (catch 'eof-input-catcher
 576                     (input-at-least ,stream-var ,bytes)
 577                     (locally ,@read-forms))))
 578              (cond (,element-var
 579                     (incf (fd-stream-ibuf-head ,stream-var) ,bytes)
 580                     ,element-var)
 581                    (t
 582                     (eof-or-lose ,stream-var ,eof-error ,eof-value))))))))
 583
 584 (defmacro def-input-routine (name
 585                              (type size sap head)
 586                              &rest body)
 587   `(progn
 588      (defun ,name (stream eof-error eof-value)
 589        (input-wrapper (stream ,size eof-error eof-value)
 590          (let ((,sap (fd-stream-ibuf-sap stream))
 591                (,head (fd-stream-ibuf-head stream)))
 592            ,@body)))
 593      (setf *input-routines*
 594            (nconc *input-routines*
 595                   (list (list ',type ',name ',size))))))
 596
 597 ;;; STREAM-IN routine for reading a string char
 598 (def-input-routine input-character
 599                    (character 1 sap head)
 600   (code-char (sap-ref-8 sap head)))
 601
 602 ;;; STREAM-IN routine for reading an unsigned 8 bit number
 603 (def-input-routine input-unsigned-8bit-byte
 604                    ((unsigned-byte 8) 1 sap head)
 605   (sap-ref-8 sap head))
 606
 607 ;;; STREAM-IN routine for reading a signed 8 bit number
 608 (def-input-routine input-signed-8bit-number
 609                    ((signed-byte 8) 1 sap head)
 610   (signed-sap-ref-8 sap head))
 611
 612 ;;; STREAM-IN routine for reading an unsigned 16 bit number
 613 (def-input-routine input-unsigned-16bit-byte
 614                    ((unsigned-byte 16) 2 sap head)
 615   (sap-ref-16 sap head))
 616
 617 ;;; STREAM-IN routine for reading a signed 16 bit number
 618 (def-input-routine input-signed-16bit-byte
 619                    ((signed-byte 16) 2 sap head)
 620   (signed-sap-ref-16 sap head))
 621
 622 ;;; STREAM-IN routine for reading a unsigned 32 bit number
 623 (def-input-routine input-unsigned-32bit-byte
 624                    ((unsigned-byte 32) 4 sap head)
 625   (sap-ref-32 sap head))
 626
 627 ;;; STREAM-IN routine for reading a signed 32 bit number
 628 (def-input-routine input-signed-32bit-byte
 629                    ((signed-byte 32) 4 sap head)
 630   (signed-sap-ref-32 sap head))
 631
 632 ;;; Find an input routine to use given the type. Return as multiple
 633 ;;; values the routine, the real type transfered, and the number of
 634 ;;; bytes per element.
 635 (defun pick-input-routine (type)
 636   (dolist (entry *input-routines*)
 637     (when (subtypep type (car entry))
 638       (return-from pick-input-routine
 639         (values (symbol-function (cadr entry))
 640                 (car entry)
 641                 (caddr entry)))))
 642   ;; FIXME: let's do it the hard way, then (but ignore things like
 643   ;; endianness, efficiency, and the necessary coupling between these
 644   ;; and the output routines).  -- CSR, 2004-02-09
 645   (loop for i from 40 by 8 to 1024 ; ARB (well, KLUDGE really)
 646         if (subtypep type `(unsigned-byte ,i))
 647         do (return-from pick-input-routine
 648              (values
 649               (lambda (stream eof-error eof-value)
 650                 (input-wrapper (stream (/ i 8) eof-error eof-value)
 651                   (let ((sap (fd-stream-ibuf-sap stream))
 652                         (head (fd-stream-ibuf-head stream)))
 653                     (loop for j from 0 below (/ i 8)
 654                           with result = 0
 655                           do (setf result
 656                                    (+ (* 256 result)
 657                                       (sap-ref-8 sap (+ head j))))
 658                           finally (return result)))))
 659               `(unsigned-byte ,i)
 660               (/ i 8))))
 661   (loop for i from 40 by 8 to 1024 ; ARB (well, KLUDGE really)
 662         if (subtypep type `(signed-byte ,i))
 663         do (return-from pick-input-routine
 664              (values
 665               (lambda (stream eof-error eof-value)
 666                 (input-wrapper (stream (/ i 8) eof-error eof-value)
 667                   (let ((sap (fd-stream-ibuf-sap stream))
 668                         (head (fd-stream-ibuf-head stream)))
 669                     (loop for j from 0 below (/ i 8)
 670                           with result = 0
 671                           do (setf result
 672                                    (+ (* 256 result)
 673                                       (sap-ref-8 sap (+ head j))))
 674                           finally (return (if (logbitp (1- i) result)
 675                                               (dpb result (byte i 0) -1)
 676                                               result))))))
 677               `(signed-byte ,i)
 678               (/ i 8)))))
 679
 680 ;;; Return a string constructed from SAP, START, and END.
 681 (defun string-from-sap (sap start end)
 682   (declare (type index start end))
 683   (let* ((length (- end start))
 684          (string (make-string length)))
 685     (copy-from-system-area sap (* start sb!vm:n-byte-bits)
 686                            string (* sb!vm:vector-data-offset
 687                                      sb!vm:n-word-bits)
 688                            (* length sb!vm:n-byte-bits))
 689     string))
 690
 691 ;;; the N-BIN method for FD-STREAMs
 692 ;;;
 693 ;;; Note that this blocks in UNIX-READ. It is generally used where
 694 ;;; there is a definite amount of reading to be done, so blocking
 695 ;;; isn't too problematical.
 696 (defun fd-stream-read-n-bytes (stream buffer start requested eof-error-p
 697                                &aux (total-copied 0))
 698   (declare (type file-stream stream))
 699   (declare (type index start requested total-copied))
 700   (let ((unread (fd-stream-unread stream)))
 701     (when unread
 702       ;; AVERs designed to fail when we have more complicated
 703       ;; character representations.
 704       (aver (typep unread 'base-char))
 705       (aver (= (fd-stream-element-size stream) 1))
 706       ;; KLUDGE: this is a slightly-unrolled-and-inlined version of
 707       ;; %BYTE-BLT
 708       (etypecase buffer
 709         (system-area-pointer
 710          (setf (sap-ref-8 buffer start) (char-code unread)))
 711         ((simple-unboxed-array (*))
 712          (setf (aref buffer start) unread)))
 713       (setf (fd-stream-unread stream) nil)
 714       (setf (fd-stream-listen stream) nil)
 715       (incf total-copied)))
 716   (do ()
 717       (nil)
 718     (let* ((remaining-request (- requested total-copied))
 719            (head (fd-stream-ibuf-head stream))
 720            (tail (fd-stream-ibuf-tail stream))
 721            (available (- tail head))
 722            (n-this-copy (min remaining-request available))
 723            (this-start (+ start total-copied))
 724            (this-end (+ this-start n-this-copy))
 725            (sap (fd-stream-ibuf-sap stream)))
 726       (declare (type index remaining-request head tail available))
 727       (declare (type index n-this-copy))
 728       ;; Copy data from stream buffer into user's buffer.
 729       (%byte-blt sap head buffer this-start this-end)
 730       (incf (fd-stream-ibuf-head stream) n-this-copy)
 731       (incf total-copied n-this-copy)
 732       ;; Maybe we need to refill the stream buffer.
 733       (cond (;; If there were enough data in the stream buffer, we're done.
 734              (= total-copied requested)
 735              (return total-copied))
 736             (;; If EOF, we're done in another way.
 737              (zerop (refill-fd-stream-buffer stream))
 738              (if eof-error-p
 739                  (error 'end-of-file :stream stream)
 740                  (return total-copied)))
 741             ;; Otherwise we refilled the stream buffer, so fall
 742             ;; through into another pass of the loop.
 743             ))))
 744
 745 ;;; Try to refill the stream buffer. Return the number of bytes read.
 746 ;;; (For EOF, the return value will be zero, otherwise positive.)
 747 (defun refill-fd-stream-buffer (stream)
 748   ;; We don't have any logic to preserve leftover bytes in the buffer,
 749   ;; so we should only be called when the buffer is empty.
 750   ;; FIXME: can have three bytes in buffer because of UTF-8
 751   (let ((new-head 0)
 752         (sap (fd-stream-ibuf-sap stream)))
 753     (do ((head (fd-stream-ibuf-head stream) (1+ head))
 754          (tail (fd-stream-ibuf-tail stream)))
 755         ((= head tail))
 756       (setf (sap-ref-8 sap new-head) (sap-ref-8 sap head))
 757       (incf new-head))
 758     (multiple-value-bind (count err)
 759         (sb!unix:unix-read (fd-stream-fd stream)
 760                            (sap+ sap new-head)
 761                            (- (fd-stream-ibuf-length stream) new-head))
 762       (declare (type (or index null) count))
 763       (when (null count)
 764         (simple-stream-perror "couldn't read from ~S" stream err))
 765       (setf (fd-stream-listen stream) nil
 766             (fd-stream-ibuf-head stream) new-head
 767             (fd-stream-ibuf-tail stream) (+ count new-head))
 768       count)))
 769 \f
 770 ;;;; utility functions (misc routines, etc)
 771
 772 ;;; Fill in the various routine slots for the given type. INPUT-P and
 773 ;;; OUTPUT-P indicate what slots to fill. The buffering slot must be
 774 ;;; set prior to calling this routine.
 775 (defun set-fd-stream-routines (fd-stream type input-p output-p buffer-p)
 776   (let ((target-type (case type
 777                        ((:default unsigned-byte)
 778                         '(unsigned-byte 8))
 779                        (signed-byte
 780                         '(signed-byte 8))
 781                        (t
 782                         type)))
 783         (input-type nil)
 784         (output-type nil)
 785         (input-size nil)
 786         (output-size nil)
 787         (character-stream-p (subtypep type 'character)))
 788
 789     (when (fd-stream-obuf-sap fd-stream)
 790       (push (fd-stream-obuf-sap fd-stream) *available-buffers*)
 791       (setf (fd-stream-obuf-sap fd-stream) nil))
 792     (when (fd-stream-ibuf-sap fd-stream)
 793       (push (fd-stream-ibuf-sap fd-stream) *available-buffers*)
 794       (setf (fd-stream-ibuf-sap fd-stream) nil))
 795
 796     (when input-p
 797       (multiple-value-bind (routine type size)
 798           (pick-input-routine target-type)
 799         (unless routine
 800           (error "could not find any input routine for ~S" target-type))
 801         (setf (fd-stream-ibuf-sap fd-stream) (next-available-buffer))
 802         (setf (fd-stream-ibuf-length fd-stream) bytes-per-buffer)
 803         (setf (fd-stream-ibuf-tail fd-stream) 0)
 804         (if character-stream-p
 805             (setf (fd-stream-in fd-stream) routine
 806                   (fd-stream-bin fd-stream) #'ill-bin)
 807             (setf (fd-stream-in fd-stream) #'ill-in
 808                   (fd-stream-bin fd-stream) routine))
 809         (when (eql size 1)
 810           (setf (fd-stream-n-bin fd-stream) #'fd-stream-read-n-bytes)
 811           (when (and buffer-p
 812                      ;; We only create this buffer for streams of type
 813                      ;; (unsigned-byte 8).  Because there's no buffer, the
 814                      ;; other element-types will dispatch to the appropriate
 815                      ;; input (output) routine in fast-read-byte.
 816                      (or character-stream-p
 817                          (equal target-type '(unsigned-byte 8)))
 818                      (not output-p) ; temporary disable on :io streams
 819                      #+(or)
 820                      (or (eq type 'unsigned-byte)
 821                          (eq type :default)))
 822             (if character-stream-p
 823                 (setf (ansi-stream-cin-buffer fd-stream)
 824                       (make-array +ansi-stream-in-buffer-length+
 825                                   :element-type 'character))
 826                 (setf (ansi-stream-in-buffer fd-stream)
 827                       (make-array +ansi-stream-in-buffer-length+
 828                                   :element-type '(unsigned-byte 8))))))
 829         (setf input-size size)
 830         (setf input-type type)))
 831
 832     (when output-p
 833       (multiple-value-bind (routine type size)
 834           (pick-output-routine target-type (fd-stream-buffering fd-stream))
 835         (unless routine
 836           (error "could not find any output routine for ~S buffered ~S"
 837                  (fd-stream-buffering fd-stream)
 838                  target-type))
 839         (setf (fd-stream-obuf-sap fd-stream) (next-available-buffer))
 840         (setf (fd-stream-obuf-length fd-stream) bytes-per-buffer)
 841         (setf (fd-stream-obuf-tail fd-stream) 0)
 842         (if (subtypep type 'character)
 843           (setf (fd-stream-out fd-stream) routine
 844                 (fd-stream-bout fd-stream) #'ill-bout)
 845           (setf (fd-stream-out fd-stream)
 846                 (or (if (eql size 1)
 847                       (pick-output-routine 'base-char
 848                                            (fd-stream-buffering fd-stream)))
 849                     #'ill-out)
 850                 (fd-stream-bout fd-stream) routine))
 851         (setf (fd-stream-sout fd-stream)
 852               (if (eql size 1) #'fd-sout #'ill-out))
 853         (setf (fd-stream-char-pos fd-stream) 0)
 854         (setf output-size size)
 855         (setf output-type type)))
 856
 857     (when (and input-size output-size
 858                (not (eq input-size output-size)))
 859       (error "Element sizes for input (~S:~S) and output (~S:~S) differ?"
 860              input-type input-size
 861              output-type output-size))
 862     (setf (fd-stream-element-size fd-stream)
 863           (or input-size output-size))
 864
 865     (setf (fd-stream-element-type fd-stream)
 866           (cond ((equal input-type output-type)
 867                  input-type)
 868                 ((null output-type)
 869                  input-type)
 870                 ((null input-type)
 871                  output-type)
 872                 ((subtypep input-type output-type)
 873                  input-type)
 874                 ((subtypep output-type input-type)
 875                  output-type)
 876                 (t
 877                  (error "Input type (~S) and output type (~S) are unrelated?"
 878                         input-type
 879                         output-type))))))
 880
 881 ;;; Handle miscellaneous operations on FD-STREAM.
 882 (defun fd-stream-misc-routine (fd-stream operation &optional arg1 arg2)
 883   (declare (ignore arg2))
 884   (case operation
 885     (:listen
 886      (or (not (eql (fd-stream-ibuf-head fd-stream)
 887                    (fd-stream-ibuf-tail fd-stream)))
 888          (fd-stream-listen fd-stream)
 889          (setf (fd-stream-listen fd-stream)
 890                (eql (sb!alien:with-alien ((read-fds (sb!alien:struct
 891                                                      sb!unix:fd-set)))
 892                       (sb!unix:fd-zero read-fds)
 893                       (sb!unix:fd-set (fd-stream-fd fd-stream) read-fds)
 894                       (sb!unix:unix-fast-select (1+ (fd-stream-fd fd-stream))
 895                                                 (sb!alien:addr read-fds)
 896                                                 nil nil 0 0))
 897                     1))))
 898     (:unread
 899      (setf (fd-stream-unread fd-stream) arg1)
 900      (setf (fd-stream-listen fd-stream) t))
 901     (:close
 902      (cond (arg1 ; We got us an abort on our hands.
 903             (when (fd-stream-handler fd-stream)
 904               (sb!sys:remove-fd-handler (fd-stream-handler fd-stream))
 905               (setf (fd-stream-handler fd-stream) nil))
 906             ;; We can't do anything unless we know what file were
 907             ;; dealing with, and we don't want to do anything
 908             ;; strange unless we were writing to the file.
 909             (when (and (fd-stream-file fd-stream)
 910                        (fd-stream-obuf-sap fd-stream))
 911               (if (fd-stream-original fd-stream)
 912                   ;; If the original is EQ to file we are appending
 913                   ;; and can just close the file without renaming.
 914                   (unless (eq (fd-stream-original fd-stream)
 915                               (fd-stream-file fd-stream))
 916                     ;; We have a handle on the original, just revert.
 917                     (multiple-value-bind (okay err)
 918                         (sb!unix:unix-rename (fd-stream-original fd-stream)
 919                                              (fd-stream-file fd-stream))
 920                       (unless okay
 921                         (simple-stream-perror
 922                          "couldn't restore ~S to its original contents"
 923                          fd-stream
 924                          err))))
 925                   ;; We can't restore the original, and aren't
 926                   ;; appending, so nuke that puppy.
 927                   ;;
 928                   ;; FIXME: This is currently the fate of superseded
 929                   ;; files, and according to the CLOSE spec this is
 930                   ;; wrong. However, there seems to be no clean way to
 931                   ;; do that that doesn't involve either copying the
 932                   ;; data (bad if the :abort resulted from a full
 933                   ;; disk), or renaming the old file temporarily
 934                   ;; (probably bad because stream opening becomes more
 935                   ;; racy).
 936                   (multiple-value-bind (okay err)
 937                       (sb!unix:unix-unlink (fd-stream-file fd-stream))
 938                     (unless okay
 939                       (error 'simple-file-error
 940                              :pathname (fd-stream-file fd-stream)
 941                              :format-control
 942                              "~@<couldn't remove ~S: ~2I~_~A~:>"
 943                              :format-arguments (list (fd-stream-file fd-stream)
 944                                                      (strerror err))))))))
 945            (t
 946             (fd-stream-misc-routine fd-stream :finish-output)
 947             (when (and (fd-stream-original fd-stream)
 948                        (fd-stream-delete-original fd-stream))
 949               (multiple-value-bind (okay err)
 950                   (sb!unix:unix-unlink (fd-stream-original fd-stream))
 951                 (unless okay
 952                   (error 'simple-file-error
 953                          :pathname (fd-stream-original fd-stream)
 954                          :format-control
 955                          "~@<couldn't delete ~S during close of ~S: ~
 956                           ~2I~_~A~:>"
 957                          :format-arguments
 958                          (list (fd-stream-original fd-stream)
 959                                fd-stream
 960                                (strerror err))))))))
 961      (when (fboundp 'cancel-finalization)
 962        (cancel-finalization fd-stream))
 963      (sb!unix:unix-close (fd-stream-fd fd-stream))
 964      (when (fd-stream-obuf-sap fd-stream)
 965        (push (fd-stream-obuf-sap fd-stream) *available-buffers*)
 966        (setf (fd-stream-obuf-sap fd-stream) nil))
 967      (when (fd-stream-ibuf-sap fd-stream)
 968        (push (fd-stream-ibuf-sap fd-stream) *available-buffers*)
 969        (setf (fd-stream-ibuf-sap fd-stream) nil))
 970      (sb!impl::set-closed-flame fd-stream))
 971     (:clear-input
 972      (setf (fd-stream-unread fd-stream) nil)
 973      (setf (fd-stream-ibuf-head fd-stream) 0)
 974      (setf (fd-stream-ibuf-tail fd-stream) 0)
 975      (catch 'eof-input-catcher
 976        (loop
 977         (let ((count (sb!alien:with-alien ((read-fds (sb!alien:struct
 978                                                       sb!unix:fd-set)))
 979                        (sb!unix:fd-zero read-fds)
 980                        (sb!unix:fd-set (fd-stream-fd fd-stream) read-fds)
 981                        (sb!unix:unix-fast-select (1+ (fd-stream-fd fd-stream))
 982                                                  (sb!alien:addr read-fds)
 983                                                  nil
 984                                                  nil
 985                                                  0
 986                                                  0))))
 987           (cond ((eql count 1)
 988                  (frob-input fd-stream)
 989                  (setf (fd-stream-ibuf-head fd-stream) 0)
 990                  (setf (fd-stream-ibuf-tail fd-stream) 0))
 991                 (t
 992                  (return t)))))))
 993     (:force-output
 994      (flush-output-buffer fd-stream))
 995     (:finish-output
 996      (flush-output-buffer fd-stream)
 997      (do ()
 998          ((null (fd-stream-output-later fd-stream)))
 999        (sb!sys:serve-all-events)))
1000     (:element-type
1001      (fd-stream-element-type fd-stream))
1002     (:interactive-p
1003      (= 1 (the (member 0 1)
1004             (sb!unix:unix-isatty (fd-stream-fd fd-stream)))))
1005     (:line-length
1006      80)
1007     (:charpos
1008      (fd-stream-char-pos fd-stream))
1009     (:file-length
1010      (unless (fd-stream-file fd-stream)
1011        ;; This is a TYPE-ERROR because ANSI's species FILE-LENGTH
1012        ;; "should signal an error of type TYPE-ERROR if stream is not
1013        ;; a stream associated with a file". Too bad there's no very
1014        ;; appropriate value for the EXPECTED-TYPE slot..
1015        (error 'simple-type-error
1016               :datum fd-stream
1017               :expected-type 'file-stream
1018               :format-control "~S is not a stream associated with a file."
1019               :format-arguments (list fd-stream)))
1020      (multiple-value-bind (okay dev ino mode nlink uid gid rdev size
1021                            atime mtime ctime blksize blocks)
1022          (sb!unix:unix-fstat (fd-stream-fd fd-stream))
1023        (declare (ignore ino nlink uid gid rdev
1024                         atime mtime ctime blksize blocks))
1025        (unless okay
1026          (simple-stream-perror "failed Unix fstat(2) on ~S" fd-stream dev))
1027        (if (zerop mode)
1028            nil
1029            (truncate size (fd-stream-element-size fd-stream)))))
1030     (:file-position
1031      (fd-stream-file-position fd-stream arg1))))
1032
1033 (defun fd-stream-file-position (stream &optional newpos)
1034   (declare (type file-stream stream)
1035            (type (or (alien sb!unix:off-t) (member nil :start :end)) newpos))
1036   (if (null newpos)
1037       (sb!sys:without-interrupts
1038         ;; First, find the position of the UNIX file descriptor in the file.
1039         (multiple-value-bind (posn errno)
1040             (sb!unix:unix-lseek (fd-stream-fd stream) 0 sb!unix:l_incr)
1041           (declare (type (or (alien sb!unix:off-t) null) posn))
1042           (cond ((integerp posn)
1043                  ;; Adjust for buffered output: If there is any output
1044                  ;; buffered, the *real* file position will be larger
1045                  ;; than reported by lseek() because lseek() obviously
1046                  ;; cannot take into account output we have not sent
1047                  ;; yet.
1048                  (dolist (later (fd-stream-output-later stream))
1049                    (incf posn (- (caddr later)
1050                                  (cadr later))))
1051                  (incf posn (fd-stream-obuf-tail stream))
1052                  ;; Adjust for unread input: If there is any input
1053                  ;; read from UNIX but not supplied to the user of the
1054                  ;; stream, the *real* file position will smaller than
1055                  ;; reported, because we want to look like the unread
1056                  ;; stuff is still available.
1057                  (decf posn (- (fd-stream-ibuf-tail stream)
1058                                (fd-stream-ibuf-head stream)))
1059                  (when (fd-stream-unread stream)
1060                    (decf posn))
1061                  ;; Divide bytes by element size.
1062                  (truncate posn (fd-stream-element-size stream)))
1063                 ((eq errno sb!unix:espipe)
1064                  nil)
1065                 (t
1066                  (sb!sys:with-interrupts
1067                    (simple-stream-perror "failure in Unix lseek() on ~S"
1068                                          stream
1069                                          errno))))))
1070       (let ((offset 0) origin)
1071         (declare (type (alien sb!unix:off-t) offset))
1072         ;; Make sure we don't have any output pending, because if we
1073         ;; move the file pointer before writing this stuff, it will be
1074         ;; written in the wrong location.
1075         (flush-output-buffer stream)
1076         (do ()
1077             ((null (fd-stream-output-later stream)))
1078           (sb!sys:serve-all-events))
1079         ;; Clear out any pending input to force the next read to go to
1080         ;; the disk.
1081         (setf (fd-stream-unread stream) nil)
1082         (setf (fd-stream-ibuf-head stream) 0)
1083         (setf (fd-stream-ibuf-tail stream) 0)
1084         ;; Trash cached value for listen, so that we check next time.
1085         (setf (fd-stream-listen stream) nil)
1086         ;; Now move it.
1087         (cond ((eq newpos :start)
1088                (setf offset 0 origin sb!unix:l_set))
1089               ((eq newpos :end)
1090                (setf offset 0 origin sb!unix:l_xtnd))
1091               ((typep newpos '(alien sb!unix:off-t))
1092                (setf offset (* newpos (fd-stream-element-size stream))
1093                      origin sb!unix:l_set))
1094               (t
1095                (error "invalid position given to FILE-POSITION: ~S" newpos)))
1096         (multiple-value-bind (posn errno)
1097             (sb!unix:unix-lseek (fd-stream-fd stream) offset origin)
1098           (cond ((typep posn '(alien sb!unix:off-t))
1099                  t)
1100                 ((eq errno sb!unix:espipe)
1101                  nil)
1102                 (t
1103                  (simple-stream-perror "error in Unix lseek() on ~S"
1104                                        stream
1105                                        errno)))))))
1106 \f
1107 ;;;; creation routines (MAKE-FD-STREAM and OPEN)
1108
1109 ;;; Create a stream for the given Unix file descriptor.
1110 ;;;
1111 ;;; If INPUT is non-NIL, allow input operations. If OUTPUT is non-nil,
1112 ;;; allow output operations. If neither INPUT nor OUTPUT is specified,
1113 ;;; default to allowing input.
1114 ;;;
1115 ;;; ELEMENT-TYPE indicates the element type to use (as for OPEN).
1116 ;;;
1117 ;;; BUFFERING indicates the kind of buffering to use.
1118 ;;;
1119 ;;; TIMEOUT (if true) is the number of seconds to wait for input. If
1120 ;;; NIL (the default), then wait forever. When we time out, we signal
1121 ;;; IO-TIMEOUT.
1122 ;;;
1123 ;;; FILE is the name of the file (will be returned by PATHNAME).
1124 ;;;
1125 ;;; NAME is used to identify the stream when printed.
1126 (defun make-fd-stream (fd
1127                        &key
1128                        (input nil input-p)
1129                        (output nil output-p)
1130                        (element-type 'base-char)
1131                        (buffering :full)
1132                        timeout
1133                        file
1134                        original
1135                        delete-original
1136                        pathname
1137                        input-buffer-p
1138                        (name (if file
1139                                  (format nil "file ~S" file)
1140                                  (format nil "descriptor ~W" fd)))
1141                        auto-close)
1142   (declare (type index fd) (type (or index null) timeout)
1143            (type (member :none :line :full) buffering))
1144   (cond ((not (or input-p output-p))
1145          (setf input t))
1146         ((not (or input output))
1147          (error "File descriptor must be opened either for input or output.")))
1148   (let ((stream (%make-fd-stream :fd fd
1149                                  :name name
1150                                  :file file
1151                                  :original original
1152                                  :delete-original delete-original
1153                                  :pathname pathname
1154                                  :buffering buffering
1155                                  :timeout timeout)))
1156     (set-fd-stream-routines stream element-type input output input-buffer-p)
1157     (when (and auto-close (fboundp 'finalize))
1158       (finalize stream
1159                 (lambda ()
1160                   (sb!unix:unix-close fd)
1161                   #!+sb-show
1162                   (format *terminal-io* "** closed file descriptor ~W **~%"
1163                           fd))))
1164     stream))
1165
1166 ;;; Pick a name to use for the backup file for the :IF-EXISTS
1167 ;;; :RENAME-AND-DELETE and :RENAME options.
1168 (defun pick-backup-name (name)
1169   (declare (type simple-base-string name))
1170   (concatenate 'simple-base-string name ".bak"))
1171
1172 ;;; Ensure that the given arg is one of the given list of valid
1173 ;;; things. Allow the user to fix any problems.
1174 (defun ensure-one-of (item list what)
1175   (unless (member item list)
1176     (error 'simple-type-error
1177            :datum item
1178            :expected-type `(member ,@list)
1179            :format-control "~@<~S is ~_invalid for ~S; ~_need one of~{ ~S~}~:>"
1180            :format-arguments (list item what list))))
1181
1182 ;;; Rename NAMESTRING to ORIGINAL. First, check whether we have write
1183 ;;; access, since we don't want to trash unwritable files even if we
1184 ;;; technically can. We return true if we succeed in renaming.
1185 (defun rename-the-old-one (namestring original)
1186   (unless (sb!unix:unix-access namestring sb!unix:w_ok)
1187     (error "~@<The file ~2I~_~S ~I~_is not writable.~:>" namestring))
1188   (multiple-value-bind (okay err) (sb!unix:unix-rename namestring original)
1189     (if okay
1190         t
1191         (error 'simple-file-error
1192                :pathname namestring
1193                :format-control
1194                "~@<couldn't rename ~2I~_~S ~I~_to ~2I~_~S: ~4I~_~A~:>"
1195                :format-arguments (list namestring original (strerror err))))))
1196
1197 (defun open (filename
1198              &key
1199              (direction :input)
1200              (element-type 'base-char)
1201              (if-exists nil if-exists-given)
1202              (if-does-not-exist nil if-does-not-exist-given)
1203              (external-format :default)
1204              &aux ; Squelch assignment warning.
1205              (direction direction)
1206              (if-does-not-exist if-does-not-exist)
1207              (if-exists if-exists))
1208   #!+sb-doc
1209   "Return a stream which reads from or writes to FILENAME.
1210   Defined keywords:
1211    :DIRECTION - one of :INPUT, :OUTPUT, :IO, or :PROBE
1212    :ELEMENT-TYPE - the type of object to read or write, default BASE-CHAR
1213    :IF-EXISTS - one of :ERROR, :NEW-VERSION, :RENAME, :RENAME-AND-DELETE,
1214                        :OVERWRITE, :APPEND, :SUPERSEDE or NIL
1215    :IF-DOES-NOT-EXIST - one of :ERROR, :CREATE or NIL
1216   See the manual for details."
1217
1218   (declare (ignore external-format)) ; FIXME: CHECK-TYPE?  WARN-if-not?
1219
1220   ;; Calculate useful stuff.
1221   (multiple-value-bind (input output mask)
1222       (case direction
1223         (:input  (values   t nil sb!unix:o_rdonly))
1224         (:output (values nil   t sb!unix:o_wronly))
1225         (:io     (values   t   t sb!unix:o_rdwr))
1226         (:probe  (values   t nil sb!unix:o_rdonly)))
1227     (declare (type index mask))
1228     (let* ((pathname (merge-pathnames filename))
1229            (namestring
1230             (cond ((unix-namestring pathname input))
1231                   ((and input (eq if-does-not-exist :create))
1232                    (unix-namestring pathname nil))
1233                   ((and (eq direction :io) (not if-does-not-exist-given))
1234                    (unix-namestring pathname nil)))))
1235       ;; Process if-exists argument if we are doing any output.
1236       (cond (output
1237              (unless if-exists-given
1238                (setf if-exists
1239                      (if (eq (pathname-version pathname) :newest)
1240                          :new-version
1241                          :error)))
1242              (ensure-one-of if-exists
1243                             '(:error :new-version :rename
1244                                      :rename-and-delete :overwrite
1245                                      :append :supersede nil)
1246                             :if-exists)
1247              (case if-exists
1248                ((:new-version :error nil)
1249                 (setf mask (logior mask sb!unix:o_excl)))
1250                ((:rename :rename-and-delete)
1251                 (setf mask (logior mask sb!unix:o_creat)))
1252                ((:supersede)
1253                 (setf mask (logior mask sb!unix:o_trunc)))
1254                (:append
1255                 (setf mask (logior mask sb!unix:o_append)))))
1256             (t
1257              (setf if-exists :ignore-this-arg)))
1258
1259       (unless if-does-not-exist-given
1260         (setf if-does-not-exist
1261               (cond ((eq direction :input) :error)
1262                     ((and output
1263                           (member if-exists '(:overwrite :append)))
1264                      :error)
1265                     ((eq direction :probe)
1266                      nil)
1267                     (t
1268                      :create))))
1269       (ensure-one-of if-does-not-exist
1270                      '(:error :create nil)
1271                      :if-does-not-exist)
1272       (if (eq if-does-not-exist :create)
1273         (setf mask (logior mask sb!unix:o_creat)))
1274
1275       (let ((original (case if-exists
1276                         ((:rename :rename-and-delete)
1277                          (pick-backup-name namestring))
1278                         ((:append)
1279                          ;; KLUDGE: Provent CLOSE from deleting
1280                          ;; appending streams when called with :ABORT T
1281                          namestring)))
1282             (delete-original (eq if-exists :rename-and-delete))
1283             (mode #o666))
1284         (when (and original (not (eq original namestring)))
1285           ;; We are doing a :RENAME or :RENAME-AND-DELETE. Determine
1286           ;; whether the file already exists, make sure the original
1287           ;; file is not a directory, and keep the mode.
1288           (let ((exists
1289                  (and namestring
1290                       (multiple-value-bind (okay err/dev inode orig-mode)
1291                           (sb!unix:unix-stat namestring)
1292                         (declare (ignore inode)
1293                                  (type (or index null) orig-mode))
1294                         (cond
1295                          (okay
1296                           (when (and output (= (logand orig-mode #o170000)
1297                                                #o40000))
1298                             (error 'simple-file-error
1299                                    :pathname namestring
1300                                    :format-control
1301                                    "can't open ~S for output: is a directory"
1302                                    :format-arguments (list namestring)))
1303                           (setf mode (logand orig-mode #o777))
1304                           t)
1305                          ((eql err/dev sb!unix:enoent)
1306                           nil)
1307                          (t
1308                           (simple-file-perror "can't find ~S"
1309                                               namestring
1310                                               err/dev)))))))
1311             (unless (and exists
1312                          (rename-the-old-one namestring original))
1313               (setf original nil)
1314               (setf delete-original nil)
1315               ;; In order to use :SUPERSEDE instead, we have to make
1316               ;; sure SB!UNIX:O_CREAT corresponds to
1317               ;; IF-DOES-NOT-EXIST. SB!UNIX:O_CREAT was set before
1318               ;; because of IF-EXISTS being :RENAME.
1319               (unless (eq if-does-not-exist :create)
1320                 (setf mask
1321                       (logior (logandc2 mask sb!unix:o_creat)
1322                               sb!unix:o_trunc)))
1323               (setf if-exists :supersede))))
1324
1325         ;; Now we can try the actual Unix open(2).
1326         (multiple-value-bind (fd errno)
1327             (if namestring
1328                 (sb!unix:unix-open namestring mask mode)
1329                 (values nil sb!unix:enoent))
1330           (labels ((open-error (format-control &rest format-arguments)
1331                      (error 'simple-file-error
1332                             :pathname pathname
1333                             :format-control format-control
1334                             :format-arguments format-arguments))
1335                    (vanilla-open-error ()
1336                      (simple-file-perror "error opening ~S" pathname errno)))
1337             (cond ((numberp fd)
1338                    (case direction
1339                      ((:input :output :io)
1340                       (make-fd-stream fd
1341                                       :input input
1342                                       :output output
1343                                       :element-type element-type
1344                                       :file namestring
1345                                       :original original
1346                                       :delete-original delete-original
1347                                       :pathname pathname
1348                                       :input-buffer-p t
1349                                       :auto-close t))
1350                      (:probe
1351                       (let ((stream
1352                              (%make-fd-stream :name namestring
1353                                               :fd fd
1354                                               :pathname pathname
1355                                               :element-type element-type)))
1356                         (close stream)
1357                         stream))))
1358                   ((eql errno sb!unix:enoent)
1359                    (case if-does-not-exist
1360                      (:error (vanilla-open-error))
1361                      (:create
1362                       (open-error "~@<The path ~2I~_~S ~I~_does not exist.~:>"
1363                                   pathname))
1364                      (t nil)))
1365                   ((and (eql errno sb!unix:eexist) (null if-exists))
1366                    nil)
1367                   (t
1368                    (vanilla-open-error)))))))))
1369 \f
1370 ;;;; initialization
1371
1372 ;;; the stream connected to the controlling terminal, or NIL if there is none
1373 (defvar *tty*)
1374
1375 ;;; the stream connected to the standard input (file descriptor 0)
1376 (defvar *stdin*)
1377
1378 ;;; the stream connected to the standard output (file descriptor 1)
1379 (defvar *stdout*)
1380
1381 ;;; the stream connected to the standard error output (file descriptor 2)
1382 (defvar *stderr*)
1383
1384 ;;; This is called when the cold load is first started up, and may also
1385 ;;; be called in an attempt to recover from nested errors.
1386 (defun stream-cold-init-or-reset ()
1387   (stream-reinit)
1388   (setf *terminal-io* (make-synonym-stream '*tty*))
1389   (setf *standard-output* (make-synonym-stream '*stdout*))
1390   (setf *standard-input* (make-synonym-stream '*stdin*))
1391   (setf *error-output* (make-synonym-stream '*stderr*))
1392   (setf *query-io* (make-synonym-stream '*terminal-io*))
1393   (setf *debug-io* *query-io*)
1394   (setf *trace-output* *standard-output*)
1395   (values))
1396
1397 ;;; This is called whenever a saved core is restarted.
1398 (defun stream-reinit ()
1399   (setf *available-buffers* nil)
1400   (setf *stdin*
1401         (make-fd-stream 0 :name "standard input" :input t :buffering :line))
1402   (setf *stdout*
1403         (make-fd-stream 1 :name "standard output" :output t :buffering :line))
1404   (setf *stderr*
1405         (make-fd-stream 2 :name "standard error" :output t :buffering :line))
1406   (let ((tty (sb!unix:unix-open "/dev/tty" sb!unix:o_rdwr #o666)))
1407     (if tty
1408         (setf *tty*
1409               (make-fd-stream tty
1410                               :name "the terminal"
1411                               :input t
1412                               :output t
1413                               :buffering :line
1414                               :auto-close t))
1415         (setf *tty* (make-two-way-stream *stdin* *stdout*))))
1416   (values))
1417 \f
1418 ;;;; miscellany
1419
1420 ;;; the Unix way to beep
1421 (defun beep (stream)
1422   (write-char (code-char bell-char-code) stream)
1423   (finish-output stream))
1424
1425 ;;; This is kind of like FILE-POSITION, but is an internal hack used
1426 ;;; by the filesys stuff to get and set the file name.
1427 ;;;
1428 ;;; FIXME: misleading name, screwy interface
1429 (defun file-name (stream &optional new-name)
1430   (when (typep stream 'file-stream)
1431       (cond (new-name
1432              (setf (fd-stream-pathname stream) new-name)
1433              (setf (fd-stream-file stream)
1434                    (unix-namestring new-name nil))
1435              t)
1436             (t
1437              (fd-stream-pathname stream)))))
1438 \f
1439 ;;;; international character support (which is trivial for our simple
1440 ;;;; character sets)
1441
1442 ;;;; (Those who do Lisp only in English might not remember that ANSI
1443 ;;;; requires these functions to be exported from package
1444 ;;;; COMMON-LISP.)
1445
1446 (defun file-string-length (stream object)
1447   (declare (type (or string character) object) (type file-stream stream))
1448   #!+sb-doc
1449   "Return the delta in STREAM's FILE-POSITION that would be caused by writing
1450    OBJECT to STREAM. Non-trivial only in implementations that support
1451    international character sets."
1452   (declare (ignore stream))
1453   (etypecase object
1454     (character 1)
1455     (string (length object))))
1456
1457 (defun stream-external-format (stream)
1458   (declare (type file-stream stream) (ignore stream))
1459   #!+sb-doc
1460   "Return :DEFAULT."
1461   :default)