X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcode%2Fstream.lisp;h=ac44a9053cd6df6b538f738d83ce6b5294d791d5;hb=24407d11d34abdaaef6d839fd0b2665c73b0e6d5;hp=29b8b21ad3f9a4d2a12d51987b0171866248935a;hpb=42b8c7570a2faa21529fadeef84a0caea186aa8c;p=sbcl.git

diff --git a/src/code/stream.lisp b/src/code/stream.lisp
index 29b8b21..ac44a90 100644
--- a/src/code/stream.lisp
+++ b/src/code/stream.lisp
@@ -11,10 +11,6 @@
 
 (in-package "SB!IMPL")
 
-(deftype string-stream ()
-  '(or string-input-stream string-output-stream
-       fill-pointer-output-stream))
-
 ;;;; standard streams
 
 ;;; The initialization of these streams is performed by
@@ -255,6 +251,55 @@
 	(stream-unread-char stream character)))
   nil)
 
+
+;;; In the interest of ``once and only once'' this macro contains the
+;;; framework necessary to implement a peek-char function, which has
+;;; two special-cases (one for gray streams and one for echo streams)
+;;; in addition to the normal case.
+;;;
+;;; All arguments are forms which will be used for a specific purpose
+;;; PEEK-TYPE - the current peek-type as defined by ANSI CL
+;;; EOF-VALUE - the eof-value argument to peek-char
+;;; CHAR-VAR - the variable which will be used to store the current character
+;;; READ-FORM - the form which will be used to read a character
+;;; UNREAD-FORM - ditto for unread-char
+;;; SKIPPED-CHAR-FORM - the form to execute when skipping a character
+;;; EOF-DETECTED-FORM - the form to execute when EOF has been detected
+;;;                     (this will default to CHAR-VAR)
+(defmacro generalized-peeking-mechanism (peek-type eof-value char-var read-form unread-form &optional (skipped-char-form nil) (eof-detected-form nil))
+  `(let ((,char-var ,read-form))
+    (cond ((eql ,char-var ,eof-value) 
+	   ,(if eof-detected-form
+		eof-detected-form
+		char-var))
+	  ((characterp ,peek-type)
+	   (do ((,char-var ,char-var ,read-form))
+	       ((or (eql ,char-var ,eof-value) 
+		    (char= ,char-var ,peek-type))
+		(cond ((eql ,char-var ,eof-value)
+		       ,(if eof-detected-form
+			    eof-detected-form
+			    char-var))
+		      (t ,unread-form
+			 ,char-var)))
+	     ,skipped-char-form))
+	  ((eql ,peek-type t)
+	   (do ((,char-var ,char-var ,read-form))
+	       ((or (eql ,char-var ,eof-value)
+		    (not (whitespace-char-p ,char-var)))
+		(cond ((eql ,char-var ,eof-value)
+		       ,(if eof-detected-form
+			    eof-detected-form
+			    char-var))
+		      (t ,unread-form
+			 ,char-var)))
+	     ,skipped-char-form))
+	  ((null ,peek-type)
+	   ,unread-form
+	   ,char-var)
+	  (t
+	   (bug "Impossible case reached in PEEK-CHAR")))))
+
 (defun peek-char (&optional (peek-type nil)
 			    (stream *standard-input*)
 			    (eof-error-p t)
@@ -273,52 +318,28 @@
 	   :format-control "~@<bad PEEK-TYPE=~S, ~_expected ~S~:>"
 	   :format-arguments (list peek-type '(or character boolean))))
   (let ((stream (in-synonym-of stream)))
-    (if (ansi-stream-p stream)
-	(let ((char (read-char stream eof-error-p eof-value)))
-	  (cond ((eq char eof-value) char)
-		((characterp peek-type)
-		 (do ((char char (read-char stream eof-error-p eof-value)))
-		     ((or (eq char eof-value) (char= char peek-type))
-		      (unless (eq char eof-value)
-			(unread-char char stream))
-		      char)))
-		((eq peek-type t)
-		 (do ((char char (read-char stream eof-error-p eof-value)))
-		     ((or (eq char eof-value) (not (whitespace-char-p char)))
-		      (unless (eq char eof-value)
-			(unread-char char stream))
-		      char)))
-		((null peek-type)
-		 (unread-char char stream)
-		 char)
-		(t
-		 (bug "impossible case"))))
-	;; by elimination, must be Gray streams FUNDAMENTAL-STREAM
-	(cond ((characterp peek-type)
-	       (do ((char (stream-read-char stream)
-			  (stream-read-char stream)))
-		   ((or (eq char :eof) (char= char peek-type))
-		    (cond ((eq char :eof)
-			   (eof-or-lose stream eof-error-p eof-value))
-			  (t
-			   (stream-unread-char stream char)
-			   char)))))
-	      ((eq peek-type t)
-	       (do ((char (stream-read-char stream)
-			  (stream-read-char stream)))
-		   ((or (eq char :eof) (not (whitespace-char-p char)))
-		    (cond ((eq char :eof)
-			   (eof-or-lose stream eof-error-p eof-value))
-			  (t
-			   (stream-unread-char stream char)
-			   char)))))
-	      ((null peek-type)
-	       (let ((char (stream-peek-char stream)))
-		 (if (eq char :eof)
-		     (eof-or-lose stream eof-error-p eof-value)
-		     char)))
-	      (t
-	       (bug "impossible case"))))))
+    (cond ((typep stream 'echo-stream)
+	   (echo-misc stream 
+		      :peek-char
+		      peek-type
+		      (list eof-error-p eof-value)))
+	  ((ansi-stream-p stream)
+	   (generalized-peeking-mechanism
+	    peek-type eof-value char
+	    (read-char stream eof-error-p eof-value)
+	    (unread-char char stream)))
+	  (t
+	   ;; by elimination, must be Gray streams FUNDAMENTAL-STREAM
+	   (generalized-peeking-mechanism
+	    peek-type :eof char
+	    (if (null peek-type)
+		(stream-peek-char stream)
+		(stream-read-char stream))
+	    (if (null peek-type)
+		()
+		(stream-unread-char stream char))
+	    ()
+	    (eof-or-lose stream eof-error-p eof-value))))))
 
 (defun listen (&optional (stream *standard-input*))
   (let ((stream (in-synonym-of stream)))
@@ -990,6 +1011,41 @@
 	     in-type `(and ,in-type ,out-type))))
       (:close
        (set-closed-flame stream))
