mirrors/emacs
1
Fork 0
mirror of git://git.sv.gnu.org/emacs.git synced 2026-03-13 10:20:59 -07:00
Code Issues Projects Releases Wiki Activity
emacs/test/src/print-tests.el
Mattias Engdegård 5a1a67a256 Less wrong printed circular list tail index (bug#55395) 
When printing a circular list and `print-circle` is nil, use a
somewhat more meaningful ". #N" tail index.  The previous method for
calculating that index was based on Floyd circularity detection being
used so it had been broken ever since the change to Brent's algorithm.

The new index is correct with respect to the start of the list itself
which is what it used to be before being completely broken.
It does not take into account the nesting depth of the list context.

* src/print.c (struct print_stack_entry, print_object):
Keep track of the tortoise index (which is cheap) instead of trying
to derive it from the printed element index.
* test/src/print-tests.el (print-test-rho, print-circular):
New test.
2022-05-23 16:50:00 +02:00

534 lines
22 KiB
EmacsLisp
Raw Blame History

This file contains ambiguous Unicode characters

This file contains Unicode characters that might be confused with other characters. If you think that this is intentional, you can safely ignore this warning. Use the Escape button to reveal them.

;;; print-tests.el --- tests for src/print.c -*- lexical-binding: t; -*-
;; Copyright (C) 2014-2022 Free Software Foundation, Inc.
;; This file is part of GNU Emacs.
;; GNU Emacs is free software: you can redistribute it and/or modify
;; it under the terms of the GNU General Public License as published by
;; the Free Software Foundation, either version 3 of the License, or
;; (at your option) any later version.
;; GNU Emacs is distributed in the hope that it will be useful,
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
;; GNU General Public License for more details.
;; You should have received a copy of the GNU General Public License
;; along with GNU Emacs. If not, see <https://www.gnu.org/licenses/>.
;;; Code:
(require 'ert)
;; 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))
(print-tests--prin1-to-string "\u00A2\ff"))
"\"\\x00a2\\ff\"")))
(defun print-tests--prints-with-charset-p (ch odd-charset)
"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"
(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)))))))
(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))))
(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))))
(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))
(should (print-tests--prints-with-charset-p ?\xf6 nil))
(should (print-tests--prints-with-charset-p ?a nil))))
(ert-deftest terpri ()
(should (string= (with-output-to-string
(princ 'abc)
(should (terpri nil t)))
"abc\n"))
(should (string= (with-output-to-string
(should-not (terpri nil t))
(princ 'xyz))
"xyz"))
(message nil)
(if noninteractive
(progn (should (terpri nil t))
(should-not (terpri nil t))
(princ 'abc)
(should (terpri nil t))
(should-not (terpri nil t)))
(should (string= (progn (should-not (terpri nil t))
(princ 'abc)
(should (terpri nil t))
(current-message))
"abc\n")))
(let ((standard-output
(with-current-buffer (get-buffer-create "*terpri-test*")
(insert "--------")
(point-max-marker))))
(should (terpri nil t))
(should-not (terpri nil t))
(should (string= (with-current-buffer (marker-buffer standard-output)
(buffer-string))
"--------\n"))))
(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
'\; '\? '\[ '\\ '\] '\` '_ 'a 'e 'e0 'x
'{ '| '} '~ : '\’ '\’bar
(intern "\t") (intern "\n") (intern " ")
(intern "\N{NO-BREAK SPACE}")
(intern "\N{ZERO WIDTH SPACE}")
(intern "\0"))))
(dolist (sym syms)
(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 (print-tests--prin1-to-string sym2)) sym2)))))))
(print-tests--deftest print-bignum ()
(let* ((str "999999999999999999999999999999999")
(val (read str)))
(should (> val most-positive-fixnum))
(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))))))
(print-tests--deftest error-message-string-circular ()
(let ((err (list 'error)))
(setcdr err err)
(should-error (error-message-string err) :type 'circular-list)))
(print-tests--deftest print-hash-table-test ()
(should
(string-match
"data (2 3)"
(let ((h (make-hash-table)))
(puthash 1 2 h)
(puthash 2 3 h)
(remhash 1 h)
(format "%S" h))))
(should
(string-match
"data ()"
(let ((h (make-hash-table)))
(let ((print-length 0))
(format "%S" h)))))
(should
(string-match
"data (99 99)"
(let ((h (make-hash-table)))
(dotimes (i 100)
(puthash i i h))
(dotimes (i 99)
(remhash i h))
(let ((print-length 1))
(format "%S" h))))))
(print-tests--deftest print-integers-as-characters ()
;; Bug#44155.
(let* ((print-integers-as-characters t)
(chars '(?? ?\; ?\( ?\) ?\{ ?\} ?\[ ?\] ?\" ?\' ?\\ ?f ?~ ?Á 32
?\n ?\r ?\t ?\b ?\f ?\a ?\v ?\e ?\d))
(nums '(-1 -65 0 1 31 #x80 #x9f #x110000 #x3fff80 #x3fffff))
(nonprints '(#xd800 #xdfff #x030a #xffff #x2002 #x200c))
(printed-chars (print-tests--prin1-to-string chars))
(printed-nums (print-tests--prin1-to-string nums))
(printed-nonprints (print-tests--prin1-to-string nonprints)))
(should (equal (read printed-chars) chars))
(should (equal
printed-chars
(concat
"(?? ?\\; ?\\( ?\\) ?\\{ ?\\} ?\\[ ?\\] ?\\\" ?\\' ?\\\\"
" ?f ?~ ?Á ?\\s ?\\n ?\\r ?\\t ?\\b ?\\f 7 11 27 127)")))
(should (equal (read printed-nums) nums))
(should (equal printed-nums
"(-1 -65 0 1 31 128 159 1114112 4194176 4194303)"))
(should (equal (read printed-nonprints) nonprints))
(should (equal printed-nonprints
"(55296 57343 778 65535 8194 8204)"))))
(ert-deftest test-unreadable ()
(should (equal (prin1-to-string (make-marker)) "#<marker in no buffer>"))
(let ((print-unreadable-function
(lambda (_object _escape)
"hello")))
(should (equal (prin1-to-string (make-marker)) "hello")))
(let ((print-unreadable-function
(lambda (_object _escape)
t)))
(should (equal (prin1-to-string (make-marker)) ""))))
(ert-deftest test-dots ()
(should (equal (prin1-to-string 'foo.bar) "foo.bar"))
(should (equal (prin1-to-string '.foo) "\\.foo"))
(should (equal (prin1-to-string '.foo.) "\\.foo."))
(should (equal (prin1-to-string 'bar?bar) "bar?bar"))
(should (equal (prin1-to-string '\?bar) "\\?bar"))
(should (equal (prin1-to-string '\?bar?) "\\?bar?")))
(ert-deftest test-prin1-overrides ()
(with-temp-buffer
(let ((print-length 10))
(prin1 (make-list 20 t) (current-buffer) t)
(should (= print-length 10)))
(goto-char (point-min))
(should (= (length (read (current-buffer))) 20)))
(with-temp-buffer
(let ((print-length 10))
(prin1 (make-list 20 t) (current-buffer) '((length . 5)))
(should (= print-length 10)))
(goto-char (point-min))
(should (= (length (read (current-buffer))) 6)))
(with-temp-buffer
(let ((print-length 10))
(prin1 (make-list 20 t) (current-buffer) '(t (length . 5)))
(should (= print-length 10)))
(goto-char (point-min))
(should (= (length (read (current-buffer))) 6))))
(ert-deftest test-prin1-to-string-overrides ()
(let ((print-length 10))
(should
(= (length (car (read-from-string
(prin1-to-string (make-list 20 t) nil t))))
20)))
(let ((print-length 10))
(should
(= (length (car (read-from-string
(prin1-to-string (make-list 20 t) nil
'((length . 5))))))
6)))
(should-error (prin1-to-string 'foo nil 'a))
(should-error (prin1-to-string 'foo nil '(a)))
(should-error (prin1-to-string 'foo nil '(t . b)))
(should-error (prin1-to-string 'foo nil '(t b)))
(should-error (prin1-to-string 'foo nil '((a . b) b)))
(should-error (prin1-to-string 'foo nil '((length . 10) . b))))
(ert-deftest print-deeply-nested ()
;; Check that we can print a deeply nested data structure correctly.
(let ((print-circle t))
(let ((levels 10000)
(x 'a)
(prefix nil)
(suffix nil))
(dotimes (_ levels)
(setq x (list (vector (record 'r x))))
(push "([#s(r " prefix)
(push ")])" suffix))
(let ((expected (concat (apply #'concat prefix)
"a"
(apply #'concat suffix))))
(should (equal (prin1-to-string x) expected))))))
(defun print-test-rho (lead loop)
"A circular iota list with LEAD elements followed by LOOP in circle."
(let ((l (number-sequence 1 (+ lead loop))))
(setcdr (nthcdr (+ lead loop -1) l) (nthcdr lead l))
l))
(ert-deftest print-circular ()
;; Check printing of rho-shaped circular lists such as (1 2 3 4 5 4 5 4 . #6)
;; when `print-circle' is nil. The exact output may differ since the number
;; of elements printed of the looping part can vary depending on when the
;; circularity was detected.
(dotimes (lead 7)
(ert-info ((prin1-to-string lead) :prefix "lead: ")
(dolist (loop (number-sequence 1 7))
(ert-info ((prin1-to-string loop) :prefix "loop: ")
(let* ((rho (print-test-rho lead loop))
(print-circle nil)
(str (prin1-to-string rho)))
(should (string-match (rx "("
(group (+ (+ digit) " "))
". #" (group (+ digit)) ")")
str))
(let* ((g1 (match-string 1 str))
(g2 (match-string 2 str))
(numbers (mapcar #'string-to-number (split-string g1)))
(loopback-index (string-to-number g2)))
;; Split the numbers in the lead and loop part.
(should (< lead (length numbers)))
(should (<= lead loopback-index))
(should (< loopback-index (length numbers)))
(let ((lead-part (butlast numbers (- (length numbers) lead)))
(loop-part (nthcdr lead numbers)))
;; The lead part must match exactly.
(should (equal lead-part (number-sequence 1 lead)))
;; The loop part is at least LOOP long: make sure it matches.
(should (>= (length loop-part) loop))
(let ((expected-loop-part
(mapcar (lambda (x) (+ lead 1 (% x loop)))
(number-sequence 0 (1- (length loop-part))))))
(should (equal loop-part expected-loop-part))
;; The loopback index must match the length of the
;; loop part.
(should (equal (% (- (length numbers) loopback-index) loop)
0)))))))))))
(provide 'print-tests)
;;; print-tests.el ends here
Reference in a new issue View git blame Copy permalink