fix fast path to not ignore pre/post conditions and bail out appropriately

This commit is contained in:
Robby Findler 2017-02-05 14:31:59 -06:00
parent 71a43f34c8
commit 8c5c8da1a7
3 changed files with 32 additions and 10 deletions

View File

@ -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

View File

@ -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 ()

View File

@ -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]