~ chicken-core (chicken-5) a84501c6e9236ada00545869204f3dcd3a1b7511

commit a84501c6e9236ada00545869204f3dcd3a1b7511
Author:     felix <felix@call-with-current-continuation.org>
AuthorDate: Fri Aug 12 12:12:43 2011 +0200
Commit:     felix <felix@call-with-current-continuation.org>
CommitDate: Fri Aug 12 12:12:43 2011 +0200

    handle complex types in specialization-match

diff --git a/scrutinizer.scm b/scrutinizer.scm
index e5460cdd..17da5a18 100755
--- a/scrutinizer.scm
+++ b/scrutinizer.scm
@@ -1203,48 +1203,92 @@
       (print "; END OF FILE"))))
 
 (define (match-specialization typelist atypes exact)
-  ;; - does not accept complex procedure or list/vector/pair types in typelist!
-  ;; - "exact" means: "or"-type in atypes is not allowed
+  ;; - does not accept complex procedure types in typelist!
+  ;; - "exact" means: "or"-type in atypes is not allowed (used for predicates)
   (define (match st t)
     (cond ((eq? st t))
-	  ((and (pair? t) (memq (car t) '(vector list)))
-	   (match st (car t)))		;XXX hack, insufficient
-	  ((and (pair? t) (eq? 'pair (car t))) 
-	   (match st 'pair))		;XXX same here
+	  ((memq st '(vector list))
+	   (match (list st '*) t))
+	  ((memq t '(vector list))
+	   (match st (list t '*)))
+	  ((eq? 'pair st)
+	   (match '(pair * *) t))
+	  ((eq? 'pair t)
+	   (match st '(pair * *)))
+	  ((and (pair? t) (eq? 'or (car t)))
+	   ((if exact every any) (cut match st <>) (cdr t)))
+	  ((and (pair? t) (eq? 'and (car t)))
+	   (every (cut match st <>) (cdr t)))
+	  ((and (pair? t) (eq? 'procedure (car t)))
+	   (match st 'procedure))
 	  ((pair? st)
 	   (case (car st)
 	     ((not) (matchnot (cadr st) t))
 	     ((or) (any (cut match <> t) (cdr st)))
 	     ((and) (every (cut match <> t) (cdr st)))
-	     ((procedure) (bomb "match-specialization: invalid complex procedure type" st))
+	     ((list)
+	      (or (eq? 'null t)
+		  (and (pair? t) 
+		       (eq? 'list (car t))
+		       (match (second st) (second t)))))
+	     ((vector) 
+	      (and (pair? t) 
+		   (eq? 'vector (car t))
+		   (match (second st) (second t))))
+	     ((pair)
+	      (and (pair? t)
+		   (eq? 'pair (car t))
+		   (match (second st) (second t))
+		   (match (third st) (third t))))
+	     ((procedure) 		;XXX
+	      (match 'procedure t))
 	     (else (equal? st t))))
 	  ((eq? st '*))
 	  ;; "list" different from "number": a pair is not necessarily a list:
-	  ((eq? st 'list) (eq? t 'list))
 	  ((eq? st 'number) (match '(or fixnum float) t))
-	  ((pair? t)
-	   (case (car t)
-	     ((or) ((if exact every any) (cut match st <>) (cdr t)))
-	     ((and) (every (cut match st <>) (cdr t)))
-	     ((procedure) (match st 'procedure))
-	     ;; (not ...) should not occur
-	     (else (equal? st t))))
 	  (else (equal? st t))))
   (define (matchnot st t)
     (cond ((eq? st t) #f)
-	  ((and (pair? t) (memq (car t) '(vector list)))
-	   (match st (car t)))		;XXX hack, insufficient
-	  ((and (pair? t) (eq? 'pair (car t))) 
-	   (match st 'pair))		;XXX same here
-	  ((eq? 'list t) (matchnot st '(or null pair)))
+	  ((memq st '(vector list))
+	   (matchnot (list st '*) t))
+	  ((memq t '(vector list))
+	   (matchnot st (list t '*)))
+	  ((eq? 'pair st)
+	   (matchnot '(pair * *) t))
+	  ((eq? 'pair t)
+	   (matchnot st '(pair * *)))
+	  ((and (pair? t) (eq? 'or (car t)))
+	   (every (cut matchnot st <>) (cdr t)))
+	  ((and (pair? t) (eq? 'and (car t)))
+	   (any (cut matchnot st <>) (cdr t))) ;XXX test for "exact" here, too?
+	  ((eq? 'number st) (not (match '(or fixnum float) t)))
 	  ((eq? 'number t) (matchnot st '(or fixnum float)))
 	  ((eq? '* t) #f)
-	  ((eq? 'list st) (not (match '(or null pair) t)))
-	  ((eq? 'number st) (not (match '(or fixnum float) t)))
-	  ((pair? t)
-	   (case (car t)
-	     ((or) (every (cut matchnot st <>) (cdr t)))
-	     ((and) (any (cut matchnot st <>) (cdr t))) ;XXX test for "exact" here, too?
+	  ((eq? 'null st)
+	   (or (not (pair? t))
+	       (not (eq? 'list (car t)))))
+	  ((pair? st)
+	   (case (car st)
+	     ;;XXX "and" not handled here
+	     ((or) (every (cut matchnot <> t) (cdr t)))
+	     ((list)
+	      (and (not (eq? 'null t))
+		   (or (not (pair? t))
+		       (and (eq? 'list (car t))
+			    (matchnot (second st) (second t)))
+		       (matchnot `(pair ,(second st) *) t)))) ;XXX too conservative?
+	     ((vector)
+	      (or (not (pair? t))
+		  (not (eq? 'vector (car t)))
+		  (matchnot (second st) (second t))))
+	     ((pair)
+	      (or (not (pair? t))
+		  (case (car t)
+		    ((list) (matchnot (second st) (second t)))
+		    ((pair)
+		     (and (matchnot (second st) (second t))
+			  (matchnot (third st) (third t))))
+		    (else #f))))
 	     (else (not (match st t)))))
 	  (else (not (match st t)))))
   (let loop ((tl typelist) (atypes atypes))