/[cmucl]/src/code/fd-stream.lisp
ViewVC logotype

Contents of /src/code/fd-stream.lisp

Parent Directory Parent Directory | Revision Log Revision Log


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