/[cmucl]/src/code/fd-stream.lisp
ViewVC logotype

Contents of /src/code/fd-stream.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.97.2.2 - (show annotations)
Tue Feb 9 19:54:14 2010 UTC (4 years, 2 months ago) by rtoy
Branch: intl-branch
CVS Tags: intl-branch-working-2010-02-11-1000
Changes since 1.97.2.1: +30 -30 lines
Mark translatable strings; update cmucl.pot and ko/cmucl.po
accordingly.
1 ;;; -*- Log: code.log; Package: LISP -*-
2 ;;;
3 ;;; **********************************************************************
4 ;;; This code was written as part of the CMU Common Lisp project at
5 ;;; Carnegie Mellon University, and has been placed in the public domain.
6 ;;;
7 (ext:file-comment
8 "$Header: /tiger/var/lib/cvsroots/cmucl/src/code/fd-stream.lisp,v 1.97.2.2 2010/02/09 19:54:14 rtoy Exp $")
9 ;;;
10 ;;; **********************************************************************
11 ;;;
12 ;;; Streams for UNIX file descriptors.
13 ;;;
14 ;;; Written by William Lott, July 1989 - January 1990.
15 ;;; Some tuning by Rob MacLachlan.
16 ;;;
17 ;;; **********************************************************************
18
19
20 (in-package "SYSTEM")
21
22 (intl:textdomain "cmucl")
23
24 (export '(fd-stream fd-stream-p fd-stream-fd make-fd-stream
25 io-timeout beep *beep-function* output-raw-bytes
26 *tty* *stdin* *stdout* *stderr*
27 binary-text-stream))
28
29
30 (in-package "EXTENSIONS")
31
32 (export '(*backup-extension*))
33
34
35 (in-package "LISP")
36
37 (export '(file-stream file-string-length))
38
39
40 ;;;; Buffer manipulation routines.
41
42 (defvar *available-buffers* ()
43 _N"List of available buffers. Each buffer is an sap pointing to
44 bytes-per-buffer of memory.")
45
46 (defvar lisp::*enable-stream-buffer-p* nil)
47
48 (defconstant bytes-per-buffer (* 4 1024)
49 _N"Number of bytes per buffer.")
50
51 ;; This limit is rather arbitrary
52 (defconstant max-stream-element-size 1024
53 _N"The maximum supported byte size for a stream element-type.")
54
55 ;;; NEXT-AVAILABLE-BUFFER -- Internal.
56 ;;;
57 ;;; Returns the next available buffer, creating one if necessary.
58 ;;;
59 (declaim (inline next-available-buffer))
60 ;;;
61 (defun next-available-buffer ()
62 (if *available-buffers*
63 (pop *available-buffers*)
64 (allocate-system-memory bytes-per-buffer)))
65
66 (declaim (inline buffer-sap bref (setf bref) buffer-copy))
67
68 (defun buffer-sap (thing &optional offset)
69 (declare (type simple-stream-buffer thing) (type (or fixnum null) offset)
70 (optimize (speed 3) (space 2) (debug 0) (safety 0)
71 ;; Suppress the note about having to box up the return:
72 (ext:inhibit-warnings 3)))
73 (let ((sap (if (vectorp thing) (sys:vector-sap thing) thing)))
74 (if offset (sys:sap+ sap offset) sap)))
75
76 (defun bref (buffer index)
77 (declare (type simple-stream-buffer buffer)
78 (type (integer 0 #.most-positive-fixnum) index))
79 (sys:sap-ref-8 (buffer-sap buffer) index))
80
81 (defun (setf bref) (octet buffer index)
82 (declare (type (unsigned-byte 8) octet)
83 (type simple-stream-buffer buffer)
84 (type (integer 0 #.most-positive-fixnum) index))
85 (setf (sys:sap-ref-8 (buffer-sap buffer) index) octet))
86
87 (defun buffer-copy (src soff dst doff length)
88 (declare (type simple-stream-buffer src dst)
89 (type fixnum soff doff length))
90 (sys:without-gcing ;; is this necessary??
91 (kernel:system-area-copy (buffer-sap src) (* soff 8)
92 (buffer-sap dst) (* doff 8)
93 (* length 8))))
94
95 #-(or big-endian little-endian)
96 (eval-when (:compile-toplevel)
97 (push (c::backend-byte-order c::*target-backend*) *features*))
98
99 (defun vector-elt-width (vector)
100 ;; Return octet-width of vector elements
101 (etypecase vector
102 ;; (simple-array fixnum (*)) not supported
103 ;; (simple-array base-char (*)) treated specially; don't call this
104 ((simple-array bit (*)) 1/8)
105 ((simple-array (unsigned-byte 2) (*)) 1/4)
106 ((simple-array (unsigned-byte 4) (*)) 1/2)
107 ((simple-array (signed-byte 8) (*)) 1)
108 ((simple-array (unsigned-byte 8) (*)) 1)
109 ((simple-array (signed-byte 16) (*)) 2)
110 ((simple-array (unsigned-byte 16) (*)) 2)
111 ((simple-array (signed-byte 32) (*)) 4)
112 ((simple-array (unsigned-byte 32) (*)) 4)
113 ((simple-array single-float (*)) 4)
114 ((simple-array double-float (*)) 8)
115 ((simple-array (complex single-float) (*)) 8)
116 ((simple-array (complex double-float) (*)) 16)
117 #+long-float
118 ((simple-array long-float (*)) 10)
119 #+long-float
120 ((simple-array (complex long-float) (*)) 20)
121 #+double-double
122 ((simple-array double-double-float (*)) 16)
123 #+double-double
124 ((simple-array (complex double-double-float) (*)) 32)))
125
126 (defun endian-swap-value (vector endian-swap)
127 (case endian-swap
128 (:network-order
129 #+big-endian 0
130 ;; This is needed because the little-endian (x86) architectures
131 ;; store the lowest indexed element in the least significant part
132 ;; of a byte. On a big-endian machine (sparc, ppc), the lowest
133 ;; indexed element is at the most significant part of a byte.
134 #+little-endian
135 (typecase vector
136 ((array (unsigned-byte 4) (*))
137 -1)
138 ((array (unsigned-byte 2) (*))
139 -2)
140 ((array (unsigned-byte 1) (*))
141 -8)
142 (t
143 (1- (vector-elt-width vector)))))
144 (:byte-8 0)
145 (:byte-16 1)
146 (:byte-32 3)
147 (:byte-64 7)
148 (:byte-128 15)
149 ;; additions by Lynn Quam
150 (:machine-endian 0)
151 (:big-endian
152 #+big-endian 0
153 #+little-endian
154 (typecase vector
155 ((array (unsigned-byte 4) (*))
156 -1)
157 ((array (unsigned-byte 2) (*))
158 -2)
159 ((array (unsigned-byte 1) (*))
160 -8)
161 (t
162 (1- (vector-elt-width vector)))))
163 (:little-endian
164 #+big-endian
165 (typecase vector
166 ((array (unsigned-byte 4) (*))
167 -1)
168 ((array (unsigned-byte 2) (*))
169 -2)
170 ((array (unsigned-byte 1) (*))
171 -8)
172 (t
173 (1- (vector-elt-width vector))))
174 #+little-endian 0)
175 (otherwise endian-swap)))
176
177
178 ;;;; The FD-STREAM structure.
179
180 ;;;; Superclass defined by the ANSI Spec
181 (defstruct (file-stream
182 (:include lisp-stream)
183 (:constructor nil)
184 (:copier nil)))
185
186 (defstruct (fd-stream
187 (:print-function %print-fd-stream)
188 (:constructor %make-fd-stream)
189 (:include file-stream
190 (misc #'fd-stream-misc-routine)))
191
192 (name nil) ; The name of this stream
193 (file nil) ; The file this stream is for
194 ;;
195 ;; The backup file namestring for the old file, for :if-exists :rename or
196 ;; :rename-and-delete.
197 (original nil :type (or simple-string null))
198 (delete-original nil) ; for :if-exists :rename-and-delete
199 ;;
200 ;;; Number of bytes per element.
201 (element-size 1 :type index)
202 (element-type 'base-char) ; The type of element being transfered.
203 (fd -1 :type fixnum) ; The file descriptor
204 ;;
205 ;; Controls when the output buffer is flushed.
206 (buffering :full :type (member :full :line :none))
207 ;;
208 ;; Character position if known.
209 (char-pos nil :type (or index null))
210 ;;
211 ;; T if input is waiting on FD. :EOF if we hit EOF.
212 (listen nil :type (member nil t :eof))
213 ;;
214 ;; The input buffer.
215 (unread nil)
216 (ibuf-sap nil :type (or system-area-pointer null))
217 (ibuf-length nil :type (or index null))
218 (ibuf-head 0 :type index)
219 (ibuf-tail 0 :type index)
220
221 ;; The output buffer.
222 (obuf-sap nil :type (or system-area-pointer null))
223 (obuf-length nil :type (or index null))
224 (obuf-tail 0 :type index)
225
226 ;; Output flushed, but not written due to non-blocking io.
227 (output-later nil)
228 (handler nil)
229 ;;
230 ;; Timeout specified for this stream, or NIL if none.
231 (timeout nil :type (or index null))
232 ;;
233 ;; Pathname of the file this stream is opened to (returned by PATHNAME.)
234 (pathname nil :type (or pathname null))
235 ;;
236 ;; External format support
237 ;;
238 ;; @@ I want to use :default here, but keyword pkg isn't set up yet at boot
239 ;; so initialize to NIL and fix it in SET-ROUTINES
240 #+unicode
241 (external-format nil :type (or null keyword cons))
242 ;;
243 ;; State for octets-to-char (for reading from a stream). The
244 ;; contents of the state can be anything and is defined by the
245 ;; external format.
246 #+unicode
247 (oc-state nil)
248 ;;
249 ;; State for char-to-octets (for writing to a stream). The contents
250 ;; of the state can be anything and is defined by the external
251 ;; format. If not NIL, then the CAR is used by char-to-octets to
252 ;; hold some state information, and the CDR is available to the
253 ;; external format to hold whatever state information is needed.
254 #+unicode
255 (co-state nil)
256 #+unicode
257 (last-char-read-size 0 :type index)
258 ;; Saved state needed for (setf stream-external-format) when the
259 ;; fast string-buffer is used.
260 #+unicode
261 (saved-oc-state nil)
262 ;;
263 ;; The number of octets in in-buffer. Normally equal to
264 ;; in-buffer-length, but could be less if we reached the
265 ;; end-of-file.
266 #+unicode
267 (in-length 0 :type index))
268
269 (defun %print-fd-stream (fd-stream stream depth)
270 (declare (ignore depth) (stream stream))
271 (format stream "#<Stream for ~A>"
272 (fd-stream-name fd-stream)))
273
274 ;; CMUCL extension. This is a FD-STREAM, but it allows reading and
275 ;; writing of 8-bit characters and unsigned bytes from the stream.
276 (defstruct (binary-text-stream
277 (:print-function %print-binary-text-stream)
278 (:constructor %make-binary-text-stream)
279 (:include fd-stream)))
280
281 (defun %print-binary-text-stream (fd-stream stream depth)
282 (declare (ignore depth) (stream stream))
283 (format stream "#<Binary-text Stream for ~A>"
284 (fd-stream-name fd-stream)))
285
286 (define-condition io-timeout (stream-error)
287 ((direction :reader io-timeout-direction :initarg :direction))
288 (:report
289 (lambda (condition stream)
290 (declare (stream stream))
291 (format stream "Timeout ~(~A~)ing ~S."
292 (io-timeout-direction condition)
293 (stream-error-stream condition)))))
294
295
296 ;;;; Output routines and related noise.
297
298 (defvar *output-routines* ()
299 _N"List of all available output routines. Each element is a list of the
300 element-type output, the kind of buffering, the function name, and the number
301 of bytes per element.")
302
303 ;;; DO-OUTPUT-LATER -- internal
304 ;;;
305 ;;; Called by the server when we can write to the given file descriptor.
306 ;;; Attempt to write the data again. If it worked, remove the data from the
307 ;;; output-later list. If it didn't work, something is wrong.
308 ;;;
309 (defun do-output-later (stream)
310 (let* ((stuff (pop (fd-stream-output-later stream)))
311 (base (car stuff))
312 (start (cadr stuff))
313 (end (caddr stuff))
314 (reuse-sap (cadddr stuff))
315 (length (- end start)))
316 (declare (type index start end length))
317 (multiple-value-bind
318 (count errno)
319 (unix:unix-write (fd-stream-fd stream)
320 base
321 start
322 length)
323 (cond ((not count)
324 (if (= errno unix:ewouldblock)
325 (error _"Write would have blocked, but SERVER told us to go.")
326 (error _"While writing ~S: ~A"
327 stream (unix:get-unix-error-msg errno))))
328 ((eql count length) ; Hot damn, it worked.
329 (when reuse-sap
330 (push base *available-buffers*)))
331 ((not (null count)) ; Sorta worked.
332 (push (list base
333 (the index (+ start count))
334 end)
335 (fd-stream-output-later stream))))))
336 (unless (fd-stream-output-later stream)
337 (system:remove-fd-handler (fd-stream-handler stream))
338 (setf (fd-stream-handler stream) nil)))
339
340 ;;; OUTPUT-LATER -- internal
341 ;;;
342 ;;; Arrange to output the string when we can write on the file descriptor.
343 ;;;
344 (defun output-later (stream base start end reuse-sap)
345 (cond ((null (fd-stream-output-later stream))
346 (setf (fd-stream-output-later stream)
347 (list (list base start end reuse-sap)))
348 (setf (fd-stream-handler stream)
349 (system:add-fd-handler (fd-stream-fd stream)
350 :output
351 #'(lambda (fd)
352 (declare (ignore fd))
353 (do-output-later stream)))))
354 (t
355 (nconc (fd-stream-output-later stream)
356 (list (list base start end reuse-sap)))))
357 (when reuse-sap
358 (let ((new-buffer (next-available-buffer)))
359 (setf (fd-stream-obuf-sap stream) new-buffer)
360 (setf (fd-stream-obuf-length stream) bytes-per-buffer))))
361
362 ;;; DO-OUTPUT -- internal
363 ;;;
364 ;;; Output the given noise. Check to see if there are any pending writes. If
365 ;;; so, just queue this one. Otherwise, try to write it. If this would block,
366 ;;; queue it.
367 ;;;
368 (defun do-output (stream base start end reuse-sap)
369 (declare (type fd-stream stream)
370 (type (or system-area-pointer (simple-array * (*))) base)
371 (type index start end))
372 (if (not (null (fd-stream-output-later stream))) ; something buffered.
373 (progn
374 (output-later stream base start end reuse-sap)
375 ;; ### check to see if any of this noise can be output
376 )
377 (let ((length (- end start)))
378 (multiple-value-bind
379 (count errno)
380 (unix:unix-write (fd-stream-fd stream) base start length)
381 (cond ((not count)
382 (if (= errno unix:ewouldblock)
383 (output-later stream base start end reuse-sap)
384 (error 'simple-stream-error
385 :stream stream
386 :format-control "while writing: ~A"
387 :format-arguments (list (unix:get-unix-error-msg errno)))))
388 ((not (eql count length))
389 (output-later stream base (the index (+ start count))
390 end reuse-sap)))))))
391
392 #+unicode
393 (stream::def-ef-macro ef-flush (extfmt lisp stream::+ef-max+ stream::+ef-flush+)
394 `(lambda (stream)
395 (declare (type fd-stream stream))
396 (let* ((tail (fd-stream-obuf-tail stream)))
397 (declare (type index tail))
398 (cond
399 ((stream::ef-flush-state ,(stream::find-external-format extfmt))
400 (stream::flush-state ,extfmt
401 (fd-stream-co-state stream)
402 (lambda (byte)
403 (when (= tail len)
404 (do-output stream sap 0 tail t)
405 (setq sap (fd-stream-obuf-sap stream)
406 tail 0))
407 (setf (bref sap (1- (incf tail))) byte)))
408 (setf (fd-stream-obuf-tail stream) tail))
409 (t
410 ;; No flush-state function, so just output a replacement
411 ;; character. We hack the co-state to what we need for this
412 ;; to work. This should be ok because we're closing the
413 ;; file anyway.
414 (let ((state (fd-stream-co-state stream)))
415 (when (and state (car state))
416 (setf (fd-stream-co-state stream)
417 (cons nil (cdr state)))
418 (funcall (ef-cout (fd-stream-external-format stream))
419 stream (code-char stream::+replacement-character-code+))))))
420 (values))))
421
422 ;;; FLUSH-OUTPUT-BUFFER -- internal
423 ;;;
424 ;;; Flush any data in the output buffer.
425 ;;;
426 (defun flush-output-buffer (stream)
427 (let ((length (fd-stream-obuf-tail stream)))
428 (unless (= length 0)
429 (do-output stream (fd-stream-obuf-sap stream) 0 length t)
430 (setf (fd-stream-obuf-tail stream) 0))))
431
432 ;;; DEF-OUTPUT-ROUTINES -- internal
433 ;;;
434 ;;; Define output routines that output numbers size bytes long for the
435 ;;; given bufferings. Use body to do the actual output.
436 ;;;
437 (defmacro def-output-routines ((name size &rest bufferings) &body body)
438 (declare (optimize (speed 1)))
439 (cons 'progn
440 (mapcar
441 #'(lambda (buffering)
442 (let ((function
443 (intern (let ((*print-case* :upcase))
444 (format nil name (car buffering))))))
445 `(progn
446 (defun ,function (stream byte)
447 ,(unless (eq (car buffering) :none)
448 `(when (< (fd-stream-obuf-length stream)
449 (+ (fd-stream-obuf-tail stream)
450 ,size))
451 (flush-output-buffer stream)))
452 ;;
453 ;; If there is any input read from UNIX but not
454 ;; supplied to the user of the stream, reposition
455 ;; to the real file position as seen from Lisp.
456 ,(unless (eq (car buffering) :none)
457 `(when (> (fd-stream-ibuf-tail stream)
458 (fd-stream-ibuf-head stream))
459 (file-position stream (file-position stream))))
460 ,@body
461 (incf (fd-stream-obuf-tail stream) ,size)
462 ,(ecase (car buffering)
463 (:none
464 `(flush-output-buffer stream))
465 (:line
466 `(when (eql (char-code byte) (char-code #\Newline))
467 (flush-output-buffer stream)))
468 (:full
469 ))
470 (values))
471 (setf *output-routines*
472 (nconc *output-routines*
473 ',(mapcar
474 #'(lambda (type)
475 (list type
476 (car buffering)
477 function
478 size))
479 (cdr buffering)))))))
480 bufferings)))
481
482 #-unicode
483 (def-output-routines ("OUTPUT-CHAR-~A-BUFFERED"
484 1
485 (:none character)
486 (:line character)
487 (:full character))
488 (if (char= byte #\Newline)
489 (setf (fd-stream-char-pos stream) 0)
490 (incf (fd-stream-char-pos stream)))
491 (setf (sap-ref-8 (fd-stream-obuf-sap stream) (fd-stream-obuf-tail stream))
492 (char-code byte)))
493
494 #+unicode
495 (def-output-routines ("OUTPUT-CHAR-~A-BUFFERED"
496 1
497 (:none character)
498 (:line character)
499 (:full character))
500 (if (char= byte #\Newline)
501 (setf (fd-stream-char-pos stream) 0)
502 (incf (fd-stream-char-pos stream)))
503 ;; FIXME! We only use the low 8 bits of a character!
504 (setf (sap-ref-8 (fd-stream-obuf-sap stream) (fd-stream-obuf-tail stream))
505 (logand #xff (char-code byte))))
506
507 (def-output-routines ("OUTPUT-UNSIGNED-BYTE-~A-BUFFERED"
508 1
509 (:none (unsigned-byte 8))
510 (:full (unsigned-byte 8)))
511 (setf (sap-ref-8 (fd-stream-obuf-sap stream) (fd-stream-obuf-tail stream))
512 byte))
513
514 (def-output-routines ("OUTPUT-SIGNED-BYTE-~A-BUFFERED"
515 1
516 (:none (signed-byte 8))
517 (:full (signed-byte 8)))
518 (setf (signed-sap-ref-8 (fd-stream-obuf-sap stream)
519 (fd-stream-obuf-tail stream))
520 byte))
521
522 (def-output-routines ("OUTPUT-UNSIGNED-SHORT-~A-BUFFERED"
523 2
524 (:none (unsigned-byte 16))
525 (:full (unsigned-byte 16)))
526 (setf (sap-ref-16 (fd-stream-obuf-sap stream) (fd-stream-obuf-tail stream))
527 byte))
528
529 (def-output-routines ("OUTPUT-SIGNED-SHORT-~A-BUFFERED"
530 2
531 (:none (signed-byte 16))
532 (:full (signed-byte 16)))
533 (setf (signed-sap-ref-16 (fd-stream-obuf-sap stream)
534 (fd-stream-obuf-tail stream))
535 byte))
536
537 (def-output-routines ("OUTPUT-UNSIGNED-LONG-~A-BUFFERED"
538 4
539 (:none (unsigned-byte 32))
540 (:full (unsigned-byte 32)))
541 (setf (sap-ref-32 (fd-stream-obuf-sap stream) (fd-stream-obuf-tail stream))
542 byte))
543
544 (def-output-routines ("OUTPUT-SIGNED-LONG-~A-BUFFERED"
545 4
546 (:none (signed-byte 32))
547 (:full (signed-byte 32)))
548 (setf (signed-sap-ref-32 (fd-stream-obuf-sap stream)
549 (fd-stream-obuf-tail stream))
550 byte))
551
552 (stream::def-ef-macro ef-cout (extfmt lisp stream::+ef-max+ stream::+ef-cout+)
553 `(lambda (stream char)
554 (declare (type fd-stream stream)
555 (type character char)
556 (optimize (speed 3) (space 0) (debug 0) (safety 0)))
557 ;; If there is any input read from UNIX but not
558 ;; supplied to the user of the stream, reposition
559 ;; to the real file position as seen from Lisp.
560 (when (> (fd-stream-ibuf-tail stream)
561 (fd-stream-ibuf-head stream))
562 (file-position stream (file-position stream)))
563 (let* ((sap (fd-stream-obuf-sap stream))
564 (len (fd-stream-obuf-length stream))
565 (tail (fd-stream-obuf-tail stream)))
566 (declare (type sys:system-area-pointer sap) (type index len tail))
567 (stream::char-to-octets ,extfmt
568 char
569 (fd-stream-co-state stream)
570 (lambda (byte)
571 (when (= tail len)
572 (do-output stream sap 0 tail t)
573 (setq sap (fd-stream-obuf-sap stream)
574 tail 0))
575 (setf (bref sap (1- (incf tail))) byte)))
576 (setf (fd-stream-obuf-tail stream) tail))
577 (if (char= char #\Newline)
578 (setf (fd-stream-char-pos stream) 0)
579 (incf (fd-stream-char-pos stream)))
580 (ecase (fd-stream-buffering stream)
581 (:none (flush-output-buffer stream))
582 (:line (when (char= char #\Newline) (flush-output-buffer stream)))
583 (:full #| do nothing |#))
584 (values)))
585
586
587 ;;; OUTPUT-RAW-BYTES -- public
588 ;;;
589 ;;; Does the actual output. If there is space to buffer the string, buffer
590 ;;; it. If the string would normally fit in the buffer, but doesn't because
591 ;;; of other stuff in the buffer, flush the old noise out of the buffer and
592 ;;; put the string in it. Otherwise we have a very long string, so just
593 ;;; send it directly (after flushing the buffer, of course).
594 ;;;
595 (defun output-raw-bytes (stream thing &optional start end)
596 _N"Output THING to stream. THING can be any kind of vector or a sap. If THING
597 is a SAP, END must be supplied (as length won't work)."
598 (let ((start (or start 0))
599 (end (or end (length (the (simple-array * (*)) thing)))))
600 (declare (type index start end))
601 ;;
602 ;; If there is any input read from UNIX but not
603 ;; supplied to the user of the stream, reposition
604 ;; to the real file position as seen from Lisp.
605 (when (> (fd-stream-ibuf-tail stream)
606 (fd-stream-ibuf-head stream))
607 (file-position stream (file-position stream)))
608 (let* ((len (fd-stream-obuf-length stream))
609 (tail (fd-stream-obuf-tail stream))
610 (space (- len tail))
611 (bytes (- end start))
612 (newtail (+ tail bytes)))
613 (cond ((minusp bytes) ; Error case
614 (cerror "Just go on as if nothing happened..."
615 "~S called with :END before :START!"
616 'output-raw-bytes))
617 ((zerop bytes)) ; Easy case
618 ((<= bytes space)
619 (if (system-area-pointer-p thing)
620 (system-area-copy thing
621 (* start vm:byte-bits)
622 (fd-stream-obuf-sap stream)
623 (* tail vm:byte-bits)
624 (* bytes vm:byte-bits))
625 (copy-to-system-area thing
626 (+ (* start vm:byte-bits)
627 (* vm:vector-data-offset vm:word-bits))
628 (fd-stream-obuf-sap stream)
629 (* tail vm:byte-bits)
630 (* bytes vm:byte-bits)))
631 (setf (fd-stream-obuf-tail stream) newtail))
632 ((<= bytes len)
633 (flush-output-buffer stream)
634 (if (system-area-pointer-p thing)
635 (system-area-copy thing
636 (* start vm:byte-bits)
637 (fd-stream-obuf-sap stream)
638 0
639 (* bytes vm:byte-bits))
640 (copy-to-system-area thing
641 (+ (* start vm:byte-bits)
642 (* vm:vector-data-offset vm:word-bits))
643 (fd-stream-obuf-sap stream)
644 0
645 (* bytes vm:byte-bits)))
646 (setf (fd-stream-obuf-tail stream) bytes))
647 (t
648 (flush-output-buffer stream)
649 (do-output stream thing start end nil))))))
650
651 ;;; FD-SOUT -- internal
652 ;;;
653 ;;; Routine to use to output a string. If the stream is unbuffered, slam
654 ;;; the string down the file descriptor, otherwise use OUTPUT-RAW-BYTES to
655 ;;; buffer the string. Update charpos by checking to see where the last newline
656 ;;; was.
657 ;;;
658 ;;; Note: some bozos (the FASL dumper) call write-string with things other
659 ;;; than strings. Therefore, we must make sure we have a string before calling
660 ;;; position on it.
661 ;;;
662
663 (stream::def-ef-macro ef-sout (extfmt lisp stream::+ef-max+ stream::+ef-sout+)
664 `(lambda (stream string start end)
665 (declare (type fd-stream stream)
666 (type simple-string string)
667 (type index start end)
668 (optimize (speed 3) (space 0) (safety 0) (debug 0)))
669 ;; If there is any input read from UNIX but not
670 ;; supplied to the user of the stream, reposition
671 ;; to the real file position as seen from Lisp.
672 ;; (maybe the caller should do this?)
673 (when (> (fd-stream-ibuf-tail stream)
674 (fd-stream-ibuf-head stream))
675 (file-position stream (file-position stream)))
676 (let* ((sap (fd-stream-obuf-sap stream))
677 (len (fd-stream-obuf-length stream))
678 (tail (fd-stream-obuf-tail stream)))
679 (declare (type sys:system-area-pointer sap) (type index len tail))
680 (dotimes (i (- end start))
681 (stream::char-to-octets ,extfmt
682 (schar string (+ i start))
683 (fd-stream-co-state stream)
684 (lambda (byte)
685 (when (= tail len)
686 (do-output stream sap 0 tail t)
687 (setq sap (fd-stream-obuf-sap stream)
688 tail 0))
689 (setf (bref sap (1- (incf tail))) byte))))
690 (setf (fd-stream-obuf-tail stream) tail))))
691
692
693 #-unicode
694 (defun fd-sout (stream thing start end)
695 (let ((start (or start 0))
696 (end (or end (length (the vector thing)))))
697 (declare (type index start end))
698 (if (stringp thing)
699 (let ((last-newline (and (find #\newline (the simple-string thing)
700 :start start :end end)
701 (position #\newline (the simple-string thing)
702 :from-end t
703 :start start
704 :end end))))
705 (ecase (fd-stream-buffering stream)
706 (:full
707 (output-raw-bytes stream thing start end))
708 (:line
709 (output-raw-bytes stream thing start end)
710 (when last-newline
711 (flush-output-buffer stream)))
712 (:none
713 (do-output stream thing start end nil)))
714 (if last-newline
715 (setf (fd-stream-char-pos stream)
716 (- end last-newline 1))
717 (incf (fd-stream-char-pos stream)
718 (- end start))))
719 (ecase (fd-stream-buffering stream)
720 ((:line :full)
721 (output-raw-bytes stream thing start end))
722 (:none
723 (do-output stream thing start end nil))))))
724
725 #+unicode
726 ;; Temporary. The final version is defined in fd-stream-extfmt.lisp
727 (defun fd-sout (stream thing start end)
728 (declare (type string thing))
729 (let ((start (or start 0))
730 (end (or end (length (the vector thing)))))
731 (declare (type index start end))
732 (cond
733 ((stringp thing) ; FIXME - remove this test
734 (let ((out (fd-stream-out stream)))
735 (do ((index start (+ index 1)))
736 ((>= index end))
737 (funcall out stream (elt thing index))))))))
738
739 (defmacro output-wrapper ((stream size buffering) &body body)
740 (let ((stream-var (gensym)))
741 `(let ((,stream-var ,stream))
742 ,(unless (eq (car buffering) :none)
743 `(when (< (fd-stream-obuf-length ,stream-var)
744 (+ (fd-stream-obuf-tail ,stream-var)
745 ,size))
746 (flush-output-buffer ,stream-var)))
747 ,(unless (eq (car buffering) :none)
748 `(when (> (fd-stream-ibuf-tail ,stream-var)
749 (fd-stream-ibuf-head ,stream-var))
750 (file-position ,stream-var (file-position ,stream-var))))
751
752 ,@body
753 (incf (fd-stream-obuf-tail ,stream-var) ,size)
754 ,(ecase (car buffering)
755 (:none
756 `(flush-output-buffer ,stream-var))
757 (:line
758 `(when (eq (char-code byte) (char-code #\Newline))
759 (flush-output-buffer ,stream-var)))
760 (:full))
761 (values))))
762
763 ;;; PICK-OUTPUT-ROUTINE -- internal
764 ;;;
765 ;;; Find an output routine to use given the type and buffering. Return as
766 ;;; multiple values the routine, the real type transfered, and the number of
767 ;;; bytes per element.
768 ;;;
769 (defun pick-output-routine (type buffering)
770 (dolist (entry *output-routines*)
771 (when (and (subtypep type (car entry))
772 (eq buffering (cadr entry)))
773 (return-from pick-output-routine
774 (values (symbol-function (caddr entry))
775 (car entry)
776 (cadddr entry)))))
777 ;; KLUDGE: also see comments in PICK-INPUT-ROUTINE
778 (loop for i from 40 by 8 to max-stream-element-size ; ARB (KLUDGE)
779 if (subtypep type `(unsigned-byte ,i))
780 do (return-from pick-output-routine
781 (values
782 (ecase buffering
783 (:none
784 (lambda (stream byte)
785 (output-wrapper (stream (/ i 8) (:none))
786 (loop for j from 0 below (/ i 8)
787 do (setf (sap-ref-8
788 (fd-stream-obuf-sap stream)
789 (+ j (fd-stream-obuf-tail stream)))
790 (ldb (byte 8 (- i 8 (* j 8))) byte))))))
791 (:full
792 (lambda (stream byte)
793 (output-wrapper (stream (/ i 8) (:full))
794 (loop for j from 0 below (/ i 8)
795 do (setf (sap-ref-8
796 (fd-stream-obuf-sap stream)
797 (+ j (fd-stream-obuf-tail stream)))
798 (ldb (byte 8 (- i 8 (* j 8))) byte)))))))
799 `(unsigned-byte ,i)
800 (/ i 8))))
801 (loop for i from 40 by 8 to max-stream-element-size ; ARB (KLUDGE)
802 if (subtypep type `(signed-byte ,i))
803 do (return-from pick-output-routine
804 (values
805 (ecase buffering
806 (:none
807 (lambda (stream byte)
808 (output-wrapper (stream (/ i 8) (:none))
809 (loop for j from 0 below (/ i 8)
810 do (setf (sap-ref-8
811 (fd-stream-obuf-sap stream)
812 (+ j (fd-stream-obuf-tail stream)))
813 (ldb (byte 8 (- i 8 (* j 8))) byte))))))
814 (:full
815 (lambda (stream byte)
816 (output-wrapper (stream (/ i 8) (:full))
817 (loop for j from 0 below (/ i 8)
818 do (setf (sap-ref-8
819 (fd-stream-obuf-sap stream)
820 (+ j (fd-stream-obuf-tail stream)))
821 (ldb (byte 8 (- i 8 (* j 8))) byte)))))))
822 `(signed-byte ,i)
823 (/ i 8)))))
824
825 ;;;; Input routines and related noise.
826
827 (defvar *input-routines* ()
828 _N"List of all available input routines. Each element is a list of the
829 element-type input, the function name, and the number of bytes per element.")
830
831 ;;; DO-INPUT -- internal
832 ;;;
833 ;;; Fills the input buffer, and returns the first character. Throws to
834 ;;; eof-input-catcher if the eof was reached. Drops into system:server if
835 ;;; necessary.
836 ;;;
837 (defun do-input (stream)
838 (let ((fd (fd-stream-fd stream))
839 (ibuf-sap (fd-stream-ibuf-sap stream))
840 (buflen (fd-stream-ibuf-length stream))
841 (head (fd-stream-ibuf-head stream))
842 (lcrs #-unicode 0
843 #+unicode (fd-stream-last-char-read-size stream))
844 (tail (fd-stream-ibuf-tail stream)))
845 (declare (type index head lcrs tail))
846 (unless (zerop head)
847 (cond ((eql head tail)
848 (setf head lcrs)
849 (setf tail lcrs)
850 (setf (fd-stream-ibuf-head stream) lcrs)
851 (setf (fd-stream-ibuf-tail stream) lcrs))
852 (t
853 (decf tail (- head lcrs))
854 (system-area-copy ibuf-sap (* (- head lcrs) vm:byte-bits)
855 ibuf-sap 0 (* tail vm:byte-bits))
856 (setf head lcrs)
857 (setf (fd-stream-ibuf-head stream) lcrs)
858 (setf (fd-stream-ibuf-tail stream) tail))))
859 (setf (fd-stream-listen stream) nil)
860 (multiple-value-bind
861 (count errno)
862 (alien:with-alien ((read-fds (alien:struct unix:fd-set)))
863 (unix:fd-zero read-fds)
864 (unix:fd-set fd read-fds)
865 (unix:unix-fast-select (1+ fd) (alien:addr read-fds) nil nil 0 0))
866 ;; Wait if input is not available or if interrupted.
867 (when (or (eql count 0)
868 (and (not count) (eql errno unix:eintr)))
869 (unless #-mp (system:wait-until-fd-usable
870 fd :input (fd-stream-timeout stream))
871 #+mp (mp:process-wait-until-fd-usable
872 fd :input (fd-stream-timeout stream))
873 (error 'io-timeout :stream stream :direction :read))))
874 (multiple-value-bind
875 (count errno)
876 (unix:unix-read fd
877 (system:int-sap (+ (system:sap-int ibuf-sap) tail))
878 (- buflen tail))
879 (cond ((null count)
880 ;; What kinds of errors do we want to look at and what do
881 ;; we want them to do?
882 (cond ((eql errno unix:ewouldblock)
883 (unless #-mp (system:wait-until-fd-usable
884 fd :input (fd-stream-timeout stream))
885 #+mp (mp:process-wait-until-fd-usable
886 fd :input (fd-stream-timeout stream))
887 (error 'io-timeout :stream stream :direction :read))
888 (do-input stream))
889 ((eql errno unix:econnreset)
890 (error 'socket-error
891 :format-control "Socket connection reset: ~A"
892 :format-arguments (list (unix:get-unix-error-msg errno))
893 :errno errno))
894 (t
895 (error _"Error reading ~S: ~A"
896 stream
897 (unix:get-unix-error-msg errno)))))
898 ((zerop count)
899 (setf (fd-stream-listen stream) :eof)
900 (throw 'eof-input-catcher nil))
901 (t
902 (incf (fd-stream-ibuf-tail stream) count))))))
903
904 ;;; INPUT-AT-LEAST -- internal
905 ;;;
906 ;;; Makes sure there are at least ``bytes'' number of bytes in the input
907 ;;; buffer. Keeps calling do-input until that condition is met.
908 ;;;
909 (defmacro input-at-least (stream bytes)
910 (let ((stream-var (gensym))
911 (bytes-var (gensym)))
912 `(let ((,stream-var ,stream)
913 (,bytes-var ,bytes))
914 (loop
915 (when (>= (- (fd-stream-ibuf-tail ,stream-var)
916 (fd-stream-ibuf-head ,stream-var))
917 ,bytes-var)
918 (return))
919 (do-input ,stream-var)))))
920
921 ;;; INPUT-WRAPPER -- internal
922 ;;;
923 ;;; Macro to wrap around all input routines to handle eof-error noise.
924 ;;;
925 (defmacro input-wrapper ((stream bytes eof-error eof-value &optional type) &body read-forms)
926 (let ((stream-var (gensym))
927 (element-var (gensym)))
928 `(let ((,stream-var ,stream))
929 (if (fd-stream-unread ,stream-var) ;;@@
930 (prog1
931 ,(if (eq type 'character)
932 `(fd-stream-unread ,stream-var)
933 `(char-code (fd-stream-unread ,stream-var)))
934 (setf (fd-stream-unread ,stream-var) nil)
935 (setf (fd-stream-listen ,stream-var) nil))
936 (let ((,element-var
937 (catch 'eof-input-catcher
938 (input-at-least ,stream-var ,bytes)
939 ,@read-forms)))
940 (cond (,element-var
941 (incf (fd-stream-ibuf-head ,stream-var) ,bytes)
942 ,element-var)
943 (t
944 (eof-or-lose ,stream-var ,eof-error ,eof-value))))))))
945
946 ;;; DEF-INPUT-ROUTINE -- internal
947 ;;;
948 ;;; Defines an input routine.
949 ;;;
950 (defmacro def-input-routine (name
951 (type size sap head)
952 &rest body)
953 `(progn
954 (defun ,name (stream eof-error eof-value)
955 (input-wrapper (stream ,size eof-error eof-value ,type)
956 (let ((,sap (fd-stream-ibuf-sap stream))
957 (,head (fd-stream-ibuf-head stream)))
958 ,@body)))
959 (setf *input-routines*
960 (nconc *input-routines*
961 (list (list ',type ',name ',size))))))
962
963 ;;; INPUT-CHARACTER -- internal
964 ;;;
965 ;;; Routine to use in stream-in slot for reading string chars.
966 ;;;
967 (def-input-routine input-character
968 (character 1 sap head)
969 (code-char (sap-ref-8 sap head)))
970
971 ;;; INPUT-UNSIGNED-8BIT-BYTE -- internal
972 ;;;
973 ;;; Routine to read in an unsigned 8 bit number.
974 ;;;
975 (def-input-routine input-unsigned-8bit-byte
976 ((unsigned-byte 8) 1 sap head)
977 (sap-ref-8 sap head))
978
979 ;;; INPUT-SIGNED-8BIT-BYTE -- internal
980 ;;;
981 ;;; Routine to read in a signed 8 bit number.
982 ;;;
983 (def-input-routine input-signed-8bit-number
984 ((signed-byte 8) 1 sap head)
985 (signed-sap-ref-8 sap head))
986
987 ;;; INPUT-UNSIGNED-16BIT-BYTE -- internal
988 ;;;
989 ;;; Routine to read in an unsigned 16 bit number.
990 ;;;
991 (def-input-routine input-unsigned-16bit-byte
992 ((unsigned-byte 16) 2 sap head)
993 (sap-ref-16 sap head))
994
995 ;;; INPUT-SIGNED-16BIT-BYTE -- internal
996 ;;;
997 ;;; Routine to read in a signed 16 bit number.
998 ;;;
999 (def-input-routine input-signed-16bit-byte
1000 ((signed-byte 16) 2 sap head)
1001 (signed-sap-ref-16 sap head))
1002
1003 ;;; INPUT-UNSIGNED-32BIT-BYTE -- internal
1004 ;;;
1005 ;;; Routine to read in a unsigned 32 bit number.
1006 ;;;
1007 (def-input-routine input-unsigned-32bit-byte
1008 ((unsigned-byte 32) 4 sap head)
1009 (sap-ref-32 sap head))
1010
1011 ;;; INPUT-SIGNED-32BIT-BYTE -- internal
1012 ;;;
1013 ;;; Routine to read in a signed 32 bit number.
1014 ;;;
1015 (def-input-routine input-signed-32bit-byte
1016 ((signed-byte 32) 4 sap head)
1017 (signed-sap-ref-32 sap head))
1018
1019 (stream::def-ef-macro ef-cin (extfmt lisp stream::+ef-max+ stream::+ef-cin+)
1020 `(lambda (stream eof-error-p eof-value)
1021 (declare (type fd-stream stream)
1022 #|(optimize (speed 3) (space 0) (debug 0) (safety 0))|#)
1023 (let* ((head (fd-stream-ibuf-head stream))
1024 (ch (catch 'eof-input-catcher
1025 (stream::octets-to-char ,extfmt
1026 (fd-stream-oc-state stream)
1027 (fd-stream-last-char-read-size stream)
1028 ;;@@ Note: need proper EOF handling...
1029 (progn
1030 (when (= head (fd-stream-ibuf-tail stream))
1031 (let ((sofar (- head (fd-stream-ibuf-head
1032 stream))))
1033 (do-input stream)
1034 (setf head (+ (fd-stream-ibuf-head stream)
1035 sofar))))
1036 (bref (fd-stream-ibuf-sap stream)
1037 (1- (incf head))))
1038 (lambda (n) (decf head n))))))
1039 (declare (type index head))
1040 (if ch
1041 (progn
1042 (setf (fd-stream-ibuf-head stream) head)
1043 ch)
1044 (eof-or-lose stream eof-error-p eof-value)))))
1045
1046 #+(or)
1047 (stream::def-ef-macro ef-sin (extfmt lisp stream::+ef-max+ stream::+ef-sin+)
1048 `(lambda (stream string char start end)
1049 (declare (type fd-stream stream)
1050 (type simple-string string)
1051 (type (or character null) char)
1052 (type index start end)
1053 (optimize (speed 3) (space 0) (debug 0) (safety 0)))
1054 (let ((sap (fd-stream-ibuf-sap stream))
1055 (head (fd-stream-ibuf-head stream))
1056 (tail (fd-stream-ibuf-tail stream))
1057 (curr start))
1058 (declare (type sys:system-area-pointer sap)
1059 (type index head tail curr))
1060 (loop
1061 ;;@@ Fix EOF handling
1062 (let* ((sz 0)
1063 (ch (catch 'eof-input-catcher
1064 (stream::octets-to-char ,extfmt
1065 (fd-stream-oc-state stream)
1066 sz
1067 (progn
1068 (when (= head tail)
1069 (let ((sofar (- head
1070 (fd-stream-ibuf-head
1071 stream))))
1072 (do-input stream)
1073 (setq head
1074 (+ (fd-stream-ibuf-head
1075 stream)
1076 sofar)
1077 tail
1078 (fd-stream-ibuf-tail
1079 stream))))
1080 (bref sap (1- (incf head))))
1081 (lambda (n) (decf head n))))))
1082 (declare (type index sz)
1083 (type (or null character) ch))
1084 (when (null ch)
1085 (return (values (- curr start) :eof)))
1086 (setf (fd-stream-last-char-read-size stream) sz)
1087 (incf (fd-stream-ibuf-head stream) sz)
1088 (when (and char (char= ch char))
1089 (return (values (- curr start) t)))
1090 (setf (schar string (1- (incf curr))) ch)
1091 (when (= curr end)
1092 (return (values (- curr start) nil))))))))
1093
1094 ;;; PICK-INPUT-ROUTINE -- internal
1095 ;;;
1096 ;;; Find an input routine to use given the type. Return as multiple values
1097 ;;; the routine, the real type transfered, and the number of bytes per element.
1098 ;;;
1099 (defun pick-input-routine (type)
1100 (dolist (entry *input-routines*)
1101 (when (subtypep type (car entry))
1102 (return-from pick-input-routine
1103 (values (symbol-function (cadr entry))
1104 (car entry)
1105 (caddr entry)))))
1106 ;; FIXME: let's do it the hard way, then (but ignore things like
1107 ;; endianness, efficiency, and the necessary coupling between these
1108 ;; and the output routines). -- CSR, 2004-02-09
1109 (loop for i from 40 by 8 to max-stream-element-size ; ARB (well, KLUDGE really)
1110 if (subtypep type `(unsigned-byte ,i))
1111 do (return-from pick-input-routine
1112 (values
1113 (lambda (stream eof-error eof-value)
1114 (input-wrapper (stream (/ i 8) eof-error eof-value)
1115 (let ((sap (fd-stream-ibuf-sap stream))
1116 (head (fd-stream-ibuf-head stream)))
1117 (loop for j from 0 below (/ i 8)
1118 with result = 0
1119 do (setf result
1120 (+ (* 256 result)
1121 (sap-ref-8 sap (+ head j))))
1122 finally (return result)))))
1123 `(unsigned-byte ,i)
1124 (/ i 8))))
1125 (loop for i from 40 by 8 to max-stream-element-size ; ARB (well, KLUDGE really)
1126 if (subtypep type `(signed-byte ,i))
1127 do (return-from pick-input-routine
1128 (values
1129 (lambda (stream eof-error eof-value)
1130 (input-wrapper (stream (/ i 8) eof-error eof-value)
1131 (let ((sap (fd-stream-ibuf-sap stream))
1132 (head (fd-stream-ibuf-head stream)))
1133 (loop for j from 0 below (/ i 8)
1134 with result = 0
1135 do (setf result
1136 (+ (* 256 result)
1137 (sap-ref-8 sap (+ head j))))
1138 finally (return (if (logbitp (1- i) result)
1139 (dpb result (byte i 0) -1)
1140 result))))))
1141 `(signed-byte ,i)
1142 (/ i 8)))))
1143
1144 ;;; STRING-FROM-SAP -- internal
1145 ;;;
1146 ;;; Returns a string constructed from the sap, start, and end.
1147 ;;;
1148 (defun string-from-sap (sap start end)
1149 (declare (type index start end))
1150 (let* ((length (- end start))
1151 (string (make-string length)))
1152 (copy-from-system-area sap (* start vm:byte-bits)
1153 string (* vm:vector-data-offset vm:word-bits)
1154 (* length vm:byte-bits))
1155 string))
1156
1157 #|
1158 ;;; FD-STREAM-READ-N-BYTES -- internal
1159 ;;;
1160 ;;; This version waits using server. I changed to the non-server version
1161 ;;; because it allows this method to be used by CLX w/o confusing serve-event.
1162 ;;; The non-server method is also significantly more efficient for large
1163 ;;; reads. -- Ram
1164 ;;;
1165 ;;; The n-bin routine.
1166 ;;;
1167 (defun fd-stream-read-n-bytes (stream buffer start requested eof-error-p)
1168 (declare (type stream stream) (type index start requested))
1169 (let* ((sap (fd-stream-ibuf-sap stream))
1170 (elsize (fd-stream-element-size stream))
1171 (offset (* elsize start))
1172 (bytes (* elsize requested))
1173 (result
1174 (catch 'eof-input-catcher
1175 (loop
1176 (input-at-least stream 1)
1177 (let* ((head (fd-stream-ibuf-head stream))
1178 (tail (fd-stream-ibuf-tail stream))
1179 (available (- tail head))
1180 (copy (min available bytes)))
1181 (if (typep buffer 'system-area-pointer)
1182 (system-area-copy sap (* head vm:byte-bits)
1183 buffer (* offset vm:byte-bits)
1184 (* copy vm:byte-bits))
1185 (copy-from-system-area sap (* head vm:byte-bits)
1186 buffer (+ (* offset vm:byte-bits)
1187 (* vm:vector-data-offset
1188 vm:word-bits))
1189 (* copy vm:byte-bits)))
1190 (incf (fd-stream-ibuf-head stream) copy)
1191 (incf offset copy)
1192 (decf bytes copy))
1193 (when (zerop bytes)
1194 (return requested))))))
1195 (or result
1196 (eof-or-lose stream eof-error-p
1197 (- requested (/ bytes elsize))))))
1198 |#
1199
1200
1201 ;;; FD-STREAM-READ-N-BYTES -- internal
1202 ;;;
1203 ;;; The N-Bin method for FD-STREAMs. This doesn't use the SERVER; it blocks
1204 ;;; in UNIX-READ. This allows the method to be used to implement reading
1205 ;;; for CLX. It is generally used where there is a definite amount of reading
1206 ;;; to be done, so blocking isn't too problematical.
1207 ;;;
1208 ;;; We copy buffered data into the buffer. If there is enough, just return.
1209 ;;; Otherwise, we see if the amount of additional data needed will fit in the
1210 ;;; stream buffer. If not, inhibit GCing (so we can have a SAP into the Buffer
1211 ;;; argument), and read directly into the user supplied buffer. Otherwise,
1212 ;;; read a buffer-full into the stream buffer and then copy the amount we need
1213 ;;; out.
1214 ;;;
1215 ;;; We loop doing the reads until we either get enough bytes or hit EOF. We
1216 ;;; must loop when eof-errorp is T because some streams (like pipes) may return
1217 ;;; a partial amount without hitting EOF.
1218 ;;;
1219 (defun fd-stream-read-n-bytes (stream buffer start requested eof-error-p)
1220 (declare (type stream stream) (type index start requested))
1221 (let* ((sap (fd-stream-ibuf-sap stream))
1222 (offset start)
1223 (head (fd-stream-ibuf-head stream))
1224 (tail (fd-stream-ibuf-tail stream))
1225 (available (- tail head))
1226 (copy (min requested available)))
1227 (declare (type index offset head tail available copy))
1228 ;;
1229 ;; If something has been unread, put that at buffer + start,
1230 ;; and read the rest to start + 1.
1231 (when (fd-stream-unread stream) ;;@@
1232 (etypecase buffer
1233 (system-area-pointer
1234 (assert (= 1 (fd-stream-element-size stream)))
1235 (setf (sap-ref-8 buffer start) (char-code (read-char stream))))
1236 (string
1237 (setf (aref buffer start) (read-char stream)))
1238 (vector
1239 (setf (aref buffer start) (char-code(read-char stream)))))
1240 (return-from fd-stream-read-n-bytes
1241 (1+ (fd-stream-read-n-bytes stream buffer (1+ start) (1- requested)
1242 eof-error-p))))
1243 ;;
1244 (unless (zerop copy)
1245 (if (typep buffer 'system-area-pointer)
1246 (system-area-copy sap (* head vm:byte-bits)
1247 buffer (* offset vm:byte-bits)
1248 (* copy vm:byte-bits))
1249 (copy-from-system-area sap (* head vm:byte-bits)
1250 buffer (+ (* offset vm:byte-bits)
1251 (* vm:vector-data-offset
1252 vm:word-bits))
1253 (* copy vm:byte-bits)))
1254 (incf (fd-stream-ibuf-head stream) copy))
1255 (cond
1256 ((or (= copy requested)
1257 (and (not eof-error-p) (/= copy 0)))
1258 copy)
1259 (t
1260 (setf (fd-stream-ibuf-head stream) 0)
1261 (setf (fd-stream-ibuf-tail stream) 0)
1262 (setf (fd-stream-listen stream) nil)
1263 (let ((now-needed (- requested copy))
1264 (len (fd-stream-ibuf-length stream)))
1265 (declare (type index now-needed len))
1266 (cond
1267 ((> now-needed len)
1268 ;;
1269 ;; If the desired amount is greater than the stream buffer size, then
1270 ;; read directly into the destination, incrementing the start
1271 ;; accordingly. In this case, we never leave anything in the stream
1272 ;; buffer.
1273 (system:without-gcing
1274 (loop
1275 (multiple-value-bind
1276 (count err)
1277 (unix:unix-read (fd-stream-fd stream)
1278 (sap+ (if (typep buffer 'system-area-pointer)
1279 buffer
1280 (vector-sap buffer))
1281 (+ offset copy))
1282 now-needed)
1283 (declare (type (or index null) count))
1284 (unless count
1285 (error _"Error reading ~S: ~A" stream
1286 (unix:get-unix-error-msg err)))
1287 (decf now-needed count)
1288 (if eof-error-p
1289 (when (zerop count)
1290 (error 'end-of-file :stream stream))
1291 (return (- requested now-needed)))
1292 (when (zerop now-needed) (return requested))
1293 (incf offset count)))))
1294 (t
1295 ;;
1296 ;; If we want less than the buffer size, then loop trying to fill the
1297 ;; stream buffer and copying what we get into the destination. When
1298 ;; we have enough, we leave what's left in the stream buffer.
1299 (loop
1300 (multiple-value-bind
1301 (count err)
1302 (unix:unix-read (fd-stream-fd stream) sap len)
1303 (declare (type (or index null) count))
1304 (unless count
1305 (error _"Error reading ~S: ~A" stream
1306 (unix:get-unix-error-msg err)))
1307 (when (and eof-error-p (zerop count))
1308 (error 'end-of-file :stream stream))
1309
1310 (let* ((copy (min now-needed count))
1311 (copy-bits (* copy vm:byte-bits))
1312 (buffer-start-bits
1313 (* (+ offset available) vm:byte-bits)))
1314 (declare (type index copy copy-bits buffer-start-bits))
1315 (if (typep buffer 'system-area-pointer)
1316 (system-area-copy sap 0
1317 buffer buffer-start-bits
1318 copy-bits)
1319 (copy-from-system-area sap 0
1320 buffer (+ buffer-start-bits
1321 (* vm:vector-data-offset
1322 vm:word-bits))
1323 copy-bits))
1324
1325 (decf now-needed copy)
1326 (when (or (zerop now-needed) (not eof-error-p))
1327 (setf (fd-stream-ibuf-head stream) copy)
1328 (setf (fd-stream-ibuf-tail stream) count)
1329 (return (- requested now-needed)))
1330 (incf offset copy)))))))))))
1331
1332
1333 ;;;; Utility functions (misc routines, etc)
1334
1335 ;;; SET-ROUTINES -- internal
1336 ;;;
1337 ;;; Fill in the various routine slots for the given type. Input-p and
1338 ;;; output-p indicate what slots to fill. The buffering slot must be set prior
1339 ;;; to calling this routine.
1340 ;;;
1341
1342 (defun set-routines (stream type input-p output-p buffer-p &key binary-stream-p)
1343 (let ((target-type (case type
1344 ((:default unsigned-byte)
1345 '(unsigned-byte 8))
1346 (signed-byte
1347 '(signed-byte 8))
1348 (t
1349 type)))
1350 (input-type nil)
1351 (output-type nil)
1352 (input-size nil)
1353 (output-size nil))
1354
1355 (when (fd-stream-obuf-sap stream)
1356 (push (fd-stream-obuf-sap stream) *available-buffers*)
1357 (setf (fd-stream-obuf-sap stream) nil))
1358 (when (fd-stream-ibuf-sap stream)
1359 (push (fd-stream-ibuf-sap stream) *available-buffers*)
1360 (setf (fd-stream-ibuf-sap stream) nil))
1361
1362 #+unicode
1363 (when (null (fd-stream-external-format stream))
1364 (setf (fd-stream-external-format stream) :default))
1365
1366 (when input-p
1367 (multiple-value-bind
1368 (routine type size)
1369 (pick-input-routine target-type)
1370 (unless routine
1371 (error _"Could not find any input routine for ~S" target-type))
1372 (setf (fd-stream-ibuf-sap stream) (next-available-buffer))
1373 (setf (fd-stream-ibuf-length stream) bytes-per-buffer)
1374 (setf (fd-stream-ibuf-tail stream) 0)
1375 (if (subtypep type 'character)
1376 (setf (fd-stream-in stream) routine
1377 (fd-stream-bin stream) #'ill-bin)
1378 (setf (fd-stream-in stream) (if (and binary-stream-p
1379 (eql size 1))
1380 (pick-input-routine 'character)
1381 #'ill-in)
1382 (fd-stream-bin stream) routine))
1383 (when (or (eql size 1)
1384 (eql size 2)
1385 (eql size 4))
1386 ;; Support for n-byte operations on 8-, 16-, and 32-bit streams
1387 (setf (fd-stream-n-bin stream) #'fd-stream-read-n-bytes)
1388 (when (and buffer-p (eql size 1)
1389 (or
1390 ;; FIXME: Do this better. We want to check for
1391 ;; (unsigned-byte 8). The 8 is unnecessary
1392 ;; since we already have size = 1.
1393 (or (eq 'unsigned-byte (and (consp type) (car type)))
1394 (eq type :default))
1395 (eq type 'character)))
1396 ;; We only create this buffer for streams of type
1397 ;; (unsigned-byte 8) or character streams with an external
1398 ;; format of :iso8859-1. Because there's no buffer, the
1399 ;; other element-types will dispatch to the appropriate
1400 ;; input (output) routine in fast-read-byte/fast-read-char.
1401 (when *enable-stream-buffer-p*
1402 (setf (lisp-stream-in-buffer stream)
1403 (make-array in-buffer-length
1404 :element-type '(unsigned-byte 8)))
1405 #+unicode
1406 (when (and (eq type 'character)
1407 (not (eq :iso8859-1 (fd-stream-external-format stream))))
1408 ;; For character streams, we create the string-buffer so
1409 ;; we can convert all available octets at once instead
1410 ;; of for each character. The string is one element
1411 ;; longer than in-buffer-length to leave room for
1412 ;; unreading.
1413 ;;
1414 ;; For ISO8859-1, we don't want this because it's very
1415 ;; easy and quick to convert octets to iso8859-1. (See
1416 ;; FAST-READ-CHAR.)
1417 (setf (lisp-stream-string-buffer stream)
1418 (make-string (1+ in-buffer-length)))
1419 (setf (lisp-stream-string-buffer-len stream) 0)
1420 (setf (lisp-stream-string-index stream) 0)))))
1421 (setf input-size size)
1422 (setf input-type type)))
1423
1424 (when output-p
1425 (multiple-value-bind
1426 (routine type size)
1427 (pick-output-routine target-type (fd-stream-buffering stream))
1428 (unless routine
1429 (error _"Could not find any output routine for ~S buffered ~S."
1430 (fd-stream-buffering stream)
1431 target-type))
1432 (setf (fd-stream-obuf-sap stream) (next-available-buffer))
1433 (setf (fd-stream-obuf-length stream) bytes-per-buffer)
1434 (setf (fd-stream-obuf-tail stream) 0)
1435 (if (subtypep type 'character)
1436 (setf (fd-stream-out stream) routine
1437 (fd-stream-bout stream) #'ill-bout)
1438 (setf (fd-stream-out stream)
1439 (or (if (eql size 1)
1440 (pick-output-routine 'base-char
1441 (fd-stream-buffering stream)))
1442 #'ill-out)
1443 (fd-stream-bout stream) routine))
1444 (setf (fd-stream-sout stream)
1445 (if (eql size 1) #'fd-sout #'ill-out))
1446 (setf (fd-stream-char-pos stream) 0)
1447 (setf output-size size)
1448 (setf output-type type)))
1449
1450 (when (and input-size output-size
1451 (not (eql input-size output-size)))
1452 (error _"Element sizes for input (~S:~S) and output (~S:~S) differ?"
1453 input-type input-size
1454 output-type output-size))
1455 (setf (fd-stream-element-size stream)
1456 (or input-size output-size))
1457
1458 (setf (fd-stream-element-type stream)
1459 (cond ((equal input-type output-type)
1460 input-type)
1461 ((null output-type)
1462 input-type)
1463 ((null input-type)
1464 output-type)
1465 ((subtypep input-type output-type)
1466 input-type)
1467 ((subtypep output-type input-type)
1468 output-type)
1469 (t
1470 (error _"Input type (~S) and output type (~S) are unrelated?"
1471 input-type
1472 output-type))))))
1473
1474 ;;; REVERT-FILE -- internal
1475 ;;;
1476 ;;; Revert a file, if possible; otherwise do nothing. Used during
1477 ;;; CLOSE when the abort flag is set.
1478 ;;;
1479 (defun revert-file (filename original)
1480 (declare (type simple-base-string filename)
1481 (type (or simple-base-string null) original))
1482 (when original
1483 (multiple-value-bind (okay err)
1484 (unix:unix-rename original filename)
1485 (unless okay
1486 (cerror "Go on as if nothing bad happened."
1487 "Could not restore ~S to its original contents: ~A"
1488 filename (unix:get-unix-error-msg err))))))
1489
1490 ;;; DELETE-ORIGINAL -- internal
1491 ;;;
1492 ;;; Delete a backup file. Used during CLOSE.
1493 ;;;
1494 (defun delete-original (filename original)
1495 (declare (type simple-base-string filename)
1496 (type (or simple-base-string null) original))
1497 (when original
1498 (multiple-value-bind (okay err) (unix:unix-unlink original)
1499 (unless okay
1500 (cerror "Go on as if nothing bad happened."
1501 "Could not delete ~S during close of ~S: ~A"
1502 original filename (unix:get-unix-error-msg err))))))
1503
1504 ;;; FD-STREAM-MISC-ROUTINE -- input
1505 ;;;
1506 ;;; Handle the various misc operations on fd-stream.
1507 ;;;
1508 (defun fd-stream-misc-routine (stream operation &optional arg1 arg2)
1509 (declare (ignore arg2))
1510 (case operation
1511 (:listen
1512 (or (not (eql (fd-stream-ibuf-head stream)
1513 (fd-stream-ibuf-tail stream)))
1514 (fd-stream-listen stream)
1515 (setf (fd-stream-listen stream)
1516 (eql (alien:with-alien ((read-fds (alien:struct unix:fd-set)))
1517 (unix:fd-zero read-fds)
1518 (unix:fd-set (fd-stream-fd stream) read-fds)
1519 (unix:unix-fast-select (1+ (fd-stream-fd stream))
1520 (alien:addr read-fds) nil nil
1521 0 0))
1522 1))))
1523 (:unread
1524 #-unicode
1525 (setf (fd-stream-unread stream) arg1)
1526 #+unicode
1527 (cond ((lisp-stream-string-buffer stream)
1528 (if (zerop (lisp-stream-string-index stream))
1529 (setf (fd-stream-unread stream) arg1)
1530 (decf (lisp-stream-string-index stream))))
1531 (t
1532 (if (zerop (fd-stream-last-char-read-size stream))
1533 (setf (fd-stream-unread stream) arg1)
1534 (decf (fd-stream-ibuf-head stream)
1535 (fd-stream-last-char-read-size stream)))))
1536 ;; Paul says:
1537 ;;
1538 ;; Not needed for unicode when unreading is implemented by backing up in
1539 ;; the buffer (e.g., with last-char-read-size...)
1540 ;;
1541 ;; (AFAICS there's nothing wrong with setting it there, but it
1542 ;; screws up read-interactive in my toplevel command thing -
1543 ;; leaves it expecting to read arguments when it shouldn't,
1544 ;; because LISTEN returns T when there's no input pending, but I
1545 ;; don't understand why...)
1546 #-unicode
1547 (setf (fd-stream-listen stream) t))
1548 (:close
1549 (cond (arg1
1550 ;; We got us an abort on our hands.
1551 (when (fd-stream-handler stream)
1552 (system:remove-fd-handler (fd-stream-handler stream))
1553 (setf (fd-stream-handler stream) nil))
1554 (when (and (fd-stream-file stream) (fd-stream-obuf-sap stream))
1555 (revert-file (fd-stream-file stream)
1556 (fd-stream-original stream))))
1557 (t
1558 #+(and unicode (not unicode-bootstrap))
1559 (when (and (output-stream-p stream)
1560 (eq (stream-element-type stream) 'character))
1561 ;; For output character streams, we need to flush out
1562 ;; any state that the external format might have.
1563 #+nil (format *debug-io* "state = ~S~%" (fd-stream-co-state stream))
1564 (funcall (ef-flush (fd-stream-external-format stream))
1565 stream))
1566 (fd-stream-misc-routine stream :finish-output)
1567 (when (fd-stream-delete-original stream)
1568 (delete-original (fd-stream-file stream)
1569 (fd-stream-original stream)))))
1570 (when (fboundp 'cancel-finalization)
1571 (cancel-finalization stream))
1572 (unix:unix-close (fd-stream-fd stream))
1573 (when (fd-stream-obuf-sap stream)
1574 (push (fd-stream-obuf-sap stream) *available-buffers*)
1575 (setf (fd-stream-obuf-sap stream) nil))
1576 (when (fd-stream-ibuf-sap stream)
1577 (push (fd-stream-ibuf-sap stream) *available-buffers*)
1578 (setf (fd-stream-ibuf-sap stream) nil))
1579 (lisp::set-closed-flame stream))
1580 (:clear-input
1581 (setf (fd-stream-unread stream) nil) ;;@@
1582 #+unicode (setf (fd-stream-last-char-read-size stream) 0)
1583 (setf (fd-stream-ibuf-head stream) 0)
1584 (setf (fd-stream-ibuf-tail stream) 0)
1585 (catch 'eof-input-catcher
1586 (loop
1587 (multiple-value-bind
1588 (count errno)
1589 (alien:with-alien ((read-fds (alien:struct unix:fd-set)))
1590 (unix:fd-zero read-fds)
1591 (unix:fd-set (fd-stream-fd stream) read-fds)
1592 (unix:unix-fast-select (1+ (fd-stream-fd stream))
1593 (alien:addr read-fds) nil nil 0 0))
1594 (cond ((eql count 1)
1595 (do-input stream)
1596 (setf (fd-stream-ibuf-head stream) 0)
1597 (setf (fd-stream-ibuf-tail stream) 0))
1598 ((and (not count) (eql errno unix:eintr)))
1599 (t
1600 (return t)))))))
1601 (:force-output
1602 (flush-output-buffer stream))
1603 (:finish-output
1604 (flush-output-buffer stream)
1605 (do ()
1606 ((null (fd-stream-output-later stream)))
1607 (system:serve-all-events)))
1608 (:element-type
1609 (fd-stream-element-type stream))
1610 (:interactive-p
1611 (unix:unix-isatty (fd-stream-fd stream)))
1612 (:line-length
1613 80)
1614 (:charpos
1615 (fd-stream-char-pos stream))
1616 (:file-length
1617 (unless (fd-stream-file stream)
1618 (error 'simple-type-error
1619 :datum stream
1620 :expected-type 'file-stream
1621 :format-control "~s is not a stream associated with a file."
1622 :format-arguments (list stream)))
1623 (multiple-value-bind
1624 (okay dev ino mode nlink uid gid rdev size
1625 atime mtime ctime blksize blocks)
1626 (unix:unix-fstat (fd-stream-fd stream))
1627 (declare (ignore ino nlink uid gid rdev
1628 atime mtime ctime blksize blocks))
1629 (unless okay
1630 (error 'simple-file-error
1631 :format-control "Error fstating ~S: ~A"
1632 :format-arguments (list stream (unix:get-unix-error-msg dev))))
1633 (if (zerop mode)
1634 nil
1635 (values (truncate size (fd-stream-element-size stream))))))
1636 (:file-position
1637 (fd-stream-file-position stream arg1))))
1638
1639
1640 ;;; FD-STREAM-FILE-POSITION -- internal.
1641 ;;;
1642 (defun fd-stream-file-position (stream &optional newpos)
1643 (declare (type fd-stream stream)
1644 (type (or (integer 0) (member nil :start :end)) newpos))
1645 (if (null newpos)
1646 (system:without-interrupts
1647 ;; First, find the position of the UNIX file descriptor in the file.
1648 (multiple-value-bind
1649 (posn errno)
1650 (unix:unix-lseek (fd-stream-fd stream) 0 unix:l_incr)
1651 (declare (type (or (integer 0) null) posn))
1652 (cond (posn
1653 ;; Adjust for buffered output:
1654 ;; If there is any output buffered, the *real* file position
1655 ;; will be larger than reported by lseek because lseek
1656 ;; obviously cannot take into account output we have not
1657 ;; sent yet.
1658 (dolist (later (fd-stream-output-later stream))
1659 (incf posn (- (the index (caddr later))
1660 (the index (cadr later)))))
1661 (incf posn (fd-stream-obuf-tail stream))
1662 ;; Adjust for unread input:
1663 ;; If there is any input read from UNIX but not supplied to
1664 ;; the user of the stream, the *real* file position will
1665 ;; smaller than reported, because we want to look like the
1666 ;; unread stuff is still available.
1667 #-unicode
1668 (decf posn (- (fd-stream-ibuf-tail stream)
1669 (fd-stream-ibuf-head stream)))
1670 #+unicode
1671 (if (fd-stream-string-buffer stream)
1672 ;; The string buffer contains Lisp characters,
1673 ;; not octets! To figure out how many octets
1674 ;; have not been already supplied, we need to
1675 ;; convert them back to the encoded format and
1676 ;; count the number of octets.
1677 (decf posn
1678 (length (string-encode (fd-stream-string-buffer stream)
1679 (fd-stream-external-format stream)
1680 (fd-stream-string-index stream)
1681 (fd-stream-string-buffer-len stream))))
1682 (decf posn (- (fd-stream-ibuf-tail stream)
1683 (fd-stream-ibuf-head stream))))
1684 (when (fd-stream-unread stream) ;;@@
1685 (decf posn))
1686 ;; Divide bytes by element size.
1687 (truncate posn (fd-stream-element-size stream)))
1688 ((eq errno unix:espipe)
1689 nil)
1690 (t
1691 (system:with-interrupts
1692 (error _"Error lseek'ing ~S: ~A"
1693 stream
1694 (unix:get-unix-error-msg errno)))))))
1695 (let ((offset 0)
1696 origin)
1697 (declare (type (integer 0) offset))
1698 ;; Make sure we don't have any output pending, because if we move the
1699 ;; file pointer before writing this stuff, it will be written in the
1700 ;; wrong location.
1701 (flush-output-buffer stream)
1702 (do ()
1703 ((null (fd-stream-output-later stream)))
1704 (system:serve-all-events))
1705 ;; Clear out any pending input to force the next read to go to the
1706 ;; disk.
1707 (setf (fd-stream-unread stream) nil) ;;@@
1708 #+unicode
1709 (progn
1710 (setf (fd-stream-last-char-read-size stream) 0)
1711 (setf (fd-stream-string-index stream)
1712 (fd-stream-string-buffer-len stream)))
1713 (setf (fd-stream-ibuf-head stream) 0)
1714 (setf (fd-stream-ibuf-tail stream) 0)
1715 ;; Trash cached value for listen, so that we check next time.
1716 (setf (fd-stream-listen stream) nil)
1717 ;; Now move it.
1718 (cond ((eq newpos :start)
1719 (setf offset 0
1720 origin unix:l_set))
1721 ((eq newpos :end)
1722 (setf offset 0
1723 origin unix:l_xtnd))
1724 ((typep newpos '(integer 0))
1725 (setf offset (* newpos (fd-stream-element-size stream))
1726 origin unix:l_set))
1727 (t
1728 (error _"Invalid position given to file-position: ~S" newpos)))
1729 (multiple-value-bind
1730 (posn errno)
1731 (unix:unix-lseek (fd-stream-fd stream) offset origin)
1732 (cond (posn
1733 t)
1734 ((eq errno unix:espipe)
1735 nil)
1736 (t
1737 (error _"Error lseek'ing ~S: ~A"
1738 stream
1739 (unix:get-unix-error-msg errno))))))))
1740
1741
1742
1743 ;;;; Creation routines (MAKE-FD-STREAM and OPEN)
1744
1745 ;;; MAKE-FD-STREAM -- Public.
1746 ;;;
1747 ;;; Returns a FD-STREAM on the given file.
1748 ;;;
1749 (defun make-fd-stream (fd
1750 &key
1751 (input nil input-p)
1752 (output nil output-p)
1753 (element-type 'base-char)
1754 (buffering :full)
1755 timeout
1756 file
1757 original
1758 delete-original
1759 pathname
1760 input-buffer-p
1761 (name (if file
1762 (format nil "file ~S" file)
1763 (format nil "descriptor ~D" fd)))
1764 auto-close
1765 (external-format :default)
1766 binary-stream-p)
1767 (declare (type index fd) (type (or index null) timeout)
1768 (type (member :none :line :full) buffering))
1769 _N"Create a stream for the given unix file descriptor.
1770 If input is non-nil, allow input operations.
1771 If output is non-nil, allow output operations.
1772 If neither input nor output are specified, default to allowing input.
1773 Element-type indicates the element type to use (as for open).
1774 Buffering indicates the kind of buffering to use.
1775 Timeout (if true) is the number of seconds to wait for input. If NIL (the
1776 default), then wait forever. When we time out, we signal IO-TIMEOUT.
1777 File is the name of the file (will be returned by PATHNAME).
1778 Name is used to identify the stream when printed."
1779 (cond ((not (or input-p output-p))
1780 (setf input t))
1781 ((not (or input output))
1782 (error _"File descriptor must be opened either for input or output.")))
1783 (let ((stream (if binary-stream-p
1784 (%make-binary-text-stream :fd fd
1785 :name name
1786 :file file
1787 :original original
1788 :delete-original delete-original
1789 :pathname pathname
1790 :buffering buffering
1791 :timeout timeout)
1792 (%make-fd-stream :fd fd
1793 :name name
1794 :file file
1795 :original original
1796 :delete-original delete-original
1797 :pathname pathname
1798 :buffering buffering
1799 :timeout timeout))))
1800 ;; FIXME: setting the external format here should be better
1801 ;; integrated into set-routines. We do it before so that
1802 ;; set-routines can create an in-buffer if appropriate. But we
1803 ;; need to do it after to put the correct input routines for the
1804 ;; external format.
1805 ;;
1806 ;;#-unicode-bootstrap ; fails in stream-reinit otherwise
1807 #+(and unicode (not unicode-bootstrap))
1808 (%set-fd-stream-external-format stream external-format nil)
1809 (set-routines stream element-type input output input-buffer-p
1810 :binary-stream-p binary-stream-p)
1811 #+(and unicode (not unicode-bootstrap))
1812 (%set-fd-stream-external-format stream external-format nil)
1813 (when (and auto-close (fboundp 'finalize))
1814 (finalize stream
1815 #'(lambda ()
1816 (unix:unix-close fd)
1817 (format *terminal-io* "** Closed ~A~%" name)
1818 (when original
1819 (revert-file file original)))))
1820 stream))
1821
1822
1823 ;;; PICK-BACKUP-NAME -- internal
1824 ;;;
1825 ;;; Pick a name to use for the backup file.
1826 ;;;
1827 (defvar *backup-extension* ".BAK"
1828 _N"This is a string that OPEN tacks on the end of a file namestring to produce
1829 a name for the :if-exists :rename-and-delete and :rename options. Also,
1830 this can be a function that takes a namestring and returns a complete
1831 namestring.")
1832 ;;;
1833 (defun pick-backup-name (name)
1834 (declare (type simple-string name))
1835 (let ((ext *backup-extension*))
1836 (etypecase ext
1837 (simple-string (concatenate 'simple-string name ext))
1838 (function (funcall ext name)))))
1839
1840 ;;; NEXT-VERSION -- internal
1841 ;;;
1842 ;;; Find the next available versioned name for a file.
1843 ;;;
1844 (defun next-version (name)
1845 (declare (type simple-string name))
1846 (let* ((sep (position #\/ name :from-end t))
1847 (base (if sep (subseq name 0 (1+ sep)) ""))
1848 (dir (unix:open-dir base)))
1849 (multiple-value-bind (name type version)
1850 (extract-name-type-and-version name (if sep (1+ sep) 0) (length name))
1851 (let ((version (if (symbolp version) 1 (1+ version)))
1852 (match (if type
1853 (concatenate 'string name "." type ".~")
1854 (concatenate 'string name ".~"))))
1855 (when dir
1856 (unwind-protect
1857 (loop
1858 (let ((name (unix:read-dir dir)))
1859 (cond ((null name) (return))
1860 ((and (> (length name) (length match))
1861 (string= name match :end1 (length match)))
1862 (multiple-value-bind (v e)
1863 (parse-integer name :start (length match)
1864 :junk-allowed t)
1865 (when (and v
1866 (= (length name) (1+ e))
1867 (char= (schar name e) #\~))
1868 (setq version (max version (1+ v)))))))))
1869 (unix:close-dir dir)))
1870 (concatenate 'string base
1871 match (quick-integer-to-string version) "~")))))
1872
1873 ;;; ASSURE-ONE-OF -- internal
1874 ;;;
1875 ;;; Assure that the given arg is one of the given list of valid things.
1876 ;;; Allow the user to fix any problems.
1877 ;;;
1878 (defun assure-one-of (item list what)
1879 (unless (member item list)
1880 (loop
1881 (cerror "Enter new value for ~*~S"
1882 "~S is invalid for ~S. Must be one of~{ ~S~}"
1883 item
1884 what
1885 list)
1886 (format (the stream *query-io*) "Enter new value for ~S: " what)
1887 (force-output *query-io*)
1888 (setf item (read *query-io*))
1889 (when (member item list)
1890 (return))))
1891 item)
1892
1893 ;;; DO-OLD-RENAME -- Internal
1894 ;;;
1895 ;;; Rename Namestring to Original. First, check if we have write access,
1896 ;;; since we don't want to trash unwritable files even if we technically can.
1897 ;;; We return true if we succeed in renaming.
1898 ;;;
1899 (defun do-old-rename (namestring original)
1900 (unless (unix:unix-access namestring unix:w_ok)
1901 (cerror "Try to rename it anyway." "File ~S is not writable." namestring))
1902 (multiple-value-bind
1903 (okay err)
1904 (unix:unix-rename namestring original)
1905 (cond (okay t)
1906 (t
1907 (cerror "Use :SUPERSEDE instead."
1908 "Could not rename ~S to ~S: ~A."
1909 namestring
1910 original
1911 (unix:get-unix-error-msg err))
1912 nil))))
1913
1914 ;;; FD-OPEN -- Internal
1915 ;;;
1916 ;;; Open a file.
1917 ;;;
1918 (defun fd-open (pathname direction if-exists if-exists-given
1919 if-does-not-exist if-does-not-exist-given)
1920 (declare (type pathname pathname)
1921 (type (member :input :output :io :probe) direction)
1922 (type (member :error :new-version :rename :rename-and-delete
1923 :overwrite :append :supersede nil) if-exists)
1924 (type (member :error :create nil) if-does-not-exist))
1925 (multiple-value-bind (input output mask)
1926 (ecase direction
1927 (:input (values t nil unix:o_rdonly))
1928 (:output (values nil t unix:o_wronly))
1929 (:io (values t t unix:o_rdwr))
1930 (:probe (values t nil unix:o_rdonly)))
1931 (declare (type index mask))
1932 ;; Process if-exists argument if we are doing any output.
1933 (cond (output
1934 (unless if-exists-given
1935 (setf if-exists
1936 (if (eq (pathname-version pathname) :newest)
1937 :new-version
1938 :error)))
1939 (case if-exists
1940 ((:error nil)
1941 (setf mask (logior mask unix:o_excl)))
1942 ((:new-version :rename :rename-and-delete)
1943 (setf mask (logior mask unix:o_creat)))
1944 (:supersede
1945 (setf mask (logior mask unix:o_trunc)))))
1946 (t
1947 (setf if-exists nil))) ; :ignore-this-arg
1948
1949 (unless if-does-not-exist-given
1950 (setf if-does-not-exist
1951 (cond ((eq direction :input) :error)
1952 ((and output
1953 (member if-exists '(:overwrite :append)))
1954 :error)
1955 ((eq direction :probe)
1956 nil)
1957 (t
1958 :create))))
1959 (if (eq if-does-not-exist :create)
1960 (setf mask (logior mask unix:o_creat)))
1961
1962 (let ((name (cond ((unix-namestring pathname input))
1963 ((and input (eq if-does-not-exist :create))
1964 (unix-namestring pathname nil)))))
1965 (let ((original (cond ((eq if-exists :new-version)
1966 (next-version name))
1967 ((member if-exists '(:rename :rename-and-delete))
1968 (pick-backup-name name))))
1969 (delete-original (eq if-exists :rename-and-delete))
1970 (mode #o666))
1971 (when original
1972 ;; We are doing a :rename or :rename-and-delete.
1973 ;; Determine if the file already exists, make sure the original
1974 ;; file is not a directory and keep the mode
1975 (let ((exists
1976 (and name
1977 (multiple-value-bind
1978 (okay err/dev inode orig-mode)
1979 (unix:unix-stat name)
1980 (declare (ignore inode)
1981 (type (or index null) orig-mode))
1982 (cond
1983 (okay
1984 (when (and output (= (logand orig-mode #o170000)
1985 #o40000))
1986 (error 'simple-file-error
1987 :pathname pathname
1988 :format-control
1989 "Cannot open ~S for output: Is a directory."
1990 :format-arguments (list name)))
1991 (setf mode (logand orig-mode #o777))
1992 t)
1993 ((eql err/dev unix:enoent)
1994 nil)
1995 (t
1996 (error 'simple-file-error
1997 :pathname pathname
1998 :format-control "Cannot find ~S: ~A"
1999 :format-arguments
2000 (list name
2001 (unix:get-unix-error-msg err/dev)))))))))
2002 (unless (and exists
2003 (do-old-rename name original))
2004 (setf original nil)
2005 (setf delete-original nil)
2006 ;; In order to use SUPERSEDE instead, we have
2007 ;; to make sure unix:o_creat corresponds to
2008 ;; if-does-not-exist. unix:o_creat was set
2009 ;; before because of if-exists being :rename.
2010 (unless (eq if-does-not-exist :create)
2011 (setf mask (logior (logandc2 mask unix:o_creat)
2012 unix:o_trunc)))
2013 (setf if-exists :supersede))))
2014
2015 ;; Okay, now we can try the actual open.
2016 (loop
2017 (multiple-value-bind (fd errno)
2018 (if name
2019 (unix:unix-open name mask mode)
2020 (values nil unix:enoent))
2021 (cond ((fixnump fd)
2022 (when (eq if-exists :append)
2023 (unix:unix-lseek fd 0 unix:l_xtnd)) ; SEEK_END
2024 (return (values fd name original delete-original)))
2025 ((eql errno unix:enoent)
2026 (case if-does-not-exist
2027 (:error
2028 (cerror "Return NIL."
2029 'simple-file-error
2030 :pathname pathname
2031 :format-control "Error opening ~S, ~A."
2032 :format-arguments
2033 (list pathname
2034 (unix:get-unix-error-msg errno))))
2035 (:create
2036 (cerror "Return NIL."
2037 'simple-file-error
2038 :pathname pathname
2039 :format-control
2040 "Error creating ~S, path does not exist."
2041 :format-arguments (list pathname))))
2042 (return nil))
2043 ((eql errno unix:eexist)
2044 (unless (eq nil if-exists)
2045 (cerror "Return NIL."
2046 'simple-file-error
2047 :pathname pathname
2048 :format-control "Error opening ~S, ~A."
2049 :format-arguments
2050 (list pathname
2051 (unix:get-unix-error-msg errno))))
2052 (return nil))
2053 ((eql errno unix:eacces)
2054 (cerror "Try again."
2055 'simple-file-error
2056 :pathname pathname
2057 :format-control "Error opening ~S, ~A."
2058 :format-arguments
2059 (list pathname
2060 (unix:get-unix-error-msg errno))))
2061 (t
2062 (cerror "Return NIL."
2063 'simple-file-error
2064 :pathname pathname
2065 :format-control "Error opening ~S, ~A."
2066 :format-arguments
2067 (list pathname
2068 (unix:get-unix-error-msg errno)))
2069 (return nil)))))))))
2070
2071 ;;; OPEN-FD-STREAM -- Internal
2072 ;;;
2073 ;;; Open an fd-stream connected to a file.
2074 ;;;
2075 (defun open-fd-stream (pathname &key (direction :input)
2076 (element-type 'base-char)
2077 (if-exists nil if-exists-given)
2078 (if-does-not-exist nil if-does-not-exist-given)
2079 (external-format :default)
2080 class)
2081 (declare (type pathname pathname)
2082 (type (member :input :output :io :probe) direction)
2083 (type (member :error :new-version :rename :rename-and-delete
2084 :overwrite :append :supersede nil) if-exists)
2085 (type (member :error :create nil) if-does-not-exist))
2086 (multiple-value-bind (fd namestring original delete-original)
2087 (fd-open pathname direction if-exists if-exists-given
2088 if-does-not-exist if-does-not-exist-given)
2089 (when fd
2090 (case direction
2091 ((:input :output :io)
2092 ;; We use the :class option to tell us if we want a
2093 ;; binary-text stream or not.
2094 (make-fd-stream fd
2095 :input (member direction '(:input :io))
2096 :output (member direction '(:output :io))
2097 :element-type element-type
2098 :file namestring
2099 :original original
2100 :delete-original delete-original
2101 :pathname pathname
2102 :input-buffer-p t
2103 :auto-close t
2104 :external-format external-format
2105 :binary-stream-p class))
2106 (:probe
2107 (let ((stream (%make-fd-stream :name namestring :fd fd
2108 :pathname pathname
2109 :element-type element-type)))
2110 (close stream)
2111 stream))))))
2112
2113 ;;; OPEN -- public
2114 ;;;
2115 ;;; Open the given file.
2116 ;;;
2117 (defun open (filename &rest options
2118 &key (direction :input)
2119 (element-type 'base-char element-type-given)
2120 (if-exists nil if-exists-given)
2121 (if-does-not-exist nil if-does-not-exist-given)
2122 (external-format :default)
2123 class mapped input-handle output-handle
2124 &allow-other-keys
2125 &aux ; Squelch assignment warning.
2126 (options options)
2127 (direction direction)
2128 (if-does-not-exist if-does-not-exist)
2129 (if-exists if-exists))
2130 _N"Return a stream which reads from or writes to Filename.
2131 Defined keywords:
2132 :direction - one of :input, :output, :io, or :probe
2133 :element-type - Type of object to read or write, default BASE-CHAR
2134 :if-exists - one of :error, :new-version, :rename, :rename-and-delete,
2135 :overwrite, :append, :supersede or nil
2136 :if-does-not-exist - one of :error, :create or nil
2137 :external-format - an external format name
2138 See the manual for details."
2139 (declare (ignore element-type external-format input-handle output-handle))
2140
2141 ;; OPEN signals a file-error if the filename is wild.
2142 (when (wild-pathname-p filename)
2143 (error 'file-error :pathname filename))
2144
2145 ;; First, make sure that DIRECTION is valid. Allow it to be changed if not.
2146 (setq direction
2147 (assure-one-of direction
2148 '(:input :output :io :probe)
2149 :direction))
2150 (setf (getf options :direction) direction)
2151
2152 (when (and if-exists-given (member direction '(:output :io)))
2153 (setq if-exists
2154 (assure-one-of if-exists
2155 '(:error :new-version :rename
2156 :rename-and-delete :overwrite
2157 :append :supersede nil)
2158 :if-exists))
2159 (setf (getf options :if-exists) if-exists))
2160
2161 (when if-does-not-exist-given
2162 (setq if-does-not-exist
2163 (assure-one-of if-does-not-exist
2164 '(:error :create nil)
2165 :if-does-not-exist))
2166 (setf (getf options :if-does-not-exist) if-does-not-exist))
2167
2168 (let ((filespec (pathname filename))
2169 (options (copy-list options))
2170 (class (or class 'fd-stream)))
2171 (cond ((eq class 'fd-stream)
2172 (remf options :class)
2173 (remf options :mapped)
2174 (remf options :input-handle)
2175 (remf options :output-handle)
2176 (apply #'open-fd-stream filespec options))
2177 ((eq class 'binary-text-stream)
2178 ;; Like fd-stream, but binary and text allowed. This is
2179 ;; indicated by leaving the :class option around for
2180 ;; open-fd-stream to see.
2181 (remf options :mapped)
2182 (remf options :input-handle)
2183 (remf options :output-handle)
2184 (apply #'open-fd-stream filespec options))
2185 ((subtypep class 'stream:simple-stream)
2186 (when element-type-given
2187 (cerror "Do it anyway."
2188 "Can't create simple-streams with an element-type."))
2189 (when (and (eq class 'stream:file-simple-stream) mapped)
2190 (setq class 'stream:mapped-file-simple-stream)
2191 (setf (getf options :class) 'stream:mapped-file-simple-stream))
2192 (when (subtypep class 'stream:file-simple-stream)
2193 (when (eq direction :probe)
2194 (setq class 'stream:probe-simple-stream)))
2195 (apply #'make-instance class :filename filespec options))
2196 ((subtypep class 'ext:fundamental-stream)
2197 (remf options :class)
2198 (remf options :mapped)
2199 (remf options :input-handle)
2200 (remf options :output-handle)
2201 (let ((stream (apply #'open-fd-stream filespec options)))
2202 (when stream
2203 (make-instance class :lisp-stream stream))))
2204 (t
2205 (error _"Unable to open streams of class ~S." class)))))
2206
2207 ;;;; Initialization.
2208
2209 (defvar *tty* nil
2210 _N"The stream connected to the controlling terminal or NIL if there is none.")
2211 (defvar *stdin* nil
2212 _N"The stream connected to the standard input (file descriptor 0).")
2213 (defvar *stdout* nil
2214 _N"The stream connected to the standard output (file descriptor 1).")
2215 (defvar *stderr* nil
2216 _N"The stream connected to the standard error output (file descriptor 2).")
2217
2218 ;;; STREAM-INIT -- internal interface
2219 ;;;
2220 ;;; Called when the cold load is first started up.
2221 ;;;
2222 (defun stream-init ()
2223 (stream-reinit)
2224 (setf *terminal-io* (make-synonym-stream '*tty*))
2225 (setf *standard-output* (make-synonym-stream '*stdout*))
2226 (setf *standard-input*
2227 (make-two-way-stream (make-synonym-stream '*stdin*)
2228 *standard-output*))
2229 (setf *error-output* (make-synonym-stream '*stderr*))
2230 (setf *query-io* (make-synonym-stream '*terminal-io*))
2231 (setf *debug-io* *query-io*)
2232 (setf *trace-output* *standard-output*)
2233 nil)
2234
2235 ;;; STREAM-REINIT -- internal interface
2236 ;;;
2237 ;;; Called whenever a saved core is restarted.
2238 ;;;
2239 (defun stream-reinit ()
2240 (setf *available-buffers* nil)
2241 (setf *stdin*
2242 (make-fd-stream 0 :name "Standard Input" :input t :buffering :line
2243 :external-format :iso8859-1))
2244 (setf *stdout*
2245 (make-fd-stream 1 :name "Standard Output" :output t :buffering :line
2246 :external-format :iso8859-1))
2247 (setf *stderr*
2248 (make-fd-stream 2 :name "Standard Error" :output t :buffering :line
2249 :external-format :iso8859-1))
2250 (let ((tty (and (not *batch-mode*)
2251 (unix:unix-open "/dev/tty" unix:o_rdwr #o666))))
2252 (setf *tty*
2253 (if tty
2254 (make-fd-stream tty :name "the Terminal" :input t :output t
2255 :buffering :line :auto-close t
2256 :external-format :iso8859-1)
2257 (make-two-way-stream *stdin* *stdout*))))
2258 nil)
2259
2260
2261 ;;;; Beeping.
2262
2263 (defun default-beep-function (stream)
2264 (write-char #\bell stream)
2265 (finish-output stream))
2266
2267 (defvar *beep-function* #'default-beep-function
2268 _N"This is called in BEEP to feep the user. It takes a stream.")
2269
2270 (defun beep (&optional (stream *terminal-io*))
2271 (funcall *beep-function* stream))
2272
2273
2274 ;;; File-Name -- internal interface
2275 ;;;
2276 ;;; Kind of like File-Position, but is an internal hack used by the filesys
2277 ;;; stuff to get and set the file name.
2278 ;;;
2279 (defun file-name (stream &optional new-name)
2280 (typecase stream
2281 (stream:simple-stream
2282 (if new-name
2283 (stream::%file-rename stream new-name)
2284 (stream::%file-name stream)))
2285 (fd-stream
2286 (cond (new-name
2287 (setf (fd-stream-pathname stream) new-name)
2288 (setf (fd-stream-file stream)
2289 (unix-namestring new-name nil))
2290 t)
2291 (t
2292 (fd-stream-pathname stream))))))
2293
2294
2295
2296 #+unicode
2297 (stream::def-ef-macro ef-strlen (extfmt lisp stream::+ef-max+ stream::+ef-str+)
2298 ;; While it would be nice not to have to call CHAR-TO-OCTETS to
2299 ;; figure out the length when the external format has fixed size
2300 ;; outputs, we can't. For example, utf16 will output a BOM, which
2301 ;; wouldn't be reflected in the count if we don't call
2302 ;; CHAR-TO-OCTETS.
2303 `(lambda (stream object &aux (count 0))
2304 (declare (type fd-stream stream)
2305 (type (or character string) object)
2306 (type (and fixnum unsigned-byte) count)
2307 #|(optimize (speed 3) (space 0) (debug 0) (safety 0))|#)
2308 (labels ((efstate (state)
2309 (stream::copy-state ,extfmt state))
2310 (eflen (char)
2311 (stream::char-to-octets ,extfmt char
2312 (fd-stream-co-state stream)
2313 (lambda (byte)
2314 (declare (ignore byte))
2315 (incf count)))))
2316 (let* ((co-state (fd-stream-co-state stream))
2317 (old-ef-state (efstate (cdr (fd-stream-co-state stream))))
2318 (old-state (cons (car co-state) old-ef-state)))
2319 (etypecase object
2320 (character (eflen object))
2321 (string (dovector (ch object) (eflen ch))))
2322 ;; Restore state
2323 (setf (fd-stream-co-state stream) old-state)
2324 count))))
2325
2326
2327 (defun file-string-length (stream object)
2328 (declare (type (or string character) object)
2329 (type (or file-stream broadcast-stream stream:simple-stream) stream))
2330 _N"Return the delta in Stream's FILE-POSITION that would be caused by writing
2331 Object to Stream. Non-trivial only in implementations that support
2332 international character sets."
2333 (typecase stream
2334 (stream:simple-stream (stream::%file-string-length stream object))
2335 (broadcast-stream
2336 ;; CLHS says we must return 1 in this case
2337 1)
2338 #+unicode
2339 (t (funcall (ef-strlen (fd-stream-external-format stream))
2340 stream object))
2341 #-unicode
2342 (t (etypecase object
2343 (character 1)
2344 (string (length object))))))
2345
2346 #+unicode
2347 (stream::def-ef-macro ef-copy-state (extfmt lisp stream::+ef-max+ stream::+ef-copy-state+)
2348 ;; Return a copy of the state of an external format.
2349 `(lambda (state)
2350 (declare (ignorable state))
2351 (stream::copy-state ,extfmt state)))

  ViewVC Help
Powered by ViewVC 1.1.5