/[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.1 - (hide annotations)
Thu Feb 22 11:54:29 1990 UTC (24 years, 1 month ago) by ram
Branch: MAIN
Initial revision
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     (system:%primitive make-immediate-type
517     (system:%primitive 8bit-system-ref sap head)
518     ; XXX character-type, should be a constant.
519     27))
520    
521     ;;; INPUT-UNSIGNED-8BIT-BYTE -- internal
522     ;;;
523     ;;; Routine to read in an unsigned 8 bit number.
524     ;;;
525     (def-input-routine input-unsigned-8bit-byte
526     ((unsigned-byte 8) 1 sap head)
527     (system:%primitive 8bit-system-ref sap head))
528    
529     ;;; INPUT-SIGNED-8BIT-BYTE -- internal
530     ;;;
531     ;;; Routine to read in a signed 8 bit number.
532     ;;;
533     (def-input-routine input-signed-8bit-number
534     ((signed-byte 8) 1 sap head)
535     (let ((byte (system:%primitive 8bit-system-ref sap head)))
536     (if (logand byte #x80)
537     (- byte #x100)
538     byte)))
539    
540     ;;; INPUT-UNSIGNED-16BIT-BYTE -- internal
541     ;;;
542     ;;; Routine to read in an unsigned 16 bit number.
543     ;;;
544     (def-input-routine input-unsigned-16bit-byte
545     ((unsigned-byte 16) 2 sap head)
546     (system:%primitive 16bit-system-ref
547     sap
548     (/ head 2)))
549    
550     ;;; INPUT-SIGNED-16BIT-BYTE -- internal
551     ;;;
552     ;;; Routine to read in a signed 16 bit number.
553     ;;;
554     (def-input-routine input-signed-16bit-byte
555     ((signed-byte 16) 2 sap head)
556     (system:%primitive signed-16bit-system-ref
557     sap
558     (/ head 2)))
559    
560     ;;; INPUT-UNSIGNED-32BIT-BYTE -- internal
561     ;;;
562     ;;; Routine to read in a unsigned 32 bit number.
563     ;;;
564     (def-input-routine input-unsigned-32bit-byte
565     ((unsigned-byte 32) 4 sap head)
566     (system:%primitive unsigned-32bit-system-ref
567     sap
568     (/ head 2)))
569    
570     ;;; INPUT-SIGNED-32BIT-BYTE -- internal
571     ;;;
572     ;;; Routine to read in a signed 32 bit number.
573     ;;;
574     (def-input-routine input-signed-32bit-byte
575     ((signed-byte 32) 4 sap head)
576     (system:%primitive signed-32bit-system-ref
577     sap
578     (/ head 2)))
579    
580     ;;; PICK-INPUT-ROUTINE -- internal
581     ;;;
582     ;;; Find an input routine to use given the type. Return as multiple values
583     ;;; the routine, the real type transfered, and the number of bytes per element.
584     ;;;
585     (defun pick-input-routine (type)
586     (dolist (entry *input-routines*)
587     (when (subtypep type (car entry))
588     (return (values (symbol-function (cadr entry))
589     (car entry)
590     (caddr entry))))))
591    
592     ;;; STRING-FROM-SAP -- internal
593     ;;;
594     ;;; Returns a string constructed from the sap, start, and end.
595     ;;;
596     (defun string-from-sap (sap start end)
597     (let* ((length (- end start))
598     (string (make-string length)))
599     (byte-blt sap start string 0 length)
600     string))
601    
602     ;;; FD-STREAM-READ-LINE -- internal
603     ;;;
604     ;;; Reads a line, returning a simple string. Note: this relies on the fact
605     ;;; that the input buffer does not change during do-input.
606     ;;;
607     (defun fd-stream-read-line (stream eof-error-p eof-value)
608     (let ((eof t))
609     (values
610     (or (let ((sap (fd-stream-ibuf-sap stream))
611     (results (if (fd-stream-unread stream)
612     (prog1
613     (string (fd-stream-unread stream))
614     (setf (fd-stream-unread stream) nil)))))
615     (catch 'eof-input-catcher
616     (loop
617     (input-at-least stream 1)
618     (let* ((head (fd-stream-ibuf-head stream))
619     (tail (fd-stream-ibuf-tail stream))
620     (newline (system:%primitive find-character
621     sap
622     head
623     tail
624     #\Newline))
625     (end (or newline tail)))
626     (push (string-from-sap sap head end)
627     results)
628    
629     (when newline
630     (setf eof nil)
631     (setf (fd-stream-ibuf-head stream)
632     (1+ newline))
633     (return))
634     (setf (fd-stream-ibuf-head stream) end))))
635     (cond ((null results)
636     nil)
637     ((null (cdr results))
638     (car results))
639     (t
640     (apply #'concatenate 'simple-string (nreverse results)))))
641     (if eof-error-p
642     (error "EOF while reading ~S" stream)
643     eof-value))
644     eof)))
645    
646    
647     ;;; FD-STREAM-READ-N-BYTES -- internal
648     ;;;
649     ;;; The n-bin routine.
650     ;;;
651     (defun fd-stream-read-n-bytes (stream buffer start requested eof-error-p)
652     (let* ((sap (fd-stream-ibuf-sap stream))
653     (elsize (fd-stream-element-size stream))
654     (offset (* elsize start))
655     (bytes (* elsize requested))
656     (result (catch 'eof-input-catcher
657     (loop
658     (input-at-least stream 1)
659     (let* ((head (fd-stream-ibuf-head stream))
660     (tail (fd-stream-ibuf-tail stream))
661     (available (- tail head))
662     (copy (min available bytes)))
663     (byte-blt sap head buffer offset (+ offset copy))
664     (incf (fd-stream-ibuf-head stream) copy)
665     (incf offset copy)
666     (decf bytes copy))
667     (when (zerop bytes)
668     (return requested))))))
669     (cond (result)
670     ((not eof-error-p)
671     (- requested (/ bytes elsize)))
672     (t
673     (error "Hit eof on ~S after reading ~D ~D~2:*-bit byte~P~*, ~
674     but ~D~2:* ~D-bit byte~P~:* ~[were~;was~:;were~] requested."
675     stream
676     (- requested (/ bytes elsize))
677     (* elsize 8)
678     requested)))))
679    
680    
681     ;;;; Utility functions (misc routines, etc)
682    
683     ;;; SET-ROUTINES -- internal
684     ;;;
685     ;;; Fill in the various routine slots for the given type. Input-p and output-p
686     ;;; indicate what slots to fill. The buffering slot must be set prior to
687     ;;; calling this routine.
688     ;;;
689     (defun set-routines (stream type input-p output-p)
690     (let ((target-type (case type
691     ((:default unsigned-byte)
692     '(unsigned-byte 8))
693     (signed-byte
694     '(signed-byte 8))
695     (t
696     type)))
697     (input-type nil)
698     (output-type nil)
699     (input-size nil)
700     (output-size nil))
701    
702     (when (fd-stream-obuf stream)
703     (push (fd-stream-obuf stream) *available-buffers*)
704     (setf (fd-stream-obuf stream) nil))
705     (when (fd-stream-ibuf stream)
706     (push (fd-stream-ibuf stream) *available-buffers*)
707     (setf (fd-stream-ibuf stream) nil))
708    
709     (when input-p
710     (multiple-value-bind
711     (routine type size)
712     (pick-input-routine target-type)
713     (unless routine
714     (error "Could not find any input routine for ~S" target-type))
715     (setf (fd-stream-ibuf stream)
716     (next-available-buffer))
717     (setf (fd-stream-ibuf-sap stream)
718     (system:alien-sap (fd-stream-ibuf stream)))
719     (setf (fd-stream-ibuf-length stream)
720     (/ (system:alien-size (fd-stream-ibuf stream)) 8))
721     (setf (fd-stream-ibuf-tail stream)
722     0)
723     (if (subtypep type 'character)
724     (setf (fd-stream-in stream) routine
725     (fd-stream-bin stream) #'ill-bin
726     (fd-stream-n-bin stream) #'ill-bin)
727     (setf (fd-stream-in stream) #'ill-in
728     (fd-stream-bin stream) routine
729     (fd-stream-n-bin stream) #'fd-stream-read-n-bytes))
730     (setf input-size size)
731     (setf input-type type)))
732    
733     (when output-p
734     (multiple-value-bind
735     (routine type size)
736     (pick-output-routine target-type (fd-stream-buffering stream))
737     (unless routine
738     (error "Could not find any output routine for ~S buffered ~S."
739     (fd-stream-buffering stream)
740     target-type))
741     (setf (fd-stream-obuf stream) (next-available-buffer))
742     (setf (fd-stream-obuf-sap stream)
743     (system:alien-sap (fd-stream-obuf stream)))
744     (setf (fd-stream-obuf-length stream)
745     (/ (system:alien-size (fd-stream-obuf stream)) 8))
746     (setf (fd-stream-obuf-tail stream) 0)
747     (if (subtypep type 'character)
748     (setf (fd-stream-out stream) routine
749     (fd-stream-bout stream) #'ill-bout)
750     (setf (fd-stream-out stream)
751     (or (if (eql size 1)
752     (pick-output-routine 'string-char
753     (fd-stream-buffering stream)))
754     #'ill-out)
755     (fd-stream-bout stream) routine))
756     (setf (fd-stream-sout stream)
757     (if (eql size 1) #'fd-sout #'ill-out))
758     (setf (fd-stream-char-pos stream) 0)
759     (setf output-size size)
760     (setf output-type type)))
761    
762     (when (and input-size output-size
763     (not (eq input-size output-size)))
764     (error "Element sizes for input (~S:~S) and output (~S:~S) differ?"
765     input-type input-size
766     output-type output-size))
767     (setf (fd-stream-element-size stream)
768     (or input-size output-size))
769    
770     (setf (fd-stream-element-type stream)
771     (cond ((equal input-type output-type)
772     input-type)
773     ((subtypep input-type output-type)
774     input-type)
775     ((subtypep output-type input-type)
776     output-type)
777     (t
778     (error "Input type (~S) and output type (~S) are unrelated?"
779     input-type
780     output-type))))))
781    
782     ;;; FD-STREAM-MISC-ROUTINE -- input
783     ;;;
784     ;;; Handle the various misc operations on fd-stream.
785     ;;;
786     (defun fd-stream-misc-routine (stream operation &optional arg1 arg2)
787     (case operation
788     (:read-line
789     (fd-stream-read-line stream arg1 arg2))
790     (:listen
791     (or (not (eql (fd-stream-ibuf-head stream)
792     (fd-stream-ibuf-tail stream)))
793     (fd-stream-listen stream)
794     (setf (fd-stream-listen stream)
795     (not (zerop (mach:unix-select (1+ (fd-stream-fd stream))
796     (ash 1 (fd-stream-fd stream))
797     0
798     0
799     0))))))
800     (:unread
801     (setf (fd-stream-unread stream) arg1))
802     (:close
803     (cond (arg1
804     ;; We got us an abort on our hands.
805     (when (and (fd-stream-file stream)
806     (fd-stream-obuf stream))
807     ;; Can't do anything unless we know what file were dealing with,
808     ;; and we don't want to do anything strange unless we were
809     ;; writing to the file.
810     (if (fd-stream-original stream)
811     ;; Have an handle on the original, just revert.
812     (multiple-value-bind
813     (okay err)
814     (mach:unix-rename (fd-stream-original stream)
815     (fd-stream-file stream))
816     (unless okay
817     (cerror "Go on as if nothing bad happened."
818     "Could not restore ~S to it's original contents: ~A"
819     (fd-stream-file stream)
820     (mach:get-unix-error-msg err))))
821     ;; Can't restore the orignal, so nuke that puppy.
822     (multiple-value-bind
823     (okay err)
824     (mach:unix-unlink (fd-stream-file stream))
825     (unless okay
826     (cerror "Go on as if nothing bad happened."
827     "Could not remove ~S: ~A"
828     (fd-stream-file stream)
829     (mach:get-unix-error-msg err)))))))
830     (t
831     (fd-stream-misc-routine stream :finish-output)
832     (when (and (fd-stream-original stream)
833     (fd-stream-delete-original stream))
834     (multiple-value-bind
835     (okay err)
836     (mach:unix-unlink (fd-stream-original stream))
837     (unless okay
838     (cerror "Go on as if nothing bad happened."
839     "Could not delete ~S during close of ~S: ~A"
840     (fd-stream-original stream)
841     stream
842     (mach:get-unix-error-msg err)))))))
843     (mach:unix-close (fd-stream-fd stream))
844     (when (fd-stream-obuf stream)
845     (push (fd-stream-obuf stream) *available-buffers*)
846     (setf (fd-stream-obuf stream) nil))
847     (when (fd-stream-ibuf stream)
848     (push (fd-stream-ibuf stream) *available-buffers*)
849     (setf (fd-stream-ibuf stream) nil))
850     (lisp::set-closed-flame stream))
851     (:clear-input)
852     (:force-output
853     (flush-output-buffer stream))
854     (:finish-output
855     (flush-output-buffer stream)
856     (do ()
857     ((null (fd-stream-output-later stream)))
858     (system:serve-all-events)))
859     (:element-type
860     (fd-stream-element-type stream))
861     (:line-length
862     80)
863     (:charpos
864     (fd-stream-char-pos stream))
865     (:file-length
866     (multiple-value-bind
867     (okay dev ino mode nlink uid gid rdev size
868     atime mtime ctime blksize blocks)
869     (mach:unix-fstat (fd-stream-fd stream))
870     (declare (ignore ino nlink uid gid rdev
871     atime mtime ctime blksize blocks))
872     (unless okay
873     (error "Error fstating ~S: ~A"
874     stream
875     (mach:get-unix-error-msg dev)))
876     (if (zerop mode)
877     nil
878     (/ size (fd-stream-element-size stream)))))
879     (:file-position
880     (fd-stream-file-position stream arg1))
881     (:file-name
882     (fd-stream-file stream))))
883    
884     ;;; FD-STREAM-FILE-POSITION -- internal.
885     ;;;
886     (defun fd-stream-file-position (stream &optional newpos)
887     (if (null newpos)
888     (system:without-interrupts
889     ;; First, find the position of the UNIX file descriptor in the
890     ;; file.
891     (multiple-value-bind
892     (posn errno)
893     (mach:unix-lseek (fd-stream-fd stream) 0 mach:l_incr)
894     (cond ((numberp posn)
895     ;; Adjust for buffered output:
896     ;; If there is any output buffered, the *real* file position
897     ;; will be larger than reported by lseek because lseek
898     ;; obviously cannot take into account output we have not
899     ;; sent yet.
900     (dolist (later (fd-stream-output-later stream))
901     (incf posn (- (caddr later) (cadr later))))
902     (incf posn (fd-stream-obuf-tail stream))
903     ;; Adjust for unread input:
904     ;; If there is any input read from UNIX but not supplied to
905     ;; the user of the stream, the *real* file position will
906     ;; smaller than reported, because we want to look like the
907     ;; unread stuff is still available.
908     (decf posn (- (fd-stream-ibuf-tail stream)
909     (fd-stream-ibuf-head stream)))
910     (when (fd-stream-unread stream)
911     (decf posn))
912     ;; Divide bytes by element size.
913     (/ posn (fd-stream-element-size stream)))
914     ((eq errno mach:espipe)
915     nil)
916     (t
917     (system:with-interrupts
918     (error "Error lseek'ing ~S: ~A"
919     stream
920     (mach:get-unix-error-msg errno)))))))
921     (let (offset origin)
922     ;; Make sure we don't have any output pending, because if we move the
923     ;; file pointer before writing this stuff, it will be written in the
924     ;; wrong location.
925     (flush-output-buffer stream)
926     (do ()
927     ((null (fd-stream-output-later stream)))
928     (system:serve-all-events))
929     (cond ((eq newpos :start)
930     (setf offset 0 origin mach:l_set))
931     ((eq newpos :end)
932     (setf offset 0 origin mach:l_xtnd))
933     ((numberp newpos)
934     (setf offset (* newpos (fd-stream-element-size stream))
935     origin mach:l_set))
936     (t
937     (error "Invalid position given to file-position: ~S" newpos)))
938     (multiple-value-bind
939     (posn errno)
940     (mach:unix-lseek (fd-stream-fd stream) offset origin)
941     (cond ((numberp posn)
942     t)
943     ((eq errno mach:espipe)
944     nil)
945     (t
946     (error "Error lseek'ing ~S: ~A"
947     stream
948     (mach:get-unix-error-msg errno))))))))
949    
950    
951    
952     ;;;; Creation routines (MAKE-FD-STREAM and OPEN)
953    
954     ;;; MAKE-FD-STREAM -- Public.
955     ;;;
956     ;;; Returns a FD-STREAM on the given file.
957     ;;;
958     (defun make-fd-stream (fd
959     &key
960     (input nil input-p)
961     (output nil output-p)
962     (element-type 'string-char)
963     (buffering :full)
964     file
965     original
966     delete-original
967     (name (if file
968     (format nil "file ~S" file)
969     (format nil "descriptor ~D" fd))))
970     "Create a stream for the given unix file descriptor. If input is non-nil,
971     allow input operations. If output is non-nil, allow output operations. If
972     neither input nor output are specified, default to allowing input.
973     element-type indicates the element type to use (as for open). Buffering
974     indicates the kind of buffering to use (one of :none, :line, or :full). If
975     file is spesified, it should be the name of the file. Name is used to
976     identify the stream when printed."
977     (cond ((not (or input-p output-p))
978     (setf input t))
979     ((not (or input output))
980     (error "File descriptor must be opened either for input or output.")))
981     (let ((stream (%make-fd-stream :fd fd
982     :name name
983     :file file
984     :original original
985     :delete-original delete-original
986     :buffering buffering)))
987     (set-routines stream element-type input output)
988     stream))
989    
990     ;;; PICK-PACKUP-NAME -- internal
991     ;;;
992     ;;; Pick a name to use for the backup file.
993     ;;;
994     (defvar *backup-extension* ".BAK"
995     "This is a string that OPEN tacks on the end of a file namestring to produce
996     a name for the :if-exists :rename-and-delete and :rename options. Also,
997     this can be a function that takes a namestring and returns a complete
998     namestring.")
999     ;;;
1000     (defun pick-backup-name (name)
1001     (etypecase *backup-extension*
1002     (string (concatenate 'simple-string name *backup-extension*))
1003     (function (funcall *backup-extension* name))))
1004    
1005     ;;; ASSURE-ONE-OF -- internal
1006     ;;;
1007     ;;; Assure that the given arg is one of the given list of valid things.
1008     ;;; Allow the user to fix any problems.
1009     ;;;
1010     (defun assure-one-of (item list what)
1011     (unless (member item list)
1012     (loop
1013     (cerror "Enter new value for ~*~S"
1014     "~S is invalid for ~S. Must be one of~{ ~S~}"
1015     item
1016     what
1017     list)
1018     (format *query-io* "Enter new value for ~S: " what)
1019     (force-output *query-io*)
1020     (setf item (read *query-io*))
1021     (when (member item list)
1022     (return))))
1023     item)
1024    
1025     ;;; OPEN -- public
1026     ;;;
1027     ;;; Open the given file.
1028     ;;;
1029     (defun open (filename
1030     &key
1031     (direction :input)
1032     (element-type 'string-char)
1033     (if-exists nil if-exists-given)
1034     (if-does-not-exist nil if-does-not-exist-given))
1035     "Return a stream which reads from or writes to Filename.
1036     Defined keywords:
1037     :direction - one of :input, :output, :io, or :probe
1038     :element-type - Type of object to read or write, default STRING-CHAR
1039     :if-exists - one of :error, :new-version, :rename, :rename-and-delete,
1040     :overwrite, :append, :supersede or nil
1041     :if-does-not-exist - one of :error, :create or nil
1042     See the manual for details."
1043     ;; First, make sure that DIRECTION is valid. Allow it to be changed if not.
1044     (setf direction
1045     (assure-one-of direction
1046     '(:input :output :io :probe)
1047     :direction))
1048    
1049     ;; Calculate useful stuff.
1050     (multiple-value-bind
1051     (input output mask)
1052     (case direction
1053     (:input (values t nil mach:o_rdonly))
1054     (:output (values nil t mach:o_wronly))
1055     (:io (values t t mach:o_rdwr))
1056     (:probe (values nil nil mach:o_rdonly)))
1057     (let* ((pathname (pathname filename))
1058     (namestring (predict-name pathname input)))
1059    
1060     ;; Process if-exists argument if we are doing any output.
1061     (cond (output
1062     (unless if-exists-given
1063     (setf if-exists
1064     (if (eq (pathname-version pathname) :newest)
1065     :new-version
1066     :error)))
1067     (setf if-exists
1068     (assure-one-of if-exists
1069     '(:error :new-version :rename
1070     :rename-and-delete :overwrite
1071     :append :supersede nil)
1072     :if-exists))
1073     (case if-exists
1074     ((:error nil)
1075     (setf mask (logior mask mach:o_excl)))
1076     ((:rename :rename-and-delete)
1077     (setf mask (logior mask mach:o_creat)))
1078     ((:new-version :supersede)
1079     (setf mask (logior mask mach:o_trunc)))
1080     (:append
1081     (setf mask (logior mask mach:o_append)))))
1082     (t
1083     (setf if-exists :ignore-this-arg)))
1084    
1085     (unless if-does-not-exist-given
1086     (setf if-does-not-exist
1087     (cond ((eq direction :input) :error)
1088     ((and output
1089     (member if-exists '(:overwrite :append)))
1090     :error)
1091     ((eq direction :probe)
1092     nil)
1093     (t
1094     :create))))
1095     (setf if-does-not-exist
1096     (assure-one-of if-does-not-exist
1097     '(:error :create nil)
1098     :if-does-not-exist))
1099     (if (eq if-does-not-exist :create)
1100     (setf mask (logior mask mach:o_creat)))
1101    
1102     (let ((original (if (member if-exists
1103     '(:rename :rename-and-delete))
1104     (pick-backup-name namestring)))
1105     (delete-original (eq if-exists :rename-and-delete))
1106     (mode #o666))
1107     (when original
1108     ;; We are doing a :rename or :rename-and-delete.
1109     ;; Determine if the file already exists, make sure the original
1110     ;; file is not a directory and keep the mode
1111     (let ((exists
1112     (multiple-value-bind
1113     (okay err/dev inode orig-mode)
1114     (mach:unix-stat namestring)
1115     (declare (ignore inode))
1116     (cond (okay
1117     (when (and output (= (logand orig-mode #o170000)
1118     #o40000))
1119     (error "Cannot open ~S for output: Is a directory."
1120     namestring))
1121     (setf mode (logand orig-mode #o777))
1122     t)
1123     ((eql err/dev mach:enoent)
1124     nil)
1125     (t
1126     (error "Cannot find ~S: ~A"
1127     namestring
1128     (mach:get-unix-error-msg err/dev)))))))
1129     (when (or (not exists)
1130     ;; Do the rename.
1131     (multiple-value-bind
1132     (okay err)
1133     (mach:unix-rename namestring original)
1134     (unless okay
1135     (cerror "Use :SUPERSEDE instead."
1136     "Could not rename ~S to ~S: ~A."
1137     namestring
1138     original
1139     (mach:get-unix-error-msg err))
1140     t)))
1141     (setf original nil)
1142     (setf delete-original nil)
1143     ;; In order to use SUPERSEDE instead, we have
1144     ;; to make sure mach:o_creat corresponds to
1145     ;; if-does-not-exist. mach:o_creat was set
1146     ;; before because of if-exists being :rename.
1147     (unless (eq if-does-not-exist :create)
1148     (setf mask (logior (logandc2 mask mach:o_creat) mach:o_trunc)))
1149     (setf if-exists :supersede))))
1150    
1151     ;; Okay, now we can try the actual open.
1152     (multiple-value-bind
1153     (fd errno)
1154     (mach:unix-open namestring mask mode)
1155     (cond ((numberp fd)
1156     (case direction
1157     ((:input :output :io)
1158     (make-fd-stream fd
1159     :input input
1160     :output output
1161     :element-type element-type
1162     :file namestring
1163     :original original
1164     :delete-original delete-original))
1165     (:probe
1166     (let ((stream (%make-fd-stream :name namestring
1167     :fd fd
1168     :element-type element-type)))
1169     (close stream)
1170     stream))))
1171     ((eql errno mach:enoent)
1172     (case if-does-not-exist
1173     (:error
1174     (cerror "Return NIL."
1175     "Error opening ~S, ~A."
1176     pathname
1177     (mach:get-unix-error-msg errno)))
1178     (:create
1179     (cerror "Return NIL."
1180     "Error creating ~S, path does not exist."
1181     pathname)))
1182     nil)
1183     ((eql errno mach:eexist)
1184     (unless (eq nil if-exists)
1185     (cerror "Return NIL."
1186     "Error opening ~S, ~A."
1187     pathname
1188     (mach:get-unix-error-msg errno)))
1189     nil)
1190     (t
1191     (cerror "Return NIL."
1192     "Error opening ~S, ~A."
1193     pathname
1194     (mach:get-unix-error-msg errno))
1195     nil)))))))
1196    
1197     ;;;; Initialization.
1198    
1199     (defvar *tty* nil
1200     "The stream connected to the controlling terminal or NIL if there is none.")
1201     (defvar *stdin* nil
1202     "The stream connected to the standard input (file descriptor 0).")
1203     (defvar *stdout* nil
1204     "The stream connected to the standard output (file descriptor 1).")
1205     (defvar *stderr* nil
1206     "The stream connected to the standard error output (file descriptor 2).")
1207    
1208     ;;; STREAM-INIT -- internal interface
1209     ;;;
1210     ;;; Called when the cold load is first started up.
1211     ;;;
1212     (defun stream-init ()
1213     (stream-reinit)
1214     (setf *terminal-io* (make-synonym-stream '*tty*))
1215     (setf *standard-input* (make-synonym-stream '*stdin*))
1216     (setf *standard-output* (make-synonym-stream '*stdout*))
1217     (setf *error-output* (make-synonym-stream '*stderr*))
1218     (setf *query-io* (make-synonym-stream '*terminal-io*))
1219     (setf *debug-io* *query-io*)
1220     (setf *trace-output* *standard-output*)
1221     nil)
1222    
1223     ;;; STREAM-REINIT -- internal interface
1224     ;;;
1225     ;;; Called whenever a saved core is restarted.
1226     ;;;
1227     (defun stream-reinit ()
1228     (setf *available-buffers* nil)
1229     (setf *stdin*
1230     (make-fd-stream 0 :name "Standard Input" :input t :buffering :line))
1231     (setf *stdout*
1232     (make-fd-stream 1 :name "Standard Output" :output t :buffering :line))
1233     (setf *stderr*
1234     (make-fd-stream 2 :name "Standard Error" :output t :buffering :line))
1235     (let ((tty (mach:unix-open "/dev/tty" mach:o_rdwr #o666)))
1236     (if tty
1237     (setf *tty*
1238     (make-fd-stream tty :name "the Terminal" :input t :output t
1239     :buffering :line))
1240     (setf *tty* (make-two-way-stream *stdin* *stdout*))))
1241     nil)
1242    
1243    
1244     ;;;; Beeping.
1245    
1246     (defun default-beep-function (stream)
1247     (write-char #\bell stream)
1248     (finish-output stream))
1249    
1250     (defvar *beep-function* #'default-beep-function
1251     "This is called in BEEP to feep the user. It takes a stream.")
1252    
1253     (defun beep (&optional (stream *terminal-io*))
1254     (funcall *beep-function* stream))
1255    
1256    
1257     ;;;; File position and file length.
1258    
1259     ;;; File-Position -- Public
1260     ;;;
1261     ;;; Call the misc method with the :file-position operation.
1262     ;;;
1263     (defun file-position (stream &optional position)
1264     "With one argument returns the current position within the file
1265     File-Stream is open to. If the second argument is supplied, then
1266     this becomes the new file position. The second argument may also
1267     be :start or :end for the start and end of the file, respectively."
1268     (unless (streamp stream)
1269     (error "Argument ~S is not a stream." stream))
1270     (funcall (stream-misc stream) stream :file-position position))
1271    
1272     ;;; File-Length -- Public
1273     ;;;
1274     ;;; Like File-Position, only use :file-length.
1275     ;;;
1276     (defun file-length (stream)
1277     "This function returns the length of the file that File-Stream is open to."
1278     (unless (streamp stream)
1279     (error "Argument ~S is not a stream." stream))
1280     (funcall (stream-misc stream) stream :file-length))
1281    
1282     ;;; File-Name -- internal interface
1283     ;;;
1284     ;;; Kind of like File-Position, but is an internal hack used by the filesys
1285     ;;; stuff to get and set the file name.
1286     ;;;
1287     (defun file-name (stream &optional new-name)
1288     (when (fd-stream-p stream)
1289     (if new-name
1290     (setf (fd-stream-file stream) new-name)
1291     (fd-stream-file stream))))

  ViewVC Help
Powered by ViewVC 1.1.5