[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-85-g48b
|
From: |
Ludovic Courtès |
|
Subject: |
[Guile-commits] GNU Guile branch, master, updated. release_1-9-4-85-g48b1db7 |
|
Date: |
Fri, 06 Nov 2009 10:38:48 +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=48b1db7543c093ba15ce7d21ac72c35966c9cc9d
The branch, master has been updated
via 48b1db7543c093ba15ce7d21ac72c35966c9cc9d (commit)
from 632299050a9063c6894c82ba31faa6b5fc03de59 (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 48b1db7543c093ba15ce7d21ac72c35966c9cc9d
Author: Ludovic Courtès <address@hidden>
Date: Fri Nov 6 10:42:45 2009 +0100
Coalesce tree traversals made for warnings.
* module/language/tree-il/analyze.scm (<tree-analysis>): New type.
(analyze-tree): New procedure.
(report-unused-variables): Replace by...
(unused-variable-analysis): ... this, as a <tree-analysis>.
(report-possibly-unbound-variables): Replace by...
(unbound-variable-analysis): ... this, as a <tree-analysis>.
* module/language/tree-il/compile-glil.scm (%warning-passes): Adjust
accordingly.
(compile-glil): Likewise. Use `analyze-tree'.
-----------------------------------------------------------------------
Summary of changes:
module/language/tree-il/analyze.scm | 397 ++++++++++++++++--------------
module/language/tree-il/compile-glil.scm | 14 +-
2 files changed, 223 insertions(+), 188 deletions(-)
diff --git a/module/language/tree-il/analyze.scm
b/module/language/tree-il/analyze.scm
index 5faed6f..ac132e3 100644
--- a/module/language/tree-il/analyze.scm
+++ b/module/language/tree-il/analyze.scm
@@ -25,8 +25,9 @@
#:use-module (system base message)
#:use-module (language tree-il)
#:export (analyze-lexicals
- report-unused-variables
- report-possibly-unbound-variables))
+ analyze-tree
+ unused-variable-analysis
+ unbound-variable-analysis))
;; Allocation is the process of assigning storage locations for lexical
;; variables. A lexical variable has a distinct "address", or storage
@@ -485,6 +486,44 @@
;;;
+;;; Tree analyses for warnings.
+;;;
+
+(define-record-type <tree-analysis>
+ (make-tree-analysis leaf down up post init)
+ tree-analysis?
+ (leaf tree-analysis-leaf) ;; (lambda (x result env) ...)
+ (down tree-analysis-down) ;; (lambda (x result env) ...)
+ (up tree-analysis-up) ;; (lambda (x result env) ...)
+ (post tree-analysis-post) ;; (lambda (result env) ...)
+ (init tree-analysis-init)) ;; arbitrary value
+
+(define (analyze-tree analyses tree env)
+ "Run all tree analyses listed in ANALYSES on TREE for ENV, using
+`tree-il-fold'. Return TREE."
+ (define (traverse proc)
+ (lambda (x results)
+ (map (lambda (analysis result)
+ ((proc analysis) x result env))
+ analyses
+ results)))
+
+ (let ((results
+ (tree-il-fold (traverse tree-analysis-leaf)
+ (traverse tree-analysis-down)
+ (traverse tree-analysis-up)
+ (map tree-analysis-init analyses)
+ tree)))
+
+ (for-each (lambda (analysis result)
+ ((tree-analysis-post analysis) result env))
+ analyses
+ results))
+
+ tree)
+
+
+;;;
;;; Unused variable analysis.
;;;
@@ -499,104 +538,104 @@
(refs binding-info-refs) ;; (GENSYM ...)
(locs binding-info-locs)) ;; (LOCATION ...)
-;; FIXME!!
-(define (report-unused-variables tree env)
- "Report about unused variables in TREE. Return TREE."
-
- (tree-il-fold (lambda (x info)
- ;; X is a leaf: extend INFO's refs accordingly.
- (let ((refs (binding-info-refs info))
- (vars (binding-info-vars info))
- (locs (binding-info-locs info)))
- (record-case x
- ((<lexical-ref> gensym)
- (make-binding-info vars (cons gensym refs) locs))
- (else info))))
-
- (lambda (x info)
- ;; Going down into X: extend INFO's variable list
- ;; accordingly.
- (let ((refs (binding-info-refs info))
- (vars (binding-info-vars info))
- (locs (binding-info-locs info))
- (src (tree-il-src x)))
- (define (extend inner-vars inner-names)
- (append (map (lambda (var name)
- (list var name src))
- inner-vars
- inner-names)
- vars))
- (record-case x
- ((<lexical-set> gensym)
- (make-binding-info vars (cons gensym refs)
- (cons src locs)))
- ((<lambda-case> req opt inits rest kw vars)
- ;; FIXME keywords.
- (let ((names `(,@req
- ,@(map car (or opt '()))
- ,@(if rest (list rest) '())
- ,@(if kw (map cadr (cdr kw)) '()))))
- (make-binding-info (extend vars names) refs
- (cons src locs))))
- ((<let> vars names)
- (make-binding-info (extend vars names) refs
- (cons src locs)))
- ((<letrec> vars names)
- (make-binding-info (extend vars names) refs
- (cons src locs)))
- ((<fix> vars names)
- (make-binding-info (extend vars names) refs
- (cons src locs)))
- (else info))))
-
- (lambda (x info)
- ;; Leaving X's scope: shrink INFO's variable list
- ;; accordingly and reported unused nested variables.
- (let ((refs (binding-info-refs info))
- (vars (binding-info-vars info))
- (locs (binding-info-locs info)))
- (define (shrink inner-vars refs)
- (for-each (lambda (var)
- (let ((gensym (car var)))
- ;; Don't report lambda parameters as
- ;; unused.
- (if (and (not (memq gensym refs))
- (not (and (lambda-case? x)
- (memq gensym
- inner-vars))))
- (let ((name (cadr var))
- ;; We can get approximate
- ;; source location by going up
- ;; the LOCS location stack.
- (loc (or (caddr var)
- (find pair? locs))))
- (warning 'unused-variable loc
name)))))
- (filter (lambda (var)
- (memq (car var) inner-vars))
- vars))
- (fold alist-delete vars inner-vars))
-
- ;; For simplicity, we leave REFS untouched, i.e., with
- ;; names of variables that are now going out of scope.
- ;; It doesn't hurt as these are unique names, it just
- ;; makes REFS unnecessarily fat.
- (record-case x
- ((<lambda-case> vars)
- (make-binding-info (shrink vars refs) refs
- (cdr locs)))
- ((<let> vars)
- (make-binding-info (shrink vars refs) refs
- (cdr locs)))
- ((<letrec> vars)
- (make-binding-info (shrink vars refs) refs
- (cdr locs)))
- ((<fix> vars)
- (make-binding-info (shrink vars refs) refs
- (cdr locs)))
- (else info))))
- (make-binding-info '() '() '())
- tree)
- tree)
+(define unused-variable-analysis
+ ;; Report about unused variables in TREE.
+
+ (make-tree-analysis
+ (lambda (x info env)
+ ;; X is a leaf: extend INFO's refs accordingly.
+ (let ((refs (binding-info-refs info))
+ (vars (binding-info-vars info))
+ (locs (binding-info-locs info)))
+ (record-case x
+ ((<lexical-ref> gensym)
+ (make-binding-info vars (cons gensym refs) locs))
+ (else info))))
+
+ (lambda (x info env)
+ ;; Going down into X: extend INFO's variable list
+ ;; accordingly.
+ (let ((refs (binding-info-refs info))
+ (vars (binding-info-vars info))
+ (locs (binding-info-locs info))
+ (src (tree-il-src x)))
+ (define (extend inner-vars inner-names)
+ (append (map (lambda (var name)
+ (list var name src))
+ inner-vars
+ inner-names)
+ vars))
+ (record-case x
+ ((<lexical-set> gensym)
+ (make-binding-info vars (cons gensym refs)
+ (cons src locs)))
+ ((<lambda-case> req opt inits rest kw vars)
+ ;; FIXME keywords.
+ (let ((names `(,@req
+ ,@(map car (or opt '()))
+ ,@(if rest (list rest) '())
+ ,@(if kw (map cadr (cdr kw)) '()))))
+ (make-binding-info (extend vars names) refs
+ (cons src locs))))
+ ((<let> vars names)
+ (make-binding-info (extend vars names) refs
+ (cons src locs)))
+ ((<letrec> vars names)
+ (make-binding-info (extend vars names) refs
+ (cons src locs)))
+ ((<fix> vars names)
+ (make-binding-info (extend vars names) refs
+ (cons src locs)))
+ (else info))))
+
+ (lambda (x info env)
+ ;; Leaving X's scope: shrink INFO's variable list
+ ;; accordingly and reported unused nested variables.
+ (let ((refs (binding-info-refs info))
+ (vars (binding-info-vars info))
+ (locs (binding-info-locs info)))
+ (define (shrink inner-vars refs)
+ (for-each (lambda (var)
+ (let ((gensym (car var)))
+ ;; Don't report lambda parameters as
+ ;; unused.
+ (if (and (not (memq gensym refs))
+ (not (and (lambda-case? x)
+ (memq gensym
+ inner-vars))))
+ (let ((name (cadr var))
+ ;; We can get approximate
+ ;; source location by going up
+ ;; the LOCS location stack.
+ (loc (or (caddr var)
+ (find pair? locs))))
+ (warning 'unused-variable loc name)))))
+ (filter (lambda (var)
+ (memq (car var) inner-vars))
+ vars))
+ (fold alist-delete vars inner-vars))
+
+ ;; For simplicity, we leave REFS untouched, i.e., with
+ ;; names of variables that are now going out of scope.
+ ;; It doesn't hurt as these are unique names, it just
+ ;; makes REFS unnecessarily fat.
+ (record-case x
+ ((<lambda-case> vars)
+ (make-binding-info (shrink vars refs) refs
+ (cdr locs)))
+ ((<let> vars)
+ (make-binding-info (shrink vars refs) refs
+ (cdr locs)))
+ ((<letrec> vars)
+ (make-binding-info (shrink vars refs) refs
+ (cdr locs)))
+ ((<fix> vars)
+ (make-binding-info (shrink vars refs) refs
+ (cdr locs)))
+ (else info))))
+
+ (lambda (result env) #t)
+ (make-binding-info '() '() '())))
;;;
@@ -639,84 +678,80 @@
(toplevel-define-arg args)))
(else #f)))
-;; TODO: Combine with `report-unused-variables' so we don't traverse the tree
-;; once for each warning type.
-
-(define (report-possibly-unbound-variables tree env)
- "Return possibly unbound variables in TREE. Return TREE."
- (define toplevel
- (tree-il-fold (lambda (x info)
- ;; X is a leaf: extend INFO's refs accordingly.
- (let ((refs (toplevel-info-refs info))
- (defs (toplevel-info-defs info))
- (locs (toplevel-info-locs info)))
- (define (bound? name)
- (or (and (module? env)
- (module-variable env name))
- (memq name defs)))
-
- (record-case x
- ((<toplevel-ref> name src)
- (if (bound? name)
- info
- (let ((src (or src (find pair? locs))))
- (make-toplevel-info (alist-cons name src refs)
- defs
- locs))))
- (else info))))
-
- (lambda (x info)
- ;; Going down into X.
- (let* ((refs (toplevel-info-refs info))
- (defs (toplevel-info-defs info))
- (src (tree-il-src x))
- (locs (cons src (toplevel-info-locs info))))
- (define (bound? name)
- (or (and (module? env)
- (module-variable env name))
- (memq name defs)))
-
- (record-case x
- ((<toplevel-set> name src)
- (if (bound? name)
- (make-toplevel-info refs defs locs)
- (let ((src (find pair? locs)))
- (make-toplevel-info (alist-cons name src refs)
- defs
- locs))))
- ((<toplevel-define> name)
- (make-toplevel-info (alist-delete name refs eq?)
- (cons name defs)
- locs))
-
- ((<application> proc args)
- ;; Check for a dynamic top-level definition, as is
- ;; done by code expanded from GOOPS macros.
- (let ((name (goops-toplevel-definition proc args
- env)))
- (if (symbol? name)
- (make-toplevel-info (alist-delete name refs
- eq?)
- (cons name defs)
- locs)
- (make-toplevel-info refs defs locs))))
- (else
- (make-toplevel-info refs defs locs)))))
-
- (lambda (x info)
- ;; Leaving X's scope.
- (let ((refs (toplevel-info-refs info))
- (defs (toplevel-info-defs info))
- (locs (toplevel-info-locs info)))
- (make-toplevel-info refs defs (cdr locs))))
-
- (make-toplevel-info '() '() '())
- tree))
-
- (for-each (lambda (name+loc)
- (let ((name (car name+loc))
- (loc (cdr name+loc)))
- (warning 'unbound-variable loc name)))
- (reverse (toplevel-info-refs toplevel)))
-
- tree)
+(define unbound-variable-analysis
+ ;; Return possibly unbound variables in TREE.
+ (make-tree-analysis
+ (lambda (x info env)
+ ;; X is a leaf: extend INFO's refs accordingly.
+ (let ((refs (toplevel-info-refs info))
+ (defs (toplevel-info-defs info))
+ (locs (toplevel-info-locs info)))
+ (define (bound? name)
+ (or (and (module? env)
+ (module-variable env name))
+ (memq name defs)))
+
+ (record-case x
+ ((<toplevel-ref> name src)
+ (if (bound? name)
+ info
+ (let ((src (or src (find pair? locs))))
+ (make-toplevel-info (alist-cons name src refs)
+ defs
+ locs))))
+ (else info))))
+
+ (lambda (x info env)
+ ;; Going down into X.
+ (let* ((refs (toplevel-info-refs info))
+ (defs (toplevel-info-defs info))
+ (src (tree-il-src x))
+ (locs (cons src (toplevel-info-locs info))))
+ (define (bound? name)
+ (or (and (module? env)
+ (module-variable env name))
+ (memq name defs)))
+
+ (record-case x
+ ((<toplevel-set> name src)
+ (if (bound? name)
+ (make-toplevel-info refs defs locs)
+ (let ((src (find pair? locs)))
+ (make-toplevel-info (alist-cons name src refs)
+ defs
+ locs))))
+ ((<toplevel-define> name)
+ (make-toplevel-info (alist-delete name refs eq?)
+ (cons name defs)
+ locs))
+
+ ((<application> proc args)
+ ;; Check for a dynamic top-level definition, as is
+ ;; done by code expanded from GOOPS macros.
+ (let ((name (goops-toplevel-definition proc args
+ env)))
+ (if (symbol? name)
+ (make-toplevel-info (alist-delete name refs
+ eq?)
+ (cons name defs)
+ locs)
+ (make-toplevel-info refs defs locs))))
+ (else
+ (make-toplevel-info refs defs locs)))))
+
+ (lambda (x info env)
+ ;; Leaving X's scope.
+ (let ((refs (toplevel-info-refs info))
+ (defs (toplevel-info-defs info))
+ (locs (toplevel-info-locs info)))
+ (make-toplevel-info refs defs (cdr locs))))
+
+ (lambda (toplevel env)
+ ;; Post-process the result.
+ (for-each (lambda (name+loc)
+ (let ((name (car name+loc))
+ (loc (cdr name+loc)))
+ (warning 'unbound-variable loc name)))
+ (reverse (toplevel-info-refs toplevel))))
+
+ (make-toplevel-info '() '() '())))
diff --git a/module/language/tree-il/compile-glil.scm
b/module/language/tree-il/compile-glil.scm
index a809e2d..1c9a9c5 100644
--- a/module/language/tree-il/compile-glil.scm
+++ b/module/language/tree-il/compile-glil.scm
@@ -28,6 +28,7 @@
#:use-module (language tree-il)
#:use-module (language tree-il optimize)
#:use-module (language tree-il analyze)
+ #:use-module ((srfi srfi-1) #:select (filter-map))
#:export (compile-glil))
;; allocation:
@@ -43,8 +44,8 @@
(define *comp-module* (make-fluid))
(define %warning-passes
- `((unused-variable . ,report-unused-variables)
- (unbound-variable . ,report-possibly-unbound-variables)))
+ `((unused-variable . ,unused-variable-analysis)
+ (unbound-variable . ,unbound-variable-analysis)))
(define (compile-glil x e opts)
(define warnings
@@ -52,11 +53,10 @@
'()))
;; Go through the warning passes.
- (for-each (lambda (kind)
- (let ((warn (assoc-ref %warning-passes kind)))
- (and (procedure? warn)
- (warn x e))))
- warnings)
+ (let ((analyses (filter-map (lambda (kind)
+ (assoc-ref %warning-passes kind))
+ warnings)))
+ (analyze-tree analyses x e))
(let* ((x (make-lambda (tree-il-src x) '()
(make-lambda-case #f '() #f #f #f '() '() #f x #f)))
hooks/post-receive
--
GNU Guile
| [Prev in Thread] |
Current Thread |
[Next in Thread] |
- [Guile-commits] GNU Guile branch, master, updated. release_1-9-4-85-g48b1db7,
Ludovic Courtès <=