(?p{}) has been deprecated for a long time.
[p5sagit/p5-mst-13.2.git] / numeric.c
CommitLineData
98994639 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 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 16/*
17=head1 Numeric functions
166f8a29 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 24*/
25
98994639 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 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 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 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 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 107/*
108=for apidoc grok_bin
98994639 109
53305cf1 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 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 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 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 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 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 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 160 }
161
7fc63493 162 for (; len-- && (bit = *s); s++) {
53305cf1 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 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 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 187 value_nv += (NV)(bit - '0');
188 continue;
189 }
190 if (bit == '_' && len && allow_underscores && (bit = s[1])
191 && (bit == '0' || bit == '1'))
98994639 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 199 "Illegal binary digit '%c' ignored", *s);
200 break;
98994639 201 }
53305cf1 202
203 if ( ( overflowed && value_nv > 4294967295.0)
98994639 204#if UVSIZE > 4
53305cf1 205 || (!overflowed && value > 0xffffffff )
98994639 206#endif
207 ) {
208 if (ckWARN(WARN_PORTABLE))
9014280d 209 Perl_warner(aTHX_ packWARN(WARN_PORTABLE),
53305cf1 210 "Binary number > 0b11111111111111111111111111111111 non-portable");
211 }
212 *len_p = s - start;
213 if (!overflowed) {
214 *flags = 0;
215 return value;
98994639 216 }
53305cf1 217 *flags = PERL_SCAN_GREATER_THAN_UV_MAX;
218 if (result)
219 *result = value_nv;
220 return UV_MAX;
98994639 221}
222
53305cf1 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 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 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 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 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 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 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 276 }
277
278 for (; len-- && *s; s++) {
a3b680e6 279 const char *hexdigit = strchr(PL_hexdigit, *s);
53305cf1 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 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 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 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 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 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 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 361
362=cut
363 */
364
365UV
7fc63493 366Perl_grok_oct(pTHX_ const char *start, STRLEN *len_p, I32 *flags, NV *result) {
53305cf1 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 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 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 400 * is a waste of time (because the NV cannot preserve
401 * the low-order bits anyway): we could just remember when
53305cf1 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 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 420 "Illegal octal digit '%c' ignored", *s);
421 }
422 break;
98994639 423 }
53305cf1 424
425 if ( ( overflowed && value_nv > 4294967295.0)
98994639 426#if UVSIZE > 4
53305cf1 427 || (!overflowed && value > 0xffffffff )
98994639 428#endif
429 ) {
430 if (ckWARN(WARN_PORTABLE))
9014280d 431 Perl_warner(aTHX_ packWARN(WARN_PORTABLE),
53305cf1 432 "Octal number > 037777777777 non-portable");
433 }
434 *len_p = s - start;
435 if (!overflowed) {
436 *flags = 0;
437 return value;
98994639 438 }
53305cf1 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 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 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 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 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 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 489
490 *retlen = len;
491 return (flags & PERL_SCAN_GREATER_THAN_UV_MAX) ? rnv : (NV)ruv;
98994639 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 506 if (PL_numeric_radix_sv && IN_LOCALE) {
507 STRLEN len;
c4420975 508 const char * const radix = SvPV(PL_numeric_radix_sv, len);
98994639 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 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 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 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 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 582 if (++s < send) {
583 int digit = *s - '0';
60939fb8 584 if (digit >= 0 && digit <= 9) {
585 value = value * 10 + digit;
58bb9ec3 586 if (++s < send) {
587 digit = *s - '0';
60939fb8 588 if (digit >= 0 && digit <= 9) {
589 value = value * 10 + digit;
58bb9ec3 590 if (++s < send) {
591 digit = *s - '0';
60939fb8 592 if (digit >= 0 && digit <= 9) {
593 value = value * 10 + digit;
58bb9ec3 594 if (++s < send) {
595 digit = *s - '0';
60939fb8 596 if (digit >= 0 && digit <= 9) {
597 value = value * 10 + digit;
58bb9ec3 598 if (++s < send) {
599 digit = *s - '0';
60939fb8 600 if (digit >= 0 && digit <= 9) {
601 value = value * 10 + digit;
58bb9ec3 602 if (++s < send) {
603 digit = *s - '0';
60939fb8 604 if (digit >= 0 && digit <= 9) {
605 value = value * 10 + digit;
58bb9ec3 606 if (++s < send) {
607 digit = *s - '0';
60939fb8 608 if (digit >= 0 && digit <= 9) {
609 value = value * 10 + digit;
58bb9ec3 610 if (++s < send) {
611 digit = *s - '0';
60939fb8 612 if (digit >= 0 && digit <= 9) {
613 value = value * 10 + digit;
58bb9ec3 614 if (++s < send) {
60939fb8 615 /* Now got 9 digits, so need to check
616 each time for overflow. */
58bb9ec3 617 digit = *s - '0';
60939fb8 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 623 if (++s < send)
624 digit = *s - '0';
60939fb8 625 else
626 break;
627 }
628 if (digit >= 0 && digit <= 9
51bd16da 629 && (s < send)) {
60939fb8 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 643 }
644 }
645 }
646 }
647 }
648 }
649 }
650 }
651 }
652 }
653 }
98994639 654 }
60939fb8 655 }
98994639 656 }
60939fb8 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 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 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 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 701
702 if (sawinf) {
703 numtype &= IS_NUMBER_NEG; /* Keep track of sign */
704 numtype |= IS_NUMBER_INFINITY | IS_NUMBER_NOT_INT;
aa8b85de 705 } else if (sawnan) {
706 numtype &= IS_NUMBER_NEG; /* Keep track of sign */
707 numtype |= IS_NUMBER_NAN | IS_NUMBER_NOT_INT;
60939fb8 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 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 736}
737
4801ca72 738STATIC NV
98994639 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 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 760 * [1] Trying to establish a condition handler to trap floating point
761 * exceptions is not a good idea. */
87032ba1 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 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 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 786#endif
787
353813d9 788 if (exponent < 0) {
789 negative = 1;
790 exponent = -exponent;
791 }
98994639 792 for (bit = 1; exponent; bit <<= 1) {
793 if (exponent & bit) {
794 exponent ^= bit;
795 result *= power;
236f0012 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 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 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 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 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 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 847 I32 digit = 0;
848 I32 old_digit = 0;
8194bf88 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 873 /* leading whitespace */
874 while (isSPACE(*s))
875 ++s;
876
98994639 877 /* sign */
878 switch (*s) {
879 case '-':
880 negative = 1;
881 /* fall through */
882 case '+':
883 ++s;
884 }
885
2b54f59f 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 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 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 904 while (1) {
905 if (isDIGIT(*s)) {
906 seen_digit = 1;
20f6aaab 907 old_digit = digit;
8194bf88 908 digit = *s++ - '0';
20f6aaab 909 if (seen_dp)
910 exp_adjust[1]++;
98994639 911
8194bf88 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 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 934 if (! seen_dp) {
935 exp_adjust[0]++;
936 }
98994639 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 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 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) {
956 ++s;
957 while (isDIGIT(*s)) {
958 ++s;
959 }
960 break;
961 }
8194bf88 962 }
963 else {
964 break;
98994639 965 }
966 }
967
20f6aaab 968 result[0] = S_mulexp10(result[0], exp_acc[0]) + (NV)accumulator[0];
969 if (seen_dp) {
970 result[1] = S_mulexp10(result[1], exp_acc[1]) + (NV)accumulator[1];
971 }
98994639 972
8194bf88 973 if (seen_digit && (*s == 'e' || *s == 'E')) {
98994639 974 bool expnegative = 0;
975
976 ++s;
977 switch (*s) {
978 case '-':
979 expnegative = 1;
980 /* fall through */
981 case '+':
982 ++s;
983 }
984 while (isDIGIT(*s))
985 exponent = exponent * 10 + (*s++ - '0');
986 if (expnegative)
987 exponent = -exponent;
988 }
989
20f6aaab 990
991
98994639 992 /* now apply the exponent */
20f6aaab 993
994 if (seen_dp) {
995 result[2] = S_mulexp10(result[0],exponent+exp_adjust[0])
996 + S_mulexp10(result[1],exponent-exp_adjust[1]);
997 } else {
998 result[2] = S_mulexp10(result[0],exponent+exp_adjust[0]);
999 }
98994639 1000
1001 /* now apply the sign */
1002 if (negative)
20f6aaab 1003 result[2] = -result[2];
a36244b7 1004#endif /* USE_PERL_ATOF */
20f6aaab 1005 *value = result[2];
73d840c0 1006 return (char *)s;
98994639 1007}
1008
55954f19 1009#if ! defined(HAS_MODFL) && defined(HAS_AINTL) && defined(HAS_COPYSIGNL)
1010long double
1011Perl_my_modfl(long double x, long double *ip)
1012{
1013 *ip = aintl(x);
1014 return (x == *ip ? copysignl(0.0L, x) : x - *ip);
1015}
1016#endif
1017
1018#if ! defined(HAS_FREXPL) && defined(HAS_ILOGBL) && defined(HAS_SCALBNL)
1019long double
1020Perl_my_frexpl(long double x, int *e) {
1021 *e = x == 0.0L ? 0 : ilogbl(x) + 1;
1022 return (scalbnl(x, -*e));
1023}
1024#endif
66610fdd 1025
1026/*
ed140128 1027=for apidoc Perl_signbit
1028
1029Return a non-zero integer if the sign bit on an NV is set, and 0 if
1030it is not.
1031
1032If Configure detects this system has a signbit() that will work with
1033our NVs, then we just use it via the #define in perl.h. Otherwise,
1034fall back on this implementation. As a first pass, this gets everything
1035right except -0.0. Alas, catching -0.0 is the main use for this function,
1036so this is not too helpful yet. Still, at least we have the scaffolding
1037in place to support other systems, should that prove useful.
1038
1039
1040Configure notes: This function is called 'Perl_signbit' instead of a
1041plain 'signbit' because it is easy to imagine a system having a signbit()
1042function or macro that doesn't happen to work with our particular choice
1043of NVs. We shouldn't just re-#define signbit as Perl_signbit and expect
1044the standard system headers to be happy. Also, this is a no-context
1045function (no pTHX_) because Perl_signbit() is usually re-#defined in
1046perl.h as a simple macro call to the system's signbit().
1047Users should just always call Perl_signbit().
1048
1049=cut
1050*/
1051#if !defined(HAS_SIGNBIT)
1052int
1053Perl_signbit(NV x) {
1054 return (x < 0.0) ? 1 : 0;
1055}
1056#endif
1057
1058/*
66610fdd 1059 * Local variables:
1060 * c-indentation-style: bsd
1061 * c-basic-offset: 4
1062 * indent-tabs-mode: t
1063 * End:
1064 *
37442d52 1065 * ex: set ts=8 sts=4 sw=4 noet:
1066 */