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 77ddd93efbad99dfebb56b9fb0a29c0a53badfd1..a2c199c14ad6462192b7df93a1098c4792e49462 100644 (file)
--- 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 26d49a5ffba023931d64a62c8443a78cd40e3917..77371a1b4cecd0ba0b6d29e9cde91712088c6aaf 100644 (file)
--- 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