#define SORTf_DESC 1
#define SORTf_STABLE 2
#define SORTf_QSORT 4
+#define SORTf_UNSTABLE 8
/*
* The mergesort implementation is by Peter M. Mcilroy <pmcilroy@lucent.com>.
=for apidoc sortsv
-Sort an array. Here is an example:
-
- sortsv(AvARRAY(av), av_top_index(av)+1, Perl_sv_cmp_locale);
+In-place sort an array of SV pointers with the given comparison routine.
Currently this always uses mergesort. See C<L</sortsv_flags>> for a more
flexible routine.
/*
=for apidoc sortsv_flags
-Sort an array, with various options.
+In-place sort an array of SV pointers with the given comparison routine,
+with various SORTf_* flag options.
=cut
*/
AV* av = NULL;
GV *gv;
CV *cv = NULL;
- I32 gimme = GIMME_V;
+ U8 gimme = GIMME_V;
OP* const nextop = PL_op->op_next;
I32 overloading = 0;
bool hasargs = FALSE;
bool copytmps;
I32 is_xsub = 0;
- I32 sorting_av = 0;
const U8 priv = PL_op->op_private;
const U8 flags = PL_op->op_flags;
U32 sort_flags = 0;
sort_flags |= SORTf_QSORT;
if ((priv & OPpSORT_STABLE) != 0)
sort_flags |= SORTf_STABLE;
+ if ((priv & OPpSORT_UNSTABLE) != 0)
+ sort_flags |= SORTf_UNSTABLE;
if (gimme != G_ARRAY) {
SP = MARK;
else {
SV *tmpstr = sv_newmortal();
gv_efullname3(tmpstr, gv, NULL);
- DIE(aTHX_ "Undefined sort subroutine \"%"SVf"\" called",
+ DIE(aTHX_ "Undefined sort subroutine \"%" SVf "\" called",
SVfARG(tmpstr));
}
}
PL_sortcop = NULL;
}
- /* optimiser converts "@a = sort @a" to "sort \@a";
- * in case of tied @a, pessimise: push (@a) onto stack, then assign
- * result back to @a at the end of this function */
+ /* optimiser converts "@a = sort @a" to "sort \@a". In this case,
+ * push (@a) onto stack, then assign result back to @a at the end of
+ * this function */
if (priv & OPpSORT_INPLACE) {
assert( MARK+1 == SP && *SP && SvTYPE(*SP) == SVt_PVAV);
(void)POPMARK; /* remove mark associated with ex-OP_AASSIGN */
av = MUTABLE_AV((*SP));
+ if (SvREADONLY(av))
+ Perl_croak_no_modify();
max = AvFILL(av) + 1;
+ MEXTEND(SP, max);
if (SvMAGICAL(av)) {
- MEXTEND(SP, max);
for (i=0; i < max; i++) {
SV **svp = av_fetch(av, i, FALSE);
*SP++ = (svp) ? *svp : NULL;
}
- SP--;
- p1 = p2 = SP - (max-1);
}
- else {
- if (SvREADONLY(av))
- Perl_croak_no_modify();
- else
- {
- SvREADONLY_on(av);
- save_pushptr((void *)av, SAVEt_READONLY_OFF);
- }
- p1 = p2 = AvARRAY(av);
- sorting_av = 1;
+ else {
+ SV **svp = AvARRAY(av);
+ assert(svp || max == 0);
+ for (i = 0; i < max; i++)
+ *SP++ = *svp++;
}
+ SP--;
+ p1 = p2 = SP - (max-1);
}
else {
p2 = MARK+1;
/* shuffle stack down, removing optional initial cv (p1!=p2), plus
* any nulls; also stringify or converting to integer or number as
* required any args */
- copytmps = !sorting_av && PL_sortcop;
+ copytmps = cBOOL(PL_sortcop);
for (i=max; i > 0 ; i--) {
if ((*p1 = *p2++)) { /* Weed out nulls. */
if (copytmps && SvPADTMP(*p1)) {
else
max--;
}
- if (sorting_av)
- AvFILLp(av) = max-1;
-
if (max > 1) {
SV **start;
if (PL_sortcop) {
PERL_CONTEXT *cx;
- SV** newsp;
const bool oldcatch = CATCH_GET;
+ I32 old_savestack_ix = PL_savestack_ix;
- SAVETMPS;
SAVEOP();
CATCH_SET(TRUE);
}
gimme = G_SCALAR;
- PUSHBLOCK(cx, CXt_NULL, PL_stack_base);
+ cx = cx_pushblock(CXt_NULL, gimme, PL_stack_base, old_savestack_ix);
if (!(flags & OPf_SPECIAL)) {
- cx->cx_type = CXt_SUB;
- PUSHSUB(cx);
+ cx->cx_type = CXt_SUB|CXp_MULTICALL;
+ cx_pushsub(cx, cv, NULL, hasargs);
if (!is_xsub) {
PADLIST * const padlist = CvPADLIST(cv);
- if (++CvDEPTH(cv) >= 2) {
- PERL_STACK_OVERFLOW_CHECK();
+ if (++CvDEPTH(cv) >= 2)
pad_push(padlist, CvDEPTH(cv));
- }
PAD_SET_CUR_NOSAVE(padlist, CvDEPTH(cv));
if (hasargs) {
cx->blk_sub.savearray = GvAV(PL_defgv);
GvAV(PL_defgv) = MUTABLE_AV(SvREFCNT_inc_simple(av));
- CX_CURPAD_SAVE(cx->blk_sub);
- cx->blk_sub.argarray = av;
}
}
}
- cx->cx_type |= CXp_MULTICALL;
-
+
start = p1 - max;
sortsvp(aTHX_ start, max,
(is_xsub ? S_sortcv_xsub : hasargs ? S_sortcv_stacked : S_sortcv),
sort_flags);
+ /* Reset cx, in case the context stack has been reallocated. */
+ cx = CX_CUR();
+
+ PL_stack_sp = PL_stack_base + cx->blk_oldsp;
+
+ CX_LEAVE_SCOPE(cx);
if (!(flags & OPf_SPECIAL)) {
- SV *sv;
- /* Reset cx, in case the context stack has been
- reallocated. */
- cx = &cxstack[cxstack_ix];
- POPSUB(cx, sv);
- LEAVESUB(sv);
+ assert(CxTYPE(cx) == CXt_SUB);
+ cx_popsub(cx);
}
- POPBLOCK(cx,PL_curpm);
- PL_stack_sp = newsp;
+ else
+ assert(CxTYPE(cx) == CXt_NULL);
+ /* there isn't a POPNULL ! */
+
+ cx_popblock(cx);
+ CX_POP(cx);
POPSTACK;
CATCH_SET(oldcatch);
}
else {
MEXTEND(SP, 20); /* Can't afford stack realloc on signal. */
- start = sorting_av ? AvARRAY(av) : ORIGMARK+1;
+ start = ORIGMARK+1;
sortsvp(aTHX_ start, max,
(priv & OPpSORT_NUMERIC)
? ( ( ( priv & OPpSORT_INTEGER) || all_SIVs)
}
}
}
- if (sorting_av)
- SvREADONLY_off(av);
- else if (av && !sorting_av) {
- /* simulate pp_aassign of tied AV */
- SV** const base = MARK+1;
- for (i=0; i < max; i++) {
- base[i] = newSVsv(base[i]);
- }
- av_clear(av);
- av_extend(av, max);
- for (i=0; i < max; i++) {
- SV * const sv = base[i];
- SV ** const didstore = av_store(av, i, sv);
- if (SvSMAGICAL(sv))
- mg_set(sv);
- if (!didstore)
- sv_2mortal(sv);
- }
+
+ if (av) {
+ /* copy back result to the array */
+ SV** const base = MARK+1;
+ if (SvMAGICAL(av)) {
+ for (i = 0; i < max; i++)
+ base[i] = newSVsv(base[i]);
+ av_clear(av);
+ av_extend(av, max);
+ for (i=0; i < max; i++) {
+ SV * const sv = base[i];
+ SV ** const didstore = av_store(av, i, sv);
+ if (SvSMAGICAL(sv))
+ mg_set(sv);
+ if (!didstore)
+ sv_2mortal(sv);
+ }
+ }
+ else {
+ /* the elements of av are likely to be the same as the
+ * (non-refcounted) elements on the stack, just in a different
+ * order. However, its possible that someone's messed with av
+ * in the meantime. So bump and unbump the relevant refcounts
+ * first.
+ */
+ for (i = 0; i < max; i++) {
+ SV *sv = base[i];
+ assert(sv);
+ if (SvREFCNT(sv) > 1)
+ base[i] = newSVsv(sv);
+ else
+ SvREFCNT_inc_simple_void_NN(sv);
+
+ if (SvWEAKREF(sv))
+ sv_rvunweaken(sv);
+ }
+ av_clear(av);
+ if (max > 0) {
+ av_extend(av, max);
+ Copy(base, AvARRAY(av), max, SV*);
+ }
+ AvFILLp(av) = max - 1;
+ AvREIFY_off(av);
+ AvREAL_on(av);
+ }
}
LEAVE;
- PL_stack_sp = ORIGMARK + (sorting_av ? 0 : max);
+ PL_stack_sp = ORIGMARK + max;
return nextop;
}
S_sortcv(pTHX_ SV *const a, SV *const b)
{
const I32 oldsaveix = PL_savestack_ix;
- const I32 oldscopeix = PL_scopestack_ix;
I32 result;
PMOP * const pm = PL_curpm;
COP * const cop = PL_curcop;
assert(PL_stack_sp > PL_stack_base || *PL_stack_base == &PL_sv_undef);
result = SvIV(*PL_stack_sp);
- while (PL_scopestack_ix > oldscopeix) {
- LEAVE;
- }
- leave_scope(oldsaveix);
+ LEAVE_SCOPE(oldsaveix);
PL_curpm = pm;
return result;
}
S_sortcv_stacked(pTHX_ SV *const a, SV *const b)
{
const I32 oldsaveix = PL_savestack_ix;
- const I32 oldscopeix = PL_scopestack_ix;
I32 result;
AV * const av = GvAV(PL_defgv);
PMOP * const pm = PL_curpm;
AvARRAY(av) = ary;
}
if (AvMAX(av) < 1) {
- AvMAX(av) = 1;
Renew(ary,2,SV*);
+ AvMAX(av) = 1;
AvARRAY(av) = ary;
AvALLOC(av) = ary;
}
assert(PL_stack_sp > PL_stack_base || *PL_stack_base == &PL_sv_undef);
result = SvIV(*PL_stack_sp);
- while (PL_scopestack_ix > oldscopeix) {
- LEAVE;
- }
- leave_scope(oldsaveix);
+ LEAVE_SCOPE(oldsaveix);
PL_curpm = pm;
return result;
}
{
dSP;
const I32 oldsaveix = PL_savestack_ix;
- const I32 oldscopeix = PL_scopestack_ix;
CV * const cv=MUTABLE_CV(PL_sortcop);
I32 result;
PMOP * const pm = PL_curpm;
assert(PL_stack_sp > PL_stack_base || *PL_stack_base == &PL_sv_undef);
result = SvIV(*PL_stack_sp);
- while (PL_scopestack_ix > oldscopeix) {
- LEAVE;
- }
- leave_scope(oldsaveix);
+ LEAVE_SCOPE(oldsaveix);
PL_curpm = pm;
return result;
}
static I32
S_sv_ncmp(pTHX_ SV *const a, SV *const b)
{
- const NV nv1 = SvNSIV(a);
- const NV nv2 = SvNSIV(b);
+ I32 cmp = do_ncmp(a, b);
PERL_ARGS_ASSERT_SV_NCMP;
-#if defined(NAN_COMPARE_BROKEN) && defined(Perl_isnan)
- if (Perl_isnan(nv1) || Perl_isnan(nv2)) {
-#else
- if (nv1 != nv1 || nv2 != nv2) {
-#endif
+ if (cmp == 2) {
if (ckWARN(WARN_UNINITIALIZED)) report_uninit(NULL);
return 0;
}
- return nv1 < nv2 ? -1 : nv1 > nv2 ? 1 : 0;
+
+ return cmp;
}
static I32
https://perl5.git.perl.org / perl5.git / blobdiff