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)
