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