From 2db772f7262115df31fe6bff20bf5c8a213d2b1c Mon Sep 17 00:00:00 2001
From: dtc <dtc>
Date: Fri, 15 May 1998 01:01:03 +0000
Subject: [PATCH] Streamline the Gray streams related dispatch code.

---
 code/reader.lisp  | 150 ++++++++++++++++++++++------------------------
 code/sharpm.lisp  |  59 +++++++++---------
 code/sysmacs.lisp |  50 +++++++---------
 3 files changed, 125 insertions(+), 134 deletions(-)

diff --git a/code/reader.lisp b/code/reader.lisp
index 242449b1a..aa5411f51 100644
--- a/code/reader.lisp
+++ b/code/reader.lisp
@@ -5,7 +5,7 @@
 ;;; Carnegie Mellon University, and has been placed in the public domain.
 ;;;
 (ext:file-comment
-  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/reader.lisp,v 1.26 1998/05/05 00:14:36 dtc Exp $")
+  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/reader.lisp,v 1.27 1998/05/15 01:01:02 dtc Exp $")
 ;;;
 ;;; **********************************************************************
 ;;;
@@ -336,24 +336,23 @@
   ;; This flushes whitespace chars, returning the last char it read (a
   ;; non-white one).  It always gets an error on end-of-file.
   (let ((stream (in-synonym-of stream)))
-    (etypecase stream
-      (lisp-stream
-       (prepare-for-fast-read-char stream
-	 (do ((attribute-table (character-attribute-table *readtable*))
-	      (char (fast-read-char t) (fast-read-char t)))
-	     ((/= (the fixnum (aref attribute-table (char-code char)))
-		  #.whitespace)
-	      (done-with-fast-read-char)
-	      char))))
-      (fundamental-stream
-       (do ((attribute-table (character-attribute-table *readtable*))
-	    (char (stream-read-char stream) (stream-read-char stream)))
-	   ((or (eq char :eof)
-		(/= (the fixnum (aref attribute-table (char-code char)))
-		    #.whitespace))
-	    (if (eq char :eof)
-		(error 'end-of-file :stream stream)
-		char)))))))
+    (if (lisp-stream-p stream)
+	(prepare-for-fast-read-char stream
+	  (do ((attribute-table (character-attribute-table *readtable*))
+	       (char (fast-read-char t) (fast-read-char t)))
+	      ((/= (the fixnum (aref attribute-table (char-code char)))
+		   #.whitespace)
+	       (done-with-fast-read-char)
+	       char)))
+	;; Fundamental-stream.
+	(do ((attribute-table (character-attribute-table *readtable*))
+	     (char (stream-read-char stream) (stream-read-char stream)))
+	    ((or (eq char :eof)
+		 (/= (the fixnum (aref attribute-table (char-code char)))
+		     #.whitespace))
+	     (if (eq char :eof)
+		 (error 'end-of-file :stream stream)
+		 char))))))
 
 
 ;;;; Temporary initialization hack.
@@ -544,16 +543,15 @@
 (defun read-comment (stream ignore)
   (declare (ignore ignore))
   (let ((stream (in-synonym-of stream)))
-    (etypecase stream
-      (lisp-stream
-       (prepare-for-fast-read-char stream
-         (do ((char (fast-read-char nil nil)
-		    (fast-read-char nil nil)))
-	     ((or (not char) (char= char #\newline))
-	      (done-with-fast-read-char)))))
-      (fundamental-stream
-       (do ((char (stream-read-char stream) (stream-read-char stream)))
-	   ((or (eq char :eof) (char= char #\newline)))))))
+    (if (lisp-stream-p stream)
+	(prepare-for-fast-read-char stream
+          (do ((char (fast-read-char nil nil)
+		     (fast-read-char nil nil)))
+	      ((or (not char) (char= char #\newline))
+	       (done-with-fast-read-char))))
+	;; Fundamental-stream.
+	(do ((char (stream-read-char stream) (stream-read-char stream)))
+	    ((or (eq char :eof) (char= char #\newline))))))
   ;;don't return anything
   (values))
 
@@ -606,24 +604,23 @@
   ;;for a very long string, this could end up bloating the read buffer.
   (reset-read-buffer)
   (let ((stream (in-synonym-of stream)))
-    (etypecase stream
-      (lisp-stream
-       (prepare-for-fast-read-char stream
-         (do ((char (fast-read-char t) (fast-read-char t)))
-	     ((char= char closech)
-	      (done-with-fast-read-char))
-	   (if (escapep char) (setq char (fast-read-char t)))
-	   (ouch-read-buffer char))))
-      (fundamental-stream
-       (do ((char (stream-read-char stream) (stream-read-char stream)))
-	   ((or (eq char :eof) (char= char closech))
+    (if (lisp-stream-p stream)
+	(prepare-for-fast-read-char stream
+          (do ((char (fast-read-char t) (fast-read-char t)))
+	      ((char= char closech)
+	       (done-with-fast-read-char))
+	    (if (escapep char) (setq char (fast-read-char t)))
+	    (ouch-read-buffer char)))
+	;; Fundamental-stream.
+	(do ((char (stream-read-char stream) (stream-read-char stream)))
+	    ((or (eq char :eof) (char= char closech))
+	     (if (eq char :eof)
+		 (error 'end-of-file :stream stream)))
+	  (when (escapep char)
+	    (setq char (stream-read-char stream))
 	    (if (eq char :eof)
 		(error 'end-of-file :stream stream)))
-	 (when (escapep char)
-	   (setq char (stream-read-char stream))
-	   (if (eq char :eof)
-	       (error 'end-of-file :stream stream)))
-	 (ouch-read-buffer char)))))
+	  (ouch-read-buffer char))))
   (read-buffer-to-string))
 
 (defun read-right-paren (stream ignore)
@@ -985,38 +982,37 @@
      SYMBOL
       ;;not a dot, dots, or number.
       (let ((stream (in-synonym-of stream)))
-	(etypecase stream
-	  (lisp-stream
-	   (prepare-for-fast-read-char stream
-	     (prog ()
-	      SYMBOL-LOOP
-	      (ouch-read-buffer char)
-	      (setq char (fast-read-char nil nil))
-	      (unless char (go RETURN-SYMBOL))
-	      (case (char-class char attribute-table)
-		(#.escape (done-with-fast-read-char)
-			  (go ESCAPE))
-		(#.delimiter (done-with-fast-read-char)
-			     (unread-char char stream)
-			     (go RETURN-SYMBOL))
-		(#.multiple-escape (done-with-fast-read-char)
-				   (go MULT-ESCAPE))
-		(#.package-delimiter (done-with-fast-read-char)
-				     (go COLON))
-		(t (go SYMBOL-LOOP))))))
-	  (fundamental-stream
-	   (prog ()
-	    SYMBOL-LOOP
-	    (ouch-read-buffer char)
-	    (setq char (stream-read-char stream))
-	    (when (eq char :eof) (go RETURN-SYMBOL))
-	    (case (char-class char attribute-table)
-	      (#.escape (go ESCAPE))
-	      (#.delimiter (stream-unread-char stream char)
-			   (go RETURN-SYMBOL))
-	      (#.multiple-escape (go MULT-ESCAPE))
-	      (#.package-delimiter (go COLON))
-	      (t (go SYMBOL-LOOP)))))))
+	(if (lisp-stream-p stream)
+	    (prepare-for-fast-read-char stream
+	      (prog ()
+	       SYMBOL-LOOP
+	       (ouch-read-buffer char)
+	       (setq char (fast-read-char nil nil))
+	       (unless char (go RETURN-SYMBOL))
+	       (case (char-class char attribute-table)
+		 (#.escape (done-with-fast-read-char)
+			   (go ESCAPE))
+		 (#.delimiter (done-with-fast-read-char)
+			      (unread-char char stream)
+			      (go RETURN-SYMBOL))
+		 (#.multiple-escape (done-with-fast-read-char)
+				    (go MULT-ESCAPE))
+		 (#.package-delimiter (done-with-fast-read-char)
+				      (go COLON))
+		 (t (go SYMBOL-LOOP)))))
+	    ;; Fundamental-stream.
+	    (prog ()
+	     SYMBOL-LOOP
+	     (ouch-read-buffer char)
+	     (setq char (stream-read-char stream))
+	     (when (eq char :eof) (go RETURN-SYMBOL))
+	     (case (char-class char attribute-table)
+	       (#.escape (go ESCAPE))
+	       (#.delimiter (stream-unread-char stream char)
+			    (go RETURN-SYMBOL))
+	       (#.multiple-escape (go MULT-ESCAPE))
+	       (#.package-delimiter (go COLON))
+	       (t (go SYMBOL-LOOP))))))
      ESCAPE
       ;;saw an escape.
       ;;don't put the escape in the read-buffer.
diff --git a/code/sharpm.lisp b/code/sharpm.lisp
index 4371d2410..3ac3b8028 100644
--- a/code/sharpm.lisp
+++ b/code/sharpm.lisp
@@ -5,7 +5,7 @@
 ;;; Carnegie Mellon University, and has been placed in the public domain.
 ;;;
 (ext:file-comment
-  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/sharpm.lisp,v 1.18 1998/05/05 00:14:37 dtc Exp $")
+  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/sharpm.lisp,v 1.19 1998/05/15 01:01:02 dtc Exp $")
 ;;;
 ;;; **********************************************************************
 ;;;
@@ -351,35 +351,34 @@
 (defun sharp-vertical-bar (stream sub-char numarg)
   (ignore-numarg sub-char numarg)
   (let ((stream (in-synonym-of stream)))
-    (etypecase stream
-      (lisp-stream
-       (prepare-for-fast-read-char stream
-         (do ((level 1)
-	      (prev (fast-read-char) char)
-	      (char (fast-read-char) (fast-read-char)))
-	     (())
-	   (cond ((and (char= prev #\|) (char= char #\#))
-		  (setq level (1- level))
-		  (when (zerop level)
-		    (done-with-fast-read-char)
-		    (return (values)))
-		  (setq char (fast-read-char)))
-		 ((and (char= prev #\#) (char= char #\|))
-		  (setq char (fast-read-char))
-		  (setq level (1+ level)))))))
-      (fundamental-stream
-       (do ((level 1)
-	    (prev (read-char stream t) char)
-	    (char (read-char stream t) (read-char stream t)))
-	   (())
-	 (cond ((and (char= prev #\|) (char= char #\#))
-		(setq level (1- level))
-		(when (zerop level)
-		  (return (values)))
-		(setq char (read-char stream t)))
-	       ((and (char= prev #\#) (char= char #\|))
-		(setq char (read-char stream t))
-		(setq level (1+ level)))))))))
+    (if (lisp-stream-p stream)
+	(prepare-for-fast-read-char stream
+          (do ((level 1)
+	       (prev (fast-read-char) char)
+	       (char (fast-read-char) (fast-read-char)))
+	      (())
+	    (cond ((and (char= prev #\|) (char= char #\#))
+		   (setq level (1- level))
+		   (when (zerop level)
+		     (done-with-fast-read-char)
+		     (return (values)))
+		   (setq char (fast-read-char)))
+		  ((and (char= prev #\#) (char= char #\|))
+		   (setq char (fast-read-char))
+		   (setq level (1+ level))))))
+	;; Fundamental-stream.
+	(do ((level 1)
+	     (prev (read-char stream t) char)
+	     (char (read-char stream t) (read-char stream t)))
+	    (())
+	  (cond ((and (char= prev #\|) (char= char #\#))
+		 (setq level (1- level))
+		 (when (zerop level)
+		   (return (values)))
+		 (setq char (read-char stream t)))
+		((and (char= prev #\#) (char= char #\|))
+		 (setq char (read-char stream t))
+		 (setq level (1+ level))))))))
 
 (defun sharp-illegal (stream sub-char ignore)
   (declare (ignore ignore))
diff --git a/code/sysmacs.lisp b/code/sysmacs.lisp
index c41578ad0..3260802e7 100644
--- a/code/sysmacs.lisp
+++ b/code/sysmacs.lisp
@@ -5,7 +5,7 @@
 ;;; Carnegie Mellon University, and has been placed in the public domain.
 ;;;
 (ext:file-comment
-  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/sysmacs.lisp,v 1.19 1998/05/05 00:14:35 dtc Exp $")
+  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/sysmacs.lisp,v 1.20 1998/05/15 01:01:03 dtc Exp $")
 ;;;
 ;;; **********************************************************************
 ;;;
@@ -107,41 +107,37 @@
 	     (T ,@(if check-type `((check-type ,svar ,check-type)))
 		,svar)))))
 
-;;; With-Mumble-Stream calls the function in the given Slot of the Stream with
-;;; the Args for lisp-streams or the pcl-fn for fundamental-streams.
+;;; With-Mumble-Stream calls the function in the given Slot of the
+;;; Stream with the Args for lisp-streams, or the Function with the
+;;; Args for fundamental-streams.
 ;;;
-(defmacro with-in-stream (stream lisp-dispatch &optional pcl-dispatch)
+(defmacro with-in-stream (stream (slot &rest args) &optional stream-dispatch)
   `(let ((stream (in-synonym-of ,stream)))
-    (etypecase stream
-      (lisp-stream
-       ,(destructuring-bind (slot &rest args) lisp-dispatch
-          `(funcall (,slot stream) stream ,@args)))
-      ,@(when pcl-dispatch
-          `((fundamental-stream
-	     ,(destructuring-bind (pcl-fn &rest args) pcl-dispatch
-	        `(,pcl-fn stream ,@args))))))))
-
-(defmacro with-out-stream (stream lisp-dispatch &optional pcl-dispatch)
+    (if (lisp-stream-p stream)
+	(funcall (,slot stream) stream ,@args)
+	,@(when stream-dispatch
+            `(,(destructuring-bind (function &rest args) stream-dispatch
+	         `(,function stream ,@args)))))))
+
+(defmacro with-out-stream (stream (slot &rest args) &optional stream-dispatch)
   `(let ((stream (out-synonym-of ,stream)))
-    (etypecase stream
-      (lisp-stream
-       ,(destructuring-bind (slot &rest args) lisp-dispatch
-          `(funcall (,slot stream) stream ,@args)))
-      ,@(when pcl-dispatch
-          `((fundamental-stream
-	     ,(destructuring-bind (pcl-fn &rest args) pcl-dispatch
-	        `(,pcl-fn stream ,@args))))))))
+    (if (lisp-stream-p stream)
+	(funcall (,slot stream) stream ,@args)
+	,@(when stream-dispatch
+	     `(,(destructuring-bind (function &rest args) stream-dispatch
+	          `(,function stream ,@args)))))))
 
 
 ;;;; These are hacks to make the reader win.
 
 ;;; Prepare-For-Fast-Read-Char  --  Internal
 ;;;
-;;;    This macro sets up some local vars for use by the Fast-Read-Char
-;;; macro within the enclosed lexical scope.
+;;;    This macro sets up some local vars for use by the
+;;; Fast-Read-Char macro within the enclosed lexical scope. The stream
+;;; is assumed to be a lisp-stream.
 ;;;
 (defmacro prepare-for-fast-read-char (stream &body forms)
-  `(let* ((%frc-stream% (in-synonym-of ,stream lisp-stream))
+  `(let* ((%frc-stream% ,stream)
 	  (%frc-method% (lisp-stream-in %frc-stream%))
 	  (%frc-buffer% (lisp-stream-in-buffer %frc-stream%))
 	  (%frc-index% (lisp-stream-in-index %frc-stream%)))
@@ -178,10 +174,10 @@
 ;;; Prepare-For-Fast-Read-Byte  --  Internal
 ;;;
 ;;;    Just like Prepare-For-Fast-Read-Char except that we get the Bin
-;;; method.
+;;; method. The stream is assumed to be a lisp-stream.
 ;;;
 (defmacro prepare-for-fast-read-byte (stream &body forms)
-  `(let* ((%frc-stream% (in-synonym-of ,stream lisp-stream))
+  `(let* ((%frc-stream% ,stream)
 	  (%frc-method% (lisp-stream-bin %frc-stream%))
 	  (%frc-buffer% (lisp-stream-in-buffer %frc-stream%))
 	  (%frc-index% (lisp-stream-in-index %frc-stream%)))
-- 
GitLab