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

* module/ice-9/r6rs-libraries.scm
(resolve-r6rs-interface <srfi-name?>: Relax symbol requirements.
Return a symbol.
<import-spec>: Add a new syntax matching clause to avoid stripping the
3rd identifier in a R7RS SRFI module name.
(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")
<"renaming works">: Extend test.
<"import works">: New test.

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

Changes in v2:
 - Leave/improve some R7RS SRFI handling in r6rs-libraries, for 'import'
 - New 'import' test

 module/ice-9/r6rs-libraries.scm      | 86 ++++++++--------------------
 module/ice-9/r7rs-libraries.scm      | 48 +++++++++++++++-
 test-suite/tests/rnrs-libraries.test | 12 +++-
 3 files changed, 81 insertions(+), 65 deletions(-)

diff --git a/module/ice-9/r6rs-libraries.scm b/module/ice-9/r6rs-libraries.scm
index f27b07841..f02b13516 100644
--- a/module/ice-9/r6rs-libraries.scm
+++ b/module/ice-9/r6rs-libraries.scm
@@ -44,9 +44,9 @@
   (define (srfi-name? stx)
     (syntax-case stx (srfi)
       ((srfi n rest ...)
-       (and (and-map sym? #'(rest ...))
-            (or (n? #'n)
-                (colon-n? #'n))))
+       (cond ((n? #'n) 'r7rs)
+             ((colon-n? #'n) 'r6rs)
+             (else #f)))
       (_ #f)))
 
   (define (module-name? stx)
@@ -85,10 +85,19 @@
               (module-and-uses mod)))
 
   (syntax-case import-spec (library only except prefix rename srfi)
-    ;; (srfi :n ...) -> (srfi srfi-n ...)
+    ;; XXX: This is R7RS-specific, but it's here since we want the
+    ;; `import' procedure below to accept (srfi 64) as well as
+    ;; (srfi :64).
+    ;;
     ;; (srfi n ...) -> (srfi srfi-n ...)
     ((library (srfi n rest ... (version ...)))
-     (srfi-name? #'(srfi n rest ...))
+     (eq? 'r7rs (srfi-name? #'(srfi n rest ...)))
+     (let ((srfi-n (make-srfi-n #'srfi #'n)))
+       (resolve-r6rs-interface
+        #`(library (srfi #,srfi-n rest ... (version ...))))))
+    ;; (srfi :n ...) -> (srfi srfi-n ...)
+    ((library (srfi n rest ... (version ...)))
+     (eq? 'r6rs (srfi-name? #'(srfi n rest ...)))
      (let ((srfi-n (make-srfi-n #'srfi #'n)))
        (resolve-r6rs-interface
         (syntax-case #'(rest ...) ()
@@ -98,7 +107,7 @@
            ;; SRFI 97 says that the first identifier after the `n'
            ;; is used for the libraries name, so it must be ignored.
            #`(library (srfi #,srfi-n rest ... (version ...))))))))
-    
+
     ((library (name name* ... (version ...)))
      (and-map sym? #'(name name* ...))
      (resolve-interface (syntax->datum #'(name name* ...))
@@ -107,7 +116,7 @@
     ((library (name name* ...))
      (and-map sym? #'(name name* ...))
      (resolve-r6rs-interface #'(library (name name* ... ()))))
-    
+
     ((only import-set identifier ...)
      (and-map sym? #'(identifier ...))
      (let* ((mod (resolve-r6rs-interface #'import-set))
@@ -121,7 +130,7 @@
                      (hashq-set! (module-replacements iface) sym #t)))
                  (syntax->datum #'(identifier ...)))
        iface))
-    
+
     ((except import-set identifier ...)
      (and-map sym? #'(identifier ...))
      (let* ((mod (resolve-r6rs-interface #'import-set))
@@ -182,7 +191,7 @@
              (module-remove! iface from)
              (hashq-remove! replacements from)
              (lp (cdr in) (cons (vector to replace? var) out))))))))
-    
+
     ((name name* ... (version ...))
      (module-name? #'(name name* ...))
      (resolve-r6rs-interface #'(library (name name* ... (version ...)))))
@@ -196,45 +205,11 @@
     (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)
-             (let ((str (symbol->string sym)))
-               (and (string-prefix? ":" str)
-                    (let ((num (string->number (substring str 1))))
-                      (and (exact-integer? num)
-                           (not (negative? num)))))))))
-
-    (define (srfi-name? stx)
-      (syntax-case stx (srfi)
-        ((srfi n rest ...)
-         (and (and-map sym? #'(rest ...))
-              (or (n? #'n)
-                  (colon-n? #'n))))
-        (_ #f)))
-
     (define (module-name? stx)
-      (or (srfi-name? stx)
-          (syntax-case stx ()
-            ((name name* ...)
-             (and-map sym? #'(name name* ...)))
-            (_ #f))))
-
-    (define (make-srfi-n context n)
-      (datum->syntax
-       context
-       (string->symbol
-        (string-append
-         "srfi-"
-         (let ((n (syntax->datum n)))
-           (if (symbol? n)
-               (substring (symbol->string n) 1)
-               (number->string n)))))))
+      (syntax-case stx ()
+        ((name name* ...)
+         (and-map sym? #'(name name* ...)))
+        (_ #f)))
 
     (define (compute-exports ifaces specs)
       (define (re-export? sym)
@@ -282,17 +257,6 @@
            (import ispec ...)
            body ...))
 
-      ((_ (srfi n rest ... (version ...))
-          (export espec ...)
-          (import ispec ...)
-          body ...)
-       (srfi-name? #'(srfi n rest ...))
-       (let ((srfi-n (make-srfi-n #'srfi #'n)))
-         #`(library (srfi #,srfi-n rest ... (version ...))
-             (export espec ...)
-             (import ispec ...)
-             body ...)))
-
       ((_ (name name* ... (version ...))
           (export espec ...)
           (import ispec ...)
@@ -328,7 +292,7 @@
                  (export! x ...)
                  (@@ @@ (name name* ...) body)
                  ...))))))))
-    
+
 (define-syntax import
   (lambda (stx)
     (define (strip-for import-set)
@@ -343,7 +307,7 @@
          #'(eval-when (expand load eval)
              (let ((iface (resolve-r6rs-interface 'library-reference)))
                (call-with-deferred-observers
-                 (lambda ()
-                   (module-use-interfaces! (current-module) (list iface)))))
+                (lambda ()
+                  (module-use-interfaces! (current-module) (list iface)))))
              ...
              (if #f #f)))))))
diff --git a/module/ice-9/r7rs-libraries.scm b/module/ice-9/r7rs-libraries.scm
index 429d82ad9..c6f70d73f 100644
--- a/module/ice-9/r7rs-libraries.scm
+++ b/module/ice-9/r7rs-libraries.scm
@@ -103,12 +103,56 @@
          #'(rename (from-identifier to-identifier)))
         (identifier #'identifier)))
 
+    (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)))))))
diff --git a/test-suite/tests/rnrs-libraries.test b/test-suite/tests/rnrs-libraries.test
index 86035e508..0fa7acb5c 100644
--- a/test-suite/tests/rnrs-libraries.test
+++ b/test-suite/tests/rnrs-libraries.test
@@ -205,9 +205,17 @@
   (with-test-prefix "srfi"
     (pass-if "renaming works"
       (eq? (resolve-interface '(srfi srfi-1))
-           (resolve-r6rs-interface '(srfi :1)))
+           (resolve-r6rs-interface '(srfi :1))
+           (resolve-r6rs-interface '(srfi 1)))
       (eq? (resolve-interface '(srfi srfi-1))
-           (resolve-r6rs-interface '(srfi :1 lists)))))
+           (resolve-r6rs-interface '(srfi :1 lists))
+           (resolve-r6rs-interface '(srfi 1))))
+
+    (pass-if "import works"
+      (import (srfi srfi-1))
+      (import (srfi :1))
+      (import (srfi 1))
+      #t))
 
   (with-test-prefix "macro"
     (pass-if "multiple clauses"
-- 
2.41.0