~ chicken-core (chicken-5) caec8083ed7df20dbd1b6bbe1aa92f4835c91279

commit caec8083ed7df20dbd1b6bbe1aa92f4835c91279
Author:     Peter Bex <peter@more-magic.net>
AuthorDate: Sat Feb 13 19:23:06 2016 +0100
Commit:     Evan Hanson <evhan@foldling.org>
CommitDate: Sun Feb 14 08:51:50 2016 +1300

    Preserve type of argument in car in assq/assv/assoc procedure results.
    
    If the result is a pair, the car will always be the same type as the
    first procedure argument.  The list may consist of pairs of union
    types or unknown types, so this allows us to recover some type info
    due to the first argument in most cases being more specific.
    
    Signed-off-by: Evan Hanson <evhan@foldling.org>

diff --git a/types.db b/types.db
index 9d565dfa..c8accdc3 100644
--- a/types.db
+++ b/types.db
@@ -198,24 +198,24 @@
 	((* (list-of (or symbol procedure immediate)))
 	 (##core#inline "C_u_i_memq" #(1) #(2))))
 
-(assq (forall (a b) (#(procedure #:clean #:foldable) assq
-		     (* (list-of (pair a b)))
-		     (or false (pair a b))))
+(assq (forall (a b c) (#(procedure #:clean #:foldable) assq
+                       (a (list-of (pair b c)))
+                       (or false (pair a c))))
       ((* null) (let ((#(tmp) #(1))) '#f))
       ((* (list-of pair)) (##core#inline "C_u_i_assq" #(1) #(2))))
 
-(assv (forall (a b) (#(procedure #:clean #:foldable) assv
-		     (* (list-of (pair a b)))
-		     (or false (pair a b))))
+(assv (forall (a b c) (#(procedure #:clean #:foldable) assv
+                       (a (list-of (pair b c)))
+                       (or false (pair a c))))
       ((* null) (let ((#(tmp) #(1))) '#f))
       (((or symbol immediate procedure) (list-of pair))
        (##core#inline "C_u_i_assq" #(1) #(2)))
       ((* (list-of (pair (or symbol procedure immediate) *)))
        (##core#inline "C_u_i_assq" #(1) #(2))))
 
-(assoc (forall (a b) (#(procedure #:clean #:foldable) assoc
-                      (* (list-of (pair a b)))
-                      (or false (pair a b))))
+(assoc (forall (a b c) (#(procedure #:clean #:foldable) assoc
+			(a (list-of (pair b c)))
+			(or false (pair a c))))
        ((* null) (let ((#(tmp) #(1))) '#f))
        (((or symbol procedure immediate) (list-of pair))
 	(##core#inline "C_u_i_assq" #(1) #(2)))