src/code/fd-stream.lisp

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