mirror/guile
mirror/guile
1
Fork 0
mirror of https://git.savannah.gnu.org/git/guile.git synced 2025-05-21 20:20:24 +02:00
Code Activity

Fix resolve-r6rs-interface to propagate replacement flags

Browse source 
* module/ice-9/r6rs-libraries.scm (resolve-r6rs-interface): Fix to
  propagate module-replacements correctly for custom interfaces.
This commit is contained in:
Andy Wingo 2019-12-06 15:35:01 +01:00
parent 2b6083865a
commit d14e8fabb3
1 changed files with 28 additions and 15 deletions
Download patch file Download diff file Expand all files Collapse all files

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

@ -84,7 +84,9 @@
(module-add! iface sym (module-add! iface sym
(or (module-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)))
(when (hashq-ref (module-replacements mod) sym)
(hashq-set! (module-replacements iface) sym #t)))
(syntax->datum #'(identifier ...))) (syntax->datum #'(identifier ...)))
iface)) iface))
@ -96,9 +98,9 @@
(module-add! iface sym var)) (module-add! iface sym var))
mod) mod)
(for-each (lambda (sym) (for-each (lambda (sym)
(if (module-local-variable iface sym) (unless (module-local-variable iface sym)
(module-remove! iface sym) (error "no binding `~A' in module ~A" sym mod))
(error "no binding `~A' in module ~A" sym mod))) (module-remove! iface sym))
(syntax->datum #'(identifier ...))) (syntax->datum #'(identifier ...)))
iface)) iface))
@ -109,13 +111,17 @@
(pre (syntax->datum #'identifier))) (pre (syntax->datum #'identifier)))
(module-for-each/nonlocal (module-for-each/nonlocal
(lambda (sym var) (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) 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))
(replacements (module-replacements mod))
(iface (make-custom-interface mod))) (iface (make-custom-interface mod)))
(module-for-each/nonlocal (module-for-each/nonlocal
(lambda (sym var) (module-add! iface sym var)) (lambda (sym var) (module-add! iface sym var))
@ -124,19 +130,26 @@
(cond (cond
((null? in) ((null? in)
(for-each (for-each
(lambda (pair) (lambda (v)
(if (module-local-variable iface (car pair)) (let ((to (vector-ref v 0))
(error "duplicate binding for `~A' in module ~A" (replace? (vector-ref v 1))
(car pair) mod) (var (vector-ref v 2)))
(module-add! iface (car pair) (cdr pair)))) (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) out)
iface) iface)
(else (else
(let ((var (or (module-variable mod (caar in)) (let* ((from (caar in))
(error "no binding `~A' in module ~A" (to (cdar in))
(caar in) mod)))) (var (module-variable mod from))
(module-remove! iface (caar in)) (replace? (hashq-ref replacements from)))
(lp (cdr in) (acons (cdar in) var out)))))))) (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 ...)) ((name name* ... (version ...))
(and-map sym? #'(name name* ...)) (and-map sym? #'(name name* ...))