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

add {impersonate,chaperone}-procedure*

Browse Source 
The new variants pass a "self" argument to the wrapper procedure in
the same way that `{impersonate,chaperone}-struct` provides a "self"
argument to redirection procedures.
This commit is contained in:
Matthew Flatt 2014-11-12 09:29:13 -07:00
parent 50a8863169
commit 1681126ed5
13 changed files with 1496 additions and 1256 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.1.1.4")
(define version "6.1.1.5")
(define deps `("racket-lib"
["racket" #:version ,version]))

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

@ -216,6 +216,28 @@ mark during the call to @racket[wrapper-proc] (which allows tail-calls
of impersonators with respect to wrapping impersonators to be detected within
@racket[wrapper-proc]).}
@defproc[(impersonate-procedure* [proc procedure?]
[wrapper-proc (or/c procedure? #f)]
[prop impersonator-property?]
[prop-val any] ... ...)
(and/c procedure? impersonator?)]{
Like @racket[impersonate-procedure], except that @racket[wrapper-proc]
receives an additional argument before all other arguments. The
additional argument is the procedure @racket[_orig-proc] that was
original applied.
If the result of @racket[impersonate-procedure*] is applied directly,
then @racket[_orig-proc] is that result. If the result is further
impersonated before being applied, however, @racket[_orig-proc] is the
further impersonator.
An @racket[_orig-proc] argument might be useful so that
@racket[wrapper-proc] can extract @tech{impersonator properties}
that are overridden by further impersonators, for example.
@history[#:added "6.1.1.5"]}
@defproc[(impersonate-struct [v any/c]
[orig-proc (or/c struct-accessor-procedure?
@ -583,6 +605,19 @@ chaperone procedure (i.e., not counting optional arguments that were
not supplied). The arguments must be ordered according to the sorted
order of the supplied arguments' keywords.}
@defproc[(chaperone-procedure* [proc procedure?]
[wrapper-proc (or/c procedure? #f)]
[prop impersonator-property?]
[prop-val any] ... ...)
(and/c procedure? chaperone?)]{
Like @racket[chaperone-procedure], but @racket[wrapper-proc] receives
an extra argument as with @racket[impersonate-procedure*].
@history[#:added "6.1.1.5"]}
@defproc[(chaperone-struct [v any/c]
[orig-proc (or/c struct-accessor-procedure?
struct-mutator-procedure?

107
pkgs/racket-pkgs/racket-test/tests/racket/chaperone.rktl
View File

@ -13,10 +13,10 @@
(test #t impersonator? a)
(chaperone? a))
(define-syntax-rule (as-chaperone-or-impersonator ([orig impersonator] ...) body ...)
(define-syntax-rule (as-chaperone-or-impersonator ([orig impersonator ...] ...) body ...)
(for-each (lambda (orig ...)
body ...)
(list orig impersonator) ...))
(list orig impersonator ...) ...))
;; ----------------------------------------
@ -59,14 +59,24 @@
(let* ([p (lambda (x) x)]
[p1 (impersonate-procedure p (lambda (y) y))]
[p2 (chaperone-procedure p1 (lambda (y) y))])
[p2 (chaperone-procedure p1 (lambda (y) y))]
[p1* (impersonate-procedure* p (lambda (self y) y))]
[p2* (chaperone-procedure* p1 (lambda (self y) y))])
(test #t impersonator-of? p2 p)
(test #t impersonator-of? p2 p1)
(test #t impersonator? p1)
(test #f chaperone? p1)
(test #t chaperone? p2)
(test #f chaperone-of? p2 p)
(test #t chaperone-of? p2 p1))
(test #t chaperone-of? p2 p1)
(test #t impersonator-of? p2* p)
(test #t impersonator-of? p2* p1)
(test #t impersonator? p1*)
(test #f chaperone? p1*)
(test #t chaperone? p2*)
(test #f chaperone-of? p2* p)
(test #t chaperone-of? p2* p1))
;; ----------------------------------------
@ -211,14 +221,30 @@
(test #t chaperone?/impersonator (chaperone-procedure (lambda (x) x) (lambda (y) y)))
(test #t impersonator? (impersonate-procedure (lambda (x) x) (lambda (y) y)))
(test #t impersonator? (impersonate-procedure* (lambda (x) x) (lambda (self y) y)))
(test #t procedure? (chaperone-procedure (lambda (x) x) (lambda (y) y)))
(test #t procedure? (chaperone-procedure* (lambda (x) x) (lambda (self y) y)))
(test #t procedure? (impersonate-procedure (lambda (x) x) (lambda (y) y)))
(test #t procedure? (impersonate-procedure* (lambda (x) x) (lambda (self y) y)))
(test #t (lambda (x) (procedure? x)) (chaperone-procedure (lambda (x) x) (lambda (y) y)))
(test #t (lambda (x) (procedure? x)) (impersonate-procedure (lambda (x) x) (lambda (y) y)))
(err/rt-test (chaperone-procedure (lambda (x) x) (lambda (y z) y)))
(err/rt-test (impersonate-procedure (lambda (x) x) (lambda (y z) y)))
(err/rt-test (chaperone-procedure (case-lambda [() 0] [(x) x]) (lambda (y) y)))
(err/rt-test (impersonate-procedure (case-lambda [() 0] [(x) x]) (lambda (y) y)))
(err/rt-test (chaperone-procedure (case-lambda [() 0] [(x) x]) (lambda (y) y)))
(err/rt-test (impersonate-procedure (case-lambda [() 0] [(x) x]) (lambda (y) y)))
(err/rt-test (chaperone-procedure* (lambda (x) x) (lambda (y) y)))
(err/rt-test (impersonate-procedure* (lambda (x) x) (lambda (y) y)))
(err/rt-test (chaperone-procedure* (lambda (x) x) (lambda (self z y) y)))
(err/rt-test (impersonate-procedure* (lambda (x) x) (lambda (self z y) y)))
(err/rt-test (chaperone-procedure* (case-lambda [() 0] [(x) x]) (lambda (self y) y)))
(err/rt-test (chaperone-procedure* (case-lambda [() 0] [(x) x]) (case-lambda [() 0] [(self y) y])))
(err/rt-test (impersonate-procedure* (case-lambda [() 0] [(x) x]) (case-lambda [() 0] [(self y) y])))
(err/rt-test (chaperone-procedure* (case-lambda [() 0] [(x) x]) (case-lambda [(self) 0] [(self z y) y])))
(err/rt-test (impersonate-procedure* (case-lambda [() 0] [(x) x]) (case-lambda [(self) 0] [(self z y) y])))
(test #t procedure? (chaperone-procedure* (case-lambda [() 0] [(x) x]) (case-lambda [(self) 0] [(self y) y])))
(test #t procedure? (impersonate-procedure* (case-lambda [() 0] [(x) x]) (case-lambda [(self) 0] [(self y) y])))
(test 88 (impersonate-procedure (lambda (x) x) (lambda (y) 88)) 10)
(err/rt-test ((chaperone-procedure (lambda (x) x) (lambda (y) 88)) 10))
@ -226,9 +252,52 @@
(test 89 (impersonate-procedure (lambda (x) x) (lambda (y) (values (lambda (z) 89) y))) 10)
(err/rt-test ((chaperone-procedure (lambda (x) x) (lambda (y) (values (lambda (z) 89) y))) 10))
(test 88 (impersonate-procedure* (lambda (x) x) (lambda (self y) 88)) 10)
(letrec ([final (impersonate-procedure*
(impersonate-procedure
(impersonate-procedure* (lambda (x) x)
(lambda (self y)
(test #t eq? self final)
(add1 y)))
(lambda (y)
(add1 y)))
(lambda (self y)
(test #t eq? self final)
(add1 y)))])
(test 13 final 10))
(letrec ([final (impersonate-procedure*
(impersonate-procedure
(impersonate-procedure* (lambda (x) x)
(lambda (self y)
(test #t eq? self final)
(values list (add1 y))))
(lambda (y)
(values list (add1 y))))
(lambda (self y)
(test #t eq? self final)
(values list (add1 y))))])
(test '(((13))) final 10))
(define (chaperone-procedure** a b)
(chaperone-procedure* a (lambda (self . args)
(apply b args))))
(define (impersonate-procedure** a b)
(impersonate-procedure* a (lambda (self . args)
(apply b args))))
(define (chaperone-procedure**/kw a b)
(chaperone-procedure* a (make-keyword-procedure
(lambda (kws kw-args self . args)
(keyword-apply b kws kw-args args)))))
(define (impersonate-procedure**/kw a b)
(impersonate-procedure* a (make-keyword-procedure
(lambda (kws kw-args self . args)
(keyword-apply b kws kw-args args)))))
;; Single argument, no post filter:
(as-chaperone-or-impersonator
([chaperone-procedure impersonate-procedure])
([chaperone-procedure impersonate-procedure
chaperone-procedure**
impersonate-procedure**])
(let* ([f (lambda (x) (list x x))]
[in #f]
[f2 (chaperone-procedure
@ -243,7 +312,9 @@
;; Multiple arguments, no post filter:
(as-chaperone-or-impersonator
([chaperone-procedure impersonate-procedure])
([chaperone-procedure impersonate-procedure
chaperone-procedure**
impersonate-procedure**])
(let* ([f (lambda (x y) (list x y))]
[in #f]
[f2 (chaperone-procedure
@ -258,7 +329,9 @@
;; Single argument, post filter on single value:
(as-chaperone-or-impersonator
([chaperone-procedure impersonate-procedure])
([chaperone-procedure impersonate-procedure
chaperone-procedure**
impersonate-procedure**])
(let* ([f (lambda (x) (list x x))]
[in #f]
[out #f]
@ -279,7 +352,9 @@
;; Multiple arguments, post filter on multiple values:
(as-chaperone-or-impersonator
([chaperone-procedure impersonate-procedure])
([chaperone-procedure impersonate-procedure
chaperone-procedure**
impersonate-procedure**])
(let* ([f (lambda (x y z) (values y (list x z)))]
[in #f]
[out #f]
@ -300,7 +375,9 @@
;; Optional keyword arguments:
(as-chaperone-or-impersonator
([chaperone-procedure impersonate-procedure])
([chaperone-procedure impersonate-procedure
chaperone-procedure**/kw
impersonate-procedure**/kw])
(let* ([f (lambda (x #:a [a 'a] #:b [b 'b]) (list x a b))]
[in #f]
[f2 (chaperone-procedure
@ -327,7 +404,9 @@
;; Optional keyword arguments with result chaperone:
(as-chaperone-or-impersonator
([chaperone-procedure impersonate-procedure])
([chaperone-procedure impersonate-procedure
chaperone-procedure**/kw
impersonate-procedure**/kw])
(let* ([f (lambda (x #:a [a 'a] #:b [b 'b]) (list x a b))]
[in #f]
[out #f]
@ -360,7 +439,9 @@
;; Required keyword arguments:
(as-chaperone-or-impersonator
([chaperone-procedure impersonate-procedure])
([chaperone-procedure impersonate-procedure
chaperone-procedure**/kw
impersonate-procedure**/kw])
(let* ([f (lambda (x #:a [a 'a] #:b b) (list x a b))]
[in #f]
[f2 (chaperone-procedure
@ -387,7 +468,9 @@
;; Required keyword arguments:
(as-chaperone-or-impersonator
([chaperone-procedure impersonate-procedure])
([chaperone-procedure impersonate-procedure
chaperone-procedure**/kw
impersonate-procedure**/kw])
(let* ([f (lambda (x #:a [a 'a] #:b b) (list x a b))]
[in #f]
[out #f]

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

@ -27,6 +27,8 @@
new:procedure-rename
new:chaperone-procedure
new:impersonate-procedure
new:chaperone-procedure*
new:impersonate-procedure*
(for-syntax kw-expander? kw-expander-impl kw-expander-proc
syntax-procedure-alias-property
syntax-procedure-converted-arguments-property))
@ -1522,18 +1524,30 @@
procedure-rename))
(define new:chaperone-procedure
(let ([chaperone-procedure
(let ([chaperone-procedure
(lambda (proc wrap-proc . props)
(do-chaperone-procedure #f chaperone-procedure 'chaperone-procedure proc wrap-proc props))])
(do-chaperone-procedure #f #f chaperone-procedure 'chaperone-procedure proc wrap-proc props))])
chaperone-procedure))
(define new:impersonate-procedure
(let ([impersonate-procedure
(let ([impersonate-procedure
(lambda (proc wrap-proc . props)
(do-chaperone-procedure #t impersonate-procedure 'impersonate-procedure proc wrap-proc props))])
(do-chaperone-procedure #t #f impersonate-procedure 'impersonate-procedure proc wrap-proc props))])
impersonate-procedure))
(define (do-chaperone-procedure is-impersonator? chaperone-procedure name proc wrap-proc props)
(define new:chaperone-procedure*
(let ([chaperone-procedure*
(lambda (proc wrap-proc . props)
(do-chaperone-procedure #f #t chaperone-procedure* 'chaperone-procedure proc wrap-proc props))])
chaperone-procedure*))
(define new:impersonate-procedure*
(let ([impersonate-procedure*
(lambda (proc wrap-proc . props)
(do-chaperone-procedure #t #t impersonate-procedure* 'impersonate-procedure proc wrap-proc props))])
impersonate-procedure*))
(define (do-chaperone-procedure is-impersonator? self-arg? 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))
@ -1550,20 +1564,21 @@
(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)]
[(number? a) (= b (+ a d))]
[(arity-at-least? a)
(b . >= . (arity-at-least-value 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))]
((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)]))
@ -1586,54 +1601,61 @@
"original procedure" proc))
(let*-values ([(kw-chaperone)
(let ([p (keyword-procedure-proc n-wrap-proc)])
(case-lambda
[(kws args . rest)
(call-with-values (lambda () (apply p kws args rest))
(lambda results
(let* ([len (length results)]
[alen (length rest)])
(unless (<= (+ alen 1) len (+ alen 2))
(raise-arguments-error
'|keyword procedure chaperone|
"wrong number of results from wrapper procedure"
"expected minimum number of results" (+ alen 1)
"expected maximum number of results" (+ alen 2)
"received number of results" len
"wrapper procedure" wrap-proc))
(let ([extra? (= len (+ alen 2))])
(let ([new-args ((if extra? cadr car) results)])
(unless (and (list? new-args)
(= (length new-args) (length args)))
(raise-arguments-error
'|keyword procedure chaperone|
(format
"expected a list of keyword-argument values as first result~a from wrapper procedure"
(if (= len alen)
""
" (after the result-wrapper procedure)"))
"first result" new-args
"wrapper procedure" wrap-proc))
(for-each
(lambda (kw new-arg arg)
(unless is-impersonator?
(unless (chaperone-of? new-arg arg)
(raise-arguments-error
'|keyword procedure chaperone|
(format
"~a keyword result is not a chaperone of original argument from chaperoning procedure"
kw)
"result" new-arg
"wrapper procedure" wrap-proc))))
kws
new-args
args))
(if extra?
(apply values (car results) kws (cdr results))
(apply values kws results))))))]
;; The following case exists only to make sure that the arity of
;; any procedure passed to `make-keyword-args' is covered
;; bu this procedure's arity.
[other (error "shouldn't get here")]))]
;; `extra-arg ...` will be `self-proc` if `self-arg?`:
(define-syntax gen-wrapper
(syntax-rules ()
[(_ extra-arg ...)
(case-lambda
[(extra-arg ... kws args . rest)
(call-with-values (lambda () (apply p kws args extra-arg ... rest))
(lambda results
(let* ([len (length results)]
[alen (length rest)])
(unless (<= (+ alen 1) len (+ alen 2))
(raise-arguments-error
'|keyword procedure chaperone|
"wrong number of results from wrapper procedure"
"expected minimum number of results" (+ alen 1)
"expected maximum number of results" (+ alen 2)
"received number of results" len
"wrapper procedure" wrap-proc))
(let ([extra? (= len (+ alen 2))])
(let ([new-args ((if extra? cadr car) results)])
(unless (and (list? new-args)
(= (length new-args) (length args)))
(raise-arguments-error
'|keyword procedure chaperone|
(format
"expected a list of keyword-argument values as first result~a from wrapper procedure"
(if (= len alen)
""
" (after the result-wrapper procedure)"))
"first result" new-args
"wrapper procedure" wrap-proc))
(for-each
(lambda (kw new-arg arg)
(unless is-impersonator?
(unless (chaperone-of? new-arg arg)
(raise-arguments-error
'|keyword procedure chaperone|
(format
"~a keyword result is not a chaperone of original argument from chaperoning procedure"
kw)
"result" new-arg
"wrapper procedure" wrap-proc))))
kws
new-args
args))
(if extra?
(apply values (car results) kws (cdr results))
(apply values kws results))))))]
;; The following case exists only to make sure that the arity of
;; any procedure passed to `make-keyword-args' is covered
;; by this procedure's arity.
[other (error "shouldn't get here")])]))
(if self-arg?
(gen-wrapper self-proc)
(gen-wrapper)))]
[(new-proc chap-accessor)
(let wrap ([proc proc] [n-proc n-proc])
(cond
@ -1664,16 +1686,24 @@
(chaperone-procedure
proc
(make-keyword-procedure
(lambda (kws kw-args self . args)
;; Chain to `kw-chaperone', pulling out the self
;; argument, and then putting it back:
(define len (length args))
(call-with-values
(lambda () (apply kw-chaperone kws kw-args args))
(lambda results
(if (= (length results) (add1 len))
(apply values (car results) self (cdr results))
(apply values (car results) (cadr results) self (cddr results))))))))))
(let ()
;; `extra-arg ...` will be `self-proc` if `self-arg?`:
(define-syntax gen-proc
(syntax-rules ()
[(_ extra-arg ...)
(lambda (extra-arg ... kws kw-args self . args)
;; Chain to `kw-chaperone', pulling out the self
;; argument, and then putting it back:
(define len (length args))
(call-with-values
(lambda () (apply kw-chaperone extra-arg ... kws kw-args args))
(lambda results
(if (= (length results) (add1 len))
(apply values (car results) self (cdr results))
(apply values (car results) (cadr results) self (cddr results))))))]))
(if self-arg?
(gen-proc proc-self)
(gen-proc)))))))
new-procedure-ref)])]
[(okp? n-proc)
(values
@ -1721,7 +1751,7 @@
new-proc
(apply chaperone-struct new-proc
;; chaperone-struct insists on having at least one selector:
chap-accessor (lambda (s v) v)
chap-accessor #f
props)))))))
(define (normalize-proc proc)

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

@ -175,12 +175,15 @@
(rename new:procedure-rename procedure-rename)
(rename new:chaperone-procedure chaperone-procedure)
(rename new:impersonate-procedure impersonate-procedure)
(rename new:chaperone-procedure* chaperone-procedure*)
(rename new:impersonate-procedure* impersonate-procedure*)
(rename new:collection-path collection-path)
(rename new:collection-file-path collection-file-path)
(all-from-except '#%kernel lambda λ #%app #%module-begin apply prop:procedure
procedure-arity procedure-reduce-arity raise-arity-error
procedure->method procedure-rename
chaperone-procedure impersonate-procedure
chaperone-procedure* impersonate-procedure*
assq assv assoc
prop:incomplete-arity prop:method-arity-error)
(all-from "reqprov.rkt")

4
racket/src/racket/include/scheme.h
View File

@ -1214,6 +1214,10 @@ typedef struct Scheme_Thread {
} k;
} ku;
/* To pass the current procedure from one chaperone
layer to the next: */
Scheme_Object *self_for_proc_chaperone;
short suspend_break;
short external_break;

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

File diff suppressed because it is too large Load Diff

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

@ -1377,6 +1377,8 @@ static Scheme_Object **evacuate_runstack(int num_rands, Scheme_Object **rands, S
static Scheme_Object *do_eval_k_readjust_mark(void)
{
Scheme_Thread *p = scheme_current_thread;
p->self_for_proc_chaperone = p->ku.k.p3;
MZ_CONT_MARK_POS -= 2; /* undo increment in do_eval_stack_overflow() */
return do_eval_k();
}
@ -1405,6 +1407,9 @@ static Scheme_Object *do_eval_stack_overflow(Scheme_Object *obj, int num_rands,
p->ku.k.p2 = (void *)rands;
p->ku.k.i2 = get_value;
p->ku.k.p3 = p->self_for_proc_chaperone;
p->self_for_proc_chaperone = NULL;
/* In case we got here via scheme_force_value_same_mark(), in case
overflow handling causes the thread to sleep, and in case another
thread tries to get this thread's continuation marks: ensure tha

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

@ -188,6 +188,8 @@ 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 *chaperone_procedure(int argc, Scheme_Object *argv[]);
static Scheme_Object *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[]);
static Scheme_Object *primitive_closure_p(int argc, Scheme_Object *argv[]);
static Scheme_Object *primitive_result_arity (int argc, Scheme_Object *argv[]);
@ -608,6 +610,16 @@ scheme_init_fun (Scheme_Env *env)
"impersonate-procedure",
2, -1),
env);
scheme_add_global_constant("chaperone-procedure*",
scheme_make_prim_w_arity(chaperone_procedure_star,
"chaperone-procedure*",
2, -1),
env);
scheme_add_global_constant("impersonate-procedure*",
scheme_make_prim_w_arity(impersonate_procedure_star,
"impersonate-procedure*",
2, -1),
env);
scheme_add_global_constant("primitive?",
scheme_make_folding_prim(primitive_p,
@ -3049,15 +3061,17 @@ static Scheme_Object *make_reduced_proc(Scheme_Object *proc, Scheme_Object *aty,
return scheme_make_struct_instance(scheme_reduced_procedure_struct, 4, a);
}
static int is_subarity(Scheme_Object *req, Scheme_Object *orig)
static int is_subarity(Scheme_Object *req, Scheme_Object *orig, int req_delta)
{
Scheme_Object *oa, *ra, *ol, *lra, *ara, *prev, *pr, *tmp;
Scheme_Object *oa, *ra, *ol, *lra, *ara, *prev, *pr, *tmp, *rd;
if (!SCHEME_PAIRP(orig) && !SCHEME_NULLP(orig))
orig = scheme_make_pair(orig, scheme_null);
if (!SCHEME_PAIRP(req) && !SCHEME_NULLP(req))
req = scheme_make_pair(req, scheme_null);
rd = scheme_make_integer(req_delta);
while (!SCHEME_NULLP(req)) {
ra = SCHEME_CAR(req);
if (SCHEME_CHAPERONE_STRUCTP(ra)
@ -3075,12 +3089,12 @@ static int is_subarity(Scheme_Object *req, Scheme_Object *orig)
oa = SCHEME_CAR(ol);
if (SCHEME_INTP(ra) || SCHEME_BIGNUMP(ra)) {
if (SCHEME_INTP(oa) || SCHEME_BIGNUMP(oa)) {
if (scheme_equal(ra, oa))
if (scheme_equal(scheme_bin_plus(ra, rd), oa))
break;
} else {
/* orig is arity-at-least */
oa = ((Scheme_Structure *)oa)->slots[0];
if (scheme_bin_lt_eq(oa, ra))
if (scheme_bin_lt_eq(oa, scheme_bin_plus(ra, rd)))
break;
}
} else {
@ -3100,10 +3114,10 @@ static int is_subarity(Scheme_Object *req, Scheme_Object *orig)
/* check [lo, hi] vs oa: */
ara = SCHEME_CAR(lra);
if (SCHEME_FALSEP(SCHEME_CDR(ara))
|| scheme_bin_lt_eq(oa, SCHEME_CDR(ara))) {
if (scheme_bin_gt_eq(oa, SCHEME_CAR(ara))) {
|| scheme_bin_lt_eq(oa, scheme_bin_plus(SCHEME_CDR(ara), rd))) {
if (scheme_bin_gt_eq(oa, scheme_bin_plus(SCHEME_CAR(ara), rd))) {
/* oa is in the range [lo, hi]: */
if (scheme_equal(oa, SCHEME_CAR(ara))) {
if (scheme_equal(oa, scheme_bin_plus(SCHEME_CAR(ara), rd))) {
/* the range is [oa, hi] */
if (at_least) {
/* oa is arity-at least, so drop from here */
@ -3112,7 +3126,7 @@ static int is_subarity(Scheme_Object *req, Scheme_Object *orig)
else
ra = scheme_null;
} else {
if (scheme_equal(oa, SCHEME_CDR(ara))) {
if (scheme_equal(oa, scheme_bin_plus(SCHEME_CDR(ara), rd))) {
/* the range is [oa, oa], so drop it */
if (prev)
SCHEME_CDR(prev) = SCHEME_CDR(lra);
@ -3121,12 +3135,14 @@ static int is_subarity(Scheme_Object *req, Scheme_Object *orig)
} else {
/* change range to [ao+1, hi] */
tmp = scheme_bin_plus(oa, scheme_make_integer(1));
tmp = scheme_bin_minus(tmp, rd);
SCHEME_CAR(ara) = tmp;
}
}
} else if (scheme_equal(oa, SCHEME_CAR(ara))) {
} else if (scheme_equal(oa, scheme_bin_plus(SCHEME_CAR(ara), rd))) {
/* the range is [lo, oa], where lo < oa */
tmp = scheme_bin_minus(oa, scheme_make_integer(1));
tmp = scheme_bin_minus(tmp, rd);
SCHEME_CDR(ara) = tmp;
if (at_least)
SCHEME_CDR(lra) = scheme_null;
@ -3134,13 +3150,16 @@ static int is_subarity(Scheme_Object *req, Scheme_Object *orig)
/* split the range */
if (at_least) {
tmp = scheme_bin_minus(oa, scheme_make_integer(1));
tmp = scheme_bin_minus(tmp, rd);
SCHEME_CDR(ara) = tmp;
SCHEME_CDR(lra) = scheme_null;
} else {
pr = scheme_make_pair(scheme_make_pair(scheme_bin_plus(oa, scheme_make_integer(1)),
SCHEME_CDR(ara)),
tmp = scheme_bin_plus(oa, scheme_make_integer(1));
tmp = scheme_bin_minus(tmp, rd);
pr = scheme_make_pair(scheme_make_pair(tmp, SCHEME_CDR(ara)),
SCHEME_CDR(lra));
tmp = scheme_bin_minus(oa, scheme_make_integer(1));
tmp = scheme_bin_minus(tmp, rd);
SCHEME_CDR(ara) = tmp;
SCHEME_CDR(lra) = pr;
}
@ -3227,7 +3246,7 @@ static Scheme_Object *procedure_reduce_arity(int argc, Scheme_Object *argv[])
orig = get_or_check_arity(argv[0], -1, NULL, 1);
aty = clone_arity(argv[1], 0, -1);
if (!is_subarity(aty, orig)) {
if (!is_subarity(aty, orig, 0)) {
scheme_contract_error("procedure-reduce-arity",
"arity of procedure does not include requested arity",
"procedure", 1, argv[0],
@ -3382,7 +3401,8 @@ static Scheme_Object *procedure_equal_closure_p(int argc, Scheme_Object *argv[])
}
static Scheme_Object *do_chaperone_procedure(const char *name, const char *whating,
int is_impersonator, int argc, Scheme_Object *argv[])
int is_impersonator, int pass_self,
int argc, Scheme_Object *argv[])
{
Scheme_Chaperone *px;
Scheme_Object *val = argv[0], *orig, *naya, *r, *app_mark;
@ -3402,12 +3422,13 @@ static Scheme_Object *do_chaperone_procedure(const char *name, const char *whati
else {
naya = get_or_check_arity(argv[1], -1, NULL, 1);
if (!is_subarity(orig, naya))
if (!is_subarity(orig, naya, pass_self ? 1 : 0))
scheme_raise_exn(MZEXN_FAIL_CONTRACT,
"%s: arity of wrapper procedure does not cover arity of original procedure\n"
"%s: arity of wrapper procedure does not cover arity of original procedure%s\n"
" wrapper: %V\n"
" original: %V",
name,
(pass_self ? " (adding an extra argument)": ""),
argv[1],
argv[0]);
}
@ -3439,8 +3460,12 @@ static Scheme_Object *do_chaperone_procedure(const char *name, const char *whati
px->prev = argv[0];
px->props = props;
/* put procedure with known-good arity (to speed checking) in a vector: */
r = scheme_make_vector(3, scheme_make_integer(-1));
/* 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: */
r = scheme_make_vector((pass_self ? 5 : 3), scheme_make_integer(-1));
SCHEME_VEC_ELS(r)[0] = argv[1];
SCHEME_VEC_ELS(r)[2] = app_mark;
@ -3456,12 +3481,22 @@ 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, argc, argv);
return do_chaperone_procedure("chaperone-procedure", "chaperoning", 0, 0, argc, argv);
}
static Scheme_Object *impersonate_procedure(int argc, Scheme_Object *argv[])
{
return do_chaperone_procedure("impersonate-procedure", "impersonating", 1, argc, argv);
return do_chaperone_procedure("impersonate-procedure", "impersonating", 1, 0, argc, argv);
}
static Scheme_Object *chaperone_procedure_star(int argc, Scheme_Object *argv[])
{
return do_chaperone_procedure("chaperone-procedure*", "chaperoning", 0, 1, argc, argv);
}
static Scheme_Object *impersonate_procedure_star(int argc, Scheme_Object *argv[])
{
return do_chaperone_procedure("impersonate-procedure*", "impersonating", 1, 1, argc, argv);
}
static Scheme_Object *apply_chaperone_k(void)
@ -3539,11 +3574,12 @@ Scheme_Object *_scheme_apply_native(Scheme_Object *obj, int num_rands, Scheme_Ob
#define MAX_QUICK_CHAP_ARGV 5
Scheme_Object *scheme_apply_chaperone(Scheme_Object *o, int argc, Scheme_Object **argv, Scheme_Object *auto_val, int checks)
/* checks & 0x2 => no tail; checks == 0x3 => no tail or multiple; */
/* auto_val => no need to actually call the function (but handle further chaperoning);
checks & 0x2 => no tail; checks == 0x3 => no tail or multiple */
{
const char *what;
Scheme_Chaperone *px;
Scheme_Object *v, *a[1], *a2[MAX_QUICK_CHAP_ARGV], **argv2, *post, *result_v, *orig_obj, *app_mark;
Scheme_Object *v, *a[1], *a2[MAX_QUICK_CHAP_ARGV], **argv2, *post, *result_v, *orig_obj, *app_mark, *self_proc;
int c, i, need_restore = 0;
int need_pop_mark;
Scheme_Cont_Frame_Data cframe;
@ -3575,6 +3611,15 @@ Scheme_Object *scheme_apply_chaperone(Scheme_Object *o, int argc, Scheme_Object
}
px = (Scheme_Chaperone *)o;
{
Scheme_Thread *p = scheme_current_thread;
self_proc = p->self_for_proc_chaperone;
if (self_proc)
p->self_for_proc_chaperone = NULL;
else
self_proc = o;
}
if (!(SCHEME_CHAPERONE_FLAGS(px) & SCHEME_CHAPERONE_IS_IMPERSONATOR))
what = "chaperone";
else
@ -3618,11 +3663,29 @@ Scheme_Object *scheme_apply_chaperone(Scheme_Object *o, int argc, Scheme_Object
} else
need_pop_mark = 0;
if (SCHEME_VEC_SIZE(px->redirects) > 3) {
/* wrapper wants the "self" argument */
c = argc+1;
if (c <= MAX_QUICK_CHAP_ARGV)
argv2 = a2;
else
argv2 = MALLOC_N(Scheme_Object *, MAX_QUICK_CHAP_ARGV);
for (i = 0; i < argc; i++) {
argv2[i+1] = argv[i];
}
argv2[0] = self_proc;
} else {
/* wrapper doesn't need the extra "self" argument */
c = argc;
argv2 = argv;
}
v = SCHEME_VEC_ELS(px->redirects)[0];
if (SAME_TYPE(SCHEME_TYPE(v), scheme_native_closure_type))
v = _apply_native(v, argc, argv);
v = _apply_native(v, c, argv2);
else
v = _scheme_apply_multi(v, argc, argv);
v = _scheme_apply_multi(v, c, argv2);
if (v == SCHEME_MULTIPLE_VALUES) {
GC_CAN_IGNORE Scheme_Thread *p = scheme_current_thread;
c = p->ku.multiple.count;
@ -3700,6 +3763,10 @@ Scheme_Object *scheme_apply_chaperone(Scheme_Object *o, int argc, Scheme_Object
/* No filter for the result, so tail call: */
if (app_mark)
scheme_set_cont_mark(SCHEME_CAR(app_mark), SCHEME_CDR(app_mark));
if (SCHEME_CHAPERONEP(px->prev)) {
/* commuincate `self_proc` to the next layer: */
scheme_current_thread->self_for_proc_chaperone = self_proc;
}
if (auto_val) {
if (SCHEME_CHAPERONEP(px->prev))
return do_apply_chaperone(px->prev, c, argv2, auto_val, 0);
@ -3749,6 +3816,11 @@ Scheme_Object *scheme_apply_chaperone(Scheme_Object *o, int argc, Scheme_Object
}else
need_pop_mark = 0;
if (SCHEME_CHAPERONEP(px->prev)) {
/* commuincate `self_proc` to the next layer: */
scheme_current_thread->self_for_proc_chaperone = self_proc;
}
if (auto_val) {
if (SCHEME_CHAPERONEP(px->prev))
result_v = do_apply_chaperone(px->prev, argc, argv2, auto_val, 0);

4
racket/src/racket/src/mzmark_type.inc
View File

@ -1860,6 +1860,8 @@ static int thread_val_MARK(void *p, struct NewGC *gc) {
gcMARK2(pr->ku.k.p3, gc);
gcMARK2(pr->ku.k.p4, gc);
gcMARK2(pr->ku.k.p5, gc);
gcMARK2(pr->self_for_proc_chaperone, gc);
gcMARK2(pr->list_stack, gc);
@ -1975,6 +1977,8 @@ static int thread_val_FIXUP(void *p, struct NewGC *gc) {
gcFIXUP2(pr->ku.k.p3, gc);
gcFIXUP2(pr->ku.k.p4, gc);
gcFIXUP2(pr->ku.k.p5, gc);
gcFIXUP2(pr->self_for_proc_chaperone, gc);
gcFIXUP2(pr->list_stack, gc);

2
racket/src/racket/src/mzmarksrc.c
View File

@ -767,6 +767,8 @@ thread_val {
gcMARK2(pr->ku.k.p3, gc);
gcMARK2(pr->ku.k.p4, gc);
gcMARK2(pr->ku.k.p5, gc);
gcMARK2(pr->self_for_proc_chaperone, gc);
gcMARK2(pr->list_stack, gc);

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

@ -12,9 +12,9 @@
finally, set EXPECTED_PRIM_COUNT to the right value and
USE_COMPILED_STARTUP to 1 and `make' again. */
#define USE_COMPILED_STARTUP 1
#define USE_COMPILED_STARTUP 0
#define EXPECTED_PRIM_COUNT 1127
#define EXPECTED_PRIM_COUNT 1129
#define EXPECTED_UNSAFE_COUNT 106
#define EXPECTED_FLFXNUM_COUNT 69
#define EXPECTED_EXTFL_COUNT 45

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

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