source: trunk/abcl/src/org/armedbear/lisp/FloatFunctions.java @ 11714

Last change on this file since 11714 was 11714, checked in by ehuelsmann, 16 years ago

Use the Fixnum factory instead of creating new Fixnums all over the place.

Patch by: Douglas Miles (logicmoo at gmail.com)
  • Property svn:eol-style set to native
  • Property svn:keywords set to Id
File size: 17.4 KB
Line 
1/*
2 * FloatFunctions.java
3 *
4 * Copyright (C) 2003-2006 Peter Graves
5 * $Id: FloatFunctions.java 11714 2009-03-23 20:05:37Z ehuelsmann $
6 *
7 * This program is free software; you can redistribute it and/or
8 * modify it under the terms of the GNU General Public License
9 * as published by the Free Software Foundation; either version 2
10 * of the License, or (at your option) any later version.
11 *
12 * This program is distributed in the hope that it will be useful,
13 * but WITHOUT ANY WARRANTY; without even the implied warranty of
14 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
15 * GNU General Public License for more details.
16 *
17 * You should have received a copy of the GNU General Public License
18 * along with this program; if not, write to the Free Software
19 * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA  02111-1307, USA.
20 *
21 * As a special exception, the copyright holders of this library give you
22 * permission to link this library with independent modules to produce an
23 * executable, regardless of the license terms of these independent
24 * modules, and to copy and distribute the resulting executable under
25 * terms of your choice, provided that you also meet, for each linked
26 * independent module, the terms and conditions of the license of that
27 * module.  An independent module is a module which is not derived from
28 * or based on this library.  If you modify this library, you may extend
29 * this exception to your version of the library, but you are not
30 * obligated to do so.  If you do not wish to do so, delete this
31 * exception statement from your version.
32 */
33
34package org.armedbear.lisp;
35
36import java.math.BigInteger;
37
38public final class FloatFunctions extends Lisp
39{
40    // ### set-floating-point-modes &key traps => <no values>
41    private static final Primitive SET_FLOATING_POINT_MODES =
42        new Primitive("set-floating-point-modes", PACKAGE_EXT, true,
43                      "&key traps")
44    {
45        @Override
46        public LispObject execute(LispObject[] args) throws ConditionThrowable
47        {
48            if (args.length % 2 != 0)
49                error(new ProgramError("Odd number of keyword arguments."));
50            for (int i = 0; i < args.length; i += 2) {
51                LispObject key = checkSymbol(args[i]);
52                LispObject value = args[i+1];
53                if (key == Keyword.TRAPS) {
54                    boolean trap_overflow  = false;
55                    boolean trap_underflow = false;
56                    while (value != NIL) {
57                        LispObject car = value.car();
58                        if (car == Keyword.OVERFLOW)
59                            trap_overflow = true;
60                        else if (car == Keyword.UNDERFLOW)
61                            trap_underflow = true;
62                        else
63                            error(new LispError("Unsupported floating point trap: " +
64                                                 car.writeToString()));
65                        value = value.cdr();
66                    }
67                    TRAP_OVERFLOW  = trap_overflow;
68                    TRAP_UNDERFLOW = trap_underflow;
69                } else
70                    error(new LispError("Unrecognized keyword: " + key.writeToString()));
71            }
72            return LispThread.currentThread().nothing();
73        }
74    };
75
76    // ### get-floating-point-modes => modes
77    private static final Primitive GET_FLOATING_POINT_MODES =
78        new Primitive("get-floating-point-modes", PACKAGE_EXT, true, "")
79    {
80        @Override
81        public LispObject execute() throws ConditionThrowable
82        {
83            LispObject traps = NIL;
84            if (TRAP_UNDERFLOW)
85                traps = traps.push(Keyword.UNDERFLOW);
86            if (TRAP_OVERFLOW)
87                traps = traps.push(Keyword.OVERFLOW);
88            return list(Keyword.TRAPS, traps);
89        }
90    };
91
92    // ### integer-decode-float float => significand, exponent, integer-sign
93    private static final Primitive INTEGER_DECODE_FLOAT =
94        new Primitive("integer-decode-float", "float")
95    {
96//         (defun sane-integer-decode-float (float)
97//           (multiple-value-bind (mantissa exp sign)
98//               (integer-decode-float float)
99//             (let ((fixup (- (integer-length mantissa) (float-precision float))))
100//                   (values (ash mantissa (- fixup))
101//                           (+ exp fixup)
102//                           sign))))
103
104        // See also: http://paste.lisp.org/display/10847
105
106        @Override
107        public LispObject execute(LispObject arg) throws ConditionThrowable
108        {
109            if (arg instanceof SingleFloat) {
110                int bits =
111                    Float.floatToRawIntBits(((SingleFloat)arg).value);
112                int s = ((bits >> 31) == 0) ? 1 : -1;
113                int e = (int) ((bits >> 23) & 0xffL);
114                int m;
115                if (e == 0)
116                    m = (bits & 0x7fffff) << 1;
117                else
118                    m = (bits & 0x7fffff) | 0x800000;
119                LispObject significand = number(m);
120                Fixnum exponent = Fixnum.getInstance(e - 150);
121                Fixnum sign = Fixnum.getInstance(s);
122                return LispThread.currentThread().setValues(significand,
123                                                            exponent,
124                                                            sign);
125            }
126            if (arg instanceof DoubleFloat) {
127                long bits =
128                    Double.doubleToRawLongBits((double)((DoubleFloat)arg).value);
129                int s = ((bits >> 63) == 0) ? 1 : -1;
130                int e = (int) ((bits >> 52) & 0x7ffL);
131                long m;
132                if (e == 0)
133                    m = (bits & 0xfffffffffffffL) << 1;
134                else
135                    m = (bits & 0xfffffffffffffL) | 0x10000000000000L;
136                LispObject significand = number(m);
137                Fixnum exponent = Fixnum.getInstance(e - 1075);
138                Fixnum sign = Fixnum.getInstance(s);
139                return LispThread.currentThread().setValues(significand,
140                                                            exponent,
141                                                            sign);
142            }
143            return type_error(arg, Symbol.FLOAT);
144        }
145    };
146
147    // ### %float-bits float => integer
148    private static final Primitive _FLOAT_BITS =
149        new Primitive("%float-bits", PACKAGE_SYS, true, "integer")
150    {
151        @Override
152        public LispObject execute(LispObject arg) throws ConditionThrowable
153        {
154            if (arg instanceof SingleFloat) {
155                int bits = Float.floatToIntBits(((SingleFloat)arg).value);
156                BigInteger big = BigInteger.valueOf(bits >> 1);
157                return new Bignum(big.shiftLeft(1).add(((bits & 1) == 1) ? BigInteger.ONE : BigInteger.ZERO));
158            }
159            if (arg instanceof DoubleFloat) {
160                long bits = Double.doubleToLongBits(((DoubleFloat)arg).value);
161                BigInteger big = BigInteger.valueOf(bits >> 1);
162                return new Bignum(big.shiftLeft(1).add(((bits & 1) == 1) ? BigInteger.ONE : BigInteger.ZERO));
163            }
164            return type_error(arg, Symbol.FLOAT);
165        }
166    };
167
168    // ### rational
169    private static final Primitive RATIONAL =
170        new Primitive("rational", "number")
171    {
172        @Override
173        public LispObject execute(LispObject arg) throws ConditionThrowable
174        {
175            if (arg instanceof SingleFloat)
176                return ((SingleFloat)arg).rational();
177            if (arg instanceof DoubleFloat)
178                return ((DoubleFloat)arg).rational();
179            if (arg.rationalp())
180                return arg;
181            return type_error(arg, Symbol.REAL);
182        }
183    };
184
185    // ### float-radix
186    // float-radix float => float-radix
187    private static final Primitive FLOAT_RADIX =
188        new Primitive("float-radix", "float")
189    {
190        @Override
191        public LispObject execute(LispObject arg) throws ConditionThrowable
192        {
193            if (arg instanceof SingleFloat || arg instanceof DoubleFloat)
194                return Fixnum.TWO;
195            return type_error(arg, Symbol.FLOAT);
196        }
197    };
198
199    private static final Fixnum FIXNUM_24 = Fixnum.getInstance(24);
200    private static final Fixnum FIXNUM_53 = Fixnum.getInstance(53);
201
202    // ### float-digits
203    // float-digits float => float-digits
204    private static final Primitive FLOAT_DIGITS =
205        new Primitive("float-digits", "float")
206    {
207        @Override
208        public LispObject execute(LispObject arg) throws ConditionThrowable
209        {
210            if (arg instanceof SingleFloat)
211                return FIXNUM_24;
212            if (arg instanceof DoubleFloat)
213                return FIXNUM_53;
214            return type_error(arg, Symbol.FLOAT);
215        }
216    };
217
218    // ### scale-float float integer => scaled-float
219    private static final Primitive SCALE_FLOAT =
220        new Primitive("scale-float", "float integer")
221    {
222        @Override
223        public LispObject execute(LispObject first, LispObject second)
224            throws ConditionThrowable
225        {
226            if (first instanceof SingleFloat) {
227                float f = ((SingleFloat)first).value;
228                int n = Fixnum.getValue(second);
229                return new SingleFloat(f * (float) Math.pow(2, n));
230            }
231            if (first instanceof DoubleFloat) {
232                double d = ((DoubleFloat)first).value;
233                int n = Fixnum.getValue(second);
234                return new DoubleFloat(d * Math.pow(2, n));
235            }
236            return type_error(first, Symbol.FLOAT);
237        }
238    };
239
240    // ### coerce-to-single-float
241    private static final Primitive COERCE_TO_SINGLE_FLOAT =
242        new Primitive("coerce-to-single-float", PACKAGE_SYS, false)
243    {
244        @Override
245        public LispObject execute(LispObject arg) throws ConditionThrowable
246        {
247            return SingleFloat.coerceToFloat(arg);
248        }
249    };
250
251    // ### coerce-to-double-float
252    private static final Primitive COERCE_TO_DOUBLE_FLOAT =
253        new Primitive("coerce-to-double-float", PACKAGE_SYS, false)
254    {
255        @Override
256        public LispObject execute(LispObject arg) throws ConditionThrowable
257        {
258            return DoubleFloat.coerceToFloat(arg);
259        }
260    };
261
262    // ### float
263    // float number &optional prototype => float
264    private static final Primitive FLOAT =
265        new Primitive("float", "number &optional prototype")
266    {
267        @Override
268        public LispObject execute(LispObject arg) throws ConditionThrowable
269        {
270            if (arg instanceof SingleFloat || arg instanceof DoubleFloat)
271                return arg;
272            return SingleFloat.coerceToFloat(arg);
273        }
274        @Override
275        public LispObject execute(LispObject first, LispObject second)
276            throws ConditionThrowable
277        {
278            if (second instanceof SingleFloat)
279                return SingleFloat.coerceToFloat(first);
280            if (second instanceof DoubleFloat)
281                return DoubleFloat.coerceToFloat(first);
282            return type_error(second, Symbol.FLOAT);
283        }
284    };
285
286    // ### floatp
287    // floatp object => generalized-boolean
288    private static final Primitive FLOATP = new Primitive("floatp", "object")
289    {
290        @Override
291        public LispObject execute(LispObject arg) throws ConditionThrowable
292        {
293            if (arg instanceof SingleFloat)
294                return T;
295            if (arg instanceof DoubleFloat)
296                return T;
297            return NIL;
298        }
299    };
300
301    // ### single-float-bits
302    private static final Primitive SINGLE_FLOAT_BITS =
303        new Primitive("single-float-bits", PACKAGE_SYS, true, "float")
304    {
305        @Override
306        public LispObject execute(LispObject arg) throws ConditionThrowable
307        {
308            if (arg instanceof SingleFloat) {
309                SingleFloat f = (SingleFloat) arg;
310                return Fixnum.getInstance(Float.floatToIntBits(f.value));
311            }
312            return type_error(arg, Symbol.FLOAT);
313        }
314    };
315
316    // ### double-float-high-bits
317    private static final Primitive DOUBLE_FLOAT_HIGH_BITS =
318        new Primitive("double-float-high-bits", PACKAGE_SYS, true, "float")
319    {
320        @Override
321        public LispObject execute(LispObject arg) throws ConditionThrowable
322        {
323            if (arg instanceof DoubleFloat) {
324                DoubleFloat f = (DoubleFloat) arg;
325                return number(Double.doubleToLongBits(f.value) >>> 32);
326            }
327            return type_error(arg, Symbol.DOUBLE_FLOAT);
328        }
329    };
330
331    // ### double-float-low-bits
332    private static final Primitive DOUBLE_FLOAT_LOW_BITS =
333        new Primitive("double-float-low-bits", PACKAGE_SYS, true, "float")
334    {
335        @Override
336        public LispObject execute(LispObject arg) throws ConditionThrowable
337        {
338            if (arg instanceof DoubleFloat) {
339                DoubleFloat f = (DoubleFloat) arg;
340                return number(Double.doubleToLongBits(f.value) & 0xffffffffL);
341            }
342            return type_error(arg, Symbol.DOUBLE_FLOAT);
343        }
344    };
345
346    // ### make-single-float bits => float
347    private static final Primitive MAKE_SINGLE_FLOAT =
348        new Primitive("make-single-float", PACKAGE_SYS, true, "bits")
349    {
350        @Override
351        public LispObject execute(LispObject arg)
352            throws ConditionThrowable
353        {
354            if (arg instanceof Fixnum) {
355                int bits = ((Fixnum)arg).value;
356                return new SingleFloat(Float.intBitsToFloat(bits));
357            }
358            if (arg instanceof Bignum) {
359                long bits = ((Bignum)arg).value.longValue();
360                return new SingleFloat(Float.intBitsToFloat((int)bits));
361            }
362            return type_error(arg, Symbol.INTEGER);
363        }
364    };
365
366    // ### make-double-float bits => float
367    private static final Primitive MAKE_DOUBLE_FLOAT =
368        new Primitive("make-double-float", PACKAGE_SYS, true, "bits")
369    {
370        @Override
371        public LispObject execute(LispObject arg)
372            throws ConditionThrowable
373        {
374            if (arg instanceof Fixnum) {
375                long bits = (long) ((Fixnum)arg).value;
376                return new DoubleFloat(Double.longBitsToDouble(bits));
377            }
378            if (arg instanceof Bignum) {
379                long bits = ((Bignum)arg).value.longValue();
380                return new DoubleFloat(Double.longBitsToDouble(bits));
381            }
382            return type_error(arg, Symbol.INTEGER);
383        }
384    };
385
386    // ### float-infinity-p
387    private static final Primitive FLOAT_INFINITY_P =
388        new Primitive("float-infinity-p", PACKAGE_SYS, true)
389    {
390        @Override
391        public LispObject execute(LispObject arg)
392            throws ConditionThrowable
393        {
394            if (arg instanceof SingleFloat)
395                return Float.isInfinite(((SingleFloat)arg).value) ? T : NIL;
396            if (arg instanceof DoubleFloat)
397                return Double.isInfinite(((DoubleFloat)arg).value) ? T : NIL;
398            return type_error(arg, Symbol.FLOAT);
399        }
400    };
401
402    // ### float-nan-p
403    private static final Primitive FLOAT_NAN_P =
404        new Primitive("float-nan-p", PACKAGE_SYS, true)
405    {
406        @Override
407        public LispObject execute(LispObject arg)
408            throws ConditionThrowable
409        {
410            if (arg instanceof SingleFloat)
411                return Float.isNaN(((SingleFloat)arg).value) ? T : NIL;
412            if (arg instanceof DoubleFloat)
413                return Double.isNaN(((DoubleFloat)arg).value) ? T : NIL;
414            return type_error(arg, Symbol.FLOAT);
415        }
416    };
417
418    // ### float-string
419    private static final Primitive FLOAT_STRING =
420        new Primitive("float-string", PACKAGE_SYS, true)
421    {
422        @Override
423        public LispObject execute(LispObject arg) throws ConditionThrowable
424        {
425            final String s1;
426            if (arg instanceof SingleFloat)
427                s1 = String.valueOf(((SingleFloat)arg).value);
428            else if (arg instanceof DoubleFloat)
429                s1 = String.valueOf(((DoubleFloat)arg).value);
430            else
431                return type_error(arg, Symbol.FLOAT);
432            int i = s1.indexOf('E');
433            if (i < 0)
434                return new SimpleString(s1);
435            String s2 = s1.substring(0, i);
436            int exponent = Integer.parseInt(s1.substring(i + 1));
437            if (exponent == 0)
438                return new SimpleString(s2);
439            int index = s2.indexOf('.');
440            if (index < 0)
441                return new SimpleString(s2);
442            StringBuffer sb = new StringBuffer(s2);
443            if (index >= 0)
444                sb.deleteCharAt(index);
445            // Now we've got just the digits in the StringBuffer.
446            if (exponent > 0) {
447                int newIndex = index + exponent;
448                if (newIndex < sb.length())
449                    sb.insert(newIndex, '.');
450                else if (newIndex == sb.length())
451                    sb.append('.');
452                else {
453                    // We need to add some zeros.
454                    while (newIndex > sb.length())
455                        sb.append('0');
456                    sb.append('.');
457                }
458            } else {
459                Debug.assertTrue(exponent < 0);
460                int newIndex = index + exponent;
461                while (newIndex < 0) {
462                    sb.insert(0, '0');
463                    ++newIndex;
464                }
465                sb.insert(0, '.');
466            }
467            return new SimpleString(sb.toString());
468        }
469    };
470}
Note: See TracBrowser for help on using the repository browser.