From 6ff9e9ecd5cd218fda596df007060214d6a39f96 Mon Sep 17 00:00:00 2001
From: Gustavo Massaccesi <gustavo@oma.org.ar>
Date: Thu, 24 May 2018 00:23:52 -0300
Subject: [PATCH] Fix call case with rest argument in cptypes

And add special case for list to reduce
  (pair? (list x y ...)) ==> (begin x y ... #t)

original commit: 196bb8c18b604cd599e154c63f95a9d0117d4d6e
---
 mats/cptypes.ms | 66 +++++++++++++++++++++++++++++++++++++++++++++++++
 s/cptypes.ss    | 18 +++++++++++---
 2 files changed, 80 insertions(+), 4 deletions(-)

diff --git a/mats/cptypes.ms b/mats/cptypes.ms
index 0433672f35..0f06b004cb 100644
--- a/mats/cptypes.ms
+++ b/mats/cptypes.ms
@@ -26,6 +26,36 @@
                      #;[optimize-level (max (optimize-level) 2)])
         (expand/optimize y)))]))
 
+(define-syntax cptypes/nocp0-equivalent-expansion?
+  (syntax-rules ()
+    [(_ x y)
+     (equivalent-expansion?
+      (parameterize ([enable-cp0 #f]
+                     [#%$suppress-primitive-inlining #f]
+                     #;[optimize-level (max (optimize-level) 2)])
+        (expand/optimize x))
+      (parameterize ([enable-cp0 #f]
+                     [#%$suppress-primitive-inlining #f]
+                     #;[optimize-level (max (optimize-level) 2)])
+        (expand/optimize y)))]))
+
+(define-syntax cptypes/nocp0/alternative-equivalent-expansion?
+  (syntax-rules ()
+    [(_ x y)
+     (equivalent-expansion?
+      (parameterize ([enable-cp0 #f]
+                     [enable-type-recovery #f]
+                     [run-cp0 (lambda (cp0 c) (#3%$cptypes c))]
+                     [#%$suppress-primitive-inlining #f]
+                     #;[optimize-level (max (optimize-level) 2)])
+        (expand/optimize x))
+      (parameterize ([enable-cp0 #f]
+                     [enable-type-recovery #f]
+                     [run-cp0 (lambda (cp0 c) (#3%$cptypes c))]
+                     [#%$suppress-primitive-inlining #f]
+                     #;[optimize-level (max (optimize-level) 2)])
+        (expand/optimize y)))]))
+
 (mat cptypes-handcoded
   (cptypes-equivalent-expansion?
     '(vector? (vector))  ;actually reduced by folding, not cptypes 
@@ -45,6 +75,12 @@
   (cptypes-equivalent-expansion?
     '(pair? (cons 1 2)) 
     #t)
+  (cptypes-equivalent-expansion?
+    '(pair? (list 1 2)) 
+    #t)
+  (cptypes-equivalent-expansion?
+    '(pair? (list)) 
+    #f)
   (cptypes-equivalent-expansion?
     '(lambda (x) (vector-set! x 0 0) (vector? x))
     '(lambda (x) (vector-set! x 0 0) #t))
@@ -629,3 +665,33 @@
          '(lambda (x) (when (number? x) (#2%odd? x)))
          '(lambda (x) (when (number? x) (#3%odd? x)))))
 )
+
+(mat cptypes-rest-argument
+  (cptypes/nocp0-equivalent-expansion?
+    '((lambda (x . r) (pair? r)) 1)
+    '((lambda (x . r) #f) 1))
+  (cptypes/nocp0-equivalent-expansion?
+    '((lambda (x . r) (null? r)) 1)
+    '((lambda (x . r) #t) 1))
+  (cptypes/nocp0-equivalent-expansion?
+    '((lambda (x . r) (pair? r)) 1 2)
+    '((lambda (x . r) #t) 1 2))
+  (cptypes/nocp0-equivalent-expansion?
+    '((lambda (x . r) (null? r)) 1 2)
+    '((lambda (x . r) #f) 1 2))
+)
+
+(mat cptypes-rest-argument/alternative
+  (cptypes/nocp0/alternative-equivalent-expansion?
+    '((lambda (x . r) (pair? r)) 1)
+    '((lambda (x . r) #f) 1))
+  (cptypes/nocp0/alternative-equivalent-expansion?
+    '((lambda (x . r) (null? r)) 1)
+    '((lambda (x . r) #t) 1))
+  (cptypes/nocp0/alternative-equivalent-expansion?
+    '((lambda (x . r) (pair? r)) 1 2)
+    '((lambda (x . r) #t) 1 2))
+  (cptypes/nocp0/alternative-equivalent-expansion?
+    '((lambda (x . r) (null? r)) 1 2)
+    '((lambda (x . r) #f) 1 2))
+)
diff --git a/s/cptypes.ss b/s/cptypes.ss
index 9acb0ab52d..c940bd221c 100644
--- a/s/cptypes.ss
+++ b/s/cptypes.ss
@@ -195,7 +195,8 @@ Notes:
                                    (set! ret (pred-env-add/key ret key (pred-intersect x z)))))
                                (lambda (key x)
                                  (set! ret (pred-env-add/key ret key x)))
-                               (lambda (key x) (error 'pred-env-intersect/base "") (void))
+                               (lambda (key x)
+                                 ($impoops 'pred-env-intersect/base "unexpected value ~s in base environment ~s" x base))
                                from
                                base)
            ret)]))
@@ -233,7 +234,8 @@ Notes:
                                  ;x-> from
                                  ;z-> types
                                  (set! ret (pred-env-add/key ret key (pred-union x z)))))
-                             (lambda (key x) (error 'pred-env-union/base "") (void))
+                             (lambda (key x)
+                               ($impoops 'pred-env-union/from "unexpected value ~s in base environment ~s" x base))
                              from
                              base)
           ret))
@@ -288,7 +290,8 @@ Notes:
                                  (if (eq? x z)
                                      (set! ret (fxmap-reset/base ret key new-base))
                                      (set! ret (fxmap-advance/base ret key new-base)))))
-                             (lambda (key x) (error 'pred-env-rebase "") (void))
+                             (lambda (key x)
+                               ($impoops 'pred-env-rebase "unexpected value ~s in base environment ~s" x base))
                              new-base
                              base)
         ret))
@@ -843,6 +846,13 @@ Notes:
                                 (pred-env-add/ref types (car e*) pred))
                            #f)]))]
              ; TODO: special case for call-with-values.
+             [(eq? (primref-name pr) 'list)
+              (cond 
+                [(null? e*)
+                 ;should have be reduced by cp0
+                 (values null-rec null-rec t #f #f)]
+                [else
+                 (values `(call ,preinfo ,pr ,e* ...) 'pair t #f #f)])]
              [(and (fx= (length e*) 1)
                    (eq? (primref-name pr) 'exact?))
               (cond
@@ -940,7 +950,7 @@ Notes:
                (fold-left pred-env-add t x*
                  (let f ([i nfixed] [r* r*])
                    (if (fx= i 0)
-                       (list (if (null? r*) 'null 'pair))
+                       (list (if (null? r*) null-rec 'pair))
                        (cons (car r*) (f (fx- i 1) (cdr r*))))))))
            (lambda () (values ir 'bottom types #f #f))))]
       [(call ,preinfo ,[e0 'value types -> e0 ret0 types0 t-types0 f-types0]