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