~ chicken-core (chicken-5) dd46f2348c2c8f86e5358a6e376483bdb7690446

commit dd46f2348c2c8f86e5358a6e376483bdb7690446
Author:     felix <felix@call-with-current-continuation.org>
AuthorDate: Sat Nov 10 14:10:56 2012 +0100
Commit:     Peter Bex <peter.bex@xs4all.nl>
CommitDate: Sat Nov 10 18:33:42 2012 +0100

    Improve type-matching for list-like types.
    
    canonicalization of list-like types uses "(list ...)" where
    appropriate to allow more precise type-matching of combinations
    of "list-of"/"list" types.
    
    Signed-off-by: Peter Bex <peter.bex@xs4all.nl>

diff --git a/compiler-namespace.scm b/compiler-namespace.scm
index 69302063..db1c1b64 100644
--- a/compiler-namespace.scm
+++ b/compiler-namespace.scm
@@ -43,7 +43,7 @@
  c-ify-string
  callback-names
  call-info
- canonicalize-list-of-type
+ canonicalize-list-type
  canonicalize-begin-body
  canonicalize-expression
  check-and-open-input-file
diff --git a/scrutinizer.scm b/scrutinizer.scm
index 73a1166b..ca78882a 100755
--- a/scrutinizer.scm
+++ b/scrutinizer.scm
@@ -1150,7 +1150,7 @@
 		(pair? t2)
 		(case (car t2)
 		  ((list-of)
-		   (let ((ct1 (canonicalize-list-of-type t1)))
+		   (let ((ct1 (canonicalize-list-type t1)))
 		     (if ct1
 			 (match1 ct1 t2)
 			 #t)))		; inexact match
@@ -1165,7 +1165,7 @@
 	   (and (pair? t1)
 		(case (car t1)
 		  ((list-of)
-		   (let ((ct2 (canonicalize-list-of-type t2)))
+		   (let ((ct2 (canonicalize-list-type t2)))
 		     (if ct2
 			 (match1 t1 ct2)
 			 (and (not exact) (not all)))))	; inexact mode: ok
@@ -1188,7 +1188,7 @@
 			  #t
 			  (lambda (t) (match1 t1 t)))))
 		      ((pair)
-		       (let ((ct2 (canonicalize-list-of-type t2)))
+		       (let ((ct2 (canonicalize-list-type t2)))
 			 (and ct2 (match1 t1 ct2))))
 		      (else #f)))))
 	  ((and (pair? t1) (eq? 'list (car t1)))
@@ -1213,7 +1213,7 @@
 		(or (eq? 'null t1)
 		    (and (pair? t1)
 			 (eq? 'pair (car t1)) ; list-of already handled above
-			 (let ((ct1 (canonicalize-list-of-type t1)))
+			 (let ((ct1 (canonicalize-list-type t1)))
 			   (and ct1 (match1 ct1 t2)))))))
 	  ((and (pair? t2) (eq? 'list (car t2)))
 	   (and (pair? t1)
@@ -1369,7 +1369,7 @@
 		     (if (and (eq? '* tcar) (eq? '* tcdr))
 			 'pair
 			 (let ((t `(pair ,tcar ,tcdr)))
-			   (or (canonicalize-list-of-type t)
+			   (or (canonicalize-list-type t)
 			       t)))))
 		  ((vector-of)
 		   (let ((t2 (simplify (second t))))
@@ -2180,26 +2180,24 @@
 ;
 ; - returns #f if not possibly matchable with "list-of"
 
-(define (canonicalize-list-of-type t)
+(define (canonicalize-list-type t)
   (cond ((not (pair? t)) t)
 	((eq? 'pair (car t))
 	 (let ((tcar (second t))
 	       (tcdr (third t)))
 	   (let rec ((tr tcdr) (ts (list tcar)))
 	     (cond ((eq? 'null tr)
-		    `(list-of ,(simplify-type `(or ,@ts))))
+		    `(list ,@(reverse ts)))
 		   ((eq? 'list tr) tr)
 		   ((and (pair? tr) (eq? 'pair (first tr)))
 		    (rec (third tr) (cons (second tr) ts)))
 		   ((and (pair? tr) (eq? 'list (first tr)))
-		    `(list-of ,(simplify-type `(or ,@ts ,@(cdr tr)))))
+		    `(list ,@(reverse ts) ,@(cdr tr)))
 		   ((and (pair? tr) (eq? 'list-of (first tr)))
-		    `(list-of 
+		    `(list-of
 		      ,(simplify-type
 			`(or ,@(reverse ts) ,@(cdr tr)))))
 		   (else #f)))))
-	((eq? 'list (car t)) 
-	 `(list-of ,(simplify-type `(or ,@(cdr t)))))
 	(else t)))