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