X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=contrib%2Fsb-simple-streams%2Fstrategy.lisp;h=38c4e9345a124f6f7c9c73a05328eb1194bd1966;hb=2fb9cd4a2286b82e065d6c673d91e46bd7f2194d;hp=ebbddf3fdd8ddafb60098a24782a5a406a8cdf70;hpb=68da29d2cd0b71b76c071102efbc807783657473;p=sbcl.git

diff --git a/contrib/sb-simple-streams/strategy.lisp b/contrib/sb-simple-streams/strategy.lisp
index ebbddf3..38c4e93 100644
--- a/contrib/sb-simple-streams/strategy.lisp
+++ b/contrib/sb-simple-streams/strategy.lisp
@@ -3,7 +3,7 @@
 ;;; **********************************************************************
 ;;; This code was written by Paul Foley and has been placed in the public
 ;;; domain.
-;;; 
+;;;
 
 ;;; Sbcl port by Rudi Schlatte.
 
@@ -17,10 +17,11 @@
 ;;;; Helper functions
 
 (defun refill-buffer (stream blocking)
+  (declare (type blocking blocking))
   (with-stream-class (simple-stream stream)
     (let* ((unread (sm last-char-read-size stream))
            (buffer (sm buffer stream))
-	   (bufptr (sm buffer-ptr stream)))
+           (bufptr (sm buffer-ptr stream)))
       (unless (or (zerop unread) (zerop bufptr))
         (buffer-copy buffer (- bufptr unread) buffer 0 unread))
       (let ((bytes (device-read stream nil unread nil blocking)))
@@ -104,69 +105,70 @@
 (defun sc-listen-ef (stream)
   (with-stream-class (simple-stream stream)
     (let ((lcrs (sm last-char-read-size stream))
-	  (buffer (sm buffer stream))
-	  (buffpos (sm buffpos stream))
-	  (cnt 0)
-	  (char nil))
+          (buffer (sm buffer stream))
+          (buffpos (sm buffpos stream))
+          (cnt 0)
+          (char nil))
       (unwind-protect
-	   (flet ((input ()
-		    (when (>= buffpos (sm buffer-ptr stream))
-		      (let ((bytes (refill-buffer stream nil)))
-			(cond ((= bytes 0)
-			       (return-from sc-listen-ef nil))
-			      ((< bytes 0)
-			       (return-from sc-listen-ef t))
-			      (t
-			       (setf buffpos (sm buffpos stream))))))
-		    (incf (sm last-char-read-size stream))
-		    (prog1 (bref buffer buffpos)
-		      (incf buffpos)))
-		  (unput (n)
-		    (decf buffpos n)))
-	     (setq char (octets-to-char (sm external-format stream)
-					(sm oc-state stream)
-					cnt #'input #'unput))
-	     (characterp char))
-	(setf (sm last-char-read-size stream) lcrs)))))
+           (flet ((input ()
+                    (when (>= buffpos (sm buffer-ptr stream))
+                      (let ((bytes (refill-buffer stream nil)))
+                        (cond ((= bytes 0)
+                               (return-from sc-listen-ef nil))
+                              ((< bytes 0)
+                               (return-from sc-listen-ef t))
+                              (t
+                               (setf buffpos (sm buffpos stream))))))
+                    (incf (sm last-char-read-size stream))
+                    (prog1 (bref buffer buffpos)
+                      (incf buffpos)))
+                  (unput (n)
+                    (decf buffpos n)))
+             (setq char (octets-to-char (sm external-format stream)
+                                        (sm oc-state stream)
+                                        cnt #'input #'unput))
+             (characterp char))
+        (setf (sm last-char-read-size stream) lcrs)))))
 
 (declaim (ftype j-read-char-fn sc-read-char-ef))
 (defun sc-read-char-ef (stream eof-error-p eof-value blocking)
   #|(declare (optimize (speed 3) (space 2) (safety 0) (debug 0)))|#
   (with-stream-class (simple-stream stream)
     (let* ((buffer (sm buffer stream))
-	   (buffpos (sm buffpos stream))
-	   (ctrl (sm control-in stream))
-	   (ef (sm external-format stream))
-	   (state (sm oc-state stream)))
+           (buffpos (sm buffpos stream))
+           (ctrl (sm control-in stream))
+           (ef (sm external-format stream))
+           (state (sm oc-state stream)))
       (flet ((input ()
-	       (when (>= buffpos (sm buffer-ptr stream))
-                 (when (sc-dirty-p stream)
+               (when (>= buffpos (sm buffer-ptr stream))
+                 (when (and (not (any-stream-instance-flags stream :dual :string))
+                            (sc-dirty-p stream))
                    (flush-buffer stream t))
-		 (let ((bytes (refill-buffer stream blocking)))
-		   (cond ((= bytes 0)
-			  (return-from sc-read-char-ef nil))
-			 ((minusp bytes)
-			  (return-from sc-read-char-ef
-			    (sb-impl::eof-or-lose stream eof-error-p eof-value)))
-			 (t
-			  (setf buffpos (sm buffpos stream))))))
-	       (incf (sm last-char-read-size stream))
-	       (prog1 (bref buffer buffpos)
-		 (incf buffpos)))
-	     (unput (n)
-	       (decf buffpos n)))
-	(let* ((cnt 0)
-	       (char (octets-to-char ef state cnt #'input #'unput))
-	       (code (char-code char)))
-	  (setf (sm buffpos stream) buffpos
-		(sm last-char-read-size stream) cnt
-		(sm oc-state stream) state)
-	  (when (and (< code 32) ctrl (svref ctrl code))
-	    (setq char (funcall (the (or symbol function) (svref ctrl code))
-				stream char)))
-	  (if (null char)
-	      (sb-impl::eof-or-lose stream eof-error-p eof-value)
-	      char))))))
+                 (let ((bytes (refill-buffer stream blocking)))
+                   (cond ((= bytes 0)
+                          (return-from sc-read-char-ef nil))
+                         ((minusp bytes)
+                          (return-from sc-read-char-ef
+                            (sb-impl::eof-or-lose stream eof-error-p eof-value)))
+                         (t
+                          (setf buffpos (sm buffpos stream))))))
+               (incf (sm last-char-read-size stream))
+               (prog1 (bref buffer buffpos)
+                 (incf buffpos)))
+             (unput (n)
+               (decf buffpos n)))
+        (let* ((cnt 0)
+               (char (octets-to-char ef state cnt #'input #'unput))
+               (code (char-code char)))
+          (setf (sm buffpos stream) buffpos
+                (sm last-char-read-size stream) cnt
+                (sm oc-state stream) state)
+          (when (and (< code 32) ctrl (svref ctrl code))
+            (setq char (funcall (the (or symbol function) (svref ctrl code))
+                                stream char)))
+          (if (null char)
+              (sb-impl::eof-or-lose stream eof-error-p eof-value)
+              char))))))
 
 
 (declaim (ftype j-read-char-fn sc-read-char-ef-mapped))
