unofficial mirror of guile-devel@gnu.org 
 help / color / mirror / Atom feed
From: Maxim Cournoyer <maxim.cournoyer@gmail.com>
To: guile-devel@gnu.org
Cc: Maxim Cournoyer <maxim.cournoyer@gmail.com>
Subject: [PATCH v9 04/18] r7rs-libraries: Better support R7RS SRFI library names.
Date: Tue, 12 Dec 2023 23:37:43 -0500	[thread overview]
Message-ID: <20231213044217.14093-5-maxim.cournoyer@gmail.com> (raw)
In-Reply-To: <20231213044217.14093-1-maxim.cournoyer@gmail.com>

* module/ice-9/r6rs-libraries.scm
(resolve-r6rs-interface <srfi-name?>: Relax symbol requirements.
<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-module-name->r6rs-module-name, r7rs-import->r6rs-import>: New
nested procedures, used to translate the library name and import sets.
<handle-cond-expand>: Apply r7rs-name->r6rs-name to the library name.
* test-suite/tests/rnrs-libraries.test ("import features")
<"renaming works">: Extend test.
<"import works">: New test.
* NEWS: Mention bug fix.

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

(no changes since v1)

 NEWS                                 |  3 +
 module/ice-9/r6rs-libraries.scm      | 88 ++++++++--------------------
 module/ice-9/r7rs-libraries.scm      | 48 ++++++++++++++-
 test-suite/tests/rnrs-libraries.test | 12 +++-
 4 files changed, 85 insertions(+), 66 deletions(-)

diff --git a/NEWS b/NEWS
index 6284bb127..af66c80bd 100644
--- a/NEWS
+++ b/NEWS
@@ -48,6 +48,9 @@ a buffer overrun, and so might vary.  This problem affected a number of
 other operations, given the internal use of those functions.
 
 
+** Add better support to R7RS library names for SRFI modules
+   (<https://bugs.gnu.org/67412>)
+
 ** Fix 'include' not finding included files when byte compiling Guile
    (<https://bugs.gnu.org/66046>)
 ** R7RS define-library now properly supports 'rename' declarations
diff --git a/module/ice-9/r6rs-libraries.scm b/module/ice-9/r6rs-libraries.scm
index f27b07841..a2ba3a740 100644
--- a/module/ice-9/r6rs-libraries.scm
+++ b/module/ice-9/r6rs-libraries.scm
@@ -1,6 +1,6 @@
 ;;; r6rs-libraries.scm --- Support for the R6RS `library' and `import' forms
 
-;;      Copyright (C) 2010, 2019 Free Software Foundation, Inc.
+;;      Copyright (C) 2010, 2019, 2023 Free Software Foundation, Inc.
 ;;
 ;; This library is free software; you can redistribute it and/or
 ;; modify it under the terms of the GNU Lesser General Public
@@ -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 97465b649..773a9d47b 100644
--- a/module/ice-9/r7rs-libraries.scm
+++ b/module/ice-9/r7rs-libraries.scm
@@ -31,6 +31,36 @@
 
 (define-syntax define-library
   (lambda (stx)
+    (define (r7rs-module-name->r6rs-module-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 (handle-includes filenames)
       (syntax-case filenames ()
         (() #'())
@@ -105,12 +135,26 @@
          #'(rename (from-identifier to-identifier)))
         (identifier #'identifier)))
 
+    (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-module-name->r6rs-module-name import-set))))
+
     (syntax-case stx ()
       ((_ name decl ...)
        (call-with-values (lambda ()
                            (partition-decls #'(decl ...) '() '() '()))
          (lambda (exports imports code)
-           #`(library name
+           #`(library #,(r7rs-module-name->r6rs-module-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




  parent reply	other threads:[~2023-12-13  4:37 UTC|newest]

Thread overview: 19+ messages / expand[flat|nested]  mbox.gz  Atom feed  top
2023-12-13  4:37 [PATCH v9 00/18] Add SRFI 209 and dependencies; improve support for R7RS libraries Maxim Cournoyer
2023-12-13  4:37 ` [PATCH v9 01/18] ice-9: Fix 'include' when used in compilation contexts Maxim Cournoyer
2023-12-13  4:37 ` [PATCH v9 02/18] Use R7RS 'rename' syntax for exports Maxim Cournoyer
2023-12-13  4:37 ` [PATCH v9 03/18] r7rs-libraries: Add support for 'else' clause in cond-expand Maxim Cournoyer
2023-12-13  4:37 ` Maxim Cournoyer [this message]
2023-12-13  4:37 ` [PATCH v9 05/18] (scheme base): Support non-negative SRFI integer names " Maxim Cournoyer
2023-12-13  4:37 ` [PATCH v9 06/18] Share features tested by cond-expand library declarations and expressions Maxim Cournoyer
2023-12-13  4:37 ` [PATCH v9 07/18] build: Register '.sld' as an alternative extension to '.scm' Maxim Cournoyer
2023-12-13  4:37 ` [PATCH v9 08/18] module: Add SRFI 126 Maxim Cournoyer
2023-12-13  4:37 ` [PATCH v9 09/18] module: Add SRFI 128 Maxim Cournoyer
2023-12-13  4:37 ` [PATCH v9 10/18] module: Add (scheme comparator) Maxim Cournoyer
2023-12-13  4:37 ` [PATCH v9 11/18] module: Add (scheme sort) Maxim Cournoyer
2023-12-13  4:37 ` [PATCH v9 12/18] module: Add SRFI 125 Maxim Cournoyer
2023-12-13  4:37 ` [PATCH v9 13/18] module: Add SRFI 151 Maxim Cournoyer
2023-12-13  4:37 ` [PATCH v9 14/18] module: Add SRFI 160 Maxim Cournoyer
2023-12-13  4:37 ` [PATCH v9 15/18] module: Add SRFI 178 Maxim Cournoyer
2023-12-13  4:37 ` [PATCH v9 16/18] module: Add SRFI 209 Maxim Cournoyer
2023-12-13  4:37 ` [PATCH v9 17/18] module: Add SRFI 48 Maxim Cournoyer
2023-12-13  4:37 ` [PATCH v9 18/18] module: Upgrade SRFI 64 to modern R7RS library implementation Maxim Cournoyer

Reply instructions:

You may reply publicly to this message via plain-text email
using any one of the following methods:

* Save the following mbox file, import it into your mail client,
  and reply-to-all from there: mbox

  Avoid top-posting and favor interleaved quoting:
  https://en.wikipedia.org/wiki/Posting_style#Interleaved_style

  List information: https://www.gnu.org/software/guile/

* Reply using the --to, --cc, and --in-reply-to
  switches of git-send-email(1):

  git send-email \
    --in-reply-to=20231213044217.14093-5-maxim.cournoyer@gmail.com \
    --to=maxim.cournoyer@gmail.com \
    --cc=guile-devel@gnu.org \
    /path/to/YOUR_REPLY

  https://kernel.org/pub/software/scm/git/docs/git-send-email.html

* If your mail client supports setting the In-Reply-To header
  via mailto: links, try the mailto: link
Be sure your reply has a Subject: header at the top and a blank line before the message body.
This is a public inbox, see mirroring instructions
for how to clone and mirror all data and code used for this inbox;
as well as URLs for read-only IMAP folder(s) and NNTP newsgroup(s).