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

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

Parent Directory Parent Directory | Revision Log Revision Log


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

  ViewVC Help
Powered by ViewVC 1.1.5