1 ;;;; streams for UNIX file descriptors
3 ;;;; This software is part of the SBCL system. See the README file for
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.
12 (in-package "SB!IMPL")
14 ;;;; buffer manipulation routines
16 ;;; FIXME: Is it really good to maintain this pool separate from the
17 ;;; GC and the C malloc logic?
18 (defvar *available-buffers
* ()
20 "List of available buffers. Each buffer is an sap pointing to
21 bytes-per-buffer of memory.")
23 (defvar *available-buffers-mutex
* (sb!thread
:make-mutex
24 :name
"lock for *AVAILABLE-BUFFERS*")
26 "Mutex for access to *AVAILABLE-BUFFERS*.")
28 (defmacro with-available-buffers-lock
((&optional
) &body body
)
29 ;; CALL-WITH-SYSTEM-MUTEX because streams are low-level enough to be
30 ;; async signal safe, and in particular a C-c that brings up the
31 ;; debugger while holding the mutex would lose badly
32 `(sb!thread
::call-with-system-mutex
(lambda () ,@body
)
33 *available-buffers-mutex
*))
35 (defconstant bytes-per-buffer
(* 4 1024)
37 "Number of bytes per buffer.")
39 ;;; Return the next available buffer, creating one if necessary.
40 #!-sb-fluid
(declaim (inline next-available-buffer
))
41 (defun next-available-buffer ()
42 (with-available-buffers-lock ()
43 (if *available-buffers
*
44 (pop *available-buffers
*)
45 (allocate-system-memory bytes-per-buffer
))))
47 ;;;; the FD-STREAM structure
50 (:constructor %make-fd-stream
)
51 (:conc-name fd-stream-
)
52 (:predicate fd-stream-p
)
54 (misc #'fd-stream-misc-routine
))
57 ;; the name of this stream
59 ;; the file this stream is for
61 ;; the backup file namestring for the old file, for :IF-EXISTS
62 ;; :RENAME or :RENAME-AND-DELETE.
63 (original nil
:type
(or simple-string null
))
64 (delete-original nil
) ; for :if-exists :rename-and-delete
65 ;;; the number of bytes per element
66 (element-size 1 :type index
)
67 ;; the type of element being transfered
68 (element-type 'base-char
)
69 ;; the Unix file descriptor
71 ;; controls when the output buffer is flushed
72 (buffering :full
:type
(member :full
:line
:none
))
73 ;; controls whether the input buffer must be cleared before output
74 ;; (must be done for files, not for sockets, pipes and other data
75 ;; sources where input and output aren't related). non-NIL means
76 ;; don't clear input buffer.
78 ;; character position if known -- this may run into bignums, but
79 ;; we probably should flip it into null then for efficiency's sake...
80 (char-pos nil
:type
(or unsigned-byte null
))
81 ;; T if input is waiting on FD. :EOF if we hit EOF.
82 (listen nil
:type
(member nil t
:eof
))
86 (ibuf-sap nil
:type
(or system-area-pointer null
))
87 (ibuf-length nil
:type
(or index null
))
88 (ibuf-head 0 :type index
)
89 (ibuf-tail 0 :type index
)
92 (obuf-sap nil
:type
(or system-area-pointer null
))
93 (obuf-length nil
:type
(or index null
))
94 (obuf-tail 0 :type index
)
96 ;; output flushed, but not written due to non-blocking io?
99 ;; timeout specified for this stream as seconds or NIL if none
100 (timeout nil
:type
(or single-float null
))
101 ;; pathname of the file this stream is opened to (returned by PATHNAME)
102 (pathname nil
:type
(or pathname null
))
103 (external-format :default
)
104 (output-bytes #'ill-out
:type function
))
105 (def!method print-object
((fd-stream fd-stream
) stream
)
106 (declare (type stream stream
))
107 (print-unreadable-object (fd-stream stream
:type t
:identity t
)
108 (format stream
"for ~S" (fd-stream-name fd-stream
))))
110 ;;;; output routines and related noise
112 (defvar *output-routines
* ()
114 "List of all available output routines. Each element is a list of the
115 element-type output, the kind of buffering, the function name, and the number
116 of bytes per element.")
118 ;;; common idioms for reporting low-level stream and file problems
119 (defun simple-stream-perror (note-format stream errno
)
120 (error 'simple-stream-error
122 :format-control
"~@<~?: ~2I~_~A~:>"
123 :format-arguments
(list note-format
(list stream
) (strerror errno
))))
124 (defun simple-file-perror (note-format pathname errno
)
125 (error 'simple-file-error
127 :format-control
"~@<~?: ~2I~_~A~:>"
129 (list note-format
(list pathname
) (strerror errno
))))
131 (defun stream-decoding-error (stream octets
)
132 (error 'stream-decoding-error
134 ;; FIXME: dunno how to get at OCTETS currently, or even if
135 ;; that's the right thing to report.
137 (defun stream-encoding-error (stream code
)
138 (error 'stream-encoding-error
142 (defun c-string-encoding-error (external-format code
)
143 (error 'c-string-encoding-error
144 :external-format external-format
147 (defun c-string-decoding-error (external-format octets
)
148 (error 'c-string-decoding-error
149 :external-format external-format
152 ;;; Returning true goes into end of file handling, false will enter another
153 ;;; round of input buffer filling followed by re-entering character decode.
154 (defun stream-decoding-error-and-handle (stream octet-count
)
156 (stream-decoding-error stream
157 (let ((sap (fd-stream-ibuf-sap stream
))
158 (head (fd-stream-ibuf-head stream
)))
159 (loop for i from
0 below octet-count
160 collect
(sap-ref-8 sap
(+ head i
)))))
162 :report
(lambda (stream)
164 "~@<Attempt to resync the stream at a character ~
165 character boundary and continue.~@:>"))
166 (fd-stream-resync stream
)
168 (force-end-of-file ()
169 :report
(lambda (stream)
170 (format stream
"~@<Force an end of file.~@:>"))
173 (defun stream-encoding-error-and-handle (stream code
)
175 (stream-encoding-error stream code
)
177 :report
(lambda (stream)
178 (format stream
"~@<Skip output of this character.~@:>"))
179 (throw 'output-nothing nil
))))
181 (defun external-format-encoding-error (stream code
)
183 (stream-encoding-error-and-handle stream code
)
184 (c-string-encoding-error stream code
)))
186 (defun external-format-decoding-error (stream octet-count
)
188 (stream-decoding-error stream octet-count
)
189 (c-string-decoding-error stream octet-count
)))
191 ;;; This is called by the server when we can write to the given file
192 ;;; descriptor. Attempt to write the data again. If it worked, remove
193 ;;; the data from the OUTPUT-LATER list. If it didn't work, something
195 (defun frob-output-later (stream)
196 (let* ((stuff (pop (fd-stream-output-later stream
)))
200 (reuse-sap (cadddr stuff
))
201 (length (- end start
)))
202 (declare (type index start end length
))
203 (multiple-value-bind (count errno
)
204 (sb!unix
:unix-write
(fd-stream-fd stream
)
210 (simple-stream-perror "couldn't write to ~S" stream errno
)
212 (if (= errno sb
!unix
:ewouldblock
)
213 (error "Write would have blocked, but SERVER told us to go.")
214 (simple-stream-perror "couldn't write to ~S" stream errno
)))
215 ((eql count length
) ; Hot damn, it worked.
217 (with-available-buffers-lock ()
218 (push base
*available-buffers
*))))
219 ((not (null count
)) ; sorta worked..
221 (the index
(+ start count
))
223 (fd-stream-output-later stream
))))))
224 (unless (fd-stream-output-later stream
)
225 (remove-fd-handler (fd-stream-handler stream
))
226 (setf (fd-stream-handler stream
) nil
)))
228 ;;; Arange to output the string when we can write on the file descriptor.
229 (defun output-later (stream base start end reuse-sap
)
230 (cond ((null (fd-stream-output-later stream
))
231 (setf (fd-stream-output-later stream
)
232 (list (list base start end reuse-sap
)))
233 (setf (fd-stream-handler stream
)
234 (add-fd-handler (fd-stream-fd stream
)
237 (declare (ignore fd
))
238 (frob-output-later stream
)))))
240 (nconc (fd-stream-output-later stream
)
241 (list (list base start end reuse-sap
)))))
243 (let ((new-buffer (next-available-buffer)))
244 (setf (fd-stream-obuf-sap stream
) new-buffer
)
245 (setf (fd-stream-obuf-length stream
) bytes-per-buffer
))))
247 ;;; Output the given noise. Check to see whether there are any pending
248 ;;; writes. If so, just queue this one. Otherwise, try to write it. If
249 ;;; this would block, queue it.
250 (defun frob-output (stream base start end reuse-sap
)
251 (declare (type fd-stream stream
)
252 (type (or system-area-pointer
(simple-array * (*))) base
)
253 (type index start end
))
254 (if (not (null (fd-stream-output-later stream
))) ; something buffered.
255 (output-later stream base start end reuse-sap
)
256 ;; ### check to see whether any of this noise can be output
257 (let ((length (- end start
)))
258 (multiple-value-bind (count errno
)
259 (sb!unix
:unix-write
(fd-stream-fd stream
) base start length
)
262 (simple-stream-perror "Couldn't write to ~S" stream errno
)
264 (if (= errno sb
!unix
:ewouldblock
)
265 (output-later stream base start end reuse-sap
)
266 (simple-stream-perror "Couldn't write to ~S"
268 ((not (eql count length
))
269 (output-later stream base
(the index
(+ start count
))
272 ;;; Flush any data in the output buffer.
273 (defun flush-output-buffer (stream)
274 (let ((length (fd-stream-obuf-tail stream
)))
276 (frob-output stream
(fd-stream-obuf-sap stream
) 0 length t
)
277 (setf (fd-stream-obuf-tail stream
) 0))))
279 (defun fd-stream-output-finished-p (stream)
280 (and (zerop (fd-stream-obuf-tail stream
))
281 (not (fd-stream-output-later stream
))))
283 (defmacro output-wrapper
/variable-width
((stream size buffering restart
)
285 (let ((stream-var (gensym)))
286 `(let ((,stream-var
,stream
)
288 ,(unless (eq (car buffering
) :none
)
289 `(when (< (fd-stream-obuf-length ,stream-var
)
290 (+ (fd-stream-obuf-tail ,stream-var
)
292 (flush-output-buffer ,stream-var
)))
293 ,(unless (eq (car buffering
) :none
)
294 `(when (and (not (fd-stream-dual-channel-p ,stream-var
))
295 (> (fd-stream-ibuf-tail ,stream-var
)
296 (fd-stream-ibuf-head ,stream-var
)))
297 (file-position ,stream-var
(file-position ,stream-var
))))
299 `(catch 'output-nothing
301 (incf (fd-stream-obuf-tail ,stream-var
) size
))
304 (incf (fd-stream-obuf-tail ,stream-var
) size
)))
305 ,(ecase (car buffering
)
307 `(flush-output-buffer ,stream-var
))
309 `(when (eq (char-code byte
) (char-code #\Newline
))
310 (flush-output-buffer ,stream-var
)))
314 (defmacro output-wrapper
((stream size buffering restart
) &body body
)
315 (let ((stream-var (gensym)))
316 `(let ((,stream-var
,stream
))
317 ,(unless (eq (car buffering
) :none
)
318 `(when (< (fd-stream-obuf-length ,stream-var
)
319 (+ (fd-stream-obuf-tail ,stream-var
)
321 (flush-output-buffer ,stream-var
)))
322 ,(unless (eq (car buffering
) :none
)
323 `(when (and (not (fd-stream-dual-channel-p ,stream-var
))
324 (> (fd-stream-ibuf-tail ,stream-var
)
325 (fd-stream-ibuf-head ,stream-var
)))
326 (file-position ,stream-var
(file-position ,stream-var
))))
328 `(catch 'output-nothing
330 (incf (fd-stream-obuf-tail ,stream-var
) ,size
))
333 (incf (fd-stream-obuf-tail ,stream-var
) ,size
)))
334 ,(ecase (car buffering
)
336 `(flush-output-buffer ,stream-var
))
338 `(when (eq (char-code byte
) (char-code #\Newline
))
339 (flush-output-buffer ,stream-var
)))
343 (defmacro def-output-routines
/variable-width
344 ((name-fmt size restart external-format
&rest bufferings
)
346 (declare (optimize (speed 1)))
351 (intern (format nil name-fmt
(string (car buffering
))))))
353 (defun ,function
(stream byte
)
354 (declare (ignorable byte
))
355 (output-wrapper/variable-width
(stream ,size
,buffering
,restart
)
357 (setf *output-routines
*
358 (nconc *output-routines
*
366 (cdr buffering
)))))))
369 ;;; Define output routines that output numbers SIZE bytes long for the
370 ;;; given bufferings. Use BODY to do the actual output.
371 (defmacro def-output-routines
((name-fmt size restart
&rest bufferings
)
373 (declare (optimize (speed 1)))
378 (intern (format nil name-fmt
(string (car buffering
))))))
380 (defun ,function
(stream byte
)
381 (output-wrapper (stream ,size
,buffering
,restart
)
383 (setf *output-routines
*
384 (nconc *output-routines
*
392 (cdr buffering
)))))))
395 ;;; FIXME: is this used anywhere any more?
396 (def-output-routines ("OUTPUT-CHAR-~A-BUFFERED"
402 (if (char= byte
#\Newline
)
403 (setf (fd-stream-char-pos stream
) 0)
404 (incf (fd-stream-char-pos stream
)))
405 (setf (sap-ref-8 (fd-stream-obuf-sap stream
) (fd-stream-obuf-tail stream
))
408 (def-output-routines ("OUTPUT-UNSIGNED-BYTE-~A-BUFFERED"
411 (:none
(unsigned-byte 8))
412 (:full
(unsigned-byte 8)))
413 (setf (sap-ref-8 (fd-stream-obuf-sap stream
) (fd-stream-obuf-tail stream
))
416 (def-output-routines ("OUTPUT-SIGNED-BYTE-~A-BUFFERED"
419 (:none
(signed-byte 8))
420 (:full
(signed-byte 8)))
421 (setf (signed-sap-ref-8 (fd-stream-obuf-sap stream
)
422 (fd-stream-obuf-tail stream
))
425 (def-output-routines ("OUTPUT-UNSIGNED-SHORT-~A-BUFFERED"
428 (:none
(unsigned-byte 16))
429 (:full
(unsigned-byte 16)))
430 (setf (sap-ref-16 (fd-stream-obuf-sap stream
) (fd-stream-obuf-tail stream
))
433 (def-output-routines ("OUTPUT-SIGNED-SHORT-~A-BUFFERED"
436 (:none
(signed-byte 16))
437 (:full
(signed-byte 16)))
438 (setf (signed-sap-ref-16 (fd-stream-obuf-sap stream
)
439 (fd-stream-obuf-tail stream
))
442 (def-output-routines ("OUTPUT-UNSIGNED-LONG-~A-BUFFERED"
445 (:none
(unsigned-byte 32))
446 (:full
(unsigned-byte 32)))
447 (setf (sap-ref-32 (fd-stream-obuf-sap stream
) (fd-stream-obuf-tail stream
))
450 (def-output-routines ("OUTPUT-SIGNED-LONG-~A-BUFFERED"
453 (:none
(signed-byte 32))
454 (:full
(signed-byte 32)))
455 (setf (signed-sap-ref-32 (fd-stream-obuf-sap stream
)
456 (fd-stream-obuf-tail stream
))
459 #+#.
(cl:if
(cl:= sb
!vm
:n-word-bits
64) '(and) '(or))
461 (def-output-routines ("OUTPUT-UNSIGNED-LONG-LONG-~A-BUFFERED"
464 (:none
(unsigned-byte 64))
465 (:full
(unsigned-byte 64)))
466 (setf (sap-ref-64 (fd-stream-obuf-sap stream
) (fd-stream-obuf-tail stream
))
468 (def-output-routines ("OUTPUT-SIGNED-LONG-LONG-~A-BUFFERED"
471 (:none
(signed-byte 64))
472 (:full
(signed-byte 64)))
473 (setf (signed-sap-ref-64 (fd-stream-obuf-sap stream
)
474 (fd-stream-obuf-tail stream
))
477 ;;; Do the actual output. If there is space to buffer the string,
478 ;;; buffer it. If the string would normally fit in the buffer, but
479 ;;; doesn't because of other stuff in the buffer, flush the old noise
480 ;;; out of the buffer and put the string in it. Otherwise we have a
481 ;;; very long string, so just send it directly (after flushing the
482 ;;; buffer, of course).
483 (defun output-raw-bytes (fd-stream thing
&optional start end
)
485 "Output THING to FD-STREAM. THING can be any kind of vector or a SAP. If
486 THING is a SAP, END must be supplied (as length won't work)."
487 (let ((start (or start
0))
488 (end (or end
(length (the (simple-array * (*)) thing
)))))
489 (declare (type index start end
))
490 (when (and (not (fd-stream-dual-channel-p fd-stream
))
491 (> (fd-stream-ibuf-tail fd-stream
)
492 (fd-stream-ibuf-head fd-stream
)))
493 (file-position fd-stream
(file-position fd-stream
)))
494 (let* ((len (fd-stream-obuf-length fd-stream
))
495 (tail (fd-stream-obuf-tail fd-stream
))
497 (bytes (- end start
))
498 (newtail (+ tail bytes
)))
499 (cond ((minusp bytes
) ; error case
500 (error ":END before :START!"))
501 ((zerop bytes
)) ; easy case
503 (if (system-area-pointer-p thing
)
504 (system-area-ub8-copy thing start
505 (fd-stream-obuf-sap fd-stream
)
508 ;; FIXME: There should be some type checking somewhere to
509 ;; verify that THING here is a vector, not just <not a SAP>.
510 (copy-ub8-to-system-area thing start
511 (fd-stream-obuf-sap fd-stream
)
514 (setf (fd-stream-obuf-tail fd-stream
) newtail
))
516 (flush-output-buffer fd-stream
)
517 (if (system-area-pointer-p thing
)
518 (system-area-ub8-copy thing
520 (fd-stream-obuf-sap fd-stream
)
523 ;; FIXME: There should be some type checking somewhere to
524 ;; verify that THING here is a vector, not just <not a SAP>.
525 (copy-ub8-to-system-area thing
527 (fd-stream-obuf-sap fd-stream
)
530 (setf (fd-stream-obuf-tail fd-stream
) bytes
))
532 (flush-output-buffer fd-stream
)
533 (frob-output fd-stream thing start end nil
))))))
535 ;;; the routine to use to output a string. If the stream is
536 ;;; unbuffered, slam the string down the file descriptor, otherwise
537 ;;; use OUTPUT-RAW-BYTES to buffer the string. Update charpos by
538 ;;; checking to see where the last newline was.
539 (defun fd-sout (stream thing start end
)
540 (declare (type fd-stream stream
) (type string thing
))
541 (let ((start (or start
0))
542 (end (or end
(length (the vector thing
)))))
543 (declare (fixnum start end
))
545 (string-dispatch (simple-base-string
547 (simple-array character
(*))
550 (position #\newline thing
:from-end t
551 :start start
:end end
))))
552 (if (and (typep thing
'base-string
)
553 (eq (fd-stream-external-format stream
) :latin-1
))
554 (ecase (fd-stream-buffering stream
)
556 (output-raw-bytes stream thing start end
))
558 (output-raw-bytes stream thing start end
)
560 (flush-output-buffer stream
)))
562 (frob-output stream thing start end nil
)))
563 (ecase (fd-stream-buffering stream
)
564 (:full
(funcall (fd-stream-output-bytes stream
)
565 stream thing nil start end
))
566 (:line
(funcall (fd-stream-output-bytes stream
)
567 stream thing last-newline start end
))
568 (:none
(funcall (fd-stream-output-bytes stream
)
569 stream thing t start end
))))
571 (setf (fd-stream-char-pos stream
) (- end last-newline
1))
572 (incf (fd-stream-char-pos stream
) (- end start
))))))
574 (defvar *external-formats
* ()
576 "List of all available external formats. Each element is a list of the
577 element-type, string input function name, character input function name,
578 and string output function name.")
580 (defun get-external-format (external-format)
581 (dolist (entry *external-formats
*)
582 (when (member external-format
(first entry
))
585 (defun get-external-format-function (external-format index
)
586 (let ((entry (get-external-format external-format
)))
587 (when entry
(nth index entry
))))
589 ;;; Find an output routine to use given the type and buffering. Return
590 ;;; as multiple values the routine, the real type transfered, and the
591 ;;; number of bytes per element.
592 (defun pick-output-routine (type buffering
&optional external-format
)
593 (when (subtypep type
'character
)
594 (let ((entry (get-external-format external-format
)))
596 (return-from pick-output-routine
597 (values (symbol-function (nth (ecase buffering
604 (symbol-function (fourth entry
))
605 (first (first entry
)))))))
606 (dolist (entry *output-routines
*)
607 (when (and (subtypep type
(first entry
))
608 (eq buffering
(second entry
))
609 (or (not (fifth entry
))
610 (eq external-format
(fifth entry
))))
611 (return-from pick-output-routine
612 (values (symbol-function (third entry
))
615 ;; KLUDGE: dealing with the buffering here leads to excessive code
618 ;; KLUDGE: also see comments in PICK-INPUT-ROUTINE
619 (loop for i from
40 by
8 to
1024 ; ARB (KLUDGE)
620 if
(subtypep type
`(unsigned-byte ,i
))
621 do
(return-from pick-output-routine
625 (lambda (stream byte
)
626 (output-wrapper (stream (/ i
8) (:none
) nil
)
627 (loop for j from
0 below
(/ i
8)
629 (fd-stream-obuf-sap stream
)
630 (+ j
(fd-stream-obuf-tail stream
)))
631 (ldb (byte 8 (- i
8 (* j
8))) byte
))))))
633 (lambda (stream byte
)
634 (output-wrapper (stream (/ i
8) (:full
) nil
)
635 (loop for j from
0 below
(/ i
8)
637 (fd-stream-obuf-sap stream
)
638 (+ j
(fd-stream-obuf-tail stream
)))
639 (ldb (byte 8 (- i
8 (* j
8))) byte
)))))))
642 (loop for i from
40 by
8 to
1024 ; ARB (KLUDGE)
643 if
(subtypep type
`(signed-byte ,i
))
644 do
(return-from pick-output-routine
648 (lambda (stream byte
)
649 (output-wrapper (stream (/ i
8) (:none
) nil
)
650 (loop for j from
0 below
(/ i
8)
652 (fd-stream-obuf-sap stream
)
653 (+ j
(fd-stream-obuf-tail stream
)))
654 (ldb (byte 8 (- i
8 (* j
8))) byte
))))))
656 (lambda (stream byte
)
657 (output-wrapper (stream (/ i
8) (:full
) nil
)
658 (loop for j from
0 below
(/ i
8)
660 (fd-stream-obuf-sap stream
)
661 (+ j
(fd-stream-obuf-tail stream
)))
662 (ldb (byte 8 (- i
8 (* j
8))) byte
)))))))
666 ;;;; input routines and related noise
668 ;;; a list of all available input routines. Each element is a list of
669 ;;; the element-type input, the function name, and the number of bytes
671 (defvar *input-routines
* ())
673 ;;; Return whether a primitive partial read operation on STREAM's FD
674 ;;; would (probably) block. Signal a `simple-stream-error' if the
675 ;;; system call implementing this operation fails.
677 ;;; It is "may" instead of "would" because "would" is not quite
678 ;;; correct on win32. However, none of the places that use it require
679 ;;; further assurance than "may" versus "will definitely not".
680 (defun sysread-may-block-p (stream)
682 ;; This answers T at EOF on win32, I think.
683 (not (sb!win32
:fd-listen
(fd-stream-fd stream
)))
685 (sb!unix
:with-restarted-syscall
(count errno
)
686 (sb!alien
:with-alien
((read-fds (sb!alien
:struct sb
!unix
:fd-set
)))
687 (sb!unix
:fd-zero read-fds
)
688 (sb!unix
:fd-set
(fd-stream-fd stream
) read-fds
)
689 (sb!unix
:unix-fast-select
(1+ (fd-stream-fd stream
))
690 (sb!alien
:addr read-fds
)
696 (simple-stream-perror "couldn't check whether ~S is readable"
700 ;;; If the read would block wait (using SERVE-EVENT) till input is available,
701 ;;; then fill the input buffer, and return the number of bytes read. Throws
702 ;;; to EOF-INPUT-CATCHER if the eof was reached.
703 (defun refill-buffer/fd
(stream)
704 (let ((fd (fd-stream-fd stream
))
708 ;; Check for blocking input before touching the stream, as if
709 ;; we happen to wait we are liable to be interrupted, and the
710 ;; interrupt handler may use the same stream.
711 (if (sysread-may-block-p stream
)
714 ;; These (:CLOSED-FLAME and :READ-ERROR) tags are here so what
715 ;; we can signal errors outside the WITHOUT-INTERRUPTS.
717 (closed-flame stream
)
719 (simple-stream-perror "couldn't read from ~S" stream errno
)
721 ;; This tag is here so we can unwind outside the WITHOUT-INTERRUPTS
722 ;; to wait for input if read tells us EWOULDBLOCK.
723 (unless (wait-until-fd-usable fd
:input
(fd-stream-timeout stream
))
724 (signal-timeout 'io-timeout
:stream stream
:direction
:read
725 :seconds
(fd-stream-timeout stream
)))
727 ;; Since the read should not block, we'll disable the
728 ;; interrupts here, so that we don't accidentally unwind and
729 ;; leave the stream in an inconsistent state.
731 (let ((ibuf-sap (fd-stream-ibuf-sap stream
))
732 (buflen (fd-stream-ibuf-length stream
))
733 (head (fd-stream-ibuf-head stream
))
734 (tail (fd-stream-ibuf-tail stream
)))
735 (declare (type index head tail
))
736 ;; Check the SAP: if it is null, then someone has closed
737 ;; the stream from underneath us. This is not ment to fix
738 ;; multithreaded races, but to deal with interrupt handlers
739 ;; closing the stream.
743 (cond ((eql head tail
)
746 (fd-stream-ibuf-head stream
) 0
747 (fd-stream-ibuf-tail stream
) 0))
750 (system-area-ub8-copy ibuf-sap head
753 (fd-stream-ibuf-head stream
) 0
754 (fd-stream-ibuf-tail stream
) tail
))))
755 (setf (fd-stream-listen stream
) nil
)
756 (setf (values count errno
)
757 (sb!unix
:unix-read fd
(int-sap (+ (sap-int ibuf-sap
) tail
))
763 (if (eql errno sb
!unix
:ewouldblock
)
767 (setf (fd-stream-listen stream
) :eof
)
768 (/show0
"THROWing EOF-INPUT-CATCHER")
769 (throw 'eof-input-catcher nil
))
772 (incf (fd-stream-ibuf-tail stream
) count
))))))
775 ;;; Make sure there are at least BYTES number of bytes in the input
776 ;;; buffer. Keep calling REFILL-BUFFER/FD until that condition is met.
777 (defmacro input-at-least
(stream bytes
)
778 (let ((stream-var (gensym))
779 (bytes-var (gensym)))
780 `(let ((,stream-var
,stream
)
783 (when (>= (- (fd-stream-ibuf-tail ,stream-var
)
784 (fd-stream-ibuf-head ,stream-var
))
787 (refill-buffer/fd
,stream-var
)))))
789 (defmacro input-wrapper
/variable-width
((stream bytes eof-error eof-value
)
791 (let ((stream-var (gensym))
793 (element-var (gensym)))
794 `(let ((,stream-var
,stream
)
796 (if (fd-stream-unread ,stream-var
)
798 (fd-stream-unread ,stream-var
)
799 (setf (fd-stream-unread ,stream-var
) nil
)
800 (setf (fd-stream-listen ,stream-var
) nil
))
801 (let ((,element-var nil
)
802 (decode-break-reason nil
))
806 (catch 'eof-input-catcher
807 (setf decode-break-reason
808 (block decode-break-reason
809 (input-at-least ,stream-var
1)
810 (let* ((byte (sap-ref-8 (fd-stream-ibuf-sap
814 (declare (ignorable byte
))
816 (input-at-least ,stream-var size
)
817 (setq ,element-var
(locally ,@read-forms
))
818 (setq ,retry-var nil
))
820 (when decode-break-reason
821 (stream-decoding-error-and-handle stream
822 decode-break-reason
))
824 (let ((octet-count (- (fd-stream-ibuf-tail ,stream-var
)
825 (fd-stream-ibuf-head ,stream-var
))))
826 (when (or (zerop octet-count
)
827 (and (not ,element-var
)
828 (not decode-break-reason
)
829 (stream-decoding-error-and-handle
830 stream octet-count
)))
831 (setq ,retry-var nil
)))))
833 (incf (fd-stream-ibuf-head ,stream-var
) size
)
836 (eof-or-lose ,stream-var
,eof-error
,eof-value
))))))))
838 ;;; a macro to wrap around all input routines to handle EOF-ERROR noise
839 (defmacro input-wrapper
((stream bytes eof-error eof-value
) &body read-forms
)
840 (let ((stream-var (gensym))
841 (element-var (gensym)))
842 `(let ((,stream-var
,stream
))
843 (if (fd-stream-unread ,stream-var
)
845 (fd-stream-unread ,stream-var
)
846 (setf (fd-stream-unread ,stream-var
) nil
)
847 (setf (fd-stream-listen ,stream-var
) nil
))
849 (catch 'eof-input-catcher
850 (input-at-least ,stream-var
,bytes
)
851 (locally ,@read-forms
))))
853 (incf (fd-stream-ibuf-head ,stream-var
) ,bytes
)
856 (eof-or-lose ,stream-var
,eof-error
,eof-value
))))))))
858 (defmacro def-input-routine
/variable-width
(name
859 (type external-format size sap head
)
862 (defun ,name
(stream eof-error eof-value
)
863 (input-wrapper/variable-width
(stream ,size eof-error eof-value
)
864 (let ((,sap
(fd-stream-ibuf-sap stream
))
865 (,head
(fd-stream-ibuf-head stream
)))
867 (setf *input-routines
*
868 (nconc *input-routines
*
869 (list (list ',type
',name
1 ',external-format
))))))
871 (defmacro def-input-routine
(name
875 (defun ,name
(stream eof-error eof-value
)
876 (input-wrapper (stream ,size eof-error eof-value
)
877 (let ((,sap
(fd-stream-ibuf-sap stream
))
878 (,head
(fd-stream-ibuf-head stream
)))
880 (setf *input-routines
*
881 (nconc *input-routines
*
882 (list (list ',type
',name
',size nil
))))))
884 ;;; STREAM-IN routine for reading a string char
885 (def-input-routine input-character
886 (character 1 sap head
)
887 (code-char (sap-ref-8 sap head
)))
889 ;;; STREAM-IN routine for reading an unsigned 8 bit number
890 (def-input-routine input-unsigned-8bit-byte
891 ((unsigned-byte 8) 1 sap head
)
892 (sap-ref-8 sap head
))
894 ;;; STREAM-IN routine for reading a signed 8 bit number
895 (def-input-routine input-signed-8bit-number
896 ((signed-byte 8) 1 sap head
)
897 (signed-sap-ref-8 sap head
))
899 ;;; STREAM-IN routine for reading an unsigned 16 bit number
900 (def-input-routine input-unsigned-16bit-byte
901 ((unsigned-byte 16) 2 sap head
)
902 (sap-ref-16 sap head
))
904 ;;; STREAM-IN routine for reading a signed 16 bit number
905 (def-input-routine input-signed-16bit-byte
906 ((signed-byte 16) 2 sap head
)
907 (signed-sap-ref-16 sap head
))
909 ;;; STREAM-IN routine for reading a unsigned 32 bit number
910 (def-input-routine input-unsigned-32bit-byte
911 ((unsigned-byte 32) 4 sap head
)
912 (sap-ref-32 sap head
))
914 ;;; STREAM-IN routine for reading a signed 32 bit number
915 (def-input-routine input-signed-32bit-byte
916 ((signed-byte 32) 4 sap head
)
917 (signed-sap-ref-32 sap head
))
919 #+#.
(cl:if
(cl:= sb
!vm
:n-word-bits
64) '(and) '(or))
921 (def-input-routine input-unsigned-64bit-byte
922 ((unsigned-byte 64) 8 sap head
)
923 (sap-ref-64 sap head
))
924 (def-input-routine input-signed-64bit-byte
925 ((signed-byte 64) 8 sap head
)
926 (signed-sap-ref-64 sap head
)))
928 ;;; Find an input routine to use given the type. Return as multiple
929 ;;; values the routine, the real type transfered, and the number of
930 ;;; bytes per element (and for character types string input routine).
931 (defun pick-input-routine (type &optional external-format
)
932 (when (subtypep type
'character
)
933 (dolist (entry *external-formats
*)
934 (when (member external-format
(first entry
))
935 (return-from pick-input-routine
936 (values (symbol-function (third entry
))
939 (symbol-function (second entry
))
940 (first (first entry
)))))))
941 (dolist (entry *input-routines
*)
942 (when (and (subtypep type
(first entry
))
943 (or (not (fourth entry
))
944 (eq external-format
(fourth entry
))))
945 (return-from pick-input-routine
946 (values (symbol-function (second entry
))
949 ;; FIXME: let's do it the hard way, then (but ignore things like
950 ;; endianness, efficiency, and the necessary coupling between these
951 ;; and the output routines). -- CSR, 2004-02-09
952 (loop for i from
40 by
8 to
1024 ; ARB (well, KLUDGE really)
953 if
(subtypep type
`(unsigned-byte ,i
))
954 do
(return-from pick-input-routine
956 (lambda (stream eof-error eof-value
)
957 (input-wrapper (stream (/ i
8) eof-error eof-value
)
958 (let ((sap (fd-stream-ibuf-sap stream
))
959 (head (fd-stream-ibuf-head stream
)))
960 (loop for j from
0 below
(/ i
8)
964 (sap-ref-8 sap
(+ head j
))))
965 finally
(return result
)))))
968 (loop for i from
40 by
8 to
1024 ; ARB (well, KLUDGE really)
969 if
(subtypep type
`(signed-byte ,i
))
970 do
(return-from pick-input-routine
972 (lambda (stream eof-error eof-value
)
973 (input-wrapper (stream (/ i
8) eof-error eof-value
)
974 (let ((sap (fd-stream-ibuf-sap stream
))
975 (head (fd-stream-ibuf-head stream
)))
976 (loop for j from
0 below
(/ i
8)
980 (sap-ref-8 sap
(+ head j
))))
981 finally
(return (if (logbitp (1- i
) result
)
982 (dpb result
(byte i
0) -
1)
987 ;;; Return a string constructed from SAP, START, and END.
988 (defun string-from-sap (sap start end
)
989 (declare (type index start end
))
990 (let* ((length (- end start
))
991 (string (make-string length
)))
992 (copy-ub8-from-system-area sap start
997 ;;; the N-BIN method for FD-STREAMs
999 ;;; Note that this blocks in UNIX-READ. It is generally used where
1000 ;;; there is a definite amount of reading to be done, so blocking
1001 ;;; isn't too problematical.
1002 (defun fd-stream-read-n-bytes (stream buffer start requested eof-error-p
1003 &aux
(total-copied 0))
1004 (declare (type fd-stream stream
))
1005 (declare (type index start requested total-copied
))
1006 (let ((unread (fd-stream-unread stream
)))
1008 ;; AVERs designed to fail when we have more complicated
1009 ;; character representations.
1010 (aver (typep unread
'base-char
))
1011 (aver (= (fd-stream-element-size stream
) 1))
1012 ;; KLUDGE: this is a slightly-unrolled-and-inlined version of
1015 (system-area-pointer
1016 (setf (sap-ref-8 buffer start
) (char-code unread
)))
1017 ((simple-unboxed-array (*))
1018 (setf (aref buffer start
) unread
)))
1019 (setf (fd-stream-unread stream
) nil
)
1020 (setf (fd-stream-listen stream
) nil
)
1021 (incf total-copied
)))
1024 (let* ((remaining-request (- requested total-copied
))
1025 (head (fd-stream-ibuf-head stream
))
1026 (tail (fd-stream-ibuf-tail stream
))
1027 (available (- tail head
))
1028 (n-this-copy (min remaining-request available
))
1029 (this-start (+ start total-copied
))
1030 (this-end (+ this-start n-this-copy
))
1031 (sap (fd-stream-ibuf-sap stream
)))
1032 (declare (type index remaining-request head tail available
))
1033 (declare (type index n-this-copy
))
1034 ;; Copy data from stream buffer into user's buffer.
1035 (%byte-blt sap head buffer this-start this-end
)
1036 (incf (fd-stream-ibuf-head stream
) n-this-copy
)
1037 (incf total-copied n-this-copy
)
1038 ;; Maybe we need to refill the stream buffer.
1039 (cond (;; If there were enough data in the stream buffer, we're done.
1040 (= total-copied requested
)
1041 (return total-copied
))
1042 (;; If EOF, we're done in another way.
1043 (null (catch 'eof-input-catcher
(refill-buffer/fd stream
)))
1045 (error 'end-of-file
:stream stream
)
1046 (return total-copied
)))
1047 ;; Otherwise we refilled the stream buffer, so fall
1048 ;; through into another pass of the loop.
1051 (defun fd-stream-resync (stream)
1052 (dolist (entry *external-formats
*)
1053 (when (member (fd-stream-external-format stream
) (first entry
))
1054 (return-from fd-stream-resync
1055 (funcall (symbol-function (eighth entry
)) stream
)))))
1057 (defun get-fd-stream-character-sizer (stream)
1058 (dolist (entry *external-formats
*)
1059 (when (member (fd-stream-external-format stream
) (first entry
))
1060 (return-from get-fd-stream-character-sizer
(ninth entry
)))))
1062 (defun fd-stream-character-size (stream char
)
1063 (let ((sizer (get-fd-stream-character-sizer stream
)))
1064 (when sizer
(funcall sizer char
))))
1066 (defun fd-stream-string-size (stream string
)
1067 (let ((sizer (get-fd-stream-character-sizer stream
)))
1069 (loop for char across string summing
(funcall sizer char
)))))
1071 (defun find-external-format (external-format)
1072 (when external-format
1073 (find external-format
*external-formats
* :test
#'member
:key
#'car
)))
1075 (defun variable-width-external-format-p (ef-entry)
1076 (when (eighth ef-entry
) t
))
1078 (defun bytes-for-char-fun (ef-entry)
1079 (if ef-entry
(symbol-function (ninth ef-entry
)) (constantly 1)))
1081 ;;; FIXME: OAOOM here vrt. *EXTERNAL-FORMAT-FUNCTIONS* in fd-stream.lisp
1082 (defmacro define-external-format
(external-format size output-restart
1084 (let* ((name (first external-format
))
1085 (out-function (symbolicate "OUTPUT-BYTES/" name
))
1086 (format (format nil
"OUTPUT-CHAR-~A-~~A-BUFFERED" (string name
)))
1087 (in-function (symbolicate "FD-STREAM-READ-N-CHARACTERS/" name
))
1088 (in-char-function (symbolicate "INPUT-CHAR/" name
))
1089 (size-function (symbolicate "BYTES-FOR-CHAR/" name
))
1090 (read-c-string-function (symbolicate "READ-FROM-C-STRING/" name
))
1091 (output-c-string-function (symbolicate "OUTPUT-TO-C-STRING/" name
))
1092 (n-buffer (gensym "BUFFER")))
1094 (defun ,size-function
(byte)
1095 (declare (ignore byte
))
1097 (defun ,out-function
(stream string flush-p start end
)
1098 (let ((start (or start
0))
1099 (end (or end
(length string
))))
1100 (declare (type index start end
))
1101 (when (and (not (fd-stream-dual-channel-p stream
))
1102 (> (fd-stream-ibuf-tail stream
)
1103 (fd-stream-ibuf-head stream
)))
1104 (file-position stream
(file-position stream
)))
1105 (unless (<= 0 start end
(length string
))
1106 (signal-bounding-indices-bad-error string start end
))
1109 (setf (fd-stream-obuf-tail stream
)
1110 (string-dispatch (simple-base-string
1112 (simple-array character
(*))
1115 (let ((len (fd-stream-obuf-length stream
))
1116 (sap (fd-stream-obuf-sap stream
))
1117 (tail (fd-stream-obuf-tail stream
)))
1118 (declare (type index tail
)
1119 ;; STRING bounds have already been checked.
1120 (optimize (safety 0)))
1122 (,@(if output-restart
1123 `(catch 'output-nothing
)
1126 ((or (= start end
) (< (- len tail
) 4)))
1127 (let* ((byte (aref string start
))
1128 (bits (char-code byte
)))
1132 ;; Exited from the loop normally
1134 ;; Exited via CATCH. Skip the current character
1135 ;; and try the inner loop again.
1138 (flush-output-buffer stream
)))
1140 (flush-output-buffer stream
))))
1141 (def-output-routines (,format
1147 (if (char= byte
#\Newline
)
1148 (setf (fd-stream-char-pos stream
) 0)
1149 (incf (fd-stream-char-pos stream
)))
1150 (let ((bits (char-code byte
))
1151 (sap (fd-stream-obuf-sap stream
))
1152 (tail (fd-stream-obuf-tail stream
)))
1154 (defun ,in-function
(stream buffer start requested eof-error-p
1155 &aux
(index start
) (end (+ start requested
)))
1156 (declare (type fd-stream stream
)
1157 (type index start requested index end
)
1159 (simple-array character
(#.
+ansi-stream-in-buffer-length
+))
1161 (let ((unread (fd-stream-unread stream
)))
1163 (setf (aref buffer index
) unread
)
1164 (setf (fd-stream-unread stream
) nil
)
1165 (setf (fd-stream-listen stream
) nil
)
1169 (let* ((head (fd-stream-ibuf-head stream
))
1170 (tail (fd-stream-ibuf-tail stream
))
1171 (sap (fd-stream-ibuf-sap stream
)))
1172 (declare (type index head tail
)
1173 (type system-area-pointer sap
))
1174 ;; Copy data from stream buffer into user's buffer.
1175 (dotimes (i (min (truncate (- tail head
) ,size
)
1177 (declare (optimize speed
))
1178 (let* ((byte (sap-ref-8 sap head
)))
1179 (setf (aref buffer index
) ,in-expr
)
1182 (setf (fd-stream-ibuf-head stream
) head
)
1183 ;; Maybe we need to refill the stream buffer.
1184 (cond ( ;; If there was enough data in the stream buffer, we're done.
1186 (return (- index start
)))
1187 ( ;; If EOF, we're done in another way.
1188 (null (catch 'eof-input-catcher
(refill-buffer/fd stream
)))
1190 (error 'end-of-file
:stream stream
)
1191 (return (- index start
))))
1192 ;; Otherwise we refilled the stream buffer, so fall
1193 ;; through into another pass of the loop.
1195 (def-input-routine ,in-char-function
(character ,size sap head
)
1196 (let ((byte (sap-ref-8 sap head
)))
1198 (defun ,read-c-string-function
(sap element-type
)
1199 (declare (type system-area-pointer sap
)
1200 (type (member character base-char
) element-type
))
1202 (declare (optimize (speed 3) (safety 0)))
1203 (let* ((stream ,name
)
1205 (loop for head of-type index upfrom
0 by
,size
1206 for count of-type index upto
(1- array-dimension-limit
)
1207 for byte
= (sap-ref-8 sap head
)
1208 for char of-type character
= ,in-expr
1209 until
(zerop (char-code char
))
1210 finally
(return count
)))
1211 ;; Inline the common cases
1212 (string (make-string length
:element-type element-type
)))
1213 (declare (ignorable stream
)
1215 (type simple-string string
))
1216 (/show0 before-copy-loop
)
1217 (loop for head of-type index upfrom
0 by
,size
1218 for index of-type index below length
1219 for byte
= (sap-ref-8 sap head
)
1220 for char of-type character
= ,in-expr
1221 do
(setf (aref string index
) char
))
1222 string
))) ;; last loop rewrite to dotimes?
1223 (defun ,output-c-string-function
(string)
1224 (declare (type simple-string string
))
1226 (declare (optimize (speed 3) (safety 0)))
1227 (let* ((length (length string
))
1228 (,n-buffer
(make-array (* (1+ length
) ,size
)
1229 :element-type
'(unsigned-byte 8)))
1230 ;; This SAP-taking may seem unsafe without pinning,
1231 ;; but since the variable name is a gensym OUT-EXPR
1232 ;; cannot close over it even if it tried, so the buffer
1233 ;; will always be either in a register or on stack.
1234 ;; FIXME: But ...this is true on x86oids only!
1235 (sap (vector-sap ,n-buffer
))
1238 (declare (type index length tail
)
1239 (type system-area-pointer sap
))
1241 (let* ((byte (aref string i
))
1242 (bits (char-code byte
)))
1243 (declare (ignorable byte bits
))
1247 (byte (code-char bits
)))
1248 (declare (ignorable bits byte
))
1251 (setf *external-formats
*
1252 (cons '(,external-format
,in-function
,in-char-function
,out-function
1253 ,@(mapcar #'(lambda (buffering)
1254 (intern (format nil format
(string buffering
))))
1255 '(:none
:line
:full
))
1256 nil
; no resync-function
1257 ,size-function
,read-c-string-function
,output-c-string-function
)
1258 *external-formats
*)))))
1260 (defmacro define-external-format
/variable-width
1261 (external-format output-restart out-size-expr
1262 out-expr in-size-expr in-expr
)
1263 (let* ((name (first external-format
))
1264 (out-function (symbolicate "OUTPUT-BYTES/" name
))
1265 (format (format nil
"OUTPUT-CHAR-~A-~~A-BUFFERED" (string name
)))
1266 (in-function (symbolicate "FD-STREAM-READ-N-CHARACTERS/" name
))
1267 (in-char-function (symbolicate "INPUT-CHAR/" name
))
1268 (resync-function (symbolicate "RESYNC/" name
))
1269 (size-function (symbolicate "BYTES-FOR-CHAR/" name
))
1270 (read-c-string-function (symbolicate "READ-FROM-C-STRING/" name
))
1271 (output-c-string-function (symbolicate "OUTPUT-TO-C-STRING/" name
))
1272 (n-buffer (gensym "BUFFER")))
1274 (defun ,size-function
(byte)
1275 (declare (ignorable byte
))
1277 (defun ,out-function
(stream string flush-p start end
)
1278 (let ((start (or start
0))
1279 (end (or end
(length string
))))
1280 (declare (type index start end
))
1281 (when (and (not (fd-stream-dual-channel-p stream
))
1282 (> (fd-stream-ibuf-tail stream
)
1283 (fd-stream-ibuf-head stream
)))
1284 (file-position stream
(file-position stream
)))
1285 (unless (<= 0 start end
(length string
))
1286 (signal-bounding-indices-bad-error string start end
))
1289 (setf (fd-stream-obuf-tail stream
)
1290 (string-dispatch (simple-base-string
1292 (simple-array character
(*))
1295 (let ((len (fd-stream-obuf-length stream
))
1296 (sap (fd-stream-obuf-sap stream
))
1297 (tail (fd-stream-obuf-tail stream
)))
1298 (declare (type index tail
)
1299 ;; STRING bounds have already been checked.
1300 (optimize (safety 0)))
1302 (,@(if output-restart
1303 `(catch 'output-nothing
)
1306 ((or (= start end
) (< (- len tail
) 4)))
1307 (let* ((byte (aref string start
))
1308 (bits (char-code byte
))
1309 (size ,out-size-expr
))
1313 ;; Exited from the loop normally
1315 ;; Exited via CATCH. Skip the current character
1316 ;; and try the inner loop again.
1319 (flush-output-buffer stream
)))
1321 (flush-output-buffer stream
))))
1322 (def-output-routines/variable-width
(,format
1329 (if (char= byte
#\Newline
)
1330 (setf (fd-stream-char-pos stream
) 0)
1331 (incf (fd-stream-char-pos stream
)))
1332 (let ((bits (char-code byte
))
1333 (sap (fd-stream-obuf-sap stream
))
1334 (tail (fd-stream-obuf-tail stream
)))
1336 (defun ,in-function
(stream buffer start requested eof-error-p
1337 &aux
(total-copied 0))
1338 (declare (type fd-stream stream
)
1339 (type index start requested total-copied
)
1341 (simple-array character
(#.
+ansi-stream-in-buffer-length
+))
1343 (let ((unread (fd-stream-unread stream
)))
1345 (setf (aref buffer start
) unread
)
1346 (setf (fd-stream-unread stream
) nil
)
1347 (setf (fd-stream-listen stream
) nil
)
1348 (incf total-copied
)))
1351 (let* ((head (fd-stream-ibuf-head stream
))
1352 (tail (fd-stream-ibuf-tail stream
))
1353 (sap (fd-stream-ibuf-sap stream
))
1354 (decode-break-reason nil
))
1355 (declare (type index head tail
))
1356 ;; Copy data from stream buffer into user's buffer.
1357 (do ((size nil nil
))
1358 ((or (= tail head
) (= requested total-copied
)))
1359 (setf decode-break-reason
1360 (block decode-break-reason
1361 (let ((byte (sap-ref-8 sap head
)))
1362 (declare (ignorable byte
))
1363 (setq size
,in-size-expr
)
1364 (when (> size
(- tail head
))
1366 (setf (aref buffer
(+ start total-copied
)) ,in-expr
)
1370 (setf (fd-stream-ibuf-head stream
) head
)
1371 (when decode-break-reason
1372 ;; If we've already read some characters on when the invalid
1373 ;; code sequence is detected, we return immediately. The
1374 ;; handling of the error is deferred until the next call
1375 ;; (where this check will be false). This allows establishing
1376 ;; high-level handlers for decode errors (for example
1377 ;; automatically resyncing in Lisp comments).
1378 (when (plusp total-copied
)
1379 (return-from ,in-function total-copied
))
1380 (when (stream-decoding-error-and-handle
1381 stream decode-break-reason
)
1383 (error 'end-of-file
:stream stream
)
1384 (return-from ,in-function total-copied
)))
1385 (setf head
(fd-stream-ibuf-head stream
))
1386 (setf tail
(fd-stream-ibuf-tail stream
))))
1387 (setf (fd-stream-ibuf-head stream
) head
)
1388 ;; Maybe we need to refill the stream buffer.
1389 (cond ( ;; If there were enough data in the stream buffer, we're done.
1390 (= total-copied requested
)
1391 (return total-copied
))
1392 ( ;; If EOF, we're done in another way.
1393 (or (eq decode-break-reason
'eof
)
1394 (null (catch 'eof-input-catcher
1395 (refill-buffer/fd stream
))))
1397 (error 'end-of-file
:stream stream
)
1398 (return total-copied
)))
1399 ;; Otherwise we refilled the stream buffer, so fall
1400 ;; through into another pass of the loop.
1402 (def-input-routine/variable-width
,in-char-function
(character
1406 (let ((byte (sap-ref-8 sap head
)))
1407 (declare (ignorable byte
))
1409 (defun ,resync-function
(stream)
1410 (loop (input-at-least stream
2)
1411 (incf (fd-stream-ibuf-head stream
))
1412 (unless (block decode-break-reason
1413 (let* ((sap (fd-stream-ibuf-sap stream
))
1414 (head (fd-stream-ibuf-head stream
))
1415 (byte (sap-ref-8 sap head
))
1416 (size ,in-size-expr
))
1417 (declare (ignorable byte
))
1418 (input-at-least stream size
)
1419 (let ((sap (fd-stream-ibuf-sap stream
))
1420 (head (fd-stream-ibuf-head stream
)))
1424 (defun ,read-c-string-function
(sap element-type
)
1425 (declare (type system-area-pointer sap
))
1427 (declare (optimize (speed 3) (safety 0)))
1428 (let* ((stream ,name
)
1429 (size 0) (head 0) (byte 0) (char nil
)
1430 (decode-break-reason nil
)
1431 (length (dotimes (count (1- ARRAY-DIMENSION-LIMIT
) count
)
1432 (setf decode-break-reason
1433 (block decode-break-reason
1434 (setf byte
(sap-ref-8 sap head
)
1439 (when decode-break-reason
1440 (c-string-decoding-error ,name decode-break-reason
))
1441 (when (zerop (char-code char
))
1443 (string (make-string length
:element-type element-type
)))
1444 (declare (ignorable stream
)
1445 (type index head length
) ;; size
1446 (type (unsigned-byte 8) byte
)
1447 (type (or null character
) char
)
1448 (type string string
))
1450 (dotimes (index length string
)
1451 (setf decode-break-reason
1452 (block decode-break-reason
1453 (setf byte
(sap-ref-8 sap head
)
1458 (when decode-break-reason
1459 (c-string-decoding-error ,name decode-break-reason
))
1460 (setf (aref string index
) char
)))))
1462 (defun ,output-c-string-function
(string)
1463 (declare (type simple-string string
))
1465 (declare (optimize (speed 3) (safety 0)))
1466 (let* ((length (length string
))
1467 (char-length (make-array (1+ length
) :element-type
'index
))
1469 (+ (loop for i of-type index below length
1470 for byte of-type character
= (aref string i
)
1471 for bits
= (char-code byte
)
1472 sum
(setf (aref char-length i
)
1473 (the index
,out-size-expr
)))
1474 (let* ((byte (code-char 0))
1475 (bits (char-code byte
)))
1476 (declare (ignorable byte bits
))
1477 (setf (aref char-length length
)
1478 (the index
,out-size-expr
)))))
1480 (,n-buffer
(make-array buffer-length
1481 :element-type
'(unsigned-byte 8)))
1482 ;; This SAP-taking may seem unsafe without pinning,
1483 ;; but since the variable name is a gensym OUT-EXPR
1484 ;; cannot close over it even if it tried, so the buffer
1485 ;; will always be either in a register or on stack.
1486 ;; FIXME: But ...this is true on x86oids only!
1487 (sap (vector-sap ,n-buffer
))
1489 (declare (type index length buffer-length tail
)
1490 (type system-area-pointer sap
)
1493 (loop for i of-type index below length
1494 for byte of-type character
= (aref string i
)
1495 for bits
= (char-code byte
)
1496 for size of-type index
= (aref char-length i
)
1501 (byte (code-char bits
))
1502 (size (aref char-length length
)))
1503 (declare (ignorable bits byte size
))
1507 (setf *external-formats
*
1508 (cons '(,external-format
,in-function
,in-char-function
,out-function
1509 ,@(mapcar #'(lambda (buffering)
1510 (intern (format nil format
(string buffering
))))
1511 '(:none
:line
:full
))
1513 ,size-function
,read-c-string-function
,output-c-string-function
)
1514 *external-formats
*)))))
1516 ;;; Multiple names for the :ISO{,-}8859-* families are needed because on
1517 ;;; FreeBSD (and maybe other BSD systems), nl_langinfo("LATIN-1") will
1518 ;;; return "ISO8859-1" instead of "ISO-8859-1".
1519 (define-external-format (:latin-1
:latin1
:iso-8859-1
:iso8859-1
)
1522 (external-format-encoding-error stream bits
)
1523 (setf (sap-ref-8 sap tail
) bits
))
1526 (define-external-format (:ascii
:us-ascii
:ansi_x3.4-
1968
1527 :iso-646
:iso-646-us
:|
646|
)
1530 (external-format-encoding-error stream bits
)
1531 (setf (sap-ref-8 sap tail
) bits
))
1534 (let* ((table (let ((s (make-string 256)))
1535 (map-into s
#'code-char
1536 '(#x00
#x01
#x02
#x03
#x9c
#x09
#x86
#x7f
#x97
#x8d
#x8e
#x0b
#x0c
#x0d
#x0e
#x0f
1537 #x10
#x11
#x12
#x13
#x9d
#x85
#x08
#x87
#x18
#x19
#x92
#x8f
#x1c
#x1d
#x1e
#x1f
1538 #x80
#x81
#x82
#x83
#x84
#x0a
#x17
#x1b
#x88
#x89
#x8a
#x8b
#x8c
#x05
#x06
#x07
1539 #x90
#x91
#x16
#x93
#x94
#x95
#x96
#x04
#x98
#x99
#x9a
#x9b
#x14
#x15
#x9e
#x1a
1540 #x20
#xa0
#xe2
#xe4
#xe0
#xe1
#xe3
#xe5
#xe7
#xf1
#xa2
#x2e
#x3c
#x28
#x2b
#x7c
1541 #x26
#xe9
#xea
#xeb
#xe8
#xed
#xee
#xef
#xec
#xdf
#x21
#x24
#x2a
#x29
#x3b
#xac
1542 #x2d
#x2f
#xc2
#xc4
#xc0
#xc1
#xc3
#xc5
#xc7
#xd1
#xa6
#x2c
#x25
#x5f
#x3e
#x3f
1543 #xf8
#xc9
#xca
#xcb
#xc8
#xcd
#xce
#xcf
#xcc
#x60
#x3a
#x23
#x40
#x27
#x3d
#x22
1544 #xd8
#x61
#x62
#x63
#x64
#x65
#x66
#x67
#x68
#x69
#xab
#xbb
#xf0
#xfd
#xfe
#xb1
1545 #xb0
#x6a
#x6b
#x6c
#x6d
#x6e
#x6f
#x70
#x71
#x72
#xaa
#xba
#xe6
#xb8
#xc6
#xa4
1546 #xb5
#x7e
#x73
#x74
#x75
#x76
#x77
#x78
#x79
#x7a
#xa1
#xbf
#xd0
#xdd
#xde
#xae
1547 #x5e
#xa3
#xa5
#xb7
#xa9
#xa7
#xb6
#xbc
#xbd
#xbe
#x5b
#x5d
#xaf
#xa8
#xb4
#xd7
1548 #x7b
#x41
#x42
#x43
#x44
#x45
#x46
#x47
#x48
#x49
#xad
#xf4
#xf6
#xf2
#xf3
#xf5
1549 #x7d
#x4a
#x4b
#x4c
#x4d
#x4e
#x4f
#x50
#x51
#x52
#xb9
#xfb
#xfc
#xf9
#xfa
#xff
1550 #x5c
#xf7
#x53
#x54
#x55
#x56
#x57
#x58
#x59
#x5a
#xb2
#xd4
#xd6
#xd2
#xd3
#xd5
1551 #x30
#x31
#x32
#x33
#x34
#x35
#x36
#x37
#x38
#x39
#xb3
#xdb
#xdc
#xd9
#xda
#x9f
))
1553 (reverse-table (let ((rt (make-array 256 :element-type
'(unsigned-byte 8) :initial-element
0)))
1554 (loop for char across table for i from
0
1555 do
(aver (= 0 (aref rt
(char-code char
))))
1556 do
(setf (aref rt
(char-code char
)) i
))
1558 (define-external-format (:ebcdic-us
:ibm-037
:ibm037
)
1561 (external-format-encoding-error stream bits
)
1562 (setf (sap-ref-8 sap tail
) (aref reverse-table bits
)))
1567 (let ((latin-9-table (let ((table (make-string 256)))
1570 (setf (aref table i
) (code-char i
)))
1571 (setf (aref table
#xa4
) (code-char #x20ac
))
1572 (setf (aref table
#xa6
) (code-char #x0160
))
1573 (setf (aref table
#xa8
) (code-char #x0161
))
1574 (setf (aref table
#xb4
) (code-char #x017d
))
1575 (setf (aref table
#xb8
) (code-char #x017e
))
1576 (setf (aref table
#xbc
) (code-char #x0152
))
1577 (setf (aref table
#xbd
) (code-char #x0153
))
1578 (setf (aref table
#xbe
) (code-char #x0178
))
1580 (latin-9-reverse-1 (make-array 16
1581 :element-type
'(unsigned-byte 21)
1582 :initial-contents
'(#x0160
#x0161
#x0152
#x0153
0 0 0 0 #x0178
0 0 0 #x20ac
#x017d
#x017e
0)))
1583 (latin-9-reverse-2 (make-array 16
1584 :element-type
'(unsigned-byte 8)
1585 :initial-contents
'(#xa6
#xa8
#xbc
#xbd
0 0 0 0 #xbe
0 0 0 #xa4
#xb4
#xb8
0))))
1586 (define-external-format (:latin-9
:latin9
:iso-8859-15
:iso8859-15
)
1588 (setf (sap-ref-8 sap tail
)
1590 (if (= bits
(char-code (aref latin-9-table bits
)))
1592 (external-format-encoding-error stream byte
))
1593 (if (= (aref latin-9-reverse-1
(logand bits
15)) bits
)
1594 (aref latin-9-reverse-2
(logand bits
15))
1595 (external-format-encoding-error stream byte
))))
1596 (aref latin-9-table byte
)))
1598 (define-external-format/variable-width
(:utf-8
:utf8
) nil
1599 (let ((bits (char-code byte
)))
1600 (cond ((< bits
#x80
) 1)
1602 ((< bits
#x10000
) 3)
1605 (1 (setf (sap-ref-8 sap tail
) bits
))
1606 (2 (setf (sap-ref-8 sap tail
) (logior #xc0
(ldb (byte 5 6) bits
))
1607 (sap-ref-8 sap
(1+ tail
)) (logior #x80
(ldb (byte 6 0) bits
))))
1608 (3 (setf (sap-ref-8 sap tail
) (logior #xe0
(ldb (byte 4 12) bits
))
1609 (sap-ref-8 sap
(1+ tail
)) (logior #x80
(ldb (byte 6 6) bits
))
1610 (sap-ref-8 sap
(+ 2 tail
)) (logior #x80
(ldb (byte 6 0) bits
))))
1611 (4 (setf (sap-ref-8 sap tail
) (logior #xf0
(ldb (byte 3 18) bits
))
1612 (sap-ref-8 sap
(1+ tail
)) (logior #x80
(ldb (byte 6 12) bits
))
1613 (sap-ref-8 sap
(+ 2 tail
)) (logior #x80
(ldb (byte 6 6) bits
))
1614 (sap-ref-8 sap
(+ 3 tail
)) (logior #x80
(ldb (byte 6 0) bits
)))))
1615 (cond ((< byte
#x80
) 1)
1616 ((< byte
#xc2
) (return-from decode-break-reason
1))
1620 (code-char (ecase size
1622 (2 (let ((byte2 (sap-ref-8 sap
(1+ head
))))
1623 (unless (<= #x80 byte2
#xbf
)
1624 (return-from decode-break-reason
2))
1625 (dpb byte
(byte 5 6) byte2
)))
1626 (3 (let ((byte2 (sap-ref-8 sap
(1+ head
)))
1627 (byte3 (sap-ref-8 sap
(+ 2 head
))))
1628 (unless (and (<= #x80 byte2
#xbf
)
1629 (<= #x80 byte3
#xbf
))
1630 (return-from decode-break-reason
3))
1631 (dpb byte
(byte 4 12) (dpb byte2
(byte 6 6) byte3
))))
1632 (4 (let ((byte2 (sap-ref-8 sap
(1+ head
)))
1633 (byte3 (sap-ref-8 sap
(+ 2 head
)))
1634 (byte4 (sap-ref-8 sap
(+ 3 head
))))
1635 (unless (and (<= #x80 byte2
#xbf
)
1636 (<= #x80 byte3
#xbf
)
1637 (<= #x80 byte4
#xbf
))
1638 (return-from decode-break-reason
4))
1639 (dpb byte
(byte 3 18)
1640 (dpb byte2
(byte 6 12)
1641 (dpb byte3
(byte 6 6) byte4
))))))))
1643 ;;;; utility functions (misc routines, etc)
1645 ;;; Fill in the various routine slots for the given type. INPUT-P and
1646 ;;; OUTPUT-P indicate what slots to fill. The buffering slot must be
1647 ;;; set prior to calling this routine.
1648 (defun set-fd-stream-routines (fd-stream element-type external-format
1649 input-p output-p buffer-p
)
1650 (let* ((target-type (case element-type
1651 (unsigned-byte '(unsigned-byte 8))
1652 (signed-byte '(signed-byte 8))
1653 (:default
'character
)
1655 (character-stream-p (subtypep target-type
'character
))
1656 (bivalent-stream-p (eq element-type
:default
))
1657 normalized-external-format
1658 (bin-routine #'ill-bin
)
1661 (cin-routine #'ill-in
)
1664 (input-type nil
) ;calculated from bin-type/cin-type
1665 (input-size nil
) ;calculated from bin-size/cin-size
1666 (read-n-characters #'ill-in
)
1667 (bout-routine #'ill-bout
)
1670 (cout-routine #'ill-out
)
1675 (output-bytes #'ill-bout
))
1677 ;; drop buffers when direction changes
1678 (when (and (fd-stream-obuf-sap fd-stream
) (not output-p
))
1679 (with-available-buffers-lock ()
1680 (push (fd-stream-obuf-sap fd-stream
) *available-buffers
*)
1681 (setf (fd-stream-obuf-sap fd-stream
) nil
)))
1682 (when (and (fd-stream-ibuf-sap fd-stream
) (not input-p
))
1683 (with-available-buffers-lock ()
1684 (push (fd-stream-ibuf-sap fd-stream
) *available-buffers
*)
1685 (setf (fd-stream-ibuf-sap fd-stream
) nil
)))
1687 (setf (fd-stream-ibuf-sap fd-stream
) (next-available-buffer))
1688 (setf (fd-stream-ibuf-length fd-stream
) bytes-per-buffer
)
1689 (setf (fd-stream-ibuf-tail fd-stream
) 0))
1691 (setf (fd-stream-obuf-sap fd-stream
) (next-available-buffer))
1692 (setf (fd-stream-obuf-length fd-stream
) bytes-per-buffer
)
1693 (setf (fd-stream-obuf-tail fd-stream
) 0)
1694 (setf (fd-stream-char-pos fd-stream
) 0))
1696 (when (and character-stream-p
1697 (eq external-format
:default
))
1698 (/show0
"/getting default external format")
1699 (setf external-format
(default-external-format)))
1702 (when (or (not character-stream-p
) bivalent-stream-p
)
1703 (multiple-value-setq (bin-routine bin-type bin-size read-n-characters
1704 normalized-external-format
)
1705 (pick-input-routine (if bivalent-stream-p
'(unsigned-byte 8)
1709 (error "could not find any input routine for ~S" target-type
)))
1710 (when character-stream-p
1711 (multiple-value-setq (cin-routine cin-type cin-size read-n-characters
1712 normalized-external-format
)
1713 (pick-input-routine target-type external-format
))
1715 (error "could not find any input routine for ~S" target-type
)))
1716 (setf (fd-stream-in fd-stream
) cin-routine
1717 (fd-stream-bin fd-stream
) bin-routine
)
1718 ;; character type gets preferential treatment
1719 (setf input-size
(or cin-size bin-size
))
1720 (setf input-type
(or cin-type bin-type
))
1721 (when normalized-external-format
1722 (setf (fd-stream-external-format fd-stream
)
1723 normalized-external-format
))
1724 (when (= (or cin-size
1) (or bin-size
1) 1)
1725 (setf (fd-stream-n-bin fd-stream
) ;XXX
1726 (if (and character-stream-p
(not bivalent-stream-p
))
1728 #'fd-stream-read-n-bytes
))
1729 ;; Sometimes turn on fast-read-char/fast-read-byte. Switch on
1730 ;; for character and (unsigned-byte 8) streams. In these
1731 ;; cases, fast-read-* will read from the
1732 ;; ansi-stream-(c)in-buffer, saving function calls.
1733 ;; Otherwise, the various data-reading functions in the stream
1734 ;; structure will be called.
1736 (not bivalent-stream-p
)
1737 ;; temporary disable on :io streams
1739 (cond (character-stream-p
1740 (setf (ansi-stream-cin-buffer fd-stream
)
1741 (make-array +ansi-stream-in-buffer-length
+
1742 :element-type
'character
)))
1743 ((equal target-type
'(unsigned-byte 8))
1744 (setf (ansi-stream-in-buffer fd-stream
)
1745 (make-array +ansi-stream-in-buffer-length
+
1746 :element-type
'(unsigned-byte 8))))))))
1749 (when (or (not character-stream-p
) bivalent-stream-p
)
1750 (multiple-value-setq (bout-routine bout-type bout-size output-bytes
1751 normalized-external-format
)
1752 (pick-output-routine (if bivalent-stream-p
1755 (fd-stream-buffering fd-stream
)
1757 (unless bout-routine
1758 (error "could not find any output routine for ~S buffered ~S"
1759 (fd-stream-buffering fd-stream
)
1761 (when character-stream-p
1762 (multiple-value-setq (cout-routine cout-type cout-size output-bytes
1763 normalized-external-format
)
1764 (pick-output-routine target-type
1765 (fd-stream-buffering fd-stream
)
1767 (unless cout-routine
1768 (error "could not find any output routine for ~S buffered ~S"
1769 (fd-stream-buffering fd-stream
)
1771 (when normalized-external-format
1772 (setf (fd-stream-external-format fd-stream
)
1773 normalized-external-format
))
1774 (when character-stream-p
1775 (setf (fd-stream-output-bytes fd-stream
) output-bytes
))
1776 (setf (fd-stream-out fd-stream
) cout-routine
1777 (fd-stream-bout fd-stream
) bout-routine
1778 (fd-stream-sout fd-stream
) (if (eql cout-size
1)
1779 #'fd-sout
#'ill-out
))
1780 (setf output-size
(or cout-size bout-size
))
1781 (setf output-type
(or cout-type bout-type
)))
1783 (when (and input-size output-size
1784 (not (eq input-size output-size
)))
1785 (error "Element sizes for input (~S:~S) and output (~S:~S) differ?"
1786 input-type input-size
1787 output-type output-size
))
1788 (setf (fd-stream-element-size fd-stream
)
1789 (or input-size output-size
))
1791 (setf (fd-stream-element-type fd-stream
)
1792 (cond ((equal input-type output-type
)
1798 ((subtypep input-type output-type
)
1800 ((subtypep output-type input-type
)
1803 (error "Input type (~S) and output type (~S) are unrelated?"
1807 ;;; Handle miscellaneous operations on FD-STREAM.
1808 (defun fd-stream-misc-routine (fd-stream operation
&optional arg1 arg2
)
1809 (declare (ignore arg2
))
1812 (labels ((do-listen ()
1813 (or (not (eql (fd-stream-ibuf-head fd-stream
)
1814 (fd-stream-ibuf-tail fd-stream
)))
1815 (fd-stream-listen fd-stream
)
1817 (sb!win32
:fd-listen
(fd-stream-fd fd-stream
))
1819 ;; If the read can block, LISTEN will certainly return NIL.
1820 (if (sysread-may-block-p fd-stream
)
1822 ;; Otherwise select(2) and CL:LISTEN have slightly
1823 ;; different semantics. The former returns that an FD
1824 ;; is readable when a read operation wouldn't block.
1825 ;; That includes EOF. However, LISTEN must return NIL
1827 (progn (catch 'eof-input-catcher
1828 ;; r-b/f too calls select, but it shouldn't
1829 ;; block as long as read can return once w/o
1831 (refill-buffer/fd fd-stream
))
1832 ;; At this point either IBUF-HEAD != IBUF-TAIL
1833 ;; and FD-STREAM-LISTEN is NIL, in which case
1834 ;; we should return T, or IBUF-HEAD ==
1835 ;; IBUF-TAIL and FD-STREAM-LISTEN is :EOF, in
1836 ;; which case we should return :EOF for this
1837 ;; call and all future LISTEN call on this stream.
1838 ;; Call ourselves again to determine which case
1843 (setf (fd-stream-unread fd-stream
) arg1
)
1844 (setf (fd-stream-listen fd-stream
) t
))
1846 (cond (arg1 ; We got us an abort on our hands.
1847 (when (fd-stream-handler fd-stream
)
1848 (remove-fd-handler (fd-stream-handler fd-stream
))
1849 (setf (fd-stream-handler fd-stream
) nil
))
1850 ;; We can't do anything unless we know what file were
1851 ;; dealing with, and we don't want to do anything
1852 ;; strange unless we were writing to the file.
1853 (when (and (fd-stream-file fd-stream
)
1854 (fd-stream-obuf-sap fd-stream
))
1855 (if (fd-stream-original fd-stream
)
1856 ;; If the original is EQ to file we are appending
1857 ;; and can just close the file without renaming.
1858 (unless (eq (fd-stream-original fd-stream
)
1859 (fd-stream-file fd-stream
))
1860 ;; We have a handle on the original, just revert.
1861 (multiple-value-bind (okay err
)
1862 (sb!unix
:unix-rename
(fd-stream-original fd-stream
)
1863 (fd-stream-file fd-stream
))
1865 (simple-stream-perror
1866 "couldn't restore ~S to its original contents"
1869 ;; We can't restore the original, and aren't
1870 ;; appending, so nuke that puppy.
1872 ;; FIXME: This is currently the fate of superseded
1873 ;; files, and according to the CLOSE spec this is
1874 ;; wrong. However, there seems to be no clean way to
1875 ;; do that that doesn't involve either copying the
1876 ;; data (bad if the :abort resulted from a full
1877 ;; disk), or renaming the old file temporarily
1878 ;; (probably bad because stream opening becomes more
1880 (multiple-value-bind (okay err
)
1881 (sb!unix
:unix-unlink
(fd-stream-file fd-stream
))
1883 (error 'simple-file-error
1884 :pathname
(fd-stream-file fd-stream
)
1886 "~@<couldn't remove ~S: ~2I~_~A~:>"
1887 :format-arguments
(list (fd-stream-file fd-stream
)
1888 (strerror err
))))))))
1890 (fd-stream-misc-routine fd-stream
:finish-output
)
1891 (when (and (fd-stream-original fd-stream
)
1892 (fd-stream-delete-original fd-stream
))
1893 (multiple-value-bind (okay err
)
1894 (sb!unix
:unix-unlink
(fd-stream-original fd-stream
))
1896 (error 'simple-file-error
1897 :pathname
(fd-stream-original fd-stream
)
1899 "~@<couldn't delete ~S during close of ~S: ~
1902 (list (fd-stream-original fd-stream
)
1904 (strerror err
))))))))
1905 (when (fboundp 'cancel-finalization
)
1906 (cancel-finalization fd-stream
))
1907 (sb!unix
:unix-close
(fd-stream-fd fd-stream
))
1908 (when (fd-stream-obuf-sap fd-stream
)
1909 (with-available-buffers-lock ()
1910 (push (fd-stream-obuf-sap fd-stream
) *available-buffers
*)
1911 (setf (fd-stream-obuf-sap fd-stream
) nil
)))
1912 (when (fd-stream-ibuf-sap fd-stream
)
1913 (with-available-buffers-lock ()
1914 (push (fd-stream-ibuf-sap fd-stream
) *available-buffers
*)
1915 (setf (fd-stream-ibuf-sap fd-stream
) nil
)))
1916 (sb!impl
::set-closed-flame fd-stream
))
1918 (setf (fd-stream-unread fd-stream
) nil
)
1919 (setf (fd-stream-ibuf-head fd-stream
) 0)
1920 (setf (fd-stream-ibuf-tail fd-stream
) 0)
1923 (sb!win32
:fd-clear-input
(fd-stream-fd fd-stream
))
1924 (setf (fd-stream-listen fd-stream
) nil
))
1926 (catch 'eof-input-catcher
1927 (loop until
(sysread-may-block-p fd-stream
)
1929 (refill-buffer/fd fd-stream
)
1930 (setf (fd-stream-ibuf-head fd-stream
) 0)
1931 (setf (fd-stream-ibuf-tail fd-stream
) 0))
1934 (flush-output-buffer fd-stream
))
1936 (finish-fd-stream-output fd-stream
))
1938 (fd-stream-element-type fd-stream
))
1940 (fd-stream-external-format fd-stream
))
1942 (= 1 (the (member 0 1)
1943 (sb!unix
:unix-isatty
(fd-stream-fd fd-stream
)))))
1947 (fd-stream-char-pos fd-stream
))
1949 (unless (fd-stream-file fd-stream
)
1950 ;; This is a TYPE-ERROR because ANSI's species FILE-LENGTH
1951 ;; "should signal an error of type TYPE-ERROR if stream is not
1952 ;; a stream associated with a file". Too bad there's no very
1953 ;; appropriate value for the EXPECTED-TYPE slot..
1954 (error 'simple-type-error
1956 :expected-type
'fd-stream
1957 :format-control
"~S is not a stream associated with a file."
1958 :format-arguments
(list fd-stream
)))
1959 (multiple-value-bind (okay dev ino mode nlink uid gid rdev size
1960 atime mtime ctime blksize blocks
)
1961 (sb!unix
:unix-fstat
(fd-stream-fd fd-stream
))
1962 (declare (ignore ino nlink uid gid rdev
1963 atime mtime ctime blksize blocks
))
1965 (simple-stream-perror "failed Unix fstat(2) on ~S" fd-stream dev
))
1968 (truncate size
(fd-stream-element-size fd-stream
)))))
1969 (:file-string-length
1971 (character (fd-stream-character-size fd-stream arg1
))
1972 (string (fd-stream-string-size fd-stream arg1
))))
1975 (fd-stream-set-file-position fd-stream arg1
)
1976 (fd-stream-get-file-position fd-stream
)))))
1978 ;; FIXME: Think about this.
1980 ;; (defun finish-fd-stream-output (fd-stream)
1981 ;; (let ((timeout (fd-stream-timeout fd-stream)))
1982 ;; (loop while (fd-stream-output-later fd-stream)
1983 ;; ;; FIXME: SIGINT while waiting for a timeout will
1984 ;; ;; cause a timeout here.
1985 ;; do (when (and (not (serve-event timeout)) timeout)
1986 ;; (signal-timeout 'io-timeout
1987 ;; :stream fd-stream
1988 ;; :direction :write
1989 ;; :seconds timeout)))))
1991 (defun finish-fd-stream-output (stream)
1992 (flush-output-buffer stream
)
1994 ((null (fd-stream-output-later stream
)))
1995 (serve-all-events)))
1997 (defun fd-stream-get-file-position (stream)
1998 (declare (fd-stream stream
))
2000 (let ((posn (sb!unix
:unix-lseek
(fd-stream-fd stream
) 0 sb
!unix
:l_incr
)))
2001 (declare (type (or (alien sb
!unix
:off-t
) null
) posn
))
2002 ;; We used to return NIL for errno==ESPIPE, and signal an error
2003 ;; in other failure cases. However, CLHS says to return NIL if
2004 ;; the position cannot be determined -- so that's what we do.
2005 (when (integerp posn
)
2006 ;; Adjust for buffered output: If there is any output
2007 ;; buffered, the *real* file position will be larger
2008 ;; than reported by lseek() because lseek() obviously
2009 ;; cannot take into account output we have not sent
2011 (dolist (later (fd-stream-output-later stream
))
2012 (incf posn
(- (caddr later
) (cadr later
))))
2013 (incf posn
(fd-stream-obuf-tail stream
))
2014 ;; Adjust for unread input: If there is any input
2015 ;; read from UNIX but not supplied to the user of the
2016 ;; stream, the *real* file position will smaller than
2017 ;; reported, because we want to look like the unread
2018 ;; stuff is still available.
2019 (decf posn
(- (fd-stream-ibuf-tail stream
)
2020 (fd-stream-ibuf-head stream
)))
2021 (when (fd-stream-unread stream
)
2023 ;; Divide bytes by element size.
2024 (truncate posn
(fd-stream-element-size stream
))))))
2026 (defun fd-stream-set-file-position (stream position-spec
)
2027 (declare (fd-stream stream
))
2028 (check-type position-spec
2029 (or (alien sb
!unix
:off-t
) (member nil
:start
:end
))
2030 "valid file position designator")
2033 ;; Make sure we don't have any output pending, because if we
2034 ;; move the file pointer before writing this stuff, it will be
2035 ;; written in the wrong location.
2036 (finish-fd-stream-output stream
)
2037 ;; Disable interrupts so that interrupt handlers doing output
2040 (unless (fd-stream-output-finished-p stream
)
2041 ;; We got interrupted and more output came our way during
2042 ;; the interrupt. Wrapping the FINISH-FD-STREAM-OUTPUT in
2043 ;; WITHOUT-INTERRUPTS gets nasty as it can signal errors,
2044 ;; so we prefer to do things like this...
2046 ;; Clear out any pending input to force the next read to go to
2048 (setf (fd-stream-unread stream
) nil
2049 (fd-stream-ibuf-head stream
) 0
2050 (fd-stream-ibuf-tail stream
) 0)
2051 ;; Trash cached value for listen, so that we check next time.
2052 (setf (fd-stream-listen stream
) nil
)
2054 (multiple-value-bind (offset origin
)
2057 (values 0 sb
!unix
:l_set
))
2059 (values 0 sb
!unix
:l_xtnd
))
2061 (values (* position-spec
(fd-stream-element-size stream
))
2063 (declare (type (alien sb
!unix
:off-t
) offset
))
2064 (let ((posn (sb!unix
:unix-lseek
(fd-stream-fd stream
)
2066 ;; CLHS says to return true if the file-position was set
2067 ;; succesfully, and NIL otherwise. We are to signal an error
2068 ;; only if the given position was out of bounds, and that is
2069 ;; dealt with above. In times past we used to return NIL for
2070 ;; errno==ESPIPE, and signal an error in other cases.
2072 ;; FIXME: We are still liable to signal an error if flushing
2074 (return-from fd-stream-set-file-position
2075 (typep posn
'(alien sb
!unix
:off-t
))))))))
2078 ;;;; creation routines (MAKE-FD-STREAM and OPEN)
2080 ;;; Create a stream for the given Unix file descriptor.
2082 ;;; If INPUT is non-NIL, allow input operations. If OUTPUT is non-nil,
2083 ;;; allow output operations. If neither INPUT nor OUTPUT is specified,
2084 ;;; default to allowing input.
2086 ;;; ELEMENT-TYPE indicates the element type to use (as for OPEN).
2088 ;;; BUFFERING indicates the kind of buffering to use.
2090 ;;; TIMEOUT (if true) is the number of seconds to wait for input. If
2091 ;;; NIL (the default), then wait forever. When we time out, we signal
2094 ;;; FILE is the name of the file (will be returned by PATHNAME).
2096 ;;; NAME is used to identify the stream when printed.
2097 (defun make-fd-stream (fd
2100 (output nil output-p
)
2101 (element-type 'base-char
)
2103 (external-format :default
)
2112 (format nil
"file ~A" file
)
2113 (format nil
"descriptor ~W" fd
)))
2115 (declare (type index fd
) (type (or real null
) timeout
)
2116 (type (member :none
:line
:full
) buffering
))
2117 (cond ((not (or input-p output-p
))
2119 ((not (or input output
))
2120 (error "File descriptor must be opened either for input or output.")))
2121 (let ((stream (%make-fd-stream
:fd fd
2125 :delete-original delete-original
2127 :buffering buffering
2128 :dual-channel-p dual-channel-p
2129 :external-format external-format
2132 (coerce timeout
'single-float
)
2134 (set-fd-stream-routines stream element-type external-format
2135 input output input-buffer-p
)
2136 (when (and auto-close
(fboundp 'finalize
))
2139 (sb!unix
:unix-close fd
)
2141 (format *terminal-io
* "** closed file descriptor ~W **~%"
2145 ;;; Pick a name to use for the backup file for the :IF-EXISTS
2146 ;;; :RENAME-AND-DELETE and :RENAME options.
2147 (defun pick-backup-name (name)
2148 (declare (type simple-string name
))
2149 (concatenate 'simple-string name
".bak"))
2151 ;;; Ensure that the given arg is one of the given list of valid
2152 ;;; things. Allow the user to fix any problems.
2153 (defun ensure-one-of (item list what
)
2154 (unless (member item list
)
2155 (error 'simple-type-error
2157 :expected-type
`(member ,@list
)
2158 :format-control
"~@<~S is ~_invalid for ~S; ~_need one of~{ ~S~}~:>"
2159 :format-arguments
(list item what list
))))
2161 ;;; Rename NAMESTRING to ORIGINAL. First, check whether we have write
2162 ;;; access, since we don't want to trash unwritable files even if we
2163 ;;; technically can. We return true if we succeed in renaming.
2164 (defun rename-the-old-one (namestring original
)
2165 (unless (sb!unix
:unix-access namestring sb
!unix
:w_ok
)
2166 (error "~@<The file ~2I~_~S ~I~_is not writable.~:>" namestring
))
2167 (multiple-value-bind (okay err
) (sb!unix
:unix-rename namestring original
)
2170 (error 'simple-file-error
2171 :pathname namestring
2173 "~@<couldn't rename ~2I~_~S ~I~_to ~2I~_~S: ~4I~_~A~:>"
2174 :format-arguments
(list namestring original
(strerror err
))))))
2176 (defun open (filename
2179 (element-type 'base-char
)
2180 (if-exists nil if-exists-given
)
2181 (if-does-not-exist nil if-does-not-exist-given
)
2182 (external-format :default
)
2183 &aux
; Squelch assignment warning.
2184 (direction direction
)
2185 (if-does-not-exist if-does-not-exist
)
2186 (if-exists if-exists
))
2188 "Return a stream which reads from or writes to FILENAME.
2190 :DIRECTION - one of :INPUT, :OUTPUT, :IO, or :PROBE
2191 :ELEMENT-TYPE - the type of object to read or write, default BASE-CHAR
2192 :IF-EXISTS - one of :ERROR, :NEW-VERSION, :RENAME, :RENAME-AND-DELETE,
2193 :OVERWRITE, :APPEND, :SUPERSEDE or NIL
2194 :IF-DOES-NOT-EXIST - one of :ERROR, :CREATE or NIL
2195 See the manual for details."
2197 ;; Calculate useful stuff.
2198 (multiple-value-bind (input output mask
)
2200 (:input
(values t nil sb
!unix
:o_rdonly
))
2201 (:output
(values nil t sb
!unix
:o_wronly
))
2202 (:io
(values t t sb
!unix
:o_rdwr
))
2203 (:probe
(values t nil sb
!unix
:o_rdonly
)))
2204 (declare (type index mask
))
2205 (let* ((pathname (merge-pathnames filename
))
2207 (cond ((unix-namestring pathname input
))
2208 ((and input
(eq if-does-not-exist
:create
))
2209 (unix-namestring pathname nil
))
2210 ((and (eq direction
:io
) (not if-does-not-exist-given
))
2211 (unix-namestring pathname nil
)))))
2212 ;; Process if-exists argument if we are doing any output.
2214 (unless if-exists-given
2216 (if (eq (pathname-version pathname
) :newest
)
2219 (ensure-one-of if-exists
2220 '(:error
:new-version
:rename
2221 :rename-and-delete
:overwrite
2222 :append
:supersede nil
)
2225 ((:new-version
:error nil
)
2226 (setf mask
(logior mask sb
!unix
:o_excl
)))
2227 ((:rename
:rename-and-delete
)
2228 (setf mask
(logior mask sb
!unix
:o_creat
)))
2230 (setf mask
(logior mask sb
!unix
:o_trunc
)))
2232 (setf mask
(logior mask sb
!unix
:o_append
)))))
2234 (setf if-exists
:ignore-this-arg
)))
2236 (unless if-does-not-exist-given
2237 (setf if-does-not-exist
2238 (cond ((eq direction
:input
) :error
)
2240 (member if-exists
'(:overwrite
:append
)))
2242 ((eq direction
:probe
)
2246 (ensure-one-of if-does-not-exist
2247 '(:error
:create nil
)
2249 (if (eq if-does-not-exist
:create
)
2250 (setf mask
(logior mask sb
!unix
:o_creat
)))
2252 (let ((original (case if-exists
2253 ((:rename
:rename-and-delete
)
2254 (pick-backup-name namestring
))
2255 ((:append
:overwrite
)
2256 ;; KLUDGE: Provent CLOSE from deleting
2257 ;; appending streams when called with :ABORT T
2259 (delete-original (eq if-exists
:rename-and-delete
))
2261 (when (and original
(not (eq original namestring
)))
2262 ;; We are doing a :RENAME or :RENAME-AND-DELETE. Determine
2263 ;; whether the file already exists, make sure the original
2264 ;; file is not a directory, and keep the mode.
2267 (multiple-value-bind (okay err
/dev inode orig-mode
)
2268 (sb!unix
:unix-stat namestring
)
2269 (declare (ignore inode
)
2270 (type (or index null
) orig-mode
))
2273 (when (and output
(= (logand orig-mode
#o170000
)
2275 (error 'simple-file-error
2276 :pathname namestring
2278 "can't open ~S for output: is a directory"
2279 :format-arguments
(list namestring
)))
2280 (setf mode
(logand orig-mode
#o777
))
2282 ((eql err
/dev sb
!unix
:enoent
)
2285 (simple-file-perror "can't find ~S"
2289 (rename-the-old-one namestring original
))
2291 (setf delete-original nil
)
2292 ;; In order to use :SUPERSEDE instead, we have to make
2293 ;; sure SB!UNIX:O_CREAT corresponds to
2294 ;; IF-DOES-NOT-EXIST. SB!UNIX:O_CREAT was set before
2295 ;; because of IF-EXISTS being :RENAME.
2296 (unless (eq if-does-not-exist
:create
)
2298 (logior (logandc2 mask sb
!unix
:o_creat
)
2300 (setf if-exists
:supersede
))))
2302 ;; Now we can try the actual Unix open(2).
2303 (multiple-value-bind (fd errno
)
2305 (sb!unix
:unix-open namestring mask mode
)
2306 (values nil sb
!unix
:enoent
))
2307 (labels ((open-error (format-control &rest format-arguments
)
2308 (error 'simple-file-error
2310 :format-control format-control
2311 :format-arguments format-arguments
))
2312 (vanilla-open-error ()
2313 (simple-file-perror "error opening ~S" pathname errno
)))
2316 ((:input
:output
:io
)
2320 :element-type element-type
2321 :external-format external-format
2324 :delete-original delete-original
2331 (%make-fd-stream
:name namestring
2334 :element-type element-type
)))
2337 ((eql errno sb
!unix
:enoent
)
2338 (case if-does-not-exist
2339 (:error
(vanilla-open-error))
2341 (open-error "~@<The path ~2I~_~S ~I~_does not exist.~:>"
2344 ((and (eql errno sb
!unix
:eexist
) (null if-exists
))
2347 (vanilla-open-error)))))))))
2351 ;;; the stream connected to the controlling terminal, or NIL if there is none
2354 ;;; the stream connected to the standard input (file descriptor 0)
2357 ;;; the stream connected to the standard output (file descriptor 1)
2360 ;;; the stream connected to the standard error output (file descriptor 2)
2363 ;;; This is called when the cold load is first started up, and may also
2364 ;;; be called in an attempt to recover from nested errors.
2365 (defun stream-cold-init-or-reset ()
2367 (setf *terminal-io
* (make-synonym-stream '*tty
*))
2368 (setf *standard-output
* (make-synonym-stream '*stdout
*))
2369 (setf *standard-input
* (make-synonym-stream '*stdin
*))
2370 (setf *error-output
* (make-synonym-stream '*stderr
*))
2371 (setf *query-io
* (make-synonym-stream '*terminal-io
*))
2372 (setf *debug-io
* *query-io
*)
2373 (setf *trace-output
* *standard-output
*)
2376 ;;; This is called whenever a saved core is restarted.
2377 (defun stream-reinit ()
2378 (setf *available-buffers
* nil
)
2379 (with-output-to-string (*error-output
*)
2381 (make-fd-stream 0 :name
"standard input" :input t
:buffering
:line
2382 #!+win32
:external-format
#!+win32
(sb!win32
::console-input-codepage
)))
2384 (make-fd-stream 1 :name
"standard output" :output t
:buffering
:line
2385 #!+win32
:external-format
#!+win32
(sb!win32
::console-output-codepage
)))
2387 (make-fd-stream 2 :name
"standard error" :output t
:buffering
:line
2388 #!+win32
:external-format
#!+win32
(sb!win32
::console-output-codepage
)))
2389 (let* ((ttyname #.
(coerce "/dev/tty" 'simple-base-string
))
2390 (tty (sb!unix
:unix-open ttyname sb
!unix
:o_rdwr
#o666
)))
2394 :name
"the terminal"
2399 (setf *tty
* (make-two-way-stream *stdin
* *stdout
*))))
2400 (princ (get-output-stream-string *error-output
*) *stderr
*))
2405 ;;; the Unix way to beep
2406 (defun beep (stream)
2407 (write-char (code-char bell-char-code
) stream
)
2408 (finish-output stream
))
2410 ;;; This is kind of like FILE-POSITION, but is an internal hack used
2411 ;;; by the filesys stuff to get and set the file name.
2413 ;;; FIXME: misleading name, screwy interface
2414 (defun file-name (stream &optional new-name
)
2415 (when (typep stream
'fd-stream
)
2417 (setf (fd-stream-pathname stream
) new-name
)
2418 (setf (fd-stream-file stream
)
2419 (unix-namestring new-name nil
))
2422 (fd-stream-pathname stream
)))))