diff options
-rw-r--r-- | module/language/tree-il/analyze.scm | 100 | ||||
-rw-r--r-- | module/language/tree-il/compile-glil.scm | 3 | ||||
-rw-r--r-- | module/system/base/message.scm | 6 | ||||
-rw-r--r-- | test-suite/tests/tree-il.test | 65 |
4 files changed, 171 insertions, 3 deletions
diff --git a/module/language/tree-il/analyze.scm b/module/language/tree-il/analyze.scm index 50a0fb80b..74d41f2a7 100644 --- a/module/language/tree-il/analyze.scm +++ b/module/language/tree-il/analyze.scm @@ -24,8 +24,11 @@ #:use-module (system base syntax) #:use-module (system base message) #:use-module (language tree-il) + #:use-module ((system base compile) + #:select (current-compilation-environment)) #:export (analyze-lexicals - report-unused-variables)) + report-unused-variables + report-possibly-unbound-variables)) ;; Allocation is the process of assigning storage locations for lexical ;; variables. A lexical variable has a distinct "address", or storage @@ -615,3 +618,98 @@ (make-binding-info '() '() '()) tree) tree) + + +;;; +;;; Unbound variable analysis. +;;; + +;; <toplevel-info> records are used during tree traversal in search of +;; possibly unbound variable. They contain a list of references to +;; potentially unbound top-level variables, a list of the top-level defines +;; that have been encountered, and a "location stack" (see above). +(define-record-type <toplevel-info> + (make-toplevel-info refs defs locs) + toplevel-info? + (refs toplevel-info-refs) ;; ((VARIABLE-NAME . LOCATION) ...) + (defs toplevel-info-defs) ;; (VARIABLE-NAME ...) + (locs toplevel-info-locs)) ;; (LOCATION ...) + +(define (env-module e) + "Return the module corresponding to E." + ;; XXX: This is a bit of a hack since since representation of compile-time + ;; environments is hidden in `(language scheme compile-tree-il)'. + (cond ((pair? e) (car e)) + ((module? e) e) + (else (current-compilation-environment)))) + +;; 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 + (let ((env (env-module env))) + (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)) + (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) diff --git a/module/language/tree-il/compile-glil.scm b/module/language/tree-il/compile-glil.scm index a78eaa6ce..e8b699eb5 100644 --- a/module/language/tree-il/compile-glil.scm +++ b/module/language/tree-il/compile-glil.scm @@ -46,7 +46,8 @@ (define *comp-module* (make-fluid)) (define %warning-passes - `((unused-variable . ,report-unused-variables))) + `((unused-variable . ,report-unused-variables) + (unbound-variable . ,report-possibly-unbound-variables))) (define (compile-glil x e opts) (define warnings diff --git a/module/system/base/message.scm b/module/system/base/message.scm index 6b68c5639..48a00b80a 100644 --- a/module/system/base/message.scm +++ b/module/system/base/message.scm @@ -79,6 +79,12 @@ "report unused variables" ,(lambda (port loc name) (format port "~A: warning: unused variable `~A'~%" + loc name))) + + (unbound-variable + "report possibly unbound variables" + ,(lambda (port loc name) + (format port "~A: warning: possibly unbound variable `~A'~%" loc name)))))) (define (lookup-warning-type name) diff --git a/test-suite/tests/tree-il.test b/test-suite/tests/tree-il.test index ee5e4d352..ffc178571 100644 --- a/test-suite/tests/tree-il.test +++ b/test-suite/tests/tree-il.test @@ -26,6 +26,9 @@ #: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. @@ -535,6 +538,8 @@ (define %opts-w-unused '(#:warnings (unused-variable))) +(define %opts-w-unbound + '(#:warnings (unbound-variable))) (with-test-prefix "warnings" @@ -588,4 +593,62 @@ (null? (call-with-warnings (lambda () (compile '(lambda (x y z) #t) - #:opts %opts-w-unused))))))) + #:opts %opts-w-unused)))))) + + (with-test-prefix "unbound variable" + + (pass-if "quiet" + (null? (call-with-warnings + (lambda () + (compile '+ #:opts %opts-w-unbound))))) + + (pass-if "ref" + (let* ((v (gensym)) + (w (call-with-warnings + (lambda () + (compile v + #:to 'assembly + #:opts %opts-w-unbound))))) + (and (= (length w) 1) + (number? (string-contains (car w) + (format #f "unbound variable `~A'" + v)))))) + + (pass-if "set!" + (let* ((v (gensym)) + (w (call-with-warnings + (lambda () + (compile `(set! ,v 7) + #:to 'assembly + #:opts %opts-w-unbound))))) + (and (= (length w) 1) + (number? (string-contains (car w) + (format #f "unbound variable `~A'" + v)))))) + + (pass-if "module-local top-level is visible" + (let ((m (make-module)) + (v (gensym))) + (beautify-user-module! m) + (compile `(define ,v 123) + #:env m #:opts %opts-w-unbound) + (null? (call-with-warnings + (lambda () + (compile v + #:env m + #:to 'assembly + #:opts %opts-w-unbound)))))) + + (pass-if "module-local top-level is visible after" + (let ((m (make-module)) + (v (gensym))) + (beautify-user-module! m) + (null? (call-with-warnings + (lambda () + (let ((in (open-input-string + "(define (f) + (set! chbouib 3)) + (define chbouib 5)"))) + (read-and-compile in + #:env m + #:opts %opts-w-unbound))))))))) |