suzanne.soy/racket
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

Add error checking to ensure blame-source produces a srcloc? as documented.

Browse Source
This commit is contained in:
Carl Eastlund 2013-03-15 12:19:32 -04:00
parent c8f79dacbb
commit 4ebf53e919
2 changed files with 20 additions and 11 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

2
collects/racket/contract/private/base.rkt
View File

@ -49,7 +49,7 @@
(check-source-location! 'contract loc) (check-source-location! 'contract loc)
(let ([new-val (let ([new-val
(((contract-projection c) (((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)]) v)])
(if (and (not (parameter? new-val)) ;; when PR 11221 is fixed, remove this line (if (and (not (parameter? new-val)) ;; when PR 11221 is fixed, remove this line
(procedure? new-val) (procedure? new-val)

11
collects/racket/contract/private/blame.rkt
View File

@ -45,7 +45,16 @@
(define -make-blame (define -make-blame
(let ([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 (make-blame
source source
value value