fix opt/c for the new way (-> any/c ... any) works
should have been a part of 36b3493e
This commit is contained in:
parent
5ae4e45340
commit
77a76a7953
|
@ -323,6 +323,19 @@
|
|||
'contract-any/c-arrow5
|
||||
'((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
|
||||
'contract-arrow-all-kwds2
|
||||
'((contract (-> #:a string? void?)
|
||||
|
|
|
@ -11,6 +11,7 @@
|
|||
(prefix-in arrow: "arrow.rkt"))
|
||||
|
||||
(provide (for-syntax build-chaperone-constructor/real)
|
||||
procedure-arity-exactly/no-kwds
|
||||
->-proj
|
||||
check-pre-cond
|
||||
check-post-cond
|
||||
|
|
|
@ -6,6 +6,7 @@
|
|||
"blame.rkt"
|
||||
"arrow.rkt"
|
||||
"arrow-val-first.rkt"
|
||||
"arrow-higher-order.rkt"
|
||||
"orc.rkt"
|
||||
(for-syntax racket/base
|
||||
syntax/stx
|
||||
|
@ -619,6 +620,10 @@
|
|||
#`(list 'values #,@rng-names))))))
|
||||
|
||||
(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)]
|
||||
[(next-doms lifts-doms superlifts-doms partials-doms stronger-ribs-dom dom-chaperone? names)
|
||||
(let loop ([vars dom-vars]
|
||||
|
@ -662,14 +667,20 @@
|
|||
((dom-arg ...) dom-vars)
|
||||
((next-dom ...) next-doms)
|
||||
(dom-len (length dom-vars)))
|
||||
(syntax (begin
|
||||
(define do-chap-stx
|
||||
#'(begin
|
||||
(check-procedure val #f dom-len 0 '() '() #|keywords|# blame #f)
|
||||
(chaperone-procedure
|
||||
val
|
||||
(case-lambda
|
||||
[(dom-arg ...) (values next-dom ...)]
|
||||
[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
|
||||
superlifts-doms
|
||||
partials-doms
|
||||
|
@ -682,25 +693,6 @@
|
|||
'any))))
|
||||
|
||||
(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?)
|
||||
(predicate/c-optres opt/info #f)]
|
||||
[(_ dom ... (values rng ...))
|
||||
|
|
Loading…
Reference in New Issue
Block a user