[Date Prev][Date Next][Thread Prev][Thread Next][Date Index][Thread Index]
[Guile-commits] 01/01: Fix resolve-r6rs-interface to propagate replaceme
From: |
Andy Wingo |
Subject: |
[Guile-commits] 01/01: Fix resolve-r6rs-interface to propagate replacement flags |
Date: |
Fri, 6 Dec 2019 09:39:26 -0500 (EST) |
wingo pushed a commit to branch master
in repository guile.
commit d14e8fabb3f592a3c04b2725ca2aab85118628c8
Author: Andy Wingo <address@hidden>
Date: Fri Dec 6 15:35:01 2019 +0100
Fix resolve-r6rs-interface to propagate replacement flags
* module/ice-9/r6rs-libraries.scm (resolve-r6rs-interface): Fix to
propagate module-replacements correctly for custom interfaces.
---
module/ice-9/r6rs-libraries.scm | 43 +++++++++++++++++++++++++++--------------
1 file changed, 28 insertions(+), 15 deletions(-)
diff --git a/module/ice-9/r6rs-libraries.scm b/module/ice-9/r6rs-libraries.scm
index 8ff1b44..c6ba6a4 100644
--- a/module/ice-9/r6rs-libraries.scm
+++ b/module/ice-9/r6rs-libraries.scm
@@ -84,7 +84,9 @@
(module-add! iface sym
(or (module-variable mod sym)
(error "no binding `~A' in module ~A"
- sym mod))))
+ sym mod)))
+ (when (hashq-ref (module-replacements mod) sym)
+ (hashq-set! (module-replacements iface) sym #t)))
(syntax->datum #'(identifier ...)))
iface))
@@ -96,9 +98,9 @@
(module-add! iface sym var))
mod)
(for-each (lambda (sym)
- (if (module-local-variable iface sym)
- (module-remove! iface sym)
- (error "no binding `~A' in module ~A" sym mod)))
+ (unless (module-local-variable iface sym)
+ (error "no binding `~A' in module ~A" sym mod))
+ (module-remove! iface sym))
(syntax->datum #'(identifier ...)))
iface))
@@ -109,13 +111,17 @@
(pre (syntax->datum #'identifier)))
(module-for-each/nonlocal
(lambda (sym var)
- (module-add! iface (symbol-append pre sym) var))
+ (let ((sym* (symbol-append pre sym)))
+ (module-add! iface sym* var)
+ (when (hashq-ref (module-replacements mod) sym)
+ (hashq-set! (module-replacements iface) sym* #t))))
mod)
iface))
((rename import-set (from to) ...)
(and (and-map sym? #'(from ...)) (and-map sym? #'(to ...)))
(let* ((mod (resolve-r6rs-interface #'import-set))
+ (replacements (module-replacements mod))
(iface (make-custom-interface mod)))
(module-for-each/nonlocal
(lambda (sym var) (module-add! iface sym var))
@@ -124,19 +130,26 @@
(cond
((null? in)
(for-each
- (lambda (pair)
- (if (module-local-variable iface (car pair))
- (error "duplicate binding for `~A' in module ~A"
- (car pair) mod)
- (module-add! iface (car pair) (cdr pair))))
+ (lambda (v)
+ (let ((to (vector-ref v 0))
+ (replace? (vector-ref v 1))
+ (var (vector-ref v 2)))
+ (when (module-local-variable iface to)
+ (error "duplicate binding for `~A' in module ~A" to mod))
+ (module-add! iface to var)
+ (when replace?
+ (hashq-set! replacements to #t))))
out)
iface)
(else
- (let ((var (or (module-variable mod (caar in))
- (error "no binding `~A' in module ~A"
- (caar in) mod))))
- (module-remove! iface (caar in))
- (lp (cdr in) (acons (cdar in) var out))))))))
+ (let* ((from (caar in))
+ (to (cdar in))
+ (var (module-variable mod from))
+ (replace? (hashq-ref replacements from)))
+ (unless var (error "no binding `~A' in module ~A" from mod))
+ (module-remove! iface from)
+ (hashq-remove! replacements from)
+ (lp (cdr in) (cons (vector to replace? var) out))))))))
((name name* ... (version ...))
(and-map sym? #'(name name* ...))