bug#27117: 26.0.50; Setting cl-print-compiled to `static' has problems if print-circle isn't set

bug#27117: 26.0.50; Setting cl-print-compiled to `static' has problems if print-circle isn't set

[npostavs]

Perhap this is just expected behaviour when `print-circle' is nil, but
using 'prin1' instead of 'cl-prin1' doesn't have this problem.

The setup is a bit convoluted (adapted from #15789) because I don't
understand what circumstances are needed to produce a bytecode function
with loops.

Evaluate the following from 'emacs -Q':

    (require 'tmm)

    (defvar frame-with-circle nil)

    (defadvice tmm-add-prompt (before emacspeak pre act comp)
      "Speaks the list of completions we have available."
      (setq frame-with-circle (backtrace-frame 4)))

    (tmm-menubar) ; then C-g

    (let ((cl-print-compiled 'static))
      (cl-prin1 (nth 1 frame-with-circle) (current-buffer)))

Prints into the buffer

   #f(compiled-function () #<bytecode> [tmm-add-prompt
    (#f(compiled-function () #<bytecode> [tmm-add-prompt
    (#f(compiled-function () #<bytecode> [tmm-add-prompt
    (#f(compiled-function () #<bytecode> [tmm-add-prompt
    ...

and 

   Debugger entered--Lisp error: (error "Lisp nesting exceeds ‘max-lisp-eval-depth’")

Replacing 'cl-prin1' with 'prin1' gives:

    #[0 "\302\303\301\242\"\210\300 \207" [tmm-add-prompt (#0) remove-hook minibuffer-setup-hook] 3]

bug#27117: 26.0.50; Setting cl-print-compiled to `static' has problems if print-circle isn't set

[Stefan Monnier]

> Replacing 'cl-prin1' with 'prin1' gives:

>     #[0 "\302\303\301\242\"\210\300 \207" [tmm-add-prompt (#0) remove-hook minibuffer-setup-hook] 3]

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).


        Stefan

bug#27117: 26.0.50; Setting cl-print-compiled to `static' has problems if print-circle isn't set

[npostavs]

[-- 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

bug#27117: 26.0.50; Setting cl-print-compiled to `static' has problems if print-circle isn't set

[npostavs]

tags 27117 fixed
close 27117 
quit

npostavs@users.sourceforge.net 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:

Pushed to master [1: a415c8bccb].

[1: a415c8bccb]: 2017-05-31 07:45:43 -0400
  cl-print: handle circular objects when `print-circle' is nil (Bug#27117)
  http://git.savannah.gnu.org/cgit/emacs.git/commit/?id=a415c8bccb917c247792c4ce8e77b2512b3414d6