diff --git a/code/seq.lisp b/code/seq.lisp index f8981b5f3f75fe1317bc10094518de8b002295de..b163dbebac58f82bd1de494c3fc5bded8c727044 100644 --- a/code/seq.lisp +++ b/code/seq.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/code/seq.lisp,v 1.44 2002/11/20 16:17:12 toy Exp $") + "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/seq.lisp,v 1.45 2002/12/20 17:59:44 toy Exp $") ;;; ;;; ********************************************************************** ;;; @@ -974,7 +974,16 @@ :format-arguments (list object output-type-spec))) (check-seq-len (type length) (unless (valid-sequence-and-length-p type length) - (coerce-error)))) + (coerce-error))) + (output-type-or-lose (val) + ;; Verify that the value really is of type + ;; OUTPUT-TYPE-SPEC. If so, return the value. Intended + ;; to catch things like + ;; + ;; (coerce 2 '(single-float 5.0 6.0)) + (unless (typep val output-type-spec) + (coerce-error)) + val)) (let ((type (specifier-type output-type-spec))) (cond ((%typep object output-type-spec) @@ -989,14 +998,14 @@ (let ((res (cond ((csubtypep type (specifier-type 'single-float)) - (%single-float object)) + (output-type-or-lose (%single-float object))) ((csubtypep type (specifier-type 'double-float)) - (%double-float object)) + (output-type-or-lose (%double-float object))) #+long-float ((csubtypep type (specifier-type 'long-float)) - (%long-float object)) + (output-type-or-lose (%long-float object))) ((csubtypep type (specifier-type 'float)) - (%single-float object)) + (output-type-or-lose (%single-float object))) ((csubtypep type (specifier-type '(complex single-float))) (complex (%single-float (realpart object)) (%single-float (imagpart object))))