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

Last change on this file was 13440, checked in by ehuelsmann, 13 years ago

Rename writeToString() to printObject() since that's what it's being used for.
Additionally, create princToString() for use in error messages, making the

required replacement where appropriate.
  • 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 13440 2011-08-05 21:25:10Z 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 static org.armedbear.lisp.Lisp.*;
37
38import java.math.BigInteger;
39
40public final class FloatFunctions
41{
42    // ### set-floating-point-modes &key traps => <no values>
43    private static final Primitive SET_FLOATING_POINT_MODES =
44        new Primitive("set-floating-point-modes", PACKAGE_EXT, true,
45                      "&key traps")
46    {
47        @Override
48        public LispObject execute(LispObject[] args)
49        {
50            if (args.length % 2 != 0)
51                error(new ProgramError("Odd number of keyword arguments."));
52            for (int i = 0; i < args.length; i += 2) {
53                LispObject key = checkSymbol(args[i]);
54                LispObject value = args[i+1];
55                if (key == Keyword.TRAPS) {
56                    boolean trap_overflow  = false;
57                    boolean trap_underflow = false;
58                    while (value != NIL) {
59                        LispObject car = value.car();
60                        if (car == Keyword.OVERFLOW)
61                            trap_overflow = true;
62                        else if (car == Keyword.UNDERFLOW)
63                            trap_underflow = true;
64                        else
65                            error(new LispError("Unsupported floating point trap: " +
66                                                 car.princToString()));
67                        value = value.cdr();
68                    }
69                    TRAP_OVERFLOW  = trap_overflow;
70                    TRAP_UNDERFLOW = trap_underflow;
71                } else
72                    error(new LispError("Unrecognized keyword: " + key.princToString()));
73            }
74            return LispThread.currentThread().nothing();
75        }
76    };
77
78    // ### get-floating-point-modes => modes
79    private static final Primitive GET_FLOATING_POINT_MODES =
80        new Primitive("get-floating-point-modes", PACKAGE_EXT, true, "")
81    {
82        @Override
83        public LispObject execute()
84        {
85            LispObject traps = NIL;
86            if (TRAP_UNDERFLOW)
87                traps = traps.push(Keyword.UNDERFLOW);
88            if (TRAP_OVERFLOW)
89                traps = traps.push(Keyword.OVERFLOW);
90            return list(Keyword.TRAPS, traps);
91        }
92    };
93
94    // ### integer-decode-float float => significand, exponent, integer-sign
95    private static final Primitive INTEGER_DECODE_FLOAT =
96        new Primitive("integer-decode-float", "float")
97    {
98//         (defun sane-integer-decode-float (float)
99//           (multiple-value-bind (mantissa exp sign)
100//               (integer-decode-float float)
101//             (let ((fixup (- (integer-length mantissa) (float-precision float))))
102//                   (values (ash mantissa (- fixup))
103//                           (+ exp fixup)
104//                           sign))))
105
106        // See also: http://paste.lisp.org/display/10847
107
108        @Override
109        public LispObject execute(LispObject arg)
110        {
111            if (arg instanceof SingleFloat) {
112                int bits =
113                    Float.floatToRawIntBits(((SingleFloat)arg).value);
114                int s = ((bits >> 31) == 0) ? 1 : -1;
115                int e = (int) ((bits >> 23) & 0xffL);
116                int m;
117                if (e == 0)
118                    m = (bits & 0x7fffff) << 1;
119                else
120                    m = (bits & 0x7fffff) | 0x800000;
121                LispObject significand = number(m);
122                Fixnum exponent = Fixnum.getInstance(e - 150);
123                Fixnum sign = Fixnum.getInstance(s);
124                return LispThread.currentThread().setValues(significand,
125                                                            exponent,
126                                                            sign);
127            }
128            if (arg instanceof DoubleFloat) {
129                long bits =
130                    Double.doubleToRawLongBits((double)((DoubleFloat)arg).value);
131                int s = ((bits >> 63) == 0) ? 1 : -1;
132                int e = (int) ((bits >> 52) & 0x7ffL);
133                long m;
134                if (e == 0)
135                    m = (bits & 0xfffffffffffffL) << 1;
136                else
137                    m = (bits & 0xfffffffffffffL) | 0x10000000000000L;
138                LispObject significand = number(m);
139                Fixnum exponent = Fixnum.getInstance(e - 1075);
140                Fixnum sign = Fixnum.getInstance(s);
141                return LispThread.currentThread().setValues(significand,
142                                                            exponent,
143                                                            sign);
144            }
145            return type_error(arg, Symbol.FLOAT);
146        }
147    };
148
149    // ### %float-bits float => integer
150    private static final Primitive _FLOAT_BITS =
151        new Primitive("%float-bits", PACKAGE_SYS, true, "integer")
152    {
153        @Override
154        public LispObject execute(LispObject arg)
155        {
156            if (arg instanceof SingleFloat) {
157                int bits = Float.floatToIntBits(((SingleFloat)arg).value);
158                BigInteger big = BigInteger.valueOf(bits >> 1);
159                return Bignum.getInstance(big.shiftLeft(1).add(((bits & 1) == 1) ? BigInteger.ONE : BigInteger.ZERO));
160            }
161            if (arg instanceof DoubleFloat) {
162                long bits = Double.doubleToLongBits(((DoubleFloat)arg).value);
163                BigInteger big = BigInteger.valueOf(bits >> 1);
164                return Bignum.getInstance(big.shiftLeft(1).add(((bits & 1) == 1) ? BigInteger.ONE : BigInteger.ZERO));
165            }
166            return type_error(arg, Symbol.FLOAT);
167        }
168    };
169
170    // ### rational
171    private static final Primitive RATIONAL =
172        new Primitive("rational", "number")
173    {
174        @Override
175        public LispObject execute(LispObject arg)
176        {
177            if (arg instanceof SingleFloat)
178                return ((SingleFloat)arg).rational();
179            if (arg instanceof DoubleFloat)
180                return ((DoubleFloat)arg).rational();
181            if (arg.rationalp())
182                return arg;
183            return type_error(arg, Symbol.REAL);
184        }
185    };
186
187    // ### float-radix
188    // float-radix float => float-radix
189    private static final Primitive FLOAT_RADIX =
190        new Primitive("float-radix", "float")
191    {
192        @Override
193        public LispObject execute(LispObject arg)
194        {
195            if (arg instanceof SingleFloat || arg instanceof DoubleFloat)
196                return Fixnum.TWO;
197            return type_error(arg, Symbol.FLOAT);
198        }
199    };
200
201    static final Fixnum FIXNUM_24 = Fixnum.getInstance(24);
202    static final Fixnum FIXNUM_53 = Fixnum.getInstance(53);
203
204    // ### float-digits
205    // float-digits float => float-digits
206    private static final Primitive FLOAT_DIGITS =
207        new Primitive("float-digits", "float")
208    {
209        @Override
210        public LispObject execute(LispObject arg)
211        {
212            if (arg instanceof SingleFloat)
213                return FIXNUM_24;
214            if (arg instanceof DoubleFloat)
215                return FIXNUM_53;
216            return type_error(arg, Symbol.FLOAT);
217        }
218    };
219
220    // ### scale-float float integer => scaled-float
221    private static final Primitive SCALE_FLOAT =
222        new Primitive("scale-float", "float integer")
223    {
224        @Override
225        public LispObject execute(LispObject first, LispObject second)
226
227        {
228            if (first instanceof SingleFloat) {
229                float f = ((SingleFloat)first).value;
230                int n = Fixnum.getValue(second);
231                return new SingleFloat(f * (float) Math.pow(2, n));
232            }
233            if (first instanceof DoubleFloat) {
234                double d = ((DoubleFloat)first).value;
235                int n = Fixnum.getValue(second);
236                return new DoubleFloat(d * Math.pow(2, n));
237            }
238            return type_error(first, Symbol.FLOAT);
239        }
240    };
241
242    // ### coerce-to-single-float
243    private static final Primitive COERCE_TO_SINGLE_FLOAT =
244        new Primitive("coerce-to-single-float", PACKAGE_SYS, false)
245    {
246        @Override
247        public LispObject execute(LispObject arg)
248        {
249            return SingleFloat.coerceToFloat(arg);
250        }
251    };
252
253    // ### coerce-to-double-float
254    private static final Primitive COERCE_TO_DOUBLE_FLOAT =
255        new Primitive("coerce-to-double-float", PACKAGE_SYS, false)
256    {
257        @Override
258        public LispObject execute(LispObject arg)
259        {
260            return DoubleFloat.coerceToFloat(arg);
261        }
262    };
263
264    // ### float
265    // float number &optional prototype => float
266    private static final Primitive FLOAT =
267        new Primitive("float", "number &optional prototype")
268    {
269        @Override
270        public LispObject execute(LispObject arg)
271        {
272            if (arg instanceof SingleFloat || arg instanceof DoubleFloat)
273                return arg;
274            return SingleFloat.coerceToFloat(arg);
275        }
276        @Override
277        public LispObject execute(LispObject first, LispObject second)
278
279        {
280            if (second instanceof SingleFloat)
281                return SingleFloat.coerceToFloat(first);
282            if (second instanceof DoubleFloat)
283                return DoubleFloat.coerceToFloat(first);
284            return type_error(second, Symbol.FLOAT);
285        }
286    };
287
288    // ### floatp
289    // floatp object => generalized-boolean
290    private static final Primitive FLOATP = new Primitive("floatp", "object")
291    {
292        @Override
293        public LispObject execute(LispObject arg)
294        {
295            if (arg instanceof SingleFloat)
296                return T;
297            if (arg instanceof DoubleFloat)
298                return T;
299            return NIL;
300        }
301    };
302
303    // ### single-float-bits
304    private static final Primitive SINGLE_FLOAT_BITS =
305        new Primitive("single-float-bits", PACKAGE_SYS, true, "float")
306    {
307        @Override
308        public LispObject execute(LispObject arg)
309        {
310            if (arg instanceof SingleFloat) {
311                SingleFloat f = (SingleFloat) arg;
312                return Fixnum.getInstance(Float.floatToIntBits(f.value));
313            }
314            return type_error(arg, Symbol.FLOAT);
315        }
316    };
317
318    // ### double-float-high-bits
319    private static final Primitive DOUBLE_FLOAT_HIGH_BITS =
320        new Primitive("double-float-high-bits", PACKAGE_SYS, true, "float")
321    {
322        @Override
323        public LispObject execute(LispObject arg)
324        {
325            if (arg instanceof DoubleFloat) {
326                DoubleFloat f = (DoubleFloat) arg;
327                return number(Double.doubleToLongBits(f.value) >>> 32);
328            }
329            return type_error(arg, Symbol.DOUBLE_FLOAT);
330        }
331    };
332
333    // ### double-float-low-bits
334    private static final Primitive DOUBLE_FLOAT_LOW_BITS =
335        new Primitive("double-float-low-bits", PACKAGE_SYS, true, "float")
336    {
337        @Override
338        public LispObject execute(LispObject arg)
339        {
340            if (arg instanceof DoubleFloat) {
341                DoubleFloat f = (DoubleFloat) arg;
342                return number(Double.doubleToLongBits(f.value) & 0xffffffffL);
343            }
344            return type_error(arg, Symbol.DOUBLE_FLOAT);
345        }
346    };
347
348    // ### make-single-float bits => float
349    private static final Primitive MAKE_SINGLE_FLOAT =
350        new Primitive("make-single-float", PACKAGE_SYS, true, "bits")
351    {
352        @Override
353        public LispObject execute(LispObject arg)
354
355        {
356            if (arg instanceof Fixnum) {
357                int bits = ((Fixnum)arg).value;
358                return new SingleFloat(Float.intBitsToFloat(bits));
359            }
360            if (arg instanceof Bignum) {
361                long bits = ((Bignum)arg).value.longValue();
362                return new SingleFloat(Float.intBitsToFloat((int)bits));
363            }
364            return type_error(arg, Symbol.INTEGER);
365        }
366    };
367
368    // ### make-double-float bits => float
369    private static final Primitive MAKE_DOUBLE_FLOAT =
370        new Primitive("make-double-float", PACKAGE_SYS, true, "bits")
371    {
372        @Override
373        public LispObject execute(LispObject arg)
374
375        {
376            if (arg instanceof Fixnum) {
377                long bits = (long) ((Fixnum)arg).value;
378                return new DoubleFloat(Double.longBitsToDouble(bits));
379            }
380            if (arg instanceof Bignum) {
381                long bits = ((Bignum)arg).value.longValue();
382                return new DoubleFloat(Double.longBitsToDouble(bits));
383            }
384            return type_error(arg, Symbol.INTEGER);
385        }
386    };
387
388    // ### float-infinity-p
389    private static final Primitive FLOAT_INFINITY_P =
390        new Primitive("float-infinity-p", PACKAGE_SYS, true)
391    {
392        @Override
393        public LispObject execute(LispObject arg)
394
395        {
396            if (arg instanceof SingleFloat)
397                return Float.isInfinite(((SingleFloat)arg).value) ? T : NIL;
398            if (arg instanceof DoubleFloat)
399                return Double.isInfinite(((DoubleFloat)arg).value) ? T : NIL;
400            return type_error(arg, Symbol.FLOAT);
401        }
402    };
403
404    // ### float-nan-p
405    private static final Primitive FLOAT_NAN_P =
406        new Primitive("float-nan-p", PACKAGE_SYS, true)
407    {
408        @Override
409        public LispObject execute(LispObject arg)
410
411        {
412            if (arg instanceof SingleFloat)
413                return Float.isNaN(((SingleFloat)arg).value) ? T : NIL;
414            if (arg instanceof DoubleFloat)
415                return Double.isNaN(((DoubleFloat)arg).value) ? T : NIL;
416            return type_error(arg, Symbol.FLOAT);
417        }
418    };
419
420    // ### float-string
421    private static final Primitive FLOAT_STRING =
422        new Primitive("float-string", PACKAGE_SYS, true)
423    {
424        @Override
425        public LispObject execute(LispObject arg)
426        {
427            final String s1;
428            if (arg instanceof SingleFloat)
429                s1 = String.valueOf(((SingleFloat)arg).value);
430            else if (arg instanceof DoubleFloat)
431                s1 = String.valueOf(((DoubleFloat)arg).value);
432            else
433                return type_error(arg, Symbol.FLOAT);
434            int i = s1.indexOf('E');
435            if (i < 0)
436                return new SimpleString(s1);
437            String s2 = s1.substring(0, i);
438            int exponent = Integer.parseInt(s1.substring(i + 1));
439            if (exponent == 0)
440                return new SimpleString(s2);
441            int index = s2.indexOf('.');
442            if (index < 0)
443                return new SimpleString(s2);
444            StringBuffer sb = new StringBuffer(s2);
445            if (index >= 0)
446                sb.deleteCharAt(index);
447            // Now we've got just the digits in the StringBuffer.
448            if (exponent > 0) {
449                int newIndex = index + exponent;
450                if (newIndex < sb.length())
451                    sb.insert(newIndex, '.');
452                else if (newIndex == sb.length())
453                    sb.append('.');
454                else {
455                    // We need to add some zeros.
456                    while (newIndex > sb.length())
457                        sb.append('0');
458                    sb.append('.');
459                }
460            } else {
461                Debug.assertTrue(exponent < 0);
462                int newIndex = index + exponent;
463                while (newIndex < 0) {
464                    sb.insert(0, '0');
465                    ++newIndex;
466                }
467                sb.insert(0, '.');
468            }
469            return new SimpleString(sb.toString());
470        }
471    };
472}
Note: See TracBrowser for help on using the repository browser.