From c8085a298876e55ac61f9bd1393992c9ae6abd54 Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Wed, 18 Dec 2013 15:19:19 -0700 Subject: [PATCH] fix `chaperone-procedure` wth extra properies Continues the saga of 5bae9773a, this time fixing chaperone properties. --- .../racket-test/tests/racket/chaperone.rktl | 49 ++-- racket/collects/racket/private/kw.rkt | 258 +++++++++--------- racket/src/racket/src/struct.c | 23 +- 3 files changed, 182 insertions(+), 148 deletions(-) diff --git a/pkgs/racket-pkgs/racket-test/tests/racket/chaperone.rktl b/pkgs/racket-pkgs/racket-test/tests/racket/chaperone.rktl index 21e59ec752..e21dda7c74 100644 --- a/pkgs/racket-pkgs/racket-test/tests/racket/chaperone.rktl +++ b/pkgs/racket-pkgs/racket-test/tests/racket/chaperone.rktl @@ -1461,28 +1461,39 @@ ;; ---------------------------------------- (let () - (define f (lambda (x y #:z [z 1]) y)) + (define (go chaperone-procedure impersonate-procedure) + (define f (lambda (x y #:z [z 1]) y)) - (define same - (make-keyword-procedure - (lambda (kws kw-args . args) - (if (null? kws) - (apply values args) - (apply values kw-args args))))) + (define same + (make-keyword-procedure + (lambda (kws kw-args . args) + (if (null? kws) + (apply values args) + (apply values kw-args args))))) - (struct s2 (v) #:property prop:procedure 0) - (define f2 (s2 f)) - (test #t chaperone-of? (chaperone-procedure f2 same) f2) - (test #t impersonator-of? (impersonate-procedure f2 same) f2) - (test 2 (lambda () ((chaperone-procedure f2 same) 1 2 #:z 3))) - (test 2 (chaperone-procedure f2 same) 1 2) + (struct s2 (v) #:property prop:procedure 0) + (define f2 (s2 f)) + (test #t chaperone-of? (chaperone-procedure f2 same) f2) + (test #t impersonator-of? (impersonate-procedure f2 same) f2) + (test 2 (lambda () ((chaperone-procedure f2 same) 1 2 #:z 3))) + (test 2 (chaperone-procedure f2 same) 1 2) - (struct s3 () #:property prop:procedure f) - (define f3 (s3)) - (test #t chaperone-of? (chaperone-procedure f3 same) f3) - (test #t impersonator-of? (impersonate-procedure f3 same) f3) - (test 2 (lambda () ((chaperone-procedure f3 same) 2 #:z 3))) - (test 2 (chaperone-procedure f3 same) 2)) + (struct s3 () #:property prop:procedure f) + (define f3 (s3)) + (test #t chaperone-of? (chaperone-procedure f3 same) f3) + (test #t impersonator-of? (impersonate-procedure f3 same) f3) + (test 2 (lambda () ((chaperone-procedure f3 same) 2 #:z 3))) + (test 2 (chaperone-procedure f3 same) 2)) + (define (add-prop mk) + (lambda (f wrap) + (define-values (prop: ? -ref) (make-impersonator-property 'x)) + (define v (mk f wrap prop: 'ex)) + (test #t ? v) + (test 'ex -ref v) + v)) + (go chaperone-procedure impersonate-procedure) + (go (add-prop chaperone-procedure) + (add-prop impersonate-procedure))) ;; ---------------------------------------- diff --git a/racket/collects/racket/private/kw.rkt b/racket/collects/racket/private/kw.rkt index 8072eaa5b2..afbc5b858f 100644 --- a/racket/collects/racket/private/kw.rkt +++ b/racket/collects/racket/private/kw.rkt @@ -1564,134 +1564,144 @@ "wrapper procedure does not accept all keywords of original procedure" "wrapper procedure" wrap-proc "original procedure" proc)) - (let* ([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")]))] - [new-proc - (let wrap ([proc proc] [n-proc n-proc]) - (cond - [(and (not (eq? n-proc proc)) - (new-procedure? proc)) - (define v (new-procedure-ref proc)) - (cond - [(exact-integer? v) - ;; we have to chaperone the access to the field that - ;; contains a procedure; the `new-procedure-accessor` - ;; property gives us that accessor - (chaperone-struct - proc - (procedure-accessor-ref proc) - (lambda (self sub-proc) - (wrap sub-proc (normalize-proc sub-proc))))] - [else - (chaperone-struct - proc - new-procedure-ref - (lambda (self proc) - ;; This `proc` takes an extra argument, which is `self`: - (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))))))))))])] - [(okp? n-proc) - (if is-impersonator? - ((if (okm? n-proc) - make-optional-keyword-method-impersonator - make-optional-keyword-procedure-impersonator) - (keyword-procedure-checker n-proc) - (chaperone-procedure (keyword-procedure-proc n-proc) - kw-chaperone) - (keyword-procedure-required n-proc) - (keyword-procedure-allowed n-proc) - (chaperone-procedure (okp-ref n-proc 0) - (okp-ref n-wrap-proc 0)) - n-proc) - (chaperone-struct - proc - keyword-procedure-proc - (lambda (self proc) - (chaperone-procedure proc kw-chaperone)) - (make-struct-field-accessor okp-ref 0) - (lambda (self proc) - (chaperone-procedure proc - (okp-ref n-wrap-proc 0)))))] - [else - (if is-impersonator? - ;; Constructor must be from `make-required': - (let* ([name+fail (keyword-procedure-name+fail n-proc)] - [mk (make-required (car name+fail) (cdr name+fail) (keyword-method? n-proc) #t)]) - (mk - (keyword-procedure-checker n-proc) - (chaperone-procedure (keyword-procedure-proc n-proc) kw-chaperone) - (keyword-procedure-required n-proc) - (keyword-procedure-allowed n-proc) - n-proc)) - (chaperone-struct - n-proc - keyword-procedure-proc - (lambda (self proc) - (chaperone-procedure proc kw-chaperone))))]))]) + (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")]))] + [(new-proc chap-accessor) + (let wrap ([proc proc] [n-proc n-proc]) + (cond + [(and (not (eq? n-proc proc)) + (new-procedure? proc)) + (define v (new-procedure-ref proc)) + (cond + [(exact-integer? v) + ;; we have to chaperone the access to the field that + ;; contains a procedure; the `new-procedure-accessor` + ;; property gives us that accessor + (define acc (procedure-accessor-ref proc)) + (values + (chaperone-struct + proc + acc + (lambda (self sub-proc) + (define-values (f acc) (wrap sub-proc (normalize-proc sub-proc))) + 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 + (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)))))))))) + new-procedure-ref)])] + [(okp? n-proc) + (values + (if is-impersonator? + ((if (okm? n-proc) + make-optional-keyword-method-impersonator + make-optional-keyword-procedure-impersonator) + (keyword-procedure-checker n-proc) + (chaperone-procedure (keyword-procedure-proc n-proc) + kw-chaperone) + (keyword-procedure-required n-proc) + (keyword-procedure-allowed n-proc) + (chaperone-procedure (okp-ref n-proc 0) + (okp-ref n-wrap-proc 0)) + n-proc) + (chaperone-struct + proc + keyword-procedure-proc + (lambda (self proc) + (chaperone-procedure proc kw-chaperone)) + (make-struct-field-accessor okp-ref 0) + (lambda (self proc) + (chaperone-procedure proc + (okp-ref n-wrap-proc 0))))) + keyword-procedure-proc)] + [else + (values + (if is-impersonator? + ;; Constructor must be from `make-required': + (let* ([name+fail (keyword-procedure-name+fail n-proc)] + [mk (make-required (car name+fail) (cdr name+fail) (keyword-method? n-proc) #t)]) + (mk + (keyword-procedure-checker n-proc) + (chaperone-procedure (keyword-procedure-proc n-proc) kw-chaperone) + (keyword-procedure-required n-proc) + (keyword-procedure-allowed n-proc) + n-proc)) + (chaperone-struct + n-proc + keyword-procedure-proc + (lambda (self proc) + (chaperone-procedure proc kw-chaperone)))) + keyword-procedure-proc)]))]) (if (null? props) new-proc (apply chaperone-struct new-proc ;; chaperone-struct insists on having at least one selector: - keyword-procedure-allowed (lambda (s v) v) + chap-accessor (lambda (s v) v) props))))))) (define (normalize-proc proc) diff --git a/racket/src/racket/src/struct.c b/racket/src/racket/src/struct.c index 6b3f8252e6..9ddd65169b 100644 --- a/racket/src/racket/src/struct.c +++ b/racket/src/racket/src/struct.c @@ -2019,9 +2019,16 @@ static Scheme_Object *chaperone_struct_ref(const char *who, Scheme_Object *o, in a[0] = px->prev; a[1] = orig; red = SCHEME_VEC_ELS(px->redirects)[PRE_REDIRECTS + i]; - if (SAME_TYPE(SCHEME_TYPE(red), scheme_native_closure_type)) + if (SAME_TYPE(SCHEME_TYPE(red), scheme_native_closure_type)) { o = _scheme_apply_native(red, 2, a); - else + if (o == SCHEME_MULTIPLE_VALUES) { + GC_CAN_IGNORE Scheme_Thread *p = scheme_current_thread; + scheme_wrong_return_arity(NULL, 1, p->ku.multiple.count, + p->ku.multiple.array, + NULL); + return NULL; + } + } else o = _scheme_apply(red, 2, a); if (!(SCHEME_CHAPERONE_FLAGS(px) & SCHEME_CHAPERONE_IS_IMPERSONATOR)) @@ -2064,11 +2071,17 @@ static void chaperone_struct_set(const char *who, Scheme_Object *o, int i, Schem if (SCHEME_TRUEP(red)) { a[0] = o; a[1] = v; - if (SAME_TYPE(SCHEME_TYPE(red), scheme_native_closure_type)) + if (SAME_TYPE(SCHEME_TYPE(red), scheme_native_closure_type)) { v = _scheme_apply_native(red, 2, a); - else + if (v == SCHEME_MULTIPLE_VALUES) { + GC_CAN_IGNORE Scheme_Thread *p = scheme_current_thread; + scheme_wrong_return_arity(NULL, 1, p->ku.multiple.count, + p->ku.multiple.array, + NULL); + } + } else v = _scheme_apply(red, 2, a); - + if (!(SCHEME_CHAPERONE_FLAGS(px) & SCHEME_CHAPERONE_IS_IMPERSONATOR)) if (!SAME_OBJ(v, a[1]) && !scheme_chaperone_of(v, a[1])) scheme_wrong_chaperoned(who, "value", a[1], v);