From e0eb1fb4fbff0f7c27c4c7fcef01ce30e86e600b Mon Sep 17 00:00:00 2001 From: Noam Postavsky Date: Sun, 28 May 2017 17:01:05 -0400 Subject: [PATCH v1] 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 3958ee80a3..6703fc99e2 100644 --- a/lisp/emacs-lisp/cl-print.el +++ b/lisp/emacs-lisp/cl-print.el @@ -39,6 +39,7 @@ (defvar cl-print-readably nil "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) @@ -61,8 +62,9 @@ (cl-defmethod cl-print-object ((object cons) stream) (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 @@ -181,15 +183,26 @@ (cl-defmethod cl-print-object ((object cl-structure-object) stream) (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 27d038a166..6448a1b37f 100644 --- a/test/lisp/emacs-lisp/cl-print-tests.el +++ b/test/lisp/emacs-lisp/cl-print-tests.el @@ -47,4 +47,12 @@ (ert-deftest cl-print-tests-2 () "\\`(#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. -- 2.11.1