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

add prop:proxy-of'; Fix chaperone-of' on keyword-accepting procedures

Browse Source
This commit is contained in:
Matthew Flatt 2010-09-17 06:53:50 -06:00
parent d4b0048d42
commit 232a580e53
13 changed files with 1235 additions and 913 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

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

@ -27,10 +27,18 @@
;; ----------------------------------------
(define-values (prop:keyword-proxy keyword-proxy? keyword-proxy-ref)
(make-struct-type-property 'keyword-proxy))
(define (keyword-procedure-proxy-of v)
(cond
[(keyword-proxy? v) ((keyword-proxy-ref v) v)]
[else #f]))
(define-values (struct:keyword-procedure mk-kw-proc keyword-procedure?
keyword-procedure-ref keyword-procedure-set!)
(make-struct-type 'keyword-procedure #f 4 0 #f
(list (cons prop:checked-procedure #t))
(list (cons prop:checked-procedure #t)
(cons prop:proxy-of keyword-procedure-proxy-of))
(current-inspector)
#f
'(0 1 2 3)))
@ -123,12 +131,16 @@
;; is used for each evaluation of a keyword lambda.)
;; The `procedure' property is a per-type method that has exactly
;; the right arity, and that sends all arguments to `missing-kw'.
(define (make-required name fail-proc method?)
(define (make-required name fail-proc method? proxy?)
(let-values ([(s: mk ? -ref -set!)
(make-struct-type (or name 'unknown)
(if method?
struct:keyword-method
struct:keyword-procedure)
(if proxy?
(if method?
struct:keyword-method-proxy
struct:keyword-procedure-proxy)
(if method?
struct:keyword-method
struct:keyword-procedure))
0 0 #f
(list (cons prop:arity-string
generate-arity-string)
@ -141,7 +153,30 @@
(define-values (new-prop:procedure new-procedure? new-procedure-ref)
(make-struct-type-property 'procedure #f
(list (cons prop:procedure values))))
;; Proxies
(define-values (struct:keyword-procedure-proxy make-kpp keyword-procedure-proxy? kpp-ref kpp-set!)
(make-struct-type 'procedure
struct:keyword-procedure
1 0 #f
(list (cons prop:keyword-proxy (lambda (v) (kpp-ref v 0))))))
(define-values (struct:keyword-method-proxy make-kmp keyword-method-proxy? kmp-ref kmp-set!)
(make-struct-type 'procedure
struct:keyword-method
1 0 #f
(list (cons prop:keyword-proxy (lambda (v) (kmp-ref v 0))))))
(define-values (struct:okpp make-optional-keyword-procedure-proxy okpp? okpp-ref okpp-set!)
(make-struct-type 'procedure
struct:okp
1 0 #f
(list (cons prop:keyword-proxy (lambda (v) (okpp-ref v 0))))))
(define-values (struct:okmp make-optional-keyword-method-proxy okmp? okmp-ref okmp-set!)
(make-struct-type 'procedure
struct:okp
1 0 #f
(list (cons prop:keyword-proxy (lambda (v) (okmp-ref v 0))))))
;; ----------------------------------------
(define make-keyword-procedure
@ -487,7 +522,7 @@
[mk-id (with-syntax ([n (syntax-local-infer-name stx)]
[call-fail (mk-kw-arity-stub)])
(syntax-local-lift-expression
#'(make-required 'n call-fail method?)))])
#'(make-required 'n call-fail method? #F)))])
(syntax/loc stx
(mk-id
(lambda (given-kws given-argc)
@ -1063,7 +1098,8 @@
missing-kw
(inc-arity arity 1))
(or (okm? proc)
(keyword-method? proc)))
(keyword-method? proc))
#f)
kw-checker
new-kw-proc
req-kw
@ -1099,7 +1135,7 @@
;; Constructor must be from `make-required', but not a method.
;; Make a new variant that's a method:
(let* ([name+fail (keyword-procedure-name+fail proc)]
[mk (make-required (car name+fail) (cdr name+fail) #t)])
[mk (make-required (car name+fail) (cdr name+fail) #t #f)])
(mk
(keyword-procedure-checker proc)
(keyword-procedure-proc proc)
@ -1129,7 +1165,7 @@
[else
;; Constructor must be from `make-required':
(let* ([name+fail (keyword-procedure-name+fail proc)]
[mk (make-required name (cdr name+fail) (keyword-method? proc))])
[mk (make-required name (cdr name+fail) (keyword-method? proc) #f)])
(mk
(keyword-procedure-checker proc)
(keyword-procedure-proc proc)
@ -1140,14 +1176,14 @@
(define new:chaperone-procedure
(let ([chaperone-procedure
(lambda (proc wrap-proc . props)
(do-chaperone-procedure #t chaperone-procedure 'chaperone-procedure proc wrap-proc props))])
chaperone-procedure ))
(do-chaperone-procedure #f chaperone-procedure 'chaperone-procedure proc wrap-proc props))])
chaperone-procedure))
(define new:proxy-procedure
(let ([chaperone-procedure
(let ([proxy-procedure
(lambda (proc wrap-proc . props)
(do-chaperone-procedure #f proxy-procedure 'proxy-procedure proc wrap-proc props))])
chaperone-procedure ))
(do-chaperone-procedure #t proxy-procedure 'proxy-procedure proc wrap-proc props))])
proxy-procedure))
(define (do-chaperone-procedure is-proxy? chaperone-procedure name proc wrap-proc props)
(if (or (not (keyword-procedure? proc))
@ -1240,23 +1276,43 @@
[new-proc
(cond
[(okp? proc)
(make-optional-keyword-procedure
(keyword-procedure-checker proc)
(chaperone-procedure (keyword-procedure-proc proc)
kw-chaperone)
(keyword-procedure-required proc)
(keyword-procedure-allowed proc)
(chaperone-procedure (okp-ref proc 0)
(okp-ref wrap-proc 0)))]
(if is-proxy?
((if (okm? proc)
make-optional-keyword-method-proxy
make-optional-keyword-procedure-proxy)
(keyword-procedure-checker proc)
(chaperone-procedure (keyword-procedure-proc proc)
kw-chaperone)
(keyword-procedure-required proc)
(keyword-procedure-allowed proc)
(chaperone-procedure (okp-ref proc 0)
(okp-ref wrap-proc 0))
proc)
(chaperone-struct
proc
keyword-procedure-proc
(lambda (self proc)
(chaperone-procedure proc kw-chaperone))
(make-struct-field-accessor okp-ref 0)
(lambda (self proc)
(chaperone-procedure proc
(okp-ref wrap-proc 0)))))]
[else
;; Constructor must be from `make-required':
(let* ([name+fail (keyword-procedure-name+fail proc)]
[mk (make-required (car name+fail) (cdr name+fail) (keyword-method? proc))])
(mk
(keyword-procedure-checker proc)
(chaperone-procedure (keyword-procedure-proc proc) kw-chaperone)
(keyword-procedure-required proc)
(keyword-procedure-allowed proc)))])])
(if is-proxy?
;; Constructor must be from `make-required':
(let* ([name+fail (keyword-procedure-name+fail proc)]
[mk (make-required (car name+fail) (cdr name+fail) (keyword-method? proc) #t)])
(mk
(keyword-procedure-checker proc)
(chaperone-procedure (keyword-procedure-proc proc) kw-chaperone)
(keyword-procedure-required proc)
(keyword-procedure-allowed proc)
proc))
(chaperone-struct
proc
keyword-procedure-proc
(lambda (self proc)
(chaperone-procedure proc kw-chaperone))))])])
(if (null? props)
new-proc
(apply chaperone-struct new-proc

7
collects/scribblings/reference/booleans.scrbl
View File

@ -44,7 +44,7 @@ strings, byte strings, numbers, pairs, mutable pairs, vectors, boxes, hash
tables, and inspectable structures. In the last five cases, equality
is recursively defined; if both @scheme[v1] and @scheme[v2] contain
reference cycles, they are equal when the infinite unfoldings of the
values would be equal. See also @scheme[prop:equal+hash].
values would be equal. See also @scheme[prop:equal+hash] and @racket[prop:proxy-of].
@examples[
(equal? 'yes 'yes)
@ -183,7 +183,10 @@ transparent structures, @scheme[equal-hash-code] and
values. For opaque structure types, @scheme[equal?] is the same as
@scheme[eq?], and @scheme[equal-hash-code] and
@scheme[equal-secondary-hash-code] results are based only on
@scheme[eq-hash-code].
@scheme[eq-hash-code]. If a structure has a @racket[prop:proxy-of]
property, then the @racket[prop:proxy-of] property takes precedence over
@racket[prop:equal+hash] if the property value's procedure returns a
non-@racket[#f] value when applied to the structure.
@examples[
(define (farm=? farm1 farm2 recursive-equal?)

23
collects/scribblings/reference/chaperones.scrbl
View File

@ -88,7 +88,9 @@ be considered proxies of each other if they are @scheme[equal?].
Otherwise, all proxies of @scheme[v2] must be intact in @scheme[v1],
in the sense that parts of @scheme[v2] must be derived from
@scheme[v1] through one of the proxy constructors (e.g.,
@scheme[proxy-procedure] or @racket[chaperone-procedure]).}
@scheme[proxy-procedure] or @racket[chaperone-procedure]).
See also @racket[prop:proxy-of].}
@defproc[(chaperone-of? [v1 any/c] [v2 any/c]) boolean?]{
@ -301,6 +303,25 @@ Pairs of @scheme[prop] and @scheme[prop-val] (the number of arguments
to @scheme[proxy-hash] must be odd) add proxy properties
or override proxy-property values of @scheme[hash].}
@defthing[prop:proxy-of struct-type-property?]{
A @tech{structure type property} (see @secref["structprops"]) that
supplies a procedure for extracting a proxied value from a structure
that represents a proxy. The property is used for @racket[proxy-of]
as well as @racket[equal?].
The property value must be a procedure of one argument, which is a
structure whose structure type has the property. The result can be
@scheme[#f] to indicate the structure does not represent a proxy,
otherwise the result is a value for which the original structure is a
proxy (so the original structure is a @racket[proxy-of?] and it is
@racket[equal?] to the result value). The result value must have the
same @racket[prop:proxy-of] and @racket[prop:equal+hash] property
values as the original structure, and the property values must be
inherited from the same structure type (which ensures some consistency
between @racket[proxy-of?] and @racket[equal?]).}
@; ------------------------------------------------------------
@section{Chaperone Constructors}

87
collects/tests/racket/chaperone.rktl
View File

@ -1047,4 +1047,91 @@
;; ----------------------------------------
(let ()
(define (a-proxy-of v) (a-x v))
(define a-equal+hash (list
(lambda (v1 v2 equal?)
(equal? (a-y v1) (a-y v2)))
(lambda (v1 hash)
(hash (a-y v1)))
(lambda (v2 hash)
(hash (a-y v2)))))
(define-struct a (x y)
#:property prop:proxy-of a-proxy-of
#:property prop:equal+hash a-equal+hash)
(define-struct (a-more a) (z))
(define-struct (a-new-proxy a) ()
#:property prop:proxy-of a-proxy-of)
(define-struct (a-new-equal a) ()
#:property prop:equal+hash a-equal+hash)
(let ([a1 (make-a #f 2)])
(test #t equal? (make-a #f 2) a1)
(test #t equal? (make-a-more #f 2 7) a1)
(test #t equal? (make-a-new-proxy #f 2) a1)
(test #f equal? (make-a-new-equal #f 2) a1)
(test #f equal? (make-a #f 3) a1)
(test #f proxy-of? (make-a #f 2) a1)
(test #t proxy-of? (make-a a1 3) a1)
(test #t proxy-of? (make-a-more a1 3 8) a1)
(test #f chaperone-of? (make-a a1 3) a1)
(test #t equal? (make-a a1 3) a1)
(test #t equal? (make-a-more a1 3 9) a1)
(err/rt-test (equal? (make-a 0 1) (make-a 0 1)))
(err/rt-test (proxy-of? (make-a-new-proxy a1 1) a1))
(err/rt-test (proxy-of? (make-a-new-equal a1 1) a1))
(err/rt-test (equal? (make-a-new-equal a1 1) a1))
(void)))
;; ----------------------------------------
(let ()
(define f1 (λ (k) k))
(define f2 (λ (#:key k) k))
(define f3 (λ (#:key [k 0]) k))
(define wrapper
(make-keyword-procedure
(λ (kwds kwd-args . args)
(apply values kwd-args args))
(λ args (apply values args))))
(define g1 (chaperone-procedure f1 wrapper))
(define g2 (chaperone-procedure f2 wrapper))
(define g3 (chaperone-procedure f2 wrapper))
(define h1 (proxy-procedure f1 wrapper))
(define h2 (proxy-procedure f2 wrapper))
(define h3 (proxy-procedure f2 wrapper))
(test #t chaperone-of? g1 f1)
(test #t chaperone-of? g2 f2)
(test #t chaperone-of? g3 f2)
(test #f chaperone-of? g3 g2)
(test #t equal? g1 f1)
(test #t equal? g2 f2)
(test #t equal? g3 f2)
(test #t equal? g3 g2)
(test #t proxy-of? h1 f1)
(test #t proxy-of? h2 f2)
(test #t proxy-of? h3 f2)
(test #f proxy-of? h3 h2)
(test #t equal? h1 f1)
(test #t equal? h2 f2)
(test #t equal? h3 f2)
(test #t equal? h3 h2)
(test #t equal? h1 g1)
(test #t equal? h2 g2)
(test #t equal? h3 g3)
(test #t equal? h3 g2)
(test #f equal? h1 f3)
(test #f equal? h2 f1)
(test #f equal? h3 f1))
;; ----------------------------------------
(report-errs)

3
doc/release-notes/racket/HISTORY.txt
View File

@ -1,3 +1,6 @@
Version 5.0.1.6
Added prop:proxy-of
Version 5.0.1.5
Added proxies to go with chaperones, and renamed chaperone property
as proxy property

166
src/racket/src/bool.c
View File

@ -63,6 +63,7 @@ typedef struct Equal_Info {
static int is_equal (Scheme_Object *obj1, Scheme_Object *obj2, Equal_Info *eql);
static int vector_equal (Scheme_Object *vec1, Scheme_Object *vec2, Equal_Info *eql);
static int struct_equal (Scheme_Object *s1, Scheme_Object *s2, Equal_Info *eql);
static Scheme_Object *apply_proxy_of(int for_chaperone, Scheme_Object *procs, Scheme_Object *obj);
void scheme_init_true_false(void)
{
@ -470,71 +471,92 @@ int is_equal (Scheme_Object *obj1, Scheme_Object *obj2, Equal_Info *eql)
st1 = SCHEME_STRUCT_TYPE(obj1);
st2 = SCHEME_STRUCT_TYPE(obj2);
if (eql->for_chaperone) {
if (eql->for_chaperone == 1)
procs1 = NULL;
} else {
procs1 = scheme_struct_type_property_ref(scheme_equal_property, (Scheme_Object *)st1);
if (procs1 && (st1 != st2)) {
procs2 = scheme_struct_type_property_ref(scheme_equal_property, (Scheme_Object *)st2);
if (!procs2
|| !SAME_OBJ(SCHEME_VEC_ELS(procs1)[0], SCHEME_VEC_ELS(procs2)[0]))
procs1 = NULL;
}
else
procs1 = scheme_struct_type_property_ref(scheme_proxy_of_property, (Scheme_Object *)st1);
if (procs1)
procs1 = apply_proxy_of(eql->for_chaperone, procs1, obj1);
if (eql->for_chaperone)
procs2 = NULL;
else {
procs2 = scheme_struct_type_property_ref(scheme_proxy_of_property, (Scheme_Object *)st2);
if (procs2)
procs2 = apply_proxy_of(eql->for_chaperone, procs2, obj2);
}
if (procs1) {
/* Has an equality property: */
Scheme_Object *a[3], *recur;
Equal_Info *eql2;
if (procs1 || procs2) {
/* proxy-of property trumps other forms of checking */
if (procs1) obj1 = procs1;
if (procs2) obj2 = procs2;
goto top;
} else {
if (eql->for_chaperone) {
procs1 = NULL;
} else {
procs1 = scheme_struct_type_property_ref(scheme_equal_property, (Scheme_Object *)st1);
if (procs1 && (st1 != st2)) {
procs2 = scheme_struct_type_property_ref(scheme_equal_property, (Scheme_Object *)st2);
if (!procs2
|| !SAME_OBJ(SCHEME_VEC_ELS(procs1)[0], SCHEME_VEC_ELS(procs2)[0]))
procs1 = NULL;
}
}
if (procs1) {
/* Has an equality property: */
Scheme_Object *a[3], *recur;
Equal_Info *eql2;
# include "mzeqchk.inc"
if (union_check(obj1, obj2, eql))
return 1;
/* Create/cache closure to use for recursive equality checks: */
if (eql->recur) {
recur = eql->recur;
eql2 = (Equal_Info *)SCHEME_PRIM_CLOSURE_ELS(recur)[0];
} else {
eql2 = (Equal_Info *)scheme_malloc(sizeof(Equal_Info));
a[0] = (Scheme_Object *)eql2;
recur = scheme_make_prim_closure_w_arity(equal_recur,
1, a,
"equal?/recur",
2, 2);
eql->recur = recur;
}
memcpy(eql2, eql, sizeof(Equal_Info));
a[0] = obj1;
a[1] = obj2;
a[2] = recur;
procs1 = SCHEME_VEC_ELS(procs1)[1];
recur = _scheme_apply(procs1, 3, a);
memcpy(eql, eql2, sizeof(Equal_Info));
return SCHEME_TRUEP(recur);
} else if (st1 != st2) {
return 0;
} else if ((eql->for_chaperone == 1)
&& !(MZ_OPT_HASH_KEY(&st1->iso) & STRUCT_TYPE_ALL_IMMUTABLE)) {
return 0;
} else {
/* Same types, but doesn't have an equality property
(or checking for chaperone), so check transparency: */
Scheme_Object *insp;
insp = scheme_get_param(scheme_current_config(), MZCONFIG_INSPECTOR);
if (scheme_inspector_sees_part(obj1, insp, -2)
&& scheme_inspector_sees_part(obj2, insp, -2)) {
# include "mzeqchk.inc"
if (union_check(obj1, obj2, eql))
return 1;
return struct_equal(obj1, obj2, eql);
} else
return 0;
/* Create/cache closure to use for recursive equality checks: */
if (eql->recur) {
recur = eql->recur;
eql2 = (Equal_Info *)SCHEME_PRIM_CLOSURE_ELS(recur)[0];
} else {
eql2 = (Equal_Info *)scheme_malloc(sizeof(Equal_Info));
a[0] = (Scheme_Object *)eql2;
recur = scheme_make_prim_closure_w_arity(equal_recur,
1, a,
"equal?/recur",
2, 2);
eql->recur = recur;
}
memcpy(eql2, eql, sizeof(Equal_Info));
a[0] = obj1;
a[1] = obj2;
a[2] = recur;
procs1 = SCHEME_VEC_ELS(procs1)[1];
recur = _scheme_apply(procs1, 3, a);
memcpy(eql, eql2, sizeof(Equal_Info));
return SCHEME_TRUEP(recur);
} else if (st1 != st2) {
return 0;
} else if ((eql->for_chaperone == 1)
&& !(MZ_OPT_HASH_KEY(&st1->iso) & STRUCT_TYPE_ALL_IMMUTABLE)) {
return 0;
} else {
/* Same types, but doesn't have an equality property
(or checking for chaperone), so check transparency: */
Scheme_Object *insp;
insp = scheme_get_param(scheme_current_config(), MZCONFIG_INSPECTOR);
if (scheme_inspector_sees_part(obj1, insp, -2)
&& scheme_inspector_sees_part(obj2, insp, -2)) {
# include "mzeqchk.inc"
if (union_check(obj1, obj2, eql))
return 1;
return struct_equal(obj1, obj2, eql);
} else
return 0;
}
}
} else if (SCHEME_BOXP(obj1)) {
SCHEME_USE_FUEL(1);
@ -689,3 +711,31 @@ int scheme_proxy_of(Scheme_Object *obj1, Scheme_Object *obj2)
return is_equal(obj1, obj2, &eql);
}
static Scheme_Object *apply_proxy_of(int for_chaperone, Scheme_Object *procs, Scheme_Object *obj)
{
Scheme_Object *a[1], *v, *oprocs;
a[0] = obj;
v = _scheme_apply(SCHEME_CDR(procs), 1, a);
if (SCHEME_FALSEP(v))
return NULL;
oprocs = scheme_struct_type_property_ref(scheme_proxy_of_property, v);
if (!oprocs || !SAME_OBJ(SCHEME_CAR(oprocs), SCHEME_CAR(procs)))
scheme_arg_mismatch((for_chaperone ? "proxy-of?" : "equal?"),
"proxy-of property procedure returned a value with a different prop:proxy-of source: ",
v);
procs = scheme_struct_type_property_ref(scheme_equal_property, obj);
oprocs = scheme_struct_type_property_ref(scheme_equal_property, v);
if (procs || oprocs)
if (!procs || !oprocs || !SAME_OBJ(SCHEME_VEC_ELS(oprocs)[0],
SCHEME_VEC_ELS(procs)[0]))
scheme_arg_mismatch((for_chaperone ? "proxy-of?" : "equal?"),
"proxy-of property procedure returned a value with a different prop:equal+hash source: ",
v);
return v;
}

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

File diff suppressed because it is too large Load Diff

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

@ -9494,61 +9494,113 @@ scheme_do_eval(Scheme_Object *obj, int num_rands, Scheme_Object **rands,
UPDATE_THREAD_RSPTR();
scheme_escape_to_continuation(obj, num_rands, rands, NULL);
return NULL;
} else if (type == scheme_proc_struct_type) {
} else if ((type == scheme_proc_struct_type)
|| ((type == scheme_proc_chaperone_type)
/* Chaperone is for struct fields, not function arguments --- but
the chaperone may guard access to the function as a field inside
the struct. We'll need to keep track of the original object
as we unwrap to discover procedure chaperones. */
&& (SCHEME_VECTORP(((Scheme_Chaperone *)obj)->redirects)))
/* A raw pair is from scheme_apply_chaperone(), propagating the
original object for an applicable structure. */
|| (type == scheme_raw_pair_type)) {
int is_method;
int check_rands = num_rands;
Scheme_Object *orig_obj;
do {
VACATE_TAIL_BUFFER_USE_RUNSTACK();
if (SCHEME_RPAIRP(obj)) {
orig_obj = SCHEME_CDR(obj);
obj = SCHEME_CAR(obj);
} else {
orig_obj = obj;
}
UPDATE_THREAD_RSPTR_FOR_ERROR(); /* in case */
while (1) {
/* Like the apply loop around this one, but we need
to keep track of orig_obj until we get down to the
structure. */
v = obj;
obj = scheme_extract_struct_procedure(obj, check_rands, rands, &is_method);
if (is_method) {
/* Have to add an extra argument to the front of rands */
if ((rands == RUNSTACK) && (RUNSTACK != RUNSTACK_START)){
/* Common case: we can just push self onto the front: */
rands = PUSH_RUNSTACK(p, RUNSTACK, 1);
rands[0] = v;
} else {
int i;
Scheme_Object **a;
type = SCHEME_TYPE(obj);
if (type == scheme_proc_struct_type) {
do {
VACATE_TAIL_BUFFER_USE_RUNSTACK();
if (p->tail_buffer && (num_rands < p->tail_buffer_size)) {
/* Use tail-call buffer. Shift in such a way that this works if
rands == p->tail_buffer */
a = p->tail_buffer;
UPDATE_THREAD_RSPTR_FOR_ERROR(); /* in case */
v = obj;
obj = scheme_extract_struct_procedure(orig_obj, check_rands, rands, &is_method);
if (is_method) {
/* Have to add an extra argument to the front of rands */
if ((rands == RUNSTACK) && (RUNSTACK != RUNSTACK_START)){
/* Common case: we can just push self onto the front: */
rands = PUSH_RUNSTACK(p, RUNSTACK, 1);
rands[0] = v;
} else {
int i;
Scheme_Object **a;
if (p->tail_buffer && (num_rands < p->tail_buffer_size)) {
/* Use tail-call buffer. Shift in such a way that this works if
rands == p->tail_buffer */
a = p->tail_buffer;
} else {
/* Uncommon general case --- allocate an array */
UPDATE_THREAD_RSPTR_FOR_GC();
a = MALLOC_N(Scheme_Object *, num_rands + 1);
}
for (i = num_rands; i--; ) {
a[i + 1] = rands[i];
}
a[0] = v;
rands = a;
}
num_rands++;
}
/* After we check arity once, no need to check again
(which would lead to O(n^2) checking for nested
struct procs): */
check_rands = -1;
DO_CHECK_FOR_BREAK(p, UPDATE_THREAD_RSPTR_FOR_GC(); if (rands == p->tail_buffer) make_tail_buffer_safe(););
break;
} while (SAME_TYPE(scheme_proc_struct_type, SCHEME_TYPE(obj)));
goto apply_top;
} else {
if (SCHEME_VECTORP(((Scheme_Chaperone *)obj)->redirects))
obj = ((Scheme_Chaperone *)obj)->prev;
else if (SAME_TYPE(SCHEME_TYPE(((Scheme_Chaperone *)obj)->redirects), scheme_nack_guard_evt_type))
/* Chaperone is for evt, not function arguments */
obj = ((Scheme_Chaperone *)obj)->prev;
else {
/* Chaperone is for function arguments */
VACATE_TAIL_BUFFER_USE_RUNSTACK();
UPDATE_THREAD_RSPTR();
v = scheme_apply_chaperone(scheme_make_raw_pair(obj, orig_obj), num_rands, rands, NULL);
if (SAME_OBJ(v, SCHEME_TAIL_CALL_WAITING)) {
/* Need to stay in this loop, because a tail-call result must
be a tail call to an unwrapped layer, so we'll eventually
need to use orig_obj. */
obj = p->ku.apply.tail_rator;
num_rands = p->ku.apply.tail_num_rands;
if (check_rands != -1) check_rands = num_rands;
rands = p->ku.apply.tail_rands;
p->ku.apply.tail_rator = NULL;
p->ku.apply.tail_rands = NULL;
RUNSTACK = old_runstack;
RUNSTACK_CHANGED();
} else {
/* Uncommon general case --- allocate an array */
UPDATE_THREAD_RSPTR_FOR_GC();
a = MALLOC_N(Scheme_Object *, num_rands + 1);
break;
}
for (i = num_rands; i--; ) {
a[i + 1] = rands[i];
}
a[0] = v;
rands = a;
}
num_rands++;
}
/* After we check arity once, no need to check again
(which would lead to O(n^2) checking for nested
struct procs): */
check_rands = -1;
DO_CHECK_FOR_BREAK(p, UPDATE_THREAD_RSPTR_FOR_GC(); if (rands == p->tail_buffer) make_tail_buffer_safe(););
} while (SAME_TYPE(scheme_proc_struct_type, SCHEME_TYPE(obj)));
goto apply_top;
}
} else if (type == scheme_proc_chaperone_type) {
if (SCHEME_VECTORP(((Scheme_Chaperone *)obj)->redirects)) {
/* Chaperone is for struct fields, not function arguments */
obj = ((Scheme_Chaperone *)obj)->prev;
goto apply_top;
} else if (SAME_TYPE(SCHEME_TYPE(((Scheme_Chaperone *)obj)->redirects), scheme_nack_guard_evt_type)) {
if (SAME_TYPE(SCHEME_TYPE(((Scheme_Chaperone *)obj)->redirects), scheme_nack_guard_evt_type)) {
/* Chaperone is for evt, not function arguments */
obj = ((Scheme_Chaperone *)obj)->prev;
goto apply_top;

30
src/racket/src/fun.c
View File

@ -4173,8 +4173,8 @@ static Scheme_Object *do_apply_chaperone(Scheme_Object *o, int argc, Scheme_Obje
Scheme_Object *scheme_apply_chaperone(Scheme_Object *o, int argc, Scheme_Object **argv, Scheme_Object *auto_val)
{
const char *what;
Scheme_Chaperone *px = (Scheme_Chaperone *)o;
Scheme_Object *v, *a[1], *a2[3], **argv2, *post, *result_v;
Scheme_Chaperone *px;
Scheme_Object *v, *a[1], *a2[3], **argv2, *post, *result_v, *orig_obj;
int c, i, need_restore = 0;
if (argv == MZ_RUNSTACK) {
@ -4192,6 +4192,18 @@ Scheme_Object *scheme_apply_chaperone(Scheme_Object *o, int argc, Scheme_Object
}
}
if (SCHEME_RPAIRP(o)) {
/* An applicable struct, where a layout of struct chaperones
has been removed from the object to apply, but we will
eventually need to extract the procedure from the original
object. */
orig_obj = SCHEME_CDR(o);
o = SCHEME_CAR(o);
} else {
orig_obj = NULL;
}
px = (Scheme_Chaperone *)o;
if (!(SCHEME_CHAPERONE_FLAGS(px) & SCHEME_CHAPERONE_IS_PROXY))
what = "chaperone";
else
@ -4272,7 +4284,12 @@ Scheme_Object *scheme_apply_chaperone(Scheme_Object *o, int argc, Scheme_Object
else
return argv2[0];
} else {
return scheme_tail_apply(px->prev, c, argv2);
if (orig_obj)
/* A raw pair tells apply to extract a procedure from orig_obj */
orig_obj = scheme_make_raw_pair(px->prev, orig_obj);
else
orig_obj = px->prev;
return scheme_tail_apply(orig_obj, c, argv2);
}
} else {
/* First element is a filter for the result(s) */
@ -4289,7 +4306,12 @@ Scheme_Object *scheme_apply_chaperone(Scheme_Object *o, int argc, Scheme_Object
result_v = argv2[0];
v = auto_val;
} else {
v = _scheme_apply_multi(px->prev, argc, argv2);
if (orig_obj)
/* A raw pair tells apply to extract a procedure from orig_obj */
orig_obj = scheme_make_raw_pair(px->prev, orig_obj);
else
orig_obj = px->prev;
v = _scheme_apply_multi(orig_obj, argc, argv2);
result_v = NULL;
}
if (v == SCHEME_MULTIPLE_VALUES) {

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

@ -13,7 +13,7 @@
#define USE_COMPILED_STARTUP 1
#define EXPECTED_PRIM_COUNT 1010
#define EXPECTED_PRIM_COUNT 1011
#define EXPECTED_UNSAFE_COUNT 69
#define EXPECTED_FLFXNUM_COUNT 60
#define EXPECTED_FUTURES_COUNT 5

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

@ -384,6 +384,7 @@ THREAD_LOCAL_DECL(extern Scheme_Object *scheme_system_idle_channel);
extern Scheme_Object *scheme_input_port_property, *scheme_output_port_property;
extern Scheme_Object *scheme_equal_property;
extern Scheme_Object *scheme_proxy_of_property;
extern Scheme_Object *scheme_reduced_procedure_struct;

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

@ -13,12 +13,12 @@
consistently.)
*/
#define MZSCHEME_VERSION "5.0.1.5"
#define MZSCHEME_VERSION "5.0.1.6"
#define MZSCHEME_VERSION_X 5
#define MZSCHEME_VERSION_Y 0
#define MZSCHEME_VERSION_Z 1
#define MZSCHEME_VERSION_W 5
#define MZSCHEME_VERSION_W 6
#define MZSCHEME_VERSION_MAJOR ((MZSCHEME_VERSION_X * 100) + MZSCHEME_VERSION_Y)
#define MZSCHEME_VERSION_MINOR ((MZSCHEME_VERSION_Z * 1000) + MZSCHEME_VERSION_W)

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

@ -32,6 +32,7 @@ READ_ONLY Scheme_Object *scheme_source_property;
READ_ONLY Scheme_Object *scheme_input_port_property;
READ_ONLY Scheme_Object *scheme_output_port_property;
READ_ONLY Scheme_Object *scheme_equal_property;
READ_ONLY Scheme_Object *scheme_proxy_of_property;
READ_ONLY Scheme_Object *scheme_make_struct_type_proc;
READ_ONLY Scheme_Object *scheme_current_inspector_proc;
READ_ONLY Scheme_Object *scheme_recur_symbol;
@ -87,6 +88,7 @@ static Scheme_Object *struct_type_property_p(int argc, Scheme_Object *argv[]);
static Scheme_Object *chaperone_property_p(int argc, Scheme_Object *argv[]);
static Scheme_Object *check_evt_property_value_ok(int argc, Scheme_Object *argv[]);
static Scheme_Object *check_equal_property_value_ok(int argc, Scheme_Object *argv[]);
static Scheme_Object *check_proxy_of_property_value_ok(int argc, Scheme_Object *argv[]);
static Scheme_Object *check_write_property_value_ok(int argc, Scheme_Object *argv[]);
static Scheme_Object *check_print_attribute_property_value_ok(int argc, Scheme_Object *argv[]);
static Scheme_Object *check_input_port_property_value_ok(int argc, Scheme_Object *argv[]);
@ -345,6 +347,16 @@ scheme_init_struct (Scheme_Env *env)
scheme_add_global_constant("prop:equal+hash", scheme_equal_property, env);
}
{
guard = scheme_make_prim_w_arity(check_proxy_of_property_value_ok,
"guard-for-prop:proxy-of",
2, 2);
REGISTER_SO(scheme_proxy_of_property);
scheme_proxy_of_property = scheme_make_struct_type_property_w_guard(scheme_intern_symbol("proxy-of"),
guard);
scheme_add_global_constant("prop:proxy-of", scheme_proxy_of_property, env);
}
{
REGISTER_SO(scheme_input_port_property);
REGISTER_SO(scheme_output_port_property);
@ -1490,6 +1502,25 @@ static Scheme_Object *check_equal_property_value_ok(int argc, Scheme_Object *arg
return v;
}
static Scheme_Object *check_proxy_of_property_value_ok(int argc, Scheme_Object *argv[])
{
/* This is the guard for prop:proxy-of */
Scheme_Object *v;
v = argv[0];
if (!scheme_check_proc_arity(NULL, 1, 0, argc, argv)) {
scheme_arg_mismatch("guard-for-prop:proxy-of",
"not a procedure of arity 1: ",
v);
}
/* Add a tag to track origin of the proxy-of property: */
v = scheme_make_pair(scheme_make_symbol("tag"), v);
return v;
}
/*========================================================================*/
/* writeable structs */
/*========================================================================*/
@ -4821,15 +4852,24 @@ Scheme_Struct_Type *scheme_lookup_prefab_type(Scheme_Object *key, int field_coun
Scheme_Object *scheme_extract_struct_procedure(Scheme_Object *obj, int num_rands, Scheme_Object **rands, int *is_method)
{
Scheme_Struct_Type *stype;
Scheme_Object *a, *proc;
Scheme_Object *plain_obj, *a, *proc;
int meth_wrap = 0;
stype = ((Scheme_Structure *)obj)->stype;
if (SCHEME_CHAPERONEP(obj))
plain_obj = SCHEME_CHAPERONE_VAL(obj);
else
plain_obj = obj;
stype = ((Scheme_Structure *)plain_obj)->stype;
a = stype->proc_attr;
if (SCHEME_INTP(a)) {
*is_method = 0;
proc = ((Scheme_Structure *)obj)->slots[SCHEME_INT_VAL(a)];
if (!SAME_OBJ(plain_obj, obj)) {
proc = chaperone_struct_ref("struct-ref", obj, SCHEME_INT_VAL(a));
} else {
proc = ((Scheme_Structure *)obj)->slots[SCHEME_INT_VAL(a)];
}
} else {
*is_method = 1;
proc = a;
@ -4843,7 +4883,7 @@ Scheme_Object *scheme_extract_struct_procedure(Scheme_Object *obj, int num_rands
* account for that.
*/
if (scheme_reduced_procedure_struct
&& scheme_is_struct_instance(scheme_reduced_procedure_struct, obj))
&& scheme_is_struct_instance(scheme_reduced_procedure_struct, plain_obj))
meth_wrap = SCHEME_TRUEP(((Scheme_Structure *)obj)->slots[3]);
scheme_wrong_count_m((char *)obj,