From 84757efc85a620f271c0dd8a3b22c38e8c5276f3 Mon Sep 17 00:00:00 2001
From: rtoy <rtoy>
Date: Thu, 23 Jul 2009 01:32:23 +0000
Subject: [PATCH] Make simple-streams work with the new Unicode external format
 support.  Add new functions def-ef-macro functions that do the dirty work and
 use them in the stream functions.  We leave the old versions around for now,
 but they should be removed.  %octets-to-char is no longer used.

---
 pcl/simple-streams/strategy.lisp | 363 +++++++++++++------------------
 1 file changed, 147 insertions(+), 216 deletions(-)

diff --git a/pcl/simple-streams/strategy.lisp b/pcl/simple-streams/strategy.lisp
index aaafe278e..c2e270982 100644
--- a/pcl/simple-streams/strategy.lisp
+++ b/pcl/simple-streams/strategy.lisp
@@ -5,7 +5,7 @@
 ;;; domain.
 ;;; 
 (ext:file-comment
- "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/pcl/simple-streams/strategy.lisp,v 1.13 2009/06/11 16:04:02 rtoy Exp $")
+ "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/pcl/simple-streams/strategy.lisp,v 1.14 2009/07/23 01:32:23 rtoy Exp $")
 ;;;
 ;;; **********************************************************************
 ;;;
@@ -131,6 +131,7 @@
 (defconstant +ef-obs-oc+ 0)
 (defconstant +ef-obs-co+ 1)
 
+#+(or)
 (defun ef-obs-oc-fn (extfmt)
   (or (aref (ef-cache extfmt) +ef-obs-oc+)
       (setf (aref (ef-cache extfmt) +ef-obs-oc+)
@@ -141,6 +142,7 @@
 				  (lambda (x) (funcall unput x)))
                (values code width state)))))))
 
+#+(or)
 (defmacro %octets-to-char (ef state count input unput)
   (let ((tmp1 (gensym)) (tmp2 (gensym)) (tmp3 (gensym)))
     `(multiple-value-bind (,tmp1 ,tmp2 ,tmp3)
@@ -171,19 +173,19 @@
 (defconstant +ss-ef-max+ 4)
 
 (def-ef-macro %read-char-fn (ef simple-streams +ss-ef-max+ +ss-ef-rchar+)
-  `(lambda (stream refill)
+  `(lambda (stream max refill)
      (declare (type simple-stream stream)
               (type function refill))
      (with-stream-class (simple-stream stream)
-       ,(octets-to-char ef (sm oc-state stream)
-                        (sm last-char-read-size stream)
-                        (prog2
-                            (when (>= (sm buffpos stream) (sm buf-len stream))
-                              (funcall refill))
-                            (bref (sm buffer stream) (sm buffpos stream))
-                          (incf (sm buffpos stream))
-                          (incf (sm last-char-read-size stream)))
-                        (lambda (n) (decf (sm buffpos stream) n))))))
+       (octets-to-char ,ef
+		       (sm oc-state stream)
+		       (sm last-char-read-size stream)
+		       (prog2
+			   (when (>= (sm buffpos stream) max)
+			     (setf max (funcall refill)))
+			   (bref (sm buffer stream) (sm buffpos stream))
+			 (incf (sm buffpos stream)))
+		       (lambda (n) (decf (sm buffpos stream) n))))))
 
 (def-ef-macro %read-chars-fn (ef simple-streams +ss-ef-max+ +ss-ef-rchars+)
   `(lambda (stream string search start end max refill)
@@ -193,37 +195,102 @@
               (type fixnum start end)
               (type lisp::index max)
               (type function refill))
-     (do ((posn start (1+ posn))
-          (count 0 (1+ count)))
-         ((>= posn end) (values count nil))
-       (declare (type lisp::index posn count))
-       (let* ((char ,(octets-to-char ef (sm oc-state stream)
-                                     (sm last-char-read-size stream)
-                                     (prog2
-                                         (when (>= (sm buffpos stream) max)
-                                           (setq max (funcall refill count)))
-                                         (bref (sm buffer stream)
-					       (sm buffpos stream))
-                                       (incf (sm buffpos stream))
-                                       (incf (sm last-char-read-size stream)))
-                                     (lambda (n)
-                                       (decf (sm buffpos stream) n))))
-              (code (char-code char))
-              (ctrl (sm control-in stream)))
-         (when (and (< code 32) ctrl (svref ctrl code))
-           (setq char (funcall (the (or symbol function) (svref ctrl code))
-                               stream char)))
-         (cond ((null char)
-                (return (values count :eof)))
-               ((and search (char= char search))
-                (return (values count t)))
-               (t
-                (setf (char string posn) char)))))))
-
+     (with-stream-class (simple-stream stream)
+       (do ((posn start (1+ posn))
+	    (count 0 (1+ count)))
+	   ((>= posn end) (values count nil))
+	 (declare (type lisp::index posn count))
+	 (let* ((char (octets-to-char ,ef
+				      (sm oc-state stream)
+				      (sm last-char-read-size stream)
+				      (prog2
+					  (when (>= (sm buffpos stream) max)
+					    (setq max (funcall refill count)))
+					  (bref (sm buffer stream)
+						(sm buffpos stream))
+					(incf (sm buffpos stream)))
+				      (lambda (n)
+					(decf (sm buffpos stream) n))))
+		(code (char-code char))
+		(ctrl (sm control-in stream)))
+	   (when (and (< code 32) ctrl (svref ctrl code))
+	     (setq char (funcall (the (or symbol function) (svref ctrl code))
+				 stream char)))
+	   (cond ((null char)
+		  (return (values count :eof)))
+		 ((and search (char= char search))
+		  (return (values count t)))
+		 (t
+		  (setf (char string posn) char))))))))
+
+(def-ef-macro %sc-write-char-fn (ef simple-streams +ss-ef-max+ +ss-ef-wchar+)
+  `(lambda (character stream)
+     (declare (type simple-stream stream))
+     (when character
+       (with-stream-class (simple-stream stream)
+	 (let ((code (char-code character))
+	       (ctrl (sm control-out stream)))
+	   (unless (and (< code 32) ctrl (svref ctrl code)
+			(funcall (the (or symbol function) (svref ctrl code))
+				 stream character))
+	     (char-to-octets ,ef
+			     character
+			     (sm oc-state stream)
+			     (lambda (byte)
+			       (when (>= (sm buffpos stream) (sm buffer-ptr stream))
+				 (setf (sm buffpos stream) (flush-buffer stream t)))
+			       (setf (bref (sm buffer stream) (sm buffpos stream)) byte)
+			       (incf (sm buffpos stream))))
+	     (sc-set-dirty stream)
+	     (when (sm charpos stream)
+	       (incf (sm charpos stream)))))))
+     character))
+
+(def-ef-macro %dc-write-char-fn (ef simple-streams +ss-ef-max+ +ss-ef-wchar+)
+  `(lambda (character stream)
+     (declare (type simple-stream stream))
+     (when character
+       (with-stream-class (dual-channel-simple-stream stream)
+	 (let ((code (char-code character))
+	       (ctrl (sm control-out stream)))
+	   (unless (and (< code 32) ctrl (svref ctrl code)
+			(funcall (the (or symbol function) (svref ctrl code))
+				 stream character))
+	     (char-to-octets ,ef
+			     character
+			     (sm oc-state stream)
+			     (lambda (byte)
+			       (when (>= (sm outpos stream) (sm max-out-pos stream))
+				 (setf (sm outpos stream) (flush-out-buffer stream t)))
+			       (setf (bref (sm out-buffer stream) (sm outpos stream)) byte)
+			       (incf (sm outpos stream))))
+	     (when (sm charpos stream)
+	       (incf (sm charpos stream)))))))
+     character))
 
 ;;;; Single-Channel-Simple-Stream strategy functions
 
 (declaim (ftype j-listen-fn (sc listen :ef)))
