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