diff --git a/collects/scheme/contract/private/arrow.ss b/collects/scheme/contract/private/arrow.ss index b96cf066e3..9e0fe81c39 100644 --- a/collects/scheme/contract/private/arrow.ss +++ b/collects/scheme/contract/private/arrow.ss @@ -707,7 +707,11 @@ v4 todo: [(post-cond leftover) (syntax-case leftover () [(#:post-cond post-cond . leftover) - (values #'post-cond #'leftover)] + (begin + (syntax-case range (any) + [any (raise-syntax-error #f "cannot have a #:post-cond with any as the range" stx #'post-cond)] + [_ (void)]) + (values #'post-cond #'leftover))] [_ (values #f leftover)])]) (syntax-case leftover () [() @@ -929,7 +933,8 @@ v4 todo: src-info neg-blame orig-str - "#:pre-cond violation"))) + "#:pre-cond violation~a" + (build-values-string ", argument" dep-pre-args)))) (call-with-immediate-continuation-mark ->d-tail-key (λ (first-mark) @@ -955,7 +960,12 @@ v4 todo: src-info pos-blame orig-str - "#:post-cond violation"))) + "#:post-cond violation~a~a" + (build-values-string ", argument" dep-pre-args) + (build-values-string (if (null? dep-pre-args) + ", result" + "\n result") + orig-results)))) (unless (= range-count (length orig-results)) (raise-contract-error val @@ -989,6 +999,20 @@ v4 todo: (->d-mandatory-keywords ->d-stct) (->d-keywords ->d-stct)))))))) +(define (build-values-string desc dep-pre-args) + (cond + [(null? dep-pre-args) ""] + [(null? (cdr dep-pre-args)) (format "~a was: ~e" desc (car dep-pre-args))] + [else + (apply + string-append + (format "~as were:" desc) + (let loop ([lst dep-pre-args]) + (cond + [(null? lst) '()] + [else (cons (format "\n ~e" (car lst)) + (loop (cdr lst)))])))])) + ;; invoke-dep-ctc : (...? -> ctc) (or/c #f (listof tst)) val pos-blame neg-blame src-info orig-src -> tst (define (invoke-dep-ctc dep-ctc dep-args val pos-blame neg-blame src-info orig-str positive-position?) (let ([ctc (coerce-contract '->d (if dep-args diff --git a/collects/tests/mzscheme/contract-test.ss b/collects/tests/mzscheme/contract-test.ss index e954c496ae..e8556a56c7 100644 --- a/collects/tests/mzscheme/contract-test.ss +++ b/collects/tests/mzscheme/contract-test.ss @@ -1607,7 +1607,7 @@ '((contract (->d () ([a number?]) #:rest rest any/c - any + [_ any/c] #:post-cond (equal? (list a rest) (list the-unsupplied-arg '()))) (λ ([a 1] . rest) 1) 'pos