fix opt/c for the new way (-> any/c ... any) works

should have been a part of 36b3493e
This commit is contained in:
Robby Findler 2016-01-02 20:49:06 -06:00
parent 5ae4e45340
commit 77a76a7953
3 changed files with 33 additions and 27 deletions

View File

@ -323,6 +323,19 @@
'contract-any/c-arrow5 'contract-any/c-arrow5
'((contract (-> any/c any) (λ (x [y 1]) x) 'pos 'neg) 1 2)) '((contract (-> any/c any) (λ (x [y 1]) x) 'pos 'neg) 1 2))
(test/spec-passed/result
'contract-any/c-arrow6
'(let ([f (λ (x) x)])
(eq? f (contract (-> any/c any) f 'pos 'neg)))
#t)
(test/spec-passed/result
'contract-any/c-arrow7
'(let ([f (λ (x [y 1]) x)])
(eq? f (contract (-> any/c any) f 'pos 'neg)))
#f)
(test/spec-passed (test/spec-passed
'contract-arrow-all-kwds2 'contract-arrow-all-kwds2
'((contract (-> #:a string? void?) '((contract (-> #:a string? void?)

View File

@ -11,6 +11,7 @@
(prefix-in arrow: "arrow.rkt")) (prefix-in arrow: "arrow.rkt"))
(provide (for-syntax build-chaperone-constructor/real) (provide (for-syntax build-chaperone-constructor/real)
procedure-arity-exactly/no-kwds
->-proj ->-proj
check-pre-cond check-pre-cond
check-post-cond check-post-cond

View File

@ -6,6 +6,7 @@
"blame.rkt" "blame.rkt"
"arrow.rkt" "arrow.rkt"
"arrow-val-first.rkt" "arrow-val-first.rkt"
"arrow-higher-order.rkt"
"orc.rkt" "orc.rkt"
(for-syntax racket/base (for-syntax racket/base
syntax/stx syntax/stx
@ -619,6 +620,10 @@
#`(list 'values #,@rng-names)))))) #`(list 'values #,@rng-names))))))
(define (opt/arrow-any-ctc doms) (define (opt/arrow-any-ctc doms)
(define all-anys? (for/and ([d (in-list doms)])
(syntax-case d (any/c)
[any/c #t]
[anything-else #f])))
(let*-values ([(dom-vars) (generate-temporaries doms)] (let*-values ([(dom-vars) (generate-temporaries doms)]
[(next-doms lifts-doms superlifts-doms partials-doms stronger-ribs-dom dom-chaperone? names) [(next-doms lifts-doms superlifts-doms partials-doms stronger-ribs-dom dom-chaperone? names)
(let loop ([vars dom-vars] (let loop ([vars dom-vars]
@ -662,14 +667,20 @@
((dom-arg ...) dom-vars) ((dom-arg ...) dom-vars)
((next-dom ...) next-doms) ((next-dom ...) next-doms)
(dom-len (length dom-vars))) (dom-len (length dom-vars)))
(syntax (begin (define do-chap-stx
#'(begin
(check-procedure val #f dom-len 0 '() '() #|keywords|# blame #f) (check-procedure val #f dom-len 0 '() '() #|keywords|# blame #f)
(chaperone-procedure (chaperone-procedure
val val
(case-lambda (case-lambda
[(dom-arg ...) (values next-dom ...)] [(dom-arg ...) (values next-dom ...)]
[args [args
(bad-number-of-arguments blame val args dom-len)]))))) (bad-number-of-arguments blame val args dom-len)]))))
(if all-anys?
#`(if (procedure-arity-exactly/no-kwds val #,(length doms))
val
#,do-chap-stx)
do-chap-stx))
lifts-doms lifts-doms
superlifts-doms superlifts-doms
partials-doms partials-doms
@ -682,25 +693,6 @@
'any)))) 'any))))
(syntax-case* stx (-> values any any/c boolean?) module-or-top-identifier=? (syntax-case* stx (-> values any any/c boolean?) module-or-top-identifier=?
[(_ any/c ... any)
(with-syntax ([n (- (length (syntax->list stx)) 2)])
(build-optres
#:exp
(with-syntax ((val (opt/info-val opt/info))
(ctc (opt/info-contract opt/info))
(blame (opt/info-blame opt/info)))
(syntax (if (and (procedure? val)
(procedure-arity-includes? val n))
val
(raise-flat-arrow-err blame val n))))
#:lifts null
#:superlifts null
#:partials null
#:flat #'(and (procedure? val) (procedure-arity-includes? val n))
#:opt #f
#:stronger-ribs null
#:chaperone #t
#:name #`'(-> #,@(build-list (syntax-e #'n) (λ (x) 'any/c)) any)))]
[(_ any/c boolean?) [(_ any/c boolean?)
(predicate/c-optres opt/info #f)] (predicate/c-optres opt/info #f)]
[(_ dom ... (values rng ...)) [(_ dom ... (values rng ...))