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

allow #f as shift for `syntax-shift-phase-level'

Browse Source
This commit is contained in:
Matthew Flatt 2012-05-09 21:17:22 -06:00
parent 698c895413
commit dbd940611e
5 changed files with 47 additions and 19 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

2
collects/compiler/zo-structs.rkt
View File

@ -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]))

2
collects/scribblings/raco/zo-struct.scrbl
View File

@ -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.}

7
collects/scribblings/reference/stx-ops.scrbl
View File

@ -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?)])

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

@ -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.
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

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

@ -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 <num> <midx> <midx> <export-registry> <insp>))
is a phase shift by <num>, remapping the first <midx> to the
- A wrap-elem (box (vector <num-or #f> <midx> <midx> <export-registry> <insp>))
is a phase shift by <num-or-#f>, remapping the first <midx> to the
second <midx>; the <export-registry> 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]);
}
}