diff --git a/pkgs/racket-test-core/tests/racket/chaperone.rktl b/pkgs/racket-test-core/tests/racket/chaperone.rktl index d206bb87d8..e8af0a4317 100644 --- a/pkgs/racket-test-core/tests/racket/chaperone.rktl +++ b/pkgs/racket-test-core/tests/racket/chaperone.rktl @@ -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 () diff --git a/racket/collects/racket/private/kw.rkt b/racket/collects/racket/private/kw.rkt index 44d4dabaaa..17896a4852 100644 --- a/racket/collects/racket/private/kw.rkt +++ b/racket/collects/racket/private/kw.rkt @@ -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? diff --git a/racket/src/racket/src/eval.c b/racket/src/racket/src/eval.c index c32b36f1e3..1220964bab 100644 --- a/racket/src/racket/src/eval.c +++ b/racket/src/racket/src/eval.c @@ -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; }