/[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 - (show annotations)
Wed Aug 26 16:25:41 2009 UTC (4 years, 7 months ago) by rtoy
Branch: MAIN
CVS Tags: release-20a-base
Branch point for: RELEASE-20A-BRANCH
Changes since 1.89: +49 -2 lines
Add support for flushing out any state in an external format when
closing an output stream.  This causes things like

(with-open-file (s "foo" :direction :output :external-format :utf-8)
  (write-char #\u+d800 s))

to output the replacement character instead of creating an empty file.

code/extfmts.lisp:
o Add new slot to efx structure to hold the function to flush the
  state in an external format.
o Add accessor for the flush-state slot.
o Update DEFINE-EXTERNAL-FORMAT to allow specifying the flush
  function.
o Add macro to call the flush-state function.
o Added +EF-FLUSH+
o Use vm::defenum to name the constants instead of the hand-written
  values.
o Export +REPLACEMENT-CHARACTER-CODE+
o Document the slots in an efx stucture.

code/fd-stream.lisp:
o Add ef-flush def-ef-macro to flush the state of an external format
  when closing an output file.  If ef-flush-state is NIL, we just call
  EF-COUT to send out the replacement character.  Otherwise, the
  flush-state function is called to handle it.
o When closing an output character stream, call ef-flush to flush any
  state before flushing the buffers of the stream.
o Document the unicode slots in an fd-stream.

code/exports.lisp:
o Export +REPLACEMENT-CHARACTER-CODE+
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 2009/08/26 16:25:41 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 (eq type 'unsigned-byte)
1376 (eq type :default)))
1377 ;; We only create this buffer for streams of type
1378 ;; (unsigned-byte 8). Because there's no buffer, the
1379 ;; other element-types will dispatch to the appropriate
1380 ;; input (output) routine in fast-read-byte.
1381 (setf (lisp-stream-in-buffer stream)
1382 (make-array in-buffer-length
1383 :element-type '(unsigned-byte 8)))))
1384 (setf input-size size)
1385 (setf input-type type)))
1386
1387 (when output-p
1388 (multiple-value-bind
1389 (routine type size)
1390 (pick-output-routine target-type (fd-stream-buffering stream))
1391 (unless routine
1392 (error "Could not find any output routine for ~S buffered ~S."
1393 (fd-stream-buffering stream)
1394 target-type))
1395 (setf (fd-stream-obuf-sap stream) (next-available-buffer))
1396 (setf (fd-stream-obuf-length stream) bytes-per-buffer)
1397 (setf (fd-stream-obuf-tail stream) 0)
1398 (if (subtypep type 'character)
1399 (setf (fd-stream-out stream) routine
1400 (fd-stream-bout stream) #'ill-bout)
1401 (setf (fd-stream-out stream)
1402 (or (if (eql size 1)
1403 (pick-output-routine 'base-char
1404 (fd-stream-buffering stream)))
1405 #'ill-out)
1406 (fd-stream-bout stream) routine))
1407 (setf (fd-stream-sout stream)
1408 ;;#-unicode
1409 (if (eql size 1) #'fd-sout #'ill-out)
1410 #|#+unicode
1411 (if (eql size 1)
1412 #'fd-sout-each-character
1413 #'ill-out)|#)
1414 (setf (fd-stream-char-pos stream) 0)
1415 (setf output-size size)
1416 (setf output-type type)))
1417
1418 (when (and input-size output-size
1419 (not (eql input-size output-size)))
1420 (error "Element sizes for input (~S:~S) and output (~S:~S) differ?"
1421 input-type input-size
1422 output-type output-size))
1423 (setf (fd-stream-element-size stream)
1424 (or input-size output-size))
1425
1426 (setf (fd-stream-element-type stream)
1427 (cond ((equal input-type output-type)
1428 input-type)
1429 ((null output-type)
1430 input-type)
1431 ((null input-type)
1432 output-type)
1433 ((subtypep input-type output-type)
1434 input-type)
1435 ((subtypep output-type input-type)
1436 output-type)
1437 (t
1438 (error "Input type (~S) and output type (~S) are unrelated?"
1439 input-type
1440 output-type))))))
1441
1442 ;;; REVERT-FILE -- internal
1443 ;;;
1444 ;;; Revert a file, if possible; otherwise do nothing. Used during
1445 ;;; CLOSE when the abort flag is set.
1446 ;;;
1447 (defun revert-file (filename original)
1448 (declare (type simple-base-string filename)
1449 (type (or simple-base-string null) original))
1450 (when original
1451 (multiple-value-bind (okay err)
1452 (unix:unix-rename original filename)
1453 (unless okay
1454 (cerror "Go on as if nothing bad happened."
1455 "Could not restore ~S to its original contents: ~A"
1456 filename (unix:get-unix-error-msg err))))))
1457
1458 ;;; DELETE-ORIGINAL -- internal
1459 ;;;
1460 ;;; Delete a backup file. Used during CLOSE.
1461 ;;;
1462 (defun delete-original (filename original)
1463 (declare (type simple-base-string filename)
1464 (type (or simple-base-string null) original))
1465 (when original
1466 (multiple-value-bind (okay err) (unix:unix-unlink original)
1467 (unless okay
1468 (cerror "Go on as if nothing bad happened."
1469 "Could not delete ~S during close of ~S: ~A"
1470 original filename (unix:get-unix-error-msg err))))))
1471
1472 ;;; FD-STREAM-MISC-ROUTINE -- input
1473 ;;;
1474 ;;; Handle the various misc operations on fd-stream.
1475 ;;;
1476 (defun fd-stream-misc-routine (stream operation &optional arg1 arg2)
1477 (declare (ignore arg2))
1478 (case operation
1479 (:listen
1480 (or (not (eql (fd-stream-ibuf-head stream)
1481 (fd-stream-ibuf-tail stream)))
1482 (fd-stream-listen stream)
1483 (setf (fd-stream-listen stream)
1484 (eql (alien:with-alien ((read-fds (alien:struct unix:fd-set)))
1485 (unix:fd-zero read-fds)
1486 (unix:fd-set (fd-stream-fd stream) read-fds)
1487 (unix:unix-fast-select (1+ (fd-stream-fd stream))
1488 (alien:addr read-fds) nil nil
1489 0 0))
1490 1))))
1491 (:unread
1492 #-unicode
1493 (setf (fd-stream-unread stream) arg1)
1494 #+unicode
1495 (if (zerop (fd-stream-last-char-read-size stream))
1496 (setf (fd-stream-unread stream) arg1)
1497 (decf (fd-stream-ibuf-head stream)
1498 (fd-stream-last-char-read-size stream)))
1499 ;; Paul says:
1500 ;;
1501 ;; Not needed for unicode when unreading is implemented by backing up in
1502 ;; the buffer (e.g., with last-char-read-size...)
1503 ;;
1504 ;; (AFAICS there's nothing wrong with setting it there, but it
1505 ;; screws up read-interactive in my toplevel command thing -
1506 ;; leaves it expecting to read arguments when it shouldn't,
1507 ;; because LISTEN returns T when there's no input pending, but I
1508 ;; don't understand why...)
1509 #-unicode
1510 (setf (fd-stream-listen stream) t))
1511 (:close
1512 (cond (arg1
1513 ;; We got us an abort on our hands.
1514 (when (fd-stream-handler stream)
1515 (system:remove-fd-handler (fd-stream-handler stream))
1516 (setf (fd-stream-handler stream) nil))
1517 (when (and (fd-stream-file stream) (fd-stream-obuf-sap stream))
1518 (revert-file (fd-stream-file stream)
1519 (fd-stream-original stream))))
1520 (t
1521 #+(and unicode (not unicode-bootstrap))
1522 (when (and (output-stream-p stream)
1523 (eq (stream-element-type stream) 'character))
1524 ;; For output character streams, we need to flush out
1525 ;; any state that the external format might have.
1526 #+nil (format *debug-io* "state = ~S~%" (fd-stream-co-state stream))
1527 (funcall (ef-flush (fd-stream-external-format stream))
1528 stream))
1529 (fd-stream-misc-routine stream :finish-output)
1530 (when (fd-stream-delete-original stream)
1531 (delete-original (fd-stream-file stream)
1532 (fd-stream-original stream)))))
1533 (when (fboundp 'cancel-finalization)
1534 (cancel-finalization stream))
1535 (unix:unix-close (fd-stream-fd stream))
1536 (when (fd-stream-obuf-sap stream)
1537 (push (fd-stream-obuf-sap stream) *available-buffers*)
1538 (setf (fd-stream-obuf-sap stream) nil))
1539 (when (fd-stream-ibuf-sap stream)
1540 (push (fd-stream-ibuf-sap stream) *available-buffers*)
1541 (setf (fd-stream-ibuf-sap stream) nil))
1542 (lisp::set-closed-flame stream))
1543 (:clear-input
1544 (setf (fd-stream-unread stream) nil) ;;@@
1545 #+unicode (setf (fd-stream-last-char-read-size stream) 0)
1546 (setf (fd-stream-ibuf-head stream) 0)
1547 (setf (fd-stream-ibuf-tail stream) 0)
1548 (catch 'eof-input-catcher
1549 (loop
1550 (multiple-value-bind
1551 (count errno)
1552 (alien:with-alien ((read-fds (alien:struct unix:fd-set)))
1553 (unix:fd-zero read-fds)
1554 (unix:fd-set (fd-stream-fd stream) read-fds)
1555 (unix:unix-fast-select (1+ (fd-stream-fd stream))
1556 (alien:addr read-fds) nil nil 0 0))
1557 (cond ((eql count 1)
1558 (do-input stream)
1559 (setf (fd-stream-ibuf-head stream) 0)
1560 (setf (fd-stream-ibuf-tail stream) 0))
1561 ((and (not count) (eql errno unix:eintr)))
1562 (t
1563 (return t)))))))
1564 (:force-output
1565 (flush-output-buffer stream))
1566 (:finish-output
1567 (flush-output-buffer stream)
1568 (do ()
1569 ((null (fd-stream-output-later stream)))
1570 (system:serve-all-events)))
1571 (:element-type
1572 (fd-stream-element-type stream))
1573 (:interactive-p
1574 (unix:unix-isatty (fd-stream-fd stream)))
1575 (:line-length
1576 80)
1577 (:charpos
1578 (fd-stream-char-pos stream))
1579 (:file-length
1580 (unless (fd-stream-file stream)
1581 (error 'simple-type-error
1582 :datum stream
1583 :expected-type 'file-stream
1584 :format-control "~s is not a stream associated with a file."
1585 :format-arguments (list stream)))
1586 (multiple-value-bind
1587 (okay dev ino mode nlink uid gid rdev size
1588 atime mtime ctime blksize blocks)
1589 (unix:unix-fstat (fd-stream-fd stream))
1590 (declare (ignore ino nlink uid gid rdev
1591 atime mtime ctime blksize blocks))
1592 (unless okay
1593 (error 'simple-file-error
1594 :format-control "Error fstating ~S: ~A"
1595 :format-arguments (list stream (unix:get-unix-error-msg dev))))
1596 (if (zerop mode)
1597 nil
1598 (values (truncate size (fd-stream-element-size stream))))))
1599 (:file-position
1600 (fd-stream-file-position stream arg1))))
1601
1602
1603 ;;; FD-STREAM-FILE-POSITION -- internal.
1604 ;;;
1605 (defun fd-stream-file-position (stream &optional newpos)
1606 (declare (type fd-stream stream)
1607 (type (or (integer 0) (member nil :start :end)) newpos))
1608 (if (null newpos)
1609 (system:without-interrupts
1610 ;; First, find the position of the UNIX file descriptor in the file.
1611 (multiple-value-bind
1612 (posn errno)
1613 (unix:unix-lseek (fd-stream-fd stream) 0 unix:l_incr)
1614 (declare (type (or (integer 0) null) posn))
1615 (cond (posn
1616 ;; Adjust for buffered output:
1617 ;; If there is any output buffered, the *real* file position
1618 ;; will be larger than reported by lseek because lseek
1619 ;; obviously cannot take into account output we have not
1620 ;; sent yet.
1621 (dolist (later (fd-stream-output-later stream))
1622 (incf posn (- (the index (caddr later))
1623 (the index (cadr later)))))
1624 (incf posn (fd-stream-obuf-tail stream))
1625 ;; Adjust for unread input:
1626 ;; If there is any input read from UNIX but not supplied to
1627 ;; the user of the stream, the *real* file position will
1628 ;; smaller than reported, because we want to look like the
1629 ;; unread stuff is still available.
1630 (decf posn (- (fd-stream-ibuf-tail stream)
1631 (fd-stream-ibuf-head stream)))
1632 (when (fd-stream-unread stream) ;;@@
1633 (decf posn))
1634 ;; Divide bytes by element size.
1635 (truncate posn (fd-stream-element-size stream)))
1636 ((eq errno unix:espipe)
1637 nil)
1638 (t
1639 (system:with-interrupts
1640 (error "Error lseek'ing ~S: ~A"
1641 stream
1642 (unix:get-unix-error-msg errno)))))))
1643 (let ((offset 0)
1644 origin)
1645 (declare (type (integer 0) offset))
1646 ;; Make sure we don't have any output pending, because if we move the
1647 ;; file pointer before writing this stuff, it will be written in the
1648 ;; wrong location.
1649 (flush-output-buffer stream)
1650 (do ()
1651 ((null (fd-stream-output-later stream)))
1652 (system:serve-all-events))
1653 ;; Clear out any pending input to force the next read to go to the
1654 ;; disk.
1655 (setf (fd-stream-unread stream) nil) ;;@@
1656 #+unicode (setf (fd-stream-last-char-read-size stream) 0)
1657 (setf (fd-stream-ibuf-head stream) 0)
1658 (setf (fd-stream-ibuf-tail stream) 0)
1659 ;; Trash cached value for listen, so that we check next time.
1660 (setf (fd-stream-listen stream) nil)
1661 ;; Now move it.
1662 (cond ((eq newpos :start)
1663 (setf offset 0
1664 origin unix:l_set))
1665 ((eq newpos :end)
1666 (setf offset 0
1667 origin unix:l_xtnd))
1668 ((typep newpos '(integer 0))
1669 (setf offset (* newpos (fd-stream-element-size stream))
1670 origin unix:l_set))
1671 (t
1672 (error "Invalid position given to file-position: ~S" newpos)))
1673 (multiple-value-bind
1674 (posn errno)
1675 (unix:unix-lseek (fd-stream-fd stream) offset origin)
1676 (cond (posn
1677 t)
1678 ((eq errno unix:espipe)
1679 nil)
1680 (t
1681 (error "Error lseek'ing ~S: ~A"
1682 stream
1683 (unix:get-unix-error-msg errno))))))))
1684
1685
1686
1687 ;;;; Creation routines (MAKE-FD-STREAM and OPEN)
1688
1689 ;;; MAKE-FD-STREAM -- Public.
1690 ;;;
1691 ;;; Returns a FD-STREAM on the given file.
1692 ;;;
1693 (defun make-fd-stream (fd
1694 &key
1695 (input nil input-p)
1696 (output nil output-p)
1697 (element-type 'base-char)
1698 (buffering :full)
1699 timeout
1700 file
1701 original
1702 delete-original
1703 pathname
1704 input-buffer-p
1705 (name (if file
1706 (format nil "file ~S" file)
1707 (format nil "descriptor ~D" fd)))
1708 auto-close
1709 (external-format :default)
1710 binary-stream-p)
1711 (declare (type index fd) (type (or index null) timeout)
1712 (type (member :none :line :full) buffering))
1713 "Create a stream for the given unix file descriptor.
1714 If input is non-nil, allow input operations.
1715 If output is non-nil, allow output operations.
1716 If neither input nor output are specified, default to allowing input.
1717 Element-type indicates the element type to use (as for open).
1718 Buffering indicates the kind of buffering to use.
1719 Timeout (if true) is the number of seconds to wait for input. If NIL (the
1720 default), then wait forever. When we time out, we signal IO-TIMEOUT.
1721 File is the name of the file (will be returned by PATHNAME).
1722 Name is used to identify the stream when printed."
1723 (cond ((not (or input-p output-p))
1724 (setf input t))
1725 ((not (or input output))
1726 (error "File descriptor must be opened either for input or output.")))
1727 (let ((stream (if binary-stream-p
1728 (%make-binary-text-stream :fd fd
1729 :name name
1730 :file file
1731 :original original
1732 :delete-original delete-original
1733 :pathname pathname
1734 :buffering buffering
1735 :timeout timeout)
1736 (%make-fd-stream :fd fd
1737 :name name
1738 :file file
1739 :original original
1740 :delete-original delete-original
1741 :pathname pathname
1742 :buffering buffering
1743 :timeout timeout))))
1744 (set-routines stream element-type input output input-buffer-p
1745 :binary-stream-p binary-stream-p)
1746 ;;#-unicode-bootstrap ; fails in stream-reinit otherwise
1747 #+(and unicode (not unicode-bootstrap))
1748 (setf (stream-external-format stream) external-format)
1749 (when (and auto-close (fboundp 'finalize))
1750 (finalize stream
1751 #'(lambda ()
1752 (unix:unix-close fd)
1753 (format *terminal-io* "** Closed ~A~%" name)
1754 (when original
1755 (revert-file file original)))))
1756 stream))
1757
1758
1759 ;;; PICK-BACKUP-NAME -- internal
1760 ;;;
1761 ;;; Pick a name to use for the backup file.
1762 ;;;
1763 (defvar *backup-extension* ".BAK"
1764 "This is a string that OPEN tacks on the end of a file namestring to produce
1765 a name for the :if-exists :rename-and-delete and :rename options. Also,
1766 this can be a function that takes a namestring and returns a complete
1767 namestring.")
1768 ;;;
1769 (defun pick-backup-name (name)
1770 (declare (type simple-string name))
1771 (let ((ext *backup-extension*))
1772 (etypecase ext
1773 (simple-string (concatenate 'simple-string name ext))
1774 (function (funcall ext name)))))
1775
1776 ;;; NEXT-VERSION -- internal
1777 ;;;
1778 ;;; Find the next available versioned name for a file.
1779 ;;;
1780 (defun next-version (name)
1781 (declare (type simple-string name))
1782 (let* ((sep (position #\/ name :from-end t))
1783 (base (if sep (subseq name 0 (1+ sep)) ""))
1784 (dir (unix:open-dir base)))
1785 (multiple-value-bind (name type version)
1786 (extract-name-type-and-version name (if sep (1+ sep) 0) (length name))
1787 (let ((version (if (symbolp version) 1 (1+ version)))
1788 (match (if type
1789 (concatenate 'string name "." type ".~")
1790 (concatenate 'string name ".~"))))
1791 (when dir
1792 (unwind-protect
1793 (loop
1794 (let ((name (unix:read-dir dir)))
1795 (cond ((null name) (return))
1796 ((and (> (length name) (length match))
1797 (string= name match :end1 (length match)))
1798 (multiple-value-bind (v e)
1799 (parse-integer name :start (length match)
1800 :junk-allowed t)
1801 (when (and v
1802 (= (length name) (1+ e))
1803 (char= (schar name e) #\~))
1804 (setq version (max version (1+ v)))))))))
1805 (unix:close-dir dir)))
1806 (concatenate 'string base
1807 match (quick-integer-to-string version) "~")))))
1808
1809 ;;; ASSURE-ONE-OF -- internal
1810 ;;;
1811 ;;; Assure that the given arg is one of the given list of valid things.
1812 ;;; Allow the user to fix any problems.
1813 ;;;
1814 (defun assure-one-of (item list what)
1815 (unless (member item list)
1816 (loop
1817 (cerror "Enter new value for ~*~S"
1818 "~S is invalid for ~S. Must be one of~{ ~S~}"
1819 item
1820 what
1821 list)
1822 (format (the stream *query-io*) "Enter new value for ~S: " what)
1823 (force-output *query-io*)
1824 (setf item (read *query-io*))
1825 (when (member item list)
1826 (return))))
1827 item)
1828
1829 ;;; DO-OLD-RENAME -- Internal
1830 ;;;
1831 ;;; Rename Namestring to Original. First, check if we have write access,
1832 ;;; since we don't want to trash unwritable files even if we technically can.
1833 ;;; We return true if we succeed in renaming.
1834 ;;;
1835 (defun do-old-rename (namestring original)
1836 (unless (unix:unix-access namestring unix:w_ok)
1837 (cerror "Try to rename it anyway." "File ~S is not writable." namestring))
1838 (multiple-value-bind
1839 (okay err)
1840 (unix:unix-rename namestring original)
1841 (cond (okay t)
1842 (t
1843 (cerror "Use :SUPERSEDE instead."
1844 "Could not rename ~S to ~S: ~A."
1845 namestring
1846 original
1847 (unix:get-unix-error-msg err))
1848 nil))))
1849
1850 ;;; FD-OPEN -- Internal
1851 ;;;
1852 ;;; Open a file.
1853 ;;;
1854 (defun fd-open (pathname direction if-exists if-exists-given
1855 if-does-not-exist if-does-not-exist-given)
1856 (declare (type pathname pathname)
1857 (type (member :input :output :io :probe) direction)
1858 (type (member :error :new-version :rename :rename-and-delete
1859 :overwrite :append :supersede nil) if-exists)
1860 (type (member :error :create nil) if-does-not-exist))
1861 (multiple-value-bind (input output mask)
1862 (ecase direction
1863 (:input (values t nil unix:o_rdonly))
1864 (:output (values nil t unix:o_wronly))
1865 (:io (values t t unix:o_rdwr))
1866 (:probe (values t nil unix:o_rdonly)))
1867 (declare (type index mask))
1868 ;; Process if-exists argument if we are doing any output.
1869 (cond (output
1870 (unless if-exists-given
1871 (setf if-exists
1872 (if (eq (pathname-version pathname) :newest)
1873 :new-version
1874 :error)))
1875 (case if-exists
1876 ((:error nil)
1877 (setf mask (logior mask unix:o_excl)))
1878 ((:new-version :rename :rename-and-delete)
1879 (setf mask (logior mask unix:o_creat)))
1880 (:supersede
1881 (setf mask (logior mask unix:o_trunc)))))
1882 (t
1883 (setf if-exists nil))) ; :ignore-this-arg
1884
1885 (unless if-does-not-exist-given
1886 (setf if-does-not-exist
1887 (cond ((eq direction :input) :error)
1888 ((and output
1889 (member if-exists '(:overwrite :append)))
1890 :error)
1891 ((eq direction :probe)
1892 nil)
1893 (t
1894 :create))))
1895 (if (eq if-does-not-exist :create)
1896 (setf mask (logior mask unix:o_creat)))
1897
1898 (let ((name (cond ((unix-namestring pathname input))
1899 ((and input (eq if-does-not-exist :create))
1900 (unix-namestring pathname nil)))))
1901 (let ((original (cond ((eq if-exists :new-version)
1902 (next-version name))
1903 ((member if-exists '(:rename :rename-and-delete))
1904 (pick-backup-name name))))
1905 (delete-original (eq if-exists :rename-and-delete))
1906 (mode #o666))
1907 (when original
1908 ;; We are doing a :rename or :rename-and-delete.
1909 ;; Determine if the file already exists, make sure the original
1910 ;; file is not a directory and keep the mode
1911 (let ((exists
1912 (and name
1913 (multiple-value-bind
1914 (okay err/dev inode orig-mode)
1915 (unix:unix-stat name)
1916 (declare (ignore inode)
1917 (type (or index null) orig-mode))
1918 (cond
1919 (okay
1920 (when (and output (= (logand orig-mode #o170000)
1921 #o40000))
1922 (error 'simple-file-error
1923 :pathname pathname
1924 :format-control
1925 "Cannot open ~S for output: Is a directory."
1926 :format-arguments (list name)))
1927 (setf mode (logand orig-mode #o777))
1928 t)
1929 ((eql err/dev unix:enoent)
1930 nil)
1931 (t
1932 (error 'simple-file-error
1933 :pathname pathname
1934 :format-control "Cannot find ~S: ~A"
1935 :format-arguments
1936 (list name
1937 (unix:get-unix-error-msg err/dev)))))))))
1938 (unless (and exists
1939 (do-old-rename name original))
1940 (setf original nil)
1941 (setf delete-original nil)
1942 ;; In order to use SUPERSEDE instead, we have
1943 ;; to make sure unix:o_creat corresponds to
1944 ;; if-does-not-exist. unix:o_creat was set
1945 ;; before because of if-exists being :rename.
1946 (unless (eq if-does-not-exist :create)
1947 (setf mask (logior (logandc2 mask unix:o_creat)
1948 unix:o_trunc)))
1949 (setf if-exists :supersede))))
1950
1951 ;; Okay, now we can try the actual open.
1952 (loop
1953 (multiple-value-bind (fd errno)
1954 (if name
1955 (unix:unix-open name mask mode)
1956 (values nil unix:enoent))
1957 (cond ((fixnump fd)
1958 (when (eq if-exists :append)
1959 (unix:unix-lseek fd 0 unix:l_xtnd)) ; SEEK_END
1960 (return (values fd name original delete-original)))
1961 ((eql errno unix:enoent)
1962 (case if-does-not-exist
1963 (:error
1964 (cerror "Return NIL."
1965 'simple-file-error
1966 :pathname pathname
1967 :format-control "Error opening ~S, ~A."
1968 :format-arguments
1969 (list pathname
1970 (unix:get-unix-error-msg errno))))
1971 (:create
1972 (cerror "Return NIL."
1973 'simple-file-error
1974 :pathname pathname
1975 :format-control
1976 "Error creating ~S, path does not exist."
1977 :format-arguments (list pathname))))
1978 (return nil))
1979 ((eql errno unix:eexist)
1980 (unless (eq nil if-exists)
1981 (cerror "Return NIL."
1982 'simple-file-error
1983 :pathname pathname
1984 :format-control "Error opening ~S, ~A."
1985 :format-arguments
1986 (list pathname
1987 (unix:get-unix-error-msg errno))))
1988 (return nil))
1989 ((eql errno unix:eacces)
1990 (cerror "Try again."
1991 'simple-file-error
1992 :pathname pathname
1993 :format-control "Error opening ~S, ~A."
1994 :format-arguments
1995 (list pathname
1996 (unix:get-unix-error-msg errno))))
1997 (t
1998 (cerror "Return NIL."
1999 'simple-file-error
2000 :pathname pathname
2001 :format-control "Error opening ~S, ~A."
2002 :format-arguments
2003 (list pathname
2004 (unix:get-unix-error-msg errno)))
2005 (return nil)))))))))
2006
2007 ;;; OPEN-FD-STREAM -- Internal
2008 ;;;
2009 ;;; Open an fd-stream connected to a file.
2010 ;;;
2011 (defun open-fd-stream (pathname &key (direction :input)
2012 (element-type 'base-char)
2013 (if-exists nil if-exists-given)
2014 (if-does-not-exist nil if-does-not-exist-given)
2015 (external-format :default)
2016 class)
2017 (declare (type pathname pathname)
2018 (type (member :input :output :io :probe) direction)
2019 (type (member :error :new-version :rename :rename-and-delete
2020 :overwrite :append :supersede nil) if-exists)
2021 (type (member :error :create nil) if-does-not-exist))
2022 (multiple-value-bind (fd namestring original delete-original)
2023 (fd-open pathname direction if-exists if-exists-given
2024 if-does-not-exist if-does-not-exist-given)
2025 (when fd
2026 (case direction
2027 ((:input :output :io)
2028 ;; We use the :class option to tell us if we want a
2029 ;; binary-text stream or not.
2030 (make-fd-stream fd
2031 :input (member direction '(:input :io))
2032 :output (member direction '(:output :io))
2033 :element-type element-type
2034 :file namestring
2035 :original original
2036 :delete-original delete-original
2037 :pathname pathname
2038 :input-buffer-p t
2039 :auto-close t
2040 :external-format external-format
2041 :binary-stream-p class))
2042 (:probe
2043 (let ((stream (%make-fd-stream :name namestring :fd fd
2044 :pathname pathname
2045 :element-type element-type)))
2046 (close stream)
2047 stream))))))
2048
2049 ;;; OPEN -- public
2050 ;;;
2051 ;;; Open the given file.
2052 ;;;
2053 (defun open (filename &rest options
2054 &key (direction :input)
2055 (element-type 'base-char element-type-given)
2056 (if-exists nil if-exists-given)
2057 (if-does-not-exist nil if-does-not-exist-given)
2058 (external-format :default)
2059 class mapped input-handle output-handle
2060 &allow-other-keys
2061 &aux ; Squelch assignment warning.
2062 (direction direction)
2063 (if-does-not-exist if-does-not-exist)
2064 (if-exists if-exists))
2065 "Return a stream which reads from or writes to Filename.
2066 Defined keywords:
2067 :direction - one of :input, :output, :io, or :probe
2068 :element-type - Type of object to read or write, default BASE-CHAR
2069 :if-exists - one of :error, :new-version, :rename, :rename-and-delete,
2070 :overwrite, :append, :supersede or nil
2071 :if-does-not-exist - one of :error, :create or nil
2072 :external-format - an external format name
2073 See the manual for details."
2074 (declare (ignore element-type external-format input-handle output-handle))
2075
2076 ;; OPEN signals a file-error if the filename is wild.
2077 (when (wild-pathname-p filename)
2078 (error 'file-error :pathname filename))
2079
2080 ;; First, make sure that DIRECTION is valid. Allow it to be changed if not.
2081 (setq direction
2082 (assure-one-of direction
2083 '(:input :output :io :probe)
2084 :direction))
2085 (setf (getf options :direction) direction)
2086
2087 (when (and if-exists-given (member direction '(:output :io)))
2088 (setq if-exists
2089 (assure-one-of if-exists
2090 '(:error :new-version :rename
2091 :rename-and-delete :overwrite
2092 :append :supersede nil)
2093 :if-exists))
2094 (setf (getf options :if-exists) if-exists))
2095
2096 (when if-does-not-exist-given
2097 (setq if-does-not-exist
2098 (assure-one-of if-does-not-exist
2099 '(:error :create nil)
2100 :if-does-not-exist))
2101 (setf (getf options :if-does-not-exist) if-does-not-exist))
2102
2103 (let ((filespec (pathname filename))
2104 (options (copy-list options))
2105 (class (or class 'fd-stream)))
2106 (cond ((eq class 'fd-stream)
2107 (remf options :class)
2108 (remf options :mapped)
2109 (remf options :input-handle)
2110 (remf options :output-handle)
2111 (apply #'open-fd-stream filespec options))
2112 ((eq class 'binary-text-stream)
2113 ;; Like fd-stream, but binary and text allowed. This is
2114 ;; indicated by leaving the :class option around for
2115 ;; open-fd-stream to see.
2116 (remf options :mapped)
2117 (remf options :input-handle)
2118 (remf options :output-handle)
2119 (apply #'open-fd-stream filespec options))
2120 ((subtypep class 'stream:simple-stream)
2121 (when element-type-given
2122 (cerror "Do it anyway."
2123 "Can't create simple-streams with an element-type."))
2124 (when (and (eq class 'stream:file-simple-stream) mapped)
2125 (setq class 'stream:mapped-file-simple-stream)
2126 (setf (getf options :class) 'stream:mapped-file-simple-stream))
2127 (when (subtypep class 'stream:file-simple-stream)
2128 (when (eq direction :probe)
2129 (setq class 'stream:probe-simple-stream)))
2130 (apply #'make-instance class :filename filespec options))
2131 ((subtypep class 'ext:fundamental-stream)
2132 (remf options :class)
2133 (remf options :mapped)
2134 (remf options :input-handle)
2135 (remf options :output-handle)
2136 (let ((stream (apply #'open-fd-stream filespec options)))
2137 (when stream
2138 (make-instance class :lisp-stream stream))))
2139 (t
2140 (error "Unable to open streams of class ~S." class)))))
2141
2142 ;;;; Initialization.
2143
2144 (defvar *tty* nil
2145 "The stream connected to the controlling terminal or NIL if there is none.")
2146 (defvar *stdin* nil
2147 "The stream connected to the standard input (file descriptor 0).")
2148 (defvar *stdout* nil
2149 "The stream connected to the standard output (file descriptor 1).")
2150 (defvar *stderr* nil
2151 "The stream connected to the standard error output (file descriptor 2).")
2152
2153 ;;; STREAM-INIT -- internal interface
2154 ;;;
2155 ;;; Called when the cold load is first started up.
2156 ;;;
2157 (defun stream-init ()
2158 (stream-reinit)
2159 (setf *terminal-io* (make-synonym-stream '*tty*))
2160 (setf *standard-output* (make-synonym-stream '*stdout*))
2161 (setf *standard-input*
2162 (make-two-way-stream (make-synonym-stream '*stdin*)
2163 *standard-output*))
2164 (setf *error-output* (make-synonym-stream '*stderr*))
2165 (setf *query-io* (make-synonym-stream '*terminal-io*))
2166 (setf *debug-io* *query-io*)
2167 (setf *trace-output* *standard-output*)
2168 nil)
2169
2170 ;;; STREAM-REINIT -- internal interface
2171 ;;;
2172 ;;; Called whenever a saved core is restarted.
2173 ;;;
2174 (defun stream-reinit ()
2175 (setf *available-buffers* nil)
2176 (setf *stdin*
2177 (make-fd-stream 0 :name "Standard Input" :input t :buffering :line
2178 :external-format :iso8859-1))
2179 (setf *stdout*
2180 (make-fd-stream 1 :name "Standard Output" :output t :buffering :line
2181 :external-format :iso8859-1))
2182 (setf *stderr*
2183 (make-fd-stream 2 :name "Standard Error" :output t :buffering :line
2184 :external-format :iso8859-1))
2185 (let ((tty (and (not *batch-mode*)
2186 (unix:unix-open "/dev/tty" unix:o_rdwr #o666))))
2187 (setf *tty*
2188 (if tty
2189 (make-fd-stream tty :name "the Terminal" :input t :output t
2190 :buffering :line :auto-close t
2191 :external-format :iso8859-1)
2192 (make-two-way-stream *stdin* *stdout*))))
2193 nil)
2194
2195
2196 ;;;; Beeping.
2197
2198 (defun default-beep-function (stream)
2199 (write-char #\bell stream)
2200 (finish-output stream))
2201
2202 (defvar *beep-function* #'default-beep-function
2203 "This is called in BEEP to feep the user. It takes a stream.")
2204
2205 (defun beep (&optional (stream *terminal-io*))
2206 (funcall *beep-function* stream))
2207
2208
2209 ;;; File-Name -- internal interface
2210 ;;;
2211 ;;; Kind of like File-Position, but is an internal hack used by the filesys
2212 ;;; stuff to get and set the file name.
2213 ;;;
2214 (defun file-name (stream &optional new-name)
2215 (typecase stream
2216 (stream:simple-stream
2217 (if new-name
2218 (stream::%file-rename stream new-name)
2219 (stream::%file-name stream)))
2220 (fd-stream
2221 (cond (new-name
2222 (setf (fd-stream-pathname stream) new-name)
2223 (setf (fd-stream-file stream)
2224 (unix-namestring new-name nil))
2225 t)
2226 (t
2227 (fd-stream-pathname stream))))))
2228
2229
2230
2231 #+unicode
2232 (stream::def-ef-macro ef-strlen (extfmt lisp stream::+ef-max+ stream::+ef-str+)
2233 (if (= (stream::ef-min-octets (stream::find-external-format extfmt))
2234 (stream::ef-max-octets (stream::find-external-format extfmt)))
2235 `(lambda (stream object)
2236 (declare (ignore stream)
2237 (type (or character string) object)
2238 (optimize (speed 3) (space 0) (safety 0)))
2239 (etypecase object
2240 (character ,(stream::ef-min-octets (stream::find-external-format extfmt)))
2241 (string (* ,(stream::ef-min-octets (stream::find-external-format extfmt))
2242 (length object)))))
2243 `(lambda (stream object &aux (count 0))
2244 (declare (type fd-stream stream)
2245 (type (or character string) object)
2246 #|(optimize (speed 3) (space 0) (debug 0) (safety 0))|#)
2247 `(labels ((eflen (char)
2248 (stream::char-to-octets ,extfmt char
2249 ;;@@ FIXME: don't alter state!
2250 (fd-stream-co-state stream)
2251 (lambda (byte)
2252 (declare (ignore byte))
2253 (incf count)))))
2254 (etypecase object
2255 (character (eflen object))
2256 (string (dovector (ch object) (eflen ch))))
2257 count))))
2258
2259
2260 (defun file-string-length (stream object)
2261 (declare (type (or string character) object)
2262 (type (or file-stream broadcast-stream stream:simple-stream) stream))
2263 "Return the delta in Stream's FILE-POSITION that would be caused by writing
2264 Object to Stream. Non-trivial only in implementations that support
2265 international character sets."
2266 (typecase stream
2267 (stream:simple-stream (stream::%file-string-length stream object))
2268 (broadcast-stream
2269 ;; CLHS says we must return 1 in this case
2270 1)
2271 #+unicode
2272 (t (funcall (ef-strlen (fd-stream-external-format stream))
2273 stream object))
2274 #-unicode
2275 (t (etypecase object
2276 (character 1)
2277 (string (length object))))))

  ViewVC Help
Powered by ViewVC 1.1.5