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

fix chaperones and prop:procedure functions with keyword arguments

Browse Source 
Commit 5bae9773aa broke `chaperone-procedure` and `impersonate-procedure`
so that it didn't always produce a chaperone or impersonator. Also,
the arity-error changeds intended for that commit were not complete,
because tests were accidentally commented out.

The main repair involves a new internal property that keeps track of an
accessor that is used to extract a procedure from a field in a structure
type that has `prop:procedure`.
This commit is contained in:
Matthew Flatt 2013-12-17 17:43:44 -07:00
parent 97ee349046
commit 4070bcd461
6 changed files with 191 additions and 58 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

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

@ -1460,4 +1460,30 @@
;; ----------------------------------------
(let ()
(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)))))
(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))
;; ----------------------------------------
(report-errs)

13
pkgs/racket-pkgs/racket-test/tests/racket/procs.rktl
View File

@ -9,6 +9,12 @@
(define (f0+ . x) x)
(define (f0+/drop1 . x) (cdr x))
(define (f1 x) (list x))
(define f1-m
(let-syntax ([m (lambda (stx)
(syntax-property #'(lambda (x) (list x))
'method-arity-error
#t))])
m))
(define (f1+ x . rest) (cons x rest))
(define (f1+/drop1 x . rest) rest)
(define (f0:a #:a a) (list a))
@ -58,7 +64,7 @@
(struct wrap-m ()
#:property prop:procedure f)
(wrap-m))
(define procs
`((,f0 0 () ())
(,(wrap f0) 0 () ())
@ -67,6 +73,7 @@
(,(wrap-m f0+/drop1) ,(make-arity-at-least 0) () ())
(,(wrap-m f1+/drop1) ,(make-arity-at-least 0) () ())
(,f1 1 () ())
(,f1-m 1 () () #t)
(,(procedure->method f1) 1 () () #t)
(,(procedure->method (wrap f1)) 1 () () #t)
(,(procedure->method (wrap f0+)) ,(make-arity-at-least 0) () () #t)
@ -241,9 +248,7 @@
[(equal? allowed #f)
(err/rt-test ((car p) 1 #:a 1 #:b 1))])))))))
(map
values ; add-chaperone
procs
#;
add-chaperone
(append procs
;; reduce to arity 1 or nothing:
(map (lambda (p)

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

@ -159,10 +159,25 @@
(current-inspector) fail-proc)])
mk))
;; Allows support for new-prop:procedure to extract a field (i.e., this property
;; makes it possible to extract a field for an integer `new-prop:procedure` value):
(define-values (prop:procedure-accessor procedure-accessor? procedure-accessor-ref)
(make-struct-type-property 'procedure (lambda (v info-l)
(if (exact-integer? v)
(make-struct-field-accessor
(list-ref info-l 3)
v)
#f))))
;; Allows keyword application to see into a "method"-style procedure attribute:
(define-values (new-prop:procedure new-procedure? new-procedure-ref)
(make-struct-type-property 'procedure #f
(list (cons prop:procedure values))))
(list
;; Imply normal `prop:procedure`:
(cons prop:procedure values)
;; Also imply `prop:procedure-accessor`, in case property
;; value is an integer:
(cons prop:procedure-accessor values))))
;; Proxies
@ -264,15 +279,15 @@
(values (keyword-procedure-required p)
(keyword-procedure-allowed p))]
[(procedure? p)
(let ([p2 (procedure-extract-target p)])
(if p2
(procedure-keywords p2)
(if (new-procedure? p)
(let ([v (new-procedure-ref p)])
(if (procedure? v)
(procedure-keywords v)
(values null null)))
(values null null))))]
(if (new-procedure? p)
(let ([v (new-procedure-ref p)])
(if (procedure? v)
(procedure-keywords v)
(let ([a (procedure-accessor-ref p)])
(if a
(procedure-keywords (a p))
(values null null)))))
(values null null))]
[else (raise-argument-error 'procedure-keywords
"procedure?"
p)]))
@ -1239,7 +1254,11 @@
;; Not ok, so far:
(let ([p2 (and (not (keyword-procedure? p))
(procedure? p)
(or (procedure-extract-target p)
(or (and (new-procedure? p)
(let ([a (procedure-accessor-ref p)])
(and a
(a p))))
(procedure-extract-target p) ; integer supplied to `make-struct-type`
(and (new-procedure? p) 'method)))])
(if p2
;; Maybe the target is ok:
@ -1420,7 +1439,10 @@
(raise-arguments-error 'procedure-reduce-arity
"procedure has required keyword arguments"
"procedure" proc)
(procedure-reduce-arity proc arity)))])
(procedure-reduce-arity (if (okm? proc)
(procedure->method proc)
proc)
arity)))])
procedure-reduce-arity))
(define new:procedure->method
@ -1548,8 +1570,8 @@
[(kws args . rest)
(call-with-values (lambda () (apply p kws args rest))
(lambda results
(let ([len (length results)]
[alen (length rest)])
(let* ([len (length results)]
[alen (length rest)])
(unless (<= (+ alen 1) len (+ alen 2))
(raise-arguments-error
'|keyword procedure chaperone|
@ -1593,45 +1615,78 @@
;; bu this procedure's arity.
[other (error "shouldn't get here")]))]
[new-proc
(cond
[(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)
(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
n-proc
keyword-procedure-proc
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)
(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
;; 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)
(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))))])])
(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))))]))])
(if (null? props)
new-proc
(apply chaperone-struct new-proc

4
racket/collects/racket/trace.rkt
View File

@ -177,7 +177,9 @@
;; A traced-proc struct instance acts like a procedure,
;; but preserves the original, too.
(define-values (struct:traced-proc make-traced-proc traced-proc? traced-proc-ref traced-proc-set!)
(make-struct-type 'traced-proc #f 2 0 #f null (current-inspector) 0))
(make-struct-type 'traced-proc #f 2 0 #f
(list (cons prop:procedure 0))
(current-inspector) #f (list 0 1)))
;; Install traced versions of a given set of procedures. The traced
;; versions are also given, so that they can be constructed to have

41
racket/src/racket/src/fun.c
View File

@ -3067,9 +3067,43 @@ static int is_subarity(Scheme_Object *req, Scheme_Object *orig)
return 1;
}
static int proc_is_method(Scheme_Object *proc)
{
if (SCHEME_CHAPERONEP(proc))
proc = SCHEME_CHAPERONE_VAL(proc);
if (SCHEME_STRUCTP(proc)
&& scheme_is_struct_instance(scheme_reduced_procedure_struct, proc))
return SCHEME_TRUEP(((Scheme_Structure *)proc)->slots[3]);
if (SAME_TYPE(SCHEME_TYPE(proc), scheme_case_closure_type)) {
Scheme_Case_Lambda *cl = (Scheme_Case_Lambda *)proc;
if (cl->count)
proc = cl->array[0];
else
return 0;
}
if (SAME_TYPE(SCHEME_TYPE(proc), scheme_closure_type)) {
return ((SCHEME_CLOSURE_DATA_FLAGS(SCHEME_COMPILED_CLOS_CODE(proc)) & CLOS_IS_METHOD)
? 1
: 0);
}
#ifdef MZ_USE_JIT
if (SAME_TYPE(SCHEME_TYPE(proc), scheme_native_closure_type)) {
Scheme_Object *pa;
pa = scheme_get_native_arity(proc, -1);
return SCHEME_BOXP(pa);
}
#endif
return 0;
}
static Scheme_Object *procedure_reduce_arity(int argc, Scheme_Object *argv[])
{
Scheme_Object *orig, *aty;
Scheme_Object *orig, *aty, *is_meth = NULL;
if (!SCHEME_PROCP(argv[0]))
scheme_wrong_contract("procedure-reduce-arity", "procedure?", 0, argc, argv);
@ -3096,8 +3130,11 @@ static Scheme_Object *procedure_reduce_arity(int argc, Scheme_Object *argv[])
return NULL;
}
if (proc_is_method(argv[0]))
is_meth = scheme_true;
/* Construct a procedure that has the given arity. */
return make_reduced_proc(argv[0], aty, NULL, NULL);
return make_reduced_proc(argv[0], aty, NULL, is_meth);
}
static Scheme_Object *procedure_rename(int argc, Scheme_Object *argv[])

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

@ -4382,6 +4382,8 @@ static Scheme_Object *_make_struct_type(Scheme_Object *base,
/* Add new props: */
for (l = props; SCHEME_PAIRP(l); ) {
int skip_supers = 0;
a = SCHEME_CAR(l);
prop = SCHEME_CAR(a);
@ -4400,6 +4402,7 @@ static Scheme_Object *_make_struct_type(Scheme_Object *base,
if (!scheme_hash_get(can_override, prop)) {
if (!SAME_OBJ(oldv, propv))
break;
skip_supers = 1;
}
/* otherwise we override */
scheme_hash_set(can_override, prop, NULL);
@ -4407,7 +4410,8 @@ static Scheme_Object *_make_struct_type(Scheme_Object *base,
}
l = SCHEME_CDR(l);
l = append_super_props((Scheme_Struct_Property *)prop, propv, l);
if (!skip_supers)
l = append_super_props((Scheme_Struct_Property *)prop, propv, l);
if (SAME_OBJ(prop, proc_property))
proc_prop_set = propv;
@ -4434,6 +4438,8 @@ static Scheme_Object *_make_struct_type(Scheme_Object *base,
num_props = i;
for (l = props; SCHEME_PAIRP(l); ) {
int skip_supers = 0;
a = SCHEME_CAR(l);
prop = SCHEME_CAR(a);
@ -4457,7 +4463,8 @@ static Scheme_Object *_make_struct_type(Scheme_Object *base,
/* already there */
if (!scheme_hash_get(can_override, prop)) {
if (!SAME_OBJ(propv, SCHEME_CDR(pa[j])))
break;
break;
skip_supers = 1;
}
/* overriding it: */
scheme_hash_set(can_override, prop, NULL);
@ -4466,7 +4473,8 @@ static Scheme_Object *_make_struct_type(Scheme_Object *base,
}
l = SCHEME_CDR(l);
l = append_super_props((Scheme_Struct_Property *)prop, propv, l);
if (!skip_supers)
l = append_super_props((Scheme_Struct_Property *)prop, propv, l);
if (SAME_OBJ(prop, proc_property))
proc_prop_set = propv;