~ chicken-core (chicken-5) 0a76384f1d7aa86daa85fc2df7c85d5babddc60d

commit 0a76384f1d7aa86daa85fc2df7c85d5babddc60d
Author:     felix <felix@call-with-current-continuation.org>
AuthorDate: Wed Sep 14 01:06:35 2011 +0200
Commit:     felix <felix@call-with-current-continuation.org>
CommitDate: Wed Sep 14 10:02:29 2011 +0200

    - types.db fixes, suggested by sjamaan and some ehancements (need testing)
    - matching (list-of T) with pair or list types will also work in exact mode

diff --git a/scrutinizer.scm b/scrutinizer.scm
index f32c0dc7..895481eb 100755
--- a/scrutinizer.scm
+++ b/scrutinizer.scm
@@ -779,7 +779,6 @@
 		    ;; first exp is always a variable so ts must be of length 1
 		    (let loop ((types params) (subs (cdr subs)))
 		      (cond ((null? types)
-			     ;;XXX figure out line-number
 			     (quit "~ano clause applies in `compiler-typecase' for expression of type `~s':~a" 
 				   (location-name loc) (car ts)
 				   (string-concatenate
@@ -1117,20 +1116,17 @@
 				(third t2))))
 		  (else #f))))
 	  ((and (pair? t1) (eq? 'list-of (car t1)))
-	   ;;XXX (list-of T) == (pair T (pair T ... (pair T null)))
-	   ;;     should also work in exact mode
-	   (and (not exact) (not all)
-		(or (eq? 'null t2)
-		    (and (pair? t2)
-			 (case (car t2)
-			   ((pair)
-			    (and (match1 (second t1) (second t2))
-				 (match1 t1 (third t2))))
-			   ((list)
-			    (match1 
-			     (second t1) 
-			     (simplify-type `(or ,@(cdr t2)))))
-			   (else #f))))))
+	   (or (eq? 'null t2)
+	       (and (pair? t2)
+		    (case (car t2)
+		      ((pair)
+		       (and (match1 (second t1) (second t2))
+			    (match1 t1 (third t2))))
+		      ((list)
+		       (match1 
+			(second t1) 
+			(simplify-type `(or ,@(cdr t2)))))
+		      (else #f)))))
 	  ((and (pair? t1) (eq? 'list (car t1)))
 	   (and (pair? t2)
 		(case (car t2)
diff --git a/types.db b/types.db
index 172326b1..82e842d4 100644
--- a/types.db
+++ b/types.db
@@ -164,32 +164,40 @@
 
 (append (#(procedure #:clean) append (list #!rest) *))
 (##sys#append (#(procedure #:clean) ##sys#append (list #!rest) *))
-(reverse (forall (a) (#(procedure #:clean #:enforce) reverse ((list a)) (list a))))
-(memq (#(procedure #:clean) memq (* list) *) ((* list) (##core#inline "C_u_i_memq" #(1) #(2))))
+(reverse (forall (a) (#(procedure #:clean #:enforce) reverse ((list-of a)) (list-of a))))
 
-(memv (#(procedure #:clean) memv (* list) *)
-      (((or fixnum boolean char eof undefined null) list)
+(memq (forall (a b) (#(procedure #:clean) memq (a (list-of b)) (or boolean (list-of b))))
+      ((* list) (##core#inline "C_u_i_memq" #(1) #(2))))
+
+(memv (forall (a b) (#(procedure #:clean) memv (a (list-of b)) (or boolean (list-of b))))
+      (((or symbol procedure immediate) list)
        (##core#inline "C_u_i_memq" #(1) #(2))))
 
-;; this may be a bit much...
-(member (forall (a) (#(procedure #:clean) member (* list #!optional (procedure (* *) *)) *))
-	(((or fixnum boolean char eof undefined null) list)
+(member (forall (a b) (#(procedure #:clean) member
+		       (a (list-of b) #!optional (procedure (b a) *)) ; sic
+		       (or boolean (list-of b))))
+	(((or symbol procedure immediate) list)
 	 (##core#inline "C_u_i_memq" #(1) #(2)))
-	((* (list (or fixnum boolean char eof undefined null)))
+	((* (list-of immediate))
 	 (##core#inline "C_u_i_memq" #(1) #(2))))
 
-(assq (#(procedure #:clean) assq (* list) *) ((* list) (##core#inline "C_u_i_assq" #(1) #(2))))
+(assq (forall (a b) (#(procedure #:clean) assq (* (list-of (pair a b)))
+		     (or boolean (pair a b))))
+      ((* list) (##core#inline "C_u_i_assq" #(1) #(2))))
 
-(assv (#(procedure #:clean) assv (* list) *)
-      (((or fixnum boolean char eof undefined null) list)
+(assv (forall (a b) (#(procedure #:clean) assv (* (list-of (pair a b))) 
+		     (or boolean (pair a b))))
+      (((or symbol immediate procedure) list)
        (##core#inline "C_u_i_assq" #(1) #(2)))
-      ((* (list (or fixnum boolean char eof undefined null)))
+      ((* (list-of (pair (or symbol procedure immediate) *)))
        (##core#inline "C_u_i_assq" #(1) #(2))))
 
-(assoc (#(procedure #:clean) assoc (* list #!optional (procedure (* *) *)) *)
-       (((or fixnum boolean char eof undefined null) list)
+(assoc (forall (a b c) (#(procedure #:clean) assoc (a (list-of (pair b c))
+						      #!optional (procedure (b a) *)) ; sic
+			(or boolean (pair b c))))
+       (((or symbol procedure immediate) list)
 	(##core#inline "C_u_i_assq" #(1) #(2)))
-       ((* (list (or fixnum boolean char eof undefined null)))
+       ((* (list-of (pair (or symbol procedure immediate) *)))
 	(##core#inline "C_u_i_assq" #(1) #(2))))
 
 (symbol? (#(procedure #:pure #:predicate symbol) symbol? (*) boolean))
@@ -1677,7 +1685,7 @@
 (set-alarm! (#(procedure #:clean #:enforce) set-alarm! (number) number))
 (set-buffering-mode! (#(procedure #:clean #:enforce) set-buffering-mode! (port symbol #!optional fixnum) undefined))
 (set-file-position! (#(procedure #:clean #:enforce) set-file-position! ((or port fixnum) fixnum #!optional fixnum) undefined))
-(set-groups! (#(procedure #:clean #:enforce) set-groups! (list) undefined))
+(set-groups! (#(procedure #:clean #:enforce) set-groups! ((list-of fixnum)) undefined))
 (set-root-directory! (#(procedure #:clean #:enforce) set-root-directory! (string) undefined))
 (set-signal-handler! (#(procedure #:clean #:enforce) set-signal-handler! (fixnum (or boolean (procedure (fixnum) . *))) undefined))
 (set-signal-mask! (#(procedure #:clean #:enforce) set-signal-mask! ((list-of fixnum)) undefined))