/[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.4.1.2 - (show annotations) (vendor branch)
Sun May 27 16:44:30 1990 UTC (23 years, 10 months ago) by wlott
Changes since 1.4.1.1: +3 -2 lines
Had the arguments to copy-from-system-area backwards in string-from-sap.
1 ;;; -*- Log: code.log; Package: LISP -*-
2
3 ;;; **********************************************************************
4 ;;; This code was written as part of the Spice Lisp project at
5 ;;; Carnegie-Mellon University, and has been placed in the public domain.
6 ;;; If you want to use this code or any part of Spice Lisp, please contact
7 ;;; Scott Fahlman (FAHLMAN@CMUC).
8 ;;; **********************************************************************
9 ;;;
10 ;;; Streams for UNIX file descriptors.
11 ;;;
12 ;;; Written by William Lott, July 1989 - January 1990.
13 ;;;
14 ;;; **********************************************************************
15
16
17 (in-package "SYSTEM")
18
19 (export '(fd-stream fd-stream-p fd-stream-fd make-fd-stream
20 beep *beep-function*
21 output-raw-bytes
22 *tty* *stdin* *stdout* *stderr*))
23
24
25 (in-package "EXTENSIONS")
26
27 (export '(*backup-extension*))
28
29
30 (in-package "LISP")
31
32
33
34 ;;;; Buffer manipulation routines.
35
36 (defvar *available-buffers* ()
37 "List of available buffers. Each buffer is an dynamic alien.")
38
39 (defconstant bytes-per-buffer (* 4 1024)
40 "Number of bytes per buffer.")
41
42 ;;; NEXT-AVAILABLE-BUFFER -- Internal.
43 ;;;
44 ;;; Returns the next available alien buffer, creating one if necessary.
45 ;;;
46 (proclaim '(inline next-available-buffer))
47 ;;;
48 (defun next-available-buffer ()
49 (if *available-buffers*
50 (pop *available-buffers*)
51 (allocate-system-memory bytes-per-buffer)))
52
53
54 ;;;; The FD-STREAM structure.
55
56 (defstruct (fd-stream
57 (:print-function %print-fd-stream)
58 (:constructor %make-fd-stream)
59 (:include stream
60 (misc #'fd-stream-misc-routine)))
61
62 (name nil) ; The name of this stream
63 (file nil) ; The file this stream is for
64 (original nil) ; The original file (for :if-exists :rename)
65 (delete-original nil) ; for :if-exists :rename-and-delete
66 (element-size 1) ; Number of bytes per element.
67 (element-type 'base-character) ; The type of element being transfered.
68 (fd -1 :type fixnum) ; The file descriptor
69 (buffering :full) ; One of :none, :line, or :full
70 (char-pos nil) ; Character position if known.
71 (listen nil) ; T if we don't need to listen
72
73 ;; The input buffer.
74 (unread nil)
75 (ibuf-sap nil)
76 (ibuf-length nil)
77 (ibuf-head 0 :type fixnum)
78 (ibuf-tail 0 :type fixnum)
79
80 ;; The output buffer.
81 (obuf-sap nil)
82 (obuf-length nil)
83 (obuf-tail 0 :type fixnum)
84
85 ;; Output flushed, but not written due to non-blocking io.
86 (output-later nil)
87 (handler nil))
88
89 (defun %print-fd-stream (fd-stream stream depth)
90 (declare (ignore depth))
91 (format stream "#<Stream for ~A>"
92 (fd-stream-name fd-stream)))
93
94
95
96 ;;;; Output routines and related noise.
97
98 (defvar *output-routines* ()
99 "List of all available output routines. Each element is a list of the
100 element-type output, the kind of buffering, the function name, and the number
101 of bytes per element.")
102
103 ;;; DO-OUTPUT-LATER -- internal
104 ;;;
105 ;;; Called by the server when we can write to the given file descriptor.
106 ;;; Attemt to write the data again. If it worked, remove the data from the
107 ;;; output-later list. If it didn't work, something is wrong.
108 ;;;
109 (defun do-output-later (stream)
110 (let* ((stuff (pop (fd-stream-output-later stream)))
111 (base (car stuff))
112 (start (cadr stuff))
113 (end (caddr stuff))
114 (reuse-sap (cadddr stuff))
115 (length (- end start)))
116 (multiple-value-bind
117 (count errno)
118 (mach:unix-write (fd-stream-fd stream)
119 base
120 start
121 length)
122 (cond ((eql count length) ; Hot damn, it workded.
123 (when reuse-sap
124 (push base *available-buffers*)))
125 ((not (null count)) ; Sorta worked.
126 (push (list base
127 (+ start count)
128 end)
129 (fd-stream-output-later stream)))
130 ((= errno mach:ewouldblock)
131 (error "Write would have blocked, but SERVER told us to go."))
132 (t
133 (error "While writing ~S: ~A"
134 stream
135 (mach:get-unix-error-msg errno))))))
136 (unless (fd-stream-output-later stream)
137 (system:remove-fd-handler (fd-stream-handler stream))
138 (setf (fd-stream-handler stream) nil)))
139
140 ;;; OUTPUT-LATER -- internal
141 ;;;
142 ;;; Arange to output the string when we can write on the file descriptor.
143 ;;;
144 (defun output-later (stream base start end reuse-sap)
145 (cond ((null (fd-stream-output-later stream))
146 (setf (fd-stream-output-later stream)
147 (list (list base start end reuse-sap)))
148 (setf (fd-stream-handler stream)
149 (system:add-fd-handler (fd-stream-fd stream)
150 :output
151 #'(lambda (fd)
152 (declare (ignore fd))
153 (do-output-later stream)))))
154 (t
155 (nconc (fd-stream-output-later stream)
156 (list (list base start end reuse-sap)))))
157 (when reuse-sap
158 (let ((new-buffer (next-available-buffer)))
159 (setf (fd-stream-obuf-sap stream) new-buffer)
160 (setf (fd-stream-obuf-length stream) bytes-per-buffer))))
161
162 ;;; DO-OUTPUT -- internal
163 ;;;
164 ;;; Output the given noise. Check to see if there are any pending writes. If
165 ;;; so, just queue this one. Otherwise, try to write it. If this would block,
166 ;;; queue it.
167 ;;;
168 (defun do-output (stream base start end reuse-sap)
169 (if (not (null (fd-stream-output-later stream))) ; something buffered.
170 (progn
171 (output-later stream base start end reuse-sap)
172 ;; ### check to see if any of this noise can be output
173 )
174 (let ((length (- end start)))
175 (multiple-value-bind
176 (count errno)
177 (mach:unix-write (fd-stream-fd stream) base start length)
178 (cond ((eql count length)) ; Hot damn, it worked.
179 ((not (null count))
180 (output-later stream base (+ start count) end reuse-sap))
181 ((= errno mach:ewouldblock)
182 (output-later stream base start end reuse-sap))
183 (t
184 (error "While writing ~S: ~A"
185 stream
186 (mach:get-unix-error-msg errno))))))))
187
188 ;;; FLUSH-OUTPUT-BUFFER -- internal
189 ;;;
190 ;;; Flush any data in the output buffer.
191 ;;;
192 (defun flush-output-buffer (stream)
193 (let ((length (fd-stream-obuf-tail stream)))
194 (unless (= length 0)
195 (do-output stream (fd-stream-obuf-sap stream) 0 length t)
196 (setf (fd-stream-obuf-tail stream) 0))))
197
198 ;;; DEF-OUTPUT-ROUTINES -- internal
199 ;;;
200 ;;; Define output routines that output numbers size bytes long for the
201 ;;; given bufferings. Use body to do the actual output.
202 ;;;
203 (defmacro def-output-routines ((name size &rest bufferings) &body body)
204 (cons 'progn
205 (mapcar
206 #'(lambda (buffering)
207 (let ((function
208 (intern (let ((*print-case* :upcase))
209 (format nil name (car buffering))))))
210 `(progn
211 (defun ,function (stream byte)
212 ,(unless (eq (car buffering) :none)
213 `(when (< (fd-stream-obuf-length stream)
214 (+ (fd-stream-obuf-tail stream)
215 ,size))
216 (flush-output-buffer stream)))
217 ,@body
218 (incf (fd-stream-obuf-tail stream) ,size)
219 ,(ecase (car buffering)
220 (:none
221 `(flush-output-buffer stream))
222 (:line
223 `(when (eq (char-code byte) (char-code #\Newline))
224 (flush-output-buffer stream)))
225 (:full
226 ))
227 (values))
228 (setf *output-routines*
229 (nconc *output-routines*
230 ',(mapcar
231 #'(lambda (type)
232 (list type
233 (car buffering)
234 function
235 size))
236 (cdr buffering)))))))
237 bufferings)))
238
239 (def-output-routines ("OUTPUT-CHAR-~A-BUFFERED"
240 1
241 (:none base-character)
242 (:line base-character)
243 (:full base-character))
244 (if (eq (char-code byte)
245 (char-code #\Newline))
246 (setf (fd-stream-char-pos stream) 0)
247 (incf (fd-stream-char-pos stream)))
248 (setf (sap-ref-8 (fd-stream-obuf-sap stream) (fd-stream-obuf-tail stream))
249 (char-code byte)))
250
251 (def-output-routines ("OUTPUT-BYTE-~A-BUFFERED"
252 1
253 (:none (signed-byte 8) (unsigned-byte 8))
254 (:full (signed-byte 8) (unsigned-byte 8)))
255 (when (characterp byte)
256 (if (eq (char-code byte)
257 (char-code #\Newline))
258 (setf (fd-stream-char-pos stream) 0)
259 (incf (fd-stream-char-pos stream))))
260 (setf (sap-ref-8 (fd-stream-obuf-sap stream) (fd-stream-obuf-tail stream))
261 byte))
262
263 (def-output-routines ("OUTPUT-SHORT-~A-BUFFERED"
264 2
265 (:none (signed-byte 16) (unsigned-byte 16))
266 (:full (signed-byte 16) (unsigned-byte 16)))
267 (setf (sap-ref-16 (fd-stream-obuf-sap stream)
268 (truncate (fd-stream-obuf-tail stream) 2))
269 byte))
270
271 (def-output-routines ("OUTPUT-LONG-~A-BUFFERED"
272 4
273 (:none (signed-byte 32) (unsigned-byte 32))
274 (:full (signed-byte 32) (unsigned-byte 32)))
275 (setf (sap-ref-32 (fd-stream-obuf-sap stream)
276 (truncate (fd-stream-obuf-tail stream) 4))
277 byte))
278
279 ;;; OUTPUT-RAW-BYTES -- public
280 ;;;
281 ;;; Does the actual output. If there is space to buffer the string, buffer
282 ;;; it. If the string would normally fit in the buffer, but doesn't because
283 ;;; of other stuff in the buffer, flush the old noise out of the buffer and
284 ;;; put the string in it. Otherwise we have a very long string, so just
285 ;;; send it directly (after flushing the buffer, of course).
286 ;;;
287 (defun output-raw-bytes (stream thing &optional start end)
288 "Output THING to stream. THING can be any kind of vector or a sap. If THING
289 is a SAP, END must be supplied (as length won't work)."
290 (let ((start (or start 0))
291 (end (or end (length thing))))
292 (declare (fixnum start end))
293 (let* ((len (fd-stream-obuf-length stream))
294 (tail (fd-stream-obuf-tail stream))
295 (space (- len tail))
296 (bytes (- end start))
297 (newtail (+ tail bytes)))
298 (cond ((minusp bytes) ; Error case
299 (cerror "Just go on as if nothing happened..."
300 "~S called with :END before :START!"
301 'output-raw-bytes))
302 ((zerop bytes)) ; Easy case
303 ((<= bytes space)
304 (if (system-area-pointer-p thing)
305 (system-area-copy thing
306 (* start vm:byte-bits)
307 (fd-stream-obuf-sap stream)
308 (* tail vm:byte-bits)
309 (* bytes vm:byte-bits))
310 (copy-to-system-area thing
311 (+ (* start vm:byte-bits)
312 (* vm:vector-data-offset vm:word-bits))
313 (fd-stream-obuf-sap stream)
314 (* tail vm:byte-bits)
315 (* bytes vm:byte-bits)))
316 (setf (fd-stream-obuf-tail stream) newtail))
317 ((<= bytes len)
318 (flush-output-buffer stream)
319 (if (system-area-pointer-p thing)
320 (system-area-copy thing
321 (* start vm:byte-bits)
322 (fd-stream-obuf-sap stream)
323 0
324 (* bytes vm:byte-bits))
325 (copy-to-system-area thing
326 (+ (* start vm:byte-bits)
327 (* vm:vector-data-offset vm:word-bits))
328 (fd-stream-obuf-sap stream)
329 0
330 (* bytes vm:byte-bits)))
331 (setf (fd-stream-obuf-tail stream) bytes))
332 (t
333 (flush-output-buffer stream)
334 (do-output stream thing start end nil))))))
335
336 ;;; FD-SOUT -- internal
337 ;;;
338 ;;; Routine to use to output a string. If the stream is unbuffered, slam
339 ;;; the string down the file descriptor, otherwise use OUTPUT-RAW-BYTES to
340 ;;; buffer the string. Update charpos by checking to see where the last newline
341 ;;; was.
342 ;;;
343 ;;; Note: some bozos (the FASL dumper) call write-string with things other
344 ;;; than strings. Therefore, we must make sure we have a string before calling
345 ;;; position on it.
346 ;;;
347 (defun fd-sout (stream thing start end)
348 (let ((start (or start 0))
349 (end (or end (length thing))))
350 (declare (fixnum start end))
351 (if (stringp thing)
352 (let ((last-newline (and (find #\newline (the simple-string thing)
353 :start start :end end)
354 (position #\newline (the simple-string thing)
355 :from-end t
356 :start start
357 :end end))))
358 (ecase (fd-stream-buffering stream)
359 (:full
360 (output-raw-bytes stream thing start end))
361 (:line
362 (output-raw-bytes stream thing start end)
363 (when last-newline
364 (flush-output-buffer stream)))
365 (:none
366 (do-output stream thing start end nil)))
367 (if last-newline
368 (setf (fd-stream-char-pos stream)
369 (- end last-newline 1))
370 (incf (fd-stream-char-pos stream)
371 (- end start))))
372 (ecase (fd-stream-buffering stream)
373 ((:line :full)
374 (output-raw-bytes stream thing start end))
375 (:none
376 (do-output stream thing start end nil))))))
377
378 ;;; PICK-OUTPUT-ROUTINE -- internal
379 ;;;
380 ;;; Find an output routine to use given the type and buffering. Return as
381 ;;; multiple values the routine, the real type transfered, and the number of
382 ;;; bytes per element.
383 ;;;
384 (defun pick-output-routine (type buffering)
385 (dolist (entry *output-routines*)
386 (when (and (subtypep type (car entry))
387 (eq buffering (cadr entry)))
388 (return (values (symbol-function (caddr entry))
389 (car entry)
390 (cadddr entry))))))
391
392
393 ;;;; Input routines and related noise.
394
395 (defvar *input-routines* ()
396 "List of all available input routines. Each element is a list of the
397 element-type input, the function name, and the number of bytes per element.")
398
399 ;;; DO-INPUT -- internal
400 ;;;
401 ;;; Fills the input buffer, and returns the first character. Throws to
402 ;;; eof-input-catcher if the eof was reached. Drops into system:server if
403 ;;; necessary.
404 ;;;
405 (defun do-input (stream)
406 (let ((fd (fd-stream-fd stream))
407 (ibuf-sap (fd-stream-ibuf-sap stream))
408 (buflen (fd-stream-ibuf-length stream))
409 (head (fd-stream-ibuf-head stream))
410 (tail (fd-stream-ibuf-tail stream)))
411 (unless (zerop head)
412 (cond ((eq head tail)
413 (setf head 0)
414 (setf tail 0)
415 (setf (fd-stream-ibuf-head stream) 0)
416 (setf (fd-stream-ibuf-tail stream) 0))
417 (t
418 (decf tail head)
419 (system-area-copy ibuf-sap (* head vm:byte-bits)
420 ibuf-sap 0 (* tail vm:byte-bits))
421 (setf head 0)
422 (setf (fd-stream-ibuf-head stream) 0)
423 (setf (fd-stream-ibuf-tail stream) tail))))
424 (setf (fd-stream-listen stream) nil)
425 #+serve-event
426 (multiple-value-bind
427 (count errno)
428 (mach:unix-select (1+ fd) (ash 1 fd) 0 0 0)
429 (case count
430 (1)
431 (0
432 (system:wait-until-fd-usable fd :input))
433 (t
434 (error "Problem checking to see if ~S is readable: ~A"
435 stream
436 (mach:get-unix-error-msg errno)))))
437 (multiple-value-bind
438 (count errno)
439 (mach:unix-read fd
440 (system:int-sap (+ (system:sap-int ibuf-sap) tail))
441 (- buflen tail))
442 (cond ((null count)
443 (if #+serve-event (eql errno mach:ewouldblock)
444 #-serve-event nil
445 (progn
446 (system:wait-until-fd-usable fd :input)
447 (do-input stream))
448 (error "Error reading ~S: ~A"
449 stream
450 (mach:get-unix-error-msg errno))))
451 ((zerop count)
452 (throw 'eof-input-catcher nil))
453 (t
454 (incf (fd-stream-ibuf-tail stream) count))))))
455
456 ;;; INPUT-AT-LEAST -- internal
457 ;;;
458 ;;; Makes sure there are at least ``bytes'' number of bytes in the input
459 ;;; buffer. Keeps calling do-input until that condition is met.
460 ;;;
461 (defmacro input-at-least (stream bytes)
462 (let ((stream-var (gensym))
463 (bytes-var (gensym)))
464 `(let ((,stream-var ,stream)
465 (,bytes-var ,bytes))
466 (loop
467 (when (>= (- (fd-stream-ibuf-tail ,stream-var)
468 (fd-stream-ibuf-head ,stream-var))
469 ,bytes-var)
470 (return))
471 (do-input ,stream-var)))))
472
473 ;;; INPUT-WRAPPER -- intenal
474 ;;;
475 ;;; Macro to wrap around all input routines to handle eof-error noise. This
476 ;;; should make provisions for filling stream-in-buffer.
477 ;;;
478 (defmacro input-wrapper ((stream bytes eof-error eof-value) &body read-forms)
479 (let ((stream-var (gensym))
480 (element-var (gensym)))
481 `(let ((,stream-var ,stream))
482 (if (fd-stream-unread ,stream)
483 (prog1
484 (fd-stream-unread ,stream)
485 (setf (fd-stream-unread ,stream) nil))
486 (let ((,element-var
487 (catch 'eof-input-catcher
488 (input-at-least ,stream-var ,bytes)
489 ,@read-forms)))
490 (cond (,element-var
491 (incf (fd-stream-ibuf-head ,stream-var) ,bytes)
492 ,element-var)
493 (,eof-error
494 (error "EOF while reading ~S" stream))
495 (t
496 ,eof-value)))))))
497
498 ;;; DEF-INPUT-ROUTINE -- internal
499 ;;;
500 ;;; Defines an input routine.
501 ;;;
502 (defmacro def-input-routine (name
503 (type size sap head)
504 &rest body)
505 `(progn
506 (defun ,name (stream eof-error eof-value)
507 (input-wrapper (stream ,size eof-error eof-value)
508 (let ((,sap (fd-stream-ibuf-sap stream))
509 (,head (fd-stream-ibuf-head stream)))
510 ,@body)))
511 (setf *input-routines*
512 (nconc *input-routines*
513 (list (list ',type ',name ',size))))))
514
515 ;;; INPUT-BASE-CHARACTER -- internal
516 ;;;
517 ;;; Routine to use in stream-in slot for reading string chars.
518 ;;;
519 (def-input-routine input-base-character
520 (base-character 1 sap head)
521 (code-char (sap-ref-8 sap head)))
522
523 ;;; INPUT-UNSIGNED-8BIT-BYTE -- internal
524 ;;;
525 ;;; Routine to read in an unsigned 8 bit number.
526 ;;;
527 (def-input-routine input-unsigned-8bit-byte
528 ((unsigned-byte 8) 1 sap head)
529 (sap-ref-8 sap head))
530
531 ;;; INPUT-SIGNED-8BIT-BYTE -- internal
532 ;;;
533 ;;; Routine to read in a signed 8 bit number.
534 ;;;
535 (def-input-routine input-signed-8bit-number
536 ((signed-byte 8) 1 sap head)
537 (signed-sap-ref-8 sap head))
538
539 ;;; INPUT-UNSIGNED-16BIT-BYTE -- internal
540 ;;;
541 ;;; Routine to read in an unsigned 16 bit number.
542 ;;;
543 (def-input-routine input-unsigned-16bit-byte
544 ((unsigned-byte 16) 2 sap head)
545 (sap-ref-16 sap (truncate head 2)))
546
547 ;;; INPUT-SIGNED-16BIT-BYTE -- internal
548 ;;;
549 ;;; Routine to read in a signed 16 bit number.
550 ;;;
551 (def-input-routine input-signed-16bit-byte
552 ((signed-byte 16) 2 sap head)
553 (signed-sap-ref-16 sap (truncate head 2)))
554
555 ;;; INPUT-UNSIGNED-32BIT-BYTE -- internal
556 ;;;
557 ;;; Routine to read in a unsigned 32 bit number.
558 ;;;
559 (def-input-routine input-unsigned-32bit-byte
560 ((unsigned-byte 32) 4 sap head)
561 (sap-ref-32 sap (truncate head 4)))
562
563 ;;; INPUT-SIGNED-32BIT-BYTE -- internal
564 ;;;
565 ;;; Routine to read in a signed 32 bit number.
566 ;;;
567 (def-input-routine input-signed-32bit-byte
568 ((signed-byte 32) 4 sap head)
569 (signed-sap-ref-32 sap (truncate head 2)))
570
571 ;;; PICK-INPUT-ROUTINE -- internal
572 ;;;
573 ;;; Find an input routine to use given the type. Return as multiple values
574 ;;; the routine, the real type transfered, and the number of bytes per element.
575 ;;;
576 (defun pick-input-routine (type)
577 (dolist (entry *input-routines*)
578 (when (subtypep type (car entry))
579 (return (values (symbol-function (cadr entry))
580 (car entry)
581 (caddr entry))))))
582
583 ;;; STRING-FROM-SAP -- internal
584 ;;;
585 ;;; Returns a string constructed from the sap, start, and end.
586 ;;;
587 (defun string-from-sap (sap start end)
588 (let* ((length (- end start))
589 (string (make-string length)))
590 (copy-from-system-area sap (* start vm:byte-bits)
591 string (* vm:vector-data-offset vm:word-bits)
592 (* length vm:byte-bits))
593 string))
594
595 ;;; FD-STREAM-READ-LINE -- internal
596 ;;;
597 ;;; Reads a line, returning a simple string. Note: this relies on the fact
598 ;;; that the input buffer does not change during do-input.
599 ;;;
600 (defun fd-stream-read-line (stream eof-error-p eof-value)
601 (let ((eof t))
602 (values
603 (or (let ((sap (fd-stream-ibuf-sap stream))
604 (results (if (fd-stream-unread stream)
605 (prog1
606 (list (string (fd-stream-unread stream)))
607 (setf (fd-stream-unread stream) nil)))))
608 (catch 'eof-input-catcher
609 (loop
610 (input-at-least stream 1)
611 (let* ((head (fd-stream-ibuf-head stream))
612 (tail (fd-stream-ibuf-tail stream))
613 (newline (do ((index head (1+ index)))
614 ((= index tail) nil)
615 (when (= (sap-ref-8 sap index)
616 (char-code #\newline))
617 (return index))))
618 (end (or newline tail)))
619 (push (string-from-sap sap head end)
620 results)
621 (when newline
622 (setf eof nil)
623 (setf (fd-stream-ibuf-head stream)
624 (1+ newline))
625 (return))
626 (setf (fd-stream-ibuf-head stream) end))))
627 (cond ((null results)
628 nil)
629 ((null (cdr results))
630 (car results))
631 (t
632 (apply #'concatenate 'simple-string (nreverse results)))))
633 (if eof-error-p
634 (error "EOF while reading ~S" stream)
635 eof-value))
636 eof)))
637
638
639 ;;; FD-STREAM-READ-N-BYTES -- internal
640 ;;;
641 ;;; The n-bin routine.
642 ;;;
643 (defun fd-stream-read-n-bytes (stream buffer start requested eof-error-p)
644 (let* ((sap (fd-stream-ibuf-sap stream))
645 (elsize (fd-stream-element-size stream))
646 (offset (* elsize start))
647 (bytes (* elsize requested))
648 (result
649 (catch 'eof-input-catcher
650 (loop
651 (input-at-least stream 1)
652 (let* ((head (fd-stream-ibuf-head stream))
653 (tail (fd-stream-ibuf-tail stream))
654 (available (- tail head))
655 (copy (min available bytes)))
656 (system-area-copy buffer (* offset vm:byte-bits)
657 sap (* head vm:byte-bits)
658 (* copy vm:byte-bits))
659 (incf (fd-stream-ibuf-head stream) copy)
660 (incf offset copy)
661 (decf bytes copy))
662 (when (zerop bytes)
663 (return requested))))))
664 (cond (result)
665 ((not eof-error-p)
666 (- requested (/ bytes elsize)))
667 (t
668 (error "Hit eof on ~S after reading ~D ~D~2:*-bit byte~P~*, ~
669 but ~D~2:* ~D-bit byte~P~:* ~[were~;was~:;were~] requested."
670 stream
671 (- requested (/ bytes elsize))
672 (* elsize 8)
673 requested)))))
674
675
676 ;;;; Utility functions (misc routines, etc)
677
678 ;;; SET-ROUTINES -- internal
679 ;;;
680 ;;; Fill in the various routine slots for the given type. Input-p and output-p
681 ;;; indicate what slots to fill. The buffering slot must be set prior to
682 ;;; calling this routine.
683 ;;;
684 (defun set-routines (stream type input-p output-p)
685 (let ((target-type (case type
686 ((:default unsigned-byte)
687 '(unsigned-byte 8))
688 (signed-byte
689 '(signed-byte 8))
690 (t
691 type)))
692 (input-type nil)
693 (output-type nil)
694 (input-size nil)
695 (output-size nil))
696
697 (when (fd-stream-obuf-sap stream)
698 (push (fd-stream-obuf-sap stream) *available-buffers*)
699 (setf (fd-stream-obuf-sap stream) nil))
700 (when (fd-stream-ibuf-sap stream)
701 (push (fd-stream-ibuf-sap stream) *available-buffers*)
702 (setf (fd-stream-ibuf-sap stream) nil))
703
704 (when input-p
705 (multiple-value-bind
706 (routine type size)
707 (pick-input-routine target-type)
708 (unless routine
709 (error "Could not find any input routine for ~S" target-type))
710 (setf (fd-stream-ibuf-sap stream) (next-available-buffer))
711 (setf (fd-stream-ibuf-length stream) bytes-per-buffer)
712 (setf (fd-stream-ibuf-tail stream) 0)
713 (if (subtypep type 'character)
714 (setf (fd-stream-in stream) routine
715 (fd-stream-bin stream) #'ill-bin
716 (fd-stream-n-bin stream) #'ill-bin)
717 (setf (fd-stream-in stream) #'ill-in
718 (fd-stream-bin stream) routine
719 (fd-stream-n-bin stream) #'fd-stream-read-n-bytes))
720 (setf input-size size)
721 (setf input-type type)))
722
723 (when output-p
724 (multiple-value-bind
725 (routine type size)
726 (pick-output-routine target-type (fd-stream-buffering stream))
727 (unless routine
728 (error "Could not find any output routine for ~S buffered ~S."
729 (fd-stream-buffering stream)
730 target-type))
731 (setf (fd-stream-obuf-sap stream) (next-available-buffer))
732 (setf (fd-stream-obuf-length stream) bytes-per-buffer)
733 (setf (fd-stream-obuf-tail stream) 0)
734 (if (subtypep type 'character)
735 (setf (fd-stream-out stream) routine
736 (fd-stream-bout stream) #'ill-bout)
737 (setf (fd-stream-out stream)
738 (or (if (eql size 1)
739 (pick-output-routine 'base-character
740 (fd-stream-buffering stream)))
741 #'ill-out)
742 (fd-stream-bout stream) routine))
743 (setf (fd-stream-sout stream)
744 (if (eql size 1) #'fd-sout #'ill-out))
745 (setf (fd-stream-char-pos stream) 0)
746 (setf output-size size)
747 (setf output-type type)))
748
749 (when (and input-size output-size
750 (not (eq input-size output-size)))
751 (error "Element sizes for input (~S:~S) and output (~S:~S) differ?"
752 input-type input-size
753 output-type output-size))
754 (setf (fd-stream-element-size stream)
755 (or input-size output-size))
756
757 (setf (fd-stream-element-type stream)
758 (cond ((equal input-type output-type)
759 input-type)
760 ((subtypep input-type output-type)
761 input-type)
762 ((subtypep output-type input-type)
763 output-type)
764 (t
765 (error "Input type (~S) and output type (~S) are unrelated?"
766 input-type
767 output-type))))))
768
769 ;;; FD-STREAM-MISC-ROUTINE -- input
770 ;;;
771 ;;; Handle the various misc operations on fd-stream.
772 ;;;
773 (defun fd-stream-misc-routine (stream operation &optional arg1 arg2)
774 (case operation
775 (:read-line
776 (fd-stream-read-line stream arg1 arg2))
777 (:listen
778 (or (not (eql (fd-stream-ibuf-head stream)
779 (fd-stream-ibuf-tail stream)))
780 (fd-stream-listen stream)
781 (setf (fd-stream-listen stream)
782 (not (zerop (mach:unix-select (1+ (fd-stream-fd stream))
783 (ash 1 (fd-stream-fd stream))
784 0
785 0
786 0))))))
787 (:unread
788 (setf (fd-stream-unread stream) arg1))
789 (:close
790 (cond (arg1
791 ;; We got us an abort on our hands.
792 (when (and (fd-stream-file stream)
793 (fd-stream-obuf-sap stream))
794 ;; Can't do anything unless we know what file were dealing with,
795 ;; and we don't want to do anything strange unless we were
796 ;; writing to the file.
797 (if (fd-stream-original stream)
798 ;; Have an handle on the original, just revert.
799 (multiple-value-bind
800 (okay err)
801 (mach:unix-rename (fd-stream-original stream)
802 (fd-stream-file stream))
803 (unless okay
804 (cerror "Go on as if nothing bad happened."
805 "Could not restore ~S to it's original contents: ~A"
806 (fd-stream-file stream)
807 (mach:get-unix-error-msg err))))
808 ;; Can't restore the orignal, so nuke that puppy.
809 (multiple-value-bind
810 (okay err)
811 (mach:unix-unlink (fd-stream-file stream))
812 (unless okay
813 (cerror "Go on as if nothing bad happened."
814 "Could not remove ~S: ~A"
815 (fd-stream-file stream)
816 (mach:get-unix-error-msg err)))))))
817 (t
818 (fd-stream-misc-routine stream :finish-output)
819 (when (and (fd-stream-original stream)
820 (fd-stream-delete-original stream))
821 (multiple-value-bind
822 (okay err)
823 (mach:unix-unlink (fd-stream-original stream))
824 (unless okay
825 (cerror "Go on as if nothing bad happened."
826 "Could not delete ~S during close of ~S: ~A"
827 (fd-stream-original stream)
828 stream
829 (mach:get-unix-error-msg err)))))))
830 (mach:unix-close (fd-stream-fd stream))
831 (when (fd-stream-obuf-sap stream)
832 (push (fd-stream-obuf-sap stream) *available-buffers*)
833 (setf (fd-stream-obuf-sap stream) nil))
834 (when (fd-stream-ibuf-sap stream)
835 (push (fd-stream-ibuf-sap stream) *available-buffers*)
836 (setf (fd-stream-ibuf-sap stream) nil))
837 (lisp::set-closed-flame stream))
838 (:clear-input)
839 (:force-output
840 (flush-output-buffer stream))
841 (:finish-output
842 (flush-output-buffer stream)
843 #+serve-event
844 (do ()
845 ((null (fd-stream-output-later stream)))
846 (system:serve-all-events)))
847 (:element-type
848 (fd-stream-element-type stream))
849 (:line-length
850 80)
851 (:charpos
852 (fd-stream-char-pos stream))
853 (:file-length
854 (multiple-value-bind
855 (okay dev ino mode nlink uid gid rdev size
856 atime mtime ctime blksize blocks)
857 (mach:unix-fstat (fd-stream-fd stream))
858 (declare (ignore ino nlink uid gid rdev
859 atime mtime ctime blksize blocks))
860 (unless okay
861 (error "Error fstating ~S: ~A"
862 stream
863 (mach:get-unix-error-msg dev)))
864 (if (zerop mode)
865 nil
866 (/ size (fd-stream-element-size stream)))))
867 (:file-position
868 (fd-stream-file-position stream arg1))
869 (:file-name
870 (fd-stream-file stream))))
871
872 ;;; FD-STREAM-FILE-POSITION -- internal.
873 ;;;
874 (defun fd-stream-file-position (stream &optional newpos)
875 (if (null newpos)
876 (system:without-interrupts
877 ;; First, find the position of the UNIX file descriptor in the
878 ;; file.
879 (multiple-value-bind
880 (posn errno)
881 (mach:unix-lseek (fd-stream-fd stream) 0 mach:l_incr)
882 (cond ((numberp posn)
883 ;; Adjust for buffered output:
884 ;; If there is any output buffered, the *real* file position
885 ;; will be larger than reported by lseek because lseek
886 ;; obviously cannot take into account output we have not
887 ;; sent yet.
888 (dolist (later (fd-stream-output-later stream))
889 (incf posn (- (caddr later) (cadr later))))
890 (incf posn (fd-stream-obuf-tail stream))
891 ;; Adjust for unread input:
892 ;; If there is any input read from UNIX but not supplied to
893 ;; the user of the stream, the *real* file position will
894 ;; smaller than reported, because we want to look like the
895 ;; unread stuff is still available.
896 (decf posn (- (fd-stream-ibuf-tail stream)
897 (fd-stream-ibuf-head stream)))
898 (when (fd-stream-unread stream)
899 (decf posn))
900 ;; Divide bytes by element size.
901 (/ posn (fd-stream-element-size stream)))
902 ((eq errno mach:espipe)
903 nil)
904 (t
905 (system:with-interrupts
906 (error "Error lseek'ing ~S: ~A"
907 stream
908 (mach:get-unix-error-msg errno)))))))
909 (let (offset origin)
910 ;; Make sure we don't have any output pending, because if we move the
911 ;; file pointer before writing this stuff, it will be written in the
912 ;; wrong location.
913 (flush-output-buffer stream)
914 (do ()
915 ((null (fd-stream-output-later stream)))
916 (system:serve-all-events))
917 (cond ((eq newpos :start)
918 (setf offset 0 origin mach:l_set))
919 ((eq newpos :end)
920 (setf offset 0 origin mach:l_xtnd))
921 ((numberp newpos)
922 (setf offset (* newpos (fd-stream-element-size stream))
923 origin mach:l_set))
924 (t
925 (error "Invalid position given to file-position: ~S" newpos)))
926 (multiple-value-bind
927 (posn errno)
928 (mach:unix-lseek (fd-stream-fd stream) offset origin)
929 (cond ((numberp posn)
930 t)
931 ((eq errno mach:espipe)
932 nil)
933 (t
934 (error "Error lseek'ing ~S: ~A"
935 stream
936 (mach:get-unix-error-msg errno))))))))
937
938
939
940 ;;;; Creation routines (MAKE-FD-STREAM and OPEN)
941
942 ;;; MAKE-FD-STREAM -- Public.
943 ;;;
944 ;;; Returns a FD-STREAM on the given file.
945 ;;;
946 (defun make-fd-stream (fd
947 &key
948 (input nil input-p)
949 (output nil output-p)
950 (element-type 'base-character)
951 (buffering :full)
952 file
953 original
954 delete-original
955 (name (if file
956 (format nil "file ~S" file)
957 (format nil "descriptor ~D" fd))))
958 "Create a stream for the given unix file descriptor. If input is non-nil,
959 allow input operations. If output is non-nil, allow output operations. If
960 neither input nor output are specified, default to allowing input.
961 element-type indicates the element type to use (as for open). Buffering
962 indicates the kind of buffering to use (one of :none, :line, or :full). If
963 file is spesified, it should be the name of the file. Name is used to
964 identify the stream when printed."
965 (cond ((not (or input-p output-p))
966 (setf input t))
967 ((not (or input output))
968 (error "File descriptor must be opened either for input or output.")))
969 (let ((stream (%make-fd-stream :fd fd
970 :name name
971 :file file
972 :original original
973 :delete-original delete-original
974 :buffering buffering)))
975 (set-routines stream element-type input output)
976 stream))
977
978 ;;; PICK-PACKUP-NAME -- internal
979 ;;;
980 ;;; Pick a name to use for the backup file.
981 ;;;
982 (defvar *backup-extension* ".BAK"
983 "This is a string that OPEN tacks on the end of a file namestring to produce
984 a name for the :if-exists :rename-and-delete and :rename options. Also,
985 this can be a function that takes a namestring and returns a complete
986 namestring.")
987 ;;;
988 (defun pick-backup-name (name)
989 (etypecase *backup-extension*
990 (string (concatenate 'simple-string name *backup-extension*))
991 (function (funcall *backup-extension* name))))
992
993 ;;; ASSURE-ONE-OF -- internal
994 ;;;
995 ;;; Assure that the given arg is one of the given list of valid things.
996 ;;; Allow the user to fix any problems.
997 ;;;
998 (defun assure-one-of (item list what)
999 (unless (member item list)
1000 (loop
1001 (cerror "Enter new value for ~*~S"
1002 "~S is invalid for ~S. Must be one of~{ ~S~}"
1003 item
1004 what
1005 list)
1006 (format *query-io* "Enter new value for ~S: " what)
1007 (force-output *query-io*)
1008 (setf item (read *query-io*))
1009 (when (member item list)
1010 (return))))
1011 item)
1012
1013 ;;; OPEN -- public
1014 ;;;
1015 ;;; Open the given file.
1016 ;;;
1017 (defun open (filename
1018 &key
1019 (direction :input)
1020 (element-type 'base-character)
1021 (if-exists nil if-exists-given)
1022 (if-does-not-exist nil if-does-not-exist-given))
1023 "Return a stream which reads from or writes to Filename.
1024 Defined keywords:
1025 :direction - one of :input, :output, :io, or :probe
1026 :element-type - Type of object to read or write, default BASE-CHARACTER
1027 :if-exists - one of :error, :new-version, :rename, :rename-and-delete,
1028 :overwrite, :append, :supersede or nil
1029 :if-does-not-exist - one of :error, :create or nil
1030 See the manual for details."
1031 ;; First, make sure that DIRECTION is valid. Allow it to be changed if not.
1032 (setf direction
1033 (assure-one-of direction
1034 '(:input :output :io :probe)
1035 :direction))
1036
1037 ;; Calculate useful stuff.
1038 (multiple-value-bind
1039 (input output mask)
1040 (case direction
1041 (:input (values t nil mach:o_rdonly))
1042 (:output (values nil t mach:o_wronly))
1043 (:io (values t t mach:o_rdwr))
1044 (:probe (values nil nil mach:o_rdonly)))
1045 (let* ((pathname (pathname filename))
1046 (namestring (predict-name pathname input)))
1047
1048 ;; Process if-exists argument if we are doing any output.
1049 (cond (output
1050 (unless if-exists-given
1051 (setf if-exists
1052 (if (eq (pathname-version pathname) :newest)
1053 :new-version
1054 :error)))
1055 (setf if-exists
1056 (assure-one-of if-exists
1057 '(:error :new-version :rename
1058 :rename-and-delete :overwrite
1059 :append :supersede nil)
1060 :if-exists))
1061 (case if-exists
1062 ((:error nil)
1063 (setf mask (logior mask mach:o_excl)))
1064 ((:rename :rename-and-delete)
1065 (setf mask (logior mask mach:o_creat)))
1066 ((:new-version :supersede)
1067 (setf mask (logior mask mach:o_trunc)))
1068 (:append
1069 (setf mask (logior mask mach:o_append)))))
1070 (t
1071 (setf if-exists :ignore-this-arg)))
1072
1073 (unless if-does-not-exist-given
1074 (setf if-does-not-exist
1075 (cond ((eq direction :input) :error)
1076 ((and output
1077 (member if-exists '(:overwrite :append)))
1078 :error)
1079 ((eq direction :probe)
1080 nil)
1081 (t
1082 :create))))
1083 (setf if-does-not-exist
1084 (assure-one-of if-does-not-exist
1085 '(:error :create nil)
1086 :if-does-not-exist))
1087 (if (eq if-does-not-exist :create)
1088 (setf mask (logior mask mach:o_creat)))
1089
1090 (let ((original (if (member if-exists
1091 '(:rename :rename-and-delete))
1092 (pick-backup-name namestring)))
1093 (delete-original (eq if-exists :rename-and-delete))
1094 (mode #o666))
1095 (when original
1096 ;; We are doing a :rename or :rename-and-delete.
1097 ;; Determine if the file already exists, make sure the original
1098 ;; file is not a directory and keep the mode
1099 (let ((exists
1100 (multiple-value-bind
1101 (okay err/dev inode orig-mode)
1102 (mach:unix-stat namestring)
1103 (declare (ignore inode))
1104 (cond (okay
1105 (when (and output (= (logand orig-mode #o170000)
1106 #o40000))
1107 (error "Cannot open ~S for output: Is a directory."
1108 namestring))
1109 (setf mode (logand orig-mode #o777))
1110 t)
1111 ((eql err/dev mach:enoent)
1112 nil)
1113 (t
1114 (error "Cannot find ~S: ~A"
1115 namestring
1116 (mach:get-unix-error-msg err/dev)))))))
1117 (when (or (not exists)
1118 ;; Do the rename.
1119 (multiple-value-bind
1120 (okay err)
1121 (mach:unix-rename namestring original)
1122 (unless okay
1123 (cerror "Use :SUPERSEDE instead."
1124 "Could not rename ~S to ~S: ~A."
1125 namestring
1126 original
1127 (mach:get-unix-error-msg err))
1128 t)))
1129 (setf original nil)
1130 (setf delete-original nil)
1131 ;; In order to use SUPERSEDE instead, we have
1132 ;; to make sure mach:o_creat corresponds to
1133 ;; if-does-not-exist. mach:o_creat was set
1134 ;; before because of if-exists being :rename.
1135 (unless (eq if-does-not-exist :create)
1136 (setf mask (logior (logandc2 mask mach:o_creat) mach:o_trunc)))
1137 (setf if-exists :supersede))))
1138
1139 ;; Okay, now we can try the actual open.
1140 (multiple-value-bind
1141 (fd errno)
1142 (mach:unix-open namestring mask mode)
1143 (cond ((numberp fd)
1144 (case direction
1145 ((:input :output :io)
1146 (make-fd-stream fd
1147 :input input
1148 :output output
1149 :element-type element-type
1150 :file namestring
1151 :original original
1152 :delete-original delete-original))
1153 (:probe
1154 (let ((stream (%make-fd-stream :name namestring
1155 :fd fd
1156 :element-type element-type)))
1157 (close stream)
1158 stream))))
1159 ((eql errno mach:enoent)
1160 (case if-does-not-exist
1161 (:error
1162 (cerror "Return NIL."
1163 "Error opening ~S, ~A."
1164 pathname
1165 (mach:get-unix-error-msg errno)))
1166 (:create
1167 (cerror "Return NIL."
1168 "Error creating ~S, path does not exist."
1169 pathname)))
1170 nil)
1171 ((eql errno mach:eexist)
1172 (unless (eq nil if-exists)
1173 (cerror "Return NIL."
1174 "Error opening ~S, ~A."
1175 pathname
1176 (mach:get-unix-error-msg errno)))
1177 nil)
1178 (t
1179 (cerror "Return NIL."
1180 "Error opening ~S, ~A."
1181 pathname
1182 (mach:get-unix-error-msg errno))
1183 nil)))))))
1184
1185 ;;;; Initialization.
1186
1187 (defvar *tty* nil
1188 "The stream connected to the controlling terminal or NIL if there is none.")
1189 (defvar *stdin* nil
1190 "The stream connected to the standard input (file descriptor 0).")
1191 (defvar *stdout* nil
1192 "The stream connected to the standard output (file descriptor 1).")
1193 (defvar *stderr* nil
1194 "The stream connected to the standard error output (file descriptor 2).")
1195
1196 ;;; STREAM-INIT -- internal interface
1197 ;;;
1198 ;;; Called when the cold load is first started up.
1199 ;;;
1200 (defun stream-init ()
1201 (stream-reinit)
1202 (setf *terminal-io* (make-synonym-stream '*tty*))
1203 (setf *standard-input* (make-synonym-stream '*stdin*))
1204 (setf *standard-output* (make-synonym-stream '*stdout*))
1205 (setf *error-output* (make-synonym-stream '*stderr*))
1206 (setf *query-io* (make-synonym-stream '*terminal-io*))
1207 (setf *debug-io* *query-io*)
1208 (setf *trace-output* *standard-output*)
1209 nil)
1210
1211 ;;; STREAM-REINIT -- internal interface
1212 ;;;
1213 ;;; Called whenever a saved core is restarted.
1214 ;;;
1215 (defun stream-reinit ()
1216 (setf *available-buffers* nil)
1217 (setf *stdin*
1218 (make-fd-stream 0 :name "Standard Input" :input t :buffering :line))
1219 (setf *stdout*
1220 (make-fd-stream 1 :name "Standard Output" :output t :buffering :line))
1221 (setf *stderr*
1222 (make-fd-stream 2 :name "Standard Error" :output t :buffering :line))
1223 (let ((tty (mach:unix-open "/dev/tty" mach:o_rdwr #o666)))
1224 (if tty
1225 (setf *tty*
1226 (make-fd-stream tty :name "the Terminal" :input t :output t
1227 :buffering :line))
1228 (setf *tty* (make-two-way-stream *stdin* *stdout*))))
1229 nil)
1230
1231
1232 ;;;; Beeping.
1233
1234 (defun default-beep-function (stream)
1235 (write-char #\bell stream)
1236 (finish-output stream))
1237
1238 (defvar *beep-function* #'default-beep-function
1239 "This is called in BEEP to feep the user. It takes a stream.")
1240
1241 (defun beep (&optional (stream *terminal-io*))
1242 (funcall *beep-function* stream))
1243
1244
1245 ;;;; File position and file length.
1246
1247 ;;; File-Position -- Public
1248 ;;;
1249 ;;; Call the misc method with the :file-position operation.
1250 ;;;
1251 (defun file-position (stream &optional position)
1252 "With one argument returns the current position within the file
1253 File-Stream is open to. If the second argument is supplied, then
1254 this becomes the new file position. The second argument may also
1255 be :start or :end for the start and end of the file, respectively."
1256 (unless (streamp stream)
1257 (error "Argument ~S is not a stream." stream))
1258 (funcall (stream-misc stream) stream :file-position position))
1259
1260 ;;; File-Length -- Public
1261 ;;;
1262 ;;; Like File-Position, only use :file-length.
1263 ;;;
1264 (defun file-length (stream)
1265 "This function returns the length of the file that File-Stream is open to."
1266 (unless (streamp stream)
1267 (error "Argument ~S is not a stream." stream))
1268 (funcall (stream-misc stream) stream :file-length))
1269
1270 ;;; File-Name -- internal interface
1271 ;;;
1272 ;;; Kind of like File-Position, but is an internal hack used by the filesys
1273 ;;; stuff to get and set the file name.
1274 ;;;
1275 (defun file-name (stream &optional new-name)
1276 (when (fd-stream-p stream)
1277 (if new-name
1278 (setf (fd-stream-file stream) new-name)
1279 (fd-stream-file stream))))

  ViewVC Help
Powered by ViewVC 1.1.5