source: trunk/abcl/src/org/armedbear/lisp/coerce.lisp @ 14215

Last change on this file since 14215 was 12939, checked in by ehuelsmann, 10 years ago

Fix COERCE on a COMPLEX, being coerced to (COMPLEX <anything>);
this is excercised by Maxima.

  • Property svn:eol-style set to native
  • Property svn:keywords set to Id
File size: 5.2 KB
Line 
1;;; coerce.lisp
2;;;
3;;; Copyright (C) 2004-2005 Peter Graves
4;;; $Id: coerce.lisp 12939 2010-10-02 19:04:00Z ehuelsmann $
5;;;
6;;; This program is free software; you can redistribute it and/or
7;;; modify it under the terms of the GNU General Public License
8;;; as published by the Free Software Foundation; either version 2
9;;; of the License, or (at your option) any later version.
10;;;
11;;; This program is distributed in the hope that it will be useful,
12;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
13;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
14;;; GNU General Public License for more details.
15;;;
16;;; You should have received a copy of the GNU General Public License
17;;; along with this program; if not, write to the Free Software
18;;; Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA  02111-1307, USA.
19;;;
20;;; As a special exception, the copyright holders of this library give you
21;;; permission to link this library with independent modules to produce an
22;;; executable, regardless of the license terms of these independent
23;;; modules, and to copy and distribute the resulting executable under
24;;; terms of your choice, provided that you also meet, for each linked
25;;; independent module, the terms and conditions of the license of that
26;;; module.  An independent module is a module which is not derived from
27;;; or based on this library.  If you modify this library, you may extend
28;;; this exception to your version of the library, but you are not
29;;; obligated to do so.  If you do not wish to do so, delete this
30;;; exception statement from your version.
31
32(in-package #:system)
33
34(declaim (ftype (function (t) t) coerce-list-to-vector))
35(defun coerce-list-to-vector (list)
36  (let* ((length (length list))
37         (result (make-array length)))
38    (dotimes (i length)
39      (declare (type index i))
40      (setf (aref result i) (pop list)))
41    result))
42
43(declaim (ftype (function (string) simple-string) copy-string))
44(defun copy-string (string)
45  (declare (optimize speed (safety 0)))
46  (declare (type string string))
47  (let* ((length (length string))
48         (copy (make-string length)))
49    (dotimes (i length copy)
50      (declare (type fixnum i))
51      (setf (schar copy i) (char string i)))))
52
53(defun coerce-error (object result-type)
54  (error 'simple-type-error
55         :datum object
56         :format-control "~S cannot be converted to type ~S."
57         :format-arguments (list object result-type)))
58
59;; FIXME This is a special case for LOOP code, which does things like
60;; (AND SINGLE-FLOAT REAL) and (AND SINGLE-FLOAT (REAL (0))).
61(declaim (ftype (function (t t) t) coerce-object-to-and-type))
62(defun coerce-object-to-and-type (object result-type)
63  (when (and (consp result-type)
64             (eq (%car result-type) 'AND)
65             (= (length result-type) 3))
66    (let* ((type1 (%cadr result-type))
67           (type2 (%caddr result-type))
68           (result (coerce object type1)))
69      (when (typep object type2)
70        (return-from coerce-object-to-and-type result))))
71  (coerce-error object result-type))
72
73(defun coerce (object result-type)
74  (cond ((eq result-type t)
75         object)
76        ((typep object result-type)
77         object)
78        ((and (listp object)
79              (eq result-type 'vector))
80         (coerce-list-to-vector object))
81        ((and (stringp object) ; a string, but not a simple-string
82              (eq result-type 'simple-string))
83         (copy-string object))
84        ((eq result-type 'character)
85         (cond ((and (stringp object)
86                     (= (length object) 1))
87                (char object 0))
88               ((and (symbolp object)
89                     (= (length (symbol-name object)) 1))
90                (char (symbol-name object) 0))
91               (t
92                (coerce-error object result-type))))
93        ((memq result-type '(float single-float short-float))
94         (coerce-to-single-float object))
95        ((memq result-type '(double-float long-float))
96         (coerce-to-double-float object))
97        ((eq result-type 'complex)
98         (cond ((floatp object)
99                (complex object 0.0))
100               ((numberp object)
101                object)
102               (t
103                (coerce-error object result-type))))
104        ((eq result-type 'function)
105         (coerce-to-function object))
106        ((and (consp result-type)
107              (eq (%car result-type) 'complex))
108         (when (complexp object)
109           (return-from coerce
110             (complex (coerce (realpart object) (cadr result-type))
111                      (coerce (imagpart object) (cadr result-type)))))
112         (if (memq (%cadr result-type)
113                   '(float single-float double-float short-float long-float))
114             (complex (coerce object (cadr result-type))
115                      (coerce 0.0 (cadr result-type)))
116             object))
117        ((and (consp result-type)
118              (eq (%car result-type) 'AND))
119         (coerce-object-to-and-type object result-type))
120        ((and (simple-typep object 'sequence)
121              (%subtypep result-type 'sequence))
122         (concatenate result-type object))
123        (t
124         (let ((expanded-type (expand-deftype result-type)))
125           (unless (eq expanded-type result-type)
126             (return-from coerce (coerce object expanded-type))))
127         (coerce-error object result-type))))
Note: See TracBrowser for help on using the repository browser.