guile-commits
[Top][All Lists]
Advanced

[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:))))



reply via email to

[Prev in Thread] Current Thread [Next in Thread]