clean up some confusion about the timing of errors
specifically, always wait for the neg party to come in before signalling any errors
This commit is contained in:
parent
640895645f
commit
71f338430b
|
@ -1068,6 +1068,19 @@
|
|||
(define a (s-x (chaperone-struct an-s s-x (λ (s x) x))))))
|
||||
(eval '(dynamic-require ''provide/contract55-m2 'a)))
|
||||
'5)
|
||||
|
||||
(test/spec-failed
|
||||
'provide/contract56
|
||||
'(let ()
|
||||
(eval '(module provide/contract56-m1 racket/base
|
||||
(require racket/contract/base)
|
||||
(provide
|
||||
(contract-out
|
||||
[f (-> integer? integer?)]))
|
||||
(define f 1)))
|
||||
(eval '(dynamic-require ''provide/contract56-m1 #f)))
|
||||
"provide/contract56-m1")
|
||||
|
||||
|
||||
(contract-error-test
|
||||
'contract-error-test8
|
||||
|
|
|
@ -15,8 +15,7 @@
|
|||
->stct-kwd-infos)
|
||||
(let/ec k
|
||||
(unless (procedure? val)
|
||||
(maybe-err
|
||||
k blame
|
||||
(k
|
||||
(λ (neg-party)
|
||||
(raise-blame-error blame #:missing-party neg-party val
|
||||
'(expected: "a procedure" given: "~e")
|
||||
|
@ -37,8 +36,7 @@
|
|||
(<= (arity-at-least-value lst) ->stct-min-arity)))
|
||||
#t)))
|
||||
(unless matching-arity?
|
||||
(maybe-err
|
||||
k blame
|
||||
(k
|
||||
(λ (neg-party)
|
||||
(raise-blame-error blame #:missing-party neg-party val
|
||||
'(expected:
|
||||
|
@ -54,8 +52,7 @@
|
|||
(arity-as-string val)))))
|
||||
|
||||
(define (should-have-supplied kwd)
|
||||
(maybe-err
|
||||
k blame
|
||||
(k
|
||||
(λ (neg-party)
|
||||
(raise-blame-error blame #:missing-party neg-party val
|
||||
'(expected:
|
||||
|
@ -67,8 +64,7 @@
|
|||
(arity-as-string val)))))
|
||||
|
||||
(define (should-not-have-supplied kwd)
|
||||
(maybe-err
|
||||
k blame
|
||||
(k
|
||||
(λ (neg-party)
|
||||
(raise-blame-error blame #:missing-party neg-party val
|
||||
'(expected:
|
||||
|
@ -107,8 +103,7 @@
|
|||
[(equal? kwd (kwd-info-kwd kwd-info))
|
||||
(when (and (not (kwd-info-mandatory? kwd-info))
|
||||
mandatory?)
|
||||
(maybe-err
|
||||
k blame
|
||||
(k
|
||||
(λ (neg-party)
|
||||
(raise-blame-error
|
||||
blame #:missing-party neg-party val
|
||||
|
@ -224,7 +219,3 @@
|
|||
(cons (format "~a, " (car kwds))
|
||||
(loop (cdr kwds)))])))]))
|
||||
|
||||
(define (maybe-err k blame neg-accepter)
|
||||
(if (blame-original? blame)
|
||||
(neg-accepter #f)
|
||||
(k neg-accepter)))
|
||||
|
|
|
@ -548,17 +548,21 @@
|
|||
(define (arrow-higher-order:vfp val)
|
||||
(define-values (normal-proc proc-with-no-result-checking expected-number-of-results)
|
||||
(apply plus-one-arity-function orig-blame val plus-one-constructor-args))
|
||||
(wrapped-extra-arg-arrow
|
||||
(cond
|
||||
[(do-arity-checking orig-blame val doms rest min-arity kwd-infos)
|
||||
=>
|
||||
values]
|
||||
[else
|
||||
(cond
|
||||
[(do-arity-checking orig-blame val doms rest min-arity kwd-infos)
|
||||
=>
|
||||
(λ (neg-party-acceptor)
|
||||
;; probably don't need to include the wrapped-extra-arrow wrapper
|
||||
;; here, but it is easier to reason about the contract-out invariant
|
||||
;; with it here
|
||||
(wrapped-extra-arg-arrow neg-party-acceptor normal-proc))]
|
||||
[else
|
||||
(wrapped-extra-arg-arrow
|
||||
(λ (neg-party)
|
||||
(successfully-got-the-right-kind-of-function val neg-party))])
|
||||
(if (equal? (procedure-result-arity val) expected-number-of-results)
|
||||
proc-with-no-result-checking
|
||||
normal-proc)))
|
||||
(successfully-got-the-right-kind-of-function val neg-party))
|
||||
(if (equal? (procedure-result-arity val) expected-number-of-results)
|
||||
proc-with-no-result-checking
|
||||
normal-proc))]))
|
||||
(if okay-to-do-only-arity-check?
|
||||
(λ (val)
|
||||
(cond
|
||||
|
|
Loading…
Reference in New Issue
Block a user