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

improved internal contract stuff

Browse Source 
svn: r2546
This commit is contained in:
Robby Findler 2006-03-30 19:05:54 +00:00
parent 680655a33e
commit ea9d5bfe8b
4 changed files with 20 additions and 40 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

23
collects/mzlib/private/contract-arrow.ss
View File

@ -2032,7 +2032,6 @@
(raise-contract-error val
src-info
blame
'ignored
orig-str
"pre-condition expression failure")))
@ -2041,7 +2040,6 @@
(raise-contract-error val
src-info
blame
'ignored
orig-str
"post-condition expression failure")))
@ -2052,7 +2050,6 @@
val
src-info
blame
'ignored
orig-str
"expected a procedure that accepts ~a arguments, given: ~e"
dom-length
@ -2063,16 +2060,14 @@
(raise-contract-error val
src-info
blame
'ignored
orig-str
orig-str
"expected a procedure, got ~e"
val))
(unless (procedure-arity-includes? val arity)
(raise-contract-error val
src-info
blame
'ignored
orig-str
orig-str
"expected a ~a of arity ~a (not arity ~a), got ~e"
kind-of-thing
arity
@ -2084,7 +2079,6 @@
(raise-contract-error val
src-info
blame
'ignored
orig-str
"expected a procedure, got ~e"
val))
@ -2092,8 +2086,7 @@
(raise-contract-error val
src-info
blame
'ignored
orig-str
orig-str
"expected a ~a that accepts ~a arguments and aribtrarily more (not arity ~a), got ~e"
kind-of-thing
arity
@ -2107,7 +2100,6 @@
val
src-info
blame
'ignored
orig-str
"expected a procedure that accepts ~a arguments and any number of arguments larger than ~a, given: ~e"
dom-length
@ -2140,8 +2132,7 @@
(raise-contract-error val
src-info
blame
'ignored
orig-str
orig-str
"expected an object, got ~e"
val)))
@ -2150,8 +2141,7 @@
(raise-contract-error val
src-info
blame
'ignored
orig-str
orig-str
"expected an object with method ~s"
method-name)))
@ -2159,8 +2149,7 @@
(raise-contract-error val
src-info
blame
'ignored
orig-str
orig-str
"expected an object with field ~s"
field-name))

13
collects/mzlib/private/contract-ds.ss
View File

@ -1,3 +1,15 @@
#|
why make a separate struct for the contract information
instead of putting it into the wrapper struct in an
extra field?
this probably requires putting the contract info into
its own struct from the beginning, rather than passing
it around flattened out.
|#
(module contract-ds mzscheme
(require "contract-guts.ss")
@ -143,7 +155,6 @@
val
src-info
blame
'ignored
orig-str
"expected <~a>, got ~e" 'name val))
(cond

21
collects/mzlib/private/contract-guts.ss
View File

@ -211,13 +211,13 @@
(define contract-violation->string (make-parameter default-contract-violation->string))
(define (raise-contract-error val src-info to-blame other-party contract-sexp fmt . args)
(define (raise-contract-error val src-info blame contract-sexp fmt . args)
(raise
(make-exn:fail:contract2
(string->immutable-string
((contract-violation->string) val
src-info
to-blame
blame
contract-sexp
(apply format fmt args)))
(current-continuation-marks)
@ -284,22 +284,6 @@
;; the argument to the result function is the value to test.
;; (the result function is the projection)
;;
(define (flat-proj ctc)
(let ([predicate ((flat-get ctc) ctc)]
[name ((name-get ctc) ctc)])
(λ (pos neg src-info orig-str)
(λ (val)
(if (predicate val)
val
(raise-contract-error
val
src-info
pos
'???
orig-str
"expected <~a>, given: ~e"
name
val))))))
(define (flat-pos-proj ctc)
(let ([predicate ((flat-get ctc) ctc)]
@ -312,7 +296,6 @@
val
src-info
pos
'???
orig-str
"expected <~a>, given: ~e"
name

3
collects/mzlib/private/contract.ss
View File

@ -1075,7 +1075,6 @@ add struct contracts for immutable structs?
val
src-info
blame
'ignored
orig-str
"expected <~a>, given: ~e"
'type-name
@ -1192,7 +1191,6 @@ add struct contracts for immutable structs?
v
src-info
blame
'ignored
orig-str
"expected <~a>, given: ~e"
'type-name
@ -1232,7 +1230,6 @@ add struct contracts for immutable structs?
v
src-info
blame
'ignored
orig-str
"expected <~a>, given: ~e"
'type-name