3 ;;; **********************************************************************
4 ;;; This code was written by Paul Foley and has been placed in the public
8 ;;; Sbcl port by Rudi Schlatte.
10 (in-package "SB-SIMPLE-STREAMS")
13 ;;; **********************************************************************
15 ;;; Strategy functions for base simple-stream classes
19 (defun refill-buffer (stream blocking)
20 (with-stream-class (simple-stream stream)
21 (let* ((unread (sm last-char-read-size stream))
22 (buffer (sm buffer stream))
23 (bufptr (sm buffer-ptr stream)))
24 (unless (or (zerop unread) (zerop bufptr))
25 (buffer-copy buffer (- bufptr unread) buffer 0 unread))
26 (let ((bytes (device-read stream nil unread nil blocking)))
27 (declare (type fixnum bytes))
28 (setf (sm buffpos stream) unread
29 (sm buffer-ptr stream) (if (plusp bytes)
34 (defun sc-set-dirty (stream)
35 (with-stream-class (single-channel-simple-stream stream)
36 (setf (sm mode stream)
37 (if (<= (sm buffpos stream)
38 (sm buffer-ptr stream))
43 (defun sc-set-clean (stream)
44 (with-stream-class (single-channel-simple-stream stream)
45 (setf (sm mode stream) 0)))
47 (defun sc-dirty-p (stream)
48 (with-stream-class (single-channel-simple-stream stream)
49 (> (sm mode stream) 0)))
51 (defun flush-buffer (stream blocking)
52 (with-stream-class (single-channel-simple-stream stream)
54 (bytes (sm buffpos stream)))
55 (declare (type fixnum ptr bytes))
56 (when (and (> (sm mode stream) 0) (> (sm buffer-ptr stream) 0))
57 ;; The data read in from the file could have been changed if
58 ;; the stream is opened in read-write mode -- write back
59 ;; everything in the buffer at the correct position just in
61 (setf (device-file-position stream)
62 (- (device-file-position stream) (sm buffer-ptr stream))))
64 (when (>= ptr bytes) (setf (sm buffpos stream) 0) (setf (sm mode stream) 0) (return 0))
65 (let ((bytes-written (device-write stream nil ptr nil blocking)))
66 (declare (fixnum bytes-written))
67 (when (minusp bytes-written)
68 (error "DEVICE-WRITE error."))
69 (incf ptr bytes-written))))))
71 (defun flush-out-buffer (stream blocking)
72 (with-stream-class (dual-channel-simple-stream stream)
74 (bytes (sm outpos stream)))
75 (declare (type fixnum ptr bytes))
77 (when (>= ptr bytes) (setf (sm outpos stream) 0) (return 0))
78 (let ((bytes-written (device-write stream nil ptr nil blocking)))
79 (declare (fixnum bytes-written))
80 (when (minusp bytes-written)
81 (error "DEVICE-WRITE error."))
82 (incf ptr bytes-written))))))
84 (defun read-byte-internal (stream eof-error-p eof-value blocking)
85 (with-stream-class (simple-stream stream)
86 (let ((ptr (sm buffpos stream)))
87 (when (>= ptr (sm buffer-ptr stream))
88 (let ((bytes (device-read stream nil 0 nil blocking)))
89 (declare (type fixnum bytes))
91 (setf (sm buffer-ptr stream) bytes
93 (return-from read-byte-internal
94 (sb-impl::eof-or-lose stream eof-error-p eof-value)))))
95 (setf (sm buffpos stream) (1+ ptr))
96 (setf (sm last-char-read-size stream) 0)
97 (setf (sm charpos stream) nil)
98 (bref (sm buffer stream) ptr))))
100 ;;;; Single-Channel-Simple-Stream strategy functions
103 (declaim (ftype j-listen-fn sc-listen-ef))
104 (defun sc-listen-ef (stream)
105 (with-stream-class (simple-stream stream)
106 (let ((lcrs (sm last-char-read-size stream))
107 (buffer (sm buffer stream))
108 (buffpos (sm buffpos stream))
113 (when (>= buffpos (sm buffer-ptr stream))
114 (let ((bytes (refill-buffer stream nil)))
116 (return-from sc-listen-ef nil))
118 (return-from sc-listen-ef t))
120 (setf buffpos (sm buffpos stream))))))
121 (incf (sm last-char-read-size stream))
122 (prog1 (bref buffer buffpos)
126 (setq char (octets-to-char (sm external-format stream)
128 cnt #'input #'unput))
130 (setf (sm last-char-read-size stream) lcrs)))))
132 (declaim (ftype j-read-char-fn sc-read-char-ef))
133 (defun sc-read-char-ef (stream eof-error-p eof-value blocking)
134 #|(declare (optimize (speed 3) (space 2) (safety 0) (debug 0)))|#
135 (with-stream-class (simple-stream stream)
136 (let* ((buffer (sm buffer stream))
137 (buffpos (sm buffpos stream))
138 (ctrl (sm control-in stream))
139 (ef (sm external-format stream))
140 (state (sm oc-state stream)))
142 (when (>= buffpos (sm buffer-ptr stream))
143 (when (sc-dirty-p stream)
144 (flush-buffer stream t))
145 (let ((bytes (refill-buffer stream blocking)))
147 (return-from sc-read-char-ef nil))
149 (return-from sc-read-char-ef
150 (sb-impl::eof-or-lose stream eof-error-p eof-value)))
152 (setf buffpos (sm buffpos stream))))))
153 (incf (sm last-char-read-size stream))
154 (prog1 (bref buffer buffpos)
159 (char (octets-to-char ef state cnt #'input #'unput))
160 (code (char-code char)))
161 (setf (sm buffpos stream) buffpos
162 (sm last-char-read-size stream) cnt
163 (sm oc-state stream) state)
164 (when (and (< code 32) ctrl (svref ctrl code))
165 (setq char (funcall (the (or symbol function) (svref ctrl code))
168 (sb-impl::eof-or-lose stream eof-error-p eof-value)
172 (declaim (ftype j-read-char-fn sc-read-char-ef-mapped))
173 (defun sc-read-char-ef-mapped (stream eof-error-p eof-value blocking)
174 #|(declare (optimize (speed 3) (space 2) (safety 0) (debug 0)))|#
175 (declare (ignore blocking))
176 (with-stream-class (simple-stream stream)
177 (let* ((buffer (sm buffer stream))
178 (buffpos (sm buffpos stream))
179 (ctrl (sm control-in stream))
180 (ef (sm external-format stream))
181 (state (sm oc-state stream)))
183 (when (>= buffpos (sm buffer-ptr stream))
184 (return-from sc-read-char-ef-mapped
185 (sb-impl::eof-or-lose stream eof-error-p eof-value)))
186 (incf (sm last-char-read-size stream))
187 (prog1 (bref buffer buffpos)
192 (char (octets-to-char ef state cnt #'input #'unput))
193 (code (char-code char)))
194 (setf (sm buffpos stream) buffpos
195 (sm last-char-read-size stream) cnt
196 (sm oc-state stream) state)
197 (when (and (< code 32) ctrl (svref ctrl code))
198 (setq char (funcall (the (or symbol function) (svref ctrl code))
201 (sb-impl::eof-or-lose stream eof-error-p eof-value)
205 (declaim (ftype j-read-chars-fn sc-read-chars-ef))
206 (defun sc-read-chars-ef (stream string search start end blocking)
207 ;; string is filled from START to END, or until SEARCH is found
208 ;; Return two values: count of chars read and
209 ;; NIL if SEARCH was not found
210 ;; T if SEARCH was found
211 ;; :EOF if eof encountered before end
212 (declare (type simple-stream stream)
214 (type (or null character) search)
215 (type fixnum start end)
216 (type boolean blocking)
217 #|(optimize (speed 3) (space 2) (safety 0) (debug 0))|#)
218 (with-stream-class (simple-stream stream)
219 (when (sc-dirty-p stream)
220 (flush-buffer stream t))
221 (do ((buffer (sm buffer stream))
222 (buffpos (sm buffpos stream))
223 (buffer-ptr (sm buffer-ptr stream))
225 (ctrl (sm control-in stream))
226 (ef (sm external-format stream))
227 (state (sm oc-state stream))
228 (posn start (1+ posn))
229 (count 0 (1+ count)))
231 (setf (sm buffpos stream) buffpos
232 (sm last-char-read-size stream) lcrs
233 (sm oc-state stream) state)
235 (declare (type sb-int:index buffpos buffer-ptr posn count))
237 (when (>= buffpos buffer-ptr)
238 (setf (sm last-char-read-size stream) lcrs)
239 (let ((bytes (refill-buffer stream blocking)))
240 (declare (type fixnum bytes))
241 (setf buffpos (sm buffpos stream)
242 buffer-ptr (sm buffer-ptr stream))
243 (unless (plusp bytes)
244 (setf (sm buffpos stream) buffpos
245 (sm last-char-read-size stream) lcrs
246 (sm oc-state stream) state)
248 (return (values count nil))
249 (return (values count :eof))))))
250 (prog1 (bref buffer buffpos)
256 (char (octets-to-char ef state cnt #'input #'unput))
257 (code (char-code char)))
259 (when (and (< code 32) ctrl (svref ctrl code))
260 (setq char (funcall (the (or symbol function) (svref ctrl code))
263 (setf (sm buffpos stream) buffpos
264 (sm last-char-read-size stream) lcrs
265 (sm oc-state stream) state)
266 (return (values count :eof)))
267 ((and search (char= char search))
268 (setf (sm buffpos stream) buffpos
269 (sm last-char-read-size stream) lcrs
270 (sm oc-state stream) state)
271 (return (values count t)))
273 (setf (char string posn) char))))))))
276 (declaim (ftype j-read-chars-fn sc-read-chars-ef-mapped))
277 (defun sc-read-chars-ef-mapped (stream string search start end blocking)
278 ;; string is filled from START to END, or until SEARCH is found
279 ;; Return two values: count of chars read and
280 ;; NIL if SEARCH was not found
281 ;; T if SEARCH was found
282 ;; :EOF if eof encountered before end
283 (declare (type simple-stream stream)
285 (type (or null character) search)
286 (type fixnum start end)
287 (type boolean blocking)
289 #|(optimize (speed 3) (space 2) (safety 0) (debug 0))|#)
290 (with-stream-class (simple-stream stream)
291 ;; if stream is single-channel and mode == 3, flush buffer (if dirty)
292 (do ((buffer (sm buffer stream))
293 (buffpos (sm buffpos stream))
294 (buffer-ptr (sm buffer-ptr stream))
296 (ctrl (sm control-in stream))
297 (ef (sm external-format stream))
298 (state (sm oc-state stream))
299 (posn start (1+ posn))
300 (count 0 (1+ count)))
302 (setf (sm buffpos stream) buffpos
303 (sm last-char-read-size stream) lcrs
304 (sm oc-state stream) state)
306 (declare (type sb-int:index buffpos buffer-ptr posn count))
308 (when (>= buffpos buffer-ptr)
309 (return (values count :eof)))
310 (prog1 (bref buffer buffpos)
316 (char (octets-to-char ef state cnt #'input #'unput))
317 (code (char-code char)))
319 (when (and (< code 32) ctrl (svref ctrl code))
320 (setq char (funcall (the (or symbol function) (svref ctrl code))
323 (setf (sm buffpos stream) buffpos
324 (sm last-char-read-size stream) lcrs
325 (sm oc-state stream) state)
326 (return (values count :eof)))
327 ((and search (char= char search))
328 (setf (sm buffpos stream) buffpos
329 (sm last-char-read-size stream) lcrs
330 (sm oc-state stream) state)
331 (return (values count t)))
333 (setf (char string posn) char))))))))
336 (declaim (ftype j-unread-char-fn sc-unread-char-ef))
337 (defun sc-unread-char-ef (stream relaxed)
338 (declare (ignore relaxed))
339 (with-stream-class (simple-stream stream)
340 (let ((unread (sm last-char-read-size stream)))
341 (if (>= (sm buffpos stream) unread)
342 (decf (sm buffpos stream) unread)
343 (error "This shouldn't happen.")))))
345 (declaim (ftype j-write-char-fn sc-write-char-ef))
346 (defun sc-write-char-ef (character stream)
348 (with-stream-class (single-channel-simple-stream stream)
349 (let ((buffer (sm buffer stream))
350 (buffpos (sm buffpos stream))
351 (buf-len (sm buf-len stream))
352 (code (char-code character))
353 (ctrl (sm control-out stream)))
354 (when (and (< code 32) ctrl (svref ctrl code)
355 (funcall (the (or symbol function) (svref ctrl code))
357 (return-from sc-write-char-ef character))
358 (flet ((output (byte)
359 (when (>= buffpos buf-len)
360 (setf (sm buffpos stream) buffpos)
361 (setq buffpos (flush-buffer stream t)))
362 (setf (bref buffer buffpos) byte)
364 (char-to-octets (sm external-format stream) character
365 (sm co-state stream) #'output))
366 (setf (sm buffpos stream) buffpos)
367 (sc-set-dirty stream)
368 (if (sm charpos stream) (incf (sm charpos stream))))))
371 (declaim (ftype j-write-chars-fn sc-write-chars-ef))
372 (defun sc-write-chars-ef (string stream start end)
373 (with-stream-class (single-channel-simple-stream stream)
374 (do ((buffer (sm buffer stream))
375 (buffpos (sm buffpos stream))
376 (buf-len (sm buf-len stream))
377 (ef (sm external-format stream))
378 (ctrl (sm control-out stream))
379 (posn start (1+ posn))
380 (count 0 (1+ count)))
381 ((>= posn end) (setf (sm buffpos stream) buffpos) count)
382 (declare (type fixnum buffpos buf-len posn count))
383 (let* ((char (char string posn))
384 (code (char-code char)))
385 (unless (and (< code 32) ctrl (svref ctrl code)
386 (funcall (the (or symbol function) (svref ctrl code))
388 (flet ((output (byte)
389 (when (>= buffpos buf-len)
390 (setf (sm buffpos stream) buffpos)
391 (setq buffpos (flush-buffer stream t)))
392 (setf (bref buffer buffpos) byte)
394 (char-to-octets ef char (sm co-state stream) #'output))
395 (setf (sm buffpos stream) buffpos)
396 (if (sm charpos stream) (incf (sm charpos stream)))
397 (sc-set-dirty stream))))))
400 ;;;; Dual-Channel-Simple-Stream strategy functions
402 ;; single-channel read-side functions work for dual-channel streams too
404 (declaim (ftype j-write-char-fn dc-write-char-ef))
405 (defun dc-write-char-ef (character stream)
407 (with-stream-class (dual-channel-simple-stream stream)
408 (let ((out-buffer (sm out-buffer stream))
409 (outpos (sm outpos stream))
410 (max-out-pos (sm max-out-pos stream))
411 (code (char-code character))
412 (ctrl (sm control-out stream)))
413 (when (and (< code 32) ctrl (svref ctrl code)
414 (funcall (the (or symbol function) (svref ctrl code))
416 (return-from dc-write-char-ef character))
417 (flet ((output (byte)
418 (when (>= outpos max-out-pos)
419 (setf (sm outpos stream) outpos)
420 (setq outpos (flush-out-buffer stream t)))
421 (setf (bref out-buffer outpos) byte)
423 (char-to-octets (sm external-format stream) character
424 (sm co-state stream) #'output))
425 (setf (sm outpos stream) outpos)
426 (if (sm charpos stream) (incf (sm charpos stream))))))
430 (declaim (ftype j-write-chars-fn dc-write-chars-ef))
431 (defun dc-write-chars-ef (string stream start end)
432 (with-stream-class (dual-channel-simple-stream stream)
433 (do ((buffer (sm out-buffer stream))
434 (outpos (sm outpos stream))
435 (max-out-pos (sm max-out-pos stream))
436 (ef (sm external-format stream))
437 (ctrl (sm control-out stream))
438 (posn start (1+ posn))
439 (count 0 (1+ count)))
440 ((>= posn end) (setf (sm outpos stream) outpos) count)
441 (declare (type fixnum outpos max-out-pos posn count))
442 (let* ((char (char string posn))
443 (code (char-code char)))
444 (unless (and (< code 32) ctrl (svref ctrl code)
445 (funcall (the (or symbol function) (svref ctrl code))
447 (flet ((output (byte)
448 (when (>= outpos max-out-pos)
449 (setf (sm outpos stream) outpos)
450 (setq outpos (flush-out-buffer stream t)))
451 (setf (bref buffer outpos) byte)
453 (char-to-octets ef char (sm co-state stream) #'output))
454 (setf (sm outpos stream) outpos)
455 (if (sm charpos stream) (incf (sm charpos stream))))))))
457 ;;;; String-Simple-Stream strategy functions
459 (declaim (ftype j-read-char-fn str-read-char))
460 (defun str-read-char (stream eof-error-p eof-value blocking)
461 (declare (type string-input-simple-stream stream) (ignore blocking)
462 #|(optimize (speed 3) (space 2) (safety 0) (debug 0))|#
464 (with-stream-class (string-input-simple-stream stream)
465 (when (any-stream-instance-flags stream :eof)
466 (sb-impl::eof-or-lose stream eof-error-p eof-value))
467 (let* ((ptr (sm buffpos stream))
468 (char (if (< ptr (sm buffer-ptr stream))
469 (schar (sm buffer stream) ptr)
472 (sb-impl::eof-or-lose stream eof-error-p eof-value)
474 (setf (sm last-char-read-size stream) 1)
475 ;; do string-streams do control-in processing?
476 #|(let ((column (sm charpos stream)))
477 (declare (type (or null fixnum) column))
479 (setf (sm charpos stream) (1+ column))))
483 (declaim (ftype j-listen-fn str-listen-e-crlf))
484 (defun str-listen-e-crlf (stream)
485 (with-stream-class (composing-stream stream)
486 ;; if this says there's a character available, it may be #\Return,
487 ;; in which case read-char will only return if there's a following
488 ;; #\Linefeed, so this really has to read the char...
489 ;; but without precluding the later unread-char of a character which
490 ;; has already been read.
491 (funcall-stm-handler j-listen (sm melded-stream stream))))
493 (declaim (ftype j-read-char-fn str-read-char-e-crlf))
494 (defun str-read-char-e-crlf (stream eof-error-p eof-value blocking)
495 (with-stream-class (composing-stream stream)
496 (let* ((encap (sm melded-stream stream))
497 (ctrl (sm control-in stream))
498 (char (funcall-stm-handler j-read-char encap nil stream blocking)))
499 ;; if CHAR is STREAM, we hit EOF; if NIL, blocking is NIL and no
500 ;; character was available...
501 (when (eql char #\Return)
502 (let ((next (funcall-stm-handler j-read-char encap nil stream blocking)))
503 ;; if NEXT is STREAM, we hit EOF, so we should just return the
504 ;; #\Return (and mark the stream :EOF? At least unread if we
505 ;; got a soft EOF, from a terminal, etc.
506 ;; if NEXT is NIL, blocking is NIL and there's a CR but no
507 ;; LF available on the stream: have to unread the CR and
508 ;; return NIL, letting the CR be reread later.
510 ;; If we did get a linefeed, adjust the last-char-read-size
511 ;; so that an unread of the resulting newline will unread both
512 ;; the linefeed _and_ the carriage return.
513 (if (eql next #\Linefeed)
514 (setq char #\Newline)
515 (funcall-stm-handler j-unread-char encap nil))))
516 (when (characterp char)
517 (let ((code (char-code char)))
518 (when (and (< code 32) ctrl (svref ctrl code))
519 (setq char (funcall (the (or symbol function) (svref ctrl code))
522 (sb-impl::eof-or-lose stream eof-error-p eof-value)
525 (declaim (ftype j-unread-char-fn str-unread-char-e-crlf))
526 (defun str-unread-char-e-crlf (stream relaxed)
527 (declare (ignore relaxed))
528 (with-stream-class (composing-stream stream)
529 (funcall-stm-handler j-unread-char (sm melded-stream stream) nil)))
532 ;;; Functions to install the strategy functions in the appropriate slots
534 (defun melding-stream (stream)
535 (with-stream-class (simple-stream)
536 (do ((stm stream (sm melded-stream stm)))
537 ((eq (sm melded-stream stm) stream) stm))))
539 (defun meld (stream encap)
540 (with-stream-class (simple-stream)
541 (setf (sm melding-base encap) (sm melding-base stream))
542 (setf (sm melded-stream encap) (sm melded-stream stream))
543 (setf (sm melded-stream stream) encap)
544 (rotatef (sm j-listen encap) (sm j-listen stream))
545 (rotatef (sm j-read-char encap) (sm j-read-char stream))
546 (rotatef (sm j-read-chars encap) (sm j-read-chars stream))
547 (rotatef (sm j-unread-char encap) (sm j-unread-char stream))
548 (rotatef (sm j-write-char encap) (sm j-write-char stream))
549 (rotatef (sm j-write-chars encap) (sm j-write-chars stream))))
551 (defun unmeld (stream)
552 (with-stream-class (simple-stream)
553 (let ((encap (sm melded-stream stream)))
554 (unless (eq encap (sm melding-base stream))
555 (setf (sm melding-base encap) encap)
556 (setf (sm melded-stream stream) (sm melded-stream encap))
557 (setf (sm melded-stream encap) encap)
558 (rotatef (sm j-listen stream) (sm j-listen encap))
559 (rotatef (sm j-read-char encap) (sm j-read-char stream))
560 (rotatef (sm j-read-chars stream) (sm j-read-chars encap))
561 (rotatef (sm j-unread-char stream) (sm j-unread-char encap))
562 (rotatef (sm j-write-char stream) (sm j-write-char encap))
563 (rotatef (sm j-write-chars stream) (sm j-write-chars encap))))))
565 ;;; In cmucl, this is done with define-function-name-syntax (lists as
566 ;;; function names), we make do with symbol frobbing.
567 (defun %sf (kind name format &optional access)
568 (flet ((find-strategy-function (&rest args)
570 (fdefinition (find-symbol (format nil "~{~A~^-~}"
571 (mapcar #'string args))
573 (or (find-strategy-function kind name format access)
574 (find-strategy-function kind name format)
575 (find-strategy-function kind name :ef access)
576 (find-strategy-function kind name :ef))))
579 (defun install-single-channel-character-strategy (stream external-format
581 (let ((format (find-external-format external-format)))
582 ;; ACCESS is usually NIL
583 ;; May be "undocumented" values: stream::buffer, stream::mapped
584 ;; to install strategies suitable for direct buffer streams
585 ;; (i.e., ones that call DEVICE-EXTEND instead of DEVICE-READ)
586 ;; (Avoids checking "mode" flags by installing special strategy)
587 (with-stream-class (simple-stream stream)
588 (setf (sm j-listen stream)
589 (%sf 'sc 'listen (ef-name format) access)
590 (sm j-read-char stream)
591 (%sf 'sc 'read-char (ef-name format) access)
592 (sm j-read-chars stream)
593 (%sf 'sc 'read-chars (ef-name format) access)
594 (sm j-unread-char stream)
595 (%sf 'sc 'unread-char (ef-name format) access)
596 (sm j-write-char stream)
597 (%sf 'sc 'write-char (ef-name format) access)
598 (sm j-write-chars stream)
599 (%sf 'sc 'write-chars (ef-name format) access))))
602 (defun install-dual-channel-character-strategy (stream external-format)
603 (let ((format (find-external-format external-format)))
604 (with-stream-class (simple-stream stream)
605 (setf (sm j-listen stream)
606 (%sf 'sc 'listen (ef-name format))
607 (sm j-read-char stream)
608 (%sf 'sc 'read-char (ef-name format))
609 (sm j-read-chars stream)
610 (%sf 'sc 'read-chars (ef-name format))
611 (sm j-unread-char stream)
612 (%sf 'sc 'unread-char (ef-name format))
613 (sm j-write-char stream)
614 (%sf 'dc 'write-char (ef-name format))
615 (sm j-write-chars stream)
616 (%sf 'dc 'write-chars (ef-name format)))))
619 ;; Deprecated -- use install-string-{input,output}-character-strategy instead!
620 (defun install-string-character-strategy (stream)
621 (when (any-stream-instance-flags stream :input)
622 (install-string-input-character-strategy stream))
623 (when (any-stream-instance-flags stream :output)
624 (install-string-output-character-strategy stream))
627 (defun install-string-input-character-strategy (stream)
629 (with-stream-class (simple-stream stream)
630 (setf (sm j-read-char stream) #'str-read-char))
633 (defun install-string-output-character-strategy (stream)
637 (defun install-composing-format-character-strategy (stream composing-format)
638 (let ((format composing-format))
639 (with-stream-class (simple-stream stream)
641 (:e-crlf (setf (sm j-read-char stream) #'str-read-char-e-crlf
642 (sm j-unread-char stream) #'str-unread-char-e-crlf))))
646 (defun compose-encapsulating-streams (stream external-format)
647 (when (consp external-format)
648 (with-stream-class (simple-stream)
649 (let ((encap (if (eq (sm melded-stream stream) stream)
651 (sm melded-stream stream))))
653 (setq encap (make-instance 'composing-stream))
655 (setf (stream-external-format encap) (car (last external-format)))
656 (setf (sm external-format stream) external-format)
657 (install-composing-format-character-strategy stream
658 (butlast external-format))
661 (defmethod (setf stream-external-format) (ef (stream simple-stream))
662 (with-stream-class (simple-stream stream)
663 (setf (sm external-format stream) (find-external-format ef)))
667 ;;; NULL STRATEGY FUNCTIONS
670 (declaim (ftype j-read-char-fn null-read-char))
671 (defun null-read-char (stream eof-error-p eof-value blocking)
672 (declare (ignore blocking))
673 (sb-impl::eof-or-lose stream eof-error-p eof-value))
675 (declaim (ftype j-read-chars-fn null-read-chars))
676 (defun null-read-chars (stream string search start end blocking)
677 (declare (ignore stream string search start end blocking))
680 (declaim (ftype j-unread-char-fn null-unread-char))
681 (defun null-unread-char (stream relaxed)
682 (declare (ignore stream relaxed)))
684 (declaim (ftype j-write-char-fn null-write-char))
685 (defun null-write-char (character stream)
686 (declare (ignore stream))
689 (declaim (ftype j-write-chars-fn null-write-chars))
690 (defun null-write-chars (string stream start end)
691 (declare (ignore string stream))
694 (declaim (ftype j-listen-fn null-listen))
695 (defun null-listen (stream)
696 (declare (ignore stream))