fixed a problem causing free-id=? to intern unbound identifiers

into the interaction environment.
This commit is contained in:
Abdulaziz Ghuloum 2008-05-01 15:04:43 -04:00
parent d49aed209a
commit b56b0fbd85
2 changed files with 15 additions and 13 deletions

View File

@ -1 +1 @@
1459
1460

View File

@ -506,7 +506,7 @@
;;; same label or if both are unbound and they have the same name.
(define free-id=?
(lambda (i j)
(let ((t0 (id->label i)) (t1 (id->label j)))
(let ((t0 (id->real-label i)) (t1 (id->real-label j)))
(if (or t0 t1)
(eq? t0 t1)
(eq? (id->sym i) (id->sym j))))))
@ -580,21 +580,23 @@
;;; id->label takes an id (that's a sym x marks x substs) and
;;; searches the substs for a label associated with the same sym
;;; and marks.
(define id->label
(define (id->label id)
(or (id->real-label id)
(cond
[(top-level-context) =>
(lambda (env)
;;; fabricate binding
(let ([rib (interaction-env-rib env)])
(let-values ([(lab loc_) (gen-define-label+loc id rib)])
lab)))]
[else #f])))
(define id->real-label
(lambda (id)
(let ((sym (id->sym id)))
(let search ((subst* (stx-subst* id)) (mark* (stx-mark* id)))
(cond
((null? subst*)
(cond
[(top-level-context) =>
(lambda (env)
;;; fabricate binding
(let ([rib (interaction-env-rib env)])
(let-values ([(lab loc_) (gen-define-label+loc id rib)])
(extend-rib! rib id lab)
lab)))]
[else #f]))
((null? subst*) #f)
((eq? (car subst*) 'shift)
;;; a shift is inserted when a mark is added.
;;; so, we search the rest of the substitution