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.scm53
1 files changed, 40 insertions, 13 deletions
diff --git a/module/ice-9/psyntax.scm b/module/ice-9/psyntax.scm
index 6305b53fe..292d6e27e 100644
--- a/module/ice-9/psyntax.scm
+++ b/module/ice-9/psyntax.scm
@@ -804,9 +804,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))
@@ -1049,20 +1075,21 @@
(define chi-when-list
(lambda (e when-list w)
- ;; when-list is syntax'd version of list of situations
+ ;; `when-list' is syntax'd version of list of situations. We
+ ;; could match these keywords lexically, via free-id=?, but then
+ ;; we twingle the definition of eval-when to the bindings of
+ ;; eval, load, expand, and compile, which is totally unintended.
+ ;; So do a symbolic match instead.
(let f ((when-list when-list) (situations '()))
(if (null? when-list)
situations
(f (cdr when-list)
- (cons (let ((x (car when-list)))
- (cond
- ((free-id=? x #'compile) 'compile)
- ((free-id=? x #'load) 'load)
- ((free-id=? x #'eval) 'eval)
- ((free-id=? x #'expand) 'expand)
- (else (syntax-violation 'eval-when
- "invalid situation"
- e (wrap x w #f)))))
+ (cons (let ((x (syntax->datum (car when-list))))
+ (if (memq x '(compile load eval expand))
+ x
+ (syntax-violation 'eval-when
+ "invalid situation"
+ e (wrap (car when-list) w #f))))
situations))))))
;; syntax-type returns six values: type, value, e, w, s, and mod. The