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