Added mutable lists to Typed Scheme.

collects/typed-scheme/private/base-env.rkt

@@ -889,8 +889,20 @@
 		     ((a b . -> . c) . -> . (a . -> . (b . -> . c)))))]
 ;; mutable pairs
 [mcons (-poly (a b) (-> a b (-mpair a b)))]
-[mcar (-poly (a b) (-> (-mpair a b) a))]
+[mcar (-poly (a b)
-[mcdr (-poly (a b) (-> (-mpair a b) b))]
+             (cl->* (-> (-mpair a b) a)
-[set-mcar! (-poly (a b) (-> (-mpair a b) a -Void))]
+                    (-> (-mlst a) a)))]
-[set-mcdr! (-poly (a b) (-> (-mpair a b) b -Void))]
+[mcdr (-poly (a b)
+             (cl->* (-> (-mpair a b) b)
+                    (-> (-mlst a) (-mlst a))))]
+[set-mcar! (-poly (a b)
+                  (cl->* (-> (-mpair a b) a -Void)
+                         (-> (-mlst a) a -Void)))]
+[set-mcdr! (-poly (a b)
+                  (cl->* (-> (-mpair a b) b -Void)
+                         (-> (-mlst a) (-mlst a) -Void)))]
 [mpair? (make-pred-ty (make-MPairTop))]
+[mlist (-poly (a) (->* (list) a (-mlst a)))]
+[mlength (-poly (a) (-> (-mlst a) -Nat))]
+[mreverse! (-poly (a) (-> (-mlst a) (-mlst a)))]
+[mappend (-poly (a) (->* (list) (-mlst a) (-mlst a)))]

collects/typed-scheme/private/base-types-new.rkt

@@ -55,5 +55,6 @@
 [Nothing (Un)]
 [Pairof (-poly (a b) (-pair a b))]
 [MPairof (-poly (a b) (-mpair a b))]
+[MListof (-poly (a) (-mlst a))]
 [Sequenceof (-poly (a) (-seq a))]
 

collects/typed-scheme/types/abbrev.rkt

@@ -15,7 +15,8 @@
 	 (for-template scheme/base scheme/contract scheme/promise scheme/tcp scheme/flonum))
 
 (provide (all-defined-out)
-         (rename-out [make-Listof -lst]))
+         (rename-out [make-Listof -lst]
+                     [make-MListof -mlst]))
 
 ;; convenient constructors
 
@@ -36,6 +37,7 @@
 
 
 (define (make-Listof elem) (-mu list-rec (*Un (-val null) (-pair elem list-rec))))
+(define (make-MListof elem) (-mu mlist-rec (*Un (-val null) (-mpair elem mlist-rec))))
 
 (define (-lst* #:tail [tail (-val null)] . args)
   (for/fold ([tl tail]) ([a (reverse args)]) (-pair a tl)))
@@ -62,6 +64,12 @@
       [(_ elem-pats)
        #'(app untuple (? values elem-pats))])))
 
+(define-match-expander MListof:
+  (lambda (stx)
+    (syntax-parse stx
+      [(_ elem-pat)
+       #'(Mu: var (Union: (list (Value: '()) (MPair: elem-pat (F: var)))))])))
+
 
 (d/c (-result t [f -no-filter] [o -no-obj])
   (c:->* (Type/c) (FilterSet? Object?) Result?)

collects/typed-scheme/types/convenience.rkt

@@ -35,9 +35,14 @@
 	[(Value: 0) -Nat]
         [(Mu: var (Union: (list (Value: '()) (Pair: _ (F: var))))) t*]
         [(Pair: t1 (Value: '())) (-lst t1)]
-        [(Pair: t1 t2)
+        [(MPair: t1 (Value: '())) (-mlst t1)]
+        [(or (Pair: t1 t2) (MPair: t1 t2))
          (let ([t-new (loop t2)])
-           (if (type-equal? (-lst t1) t-new)
+           (if (type-equal? ((match t*
+                               [(Pair: _ _) -lst]
+                               [(MPair: _ _) -mlst])
+                             t1)
+                            t-new)
                t-new
                (exit t)))]
         [_ (exit t)]))))

collects/typed-scheme/types/printer.rkt

@@ -133,6 +133,10 @@
      (fp "(Listof ~a)" elem-ty)]
     [(Mu: var (Union: (list (Pair: elem-ty (F: var)) (Value: '()))))
      (fp "(Listof ~a)" elem-ty)]
+    [(Mu: var (Union: (list (Value: '()) (MPair: elem-ty (F: var)))))
+     (fp "(MListof ~a)" elem-ty)]
+    [(Mu: var (Union: (list (MPair: elem-ty (F: var)) (Value: '()))))
+     (fp "(MListof ~a)" elem-ty)]
     [(Value: v) (cond [(or (symbol? v) (null? v))
                        (fp "'~a" v)]
                       [else (fp "~a" v)])]