[Chicken-hackers] [PATCH] improve type-matching some more

[Felix]

This patch builds on the recent scrutinizer fix for list-of/list
type matching and generalizes the fix somewhat to uses of
"(pair ...)" types. Canonicalization of list-like types
uses "(list ...)" where appropriate, which is more precise
than "(list-of (or ...))".

I darkly recall that the use of "list-of" was intentional at
some point, but this way of canonicalization is definitely
more accurate. Still, we should look out for regressions.


cheers,
felix

>From ca99d042a7e7d3d3142101959a7f874023d0ab5b Mon Sep 17 00:00:00 2001
From: felix <address@hidden>
Date: Sat, 10 Nov 2012 14:10:56 +0100
Subject: [PATCH] Improve type-matching for list-like types.

canonicalization of list-like types uses "(list ...)" where
appropriate to allow more precise type-matching of combinations
of "list-of"/"list" types.
---
 compiler-namespace.scm |    2 +-
 scrutinizer.scm        |   20 +++++++++-----------
 2 files changed, 10 insertions(+), 12 deletions(-)

diff --git a/compiler-namespace.scm b/compiler-namespace.scm
index 6930206..db1c1b6 100644
--- a/compiler-namespace.scm
+++ b/compiler-namespace.scm
@@ -43,7 +43,7 @@
  c-ify-string
  callback-names
  call-info
- canonicalize-list-of-type
+ canonicalize-list-type
  canonicalize-begin-body
  canonicalize-expression
  check-and-open-input-file
diff --git a/scrutinizer.scm b/scrutinizer.scm
index 73a1166..ca78882 100755
--- a/scrutinizer.scm
+++ b/scrutinizer.scm
@@ -1150,7 +1150,7 @@
                (pair? t2)
                (case (car t2)
                  ((list-of)
-                  (let ((ct1 (canonicalize-list-of-type t1)))
+                  (let ((ct1 (canonicalize-list-type t1)))
                     (if ct1
                         (match1 ct1 t2)
                         #t)))          ; inexact match
@@ -1165,7 +1165,7 @@
           (and (pair? t1)
                (case (car t1)
                  ((list-of)
-                  (let ((ct2 (canonicalize-list-of-type t2)))
+                  (let ((ct2 (canonicalize-list-type t2)))
                     (if ct2
                         (match1 t1 ct2)
                         (and (not exact) (not all))))) ; inexact mode: ok
@@ -1188,7 +1188,7 @@
                          #t
                          (lambda (t) (match1 t1 t)))))
                      ((pair)
-                      (let ((ct2 (canonicalize-list-of-type t2)))
+                      (let ((ct2 (canonicalize-list-type t2)))
                         (and ct2 (match1 t1 ct2))))
                      (else #f)))))
          ((and (pair? t1) (eq? 'list (car t1)))
@@ -1213,7 +1213,7 @@
                (or (eq? 'null t1)
                    (and (pair? t1)
                         (eq? 'pair (car t1)) ; list-of already handled above
-                        (let ((ct1 (canonicalize-list-of-type t1)))
+                        (let ((ct1 (canonicalize-list-type t1)))
                           (and ct1 (match1 ct1 t2)))))))
          ((and (pair? t2) (eq? 'list (car t2)))
           (and (pair? t1)
@@ -1369,7 +1369,7 @@
                     (if (and (eq? '* tcar) (eq? '* tcdr))
                         'pair
                         (let ((t `(pair ,tcar ,tcdr)))
-                          (or (canonicalize-list-of-type t)
+                          (or (canonicalize-list-type t)
                               t)))))
                  ((vector-of)
                   (let ((t2 (simplify (second t))))
@@ -2180,26 +2180,24 @@
 ;
 ; - returns #f if not possibly matchable with "list-of"
 
-(define (canonicalize-list-of-type t)
+(define (canonicalize-list-type t)
   (cond ((not (pair? t)) t)
        ((eq? 'pair (car t))
         (let ((tcar (second t))
               (tcdr (third t)))
           (let rec ((tr tcdr) (ts (list tcar)))
             (cond ((eq? 'null tr)
-                   `(list-of ,(simplify-type `(or ,@ts))))
+                   `(list ,@(reverse ts)))
                   ((eq? 'list tr) tr)
                   ((and (pair? tr) (eq? 'pair (first tr)))
                    (rec (third tr) (cons (second tr) ts)))
                   ((and (pair? tr) (eq? 'list (first tr)))
-                   `(list-of ,(simplify-type `(or ,@ts ,@(cdr tr)))))
+                   `(list ,@(reverse ts) ,@(cdr tr)))
                   ((and (pair? tr) (eq? 'list-of (first tr)))
-                   `(list-of 
+                   `(list-of
                      ,(simplify-type
                        `(or ,@(reverse ts) ,@(cdr tr)))))
                   (else #f)))))
-       ((eq? 'list (car t)) 
-        `(list-of ,(simplify-type `(or ,@(cdr t)))))
        (else t)))
 
 
-- 
1.7.0.4