542 lines
22 KiB
EmacsLisp
542 lines
22 KiB
EmacsLisp
;;; print-tests.el --- tests for src/print.c -*- lexical-binding: t; -*-
|
||
|
||
;; Copyright (C) 2014-2024 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 (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 (take lead numbers))
|
||
(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)))))))))))
|
||
|
||
(ert-deftest test-print-unreadable-function-buffer ()
|
||
(let* ((buffer nil)
|
||
(callback-buffer nil)
|
||
(str (with-temp-buffer
|
||
(setq buffer (current-buffer))
|
||
(let ((print-unreadable-function
|
||
(lambda (_object _escape)
|
||
(setq callback-buffer (current-buffer))
|
||
"tata")))
|
||
(prin1-to-string (make-marker))))))
|
||
(should (eq callback-buffer buffer))
|
||
(should (equal str "tata"))))
|
||
|
||
(provide 'print-tests)
|
||
;;; print-tests.el ends here
|