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