[Top][All Lists]
[Date Prev][Date Next][Thread Prev][Thread Next][Date Index][Thread Index]
[Guile-commits] GNU Guile branch, master, updated. release_1-9-4-88-g565
|
From: |
Ludovic Courtès |
|
Subject: |
[Guile-commits] GNU Guile branch, master, updated. release_1-9-4-88-g5658035 |
|
Date: |
Sat, 07 Nov 2009 18:26:00 +0000 |
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=5658035c9c7c2688ca90cd6241c1687bde8c992c
The branch, master has been updated
via 5658035c9c7c2688ca90cd6241c1687bde8c992c (commit)
via cdd73a8d697ee487c8b52785a9d02d3314d3fdf5 (commit)
via ae03cf1f59b78bbf23e3a3b4eefd3c8a3ea8301d (commit)
from 48b1db7543c093ba15ce7d21ac72c35966c9cc9d (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 5658035c9c7c2688ca90cd6241c1687bde8c992c
Author: Ludovic Courtès <address@hidden>
Date: Sat Nov 7 19:24:49 2009 +0100
Fix typos leading to wrong argument counts.
* module/ice-9/channel.scm (eval): Fix number of arguments to
`guile:eval'.
* module/oop/goops/save.scm (write-readably): Fix number of arguments to
`write-array'.
* module/srfi/srfi-19.scm (priv:char->int): Fix number of arguments to
`priv:time-error'.
commit cdd73a8d697ee487c8b52785a9d02d3314d3fdf5
Author: Ludovic Courtès <address@hidden>
Date: Sat Nov 7 19:19:16 2009 +0100
Fix typos in `psyntax'.
* module/ice-9/psyntax.scm (lambda*-formals): Fix argument count in
`rest' invocations.
[pred]: Fix argument count in `syntax->datum' invocation.
commit ae03cf1f59b78bbf23e3a3b4eefd3c8a3ea8301d
Author: Ludovic Courtès <address@hidden>
Date: Sat Nov 7 18:32:26 2009 +0100
Add `arity-mismatch' warning type.
* module/language/tree-il/analyze.scm (<arity-info>): 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.
-----------------------------------------------------------------------
Summary of changes:
module/ice-9/channel.scm | 4 +-
module/ice-9/psyntax-pp.scm | 16 +-
module/ice-9/psyntax.scm | 10 +-
module/language/tree-il/analyze.scm | 218 +++++++++++++++++++++++++++++-
module/language/tree-il/compile-glil.scm | 3 +-
module/oop/goops/save.scm | 2 +-
module/srfi/srfi-19.scm | 2 +-
module/system/base/message.scm | 13 ++-
test-suite/tests/tree-il.test | 130 +++++++++++++++++-
9 files changed, 371 insertions(+), 27 deletions(-)
diff --git a/module/ice-9/channel.scm b/module/ice-9/channel.scm
index b9d4700..01bff02 100644
--- a/module/ice-9/channel.scm
+++ b/module/ice-9/channel.scm
@@ -1,6 +1,6 @@
;;; Guile object channel
-;; Copyright (C) 2001, 2006 Free Software Foundation, Inc.
+;; Copyright (C) 2001, 2006, 2009 Free Software Foundation, Inc.
;;;; This library is free software; you can redistribute it and/or
;;;; modify it under the terms of the GNU Lesser General Public
@@ -159,7 +159,7 @@
(define guile:eval eval)
(define eval
(if (= (car (procedure-property guile:eval 'arity)) 1)
- (lambda (x e) (guile:eval x))
+ (lambda (x e) (guile:eval x e))
guile:eval))
(define object->string
diff --git a/module/ice-9/psyntax-pp.scm b/module/ice-9/psyntax-pp.scm
index 1dc6469..f2d3dfc 100644
--- a/module/ice-9/psyntax-pp.scm
+++ b/module/ice-9/psyntax-pp.scm
@@ -628,8 +628,8 @@
#{a\ 483}#
#{b\ 484}#)
(eq? (syntax->datum
- #{a\ 483}#
- #:rest)))
+ #{a\ 483}#)
+ #:rest))
#{tmp\ 481}#)
#f)
(apply (lambda (#{x\ 485}#
@@ -639,9 +639,8 @@
#{b\ 487}#
#{req\ 475}#
#{opt\ 476}#
- #f
#{kw\ 477}#
- #{x\ 485}#))
+ #f))
#{tmp\ 481}#)
((lambda (#{tmp\ 488}#)
(if (if #{tmp\ 488}#
@@ -657,9 +656,8 @@
#{b\ 492}#
#{req\ 475}#
#{opt\ 476}#
- #f
#{kw\ 477}#
- #{x\ 491}#))
+ #f))
#{tmp\ 488}#)
((lambda (#{else\ 493}#)
(syntax-violation
@@ -1250,7 +1248,8 @@
#{opt\ 496}#
(cons #t
(reverse
-
#{rkey\ 497}#))))
+
#{rkey\ 497}#))
+
#f))
#{tmp\ 535}#)
((lambda
(#{tmp\ 542}#)
(if (if
#{tmp\ 542}#
@@ -1272,7 +1271,8 @@
#{opt\ 496}#
(cons #t
(reverse
-
#{rkey\ 497}#))))
+
#{rkey\ 497}#))
+
#f))
#{tmp\ 542}#)
((lambda (#{tmp\ 547}#)
(if
(if #{tmp\ 547}#
diff --git a/module/ice-9/psyntax.scm b/module/ice-9/psyntax.scm
index 6fcc9b0..b1c09f8 100644
--- a/module/ice-9/psyntax.scm
+++ b/module/ice-9/psyntax.scm
@@ -1664,10 +1664,10 @@
(pred #'b req opt (cons #t (reverse rkey))))
((aok a b) (and (eq? (syntax->datum #'aok) #:allow-other-keys)
(eq? (syntax->datum #'a) #:rest))
- (rest #'b req opt (cons #t (reverse rkey))))
+ (rest #'b req opt (cons #t (reverse rkey)) #f))
((aok . r) (and (eq? (syntax->datum #'aok) #:allow-other-keys)
(id? #'r))
- (rest #'r req opt (cons #t (reverse rkey))))
+ (rest #'r req opt (cons #t (reverse rkey)) #f))
((a . b) (eq? (syntax->datum #'a) #:predicate)
(pred #'b req opt (cons #f (reverse rkey))))
((a b) (eq? (syntax->datum #'a) #:rest)
@@ -1680,10 +1680,10 @@
(define (pred args req opt kw)
(syntax-case args ()
((x) (check req opt #f kw #'x))
- ((x a b) (eq? (syntax->datum #'a #:rest))
- (rest #'b req opt #f kw #'x))
+ ((x a b) (eq? (syntax->datum #'a) #:rest)
+ (rest #'b req opt kw #f))
((x . b) (id? #'b)
- (rest #'b req opt #f kw #'x))
+ (rest #'b req opt kw #f))
(else
(syntax-violation 'lambda* "invalid argument list following
#:predicate"
orig-args args))))
diff --git a/module/language/tree-il/analyze.scm
b/module/language/tree-il/analyze.scm
index ac132e3..1478b8d 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 1c9a9c5..dfe2907 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/oop/goops/save.scm b/module/oop/goops/save.scm
index b500a0c..b51c9e3 100644
--- a/module/oop/goops/save.scm
+++ b/module/oop/goops/save.scm
@@ -270,7 +270,7 @@
(display "(list->uniform-array " file)
(display (array-rank o) file)
(display " '() " file)
- (write-array "(list " o file env)))))
+ (write-array "(list " o #f file env)))))
;;;
;;; Pairs
diff --git a/module/srfi/srfi-19.scm b/module/srfi/srfi-19.scm
index 2820615..8a86b35 100644
--- a/module/srfi/srfi-19.scm
+++ b/module/srfi/srfi-19.scm
@@ -1224,7 +1224,7 @@
((#\7) 7)
((#\8) 8)
((#\9) 9)
- (else (priv:time-error 'bad-date-template-string
+ (else (priv:time-error 'priv:char->int 'bad-date-template-string
(list "Non-integer character" ch)))))
;; read an integer upto n characters long on port; upto -> #f is any length
diff --git a/module/system/base/message.scm b/module/system/base/message.scm
index 48a00b8..bacf041 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 2e78a1a..4104271 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))))))))
hooks/post-receive
--
GNU Guile
| [Prev in Thread] |
Current Thread |
[Next in Thread] |
- [Guile-commits] GNU Guile branch, master, updated. release_1-9-4-88-g5658035,
Ludovic Courtès <=