From 5e470ea48f054aebad0e1000453a6c84e59cf460 Mon Sep 17 00:00:00 2001 From: Andy Wingo Date: Thu, 14 Apr 2016 11:50:08 +0200 Subject: [PATCH] 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 a68df3c63..579d6bd72 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 9add98af6..86035e508 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:))))