~ chicken-core (chicken-5) 017918bd4b374b4743fe6a4009a5d16532047885

commit 017918bd4b374b4743fe6a4009a5d16532047885
Author:     felix <felix@call-with-current-continuation.org>
AuthorDate: Mon Sep 26 09:11:58 2011 +0200
Commit:     felix <felix@call-with-current-continuation.org>
CommitDate: 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 <felix@call-with-current-continuation.org>
    Date:   Mon Sep 26 08:34:10 2011 +0200
    
        added some testcases
    
    commit 2ab58471a67b474197714aeb98a17a44b6ca8416
    Author: felix <felix@call-with-current-continuation.org>
    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 115b118d..3f9ebfd3 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 299b92f8..cb95c0d6 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 a1048f40..6b687c8b 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))))
+