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

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

p4raw-id: //depot/perl@10379

8 files changed, 91 insertions, 22 deletions

diff --git a/embed.h b/embed.h
index 1a2f0e0d71..dd0097c438 100644
--- 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 139270b47b..7c251bb617 100755
--- 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 544e1cfc25..b8bfb2c1ad 100644
--- 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 a3cb92cae2..d3ca5272b7 100644
--- 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 88d32a4852..45614676f7 100644
--- 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 b8ec2c5c68..a04ab223cf 100644
--- 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 5104261810..9a5cdfb961 100644
--- 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 6a01a4665a..9b6795b690 100644
--- 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)
 {