~ chicken-core (chicken-5) 405f6319f005ad8a411c75e3038cfbaec1fe4d03
commit 405f6319f005ad8a411c75e3038cfbaec1fe4d03
Author: megane <meganeka@gmail.com>
AuthorDate: Fri Apr 9 17:04:52 2021 +0300
Commit: megane <meganeka@gmail.com>
CommitDate: Thu Apr 22 13:09:33 2021 +0300
Report more information for unresolved identifiers in modules
The new format gives more clues to resolve unresolved identifiers
warnings. Especially compare the messages for 'last' below.
Given this input:
(module
mod () (import scheme)
(define-syntax mac
(ir-macro-transformer
(lambda (e i c)
`(last))))
(define (foo)
(+ bar)
(lambda ()
(mac)
(+ baz))
(+ fx+)
(lambda ()
(+ baz)
(mac)))
(define (quux)
(+ fx+))
)
Signed-off-by: Evan Hanson <evhan@foldling.org>
diff --git a/core.scm b/core.scm
index e548bbc0..041bfe19 100644
--- a/core.scm
+++ b/core.scm
@@ -567,7 +567,7 @@
(cadr x)
x) )
- (define (resolve-variable x0 e dest ldest h)
+ (define (resolve-variable x0 e dest ldest h outer-ln)
(when (memq x0 unlikely-variables)
(warning
(sprintf "reference to variable `~s' possibly unintended" x0) ))
@@ -598,7 +598,7 @@
(finish-foreign-result ft body)
t)
e dest ldest h #f #f))))
- ((not (memq x e)) (##sys#alias-global-hook x #f h)) ; only if global
+ ((not (memq x e)) (##sys#alias-global-hook x #f (cons h outer-ln))) ; only if global
((assq x forbidden-refs) =>
(lambda (a)
(let ((ln (cdr a)))
@@ -633,7 +633,7 @@
(define (walk x e dest ldest h outer-ln tl?)
(cond ((keyword? x) `(quote ,x))
- ((symbol? x) (resolve-variable x e dest ldest h))
+ ((symbol? x) (resolve-variable x e dest ldest h outer-ln))
((not (pair? x))
(if (constant? x)
`(quote ,x)
@@ -684,9 +684,9 @@
,(walk (cadddr x) e dest ldest h ln tl?)))
((##core#local-specialization)
- (let* ((name (resolve-variable (cadr x) e dest ldest h))
+ (let* ((name (resolve-variable (cadr x) e dest ldest h outer-ln))
(raw-alias (caddr x))
- (resolved-alias (resolve-variable raw-alias e dest ldest h))
+ (resolved-alias (resolve-variable raw-alias e dest ldest h outer-ln))
(specs (##sys#get name '##compiler#local-specializations '())))
(letrec ((resolve-alias (lambda (form)
(cond ((pair? form) (cons (resolve-alias (car form)) (resolve-alias (cdr form))))
@@ -800,8 +800,7 @@
((##core#with-forbidden-refs)
(let* ((loc (caddr x))
(vars (map (lambda (v)
- (cons (resolve-variable v e dest
- ldest h)
+ (cons (resolve-variable v e dest ldest h outer-ln)
loc))
(cadr x))))
(fluid-let ((forbidden-refs
diff --git a/modules.scm b/modules.scm
index 4f9b507b..0ba1df49 100644
--- a/modules.scm
+++ b/modules.scm
@@ -42,7 +42,9 @@
chicken.internal
chicken.keyword
chicken.platform
- chicken.syntax)
+ chicken.syntax
+ (only chicken.string string-split)
+ (only chicken.format fprintf format))
(include "common-declarations.scm")
(include "mini-srfi-1.scm")
@@ -460,6 +462,63 @@
;; invalid-export: Returns a string if given identifier names a
;; non-exportable object. The string names the type (e.g. "an
;; inline function"). Returns #f otherwise.
+
+ ;; Given a list of (<identifier> . <source-location>), builds a nicely
+ ;; formatted error message with suggestions where possible.
+ (define (report-unresolved-identifiers unknowns)
+ (let ((out (open-output-string)))
+ (fprintf out "Module `~a' has unresolved identifiers" (module-name mod))
+
+ ;; Print filename from a line number entry
+ (let lp ((locs (apply append (map cdr unknowns))))
+ (unless (null? locs)
+ (or (and-let* ((loc (car locs))
+ (ln (and (pair? loc) (cdr loc)))
+ (ss (string-split ln ":"))
+ ((= 2 (length ss))))
+ (fprintf out "\n In file `~a':" (car ss))
+ #t)
+ (lp (cdr locs)))))
+
+ (for-each
+ (lambda (id.locs)
+ (fprintf out "\n\n Unknown identifier `~a'" (car id.locs))
+
+ ;; Print all source locations where this ID occurs
+ (for-each
+ (lambda (loc)
+ (define (ln->num ln) (let ((ss (string-split ln ":")))
+ (if (and (pair? ss) (= 2 (length ss)))
+ (cadr ss)
+ ln)))
+ (and-let* ((loc-s
+ (cond
+ ((and (pair? loc) (car loc) (cdr loc)) =>
+ (lambda (ln)
+ (format "In procedure `~a' on line ~a" (car loc) (ln->num ln))))
+ ((and (pair? loc) (cdr loc))
+ (format "On line ~a" (ln->num (cdr loc))))
+ (else (format "In procedure `~a'" loc)))))
+ (fprintf out "\n ~a" loc-s)))
+ (reverse (cdr id.locs)))
+
+ ;; Print suggestions from identifier db
+ (and-let* ((id (car id.locs))
+ (a (getp id '##core#db)))
+ (fprintf out "\n Suggestion: try importing ")
+ (cond
+ ((= 1 (length a))
+ (fprintf out "module `~a'" (cadar a)))
+ (else
+ (fprintf out "one of these modules:")
+ (for-each
+ (lambda (a)
+ (fprintf out "\n ~a" (cadr a)))
+ a)))))
+ unknowns)
+
+ (##sys#error (get-output-string out))))
+
(let* ((explist (module-export-list mod))
(name (module-name mod))
(dlist (module-defined-list mod))
@@ -511,38 +570,16 @@
" has not been defined.")))
(else (bomb "fail")))))))
(loop (cdr xl))))))))))
- (for-each
- (lambda (u)
- (let* ((where (cdr u))
- (u (car u)))
- (unless (memq u elist)
- (let ((out (open-output-string)))
- (set! missing #t)
- (display "reference to possibly unbound identifier `" out)
- (display u out)
- (write-char #\' out)
- (when (pair? where)
- (display " in:" out)
- (for-each
- (lambda (sym)
- (display "\nWarning: " out)
- (display sym out))
- where))
- (and-let* ((a (getp u '##core#db)))
- (cond ((= 1 (length a))
- (display "\nWarning: suggesting: `(import " out)
- (display (cadar a) out)
- (display ")'" out))
- (else
- (display "\nWarning: suggesting one of:" out)
- (for-each
- (lambda (a)
- (display "\nWarning: (import " out)
- (display (cadr a) out)
- (write-char #\) out))
- a))))
- (##sys#warn (get-output-string out))))))
- (reverse (module-undefined-list mod)))
+
+ ;; Check all identifiers were resolved
+ (let ((unknowns '()))
+ (for-each (lambda (u)
+ (unless (memq (car u) elist)
+ (set! unknowns (cons u unknowns))))
+ (module-undefined-list mod))
+ (unless (null? unknowns)
+ (report-unresolved-identifiers unknowns)))
+
(when missing
(##sys#error "module unresolved" name))
(let* ((iexports
Trap