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) (go (add-prop chaperone-procedure)
(add-prop impersonate-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 () (let ()

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

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

93
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_Type type;
Scheme_Object *v; 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 *tmpv; /* safe-for-space relies on GC_CAN_IGNORE */
GC_CAN_IGNORE Scheme_Object **tmprands; /* 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; 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); return scheme_enlarge_runstack(SCHEME_TAIL_COPY_THRESHOLD, (void *(*)(void))do_eval_k);
} }
check_rands = num_rands;
apply_top: apply_top:
/* DANGER: if rands == p->tail_buffer, we have to be careful to /* 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. */ original object for an applicable structure. */
|| (type == scheme_raw_pair_type)) { || (type == scheme_raw_pair_type)) {
int is_method; int is_method;
int check_rands = num_rands;
Scheme_Object *orig_obj; Scheme_Object *orig_obj;
if (SCHEME_RPAIRP(obj)) { orig_obj = obj;
orig_obj = SCHEME_CDR(obj);
obj = SCHEME_CAR(obj);
} else {
orig_obj = obj;
}
while (1) { while (1) {
/* Like the apply loop around this one, but we need /* Like the apply loop around this one, but we need
to keep track of orig_obj until we get down to the to keep track of orig_obj until we get down to the
structure. */ structure. */
if (SCHEME_RPAIRP(obj)) {
orig_obj = SCHEME_CDR(obj);
obj = SCHEME_CAR(obj);
}
type = SCHEME_TYPE(obj); type = SCHEME_TYPE(obj);
if (type == scheme_proc_struct_type) { 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; v = obj;
obj = scheme_extract_struct_procedure(orig_obj, check_rands, rands, &is_method); obj = scheme_extract_struct_procedure(orig_obj, check_rands, rands, &is_method);
if (is_method) { if (is_method) {
/* Have to add an extra argument to the front of rands */ /* Have to add an extra argument to the front of rands */
if ((rands == RUNSTACK) && (RUNSTACK != RUNSTACK_START)){ if ((rands == RUNSTACK) && (RUNSTACK != RUNSTACK_START)){
/* Common case: we can just push self onto the front: */ /* Common case: we can just push self onto the front: */
rands = PUSH_RUNSTACK(p, RUNSTACK, 1); rands = PUSH_RUNSTACK(p, RUNSTACK, 1);
rands[0] = v; 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 { } else {
int i; /* Uncommon general case --- allocate an array */
Scheme_Object **a; UPDATE_THREAD_RSPTR_FOR_GC();
a = MALLOC_N(Scheme_Object *, num_rands + 1);
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++;
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 DO_CHECK_FOR_BREAK(p, UPDATE_THREAD_RSPTR_FOR_GC(); if (rands == p->tail_buffer) make_tail_buffer_safe(););
(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();); /* After we check arity once, no need to check again
(which would lead to O(n^2) checking for nested
break; struct procs): */
} while (SAME_TYPE(scheme_proc_struct_type, SCHEME_TYPE(obj))); check_rands = -1;
goto apply_top; goto apply_top;
} else { } 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)) { if (SAME_TYPE(SCHEME_TYPE(((Scheme_Chaperone *)obj)->redirects), scheme_nack_guard_evt_type)) {
/* Chaperone is for evt, not function arguments */ /* Chaperone is for evt, not function arguments */
obj = ((Scheme_Chaperone *)obj)->prev; obj = ((Scheme_Chaperone *)obj)->prev;
check_rands = num_rands;
goto apply_top; goto apply_top;
} else { } else {
/* Chaperone is for function arguments */ /* Chaperone is for function arguments */
@ -3388,6 +3387,7 @@ scheme_do_eval(Scheme_Object *obj, int num_rands, Scheme_Object **rands,
} else } else
rands = &zero_rands_ptr; rands = &zero_rands_ptr;
check_rands = num_rands;
goto apply_top; goto apply_top;
} }
@ -3467,6 +3467,7 @@ scheme_do_eval(Scheme_Object *obj, int num_rands, Scheme_Object **rands,
rands[0] = arg; rands[0] = arg;
num_rands = 1; num_rands = 1;
check_rands = num_rands;
goto apply_top; goto apply_top;
} }
@ -3561,6 +3562,7 @@ scheme_do_eval(Scheme_Object *obj, int num_rands, Scheme_Object **rands,
num_rands = 2; num_rands = 2;
check_rands = num_rands;
goto apply_top; 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; p->ku.apply.tail_rands = NULL;
RUNSTACK = runstack_base; RUNSTACK = runstack_base;
RUNSTACK_CHANGED(); RUNSTACK_CHANGED();
check_rands = num_rands;
goto apply_top; goto apply_top;
} }