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