diff --git a/MANIFEST b/MANIFEST index 428b50145c..7ac191be39 100644 --- a/MANIFEST +++ b/MANIFEST @@ -5201,6 +5201,7 @@ ext/XS-APItest/t/subcall.t Test XSUB calls ext/XS-APItest/t/subsignature.t Test parse_subsignature() ext/XS-APItest/t/sv_numcmp.t Test sv_numcmp ext/XS-APItest/t/sv_numeq.t Test sv_numeq +ext/XS-APItest/t/sv_numlget.t Test sv_num[lg][et] ext/XS-APItest/t/sv_numne.t Test sv_numne ext/XS-APItest/t/sv_streq.t Test sv_streq ext/XS-APItest/t/svcat.t Test sv_catpvn diff --git a/embed.fnc b/embed.fnc index da36c953a4..6114efc208 100644 --- a/embed.fnc +++ b/embed.fnc @@ -3441,6 +3441,26 @@ Admp |bool |sv_numeq |NULLOK SV *sv1 \ Adp |bool |sv_numeq_flags |NULLOK SV *sv1 \ |NULLOK SV *sv2 \ |const U32 flags +Admp |bool |sv_numge |NULLOK SV *sv1 \ + |NULLOK SV *sv2 +Adp |bool |sv_numge_flags |NULLOK SV *sv1 \ + |NULLOK SV *sv2 \ + |const U32 flags +Admp |bool |sv_numgt |NULLOK SV *sv1 \ + |NULLOK SV *sv2 +Adp |bool |sv_numgt_flags |NULLOK SV *sv1 \ + |NULLOK SV *sv2 \ + |const U32 flags +Admp |bool |sv_numle |NULLOK SV *sv1 \ + |NULLOK SV *sv2 +Adp |bool |sv_numle_flags |NULLOK SV *sv1 \ + |NULLOK SV *sv2 \ + |const U32 flags +Admp |bool |sv_numlt |NULLOK SV *sv1 \ + |NULLOK SV *sv2 +Adp |bool |sv_numlt_flags |NULLOK SV *sv1 \ + |NULLOK SV *sv2 \ + |const U32 flags Admp |bool |sv_numne |NULLOK SV *sv1 \ |NULLOK SV *sv2 Adp |bool |sv_numne_flags |NULLOK SV *sv1 \ diff --git a/embed.h b/embed.h index cadce32659..c19720304a 100644 --- a/embed.h +++ b/embed.h @@ -934,6 +934,10 @@ # define sv_nosharing(a) Perl_sv_nosharing(aTHX_ a) # define sv_numcmp_flags(a,b,c) Perl_sv_numcmp_flags(aTHX_ a,b,c) # define sv_numeq_flags(a,b,c) Perl_sv_numeq_flags(aTHX_ a,b,c) +# define sv_numge_flags(a,b,c) Perl_sv_numge_flags(aTHX_ a,b,c) +# define sv_numgt_flags(a,b,c) Perl_sv_numgt_flags(aTHX_ a,b,c) +# define sv_numle_flags(a,b,c) Perl_sv_numle_flags(aTHX_ a,b,c) +# define sv_numlt_flags(a,b,c) Perl_sv_numlt_flags(aTHX_ a,b,c) # define sv_numne_flags(a,b,c) Perl_sv_numne_flags(aTHX_ a,b,c) # define sv_peek(a) Perl_sv_peek(aTHX_ a) # define sv_pos_b2u(a,b) Perl_sv_pos_b2u(aTHX_ a,b) @@ -2604,6 +2608,10 @@ # define Perl_sv_mortalcopy(mTHX,a) sv_mortalcopy(a) # define Perl_sv_numcmp(mTHX,a,b) sv_numcmp(a,b) # define Perl_sv_numeq(mTHX,a,b) sv_numeq(a,b) +# define Perl_sv_numge(mTHX,a,b) sv_numge(a,b) +# define Perl_sv_numgt(mTHX,a,b) sv_numgt(a,b) +# define Perl_sv_numle(mTHX,a,b) sv_numle(a,b) +# define Perl_sv_numlt(mTHX,a,b) sv_numlt(a,b) # define Perl_sv_numne(mTHX,a,b) sv_numne(a,b) # define Perl_sv_pv(mTHX,a) sv_pv(a) # define Perl_sv_pvbyte(mTHX,a) sv_pvbyte(a) @@ -2710,6 +2718,10 @@ # define Perl_sv_mortalcopy sv_mortalcopy # define Perl_sv_numcmp sv_numcmp # define Perl_sv_numeq sv_numeq +# define Perl_sv_numge sv_numge +# define Perl_sv_numgt sv_numgt +# define Perl_sv_numle sv_numle +# define Perl_sv_numlt sv_numlt # define Perl_sv_numne sv_numne # define Perl_sv_pv sv_pv # define Perl_sv_pvbyte sv_pvbyte diff --git a/ext/XS-APItest/APItest.xs b/ext/XS-APItest/APItest.xs index 4dbfa85965..b48b7b4118 100644 --- a/ext/XS-APItest/APItest.xs +++ b/ext/XS-APItest/APItest.xs @@ -5067,6 +5067,30 @@ sv_numcmp(nullable_SV sv1, nullable_SV sv2) I32 sv_numcmp_flags(nullable_SV sv1, nullable_SV sv2, U32 flags) +bool +sv_numle(nullable_SV sv1, nullable_SV sv2) + +bool +sv_numle_flags(nullable_SV sv1, nullable_SV sv2, U32 flags) + +bool +sv_numlt(nullable_SV sv1, nullable_SV sv2) + +bool +sv_numlt_flags(nullable_SV sv1, nullable_SV sv2, U32 flags) + +bool +sv_numge(nullable_SV sv1, nullable_SV sv2) + +bool +sv_numge_flags(nullable_SV sv1, nullable_SV sv2, U32 flags) + +bool +sv_numgt(nullable_SV sv1, nullable_SV sv2) + +bool +sv_numgt_flags(nullable_SV sv1, nullable_SV sv2, U32 flags) + bool sv_streq(SV *sv1, SV *sv2) CODE: diff --git a/ext/XS-APItest/t/sv_numlget.t b/ext/XS-APItest/t/sv_numlget.t new file mode 100644 index 0000000000..e3f00a78b6 --- /dev/null +++ b/ext/XS-APItest/t/sv_numlget.t @@ -0,0 +1,49 @@ +#!perl +# tests the numeric sv_num[lg][te]() APIs + +use Test::More; +use XS::APItest; +use strict; + +# +0 overloading with large numbers and using fallback +package MyBigNum { + use overload + "0+" => sub { $_[0][0] }, + fallback => 1; +} + +my $nan = eval { + no warnings "experimental"; + builtin::nan(); +}; + +my @values = + ( + [ ~0 ], + [ ~0-1 ], + [ -int(~0/2) ], + [ 1.001 ], + [ 1.002 ], + [ bless([ ~0 ], "MyBigNum"), "bignum ~0" ], + [ bless([ ~0 ], "MyBigNum"), "bignum ~0 #2" ], + [ bless([ ~0-1 ], "MyBigNum"), "bignum ~0-1" ], + [ undef(), "undef" ], + defined $nan ? ( [ $nan, "NaN" ] ) : (), + ); + +for my $x (@values) { + for my $y (@values) { + for my $func ( [ "le", sub { $_[0] <= $_[1] }, \&sv_numle ], + [ "lt", sub { $_[0] < $_[1] }, \&sv_numlt ], + [ "ge", sub { $_[0] >= $_[1] }, \&sv_numge ], + [ "gt", sub { $_[0] > $_[1] }, \&sv_numgt ]) { + my ($op, $native, $api) = @$func; + my $lname = $x->[1] // $x->[0]; + my $rname = $y->[1] // $y->[0]; + is($api->($x->[0], $x->[1]), $native->($x->[0], $x->[1]), + "$lname $op $rname"); + } + } +} + +done_testing; diff --git a/proto.h b/proto.h index 1d597df60d..80ef8aa164 100644 --- a/proto.h +++ b/proto.h @@ -4801,6 +4801,34 @@ PERL_CALLCONV bool Perl_sv_numeq_flags(pTHX_ SV *sv1, SV *sv2, const U32 flags); #define PERL_ARGS_ASSERT_SV_NUMEQ_FLAGS +/* PERL_CALLCONV bool +Perl_sv_numge(pTHX_ SV *sv1, SV *sv2); */ + +PERL_CALLCONV bool +Perl_sv_numge_flags(pTHX_ SV *sv1, SV *sv2, const U32 flags); +#define PERL_ARGS_ASSERT_SV_NUMGE_FLAGS + +/* PERL_CALLCONV bool +Perl_sv_numgt(pTHX_ SV *sv1, SV *sv2); */ + +PERL_CALLCONV bool +Perl_sv_numgt_flags(pTHX_ SV *sv1, SV *sv2, const U32 flags); +#define PERL_ARGS_ASSERT_SV_NUMGT_FLAGS + +/* PERL_CALLCONV bool +Perl_sv_numle(pTHX_ SV *sv1, SV *sv2); */ + +PERL_CALLCONV bool +Perl_sv_numle_flags(pTHX_ SV *sv1, SV *sv2, const U32 flags); +#define PERL_ARGS_ASSERT_SV_NUMLE_FLAGS + +/* PERL_CALLCONV bool +Perl_sv_numlt(pTHX_ SV *sv1, SV *sv2); */ + +PERL_CALLCONV bool +Perl_sv_numlt_flags(pTHX_ SV *sv1, SV *sv2, const U32 flags); +#define PERL_ARGS_ASSERT_SV_NUMLT_FLAGS + /* PERL_CALLCONV bool Perl_sv_numne(pTHX_ SV *sv1, SV *sv2); */ diff --git a/sv.c b/sv.c index d19f52dc6d..3031b453dc 100644 --- a/sv.c +++ b/sv.c @@ -8736,6 +8736,14 @@ S_sv_numcmp_common(pTHX_ SV **sv1, SV **sv2, const U32 flags, =for apidoc_item sv_numeq_flags =for apidoc_item sv_numne =for apidoc_item sv_numne_flags +=for apidoc_item sv_numge +=for apidoc_item sv_numge_flags +=for apidoc_item sv_numgt +=for apidoc_item sv_numgt_flags +=for apidoc_item sv_numle +=for apidoc_item sv_numle_flags +=for apidoc_item sv_numlt +=for apidoc_item sv_numlt_flags These return a boolean that is the result of the corresponding numeric comparison: @@ -8754,17 +8762,42 @@ Numeric equality, the same as S>. Numeric inequality, the same as S>. +=item C + +=item C + +Numeric less than or equal, the same as S= $sv2>>. + +=item C + +=item C + +Numeric less than, the same as S $sv2>>. + +=item C + +=item C + +Numeric greater than or equal, the same as S= $sv2>>. + +=item C + +=item C + +Numeric greater than, the same as S $sv2>>. + =back -Beware that in the presence of overloading C<==> may not be a strict -inverse of C. +Beware that in the presence of overloading the comparisons might not +have their normal properties, eg. C< sv_numeq(sv1, sv2) > might be +different to C< !sv_numne(sv1, sv2) >. The non-C<_flags> suffix versions of these functions always perform get magic and handle the appropriate type of overloading. See L for details. These each return a boolean indicating if the numbers in the two SV -arguments are equal or not equal, coercing them to numbers if +arguments satisfy the given relationship, coercing them to numbers if necessary, basically behaving like the Perl code. A NULL SV is treated as C. @@ -8807,7 +8840,6 @@ Perl_sv_numne_flags(pTHX_ SV *sv1, SV *sv2, const U32 flags) { PERL_ARGS_ASSERT_SV_NUMNE_FLAGS; - SV *result; if (UNLIKELY(sv_numcmp_common(&sv1, &sv2, flags, ne_amg, &result))) return SvTRUE(result); @@ -8815,6 +8847,58 @@ Perl_sv_numne_flags(pTHX_ SV *sv1, SV *sv2, const U32 flags) return do_ncmp(sv1, sv2) != 0; } +bool +Perl_sv_numle_flags(pTHX_ SV *sv1, SV *sv2, const U32 flags) +{ + PERL_ARGS_ASSERT_SV_NUMLE_FLAGS; + + SV *result; + if (UNLIKELY(sv_numcmp_common(&sv1, &sv2, flags, le_amg, &result))) + return SvTRUE(result); + + return do_ncmp(sv1, sv2) <= 0; +} + +bool +Perl_sv_numlt_flags(pTHX_ SV *sv1, SV *sv2, const U32 flags) +{ + PERL_ARGS_ASSERT_SV_NUMLT_FLAGS; + + SV *result; + if (UNLIKELY(sv_numcmp_common(&sv1, &sv2, flags, lt_amg, &result))) + return SvTRUE(result); + + return do_ncmp(sv1, sv2) < 0; +} + +bool +Perl_sv_numge_flags(pTHX_ SV *sv1, SV *sv2, const U32 flags) +{ + PERL_ARGS_ASSERT_SV_NUMGE_FLAGS; + + SV *result; + if (UNLIKELY(sv_numcmp_common(&sv1, &sv2, flags, ge_amg, &result))) + return SvTRUE(result); + + I32 cmp = do_ncmp(sv1, sv2); + + return cmp != 2 && cmp >= 0; +} + +bool +Perl_sv_numgt_flags(pTHX_ SV *sv1, SV *sv2, const U32 flags) +{ + PERL_ARGS_ASSERT_SV_NUMGT_FLAGS; + + SV *result; + if (UNLIKELY(sv_numcmp_common(&sv1, &sv2, flags, gt_amg, &result))) + return SvTRUE(result); + + I32 cmp = do_ncmp(sv1, sv2); + + return cmp != 2 && cmp > 0; +} + /* =for apidoc sv_numcmp =for apidoc_item sv_numcmp_flags diff --git a/sv.h b/sv.h index a91c05a61c..65592bd679 100644 --- a/sv.h +++ b/sv.h @@ -2323,6 +2323,10 @@ Usually accessed via the C macro. #define sv_cmp_locale(sv1, sv2) sv_cmp_locale_flags(sv1, sv2, SV_GMAGIC) #define sv_numeq(sv1, sv2) sv_numeq_flags(sv1, sv2, SV_GMAGIC) #define sv_numne(sv1, sv2) sv_numne_flags(sv1, sv2, SV_GMAGIC) +#define sv_numle(sv1, sv2) sv_numle_flags(sv1, sv2, SV_GMAGIC) +#define sv_numlt(sv1, sv2) sv_numlt_flags(sv1, sv2, SV_GMAGIC) +#define sv_numge(sv1, sv2) sv_numge_flags(sv1, sv2, SV_GMAGIC) +#define sv_numgt(sv1, sv2) sv_numgt_flags(sv1, sv2, SV_GMAGIC) #define sv_numcmp(sv1, sv2) sv_numcmp_flags(sv1, sv2, SV_GMAGIC) #define sv_streq(sv1, sv2) sv_streq_flags(sv1, sv2, SV_GMAGIC) #define sv_collxfrm(sv, nxp) sv_collxfrm_flags(sv, nxp, SV_GMAGIC)