+      (:peek-char
+       ;; For the special case of peeking into an echo-stream
+       ;; arg1 is PEEK-TYPE, arg2 is (EOF-ERROR-P EOF-VALUE)
+       ;; returns peeked-char, eof-value, or errors end-of-file
+       ;;
+       ;; Note: This code could be moved into PEEK-CHAR if desired.
+       ;; I am unsure whether this belongs with echo-streams because it is
+       ;; echo-stream specific, or PEEK-CHAR because it is peeking code.
+       ;; -- mrd 2002-11-18
+       ;;
+       ;; UNREAD-CHAR-P indicates whether the current character was one
+       ;; that was previously unread.  In that case, we need to ensure that
+       ;; the semantics for UNREAD-CHAR are held; the character should
+       ;; not be echoed again.
+       (let ((unread-char-p nil))
+	 (flet ((outfn (c)
+		  (unless unread-char-p
+		    (if (ansi-stream-p out)
+			(funcall (ansi-stream-out out) out c)
+			;; gray-stream
+			(stream-write-char out c))))
+		(infn ()
+		  ;; Obtain input from unread buffer or input stream,
+		  ;; and set the flag appropriately.
+		  (cond ((not (null (echo-stream-unread-stuff stream)))
+			 (setf unread-char-p t)
+			 (pop (echo-stream-unread-stuff stream)))
+			(t
+			 (setf unread-char-p nil)
+			 (read-char in (first arg2) (second arg2))))))
+	   (generalized-peeking-mechanism
+	    arg1 (second arg2) char
+	    (infn)
+	    (unread-char char in)
+	    (outfn char)))))
       (t
        (or (if (ansi-stream-p in)
 	       (funcall (ansi-stream-misc in) in operation arg1 arg2)
@@ -997,20 +1053,27 @@
 	   (if (ansi-stream-p out)
 	       (funcall (ansi-stream-misc out) out operation arg1 arg2)
 	       (stream-misc-dispatch out operation arg1 arg2)))))))
+
+;;;; base STRING-STREAM stuff
 
+(defstruct (string-stream
+             (:include ansi-stream)
+             (:constructor nil)
+             (:copier nil))
+  (string nil :type string))
 
-;;;; string input streams
+;;;; STRING-INPUT-STREAM stuff
 
 (defstruct (string-input-stream
-	     (:include ansi-stream
+	     (:include string-stream
 		       (in #'string-inch)
 		       (bin #'string-binch)
 		       (n-bin #'string-stream-read-n-bytes)
-		       (misc #'string-in-misc))
+		       (misc #'string-in-misc)
+                       (string nil :type simple-string))
 	     (:constructor internal-make-string-input-stream
 			   (string current end))
 	     (:copier nil))
-  (string nil :type simple-string)
   (current nil :type index)
   (end nil :type index))
 
@@ -1091,17 +1154,17 @@
   (internal-make-string-input-stream (coerce string 'simple-string)
 				     start end))
 
-;;;; string output streams
+;;;; STRING-OUTPUT-STREAM stuff
 
 (defstruct (string-output-stream
-	    (:include ansi-stream
+	    (:include string-stream
 		      (out #'string-ouch)
 		      (sout #'string-sout)
-		      (misc #'string-out-misc))
+		      (misc #'string-out-misc)
+                      ;; The string we throw stuff in.
+                      (string (make-string 40) :type simple-string))
 	    (:constructor make-string-output-stream ())
 	    (:copier nil))
-  ;; The string we throw stuff in.
-  (string (make-string 40) :type simple-string)
   ;; Index of the next location to use.
   (index 0 :type fixnum))
 
@@ -1190,16 +1253,17 @@
 	(satisfies array-has-fill-pointer-p)))
 
 (defstruct (fill-pointer-output-stream
- 	    (:include ansi-stream
+ 	    (:include string-stream
 		      (out #'fill-pointer-ouch)
 		      (sout #'fill-pointer-sout)
-		      (misc #'fill-pointer-misc))
+		      (misc #'fill-pointer-misc)
+                      ;; a string with a fill pointer where we stuff
+                      ;; the stuff we write
+                      (string (error "missing argument")
+                              :type string-with-fill-pointer
+                              :read-only t))
 	    (:constructor make-fill-pointer-output-stream (string))
-	    (:copier nil))
-  ;; a string with a fill pointer where we stuff the stuff we write
-  (string (error "missing argument")
-	  :type string-with-fill-pointer
-	  :read-only t))
+	    (:copier nil)))
 
 (defun fill-pointer-ouch (stream character)
   (let* ((buffer (fill-pointer-output-stream-string stream))