/* pp_sort.c
*
* Copyright (C) 1991, 1992, 1993, 1994, 1995, 1996, 1997, 1998, 1999,
- * 2000, 2001, 2002, 2003, by Larry Wall and others
+ * 2000, 2001, 2002, 2003, 2004, by Larry Wall and others
*
* You may distribute under the terms of either the GNU General Public
* License or the Artistic License, as specified in the README file.
* rear!' the slave-driver shouted. 'Three files up. And stay there...
*/
+/* This file contains pp ("push/pop") functions that
+ * execute the opcodes that make up a perl program. A typical pp function
+ * expects to find its arguments on the stack, and usually pushes its
+ * results onto the stack, hence the 'pp' terminology. Each OP structure
+ * contains a pointer to the relevant pp_foo() function.
+ *
+ * This particular file just contains pp_sort(), which is complex
+ * enough to merit its own file! See the other pp*.c files for the rest of
+ * the pp_ functions.
+ */
+
#include "EXTERN.h"
#define PERL_IN_PP_SORT_C
#include "perl.h"
IV runs; /* how many runs must be combined into 1 */
} off_runs; /* pseudo-stack element */
+
+static I32
+cmp_desc(pTHX_ gptr a, gptr b)
+{
+ return -PL_sort_RealCmp(aTHX_ a, b);
+}
+
STATIC void
-S_mergesortsv(pTHX_ gptr *base, size_t nmemb, SVCOMPARE_t cmp)
+S_mergesortsv(pTHX_ gptr *base, size_t nmemb, SVCOMPARE_t cmp, U32 flags)
{
IV i, run, runs, offset;
I32 sense, level;
gptr small[SMALLSORT];
gptr *which[3];
off_runs stack[60], *stackp;
+ SVCOMPARE_t savecmp;
if (nmemb <= 1) return; /* sorted trivially */
+
+ if (flags) {
+ savecmp = PL_sort_RealCmp; /* Save current comparison routine, if any */
+ PL_sort_RealCmp = cmp; /* Put comparison routine where cmp_desc can find it */
+ cmp = cmp_desc;
+ }
+
if (nmemb <= SMALLSORT) aux = small; /* use stack for aux array */
else { New(799,aux,nmemb,gptr); } /* allocate auxilliary array */
level = 0;
}
done:
if (aux != small) Safefree(aux); /* free iff allocated */
+ if (flags) {
+ PL_sort_RealCmp = savecmp; /* Restore current comparison routine, if any */
+ }
return;
}
return sense;
}
+static I32
+cmpindir_desc(pTHX_ gptr a, gptr b)
+{
+ I32 sense;
+ gptr *ap = (gptr *)a;
+ gptr *bp = (gptr *)b;
+
+ /* Reverse the default */
+ if ((sense = PL_sort_RealCmp(aTHX_ *ap, *bp)))
+ return -sense;
+ /* But don't reverse the stability test. */
+ return (ap > bp) ? 1 : ((ap < bp) ? -1 : 0);
+
+}
+
STATIC void
-S_qsortsv(pTHX_ gptr *list1, size_t nmemb, SVCOMPARE_t cmp)
+S_qsortsv(pTHX_ gptr *list1, size_t nmemb, SVCOMPARE_t cmp, U32 flags)
{
SV *hintsv;
PL_sort_RealCmp = cmp; /* Put comparison routine where cmpindir can find it */
/* sort, with indirection */
- S_qsortsvu(aTHX_ (gptr *)indir, nmemb, cmpindir);
+ S_qsortsvu(aTHX_ (gptr *)indir, nmemb,
+ flags ? cmpindir_desc : cmpindir);
pp = indir;
q = list1;
if (indir != small) { Safefree(indir); }
/* restore prevailing comparison routine */
PL_sort_RealCmp = savecmp;
+ } else if (flags) {
+ SVCOMPARE_t savecmp = PL_sort_RealCmp; /* Save current comparison routine, if any */
+ PL_sort_RealCmp = cmp; /* Put comparison routine where cmp_desc can find it */
+ cmp = cmp_desc;
+ S_qsortsvu(aTHX_ list1, nmemb, cmp);
+ /* restore prevailing comparison routine */
+ PL_sort_RealCmp = savecmp;
} else {
S_qsortsvu(aTHX_ list1, nmemb, cmp);
}
void
Perl_sortsv(pTHX_ SV **array, size_t nmemb, SVCOMPARE_t cmp)
{
- void (*sortsvp)(pTHX_ SV **array, size_t nmemb, SVCOMPARE_t cmp) =
- S_mergesortsv;
+ void (*sortsvp)(pTHX_ SV **array, size_t nmemb, SVCOMPARE_t cmp, U32 flags)
+ = S_mergesortsv;
+ SV *hintsv;
+ I32 hints;
+
+ /* Sun's Compiler (cc: WorkShop Compilers 4.2 30 Oct 1996 C 4.2) used
+ to miscompile this function under optimization -O. If you get test
+ errors related to picking the correct sort() function, try recompiling
+ this file without optimiziation. -- A.D. 4/2002.
+ */
+ hints = SORTHINTS(hintsv);
+ if (hints & HINT_SORT_QUICKSORT) {
+ sortsvp = S_qsortsv;
+ }
+ else {
+ /* The default as of 5.8.0 is mergesort */
+ sortsvp = S_mergesortsv;
+ }
+
+ sortsvp(aTHX_ array, nmemb, cmp, 0);
+}
+
+
+void
+S_sortsv_desc(pTHX_ SV **array, size_t nmemb, SVCOMPARE_t cmp)
+{
+ void (*sortsvp)(pTHX_ SV **array, size_t nmemb, SVCOMPARE_t cmp, U32 flags)
+ = S_mergesortsv;
SV *hintsv;
I32 hints;
sortsvp = S_mergesortsv;
}
- sortsvp(aTHX_ array, nmemb, cmp);
+ sortsvp(aTHX_ array, nmemb, cmp, 1);
}
PP(pp_sort)
bool hasargs = FALSE;
I32 is_xsub = 0;
I32 sorting_av = 0;
+ U8 private = PL_op->op_private;
+ U8 flags = PL_op->op_flags;
+ void (*sortsvp)(pTHX_ SV **array, size_t nmemb, SVCOMPARE_t cmp)
+ = Perl_sortsv;
if (gimme != G_ARRAY) {
SP = MARK;
ENTER;
SAVEVPTR(PL_sortcop);
- if (PL_op->op_flags & OPf_STACKED) {
- if (PL_op->op_flags & OPf_SPECIAL) {
+ if (flags & OPf_STACKED) {
+ if (flags & OPf_SPECIAL) {
OP *kid = cLISTOP->op_first->op_sibling; /* pass pushmark */
kid = kUNOP->op_first; /* pass rv2gv */
kid = kUNOP->op_first; /* pass leave */
/* 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 */
- if (PL_op->op_private & OPpSORT_INPLACE) {
+ if (private & OPpSORT_INPLACE) {
assert( MARK+1 == SP && *SP && SvTYPE(*SP) == SVt_PVAV);
(void)POPMARK; /* remove mark associated with ex-OP_AASSIGN */
av = (AV*)(*SP);
max = SP - MARK;
}
+ if (private & OPpSORT_DESCEND) {
+ sortsvp = S_sortsv_desc;
+ }
+
/* shuffle stack down, removing optional initial cv (p1!=p2), plus any
* nulls; also stringify any args */
for (i=max; i > 0 ; i--) {
AvFILLp(av) = max-1;
if (max > 1) {
+ SV **start;
if (PL_sortcop) {
PERL_CONTEXT *cx;
SV** newsp;
}
PUSHBLOCK(cx, CXt_NULL, PL_stack_base);
- if (!(PL_op->op_flags & OPf_SPECIAL)) {
+ if (!(flags & OPf_SPECIAL)) {
cx->cx_type = CXt_SUB;
cx->blk_gimme = G_SCALAR;
PUSHSUB(cx);
CX_CURPAD_SAVE(cx->blk_sub);
cx->blk_sub.argarray = av;
}
- sortsv(p1-max, max,
- is_xsub ? sortcv_xsub : hasargs ? sortcv_stacked : sortcv);
+
+ start = p1 - max;
+ sortsvp(aTHX_ start, max,
+ is_xsub ? sortcv_xsub : hasargs ? sortcv_stacked : sortcv);
POPBLOCK(cx,PL_curpm);
PL_stack_sp = newsp;
}
else {
MEXTEND(SP, 20); /* Can't afford stack realloc on signal. */
- sortsv(sorting_av ? AvARRAY(av) : ORIGMARK+1, max,
- (PL_op->op_private & OPpSORT_NUMERIC)
- ? ( (PL_op->op_private & OPpSORT_INTEGER)
+ start = sorting_av ? AvARRAY(av) : ORIGMARK+1;
+ sortsvp(aTHX_ start, max,
+ (private & OPpSORT_NUMERIC)
+ ? ( (private & OPpSORT_INTEGER)
? ( overloading ? amagic_i_ncmp : sv_i_ncmp)
: ( overloading ? amagic_ncmp : sv_ncmp))
: ( IN_LOCALE_RUNTIME
? amagic_cmp_locale
: sv_cmp_locale_static)
: ( overloading ? amagic_cmp : sv_cmp_static)));
- if (PL_op->op_private & OPpSORT_REVERSE) {
- SV **p = sorting_av ? AvARRAY(av) : ORIGMARK+1;
- SV **q = p+max-1;
- while (p < q) {
- SV *tmp = *p;
- *p++ = *q;
- *q-- = tmp;
- }
+ }
+ if (private & OPpSORT_REVERSE) {
+ SV **q = start+max-1;
+ while (start < q) {
+ SV *tmp = *start;
+ *start++ = *q;
+ *q-- = tmp;
}
}
}
https://perl5.git.perl.org / perl5.git / blobdiff