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 (struct ->i (arg-ctcs arg-dep-ctcs indy-arg-ctcs
rng-ctcs rng-dep-ctcs indy-rng-ctcs rng-ctcs rng-dep-ctcs indy-rng-ctcs
pre/post-procs pre/post-procs
mandatory-args opt-args mandatory-kwds opt-kwds rest? mandatory-args opt-args mandatory-kwds opt-kwds rest? mtd?
here here
mk-wrapper mk-wrapper
name-info) name-info)
@ -149,7 +149,18 @@
,@(if post-info ,@(if post-info
`(#:post ,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 #:stronger (λ (this that) (eq? this that)))) ;; WRONG
;; find-ordering : (listof arg) -> (values (listof arg) (listof number)) ;; find-ordering : (listof arg) -> (values (listof arg) (listof number))
@ -731,6 +742,7 @@
(istx-args an-istx))) (istx-args an-istx)))
keyword<?) keyword<?)
#,(and (istx-rst an-istx) #t) #,(and (istx-rst an-istx) #t)
#,(and (syntax-parameter-value #'making-a-method) #t)
(quote-module-path) (quote-module-path)
#,wrapper-func #,wrapper-func
'#(#,(for/list ([an-arg (in-list (istx-args an-istx))]) '#(#,(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) (λ (blame)
(let ([this->d-id (gensym '->d-tail-key)]) (let ([this->d-id (gensym '->d-tail-key)])
(λ (val) (λ (val)
(check-procedure val (if (->d-rest-ctc ->d-stct)
(->d-mtd? ->d-stct) (check-procedure/more val
(length (->d-mandatory-dom-ctcs ->d-stct)) ;dom-length (->d-mtd? ->d-stct)
(length (->d-optional-dom-ctcs ->d-stct)) ; optionals-length (length (->d-mandatory-dom-ctcs ->d-stct)) ;dom-length
(->d-mandatory-keywords ->d-stct) (->d-mandatory-keywords ->d-stct)
(->d-optional-keywords ->d-stct) (->d-optional-keywords ->d-stct)
blame) 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 (let ([kwd-proc
(λ (kwd-args kwd-arg-vals . raw-orig-args) (λ (kwd-args kwd-arg-vals . raw-orig-args)
(let* ([orig-args (if (->d-mtd? ->d-stct) (let* ([orig-args (if (->d-mtd? ->d-stct)
@ -1246,7 +1253,16 @@ v4 todo:
(list '#:post '...) (list '#:post '...)
(list))))) (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)))) #:stronger (λ (this that) (eq? this that))))
@ -1555,22 +1571,23 @@ v4 todo:
(null? mandatory))) (null? mandatory)))
(define (check-procedure val mtd? dom-length optionals mandatory-kwds optional-keywords blame) (define (check-procedure val mtd? dom-length optionals mandatory-kwds optional-keywords blame)
(unless (and (procedure? val) (or (and (procedure? val)
(procedure-arity-includes?/optionals val (if mtd? (+ dom-length 1) dom-length) optionals) (procedure-arity-includes?/optionals val (if mtd? (+ dom-length 1) dom-length) optionals)
(keywords-match mandatory-kwds optional-keywords val)) (keywords-match mandatory-kwds optional-keywords val))
(raise-blame-error (and blame
blame (raise-blame-error
val blame
"expected a ~a that accepts ~a~a~a argument~a~a~a, given: ~e" val
(if mtd? "method" "procedure") "expected a ~a that accepts ~a~a~a argument~a~a~a, given: ~e"
(if (zero? dom-length) "no" dom-length) (if mtd? "method" "procedure")
(if (null? optionals) "" " mandatory") (if (zero? dom-length) "no" dom-length)
(if (null? mandatory-kwds) "" " ordinary") (if (null? optionals) "" " mandatory")
(if (= 1 dom-length) "" "s") (if (null? mandatory-kwds) "" " ordinary")
(if (zero? optionals) "" (if (= 1 dom-length) "" "s")
(format " and up to ~a optional argument~a" optionals (if (= 1 optionals) "" "s"))) (if (zero? optionals) ""
(keyword-error-text mandatory-kwds optional-keywords) (format " and up to ~a optional argument~a" optionals (if (= 1 optionals) "" "s")))
val))) (keyword-error-text mandatory-kwds optional-keywords)
val))))
(define (procedure-arity-includes?/optionals f base optionals) (define (procedure-arity-includes?/optionals f base optionals)
(cond (cond
@ -1620,20 +1637,21 @@ v4 todo:
(format-keywords-error 'optional optional-keywords))])) (format-keywords-error 'optional optional-keywords))]))
(define (check-procedure/more val mtd? dom-length mandatory-kwds optional-kwds blame) (define (check-procedure/more val mtd? dom-length mandatory-kwds optional-kwds blame)
(unless (and (procedure? val) (or (and (procedure? val)
(procedure-accepts-and-more? val (if mtd? (+ dom-length 1) dom-length)) (procedure-accepts-and-more? val (if mtd? (+ dom-length 1) dom-length))
(keywords-match mandatory-kwds optional-kwds val)) (keywords-match mandatory-kwds optional-kwds val))
(raise-blame-error (and blame
blame (raise-blame-error
val blame
"expected a ~a that accepts ~a argument~a and arbitrarily more~a, given: ~e" val
(if mtd? "method" "procedure") "expected a ~a that accepts ~a argument~a and arbitrarily more~a, given: ~e"
(cond (if mtd? "method" "procedure")
[(zero? dom-length) "no"] (cond
[else dom-length]) [(zero? dom-length) "no"]
(if (= 1 dom-length) "" "s") [else dom-length])
(keyword-error-text mandatory-kwds optional-kwds) (if (= 1 dom-length) "" "s")
val))) (keyword-error-text mandatory-kwds optional-kwds)
val))))
;; timing & size tests ;; 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 y . z) #f))
(ctest #f contract-first-order-passes? (->* (integer?) () #:rest any/c (values char? any/c)) (λ (x) #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? (->* (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 #t contract-first-order-passes? (listof integer?) (list 1))
(ctest #f contract-first-order-passes? (listof integer?) #f) (ctest #f contract-first-order-passes? (listof integer?) #f)