+#-(or)
+(defun (sc listen :ef) (stream)
+  (with-stream-class (simple-stream stream)
+    (let ((lcrs (sm last-char-read-size stream))
+	  (char nil))
+      (unwind-protect
+	   (flet ((refill ()
+		    (let ((bytes (refill-buffer stream nil)))
+		      (cond ((= bytes 0)
+			     (return-from listen nil))
+			    ((minusp bytes)
+			     (return-from listen t))
+			    (t
+			     (+ bytes (sm last-char-read-size stream)))))))
+	     (setq char (funcall (%read-char-fn (sm external-format stream))
+				 stream (sm buffer-ptr stream) #'refill))
+	     (characterp char))
+	(setf (sm last-char-read-size stream) lcrs)))))
+
+#+(or)
 (defun (sc listen :ef) (stream)
   (with-stream-class (simple-stream stream)
     (let ((lcrs (sm last-char-read-size stream))
@@ -246,6 +313,7 @@
 		      (incf buffpos)))
 		  (unput (n)
 		    (decf buffpos n)))
+	     (format t "listen on ~S~%" stream)
 	     (setq char (%octets-to-char (sm external-format stream)
 					(sm oc-state stream)
 					cnt #'input #'unput))
@@ -265,9 +333,11 @@
                       (return-from read-char nil))
                      ((minusp bytes)
                       (return-from read-char
-                        (lisp::eof-or-lose stream eof-error-p eof-value)))))))
+                        (lisp::eof-or-lose stream eof-error-p eof-value)))
+		     (t
+		      (+ bytes (sm last-char-read-size stream)))))))
       (let* ((char (funcall (%read-char-fn (sm external-format stream))
-			    stream #'refill))
+			    stream (sm buffer-ptr stream) #'refill))
              (code (char-code char))
              (ctrl (sm control-in stream)))
         (when (and (< code 32) ctrl (svref ctrl code))
@@ -276,6 +346,7 @@
         (if (null char)
             (lisp::eof-or-lose stream eof-error-p eof-value)
             char)))))
