bug#31559: 26.1; Debugger and ERT backtraces are not abbreviated

[Gemini Lasswell <gazally@runbox.com>]

[-- Attachment #1: Type: text/plain, Size: 1198 bytes --]

In Emacs 25, the backtraces produced by debug.el and ert.el
abbreviated long lists and deeply nested forms with "...".  This
doesn't happen in Emacs 26.

To reproduce, evaluate these lines of code:

(defun my-func (arg) arg)
(debug-on-entry 'my-func)
(my-func (make-list 100 'a))

Result: An ellipsis appears in the list in the backtrace in
Emacs 25, and the entire list is printed in Emacs 26.

Edebug's backtraces still have ellipses, but its printing of
evaluation results no longer shows them.

The reason this is happening is that the printing of backtraces by the
debugger was switched to use cl-prin1 by the fix to bug#6991.
Edebug's results printing was switched to cl-prin1 when CL printing
was added to Emacs but its backtrace printing was left as before.

edebug.el, debug.el and ert.el all bind print-level and print-length
before printing backtraces, but CL printing does not pay any attention
to those variables, in spite of cl-prin1's docstring which says
that it does.

Here is a patch that makes cl-prin1 behave like prin1 with respect to
print-level and print-length, except for hash tables (because prin1
prints hash table items and cl-prin1 doesn't, although maybe it
should).


[-- Attachment #2: 0001-Make-CL-printing-respect-print-level-and-print-lengt.patch --]
[-- Type: text/plain, Size: 8890 bytes --]

From b9983ac73df07a5fe78760418fb3fa487b75681e Mon Sep 17 00:00:00 2001
From: Gemini Lasswell <gazally@runbox.com>
Date: Mon, 21 May 2018 18:05:55 -0700
Subject: [PATCH] Make CL printing respect print-level and print-length

* 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 strucure 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.
---
 lisp/emacs-lisp/cl-print.el            | 115 +++++++++++++++++++--------------
 test/lisp/emacs-lisp/cl-print-tests.el |  25 +++++++
 2 files changed, 93 insertions(+), 47 deletions(-)

diff --git a/lisp/emacs-lisp/cl-print.el b/lisp/emacs-lisp/cl-print.el
index ada5923515..55e2bf8bd4 100644
--- a/lisp/emacs-lisp/cl-print.el
+++ b/lisp/emacs-lisp/cl-print.el
@@ -40,6 +40,10 @@ cl-print-readably
 
 (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 @@ cl-print--currently-printing
   (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 @@ cl-print-compiled-button
 (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 @@ cl-print-compiled-button
 
 (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 d986c4015d..bfce4a16ce 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))
-- 
2.16.2