From: Maxim Cournoyer <maxim.cournoyer@gmail.com>
To: 67412@debbugs.gnu.org
Cc: Maxim Cournoyer <maxim.cournoyer@gmail.com>
Subject: bug#67412: [PATCH v2 2/2] r7rs-libraries: Better support R7RS SRFI library names.
Date: Fri, 24 Nov 2023 16:19:06 -0500 [thread overview]
Message-ID: <20231124212033.18967-2-maxim.cournoyer@gmail.com> (raw)
In-Reply-To: <20231124212033.18967-1-maxim.cournoyer@gmail.com>
* 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
prev parent reply other threads:[~2023-11-24 21:19 UTC|newest]
Thread overview: 6+ messages / expand[flat|nested] mbox.gz Atom feed top
2023-11-23 19:45 bug#67412: (resolve-r6rs-interface '(srfi 160 u8) tries to load (srfi srfi-160) Maxim Cournoyer
2023-11-23 21:44 ` Maxim Cournoyer
2023-11-24 16:39 ` bug#67412: [PATCH 1/2] Use R7RS 'rename' syntax for exports Maxim Cournoyer
2023-11-24 16:39 ` bug#67412: [PATCH 2/2] r7rs-libraries: Better support R7RS SRFI library names Maxim Cournoyer
2023-11-24 21:19 ` bug#67412: [PATCH v2 1/2] Use R7RS 'rename' syntax for exports Maxim Cournoyer
2023-11-24 21:19 ` Maxim Cournoyer [this message]
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=20231124212033.18967-2-maxim.cournoyer@gmail.com \
--to=maxim.cournoyer@gmail.com \
--cc=67412@debbugs.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).