~ chicken-core (chicken-5) b671f5db5832d28d0f43c5236624e3f5f0d26ca6

commit b671f5db5832d28d0f43c5236624e3f5f0d26ca6
Author:     felix <felix@call-with-current-continuation.org>
AuthorDate: Tue Apr 5 15:17:59 2011 +0200
Commit:     felix <felix@call-with-current-continuation.org>
CommitDate: Tue Apr 5 15:17:59 2011 +0200

    scrutiny bugfix and types.db predicate fixes for list-predicates

diff --git a/scrutinizer.scm b/scrutinizer.scm
index c3eb0470..023c5974 100755
--- a/scrutinizer.scm
+++ b/scrutinizer.scm
@@ -521,7 +521,7 @@
 				       (report
 					loc
 					(sprintf 
-					    "~apredicate is called with an argument of type `~a' and will always return true"
+					    "~athe predicate is called with an argument of type `~a' and will always return true"
 					  (pname) pt))
 				       (specialize-node!
 					node
@@ -531,8 +531,8 @@
 				       (report
 					loc
 					(sprintf 
-					    "~apredicate is called with an argument of type `~a' and will always return false"
-					  (pname) (car args)))
+					    "~athe predicate is called with an argument of type `~a' and will always return false"
+					  (pname) (cadr args)))
 				       (specialize-node!
 					node
 					`(let ((#:tmp #(1))) '#f))
@@ -814,8 +814,10 @@
      (read-file dbfile))))
 
 (define (match-specialization typelist atypes)
+  ;; does not accept complex procedure types in typelist!
   (define (match st t)
-    (cond ((pair? st)
+    (cond ((eq? st t))
+	  ((pair? st)
 	   (case (car st)
 	     ((not) 
 	      (cond ((and (pair? t) (eq? 'or (car t)))
@@ -830,7 +832,7 @@
 	   (or (eq? t 'procedure)
 	       (and (pair? t) (eq? 'procedure (car t)))))
 	  ;;XXX match number with fixnum and float?
-	  (else (eq? st t))))
+	  (else #f)))
   (let loop ((tl typelist) (atypes atypes))
     (cond ((null? tl) (null? atypes))
 	  ((null? atypes) #f)
diff --git a/types.db b/types.db
index 8597621b..e92875f1 100644
--- a/types.db
+++ b/types.db
@@ -55,8 +55,9 @@
 	(((or fixnum symbol char eof null undefined) *) (eq? #(1) #(2)))
 	((* (or fixnum symbol char eof null undefined) (eq? #(1) #(2)))))
 
-(pair? (procedure pair? (*) boolean))
-(predicate pair? pair)
+(pair? (procedure pair? (*) boolean)
+       ((pair) (let ((#:tmp #(1))) '#t))
+       (((and (not pair) (not list))) (let ((#:tmp #(1))) '#f)))
 
 (cons (procedure cons (* *) pair))
 
@@ -95,9 +96,10 @@
 (set-car! (procedure! set-car! (pair *) undefined) ((pair *) (##sys#setslot #(1) '0 #(2))))
 (set-cdr! (procedure! set-cdr! (pair *) undefined) ((pair *) (##sys#setslot #(1) '1 #(2))))
 
-(null? (procedure null? (*) boolean))
-(predicate null? null)
-
+(null? (procedure null? (*) boolean)
+       ((null) (let ((#:tmp #(1))) '#t))
+       (((and (not list) (not null))) (let ((#:tmp #(1))) '#f)))
+				     
 (list? (procedure list? (*) boolean) 
        (((or null pair list)) (let ((#:tmp #(1))) '#t))
        (((not (or null pair list))) (let ((#:tmp #(1))) '#f)))