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 ()

42
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,13 +1707,22 @@
f))
acc)]
[else
(values
(chaperone-struct
proc
(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`:
(chaperone-procedure
((if is-impersonator?
new:impersonate-procedure
new:chaperone-procedure)
proc
(make-keyword-procedure
(let ()
@ -1725,13 +1737,23 @@
(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))))))]))
(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)))))))
new-procedure-ref)])]
(gen-proc)))))))])
(values new-kw-proc
new-procedure-ref))])]
[(okp? n-proc)
(values
(if is-impersonator?

27
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,24 +3094,22 @@ 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;
}
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();
UPDATE_THREAD_RSPTR_FOR_ERROR(); /* in case */
@ -3144,16 +3145,13 @@ scheme_do_eval(Scheme_Object *obj, int num_rands, Scheme_Object **rands,
num_rands++;
}
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
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)
@ -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 */
@ -3388,6 +3387,7 @@ scheme_do_eval(Scheme_Object *obj, int num_rands, Scheme_Object **rands,
} else
rands = &zero_rands_ptr;
check_rands = num_rands;
goto apply_top;
}
@ -3467,6 +3467,7 @@ 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;
}
@ -3561,6 +3562,7 @@ scheme_do_eval(Scheme_Object *obj, int num_rands, Scheme_Object **rands,
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;
}