/[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.103 - (show annotations)
Fri Jul 2 02:50:35 2010 UTC (3 years, 9 months ago) by rtoy
Branch: MAIN
Changes since 1.102: +26 -10 lines
Implement more of the external format error handlers.

code/extfmts.lisp
o Call the error handler for iso8859-1 output.
o In OCTETS-TO-CODEPOINT and CODEPOINT-TO-OCTETS, call the external
  format with the error argument.
o In OCTETS-TO-CHAR
  - Call OCTETS-TO-CODEPOINT with the error handler.
  - For all of the error conditions, call the error handler if
    defined.
o Add error parameter to EF-STRING-TO-OCTETS and EF-ENCODE so we can
  handle errors.  Call CHAR-TO-OCTETS with the error handler.
o Add error parameter to STRING-TO-OCTETS and use it.
o Add error parameter to EF-OCTETS-TO-STRING and EF-DECODE so we can
  handle errors.  Call OCTETS-TO-CHAR with the error handler.
o Add error parameter to OCTETS-TO-STRING and use it.
o In STRING-ENCODE and STRING-DECODE, call the ef function with the
  error handler.
o Change STRING-ENCODE to use keyword args instead of optional args.
  Add error parameter and use it.

code/fd-stream-extfmt.lisp:
o Tell OCTETS-TO-STRING about the error handler stored in the
  fd-stream.

code/fd-stream.lisp:
o OPEN, MAKE-FD-STREAM, and OPEN-FD-STREAM get DECODING-ERROR and
  ENCODING-ERROR keyword arguments for specifying how to handle
  decoding and encoding errors in external formats.

code/stream.lisp:
o Make sure the error handler is called in
  FAST-READ-CHAR-STRING-REFILL.

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

  ViewVC Help
Powered by ViewVC 1.1.5