diff --git a/module/language/tree-il/analyze.scm b/module/language/tree-il/analyze.scm index 42ad74d7d..352462f44 100644 --- a/module/language/tree-il/analyze.scm +++ b/module/language/tree-il/analyze.scm @@ -633,6 +633,23 @@ (defs toplevel-info-defs) ;; (VARIABLE-NAME ...) (locs toplevel-info-locs)) ;; (LOCATION ...) +(define (goops-toplevel-definition proc args) + ;; If application of PROC to ARGS is a GOOPS top-level definition, return + ;; the name of the variable being defined; otherwise return #f. This + ;; assumes knowledge of the current implementation of `define-class' et al. + (record-case proc + (( mod public? name) + (and (equal? mod '(oop goops)) + (not public?) + (eq? name 'toplevel-define!) + (pair? args) (pair? (cdr args)) (null? (cddr args)) + (record-case (car args) + (( exp) + (and (symbol? exp) + exp)) + (else #f)))) + (else #f))) + ;; TODO: Combine with `report-unused-variables' so we don't traverse the tree ;; once for each warning type. @@ -682,6 +699,17 @@ (make-toplevel-info (alist-delete name refs eq?) (cons name defs) locs)) + + (( proc args) + ;; Check for a dynamic top-level definition, as is + ;; done by code expanded from GOOPS macros. + (let ((name (goops-toplevel-definition proc args))) + (if (symbol? name) + (make-toplevel-info (alist-delete name refs + eq?) + (cons name defs) + locs) + (make-toplevel-info refs defs locs)))) (else (make-toplevel-info refs defs locs))))) diff --git a/test-suite/tests/tree-il.test b/test-suite/tests/tree-il.test index ffc178571..90dde7d00 100644 --- a/test-suite/tests/tree-il.test +++ b/test-suite/tests/tree-il.test @@ -649,6 +649,21 @@ "(define (f) (set! chbouib 3)) (define chbouib 5)"))) + (read-and-compile in + #:env m + #:opts %opts-w-unbound))))))) + + (pass-if "GOOPS definitions are visible" + (let ((m (make-module)) + (v (gensym))) + (beautify-user-module! m) + (module-use! m (resolve-interface '(oop goops))) + (null? (call-with-warnings + (lambda () + (let ((in (open-input-string + "(define-class () + (bar #:getter foo-bar)) + (define z (foo-bar (make )))"))) (read-and-compile in #:env m #:opts %opts-w-unbound)))))))))