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")
16 ;;;; Streams hold BUFFER objects, which contain a SAP, size of the
17 ;;;; memory area the SAP stands for (LENGTH bytes), and HEAD and TAIL
18 ;;;; indexes which delimit the "valid", or "active" area of the
19 ;;;; memory. HEAD is inclusive, TAIL is exclusive.
21 ;;;; Buffers get allocated lazily, and are recycled by returning them
22 ;;;; to the *AVAILABLE-BUFFERS* list. Every buffer has its own
23 ;;;; finalizer, to take care of releasing the SAP memory when a stream
24 ;;;; is not properly closed.
26 ;;;; The code aims to provide a limited form of thread and interrupt
27 ;;;; safety: parallel writes and reads may lose output or input, cause
28 ;;;; interleaved IO, etc -- but they should not corrupt memory. The
29 ;;;; key to doing this is to read buffer state once, and update the
30 ;;;; state based on the read state:
32 ;;;; (let ((tail (buffer-tail buffer)))
34 ;;;; (setf (buffer-tail buffer) (+ tail n)))
38 ;;;; (let ((tail (buffer-tail buffer)))
40 ;;;; (incf (buffer-tail buffer) n))
43 (defstruct (buffer (:constructor
!make-buffer
(sap length
))
45 (sap (missing-arg) :type system-area-pointer
:read-only t
)
46 (length (missing-arg) :type index
:read-only t
)
49 (prev-head 0 :type index
))
50 (declaim (freeze-type buffer
))
52 (define-load-time-global *available-buffers
* ()
53 "List of available buffers.")
55 (defconstant +bytes-per-buffer
+ (* 32 1024)
56 "Default number of bytes per buffer.")
58 (defun alloc-buffer (&optional
(size +bytes-per-buffer
+))
59 (declare (sb-c::tlab
:system
)
60 (inline allocate-system-memory
) ; so the SAP gets heap-consed
61 (inline !make-buffer
))
62 ;; Don't want to allocate & unwind before the finalizer is in place.
64 (let* ((sap (allocate-system-memory size
))
65 (buffer (!make-buffer sap size
)))
66 (when (zerop (sap-int sap
))
67 (error "Could not allocate ~D bytes for buffer." size
))
68 (finalize buffer
(lambda ()
69 (deallocate-system-memory sap size
))
74 (or (and *available-buffers
* (atomic-pop *available-buffers
*))
77 (declaim (inline reset-buffer
))
78 (defun reset-buffer (buffer)
79 (setf (buffer-head buffer
) 0
80 (buffer-tail buffer
) 0)
83 (defun release-buffer (buffer)
84 (declare (sb-c::tlab
:system
))
86 (atomic-push buffer
*available-buffers
*))
89 ;;;; the FD-STREAM structure
91 ;;; Coarsely characterizes the element type of an FD-STREAM w.r.t.
92 ;;; its SUBTYPEP relations to the relevant CHARACTER and
93 ;;; ([UN]SIGNED-BYTE 8) types. This coarse characterization enables
94 ;;; dispatching on the element type as needed by {READ,WRITE}-SEQUENCE
95 ;;; without calling SUBTYPEP.
96 (deftype stream-element-mode
()
97 '(member character unsigned-byte signed-byte
:bivalent
))
100 (:constructor %make-fd-stream
)
101 (:conc-name fd-stream-
)
102 (:predicate fd-stream-p
)
103 (:include ansi-stream
104 ;; FIXME: would a type constraint on IN-BUFFER
105 ;; and/or CIN-BUFFER improve anything?
106 (misc #'fd-stream-misc-routine
))
109 ;; the name of this stream
111 ;; the file this stream is for
113 ;; the backup file namestring for the old file, for :IF-EXISTS
114 ;; :RENAME or :RENAME-AND-DELETE.
115 (original nil
:type
(or simple-string null
))
116 (delete-original nil
) ; for :if-exists :rename-and-delete
117 ;;; the number of bytes per element
118 (element-size 1 :type index
)
119 ;; the type of element being transfered
120 (element-type 'base-char
)
121 ;; coarse characterization of the element type. see description of
122 ;; STREAM-ELEMENT-MODE type.
123 (element-mode :bivalent
:type stream-element-mode
)
124 ;; the Unix file descriptor
125 (fd -
1 :type
#-win32 fixnum
#+win32 sb-vm
:signed-word
)
126 ;; What do we know about the FD?
127 (fd-type :unknown
:type keyword
)
128 ;; controls when the output buffer is flushed
129 (buffering :full
:type
(member :full
:line
:none
))
130 ;; controls whether the input buffer must be cleared before output
131 ;; (must be done for files, not for sockets, pipes and other data
132 ;; sources where input and output aren't related).
133 (synchronize-output nil
)
134 ;; character position if known -- this may run into bignums, but
135 ;; we probably should flip it into null then for efficiency's sake...
136 (output-column nil
:type
(or (and unsigned-byte
139 ;; T if input is waiting on FD. :EOF if we hit EOF.
140 (listen nil
:type
(member nil t
:eof
))
141 ;; T if serve-event is allowed when this stream blocks
142 (serve-events nil
:type boolean
)
145 (instead (make-array 0 :element-type
'character
:adjustable t
:fill-pointer t
) :type
(array character
(*)))
146 (ibuf nil
:type
(or buffer null
))
147 (eof-forced-p nil
:type
(member t nil
))
150 (obuf nil
:type
(or buffer null
))
152 ;; output flushed, but not written due to non-blocking io?
155 ;; timeout specified for this stream as seconds or NIL if none
156 (timeout nil
:type
(or single-float null
))
157 ;; pathname of the file this stream is opened to (returned by PATHNAME)
158 (pathname nil
:type
(or pathname null
))
159 ;; Not :DEFAULT, because we want to match CHAR-SIZE!
160 (external-format :latin-1
)
161 ;; fixed width, or function to call with a character
162 (char-size 1 :type
(or fixnum function
))
163 (replacement nil
:type
(or null character string
(simple-array (unsigned-byte 8) 1)))
164 (output-bytes #'ill-out
:type function
))
166 (defun fd-stream-bivalent-p (stream)
167 (eq (fd-stream-element-mode stream
) :bivalent
))
169 (defmethod print-object ((fd-stream fd-stream
) stream
)
170 (declare (type stream stream
))
171 (print-unreadable-object (fd-stream stream
:type t
:identity t
)
172 (format stream
"for ~S" (fd-stream-name fd-stream
))))
174 ;;; Release all of FD-STREAM's buffers. Originally the intent of this
175 ;;; was to grab a mutex once only, but the buffer pool is lock-free now.
176 (defun release-fd-stream-buffers (fd-stream)
177 (awhen (fd-stream-ibuf fd-stream
)
178 (setf (fd-stream-ibuf fd-stream
) nil
)
180 (awhen (fd-stream-obuf fd-stream
)
181 (setf (fd-stream-obuf fd-stream
) nil
)
183 (dolist (buf (fd-stream-output-queue fd-stream
))
185 (release-buffer buf
)))
186 (setf (fd-stream-output-queue fd-stream
) nil
))
188 ;;;; FORM-TRACKING-STREAM
190 ;; The compiler uses this to record for each input subform the start and
191 ;; end positions as character offsets. Measuring in characters rather than
192 ;; bytes is both better suited to the task - in that it is consistent with
193 ;; reporting of "point" by Emacs - and faster than querying FILE-POSITION.
194 ;; The slowness of FILE-POSITION on an FD-STREAM is due to making a system
195 ;; call every time, to ensure that the case of an append-only stream works
196 ;; correctly (where the OS forces all writes to the end), and other factors.
198 (defstruct (form-tracking-stream
199 (:constructor %make-form-tracking-stream
)
201 (misc #'tracking-stream-misc
)
202 (input-char-pos (- +ansi-stream-in-buffer-length
+)))
204 ;; a function which is called for events on this stream.
205 (observer (lambda (x y z
) (declare (ignore x y z
))) :type function
)
206 ;; A vector of the character position of each #\Newline seen
207 (newlines (make-array 10 :fill-pointer
0 :adjustable t
))
208 (last-newline +ansi-stream-in-buffer-length
+ :type
(integer 0 #.
+ansi-stream-in-buffer-length
+))
209 ;; Better than reporting that a reader error occurred at a position
210 ;; before any whitespace (or equivalently, a macro producing no value),
211 ;; we can note the position at the first "good" character.
212 (form-start-byte-pos)
213 (form-start-char-pos))
215 (defun line/col-from-charpos
216 (stream &optional
(charpos (form-tracking-stream-current-char-pos stream
)))
217 (track-newlines stream
)
218 (let ((newlines (form-tracking-stream-newlines stream
)))
220 (let ((index (position charpos newlines
:test
#'>= :from-end t
)))
221 ;; Line numbers traditionally begin at 1, columns at 0.
223 ;; INDEX is 1 less than the number of newlines seen
224 ;; up to and including this startpos.
225 ;; e.g. index=0 => 1 newline seen => line=2
227 ;; 1 char after the newline = column 0
228 (- charpos
(aref newlines index
) 1))
229 ;; zero newlines were seen
231 ;; No charpos means the error is before reading the first char
232 ;; e.g. an encoding error. Take the last Newline.
233 (cons (1+ (length newlines
)) 0))))
235 ;;;; CORE OUTPUT FUNCTIONS
237 ;;; Buffer the section of THING delimited by START and END by copying
238 ;;; to output buffer(s) of stream.
239 (defun buffer-output (stream thing start end
)
240 (declare (index start end
))
242 (error ":END before :START!"))
244 ;; Copy bytes from THING to buffers.
245 (flet ((copy-to-buffer (buffer tail count
)
246 (declare (buffer buffer
) (index tail count
))
248 (let ((sap (buffer-sap buffer
)))
251 (system-area-ub8-copy thing start sap tail count
))
252 ((simple-unboxed-array (*))
253 (copy-ub8-to-system-area thing start sap tail count
))))
254 ;; Not INCF! If another thread has moved tail from under
255 ;; us, we don't want to accidentally increment tail
256 ;; beyond buffer-length.
257 (setf (buffer-tail buffer
) (+ count tail
))
260 ;; First copy is special: the buffer may already contain
261 ;; something, or be even full.
262 (let* ((obuf (fd-stream-obuf stream
))
263 (tail (buffer-tail obuf
))
264 (buffer-length (buffer-length obuf
))
265 (space (- buffer-length tail
))
266 (length (- end start
)))
267 (cond ((and (not (fd-stream-serve-events stream
))
268 (>= length buffer-length
))
269 (flush-output-buffer stream
)
270 (finish-writing-sequence thing stream start end
)
271 (return-from buffer-output
))
273 (copy-to-buffer obuf tail
(min space length
))
274 (go :more-output-p
))))
276 ;; Later copies should always have an empty buffer, since
277 ;; they are freshly flushed, but if another thread is
278 ;; stomping on the same buffer that might not be the case.
279 (let* ((obuf (flush-output-buffer stream
))
280 (tail (buffer-tail obuf
))
281 (space (- (buffer-length obuf
) tail
)))
282 (copy-to-buffer obuf tail
(min space
(- end start
))))
285 (go :flush-and-fill
))))))
287 (define-symbol-macro +write-failed
+ "Couldn't write to ~S")
289 ;;; Flush the current output buffer of the stream, ensuring that the
290 ;;; new buffer is empty. Returns (for convenience) the new output
291 ;;; buffer -- which may or may not be EQ to the old one. If the is no
292 ;;; queued output we try to write the buffer immediately -- otherwise
293 ;;; we queue it for later.
294 (defun flush-output-buffer (stream)
295 (let ((obuf (fd-stream-obuf stream
)))
297 (let ((head (buffer-head obuf
))
298 (tail (buffer-tail obuf
)))
299 (cond ((eql head tail
)
300 ;; Buffer is already empty -- just ensure that is is
301 ;; set to zero as well.
303 ((fd-stream-output-queue stream
)
304 ;; There is already stuff on the queue -- go directly
307 (%queue-and-replace-output-buffer stream
))
309 ;; Try a non-blocking write, if SERVE-EVENT is allowed, queue
310 ;; whatever is left over. Otherwise wait until we can write.
312 (when (fd-stream-synchronize-output stream
)
313 (synchronize-stream-output stream
))
315 (let ((length (- tail head
)))
316 (multiple-value-bind (count errno
)
317 (sb-unix:unix-write
(fd-stream-fd stream
) (buffer-sap obuf
)
319 (flet ((queue-or-wait ()
320 (if (fd-stream-serve-events stream
)
321 (return (%queue-and-replace-output-buffer stream
))
322 (or (wait-until-fd-usable (fd-stream-fd stream
) :output
323 (fd-stream-timeout stream
)
325 (signal-timeout 'io-timeout
328 :seconds
(fd-stream-timeout stream
))))))
329 (cond ((eql count length
)
330 ;; Complete write -- we can use the same buffer.
331 (return (reset-buffer obuf
)))
333 ;; Partial write -- update buffer status and
336 (setf (buffer-head obuf
) head
)
339 ((eql errno sb-unix
:ewouldblock
)
340 ;; Blocking, queue or wair.
342 ;; if interrupted on win32, just try again
343 #+win32
((eql errno sb-unix
:eintr
))
345 (simple-stream-perror +write-failed
+
346 stream errno
)))))))))))))
348 (defun finish-writing-sequence (sequence stream start end
)
349 (when (fd-stream-synchronize-output stream
)
350 (synchronize-stream-output stream
))
352 (let ((length (- end start
)))
353 (multiple-value-bind (count errno
)
354 (sb-unix:unix-write
(fd-stream-fd stream
) sequence start length
)
356 (or (wait-until-fd-usable (fd-stream-fd stream
) :output
357 (fd-stream-timeout stream
)
359 (signal-timeout 'io-timeout
362 :seconds
(fd-stream-timeout stream
)))))
363 (cond ((eql count length
)
369 ((eql errno sb-unix
:ewouldblock
)
371 ;; if interrupted on win32, just try again
372 #+win32
((eql errno sb-unix
:eintr
))
374 (simple-stream-perror +write-failed
+
377 ;;; Helper for FLUSH-OUTPUT-BUFFER -- returns the new buffer.
378 (defun %queue-and-replace-output-buffer
(stream)
379 (aver (fd-stream-serve-events stream
))
380 (let ((queue (fd-stream-output-queue stream
))
381 (later (list (or (fd-stream-obuf stream
) (bug "Missing obuf."))))
383 ;; Important: before putting the buffer on queue, give the stream
384 ;; a new one. If we get an interrupt and unwind losing the buffer
385 ;; is relatively OK, but having the same buffer in two places
387 (setf (fd-stream-obuf stream
) new
)
391 (setf (fd-stream-output-queue stream
) later
)))
392 (unless (fd-stream-handler stream
)
393 (setf (fd-stream-handler stream
)
394 (add-fd-handler (fd-stream-fd stream
)
397 (declare (ignore fd
))
398 (write-output-from-queue stream
)))))
401 ;;; This is called by the FD-HANDLER for the stream when output is
403 (defun write-output-from-queue (stream)
404 (aver (fd-stream-serve-events stream
))
405 (when (fd-stream-synchronize-output stream
)
406 (synchronize-stream-output stream
))
410 (let* ((buffer (pop (fd-stream-output-queue stream
)))
411 (head (buffer-head buffer
))
412 (length (- (buffer-tail buffer
) head
)))
413 (declare (index head length
))
415 (multiple-value-bind (count errno
)
416 (sb-unix:unix-write
(fd-stream-fd stream
) (buffer-sap buffer
)
418 (cond ((eql count length
)
419 ;; Complete write, see if we can do another right
420 ;; away, or remove the handler if we're done.
421 (release-buffer buffer
)
422 (cond ((fd-stream-output-queue stream
)
426 (let ((handler (fd-stream-handler stream
)))
428 (setf (fd-stream-handler stream
) nil
)
429 (remove-fd-handler handler
)))))
431 ;; Partial write. Update buffer status and requeue.
432 (aver (< count length
))
433 ;; Do not use INCF! Another thread might have moved head.
434 (setf (buffer-head buffer
) (+ head count
))
435 (push buffer
(fd-stream-output-queue stream
)))
437 ;; We tried to do multiple writes, and finally our
438 ;; luck ran out. Requeue.
439 (push buffer
(fd-stream-output-queue stream
)))
441 ;; Could not write on the first try at all!
443 (simple-stream-perror +write-failed
+ stream errno
)
445 (if (= errno sb-unix
:ewouldblock
)
446 (bug "Unexpected blocking in WRITE-OUTPUT-FROM-QUEUE.")
447 (simple-stream-perror +write-failed
+
451 ;;; Try to write THING directly to STREAM without buffering, if
452 ;;; possible. If direct write doesn't happen, buffer.
453 (defun write-or-buffer-output (stream thing start end
)
454 (declare (index start end
))
455 (cond ((fd-stream-output-queue stream
)
456 (buffer-output stream thing start end
))
458 (error ":END before :START!"))
460 (let ((length (- end start
)))
461 (when (fd-stream-synchronize-output stream
)
462 (synchronize-stream-output stream
))
463 (multiple-value-bind (count errno
)
464 (sb-unix:unix-write
(fd-stream-fd stream
) thing start length
)
465 (cond ((eql count length
)
466 ;; Complete write -- done!
469 (aver (< count length
))
470 ;; Partial write -- buffer the rest.
471 (buffer-output stream thing
(+ start count
) end
))
473 ;; Could not write -- buffer or error.
475 (simple-stream-perror +write-failed
+ stream errno
)
477 (if (= errno sb-unix
:ewouldblock
)
478 (buffer-output stream thing start end
)
479 (simple-stream-perror +write-failed
+ stream errno
)))))))))
481 ;;;; output routines and related noise
483 (define-load-time-global *output-routines
* ()
484 "List of all available output routines. Each element is a list of the
485 element-type output, the kind of buffering, the function name, and the number
486 of bytes per element.")
488 (defun stream-errno-to-condition (errno)
490 (#-win32
#.sb-unix
:epipe
491 #+win32
#.sb-win32
::error-no-data
493 (t 'simple-stream-error
)))
495 ;;; common idioms for reporting low-level stream and file problems
496 (define-error-wrapper simple-stream-perror
(format-control stream
&optional errno
&rest format-arguments
)
497 (error (stream-errno-to-condition errno
)
499 :format-control
"~@<~?~@[: ~2I~_~A~]~:>"
500 :format-arguments
(list format-control
501 (list* stream format-arguments
)
502 (when errno
(strerror errno
)))))
504 (define-error-wrapper file-perror
(pathname errno
&optional datum
&rest arguments
)
505 (let ((message (when errno
(strerror errno
))))
506 (multiple-value-bind (condition-type arguments
)
509 (values 'simple-file-error
(list :format-control datum
510 :format-arguments arguments
)))
512 (values datum arguments
)))
513 (apply #'error condition-type
:pathname pathname
:message message
516 (define-error-wrapper c-string-encoding-error
(external-format code
)
517 (error 'c-string-encoding-error
518 :external-format external-format
521 (macrolet ((sap-ref-octets (sap offset count
)
523 (make-array (the fixnum
,count
) :element-type
'(unsigned-byte 8))))
524 (%byte-blt
,sap
,offset .buffer.
0 ,count
)
527 (define-error-wrapper c-string-decoding-error
(external-format sap offset count
)
528 (error 'c-string-decoding-error
529 :external-format external-format
530 :octets
(sap-ref-octets sap offset count
)))
532 ;;; Returning true goes into end of file handling, false will enter another
533 ;;; round of input buffer filling followed by re-entering character decode.
534 (defun stream-decoding-error-and-handle (stream octet-count stream-unit-count
)
535 (let ((external-format (stream-external-format stream
))
536 (replacement (fd-stream-replacement stream
)))
537 (labels ((replacement (thing resyncp
)
538 (let* ((string (decoding-replacement-stringify thing external-format
))
539 (reversed (reverse string
))
540 (instead (fd-stream-instead stream
)))
541 (dotimes (i (length reversed
))
542 (vector-push-extend (char reversed i
) instead
))
543 (when (> (length reversed
) 0)
544 (setf (fd-stream-listen stream
) t
))
549 (fd-stream-resync stream
)
552 (fd-stream-advance stream stream-unit-count
)
555 (replacement replacement nil
)
557 (error 'stream-decoding-error
558 :external-format external-format
560 :octets
(let ((buffer (fd-stream-ibuf stream
)))
561 (sap-ref-octets (buffer-sap buffer
)
565 :report
(lambda (stream)
567 "~@<Attempt to resync the stream at a ~
568 character boundary and continue.~@:>"))
570 (force-end-of-file ()
571 :report
(lambda (stream)
572 (format stream
"~@<Force an end of file.~@:>"))
573 (setf (fd-stream-eof-forced-p stream
) t
))
574 (use-value (replacement)
575 :report
(lambda (stream)
576 (format stream
"~@<Use datum as replacement input ~
578 :interactive
(lambda ()
580 "Replacement byte, bytes, character, or string (evaluated): "))
581 (replacement replacement nil
))
582 (input-replacement (thing)
583 :report
(lambda (stream)
584 (format stream
"~@<Use string as replacement input, ~
585 attempt to resync at a character ~
586 boundary and continue.~@:>"))
587 :interactive
(lambda ()
588 (format *query-io
* "~@<Enter a string: ~@:>")
589 (finish-output *query-io
*)
590 (list (read *query-io
*)))
591 (replacement thing t
)))))))
594 (defun encoding-replacement-adjust-charpos (replacement stream
)
595 (typecase replacement
596 (character (if (char= replacement
#\Newline
)
597 (setf (fd-stream-output-column stream
) 0)
598 (incf (fd-stream-output-column stream
) 1)))
599 (string (let ((newline-pos (position #\Newline replacement
:from-end t
)))
601 (setf (fd-stream-output-column stream
) (- (length replacement
) newline-pos
1))
602 (incf (fd-stream-output-column stream
) (length replacement
)))))
604 ((simple-array (unsigned-byte 8) 1))))
606 (defun stream-encoding-error-and-handle (stream code
)
607 (let ((external-format (stream-external-format stream
))
608 (replacement (fd-stream-replacement stream
)))
609 (labels ((replacement (thing)
610 (let ((octets (encoding-replacement-octetify thing external-format
)))
611 (ecase (fd-stream-buffering stream
)
612 (:full
(buffer-output stream octets
0 (length octets
)))
613 (:line
(buffer-output stream octets
0 (length octets
)))
614 (:none
(write-or-buffer-output stream octets
0 (length octets
))))
615 (encoding-replacement-adjust-charpos thing stream
))))
617 (replacement replacement
)
619 (error 'stream-encoding-error
620 :external-format external-format
624 :report
(lambda (stream)
625 (format stream
"~@<Skip output of this character.~@:>")))
626 (use-value (replacement)
627 :report
(lambda (stream)
628 (format stream
"~@<Use datum as replacement output.~@:>"))
629 :interactive
(lambda ()
631 "Replacement byte, bytes, character, or string (evaluated): "))
632 (replacement replacement
))
633 (output-replacement (string)
634 :report
(lambda (stream)
635 (format stream
"~@<Output replacement string.~@:>"))
636 :interactive
(lambda ()
637 (format *query-io
* "~@<Enter a string: ~@:>")
638 (finish-output *query-io
*)
639 (list (read *query-io
*)))
640 (let ((string (string string
)))
641 (fd-sout stream
(string string
) 0 (length string
)))))))))
643 (defun %external-format-encoding-error
(stream code
)
645 (stream-encoding-error-and-handle stream code
)
646 (c-string-encoding-error stream code
)))
648 (defmacro external-format-encoding-error
(stream code
)
649 `(return-from output-nothing
(%external-format-encoding-error
,stream
,code
)))
651 (defun synchronize-stream-output (stream)
652 ;; If we're reading and writing on the same file, flush buffered
653 ;; input and rewind file position accordingly.
654 (when (fd-stream-synchronize-output stream
)
655 (let ((adjust (nth-value 1 (flush-input-buffer stream
))))
656 (unless (eql 0 adjust
)
657 (sb-unix:unix-lseek
(fd-stream-fd stream
) (- adjust
) sb-unix
:l_incr
)))))
659 (defun fd-stream-output-finished-p (stream)
660 (let ((obuf (fd-stream-obuf stream
)))
662 (and (zerop (buffer-tail obuf
))
663 (not (fd-stream-output-queue stream
))))))
665 (defmacro output-wrapper
/variable-width
((stream size buffering restart
)
667 (let ((stream-var '#:stream
))
668 `(let* ((,stream-var
,stream
)
669 (obuf (fd-stream-obuf ,stream-var
))
670 (tail (buffer-tail obuf
))
672 ,@(unless (eq (car buffering
) :none
)
673 `((when (< (buffer-length obuf
) (+ tail size
))
674 (setf obuf
(flush-output-buffer ,stream-var
)
675 tail
(buffer-tail obuf
)))))
676 ,@(unless (eq (car buffering
) :none
)
677 ;; FIXME: Why this here? Doesn't seem necessary.
678 `((when (fd-stream-synchronize-output ,stream-var
)
679 (synchronize-stream-output ,stream-var
))))
681 `(block output-nothing
683 (setf (buffer-tail obuf
) (+ tail size
)))
686 (setf (buffer-tail obuf
) (+ tail size
))))
687 ,@(ecase (car buffering
)
688 (:none
`((flush-output-buffer ,stream-var
)))
689 (:line
`((when (eql |ch|
#\Newline
)
690 (flush-output-buffer ,stream-var
))))
693 (defmacro output-wrapper
((stream size buffering restart
) &body body
)
694 (let ((stream-var '#:stream
))
695 `(let* ((,stream-var
,stream
)
696 (obuf (fd-stream-obuf ,stream-var
))
697 (tail (buffer-tail obuf
)))
698 ,@(unless (eq (car buffering
) :none
)
699 `((when (< (buffer-length obuf
) (+ tail
,size
))
700 (setf obuf
(flush-output-buffer ,stream-var
)
701 tail
(buffer-tail obuf
)))))
702 ;; FIXME: Why this here? Doesn't seem necessary.
703 ,@(unless (eq (car buffering
) :none
)
704 `((when (fd-stream-synchronize-output ,stream-var
)
705 (synchronize-stream-output ,stream-var
))))
707 `(block output-nothing
709 (setf (buffer-tail obuf
) (+ tail
,size
)))
712 (setf (buffer-tail obuf
) (+ tail
,size
))))
713 ,@(ecase (car buffering
)
714 (:none
`((flush-output-buffer ,stream-var
)))
715 (:line
`((when (eql |ch|
#\Newline
)
716 (flush-output-buffer ,stream-var
))))
719 (defmacro def-output-routines
/variable-width
720 ((name-fmt size restart external-format
&rest bufferings
)
726 (intern (format nil name-fmt
(string (car buffering
))))))
728 `(defun ,function
(stream |ch|
)
729 (declare (optimize (sb-c:verify-arg-count
0)))
730 (output-wrapper/variable-width
(stream ,size
,buffering
,restart
)
732 ;; return char so WRITE-CHAR can tail-call the stream's output method
734 ;; FIXME: technically illegal use of quoted constant, as we keep NCONCing
735 ;; onto the tail of a literal
736 `(setf *output-routines
*
737 (nconc *output-routines
*
745 (cdr buffering
)))))))
748 ;;; Define output routines that output numbers SIZE bytes long for the
749 ;;; given bufferings. Use BODY to do the actual output.
750 (defmacro def-output-routines
((name-fmt size restart
&rest bufferings
)
756 (intern (format nil name-fmt
(string (car buffering
))))))
758 `(defun ,function
(stream byte
)
759 (declare (optimize (sb-c:verify-arg-count
0)))
760 (output-wrapper (stream ,size
,buffering
,restart
)
762 ;; return byte so WRITE-BYTE can tail-call the stream's output method
764 `(setf *output-routines
*
765 (nconc *output-routines
*
773 (cdr buffering
)))))))
776 (def-output-routines ("OUTPUT-UNSIGNED-BYTE-~A-BUFFERED"
779 (:none
(unsigned-byte 8))
780 (:full
(unsigned-byte 8)))
781 (setf (sap-ref-8 (buffer-sap obuf
) tail
)
784 (def-output-routines ("OUTPUT-SIGNED-BYTE-~A-BUFFERED"
787 (:none
(signed-byte 8))
788 (:full
(signed-byte 8)))
789 (setf (signed-sap-ref-8 (buffer-sap obuf
) tail
)
792 (def-output-routines ("OUTPUT-UNSIGNED-SHORT-~A-BUFFERED"
795 (:none
(unsigned-byte 16))
796 (:full
(unsigned-byte 16)))
797 (setf (sap-ref-16 (buffer-sap obuf
) tail
)
800 (def-output-routines ("OUTPUT-SIGNED-SHORT-~A-BUFFERED"
803 (:none
(signed-byte 16))
804 (:full
(signed-byte 16)))
805 (setf (signed-sap-ref-16 (buffer-sap obuf
) tail
)
808 (def-output-routines ("OUTPUT-UNSIGNED-LONG-~A-BUFFERED"
811 (:none
(unsigned-byte 32))
812 (:full
(unsigned-byte 32)))
813 (setf (sap-ref-32 (buffer-sap obuf
) tail
)
816 (def-output-routines ("OUTPUT-SIGNED-LONG-~A-BUFFERED"
819 (:none
(signed-byte 32))
820 (:full
(signed-byte 32)))
821 (setf (signed-sap-ref-32 (buffer-sap obuf
) tail
)
826 (def-output-routines ("OUTPUT-UNSIGNED-LONG-LONG-~A-BUFFERED"
829 (:none
(unsigned-byte 64))
830 (:full
(unsigned-byte 64)))
831 (setf (sap-ref-64 (buffer-sap obuf
) tail
)
833 (def-output-routines ("OUTPUT-SIGNED-LONG-LONG-~A-BUFFERED"
836 (:none
(signed-byte 64))
837 (:full
(signed-byte 64)))
838 (setf (signed-sap-ref-64 (buffer-sap obuf
) tail
)
841 ;;; the routine to use to output a string. If the stream is
842 ;;; unbuffered, slam the string down the file descriptor, otherwise
843 ;;; use BUFFER-OUTPUT to buffer the string. Update charpos by
844 ;;; checking to see where the last newline was.
845 (defun fd-sout (stream thing start end
)
846 (declare (type fd-stream stream
) (type string thing
))
847 (let ((start (or start
0))
848 (end (or end
(length (the vector thing
)))))
849 (declare (fixnum start end
))
851 (string-dispatch (simple-base-string
853 (simple-array character
(*))
856 (position #\newline thing
:from-end t
857 :start start
:end end
))))
858 (if (and (typep thing
'base-string
)
859 (let ((external-format (fd-stream-external-format stream
)))
860 (and (memq (external-format-keyword external-format
)
861 '(#+sb-unicode
:utf-8
:latin-1
))
862 (or (null last-newline
)
863 (eq (external-format-newline-variant external-format
) :lf
)))))
864 (ecase (fd-stream-buffering stream
)
866 (buffer-output stream thing start end
))
868 (buffer-output stream thing start end
)
870 (flush-output-buffer stream
)))
872 (write-or-buffer-output stream thing start end
)))
873 (ecase (fd-stream-buffering stream
)
874 (:full
(funcall (fd-stream-output-bytes stream
)
875 stream thing nil start end
))
876 (:line
(funcall (fd-stream-output-bytes stream
)
877 stream thing last-newline start end
))
878 (:none
(funcall (fd-stream-output-bytes stream
)
879 stream thing t start end
))))
881 (setf (fd-stream-output-column stream
) (- end last-newline
1))
882 (incf (fd-stream-output-column stream
) (- end start
))))))
884 (defstruct (external-format
885 (:constructor %make-external-format
)
887 (:predicate external-format-p
)
888 (:copier %copy-external-format
))
889 ;; All the names that can refer to this external format. The first
890 ;; one is the canonical name.
891 (names (missing-arg) :type list
:read-only t
)
892 (newline-variant (missing-arg) :type
(member :crlf
:lf
:cr
) :read-only t
)
893 (default-replacement-character (missing-arg) :type character
)
894 (replacement nil
:type
(or null character string
(unsigned-byte 8) (simple-array (unsigned-byte 8) 1)))
895 (read-n-chars-fun (missing-arg) :type function
)
896 (read-char-fun (missing-arg) :type function
)
897 (write-n-bytes-fun (missing-arg) :type function
)
898 (write-char-none-buffered-fun (missing-arg) :type function
)
899 (write-char-line-buffered-fun (missing-arg) :type function
)
900 (write-char-full-buffered-fun (missing-arg) :type function
)
901 ;; Can be nil for fixed-width formats.
902 (resync-fun nil
:type
(or function null
))
903 (bytes-for-char-fun (missing-arg) :type function
)
904 (read-c-string-fun (missing-arg) :type function
)
905 (write-c-string-fun (missing-arg) :type function
)
906 (octets-to-string-fun (missing-arg) :type function
)
907 (string-to-octets-fun (missing-arg) :type function
))
908 (declaim (freeze-type external-format
))
910 (defun ef-char-size (ef-entry)
911 (if (variable-width-external-format-p ef-entry
)
912 (bytes-for-char-fun ef-entry
)
913 (funcall (bytes-for-char-fun ef-entry
) #\x
)))
915 (defun sb-alien::string-to-c-string
(string external-format
)
916 (declare (type simple-string string
)
917 (explicit-check :result
))
919 (declare (optimize (speed 3) (safety 0)))
920 (let ((external-format (get-external-format-or-lose external-format
)))
921 (funcall (ef-write-c-string-fun external-format
) string
))))
923 (defun sb-alien::c-string-to-string
(sap external-format element-type
)
924 (declare (type system-area-pointer sap
)
925 (explicit-check :result
))
927 (declare (optimize (speed 3) (safety 0)))
928 (let ((external-format (get-external-format-or-lose external-format
)))
929 (funcall (ef-read-c-string-fun external-format
) sap element-type
))))
931 (defun get-external-format-or-lose (external-format)
932 (or (get-external-format external-format
)
933 (error "Undefined external-format: ~S" external-format
)))
935 (defun external-format-keyword (external-format)
936 (typecase external-format
937 (keyword external-format
)
938 ((cons keyword
) (car external-format
))))
940 (defun external-format-newline-variant (external-format)
941 (typecase external-format
943 ((cons keyword
) (getf (cdr external-format
) :newline
:lf
))))
945 (defun canonize-external-format (external-format entry
)
946 (typecase external-format
947 (keyword (first (ef-names entry
)))
948 ((cons keyword
) (cons (first (ef-names entry
)) (rest external-format
)))))
950 ;;; Find an output routine to use given the type and buffering. Return
951 ;;; as multiple values the routine, the real type transfered, and the
952 ;;; number of bytes per element.
953 (defun pick-output-routine (type buffering
&optional entry
)
954 (when (subtypep type
'character
)
955 (return-from pick-output-routine
956 (values (ecase buffering
957 (:none
(ef-write-char-none-buffered-fun entry
))
958 (:line
(ef-write-char-line-buffered-fun entry
))
959 (:full
(ef-write-char-full-buffered-fun entry
)))
962 (ef-write-n-bytes-fun entry
)
964 (ef-replacement entry
))))
965 (dolist (entry *output-routines
*)
966 (when (and (subtypep type
(first entry
))
967 (eq buffering
(second entry
))
969 (return-from pick-output-routine
970 (values (symbol-function (third entry
))
973 ;; KLUDGE: dealing with the buffering here leads to excessive code
976 ;; KLUDGE: also see comments in PICK-INPUT-ROUTINE
977 (loop for i from
40 by
8 to
1024 ; ARB (KLUDGE)
978 if
(subtypep type
`(unsigned-byte ,i
))
979 do
(return-from pick-output-routine
983 (lambda (stream byte
)
984 (output-wrapper (stream (/ i
8) (:none
) nil
)
985 (loop for j from
0 below
(/ i
8)
986 do
(setf (sap-ref-8 (buffer-sap obuf
)
988 (ldb (byte 8 (- i
8 (* j
8))) byte
))))))
990 (lambda (stream byte
)
991 (output-wrapper (stream (/ i
8) (:full
) nil
)
992 (loop for j from
0 below
(/ i
8)
993 do
(setf (sap-ref-8 (buffer-sap obuf
)
995 (ldb (byte 8 (- i
8 (* j
8))) byte
)))))))
998 (loop for i from
40 by
8 to
1024 ; ARB (KLUDGE)
999 if
(subtypep type
`(signed-byte ,i
))
1000 do
(return-from pick-output-routine
1004 (lambda (stream byte
)
1005 (output-wrapper (stream (/ i
8) (:none
) nil
)
1006 (loop for j from
0 below
(/ i
8)
1007 do
(setf (sap-ref-8 (buffer-sap obuf
)
1009 (ldb (byte 8 (- i
8 (* j
8))) byte
))))))
1011 (lambda (stream byte
)
1012 (output-wrapper (stream (/ i
8) (:full
) nil
)
1013 (loop for j from
0 below
(/ i
8)
1014 do
(setf (sap-ref-8 (buffer-sap obuf
)
1016 (ldb (byte 8 (- i
8 (* j
8))) byte
)))))))
1020 ;;;; input routines and related noise
1022 ;;; a list of all available input routines. Each element is a list of
1023 ;;; the element-type input, the function name, and the number of bytes
1025 (define-load-time-global *input-routines
* ())
1027 ;;; Return whether a primitive partial read operation on STREAM's FD
1028 ;;; would (probably) block. Signal a `simple-stream-error' if the
1029 ;;; system call implementing this operation fails.
1031 ;;; It is "may" instead of "would" because "would" is not quite
1032 ;;; correct on win32. However, none of the places that use it require
1033 ;;; further assurance than "may" versus "will definitely not".
1034 (defun sysread-may-block-p (stream)
1036 ;; This answers T at EOF on win32.
1037 (not (sb-win32:handle-listen
(fd-stream-fd stream
)))
1039 (not (sb-unix:unix-simple-poll
(fd-stream-fd stream
) :input
0)))
1041 ;;; If the read would block wait (using SERVE-EVENT) till input is available,
1042 ;;; then fill the input buffer, and return the number of bytes read. Throws
1043 ;;; to EOF-INPUT-CATCHER if the eof was reached.
1044 (defun refill-input-buffer (stream)
1045 (let ((fd (fd-stream-fd stream
))
1052 ;; Check for blocking input before touching the stream if we are to
1053 ;; serve events: if the FD is blocking, we don't want to try an uninterruptible
1054 ;; read(). Regular files should never block, so we can elide the check.
1055 (if (and (neq :regular
(fd-stream-fd-type stream
))
1056 (sysread-may-block-p stream
))
1057 (go :wait-for-input
)
1059 ;; These (:CLOSED-FLAME and :READ-ERROR) tags are here so what
1060 ;; we can signal errors outside the WITHOUT-INTERRUPTS.
1062 (closed-flame stream
)
1064 (simple-stream-perror "couldn't read from ~S" stream errno
)
1066 ;; This tag is here so we can unwind outside the WITHOUT-INTERRUPTS
1067 ;; to wait for input if read tells us EWOULDBLOCK.
1068 (unless (wait-until-fd-usable fd
:input
(fd-stream-timeout stream
)
1069 (fd-stream-serve-events stream
))
1070 (signal-timeout 'io-timeout
1073 :seconds
(fd-stream-timeout stream
)))
1075 ;; Since the read should not block, we'll disable the
1076 ;; interrupts here, so that we don't accidentally unwind and
1077 ;; leave the stream in an inconsistent state.
1079 ;; Execute the nlx outside without-interrupts to ensure the
1080 ;; resulting thunk is stack-allocatable.
1081 ((lambda (return-reason)
1082 (ecase return-reason
1083 ((nil)) ; fast path normal cases
1084 ((:wait-for-input
) (go #-win32
:wait-for-input
#+win32
:main
))
1085 ((:closed-flame
) (go :closed-flame
))
1086 ((:read-error
) (go :read-error
))))
1088 ;; Check the buffer: if it is null, then someone has closed
1089 ;; the stream from underneath us. This is not ment to fix
1090 ;; multithreaded races, but to deal with interrupt handlers
1091 ;; closing the stream.
1094 (let* ((ibuf (or (fd-stream-ibuf stream
) (return :closed-flame
)))
1095 (sap (buffer-sap ibuf
))
1096 (length (buffer-length ibuf
))
1097 (head (buffer-head ibuf
))
1098 (tail (buffer-tail ibuf
)))
1099 (declare (index length head tail
)
1100 (inline sb-unix
:unix-read
))
1101 (unless (zerop head
)
1102 (cond ((eql head tail
)
1103 ;; Buffer is empty, but not at yet reset -- make it so.
1106 (reset-buffer ibuf
))
1108 ;; Buffer has things in it, but they are not at the
1109 ;; head -- move them there.
1110 (let ((n (- tail head
)))
1111 (system-area-ub8-copy sap head sap
0 n
)
1113 (buffer-head ibuf
) head
1115 (buffer-tail ibuf
) tail
)))))
1116 (setf (fd-stream-listen stream
) nil
)
1117 (setf (values count errno
)
1118 (sb-unix:unix-read fd
(sap+ sap tail
) (- length tail
)))
1121 #+win32 sb-unix
:eintr
1122 #-win32 sb-unix
:ewouldblock
)
1123 (return :wait-for-input
)
1124 (return :read-error
)))
1126 (setf (fd-stream-listen stream
) :eof
)
1127 (/show0
"THROWing EOF-INPUT-CATCHER")
1128 (throw 'eof-input-catcher nil
))
1130 ;; Success! (Do not use INCF, for sake of other threads.)
1131 (setf (buffer-tail ibuf
) (+ count tail
))))))))))
1134 ;;; Make sure there are at least BYTES number of bytes in the input
1135 ;;; buffer. Keep calling REFILL-INPUT-BUFFER until that condition is met.
1136 (defmacro input-at-least
(stream bytes
)
1137 (let ((stream-var (gensym "STREAM"))
1138 (bytes-var (gensym "BYTES"))
1139 (buffer-var (gensym "IBUF")))
1140 `(let* ((,stream-var
,stream
)
1142 (,buffer-var
(fd-stream-ibuf ,stream-var
)))
1144 (when (>= (- (buffer-tail ,buffer-var
)
1145 (buffer-head ,buffer-var
))
1148 (refill-input-buffer ,stream-var
)))))
1150 (defmacro input-wrapper
/variable-width
((stream bytes eof-error eof-value
)
1152 (let ((stream-var (gensym "STREAM"))
1153 (retry-var (gensym "RETRY"))
1154 (element-var (gensym "ELT")))
1155 `(let* ((,stream-var
,stream
)
1156 (ibuf (fd-stream-ibuf ,stream-var
))
1158 (unit ,(if (consp bytes
)
1159 (let ((size-info (car bytes
)))
1160 (if (consp size-info
)
1165 (when (fd-stream-eof-forced-p ,stream-var
)
1166 (setf (fd-stream-eof-forced-p ,stream-var
) nil
)
1167 (return-from use-instead
1168 (eof-or-lose ,stream-var
,eof-error
,eof-value
)))
1169 (let ((,element-var nil
)
1170 (decode-break-reason nil
))
1171 (do ((,retry-var t
))
1173 (if (> (length (fd-stream-instead ,stream-var
)) 0)
1174 (let* ((instead (fd-stream-instead ,stream-var
))
1175 (result (vector-pop instead
))
1176 (pointer (fill-pointer instead
)))
1178 (setf (fd-stream-listen ,stream-var
) nil
))
1179 (setf (buffer-prev-head ibuf
) (buffer-head ibuf
))
1180 (return-from use-instead
(values result
0)))
1182 (catch 'eof-input-catcher
1183 (setf decode-break-reason
1184 (block decode-break-reason
1186 (let ((size-info (car bytes
)))
1187 (if (consp size-info
)
1189 (input-at-least ,stream-var
,(cadr size-info
))
1190 (catch 'eof-input-catcher
1191 (input-at-least ,stream-var
,(car size-info
))))
1192 `(input-at-least ,stream-var
,size-info
)))
1193 `(input-at-least ,stream-var
(setq size
,bytes
)))
1194 (let* ((byte (sap-ref-8 (buffer-sap ibuf
) (buffer-head ibuf
))))
1195 (declare (ignorable byte
))
1196 ,@(when (consp bytes
)
1197 `((let ((sap (buffer-sap ibuf
))
1198 (head (buffer-head ibuf
))
1199 (tail (buffer-tail ibuf
)))
1200 (declare (ignorable sap head tail
))
1201 (setq size
,(cadr bytes
))
1202 (input-at-least ,stream-var size
))))
1203 (setq ,element-var
(locally ,@read-forms
))
1204 (setq ,retry-var nil
))
1206 (when decode-break-reason
1207 (when (stream-decoding-error-and-handle
1208 stream decode-break-reason unit
)
1209 (setq ,retry-var nil
)
1210 (throw 'eof-input-catcher nil
)))
1212 (let ((octet-count (- (buffer-tail ibuf
)
1213 (buffer-head ibuf
))))
1214 (when (or (zerop octet-count
)
1215 (and (not ,element-var
)
1216 (not decode-break-reason
)
1217 (stream-decoding-error-and-handle
1218 stream octet-count unit
)))
1219 (setq ,retry-var nil
))))))
1221 (setf (buffer-prev-head ibuf
) (buffer-head ibuf
))
1222 (incf (buffer-head ibuf
) size
)
1223 (values ,element-var size
))
1225 (eof-or-lose ,stream-var
,eof-error
,eof-value
))))))))
1227 ;;; a macro to wrap around all input routines to handle EOF-ERROR noise
1228 (defmacro input-wrapper
((stream bytes eof-error eof-value
) &body read-forms
)
1229 (let ((stream-var (gensym "STREAM"))
1230 (element-var (gensym "ELT")))
1231 `(let* ((,stream-var
,stream
)
1232 (ibuf (fd-stream-ibuf ,stream-var
)))
1233 (if (> (length (fd-stream-instead ,stream-var
)) 0)
1234 (bug "INSTEAD not empty in INPUT-WRAPPER for ~S" ,stream-var
)
1236 (catch 'eof-input-catcher
1237 (input-at-least ,stream-var
,bytes
)
1238 (locally ,@read-forms
))))
1240 (incf (buffer-head (fd-stream-ibuf ,stream-var
)) ,bytes
)
1243 (eof-or-lose ,stream-var
,eof-error
,eof-value
))))))))
1245 (defmacro def-input-routine
/variable-width
(name
1246 (type external-format size sap head
)
1249 (defun ,name
(stream eof-error eof-value
)
1250 (declare (optimize (sb-c:verify-arg-count
0)))
1251 (input-wrapper/variable-width
(stream ,size eof-error eof-value
)
1252 (let ((,sap
(buffer-sap ibuf
))
1253 (,head
(buffer-head ibuf
)))
1255 (setf *input-routines
*
1256 (nconc *input-routines
*
1257 (list (list ',type
',name
1 ',external-format
))))))
1259 (defmacro def-input-routine
(name
1260 (type size sap head
)
1263 (defun ,name
(stream eof-error eof-value
)
1264 (declare (optimize (sb-c:verify-arg-count
0)))
1265 (input-wrapper (stream ,size eof-error eof-value
)
1266 (let ((,sap
(buffer-sap ibuf
))
1267 (,head
(buffer-head ibuf
)))
1269 (setf *input-routines
*
1270 (nconc *input-routines
*
1271 (list (list ',type
',name
',size nil
))))))
1273 ;;; STREAM-IN routine for reading a string char
1274 (def-input-routine input-character
1275 (character 1 sap head
)
1276 (code-char (sap-ref-8 sap head
)))
1278 ;;; STREAM-IN routine for reading an unsigned 8 bit number
1279 (def-input-routine input-unsigned-8bit-byte
1280 ((unsigned-byte 8) 1 sap head
)
1281 (sap-ref-8 sap head
))
1283 ;;; STREAM-IN routine for reading a signed 8 bit number
1284 (def-input-routine input-signed-8bit-number
1285 ((signed-byte 8) 1 sap head
)
1286 (signed-sap-ref-8 sap head
))
1288 ;;; STREAM-IN routine for reading an unsigned 16 bit number
1289 (def-input-routine input-unsigned-16bit-byte
1290 ((unsigned-byte 16) 2 sap head
)
1291 (sap-ref-16 sap head
))
1293 ;;; STREAM-IN routine for reading a signed 16 bit number
1294 (def-input-routine input-signed-16bit-byte
1295 ((signed-byte 16) 2 sap head
)
1296 (signed-sap-ref-16 sap head
))
1298 ;;; STREAM-IN routine for reading a unsigned 32 bit number
1299 (def-input-routine input-unsigned-32bit-byte
1300 ((unsigned-byte 32) 4 sap head
)
1301 (sap-ref-32 sap head
))
1303 ;;; STREAM-IN routine for reading a signed 32 bit number
1304 (def-input-routine input-signed-32bit-byte
1305 ((signed-byte 32) 4 sap head
)
1306 (signed-sap-ref-32 sap head
))
1310 (def-input-routine input-unsigned-64bit-byte
1311 ((unsigned-byte 64) 8 sap head
)
1312 (sap-ref-64 sap head
))
1313 (def-input-routine input-signed-64bit-byte
1314 ((signed-byte 64) 8 sap head
)
1315 (signed-sap-ref-64 sap head
)))
1317 ;;; Find an input routine to use given the type. Return as multiple
1318 ;;; values the routine, the real type transfered, and the number of
1319 ;;; bytes per element (and for character types string input routine).
1320 (defun pick-input-routine (type &optional entry
)
1321 (when (subtypep type
'character
)
1322 (return-from pick-input-routine
1323 (values (ef-read-char-fun entry
)
1326 (ef-read-n-chars-fun entry
)
1327 (ef-char-size entry
)
1328 (ef-replacement entry
))))
1329 (dolist (entry *input-routines
*)
1330 (when (and (subtypep type
(first entry
))
1331 (not (fourth entry
)))
1332 (return-from pick-input-routine
1333 (values (symbol-function (second entry
))
1336 ;; FIXME: let's do it the hard way, then (but ignore things like
1337 ;; endianness, efficiency, and the necessary coupling between these
1338 ;; and the output routines). -- CSR, 2004-02-09
1339 (loop for i from
40 by
8 to
1024 ; ARB (well, KLUDGE really)
1340 if
(subtypep type
`(unsigned-byte ,i
))
1341 do
(return-from pick-input-routine
1343 (lambda (stream eof-error eof-value
)
1344 (input-wrapper (stream (/ i
8) eof-error eof-value
)
1345 (let ((sap (buffer-sap ibuf
))
1346 (head (buffer-head ibuf
)))
1347 (loop for j from
0 below
(/ i
8)
1351 (sap-ref-8 sap
(+ head j
))))
1352 finally
(return result
)))))
1355 (loop for i from
40 by
8 to
1024 ; ARB (well, KLUDGE really)
1356 if
(subtypep type
`(signed-byte ,i
))
1357 do
(return-from pick-input-routine
1359 (lambda (stream eof-error eof-value
)
1360 (input-wrapper (stream (/ i
8) eof-error eof-value
)
1361 (let ((sap (buffer-sap ibuf
))
1362 (head (buffer-head ibuf
)))
1363 (loop for j from
0 below
(/ i
8)
1367 (sap-ref-8 sap
(+ head j
))))
1368 finally
(return (if (logbitp (1- i
) result
)
1369 (dpb result
(byte i
0) -
1)
1374 ;;; the N-BIN method for binary FD-STREAMs
1376 ;;; Note that this blocks in UNIX-READ. It is generally used where
1377 ;;; there is a definite amount of reading to be done, so blocking
1378 ;;; isn't too problematical.
1379 (defun fd-stream-read-n-bytes (stream buffer sbuffer start end eof-error-p
1381 (declare (type fd-stream stream
))
1382 (declare (type index start end
))
1383 (declare (ignore sbuffer
))
1384 (aver (= (length (fd-stream-instead stream
)) 0))
1385 (let* ((ibuf (fd-stream-ibuf stream
))
1386 (sap (buffer-sap ibuf
)))
1387 (cond #+soft-card-marks
; read(2) doesn't like write-protected buffers
1388 ((and (typep buffer
'(simple-array (unsigned-byte 8) (*)))
1389 (>= (- end start
) 256)
1390 (eq (fd-stream-fd-type stream
) :regular
)
1391 ;; TODO: handle non-empty initial buffers
1392 (= (buffer-head ibuf
) (buffer-tail ibuf
)))
1393 (prog ((fd (fd-stream-fd stream
))
1396 (declare ((or null index
) count
))
1399 (simple-stream-perror "couldn't read from ~S" stream errno
)
1402 (error 'end-of-file
:stream stream
)
1408 (with-pinned-objects (buffer)
1409 (let ((sap (vector-sap buffer
)))
1410 (declare (inline sb-unix
:unix-read
))
1411 (setf (fd-stream-listen stream
) nil
)
1412 (setf (values count errno
)
1413 (sb-unix:unix-read fd
(sap+ sap index
) (- end index
)))
1415 (cond #-win32
((eql errno sb-unix
:eintr
)
1420 (setf (fd-stream-listen stream
) :eof
)
1423 (setf index
(truly-the index
(+ index count
)))))
1430 (let* ((remaining-request (- end index
))
1431 (head (buffer-head ibuf
))
1432 (tail (buffer-tail ibuf
))
1433 (available (- tail head
))
1434 (n-this-copy (min remaining-request available
)))
1435 (declare (type index remaining-request head tail available
))
1436 (declare (type index n-this-copy
))
1437 ;; Copy data from stream buffer into user's buffer.
1438 (%byte-blt sap head buffer index n-this-copy
)
1439 (incf (buffer-head ibuf
) n-this-copy
)
1440 (incf index n-this-copy
)
1441 ;; Maybe we need to refill the stream buffer.
1442 (cond (;; If there were enough data in the stream buffer, we're done.
1445 (;; If EOF, we're done in another way.
1446 (null (catch 'eof-input-catcher
(refill-input-buffer stream
)))
1448 (error 'end-of-file
:stream stream
)
1450 ;; Otherwise we refilled the stream buffer, so fall
1451 ;; through into another pass of the loop.
1454 (defun fd-stream-advance (stream unit
)
1455 (let* ((buffer (fd-stream-ibuf stream
))
1456 (head (buffer-head buffer
)))
1457 (catch 'eof-input-catcher
1458 (input-at-least stream unit
)
1459 ;; OK: we have another unit
1460 (setf (buffer-prev-head buffer
) head
)
1461 (setf (buffer-head buffer
) (+ head unit
))
1462 (return-from fd-stream-advance nil
))
1463 ;; we do not have enough input: set the HEAD to TAIL and let the next caller
1465 (setf (buffer-head buffer
) (buffer-tail buffer
))
1468 (defun fd-stream-resync (stream)
1469 (let ((entry (get-external-format (fd-stream-external-format stream
))))
1471 (funcall (ef-resync-fun entry
) stream
))))
1473 (defun get-fd-stream-character-sizer (stream)
1474 (let ((entry (get-external-format (fd-stream-external-format stream
))))
1476 (ef-bytes-for-char-fun entry
))))
1478 (defun fd-stream-character-size (stream char
)
1479 (let ((sizer (get-fd-stream-character-sizer stream
)))
1480 (when sizer
(funcall sizer char
))))
1482 (defun fd-stream-string-size (stream string
)
1483 (let ((sizer (get-fd-stream-character-sizer stream
)))
1485 (loop for char across string
1486 for size
= (funcall sizer char
)
1487 when
(null size
) do
(return nil
)
1490 (defun find-external-format (external-format)
1491 (when external-format
1492 (get-external-format external-format
)))
1494 (defun variable-width-external-format-p (ef-entry)
1495 ;; TODO: I'm pretty sure this is always true
1496 (and ef-entry
(not (null (ef-resync-fun ef-entry
)))))
1498 (defun bytes-for-char-fun (ef-entry)
1499 (if ef-entry
(ef-bytes-for-char-fun ef-entry
) (constantly 1)))
1501 (defmacro define-unibyte-mapping-external-format
1502 (canonical-name (&rest other-names
) &body exceptions
)
1503 (let ((->code-name
(symbolicate canonical-name
'-
>code-mapper
))
1504 (code->-name
(symbolicate 'code-
> canonical-name
'-mapper
))
1505 (get-bytes-name (symbolicate 'get- canonical-name
'-bytes
))
1506 (string->-name
(symbolicate 'string-
> canonical-name
))
1507 (string->/cr-name
(symbolicate 'string-
> canonical-name
'/cr
))
1508 (string->/crlf-name
(symbolicate 'string-
> canonical-name
'/crlf
))
1509 (string-name (symbolicate canonical-name
'-
>string
))
1510 (->string-aref-name
(symbolicate canonical-name
'-
>string-aref
))
1511 (->string-aref
/cr-name
(symbolicate canonical-name
'-
>string
/cr-aref
))
1512 (->string-aref
/crlf-name
(symbolicate canonical-name
'-
>string
/crlf-aref
))
1513 (invalid-bytes-p (loop for
(nil code
) in exceptions thereis
(null code
))))
1515 (define-unibyte-mapper ,-
>code-name
,code-
>-name
1517 (define-unibyte-to-octets-functions ,canonical-name
,get-bytes-name
,string-
>-name
,code-
>-name
)
1518 (define-unibyte-to-string-functions ,canonical-name
,string-name
,-
>code-name
,invalid-bytes-p
)
1519 (define-unibyte-external-format-with-newline-variants ,canonical-name
,other-names
1520 (,-
>code-name
,code-
>-name
)
1521 (,-
>string-aref-name
,string-
>-name
)
1522 (,-
>string-aref
/cr-name
,string-
>/cr-name
)
1523 (,-
>string-aref
/crlf-name
,string-
>/crlf-name
)
1524 ,invalid-bytes-p
))))
1526 (defmacro define-unibyte-external-format
1527 (canonical-name (&rest other-names
)
1528 char-encodable-p out-form in-form octets-to-string-symbol string-to-octets-symbol
)
1529 `(define-external-format/variable-width
(,canonical-name
,@other-names
)
1534 ,octets-to-string-symbol
1535 ,string-to-octets-symbol
1536 :char-encodable-p
,char-encodable-p
))
1538 (defmacro define-external-format
/variable-width
1539 (external-format output-restart replacement-character
1540 out-size-expr out-expr in-size-expr in-expr
1541 octets-to-string-sym string-to-octets-sym
1542 &key base-string-direct-mapping
1543 fd-stream-read-n-characters
1544 (newline-variant :lf
)
1545 (char-encodable-p t
))
1546 (let* ((name (first external-format
))
1547 (suffix (symbolicate name
'/ newline-variant
))
1548 (out-function (symbolicate "OUTPUT-BYTES/" suffix
))
1549 (format (format nil
"OUTPUT-CHAR-~A/~A-~~A-BUFFERED" (string name
) newline-variant
))
1550 (in-function (or fd-stream-read-n-characters
1551 (symbolicate "FD-STREAM-READ-N-CHARACTERS/" suffix
)))
1552 (in-char-function (symbolicate "INPUT-CHAR/" suffix
))
1553 (resync-function (symbolicate "RESYNC/" suffix
))
1554 (size-function (symbolicate "BYTES-FOR-CHAR/" suffix
))
1555 (read-c-string-function (symbolicate "READ-FROM-C-STRING/" suffix
))
1556 (output-c-string-function (symbolicate "OUTPUT-TO-C-STRING/" suffix
))
1557 (n-buffer (gensym "BUFFER")))
1559 (defun ,size-function
(|ch|
)
1560 (declare (ignorable |ch|
)
1561 (optimize (sb-c:verify-arg-count
0)))
1562 (and ,char-encodable-p
,out-size-expr
))
1563 (defun ,out-function
(stream string flush-p start end
)
1564 (declare (optimize (sb-c:verify-arg-count
0)))
1565 (let ((start (or start
0))
1566 (end (or end
(length string
))))
1567 (declare (type index start end
))
1568 (when (fd-stream-synchronize-output stream
)
1569 (synchronize-stream-output stream
))
1570 (unless (<= 0 start end
(length string
))
1571 (sequence-bounding-indices-bad-error string start end
))
1574 (let ((obuf (fd-stream-obuf stream
)))
1575 (string-dispatch (simple-base-string
1576 #+sb-unicode
(simple-array character
(*))
1579 (let ((len (buffer-length obuf
))
1580 (sap (buffer-sap obuf
))
1582 (tail (buffer-tail obuf
)))
1583 (declare (type index tail
)
1584 ;; STRING bounds have already been checked.
1585 (optimize (safety 0)))
1586 (,@(if output-restart
1587 `(block output-nothing
)
1590 ((or (= start end
) (< (- len tail
) 4)))
1591 (let* ((|ch|
(aref string start
))
1592 (bits (char-code |ch|
))
1593 (size ,out-size-expr
))
1594 (declare (ignorable |ch| bits
))
1597 (setf (buffer-tail obuf
) tail
)
1600 ;; Exited via RETURN-FROM OUTPUT-NOTHING: skip the current character.
1604 (flush-output-buffer stream
)))
1606 (flush-output-buffer stream
))))
1607 (def-output-routines/variable-width
(,format
1614 (if (eql |ch|
#\Newline
)
1615 (setf (fd-stream-output-column stream
) 0)
1616 (setf (fd-stream-output-column stream
)
1617 (+ (truly-the unsigned-byte
(fd-stream-output-column stream
)) 1)))
1618 (let ((bits (char-code |ch|
))
1619 (sap (buffer-sap obuf
))
1620 (tail (buffer-tail obuf
)))
1622 ,@(unless fd-stream-read-n-characters
1623 `((defun ,in-function
(stream buffer sbuffer start end
&aux
(index start
))
1624 (declare (type fd-stream stream
)
1625 (type index index start end
)
1626 (type ansi-stream-cin-buffer buffer
)
1627 (type ansi-stream-csize-buffer sbuffer
)
1628 (optimize (sb-c:verify-arg-count
0)))
1629 (when (fd-stream-eof-forced-p stream
)
1630 (setf (fd-stream-eof-forced-p stream
) nil
)
1631 (return-from ,in-function index
))
1632 (do ((instead (fd-stream-instead stream
)))
1633 ((= (fill-pointer instead
) 0)
1634 (setf (fd-stream-listen stream
) nil
))
1635 (setf (aref buffer index
) (vector-pop instead
))
1636 (setf (aref sbuffer index
) 0)
1639 (when (= (fill-pointer instead
) 0)
1640 (setf (fd-stream-listen stream
) nil
))
1641 (return-from ,in-function index
)))
1642 (do (;; external formats might wish for e.g. 2 octets
1643 ;; to be available, but still be able to handle a
1644 ;; single octet before end of file. This flag
1645 ;; lets the refilling be tracked so that we know
1646 ;; if we've run out of octets and just have to
1647 ;; make do with what we've got.
1649 ;; but actually I don't think this works.
1650 ;; Consider: a file which is exactly the size of
1651 ;; the buffer, and whose last character is a CR.
1652 ;; We will get to the last character and request a
1653 ;; refill of the buffer; however, the refill will
1654 ;; throw EOF. We need something like the
1655 ;; input-at-least logic here (where we catch EOF
1656 ;; ourselves for refills between what the external
1657 ;; format can handle if there is no more, and what
1658 ;; it wants if there is more.)
1660 ;; but actually actually: it might be that
1661 ;; FAST-READ-CHAR-REFILL is doing this work for
1663 (requested-refill nil
))
1665 (let* ((ibuf (fd-stream-ibuf stream
))
1666 (head (buffer-head ibuf
))
1667 (tail (buffer-tail ibuf
))
1668 (sap (buffer-sap ibuf
))
1669 (decode-break-reason nil
)
1670 (unit ,(if (consp in-size-expr
)
1671 (let ((size-info (car in-size-expr
)))
1672 (if (consp size-info
)
1676 (declare (type index head tail
))
1677 ;; Copy data from stream buffer into user's buffer.
1678 (do ((size nil nil
))
1681 (setf decode-break-reason
1682 (block decode-break-reason
1683 ,@(when (consp in-size-expr
)
1684 (let* ((size-info (car in-size-expr
))
1685 (want (if (consp size-info
)
1686 `(if requested-refill
,(cadr size-info
) ,(car size-info
))
1688 `((when (> ,want
(- tail head
))
1689 (setf requested-refill t
)
1691 (let ((byte (sap-ref-8 sap head
)))
1692 (declare (ignorable byte
))
1693 (setf requested-refill nil
)
1694 (setq size
,(if (consp in-size-expr
) (cadr in-size-expr
) in-size-expr
))
1695 (when (> size
(- tail head
))
1697 (setf (aref buffer index
) ,in-expr
)
1698 (setf (aref sbuffer index
) size
)
1702 (setf (buffer-head ibuf
) head
)
1703 (when decode-break-reason
1704 ;; If we've already read some characters on when the invalid
1705 ;; code sequence is detected, we return immediately. The
1706 ;; handling of the error is deferred until the next call
1707 ;; (where this check will be false). This allows establishing
1708 ;; high-level handlers for decode errors (for example
1709 ;; automatically resyncing in Lisp comments).
1710 (unless (> index start
)
1711 (stream-decoding-error-and-handle stream decode-break-reason unit
))
1712 ;; we might have been given stuff to use instead, so
1713 ;; we have to return
1714 (return-from ,in-function index
)))
1715 (setf (buffer-head ibuf
) head
)
1716 ;; Maybe we need to refill the stream buffer.
1718 ;; If there was data in the stream buffer, we're done.
1720 ;; If EOF, we're also done
1721 (null (catch 'eof-input-catcher
1722 (refill-input-buffer stream
))))
1724 ;; Otherwise we refilled the stream buffer, so fall
1725 ;; through into another pass of the loop.
1727 (def-input-routine/variable-width
,in-char-function
(character
1731 (let ((byte (sap-ref-8 sap head
)))
1732 (declare (ignorable byte
))
1734 (defun ,resync-function
(stream)
1735 (declare (optimize (sb-c:verify-arg-count
0)))
1736 (let ((ibuf (fd-stream-ibuf stream
))
1738 (unit ,(if (consp in-size-expr
)
1739 (let ((size-info (car in-size-expr
)))
1740 (if (consp size-info
)
1744 (catch 'eof-input-catcher
1746 (incf (buffer-head ibuf
) unit
)
1747 ,(if (consp in-size-expr
)
1748 (let ((size-info (car in-size-expr
)))
1749 (if (consp size-info
)
1751 (input-at-least stream
,(cadr size-info
))
1752 (catch 'eof-input-catcher
1753 (input-at-least stream
,(car size-info
))))
1754 `(input-at-least stream
,size-info
)))
1755 `(input-at-least stream
(setq size
,in-size-expr
)))
1756 (unless (block decode-break-reason
1757 (let* ((sap (buffer-sap ibuf
))
1758 (head (buffer-head ibuf
))
1759 (tail (buffer-tail ibuf
))
1760 (byte (sap-ref-8 sap head
)))
1761 (declare (ignorable byte tail
))
1762 ,@(when (consp in-size-expr
)
1763 `((setq size
,(cadr in-size-expr
))
1764 (input-at-least stream size
)))
1765 (setf head
(buffer-head ibuf
))
1769 (defun ,read-c-string-function
(sap element-type
)
1770 (declare (type system-area-pointer sap
)
1771 (optimize (sb-c:verify-arg-count
0)))
1773 (declare (optimize (speed 3) (safety 0)))
1774 (let* ((stream ,name
)
1775 (size 0) (head 0) (tail (1- array-dimension-limit
)) (byte 0) (|ch| nil
)
1776 (decode-break-reason nil
)
1777 (length (dotimes (count (1- array-dimension-limit
) count
)
1778 (setf decode-break-reason
1779 (block decode-break-reason
1780 (setf byte
(sap-ref-8 sap head
)
1781 size
,(if (consp in-size-expr
)
1787 (when decode-break-reason
1788 (c-string-decoding-error
1789 ,name sap head decode-break-reason
))
1790 (when (zerop (char-code |ch|
))
1792 (string (case element-type
1794 (make-string length
:element-type
'base-char
))
1796 (make-string length
:element-type
'character
))
1798 (make-string length
:element-type element-type
)))))
1799 (declare (ignorable stream byte tail
)
1800 (type index head length tail
) ;; size
1801 (type (unsigned-byte 8) byte
)
1802 (type (or null character
) |ch|
)
1803 (type string string
))
1805 (dotimes (index length string
)
1806 (setf decode-break-reason
1807 (block decode-break-reason
1808 (setf byte
(sap-ref-8 sap head
)
1809 size
,(if (consp in-size-expr
)
1815 (when decode-break-reason
1816 (c-string-decoding-error
1817 ,name sap head decode-break-reason
))
1818 (setf (aref string index
) |ch|
)))))
1820 (defun ,output-c-string-function
(string)
1821 (declare (type simple-string string
))
1822 (cond ,@(and base-string-direct-mapping
1823 `(((simple-base-string-p string
)
1827 (declare (optimize (speed 3) (safety 0)))
1828 (block output-nothing
1829 (let* ((length (length string
))
1830 ;; wtf? why not just "LET ((bits 0))" ?
1831 (null-size (let* ((|ch|
(code-char 0))
1832 (bits (char-code |ch|
)))
1833 (declare (ignorable |ch| bits
))
1834 (the index
,out-size-expr
)))
1836 (+ (loop for i of-type index below length
1837 for |ch| of-type character
= (aref string i
)
1838 for bits
= (char-code |ch|
)
1839 sum
(the index
,out-size-expr
) of-type index
)
1842 (,n-buffer
(make-array buffer-length
1843 :element-type
'(unsigned-byte 8)))
1844 ;; For external-format-encoding-error
1846 (declare (type index length buffer-length tail
)
1848 (with-pinned-objects (,n-buffer
)
1849 (let ((sap (vector-sap ,n-buffer
)))
1850 (declare (system-area-pointer sap
))
1851 (loop for i of-type index below length
1852 for |ch| of-type character
= (aref string i
)
1853 for bits
= (char-code |ch|
)
1854 for size of-type index
= ,out-size-expr
1859 (|ch|
(code-char bits
)) ; more wtf
1861 (declare (ignorable bits |ch| size
))
1865 (register-external-format
1867 :newline-variant
,newline-variant
1868 :default-replacement-character
,replacement-character
1869 :read-n-chars-fun
#',in-function
1870 :read-char-fun
#',in-char-function
1871 :write-n-bytes-fun
#',out-function
1872 ,@(mapcan #'(lambda (buffering)
1873 (list (intern (format nil
"WRITE-CHAR-~A-BUFFERED-FUN" buffering
) :keyword
)
1874 `#',(intern (format nil format
(string buffering
)))))
1875 '(:none
:line
:full
))
1876 :resync-fun
#',resync-function
1877 :bytes-for-char-fun
#',size-function
1878 :read-c-string-fun
#',read-c-string-function
1879 :write-c-string-fun
#',output-c-string-function
1880 :octets-to-string-fun
(lambda (&rest rest
)
1881 (declare (dynamic-extent rest
))
1882 (apply ',octets-to-string-sym rest
))
1883 :string-to-octets-fun
(lambda (&rest rest
)
1884 (declare (dynamic-extent rest
))
1885 (apply ',string-to-octets-sym rest
))))))
1887 ;;;; utility functions (misc routines, etc)
1889 ;;; Fill in the various routine slots for the given type. INPUT-P and
1890 ;;; OUTPUT-P indicate what slots to fill. The buffering slot must be
1891 ;;; set prior to calling this routine.
1892 (defun set-fd-stream-routines (fd-stream element-type canonized-external-format external-format-entry
1893 input-p output-p buffer-p
1895 (let* ((target-type (case element-type
1896 (unsigned-byte '(unsigned-byte 8))
1897 (signed-byte '(signed-byte 8))
1898 (:default
'character
)
1900 (character-stream-p (subtypep target-type
'character
))
1901 (bivalent-stream-p (eq element-type
:default
))
1904 (bin-routine #'ill-bin
)
1907 (cin-routine #'ill-in
)
1910 (input-type nil
) ;calculated from bin-type/cin-type
1911 (input-size nil
) ;calculated from bin-size/cin-size
1912 (read-n-characters #'ill-in
)
1913 (bout-routine #'ill-bout
)
1916 (cout-routine #'ill-out
)
1921 (output-bytes #'ill-bout
))
1923 ;; Ensure that we have buffers in the desired direction(s) only,
1924 ;; getting new ones and dropping/resetting old ones as necessary.
1925 (let ((obuf (fd-stream-obuf fd-stream
)))
1929 (setf (fd-stream-obuf fd-stream
) (get-buffer)))
1931 (setf (fd-stream-obuf fd-stream
) nil
)
1932 (release-buffer obuf
))))
1934 (let ((ibuf (fd-stream-ibuf fd-stream
)))
1938 (setf (fd-stream-ibuf fd-stream
) (get-buffer)))
1940 (setf (fd-stream-ibuf fd-stream
) nil
)
1941 (release-buffer ibuf
))))
1943 ;; FIXME: Why only for output? Why unconditionally?
1945 (setf (fd-stream-output-column fd-stream
) 0))
1948 (flet ((no-input-routine ()
1949 (error "could not find any input routine for ~
1950 ~/sb-impl:print-type-specifier/"
1952 (when (or (not character-stream-p
) bivalent-stream-p
)
1953 (setf (values bin-routine bin-type bin-size read-n-characters
1954 char-size replacement
)
1955 (pick-input-routine (if bivalent-stream-p
'(unsigned-byte 8)
1957 external-format-entry
))
1958 (unless bin-routine
(no-input-routine)))
1959 (when character-stream-p
1960 (setf (values cin-routine cin-type cin-size read-n-characters
1961 char-size replacement
)
1962 (pick-input-routine target-type external-format-entry
))
1963 (unless cin-routine
(no-input-routine))))
1964 (setf (fd-stream-in fd-stream
) cin-routine
1965 (fd-stream-bin fd-stream
) bin-routine
)
1966 ;; character type gets preferential treatment
1967 (setf input-size
(or cin-size bin-size
))
1968 (setf input-type
(or cin-type bin-type
))
1970 (setf (fd-stream-external-format fd-stream
) canonized-external-format
1971 (fd-stream-char-size fd-stream
) char-size
1972 (fd-stream-replacement fd-stream
) replacement
))
1973 (when (= (or cin-size
1) (or bin-size
1) 1)
1974 (setf (fd-stream-n-bin fd-stream
)
1975 (if (and character-stream-p
(not bivalent-stream-p
))
1977 #'fd-stream-read-n-bytes
))
1978 ;; Sometimes turn on fast-read-char/fast-read-byte. Switch on
1979 ;; for character and (unsigned-byte 8) streams. In these
1980 ;; cases, fast-read-* will read from the
1981 ;; ansi-stream-(c)in-buffer, saving function calls.
1982 ;; Otherwise, the various data-reading functions in the stream
1983 ;; structure will be called.
1985 (not bivalent-stream-p
)
1986 ;; temporary disable on :io streams
1988 (cond (character-stream-p
1989 (setf (ansi-stream-cin-buffer fd-stream
)
1990 (make-array +ansi-stream-in-buffer-length
+
1991 :element-type
'character
))
1992 (setf (ansi-stream-csize-buffer fd-stream
)
1993 (make-array +ansi-stream-in-buffer-length
+
1994 :element-type
'(unsigned-byte 8))))
1995 ((equal target-type
'(unsigned-byte 8))
1996 (setf (ansi-stream-in-buffer fd-stream
)
1997 (make-array +ansi-stream-in-buffer-length
+
1998 :element-type
'(unsigned-byte 8))))))))
2001 (when (or (not character-stream-p
) bivalent-stream-p
)
2002 (setf (values bout-routine bout-type bout-size output-bytes
2003 char-size replacement
)
2004 (let ((buffering (fd-stream-buffering fd-stream
)))
2005 (if bivalent-stream-p
2006 (pick-output-routine '(unsigned-byte 8)
2007 (if (eq :line buffering
)
2010 (pick-output-routine target-type buffering external-format-entry
))))
2011 (unless bout-routine
2012 (error "could not find any output routine for ~S buffered ~S"
2013 (fd-stream-buffering fd-stream
)
2015 (when character-stream-p
2016 (setf (values cout-routine cout-type cout-size output-bytes
2017 char-size replacement
)
2018 (pick-output-routine target-type
2019 (fd-stream-buffering fd-stream
)
2020 external-format-entry
))
2021 (unless cout-routine
2022 (error "could not find any output routine for ~S buffered ~S"
2023 (fd-stream-buffering fd-stream
)
2026 (setf (fd-stream-external-format fd-stream
) canonized-external-format
2027 (fd-stream-replacement fd-stream
) replacement
2028 (fd-stream-char-size fd-stream
) char-size
))
2029 (when character-stream-p
2030 (setf (fd-stream-output-bytes fd-stream
) output-bytes
))
2031 (setf (fd-stream-cout fd-stream
) cout-routine
2032 (fd-stream-bout fd-stream
) bout-routine
2033 (fd-stream-sout fd-stream
) (if (eql cout-size
1)
2034 #'fd-sout
#'ill-out
))
2035 (setf output-size
(or cout-size bout-size
))
2036 (setf output-type
(or cout-type bout-type
))
2038 (not dual-channel-p
))
2039 (setf (fd-stream-synchronize-output fd-stream
) t
)))
2041 (when (and input-size output-size
2042 (not (eq input-size output-size
)))
2043 (error "Element sizes for input (~S:~S) and output (~S:~S) differ?"
2044 input-type input-size
2045 output-type output-size
))
2046 (setf (fd-stream-element-size fd-stream
)
2047 (or input-size output-size
))
2049 (setf (fd-stream-element-type fd-stream
)
2050 (cond ((equal input-type output-type
)
2056 ((subtypep input-type output-type
)
2058 ((subtypep output-type input-type
)
2061 (error "Input type (~/sb-impl:print-type-specifier/) and ~
2062 output type (~/sb-impl:print-type-specifier/) ~
2064 input-type output-type
))))))
2066 ;;; Handles the resource-release aspects of stream closing, and marks
2068 (defun release-fd-stream-resources (fd-stream)
2071 ;; Drop handlers first.
2072 (when (fd-stream-handler fd-stream
)
2073 (remove-fd-handler (fd-stream-handler fd-stream
))
2074 (setf (fd-stream-handler fd-stream
) nil
))
2075 ;; Disable interrupts so that a asynch unwind will not leave
2076 ;; us with a dangling finalizer (that would close the same
2077 ;; --possibly reassigned-- FD again), or a stream with a closed
2078 ;; FD that appears open.
2079 (cancel-finalization fd-stream
)
2080 (let ((fd (fd-stream-fd fd-stream
)))
2081 (when (and (/= fd -
1)
2082 (eq (cas (fd-stream-fd fd-stream
) fd -
1) fd
))
2083 (sb-unix:unix-close fd
)))
2084 (set-closed-flame fd-stream
))
2085 ;; On error unwind from WITHOUT-INTERRUPTS.
2086 (serious-condition (e)
2088 ;; Release all buffers. If this is undone, or interrupted,
2089 ;; we're still safe: buffers have finalizers of their own.
2090 (release-fd-stream-buffers fd-stream
))
2092 ;;; Flushes the current input buffer and any supplied replacements,
2093 ;;; and returns the input buffer, and the amount of flushed input in
2095 (defun flush-input-buffer (stream)
2096 (let* ((instead (fd-stream-instead stream
))
2097 (unread (length instead
)))
2098 ;; (setf fill-pointer) performs some checks and is slower
2099 (setf (%array-fill-pointer instead
) 0)
2100 (let ((ibuf (fd-stream-ibuf stream
)))
2102 (let ((head (buffer-head ibuf
))
2103 (tail (buffer-tail ibuf
)))
2104 (values (reset-buffer ibuf
) (- (+ unread tail
) head
)))
2105 (values nil unread
)))))
2107 (defun fd-stream-clear-input (stream)
2108 (flush-input-buffer stream
)
2111 (sb-win32:handle-clear-input
(fd-stream-fd stream
))
2112 (setf (fd-stream-listen stream
) nil
))
2114 (catch 'eof-input-catcher
2115 (loop until
(sysread-may-block-p stream
)
2117 (refill-input-buffer stream
)
2118 (reset-buffer (fd-stream-ibuf stream
)))
2121 ;;; Handle miscellaneous operations on FD-STREAM.
2122 (defun fd-stream-misc-routine (fd-stream operation arg1
)
2123 (stream-misc-case (operation :default nil
)
2125 (labels ((do-listen ()
2126 (let ((ibuf (fd-stream-ibuf fd-stream
)))
2127 (or (not (eql (buffer-head ibuf
) (buffer-tail ibuf
)))
2128 (fd-stream-listen fd-stream
)
2129 ;; If the read can block, LISTEN will certainly return NIL.
2130 (if (sysread-may-block-p fd-stream
)
2132 ;; Otherwise select(2) and CL:LISTEN have slightly
2133 ;; different semantics. The former returns that an FD
2134 ;; is readable when a read operation wouldn't block.
2135 ;; That includes EOF. However, LISTEN must return NIL
2137 (progn (catch 'eof-input-catcher
2138 ;; r-b/f too calls select, but it shouldn't
2139 ;; block as long as read can return once w/o
2141 (refill-input-buffer fd-stream
))
2142 ;; At this point either IBUF-HEAD != IBUF-TAIL
2143 ;; and FD-STREAM-LISTEN is NIL, in which case
2144 ;; we should return T, or IBUF-HEAD ==
2145 ;; IBUF-TAIL and FD-STREAM-LISTEN is :EOF, in
2146 ;; which case we should return :EOF for this
2147 ;; call and all future LISTEN call on this stream.
2148 ;; Call ourselves again to determine which case
2153 (let* ((ibuf (fd-stream-ibuf fd-stream
))
2154 (head (buffer-head ibuf
))
2155 (prev (buffer-prev-head ibuf
)))
2157 ;; we are unreading a character which we previously pulled
2158 ;; from INSTEAD; push it back there.
2159 (vector-push-extend arg1
(fd-stream-instead fd-stream
))
2160 ;; reset the buffer position to where it was before we read
2161 ;; the previous character.
2162 (setf (buffer-head ibuf
) (buffer-prev-head ibuf
)))))
2164 ;; Drop input buffers
2165 (setf (ansi-stream-in-index fd-stream
) +ansi-stream-in-buffer-length
+
2166 (ansi-stream-cin-buffer fd-stream
) nil
2167 (ansi-stream-csize-buffer fd-stream
) nil
2168 (ansi-stream-in-buffer fd-stream
) nil
)
2170 ;; We got us an abort on our hands.
2171 (let ((outputp (fd-stream-obuf fd-stream
))
2172 (file (fd-stream-file fd-stream
))
2173 (orig (fd-stream-original fd-stream
)))
2174 ;; This takes care of the important stuff -- everything
2175 ;; rest is cleaning up the file-system, which we cannot
2176 ;; do on some platforms as long as the file is open.
2177 (release-fd-stream-resources fd-stream
)
2178 ;; We can't do anything unless we know what file were
2179 ;; dealing with, and we don't want to do anything
2180 ;; strange unless we were writing to the file.
2181 (when (and outputp file
)
2183 ;; If the original is EQ to file we are appending to
2184 ;; and can just close the file without renaming.
2185 (unless (eq orig file
)
2186 ;; We have a handle on the original, just revert.
2187 (multiple-value-bind (okay err
)
2188 (sb-unix:unix-rename orig file
)
2189 ;; FIXME: Why is this a SIMPLE-STREAM-ERROR, and the
2190 ;; others are SIMPLE-FILE-ERRORS? Surely they should
2193 (simple-stream-perror
2194 "~@<Couldn't restore ~S to its original ~
2195 contents from ~S while closing ~S~:>"
2197 file orig fd-stream
))))
2198 ;; We can't restore the original, and aren't
2199 ;; appending, so nuke that puppy.
2201 ;; FIXME: This is currently the fate of superseded
2202 ;; files, and according to the CLOSE spec this is
2203 ;; wrong. However, there seems to be no clean way to
2204 ;; do that that doesn't involve either copying the
2205 ;; data (bad if the :abort resulted from a full
2206 ;; disk), or renaming the old file temporarily
2207 ;; (probably bad because stream opening becomes more
2209 (multiple-value-bind (okay err
)
2210 (sb-unix:unix-unlink file
)
2214 "~@<Couldn't remove ~S while closing ~S~:>" file fd-stream
)))))))
2216 (finish-fd-stream-output fd-stream
)
2217 (let ((orig (fd-stream-original fd-stream
)))
2218 (when (and orig
(fd-stream-delete-original fd-stream
))
2219 (multiple-value-bind (okay err
) (sb-unix:unix-unlink orig
)
2223 "~@<Couldn't delete ~S while closing ~S~:>" orig fd-stream
)))))
2224 ;; In case of no-abort close, don't *really* close the
2225 ;; stream until the last moment -- the cleaning up of the
2226 ;; original can be done first.
2227 (release-fd-stream-resources fd-stream
))))
2229 (fd-stream-clear-input fd-stream
))
2231 (flush-output-buffer fd-stream
))
2233 (finish-fd-stream-output fd-stream
))
2235 (fd-stream-element-type fd-stream
))
2237 (fd-stream-element-mode fd-stream
))
2239 (fd-stream-external-format fd-stream
))
2241 (plusp (the (integer 0)
2242 (sb-unix:unix-isatty
(fd-stream-fd fd-stream
)))))
2246 (fd-stream-output-column fd-stream
))
2248 (unless (fd-stream-file fd-stream
)
2249 ;; This is a TYPE-ERROR because ANSI's species FILE-LENGTH
2250 ;; "should signal an error of type TYPE-ERROR if stream is not
2251 ;; a stream associated with a file". Too bad there's no very
2252 ;; appropriate value for the EXPECTED-TYPE slot..
2253 (error 'simple-type-error
2255 :expected-type
'fd-stream
2256 :format-control
"~S is not a stream associated with a file."
2257 :format-arguments
(list fd-stream
)))
2259 (multiple-value-bind (okay dev ino mode nlink uid gid rdev size
2260 atime mtime ctime blksize blocks
)
2261 (sb-unix:unix-fstat
(fd-stream-fd fd-stream
))
2262 (declare (ignore ino nlink uid gid rdev
2263 atime mtime ctime blksize blocks
))
2265 (simple-stream-perror "failed Unix fstat(2) on ~S" fd-stream dev
))
2268 (truncate size
(fd-stream-element-size fd-stream
))))
2270 (let* ((handle (fd-stream-fd fd-stream
))
2271 (element-size (fd-stream-element-size fd-stream
)))
2272 (multiple-value-bind (got native-size
)
2273 (sb-win32:get-file-size-ex handle
0)
2275 ;; Might be a block device, in which case we fall back to
2276 ;; a non-atomic workaround:
2277 (let* ((here (sb-unix:unix-lseek handle
0 sb-unix
:l_incr
))
2278 (there (sb-unix:unix-lseek handle
0 sb-unix
:l_xtnd
)))
2279 (when (and here there
)
2280 (sb-unix:unix-lseek handle here sb-unix
:l_set
)
2281 (truncate there element-size
)))
2282 (truncate native-size element-size
)))))
2283 (:file-string-length
2285 (character (fd-stream-character-size fd-stream arg1
))
2286 (string (fd-stream-string-size fd-stream arg1
))))
2287 (:get-file-position
(fd-stream-get-file-position fd-stream
))
2288 (:set-file-position
(fd-stream-set-file-position fd-stream arg1
))))
2290 ;; FIXME: Think about this.
2292 ;; (defun finish-fd-stream-output (fd-stream)
2293 ;; (let ((timeout (fd-stream-timeout fd-stream)))
2294 ;; (loop while (fd-stream-output-queue fd-stream)
2295 ;; ;; FIXME: SIGINT while waiting for a timeout will
2296 ;; ;; cause a timeout here.
2297 ;; do (when (and (not (serve-event timeout)) timeout)
2298 ;; (signal-timeout 'io-timeout
2299 ;; :stream fd-stream
2300 ;; :direction :write
2301 ;; :seconds timeout)))))
2303 (defun finish-fd-stream-output (stream)
2304 (flush-output-buffer stream
)
2306 ((null (fd-stream-output-queue stream
)))
2307 (aver (fd-stream-serve-events stream
))
2308 (serve-all-events)))
2310 (defun fd-stream-get-file-position (stream)
2311 (declare (fd-stream stream
))
2313 (let ((posn (sb-unix:unix-lseek
(fd-stream-fd stream
) 0 sb-unix
:l_incr
)))
2314 (declare (type (or (alien sb-unix
:unix-offset
) null
) posn
))
2315 ;; We used to return NIL for errno==ESPIPE, and signal an error
2316 ;; in other failure cases. However, CLHS says to return NIL if
2317 ;; the position cannot be determined -- so that's what we do.
2318 (when (integerp posn
)
2319 ;; Adjust for buffered output: If there is any output
2320 ;; buffered, the *real* file position will be larger
2321 ;; than reported by lseek() because lseek() obviously
2322 ;; cannot take into account output we have not sent
2324 (dolist (buffer (fd-stream-output-queue stream
))
2325 (incf posn
(- (buffer-tail buffer
) (buffer-head buffer
))))
2326 (let ((obuf (fd-stream-obuf stream
)))
2328 (incf posn
(buffer-tail obuf
))))
2329 ;; Adjust for unread input: If there is any input
2330 ;; read from UNIX but not supplied to the user of the
2331 ;; stream, the *real* file position will smaller than
2332 ;; reported, because we want to look like the unread
2333 ;; stuff is still available.
2334 (let ((ibuf (fd-stream-ibuf stream
)))
2336 (decf posn
(- (buffer-tail ibuf
) (buffer-head ibuf
)))))
2337 ;; Divide bytes by element size.
2338 (truncate posn
(fd-stream-element-size stream
))))))
2340 (defun fd-stream-set-file-position (stream position-spec
)
2341 (declare (fd-stream stream
))
2342 (check-type position-spec
2343 (or (alien sb-unix
:unix-offset
) (member nil
:start
:end
))
2344 "valid file position designator")
2347 ;; Make sure we don't have any output pending, because if we
2348 ;; move the file pointer before writing this stuff, it will be
2349 ;; written in the wrong location.
2350 (finish-fd-stream-output stream
)
2351 ;; Disable interrupts so that interrupt handlers doing output
2354 (unless (fd-stream-output-finished-p stream
)
2355 ;; We got interrupted and more output came our way during
2356 ;; the interrupt. Wrapping the FINISH-FD-STREAM-OUTPUT in
2357 ;; WITHOUT-INTERRUPTS gets nasty as it can signal errors,
2358 ;; so we prefer to do things like this...
2360 ;; Clear out any pending input to force the next read to go to
2362 (flush-input-buffer stream
)
2363 ;; Trash cached value for listen, so that we check next time.
2364 (setf (fd-stream-listen stream
) nil
)
2366 (multiple-value-bind (offset origin
)
2369 (values 0 sb-unix
:l_set
))
2371 (values 0 sb-unix
:l_xtnd
))
2373 (values (* position-spec
(fd-stream-element-size stream
))
2375 (declare (type (alien sb-unix
:unix-offset
) offset
))
2376 (let ((posn (sb-unix:unix-lseek
(fd-stream-fd stream
)
2378 ;; CLHS says to return true if the file-position was set
2379 ;; successfully, and NIL otherwise. We are to signal an error
2380 ;; only if the given position was out of bounds, and that is
2381 ;; dealt with above. In times past we used to return NIL for
2382 ;; errno==ESPIPE, and signal an error in other cases.
2384 ;; FIXME: We are still liable to signal an error if flushing
2386 (return-from fd-stream-set-file-position
2387 (typep posn
'(alien sb-unix
:unix-offset
))))))))
2390 ;;;; creation routines (MAKE-FD-STREAM and OPEN)
2392 ;;; Create a stream for the given Unix file descriptor.
2394 ;;; If INPUT is non-NIL, allow input operations. If OUTPUT is non-nil,
2395 ;;; allow output operations. If neither INPUT nor OUTPUT is specified,
2396 ;;; default to allowing input.
2398 ;;; ELEMENT-TYPE indicates the element type to use (as for OPEN).
2400 ;;; BUFFERING indicates the kind of buffering to use.
2402 ;;; TIMEOUT (if true) is the number of seconds to wait for input. If
2403 ;;; NIL (the default), then wait forever. When we time out, we signal
2406 ;;; FILE is the name of the file (will be returned by PATHNAME).
2408 ;;; NAME is used to identify the stream when printed.
2410 ;;; If SERVE-EVENTS is true, SERVE-EVENT machinery is used to
2411 ;;; handle blocking IO on the stream.
2412 (defun make-fd-stream (fd
2416 (output nil output-p
)
2417 (element-type 'base-char
)
2419 (external-format :default
)
2429 (format nil
"file ~A" file
)
2430 (format nil
"descriptor ~W" fd
)))
2432 (declare (type index fd
) (type (or real null
) timeout
)
2433 (type (member :none
:line
:full
) buffering
))
2434 ;; OPEN ensures that the external-format argument is OK before
2435 ;; creating an FD and calling here. MAKE-FD-STREAM isn't really
2436 ;; part of a public interface but has numerous callers with an
2437 ;; :EXTERNAL-FORMAT argument, so we need to repeat the check and
2438 ;; canonization here, but if we detect a problem we must make sure
2440 (let* ((defaulted-external-format (if (eql external-format
:default
)
2441 (default-external-format)
2443 (external-format-entry (get-external-format defaulted-external-format
))
2444 (canonized-external-format
2445 (and external-format-entry
(canonize-external-format defaulted-external-format external-format-entry
))))
2446 (unless external-format-entry
2448 (error "Undefined external-format: ~S" external-format
)
2449 (sb-unix:unix-close fd
)))
2451 (cond ((not (or input-p output-p
))
2453 ((not (or input output
))
2455 (error "File descriptor must be opened either for input or output.")
2456 (sb-unix:unix-close fd
))))
2457 (let* ((constructor (ecase class
2458 (fd-stream '%make-fd-stream
)
2459 (form-tracking-stream '%make-form-tracking-stream
)))
2460 (element-mode (stream-element-type-stream-element-mode element-type
))
2461 (stream (funcall constructor
2464 #-win32
(sb-unix:fd-type fd
)
2466 #+win32
(if serve-events
2472 :delete-original delete-original
2474 :buffering buffering
2475 :element-mode element-mode
2476 :serve-events serve-events
2479 (coerce timeout
'single-float
)
2481 (set-fd-stream-routines stream element-type canonized-external-format external-format-entry
2482 input output input-buffer-p dual-channel-p
)
2486 (sb-unix:unix-close fd
)
2488 (format *terminal-io
* "** closed file descriptor ~W **~%"
2493 ;;; Pick a name to use for the backup file for the :IF-EXISTS
2494 ;;; :RENAME-AND-DELETE and :RENAME options.
2495 (defun pick-backup-name (name)
2496 (declare (type simple-string name
))
2497 (concatenate 'simple-string name
".bak"))
2499 ;;; Rename NAMESTRING to ORIGINAL. First, check whether we have write
2500 ;;; access, since we don't want to trash unwritable files even if we
2501 ;;; technically can. We return true if we succeed in renaming.
2502 (defun rename-the-old-one (namestring original
)
2503 (unless (sb-unix:unix-access namestring sb-unix
:w_ok
)
2504 (error "~@<The file ~2I~_~S ~I~_is not writable.~:>" namestring
))
2505 (multiple-value-bind (okay err
) (sb-unix:unix-rename namestring original
)
2510 "~@<couldn't rename ~2I~_~S ~I~_to ~2I~_~S~:>" namestring original
))))
2512 #+unix
(defun file-exists-p (path) (sb-unix:unix-access path sb-unix
:f_ok
))
2514 (defun %open-error
(pathname errno if-exists if-does-not-exist
)
2515 (flet ((signal-it (&rest arguments
)
2516 (apply #'file-perror pathname errno arguments
)))
2519 (#-win32
#.sb-unix
:enoent
2520 #+win32
#.sb-win32
::error_file_not_found
2521 (case if-does-not-exist
2524 (signal-it 'file-does-not-exist
)
2526 :report
"Reopen with :if-does-not-exist :create"
2527 '(:new-if-does-not-exist
:create
))))
2529 (sb-kernel::%file-error
2531 "~@<The path ~2I~_~S ~I~_does not exist.~:>" pathname
))
2533 (#-win32
#.sb-unix
:eexist
2534 #+win32
#.sb-win32
::error_file_exists
2535 (if (null if-exists
)
2538 (signal-it 'file-exists
)
2540 :report
"Reopen with :if-exists :supersede"
2541 '(:new-if-exists
:supersede
))
2543 :report
"Reopen with :if-exists :overwrite"
2544 '(:new-if-exists
:overwrite
))
2546 :report
"Reopen with :if-exists :rename"
2547 '(:new-if-exists
:rename
))
2549 :report
"Reopen with :if-exists :append"
2550 '(:new-if-exists
:append
)))))
2552 (signal-it "Error opening ~S" pathname
)))
2554 :report
"Retry opening."
2557 :report
"Try opening a different file."
2558 :interactive read-evaluated-form
2559 (list :new-filename
(the pathname-designator value
))))))
2561 (defun open (filename
2564 (element-type 'character
)
2565 (if-exists nil if-exists-given
)
2566 (if-does-not-exist nil if-does-not-exist-given
)
2567 (external-format :default
)
2568 ;; private options - use at your own risk
2573 ;; Squelch assignment warning.
2575 (direction direction
)
2576 (if-does-not-exist if-does-not-exist
)
2577 (if-exists if-exists
))
2578 "Return a stream which reads from or writes to FILENAME.
2580 :DIRECTION - one of :INPUT, :OUTPUT, :IO, or :PROBE
2581 :ELEMENT-TYPE - the type of object to read or write, default BASE-CHAR
2582 :IF-EXISTS - one of :ERROR, :NEW-VERSION, :RENAME, :RENAME-AND-DELETE,
2583 :OVERWRITE, :APPEND, :SUPERSEDE or NIL
2584 :IF-DOES-NOT-EXIST - one of :ERROR, :CREATE or NIL
2585 See the manual for details."
2586 (let* ((defaulted-external-format (if (eql external-format
:default
)
2587 (default-external-format)
2589 (external-format-entry (get-external-format defaulted-external-format
))
2590 (canonized-external-format
2591 (and external-format-entry
(canonize-external-format defaulted-external-format external-format-entry
))))
2592 (unless external-format-entry
2593 (error "Undefined external-format: ~S" external-format
))
2594 ;; Calculate useful stuff.
2596 (multiple-value-bind (input output mask
)
2598 (:input
(values t nil sb-unix
:o_rdonly
))
2599 (:output
(values nil t sb-unix
:o_wronly
))
2600 (:io
(values t t sb-unix
:o_rdwr
))
2601 (:probe
(values t nil sb-unix
:o_rdonly
)))
2602 (declare (type index mask
))
2603 (let* (;; PATHNAME is the pathname we associate with the stream.
2604 (pathname (merge-pathnames filename
))
2605 (physical (native-namestring (physicalize-pathname pathname
) :as-file t
))
2606 ;; One call to access() is reasonable. 40 calls to lstat() is not.
2607 ;; So DO NOT CALL TRUENAME HERE.
2608 (existsp (file-exists-p physical
))
2609 ;; Leave NAMESTRING as NIL if nonexistent and not creating a file.
2610 (namestring (when (or existsp
2612 (and input
(eq if-does-not-exist
:create
))
2613 (and (eq direction
:io
)
2614 (not if-does-not-exist-given
))))
2616 ;; Process if-exists argument if we are doing any output.
2618 (unless if-exists-given
2620 (if (eq (pathname-version pathname
) :newest
)
2624 ((:new-version
:error nil
)
2625 (setf mask
(logior mask sb-unix
:o_excl
)))
2626 ((:rename
:rename-and-delete
)
2627 (setf mask
(logior mask sb-unix
:o_creat
)))
2629 (setf mask
(logior mask sb-unix
:o_trunc
)))
2631 (setf mask
(logior mask sb-unix
:o_append
)))))
2633 (setf if-exists
:ignore-this-arg
)))
2635 (unless if-does-not-exist-given
2636 (setf if-does-not-exist
2637 (cond ((eq direction
:input
) :error
)
2639 (member if-exists
'(:overwrite
:append
)))
2641 ((eq direction
:probe
)
2645 (cond ((and existsp if-exists-given
(eq if-exists
:new-version
))
2646 (sb-kernel::%file-error
2647 pathname
"OPEN :IF-EXISTS :NEW-VERSION is not supported ~
2648 when a new version must be created."))
2649 ((eq if-does-not-exist
:create
)
2650 (setf mask
(logior mask sb-unix
:o_creat
)))
2651 ((not (member if-exists
'(:error nil
))))
2652 ;; Both if-does-not-exist and if-exists now imply
2653 ;; that there will be no opening of files, and either
2654 ;; an error would be signalled, or NIL returned
2655 ((and (not if-exists
) (not if-does-not-exist
))
2657 ((and if-exists if-does-not-exist
)
2658 (sb-kernel::%file-error
2659 pathname
"OPEN :IF-DOES-NOT-EXIST ~s ~
2660 :IF-EXISTS ~s will always signal an error."
2661 if-does-not-exist if-exists
))
2664 (sb-kernel::%file-error pathname
'file-exists
)
2667 (sb-kernel::%file-error pathname
'file-does-not-exist
))
2670 (let ((original (case if-exists
2671 ((:rename
:rename-and-delete
)
2672 (pick-backup-name namestring
))
2673 ((:append
:overwrite
)
2674 ;; KLUDGE: Prevent CLOSE from deleting
2675 ;; appending streams when called with :ABORT T
2677 (delete-original (eq if-exists
:rename-and-delete
))
2679 (when (and original
(not (eq original namestring
)))
2680 ;; We are doing a :RENAME or :RENAME-AND-DELETE. Determine
2681 ;; whether the file already exists, make sure the original
2682 ;; file is not a directory, and keep the mode.
2685 (multiple-value-bind (okay err
/dev inode orig-mode
)
2686 (sb-unix:unix-stat namestring
)
2687 (declare (ignore inode
)
2688 (type (or index null
) orig-mode
))
2691 (when (and output
(= (logand orig-mode
#o170000
)
2695 "Can't open ~S for output: is a directory"
2697 (setf mode
(logand orig-mode
#o777
))
2699 ((eql err
/dev sb-unix
:enoent
)
2702 (file-perror namestring err
/dev
2703 "Can't find ~S" namestring
)))))))
2705 (rename-the-old-one namestring original
))
2707 (setf delete-original nil
)
2708 ;; In order to use :SUPERSEDE instead, we have to make
2709 ;; sure SB-UNIX:O_CREAT corresponds to
2710 ;; IF-DOES-NOT-EXIST. SB-UNIX:O_CREAT was set before
2711 ;; because of IF-EXISTS being :RENAME.
2712 (unless (eq if-does-not-exist
:create
)
2714 (logior (logandc2 mask sb-unix
:o_creat
)
2716 (setf if-exists
:supersede
))))
2718 ;; Now we can try the actual Unix open(2).
2719 (multiple-value-bind (fd errno
)
2721 (sb-unix:unix-open namestring mask mode
2722 #+win32
:overlapped
#+win32 overlapped
)
2723 (values nil
#-win32 sb-unix
:enoent
2724 #+win32 sb-win32
::error_file_not_found
))
2726 (return (case direction
2727 ((:input
:output
:io
)
2728 ;; For O_APPEND opened files, lseek returns 0 until first write.
2729 ;; So we jump ahead here.
2730 (when (eq if-exists
:append
)
2731 (sb-unix:unix-lseek fd
0 sb-unix
:l_xtnd
))
2736 :element-type element-type
2737 :external-format canonized-external-format
2740 :delete-original delete-original
2748 (%make-fd-stream
:name namestring
2751 :element-type element-type
)))
2754 (destructuring-bind (&key return
2757 new-if-does-not-exist
)
2758 (%open-error pathname errno if-exists if-does-not-exist
)
2762 (setf filename new-filename
))
2764 (setf if-exists new-if-exists if-exists-given t
))
2765 (when new-if-does-not-exist
2766 (setf if-does-not-exist new-if-does-not-exist
2767 if-does-not-exist-given t
))))))))))
2770 ;;; the Unix way to beep
2771 (defun beep (stream)
2772 (write-char (code-char bell-char-code
) stream
)
2773 (finish-output stream
))
2775 ;;; This is kind of like FILE-POSITION, but is an internal hack used
2776 ;;; by the filesys stuff to get and set the file name.
2778 ;;; FIXME: misleading name, screwy interface
2779 (defun file-name (stream &optional new-name
)
2780 (stream-api-dispatch (stream)
2783 (when (typep stream
'fd-stream
)
2785 (setf (fd-stream-pathname stream
) new-name
)
2786 (setf (fd-stream-file stream
)
2787 (native-namestring (physicalize-pathname new-name
)
2791 (fd-stream-pathname stream
))))
2792 :simple
(s-%file-name stream new-name
)))
2794 (defun track-newlines (stream &optional
(end (ansi-stream-in-index stream
)))
2795 (do ((start (form-tracking-stream-input-char-pos stream
))
2796 (chars (or (ansi-stream-cin-buffer stream
)
2797 (return-from track-newlines
)))
2798 (i (form-tracking-stream-last-newline stream
) (1+ i
)))
2800 (setf (form-tracking-stream-last-newline stream
) i
))
2801 (let ((char (aref chars i
)))
2802 (when (eql char
#\Newline
)
2803 (vector-push-extend (+ start i
)
2804 (form-tracking-stream-newlines stream
))))))
2806 ;; Fix the INPUT-CHAR-POS slot of STREAM after having consumed characters
2807 ;; before refilling cin-buffer.
2808 (defun update-input-char-pos (stream)
2809 (track-newlines stream
+ansi-stream-in-buffer-length
+)
2810 (incf (form-tracking-stream-input-char-pos stream
) +ansi-stream-in-buffer-length
+))
2812 (defun form-tracking-stream-current-char-pos (stream)
2813 (+ (form-tracking-stream-input-char-pos stream
)
2814 (ansi-stream-in-index stream
)))
2816 (defun tracking-stream-misc (stream operation arg1
)
2817 ;; The :UNREAD operation will never be invoked because STREAM has a buffer,
2818 ;; so unreading is implemented entirely within ANSI-STREAM-UNREAD-CHAR.
2819 ;; But we do need to prevent attempts to change the absolute position.
2820 (stream-misc-case (operation)
2821 (:set-file-position
(simple-stream-perror "~S is not positionable" stream
))
2823 (stream-misc-case (operation :default nil
)
2825 (track-newlines stream
)))
2827 (fd-stream-misc-routine stream operation arg1
))))