suzanne.soy/racket
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

fix chaperone-procedure wth extra properies

Browse Source 
Continues the saga of 5bae9773a, this time fixing chaperone
properties.
This commit is contained in:
Matthew Flatt 2013-12-18 15:19:19 -07:00
parent 266e4ab119
commit c8085a2988
3 changed files with 182 additions and 148 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

11
pkgs/racket-pkgs/racket-test/tests/racket/chaperone.rktl
View File

@ -1461,6 +1461,7 @@
;; ---------------------------------------- ;; ----------------------------------------
(let () (let ()
(define (go chaperone-procedure impersonate-procedure)
(define f (lambda (x y #:z [z 1]) y)) (define f (lambda (x y #:z [z 1]) y))
(define same (define same
@ -1483,6 +1484,16 @@
(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)))
;; ---------------------------------------- ;; ----------------------------------------

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

@ -1564,7 +1564,7 @@
"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)
@ -1614,7 +1614,7 @@
;; 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))
@ -1625,12 +1625,17 @@
;; 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
(define acc (procedure-accessor-ref proc))
(values
(chaperone-struct (chaperone-struct
proc proc
(procedure-accessor-ref proc) acc
(lambda (self sub-proc) (lambda (self sub-proc)
(wrap sub-proc (normalize-proc sub-proc))))] (define-values (f acc) (wrap sub-proc (normalize-proc sub-proc)))
f))
acc)]
[else [else
(values
(chaperone-struct (chaperone-struct
proc proc
new-procedure-ref new-procedure-ref
@ -1648,8 +1653,10 @@
(lambda results (lambda results
(if (= (length results) (add1 len)) (if (= (length results) (add1 len))
(apply values (car results) self (cdr results)) (apply values (car results) self (cdr results))
(apply values (car results) (cadr results) self (cddr results))))))))))])] (apply values (car results) (cadr results) self (cddr results))))))))))
new-procedure-ref)])]
[(okp? n-proc) [(okp? n-proc)
(values
(if is-impersonator? (if is-impersonator?
((if (okm? n-proc) ((if (okm? n-proc)
make-optional-keyword-method-impersonator make-optional-keyword-method-impersonator
@ -1670,8 +1677,10 @@
(make-struct-field-accessor okp-ref 0) (make-struct-field-accessor okp-ref 0)
(lambda (self proc) (lambda (self proc)
(chaperone-procedure proc (chaperone-procedure proc
(okp-ref n-wrap-proc 0)))))] (okp-ref n-wrap-proc 0)))))
keyword-procedure-proc)]
[else [else
(values
(if is-impersonator? (if is-impersonator?
;; Constructor must be from `make-required': ;; Constructor must be from `make-required':
(let* ([name+fail (keyword-procedure-name+fail n-proc)] (let* ([name+fail (keyword-procedure-name+fail n-proc)]
@ -1686,12 +1695,13 @@
n-proc n-proc
keyword-procedure-proc keyword-procedure-proc
(lambda (self proc) (lambda (self proc)
(chaperone-procedure proc kw-chaperone))))]))]) (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)

21
racket/src/racket/src/struct.c
View File

@ -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,9 +2071,15 @@ 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))