fix fast path to not ignore pre/post conditions and bail out appropriately
This commit is contained in:
parent
71a43f34c8
commit
8c5c8da1a7
|
@ -1196,8 +1196,22 @@
|
|||
(f)))
|
||||
(eval '(dynamic-require ''provide/contract64-m2 #f)))
|
||||
"provide/contract64-m1")
|
||||
|
||||
|
||||
|
||||
(test/spec-failed
|
||||
'provide/contract65
|
||||
'(let ()
|
||||
(eval '(module provide/contract65-m1 racket/base
|
||||
(require racket/contract/base)
|
||||
(provide
|
||||
(contract-out
|
||||
[f (->* () () #:pre/desc "get-apples not allowed" any)]))
|
||||
(define (f) (values #t #t))))
|
||||
(eval '(module provide/contract65-m2 racket/base
|
||||
(require 'provide/contract65-m1)
|
||||
(f)))
|
||||
(eval '(dynamic-require ''provide/contract65-m2 #f)))
|
||||
"provide/contract65-m2")
|
||||
|
||||
(contract-error-test
|
||||
'contract-error-test8
|
||||
#'(begin
|
||||
|
|
|
@ -830,11 +830,14 @@
|
|||
(parse->* stx this->*))
|
||||
(with-syntax ([((mandatory-dom-kwd mandatory-dom-kwd-ctc) ...) man-dom-kwds]
|
||||
[((optional-dom-kwd optional-dom-kwd-ctc) ...) opt-dom-kwds])
|
||||
(valid-app-shapes-from-man/opts (length (syntax->list man-dom))
|
||||
(length (syntax->list opt-dom))
|
||||
rest-ctc
|
||||
(syntax->datum #'(mandatory-dom-kwd ...))
|
||||
(syntax->datum #'(optional-dom-kwd ...)))))
|
||||
(cond
|
||||
[(or pre pre/desc post post/desc) #f]
|
||||
[else
|
||||
(valid-app-shapes-from-man/opts (length (syntax->list man-dom))
|
||||
(length (syntax->list opt-dom))
|
||||
rest-ctc
|
||||
(syntax->datum #'(mandatory-dom-kwd ...))
|
||||
(syntax->datum #'(optional-dom-kwd ...)))])))
|
||||
|
||||
(define-syntax (->* stx)
|
||||
(syntax-case stx ()
|
||||
|
|
|
@ -283,9 +283,14 @@
|
|||
[(-> . _)
|
||||
(not (->-arity-check-only->? ctrct))
|
||||
(values #t (->-valid-app-shapes ctrct))]
|
||||
[(->* . _)
|
||||
(values (not (->*-arity-check-only->? ctrct))
|
||||
(->*-valid-app-shapes ctrct))]
|
||||
[(->* . _)
|
||||
(cond
|
||||
[(->*-arity-check-only->? ctrct) (values #f #f)]
|
||||
[else
|
||||
(define shapes (->*-valid-app-shapes ctrct))
|
||||
(if shapes
|
||||
(values #t shapes)
|
||||
(values #f #f))])]
|
||||
[(->i . _) (values #t (->i-valid-app-shapes ctrct))]
|
||||
[_ (values #f #f)]))
|
||||
(with-syntax ([id id]
|
||||
|
|
Loading…
Reference in New Issue
Block a user