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

Last change on this file was 14465, checked in by rschlatte, 12 years ago

new method program_error, analogous to type_error
  • 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 14465 2013-04-24 12:50:37Z rschlatte $
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                program_error("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.