/[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.79 - (hide annotations)
Fri Apr 23 15:08:15 2004 UTC (9 years, 11 months ago) by rtoy
Branch: MAIN
CVS Tags: snapshot-2004-08, snapshot-2004-09, snapshot-2004-05, snapshot-2004-06, snapshot-2004-07, amd64-merge-start, prm-before-macosx-merge-tag, release-19a-base, release-19a-pre1, release-19a-pre3, release-19a-pre2, release-19a
Branch point for: release-19a-branch
Changes since 1.78: +119 -8 lines
Enhance PICK-OUTPUT-ROUTINE and PICK-INPUT-ROUTINE to support byte
sizes up to MAX-STREAM-ELEMENT-SIZE (currently 1024).

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

  ViewVC Help
Powered by ViewVC 1.1.5