add a second argument to list*of

to control what the last piece of the list is more explicitly

pkgs/racket-doc/scribblings/reference/contracts.scrbl

@@ -469,13 +469,14 @@ a value, the result is not necessarily @racket[eq?] to the input.
                     (list)))]
 }
 
-@defproc[(list*of [c contract?]) contract?]{
+@defproc[(list*of [ele-c contract?] [last-c contract? ele-c]) contract?]{
 
 Returns a contract that recognizes improper lists whose elements match
-the contract @racket[c]. If an improper list is created with @racket[cons],
+the contract @racket[ele-c] and whose last position matches @racket[last-c].
-then its @racket[car] position is expected to match @racket[c] and
+If an improper list is created with @racket[cons],
-its @racket[cdr] position is expected to be @racket[(list*of c)]. Otherwise,
+then its @racket[car] position is expected to match @racket[ele-c] and
-it is expected to match @racket[c]. Beware that when this contract is applied to
+its @racket[cdr] position is expected to be @racket[(list*of ele-c list-c)]. Otherwise,
+it is expected to match @racket[last-c]. Beware that when this contract is applied to
 a value, the result is not necessarily @racket[eq?] to the input.
 
 @examples[#:eval (contract-eval) #:once
@@ -488,7 +489,8 @@ a value, the result is not necessarily @racket[eq?] to the input.
                     (list*of number?)
                     (list 1 2 3)))]
 
