From d9e3e0453c30d1c2ea6ee5fd832b25233c9a66ce Mon Sep 17 00:00:00 2001
From: wlott <wlott>
Date: Thu, 13 Dec 1990 23:27:03 +0000
Subject: [PATCH] Added lots of without-interrupts and without-gcing to keep
 them from happening at bad times.

---
 hemlock/ts-stream.lisp | 184 ++++++++++++++++++++++-------------------
 1 file changed, 100 insertions(+), 84 deletions(-)

diff --git a/hemlock/ts-stream.lisp b/hemlock/ts-stream.lisp
index cc4454a06..da4f50a8f 100644
--- a/hemlock/ts-stream.lisp
+++ b/hemlock/ts-stream.lisp
@@ -46,10 +46,11 @@
 (defun ts-stream-accept-input (remote string)
   (let ((stream (wire:remote-object-value remote)))
     (system:without-interrupts
+     (system:without-gcing
       (setf (ts-stream-current-input stream)
 	    (nconc (ts-stream-current-input stream)
 		   (list string)))
-      (setf (ts-stream-char-pos stream) 0)))
+      (setf (ts-stream-char-pos stream) 0))))
   nil)
 
 ;;; %TS-STREAM-LISTEN --- internal.
@@ -59,17 +60,18 @@
 ;;; 
 (defun %ts-stream-listen (stream)
   (flet ((check ()
-		(system:without-interrupts
-		 (loop
-		   (let ((current (ts-stream-current-input stream)))
-		     (cond ((null current)
-			    (return nil))
-			   ((>= (ts-stream-input-read-index stream)
-				(length (the simple-string (car current))))
-			    (pop (ts-stream-current-input stream))
-			    (setf (ts-stream-input-read-index stream) 0))
-			   (t
-			    (return t))))))))
+	   (system:without-interrupts
+	    (system:without-gcing
+	     (loop
+	       (let ((current (ts-stream-current-input stream)))
+		 (cond ((null current)
+			(return nil))
+		       ((>= (ts-stream-input-read-index stream)
+			    (length (the simple-string (car current))))
+			(pop (ts-stream-current-input stream))
+			(setf (ts-stream-input-read-index stream) 0))
+		       (t
+			(return t)))))))))
     (or (check)
 	(progn
 	  (system:serve-all-events 0)
@@ -83,9 +85,10 @@
   (unless (%ts-stream-listen stream)
     (let ((wire (ts-stream-wire stream))
 	  (ts (ts-stream-typescript stream)))
-      (wire:remote wire
-		   (ts-buffer-ask-for-input ts))
-      (wire:wire-force-output wire)
+      (system:without-interrupts
+       (system:without-gcing
+	(wire:remote wire (ts-buffer-ask-for-input ts))
+	(wire:wire-force-output wire)))
       (loop
 	(system:serve-all-events)
 	(when (%ts-stream-listen stream)
@@ -99,12 +102,11 @@
   (declare (ignore eoferr eofval)) ; EOF's are impossible.
   (wait-for-typescript-input stream)
   (system:without-interrupts
-   (prog1
-       (schar (car (ts-stream-current-input stream))
-	      (ts-stream-input-read-index stream))
-     (incf (ts-stream-input-read-index stream)))))
-
-
+   (system:without-gcing
+    (prog1
+	(schar (car (ts-stream-current-input stream))
+	       (ts-stream-input-read-index stream))
+      (incf (ts-stream-input-read-index stream))))))
 
 ;;; %TS-STREAM-READ-LINE --- internal.
 ;;;
@@ -117,12 +119,13 @@
 	       '(progn
 		  (wait-for-typescript-input stream)
 		  (system:without-interrupts
+		   (system:without-gcing
 		    (prog1
 			(if (zerop (ts-stream-input-read-index stream))
 			    (pop (ts-stream-current-input stream))
 			    (subseq (pop (ts-stream-current-input stream))
 				    (ts-stream-input-read-index stream)))
-		      (setf (ts-stream-input-read-index stream) 0))))))
+		      (setf (ts-stream-input-read-index stream) 0)))))))
     (do ((result (next-str) (concatenate 'simple-string result (next-str))))
 	((char= (schar result (1- (length result))) #\newline)
 	 (values (subseq result 0 (1- (length result)))
@@ -131,20 +134,20 @@
 
 ;;; %TS-STREAM-FLSBUF --- internal.
 ;;;
-;;; Flush the output buffer associated with stream.
+;;; Flush the output buffer associated with stream.  This should only be used
+;;; inside a without-interrupts and without-gcing.
 ;;; 
 (defun %ts-stream-flsbuf (stream)
   (when (and (ts-stream-wire stream)
 	     (ts-stream-output-buffer stream)
 	     (not (zerop (ts-stream-output-buffer-index stream))))
     (wire:remote (ts-stream-wire stream)
-      (ts-buffer-output-string (ts-stream-typescript stream)
-			       (subseq (the simple-string
-					    (ts-stream-output-buffer stream))
-				       0
-				       (ts-stream-output-buffer-index stream))))
-    (setf (ts-stream-output-buffer-index stream)
-	  0)))
+      (ts-buffer-output-string
+       (ts-stream-typescript stream)
+       (subseq (the simple-string (ts-stream-output-buffer stream))
+	       0
+	       (ts-stream-output-buffer-index stream))))
+    (setf (ts-stream-output-buffer-index stream) 0)))
 
 ;;; %TS-STREAM-OUT --- internal.
 ;;;
@@ -152,20 +155,22 @@
 ;;;
 (defun %ts-stream-out (stream char)
   (declare (base-character char))
-  (when (= (ts-stream-output-buffer-index stream)
-	   ts-stream-output-buffer-size)
-    (%ts-stream-flsbuf stream))
-  (setf (schar (ts-stream-output-buffer stream)
-	       (ts-stream-output-buffer-index stream))
-	char)
-  (incf (ts-stream-output-buffer-index stream))
-  (incf (ts-stream-char-pos stream))
-  (when (= (char-code char)
-	   (char-code #\Newline))
-    (%ts-stream-flsbuf stream)
-    (setf (ts-stream-char-pos stream) 0)
-    (wire:wire-force-output (ts-stream-wire stream)))
-  char)
+  (system:without-interrupts
+   (system:without-gcing
+    (when (= (ts-stream-output-buffer-index stream)
+	     ts-stream-output-buffer-size)
+      (%ts-stream-flsbuf stream))
+    (setf (schar (ts-stream-output-buffer stream)
+		 (ts-stream-output-buffer-index stream))
+	  char)
+    (incf (ts-stream-output-buffer-index stream))
+    (incf (ts-stream-char-pos stream))
+    (when (= (char-code char)
+	     (char-code #\Newline))
+      (%ts-stream-flsbuf stream)
+      (setf (ts-stream-char-pos stream) 0)
+      (wire:wire-force-output (ts-stream-wire stream)))
+    char)))
 
 ;;; %TS-STREAM-SOUT --- internal.
 ;;;
@@ -178,32 +183,34 @@
 	(newline (position #\Newline string :start start :end end :from-end t))
 	(length (- end start)))
     (when wire
-      (let ((index (ts-stream-output-buffer-index stream)))
-	(cond ((> (+ index length)
-		  ts-stream-output-buffer-size)
-	       (%ts-stream-flsbuf stream)
-	       (wire:remote wire
-		 (ts-buffer-output-string (ts-stream-typescript stream)
-					  (subseq string start end)))
-	       (when newline
-		 (wire:wire-force-output wire)))
-	      (t
-	       (replace (the simple-string (ts-stream-output-buffer stream))
-			string
-			:start1 index
-			:end1 (+ index length)
-			:start2 start
-			:end2 end)
-	       (incf (ts-stream-output-buffer-index stream)
-		     length)
-	       (when newline
+      (system:without-interrupts
+       (system:without-gcing
+	(let ((index (ts-stream-output-buffer-index stream)))
+	  (cond ((> (+ index length)
+		    ts-stream-output-buffer-size)
 		 (%ts-stream-flsbuf stream)
-		 (wire:wire-force-output wire))))))
-    (setf (ts-stream-char-pos stream)
-	  (if newline
-	    (- end newline 1)
-	    (+ (ts-stream-char-pos stream)
-	       length)))))
+		 (wire:remote wire
+		   (ts-buffer-output-string (ts-stream-typescript stream)
+					    (subseq string start end)))
+		 (when newline
+		   (wire:wire-force-output wire)))
+		(t
+		 (replace (the simple-string (ts-stream-output-buffer stream))
+			  string
+			  :start1 index
+			  :end1 (+ index length)
+			  :start2 start
+			  :end2 end)
+		 (incf (ts-stream-output-buffer-index stream)
+		       length)
+		 (when newline
+		   (%ts-stream-flsbuf stream)
+		   (wire:wire-force-output wire)))))
+	(setf (ts-stream-char-pos stream)
+	      (if newline
+		  (- end newline 1)
+		  (+ (ts-stream-char-pos stream)
+		     length))))))))
 
 ;;; %TS-STREAM-UNREAD --- internal.
 ;;;
@@ -211,6 +218,7 @@
 ;;; 
 (defun %ts-stream-unread (stream char)
   (system:without-interrupts
+   (system:without-gcing
     (cond ((and (ts-stream-current-input stream)
 		(> (ts-stream-input-read-index stream) 0))
 	   (setf (schar (car (ts-stream-current-input stream))
@@ -218,7 +226,7 @@
 		 char))
 	  (t
 	   (push (string char) (ts-stream-current-input stream))
-	   (setf (ts-stream-input-read-index stream) 0)))))
+	   (setf (ts-stream-input-read-index stream) 0))))))
 
 ;;; %TS-STREAM-CLOSE --- internal.
 ;;;
