/[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.85.4.2 - (show annotations)
Wed Mar 25 19:32:53 2009 UTC (5 years ago) by rtoy
Branch: unicode-utf16-branch
CVS Tags: unicode-utf16-char-support-2009-03-26, unicode-utf16-char-support-2009-03-25
Changes since 1.85.4.1: +15 -2 lines
Character name and properties support, from Paul Foley, slightly
modified by Raymond Toy.

Use 19f/boot-2009-03-cross-unicode-<arch> for the cross compile
script.  Use 19f/boot-2009-03-unicode-char for the bootstrap file to
initialize the unicode character structures.

bootfiles/19e/boot-2008-05-cross-unicode-common.lisp:
o Just add new slots to fd-stream here, to make it easier to bootstrap
  the utf16-extfmts code, and to select the clobber-it restart
  automatically.
o Build the initial unicode properties

bootfiles/19f/boot-2009-03-cross-unicode-ppc.lisp:
bootfiles/19f/boot-2009-03-cross-unicode-sparc.lisp:
bootfiles/19f/boot-2009-03-cross-unicode-x86.lisp:
o New scripts for cross-compiling.  Basically just calls the
  original ones in the 19e directory.

bootfiles/19f/boot-2009-03-unicode-char.lisp:
o Bootstrap file to load up the full unicode properties.

i18n/UnicodeData.txt:
o UnicodeData.txt, obtained from
  unicode.org/Public/UNIDATA/UnicodeData.txt, 2009-03-24.

code/fd-stream.lisp:
o Add new slots to fd-stream, needed by utf16-extfmts branch.

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

  ViewVC Help
Powered by ViewVC 1.1.5