conservatory
/
ikarus
4
0
Fork 0
Code Issues Pull Requests Projects Releases Wiki Activity

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
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

2
scheme/last-revision
View File

@ -1 +1 @@
1459 1460

26
scheme/psyntax.expander.ss
View File

@ -506,7 +506,7 @@
;;; same label or if both are unbound and they have the same name. ;;; same label or if both are unbound and they have the same name.
(define free-id=? (define free-id=?
(lambda (i j) (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) (if (or t0 t1)
(eq? t0 t1) (eq? t0 t1)
(eq? (id->sym i) (id->sym j)))))) (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 ;;; 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 ;;; searches the substs for a label associated with the same sym
;;; and marks. ;;; 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) (lambda (id)
(let ((sym (id->sym id))) (let ((sym (id->sym id)))
(let search ((subst* (stx-subst* id)) (mark* (stx-mark* id))) (let search ((subst* (stx-subst* id)) (mark* (stx-mark* id)))
(cond (cond
((null? subst*) ((null? subst*) #f)
(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]))
((eq? (car subst*) 'shift) ((eq? (car subst*) 'shift)
;;; a shift is inserted when a mark is added. ;;; a shift is inserted when a mark is added.
;;; so, we search the rest of the substitution ;;; so, we search the rest of the substitution