@@ -234,12 +242,13 @@
 ;;; Pass the request to the editor and clear any buffered input.
 ;;;
 (defun %ts-stream-clear-input (stream)
-  (when (ts-stream-wire stream)
-    (wire:remote-value (ts-stream-wire stream)
-      (ts-buffer-clear-input (ts-stream-typescript stream))))
   (system:without-interrupts
+   (system:without-gcing
+    (when (ts-stream-wire stream)
+      (wire:remote-value (ts-stream-wire stream)
+	(ts-buffer-clear-input (ts-stream-typescript stream))))
     (setf (ts-stream-current-input stream) nil
-	  (ts-stream-input-read-index stream) 0)))
+	  (ts-stream-input-read-index stream) 0))))
 
 ;;; %TS-STREAM-MISC --- internal.
 ;;;
@@ -260,24 +269,31 @@
      t)
     (:finish-output
      (when (ts-stream-wire stream)
-       (%ts-stream-flsbuf stream)
-       ;; Note: for the return value to come back,
-       ;; all pending RPCs must have completed.
-       (wire:remote-value (ts-stream-wire stream)
-	 (ts-buffer-finish-output (ts-stream-typescript stream))))
+       (system:without-interrupts
+	(system:without-gcing
+	 (%ts-stream-flsbuf stream)
+	 ;; Note: for the return value to come back,
+	 ;; all pending RPCs must have completed.
+	 ;; Therefore, we know it has synced.
+	 (wire:remote-value (ts-stream-wire stream)
+	   (ts-buffer-finish-output (ts-stream-typescript stream))))))
      t)
     (:force-output
      (when (ts-stream-wire stream)
-       (%ts-stream-flsbuf stream)
-       (wire:wire-force-output (ts-stream-wire stream)))
+       (system:without-interrupts
+	(system:without-gcing
+	 (%ts-stream-flsbuf stream)
+	 (wire:wire-force-output (ts-stream-wire stream)))))
      t)
     (:clear-output
      (setf (ts-stream-output-buffer-index stream) 0)
      t)
     (:element-type
-     'char-string)
+     'base-character)
     (:charpos
      (ts-stream-char-pos stream))
     (:line-length
-     (wire:remote-value (ts-stream-wire stream)
-       (ts-buffer-line-length (ts-stream-typescript stream))))))
+     (system:without-interrupts
+      (system:without-gcing
+       (wire:remote-value (ts-stream-wire stream)
+	 (ts-buffer-line-length (ts-stream-typescript stream))))))))
-- 
GitLab