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

Add better first-order checking for ->d and ->i.

Browse Source 
Closes PR 11247.
This commit is contained in:
Stevie Strickland 2010-09-23 14:29:30 -04:00
parent 206fe52047
commit d2a3cbf6d0
3 changed files with 76 additions and 40 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

16
collects/racket/contract/private/arr-i.rkt
View File

@ -34,7 +34,7 @@
(struct ->i (arg-ctcs arg-dep-ctcs indy-arg-ctcs
rng-ctcs rng-dep-ctcs indy-rng-ctcs
pre/post-procs
mandatory-args opt-args mandatory-kwds opt-kwds rest?
mandatory-args opt-args mandatory-kwds opt-kwds rest? mtd?
here
mk-wrapper
name-info)
@ -149,7 +149,18 @@
,@(if post-info
`(#:post ,post-info ...)
'()))))
#:first-order (λ (ctc) (λ (x) #f)) ;; WRONG
#:first-order
(λ (ctc)
(let ([has-rest? (->i-rest? ctc)]
[mtd? (->i-mtd? ctc)]
[mand-args (->i-mandatory-args ctc)]
[opt-args (->i-opt-args ctc)]
[mand-kwds (->i-mandatory-kwds ctc)]
[opt-kwds (->i-opt-kwds ctc)])
(λ (val)
(if has-rest?
(check-procedure/more val mtd? mand-args mand-kwds opt-kwds #f)
(check-procedure val mtd? mand-args opt-args mand-kwds opt-kwds #f)))))
#:stronger (λ (this that) (eq? this that)))) ;; WRONG
;; find-ordering : (listof arg) -> (values (listof arg) (listof number))
@ -731,6 +742,7 @@
(istx-args an-istx)))
keyword<?)
#,(and (istx-rst an-istx) #t)
#,(and (syntax-parameter-value #'making-a-method) #t)
(quote-module-path)
#,wrapper-func
'#(#,(for/list ([an-arg (in-list (istx-args an-istx))])

94
collects/racket/contract/private/arrow.rkt
View File

@ -965,13 +965,20 @@ v4 todo:
(λ (blame)
(let ([this->d-id (gensym '->d-tail-key)])
(λ (val)
(check-procedure val
(->d-mtd? ->d-stct)
(length (->d-mandatory-dom-ctcs ->d-stct)) ;dom-length
(length (->d-optional-dom-ctcs ->d-stct)) ; optionals-length
(->d-mandatory-keywords ->d-stct)
(->d-optional-keywords ->d-stct)
blame)
(if (->d-rest-ctc ->d-stct)
(check-procedure/more val
(->d-mtd? ->d-stct)
(length (->d-mandatory-dom-ctcs ->d-stct)) ;dom-length
(->d-mandatory-keywords ->d-stct)
(->d-optional-keywords ->d-stct)
blame)
(check-procedure val
(->d-mtd? ->d-stct)
(length (->d-mandatory-dom-ctcs ->d-stct)) ;dom-length
(length (->d-optional-dom-ctcs ->d-stct)) ; optionals-length
(->d-mandatory-keywords ->d-stct)
(->d-optional-keywords ->d-stct)
blame))
(let ([kwd-proc
(λ (kwd-args kwd-arg-vals . raw-orig-args)
(let* ([orig-args (if (->d-mtd? ->d-stct)
@ -1246,7 +1253,16 @@ v4 todo:
(list '#:post '...)
(list)))))
#:first-order (λ (ctc) (λ (x) #f))
#:first-order (λ (ctc)
(λ (val)
(let* ([mtd? (->d-mtd? ctc)]
[dom-length (length (->d-mandatory-dom-ctcs ctc))]
[optionals (length (->d-optional-dom-ctcs ctc))]
[mandatory-kwds (->d-mandatory-keywords ctc)]
[optional-kwds (->d-optional-keywords ctc)])
(if (->d-rest-ctc ctc)
(check-procedure/more val mtd? dom-length mandatory-kwds optional-kwds #f)
(check-procedure val mtd? dom-length optionals mandatory-kwds optional-kwds #f)))))
#:stronger (λ (this that) (eq? this that))))
@ -1555,22 +1571,23 @@ v4 todo:
(null? mandatory)))
(define (check-procedure val mtd? dom-length optionals mandatory-kwds optional-keywords blame)
(unless (and (procedure? val)
(procedure-arity-includes?/optionals val (if mtd? (+ dom-length 1) dom-length) optionals)
(keywords-match mandatory-kwds optional-keywords val))
(raise-blame-error
blame
val
"expected a ~a that accepts ~a~a~a argument~a~a~a, given: ~e"
(if mtd? "method" "procedure")
(if (zero? dom-length) "no" dom-length)
(if (null? optionals) "" " mandatory")
(if (null? mandatory-kwds) "" " ordinary")
(if (= 1 dom-length) "" "s")
(if (zero? optionals) ""
(format " and up to ~a optional argument~a" optionals (if (= 1 optionals) "" "s")))
(keyword-error-text mandatory-kwds optional-keywords)
val)))
(or (and (procedure? val)
(procedure-arity-includes?/optionals val (if mtd? (+ dom-length 1) dom-length) optionals)
(keywords-match mandatory-kwds optional-keywords val))
(and blame
(raise-blame-error
blame
val
"expected a ~a that accepts ~a~a~a argument~a~a~a, given: ~e"
(if mtd? "method" "procedure")
(if (zero? dom-length) "no" dom-length)
(if (null? optionals) "" " mandatory")
(if (null? mandatory-kwds) "" " ordinary")
(if (= 1 dom-length) "" "s")
(if (zero? optionals) ""
(format " and up to ~a optional argument~a" optionals (if (= 1 optionals) "" "s")))
(keyword-error-text mandatory-kwds optional-keywords)
val))))
(define (procedure-arity-includes?/optionals f base optionals)
(cond
@ -1620,20 +1637,21 @@ v4 todo:
(format-keywords-error 'optional optional-keywords))]))
(define (check-procedure/more val mtd? dom-length mandatory-kwds optional-kwds blame)
(unless (and (procedure? val)
(procedure-accepts-and-more? val (if mtd? (+ dom-length 1) dom-length))
(keywords-match mandatory-kwds optional-kwds val))
(raise-blame-error
blame
val
"expected a ~a that accepts ~a argument~a and arbitrarily more~a, given: ~e"
(if mtd? "method" "procedure")
(cond
[(zero? dom-length) "no"]
[else dom-length])
(if (= 1 dom-length) "" "s")
(keyword-error-text mandatory-kwds optional-kwds)
val)))
(or (and (procedure? val)
(procedure-accepts-and-more? val (if mtd? (+ dom-length 1) dom-length))
(keywords-match mandatory-kwds optional-kwds val))
(and blame
(raise-blame-error
blame
val
"expected a ~a that accepts ~a argument~a and arbitrarily more~a, given: ~e"
(if mtd? "method" "procedure")
(cond
[(zero? dom-length) "no"]
[else dom-length])
(if (= 1 dom-length) "" "s")
(keyword-error-text mandatory-kwds optional-kwds)
val))))
;; timing & size tests

6
collects/tests/racket/contract-test.rktl
View File

@ -9552,6 +9552,12 @@ so that propagation occurs.
(ctest #f contract-first-order-passes? (->* (integer?) () #:rest any/c (values char? any/c)) (λ (x y . z) #f))
(ctest #f contract-first-order-passes? (->* (integer?) () #:rest any/c (values char? any/c)) (λ (x) #f))
(ctest #t contract-first-order-passes? (->* (integer?) () #:rest any/c (values char? any/c)) (λ x #f))
(ctest #t contract-first-order-passes? (->d ((z any/c)) () (result any/c)) (λ (x) x))
(ctest #f contract-first-order-passes? (->d ((z any/c)) () (result any/c)) (λ (x y) x))
(ctest #t contract-first-order-passes? (->i ((z any/c)) () (result any/c)) (λ (x) x))
(ctest #f contract-first-order-passes? (->i ((z any/c)) () (result any/c)) (λ (x y) x))
(ctest #t contract-first-order-passes? (listof integer?) (list 1))
(ctest #f contract-first-order-passes? (listof integer?) #f)