Re: [ID 20010529.006] String plus zero inconsistent across platforms

Message-Id: <200105311949.UAA02798@crypt.compulink.co.uk>

p4raw-id: //depot/perl@10379

diff --git a/embed.h b/embed.h
index 1a2f0e0..dd0097c 100644 (file)
--- a/embed.h
+++ b/embed.h
@@ -1178,6 +1178,7 @@
 #define sv_utf8_upgrade_flags  Perl_sv_utf8_upgrade_flags
 #define sv_pvn_force_flags     Perl_sv_pvn_force_flags
 #define sv_2pv_flags           Perl_sv_2pv_flags
+#define my_atof2               Perl_my_atof2
 #define ck_anoncode            Perl_ck_anoncode
 #define ck_bitop               Perl_ck_bitop
 #define ck_concat              Perl_ck_concat
@@ -2667,6 +2668,7 @@
 #define sv_utf8_upgrade_flags(a,b)     Perl_sv_utf8_upgrade_flags(aTHX_ a,b)
 #define sv_pvn_force_flags(a,b,c)      Perl_sv_pvn_force_flags(aTHX_ a,b,c)
 #define sv_2pv_flags(a,b,c)    Perl_sv_2pv_flags(aTHX_ a,b,c)
+#define my_atof2(a,b)          Perl_my_atof2(aTHX_ a,b)
 #define ck_anoncode(a)         Perl_ck_anoncode(aTHX_ a)
 #define ck_bitop(a)            Perl_ck_bitop(aTHX_ a)
 #define ck_concat(a)           Perl_ck_concat(aTHX_ a)
@@ -5186,6 +5188,8 @@
 #define sv_pvn_force_flags     Perl_sv_pvn_force_flags
 #define Perl_sv_2pv_flags      CPerlObj::Perl_sv_2pv_flags
 #define sv_2pv_flags           Perl_sv_2pv_flags
+#define Perl_my_atof2          CPerlObj::Perl_my_atof2
+#define my_atof2               Perl_my_atof2
 #define Perl_ck_anoncode       CPerlObj::Perl_ck_anoncode
 #define ck_anoncode            Perl_ck_anoncode
 #define Perl_ck_bitop          CPerlObj::Perl_ck_bitop

diff --git a/embed.pl b/embed.pl
index 139270b..7c251bb 100755 (executable)
--- a/embed.pl
+++ b/embed.pl
@@ -2594,3 +2594,4 @@ Apd       |void   |sv_catsv_flags |SV* dsv|SV* ssv|I32 flags
 Apd    |STRLEN |sv_utf8_upgrade_flags|SV *sv|I32 flags
 Apd    |char*  |sv_pvn_force_flags|SV* sv|STRLEN* lp|I32 flags
 Ap     |char*  |sv_2pv_flags   |SV* sv|STRLEN* lp|I32 flags
+Ap     |char*  |my_atof2       |const char *s|NV* value

diff --git a/global.sym b/global.sym
index 544e1cf..b8bfb2c 100644 (file)
--- a/global.sym
+++ b/global.sym
@@ -579,3 +579,4 @@ Perl_sv_catsv_flags
 Perl_sv_utf8_upgrade_flags
 Perl_sv_pvn_force_flags
 Perl_sv_2pv_flags
+Perl_my_atof2

diff --git a/objXSUB.h b/objXSUB.h
index a3cb92c..d3ca527 100644 (file)
--- a/objXSUB.h
+++ b/objXSUB.h
@@ -2414,6 +2414,10 @@
 #define Perl_sv_2pv_flags      pPerl->Perl_sv_2pv_flags
 #undef  sv_2pv_flags
 #define sv_2pv_flags           Perl_sv_2pv_flags
+#undef  Perl_my_atof2
+#define Perl_my_atof2          pPerl->Perl_my_atof2
+#undef  my_atof2
+#define my_atof2               Perl_my_atof2
 
 #endif  /* PERL_CORE && PERL_OBJECT */
 #endif /* __objXSUB_h__ */

diff --git a/perl.h b/perl.h
index 88d32a4..4561467 100644 (file)
--- a/perl.h
+++ b/perl.h
@@ -1311,24 +1311,8 @@ typedef NVTYPE NV;
 #   endif
 #endif
 
