suzanne.soy/racket
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

fix a marshaling bug for syntax objects

Browse Source 
Closes PR 12300

Merge to 5.2
(cherry picked from commit a81054fef4)
This commit is contained in:
Matthew Flatt 2011-10-18 20:41:44 -06:00 committed by Eli Barzilay
parent 34f3b16626
commit a82a55074b
2 changed files with 66 additions and 6 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

55
collects/tests/racket/stx.rktl
View File

@ -1611,6 +1611,61 @@
(displayln (syntax-transforming-module-expression?))))))
(test "#t\n#f\n" get-output-string o))
;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Check that a common wraps encoding that is detected only
;; after simplification and encoding is shared propery. If
;; it's not shared properly in this example, a gensym for
;; the internal-definition context gets duplicated.
(parameterize ([current-namespace (make-base-namespace)])
(define e
(compile '(module producer racket/base
(#%module-begin
(require (for-syntax racket/base))
(define-syntax (compare stx)
(syntax-case stx ()
[(_ formal body)
(let ()
(define (internal-definition-context-apply ctx s)
(syntax-case (local-expand #`(quote-syntax #,s)
'expression
(list #'quote-syntax)
ctx) ()
[(qs e) #'e]))
(define ctx (syntax-local-make-definition-context))
(syntax-local-bind-syntaxes (list #'formal) #f ctx)
(internal-definition-context-seal ctx)
(with-syntax ([one
(internal-definition-context-apply ctx #'formal)]
[two
(syntax-local-introduce
(internal-definition-context-apply
ctx
(syntax-local-introduce
(internal-definition-context-apply ctx #'body))))])
(unless (free-identifier=? #'one #'two)
(error 'before
"identifiers were never the same"))
#'(begin-for-syntax
(unless (free-identifier=? #'one #'two)
(error 'after
"identifiers used to be the same, but now are not")))))]))
(compare z z)))))
(let ([o (open-output-bytes)])
(write e o)
(parameterize ([read-accept-compiled #t])
(eval (read (open-input-bytes (get-output-bytes o))))))
(namespace-require ''producer)
(eval 10))
;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(report-errs)

17
src/racket/src/syntax.c
View File

@ -3764,7 +3764,7 @@ static Scheme_Object *resolve_env(Scheme_Object *a, Scheme_Object *orig_phase,
scheme_write_to_string(((Scheme_Modidx *)result)->path, NULL),
scheme_write_to_string(((Scheme_Modidx *)result)->base, NULL)));
} else {
EXPLAIN(fprintf(stderr, "%d Result: %s\n", depth, scheme_write_to_string(result, NULL)));
EXPLAIN(fprintf(stderr, "%d Result: %s %p\n", depth, scheme_write_to_string(result, NULL), result));
}
if (get_names) {
EXPLAIN(fprintf(stderr, "%d phase %s\n", depth, scheme_write_to_string(get_names[3], NULL)));
@ -5075,12 +5075,17 @@ Scheme_Object *scheme_flatten_syntax_list(Scheme_Object *lst, int *islist)
#define EXPLAIN_SIMP 0
#if EXPLAIN_SIMP
#define EXPLAIN_S(x) if (explain_simp) x
static int explain_simp = 0;
static int explain_simp = 1;
static void print_skips(Scheme_Object *skips)
{
while (skips) {
fprintf(stderr, " skip %s\n", scheme_write_to_string(SCHEME_CAR(skips), NULL));
skips = SCHEME_CDR(skips);
if (SCHEME_PAIRP(skips)) {
fprintf(stderr, " skip %s\n", scheme_write_to_string(SCHEME_CAR(skips), NULL));
skips = SCHEME_CDR(skips);
} else {
fprintf(stderr, " skip val %s\n", scheme_write_to_string(skips, NULL));
skips = NULL;
}
}
}
#else
@ -5273,7 +5278,7 @@ static Scheme_Object *simplify_lex_renames(Scheme_Object *wraps, Scheme_Hash_Tab
EXPLAIN_S(fprintf(stderr, "[in simplify]\n"));
EXPLAIN_R(printf("Simplifying %p\n", lex_cache));
EXPLAIN_R(printf("Simplifying %p %s\n", lex_cache, scheme_write_to_string(stx_datum, NULL)));
while (!WRAP_POS_END_P(w)) {
if (SCHEME_VECTORP(WRAP_POS_FIRST(w))
@ -6224,7 +6229,6 @@ static Scheme_Object *wraps_to_datum(Scheme_Object *stx_datum,
return scheme_hash_get(rns, old_key);
} else {
a = scheme_marshal_lookup(mt, old_key);
scheme_marshal_using_key(mt, old_key);
if (!mt->same_map) {
Scheme_Hash_Table *same_map;
same_map = scheme_make_hash_table(SCHEME_hash_ptr);
@ -6233,6 +6237,7 @@ static Scheme_Object *wraps_to_datum(Scheme_Object *stx_datum,
scheme_hash_set(mt->same_map, w_in, old_key);
/* nevermind references that we saw when creating `stack': */
scheme_marshal_pop_refs(mt, 0);
scheme_marshal_using_key(mt, old_key);
return a;
}
}