Create common tests for print.c and cl-print.el

* test/lisp/emacs-lisp/cl-print-tests.el
(cl-print--test, cl-print-tests-1, cl-print-tests-2)
(cl-print-tests-3, cl-print-tests-4, cl-print-tests-5)
(cl-print-tests-strings, cl-print-circle, cl-print-circle-2):
Remove.
* test/src/print-tests.el (print-tests--prin1-to-string): New
alias.
(print-tests--deftest): New macro.
(print-hex-backslash, print-read-roundtrip, print-bignum): Define with
print-tests--deftest and use print-tests--prin1-to-string.
(print-tests--prints-with-charset-p): Use
print-tests--prin1-to-string.
(print-tests--print-charset-text-property-nil)
(print-tests--print-charset-text-property-t)
(print-tests--print-charset-text-property-default): Define with
print-tests--deftest.
(print-tests-print-gensym)
(print-tests-continuous-numbering, print-tests-1, print-tests-2)
(print-tests-3, print-tests-4, print-tests-5)
(print-tests-strings, print-circle, print-circle-2): New tests.
(print--test, print-tests-struct): New cl-defstructs.

2 files changed, 250 insertions, 124 deletions

diff --git a/test/lisp/emacs-lisp/cl-print-tests.el b/test/lisp/emacs-lisp/cl-print-tests.el
index 406c528dce5..31d79df71b5 100644
--- a/test/lisp/emacs-lisp/cl-print-tests.el
+++ b/test/lisp/emacs-lisp/cl-print-tests.el
@@ -19,109 +19,17 @@
 
 ;;; Commentary:
 
