[Date Prev][Date Next][Thread Prev][Thread Next][Date Index][Thread Index]
[Guile-commits] 05/06: Fix R6RS imports of interfaces that use interface
From: |
Andy Wingo |
Subject: |
[Guile-commits] 05/06: Fix R6RS imports of interfaces that use interfaces |
Date: |
Thu, 14 Apr 2016 14:34:12 +0000 |
wingo pushed a commit to branch wip-port-refactor
in repository guile.
commit 5e470ea48f054aebad0e1000453a6c84e59cf460
Author: Andy Wingo <address@hidden>
Date: Thu Apr 14 11:50:08 2016 +0200
Fix R6RS imports of interfaces that use interfaces
* module/ice-9/r6rs-libraries.scm (resolve-r6rs-interface): In Guile, a
module's public interface is just another module, and that means that
it can import other modules as well. Allow for R6RS modules that
import module whose interfaces import other modules to access all
visible bindings.
* test-suite/tests/rnrs-libraries.test ("import features"): Update
test.
---
module/ice-9/r6rs-libraries.scm | 34 ++++++++++++++++++++-------
test-suite/tests/rnrs-libraries.test | 42 +++++++++++++++++++++++++--------
2 files changed, 57 insertions(+), 19 deletions(-)
diff --git a/module/ice-9/r6rs-libraries.scm b/module/ice-9/r6rs-libraries.scm
index a68df3c..579d6bd 100644
--- a/module/ice-9/r6rs-libraries.scm
+++ b/module/ice-9/r6rs-libraries.scm
@@ -26,6 +26,17 @@
(set-module-kind! iface 'custom-interface)
(set-module-name! iface (module-name mod))
iface))
+ (define (module-for-each/nonlocal f mod)
+ (define (module-and-uses mod)
+ (let lp ((in (list mod)) (out '()))
+ (cond
+ ((null? in) (reverse out))
+ ((memq (car in) out) (lp (cdr in) out))
+ (else (lp (append (module-uses (car in)) (cdr in))
+ (cons (car in) out))))))
+ (for-each (lambda (mod)
+ (module-for-each f mod))
+ (module-and-uses mod)))
(define (sym? x) (symbol? (syntax->datum x)))
(syntax-case import-spec (library only except prefix rename srfi)
@@ -63,7 +74,7 @@
(iface (make-custom-interface mod)))
(for-each (lambda (sym)
(module-add! iface sym
- (or (module-local-variable mod sym)
+ (or (module-variable mod sym)
(error "no binding `~A' in module ~A"
sym mod))))
(syntax->datum #'(identifier ...)))
@@ -73,7 +84,9 @@
(and-map sym? #'(identifier ...))
(let* ((mod (resolve-r6rs-interface #'import-set))
(iface (make-custom-interface mod)))
- (module-for-each (lambda (sym var) (module-add! iface sym var)) mod)
+ (module-for-each/nonlocal (lambda (sym var)
+ (module-add! iface sym var))
+ mod)
(for-each (lambda (sym)
(if (module-local-variable iface sym)
(module-remove! iface sym)
@@ -86,16 +99,19 @@
(let* ((mod (resolve-r6rs-interface #'import-set))
(iface (make-custom-interface mod))
(pre (syntax->datum #'identifier)))
- (module-for-each (lambda (sym var)
- (module-add! iface (symbol-append pre sym) var))
- mod)
+ (module-for-each/nonlocal
+ (lambda (sym var)
+ (module-add! iface (symbol-append pre sym) var))
+ mod)
iface))
((rename import-set (from to) ...)
(and (and-map sym? #'(from ...)) (and-map sym? #'(to ...)))
(let* ((mod (resolve-r6rs-interface #'import-set))
(iface (make-custom-interface mod)))
- (module-for-each (lambda (sym var) (module-add! iface sym var)) mod)
+ (module-for-each/nonlocal
+ (lambda (sym var) (module-add! iface sym var))
+ mod)
(let lp ((in (syntax->datum #'((from . to) ...))) (out '()))
(cond
((null? in)
@@ -108,7 +124,7 @@
out)
iface)
(else
- (let ((var (or (module-local-variable mod (caar in))
+ (let ((var (or (module-variable mod (caar in))
(error "no binding `~A' in module ~A"
(caar in) mod))))
(module-remove! iface (caar in))
@@ -126,9 +142,9 @@
(lambda (stx)
(define (compute-exports ifaces specs)
(define (re-export? sym)
- (or-map (lambda (iface) (module-local-variable iface sym)) ifaces))
+ (or-map (lambda (iface) (module-variable iface sym)) ifaces))
(define (replace? sym)
- (module-local-variable the-scm-module sym))
+ (module-variable the-scm-module sym))
(let lp ((specs specs) (e '()) (r '()) (x '()))
(syntax-case specs (rename)
diff --git a/test-suite/tests/rnrs-libraries.test
b/test-suite/tests/rnrs-libraries.test
index 9add98a..86035e5 100644
--- a/test-suite/tests/rnrs-libraries.test
+++ b/test-suite/tests/rnrs-libraries.test
@@ -143,18 +143,40 @@
(module-obarray (resolve-r6rs-interface '(only (guile) +)))))))
(with-test-prefix "except"
- (let ((bindings (hash-map->list
- (lambda (sym var) sym)
- (module-obarray
- (resolve-r6rs-interface '(except (guile) +))))))
+ ;; In Guile, interfaces can use other interfaces. For R6RS modules
+ ;; that are imported as-is (without `except', etc), Guile will just
+ ;; import them as-is. `(guile)' is one of those modules. For other
+ ;; import kinds like `except', the resolve-r6rs-interface code will
+ ;; go binding-by-binding and create a new flat interface. Anyway,
+ ;; that means to compare an except interface with (guile), we're
+ ;; comparing a flat interface with a deep interface, so we need to
+ ;; do more work to get the set of bindings in (guile), knowing also
+ ;; that some of those bindings could be duplicates.
+ (define (bound-name-count mod)
+ (define (module-for-each/nonlocal f mod)
+ (define (module-and-uses mod)
+ (let lp ((in (list mod)) (out '()))
+ (cond
+ ((null? in) (reverse out))
+ ((memq (car in) out) (lp (cdr in) out))
+ (else (lp (append (module-uses (car in)) (cdr in))
+ (cons (car in) out))))))
+ (for-each (lambda (mod)
+ (module-for-each f mod))
+ (module-and-uses mod)))
+ (hash-fold (lambda (sym var n) (1+ n))
+ 0
+ (let ((t (make-hash-table)))
+ (module-for-each/nonlocal (lambda (sym var)
+ (hashq-set! t sym var))
+ mod)
+ t)))
+ (let ((except-+ (resolve-r6rs-interface '(except (guile) +))))
(pass-if "contains"
- (equal? (length bindings)
- (1- (hash-fold
- (lambda (sym var n) (1+ n))
- 0
- (module-obarray (resolve-interface '(guile)))))))
+ (equal? (bound-name-count except-+)
+ (1- (bound-name-count (resolve-interface '(guile))))))
(pass-if "does not contain"
- (not (memq '+ bindings)))))
+ (not (module-variable except-+ '+)))))
(with-test-prefix "prefix"
(let ((iface (resolve-r6rs-interface '(prefix (ice-9 q) q:))))
- [Guile-commits] branch wip-port-refactor updated (f7027a8 -> 25461be), Andy Wingo, 2016/04/14
- [Guile-commits] 03/06: Fix error in exception printer when bootstrapping, Andy Wingo, 2016/04/14
- [Guile-commits] 05/06: Fix R6RS imports of interfaces that use interfaces,
Andy Wingo <=
- [Guile-commits] 02/06: Allow port "write" functions to only write a chunk, Andy Wingo, 2016/04/14
- [Guile-commits] 01/06: Update port implementation documentation., Andy Wingo, 2016/04/14
- [Guile-commits] 04/06: Fix scm_init_struct dependency on port conversion handlers, Andy Wingo, 2016/04/14
- [Guile-commits] 06/06: Load port bindings in separate (ice-9 ports) module, Andy Wingo, 2016/04/14