~ chicken-core (chicken-5) 9f07e332986de5bc94b5bc04735ca599df41615d

commit 9f07e332986de5bc94b5bc04735ca599df41615d
Author:     Evan Hanson <evhan@foldling.org>
AuthorDate: Sun Aug 17 18:36:21 2014 +1200
Commit:     Peter Bex <peter.bex@xs4all.nl>
CommitDate: Sun Oct 19 14:27:20 2014 +0200

    Add scrutiny special cases for make-list/make-vector with known sizes
    
    Signed-off-by: Peter Bex <peter.bex@xs4all.nl>

diff --git a/scrutinizer.scm b/scrutinizer.scm
index c5cd8c4c..afe3cabe 100644
--- a/scrutinizer.scm
+++ b/scrutinizer.scm
@@ -110,6 +110,7 @@
 (define-constant +fragment-max-length+ 6)
 (define-constant +fragment-max-depth+ 4)
 (define-constant +maximal-union-type-length+ 20)
+(define-constant +maximal-complex-object-constructor-result-type-length+ 256)
 
 
 (define specialization-statistics '())
@@ -2269,6 +2270,34 @@
     `((vector ,@(map walked-result (cdr args))))))
 
 
+;;; Special cases for make-list/make-vector with a known size
+;
+; e.g. (make-list 3 #\a) => (list char char char)
+
+(let ()
+
+  (define (complex-object-constructor-result-type-special-case type)
+    (lambda (node args rtypes)
+      (or (and-let* ((subs (node-subexpressions node))
+		     (fill (case (length subs)
+			     ((2) '*)
+			     ((3) (walked-result (third args)))
+			     (else #f)))
+		     (sub2 (second subs))
+		     ((eq? 'quote (node-class sub2)))
+		     (size (first (node-parameters sub2)))
+		     ((fixnum? size))
+		     ((<= 0 size +maximal-complex-object-constructor-result-type-length+)))
+	    `((,type ,@(make-list size fill))))
+	  rtypes)))
+
+  (define-special-case make-list
+    (complex-object-constructor-result-type-special-case 'list))
+
+  (define-special-case make-vector
+    (complex-object-constructor-result-type-special-case 'vector)))
+
+
 ;;; perform check over all typevar instantiations
 
 (define (over-all-instantiations tlist typeenv exact process)
@@ -2312,7 +2341,8 @@
 
     (ddd " over-all-instantiations: ~s exact=~a" tlist exact)
     ;; process all tlist elements
-    (let loop ((ts tlist) (ok #f))
+    (let loop ((ts (delete-duplicates tlist equal?))
+	       (ok #f))
       (cond ((null? ts)
 	     (cond ((or ok (null? tlist))
 		    (for-each 
diff --git a/tests/typematch-tests.scm b/tests/typematch-tests.scm
index 40515957..4374337b 100644
--- a/tests/typematch-tests.scm
+++ b/tests/typematch-tests.scm
@@ -286,6 +286,10 @@
 (mx (list fixnum) (take (list 1 2.3) 1))
 (mx (list fixnum) (take (cons 1 2.3) 1))
 (mx (list fixnum float) (take (list 1 2.3) 2))
+(mx (list * *) (make-list 2))
+(mx (list string string) (make-list 2 "a"))
+(mx (vector * *) (make-vector 2))
+(mx (vector string string) (make-vector 2 "a"))
 
 (: f1 (forall (a) ((list-of a) -> a)))
 (define (f1 x) (car x))
diff --git a/types.db b/types.db
index 7d555383..19f01f37 100644
--- a/types.db
+++ b/types.db
@@ -561,6 +561,7 @@
 
 (vector? (#(procedure #:pure #:predicate vector) vector? (*) boolean))
 
+;; special-cased (see scrutinizer.scm)
 (make-vector (forall (a) (#(procedure #:clean #:enforce) make-vector (fixnum #!optional a) 
 			  (vector-of a))))
 
@@ -1993,6 +1994,7 @@
  ((procedure) (let ((#(tmp) #(1))) '#t))
  ((procedure list) (let ((#(tmp1) #(1)) (#(tmp2) #(2))) '#t)))
 
+;; special-cased (see scrutinizer.scm)
 (make-list (forall (a) (#(procedure #:clean #:enforce) make-list (fixnum #!optional a) (list-of a))))
 
 (map!