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

Re-disabled legacy (contract ...) form.

Browse Source 
svn: r17960
This commit is contained in:
Carl Eastlund 2010-02-03 17:08:26 +00:00
parent 73407bed63
commit 2e64069d14
3 changed files with 8 additions and 27 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

5
collects/scheme/contract/base.ss
View File

@ -27,10 +27,7 @@
check-unary-between/c) check-unary-between/c)
(all-from-out "private/provide.ss") (all-from-out "private/provide.ss")
(all-from-out "private/base.ss") (all-from-out "private/base.ss")
(except-out (all-from-out "private/legacy.ss") (all-from-out "private/legacy.ss")
unpack-blame
unpack-source
unpack-name)
(except-out (all-from-out "private/guts.ss") (except-out (all-from-out "private/guts.ss")
check-flat-contract check-flat-contract
check-flat-named-contract)) check-flat-named-contract))

28
collects/scheme/contract/private/base.ss
View File

@ -18,8 +18,7 @@ improve method arity mismatch contract violation error messages?
unstable/srcloc unstable/srcloc
unstable/location unstable/location
"guts.ss" "guts.ss"
"blame.ss" "blame.ss")
"legacy.ss")
(define-syntax-parameter current-contract-region (define-syntax-parameter current-contract-region
(λ (stx) #'(quote-module-path))) (λ (stx) #'(quote-module-path)))
@ -28,28 +27,15 @@ improve method arity mismatch contract violation error messages?
(syntax-case stx () (syntax-case stx ()
[(_ c v pos neg name loc) [(_ c v pos neg name loc)
(syntax/loc stx (syntax/loc stx
(apply-contract c (apply-contract c v pos neg name loc))]
v
(unpack-blame pos)
(unpack-blame neg)
name
loc))]
[(_ c v pos neg) [(_ c v pos neg)
(syntax/loc stx (syntax/loc stx
(apply-contract c (apply-contract c v pos neg #f (build-source-location #f)))]
v
(unpack-blame pos)
(unpack-blame neg)
#f
(build-source-location #f)))]
[(_ c v pos neg src) [(_ c v pos neg src)
(syntax/loc stx (raise-syntax-error 'contract
(apply-contract c (string-append
v "please update contract application to new protocol "
(unpack-blame pos) "(either 4 or 6 arguments)"))]))
(unpack-blame neg)
(unpack-name src)
(unpack-source src)))]))
(define (apply-contract c v pos neg name loc) (define (apply-contract c v pos neg name loc)
(let* ([c (coerce-contract 'contract c)]) (let* ([c (coerce-contract 'contract c)])

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

@ -12,8 +12,6 @@
first-order-prop first-order-get first-order-pred? first-order-prop first-order-get first-order-pred?
flat-prop flat-get flat-pred? flat-prop flat-get flat-pred?
unpack-blame unpack-source unpack-name
) )
(define (raise-contract-error x src pos name fmt . args) (define (raise-contract-error x src pos name fmt . args)