@@ -175,31 +177,31 @@
   (declare (ignore blocking))
   (with-stream-class (simple-stream stream)
     (let* ((buffer (sm buffer stream))
-	   (buffpos (sm buffpos stream))
-	   (ctrl (sm control-in stream))
-	   (ef (sm external-format stream))
-	   (state (sm oc-state stream)))
+           (buffpos (sm buffpos stream))
+           (ctrl (sm control-in stream))
+           (ef (sm external-format stream))
+           (state (sm oc-state stream)))
       (flet ((input ()
-	       (when (>= buffpos (sm buffer-ptr stream))
-		 (return-from sc-read-char-ef-mapped
+               (when (>= buffpos (sm buffer-ptr stream))
+                 (return-from sc-read-char-ef-mapped
                    (sb-impl::eof-or-lose stream eof-error-p eof-value)))
-	       (incf (sm last-char-read-size stream))
-	       (prog1 (bref buffer buffpos)
-		 (incf buffpos)))
-	     (unput (n)
-	       (decf buffpos n)))
-	(let* ((cnt 0)
-	       (char (octets-to-char ef state cnt #'input #'unput))
-	       (code (char-code char)))
-	  (setf (sm buffpos stream) buffpos
-		(sm last-char-read-size stream) cnt
-		(sm oc-state stream) state)
-	  (when (and (< code 32) ctrl (svref ctrl code))
-	    (setq char (funcall (the (or symbol function) (svref ctrl code))
-				stream char)))
-	  (if (null char)
-	      (sb-impl::eof-or-lose stream eof-error-p eof-value)
-	      char))))))
+               (incf (sm last-char-read-size stream))
+               (prog1 (bref buffer buffpos)
+                 (incf buffpos)))
+             (unput (n)
+               (decf buffpos n)))
+        (let* ((cnt 0)
+               (char (octets-to-char ef state cnt #'input #'unput))
+               (code (char-code char)))
+          (setf (sm buffpos stream) buffpos
+                (sm last-char-read-size stream) cnt
+                (sm oc-state stream) state)
+          (when (and (< code 32) ctrl (svref ctrl code))
+            (setq char (funcall (the (or symbol function) (svref ctrl code))
+                                stream char)))
+          (if (null char)
+              (sb-impl::eof-or-lose stream eof-error-p eof-value)
+              char))))))
 
 
 (declaim (ftype j-read-chars-fn sc-read-chars-ef))
