view release on metacpan or  search on metacpan

XS.xs  view on Meta::CPAN

#define PERL_NO_GET_CONTEXT
#include "EXTERN.h"
#include "perl.h"
#include "XSUB.h"

#include "ppport.h"

#ifndef NOT_REACHED
#  define NOT_REACHED assert(0)
#endif

#define iParent(i)      (((i)-1) / 2)
#define iLeftChild(i)   ((2*(i)) + 1)
#define iRightChild(i)  ((2*(i)) + 2)

#define HAVE_PERL_SV_NUMCMP \
    (PERL_REVISION > 5 || (PERL_REVISION == 5 && (PERL_VERSION > 43 || (PERL_VERSION == 43 && PERL_SUBVERSION >= 8))))

#define OUT_OF_ORDER(a,child,parent,is_min)                                    \
    ( ( (is_min & 2)                                                           \
        ? my_sv_string_gt(aTHX_ (a)[(child)], (a)[(parent)])                   \
        : my_sv_num_gt(aTHX_ (a)[(child)], (a)[(parent)]))                     \
      ? !(is_min & 1) : (is_min & 1) )

#define FORCE_SCALAR(fakeop)                    \
STMT_START {                                    \
        SAVEOP();                               \
        Copy(PL_op, &fakeop, 1, OP);            \
        fakeop.op_flags = OPf_WANT_SCALAR;      \
        PL_op = &fakeop;                        \
} STMT_END


#ifdef Perl_do_ncmp
#define my_Perl_do_ncmp Perl_do_ncmp
#else
/* compare left and right SVs. Returns:
 * -1: <
 *  0: ==
 *  1: >
 *  2: left or right was a NaN
 */
I32
my_Perl_do_ncmp(pTHX_ SV* const left, SV * const right)
{
    PERL_ARGS_ASSERT_DO_NCMP;
    /* Fortunately it seems NaN isn't IOK */
    if (SvIV_please_nomg(right) && SvIV_please_nomg(left)) {
            if (!SvIsUV(left)) {
                const IV leftiv = SvIVX(left);
                if (!SvIsUV(right)) {
                    /* ## IV <=> IV ## */
                    const IV rightiv = SvIVX(right);
                    return (leftiv > rightiv) - (leftiv < rightiv);
                }
                /* ## IV <=> UV ## */
                if (leftiv < 0)
                    /* As (b) is a UV, it's >=0, so it must be < */
                    return -1;
                {
                    const UV rightuv = SvUVX(right);
                    return ((UV)leftiv > rightuv) - ((UV)leftiv < rightuv);
                }
            }

            if (SvIsUV(right)) {
                /* ## UV <=> UV ## */
                const UV leftuv = SvUVX(left);
                const UV rightuv = SvUVX(right);
                return (leftuv > rightuv) - (leftuv < rightuv);
            }
            /* ## UV <=> IV ## */
            {
                const IV rightiv = SvIVX(right);
                if (rightiv < 0)
                    /* As (a) is a UV, it's >=0, so it cannot be < */
                    return 1;
                {
                    const UV leftuv = SvUVX(left);
                    return (leftuv > (UV)rightiv) - (leftuv < (UV)rightiv);
                }
            }
            NOT_REACHED; /* NOTREACHED */
    }
    {
      NV const lnv = SvNV_nomg(left);
      NV const rnv = SvNV_nomg(right);

#if defined(NAN_COMPARE_BROKEN) && defined(Perl_isnan)
      if (Perl_isnan(lnv) || Perl_isnan(rnv)) {
          return 2;
       }
      return (lnv > rnv) - (lnv < rnv);
#else
      if (lnv < rnv)
        return -1;
      if (lnv > rnv)
        return 1;
      if (lnv == rnv)
        return 0;
      return 2;
#endif
    }
}
#endif

static bool