fix reducing arity or chaperoning keyword-valued prop:procedure
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
Ryan Culpepper
parent
b9c81b6906
commit
5bae9773aa
|
|
@ -6,14 +6,24 @@
|
|||
;; ----------------------------------------
|
||||
|
||||
(define (f0) null)
|
||||
(define (f0+ . x) x)
|
||||
(define (f0+/drop1 . x) (cdr x))
|
||||
(define (f1 x) (list x))
|
||||
(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 0]) (list 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 . 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 0] #:b b) (list a b))
|
||||
(define (f1:a:b x #:a a #:b b) (list x a b))
|
||||
|
|
@ -37,10 +47,29 @@
|
|||
(lambda (kws kw-args x)
|
||||
(cons x kw-args))
|
||||
(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
|
||||
`((,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 () ())
|
||||
(,(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) () ())
|
||||
(,f0:a 0 (#:a) (#:a))
|
||||
(,f0:a? 0 () (#:a))
|
||||
|
|
@ -48,6 +77,11 @@
|
|||
(,f1:a? 1 () (#:a))
|
||||
(,f1+:a ,(make-arity-at-least 1) (#:a) (#: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 (#:b) (#:a #:b))
|
||||
(,f1:a:b 1 (#:a #:b) (#:a #:b))
|
||||
|
|
@ -63,8 +97,20 @@
|
|||
(,f_ () () ())
|
||||
(,f_1_2 (1 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)
|
||||
(cond
|
||||
[(procedure-arity-includes? p n #t)
|
||||
|
|
@ -80,13 +126,20 @@
|
|||
(exn-message exn))))]))
|
||||
|
||||
(let ()
|
||||
(define (get-maybe p n)
|
||||
(and ((length p) . > . n) (list-ref p n)))
|
||||
(define (try-combos procs add-chaperone)
|
||||
(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))
|
||||
(when (number? a)
|
||||
(let ([rx (regexp (format " mismatch;.*expected: (|at least )~a"
|
||||
(if (zero? a) "(0|no)" a)))]
|
||||
(let ([rx (regexp (format " mismatch;.*(expected number(?!.*expected:)|expected: ~a)"
|
||||
(if (zero? a) "(0|no)" (if method? (sub1 a) a))))]
|
||||
[bad-args (cons 'extra (for/list ([i (in-range a)]) 'a))])
|
||||
(test #t regexp-match? rx
|
||||
(with-handlers ([exn:fail? (lambda (exn)
|
||||
|
|
@ -98,6 +151,16 @@
|
|||
(exn-message exn))])
|
||||
(for-each (car p) (list bad-args))
|
||||
"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))
|
||||
(lambda ()
|
||||
(procedure-keywords (car p))))
|
||||
|
|
@ -116,7 +179,7 @@
|
|||
(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->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)
|
||||
(unless (null? (list-tail p 4))
|
||||
(test (object-name (list-ref p 4)) object-name (car p)))
|
||||
|
|
@ -178,50 +241,59 @@
|
|||
[(equal? allowed #f)
|
||||
(err/rt-test ((car p) 1 #:a 1 #:b 1))])))))))
|
||||
(map
|
||||
add-chaperone
|
||||
values ; add-chaperone
|
||||
procs
|
||||
#;
|
||||
(append procs
|
||||
;; reduce to arity 1 or nothing:
|
||||
(map (lambda (p)
|
||||
(let ([p (car p)])
|
||||
(let ([p (car p)]
|
||||
[method? (get-maybe p 4)])
|
||||
(let-values ([(req allowed) (procedure-keywords p)])
|
||||
(if (null? allowed)
|
||||
(if (procedure-arity-includes? p 1 #t)
|
||||
(list (procedure-reduce-arity p 1) 1 req allowed p)
|
||||
(list (procedure-reduce-arity p '()) '() req allowed p))
|
||||
(list (procedure-reduce-arity p 1) 1 req allowed method? p)
|
||||
(list (procedure-reduce-arity p '()) '() req allowed method? p))
|
||||
(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 '() req allowed) '() 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 method? p))))))
|
||||
procs)
|
||||
;; reduce to arity 0 or nothing:
|
||||
(map (lambda (p)
|
||||
(let ([p (car p)])
|
||||
(let ([p (car p)]
|
||||
[method? (get-maybe p 4)])
|
||||
(let-values ([(req allowed) (procedure-keywords p)])
|
||||
(if (null? allowed)
|
||||
(if (procedure-arity-includes? p 0 #t)
|
||||
(list (procedure-reduce-arity p 0) 0 req allowed p)
|
||||
(list (procedure-reduce-arity p '()) '() req allowed p))
|
||||
(list (procedure-reduce-arity p 0) 0 req allowed method? p)
|
||||
(list (procedure-reduce-arity p '()) '() req allowed method? p))
|
||||
(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 '() req allowed) '() 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 method? p))))))
|
||||
procs)
|
||||
;; reduce to arity 1 or nothing --- no keywords:
|
||||
(map (lambda (p)
|
||||
(let ([p (car p)])
|
||||
(let ([p (car p)]
|
||||
[method? (get-maybe p 4)])
|
||||
(let-values ([(req allowed) (procedure-keywords p)])
|
||||
(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)
|
||||
null
|
||||
(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)
|
||||
;; reduce to arity 0 or nothing --- no keywords:
|
||||
(map (lambda (p)
|
||||
(let ([p (car p)])
|
||||
(let ([p (car p)]
|
||||
[method? (get-maybe p 4)])
|
||||
(let-values ([(req allowed) (procedure-keywords p)])
|
||||
(if (procedure-arity-includes? p 0)
|
||||
(list (procedure-reduce-arity p 0) 0 '() '() p)
|
||||
(list (procedure-reduce-arity p '()) '() '() '() p)))))
|
||||
(list (procedure-reduce-arity p 0) 0 '() '() method? p)
|
||||
(list (procedure-reduce-arity p '()) '() '() '() method? p)))))
|
||||
procs)
|
||||
;; make #:a required, if possible:
|
||||
(map (lambda (p)
|
||||
|
|
@ -237,6 +309,7 @@
|
|||
(cadr p)
|
||||
new-req
|
||||
allowed
|
||||
(get-maybe p 4)
|
||||
(car p)))))
|
||||
(filter (lambda (p)
|
||||
(let-values ([(req allowed) (procedure-keywords (car p))])
|
||||
|
|
@ -257,6 +330,7 @@
|
|||
(cadr p)
|
||||
req
|
||||
new-allowed
|
||||
(get-maybe p 4)
|
||||
(car p)
|
||||
(if allowed
|
||||
(list allowed)
|
||||
|
|
|
|||
|
|
@ -1325,10 +1325,10 @@
|
|||
|
||||
;; setting procedure arity
|
||||
(define (procedure-reduce-keyword-arity proc arity req-kw allowed-kw)
|
||||
(let ([plain-proc (procedure-reduce-arity (if (okp? proc)
|
||||
(okp-ref proc 0)
|
||||
proc)
|
||||
arity)])
|
||||
(let* ([plain-proc (procedure-reduce-arity (if (okp? proc)
|
||||
(okp-ref proc 0)
|
||||
proc)
|
||||
arity)])
|
||||
(define (sorted? kws)
|
||||
(let loop ([kws kws])
|
||||
(cond
|
||||
|
|
@ -1351,12 +1351,7 @@
|
|||
"allowed-keyword list does not include all required keywords"
|
||||
"allowed-keyword list" allowed-kw
|
||||
"required keywords" req-kw)))
|
||||
(let ([old-req (if (keyword-procedure? proc)
|
||||
(keyword-procedure-required proc)
|
||||
null)]
|
||||
[old-allowed (if (keyword-procedure? proc)
|
||||
(keyword-procedure-allowed proc)
|
||||
null)])
|
||||
(let-values ([(old-req old-allowed) (procedure-keywords proc)])
|
||||
(unless (subset? old-req req-kw)
|
||||
(raise-arguments-error 'procedure-reduce-keyword-arity
|
||||
"cannot reduce required keyword set"
|
||||
|
|
@ -1386,6 +1381,7 @@
|
|||
(map loop a)])))]
|
||||
[new-arity (inc-arity arity 2)]
|
||||
[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-arity)])
|
||||
(if (null? req-kw)
|
||||
|
|
@ -1403,7 +1399,7 @@
|
|||
((make-required (or (and (named-keyword-procedure? proc)
|
||||
(car (keyword-procedure-name+fail proc)))
|
||||
(object-name proc))
|
||||
(procedure-reduce-arity
|
||||
(procedure-reduce-arity
|
||||
missing-kw
|
||||
(inc-arity arity 1))
|
||||
(or (okm? proc)
|
||||
|
|
@ -1418,8 +1414,8 @@
|
|||
(let ([procedure-reduce-arity
|
||||
(lambda (proc arity)
|
||||
(if (and (procedure? proc)
|
||||
(keyword-procedure? proc)
|
||||
(not (okp? proc))
|
||||
(let-values ([(req allows) (procedure-keywords proc)])
|
||||
(pair? req))
|
||||
(not (null? arity)))
|
||||
(raise-arguments-error 'procedure-reduce-arity
|
||||
"procedure has required keyword arguments"
|
||||
|
|
@ -1430,28 +1426,29 @@
|
|||
(define new:procedure->method
|
||||
(let ([procedure->method
|
||||
(lambda (proc)
|
||||
(if (keyword-procedure? proc)
|
||||
(cond
|
||||
[(okm? proc) proc]
|
||||
[(keyword-method? proc) proc]
|
||||
[(okp? proc) (make-optional-keyword-method
|
||||
(keyword-procedure-checker proc)
|
||||
(keyword-procedure-proc proc)
|
||||
(keyword-procedure-required proc)
|
||||
(keyword-procedure-allowed proc)
|
||||
(okp-ref proc 0))]
|
||||
[else
|
||||
;; Constructor must be from `make-required', but not a method.
|
||||
;; Make a new variant that's a method:
|
||||
(let* ([name+fail (keyword-procedure-name+fail proc)]
|
||||
[mk (make-required (car name+fail) (cdr name+fail) #t #f)])
|
||||
(mk
|
||||
(keyword-procedure-checker proc)
|
||||
(keyword-procedure-proc proc)
|
||||
(keyword-procedure-required proc)
|
||||
(keyword-procedure-allowed proc)))])
|
||||
;; Not a keyword-accepting procedure:
|
||||
(procedure->method proc)))])
|
||||
(let ([proc (normalize-proc proc)])
|
||||
(if (keyword-procedure? proc)
|
||||
(cond
|
||||
[(okm? proc) proc]
|
||||
[(keyword-method? proc) proc]
|
||||
[(okp? proc) (make-optional-keyword-method
|
||||
(keyword-procedure-checker proc)
|
||||
(keyword-procedure-proc proc)
|
||||
(keyword-procedure-required proc)
|
||||
(keyword-procedure-allowed proc)
|
||||
(okp-ref proc 0))]
|
||||
[else
|
||||
;; Constructor must be from `make-required', but not a method.
|
||||
;; Make a new variant that's a method:
|
||||
(let* ([name+fail (keyword-procedure-name+fail proc)]
|
||||
[mk (make-required (car name+fail) (cdr name+fail) #t #f)])
|
||||
(mk
|
||||
(keyword-procedure-checker proc)
|
||||
(keyword-procedure-proc proc)
|
||||
(keyword-procedure-required proc)
|
||||
(keyword-procedure-allowed proc)))])
|
||||
;; Not a keyword-accepting procedure:
|
||||
(procedure->method proc))))])
|
||||
procedure->method))
|
||||
|
||||
(define new:procedure-rename
|
||||
|
|
@ -1495,147 +1492,172 @@
|
|||
impersonate-procedure))
|
||||
|
||||
(define (do-chaperone-procedure is-impersonator? chaperone-procedure name proc wrap-proc props)
|
||||
(if (or (not (keyword-procedure? proc))
|
||||
(not (procedure? wrap-proc))
|
||||
;; if any bad prop, let `chaperone-procedure' complain
|
||||
(let loop ([props props])
|
||||
(let ([n-proc (normalize-proc proc)]
|
||||
[n-wrap-proc (normalize-proc wrap-proc)])
|
||||
(if (or (not (keyword-procedure? n-proc))
|
||||
(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
|
||||
[(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
|
||||
[(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)]))
|
||||
[(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)
|
||||
;; Let core report error:
|
||||
(apply chaperone-procedure proc wrap-proc props))
|
||||
(unless (subset? b-req a-req)
|
||||
(raise-arguments-error
|
||||
name
|
||||
"wrapper procedure requires more keywords than original procedure"
|
||||
"wrapper procedure" wrap-proc
|
||||
"original procedure" proc))
|
||||
(unless (or (not b-allow)
|
||||
(and a-allow
|
||||
(subset? a-allow b-allow)))
|
||||
(raise-arguments-error
|
||||
name
|
||||
"wrapper procedure does not accept all keywords of original procedure"
|
||||
"wrapper procedure" wrap-proc
|
||||
"original procedure" proc))
|
||||
(let* ([kw-chaperone
|
||||
(let ([p (keyword-procedure-proc wrap-proc)])
|
||||
(case-lambda
|
||||
[(kws args . rest)
|
||||
(call-with-values (lambda () (apply p kws args rest))
|
||||
(lambda results
|
||||
(let ([len (length results)]
|
||||
[alen (length rest)])
|
||||
(unless (<= (+ alen 1) len (+ alen 2))
|
||||
(raise-arguments-error
|
||||
'|keyword procedure chaperone|
|
||||
"wrong number of results from wrapper procedure"
|
||||
"expected minimum number of results" (+ alen 1)
|
||||
"expected maximum number of results" (+ alen 2)
|
||||
"received number of results" len
|
||||
"wrapper procedure" wrap-proc))
|
||||
(let ([extra? (= len (+ alen 2))])
|
||||
(let ([new-args ((if extra? cadr car) results)])
|
||||
(unless (and (list? new-args)
|
||||
(= (length new-args) (length args)))
|
||||
(raise-arguments-error
|
||||
'|keyword procedure chaperone|
|
||||
(format
|
||||
"expected a list of keyword-argument values as first result~a from wrapper procedure"
|
||||
(if (= len alen)
|
||||
""
|
||||
" (after the result-wrapper procedure)"))
|
||||
"first result" new-args
|
||||
"wrapper procedure" wrap-proc))
|
||||
(for-each
|
||||
(lambda (kw new-arg arg)
|
||||
(unless is-impersonator?
|
||||
(unless (chaperone-of? new-arg arg)
|
||||
(raise-arguments-error
|
||||
'|keyword procedure chaperone|
|
||||
(format
|
||||
"~a keyword result is not a chaperone of original argument from chaperoning procedure"
|
||||
kw)
|
||||
"result" new-arg
|
||||
"wrapper procedure" wrap-proc))))
|
||||
kws
|
||||
new-args
|
||||
args))
|
||||
(if extra?
|
||||
(apply values (car results) kws (cdr results))
|
||||
(apply values kws results))))))]
|
||||
;; The following case exists only to make sure that the arity of
|
||||
;; any procedure passed to `make-keyword-args' is covered
|
||||
;; bu this procedure's arity.
|
||||
[other (error "shouldn't get here")]))]
|
||||
[new-proc
|
||||
(cond
|
||||
[(okp? proc)
|
||||
(if is-impersonator?
|
||||
((if (okm? proc)
|
||||
make-optional-keyword-method-impersonator
|
||||
make-optional-keyword-procedure-impersonator)
|
||||
(keyword-procedure-checker proc)
|
||||
(chaperone-procedure (keyword-procedure-proc proc)
|
||||
kw-chaperone)
|
||||
(keyword-procedure-required proc)
|
||||
(keyword-procedure-allowed proc)
|
||||
(chaperone-procedure (okp-ref proc 0)
|
||||
(okp-ref wrap-proc 0))
|
||||
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 wrap-proc 0)))))]
|
||||
[else
|
||||
(if is-impersonator?
|
||||
;; Constructor must be from `make-required':
|
||||
(let* ([name+fail (keyword-procedure-name+fail proc)]
|
||||
[mk (make-required (car name+fail) (cdr name+fail) (keyword-method? proc) #t)])
|
||||
(mk
|
||||
(keyword-procedure-checker proc)
|
||||
(chaperone-procedure (keyword-procedure-proc proc) kw-chaperone)
|
||||
(keyword-procedure-required proc)
|
||||
(keyword-procedure-allowed proc)
|
||||
proc))
|
||||
(chaperone-struct
|
||||
proc
|
||||
keyword-procedure-proc
|
||||
(lambda (self proc)
|
||||
(chaperone-procedure proc kw-chaperone))))])])
|
||||
(if (null? props)
|
||||
new-proc
|
||||
(apply chaperone-struct new-proc
|
||||
;; chaperone-struct insists on having at least one selector:
|
||||
keyword-procedure-allowed (lambda (s v) v)
|
||||
props)))))))
|
||||
(unless (includes? b a)
|
||||
;; Let core report error:
|
||||
(apply chaperone-procedure proc wrap-proc props))
|
||||
(unless (subset? b-req a-req)
|
||||
(raise-arguments-error
|
||||
name
|
||||
"wrapper procedure requires more keywords than original procedure"
|
||||
"wrapper procedure" wrap-proc
|
||||
"original procedure" proc))
|
||||
(unless (or (not b-allow)
|
||||
(and a-allow
|
||||
(subset? a-allow b-allow)))
|
||||
(raise-arguments-error
|
||||
name
|
||||
"wrapper procedure does not accept all keywords of original procedure"
|
||||
"wrapper procedure" wrap-proc
|
||||
"original procedure" proc))
|
||||
(let* ([kw-chaperone
|
||||
(let ([p (keyword-procedure-proc n-wrap-proc)])
|
||||
(case-lambda
|
||||
[(kws args . rest)
|
||||
(call-with-values (lambda () (apply p kws args rest))
|
||||
(lambda results
|
||||
(let ([len (length results)]
|
||||
[alen (length rest)])
|
||||
(unless (<= (+ alen 1) len (+ alen 2))
|
||||
(raise-arguments-error
|
||||
'|keyword procedure chaperone|
|
||||
"wrong number of results from wrapper procedure"
|
||||
"expected minimum number of results" (+ alen 1)
|
||||
"expected maximum number of results" (+ alen 2)
|
||||
"received number of results" len
|
||||
"wrapper procedure" wrap-proc))
|
||||
(let ([extra? (= len (+ alen 2))])
|
||||
(let ([new-args ((if extra? cadr car) results)])
|
||||
(unless (and (list? new-args)
|
||||
(= (length new-args) (length args)))
|
||||
(raise-arguments-error
|
||||
'|keyword procedure chaperone|
|
||||
(format
|
||||
"expected a list of keyword-argument values as first result~a from wrapper procedure"
|
||||
(if (= len alen)
|
||||
""
|
||||
" (after the result-wrapper procedure)"))
|
||||
"first result" new-args
|
||||
"wrapper procedure" wrap-proc))
|
||||
(for-each
|
||||
(lambda (kw new-arg arg)
|
||||
(unless is-impersonator?
|
||||
(unless (chaperone-of? new-arg arg)
|
||||
(raise-arguments-error
|
||||
'|keyword procedure chaperone|
|
||||
(format
|
||||
"~a keyword result is not a chaperone of original argument from chaperoning procedure"
|
||||
kw)
|
||||
"result" new-arg
|
||||
"wrapper procedure" wrap-proc))))
|
||||
kws
|
||||
new-args
|
||||
args))
|
||||
(if extra?
|
||||
(apply values (car results) kws (cdr results))
|
||||
(apply values kws results))))))]
|
||||
;; The following case exists only to make sure that the arity of
|
||||
;; any procedure passed to `make-keyword-args' is covered
|
||||
;; 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)
|
||||
(chaperone-struct
|
||||
n-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
|
||||
;; chaperone-struct insists on having at least one selector:
|
||||
keyword-procedure-allowed (lambda (s v) v)
|
||||
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])))
|
||||
|
|
|
|||
|
|
@ -1194,7 +1194,10 @@ static char *make_arity_expect_string(const char *name, int namelen,
|
|||
v = (Scheme_Object *)name;
|
||||
if (SCHEME_CHAPERONEP(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))
|
||||
break;
|
||||
name = (const char *)v;
|
||||
|
|
|
|||
|
|
@ -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 (mina < drop)
|
||||
return scheme_null;
|
||||
else
|
||||
if (mina < drop) {
|
||||
if ((maxa >= 0) && (maxa < drop))
|
||||
return scheme_null;
|
||||
else
|
||||
mina = 0;
|
||||
} else
|
||||
mina -= drop;
|
||||
if (maxa > 0)
|
||||
if (maxa > 0) {
|
||||
/* assert: maxa >= drop, or else would have returned in `mina < drop` test */
|
||||
maxa -= drop;
|
||||
}
|
||||
|
||||
return make_arity(mina, maxa, a);
|
||||
}
|
||||
|
|
|
|||
Loading…
Reference in New Issue
Block a user