From: Paul Eggert <eggert@cs.ucla.edu>
Date: Wed, 30 Oct 2019 21:40:06 +0000 (-0700)
Subject: Fix print.c infloop on circular lists
X-Git-Tag: emacs-27.0.90~807
X-Git-Url: http://git.eshelyaron.com/gitweb/?a=commitdiff_plain;h=f2a72bb8ed29223dd1197492d4270c171db5e443;p=emacs.git

Fix print.c infloop on circular lists

Fix infinite loops in print.c when a circular list is passed
to command-error-default-function or to error-message-string.
* src/print.c (print_error_message):
Use FOR_EACH_TAIL to avoid infloop on circular lists.
(print_object): Use FOR_EACH_TAIL_SAFE, as it uses
Brent’s teleporting tortoise-hare algorithm which is
asymptotically better than the classic tortoise-hare
algorithm that the code wsas using.
* test/src/print-tests.el (print-circle-2): When print-circle
is nil, do not insist on a particular cycle-detection heuristic.
(error-message-string-circular): New test.
---

diff --git a/src/print.c b/src/print.c
index 77ddd93efba..a2c199c14ad 100644
--- a/src/print.c
+++ b/src/print.c
@@ -966,13 +966,12 @@ print_error_message (Lisp_Object data, Lisp_Object stream, const char *context,
     else
       sep = NULL;
 
-    for (; CONSP (tail); tail = XCDR (tail), sep = ", ")
+    FOR_EACH_TAIL (tail)
       {
-	Lisp_Object obj;
-
 	if (sep)
 	  write_string (sep, stream);
-	obj = XCAR (tail);
+	sep = ", ";
+	Lisp_Object obj = XCAR (tail);
 	if (!NILP (file_error)
 	    || EQ (errname, Qend_of_file) || EQ (errname, Quser_error))
 	  Fprinc (obj, stream);
@@ -2087,46 +2086,33 @@ print_object (Lisp_Object obj, Lisp_Object printcharfun, bool escapeflag)
 	{
 	  printchar ('(', printcharfun);
 
-	  Lisp_Object halftail = obj;
-
 	  /* Negative values of print-length are invalid in CL.
 	     Treat them like nil, as CMUCL does.  */
 	  intmax_t print_length = (FIXNATP (Vprint_length)
 				   ? XFIXNAT (Vprint_length)
 				   : INTMAX_MAX);
-
+	  Lisp_Object objtail = Qnil;
 	  intmax_t i = 0;
-	  while (CONSP (obj))
+	  FOR_EACH_TAIL_SAFE (obj)
 	    {
-	      /* Detect circular list.  */
-	      if (NILP (Vprint_circle))
-		{
-		  /* Simple but incomplete way.  */
-		  if (i != 0 && EQ (obj, halftail))
-		    {
-		      int len = sprintf (buf, " . #%"PRIdMAX, i >> 1);
-		      strout (buf, len, len, printcharfun);
-		      goto end_of_list;
-		    }
-		}
-	      else
+	      if (i != 0)
 		{
-		  /* With the print-circle feature.  */
-		  if (i != 0)
+		  printchar (' ', printcharfun);
+
+		  if (!NILP (Vprint_circle))
 		    {
-		      Lisp_Object num = Fgethash (obj, Vprint_number_table, Qnil);
+		      /* With the print-circle feature.  */
+		      Lisp_Object num = Fgethash (obj, Vprint_number_table,
+						  Qnil);
 		      if (FIXNUMP (num))
 			{
-			  print_c_string (" . ", printcharfun);
+			  print_c_string (". ", printcharfun);
 			  print_object (obj, printcharfun, escapeflag);
 			  goto end_of_list;
 			}
 		    }
 		}
 
-	      if (i)
-		printchar (' ', printcharfun);
-
 	      if (print_length <= i)
 		{
 		  print_c_string ("...", printcharfun);
@@ -2135,17 +2121,23 @@ print_object (Lisp_Object obj, Lisp_Object printcharfun, bool escapeflag)
 
 	      i++;
 	      print_object (XCAR (obj), printcharfun, escapeflag);
+	      objtail = XCDR (obj);
+	    }
 
-	      obj = XCDR (obj);
-	      if (!(i & 1))
-		halftail = XCDR (halftail);
-	  }
-
-	  /* OBJ non-nil here means it's the end of a dotted list.  */
-	  if (!NILP (obj))
+	  /* OBJTAIL non-nil here means it's the end of a dotted list
+	     or FOR_EACH_TAIL_SAFE detected a circular list.  */
+	  if (!NILP (objtail))
 	    {
 	      print_c_string (" . ", printcharfun);
-	      print_object (obj, printcharfun, escapeflag);
+
+	      if (CONSP (objtail) && NILP (Vprint_circle))
+		{
+		  int len = sprintf (buf, "#%"PRIdMAX, i >> 1);
+		  strout (buf, len, len, printcharfun);
+		  goto end_of_list;
+		}
+
+	      print_object (objtail, printcharfun, escapeflag);
 	    }
 
 	end_of_list:
diff --git a/test/src/print-tests.el b/test/src/print-tests.el
index 26d49a5ffba..77371a1b4ce 100644
--- a/test/src/print-tests.el
+++ b/test/src/print-tests.el
@@ -345,11 +345,15 @@ otherwise, use a different charset."
    ;; Bug#31146.
   (let ((x '(0 . #1=(0 . #1#))))
     (let ((print-circle nil))
-      (should (string-match "\\`(0 0 . #[0-9])\\'"
+      (should (string-match "\\`(0\\( 0\\)* . #[0-9]+)\\'"
                             (print-tests--prin1-to-string x))))
     (let ((print-circle t))
       (should (equal "(0 . #1=(0 . #1#))" (print-tests--prin1-to-string x))))))
 
+(print-tests--deftest error-message-string-circular ()
+  (let ((err (list 'error)))
+    (setcdr err err)
+    (should-error (error-message-string err) :type 'circular-list)))
 
 (provide 'print-tests)
 ;;; print-tests.el ends here