From ae03cf1f59b78bbf23e3a3b4eefd3c8a3ea8301d Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Ludovic=20Court=C3=A8s?= Date: Sat, 7 Nov 2009 18:32:26 +0100 Subject: [PATCH] Add `arity-mismatch' warning type. * module/language/tree-il/analyze.scm (): New record type. (validate-arity, arity-analysis): New variables. * module/language/tree-il/compile-glil.scm (%warning-passes): Add `arity-mismatch'. * module/system/base/message.scm (%warning-types): Likewise. * test-suite/tests/tree-il.test (read-and-compile): Remove, as it's now public. (%opts-w-arity): New. ("warnings")["arity mismatch"]: New test prefix. --- module/language/tree-il/analyze.scm | 218 ++++++++++++++++++++++- module/language/tree-il/compile-glil.scm | 3 +- module/system/base/message.scm | 13 +- test-suite/tests/tree-il.test | 130 +++++++++++++- 4 files changed, 354 insertions(+), 10 deletions(-) diff --git a/module/language/tree-il/analyze.scm b/module/language/tree-il/analyze.scm index ac132e396..1478b8d41 100644 --- a/module/language/tree-il/analyze.scm +++ b/module/language/tree-il/analyze.scm @@ -27,7 +27,8 @@ #:export (analyze-lexicals analyze-tree unused-variable-analysis - unbound-variable-analysis)) + unbound-variable-analysis + arity-analysis)) ;; Allocation is the process of assigning storage locations for lexical ;; variables. A lexical variable has a distinct "address", or storage @@ -539,8 +540,7 @@ (locs binding-info-locs)) ;; (LOCATION ...) (define unused-variable-analysis - ;; Report about unused variables in TREE. - + ;; Report unused variables in the given tree. (make-tree-analysis (lambda (x info env) ;; X is a leaf: extend INFO's refs accordingly. @@ -679,7 +679,7 @@ (else #f))) (define unbound-variable-analysis - ;; Return possibly unbound variables in TREE. + ;; Report possibly unbound variables in the given tree. (make-tree-analysis (lambda (x info env) ;; X is a leaf: extend INFO's refs accordingly. @@ -755,3 +755,213 @@ (reverse (toplevel-info-refs toplevel)))) (make-toplevel-info '() '() '()))) + + +;;; +;;; Arity analysis. +;;; + +;; records contains information about lexical definitions of +;; procedures currently in scope, top-level procedure definitions that have +;; been encountered, and calls to top-level procedures that have been +;; encountered. +(define-record-type + (make-arity-info toplevel-calls lexical-lambdas toplevel-lambdas) + arity-info? + (toplevel-calls toplevel-procedure-calls) ;; ((NAME . APPLICATION) ...) + (lexical-lambdas lexical-lambdas) ;; ((GENSYM . DEFINITION) ...) + (toplevel-lambdas toplevel-lambdas)) ;; ((NAME . DEFINITION) ...) + +(define (validate-arity proc application lexical?) + ;; Validate the argument count of APPLICATION, a tree-il application of + ;; PROC, emitting a warning in case of argument count mismatch. + + (define (arity proc) + ;; Return the arity 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 ;; FIXME: Handle programs to get accurate arity info? + ;; ((program? proc) + ;; (let ((a (program-arities proc))) + ;; (values (program-name proc) + ;; (arity:nreq a) (arity:nopt a) (arity:rest? a) + ;; (arity:kw a)))) + ((procedure? proc) + (let ((arity (procedure-property proc 'arity))) + (values (procedure-name proc) + (car arity) (cadr arity) (caddr arity) 0))) + (else + (let loop ((name #f) + (proc proc)) + (record-case proc + (( req opt rest kw) + (values name (len req) (len opt) rest (len kw))) + (( meta body) + (loop (assoc-ref meta 'name) body)) + (else + (values #f #f #f #f #f))))))) + + (let ((args (application-args application)) + (src (tree-il-src application))) + (call-with-values (lambda () (arity proc)) + (lambda (name req opt rest kw) + ;; FIXME: handle keyword arguments + (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)))) + (and lexical? (= 0 kw))))) + #t)))) + #t) + +(define arity-analysis + ;; Report arity mismatches in the given tree. + (make-tree-analysis + (lambda (x info env) + ;; X is a leaf. + info) + (lambda (x info env) + ;; Down into X. + (define (extend lexical-name val info) + ;; If VAL is a lambda, add NAME to the lexical-lambdas of INFO. + (let ((toplevel-calls (toplevel-procedure-calls info)) + (lexical-lambdas (lexical-lambdas info)) + (toplevel-lambdas (toplevel-lambdas info))) + (record-case val + (( body) + (make-arity-info toplevel-calls + (alist-cons lexical-name val + lexical-lambdas) + toplevel-lambdas)) + (( gensym) + ;; lexical alias + (let ((val* (assq gensym lexical-lambdas))) + (if (pair? val*) + (extend lexical-name (cdr val*) info) + info))) + (( name) + ;; top-level alias + (make-arity-info toplevel-calls + (alist-cons lexical-name val + lexical-lambdas) + toplevel-lambdas)) + (else info)))) + + (let ((toplevel-calls (toplevel-procedure-calls info)) + (lexical-lambdas (lexical-lambdas info)) + (toplevel-lambdas (toplevel-lambdas info))) + + (record-case x + (( name exp) + (record-case exp + (( body) + (make-arity-info toplevel-calls + lexical-lambdas + (alist-cons name exp toplevel-lambdas))) + (( name) + ;; alias for another toplevel + (let ((proc (assq name toplevel-lambdas))) + (make-arity-info toplevel-calls + lexical-lambdas + (alist-cons (toplevel-define-name x) + (if (pair? proc) + (cdr proc) + exp) + toplevel-lambdas)))) + (else info))) + (( vars vals) + (fold extend info vars vals)) + (( vars vals) + (fold extend info vars vals)) + (( vars vals) + (fold extend info vars vals)) + + (( proc args src) + (record-case proc + (( body) + (validate-arity proc x #t) + info) + (( name) + (make-arity-info (alist-cons name x toplevel-calls) + lexical-lambdas + toplevel-lambdas)) + (( gensym) + (let ((proc (assq gensym lexical-lambdas))) + (if (pair? proc) + (record-case (cdr proc) + (( name) + ;; alias to toplevel + (make-arity-info (alist-cons name x toplevel-calls) + lexical-lambdas + toplevel-lambdas)) + (else + (validate-arity (cdr proc) x #t) + info)) + + ;; If GENSYM wasn't found, it may be because it's an + ;; argument of the procedure being compiled. + info))) + (else info))) + (else info)))) + + (lambda (x info env) + ;; Up from X. + (define (shrink name val info) + ;; Remove NAME from the lexical-lambdas of INFO. + (let ((toplevel-calls (toplevel-procedure-calls info)) + (lexical-lambdas (lexical-lambdas info)) + (toplevel-lambdas (toplevel-lambdas info))) + (make-arity-info toplevel-calls + (alist-delete name lexical-lambdas eq?) + toplevel-lambdas))) + + (let ((toplevel-calls (toplevel-procedure-calls info)) + (lexical-lambdas (lexical-lambdas info)) + (toplevel-lambdas (toplevel-lambdas info))) + (record-case x + (( vars vals) + (fold shrink info vars vals)) + (( vars vals) + (fold shrink info vars vals)) + (( vars vals) + (fold shrink info vars vals)) + + (else info)))) + + (lambda (result env) + ;; Post-processing: check all top-level procedure calls that have been + ;; encountered. + (let ((toplevel-calls (toplevel-procedure-calls result)) + (toplevel-lambdas (toplevel-lambdas result))) + (for-each (lambda (name+application) + (let* ((name (car name+application)) + (application (cdr name+application)) + (proc + (or (assoc-ref toplevel-lambdas name) + (and (module? env) + (false-if-exception + (module-ref env name))))) + (proc* + ;; handle toplevel aliases + (if (toplevel-ref? proc) + (let ((name (toplevel-ref-name proc))) + (and (module? env) + (false-if-exception + (module-ref env name)))) + proc))) + ;; (format #t "toplevel-call to ~A (~A) from ~A~%" + ;; name proc* application) + (if (or (lambda? proc*) (procedure? proc*)) + (validate-arity proc* application (lambda? proc*))))) + toplevel-calls))) + + (make-arity-info '() '() '()))) diff --git a/module/language/tree-il/compile-glil.scm b/module/language/tree-il/compile-glil.scm index 1c9a9c568..dfe290788 100644 --- a/module/language/tree-il/compile-glil.scm +++ b/module/language/tree-il/compile-glil.scm @@ -45,7 +45,8 @@ (define %warning-passes `((unused-variable . ,unused-variable-analysis) - (unbound-variable . ,unbound-variable-analysis))) + (unbound-variable . ,unbound-variable-analysis) + (arity-mismatch . ,arity-analysis))) (define (compile-glil x e opts) (define warnings diff --git a/module/system/base/message.scm b/module/system/base/message.scm index 48a00b80a..bacf0415b 100644 --- a/module/system/base/message.scm +++ b/module/system/base/message.scm @@ -85,7 +85,18 @@ "report possibly unbound variables" ,(lambda (port loc name) (format port "~A: warning: possibly unbound variable `~A'~%" - loc name)))))) + loc name))) + + (arity-mismatch + "report procedure arity mismatches (wrong number of arguments)" + ,(lambda (port loc name certain?) + (if certain? + (format port + "~A: warning: wrong number of arguments to `~A'~%" + loc name) + (format port + "~A: warning: possibly wrong number of arguments to `~A'~%" + loc name))))))) (define (lookup-warning-type name) "Return the warning type NAME or `#f' if not found." diff --git a/test-suite/tests/tree-il.test b/test-suite/tests/tree-il.test index 2e78a1a07..4104271a1 100644 --- a/test-suite/tests/tree-il.test +++ b/test-suite/tests/tree-il.test @@ -26,9 +26,6 @@ #:use-module (language glil) #:use-module (srfi srfi-13)) -(define read-and-compile - (@@ (system base compile) read-and-compile)) - ;; Of course, the GLIL that is emitted depends on the source info of the ;; input. Here we're not concerned about that, so we strip source ;; information from the incoming tree-il. @@ -561,6 +558,10 @@ (define %opts-w-unbound '(#:warnings (unbound-variable))) +(define %opts-w-arity + '(#:warnings (arity-mismatch))) + + (with-test-prefix "warnings" (pass-if "unknown warning type" @@ -686,4 +687,125 @@ (define z (foo-bar (make )))"))) (read-and-compile in #:env m - #:opts %opts-w-unbound))))))))) + #:opts %opts-w-unbound)))))))) + + (with-test-prefix "arity mismatch" + + (pass-if "quiet" + (null? (call-with-warnings + (lambda () + (compile '(cons 'a 'b) #:opts %opts-w-arity))))) + + (pass-if "direct application" + (let ((w (call-with-warnings + (lambda () + (compile '((lambda (x y) (or x y)) 1 2 3 4 5) + #:opts %opts-w-arity + #:to 'assembly))))) + (and (= (length w) 1) + (number? (string-contains (car w) + "wrong number of arguments to"))))) + (pass-if "local" + (let ((w (call-with-warnings + (lambda () + (compile '(let ((f (lambda (x y) (+ x y)))) + (f 2)) + #:opts %opts-w-arity + #:to 'assembly))))) + (and (= (length w) 1) + (number? (string-contains (car w) + "wrong number of arguments to"))))) + + (pass-if "global" + (let ((w (call-with-warnings + (lambda () + (compile '(cons 1 2 3 4) + #:opts %opts-w-arity + #:to 'assembly))))) + (and (= (length w) 1) + (number? (string-contains (car w) + "wrong number of arguments to"))))) + + (pass-if "alias to global" + (let ((w (call-with-warnings + (lambda () + (compile '(let ((f cons)) (f 1 2 3 4)) + #:opts %opts-w-arity + #:to 'assembly))))) + (and (= (length w) 1) + (number? (string-contains (car w) + "wrong number of arguments to"))))) + + (pass-if "alias to lexical to global" + (let ((w (call-with-warnings + (lambda () + (compile '(let ((f number?)) + (let ((g f)) + (f 1 2 3 4))) + #:opts %opts-w-arity + #:to 'assembly))))) + (and (= (length w) 1) + (number? (string-contains (car w) + "wrong number of arguments to"))))) + + (pass-if "alias to lexical" + (let ((w (call-with-warnings + (lambda () + (compile '(let ((f (lambda (x y z) (+ x y z)))) + (let ((g f)) + (g 1))) + #:opts %opts-w-arity + #:to 'assembly))))) + (and (= (length w) 1) + (number? (string-contains (car w) + "wrong number of arguments to"))))) + + (pass-if "letrec" + (let ((w (call-with-warnings + (lambda () + (compile '(letrec ((odd? (lambda (x) (even? (1- x)))) + (even? (lambda (x) + (or (= 0 x) + (odd?))))) + (odd? 1)) + #: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 () + (let ((in (open-input-string " + (define (g x) (f x)) + (define (f) 1)"))) + (read-and-compile in + #:opts %opts-w-arity + #:to 'assembly)))))) + (and (= (length w) 1) + (number? (string-contains (car w) + "wrong number of arguments to"))))) + + (pass-if "global toplevel alias" + (let ((w (call-with-warnings + (lambda () + (let ((in (open-input-string " + (define f cons) + (define (g) (f))"))) + (read-and-compile in + #:opts %opts-w-arity + #:to 'assembly)))))) + (and (= (length w) 1) + (number? (string-contains (car w) + "wrong number of arguments to"))))) + + (pass-if "local toplevel overrides global" + (null? (call-with-warnings + (lambda () + (let ((in (open-input-string " + (define (cons) 0) + (define (foo x) (cons))"))) + (read-and-compile in + #:opts %opts-w-arity + #:to 'assembly))))))))