+;; See test/src/print-tests.el for tests which apply to both
+;; cl-print.el and src/print.c.
+
 ;;; Code:
 
 (require 'ert)
 
-(cl-defstruct cl-print--test a b)
-
-(ert-deftest cl-print-tests-1 ()
-  "Test cl-print code."
-  (let ((x (make-cl-print--test :a 1 :b 2)))
-    (let ((print-circle nil))
-      (should (equal (cl-prin1-to-string `((x . ,x) (y . ,x)))
-                     "((x . #s(cl-print--test :a 1 :b 2)) (y . #s(cl-print--test :a 1 :b 2)))")))
-    (let ((print-circle t))
-      (should (equal (cl-prin1-to-string `((x . ,x) (y . ,x)))
-                     "((x . #1=#s(cl-print--test :a 1 :b 2)) (y . #1#))")))
-    (should (string-match "\\`#f(compiled-function (x) \"[^\"]+\" [^)]*)\\'"
-                          (cl-prin1-to-string (symbol-function #'caar))))))
-
-(ert-deftest cl-print-tests-2 ()
-  (let ((x (record 'foo 1 2 3)))
-    (should (equal
-             x
-             (car (read-from-string (with-output-to-string (prin1 x))))))
-    (let ((print-circle t))
-      (should (string-match
-               "\\`(#1=#s(foo 1 2 3) #1#)\\'"
-               (cl-prin1-to-string (list x x)))))))
-
 (cl-defstruct (cl-print-tests-struct
                (:constructor cl-print-tests-con))
   a b c d e)
 
-(ert-deftest cl-print-tests-3 ()
-  "CL printing observes `print-length'."
-  (let ((long-list (make-list 5 'a))
-        (long-vec (make-vector 5 'b))
-        (long-struct (cl-print-tests-con))
-        (long-string (make-string 5 ?a))
-        (print-length 4))
-    (should (equal "(a a a a ...)" (cl-prin1-to-string long-list)))
-    (should (equal "[b b b b ...]" (cl-prin1-to-string long-vec)))
-    (should (equal "#s(cl-print-tests-struct :a nil :b nil :c nil :d nil ...)"
-                   (cl-prin1-to-string long-struct)))
-    (should (equal "\"aaaa...\"" (cl-prin1-to-string long-string)))))
-
-(ert-deftest cl-print-tests-4 ()
-  "CL printing observes `print-level'."
-  (let* ((deep-list '(a (b (c (d (e))))))
-         (buried-vector '(a (b (c (d [e])))))
-         (deep-struct (cl-print-tests-con))
-         (buried-struct `(a (b (c (d ,deep-struct)))))
-         (buried-string '(a (b (c (d #("hello" 0 5 (cl-print-test t)))))))
-         (buried-simple-string '(a (b (c (d "hello")))))
-         (print-level 4))
-    (setf (cl-print-tests-struct-a deep-struct) deep-list)
-    (should (equal "(a (b (c (d ...))))" (cl-prin1-to-string deep-list)))
-    (should (equal "(a (b (c (d ...))))" (cl-prin1-to-string buried-vector)))
-    (should (equal "(a (b (c (d ...))))" (cl-prin1-to-string buried-struct)))
-    (should (equal "(a (b (c (d ...))))" (cl-prin1-to-string buried-string)))
-    (should (equal "(a (b (c (d \"hello\"))))"
-                   (cl-prin1-to-string buried-simple-string)))
-    (should (equal "#s(cl-print-tests-struct :a (a (b (c ...))) :b nil :c nil :d nil :e nil)"
-                   (cl-prin1-to-string deep-struct)))))
-
-(ert-deftest cl-print-tests-5 ()
-  "CL printing observes `print-quoted'."
-  (let ((quoted-stuff '('a #'b `(,c ,@d))))
-    (let ((print-quoted t))
-      (should (equal "('a #'b `(,c ,@d))"
-                     (cl-prin1-to-string quoted-stuff))))
-    (let ((print-quoted nil))
-      (should (equal "((quote a) (function b) (\\` ((\\, c) (\\,@ d))))"
-                     (cl-prin1-to-string quoted-stuff))))))
-
-(ert-deftest cl-print-tests-strings ()
-  "CL printing prints strings and propertized strings."
-  (let* ((str1 "abcdefghij")
-         (str2 #("abcdefghij" 3 6 (bold t) 7 9 (italic t)))
-         (str3 #("abcdefghij" 0 10 (test t)))
-         (obj '(a b))
-         ;; Since the byte compiler reuses string literals,
-         ;; and the put-text-property call is destructive, use
-         ;; copy-sequence to make a new string.
-         (str4 (copy-sequence "abcdefghij")))
-    (put-text-property 0 5 'test obj str4)
-    (put-text-property 7 10 'test obj str4)
-
-    (should (equal "\"abcdefghij\"" (cl-prin1-to-string str1)))
-    (should (equal "#(\"abcdefghij\" 3 6 (bold t) 7 9 (italic t))"
-                   (cl-prin1-to-string str2)))
-    (should (equal "#(\"abcdefghij\" 0 10 (test t))"
-                   (cl-prin1-to-string str3)))
-    (let ((print-circle nil))
-      (should
-       (equal
-        "#(\"abcdefghij\" 0 5 (test (a b)) 7 10 (test (a b)))"
-        (cl-prin1-to-string str4))))
-    (let ((print-circle t))
-      (should
-       (equal
-        "#(\"abcdefghij\" 0 5 (test #1=(a b)) 7 10 (test #1#))"
-        (cl-prin1-to-string str4))))))
-
 (ert-deftest cl-print-tests-ellipsis-cons ()
   "Ellipsis expansion works in conses."
   (let ((print-length 4)
@@ -216,23 +124,6 @@
     (should (string-match expanded (with-output-to-string
                                      (cl-print-expand-ellipsis value nil))))))
 
-(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))))))
-
-(ert-deftest cl-print-circle-2 ()
-  ;; Bug#31146.
-  (let ((x '(0 . #1=(0 . #1#))))
-    (let ((print-circle nil))
-      (should (string-match "\\`(0 0 . #[0-9])\\'"
-                            (cl-prin1-to-string x))))
-    (let ((print-circle t))
-      (should (equal "(0 . #1=(0 . #1#))" (cl-prin1-to-string x))))))
-
 (ert-deftest cl-print-tests-print-to-string-with-limit ()
   (let* ((thing10 (make-list 10 'a))
          (thing100 (make-list 100 'a))
diff --git a/test/src/print-tests.el b/test/src/print-tests.el
index 8e377d71808..26d49a5ffba 100644
--- a/test/src/print-tests.el
+++ b/test/src/print-tests.el
@@ -21,42 +21,86 @@
 
 (require 'ert)
 
-(ert-deftest print-hex-backslash ()
+;; Support sharing test code with cl-print-tests.
+
+(defalias 'print-tests--prin1-to-string #'identity
+  "The function to print to a string which is under test.")
+
+(defmacro print-tests--deftest (name arg &rest docstring-keys-and-body)
+  "Test both print.c and cl-print.el at once."
+  (declare (debug ert-deftest)
+           (doc-string 3)
+           (indent 2))
+  (let ((clname (intern (concat (symbol-name name) "-cl-print")))
+        (doc (when (stringp (car-safe docstring-keys-and-body))
+               (list (pop docstring-keys-and-body))))
+        (keys-and-values nil))
+    (while (keywordp (car-safe docstring-keys-and-body))
+      (let ((key (pop docstring-keys-and-body))
+            (val (pop docstring-keys-and-body)))
+        (push val keys-and-values)
+        (push key keys-and-values)))
+    `(progn
+       ;; Set print-tests--prin1-to-string at both declaration and
+       ;; runtime, so that it can be used by the :expected-result
+       ;; keyword.
+       (cl-letf (((symbol-function #'print-tests--prin1-to-string)
+                  #'prin1-to-string))
+         (ert-deftest ,name ,arg
+           ,@doc
+           ,@keys-and-values
+           (cl-letf (((symbol-function #'print-tests--prin1-to-string)
+                      #'prin1-to-string))
+             ,@docstring-keys-and-body)))
+       (cl-letf (((symbol-function #'print-tests--prin1-to-string)
+                  #'cl-prin1-to-string))
+         (ert-deftest ,clname ,arg
+           ,@doc
+           ,@keys-and-values
+           (cl-letf (((symbol-function #'print-tests--prin1-to-string)
+                      #'cl-prin1-to-string))
+             ,@docstring-keys-and-body))))))
+
+(print-tests--deftest print-hex-backslash ()
   (should (string= (let ((print-escape-multibyte t)
                          (print-escape-newlines t))
-                     (prin1-to-string "\u00A2\ff"))
+                     (print-tests--prin1-to-string "\u00A2\ff"))
                    "\"\\x00a2\\ff\"")))
 
 (defun print-tests--prints-with-charset-p (ch odd-charset)
-  "Return t if `prin1-to-string' prints CH with the `charset' property.
+  "Return t if print function being tested prints CH with the `charset' property.
 CH is propertized with a `charset' value according to
 ODD-CHARSET: if nil, then use the one returned by `char-charset',
 otherwise, use a different charset."
   (integerp
    (string-match
     "charset"
-    (prin1-to-string
+    (print-tests--prin1-to-string
      (propertize (string ch)
                  'charset
                  (if odd-charset
                      (cl-find (char-charset ch) charset-list :test-not #'eq)
                    (char-charset ch)))))))
 
-(ert-deftest print-charset-text-property-nil ()
+(print-tests--deftest print-charset-text-property-nil ()
+  :expected-result (if (eq (symbol-function #'print-tests--prin1-to-string)
+                           #'cl-prin1-to-string) :failed :passed)
   (let ((print-charset-text-property nil))
     (should-not (print-tests--prints-with-charset-p ?\xf6 t)) ; Bug#31376.
     (should-not (print-tests--prints-with-charset-p ?a t))
     (should-not (print-tests--prints-with-charset-p ?\xf6 nil))
     (should-not (print-tests--prints-with-charset-p ?a nil))))
 
-(ert-deftest print-charset-text-property-default ()
+(print-tests--deftest print-charset-text-property-default ()
+  :expected-result (if (eq (symbol-function #'print-tests--prin1-to-string)
+                           #'cl-prin1-to-string) :failed :passed)
   (let ((print-charset-text-property 'default))
     (should (print-tests--prints-with-charset-p ?\xf6 t))
     (should-not (print-tests--prints-with-charset-p ?a t))
     (should-not (print-tests--prints-with-charset-p ?\xf6 nil))
     (should-not (print-tests--prints-with-charset-p ?a nil))))
 
-(ert-deftest print-charset-text-property-t ()
+(print-tests--deftest print-charset-text-property-t ()
   (let ((print-charset-text-property t))
     (should (print-tests--prints-with-charset-p ?\xf6 t))
     (should (print-tests--prints-with-charset-p ?a t))
@@ -94,7 +138,7 @@ otherwise, use a different charset."
                        (buffer-string))
                      "--------\n"))))
 
-(ert-deftest print-read-roundtrip ()
+(print-tests--deftest print-read-roundtrip ()
   (let ((syms (list '## '& '* '+ '- '/ '0E '0e '< '= '> 'E 'E0 'NaN '\"
                     '\# '\#x0 '\' '\'\' '\( '\) '\+00 '\, '\-0 '\. '\.0
                     '\0 '\0.0 '\0E0 '\0e0 '\1E+ '\1E+NaN '\1e+ '\1e+NaN
@@ -105,16 +149,207 @@ otherwise, use a different charset."
                     (intern "\N{ZERO WIDTH SPACE}")
                     (intern "\0"))))
     (dolist (sym syms)
-      (should (eq (read (prin1-to-string sym)) sym))
+      (should (eq (read (print-tests--prin1-to-string sym)) sym))
       (dolist (sym1 syms)
         (let ((sym2 (intern (concat (symbol-name sym) (symbol-name sym1)))))
-          (should (eq (read (prin1-to-string sym2)) sym2)))))))
+          (should (eq (read (print-tests--prin1-to-string sym2)) sym2)))))))
 
-(ert-deftest print-bignum ()
+(print-tests--deftest print-bignum ()
   (let* ((str "999999999999999999999999999999999")
          (val (read str)))
     (should (> val most-positive-fixnum))
-    (should (equal (prin1-to-string val) str))))
+    (should (equal (print-tests--prin1-to-string val) str))))
+
+(print-tests--deftest print-tests-print-gensym ()
+  "Printing observes `print-gensym'."
+  (let* ((sym1 (gensym))
+         (syms (list sym1 (gensym "x") (make-symbol "y") sym1)))
+    (let* ((print-circle nil)
+           (printed-with (let ((print-gensym t))
+                           (print-tests--prin1-to-string syms)))
+           (printed-without (let ((print-gensym nil))
+                              (print-tests--prin1-to-string syms))))
+      (should (string-match
+               "(#:\\(g[[:digit:]]+\\) #:x[[:digit:]]+ #:y #:\\(g[[:digit:]]+\\))$"
+               printed-with))
+      (should (string= (match-string 1 printed-with)
+                       (match-string 2 printed-with)))
+      (should (string-match "(g[[:digit:]]+ x[[:digit:]]+ y g[[:digit:]]+)$"
+                            printed-without)))
+    (let* ((print-circle t)
+           (printed-with (let ((print-gensym t))
+                           (print-tests--prin1-to-string syms)))
+           (printed-without (let ((print-gensym nil))
+                              (print-tests--prin1-to-string syms))))
+      (should (string-match "(#1=#:g[[:digit:]]+ #:x[[:digit:]]+ #:y #1#)$"
+                            printed-with))
+      (should (string-match "(g[[:digit:]]+ x[[:digit:]]+ y g[[:digit:]]+)$"
+                            printed-without)))))
+
+(print-tests--deftest print-tests-continuous-numbering ()
+  "Printing observes `print-continuous-numbering'."
+  ;; cl-print does not support print-continuous-numbering.
+  :expected-result (if (eq (symbol-function #'print-tests--prin1-to-string)
+                           #'cl-prin1-to-string) :failed :passed)
+  (let* ((x (list 1))
+         (y "hello")
+         (g (gensym))
+         (g2 (gensym))
+         (print-circle t)
+         (print-gensym t))
+    (let ((print-continuous-numbering t)
+          (print-number-table nil))
+      (should (string-match
+               "(#1=(1) #1# #2=\"hello\" #2#)(#3=#:g[[:digit:]]+ #3#)(#1# #2# #3#)#2#$"
+               (mapconcat #'print-tests--prin1-to-string `((,x ,x ,y ,y) (,g ,g) (,x ,y ,g) ,y) ""))))
+
+    ;; This is the special case for byte-compile-output-docform
+    ;; mentioned in a comment in print_preprocess.  When
+    ;; print-continuous-numbering and print-circle and print-gensym
+    ;; are all non-nil, print all gensyms with numbers even if they
+    ;; only occur once.
+    (let ((print-continuous-numbering t)
+          (print-number-table nil))
+      (should (string-match
+               "(#1=#:g[[:digit:]]+ #2=#:g[[:digit:]]+)$"
+               (print-tests--prin1-to-string (list g g2)))))))
+
+(cl-defstruct print--test a b)
+
+(print-tests--deftest print-tests-1 ()
+  "Test print code."
+  (let ((x (make-print--test :a 1 :b 2))
+        (rec (cond
+              ((eq (symbol-function #'print-tests--prin1-to-string) 'prin1-to-string)
+               "#s(print--test 1 2)")
+              ((eq (symbol-function #'print-tests--prin1-to-string) 'cl-prin1-to-string)
+               "#s(print--test :a 1 :b 2)")
+              (t (cl-assert nil)))))
+
+    (let ((print-circle nil))
+      (should (equal (print-tests--prin1-to-string `((x . ,x) (y . ,x)))
+                     (format "((x . %s) (y . %s))" rec rec))))
+    (let ((print-circle t))
+      (should (equal (print-tests--prin1-to-string `((x . ,x) (y . ,x)))
+                     (format "((x . #1=%s) (y . #1#))" rec))))))
+
+(print-tests--deftest print-tests-2 ()
+  (let ((x (record 'foo 1 2 3)))
+    (should (equal
+             x
+             (car (read-from-string (with-output-to-string (prin1 x))))))
+    (let ((print-circle t))
+      (should (string-match
+               "\\`(#1=#s(foo 1 2 3) #1#)\\'"
+               (print-tests--prin1-to-string (list x x)))))))
+
+(cl-defstruct (print-tests-struct
+               (:constructor print-tests-con))
+  a b c d e)
+
+(print-tests--deftest print-tests-3 ()
+  "Printing observes `print-length'."
+  (let ((long-list (make-list 5 'a))
+        (long-vec (make-vector 5 'b))
+        ;; (long-struct (print-tests-con))
+        ;; (long-string (make-string 5 ?a))
+        (print-length 4))
+    (should (equal "(a a a a ...)" (print-tests--prin1-to-string long-list)))
+    (should (equal "[b b b b ...]" (print-tests--prin1-to-string long-vec)))
+    ;; This one only prints 3 nils. Should it print 4?
+    ;; (should (equal "#s(print-tests-struct nil nil nil nil ...)"
+    ;;                (print-tests--prin1-to-string long-struct)))
+    ;; This one is only supported by cl-print
+    ;; (should (equal "\"aaaa...\"" (cl-print-tests--prin1-to-string long-string)))
+    ))
+
+(print-tests--deftest print-tests-4 ()
+  "Printing observes `print-level'."
+  (let* ((deep-list '(a (b (c (d (e))))))
+         (buried-vector '(a (b (c (d [e])))))
+         (deep-struct (print-tests-con))
+         (buried-struct `(a (b (c (d ,deep-struct)))))
+         (buried-string '(a (b (c (d #("hello" 0 5 (print-test t)))))))
+         (buried-simple-string '(a (b (c (d "hello")))))
+         (print-level 4))
+    (setf (print-tests-struct-a deep-struct) deep-list)
+    (should (equal "(a (b (c (d ...))))" (print-tests--prin1-to-string deep-list)))
+    (should (equal "(a (b (c (d \"hello\"))))"
+                   (print-tests--prin1-to-string buried-simple-string)))
+    (cond
+     ((eq (symbol-function #'print-tests--prin1-to-string) #'prin1-to-string)
+      (should (equal "(a (b (c (d [e]))))" (print-tests--prin1-to-string buried-vector)))
+      (should (equal "(a (b (c (d #s(print-tests-struct ... nil nil nil nil)))))"
+                     (print-tests--prin1-to-string buried-struct)))
+      (should (equal "(a (b (c (d #(\"hello\" 0 5 ...)))))"
+                     (print-tests--prin1-to-string buried-string)))
+      (should (equal "#s(print-tests-struct (a (b (c ...))) nil nil nil nil)"
+                     (print-tests--prin1-to-string deep-struct))))
+
+     ((eq (symbol-function #'print-tests--prin1-to-string) #'cl-prin1-to-string)
+      (should (equal "(a (b (c (d ...))))" (print-tests--prin1-to-string buried-vector)))
+      (should (equal "(a (b (c (d ...))))" (print-tests--prin1-to-string buried-struct)))
+      (should (equal "(a (b (c (d ...))))" (print-tests--prin1-to-string buried-string)))
+      (should (equal "#s(print-tests-struct :a (a (b (c ...))) :b nil :c nil :d nil :e nil)"
+                     (print-tests--prin1-to-string deep-struct))))
+     (t (cl-assert nil)))))
+
+(print-tests--deftest print-tests-5 ()
+  "Printing observes `print-quoted'."
+  (let ((quoted-stuff '('a #'b `(,c ,@d))))
+    (let ((print-quoted t))
+      (should (equal "('a #'b `(,c ,@d))"
+                     (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--deftest print-tests-strings ()
+  "Can print strings and propertized strings."
+  (let* ((str1 "abcdefghij")
+         (str2 #("abcdefghij" 3 6 (bold t) 7 9 (italic t)))
+         (str3 #("abcdefghij" 0 10 (test t)))
+         (obj '(a b))
+         ;; Since the byte compiler reuses string literals,
+         ;; and the put-text-property call is destructive, use
+         ;; copy-sequence to make a new string.
+         (str4 (copy-sequence "abcdefghij")))
+    (put-text-property 0 5 'test obj str4)
+    (put-text-property 7 10 'test obj str4)
+
+    (should (equal "\"abcdefghij\"" (print-tests--prin1-to-string str1)))
+    (should (equal "#(\"abcdefghij\" 3 6 (bold t) 7 9 (italic t))"
+                   (print-tests--prin1-to-string str2)))
+    (should (equal "#(\"abcdefghij\" 0 10 (test t))"
+                   (print-tests--prin1-to-string str3)))
+    (let ((print-circle nil))
+      (should
+       (equal
+        "#(\"abcdefghij\" 0 5 (test (a b)) 7 10 (test (a b)))"
+        (print-tests--prin1-to-string str4))))
+    (let ((print-circle t))
+      (should
+       (equal
+        "#(\"abcdefghij\" 0 5 (test #1=(a b)) 7 10 (test #1#))"
+        (print-tests--prin1-to-string str4))))))
+
+(print-tests--deftest print-circle ()
+  (let ((x '(#1=(a . #1#) #1#)))
+    (let ((print-circle nil))
+      (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))))))
+
+(print-tests--deftest print-circle-2 ()
+   ;; Bug#31146.
+  (let ((x '(0 . #1=(0 . #1#))))
+    (let ((print-circle nil))
+      (should (string-match "\\`(0 0 . #[0-9])\\'"
+                            (print-tests--prin1-to-string x))))
+    (let ((print-circle t))
+      (should (equal "(0 . #1=(0 . #1#))" (print-tests--prin1-to-string x))))))
+
 
 (provide 'print-tests)
 ;;; print-tests.el ends here