1 ;;; -*- Log: code.log; Package: LISP -*-
3 ;;; **********************************************************************
4 ;;; 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.
8 "$Header: /home/david/closure-cvs/cvsroot/closure/src/lisp-dep/cmucl/Attic/fd-stream.lisp,v 1.1.1.1 2002-07-22 02:27:20 gilbert Exp $")
10 ;;; **********************************************************************
12 ;;; Streams for UNIX file descriptors.
14 ;;; Written by William Lott, July 1989 - January 1990.
15 ;;; Some tuning by Rob MacLachlan.
17 ;;; **********************************************************************
22 (export '(fd-stream fd-stream-p fd-stream-fd make-fd-stream
23 io-timeout beep
*beep-function
* output-raw-bytes
24 *tty
* *stdin
* *stdout
* *stderr
*))
27 (in-package "EXTENSIONS")
29 (export '(*backup-extension
*))
34 (export '(file-stream file-string-length stream-external-format
))
35 (deftype file-stream
() 'fd-stream
)
38 ;;;; Buffer manipulation routines.
40 (defvar *available-buffers
* ()
41 "List of available buffers. Each buffer is an sap pointing to
42 bytes-per-buffer of memory.")
44 (defconstant bytes-per-buffer
(* 4 1024)
45 "Number of bytes per buffer.")
47 ;;; NEXT-AVAILABLE-BUFFER -- Internal.
49 ;;; Returns the next available buffer, creating one if necessary.
51 (declaim (inline next-available-buffer
))
53 (defun next-available-buffer ()
54 (let ((res (mp:without-scheduling
(pop *available-buffers
*))))
56 (allocate-system-memory bytes-per-buffer
))))
58 (declaim (inline put-buffer-back
))
59 (defun put-buffer-back (buffer)
60 (let ((c (cons buffer nil
)))
61 (mp:without-scheduling
62 (setf (cdr c
) *available-buffers
*
63 *available-buffers
* c
))))
66 ;;;; The FD-STREAM structure.
69 (:print-function %print-fd-stream
)
70 (:constructor %make-fd-stream
)
72 (misc #'fd-stream-misc-routine
)))
74 (name nil
) ; The name of this stream
75 (file nil
) ; The file this stream is for
77 ;; The backup file namestring for the old file, for :if-exists :rename or
78 ;; :rename-and-delete.
79 (original nil
:type
(or simple-string null
))
80 (delete-original nil
) ; for :if-exists :rename-and-delete
82 ;;; Number of bytes per element.
83 (element-size 1 :type index
)
84 (element-type 'base-char
) ; The type of element being transfered.
85 (fd -
1 :type fixnum
) ; The file descriptor
87 ;; Controls when the output buffer is flushed.
88 (buffering :full
:type
(member :full
:line
:none
))
90 ;; Character position if known.
91 (char-pos nil
:type
(or index null
))
93 ;; T if input is waiting on FD. :EOF if we hit EOF.
94 (listen nil
:type
(member nil t
:eof
))
98 (ibuf-sap nil
:type
(or system-area-pointer null
))
99 (ibuf-length nil
:type
(or index null
))
100 (ibuf-head 0 :type index
)
101 (ibuf-tail 0 :type index
)
103 ;; The output buffer.
104 (obuf-sap nil
:type
(or system-area-pointer null
))
105 (obuf-length nil
:type
(or index null
))
106 (obuf-tail 0 :type index
)
108 ;; Output flushed, but not written due to non-blocking io.
112 ;; Timeout specified for this stream, or NIL if none.
113 (timeout nil
:type
(or index null
))
115 ;; Pathname of the file this stream is opened to (returned by PATHNAME.)
116 (pathname nil
:type
(or pathname null
)))
118 (defun %print-fd-stream
(fd-stream stream depth
)
119 (declare (ignore depth
) (stream stream
))
120 (format stream
"#<Stream for ~A>"
121 (fd-stream-name fd-stream
)))
124 (define-condition io-timeout
(stream-error)
125 ((direction :reader io-timeout-direction
:initarg
:direction
))
127 (lambda (condition stream
)
128 (declare (stream stream
))
129 (format stream
"Timeout ~(~A~)ing ~S."
130 (io-timeout-direction condition
)
131 (stream-error-stream condition
)))))
133 (define-condition io-error
(stream-error)
134 ((direction :reader io-error-direction
:initarg
:direction
)
135 (message :reader io-error-message
:initarg
:message
))
137 (lambda (condition stream
)
138 (declare (stream stream
))
139 (format stream
"I/O Error while ~(~A~)ing ~S: ~A."
140 (io-error-direction condition
)
141 (stream-error-stream condition
)
142 (io-error-message condition
)))))
144 ;;;; Output routines and related noise.
146 (defvar *output-routines
* ()
147 "List of all available output routines. Each element is a list of the
148 element-type output, the kind of buffering, the function name, and the number
149 of bytes per element.")
151 ;;; DO-OUTPUT -- internal
153 ;;; Output the given noise.
155 ;;; This used to queue stuff via serve-event, I changed it to always
156 ;;; block until everything written (or I/O timeout). --GB
158 (defun do-output (stream base start end reuse-sap
)
159 (declare (type fd-stream stream
)
160 (type (or system-area-pointer
(simple-array * (*))) base
)
161 (type index start end
))
162 (let ((length (- end start
))
163 (fd (fd-stream-fd stream
)))
166 (unix:unix-write fd base start length
)
168 (cond ((eql errno unix
:ewouldblock
)
169 ;; OS said WOULDBLOCK, so arrange to wait
170 ;; until we can do the output, and try again.
171 (unless #-mp
(system:wait-until-fd-usable
172 fd
:output
(fd-stream-timeout stream
))
173 #+mp
(mp:process-wait-until-fd-usable
174 fd
:output
(fd-stream-timeout stream
))
175 (error 'io-timeout
:stream stream
:direction
:write
))
176 (do-output stream base start end reuse-sap
))
181 :message
(unix:get-unix-error-msg errno
)))))
183 ((not (eql count length
))
184 ;; not fully written, try to write the rest
185 (do-output stream base
(the index
(+ start count
)) end reuse-sap
))))))
188 ;;; FLUSH-OUTPUT-BUFFER -- internal
190 ;;; Flush any data in the output buffer.
192 (defun flush-output-buffer (stream)
193 (let ((length (fd-stream-obuf-tail stream
)))
195 (do-output stream
(fd-stream-obuf-sap stream
) 0 length t
)
196 (setf (fd-stream-obuf-tail stream
) 0))))
198 ;;; DEF-OUTPUT-ROUTINES -- internal
200 ;;; Define output routines that output numbers size bytes long for the
201 ;;; given bufferings. Use body to do the actual output.
203 (defmacro def-output-routines
((name size
&rest bufferings
) &body body
)
204 (declare (optimize (speed 1)))
207 #'(lambda (buffering)
209 (intern (let ((*print-case
* :upcase
))
210 (format nil name
(car buffering
))))))
212 (defun ,function
(stream byte
)
213 ,(unless (eq (car buffering
) :none
)
214 `(when (< (fd-stream-obuf-length stream
)
215 (+ (fd-stream-obuf-tail stream
)
217 (flush-output-buffer stream
)))
219 (incf (fd-stream-obuf-tail stream
) ,size
)
220 ,(ecase (car buffering
)
222 `(flush-output-buffer stream
))
224 `(when (eq (char-code byte
) (char-code #\Newline
))
225 (flush-output-buffer stream
)))
229 (setf *output-routines
*
230 (nconc *output-routines
*
237 (cdr buffering
)))))))
240 (def-output-routines ("OUTPUT-CHAR-~A-BUFFERED"
245 (if (char= byte
#\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
))
251 (def-output-routines ("OUTPUT-UNSIGNED-BYTE-~A-BUFFERED"
253 (:none
(unsigned-byte 8))
254 (:full
(unsigned-byte 8)))
255 (setf (sap-ref-8 (fd-stream-obuf-sap stream
) (fd-stream-obuf-tail stream
))
258 (def-output-routines ("OUTPUT-SIGNED-BYTE-~A-BUFFERED"
260 (:none
(signed-byte 8))
261 (:full
(signed-byte 8)))
262 (setf (signed-sap-ref-8 (fd-stream-obuf-sap stream
)
263 (fd-stream-obuf-tail stream
))
266 (def-output-routines ("OUTPUT-UNSIGNED-SHORT-~A-BUFFERED"
268 (:none
(unsigned-byte 16))
269 (:full
(unsigned-byte 16)))
270 (setf (sap-ref-16 (fd-stream-obuf-sap stream
) (fd-stream-obuf-tail stream
))
273 (def-output-routines ("OUTPUT-SIGNED-SHORT-~A-BUFFERED"
275 (:none
(signed-byte 16))
276 (:full
(signed-byte 16)))
277 (setf (signed-sap-ref-16 (fd-stream-obuf-sap stream
)
278 (fd-stream-obuf-tail stream
))
281 (def-output-routines ("OUTPUT-UNSIGNED-LONG-~A-BUFFERED"
283 (:none
(unsigned-byte 32))
284 (:full
(unsigned-byte 32)))
285 (setf (sap-ref-32 (fd-stream-obuf-sap stream
) (fd-stream-obuf-tail stream
))
288 (def-output-routines ("OUTPUT-SIGNED-LONG-~A-BUFFERED"
290 (:none
(signed-byte 32))
291 (:full
(signed-byte 32)))
292 (setf (signed-sap-ref-32 (fd-stream-obuf-sap stream
)
293 (fd-stream-obuf-tail stream
))
297 ;;; OUTPUT-RAW-BYTES -- public
299 ;;; Does the actual output. If there is space to buffer the string, buffer
300 ;;; it. If the string would normally fit in the buffer, but doesn't because
301 ;;; of other stuff in the buffer, flush the old noise out of the buffer and
302 ;;; put the string in it. Otherwise we have a very long string, so just
303 ;;; send it directly (after flushing the buffer, of course).
305 (defun output-raw-bytes (stream thing
&optional start end
)
306 "Output THING to stream. THING can be any kind of vector or a sap. If THING
307 is a SAP, END must be supplied (as length won't work)."
308 (let ((start (or start
0))
309 (end (or end
(length (the (simple-array * (*)) thing
)))))
310 (declare (type index start end
))
311 (let* ((len (fd-stream-obuf-length stream
))
312 (tail (fd-stream-obuf-tail stream
))
314 (bytes (- end start
))
315 (newtail (+ tail bytes
)))
316 (cond ((minusp bytes
) ; Error case
317 (cerror "Just go on as if nothing happened..."
318 "~S called with :END before :START!"
320 ((zerop bytes
)) ; Easy case
322 (if (system-area-pointer-p thing
)
323 (system-area-copy thing
324 (* start vm
:byte-bits
)
325 (fd-stream-obuf-sap stream
)
326 (* tail vm
:byte-bits
)
327 (* bytes vm
:byte-bits
))
328 (copy-to-system-area thing
329 (+ (* start vm
:byte-bits
)
330 (* vm
:vector-data-offset vm
:word-bits
))
331 (fd-stream-obuf-sap stream
)
332 (* tail vm
:byte-bits
)
333 (* bytes vm
:byte-bits
)))
334 (setf (fd-stream-obuf-tail stream
) newtail
))
336 (flush-output-buffer stream
)
337 (if (system-area-pointer-p thing
)
338 (system-area-copy thing
339 (* start vm
:byte-bits
)
340 (fd-stream-obuf-sap stream
)
342 (* bytes vm
:byte-bits
))
343 (copy-to-system-area thing
344 (+ (* start vm
:byte-bits
)
345 (* vm
:vector-data-offset vm
:word-bits
))
346 (fd-stream-obuf-sap stream
)
348 (* bytes vm
:byte-bits
)))
349 (setf (fd-stream-obuf-tail stream
) bytes
))
351 (flush-output-buffer stream
)
352 (do-output stream thing start end nil
))))))
354 ;;; FD-SOUT -- internal
356 ;;; Routine to use to output a string. If the stream is unbuffered, slam
357 ;;; the string down the file descriptor, otherwise use OUTPUT-RAW-BYTES to
358 ;;; buffer the string. Update charpos by checking to see where the last newline
361 ;;; Note: some bozos (the FASL dumper) call write-string with things other
362 ;;; than strings. Therefore, we must make sure we have a string before calling
365 (defun fd-sout (stream thing start end
)
366 (let ((start (or start
0))
367 (end (or end
(length (the vector thing
)))))
368 (declare (type index start end
))
370 (let ((last-newline (and (find #\newline
(the simple-string thing
)
371 :start start
:end end
)
372 (position #\newline
(the simple-string thing
)
376 (ecase (fd-stream-buffering stream
)
378 (output-raw-bytes stream thing start end
))
380 (output-raw-bytes stream thing start end
)
382 (flush-output-buffer stream
)))
384 (do-output stream thing start end nil
)))
386 (setf (fd-stream-char-pos stream
)
387 (- end last-newline
1))
388 (incf (fd-stream-char-pos stream
)
390 (ecase (fd-stream-buffering stream
)
392 (output-raw-bytes stream thing start end
))
394 (do-output stream thing start end nil
))))))
396 ;;; PICK-OUTPUT-ROUTINE -- internal
398 ;;; Find an output routine to use given the type and buffering. Return as
399 ;;; multiple values the routine, the real type transfered, and the number of
400 ;;; bytes per element.
402 (defun pick-output-routine (type buffering
)
403 (dolist (entry *output-routines
*)
404 (when (and (subtypep type
(car entry
))
405 (eq buffering
(cadr entry
)))
406 (return (values (symbol-function (caddr entry
))
411 ;;;; Input routines and related noise.
413 (defvar *input-routines
* ()
414 "List of all available input routines. Each element is a list of the
415 element-type input, the function name, and the number of bytes per element.")
417 ;;; DO-INPUT -- internal
419 ;;; Fills the input buffer, and returns the first character. Throws to
420 ;;; eof-input-catcher if the eof was reached. Drops into system:server if
423 (defun do-input (stream)
424 (let ((fd (fd-stream-fd stream
))
425 (ibuf-sap (fd-stream-ibuf-sap stream
))
426 (buflen (fd-stream-ibuf-length stream
))
427 (head (fd-stream-ibuf-head stream
))
428 (tail (fd-stream-ibuf-tail stream
)))
429 (declare (type index head tail
))
431 (cond ((eql head tail
)
434 (setf (fd-stream-ibuf-head stream
) 0)
435 (setf (fd-stream-ibuf-tail stream
) 0))
438 (system-area-copy ibuf-sap
(* head vm
:byte-bits
)
439 ibuf-sap
0 (* tail vm
:byte-bits
))
441 (setf (fd-stream-ibuf-head stream
) 0)
442 (setf (fd-stream-ibuf-tail stream
) tail
))))
443 (setf (fd-stream-listen stream
) nil
)
446 (alien:with-alien
((read-fds (alien:struct unix
:fd-set
)))
447 (unix:fd-zero read-fds
)
448 (unix:fd-set fd read-fds
)
449 (unix:unix-fast-select
(1+ fd
) (alien:addr read-fds
) nil nil
0 0))
450 ;; Wait if input is not available or if interrupted.
451 (when (or (eql count
0)
452 (and (not count
) (eql errno unix
:eintr
)))
453 (unless #-mp
(system:wait-until-fd-usable
454 fd
:input
(fd-stream-timeout stream
))
455 #+mp
(mp:process-wait-until-fd-usable
456 fd
:input
(fd-stream-timeout stream
))
457 (error 'io-timeout
:stream stream
:direction
:read
))))
461 (system:int-sap
(+ (system:sap-int ibuf-sap
) tail
))
464 (if (eql errno unix
:ewouldblock
)
466 (unless #-mp
(system:wait-until-fd-usable
467 fd
:input
(fd-stream-timeout stream
))
468 #+mp
(mp:process-wait-until-fd-usable
469 fd
:input
(fd-stream-timeout stream
))
470 (error 'io-timeout
:stream stream
:direction
:read
))
475 :message
(unix:get-unix-error-msg errno
) )))
477 (setf (fd-stream-listen stream
) :eof
)
478 (throw 'eof-input-catcher nil
))
480 (incf (fd-stream-ibuf-tail stream
) count
))))))
482 ;;; INPUT-AT-LEAST -- internal
484 ;;; Makes sure there are at least ``bytes'' number of bytes in the input
485 ;;; buffer. Keeps calling do-input until that condition is met.
487 (defmacro input-at-least
(stream bytes
)
488 (let ((stream-var (gensym))
489 (bytes-var (gensym)))
490 `(let ((,stream-var
,stream
)
493 (when (>= (- (fd-stream-ibuf-tail ,stream-var
)
494 (fd-stream-ibuf-head ,stream-var
))
497 (do-input ,stream-var
)))))
499 ;;; INPUT-WRAPPER -- intenal
501 ;;; Macro to wrap around all input routines to handle eof-error noise.
503 (defmacro input-wrapper
((stream bytes eof-error eof-value
) &body read-forms
)
504 (let ((stream-var (gensym))
505 (element-var (gensym)))
506 `(let ((,stream-var
,stream
))
507 (if (fd-stream-unread ,stream-var
)
509 (fd-stream-unread ,stream-var
)
510 (setf (fd-stream-unread ,stream-var
) nil
)
511 (setf (fd-stream-listen ,stream-var
) nil
))
513 (catch 'eof-input-catcher
514 (input-at-least ,stream-var
,bytes
)
517 (incf (fd-stream-ibuf-head ,stream-var
) ,bytes
)
520 (eof-or-lose ,stream-var
,eof-error
,eof-value
))))))))
522 ;;; DEF-INPUT-ROUTINE -- internal
524 ;;; Defines an input routine.
526 (defmacro def-input-routine
(name
530 (defun ,name
(stream eof-error eof-value
)
531 (input-wrapper (stream ,size eof-error eof-value
)
532 (let ((,sap
(fd-stream-ibuf-sap stream
))
533 (,head
(fd-stream-ibuf-head stream
)))
535 (setf *input-routines
*
536 (nconc *input-routines
*
537 (list (list ',type
',name
',size
))))))
539 ;;; INPUT-CHARACTER -- internal
541 ;;; Routine to use in stream-in slot for reading string chars.
543 (def-input-routine input-character
544 (character 1 sap head
)
545 (code-char (sap-ref-8 sap head
)))
547 ;;; INPUT-UNSIGNED-8BIT-BYTE -- internal
549 ;;; Routine to read in an unsigned 8 bit number.
551 (def-input-routine input-unsigned-8bit-byte
552 ((unsigned-byte 8) 1 sap head
)
553 (sap-ref-8 sap head
))
555 ;;; INPUT-SIGNED-8BIT-BYTE -- internal
557 ;;; Routine to read in a signed 8 bit number.
559 (def-input-routine input-signed-8bit-number
560 ((signed-byte 8) 1 sap head
)
561 (signed-sap-ref-8 sap head
))
563 ;;; INPUT-UNSIGNED-16BIT-BYTE -- internal
565 ;;; Routine to read in an unsigned 16 bit number.
567 (def-input-routine input-unsigned-16bit-byte
568 ((unsigned-byte 16) 2 sap head
)
569 (sap-ref-16 sap head
))
571 ;;; INPUT-SIGNED-16BIT-BYTE -- internal
573 ;;; Routine to read in a signed 16 bit number.
575 (def-input-routine input-signed-16bit-byte
576 ((signed-byte 16) 2 sap head
)
577 (signed-sap-ref-16 sap head
))
579 ;;; INPUT-UNSIGNED-32BIT-BYTE -- internal
581 ;;; Routine to read in a unsigned 32 bit number.
583 (def-input-routine input-unsigned-32bit-byte
584 ((unsigned-byte 32) 4 sap head
)
585 (sap-ref-32 sap head
))
587 ;;; INPUT-SIGNED-32BIT-BYTE -- internal
589 ;;; Routine to read in a signed 32 bit number.
591 (def-input-routine input-signed-32bit-byte
592 ((signed-byte 32) 4 sap head
)
593 (signed-sap-ref-32 sap head
))
595 ;;; PICK-INPUT-ROUTINE -- internal
597 ;;; Find an input routine to use given the type. Return as multiple values
598 ;;; the routine, the real type transfered, and the number of bytes per element.
600 (defun pick-input-routine (type)
601 (dolist (entry *input-routines
*)
602 (when (subtypep type
(car entry
))
603 (return (values (symbol-function (cadr entry
))
607 ;;; STRING-FROM-SAP -- internal
609 ;;; Returns a string constructed from the sap, start, and end.
611 (defun string-from-sap (sap start end
)
612 (declare (type index start end
))
613 (let* ((length (- end start
))
614 (string (make-string length
)))
615 (copy-from-system-area sap
(* start vm
:byte-bits
)
616 string
(* vm
:vector-data-offset vm
:word-bits
)
617 (* length vm
:byte-bits
))
621 ;;; FD-STREAM-READ-N-BYTES -- internal
623 ;;; This version waits using server. I changed to the non-server version
624 ;;; because it allows this method to be used by CLX w/o confusing serve-event.
625 ;;; The non-server method is also significantly more efficient for large
628 ;;; The n-bin routine.
630 (defun fd-stream-read-n-bytes (stream buffer start requested eof-error-p
)
631 (declare (type stream stream
) (type index start requested
))
632 (let* ((sap (fd-stream-ibuf-sap stream
))
633 (elsize (fd-stream-element-size stream
))
634 (offset (* elsize start
))
635 (bytes (* elsize requested
))
637 (catch 'eof-input-catcher
639 (input-at-least stream
1)
640 (let* ((head (fd-stream-ibuf-head stream
))
641 (tail (fd-stream-ibuf-tail stream
))
642 (available (- tail head
))
643 (copy (min available bytes
)))
644 (if (typep buffer
'system-area-pointer
)
645 (system-area-copy sap
(* head vm
:byte-bits
)
646 buffer
(* offset vm
:byte-bits
)
647 (* copy vm
:byte-bits
))
648 (copy-from-system-area sap
(* head vm
:byte-bits
)
649 buffer
(+ (* offset vm
:byte-bits
)
650 (* vm
:vector-data-offset
652 (* copy vm
:byte-bits
)))
653 (incf (fd-stream-ibuf-head stream
) copy
)
657 (return requested
))))))
659 (eof-or-lose stream eof-error-p
660 (- requested
(/ bytes elsize
))))))
664 ;;; FD-STREAM-READ-N-BYTES -- internal
666 ;;; The N-Bin method for FD-STREAMs. This doesn't use the SERVER; it blocks
667 ;;; in UNIX-READ. This allows the method to be used to implementing reading
668 ;;; for CLX. It is generally used where there is a definite amount of reading
669 ;;; to be done, so blocking isn't too problematical.
671 ;;; We copy buffered data into the buffer. If there is enough, just return.
672 ;;; Otherwise, we see if the amount of additional data needed will fit in the
673 ;;; stream buffer. If not, inhibit GCing (so we can have a SAP into the Buffer
674 ;;; argument), and read directly into the user supplied buffer. Otherwise,
675 ;;; read a buffer-full into the stream buffer and then copy the amount we need
678 ;;; We loop doing the reads until we either get enough bytes or hit EOF. We
679 ;;; must loop when eof-errorp is T because some streams (like pipes) may return
680 ;;; a partial amount without hitting EOF.
682 (defun fd-stream-read-n-bytes (stream buffer start requested eof-error-p
)
683 (declare (type stream stream
) (type index start requested
))
684 (let* ((sap (fd-stream-ibuf-sap stream
))
686 (head (fd-stream-ibuf-head stream
))
687 (tail (fd-stream-ibuf-tail stream
))
688 (available (- tail head
))
689 (copy (min requested available
)))
690 (declare (type index offset head tail available copy
))
692 (if (typep buffer
'system-area-pointer
)
693 (system-area-copy sap
(* head vm
:byte-bits
)
694 buffer
(* offset vm
:byte-bits
)
695 (* copy vm
:byte-bits
))
696 (copy-from-system-area sap
(* head vm
:byte-bits
)
697 buffer
(+ (* offset vm
:byte-bits
)
698 (* vm
:vector-data-offset
700 (* copy vm
:byte-bits
)))
701 (incf (fd-stream-ibuf-head stream
) copy
))
703 ((or (= copy requested
)
704 (and (not eof-error-p
) (/= copy
0)))
707 (setf (fd-stream-ibuf-head stream
) 0)
708 (setf (fd-stream-ibuf-tail stream
) 0)
709 (setf (fd-stream-listen stream
) nil
)
710 (let ((now-needed (- requested copy
))
711 (len (fd-stream-ibuf-length stream
)))
712 (declare (type index now-needed len
))
715 (let ((fd (fd-stream-fd stream
)))
717 ;; If the desired amount is greater than the stream buffer size, then
718 ;; read directly into the destination, incrementing the start
719 ;; accordingly. In this case, we never leave anything in the stream
722 ;; Code duplication alert: yanked from do-input. --GB
723 (multiple-value-bind (count errno
)
724 (alien:with-alien
((read-fds (alien:struct unix
:fd-set
)))
725 (unix:fd-zero read-fds
)
726 (unix:fd-set fd read-fds
)
727 (unix:unix-fast-select
(1+ fd
) (alien:addr read-fds
) nil nil
0 0))
728 ;; Wait if input is not available or if interrupted.
729 (when (or (eql count
0)
730 (and (not count
) (eql errno unix
:eintr
)))
731 (unless #-mp
(system:wait-until-fd-usable fd
:input
(fd-stream-timeout stream
))
732 #+mp
(mp:process-wait-until-fd-usable fd
:input
(fd-stream-timeout stream
))
733 (error 'io-timeout
:stream stream
:direction
:read
))))
735 (progn;;system:without-gcing -- unsure about this --GB
737 (multiple-value-bind (count errno
)
739 (sap+ (if (typep buffer
'system-area-pointer
)
744 (declare (type (or index null
) count
))
746 (cond ((eql errno unix
:ewouldblock
)
747 ;; arrange to wait until data is there
748 (unless #-mp
(system:wait-until-fd-usable fd
:input
(fd-stream-timeout stream
))
749 #+mp
(mp:process-wait-until-fd-usable fd
:input
(fd-stream-timeout stream
))
750 (error 'io-timeout
:stream stream
:direction
:read
))
754 ;; this is some other error
755 (error 'io-error
:direction
:read
:stream stream
:message
(unix:get-unix-error-msg errno
)))))
757 (decf now-needed count
)
760 (error 'end-of-file
:stream stream
))
761 (return (- requested now-needed
)))
762 (when (zerop now-needed
) (return requested
))
763 (incf offset count
))))))))
765 (let ((fd (fd-stream-fd stream
)))
767 ;; If we want less than the buffer size, then loop trying to fill the
768 ;; stream buffer and copying what we get into the destination. When
769 ;; we have enough, we leave what's left in the stream buffer.
771 ;; Code duplication alert: yanked from do-input. --GB
772 (multiple-value-bind (count errno
)
773 (alien:with-alien
((read-fds (alien:struct unix
:fd-set
)))
774 (unix:fd-zero read-fds
)
775 (unix:fd-set fd read-fds
)
776 (unix:unix-fast-select
(1+ fd
) (alien:addr read-fds
) nil nil
0 0))
777 ;; Wait if input is not available or if interrupted.
778 (when (or (eql count
0)
779 (and (not count
) (eql errno unix
:eintr
)))
780 (unless #-mp
(system:wait-until-fd-usable fd
:input
(fd-stream-timeout stream
))
781 #+mp
(mp:process-wait-until-fd-usable fd
:input
(fd-stream-timeout stream
))
782 (error 'io-timeout
:stream stream
:direction
:read
))))
785 (multiple-value-bind (count errno
)
786 (unix:unix-read fd sap len
)
787 (declare (type (or index null
) count
))
789 (cond ((eql errno unix
:ewouldblock
)
791 (unless #-mp
(system:wait-until-fd-usable fd
:input
(fd-stream-timeout stream
))
792 #+mp
(mp:process-wait-until-fd-usable fd
:input
(fd-stream-timeout stream
))
793 (error 'io-timeout
:stream stream
:direction
:read
))
797 (error 'io-error
:stream stream
:direction
:read
:message
(unix:get-unix-error-msg errno
)))))
799 (when (and eof-error-p
(zerop count
))
800 (error 'end-of-file
:stream stream
))
802 (let* ((copy (min now-needed count
))
803 (copy-bits (* copy vm
:byte-bits
))
805 (* (+ offset available
) vm
:byte-bits
)))
806 (declare (type index copy copy-bits buffer-start-bits
))
807 (if (typep buffer
'system-area-pointer
)
808 (system-area-copy sap
0
809 buffer buffer-start-bits
811 (copy-from-system-area sap
0
812 buffer
(+ buffer-start-bits
813 (* vm
:vector-data-offset
817 (decf now-needed copy
)
818 (when (or (zerop now-needed
) (not eof-error-p
))
819 (setf (fd-stream-ibuf-head stream
) copy
)
820 (setf (fd-stream-ibuf-tail stream
) count
)
821 (return (- requested now-needed
)))
822 (incf offset copy
) ))))))) ))))))
825 ;;;; Utility functions (misc routines, etc)
827 ;;; SET-ROUTINES -- internal
829 ;;; Fill in the various routine slots for the given type. Input-p and
830 ;;; output-p indicate what slots to fill. The buffering slot must be set prior
831 ;;; to calling this routine.
833 (defun set-routines (stream type input-p output-p buffer-p
)
834 (let ((target-type (case type
835 ((:default unsigned-byte
)
846 (when (fd-stream-obuf-sap stream
)
847 (put-buffer-back (fd-stream-obuf-sap stream
))
848 (setf (fd-stream-obuf-sap stream
) nil
))
849 (when (fd-stream-ibuf-sap stream
)
850 (put-buffer-back (fd-stream-ibuf-sap stream
))
851 (setf (fd-stream-ibuf-sap stream
) nil
))
856 (pick-input-routine target-type
)
858 (error "Could not find any input routine for ~S" target-type
))
859 (setf (fd-stream-ibuf-sap stream
) (next-available-buffer))
860 (setf (fd-stream-ibuf-length stream
) bytes-per-buffer
)
861 (setf (fd-stream-ibuf-tail stream
) 0)
862 (if (subtypep type
'character
)
863 (setf (fd-stream-in stream
) routine
864 (fd-stream-bin stream
) #'ill-bin
)
865 (setf (fd-stream-in stream
) #'ill-in
866 (fd-stream-bin stream
) routine
))
868 (setf (fd-stream-n-bin stream
) #'fd-stream-read-n-bytes
)
870 (setf (lisp-stream-in-buffer stream
)
871 (make-array in-buffer-length
872 :element-type
'(unsigned-byte 8)))))
873 (setf input-size size
)
874 (setf input-type type
)))
879 (pick-output-routine target-type
(fd-stream-buffering stream
))
881 (error "Could not find any output routine for ~S buffered ~S."
882 (fd-stream-buffering stream
)
884 (setf (fd-stream-obuf-sap stream
) (next-available-buffer))
885 (setf (fd-stream-obuf-length stream
) bytes-per-buffer
)
886 (setf (fd-stream-obuf-tail stream
) 0)
887 (if (subtypep type
'character
)
888 (setf (fd-stream-out stream
) routine
889 (fd-stream-bout stream
) #'ill-bout
)
890 (setf (fd-stream-out stream
)
892 (pick-output-routine 'base-char
893 (fd-stream-buffering stream
)))
895 (fd-stream-bout stream
) routine
))
896 (setf (fd-stream-sout stream
)
897 (if (eql size
1) #'fd-sout
#'ill-out
))
898 (setf (fd-stream-char-pos stream
) 0)
899 (setf output-size size
)
900 (setf output-type type
)))
902 (when (and input-size output-size
903 (not (eq input-size output-size
)))
904 (error "Element sizes for input (~S:~S) and output (~S:~S) differ?"
905 input-type input-size
906 output-type output-size
))
907 (setf (fd-stream-element-size stream
)
908 (or input-size output-size
))
910 (setf (fd-stream-element-type stream
)
911 (cond ((equal input-type output-type
)
917 ((subtypep input-type output-type
)
919 ((subtypep output-type input-type
)
922 (error "Input type (~S) and output type (~S) are unrelated?"
926 ;;; FD-STREAM-MISC-ROUTINE -- input
928 ;;; Handle the various misc operations on fd-stream.
930 (defun fd-stream-misc-routine (stream operation
&optional arg1 arg2
)
931 (declare (ignore arg2
))
934 (or (not (eql (fd-stream-ibuf-head stream
)
935 (fd-stream-ibuf-tail stream
)))
936 (fd-stream-listen stream
)
937 (setf (fd-stream-listen stream
)
938 (eql (alien:with-alien
((read-fds (alien:struct unix
:fd-set
)))
939 (unix:fd-zero read-fds
)
940 (unix:fd-set
(fd-stream-fd stream
) read-fds
)
941 (unix:unix-fast-select
(1+ (fd-stream-fd stream
))
942 (alien:addr read-fds
) nil nil
946 (setf (fd-stream-unread stream
) arg1
)
947 (setf (fd-stream-listen stream
) t
))
950 ;; We got us an abort on our hands.
951 (when (fd-stream-handler stream
)
952 (system:remove-fd-handler
(fd-stream-handler stream
))
953 (setf (fd-stream-handler stream
) nil
))
954 (when (and (fd-stream-file stream
)
955 (fd-stream-obuf-sap stream
))
956 ;; Can't do anything unless we know what file were dealing with,
957 ;; and we don't want to do anything strange unless we were
958 ;; writing to the file.
959 (if (fd-stream-original stream
)
960 ;; Have an handle on the original, just revert.
963 (unix:unix-rename
(fd-stream-original stream
)
964 (fd-stream-file stream
))
966 (cerror "Go on as if nothing bad happened."
967 "Could not restore ~S to it's original contents: ~A"
968 (fd-stream-file stream
)
969 (unix:get-unix-error-msg err
))))
970 ;; Can't restore the orignal, so nuke that puppy.
973 (unix:unix-unlink
(fd-stream-file stream
))
975 (cerror "Go on as if nothing bad happened."
976 "Could not remove ~S: ~A"
977 (fd-stream-file stream
)
978 (unix:get-unix-error-msg err
)))))))
980 (fd-stream-misc-routine stream
:finish-output
)
981 (when (and (fd-stream-original stream
)
982 (fd-stream-delete-original stream
))
985 (unix:unix-unlink
(fd-stream-original stream
))
987 (cerror "Go on as if nothing bad happened."
988 "Could not delete ~S during close of ~S: ~A"
989 (fd-stream-original stream
)
991 (unix:get-unix-error-msg err
)))))))
992 (when (fboundp 'cancel-finalization
)
993 (cancel-finalization stream
))
994 (unix:unix-close
(fd-stream-fd stream
))
995 (when (fd-stream-obuf-sap stream
)
996 (put-buffer-back (fd-stream-obuf-sap stream
))
997 (setf (fd-stream-obuf-sap stream
) nil
))
998 (when (fd-stream-ibuf-sap stream
)
999 (put-buffer-back (fd-stream-ibuf-sap stream
))
1000 (setf (fd-stream-ibuf-sap stream
) nil
))
1001 (lisp::set-closed-flame stream
))
1003 (setf (fd-stream-unread stream
) nil
)
1004 (setf (fd-stream-ibuf-head stream
) 0)
1005 (setf (fd-stream-ibuf-tail stream
) 0)
1006 (catch 'eof-input-catcher
1008 (multiple-value-bind
1010 (alien:with-alien
((read-fds (alien:struct unix
:fd-set
)))
1011 (unix:fd-zero read-fds
)
1012 (unix:fd-set
(fd-stream-fd stream
) read-fds
)
1013 (unix:unix-fast-select
(1+ (fd-stream-fd stream
))
1014 (alien:addr read-fds
) nil nil
0 0))
1015 (cond ((eql count
1)
1017 (setf (fd-stream-ibuf-head stream
) 0)
1018 (setf (fd-stream-ibuf-tail stream
) 0))
1019 ((and (not count
) (eql errno unix
:eintr
)))
1023 (flush-output-buffer stream
))
1025 (flush-output-buffer stream
) )
1027 (fd-stream-element-type stream
))
1029 (unix:unix-isatty
(fd-stream-fd stream
)))
1033 (fd-stream-char-pos stream
))
1035 (unless (fd-stream-file stream
)
1036 (error 'simple-type-error
1038 :expected-type
'file-stream
1039 :format-control
"~s is not a stream associated with a file."
1040 :format-arguments
(list stream
)))
1041 (multiple-value-bind
1042 (okay dev ino mode nlink uid gid rdev size
1043 atime mtime ctime blksize blocks
)
1044 (unix:unix-fstat
(fd-stream-fd stream
))
1045 (declare (ignore ino nlink uid gid rdev
1046 atime mtime ctime blksize blocks
))
1048 (error "Error fstating ~S: ~A"
1050 (unix:get-unix-error-msg dev
)))
1053 (truncate size
(fd-stream-element-size stream
)))))
1055 (fd-stream-file-position stream arg1
))))
1058 ;;; FD-STREAM-FILE-POSITION -- internal.
1060 (defun fd-stream-file-position (stream &optional newpos
)
1061 (declare (type fd-stream stream
)
1062 (type (or (integer 0) (member nil
:start
:end
)) newpos
))
1064 (system:without-interrupts
1065 ;; First, find the position of the UNIX file descriptor in the file.
1066 (multiple-value-bind
1068 (unix:unix-lseek
(fd-stream-fd stream
) 0 unix
:l_incr
)
1069 (declare (type (or (integer 0) null
) posn
))
1071 ;; Adjust for buffered output:
1072 ;; If there is any output buffered, the *real* file position
1073 ;; will be larger than reported by lseek because lseek
1074 ;; obviously cannot take< into account output we have not
1076 (incf posn
(fd-stream-obuf-tail stream
))
1077 ;; Adjust for unread input:
1078 ;; If there is any input read from UNIX but not supplied to
1079 ;; the user of the stream, the *real* file position will
1080 ;; smaller than reported, because we want to look like the
1081 ;; unread stuff is still available.
1082 (decf posn
(- (fd-stream-ibuf-tail stream
)
1083 (fd-stream-ibuf-head stream
)))
1084 (when (fd-stream-unread stream
)
1086 ;; Divide bytes by element size.
1087 (truncate posn
(fd-stream-element-size stream
)))
1088 ((eq errno unix
:espipe
)
1091 (system:with-interrupts
1092 (error "Error lseek'ing ~S: ~A"
1094 (unix:get-unix-error-msg errno
)))))))
1097 (declare (type (integer 0) offset
))
1098 ;; Make sure we don't have any output pending, because if we move the
1099 ;; file pointer before writing this stuff, it will be written in the
1101 (flush-output-buffer stream
)
1102 ;; Clear out any pending input to force the next read to go to the
1104 (setf (fd-stream-unread stream
) nil
)
1105 (setf (fd-stream-ibuf-head stream
) 0)
1106 (setf (fd-stream-ibuf-tail stream
) 0)
1107 ;; Trash cached value for listen, so that we check next time.
1108 (setf (fd-stream-listen stream
) nil
)
1110 (cond ((eq newpos
:start
)
1115 origin unix
:l_xtnd
))
1116 ((typep newpos
'(integer 0))
1117 (setf offset
(* newpos
(fd-stream-element-size stream
))
1120 (error "Invalid position given to file-position: ~S" newpos
)))
1121 (multiple-value-bind
1123 (unix:unix-lseek
(fd-stream-fd stream
) offset origin
)
1126 ((eq errno unix
:espipe
)
1129 (error "Error lseek'ing ~S: ~A"
1131 (unix:get-unix-error-msg errno
))))))))
1135 ;;;; Creation routines (MAKE-FD-STREAM and OPEN)
1137 ;;; MAKE-FD-STREAM -- Public.
1139 ;;; Returns a FD-STREAM on the given file.
1141 (defun make-fd-stream (fd
1144 (output nil output-p
)
1145 (element-type 'base-char
)
1154 (format nil
"file ~S" file
)
1155 (format nil
"descriptor ~D" fd
)))
1157 (declare (type index fd
) (type (or index null
) timeout
)
1158 (type (member :none
:line
:full
) buffering
))
1159 "Create a stream for the given unix file descriptor.
1160 If input is non-nil, allow input operations.
1161 If output is non-nil, allow output operations.
1162 If neither input nor output are specified, default to allowing input.
1163 Element-type indicates the element type to use (as for open).
1164 Buffering indicates the kind of buffering to use.
1165 Timeout (if true) is the number of seconds to wait for input. If NIL (the
1166 default), then wait forever. When we time out, we signal IO-TIMEOUT.
1167 File is the name of the file (will be returned by PATHNAME).
1168 Name is used to identify the stream when printed."
1169 (cond ((not (or input-p output-p
))
1171 ((not (or input output
))
1172 (error "File descriptor must be opened either for input or output.")))
1173 (let ((stream (%make-fd-stream
:fd fd
1177 :delete-original delete-original
1179 :buffering buffering
1181 (set-routines stream element-type input output input-buffer-p
)
1182 (when (and auto-close
(fboundp 'finalize
))
1185 (unix:unix-close fd
)
1186 (format *terminal-io
* "** Closed file descriptor ~D~%"
1191 ;;; PICK-PACKUP-NAME -- internal
1193 ;;; Pick a name to use for the backup file.
1195 (defvar *backup-extension
* ".BAK"
1196 "This is a string that OPEN tacks on the end of a file namestring to produce
1197 a name for the :if-exists :rename-and-delete and :rename options. Also,
1198 this can be a function that takes a namestring and returns a complete
1201 (defun pick-backup-name (name)
1202 (declare (type simple-string name
))
1203 (let ((ext *backup-extension
*))
1205 (simple-string (concatenate 'simple-string name ext
))
1206 (function (funcall ext name
)))))
1208 ;;; ASSURE-ONE-OF -- internal
1210 ;;; Assure that the given arg is one of the given list of valid things.
1211 ;;; Allow the user to fix any problems.
1213 (defun assure-one-of (item list what
)
1214 (unless (member item list
)
1216 (cerror "Enter new value for ~*~S"
1217 "~S is invalid for ~S. Must be one of~{ ~S~}"
1221 (format (the stream
*query-io
*) "Enter new value for ~S: " what
)
1222 (force-output *query-io
*)
1223 (setf item
(read *query-io
*))
1224 (when (member item list
)
1228 ;;; DO-OLD-RENAME -- Internal
1230 ;;; Rename Namestring to Original. First, check if we have write access,
1231 ;;; since we don't want to trash unwritable files even if we technically can.
1232 ;;; We return true if we suceed in renaming.
1234 (defun do-old-rename (namestring original
)
1235 (unless (unix:unix-access namestring unix
:w_ok
)
1236 (cerror "Try to rename it anyway." "File ~S is not writable." namestring
))
1237 (multiple-value-bind
1239 (unix:unix-rename namestring original
)
1242 (cerror "Use :SUPERSEDE instead."
1243 "Could not rename ~S to ~S: ~A."
1246 (unix:get-unix-error-msg err
))
1249 ;;; RETURN-STREAM -- internal
1251 ;;; (this is just to save having to reindent the code in OPEN...move it there)
1253 (defmacro return-stream
(class &body body
)
1254 (let ((stream (gensym)))
1255 `(let ((,stream
(progn ,@body
)))
1257 (make-instance ,class
:lisp-stream
,stream
)
1262 ;;; Open the given file.
1264 (defun open (filename
1267 (element-type 'base-char
)
1268 (if-exists nil if-exists-given
)
1269 (if-does-not-exist nil if-does-not-exist-given
)
1270 (external-format :default
)
1272 &aux
; Squelch assignment warning.
1273 (direction direction
)
1274 (if-does-not-exist if-does-not-exist
)
1275 (if-exists if-exists
))
1276 "Return a stream which reads from or writes to Filename.
1278 :direction - one of :input, :output, :io, or :probe
1279 :element-type - Type of object to read or write, default BASE-CHAR
1280 :if-exists - one of :error, :new-version, :rename, :rename-and-delete,
1281 :overwrite, :append, :supersede or nil
1282 :if-does-not-exist - one of :error, :create or nil
1283 See the manual for details."
1284 (declare (ignore external-format
))
1286 ;; First, make sure that DIRECTION is valid. Allow it to be changed if not.
1288 (assure-one-of direction
1289 '(:input
:output
:io
:probe
)
1292 ;; Calculate useful stuff.
1293 (multiple-value-bind
1296 (:input
(values t nil unix
:o_rdonly
))
1297 (:output
(values nil t unix
:o_wronly
))
1298 (:io
(values t t unix
:o_rdwr
))
1299 (:probe
(values t nil unix
:o_rdonly
)))
1300 (declare (type index mask
))
1301 (let* ((pathname (pathname filename
))
1303 (cond ((unix-namestring pathname input
))
1304 ((and input
(eq if-does-not-exist
:create
))
1305 (unix-namestring pathname nil
)))))
1306 ;; Process if-exists argument if we are doing any output.
1308 (unless if-exists-given
1310 (if (eq (pathname-version pathname
) :newest
)
1314 (assure-one-of if-exists
1315 '(:error
:new-version
:rename
1316 :rename-and-delete
:overwrite
1317 :append
:supersede nil
)
1321 (setf mask
(logior mask unix
:o_excl
)))
1322 ((:rename
:rename-and-delete
)
1323 (setf mask
(logior mask unix
:o_creat
)))
1324 ((:new-version
:supersede
)
1325 (setf mask
(logior mask unix
:o_trunc
)))
1327 (setf mask
(logior mask unix
:o_append
)))))
1329 (setf if-exists
:ignore-this-arg
)))
1331 (unless if-does-not-exist-given
1332 (setf if-does-not-exist
1333 (cond ((eq direction
:input
) :error
)
1335 (member if-exists
'(:overwrite
:append
)))
1337 ((eq direction
:probe
)
1341 (setf if-does-not-exist
1342 (assure-one-of if-does-not-exist
1343 '(:error
:create nil
)
1344 :if-does-not-exist
))
1345 (if (eq if-does-not-exist
:create
)
1346 (setf mask
(logior mask unix
:o_creat
)))
1348 (let ((original (if (member if-exists
1349 '(:rename
:rename-and-delete
))
1350 (pick-backup-name namestring
)))
1351 (delete-original (eq if-exists
:rename-and-delete
))
1354 ;; We are doing a :rename or :rename-and-delete.
1355 ;; Determine if the file already exists, make sure the original
1356 ;; file is not a directory and keep the mode
1359 (multiple-value-bind
1360 (okay err
/dev inode orig-mode
)
1361 (unix:unix-stat namestring
)
1362 (declare (ignore inode
)
1363 (type (or index null
) orig-mode
))
1366 (when (and output
(= (logand orig-mode
#o170000
)
1368 (error "Cannot open ~S for output: Is a directory."
1370 (setf mode
(logand orig-mode
#o777
))
1372 ((eql err
/dev unix
:enoent
)
1375 (error "Cannot find ~S: ~A"
1377 (unix:get-unix-error-msg err
/dev
))))))))
1379 (do-old-rename namestring original
))
1381 (setf delete-original nil
)
1382 ;; In order to use SUPERSEDE instead, we have
1383 ;; to make sure unix:o_creat corresponds to
1384 ;; if-does-not-exist. unix:o_creat was set
1385 ;; before because of if-exists being :rename.
1386 (unless (eq if-does-not-exist
:create
)
1387 (setf mask
(logior (logandc2 mask unix
:o_creat
) unix
:o_trunc
)))
1388 (setf if-exists
:supersede
))))
1390 ;; Okay, now we can try the actual open.
1392 (multiple-value-bind
1395 (unix:unix-open namestring mask mode
)
1396 (values nil unix
:enoent
))
1398 (return-stream class
1400 ((:input
:output
:io
)
1404 :element-type element-type
1407 :delete-original delete-original
1413 (%make-fd-stream
:name namestring
:fd fd
1415 :element-type element-type
)))
1418 ((eql errno unix
:enoent
)
1419 (case if-does-not-exist
1421 (cerror "Return NIL."
1424 :format-control
"Error opening ~S, ~A."
1426 (list pathname
(unix:get-unix-error-msg errno
))))
1428 (cerror "Return NIL."
1431 "Error creating ~S, path does not exist."
1435 ((eql errno unix
:eexist
)
1436 (unless (eq nil if-exists
)
1437 (cerror "Return NIL."
1440 :format-control
"Error opening ~S, ~A."
1442 (list pathname
(unix:get-unix-error-msg errno
))))
1444 ((eql errno unix
:eacces
)
1445 (cerror "Try again."
1446 "Error opening ~S, ~A."
1448 (unix:get-unix-error-msg errno
)))
1450 (cerror "Return NIL."
1451 "Error opening ~S, ~A."
1453 (unix:get-unix-error-msg errno
))
1454 (return nil
)))))))))
1456 ;;;; Initialization.
1459 "The stream connected to the controlling terminal or NIL if there is none.")
1461 "The stream connected to the standard input (file descriptor 0).")
1462 (defvar *stdout
* nil
1463 "The stream connected to the standard output (file descriptor 1).")
1464 (defvar *stderr
* nil
1465 "The stream connected to the standard error output (file descriptor 2).")
1467 ;;; STREAM-INIT -- internal interface
1469 ;;; Called when the cold load is first started up.
1471 (defun stream-init ()
1473 (setf *terminal-io
* (make-synonym-stream '*tty
*))
1474 (setf *standard-output
* (make-synonym-stream '*stdout
*))
1475 (setf *standard-input
*
1476 (make-two-way-stream (make-synonym-stream '*stdin
*)
1478 (setf *error-output
* (make-synonym-stream '*stderr
*))
1479 (setf *query-io
* (make-synonym-stream '*terminal-io
*))
1480 (setf *debug-io
* *query-io
*)
1481 (setf *trace-output
* *standard-output
*)
1484 ;;; STREAM-REINIT -- internal interface
1486 ;;; Called whenever a saved core is restarted.
1488 (defun stream-reinit ()
1489 (setf *available-buffers
* nil
)
1491 (make-fd-stream 0 :name
"Standard Input" :input t
:buffering
:line
))
1493 (make-fd-stream 1 :name
"Standard Output" :output t
:buffering
:line
))
1495 (make-fd-stream 2 :name
"Standard Error" :output t
:buffering
:line
))
1496 (let ((tty (and (not *batch-mode
*)
1497 (unix:unix-open
"/dev/tty" unix
:o_rdwr
#o666
))))
1500 (make-fd-stream tty
:name
"the Terminal" :input t
:output t
1501 :buffering
:line
:auto-close t
)
1502 (make-two-way-stream *stdin
* *stdout
*))))
1508 (defun default-beep-function (stream)
1509 (write-char #\bell stream
)
1510 (finish-output stream
))
1512 (defvar *beep-function
* #'default-beep-function
1513 "This is called in BEEP to feep the user. It takes a stream.")
1515 (defun beep (&optional
(stream *terminal-io
*))
1516 (funcall *beep-function
* stream
))
1519 ;;; File-Name -- internal interface
1521 ;;; Kind of like File-Position, but is an internal hack used by the filesys
1522 ;;; stuff to get and set the file name.
1524 (defun file-name (stream &optional new-name
)
1525 (when (typep stream
'fd-stream
)
1527 (setf (fd-stream-pathname stream
) new-name
)
1528 (setf (fd-stream-file stream
)
1529 (unix-namestring new-name nil
))
1532 (fd-stream-pathname stream
)))))
1535 ;;;; Degenerate international character support:
1537 (defun file-string-length (stream object
)
1538 (declare (type (or string character
) object
) (type file-stream stream
))
1539 "Return the delta in Stream's FILE-POSITION that would be caused by writing
1540 Object to Stream. Non-trivial only in implementations that support
1541 international character sets."
1542 (declare (ignore stream
))
1545 (string (length object
))))
1547 (defun stream-external-format (stream)
1548 (declare (type file-stream stream
) (ignore stream
))