From 097ec48176f6d93eb7702fcfa6314ad7c29eb385 Mon Sep 17 00:00:00 2001
From: gerd <gerd>
Date: Sat, 8 Nov 2003 11:45:48 +0000
Subject: [PATCH] 	(in-package :cl-user) 	(require :gray-streams)

	(defclass my-in-stream (ext:fundamental-character-input-stream)
	  ((last-char :initarg :last-char)))

	(let ((string " a ")
	      (i 0))
	  (defmethod ext:stream-read-char ((s my-in-stream))
	    (with-input-from-string (s "b") (read s))
	    (with-slots (last-char) s
	      (cond (last-char (prog1 last-char (setf last-char nil)))
		     (t (prog1 (aref string i)
			  (setq i (mod (1+ i) (length string)))))))))

	(defmethod ext:stream-unread-char ((s my-in-stream) char)
	  (setf (slot-value s 'last-char) char)
	  nil)

	(setq x (make-instance 'my-in-stream :last-char nil))
	(read x)
	 => b, instead of a

	* src/code/reader.lisp: Use a new read buffer for each call to
	read or read-preserving-whitespace, instead of using one global
	buffer.  From Helmut Eller.
---
 code/reader.lisp | 194 +++++++++++++++++++++++++++++------------------
 1 file changed, 121 insertions(+), 73 deletions(-)

diff --git a/code/reader.lisp b/code/reader.lisp
index 2cbe99f73..4523f6ca7 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.42 2003/09/08 17:34:57 gerd Exp $")
+  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/reader.lisp,v 1.43 2003/11/08 11:45:48 gerd Exp $")
 ;;;
 ;;; **********************************************************************
 ;;;
@@ -410,70 +410,106 @@
 
 ;;;; read-buffer implementation.
 
-(defvar read-buffer)
-(defvar read-buffer-length)
+(defvar *read-buffer*)
+(defvar *read-buffer-length*)
 
-(defvar inch-ptr)
-(defvar ouch-ptr)
+(defvar *inch-ptr*)
+(defvar *ouch-ptr*)
 
-(declaim (type index read-buffer-length inch-ptr ouch-ptr))
-(declaim (simple-string read-buffer))
+(declaim (type index *read-buffer-length* *inch-ptr* *ouch-ptr*))
+(declaim (simple-string *read-buffer*))
+
+(defconstant +read-buffer-pool-size+ 16)
+(defconstant +read-buffer-initial-size+ 16)
+
+(defun make-read-buffer-stack (size count)
+  (let ((stack (make-array count :fill-pointer 0)))
+    (dotimes (i count)
+      (vector-push (make-string size) stack))
+    stack))
+
+(defvar *read-buffer-stack*)
+
+(defun init-read-buffer-stack ()
+  (setq *read-buffer-stack*
+	(make-read-buffer-stack +read-buffer-initial-size+ +read-buffer-pool-size+)))
+
+(defun allocate-read-buffer ()
+  (cond ((zerop (fill-pointer *read-buffer-stack*))
+	 (make-string 32))
+	(t (vector-pop  *read-buffer-stack*))))
+
+(defun free-read-buffer (buffer)
+  (vector-push buffer *read-buffer-stack*))
+
+;;; Recursive reader functions use with-read-buffer to allocate a
+;;; fresh buffer.  We currently allocate a fresh buffer only for the
+;;; exported functions READ, READ-PRESERVING-WHITESPACE,
+;;; READ-FROM-STRING, and READ-DELIMITED-LIST.  Some internal
+;;; functions like READ-TOKEN, INTERNAL-READ-EXTENDED-TOKEN and
+;;; READ-STRING avoid the overhead for the allocation and clobber the
+;;; current read-buffer.  
+
+(defmacro with-read-buffer (() &body body)
+  "Bind *read-buffer* to a fresh buffer and execute Body."
+  `(let* ((*read-buffer* (allocate-read-buffer))
+	  (*read-buffer-length* (length *read-buffer*))
+	  (*ouch-ptr* 0)
+	  (*inch-ptr* 0))
+    (unwind-protect (progn ,@body)
+      (free-read-buffer *read-buffer*))))
 
 (defmacro reset-read-buffer ()
-  ;;turn read-buffer into an empty read-buffer.
-  ;;ouch-ptr always points to next char to write
+  ;;turn *read-buffer* into an empty read-buffer.
+  ;;*ouch-ptr* always points to next char to write
   `(progn
-    (setq ouch-ptr 0)
-    ;;inch-ptr always points to next char to read
-    (setq inch-ptr 0)))
-
-(defun init-read-buffer ()
-  (setq read-buffer (make-string 512))			;initial bufsize
-  (setq read-buffer-length 512)
-  (reset-read-buffer))
+    (setq *ouch-ptr* 0)
+    ;;*inch-ptr* always points to next char to read
+    (setq *inch-ptr* 0)))
 
 (defmacro ouch-read-buffer (char)
   `(progn
-    (if (>= (the fixnum ouch-ptr)
-	    (the fixnum read-buffer-length))
+    (if (>= (the fixnum *ouch-ptr*)
+	    (the fixnum *read-buffer-length*))
 	;;buffer overflow -- double the size
 	(grow-read-buffer))
-    (setf (elt (the simple-string read-buffer) ouch-ptr) ,char)
-    (setq ouch-ptr (1+ ouch-ptr))))
-;; macro to move ouch-ptr back one.
+    (setf (elt (the simple-string *read-buffer*) *ouch-ptr*) ,char)
+    (setq *ouch-ptr* (1+ *ouch-ptr*))))
+
+;; macro to move *ouch-ptr* back one.
 (defmacro ouch-unread-buffer ()
-  '(if (> (the fixnum ouch-ptr) (the fixnum inch-ptr))
-       (setq ouch-ptr (1- (the fixnum ouch-ptr)))))
+  '(if (> (the fixnum *ouch-ptr*) (the fixnum *inch-ptr*))
+       (setq *ouch-ptr* (1- (the fixnum *ouch-ptr*)))))
 
 (defun grow-read-buffer ()
-  (let ((rbl (length (the simple-string read-buffer))))
+  (let ((rbl (length (the simple-string *read-buffer*))))
     (declare (fixnum rbl))
-    (setq read-buffer
+    (setq *read-buffer*
 	  (concatenate 'simple-string
-		       (the simple-string read-buffer)
+		       (the simple-string *read-buffer*)
 		       (the simple-string (make-string rbl))))
-    (setq read-buffer-length (* 2 rbl))))
+    (setq *read-buffer-length* (* 2 rbl))))
 
 (defun inchpeek-read-buffer ()
-  (if (>= (the fixnum inch-ptr) (the fixnum ouch-ptr))
+  (if (>= (the fixnum *inch-ptr*) (the fixnum *ouch-ptr*))
       eof-object
-      (elt (the simple-string read-buffer) inch-ptr)))
+      (elt (the simple-string *read-buffer*) *inch-ptr*)))
 
 (defun inch-read-buffer ()
-  (cond ((>= (the fixnum inch-ptr) (the fixnum ouch-ptr))
+  (cond ((>= (the fixnum *inch-ptr*) (the fixnum *ouch-ptr*))
 	 eof-object)
-	(t (prog1 (elt (the simple-string read-buffer) inch-ptr)
-		  (setq inch-ptr (1+ (the fixnum inch-ptr)))))))
+	(t (prog1 (elt (the simple-string *read-buffer*) *inch-ptr*)
+		  (setq *inch-ptr* (1+ (the fixnum *inch-ptr*)))))))
 
 (defmacro unread-buffer ()
-  `(decf (the fixnum inch-ptr)))
+  `(decf (the fixnum *inch-ptr*)))
 
 (defun read-unwind-read-buffer ()
   ;;keep contents, but make next (inch..) return first char.
-  (setq inch-ptr 0))
+  (setq *inch-ptr* 0))
 
 (defun read-buffer-to-string ()
-  (subseq (the simple-string read-buffer) 0 ouch-ptr))
+  (subseq (the simple-string *read-buffer*) 0 *ouch-ptr*))
 
 
 
@@ -493,14 +529,21 @@
 ;;; to leave terminating whitespace in the stream.
 ;;;
 (defun read-preserving-whitespace (&optional (stream *standard-input*)
-					     (eof-errorp t) (eof-value nil)
-					     (recursivep nil))
+				   (eof-errorp t) (eof-value nil)
+				   (recursivep nil))
   "Reads from stream and returns the object read, preserving the whitespace
    that followed the object."
+  (with-read-buffer ()
+    (read-preserving-whitespace-internal stream eof-errorp eof-value recursivep)))
+
+(defun read-preserving-whitespace-internal (&optional (stream *standard-input*)
+					    (eof-errorp t) (eof-value nil)
+					    (recursivep nil))
+  
   (cond
-   (recursivep
-    ;; Loop for repeating when a macro returns nothing.
-    (loop
+    (recursivep
+     ;; Loop for repeating when a macro returns nothing.
+     (loop
       (let ((char (read-char stream eof-errorp eof-object)))
 	(cond ((eofp char) (return eof-value))
 	      ((whitespacep char))
@@ -510,9 +553,9 @@
 			       (funcall macrofun stream char))))
 		 ;; Repeat if macro returned nothing.
 		 (if result (return (car result)))))))))
-   (t
-    (let ((*sharp-equal-alist* nil))
-      (read-preserving-whitespace stream eof-errorp eof-value t)))))
+    (t
+     (let ((*sharp-equal-alist* nil))
+       (read-preserving-whitespace-internal stream eof-errorp eof-value t)))))
 
 
 (defun read-maybe-nothing (stream char)
@@ -528,8 +571,13 @@
   "Reads in the next object in the stream, which defaults to
    *standard-input*. For details see the I/O chapter of
    the manual."
+  (with-read-buffer ()
+    (read-internal stream eof-errorp eof-value recursivep)))
+
+(defun read-internal (&optional (stream *standard-input*) (eof-errorp t)
+		      (eof-value ()) (recursivep ()))
   (prog1
-      (read-preserving-whitespace stream eof-errorp eof-value recursivep)
+      (read-preserving-whitespace-internal stream eof-errorp eof-value recursivep)
     (let ((whitechar (read-char stream nil eof-object)))
       (if (and (not (eofp whitechar))
 	       (or (not (whitespacep whitechar))
@@ -543,19 +591,19 @@
    object's representation is endchar.  A list of those objects read
    is returned."
   (declare (ignore recursive-p))
-  (do ((char (flush-whitespace input-stream)
-	     (flush-whitespace input-stream))
-       (retlist ()))
-      ((char= char endchar) (nreverse retlist))
-    (setq retlist (nconc (read-maybe-nothing input-stream char) retlist))))
-
+  (with-read-buffer ()
+    (do ((char (flush-whitespace input-stream)
+	       (flush-whitespace input-stream))
+	 (retlist ()))
+	((char= char endchar) (nreverse retlist))
+      (setq retlist (nconc (read-maybe-nothing input-stream char) retlist)))))
 
 
 ;;;; Standard ReadMacro definitions to implement the reader.
 
 (defun read-quote (stream ignore)
   (declare (ignore ignore))
-  (list 'quote (read stream t nil t)))
+  (list 'quote (read-internal stream t nil t)))
 
 (defun read-comment (stream ignore)
   (declare (ignore ignore))
@@ -666,7 +714,7 @@
 ;;;
 ;;; Read from the stream up to the next delimiter.  If escape-firstchar is
 ;;; true then the firstchar is assumed to be escaped.  Leaves resulting token
-;;; in read-buffer, returns two values:
+;;; in *read-buffer*, returns two values:
 ;;; -- a list of the escaped character positions, and
 ;;; -- The position of the first package delimiter (or NIL).
 ;;;
@@ -674,7 +722,7 @@
   (reset-read-buffer)
   (let ((escapes ()))
     (when escape-firstchar
-      (push ouch-ptr escapes)
+      (push *ouch-ptr* escapes)
       (ouch-read-buffer firstchar)
       (setq firstchar (read-char stream nil eof-object)))
     (do ((char firstchar (read-char stream nil eof-object))
@@ -688,7 +736,7 @@
       (cond ((escapep char)
 	     ;; It can't be a number, even if it's 1\23.
 	     ;; Read next char here, so it won't be casified.
-	     (push ouch-ptr escapes)
+	     (push *ouch-ptr* escapes)
 	     (let ((nextchar (read-char stream nil eof-object)))
 	       (if (eofp nextchar)
 		   (reader-eof-error stream "after escape character")
@@ -707,17 +755,17 @@
 		     (cond ((eofp nextchar)
 			    (reader-eof-error stream "after escape character"))
 			   (t
-			    (push ouch-ptr escapes)
+			    (push *ouch-ptr* escapes)
 			    (ouch-read-buffer nextchar)))))
 		  (t
-		   (push ouch-ptr escapes)
+		   (push *ouch-ptr* escapes)
 		   (ouch-read-buffer ch))))))
 	    (t
 	     (when (and (constituentp char)
 			(eql (get-secondary-attribute char)
 			     #.package-delimiter)
 			(not colon))
-	       (setq colon ouch-ptr))
+	       (setq colon *ouch-ptr*))
 	     (ouch-read-buffer char))))))
 
 
@@ -781,19 +829,19 @@
 
 ;;; CASIFY-READ-BUFFER  --  Internal
 ;;;
-;;;    Modify the read-buffer according to READTABLE-CASE, ignoring escapes.
+;;;    Modify the *read-buffer* according to READTABLE-CASE, ignoring escapes.
 ;;; ESCAPES is a list of the escaped indices, in reverse order. 
 ;;;
 (defun casify-read-buffer (escapes)
   (let ((case (readtable-case *readtable*)))
     (cond
      ((and (null escapes) (eq case :upcase))
-      (dotimes (i ouch-ptr)
-	(setf (schar read-buffer i) (char-upcase (schar read-buffer i)))))
+      (dotimes (i *ouch-ptr*)
+	(setf (schar *read-buffer* i) (char-upcase (schar *read-buffer* i)))))
      ((eq case :preserve))
      (t
       (macrolet ((skip-esc (&body body)
-		   `(do ((i (1- ouch-ptr) (1- i))
+		   `(do ((i (1- *ouch-ptr*) (1- i))
 			 (escapes escapes))
 			((minusp i))
 		      (declare (fixnum i))
@@ -805,12 +853,12 @@
 					 (assert (= esc i))
 					 (pop escapes)
 					 nil))))
-			(let ((ch (schar read-buffer i)))
+			(let ((ch (schar *read-buffer* i)))
 			  ,@body)))))
 	(flet ((lower-em ()
-		 (skip-esc (setf (schar read-buffer i) (char-downcase ch))))
+		 (skip-esc (setf (schar *read-buffer* i) (char-downcase ch))))
 	       (raise-em ()
-		 (skip-esc (setf (schar read-buffer i) (char-upcase ch)))))
+		 (skip-esc (setf (schar *read-buffer* i) (char-upcase ch)))))
 	  (ecase case
 	    (:upcase (raise-em))
 	    (:downcase (lower-em))
@@ -832,7 +880,7 @@
   ;;Report an error if these are violated (if we called this, we want
   ;;something that is a legitimate token!).
   ;;read in the longest possible string satisfying the bnf for
-  ;;"unqualified-token".  Leave the result in the READ-BUFFER.
+  ;;"unqualified-token".  Leave the result in the *READ-BUFFER*.
   ;;Return next char after token (last char read).
   (when *read-suppress*
     (internal-read-extended-token stream firstchar nil)
@@ -1071,7 +1119,7 @@
       (let ((nextchar (read-char stream nil nil)))
 	(unless nextchar
 	  (reader-eof-error stream "after escape character"))
-	(push ouch-ptr escapes)
+	(push *ouch-ptr* escapes)
 	(ouch-read-buffer nextchar))
       (setq char (read-char stream nil nil))
       (unless char (go RETURN-SYMBOL))
@@ -1085,7 +1133,7 @@
       (do ((char (read-char stream t) (read-char stream t)))
 	  ((multiple-escape-p char))
 	(if (escapep char) (setq char (read-char stream t)))
-	(push ouch-ptr escapes)
+	(push *ouch-ptr* escapes)
 	(ouch-read-buffer char))
       (setq char (read-char stream nil nil))
       (unless char (go RETURN-SYMBOL))
@@ -1145,9 +1193,9 @@
 		 :format-control "Package ~S not found."))
 
 	(if (or (zerop colons) (= colons 2) (eq found *keyword-package*))
-	    (return (intern* read-buffer ouch-ptr found))
+	    (return (intern* *read-buffer* *ouch-ptr* found))
 	    (multiple-value-bind (symbol test)
-				 (find-symbol* read-buffer ouch-ptr found)
+				 (find-symbol* *read-buffer* *ouch-ptr* found)
 	      (when (eq test :external) (return symbol))
 	      (let ((name (read-buffer-to-string)))
 		(with-simple-restart (continue "Use symbol anyway.")
@@ -1263,7 +1311,7 @@
 
 
 (defun make-float ()
-  ;;assume that the contents of read-buffer are a legal float, with nothing
+  ;;assume that the contents of *read-buffer* are a legal float, with nothing
   ;;else after it.
   (read-unwind-read-buffer)
   (let ((negative-fraction nil)
@@ -1364,7 +1412,7 @@
 
 
 (defun make-ratio ()
-  ;;assume read-buffer contains a legal ratio.  Build the number from
+  ;;assume *read-buffer* contains a legal ratio.  Build the number from
   ;;the string.
   ;;look for optional "+" or "-".
   (let ((numerator 0) (denominator 0) (char ()) (negative-number nil))
@@ -1560,7 +1608,7 @@
 ;;;; Reader initialization code.
 
 (defun reader-init ()
-  (init-read-buffer)
+  (init-read-buffer-stack)
   (init-secondary-attribute-table)
   (init-std-lisp-readtable)
 ; (init-integer-reader)
-- 
GitLab