-@history[#:added "6.1.1.1"]
+@history[#:added "6.1.1.1"
+         #:changed "6.4.0.4" @list{Added the @racket[last-c] argument.}]
 }
 
 

pkgs/racket-test/tests/racket/contract/list-contract.rkt

@@ -56,6 +56,16 @@
    'list-contract-10b
    '(list-contract? (list*of any/c))
    #f)
+
+  (test/spec-passed/result
+   'list-contract-10c
+   '(list-contract? (list*of any/c boolean?))
+   #f)
+
+  (test/spec-passed/result
+   'list-contract-10d
+   '(list-contract? (list*of any/c null?))
+   #t)
   
   (test/spec-passed/result
    'list-contract-11

pkgs/racket-test/tests/racket/contract/list.rkt

@@ -64,6 +64,29 @@
   (test/pos-blame 
    'imlistof5
    '(contract (list*of integer?) (cons #f #t) 'pos 'neg))
+
+  (test/spec-passed/result 
+   'imlistof6
+   '(contract (list*of integer? char?) '(1 2 . #\3) 'pos 'neg)
+   '(1 2 . #\3))
+  (test/pos-blame
+   'imlistof7
+   '(contract (list*of integer? char?) '() 'pos 'neg))
+  (test/pos-blame 
+   'imlistof8
+   '(contract (list*of integer? char?) #f 'pos 'neg))
+  (test/pos-blame 
+   'imlistof9
+   '(contract (list*of integer? char?) (list 1 2) 'pos 'neg))
+  (test/pos-blame 
+   'imlistof10
+   '(contract (list*of integer? char?) (cons #f #t) 'pos 'neg))
+  (test/spec-passed
+   'imlistof11
+   '(contract (list*of (-> integer? integer?)
+                       (-> boolean? boolean? boolean?))
+              (cons (λ (x) x) (cons (λ (y) y) (λ (a b) a)))
+              'pos 'neg))   
   
   (test/pos-blame
    'cons/dc1

pkgs/racket-test/tests/racket/contract/name.rkt

@@ -273,6 +273,9 @@
   (test-name '(list*of boolean?) (list*of boolean?))
   (test-name '(list*of any/c) (list*of any/c))
   (test-name '(list*of (-> boolean? boolean?)) (list*of (-> boolean? boolean?)))
+  (test-name '(list*of boolean? char?) (list*of boolean? char?))
+  (test-name '(list*of any/c char?) (list*of any/c char?))
+  (test-name '(list*of (-> boolean? boolean?) char?) (list*of (-> boolean? boolean?) char?))
 
 
   (test-name '(vectorof boolean?) (vectorof boolean?))

pkgs/racket-test/tests/racket/contract/random-generate.rkt

@@ -76,6 +76,7 @@
 (check-not-exn (λ () (test-contract-generation (listof some-crazy-predicate?))))
 (check-not-exn (λ () (test-contract-generation (non-empty-listof boolean?))))
 (check-not-exn (λ () (test-contract-generation (list*of boolean?))))
+(check-not-exn (λ () (test-contract-generation (list*of boolean? char?))))
 (check-not-exn (λ () (test-contract-generation (list/c boolean? number?))))
 (check-not-exn (λ () ((car (test-contract-generation (list/c (-> number? number?)))) 0)))
 

pkgs/racket-test/tests/racket/contract/stronger.rkt

@@ -210,6 +210,14 @@
   (ctest #f contract-stronger? (listof number?) (cons/c number? (cons/c number? (listof any/c))))
   (ctest #t contract-stronger? (list*of (<=/c 2)) (list*of (<=/c 3)))
   (ctest #f contract-stronger? (list*of (<=/c 3)) (list*of (<=/c 2)))
+  (ctest #t contract-stronger? (list*of (<=/c 2) char?) (list*of (<=/c 3) char?))
+  (ctest #f contract-stronger? (list*of (<=/c 3) char?) (list*of (<=/c 2) char?))
+  (ctest #t contract-stronger? (list*of char? (<=/c 2)) (list*of char? (<=/c 3)))
+  (ctest #f contract-stronger? (list*of char? (<=/c 3)) (list*of char? (<=/c 2)))
+  (ctest #t contract-stronger? (list*of char? null?) (listof char?))
+  (ctest #t contract-stronger? (listof char?) (list*of char? null?))
+  (ctest #f contract-stronger? (list*of char? any/c) (listof char?))
+  
   
   (ctest #f contract-stronger? (vectorof (<=/c 3)) (vectorof (<=/c 4)))
   (ctest #f contract-stronger? (vectorof (<=/c 3)) (vectorof (<=/c 4)))

racket/collects/racket/contract/private/misc.rkt

@@ -524,29 +524,56 @@
      (λ (x) (not (pred x))))))
 
 (define (listof-generate ctc)
-  (λ (fuel)
+  (cond
-    (define eg (contract-random-generate/choose (listof-ctc-elem-c ctc) fuel))
+    [(im-listof-ctc? ctc)
-    (if eg
+     (λ (fuel)
-        (λ ()
+       (define middle-eg (contract-random-generate/choose (listof-ctc-elem-c ctc) fuel))
-          (let loop ([so-far (cond
+       (define last-eg (contract-random-generate/choose (im-listof-ctc-last-c ctc) fuel))
-                               [(pe-listof-ctc? ctc)
+       (cond
-                                '()]
+         [(and last-eg middle-eg)
-                               [(ne-listof-ctc? ctc)
+          (λ ()
-                                (list (eg))]
+            (let loop ([so-far (last-eg)])
-                               [else
+              (rand-choice
-                                ;; improper list
+               [1/5 so-far]
-                                (eg)])])
+               [else (loop (cons (middle-eg) so-far))])))]
-            (rand-choice
+         [last-eg
-             [1/5 so-far]
+          (λ ()
-             [else (loop (cons (eg) so-far))])))
+            (last-eg))]
-        (if (pe-listof-ctc? ctc)
+         [else #f]))]
-            (λ () '())
+    [else
-            #f))))
+     (λ (fuel)
+       (define eg (contract-random-generate/choose (listof-ctc-elem-c ctc) fuel))
+       (if eg
+           (λ ()
+             (let loop ([so-far (cond
+                                  [(pe-listof-ctc? ctc)
+                                   '()]
+                                  [(ne-listof-ctc? ctc)
+                                   (list (eg))])])
+               (rand-choice
+                [1/5 so-far]
+                [else (loop (cons (eg) so-far))])))
+           (if (pe-listof-ctc? ctc)
+               (λ () '())
+               #f)))]))
 
 (define (listof-exercise ctc) 
   (cond
     [(pe-listof-ctc? ctc)
      (λ (fuel) (values void '()))]
+    [(im-listof-ctc? ctc)
+     (define last-ctc (im-listof-ctc-last-c ctc))
+     (λ (fuel)
+       (define env (contract-random-generate-get-current-environment))
+       (values
+        (λ (lst)
+          (contract-random-generate-stash
+           env last-ctc 
+           (let loop ([lst lst])
+             (cond
+               [(pair? lst) (loop (cdr lst))]
+               [else lst]))))
+        (list last-ctc)))]
     [else
      (define elem-ctc (listof-ctc-elem-c ctc))
      (λ (fuel)
@@ -555,10 +582,7 @@
         (λ (lst)
           (contract-random-generate-stash
            env elem-ctc 
-           (oneof
+           (oneof lst)))
-            (if (im-listof-ctc? ctc)
-                (improper-list->list lst)
-                lst))))
         (list elem-ctc)))]))
 
 (define (improper-list->list l)
@@ -571,11 +595,15 @@
   (cond
     [(listof-ctc? that)
      (define that-elem (listof-ctc-elem-c that))
-     (and (cond
+     (cond
-            [(pe-listof-ctc? this) (pe-listof-ctc? that)]
+       [(pe-listof-ctc? this) (and (pe-listof-ctc? that)
-            [(im-listof-ctc? this) (im-listof-ctc? that)]
+                                   (contract-struct-stronger? this-elem that-elem))]
-            [else #t])
+       [(im-listof-ctc? this)
-          (contract-struct-stronger? this-elem that-elem))]
+        (and (im-listof-ctc? that)
+             (contract-struct-stronger? this-elem that-elem)
+             (contract-struct-stronger? (im-listof-ctc-last-c this)
+                                        (im-listof-ctc-last-c that)))]
+       [else (contract-struct-stronger? this-elem that-elem)])]
     [(the-cons/c? that)
      (define hd-ctc (the-cons/c-hd-ctc that))
      (define tl-ctc (the-cons/c-tl-ctc that))
@@ -596,14 +624,19 @@
 (define (non-empty-list? x) (and (pair? x) (list? x)))
 
 (define (list-name ctc)
-  (build-compound-type-name (cond
+  (cond
-                              [(pe-listof-ctc? ctc)
+    [(pe-listof-ctc? ctc)
-                               'listof]
+     (build-compound-type-name 'listof (listof-ctc-elem-c ctc))]
-                              [(ne-listof-ctc? ctc)
+    [(ne-listof-ctc? ctc)
-                               'non-empty-listof]
+     (build-compound-type-name 'non-empty-listof (listof-ctc-elem-c ctc))]
-                              [(im-listof-ctc? ctc)
+    [(im-listof-ctc? ctc)
-                               'list*of])
+     (define elem-name (contract-name (listof-ctc-elem-c ctc)))
-                            (listof-ctc-elem-c ctc)))
+     (define last-name (contract-name (im-listof-ctc-last-c ctc)))
+     (cond
+       [(equal? elem-name last-name)
+        `(list*of ,elem-name)]
+       [else
+        `(list*of ,elem-name ,last-name)])]))
 
 (define (list-fo-check ctc)
   (define elem-fo? (contract-first-order (listof-ctc-elem-c ctc)))
@@ -620,6 +653,7 @@
             (for/and ([e (in-list v)])
               (elem-fo? e))))]
     [(im-listof-ctc? ctc)
+     (define last-fo? (contract-first-order (im-listof-ctc-last-c ctc)))
      (λ (v)
        (let loop ([v v])
          (cond
@@ -627,50 +661,59 @@
             (and (elem-fo? (car v))
                  (loop (cdr v)))]
            [else
-            (elem-fo? v)])))]))
+            (last-fo? v)])))]))
 
 (define (listof-late-neg-projection ctc)
   (define elem-proj (get/build-late-neg-projection (listof-ctc-elem-c ctc)))
   (define pred? (if (pe-listof-ctc? ctc)
                     list?
                     non-empty-list?))
+  (define last-proj (and (im-listof-ctc? ctc)
+                         (get/build-late-neg-projection (im-listof-ctc-last-c ctc))))
   (λ (blame)
-    (define elem-proj+blame (elem-proj (blame-add-listof-context blame)))
+    (define lo-blame (blame-add-listof-context blame))
+    (define elem-proj+blame (elem-proj lo-blame))
     (cond
       [(flat-listof-ctc? ctc)
-       (if (im-listof-ctc? ctc)
+       (cond
-           (λ (val neg-party)
+         [(im-listof-ctc? ctc)
-             (let loop ([val val])
+          (define last-elem-proj+blame (last-proj lo-blame))
-               (cond
+          (λ (val neg-party)
-                 [(pair? val)
+            (let loop ([val val])
-                  (elem-proj+blame (car val) neg-party)
+              (cond
-                  (loop (cdr val))]
+                [(pair? val)
-                 [else 
+                 (elem-proj+blame (car val) neg-party)
-                  (elem-proj+blame val neg-party)]))
+                 (loop (cdr val))]
-             val)
+                [else 
-           (λ (val neg-party)
+                 (last-elem-proj+blame val neg-party)]))
-             (cond
+            val)]
-               [(pred? val)
+         [else
-                (for ([x (in-list val)])
+          (λ (val neg-party)
-                  (elem-proj+blame x neg-party))
+            (cond
-                val]
+              [(pred? val)
-               [else
+               (for ([x (in-list val)])
-                (raise-listof-blame-error blame val (pe-listof-ctc? ctc) neg-party)])))]
+                 (elem-proj+blame x neg-party))
+               val]
+              [else
+               (raise-listof-blame-error blame val (pe-listof-ctc? ctc) neg-party)]))])]
       [else
-       (if (im-listof-ctc? ctc)
+       (cond
-           (λ (val neg-party)
+         [(im-listof-ctc? ctc)
-             (let loop ([val val])
+          (define last-elem-proj+blame (last-proj lo-blame))
-               (cond
+          (λ (val neg-party)
-                 [(pair? val)
+            (let loop ([val val])
-                  (cons (elem-proj+blame (car val) neg-party)
+              (cond
-                        (loop (cdr val)))]
+                [(pair? val)
-                 [else 
+                 (cons (elem-proj+blame (car val) neg-party)
-                  (elem-proj+blame val neg-party)])))
+                       (loop (cdr val)))]
-           (λ (val neg-party)
+                [else 
-             (if (pred? val)
+                 (last-elem-proj+blame val neg-party)])))]
-                 (for/list ([x (in-list val)])
+         [else
-                   (elem-proj+blame x neg-party))
+          (λ (val neg-party)
-                 (raise-listof-blame-error blame val (pe-listof-ctc? ctc) neg-party))))])))
+            (if (pred? val)
+                (for/list ([x (in-list val)])
+                  (elem-proj+blame x neg-party))
+                (raise-listof-blame-error blame val (pe-listof-ctc? ctc) neg-party)))])])))
 
 (define flat-prop
   (build-flat-contract-property
@@ -735,7 +778,7 @@
   #:property prop:contract full-prop)
 
 ;; improper lists
-(struct im-listof-ctc listof-ctc ())
+(struct im-listof-ctc listof-ctc (last-c))
 
 ;; improper, flat
 (struct imf-listof-ctc im-listof-ctc ()
@@ -777,12 +820,16 @@
     [(flat-contract? c) (pef-listof-ctc c)]
     [(chaperone-contract? c) (pec-listof-ctc c)]
     [else (pei-listof-ctc c)]))
-(define/subexpression-pos-prop (list*of raw-c)
+(define/subexpression-pos-prop (list*of raw-ele-c [raw-last-c raw-ele-c])
-  (define c (coerce-contract 'list*of raw-c))
+  (define ele-c (coerce-contract 'list*of raw-ele-c))
+  (define last-c (coerce-contract 'list*of raw-last-c))
   (cond
-    [(flat-contract? c) (imf-listof-ctc c)]
+    [(and (generic-list/c? last-c)
-    [(chaperone-contract? c) (imc-listof-ctc c)]
+          (null? (generic-list/c-args last-c)))
-    [else (imi-listof-ctc c)]))
+     (listof ele-c)]
+    [(and (flat-contract? ele-c) (flat-contract? last-c)) (imf-listof-ctc ele-c last-c)]
+    [(and (chaperone-contract? ele-c) (chaperone-contract? last-c)) (imc-listof-ctc ele-c last-c)]
+    [else (imi-listof-ctc ele-c last-c)]))
 
 
 (define (blame-add-car-context blame) (blame-add-context blame "the car of"))