[Guile-commits] GNU Guile branch, master, updated. release_1-9-4-95-g99480e1

[Ludovic Courtès]

This is an automated email from the git hooks/post-receive script. It was
generated because a ref change was pushed to the repository containing
the project "GNU Guile".

http://git.savannah.gnu.org/cgit/guile.git/commit/?id=99480e111815593c6828eb6081baece0f41d8233

The branch, master has been updated
       via  99480e111815593c6828eb6081baece0f41d8233 (commit)
      from  5e5351f8f83103da4ddd508f5b68f83d4342ec43 (commit)

Those revisions listed above that are new to this repository have
not appeared on any other notification email; so we list those
revisions in full, below.

- Log -----------------------------------------------------------------
commit 99480e111815593c6828eb6081baece0f41d8233
Author: Ludovic Courtès <address@hidden>
Date:   Sun Nov 8 17:53:14 2009 +0100

    Add support for multiple arities in `arity-mismatch-analysis'.
    
    * module/language/tree-il/analyze.scm (validate-arity)[arity]: Rename
      to...
      [arities]: ... this.  Return all the arities of PROC.
      Update caller accordingly.
    
    * test-suite/tests/tree-il.test ("warnings")["arity
      mismatch"]("case-lambda", "case-lambda with wrong number of
      arguments", "case-lambda*", "case-lambda* with wrong arguments"): New
      tests.

-----------------------------------------------------------------------

Summary of changes:
 module/language/tree-il/analyze.scm |   85 ++++++++++++++++++++---------------
 test-suite/tests/tree-il.test       |   59 ++++++++++++++++++++++++
 2 files changed, 108 insertions(+), 36 deletions(-)

diff --git a/module/language/tree-il/analyze.scm 
b/module/language/tree-il/analyze.scm
index 286dc51..e06a5af 100644
--- a/module/language/tree-il/analyze.scm
+++ b/module/language/tree-il/analyze.scm
@@ -25,6 +25,7 @@
   #:use-module (system base message)
   #:use-module (system vm program)
   #:use-module (language tree-il)
+  #:use-module (system base pmatch)
   #:export (analyze-lexicals
             analyze-tree
             unused-variable-analysis
@@ -796,55 +797,67 @@
                 (loop (cdr args)
                       (cons arg result)))))))
 
-  (define (arity proc)
-    ;; Return the arity of PROC, which can be either a tree-il or a
+  (define (arities proc)
+    ;; Return the arities of PROC, which can be either a tree-il or a
     ;; procedure.
     (define (len x)
       (or (and (or (null? x) (pair? x))
                (length x))
           0))
     (cond ((program? proc)
-           (let ((a (car (last-pair (program-arities proc)))))
-             (values (program-name proc)
-                     (arity:nreq a) (arity:nopt a) (arity:rest? a)
-                     (map car (arity:kw a)) (arity:allow-other-keys? a))))
+           (values (program-name proc)
+                   (map (lambda (a)
+                          (list (arity:nreq a) (arity:nopt a) (arity:rest? a)
+                                (map car (arity:kw a))
+                                (arity:allow-other-keys? a)))
+                        (program-arities proc))))
           ((procedure? proc)
            (let ((arity (procedure-property proc 'arity)))
              (values (procedure-name proc)
-                     (car arity) (cadr arity) (caddr arity)
-                     #f #f)))
+                     (list (list (car arity) (cadr arity) (caddr arity)
+                                 #f #f)))))
           (else
-           (let loop ((name #f)
-                      (proc proc))
-             (record-case proc
-               ((<lambda-case> req opt rest kw)
-                (values name (len req) (len opt) rest
-                        (and (pair? kw) (map car (cdr kw)))
-                        (and (pair? kw) (car kw))))
-               ((<lambda> meta body)
-                (loop (assoc-ref meta 'name) body))
-               (else
-                (values #f #f #f #f #f #f)))))))
+           (let loop ((name    #f)
+                      (proc    proc)
+                      (arities '()))
+             (if (not proc)
+                 (values name (reverse arities))
+                 (record-case proc
+                   ((<lambda-case> req opt rest kw else)
+                    (loop name else
+                          (cons (list (len req) (len opt) rest
+                                      (and (pair? kw) (map car (cdr kw)))
+                                      (and (pair? kw) (car kw)))
+                                arities)))
+                   ((<lambda> meta body)
+                    (loop (assoc-ref meta 'name) body arities))
+                   (else
+                    (values #f #f))))))))
 
   (let ((args (application-args application))
         (src  (tree-il-src application)))
-    (call-with-values (lambda () (arity proc))
-      (lambda (name req opt rest kw aok?)
-        (let ((args (if (pair? kw)
-                        (filter-keyword-args kw aok? args)
-                        args)))
-          (if (and req opt)
-              (let ((count (length args)))
-                (if (or (< count req)
-                        (and (not rest)
-                             (> count (+ req opt))))
-                    (warning 'arity-mismatch src
-                             (or name
-                                 (with-output-to-string
-                                   (lambda ()
-                                     (write proc))))
-                             lexical?)))
-              #t)))))
+    (call-with-values (lambda () (arities proc))
+      (lambda (name arities)
+        (define matches?
+          (find (lambda (arity)
+                  (pmatch arity
+                    ((,req ,opt ,rest? ,kw ,aok?)
+                     (let ((args (if (pair? kw)
+                                     (filter-keyword-args kw aok? args)
+                                     args)))
+                       (if (and req opt)
+                           (let ((count (length args)))
+                             (and (>= count req)
+                                  (or rest?
+                                      (<= count (+ req opt)))))
+                           #t)))
+                    (else #t)))
+                arities))
+
+        (if (not matches?)
+            (warning 'arity-mismatch src
+                     (or name (with-output-to-string (lambda () (write proc))))
+                     lexical?)))))
   #t)
 
 (define arity-analysis
diff --git a/test-suite/tests/tree-il.test b/test-suite/tests/tree-il.test
index 01ce39e..874552f 100644
--- a/test-suite/tests/tree-il.test
+++ b/test-suite/tests/tree-il.test
@@ -788,6 +788,65 @@
               (number? (string-contains (car w)
                                         "wrong number of arguments to")))))
 
+     (pass-if "case-lambda"
+       (null? (call-with-warnings
+                (lambda ()
+                  (compile '(let ((f (case-lambda
+                                       ((x)     1)
+                                       ((x y)   2)
+                                       ((x y z) 3))))
+                              (list (f 1)
+                                    (f 1 2)
+                                    (f 1 2 3)))
+                           #:opts %opts-w-arity
+                           #:to 'assembly)))))
+
+     (pass-if "case-lambda with wrong number of arguments"
+       (let ((w (call-with-warnings
+                  (lambda ()
+                    (compile '(let ((f (case-lambda
+                                         ((x)     1)
+                                         ((x y)   2))))
+                                (f 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 "case-lambda*"
+       (null? (call-with-warnings
+                (lambda ()
+                  (compile '(let ((f (case-lambda*
+                                       ((x #:optional y) 1)
+                                       ((x #:key y)      2)
+                                       ((x y #:key z)    3))))
+                              (list (f 1)
+                                    (f 1 2)
+                                    (f #:y 2)
+                                    (f 1 2 #:z 3)))
+                           #:opts %opts-w-arity
+                           #:to 'assembly)))))
+
+     (pass-if "case-lambda* with wrong arguments"
+       (let ((w (call-with-warnings
+                  (lambda ()
+                    (compile '(let ((f (case-lambda*
+                                         ((x #:optional y) 1)
+                                         ((x #:key y)      2)
+                                         ((x y #:key z)    3))))
+                                (list (f)
+                                      (f 1 #:z 3)))
+                             #:opts %opts-w-arity
+                             #:to 'assembly)))))
+         (and (= (length w) 2)
+              (null? (filter (lambda (w)
+                               (not
+                                (number?
+                                 (string-contains
+                                  w "wrong number of arguments to"))))
+                             w)))))
+
      (pass-if "local toplevel-defines"
        (let ((w (call-with-warnings
                   (lambda ()


hooks/post-receive
-- 
GNU Guile