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

.

Browse Source 
original commit: 9f1a41f5a9eeb77d15edb96afc70b710a6d117b0
This commit is contained in:
Robby Findler 2005-02-10 04:01:00 +00:00
parent 9276cc66f6
commit f37aa08dae
1 changed files with 30 additions and 2 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

32
collects/mzlib/contract.ss
View File

@ -648,6 +648,26 @@ add struct contracts for immutable structs?
(((contract-proc a-contract) pos-blame neg-blame src-info (contract-name a-contract))
name)))
(define-values (make-exn:fail:contract2
exn:fail:contract2?
exn:fail:contract2-srclocs)
(let-values ([(exn:fail:contract2
make-exn:fail:contract2
exn:fail:contract2?
get
set)
(parameterize ([current-inspector (make-inspector)])
(make-struct-type 'exn:fail:contract2
struct:exn:fail
1
0
#f
(list (cons prop:exn:srclocs (lambda (x) (exn:fail:contract2-srclocs x))))))])
(values
make-exn:fail:contract2
exn:fail:contract2?
(lambda (x) (get x 0)))))
;; raise-contract-error : (union syntax #f) symbol symbol string string args ... -> alpha
;; doesn't return
(define (raise-contract-error src-info to-blame other-party contract-sexp fmt . args)
@ -666,7 +686,7 @@ add struct contracts for immutable structs?
(format "broke ~a's contract:" datum)
"failed contract"))])
(raise
(make-exn:fail
(make-exn:fail:contract2
(string->immutable-string
(string-append (format "~a~a: ~a ~a ~a"
blame-src
@ -675,7 +695,15 @@ add struct contracts for immutable structs?
specific-blame
formatted-contract-sexp)
(apply format fmt args)))
(current-continuation-marks)))))
(current-continuation-marks)
(if src-info
(list (make-srcloc
(syntax-source src-info)
(syntax-line src-info)
(syntax-column src-info)
(syntax-position src-info)
(syntax-span src-info)))
'())))))
;; src-info-as-string : (union syntax #f) -> string
(define (src-info-as-string src-info)