diff options
| -rw-r--r-- | embed.h | 4 | ||||
| -rwxr-xr-x | embed.pl | 1 | ||||
| -rw-r--r-- | global.sym | 1 | ||||
| -rw-r--r-- | objXSUB.h | 4 | ||||
| -rw-r--r-- | perl.h | 20 | ||||
| -rw-r--r-- | perlapi.c | 7 | ||||
| -rw-r--r-- | proto.h | 1 | ||||
| -rw-r--r-- | util.c | 75 |
8 files changed, 91 insertions, 22 deletions
@@ -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 @@ -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 @@ -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__ */ @@ -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 @@ -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, ...) @@ -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); @@ -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) { |