@@ -214,63 +216,64 @@
            (type (or null character) search)
            (type fixnum start end)
            (type boolean blocking)
-	   #|(optimize (speed 3) (space 2) (safety 0) (debug 0))|#)
+           #|(optimize (speed 3) (space 2) (safety 0) (debug 0))|#)
   (with-stream-class (simple-stream stream)
-    (when (sc-dirty-p stream)
+    (when (and (not (any-stream-instance-flags stream :dual :string))
+               (sc-dirty-p stream))
       (flush-buffer stream t))
     (do ((buffer (sm buffer stream))
          (buffpos (sm buffpos stream))
          (buffer-ptr (sm buffer-ptr stream))
-	 (lcrs 0)
-	 (ctrl (sm control-in stream))
-	 (ef (sm external-format stream))
-	 (state (sm oc-state stream))
+         (lcrs 0)
+         (ctrl (sm control-in stream))
+         (ef (sm external-format stream))
+         (state (sm oc-state stream))
          (posn start (1+ posn))
          (count 0 (1+ count)))
         ((>= posn end)
-	 (setf (sm buffpos stream) buffpos
-	       (sm last-char-read-size stream) lcrs
-	       (sm oc-state stream) state)
-	 (values count nil))
+         (setf (sm buffpos stream) buffpos
+               (sm last-char-read-size stream) lcrs
+               (sm oc-state stream) state)
+         (values count nil))
       (declare (type sb-int:index buffpos buffer-ptr posn count))
       (flet ((input ()
-	       (when (>= buffpos buffer-ptr)
-		 (setf (sm last-char-read-size stream) lcrs)
-		 (let ((bytes (refill-buffer stream blocking)))
-		   (declare (type fixnum bytes))
-		   (setf buffpos (sm buffpos stream)
-			 buffer-ptr (sm buffer-ptr stream))
-		   (unless (plusp bytes)
-		     (setf (sm buffpos stream) buffpos
-			   (sm last-char-read-size stream) lcrs
-			   (sm oc-state stream) state)
-		     (if (zerop bytes)
-			 (return (values count nil))
-			 (return (values count :eof))))))
-	       (prog1 (bref buffer buffpos)
-		 (incf buffpos)
-		 (incf lcrs)))
-	     (unput (n)
-	       (decf buffpos n)))
-	(let* ((cnt 0)
-	       (char (octets-to-char ef state cnt #'input #'unput))
-	       (code (char-code char)))
-	  (setq lcrs cnt)
-	  (when (and (< code 32) ctrl (svref ctrl code))
-	    (setq char (funcall (the (or symbol function) (svref ctrl code))
-				stream char)))
-	  (cond ((null char)
-		 (setf (sm buffpos stream) buffpos
-		       (sm last-char-read-size stream) lcrs
-		       (sm oc-state stream) state)
-		 (return (values count :eof)))
-		((and search (char= char search))
-		 (setf (sm buffpos stream) buffpos
-		       (sm last-char-read-size stream) lcrs
-		       (sm oc-state stream) state)
-		 (return (values count t)))
-		(t
-		 (setf (char string posn) char))))))))
+               (when (>= buffpos buffer-ptr)
+                 (setf (sm last-char-read-size stream) lcrs)
+                 (let ((bytes (refill-buffer stream blocking)))
+                   (declare (type fixnum bytes))
+                   (setf buffpos (sm buffpos stream)
+                         buffer-ptr (sm buffer-ptr stream))
+                   (unless (plusp bytes)
+                     (setf (sm buffpos stream) buffpos
+                           (sm last-char-read-size stream) lcrs
+                           (sm oc-state stream) state)
+                     (if (zerop bytes)
+                         (return (values count nil))
+                         (return (values count :eof))))))
+               (prog1 (bref buffer buffpos)
+                 (incf buffpos)
+                 (incf lcrs)))
+             (unput (n)
+               (decf buffpos n)))
+        (let* ((cnt 0)
+               (char (octets-to-char ef state cnt #'input #'unput))
+               (code (char-code char)))
+          (setq lcrs cnt)
+          (when (and (< code 32) ctrl (svref ctrl code))
+            (setq char (funcall (the (or symbol function) (svref ctrl code))
+                                stream char)))
+          (cond ((null char)
+                 (setf (sm buffpos stream) buffpos
+                       (sm last-char-read-size stream) lcrs
+                       (sm oc-state stream) state)
+                 (return (values count :eof)))
+                ((and search (char= char search))
+                 (setf (sm buffpos stream) buffpos
+                       (sm last-char-read-size stream) lcrs
+                       (sm oc-state stream) state)
+                 (return (values count t)))
+                (t
+                 (setf (char string posn) char))))))))
 
 
 (declaim (ftype j-read-chars-fn sc-read-chars-ef-mapped))
