mirror/guile
mirror/guile
1
Fork 0
mirror of https://git.savannah.gnu.org/git/guile.git synced 2025-06-30 06:50:31 +02:00
Code Activity

Add support for keyword arguments in `arity-mismatch-analysis'.

Browse source 
* 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.
This commit is contained in:
Ludovic Courtès 2009-11-08 01:02:08 +01:00
parent 5658035c9c
commit af5ed54927
2 changed files with 96 additions and 25 deletions
Download patch file Download diff file Expand all files Collapse all files

73
module/language/tree-il/analyze.scm
View file

@ -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.
;;;
;; <arity-info> records contains information about lexical definitions of
;; <arity-info> 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
((<lambda-case> 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))))
((<lambda> 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

48
test-suite/tests/tree-il.test
View file

@ -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)))))))