* bug#27117: 26.0.50; Setting cl-print-compiled to `static' has problems if print-circle isn't set
2017-05-28 18:33 ` Stefan Monnier
@ 2017-05-28 21:13 ` npostavs
2017-05-31 11:48 ` npostavs
0 siblings, 1 reply; 4+ messages in thread
From: npostavs @ 2017-05-28 21:13 UTC (permalink / raw)
To: Stefan Monnier; +Cc: 27117
[-- Attachment #1: Type: text/plain, Size: 708 bytes --]
retitle 27117 26.0.50; cl-print loops endlessly on circular objects if print-circle is nil
tags 27117 patch
quit
Stefan Monnier <monnier@iro.umontreal.ca> writes:
>
> Indeed, prin1 has a two ways to prevent infinite recursion:
> - limit the print to a certain depth
> - detect when we start printing that we're already in the process of
> printing, and then replace it with #N where N is some kind of depth of
> the reference (so #0 refers to the whole object that we're in the
> process of printing).
>
> cl-prin1 doesn't offer these safety belts, currently (I always set
> print-circle).
Oh, I see, it's not specific to bytecode functions at all. Here's a
patch implementing the 2nd safety belt:
[-- Warning: decoded text below may be mangled, UTF-8 assumed --]
[-- Attachment #2: patch --]
[-- Type: text/x-diff, Size: 4100 bytes --]
From e0eb1fb4fbff0f7c27c4c7fcef01ce30e86e600b Mon Sep 17 00:00:00 2001
From: Noam Postavsky <npostavs@gmail.com>
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
^ permalink raw reply related [flat|nested] 4+ messages in thread