test: make subr mocks variadic for native-comp, add arity meta-test

Re-enabling native-comp surfaced a suite-wide fragility. When a test redefines a C primitive (or a native-compiled function), native-comp routes native callers through a trampoline that calls the mock with the primitive's maximum arity. A fixed-arity mock narrower than the primitive then throws wrong-number-of-arguments, intermittently, as the eln-cache fills.

I swept every arity-narrow subr mock to append &rest _ (188 sites, preserving any named args the body uses), and added tests/test-meta-subr-mock-arity.el, which fails make test on any subr mock too narrow for the primitive's arity. The rule isn't "never mock a subr". The suite mocks message and completing-read freely. It's "a subr mock must accept the primitive's arity."

Background, the three failure modes, and the research are in docs/native-comp-subr-mocking.org.

1 files changed, 113 insertions, 0 deletions

diff --git a/tests/test-meta-subr-mock-arity.el b/tests/test-meta-subr-mock-arity.el
new file mode 100644
index 00000000..8ee2cb5e
--- /dev/null
+++ b/tests/test-meta-subr-mock-arity.el
@@ -0,0 +1,113 @@
+;;; test-meta-subr-mock-arity.el --- Guard against arity-narrow subr mocks -*- lexical-binding: t; -*-
+
+;;; Commentary:
+;; A meta-test: it tests the other tests.  Native compilation routes a
+;; redefined C primitive (subr) through a trampoline that calls the
+;; replacement with the primitive's FULL arity, filling optionals with nil.
+;; So a fixed-arity mock that is narrower than the primitive throws
+;; `wrong-number-of-arguments' the moment native-comp has compiled that
+;; trampoline -- a failure that appears intermittently as the eln-cache fills.
+;;
+;; The rule this enforces is NOT "never mock a subr" (the suite mocks subrs
+;; like `message' and `completing-read' hundreds of times, all fine).  It is:
+;; a mock of a C primitive must be able to accept the primitive's maximum
+;; arity -- in practice, use (lambda (&rest _) ...).  This test scans every
+;; file under tests/ for `cl-letf' / `setf' / `fset' redefinitions of a
+;; `symbol-function', and fails listing any whose replacement is too narrow.
+;;
+;; It is deterministic: a pure static read of the test sources plus
+;; `func-arity', with no dependence on whether native-comp happens to have
+;; built the trampoline yet.
+
+;;; Code:
+
+(require 'ert)
+(require 'cl-lib)
+(require 'seq)
+
+(defconst test-meta-subr--test-dir
+  (expand-file-name "tests" (or (getenv "EMACS_CONFIG_ROOT") default-directory))
+  "Directory whose .el files are scanned for subr mocks.")
+
+(defun test-meta-subr--replacement-arglist (repl)
+  "Return the formal arglist of REPL, or the symbol `unknown'.
+Handles (lambda ARGS ...) and (function (lambda ARGS ...)); returns `variadic'
+for forms known to accept any arity (`ignore', `always'), and `unknown' for
+anything whose arity can't be read statically (a bare variable, a call)."
+  (pcase repl
+    (`(lambda ,args . ,_) args)
+    (`(function (lambda ,args . ,_)) args)
+    (`(quote ,(or 'ignore 'always)) 'variadic)
+    (`(function ,(or 'ignore 'always)) 'variadic)
+    (_ 'unknown)))
+
+(defun test-meta-subr--accepts-p (arglist subr-max)
+  "Non-nil if a lambda with ARGLIST can be called with SUBR-MAX positional args.
+ARGLIST may also be `variadic' or `unknown' (both treated as acceptable)."
+  (cond
+   ((memq arglist '(variadic unknown)) t)
+   ((memq '&rest arglist) t)
+   ((eq subr-max 'many) nil)            ; only &rest accepts unbounded arity
+   ((integerp subr-max)
+    (>= (length (seq-remove (lambda (s) (memq s '(&optional &rest &key)))
+                            arglist))
+        subr-max))
+   (t t)))
+
+(defun test-meta-subr--quoted-symbol (form)
+  "If FORM is 'SYM or #'SYM, return SYM, else nil."
+  (pcase form
+    (`(quote ,(and s (guard (symbolp s)))) s)
+    (`(function ,(and s (guard (symbolp s)))) s)))
+
+(defun test-meta-subr--collect (form acc)
+  "Walk FORM, pushing (SYM . REPLACEMENT) for each symbol-function redefinition.
+Covers `cl-letf'/`setf' binding shape ((symbol-function 'SYM) REPL) and
+\(fset 'SYM REPL)."
+  (when (consp form)
+    ;; (fset 'SYM REPL)
+    (when (eq (car-safe form) 'fset)
+      (let ((s (test-meta-subr--quoted-symbol (nth 1 form))))
+        (when s (push (cons s (nth 2 form)) acc))))
+    ;; binding element ((symbol-function 'SYM) REPL) -- cl-letf, cl-letf*, setf
+    (when (and (consp (car-safe form))
+               (eq (car-safe (car form)) 'symbol-function))
+      (let ((s (test-meta-subr--quoted-symbol (nth 1 (car form)))))
+        (when s (push (cons s (nth 1 form)) acc))))
+    (dolist (sub form) (setq acc (test-meta-subr--collect sub acc))))
+  acc)
+
+(defun test-meta-subr--violations ()
+  "Return a list of human-readable violation strings across the test files."
+  (let ((violations '()))
+    (dolist (file (directory-files-recursively test-meta-subr--test-dir "\\.el\\'"))
+      ;; Don't scan this meta-test itself (its examples would self-trip).
+      (unless (string-suffix-p "test-meta-subr-mock-arity.el" file)
+        (let ((mocks '()))
+          (with-temp-buffer
+            (insert-file-contents file)
+            (goto-char (point-min))
+            (condition-case nil
+                (while t (setq mocks (test-meta-subr--collect (read (current-buffer)) mocks)))
+              (error nil)))
+          (pcase-dolist (`(,sym . ,repl) (nreverse mocks))
+            (when (and (fboundp sym)
+                       (condition-case nil (subrp (symbol-function sym)) (error nil)))
+              (let ((subr-max (cdr (func-arity sym)))
+                    (arglist (test-meta-subr--replacement-arglist repl)))
+                (unless (test-meta-subr--accepts-p arglist subr-max)
+                  (push (format "%s: mock of subr `%s' (arity max %s) takes %S -- use (&rest _)"
+                                (file-name-nondirectory file) sym subr-max arglist)
+                        violations))))))))
+    (nreverse violations)))
+
+(ert-deftest test-meta-no-arity-narrow-subr-mocks ()
+  "No test mocks a C primitive with a lambda too narrow for its arity.
+Such a mock breaks under native-comp's subr trampoline (it calls the mock with
+the primitive's full arity).  Fix by making the mock variadic: (lambda (&rest _)
+...).  See this file's commentary."
+  (let ((violations (test-meta-subr--violations)))
+    (should (null violations))))
+
+(provide 'test-meta-subr-mock-arity)
+;;; test-meta-subr-mock-arity.el ends here