fix problem in `free-identifier=?'
Renamings created by a rename-transformer binding were not treated correctly by `free-identifier=?'. Closes PR 12623
This commit is contained in:
parent
f225eedc24
commit
a48154a665
|
@ -853,6 +853,68 @@
|
|||
(eval '(def t))
|
||||
(eval '(t)))
|
||||
|
||||
;; ----------------------------------------
|
||||
;; Check that a `free-identifier=?' mapping via a rename transformer
|
||||
;; doesn't mess up a `free-identifier=?' test where the relevant
|
||||
;; identifier is shadowed with a lexical binding; this test was
|
||||
;; provided by Carl Eastlund.
|
||||
|
||||
(module lang-for-identifier=?-test racket/base
|
||||
(#%module-begin
|
||||
|
||||
(provide
|
||||
#%module-begin
|
||||
(all-from-out racket/base)
|
||||
(for-syntax
|
||||
(all-from-out racket/base)
|
||||
(all-from-out syntax/parse)))
|
||||
|
||||
(require
|
||||
(for-syntax
|
||||
racket/base
|
||||
syntax/parse))
|
||||
|
||||
(define-syntax (#%module-begin stx)
|
||||
(syntax-parse stx
|
||||
[(_ before ...)
|
||||
(syntax-parse (local-expand
|
||||
#'(#%plain-module-begin before ...)
|
||||
'module-begin
|
||||
'())
|
||||
#:literal-sets {kernel-literals}
|
||||
[(#%plain-module-begin
|
||||
_
|
||||
_
|
||||
(#%plain-lambda {one:id}
|
||||
(letrec-syntaxes+values _ _ two:id)))
|
||||
|
||||
(let ()
|
||||
(when (bound-identifier=? #'one #'two)
|
||||
(unless (free-identifier=? #'one #'two)
|
||||
(error 'bug
|
||||
"{bound,free}-identifier=? inconsistency")))
|
||||
|
||||
#'(#%plain-module-begin))])]))))
|
||||
|
||||
(module consistency-of-identifier=?-test 'lang-for-identifier=?-test
|
||||
(#%module-begin
|
||||
|
||||
(define-syntaxes {lam}
|
||||
(lambda (stx)
|
||||
(syntax-parse stx
|
||||
[(_ unmarked . body)
|
||||
(define/syntax-parse marked
|
||||
(syntax-local-introduce (attribute unmarked)))
|
||||
#'(#%plain-lambda {marked}
|
||||
(define-syntaxes {unmarked}
|
||||
(make-rename-transformer #'marked))
|
||||
. body)])))
|
||||
|
||||
(define-syntaxes {x}
|
||||
(make-rename-transformer #'dummy))
|
||||
|
||||
(lam x x)))
|
||||
|
||||
;; ----------------------------------------
|
||||
|
||||
(report-errs)
|
||||
|
|
|
@ -4437,8 +4437,9 @@ static Scheme_Object *get_module_src_name(Scheme_Object *a, Scheme_Object *orig_
|
|||
Scheme_Object *bdg = NULL;
|
||||
|
||||
result = ((Scheme_Stx *)a)->u.modinfo_cache;
|
||||
if (result && SAME_OBJ(phase, scheme_make_integer(0)))
|
||||
if (result && SAME_OBJ(phase, scheme_make_integer(0))) {
|
||||
return result;
|
||||
}
|
||||
|
||||
WRAP_POS_INIT(wraps, ((Scheme_Stx *)a)->wraps);
|
||||
|
||||
|
@ -4458,7 +4459,7 @@ static Scheme_Object *get_module_src_name(Scheme_Object *a, Scheme_Object *orig_
|
|||
result = SCHEME_STX_VAL(a);
|
||||
|
||||
#if 0
|
||||
printf("%p %p %s (%d) %d %p\n",
|
||||
printf("%p %p %s (%d) %d %p\n",
|
||||
a, orig_phase, SCHEME_SYMBOLP(result) ? SCHEME_SYM_VAL(result) : "!?",
|
||||
can_cache, sealed, free_id_recur);
|
||||
#endif
|
||||
|
@ -4563,7 +4564,10 @@ static Scheme_Object *get_module_src_name(Scheme_Object *a, Scheme_Object *orig_
|
|||
if (SCHEME_BOXP(rename)) {
|
||||
/* only happens with free_id_renames */
|
||||
rename = SCHEME_BOX_VAL(rename);
|
||||
result = SCHEME_CAR(rename);
|
||||
if (no_lexical || SCHEME_TRUEP(SCHEME_CDR(rename)))
|
||||
result = SCHEME_CAR(rename);
|
||||
else
|
||||
rename = NULL;
|
||||
} else if (SCHEME_PAIRP(rename)) {
|
||||
if (nom_mod_p(rename)) {
|
||||
result = glob_id;
|
||||
|
|
Loading…
Reference in New Issue
Block a user