master f2a72bb 3/3: Fix print.c infloop on circular lists

[Paul Eggert]

branch: master
commit f2a72bb8ed29223dd1197492d4270c171db5e443
Author: Paul Eggert <address@hidden>
Commit: Paul Eggert <address@hidden>

    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.
---
 src/print.c             | 62 +++++++++++++++++++++----------------------------
 test/src/print-tests.el |  6 ++++-
 2 files changed, 32 insertions(+), 36 deletions(-)

diff --git a/src/print.c b/src/print.c
index 77ddd93..a2c199c 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 26d49a5..77371a1 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