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.")
24 (defvar *available-buffers-mutex
* (sb!thread
:make-mutex
25 :name
"lock for *AVAILABLE-BUFFERS*")
27 "Mutex for access to *AVAILABLE-BUFFERS*.")
29 (defmacro with-available-buffers-lock
((&optional
) &body body
)
30 ;; CALL-WITH-SYSTEM-MUTEX 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 `(sb!thread
::call-with-system-mutex
(lambda () ,@body
)
34 *available-buffers-mutex
*))
36 (defconstant bytes-per-buffer
(* 4 1024)
38 "Number of bytes per buffer.")
40 ;;; Return the next available buffer, creating one if necessary.
41 #!-sb-fluid
(declaim (inline next-available-buffer
))
42 (defun next-available-buffer ()
43 (with-available-buffers-lock ()
44 (if *available-buffers
*
45 (pop *available-buffers
*)
46 (allocate-system-memory bytes-per-buffer
))))
48 ;;;; the FD-STREAM structure
51 (:constructor %make-fd-stream
)
52 (:conc-name fd-stream-
)
53 (:predicate fd-stream-p
)
55 (misc #'fd-stream-misc-routine
))
58 ;; the name of this stream
60 ;; the file this stream is for
62 ;; the backup file namestring for the old file, for :IF-EXISTS
63 ;; :RENAME or :RENAME-AND-DELETE.
64 (original nil
:type
(or simple-string null
))
65 (delete-original nil
) ; for :if-exists :rename-and-delete
66 ;;; the number of bytes per element
67 (element-size 1 :type index
)
68 ;; the type of element being transfered
69 (element-type 'base-char
)
70 ;; the Unix file descriptor
72 ;; controls when the output buffer is flushed
73 (buffering :full
:type
(member :full
:line
:none
))
74 ;; controls whether the input buffer must be cleared before output
75 ;; (must be done for files, not for sockets, pipes and other data
76 ;; sources where input and output aren't related). non-NIL means
77 ;; don't clear input buffer.
79 ;; character position if known -- this may run into bignums, but
80 ;; we probably should flip it into null then for efficiency's sake...
81 (char-pos nil
:type
(or unsigned-byte null
))
82 ;; T if input is waiting on FD. :EOF if we hit EOF.
83 (listen nil
:type
(member nil t
:eof
))
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
)
93 (obuf-sap nil
:type
(or system-area-pointer null
))
94 (obuf-length nil
:type
(or index null
))
95 (obuf-tail 0 :type index
)
97 ;; output flushed, but not written due to non-blocking io?
100 ;; timeout specified for this stream as seconds or NIL if none
101 (timeout nil
:type
(or single-float 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
))))
111 ;;;; output routines and related noise
113 (defvar *output-routines
* ()
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.")
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
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
128 :format-control
"~@<~?: ~2I~_~A~:>"
130 (list note-format
(list pathname
) (strerror errno
))))
132 (defun stream-decoding-error (stream octets
)
133 (error 'stream-decoding-error
135 ;; FIXME: dunno how to get at OCTETS currently, or even if
136 ;; that's the right thing to report.
138 (defun stream-encoding-error (stream code
)
139 (error 'stream-encoding-error
143 (defun c-string-encoding-error (external-format code
)
144 (error 'c-string-encoding-error
145 :external-format external-format
148 (defun c-string-decoding-error (external-format octets
)
149 (error 'c-string-decoding-error
150 :external-format external-format
153 ;;; Returning true goes into end of file handling, false will enter another
154 ;;; round of input buffer filling followed by re-entering character decode.
155 (defun stream-decoding-error-and-handle (stream octet-count
)
157 (stream-decoding-error stream
158 (let ((sap (fd-stream-ibuf-sap stream
))
159 (head (fd-stream-ibuf-head stream
)))
160 (loop for i from
0 below octet-count
161 collect
(sap-ref-8 sap
(+ head i
)))))
163 :report
(lambda (stream)
165 "~@<Attempt to resync the stream at a character ~
166 character boundary and continue.~@:>"))
167 (fd-stream-resync stream
)
169 (force-end-of-file ()
170 :report
(lambda (stream)
171 (format stream
"~@<Force an end of file.~@:>"))
174 (defun stream-encoding-error-and-handle (stream code
)
176 (stream-encoding-error stream code
)
178 :report
(lambda (stream)
179 (format stream
"~@<Skip output of this character.~@:>"))
180 (throw 'output-nothing nil
))))
182 (defun external-format-encoding-error (stream code
)
184 (stream-encoding-error-and-handle stream code
)
185 (c-string-encoding-error stream code
)))
187 (defun external-format-decoding-error (stream octet-count
)
189 (stream-decoding-error stream octet-count
)
190 (c-string-decoding-error stream octet-count
)))
192 ;;; This is called by the server when we can write to the given file
193 ;;; descriptor. Attempt to write the data again. If it worked, remove
194 ;;; the data from the OUTPUT-LATER list. If it didn't work, something
196 (defun frob-output-later (stream)
197 (let* ((stuff (pop (fd-stream-output-later stream
)))
201 (reuse-sap (cadddr stuff
))
202 (length (- end start
)))
203 (declare (type index start end length
))
204 (multiple-value-bind (count errno
)
205 (sb!unix
:unix-write
(fd-stream-fd stream
)
211 (simple-stream-perror "couldn't write to ~S" stream errno
)
213 (if (= errno sb
!unix
:ewouldblock
)
214 (error "Write would have blocked, but SERVER told us to go.")
215 (simple-stream-perror "couldn't write to ~S" stream errno
)))
216 ((eql count length
) ; Hot damn, it worked.
218 (with-available-buffers-lock ()
219 (push base
*available-buffers
*))))
220 ((not (null count
)) ; sorta worked..
222 (the index
(+ start count
))
224 (fd-stream-output-later stream
))))))
225 (unless (fd-stream-output-later stream
)
226 (remove-fd-handler (fd-stream-handler stream
))
227 (setf (fd-stream-handler stream
) nil
)))
229 ;;; Arange to output the string when we can write on the file descriptor.
230 (defun output-later (stream base start end reuse-sap
)
231 (cond ((null (fd-stream-output-later stream
))
232 (setf (fd-stream-output-later stream
)
233 (list (list base start end reuse-sap
)))
234 (setf (fd-stream-handler stream
)
235 (add-fd-handler (fd-stream-fd stream
)
238 (declare (ignore fd
))
239 (frob-output-later stream
)))))
241 (nconc (fd-stream-output-later stream
)
242 (list (list base start end reuse-sap
)))))
244 (let ((new-buffer (next-available-buffer)))
245 (setf (fd-stream-obuf-sap stream
) new-buffer
)
246 (setf (fd-stream-obuf-length stream
) bytes-per-buffer
))))
248 ;;; Output the given noise. Check to see whether there are any pending
249 ;;; writes. If so, just queue this one. Otherwise, try to write it. If
250 ;;; this would block, queue it.
251 (defun frob-output (stream base start end reuse-sap
)
252 (declare (type fd-stream stream
)
253 (type (or system-area-pointer
(simple-array * (*))) base
)
254 (type index start end
))
255 (if (not (null (fd-stream-output-later stream
))) ; something buffered.
256 (output-later stream base start end reuse-sap
)
257 ;; ### check to see whether any of this noise can be output
258 (let ((length (- end start
)))
259 (multiple-value-bind (count errno
)
260 (sb!unix
:unix-write
(fd-stream-fd stream
) base start length
)
263 (simple-stream-perror "Couldn't write to ~S" stream errno
)
265 (if (= errno sb
!unix
:ewouldblock
)
266 (output-later stream base start end reuse-sap
)
267 (simple-stream-perror "Couldn't write to ~S"
269 ((not (eql count length
))
270 (output-later stream base
(the index
(+ start count
))
273 ;;; Flush any data in the output buffer.
274 (defun flush-output-buffer (stream)
275 (let ((length (fd-stream-obuf-tail stream
)))
277 (frob-output stream
(fd-stream-obuf-sap stream
) 0 length t
)
278 (setf (fd-stream-obuf-tail stream
) 0))))
280 (defun fd-stream-output-finished-p (stream)
281 (and (zerop (fd-stream-obuf-tail stream
))
282 (not (fd-stream-output-later stream
))))
284 (defmacro output-wrapper
/variable-width
((stream size buffering restart
)
286 (let ((stream-var (gensym)))
287 `(let ((,stream-var
,stream
)
289 ,(unless (eq (car buffering
) :none
)
290 `(when (< (fd-stream-obuf-length ,stream-var
)
291 (+ (fd-stream-obuf-tail ,stream-var
)
293 (flush-output-buffer ,stream-var
)))
294 ,(unless (eq (car buffering
) :none
)
295 `(when (and (not (fd-stream-dual-channel-p ,stream-var
))
296 (> (fd-stream-ibuf-tail ,stream-var
)
297 (fd-stream-ibuf-head ,stream-var
)))
298 (file-position ,stream-var
(file-position ,stream-var
))))
300 `(catch 'output-nothing
302 (incf (fd-stream-obuf-tail ,stream-var
) size
))
305 (incf (fd-stream-obuf-tail ,stream-var
) size
)))
306 ,(ecase (car buffering
)
308 `(flush-output-buffer ,stream-var
))
310 `(when (eq (char-code byte
) (char-code #\Newline
))
311 (flush-output-buffer ,stream-var
)))
315 (defmacro output-wrapper
((stream size buffering restart
) &body body
)
316 (let ((stream-var (gensym)))
317 `(let ((,stream-var
,stream
))
318 ,(unless (eq (car buffering
) :none
)
319 `(when (< (fd-stream-obuf-length ,stream-var
)
320 (+ (fd-stream-obuf-tail ,stream-var
)
322 (flush-output-buffer ,stream-var
)))
323 ,(unless (eq (car buffering
) :none
)
324 `(when (and (not (fd-stream-dual-channel-p ,stream-var
))
325 (> (fd-stream-ibuf-tail ,stream-var
)
326 (fd-stream-ibuf-head ,stream-var
)))
327 (file-position ,stream-var
(file-position ,stream-var
))))
329 `(catch 'output-nothing
331 (incf (fd-stream-obuf-tail ,stream-var
) ,size
))
334 (incf (fd-stream-obuf-tail ,stream-var
) ,size
)))
335 ,(ecase (car buffering
)
337 `(flush-output-buffer ,stream-var
))
339 `(when (eq (char-code byte
) (char-code #\Newline
))
340 (flush-output-buffer ,stream-var
)))
344 (defmacro def-output-routines
/variable-width
345 ((name-fmt size restart external-format
&rest bufferings
)
347 (declare (optimize (speed 1)))
352 (intern (format nil name-fmt
(string (car buffering
))))))
354 (defun ,function
(stream byte
)
355 (declare (ignorable byte
))
356 (output-wrapper/variable-width
(stream ,size
,buffering
,restart
)
358 (setf *output-routines
*
359 (nconc *output-routines
*
367 (cdr buffering
)))))))
370 ;;; Define output routines that output numbers SIZE bytes long for the
371 ;;; given bufferings. Use BODY to do the actual output.
372 (defmacro def-output-routines
((name-fmt size restart
&rest bufferings
)
374 (declare (optimize (speed 1)))
379 (intern (format nil name-fmt
(string (car buffering
))))))
381 (defun ,function
(stream byte
)
382 (output-wrapper (stream ,size
,buffering
,restart
)
384 (setf *output-routines
*
385 (nconc *output-routines
*
393 (cdr buffering
)))))))
396 ;;; FIXME: is this used anywhere any more?
397 (def-output-routines ("OUTPUT-CHAR-~A-BUFFERED"
403 (if (char= byte
#\Newline
)
404 (setf (fd-stream-char-pos stream
) 0)
405 (incf (fd-stream-char-pos stream
)))
406 (setf (sap-ref-8 (fd-stream-obuf-sap stream
) (fd-stream-obuf-tail stream
))
409 (def-output-routines ("OUTPUT-UNSIGNED-BYTE-~A-BUFFERED"
412 (:none
(unsigned-byte 8))
413 (:full
(unsigned-byte 8)))
414 (setf (sap-ref-8 (fd-stream-obuf-sap stream
) (fd-stream-obuf-tail stream
))
417 (def-output-routines ("OUTPUT-SIGNED-BYTE-~A-BUFFERED"
420 (:none
(signed-byte 8))
421 (:full
(signed-byte 8)))
422 (setf (signed-sap-ref-8 (fd-stream-obuf-sap stream
)
423 (fd-stream-obuf-tail stream
))
426 (def-output-routines ("OUTPUT-UNSIGNED-SHORT-~A-BUFFERED"
429 (:none
(unsigned-byte 16))
430 (:full
(unsigned-byte 16)))
431 (setf (sap-ref-16 (fd-stream-obuf-sap stream
) (fd-stream-obuf-tail stream
))
434 (def-output-routines ("OUTPUT-SIGNED-SHORT-~A-BUFFERED"
437 (:none
(signed-byte 16))
438 (:full
(signed-byte 16)))
439 (setf (signed-sap-ref-16 (fd-stream-obuf-sap stream
)
440 (fd-stream-obuf-tail stream
))
443 (def-output-routines ("OUTPUT-UNSIGNED-LONG-~A-BUFFERED"
446 (:none
(unsigned-byte 32))
447 (:full
(unsigned-byte 32)))
448 (setf (sap-ref-32 (fd-stream-obuf-sap stream
) (fd-stream-obuf-tail stream
))
451 (def-output-routines ("OUTPUT-SIGNED-LONG-~A-BUFFERED"
454 (:none
(signed-byte 32))
455 (:full
(signed-byte 32)))
456 (setf (signed-sap-ref-32 (fd-stream-obuf-sap stream
)
457 (fd-stream-obuf-tail stream
))
460 #+#.
(cl:if
(cl:= sb
!vm
:n-word-bits
64) '(and) '(or))
462 (def-output-routines ("OUTPUT-UNSIGNED-LONG-LONG-~A-BUFFERED"
465 (:none
(unsigned-byte 64))
466 (:full
(unsigned-byte 64)))
467 (setf (sap-ref-64 (fd-stream-obuf-sap stream
) (fd-stream-obuf-tail stream
))
469 (def-output-routines ("OUTPUT-SIGNED-LONG-LONG-~A-BUFFERED"
472 (:none
(signed-byte 64))
473 (:full
(signed-byte 64)))
474 (setf (signed-sap-ref-64 (fd-stream-obuf-sap stream
)
475 (fd-stream-obuf-tail stream
))
478 ;;; Do the actual output. If there is space to buffer the string,
479 ;;; buffer it. If the string would normally fit in the buffer, but
480 ;;; doesn't because of other stuff in the buffer, flush the old noise
481 ;;; out of the buffer and put the string in it. Otherwise we have a
482 ;;; very long string, so just send it directly (after flushing the
483 ;;; buffer, of course).
484 (defun output-raw-bytes (fd-stream thing
&optional start end
)
486 "Output THING to FD-STREAM. THING can be any kind of vector or a SAP. If
487 THING is a SAP, END must be supplied (as length won't work)."
488 (let ((start (or start
0))
489 (end (or end
(length (the (simple-array * (*)) thing
)))))
490 (declare (type index start end
))
491 (when (and (not (fd-stream-dual-channel-p fd-stream
))
492 (> (fd-stream-ibuf-tail fd-stream
)
493 (fd-stream-ibuf-head fd-stream
)))
494 (file-position fd-stream
(file-position fd-stream
)))
495 (let* ((len (fd-stream-obuf-length fd-stream
))
496 (tail (fd-stream-obuf-tail fd-stream
))
498 (bytes (- end start
))
499 (newtail (+ tail bytes
)))
500 (cond ((minusp bytes
) ; error case
501 (error ":END before :START!"))
502 ((zerop bytes
)) ; easy case
504 (if (system-area-pointer-p thing
)
505 (system-area-ub8-copy thing start
506 (fd-stream-obuf-sap fd-stream
)
509 ;; FIXME: There should be some type checking somewhere to
510 ;; verify that THING here is a vector, not just <not a SAP>.
511 (copy-ub8-to-system-area thing start
512 (fd-stream-obuf-sap fd-stream
)
515 (setf (fd-stream-obuf-tail fd-stream
) newtail
))
517 (flush-output-buffer fd-stream
)
518 (if (system-area-pointer-p thing
)
519 (system-area-ub8-copy thing
521 (fd-stream-obuf-sap fd-stream
)
524 ;; FIXME: There should be some type checking somewhere to
525 ;; verify that THING here is a vector, not just <not a SAP>.
526 (copy-ub8-to-system-area thing
528 (fd-stream-obuf-sap fd-stream
)
531 (setf (fd-stream-obuf-tail fd-stream
) bytes
))
533 (flush-output-buffer fd-stream
)
534 (frob-output fd-stream thing start end nil
))))))
536 ;;; the routine to use to output a string. If the stream is
537 ;;; unbuffered, slam the string down the file descriptor, otherwise
538 ;;; use OUTPUT-RAW-BYTES to buffer the string. Update charpos by
539 ;;; checking to see where the last newline was.
540 (defun fd-sout (stream thing start end
)
541 (declare (type fd-stream stream
) (type string thing
))
542 (let ((start (or start
0))
543 (end (or end
(length (the vector thing
)))))
544 (declare (fixnum start end
))
546 (string-dispatch (simple-base-string
548 (simple-array character
(*))
551 (position #\newline thing
:from-end t
552 :start start
:end end
))))
553 (if (and (typep thing
'base-string
)
554 (eq (fd-stream-external-format stream
) :latin-1
))
555 (ecase (fd-stream-buffering stream
)
557 (output-raw-bytes stream thing start end
))
559 (output-raw-bytes stream thing start end
)
561 (flush-output-buffer stream
)))
563 (frob-output stream thing start end nil
)))
564 (ecase (fd-stream-buffering stream
)
565 (:full
(funcall (fd-stream-output-bytes stream
)
566 stream thing nil start end
))
567 (:line
(funcall (fd-stream-output-bytes stream
)
568 stream thing last-newline start end
))
569 (:none
(funcall (fd-stream-output-bytes stream
)
570 stream thing t start end
))))
572 (setf (fd-stream-char-pos stream
) (- end last-newline
1))
573 (incf (fd-stream-char-pos stream
) (- end start
))))))
575 (defvar *external-formats
* ()
577 "List of all available external formats. Each element is a list of the
578 element-type, string input function name, character input function name,
579 and string output function name.")
581 (defun get-external-format (external-format)
582 (dolist (entry *external-formats
*)
583 (when (member external-format
(first entry
))
586 (defun get-external-format-function (external-format index
)
587 (let ((entry (get-external-format external-format
)))
588 (when entry
(nth index entry
))))
590 ;;; Find an output routine to use given the type and buffering. Return
591 ;;; as multiple values the routine, the real type transfered, and the
592 ;;; number of bytes per element.
593 (defun pick-output-routine (type buffering
&optional external-format
)
594 (when (subtypep type
'character
)
595 (let ((entry (get-external-format external-format
)))
597 (return-from pick-output-routine
598 (values (symbol-function (nth (ecase buffering
605 (symbol-function (fourth entry
))
606 (first (first entry
)))))))
607 (dolist (entry *output-routines
*)
608 (when (and (subtypep type
(first entry
))
609 (eq buffering
(second entry
))
610 (or (not (fifth entry
))
611 (eq external-format
(fifth entry
))))
612 (return-from pick-output-routine
613 (values (symbol-function (third entry
))
616 ;; KLUDGE: dealing with the buffering here leads to excessive code
619 ;; KLUDGE: also see comments in PICK-INPUT-ROUTINE
620 (loop for i from
40 by
8 to
1024 ; ARB (KLUDGE)
621 if
(subtypep type
`(unsigned-byte ,i
))
622 do
(return-from pick-output-routine
626 (lambda (stream byte
)
627 (output-wrapper (stream (/ i
8) (:none
) nil
)
628 (loop for j from
0 below
(/ i
8)
630 (fd-stream-obuf-sap stream
)
631 (+ j
(fd-stream-obuf-tail stream
)))
632 (ldb (byte 8 (- i
8 (* j
8))) byte
))))))
634 (lambda (stream byte
)
635 (output-wrapper (stream (/ i
8) (:full
) nil
)
636 (loop for j from
0 below
(/ i
8)
638 (fd-stream-obuf-sap stream
)
639 (+ j
(fd-stream-obuf-tail stream
)))
640 (ldb (byte 8 (- i
8 (* j
8))) byte
)))))))
643 (loop for i from
40 by
8 to
1024 ; ARB (KLUDGE)
644 if
(subtypep type
`(signed-byte ,i
))
645 do
(return-from pick-output-routine
649 (lambda (stream byte
)
650 (output-wrapper (stream (/ i
8) (:none
) nil
)
651 (loop for j from
0 below
(/ i
8)
653 (fd-stream-obuf-sap stream
)
654 (+ j
(fd-stream-obuf-tail stream
)))
655 (ldb (byte 8 (- i
8 (* j
8))) byte
))))))
657 (lambda (stream byte
)
658 (output-wrapper (stream (/ i
8) (:full
) nil
)
659 (loop for j from
0 below
(/ i
8)
661 (fd-stream-obuf-sap stream
)
662 (+ j
(fd-stream-obuf-tail stream
)))
663 (ldb (byte 8 (- i
8 (* j
8))) byte
)))))))
667 ;;;; input routines and related noise
669 ;;; a list of all available input routines. Each element is a list of
670 ;;; the element-type input, the function name, and the number of bytes
672 (defvar *input-routines
* ())
674 ;;; Return whether a primitive partial read operation on STREAM's FD
675 ;;; would (probably) block. Signal a `simple-stream-error' if the
676 ;;; system call implementing this operation fails.
678 ;;; It is "may" instead of "would" because "would" is not quite
679 ;;; correct on win32. However, none of the places that use it require
680 ;;; further assurance than "may" versus "will definitely not".
681 (defun sysread-may-block-p (stream)
683 ;; This answers T at EOF on win32, I think.
684 (not (sb!win32
:fd-listen
(fd-stream-fd stream
)))
686 (sb!unix
:with-restarted-syscall
(count errno
)
687 (sb!alien
:with-alien
((read-fds (sb!alien
:struct sb
!unix
:fd-set
)))
688 (sb!unix
:fd-zero read-fds
)
689 (sb!unix
:fd-set
(fd-stream-fd stream
) read-fds
)
690 (sb!unix
:unix-fast-select
(1+ (fd-stream-fd stream
))
691 (sb!alien
:addr read-fds
)
697 (simple-stream-perror "couldn't check whether ~S is readable"
701 ;;; If the read would block wait (using SERVE-EVENT) till input is available,
702 ;;; then fill the input buffer, and return the number of bytes read. Throws
703 ;;; to EOF-INPUT-CATCHER if the eof was reached.
704 (defun refill-buffer/fd
(stream)
705 (let ((fd (fd-stream-fd stream
))
709 ;; Check for blocking input before touching the stream, as if
710 ;; we happen to wait we are liable to be interrupted, and the
711 ;; interrupt handler may use the same stream.
712 (if (sysread-may-block-p stream
)
715 ;; These (:CLOSED-FLAME and :READ-ERROR) tags are here so what
716 ;; we can signal errors outside the WITHOUT-INTERRUPTS.
718 (closed-flame stream
)
720 (simple-stream-perror "couldn't read from ~S" stream errno
)
722 ;; This tag is here so we can unwind outside the WITHOUT-INTERRUPTS
723 ;; to wait for input if read tells us EWOULDBLOCK.
724 (unless (wait-until-fd-usable fd
:input
(fd-stream-timeout stream
))
725 (signal-timeout 'io-timeout
:stream stream
:direction
:read
726 :seconds
(fd-stream-timeout stream
)))
728 ;; Since the read should not block, we'll disable the
729 ;; interrupts here, so that we don't accidentally unwind and
730 ;; leave the stream in an inconsistent state.
732 (let ((ibuf-sap (fd-stream-ibuf-sap stream
))
733 (buflen (fd-stream-ibuf-length stream
))
734 (head (fd-stream-ibuf-head stream
))
735 (tail (fd-stream-ibuf-tail stream
)))
736 (declare (type index head tail
))
737 ;; Check the SAP: if it is null, then someone has closed
738 ;; the stream from underneath us. This is not ment to fix
739 ;; multithreaded races, but to deal with interrupt handlers
740 ;; closing the stream.
744 (cond ((eql head tail
)
747 (fd-stream-ibuf-head stream
) 0
748 (fd-stream-ibuf-tail stream
) 0))
751 (system-area-ub8-copy ibuf-sap head
754 (fd-stream-ibuf-head stream
) 0
755 (fd-stream-ibuf-tail stream
) tail
))))
756 (setf (fd-stream-listen stream
) nil
)
757 (setf (values count errno
)
758 (sb!unix
:unix-read fd
(int-sap (+ (sap-int ibuf-sap
) tail
))
764 (if (eql errno sb
!unix
:ewouldblock
)
768 (setf (fd-stream-listen stream
) :eof
)
769 (/show0
"THROWing EOF-INPUT-CATCHER")
770 (throw 'eof-input-catcher nil
))
773 (incf (fd-stream-ibuf-tail stream
) count
))))))
776 ;;; Make sure there are at least BYTES number of bytes in the input
777 ;;; buffer. Keep calling REFILL-BUFFER/FD until that condition is met.
778 (defmacro input-at-least
(stream bytes
)
779 (let ((stream-var (gensym))
780 (bytes-var (gensym)))
781 `(let ((,stream-var
,stream
)
784 (when (>= (- (fd-stream-ibuf-tail ,stream-var
)
785 (fd-stream-ibuf-head ,stream-var
))
788 (refill-buffer/fd
,stream-var
)))))
790 (defmacro input-wrapper
/variable-width
((stream bytes eof-error eof-value
)
792 (let ((stream-var (gensym))
794 (element-var (gensym)))
795 `(let ((,stream-var
,stream
)
797 (if (fd-stream-unread ,stream-var
)
799 (fd-stream-unread ,stream-var
)
800 (setf (fd-stream-unread ,stream-var
) nil
)
801 (setf (fd-stream-listen ,stream-var
) nil
))
802 (let ((,element-var nil
)
803 (decode-break-reason nil
))
807 (catch 'eof-input-catcher
808 (setf decode-break-reason
809 (block decode-break-reason
810 (input-at-least ,stream-var
1)
811 (let* ((byte (sap-ref-8 (fd-stream-ibuf-sap
815 (declare (ignorable byte
))
817 (input-at-least ,stream-var size
)
818 (setq ,element-var
(locally ,@read-forms
))
819 (setq ,retry-var nil
))
821 (when decode-break-reason
822 (stream-decoding-error-and-handle stream
823 decode-break-reason
))
825 (let ((octet-count (- (fd-stream-ibuf-tail ,stream-var
)
826 (fd-stream-ibuf-head ,stream-var
))))
827 (when (or (zerop octet-count
)
828 (and (not ,element-var
)
829 (not decode-break-reason
)
830 (stream-decoding-error-and-handle
831 stream octet-count
)))
832 (setq ,retry-var nil
)))))
834 (incf (fd-stream-ibuf-head ,stream-var
) size
)
837 (eof-or-lose ,stream-var
,eof-error
,eof-value
))))))))
839 ;;; a macro to wrap around all input routines to handle EOF-ERROR noise
840 (defmacro input-wrapper
((stream bytes eof-error eof-value
) &body read-forms
)
841 (let ((stream-var (gensym))
842 (element-var (gensym)))
843 `(let ((,stream-var
,stream
))
844 (if (fd-stream-unread ,stream-var
)
846 (fd-stream-unread ,stream-var
)
847 (setf (fd-stream-unread ,stream-var
) nil
)
848 (setf (fd-stream-listen ,stream-var
) nil
))
850 (catch 'eof-input-catcher
851 (input-at-least ,stream-var
,bytes
)
852 (locally ,@read-forms
))))
854 (incf (fd-stream-ibuf-head ,stream-var
) ,bytes
)
857 (eof-or-lose ,stream-var
,eof-error
,eof-value
))))))))
859 (defmacro def-input-routine
/variable-width
(name
860 (type external-format size sap head
)
863 (defun ,name
(stream eof-error eof-value
)
864 (input-wrapper/variable-width
(stream ,size eof-error eof-value
)
865 (let ((,sap
(fd-stream-ibuf-sap stream
))
866 (,head
(fd-stream-ibuf-head stream
)))
868 (setf *input-routines
*
869 (nconc *input-routines
*
870 (list (list ',type
',name
1 ',external-format
))))))
872 (defmacro def-input-routine
(name
876 (defun ,name
(stream eof-error eof-value
)
877 (input-wrapper (stream ,size eof-error eof-value
)
878 (let ((,sap
(fd-stream-ibuf-sap stream
))
879 (,head
(fd-stream-ibuf-head stream
)))
881 (setf *input-routines
*
882 (nconc *input-routines
*
883 (list (list ',type
',name
',size nil
))))))
885 ;;; STREAM-IN routine for reading a string char
886 (def-input-routine input-character
887 (character 1 sap head
)
888 (code-char (sap-ref-8 sap head
)))
890 ;;; STREAM-IN routine for reading an unsigned 8 bit number
891 (def-input-routine input-unsigned-8bit-byte
892 ((unsigned-byte 8) 1 sap head
)
893 (sap-ref-8 sap head
))
895 ;;; STREAM-IN routine for reading a signed 8 bit number
896 (def-input-routine input-signed-8bit-number
897 ((signed-byte 8) 1 sap head
)
898 (signed-sap-ref-8 sap head
))
900 ;;; STREAM-IN routine for reading an unsigned 16 bit number
901 (def-input-routine input-unsigned-16bit-byte
902 ((unsigned-byte 16) 2 sap head
)
903 (sap-ref-16 sap head
))
905 ;;; STREAM-IN routine for reading a signed 16 bit number
906 (def-input-routine input-signed-16bit-byte
907 ((signed-byte 16) 2 sap head
)
908 (signed-sap-ref-16 sap head
))
910 ;;; STREAM-IN routine for reading a unsigned 32 bit number
911 (def-input-routine input-unsigned-32bit-byte
912 ((unsigned-byte 32) 4 sap head
)
913 (sap-ref-32 sap head
))
915 ;;; STREAM-IN routine for reading a signed 32 bit number
916 (def-input-routine input-signed-32bit-byte
917 ((signed-byte 32) 4 sap head
)
918 (signed-sap-ref-32 sap head
))
920 #+#.
(cl:if
(cl:= sb
!vm
:n-word-bits
64) '(and) '(or))
922 (def-input-routine input-unsigned-64bit-byte
923 ((unsigned-byte 64) 8 sap head
)
924 (sap-ref-64 sap head
))
925 (def-input-routine input-signed-64bit-byte
926 ((signed-byte 64) 8 sap head
)
927 (signed-sap-ref-64 sap head
)))
929 ;;; Find an input routine to use given the type. Return as multiple
930 ;;; values the routine, the real type transfered, and the number of
931 ;;; bytes per element (and for character types string input routine).
932 (defun pick-input-routine (type &optional external-format
)
933 (when (subtypep type
'character
)
934 (dolist (entry *external-formats
*)
935 (when (member external-format
(first entry
))
936 (return-from pick-input-routine
937 (values (symbol-function (third entry
))
940 (symbol-function (second entry
))
941 (first (first entry
)))))))
942 (dolist (entry *input-routines
*)
943 (when (and (subtypep type
(first entry
))
944 (or (not (fourth entry
))
945 (eq external-format
(fourth entry
))))
946 (return-from pick-input-routine
947 (values (symbol-function (second entry
))
950 ;; FIXME: let's do it the hard way, then (but ignore things like
951 ;; endianness, efficiency, and the necessary coupling between these
952 ;; and the output routines). -- CSR, 2004-02-09
953 (loop for i from
40 by
8 to
1024 ; ARB (well, KLUDGE really)
954 if
(subtypep type
`(unsigned-byte ,i
))
955 do
(return-from pick-input-routine
957 (lambda (stream eof-error eof-value
)
958 (input-wrapper (stream (/ i
8) eof-error eof-value
)
959 (let ((sap (fd-stream-ibuf-sap stream
))
960 (head (fd-stream-ibuf-head stream
)))
961 (loop for j from
0 below
(/ i
8)
965 (sap-ref-8 sap
(+ head j
))))
966 finally
(return result
)))))
969 (loop for i from
40 by
8 to
1024 ; ARB (well, KLUDGE really)
970 if
(subtypep type
`(signed-byte ,i
))
971 do
(return-from pick-input-routine
973 (lambda (stream eof-error eof-value
)
974 (input-wrapper (stream (/ i
8) eof-error eof-value
)
975 (let ((sap (fd-stream-ibuf-sap stream
))
976 (head (fd-stream-ibuf-head stream
)))
977 (loop for j from
0 below
(/ i
8)
981 (sap-ref-8 sap
(+ head j
))))
982 finally
(return (if (logbitp (1- i
) result
)
983 (dpb result
(byte i
0) -
1)
988 ;;; Return a string constructed from SAP, START, and END.
989 (defun string-from-sap (sap start end
)
990 (declare (type index start end
))
991 (let* ((length (- end start
))
992 (string (make-string length
)))
993 (copy-ub8-from-system-area sap start
998 ;;; the N-BIN method for FD-STREAMs
1000 ;;; Note that this blocks in UNIX-READ. It is generally used where
1001 ;;; there is a definite amount of reading to be done, so blocking
1002 ;;; isn't too problematical.
1003 (defun fd-stream-read-n-bytes (stream buffer start requested eof-error-p
1004 &aux
(total-copied 0))
1005 (declare (type fd-stream stream
))
1006 (declare (type index start requested total-copied
))
1007 (let ((unread (fd-stream-unread stream
)))
1009 ;; AVERs designed to fail when we have more complicated
1010 ;; character representations.
1011 (aver (typep unread
'base-char
))
1012 (aver (= (fd-stream-element-size stream
) 1))
1013 ;; KLUDGE: this is a slightly-unrolled-and-inlined version of
1016 (system-area-pointer
1017 (setf (sap-ref-8 buffer start
) (char-code unread
)))
1018 ((simple-unboxed-array (*))
1019 (setf (aref buffer start
) unread
)))
1020 (setf (fd-stream-unread stream
) nil
)
1021 (setf (fd-stream-listen stream
) nil
)
1022 (incf total-copied
)))
1025 (let* ((remaining-request (- requested total-copied
))
1026 (head (fd-stream-ibuf-head stream
))
1027 (tail (fd-stream-ibuf-tail stream
))
1028 (available (- tail head
))
1029 (n-this-copy (min remaining-request available
))
1030 (this-start (+ start total-copied
))
1031 (this-end (+ this-start n-this-copy
))
1032 (sap (fd-stream-ibuf-sap stream
)))
1033 (declare (type index remaining-request head tail available
))
1034 (declare (type index n-this-copy
))
1035 ;; Copy data from stream buffer into user's buffer.
1036 (%byte-blt sap head buffer this-start this-end
)
1037 (incf (fd-stream-ibuf-head stream
) n-this-copy
)
1038 (incf total-copied n-this-copy
)
1039 ;; Maybe we need to refill the stream buffer.
1040 (cond (;; If there were enough data in the stream buffer, we're done.
1041 (= total-copied requested
)
1042 (return total-copied
))
1043 (;; If EOF, we're done in another way.
1044 (null (catch 'eof-input-catcher
(refill-buffer/fd stream
)))
1046 (error 'end-of-file
:stream stream
)
1047 (return total-copied
)))
1048 ;; Otherwise we refilled the stream buffer, so fall
1049 ;; through into another pass of the loop.
1052 (defun fd-stream-resync (stream)
1053 (dolist (entry *external-formats
*)
1054 (when (member (fd-stream-external-format stream
) (first entry
))
1055 (return-from fd-stream-resync
1056 (funcall (symbol-function (eighth entry
)) stream
)))))
1058 (defun get-fd-stream-character-sizer (stream)
1059 (dolist (entry *external-formats
*)
1060 (when (member (fd-stream-external-format stream
) (first entry
))
1061 (return-from get-fd-stream-character-sizer
(ninth entry
)))))
1063 (defun fd-stream-character-size (stream char
)
1064 (let ((sizer (get-fd-stream-character-sizer stream
)))
1065 (when sizer
(funcall sizer char
))))
1067 (defun fd-stream-string-size (stream string
)
1068 (let ((sizer (get-fd-stream-character-sizer stream
)))
1070 (loop for char across string summing
(funcall sizer char
)))))
1072 (defun find-external-format (external-format)
1073 (when external-format
1074 (find external-format
*external-formats
* :test
#'member
:key
#'car
)))
1076 (defun variable-width-external-format-p (ef-entry)
1077 (when (eighth ef-entry
) t
))
1079 (defun bytes-for-char-fun (ef-entry)
1080 (if ef-entry
(symbol-function (ninth ef-entry
)) (constantly 1)))
1082 ;;; FIXME: OAOOM here vrt. *EXTERNAL-FORMAT-FUNCTIONS* in fd-stream.lisp
1083 (defmacro define-external-format
(external-format size output-restart
1085 (let* ((name (first external-format
))
1086 (out-function (symbolicate "OUTPUT-BYTES/" name
))
1087 (format (format nil
"OUTPUT-CHAR-~A-~~A-BUFFERED" (string name
)))
1088 (in-function (symbolicate "FD-STREAM-READ-N-CHARACTERS/" name
))
1089 (in-char-function (symbolicate "INPUT-CHAR/" name
))
1090 (size-function (symbolicate "BYTES-FOR-CHAR/" name
))
1091 (read-c-string-function (symbolicate "READ-FROM-C-STRING/" name
))
1092 (output-c-string-function (symbolicate "OUTPUT-TO-C-STRING/" name
))
1093 (n-buffer (gensym "BUFFER")))
1095 (defun ,size-function
(byte)
1096 (declare (ignore byte
))
1098 (defun ,out-function
(stream string flush-p start end
)
1099 (let ((start (or start
0))
1100 (end (or end
(length string
))))
1101 (declare (type index start end
))
1102 (when (and (not (fd-stream-dual-channel-p stream
))
1103 (> (fd-stream-ibuf-tail stream
)
1104 (fd-stream-ibuf-head stream
)))
1105 (file-position stream
(file-position stream
)))
1106 (unless (<= 0 start end
(length string
))
1107 (signal-bounding-indices-bad-error string start end
))
1110 (setf (fd-stream-obuf-tail stream
)
1111 (string-dispatch (simple-base-string
1113 (simple-array character
(*))
1116 (let ((len (fd-stream-obuf-length stream
))
1117 (sap (fd-stream-obuf-sap stream
))
1118 (tail (fd-stream-obuf-tail stream
)))
1119 (declare (type index tail
)
1120 ;; STRING bounds have already been checked.
1121 (optimize (safety 0)))
1123 (,@(if output-restart
1124 `(catch 'output-nothing
)
1127 ((or (= start end
) (< (- len tail
) 4)))
1128 (let* ((byte (aref string start
))
1129 (bits (char-code byte
)))
1133 ;; Exited from the loop normally
1135 ;; Exited via CATCH. Skip the current character
1136 ;; and try the inner loop again.
1139 (flush-output-buffer stream
)))
1141 (flush-output-buffer stream
))))
1142 (def-output-routines (,format
1148 (if (char= byte
#\Newline
)
1149 (setf (fd-stream-char-pos stream
) 0)
1150 (incf (fd-stream-char-pos stream
)))
1151 (let ((bits (char-code byte
))
1152 (sap (fd-stream-obuf-sap stream
))
1153 (tail (fd-stream-obuf-tail stream
)))
1155 (defun ,in-function
(stream buffer start requested eof-error-p
1156 &aux
(index start
) (end (+ start requested
)))
1157 (declare (type fd-stream stream
)
1158 (type index start requested index end
)
1160 (simple-array character
(#.
+ansi-stream-in-buffer-length
+))
1162 (let ((unread (fd-stream-unread stream
)))
1164 (setf (aref buffer index
) unread
)
1165 (setf (fd-stream-unread stream
) nil
)
1166 (setf (fd-stream-listen stream
) nil
)
1170 (let* ((head (fd-stream-ibuf-head stream
))
1171 (tail (fd-stream-ibuf-tail stream
))
1172 (sap (fd-stream-ibuf-sap stream
)))
1173 (declare (type index head tail
)
1174 (type system-area-pointer sap
))
1175 ;; Copy data from stream buffer into user's buffer.
1176 (dotimes (i (min (truncate (- tail head
) ,size
)
1178 (declare (optimize speed
))
1179 (let* ((byte (sap-ref-8 sap head
)))
1180 (setf (aref buffer index
) ,in-expr
)
1183 (setf (fd-stream-ibuf-head stream
) head
)
1184 ;; Maybe we need to refill the stream buffer.
1185 (cond ( ;; If there was enough data in the stream buffer, we're done.
1187 (return (- index start
)))
1188 ( ;; If EOF, we're done in another way.
1189 (null (catch 'eof-input-catcher
(refill-buffer/fd stream
)))
1191 (error 'end-of-file
:stream stream
)
1192 (return (- index start
))))
1193 ;; Otherwise we refilled the stream buffer, so fall
1194 ;; through into another pass of the loop.
1196 (def-input-routine ,in-char-function
(character ,size sap head
)
1197 (let ((byte (sap-ref-8 sap head
)))
1199 (defun ,read-c-string-function
(sap element-type
)
1200 (declare (type system-area-pointer sap
)
1201 (type (member character base-char
) element-type
))
1203 (declare (optimize (speed 3) (safety 0)))
1204 (let* ((stream ,name
)
1206 (loop for head of-type index upfrom
0 by
,size
1207 for count of-type index upto
(1- array-dimension-limit
)
1208 for byte
= (sap-ref-8 sap head
)
1209 for char of-type character
= ,in-expr
1210 until
(zerop (char-code char
))
1211 finally
(return count
)))
1212 ;; Inline the common cases
1213 (string (make-string length
:element-type element-type
)))
1214 (declare (ignorable stream
)
1216 (type simple-string string
))
1217 (/show0 before-copy-loop
)
1218 (loop for head of-type index upfrom
0 by
,size
1219 for index of-type index below length
1220 for byte
= (sap-ref-8 sap head
)
1221 for char of-type character
= ,in-expr
1222 do
(setf (aref string index
) char
))
1223 string
))) ;; last loop rewrite to dotimes?
1224 (defun ,output-c-string-function
(string)
1225 (declare (type simple-string string
))
1227 (declare (optimize (speed 3) (safety 0)))
1228 (let* ((length (length string
))
1229 (,n-buffer
(make-array (* (1+ length
) ,size
)
1230 :element-type
'(unsigned-byte 8)))
1231 ;; This SAP-taking may seem unsafe without pinning,
1232 ;; but since the variable name is a gensym OUT-EXPR
1233 ;; cannot close over it even if it tried, so the buffer
1234 ;; will always be either in a register or on stack.
1235 ;; FIXME: But ...this is true on x86oids only!
1236 (sap (vector-sap ,n-buffer
))
1239 (declare (type index length tail
)
1240 (type system-area-pointer sap
))
1242 (let* ((byte (aref string i
))
1243 (bits (char-code byte
)))
1244 (declare (ignorable byte bits
))
1248 (byte (code-char bits
)))
1249 (declare (ignorable bits byte
))
1252 (setf *external-formats
*
1253 (cons '(,external-format
,in-function
,in-char-function
,out-function
1254 ,@(mapcar #'(lambda (buffering)
1255 (intern (format nil format
(string buffering
))))
1256 '(:none
:line
:full
))
1257 nil
; no resync-function
1258 ,size-function
,read-c-string-function
,output-c-string-function
)
1259 *external-formats
*)))))
1261 (defmacro define-external-format
/variable-width
1262 (external-format output-restart out-size-expr
1263 out-expr in-size-expr in-expr
)
1264 (let* ((name (first external-format
))
1265 (out-function (symbolicate "OUTPUT-BYTES/" name
))
1266 (format (format nil
"OUTPUT-CHAR-~A-~~A-BUFFERED" (string name
)))
1267 (in-function (symbolicate "FD-STREAM-READ-N-CHARACTERS/" name
))
1268 (in-char-function (symbolicate "INPUT-CHAR/" name
))
1269 (resync-function (symbolicate "RESYNC/" name
))
1270 (size-function (symbolicate "BYTES-FOR-CHAR/" name
))
1271 (read-c-string-function (symbolicate "READ-FROM-C-STRING/" name
))
1272 (output-c-string-function (symbolicate "OUTPUT-TO-C-STRING/" name
))
1273 (n-buffer (gensym "BUFFER")))
1275 (defun ,size-function
(byte)
1276 (declare (ignorable byte
))
1278 (defun ,out-function
(stream string flush-p start end
)
1279 (let ((start (or start
0))
1280 (end (or end
(length string
))))
1281 (declare (type index start end
))
1282 (when (and (not (fd-stream-dual-channel-p stream
))
1283 (> (fd-stream-ibuf-tail stream
)
1284 (fd-stream-ibuf-head stream
)))
1285 (file-position stream
(file-position stream
)))
1286 (unless (<= 0 start end
(length string
))
1287 (signal-bounding-indices-bad-error string start end
))
1290 (setf (fd-stream-obuf-tail stream
)
1291 (string-dispatch (simple-base-string
1293 (simple-array character
(*))
1296 (let ((len (fd-stream-obuf-length stream
))
1297 (sap (fd-stream-obuf-sap stream
))
1298 (tail (fd-stream-obuf-tail stream
)))
1299 (declare (type index tail
)
1300 ;; STRING bounds have already been checked.
1301 (optimize (safety 0)))
1303 (,@(if output-restart
1304 `(catch 'output-nothing
)
1307 ((or (= start end
) (< (- len tail
) 4)))
1308 (let* ((byte (aref string start
))
1309 (bits (char-code byte
))
1310 (size ,out-size-expr
))
1314 ;; Exited from the loop normally
1316 ;; Exited via CATCH. Skip the current character
1317 ;; and try the inner loop again.
1320 (flush-output-buffer stream
)))
1322 (flush-output-buffer stream
))))
1323 (def-output-routines/variable-width
(,format
1330 (if (char= byte
#\Newline
)
1331 (setf (fd-stream-char-pos stream
) 0)
1332 (incf (fd-stream-char-pos stream
)))
1333 (let ((bits (char-code byte
))
1334 (sap (fd-stream-obuf-sap stream
))
1335 (tail (fd-stream-obuf-tail stream
)))
1337 (defun ,in-function
(stream buffer start requested eof-error-p
1338 &aux
(total-copied 0))
1339 (declare (type fd-stream stream
)
1340 (type index start requested total-copied
)
1342 (simple-array character
(#.
+ansi-stream-in-buffer-length
+))
1344 (let ((unread (fd-stream-unread stream
)))
1346 (setf (aref buffer start
) unread
)
1347 (setf (fd-stream-unread stream
) nil
)
1348 (setf (fd-stream-listen stream
) nil
)
1349 (incf total-copied
)))
1352 (let* ((head (fd-stream-ibuf-head stream
))
1353 (tail (fd-stream-ibuf-tail stream
))
1354 (sap (fd-stream-ibuf-sap stream
))
1355 (decode-break-reason nil
))
1356 (declare (type index head tail
))
1357 ;; Copy data from stream buffer into user's buffer.
1358 (do ((size nil nil
))
1359 ((or (= tail head
) (= requested total-copied
)))
1360 (setf decode-break-reason
1361 (block decode-break-reason
1362 (let ((byte (sap-ref-8 sap head
)))
1363 (declare (ignorable byte
))
1364 (setq size
,in-size-expr
)
1365 (when (> size
(- tail head
))
1367 (setf (aref buffer
(+ start total-copied
)) ,in-expr
)
1371 (setf (fd-stream-ibuf-head stream
) head
)
1372 (when decode-break-reason
1373 ;; If we've already read some characters on when the invalid
1374 ;; code sequence is detected, we return immediately. The
1375 ;; handling of the error is deferred until the next call
1376 ;; (where this check will be false). This allows establishing
1377 ;; high-level handlers for decode errors (for example
1378 ;; automatically resyncing in Lisp comments).
1379 (when (plusp total-copied
)
1380 (return-from ,in-function total-copied
))
1381 (when (stream-decoding-error-and-handle
1382 stream decode-break-reason
)
1384 (error 'end-of-file
:stream stream
)
1385 (return-from ,in-function total-copied
)))
1386 (setf head
(fd-stream-ibuf-head stream
))
1387 (setf tail
(fd-stream-ibuf-tail stream
))))
1388 (setf (fd-stream-ibuf-head stream
) head
)
1389 ;; Maybe we need to refill the stream buffer.
1390 (cond ( ;; If there were enough data in the stream buffer, we're done.
1391 (= total-copied requested
)
1392 (return total-copied
))
1393 ( ;; If EOF, we're done in another way.
1394 (or (eq decode-break-reason
'eof
)
1395 (null (catch 'eof-input-catcher
1396 (refill-buffer/fd stream
))))
1398 (error 'end-of-file
:stream stream
)
1399 (return total-copied
)))
1400 ;; Otherwise we refilled the stream buffer, so fall
1401 ;; through into another pass of the loop.
1403 (def-input-routine/variable-width
,in-char-function
(character
1407 (let ((byte (sap-ref-8 sap head
)))
1408 (declare (ignorable byte
))
1410 (defun ,resync-function
(stream)
1411 (loop (input-at-least stream
2)
1412 (incf (fd-stream-ibuf-head stream
))
1413 (unless (block decode-break-reason
1414 (let* ((sap (fd-stream-ibuf-sap stream
))
1415 (head (fd-stream-ibuf-head stream
))
1416 (byte (sap-ref-8 sap head
))
1417 (size ,in-size-expr
))
1418 (declare (ignorable byte
))
1419 (input-at-least stream size
)
1420 (let ((sap (fd-stream-ibuf-sap stream
))
1421 (head (fd-stream-ibuf-head stream
)))
1425 (defun ,read-c-string-function
(sap element-type
)
1426 (declare (type system-area-pointer sap
))
1428 (declare (optimize (speed 3) (safety 0)))
1429 (let* ((stream ,name
)
1430 (size 0) (head 0) (byte 0) (char nil
)
1431 (decode-break-reason nil
)
1432 (length (dotimes (count (1- ARRAY-DIMENSION-LIMIT
) count
)
1433 (setf decode-break-reason
1434 (block decode-break-reason
1435 (setf byte
(sap-ref-8 sap head
)
1440 (when decode-break-reason
1441 (c-string-decoding-error ,name decode-break-reason
))
1442 (when (zerop (char-code char
))
1444 (string (make-string length
:element-type element-type
)))
1445 (declare (ignorable stream
)
1446 (type index head length
) ;; size
1447 (type (unsigned-byte 8) byte
)
1448 (type (or null character
) char
)
1449 (type string string
))
1451 (dotimes (index length string
)
1452 (setf decode-break-reason
1453 (block decode-break-reason
1454 (setf byte
(sap-ref-8 sap head
)
1459 (when decode-break-reason
1460 (c-string-decoding-error ,name decode-break-reason
))
1461 (setf (aref string index
) char
)))))
1463 (defun ,output-c-string-function
(string)
1464 (declare (type simple-string string
))
1466 (declare (optimize (speed 3) (safety 0)))
1467 (let* ((length (length string
))
1468 (char-length (make-array (1+ length
) :element-type
'index
))
1470 (+ (loop for i of-type index below length
1471 for byte of-type character
= (aref string i
)
1472 for bits
= (char-code byte
)
1473 sum
(setf (aref char-length i
)
1474 (the index
,out-size-expr
)))
1475 (let* ((byte (code-char 0))
1476 (bits (char-code byte
)))
1477 (declare (ignorable byte bits
))
1478 (setf (aref char-length length
)
1479 (the index
,out-size-expr
)))))
1481 (,n-buffer
(make-array buffer-length
1482 :element-type
'(unsigned-byte 8)))
1483 ;; This SAP-taking may seem unsafe without pinning,
1484 ;; but since the variable name is a gensym OUT-EXPR
1485 ;; cannot close over it even if it tried, so the buffer
1486 ;; will always be either in a register or on stack.
1487 ;; FIXME: But ...this is true on x86oids only!
1488 (sap (vector-sap ,n-buffer
))
1490 (declare (type index length buffer-length tail
)
1491 (type system-area-pointer sap
)
1494 (loop for i of-type index below length
1495 for byte of-type character
= (aref string i
)
1496 for bits
= (char-code byte
)
1497 for size of-type index
= (aref char-length i
)
1502 (byte (code-char bits
))
1503 (size (aref char-length length
)))
1504 (declare (ignorable bits byte size
))
1508 (setf *external-formats
*
1509 (cons '(,external-format
,in-function
,in-char-function
,out-function
1510 ,@(mapcar #'(lambda (buffering)
1511 (intern (format nil format
(string buffering
))))
1512 '(:none
:line
:full
))
1514 ,size-function
,read-c-string-function
,output-c-string-function
)
1515 *external-formats
*)))))
1517 ;;; Multiple names for the :ISO{,-}8859-* families are needed because on
1518 ;;; FreeBSD (and maybe other BSD systems), nl_langinfo("LATIN-1") will
1519 ;;; return "ISO8859-1" instead of "ISO-8859-1".
1520 (define-external-format (:latin-1
:latin1
:iso-8859-1
:iso8859-1
)
1523 (external-format-encoding-error stream bits
)
1524 (setf (sap-ref-8 sap tail
) bits
))
1527 (define-external-format (:ascii
:us-ascii
:ansi_x3.4-
1968
1528 :iso-646
:iso-646-us
:|
646|
)
1531 (external-format-encoding-error stream bits
)
1532 (setf (sap-ref-8 sap tail
) bits
))
1535 (let* ((table (let ((s (make-string 256)))
1536 (map-into s
#'code-char
1537 '(#x00
#x01
#x02
#x03
#x9c
#x09
#x86
#x7f
#x97
#x8d
#x8e
#x0b
#x0c
#x0d
#x0e
#x0f
1538 #x10
#x11
#x12
#x13
#x9d
#x85
#x08
#x87
#x18
#x19
#x92
#x8f
#x1c
#x1d
#x1e
#x1f
1539 #x80
#x81
#x82
#x83
#x84
#x0a
#x17
#x1b
#x88
#x89
#x8a
#x8b
#x8c
#x05
#x06
#x07
1540 #x90
#x91
#x16
#x93
#x94
#x95
#x96
#x04
#x98
#x99
#x9a
#x9b
#x14
#x15
#x9e
#x1a
1541 #x20
#xa0
#xe2
#xe4
#xe0
#xe1
#xe3
#xe5
#xe7
#xf1
#xa2
#x2e
#x3c
#x28
#x2b
#x7c
1542 #x26
#xe9
#xea
#xeb
#xe8
#xed
#xee
#xef
#xec
#xdf
#x21
#x24
#x2a
#x29
#x3b
#xac
1543 #x2d
#x2f
#xc2
#xc4
#xc0
#xc1
#xc3
#xc5
#xc7
#xd1
#xa6
#x2c
#x25
#x5f
#x3e
#x3f
1544 #xf8
#xc9
#xca
#xcb
#xc8
#xcd
#xce
#xcf
#xcc
#x60
#x3a
#x23
#x40
#x27
#x3d
#x22
1545 #xd8
#x61
#x62
#x63
#x64
#x65
#x66
#x67
#x68
#x69
#xab
#xbb
#xf0
#xfd
#xfe
#xb1
1546 #xb0
#x6a
#x6b
#x6c
#x6d
#x6e
#x6f
#x70
#x71
#x72
#xaa
#xba
#xe6
#xb8
#xc6
#xa4
1547 #xb5
#x7e
#x73
#x74
#x75
#x76
#x77
#x78
#x79
#x7a
#xa1
#xbf
#xd0
#xdd
#xde
#xae
1548 #x5e
#xa3
#xa5
#xb7
#xa9
#xa7
#xb6
#xbc
#xbd
#xbe
#x5b
#x5d
#xaf
#xa8
#xb4
#xd7
1549 #x7b
#x41
#x42
#x43
#x44
#x45
#x46
#x47
#x48
#x49
#xad
#xf4
#xf6
#xf2
#xf3
#xf5
1550 #x7d
#x4a
#x4b
#x4c
#x4d
#x4e
#x4f
#x50
#x51
#x52
#xb9
#xfb
#xfc
#xf9
#xfa
#xff
1551 #x5c
#xf7
#x53
#x54
#x55
#x56
#x57
#x58
#x59
#x5a
#xb2
#xd4
#xd6
#xd2
#xd3
#xd5
1552 #x30
#x31
#x32
#x33
#x34
#x35
#x36
#x37
#x38
#x39
#xb3
#xdb
#xdc
#xd9
#xda
#x9f
))
1554 (reverse-table (let ((rt (make-array 256 :element-type
'(unsigned-byte 8) :initial-element
0)))
1555 (loop for char across table for i from
0
1556 do
(aver (= 0 (aref rt
(char-code char
))))
1557 do
(setf (aref rt
(char-code char
)) i
))
1559 (define-external-format (:ebcdic-us
:ibm-037
:ibm037
)
1562 (external-format-encoding-error stream bits
)
1563 (setf (sap-ref-8 sap tail
) (aref reverse-table bits
)))
1568 (let ((latin-9-table (let ((table (make-string 256)))
1571 (setf (aref table i
) (code-char i
)))
1572 (setf (aref table
#xa4
) (code-char #x20ac
))
1573 (setf (aref table
#xa6
) (code-char #x0160
))
1574 (setf (aref table
#xa8
) (code-char #x0161
))
1575 (setf (aref table
#xb4
) (code-char #x017d
))
1576 (setf (aref table
#xb8
) (code-char #x017e
))
1577 (setf (aref table
#xbc
) (code-char #x0152
))
1578 (setf (aref table
#xbd
) (code-char #x0153
))
1579 (setf (aref table
#xbe
) (code-char #x0178
))
1581 (latin-9-reverse-1 (make-array 16
1582 :element-type
'(unsigned-byte 21)
1583 :initial-contents
'(#x0160
#x0161
#x0152
#x0153
0 0 0 0 #x0178
0 0 0 #x20ac
#x017d
#x017e
0)))
1584 (latin-9-reverse-2 (make-array 16
1585 :element-type
'(unsigned-byte 8)
1586 :initial-contents
'(#xa6
#xa8
#xbc
#xbd
0 0 0 0 #xbe
0 0 0 #xa4
#xb4
#xb8
0))))
1587 (define-external-format (:latin-9
:latin9
:iso-8859-15
:iso8859-15
)
1589 (setf (sap-ref-8 sap tail
)
1591 (if (= bits
(char-code (aref latin-9-table bits
)))
1593 (external-format-encoding-error stream byte
))
1594 (if (= (aref latin-9-reverse-1
(logand bits
15)) bits
)
1595 (aref latin-9-reverse-2
(logand bits
15))
1596 (external-format-encoding-error stream byte
))))
1597 (aref latin-9-table byte
)))
1599 (define-external-format/variable-width
(:utf-8
:utf8
) nil
1600 (let ((bits (char-code byte
)))
1601 (cond ((< bits
#x80
) 1)
1603 ((< bits
#x10000
) 3)
1606 (1 (setf (sap-ref-8 sap tail
) bits
))
1607 (2 (setf (sap-ref-8 sap tail
) (logior #xc0
(ldb (byte 5 6) bits
))
1608 (sap-ref-8 sap
(1+ tail
)) (logior #x80
(ldb (byte 6 0) bits
))))
1609 (3 (setf (sap-ref-8 sap tail
) (logior #xe0
(ldb (byte 4 12) bits
))
1610 (sap-ref-8 sap
(1+ tail
)) (logior #x80
(ldb (byte 6 6) bits
))
1611 (sap-ref-8 sap
(+ 2 tail
)) (logior #x80
(ldb (byte 6 0) bits
))))
1612 (4 (setf (sap-ref-8 sap tail
) (logior #xf0
(ldb (byte 3 18) bits
))
1613 (sap-ref-8 sap
(1+ tail
)) (logior #x80
(ldb (byte 6 12) bits
))
1614 (sap-ref-8 sap
(+ 2 tail
)) (logior #x80
(ldb (byte 6 6) bits
))
1615 (sap-ref-8 sap
(+ 3 tail
)) (logior #x80
(ldb (byte 6 0) bits
)))))
1616 (cond ((< byte
#x80
) 1)
1617 ((< byte
#xc2
) (return-from decode-break-reason
1))
1621 (code-char (ecase size
1623 (2 (let ((byte2 (sap-ref-8 sap
(1+ head
))))
1624 (unless (<= #x80 byte2
#xbf
)
1625 (return-from decode-break-reason
2))
1626 (dpb byte
(byte 5 6) byte2
)))
1627 (3 (let ((byte2 (sap-ref-8 sap
(1+ head
)))
1628 (byte3 (sap-ref-8 sap
(+ 2 head
))))
1629 (unless (and (<= #x80 byte2
#xbf
)
1630 (<= #x80 byte3
#xbf
))
1631 (return-from decode-break-reason
3))
1632 (dpb byte
(byte 4 12) (dpb byte2
(byte 6 6) byte3
))))
1633 (4 (let ((byte2 (sap-ref-8 sap
(1+ head
)))
1634 (byte3 (sap-ref-8 sap
(+ 2 head
)))
1635 (byte4 (sap-ref-8 sap
(+ 3 head
))))
1636 (unless (and (<= #x80 byte2
#xbf
)
1637 (<= #x80 byte3
#xbf
)
1638 (<= #x80 byte4
#xbf
))
1639 (return-from decode-break-reason
4))
1640 (dpb byte
(byte 3 18)
1641 (dpb byte2
(byte 6 12)
1642 (dpb byte3
(byte 6 6) byte4
))))))))
1644 ;;;; utility functions (misc routines, etc)
1646 ;;; Fill in the various routine slots for the given type. INPUT-P and
1647 ;;; OUTPUT-P indicate what slots to fill. The buffering slot must be
1648 ;;; set prior to calling this routine.
1649 (defun set-fd-stream-routines (fd-stream element-type external-format
1650 input-p output-p buffer-p
)
1651 (let* ((target-type (case element-type
1652 (unsigned-byte '(unsigned-byte 8))
1653 (signed-byte '(signed-byte 8))
1654 (:default
'character
)
1656 (character-stream-p (subtypep target-type
'character
))
1657 (bivalent-stream-p (eq element-type
:default
))
1658 normalized-external-format
1659 (bin-routine #'ill-bin
)
1662 (cin-routine #'ill-in
)
1665 (input-type nil
) ;calculated from bin-type/cin-type
1666 (input-size nil
) ;calculated from bin-size/cin-size
1667 (read-n-characters #'ill-in
)
1668 (bout-routine #'ill-bout
)
1671 (cout-routine #'ill-out
)
1676 (output-bytes #'ill-bout
))
1678 ;; drop buffers when direction changes
1679 (when (and (fd-stream-obuf-sap fd-stream
) (not output-p
))
1680 (with-available-buffers-lock ()
1681 (push (fd-stream-obuf-sap fd-stream
) *available-buffers
*)
1682 (setf (fd-stream-obuf-sap fd-stream
) nil
)))
1683 (when (and (fd-stream-ibuf-sap fd-stream
) (not input-p
))
1684 (with-available-buffers-lock ()
1685 (push (fd-stream-ibuf-sap fd-stream
) *available-buffers
*)
1686 (setf (fd-stream-ibuf-sap fd-stream
) nil
)))
1688 (setf (fd-stream-ibuf-sap fd-stream
) (next-available-buffer))
1689 (setf (fd-stream-ibuf-length fd-stream
) bytes-per-buffer
)
1690 (setf (fd-stream-ibuf-tail fd-stream
) 0))
1692 (setf (fd-stream-obuf-sap fd-stream
) (next-available-buffer))
1693 (setf (fd-stream-obuf-length fd-stream
) bytes-per-buffer
)
1694 (setf (fd-stream-obuf-tail fd-stream
) 0)
1695 (setf (fd-stream-char-pos fd-stream
) 0))
1697 (when (and character-stream-p
1698 (eq external-format
:default
))
1699 (/show0
"/getting default external format")
1700 (setf external-format
(default-external-format)))
1703 (when (or (not character-stream-p
) bivalent-stream-p
)
1704 (multiple-value-setq (bin-routine bin-type bin-size read-n-characters
1705 normalized-external-format
)
1706 (pick-input-routine (if bivalent-stream-p
'(unsigned-byte 8)
1710 (error "could not find any input routine for ~S" target-type
)))
1711 (when character-stream-p
1712 (multiple-value-setq (cin-routine cin-type cin-size read-n-characters
1713 normalized-external-format
)
1714 (pick-input-routine target-type external-format
))
1716 (error "could not find any input routine for ~S" target-type
)))
1717 (setf (fd-stream-in fd-stream
) cin-routine
1718 (fd-stream-bin fd-stream
) bin-routine
)
1719 ;; character type gets preferential treatment
1720 (setf input-size
(or cin-size bin-size
))
1721 (setf input-type
(or cin-type bin-type
))
1722 (when normalized-external-format
1723 (setf (fd-stream-external-format fd-stream
)
1724 normalized-external-format
))
1725 (when (= (or cin-size
1) (or bin-size
1) 1)
1726 (setf (fd-stream-n-bin fd-stream
) ;XXX
1727 (if (and character-stream-p
(not bivalent-stream-p
))
1729 #'fd-stream-read-n-bytes
))
1730 ;; Sometimes turn on fast-read-char/fast-read-byte. Switch on
1731 ;; for character and (unsigned-byte 8) streams. In these
1732 ;; cases, fast-read-* will read from the
1733 ;; ansi-stream-(c)in-buffer, saving function calls.
1734 ;; Otherwise, the various data-reading functions in the stream
1735 ;; structure will be called.
1737 (not bivalent-stream-p
)
1738 ;; temporary disable on :io streams
1740 (cond (character-stream-p
1741 (setf (ansi-stream-cin-buffer fd-stream
)
1742 (make-array +ansi-stream-in-buffer-length
+
1743 :element-type
'character
)))
1744 ((equal target-type
'(unsigned-byte 8))
1745 (setf (ansi-stream-in-buffer fd-stream
)
1746 (make-array +ansi-stream-in-buffer-length
+
1747 :element-type
'(unsigned-byte 8))))))))
1750 (when (or (not character-stream-p
) bivalent-stream-p
)
1751 (multiple-value-setq (bout-routine bout-type bout-size output-bytes
1752 normalized-external-format
)
1753 (pick-output-routine (if bivalent-stream-p
1756 (fd-stream-buffering fd-stream
)
1758 (unless bout-routine
1759 (error "could not find any output routine for ~S buffered ~S"
1760 (fd-stream-buffering fd-stream
)
1762 (when character-stream-p
1763 (multiple-value-setq (cout-routine cout-type cout-size output-bytes
1764 normalized-external-format
)
1765 (pick-output-routine target-type
1766 (fd-stream-buffering fd-stream
)
1768 (unless cout-routine
1769 (error "could not find any output routine for ~S buffered ~S"
1770 (fd-stream-buffering fd-stream
)
1772 (when normalized-external-format
1773 (setf (fd-stream-external-format fd-stream
)
1774 normalized-external-format
))
1775 (when character-stream-p
1776 (setf (fd-stream-output-bytes fd-stream
) output-bytes
))
1777 (setf (fd-stream-out fd-stream
) cout-routine
1778 (fd-stream-bout fd-stream
) bout-routine
1779 (fd-stream-sout fd-stream
) (if (eql cout-size
1)
1780 #'fd-sout
#'ill-out
))
1781 (setf output-size
(or cout-size bout-size
))
1782 (setf output-type
(or cout-type bout-type
)))
1784 (when (and input-size output-size
1785 (not (eq input-size output-size
)))
1786 (error "Element sizes for input (~S:~S) and output (~S:~S) differ?"
1787 input-type input-size
1788 output-type output-size
))
1789 (setf (fd-stream-element-size fd-stream
)
1790 (or input-size output-size
))
1792 (setf (fd-stream-element-type fd-stream
)
1793 (cond ((equal input-type output-type
)
1799 ((subtypep input-type output-type
)
1801 ((subtypep output-type input-type
)
1804 (error "Input type (~S) and output type (~S) are unrelated?"
1808 ;;; Handle miscellaneous operations on FD-STREAM.
1809 (defun fd-stream-misc-routine (fd-stream operation
&optional arg1 arg2
)
1810 (declare (ignore arg2
))
1813 (labels ((do-listen ()
1814 (or (not (eql (fd-stream-ibuf-head fd-stream
)
1815 (fd-stream-ibuf-tail fd-stream
)))
1816 (fd-stream-listen fd-stream
)
1818 (sb!win32
:fd-listen
(fd-stream-fd fd-stream
))
1820 ;; If the read can block, LISTEN will certainly return NIL.
1821 (if (sysread-may-block-p fd-stream
)
1823 ;; Otherwise select(2) and CL:LISTEN have slightly
1824 ;; different semantics. The former returns that an FD
1825 ;; is readable when a read operation wouldn't block.
1826 ;; That includes EOF. However, LISTEN must return NIL
1828 (progn (catch 'eof-input-catcher
1829 ;; r-b/f too calls select, but it shouldn't
1830 ;; block as long as read can return once w/o
1832 (refill-buffer/fd fd-stream
))
1833 ;; At this point either IBUF-HEAD != IBUF-TAIL
1834 ;; and FD-STREAM-LISTEN is NIL, in which case
1835 ;; we should return T, or IBUF-HEAD ==
1836 ;; IBUF-TAIL and FD-STREAM-LISTEN is :EOF, in
1837 ;; which case we should return :EOF for this
1838 ;; call and all future LISTEN call on this stream.
1839 ;; Call ourselves again to determine which case
1844 (setf (fd-stream-unread fd-stream
) arg1
)
1845 (setf (fd-stream-listen fd-stream
) t
))
1847 (cond (arg1 ; We got us an abort on our hands.
1848 (when (fd-stream-handler fd-stream
)
1849 (remove-fd-handler (fd-stream-handler fd-stream
))
1850 (setf (fd-stream-handler fd-stream
) nil
))
1851 ;; We can't do anything unless we know what file were
1852 ;; dealing with, and we don't want to do anything
1853 ;; strange unless we were writing to the file.
1854 (when (and (fd-stream-file fd-stream
)
1855 (fd-stream-obuf-sap fd-stream
))
1856 (if (fd-stream-original fd-stream
)
1857 ;; If the original is EQ to file we are appending
1858 ;; and can just close the file without renaming.
1859 (unless (eq (fd-stream-original fd-stream
)
1860 (fd-stream-file fd-stream
))
1861 ;; We have a handle on the original, just revert.
1862 (multiple-value-bind (okay err
)
1863 (sb!unix
:unix-rename
(fd-stream-original fd-stream
)
1864 (fd-stream-file fd-stream
))
1866 (simple-stream-perror
1867 "couldn't restore ~S to its original contents"
1870 ;; We can't restore the original, and aren't
1871 ;; appending, so nuke that puppy.
1873 ;; FIXME: This is currently the fate of superseded
1874 ;; files, and according to the CLOSE spec this is
1875 ;; wrong. However, there seems to be no clean way to
1876 ;; do that that doesn't involve either copying the
1877 ;; data (bad if the :abort resulted from a full
1878 ;; disk), or renaming the old file temporarily
1879 ;; (probably bad because stream opening becomes more
1881 (multiple-value-bind (okay err
)
1882 (sb!unix
:unix-unlink
(fd-stream-file fd-stream
))
1884 (error 'simple-file-error
1885 :pathname
(fd-stream-file fd-stream
)
1887 "~@<couldn't remove ~S: ~2I~_~A~:>"
1888 :format-arguments
(list (fd-stream-file fd-stream
)
1889 (strerror err
))))))))
1891 (fd-stream-misc-routine fd-stream
:finish-output
)
1892 (when (and (fd-stream-original fd-stream
)
1893 (fd-stream-delete-original fd-stream
))
1894 (multiple-value-bind (okay err
)
1895 (sb!unix
:unix-unlink
(fd-stream-original fd-stream
))
1897 (error 'simple-file-error
1898 :pathname
(fd-stream-original fd-stream
)
1900 "~@<couldn't delete ~S during close of ~S: ~
1903 (list (fd-stream-original fd-stream
)
1905 (strerror err
))))))))
1906 (when (fboundp 'cancel-finalization
)
1907 (cancel-finalization fd-stream
))
1908 (sb!unix
:unix-close
(fd-stream-fd fd-stream
))
1909 (when (fd-stream-obuf-sap fd-stream
)
1910 (with-available-buffers-lock ()
1911 (push (fd-stream-obuf-sap fd-stream
) *available-buffers
*)
1912 (setf (fd-stream-obuf-sap fd-stream
) nil
)))
1913 (when (fd-stream-ibuf-sap fd-stream
)
1914 (with-available-buffers-lock ()
1915 (push (fd-stream-ibuf-sap fd-stream
) *available-buffers
*)
1916 (setf (fd-stream-ibuf-sap fd-stream
) nil
)))
1917 (sb!impl
::set-closed-flame fd-stream
))
1919 (setf (fd-stream-unread fd-stream
) nil
)
1920 (setf (fd-stream-ibuf-head fd-stream
) 0)
1921 (setf (fd-stream-ibuf-tail fd-stream
) 0)
1924 (sb!win32
:fd-clear-input
(fd-stream-fd fd-stream
))
1925 (setf (fd-stream-listen fd-stream
) nil
))
1927 (catch 'eof-input-catcher
1928 (loop until
(sysread-may-block-p fd-stream
)
1930 (refill-buffer/fd fd-stream
)
1931 (setf (fd-stream-ibuf-head fd-stream
) 0)
1932 (setf (fd-stream-ibuf-tail fd-stream
) 0))
1935 (flush-output-buffer fd-stream
))
1937 (finish-fd-stream-output fd-stream
))
1939 (fd-stream-element-type fd-stream
))
1941 (fd-stream-external-format fd-stream
))
1943 (= 1 (the (member 0 1)
1944 (sb!unix
:unix-isatty
(fd-stream-fd fd-stream
)))))
1948 (fd-stream-char-pos fd-stream
))
1950 (unless (fd-stream-file fd-stream
)
1951 ;; This is a TYPE-ERROR because ANSI's species FILE-LENGTH
1952 ;; "should signal an error of type TYPE-ERROR if stream is not
1953 ;; a stream associated with a file". Too bad there's no very
1954 ;; appropriate value for the EXPECTED-TYPE slot..
1955 (error 'simple-type-error
1957 :expected-type
'fd-stream
1958 :format-control
"~S is not a stream associated with a file."
1959 :format-arguments
(list fd-stream
)))
1960 (multiple-value-bind (okay dev ino mode nlink uid gid rdev size
1961 atime mtime ctime blksize blocks
)
1962 (sb!unix
:unix-fstat
(fd-stream-fd fd-stream
))
1963 (declare (ignore ino nlink uid gid rdev
1964 atime mtime ctime blksize blocks
))
1966 (simple-stream-perror "failed Unix fstat(2) on ~S" fd-stream dev
))
1969 (truncate size
(fd-stream-element-size fd-stream
)))))
1970 (:file-string-length
1972 (character (fd-stream-character-size fd-stream arg1
))
1973 (string (fd-stream-string-size fd-stream arg1
))))
1976 (fd-stream-set-file-position fd-stream arg1
)
1977 (fd-stream-get-file-position fd-stream
)))))
1979 ;; FIXME: Think about this.
1981 ;; (defun finish-fd-stream-output (fd-stream)
1982 ;; (let ((timeout (fd-stream-timeout fd-stream)))
1983 ;; (loop while (fd-stream-output-later fd-stream)
1984 ;; ;; FIXME: SIGINT while waiting for a timeout will
1985 ;; ;; cause a timeout here.
1986 ;; do (when (and (not (serve-event timeout)) timeout)
1987 ;; (signal-timeout 'io-timeout
1988 ;; :stream fd-stream
1989 ;; :direction :write
1990 ;; :seconds timeout)))))
1992 (defun finish-fd-stream-output (stream)
1993 (flush-output-buffer stream
)
1995 ((null (fd-stream-output-later stream
)))
1996 (serve-all-events)))
1998 (defun fd-stream-get-file-position (stream)
1999 (declare (fd-stream stream
))
2001 (let ((posn (sb!unix
:unix-lseek
(fd-stream-fd stream
) 0 sb
!unix
:l_incr
)))
2002 (declare (type (or (alien sb
!unix
:off-t
) null
) posn
))
2003 ;; We used to return NIL for errno==ESPIPE, and signal an error
2004 ;; in other failure cases. However, CLHS says to return NIL if
2005 ;; the position cannot be determined -- so that's what we do.
2006 (when (integerp posn
)
2007 ;; Adjust for buffered output: If there is any output
2008 ;; buffered, the *real* file position will be larger
2009 ;; than reported by lseek() because lseek() obviously
2010 ;; cannot take into account output we have not sent
2012 (dolist (later (fd-stream-output-later stream
))
2013 (incf posn
(- (caddr later
) (cadr later
))))
2014 (incf posn
(fd-stream-obuf-tail stream
))
2015 ;; Adjust for unread input: If there is any input
2016 ;; read from UNIX but not supplied to the user of the
2017 ;; stream, the *real* file position will smaller than
2018 ;; reported, because we want to look like the unread
2019 ;; stuff is still available.
2020 (decf posn
(- (fd-stream-ibuf-tail stream
)
2021 (fd-stream-ibuf-head stream
)))
2022 (when (fd-stream-unread stream
)
2024 ;; Divide bytes by element size.
2025 (truncate posn
(fd-stream-element-size stream
))))))
2027 (defun fd-stream-set-file-position (stream position-spec
)
2028 (declare (fd-stream stream
))
2029 (check-type position-spec
2030 (or (alien sb
!unix
:off-t
) (member nil
:start
:end
))
2031 "valid file position designator")
2034 ;; Make sure we don't have any output pending, because if we
2035 ;; move the file pointer before writing this stuff, it will be
2036 ;; written in the wrong location.
2037 (finish-fd-stream-output stream
)
2038 ;; Disable interrupts so that interrupt handlers doing output
2041 (unless (fd-stream-output-finished-p stream
)
2042 ;; We got interrupted and more output came our way during
2043 ;; the interrupt. Wrapping the FINISH-FD-STREAM-OUTPUT in
2044 ;; WITHOUT-INTERRUPTS gets nasty as it can signal errors,
2045 ;; so we prefer to do things like this...
2047 ;; Clear out any pending input to force the next read to go to
2049 (setf (fd-stream-unread stream
) nil
2050 (fd-stream-ibuf-head stream
) 0
2051 (fd-stream-ibuf-tail stream
) 0)
2052 ;; Trash cached value for listen, so that we check next time.
2053 (setf (fd-stream-listen stream
) nil
)
2055 (multiple-value-bind (offset origin
)
2058 (values 0 sb
!unix
:l_set
))
2060 (values 0 sb
!unix
:l_xtnd
))
2062 (values (* position-spec
(fd-stream-element-size stream
))
2064 (declare (type (alien sb
!unix
:off-t
) offset
))
2065 (let ((posn (sb!unix
:unix-lseek
(fd-stream-fd stream
)
2067 ;; CLHS says to return true if the file-position was set
2068 ;; succesfully, and NIL otherwise. We are to signal an error
2069 ;; only if the given position was out of bounds, and that is
2070 ;; dealt with above. In times past we used to return NIL for
2071 ;; errno==ESPIPE, and signal an error in other cases.
2073 ;; FIXME: We are still liable to signal an error if flushing
2075 (return-from fd-stream-set-file-position
2076 (typep posn
'(alien sb
!unix
:off-t
))))))))
2079 ;;;; creation routines (MAKE-FD-STREAM and OPEN)
2081 ;;; Create a stream for the given Unix file descriptor.
2083 ;;; If INPUT is non-NIL, allow input operations. If OUTPUT is non-nil,
2084 ;;; allow output operations. If neither INPUT nor OUTPUT is specified,
2085 ;;; default to allowing input.
2087 ;;; ELEMENT-TYPE indicates the element type to use (as for OPEN).
2089 ;;; BUFFERING indicates the kind of buffering to use.
2091 ;;; TIMEOUT (if true) is the number of seconds to wait for input. If
2092 ;;; NIL (the default), then wait forever. When we time out, we signal
2095 ;;; FILE is the name of the file (will be returned by PATHNAME).
2097 ;;; NAME is used to identify the stream when printed.
2098 (defun make-fd-stream (fd
2101 (output nil output-p
)
2102 (element-type 'base-char
)
2104 (external-format :default
)
2113 (format nil
"file ~A" file
)
2114 (format nil
"descriptor ~W" fd
)))
2116 (declare (type index fd
) (type (or real null
) timeout
)
2117 (type (member :none
:line
:full
) buffering
))
2118 (cond ((not (or input-p output-p
))
2120 ((not (or input output
))
2121 (error "File descriptor must be opened either for input or output.")))
2122 (let ((stream (%make-fd-stream
:fd fd
2126 :delete-original delete-original
2128 :buffering buffering
2129 :dual-channel-p dual-channel-p
2130 :external-format external-format
2133 (coerce timeout
'single-float
)
2135 (set-fd-stream-routines stream element-type external-format
2136 input output input-buffer-p
)
2137 (when (and auto-close
(fboundp 'finalize
))
2140 (sb!unix
:unix-close fd
)
2142 (format *terminal-io
* "** closed file descriptor ~W **~%"
2146 ;;; Pick a name to use for the backup file for the :IF-EXISTS
2147 ;;; :RENAME-AND-DELETE and :RENAME options.
2148 (defun pick-backup-name (name)
2149 (declare (type simple-string name
))
2150 (concatenate 'simple-string name
".bak"))
2152 ;;; Ensure that the given arg is one of the given list of valid
2153 ;;; things. Allow the user to fix any problems.
2154 (defun ensure-one-of (item list what
)
2155 (unless (member item list
)
2156 (error 'simple-type-error
2158 :expected-type
`(member ,@list
)
2159 :format-control
"~@<~S is ~_invalid for ~S; ~_need one of~{ ~S~}~:>"
2160 :format-arguments
(list item what list
))))
2162 ;;; Rename NAMESTRING to ORIGINAL. First, check whether we have write
2163 ;;; access, since we don't want to trash unwritable files even if we
2164 ;;; technically can. We return true if we succeed in renaming.
2165 (defun rename-the-old-one (namestring original
)
2166 (unless (sb!unix
:unix-access namestring sb
!unix
:w_ok
)
2167 (error "~@<The file ~2I~_~S ~I~_is not writable.~:>" namestring
))
2168 (multiple-value-bind (okay err
) (sb!unix
:unix-rename namestring original
)
2171 (error 'simple-file-error
2172 :pathname namestring
2174 "~@<couldn't rename ~2I~_~S ~I~_to ~2I~_~S: ~4I~_~A~:>"
2175 :format-arguments
(list namestring original
(strerror err
))))))
2177 (defun open (filename
2180 (element-type 'base-char
)
2181 (if-exists nil if-exists-given
)
2182 (if-does-not-exist nil if-does-not-exist-given
)
2183 (external-format :default
)
2184 &aux
; Squelch assignment warning.
2185 (direction direction
)
2186 (if-does-not-exist if-does-not-exist
)
2187 (if-exists if-exists
))
2189 "Return a stream which reads from or writes to FILENAME.
2191 :DIRECTION - one of :INPUT, :OUTPUT, :IO, or :PROBE
2192 :ELEMENT-TYPE - the type of object to read or write, default BASE-CHAR
2193 :IF-EXISTS - one of :ERROR, :NEW-VERSION, :RENAME, :RENAME-AND-DELETE,
2194 :OVERWRITE, :APPEND, :SUPERSEDE or NIL
2195 :IF-DOES-NOT-EXIST - one of :ERROR, :CREATE or NIL
2196 See the manual for details."
2198 ;; Calculate useful stuff.
2199 (multiple-value-bind (input output mask
)
2201 (:input
(values t nil sb
!unix
:o_rdonly
))
2202 (:output
(values nil t sb
!unix
:o_wronly
))
2203 (:io
(values t t sb
!unix
:o_rdwr
))
2204 (:probe
(values t nil sb
!unix
:o_rdonly
)))
2205 (declare (type index mask
))
2206 (let* ((pathname (merge-pathnames filename
))
2208 (cond ((unix-namestring pathname input
))
2209 ((and input
(eq if-does-not-exist
:create
))
2210 (unix-namestring pathname nil
))
2211 ((and (eq direction
:io
) (not if-does-not-exist-given
))
2212 (unix-namestring pathname nil
)))))
2213 ;; Process if-exists argument if we are doing any output.
2215 (unless if-exists-given
2217 (if (eq (pathname-version pathname
) :newest
)
2220 (ensure-one-of if-exists
2221 '(:error
:new-version
:rename
2222 :rename-and-delete
:overwrite
2223 :append
:supersede nil
)
2226 ((:new-version
:error nil
)
2227 (setf mask
(logior mask sb
!unix
:o_excl
)))
2228 ((:rename
:rename-and-delete
)
2229 (setf mask
(logior mask sb
!unix
:o_creat
)))
2231 (setf mask
(logior mask sb
!unix
:o_trunc
)))
2233 (setf mask
(logior mask sb
!unix
:o_append
)))))
2235 (setf if-exists
:ignore-this-arg
)))
2237 (unless if-does-not-exist-given
2238 (setf if-does-not-exist
2239 (cond ((eq direction
:input
) :error
)
2241 (member if-exists
'(:overwrite
:append
)))
2243 ((eq direction
:probe
)
2247 (ensure-one-of if-does-not-exist
2248 '(:error
:create nil
)
2250 (if (eq if-does-not-exist
:create
)
2251 (setf mask
(logior mask sb
!unix
:o_creat
)))
2253 (let ((original (case if-exists
2254 ((:rename
:rename-and-delete
)
2255 (pick-backup-name namestring
))
2256 ((:append
:overwrite
)
2257 ;; KLUDGE: Provent CLOSE from deleting
2258 ;; appending streams when called with :ABORT T
2260 (delete-original (eq if-exists
:rename-and-delete
))
2262 (when (and original
(not (eq original namestring
)))
2263 ;; We are doing a :RENAME or :RENAME-AND-DELETE. Determine
2264 ;; whether the file already exists, make sure the original
2265 ;; file is not a directory, and keep the mode.
2268 (multiple-value-bind (okay err
/dev inode orig-mode
)
2269 (sb!unix
:unix-stat namestring
)
2270 (declare (ignore inode
)
2271 (type (or index null
) orig-mode
))
2274 (when (and output
(= (logand orig-mode
#o170000
)
2276 (error 'simple-file-error
2277 :pathname namestring
2279 "can't open ~S for output: is a directory"
2280 :format-arguments
(list namestring
)))
2281 (setf mode
(logand orig-mode
#o777
))
2283 ((eql err
/dev sb
!unix
:enoent
)
2286 (simple-file-perror "can't find ~S"
2290 (rename-the-old-one namestring original
))
2292 (setf delete-original nil
)
2293 ;; In order to use :SUPERSEDE instead, we have to make
2294 ;; sure SB!UNIX:O_CREAT corresponds to
2295 ;; IF-DOES-NOT-EXIST. SB!UNIX:O_CREAT was set before
2296 ;; because of IF-EXISTS being :RENAME.
2297 (unless (eq if-does-not-exist
:create
)
2299 (logior (logandc2 mask sb
!unix
:o_creat
)
2301 (setf if-exists
:supersede
))))
2303 ;; Now we can try the actual Unix open(2).
2304 (multiple-value-bind (fd errno
)
2306 (sb!unix
:unix-open namestring mask mode
)
2307 (values nil sb
!unix
:enoent
))
2308 (labels ((open-error (format-control &rest format-arguments
)
2309 (error 'simple-file-error
2311 :format-control format-control
2312 :format-arguments format-arguments
))
2313 (vanilla-open-error ()
2314 (simple-file-perror "error opening ~S" pathname errno
)))
2317 ((:input
:output
:io
)
2321 :element-type element-type
2322 :external-format external-format
2325 :delete-original delete-original
2332 (%make-fd-stream
:name namestring
2335 :element-type element-type
)))
2338 ((eql errno sb
!unix
:enoent
)
2339 (case if-does-not-exist
2340 (:error
(vanilla-open-error))
2342 (open-error "~@<The path ~2I~_~S ~I~_does not exist.~:>"
2345 ((and (eql errno sb
!unix
:eexist
) (null if-exists
))
2348 (vanilla-open-error)))))))))
2352 ;;; the stream connected to the controlling terminal, or NIL if there is none
2355 ;;; the stream connected to the standard input (file descriptor 0)
2358 ;;; the stream connected to the standard output (file descriptor 1)
2361 ;;; the stream connected to the standard error output (file descriptor 2)
2364 ;;; This is called when the cold load is first started up, and may also
2365 ;;; be called in an attempt to recover from nested errors.
2366 (defun stream-cold-init-or-reset ()
2368 (setf *terminal-io
* (make-synonym-stream '*tty
*))
2369 (setf *standard-output
* (make-synonym-stream '*stdout
*))
2370 (setf *standard-input
* (make-synonym-stream '*stdin
*))
2371 (setf *error-output
* (make-synonym-stream '*stderr
*))
2372 (setf *query-io
* (make-synonym-stream '*terminal-io
*))
2373 (setf *debug-io
* *query-io
*)
2374 (setf *trace-output
* *standard-output
*)
2377 ;;; This is called whenever a saved core is restarted.
2378 (defun stream-reinit ()
2379 (setf *available-buffers
* nil
)
2380 (with-output-to-string (*error-output
*)
2382 (make-fd-stream 0 :name
"standard input" :input t
:buffering
:line
2383 #!+win32
:external-format
#!+win32
(sb!win32
::console-input-codepage
)))
2385 (make-fd-stream 1 :name
"standard output" :output t
:buffering
:line
2386 #!+win32
:external-format
#!+win32
(sb!win32
::console-output-codepage
)))
2388 (make-fd-stream 2 :name
"standard error" :output t
:buffering
:line
2389 #!+win32
:external-format
#!+win32
(sb!win32
::console-output-codepage
)))
2390 (let* ((ttyname #.
(coerce "/dev/tty" 'simple-base-string
))
2391 (tty (sb!unix
:unix-open ttyname sb
!unix
:o_rdwr
#o666
)))
2395 :name
"the terminal"
2400 (setf *tty
* (make-two-way-stream *stdin
* *stdout
*))))
2401 (princ (get-output-stream-string *error-output
*) *stderr
*))
2406 ;;; the Unix way to beep
2407 (defun beep (stream)
2408 (write-char (code-char bell-char-code
) stream
)
2409 (finish-output stream
))
2411 ;;; This is kind of like FILE-POSITION, but is an internal hack used
2412 ;;; by the filesys stuff to get and set the file name.
2414 ;;; FIXME: misleading name, screwy interface
2415 (defun file-name (stream &optional new-name
)
2416 (when (typep stream
'fd-stream
)
2418 (setf (fd-stream-pathname stream
) new-name
)
2419 (setf (fd-stream-file stream
)
2420 (unix-namestring new-name nil
))
2423 (fd-stream-pathname stream
)))))