From 63c1a0fe550ca123f039fde73fd326d6cc94713c Mon Sep 17 00:00:00 2001
From: gerd <gerd>
Date: Sat, 2 Aug 2003 11:52:15 +0000
Subject: [PATCH] 	(deftype string-and-number () '(cons string (cons
 number null)))

	(defun bug1 (x)
	  (declare (type string-and-number x))
   	  (the number (car (reverse x))))

	(bug1 (list "one" 1))
	 => Type error 1 is not of type number.

	Reported by Luke Gorrie on cmucl-imp.

	* src/compiler/knownfun.lisp (result-type-first-arg/reverse)
	(reversed-cons-type): New functions.

	* src/compiler/fndb.lisp (nreverse, reverse): Use
	result-type-first-arg/reverse.
---
 compiler/fndb.lisp     |  6 +++---
 compiler/knownfun.lisp | 31 +++++++++++++++++++++++++++++--
 2 files changed, 32 insertions(+), 5 deletions(-)

diff --git a/compiler/fndb.lisp b/compiler/fndb.lisp
index 1ebf859c0..408e56f20 100644
--- a/compiler/fndb.lisp
+++ b/compiler/fndb.lisp
@@ -5,7 +5,7 @@
 ;;; Carnegie Mellon University, and has been placed in the public domain.
 ;;;
 (ext:file-comment
-  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/fndb.lisp,v 1.120 2003/07/30 16:51:43 toy Exp $")
+  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/fndb.lisp,v 1.121 2003/08/02 11:52:15 gerd Exp $")
 ;;;
 ;;; **********************************************************************
 ;;;
@@ -398,10 +398,10 @@
 (defknown length (sequence) index (foldable flushable))
 
 (defknown reverse (sequence) consed-sequence (flushable)
-  :derive-type #'result-type-first-arg)
+  :derive-type #'result-type-first-arg/reverse)
 
 (defknown nreverse (sequence) sequence ()
-  :derive-type #'result-type-first-arg)
+  :derive-type #'result-type-first-arg/reverse)
 
 (defknown make-sequence (type-specifier index &key (:initial-element t)) consed-sequence
   (movable flushable unsafe)
diff --git a/compiler/knownfun.lisp b/compiler/knownfun.lisp
index 287c807d4..6cbb5af2b 100644
--- a/compiler/knownfun.lisp
+++ b/compiler/knownfun.lisp
@@ -5,7 +5,7 @@
 ;;; Carnegie Mellon University, and has been placed in the public domain.
 ;;;
 (ext:file-comment
-  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/knownfun.lisp,v 1.24 2003/07/30 15:33:05 toy Exp $")
+  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/knownfun.lisp,v 1.25 2003/08/02 11:52:15 gerd Exp $")
 ;;;
 ;;; **********************************************************************
 ;;;
@@ -242,7 +242,34 @@
   (declare (type combination call))
   (let ((cont (first (combination-args call))))
     (when cont (continuation-type cont))))
-;;;
+
+(defun result-type-first-arg/reverse (call)
+  (declare (type combination call))
+  (let ((cont (first (combination-args call))))
+    (when cont
+      (let ((type (continuation-type cont)))
+	(if (cons-type-p type)
+	    (reversed-cons-type type)
+	    type)))))
+
+(defun reversed-cons-type (type)
+  (declare (type cons-type type))
+  (collect ((car-types))
+    (let ((cdr-type nil))
+      (loop for x = type then (cons-type-cdr-type x)
+	    while (cons-type-p x) do
+	    (let ((car (cons-type-car-type x))
+		  (cdr (cons-type-cdr-type x)))
+	      (car-types (type-specifier car))
+	      (setq cdr-type cdr)))
+      (let ((cons-type (specifier-type 'cons)))
+	(if (types-intersect cons-type cdr-type)
+	    cons-type
+	    (let ((spec 'null))
+	      (dolist (x (car-types))
+		(setq spec `(cons ,x ,spec)))
+	      (specifier-type spec)))))))
+
 (defun result-type-last-arg (call)
   (declare (type combination call))
   (let ((cont (car (last (combination-args call)))))
-- 
GitLab