This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
The revenge of the consts
[perl5.git] / numeric.c
CommitLineData
98994639
HS
1/* numeric.c
2 *
4bb101f2 3 * Copyright (C) 1993, 1994, 1995, 1996, 1997, 1998, 1999,
54ca4ee7 4 * 2000, 2001, 2002, 2003, 2004, 2005, 2006, by Larry Wall and others
98994639
HS
5 *
6 * You may distribute under the terms of either the GNU General Public
7 * License or the Artistic License, as specified in the README file.
8 *
9 */
10
11/*
12 * "That only makes eleven (plus one mislaid) and not fourteen, unless
13 * wizards count differently to other people."
14 */
15
ccfc67b7
JH
16/*
17=head1 Numeric functions
166f8a29
DM
18
19This file contains all the stuff needed by perl for manipulating numeric
20values, including such things as replacements for the OS's atof() function
21
22=cut
23
ccfc67b7
JH
24*/
25
98994639
HS
26#include "EXTERN.h"
27#define PERL_IN_NUMERIC_C
28#include "perl.h"
29
30U32
31Perl_cast_ulong(pTHX_ NV f)
32{
96a5add6 33 PERL_UNUSED_CONTEXT;
98994639
HS
34 if (f < 0.0)
35 return f < I32_MIN ? (U32) I32_MIN : (U32)(I32) f;
36 if (f < U32_MAX_P1) {
37#if CASTFLAGS & 2
38 if (f < U32_MAX_P1_HALF)
39 return (U32) f;
40 f -= U32_MAX_P1_HALF;
41 return ((U32) f) | (1 + U32_MAX >> 1);
42#else
43 return (U32) f;
44#endif
45 }
46 return f > 0 ? U32_MAX : 0 /* NaN */;
47}
48
49I32
50Perl_cast_i32(pTHX_ NV f)
51{
96a5add6 52 PERL_UNUSED_CONTEXT;
98994639
HS
53 if (f < I32_MAX_P1)
54 return f < I32_MIN ? I32_MIN : (I32) f;
55 if (f < U32_MAX_P1) {
56#if CASTFLAGS & 2
57 if (f < U32_MAX_P1_HALF)
58 return (I32)(U32) f;
59 f -= U32_MAX_P1_HALF;
60 return (I32)(((U32) f) | (1 + U32_MAX >> 1));
61#else
62 return (I32)(U32) f;
63#endif
64 }
65 return f > 0 ? (I32)U32_MAX : 0 /* NaN */;
66}
67
68IV
69Perl_cast_iv(pTHX_ NV f)
70{
96a5add6 71 PERL_UNUSED_CONTEXT;
98994639
HS
72 if (f < IV_MAX_P1)
73 return f < IV_MIN ? IV_MIN : (IV) f;
74 if (f < UV_MAX_P1) {
75#if CASTFLAGS & 2
76 /* For future flexibility allowing for sizeof(UV) >= sizeof(IV) */
77 if (f < UV_MAX_P1_HALF)
78 return (IV)(UV) f;
79 f -= UV_MAX_P1_HALF;
80 return (IV)(((UV) f) | (1 + UV_MAX >> 1));
81#else
82 return (IV)(UV) f;
83#endif
84 }
85 return f > 0 ? (IV)UV_MAX : 0 /* NaN */;
86}
87
88UV
89Perl_cast_uv(pTHX_ NV f)
90{
96a5add6 91 PERL_UNUSED_CONTEXT;
98994639
HS
92 if (f < 0.0)
93 return f < IV_MIN ? (UV) IV_MIN : (UV)(IV) f;
94 if (f < UV_MAX_P1) {
95#if CASTFLAGS & 2
96 if (f < UV_MAX_P1_HALF)
97 return (UV) f;
98 f -= UV_MAX_P1_HALF;
99 return ((UV) f) | (1 + UV_MAX >> 1);
100#else
101 return (UV) f;
102#endif
103 }
104 return f > 0 ? UV_MAX : 0 /* NaN */;
105}
106
53305cf1
NC
107/*
108=for apidoc grok_bin
98994639 109
53305cf1
NC
110converts a string representing a binary number to numeric form.
111
112On entry I<start> and I<*len> give the string to scan, I<*flags> gives
113conversion flags, and I<result> should be NULL or a pointer to an NV.
114The scan stops at the end of the string, or the first invalid character.
7b667b5f
MHM
115Unless C<PERL_SCAN_SILENT_ILLDIGIT> is set in I<*flags>, encountering an
116invalid character will also trigger a warning.
117On return I<*len> is set to the length of the scanned string,
118and I<*flags> gives output flags.
53305cf1 119
7fc63493 120If the value is <= C<UV_MAX> it is returned as a UV, the output flags are clear,
53305cf1
NC
121and nothing is written to I<*result>. If the value is > UV_MAX C<grok_bin>
122returns UV_MAX, sets C<PERL_SCAN_GREATER_THAN_UV_MAX> in the output flags,
123and writes the value to I<*result> (or the value is discarded if I<result>
124is NULL).
125
7b667b5f 126The binary number may optionally be prefixed with "0b" or "b" unless
a4c04bdc
NC
127C<PERL_SCAN_DISALLOW_PREFIX> is set in I<*flags> on entry. If
128C<PERL_SCAN_ALLOW_UNDERSCORES> is set in I<*flags> then the binary
53305cf1
NC
129number may use '_' characters to separate digits.
130
131=cut
132 */
133
134UV
7fc63493 135Perl_grok_bin(pTHX_ const char *start, STRLEN *len_p, I32 *flags, NV *result) {
53305cf1
NC
136 const char *s = start;
137 STRLEN len = *len_p;
138 UV value = 0;
139 NV value_nv = 0;
140
141 const UV max_div_2 = UV_MAX / 2;
585ec06d 142 const bool allow_underscores = (bool)(*flags & PERL_SCAN_ALLOW_UNDERSCORES);
53305cf1 143 bool overflowed = FALSE;
7fc63493 144 char bit;
53305cf1 145
a4c04bdc
NC
146 if (!(*flags & PERL_SCAN_DISALLOW_PREFIX)) {
147 /* strip off leading b or 0b.
148 for compatibility silently suffer "b" and "0b" as valid binary
149 numbers. */
150 if (len >= 1) {
151 if (s[0] == 'b') {
152 s++;
153 len--;
154 }
155 else if (len >= 2 && s[0] == '0' && s[1] == 'b') {
156 s+=2;
157 len-=2;
158 }
159 }
53305cf1
NC
160 }
161
7fc63493 162 for (; len-- && (bit = *s); s++) {
53305cf1
NC
163 if (bit == '0' || bit == '1') {
164 /* Write it in this wonky order with a goto to attempt to get the
165 compiler to make the common case integer-only loop pretty tight.
166 With gcc seems to be much straighter code than old scan_bin. */
167 redo:
168 if (!overflowed) {
169 if (value <= max_div_2) {
170 value = (value << 1) | (bit - '0');
171 continue;
172 }
173 /* Bah. We're just overflowed. */
174 if (ckWARN_d(WARN_OVERFLOW))
9014280d 175 Perl_warner(aTHX_ packWARN(WARN_OVERFLOW),
53305cf1
NC
176 "Integer overflow in binary number");
177 overflowed = TRUE;
178 value_nv = (NV) value;
179 }
180 value_nv *= 2.0;
98994639 181 /* If an NV has not enough bits in its mantissa to
d1be9408 182 * represent a UV this summing of small low-order numbers
98994639
HS
183 * is a waste of time (because the NV cannot preserve
184 * the low-order bits anyway): we could just remember when
53305cf1 185 * did we overflow and in the end just multiply value_nv by the
98994639 186 * right amount. */
53305cf1
NC
187 value_nv += (NV)(bit - '0');
188 continue;
189 }
190 if (bit == '_' && len && allow_underscores && (bit = s[1])
191 && (bit == '0' || bit == '1'))
98994639
HS
192 {
193 --len;
194 ++s;
53305cf1 195 goto redo;
98994639 196 }
94dd8549 197 if (!(*flags & PERL_SCAN_SILENT_ILLDIGIT) && ckWARN(WARN_DIGIT))
9014280d 198 Perl_warner(aTHX_ packWARN(WARN_DIGIT),
53305cf1
NC
199 "Illegal binary digit '%c' ignored", *s);
200 break;
98994639 201 }
53305cf1
NC
202
203 if ( ( overflowed && value_nv > 4294967295.0)
98994639 204#if UVSIZE > 4
53305cf1 205 || (!overflowed && value > 0xffffffff )
98994639
HS
206#endif
207 ) {
208 if (ckWARN(WARN_PORTABLE))
9014280d 209 Perl_warner(aTHX_ packWARN(WARN_PORTABLE),
53305cf1
NC
210 "Binary number > 0b11111111111111111111111111111111 non-portable");
211 }
212 *len_p = s - start;
213 if (!overflowed) {
214 *flags = 0;
215 return value;
98994639 216 }
53305cf1
NC
217 *flags = PERL_SCAN_GREATER_THAN_UV_MAX;
218 if (result)
219 *result = value_nv;
220 return UV_MAX;
98994639
HS
221}
222
53305cf1
NC
223/*
224=for apidoc grok_hex
225
226converts a string representing a hex number to numeric form.
227
228On entry I<start> and I<*len> give the string to scan, I<*flags> gives
229conversion flags, and I<result> should be NULL or a pointer to an NV.
7b667b5f
MHM
230The scan stops at the end of the string, or the first invalid character.
231Unless C<PERL_SCAN_SILENT_ILLDIGIT> is set in I<*flags>, encountering an
232invalid character will also trigger a warning.
233On return I<*len> is set to the length of the scanned string,
234and I<*flags> gives output flags.
53305cf1
NC
235
236If the value is <= UV_MAX it is returned as a UV, the output flags are clear,
237and nothing is written to I<*result>. If the value is > UV_MAX C<grok_hex>
238returns UV_MAX, sets C<PERL_SCAN_GREATER_THAN_UV_MAX> in the output flags,
239and writes the value to I<*result> (or the value is discarded if I<result>
240is NULL).
241
d1be9408 242The hex number may optionally be prefixed with "0x" or "x" unless
a4c04bdc
NC
243C<PERL_SCAN_DISALLOW_PREFIX> is set in I<*flags> on entry. If
244C<PERL_SCAN_ALLOW_UNDERSCORES> is set in I<*flags> then the hex
53305cf1
NC
245number may use '_' characters to separate digits.
246
247=cut
248 */
249
250UV
7fc63493 251Perl_grok_hex(pTHX_ const char *start, STRLEN *len_p, I32 *flags, NV *result) {
27da23d5 252 dVAR;
53305cf1
NC
253 const char *s = start;
254 STRLEN len = *len_p;
255 UV value = 0;
256 NV value_nv = 0;
257
258 const UV max_div_16 = UV_MAX / 16;
585ec06d 259 const bool allow_underscores = (bool)(*flags & PERL_SCAN_ALLOW_UNDERSCORES);
53305cf1 260 bool overflowed = FALSE;
98994639 261
a4c04bdc
NC
262 if (!(*flags & PERL_SCAN_DISALLOW_PREFIX)) {
263 /* strip off leading x or 0x.
264 for compatibility silently suffer "x" and "0x" as valid hex numbers.
265 */
266 if (len >= 1) {
267 if (s[0] == 'x') {
268 s++;
269 len--;
270 }
271 else if (len >= 2 && s[0] == '0' && s[1] == 'x') {
272 s+=2;
273 len-=2;
274 }
275 }
98994639
HS
276 }
277
278 for (; len-- && *s; s++) {
a3b680e6 279 const char *hexdigit = strchr(PL_hexdigit, *s);
53305cf1
NC
280 if (hexdigit) {
281 /* Write it in this wonky order with a goto to attempt to get the
282 compiler to make the common case integer-only loop pretty tight.
283 With gcc seems to be much straighter code than old scan_hex. */
284 redo:
285 if (!overflowed) {
286 if (value <= max_div_16) {
287 value = (value << 4) | ((hexdigit - PL_hexdigit) & 15);
288 continue;
289 }
290 /* Bah. We're just overflowed. */
291 if (ckWARN_d(WARN_OVERFLOW))
9014280d 292 Perl_warner(aTHX_ packWARN(WARN_OVERFLOW),
53305cf1
NC
293 "Integer overflow in hexadecimal number");
294 overflowed = TRUE;
295 value_nv = (NV) value;
296 }
297 value_nv *= 16.0;
298 /* If an NV has not enough bits in its mantissa to
d1be9408 299 * represent a UV this summing of small low-order numbers
53305cf1
NC
300 * is a waste of time (because the NV cannot preserve
301 * the low-order bits anyway): we could just remember when
302 * did we overflow and in the end just multiply value_nv by the
303 * right amount of 16-tuples. */
304 value_nv += (NV)((hexdigit - PL_hexdigit) & 15);
305 continue;
306 }
307 if (*s == '_' && len && allow_underscores && s[1]
e1ec3a88 308 && (hexdigit = strchr(PL_hexdigit, s[1])))
98994639
HS
309 {
310 --len;
311 ++s;
53305cf1 312 goto redo;
98994639 313 }
94dd8549 314 if (!(*flags & PERL_SCAN_SILENT_ILLDIGIT) && ckWARN(WARN_DIGIT))
9014280d 315 Perl_warner(aTHX_ packWARN(WARN_DIGIT),
53305cf1
NC
316 "Illegal hexadecimal digit '%c' ignored", *s);
317 break;
318 }
319
320 if ( ( overflowed && value_nv > 4294967295.0)
321#if UVSIZE > 4
322 || (!overflowed && value > 0xffffffff )
323#endif
324 ) {
325 if (ckWARN(WARN_PORTABLE))
9014280d 326 Perl_warner(aTHX_ packWARN(WARN_PORTABLE),
53305cf1
NC
327 "Hexadecimal number > 0xffffffff non-portable");
328 }
329 *len_p = s - start;
330 if (!overflowed) {
331 *flags = 0;
332 return value;
333 }
334 *flags = PERL_SCAN_GREATER_THAN_UV_MAX;
335 if (result)
336 *result = value_nv;
337 return UV_MAX;
338}
339
340/*
341=for apidoc grok_oct
342
7b667b5f
MHM
343converts a string representing an octal number to numeric form.
344
345On entry I<start> and I<*len> give the string to scan, I<*flags> gives
346conversion flags, and I<result> should be NULL or a pointer to an NV.
347The scan stops at the end of the string, or the first invalid character.
348Unless C<PERL_SCAN_SILENT_ILLDIGIT> is set in I<*flags>, encountering an
349invalid character will also trigger a warning.
350On return I<*len> is set to the length of the scanned string,
351and I<*flags> gives output flags.
352
353If the value is <= UV_MAX it is returned as a UV, the output flags are clear,
354and nothing is written to I<*result>. If the value is > UV_MAX C<grok_oct>
355returns UV_MAX, sets C<PERL_SCAN_GREATER_THAN_UV_MAX> in the output flags,
356and writes the value to I<*result> (or the value is discarded if I<result>
357is NULL).
358
359If C<PERL_SCAN_ALLOW_UNDERSCORES> is set in I<*flags> then the octal
360number may use '_' characters to separate digits.
53305cf1
NC
361
362=cut
363 */
364
365UV
7fc63493 366Perl_grok_oct(pTHX_ const char *start, STRLEN *len_p, I32 *flags, NV *result) {
53305cf1
NC
367 const char *s = start;
368 STRLEN len = *len_p;
369 UV value = 0;
370 NV value_nv = 0;
371
372 const UV max_div_8 = UV_MAX / 8;
585ec06d 373 const bool allow_underscores = (bool)(*flags & PERL_SCAN_ALLOW_UNDERSCORES);
53305cf1
NC
374 bool overflowed = FALSE;
375
376 for (; len-- && *s; s++) {
377 /* gcc 2.95 optimiser not smart enough to figure that this subtraction
378 out front allows slicker code. */
379 int digit = *s - '0';
380 if (digit >= 0 && digit <= 7) {
381 /* Write it in this wonky order with a goto to attempt to get the
382 compiler to make the common case integer-only loop pretty tight.
383 */
384 redo:
385 if (!overflowed) {
386 if (value <= max_div_8) {
387 value = (value << 3) | digit;
388 continue;
389 }
390 /* Bah. We're just overflowed. */
391 if (ckWARN_d(WARN_OVERFLOW))
9014280d 392 Perl_warner(aTHX_ packWARN(WARN_OVERFLOW),
53305cf1
NC
393 "Integer overflow in octal number");
394 overflowed = TRUE;
395 value_nv = (NV) value;
396 }
397 value_nv *= 8.0;
98994639 398 /* If an NV has not enough bits in its mantissa to
d1be9408 399 * represent a UV this summing of small low-order numbers
98994639
HS
400 * is a waste of time (because the NV cannot preserve
401 * the low-order bits anyway): we could just remember when
53305cf1
NC
402 * did we overflow and in the end just multiply value_nv by the
403 * right amount of 8-tuples. */
404 value_nv += (NV)digit;
405 continue;
406 }
407 if (digit == ('_' - '0') && len && allow_underscores
408 && (digit = s[1] - '0') && (digit >= 0 && digit <= 7))
409 {
410 --len;
411 ++s;
412 goto redo;
413 }
414 /* Allow \octal to work the DWIM way (that is, stop scanning
7b667b5f 415 * as soon as non-octal characters are seen, complain only if
53305cf1
NC
416 * someone seems to want to use the digits eight and nine). */
417 if (digit == 8 || digit == 9) {
94dd8549 418 if (!(*flags & PERL_SCAN_SILENT_ILLDIGIT) && ckWARN(WARN_DIGIT))
9014280d 419 Perl_warner(aTHX_ packWARN(WARN_DIGIT),
53305cf1
NC
420 "Illegal octal digit '%c' ignored", *s);
421 }
422 break;
98994639 423 }
53305cf1
NC
424
425 if ( ( overflowed && value_nv > 4294967295.0)
98994639 426#if UVSIZE > 4
53305cf1 427 || (!overflowed && value > 0xffffffff )
98994639
HS
428#endif
429 ) {
430 if (ckWARN(WARN_PORTABLE))
9014280d 431 Perl_warner(aTHX_ packWARN(WARN_PORTABLE),
53305cf1
NC
432 "Octal number > 037777777777 non-portable");
433 }
434 *len_p = s - start;
435 if (!overflowed) {
436 *flags = 0;
437 return value;
98994639 438 }
53305cf1
NC
439 *flags = PERL_SCAN_GREATER_THAN_UV_MAX;
440 if (result)
441 *result = value_nv;
442 return UV_MAX;
443}
444
445/*
446=for apidoc scan_bin
447
448For backwards compatibility. Use C<grok_bin> instead.
449
450=for apidoc scan_hex
451
452For backwards compatibility. Use C<grok_hex> instead.
453
454=for apidoc scan_oct
455
456For backwards compatibility. Use C<grok_oct> instead.
457
458=cut
459 */
460
461NV
73d840c0 462Perl_scan_bin(pTHX_ const char *start, STRLEN len, STRLEN *retlen)
53305cf1
NC
463{
464 NV rnv;
465 I32 flags = *retlen ? PERL_SCAN_ALLOW_UNDERSCORES : 0;
73d840c0 466 const UV ruv = grok_bin (start, &len, &flags, &rnv);
53305cf1
NC
467
468 *retlen = len;
469 return (flags & PERL_SCAN_GREATER_THAN_UV_MAX) ? rnv : (NV)ruv;
470}
471
472NV
73d840c0 473Perl_scan_oct(pTHX_ const char *start, STRLEN len, STRLEN *retlen)
53305cf1
NC
474{
475 NV rnv;
476 I32 flags = *retlen ? PERL_SCAN_ALLOW_UNDERSCORES : 0;
73d840c0 477 const UV ruv = grok_oct (start, &len, &flags, &rnv);
53305cf1
NC
478
479 *retlen = len;
480 return (flags & PERL_SCAN_GREATER_THAN_UV_MAX) ? rnv : (NV)ruv;
481}
482
483NV
73d840c0 484Perl_scan_hex(pTHX_ const char *start, STRLEN len, STRLEN *retlen)
53305cf1
NC
485{
486 NV rnv;
487 I32 flags = *retlen ? PERL_SCAN_ALLOW_UNDERSCORES : 0;
73d840c0 488 const UV ruv = grok_hex (start, &len, &flags, &rnv);
53305cf1
NC
489
490 *retlen = len;
491 return (flags & PERL_SCAN_GREATER_THAN_UV_MAX) ? rnv : (NV)ruv;
98994639
HS
492}
493
494/*
495=for apidoc grok_numeric_radix
496
497Scan and skip for a numeric decimal separator (radix).
498
499=cut
500 */
501bool
502Perl_grok_numeric_radix(pTHX_ const char **sp, const char *send)
503{
504#ifdef USE_LOCALE_NUMERIC
97aff369 505 dVAR;
98994639
HS
506 if (PL_numeric_radix_sv && IN_LOCALE) {
507 STRLEN len;
c4420975 508 const char * const radix = SvPV(PL_numeric_radix_sv, len);
98994639
HS
509 if (*sp + len <= send && memEQ(*sp, radix, len)) {
510 *sp += len;
511 return TRUE;
512 }
513 }
514 /* always try "." if numeric radix didn't match because
515 * we may have data from different locales mixed */
516#endif
517 if (*sp < send && **sp == '.') {
518 ++*sp;
519 return TRUE;
520 }
521 return FALSE;
522}
523
524/*
525=for apidoc grok_number
526
527Recognise (or not) a number. The type of the number is returned
528(0 if unrecognised), otherwise it is a bit-ORed combination of
529IS_NUMBER_IN_UV, IS_NUMBER_GREATER_THAN_UV_MAX, IS_NUMBER_NOT_INT,
aa8b85de 530IS_NUMBER_NEG, IS_NUMBER_INFINITY, IS_NUMBER_NAN (defined in perl.h).
60939fb8
NC
531
532If the value of the number can fit an in UV, it is returned in the *valuep
533IS_NUMBER_IN_UV will be set to indicate that *valuep is valid, IS_NUMBER_IN_UV
534will never be set unless *valuep is valid, but *valuep may have been assigned
535to during processing even though IS_NUMBER_IN_UV is not set on return.
536If valuep is NULL, IS_NUMBER_IN_UV will be set for the same cases as when
537valuep is non-NULL, but no actual assignment (or SEGV) will occur.
538
539IS_NUMBER_NOT_INT will be set with IS_NUMBER_IN_UV if trailing decimals were
540seen (in which case *valuep gives the true value truncated to an integer), and
541IS_NUMBER_NEG if the number is negative (in which case *valuep holds the
542absolute value). IS_NUMBER_IN_UV is not set if e notation was used or the
543number is larger than a UV.
98994639
HS
544
545=cut
546 */
547int
548Perl_grok_number(pTHX_ const char *pv, STRLEN len, UV *valuep)
549{
60939fb8 550 const char *s = pv;
c4420975 551 const char * const send = pv + len;
60939fb8
NC
552 const UV max_div_10 = UV_MAX / 10;
553 const char max_mod_10 = UV_MAX % 10;
554 int numtype = 0;
555 int sawinf = 0;
aa8b85de 556 int sawnan = 0;
60939fb8
NC
557
558 while (s < send && isSPACE(*s))
559 s++;
560 if (s == send) {
561 return 0;
562 } else if (*s == '-') {
563 s++;
564 numtype = IS_NUMBER_NEG;
565 }
566 else if (*s == '+')
567 s++;
568
569 if (s == send)
570 return 0;
571
572 /* next must be digit or the radix separator or beginning of infinity */
573 if (isDIGIT(*s)) {
574 /* UVs are at least 32 bits, so the first 9 decimal digits cannot
575 overflow. */
576 UV value = *s - '0';
577 /* This construction seems to be more optimiser friendly.
578 (without it gcc does the isDIGIT test and the *s - '0' separately)
579 With it gcc on arm is managing 6 instructions (6 cycles) per digit.
580 In theory the optimiser could deduce how far to unroll the loop
581 before checking for overflow. */
58bb9ec3
NC
582 if (++s < send) {
583 int digit = *s - '0';
60939fb8
NC
584 if (digit >= 0 && digit <= 9) {
585 value = value * 10 + digit;
58bb9ec3
NC
586 if (++s < send) {
587 digit = *s - '0';
60939fb8
NC
588 if (digit >= 0 && digit <= 9) {
589 value = value * 10 + digit;
58bb9ec3
NC
590 if (++s < send) {
591 digit = *s - '0';
60939fb8
NC
592 if (digit >= 0 && digit <= 9) {
593 value = value * 10 + digit;
58bb9ec3
NC
594 if (++s < send) {
595 digit = *s - '0';
60939fb8
NC
596 if (digit >= 0 && digit <= 9) {
597 value = value * 10 + digit;
58bb9ec3
NC
598 if (++s < send) {
599 digit = *s - '0';
60939fb8
NC
600 if (digit >= 0 && digit <= 9) {
601 value = value * 10 + digit;
58bb9ec3
NC
602 if (++s < send) {
603 digit = *s - '0';
60939fb8
NC
604 if (digit >= 0 && digit <= 9) {
605 value = value * 10 + digit;
58bb9ec3
NC
606 if (++s < send) {
607 digit = *s - '0';
60939fb8
NC
608 if (digit >= 0 && digit <= 9) {
609 value = value * 10 + digit;
58bb9ec3
NC
610 if (++s < send) {
611 digit = *s - '0';
60939fb8
NC
612 if (digit >= 0 && digit <= 9) {
613 value = value * 10 + digit;
58bb9ec3 614 if (++s < send) {
60939fb8
NC
615 /* Now got 9 digits, so need to check
616 each time for overflow. */
58bb9ec3 617 digit = *s - '0';
60939fb8
NC
618 while (digit >= 0 && digit <= 9
619 && (value < max_div_10
620 || (value == max_div_10
621 && digit <= max_mod_10))) {
622 value = value * 10 + digit;
58bb9ec3
NC
623 if (++s < send)
624 digit = *s - '0';
60939fb8
NC
625 else
626 break;
627 }
628 if (digit >= 0 && digit <= 9
51bd16da 629 && (s < send)) {
60939fb8
NC
630 /* value overflowed.
631 skip the remaining digits, don't
632 worry about setting *valuep. */
633 do {
634 s++;
635 } while (s < send && isDIGIT(*s));
636 numtype |=
637 IS_NUMBER_GREATER_THAN_UV_MAX;
638 goto skip_value;
639 }
640 }
641 }
98994639 642 }
60939fb8
NC
643 }
644 }
645 }
646 }
647 }
648 }
649 }
650 }
651 }
652 }
653 }
98994639 654 }
60939fb8 655 }
98994639 656 }
60939fb8
NC
657 numtype |= IS_NUMBER_IN_UV;
658 if (valuep)
659 *valuep = value;
660
661 skip_value:
662 if (GROK_NUMERIC_RADIX(&s, send)) {
663 numtype |= IS_NUMBER_NOT_INT;
664 while (s < send && isDIGIT(*s)) /* optional digits after the radix */
665 s++;
98994639 666 }
60939fb8
NC
667 }
668 else if (GROK_NUMERIC_RADIX(&s, send)) {
669 numtype |= IS_NUMBER_NOT_INT | IS_NUMBER_IN_UV; /* valuep assigned below */
670 /* no digits before the radix means we need digits after it */
671 if (s < send && isDIGIT(*s)) {
672 do {
673 s++;
674 } while (s < send && isDIGIT(*s));
675 if (valuep) {
676 /* integer approximation is valid - it's 0. */
677 *valuep = 0;
678 }
98994639 679 }
60939fb8
NC
680 else
681 return 0;
682 } else if (*s == 'I' || *s == 'i') {
683 s++; if (s == send || (*s != 'N' && *s != 'n')) return 0;
684 s++; if (s == send || (*s != 'F' && *s != 'f')) return 0;
685 s++; if (s < send && (*s == 'I' || *s == 'i')) {
686 s++; if (s == send || (*s != 'N' && *s != 'n')) return 0;
687 s++; if (s == send || (*s != 'I' && *s != 'i')) return 0;
688 s++; if (s == send || (*s != 'T' && *s != 't')) return 0;
689 s++; if (s == send || (*s != 'Y' && *s != 'y')) return 0;
690 s++;
98994639 691 }
60939fb8 692 sawinf = 1;
aa8b85de
JH
693 } else if (*s == 'N' || *s == 'n') {
694 /* XXX TODO: There are signaling NaNs and quiet NaNs. */
695 s++; if (s == send || (*s != 'A' && *s != 'a')) return 0;
696 s++; if (s == send || (*s != 'N' && *s != 'n')) return 0;
697 s++;
698 sawnan = 1;
699 } else
98994639 700 return 0;
60939fb8
NC
701
702 if (sawinf) {
703 numtype &= IS_NUMBER_NEG; /* Keep track of sign */
704 numtype |= IS_NUMBER_INFINITY | IS_NUMBER_NOT_INT;
aa8b85de
JH
705 } else if (sawnan) {
706 numtype &= IS_NUMBER_NEG; /* Keep track of sign */
707 numtype |= IS_NUMBER_NAN | IS_NUMBER_NOT_INT;
60939fb8
NC
708 } else if (s < send) {
709 /* we can have an optional exponent part */
710 if (*s == 'e' || *s == 'E') {
711 /* The only flag we keep is sign. Blow away any "it's UV" */
712 numtype &= IS_NUMBER_NEG;
713 numtype |= IS_NUMBER_NOT_INT;
714 s++;
715 if (s < send && (*s == '-' || *s == '+'))
716 s++;
717 if (s < send && isDIGIT(*s)) {
718 do {
719 s++;
720 } while (s < send && isDIGIT(*s));
721 }
722 else
723 return 0;
724 }
725 }
726 while (s < send && isSPACE(*s))
727 s++;
728 if (s >= send)
aa8b85de 729 return numtype;
60939fb8
NC
730 if (len == 10 && memEQ(pv, "0 but true", 10)) {
731 if (valuep)
732 *valuep = 0;
733 return IS_NUMBER_IN_UV;
734 }
735 return 0;
98994639
HS
736}
737
4801ca72 738STATIC NV
98994639
HS
739S_mulexp10(NV value, I32 exponent)
740{
741 NV result = 1.0;
742 NV power = 10.0;
743 bool negative = 0;
744 I32 bit;
745
746 if (exponent == 0)
747 return value;
20f6aaab 748 if (value == 0)
66a1b24b 749 return (NV)0;
87032ba1 750
24866caa 751 /* On OpenVMS VAX we by default use the D_FLOAT double format,
67597c89 752 * and that format does not have *easy* capabilities [1] for
24866caa
CB
753 * overflowing doubles 'silently' as IEEE fp does. We also need
754 * to support G_FLOAT on both VAX and Alpha, and though the exponent
755 * range is much larger than D_FLOAT it still doesn't do silent
756 * overflow. Therefore we need to detect early whether we would
757 * overflow (this is the behaviour of the native string-to-float
758 * conversion routines, and therefore of native applications, too).
67597c89 759 *
24866caa
CB
760 * [1] Trying to establish a condition handler to trap floating point
761 * exceptions is not a good idea. */
87032ba1
JH
762
763 /* In UNICOS and in certain Cray models (such as T90) there is no
764 * IEEE fp, and no way at all from C to catch fp overflows gracefully.
765 * There is something you can do if you are willing to use some
766 * inline assembler: the instruction is called DFI-- but that will
767 * disable *all* floating point interrupts, a little bit too large
768 * a hammer. Therefore we need to catch potential overflows before
769 * it's too late. */
353813d9
HS
770
771#if ((defined(VMS) && !defined(__IEEE_FP)) || defined(_UNICOS)) && defined(NV_MAX_10_EXP)
772 STMT_START {
c4420975 773 const NV exp_v = log10(value);
353813d9
HS
774 if (exponent >= NV_MAX_10_EXP || exponent + exp_v >= NV_MAX_10_EXP)
775 return NV_MAX;
776 if (exponent < 0) {
777 if (-(exponent + exp_v) >= NV_MAX_10_EXP)
778 return 0.0;
779 while (-exponent >= NV_MAX_10_EXP) {
780 /* combination does not overflow, but 10^(-exponent) does */
781 value /= 10;
782 ++exponent;
783 }
784 }
785 } STMT_END;
87032ba1
JH
786#endif
787
353813d9
HS
788 if (exponent < 0) {
789 negative = 1;
790 exponent = -exponent;
791 }
98994639
HS
792 for (bit = 1; exponent; bit <<= 1) {
793 if (exponent & bit) {
794 exponent ^= bit;
795 result *= power;
236f0012
CB
796 /* Floating point exceptions are supposed to be turned off,
797 * but if we're obviously done, don't risk another iteration.
798 */
799 if (exponent == 0) break;
98994639
HS
800 }
801 power *= power;
802 }
803 return negative ? value / result : value * result;
804}
805
806NV
807Perl_my_atof(pTHX_ const char* s)
808{
809 NV x = 0.0;
810#ifdef USE_LOCALE_NUMERIC
97aff369 811 dVAR;
98994639
HS
812 if (PL_numeric_local && IN_LOCALE) {
813 NV y;
814
815 /* Scan the number twice; once using locale and once without;
816 * choose the larger result (in absolute value). */
a36244b7 817 Perl_atof2(s, x);
98994639 818 SET_NUMERIC_STANDARD();
a36244b7 819 Perl_atof2(s, y);
98994639
HS
820 SET_NUMERIC_LOCAL();
821 if ((y < 0.0 && y < x) || (y > 0.0 && y > x))
822 return y;
823 }
824 else
a36244b7 825 Perl_atof2(s, x);
98994639 826#else
a36244b7 827 Perl_atof2(s, x);
98994639
HS
828#endif
829 return x;
830}
831
832char*
833Perl_my_atof2(pTHX_ const char* orig, NV* value)
834{
20f6aaab 835 NV result[3] = {0.0, 0.0, 0.0};
e1ec3a88 836 const char* s = orig;
a36244b7 837#ifdef USE_PERL_ATOF
20f6aaab 838 UV accumulator[2] = {0,0}; /* before/after dp */
a36244b7 839 bool negative = 0;
e1ec3a88 840 const char* send = s + strlen(orig) - 1;
8194bf88 841 bool seen_digit = 0;
20f6aaab
AS
842 I32 exp_adjust[2] = {0,0};
843 I32 exp_acc[2] = {-1, -1};
844 /* the current exponent adjust for the accumulators */
98994639 845 I32 exponent = 0;
8194bf88 846 I32 seen_dp = 0;
20f6aaab
AS
847 I32 digit = 0;
848 I32 old_digit = 0;
8194bf88
DM
849 I32 sig_digits = 0; /* noof significant digits seen so far */
850
851/* There is no point in processing more significant digits
852 * than the NV can hold. Note that NV_DIG is a lower-bound value,
853 * while we need an upper-bound value. We add 2 to account for this;
854 * since it will have been conservative on both the first and last digit.
855 * For example a 32-bit mantissa with an exponent of 4 would have
856 * exact values in the set
857 * 4
858 * 8
859 * ..
860 * 17179869172
861 * 17179869176
862 * 17179869180
863 *
864 * where for the purposes of calculating NV_DIG we would have to discount
865 * both the first and last digit, since neither can hold all values from
866 * 0..9; but for calculating the value we must examine those two digits.
867 */
868#define MAX_SIG_DIGITS (NV_DIG+2)
869
870/* the max number we can accumulate in a UV, and still safely do 10*N+9 */
871#define MAX_ACCUMULATE ( (UV) ((UV_MAX - 9)/10))
98994639 872
96a05aee
HS
873 /* leading whitespace */
874 while (isSPACE(*s))
875 ++s;
876
98994639
HS
877 /* sign */
878 switch (*s) {
879 case '-':
880 negative = 1;
881 /* fall through */
882 case '+':
883 ++s;
884 }
885
2b54f59f
YST
886 /* punt to strtod for NaN/Inf; if no support for it there, tough luck */
887
888#ifdef HAS_STRTOD
889 if (*s == 'n' || *s == 'N' || *s == 'i' || *s == 'I') {
c042ae3a 890 const char *p = negative ? s - 1 : s;
2b54f59f
YST
891 char *endp;
892 NV rslt;
893 rslt = strtod(p, &endp);
894 if (endp != p) {
895 *value = rslt;
896 return (char *)endp;
897 }
898 }
899#endif
900
8194bf88
DM
901 /* we accumulate digits into an integer; when this becomes too
902 * large, we add the total to NV and start again */
98994639 903
8194bf88
DM
904 while (1) {
905 if (isDIGIT(*s)) {
906 seen_digit = 1;
20f6aaab 907 old_digit = digit;
8194bf88 908 digit = *s++ - '0';
20f6aaab
AS
909 if (seen_dp)
910 exp_adjust[1]++;
98994639 911
8194bf88
DM
912 /* don't start counting until we see the first significant
913 * digit, eg the 5 in 0.00005... */
914 if (!sig_digits && digit == 0)
915 continue;
916
917 if (++sig_digits > MAX_SIG_DIGITS) {
98994639 918 /* limits of precision reached */
20f6aaab
AS
919 if (digit > 5) {
920 ++accumulator[seen_dp];
921 } else if (digit == 5) {
922 if (old_digit % 2) { /* round to even - Allen */
923 ++accumulator[seen_dp];
924 }
925 }
926 if (seen_dp) {
927 exp_adjust[1]--;
928 } else {
929 exp_adjust[0]++;
930 }
8194bf88 931 /* skip remaining digits */
98994639 932 while (isDIGIT(*s)) {
98994639 933 ++s;
20f6aaab
AS
934 if (! seen_dp) {
935 exp_adjust[0]++;
936 }
98994639
HS
937 }
938 /* warn of loss of precision? */
98994639 939 }
8194bf88 940 else {
20f6aaab 941 if (accumulator[seen_dp] > MAX_ACCUMULATE) {
8194bf88 942 /* add accumulator to result and start again */
20f6aaab
AS
943 result[seen_dp] = S_mulexp10(result[seen_dp],
944 exp_acc[seen_dp])
945 + (NV)accumulator[seen_dp];
946 accumulator[seen_dp] = 0;
947 exp_acc[seen_dp] = 0;
98994639 948 }
20f6aaab
AS
949 accumulator[seen_dp] = accumulator[seen_dp] * 10 + digit;
950 ++exp_acc[seen_dp];
98994639 951 }
8194bf88 952 }
e1ec3a88 953 else if (!seen_dp && GROK_NUMERIC_RADIX(&s, send)) {
8194bf88 954 seen_dp = 1;
20f6aaab 955 if (sig_digits > MAX_SIG_DIGITS) {
c86f7df5 956 do {
20f6aaab 957 ++s;
c86f7df5 958 } while (isDIGIT(*s));
20f6aaab
AS
959 break;
960 }
8194bf88
DM
961 }
962 else {
963 break;
98994639
HS
964 }
965 }
966
20f6aaab
AS
967 result[0] = S_mulexp10(result[0], exp_acc[0]) + (NV)accumulator[0];
968 if (seen_dp) {
969 result[1] = S_mulexp10(result[1], exp_acc[1]) + (NV)accumulator[1];
970 }
98994639 971
8194bf88 972 if (seen_digit && (*s == 'e' || *s == 'E')) {
98994639
HS
973 bool expnegative = 0;
974
975 ++s;
976 switch (*s) {
977 case '-':
978 expnegative = 1;
979 /* fall through */
980 case '+':
981 ++s;
982 }
983 while (isDIGIT(*s))
984 exponent = exponent * 10 + (*s++ - '0');
985 if (expnegative)
986 exponent = -exponent;
987 }
988
20f6aaab
AS
989
990
98994639 991 /* now apply the exponent */
20f6aaab
AS
992
993 if (seen_dp) {
994 result[2] = S_mulexp10(result[0],exponent+exp_adjust[0])
995 + S_mulexp10(result[1],exponent-exp_adjust[1]);
996 } else {
997 result[2] = S_mulexp10(result[0],exponent+exp_adjust[0]);
998 }
98994639
HS
999
1000 /* now apply the sign */
1001 if (negative)
20f6aaab 1002 result[2] = -result[2];
a36244b7 1003#endif /* USE_PERL_ATOF */
20f6aaab 1004 *value = result[2];
73d840c0 1005 return (char *)s;
98994639
HS
1006}
1007
55954f19
JH
1008#if ! defined(HAS_MODFL) && defined(HAS_AINTL) && defined(HAS_COPYSIGNL)
1009long double
1010Perl_my_modfl(long double x, long double *ip)
1011{
1012 *ip = aintl(x);
1013 return (x == *ip ? copysignl(0.0L, x) : x - *ip);
1014}
1015#endif
1016
1017#if ! defined(HAS_FREXPL) && defined(HAS_ILOGBL) && defined(HAS_SCALBNL)
1018long double
1019Perl_my_frexpl(long double x, int *e) {
1020 *e = x == 0.0L ? 0 : ilogbl(x) + 1;
1021 return (scalbnl(x, -*e));
1022}
1023#endif
66610fdd
RGS
1024
1025/*
ed140128
AD
1026=for apidoc Perl_signbit
1027
1028Return a non-zero integer if the sign bit on an NV is set, and 0 if
1029it is not.
1030
1031If Configure detects this system has a signbit() that will work with
1032our NVs, then we just use it via the #define in perl.h. Otherwise,
1033fall back on this implementation. As a first pass, this gets everything
1034right except -0.0. Alas, catching -0.0 is the main use for this function,
1035so this is not too helpful yet. Still, at least we have the scaffolding
1036in place to support other systems, should that prove useful.
1037
1038
1039Configure notes: This function is called 'Perl_signbit' instead of a
1040plain 'signbit' because it is easy to imagine a system having a signbit()
1041function or macro that doesn't happen to work with our particular choice
1042of NVs. We shouldn't just re-#define signbit as Perl_signbit and expect
1043the standard system headers to be happy. Also, this is a no-context
1044function (no pTHX_) because Perl_signbit() is usually re-#defined in
1045perl.h as a simple macro call to the system's signbit().
1046Users should just always call Perl_signbit().
1047
1048=cut
1049*/
1050#if !defined(HAS_SIGNBIT)
1051int
1052Perl_signbit(NV x) {
1053 return (x < 0.0) ? 1 : 0;
1054}
1055#endif
1056
1057/*
66610fdd
RGS
1058 * Local variables:
1059 * c-indentation-style: bsd
1060 * c-basic-offset: 4
1061 * indent-tabs-mode: t
1062 * End:
1063 *
37442d52
RGS
1064 * ex: set ts=8 sts=4 sw=4 noet:
1065 */