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)

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

@ -1325,10 +1325,10 @@
;; 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)])
(define (sorted? kws) (define (sorted? kws)
(let loop ([kws kws]) (let loop ([kws kws])
(cond (cond
@ -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,28 +1426,29 @@
(define new:procedure->method (define new:procedure->method
(let ([procedure->method (let ([procedure->method
(lambda (proc) (lambda (proc)
(if (keyword-procedure? proc) (let ([proc (normalize-proc proc)])
(cond (if (keyword-procedure? proc)
[(okm? proc) proc] (cond
[(keyword-method? proc) proc] [(okm? proc) proc]
[(okp? proc) (make-optional-keyword-method [(keyword-method? proc) proc]
(keyword-procedure-checker proc) [(okp? proc) (make-optional-keyword-method
(keyword-procedure-proc proc) (keyword-procedure-checker proc)
(keyword-procedure-required proc) (keyword-procedure-proc proc)
(keyword-procedure-allowed proc) (keyword-procedure-required proc)
(okp-ref proc 0))] (keyword-procedure-allowed proc)
[else (okp-ref proc 0))]
;; Constructor must be from `make-required', but not a method. [else
;; Make a new variant that's a method: ;; Constructor must be from `make-required', but not a method.
(let* ([name+fail (keyword-procedure-name+fail proc)] ;; Make a new variant that's a method:
[mk (make-required (car name+fail) (cdr name+fail) #t #f)]) (let* ([name+fail (keyword-procedure-name+fail proc)]
(mk [mk (make-required (car name+fail) (cdr name+fail) #t #f)])
(keyword-procedure-checker proc) (mk
(keyword-procedure-proc proc) (keyword-procedure-checker proc)
(keyword-procedure-required proc) (keyword-procedure-proc proc)
(keyword-procedure-allowed proc)))]) (keyword-procedure-required proc)
;; Not a keyword-accepting procedure: (keyword-procedure-allowed proc)))])
(procedure->method proc)))]) ;; Not a keyword-accepting procedure:
(procedure->method proc))))])
procedure->method)) procedure->method))
(define new:procedure-rename (define new:procedure-rename
@ -1495,147 +1492,172 @@
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)]
(not (procedure? wrap-proc)) [n-wrap-proc (normalize-proc wrap-proc)])
;; if any bad prop, let `chaperone-procedure' complain (if (or (not (keyword-procedure? n-proc))
(let loop ([props props]) (not (procedure? wrap-proc))
;; if any bad prop, let `chaperone-procedure' complain
(let loop ([props props])
(cond
[(null? props) #f]
[(impersonator-property? (car props))
(let ([props (cdr props)])
(or (null? props)
(loop (cdr props))))]
[else #t])))
(apply chaperone-procedure proc wrap-proc props)
(let-values ([(a) (procedure-arity proc)]
[(b) (procedure-arity wrap-proc)]
[(a-req a-allow) (procedure-keywords proc)]
[(b-req b-allow) (procedure-keywords wrap-proc)])
(define (includes? a b)
(cond (cond
[(null? props) #f] [(number? b) (cond
[(impersonator-property? (car props)) [(number? a) (= b a)]
(let ([props (cdr props)]) [(arity-at-least? a)
(or (null? props) (b . >= . (arity-at-least-value a))]
(loop (cdr props))))] [else
[else #t]))) (ormap (lambda (a) (includes? a b)) a)])]
(apply chaperone-procedure proc wrap-proc props) [(arity-at-least? b) (cond
(let-values ([(a) (procedure-arity proc)] [(number? a) #f]
[(b) (procedure-arity wrap-proc)] [(arity-at-least? a)
[(a-req a-allow) (procedure-keywords proc)] ((arity-at-least-value b) . >= . (arity-at-least-value a))]
[(b-req b-allow) (procedure-keywords wrap-proc)]) [else (ormap (lambda (a) (includes? b a)) a)])]
(define (includes? a b) [else (andmap (lambda (b) (includes? a b)) b)]))
(cond
[(number? b) (cond
[(number? a) (= b a)]
[(arity-at-least? a)
(b . >= . (arity-at-least-value a))]
[else
(ormap (lambda (a) (includes? a b)) a)])]
[(arity-at-least? b) (cond
[(number? a) #f]
[(arity-at-least? a)
((arity-at-least-value b) . >= . (arity-at-least-value a))]
[else (ormap (lambda (a) (includes? b a)) a)])]
[else (andmap (lambda (b) (includes? a b)) b)]))
(unless (includes? b a) (unless (includes? b a)
;; Let core report error: ;; Let core report error:
(apply chaperone-procedure proc wrap-proc props)) (apply chaperone-procedure proc wrap-proc props))
(unless (subset? b-req a-req) (unless (subset? b-req a-req)
(raise-arguments-error (raise-arguments-error
name name
"wrapper procedure requires more keywords than original procedure" "wrapper procedure requires more keywords than original procedure"
"wrapper procedure" wrap-proc "wrapper procedure" wrap-proc
"original procedure" proc)) "original procedure" proc))
(unless (or (not b-allow) (unless (or (not b-allow)
(and a-allow (and a-allow
(subset? a-allow b-allow))) (subset? a-allow b-allow)))
(raise-arguments-error (raise-arguments-error
name name
"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* ([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))
(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
(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))))])])
(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) 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])))

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

@ -1194,7 +1194,10 @@ 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);
v = scheme_extract_struct_procedure(v, -1, NULL, &is_method); 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);
if (!v || is_method || !SCHEME_CHAPERONE_PROC_STRUCTP(v)) if (!v || is_method || !SCHEME_CHAPERONE_PROC_STRUCTP(v))
break; break;
name = (const char *)v; name = (const char *)v;

13
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) {
return scheme_null; if ((maxa >= 0) && (maxa < drop))
else return scheme_null;
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);
} }