diff --git a/collects/compiler/zo-structs.rkt b/collects/compiler/zo-structs.rkt index 448d43d611..03b53d31dc 100644 --- a/collects/compiler/zo-structs.rkt +++ b/collects/compiler/zo-structs.rkt @@ -193,7 +193,7 @@ (or/c (cons/c symbol? (or/c symbol? #f)) free-id-info?)))))])) -(define-form-struct (phase-shift wrap) ([amt exact-integer?] [src (or/c module-path-index? #f)] [dest (or/c module-path-index? #f)])) +(define-form-struct (phase-shift wrap) ([amt (or/c exact-integer? #f)] [src (or/c module-path-index? #f)] [dest (or/c module-path-index? #f)])) (define-form-struct (wrap-mark wrap) ([val exact-integer?])) (define-form-struct (prune wrap) ([sym any/c])) diff --git a/collects/scribblings/raco/zo-struct.scrbl b/collects/scribblings/raco/zo-struct.scrbl index 5f8e73451e..5b7d11f30b 100644 --- a/collects/scribblings/raco/zo-struct.scrbl +++ b/collects/scribblings/raco/zo-struct.scrbl @@ -529,7 +529,7 @@ structures that are produced by @racket[zo-parse] and consumed by @defstruct+[(phase-shift wrap) - ([amt exact-integer?] + ([amt (or/c exact-integer? #f)] [src module-path-index?] [dest module-path-index?])]{ Shifts module bindings later in the wrap set.} diff --git a/collects/scribblings/reference/stx-ops.scrbl b/collects/scribblings/reference/stx-ops.scrbl index 32669deec7..6285dae9ba 100644 --- a/collects/scribblings/reference/stx-ops.scrbl +++ b/collects/scribblings/reference/stx-ops.scrbl @@ -265,13 +265,14 @@ if a former representative becomes otherwise unreachable, then @defproc[(syntax-shift-phase-level [stx syntax?] - [shift exact-integer?]) + [shift (or/c exact-integer? #f)]) syntax?]{ Returns a syntax object that is like @racket[stx], but with all of its top-level and module binding shifted by @racket[shift] @tech{phase -levels}. If @racket[shift] is @racket[0], then the result is -@racket[stx].} +levels}. If @racket[shift] is @racket[#f], then only bindings +at @tech{phase level} 0 are shifted to the @tech{label phase level}. +If @racket[shift] is @racket[0], then the result is @racket[stx].} @defproc[(generate-temporaries [stx-pair (or syntax? list?)]) diff --git a/collects/tests/racket/stx.rktl b/collects/tests/racket/stx.rktl index a13e853602..aadcb530ac 100644 --- a/collects/tests/racket/stx.rktl +++ b/collects/tests/racket/stx.rktl @@ -516,6 +516,22 @@ (test '(lib "lang/htdp-intermediate.rkt") values nominal) (test 'cons cadddr b))) +(let () + (define (check wrap) + (test #f identifier-binding (wrap (datum->syntax #f 'lambda))) + (test #f identifier-template-binding (wrap #'lambda)) + (test (identifier-binding #'lambda) identifier-template-binding (wrap (syntax-shift-phase-level #'lambda -1))) + (test #f identifier-label-binding (wrap #'lambda)) + (test (identifier-binding #'lambda) identifier-label-binding (wrap (syntax-shift-phase-level #'lambda #f))) + (test #f identifier-binding (wrap (syntax-shift-phase-level #'lambda #f))) + (test #f identifier-template-binding (wrap (syntax-shift-phase-level #'lambda #f)))) + (check values) + (check (lambda (s) + (define-values (i o) (make-pipe)) + (write (compile-syntax #`(quote-syntax #,s)) o) + (parameterize ([read-accept-compiled #t]) + (eval (read i)))))) + ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; eval versus eval-syntax, etc. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; diff --git a/src/racket/src/syntax.c b/src/racket/src/syntax.c index e25efefa2b..8a76c6e15a 100644 --- a/src/racket/src/syntax.c +++ b/src/racket/src/syntax.c @@ -271,8 +271,8 @@ XFORM_NONGCING static int is_member(Scheme_Object *a, Scheme_Object *l) simple lexical renames (not ribs) and marks, only, and it's inserted into a chain heuristically - - A wrap-elem (box (vector )) - is a phase shift by , remapping the first to the + - A wrap-elem (box (vector )) + is a phase shift by , remapping the first to the second ; the part is for finding modules to unmarshal import renamings @@ -1178,7 +1178,8 @@ static int same_phase(Scheme_Object *a, Scheme_Object *b) if (SAME_OBJ(a, b)) return 1; else if (SCHEME_INTP(a) || SCHEME_INTP(b) - || SCHEME_FALSEP(a) || SCHEME_FALSEP(b)) + || SCHEME_FALSEP(a) || SCHEME_FALSEP(b) + || SCHEME_VOIDP(a) || SCHEME_VOIDP(b)) return 0; else return scheme_eqv(a, b); @@ -2193,8 +2194,8 @@ static Scheme_Object *syntax_shift_phase(int argc, Scheme_Object **argv) { if (!SCHEME_STXP(argv[0])) scheme_wrong_type("syntax-shift-phase-level", "syntax", 0, argc, argv); - if (!scheme_exact_p(argv[1])) - scheme_wrong_type("syntax-shift-phase-level", "exact integer", 0, argc, argv); + if (SCHEME_TRUEP(argv[1]) && !scheme_exact_p(argv[1])) + scheme_wrong_type("syntax-shift-phase-level", "exact integer or #f", 0, argc, argv); if (SCHEME_INTP(argv[1]) && !SCHEME_INT_VAL(argv[1])) return argv[0]; @@ -3123,6 +3124,21 @@ XFORM_NONGCING static int is_from_rib(Scheme_Object *other_env) return 0; } +static Scheme_Object *reverse_phase_shift(Scheme_Object *phase, Scheme_Object *n) +{ + if (SCHEME_TRUEP(n) && !SCHEME_VOIDP(phase)) { + if (SCHEME_TRUEP(phase)) + phase = scheme_bin_minus(phase, n); + } else { + /* phase shift to #f shifts only phase-0 bindings: */ + if (SCHEME_FALSEP(phase)) + phase = scheme_make_integer(0); + else + phase = scheme_void; /* don't match any phase */ + } + return phase; +} + static int same_marks(WRAP_POS *_awl, WRAP_POS *_bwl, Scheme_Object *barrier_env) /* Compares the marks in two wraps lists. The `barrier_env' argument cuts off the mark list if a rib containing a `barrier_env' renaming is found; @@ -4055,8 +4071,7 @@ static Scheme_Object *resolve_env(Scheme_Object *a, Scheme_Object *orig_phase, EXPLAIN(fprintf(stderr, "%d phase shift by %d\n", depth, SCHEME_INT_VAL(n))); - if (SCHEME_TRUEP(phase)) - phase = scheme_bin_minus(phase, n); + phase = reverse_phase_shift(phase, n); src = SCHEME_VEC_ELS(vec)[1]; dest = SCHEME_VEC_ELS(vec)[2]; @@ -4454,8 +4469,7 @@ static Scheme_Object *get_module_src_name(Scheme_Object *a, Scheme_Object *orig_ Scheme_Object *n, *vec; vec = SCHEME_PTR_VAL(WRAP_POS_FIRST(wraps)); n = SCHEME_VEC_ELS(vec)[0]; - if (SCHEME_TRUEP(phase)) - phase = scheme_bin_minus(phase, n); + phase = reverse_phase_shift(phase, n); } else if (!no_lexical && (SCHEME_VECTORP(WRAP_POS_FIRST(wraps)) || SCHEME_RIBP(WRAP_POS_FIRST(wraps)))) { @@ -6064,11 +6078,8 @@ static Scheme_Object *wraps_to_datum(Scheme_Object *stx_datum, redundant = 1; break; } - } else if (SCHEME_BOXP(la)) { - if (SCHEME_TRUEP(phase)) - phase = scheme_bin_minus(phase, - SCHEME_VEC_ELS(SCHEME_PTR_VAL(WRAP_POS_FIRST(l)))[0]); - } + } else if (SCHEME_BOXP(la)) + phase = reverse_phase_shift(phase, SCHEME_VEC_ELS(SCHEME_BOX_VAL(la))[0]); } }