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