source: branches/0.17.x/abcl/src/org/armedbear/lisp/FloatFunctions.java

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

Remove 'throws ConditionThrowable?' method annotations:

it's an unchecked exception now, so no need to declare it thrown.
  • Property svn:eol-style set to native
  • Property svn:keywords set to Id
File size: 16.9 KB
Line 
1/*
2 * FloatFunctions.java
3 *
4 * Copyright (C) 2003-2006 Peter Graves
5 * $Id: FloatFunctions.java 12254 2009-11-06 20:07:54Z 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)
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()
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)
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)
153        {
154            if (arg instanceof SingleFloat) {
155                int bits = Float.floatToIntBits(((SingleFloat)arg).value);
156                BigInteger big = BigInteger.valueOf(bits >> 1);
157                return Bignum.getInstance(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 Bignum.getInstance(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)
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)
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)
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
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)
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)
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)
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
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)
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)
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)
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)
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
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
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
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
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)
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.