/[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.81 - (hide annotations)
Thu Feb 10 17:49:46 2005 UTC (9 years, 2 months ago) by rtoy
Branch: MAIN
CVS Tags: ppc_gencgc_snap_2005-05-14
Branch point for: ppc_gencgc_branch
Changes since 1.80: +19 -12 lines
Signal a socket-error instead of a general error when a socket
connection is reset.  Based on code from Scott Burson, cmucl-imp,
2005-01-31.
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.81 "$Header: /tiger/var/lib/cvsroots/cmucl/src/code/fd-stream.lisp,v 1.81 2005/02/10 17:49:46 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 rtoy 1.81 ;; What kinds of errors do we want to look at and what do
596     ;; we want them to do?
597     (cond ((eql errno unix:ewouldblock)
598     (unless #-mp (system:wait-until-fd-usable
599     fd :input (fd-stream-timeout stream))
600     #+mp (mp:process-wait-until-fd-usable
601     fd :input (fd-stream-timeout stream))
602     (error 'io-timeout :stream stream :direction :read))
603     (do-input stream))
604     ((eql errno unix:econnreset)
605     (error 'socket-error
606     :format-control "Socket connection reset: ~A"
607     :format-arguments (list (unix:get-unix-error-msg errno))
608     :errno errno))
609     (t
610     (error "Error reading ~S: ~A"
611     stream
612     (unix:get-unix-error-msg errno)))))
613 ram 1.1 ((zerop count)
614 ram 1.12 (setf (fd-stream-listen stream) :eof)
615 ram 1.1 (throw 'eof-input-catcher nil))
616     (t
617     (incf (fd-stream-ibuf-tail stream) count))))))
618    
619     ;;; INPUT-AT-LEAST -- internal
620     ;;;
621     ;;; Makes sure there are at least ``bytes'' number of bytes in the input
622     ;;; buffer. Keeps calling do-input until that condition is met.
623     ;;;
624     (defmacro input-at-least (stream bytes)
625     (let ((stream-var (gensym))
626     (bytes-var (gensym)))
627     `(let ((,stream-var ,stream)
628     (,bytes-var ,bytes))
629     (loop
630     (when (>= (- (fd-stream-ibuf-tail ,stream-var)
631     (fd-stream-ibuf-head ,stream-var))
632     ,bytes-var)
633     (return))
634     (do-input ,stream-var)))))
635    
636     ;;; INPUT-WRAPPER -- intenal
637     ;;;
638 ram 1.24 ;;; Macro to wrap around all input routines to handle eof-error noise.
639 ram 1.1 ;;;
640     (defmacro input-wrapper ((stream bytes eof-error eof-value) &body read-forms)
641     (let ((stream-var (gensym))
642     (element-var (gensym)))
643     `(let ((,stream-var ,stream))
644 ram 1.26 (if (fd-stream-unread ,stream-var)
645     (prog1
646     (fd-stream-unread ,stream-var)
647     (setf (fd-stream-unread ,stream-var) nil)
648     (setf (fd-stream-listen ,stream-var) nil))
649     (let ((,element-var
650     (catch 'eof-input-catcher
651     (input-at-least ,stream-var ,bytes)
652     ,@read-forms)))
653     (cond (,element-var
654     (incf (fd-stream-ibuf-head ,stream-var) ,bytes)
655     ,element-var)
656     (t
657     (eof-or-lose ,stream-var ,eof-error ,eof-value))))))))
658 ram 1.1
659     ;;; DEF-INPUT-ROUTINE -- internal
660     ;;;
661     ;;; Defines an input routine.
662     ;;;
663     (defmacro def-input-routine (name
664     (type size sap head)
665     &rest body)
666     `(progn
667     (defun ,name (stream eof-error eof-value)
668     (input-wrapper (stream ,size eof-error eof-value)
669     (let ((,sap (fd-stream-ibuf-sap stream))
670     (,head (fd-stream-ibuf-head stream)))
671     ,@body)))
672     (setf *input-routines*
673     (nconc *input-routines*
674     (list (list ',type ',name ',size))))))
675    
676 wlott 1.6 ;;; INPUT-CHARACTER -- internal
677 ram 1.1 ;;;
678     ;;; Routine to use in stream-in slot for reading string chars.
679     ;;;
680 wlott 1.6 (def-input-routine input-character
681     (character 1 sap head)
682 wlott 1.5 (code-char (sap-ref-8 sap head)))
683 ram 1.1
684     ;;; INPUT-UNSIGNED-8BIT-BYTE -- internal
685     ;;;
686     ;;; Routine to read in an unsigned 8 bit number.
687     ;;;
688     (def-input-routine input-unsigned-8bit-byte
689     ((unsigned-byte 8) 1 sap head)
690 wlott 1.5 (sap-ref-8 sap head))
691 ram 1.1
692     ;;; INPUT-SIGNED-8BIT-BYTE -- internal
693     ;;;
694     ;;; Routine to read in a signed 8 bit number.
695     ;;;
696     (def-input-routine input-signed-8bit-number
697     ((signed-byte 8) 1 sap head)
698 wlott 1.5 (signed-sap-ref-8 sap head))
699 ram 1.1
700     ;;; INPUT-UNSIGNED-16BIT-BYTE -- internal
701     ;;;
702     ;;; Routine to read in an unsigned 16 bit number.
703     ;;;
704     (def-input-routine input-unsigned-16bit-byte
705     ((unsigned-byte 16) 2 sap head)
706 wlott 1.20 (sap-ref-16 sap head))
707 ram 1.1
708     ;;; INPUT-SIGNED-16BIT-BYTE -- internal
709     ;;;
710     ;;; Routine to read in a signed 16 bit number.
711     ;;;
712     (def-input-routine input-signed-16bit-byte
713     ((signed-byte 16) 2 sap head)
714 wlott 1.20 (signed-sap-ref-16 sap head))
715 ram 1.1
716     ;;; INPUT-UNSIGNED-32BIT-BYTE -- internal
717     ;;;
718     ;;; Routine to read in a unsigned 32 bit number.
719     ;;;
720     (def-input-routine input-unsigned-32bit-byte
721     ((unsigned-byte 32) 4 sap head)
722 wlott 1.20 (sap-ref-32 sap head))
723 ram 1.1
724     ;;; INPUT-SIGNED-32BIT-BYTE -- internal
725     ;;;
726     ;;; Routine to read in a signed 32 bit number.
727     ;;;
728     (def-input-routine input-signed-32bit-byte
729     ((signed-byte 32) 4 sap head)
730 wlott 1.20 (signed-sap-ref-32 sap head))
731 ram 1.1
732     ;;; PICK-INPUT-ROUTINE -- internal
733     ;;;
734     ;;; Find an input routine to use given the type. Return as multiple values
735     ;;; the routine, the real type transfered, and the number of bytes per element.
736     ;;;
737     (defun pick-input-routine (type)
738     (dolist (entry *input-routines*)
739     (when (subtypep type (car entry))
740 rtoy 1.79 (return-from pick-input-routine
741     (values (symbol-function (cadr entry))
742     (car entry)
743     (caddr entry)))))
744     ;; FIXME: let's do it the hard way, then (but ignore things like
745     ;; endianness, efficiency, and the necessary coupling between these
746     ;; and the output routines). -- CSR, 2004-02-09
747     (loop for i from 40 by 8 to max-stream-element-size ; ARB (well, KLUDGE really)
748     if (subtypep type `(unsigned-byte ,i))
749     do (return-from pick-input-routine
750     (values
751     (lambda (stream eof-error eof-value)
752     (input-wrapper (stream (/ i 8) eof-error eof-value)
753     (let ((sap (fd-stream-ibuf-sap stream))
754     (head (fd-stream-ibuf-head stream)))
755     (loop for j from 0 below (/ i 8)
756     with result = 0
757     do (setf result
758     (+ (* 256 result)
759     (sap-ref-8 sap (+ head j))))
760     finally (return result)))))
761     `(unsigned-byte ,i)
762     (/ i 8))))
763     (loop for i from 40 by 8 to max-stream-element-size ; ARB (well, KLUDGE really)
764     if (subtypep type `(signed-byte ,i))
765     do (return-from pick-input-routine
766     (values
767     (lambda (stream eof-error eof-value)
768     (input-wrapper (stream (/ i 8) eof-error eof-value)
769     (let ((sap (fd-stream-ibuf-sap stream))
770     (head (fd-stream-ibuf-head stream)))
771     (loop for j from 0 below (/ i 8)
772     with result = 0
773     do (setf result
774     (+ (* 256 result)
775     (sap-ref-8 sap (+ head j))))
776 rtoy 1.80 finally (return (if (logbitp (1- i) result)
777     (dpb result (byte i 0) -1)
778     result))))))
779 rtoy 1.79 `(signed-byte ,i)
780     (/ i 8)))))
781 ram 1.1
782     ;;; STRING-FROM-SAP -- internal
783     ;;;
784     ;;; Returns a string constructed from the sap, start, and end.
785     ;;;
786     (defun string-from-sap (sap start end)
787 ram 1.14 (declare (type index start end))
788 ram 1.1 (let* ((length (- end start))
789     (string (make-string length)))
790 wlott 1.5 (copy-from-system-area sap (* start vm:byte-bits)
791     string (* vm:vector-data-offset vm:word-bits)
792     (* length vm:byte-bits))
793 ram 1.1 string))
794    
795 ram 1.13 #|
796 ram 1.1 ;;; FD-STREAM-READ-N-BYTES -- internal
797     ;;;
798 dtc 1.50 ;;; This version waits using server. I changed to the non-server version
799     ;;; because it allows this method to be used by CLX w/o confusing serve-event.
800     ;;; The non-server method is also significantly more efficient for large
801     ;;; reads. -- Ram
802     ;;;
803 ram 1.1 ;;; The n-bin routine.
804     ;;;
805     (defun fd-stream-read-n-bytes (stream buffer start requested eof-error-p)
806 dtc 1.50 (declare (type stream stream) (type index start requested))
807 ram 1.1 (let* ((sap (fd-stream-ibuf-sap stream))
808     (elsize (fd-stream-element-size stream))
809     (offset (* elsize start))
810     (bytes (* elsize requested))
811 wlott 1.5 (result
812     (catch 'eof-input-catcher
813     (loop
814     (input-at-least stream 1)
815     (let* ((head (fd-stream-ibuf-head stream))
816     (tail (fd-stream-ibuf-tail stream))
817     (available (- tail head))
818     (copy (min available bytes)))
819     (if (typep buffer 'system-area-pointer)
820     (system-area-copy sap (* head vm:byte-bits)
821     buffer (* offset vm:byte-bits)
822     (* copy vm:byte-bits))
823     (copy-from-system-area sap (* head vm:byte-bits)
824     buffer (+ (* offset vm:byte-bits)
825     (* vm:vector-data-offset
826     vm:word-bits))
827     (* copy vm:byte-bits)))
828     (incf (fd-stream-ibuf-head stream) copy)
829     (incf offset copy)
830     (decf bytes copy))
831     (when (zerop bytes)
832     (return requested))))))
833 ram 1.26 (or result
834     (eof-or-lose stream eof-error-p
835     (- requested (/ bytes elsize))))))
836 ram 1.13 |#
837 ram 1.1
838 ram 1.13
839     ;;; FD-STREAM-READ-N-BYTES -- internal
840     ;;;
841 dtc 1.50 ;;; The N-Bin method for FD-STREAMs. This doesn't use the SERVER; it blocks
842 ram 1.13 ;;; in UNIX-READ. This allows the method to be used to implementing reading
843     ;;; for CLX. It is generally used where there is a definite amount of reading
844 ram 1.14 ;;; to be done, so blocking isn't too problematical.
845 ram 1.13 ;;;
846     ;;; We copy buffered data into the buffer. If there is enough, just return.
847     ;;; Otherwise, we see if the amount of additional data needed will fit in the
848     ;;; stream buffer. If not, inhibit GCing (so we can have a SAP into the Buffer
849     ;;; argument), and read directly into the user supplied buffer. Otherwise,
850     ;;; read a buffer-full into the stream buffer and then copy the amount we need
851     ;;; out.
852     ;;;
853     ;;; We loop doing the reads until we either get enough bytes or hit EOF. We
854 ram 1.24 ;;; must loop when eof-errorp is T because some streams (like pipes) may return
855     ;;; a partial amount without hitting EOF.
856     ;;;
857 ram 1.13 (defun fd-stream-read-n-bytes (stream buffer start requested eof-error-p)
858     (declare (type stream stream) (type index start requested))
859     (let* ((sap (fd-stream-ibuf-sap stream))
860 ram 1.24 (offset start)
861 ram 1.13 (head (fd-stream-ibuf-head stream))
862     (tail (fd-stream-ibuf-tail stream))
863     (available (- tail head))
864 ram 1.24 (copy (min requested available)))
865     (declare (type index offset head tail available copy))
866 gerd 1.72 ;;
867     ;; If something has been unread, put that at buffer + start,
868     ;; and read the rest to start + 1.
869     (when (fd-stream-unread stream)
870     (etypecase buffer
871     (system-area-pointer
872     (assert (= 1 (fd-stream-element-size stream)))
873     (setf (sap-ref-8 buffer start) (char-code (read-char stream))))
874     (vector
875     (setf (aref buffer start) (read-char stream))))
876     (return-from fd-stream-read-n-bytes
877     (1+ (fd-stream-read-n-bytes stream buffer (1+ start) (1- requested)
878     eof-error-p))))
879     ;;
880 ram 1.13 (unless (zerop copy)
881     (if (typep buffer 'system-area-pointer)
882     (system-area-copy sap (* head vm:byte-bits)
883     buffer (* offset vm:byte-bits)
884     (* copy vm:byte-bits))
885     (copy-from-system-area sap (* head vm:byte-bits)
886     buffer (+ (* offset vm:byte-bits)
887     (* vm:vector-data-offset
888     vm:word-bits))
889     (* copy vm:byte-bits)))
890     (incf (fd-stream-ibuf-head stream) copy))
891     (cond
892 ram 1.24 ((or (= copy requested)
893     (and (not eof-error-p) (/= copy 0)))
894     copy)
895     (t
896 ram 1.13 (setf (fd-stream-ibuf-head stream) 0)
897     (setf (fd-stream-ibuf-tail stream) 0)
898     (setf (fd-stream-listen stream) nil)
899 ram 1.24 (let ((now-needed (- requested copy))
900 ram 1.13 (len (fd-stream-ibuf-length stream)))
901     (declare (type index now-needed len))
902     (cond
903     ((> now-needed len)
904 ram 1.32 ;;
905     ;; If the desired amount is greater than the stream buffer size, then
906     ;; read directly into the destination, incrementing the start
907     ;; accordingly. In this case, we never leave anything in the stream
908     ;; buffer.
909 ram 1.13 (system:without-gcing
910     (loop
911     (multiple-value-bind
912     (count err)
913 wlott 1.19 (unix:unix-read (fd-stream-fd stream)
914 ram 1.13 (sap+ (if (typep buffer 'system-area-pointer)
915     buffer
916     (vector-sap buffer))
917     (+ offset copy))
918     now-needed)
919     (declare (type (or index null) count))
920     (unless count
921     (error "Error reading ~S: ~A" stream
922 wlott 1.19 (unix:get-unix-error-msg err)))
923 pw 1.48 (decf now-needed count)
924 ram 1.33 (if eof-error-p
925     (when (zerop count)
926     (error 'end-of-file :stream stream))
927     (return (- requested now-needed)))
928 ram 1.13 (when (zerop now-needed) (return requested))
929     (incf offset count)))))
930     (t
931 ram 1.32 ;;
932     ;; If we want less than the buffer size, then loop trying to fill the
933     ;; stream buffer and copying what we get into the destination. When
934     ;; we have enough, we leave what's left in the stream buffer.
935 ram 1.13 (loop
936     (multiple-value-bind
937     (count err)
938 wlott 1.19 (unix:unix-read (fd-stream-fd stream) sap len)
939 ram 1.13 (declare (type (or index null) count))
940     (unless count
941     (error "Error reading ~S: ~A" stream
942 wlott 1.19 (unix:get-unix-error-msg err)))
943 ram 1.33 (when (and eof-error-p (zerop count))
944     (error 'end-of-file :stream stream))
945    
946 ram 1.13 (let* ((copy (min now-needed count))
947     (copy-bits (* copy vm:byte-bits))
948     (buffer-start-bits
949     (* (+ offset available) vm:byte-bits)))
950     (declare (type index copy copy-bits buffer-start-bits))
951     (if (typep buffer 'system-area-pointer)
952     (system-area-copy sap 0
953     buffer buffer-start-bits
954     copy-bits)
955     (copy-from-system-area sap 0
956     buffer (+ buffer-start-bits
957     (* vm:vector-data-offset
958     vm:word-bits))
959     copy-bits))
960 ram 1.32
961 ram 1.13 (decf now-needed copy)
962 ram 1.33 (when (or (zerop now-needed) (not eof-error-p))
963 ram 1.32 (setf (fd-stream-ibuf-head stream) copy)
964     (setf (fd-stream-ibuf-tail stream) count)
965 ram 1.33 (return (- requested now-needed)))
966 ram 1.24 (incf offset copy)))))))))))
967 ram 1.13
968 ram 1.1
969     ;;;; Utility functions (misc routines, etc)
970    
971     ;;; SET-ROUTINES -- internal
972     ;;;
973 ram 1.24 ;;; Fill in the various routine slots for the given type. Input-p and
974     ;;; output-p indicate what slots to fill. The buffering slot must be set prior
975     ;;; to calling this routine.
976 ram 1.1 ;;;
977 ram 1.24 (defun set-routines (stream type input-p output-p buffer-p)
978 ram 1.1 (let ((target-type (case type
979     ((:default unsigned-byte)
980     '(unsigned-byte 8))
981     (signed-byte
982     '(signed-byte 8))
983     (t
984     type)))
985     (input-type nil)
986     (output-type nil)
987     (input-size nil)
988     (output-size nil))
989    
990 wlott 1.5 (when (fd-stream-obuf-sap stream)
991     (push (fd-stream-obuf-sap stream) *available-buffers*)
992     (setf (fd-stream-obuf-sap stream) nil))
993     (when (fd-stream-ibuf-sap stream)
994     (push (fd-stream-ibuf-sap stream) *available-buffers*)
995     (setf (fd-stream-ibuf-sap stream) nil))
996 ram 1.1
997     (when input-p
998     (multiple-value-bind
999     (routine type size)
1000     (pick-input-routine target-type)
1001     (unless routine
1002     (error "Could not find any input routine for ~S" target-type))
1003 wlott 1.5 (setf (fd-stream-ibuf-sap stream) (next-available-buffer))
1004     (setf (fd-stream-ibuf-length stream) bytes-per-buffer)
1005     (setf (fd-stream-ibuf-tail stream) 0)
1006 ram 1.1 (if (subtypep type 'character)
1007 ram 1.14 (setf (fd-stream-in stream) routine
1008 ram 1.24 (fd-stream-bin stream) #'ill-bin)
1009 ram 1.14 (setf (fd-stream-in stream) #'ill-in
1010 ram 1.24 (fd-stream-bin stream) routine))
1011 toy 1.58 (when (or (eql size 1)
1012     (eql size 2)
1013     (eql size 4))
1014     ;; Support for n-byte operations on 8-, 16-, and 32-bit streams
1015 ram 1.24 (setf (fd-stream-n-bin stream) #'fd-stream-read-n-bytes)
1016 toy 1.60 (when (and buffer-p (eql size 1)
1017     (or (eq type 'unsigned-byte)
1018     (eq type :default)))
1019     ;; We only create this buffer for streams of type
1020     ;; (unsigned-byte 8). Because there's no buffer, the
1021     ;; other element-types will dispatch to the appropriate
1022     ;; input (output) routine in fast-read-byte.
1023 dtc 1.43 (setf (lisp-stream-in-buffer stream)
1024 ram 1.24 (make-array in-buffer-length
1025     :element-type '(unsigned-byte 8)))))
1026 ram 1.1 (setf input-size size)
1027     (setf input-type type)))
1028    
1029     (when output-p
1030     (multiple-value-bind
1031     (routine type size)
1032     (pick-output-routine target-type (fd-stream-buffering stream))
1033     (unless routine
1034     (error "Could not find any output routine for ~S buffered ~S."
1035     (fd-stream-buffering stream)
1036     target-type))
1037 wlott 1.5 (setf (fd-stream-obuf-sap stream) (next-available-buffer))
1038     (setf (fd-stream-obuf-length stream) bytes-per-buffer)
1039 ram 1.1 (setf (fd-stream-obuf-tail stream) 0)
1040     (if (subtypep type 'character)
1041     (setf (fd-stream-out stream) routine
1042     (fd-stream-bout stream) #'ill-bout)
1043     (setf (fd-stream-out stream)
1044     (or (if (eql size 1)
1045 wlott 1.16 (pick-output-routine 'base-char
1046 ram 1.1 (fd-stream-buffering stream)))
1047     #'ill-out)
1048     (fd-stream-bout stream) routine))
1049     (setf (fd-stream-sout stream)
1050     (if (eql size 1) #'fd-sout #'ill-out))
1051     (setf (fd-stream-char-pos stream) 0)
1052     (setf output-size size)
1053     (setf output-type type)))
1054    
1055     (when (and input-size output-size
1056     (not (eq input-size output-size)))
1057     (error "Element sizes for input (~S:~S) and output (~S:~S) differ?"
1058     input-type input-size
1059     output-type output-size))
1060     (setf (fd-stream-element-size stream)
1061     (or input-size output-size))
1062    
1063     (setf (fd-stream-element-type stream)
1064     (cond ((equal input-type output-type)
1065     input-type)
1066 dtc 1.39 ((null output-type)
1067     input-type)
1068     ((null input-type)
1069     output-type)
1070     ((subtypep input-type output-type)
1071 ram 1.1 input-type)
1072     ((subtypep output-type input-type)
1073     output-type)
1074     (t
1075     (error "Input type (~S) and output type (~S) are unrelated?"
1076     input-type
1077     output-type))))))
1078    
1079 toy 1.66 ;;; REVERT-FILE -- internal
1080     ;;;
1081     ;;; Revert a file, if possible; otherwise just delete it. Used during
1082     ;;; CLOSE when the abort flag is set.
1083     ;;;
1084     (defun revert-file (filename original)
1085     (declare (type simple-base-string filename)
1086     (type (or simple-base-string null) original))
1087     (if original
1088     (multiple-value-bind (okay err) (unix:unix-rename original filename)
1089     (unless okay
1090     (cerror "Go on as if nothing bad happened."
1091 emarsden 1.71 "Could not restore ~S to its original contents: ~A"
1092 toy 1.66 filename (unix:get-unix-error-msg err))))
1093     (multiple-value-bind (okay err) (unix:unix-unlink filename)
1094     (unless okay
1095     (cerror "Go on as if nothing bad happened."
1096     "Could not remove ~S: ~A"
1097     filename (unix:get-unix-error-msg err))))))
1098    
1099     ;;; DELETE-ORIGINAL -- internal
1100     ;;;
1101     ;;; Delete a backup file. Used during CLOSE.
1102     ;;;
1103     (defun delete-original (filename original)
1104     (declare (type simple-base-string filename)
1105     (type (or simple-base-string null) original))
1106     (when original
1107     (multiple-value-bind (okay err) (unix:unix-unlink original)
1108     (unless okay
1109     (cerror "Go on as if nothing bad happened."
1110     "Could not delete ~S during close of ~S: ~A"
1111 emarsden 1.69 original filename (unix:get-unix-error-msg err))))))
1112 toy 1.66
1113 ram 1.1 ;;; FD-STREAM-MISC-ROUTINE -- input
1114     ;;;
1115     ;;; Handle the various misc operations on fd-stream.
1116     ;;;
1117     (defun fd-stream-misc-routine (stream operation &optional arg1 arg2)
1118 ram 1.24 (declare (ignore arg2))
1119 ram 1.1 (case operation
1120 ram 1.24 (:listen
1121 ram 1.1 (or (not (eql (fd-stream-ibuf-head stream)
1122     (fd-stream-ibuf-tail stream)))
1123     (fd-stream-listen stream)
1124     (setf (fd-stream-listen stream)
1125 dtc 1.41 (eql (alien:with-alien ((read-fds (alien:struct unix:fd-set)))
1126     (unix:fd-zero read-fds)
1127     (unix:fd-set (fd-stream-fd stream) read-fds)
1128     (unix:unix-fast-select (1+ (fd-stream-fd stream))
1129     (alien:addr read-fds) nil nil
1130     0 0))
1131 ram 1.13 1))))
1132 ram 1.1 (:unread
1133 wlott 1.5 (setf (fd-stream-unread stream) arg1)
1134     (setf (fd-stream-listen stream) t))
1135 ram 1.1 (:close
1136     (cond (arg1
1137     ;; We got us an abort on our hands.
1138 dtc 1.40 (when (fd-stream-handler stream)
1139     (system:remove-fd-handler (fd-stream-handler stream))
1140     (setf (fd-stream-handler stream) nil))
1141 toy 1.66 (when (and (fd-stream-file stream) (fd-stream-obuf-sap stream))
1142     (revert-file (fd-stream-file stream)
1143     (fd-stream-original stream))))
1144 ram 1.1 (t
1145     (fd-stream-misc-routine stream :finish-output)
1146 toy 1.66 (when (fd-stream-delete-original stream)
1147     (delete-original (fd-stream-file stream)
1148     (fd-stream-original stream)))))
1149 wlott 1.17 (when (fboundp 'cancel-finalization)
1150     (cancel-finalization stream))
1151 wlott 1.19 (unix:unix-close (fd-stream-fd stream))
1152 wlott 1.5 (when (fd-stream-obuf-sap stream)
1153     (push (fd-stream-obuf-sap stream) *available-buffers*)
1154     (setf (fd-stream-obuf-sap stream) nil))
1155     (when (fd-stream-ibuf-sap stream)
1156     (push (fd-stream-ibuf-sap stream) *available-buffers*)
1157     (setf (fd-stream-ibuf-sap stream) nil))
1158 ram 1.1 (lisp::set-closed-flame stream))
1159 wlott 1.6 (:clear-input
1160 wlott 1.25 (setf (fd-stream-unread stream) nil)
1161 wlott 1.6 (setf (fd-stream-ibuf-head stream) 0)
1162     (setf (fd-stream-ibuf-tail stream) 0)
1163 ram 1.38 (catch 'eof-input-catcher
1164     (loop
1165 dtc 1.49 (multiple-value-bind
1166     (count errno)
1167     (alien:with-alien ((read-fds (alien:struct unix:fd-set)))
1168     (unix:fd-zero read-fds)
1169     (unix:fd-set (fd-stream-fd stream) read-fds)
1170     (unix:unix-fast-select (1+ (fd-stream-fd stream))
1171     (alien:addr read-fds) nil nil 0 0))
1172 ram 1.38 (cond ((eql count 1)
1173     (do-input stream)
1174     (setf (fd-stream-ibuf-head stream) 0)
1175     (setf (fd-stream-ibuf-tail stream) 0))
1176 dtc 1.49 ((and (not count) (eql errno unix:eintr)))
1177 ram 1.38 (t
1178     (return t)))))))
1179 ram 1.1 (:force-output
1180     (flush-output-buffer stream))
1181     (:finish-output
1182     (flush-output-buffer stream)
1183     (do ()
1184     ((null (fd-stream-output-later stream)))
1185     (system:serve-all-events)))
1186     (:element-type
1187     (fd-stream-element-type stream))
1188 ram 1.22 (:interactive-p
1189     (unix:unix-isatty (fd-stream-fd stream)))
1190 ram 1.1 (:line-length
1191     80)
1192     (:charpos
1193     (fd-stream-char-pos stream))
1194     (:file-length
1195 pw 1.56 (unless (fd-stream-file stream)
1196     (error 'simple-type-error
1197     :datum stream
1198     :expected-type 'file-stream
1199     :format-control "~s is not a stream associated with a file."
1200     :format-arguments (list stream)))
1201 ram 1.1 (multiple-value-bind
1202     (okay dev ino mode nlink uid gid rdev size
1203     atime mtime ctime blksize blocks)
1204 wlott 1.19 (unix:unix-fstat (fd-stream-fd stream))
1205 ram 1.1 (declare (ignore ino nlink uid gid rdev
1206     atime mtime ctime blksize blocks))
1207     (unless okay
1208 pmai 1.61 (error 'simple-file-error
1209     :format-control "Error fstating ~S: ~A"
1210     :format-arguments (list stream (unix:get-unix-error-msg dev))))
1211 dtc 1.51 (if (zerop mode)
1212 ram 1.23 nil
1213 toy 1.64 (values (truncate size (fd-stream-element-size stream))))))
1214 ram 1.1 (:file-position
1215 ram 1.29 (fd-stream-file-position stream arg1))))
1216 ram 1.1
1217 ram 1.28
1218 ram 1.1 ;;; FD-STREAM-FILE-POSITION -- internal.
1219     ;;;
1220     (defun fd-stream-file-position (stream &optional newpos)
1221 ram 1.14 (declare (type fd-stream stream)
1222 dtc 1.51 (type (or (integer 0) (member nil :start :end)) newpos))
1223 ram 1.1 (if (null newpos)
1224     (system:without-interrupts
1225 dtc 1.51 ;; First, find the position of the UNIX file descriptor in the file.
1226 ram 1.1 (multiple-value-bind
1227 dtc 1.51 (posn errno)
1228 wlott 1.19 (unix:unix-lseek (fd-stream-fd stream) 0 unix:l_incr)
1229 dtc 1.51 (declare (type (or (integer 0) null) posn))
1230     (cond (posn
1231 ram 1.1 ;; Adjust for buffered output:
1232     ;; If there is any output buffered, the *real* file position
1233     ;; will be larger than reported by lseek because lseek
1234 toy 1.70 ;; obviously cannot take into account output we have not
1235 ram 1.1 ;; sent yet.
1236     (dolist (later (fd-stream-output-later stream))
1237 ram 1.14 (incf posn (- (the index (caddr later))
1238     (the index (cadr later)))))
1239 ram 1.1 (incf posn (fd-stream-obuf-tail stream))
1240     ;; Adjust for unread input:
1241     ;; If there is any input read from UNIX but not supplied to
1242     ;; the user of the stream, the *real* file position will
1243     ;; smaller than reported, because we want to look like the
1244     ;; unread stuff is still available.
1245     (decf posn (- (fd-stream-ibuf-tail stream)
1246     (fd-stream-ibuf-head stream)))
1247     (when (fd-stream-unread stream)
1248     (decf posn))
1249     ;; Divide bytes by element size.
1250 ram 1.14 (truncate posn (fd-stream-element-size stream)))
1251 wlott 1.19 ((eq errno unix:espipe)
1252 ram 1.1 nil)
1253     (t
1254     (system:with-interrupts
1255     (error "Error lseek'ing ~S: ~A"
1256     stream
1257 wlott 1.19 (unix:get-unix-error-msg errno)))))))
1258 dtc 1.51 (let ((offset 0)
1259     origin)
1260     (declare (type (integer 0) offset))
1261 ram 1.1 ;; Make sure we don't have any output pending, because if we move the
1262     ;; file pointer before writing this stuff, it will be written in the
1263     ;; wrong location.
1264     (flush-output-buffer stream)
1265     (do ()
1266     ((null (fd-stream-output-later stream)))
1267     (system:serve-all-events))
1268 ram 1.4 ;; Clear out any pending input to force the next read to go to the
1269     ;; disk.
1270     (setf (fd-stream-unread stream) nil)
1271     (setf (fd-stream-ibuf-head stream) 0)
1272     (setf (fd-stream-ibuf-tail stream) 0)
1273 dtc 1.51 ;; Trash cached value for listen, so that we check next time.
1274 wlott 1.5 (setf (fd-stream-listen stream) nil)
1275 ram 1.4 ;; Now move it.
1276 ram 1.1 (cond ((eq newpos :start)
1277 dtc 1.51 (setf offset 0
1278     origin unix:l_set))
1279 ram 1.1 ((eq newpos :end)
1280 dtc 1.51 (setf offset 0
1281     origin unix:l_xtnd))
1282     ((typep newpos '(integer 0))
1283 ram 1.1 (setf offset (* newpos (fd-stream-element-size stream))
1284 wlott 1.19 origin unix:l_set))
1285 ram 1.1 (t
1286     (error "Invalid position given to file-position: ~S" newpos)))
1287     (multiple-value-bind
1288     (posn errno)
1289 wlott 1.19 (unix:unix-lseek (fd-stream-fd stream) offset origin)
1290 dtc 1.51 (cond (posn
1291 ram 1.1 t)
1292 wlott 1.19 ((eq errno unix:espipe)
1293 ram 1.1 nil)
1294     (t
1295     (error "Error lseek'ing ~S: ~A"
1296     stream
1297 wlott 1.19 (unix:get-unix-error-msg errno))))))))
1298 ram 1.1
1299    
1300    
1301     ;;;; Creation routines (MAKE-FD-STREAM and OPEN)
1302    
1303     ;;; MAKE-FD-STREAM -- Public.
1304     ;;;
1305     ;;; Returns a FD-STREAM on the given file.
1306     ;;;
1307     (defun make-fd-stream (fd
1308     &key
1309     (input nil input-p)
1310     (output nil output-p)
1311 wlott 1.16 (element-type 'base-char)
1312 ram 1.1 (buffering :full)
1313 ram 1.15 timeout
1314 ram 1.1 file
1315     original
1316     delete-original
1317 ram 1.28 pathname
1318 ram 1.24 input-buffer-p
1319 ram 1.1 (name (if file
1320     (format nil "file ~S" file)
1321 wlott 1.17 (format nil "descriptor ~D" fd)))
1322     auto-close)
1323 ram 1.15 (declare (type index fd) (type (or index null) timeout)
1324     (type (member :none :line :full) buffering))
1325     "Create a stream for the given unix file descriptor.
1326     If input is non-nil, allow input operations.
1327     If output is non-nil, allow output operations.
1328     If neither input nor output are specified, default to allowing input.
1329     Element-type indicates the element type to use (as for open).
1330     Buffering indicates the kind of buffering to use.
1331     Timeout (if true) is the number of seconds to wait for input. If NIL (the
1332     default), then wait forever. When we time out, we signal IO-TIMEOUT.
1333     File is the name of the file (will be returned by PATHNAME).
1334     Name is used to identify the stream when printed."
1335 ram 1.1 (cond ((not (or input-p output-p))
1336     (setf input t))
1337     ((not (or input output))
1338     (error "File descriptor must be opened either for input or output.")))
1339     (let ((stream (%make-fd-stream :fd fd
1340     :name name
1341     :file file
1342     :original original
1343     :delete-original delete-original
1344 ram 1.28 :pathname pathname
1345 ram 1.15 :buffering buffering
1346     :timeout timeout)))
1347 ram 1.24 (set-routines stream element-type input output input-buffer-p)
1348 wlott 1.17 (when (and auto-close (fboundp 'finalize))
1349     (finalize stream
1350     #'(lambda ()
1351 wlott 1.19 (unix:unix-close fd)
1352 toy 1.70 (format *terminal-io* "** Closed ~A~%" name)
1353     (when original
1354     (revert-file file original)))))
1355 ram 1.1 stream))
1356    
1357 ram 1.24
1358 toy 1.66 ;;; PICK-BACKUP-NAME -- internal
1359 ram 1.1 ;;;
1360     ;;; Pick a name to use for the backup file.
1361     ;;;
1362     (defvar *backup-extension* ".BAK"
1363     "This is a string that OPEN tacks on the end of a file namestring to produce
1364     a name for the :if-exists :rename-and-delete and :rename options. Also,
1365     this can be a function that takes a namestring and returns a complete
1366     namestring.")
1367     ;;;
1368     (defun pick-backup-name (name)
1369 ram 1.14 (declare (type simple-string name))
1370     (let ((ext *backup-extension*))
1371     (etypecase ext
1372     (simple-string (concatenate 'simple-string name ext))
1373     (function (funcall ext name)))))
1374 ram 1.1
1375 toy 1.65 ;;; NEXT-VERSION -- internal
1376     ;;;
1377     ;;; Find the next available versioned name for a file.
1378     ;;;
1379     (defun next-version (name)
1380     (declare (type simple-string name))
1381     (let* ((sep (position #\/ name :from-end t))
1382     (base (if sep (subseq name 0 (1+ sep)) ""))
1383     (dir (unix:open-dir base)))
1384     (multiple-value-bind (name type version)
1385     (extract-name-type-and-version name (if sep (1+ sep) 0) (length name))
1386     (let ((version (if (symbolp version) 1 (1+ version)))
1387 toy 1.67 (match (if type
1388     (concatenate 'string name "." type ".~")
1389     (concatenate 'string name ".~"))))
1390 toy 1.65 (when dir
1391     (unwind-protect
1392     (loop
1393     (let ((name (unix:read-dir dir)))
1394     (cond ((null name) (return))
1395     ((and (> (length name) (length match))
1396     (string= name match :end1 (length match)))
1397     (multiple-value-bind (v e)
1398     (parse-integer name :start (length match)
1399     :junk-allowed t)
1400     (when (and v
1401     (= (length name) (1+ e))
1402     (char= (schar name e) #\~))
1403     (setq version (max version (1+ v)))))))))
1404     (unix:close-dir dir)))
1405     (concatenate 'string base
1406     match (quick-integer-to-string version) "~")))))
1407    
1408 ram 1.1 ;;; ASSURE-ONE-OF -- internal
1409     ;;;
1410     ;;; Assure that the given arg is one of the given list of valid things.
1411     ;;; Allow the user to fix any problems.
1412     ;;;
1413     (defun assure-one-of (item list what)
1414     (unless (member item list)
1415     (loop
1416     (cerror "Enter new value for ~*~S"
1417     "~S is invalid for ~S. Must be one of~{ ~S~}"
1418     item
1419     what
1420     list)
1421 ram 1.14 (format (the stream *query-io*) "Enter new value for ~S: " what)
1422 ram 1.1 (force-output *query-io*)
1423     (setf item (read *query-io*))
1424     (when (member item list)
1425     (return))))
1426     item)
1427    
1428 ram 1.14 ;;; DO-OLD-RENAME -- Internal
1429     ;;;
1430     ;;; Rename Namestring to Original. First, check if we have write access,
1431     ;;; since we don't want to trash unwritable files even if we technically can.
1432 toy 1.70 ;;; We return true if we succeed in renaming.
1433 ram 1.14 ;;;
1434     (defun do-old-rename (namestring original)
1435 wlott 1.19 (unless (unix:unix-access namestring unix:w_ok)
1436 ram 1.14 (cerror "Try to rename it anyway." "File ~S is not writable." namestring))
1437     (multiple-value-bind
1438     (okay err)
1439 wlott 1.19 (unix:unix-rename namestring original)
1440 ram 1.14 (cond (okay t)
1441     (t
1442     (cerror "Use :SUPERSEDE instead."
1443     "Could not rename ~S to ~S: ~A."
1444     namestring
1445     original
1446 wlott 1.19 (unix:get-unix-error-msg err))
1447 ram 1.14 nil))))
1448    
1449 toy 1.66 ;;; FD-OPEN -- Internal
1450 pw 1.57 ;;;
1451 toy 1.66 ;;; Open a file.
1452 pw 1.57 ;;;
1453 toy 1.66 (defun fd-open (pathname direction if-exists if-exists-given
1454     if-does-not-exist if-does-not-exist-given)
1455     (declare (type pathname pathname)
1456     (type (member :input :output :io :probe) direction)
1457     (type (member :error :new-version :rename :rename-and-delete
1458     :overwrite :append :supersede nil) if-exists)
1459     (type (member :error :create nil) if-does-not-exist))
1460     (multiple-value-bind (input output mask)
1461     (ecase direction
1462     (:input (values t nil unix:o_rdonly))
1463     (:output (values nil t unix:o_wronly))
1464     (:io (values t t unix:o_rdwr))
1465     (:probe (values t nil unix:o_rdonly)))
1466     (declare (type index mask))
1467 emarsden 1.76 ;; Process if-exists argument if we are doing any output.
1468     (cond (output
1469     (unless if-exists-given
1470     (setf if-exists
1471     (if (eq (pathname-version pathname) :newest)
1472     :new-version
1473     :error)))
1474     (case if-exists
1475     ((:error nil)
1476     (setf mask (logior mask unix:o_excl)))
1477     ((:new-version :rename :rename-and-delete)
1478     (setf mask (logior mask unix:o_creat)))
1479     (:supersede
1480     (setf mask (logior mask unix:o_trunc)))))
1481     (t
1482     (setf if-exists nil))) ; :ignore-this-arg
1483    
1484     (unless if-does-not-exist-given
1485     (setf if-does-not-exist
1486     (cond ((eq direction :input) :error)
1487     ((and output
1488     (member if-exists '(:overwrite :append)))
1489     :error)
1490     ((eq direction :probe)
1491     nil)
1492     (t
1493     :create))))
1494     (if (eq if-does-not-exist :create)
1495     (setf mask (logior mask unix:o_creat)))
1496    
1497 toy 1.66 (let ((name (cond ((unix-namestring pathname input))
1498     ((and input (eq if-does-not-exist :create))
1499     (unix-namestring pathname nil)))))
1500     (let ((original (cond ((eq if-exists :new-version)
1501     (next-version name))
1502     ((member if-exists '(:rename :rename-and-delete))
1503     (pick-backup-name name))))
1504     (delete-original (eq if-exists :rename-and-delete))
1505     (mode #o666))
1506     (when original
1507     ;; We are doing a :rename or :rename-and-delete.
1508     ;; Determine if the file already exists, make sure the original
1509     ;; file is not a directory and keep the mode
1510     (let ((exists
1511     (and name
1512     (multiple-value-bind
1513     (okay err/dev inode orig-mode)
1514     (unix:unix-stat name)
1515     (declare (ignore inode)
1516     (type (or index null) orig-mode))
1517     (cond
1518     (okay
1519     (when (and output (= (logand orig-mode #o170000)
1520     #o40000))
1521     (error 'simple-file-error
1522     :pathname pathname
1523     :format-control
1524     "Cannot open ~S for output: Is a directory."
1525     :format-arguments (list name)))
1526     (setf mode (logand orig-mode #o777))
1527     t)
1528     ((eql err/dev unix:enoent)
1529     nil)
1530     (t
1531     (error 'simple-file-error
1532     :pathname pathname
1533     :format-control "Cannot find ~S: ~A"
1534     :format-arguments
1535     (list name
1536     (unix:get-unix-error-msg err/dev)))))))))
1537     (unless (and exists
1538     (do-old-rename name original))
1539     (setf original nil)
1540     (setf delete-original nil)
1541     ;; In order to use SUPERSEDE instead, we have
1542     ;; to make sure unix:o_creat corresponds to
1543     ;; if-does-not-exist. unix:o_creat was set
1544     ;; before because of if-exists being :rename.
1545     (unless (eq if-does-not-exist :create)
1546     (setf mask (logior (logandc2 mask unix:o_creat)
1547     unix:o_trunc)))
1548     (setf if-exists :supersede))))
1549    
1550     ;; Okay, now we can try the actual open.
1551     (loop
1552     (multiple-value-bind (fd errno)
1553     (if name
1554     (unix:unix-open name mask mode)
1555     (values nil unix:enoent))
1556     (cond ((fixnump fd)
1557 toy 1.68 (when (eq if-exists :append)
1558     (unix:unix-lseek fd 0 unix:l_xtnd)) ; SEEK_END
1559 toy 1.66 (return (values fd name original delete-original)))
1560     ((eql errno unix:enoent)
1561     (case if-does-not-exist
1562     (:error
1563     (cerror "Return NIL."
1564     'simple-file-error
1565     :pathname pathname
1566     :format-control "Error opening ~S, ~A."
1567     :format-arguments
1568     (list pathname
1569     (unix:get-unix-error-msg errno))))
1570     (:create
1571     (cerror "Return NIL."
1572     'simple-file-error
1573     :pathname pathname
1574     :format-control
1575     "Error creating ~S, path does not exist."
1576     :format-arguments (list pathname))))
1577     (return nil))
1578     ((eql errno unix:eexist)
1579     (unless (eq nil if-exists)
1580     (cerror "Return NIL."
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     (return nil))
1588     ((eql errno unix:eacces)
1589     (cerror "Try again."
1590     'simple-file-error
1591     :pathname pathname
1592     :format-control "Error opening ~S, ~A."
1593     :format-arguments
1594     (list pathname
1595     (unix:get-unix-error-msg errno))))
1596     (t
1597     (cerror "Return NIL."
1598     'simple-file-error
1599     :pathname pathname
1600     :format-control "Error opening ~S, ~A."
1601     :format-arguments
1602     (list pathname
1603     (unix:get-unix-error-msg errno)))
1604     (return nil)))))))))
1605    
1606     ;;; OPEN-FD-STREAM -- Internal
1607     ;;;
1608     ;;; Open an fd-stream connected to a file.
1609     ;;;
1610     (defun open-fd-stream (pathname &key (direction :input)
1611     (element-type 'base-char)
1612     (if-exists nil if-exists-given)
1613     (if-does-not-exist nil if-does-not-exist-given)
1614     (external-format :default))
1615     (declare (type pathname pathname)
1616     (type (member :input :output :io :probe) direction)
1617     (type (member :error :new-version :rename :rename-and-delete
1618     :overwrite :append :supersede nil) if-exists)
1619     (type (member :error :create nil) if-does-not-exist)
1620     (ignore external-format))
1621     (multiple-value-bind (fd namestring original delete-original)
1622     (fd-open pathname direction if-exists if-exists-given
1623     if-does-not-exist if-does-not-exist-given)
1624     (when fd
1625     (case direction
1626     ((:input :output :io)
1627     (make-fd-stream fd
1628     :input (member direction '(:input :io))
1629     :output (member direction '(:output :io))
1630     :element-type element-type
1631     :file namestring
1632     :original original
1633     :delete-original delete-original
1634     :pathname pathname
1635     :input-buffer-p t
1636     :auto-close t))
1637     (:probe
1638     (let ((stream (%make-fd-stream :name namestring :fd fd
1639     :pathname pathname
1640     :element-type element-type)))
1641     (close stream)
1642     stream))))))
1643 ram 1.14
1644 ram 1.1 ;;; OPEN -- public
1645     ;;;
1646     ;;; Open the given file.
1647     ;;;
1648 toy 1.66 (defun open (filename &rest options
1649     &key (direction :input)
1650     (element-type 'base-char element-type-given)
1651     (if-exists nil if-exists-given)
1652     (if-does-not-exist nil if-does-not-exist-given)
1653     (external-format :default)
1654     class mapped input-handle output-handle
1655     &allow-other-keys
1656     &aux ; Squelch assignment warning.
1657     (direction direction)
1658     (if-does-not-exist if-does-not-exist)
1659     (if-exists if-exists))
1660 ram 1.1 "Return a stream which reads from or writes to Filename.
1661     Defined keywords:
1662     :direction - one of :input, :output, :io, or :probe
1663 wlott 1.16 :element-type - Type of object to read or write, default BASE-CHAR
1664 ram 1.1 :if-exists - one of :error, :new-version, :rename, :rename-and-delete,
1665     :overwrite, :append, :supersede or nil
1666     :if-does-not-exist - one of :error, :create or nil
1667 toy 1.66 :external-format - :default
1668 ram 1.1 See the manual for details."
1669 toy 1.66 (declare (ignore external-format input-handle output-handle))
1670 rtoy 1.78
1671     ;; OPEN signals a file-error if the filename is wild.
1672     (when (wild-pathname-p filename)
1673     (error 'file-error :pathname filename))
1674 dtc 1.46
1675 ram 1.1 ;; First, make sure that DIRECTION is valid. Allow it to be changed if not.
1676 toy 1.67 (setq direction
1677 ram 1.1 (assure-one-of direction
1678     '(:input :output :io :probe)
1679     :direction))
1680 toy 1.67 (setf (getf options :direction) direction)
1681 ram 1.1
1682 toy 1.66 (when (and if-exists-given (member direction '(:output :io)))
1683     (setq if-exists
1684     (assure-one-of if-exists
1685     '(:error :new-version :rename
1686     :rename-and-delete :overwrite
1687     :append :supersede nil)
1688     :if-exists))
1689     (setf (getf options :if-exists) if-exists))
1690    
1691     (when if-does-not-exist-given
1692     (setq if-does-not-exist
1693     (assure-one-of if-does-not-exist
1694     '(:error :create nil)
1695     :if-does-not-exist))
1696     (setf (getf options :if-does-not-exist) if-does-not-exist))
1697    
1698 toy 1.67 (let ((filespec (pathname filename))
1699 toy 1.66 (options (copy-list options))
1700 toy 1.67 (class (or class 'fd-stream)))
1701 toy 1.66 (cond ((eq class 'fd-stream)
1702     (remf options :class)
1703     (remf options :mapped)
1704     (remf options :input-handle)
1705     (remf options :output-handle)
1706     (apply #'open-fd-stream filespec options))
1707     ((subtypep class 'stream:simple-stream)
1708     (when element-type-given
1709 toy 1.70 (cerror "Do it anyway."
1710     "Can't create simple-streams with an element-type."))
1711     (when (and (eq class 'stream:file-simple-stream) mapped)
1712     (setq class 'stream:mapped-file-simple-stream)
1713     (setf (getf options :class) 'stream:mapped-file-simple-stream))
1714     (when (subtypep class 'stream:file-simple-stream)
1715 toy 1.66 (when (eq direction :probe)
1716 toy 1.70 (setq class 'stream:probe-simple-stream)))
1717 toy 1.66 (apply #'make-instance class :filename filespec options))
1718     ((subtypep class 'ext:fundamental-stream)
1719     (remf options :class)
1720     (remf options :mapped)
1721     (remf options :input-handle)
1722     (remf options :output-handle)
1723     (let ((stream (apply #'open-fd-stream filespec options)))
1724     (when stream
1725     (make-instance class :lisp-stream stream))))
1726     (t
1727     (error "Unable to open streams of class ~S." class)))))
1728 ram 1.1
1729     ;;;; Initialization.
1730    
1731     (defvar *tty* nil
1732     "The stream connected to the controlling terminal or NIL if there is none.")
1733     (defvar *stdin* nil
1734     "The stream connected to the standard input (file descriptor 0).")
1735     (defvar *stdout* nil
1736     "The stream connected to the standard output (file descriptor 1).")
1737     (defvar *stderr* nil
1738     "The stream connected to the standard error output (file descriptor 2).")
1739    
1740     ;;; STREAM-INIT -- internal interface
1741     ;;;
1742     ;;; Called when the cold load is first started up.
1743     ;;;
1744     (defun stream-init ()
1745     (stream-reinit)
1746     (setf *terminal-io* (make-synonym-stream '*tty*))
1747     (setf *standard-output* (make-synonym-stream '*stdout*))
1748 ram 1.11 (setf *standard-input*
1749     (make-two-way-stream (make-synonym-stream '*stdin*)
1750     *standard-output*))
1751 ram 1.1 (setf *error-output* (make-synonym-stream '*stderr*))
1752     (setf *query-io* (make-synonym-stream '*terminal-io*))
1753 pw 1.53 (setf *debug-io* *query-io*)
1754 ram 1.1 (setf *trace-output* *standard-output*)
1755     nil)
1756    
1757     ;;; STREAM-REINIT -- internal interface
1758     ;;;
1759     ;;; Called whenever a saved core is restarted.
1760     ;;;
1761     (defun stream-reinit ()
1762     (setf *available-buffers* nil)
1763     (setf *stdin*
1764     (make-fd-stream 0 :name "Standard Input" :input t :buffering :line))
1765     (setf *stdout*
1766     (make-fd-stream 1 :name "Standard Output" :output t :buffering :line))
1767     (setf *stderr*
1768     (make-fd-stream 2 :name "Standard Error" :output t :buffering :line))
1769 dtc 1.54 (let ((tty (and (not *batch-mode*)
1770     (unix:unix-open "/dev/tty" unix:o_rdwr #o666))))
1771     (setf *tty*
1772     (if tty
1773 ram 1.1 (make-fd-stream tty :name "the Terminal" :input t :output t
1774 dtc 1.54 :buffering :line :auto-close t)
1775     (make-two-way-stream *stdin* *stdout*))))
1776 ram 1.1 nil)
1777    
1778    
1779     ;;;; Beeping.
1780    
1781     (defun default-beep-function (stream)
1782     (write-char #\bell stream)
1783     (finish-output stream))
1784    
1785     (defvar *beep-function* #'default-beep-function
1786     "This is called in BEEP to feep the user. It takes a stream.")
1787    
1788     (defun beep (&optional (stream *terminal-io*))
1789     (funcall *beep-function* stream))
1790    
1791    
1792     ;;; File-Name -- internal interface
1793     ;;;
1794     ;;; Kind of like File-Position, but is an internal hack used by the filesys
1795     ;;; stuff to get and set the file name.
1796     ;;;
1797     (defun file-name (stream &optional new-name)
1798 toy 1.66 (typecase stream
1799     (stream:simple-stream
1800     (if new-name
1801     (stream::%file-rename stream new-name)
1802     (stream::%file-name stream)))
1803     (fd-stream
1804     (cond (new-name
1805     (setf (fd-stream-pathname stream) new-name)
1806     (setf (fd-stream-file stream)
1807     (unix-namestring new-name nil))
1808     t)
1809     (t
1810     (fd-stream-pathname stream))))))
1811 ram 1.29
1812 ram 1.27
1813     ;;;; Degenerate international character support:
1814    
1815     (defun file-string-length (stream object)
1816 toy 1.66 (declare (type (or string character) object)
1817 rtoy 1.77 (type (or file-stream broadcast-stream stream:simple-stream) stream))
1818 ram 1.27 "Return the delta in Stream's FILE-POSITION that would be caused by writing
1819     Object to Stream. Non-trivial only in implementations that support
1820     international character sets."
1821 toy 1.66 (typecase stream
1822     (stream:simple-stream (stream::%file-string-length stream object))
1823 rtoy 1.77 (broadcast-stream
1824     ;; CLHS says we must return 1 in this case
1825     1)
1826 toy 1.66 (t
1827     (etypecase object
1828     (character 1)
1829     (string (length object))))))

  ViewVC Help
Powered by ViewVC 1.1.5