make syntax objects work as preserved syntax properties
Syntax objects generally make sense as properties in other syntax objects, but they require special care when marshaling to bytecode (as syntax objects do in general). To make that special handling possible and reliable, constrain the shape of allowed values.
This commit is contained in:
Matthew Flatt
parent
f549724e36
commit
99b3ed55be
|
|
@ -118,13 +118,39 @@ an arbitrary property value @racket[v] with the key @racket[key]; the
|
|||
result is a new syntax object with the association (while @racket[stx]
|
||||
itself is unchanged). The property is added as @tech{preserved} if
|
||||
@racket[preserved?] is true, in which case @racket[key] must be an
|
||||
@tech{interned} symbol, and @racket[v] should be a value can itself
|
||||
be saved in marshaled bytecode.
|
||||
@tech{interned} symbol, and @racket[v] should be a value as described
|
||||
below that can be saved in marshaled bytecode.
|
||||
|
||||
The two-argument form returns an arbitrary property value associated
|
||||
to @racket[stx] with the key @racket[key], or @racket[#f] if no value
|
||||
is associated to @racket[stx] for @racket[key].
|
||||
|
||||
To support marshaling to bytecode, a value for a preserved syntax
|
||||
property must be a non-cyclic value that is either
|
||||
|
||||
@itemlist[
|
||||
|
||||
@item{a @tech{pair} containing allowed preserved-property values;}
|
||||
|
||||
@item{a @tech{vector} (unmarshaled as immutable) containing allowed preserved-property values;}
|
||||
|
||||
@item{a @tech{box} (unmarshaled as immutable) containing allowed preserved-property values;}
|
||||
|
||||
@item{an immutable @tech{prefab} structure containing allowed preserved-property values;}
|
||||
|
||||
@item{an immutable @tech{hash table} whose keys and values are allowed preserved-property values;}
|
||||
|
||||
@item{a @tech{syntax object}; or}
|
||||
|
||||
@item{an empty list, @tech{symbol}, @tech{number}, @tech{character},
|
||||
@tech{string}, @tech{byte string}, or @tech{regexp
|
||||
value}.}
|
||||
|
||||
]
|
||||
|
||||
Any other value for a preserved property triggers an exception at an
|
||||
attempt to marshal the owning syntax object to bytecode form.
|
||||
|
||||
@history[#:changed "6.4.0.14" @elem{Added the @racket[preserved?] argument.}]}
|
||||
|
||||
|
||||
|
|
|
|||
|
|
@ -2365,7 +2365,36 @@
|
|||
(test 3.0 syntax-property s2 'a-third-thing)
|
||||
(test 3.0 syntax-property s2-0 'a-third-thing)
|
||||
(test #t syntax-property-preserved? s2 'a-third-thing)
|
||||
(test #t syntax-property-preserved? s2-0 'a-third-thing))
|
||||
(test #t syntax-property-preserved? s2-0 'a-third-thing)
|
||||
|
||||
;; Check value encoding and decoding:
|
||||
(define prop-val (list 1
|
||||
1.0
|
||||
(vector-immutable 'a "apple" #"apple")
|
||||
(vector-immutable)
|
||||
(vector 7 8 9)
|
||||
(hash 'a 1 'b 2)
|
||||
(hasheq 'a 1 'b 2)
|
||||
(box-immutable 3/4)
|
||||
(box 'b)
|
||||
#rx"."))
|
||||
(define s3 (syntax-property #'3 'saved prop-val #t))
|
||||
(test prop-val syntax-property (zo-bounce s3) 'saved)
|
||||
|
||||
(define s4 (syntax-property #'4 'saved-stx (vector-immutable s3 #'cons) #t))
|
||||
(define p-v (syntax-property (zo-bounce s4) 'saved-stx))
|
||||
(test #t vector? p-v)
|
||||
(test prop-val syntax-property (vector-ref p-v 0) 'saved)
|
||||
(test #t free-identifier=? #'cons (vector-ref p-v 1))
|
||||
|
||||
(define (check-bad val)
|
||||
(err/rt-test (zo-bounce (syntax-property #'#f 'saved val #t))
|
||||
(lambda (exn) (regexp-match #rx"write: disallowed" (exn-message exn)))))
|
||||
|
||||
(check-bad (lambda (x) x))
|
||||
(check-bad (mcons 1 2))
|
||||
(check-bad (read (open-input-string "#0=(1 . #0#)")))
|
||||
(check-bad void))
|
||||
|
||||
;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
|
||||
|
|
|
|||
|
|
@ -181,6 +181,16 @@ static void sort_scope_array(Scheme_Object **a, intptr_t count);
|
|||
static void sort_symbol_array(Scheme_Object **a, intptr_t count);
|
||||
static void sort_number_array(Scheme_Object **a, intptr_t count);
|
||||
|
||||
static Scheme_Object *syntax_to_datum_inner(Scheme_Object *o,
|
||||
int with_scopes,
|
||||
Scheme_Marshal_Tables *mt);
|
||||
static Scheme_Object *datum_to_syntax_inner(Scheme_Object *o,
|
||||
Scheme_Unmarshal_Tables *ut,
|
||||
Scheme_Stx *stx_src,
|
||||
Scheme_Stx *stx_wraps,
|
||||
Scheme_Hash_Table *ht,
|
||||
int tainted);
|
||||
|
||||
XFORM_NONGCING static void extract_module_binding_parts(Scheme_Object *l,
|
||||
Scheme_Object *phase,
|
||||
Scheme_Object **_insp_desc,
|
||||
|
|
@ -6400,6 +6410,176 @@ static Scheme_Object *srcloc_path_to_string(Scheme_Object *p)
|
|||
return scheme_false;
|
||||
}
|
||||
|
||||
static Scheme_Object *convert_prop_val_k(void);
|
||||
|
||||
static Scheme_Object *convert_prop_val(Scheme_Object *val, Scheme_Marshal_Tables *mt,
|
||||
Scheme_Unmarshal_Tables *ut,
|
||||
Scheme_Hash_Tree *seen)
|
||||
/* Encode or decode a property value to encode/decode syntax objects
|
||||
contained in the value. In encode mode, an exception is raised if any
|
||||
disallowed value is found. In decoding mode, the result is NULL
|
||||
if decoding fails. */
|
||||
{
|
||||
#ifdef DO_STACK_CHECK
|
||||
{
|
||||
# include "mzstkchk.h"
|
||||
{
|
||||
Scheme_Thread *p = scheme_current_thread;
|
||||
|
||||
p->ku.k.p1 = (void *)val;
|
||||
p->ku.k.p2 = (void *)mt;
|
||||
p->ku.k.p3 = (void *)ut;
|
||||
p->ku.k.p4 = (void *)seen;
|
||||
|
||||
return scheme_handle_stack_overflow(convert_prop_val_k);
|
||||
}
|
||||
}
|
||||
#endif
|
||||
|
||||
if (scheme_hash_tree_get(seen, val)) {
|
||||
if (mt)
|
||||
scheme_raise_exn(MZEXN_FAIL,
|
||||
"write: disallowed cycle within preserved syntax property\n value: %V",
|
||||
val);
|
||||
return NULL;
|
||||
}
|
||||
|
||||
if (SCHEME_PAIRP(val)) {
|
||||
Scheme_Object *a, *d;
|
||||
seen = scheme_hash_tree_set(seen, val, scheme_true);
|
||||
a = convert_prop_val(SCHEME_CAR(val), mt, ut, seen);
|
||||
d = convert_prop_val(SCHEME_CDR(val), mt, ut, seen);
|
||||
if (a && d)
|
||||
return CONS(a, d);
|
||||
else
|
||||
return NULL;
|
||||
} else if (mt ? SCHEME_BOXP(val) : SCHEME_IMMUTABLE_BOXP(val)) {
|
||||
Scheme_Object *c;
|
||||
seen = scheme_hash_tree_set(seen, val, scheme_true);
|
||||
c = convert_prop_val(SCHEME_BOX_VAL(val), mt, ut, seen);
|
||||
if (c) {
|
||||
c = scheme_box(c);
|
||||
SCHEME_SET_IMMUTABLE(c);
|
||||
return c;
|
||||
} else
|
||||
return NULL;
|
||||
} else if (mt ? SCHEME_VECTORP(val) : SCHEME_IMMUTABLE_VECTORP(val)) {
|
||||
intptr_t len = SCHEME_VEC_SIZE(val);
|
||||
if (ut && (len == 2) && SCHEME_TRUEP(SCHEME_VEC_ELS(val)[0])) {
|
||||
/* A vector that starts #t encodes a syntax object */
|
||||
return datum_to_syntax_inner(SCHEME_VEC_ELS(val)[1],
|
||||
ut,
|
||||
(Scheme_Stx *)scheme_false,
|
||||
(Scheme_Stx *)scheme_false,
|
||||
NULL,
|
||||
0);
|
||||
} else if (len) {
|
||||
int start, offset;
|
||||
Scheme_Object *vec, *v;
|
||||
intptr_t i;
|
||||
if (mt) {
|
||||
/* Encode a vector in a vectot that starts #f */
|
||||
vec = scheme_make_vector(len+1, scheme_false);
|
||||
offset = 1;
|
||||
start = 0;
|
||||
} else {
|
||||
/* Decode from a vector that starts #f */
|
||||
if (len < 1) return NULL;
|
||||
if (!SCHEME_FALSEP(SCHEME_VEC_ELS(val)[0])) return NULL;
|
||||
vec = scheme_make_vector(len-1, scheme_false);
|
||||
offset = -1;
|
||||
start = 1;
|
||||
}
|
||||
seen = scheme_hash_tree_set(seen, val, scheme_true);
|
||||
for (i = start; i < len; i++) {
|
||||
v = convert_prop_val(SCHEME_VEC_ELS(val)[i], mt, ut, seen);
|
||||
if (!v)
|
||||
return NULL;
|
||||
SCHEME_VEC_ELS(vec)[i+offset] = v;
|
||||
}
|
||||
SCHEME_SET_IMMUTABLE(vec);
|
||||
return vec;
|
||||
} else
|
||||
return val;
|
||||
} else if (prefab_p(val)) {
|
||||
Scheme_Structure *s = (Scheme_Structure *)val;
|
||||
Scheme_Object *a;
|
||||
int size = s->stype->num_slots, i;
|
||||
|
||||
seen = scheme_hash_tree_set(seen, val, scheme_true);
|
||||
|
||||
s = (Scheme_Structure *)scheme_clone_prefab_struct_instance(s);
|
||||
for (i = 0; i < size; i++) {
|
||||
a = convert_prop_val(s->slots[i], mt, ut, seen);
|
||||
if (!a)
|
||||
return NULL;
|
||||
s->slots[i] = a;
|
||||
}
|
||||
|
||||
return (Scheme_Object *)s;
|
||||
} else if (SCHEME_HASHTRP(val)) {
|
||||
Scheme_Hash_Tree *ht = (Scheme_Hash_Tree *)val, *ht2;
|
||||
Scheme_Object *key, *tval;
|
||||
mzlonglong i;
|
||||
|
||||
seen = scheme_hash_tree_set(seen, val, scheme_true);
|
||||
|
||||
ht2 = scheme_make_hash_tree_of_type(SCHEME_HASHTR_TYPE(ht));
|
||||
|
||||
i = scheme_hash_tree_next(ht, -1);
|
||||
while (i != -1) {
|
||||
scheme_hash_tree_index(ht, i, &key, &tval);
|
||||
tval = convert_prop_val(tval, mt, ut, seen);
|
||||
if (!tval)
|
||||
return NULL;
|
||||
ht2 = scheme_hash_tree_set(ht2, key, tval);
|
||||
i = scheme_hash_tree_next(ht, i);
|
||||
}
|
||||
|
||||
return (Scheme_Object *)ht2;
|
||||
} else if (SCHEME_STXP(val)) {
|
||||
/* Encode a syntax object in a vectot that starts #t */
|
||||
Scheme_Object *v;
|
||||
if (!mt)
|
||||
return NULL;
|
||||
v = syntax_to_datum_inner(val, 1, mt);
|
||||
v = scheme_make_vector(2, v);
|
||||
SCHEME_VEC_ELS(v)[0] = scheme_true;
|
||||
return v;
|
||||
} else if (SCHEME_BOOLP(val)
|
||||
|| SCHEME_NULLP(val)
|
||||
|| SCHEME_SYMBOLP(val)
|
||||
|| SCHEME_CHARP(val)
|
||||
|| SCHEME_NUMBERP(val)
|
||||
|| SCHEME_BYTE_STRINGP(val)
|
||||
|| SCHEME_CHAR_STRINGP(val)
|
||||
|| SAME_TYPE(SCHEME_TYPE(val), scheme_regexp_type)) {
|
||||
return val;
|
||||
} else {
|
||||
if (mt)
|
||||
scheme_raise_exn(MZEXN_FAIL,
|
||||
"write: disallowed value within preserved syntax property\n value: %V",
|
||||
val);
|
||||
return NULL;
|
||||
}
|
||||
}
|
||||
|
||||
static Scheme_Object *convert_prop_val_k(void)
|
||||
{
|
||||
Scheme_Thread *p = scheme_current_thread;
|
||||
Scheme_Object *val = (Scheme_Object *)p->ku.k.p1;
|
||||
Scheme_Marshal_Tables *mt = (Scheme_Marshal_Tables *)p->ku.k.p2;
|
||||
Scheme_Unmarshal_Tables *ut = (Scheme_Unmarshal_Tables *)p->ku.k.p3;
|
||||
Scheme_Hash_Tree *seen = (Scheme_Hash_Tree *)p->ku.k.p4;
|
||||
|
||||
p->ku.k.p1 = NULL;
|
||||
p->ku.k.p2 = NULL;
|
||||
p->ku.k.p3 = NULL;
|
||||
p->ku.k.p4 = NULL;
|
||||
|
||||
return convert_prop_val(val, mt, ut, seen);
|
||||
}
|
||||
|
||||
static Scheme_Object *convert_srcloc(Scheme_Stx_Srcloc *srcloc, Scheme_Hash_Tree *props, Scheme_Marshal_Tables *mt)
|
||||
{
|
||||
Scheme_Object *vec, *paren, *src, *dir, *preserved_properties;
|
||||
|
|
@ -6467,7 +6647,8 @@ static Scheme_Object *convert_srcloc(Scheme_Stx_Srcloc *srcloc, Scheme_Hash_Tree
|
|||
sort_symbol_array(a, count);
|
||||
for (i = count; i--; ) {
|
||||
val = scheme_hash_tree_get(props, a[i]);
|
||||
preserved_properties = CONS(CONS(a[i], SCHEME_PTR_VAL(val)), preserved_properties);
|
||||
val = convert_prop_val(SCHEME_PTR_VAL(val), mt, NULL, empty_hash_tree);
|
||||
preserved_properties = CONS(CONS(a[i], val), preserved_properties);
|
||||
}
|
||||
}
|
||||
}
|
||||
|
|
@ -6491,7 +6672,7 @@ static Scheme_Object *convert_srcloc(Scheme_Stx_Srcloc *srcloc, Scheme_Hash_Tree
|
|||
return intern_one(vec, mt->intern_map);
|
||||
}
|
||||
|
||||
static void unconvert_srcloc(Scheme_Object *srcloc_vec, Scheme_Stx *dest)
|
||||
static void unconvert_srcloc(Scheme_Object *srcloc_vec, Scheme_Stx *dest, Scheme_Unmarshal_Tables *ut)
|
||||
{
|
||||
Scheme_Stx_Srcloc *srcloc;
|
||||
|
||||
|
|
@ -6523,28 +6704,27 @@ static void unconvert_srcloc(Scheme_Object *srcloc_vec, Scheme_Stx *dest)
|
|||
|
||||
if (SCHEME_VEC_SIZE(srcloc_vec) > 6) {
|
||||
/* Restore preserved properties */
|
||||
Scheme_Object *l = SCHEME_VEC_ELS(srcloc_vec)[6], *p;
|
||||
Scheme_Object *l = SCHEME_VEC_ELS(srcloc_vec)[6], *p, *v;
|
||||
Scheme_Hash_Tree *props;
|
||||
while (SCHEME_PAIRP(l)) {
|
||||
p = SCHEME_CAR(l);
|
||||
if (SCHEME_PAIRP(p)
|
||||
&& SCHEME_SYMBOLP(SCHEME_CAR(p))
|
||||
&& !SCHEME_SYM_WEIRDP(SCHEME_CAR(p))) {
|
||||
v = convert_prop_val(SCHEME_CDR(p), NULL, ut, empty_hash_tree);
|
||||
if (v) {
|
||||
props = scheme_hash_tree_set((dest->props ? dest->props : empty_hash_tree),
|
||||
SCHEME_CAR(p),
|
||||
make_preserved_property_value(SCHEME_CDR(p)));
|
||||
make_preserved_property_value(v));
|
||||
dest->props = props;
|
||||
}
|
||||
}
|
||||
l = SCHEME_CDR(l);
|
||||
}
|
||||
}
|
||||
}
|
||||
|
||||
#ifdef DO_STACK_CHECK
|
||||
static Scheme_Object *syntax_to_datum_inner(Scheme_Object *o,
|
||||
int with_scopes,
|
||||
Scheme_Marshal_Tables *mt);
|
||||
|
||||
static Scheme_Object *syntax_to_datum_k(void)
|
||||
{
|
||||
Scheme_Thread *p = scheme_current_thread;
|
||||
|
|
@ -6794,7 +6974,7 @@ Scheme_Object *scheme_syntax_to_datum(Scheme_Object *stx, int with_scopes,
|
|||
/* datum->syntax */
|
||||
/*========================================================================*/
|
||||
|
||||
#define return_NULL return NULL
|
||||
#define return_NULL abort()
|
||||
|
||||
Scheme_Object *scheme_hash_get_either(Scheme_Hash_Table *ht, Scheme_Hash_Table *ht2,
|
||||
Scheme_Object *key)
|
||||
|
|
@ -7244,13 +7424,6 @@ Scheme_Object *scope_unmarshal_content(Scheme_Object *box, Scheme_Unmarshal_Tabl
|
|||
|
||||
|
||||
#ifdef DO_STACK_CHECK
|
||||
static Scheme_Object *datum_to_syntax_inner(Scheme_Object *o,
|
||||
Scheme_Unmarshal_Tables *ut,
|
||||
Scheme_Stx *stx_src,
|
||||
Scheme_Stx *stx_wraps,
|
||||
Scheme_Hash_Table *ht,
|
||||
int tainted);
|
||||
|
||||
static Scheme_Object *datum_to_syntax_k(void)
|
||||
{
|
||||
Scheme_Thread *p = scheme_current_thread;
|
||||
|
|
@ -7515,7 +7688,7 @@ static Scheme_Object *datum_to_syntax_inner(Scheme_Object *o,
|
|||
}
|
||||
|
||||
if (SCHEME_TRUEP(srcloc_vec))
|
||||
unconvert_srcloc(srcloc_vec, (Scheme_Stx *)result);
|
||||
unconvert_srcloc(srcloc_vec, (Scheme_Stx *)result, ut);
|
||||
|
||||
if (wraps) {
|
||||
if (!do_not_unpack_wraps) {
|
||||
|
|
|
|||
Loading…
Reference in New Issue
Block a user