From mboxrd@z Thu Jan 1 00:00:00 1970 Path: news.gmane.org!.POSTED!not-for-mail From: Gemini Lasswell Newsgroups: gmane.emacs.bugs Subject: bug#31559: 26.1; Debugger and ERT backtraces are not abbreviated Date: Tue, 22 May 2018 12:56:44 -0700 Message-ID: <874lizpksp.fsf@runbox.com> NNTP-Posting-Host: blaine.gmane.org Mime-Version: 1.0 Content-Type: multipart/mixed; boundary="=-=-=" X-Trace: blaine.gmane.org 1527018970 8292 195.159.176.226 (22 May 2018 19:56:10 GMT) X-Complaints-To: usenet@blaine.gmane.org NNTP-Posting-Date: Tue, 22 May 2018 19:56:10 +0000 (UTC) To: 31559@debbugs.gnu.org Original-X-From: bug-gnu-emacs-bounces+geb-bug-gnu-emacs=m.gmane.org@gnu.org Tue May 22 21:56:06 2018 Return-path: Envelope-to: geb-bug-gnu-emacs@m.gmane.org Original-Received: from lists.gnu.org ([208.118.235.17]) by blaine.gmane.org with esmtp (Exim 4.84_2) (envelope-from ) id 1fLDO6-0001y9-BR for geb-bug-gnu-emacs@m.gmane.org; Tue, 22 May 2018 21:56:02 +0200 Original-Received: from localhost ([::1]:57657 helo=lists.gnu.org) by lists.gnu.org with esmtp (Exim 4.71) (envelope-from ) id 1fLDQD-0006ig-At for geb-bug-gnu-emacs@m.gmane.org; Tue, 22 May 2018 15:58:13 -0400 Original-Received: from eggs.gnu.org ([2001:4830:134:3::10]:42335) by lists.gnu.org with esmtp (Exim 4.71) (envelope-from ) id 1fLDQ6-0006iY-IJ for bug-gnu-emacs@gnu.org; Tue, 22 May 2018 15:58:08 -0400 Original-Received: from Debian-exim by eggs.gnu.org with spam-scanned (Exim 4.71) (envelope-from ) id 1fLDQ2-0005ND-KD for bug-gnu-emacs@gnu.org; Tue, 22 May 2018 15:58:06 -0400 Original-Received: from debbugs.gnu.org ([208.118.235.43]:36625) by eggs.gnu.org with esmtps (TLS1.0:RSA_AES_128_CBC_SHA1:16) (Exim 4.71) (envelope-from ) id 1fLDQ2-0005Ms-Ei for bug-gnu-emacs@gnu.org; Tue, 22 May 2018 15:58:02 -0400 Original-Received: from Debian-debbugs by debbugs.gnu.org with local (Exim 4.84_2) (envelope-from ) id 1fLDQ2-0003AJ-3S for bug-gnu-emacs@gnu.org; Tue, 22 May 2018 15:58:02 -0400 X-Loop: help-debbugs@gnu.org Resent-From: Gemini Lasswell Original-Sender: "Debbugs-submit" Resent-CC: bug-gnu-emacs@gnu.org Resent-Date: Tue, 22 May 2018 19:58:01 +0000 Resent-Message-ID: Resent-Sender: help-debbugs@gnu.org X-GNU-PR-Message: report 31559 X-GNU-PR-Package: emacs X-GNU-PR-Keywords: X-Debbugs-Original-To: bug-gnu-emacs@gnu.org Original-Received: via spool by submit@debbugs.gnu.org id=B.152701904412122 (code B ref -1); Tue, 22 May 2018 19:58:01 +0000 Original-Received: (at submit) by debbugs.gnu.org; 22 May 2018 19:57:24 +0000 Original-Received: from localhost ([127.0.0.1]:44522 helo=debbugs.gnu.org) by debbugs.gnu.org with esmtp (Exim 4.84_2) (envelope-from ) id 1fLDPP-00039P-DY for submit@debbugs.gnu.org; Tue, 22 May 2018 15:57:23 -0400 Original-Received: from eggs.gnu.org ([208.118.235.92]:50767) by debbugs.gnu.org with esmtp (Exim 4.84_2) (envelope-from ) id 1fLDPL-00039A-Bq for submit@debbugs.gnu.org; Tue, 22 May 2018 15:57:20 -0400 Original-Received: from Debian-exim by eggs.gnu.org with spam-scanned (Exim 4.71) (envelope-from ) id 1fLDPE-0004lp-Fs for submit@debbugs.gnu.org; Tue, 22 May 2018 15:57:14 -0400 Original-Received: from lists.gnu.org ([2001:4830:134:3::11]:39399) by eggs.gnu.org with esmtps (TLS1.0:RSA_AES_256_CBC_SHA1:32) (Exim 4.71) (envelope-from ) id 1fLDPE-0004le-Ag for submit@debbugs.gnu.org; Tue, 22 May 2018 15:57:12 -0400 Original-Received: from eggs.gnu.org ([2001:4830:134:3::10]:41698) by lists.gnu.org with esmtp (Exim 4.71) (envelope-from ) id 1fLDPC-0006f2-H2 for bug-gnu-emacs@gnu.org; Tue, 22 May 2018 15:57:12 -0400 Original-Received: from Debian-exim by eggs.gnu.org with spam-scanned (Exim 4.71) (envelope-from ) id 1fLDP8-0004gw-Jh for bug-gnu-emacs@gnu.org; Tue, 22 May 2018 15:57:10 -0400 Original-Received: from aibo.runbox.com ([91.220.196.211]:40774) by eggs.gnu.org with esmtps (TLS1.0:RSA_AES_128_CBC_SHA1:16) (Exim 4.71) (envelope-from ) id 1fLDP8-0004ed-1a for bug-gnu-emacs@gnu.org; Tue, 22 May 2018 15:57:06 -0400 DKIM-Signature: v=1; a=rsa-sha256; q=dns/txt; c=relaxed/relaxed; d=runbox.com; s=rbselector1; h=Content-Type:MIME-Version:Date:Message-ID:Subject:To:From; bh=eZs2hvs7olgc+kN3p23TNviyenDc0tc+C6+pwK21ndA=; b=Q4ymCznKwQy4+NDWWBCqZKJV3 7TBmQYX5dIjBnmVr7huLQow3qj7I442NSpijE//3/Z7S4p0xo+36HpQTGcaUA5dQ7f05vY8TQdpDx l7He/anwt4AymX4iEFPzhsAn752qKUy6ULHJamv4Uj1yf4Zs/lIXlvI5087035mgLJcGfYLzPXPaF pamYaw/o+ONHVY9ylZu1DlOvq3UtSpK0i/THSMm5OG8xe5lxuzH0lhQJssy+c0B75Q+5vJZswDGJs AlqvHxqXa5GleeKVhq4SaOR8LE0xBKyCZt0innuDDqVqRFCKtKL3mobgTN7hbxC349OrjTh7vKFf6 DYy8UzacQ==; Original-Received: from [10.9.9.210] (helo=mailfront10.runbox.com) by mailtransmit03.runbox with esmtp (Exim 4.86_2) (envelope-from ) id 1fLDP5-0007UX-Aq for bug-gnu-emacs@gnu.org; Tue, 22 May 2018 21:57:03 +0200 Original-Received: from c-24-22-244-161.hsd1.wa.comcast.net ([24.22.244.161] helo=chinook) by mailfront10.runbox.com with esmtpsa (uid:179284 ) (TLS1.2:RSA_AES_256_CBC_SHA1:256) (Exim 4.82) id 1fLDOw-0004So-QN for bug-gnu-emacs@gnu.org; Tue, 22 May 2018 21:56:55 +0200 X-detected-operating-system: by eggs.gnu.org: GNU/Linux 2.2.x-3.x [generic] [fuzzy] X-detected-operating-system: by eggs.gnu.org: GNU/Linux 2.6.x X-BeenThere: debbugs-submit@debbugs.gnu.org X-Mailman-Version: 2.1.18 Precedence: list X-detected-operating-system: by eggs.gnu.org: GNU/Linux 2.2.x-3.x [generic] X-Received-From: 208.118.235.43 X-BeenThere: bug-gnu-emacs@gnu.org List-Id: "Bug reports for GNU Emacs, the Swiss army knife of text editors" List-Unsubscribe: , List-Archive: List-Post: List-Help: List-Subscribe: , Errors-To: bug-gnu-emacs-bounces+geb-bug-gnu-emacs=m.gmane.org@gnu.org Original-Sender: "bug-gnu-emacs" Xref: news.gmane.org gmane.emacs.bugs:146406 Archived-At: --=-=-= Content-Type: text/plain 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). --=-=-= Content-Type: text/plain Content-Disposition: attachment; filename=0001-Make-CL-printing-respect-print-level-and-print-lengt.patch >From b9983ac73df07a5fe78760418fb3fa487b75681e Mon Sep 17 00:00:00 2001 From: Gemini Lasswell 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) : Print ellipsis if printing depth greater than 'print-level' or length of list greater than 'print-length'. (cl-print-object) : Truncate printing with ellipsis if vector is longer than 'print-length'. (cl-print-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 --=-=-=--