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