-#if !defined(Perl_atof) && defined(USE_LONG_DOUBLE) && defined(HAS_LONG_DOUBLE)
-#   if !defined(Perl_atof) && defined(HAS_STRTOLD)
-#       define Perl_atof(s) (NV)strtold(s, (char**)NULL)
-#   endif
-#   if !defined(Perl_atof) && defined(HAS_ATOLF)
-#       define Perl_atof (NV)atolf
-#   endif
-#   if !defined(Perl_atof) && defined(PERL_SCNfldbl)
-#       define Perl_atof PERL_SCNfldbl
-#       define Perl_atof2(s,f) sscanf((s), "%"PERL_SCNfldbl, &(f))
-#   endif
-#endif
-#if !defined(Perl_atof)
-#   define Perl_atof atof /* we assume atof being available anywhere */
-#endif
-#if !defined(Perl_atof2)
-#   define Perl_atof2(s,f) ((f) = (NV)Perl_atof(s))
-#endif
+#define Perl_atof(s) Perl_my_atof(s)
+#define Perl_atof2(s, np) Perl_my_atof2(s, np)
 
 /* Previously these definitions used hardcoded figures.
  * It is hoped these formula are more portable, although

diff --git a/perlapi.c b/perlapi.c
index b8ec2c5..a04ab22 100644 (file)
--- a/perlapi.c
+++ b/perlapi.c
@@ -4289,6 +4289,13 @@ Perl_sv_2pv_flags(pTHXo_ SV* sv, STRLEN* lp, I32 flags)
     return ((CPerlObj*)pPerl)->Perl_sv_2pv_flags(sv, lp, flags);
 }
 
+#undef  Perl_my_atof2
+char*
+Perl_my_atof2(pTHXo_ const char *s, NV* value)
+{
+    return ((CPerlObj*)pPerl)->Perl_my_atof2(s, value);
+}
+
 #undef Perl_fprintf_nocontext
 int
 Perl_fprintf_nocontext(PerlIO *stream, const char *format, ...)

diff --git a/proto.h b/proto.h
index 5104261..9a5cdfb 100644 (file)
--- a/proto.h
+++ b/proto.h
@@ -1314,3 +1314,4 @@ PERL_CALLCONV void        Perl_sv_catsv_flags(pTHX_ SV* dsv, SV* ssv, I32 flags);
 PERL_CALLCONV STRLEN   Perl_sv_utf8_upgrade_flags(pTHX_ SV *sv, I32 flags);
 PERL_CALLCONV char*    Perl_sv_pvn_force_flags(pTHX_ SV* sv, STRLEN* lp, I32 flags);
 PERL_CALLCONV char*    Perl_sv_2pv_flags(pTHX_ SV* sv, STRLEN* lp, I32 flags);
+PERL_CALLCONV char*    Perl_my_atof2(pTHX_ const char *s, NV* value);

diff --git a/util.c b/util.c
index 6a01a46..9b6795b 100644 (file)
--- a/util.c
+++ b/util.c
@@ -4018,21 +4018,88 @@ Perl_my_atof(pTHX_ const char* s)
     if ((PL_hints & HINT_LOCALE) && PL_numeric_local) {
        NV y;
 
-       Perl_atof2(s, x);
+       Perl_atof2(s, &x);
        SET_NUMERIC_STANDARD();
-       Perl_atof2(s, y);
+       Perl_atof2(s, &y);
        SET_NUMERIC_LOCAL();
        if ((y < 0.0 && y < x) || (y > 0.0 && y > x))
            return y;
     }
     else
-       Perl_atof2(s, x);
+       Perl_atof2(s, &x);
 #else
-    Perl_atof2(s, x);
+    Perl_atof2(s, &x);
 #endif
     return x;
 }
 
+char*
+Perl_my_atof2(pTHX_ const char* orig, NV* value)
+{
+    NV result = 0.0;
+    bool negative = 0;
+    char* s = (char*)orig;
+    char* point = "."; /* locale-dependent decimal point equivalent */
+    STRLEN pointlen = 1;
+    bool seendigit = 0;
+
+    if (PL_numeric_radix_sv)
+       point = SvPV(PL_numeric_radix_sv, pointlen);
+
+    switch (*s) {
+       case '-':
+           negative = 1;
+           /* fall through */
+       case '+':
+           ++s;
+    }
+    while (isDIGIT(*s)) {
+       result = result * 10 + (*s++ - '0');
+       seendigit = 1;
+    }
+    if (memEQ(s, point, pointlen)) {
+       NV decimal = 0.1;
+
+       s += pointlen;
+       while (isDIGIT(*s)) {
+           result += (*s++ - '0') * decimal;
+           decimal *= 0.1;
+           seendigit = 1;
+       }
+    }
+    if (seendigit && (*s == 'e' || *s == 'E')) {
+       I32 exponent = 0;
+       I32 expnegative = 0;
+       I32 bit;
+       NV power;
+
+       ++s;
+       switch (*s) {
+           case '-':
+               expnegative = 1;
+               /* fall through */
+           case '+':
+               ++s;
+       }
+       while (isDIGIT(*s))
+           exponent = exponent * 10 + (*s++ - '0');
+
+       /* now apply the exponent */
+       power = (expnegative) ? 0.1 : 10.0;
+       for (bit = 1; exponent; bit <<= 1) {
+           if (exponent & bit) {
+               exponent ^= bit;
+               result *= power;
+           }
+           power *= power;
+       }
+    }
+    if (negative)
+       result = -result;
+    *value = result;
+    return s;
+}
+
 void
 Perl_report_evil_fh(pTHX_ GV *gv, IO *io, I32 op)
 {