@@ -286,51 +289,51 @@
            (type fixnum start end)
            (type boolean blocking)
            (ignore blocking)
-	   #|(optimize (speed 3) (space 2) (safety 0) (debug 0))|#)
+           #|(optimize (speed 3) (space 2) (safety 0) (debug 0))|#)
   (with-stream-class (simple-stream stream)
     ;; if stream is single-channel and mode == 3, flush buffer (if dirty)
     (do ((buffer (sm buffer stream))
          (buffpos (sm buffpos stream))
          (buffer-ptr (sm buffer-ptr stream))
-	 (lcrs 0)
-	 (ctrl (sm control-in stream))
-	 (ef (sm external-format stream))
-	 (state (sm oc-state stream))
+         (lcrs 0)
+         (ctrl (sm control-in stream))
+         (ef (sm external-format stream))
+         (state (sm oc-state stream))
          (posn start (1+ posn))
          (count 0 (1+ count)))
         ((>= posn end)
-	 (setf (sm buffpos stream) buffpos
-	       (sm last-char-read-size stream) lcrs
-	       (sm oc-state stream) state)
-	 (values count nil))
+         (setf (sm buffpos stream) buffpos
+               (sm last-char-read-size stream) lcrs
+               (sm oc-state stream) state)
+         (values count nil))
       (declare (type sb-int:index buffpos buffer-ptr posn count))
       (flet ((input ()
-	       (when (>= buffpos buffer-ptr)
+               (when (>= buffpos buffer-ptr)
                  (return (values count :eof)))
-	       (prog1 (bref buffer buffpos)
-		 (incf buffpos)
-		 (incf lcrs)))
-	     (unput (n)
-	       (decf buffpos n)))
-	(let* ((cnt 0)
-	       (char (octets-to-char ef state cnt #'input #'unput))
-	       (code (char-code char)))
-	  (setq lcrs cnt)
-	  (when (and (< code 32) ctrl (svref ctrl code))
-	    (setq char (funcall (the (or symbol function) (svref ctrl code))
-				stream char)))
-	  (cond ((null char)
-		 (setf (sm buffpos stream) buffpos
-		       (sm last-char-read-size stream) lcrs
-		       (sm oc-state stream) state)
-		 (return (values count :eof)))
-		((and search (char= char search))
-		 (setf (sm buffpos stream) buffpos
-		       (sm last-char-read-size stream) lcrs
-		       (sm oc-state stream) state)
-		 (return (values count t)))
-		(t
-		 (setf (char string posn) char))))))))
+               (prog1 (bref buffer buffpos)
+                 (incf buffpos)
+                 (incf lcrs)))
+             (unput (n)
+               (decf buffpos n)))
+        (let* ((cnt 0)
+               (char (octets-to-char ef state cnt #'input #'unput))
+               (code (char-code char)))
+          (setq lcrs cnt)
+          (when (and (< code 32) ctrl (svref ctrl code))
+            (setq char (funcall (the (or symbol function) (svref ctrl code))
+                                stream char)))
+          (cond ((null char)
+                 (setf (sm buffpos stream) buffpos
+                       (sm last-char-read-size stream) lcrs
+                       (sm oc-state stream) state)
+                 (return (values count :eof)))
+                ((and search (char= char search))
+                 (setf (sm buffpos stream) buffpos
+                       (sm last-char-read-size stream) lcrs
+                       (sm oc-state stream) state)
+                 (return (values count t)))
+                (t
+                 (setf (char string posn) char))))))))
 
 
 (declaim (ftype j-unread-char-fn sc-unread-char-ef))
