Merge remote-tracking branch 'savannah/master' into feature/tree-sitter

8 files changed, 247 insertions, 3 deletions

diff --git a/test/src/buffer-tests.el b/test/src/buffer-tests.el
index c1e5d0ebed3..13d48b31a4f 100644
--- a/test/src/buffer-tests.el
+++ b/test/src/buffer-tests.el
@@ -1482,4 +1482,53 @@ with parameters from the *Messages* buffer modification."
           (when auto-save
             (ignore-errors (delete-file auto-save))))))))
 
+(ert-deftest test-buffer-modifications ()
+  (ert-with-temp-file file
+    (with-current-buffer (find-file file)
+      (auto-save-mode 1)
+      (should-not (buffer-modified-p))
+      (insert "foo")
+      (should (buffer-modified-p))
+      (should-not (eq (buffer-modified-p) 'autosaved))
+      (do-auto-save nil t)
+      (should (eq (buffer-modified-p) 'autosaved))
+      (with-silent-modifications
+        (put-text-property 1 3 'face 'bold))
+      (should (eq (buffer-modified-p) 'autosaved))
+      (save-buffer)
+      (should-not (buffer-modified-p))
+      (with-silent-modifications
+        (put-text-property 1 3 'face 'italic))
+      (should-not (buffer-modified-p)))))
+
+(ert-deftest test-restore-buffer-modified-p ()
+  (ert-with-temp-file file
+    (with-current-buffer (find-file file)
+      (auto-save-mode 1)
+      (should-not (buffer-modified-p))
+      (insert "foo")
+      (should (buffer-modified-p))
+      (restore-buffer-modified-p nil)
+      (should-not (buffer-modified-p))
+      (insert "bar")
+      (do-auto-save nil t)
+      (should (eq (buffer-modified-p) 'autosaved))
+      (insert "zot")
+      (restore-buffer-modified-p 'autosaved)
+      (should (eq (buffer-modified-p) 'autosaved))
+
+      ;; Clean up.
+      (when (file-exists-p buffer-auto-save-file-name)
+        (delete-file buffer-auto-save-file-name))))
+
+  (ert-with-temp-file file
+    (with-current-buffer (find-file file)
+      (auto-save-mode 1)
+      (should-not (buffer-modified-p))
+      (insert "foo")
+      (should (buffer-modified-p))
+      (should-not (eq (buffer-modified-p) 'autosaved))
+      (restore-buffer-modified-p 'autosaved)
+      (should (eq (buffer-modified-p) 'autosaved)))))
+
 ;;; buffer-tests.el ends here
diff --git a/test/src/comp-tests.el b/test/src/comp-tests.el
index 212d9e999f2..e7b534d00ec 100644
--- a/test/src/comp-tests.el
+++ b/test/src/comp-tests.el
@@ -51,7 +51,14 @@
            (doc-string 3))
   `(ert-deftest ,(intern (concat "comp-tests-" (symbol-name name))) ,args
      :tags '(:nativecomp)
-     ,@docstring-and-body))
+     ,@(and (stringp (car docstring-and-body))
+            (list (pop docstring-and-body)))
+     ;; Some of the tests leave spill files behind -- so create a
+     ;; sub-dir where native-comp can do its work, and then delete it
+     ;; at the end.
+     (ert-with-temp-directory dir
+       (let ((temporary-file-directory dir))
+         ,@docstring-and-body))))
 
 
 
diff --git a/test/src/eval-tests.el b/test/src/eval-tests.el
index e4230c10efd..1b2ad99360b 100644
--- a/test/src/eval-tests.el
+++ b/test/src/eval-tests.el
@@ -240,4 +240,31 @@ expressions works for identifiers starting with period."
       (should (equal (string-trim (buffer-string))
                      "Error: (error \"Boo\")")))))
 
+(ert-deftest eval-tests/funcall-with-delayed-message ()
+  ;; Check that `funcall-with-delayed-message' displays its message before
+  ;; its function terminates iff the timeout is short enough.
+
+  ;; This also serves as regression test for bug#55628 where a short
+  ;; timeout was rounded up to the next whole second.
+  (dolist (params '((0.8 0.4)
+                    (0.1 0.8)))
+    (let ((timeout (nth 0 params))
+          (work-time (nth 1 params)))
+      (ert-info ((prin1-to-string params) :prefix "params: ")
+        (with-current-buffer "*Messages*"
+          (let ((inhibit-read-only t))
+            (erase-buffer))
+          (let ((stop (+ (float-time) work-time)))
+            (funcall-with-delayed-message
+             timeout "timed out"
+             (lambda ()
+               (while (< (float-time) stop))
+               (message "finished"))))
+          (let ((expected-messages
+                 (if (< timeout work-time)
+                     "timed out\nfinished"
+                   "finished")))
+            (should (equal (string-trim (buffer-string))
+                           expected-messages))))))))
+
 ;;; eval-tests.el ends here
diff --git a/test/src/fileio-tests.el b/test/src/fileio-tests.el
index 511490c5745..c137ce06f1a 100644
--- a/test/src/fileio-tests.el
+++ b/test/src/fileio-tests.el
@@ -138,7 +138,7 @@ Also check that an encoding error can appear in a symlink."
     (should (and (file-name-absolute-p name)
                  (not (eq (aref name 0) ?~))))))
 
-(ert-deftest fileio-test--expand-file-name-null-bytes ()
+(ert-deftest fileio-tests--expand-file-name-null-bytes ()
   "Test that `expand-file-name' checks for null bytes in filenames."
   (should-error (expand-file-name (concat "file" (char-to-string ?\0) ".txt"))
                 :type 'wrong-type-argument)
@@ -193,4 +193,12 @@ Also check that an encoding error can appear in a symlink."
   (should (equal (file-name-concat "" "bar") "bar"))
   (should (equal (file-name-concat "" "") "")))
 
+(ert-deftest fileio-tests--non-regular-insert ()
+  (skip-unless (file-exists-p "/dev/urandom"))
+  (with-temp-buffer
+    (set-buffer-multibyte nil)
+    (should-error (insert-file-contents "/dev/urandom" nil 5 10))
+    (insert-file-contents "/dev/urandom" nil nil 10)
+    (should (= (buffer-size) 10))))
+
 ;;; fileio-tests.el ends here
diff --git a/test/src/image-tests.el b/test/src/image-tests.el
index 3885981e0b2..f710aadea74 100644
--- a/test/src/image-tests.el
+++ b/test/src/image-tests.el
@@ -53,6 +53,8 @@
 
 ;;;; image-test-size
 
+(declare-function image-size "image.c" (spec &optional pixels frame))
+
 (ert-deftest image-tests-image-size/gif ()
   (image-skip-unless 'gif)
   (pcase (image-size (create-image (cdr (assq 'gif image-tests--images))))
@@ -126,6 +128,8 @@
 
 ;;;; image-mask-p
 
+(declare-function image-mask-p "image.c" (spec &optional frame))
+
 (ert-deftest image-tests-image-mask-p/gif ()
   (image-skip-unless 'gif)
   (should-not (image-mask-p (create-image
@@ -176,6 +180,8 @@
 
 ;;;; image-metadata
 
+(declare-function image-metadata "image.c" (spec &optional frame))
+
 ;; TODO: These tests could be expanded with files that actually
 ;;       contain metadata.
 
@@ -238,6 +244,7 @@
 
 (ert-deftest image-tests-init-image-library ()
   (skip-unless (fboundp 'init-image-library))
+  (declare-function init-image-library "image.c" (type))
   (should (init-image-library 'pbm)) ; built-in
   (should-not (init-image-library 'invalid-image-type)))
 
diff --git a/test/src/lread-tests.el b/test/src/lread-tests.el
index 9ec54c719c8..f190f14781e 100644
--- a/test/src/lread-tests.el
+++ b/test/src/lread-tests.el
@@ -281,4 +281,45 @@ literals (Bug#20852)."
       (should (equal (lread-test-read-and-print str) str))))
   (should-error (read-from-string "#1=#1#") :type 'invalid-read-syntax))
 
+(ert-deftest lread-deeply-nested ()
+  ;; Check that we can read a deeply nested data structure correctly.
+  (let ((levels 10000)
+        (prefix nil)
+        (suffix nil))
+    (dotimes (_ levels)
+      (push "([#s(r " prefix)
+      (push ")])" suffix))
+    (let ((str (concat (apply #'concat prefix)
+                       "a"
+                       (apply #'concat suffix))))
+      (let* ((read-circle t)
+             (result (read-from-string str)))
+        (should (equal (cdr result) (length str)))
+        ;; Check the result.  (We can't build a reference value and compare
+        ;; using `equal' because that function is currently depth-limited.)
+        (named-let check ((x (car result)) (level 0))
+          (if (equal level levels)
+              (should (equal x 'a))
+            (should (and (consp x) (null (cdr x))))
+            (let ((x2 (car x)))
+              (should (and (vectorp x2) (equal (length x2) 1)))
+              (let ((x3 (aref x2 0)))
+                (should (and (recordp x3) (equal (length x3) 2)
+                             (equal (aref x3 0) 'r)))
+                (check (aref x3 1) (1+ level))))))))))
+
+(ert-deftest lread-misc ()
+  ;; Regression tests for issues found and fixed in bug#55676:
+  ;; Non-breaking space after a dot makes it a dot token.
+  (should (equal (read-from-string "(a .\u00A0b)")
+                 '((a . b) . 7)))
+  ;; #_ without symbol following is the interned empty symbol.
+  (should (equal (read-from-string "#_")
+                 '(## . 2))))
+
+(ert-deftest lread-escaped-lf ()
+  ;; ?\LF should signal an error; \LF is ignored inside string literals.
+  (should-error (read-from-string "?\\\n x"))
+  (should (equal (read-from-string "\"a\\\nb\"") '("ab" . 6))))
+
 ;;; lread-tests.el ends here
diff --git a/test/src/print-tests.el b/test/src/print-tests.el
index 0bae1959d1b..6ff7e997837 100644
--- a/test/src/print-tests.el
+++ b/test/src/print-tests.el
@@ -425,5 +425,110 @@ otherwise, use a different charset."
   (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
diff --git a/test/src/process-tests.el b/test/src/process-tests.el
index f5908d3cda5..824c6da1191 100644
--- a/test/src/process-tests.el
+++ b/test/src/process-tests.el
@@ -931,7 +931,7 @@ Return nil if FILENAME doesn't exist."
                         (< (float-time) (+ t0 limit)))
               (sit-for 0.1)))
           (should status)
-          (should-not (assq :error status))
+          (should-not (plist-get status ':error))
           (should buf)
           (should (> (buffer-size buf) 0))
           )