[Chicken-hackers] [PATCH] Print more information about why an identifier cannot be exported

[megane]

Hi,

Here's a small QOL improvement for the export checks.

>From fdd9d1af41ad8f08ce45849ec9704bc7e0b4328d Mon Sep 17 00:00:00 2001
From: megane <address@hidden>
Date: Thu, 10 Oct 2019 12:11:07 +0300
Subject: [PATCH] Print more information about why an identifier cannot be
 exported

After change:

Warning: Cannot export `a-type-alias' from module `mod', it refers to a type 
abbreviation.

Warning: Cannot export `an-inline' from module `mod', it refers to an inlined 
function.

Warning: Cannot export `a-constant' from module `mod', it refers to a constant.

Warning: Cannot export `a-foreign' from module `mod', it refers to a foreign 
variable.

Warning: In module `mod' exported identifier `a-undefined' has not been defined.

When trying to compile this:
(module
 mod
 (a-type-alias an-inline a-constant a-foreign a-undefined)
 (import scheme)
 (cond-expand
  (chicken-5 (import (chicken base) (chicken type)
                     (chicken foreign)))
  (else (import chicken)))

 (define-type a-type-alias fixnum)
 (define-inline (an-inline) 1)
 (define-constant a-constant 2)
 (define-foreign-variable a-foreign int)
 )
---
 core.scm    | 16 +++++++++++-----
 modules.scm | 42 +++++++++++++++++++++++++++---------------
 2 files changed, 38 insertions(+), 20 deletions(-)

diff --git a/core.scm b/core.scm
index b05a68b6..2e5a83b0 100644
--- a/core.scm
+++ b/core.scm
@@ -1038,13 +1038,19 @@
                                                       ;; avoid backtrace
                                                       (print-error-message ex 
(current-error-port))
                                                       (exit 1))
-                                                  (##sys#finalize-module 
+                                                  (##sys#finalize-module
                                                      (##sys#current-module)
                                                      (lambda (id)
-                                                       (and (not (assq id 
foreign-variables))
-                                                            (not 
(hash-table-ref inline-table id))
-                                                            (not 
(hash-table-ref constant-table id))
-                                                            (not (##sys#get id 
'##compiler#type-abbreviation))))))
+                                                      (cond
+                                                       ((assq id 
foreign-variables)
+                                                        "a foreign variable")
+                                                       ((hash-table-ref 
inline-table id)
+                                                        "an inlined function")
+                                                       ((hash-table-ref 
constant-table id)
+                                                        "a constant")
+                                                       ((##sys#get id 
'##compiler#type-abbreviation)
+                                                        "a type abbreviation")
+                                                       (else #f)))))
                                                 (let ((il (or (assq name 
import-libraries) all-import-libraries)))
                                                   (when il
                                                     (emit-import-lib name il)
diff --git a/modules.scm b/modules.scm
index 1501ab04..306e1bbb 100644
--- a/modules.scm
+++ b/modules.scm
@@ -446,8 +446,10 @@
 (define ##sys#finalize-module 
   (let ((display display)
        (write-char write-char))
-    (lambda (mod #!optional (check-export (lambda _ #t)))
-      ;; check-export: returns #f if given identifier names a non-exportable 
object
+    (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.
       (let* ((explist (module-export-list mod))
             (name (module-name mod))
             (dlist (module-defined-list mod))
@@ -478,21 +480,31 @@
                                     (if (and def (symbol? (cdr def))) 
                                         (cdr def)
                                         (let ((a (assq id 
(##sys#current-environment))))
-                                          (cond ((and a (symbol? (cdr a))) 
+                                         (define (fail msg)
+                                           (set! missing #t)
+                                           (##sys#warn msg)
+                                           #f)
+                                         (define (mod-string)
+                                           (string-append "module `" 
(symbol->string name) "'"))
+                                         (define (id-string)
+                                           (string-append "`" (symbol->string 
id) "'"))
+                                          (cond ((and a (symbol? (cdr a)))
                                                  (dm "reexporting: " id " -> " 
(cdr a))
-                                                 (cdr a)) 
+                                                 (cdr a))
+                                               (def (module-rename id name))
+                                               ((invalid-export id)
+                                                =>
+                                                (lambda (type)
+                                                  (fail (string-append
+                                                         "Cannot export " 
(id-string) " from "
+                                                         (mod-string) ", it 
refers to "
+                                                         type "."))))
                                                 ((not def)
-                                                 (set! missing #t)
-                                                 (##sys#warn
-                                                 (string-append
-                                                  "exported identifier of 
module `"
-                                                  (symbol->string name)
-                                                  (if (check-export id)
-                                                      "' has not been defined"
-                                                      "' does not refer to 
value or syntax binding"))
-                                                 id)
-                                                 #f)
-                                                (else (module-rename id 
name)))))))
+                                                (fail (string-append
+                                                       "In " (mod-string)
+                                                       " exported identifier " 
(id-string)
+                                                       " has not been 
defined.")))
+                                                (else (bomb "fail")))))))
                               (loop (cdr xl))))))))))
         (for-each
         (lambda (u)
-- 
2.17.1