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

Contents of /src/code/stream.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.33 - (hide annotations)
Fri May 15 01:03:18 1998 UTC (15 years, 11 months ago) by dtc
Branch: MAIN
Changes since 1.32: +377 -282 lines
Complete the Gray streams support for the lisp-streams that
encapsulate fundamental-streams, and streamline the Gray streams
related dispatch code.
1 ram 1.14 ;;; -*- Package: Lisp -*-
2 ram 1.1 ;;;
3     ;;; **********************************************************************
4 ram 1.9 ;;; This code was written as part of the CMU Common Lisp project at
5     ;;; Carnegie Mellon University, and has been placed in the public domain.
6     ;;;
7     (ext:file-comment
8 dtc 1.33 "$Header: /tiger/var/lib/cvsroots/cmucl/src/code/stream.lisp,v 1.33 1998/05/15 01:03:18 dtc Exp $")
9 ram 1.9 ;;;
10 ram 1.1 ;;; **********************************************************************
11     ;;;
12     ;;; Stream functions for Spice Lisp.
13     ;;; Written by Skef Wholey and Rob MacLachlan.
14 dtc 1.33 ;;; Gray streams support by Douglas Crosher, 1998.
15 ram 1.1 ;;;
16 ram 1.14 ;;; This file contains the OS-independent stream functions.
17 ram 1.1 ;;;
18 ram 1.2 (in-package "LISP")
19 ram 1.1
20 ram 1.14 (export '(broadcast-stream make-broadcast-stream broadcast-stream-streams
21     synonym-stream make-synonym-stream synonym-stream-symbol
22     concatenated-stream make-concatenated-stream
23     concatenated-stream-streams
24     two-way-stream make-two-way-stream two-way-stream-input-stream
25     two-way-stream-output-stream
26     echo-stream make-echo-stream echo-stream-input-stream
27     echo-stream-output-stream
28     make-string-input-stream make-string-output-stream
29 ram 1.1 get-output-stream-string stream-element-type input-stream-p
30 ram 1.14 output-stream-p open-stream-p interactive-stream-p
31 wlott 1.17 open-stream-p close read-line read-char
32 ram 1.1 unread-char peek-char listen read-char-no-hang clear-input read-byte
33     write-char write-string write-line terpri fresh-line
34     finish-output force-output clear-output write-byte
35 ram 1.14 stream streamp string-stream
36     *standard-input* *standard-output*
37 ram 1.1 *error-output* *query-io* *debug-io* *terminal-io* *trace-output*))
38    
39 ram 1.18 (in-package "SYSTEM")
40 ram 1.1 (export '(make-indenting-stream read-n-bytes))
41    
42 ram 1.18 (in-package "EXT")
43    
44     (export '(get-stream-command
45     stream-command stream-command-p stream-command-name
46     stream-command-args make-stream-command make-case-frob-stream))
47    
48     (in-package "LISP")
49    
50 ram 1.14 (deftype string-stream ()
51     '(or string-input-stream string-output-stream
52     fill-pointer-output-stream))
53    
54 ram 1.1 ;;;; Standard streams:
55     ;;;
56     ;;; The initialization of these streams is performed by Stream-Init,
57     ;;; which lives in the file of machine-specific stream functions.
58     ;;;
59     (defvar *terminal-io* () "Terminal I/O stream.")
60     (defvar *standard-input* () "Default input stream.")
61     (defvar *standard-output* () "Default output stream.")
62     (defvar *error-output* () "Error output stream.")
63     (defvar *query-io* () "Query I/O stream.")
64     (defvar *trace-output* () "Trace output stream.")
65     (defvar *debug-io* () "Interactive debugging stream.")
66    
67     (defun ill-in (stream &rest ignore)
68     (declare (ignore ignore))
69     (error "~S is not a character input stream." stream))
70     (defun ill-out (stream &rest ignore)
71     (declare (ignore ignore))
72     (error "~S is not a character output stream." stream))
73     (defun ill-bin (stream &rest ignore)
74     (declare (ignore ignore))
75     (error "~S is not a binary input stream." stream))
76     (defun ill-bout (stream &rest ignore)
77     (declare (ignore ignore))
78     (error "~S is not a binary output stream." stream))
79     (defun closed-flame (stream &rest ignore)
80     (declare (ignore ignore))
81     (error "~S is closed." stream))
82     (defun do-nothing (&rest ignore)
83     (declare (ignore ignore)))
84    
85     (defun %print-stream (structure stream d)
86     (declare (ignore d structure))
87     (write-string "#<Bare Stream>" stream))
88    
89     ;;; HOW THE STREAM STRUCTURE IS USED:
90     ;;;
91     ;;; Many of the slots of the stream structure contain functions
92     ;;; which are called to perform some operation on the stream. Closed
93     ;;; streams have #'Closed-Flame in all of their function slots. If
94     ;;; one side of an I/O or echo stream is closed, the whole stream is
95     ;;; considered closed. The functions in the operation slots take
96     ;;; arguments as follows:
97     ;;;
98     ;;; In: Stream, Eof-Errorp, Eof-Value
99     ;;; Bin: Stream, Eof-Errorp, Eof-Value
100     ;;; N-Bin: Stream, Buffer, Start, Numbytes, Eof-Errorp
101     ;;; Out: Stream, Character
102     ;;; Bout: Stream, Integer
103     ;;; Sout: Stream, String, Start, End
104     ;;; Misc: Stream, Operation, &Optional Arg1, Arg2
105     ;;;
106     ;;; In order to save space, some of the less common stream operations
107     ;;; are handled by just one function, the Misc method. This function
108     ;;; is passed a keyword which indicates the operation to perform.
109     ;;; The following keywords are used:
110 ram 1.10 ;;; :listen - Return the following values:
111     ;;; t if any input waiting.
112     ;;; :eof if at eof.
113     ;;; nil if no input is available and not at eof.
114 ram 1.1 ;;; :unread - Unread the character Arg.
115     ;;; :close - Do any stream specific stuff to close the stream.
116     ;;; The methods are set to closed-flame by the close
117     ;;; function, so that need not be done by this
118     ;;; function.
119     ;;; :clear-input - Clear any unread input
120     ;;; :finish-output,
121     ;;; :force-output - Cause output to happen
122     ;;; :clear-output - Clear any undone output
123 ram 1.18 ;;; :element-type - Return the type of element the stream deals wit<h.
124 ram 1.1 ;;; :line-length - Return the length of a line of output.
125     ;;; :charpos - Return current output position on the line.
126     ;;; :file-length - Return the file length of a file stream.
127     ;;; :file-position - Return or change the current position of a file stream.
128     ;;; :file-name - Return the name of an associated file.
129 ram 1.14 ;;; :interactive-p - Is this an interactive device?
130 ram 1.1 ;;;
131     ;;; In order to do almost anything useful, it is necessary to
132     ;;; define a new type of structure that includes stream, so that the
133     ;;; stream can have some state information.
134     ;;;
135     ;;; THE STREAM IN-BUFFER:
136     ;;;
137     ;;; The In-Buffer in the stream holds characters or bytes that
138     ;;; are ready to be read by some input function. If there is any
139     ;;; stuff in the In-Buffer, then the reading function can use it
140     ;;; without calling any stream method. Any stream may put stuff in
141     ;;; the In-Buffer, and may also assume that any input in the In-Buffer
142     ;;; has been consumed before any in-method is called. If a text
143     ;;; stream has in In-Buffer, then the first character should not be
144     ;;; used to buffer normal input so that it is free for unreading into.
145     ;;;
146     ;;; The In-Buffer slot is a vector In-Buffer-Length long. The
147     ;;; In-Index is the index in the In-Buffer of the first available
148     ;;; object. The available objects are thus between In-Index and the
149     ;;; length of the In-Buffer.
150     ;;;
151     ;;; When this buffer is only accessed by the normal stream
152     ;;; functions, the number of function calls is halved, thus
153     ;;; potentially doubling the speed of simple operations. If the
154     ;;; Fast-Read-Char and Fast-Read-Byte macros are used, nearly all
155     ;;; function call overhead is removed, vastly speeding up these
156     ;;; important operations.
157     ;;;
158     ;;; If a stream does not have an In-Buffer, then the In-Buffer slot
159     ;;; must be nil, and the In-Index must be In-Buffer-Length. These are
160     ;;; the default values for the slots.
161 ram 1.18
162 ram 1.1
163     ;;; Stream manipulation functions.
164    
165     (defun input-stream-p (stream)
166     "Returns non-nil if the given Stream can perform input operations."
167 dtc 1.30 (and (lisp-stream-p stream)
168     (not (eq (lisp-stream-in stream) #'closed-flame))
169     (or (not (eq (lisp-stream-in stream) #'ill-in))
170     (not (eq (lisp-stream-bin stream) #'ill-bin)))))
171 ram 1.1
172     (defun output-stream-p (stream)
173     "Returns non-nil if the given Stream can perform output operations."
174 dtc 1.30 (and (lisp-stream-p stream)
175     (not (eq (lisp-stream-in stream) #'closed-flame))
176     (or (not (eq (lisp-stream-out stream) #'ill-out))
177     (not (eq (lisp-stream-bout stream) #'ill-bout)))))
178 ram 1.1
179 ram 1.14 (defun open-stream-p (stream)
180     "Return true if Stream is not closed."
181     (declare (type stream stream))
182 dtc 1.30 (not (eq (lisp-stream-in stream) #'closed-flame)))
183 ram 1.14
184 ram 1.1 (defun stream-element-type (stream)
185     "Returns a type specifier for the kind of object returned by the Stream."
186 wlott 1.17 (declare (type stream stream))
187 dtc 1.30 (funcall (lisp-stream-misc stream) stream :element-type))
188 ram 1.1
189 ram 1.14 (defun interactive-stream-p (stream)
190     "Return true if Stream does I/O on a terminal or other interactive device."
191     (declare (type stream stream))
192 dtc 1.30 (funcall (lisp-stream-misc stream) stream :interactive-p))
193 ram 1.14
194 wlott 1.17 (defun open-stream-p (stream)
195     "Return true if and only if STREAM has not been closed."
196     (declare (type stream stream))
197 dtc 1.30 (not (eq (lisp-stream-in stream) #'closed-flame)))
198 wlott 1.17
199 ram 1.1 (defun close (stream &key abort)
200     "Closes the given Stream. No more I/O may be performed, but inquiries
201     may still be made. If :Abort is non-nil, an attempt is made to clean
202     up the side effects of having created the stream."
203 wlott 1.17 (declare (type stream stream))
204     (when (open-stream-p stream)
205 dtc 1.30 (funcall (lisp-stream-misc stream) stream :close abort))
206 ram 1.1 t)
207    
208     (defun set-closed-flame (stream)
209 dtc 1.30 (setf (lisp-stream-in stream) #'closed-flame)
210     (setf (lisp-stream-bin stream) #'closed-flame)
211     (setf (lisp-stream-n-bin stream) #'closed-flame)
212     (setf (lisp-stream-in stream) #'closed-flame)
213     (setf (lisp-stream-out stream) #'closed-flame)
214     (setf (lisp-stream-bout stream) #'closed-flame)
215     (setf (lisp-stream-sout stream) #'closed-flame)
216     (setf (lisp-stream-misc stream) #'closed-flame))
217 ram 1.18
218 ram 1.1
219 ram 1.18 ;;;; File position and file length.
220    
221     ;;; File-Position -- Public
222     ;;;
223     ;;; Call the misc method with the :file-position operation.
224     ;;;
225     (defun file-position (stream &optional position)
226     "With one argument returns the current position within the file
227 wlott 1.19 File-Stream is open to. If the second argument is supplied, then
228     this becomes the new file position. The second argument may also
229     be :start or :end for the start and end of the file, respectively."
230     (declare (stream stream)
231     (type (or index (member nil :start :end)) position))
232 ram 1.18 (cond
233     (position
234 dtc 1.30 (setf (lisp-stream-in-index stream) in-buffer-length)
235     (funcall (lisp-stream-misc stream) stream :file-position position))
236 ram 1.18 (t
237 dtc 1.30 (let ((res (funcall (lisp-stream-misc stream) stream :file-position nil)))
238     (when res (- res (- in-buffer-length (lisp-stream-in-index stream))))))))
239 ram 1.18
240    
241     ;;; File-Length -- Public
242     ;;;
243     ;;; Like File-Position, only use :file-length.
244     ;;;
245     (defun file-length (stream)
246     "This function returns the length of the file that File-Stream is open to."
247     (declare (stream stream))
248 dtc 1.30 (funcall (lisp-stream-misc stream) stream :file-length))
249 ram 1.18
250    
251 ram 1.1 ;;; Input functions:
252    
253     (defun read-line (&optional (stream *standard-input*) (eof-errorp t) eof-value
254     recursive-p)
255     "Returns a line of text read from the Stream as a string, discarding the
256     newline character."
257     (declare (ignore recursive-p))
258 dtc 1.32 (let ((stream (in-synonym-of stream)))
259 dtc 1.33 (if (lisp-stream-p stream)
260     (prepare-for-fast-read-char stream
261     (let ((res (make-string 80))
262     (len 80)
263     (index 0))
264     (loop
265     (let ((ch (fast-read-char nil nil)))
266     (cond (ch
267     (when (char= ch #\newline)
268     (done-with-fast-read-char)
269     (return (values (shrink-vector res index) nil)))
270     (when (= index len)
271     (setq len (* len 2))
272     (let ((new (make-string len)))
273     (replace new res)
274     (setq res new)))
275     (setf (schar res index) ch)
276     (incf index))
277     ((zerop index)
278     (done-with-fast-read-char)
279     (return (values (eof-or-lose stream eof-errorp eof-value)
280     t)))
281     ;; since fast-read-char hit already the eof char, we
282     ;; shouldn't do another read-char
283     (t
284     (done-with-fast-read-char)
285     (return (values (shrink-vector res index) t))))))))
286     ;; Fundamental-stream.
287     (multiple-value-bind (string eof)
288     (stream-read-line stream)
289     (if (and eof (zerop (length string)))
290     (values (eof-or-lose stream eof-errorp eof-value) t)
291     (values string eof))))))
292 ram 1.10
293 ram 1.1 ;;; We proclaim them inline here, then proclaim them notinline at EOF,
294     ;;; so, except in this file, they are not inline by default, but they can be.
295     ;;;
296     (proclaim '(inline read-char unread-char read-byte listen))
297     (defun read-char (&optional (stream *standard-input*) (eof-errorp t) eof-value
298     recursive-p)
299     "Inputs a character from Stream and returns it."
300     (declare (ignore recursive-p))
301 dtc 1.32 (let ((stream (in-synonym-of stream)))
302 dtc 1.33 (if (lisp-stream-p stream)
303     (prepare-for-fast-read-char stream
304     (prog1
305     (fast-read-char eof-errorp eof-value)
306     (done-with-fast-read-char)))
307     ;; Fundamental-stream.
308     (let ((char (stream-read-char stream)))
309     (if (eq char :eof)
310     (eof-or-lose stream eof-errorp eof-value)
311     char)))))
312 ram 1.1
313     (defun unread-char (character &optional (stream *standard-input*))
314     "Puts the Character back on the front of the input Stream."
315 dtc 1.32 (let ((stream (in-synonym-of stream)))
316 dtc 1.33 (if (lisp-stream-p stream)
317     (let ((index (1- (lisp-stream-in-index stream)))
318     (buffer (lisp-stream-in-buffer stream)))
319     (declare (fixnum index))
320     (when (minusp index) (error "Nothing to unread."))
321     (cond (buffer
322     (setf (aref buffer index) (char-code character))
323     (setf (lisp-stream-in-index stream) index))
324     (t
325     (funcall (lisp-stream-misc stream) stream
326     :unread character))))
327     ;; Fundamental-stream
328     (stream-unread-char stream character)))
329 ram 1.1 nil)
330    
331     (defun peek-char (&optional (peek-type nil) (stream *standard-input*)
332     (eof-errorp t) eof-value recursive-p)
333     "Peeks at the next character in the input Stream. See manual for details."
334     (declare (ignore recursive-p))
335 dtc 1.32 (let ((stream (in-synonym-of stream)))
336 dtc 1.33 (if (lisp-stream-p stream)
337     (let ((char (read-char stream eof-errorp eof-value)))
338     (cond ((eq char eof-value) char)
339     ((characterp peek-type)
340     (do ((char char (read-char stream eof-errorp eof-value)))
341     ((or (eq char eof-value) (char= char peek-type))
342     (unless (eq char eof-value)
343     (unread-char char stream))
344     char)))
345     ((eq peek-type t)
346     (do ((char char (read-char stream eof-errorp eof-value)))
347     ((or (eq char eof-value) (not (whitespace-char-p char)))
348     (unless (eq char eof-value)
349     (unread-char char stream))
350     char)))
351     (t
352     (unread-char char stream)
353     char)))
354     ;; Fundamental-stream.
355     (cond ((characterp peek-type)
356     (do ((char (stream-read-char stream) (stream-read-char stream)))
357     ((or (eq char :eof) (char= char peek-type))
358     (cond ((eq char :eof)
359     (eof-or-lose stream eof-errorp eof-value))
360     (t
361     (stream-unread-char stream char)
362     char)))))
363     ((eq peek-type t)
364     (do ((char (stream-read-char stream) (stream-read-char stream)))
365     ((or (eq char :eof) (not (whitespace-char-p char)))
366     (cond ((eq char :eof)
367     (eof-or-lose stream eof-errorp eof-value))
368     (t
369     (stream-unread-char stream char)
370     char)))))
371     (t
372     (let ((char (stream-peek-char stream)))
373     (if (eq char :eof)
374     (eof-or-lose stream eof-errorp eof-value)
375     char)))))))
376 ram 1.1
377     (defun listen (&optional (stream *standard-input*))
378     "Returns T if a character is availible on the given Stream."
379 dtc 1.32 (let ((stream (in-synonym-of stream)))
380 dtc 1.33 (if (lisp-stream-p stream)
381     (or (/= (the fixnum (lisp-stream-in-index stream)) in-buffer-length)
382     ;; Test for t explicitly since misc methods return :eof sometimes.
383     (eq (funcall (lisp-stream-misc stream) stream :listen) t))
384     ;; Fundamental-stream.
385     (stream-listen stream))))
386 ram 1.1
387     (defun read-char-no-hang (&optional (stream *standard-input*)
388     (eof-errorp t) eof-value recursive-p)
389     "Returns the next character from the Stream if one is availible, or nil."
390     (declare (ignore recursive-p))
391 dtc 1.32 (let ((stream (in-synonym-of stream)))
392 dtc 1.33 (if (lisp-stream-p stream)
393     (if (funcall (lisp-stream-misc stream) stream :listen)
394     ;; On t or :eof get READ-CHAR to do the work.
395     (read-char stream eof-errorp eof-value)
396     nil)
397     ;; Fundamental-stream.
398     (let ((char (stream-read-char-no-hang stream)))
399     (if (eq char :eof)
400     (eof-or-lose stream eof-errorp eof-value)
401     char)))))
402 dtc 1.30
403 ram 1.1
404     (defun clear-input (&optional (stream *standard-input*))
405     "Clears any buffered input associated with the Stream."
406 dtc 1.32 (let ((stream (in-synonym-of stream)))
407 dtc 1.33 (cond ((lisp-stream-p stream)
408     (setf (lisp-stream-in-index stream) in-buffer-length)
409     (funcall (lisp-stream-misc stream) stream :clear-input))
410     (t
411     (stream-clear-input stream))))
412 dtc 1.30 nil)
413 ram 1.1
414     (defun read-byte (stream &optional (eof-errorp t) eof-value)
415     "Returns the next byte of the Stream."
416 dtc 1.32 (let ((stream (in-synonym-of stream)))
417 dtc 1.33 (if (lisp-stream-p stream)
418     (prepare-for-fast-read-byte stream
419     (prog1
420     (fast-read-byte eof-errorp eof-value t)
421     (done-with-fast-read-byte)))
422     ;; Fundamental-stream.
423     (let ((char (stream-read-byte stream)))
424     (if (eq char :eof)
425     (eof-or-lose stream eof-errorp eof-value)
426     char)))))
427 ram 1.1
428     (defun read-n-bytes (stream buffer start numbytes &optional (eof-errorp t))
429 ram 1.24 "Reads Numbytes bytes into the Buffer starting at Start, returning the number
430     of bytes read.
431     -- If EOF-ERROR-P is true, an END-OF-FILE condition is signalled if
432     end-of-file is encountered before Count bytes have been read.
433     -- If EOF-ERROR-P is false, READ-N-BYTES reads as much data is currently
434     available (up to count bytes.) On pipes or similar devices, this
435     function returns as soon as any adata is available, even if the amount
436     read is less than Count and eof has not been hit."
437 dtc 1.30 (declare (type lisp-stream stream)
438     (type index numbytes start)
439 ram 1.18 (type (or (simple-array * (*)) system-area-pointer) buffer))
440 dtc 1.32 (let* ((stream (in-synonym-of stream lisp-stream))
441 dtc 1.30 (in-buffer (lisp-stream-in-buffer stream))
442     (index (lisp-stream-in-index stream))
443 ram 1.1 (num-buffered (- in-buffer-length index)))
444     (declare (fixnum index num-buffered))
445     (cond
446 ram 1.2 ((not in-buffer)
447 dtc 1.30 (funcall (lisp-stream-n-bin stream) stream buffer start numbytes eof-errorp))
448 ram 1.1 ((<= numbytes num-buffered)
449     (%primitive byte-blt in-buffer index buffer start (+ start numbytes))
450 dtc 1.30 (setf (lisp-stream-in-index stream) (+ index numbytes))
451 ram 1.1 numbytes)
452     (t
453     (let ((end (+ start num-buffered)))
454     (%primitive byte-blt in-buffer index buffer start end)
455 dtc 1.30 (setf (lisp-stream-in-index stream) in-buffer-length)
456     (+ (funcall (lisp-stream-n-bin stream) stream buffer end
457 ram 1.18 (- numbytes num-buffered)
458     eof-errorp)
459 ram 1.1 num-buffered))))))
460 ram 1.18
461    
462     ;;; Amount of space we leave at the start of the in-buffer for unreading. 4
463     ;;; instead of 1 to allow word-aligned copies.
464     ;;;
465     (defconstant in-buffer-extra 4)
466    
467     ;;; FAST-READ-CHAR-REFILL -- Interface
468     ;;;
469     ;;; This function is called by the fast-read-char expansion to refill the
470     ;;; in-buffer for text streams. There is definitely an in-buffer, and hence
471     ;;; myst be an n-bin method.
472     ;;;
473     (defun fast-read-char-refill (stream eof-errorp eof-value)
474 dtc 1.30 (let* ((ibuf (lisp-stream-in-buffer stream))
475     (count (funcall (lisp-stream-n-bin stream) stream
476 ram 1.18 ibuf in-buffer-extra
477     (- in-buffer-length in-buffer-extra)
478     nil))
479     (start (- in-buffer-length count)))
480     (declare (type index start count))
481     (cond ((zerop count)
482 dtc 1.30 (setf (lisp-stream-in-index stream) in-buffer-length)
483     (funcall (lisp-stream-in stream) stream eof-errorp eof-value))
484 ram 1.18 (t
485     (when (/= start in-buffer-extra)
486     (bit-bash-copy ibuf (+ (* in-buffer-extra vm:byte-bits)
487     (* vm:vector-data-offset vm:word-bits))
488     ibuf (+ (the index (* start vm:byte-bits))
489     (* vm:vector-data-offset vm:word-bits))
490     (* count vm:byte-bits)))
491 dtc 1.30 (setf (lisp-stream-in-index stream) (1+ start))
492 ram 1.18 (code-char (aref ibuf start))))))
493    
494    
495     ;;; FAST-READ-BYTE-REFILL -- Interface
496     ;;;
497     ;;; Similar to FAST-READ-CHAR-REFILL, but we don't have to leave room for
498     ;;; unreading.
499     ;;;
500     (defun fast-read-byte-refill (stream eof-errorp eof-value)
501 dtc 1.30 (let* ((ibuf (lisp-stream-in-buffer stream))
502     (count (funcall (lisp-stream-n-bin stream) stream
503 ram 1.18 ibuf 0 in-buffer-length
504     nil))
505     (start (- in-buffer-length count)))
506     (declare (type index start count))
507     (cond ((zerop count)
508 dtc 1.30 (setf (lisp-stream-in-index stream) in-buffer-length)
509     (funcall (lisp-stream-bin stream) stream eof-errorp eof-value))
510 ram 1.18 (t
511     (unless (zerop start)
512     (bit-bash-copy ibuf (* vm:vector-data-offset vm:word-bits)
513     ibuf (+ (the index (* start vm:byte-bits))
514     (* vm:vector-data-offset vm:word-bits))
515     (* count vm:byte-bits)))
516 dtc 1.30 (setf (lisp-stream-in-index stream) (1+ start))
517 ram 1.18 (aref ibuf start)))))
518    
519 ram 1.1
520     ;;; Output functions:
521    
522     (defun write-char (character &optional (stream *standard-output*))
523     "Outputs the Character to the Stream."
524 dtc 1.32 (with-out-stream stream (lisp-stream-out character)
525     (stream-write-char character))
526 ram 1.1 character)
527    
528     (defun terpri (&optional (stream *standard-output*))
529     "Outputs a new line to the Stream."
530 dtc 1.32 (with-out-stream stream (lisp-stream-out #\newline) (stream-terpri))
531 ram 1.1 nil)
532    
533     (defun fresh-line (&optional (stream *standard-output*))
534     "Outputs a new line to the Stream if it is not positioned at the begining of
535     a line. Returns T if it output a new line, nil otherwise."
536 dtc 1.32 (let ((stream (out-synonym-of stream)))
537 dtc 1.33 (if (lisp-stream-p stream)
538     (when (/= (or (charpos stream) 1) 0)
539     (funcall (lisp-stream-out stream) stream #\newline)
540     t)
541     ;; Fundamental-stream.
542     (stream-fresh-line stream))))
543 ram 1.1
544     (defun write-string (string &optional (stream *standard-output*)
545     &key (start 0) (end (length (the vector string))))
546     "Outputs the String to the given Stream."
547     (write-string* string stream start end))
548    
549     (defun write-string* (string &optional (stream *standard-output*)
550     (start 0) (end (length (the vector string))))
551     (declare (fixnum start end))
552 dtc 1.32 (let ((stream (out-synonym-of stream)))
553 dtc 1.33 (cond ((lisp-stream-p stream)
554     (if (array-header-p string)
555     (with-array-data ((data string) (offset-start start)
556     (offset-end end))
557     (funcall (lisp-stream-sout stream)
558     stream data offset-start offset-end))
559     (funcall (lisp-stream-sout stream) stream string start end))
560     string)
561     (t ; Fundamental-stream.
562     (stream-write-string stream string start end)))))
563 ram 1.1
564     (defun write-line (string &optional (stream *standard-output*)
565     &key (start 0) (end (length string)))
566     "Outputs the String to the given Stream, followed by a newline character."
567     (write-line* string stream start end))
568    
569     (defun write-line* (string &optional (stream *standard-output*)
570     (start 0) (end (length string)))
571     (declare (fixnum start end))
572 dtc 1.32 (let ((stream (out-synonym-of stream)))
573 dtc 1.33 (cond ((lisp-stream-p stream)
574     (if (array-header-p string)
575     (with-array-data ((data string) (offset-start start)
576     (offset-end end))
577     (with-out-stream stream (lisp-stream-sout data offset-start
578     offset-end)))
579     (with-out-stream stream (lisp-stream-sout string start end)))
580     (funcall (lisp-stream-out stream) stream #\newline))
581     (t ; Fundamental-stream.
582     (stream-write-string stream string start end)
583     (stream-write-char stream #\Newline)))
584 dtc 1.30 string))
585 ram 1.1
586     (defun charpos (&optional (stream *standard-output*))
587     "Returns the number of characters on the current line of output of the given
588     Stream, or Nil if that information is not availible."
589 dtc 1.32 (with-out-stream stream (lisp-stream-misc :charpos) (stream-line-column)))
590 ram 1.1
591     (defun line-length (&optional (stream *standard-output*))
592     "Returns the number of characters that will fit on a line of output on the
593     given Stream, or Nil if that information is not available."
594 dtc 1.32 (with-out-stream stream (lisp-stream-misc :line-length)
595     (stream-line-length)))
596 ram 1.1
597     (defun finish-output (&optional (stream *standard-output*))
598 dtc 1.28 "Attempts to ensure that all output sent to the Stream has reached its
599 ram 1.1 destination, and only then returns."
600 dtc 1.32 (with-out-stream stream (lisp-stream-misc :finish-output)
601     (stream-finish-output))
602 ram 1.1 nil)
603    
604     (defun force-output (&optional (stream *standard-output*))
605     "Attempts to force any buffered output to be sent."
606 dtc 1.32 (with-out-stream stream (lisp-stream-misc :force-output)
607     (stream-force-output))
608 ram 1.1 nil)
609    
610     (defun clear-output (&optional (stream *standard-output*))
611     "Clears the given output Stream."
612 dtc 1.32 (with-out-stream stream (lisp-stream-misc :clear-output)
613     (stream-force-output))
614 ram 1.1 nil)
615    
616     (defun write-byte (integer stream)
617     "Outputs the Integer to the binary Stream."
618 dtc 1.32 (with-out-stream stream (lisp-stream-bout integer) (stream-write-byte))
619 ram 1.1 integer)
620    
621 dtc 1.33
622     ;;; Stream-misc-dispatch
623     ;;;
624     ;;; Called from lisp-steam routines that encapsulate CLOS streams to
625     ;;; handle the misc routines and dispatch to the appropriate Gray
626     ;;; stream functions.
627     ;;;
628     (defun stream-misc-dispatch (stream operation &optional arg1 arg2)
629     (declare (type fundamental-stream stream)
630     (ignore arg2))
631     (case operation
632     (:listen
633     ;; Return true is input available, :eof for eof-of-file, otherwise Nil.
634     (let ((char (stream-read-char-no-hang stream)))
635     (when (characterp char)
636     (stream-unread-char stream char))
637     char))
638     (:unread
639     (stream-unread-char stream arg1))
640     (:close
641     (close stream))
642     (:clear-input
643     (stream-clear-input stream))
644     (:force-output
645     (stream-force-output stream))
646     (:finish-output
647     (stream-finish-output stream))
648     (:element-type
649     (stream-element-type stream))
650     (:interactive-p
651     (interactive-stream-p stream))
652     (:line-length
653     (stream-line-length stream))
654     (:charpos
655     (stream-line-column stream))
656     (:file-length
657     (file-length stream))
658     (:file-position
659     (file-position stream arg1))))
660    
661    
662 ram 1.1 ;;;; Broadcast streams:
663    
664 dtc 1.30 (defstruct (broadcast-stream (:include lisp-stream
665 ram 1.1 (out #'broadcast-out)
666     (bout #'broadcast-bout)
667     (sout #'broadcast-sout)
668     (misc #'broadcast-misc))
669     (:print-function %print-broadcast-stream)
670     (:constructor make-broadcast-stream (&rest streams)))
671     ;; This is a list of all the streams we broadcast to.
672 ram 1.14 (streams () :type list :read-only t))
673 ram 1.1
674     (setf (documentation 'make-broadcast-stream 'function)
675     "Returns an ouput stream which sends its output to all of the given streams.")
676    
677     (defun %print-broadcast-stream (s stream d)
678     (declare (ignore s d))
679     (write-string "#<Broadcast Stream>" stream))
680    
681 dtc 1.33 (macrolet ((out-fun (fun method stream-method &rest args)
682 ram 1.1 `(defun ,fun (stream ,@args)
683     (dolist (stream (broadcast-stream-streams stream))
684 dtc 1.33 (if (lisp-stream-p stream)
685     (funcall (,method stream) stream ,@args)
686     (,stream-method stream ,@args))))))
687     (out-fun broadcast-out lisp-stream-out stream-write-char char)
688     (out-fun broadcast-bout lisp-stream-bout stream-write-byte byte)
689     (out-fun broadcast-sout lisp-stream-sout stream-write-string
690     string start end))
691 ram 1.1
692     (defun broadcast-misc (stream operation &optional arg1 arg2)
693     (let ((streams (broadcast-stream-streams stream)))
694     (case operation
695     (:charpos
696     (dolist (stream streams)
697 dtc 1.33 (let ((charpos (charpos stream)))
698 ram 1.1 (if charpos (return charpos)))))
699     (:line-length
700     (let ((min nil))
701     (dolist (stream streams min)
702 dtc 1.33 (let ((res (line-length stream)))
703 ram 1.1 (when res (setq min (if min (min res min) res)))))))
704     (:element-type
705     (let (res)
706     (dolist (stream streams (if (> (length res) 1) `(and ,@res) res))
707 dtc 1.33 (pushnew (stream-element-type stream) res :test #'equal))))
708 wlott 1.25 (:close)
709 ram 1.1 (t
710     (let ((res nil))
711     (dolist (stream streams res)
712 dtc 1.33 (setq res
713     (if (lisp-stream-p stream)
714     (funcall (lisp-stream-misc stream) stream operation
715     arg1 arg2)
716     (stream-misc-dispatch stream operation arg1 arg2)))))))))
717    
718 ram 1.1
719     ;;;; Synonym Streams:
720    
721 dtc 1.30 (defstruct (synonym-stream (:include lisp-stream
722 ram 1.1 (in #'synonym-in)
723     (bin #'synonym-bin)
724     (n-bin #'synonym-n-bin)
725     (out #'synonym-out)
726     (bout #'synonym-bout)
727     (sout #'synonym-sout)
728     (misc #'synonym-misc))
729     (:print-function %print-synonym-stream)
730     (:constructor make-synonym-stream (symbol)))
731     ;; This is the symbol, the value of which is the stream we are synonym to.
732 wlott 1.15 (symbol nil :type symbol :read-only t))
733 ram 1.1
734     (defun %print-synonym-stream (s stream d)
735     (declare (ignore d))
736     (format stream "#<Synonym Stream to ~S>" (synonym-stream-symbol s)))
737    
738     (setf (documentation 'make-synonym-stream 'function)
739     "Returns a stream which performs its operations on the stream which is the
740     value of the dynamic variable named by Symbol.")
741    
742     ;;; The output simple output methods just call the corresponding method
743     ;;; in the synonymed stream.
744     ;;;
745 dtc 1.33 (macrolet ((out-fun (name slot stream-method &rest args)
746 ram 1.1 `(defun ,name (stream ,@args)
747 ram 1.11 (declare (optimize (safety 1)))
748 ram 1.1 (let ((syn (symbol-value (synonym-stream-symbol stream))))
749 dtc 1.33 (if (lisp-stream-p syn)
750     (funcall (,slot syn) syn ,@args)
751     (,stream-method syn ,@args))))))
752     (out-fun synonym-out lisp-stream-out stream-write-char ch)
753     (out-fun synonym-bout lisp-stream-bout stream-write-byte n)
754     (out-fun synonym-sout lisp-stream-sout stream-write-string string start end))
755 ram 1.1
756    
757     ;;; Bind synonym stream to this so that SPIO can turn on the right frob in
758     ;;; the icon when we are in a terminal input wait.
759     ;;;
760     (defvar *previous-stream* nil)
761    
762     ;;; For the input methods, we just call the corresponding function on the
763     ;;; synonymed stream. These functions deal with getting input out of
764     ;;; the In-Buffer if there is any.
765     ;;;
766     (macrolet ((in-fun (name fun &rest args)
767     `(defun ,name (stream ,@args)
768 ram 1.11 (declare (optimize (safety 1)))
769 ram 1.1 (let ((*previous-stream* stream))
770     (,fun (symbol-value (synonym-stream-symbol stream)) ,@args)))))
771     (in-fun synonym-in read-char eof-errorp eof-value)
772     (in-fun synonym-bin read-byte eof-errorp eof-value)
773     (in-fun synonym-n-bin read-n-bytes buffer start numbytes eof-errorp))
774    
775    
776     ;;; Synonym-Misc -- Internal
777     ;;;
778     ;;; We have to special-case the operations which could look at stuff in
779     ;;; the in-buffer.
780     ;;;
781     (defun synonym-misc (stream operation &optional arg1 arg2)
782 ram 1.11 (declare (optimize (safety 1)))
783 ram 1.1 (let ((syn (symbol-value (synonym-stream-symbol stream)))
784     (*previous-stream* stream))
785 dtc 1.33 (if (lisp-stream-p syn)
786     (case operation
787     (:listen (or (/= (the fixnum (lisp-stream-in-index syn))
788     in-buffer-length)
789     (funcall (lisp-stream-misc syn) syn :listen)))
790     (t
791     (funcall (lisp-stream-misc syn) syn operation arg1 arg2)))
792     (stream-misc-dispatch syn operation arg1 arg2))))
793 ram 1.1
794     ;;;; Two-Way streams:
795    
796     (defstruct (two-way-stream
797 dtc 1.30 (:include lisp-stream
798 ram 1.1 (in #'two-way-in)
799     (bin #'two-way-bin)
800     (n-bin #'two-way-n-bin)
801     (out #'two-way-out)
802     (bout #'two-way-bout)
803     (sout #'two-way-sout)
804     (misc #'two-way-misc))
805     (:print-function %print-two-way-stream)
806     (:constructor make-two-way-stream (input-stream output-stream)))
807     ;; We read from this stream...
808 ram 1.14 (input-stream (required-argument) :type stream :read-only t)
809 ram 1.1 ;; And write to this one
810 ram 1.14 (output-stream (required-argument) :type stream :read-only t))
811 ram 1.1
812     (defun %print-two-way-stream (s stream d)
813     (declare (ignore d))
814     (format stream "#<Two-Way Stream, Input = ~S, Output = ~S>"
815     (two-way-stream-input-stream s)
816     (two-way-stream-output-stream s)))
817    
818     (setf (documentation 'make-two-way-stream 'function)
819     "Returns a bidirectional stream which gets its input from Input-Stream and
820     sends its output to Output-Stream.")
821    
822 dtc 1.33 (macrolet ((out-fun (name slot stream-method &rest args)
823 ram 1.1 `(defun ,name (stream ,@args)
824     (let ((syn (two-way-stream-output-stream stream)))
825 dtc 1.33 (if (lisp-stream-p syn)
826     (funcall (,slot syn) syn ,@args)
827     (,stream-method syn ,@args))))))
828     (out-fun two-way-out lisp-stream-out stream-write-char ch)
829     (out-fun two-way-bout lisp-stream-bout stream-write-byte n)
830     (out-fun two-way-sout lisp-stream-sout stream-write-string string start end))
831 ram 1.1
832     (macrolet ((in-fun (name fun &rest args)
833     `(defun ,name (stream ,@args)
834 ram 1.10 (force-output (two-way-stream-output-stream stream))
835 ram 1.1 (,fun (two-way-stream-input-stream stream) ,@args))))
836     (in-fun two-way-in read-char eof-errorp eof-value)
837     (in-fun two-way-bin read-byte eof-errorp eof-value)
838     (in-fun two-way-n-bin read-n-bytes buffer start numbytes eof-errorp))
839    
840     (defun two-way-misc (stream operation &optional arg1 arg2)
841     (let* ((in (two-way-stream-input-stream stream))
842     (out (two-way-stream-output-stream stream))
843 dtc 1.33 (in-lisp-stream-p (lisp-stream-p in))
844     (out-lisp-stream-p (lisp-stream-p out)))
845 ram 1.1 (case operation
846 dtc 1.33 (:listen
847     (if in-lisp-stream-p
848     (or (/= (the fixnum (lisp-stream-in-index in)) in-buffer-length)
849     (funcall (lisp-stream-misc in) in :listen))
850     (stream-listen in)))
851 ram 1.1 ((:finish-output :force-output :clear-output)
852 dtc 1.33 (if out-lisp-stream-p
853     (funcall (lisp-stream-misc out) out operation arg1 arg2)
854     (stream-misc-dispatch out operation arg1 arg2)))
855 ram 1.1 ((:clear-input :unread)
856 dtc 1.33 (if in-lisp-stream-p
857     (funcall (lisp-stream-misc in) in operation arg1 arg2)
858     (stream-misc-dispatch in operation arg1 arg2)))
859 ram 1.1 (:element-type
860 dtc 1.33 (let ((in-type (stream-element-type in))
861     (out-type (stream-element-type out)))
862 ram 1.1 (if (equal in-type out-type)
863     in-type `(and ,in-type ,out-type))))
864 dtc 1.33 (:close
865 ram 1.1 (set-closed-flame stream))
866     (t
867 dtc 1.33 (or (if in-lisp-stream-p
868     (funcall (lisp-stream-misc in) in operation arg1 arg2)
869     (stream-misc-dispatch in operation arg1 arg2))
870     (if out-lisp-stream-p
871     (funcall (lisp-stream-misc out) out operation arg1 arg2)
872     (stream-misc-dispatch out operation arg1 arg2)))))))
873    
874 ram 1.1
875     ;;;; Concatenated Streams:
876    
877     (defstruct (concatenated-stream
878 dtc 1.30 (:include lisp-stream
879 ram 1.1 (in #'concatenated-in)
880     (bin #'concatenated-bin)
881     (misc #'concatenated-misc))
882     (:print-function %print-concatenated-stream)
883     (:constructor
884     make-concatenated-stream (&rest streams &aux (current streams))))
885     ;; The car of this is the stream we are reading from now.
886     current
887     ;; This is a list of all the streams. We need to remember them so that
888     ;; we can close them.
889 ram 1.14 (streams nil :type list :read-only t))
890 ram 1.1
891     (defun %print-concatenated-stream (s stream d)
892     (declare (ignore d))
893     (format stream "#<Concatenated Stream, Streams = ~S>"
894     (concatenated-stream-streams s)))
895    
896     (setf (documentation 'make-concatenated-stream 'function)
897     "Returns a stream which takes its input from each of the Streams in turn,
898     going on to the next at EOF.")
899    
900     (macrolet ((in-fun (name fun)
901     `(defun ,name (stream eof-errorp eof-value)
902     (do ((current (concatenated-stream-current stream) (cdr current)))
903     ((null current)
904     (eof-or-lose stream eof-errorp eof-value))
905     (let* ((stream (car current))
906     (result (,fun stream nil nil)))
907     (when result (return result)))
908     (setf (concatenated-stream-current stream) current)))))
909     (in-fun concatenated-in read-char)
910     (in-fun concatenated-bin read-byte))
911    
912     (defun concatenated-misc (stream operation &optional arg1 arg2)
913 ram 1.18 (let ((left (concatenated-stream-current stream)))
914     (when left
915 dtc 1.33 (let* ((current (car left)))
916 ram 1.18 (case operation
917     (:listen
918     (loop
919 dtc 1.33 (let ((stuff (if (lisp-stream-p current)
920     (funcall (lisp-stream-misc current) current
921     :listen)
922     (stream-misc-dispatch current :listen))))
923 ram 1.18 (cond ((eq stuff :eof)
924     ;; Advance current, and try again.
925     (pop (concatenated-stream-current stream))
926     (setf current
927     (car (concatenated-stream-current stream)))
928     (unless current
929     ;; No further streams. EOF.
930 dtc 1.33 (return :eof)))
931 ram 1.18 (stuff
932     ;; Stuff's available.
933     (return t))
934     (t
935     ;; Nothing available yet.
936     (return nil))))))
937     (:close
938     (set-closed-flame stream))
939     (t
940 dtc 1.33 (if (lisp-stream-p current)
941     (funcall (lisp-stream-misc current) current operation arg1 arg2)
942     (stream-misc-dispatch current operation arg1 arg2))))))))
943    
944 ram 1.1
945     ;;;; Echo Streams:
946    
947     (defstruct (echo-stream
948     (:include two-way-stream
949     (in #'echo-in)
950     (bin #'echo-bin)
951     (misc #'echo-misc)
952     (n-bin #'ill-bin))
953     (:print-function %print-echo-stream)
954 wlott 1.8 (:constructor make-echo-stream (input-stream output-stream)))
955     unread-stuff)
956 ram 1.1
957    
958 dtc 1.33 (macrolet ((in-fun (name fun out-slot stream-method &rest args)
959 ram 1.1 `(defun ,name (stream ,@args)
960 wlott 1.8 (or (pop (echo-stream-unread-stuff stream))
961     (let* ((in (echo-stream-input-stream stream))
962     (out (echo-stream-output-stream stream))
963     (result (,fun in ,@args)))
964 dtc 1.33 (if (lisp-stream-p out)
965     (funcall (,out-slot out) out result)
966     (,stream-method out result))
967 wlott 1.8 result)))))
968 dtc 1.33 (in-fun echo-in read-char lisp-stream-out stream-write-char
969     eof-errorp eof-value)
970     (in-fun echo-bin read-byte lisp-stream-bout stream-write-byte
971     eof-errorp eof-value))
972 ram 1.1
973     (defun echo-misc (stream operation &optional arg1 arg2)
974     (let* ((in (two-way-stream-input-stream stream))
975 dtc 1.33 (out (two-way-stream-output-stream stream)))
976 ram 1.1 (case operation
977 dtc 1.33 (:listen
978     (or (not (null (echo-stream-unread-stuff stream)))
979     (if (lisp-stream-p in)
980     (or (/= (the fixnum (lisp-stream-in-index in)) in-buffer-length)
981     (funcall (lisp-stream-misc in) in :listen))
982     (stream-misc-dispatch in :listen))))
983 wlott 1.8 (:unread (push arg1 (echo-stream-unread-stuff stream)))
984 ram 1.1 (:element-type
985 dtc 1.33 (let ((in-type (stream-element-type in))
986     (out-type (stream-element-type out)))
987 ram 1.1 (if (equal in-type out-type)
988     in-type `(and ,in-type ,out-type))))
989     (:close
990     (set-closed-flame stream))
991     (t
992 dtc 1.33 (or (if (lisp-stream-p in)
993     (funcall (lisp-stream-misc in) in operation arg1 arg2)
994     (stream-misc-dispatch in operation arg1 arg2))
995     (if (lisp-stream-p out)
996     (funcall (lisp-stream-misc out) out operation arg1 arg2)
997     (stream-misc-dispatch out operation arg1 arg2)))))))
998 ram 1.1
999     (defun %print-echo-stream (s stream d)
1000     (declare (ignore d))
1001     (format stream "#<Echo Stream, Input = ~S, Output = ~S>"
1002     (two-way-stream-input-stream s)
1003     (two-way-stream-output-stream s)))
1004    
1005     (setf (documentation 'make-echo-stream 'function)
1006     "Returns a bidirectional stream which gets its input from Input-Stream and
1007     sends its output to Output-Stream. In addition, all input is echoed to
1008     the output stream")
1009    
1010     ;;;; String Input Streams:
1011    
1012     (defstruct (string-input-stream
1013 dtc 1.30 (:include lisp-stream
1014 ram 1.21 (in #'string-inch)
1015     (bin #'string-binch)
1016     (n-bin #'string-stream-read-n-bytes)
1017     (misc #'string-in-misc))
1018     (:print-function %print-string-input-stream)
1019     ;(:constructor nil)
1020     (:constructor internal-make-string-input-stream
1021     (string current end)))
1022 ram 1.1 (string nil :type simple-string)
1023 dtc 1.31 (current nil :type index)
1024     (end nil :type index))
1025 ram 1.1
1026     (defun %print-string-input-stream (s stream d)
1027     (declare (ignore s d))
1028     (write-string "#<String-Input Stream>" stream))
1029    
1030     (defun string-inch (stream eof-errorp eof-value)
1031     (let ((string (string-input-stream-string stream))
1032     (index (string-input-stream-current stream)))
1033     (declare (simple-string string) (fixnum index))
1034 dtc 1.31 (cond ((= index (the index (string-input-stream-end stream)))
1035 ram 1.1 (eof-or-lose stream eof-errorp eof-value))
1036     (t
1037     (setf (string-input-stream-current stream) (1+ index))
1038     (aref string index)))))
1039 ram 1.21
1040     (defun string-binch (stream eof-errorp eof-value)
1041     (let ((string (string-input-stream-string stream))
1042     (index (string-input-stream-current stream)))
1043 dtc 1.31 (declare (simple-string string)
1044     (type index index))
1045     (cond ((= index (the index (string-input-stream-end stream)))
1046 ram 1.21 (eof-or-lose stream eof-errorp eof-value))
1047     (t
1048     (setf (string-input-stream-current stream) (1+ index))
1049     (char-code (aref string index))))))
1050    
1051     (defun string-stream-read-n-bytes (stream buffer start requested eof-errorp)
1052     (declare (type string-input-stream stream)
1053     (type index start requested))
1054 dtc 1.31 (let* ((string (string-input-stream-string stream))
1055     (index (string-input-stream-current stream))
1056     (available (- (string-input-stream-end stream) index))
1057     (copy (min available requested)))
1058     (declare (simple-string string)
1059     (type index index available copy))
1060     (when (plusp copy)
1061     (setf (string-input-stream-current stream)
1062     (truly-the index (+ index copy)))
1063     (system:without-gcing
1064     (system-area-copy (vector-sap string)
1065     (* index vm:byte-bits)
1066     (if (typep buffer 'system-area-pointer)
1067     buffer
1068     (vector-sap buffer))
1069     (* start vm:byte-bits)
1070     (* copy vm:byte-bits))))
1071     (if (and (> requested copy) eof-errorp)
1072     (error 'end-of-file :stream stream)
1073     copy)))
1074 ram 1.1
1075     (defun string-in-misc (stream operation &optional arg1 arg2)
1076 ram 1.18 (declare (ignore arg2))
1077 ram 1.1 (case operation
1078 ram 1.2 (:file-position
1079 ram 1.5 (if arg1
1080     (setf (string-input-stream-current stream) arg1)
1081     (string-input-stream-current stream)))
1082     (:file-length (length (string-input-stream-string stream)))
1083 ram 1.1 (:unread (decf (string-input-stream-current stream)))
1084 ram 1.10 (:listen (or (/= (the fixnum (string-input-stream-current stream))
1085     (the fixnum (string-input-stream-end stream)))
1086     :eof))
1087 pw 1.27 (:element-type 'base-char)))
1088 ram 1.1
1089     (defun make-string-input-stream (string &optional
1090     (start 0) (end (length string)))
1091     "Returns an input stream which will supply the characters of String between
1092     Start and End in order."
1093 wlott 1.17 (declare (type string string)
1094     (type index start)
1095 ram 1.18 (type (or index null) end))
1096 wlott 1.17 (internal-make-string-input-stream (coerce string 'simple-string)
1097     start end))
1098 ram 1.1
1099     ;;;; String Output Streams:
1100    
1101     (defstruct (string-output-stream
1102 dtc 1.30 (:include lisp-stream
1103 ram 1.1 (out #'string-ouch)
1104     (sout #'string-sout)
1105     (misc #'string-out-misc))
1106     (:print-function %print-string-output-stream)
1107     (:constructor make-string-output-stream ()))
1108     ;; The string we throw stuff in.
1109     (string (make-string 40) :type simple-string)
1110     ;; Index of the next location to use.
1111     (index 0 :type fixnum))
1112    
1113     (defun %print-string-output-stream (s stream d)
1114     (declare (ignore s d))
1115     (write-string "#<String-Output Stream>" stream))
1116    
1117     (setf (documentation 'make-string-output-stream 'function)
1118     "Returns an Output stream which will accumulate all output given it for
1119     the benefit of the function Get-Output-Stream-String.")
1120    
1121     (defun string-ouch (stream character)
1122     (let ((current (string-output-stream-index stream))
1123     (workspace (string-output-stream-string stream)))
1124     (declare (simple-string workspace) (fixnum current))
1125     (if (= current (the fixnum (length workspace)))
1126     (let ((new-workspace (make-string (* current 2))))
1127 wlott 1.17 (replace new-workspace workspace)
1128 ram 1.1 (setf (aref new-workspace current) character)
1129     (setf (string-output-stream-string stream) new-workspace))
1130     (setf (aref workspace current) character))
1131     (setf (string-output-stream-index stream) (1+ current))))
1132    
1133     (defun string-sout (stream string start end)
1134     (declare (simple-string string) (fixnum start end))
1135     (let* ((current (string-output-stream-index stream))
1136     (length (- end start))
1137     (dst-end (+ length current))
1138     (workspace (string-output-stream-string stream)))
1139     (declare (simple-string workspace)
1140     (fixnum current length dst-end))
1141     (if (> dst-end (the fixnum (length workspace)))
1142     (let ((new-workspace (make-string (+ (* current 2) length))))
1143 wlott 1.17 (replace new-workspace workspace :end2 current)
1144     (replace new-workspace string
1145     :start1 current :end1 dst-end
1146     :start2 start :end2 end)
1147 ram 1.1 (setf (string-output-stream-string stream) new-workspace))
1148 wlott 1.17 (replace workspace string
1149     :start1 current :end1 dst-end
1150     :start2 start :end2 end))
1151 ram 1.1 (setf (string-output-stream-index stream) dst-end)))
1152    
1153     (defun string-out-misc (stream operation &optional arg1 arg2)
1154 ram 1.3 (declare (ignore arg2))
1155 ram 1.1 (case operation
1156 ram 1.2 (:file-position
1157     (if (null arg1)
1158 ram 1.3 (string-output-stream-index stream)))
1159 ram 1.1 (:charpos
1160     (do ((index (1- (the fixnum (string-output-stream-index stream)))
1161     (1- index))
1162     (count 0 (1+ count))
1163     (string (string-output-stream-string stream)))
1164     ((< index 0) count)
1165     (declare (simple-string string)
1166     (fixnum index count))
1167     (if (char= (schar string index) #\newline)
1168     (return count))))
1169 pw 1.27 (:element-type 'base-char)))
1170 ram 1.1
1171     (defun get-output-stream-string (stream)
1172     "Returns a string of all the characters sent to a stream made by
1173     Make-String-Output-Stream since the last call to this function."
1174 wlott 1.17 (declare (type string-output-stream stream))
1175     (let* ((length (string-output-stream-index stream))
1176     (result (make-string length)))
1177     (replace result (string-output-stream-string stream))
1178     (setf (string-output-stream-index stream) 0)
1179     result))
1180 ram 1.1
1181     (defun dump-output-stream-string (in-stream out-stream)
1182     "Dumps the characters buffer up in the In-Stream to the Out-Stream as
1183     Get-Output-Stream-String would return them."
1184 dtc 1.30 (write-string* (string-output-stream-string in-stream) out-stream
1185     0 (string-output-stream-index in-stream))
1186 ram 1.1 (setf (string-output-stream-index in-stream) 0))
1187    
1188     ;;;; Fill-pointer streams:
1189     ;;;
1190     ;;; Fill pointer string output streams are not explicitly mentioned in
1191     ;;; the CLM, but they are required for the implementation of With-Output-To-String.
1192    
1193     (defstruct (fill-pointer-output-stream
1194 dtc 1.30 (:include lisp-stream
1195 ram 1.1 (out #'fill-pointer-ouch)
1196     (sout #'fill-pointer-sout)
1197     (misc #'fill-pointer-misc))
1198     (:print-function
1199     (lambda (s stream d)
1200     (declare (ignore s d))
1201     (write-string "#<Fill-Pointer String Output Stream>" stream)))
1202     (:constructor make-fill-pointer-output-stream (string)))
1203     ;; The string we throw stuff in.
1204     string)
1205    
1206    
1207     (defun fill-pointer-ouch (stream character)
1208     (let* ((buffer (fill-pointer-output-stream-string stream))
1209 wlott 1.4 (current (fill-pointer buffer))
1210 ram 1.1 (current+1 (1+ current)))
1211     (declare (fixnum current))
1212     (with-array-data ((workspace buffer) (start) (end))
1213     (declare (simple-string workspace))
1214     (let ((offset-current (+ start current)))
1215     (declare (fixnum offset-current))
1216     (if (= offset-current end)
1217     (let* ((new-length (* current 2))
1218     (new-workspace (make-string new-length)))
1219     (declare (simple-string new-workspace))
1220     (%primitive byte-blt workspace start new-workspace 0 current)
1221     (setf workspace new-workspace)
1222     (setf offset-current current)
1223     (set-array-header buffer workspace new-length
1224     current+1 0 new-length nil))
1225 wlott 1.4 (setf (fill-pointer buffer) current+1))
1226 ram 1.1 (setf (schar workspace offset-current) character)))
1227     current+1))
1228    
1229    
1230     (defun fill-pointer-sout (stream string start end)
1231     (declare (simple-string string) (fixnum start end))
1232     (let* ((buffer (fill-pointer-output-stream-string stream))
1233 wlott 1.4 (current (fill-pointer buffer))
1234 ram 1.1 (string-len (- end start))
1235     (dst-end (+ string-len current)))
1236     (declare (fixnum current dst-end string-len))
1237     (with-array-data ((workspace buffer) (dst-start) (dst-length))
1238     (declare (simple-string workspace))
1239     (let ((offset-dst-end (+ dst-start dst-end))
1240     (offset-current (+ dst-start current)))
1241     (declare (fixnum offset-dst-end offset-current))
1242     (if (> offset-dst-end dst-length)
1243     (let* ((new-length (+ (the fixnum (* current 2)) string-len))
1244     (new-workspace (make-string new-length)))
1245     (declare (simple-string new-workspace))
1246     (%primitive byte-blt workspace dst-start new-workspace 0 current)
1247     (setf workspace new-workspace)
1248     (setf offset-current current)
1249     (setf offset-dst-end dst-end)
1250     (set-array-header buffer workspace new-length
1251     dst-end 0 new-length nil))
1252 wlott 1.4 (setf (fill-pointer buffer) dst-end))
1253 ram 1.1 (%primitive byte-blt string start
1254     workspace offset-current offset-dst-end)))
1255     dst-end))
1256    
1257    
1258     (defun fill-pointer-misc (stream operation &optional arg1 arg2)
1259     (declare (ignore arg1 arg2))
1260     (case operation
1261     (:charpos
1262     (let* ((buffer (fill-pointer-output-stream-string stream))
1263 wlott 1.4 (current (fill-pointer buffer)))
1264 ram 1.1 (with-array-data ((string buffer) (start) (end current))
1265     (declare (simple-string string) (ignore start))
1266     (let ((found (position #\newline string :test #'char=
1267     :end end :from-end t)))
1268     (if found
1269     (- end (the fixnum found))
1270     current)))))
1271 pw 1.27 (:element-type 'base-char)))
1272 ram 1.1
1273     ;;;; Indenting streams:
1274    
1275 dtc 1.30 (defstruct (indenting-stream (:include lisp-stream
1276 ram 1.1 (out #'indenting-out)
1277     (sout #'indenting-sout)
1278     (misc #'indenting-misc))
1279     (:print-function %print-indenting-stream)
1280     (:constructor make-indenting-stream (stream)))
1281     ;; The stream we're based on:
1282     stream
1283     ;; How much we indent on each line:
1284     (indentation 0))
1285    
1286     (setf (documentation 'make-indenting-stream 'function)
1287     "Returns an ouput stream which indents its output by some amount.")
1288    
1289     (defun %print-indenting-stream (s stream d)
1290     (declare (ignore s d))
1291     (write-string "#<Indenting Stream>" stream))
1292    
1293     ;;; Indenting-Indent writes the right number of spaces needed to indent output on
1294     ;;; the given Stream based on the specified Sub-Stream.
1295    
1296     (defmacro indenting-indent (stream sub-stream)
1297     `(do ((i 0 (+ i 60))
1298     (indentation (indenting-stream-indentation ,stream)))
1299     ((>= i indentation))
1300 dtc 1.30 (write-string*
1301     " "
1302     ,sub-stream 0 (min 60 (- indentation i)))))
1303 ram 1.1
1304     ;;; Indenting-Out writes a character to an indenting stream.
1305    
1306     (defun indenting-out (stream char)
1307     (let ((sub-stream (indenting-stream-stream stream)))
1308 dtc 1.30 (write-char char sub-stream)
1309 ram 1.1 (if (char= char #\newline)
1310     (indenting-indent stream sub-stream))))
1311    
1312     ;;; Indenting-Sout writes a string to an indenting stream.
1313    
1314     (defun indenting-sout (stream string start end)
1315     (declare (simple-string string) (fixnum start end))
1316     (do ((i start)
1317     (sub-stream (indenting-stream-stream stream)))
1318     ((= i end))
1319     (let ((newline (position #\newline string :start i :end end)))
1320     (cond (newline
1321 dtc 1.30 (write-string* string sub-stream i (1+ newline))
1322 ram 1.1 (indenting-indent stream sub-stream)
1323     (setq i (+ newline 1)))
1324     (t
1325 dtc 1.30 (write-string* string sub-stream i end)
1326 ram 1.1 (setq i end))))))
1327    
1328     ;;; Indenting-Misc just treats just the :Line-Length message differently.
1329     ;;; Indenting-Charpos says the charpos is the charpos of the base stream minus
1330     ;;; the stream's indentation.
1331    
1332     (defun indenting-misc (stream operation &optional arg1 arg2)
1333 dtc 1.30 (let ((sub-stream (indenting-stream-stream stream)))
1334 dtc 1.33 (if (lisp-stream-p sub-stream)
1335     (let ((method (lisp-stream-misc sub-stream)))
1336     (case operation
1337     (:line-length
1338     (let ((line-length (funcall method sub-stream operation)))
1339     (if line-length
1340     (- line-length (indenting-stream-indentation stream)))))
1341     (:charpos
1342     (let ((charpos (funcall method sub-stream operation)))
1343     (if charpos
1344     (- charpos (indenting-stream-indentation stream)))))
1345     (t
1346     (funcall method sub-stream operation arg1 arg2))))
1347     ;; Fundamental-stream.
1348     (case operation
1349     (:line-length
1350     (let ((line-length (stream-line-length sub-stream)))
1351     (if line-length
1352     (- line-length (indenting-stream-indentation stream)))))
1353     (:charpos
1354     (let ((charpos (stream-line-column sub-stream)))
1355     (if charpos
1356     (- charpos (indenting-stream-indentation stream)))))
1357     (t
1358     (stream-misc-dispatch sub-stream operation arg1 arg2))))))
1359 dtc 1.30
1360 ram 1.1
1361 wlott 1.13 (proclaim '(maybe-inline read-char unread-char read-byte listen))
1362    
1363    
1364    
1365     ;;;; Case frobbing streams, used by format ~(...~).
1366    
1367     (defstruct (case-frob-stream
1368 dtc 1.30 (:include lisp-stream
1369 wlott 1.13 (:misc #'case-frob-misc))
1370     (:constructor %make-case-frob-stream (target out sout)))
1371     (target (required-argument) :type stream))
1372    
1373     (defun make-case-frob-stream (target kind)
1374     "Returns a stream that sends all output to the stream TARGET, but modifies
1375     the case of letters, depending on KIND, which should be one of:
1376     :upcase - convert to upper case.
1377     :downcase - convert to lower case.
1378     :capitalize - convert the first letter of words to upper case and the
1379     rest of the word to lower case.
1380     :capitalize-first - convert the first letter of the first word to upper
1381     case and everything else to lower case."
1382     (declare (type stream target)
1383     (type (member :upcase :downcase :capitalize :capitalize-first)
1384     kind)
1385     (values stream))
1386     (if (case-frob-stream-p target)
1387     ;; If we are going to be writing to a stream that already does case
1388     ;; frobbing, why bother frobbing the case just so it can frob it
1389     ;; again?
1390     target
1391     (multiple-value-bind
1392     (out sout)
1393     (ecase kind
1394     (:upcase
1395     (values #'case-frob-upcase-out
1396     #'case-frob-upcase-sout))
1397     (:downcase
1398     (values #'case-frob-downcase-out
1399     #'case-frob-downcase-sout))
1400     (:capitalize
1401     (values #'case-frob-capitalize-out
1402     #'case-frob-capitalize-sout))
1403     (:capitalize-first
1404     (values #'case-frob-capitalize-first-out
1405     #'case-frob-capitalize-first-sout)))
1406     (%make-case-frob-stream target out sout))))
1407    
1408     (defun case-frob-misc (stream op &optional arg1 arg2)
1409     (declare (type case-frob-stream stream))
1410     (case op
1411     (:close)
1412     (t
1413     (let ((target (case-frob-stream-target stream)))
1414 dtc 1.33 (if (lisp-stream-p target)
1415     (funcall (lisp-stream-misc target) target op arg1 arg2)
1416     (stream-misc-dispatch target op arg1 arg2))))))
1417 wlott 1.13
1418     (defun case-frob-upcase-out (stream char)
1419     (declare (type case-frob-stream stream)
1420 ram 1.16 (type base-char char))
1421 dtc 1.33 (let ((target (case-frob-stream-target stream))
1422     (char (char-upcase char)))
1423     (if (lisp-stream-p target)
1424     (funcall (lisp-stream-out target) target char)
1425     (stream-write-char target char))))
1426 wlott 1.13
1427     (defun case-frob-upcase-sout (stream str start end)
1428     (declare (type case-frob-stream stream)
1429     (type simple-base-string str)
1430     (type index start)
1431     (type (or index null) end))
1432     (let* ((target (case-frob-stream-target stream))
1433     (len (length str))
1434 dtc 1.33 (end (or end len))
1435     (string (if (and (zerop start) (= len end))
1436     (string-upcase str)
1437     (nstring-upcase (subseq str start end))))
1438     (string-len (- end start)))
1439     (if (lisp-stream-p target)
1440     (funcall (lisp-stream-sout target) target string 0 string-len)
1441     (stream-write-string target string 0 string-len))))
1442 wlott 1.13
1443     (defun case-frob-downcase-out (stream char)
1444     (declare (type case-frob-stream stream)
1445 ram 1.16 (type base-char char))
1446 dtc 1.33 (let ((target (case-frob-stream-target stream))
1447     (char (char-downcase char)))
1448     (if (lisp-stream-p target)
1449     (funcall (lisp-stream-out target) target char)
1450     (stream-write-char target char))))
1451 wlott 1.13
1452     (defun case-frob-downcase-sout (stream str start end)
1453     (declare (type case-frob-stream stream)
1454     (type simple-base-string str)
1455     (type index start)
1456     (type (or index null) end))
1457     (let* ((target (case-frob-stream-target stream))
1458     (len (length str))
1459 dtc 1.33 (end (or end len))
1460     (string (if (and (zerop start) (= len end))
1461     (string-downcase str)
1462     (nstring-downcase (subseq str start end))))
1463     (string-len (- end start)))
1464     (if (lisp-stream-p target)
1465     (funcall (lisp-stream-sout target) target string 0 string-len)
1466     (stream-write-string target string 0 string-len))))
1467 wlott 1.13
1468     (defun case-frob-capitalize-out (stream char)
1469     (declare (type case-frob-stream stream)
1470 ram 1.16 (type base-char char))
1471 wlott 1.13 (let ((target (case-frob-stream-target stream)))
1472     (cond ((alphanumericp char)
1473 dtc 1.33 (let ((char (char-upcase char)))
1474     (if (lisp-stream-p target)
1475     (funcall (lisp-stream-out target) target char)
1476     (stream-write-char target char)))
1477     (setf (case-frob-stream-out stream) #'case-frob-capitalize-aux-out)
1478 wlott 1.13 (setf (case-frob-stream-sout stream)
1479     #'case-frob-capitalize-aux-sout))
1480     (t
1481 dtc 1.33 (if (lisp-stream-p target)
1482     (funcall (lisp-stream-out target) target char)
1483     (stream-write-char target char))))))
1484 wlott 1.13
1485     (defun case-frob-capitalize-sout (stream str start end)
1486     (declare (type case-frob-stream stream)
1487     (type simple-base-string str)
1488     (type index start)
1489     (type (or index null) end))
1490     (let* ((target (case-frob-stream-target stream))
1491     (str (subseq str start end))
1492     (len (length str))
1493     (inside-word nil))
1494     (dotimes (i len)
1495     (let ((char (schar str i)))
1496     (cond ((not (alphanumericp char))
1497     (setf inside-word nil))
1498     (inside-word
1499     (setf (schar str i) (char-downcase char)))
1500     (t
1501     (setf inside-word t)
1502     (setf (schar str i) (char-upcase char))))))
1503     (when inside-word
1504     (setf (case-frob-stream-out stream)
1505     #'case-frob-capitalize-aux-out)
1506     (setf (case-frob-stream-sout stream)
1507     #'case-frob-capitalize-aux-sout))
1508 dtc 1.33 (if (lisp-stream-p target)
1509     (funcall (lisp-stream-sout target) target str 0 len)
1510     (stream-write-string target str 0 len))))
1511 wlott 1.13
1512     (defun case-frob-capitalize-aux-out (stream char)
1513     (declare (type case-frob-stream stream)
1514 ram 1.16 (type base-char char))
1515 wlott 1.13 (let ((target (case-frob-stream-target stream)))
1516     (cond ((alphanumericp char)
1517 dtc 1.33 (let ((char (char-downcase char)))
1518     (if (lisp-stream-p target)
1519     (funcall (lisp-stream-out target) target char)
1520     (stream-write-char target char))))
1521 wlott 1.13 (t
1522 dtc 1.33 (if (lisp-stream-p target)
1523     (funcall (lisp-stream-out target) target char)
1524     (stream-write-char target char))
1525 wlott 1.13 (setf (case-frob-stream-out stream)
1526     #'case-frob-capitalize-out)
1527     (setf (case-frob-stream-sout stream)
1528     #'case-frob-capitalize-sout)))))
1529    
1530     (defun case-frob-capitalize-aux-sout (stream str start end)
1531     (declare (type case-frob-stream stream)
1532     (type simple-base-string str)
1533     (type index start)
1534     (type (or index null) end))
1535     (let* ((target (case-frob-stream-target stream))
1536     (str (subseq str start end))
1537     (len (length str))
1538     (inside-word t))
1539     (dotimes (i len)
1540     (let ((char (schar str i)))
1541     (cond ((not (alphanumericp char))
1542     (setf inside-word nil))
1543     (inside-word
1544     (setf (schar str i) (char-downcase char)))
1545     (t
1546     (setf inside-word t)
1547     (setf (schar str i) (char-upcase char))))))
1548     (unless inside-word
1549     (setf (case-frob-stream-out stream)
1550     #'case-frob-capitalize-out)
1551     (setf (case-frob-stream-sout stream)
1552     #'case-frob-capitalize-sout))
1553 dtc 1.33 (if (lisp-stream-p target)
1554     (funcall (lisp-stream-sout target) target str 0 len)
1555     (stream-write-string target str 0 len))))
1556 wlott 1.13
1557     (defun case-frob-capitalize-first-out (stream char)
1558     (declare (type case-frob-stream stream)
1559 ram 1.16 (type base-char char))
1560 wlott 1.13 (let ((target (case-frob-stream-target stream)))
1561     (cond ((alphanumericp char)
1562 dtc 1.33 (let ((char (char-upcase char)))
1563     (if (lisp-stream-p target)
1564     (funcall (lisp-stream-out target) target char)
1565     (stream-write-char target char)))
1566 wlott 1.13 (setf (case-frob-stream-out stream)
1567     #'case-frob-downcase-out)
1568     (setf (case-frob-stream-sout stream)
1569     #'case-frob-downcase-sout))
1570     (t
1571 dtc 1.33 (if (lisp-stream-p target)
1572     (funcall (lisp-stream-out target) target char)
1573     (stream-write-char target char))))))
1574 wlott 1.13
1575     (defun case-frob-capitalize-first-sout (stream str start end)
1576     (declare (type case-frob-stream stream)
1577     (type simple-base-string str)
1578     (type index start)
1579     (type (or index null) end))
1580     (let* ((target (case-frob-stream-target stream))
1581     (str (subseq str start end))
1582     (len (length str)))
1583     (dotimes (i len)
1584     (let ((char (schar str i)))
1585     (when (alphanumericp char)
1586     (setf (schar str i) (char-upcase char))
1587     (do ((i (1+ i) (1+ i)))
1588     ((= i len))
1589     (setf (schar str i) (char-downcase (schar str i))))
1590     (setf (case-frob-stream-out stream)
1591     #'case-frob-downcase-out)
1592     (setf (case-frob-stream-sout stream)
1593     #'case-frob-downcase-sout)
1594     (return))))
1595 dtc 1.33 (if (lisp-stream-p target)
1596     (funcall (lisp-stream-sout target) target str 0 len)
1597     (stream-write-string target str 0 len))))
1598 chiles 1.12
1599    
1600     ;;;; Public interface from "EXTENSIONS" package.
1601    
1602     (defstruct (stream-command (:print-function print-stream-command)
1603     (:constructor make-stream-command
1604     (name &optional args)))
1605     (name nil :type symbol)
1606     (args nil :type list))
1607    
1608     (defun print-stream-command (obj str n)
1609     (declare (ignore n))
1610     (format str "#<Stream-Cmd ~S>" (stream-command-name obj)))
1611    
1612    
1613     ;;; GET-STREAM-COMMAND -- Public.
1614     ;;;
1615 dtc 1.26 ;;; We can't simply call the stream's misc method because nil is an
1616 chiles 1.12 ;;; ambiguous return value: does it mean text arrived, or does it mean the
1617     ;;; stream's misc method had no :get-command implementation. We can't return
1618     ;;; nil until there is text input. We don't need to loop because any stream
1619     ;;; implementing :get-command would wait until it had some input. If the
1620     ;;; LISTEN fails, then we have some random stream we must wait on.
1621     ;;;
1622     (defun get-stream-command (stream)
1623     "This takes a stream and waits for text or a command to appear on it. If
1624     text appears before a command, this returns nil, and otherwise it returns
1625     a command."
1626 dtc 1.30 (let ((cmdp (funcall (lisp-stream-misc stream) stream :get-command)))
1627 chiles 1.12 (cond (cmdp)
1628     ((listen stream)
1629     nil)
1630     (t
1631     ;; This waits for input and returns nil when it arrives.
1632     (unread-char (read-char stream) stream)))))
1633 dtc 1.26
1634    
1635     ;;; READ-SEQUENCE -- Public
1636     ;;;
1637     (defun read-sequence (seq stream &key (start 0) (end nil))
1638     "Destructively modify SEQ by reading elements from STREAM.
1639     SEQ is bounded by START and END. SEQ is destructively modified by
1640     copying successive elements into it from STREAM. If the end of file
1641     for STREAM is reached before copying all elements of the subsequence,
1642     then the extra elements near the end of sequence are not updated, and
1643     the index of the next element is returned."
1644     (declare (type sequence seq)
1645     (type stream stream)
1646     (type index start)
1647     (type sequence-end end)
1648     (values index))
1649     (let ((end (or end (length seq))))
1650     (declare (type index end))
1651     (etypecase seq
1652     (list
1653     (let ((read-function
1654     (if (subtypep (stream-element-type stream) 'character)
1655     #'read-char
1656     #'read-byte)))
1657     (do ((rem (nthcdr start seq) (rest rem))
1658     (i start (1+ i)))
1659     ((or (endp rem) (>= i end)) i)
1660     (declare (type list rem)
1661     (type index i))
1662 dtc 1.31 (let ((el (funcall read-function stream nil :eof)))
1663     (when (eq el :eof)
1664 dtc 1.26 (return i))
1665     (setf (first rem) el)))))
1666     (vector
1667     (with-array-data ((data seq) (offset-start start) (offset-end end))
1668 dtc 1.31 (typecase data
1669     ((or (simple-array (unsigned-byte 8) (*))
1670     #+signed-array (simple-array (signed-byte 8) (*))
1671     simple-string)
1672     (let* ((numbytes (- end start))
1673     (bytes-read (system:read-n-bytes
1674     stream data offset-start numbytes nil)))
1675     (if (< bytes-read numbytes)
1676     (+ start bytes-read)
1677     end)))
1678     (t
1679     (let ((read-function
1680     (if (subtypep (stream-element-type stream) 'character)
1681     #'read-char
1682     #'read-byte)))
1683     (do ((i offset-start (1+ i)))
1684     ((>= i offset-end) end)
1685     (declare (type index i))
1686     (let ((el (funcall read-function stream nil :eof)))
1687     (when (eq el :eof)
1688     (return (+ start (- i offset-start))))
1689     (setf (aref data i) el)))))))))))
1690 dtc 1.26
1691     ;;; WRITE-SEQUENCE -- Public
1692     ;;;
1693     (defun write-sequence (seq stream &key (start 0) (end nil))
1694     "Write the elements of SEQ bounded by START and END to STREAM."
1695     (declare (type sequence seq)
1696     (type stream stream)
1697     (type index start)
1698     (type sequence-end end)
1699     (values sequence))
1700     (let ((end (or end (length seq))))
1701     (declare (type index start end))
1702     (etypecase seq
1703     (list
1704     (let ((write-function
1705     (if (subtypep (stream-element-type stream) 'character)
1706     #'write-char
1707     #'write-byte)))
1708     (do ((rem (nthcdr start seq) (rest rem))
1709     (i start (1+ i)))
1710     ((or (endp rem) (>= i end)) seq)
1711     (declare (type list rem)
1712     (type index i))
1713     (funcall write-function (first rem) stream))))
1714     (string
1715 dtc 1.30 (write-string* seq stream start end))
1716 dtc 1.26 (vector
1717     (let ((write-function
1718     (if (subtypep (stream-element-type stream) 'character)
1719     #'write-char
1720     #'write-byte)))
1721     (do ((i start (1+ i)))
1722     ((>= i end) seq)
1723     (declare (type index i))
1724     (funcall write-function (aref seq i) stream)))))))

  ViewVC Help
Powered by ViewVC 1.1.5