..

original commit: 0e9ff6840c15084a7f262a474d011b9010790974

collects/mzlib/contract.ss

@@ -591,9 +591,7 @@
                         pos-blame
                         a-contract-raw
                         name))
-               ;((a-contract pos-blame neg-blame src-info) name)
+               (((contract-proc a-contract) pos-blame neg-blame src-info) name))))])))
-               (((contract-proc a-contract) pos-blame neg-blame src-info) name)
-               )))])))
   
   ;; raise-contract-error : (union syntax #f) symbol symbol string args ... -> alpha
   ;; doesn't return
@@ -1570,7 +1568,7 @@
                   [else (cons (- n i)
                               (loop (- i 1)))]))))))
 
-  ;; coerce/select-contract : (union contract? procedure-arity-1) -> contract-proc
+  ;; coerce/select-contract : id (union contract? procedure-arity-1) -> contract-proc
   ;; contract-proc = sym sym stx -> alpha -> alpha
   ;; returns the procedure for the contract after extracting it from the
   ;; struct. Coerces the argument to a flat contract if it is procedure, but first.
@@ -1653,8 +1651,10 @@
 	   printable?
            symbols
 	   is-a?/c subclass?/c implementation?/c
-           listof vectorof
+           listof list-immutableof 
-	   vector/p cons/p list/p box/p
+           vectorof vector-immutableof vector/p vector-immutable/c 
+           cons-immutable/c cons/p list-immutable/c list/p 
+           box-immutable/c box/p
 	   mixin-contract make-mixin-contract)
   
   (define (union . args)
@@ -1877,6 +1877,53 @@
 	    (andmap (lambda (ele) (test-flat-contract p ele))
 		    v)))))
   
