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

add prop:expansion-contexts

Browse Source 
The `prop:expansion-contexts` property can control the expansion
of a rename transformer in much the same that conditionals on
`(syntax-local-context)` can control the expansion of other
transformers.
This commit is contained in:
Matthew Flatt 2015-08-31 20:21:40 -06:00
parent c290de0f88
commit 929db29b67
10 changed files with 1011 additions and 714 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

2
pkgs/base/info.rkt
View File

@ -12,7 +12,7 @@
(define collection 'multi)
(define version "6.2.900.11")
(define version "6.2.900.12")
(define deps `("racket-lib"
["racket" #:version ,version]))

42
pkgs/racket-doc/scribblings/reference/stx-trans.scrbl
View File

@ -460,6 +460,48 @@ provided for backward compatibility; the more general
@history[#:changed "6.3" @elem{Simplified the operation to @tech{scope} removal.}]}
@defthing[prop:expansion-contexts struct-type-property?]{
A @tech{structure type property} to constrain the use of macro
@tech{transformers} and @tech{rename transformers}. The property's
value must be a list of symbols, where the allowed symbols are
@racket['expression], @racket['top-level], @racket['module],
@racket['module-begin], and @racket['definition-context]. Each symbol
corresponds to an expansion context in the same way as for
@racket[local-expand] or as reported by @racket[syntax-local-context],
except that @racket['definition-context] is used (instead of a list)
to represent an @tech{internal-definition context}.
If an identifier is bound to a transformer whose list does not include
a symbol for a particular use of the identifier, then the use is
adjusted as follows:
@;
@itemlist[
@item{In a @racket['module-begin] context, then the use is wrapped in
a @racket[begin] form.}
@item{In a @racket['module], @racket['top-level],
@racket['internal-definition] or context, if
@racket['expression] is present in the list, then the use is
wrapped in an @racket[#%expression] form.}
@item{Otherwise, a syntax error is reported.}
]
The @racket[prop:expansion-contexts] property is most useful in
combination with @racket[prop:rename-transformer], since a general
@tech{transformer} procedure can use @racket[syntax-local-context].
Furthermore, a @racket[prop:expansion-contexts] property makes the
most sense when a @tech{rename transformer}'s identifier has the
@racket['not-free-identifier=?] property, otherwise a definition of
the binding creates a binding alias that effectively routes around the
@racket[prop:expansion-contexts] property.
@history[#:added "6.2.900.12"]}
@defproc[(syntax-local-value [id-stx syntax?]
[failure-thunk (or/c (-> any) #f)
#f]

92
pkgs/racket-test-core/tests/racket/macro.rktl
View File

@ -594,6 +594,97 @@
(test '(#t #f) (dynamic-require ''rename-transformer-tests:n 'go))
;; ----------------------------------------
(let ()
(define (go contexts
wrap
prop:macro
#:sub? [sub? #f]
#:trim-error [error-rx #f])
(define o (open-output-bytes))
(define e (open-output-bytes))
(parameterize ([current-output-port o]
[current-error-port e]
[current-namespace (make-base-namespace)])
(call-with-continuation-prompt
(lambda ()
(eval
`(module m racket/base
(require (for-syntax racket/base))
(define v 0)
(begin-for-syntax
(struct e (p)
#:property ,prop:macro ,(if (eq? prop:macro 'prop:procedure)
0
(list #'quote-syntax
(syntax-property #'v
'not-free-identifier=?
#t)))
#:property prop:expansion-contexts ',contexts))
(define-syntax m (e (lambda (stx)
(displayln (syntax-local-context))
#'10)))
,(wrap 'm)))
(dynamic-require (if sub? '(submod 'm sub) ''m) #f))))
(list (get-output-string o)
(if error-rx
(let ([m (regexp-match error-rx (get-output-string e))])
(or (and m (car m))
(get-output-string e)))
(get-output-string e))))
(test '("module\n10\n" "") go '(module expression) list 'prop:procedure)
(test '("module\n10\n" "") go '(module expression) values 'prop:procedure)
(test '("expression\n10\n" "") go '(expression) list 'prop:procedure)
(test '("expression\n10\n" "") go '(expression) values 'prop:procedure)
(test '("" "m: not allowed in context\n expansion context: module") go '() values 'prop:procedure
#:trim-error #rx"^[^\n]*\n[^\n]*")
(test '("0\n" "") go '(module expression) values 'prop:rename-transformer)
(test '("" "application: not a procedure") go '(module expression) list 'prop:rename-transformer
#:trim-error #rx"^[^;]*")
(test '("0\n" "") go '(expression) values 'prop:rename-transformer)
(test '("" "application: not a procedure") go '(expression) list 'prop:rename-transformer
#:trim-error #rx"^[^;]*")
(test '("" "m: not allowed in context\n expansion context: module") go '() values 'prop:rename-transformer
#:trim-error #rx"^[^\n]*\n[^\n]*")
(define (in-submodule s) `(module* sub #f ,s))
(test '("module-begin\n10\n" "") go '(module-begin expression) in-submodule 'prop:procedure #:sub? #t)
(test '("module-begin\n10\n" "") go '(module-begin) in-submodule 'prop:procedure #:sub? #t)
(test '("module\n10\n" "") go '(module expression) in-submodule 'prop:procedure #:sub? #t)
(test '("module\n10\n" "") go '(module) in-submodule 'prop:procedure #:sub? #t)
(test '("expression\n10\n" "") go '(expression) in-submodule 'prop:procedure #:sub? #t)
(test '("" "m: not allowed in context\n expansion context: module") go '() in-submodule 'prop:procedure
#:trim-error #rx"^[^\n]*\n[^\n]*")
(test '("0\n" "") go '(module-begin expression) in-submodule 'prop:rename-transformer #:sub? #t)
(test '("0\n" "") go '(module-begin) in-submodule 'prop:rename-transformer #:sub? #t)
(test '("0\n" "") go '(module expression) in-submodule 'prop:rename-transformer #:sub? #t)
(test '("0\n" "") go '(module) in-submodule 'prop:rename-transformer #:sub? #t)
(test '("0\n" "") go '(expression) in-submodule 'prop:rename-transformer #:sub? #t)
(test '("" "m: not allowed in context\n expansion context: module") go '() in-submodule 'prop:rename-transformer
#:trim-error #rx"^[^\n]*\n[^\n]*")
(define (in-defctx s) `(let () ,s))
(test '("(#(struct:liberal-define-context))\n10\n" "") go '(definition-context expression) in-defctx 'prop:procedure)
(test '("(#(struct:liberal-define-context))\n10\n" "") go '(definition-context) in-defctx 'prop:procedure)
(test '("expression\n10\n" "") go '(expression) in-defctx 'prop:procedure)
(test '("" "m: not allowed in context\n expansion context: definition-context") go '() in-defctx 'prop:procedure
#:trim-error #rx"^[^\n]*\n[^\n]*")
(test '("0\n" "") go '(definition-context expression) in-defctx 'prop:rename-transformer)
(test '("0\n" "") go '(definition-context) in-defctx 'prop:rename-transformer)
(test '("0\n" "") go '(expression) in-defctx 'prop:rename-transformer)
(test '("" "m: not allowed in context\n expansion context: definition-context") go '() in-defctx 'prop:rename-transformer
#:trim-error #rx"^[^\n]*\n[^\n]*")
(void))
;; ----------------------------------------
(let ()
@ -1354,7 +1445,6 @@
(eval-syntax #'a)
(eval-syntax (expand-syntax #'b)))])))
;; ----------------------------------------
(report-errs)

169
racket/src/racket/src/compile.c
View File

@ -56,6 +56,7 @@ ROSYM static Scheme_Object *begin_symbol;
ROSYM static Scheme_Object *disappeared_binding_symbol;
ROSYM static Scheme_Object *compiler_inline_hint_symbol;
ROSYM static Scheme_Object *app_symbol;
ROSYM static Scheme_Object *expression_symbol;
ROSYM static Scheme_Object *datum_symbol;
ROSYM static Scheme_Object *top_symbol;
ROSYM static Scheme_Object *protected_symbol;
@ -301,6 +302,7 @@ void scheme_init_compile (Scheme_Env *env)
env);
REGISTER_SO(app_symbol);
REGISTER_SO(expression_symbol);
REGISTER_SO(datum_symbol);
REGISTER_SO(top_symbol);
REGISTER_SO(protected_symbol);
@ -310,6 +312,7 @@ void scheme_init_compile (Scheme_Env *env)
REGISTER_SO(call_with_values_symbol);
app_symbol = scheme_intern_symbol("#%app");
expression_symbol = scheme_intern_symbol("#%expression");
datum_symbol = scheme_intern_symbol("#%datum");
top_symbol = scheme_intern_symbol("#%top");
protected_symbol = scheme_intern_symbol("protected");
@ -4403,13 +4406,58 @@ Scheme_Object *compile_list(Scheme_Object *form, Scheme_Comp_Env *env,
return inner_compile_list(form, env, rec, drec, 0);
}
static Scheme_Object *adjust_for_other_context(Scheme_Object *form, Scheme_Object *var, Scheme_Comp_Env *env)
{
/* Macro doesn't expand in this context. In a module-begin context,
just don't expand. If it's not an expression
context and expression context is ok, then wrap as an
expression. Otherwise, we just have to complain. */
if (env->flags & SCHEME_MODULE_BEGIN_FRAME) {
/* wrap in `begin` to trigger `#%module-begin` wrapper */
var = scheme_datum_to_syntax(begin_symbol, scheme_false, scheme_sys_wraps(env), 0, 0);
var = scheme_make_pair(var, scheme_make_pair(form, scheme_null));
form = scheme_datum_to_syntax(var, form, scheme_false, 0, 0);
} else if (scheme_expansion_contexts_include(SCHEME_PTR_VAL(var),
scheme_frame_to_expansion_context_symbol(0))) {
/* expression is ok, so we must not be in an expression context */
var = scheme_datum_to_syntax(expression_symbol, scheme_false, scheme_sys_wraps(env), 0, 0);
var = scheme_make_pair(var, scheme_make_pair(form, scheme_null));
form = scheme_datum_to_syntax(var, form, scheme_false, 0, 0);
} else {
Scheme_Object *csym;
csym = scheme_frame_to_expansion_context_symbol(env->flags);
scheme_wrong_syntax(NULL, NULL, form,
"not allowed in context\n expansion context: %S",
csym);
return NULL;
}
return form;
}
static Scheme_Object *install_alt_from_rename(Scheme_Object *first, Scheme_Object *alt_first)
{
if (alt_first) {
if (SCHEME_STX_PAIRP(first)) {
Scheme_Object *tail;
tail = scheme_stx_taint_disarm(first, NULL);
tail = SCHEME_STX_CDR(tail);
alt_first = scheme_datum_to_syntax(scheme_make_pair(alt_first, tail),
first, first, 0, 1);
return scheme_stx_track(alt_first, first, first);
} else
return alt_first;
} else
return first;
}
Scheme_Object *scheme_check_immediate_macro(Scheme_Object *first,
Scheme_Comp_Env *env,
Scheme_Compile_Expand_Info *rec, int drec,
Scheme_Object **current_val,
int keep_name)
{
Scheme_Object *name, *val;
Scheme_Object *name, *val, *alt_first = NULL;
Scheme_Expand_Info erec1;
Scheme_Env *menv = NULL;
@ -4453,23 +4501,38 @@ Scheme_Object *scheme_check_immediate_macro(Scheme_Object *first,
*current_val = val;
if (!val) {
first = install_alt_from_rename(first, alt_first);
SCHEME_EXPAND_OBSERVE_EXIT_CHECK(rec[drec].observer, first);
return first;
} else if (SAME_TYPE(SCHEME_TYPE(val), scheme_macro_type)) {
if (scheme_is_rename_transformer(SCHEME_PTR_VAL(val))) {
/* It's a rename. Look up the target name and try again. */
name = scheme_transfer_srcloc(scheme_rename_transformer_id(SCHEME_PTR_VAL(val)),
name);
menv = NULL;
SCHEME_USE_FUEL(1);
if (scheme_expansion_contexts_include(SCHEME_PTR_VAL(val),
scheme_frame_to_expansion_context_symbol(env->flags))) {
if (scheme_is_rename_transformer(SCHEME_PTR_VAL(val))) {
/* It's a rename. Look up the target name and try again. */
Scheme_Object *new_name;
new_name = scheme_rename_transformer_id(SCHEME_PTR_VAL(val));
if (!rec[drec].comp)
new_name = scheme_stx_track(new_name, name, name);
name = scheme_transfer_srcloc(new_name, name);
alt_first = name;
menv = NULL;
SCHEME_USE_FUEL(1);
} else {
alt_first = NULL;
scheme_init_expand_recs(rec, drec, &erec1, 1);
erec1.depth = 1;
erec1.value_name = (keep_name ? rec[drec].value_name : scheme_false);
first = scheme_expand_expr(first, env, &erec1, 0);
break; /* break to outer loop */
}
} else {
scheme_init_expand_recs(rec, drec, &erec1, 1);
erec1.depth = 1;
erec1.value_name = (keep_name ? rec[drec].value_name : scheme_false);
first = scheme_expand_expr(first, env, &erec1, 0);
first = install_alt_from_rename(first, alt_first);
alt_first = NULL;
first = adjust_for_other_context(first, val, env);
break; /* break to outer loop */
}
} else {
first = install_alt_from_rename(first, alt_first);
SCHEME_EXPAND_OBSERVE_EXIT_CHECK(rec[drec].observer, first);
return first;
}
@ -4648,16 +4711,20 @@ compile_expand_expr(Scheme_Object *form, Scheme_Comp_Env *env,
if (var && SAME_TYPE(SCHEME_TYPE(var), scheme_macro_type)
&& scheme_is_rename_transformer(SCHEME_PTR_VAL(var))) {
/* It's a rename. Look up the target name and try again. */
Scheme_Object *new_name;
new_name = scheme_rename_transformer_id(SCHEME_PTR_VAL(var));
if (!rec[drec].comp) {
new_name = scheme_stx_track(new_name, find_name, find_name);
}
find_name = scheme_transfer_srcloc(new_name, find_name);
SCHEME_USE_FUEL(1);
menv = NULL;
protected = 0;
if (scheme_expansion_contexts_include(SCHEME_PTR_VAL(var),
scheme_frame_to_expansion_context_symbol(env->flags))) {
/* It's a rename. Look up the target name and try again. */
Scheme_Object *new_name;
new_name = scheme_rename_transformer_id(SCHEME_PTR_VAL(var));
if (!rec[drec].comp) {
new_name = scheme_stx_track(new_name, find_name, find_name);
}
find_name = scheme_transfer_srcloc(new_name, find_name);
SCHEME_USE_FUEL(1);
menv = NULL;
protected = 0;
} else
break;
} else
break;
}
@ -4771,15 +4838,19 @@ compile_expand_expr(Scheme_Object *form, Scheme_Comp_Env *env,
SCHEME_EXPAND_OBSERVE_RESOLVE(rec[drec].observer, find_name);
if (var && SAME_TYPE(SCHEME_TYPE(var), scheme_macro_type)
&& scheme_is_rename_transformer(SCHEME_PTR_VAL(var))) {
/* It's a rename. Look up the target name and try again. */
Scheme_Object *new_name;
new_name = scheme_rename_transformer_id(SCHEME_PTR_VAL(var));
if (!rec[drec].comp) {
new_name = scheme_stx_track(new_name, find_name, find_name);
}
find_name = scheme_transfer_srcloc(new_name, find_name);
SCHEME_USE_FUEL(1);
menv = NULL;
if (scheme_expansion_contexts_include(SCHEME_PTR_VAL(var),
scheme_frame_to_expansion_context_symbol(env->flags))) {
/* It's a rename. Look up the target name and try again. */
Scheme_Object *new_name;
new_name = scheme_rename_transformer_id(SCHEME_PTR_VAL(var));
if (!rec[drec].comp) {
new_name = scheme_stx_track(new_name, find_name, find_name);
}
find_name = scheme_transfer_srcloc(new_name, find_name);
SCHEME_USE_FUEL(1);
menv = NULL;
} else
break;
} else
break;
}
@ -4866,14 +4937,18 @@ compile_expand_expr(Scheme_Object *form, Scheme_Comp_Env *env,
if (var && SAME_TYPE(SCHEME_TYPE(var), scheme_macro_type)
&& scheme_is_rename_transformer(SCHEME_PTR_VAL(var))) {
/* It's a rename. Look up the target name and try again. */
Scheme_Object *new_name;
new_name = scheme_rename_transformer_id(SCHEME_PTR_VAL(var));
if (!rec[drec].comp) {
new_name = scheme_stx_track(new_name, find_name, find_name);
}
find_name = scheme_transfer_srcloc(new_name, find_name);
SCHEME_USE_FUEL(1);
menv = NULL;
if (scheme_expansion_contexts_include(SCHEME_PTR_VAL(var),
scheme_frame_to_expansion_context_symbol(env->flags))) {
Scheme_Object *new_name;
new_name = scheme_rename_transformer_id(SCHEME_PTR_VAL(var));
if (!rec[drec].comp) {
new_name = scheme_stx_track(new_name, find_name, find_name);
}
find_name = scheme_transfer_srcloc(new_name, find_name);
SCHEME_USE_FUEL(1);
menv = NULL;
} else
break;
} else
break;
}
@ -4976,14 +5051,18 @@ compile_expand_expr(Scheme_Object *form, Scheme_Comp_Env *env,
}
SCHEME_EXPAND_OBSERVE_ENTER_MACRO(rec[drec].observer, form);
form = compile_expand_macro_app(name, menv, var, form, env, rec, drec, need_macro_scope);
SCHEME_EXPAND_OBSERVE_EXIT_MACRO(rec[drec].observer, form);
if (scheme_expansion_contexts_include(SCHEME_PTR_VAL(var),
scheme_frame_to_expansion_context_symbol(env->flags))) {
form = compile_expand_macro_app(name, menv, var, form, env, rec, drec, need_macro_scope);
if (env->expand_result_adjust) {
Scheme_Expand_Result_Adjust_Proc adjust;
adjust = env->expand_result_adjust;
form = adjust(form, env->expand_result_adjust_arg);
}
if (env->expand_result_adjust) {
Scheme_Expand_Result_Adjust_Proc adjust;
adjust = env->expand_result_adjust;
form = adjust(form, env->expand_result_adjust_arg);
}
} else
form = adjust_for_other_context(form, var, env);
SCHEME_EXPAND_OBSERVE_EXIT_MACRO(rec[drec].observer, form);
if (rec[drec].comp)
goto top;

1322
racket/src/racket/src/cstartup.inc
View File

File diff suppressed because it is too large Load Diff

29
racket/src/racket/src/eval.c
View File

@ -226,10 +226,10 @@ ROSYM static Scheme_Object *quote_symbol;
ROSYM static Scheme_Object *letrec_syntaxes_symbol;
ROSYM static Scheme_Object *begin_symbol;
ROSYM static Scheme_Object *let_values_symbol;
ROSYM static Scheme_Object *internal_define_symbol;
ROSYM static Scheme_Object *module_symbol;
ROSYM static Scheme_Object *module_begin_symbol;
ROSYM static Scheme_Object *expression_symbol;
ROSYM static Scheme_Object *definition_context_symbol;
ROSYM Scheme_Object *scheme_stack_dump_key;
READ_ONLY static Scheme_Object *zero_rands_ptr; /* &zero_rands_ptr is dummy rands pointer */
@ -332,15 +332,15 @@ scheme_init_eval (Scheme_Env *env)
REGISTER_SO(module_symbol);
REGISTER_SO(module_begin_symbol);
REGISTER_SO(internal_define_symbol);
REGISTER_SO(expression_symbol);
REGISTER_SO(top_level_symbol);
REGISTER_SO(definition_context_symbol);
module_symbol = scheme_intern_symbol("module");
module_begin_symbol = scheme_intern_symbol("module-begin");
internal_define_symbol = scheme_intern_symbol("internal-define");
expression_symbol = scheme_intern_symbol("expression");
top_level_symbol = scheme_intern_symbol("top-level");
definition_context_symbol = scheme_intern_symbol("definition-context");
REGISTER_SO(app_symbol);
REGISTER_SO(datum_symbol);
@ -4955,6 +4955,29 @@ static Scheme_Object *expand_stx(int argc, Scheme_Object **argv)
-1, -1, 0, scheme_false, 0, 0);
}
int scheme_is_expansion_context_symbol(Scheme_Object *v)
{
return (SAME_OBJ(v, module_symbol)
|| SAME_OBJ(v, module_begin_symbol)
|| SAME_OBJ(v, expression_symbol)
|| SAME_OBJ(v, top_level_symbol)
|| SAME_OBJ(v, definition_context_symbol));
}
Scheme_Object *scheme_frame_to_expansion_context_symbol(int flags)
{
if (flags & SCHEME_TOPLEVEL_FRAME)
return top_level_symbol;
else if (flags & SCHEME_MODULE_FRAME)
return module_symbol;
else if (flags & SCHEME_MODULE_BEGIN_FRAME)
return module_begin_symbol;
else if (flags & SCHEME_INTDEF_FRAME)
return definition_context_symbol;
else
return expression_symbol;
}
Scheme_Object *scheme_generate_lifts_key(void)
{
char buf[20];

2
racket/src/racket/src/schminc.h
View File

@ -14,7 +14,7 @@
#define USE_COMPILED_STARTUP 1
#define EXPECTED_PRIM_COUNT 1134
#define EXPECTED_PRIM_COUNT 1135
#define EXPECTED_UNSAFE_COUNT 106
#define EXPECTED_FLFXNUM_COUNT 69
#define EXPECTED_EXTFL_COUNT 45

4
racket/src/racket/src/schpriv.h
View File

@ -3378,6 +3378,10 @@ Scheme_Object *scheme_rename_transformer_id(Scheme_Object *o);
int scheme_is_set_transformer(Scheme_Object *o);
Scheme_Object *scheme_set_transformer_proc(Scheme_Object *o);
int scheme_is_expansion_context_symbol(Scheme_Object *v);
int scheme_expansion_contexts_include(Scheme_Object *o, Scheme_Object *ctx);
Scheme_Object *scheme_frame_to_expansion_context_symbol(int flags);
Scheme_Object *scheme_top_level_require_execute(Scheme_Object *data);
Scheme_Object *scheme_case_lambda_execute(Scheme_Object *expr);

4
racket/src/racket/src/schvers.h
View File

@ -13,12 +13,12 @@
consistently.)
*/
#define MZSCHEME_VERSION "6.2.900.11"
#define MZSCHEME_VERSION "6.2.900.12"
#define MZSCHEME_VERSION_X 6
#define MZSCHEME_VERSION_Y 2
#define MZSCHEME_VERSION_Z 900
#define MZSCHEME_VERSION_W 11
#define MZSCHEME_VERSION_W 12
#define MZSCHEME_VERSION_MAJOR ((MZSCHEME_VERSION_X * 100) + MZSCHEME_VERSION_Y)
#define MZSCHEME_VERSION_MINOR ((MZSCHEME_VERSION_Z * 1000) + MZSCHEME_VERSION_W)

59
racket/src/racket/src/struct.c
View File

@ -58,6 +58,7 @@ READ_ONLY static Scheme_Object *proc_property;
READ_ONLY static Scheme_Object *method_property;
READ_ONLY static Scheme_Object *rename_transformer_property;
READ_ONLY static Scheme_Object *set_transformer_property;
READ_ONLY static Scheme_Object *expansion_contexts_property;
READ_ONLY static Scheme_Object *not_free_id_symbol;
READ_ONLY static Scheme_Object *scheme_checked_proc_property;
READ_ONLY static Scheme_Object *struct_info_proc;
@ -117,6 +118,7 @@ static Scheme_Object *check_output_port_property_value_ok(int argc, Scheme_Objec
static Scheme_Object *check_cpointer_property_value_ok(int argc, Scheme_Object *argv[]);
static Scheme_Object *check_rename_transformer_property_value_ok(int argc, Scheme_Object *argv[]);
static Scheme_Object *check_set_transformer_property_value_ok(int argc, Scheme_Object *argv[]);
static Scheme_Object *check_expansion_contexts_property_value_ok(int argc, Scheme_Object *argv[]);
static Scheme_Object *check_checked_proc_property_value_ok(int argc, Scheme_Object *argv[]);
static Scheme_Object *unary_acc(int argc, Scheme_Object **argv, Scheme_Object *self);
@ -489,6 +491,18 @@ scheme_init_struct (Scheme_Env *env)
scheme_add_global_constant("prop:set!-transformer", set_transformer_property, env);
}
{
REGISTER_SO(expansion_contexts_property);
guard = scheme_make_prim_w_arity(check_expansion_contexts_property_value_ok,
"guard-for-prop:expansion-contexts",
2, 2);
expansion_contexts_property = scheme_make_struct_type_property_w_guard(scheme_intern_symbol("expansion-contexts"),
guard);
scheme_add_global_constant("prop:expansion-contexts", expansion_contexts_property, env);
}
{
guard = scheme_make_prim_w_arity(check_checked_proc_property_value_ok,
@ -1951,6 +1965,51 @@ static Scheme_Object *check_set_transformer_property_value_ok(int argc, Scheme_O
argc, argv);
}
/*========================================================================*/
/* expansion-contexts property */
/*========================================================================*/
static Scheme_Object *check_expansion_contexts_property_value_ok(int argc, Scheme_Object *argv[])
{
Scheme_Object *v;
v = argv[0];
while (SCHEME_PAIRP(v)) {
if (!scheme_is_expansion_context_symbol(SCHEME_CAR(v)))
break;
v = SCHEME_CDR(v);
}
if (SCHEME_NULLP(v))
return argv[0];
wrong_property_contract("guard-for-prop:expression-contexts",
"(lisrof (or/c 'expression 'top-level 'module 'module-begin 'definition-context)",
v);
return NULL;
}
int scheme_expansion_contexts_include(Scheme_Object *o, Scheme_Object *ctx)
{
Scheme_Object *v;
if (SCHEME_CHAPERONE_STRUCTP(o)) {
v = scheme_chaperone_struct_type_property_ref(expansion_contexts_property, o);
if (v) {
while (!SCHEME_NULLP(v)) {
if (SAME_OBJ(SCHEME_CAR(v), ctx))
return 1;
v = SCHEME_CDR(v);
}
return 0;
}
}
return 1;
}
/*========================================================================*/
/* checked-proc property */
/*========================================================================*/