From af5ed549271a8939f8b02599dc6eb6fd5c174bea Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Ludovic=20Court=C3=A8s?= Date: Sun, 8 Nov 2009 01:02:08 +0100 Subject: [PATCH] Add support for keyword arguments in `arity-mismatch-analysis'. * module/language/tree-il/analyze.scm (validate-arity)[filter-keyword-args]: New procedure. [arity]: Get accurate arity for programs, return ALLOW-OTHER-KEYS? as an additional value. Update to `arity' change; use `filter-keyword-args'. * test-suite/tests/tree-il.test ("warnings")["arity mismatch"]("keyword not passed and quiet", "keyword passed and quiet", "keyword passed to global and quiet", "extra keyword", "extra keywords allowed"): New tests. --- module/language/tree-il/analyze.scm | 73 +++++++++++++++++++---------- test-suite/tests/tree-il.test | 48 ++++++++++++++++++- 2 files changed, 96 insertions(+), 25 deletions(-) diff --git a/module/language/tree-il/analyze.scm b/module/language/tree-il/analyze.scm index 1478b8d41..d175a3877 100644 --- a/module/language/tree-il/analyze.scm +++ b/module/language/tree-il/analyze.scm @@ -23,6 +23,7 @@ #:use-module (srfi srfi-9) #:use-module (system base syntax) #:use-module (system base message) + #:use-module (system vm program) #:use-module (language tree-il) #:export (analyze-lexicals analyze-tree @@ -761,7 +762,7 @@ ;;; Arity analysis. ;;; -;; records contains information about lexical definitions of +;; records contain 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. @@ -776,6 +777,26 @@ ;; Validate the argument count of APPLICATION, a tree-il application of ;; PROC, emitting a warning in case of argument count mismatch. + (define (filter-keyword-args keywords allow-other-keys? args) + ;; Filter keyword arguments from ARGS and return the resulting list. + ;; KEYWORDS is the list of allowed keywords, and ALLOW-OTHER-KEYS? + ;; specified whethere keywords not listed in KEYWORDS are allowed. + (let loop ((args args) + (result '())) + (if (null? args) + (reverse result) + (let ((arg (car args))) + (if (and (const? arg) + (or (memq (const-exp arg) keywords) + (and allow-other-keys? + (keyword? (const-exp arg))))) + (loop (if (pair? (cdr args)) + (cddr args) + '()) + result) + (loop (cdr args) + (cons arg result))))))) + (define (arity proc) ;; Return the arity of PROC, which can be either a tree-il or a ;; procedure. @@ -783,44 +804,48 @@ (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)))) + (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)))) ((procedure? proc) (let ((arity (procedure-property proc 'arity))) (values (procedure-name proc) - (car arity) (cadr arity) (caddr arity) 0))) + (car arity) (cadr arity) (caddr arity) + #f #f))) (else (let loop ((name #f) (proc proc)) (record-case proc (( req opt rest kw) - (values name (len req) (len opt) rest (len kw))) + (values name (len req) (len opt) rest + (and (pair? kw) (map car (cdr kw))) + (and (pair? kw) (car kw)))) (( meta body) (loop (assoc-ref meta 'name) body)) (else - (values #f #f #f #f #f))))))) + (values #f #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)))) + (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))))) #t) (define arity-analysis diff --git a/test-suite/tests/tree-il.test b/test-suite/tests/tree-il.test index 4104271a1..ea098a5c6 100644 --- a/test-suite/tests/tree-il.test +++ b/test-suite/tests/tree-il.test @@ -808,4 +808,50 @@ (define (foo x) (cons))"))) (read-and-compile in #:opts %opts-w-arity - #:to 'assembly)))))))) + #:to 'assembly)))))) + + (pass-if "keyword not passed and quiet" + (null? (call-with-warnings + (lambda () + (compile '(let ((f (lambda* (x #:key y) y))) + (f 2)) + #:opts %opts-w-arity + #:to 'assembly))))) + + (pass-if "keyword passed and quiet" + (null? (call-with-warnings + (lambda () + (compile '(let ((f (lambda* (x #:key y) y))) + (f 2 #:y 3)) + #:opts %opts-w-arity + #:to 'assembly))))) + + (pass-if "keyword passed to global and quiet" + (null? (call-with-warnings + (lambda () + (let ((in (open-input-string " + (use-modules (system base compile)) + (compile '(+ 2 3) #:env (current-module))"))) + (read-and-compile in + #:opts %opts-w-arity + #:to 'assembly)))))) + + (pass-if "extra keyword" + (let ((w (call-with-warnings + (lambda () + (compile '(let ((f (lambda* (x #:key y) y))) + (f 2 #:Z 3)) + #:opts %opts-w-arity + #:to 'assembly))))) + (and (= (length w) 1) + (number? (string-contains (car w) + "wrong number of arguments to"))))) + + (pass-if "extra keywords allowed" + (null? (call-with-warnings + (lambda () + (compile '(let ((f (lambda* (x #:key y #:allow-other-keys) + y))) + (f 2 #:Z 3)) + #:opts %opts-w-arity + #:to 'assembly)))))))