Cool, here is a signed off copy. But, I made some small changes, so if you
or another hacker could have a look just to make sure you're OK with it?

I fixed two places where the `resolve-variable` procedure didn't have the new
`outer-ln` argument passed through, and one typo in a string (changed "in2" to
"in"). These are pretty small tweaks, and necessary.

But, I also capitalised the output messages to match the style in
scrutinizer.scm and it now looks like the below when suggesting things, these
are stylistic changes so I didn't want to push them directly, someone else can
have a look and do that:

    Error: Module `mod' has unresolved identifiers
      In file `test.scm':
    
      Unknown identifier `bar'
        In procedure `foo' on line 10
      Suggestion: try importing module `lexgen'
    
      Unknown identifier `last'
        On line 12
        On line 17
      Suggestion: try importing module `srfi-1'
    
      Unknown identifier `baz'
        On line 13
        On line 16
    
      Unknown identifier `string-index'
        In procedure `foo' on line 14
        In procedure `quux' on line 20
      Suggestion: try importing one of these modules:
        srfi-130
        srfi-152
        utf8-srfi-13
        srfi-13

Cheers,

Evan
>From e7db0e600e2331ce2031d4090cc20028422e9f06 Mon Sep 17 00:00:00 2001
From: megane <megan...@gmail.com>
Date: Fri, 9 Apr 2021 17:04:52 +0300
Subject: [PATCH] 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 <ev...@foldling.org>
---
 core.scm    |  13 +++----
 modules.scm | 108 ++++++++++++++++++++++++++++++++++------------------
 2 files changed, 78 insertions(+), 43 deletions(-)

diff --git a/core.scm b/core.scm
index cdfbefa2..8d459702 100644
--- a/core.scm
+++ b/core.scm
@@ -565,7 +565,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) ))
@@ -596,7 +596,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)))
@@ -631,7 +631,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)
@@ -682,9 +682,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))))
@@ -798,8 +798,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..cecd4f02 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")
@@ -456,10 +458,67 @@
 (define ##sys#finalize-module 
   (let ((display display)
        (write-char write-char))
+    ;; 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.
     (lambda (mod #!optional (invalid-export (lambda _ #f)))
-      ;; 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,15 @@
                                                        " 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 
-- 
2.29.3

Reply via email to