From: Ludovic Courtès <ludo@gnu.org>
Date: Sat, 12 May 2012 13:58:23 +0000 (+0200)
Subject: Have `-Warity-mismatch' handle applicable structs.
X-Git-Url: http://git.hcoop.net/bpt/guile.git/commitdiff_plain/2c5f0bdb0e4d59c8a49925f75dd4793c19ebe08a

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 76923fc82..340f9401c 100644
--- 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 28c0b26be..96ae98967 100644
--- 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 ()