added parameter/c

svn: r6770

collects/mzlib/private/contract.ss

@@ -825,7 +825,8 @@ improve method arity mismatch contract violation error messages?
 	   syntax/c
            
            check-between/c
-           check-unary-between/c)
+           check-unary-between/c
+           parameter/c)
   
   (define-syntax (flat-rec-contract stx)
     (syntax-case stx  ()
@@ -1976,4 +1977,44 @@ improve method arity mismatch contract violation error messages?
                    (and (predicate-id val)
                         (ctc-pred-x (selector-id val)) ...))))))))]
       [(_ struct-name anything ...)
-       (raise-syntax-error 'struct/c "expected a struct identifier" stx (syntax struct-name))])))
+       (raise-syntax-error 'struct/c "expected a struct identifier" stx (syntax struct-name))]))
+  
+  
+  (define (parameter/c x)
+    (make-parameter/c (coerce-contract 'parameter/c x)))
+  
+  (define-struct/prop parameter/c (ctc)
+    ((proj-prop (λ (ctc)
+                  (let ([c-proc ((proj-get (parameter/c-ctc ctc)) (parameter/c-ctc ctc))])
+                    (λ (pos-blame neg-blame src-info orig-str)
+                      (let ([partial-neg-contract (c-proc neg-blame pos-blame src-info orig-str)]
+                            [partial-pos-contract (c-proc neg-blame pos-blame src-info orig-str)])
+                        (λ (val)
+                          (cond
+                            [(parameter? val)
+                             (make-derived-parameter 
+                              val 
+                              #;partial-pos-contract
+                              partial-neg-contract)]
+                            [else
+                             (raise-contract-error val src-info pos-blame orig-str 
+                                                   "expected a parameter")])))))))
+     (name-prop (λ (ctc) (build-compound-type-name 'parameter/c (parameter/c-ctc ctc))))
+     (first-order-prop
+      (λ (ctc)
+        (let ([tst ((first-order-get (parameter/c-ctc ctc)) (parameter/c-ctc ctc))])
+          (λ (x)
+            (and (parameter? x)
+                 (tst (x)))))))
+     
+     (stronger-prop
+      (λ (this that)
+        ;; must be invariant (because the library doesn't currently split out pos/neg contracts
+        ;; which could be tested individually ....)
+        (and (parameter/c? that)
+             (contract-stronger? (parameter/c-ctc this) 
+                                 (parameter/c-ctc that))
+             (contract-stronger? (parameter/c-ctc that) 
+                                 (parameter/c-ctc this)))))))
+  
+  )

collects/tests/mzscheme/contract-test.ss

@@ -1539,6 +1539,19 @@
       x)
    (reverse '(1 3 4 2)))
 
+  (test/neg-blame
+   'parameter/c1
+   '((contract (parameter/c integer?)
+               (make-parameter 1)
+               'pos 'neg)
+     #f))
+  
+  (test/pos-blame
+   'parameter/c1
+   '((contract (parameter/c integer?)
+               (make-parameter 'not-an-int)
+               'pos 'neg)))
+  
   (test/spec-passed
    'define/contract1
    '(let ()
@@ -4398,6 +4411,8 @@ so that propagation occurs.
   (test-name '(cons-immutable/c (-> boolean? boolean?) (cons-immutable/c integer? null?))
              (list-immutable/c (-> boolean? boolean?) integer?))
   
+  (test-name '(parameter/c integer?) (parameter/c integer?))
+  
   (test-name '(box/c boolean?) (box/c boolean?))
   (test-name '(box/c boolean?) (box/c (flat-contract boolean?)))
   (test-name 'the-name (flat-rec-contract the-name))
@@ -4510,6 +4525,10 @@ so that propagation occurs.
   (ctest #t contract-stronger? number? number?)
   (ctest #f contract-stronger? boolean? number?)
     
+  (ctest #t contract-stronger? (parameter/c (between/c 0 5)) (parameter/c (between/c 0 5)))
+  (ctest #f contract-stronger? (parameter/c (between/c 0 5)) (parameter/c (between/c 1 4)))
+  (ctest #f contract-stronger? (parameter/c (between/c 1 4)) (parameter/c (between/c 0 5)))
+  
   (ctest #t contract-stronger? (symbols 'x 'y) (symbols 'x 'y 'z))
   (ctest #f contract-stronger? (symbols 'x 'y 'z) (symbols 'x 'y))
   (ctest #t contract-stronger? (symbols 'x 'y) (symbols 'z 'x 'y))