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

Contents of /src/code/stream.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.2 - (hide annotations)
Thu Feb 22 12:40:57 1990 UTC (24 years, 2 months ago) by ram
Branch: MAIN
Changes since 1.1: +10 -3 lines
.../systems-work/code/stream.lisp, 16-Jan-90 11:47:26, Edit by Wlott.
  Fixed bug in read-n-bytes: buffer was used where in-buffer should have been.

.../systems-work/code/stream.lisp, 23-Oct-89 16:45:49, Edit by Chiles.
  Picked up Chris's fix to make CLEAR-INPUT always return nil.

/usr1/lisp/ncode/stream.lisp, 25-Aug-89 11:46:56, Edit by Chiles.
  Added FILE-POSITION methods for string streams.
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     ;;; Stream functions for Spice Lisp.
11     ;;; Written by Skef Wholey and Rob MacLachlan.
12     ;;;
13     ;;; This file contains the machine-independent stream functions. Another
14     ;;; file (VAXIO, SPIO, or VMIO) contains functions used by this file for
15     ;;; a specific machine.
16     ;;;
17 ram 1.2 (in-package "LISP")
18 ram 1.1
19     (export '(make-broadcast-stream make-synonym-stream
20     make-broadcast-stream make-concatenated-stream make-two-way-stream
21     make-echo-stream make-string-input-stream make-string-output-stream
22     get-output-stream-string stream-element-type input-stream-p
23     output-stream-p close read-line read-char
24     unread-char peek-char listen read-char-no-hang clear-input read-byte
25     write-char write-string write-line terpri fresh-line
26     finish-output force-output clear-output write-byte
27     stream streamp *standard-input* *standard-output*
28     *error-output* *query-io* *debug-io* *terminal-io* *trace-output*))
29    
30     (in-package 'system)
31     (export '(make-indenting-stream read-n-bytes))
32     (in-package 'lisp)
33    
34     ;;;; Standard streams:
35     ;;;
36     ;;; The initialization of these streams is performed by Stream-Init,
37     ;;; which lives in the file of machine-specific stream functions.
38     ;;;
39     (defvar *terminal-io* () "Terminal I/O stream.")
40     (defvar *standard-input* () "Default input stream.")
41     (defvar *standard-output* () "Default output stream.")
42     (defvar *error-output* () "Error output stream.")
43     (defvar *query-io* () "Query I/O stream.")
44     (defvar *trace-output* () "Trace output stream.")
45     (defvar *debug-io* () "Interactive debugging stream.")
46    
47     (defun ill-in (stream &rest ignore)
48     (declare (ignore ignore))
49     (error "~S is not a character input stream." stream))
50     (defun ill-out (stream &rest ignore)
51     (declare (ignore ignore))
52     (error "~S is not a character output stream." stream))
53     (defun ill-bin (stream &rest ignore)
54     (declare (ignore ignore))
55     (error "~S is not a binary input stream." stream))
56     (defun ill-bout (stream &rest ignore)
57     (declare (ignore ignore))
58     (error "~S is not a binary output stream." stream))
59     (defun closed-flame (stream &rest ignore)
60     (declare (ignore ignore))
61     (error "~S is closed." stream))
62     (defun do-nothing (&rest ignore)
63     (declare (ignore ignore)))
64    
65     (defun %print-stream (structure stream d)
66     (declare (ignore d structure))
67     (write-string "#<Bare Stream>" stream))
68    
69     ;;; HOW THE STREAM STRUCTURE IS USED:
70     ;;;
71     ;;; Many of the slots of the stream structure contain functions
72     ;;; which are called to perform some operation on the stream. Closed
73     ;;; streams have #'Closed-Flame in all of their function slots. If
74     ;;; one side of an I/O or echo stream is closed, the whole stream is
75     ;;; considered closed. The functions in the operation slots take
76     ;;; arguments as follows:
77     ;;;
78     ;;; In: Stream, Eof-Errorp, Eof-Value
79     ;;; Bin: Stream, Eof-Errorp, Eof-Value
80     ;;; N-Bin: Stream, Buffer, Start, Numbytes, Eof-Errorp
81     ;;; Out: Stream, Character
82     ;;; Bout: Stream, Integer
83     ;;; Sout: Stream, String, Start, End
84     ;;; Misc: Stream, Operation, &Optional Arg1, Arg2
85     ;;;
86     ;;; In order to save space, some of the less common stream operations
87     ;;; are handled by just one function, the Misc method. This function
88     ;;; is passed a keyword which indicates the operation to perform.
89     ;;; The following keywords are used:
90     ;;; :read-line - Do a read-line.
91     ;;; :listen - Return true if any input waiting.
92     ;;; :unread - Unread the character Arg.
93     ;;; :close - Do any stream specific stuff to close the stream.
94     ;;; The methods are set to closed-flame by the close
95     ;;; function, so that need not be done by this
96     ;;; function.
97     ;;; :clear-input - Clear any unread input
98     ;;; :finish-output,
99     ;;; :force-output - Cause output to happen
100     ;;; :clear-output - Clear any undone output
101     ;;; :element-type - Return the type of element the stream deals with.
102     ;;; :line-length - Return the length of a line of output.
103     ;;; :charpos - Return current output position on the line.
104     ;;; :file-length - Return the file length of a file stream.
105     ;;; :file-position - Return or change the current position of a file stream.
106     ;;; :file-name - Return the name of an associated file.
107     ;;;
108     ;;; In order to do almost anything useful, it is necessary to
109     ;;; define a new type of structure that includes stream, so that the
110     ;;; stream can have some state information.
111     ;;;
112     ;;; THE STREAM IN-BUFFER:
113     ;;;
114     ;;; The In-Buffer in the stream holds characters or bytes that
115     ;;; are ready to be read by some input function. If there is any
116     ;;; stuff in the In-Buffer, then the reading function can use it
117     ;;; without calling any stream method. Any stream may put stuff in
118     ;;; the In-Buffer, and may also assume that any input in the In-Buffer
119     ;;; has been consumed before any in-method is called. If a text
120     ;;; stream has in In-Buffer, then the first character should not be
121     ;;; used to buffer normal input so that it is free for unreading into.
122     ;;;
123     ;;; The In-Buffer slot is a vector In-Buffer-Length long. The
124     ;;; In-Index is the index in the In-Buffer of the first available
125     ;;; object. The available objects are thus between In-Index and the
126     ;;; length of the In-Buffer.
127     ;;;
128     ;;; When this buffer is only accessed by the normal stream
129     ;;; functions, the number of function calls is halved, thus
130     ;;; potentially doubling the speed of simple operations. If the
131     ;;; Fast-Read-Char and Fast-Read-Byte macros are used, nearly all
132     ;;; function call overhead is removed, vastly speeding up these
133     ;;; important operations.
134     ;;;
135     ;;; If a stream does not have an In-Buffer, then the In-Buffer slot
136     ;;; must be nil, and the In-Index must be In-Buffer-Length. These are
137     ;;; the default values for the slots.
138    
139     ;;; Stream manipulation functions.
140    
141     (defun input-stream-p (stream)
142     "Returns non-nil if the given Stream can perform input operations."
143     (and (streamp stream)
144     (not (eq (stream-in stream) #'closed-flame))
145     (or (not (eq (stream-in stream) #'ill-in))
146     (not (eq (stream-bin stream) #'ill-bin)))))
147    
148     (defun output-stream-p (stream)
149     "Returns non-nil if the given Stream can perform output operations."
150     (and (streamp stream)
151     (not (eq (stream-in stream) #'closed-flame))
152     (or (not (eq (stream-out stream) #'ill-out))
153     (not (eq (stream-bout stream) #'ill-bout)))))
154    
155     (defun stream-element-type (stream)
156     "Returns a type specifier for the kind of object returned by the Stream."
157     (if (streamp stream)
158     (funcall (stream-misc stream) stream :element-type)
159     (error "~S is not a stream." stream)))
160    
161     (defun close (stream &key abort)
162     "Closes the given Stream. No more I/O may be performed, but inquiries
163     may still be made. If :Abort is non-nil, an attempt is made to clean
164     up the side effects of having created the stream."
165     (if (streamp stream)
166     (unless (eq (stream-in stream) #'closed-flame)
167     (funcall (stream-misc stream) stream :close abort))
168     (error "~S is not a stream." stream))
169     t)
170    
171     (defun set-closed-flame (stream)
172     (setf (stream-in stream) #'closed-flame)
173     (setf (stream-bin stream) #'closed-flame)
174     (setf (stream-n-bin stream) #'closed-flame)
175     (setf (stream-in stream) #'closed-flame)
176     (setf (stream-out stream) #'closed-flame)
177     (setf (stream-bout stream) #'closed-flame)
178     (setf (stream-sout stream) #'closed-flame)
179     (setf (stream-misc stream) #'closed-flame))
180    
181     ;;; Input functions:
182    
183     (defun read-line (&optional (stream *standard-input*) (eof-errorp t) eof-value
184     recursive-p)
185     "Returns a line of text read from the Stream as a string, discarding the
186     newline character."
187     (declare (ignore recursive-p))
188     (let* ((stream (in-synonym-of stream))
189     (buffer (stream-in-buffer stream))
190     (index (stream-in-index stream)))
191     (declare (fixnum index))
192     (if (simple-string-p buffer)
193     (let ((nl (%primitive find-character buffer index in-buffer-length
194     #\newline)))
195     (if nl
196     (values (prog1 (subseq (the simple-string buffer) index nl)
197     (setf (stream-in-index stream) (1+ (the fixnum nl))))
198     nil)
199     (multiple-value-bind (str eofp)
200     (funcall (stream-misc stream) stream
201     :read-line eof-errorp eof-value)
202     (declare (simple-string str))
203     (if (= index in-buffer-length)
204     (values str eofp)
205     (values (prog1
206     (concatenate 'simple-string
207     (subseq buffer index in-buffer-length)
208     str)
209     (setf (stream-in-index stream) in-buffer-length))
210     eofp)))))
211     (funcall (stream-misc stream) stream :read-line eof-errorp eof-value))))
212    
213     ;;; We proclaim them inline here, then proclaim them notinline at EOF,
214     ;;; so, except in this file, they are not inline by default, but they can be.
215     ;;;
216     (proclaim '(inline read-char unread-char read-byte listen))
217     (defun read-char (&optional (stream *standard-input*) (eof-errorp t) eof-value
218     recursive-p)
219     "Inputs a character from Stream and returns it."
220     (declare (ignore recursive-p))
221     (let* ((stream (in-synonym-of stream))
222     (index (stream-in-index stream)))
223     (declare (fixnum index))
224     (if (eql index in-buffer-length)
225     (funcall (stream-in stream) stream eof-errorp eof-value)
226     (prog1 (aref (stream-in-buffer stream) index)
227     (setf (stream-in-index stream) (1+ index))))))
228    
229     (defun unread-char (character &optional (stream *standard-input*))
230     "Puts the Character back on the front of the input Stream."
231     (let* ((stream (in-synonym-of stream))
232     (index (1- (the fixnum (stream-in-index stream))))
233     (buffer (stream-in-buffer stream)))
234     (declare (fixnum index))
235     (when (minusp index) (error "Nothing to unread."))
236     (if buffer
237     (setf (aref (the simple-array buffer) index) character
238     (stream-in-index stream) index)
239     (funcall (stream-misc stream) stream :unread character)))
240     nil)
241    
242     (defun peek-char (&optional (peek-type nil) (stream *standard-input*)
243     (eof-errorp t) eof-value recursive-p)
244     "Peeks at the next character in the input Stream. See manual for details."
245     (declare (ignore recursive-p))
246     (let* ((stream (in-synonym-of stream))
247     (char (read-char stream eof-errorp eof-value)))
248     (cond ((eq char eof-value) char)
249     ((characterp peek-type)
250     (do ((char char (read-char stream eof-errorp eof-value)))
251     ((or (eq char eof-value) (char= char peek-type))
252     (unless (eq char eof-value)
253     (unread-char char stream))
254     char)))
255     ((eq peek-type t)
256     (do ((char char (read-char stream eof-errorp eof-value)))
257     ((or (eq char eof-value) (not (whitespace-char-p char)))
258     (unless (eq char eof-value)
259     (unread-char char stream))
260     char)))
261     (t
262     (unread-char char stream)
263     char))))
264    
265     (defun listen (&optional (stream *standard-input*))
266     "Returns T if a character is availible on the given Stream."
267     (let ((stream (in-synonym-of stream)))
268     (or (/= (the fixnum (stream-in-index stream)) in-buffer-length)
269     (funcall (stream-misc stream) stream :listen))))
270    
271     (defun read-char-no-hang (&optional (stream *standard-input*)
272     (eof-errorp t) eof-value recursive-p)
273     "Returns the next character from the Stream if one is availible, or nil."
274     (declare (ignore recursive-p))
275     (if (listen stream) (read-char stream eof-errorp eof-value) nil))
276    
277     (defun clear-input (&optional (stream *standard-input*))
278     "Clears any buffered input associated with the Stream."
279     (let ((stream (in-synonym-of stream)))
280     (setf (stream-in-index stream) in-buffer-length)
281 ram 1.2 (funcall (stream-misc stream) stream :clear-input)
282     nil))
283 ram 1.1
284     (defun read-byte (stream &optional (eof-errorp t) eof-value)
285     "Returns the next byte of the Stream."
286     (let* ((stream (in-synonym-of stream))
287     (index (stream-in-index stream)))
288     (declare (fixnum index))
289     (if (eql index in-buffer-length)
290     (funcall (stream-bin stream) stream eof-errorp eof-value)
291     (prog1 (aref (stream-in-buffer stream) index)
292     (setf (stream-in-index stream) (1+ index))))))
293    
294     (defun read-n-bytes (stream buffer start numbytes &optional (eof-errorp t))
295     "Reads Numbytes bytes into the Buffer starting at Start, and returns
296     the number of bytes actually read if the end of file was hit before Numbytes
297     bytes were read (and Eof-Errorp is false)."
298     (declare (fixnum numbytes))
299     (let* ((stream (in-synonym-of stream))
300     (in-buffer (stream-in-buffer stream))
301     (index (stream-in-index stream))
302     (num-buffered (- in-buffer-length index)))
303     (declare (fixnum index num-buffered))
304     (cond
305 ram 1.2 ((not in-buffer)
306 ram 1.1 (with-in-stream stream stream-n-bin buffer start numbytes eof-errorp))
307     ((not (eql (%primitive get-vector-access-code in-buffer) 3))
308     (error "N-Bin only works on 8-bit-like streams."))
309     ((<= numbytes num-buffered)
310     (%primitive byte-blt in-buffer index buffer start (+ start numbytes))
311     (setf (stream-in-index stream) (+ index numbytes))
312     numbytes)
313     (t
314     (let ((end (+ start num-buffered)))
315     (%primitive byte-blt in-buffer index buffer start end)
316     (setf (stream-in-index stream) in-buffer-length)
317     (+ (with-in-stream stream stream-n-bin buffer end
318     (- numbytes num-buffered)
319     eof-errorp)
320     num-buffered))))))
321    
322     ;;; Output functions:
323    
324     (defun write-char (character &optional (stream *standard-output*))
325     "Outputs the Character to the Stream."
326     (with-out-stream stream stream-out character)
327     character)
328    
329     (defun terpri (&optional (stream *standard-output*))
330     "Outputs a new line to the Stream."
331     (with-out-stream stream stream-out #\newline)
332     nil)
333    
334     (defun fresh-line (&optional (stream *standard-output*))
335     "Outputs a new line to the Stream if it is not positioned at the begining of
336     a line. Returns T if it output a new line, nil otherwise."
337     (let ((stream (out-synonym-of stream)))
338     (when (/= (or (charpos stream) 1) 0)
339     (funcall (stream-out stream) stream #\newline)
340     t)))
341    
342     (defun write-string (string &optional (stream *standard-output*)
343     &key (start 0) (end (length (the vector string))))
344     "Outputs the String to the given Stream."
345     (write-string* string stream start end))
346    
347     (defun write-string* (string &optional (stream *standard-output*)
348     (start 0) (end (length (the vector string))))
349     (declare (fixnum start end))
350     (if (array-header-p string)
351     (with-array-data ((data string) (offset-start start) (offset-end end))
352     (with-out-stream stream stream-sout data offset-start offset-end))
353     (with-out-stream stream stream-sout string start end))
354     string)
355    
356     (defun write-line (string &optional (stream *standard-output*)
357     &key (start 0) (end (length string)))
358     "Outputs the String to the given Stream, followed by a newline character."
359     (write-line* string stream start end))
360    
361     (defun write-line* (string &optional (stream *standard-output*)
362     (start 0) (end (length string)))
363     (declare (fixnum start end))
364     (let ((stream (out-synonym-of stream)))
365     (if (array-header-p string)
366     (with-array-data ((data string) (offset-start start) (offset-end end))
367     (with-out-stream stream stream-sout data offset-start offset-end))
368     (with-out-stream stream stream-sout string start end))
369     (funcall (stream-out stream) stream #\newline))
370     string)
371    
372     (defun charpos (&optional (stream *standard-output*))
373     "Returns the number of characters on the current line of output of the given
374     Stream, or Nil if that information is not availible."
375     (with-out-stream stream stream-misc :charpos))
376    
377     (defun line-length (&optional (stream *standard-output*))
378     "Returns the number of characters that will fit on a line of output on the
379     given Stream, or Nil if that information is not available."
380     (with-out-stream stream stream-misc :line-length))
381    
382     (defun finish-output (&optional (stream *standard-output*))
383     "Attempts to ensure that all output sent to the the Stream has reached its
384     destination, and only then returns."
385     (with-out-stream stream stream-misc :finish-output)
386     nil)
387    
388     (defun force-output (&optional (stream *standard-output*))
389     "Attempts to force any buffered output to be sent."
390     (with-out-stream stream stream-misc :force-output)
391     nil)
392    
393     (defun clear-output (&optional (stream *standard-output*))
394     "Clears the given output Stream."
395     (with-out-stream stream stream-misc :clear-output)
396     nil)
397    
398     (defun write-byte (integer stream)
399     "Outputs the Integer to the binary Stream."
400     (with-out-stream stream stream-bout integer)
401     integer)
402    
403     ;;;; Broadcast streams:
404    
405     (defstruct (broadcast-stream (:include stream
406     (out #'broadcast-out)
407     (bout #'broadcast-bout)
408     (sout #'broadcast-sout)
409     (misc #'broadcast-misc))
410     (:print-function %print-broadcast-stream)
411     (:constructor make-broadcast-stream (&rest streams)))
412     ;; This is a list of all the streams we broadcast to.
413     streams)
414    
415     (setf (documentation 'make-broadcast-stream 'function)
416     "Returns an ouput stream which sends its output to all of the given streams.")
417    
418     (defun %print-broadcast-stream (s stream d)
419     (declare (ignore s d))
420     (write-string "#<Broadcast Stream>" stream))
421    
422     (macrolet ((out-fun (fun method &rest args)
423     `(defun ,fun (stream ,@args)
424     (dolist (stream (broadcast-stream-streams stream))
425     (funcall (,method stream) stream ,@args)))))
426     (out-fun broadcast-out stream-out char)
427     (out-fun broadcast-bout stream-bout byte)
428     (out-fun broadcast-sout stream-sout string start end))
429    
430     (defun broadcast-misc (stream operation &optional arg1 arg2)
431     (let ((streams (broadcast-stream-streams stream)))
432     (case operation
433     (:charpos
434     (dolist (stream streams)
435     (let ((charpos (funcall (stream-misc stream) stream :charpos)))
436     (if charpos (return charpos)))))
437     (:line-length
438     (let ((min nil))
439     (dolist (stream streams min)
440     (let ((res (funcall (stream-misc stream) stream :line-length)))
441     (when res (setq min (if min (min res min) res)))))))
442     (:element-type
443     (let (res)
444     (dolist (stream streams (if (> (length res) 1) `(and ,@res) res))
445     (pushnew (funcall (stream-misc stream) stream :element-type) res
446     :test #'equal))))
447     (t
448     (let ((res nil))
449     (dolist (stream streams res)
450     (setq res (funcall (stream-misc stream) stream operation
451     arg1 arg2))))))))
452    
453     ;;;; Synonym Streams:
454    
455     (defstruct (synonym-stream (:include stream
456     (in #'synonym-in)
457     (bin #'synonym-bin)
458     (n-bin #'synonym-n-bin)
459     (out #'synonym-out)
460     (bout #'synonym-bout)
461     (sout #'synonym-sout)
462     (misc #'synonym-misc))
463     (:print-function %print-synonym-stream)
464     (:constructor make-synonym-stream (symbol)))
465     ;; This is the symbol, the value of which is the stream we are synonym to.
466     symbol)
467    
468     (defun %print-synonym-stream (s stream d)
469     (declare (ignore d))
470     (format stream "#<Synonym Stream to ~S>" (synonym-stream-symbol s)))
471    
472     (setf (documentation 'make-synonym-stream 'function)
473     "Returns a stream which performs its operations on the stream which is the
474     value of the dynamic variable named by Symbol.")
475    
476     ;;; The output simple output methods just call the corresponding method
477     ;;; in the synonymed stream.
478     ;;;
479     (macrolet ((out-fun (name slot &rest args)
480     `(defun ,name (stream ,@args)
481     (let ((syn (symbol-value (synonym-stream-symbol stream))))
482     (funcall (,slot syn) syn ,@args)))))
483     (out-fun synonym-out stream-out ch)
484     (out-fun synonym-bout stream-bout n)
485     (out-fun synonym-sout stream-sout string start end))
486    
487    
488     ;;; Bind synonym stream to this so that SPIO can turn on the right frob in
489     ;;; the icon when we are in a terminal input wait.
490     ;;;
491     (defvar *previous-stream* nil)
492    
493     ;;; For the input methods, we just call the corresponding function on the
494     ;;; synonymed stream. These functions deal with getting input out of
495     ;;; the In-Buffer if there is any.
496     ;;;
497     (macrolet ((in-fun (name fun &rest args)
498     `(defun ,name (stream ,@args)
499     (let ((*previous-stream* stream))
500     (,fun (symbol-value (synonym-stream-symbol stream)) ,@args)))))
501     (in-fun synonym-in read-char eof-errorp eof-value)
502     (in-fun synonym-bin read-byte eof-errorp eof-value)
503     (in-fun synonym-n-bin read-n-bytes buffer start numbytes eof-errorp))
504    
505    
506     ;;; Synonym-Misc -- Internal
507     ;;;
508     ;;; We have to special-case the operations which could look at stuff in
509     ;;; the in-buffer.
510     ;;;
511     (defun synonym-misc (stream operation &optional arg1 arg2)
512     (let ((syn (symbol-value (synonym-stream-symbol stream)))
513     (*previous-stream* stream))
514     (case operation
515     (:read-line (read-line syn))
516     (:listen (or (/= (the fixnum (stream-in-index syn)) in-buffer-length)
517     (funcall (stream-misc syn) syn :listen)))
518     (t
519     (funcall (stream-misc syn) syn operation arg1 arg2)))))
520    
521     ;;;; Two-Way streams:
522    
523     (defstruct (two-way-stream
524     (:include stream
525     (in #'two-way-in)
526     (bin #'two-way-bin)
527     (n-bin #'two-way-n-bin)
528     (out #'two-way-out)
529     (bout #'two-way-bout)
530     (sout #'two-way-sout)
531     (misc #'two-way-misc))
532     (:print-function %print-two-way-stream)
533     (:constructor make-two-way-stream (input-stream output-stream)))
534     ;; We read from this stream...
535     input-stream
536     ;; And write to this one
537     output-stream)
538    
539     (defun %print-two-way-stream (s stream d)
540     (declare (ignore d))
541     (format stream "#<Two-Way Stream, Input = ~S, Output = ~S>"
542     (two-way-stream-input-stream s)
543     (two-way-stream-output-stream s)))
544    
545     (setf (documentation 'make-two-way-stream 'function)
546     "Returns a bidirectional stream which gets its input from Input-Stream and
547     sends its output to Output-Stream.")
548    
549     (macrolet ((out-fun (name slot &rest args)
550     `(defun ,name (stream ,@args)
551     (let ((syn (two-way-stream-output-stream stream)))
552     (funcall (,slot syn) syn ,@args)))))
553     (out-fun two-way-out stream-out ch)
554     (out-fun two-way-bout stream-bout n)
555     (out-fun two-way-sout stream-sout string start end))
556    
557     (macrolet ((in-fun (name fun &rest args)
558     `(defun ,name (stream ,@args)
559     (,fun (two-way-stream-input-stream stream) ,@args))))
560     (in-fun two-way-in read-char eof-errorp eof-value)
561     (in-fun two-way-bin read-byte eof-errorp eof-value)
562     (in-fun two-way-n-bin read-n-bytes buffer start numbytes eof-errorp))
563    
564     (defun two-way-misc (stream operation &optional arg1 arg2)
565     (let* ((in (two-way-stream-input-stream stream))
566     (in-method (stream-misc in))
567     (out (two-way-stream-output-stream stream))
568     (out-method (stream-misc out)))
569     (case operation
570     (:listen (or (/= (the fixnum (stream-in-index in)) in-buffer-length)
571     (funcall in-method in :listen)))
572     (:read-line (read-line in arg1 arg2))
573     ((:finish-output :force-output :clear-output)
574     (funcall out-method out operation arg1 arg2))
575     ((:clear-input :unread)
576     (funcall in-method in operation arg1 arg2))
577     (:element-type
578     (let ((in-type (funcall in-method in :element-type))
579     (out-type (funcall out-method out :element-type)))
580     (if (equal in-type out-type)
581     in-type `(and ,in-type ,out-type))))
582     (:close
583     (funcall in-method in :close arg1)
584     (funcall out-method out :close arg1)
585     (set-closed-flame stream))
586     (t
587     (or (funcall in-method in operation arg1 arg2)
588     (funcall out-method out operation arg1 arg2))))))
589    
590     ;;;; Concatenated Streams:
591    
592     (defstruct (concatenated-stream
593     (:include stream
594     (in #'concatenated-in)
595     (bin #'concatenated-bin)
596     (misc #'concatenated-misc))
597     (:print-function %print-concatenated-stream)
598     (:constructor
599     make-concatenated-stream (&rest streams &aux (current streams))))
600     ;; The car of this is the stream we are reading from now.
601     current
602     ;; This is a list of all the streams. We need to remember them so that
603     ;; we can close them.
604     streams)
605    
606     (defun %print-concatenated-stream (s stream d)
607     (declare (ignore d))
608     (format stream "#<Concatenated Stream, Streams = ~S>"
609     (concatenated-stream-streams s)))
610    
611     (setf (documentation 'make-concatenated-stream 'function)
612     "Returns a stream which takes its input from each of the Streams in turn,
613     going on to the next at EOF.")
614    
615     (macrolet ((in-fun (name fun)
616     `(defun ,name (stream eof-errorp eof-value)
617     (do ((current (concatenated-stream-current stream) (cdr current)))
618     ((null current)
619     (eof-or-lose stream eof-errorp eof-value))
620     (let* ((stream (car current))
621     (result (,fun stream nil nil)))
622     (when result (return result)))
623     (setf (concatenated-stream-current stream) current)))))
624     (in-fun concatenated-in read-char)
625     (in-fun concatenated-bin read-byte))
626    
627     ;;; Concatenated-Readline is somewhat hairy, since we may need to
628     ;;; do several readlines and concatenate the result if the lines are
629     ;;; terminated by eof.
630     ;;;
631     (defun concatenated-readline (stream eof-errorp eof-value)
632     ;; Loop until we find a stream that will give us something or we error
633     ;; out.
634     (do ((current (concatenated-stream-current stream) (cdr current)))
635     ((null current)
636     (eof-or-lose stream eof-errorp eof-value))
637     (setf (concatenated-stream-current stream) current)
638     (let ((this (car current)))
639     (multiple-value-bind (result eofp)
640     (read-line this nil nil)
641     (declare (simple-string result))
642     ;; Once we have found some input, we loop until we either find a
643     ;; line not terminated by eof or hit eof on the last stream.
644     (when result
645     (do ((current (cdr current) (cdr current))
646     (new ""))
647     ((or (not eofp) (null current))
648     (return-from concatenated-readline (values result eofp)))
649     (declare (simple-string new))
650     (setf (concatenated-stream-current stream) current)
651     (let ((this (car current)))
652     (multiple-value-setq (new eofp)
653     (read-line this nil nil))
654     (if new
655     (setq result (concatenate 'simple-string result new))
656     (setq eofp t)))))))))
657    
658     (defun concatenated-misc (stream operation &optional arg1 arg2)
659     (if (eq operation :read-line)
660     (concatenated-readline stream arg1 arg2)
661     (let ((left (concatenated-stream-current stream)))
662     (when left
663     (let* ((current (car left))
664     (misc (stream-misc current)))
665     (case operation
666     (:listen (or (/= (the fixnum (stream-in-index current)) in-buffer-length)
667     (funcall misc current :listen)))
668     (:close
669     (dolist (stream (concatenated-stream-streams stream))
670     (funcall (stream-misc stream) stream :close arg1))
671     (set-closed-flame stream))
672     (t
673     (funcall misc current operation arg1 arg2))))))))
674    
675     ;;;; Echo Streams:
676    
677     (defstruct (echo-stream
678     (:include two-way-stream
679     (in #'echo-in)
680     (bin #'echo-bin)
681     (misc #'echo-misc)
682     (n-bin #'ill-bin))
683     (:print-function %print-echo-stream)
684     (:constructor make-echo-stream (input-stream output-stream))))
685    
686    
687     (macrolet ((in-fun (name fun out-slot &rest args)
688     `(defun ,name (stream ,@args)
689     (let* ((in (two-way-stream-input-stream stream))
690     (out (two-way-stream-output-stream stream))
691     (result (,fun in ,@args)))
692     (funcall (,out-slot out) out result)
693     result))))
694     (in-fun echo-in read-char stream-out eof-errorp eof-value)
695     (in-fun echo-bin read-byte stream-bout eof-errorp eof-value))
696    
697     (defun echo-misc (stream operation &optional arg1 arg2)
698     (let* ((in (two-way-stream-input-stream stream))
699     (in-method (stream-misc in))
700     (out (two-way-stream-output-stream stream))
701     (out-method (stream-misc out)))
702     (case operation
703     (:listen (or (/= (the fixnum (stream-in-index in)) in-buffer-length)
704     (funcall in-method in :listen)))
705     (:read-line
706     (multiple-value-bind (result eofp)
707     (read-line in arg1 arg2)
708     (if eofp
709     (write-string result out)
710     (write-line result out))
711     (values result eofp)))
712     (:element-type
713     (let ((in-type (funcall in-method in :element-type))
714     (out-type (funcall out-method out :element-type)))
715     (if (equal in-type out-type)
716     in-type `(and ,in-type ,out-type))))
717     (:close
718     (funcall in-method in :close arg1)
719     (funcall out-method out :close arg1)
720     (set-closed-flame stream))
721     (t
722     (or (funcall in-method in operation arg1 arg2)
723     (funcall out-method out operation arg1 arg2))))))
724    
725     (defun %print-echo-stream (s stream d)
726     (declare (ignore d))
727     (format stream "#<Echo Stream, Input = ~S, Output = ~S>"
728     (two-way-stream-input-stream s)
729     (two-way-stream-output-stream s)))
730    
731     (setf (documentation 'make-echo-stream 'function)
732     "Returns a bidirectional stream which gets its input from Input-Stream and
733     sends its output to Output-Stream. In addition, all input is echoed to
734     the output stream")
735    
736     ;;;; String Input Streams:
737    
738     (defstruct (string-input-stream
739     (:include stream
740     (in #'string-inch)
741     (misc #'string-in-misc))
742     (:print-function %print-string-input-stream)
743     (:constructor nil)
744     (:constructor internal-make-string-input-stream
745     (string current end)))
746     (string nil :type simple-string)
747     (current nil :type fixnum)
748     (end nil :type fixnum))
749    
750     (defun %print-string-input-stream (s stream d)
751     (declare (ignore s d))
752     (write-string "#<String-Input Stream>" stream))
753    
754     (defun string-inch (stream eof-errorp eof-value)
755     (let ((string (string-input-stream-string stream))
756     (index (string-input-stream-current stream)))
757     (declare (simple-string string) (fixnum index))
758     (cond ((= index (the fixnum (string-input-stream-end stream)))
759     (eof-or-lose stream eof-errorp eof-value))
760     (t
761     (setf (string-input-stream-current stream) (1+ index))
762     (aref string index)))))
763    
764     (defun string-in-misc (stream operation &optional arg1 arg2)
765     (case operation
766 ram 1.2 (:file-position
767     (if (null arg1)
768     (string-input-stream-current stream)))
769 ram 1.1 (:read-line
770     (let ((string (string-input-stream-string stream))
771     (current (string-input-stream-current stream))
772     (end (string-input-stream-end stream)))
773     (declare (simple-string string) (fixnum current end))
774     (if (= current end)
775     (eof-or-lose stream arg1 arg2)
776     (let ((pos (%primitive find-character string current end #\newline)))
777     (if pos
778     (let* ((res-length (- (the fixnum pos) current))
779     (result (make-string res-length)))
780     (%primitive byte-blt string current result 0 res-length)
781     (setf (string-input-stream-current stream)
782     (1+ (the fixnum pos)))
783     (values result nil))
784     (let* ((res-length (- end current))
785     (result (make-string res-length)))
786     (%primitive byte-blt string current result 0 res-length)
787     (setf (string-input-stream-current stream) end)
788     (values result t)))))))
789     (:unread (decf (string-input-stream-current stream)))
790     (:listen (not (= (the fixnum (string-input-stream-current stream))
791     (the fixnum (string-input-stream-end stream)))))
792     (:element-type 'string-char)))
793    
794     (defun make-string-input-stream (string &optional
795     (start 0) (end (length string)))
796     "Returns an input stream which will supply the characters of String between
797     Start and End in order."
798     (if (stringp string)
799     (internal-make-string-input-stream (coerce string 'simple-string)
800     start end)
801     (error "~S is not a string." string)))
802    
803     ;;;; String Output Streams:
804    
805     (defstruct (string-output-stream
806     (:include stream
807     (out #'string-ouch)
808     (sout #'string-sout)
809     (misc #'string-out-misc))
810     (:print-function %print-string-output-stream)
811     (:constructor make-string-output-stream ()))
812     ;; The string we throw stuff in.
813     (string (make-string 40) :type simple-string)
814     ;; Index of the next location to use.
815     (index 0 :type fixnum))
816    
817     (defun %print-string-output-stream (s stream d)
818     (declare (ignore s d))
819     (write-string "#<String-Output Stream>" stream))
820    
821     (setf (documentation 'make-string-output-stream 'function)
822     "Returns an Output stream which will accumulate all output given it for
823     the benefit of the function Get-Output-Stream-String.")
824    
825     (defun string-ouch (stream character)
826     (let ((current (string-output-stream-index stream))
827     (workspace (string-output-stream-string stream)))
828     (declare (simple-string workspace) (fixnum current))
829     (if (= current (the fixnum (length workspace)))
830     (let ((new-workspace (make-string (* current 2))))
831     (%primitive byte-blt workspace 0 new-workspace 0 current)
832     (setf (aref new-workspace current) character)
833     (setf (string-output-stream-string stream) new-workspace))
834     (setf (aref workspace current) character))
835     (setf (string-output-stream-index stream) (1+ current))))
836    
837     (defun string-sout (stream string start end)
838     (declare (simple-string string) (fixnum start end))
839     (let* ((current (string-output-stream-index stream))
840     (length (- end start))
841     (dst-end (+ length current))
842     (workspace (string-output-stream-string stream)))
843     (declare (simple-string workspace)
844     (fixnum current length dst-end))
845     (if (> dst-end (the fixnum (length workspace)))
846     (let ((new-workspace (make-string (+ (* current 2) length))))
847     (%primitive byte-blt workspace 0 new-workspace 0 current)
848     (%primitive byte-blt string start new-workspace current dst-end)
849     (setf (string-output-stream-string stream) new-workspace))
850     (%primitive byte-blt string start workspace current dst-end))
851     (setf (string-output-stream-index stream) dst-end)))
852    
853     (defun string-out-misc (stream operation &optional arg1 arg2)
854     (declare (ignore arg1 arg2))
855     (case operation
856 ram 1.2 (:file-position
857     (if (null arg1)
858     (string-output-stream-index stream)))
859 ram 1.1 (:charpos
860     (do ((index (1- (the fixnum (string-output-stream-index stream)))
861     (1- index))
862     (count 0 (1+ count))
863     (string (string-output-stream-string stream)))
864     ((< index 0) count)
865     (declare (simple-string string)
866     (fixnum index count))
867     (if (char= (schar string index) #\newline)
868     (return count))))
869     (:element-type 'string-char)))
870    
871     (defun get-output-stream-string (stream)
872     "Returns a string of all the characters sent to a stream made by
873     Make-String-Output-Stream since the last call to this function."
874     (if (streamp stream)
875     (let* ((length (string-output-stream-index stream))
876     (result (make-string length)))
877     (%primitive byte-blt (string-output-stream-string stream) 0
878     result 0 length)
879     (setf (string-output-stream-index stream) 0)
880     result)
881     (error "~S is not a string stream.")))
882    
883     (defun dump-output-stream-string (in-stream out-stream)
884     "Dumps the characters buffer up in the In-Stream to the Out-Stream as
885     Get-Output-Stream-String would return them."
886     (write-string (string-output-stream-string in-stream) out-stream
887     :start 0 :end (string-output-stream-index in-stream))
888     (setf (string-output-stream-index in-stream) 0))
889    
890     ;;;; Fill-pointer streams:
891     ;;;
892     ;;; Fill pointer string output streams are not explicitly mentioned in
893     ;;; the CLM, but they are required for the implementation of With-Output-To-String.
894    
895     (defstruct (fill-pointer-output-stream
896     (:include stream
897     (out #'fill-pointer-ouch)
898     (sout #'fill-pointer-sout)
899     (misc #'fill-pointer-misc))
900     (:print-function
901     (lambda (s stream d)
902     (declare (ignore s d))
903     (write-string "#<Fill-Pointer String Output Stream>" stream)))
904     (:constructor make-fill-pointer-output-stream (string)))
905     ;; The string we throw stuff in.
906     string)
907    
908    
909     (defun fill-pointer-ouch (stream character)
910     (let* ((buffer (fill-pointer-output-stream-string stream))
911     (current (%primitive header-ref buffer %array-fill-pointer-slot))
912     (current+1 (1+ current)))
913     (declare (fixnum current))
914     (with-array-data ((workspace buffer) (start) (end))
915     (declare (simple-string workspace))
916     (let ((offset-current (+ start current)))
917     (declare (fixnum offset-current))
918     (if (= offset-current end)
919     (let* ((new-length (* current 2))
920     (new-workspace (make-string new-length)))
921     (declare (simple-string new-workspace))
922     (%primitive byte-blt workspace start new-workspace 0 current)
923     (setf workspace new-workspace)
924     (setf offset-current current)
925     (set-array-header buffer workspace new-length
926     current+1 0 new-length nil))
927     (%primitive header-set buffer %array-fill-pointer-slot current+1))
928     (setf (schar workspace offset-current) character)))
929     current+1))
930    
931    
932     (defun fill-pointer-sout (stream string start end)
933     (declare (simple-string string) (fixnum start end))
934     (let* ((buffer (fill-pointer-output-stream-string stream))
935     (current (%primitive header-ref buffer %array-fill-pointer-slot))
936     (string-len (- end start))
937     (dst-end (+ string-len current)))
938     (declare (fixnum current dst-end string-len))
939     (with-array-data ((workspace buffer) (dst-start) (dst-length))
940     (declare (simple-string workspace))
941     (let ((offset-dst-end (+ dst-start dst-end))
942     (offset-current (+ dst-start current)))
943     (declare (fixnum offset-dst-end offset-current))
944     (if (> offset-dst-end dst-length)
945     (let* ((new-length (+ (the fixnum (* current 2)) string-len))
946     (new-workspace (make-string new-length)))
947     (declare (simple-string new-workspace))
948     (%primitive byte-blt workspace dst-start new-workspace 0 current)
949     (setf workspace new-workspace)
950     (setf offset-current current)
951     (setf offset-dst-end dst-end)
952     (set-array-header buffer workspace new-length
953     dst-end 0 new-length nil))
954     (%primitive header-set buffer %array-fill-pointer-slot dst-end))
955     (%primitive byte-blt string start
956     workspace offset-current offset-dst-end)))
957     dst-end))
958    
959    
960     (defun fill-pointer-misc (stream operation &optional arg1 arg2)
961     (declare (ignore arg1 arg2))
962     (case operation
963     (:charpos
964     (let* ((buffer (fill-pointer-output-stream-string stream))
965     (current (%primitive header-ref buffer %array-fill-pointer-slot)))
966     (with-array-data ((string buffer) (start) (end current))
967     (declare (simple-string string) (ignore start))
968     (let ((found (position #\newline string :test #'char=
969     :end end :from-end t)))
970     (if found
971     (- end (the fixnum found))
972     current)))))
973     (:element-type 'string-char)))
974    
975     ;;;; Indenting streams:
976    
977     (defstruct (indenting-stream (:include stream
978     (out #'indenting-out)
979     (sout #'indenting-sout)
980     (misc #'indenting-misc))
981     (:print-function %print-indenting-stream)
982     (:constructor make-indenting-stream (stream)))
983     ;; The stream we're based on:
984     stream
985     ;; How much we indent on each line:
986     (indentation 0))
987    
988     (setf (documentation 'make-indenting-stream 'function)
989     "Returns an ouput stream which indents its output by some amount.")
990    
991     (defun %print-indenting-stream (s stream d)
992     (declare (ignore s d))
993     (write-string "#<Indenting Stream>" stream))
994    
995     ;;; Indenting-Indent writes the right number of spaces needed to indent output on
996     ;;; the given Stream based on the specified Sub-Stream.
997    
998     (defmacro indenting-indent (stream sub-stream)
999     `(do ((i 0 (+ i 60))
1000     (indentation (indenting-stream-indentation ,stream)))
1001     ((>= i indentation))
1002     (funcall (stream-sout ,sub-stream) ,sub-stream
1003     " "
1004     0 (min 60 (- indentation i)))))
1005    
1006     ;;; Indenting-Out writes a character to an indenting stream.
1007    
1008     (defun indenting-out (stream char)
1009     (let ((sub-stream (indenting-stream-stream stream)))
1010     (funcall (stream-out sub-stream) sub-stream char)
1011     (if (char= char #\newline)
1012     (indenting-indent stream sub-stream))))
1013    
1014     ;;; Indenting-Sout writes a string to an indenting stream.
1015    
1016     (defun indenting-sout (stream string start end)
1017     (declare (simple-string string) (fixnum start end))
1018     (do ((i start)
1019     (sub-stream (indenting-stream-stream stream)))
1020     ((= i end))
1021     (let ((newline (position #\newline string :start i :end end)))
1022     (cond (newline
1023     (funcall (stream-sout sub-stream) sub-stream string i (1+ newline))
1024     (indenting-indent stream sub-stream)
1025     (setq i (+ newline 1)))
1026     (t
1027     (funcall (stream-sout sub-stream) sub-stream string i end)
1028     (setq i end))))))
1029    
1030     ;;; Indenting-Misc just treats just the :Line-Length message differently.
1031     ;;; Indenting-Charpos says the charpos is the charpos of the base stream minus
1032     ;;; the stream's indentation.
1033    
1034     (defun indenting-misc (stream operation &optional arg1 arg2)
1035     (let* ((sub-stream (indenting-stream-stream stream))
1036     (method (stream-misc sub-stream)))
1037     (case operation
1038     (:line-length
1039     (let ((line-length (funcall method sub-stream operation)))
1040     (if line-length
1041     (- line-length (indenting-stream-indentation stream)))))
1042     (:charpos
1043     (let* ((sub-stream (indenting-stream-stream stream))
1044     (charpos (funcall method sub-stream operation)))
1045     (if charpos
1046     (- charpos (indenting-stream-indentation stream)))))
1047     (t
1048     (funcall method sub-stream operation arg1 arg2)))))
1049    
1050     (proclaim '(notinline read-char unread-char read-byte listen))

  ViewVC Help
Powered by ViewVC 1.1.5