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