summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
-rw-r--r--module/language/tree-il/analyze.scm218
-rw-r--r--module/language/tree-il/compile-glil.scm3
-rw-r--r--module/system/base/message.scm13
-rw-r--r--test-suite/tests/tree-il.test130
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.
+;;;
+
+;; <arity-info> 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 <arity-info>
+ (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
+ ((<lambda-case> req opt rest kw)
+ (values name (len req) (len opt) rest (len kw)))
+ ((<lambda> 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
+ ((<lambda> body)
+ (make-arity-info toplevel-calls
+ (alist-cons lexical-name val
+ lexical-lambdas)
+ toplevel-lambdas))
+ ((<lexical-ref> gensym)
+ ;; lexical alias
+ (let ((val* (assq gensym lexical-lambdas)))
+ (if (pair? val*)
+ (extend lexical-name (cdr val*) info)
+ info)))
+ ((<toplevel-ref> 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
+ ((<toplevel-define> name exp)
+ (record-case exp
+ ((<lambda> body)
+ (make-arity-info toplevel-calls
+ lexical-lambdas
+ (alist-cons name exp toplevel-lambdas)))
+ ((<toplevel-ref> 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)))
+ ((<let> vars vals)
+ (fold extend info vars vals))
+ ((<letrec> vars vals)
+ (fold extend info vars vals))
+ ((<fix> vars vals)
+ (fold extend info vars vals))
+
+ ((<application> proc args src)
+ (record-case proc
+ ((<lambda> body)
+ (validate-arity proc x #t)
+ info)
+ ((<toplevel-ref> name)
+ (make-arity-info (alist-cons name x toplevel-calls)
+ lexical-lambdas
+ toplevel-lambdas))
+ ((<lexical-ref> gensym)
+ (let ((proc (assq gensym lexical-lambdas)))
+ (if (pair? proc)
+ (record-case (cdr proc)
+ ((<toplevel-ref> 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
+ ((<let> vars vals)
+ (fold shrink info vars vals))
+ ((<letrec> vars vals)
+ (fold shrink info vars vals))
+ ((<fix> 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 <foo>)))")))
(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))))))))