Skip to content
Snippets Groups Projects
Commit 63c1a0fe authored by gerd's avatar gerd
Browse files

(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.
parent 0a335dfe
No related branches found
No related tags found
No related merge requests found
......@@ -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)
......
......@@ -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)))))
......
0% Loading or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment