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

fix reducing arity or chaperoning keyword-valued prop:procedure

Browse Source 
Fix various problems, including a bad result from `procedure-arity`
and problems with chaperones and arity error messages when a
structure's `prop:procedure` value is a keyword-accepting procedure.

Merge to v6.0
(cherry picked from commit 0b48e883da)
This commit is contained in:
Matthew Flatt 2013-12-12 12:13:17 -07:00 committed by Ryan Culpepper
parent b9c81b6906
commit 5bae9773aa
4 changed files with 308 additions and 204 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

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

@ -6,14 +6,24 @@
;; ---------------------------------------- ;; ----------------------------------------
(define (f0) null) (define (f0) null)
(define (f0+ . x) x)
(define (f0+/drop1 . x) (cdr x))
(define (f1 x) (list x)) (define (f1 x) (list x))
(define (f1+ x . rest) (cons x rest)) (define (f1+ x . rest) (cons x rest))
(define (f1+/drop1 x . rest) rest)
(define (f0:a #:a a) (list a)) (define (f0:a #:a a) (list a))
(define (f0:a? #:a [a 0]) (list a)) (define (f0:a? #:a [a 0]) (list a))
(define (f1:a x #:a a) (list x a)) (define (f1:a x #:a a) (list x a))
(define (f1:a? x #:a [a 0]) (list x a)) (define (f1:a? x #:a [a 0]) (list x a))
(define (f1+:a x #:a a . args) (list* x a args)) (define (f1+:a x #:a a . args) (list* x a args))
(define (f1+:a? x #:a [a 0] . args) (list* x a args)) (define (f1+:a? x #:a [a 0] . args) (list* x a args))
(define (f1+:a/drop x #:a a . args) (if (null? args)
(list a)
(list* (car args) a (cdr args))))
(define (f1+:a?/drop x #:a [a 0] . args) (if (null? args)
(list a)
(list* (car args) a (cdr args))))
(define (f2+:a?/drop x y #:a [a 0] . args) (list* y a args))
(define (f0:a:b #:a a #:b b) (list a b)) (define (f0:a:b #:a a #:b b) (list a b))
(define (f0:a?:b #:a [a 0] #:b b) (list a b)) (define (f0:a?:b #:a [a 0] #:b b) (list a b))
(define (f1:a:b x #:a a #:b b) (list x a b)) (define (f1:a:b x #:a a #:b b) (list x a b))
@ -37,10 +47,29 @@
(lambda (kws kw-args x) (lambda (kws kw-args x)
(cons x kw-args)) (cons x kw-args))
(lambda (x) (list x)))) (lambda (x) (list x))))
(define f1:+/drop (make-keyword-procedure
(lambda (kws kw-args x)
kw-args)
(lambda (x) null)))
(struct wrap (v)
#:property prop:procedure 0)
(define (wrap-m f)
(struct wrap-m ()
#:property prop:procedure f)
(wrap-m))
(define procs (define procs
`((,f0 0 () ()) `((,f0 0 () ())
(,(wrap f0) 0 () ())
(,f0+ ,(make-arity-at-least 0) () ())
(,(wrap f0+) ,(make-arity-at-least 0) () ())
(,(wrap-m f0+/drop1) ,(make-arity-at-least 0) () ())
(,(wrap-m f1+/drop1) ,(make-arity-at-least 0) () ())
(,f1 1 () ()) (,f1 1 () ())
(,(procedure->method f1) 1 () () #t)
(,(procedure->method (wrap f1)) 1 () () #t)
(,(procedure->method (wrap f0+)) ,(make-arity-at-least 0) () () #t)
(,f1+ ,(make-arity-at-least 1) () ()) (,f1+ ,(make-arity-at-least 1) () ())
(,f0:a 0 (#:a) (#:a)) (,f0:a 0 (#:a) (#:a))
(,f0:a? 0 () (#:a)) (,f0:a? 0 () (#:a))
@ -48,6 +77,11 @@
(,f1:a? 1 () (#:a)) (,f1:a? 1 () (#:a))
(,f1+:a ,(make-arity-at-least 1) (#:a) (#:a)) (,f1+:a ,(make-arity-at-least 1) (#:a) (#:a))
(,f1+:a? ,(make-arity-at-least 1) () (#:a)) (,f1+:a? ,(make-arity-at-least 1) () (#:a))
(,(wrap f1+:a) ,(make-arity-at-least 1) (#:a) (#:a))
(,(wrap f1+:a?) ,(make-arity-at-least 1) () (#:a))
(,(wrap-m f1+:a/drop) ,(make-arity-at-least 0) (#:a) (#:a))
(,(wrap-m f1+:a?/drop) ,(make-arity-at-least 0) () (#:a))
(,(procedure->method (wrap f1+:a?)) ,(make-arity-at-least 1) () (#:a) #t)
(,f0:a:b 0 (#:a #:b) (#:a #:b)) (,f0:a:b 0 (#:a #:b) (#:a #:b))
(,f0:a?:b 0 (#:b) (#:a #:b)) (,f0:a?:b 0 (#:b) (#:a #:b))
(,f1:a:b 1 (#:a #:b) (#:a #:b)) (,f1:a:b 1 (#:a #:b) (#:a #:b))
@ -63,7 +97,19 @@
(,f_ () () ()) (,f_ () () ())
(,f_1_2 (1 2) () ()) (,f_1_2 (1 2) () ())
(,f_0_2+ ,(list 0 (make-arity-at-least 2)) () ()) (,f_0_2+ ,(list 0 (make-arity-at-least 2)) () ())
(,f1:+ 1 () #f))) (,f1:+ 1 () #f)
(,(wrap f1:+) 1 () #f)
(,(wrap-m f1:+/drop) 0 () #f)))
((chaperone-procedure
(wrap f1+:a)
(make-keyword-procedure
(lambda (kws kw-args . rest)
(if (null? kws)
(apply values rest)
(apply values kw-args rest)))))
1
#:a 2)
(define (check-arity-error p n err-n) (define (check-arity-error p n err-n)
(cond (cond
@ -80,13 +126,20 @@
(exn-message exn))))])) (exn-message exn))))]))
(let () (let ()
(define (get-maybe p n)
(and ((length p) . > . n) (list-ref p n)))
(define (try-combos procs add-chaperone) (define (try-combos procs add-chaperone)
(for-each (lambda (p) (for-each (lambda (p)
(let ([a (cadr p)]) (let ([a (cadr p)]
[method? (get-maybe p 4)]
[p (list* (car p) (cadr p) (caddr p) (cadddr p)
(if ((length p) . >= . 5)
(list-tail p 5)
null))])
(test a procedure-arity (car p)) (test a procedure-arity (car p))
(when (number? a) (when (number? a)
(let ([rx (regexp (format " mismatch;.*expected: (|at least )~a" (let ([rx (regexp (format " mismatch;.*(expected number(?!.*expected:)|expected: ~a)"
(if (zero? a) "(0|no)" a)))] (if (zero? a) "(0|no)" (if method? (sub1 a) a))))]
[bad-args (cons 'extra (for/list ([i (in-range a)]) 'a))]) [bad-args (cons 'extra (for/list ([i (in-range a)]) 'a))])
(test #t regexp-match? rx (test #t regexp-match? rx
(with-handlers ([exn:fail? (lambda (exn) (with-handlers ([exn:fail? (lambda (exn)
@ -98,6 +151,16 @@
(exn-message exn))]) (exn-message exn))])
(for-each (car p) (list bad-args)) (for-each (car p) (list bad-args))
"done!"))))) "done!")))))
(when (and (arity-at-least? a)
(positive? (arity-at-least-value a)))
(let ([a (arity-at-least-value a)])
(let ([rx (regexp (format " mismatch;.*(expected number(?!.*expected:)|expected: at least ~a)"
(if (zero? a) "(0|no)" (if method? (sub1 a) a))))]
[bad-args (for/list ([i (in-range (sub1 a))]) 'a)])
(test #t regexp-match? rx
(with-handlers ([exn:fail? (lambda (exn)
(exn-message exn))])
(apply (car p) bad-args))))))
(test-values (list (caddr p) (cadddr p)) (test-values (list (caddr p) (cadddr p))
(lambda () (lambda ()
(procedure-keywords (car p)))) (procedure-keywords (car p))))
@ -116,7 +179,7 @@
(test 'other object-name (procedure-rename (car p) 'other)) (test 'other object-name (procedure-rename (car p) 'other))
(test (procedure-arity (car p)) procedure-arity (procedure-rename (car p) 'other)) (test (procedure-arity (car p)) procedure-arity (procedure-rename (car p) 'other))
(test (procedure-arity (car p)) procedure-arity (procedure->method (car p))) (test (procedure-arity (car p)) procedure-arity (procedure->method (car p)))
(check-arity-error (car p) 10 10) (check-arity-error (car p) 10 (if method? 9 10))
(check-arity-error (procedure->method (car p)) 10 9) (check-arity-error (procedure->method (car p)) 10 9)
(unless (null? (list-tail p 4)) (unless (null? (list-tail p 4))
(test (object-name (list-ref p 4)) object-name (car p))) (test (object-name (list-ref p 4)) object-name (car p)))
@ -178,50 +241,59 @@
[(equal? allowed #f) [(equal? allowed #f)
(err/rt-test ((car p) 1 #:a 1 #:b 1))]))))))) (err/rt-test ((car p) 1 #:a 1 #:b 1))])))))))
(map (map
add-chaperone values ; add-chaperone
procs
#;
(append procs (append procs
;; reduce to arity 1 or nothing: ;; reduce to arity 1 or nothing:
(map (lambda (p) (map (lambda (p)
(let ([p (car p)]) (let ([p (car p)]
[method? (get-maybe p 4)])
(let-values ([(req allowed) (procedure-keywords p)]) (let-values ([(req allowed) (procedure-keywords p)])
(if (null? allowed) (if (null? allowed)
(if (procedure-arity-includes? p 1 #t) (if (procedure-arity-includes? p 1 #t)
(list (procedure-reduce-arity p 1) 1 req allowed p) (list (procedure-reduce-arity p 1) 1 req allowed method? p)
(list (procedure-reduce-arity p '()) '() req allowed p)) (list (procedure-reduce-arity p '()) '() req allowed method? p))
(if (procedure-arity-includes? p 1 #t) (if (procedure-arity-includes? p 1 #t)
(list (procedure-reduce-keyword-arity p 1 req allowed) 1 req allowed p) (list (procedure-reduce-keyword-arity p 1 req allowed) 1 req allowed method? p)
(list (procedure-reduce-keyword-arity p '() req allowed) '() req allowed p)))))) (list (procedure-reduce-keyword-arity p '() req allowed) '() req allowed method? p))))))
procs) procs)
;; reduce to arity 0 or nothing: ;; reduce to arity 0 or nothing:
(map (lambda (p) (map (lambda (p)
(let ([p (car p)]) (let ([p (car p)]
[method? (get-maybe p 4)])
(let-values ([(req allowed) (procedure-keywords p)]) (let-values ([(req allowed) (procedure-keywords p)])
(if (null? allowed) (if (null? allowed)
(if (procedure-arity-includes? p 0 #t) (if (procedure-arity-includes? p 0 #t)
(list (procedure-reduce-arity p 0) 0 req allowed p) (list (procedure-reduce-arity p 0) 0 req allowed method? p)
(list (procedure-reduce-arity p '()) '() req allowed p)) (list (procedure-reduce-arity p '()) '() req allowed method? p))
(if (procedure-arity-includes? p 0 #t) (if (procedure-arity-includes? p 0 #t)
(list (procedure-reduce-keyword-arity p 0 req allowed) 0 req allowed p) (list (procedure-reduce-keyword-arity p 0 req allowed) 0 req allowed method? p)
(list (procedure-reduce-keyword-arity p '() req allowed) '() req allowed p)))))) (list (procedure-reduce-keyword-arity p '() req allowed) '() req allowed method? p))))))
procs) procs)
;; reduce to arity 1 or nothing --- no keywords: ;; reduce to arity 1 or nothing --- no keywords:
(map (lambda (p) (map (lambda (p)
(let ([p (car p)]) (let ([p (car p)]
[method? (get-maybe p 4)])
(let-values ([(req allowed) (procedure-keywords p)]) (let-values ([(req allowed) (procedure-keywords p)])
(if (procedure-arity-includes? p 1) (if (procedure-arity-includes? p 1)
(list* (procedure-reduce-arity p 1) 1 '() '() p (list* (procedure-reduce-arity p 1) 1 '() '() method? p
(if (null? allowed) (if (null? allowed)
null null
(list allowed))) (list allowed)))
(list (procedure-reduce-arity p '()) '() '() '() p))))) (begin
(when (procedure-arity-includes? p 1 #t)
(err/rt-test (procedure-reduce-arity p 1) #rx"has required keyword arguments"))
(list (procedure-reduce-arity p '()) '() '() '() method? p))))))
procs) procs)
;; reduce to arity 0 or nothing --- no keywords: ;; reduce to arity 0 or nothing --- no keywords:
(map (lambda (p) (map (lambda (p)
(let ([p (car p)]) (let ([p (car p)]
[method? (get-maybe p 4)])
(let-values ([(req allowed) (procedure-keywords p)]) (let-values ([(req allowed) (procedure-keywords p)])
(if (procedure-arity-includes? p 0) (if (procedure-arity-includes? p 0)
(list (procedure-reduce-arity p 0) 0 '() '() p) (list (procedure-reduce-arity p 0) 0 '() '() method? p)
(list (procedure-reduce-arity p '()) '() '() '() p))))) (list (procedure-reduce-arity p '()) '() '() '() method? p)))))
procs) procs)
;; make #:a required, if possible: ;; make #:a required, if possible:
(map (lambda (p) (map (lambda (p)
@ -237,6 +309,7 @@
(cadr p) (cadr p)
new-req new-req
allowed allowed
(get-maybe p 4)
(car p))))) (car p)))))
(filter (lambda (p) (filter (lambda (p)
(let-values ([(req allowed) (procedure-keywords (car p))]) (let-values ([(req allowed) (procedure-keywords (car p))])
@ -257,6 +330,7 @@
(cadr p) (cadr p)
req req
new-allowed new-allowed
(get-maybe p 4)
(car p) (car p)
(if allowed (if allowed
(list allowed) (list allowed)

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

@ -1325,7 +1325,7 @@
;; setting procedure arity ;; setting procedure arity
(define (procedure-reduce-keyword-arity proc arity req-kw allowed-kw) (define (procedure-reduce-keyword-arity proc arity req-kw allowed-kw)
(let ([plain-proc (procedure-reduce-arity (if (okp? proc) (let* ([plain-proc (procedure-reduce-arity (if (okp? proc)
(okp-ref proc 0) (okp-ref proc 0)
proc) proc)
arity)]) arity)])
@ -1351,12 +1351,7 @@
"allowed-keyword list does not include all required keywords" "allowed-keyword list does not include all required keywords"
"allowed-keyword list" allowed-kw "allowed-keyword list" allowed-kw
"required keywords" req-kw))) "required keywords" req-kw)))
(let ([old-req (if (keyword-procedure? proc) (let-values ([(old-req old-allowed) (procedure-keywords proc)])
(keyword-procedure-required proc)
null)]
[old-allowed (if (keyword-procedure? proc)
(keyword-procedure-allowed proc)
null)])
(unless (subset? old-req req-kw) (unless (subset? old-req req-kw)
(raise-arguments-error 'procedure-reduce-keyword-arity (raise-arguments-error 'procedure-reduce-keyword-arity
"cannot reduce required keyword set" "cannot reduce required keyword set"
@ -1386,6 +1381,7 @@
(map loop a)])))] (map loop a)])))]
[new-arity (inc-arity arity 2)] [new-arity (inc-arity arity 2)]
[kw-checker (make-keyword-checker req-kw allowed-kw new-arity)] [kw-checker (make-keyword-checker req-kw allowed-kw new-arity)]
[proc (normalize-proc proc)]
[new-kw-proc (procedure-reduce-arity (keyword-procedure-proc proc) [new-kw-proc (procedure-reduce-arity (keyword-procedure-proc proc)
new-arity)]) new-arity)])
(if (null? req-kw) (if (null? req-kw)
@ -1418,8 +1414,8 @@
(let ([procedure-reduce-arity (let ([procedure-reduce-arity
(lambda (proc arity) (lambda (proc arity)
(if (and (procedure? proc) (if (and (procedure? proc)
(keyword-procedure? proc) (let-values ([(req allows) (procedure-keywords proc)])
(not (okp? proc)) (pair? req))
(not (null? arity))) (not (null? arity)))
(raise-arguments-error 'procedure-reduce-arity (raise-arguments-error 'procedure-reduce-arity
"procedure has required keyword arguments" "procedure has required keyword arguments"
@ -1430,6 +1426,7 @@
(define new:procedure->method (define new:procedure->method
(let ([procedure->method (let ([procedure->method
(lambda (proc) (lambda (proc)
(let ([proc (normalize-proc proc)])
(if (keyword-procedure? proc) (if (keyword-procedure? proc)
(cond (cond
[(okm? proc) proc] [(okm? proc) proc]
@ -1451,7 +1448,7 @@
(keyword-procedure-required proc) (keyword-procedure-required proc)
(keyword-procedure-allowed proc)))]) (keyword-procedure-allowed proc)))])
;; Not a keyword-accepting procedure: ;; Not a keyword-accepting procedure:
(procedure->method proc)))]) (procedure->method proc))))])
procedure->method)) procedure->method))
(define new:procedure-rename (define new:procedure-rename
@ -1495,7 +1492,9 @@
impersonate-procedure)) impersonate-procedure))
(define (do-chaperone-procedure is-impersonator? chaperone-procedure name proc wrap-proc props) (define (do-chaperone-procedure is-impersonator? chaperone-procedure name proc wrap-proc props)
(if (or (not (keyword-procedure? proc)) (let ([n-proc (normalize-proc proc)]
[n-wrap-proc (normalize-proc wrap-proc)])
(if (or (not (keyword-procedure? n-proc))
(not (procedure? wrap-proc)) (not (procedure? wrap-proc))
;; if any bad prop, let `chaperone-procedure' complain ;; if any bad prop, let `chaperone-procedure' complain
(let loop ([props props]) (let loop ([props props])
@ -1544,7 +1543,7 @@
"wrapper procedure" wrap-proc "wrapper procedure" wrap-proc
"original procedure" proc)) "original procedure" proc))
(let* ([kw-chaperone (let* ([kw-chaperone
(let ([p (keyword-procedure-proc 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))
@ -1595,41 +1594,41 @@
[other (error "shouldn't get here")]))] [other (error "shouldn't get here")]))]
[new-proc [new-proc
(cond (cond
[(okp? proc) [(okp? n-proc)
(if is-impersonator? (if is-impersonator?
((if (okm? proc) ((if (okm? n-proc)
make-optional-keyword-method-impersonator make-optional-keyword-method-impersonator
make-optional-keyword-procedure-impersonator) make-optional-keyword-procedure-impersonator)
(keyword-procedure-checker proc) (keyword-procedure-checker n-proc)
(chaperone-procedure (keyword-procedure-proc proc) (chaperone-procedure (keyword-procedure-proc n-proc)
kw-chaperone) kw-chaperone)
(keyword-procedure-required proc) (keyword-procedure-required n-proc)
(keyword-procedure-allowed proc) (keyword-procedure-allowed n-proc)
(chaperone-procedure (okp-ref proc 0) (chaperone-procedure (okp-ref n-proc 0)
(okp-ref wrap-proc 0)) (okp-ref n-wrap-proc 0))
proc) n-proc)
(chaperone-struct (chaperone-struct
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))
(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 wrap-proc 0)))))] (okp-ref n-wrap-proc 0)))))]
[else [else
(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 proc)] (let* ([name+fail (keyword-procedure-name+fail n-proc)]
[mk (make-required (car name+fail) (cdr name+fail) (keyword-method? proc) #t)]) [mk (make-required (car name+fail) (cdr name+fail) (keyword-method? n-proc) #t)])
(mk (mk
(keyword-procedure-checker proc) (keyword-procedure-checker n-proc)
(chaperone-procedure (keyword-procedure-proc proc) kw-chaperone) (chaperone-procedure (keyword-procedure-proc n-proc) kw-chaperone)
(keyword-procedure-required proc) (keyword-procedure-required n-proc)
(keyword-procedure-allowed proc) (keyword-procedure-allowed n-proc)
proc)) n-proc))
(chaperone-struct (chaperone-struct
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))))])])
@ -1639,3 +1638,26 @@
;; 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) keyword-procedure-allowed (lambda (s v) v)
props))))))) props)))))))
(define (normalize-proc proc)
;; If `proc' gets keyword support through `new-prop:procedure',
;; then wrap it to normalize to to something that matches
;; `keyword-procedure?'.
(cond
[(keyword-procedure? proc) proc]
[(new-procedure? proc)
(let-values ([(req-kws allowed-kws) (procedure-keywords proc)])
(if (null? allowed-kws)
proc
(make-optional-keyword-procedure
(lambda (given-kws given-argc)
(and (procedure-arity-includes? proc (- given-argc 2) #t)
(or (not allowed-kws)
(subset? given-kws allowed-kws))
(subset? req-kws given-kws)))
(lambda (kws kw-args . vals)
(keyword-apply proc kws kw-args vals))
req-kws
allowed-kws
proc)))]
[else proc])))

3
racket/src/racket/src/error.c
View File

@ -1194,6 +1194,9 @@ static char *make_arity_expect_string(const char *name, int namelen,
v = (Scheme_Object *)name; v = (Scheme_Object *)name;
if (SCHEME_CHAPERONEP(v)) if (SCHEME_CHAPERONEP(v))
v = SCHEME_CHAPERONE_VAL(v); v = SCHEME_CHAPERONE_VAL(v);
if (scheme_is_struct_instance(scheme_reduced_procedure_struct, v))
v = NULL; /* hide any wider type that a nested structure might report */
else
v = scheme_extract_struct_procedure(v, -1, NULL, &is_method); v = scheme_extract_struct_procedure(v, -1, NULL, &is_method);
if (!v || is_method || !SCHEME_CHAPERONE_PROC_STRUCTP(v)) if (!v || is_method || !SCHEME_CHAPERONE_PROC_STRUCTP(v))
break; break;

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

@ -2336,12 +2336,17 @@ static Scheme_Object *get_or_check_arity(Scheme_Object *p, intptr_t a, Scheme_Ob
} }
if ((a == -1) || (a == -3)) { if ((a == -1) || (a == -3)) {
if (mina < drop) if (mina < drop) {
if ((maxa >= 0) && (maxa < drop))
return scheme_null; return scheme_null;
else else
mina = 0;
} else
mina -= drop; mina -= drop;
if (maxa > 0) if (maxa > 0) {
/* assert: maxa >= drop, or else would have returned in `mina < drop` test */
maxa -= drop; maxa -= drop;
}
return make_arity(mina, maxa, a); return make_arity(mina, maxa, a);
} }