From e3678a937e4de35315ebf6facb0faee4c5e05146 Mon Sep 17 00:00:00 2001
From: Stevie Strickland <sstrickl@racket-lang.org>
Date: Fri, 14 May 2010 15:38:19 -0400
Subject: [PATCH] Change box-immutable/c to use box/c with #:immutable #t.

---
 collects/racket/contract/private/box.rkt | 83 +-----------------------
 collects/tests/racket/contract-test.rktl |  3 +
 2 files changed, 5 insertions(+), 81 deletions(-)

diff --git a/collects/racket/contract/private/box.rkt b/collects/racket/contract/private/box.rkt
index b52aaf9dae..4096af3616 100644
--- a/collects/racket/contract/private/box.rkt
+++ b/collects/racket/contract/private/box.rkt
@@ -6,87 +6,8 @@
 (provide box-immutable/c 
          (rename-out [wrap-box/c box/c]))
 
-(define-syntax (*-immutable/c stx)
-  (syntax-case stx ()
-    [(_ predicate? constructor (arb? selectors ...) type-name name)
-     #'(*-immutable/c predicate? constructor (arb? selectors ...) type-name name #t)]
-    [(_ predicate? constructor (arb? selectors ...) type-name name test-immutable?)
-     (and (eq? #f (syntax->datum (syntax arb?)))
-          (boolean? (syntax->datum #'test-immutable?)))
-     (let ([test-immutable? (syntax->datum #'test-immutable?)])
-       (with-syntax ([(params ...) (generate-temporaries (syntax (selectors ...)))]
-                     [(p-apps ...) (generate-temporaries (syntax (selectors ...)))]
-                     [(ctc-x ...) (generate-temporaries (syntax (selectors ...)))]
-                     [(procs ...) (generate-temporaries (syntax (selectors ...)))]
-                     [(selector-names ...) (generate-temporaries (syntax (selectors ...)))])
-         #`(let ([predicate?-name predicate?]
-                 [constructor-name constructor]
-                 [selector-names selectors] ...)
-             (λ (params ...)
-               (let ([ctc-x (coerce-contract 'name params)] ...)
-                 (if (and (flat-contract? ctc-x) ...)
-                     (let ([p-apps (flat-contract-predicate ctc-x)] ...)
-                       (build-flat-contract
-                        `(name ,(contract-name ctc-x) ...)
-                        (lambda (x)
-                          (and (predicate?-name x)
-                               (p-apps (selector-names x)) 
-                               ...))))
-                     (let ([procs (contract-projection ctc-x)] ...)
-                       (make-contract
-                        #:name (build-compound-type-name 'name ctc-x ...)
-                        #:projection
-                        (λ (blame)
-                          (let ([p-apps (procs blame)] ...)
-                            (λ (v)
-                              (if #,(if test-immutable?
-                                        #'(and (predicate?-name v)
-                                               (immutable? v))
-                                        #'(predicate?-name v))
-                                  (constructor-name (p-apps (selector-names v)) ...)
-                                  (raise-blame-error
-                                   blame
-                                   v
-                                   #,(if test-immutable?
-                                         "expected immutable <~a>, given: ~e"
-                                         "expected <~a>, given: ~e")
-                                   'type-name
-                                   v)))))))))))))]
-    [(_ predicate? constructor (arb? selector) correct-size type-name name)
-     (eq? #t (syntax->datum (syntax arb?)))
-     (syntax
-      (let ([predicate?-name predicate?]
-            [constructor-name constructor]
-            [selector-name selector])
-        (λ params
-          (let ([ctcs (map (λ (param) (coerce-contract 'name param)) params)])
-            (let ([procs (map contract-projection ctcs)])
-              (make-contract
-               #:name (apply build-compound-type-name 'name ctcs)
-               #:projection
-               (λ (blame)
-                 (let ([p-apps (map (λ (proc) (proc blame)) procs)]
-                       [count (length params)])
-                   (λ (v)
-                     (if (and (immutable? v)
-                              (predicate?-name v)
-                              (correct-size count v))
-                         (apply constructor-name 
-                                (let loop ([p-apps p-apps]
-                                           [i 0])
-                                  (cond
-                                    [(null? p-apps) null]
-                                    [else (let ([p-app (car p-apps)])
-                                            (cons (p-app (selector-name v i))
-                                                  (loop (cdr p-apps) (+ i 1))))])))
-                         (raise-blame-error
-                          blame
-                          v
-                          "expected <~a>, given: ~e"
-                          'type-name
-                          v)))))))))))]))
-
-(define box-immutable/c (*-immutable/c box? box-immutable (#f unbox) immutable-box box-immutable/c))
+(define/subexpression-pos-prop (box-immutable/c elem)
+  (build-box/c elem #:immutable #t))
 
 (define-struct box/c (content immutable))
 
diff --git a/collects/tests/racket/contract-test.rktl b/collects/tests/racket/contract-test.rktl
index fedd38fdcc..4e8ad1fc7b 100644
--- a/collects/tests/racket/contract-test.rktl
+++ b/collects/tests/racket/contract-test.rktl
@@ -10022,6 +10022,9 @@ so that propagation occurs.
   (test-obligations '(box/c a)
                     '((racket/contract:contract (box/c) ())
                       (racket/contract:positive-position a)))
+  (test-obligations '(box-immutable/c a)
+                    '((racket/contract:contract (box-immutable/c) ())
+                      (racket/contract:positive-position a)))
   
   
 ;