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

Ported more code to new contract tools.

Browse Source 
svn: r17733

original commit: 722fae41a8e5e74a053336ab6e5bc32f3487870d
This commit is contained in:
Carl Eastlund 2010-01-19 03:42:45 +00:00
parent 6e0495d778
commit 9747444199
2 changed files with 10 additions and 6 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

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

@ -33,7 +33,7 @@
(let ([proj-x (contract-projection rngs-x)] ...) (let ([proj-x (contract-projection rngs-x)] ...)
(simple-contract (simple-contract
#:name #:name
(build-compound-type-name 'unconstrained-domain-> ((name-get rngs-x) rngs-x) ...) (build-compound-type-name 'unconstrained-domain-> (contract-name rngs-x) ...)
#:projection #:projection
(λ (blame) (λ (blame)
(let ([p-app-x (proj-x blame)] ...) (let ([p-app-x (proj-x blame)] ...)

14
collects/mzlib/private/contract-define.ss
View File

@ -2,9 +2,11 @@
(provide define/contract) (provide define/contract)
(require (for-syntax scheme/base) (require (for-syntax scheme/base
unstable/srcloc
(prefix-in a: scheme/contract/private/helpers))
(only-in scheme/contract contract) (only-in scheme/contract contract)
(for-syntax (prefix-in a: scheme/contract/private/helpers))) unstable/location)
;; First, we have the old define/contract implementation, which ;; First, we have the old define/contract implementation, which
;; is still used in mzlib/contract. ;; is still used in mzlib/contract.
@ -12,7 +14,7 @@
(define-for-syntax (make-define/contract-transformer contract-id id) (define-for-syntax (make-define/contract-transformer contract-id id)
(make-set!-transformer (make-set!-transformer
(λ (stx) (λ (stx)
(with-syntax ([neg-blame-str (a:build-src-loc-string stx)] (with-syntax ([neg-blame-str (source-location->string stx)]
[contract-id contract-id] [contract-id contract-id]
[id id]) [id id])
(syntax-case stx (set!) (syntax-case stx (set!)
@ -27,7 +29,8 @@
id id
(syntax->datum (quote-syntax f)) (syntax->datum (quote-syntax f))
neg-blame-str neg-blame-str
(quote-syntax f)) (quote f)
(quote-srcloc f))
arg arg
...))] ...))]
[ident [ident
@ -37,7 +40,8 @@
id id
(syntax->datum (quote-syntax ident)) (syntax->datum (quote-syntax ident))
neg-blame-str neg-blame-str
(quote-syntax ident)))]))))) (quote ident)
(quote-srcloc ident)))])))))
;; (define/contract id contract expr) ;; (define/contract id contract expr)
;; defines `id' with `contract'; initially binding ;; defines `id' with `contract'; initially binding