[Chicken-hackers] [PATCH] simplify typevar instantiation handling in scrutinizer

[Felix]

Attached is a patch that simplifies the use of
"over-all-instantiations" in the scrutinizer. Peter was of course
right about the redundant matching at some call-sites of this
procedure, which I boneheadedly refused to see.

This patch also fixes a bug in the transformation of the internal
node tree to s-expressions for the "##core#typecase" construct.

Testcases have been added. The changes have been tested with the
core test-suite and all core libraries and tools.


cheers,
felix

commit 017918bd4b374b4743fe6a4009a5d16532047885
Author: felix <address@hidden>
Date:   Mon Sep 26 09:11:58 2011 +0200

    - simplify use of "over-all-instantiations"
    - combining instantiations over union-types uses fallback "*" type only in 
exact mode
    - fixed broken Node->Sexpr transformation for "##core#typecase" without 
"else"-clause
    - added more test-cases for type-matching
    
    Squashed commit of the following:
    
    commit 56299cdc71ccbc6342b4614014536b715ff3747c
    Author: felix <address@hidden>
    Date:   Mon Sep 26 08:34:10 2011 +0200
    
        added some testcases
    
    commit 2ab58471a67b474197714aeb98a17a44b6ca8416
    Author: felix <address@hidden>
    Date:   Sun Sep 25 15:26:04 2011 +0200
    
        simplified o-a-i, fallback to * for unbound typevars only in exact 
mode, fixed bug in build-expression-tree for typecase

diff --git a/scrutinizer.scm b/scrutinizer.scm
index 115b118..3f9ebfd 100755
--- a/scrutinizer.scm
+++ b/scrutinizer.scm
@@ -1015,19 +1015,15 @@
          ((and (pair? t2) (eq? 'or (car t2)))
           (over-all-instantiations
            (cdr t2)
-           typeenv
-           (lambda (t) (match1 t1 t))
-           (lambda () 
-             (if (or exact all)
-                 (every 
-                  (cut match1 t1 <>)
-                  (cdr t2))
-                 #t))))
+           typeenv 
+           (or exact all)
+           (lambda (t) (match1 t1 t))))
          ;; s.a.
          ((and (pair? t1) (eq? 'or (car t1))) 
           (over-all-instantiations
            (cdr t1)
            typeenv
+           #f
            (lambda (t) (match1 t t2)))) ; o-a-i ensures at least one element 
matches
          ((and (pair? t1) (eq? 'forall (car t1)))
           (match1 (third t1) t2)) ; assumes typeenv has already been extracted
@@ -1435,9 +1431,8 @@
                               (over-all-instantiations
                                (cdr t2)
                                typeenv
-                               (lambda (t) (test t1 t))
-                               (lambda ()
-                                 (every (cut test t1 <>) (cdr t2)))))
+                               #t
+                               (lambda (t) (test t1 t))))
                              ((and (eq? 'vector (car t1)) (eq? 'vector-of (car 
t2)))
                               (every (cute test <> (second t2)) (cdr t1)))
                              ((and (eq? 'vector-of (car t1)) (eq? 'vector (car 
t2)))
@@ -1462,9 +1457,8 @@
                                  (over-all-instantiations
                                   (cdr t1)
                                   typeenv
-                                  (lambda (t) (test t t2))
-                                  (lambda ()
-                                    (every (cut test <> t2) (cdr t1)))))
+                                  #t
+                                  (lambda (t) (test t t2))))
                                 ((vector-of list-of) (test (second t1) (second 
t2)))
                                 ((pair) (every test (cdr t1) (cdr t2)))
                                 ((procedure)
@@ -2277,7 +2271,7 @@
 
 ;;; perform check over all typevar instantiations
 
-(define (over-all-instantiations tlist typeenv process #!optional (combine 
(constantly #t)))
+(define (over-all-instantiations tlist typeenv exact process)
   (let ((insts '())
        (anyinst #f)
        (trail0 trail))
@@ -2306,15 +2300,17 @@
             (all (map (lambda (var)
                         (cons
                          var
-                         (map (lambda (inst)
-                                (cond ((assq var inst) => cdr)
-                                      (else '*)))
-                              insts)))
+                         (append-map
+                          (lambda (inst)
+                            (cond ((assq var inst) => (o list cdr))
+                                  (exact '(*))
+                                  (else '())))
+                          insts)))
                       vars)))
        ;;(dd "  collected: ~s" all)    ;XXX remove
        all))
 
-    (dd " over-all-instantiations: ~s" tlist) ;XXX remove
+    (dd " over-all-instantiations: ~s exact=~a" tlist exact) ;XXX remove
     ;; process all tlist elements
     (let loop ((ts tlist) (ok #f))
       (cond ((null? ts)
@@ -2322,13 +2318,17 @@
                    (for-each 
                     (lambda (i)
                       (set! trail (cons (car i) trail))
-                      (set-car! (cdr (assq (car i) typeenv)) `(or ,@(cdr i))))
+                      (set-car! (cdr (assq (car i) typeenv))
+                                (simplify-type `(or ,@(cdr i)))))
                     (collect))
-                   (combine))
+                   #t)
                   (else #f)))
            ((process (car ts))
             (restore)
             (loop (cdr ts) #t))
+           (exact 
+            (restore)
+            #f)
            (else 
             (restore)
             (loop (cdr ts) ok))))))
diff --git a/support.scm b/support.scm
index 299b92f..cb95c0d 100644
--- a/support.scm
+++ b/support.scm
@@ -595,7 +595,9 @@
           ,(walk (first subs))
           ,@(let loop ((types params) (bodies (cdr subs)))
               (if (null? types)
-                  `((else ,(walk (car bodies))))
+                  (if (null? bodies)
+                      '()
+                      `((else ,(walk (car bodies)))))
                   (cons (list (car types) (walk (car bodies)))
                         (loop (cdr types) (cdr bodies)))))))
        ((##core#call) 
diff --git a/tests/typematch-tests.scm b/tests/typematch-tests.scm
index a1048f4..6b687c8 100644
--- a/tests/typematch-tests.scm
+++ b/tests/typematch-tests.scm
@@ -1,7 +1,7 @@
 ;;;; typematch-tests.scm
 
 
-(use lolevel)
+(use lolevel data-structures)
 
 
 (define-syntax check
@@ -211,3 +211,28 @@
        (symbol 's)
        (fixnum 'f)
        ((or fixnum symbol) 'sf))))
+
+(: f3 (forall (a) ((list-of a) -> a)))
+(define f3 car)
+(define xxx '(1))
+
+(compiler-typecase (f3 (the (or (vector-of fixnum) (list-of fixnum)) xxx))
+  (fixnum 'ok))
+
+(assert
+ (eq? 'ok
+      (compiler-typecase (list 123)
+       ((forall (a) (or (vector-of a) (list-of a))) 'ok)
+       (else 'not-ok))))
+
+(: f4 (forall (a) ((or fixnum (list-of a)) -> a)))
+(define f4 identity)
+
+(compiler-typecase (f4 '(1))
+  (fixnum 'ok))
+
+(assert
+ (eq? 'ok (compiler-typecase (f4 1)
+           (fixnum 'not-ok)
+           (else 'ok))))
+