source: trunk/j/src/org/armedbear/lisp/coerce.lisp @ 9266

Last change on this file since 9266 was 8784, checked in by piso, 16 years ago

SINGLE-FLOAT support.

File size: 3.0 KB
Line 
1;;; coerce.lisp
2;;;
3;;; Copyright (C) 2004-2005 Peter Graves
4;;; $Id: coerce.lisp,v 1.7 2005-03-17 14:59:03 piso Exp $
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(in-package #:system)
21
22(defun coerce-list-to-vector (list result-type)
23  (let* ((length (length list))
24         (result (make-sequence result-type length)))
25    (dotimes (i length)
26      (setf (aref result i) (pop list)))
27    result))
28
29(defun coerce-error (object result-type)
30  (error 'simple-type-error
31         :datum object
32         :format-control "~S cannot be converted to type ~S."
33         :format-arguments (list object result-type)))
34
35(defun coerce (object result-type)
36  (cond ((eq result-type t)
37         object)
38        ((typep object result-type)
39         object)
40        ((eq result-type 'character)
41         (cond ((and (stringp object)
42                     (= (length object) 1))
43                (char object 0))
44               ((and (symbolp object)
45                     (= (length (symbol-name object)) 1))
46                (char (symbol-name object) 0))
47               (t
48                (coerce-error object result-type))))
49        ((memq result-type '(float single-float short-float))
50         (coerce-to-single-float object))
51        ((memq result-type '(double-float long-float))
52         (coerce-to-double-float object))
53        ((eq result-type 'complex)
54         (cond ((floatp object)
55                (complex object 0.0))
56               ((numberp object)
57                object)
58               (t
59                (coerce-error object result-type))))
60        ((and (consp result-type)
61              (eq (car result-type) 'complex))
62         (if (memq (cadr result-type)
63                   '(float single-float double-float short-float long-float))
64             (complex object 0.0)
65             object))
66        ((eq result-type 'function)
67         (coerce-to-function object))
68        ((and (listp object)
69              (eq result-type 'vector))
70         (coerce-list-to-vector object result-type))
71        ((and (simple-typep object 'sequence)
72              (%subtypep result-type 'sequence))
73         (concatenate result-type object))
74        (t
75         (let ((expanded-type (expand-deftype result-type)))
76           (unless (eq expanded-type result-type)
77             (return-from coerce (coerce object expanded-type))))
78         (coerce-error object result-type))))
Note: See TracBrowser for help on using the repository browser.