~ chicken-core (chicken-5) d1f1408b7cbe21ad5679c1d1c02a45f63f2b8ccb

commit d1f1408b7cbe21ad5679c1d1c02a45f63f2b8ccb
Author:     felix <felix@call-with-current-continuation.org>
AuthorDate: Sat Aug 20 13:35:11 2011 +0200
Commit:     felix <felix@call-with-current-continuation.org>
CommitDate: Sat Aug 20 13:35:11 2011 +0200

    more tmatch tests

diff --git a/tests/typematch-tests.scm b/tests/typematch-tests.scm
index 9124598f..031196c5 100644
--- a/tests/typematch-tests.scm
+++ b/tests/typematch-tests.scm
@@ -46,6 +46,13 @@
 	  (compiler-typecase (,foo2)
 	    (,t1 'ok)))))))
 
+(define-syntax mx
+  (syntax-rules ()
+    ((_ t x) 
+     (compiler-typecase 
+      x
+      (t 'ok)))))
+
 (define-syntax mn
   (er-macro-transformer
    (lambda (x r c)
@@ -137,6 +144,9 @@
 (ms (##sys#make-structure 'promise) 1 (struct promise))
 (ms '(1 . 2.3) '(a) (pair fixnum float))
 (ms '#(a) 1 (vector symbol))
+(ms '(1) 'a (or pair symbol))
+(ms (list) 'a list)
+(ms '() 'a (or null pair))
 
 (checkp boolean? #t boolean)
 (checkp boolean? #f boolean)
@@ -170,3 +180,7 @@
 (mn (procedure (*) *) (procedure () *))
 (m (procedure (#!rest) . *) (procedure (*) . *))
 (mn (procedure () *) (procedure () * *))
+
+(mx (forall (a) (procedure (#!rest a) a) +))
+(mx (or pair null) '(1))
+(mx (or pair null) (list))
diff --git a/types.db.new b/types.db.new
index b1e00026..6e717fa5 100644
--- a/types.db.new
+++ b/types.db.new
@@ -1029,7 +1029,7 @@
 
 (alist-ref (procedure! alist-ref (* (list pair) #!optional (procedure (* *) *) *) *))
 (alist-update! (procedure! alist-update! (* * (list pair) #!optional (procedure (* *) *)) *))
-(always? (procedure always? (#!rest) boolean))
+(always? deprecated)
 
 (any? (procedure any? (*) boolean)
       ((*) (let ((#(tmp) #(1))) '#t)))
@@ -1059,14 +1059,10 @@
 (make-queue (procedure make-queue () (struct queue)))
 (merge (procedure! merge (list list (procedure (* *) *)) list))
 (merge! (procedure! merge! (list list (procedure (* *) *)) list))
-(never? (procedure never? (#!rest) boolean))
-
-(none? (procedure none? (*) boolean))
-
+(never? deprecated)
+(none? deprecated)
 (o (procedure! o (#!rest (procedure (*) *)) (procedure (*) *)))
-
 (queue->list (procedure! queue->list ((struct queue)) list))
-
 (queue-add! (procedure! queue-add! ((struct queue) *) undefined))
 
 (queue-empty? (procedure! queue-empty? ((struct queue)) boolean)