[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-1-21-g4b8
|
From: |
Ludovic Courtès |
|
Subject: |
[Guile-commits] GNU Guile branch, master, updated. release_1-9-1-21-g4b85637 |
|
Date: |
Thu, 30 Jul 2009 23:23:33 +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=4b856371b3e85cd82f6d637f72bc610d0158b5de
The branch, master has been updated
via 4b856371b3e85cd82f6d637f72bc610d0158b5de (commit)
via 2e4c3227ce1374dd53abd3c7c5797cc64329de91 (commit)
via f4aa0f104b3347c21093b837046022fb7bb6a2ff (commit)
from 904a78f11d2d11a58d5df365a44c4fbbd4c96df3 (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 4b856371b3e85cd82f6d637f72bc610d0158b5de
Author: Ludovic Courtès <address@hidden>
Date: Fri Jul 31 00:42:58 2009 +0200
Add unused variable analysis in the tree-il->glil compiler.
* module/language/tree-il/analyze.scm (<binding-info>): New record type.
(report-unused-variables): New procedure.
* module/language/tree-il/compile-glil.scm (%warning-passes): New
variable.
(compile-glil): Honor `#:warnings' from OPTS.
* test-suite/tests/tree-il.test (call-with-warnings): New procedure.
(%opts-w-unused): New variable.
("warnings"): New test prefix.
commit 2e4c3227ce1374dd53abd3c7c5797cc64329de91
Author: Ludovic Courtès <address@hidden>
Date: Fri Jul 31 00:06:59 2009 +0200
Add `(system base message)', a simple warning framework.
* module/Makefile.am (SOURCES): Add `system/base/message.scm'.
* module/scripts/compile.scm (%options): Add `--warn'.
(parse-args): Update default value for `warnings'.
(show-warning-help): New procedure.
(compile)[compile-opts]: Add `#:warnings'.
Update help message.
* module/system/base/compile.scm (compile): Sanity-check the requested
warnings.
* module/system/base/message.scm: New file.
commit f4aa0f104b3347c21093b837046022fb7bb6a2ff
Author: Ludovic Courtès <address@hidden>
Date: Thu Jul 30 00:48:04 2009 +0200
Add `tree-il-fold', a purely functional iterator on `tree-il'.
* module/language/tree-il.scm (tree-il-fold): New procedure.
* test-suite/tests/tree-il.test ("tree-il-fold"): New test prefix.
-----------------------------------------------------------------------
Summary of changes:
module/Makefile.am | 1 +
module/language/tree-il.scm | 49 +++++++++++-
module/language/tree-il/analyze.scm | 129 +++++++++++++++++++++++++++++-
module/language/tree-il/compile-glil.scm | 16 ++++
module/scripts/compile.scm | 34 ++++++++-
module/system/base/compile.scm | 11 +++
module/system/base/message.scm | 102 +++++++++++++++++++++++
test-suite/tests/tree-il.test | 117 +++++++++++++++++++++++++++-
8 files changed, 454 insertions(+), 5 deletions(-)
create mode 100644 module/system/base/message.scm
diff --git a/module/Makefile.am b/module/Makefile.am
index a904a8f..2971fc6 100644
--- a/module/Makefile.am
+++ b/module/Makefile.am
@@ -34,6 +34,7 @@ SOURCES =
\
ice-9/psyntax-pp.scm
\
system/base/pmatch.scm system/base/syntax.scm
\
system/base/compile.scm system/base/language.scm \
+ system/base/message.scm \
\
language/tree-il.scm \
language/ghil.scm language/glil.scm language/assembly.scm \
diff --git a/module/language/tree-il.scm b/module/language/tree-il.scm
index 0f8448a..aec4eed 100644
--- a/module/language/tree-il.scm
+++ b/module/language/tree-il.scm
@@ -17,6 +17,7 @@
(define-module (language tree-il)
+ #:use-module (srfi srfi-1)
#:use-module (system base pmatch)
#:use-module (system base syntax)
#:export (tree-il-src
@@ -38,11 +39,12 @@
<let> let? make-let let-src let-names let-vars let-vals let-body
<letrec> letrec? make-letrec letrec-src letrec-names letrec-vars
letrec-vals letrec-body
<let-values> let-values? make-let-values let-values-src
let-values-names let-values-vars let-values-exp let-values-body
-
+
parse-tree-il
unparse-tree-il
tree-il->scheme
+ tree-il-fold
post-order!
pre-order!))
@@ -258,6 +260,51 @@
`(call-with-values (lambda () ,(tree-il->scheme exp))
(lambda ,vars ,(tree-il->scheme body))))))
+
+(define (tree-il-fold leaf down up seed tree)
+ "Traverse TREE, calling LEAF on each leaf encountered, DOWN upon descent
+into a sub-tree, and UP when leaving a sub-tree. Each of these procedures is
+invoked as `(PROC TREE SEED)', where TREE is the sub-tree or leaf considered
+and SEED is the current result, intially seeded with SEED.
+
+This is an implementation of `foldts' as described by Andy Wingo in
+``Applications of fold to XML transformation''."
+ (let loop ((tree tree)
+ (result seed))
+ (if (or (null? tree) (pair? tree))
+ (fold loop result tree)
+ (record-case tree
+ ((<lexical-set> exp)
+ (up tree (loop exp (down tree result))))
+ ((<module-set> exp)
+ (up tree (loop exp (down tree result))))
+ ((<toplevel-set> exp)
+ (up tree (loop exp (down tree result))))
+ ((<toplevel-define> exp)
+ (up tree (loop exp (down tree result))))
+ ((<conditional> test then else)
+ (up tree (loop else
+ (loop then
+ (loop test (down tree result))))))
+ ((<application> proc args)
+ (up tree (loop (cons proc args) (down tree result))))
+ ((<sequence> exps)
+ (up tree (loop exps (down tree result))))
+ ((<lambda> body)
+ (up tree (loop body (down tree result))))
+ ((<let> vals body)
+ (up tree (loop body
+ (loop vals
+ (down tree result)))))
+ ((<letrec> vals body)
+ (up tree (loop body
+ (loop vals
+ (down tree result)))))
+ ((<let-values> body)
+ (up tree (loop body (down tree result))))
+ (else
+ (leaf tree result))))))
+
(define (post-order! f x)
(let lp ((x x))
(record-case x
diff --git a/module/language/tree-il/analyze.scm
b/module/language/tree-il/analyze.scm
index 4ed796c..1b39b2d 100644
--- a/module/language/tree-il/analyze.scm
+++ b/module/language/tree-il/analyze.scm
@@ -20,9 +20,12 @@
(define-module (language tree-il analyze)
#:use-module (srfi srfi-1)
+ #:use-module (srfi srfi-9)
#:use-module (system base syntax)
+ #:use-module (system base message)
#:use-module (language tree-il)
- #:export (analyze-lexicals))
+ #:export (analyze-lexicals
+ report-unused-variables))
;; Allocation is the process of assigning storage locations for lexical
;; variables. A lexical variable has a distinct "address", or storage
@@ -308,3 +311,127 @@
(allocate! x #f 0)
allocation)
+
+
+;;;
+;;; Unused variable analysis.
+;;;
+
+;; <binding-info> records are used during tree traversals in
+;; `report-unused-variables'. They contain a list of the local vars
+;; currently in scope, a list of locals vars that have been referenced, and a
+;; "location stack" (the stack of `tree-il-src' values for each parent tree).
+(define-record-type <binding-info>
+ (make-binding-info vars refs locs)
+ binding-info?
+ (vars binding-info-vars) ;; ((GENSYM NAME LOCATION) ...)
+ (refs binding-info-refs) ;; (GENSYM ...)
+ (locs binding-info-locs)) ;; (LOCATION ...)
+
+(define (report-unused-variables tree)
+ "Report about unused variables in TREE. Return TREE."
+
+ (define (dotless-list lst)
+ ;; If LST is a dotted list, return a proper list equal to LST except that
+ ;; the very last element is a pair; otherwise return LST.
+ (let loop ((lst lst)
+ (result '()))
+ (cond ((null? lst)
+ (reverse result))
+ ((pair? lst)
+ (loop (cdr lst) (cons (car lst) result)))
+ (else
+ (loop '() (cons lst result))))))
+
+ (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> vars names)
+ (let ((vars (dotless-list vars))
+ (names (dotless-list names)))
+ (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)))
+ ((<let-values> 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? 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> vars)
+ (let ((vars (dotless-list 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)))
+ ((<let-values> vars)
+ (make-binding-info (shrink vars refs) refs
+ (cdr locs)))
+ (else info))))
+ (make-binding-info '() '() '())
+ tree)
+ tree)
diff --git a/module/language/tree-il/compile-glil.scm
b/module/language/tree-il/compile-glil.scm
index f1d86e3..bf46997 100644
--- a/module/language/tree-il/compile-glil.scm
+++ b/module/language/tree-il/compile-glil.scm
@@ -21,6 +21,7 @@
(define-module (language tree-il compile-glil)
#:use-module (system base syntax)
#:use-module (system base pmatch)
+ #:use-module (system base message)
#:use-module (ice-9 receive)
#:use-module (language glil)
#:use-module (system vm instruction)
@@ -44,10 +45,25 @@
(define *comp-module* (make-fluid))
+(define %warning-passes
+ `((unused-variable . ,report-unused-variables)))
+
(define (compile-glil x e opts)
+ (define warnings
+ (or (and=> (memq #:warnings opts) cadr)
+ '()))
+
(let* ((x (make-lambda (tree-il-src x) '() '() '() x))
(x (optimize! x e opts))
(allocation (analyze-lexicals x)))
+
+ ;; Go throught the warning passes.
+ (for-each (lambda (kind)
+ (let ((warn (assoc-ref %warning-passes kind)))
+ (and (procedure? warn)
+ (warn x))))
+ warnings)
+
(with-fluid* *comp-module* (or (and e (car e)) (current-module))
(lambda ()
(values (flatten-lambda x allocation)
diff --git a/module/scripts/compile.scm b/module/scripts/compile.scm
index 311e35b..89d35bc 100644
--- a/module/scripts/compile.scm
+++ b/module/scripts/compile.scm
@@ -30,9 +30,11 @@
(define-module (scripts compile)
#:use-module ((system base compile) #:select (compile-file))
+ #:use-module (system base message)
#:use-module (srfi srfi-1)
#:use-module (srfi srfi-13)
#:use-module (srfi srfi-37)
+ #:use-module (ice-9 format)
#:export (compile))
@@ -58,6 +60,17 @@
(fail "`-o' option cannot be specified more than once")
(alist-cons 'output-file arg result))))
+ (option '(#\W "warn") #t #f
+ (lambda (opt name arg result)
+ (if (string=? arg "help")
+ (begin
+ (show-warning-help)
+ (exit 0))
+ (let ((warnings (assoc-ref result 'warnings)))
+ (alist-cons 'warnings
+ (cons (string->symbol arg) warnings)
+ (alist-delete 'warnings result))))))
+
(option '(#\O "optimize") #f #f
(lambda (opt name arg result)
(alist-cons 'optimize? #t result)))
@@ -86,13 +99,27 @@ options."
;; default option values
'((input-files)
- (load-path))))
+ (load-path)
+ (warnings unsupported-warning))))
+
+(define (show-warning-help)
+ (format #t "The available warning types are:~%~%")
+ (for-each (lambda (wt)
+ (format #t " ~22A ~A~%"
+ (format #f "`~A'" (warning-type-name wt))
+ (warning-type-description wt)))
+ %warning-types)
+ (format #t "~%"))
(define (compile . args)
(let* ((options (parse-args args))
(help? (assoc-ref options 'help?))
- (compile-opts (if (assoc-ref options 'optimize?) '(#:O) '()))
+ (compile-opts (let ((o `(#:warnings
+ ,(assoc-ref options 'warnings))))
+ (if (assoc-ref options 'optimize?)
+ (cons #:O o)
+ o)))
(from (or (assoc-ref options 'from) 'scheme))
(to (or (assoc-ref options 'to) 'objcode))
(input-files (assoc-ref options 'input-files))
@@ -108,6 +135,9 @@ Compile each Guile source file FILE into a Guile object.
-L, --load-path=DIR add DIR to the front of the module load path
-o, --output=OFILE write output to OFILE
+ -W, --warn=WARNING emit warnings of type WARNING; use `--warn=help'
+ for a list of available warnings
+
-f, --from=LANG specify a source language other than `scheme'
-t, --to=LANG specify a target language other than `objcode'
diff --git a/module/system/base/compile.scm b/module/system/base/compile.scm
index 7e26609..8470f39 100644
--- a/module/system/base/compile.scm
+++ b/module/system/base/compile.scm
@@ -21,6 +21,7 @@
(define-module (system base compile)
#:use-module (system base syntax)
#:use-module (system base language)
+ #:use-module (system base message)
#:use-module (system vm vm) ;; FIXME: there's a reason for this, can't
remember why tho
#:use-module (ice-9 regex)
#:use-module (ice-9 optargs)
@@ -213,6 +214,16 @@
(from (current-language))
(to 'value)
(opts '()))
+
+ (let ((warnings (memq #:warnings opts)))
+ (if (pair? warnings)
+ (let ((warnings (cadr warnings)))
+ ;; Sanity-check the requested warnings.
+ (for-each (lambda (w)
+ (or (lookup-warning-type w)
+ (warning 'unsupported-warning #f w)))
+ warnings))))
+
(receive (exp env cenv)
(compile-fold (compile-passes from to opts) x env opts)
exp))
diff --git a/module/system/base/message.scm b/module/system/base/message.scm
new file mode 100644
index 0000000..6b68c56
--- /dev/null
+++ b/module/system/base/message.scm
@@ -0,0 +1,102 @@
+;;; User interface messages
+
+;; Copyright (C) 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
+;;; License as published by the Free Software Foundation; either
+;;; version 3 of the License, or (at your option) any later version.
+;;;
+;;; This library is distributed in the hope that it will be useful,
+;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
+;;; Lesser General Public License for more details.
+;;;
+;;; You should have received a copy of the GNU Lesser General Public
+;;; License along with this library; if not, write to the Free Software
+;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301
USA
+
+;;; Commentary:
+;;;
+;;; This module provide a simple interface to send messages to the user.
+;;; TODO: Internationalize messages.
+;;;
+;;; Code:
+
+(define-module (system base message)
+ #:use-module (srfi srfi-1)
+ #:use-module (srfi srfi-9)
+ #:export (*current-warning-port* warning
+
+ warning-type? warning-type-name warning-type-description
+ warning-type-printer lookup-warning-type
+
+ %warning-types))
+
+
+;;;
+;;; Source location
+;;;
+
+(define (location-string loc)
+ (if (pair? loc)
+ (format #f "~a:~a:~a"
+ (or (assoc-ref loc 'filename) "<stdin>")
+ (1+ (assoc-ref loc 'line))
+ (assoc-ref loc 'column))
+ "<unknown-location>"))
+
+
+;;;
+;;; Warnings
+;;;
+
+(define *current-warning-port*
+ ;; The port where warnings are sent.
+ (make-fluid))
+
+(fluid-set! *current-warning-port* (current-error-port))
+
+(define-record-type <warning-type>
+ (make-warning-type name description printer)
+ warning-type?
+ (name warning-type-name)
+ (description warning-type-description)
+ (printer warning-type-printer))
+
+(define %warning-types
+ ;; List of know warning types.
+ (map (lambda (args)
+ (apply make-warning-type args))
+
+ `((unsupported-warning ;; a "meta warning"
+ "warn about unknown warning types"
+ ,(lambda (port unused name)
+ (format port "warning: unknown warning type `~A'~%"
+ name)))
+
+ (unused-variable
+ "report unused variables"
+ ,(lambda (port loc name)
+ (format port "~A: warning: unused variable `~A'~%"
+ loc name))))))
+
+(define (lookup-warning-type name)
+ "Return the warning type NAME or `#f' if not found."
+ (find (lambda (wt)
+ (eq? name (warning-type-name wt)))
+ %warning-types))
+
+(define (warning type location . args)
+ "Emit a warning of type TYPE for source location LOCATION (a source
+property alist) using the data in ARGS."
+ (let ((wt (lookup-warning-type type))
+ (port (fluid-ref *current-warning-port*)))
+ (if (warning-type? wt)
+ (apply (warning-type-printer wt)
+ port (location-string location)
+ args)
+ (format port "~A: unknown warning type `~A': ~A~%"
+ (location-string location) type args))))
+
+;;; message.scm ends here
diff --git a/test-suite/tests/tree-il.test b/test-suite/tests/tree-il.test
index 6634dcd..896206b 100644
--- a/test-suite/tests/tree-il.test
+++ b/test-suite/tests/tree-il.test
@@ -21,8 +21,10 @@
#:use-module (test-suite lib)
#:use-module (system base compile)
#:use-module (system base pmatch)
+ #:use-module (system base message)
#:use-module (language tree-il)
- #:use-module (language glil))
+ #:use-module (language glil)
+ #:use-module (srfi srfi-13))
;; 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
@@ -467,3 +469,116 @@
(toplevel ref bar) (call call/cc 1)
(call goto/args 1))))
+
+(with-test-prefix "tree-il-fold"
+
+ (pass-if "empty tree"
+ (let ((leaf? #f) (up? #f) (down? #f) (mark (list 'mark)))
+ (and (eq? mark
+ (tree-il-fold (lambda (x y) (set! leaf? #t) y)
+ (lambda (x y) (set! down? #t) y)
+ (lambda (x y) (set! up? #t) y)
+ mark
+ '()))
+ (not leaf?)
+ (not up?)
+ (not down?))))
+
+ (pass-if "lambda and application"
+ (let* ((leaves '()) (ups '()) (downs '())
+ (result (tree-il-fold (lambda (x y)
+ (set! leaves (cons x leaves))
+ (1+ y))
+ (lambda (x y)
+ (set! downs (cons x downs))
+ (1+ y))
+ (lambda (x y)
+ (set! ups (cons x ups))
+ (1+ y))
+ 0
+ (parse-tree-il
+ '(lambda (x y) (x1 y1)
+ (apply (toplevel +)
+ (lexical x x1)
+ (lexical y y1)))))))
+ (and (equal? (map strip-source leaves)
+ (list (make-lexical-ref #f 'y 'y1)
+ (make-lexical-ref #f 'x 'x1)
+ (make-toplevel-ref #f '+)))
+ (= (length downs) 2)
+ (equal? (reverse (map strip-source ups))
+ (map strip-source downs))))))
+
+
+;;;
+;;; Warnings.
+;;;
+
+;; Make sure we get English messages.
+(setlocale LC_ALL "C")
+
+(define (call-with-warnings thunk)
+ (let ((port (open-output-string)))
+ (with-fluid* *current-warning-port* port
+ thunk)
+ (let ((warnings (get-output-string port)))
+ (string-tokenize warnings
+ (char-set-complement (char-set #\newline))))))
+
+(define %opts-w-unused
+ '(#:warnings (unused-variable)))
+
+
+(with-test-prefix "warnings"
+
+ (pass-if "unknown warning type"
+ (let ((w (call-with-warnings
+ (lambda ()
+ (compile #t #:opts '(#:warnings (does-not-exist)))))))
+ (and (= (length w) 1)
+ (number? (string-contains (car w) "unknown warning")))))
+
+ (with-test-prefix "unused-variable"
+
+ (pass-if "quiet"
+ (null? (call-with-warnings
+ (lambda ()
+ (compile '(lambda (x y) (+ x y))
+ #:opts %opts-w-unused)))))
+
+ (pass-if "let/unused"
+ (let ((w (call-with-warnings
+ (lambda ()
+ (compile '(lambda (x)
+ (let ((y (+ x 2)))
+ x))
+ #:opts %opts-w-unused)))))
+ (and (= (length w) 1)
+ (number? (string-contains (car w) "unused variable `y'")))))
+
+ (pass-if "shadowed variable"
+ (let ((w (call-with-warnings
+ (lambda ()
+ (compile '(lambda (x)
+ (let ((y x))
+ (let ((y (+ x 2)))
+ (+ x y))))
+ #:opts %opts-w-unused)))))
+ (and (= (length w) 1)
+ (number? (string-contains (car w) "unused variable `y'")))))
+
+ (pass-if "letrec"
+ (null? (call-with-warnings
+ (lambda ()
+ (compile '(lambda ()
+ (letrec ((x (lambda () (y)))
+ (y (lambda () (x))))
+ y))
+ #:opts %opts-w-unused)))))
+
+ (pass-if "unused argument"
+ ;; Unused arguments should not be reported.
+ (null? (call-with-warnings
+ (lambda ()
+ (compile '(lambda (x y z) #t)
+ #:opts %opts-w-unused)))))))
hooks/post-receive
--
GNU Guile
| [Prev in Thread] |
Current Thread |
[Next in Thread] |
- [Guile-commits] GNU Guile branch, master, updated. release_1-9-1-21-g4b85637,
Ludovic Courtès <=