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