diff --git a/collects/mzlib/contract.ss b/collects/mzlib/contract.ss index 373846b..944fcd4 100644 --- a/collects/mzlib/contract.ss +++ b/collects/mzlib/contract.ss @@ -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 diff --git a/collects/mzlib/private/contract-define.ss b/collects/mzlib/private/contract-define.ss new file mode 100644 index 0000000..d1f3ea6 --- /dev/null +++ b/collects/mzlib/private/contract-define.ss @@ -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))])) + + +