summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
-rw-r--r--module/language/tree-il/analyze.scm100
-rw-r--r--module/language/tree-il/compile-glil.scm3
-rw-r--r--module/system/base/message.scm6
-rw-r--r--test-suite/tests/tree-il.test65
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)))))))))