+
 #+(or)
 (defun (sc read-char :ef) (stream eof-error-p eof-value blocking)
   #|(declare (optimize (speed 3) (space 2) (safety 0) (debug 0)))|#
@@ -326,7 +397,7 @@
              (return-from read-char
                (lisp::eof-or-lose stream eof-error-p eof-value))))
       (let* ((char (funcall (%read-char-fn (sm external-format stream))
-			    stream #'refill))
+			    stream (sm buf-len stream) #'refill))
              (code (char-code char))
              (ctrl (sm control-in stream)))
         (when (and (< code 32) ctrl (svref ctrl code))
@@ -335,6 +406,7 @@
         (if (null char)
             (lisp::eof-or-lose stream eof-error-p eof-value)
             char)))))
+
 #+(or)
 (defun (sc read-char :ef mapped) (stream eof-error-p eof-value blocking)
   #|(declare (optimize (speed 3) (space 2) (safety 0) (debug 0)))|#
@@ -382,59 +454,17 @@
 	   #|(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))
-         (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))
-      (declare (type lisp::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))))))))
+    (flet ((refill (count)
+	     (let ((bytes (refill-buffer stream blocking)))
+	       (declare (type fixnum bytes))
+	       (cond ((= bytes 0)
+		      (return-from read-chars (values count nil)))
+		     ((minusp bytes)
+		      (return-from read-chars (values count :eof)))
+		     (t
+		      (+ bytes (sm last-char-read-size stream)))))))
+      (funcall (%read-chars-fn (sm external-format stream))
+	       stream string search start end (sm buffer-ptr stream) #'refill))))
 
 
 (declaim (ftype j-read-chars-fn (sc read-chars :ef mapped)))
@@ -453,48 +483,10 @@
 	   #|(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))
-         (buf-len (sm buf-len 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))
-      (declare (type lisp::index buffpos buf-len posn count))
-      (flet ((input ()
-	       (when (>= buffpos buf-len)
-                 (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))))))))
+    (flet ((refill (count)
+	     (return-from read-chars (values count :eof))))
+      (funcall (%read-chars-fn (sm external-format stream))
+	       stream string search start end (sm buf-len stream) #'refill))))
 
 
 (declaim (ftype j-unread-char-fn (sc unread-char :ef)))
@@ -508,59 +500,27 @@
 
 (declaim (ftype j-write-char-fn (sc write-char :ef)))
 (defun (sc write-char :ef) (character stream)
-  (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 write-char 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)
-	(when (sm charpos stream)
-	  (incf (sm charpos stream))))))
-  character)
+  (with-stream-class (simple-stream stream)
+    (funcall (%sc-write-char-fn (sm external-format stream))
+	     character stream)))
 
 (declaim (ftype j-write-chars-fn (sc write-chars :ef)))
 (defun (sc write-chars :ef) (string stream start end)
-  (with-stream-class (single-channel-simple-stream stream)
-    (do ((buffer (sm buffer stream))
-         (buffpos (sm buffpos stream))
-         (buf-len (sm buf-len stream))
-	 (ef (sm external-format stream))
+  (with-stream-class (simple-stream stream)
+    (do ((ef (sm external-format stream))
          (ctrl (sm control-out stream))
          (posn start (1+ posn))
          (count 0 (1+ count)))
-        ((>= posn end) (setf (sm buffpos stream) buffpos) count)
-      (declare (type fixnum buffpos buf-len posn count))
+        ((>= posn end)
+	 count)
+      (declare (type fixnum posn count))
       (let* ((char (char string posn))
              (code (char-code char)))
         (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)
-	  (when (sm charpos stream)
-	    (incf (sm charpos stream)))
-	  (sc-set-dirty stream))))))
+	  (funcall (%sc-write-char-fn ef)
+		   char stream))))))
 
 
 ;;;; Dual-Channel-Simple-Stream strategy functions
@@ -569,55 +529,26 @@
 
 (declaim (ftype j-write-char-fn (dc write-char :ef)))
 (defun (dc write-char :ef) (character stream)
-  (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 write-char 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)
-	(incf (sm charpos stream)))))
-  character)
+  (with-stream-class (dual-channel-simple-stream stream)
+    (funcall (%dc-write-char-fn (sm external-format stream))
+	     character stream)))
 
 (declaim (ftype j-write-chars-fn (dc write-chars :ef)))
 (defun (dc write-chars :ef) (string stream start end)
   (with-stream-class (dual-channel-simple-stream stream)
-    (do ((buffer (sm out-buffer stream))
-         (outpos (sm outpos stream))
-         (max-out-pos (sm max-out-pos stream))
-	 (ef (sm external-format stream))
-         (ctrl (sm control-out stream))
+    (do ((ctrl (sm control-out stream))
          (posn start (1+ posn))
          (count 0 (1+ count)))
-        ((>= posn end) (setf (sm outpos stream) outpos) count)
-      (declare (type fixnum outpos max-out-pos posn count))
+        ((>= posn end)
+	 count)
+      (declare (type fixnum posn count))
       (let* ((char (char string posn))
              (code (char-code char)))
         (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)
-	  (incf (sm charpos stream)))))))
+	  (funcall (%dc-write-char-fn (sm external-format stream))
+		   char stream))))))
 
 
 ;;;; String-Simple-Stream strategy functions
-- 
GitLab