This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
Merge branch 'grok_bin_oct_hex' into blead
[perl5.git] / numeric.c
1 /*    numeric.c
2  *
3  *    Copyright (C) 1993, 1994, 1995, 1996, 1997, 1998, 1999, 2000, 2001,
4  *    2002, 2003, 2004, 2005, 2006, 2007, 2008 by Larry Wall and others
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,
13  *  unless wizards count differently to other people."  --Beorn
14  *
15  *     [p.115 of _The Hobbit_: "Queer Lodgings"]
16  */
17
18 /*
19 =head1 Numeric functions
20
21 =cut
22
23 This file contains all the stuff needed by perl for manipulating numeric
24 values, including such things as replacements for the OS's atof() function
25
26 */
27
28 #include "EXTERN.h"
29 #define PERL_IN_NUMERIC_C
30 #include "perl.h"
31
32 #ifdef Perl_strtod
33
34 PERL_STATIC_INLINE NV
35 S_strtod(pTHX_ const char * const s, char ** e)
36 {
37     DECLARATION_FOR_LC_NUMERIC_MANIPULATION;
38     NV result;
39
40     STORE_LC_NUMERIC_SET_TO_NEEDED();
41
42 #  ifdef USE_QUADMATH
43
44     result = strtoflt128(s, e);
45
46 #  elif defined(HAS_STRTOLD) && defined(HAS_LONG_DOUBLE)    \
47                              && defined(USE_LONG_DOUBLE)
48 #    if defined(__MINGW64_VERSION_MAJOR)
49       /***********************************************
50        We are unable to use strtold because of
51         https://sourceforge.net/p/mingw-w64/bugs/711/
52         &
53         https://sourceforge.net/p/mingw-w64/bugs/725/
54
55        but __mingw_strtold is fine.
56       ***********************************************/
57
58     result = __mingw_strtold(s, e);
59
60 #    else
61
62     result = strtold(s, e);
63
64 #    endif
65 #  elif defined(HAS_STRTOD)
66
67     result = strtod(s, e);
68
69 #  else
70 #    error No strtod() equivalent found
71 #  endif
72
73     RESTORE_LC_NUMERIC();
74
75     return result;
76 }
77
78 #endif  /* #ifdef Perl_strtod */
79
80 /*
81
82 =for apidoc my_strtod
83
84 This function is equivalent to the libc strtod() function, and is available
85 even on platforms that lack plain strtod().  Its return value is the best
86 available precision depending on platform capabilities and F<Configure>
87 options.
88
89 It properly handles the locale radix character, meaning it expects a dot except
90 when called from within the scope of S<C<use locale>>, in which case the radix
91 character should be that specified by the current locale.
92
93 The synonym Strtod() may be used instead.
94
95 =cut
96
97 */
98
99 NV
100 Perl_my_strtod(const char * const s, char **e)
101 {
102     dTHX;
103
104     PERL_ARGS_ASSERT_MY_STRTOD;
105
106 #ifdef Perl_strtod
107
108     return S_strtod(aTHX_ s, e);
109
110 #else
111
112     {
113         NV result;
114         char ** end_ptr = NULL;
115
116         *end_ptr = my_atof2(s, &result);
117         if (e) {
118             *e = *end_ptr;
119         }
120
121         if (! *end_ptr) {
122             result = 0.0;
123         }
124
125         return result;
126     }
127
128 #endif
129
130 }
131
132
133 U32
134 Perl_cast_ulong(NV f)
135 {
136   if (f < 0.0)
137     return f < I32_MIN ? (U32) I32_MIN : (U32)(I32) f;
138   if (f < U32_MAX_P1) {
139 #if CASTFLAGS & 2
140     if (f < U32_MAX_P1_HALF)
141       return (U32) f;
142     f -= U32_MAX_P1_HALF;
143     return ((U32) f) | (1 + (U32_MAX >> 1));
144 #else
145     return (U32) f;
146 #endif
147   }
148   return f > 0 ? U32_MAX : 0 /* NaN */;
149 }
150
151 I32
152 Perl_cast_i32(NV f)
153 {
154   if (f < I32_MAX_P1)
155     return f < I32_MIN ? I32_MIN : (I32) f;
156   if (f < U32_MAX_P1) {
157 #if CASTFLAGS & 2
158     if (f < U32_MAX_P1_HALF)
159       return (I32)(U32) f;
160     f -= U32_MAX_P1_HALF;
161     return (I32)(((U32) f) | (1 + (U32_MAX >> 1)));
162 #else
163     return (I32)(U32) f;
164 #endif
165   }
166   return f > 0 ? (I32)U32_MAX : 0 /* NaN */;
167 }
168
169 IV
170 Perl_cast_iv(NV f)
171 {
172   if (f < IV_MAX_P1)
173     return f < IV_MIN ? IV_MIN : (IV) f;
174   if (f < UV_MAX_P1) {
175 #if CASTFLAGS & 2
176     /* For future flexibility allowing for sizeof(UV) >= sizeof(IV)  */
177     if (f < UV_MAX_P1_HALF)
178       return (IV)(UV) f;
179     f -= UV_MAX_P1_HALF;
180     return (IV)(((UV) f) | (1 + (UV_MAX >> 1)));
181 #else
182     return (IV)(UV) f;
183 #endif
184   }
185   return f > 0 ? (IV)UV_MAX : 0 /* NaN */;
186 }
187
188 UV
189 Perl_cast_uv(NV f)
190 {
191   if (f < 0.0)
192     return f < IV_MIN ? (UV) IV_MIN : (UV)(IV) f;
193   if (f < UV_MAX_P1) {
194 #if CASTFLAGS & 2
195     if (f < UV_MAX_P1_HALF)
196       return (UV) f;
197     f -= UV_MAX_P1_HALF;
198     return ((UV) f) | (1 + (UV_MAX >> 1));
199 #else
200     return (UV) f;
201 #endif
202   }
203   return f > 0 ? UV_MAX : 0 /* NaN */;
204 }
205
206 /*
207 =for apidoc grok_bin
208
209 converts a string representing a binary number to numeric form.
210
211 On entry C<start> and C<*len_p> give the string to scan, C<*flags> gives
212 conversion flags, and C<result> should be C<NULL> or a pointer to an NV.  The
213 scan stops at the end of the string, or at just before the first invalid
214 character.  Unless C<PERL_SCAN_SILENT_ILLDIGIT> is set in C<*flags>,
215 encountering an invalid character (except NUL) will also trigger a warning.  On
216 return C<*len_p> is set to the length of the scanned string, and C<*flags>
217 gives output flags.
218
219 If the value is <= C<UV_MAX> it is returned as a UV, the output flags are clear,
220 and nothing is written to C<*result>.  If the value is > C<UV_MAX>, C<grok_bin>
221 returns C<UV_MAX>, sets C<PERL_SCAN_GREATER_THAN_UV_MAX> in the output flags,
222 and writes an approximation of the correct value into C<*result> (which is an
223 NV; or the approximation is discarded if C<result> is NULL).
224
225 The binary number may optionally be prefixed with C<"0b"> or C<"b"> unless
226 C<PERL_SCAN_DISALLOW_PREFIX> is set in C<*flags> on entry.
227
228 If C<PERL_SCAN_ALLOW_UNDERSCORES> is set in C<*flags> then any or all pairs of
229 digits may be separated from each other by a single underscore; also a single
230 leading underscore is accepted.
231
232 =for apidoc Amnh||PERL_SCAN_ALLOW_UNDERSCORES
233 =for apidoc Amnh||PERL_SCAN_DISALLOW_PREFIX
234 =for apidoc Amnh||PERL_SCAN_GREATER_THAN_UV_MAX
235 =for apidoc Amnh||PERL_SCAN_SILENT_ILLDIGIT
236
237 =cut
238
239 Not documented yet because experimental is C<PERL_SCAN_SILENT_NON_PORTABLE
240 which suppresses any message for non-portable numbers that are still valid
241 on this platform.
242  */
243
244 UV
245 Perl_grok_bin(pTHX_ const char *start, STRLEN *len_p, I32 *flags, NV *result)
246 {
247     PERL_ARGS_ASSERT_GROK_BIN;
248
249     return grok_bin(start, len_p, flags, result);
250 }
251
252 /*
253 =for apidoc grok_hex
254
255 converts a string representing a hex number to numeric form.
256
257 On entry C<start> and C<*len_p> give the string to scan, C<*flags> gives
258 conversion flags, and C<result> should be C<NULL> or a pointer to an NV.  The
259 scan stops at the end of the string, or at just before the first invalid
260 character.  Unless C<PERL_SCAN_SILENT_ILLDIGIT> is set in C<*flags>,
261 encountering an invalid character (except NUL) will also trigger a warning.  On
262 return C<*len_p> is set to the length of the scanned string, and C<*flags>
263 gives output flags.
264
265 If the value is <= C<UV_MAX> it is returned as a UV, the output flags are clear,
266 and nothing is written to C<*result>.  If the value is > C<UV_MAX>, C<grok_hex>
267 returns C<UV_MAX>, sets C<PERL_SCAN_GREATER_THAN_UV_MAX> in the output flags,
268 and writes an approximation of the correct value into C<*result> (which is an
269 NV; or the approximation is discarded if C<result> is NULL).
270
271 The hex number may optionally be prefixed with C<"0x"> or C<"x"> unless
272 C<PERL_SCAN_DISALLOW_PREFIX> is set in C<*flags> on entry.
273
274 If C<PERL_SCAN_ALLOW_UNDERSCORES> is set in C<*flags> then any or all pairs of
275 digits may be separated from each other by a single underscore; also a single
276 leading underscore is accepted.
277
278 =cut
279
280 Not documented yet because experimental is C<PERL_SCAN_SILENT_NON_PORTABLE>
281 which suppresses any message for non-portable numbers, but which are valid
282 on this platform.
283  */
284
285 UV
286 Perl_grok_hex(pTHX_ const char *start, STRLEN *len_p, I32 *flags, NV *result)
287 {
288     PERL_ARGS_ASSERT_GROK_HEX;
289
290     return grok_hex(start, len_p, flags, result);
291 }
292
293 /*
294 =for apidoc grok_oct
295
296 converts a string representing an octal number to numeric form.
297
298 On entry C<start> and C<*len_p> give the string to scan, C<*flags> gives
299 conversion flags, and C<result> should be C<NULL> or a pointer to an NV.  The
300 scan stops at the end of the string, or at just before the first invalid
301 character.  Unless C<PERL_SCAN_SILENT_ILLDIGIT> is set in C<*flags>,
302 encountering an invalid character (except NUL) will also trigger a warning.  On
303 return C<*len_p> is set to the length of the scanned string, and C<*flags>
304 gives output flags.
305
306 If the value is <= C<UV_MAX> it is returned as a UV, the output flags are clear,
307 and nothing is written to C<*result>.  If the value is > C<UV_MAX>, C<grok_oct>
308 returns C<UV_MAX>, sets C<PERL_SCAN_GREATER_THAN_UV_MAX> in the output flags,
309 and writes an approximation of the correct value into C<*result> (which is an
310 NV; or the approximation is discarded if C<result> is NULL).
311
312 If C<PERL_SCAN_ALLOW_UNDERSCORES> is set in C<*flags> then any or all pairs of
313 digits may be separated from each other by a single underscore; also a single
314 leading underscore is accepted.
315
316 The the C<PERL_SCAN_DISALLOW_PREFIX> flag is always treated as being set for
317 this function.
318
319 =cut
320
321 Not documented yet because experimental is C<PERL_SCAN_SILENT_NON_PORTABLE>
322 which suppresses any message for non-portable numbers, but which are valid
323 on this platform.
324  */
325
326 UV
327 Perl_grok_oct(pTHX_ const char *start, STRLEN *len_p, I32 *flags, NV *result)
328 {
329     PERL_ARGS_ASSERT_GROK_OCT;
330
331     return grok_oct(start, len_p, flags, result);
332 }
333
334 STATIC void
335 S_output_non_portable(pTHX_ const U8 base)
336 {
337     /* Display the proper message for a number in the given input base not
338      * fitting in 32 bits */
339     const char * which = (base == 2)
340                       ? "Binary number > 0b11111111111111111111111111111111"
341                       : (base == 8)
342                         ? "Octal number > 037777777777"
343                         : "Hexadecimal number > 0xffffffff";
344
345     PERL_ARGS_ASSERT_OUTPUT_NON_PORTABLE;
346
347     /* Also there are listings for the other two.  That's because, since they
348      * are the first word, it would be hard for a user to find them there
349      * starting with a %s */
350     /* diag_listed_as: Hexadecimal number > 0xffffffff non-portable */
351     Perl_ck_warner(aTHX_ packWARN(WARN_PORTABLE), "%s non-portable", which);
352 }
353
354 UV
355 Perl_grok_bin_oct_hex(pTHX_ const char *start,
356                         STRLEN *len_p,
357                         I32 *flags,
358                         NV *result,
359                         const unsigned shift, /* 1 for binary; 3 for octal;
360                                                  4 for hex */
361                         const U8 class_bit,
362                         const char prefix
363                      )
364
365 {
366     const char *s0 = start;
367     const char *s;
368     STRLEN len = *len_p;
369     STRLEN bytes_so_far;    /* How many real digits have been processed */
370     UV value = 0;
371     NV value_nv = 0;
372     const PERL_UINT_FAST8_T base = 1 << shift;  /* 2, 8, or 16 */
373     const UV max_div= UV_MAX / base;    /* Value above which, the next digit
374                                            processed would overflow */
375     const I32 input_flags = *flags;
376     const bool allow_underscores =
377                                 cBOOL(input_flags & PERL_SCAN_ALLOW_UNDERSCORES);
378     bool overflowed = FALSE;
379
380     /* In overflows, this keeps track of how much to multiply the overflowed NV
381      * by as we continue to parse the remaining digits */
382     UV factor;
383
384     /* This function unifies the core of grok_bin, grok_oct, and grok_hex.  It
385      * is optimized for hex conversion.  For example, it uses XDIGIT_VALUE to
386      * find the numeric value of a digit.  That requires more instructions than
387      * OCTAL_VALUE would, but gives the same result for the narrowed range of
388      * octal digits; same for binary.  If it were ever critical to squeeze more
389      * performance from this, the function could become grok_hex, and a regen
390      * perl script could scan it and write out two edited copies for the other
391      * two functions.  That would improve the performance of all three
392      * somewhat.  Besides eliminating XDIGIT_VALUE for the other two, extra
393      * parameters are now passed to this to avoid conditionals.  Those could
394      * become declared consts, like:
395      *      const U8 base = 16;
396      *      const U8 base = 8;
397      *      ...
398      */
399
400     PERL_ARGS_ASSERT_GROK_BIN_OCT_HEX;
401
402     ASSUME(inRANGE(shift, 1, 4) && shift != 2);
403
404     /* Clear output flags; unlikely to find a problem that sets them */
405     *flags = 0;
406
407     if (!(input_flags & PERL_SCAN_DISALLOW_PREFIX)) {
408
409         /* strip off leading b or 0b; x or 0x.
410            for compatibility silently suffer "b" and "0b" as valid binary; "x"
411            and "0x" as valid hex numbers. */
412         if (len >= 1) {
413             if (isALPHA_FOLD_EQ(s0[0], prefix)) {
414                 s0++;
415                 len--;
416             }
417             else if (len >= 2 && s0[0] == '0' && (isALPHA_FOLD_EQ(s0[1], prefix))) {
418                 s0+=2;
419                 len-=2;
420             }
421         }
422     }
423
424     s = s0; /* s0 potentially advanced from 'start' */
425
426     /* Unroll the loop so that the first 7 digits are branchless except for the
427      * switch.  An eighth one could overflow a 32 bit word.  This should
428      * completely handle the common case without needing extra checks */
429     switch (len) {
430       case 0:
431           return 0;
432       default:
433           if (! _generic_isCC(*s, class_bit))  break;
434           value = (value << shift) | XDIGIT_VALUE(*s);
435           s++;
436           /* FALLTHROUGH */
437       case 6:
438           if (! _generic_isCC(*s, class_bit))  break;
439           value = (value << shift) | XDIGIT_VALUE(*s);
440           s++;
441           /* FALLTHROUGH */
442       case 5:
443           if (! _generic_isCC(*s, class_bit))  break;
444           value = (value << shift) | XDIGIT_VALUE(*s);
445           s++;
446           /* FALLTHROUGH */
447       case 4:
448           if (! _generic_isCC(*s, class_bit))  break;
449           value = (value << shift) | XDIGIT_VALUE(*s);
450           s++;
451           /* FALLTHROUGH */
452       case 3:
453           if (! _generic_isCC(*s, class_bit))  break;
454           value = (value << shift) | XDIGIT_VALUE(*s);
455           s++;
456           /* FALLTHROUGH */
457       case 2:
458           if (! _generic_isCC(*s, class_bit))  break;
459           value = (value << shift) | XDIGIT_VALUE(*s);
460           s++;
461           /* FALLTHROUGH */
462       case 1:
463           if (! _generic_isCC(*s, class_bit))  break;
464           value = (value << shift) | XDIGIT_VALUE(*s);
465
466           if (LIKELY(len <= 7)) {
467               return value;
468           }
469
470           s++;
471           break;
472     }
473
474     bytes_so_far = s - s0;
475     factor = shift << bytes_so_far;
476     len -= bytes_so_far;
477
478     for (; len--; s++) {
479         if (_generic_isCC(*s, class_bit)) {
480             /* Write it in this wonky order with a goto to attempt to get the
481                compiler to make the common case integer-only loop pretty tight.
482                With gcc seems to be much straighter code than old scan_hex.
483                (khw suspects that adding a LIKELY() just above would do the
484                same thing) */
485           redo:
486             if (LIKELY(value <= max_div)) {
487                 value = (value << shift) | XDIGIT_VALUE(*s);
488                     /* Note XDIGIT_VALUE() is branchless, works on binary
489                      * and octal as well, so can be used here, without
490                      * slowing those down */
491                 factor <<= shift;
492                 continue;
493             }
494
495             /* Bah. We are about to overflow.  Instead, add the unoverflowed
496              * value to an NV that contains an approximation to the correct
497              * value.  Each time through the loop we have increased 'factor' so
498              * that it gives how much the current approximation needs to
499              * effectively be shifted to make room for this new value */
500             value_nv *= (NV) factor;
501             value_nv += (NV) value;
502
503             /* Then we keep accumulating digits, until all are parsed.  We
504              * start over using the current input value.  This will be added to
505              * 'value_nv' eventually, either when all digits are gone, or we
506              * have overflowed this fresh start. */
507             value = XDIGIT_VALUE(*s);
508             factor = 1 << shift;
509
510             if (! overflowed) {
511                 overflowed = TRUE;
512                 Perl_ck_warner_d(aTHX_ packWARN(WARN_OVERFLOW),
513                                        "Integer overflow in %s number",
514                                        (base == 16) ? "hexadecimal"
515                                                     : (base == 2)
516                                                       ? "binary"
517                                                       : "octal");
518             }
519             continue;
520         }
521
522         if (   *s == '_'
523             && len
524             && allow_underscores
525             && _generic_isCC(s[1], class_bit))
526         {
527             --len;
528             ++s;
529             goto redo;
530         }
531
532         if (      *s
533             && ! (input_flags & PERL_SCAN_SILENT_ILLDIGIT)
534             &&    ckWARN(WARN_DIGIT))
535         {
536             if (base != 8) {
537                 Perl_warner(aTHX_ packWARN(WARN_DIGIT),
538                                    "Illegal %s digit '%c' ignored",
539                                    ((base == 2)
540                                     ? "binary"
541                                       : "hexadecimal"),
542                                     *s);
543             }
544             else if (isDIGIT(*s)) { /* octal base */
545
546                 /* Allow \octal to work the DWIM way (that is, stop scanning as
547                  * soon as non-octal characters are seen, complain only if
548                  * someone seems to want to use the digits eight and nine.
549                  * Since we know it is not octal, then if isDIGIT, must be an 8
550                  * or 9). */
551                 Perl_warner(aTHX_ packWARN(WARN_DIGIT),
552                                        "Illegal octal digit '%c' ignored", *s);
553             }
554         }
555
556         break;
557     }
558
559     *len_p = s - start;
560
561     if (LIKELY(! overflowed)) {
562 #if UVSIZE > 4
563         if (      UNLIKELY(value > 0xffffffff)
564             && ! (input_flags & PERL_SCAN_SILENT_NON_PORTABLE))
565         {
566             output_non_portable(base);
567         }
568 #endif
569         return value;
570     }
571
572     /* Overflowed: Calculate the final overflow approximation */
573     value_nv *= (NV) factor;
574     value_nv += (NV) value;
575
576     output_non_portable(base);
577
578     *flags = PERL_SCAN_GREATER_THAN_UV_MAX;
579     if (result)
580         *result = value_nv;
581     return UV_MAX;
582 }
583
584 /*
585 =for apidoc scan_bin
586
587 For backwards compatibility.  Use C<grok_bin> instead.
588
589 =for apidoc scan_hex
590
591 For backwards compatibility.  Use C<grok_hex> instead.
592
593 =for apidoc scan_oct
594
595 For backwards compatibility.  Use C<grok_oct> instead.
596
597 =cut
598  */
599
600 NV
601 Perl_scan_bin(pTHX_ const char *start, STRLEN len, STRLEN *retlen)
602 {
603     NV rnv;
604     I32 flags = *retlen ? PERL_SCAN_ALLOW_UNDERSCORES : 0;
605     const UV ruv = grok_bin (start, &len, &flags, &rnv);
606
607     PERL_ARGS_ASSERT_SCAN_BIN;
608
609     *retlen = len;
610     return (flags & PERL_SCAN_GREATER_THAN_UV_MAX) ? rnv : (NV)ruv;
611 }
612
613 NV
614 Perl_scan_oct(pTHX_ const char *start, STRLEN len, STRLEN *retlen)
615 {
616     NV rnv;
617     I32 flags = *retlen ? PERL_SCAN_ALLOW_UNDERSCORES : 0;
618     const UV ruv = grok_oct (start, &len, &flags, &rnv);
619
620     PERL_ARGS_ASSERT_SCAN_OCT;
621
622     *retlen = len;
623     return (flags & PERL_SCAN_GREATER_THAN_UV_MAX) ? rnv : (NV)ruv;
624 }
625
626 NV
627 Perl_scan_hex(pTHX_ const char *start, STRLEN len, STRLEN *retlen)
628 {
629     NV rnv;
630     I32 flags = *retlen ? PERL_SCAN_ALLOW_UNDERSCORES : 0;
631     const UV ruv = grok_hex (start, &len, &flags, &rnv);
632
633     PERL_ARGS_ASSERT_SCAN_HEX;
634
635     *retlen = len;
636     return (flags & PERL_SCAN_GREATER_THAN_UV_MAX) ? rnv : (NV)ruv;
637 }
638
639 /*
640 =for apidoc grok_numeric_radix
641
642 Scan and skip for a numeric decimal separator (radix).
643
644 =cut
645  */
646 bool
647 Perl_grok_numeric_radix(pTHX_ const char **sp, const char *send)
648 {
649     PERL_ARGS_ASSERT_GROK_NUMERIC_RADIX;
650
651 #ifdef USE_LOCALE_NUMERIC
652
653     if (IN_LC(LC_NUMERIC)) {
654         STRLEN len;
655         char * radix;
656         bool matches_radix = FALSE;
657         DECLARATION_FOR_LC_NUMERIC_MANIPULATION;
658
659         STORE_LC_NUMERIC_FORCE_TO_UNDERLYING();
660
661         radix = SvPV(PL_numeric_radix_sv, len);
662         radix = savepvn(radix, len);
663
664         RESTORE_LC_NUMERIC();
665
666         if (*sp + len <= send) {
667             matches_radix = memEQ(*sp, radix, len);
668         }
669
670         Safefree(radix);
671
672         if (matches_radix) {
673             *sp += len;
674             return TRUE;
675         }
676     }
677
678 #endif
679
680     /* always try "." if numeric radix didn't match because
681      * we may have data from different locales mixed */
682     if (*sp < send && **sp == '.') {
683         ++*sp;
684         return TRUE;
685     }
686
687     return FALSE;
688 }
689
690 /*
691 =for apidoc grok_infnan
692
693 Helper for C<grok_number()>, accepts various ways of spelling "infinity"
694 or "not a number", and returns one of the following flag combinations:
695
696   IS_NUMBER_INFINITY
697   IS_NUMBER_NAN
698   IS_NUMBER_INFINITY | IS_NUMBER_NEG
699   IS_NUMBER_NAN | IS_NUMBER_NEG
700   0
701
702 possibly |-ed with C<IS_NUMBER_TRAILING>.
703
704 If an infinity or a not-a-number is recognized, C<*sp> will point to
705 one byte past the end of the recognized string.  If the recognition fails,
706 zero is returned, and C<*sp> will not move.
707
708 =for apidoc Amn|bool|IS_NUMBER_GREATER_THAN_UV_MAX
709 =for apidoc Amn|bool|IS_NUMBER_INFINITY
710 =for apidoc Amn|bool|IS_NUMBER_IN_UV
711 =for apidoc Amn|bool|IS_NUMBER_NAN
712 =for apidoc Amn|bool|IS_NUMBER_NEG
713 =for apidoc Amn|bool|IS_NUMBER_NOT_INT
714
715 =cut
716 */
717
718 int
719 Perl_grok_infnan(pTHX_ const char** sp, const char* send)
720 {
721     const char* s = *sp;
722     int flags = 0;
723 #if defined(NV_INF) || defined(NV_NAN)
724     bool odh = FALSE; /* one-dot-hash: 1.#INF */
725
726     PERL_ARGS_ASSERT_GROK_INFNAN;
727
728     if (*s == '+') {
729         s++; if (s == send) return 0;
730     }
731     else if (*s == '-') {
732         flags |= IS_NUMBER_NEG; /* Yes, -NaN happens. Incorrect but happens. */
733         s++; if (s == send) return 0;
734     }
735
736     if (*s == '1') {
737         /* Visual C: 1.#SNAN, -1.#QNAN, 1#INF, 1.#IND (maybe also 1.#NAN)
738          * Let's keep the dot optional. */
739         s++; if (s == send) return 0;
740         if (*s == '.') {
741             s++; if (s == send) return 0;
742         }
743         if (*s == '#') {
744             s++; if (s == send) return 0;
745         } else
746             return 0;
747         odh = TRUE;
748     }
749
750     if (isALPHA_FOLD_EQ(*s, 'I')) {
751         /* INF or IND (1.#IND is "indeterminate", a certain type of NAN) */
752
753         s++; if (s == send || isALPHA_FOLD_NE(*s, 'N')) return 0;
754         s++; if (s == send) return 0;
755         if (isALPHA_FOLD_EQ(*s, 'F')) {
756             s++;
757             if (s < send && (isALPHA_FOLD_EQ(*s, 'I'))) {
758                 int fail =
759                     flags | IS_NUMBER_INFINITY | IS_NUMBER_NOT_INT | IS_NUMBER_TRAILING;
760                 s++; if (s == send || isALPHA_FOLD_NE(*s, 'N')) return fail;
761                 s++; if (s == send || isALPHA_FOLD_NE(*s, 'I')) return fail;
762                 s++; if (s == send || isALPHA_FOLD_NE(*s, 'T')) return fail;
763                 s++; if (s == send || isALPHA_FOLD_NE(*s, 'Y')) return fail;
764                 s++;
765             } else if (odh) {
766                 while (*s == '0') { /* 1.#INF00 */
767                     s++;
768                 }
769             }
770             while (s < send && isSPACE(*s))
771                 s++;
772             if (s < send && *s) {
773                 flags |= IS_NUMBER_TRAILING;
774             }
775             flags |= IS_NUMBER_INFINITY | IS_NUMBER_NOT_INT;
776         }
777         else if (isALPHA_FOLD_EQ(*s, 'D') && odh) { /* 1.#IND */
778             s++;
779             flags |= IS_NUMBER_NAN | IS_NUMBER_NOT_INT;
780             while (*s == '0') { /* 1.#IND00 */
781                 s++;
782             }
783             if (*s) {
784                 flags |= IS_NUMBER_TRAILING;
785             }
786         } else
787             return 0;
788     }
789     else {
790         /* Maybe NAN of some sort */
791
792         if (isALPHA_FOLD_EQ(*s, 'S') || isALPHA_FOLD_EQ(*s, 'Q')) {
793             /* snan, qNaN */
794             /* XXX do something with the snan/qnan difference */
795             s++; if (s == send) return 0;
796         }
797
798         if (isALPHA_FOLD_EQ(*s, 'N')) {
799             s++; if (s == send || isALPHA_FOLD_NE(*s, 'A')) return 0;
800             s++; if (s == send || isALPHA_FOLD_NE(*s, 'N')) return 0;
801             s++;
802
803             flags |= IS_NUMBER_NAN | IS_NUMBER_NOT_INT;
804             if (s == send) {
805                 return flags;
806             }
807
808             /* NaN can be followed by various stuff (NaNQ, NaNS), but
809              * there are also multiple different NaN values, and some
810              * implementations output the "payload" values,
811              * e.g. NaN123, NAN(abc), while some legacy implementations
812              * have weird stuff like NaN%. */
813             if (isALPHA_FOLD_EQ(*s, 'q') ||
814                 isALPHA_FOLD_EQ(*s, 's')) {
815                 /* "nanq" or "nans" are ok, though generating
816                  * these portably is tricky. */
817                 s++;
818                 if (s == send) {
819                     return flags;
820                 }
821             }
822             if (*s == '(') {
823                 /* C99 style "nan(123)" or Perlish equivalent "nan($uv)". */
824                 const char *t;
825                 s++;
826                 if (s == send) {
827                     return flags | IS_NUMBER_TRAILING;
828                 }
829                 t = s + 1;
830                 while (t < send && *t && *t != ')') {
831                     t++;
832                 }
833                 if (t == send) {
834                     return flags | IS_NUMBER_TRAILING;
835                 }
836                 if (*t == ')') {
837                     int nantype;
838                     UV nanval;
839                     if (s[0] == '0' && s + 2 < t &&
840                         isALPHA_FOLD_EQ(s[1], 'x') &&
841                         isXDIGIT(s[2])) {
842                         STRLEN len = t - s;
843                         I32 flags = PERL_SCAN_ALLOW_UNDERSCORES;
844                         nanval = grok_hex(s, &len, &flags, NULL);
845                         if ((flags & PERL_SCAN_GREATER_THAN_UV_MAX)) {
846                             nantype = 0;
847                         } else {
848                             nantype = IS_NUMBER_IN_UV;
849                         }
850                         s += len;
851                     } else if (s[0] == '0' && s + 2 < t &&
852                                isALPHA_FOLD_EQ(s[1], 'b') &&
853                                (s[2] == '0' || s[2] == '1')) {
854                         STRLEN len = t - s;
855                         I32 flags = PERL_SCAN_ALLOW_UNDERSCORES;
856                         nanval = grok_bin(s, &len, &flags, NULL);
857                         if ((flags & PERL_SCAN_GREATER_THAN_UV_MAX)) {
858                             nantype = 0;
859                         } else {
860                             nantype = IS_NUMBER_IN_UV;
861                         }
862                         s += len;
863                     } else {
864                         const char *u;
865                         nantype =
866                             grok_number_flags(s, t - s, &nanval,
867                                               PERL_SCAN_TRAILING |
868                                               PERL_SCAN_ALLOW_UNDERSCORES);
869                         /* Unfortunately grok_number_flags() doesn't
870                          * tell how far we got and the ')' will always
871                          * be "trailing", so we need to double-check
872                          * whether we had something dubious. */
873                         for (u = s; u < t; u++) {
874                             if (!isDIGIT(*u)) {
875                                 flags |= IS_NUMBER_TRAILING;
876                                 break;
877                             }
878                         }
879                         s = u;
880                     }
881
882                     /* XXX Doesn't do octal: nan("0123").
883                      * Probably not a big loss. */
884
885                     if ((nantype & IS_NUMBER_NOT_INT) ||
886                         !(nantype && IS_NUMBER_IN_UV)) {
887                         /* XXX the nanval is currently unused, that is,
888                          * not inserted as the NaN payload of the NV.
889                          * But the above code already parses the C99
890                          * nan(...)  format.  See below, and see also
891                          * the nan() in POSIX.xs.
892                          *
893                          * Certain configuration combinations where
894                          * NVSIZE is greater than UVSIZE mean that
895                          * a single UV cannot contain all the possible
896                          * NaN payload bits.  There would need to be
897                          * some more generic syntax than "nan($uv)".
898                          *
899                          * Issues to keep in mind:
900                          *
901                          * (1) In most common cases there would
902                          * not be an integral number of bytes that
903                          * could be set, only a certain number of bits.
904                          * For example for the common case of
905                          * NVSIZE == UVSIZE == 8 there is room for 52
906                          * bits in the payload, but the most significant
907                          * bit is commonly reserved for the
908                          * signaling/quiet bit, leaving 51 bits.
909                          * Furthermore, the C99 nan() is supposed
910                          * to generate quiet NaNs, so it is doubtful
911                          * whether it should be able to generate
912                          * signaling NaNs.  For the x86 80-bit doubles
913                          * (if building a long double Perl) there would
914                          * be 62 bits (s/q bit being the 63rd).
915                          *
916                          * (2) Endianness of the payload bits. If the
917                          * payload is specified as an UV, the low-order
918                          * bits of the UV are naturally little-endianed
919                          * (rightmost) bits of the payload.  The endianness
920                          * of UVs and NVs can be different. */
921                         return 0;
922                     }
923                     if (s < t) {
924                         flags |= IS_NUMBER_TRAILING;
925                     }
926                 } else {
927                     /* Looked like nan(...), but no close paren. */
928                     flags |= IS_NUMBER_TRAILING;
929                 }
930             } else {
931                 while (s < send && isSPACE(*s))
932                     s++;
933                 if (s < send && *s) {
934                     /* Note that we here implicitly accept (parse as
935                      * "nan", but with warnings) also any other weird
936                      * trailing stuff for "nan".  In the above we just
937                      * check that if we got the C99-style "nan(...)",
938                      * the "..."  looks sane.
939                      * If in future we accept more ways of specifying
940                      * the nan payload, the accepting would happen around
941                      * here. */
942                     flags |= IS_NUMBER_TRAILING;
943                 }
944             }
945             s = send;
946         }
947         else
948             return 0;
949     }
950
951     while (s < send && isSPACE(*s))
952         s++;
953
954 #else
955     PERL_UNUSED_ARG(send);
956 #endif /* #if defined(NV_INF) || defined(NV_NAN) */
957     *sp = s;
958     return flags;
959 }
960
961 /*
962 =for apidoc grok_number_flags
963
964 Recognise (or not) a number.  The type of the number is returned
965 (0 if unrecognised), otherwise it is a bit-ORed combination of
966 C<IS_NUMBER_IN_UV>, C<IS_NUMBER_GREATER_THAN_UV_MAX>, C<IS_NUMBER_NOT_INT>,
967 C<IS_NUMBER_NEG>, C<IS_NUMBER_INFINITY>, C<IS_NUMBER_NAN> (defined in perl.h).
968
969 If the value of the number can fit in a UV, it is returned in C<*valuep>.
970 C<IS_NUMBER_IN_UV> will be set to indicate that C<*valuep> is valid, C<IS_NUMBER_IN_UV>
971 will never be set unless C<*valuep> is valid, but C<*valuep> may have been assigned
972 to during processing even though C<IS_NUMBER_IN_UV> is not set on return.
973 If C<valuep> is C<NULL>, C<IS_NUMBER_IN_UV> will be set for the same cases as when
974 C<valuep> is non-C<NULL>, but no actual assignment (or SEGV) will occur.
975
976 C<IS_NUMBER_NOT_INT> will be set with C<IS_NUMBER_IN_UV> if trailing decimals were
977 seen (in which case C<*valuep> gives the true value truncated to an integer), and
978 C<IS_NUMBER_NEG> if the number is negative (in which case C<*valuep> holds the
979 absolute value).  C<IS_NUMBER_IN_UV> is not set if e notation was used or the
980 number is larger than a UV.
981
982 C<flags> allows only C<PERL_SCAN_TRAILING>, which allows for trailing
983 non-numeric text on an otherwise successful I<grok>, setting
984 C<IS_NUMBER_TRAILING> on the result.
985
986 =for apidoc Amnh||PERL_SCAN_TRAILING
987
988 =for apidoc grok_number
989
990 Identical to C<grok_number_flags()> with C<flags> set to zero.
991
992 =cut
993  */
994 int
995 Perl_grok_number(pTHX_ const char *pv, STRLEN len, UV *valuep)
996 {
997     PERL_ARGS_ASSERT_GROK_NUMBER;
998
999     return grok_number_flags(pv, len, valuep, 0);
1000 }
1001
1002 static const UV uv_max_div_10 = UV_MAX / 10;
1003 static const U8 uv_max_mod_10 = UV_MAX % 10;
1004
1005 int
1006 Perl_grok_number_flags(pTHX_ const char *pv, STRLEN len, UV *valuep, U32 flags)
1007 {
1008   const char *s = pv;
1009   const char * const send = pv + len;
1010   const char *d;
1011   int numtype = 0;
1012
1013   PERL_ARGS_ASSERT_GROK_NUMBER_FLAGS;
1014
1015   while (s < send && isSPACE(*s))
1016     s++;
1017   if (s == send) {
1018     return 0;
1019   } else if (*s == '-') {
1020     s++;
1021     numtype = IS_NUMBER_NEG;
1022   }
1023   else if (*s == '+')
1024     s++;
1025
1026   if (s == send)
1027     return 0;
1028
1029   /* The first digit (after optional sign): note that might
1030    * also point to "infinity" or "nan", or "1.#INF". */
1031   d = s;
1032
1033   /* next must be digit or the radix separator or beginning of infinity/nan */
1034   if (isDIGIT(*s)) {
1035     /* UVs are at least 32 bits, so the first 9 decimal digits cannot
1036        overflow.  */
1037     UV value = *s - '0';
1038     /* This construction seems to be more optimiser friendly.
1039        (without it gcc does the isDIGIT test and the *s - '0' separately)
1040        With it gcc on arm is managing 6 instructions (6 cycles) per digit.
1041        In theory the optimiser could deduce how far to unroll the loop
1042        before checking for overflow.  */
1043     if (++s < send) {
1044       int digit = *s - '0';
1045       if (inRANGE(digit, 0, 9)) {
1046         value = value * 10 + digit;
1047         if (++s < send) {
1048           digit = *s - '0';
1049           if (inRANGE(digit, 0, 9)) {
1050             value = value * 10 + digit;
1051             if (++s < send) {
1052               digit = *s - '0';
1053               if (inRANGE(digit, 0, 9)) {
1054                 value = value * 10 + digit;
1055                 if (++s < send) {
1056                   digit = *s - '0';
1057                   if (inRANGE(digit, 0, 9)) {
1058                     value = value * 10 + digit;
1059                     if (++s < send) {
1060                       digit = *s - '0';
1061                       if (inRANGE(digit, 0, 9)) {
1062                         value = value * 10 + digit;
1063                         if (++s < send) {
1064                           digit = *s - '0';
1065                           if (inRANGE(digit, 0, 9)) {
1066                             value = value * 10 + digit;
1067                             if (++s < send) {
1068                               digit = *s - '0';
1069                               if (inRANGE(digit, 0, 9)) {
1070                                 value = value * 10 + digit;
1071                                 if (++s < send) {
1072                                   digit = *s - '0';
1073                                   if (inRANGE(digit, 0, 9)) {
1074                                     value = value * 10 + digit;
1075                                     if (++s < send) {
1076                                       /* Now got 9 digits, so need to check
1077                                          each time for overflow.  */
1078                                       digit = *s - '0';
1079                                       while (    inRANGE(digit, 0, 9)
1080                                              && (value < uv_max_div_10
1081                                                  || (value == uv_max_div_10
1082                                                      && digit <= uv_max_mod_10))) {
1083                                         value = value * 10 + digit;
1084                                         if (++s < send)
1085                                           digit = *s - '0';
1086                                         else
1087                                           break;
1088                                       }
1089                                       if (inRANGE(digit, 0, 9)
1090                                           && (s < send)) {
1091                                         /* value overflowed.
1092                                            skip the remaining digits, don't
1093                                            worry about setting *valuep.  */
1094                                         do {
1095                                           s++;
1096                                         } while (s < send && isDIGIT(*s));
1097                                         numtype |=
1098                                           IS_NUMBER_GREATER_THAN_UV_MAX;
1099                                         goto skip_value;
1100                                       }
1101                                     }
1102                                   }
1103                                 }
1104                               }
1105                             }
1106                           }
1107                         }
1108                       }
1109                     }
1110                   }
1111                 }
1112               }
1113             }
1114           }
1115         }
1116       }
1117     }
1118     numtype |= IS_NUMBER_IN_UV;
1119     if (valuep)
1120       *valuep = value;
1121
1122   skip_value:
1123     if (GROK_NUMERIC_RADIX(&s, send)) {
1124       numtype |= IS_NUMBER_NOT_INT;
1125       while (s < send && isDIGIT(*s))  /* optional digits after the radix */
1126         s++;
1127     }
1128   }
1129   else if (GROK_NUMERIC_RADIX(&s, send)) {
1130     numtype |= IS_NUMBER_NOT_INT | IS_NUMBER_IN_UV; /* valuep assigned below */
1131     /* no digits before the radix means we need digits after it */
1132     if (s < send && isDIGIT(*s)) {
1133       do {
1134         s++;
1135       } while (s < send && isDIGIT(*s));
1136       if (valuep) {
1137         /* integer approximation is valid - it's 0.  */
1138         *valuep = 0;
1139       }
1140     }
1141     else
1142         return 0;
1143   }
1144
1145   if (s > d && s < send) {
1146     /* we can have an optional exponent part */
1147     if (isALPHA_FOLD_EQ(*s, 'e')) {
1148       s++;
1149       if (s < send && (*s == '-' || *s == '+'))
1150         s++;
1151       if (s < send && isDIGIT(*s)) {
1152         do {
1153           s++;
1154         } while (s < send && isDIGIT(*s));
1155       }
1156       else if (flags & PERL_SCAN_TRAILING)
1157         return numtype | IS_NUMBER_TRAILING;
1158       else
1159         return 0;
1160
1161       /* The only flag we keep is sign.  Blow away any "it's UV"  */
1162       numtype &= IS_NUMBER_NEG;
1163       numtype |= IS_NUMBER_NOT_INT;
1164     }
1165   }
1166   while (s < send && isSPACE(*s))
1167     s++;
1168   if (s >= send)
1169     return numtype;
1170   if (memEQs(pv, len, "0 but true")) {
1171     if (valuep)
1172       *valuep = 0;
1173     return IS_NUMBER_IN_UV;
1174   }
1175   /* We could be e.g. at "Inf" or "NaN", or at the "#" of "1.#INF". */
1176   if ((s + 2 < send) && memCHRs("inqs#", toFOLD(*s))) {
1177       /* Really detect inf/nan. Start at d, not s, since the above
1178        * code might have already consumed the "1." or "1". */
1179       const int infnan = Perl_grok_infnan(aTHX_ &d, send);
1180       if ((infnan & IS_NUMBER_INFINITY)) {
1181           return (numtype | infnan); /* Keep sign for infinity. */
1182       }
1183       else if ((infnan & IS_NUMBER_NAN)) {
1184           return (numtype | infnan) & ~IS_NUMBER_NEG; /* Clear sign for nan. */
1185       }
1186   }
1187   else if (flags & PERL_SCAN_TRAILING) {
1188     return numtype | IS_NUMBER_TRAILING;
1189   }
1190
1191   return 0;
1192 }
1193
1194 /*
1195 =for apidoc grok_atoUV
1196
1197 parse a string, looking for a decimal unsigned integer.
1198
1199 On entry, C<pv> points to the beginning of the string;
1200 C<valptr> points to a UV that will receive the converted value, if found;
1201 C<endptr> is either NULL or points to a variable that points to one byte
1202 beyond the point in C<pv> that this routine should examine.
1203 If C<endptr> is NULL, C<pv> is assumed to be NUL-terminated.
1204
1205 Returns FALSE if C<pv> doesn't represent a valid unsigned integer value (with
1206 no leading zeros).  Otherwise it returns TRUE, and sets C<*valptr> to that
1207 value.
1208
1209 If you constrain the portion of C<pv> that is looked at by this function (by
1210 passing a non-NULL C<endptr>), and if the intial bytes of that portion form a
1211 valid value, it will return TRUE, setting C<*endptr> to the byte following the
1212 final digit of the value.  But if there is no constraint at what's looked at,
1213 all of C<pv> must be valid in order for TRUE to be returned.
1214
1215 The only characters this accepts are the decimal digits '0'..'9'.
1216
1217 As opposed to L<atoi(3)> or L<strtol(3)>, C<grok_atoUV> does NOT allow optional
1218 leading whitespace, nor negative inputs.  If such features are required, the
1219 calling code needs to explicitly implement those.
1220
1221 Note that this function returns FALSE for inputs that would overflow a UV,
1222 or have leading zeros.  Thus a single C<0> is accepted, but not C<00> nor
1223 C<01>, C<002>, I<etc>.
1224
1225 Background: C<atoi> has severe problems with illegal inputs, it cannot be
1226 used for incremental parsing, and therefore should be avoided
1227 C<atoi> and C<strtol> are also affected by locale settings, which can also be
1228 seen as a bug (global state controlled by user environment).
1229
1230 =cut
1231
1232 */
1233
1234 bool
1235 Perl_grok_atoUV(const char *pv, UV *valptr, const char** endptr)
1236 {
1237     const char* s = pv;
1238     const char** eptr;
1239     const char* end2; /* Used in case endptr is NULL. */
1240     UV val = 0; /* The parsed value. */
1241
1242     PERL_ARGS_ASSERT_GROK_ATOUV;
1243
1244     if (endptr) {
1245         eptr = endptr;
1246     }
1247     else {
1248         end2 = s + strlen(s);
1249         eptr = &end2;
1250     }
1251
1252     if (   *eptr <= s
1253         || ! isDIGIT(*s))
1254     {
1255         return FALSE;
1256     }
1257
1258     /* Single-digit inputs are quite common. */
1259     val = *s++ - '0';
1260     if (s < *eptr && isDIGIT(*s)) {
1261         /* Fail on extra leading zeros. */
1262         if (val == 0)
1263             return FALSE;
1264         while (s < *eptr && isDIGIT(*s)) {
1265             /* This could be unrolled like in grok_number(), but
1266                 * the expected uses of this are not speed-needy, and
1267                 * unlikely to need full 64-bitness. */
1268             const U8 digit = *s++ - '0';
1269             if (val < uv_max_div_10 ||
1270                 (val == uv_max_div_10 && digit <= uv_max_mod_10)) {
1271                 val = val * 10 + digit;
1272             } else {
1273                 return FALSE;
1274             }
1275         }
1276     }
1277
1278     if (endptr == NULL) {
1279         if (*s) {
1280             return FALSE; /* If endptr is NULL, no trailing non-digits allowed. */
1281         }
1282     }
1283     else {
1284         *endptr = s;
1285     }
1286
1287     *valptr = val;
1288     return TRUE;
1289 }
1290
1291 #ifndef Perl_strtod
1292 STATIC NV
1293 S_mulexp10(NV value, I32 exponent)
1294 {
1295     NV result = 1.0;
1296     NV power = 10.0;
1297     bool negative = 0;
1298     I32 bit;
1299
1300     if (exponent == 0)
1301         return value;
1302     if (value == 0)
1303         return (NV)0;
1304
1305     /* On OpenVMS VAX we by default use the D_FLOAT double format,
1306      * and that format does not have *easy* capabilities [1] for
1307      * overflowing doubles 'silently' as IEEE fp does.  We also need
1308      * to support G_FLOAT on both VAX and Alpha, and though the exponent
1309      * range is much larger than D_FLOAT it still doesn't do silent
1310      * overflow.  Therefore we need to detect early whether we would
1311      * overflow (this is the behaviour of the native string-to-float
1312      * conversion routines, and therefore of native applications, too).
1313      *
1314      * [1] Trying to establish a condition handler to trap floating point
1315      *     exceptions is not a good idea. */
1316
1317     /* In UNICOS and in certain Cray models (such as T90) there is no
1318      * IEEE fp, and no way at all from C to catch fp overflows gracefully.
1319      * There is something you can do if you are willing to use some
1320      * inline assembler: the instruction is called DFI-- but that will
1321      * disable *all* floating point interrupts, a little bit too large
1322      * a hammer.  Therefore we need to catch potential overflows before
1323      * it's too late. */
1324
1325 #if ((defined(VMS) && !defined(_IEEE_FP)) || defined(_UNICOS) || defined(DOUBLE_IS_VAX_FLOAT)) && defined(NV_MAX_10_EXP)
1326     STMT_START {
1327         const NV exp_v = log10(value);
1328         if (exponent >= NV_MAX_10_EXP || exponent + exp_v >= NV_MAX_10_EXP)
1329             return NV_MAX;
1330         if (exponent < 0) {
1331             if (-(exponent + exp_v) >= NV_MAX_10_EXP)
1332                 return 0.0;
1333             while (-exponent >= NV_MAX_10_EXP) {
1334                 /* combination does not overflow, but 10^(-exponent) does */
1335                 value /= 10;
1336                 ++exponent;
1337             }
1338         }
1339     } STMT_END;
1340 #endif
1341
1342     if (exponent < 0) {
1343         negative = 1;
1344         exponent = -exponent;
1345 #ifdef NV_MAX_10_EXP
1346         /* for something like 1234 x 10^-309, the action of calculating
1347          * the intermediate value 10^309 then returning 1234 / (10^309)
1348          * will fail, since 10^309 becomes infinity. In this case try to
1349          * refactor it as 123 / (10^308) etc.
1350          */
1351         while (value && exponent > NV_MAX_10_EXP) {
1352             exponent--;
1353             value /= 10;
1354         }
1355         if (value == 0.0)
1356             return value;
1357 #endif
1358     }
1359 #if defined(__osf__)
1360     /* Even with cc -ieee + ieee_set_fp_control(IEEE_TRAP_ENABLE_INV)
1361      * Tru64 fp behavior on inf/nan is somewhat broken. Another way
1362      * to do this would be ieee_set_fp_control(IEEE_TRAP_ENABLE_OVF)
1363      * but that breaks another set of infnan.t tests. */
1364 #  define FP_OVERFLOWS_TO_ZERO
1365 #endif
1366     for (bit = 1; exponent; bit <<= 1) {
1367         if (exponent & bit) {
1368             exponent ^= bit;
1369             result *= power;
1370 #ifdef FP_OVERFLOWS_TO_ZERO
1371             if (result == 0)
1372 # ifdef NV_INF
1373                 return value < 0 ? -NV_INF : NV_INF;
1374 # else
1375                 return value < 0 ? -FLT_MAX : FLT_MAX;
1376 # endif
1377 #endif
1378             /* Floating point exceptions are supposed to be turned off,
1379              *  but if we're obviously done, don't risk another iteration.
1380              */
1381              if (exponent == 0) break;
1382         }
1383         power *= power;
1384     }
1385     return negative ? value / result : value * result;
1386 }
1387 #endif /* #ifndef Perl_strtod */
1388
1389 #ifdef Perl_strtod
1390 #  define ATOF(s, x) my_atof2(s, &x)
1391 #else
1392 #  define ATOF(s, x) Perl_atof2(s, x)
1393 #endif
1394
1395 NV
1396 Perl_my_atof(pTHX_ const char* s)
1397 {
1398     /* 's' must be NUL terminated */
1399
1400     NV x = 0.0;
1401
1402     PERL_ARGS_ASSERT_MY_ATOF;
1403
1404 #if ! defined(USE_LOCALE_NUMERIC)
1405
1406     ATOF(s, x);
1407
1408 #else
1409
1410     {
1411         DECLARATION_FOR_LC_NUMERIC_MANIPULATION;
1412         STORE_LC_NUMERIC_SET_TO_NEEDED();
1413         if (! (PL_numeric_radix_sv && IN_LC(LC_NUMERIC))) {
1414             ATOF(s,x);
1415         }
1416         else {
1417
1418             /* Look through the string for the first thing that looks like a
1419              * decimal point: either the value in the current locale or the
1420              * standard fallback of '.'. The one which appears earliest in the
1421              * input string is the one that we should have atof look for. Note
1422              * that we have to determine this beforehand because on some
1423              * systems, Perl_atof2 is just a wrapper around the system's atof.
1424              * */
1425             const char * const standard_pos = strchr(s, '.');
1426             const char * const local_pos
1427                                   = strstr(s, SvPV_nolen(PL_numeric_radix_sv));
1428             const bool use_standard_radix
1429                     = standard_pos && (!local_pos || standard_pos < local_pos);
1430
1431             if (use_standard_radix) {
1432                 SET_NUMERIC_STANDARD();
1433                 LOCK_LC_NUMERIC_STANDARD();
1434             }
1435
1436             ATOF(s,x);
1437
1438             if (use_standard_radix) {
1439                 UNLOCK_LC_NUMERIC_STANDARD();
1440                 SET_NUMERIC_UNDERLYING();
1441             }
1442         }
1443         RESTORE_LC_NUMERIC();
1444     }
1445
1446 #endif
1447
1448     return x;
1449 }
1450
1451 #if defined(NV_INF) || defined(NV_NAN)
1452
1453 static char*
1454 S_my_atof_infnan(pTHX_ const char* s, bool negative, const char* send, NV* value)
1455 {
1456     const char *p0 = negative ? s - 1 : s;
1457     const char *p = p0;
1458     const int infnan = grok_infnan(&p, send);
1459     if (infnan && p != p0) {
1460         /* If we can generate inf/nan directly, let's do so. */
1461 #ifdef NV_INF
1462         if ((infnan & IS_NUMBER_INFINITY)) {
1463             *value = (infnan & IS_NUMBER_NEG) ? -NV_INF: NV_INF;
1464             return (char*)p;
1465         }
1466 #endif
1467 #ifdef NV_NAN
1468         if ((infnan & IS_NUMBER_NAN)) {
1469             *value = NV_NAN;
1470             return (char*)p;
1471         }
1472 #endif
1473 #ifdef Perl_strtod
1474         /* If still here, we didn't have either NV_INF or NV_NAN,
1475          * and can try falling back to native strtod/strtold.
1476          *
1477          * The native interface might not recognize all the possible
1478          * inf/nan strings Perl recognizes.  What we can try
1479          * is to try faking the input.  We will try inf/-inf/nan
1480          * as the most promising/portable input. */
1481         {
1482             const char* fake = "silence compiler warning";
1483             char* endp;
1484             NV nv;
1485 #ifdef NV_INF
1486             if ((infnan & IS_NUMBER_INFINITY)) {
1487                 fake = ((infnan & IS_NUMBER_NEG)) ? "-inf" : "inf";
1488             }
1489 #endif
1490 #ifdef NV_NAN
1491             if ((infnan & IS_NUMBER_NAN)) {
1492                 fake = "nan";
1493             }
1494 #endif
1495             assert(strNE(fake, "silence compiler warning"));
1496             nv = S_strtod(aTHX_ fake, &endp);
1497             if (fake != endp) {
1498 #ifdef NV_INF
1499                 if ((infnan & IS_NUMBER_INFINITY)) {
1500 #  ifdef Perl_isinf
1501                     if (Perl_isinf(nv))
1502                         *value = nv;
1503 #  else
1504                     /* last resort, may generate SIGFPE */
1505                     *value = Perl_exp((NV)1e9);
1506                     if ((infnan & IS_NUMBER_NEG))
1507                         *value = -*value;
1508 #  endif
1509                     return (char*)p; /* p, not endp */
1510                 }
1511 #endif
1512 #ifdef NV_NAN
1513                 if ((infnan & IS_NUMBER_NAN)) {
1514 #  ifdef Perl_isnan
1515                     if (Perl_isnan(nv))
1516                         *value = nv;
1517 #  else
1518                     /* last resort, may generate SIGFPE */
1519                     *value = Perl_log((NV)-1.0);
1520 #  endif
1521                     return (char*)p; /* p, not endp */
1522 #endif
1523                 }
1524             }
1525         }
1526 #endif /* #ifdef Perl_strtod */
1527     }
1528     return NULL;
1529 }
1530
1531 #endif /* if defined(NV_INF) || defined(NV_NAN) */
1532
1533 char*
1534 Perl_my_atof2(pTHX_ const char* orig, NV* value)
1535 {
1536     PERL_ARGS_ASSERT_MY_ATOF2;
1537     return my_atof3(orig, value, 0);
1538 }
1539
1540 char*
1541 Perl_my_atof3(pTHX_ const char* orig, NV* value, const STRLEN len)
1542 {
1543     const char* s = orig;
1544     NV result[3] = {0.0, 0.0, 0.0};
1545 #if defined(USE_PERL_ATOF) || defined(Perl_strtod)
1546     const char* send = s + ((len != 0)
1547                            ? len
1548                            : strlen(orig)); /* one past the last */
1549     bool negative = 0;
1550 #endif
1551 #if defined(USE_PERL_ATOF) && !defined(Perl_strtod)
1552     UV accumulator[2] = {0,0};  /* before/after dp */
1553     bool seen_digit = 0;
1554     I32 exp_adjust[2] = {0,0};
1555     I32 exp_acc[2] = {-1, -1};
1556     /* the current exponent adjust for the accumulators */
1557     I32 exponent = 0;
1558     I32 seen_dp  = 0;
1559     I32 digit = 0;
1560     I32 old_digit = 0;
1561     I32 sig_digits = 0; /* noof significant digits seen so far */
1562 #endif
1563
1564 #if defined(USE_PERL_ATOF) || defined(Perl_strtod)
1565     PERL_ARGS_ASSERT_MY_ATOF3;
1566
1567     /* leading whitespace */
1568     while (s < send && isSPACE(*s))
1569         ++s;
1570
1571     /* sign */
1572     switch (*s) {
1573         case '-':
1574             negative = 1;
1575             /* FALLTHROUGH */
1576         case '+':
1577             ++s;
1578     }
1579 #endif
1580
1581 #ifdef Perl_strtod
1582     {
1583         char* endp;
1584         char* copy = NULL;
1585
1586         if ((endp = S_my_atof_infnan(aTHX_ s, negative, send, value)))
1587             return endp;
1588
1589         /* strtold() accepts 0x-prefixed hex and in POSIX implementations,
1590            0b-prefixed binary numbers, which is backward incompatible
1591         */
1592         if ((len == 0 || len - (s-orig) >= 2) && *s == '0' &&
1593             (isALPHA_FOLD_EQ(s[1], 'x') || isALPHA_FOLD_EQ(s[1], 'b'))) {
1594             *value = 0;
1595             return (char *)s+1;
1596         }
1597
1598         /* If the length is passed in, the input string isn't NUL-terminated,
1599          * and in it turns out the function below assumes it is; therefore we
1600          * create a copy and NUL-terminate that */
1601         if (len) {
1602             Newx(copy, len + 1, char);
1603             Copy(orig, copy, len, char);
1604             copy[len] = '\0';
1605             s = copy + (s - orig);
1606         }
1607
1608         result[2] = S_strtod(aTHX_ s, &endp);
1609
1610         /* If we created a copy, 'endp' is in terms of that.  Convert back to
1611          * the original */
1612         if (copy) {
1613             s = (s - copy) + (char *) orig;
1614             endp = (endp - copy) + (char *) orig;
1615             Safefree(copy);
1616         }
1617
1618         if (s != endp) {
1619             *value = negative ? -result[2] : result[2];
1620             return endp;
1621         }
1622         return NULL;
1623     }
1624 #elif defined(USE_PERL_ATOF)
1625
1626 /* There is no point in processing more significant digits
1627  * than the NV can hold. Note that NV_DIG is a lower-bound value,
1628  * while we need an upper-bound value. We add 2 to account for this;
1629  * since it will have been conservative on both the first and last digit.
1630  * For example a 32-bit mantissa with an exponent of 4 would have
1631  * exact values in the set
1632  *               4
1633  *               8
1634  *              ..
1635  *     17179869172
1636  *     17179869176
1637  *     17179869180
1638  *
1639  * where for the purposes of calculating NV_DIG we would have to discount
1640  * both the first and last digit, since neither can hold all values from
1641  * 0..9; but for calculating the value we must examine those two digits.
1642  */
1643 #ifdef MAX_SIG_DIG_PLUS
1644     /* It is not necessarily the case that adding 2 to NV_DIG gets all the
1645        possible digits in a NV, especially if NVs are not IEEE compliant
1646        (e.g., long doubles on IRIX) - Allen <allens@cpan.org> */
1647 # define MAX_SIG_DIGITS (NV_DIG+MAX_SIG_DIG_PLUS)
1648 #else
1649 # define MAX_SIG_DIGITS (NV_DIG+2)
1650 #endif
1651
1652 /* the max number we can accumulate in a UV, and still safely do 10*N+9 */
1653 #define MAX_ACCUMULATE ( (UV) ((UV_MAX - 9)/10))
1654
1655 #if defined(NV_INF) || defined(NV_NAN)
1656     {
1657         char* endp;
1658         if ((endp = S_my_atof_infnan(aTHX_ s, negative, send, value)))
1659             return endp;
1660     }
1661 #endif
1662
1663     /* we accumulate digits into an integer; when this becomes too
1664      * large, we add the total to NV and start again */
1665
1666     while (s < send) {
1667         if (isDIGIT(*s)) {
1668             seen_digit = 1;
1669             old_digit = digit;
1670             digit = *s++ - '0';
1671             if (seen_dp)
1672                 exp_adjust[1]++;
1673
1674             /* don't start counting until we see the first significant
1675              * digit, eg the 5 in 0.00005... */
1676             if (!sig_digits && digit == 0)
1677                 continue;
1678
1679             if (++sig_digits > MAX_SIG_DIGITS) {
1680                 /* limits of precision reached */
1681                 if (digit > 5) {
1682                     ++accumulator[seen_dp];
1683                 } else if (digit == 5) {
1684                     if (old_digit % 2) { /* round to even - Allen */
1685                         ++accumulator[seen_dp];
1686                     }
1687                 }
1688                 if (seen_dp) {
1689                     exp_adjust[1]--;
1690                 } else {
1691                     exp_adjust[0]++;
1692                 }
1693                 /* skip remaining digits */
1694                 while (s < send && isDIGIT(*s)) {
1695                     ++s;
1696                     if (! seen_dp) {
1697                         exp_adjust[0]++;
1698                     }
1699                 }
1700                 /* warn of loss of precision? */
1701             }
1702             else {
1703                 if (accumulator[seen_dp] > MAX_ACCUMULATE) {
1704                     /* add accumulator to result and start again */
1705                     result[seen_dp] = S_mulexp10(result[seen_dp],
1706                                                  exp_acc[seen_dp])
1707                         + (NV)accumulator[seen_dp];
1708                     accumulator[seen_dp] = 0;
1709                     exp_acc[seen_dp] = 0;
1710                 }
1711                 accumulator[seen_dp] = accumulator[seen_dp] * 10 + digit;
1712                 ++exp_acc[seen_dp];
1713             }
1714         }
1715         else if (!seen_dp && GROK_NUMERIC_RADIX(&s, send)) {
1716             seen_dp = 1;
1717             if (sig_digits > MAX_SIG_DIGITS) {
1718                 while (s < send && isDIGIT(*s)) {
1719                     ++s;
1720                 }
1721                 break;
1722             }
1723         }
1724         else {
1725             break;
1726         }
1727     }
1728
1729     result[0] = S_mulexp10(result[0], exp_acc[0]) + (NV)accumulator[0];
1730     if (seen_dp) {
1731         result[1] = S_mulexp10(result[1], exp_acc[1]) + (NV)accumulator[1];
1732     }
1733
1734     if (s < send && seen_digit && (isALPHA_FOLD_EQ(*s, 'e'))) {
1735         bool expnegative = 0;
1736
1737         ++s;
1738         switch (*s) {
1739             case '-':
1740                 expnegative = 1;
1741                 /* FALLTHROUGH */
1742             case '+':
1743                 ++s;
1744         }
1745         while (s < send && isDIGIT(*s))
1746             exponent = exponent * 10 + (*s++ - '0');
1747         if (expnegative)
1748             exponent = -exponent;
1749     }
1750
1751     /* now apply the exponent */
1752
1753     if (seen_dp) {
1754         result[2] = S_mulexp10(result[0],exponent+exp_adjust[0])
1755                 + S_mulexp10(result[1],exponent-exp_adjust[1]);
1756     } else {
1757         result[2] = S_mulexp10(result[0],exponent+exp_adjust[0]);
1758     }
1759
1760     /* now apply the sign */
1761     if (negative)
1762         result[2] = -result[2];
1763 #endif /* USE_PERL_ATOF */
1764     *value = result[2];
1765     return (char *)s;
1766 }
1767
1768 /*
1769 =for apidoc isinfnan
1770
1771 C<Perl_isinfnan()> is a utility function that returns true if the NV
1772 argument is either an infinity or a C<NaN>, false otherwise.  To test
1773 in more detail, use C<Perl_isinf()> and C<Perl_isnan()>.
1774
1775 This is also the logical inverse of Perl_isfinite().
1776
1777 =cut
1778 */
1779 bool
1780 Perl_isinfnan(NV nv)
1781 {
1782   PERL_UNUSED_ARG(nv);
1783 #ifdef Perl_isinf
1784     if (Perl_isinf(nv))
1785         return TRUE;
1786 #endif
1787 #ifdef Perl_isnan
1788     if (Perl_isnan(nv))
1789         return TRUE;
1790 #endif
1791     return FALSE;
1792 }
1793
1794 /*
1795 =for apidoc isinfnansv
1796
1797 Checks whether the argument would be either an infinity or C<NaN> when used
1798 as a number, but is careful not to trigger non-numeric or uninitialized
1799 warnings.  it assumes the caller has done C<SvGETMAGIC(sv)> already.
1800
1801 =cut
1802 */
1803
1804 bool
1805 Perl_isinfnansv(pTHX_ SV *sv)
1806 {
1807     PERL_ARGS_ASSERT_ISINFNANSV;
1808     if (!SvOK(sv))
1809         return FALSE;
1810     if (SvNOKp(sv))
1811         return Perl_isinfnan(SvNVX(sv));
1812     if (SvIOKp(sv))
1813         return FALSE;
1814     {
1815         STRLEN len;
1816         const char *s = SvPV_nomg_const(sv, len);
1817         return cBOOL(grok_infnan(&s, s+len));
1818     }
1819 }
1820
1821 #ifndef HAS_MODFL
1822 /* C99 has truncl, pre-C99 Solaris had aintl.  We can use either with
1823  * copysignl to emulate modfl, which is in some platforms missing or
1824  * broken. */
1825 #  if defined(HAS_TRUNCL) && defined(HAS_COPYSIGNL)
1826 long double
1827 Perl_my_modfl(long double x, long double *ip)
1828 {
1829     *ip = truncl(x);
1830     return (x == *ip ? copysignl(0.0L, x) : x - *ip);
1831 }
1832 #  elif defined(HAS_AINTL) && defined(HAS_COPYSIGNL)
1833 long double
1834 Perl_my_modfl(long double x, long double *ip)
1835 {
1836     *ip = aintl(x);
1837     return (x == *ip ? copysignl(0.0L, x) : x - *ip);
1838 }
1839 #  endif
1840 #endif
1841
1842 /* Similarly, with ilogbl and scalbnl we can emulate frexpl. */
1843 #if ! defined(HAS_FREXPL) && defined(HAS_ILOGBL) && defined(HAS_SCALBNL)
1844 long double
1845 Perl_my_frexpl(long double x, int *e) {
1846     *e = x == 0.0L ? 0 : ilogbl(x) + 1;
1847     return (scalbnl(x, -*e));
1848 }
1849 #endif
1850
1851 /*
1852 =for apidoc Perl_signbit
1853
1854 Return a non-zero integer if the sign bit on an NV is set, and 0 if
1855 it is not.
1856
1857 If F<Configure> detects this system has a C<signbit()> that will work with
1858 our NVs, then we just use it via the C<#define> in F<perl.h>.  Otherwise,
1859 fall back on this implementation.  The main use of this function
1860 is catching C<-0.0>.
1861
1862 C<Configure> notes:  This function is called C<'Perl_signbit'> instead of a
1863 plain C<'signbit'> because it is easy to imagine a system having a C<signbit()>
1864 function or macro that doesn't happen to work with our particular choice
1865 of NVs.  We shouldn't just re-C<#define> C<signbit> as C<Perl_signbit> and expect
1866 the standard system headers to be happy.  Also, this is a no-context
1867 function (no C<pTHX_>) because C<Perl_signbit()> is usually re-C<#defined> in
1868 F<perl.h> as a simple macro call to the system's C<signbit()>.
1869 Users should just always call C<Perl_signbit()>.
1870
1871 =cut
1872 */
1873 #if !defined(HAS_SIGNBIT)
1874 int
1875 Perl_signbit(NV x) {
1876 #  ifdef Perl_fp_class_nzero
1877     return Perl_fp_class_nzero(x);
1878     /* Try finding the high byte, and assume it's highest bit
1879      * is the sign.  This assumption is probably wrong somewhere. */
1880 #  elif defined(USE_LONG_DOUBLE) && LONG_DOUBLEKIND == LONG_DOUBLE_IS_X86_80_BIT_LITTLE_ENDIAN
1881     return (((unsigned char *)&x)[9] & 0x80);
1882 #  elif defined(NV_LITTLE_ENDIAN)
1883     /* Note that NVSIZE is sizeof(NV), which would make the below be
1884      * wrong if the end bytes are unused, which happens with the x86
1885      * 80-bit long doubles, which is why take care of that above. */
1886     return (((unsigned char *)&x)[NVSIZE - 1] & 0x80);
1887 #  elif defined(NV_BIG_ENDIAN)
1888     return (((unsigned char *)&x)[0] & 0x80);
1889 #  else
1890     /* This last resort fallback is wrong for the negative zero. */
1891     return (x < 0.0) ? 1 : 0;
1892 #  endif
1893 }
1894 #endif
1895
1896 /*
1897  * ex: set ts=8 sts=4 sw=4 et:
1898  */