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

  ViewVC Help
Powered by ViewVC 1.1.5