summaryrefslogtreecommitdiff
path: root/module/ice-9/psyntax.scm
diff options
context:
space:
mode:
Diffstat (limited to 'module/ice-9/psyntax.scm')
-rw-r--r--module/ice-9/psyntax.scm32
1 files changed, 29 insertions, 3 deletions
diff --git a/module/ice-9/psyntax.scm b/module/ice-9/psyntax.scm
index 8232ad9f2..14b89f9a6 100644
--- a/module/ice-9/psyntax.scm
+++ b/module/ice-9/psyntax.scm
@@ -821,9 +821,35 @@
(define free-id=?
(lambda (i j)
- (and (eq? (id-sym-name i) (id-sym-name j)) ; accelerator
- (eq? (id-var-name i empty-wrap) (id-var-name j empty-wrap)))))
-
+ (let ((ni (id-var-name i empty-wrap))
+ (nj (id-var-name j empty-wrap)))
+ (define (id-module-binding id)
+ (let ((mod (and (syntax-object? id) (syntax-object-module id))))
+ (module-variable
+ (if mod
+ ;; The normal case.
+ (resolve-module (cdr mod))
+ ;; Either modules have not been booted, or we have a
+ ;; raw symbol coming in, which is possible.
+ (current-module))
+ (id-sym-name id))))
+ (if (eq? ni (id-sym-name i))
+ ;; `i' is not lexically bound. Assert that `j' is free,
+ ;; and if so, compare their bindings, that they are either
+ ;; bound to the same variable, or both unbound and have
+ ;; the same name.
+ (and (eq? nj (id-sym-name j))
+ (let ((bi (id-module-binding i)))
+ (if bi
+ (eq? bi (id-module-binding j))
+ (and (not (id-module-binding j))
+ (eq? ni nj))))
+ (eq? (id-module-binding i) (id-module-binding j)))
+ ;; Otherwise `i' is bound, so check that `j' is bound, and
+ ;; bound to the same thing.
+ (and (eq? ni nj)
+ (not (eq? nj (id-sym-name j))))))))
+
;; bound-id=? may be passed unwrapped (or partially wrapped) ids as
;; long as the missing portion of the wrap is common to both of the ids
;; since (bound-id=? x y) iff (bound-id=? (wrap x w) (wrap y w))