~ chicken-core (chicken-5) 20e7cae502b5efaa51f146c60940f1c68bb5f209

commit 20e7cae502b5efaa51f146c60940f1c68bb5f209
Author:     Evan Hanson <evhan@foldling.org>
AuthorDate: Sat Sep 6 09:10:18 2014 +1200
Commit:     Peter Bex <peter.bex@xs4all.nl>
CommitDate: Sun Oct 19 14:36:15 2014 +0200

    Add scrutiny special case for reverse and specialization for null argument
    
    This preserves the element types of list- and null-type arguments to
    reverse in its result type (rather than the less specialized list-of).
    
    Signed-off-by: Peter Bex <peter.bex@xs4all.nl>

diff --git a/scrutinizer.scm b/scrutinizer.scm
index afe3cabe..b363ccd2 100644
--- a/scrutinizer.scm
+++ b/scrutinizer.scm
@@ -2269,6 +2269,15 @@
   (lambda (node args rtypes)
     `((vector ,@(map walked-result (cdr args))))))
 
+(define-special-case reverse
+  (lambda (node args rtypes)
+    (or (and-let* ((subs (node-subexpressions node))
+		   ((= (length subs) 2))
+		   (arg1 (walked-result (second args)))
+		   ((pair? arg1))
+		   ((eq? (car arg1) 'list)))
+	  `((list ,@(reverse (cdr arg1)))))
+	rtypes)))
 
 ;;; Special cases for make-list/make-vector with a known size
 ;
diff --git a/tests/typematch-tests.scm b/tests/typematch-tests.scm
index 4374337b..930362fa 100644
--- a/tests/typematch-tests.scm
+++ b/tests/typematch-tests.scm
@@ -290,6 +290,10 @@
 (mx (list string string) (make-list 2 "a"))
 (mx (vector * *) (make-vector 2))
 (mx (vector string string) (make-vector 2 "a"))
+(mx null (reverse '()))
+(mx list (reverse (the list (list 1 "2"))))
+(mx (list string fixnum) (reverse (list 1 "2")))
+(mx (list fixnum string) (reverse (cons "1" (cons 2 '()))))
 
 (: f1 (forall (a) ((list-of a) -> a)))
 (define (f1 x) (car x))
diff --git a/types.db b/types.db
index 19f01f37..fb8557e5 100644
--- a/types.db
+++ b/types.db
@@ -170,7 +170,9 @@
 (append (#(procedure #:clean) append (#!rest *) *)) ; sic
 (##sys#append (#(procedure #:clean) ##sys#append (#!rest *) *))
 
-(reverse (forall (a) (#(procedure #:clean #:enforce) reverse ((list-of a)) (list-of a))))
+;; special cased (see scrutinizer.scm)
+(reverse (forall (a) (#(procedure #:clean #:enforce) reverse ((list-of a)) (list-of a)))
+         ((null) (null) (let ((#(tmp) #(1))) '())))
 
 (memq (forall (a b) (#(procedure #:clean) memq (a (list-of b)) (or false (list-of b))))
       ((* list) (##core#inline "C_u_i_memq" #(1) #(2))))