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

Okay, here's the old stuff put back, will fix up the unit tests when I get

Browse Source 
home.

svn: r11709
This commit is contained in:
Stevie Strickland 2008-09-12 23:51:51 +00:00
parent 32f0b99f12
commit c484131597
3 changed files with 72 additions and 2 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

6
collects/mzlib/contract.ss
View File

@ -34,10 +34,14 @@
lazy-depth-to-look)
(except-out (all-from-out scheme/private/contract)
old-define/contract
define/contract
with-contract
check-between/c
string-len/c
check-unary-between/c)
(rename-out [string-len/c string/len]))
(rename-out [string-len/c string/len]
[old-define/contract define/contract]))
;; from contract-guts.ss

1
collects/scheme/contract.ss
View File

@ -27,6 +27,7 @@ differences from v3:
check-procedure
check-procedure/more)
(except-out (all-from-out "private/contract.ss")
old-define/contract
check-between/c
check-unary-between/c))

67
collects/scheme/private/contract.ss
View File

@ -12,6 +12,7 @@ improve method arity mismatch contract violation error messages?
(provide (rename-out [-contract contract])
recursive-contract
provide/contract
old-define/contract
define/contract
with-contract
current-contract-region)
@ -57,7 +58,9 @@ improve method arity mismatch contract violation error messages?
#,(syntax-position id)
#,(syntax-span id))
#,(format "~s" (syntax->datum id))))
;
;
;
@ -75,6 +78,68 @@ improve method arity mismatch contract violation error messages?
; ;
;
;; First, we have the old define/contract implementation, which
;; is still used in mzlib/contract.
(define-for-syntax (old-make-define/contract-transformer contract-id id)
(make-set!-transformer
(λ (stx)
(with-syntax ([neg-blame-str (a:build-src-loc-string stx)]
[contract-id contract-id]
[id id])
(syntax-case stx (set!)
[(set! id arg)
(raise-syntax-error 'define/contract
"cannot set! a define/contract variable"
stx
(syntax id))]
[(f arg ...)
(syntax/loc stx
((-contract contract-id
id
(syntax->datum (quote-syntax f))
neg-blame-str
(quote-syntax f))
arg
...))]
[ident
(identifier? (syntax ident))
(syntax/loc stx
(-contract contract-id
id
(syntax->datum (quote-syntax ident))
neg-blame-str
(quote-syntax ident)))])))))
;; (define/contract id contract expr)
;; defines `id' with `contract'; initially binding
;; it to the result of `expr'. These variables may not be set!'d.
(define-syntax (old-define/contract define-stx)
(syntax-case define-stx ()
[(_ name contract-expr expr)
(identifier? (syntax name))
(with-syntax ([contract-id
(a:mangle-id define-stx
"define/contract-contract-id"
(syntax name))]
[id (a:mangle-id define-stx
"define/contract-id"
(syntax name))])
(syntax/loc define-stx
(begin
(define contract-id contract-expr)
(define-syntax name
(old-make-define/contract-transformer (quote-syntax contract-id)
(quote-syntax id)))
(define id (let ([name expr]) name)) ;; let for procedure naming
)))]
[(_ name contract-expr expr)
(raise-syntax-error 'define/contract "expected identifier in first position"
define-stx
(syntax name))]))
;; (define/contract id contract expr)
;; defines `id' with `contract'; initially binding
;; it to the result of `expr'. These variables may not be set!'d.