/[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.82 - (hide annotations)
Mon Feb 21 17:14:28 2005 UTC (9 years, 1 month ago) by rtoy
Branch: MAIN
CVS Tags: snapshot-2005-03
Changes since 1.81: +19 -6 lines
Apply Lynn Quam's proposed enhancements to fd-streams allowing input
streams opened with element-type (unsigned-byte 8) to be also opened
for character input.  This gives simple-streams semantics to
fd-streams.

* code/fd-stream.lisp
  o Make FD-STREAM-IN use PICK-INPUT-ROUTINE to select the correct
    type of input.
  o Add *FD-STREAM-ENABLE-CHARACTER-AND-BINARY-INPUT* to allow binary
    and character input.  Currently defaults to NIL, but will change
    to T.

* code/stream.lisp
  o New READ-INTO-SIMPLE-STRING to allow stream element-type of
    (unsigned-byte 8).
  o Support reading and writing simple arrays of single-float and
    double-float.
  o Strings can be written to streams of element-type '(unsigned-byte
    8).

* tools/worldcom.lisp
  o Compile stream-vector-io.lisp.

* tools/worldload.lisp
  o Load stream-vector-io.

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

  ViewVC Help
Powered by ViewVC 1.1.5