Have `-Warity-mismatch' handle applicable structs.

* module/language/tree-il/analyze.scm (arity-analysis): Honor applicable
  structs.

* test-suite/tests/tree-il.test ("warnings")["arity
  mismatch"]("top-level applicable struct", "top-level applicable struct
  with wrong arguments"): New tests.

diff --git a/module/language/tree-il/analyze.scm b/module/language/tree-il/analyze.scm
index 76923fc..340f940 100644 (file)
--- a/module/language/tree-il/analyze.scm
+++ b/module/language/tree-il/analyze.scm
@@ -1194,8 +1194,15 @@ accurate information is missing from a given `tree-il' element."
                              (false-if-exception
                               (module-ref env name))))
                       proc)))
-            (if (or (lambda? proc*) (procedure? proc*))
-                (validate-arity proc* application (lambda? proc*)))))
+            (cond ((lambda? proc*)
+                   (validate-arity proc* application #t))
+                  ((struct? proc*)
+                   ;; An applicable struct.
+                   (let ((p (struct-ref proc* 0)))
+                     (and (procedure? p)
+                          (validate-arity p application #f))))
+                  ((procedure? proc*)
+                   (validate-arity proc* application #f)))))
         toplevel-calls)))
 
    (make-arity-info vlist-null vlist-null vlist-null)))

diff --git a/test-suite/tests/tree-il.test b/test-suite/tests/tree-il.test
index 28c0b26..96ae989 100644 (file)
--- a/test-suite/tests/tree-il.test
+++ b/test-suite/tests/tree-il.test
@@ -1103,6 +1103,26 @@
                                   w "wrong number of arguments to"))))
                              w)))))
 
+     (pass-if "top-level applicable struct"
+       (null? (call-with-warnings
+               (lambda ()
+                 (compile '(let ((p current-warning-port))
+                             (p (+ (p) 1))
+                             (p))
+                          #:opts %opts-w-arity
+                          #:to 'assembly)))))
+
+     (pass-if "top-level applicable struct with wrong arguments"
+       (let ((w (call-with-warnings
+                 (lambda ()
+                   (compile '(let ((p current-warning-port))
+                               (p 1 2 3))
+                            #:opts %opts-w-arity
+                            #:to 'assembly)))))
+         (and (= (length w) 1)
+              (number? (string-contains (car w)
+                                        "wrong number of arguments to")))))
+
      (pass-if "local toplevel-defines"
        (let ((w (call-with-warnings
                   (lambda ()