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

  ViewVC Help
Powered by ViewVC 1.1.5