Re: Reporting unused local variables

[Ludovic Courtès]

Hello Guilers!

Here's a third attempt.  This time, it's done as a separate pass at the
tree-il level *and* in a purely functional way.

I owe a great debt to a famous Scheme hacker whose paper /Applications
of fold to XML transformation/ was a invaluable source of
inspiration [0].  Thanks!  :-)

If we agree on this approach, I'll polish it up, make the pass optional
based on compilation options (disabled by default), and separate out the
UI-related things (messages, that is).

Thanks,
Ludo'.

[0] http://wingolog.org/archives/2007/07/11/fold-xml-presentations

    This one is not the "official" version with the ACM copyright, but
    it can easily be found on the Internet (and the content is
    essentially the same, I think.)

diff --git a/module/language/tree-il/analyze.scm 
b/module/language/tree-il/analyze.scm
index 4ed796c..1e97c49 100644
--- a/module/language/tree-il/analyze.scm
+++ b/module/language/tree-il/analyze.scm
@@ -307,4 +307,150 @@
   (analyze! x #f)
   (allocate! x #f 0)
 
+  (report-unused-variables x)
   allocation)
+
+(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 (make-binding-info vars refs) (vector vars refs))
+(define (binding-info-vars info)      (vector-ref info 0))
+(define (binding-info-refs info)      (vector-ref info 1))
+
+(define (report-unused-variables tree)
+  "Report about unused variables in TREE.  Return TREE."
+
+  (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>"))
+
+  (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)))
+                    (record-case x
+                      ((<lexical-ref> gensym)
+                       (make-binding-info vars (cons gensym refs)))
+                      (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))
+                        (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)))
+                      ((<lambda> vars names)
+                       (let ((vars  (dotless-list vars))
+                             (names (dotless-list names)))
+                         (make-binding-info (extend vars names) refs)))
+                      ((<let> vars names)
+                       (make-binding-info (extend vars names) refs))
+                      ((<letrec> vars names)
+                       (make-binding-info (extend vars names) refs))
+                      ((<let-values> vars names)
+                       (make-binding-info (extend vars names) refs))
+                      (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)))
+                    (define (shrink inner-vars refs)
+                      (for-each (lambda (var)
+                                  (let ((gensym (car var)))
+                                    (if (not (memq gensym refs))
+                                        (let ((name (cadr var))
+                                              (loc  (location-string (caddr 
var))))
+                                          (format (current-error-port)
+                                                  "~A: variable `~A' never 
referenced~%"
+                                                  loc name)))))
+                                (filter (lambda (var)
+                                          (memq (car var) inner-vars))
+                                        vars))
+                      (fold alist-delete vars inner-vars))
+
+                    ;; XXX: 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)))
+                      ((<let> vars)
+                       (make-binding-info (shrink vars refs) refs))
+                      ((<letrec> vars)
+                       (make-binding-info (shrink vars refs) refs))
+                      ((<let-values> vars)
+                       (make-binding-info (shrink vars refs) refs))
+                      (else info))))
+                (make-binding-info '() '())
+                tree)
+  tree)