@@ -347,25 +350,25 @@
   (when character
     (with-stream-class (single-channel-simple-stream stream)
       (let ((buffer (sm buffer stream))
-	    (buffpos (sm buffpos stream))
-	    (buf-len (sm buf-len stream))
-	    (code (char-code character))
-	    (ctrl (sm control-out stream)))
-	(when (and (< code 32) ctrl (svref ctrl code)
-		   (funcall (the (or symbol function) (svref ctrl code))
-			    stream character))
-	  (return-from sc-write-char-ef character))
-	(flet ((output (byte)
-		 (when (>= buffpos buf-len)
-		   (setf (sm buffpos stream) buffpos)
-		   (setq buffpos (flush-buffer stream t)))
-		 (setf (bref buffer buffpos) byte)
-		 (incf buffpos)))
-	  (char-to-octets (sm external-format stream) character
-			  (sm co-state stream) #'output))
-	(setf (sm buffpos stream) buffpos)
+            (buffpos (sm buffpos stream))
+            (buf-len (sm buf-len stream))
+            (code (char-code character))
+            (ctrl (sm control-out stream)))
+        (when (and (< code 32) ctrl (svref ctrl code)
+                   (funcall (the (or symbol function) (svref ctrl code))
+                            stream character))
+          (return-from sc-write-char-ef character))
+        (flet ((output (byte)
+                 (when (>= buffpos buf-len)
+                   (setf (sm buffpos stream) buffpos)
+                   (setq buffpos (flush-buffer stream t)))
+                 (setf (bref buffer buffpos) byte)
+                 (incf buffpos)))
+          (char-to-octets (sm external-format stream) character
+                          (sm co-state stream) #'output))
+        (setf (sm buffpos stream) buffpos)
         (sc-set-dirty stream)
-	(if (sm charpos stream) (incf (sm charpos stream))))))
+        (if (sm charpos stream) (incf (sm charpos stream))))))
   character)
 
 (declaim (ftype j-write-chars-fn sc-write-chars-ef))
