master 2dfeea8962: Fix reader infinite recursion for circular mixed-type values

[Mattias Engdegård]

branch: master
commit 2dfeea8962751718168494c0560d69e678794b39
Author: Mattias Engdegård <mattiase@acm.org>
Commit: Mattias Engdegård <mattiase@acm.org>

    Fix reader infinite recursion for circular mixed-type values
    
    Make sure that the value added to the `read_objects_completed` set is
    the one we actually return; previously this wasn't the case for conses
    because of an optimisation (bug#54501).
    
    Also add a check for vacuous self-references such as #1=#1# instead of
    returning a nonsense value from thin air.
    
    * src/lread.c (read1): Treat numbered conses correctly as described
    above.  Detect vacuous self-references.
    * test/src/lread-tests.el (lread-test-read-and-print)
    (lread-test-circle-cases, lread-circle): Add tests.
---
 src/lread.c             | 46 ++++++++++++++++++++++++++++++----------------
 test/src/lread-tests.el | 22 ++++++++++++++++++++++
 2 files changed, 52 insertions(+), 16 deletions(-)

diff --git a/src/lread.c b/src/lread.c
index 6130300b0a..2538851bac 100644
--- a/src/lread.c
+++ b/src/lread.c
@@ -3488,6 +3488,29 @@ read1 (Lisp_Object readcharfun, int *pch, bool 
first_in_list, bool locate_syms)
                      /* Read the object itself.  */
                      Lisp_Object tem = read0 (readcharfun, locate_syms);
 
+                      if (CONSP (tem))
+                        {
+                         if (BASE_EQ (tem, placeholder))
+                           /* Catch silly games like #1=#1# */
+                           invalid_syntax ("nonsensical self-reference",
+                                           readcharfun);
+
+                         /* Optimisation: since the placeholder is already
+                            a cons, repurpose it as the actual value.
+                            This allows us to skip the substition below,
+                            since the placeholder is already referenced
+                            inside TEM at the appropriate places.  */
+                          Fsetcar (placeholder, XCAR (tem));
+                          Fsetcdr (placeholder, XCDR (tem));
+
+                         struct Lisp_Hash_Table *h2
+                           = XHASH_TABLE (read_objects_completed);
+                         ptrdiff_t i = hash_lookup (h2, placeholder, &hash);
+                         eassert (i < 0);
+                         hash_put (h2, placeholder, Qnil, hash);
+                         return placeholder;
+                       }
+
                      /* If it can be recursive, remember it for
                         future substitutions.  */
                      if (! SYMBOLP (tem)
@@ -3502,24 +3525,15 @@ read1 (Lisp_Object readcharfun, int *pch, bool 
first_in_list, bool locate_syms)
                        }
 
                      /* Now put it everywhere the placeholder was...  */
-                      if (CONSP (tem))
-                        {
-                          Fsetcar (placeholder, XCAR (tem));
-                          Fsetcdr (placeholder, XCDR (tem));
-                          return placeholder;
-                        }
-                      else
-                        {
-                         Flread__substitute_object_in_subtree
-                           (tem, placeholder, read_objects_completed);
+                     Flread__substitute_object_in_subtree
+                       (tem, placeholder, read_objects_completed);
 
-                         /* ...and #n# will use the real value from now on.  */
-                         i = hash_lookup (h, number, &hash);
-                         eassert (i >= 0);
-                         set_hash_value_slot (h, i, tem);
+                     /* ...and #n# will use the real value from now on.  */
+                     i = hash_lookup (h, number, &hash);
+                     eassert (i >= 0);
+                     set_hash_value_slot (h, i, tem);
 
-                         return tem;
-                        }
+                     return tem;
                    }
 
                  /* #n# returns a previously read object.  */
diff --git a/test/src/lread-tests.el b/test/src/lread-tests.el
index 862f6a6595..9ec54c719c 100644
--- a/test/src/lread-tests.el
+++ b/test/src/lread-tests.el
@@ -258,5 +258,27 @@ literals (Bug#20852)."
   (should (equal (read "-0.e-5") -0.0))
   )
 
+(defun lread-test-read-and-print (str)
+  (let* ((read-circle t)
+         (print-circle t)
+         (val (read-from-string str)))
+    (if (consp val)
+        (prin1-to-string (car val))
+      (error "reading %S failed: %S" str val))))
+
+(defconst lread-test-circle-cases
+  '("#1=(#1# . #1#)"
+    "#1=[#1# a #1#]"
+    "#1=(#2=[#1# #2#] . #1#)"
+    "#1=(#2=[#1# #2#] . #2#)"
+    "#1=[#2=(#1# . #2#)]"
+    "#1=(#2=[#3=(#1# . #2#) #4=(#3# . #4#)])"
+    ))
+
+(ert-deftest lread-circle ()
+  (dolist (str lread-test-circle-cases)
+    (ert-info (str :prefix "input: ")
+      (should (equal (lread-test-read-and-print str) str))))
+  (should-error (read-from-string "#1=#1#") :type 'invalid-read-syntax))
 
 ;;; lread-tests.el ends here