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

add `prop:liberal-define-context'

Browse Source
This commit is contained in:
Matthew Flatt 2011-08-07 13:16:32 -06:00
parent ff024068d9
commit 39a96dd699
11 changed files with 477 additions and 375 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

8
collects/racket/block.rkt
View File

@ -13,12 +13,18 @@
(#%provide block)
(define-values-for-syntax (make-context)
(let-values ([(struct: mk ? ref set)
(make-struct-type 'in-liberal-define-context #f 0 0 #f
(list (cons prop:liberal-define-context #t)))])
mk))
(define-syntax (block stx)
;; Body can have mixed exprs and defns. Wrap expressions with
;; `(define-values () ... (values))' as needed, and add a (void)
;; at the end if needed.
(let* ([def-ctx (syntax-local-make-definition-context)]
[ctx (list (gensym 'intdef))]
[ctx (list (make-context))]
;; [kernel-forms (kernel-form-identifier-list)]
[stoplist (list #'begin #'define-syntaxes #'define-values)]
[init-exprs (let ([v (syntax->list stx)])

9
collects/racket/package.rkt
View File

@ -4,7 +4,8 @@
syntax/kerncase
syntax/boundmap
syntax/define
syntax/flatten-begin))
syntax/flatten-begin
syntax/context))
(provide define-package
package-begin
@ -141,11 +142,7 @@
stx
exports)])])
(let* ([def-ctx (syntax-local-make-definition-context)]
[ctx (cons (gensym 'intdef)
(let ([orig-ctx (syntax-local-context)])
(if (pair? orig-ctx)
orig-ctx
null)))]
[ctx (generate-expand-context #t)]
[pre-package-id (lambda (id def-ctxes)
(identifier-remove-from-definition-context
id

5
collects/racket/private/kw.rkt
View File

@ -785,7 +785,10 @@
(define #,id #,rhs)))])
(syntax-case rhs ()
[(lam-id . _)
(and (memq (syntax-local-context) '(top-level module module-begin))
(and (let ([ctx (syntax-local-context)])
(or (memq ctx '(top-level module module-begin))
(and (list? ctx)
(andmap liberal-define-context? ctx))))
(identifier? #'lam-id)
(or (free-identifier=? #'lam-id #'new-lambda)
(free-identifier=? #'lam-id #'new-λ)))

34
collects/scribblings/reference/stx-trans.scrbl
View File

@ -194,9 +194,8 @@ with an empty context is used, instead.}
Expands @racket[stx] in the lexical context of the expression
currently being expanded. The @racket[context-v] argument is used as
the result of @racket[syntax-local-context] for immediate expansions;
for a particular @tech{internal-definition context}, generate a unique
value and @racket[cons] it onto the current result of
@racket[syntax-local-context] if it is a list.
a list indicates an @tech{internal-definition context}, and more
information on the form of the list is below.
When an identifier in @racket[stop-ids] is encountered by the expander
in a sub-expression, expansions stops for the sub-expression. If
@ -226,6 +225,17 @@ internal definitions is added to @racket[stx] before it is expanded
also added to the expansion result (because the expansion might
introduce bindings or references to internal-definition bindings).
For a particular @tech{internal-definition context}, generate a unique
value and put it into a list for @racket[context-v]. To allow
@tech{liberal expansion} of @racket[define] forms, the generated value
should be an instance of a structure with a true value for
@racket[prop:liberal-define-context]. If the internal-definition
context is meant to be self-contained, the list for @racket[context-c]
should contain only the generated value; if the internal-definition
context is meant to splice into an immediately enclosing context, then
when @racket[syntax-local-context] produces a list, @racket[cons] the
generated value onto that list.
@transform-time[]
@examples[#:eval stx-eval
@ -777,6 +787,24 @@ includes the identifier by its internal name. Use
@racket[identifier-binding] to obtain more information about the
identifier.}
@deftogether[(
@defthing[prop:liberal-define-context struct-type-property?]
@defproc[(liberal-define-context? [v any/c]) boolean?]
)]{
An instance of a structure type with a true value for the
@racket[prop:liberal-define-context] property can be used as an
element of an @tech{internal-definition context} representation in the
result of @racket[syntax-local-context] for the second argument of
@racket[local-expand]. Such a value indicates that the context
supports @deftech{liberal expansion} of @racket[define] forms into
potentially multiple @racket[define-values] and
@racket[define-syntaxes] forms.
The @racket[liberal-define-context?] predicate returns @racket[#t] if
@arcket[v] is an instance of a structure with a true value for the
@racket[prop:liberal-define-context] property, @racket[#f] otherwise.}
@; ----------------------------------------------------------------------
@section[#:tag "require-trans"]{@racket[require] Transformers}

10
collects/syntax/context.rkt
View File

@ -1,4 +1,4 @@
#lang scheme/base
#lang racket/base
(provide build-expand-context
generate-expand-context)
@ -9,6 +9,10 @@
(cons v c)
(list v))))
(define (generate-expand-context)
(build-expand-context (gensym 'internal-define)))
(struct in-liberal-define-context ()
#:property prop:liberal-define-context #t)
(define (generate-expand-context [liberal-definitions? #f])
(build-expand-context (if liberal-definitions?
(in-liberal-define-context)
(gensym 'internal-define))))

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

@ -5369,7 +5369,8 @@ compile_expand_block(Scheme_Object *forms, Scheme_Comp_Env *env,
d[0] = env;
SCHEME_PTR1_VAL(ctx) = d;
SCHEME_PTR2_VAL(ctx) = rib;
ectx = scheme_make_pair(ctx, scheme_null);
ectx = scheme_make_pair(scheme_make_struct_instance(scheme_liberal_def_ctx_type, 0, NULL),
scheme_null);
scheme_begin_dup_symbol_check(&r, env);
try_again:

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

File diff suppressed because it is too large Load Diff

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

@ -13,7 +13,7 @@
#define USE_COMPILED_STARTUP 1
#define EXPECTED_PRIM_COUNT 1027
#define EXPECTED_PRIM_COUNT 1029
#define EXPECTED_UNSAFE_COUNT 78
#define EXPECTED_FLFXNUM_COUNT 68
#define EXPECTED_FUTURES_COUNT 11

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

@ -388,6 +388,8 @@ extern Scheme_Object *scheme_raise_arity_error_proc;
extern Scheme_Object *scheme_date;
#endif
extern Scheme_Object *scheme_liberal_def_ctx_type;
extern Scheme_Object *scheme_module_stx;
extern Scheme_Object *scheme_begin_stx;
extern Scheme_Object *scheme_module_begin_stx;

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

@ -13,12 +13,12 @@
consistently.)
*/
#define MZSCHEME_VERSION "5.1.2.3"
#define MZSCHEME_VERSION "5.1.2.4"
#define MZSCHEME_VERSION_X 5
#define MZSCHEME_VERSION_Y 1
#define MZSCHEME_VERSION_Z 2
#define MZSCHEME_VERSION_W 3
#define MZSCHEME_VERSION_W 4
#define MZSCHEME_VERSION_MAJOR ((MZSCHEME_VERSION_X * 100) + MZSCHEME_VERSION_Y)
#define MZSCHEME_VERSION_MINOR ((MZSCHEME_VERSION_Z * 1000) + MZSCHEME_VERSION_W)

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

@ -40,6 +40,7 @@ READ_ONLY Scheme_Object *scheme_recur_symbol;
READ_ONLY Scheme_Object *scheme_display_symbol;
READ_ONLY Scheme_Object *scheme_write_special_symbol;
READ_ONLY Scheme_Object *scheme_app_mark_impersonator_property;
READ_ONLY Scheme_Object *scheme_liberal_def_ctx_type;;
READ_ONLY static Scheme_Object *location_struct;
READ_ONLY static Scheme_Object *write_property;
@ -99,6 +100,8 @@ static Scheme_Object *check_rename_transformer_property_value_ok(int argc, Schem
static Scheme_Object *check_set_transformer_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);
static Scheme_Object *make_struct_type(int argc, Scheme_Object *argv[]);
static Scheme_Object *make_struct_field_accessor(int argc, Scheme_Object *argv[]);
@ -171,6 +174,8 @@ static Scheme_Object *make_chaperone_property(int argc, Scheme_Object *argv[]);
static Scheme_Object *make_chaperone_property_from_c(Scheme_Object *name);
static Scheme_Object *is_liberal_def_ctx(int argc, Scheme_Object **argv, Scheme_Object *self);
#define PRE_REDIRECTS 2
#ifdef MZ_PRECISE_GC
@ -294,7 +299,13 @@ scheme_init_struct (Scheme_Env *env)
scheme_struct_property_type);
scheme_add_global_constant("prop:custom-write", write_property, env);
scheme_add_global_constant("custom-write?", pred, env);
scheme_add_global_constant("custom-write-accessor", access, env);
a[0] = access;
scheme_add_global_constant("custom-write-accessor",
scheme_make_prim_closure_w_arity(unary_acc, 1, a,
"custom-write-accessor",
1, 1),
env);
}
REGISTER_SO(print_attribute_property);
@ -310,7 +321,13 @@ scheme_init_struct (Scheme_Env *env)
scheme_struct_property_type);
scheme_add_global_constant("prop:custom-print-quotable", print_attribute_property, env);
scheme_add_global_constant("custom-print-quotable?", pred, env);
scheme_add_global_constant("custom-print-quotable-accessor", access, env);
a[0] = access;
scheme_add_global_constant("custom-print-quotable-accessor",
scheme_make_prim_closure_w_arity(unary_acc, 1, a,
"custom-print-quotable-accessor",
1, 1),
env);
}
REGISTER_SO(evt_property);
@ -419,6 +436,27 @@ scheme_init_struct (Scheme_Env *env)
scheme_add_global_constant("prop:checked-procedure", scheme_checked_proc_property, env);
}
REGISTER_SO(scheme_liberal_def_ctx_type);
{
Scheme_Object *a[1], *prop, *pred, *access;
a[0] = scheme_intern_symbol("liberal-define-context");
prop = make_struct_type_property_from_c(1, a, &pred, &access,
scheme_struct_property_type);
scheme_add_global_constant("prop:liberal-define-context", prop, env);
a[0] = prop;
scheme_add_global_constant("liberal-define-context?",
scheme_make_prim_closure_w_arity(is_liberal_def_ctx, 1, a,
"liberal-define-context?",
1, 1),
env);
scheme_liberal_def_ctx_type = scheme_make_struct_type_from_string("liberal-define-context", NULL, 0,
cons(cons(prop, scheme_true), scheme_null),
NULL, 1);
}
REGISTER_SO(not_free_id_symbol);
not_free_id_symbol = scheme_intern_symbol("not-free-identifier=?");
@ -1107,7 +1145,7 @@ static Scheme_Object *make_struct_type_property_from_c(int argc, Scheme_Object *
memcpy(name, SCHEME_SYM_VAL(argv[0]), len);
memcpy(name + len, "-accessor", 10);
v = scheme_make_folding_prim_closure(prop_accessor, 1, a, name, 1, 2, 0);
v = scheme_make_prim_closure_w_arity(prop_accessor, 1, a, name, 1, 2);
((Scheme_Closed_Primitive_Proc *)v)->pp.flags |= (SCHEME_PRIM_IS_STRUCT_OTHER
| SCHEME_PRIM_TYPE_STRUCT_PROP_GETTER);
@ -1602,6 +1640,13 @@ Scheme_Object *scheme_print_attribute_ref(Scheme_Object *s)
return scheme_struct_type_property_ref(print_attribute_property, s);
}
static Scheme_Object *unary_acc(int argc, Scheme_Object **argv, Scheme_Object *self)
{
Scheme_Object *acc = SCHEME_PRIM_CLOSURE_ELS(self)[0];
return _scheme_apply(acc, argc, argv);
}
/*========================================================================*/
/* rename and set! transformer properties */
/*========================================================================*/
@ -1788,6 +1833,22 @@ Scheme_Object *scheme_extract_checked_procedure(int argc, Scheme_Object **argv)
return _scheme_apply(argv[2], 3, a);
}
/*========================================================================*/
/* liberal-define */
/*========================================================================*/
static Scheme_Object *is_liberal_def_ctx(int argc, Scheme_Object **argv, Scheme_Object *self)
{
Scheme_Object *prop = SCHEME_PRIM_CLOSURE_ELS(self)[0], *val;
val = scheme_struct_type_property_ref(prop, argv[0]);
if (!val || SCHEME_FALSEP(val))
return scheme_false;
else
return scheme_true;
}
/*========================================================================*/
/* struct ops */
/*========================================================================*/