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