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