@@ -374,7 +377,7 @@
     (do ((buffer (sm buffer stream))
          (buffpos (sm buffpos stream))
          (buf-len (sm buf-len stream))
-	 (ef (sm external-format stream))
+         (ef (sm external-format stream))
          (ctrl (sm control-out stream))
          (posn start (1+ posn))
          (count 0 (1+ count)))
@@ -385,15 +388,15 @@
         (unless (and (< code 32) ctrl (svref ctrl code)
                      (funcall (the (or symbol function) (svref ctrl code))
                               stream char))
-	  (flet ((output (byte)
-		   (when (>= buffpos buf-len)
-		     (setf (sm buffpos stream) buffpos)
-		     (setq buffpos (flush-buffer stream t)))
-		   (setf (bref buffer buffpos) byte)
-		   (incf buffpos)))
-	    (char-to-octets ef char (sm co-state stream) #'output))
-	  (setf (sm buffpos stream) buffpos)
-	  (if (sm charpos stream) (incf (sm charpos stream)))
+          (flet ((output (byte)
+                   (when (>= buffpos buf-len)
+                     (setf (sm buffpos stream) buffpos)
+                     (setq buffpos (flush-buffer stream t)))
+                   (setf (bref buffer buffpos) byte)
+                   (incf buffpos)))
+            (char-to-octets ef char (sm co-state stream) #'output))
+          (setf (sm buffpos stream) buffpos)
+          (if (sm charpos stream) (incf (sm charpos stream)))
           (sc-set-dirty stream))))))
 
 
@@ -406,24 +409,24 @@
   (when character
     (with-stream-class (dual-channel-simple-stream stream)
       (let ((out-buffer (sm out-buffer stream))
-	    (outpos (sm outpos stream))
-	    (max-out-pos (sm max-out-pos stream))
-	    (code (char-code character))
-	    (ctrl (sm control-out stream)))
-	(when (and (< code 32) ctrl (svref ctrl code)
-		   (funcall (the (or symbol function) (svref ctrl code))
-			    stream character))
-	  (return-from dc-write-char-ef character))
-	(flet ((output (byte)
-		 (when (>= outpos max-out-pos)
-		   (setf (sm outpos stream) outpos)
-		   (setq outpos (flush-out-buffer stream t)))
-		 (setf (bref out-buffer outpos) byte)
-		 (incf outpos)))
-	  (char-to-octets (sm external-format stream) character
-			  (sm co-state stream) #'output))
-	(setf (sm outpos stream) outpos)
-	(if (sm charpos stream) (incf (sm charpos stream))))))
+            (outpos (sm outpos stream))
+            (max-out-pos (sm max-out-pos stream))
+            (code (char-code character))
+            (ctrl (sm control-out stream)))
+        (when (and (< code 32) ctrl (svref ctrl code)
+                   (funcall (the (or symbol function) (svref ctrl code))
+                            stream character))
+          (return-from dc-write-char-ef character))
+        (flet ((output (byte)
+                 (when (>= outpos max-out-pos)
+                   (setf (sm outpos stream) outpos)
+                   (setq outpos (flush-out-buffer stream t)))
+                 (setf (bref out-buffer outpos) byte)
+                 (incf outpos)))
+          (char-to-octets (sm external-format stream) character
+                          (sm co-state stream) #'output))
+        (setf (sm outpos stream) outpos)
+        (if (sm charpos stream) (incf (sm charpos stream))))))
   character)
 
 
@@ -433,7 +436,7 @@
     (do ((buffer (sm out-buffer stream))
          (outpos (sm outpos stream))
          (max-out-pos (sm max-out-pos stream))
-	 (ef (sm external-format stream))
+         (ef (sm external-format stream))
          (ctrl (sm control-out stream))
          (posn start (1+ posn))
          (count 0 (1+ count)))
@@ -444,15 +447,15 @@
         (unless (and (< code 32) ctrl (svref ctrl code)
                      (funcall (the (or symbol function) (svref ctrl code))
                               stream char))
-	  (flet ((output (byte)
-		   (when (>= outpos max-out-pos)
-		     (setf (sm outpos stream) outpos)
-		     (setq outpos (flush-out-buffer stream t)))
-		   (setf (bref buffer outpos) byte)
-		   (incf outpos)))
-	    (char-to-octets ef char (sm co-state stream) #'output))
-	  (setf (sm outpos stream) outpos)
-	  (if (sm charpos stream) (incf (sm charpos stream))))))))
+          (flet ((output (byte)
+                   (when (>= outpos max-out-pos)
+                     (setf (sm outpos stream) outpos)
+                     (setq outpos (flush-out-buffer stream t)))
+                   (setf (bref buffer outpos) byte)
+                   (incf outpos)))
+            (char-to-octets ef char (sm co-state stream) #'output))
+          (setf (sm outpos stream) outpos)
+          (if (sm charpos stream) (incf (sm charpos stream))))))))
 
 ;;;; String-Simple-Stream strategy functions
 
