mirror/guile
mirror/guile
1
Fork 0
mirror of https://git.savannah.gnu.org/git/guile.git synced 2025-06-29 22:40:34 +02:00
Code Activity

Fix R6RS imports of interfaces that use interfaces

Browse source 
* 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.
This commit is contained in:
Andy Wingo 2016-04-14 11:50:08 +02:00
parent cf80502c0a
commit 5e470ea48f
2 changed files with 57 additions and 19 deletions
Download patch file Download diff file Expand all files Collapse all files

34
module/ice-9/r6rs-libraries.scm
View file

@ -26,6 +26,17 @@
(set-module-kind! iface 'custom-interface) (set-module-kind! iface 'custom-interface)
(set-module-name! iface (module-name mod)) (set-module-name! iface (module-name mod))
iface)) 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))) (define (sym? x) (symbol? (syntax->datum x)))
(syntax-case import-spec (library only except prefix rename srfi) (syntax-case import-spec (library only except prefix rename srfi)
@ -63,7 +74,7 @@
(iface (make-custom-interface mod))) (iface (make-custom-interface mod)))
(for-each (lambda (sym) (for-each (lambda (sym)
(module-add! iface sym (module-add! iface sym
(or (module-local-variable mod sym) (or (module-variable mod sym)
(error "no binding `~A' in module ~A" (error "no binding `~A' in module ~A"
sym mod)))) sym mod))))
(syntax->datum #'(identifier ...))) (syntax->datum #'(identifier ...)))
@ -73,7 +84,9 @@
(and-map sym? #'(identifier ...)) (and-map sym? #'(identifier ...))
(let* ((mod (resolve-r6rs-interface #'import-set)) (let* ((mod (resolve-r6rs-interface #'import-set))
(iface (make-custom-interface mod))) (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) (for-each (lambda (sym)
(if (module-local-variable iface sym) (if (module-local-variable iface sym)
(module-remove! iface sym) (module-remove! iface sym)
@ -86,16 +99,19 @@
(let* ((mod (resolve-r6rs-interface #'import-set)) (let* ((mod (resolve-r6rs-interface #'import-set))
(iface (make-custom-interface mod)) (iface (make-custom-interface mod))
(pre (syntax->datum #'identifier))) (pre (syntax->datum #'identifier)))
(module-for-each (lambda (sym var) (module-for-each/nonlocal
(module-add! iface (symbol-append pre sym) var)) (lambda (sym var)
mod) (module-add! iface (symbol-append pre sym) var))
mod)
iface)) iface))
((rename import-set (from to) ...) ((rename import-set (from to) ...)
(and (and-map sym? #'(from ...)) (and-map sym? #'(to ...))) (and (and-map sym? #'(from ...)) (and-map sym? #'(to ...)))
(let* ((mod (resolve-r6rs-interface #'import-set)) (let* ((mod (resolve-r6rs-interface #'import-set))
(iface (make-custom-interface mod))) (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 '())) (let lp ((in (syntax->datum #'((from . to) ...))) (out '()))
(cond (cond
((null? in) ((null? in)
@ -108,7 +124,7 @@
out) out)
iface) iface)
(else (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" (error "no binding `~A' in module ~A"
(caar in) mod)))) (caar in) mod))))
(module-remove! iface (caar in)) (module-remove! iface (caar in))
@ -126,9 +142,9 @@
(lambda (stx) (lambda (stx)
(define (compute-exports ifaces specs) (define (compute-exports ifaces specs)
(define (re-export? sym) (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) (define (replace? sym)
(module-local-variable the-scm-module sym)) (module-variable the-scm-module sym))
(let lp ((specs specs) (e '()) (r '()) (x '())) (let lp ((specs specs) (e '()) (r '()) (x '()))
(syntax-case specs (rename) (syntax-case specs (rename)

42
test-suite/tests/rnrs-libraries.test
View file

@ -143,18 +143,40 @@
(module-obarray (resolve-r6rs-interface '(only (guile) +))))))) (module-obarray (resolve-r6rs-interface '(only (guile) +)))))))
(with-test-prefix "except" (with-test-prefix "except"
(let ((bindings (hash-map->list ;; In Guile, interfaces can use other interfaces. For R6RS modules
(lambda (sym var) sym) ;; that are imported as-is (without `except', etc), Guile will just
(module-obarray ;; import them as-is. `(guile)' is one of those modules. For other
(resolve-r6rs-interface '(except (guile) +)))))) ;; 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" (pass-if "contains"
(equal? (length bindings) (equal? (bound-name-count except-+)
(1- (hash-fold (1- (bound-name-count (resolve-interface '(guile))))))
(lambda (sym var n) (1+ n))
0
(module-obarray (resolve-interface '(guile)))))))
(pass-if "does not contain" (pass-if "does not contain"
(not (memq '+ bindings))))) (not (module-variable except-+ '+)))))
(with-test-prefix "prefix" (with-test-prefix "prefix"
(let ((iface (resolve-r6rs-interface '(prefix (ice-9 q) q:)))) (let ((iface (resolve-r6rs-interface '(prefix (ice-9 q) q:))))