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

  ViewVC Help
Powered by ViewVC 1.1.5