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

fix problems with chaperoning/impersonating keyword functions

Browse Source
This commit is contained in:
Matthew Flatt 2017-03-29 12:26:48 -06:00
parent 1030e079c4
commit 92a0dcbcb0
3 changed files with 147 additions and 77 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

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

@ -2316,6 +2316,51 @@
(go (add-prop chaperone-procedure)
(add-prop impersonate-procedure)))
(let ()
(struct the-struct ()
#:property prop:procedure
(make-keyword-procedure (lambda (kws kw-values _ i) "result")))
(define struct-as-keyword-proc
(the-struct))
(define (check chaperone-procedure mangle?)
(define in-checked 0)
(define out-checked 0)
(define wrapped
(chaperone-procedure struct-as-keyword-proc
(make-keyword-procedure
(lambda (kws vals . args)
(set! in-checked (add1 in-checked))
(apply
values
(lambda (r)
(set! out-checked (add1 out-checked))
r)
vals
(if mangle?
;; Check that an impersonator doesn't have to act
;; like a chaperone:
(map list args)
args)))
(lambda args
(set! in-checked (add1 in-checked))
(apply
values
(lambda (r)
(set! out-checked (add1 out-checked))
r)
(if mangle?
(map list args)
args))))))
(wrapped "arg")
(test '(1 1) list in-checked out-checked)
(wrapped "arg" #:z 10)
(test '(2 2) list in-checked out-checked))
(check chaperone-procedure #f)
(check impersonate-procedure #t))
;; ----------------------------------------
(let ()

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

@ -160,7 +160,9 @@
(cons prop:procedure values)
;; Also imply `prop:procedure-accessor`, in case property
;; value is an integer:
(cons prop:procedure-accessor values))))
(cons prop:procedure-accessor values))
;; Can impersonate:
#t))
;; ----------------------------------------
;; Proxies
@ -1669,6 +1671,7 @@
kws
new-args
args))
;; Add back `kws` in the right place among the results:
(case num-extra
[(0) (apply values kws results)]
[(1) (apply values (car results) kws (cdr results))]
@ -1704,34 +1707,53 @@
f))
acc)]
[else
(values
(chaperone-struct
proc
new-procedure-ref
(lambda (self proc)
;; This `proc` takes an extra argument, which is `self`:
(chaperone-procedure
proc
(make-keyword-procedure
(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)])]
(let ([new-kw-proc
((if is-impersonator?
impersonate-struct
chaperone-struct)
(if (okp? n-proc)
;; All keyword arguments are optional, so need to
;; chaperone as a plain procedure, too:
(chaperone-procedure proc wrap-proc)
;; Some keyword is required:
proc)
new-procedure-ref
(lambda (self proc)
;; This `proc` takes an extra argument, which is `self`:
((if is-impersonator?
new:impersonate-procedure
new:chaperone-procedure)
proc
(make-keyword-procedure
(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
(define r-len (length results))
(define (list-take l n)
(if (zero? n) null (cons (car l) (list-take (cdr l) (sub1 n)))))
;; Drop out `kws` result, add in `self`:
(if (and (null? '(extra-arg ...))
(= r-len (+ 2 len)))
(apply values (cadr results) self (cddr results))
(apply values (let ([skip (- r-len len)])
(append (list-take results (- skip 2))
(list (list-ref results (sub1 skip))
self)
(list-tail results skip))))))))]))
(if self-arg?
(gen-proc proc-self)
(gen-proc)))))))])
(values new-kw-proc
new-procedure-ref))])]
[(okp? n-proc)
(values
(if is-impersonator?

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

@ -2653,6 +2653,7 @@ scheme_do_eval(Scheme_Object *obj, int num_rands, Scheme_Object **rands,
{
Scheme_Type type;
Scheme_Object *v;
int check_rands;
GC_CAN_IGNORE Scheme_Object *tmpv; /* safe-for-space relies on GC_CAN_IGNORE */
GC_CAN_IGNORE Scheme_Object **tmprands; /* safe-for-space relies on GC_CAN_IGNORE */
GC_MAYBE_IGNORE_INTERIOR Scheme_Object **old_runstack, **runstack_base;
@ -2753,6 +2754,8 @@ scheme_do_eval(Scheme_Object *obj, int num_rands, Scheme_Object **rands,
return scheme_enlarge_runstack(SCHEME_TAIL_COPY_THRESHOLD, (void *(*)(void))do_eval_k);
}
check_rands = num_rands;
apply_top:
/* DANGER: if rands == p->tail_buffer, we have to be careful to
@ -3091,68 +3094,63 @@ scheme_do_eval(Scheme_Object *obj, int num_rands, Scheme_Object **rands,
original object for an applicable structure. */
|| (type == scheme_raw_pair_type)) {
int is_method;
int check_rands = num_rands;
Scheme_Object *orig_obj;
if (SCHEME_RPAIRP(obj)) {
orig_obj = SCHEME_CDR(obj);
obj = SCHEME_CAR(obj);
} else {
orig_obj = obj;
}
orig_obj = obj;
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. */
if (SCHEME_RPAIRP(obj)) {
orig_obj = SCHEME_CDR(obj);
obj = SCHEME_CAR(obj);
}
type = SCHEME_TYPE(obj);
if (type == scheme_proc_struct_type) {
do {
VACATE_TAIL_BUFFER_USE_RUNSTACK();
VACATE_TAIL_BUFFER_USE_RUNSTACK();
UPDATE_THREAD_RSPTR_FOR_ERROR(); /* in case */
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;
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 {
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;
/* Uncommon general case --- allocate an array */
UPDATE_THREAD_RSPTR_FOR_GC();
a = MALLOC_N(Scheme_Object *, num_rands + 1);
}
num_rands++;
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(););
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)));
/* 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;
goto apply_top;
} else {
@ -3192,6 +3190,7 @@ scheme_do_eval(Scheme_Object *obj, int num_rands, Scheme_Object **rands,
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;
check_rands = num_rands;
goto apply_top;
} else {
/* Chaperone is for function arguments */
@ -3387,7 +3386,8 @@ scheme_do_eval(Scheme_Object *obj, int num_rands, Scheme_Object **rands,
}
} else
rands = &zero_rands_ptr;
check_rands = num_rands;
goto apply_top;
}
@ -3466,7 +3466,8 @@ scheme_do_eval(Scheme_Object *obj, int num_rands, Scheme_Object **rands,
rands[0] = arg;
num_rands = 1;
check_rands = num_rands;
goto apply_top;
}
@ -3560,7 +3561,8 @@ scheme_do_eval(Scheme_Object *obj, int num_rands, Scheme_Object **rands,
rands[1] = arg;
num_rands = 2;
check_rands = num_rands;
goto apply_top;
}
@ -3956,6 +3958,7 @@ scheme_do_eval(Scheme_Object *obj, int num_rands, Scheme_Object **rands,
p->ku.apply.tail_rands = NULL;
RUNSTACK = runstack_base;
RUNSTACK_CHANGED();
check_rands = num_rands;
goto apply_top;
}