From 0870c7ae1ddd58de472e2990f6b194686e61b083 Mon Sep 17 00:00:00 2001
From: Stevie Strickland <sstrickl@racket-lang.org>
Date: Sat, 13 Sep 2008 02:51:09 +0000
Subject: [PATCH] Actually, move the old-style define/contract to its own file
 in mzlib, and change around mzlib/contract.ss appropriately.

svn: r11715
---
 collects/mzlib/contract.ss                | 17 ++++--
 collects/mzlib/private/contract-define.ss | 70 +++++++++++++++++++++++
 collects/mzlib/scribblings/contract.scrbl |  2 +-
 collects/scheme/contract.ss               |  1 -
 collects/scheme/private/contract.ss       | 63 --------------------
 5 files changed, 82 insertions(+), 71 deletions(-)
 create mode 100644 collects/mzlib/private/contract-define.ss

diff --git a/collects/mzlib/contract.ss b/collects/mzlib/contract.ss
index 373846be04..944fcd4808 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 0000000000..d1f3ea63ed
--- /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))]))
+
+
+
diff --git a/collects/mzlib/scribblings/contract.scrbl b/collects/mzlib/scribblings/contract.scrbl
index fd5922d366..b9385821e8 100644
--- a/collects/mzlib/scribblings/contract.scrbl
+++ b/collects/mzlib/scribblings/contract.scrbl
@@ -24,7 +24,7 @@
 
 @mzlib[#:mode title contract]
 
-The @schememodname[mzlib/list] library re-exports many bindings
+The @schememodname[mzlib/contract] library re-exports many bindings
 from @schememodname[scheme/contract]:
 
 @twocolumns[
diff --git a/collects/scheme/contract.ss b/collects/scheme/contract.ss
index 617fd07c81..ca55dbf472 100644
--- a/collects/scheme/contract.ss
+++ b/collects/scheme/contract.ss
@@ -27,7 +27,6 @@ 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))
 
diff --git a/collects/scheme/private/contract.ss b/collects/scheme/private/contract.ss
index 44d6268080..de41f43383 100644
--- a/collects/scheme/private/contract.ss
+++ b/collects/scheme/private/contract.ss
@@ -12,7 +12,6 @@ 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)
@@ -78,68 +77,6 @@ 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
-                        (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 (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.