+  (define-syntax (*-immutableof stx)
+    (syntax-case stx ()
+      [(_ predicate? fill type-name name)
+       (syntax
+        (let ([predicate?-name predicate?]
+              [fill-name fill])
+          (lambda (_p)
+            (let ([p (coerce/select-contract name _p)])
+              (make-contract
+               (lambda (pos neg src-info)
+                 (let ([p-app (p pos neg src-info)])
+                   (lambda (val)
+                     (unless (predicate?-name val)
+                       (raise-contract-error
+                        src-info
+                        pos
+                        neg
+                        "expected <~a>, given: ~e"
+                        'type-name
+                        val))
+                     (fill-name p-app val)))))))))]))
+  
+  (define (map-immutable f lst)
+    (let loop ([lst lst])
+      (cond
+        [(pair? lst)
+         (cons-immutable (f (car lst))
+                         (loop (cdr lst)))]
+        [(null? lst) null])))
+  
+  (define (immutable-list? lst)
+    (cond
+      [(and (pair? lst)
+            (immutable? lst))
+       (immutable-list? (cdr lst))]
+      [(null? lst) #t]
+      [else #f]))
+  
+  (define list-immutableof
+    (*-immutableof immutable-list? map-immutable immutable-list list-immutableof))  
+
+  (define vector-immutableof
+    (*-immutableof (lambda (x) (and (vector? x) (immutable? x)))
+                   (lambda (f v) (vector->immutable-vector (list->vector (map f (vector->list v)))))
+                   immutable-vector
+                   vector-immutableof))
+  
   (define (vectorof p)
     (unless (flat-contract/predicate? p)
       (error 'vectorof "expected a flat contract or procedure of arity 1 as argument, got: ~e" p))
@@ -1919,7 +1966,7 @@
   (define (cons/p hdp tlp)
     (unless (and (flat-contract/predicate? hdp)
                  (flat-contract/predicate? tlp))
-      (error 'cons/p "expected two flat contracts, got: ~e and ~e" hdp tlp))
+      (error 'cons/p "expected two flat contracts or procedures of arity 1, got: ~e and ~e" hdp tlp))
     (flat-named-contract
      (build-compound-type-name "cons/p" hdp tlp)
      (lambda (x)
@@ -1927,6 +1974,75 @@
             (test-flat-contract hdp (car x))
             (test-flat-contract tlp (cdr x))))))
   
+  (define-syntax (*-immutable/c stx)
+    (syntax-case stx ()
+      [(_ predicate? constructor (arb? selectors ...) type-name name)
+       (eq? #f (syntax-object->datum (syntax arb?)))
+       (with-syntax ([(params ...) (generate-temporaries (syntax (selectors ...)))]
+                     [(p-apps ...) (generate-temporaries (syntax (selectors ...)))]
+                     [(procs ...) (generate-temporaries (syntax (selectors ...)))]
+                     [(selector-names ...) (generate-temporaries (syntax (selectors ...)))])
+         (syntax
+          (let ([predicate?-name predicate?]
+                [constructor-name constructor]
+                [selector-names selectors] ...)
+            (lambda (params ...)
+              (let ([procs (coerce/select-contract name params)] ...)
+                (make-contract
+                 (lambda (pos neg src-info)
+                   (let ([p-apps (procs pos neg src-info)] ...)
+                     (lambda (v)
+                       (if (and (immutable? v)
+                                (predicate?-name v))
+                           (constructor-name (p-apps (selector-names v)) ...)
+                           (raise-contract-error
+                            src-info
+                            pos
+                            neg
+                            "expected <~a>, given: ~e"
+                            'type-name
+                            v)))))))))))]
+      [(_ predicate? constructor (arb? selector) correct-size type-name name)
+       (eq? #t (syntax-object->datum (syntax arb?)))
+       (syntax
+        (let ([predicate?-name predicate?]
+              [constructor-name constructor]
+              [selector-name selector])
+          (lambda params
+            (let ([procs (map (lambda (param) (coerce/select-contract name param)) params)])
+              (make-contract
+               (lambda (pos neg src-info)
+                 (let ([p-apps (map (lambda (proc) (proc pos neg src-info)) procs)]
+                       [count (length params)])
+                   (lambda (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-contract-error
+                          src-info
+                          pos
+                          neg
+                          "expected <~a>, given: ~e"
+                          'type-name
+                          v))))))))))]))
+  
+  (define cons-immutable/c (*-immutable/c pair? cons (#f car cdr) immutable-cons cons-immutable/c))
+  (define box-immutable/c (*-immutable/c box? box (#f unbox) immutable-box box-immutable/c))
+  (define vector-immutable/c (*-immutable/c vector?
+                                            vector
+                                            (#t (lambda (v i) (vector-ref v i)))
+                                            (lambda (n v) (= n (vector-length v)))
+                                            immutable-vector
+                                            vector-immutable/c))
+       
   (define (list/p . args)
     (unless (andmap flat-contract/predicate? args)
       (error 'list/p "expected flat contracts, got: ~a"
@@ -1939,9 +2055,27 @@
                         (loop (cdr args)))]))))
     (let loop ([args args])
       (cond
-	[(null? args) null?]
+	[(null? args) (flat-contract null?)]
 	[else (cons/p (car args) (loop (cdr args)))])))
   
+  (define (list-immutable/c . args)
+    (unless (andmap (lambda (x) (or (contract? x)
+                                    (and (procedure? x)
+                                         (procedure-arity-includes? x 1))))
+                    args)
+      (error 'list/p "expected flat contracts or procedures of arity 1, got: ~a"
+             (let loop ([args args]) 
+               (cond
+                 [(null? args) ""]
+                 [(null? (cdr args)) (format "~e" (car args))]
+                 [else (string-append
+                        (format "~e " (car args))
+                        (loop (cdr args)))]))))
+    (let loop ([args args])
+      (cond
+	[(null? args) (flat-contract null?)]
+	[else (cons-immutable/c (car args) (loop (cdr args)))])))
+
   (define (syntax/p c)
     (unless (flat-contract/predicate? c)
       (error 'syntax/p "expected argument of type <flat-contract> or procedure of arity 1, got ~e" c))

collects/tests/mzscheme/contract-test.ss

@@ -22,6 +22,7 @@
   
   ;; test/spec-failed : symbol sexp string -> void
   ;; tests a failing specification with blame assigned to `blame'
+  #;
   (define (test/spec-failed name expression blame)
     (define (ensure-contract-failed x)
       (let ([result (with-handlers ([(lambda (x) (and (not-break-exn? x) (exn? x)))
@@ -39,6 +40,22 @@
           ensure-contract-failed
           expression))
   
+  (define (test/spec-failed name expression blame)
+    (define (has-proper-blame? msg)
+      (equal?
+       blame
+       (cond
+         [(regexp-match ": ([^ ]*) broke" msg) => cadr]
+         [(regexp-match "([^ ]+): .* does not imply" msg) => cadr]
+         [else (format "no blame in error message: \"~a\"" msg)])))
+    (printf "testing: ~s\n" name)
+    (thunk-error-test 
+     (lambda () (eval expression))
+     (datum->syntax-object #'here expression)
+     (lambda (exn)
+       (and (exn? exn)
+            (has-good-blame? (exn-message exn))))))
+  
   (define (test/well-formed stx)
     (test (void) 
           (let ([expand/ret-void (lambda (x) (expand x) (void))]) expand/ret-void)
@@ -96,6 +113,7 @@
   (test/no-error '(opt->* ((flat-contract integer?)) ((flat-contract integer?)) ((flat-contract integer?))))
   
   (test/no-error '(listof any?))
+  (test/no-error '(listof (lambda (x) #t)))
   
   (test/spec-passed
    'contract-arrow-star0a
@@ -873,6 +891,309 @@
    "c-neg")  
 |#
 
+  (test/spec-failed
+   'immutable1
+   '(let ([ct (contract (list-immutableof (boolean? . -> . boolean?)) 
+                        #f 
+                        'pos
+                        'neg)])
+      ((car ct) 1))
+   "pos")
+  
+  (test/spec-failed
+   'immutable2
+   '(let ([ct (contract (list-immutableof (boolean? . -> . boolean?)) 
+                        (list (lambda (x) x)) 
+                        'pos
+                        'neg)])
+      ((car ct) 1))
+   "pos")
+  
+  (test/spec-failed
+   'immutable3
+   '(let ([ct (contract (list-immutableof (number? . -> . boolean?)) 
+                        (list-immutable (lambda (x) 1)) 
+                        'pos
+                        'neg)])
+      ((car ct) #f))
+   "neg")
+  
+  (test/spec-failed
+   'immutable4
+   '(let ([ct (contract (list-immutableof (number? . -> . boolean?)) 
+                        (list-immutable (lambda (x) 1)) 
+                        'pos
+                        'neg)])
+      ((car ct) 1))
+   "pos")
+  
+  (test/spec-passed
+   'immutable5
+   '(let ([ct (contract (list-immutableof (number? . -> . boolean?)) 
+                        (list-immutable (lambda (x) #t)) 
+                        'pos
+                        'neg)])
+      ((car ct) 1)))
+  
+
+  (test/spec-failed
+   'immutable6
+   '(contract (cons-immutable/c (boolean? . -> . boolean?) (boolean? . -> . boolean?)) 
+              #f 
+              'pos
+              'neg)
+   "pos")
+  
+  (test/spec-failed
+   'immutable7
+   '(contract (cons-immutable/c (boolean? . -> . boolean?) (boolean? . -> . boolean?)) 
+              (cons (lambda (x) x) (lambda (x) x))
+              'pos
+              'neg)
+   "pos")
+  
+  (test/spec-failed
+   'immutable8
+   '(let ([ct (contract (cons-immutable/c (number? . -> . boolean?) (number? . -> . boolean?)) 
+                        (cons-immutable (lambda (x) 1) (lambda (x) 1))
+                        'pos
+                        'neg)])
+      ((car ct) #f))
+   "neg")
+  
+  (test/spec-failed
+   'immutable9
+   '(let ([ct (contract (cons-immutable/c (number? . -> . boolean?) (number? . -> . boolean?)) 
+                        (cons-immutable (lambda (x) 1) (lambda (x) 1))
+                        'pos
+                        'neg)])
+      ((cdr ct) #f))
+   "neg")
+  
+  (test/spec-failed
+   'immutable10
+   '(let ([ct (contract (cons-immutable/c (number? . -> . boolean?) (number? . -> . boolean?)) 
+                        (cons-immutable (lambda (x) 1) (lambda (x) 1)) 
+                        'pos
+                        'neg)])
+      ((car ct) 1))
+   "pos")
+  
+  (test/spec-failed
+   'immutable11
+   '(let ([ct (contract (cons-immutable/c (number? . -> . boolean?) (number? . -> . boolean?)) 
+                        (cons-immutable (lambda (x) 1) (lambda (x) 1)) 
+                        'pos
+                        'neg)])
+      ((cdr ct) 1))
+   "pos")
+  
+  (test/spec-passed
+   'immutable12
+   '(let ([ct (contract (cons-immutable/c (number? . -> . boolean?) (number? . -> . boolean?)) 
+                        (cons-immutable (lambda (x) #t) (lambda (x) #t)) 
+                        'pos
+                        'neg)])
+      ((car ct) 1)))
+  
+  (test/spec-passed
+   'immutable13
+   '(let ([ct (contract (cons-immutable/c (number? . -> . boolean?) (number? . -> . boolean?)) 
+                        (cons-immutable (lambda (x) #t) (lambda (x) #t)) 
+                        'pos
+                        'neg)])
+      ((cdr ct) 1)))
+  
+  (test/spec-passed/result
+   'immutable14
+   '(contract (cons-immutable/c number? boolean?) 
+              (cons-immutable 1 #t) 
+              'pos
+              'neg)
+   (cons-immutable 1 #t))
+  
+  (test/spec-failed
+   'immutable15
+   '(contract (list-immutable/c (number? . -> . boolean?) (number? . -> . boolean?)) 
+              #f
+              'pos
+              'neg)
+   "pos")
+  
+  (test/spec-failed
+   'immutable16
+   '(contract (list-immutable/c (number? . -> . boolean?) (number? . -> . boolean?)) 
+              (list (lambda (x) #t) (lambda (x) #t)) 
+              'pos
+              'neg)
+   "pos")
+  
+  (test/spec-failed
+   'immutable17
+   '(contract (list-immutable/c (number? . -> . boolean?) (number? . -> . boolean?)) 
+              (list-immutable (lambda (x) #t)) 
+              'pos
+              'neg)
+   "pos")
+  
+  (test/spec-failed
+   'immutable18
+   '(contract (list-immutable/c (number? . -> . boolean?) (number? . -> . boolean?)) 
+              (list-immutable (lambda (x) #t) (lambda (x) #t) (lambda (x) #t)) 
+              'pos
+              'neg)
+   "pos")
+  
+  (test/spec-passed
+   'immutable19
+   '(let ([ctc (contract (list-immutable/c (number? . -> . boolean?) (number? . -> . boolean?)) 
+                         (list-immutable (lambda (x) #t) (lambda (x) #t)) 
+                         'pos
+                         'neg)])
+      (for-each (lambda (x) (x 1)) ctc)))
+
+  (test/spec-failed
+   'vector-immutable1
+   '(contract (vector-immutableof (boolean? . -> . boolean?)) 
+              #f 
+              'pos
+              'neg)
+   "pos")
+  
+  (test/spec-failed
+   'vector-immutable2
+   '(contract (vector-immutableof (boolean? . -> . boolean?)) 
+              (vector (lambda (x) x)) 
+              'pos
+              'neg)
+   "pos")
+  
+  (test/spec-failed
+   'vector-immutable3
+   '(let ([ct (contract (vector-immutableof (number? . -> . boolean?)) 
+                        (vector->immutable-vector (vector (lambda (x) 1)))
+                        'pos
+                        'neg)])
+      ((vector-ref ct 0) #f))
+   "neg")
+  
+  (test/spec-failed
+   'vector-immutable4
+   '(let ([ct (contract (vector-immutableof (number? . -> . boolean?)) 
+                        (vector->immutable-vector (vector (lambda (x) 1)))
+                        'pos
+                        'neg)])
+      ((vector-ref ct 0) 1))
+   "pos")
+  
+  (test/spec-passed
+   'vector-immutable5
+   '(let ([ct (contract (vector-immutableof (number? . -> . boolean?)) 
+                        (vector->immutable-vector (vector (lambda (x) #t)))
+                        'pos
+                        'neg)])
+      ((vector-ref ct 0) 1)))
+  
+  (test/spec-failed
+   'vector-immutable6
+   '(contract (vector-immutable/c (number? . -> . boolean?) (number? . -> . boolean?)) 
+              #f
+              'pos
+              'neg)
+   "pos")
+  
+  (test/spec-failed
+   'vector-immutable7
+   '(contract (vector-immutable/c (number? . -> . boolean?) (number? . -> . boolean?)) 
+              (vector (lambda (x) #t) (lambda (x) #t)) 
+              'pos
+              'neg)
+   "pos")
+  
+  (test/spec-failed
+   'vector-immutable8
+   '(contract (vector-immutable/c (number? . -> . boolean?) (number? . -> . boolean?)) 
+              (vector->immutable-vector (vector (lambda (x) #t)))
+              'pos
+              'neg)
+   "pos")
+  
+  (test/spec-failed
+   'vector-immutable9
+   '(contract (vector-immutable/c (number? . -> . boolean?) (number? . -> . boolean?)) 
+              (vector->immutable-vector (vector (lambda (x) #t) (lambda (x) #t) (lambda (x) #t)))
+              'pos
+              'neg)
+   "pos")
+  
+  (test/spec-passed
+   'vector-immutable10
+   '(let ([ctc (contract (vector-immutable/c (number? . -> . boolean?) (number? . -> . boolean?)) 
+                         (vector->immutable-vector (vector (lambda (x) #t) (lambda (x) #t))) 
+                         'pos
+                         'neg)])
+      ((vector-ref ctc 0) 1)
+      ((vector-ref ctc 1) 1)))
+
+  (test/spec-passed/result
+   'vector-immutable11
+   '(contract (vector-immutable/c number? boolean?) 
+              (vector->immutable-vector (vector 1 #t))
+              'pos
+              'neg)
+   (vector->immutable-vector (vector 1 #t)))
+
+  (test/spec-failed
+   'box-immutable1
+   '(contract (box-immutable/c (number? . -> . boolean?)) 
+              #f
+              'pos
+              'neg)
+   "pos")
+  
+  (test/spec-failed
+   'box-immutable2
+   '(contract (box-immutable/c (number? . -> . boolean?)) 
+              (box (lambda (x) #t)) 
+              'pos
+              'neg)
+   "pos")
+  
+  (test/spec-failed
+   'box-immutable3
+   '(let ([ctc (contract (box-immutable/c (number? . -> . boolean?)) 
+                         (box-immutable (lambda (x) #t))
+                         'pos
+                         'neg)])
+      ((unbox ctc) #f))
+   "neg")
+  
+  (test/spec-failed
+   'box-immutable4
+   '(let ([ctc (contract (box-immutable/c (number? . -> . boolean?)) 
+                         (box-immutable (lambda (x) 1))
+                         'pos
+                         'neg)])
+      ((unbox ctc) 1))
+   "pos")
+  
+  (test/spec-passed
+   'box-immutable5
+   '(let ([ctc (contract (box-immutable/c (number? . -> . boolean?)) 
+                         (box-immutable (lambda (x) #t))
+                         'pos
+                         'neg)])
+      ((unbox ctc) 1)))
+
+  (test/spec-passed/result
+   'vector-immutable6
+   '(contract (box-immutable/c boolean?) 
+              (box-immutable #t)
+              'pos
+              'neg)
+   (box-immutable #t))
+
+  
   ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
   ;;                                                        ;;
   ;;   Flat Contract Tests                                  ;;
@@ -922,15 +1243,32 @@
   
   (test-flat-contract '(listof boolean?) (list #t #f) (list #f 3 #t))
   (test-flat-contract '(listof any?) (list #t #f) 3)
+  ;(test-flat-contract '(list-immutableof boolean?) (list-immutable #t #f) (list-immutable #f 3 #t))
+  ;(test-flat-contract '(list-immutableof any?) (list-immutable #t #f) 3)
+  ;(test-flat-contract '(list-immutableof boolean?) (list-immutable) (list))
+  ;(test-flat-contract '(list-immutableof (-> boolean? boolean?)) (list-immutable (lambda (x) x)) (list (lambda (x) x)))
+  
   (test-flat-contract '(vectorof boolean?) (vector #t #f) (vector #f 3 #t))
   (test-flat-contract '(vectorof any?) (vector #t #f) 3)
   
   (test-flat-contract '(vector/p boolean? (flat-contract integer?)) (vector #t 1) (vector 1 #f))
   (test-flat-contract '(vector/p boolean? (flat-contract integer?)) (vector #t 1) #f)
+
   (test-flat-contract '(cons/p boolean? (flat-contract integer?)) (cons #t 1) (cons 1 #f))
   (test-flat-contract '(cons/p boolean? (flat-contract integer?)) (cons #t 1) #f)
   (test-flat-contract '(list/p boolean? (flat-contract integer?)) (list #t 1) (list 1 #f))
   (test-flat-contract '(list/p boolean? (flat-contract integer?)) (list #t 1) #f)
+
+  ;(test-flat-contract '(cons-immutable/c boolean? (flat-contract integer?)) (cons-immutable #t 1) (cons-immutable 1 #f))
+  ;(test-flat-contract '(cons-immutable/c boolean? (flat-contract integer?)) (cons-immutable #t 1) #f)
+  ;(test-flat-contract '(cons-immutable/c boolean? (flat-contract integer?)) (cons-immutable #t 1) (cons #t 1))
+  ;(test-flat-contract '(cons-immutable/c (-> boolean? boolean?) integer?) (cons-immutable (lambda (x) x) 1) #f)
+  
+  ;(test-flat-contract '(list-immutable/c boolean? (flat-contract integer?)) (list-immutable #t 1) (list-immutable 1 #f))
+  ;(test-flat-contract '(list-immutable/c boolean? (flat-contract integer?)) (list-immutable #t 1) #f)
+  ;(test-flat-contract '(list-immutable/c boolean? (flat-contract integer?)) (list-immutable #t 1) (list #t 1))
+  ;(test-flat-contract '(list-immutable/c (-> boolean? boolean?) integer?) (list-immutable (lambda (x) x) 1) #f)
+  
   (test-flat-contract '(box/p boolean?) (box #f) (box 1))
   (test-flat-contract '(box/p (flat-contract boolean?)) (box #t) #f)