Re: [Chicken-hackers] [PATCH] types.db fixes/enhancements, change in list-of matching

[Felix]

From: Felix <address@hidden>
Subject: [PATCH] types.db fixes/enhancements, change in list-of matching
Date: Wed, 14 Sep 2011 04:02:00 -0400 (EDT)

> The attached patch fixes some issues in types.db which
> were reported by Peter and uses slightly more precise
> types in a few spots.
> 
> Matching (list-of T) with pair and list types has been corrected
> (it matches both in normal and exact mode, the latter being used
> for specializations).
> 

Oops. Forgot part of the change. Attached is a new patch, please
ignore the previous one.


cheers,
felix

commit 0a76384f1d7aa86daa85fc2df7c85d5babddc60d
Author: felix <address@hidden>
Date:   Wed Sep 14 01:06:35 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 f32c0dc..895481e 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 172326b..82e842d 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))