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

fixed bug in expansion of expressions in interaction environment 

where id->label was prematurely interning identifiers in the
environment.  Now, there is id->label/intern that does that and it's
only used when an identifier's type is resolved and not at other
times (like in free-id=? and bount-id=?).
This commit is contained in:
Abdulaziz Ghuloum 2009-04-27 09:59:23 +03:00
parent 2924c91788
commit 5b2fca49e6
3 changed files with 8 additions and 8 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

2
scheme/ikarus.string-to-number.ss
View File

@ -335,7 +335,7 @@
(sign-inf. (r ex sn) (sign-inf. (r ex sn)
[(#\0) (next sign-inf.0 r ex sn)]) [(#\0) (next sign-inf.0 r ex sn)])
(sign-inf.0 (r ex sn) (sign-inf.0 (r ex sn)
[(eof) (* sn +inf.0)] [(eof) (if (= sn 1) +inf.0 -inf.0)] ;(* sn +inf.0)
[(#\+) (next im:sign r (* sn +inf.0) ex +1)] [(#\+) (next im:sign r (* sn +inf.0) ex +1)]
[(#\-) (next im:sign r (* sn +inf.0) ex -1)] [(#\-) (next im:sign r (* sn +inf.0) ex -1)]
[(#\@) (next polar r (* sn +inf.0) ex)] [(#\@) (next polar r (* sn +inf.0) ex)]

2
scheme/last-revision
View File

@ -1 +1 @@
1766 1767

12
scheme/psyntax.expander.ss
View File

@ -507,7 +507,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->real-label i)) (t1 (id->real-label j))) (let ((t0 (id->label i)) (t1 (id->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))))))
@ -584,8 +584,8 @@
;;; 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 id) (define (id->label/intern id)
(or (id->real-label id) (or (id->label id)
(cond (cond
((top-level-context) => ((top-level-context) =>
(lambda (env) (lambda (env)
@ -596,7 +596,7 @@
lab)))) lab))))
(else #f)))) (else #f))))
(define id->real-label (define id->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)))
@ -679,7 +679,7 @@
(cond (cond
((id? e) ((id? e)
(let ((id e)) (let ((id e))
(let* ((label (id->label id)) (let* ((label (id->label/intern id))
(b (label->binding label r)) (b (label->binding label r))
(type (binding-type b))) (type (binding-type b)))
(unless label ;;; fail early. (unless label ;;; fail early.
@ -694,7 +694,7 @@
((syntax-pair? e) ((syntax-pair? e)
(let ((id (syntax-car e))) (let ((id (syntax-car e)))
(if (id? id) (if (id? id)
(let* ((label (id->label id)) (let* ((label (id->label/intern id))
(b (label->binding label r)) (b (label->binding label r))
(type (binding-type b))) (type (binding-type b)))
(unless label ;;; fail early. (unless label ;;; fail early.