bug#67412: [PATCH 2/2] r7rs-libraries: Better support R7RS SRFI library names.

[Maxim Cournoyer <maxim.cournoyer@gmail.com>]

* module/ice-9/r6rs-libraries.scm (resolve-r6rs-interface)
(library): Move R7RS specifics to...
* module/ice-9/r7rs-libraries.scm (define-library): ... here.
<r7rs-name->r6rs-name, r7rs-import->r6rs-import>: New nested procedures,
used to translate the library name and import sets.
* test-suite/tests/rnrs-libraries.test ("import features"): Add a test.

Fixes: https://bugs.gnu.org/67412
---

 module/ice-9/r6rs-libraries.scm | 25 +++--------------
 module/ice-9/r7rs-libraries.scm | 48 +++++++++++++++++++++++++++++++--
 2 files changed, 50 insertions(+), 23 deletions(-)

diff --git a/module/ice-9/r6rs-libraries.scm b/module/ice-9/r6rs-libraries.scm
index f27b07841..78b3dfcfb 100644
--- a/module/ice-9/r6rs-libraries.scm
+++ b/module/ice-9/r6rs-libraries.scm
@@ -27,11 +27,6 @@
   (define (sym? stx)
     (symbol? (syntax->datum stx)))
 
-  (define (n? stx)
-    (let ((n (syntax->datum stx)))
-      (and (exact-integer? n)
-           (not (negative? n)))))
-
   (define (colon-n? x)
     (let ((sym (syntax->datum x)))
       (and (symbol? sym)
@@ -45,8 +40,7 @@
     (syntax-case stx (srfi)
       ((srfi n rest ...)
        (and (and-map sym? #'(rest ...))
-            (or (n? #'n)
-                (colon-n? #'n))))
+            (colon-n? #'n)))
       (_ #f)))
 
   (define (module-name? stx)
@@ -63,9 +57,7 @@
       (string-append
        "srfi-"
        (let ((n (syntax->datum n)))
-         (if (symbol? n)
-             (substring (symbol->string n) 1)
-             (number->string n)))))))
+         (substring (symbol->string n) 1))))))
 
   (define (make-custom-interface mod)
     (let ((iface (make-module)))
@@ -86,7 +78,6 @@
 
   (syntax-case import-spec (library only except prefix rename srfi)
     ;; (srfi :n ...) -> (srfi srfi-n ...)
-    ;; (srfi n ...) -> (srfi srfi-n ...)
     ((library (srfi n rest ... (version ...)))
      (srfi-name? #'(srfi n rest ...))
      (let ((srfi-n (make-srfi-n #'srfi #'n)))
@@ -196,11 +187,6 @@
     (define (sym? stx)
       (symbol? (syntax->datum stx)))
 
-    (define (n? stx)
-      (let ((n (syntax->datum stx)))
-        (and (exact-integer? n)
-             (not (negative? n)))))
-
     (define (colon-n? x)
       (let ((sym (syntax->datum x)))
         (and (symbol? sym)
@@ -214,8 +200,7 @@
       (syntax-case stx (srfi)
         ((srfi n rest ...)
          (and (and-map sym? #'(rest ...))
-              (or (n? #'n)
-                  (colon-n? #'n))))
+              (colon-n? #'n)))
         (_ #f)))
 
     (define (module-name? stx)
@@ -232,9 +217,7 @@
         (string-append
          "srfi-"
          (let ((n (syntax->datum n)))
-           (if (symbol? n)
-               (substring (symbol->string n) 1)
-               (number->string n)))))))
+           (substring (symbol->string n) 1))))))
 
     (define (compute-exports ifaces specs)
       (define (re-export? sym)
diff --git a/module/ice-9/r7rs-libraries.scm b/module/ice-9/r7rs-libraries.scm
index f8b6b4c59..f2692b833 100644
--- a/module/ice-9/r7rs-libraries.scm
+++ b/module/ice-9/r7rs-libraries.scm
@@ -102,12 +102,56 @@
         ((rename internal external) #'(rename (internal external)))
         (_ export)))
 
+    (define (r7rs-name->r6rs-name name)
+      ;; This is a hack to support (srfi N x ...) modules in R7RS.  The
+      ;; longer term solution would be to add support at the level of
+      ;; resolve-interface (bug #40371).
+      (define (n? stx)
+        (let ((n (syntax->datum stx)))
+          (and (exact-integer? n)
+               (not (negative? n)))))
+
+      (define (srfi-name? stx)
+        (syntax-case stx (srfi)
+          ((srfi n rest ...)
+           (n? #'n))
+          (_ #f)))
+
+      (define (make-srfi-n context n)
+        (datum->syntax
+         context
+         (string->symbol
+          (string-append
+           "srfi-"
+           (let ((n (syntax->datum n)))
+             (number->string n))))))
+
+      (syntax-case name (srfi)
+        ;; (srfi n ...) -> (srfi srfi-n ...)
+        ((srfi n rest ...) (srfi-name? #'(srfi n rest ...))
+         #`(srfi #,(make-srfi-n #'srfi #'n) rest ...))
+        (_ name)))
+
+    (define (r7rs-import->r6rs-import import-set)
+      ;; Normalize SRFI names.
+      (syntax-case import-set (only except prefix rename)
+        ((only import-set identifier ...)
+         #`(only #,(r7rs-import->r6rs-import #'import-set) identifier ...))
+        ((except import-set identifier ...)
+         #`(except #,(r7rs-import->r6rs-import #'import-set) identifier ...))
+        ((prefix import-set identifier ...)
+         #`(prefix #,(r7rs-import->r6rs-import #'import-set) identifier ...))
+        ((rename import-set (from-identifier to-identifier) ...)
+         #`(rename #,(r7rs-import->r6rs-import #'import-set)
+                   (from-identifier to-identifier) ...))
+        (_ (r7rs-name->r6rs-name import-set))))
+
     (syntax-case stx ()
       ((_ name decl ...)
        (call-with-values (lambda ()
                            (partition-decls #'(decl ...) '() '() '()))
          (lambda (exports imports code)
-           #`(library name
+           #`(library #,(r7rs-name->r6rs-name #'name)
                (export . #,(map r7rs-export->r6rs-export exports))
-               (import . #,imports)
+               (import . #,(map r7rs-import->r6rs-import imports))
                . #,code)))))))
-- 
2.41.0