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

Contents of /src/code/stream.lisp

Parent Directory Parent Directory | Revision Log Revision Log


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

  ViewVC Help
Powered by ViewVC 1.1.5