~ chicken-core (chicken-5) 42490cf95afd4d2f0521a967b965239403398420

commit 42490cf95afd4d2f0521a967b965239403398420
Author:     felix <felix@call-with-current-continuation.org>
AuthorDate: Wed Feb 9 08:37:57 2011 -0500
Commit:     felix <felix@call-with-current-continuation.org>
CommitDate: Wed Feb 9 08:37:57 2011 -0500

    and pattern matches and *; added interesting rule for eqv? (untested)

diff --git a/scrutinizer.scm b/scrutinizer.scm
index e990a4d3..c237c75b 100755
--- a/scrutinizer.scm
+++ b/scrutinizer.scm
@@ -66,11 +66,14 @@
 ; specialization specifiers:
 ;
 ;   SPECIALIZATION = ((MVAL ... [#!rest MVAL]) TEMPLATE)
-;   MVAL = VAL | (not VAL) | (or VAL ...)
+;   MVAL = VAL | (not VAL) | (or VAL ...) | (and VAL ...)
 ;   TEMPLATE = #(INDEX [...])
 ;            | INTEGER | SYMBOL | STRING
 ;            | (quote CONSTANT)
 ;            | (TEMPLATE . TEMPLATE)
+;
+;   - (not number) succeeds for fixnum and flonum
+;   - (not list) succeeds for pair and null
 
 
 (define-constant +fragment-max-length+ 5)
@@ -700,16 +703,18 @@
 
 (define (match-specialization typelist atypes)
   (define (match st t)
-    (if (pair? st)
-	(case (car st)
-	  ((not) 
-	   (cond ((and (pair? t) (eq? 'or (car t)))
-		  (not (any (cute match (cadr st) <>) (cdr t))))
-		 ((eq? '* t) #f)
-		 (else (not (match (cadr st) t)))))
-	  ((or) (any (cut match <> t) (cdr st)))
-	  (else (equal? st t)))
-	(eq? st t)))
+    (cond ((pair? st)
+	   (case (car st)
+	     ((not) 
+	      (cond ((and (pair? t) (eq? 'or (car t)))
+		     (not (any (cute match (cadr st) <>) (cdr t))))
+		    ((eq? '* t) #f)
+		    (else (not (match (cadr st) t)))))
+	     ((or) (any (cut match <> t) (cdr st)))
+	     ((and) (every (cut match <> t) (cdr st)))
+	     (else (equal? st t))))
+	  ((eq? st '*))
+	  (else (eq? st t))))
   (let loop ((tl typelist) (atypes atypes))
     (cond ((null? tl) (null? atypes))
 	  ((null? atypes) #f)
diff --git a/types.db b/types.db
index 4379b1de..a01bf8d5 100644
--- a/types.db
+++ b/types.db
@@ -32,7 +32,9 @@
 	  ((boolean) '#t)
 	  (((not boolean)) '#f))
 (eq? (procedure eq? (* *) boolean))
-(eqv? (procedure eqv? (* *) boolean))
+(eqv? (procedure eqv? (* *) boolean)
+      (((and (not number) (not flonum)) *) (eq? #(1) #(2)))
+      ((* (and (not number) (not flonum))) (eq? #(1) #(2))))
 (equal? (procedure equal? (* *) boolean))
 (pair? (procedure pair? (*) boolean))
 (cons (procedure cons (* *) pair))