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

Fixed legacy projections to allow 4 or 5 arguments.

Browse Source 
svn: r17903
This commit is contained in:
Carl Eastlund 2010-01-31 00:29:37 +00:00
parent 7d577d9d02
commit 29b628cb0a
1 changed files with 19 additions and 7 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

16
collects/scheme/contract/private/legacy.ss
View File

@ -33,16 +33,28 @@
#:name name #:name name
#:first-order test #:first-order test
#:projection #:projection
(cond
[(procedure-arity-includes? proj 5)
(lambda (blame) (lambda (blame)
(proj (blame-guilty blame) (proj (blame-guilty blame)
(blame-innocent blame) (blame-innocent blame)
(list (blame-source blame) (blame-value blame)) (list (blame-source blame) (blame-value blame))
(blame-contract blame) (blame-contract blame)
(not (blame-swapped? blame)))))) (not (blame-swapped? blame))))]
[(procedure-arity-includes? proj 4)
(lambda (blame)
(proj (blame-guilty blame)
(blame-innocent blame)
(list (blame-source blame) (blame-value blame))
(blame-contract blame)))]
[else
(error 'make-proj-contract
"expected a projection that accepts 4 or 5 arguments; got: ~e"
proj)])))
(define (contract-proc c) (define (contract-proc c)
(let* ([proj (contract-projection c)]) (let* ([proj (contract-projection c)])
(lambda (pos neg src name original?) (lambda (pos neg src name [original? #t])
(proj (make-blame (unpack-source src) (proj (make-blame (unpack-source src)
(unpack-name src) (unpack-name src)
name name