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

add unsafe-{chaperone,impersonate}-procedure

Browse Source
This commit is contained in:
Robby Findler 2016-01-13 16:20:22 -06:00
parent df29c4e7e2
commit 41c8d5bc27
12 changed files with 1893 additions and 1656 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.4.0.1")
(define version "6.4.0.2")
(define deps `("racket-lib"
["racket" #:version ,version]))

81
pkgs/racket-doc/scribblings/reference/chaperones.scrbl
View File

@ -310,6 +310,77 @@ that are overridden by further impersonators, for example.
@history[#:added "6.1.1.5"]}
@defproc[(unsafe-impersonate-procedure [proc procedure?]
[replacement-proc procedure?]
[prop impersonator-property?]
[prop-val any] ... ...)
(and/c procedure? impersonator?)]{
Like @racket[impersonate-procedure], except it assumes that @racket[replacement-proc]
is already properly wrapping @racket[proc] and so when the procedure that
@racket[unsafe-impersonate-procedure] produces is invoked, the
@racket[replacement-proc] is invoked directly, ignoring @racket[proc].
In addition, it does not specially handle @racket[impersonator-prop:application-mark],
instead just treating it as an ordinary property if it is supplied as one of the
@racket[prop] arguments.
This procedure is unsafe only in how it assumes @racket[replacement-proc] is
a proper wrapper for @racket[proc]. It otherwise does all of the checking
that @racket[impersonate-procedure] does.
As an example, this function:
@racketblock[(λ (f)
(unsafe-impersonate-procedure
f
(λ (x)
(if (number? x)
(error 'no-numbers!)
(f x)))))]
is equivalent to this one:
@racketblock[(λ (f)
(impersonate-procedure
f
(λ (x)
(if (number? x)
(error 'no-numbers!)
x))))]
(except that some error messages start with @litchar{unsafe-impersonate-procedure}
instead of @litchar{impersonate-procedure}).
Similarly the two procedures @racket[_wrap-f1] and
@racket[_wrap-f2] are almost equivalent; they differ only
in the error message produced when their arguments are
functions that return multiple values (and that they update
different global variables). The version using @racket[unsafe-impersonate-procedure]
will signal an error in the @racket[let] expression about multiple
value return, whereas the one using @racket[impersonate-procedure] signals
an error from @racket[impersonate-procedure] about multiple value return.
@racketblock[(define log1-args '())
(define log1-results '())
(define wrap-f1
(λ (f)
(impersonate-procedure
f
(λ (arg)
(set! log1-args (cons arg log1-args))
(values (λ (res)
(set! log1-results (cons res log1-results))
res)
arg)))))
(define log2-args '())
(define log2-results '())
(define wrap-f2
(λ (f)
(unsafe-impersonate-procedure
f
(λ (arg)
(set! log2-args (cons arg log2-args))
(let ([res (f arg)])
(set! log2-results (cons res log2-results))
res)))))]
}
@defproc[(impersonate-struct [v any/c]
[struct-type struct-type? _unspecified]
@ -722,6 +793,15 @@ an extra argument as with @racket[impersonate-procedure*].
@history[#:added "6.1.1.5"]}
@defproc[(unsafe-chaperone-procedure [proc procedure?]
[wrapper-proc procedure?]
[prop impersonator-property?]
[prop-val any] ... ...)
(and/c procedure? chaperone?)]{
Like @racket[unsafe-impersonate-procedure], but creates a @tech{chaperone}.
@history[#:added "6.1.1.5"]
}
@defproc[(chaperone-struct [v any/c]
[struct-type struct-type? _unspecified]
@ -783,7 +863,6 @@ or structure type.
#:changed "6.1.1.8" @elem{Added optional @racket[struct-type]
argument.}]}
@defproc[(chaperone-vector [vec vector?]
[ref-proc (vector? exact-nonnegative-integer? any/c . -> . any/c)]
[set-proc (vector? exact-nonnegative-integer? any/c . -> . any/c)]

68
pkgs/racket-test-core/tests/racket/chaperone.rktl
View File

@ -2310,6 +2310,74 @@
;; ----------------------------------------
(let ()
(define (f x) (+ x 1))
(define f2 (unsafe-chaperone-procedure f f))
(test 2 f2 1)
(test #t chaperone-of? f2 f)
(test #f chaperone-of? f f2)
(define f3 (unsafe-chaperone-procedure f sub1))
(define f3i (unsafe-impersonate-procedure f sub1))
(test 0 f3 1)
(test 0 f3i 1)
(test #t chaperone-of? f3 f)
(test #f chaperone-of? f3i f)
(test #f chaperone-of? f3 f2)
(test #f chaperone-of? f2 f3)
(test #f chaperone-of?
(unsafe-chaperone-procedure f f)
(unsafe-chaperone-procedure f f))
(define-values (prop:p prop:p? prop:get-p)
(make-impersonator-property 'p))
(test #t prop:p? (unsafe-chaperone-procedure f f prop:p 5))
(test 5 prop:get-p (unsafe-chaperone-procedure f f prop:p 5))
(define f4 (unsafe-chaperone-procedure f (case-lambda
[(x) (f x)]
[(x y) (f x)])))
(test 2 f4 1)
(test 1
procedure-arity
(unsafe-chaperone-procedure (λ (x) (+ x 1))
(case-lambda
[(x) (+ x 1)]
[(x y) (+ x y)])))
(define f5 (unsafe-chaperone-procedure f (λ (x #:y [y 1]) (f x))))
(test 2 f5 1)
(err/rt-test (unsafe-chaperone-procedure
(λ (#:x x) x)
(λ (#:y y) y))
exn:fail?)
(let ()
(define (f-marks)
(continuation-mark-set->list
(current-continuation-marks)
'mark-key))
(define f-marks-chap
(unsafe-chaperone-procedure
f-marks
f-marks
impersonator-prop:application-mark
(cons 'x 123)))
;; test that impersonator-prop:application-mark
;; is ignored (as the docs say it is).
(test '() f-marks-chap))
(let ()
(struct s (f) #:property prop:procedure 0)
(test #t s? (unsafe-chaperone-procedure (s add1) (λ (x) x)))))
;; ----------------------------------------
(let ()
(struct s ([a #:mutable]))
(err/rt-test (impersonate-struct 5 set-s-a! (lambda (a b) b)))

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

@ -26,7 +26,9 @@
new:procedure->method
new:procedure-rename
new:chaperone-procedure
new:unsafe-chaperone-procedure
new:impersonate-procedure
new:unsafe-impersonate-procedure
new:chaperone-procedure*
new:impersonate-procedure*
(for-syntax kw-expander? kw-expander-impl kw-expander-proc
@ -1529,12 +1531,24 @@
(do-chaperone-procedure #f #f chaperone-procedure 'chaperone-procedure proc wrap-proc props))])
chaperone-procedure))
(define new:unsafe-chaperone-procedure
(let ([unsafe-chaperone-procedure
(lambda (proc wrap-proc . props)
(do-unsafe-chaperone-procedure unsafe-chaperone-procedure 'unsafe-chaperone-procedure proc wrap-proc props))])
unsafe-chaperone-procedure))
(define new:impersonate-procedure
(let ([impersonate-procedure
(lambda (proc wrap-proc . props)
(do-chaperone-procedure #t #f impersonate-procedure 'impersonate-procedure proc wrap-proc props))])
impersonate-procedure))
(define new:unsafe-impersonate-procedure
(let ([unsafe-impersonate-procedure
(lambda (proc wrap-proc . props)
(do-unsafe-chaperone-procedure unsafe-impersonate-procedure 'unsafe-impersonate-procedure proc wrap-proc props))])
unsafe-impersonate-procedure))
(define new:chaperone-procedure*
(let ([chaperone-procedure*
(lambda (proc wrap-proc . props)
@ -1553,52 +1567,10 @@
(if (or (not (keyword-procedure? n-proc))
(not (procedure? wrap-proc))
;; if any bad prop, let `chaperone-procedure' complain
(let loop ([props props])
(cond
[(null? props) #f]
[(impersonator-property? (car props))
(let ([props (cdr props)])
(or (null? props)
(loop (cdr props))))]
[else #t])))
(bad-props? props))
(apply chaperone-procedure proc wrap-proc props)
(let-values ([(a) (procedure-arity proc)]
[(b) (procedure-arity wrap-proc)]
[(d) (if self-arg? 1 0)]
[(a-req a-allow) (procedure-keywords proc)]
[(b-req b-allow) (procedure-keywords wrap-proc)])
(define (includes? a b)
(cond
[(number? b) (cond
[(number? a) (= b (+ a d))]
[(arity-at-least? a)
(b . >= . (+ (arity-at-least-value a) d))]
[else
(ormap (lambda (a) (includes? a b)) a)])]
[(arity-at-least? b) (cond
[(number? a) #f]
[(arity-at-least? a)
((arity-at-least-value b) . >= . (+ (arity-at-least-value a) d))]
[else (ormap (lambda (a) (includes? b a)) a)])]
[else (andmap (lambda (b) (includes? a b)) b)]))
(unless (includes? b a)
;; Let core report error:
(apply chaperone-procedure proc wrap-proc props))
(unless (subset? b-req a-req)
(raise-arguments-error
name
"wrapper procedure requires more keywords than original procedure"
"wrapper procedure" wrap-proc
"original procedure" proc))
(unless (or (not b-allow)
(and a-allow
(subset? a-allow b-allow)))
(raise-arguments-error
name
"wrapper procedure does not accept all keywords of original procedure"
"wrapper procedure" wrap-proc
"original procedure" proc))
(begin
(chaperone-arity-match-checking self-arg? name proc wrap-proc props)
(let*-values ([(kw-chaperone)
(let ([p (keyword-procedure-proc n-wrap-proc)])
;; `extra-arg ...` will be `self-proc` if `self-arg?`:
@ -1759,6 +1731,68 @@
chap-accessor #f
props)))))))
(define (do-unsafe-chaperone-procedure unsafe-chaperone-procedure name proc wrap-proc props)
(let ([n-proc (normalize-proc proc)]
[n-wrap-proc (normalize-proc wrap-proc)])
(if (or (not (keyword-procedure? n-proc))
(not (procedure? wrap-proc))
;; if any bad prop, let `unsafe-chaperone-procedure' complain
(bad-props? props))
(apply unsafe-chaperone-procedure proc wrap-proc props)
(begin
(chaperone-arity-match-checking #f name proc wrap-proc props)
(apply unsafe-chaperone-procedure proc wrap-proc props)))))
(define (bad-props? props)
(let loop ([props props])
(cond
[(null? props) #f]
[(impersonator-property? (car props))
(let ([props (cdr props)])
(or (null? props)
(loop (cdr props))))]
[else #t])))
(define (chaperone-arity-match-checking self-arg? name proc wrap-proc props)
(let-values ([(a) (procedure-arity proc)]
[(b) (procedure-arity wrap-proc)]
[(d) (if self-arg? 1 0)]
[(a-req a-allow) (procedure-keywords proc)]
[(b-req b-allow) (procedure-keywords wrap-proc)])
(define (includes? a b)
(cond
[(number? b) (cond
[(number? a) (= b (+ a d))]
[(arity-at-least? a)
(b . >= . (+ (arity-at-least-value a) d))]
[else
(ormap (lambda (a) (includes? a b)) a)])]
[(arity-at-least? b) (cond
[(number? a) #f]
[(arity-at-least? a)
((arity-at-least-value b) . >= . (+ (arity-at-least-value a) d))]
[else (ormap (lambda (a) (includes? b a)) a)])]
[else (andmap (lambda (b) (includes? a b)) b)]))
(unless (includes? b a)
;; Let core report error:
(apply chaperone-procedure proc wrap-proc props))
(unless (subset? b-req a-req)
(raise-arguments-error
name
"wrapper procedure requires more keywords than original procedure"
"wrapper procedure" wrap-proc
"original procedure" proc))
(unless (or (not b-allow)
(and a-allow
(subset? a-allow b-allow)))
(raise-arguments-error
name
"wrapper procedure does not accept all keywords of original procedure"
"wrapper procedure" wrap-proc
"original procedure" proc))
(void)))
(define (normalize-proc proc)
;; If `proc' gets keyword support through `new-prop:procedure',
;; then wrap it to normalize to to something that matches

3
racket/collects/racket/private/pre-base.rkt
View File

@ -219,7 +219,9 @@
(rename new:procedure->method procedure->method)
(rename new:procedure-rename procedure-rename)
(rename new:chaperone-procedure chaperone-procedure)
(rename new:unsafe-chaperone-procedure unsafe-chaperone-procedure)
(rename new:impersonate-procedure impersonate-procedure)
(rename new:unsafe-impersonate-procedure unsafe-impersonate-procedure)
(rename new:chaperone-procedure* chaperone-procedure*)
(rename new:impersonate-procedure* impersonate-procedure*)
(rename new:collection-path collection-path)
@ -228,6 +230,7 @@
procedure-arity procedure-reduce-arity raise-arity-error
procedure->method procedure-rename
chaperone-procedure impersonate-procedure
unsafe-chaperone-procedure unsafe-impersonate-procedure
chaperone-procedure* impersonate-procedure*
assq assv assoc
prop:incomplete-arity prop:method-arity-error

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

File diff suppressed because it is too large Load Diff

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

@ -182,7 +182,9 @@ static Scheme_Object *procedure_to_method(int argc, Scheme_Object *argv[]);
static Scheme_Object *procedure_equal_closure_p(int argc, Scheme_Object *argv[]);
static Scheme_Object *procedure_specialize(int argc, Scheme_Object *argv[]);
static Scheme_Object *chaperone_procedure(int argc, Scheme_Object *argv[]);
static Scheme_Object *unsafe_chaperone_procedure(int argc, Scheme_Object *argv[]);
static Scheme_Object *impersonate_procedure(int argc, Scheme_Object *argv[]);
static Scheme_Object *unsafe_impersonate_procedure(int argc, Scheme_Object *argv[]);
static Scheme_Object *chaperone_procedure_star(int argc, Scheme_Object *argv[]);
static Scheme_Object *impersonate_procedure_star(int argc, Scheme_Object *argv[]);
static Scheme_Object *primitive_p(int argc, Scheme_Object *argv[]);
@ -608,11 +610,21 @@ scheme_init_fun (Scheme_Env *env)
"chaperone-procedure",
2, -1),
env);
scheme_add_global_constant("unsafe-chaperone-procedure",
scheme_make_prim_w_arity(unsafe_chaperone_procedure,
"unsafe-chaperone-procedure",
2, -1),
env);
scheme_add_global_constant("impersonate-procedure",
scheme_make_prim_w_arity(impersonate_procedure,
"impersonate-procedure",
2, -1),
env);
scheme_add_global_constant("unsafe-impersonate-procedure",
scheme_make_prim_w_arity(unsafe_impersonate_procedure,
"unsafe-impersonate-procedure",
2, -1),
env);
scheme_add_global_constant("chaperone-procedure*",
scheme_make_prim_w_arity(chaperone_procedure_star,
"chaperone-procedure*",
@ -3465,7 +3477,7 @@ static Scheme_Object *procedure_specialize(int argc, Scheme_Object *argv[])
static Scheme_Object *do_chaperone_procedure(const char *name, const char *whating,
int is_impersonator, int pass_self,
int argc, Scheme_Object *argv[])
int argc, Scheme_Object *argv[], int is_unsafe)
{
Scheme_Chaperone *px;
Scheme_Object *val = argv[0], *orig, *naya, *r, *app_mark;
@ -3476,8 +3488,13 @@ static Scheme_Object *do_chaperone_procedure(const char *name, const char *whati
if (!SCHEME_PROCP(val))
scheme_wrong_contract(name, "procedure?", 0, argc, argv);
if (!SCHEME_FALSEP(argv[1]) && !SCHEME_PROCP(argv[1]))
scheme_wrong_contract(name, "(or/c procedure? #f)", 1, argc, argv);
if (is_unsafe) {
if (!SCHEME_PROCP(argv[1]))
scheme_wrong_contract(name, "procedure?", 1, argc, argv);
} else {
if (!SCHEME_FALSEP(argv[1]) && !SCHEME_PROCP(argv[1]))
scheme_wrong_contract(name, "(or/c procedure? #f)", 1, argc, argv);
}
orig = get_or_check_arity(val, -1, NULL, 1);
if (SCHEME_FALSEP(argv[1]))
@ -3524,16 +3541,35 @@ static Scheme_Object *do_chaperone_procedure(const char *name, const char *whati
px->props = props;
/* Put the procedure along with known-good arity (to speed checking;
initialized to -1) in a vector. An odd-sized vector makes the
chaperone recognized as a procedure chaperone, and a size of 5
(instead of 3) indicates that the wrapper procedure accepts a
"self" argument: */
initialized to -1) in a vector.
Vector of odd size for redirects means a procedure chaperone,
vector with even slots means a structure chaperone.
A size of 5 (instead of 3) indicates that the wrapper
procedure accepts a "self" argument
If the known-good arity is a boolean, this means the chaperone
wrapper defers directly to SCHEME_VEC_ELES(r)[0], instead of
following the actual chaperone procedure.
If the boolean is #f, that means the interposition proc was #f
originally and SCHEME_VEC_ELES(r)[0] is the original procedure.
If the boolean is #t, that means that this chaperone was created
via unsafe-{chaperone,impersonate}-procedure.
*/
r = scheme_make_vector((pass_self ? 5 : 3), scheme_make_integer(-1));
SCHEME_VEC_ELS(r)[0] = argv[1];
if (SCHEME_FALSEP(argv[1]))
SCHEME_VEC_ELS(r)[0] = argv[0];
else
SCHEME_VEC_ELS(r)[0] = argv[1];
if (is_unsafe)
SCHEME_VEC_ELS(r)[1] = scheme_true;
if (SCHEME_FALSEP(argv[1]))
SCHEME_VEC_ELS(r)[1] = scheme_false;
SCHEME_VEC_ELS(r)[2] = app_mark;
/* Vector of odd size for redirects means a procedure chaperone,
vector with even slots means a structure chaperone. */
px->redirects = r;
if (is_impersonator)
@ -3544,22 +3580,32 @@ static Scheme_Object *do_chaperone_procedure(const char *name, const char *whati
static Scheme_Object *chaperone_procedure(int argc, Scheme_Object *argv[])
{
return do_chaperone_procedure("chaperone-procedure", "chaperoning", 0, 0, argc, argv);
return do_chaperone_procedure("chaperone-procedure", "chaperoning", 0, 0, argc, argv, 0);
}
static Scheme_Object *unsafe_chaperone_procedure(int argc, Scheme_Object *argv[])
{
return do_chaperone_procedure("unsafe-chaperone-procedure", "chaperoning", 0, 0, argc, argv, 1);
}
static Scheme_Object *impersonate_procedure(int argc, Scheme_Object *argv[])
{
return do_chaperone_procedure("impersonate-procedure", "impersonating", 1, 0, argc, argv);
return do_chaperone_procedure("impersonate-procedure", "impersonating", 1, 0, argc, argv, 0);
}
static Scheme_Object *unsafe_impersonate_procedure(int argc, Scheme_Object *argv[])
{
return do_chaperone_procedure("unsafe-impersonate-procedure", "impersonating", 1, 0, argc, argv, 1);
}
static Scheme_Object *chaperone_procedure_star(int argc, Scheme_Object *argv[])
{
return do_chaperone_procedure("chaperone-procedure*", "chaperoning", 0, 1, argc, argv);
return do_chaperone_procedure("chaperone-procedure*", "chaperoning", 0, 1, argc, argv, 0);
}
static Scheme_Object *impersonate_procedure_star(int argc, Scheme_Object *argv[])
{
return do_chaperone_procedure("impersonate-procedure*", "impersonating", 1, 1, argc, argv);
return do_chaperone_procedure("impersonate-procedure*", "impersonating", 1, 1, argc, argv, 0);
}
static Scheme_Object *apply_chaperone_k(void)
@ -3741,7 +3787,7 @@ Scheme_Object *scheme_apply_chaperone(Scheme_Object *o, int argc, Scheme_Object
checks & 0x2 => no tail; checks == 0x3 => no tail or multiple */
{
Scheme_Chaperone *px;
Scheme_Object *v, *a[1], *a2[MAX_QUICK_CHAP_ARGV], **argv2, *post, *result_v, *orig_obj, *app_mark, *self_proc;
Scheme_Object *v, *a[1], *a2[MAX_QUICK_CHAP_ARGV], **argv2, *post, *result_v, *orig_obj, *app_mark, *self_proc, *simple_call;
int c, i, need_restore = 0;
int need_pop_mark;
Scheme_Cont_Frame_Data cframe;
@ -3767,9 +3813,10 @@ Scheme_Object *scheme_apply_chaperone(Scheme_Object *o, int argc, Scheme_Object
self_proc = o;
}
if (SCHEME_FALSEP(SCHEME_VEC_ELS(px->redirects)[0])) {
if (SCHEME_BOOLP(SCHEME_VEC_ELS(px->redirects)[1])) {
simple_call = SCHEME_VEC_ELS(px->redirects)[0];
/* no redirection procedure */
if (SCHEME_CHAPERONEP(px->prev)) {
if (SCHEME_CHAPERONEP(simple_call)) {
/* communicate `self_proc` to the next layer: */
scheme_current_thread->self_for_proc_chaperone = self_proc;
}
@ -3777,16 +3824,16 @@ Scheme_Object *scheme_apply_chaperone(Scheme_Object *o, int argc, Scheme_Object
/* cannot return a tail call */
MZ_CONT_MARK_POS -= 2;
if (checks & 0x1) {
v = _scheme_apply(px->prev, argc, argv);
} else if (SAME_TYPE(SCHEME_TYPE(px->prev), scheme_native_closure_type)) {
v = _apply_native(px->prev, argc, argv);
v = _scheme_apply(simple_call, argc, argv);
} else if (SAME_TYPE(SCHEME_TYPE(simple_call), scheme_native_closure_type)) {
v = _apply_native(simple_call, argc, argv);
} else {
v = _scheme_apply_multi(px->prev, argc, argv);
v = _scheme_apply_multi(simple_call, argc, argv);
}
MZ_CONT_MARK_POS += 2;
return v;
} else
return _scheme_tail_apply(px->prev, argc, argv);
return _scheme_tail_apply(simple_call, argc, argv);
}
if (argv == MZ_RUNSTACK) {

16
racket/src/racket/src/jitcall.c
View File

@ -111,16 +111,22 @@ static jit_insn *generate_proc_struct_retry(mz_jit_state *jitter, int num_rands,
CHECK_LIMIT();
mz_patch_branch(ref2);
/* check for a procedure impersonator that just keeps properties */
/* check for a procedure impersonator that just keeps properties
or is the result of unsafe-{impersonate,chaperone}-procedure */
ref2 = jit_bnei_i(jit_forward(), JIT_R1, scheme_proc_chaperone_type);
jit_ldxi_p(JIT_R1, JIT_V1, &((Scheme_Chaperone *)0x0)->redirects);
refz6 = mz_bnei_t(jit_forward(), JIT_R1, scheme_vector_type, JIT_R2);
(void)jit_ldxi_l(JIT_R2, JIT_R1, &SCHEME_VEC_SIZE(0x0));
refz7 = jit_bmci_i(jit_forward(), JIT_R2, 0x1);
(void)jit_ldxi_l(JIT_R2, JIT_R1, &(SCHEME_VEC_ELS(0x0)[0]));
refz8 = jit_bnei_p(jit_forward(), JIT_R2, scheme_false);
/* Can extract the impersonated function and use it directly */
jit_ldxi_p(JIT_V1, JIT_V1, &((Scheme_Chaperone *)0x0)->prev);
/* if &(SCHEME_VEC_ELS(0x0)[1]) is a boolean, we have the fast
path; it can only otherwise be a fixnum, so just check that */
(void)jit_ldxi_l(JIT_R2, JIT_R1, &(SCHEME_VEC_ELS(0x0)[1]));
refz8 = jit_bmsi_ul(jit_forward(), JIT_R2, 0x1);
/* Position [0] in SCHEME_VEC_ELS contains either the
unwrapped function (if chaperone-procedure got #f
for the proc argument) or the unsafe-chaperone
replacement-proc argument; either way, just call it */
jit_ldxi_p(JIT_V1, JIT_R1, &(SCHEME_VEC_ELS(0x0)[0]));
(void)jit_jmpi(refagain);
mz_patch_branch(refz1);

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

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

7
racket/src/racket/src/schnapp.inc
View File

@ -63,9 +63,10 @@ Scheme_Object *PRIM_APPLY_NAME(Scheme_Object *rator,
if ((t == scheme_proc_chaperone_type)
&& SCHEME_VECTORP(((Scheme_Chaperone *)rator)->redirects)
&& (SCHEME_VEC_SIZE(((Scheme_Chaperone *)rator)->redirects) & 0x1)) {
if (SCHEME_FALSEP(SCHEME_VEC_ELS(((Scheme_Chaperone *)rator)->redirects)[0])) {
/* No redirection proc (i.e, chaperone is just for properties) */
rator = ((Scheme_Chaperone *)rator)->prev;
if (SCHEME_BOOLP(SCHEME_VEC_ELS(((Scheme_Chaperone *)rator)->redirects)[1])) {
/* No redirection proc, i.e, chaperone is just for
properties or unsafe-chaperone-procedure result */
rator = SCHEME_VEC_ELS(((Scheme_Chaperone *)rator)->redirects)[0];
t = _SCHEME_TYPE(rator);
} else
return scheme_apply_chaperone(rator, argc, argv, NULL, PRIM_CHECK_MULTI | (PRIM_CHECK_VALUE << 1));

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

@ -13,12 +13,12 @@
consistently.)
*/
#define MZSCHEME_VERSION "6.4.0.1"
#define MZSCHEME_VERSION "6.4.0.2"
#define MZSCHEME_VERSION_X 6
#define MZSCHEME_VERSION_Y 4
#define MZSCHEME_VERSION_Z 0
#define MZSCHEME_VERSION_W 1
#define MZSCHEME_VERSION_W 2
#define MZSCHEME_VERSION_MAJOR ((MZSCHEME_VERSION_X * 100) + MZSCHEME_VERSION_Y)
#define MZSCHEME_VERSION_MINOR ((MZSCHEME_VERSION_Z * 1000) + MZSCHEME_VERSION_W)

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

@ -2428,9 +2428,9 @@ int scheme_is_noninterposing_chaperone(Scheme_Object *o)
if (SCHEME_VEC_SIZE(px->redirects) & 1) {
/* procedure chaperone */
if (SCHEME_TRUEP(SCHEME_VEC_ELS(px->redirects)[0]))
return 0;
return 1;
if (SCHEME_FALSEP(SCHEME_VEC_ELS(px->redirects)[1]))
return 1;
return 0;
}
if (SCHEME_TRUEP(SCHEME_VEC_ELS(px->redirects)[0]))