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