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.

1 files changed, 247 insertions, 12 deletions

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