Make cl-print respect print-level and print-length (bug#31559)

* lisp/emacs-lisp/cl-print.el (cl-print--depth): New variable.
(cl-print-object) <cons>: Print ellipsis if printing depth greater
than 'print-level' or length of list greater than 'print-length'.
(cl-print-object) <vector>: Truncate printing with ellipsis if
vector is longer than 'print-length'.
(cl-print-object) <cl-structure-object>: Truncate printing with
ellipsis if structure has more slots than 'print-length'.
(cl-print-object) <:around>: Bind 'cl-print--depth'.
* test/lisp/emacs-lisp/cl-print-tests.el
(cl-print-tests-3, cl-print-tests-4): New tests.

(cherry picked from commit 0f48d18fd2a30f29cc3592a835d2a2254c9b0afb)

2 files changed, 93 insertions, 47 deletions

diff --git a/lisp/emacs-lisp/cl-print.el b/lisp/emacs-lisp/cl-print.el
index 7c0e81c9349..780b9fb3fe9 100644
--- a/lisp/emacs-lisp/cl-print.el
+++ b/lisp/emacs-lisp/cl-print.el
@@ -40,6 +40,10 @@
 
 (defvar cl-print--number-table nil)
 (defvar cl-print--currently-printing nil)
+(defvar cl-print--depth nil
+  "Depth of recursion within cl-print functions.
+Compared to `print-level' to determine when to stop recursing.")
+
 
 ;;;###autoload
 (cl-defgeneric cl-print-object (object stream)
@@ -52,33 +56,45 @@ call other entry points instead, such as `cl-prin1'."
   (prin1 object stream))
 
 (cl-defmethod cl-print-object ((object cons) stream)
-  (let ((car (pop object)))
-    (if (and (memq car '(\, quote \` \,@ \,.))
-             (consp object)
-             (null (cdr object)))
-        (progn
-          (princ (if (eq car 'quote) '\' car) stream)
-          (cl-print-object (car object) stream))
-      (princ "(" stream)
-      (cl-print-object car stream)
-      (while (and (consp object)
-                  (not (cond
-                        (cl-print--number-table
-                         (numberp (gethash object cl-print--number-table)))
-                        ((memq object cl-print--currently-printing))
-                        (t (push object cl-print--currently-printing)
-                           nil))))
-        (princ " " stream)
-        (cl-print-object (pop object) stream))
-      (when object
-        (princ " . " stream) (cl-print-object object stream))
-      (princ ")" stream))))
+  (if (and cl-print--depth (natnump print-level)
+           (> cl-print--depth print-level))
+      (princ "..." stream)
+    (let ((car (pop object))
+          (count 1))
+      (if (and (memq car '(\, quote \` \,@ \,.))
+               (consp object)
+               (null (cdr object)))
+          (progn
+            (princ (if (eq car 'quote) '\' car) stream)
+            (cl-print-object (car object) stream))
+        (princ "(" stream)
+        (cl-print-object car stream)
+        (while (and (consp object)
+                    (not (cond
+                          (cl-print--number-table
+                           (numberp (gethash object cl-print--number-table)))
+                          ((memq object cl-print--currently-printing))
+                          (t (push object cl-print--currently-printing)
+                             nil))))
+          (princ " " stream)
+          (if (or (not (natnump print-length)) (> print-length count))
+              (cl-print-object (pop object) stream)
+            (princ "..." stream)
+            (setq object nil))
+          (cl-incf count))
+        (when object
+          (princ " . " stream) (cl-print-object object stream))
+        (princ ")" stream)))))
 
 (cl-defmethod cl-print-object ((object vector) stream)
   (princ "[" stream)
-  (dotimes (i (length object))
-    (unless (zerop i) (princ " " stream))
-    (cl-print-object (aref object i) stream))
+  (let ((count (length object)))
+    (dotimes (i (if (natnump print-length)
+                    (min print-length count) count))
+      (unless (zerop i) (princ " " stream))
+      (cl-print-object (aref object i) stream))
+    (when (and (natnump print-length) (< print-length count))
+      (princ " ..." stream)))
   (princ "]" stream))
 
 (cl-defmethod cl-print-object ((object hash-table) stream)
@@ -180,14 +196,18 @@ into a button whose action shows the function's disassembly.")
 (cl-defmethod cl-print-object ((object cl-structure-object) stream)
   (princ "#s(" stream)
   (let* ((class (cl-find-class (type-of object)))
-         (slots (cl--struct-class-slots class)))
+         (slots (cl--struct-class-slots class))
+         (count (length slots)))
     (princ (cl--struct-class-name class) stream)
-    (dotimes (i (length slots))
+    (dotimes (i (if (natnump print-length)
+                    (min print-length count) count))
       (let ((slot (aref slots i)))
         (princ " :" stream)
         (princ (cl--slot-descriptor-name slot) stream)
         (princ " " stream)
-        (cl-print-object (aref object (1+ i)) stream))))
+        (cl-print-object (aref object (1+ i)) stream)))
+    (when (and (natnump print-length) (< print-length count))
+      (princ " ..." stream)))
   (princ ")" stream))
 
 ;;; Circularity and sharing.
@@ -198,26 +218,27 @@ into a button whose action shows the function's disassembly.")
 
 (cl-defmethod cl-print-object :around (object stream)
   ;; FIXME: Only put such an :around method on types where it's relevant.
-  (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)))))
+  (let ((cl-print--depth (if cl-print--depth (1+ cl-print--depth) 1)))
+    (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 d986c4015d7..bfce4a16cec 100644
--- a/test/lisp/emacs-lisp/cl-print-tests.el
+++ b/test/lisp/emacs-lisp/cl-print-tests.el
@@ -47,6 +47,31 @@
                "\\`(#1=#s(foo 1 2 3) #1#)\\'"
                (cl-prin1-to-string (list x x)))))))
 
+(cl-defstruct (cl-print-tests-struct
+               (:constructor cl-print-tests-con))
+  a b c d e)
+
+(ert-deftest cl-print-tests-3 ()
+  "CL printing observes `print-length'."
+  (let ((long-list (make-list 5 'a))
+        (long-vec (make-vector 5 'b))
+        (long-struct (cl-print-tests-con))
+        (print-length 4))
+    (should (equal "(a a a a ...)" (cl-prin1-to-string long-list)))
+    (should (equal "[b b b b ...]" (cl-prin1-to-string long-vec)))
+    (should (equal "#s(cl-print-tests-struct :a nil :b nil :c nil :d nil ...)"
+                   (cl-prin1-to-string long-struct)))))
+
+(ert-deftest cl-print-tests-4 ()
+  "CL printing observes `print-level'."
+  (let ((deep-list '(a (b (c (d (e))))))
+        (deep-struct (cl-print-tests-con))
+        (print-level 4))
+    (setf (cl-print-tests-struct-a deep-struct) deep-list)
+    (should (equal "(a (b (c (d ...))))" (cl-prin1-to-string deep-list)))
+    (should (equal "#s(cl-print-tests-struct :a (a (b (c ...))) :b nil :c nil :d nil :e nil)"
+                   (cl-prin1-to-string deep-struct)))))
+
 (ert-deftest cl-print-circle ()
   (let ((x '(#1=(a . #1#) #1#)))
     (let ((print-circle nil))