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