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

Actually, move the old-style define/contract to its own file in mzlib,

Browse Source 
and change around mzlib/contract.ss appropriately.

svn: r11715

original commit: 0870c7ae1ddd58de472e2990f6b194686e61b083
This commit is contained in:
Stevie Strickland 2008-09-13 02:51:09 +00:00
parent 74026b5e51
commit f00388ac41
2 changed files with 81 additions and 6 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

17
collects/mzlib/contract.ss
View File

@ -15,6 +15,13 @@
(require "private/contract-object.ss")
(provide (all-from-out "private/contract-object.ss"))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;
;; old-style define/contract
;;
(require "private/contract-define.ss")
(provide (all-from-out "private/contract-define.ss"))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;
@ -22,7 +29,9 @@
;; except the arrow contracts
;;
(require scheme/private/contract
(require (except-in scheme/private/contract
define/contract
with-contract)
scheme/private/contract-guts
scheme/private/contract-ds
scheme/private/contract-opt
@ -34,14 +43,10 @@
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]
[old-define/contract define/contract]))
(rename-out [string-len/c string/len]))
;; from contract-guts.ss

70
collects/mzlib/private/contract-define.ss Normal file
View File

@ -0,0 +1,70 @@
#lang scheme/base
(provide define/contract)
(require (for-syntax scheme/base)
(only-in scheme/contract contract)
(for-syntax (prefix-in a: scheme/private/contract-helpers)))
;; First, we have the old define/contract implementation, which
;; is still used in mzlib/contract.
(define-for-syntax (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
(format "definition ~a" (syntax->datum (quote-syntax f)))
neg-blame-str
(quote-syntax f))
arg
...))]
[ident
(identifier? (syntax ident))
(syntax/loc stx
(contract contract-id
id
(format "definition ~a" (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 (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
(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))]))