@@ -494,7 +497,7 @@
 (defun str-read-char-e-crlf (stream eof-error-p eof-value blocking)
   (with-stream-class (composing-stream stream)
     (let* ((encap (sm melded-stream stream))
-	   (ctrl (sm control-in stream))
+           (ctrl (sm control-in stream))
            (char (funcall-stm-handler j-read-char encap nil stream blocking)))
       ;; if CHAR is STREAM, we hit EOF; if NIL, blocking is NIL and no
       ;; character was available...
@@ -514,13 +517,13 @@
               (setq char #\Newline)
               (funcall-stm-handler j-unread-char encap nil))))
       (when (characterp char)
-	(let ((code (char-code char)))
-	  (when (and (< code 32) ctrl (svref ctrl code))
-	    (setq char (funcall (the (or symbol function) (svref ctrl code))
-				stream char)))))
+        (let ((code (char-code char)))
+          (when (and (< code 32) ctrl (svref ctrl code))
+            (setq char (funcall (the (or symbol function) (svref ctrl code))
+                                stream char)))))
       (if (eq char stream)
-	  (sb-impl::eof-or-lose stream eof-error-p eof-value)
-	  char))))
+          (sb-impl::eof-or-lose stream eof-error-p eof-value)
+          char))))
 
 (declaim (ftype j-unread-char-fn str-unread-char-e-crlf))
 (defun str-unread-char-e-crlf (stream relaxed)
@@ -534,7 +537,7 @@
 (defun melding-stream (stream)
   (with-stream-class (simple-stream)
     (do ((stm stream (sm melded-stream stm)))
-	((eq (sm melded-stream stm) stream) stm))))
+        ((eq (sm melded-stream stm) stream) stm))))
 
 (defun meld (stream encap)
   (with-stream-class (simple-stream)
@@ -552,24 +555,24 @@
   (with-stream-class (simple-stream)
     (let ((encap (sm melded-stream stream)))
       (unless (eq encap (sm melding-base stream))
-	(setf (sm melding-base encap) encap)
-	(setf (sm melded-stream stream) (sm melded-stream encap))
-	(setf (sm melded-stream encap) encap)
-	(rotatef (sm j-listen stream) (sm j-listen encap))
-	(rotatef (sm j-read-char encap) (sm j-read-char stream))
-	(rotatef (sm j-read-chars stream) (sm j-read-chars encap))
-	(rotatef (sm j-unread-char stream) (sm j-unread-char encap))
-	(rotatef (sm j-write-char stream) (sm j-write-char encap))
-	(rotatef (sm j-write-chars stream) (sm j-write-chars encap))))))
+        (setf (sm melding-base encap) encap)
+        (setf (sm melded-stream stream) (sm melded-stream encap))
+        (setf (sm melded-stream encap) encap)
+        (rotatef (sm j-listen stream) (sm j-listen encap))
+        (rotatef (sm j-read-char encap) (sm j-read-char stream))
+        (rotatef (sm j-read-chars stream) (sm j-read-chars encap))
+        (rotatef (sm j-unread-char stream) (sm j-unread-char encap))
+        (rotatef (sm j-write-char stream) (sm j-write-char encap))
+        (rotatef (sm j-write-chars stream) (sm j-write-chars encap))))))
 
 ;;; In cmucl, this is done with define-function-name-syntax (lists as
 ;;; function names), we make do with symbol frobbing.
 (defun %sf (kind name format &optional access)
   (flet ((find-strategy-function (&rest args)
-	   (let ((name
-		  (find-symbol (format nil "~{~A~^-~}" (mapcar #'string args))
-			       #.*package*)))
-	     (if (fboundp name) (fdefinition name) nil))))
+           (let ((name
+                  (find-symbol (format nil "~{~A~^-~}" (mapcar #'string args))
+                               #.*package*)))
+             (if (fboundp name) (fdefinition name) nil))))
     (or (find-strategy-function kind name format access)
         (find-strategy-function kind name format)
         (find-strategy-function kind name :ef access)
@@ -586,34 +589,34 @@
     ;; (Avoids checking "mode" flags by installing special strategy)
     (with-stream-class (simple-stream stream)
       (setf (sm j-listen stream)
-	  (%sf 'sc 'listen (ef-name format) access)
-	    (sm j-read-char stream)
-	  (%sf 'sc 'read-char (ef-name format) access)
-	    (sm j-read-chars stream)
-	  (%sf 'sc 'read-chars (ef-name format) access)
-	    (sm j-unread-char stream)
-	  (%sf 'sc 'unread-char (ef-name format) access)
-	    (sm j-write-char stream)
-	  (%sf 'sc 'write-char (ef-name format) access)
-	    (sm j-write-chars stream)
-	  (%sf 'sc 'write-chars (ef-name format) access))))
+          (%sf 'sc 'listen (ef-name format) access)
+            (sm j-read-char stream)
+          (%sf 'sc 'read-char (ef-name format) access)
+            (sm j-read-chars stream)
+          (%sf 'sc 'read-chars (ef-name format) access)
+            (sm j-unread-char stream)
+          (%sf 'sc 'unread-char (ef-name format) access)
+            (sm j-write-char stream)
+          (%sf 'sc 'write-char (ef-name format) access)
+            (sm j-write-chars stream)
+          (%sf 'sc 'write-chars (ef-name format) access))))
   stream)
 
 (defun install-dual-channel-character-strategy (stream external-format)
   (let ((format (find-external-format external-format)))
     (with-stream-class (simple-stream stream)
       (setf (sm j-listen stream)
-	  (%sf 'sc 'listen (ef-name format))
-	    (sm j-read-char stream)
-	  (%sf 'sc 'read-char (ef-name format))
-	    (sm j-read-chars stream)
-	  (%sf 'sc 'read-chars (ef-name format))
-	    (sm j-unread-char stream)
-	  (%sf 'sc 'unread-char (ef-name format))
-	    (sm j-write-char stream)
-	  (%sf 'dc 'write-char (ef-name format))
-	    (sm j-write-chars stream)
-	  (%sf 'dc 'write-chars (ef-name format)))))
+          (%sf 'sc 'listen (ef-name format))
+            (sm j-read-char stream)
+          (%sf 'sc 'read-char (ef-name format))
+            (sm j-read-chars stream)
+          (%sf 'sc 'read-chars (ef-name format))
+            (sm j-unread-char stream)
+          (%sf 'sc 'unread-char (ef-name format))
+            (sm j-write-char stream)
+          (%sf 'dc 'write-char (ef-name format))
+            (sm j-write-chars stream)
+          (%sf 'dc 'write-chars (ef-name format)))))
   stream)
 
 ;; Deprecated -- use install-string-{input,output}-character-strategy instead!
@@ -638,8 +641,8 @@
   (let ((format composing-format))
     (with-stream-class (simple-stream stream)
       (case format
-	(:e-crlf (setf (sm j-read-char stream) #'str-read-char-e-crlf
-		       (sm j-unread-char stream) #'str-unread-char-e-crlf))))
+        (:e-crlf (setf (sm j-read-char stream) #'str-read-char-e-crlf
+                       (sm j-unread-char stream) #'str-unread-char-e-crlf))))
     #| implement me |#)
   stream)
 
@@ -647,16 +650,16 @@
   (when (consp external-format)
     (with-stream-class (simple-stream)
       (let ((encap (if (eq (sm melded-stream stream) stream)
-		       nil
-		       (sm melded-stream stream))))
-	(when (null encap)
-	  (setq encap (make-instance 'composing-stream))
-	  (meld stream encap))
-	(setf (stream-external-format encap) (car (last external-format)))
-	(setf (sm external-format stream) external-format)
-	(install-composing-format-character-strategy stream
-						     (butlast external-format))
-	))))
+                       nil
+                       (sm melded-stream stream))))
+        (when (null encap)
+          (setq encap (make-instance 'composing-stream))
+          (meld stream encap))
+        (setf (stream-external-format encap) (car (last external-format)))
+        (setf (sm external-format stream) external-format)
+        (install-composing-format-character-strategy stream
+                                                     (butlast external-format))
+        ))))
 
 (defmethod (setf stream-external-format) (ef (stream simple-stream))
   (with-stream-class (simple-stream stream)