fix chaperone-procedure wth extra properies
Continues the saga of 5bae9773a, this time fixing chaperone
properties.
This commit is contained in:
Matthew Flatt
parent
266e4ab119
commit
c8085a2988
|
|
@ -1461,28 +1461,39 @@
|
||||||
;; ----------------------------------------
|
;; ----------------------------------------
|
||||||
|
|
||||||
(let ()
|
(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
|
(define same
|
||||||
(make-keyword-procedure
|
(make-keyword-procedure
|
||||||
(lambda (kws kw-args . args)
|
(lambda (kws kw-args . args)
|
||||||
(if (null? kws)
|
(if (null? kws)
|
||||||
(apply values args)
|
(apply values args)
|
||||||
(apply values kw-args args)))))
|
(apply values kw-args args)))))
|
||||||
|
|
||||||
(struct s2 (v) #:property prop:procedure 0)
|
(struct s2 (v) #:property prop:procedure 0)
|
||||||
(define f2 (s2 f))
|
(define f2 (s2 f))
|
||||||
(test #t chaperone-of? (chaperone-procedure f2 same) f2)
|
(test #t chaperone-of? (chaperone-procedure f2 same) f2)
|
||||||
(test #t impersonator-of? (impersonate-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 (lambda () ((chaperone-procedure f2 same) 1 2 #:z 3)))
|
||||||
(test 2 (chaperone-procedure f2 same) 1 2)
|
(test 2 (chaperone-procedure f2 same) 1 2)
|
||||||
|
|
||||||
(struct s3 () #:property prop:procedure f)
|
(struct s3 () #:property prop:procedure f)
|
||||||
(define f3 (s3))
|
(define f3 (s3))
|
||||||
(test #t chaperone-of? (chaperone-procedure f3 same) f3)
|
(test #t chaperone-of? (chaperone-procedure f3 same) f3)
|
||||||
(test #t impersonator-of? (impersonate-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 (lambda () ((chaperone-procedure f3 same) 2 #:z 3)))
|
||||||
(test 2 (chaperone-procedure f3 same) 2))
|
(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)))
|
||||||
|
|
||||||
;; ----------------------------------------
|
;; ----------------------------------------
|
||||||
|
|
||||||
|
|
|
||||||
|
|
@ -1564,134 +1564,144 @@
|
||||||
"wrapper procedure does not accept all keywords of original procedure"
|
"wrapper procedure does not accept all keywords of original procedure"
|
||||||
"wrapper procedure" wrap-proc
|
"wrapper procedure" wrap-proc
|
||||||
"original procedure" proc))
|
"original procedure" proc))
|
||||||
(let* ([kw-chaperone
|
(let*-values ([(kw-chaperone)
|
||||||
(let ([p (keyword-procedure-proc n-wrap-proc)])
|
(let ([p (keyword-procedure-proc n-wrap-proc)])
|
||||||
(case-lambda
|
(case-lambda
|
||||||
[(kws args . rest)
|
[(kws args . rest)
|
||||||
(call-with-values (lambda () (apply p kws args rest))
|
(call-with-values (lambda () (apply p kws args rest))
|
||||||
(lambda results
|
(lambda results
|
||||||
(let* ([len (length results)]
|
(let* ([len (length results)]
|
||||||
[alen (length rest)])
|
[alen (length rest)])
|
||||||
(unless (<= (+ alen 1) len (+ alen 2))
|
(unless (<= (+ alen 1) len (+ alen 2))
|
||||||
(raise-arguments-error
|
(raise-arguments-error
|
||||||
'|keyword procedure chaperone|
|
'|keyword procedure chaperone|
|
||||||
"wrong number of results from wrapper procedure"
|
"wrong number of results from wrapper procedure"
|
||||||
"expected minimum number of results" (+ alen 1)
|
"expected minimum number of results" (+ alen 1)
|
||||||
"expected maximum number of results" (+ alen 2)
|
"expected maximum number of results" (+ alen 2)
|
||||||
"received number of results" len
|
"received number of results" len
|
||||||
"wrapper procedure" wrap-proc))
|
"wrapper procedure" wrap-proc))
|
||||||
(let ([extra? (= len (+ alen 2))])
|
(let ([extra? (= len (+ alen 2))])
|
||||||
(let ([new-args ((if extra? cadr car) results)])
|
(let ([new-args ((if extra? cadr car) results)])
|
||||||
(unless (and (list? new-args)
|
(unless (and (list? new-args)
|
||||||
(= (length new-args) (length args)))
|
(= (length new-args) (length args)))
|
||||||
(raise-arguments-error
|
(raise-arguments-error
|
||||||
'|keyword procedure chaperone|
|
'|keyword procedure chaperone|
|
||||||
(format
|
(format
|
||||||
"expected a list of keyword-argument values as first result~a from wrapper procedure"
|
"expected a list of keyword-argument values as first result~a from wrapper procedure"
|
||||||
(if (= len alen)
|
(if (= len alen)
|
||||||
""
|
""
|
||||||
" (after the result-wrapper procedure)"))
|
" (after the result-wrapper procedure)"))
|
||||||
"first result" new-args
|
"first result" new-args
|
||||||
"wrapper procedure" wrap-proc))
|
"wrapper procedure" wrap-proc))
|
||||||
(for-each
|
(for-each
|
||||||
(lambda (kw new-arg arg)
|
(lambda (kw new-arg arg)
|
||||||
(unless is-impersonator?
|
(unless is-impersonator?
|
||||||
(unless (chaperone-of? new-arg arg)
|
(unless (chaperone-of? new-arg arg)
|
||||||
(raise-arguments-error
|
(raise-arguments-error
|
||||||
'|keyword procedure chaperone|
|
'|keyword procedure chaperone|
|
||||||
(format
|
(format
|
||||||
"~a keyword result is not a chaperone of original argument from chaperoning procedure"
|
"~a keyword result is not a chaperone of original argument from chaperoning procedure"
|
||||||
kw)
|
kw)
|
||||||
"result" new-arg
|
"result" new-arg
|
||||||
"wrapper procedure" wrap-proc))))
|
"wrapper procedure" wrap-proc))))
|
||||||
kws
|
kws
|
||||||
new-args
|
new-args
|
||||||
args))
|
args))
|
||||||
(if extra?
|
(if extra?
|
||||||
(apply values (car results) kws (cdr results))
|
(apply values (car results) kws (cdr results))
|
||||||
(apply values kws results))))))]
|
(apply values kws results))))))]
|
||||||
;; The following case exists only to make sure that the arity of
|
;; The following case exists only to make sure that the arity of
|
||||||
;; any procedure passed to `make-keyword-args' is covered
|
;; any procedure passed to `make-keyword-args' is covered
|
||||||
;; bu this procedure's arity.
|
;; bu this procedure's arity.
|
||||||
[other (error "shouldn't get here")]))]
|
[other (error "shouldn't get here")]))]
|
||||||
[new-proc
|
[(new-proc chap-accessor)
|
||||||
(let wrap ([proc proc] [n-proc n-proc])
|
(let wrap ([proc proc] [n-proc n-proc])
|
||||||
(cond
|
(cond
|
||||||
[(and (not (eq? n-proc proc))
|
[(and (not (eq? n-proc proc))
|
||||||
(new-procedure? proc))
|
(new-procedure? proc))
|
||||||
(define v (new-procedure-ref proc))
|
(define v (new-procedure-ref proc))
|
||||||
(cond
|
(cond
|
||||||
[(exact-integer? v)
|
[(exact-integer? v)
|
||||||
;; we have to chaperone the access to the field that
|
;; we have to chaperone the access to the field that
|
||||||
;; contains a procedure; the `new-procedure-accessor`
|
;; contains a procedure; the `new-procedure-accessor`
|
||||||
;; property gives us that accessor
|
;; property gives us that accessor
|
||||||
(chaperone-struct
|
(define acc (procedure-accessor-ref proc))
|
||||||
proc
|
(values
|
||||||
(procedure-accessor-ref proc)
|
(chaperone-struct
|
||||||
(lambda (self sub-proc)
|
proc
|
||||||
(wrap sub-proc (normalize-proc sub-proc))))]
|
acc
|
||||||
[else
|
(lambda (self sub-proc)
|
||||||
(chaperone-struct
|
(define-values (f acc) (wrap sub-proc (normalize-proc sub-proc)))
|
||||||
proc
|
f))
|
||||||
new-procedure-ref
|
acc)]
|
||||||
(lambda (self proc)
|
[else
|
||||||
;; This `proc` takes an extra argument, which is `self`:
|
(values
|
||||||
(chaperone-procedure
|
(chaperone-struct
|
||||||
proc
|
proc
|
||||||
(make-keyword-procedure
|
new-procedure-ref
|
||||||
(lambda (kws kw-args self . args)
|
(lambda (self proc)
|
||||||
;; Chain to `kw-chaperone', pulling out the self
|
;; This `proc` takes an extra argument, which is `self`:
|
||||||
;; argument, and then putting it back:
|
(chaperone-procedure
|
||||||
(define len (length args))
|
proc
|
||||||
(call-with-values
|
(make-keyword-procedure
|
||||||
(lambda () (apply kw-chaperone kws kw-args args))
|
(lambda (kws kw-args self . args)
|
||||||
(lambda results
|
;; Chain to `kw-chaperone', pulling out the self
|
||||||
(if (= (length results) (add1 len))
|
;; argument, and then putting it back:
|
||||||
(apply values (car results) self (cdr results))
|
(define len (length args))
|
||||||
(apply values (car results) (cadr results) self (cddr results))))))))))])]
|
(call-with-values
|
||||||
[(okp? n-proc)
|
(lambda () (apply kw-chaperone kws kw-args args))
|
||||||
(if is-impersonator?
|
(lambda results
|
||||||
((if (okm? n-proc)
|
(if (= (length results) (add1 len))
|
||||||
make-optional-keyword-method-impersonator
|
(apply values (car results) self (cdr results))
|
||||||
make-optional-keyword-procedure-impersonator)
|
(apply values (car results) (cadr results) self (cddr results))))))))))
|
||||||
(keyword-procedure-checker n-proc)
|
new-procedure-ref)])]
|
||||||
(chaperone-procedure (keyword-procedure-proc n-proc)
|
[(okp? n-proc)
|
||||||
kw-chaperone)
|
(values
|
||||||
(keyword-procedure-required n-proc)
|
(if is-impersonator?
|
||||||
(keyword-procedure-allowed n-proc)
|
((if (okm? n-proc)
|
||||||
(chaperone-procedure (okp-ref n-proc 0)
|
make-optional-keyword-method-impersonator
|
||||||
(okp-ref n-wrap-proc 0))
|
make-optional-keyword-procedure-impersonator)
|
||||||
n-proc)
|
(keyword-procedure-checker n-proc)
|
||||||
(chaperone-struct
|
(chaperone-procedure (keyword-procedure-proc n-proc)
|
||||||
proc
|
kw-chaperone)
|
||||||
keyword-procedure-proc
|
(keyword-procedure-required n-proc)
|
||||||
(lambda (self proc)
|
(keyword-procedure-allowed n-proc)
|
||||||
(chaperone-procedure proc kw-chaperone))
|
(chaperone-procedure (okp-ref n-proc 0)
|
||||||
(make-struct-field-accessor okp-ref 0)
|
(okp-ref n-wrap-proc 0))
|
||||||
(lambda (self proc)
|
n-proc)
|
||||||
(chaperone-procedure proc
|
(chaperone-struct
|
||||||
(okp-ref n-wrap-proc 0)))))]
|
proc
|
||||||
[else
|
keyword-procedure-proc
|
||||||
(if is-impersonator?
|
(lambda (self proc)
|
||||||
;; Constructor must be from `make-required':
|
(chaperone-procedure proc kw-chaperone))
|
||||||
(let* ([name+fail (keyword-procedure-name+fail n-proc)]
|
(make-struct-field-accessor okp-ref 0)
|
||||||
[mk (make-required (car name+fail) (cdr name+fail) (keyword-method? n-proc) #t)])
|
(lambda (self proc)
|
||||||
(mk
|
(chaperone-procedure proc
|
||||||
(keyword-procedure-checker n-proc)
|
(okp-ref n-wrap-proc 0)))))
|
||||||
(chaperone-procedure (keyword-procedure-proc n-proc) kw-chaperone)
|
keyword-procedure-proc)]
|
||||||
(keyword-procedure-required n-proc)
|
[else
|
||||||
(keyword-procedure-allowed n-proc)
|
(values
|
||||||
n-proc))
|
(if is-impersonator?
|
||||||
(chaperone-struct
|
;; Constructor must be from `make-required':
|
||||||
n-proc
|
(let* ([name+fail (keyword-procedure-name+fail n-proc)]
|
||||||
keyword-procedure-proc
|
[mk (make-required (car name+fail) (cdr name+fail) (keyword-method? n-proc) #t)])
|
||||||
(lambda (self proc)
|
(mk
|
||||||
(chaperone-procedure proc kw-chaperone))))]))])
|
(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)
|
(if (null? props)
|
||||||
new-proc
|
new-proc
|
||||||
(apply chaperone-struct new-proc
|
(apply chaperone-struct new-proc
|
||||||
;; chaperone-struct insists on having at least one selector:
|
;; chaperone-struct insists on having at least one selector:
|
||||||
keyword-procedure-allowed (lambda (s v) v)
|
chap-accessor (lambda (s v) v)
|
||||||
props)))))))
|
props)))))))
|
||||||
|
|
||||||
(define (normalize-proc proc)
|
(define (normalize-proc proc)
|
||||||
|
|
|
||||||
|
|
@ -2019,9 +2019,16 @@ static Scheme_Object *chaperone_struct_ref(const char *who, Scheme_Object *o, in
|
||||||
a[0] = px->prev;
|
a[0] = px->prev;
|
||||||
a[1] = orig;
|
a[1] = orig;
|
||||||
red = SCHEME_VEC_ELS(px->redirects)[PRE_REDIRECTS + i];
|
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);
|
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);
|
o = _scheme_apply(red, 2, a);
|
||||||
|
|
||||||
if (!(SCHEME_CHAPERONE_FLAGS(px) & SCHEME_CHAPERONE_IS_IMPERSONATOR))
|
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)) {
|
if (SCHEME_TRUEP(red)) {
|
||||||
a[0] = o;
|
a[0] = o;
|
||||||
a[1] = v;
|
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);
|
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);
|
v = _scheme_apply(red, 2, a);
|
||||||
|
|
||||||
if (!(SCHEME_CHAPERONE_FLAGS(px) & SCHEME_CHAPERONE_IS_IMPERSONATOR))
|
if (!(SCHEME_CHAPERONE_FLAGS(px) & SCHEME_CHAPERONE_IS_IMPERSONATOR))
|
||||||
if (!SAME_OBJ(v, a[1]) && !scheme_chaperone_of(v, a[1]))
|
if (!SAME_OBJ(v, a[1]) && !scheme_chaperone_of(v, a[1]))
|
||||||
scheme_wrong_chaperoned(who, "value", a[1], v);
|
scheme_wrong_chaperoned(who, "value", a[1], v);
|
||||||
|
|
|
||||||
Loading…
Reference in New Issue
Block a user