/[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 - (hide annotations)
Fri Mar 16 15:26:37 1990 UTC (24 years, 1 month ago) by ram
Branch: MAIN
Changes since 1.3: +6 -0 lines
.../code/fd-stream.lisp, 08-Mar-90 17:58:17, Edit by Wlott.
  Yet another attempt at file-position.  Forgot to zero both the head and
  tail of the input buffer when we moved the file pointer.  Therefore, UNIX
  thought that the file pointer was at the beginning of the file, but LISP
  thought that the file pointer was ibuf-tail bytes in.
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 ram 1.4 ;; Clear out any pending input to force the next read to go to the
927     ;; disk.
928     (setf (fd-stream-unread stream) nil)
929     (setf (fd-stream-ibuf-head stream) 0)
930     (setf (fd-stream-ibuf-tail stream) 0)
931     ;; Now move it.
932 ram 1.1 (cond ((eq newpos :start)
933     (setf offset 0 origin mach:l_set))
934     ((eq newpos :end)
935     (setf offset 0 origin mach:l_xtnd))
936     ((numberp newpos)
937     (setf offset (* newpos (fd-stream-element-size stream))
938     origin mach:l_set))
939     (t
940     (error "Invalid position given to file-position: ~S" newpos)))
941     (multiple-value-bind
942     (posn errno)
943     (mach:unix-lseek (fd-stream-fd stream) offset origin)
944     (cond ((numberp posn)
945     t)
946     ((eq errno mach:espipe)
947     nil)
948     (t
949     (error "Error lseek'ing ~S: ~A"
950     stream
951     (mach:get-unix-error-msg errno))))))))
952    
953    
954    
955     ;;;; Creation routines (MAKE-FD-STREAM and OPEN)
956    
957     ;;; MAKE-FD-STREAM -- Public.
958     ;;;
959     ;;; Returns a FD-STREAM on the given file.
960     ;;;
961     (defun make-fd-stream (fd
962     &key
963     (input nil input-p)
964     (output nil output-p)
965     (element-type 'string-char)
966     (buffering :full)
967     file
968     original
969     delete-original
970     (name (if file
971     (format nil "file ~S" file)
972     (format nil "descriptor ~D" fd))))
973     "Create a stream for the given unix file descriptor. If input is non-nil,
974     allow input operations. If output is non-nil, allow output operations. If
975     neither input nor output are specified, default to allowing input.
976     element-type indicates the element type to use (as for open). Buffering
977     indicates the kind of buffering to use (one of :none, :line, or :full). If
978     file is spesified, it should be the name of the file. Name is used to
979     identify the stream when printed."
980     (cond ((not (or input-p output-p))
981     (setf input t))
982     ((not (or input output))
983     (error "File descriptor must be opened either for input or output.")))
984     (let ((stream (%make-fd-stream :fd fd
985     :name name
986     :file file
987     :original original
988     :delete-original delete-original
989     :buffering buffering)))
990     (set-routines stream element-type input output)
991     stream))
992    
993     ;;; PICK-PACKUP-NAME -- internal
994     ;;;
995     ;;; Pick a name to use for the backup file.
996     ;;;
997     (defvar *backup-extension* ".BAK"
998     "This is a string that OPEN tacks on the end of a file namestring to produce
999     a name for the :if-exists :rename-and-delete and :rename options. Also,
1000     this can be a function that takes a namestring and returns a complete
1001     namestring.")
1002     ;;;
1003     (defun pick-backup-name (name)
1004     (etypecase *backup-extension*
1005     (string (concatenate 'simple-string name *backup-extension*))
1006     (function (funcall *backup-extension* name))))
1007    
1008     ;;; ASSURE-ONE-OF -- internal
1009     ;;;
1010     ;;; Assure that the given arg is one of the given list of valid things.
1011     ;;; Allow the user to fix any problems.
1012     ;;;
1013     (defun assure-one-of (item list what)
1014     (unless (member item list)
1015     (loop
1016     (cerror "Enter new value for ~*~S"
1017     "~S is invalid for ~S. Must be one of~{ ~S~}"
1018     item
1019     what
1020     list)
1021     (format *query-io* "Enter new value for ~S: " what)
1022     (force-output *query-io*)
1023     (setf item (read *query-io*))
1024     (when (member item list)
1025     (return))))
1026     item)
1027    
1028     ;;; OPEN -- public
1029     ;;;
1030     ;;; Open the given file.
1031     ;;;
1032     (defun open (filename
1033     &key
1034     (direction :input)
1035     (element-type 'string-char)
1036     (if-exists nil if-exists-given)
1037     (if-does-not-exist nil if-does-not-exist-given))
1038     "Return a stream which reads from or writes to Filename.
1039     Defined keywords:
1040     :direction - one of :input, :output, :io, or :probe
1041     :element-type - Type of object to read or write, default STRING-CHAR
1042     :if-exists - one of :error, :new-version, :rename, :rename-and-delete,
1043     :overwrite, :append, :supersede or nil
1044     :if-does-not-exist - one of :error, :create or nil
1045     See the manual for details."
1046     ;; First, make sure that DIRECTION is valid. Allow it to be changed if not.
1047     (setf direction
1048     (assure-one-of direction
1049     '(:input :output :io :probe)
1050     :direction))
1051    
1052     ;; Calculate useful stuff.
1053     (multiple-value-bind
1054     (input output mask)
1055     (case direction
1056     (:input (values t nil mach:o_rdonly))
1057     (:output (values nil t mach:o_wronly))
1058     (:io (values t t mach:o_rdwr))
1059     (:probe (values nil nil mach:o_rdonly)))
1060     (let* ((pathname (pathname filename))
1061     (namestring (predict-name pathname input)))
1062    
1063     ;; Process if-exists argument if we are doing any output.
1064     (cond (output
1065     (unless if-exists-given
1066     (setf if-exists
1067     (if (eq (pathname-version pathname) :newest)
1068     :new-version
1069     :error)))
1070     (setf if-exists
1071     (assure-one-of if-exists
1072     '(:error :new-version :rename
1073     :rename-and-delete :overwrite
1074     :append :supersede nil)
1075     :if-exists))
1076     (case if-exists
1077     ((:error nil)
1078     (setf mask (logior mask mach:o_excl)))
1079     ((:rename :rename-and-delete)
1080     (setf mask (logior mask mach:o_creat)))
1081     ((:new-version :supersede)
1082     (setf mask (logior mask mach:o_trunc)))
1083     (:append
1084     (setf mask (logior mask mach:o_append)))))
1085     (t
1086     (setf if-exists :ignore-this-arg)))
1087    
1088     (unless if-does-not-exist-given
1089     (setf if-does-not-exist
1090     (cond ((eq direction :input) :error)
1091     ((and output
1092     (member if-exists '(:overwrite :append)))
1093     :error)
1094     ((eq direction :probe)
1095     nil)
1096     (t
1097     :create))))
1098     (setf if-does-not-exist
1099     (assure-one-of if-does-not-exist
1100     '(:error :create nil)
1101     :if-does-not-exist))
1102     (if (eq if-does-not-exist :create)
1103     (setf mask (logior mask mach:o_creat)))
1104    
1105     (let ((original (if (member if-exists
1106     '(:rename :rename-and-delete))
1107     (pick-backup-name namestring)))
1108     (delete-original (eq if-exists :rename-and-delete))
1109     (mode #o666))
1110     (when original
1111     ;; We are doing a :rename or :rename-and-delete.
1112     ;; Determine if the file already exists, make sure the original
1113     ;; file is not a directory and keep the mode
1114     (let ((exists
1115     (multiple-value-bind
1116     (okay err/dev inode orig-mode)
1117     (mach:unix-stat namestring)
1118     (declare (ignore inode))
1119     (cond (okay
1120     (when (and output (= (logand orig-mode #o170000)
1121     #o40000))
1122     (error "Cannot open ~S for output: Is a directory."
1123     namestring))
1124     (setf mode (logand orig-mode #o777))
1125     t)
1126     ((eql err/dev mach:enoent)
1127     nil)
1128     (t
1129     (error "Cannot find ~S: ~A"
1130     namestring
1131     (mach:get-unix-error-msg err/dev)))))))
1132     (when (or (not exists)
1133     ;; Do the rename.
1134     (multiple-value-bind
1135     (okay err)
1136     (mach:unix-rename namestring original)
1137     (unless okay
1138     (cerror "Use :SUPERSEDE instead."
1139     "Could not rename ~S to ~S: ~A."
1140     namestring
1141     original
1142     (mach:get-unix-error-msg err))
1143     t)))
1144     (setf original nil)
1145     (setf delete-original nil)
1146     ;; In order to use SUPERSEDE instead, we have
1147     ;; to make sure mach:o_creat corresponds to
1148     ;; if-does-not-exist. mach:o_creat was set
1149     ;; before because of if-exists being :rename.
1150     (unless (eq if-does-not-exist :create)
1151     (setf mask (logior (logandc2 mask mach:o_creat) mach:o_trunc)))
1152     (setf if-exists :supersede))))
1153    
1154     ;; Okay, now we can try the actual open.
1155     (multiple-value-bind
1156     (fd errno)
1157     (mach:unix-open namestring mask mode)
1158     (cond ((numberp fd)
1159     (case direction
1160     ((:input :output :io)
1161     (make-fd-stream fd
1162     :input input
1163     :output output
1164     :element-type element-type
1165     :file namestring
1166     :original original
1167     :delete-original delete-original))
1168     (:probe
1169     (let ((stream (%make-fd-stream :name namestring
1170     :fd fd
1171     :element-type element-type)))
1172     (close stream)
1173     stream))))
1174     ((eql errno mach:enoent)
1175     (case if-does-not-exist
1176     (:error
1177     (cerror "Return NIL."
1178     "Error opening ~S, ~A."
1179     pathname
1180     (mach:get-unix-error-msg errno)))
1181     (:create
1182     (cerror "Return NIL."
1183     "Error creating ~S, path does not exist."
1184     pathname)))
1185     nil)
1186     ((eql errno mach:eexist)
1187     (unless (eq nil if-exists)
1188     (cerror "Return NIL."
1189     "Error opening ~S, ~A."
1190     pathname
1191     (mach:get-unix-error-msg errno)))
1192     nil)
1193     (t
1194     (cerror "Return NIL."
1195     "Error opening ~S, ~A."
1196     pathname
1197     (mach:get-unix-error-msg errno))
1198     nil)))))))
1199    
1200     ;;;; Initialization.
1201    
1202     (defvar *tty* nil
1203     "The stream connected to the controlling terminal or NIL if there is none.")
1204     (defvar *stdin* nil
1205     "The stream connected to the standard input (file descriptor 0).")
1206     (defvar *stdout* nil
1207     "The stream connected to the standard output (file descriptor 1).")
1208     (defvar *stderr* nil
1209     "The stream connected to the standard error output (file descriptor 2).")
1210    
1211     ;;; STREAM-INIT -- internal interface
1212     ;;;
1213     ;;; Called when the cold load is first started up.
1214     ;;;
1215     (defun stream-init ()
1216     (stream-reinit)
1217     (setf *terminal-io* (make-synonym-stream '*tty*))
1218     (setf *standard-input* (make-synonym-stream '*stdin*))
1219     (setf *standard-output* (make-synonym-stream '*stdout*))
1220     (setf *error-output* (make-synonym-stream '*stderr*))
1221     (setf *query-io* (make-synonym-stream '*terminal-io*))
1222     (setf *debug-io* *query-io*)
1223     (setf *trace-output* *standard-output*)
1224     nil)
1225    
1226     ;;; STREAM-REINIT -- internal interface
1227     ;;;
1228     ;;; Called whenever a saved core is restarted.
1229     ;;;
1230     (defun stream-reinit ()
1231     (setf *available-buffers* nil)
1232     (setf *stdin*
1233     (make-fd-stream 0 :name "Standard Input" :input t :buffering :line))
1234     (setf *stdout*
1235     (make-fd-stream 1 :name "Standard Output" :output t :buffering :line))
1236     (setf *stderr*
1237     (make-fd-stream 2 :name "Standard Error" :output t :buffering :line))
1238     (let ((tty (mach:unix-open "/dev/tty" mach:o_rdwr #o666)))
1239     (if tty
1240     (setf *tty*
1241     (make-fd-stream tty :name "the Terminal" :input t :output t
1242     :buffering :line))
1243     (setf *tty* (make-two-way-stream *stdin* *stdout*))))
1244     nil)
1245    
1246    
1247     ;;;; Beeping.
1248    
1249     (defun default-beep-function (stream)
1250     (write-char #\bell stream)
1251     (finish-output stream))
1252    
1253     (defvar *beep-function* #'default-beep-function
1254     "This is called in BEEP to feep the user. It takes a stream.")
1255    
1256     (defun beep (&optional (stream *terminal-io*))
1257     (funcall *beep-function* stream))
1258    
1259    
1260     ;;;; File position and file length.
1261    
1262     ;;; File-Position -- Public
1263     ;;;
1264     ;;; Call the misc method with the :file-position operation.
1265     ;;;
1266     (defun file-position (stream &optional position)
1267     "With one argument returns the current position within the file
1268     File-Stream is open to. If the second argument is supplied, then
1269     this becomes the new file position. The second argument may also
1270     be :start or :end for the start and end of the file, respectively."
1271     (unless (streamp stream)
1272     (error "Argument ~S is not a stream." stream))
1273     (funcall (stream-misc stream) stream :file-position position))
1274    
1275     ;;; File-Length -- Public
1276     ;;;
1277     ;;; Like File-Position, only use :file-length.
1278     ;;;
1279     (defun file-length (stream)
1280     "This function returns the length of the file that File-Stream is open to."
1281     (unless (streamp stream)
1282     (error "Argument ~S is not a stream." stream))
1283     (funcall (stream-misc stream) stream :file-length))
1284    
1285     ;;; File-Name -- internal interface
1286     ;;;
1287     ;;; Kind of like File-Position, but is an internal hack used by the filesys
1288     ;;; stuff to get and set the file name.
1289     ;;;
1290     (defun file-name (stream &optional new-name)
1291     (when (fd-stream-p stream)
1292     (if new-name
1293     (setf (fd-stream-file stream) new-name)
1294     (fd-stream-file stream))))

  ViewVC Help
Powered by ViewVC 1.1.5