diff --git a/collects/racket/contract/private/base.rkt b/collects/racket/contract/private/base.rkt index a3fe542536..938123f426 100644 --- a/collects/racket/contract/private/base.rkt +++ b/collects/racket/contract/private/base.rkt @@ -49,7 +49,7 @@ (check-source-location! 'contract loc) (let ([new-val (((contract-projection c) - (make-blame loc name (λ () (contract-name c)) pos neg #t)) + (make-blame (build-source-location loc) name (λ () (contract-name c)) pos neg #t)) v)]) (if (and (not (parameter? new-val)) ;; when PR 11221 is fixed, remove this line (procedure? new-val) diff --git a/collects/racket/contract/private/blame.rkt b/collects/racket/contract/private/blame.rkt index 798a7c0b0a..49106a403c 100644 --- a/collects/racket/contract/private/blame.rkt +++ b/collects/racket/contract/private/blame.rkt @@ -45,17 +45,26 @@ (define -make-blame (let ([make-blame - (λ (source value build-name positive negative original?) + (lambda (source value build-name positive negative original?) + (unless (srcloc? source) + (raise-type-error 'make-blame "source location (srcloc?)" 0 + source value build-name positive negative original?)) + (unless (procedure? build-name) + (raise-type-error 'make-blame "procedure" 2 + source value build-name positive negative original?)) + (unless (procedure-arity-includes? build-name 0) + (raise-type-error 'make-blame "procedure of 0 arguments" 2 + source value build-name positive negative original?)) (make-blame - source - value - build-name - (list positive) - (list negative) - original? - '() - #t - #f))]) + source + value + build-name + (list positive) + (list negative) + original? + '() + #t + #f))]) make-blame)) ;; s : (or/c string? #f)