1
2#ifdef MZ_PRECISE_GC
3START_XFORM_SKIP;
4#endif
5
6#ifndef FP_ZEROx
7# define FP_ZEROx 0.0
8# define FP_ONEx 1.0
9# define FP_TWOx 2.0
10# define FP_POWx pow
11# define FP_MZ_IS_POS_INFINITY(x) MZ_IS_POS_INFINITY(x)
12# define FP_scheme_floating_point_nzero scheme_floating_point_nzero
13#endif
14
15/* Optimization sometimes causes a problem?
16   See note in "ratfloat.inc". */
17int IS_FLOAT_INF(FP_TYPE d)
18{
19  return FP_MZ_IS_POS_INFINITY(d);
20}
21
22/* Must not trigger GC! (Required by xform in number.c) */
23FP_TYPE SCHEME_BIGNUM_TO_FLOAT_INFO(const Scheme_Object *n, intptr_t skip, intptr_t *_skipped)
24{
25  intptr_t nl, skipped;
26  bigdig *na;
27  FP_TYPE d;
28
29  nl = SCHEME_BIGLEN(n);
30  na = SCHEME_BIGDIG(n);
31
32  skipped = nl;
33
34  if (skip >= nl) {
35    if (SCHEME_BIGPOS(n))
36      return FP_ZEROx;
37    else
38      return FP_scheme_floating_point_nzero;
39  } else
40    nl -= skip;
41
42  if (!nl)
43    d = FP_ZEROx;
44  else if (nl == 1) {
45    d = FP_TYPE_FROM_UINTPTR(*na);
46    skipped = 0;
47  } else {
48    /* We'll get all the bits that matter in the first word or two,
49       and we won't lose precision as long as we shift so that the
50       highest bit in a word is non-zero */
51    bigdig b = na[nl-1];
52    int delta;
53
54    delta = mz_clz(b);
55    if (delta) {
56      /* zero bits in the highest word => pull in bits from the
57         second-highest word */
58      b = (b << delta) + (na[nl-2] >> (WORD_SIZE - delta));
59    }
60    if (sizeof(FP_TYPE) <= sizeof(bigdig)) {
61      /* one bigdig is enough, and the last bit is certainly
62         not needed, but it needs to summarize whether there
63         are any more non-zero bits in the number */
64      if (!(b & 0x1) && any_nonzero_digits(na, nl-1, delta))
65        b |= 0x1;
66      d = FP_TYPE_FROM_UINTPTR(b);
67    } else {
68      /* Need to look at a second word, possibly pulling in bits from
69         a third word */
70      d = FP_TYPE_FROM_UINTPTR(b);
71      d = FP_TYPE_MULT(d, FP_TYPE_FROM_DOUBLE(BIG_RADIX));
72      b = (na[nl-2] << delta);
73      if ((nl > 2) && delta)
74        b += (na[nl-3] >> (WORD_SIZE - delta));
75      if (!(b & 0x1) && (nl > 2) && any_nonzero_digits(na, nl-2, delta))
76        b |= 0x1;
77      d = FP_TYPE_PLUS(d, FP_TYPE_FROM_UINTPTR(b));
78      d = FP_TYPE_DIV(d, FP_TYPE_FROM_DOUBLE(BIG_RADIX));
79    }
80    /* Shift `d` back down by delta: */
81    if (delta)
82      d = FP_TYPE_DIV(d, FP_TYPE_POW(FP_TYPE_FROM_DOUBLE(2.0),
83                                     FP_TYPE_FROM_INT(delta)));
84    nl--;
85
86    /* Shift `d` up by remaining bignum words */
87    if (_skipped) {
88      while (nl--) {
89        d = FP_TYPE_MULT(d, FP_TYPE_FROM_DOUBLE(BIG_RADIX));
90        if (IS_FLOAT_INF(d))
91          break;
92        --skipped;
93      }
94    } else {
95      d = FP_TYPE_MULT(d, FP_TYPE_POW(FP_TYPE_FROM_DOUBLE(2.0),
96                                      FP_TYPE_FROM_UINTPTR(nl * WORD_SIZE)));
97    }
98  }
99
100  if (_skipped)
101    *_skipped = skipped;
102
103  if (!SCHEME_BIGPOS(n))
104    d = FP_TYPE_NEG(d);
105
106  return d;
107}
108
109FP_TYPE SCHEME_BIGNUM_TO_FLOAT(const Scheme_Object *n)
110{
111  return SCHEME_BIGNUM_TO_FLOAT_INFO(n, 0, NULL);
112}
113
114#ifdef MZ_PRECISE_GC
115END_XFORM_SKIP;
116#endif
117
118Scheme_Object *SCHEME_BIGNUM_FROM_FLOAT(FP_TYPE d)
119{
120  Small_Bignum s1;
121  int negate, log, times, i;
122  FP_TYPE r;
123  Scheme_Object *n, *m;
124
125  r = FP_ONEx;
126
127  SCHEME_CHECK_FLOAT("inexact->exact", d, "integer");
128
129  if (FP_TYPE_LESS(d, FP_ZEROx)) {
130    negate = 1;
131    d = FP_TYPE_NEG(d);
132  } else
133    negate = 0;
134
135  if (FP_TYPE_LESS(d, FP_ONEx))
136    return scheme_make_integer(0);
137
138  log = 0;
139  while (FP_TYPE_LESS(r, d)) {
140    log++;
141    r = FP_TYPE_MULT(r, FP_TWOx);
142  }
143
144  if (log > USE_FLOAT_BITS) {
145    times = log - USE_FLOAT_BITS;
146    log = USE_FLOAT_BITS;
147    for (i = 0; i < times; i++) {
148      d = FP_TYPE_DIV(d, FP_TWOx);
149    }
150  } else
151    times = 0;
152
153  r = FP_POWx(FP_TWOx, FP_TYPE_FROM_INT(log));
154
155  n = scheme_make_small_bignum(0, &s1);
156
157  log++;
158  while (log--) {
159    bignum_double_inplace(&n);
160    if (FP_TYPE_GREATER_OR_EQV(d, r)) {
161      d = FP_TYPE_MINUS(d, r);
162      bignum_add1_inplace(&n);
163    }
164    r = FP_TYPE_DIV(r, FP_TWOx);
165  }
166
167  if (times) {
168    m = scheme_make_bignum(1);
169    while (times--) {
170      bignum_double_inplace(&m);
171    }
172    n = bignum_multiply(n, m, 0);
173  }
174
175  if (negate)
176    SCHEME_SET_BIGPOS(n, !SCHEME_BIGPOS(n));
177
178  n = scheme_bignum_normalize(n);
179
180  return n;
181}
182
183#undef USE_FLOAT_BITS
184#undef FP_TYPE
185#undef IS_FLOAT_INF
186#undef SCHEME_BIGNUM_TO_FLOAT_INFO
187#undef SCHEME_BIGNUM_TO_FLOAT
188#undef SCHEME_CHECK_FLOAT
189#undef SCHEME_BIGNUM_FROM_FLOAT
190#undef FP_ZEROx
191#undef FP_ONEx
192#undef FP_TWOx
193#undef FP_POWx
194#undef FP_MZ_IS_POS_INFINITY
195#undef FP_scheme_floating_point_nzero
196
197#undef FP_TYPE_FROM_DOUBLE
198#undef FP_TYPE_NEG
199#undef FP_TYPE_LESS
200#undef FP_TYPE_MULT
201#undef FP_TYPE_PLUS
202#undef FP_TYPE_DIV
203#undef FP_TYPE_POW
204#undef FP_TYPE_FROM_INT
205#undef FP_TYPE_GREATER_OR_EQV
206#undef FP_TYPE_MINUS
207#undef FP_TYPE_FROM_UINTPTR
208