[Emacs-diffs] master a415c8b 2/2: cl-print: handle circular objects when `print-circle' is nil (Bug#27117)

[Noam Postavsky]

branch: master
commit a415c8bccb917c247792c4ce8e77b2512b3414d6
Author: Noam Postavsky <address@hidden>
Commit: Noam Postavsky <address@hidden>

    cl-print: handle circular objects when `print-circle' is nil (Bug#27117)
    
    * lisp/emacs-lisp/cl-print.el (cl-print--currently-printing): New variable.
    (cl-print-object): When `print-circle' is nil, bind it to a list of
    objects that are currently printing to avoid printing the same object
    endlessly.
    * test/lisp/emacs-lisp/cl-print-tests.el (cl-print-circle): New test.
---
 lisp/emacs-lisp/cl-print.el            | 35 +++++++++++++++++++++++-----------
 test/lisp/emacs-lisp/cl-print-tests.el |  8 ++++++++
 2 files changed, 32 insertions(+), 11 deletions(-)

diff --git a/lisp/emacs-lisp/cl-print.el b/lisp/emacs-lisp/cl-print.el
index 65c86d2..70ccaac 100644
--- a/lisp/emacs-lisp/cl-print.el
+++ b/lisp/emacs-lisp/cl-print.el
@@ -37,6 +37,7 @@
   "If non-nil, try and make sure the result can be `read'.")
 
 (defvar cl-print--number-table nil)
+(defvar cl-print--currently-printing nil)
 
 ;;;###autoload
 (cl-defgeneric cl-print-object (object stream)
@@ -59,8 +60,9 @@ call other entry points instead, such as `cl-prin1'."
       (princ "(" stream)
       (cl-print-object car stream)
       (while (and (consp object)
-                  (not (and cl-print--number-table
-                            (numberp (gethash object 
cl-print--number-table)))))
+                  (not (if cl-print--number-table
+                           (numberp (gethash object cl-print--number-table))
+                         (memq object cl-print--currently-printing))))
         (princ " " stream)
         (cl-print-object (pop object) stream))
       (when object
@@ -156,15 +158,26 @@ call other entry points instead, such as `cl-prin1'."
 
 (cl-defmethod cl-print-object :around (object stream)
   ;; FIXME: Only put such an :around method on types where it's relevant.
-  (let ((n (if cl-print--number-table (gethash object 
cl-print--number-table))))
-    (if (not (numberp n))
-        (cl-call-next-method)
-      (if (> n 0)
-          ;; Already printed.  Just print a reference.
-          (progn (princ "#" stream) (princ n stream) (princ "#" stream))
-        (puthash object (- n) cl-print--number-table)
-        (princ "#" stream) (princ (- n) stream) (princ "=" stream)
-        (cl-call-next-method)))))
+  (cond
+   (print-circle
+    (let ((n (gethash object cl-print--number-table)))
+      (if (not (numberp n))
+          (cl-call-next-method)
+        (if (> n 0)
+            ;; Already printed.  Just print a reference.
+            (progn (princ "#" stream) (princ n stream) (princ "#" stream))
+          (puthash object (- n) cl-print--number-table)
+          (princ "#" stream) (princ (- n) stream) (princ "=" stream)
+          (cl-call-next-method)))))
+   ((let ((already-printing (memq object cl-print--currently-printing)))
+      (when already-printing
+        ;; Currently printing, just print reference to avoid endless
+        ;; recursion.
+        (princ "#" stream)
+        (princ (length (cdr already-printing)) stream))))
+    (t (let ((cl-print--currently-printing
+              (cons object cl-print--currently-printing)))
+         (cl-call-next-method)))))
 
 (defvar cl-print--number-index nil)
 
diff --git a/test/lisp/emacs-lisp/cl-print-tests.el 
b/test/lisp/emacs-lisp/cl-print-tests.el
index 772601f..dfbe18d 100644
--- a/test/lisp/emacs-lisp/cl-print-tests.el
+++ b/test/lisp/emacs-lisp/cl-print-tests.el
@@ -47,4 +47,12 @@
                "\\`(#1=#s(foo 1 2 3) #1#)\\'"
                (cl-prin1-to-string (list x x)))))))
 
+(ert-deftest cl-print-circle ()
+  (let ((x '(#1=(a . #1#) #1#)))
+    (let ((print-circle nil))
+      (should (string-match "\\`((a . #[0-9]) (a . #[0-9]))\\'"
+                            (cl-prin1-to-string x))))
+    (let ((print-circle t))
+      (should (equal "(#1=(a . #1#) #1#)" (cl-prin1-to-string x))))))
+
 ;;; cl-print-tests.el ends here.