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

allow gensym' and string->uninterned-symbol' in cross-phase persistent

Browse Source
This commit is contained in:
Matthew Flatt 2013-07-22 12:26:57 -06:00
parent 9e2cf2ab37
commit 9f4420b07a
3 changed files with 71 additions and 7 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

8
pkgs/racket-pkgs/racket-doc/scribblings/reference/syntax-model.scrbl
View File

@ -1004,7 +1004,8 @@ and only if no module-level binding is @racket[set!]ed.
#%plain-lambda case-lambda begin
set! quote-syntax quote with-continuation-mark
#%plain-app
cons list make-struct-type make-struct-type-property)
cons list make-struct-type make-struct-type-property
gensym string->uninterned-symbol)
[cross-module (module id module-path
(#%plain-module-begin
cross-form ...))]
@ -1022,7 +1023,10 @@ and only if no module-level binding is @racket[set!]ed.
(#%plain-app list cross-expr ...+)
(#%plain-app make-struct-type cross-expr ...+)
(#%plain-app make-struct-type-property
cross-expr ...+)]
cross-expr ...+)
(#%plain-app gensym)
(#%plain-app gensym string)
(#%plain-app string->uninterned-symbol string)]
[cross-datum number
boolean
identifier

10
pkgs/racket-pkgs/racket-test/tests/racket/cross-phase.rkt
View File

@ -25,6 +25,7 @@
(check-cross-phase #t '(define-values (x) cons))
(check-cross-phase #t '(define-values (x) (cons 1 2)))
(check-cross-phase #t '(define-values (x) (list 1 2)))
(check-cross-phase #t '(define-values (x) (#%app list 1 2)))
(check-cross-phase #t '(define-values (x) (cons 1 '())))
(check-cross-phase #t '(#%require racket/tcp))
(check-cross-phase #t '(define-values (x) (lambda (x) x)))
@ -36,6 +37,13 @@
(check-cross-phase #t '(begin
(define-values (x) 5)
(define-values (y) 6)))
(check-cross-phase #t '(define-values (x) (gensym)))
(check-cross-phase #t '(define-values (x) (gensym "s")))
(check-cross-phase #t '(define-values (x) (gensym '"s")))
(check-cross-phase #t '(define-values (x) (#%app gensym '"s")))
(check-cross-phase #t '(define-values (x) (string->uninterned-symbol "s")))
(check-cross-phase #t '(define-values (x) (string->uninterned-symbol '"s")))
(check-cross-phase #t '(define-values (x) (#%app string->uninterned-symbol '"s")))
(check-cross-phase #f '(define-values (x) #(x)))
(check-cross-phase #f '(define-values (x) '(x)))
@ -47,6 +55,8 @@
(check-cross-phase #f '(define-values (x) (lambda () (if #f (#%variable-reference) 10))))
(check-cross-phase #f '(define-values (x) (#%variable-reference x)))
(check-cross-phase #f '(#%require racket/base))
(check-cross-phase #f '(define-values (x) (gensym 1)))
(check-cross-phase #f '(define-values (x) (string->uninterned-symbol)))
(check-cross-phase #t '(module* sub #f (vector 1 2 3)))
(check-cross-phase #t '(module* sub #f (#%variable-reference)))

58
racket/src/racket/src/module.c
View File

@ -246,6 +246,8 @@ READ_ONLY static Scheme_Object *make_struct_type_stx;
READ_ONLY static Scheme_Object *make_struct_type_property_stx;
READ_ONLY static Scheme_Object *list_stx;
READ_ONLY static Scheme_Object *cons_stx;
READ_ONLY static Scheme_Object *gensym_stx;
READ_ONLY static Scheme_Object *string_to_uninterned_symbol_stx;
READ_ONLY static Scheme_Object *empty_self_modidx;
READ_ONLY static Scheme_Object *empty_self_modname;
@ -687,11 +689,16 @@ void scheme_finish_kernel(Scheme_Env *env)
REGISTER_SO(make_struct_type_property_stx);
REGISTER_SO(cons_stx);
REGISTER_SO(list_stx);
REGISTER_SO(gensym_stx);
REGISTER_SO(string_to_uninterned_symbol_stx);
make_struct_type_stx = scheme_datum_to_syntax(scheme_intern_symbol("make-struct-type"), scheme_false, w, 0, 0);
make_struct_type_property_stx = scheme_datum_to_syntax(scheme_intern_symbol("make-struct-type-property"), scheme_false, w, 0, 0);
cons_stx = scheme_datum_to_syntax(scheme_intern_symbol("cons"), scheme_false, w, 0, 0);
list_stx = scheme_datum_to_syntax(scheme_intern_symbol("list"), scheme_false, w, 0, 0);
gensym_stx = scheme_datum_to_syntax(scheme_intern_symbol("gensym"), scheme_false, w, 0, 0);
string_to_uninterned_symbol_stx = scheme_datum_to_syntax(scheme_intern_symbol("string->uninterned-symbol"),
scheme_false, w, 0, 0);
REGISTER_SO(prefix_symbol);
REGISTER_SO(only_symbol);
@ -11328,11 +11335,8 @@ static int expression_starts(Scheme_Object *expr, Scheme_Object *id, int phase)
static int expression_starts_app(Scheme_Object *expr, Scheme_Object *id, int phase)
{
if (expression_starts(expr, app_stx, phase)) {
expr = SCHEME_STX_CDR(expr);
if (SCHEME_STX_PAIRP(expr)) {
expr = SCHEME_STX_CDR(expr);
return expression_starts(expr, id, phase);
}
} else if (expression_starts(expr, id, phase)) {
/* would explicit `#%app' be the core one? */
id = scheme_datum_to_syntax(SCHEME_STX_VAL(app_stx), expr, expr, 0, 0);
@ -11344,6 +11348,15 @@ static int expression_starts_app(Scheme_Object *expr, Scheme_Object *id, int pha
return 0;
}
static Scheme_Object *expression_app_args(Scheme_Object *expr, int phase)
{
if (expression_starts(expr, app_stx, phase)) {
expr = SCHEME_STX_CDR(expr);
return SCHEME_STX_CDR(expr);
} else
return SCHEME_STX_CDR(expr);
}
static int phaseless_literal(Scheme_Object *val)
{
val = SCHEME_STX_VAL(val);
@ -11436,10 +11449,36 @@ static int phaseless_constant_expression(Scheme_Object *val, int phase)
if (expression_starts_app(val, cons_stx, phase)
|| expression_starts_app(val, list_stx, phase)) {
val = SCHEME_STX_CDR(val);
val = expression_app_args(val, phase);
return phaseless_constant_expressions(val, phase);
}
return 0;
}
static int expression_string_argument(Scheme_Object *val, int phase)
{
Scheme_Object *a, *av;
if (SCHEME_STX_PAIRP(val)) {
a = SCHEME_STX_CAR(val);
val = SCHEME_STX_CDR(val);
if (SCHEME_STX_NULLP(val)) {
av = SCHEME_STX_VAL(a);
if (SCHEME_CHAR_STRINGP(av)
&& phaseless_constant_expression(a, phase))
return 1;
else if (expression_starts(a, quote_stx, phase)) {
val = SCHEME_STX_CDR(a);
if (SCHEME_STX_PAIRP(val)) {
val = SCHEME_STX_CAR(val);
a = SCHEME_STX_VAL(val);
if (SCHEME_CHAR_STRINGP(a))
return 1;
}
}
}
}
return 0;
}
@ -11449,6 +11488,17 @@ static int phaseless_rhs(Scheme_Object *val, int var_count, int phase)
if (var_count == 1) {
if (phaseless_constant_expression(val, phase))
return 1;
else if (expression_starts_app(val, gensym_stx, phase)) {
val = expression_app_args(val, phase);
if (SCHEME_STX_NULLP(val))
return 1;
else if (expression_string_argument(val, phase))
return 1;
} else if (expression_starts_app(val, string_to_uninterned_symbol_stx, phase)) {
val = expression_app_args(val, phase);
if (expression_string_argument(val, phase))
return 1;
}
} else if (var_count == 5) {
if (expression_starts_app(val, make_struct_type_stx, phase)
&& phaseless_constant_expressions(val, phase)) {