Subject: bug#72334: [PATCH] Always print commas and comma-ats specially

From: Thuna <[email-masked]>
Date: Wed, 12 Feb 2025 23:55:46 +0100

Ok, I have the tests.  In the process I found what I think are bugs in
print-tests.el and realized that I need to patch cl-print.el as well, so
I have all of those here as well, as separate patches.

>From c0a7b13cfbf494f6b4126e73e904151f6c9fc78a Mon Sep 17 00:00:00 2001
From: Thuna <[email-masked]>
Date: Wed, 12 Feb 2025 23:34:16 +0100
Subject: [PATCH 1/4] Fix print-tests

* test/src/print-tests.el (terpri): Erase the buffer *terpri-test*
before individual runs.
(print-circle): Allow circular references with number greater than 9.
---
 test/src/print-tests.el | 3 ++-
 1 file changed, 2 insertions(+), 1 deletion(-)

diff --git a/test/src/print-tests.el b/test/src/print-tests.el
index ddee6d914a4..1a04cf73f30 100644
--- a/test/src/print-tests.el
+++ b/test/src/print-tests.el
@@ -130,6 +130,7 @@ terpri
                      "abc\n")))
   (let ((standard-output
          (with-current-buffer (get-buffer-create "*terpri-test*")
+           (erase-buffer)
            (insert "--------")
            (point-max-marker))))
     (should     (terpri nil t))
@@ -338,7 +339,7 @@ print-tests-strings
 (print-tests--deftest print-circle ()
   (let ((x '(#1=(a . #1#) #1#)))
     (let ((print-circle nil))
-      (should (string-match "\\`((a . #[0-9]) (a . #[0-9]))\\'"
+      (should (string-match "\\`((a . #[0-9]+) (a . #[0-9]+))\\'"
                             (print-tests--prin1-to-string x))))
     (let ((print-circle t))
       (should (equal "(#1=(a . #1#) #1#)" (print-tests--prin1-to-string x))))))
-- 
2.44.2

>From 57be1efaa6ab42b3f32283c09d25bdc32a64992c Mon Sep 17 00:00:00 2001
From: Thuna <[email-masked]>
Date: Wed, 12 Feb 2025 23:36:32 +0100
Subject: [PATCH 2/4] Add tests for printing comma and backquote at the tail
 position

* test/src/print-tests.el (print-tests-5): Add tests for commas outside
of backquotes (Bug#72434) and commas at the tail position (Bug#72334)
---
 test/src/print-tests.el | 17 ++++++++++++++++-
 1 file changed, 16 insertions(+), 1 deletion(-)

diff --git a/test/src/print-tests.el b/test/src/print-tests.el
index 1a04cf73f30..d3093ebed1b 100644
--- a/test/src/print-tests.el
+++ b/test/src/print-tests.el
@@ -305,7 +305,22 @@ print-tests-5
                      (print-tests--prin1-to-string quoted-stuff))))
     (let ((print-quoted nil))
       (should (equal "((quote a) (function b) (\\` ((\\, c) (\\,@ d))))"
-                     (print-tests--prin1-to-string quoted-stuff))))))
+                     (print-tests--prin1-to-string quoted-stuff)))))
+  ;; Bug#72334 and Bug#72434
+  (let ((print-quoted t))
+    (should (equal "`,,foo" (print-tests--prin1-to-string '`,,foo)))
+    (should (equal "`,@,foo" (print-tests--prin1-to-string '`,@,foo)))
+    (should (equal "(foo . `bar)" (print-tests--prin1-to-string '(foo . `bar))))
+    (should (equal "(foo . ,bar)" (print-tests--prin1-to-string '(foo . ,bar))))
+    (should (equal "(foo . ,@bar)" (print-tests--prin1-to-string '(foo . ,@bar))))
+    (should (equal "(foo \\,@ bar baz)" (print-tests--prin1-to-string '(foo . (\,@ bar baz))))))
+  (let ((print-quoted nil))
+    (should (equal "(\\` (\\, (\\, foo)))" (print-tests--prin1-to-string '`,,foo)))
+    (should (equal "(\\` (\\,@ (\\, foo)))" (print-tests--prin1-to-string '`,@,foo)))
+    (should (equal "(foo \\` bar)" (print-tests--prin1-to-string '(foo . `bar))))
+    (should (equal "(foo \\, bar)" (print-tests--prin1-to-string '(foo . ,bar))))
+    (should (equal "(foo \\,@ bar)" (print-tests--prin1-to-string '(foo . ,@bar))))
+    (should (equal "(foo \\,@ bar baz)" (print-tests--prin1-to-string '(foo . (\,@ bar baz)))))))
 
 (print-tests--deftest print-tests-strings ()
   "Can print strings and propertized strings."
-- 
2.44.2

>From 8b4d1ff7ef49a7f0b6e432cf03b7aa33c7fd7e48 Mon Sep 17 00:00:00 2001
From: Thuna <[email-masked]>
Date: Wed, 12 Feb 2025 23:40:44 +0100
Subject: [PATCH 3/4] Print commas and backquotes correctly

* src/print.c (print_object): Print commas and comma-ats as special
regardless of whether they are in a backquote or not, so long as
print-quoted is non-nil.  Print tailing backquote, comma, and comma-at
forms as atoms and not lists.  Calculate the head of OBJ once.
---
 src/print.c | 58 ++++++++++++++++++++++-------------------------------
 1 file changed, 24 insertions(+), 34 deletions(-)

diff --git a/src/print.c b/src/print.c
index c7cba5bface..adc63ec253c 100644
--- a/src/print.c
+++ b/src/print.c
@@ -2483,48 +2483,32 @@ print_object (Lisp_Object obj, Lisp_Object printcharfun, bool escapeflag)
       break;
 
     case Lisp_Cons:
+      Lisp_Object car = XCAR (obj);
       /* If deeper than spec'd depth, print placeholder.  */
       if (FIXNUMP (Vprint_level)
 	  && print_depth > XFIXNUM (Vprint_level))
 	print_c_string ("...", printcharfun);
       else if (print_quoted && CONSP (XCDR (obj)) && NILP (XCDR (XCDR (obj)))
-	       && EQ (XCAR (obj), Qquote))
+	       && (EQ (car, Qquote) ||
+		   EQ (car, Qfunction) ||
+		   EQ (car, Qbackquote) ||
+		   EQ (car, Qcomma) ||
+		   EQ (car, Qcomma_at)))
 	{
-	  printchar ('\'', printcharfun);
+	  if (EQ (car, Qquote))
+	    printchar ('\'', printcharfun);
+	  else if (EQ (car, Qfunction))
+	    print_c_string("#'", printcharfun);
+          else if (EQ (car, Qbackquote))
+	    printchar ('`', printcharfun);
+          else if (EQ (car, Qcomma))
+	    printchar (',', printcharfun);
+          else if (EQ (car, Qcomma_at))
+	    print_c_string (",@", printcharfun);
 	  obj = XCAR (XCDR (obj));
 	  --print_depth;	/* tail recursion */
 	  goto print_obj;
 	}
-      else if (print_quoted && CONSP (XCDR (obj)) && NILP (XCDR (XCDR (obj)))
-	       && EQ (XCAR (obj), Qfunction))
-	{
-	  print_c_string ("#'", printcharfun);
-	  obj = XCAR (XCDR (obj));
-	  --print_depth;	/* tail recursion */
-	  goto print_obj;
-	}
-      /* FIXME: Do we really need the new_backquote_output gating of
-	 special syntax for comma and comma-at?  There is basically no
-	 benefit from it at all, and it would be nice to get rid of
-	 the recursion here without additional complexity.  */
-      else if (print_quoted && CONSP (XCDR (obj)) && NILP (XCDR (XCDR (obj)))
-	       && EQ (XCAR (obj), Qbackquote))
-	{
-	  printchar ('`', printcharfun);
-	  new_backquote_output++;
-	  print_object (XCAR (XCDR (obj)), printcharfun, escapeflag);
-	  new_backquote_output--;
-	}
-      else if (print_quoted && CONSP (XCDR (obj)) && NILP (XCDR (XCDR (obj)))
-	       && (EQ (XCAR (obj), Qcomma)
-		   || EQ (XCAR (obj), Qcomma_at))
-	       && new_backquote_output)
-	{
-	  print_object (XCAR (obj), printcharfun, false);
-	  new_backquote_output--;
-	  print_object (XCAR (XCDR (obj)), printcharfun, escapeflag);
-	  new_backquote_output++;
-	}
       else
 	{
 	  printchar ('(', printcharfun);
@@ -2547,7 +2531,7 @@ print_object (Lisp_Object obj, Lisp_Object printcharfun, bool escapeflag)
 		  .u.list.tortoise_idx = 0,
 		});
 	      /* print the car */
-	      obj = XCAR (obj);
+	      obj = car;
 	      goto print_obj;
 	    }
 	}
@@ -2670,7 +2654,13 @@ print_object (Lisp_Object obj, Lisp_Object printcharfun, bool escapeflag)
 		--print_depth;
 		goto next_obj;
 	      }
-	    else if (CONSP (next))
+	    else if (CONSP (next)
+		     && !(print_quoted
+			  && (EQ (Qbackquote, XCAR (next))
+			      || EQ (Qcomma, XCAR (next))
+			      || EQ (Qcomma_at, XCAR (next)))
+			  && CONSP (XCDR (next))
+			  && NILP (XCDR (XCDR (next)))))
 	      {
 		if (!NILP (Vprint_circle))
 		  {
-- 
2.44.2

>From c6a9843680ebb075ff0d0041ca590656e06bcee7 Mon Sep 17 00:00:00 2001
From: Thuna <[email-masked]>
Date: Wed, 12 Feb 2025 23:42:48 +0100
Subject: [PATCH 4/4] Print backquotes and commas correctly in cl-print.el

* lisp/emacs-lisp/cl-print.el (cl-print--cons-tail): Delete function.
(cl-print-object): Refactor to do the work of `cl-print--cons-tail' as
well.  Print tailing backquote, comma, and comma-ats as atoms.
---
 lisp/emacs-lisp/cl-print.el | 75 ++++++++++++++++++++-----------------
 1 file changed, 41 insertions(+), 34 deletions(-)

diff --git a/lisp/emacs-lisp/cl-print.el b/lisp/emacs-lisp/cl-print.el
index 5af34361b92..4ff8c58eae1 100644
--- a/lisp/emacs-lisp/cl-print.el
+++ b/lisp/emacs-lisp/cl-print.el
@@ -66,43 +66,50 @@ cl-print-object-contents
   (error "Missing cl-print-object-contents method"))
 
 (cl-defmethod cl-print-object ((object cons) stream)
-  (if (and cl-print--depth (natnump print-level)
-           (> cl-print--depth print-level))
-      (cl-print-insert-ellipsis object nil stream)
-    (let ((car (pop object)))
-      (if (and print-quoted
-               (memq car '(\, quote function \` \,@ \,.))
-               (consp object)
-               (null (cdr object)))
-          (progn
-            (princ (cond
-                    ((eq car 'quote) '\')
-                    ((eq car 'function) "#'")
-                    (t car))
-                   stream)
-            (cl-print-object (car object) stream))
-        (princ "(" stream)
-        (cl-print--cons-tail car object stream)
-        (princ ")" stream)))))
-
-(defun cl-print--cons-tail (car object stream)
-  (let ((count 1))
-    (cl-print-object car stream)
-    (while (and (consp object)
-                (not (cond
+  (let ((count 0))
+    (cl-flet* ((quotedp (obj &optional tailp)
+		 (and print-quoted
+                      (consp obj)
+                      (consp (cdr obj))
+                      (null (cddr obj))
+                      (or (and (not tailp) (memq (car object) '(function quote)))
+                          (memq (car obj) '(\` \, \,@ \,.)))))
+               (endp (tail)
+		 (or (atom tail)
+                     (quotedp tail t)
+		     (cond
+		      ((zerop count) nil)
                       (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)
-        (cl-print-insert-ellipsis object t stream)
-        (setq object nil))
-      (cl-incf count))
-    (when object
-      (princ " . " stream) (cl-print-object object stream))))
+		      (t (push object cl-print--currently-printing)
+			 nil)))))
+      (cond
+       ((and cl-print--depth (natnump print-level)
+             (> cl-print--depth print-level))
+	(cl-print-insert-ellipsis object nil stream))
+       ((quotedp object)
+	(princ (cl-case (car object)
+		 (quote "'")
+		 (function "#'")
+		 (t (car object)))
+               stream)
+	(cl-print-object (cadr object) stream))
+       (t
+	(princ "(" stream)
+	(while (not (endp object))
+          (if (and (natnump print-length) (>= count print-length))
+	      (progn
+                (cl-print-insert-ellipsis object t stream)
+                (setq object nil))
+            (cl-print-object (pop object) stream)
+            (when object
+	      (princ " " stream)))
+          (cl-incf count))
+	(when object
+          (princ ". " stream)
+          (cl-print-object object stream))
+	(princ ")" stream))))))
 
 (cl-defmethod cl-print-object-contents ((object cons) _start stream)
   (cl-print--cons-tail (car object) (cdr object) stream))
-- 
2.44.2