projects / p5sagit/p5-mst-13.2.git / commitdiff
? search:
summary | shortlog | log | commit | commitdiff | tree
raw (parent: 17d0df5)
allow XSUBs and prototyped subroutines to be used with sort() (tweaked
Gurusamy Sarathy [Thu, 2 Dec 1999 03:42:55 +0000 (03:42 +0000)]
variant of patch suggested by Peter Haworth <pmh@edison.ioppublishing.com>)

p4raw-id: //depot/perl@4614

pod/perldelta.pod patch | blob | blame | history
pod/perlfunc.pod patch | blob | blame | history
pp_ctl.c patch | blob | blame | history
t/op/sort.t patch | blob | blame | history

diff --git a/pod/perldelta.pod b/pod/perldelta.pod
index e46df77..12d2684 100644 (file)
--- a/pod/perldelta.pod
+++ b/pod/perldelta.pod
@@ -469,6 +469,16 @@ this support (if it is available).
 You can Configure -Dusemorebits to turn on both the 64-bit support
 and the long double support.
 
+=head2 Enhanced support for sort() subroutines
+
+Perl subroutines with a prototype of C<($$)> and XSUBs in general can
+now be used as sort subroutines.  In either case, the two elements to
+be compared as passed as normal parameters in @_.  See L<perlfunc/sort>.
+
+For unprototyped sort subroutines, the historical behavior of passing 
+the elements to be compared as the global variables $a and $b remains
+unchanged.
+
 =head2 Better syntax checks on parenthesized unary operators
 
 Expressions such as:
diff --git a/pod/perlfunc.pod b/pod/perlfunc.pod
index 513cf7c..7cf4d3f 100644 (file)
--- a/pod/perlfunc.pod
+++ b/pod/perlfunc.pod
@@ -3941,12 +3941,16 @@ the name of (or a reference to) the actual subroutine to use.  In place
 of a SUBNAME, you can provide a BLOCK as an anonymous, in-line sort
 subroutine.
 
-In the interests of efficiency the normal calling code for subroutines is
-bypassed, with the following effects: the subroutine may not be a
-recursive subroutine, and the two elements to be compared are passed into
-the subroutine not via C<@_> but as the package global variables $a and
-$b (see example below).  They are passed by reference, so don't
-modify $a and $b.  And don't try to declare them as lexicals either.
+If the subroutine's prototype is C<($$)>, the elements to be compared
+are passed by reference in C<@_>, as for a normal subroutine.  If not,
+the normal calling code for subroutines is bypassed in the interests of
+efficiency, and the elements to be compared are passed into the subroutine
+as the package global variables $a and $b (see example below).  Note that
+in the latter case, it is usually counter-productive to declare $a and
+$b as lexicals.
+
+In either case, the subroutine may not be recursive.  The values to be
+compared are always passed by reference, so don't modify them.
 
 You also cannot exit out of the sort block or subroutine using any of the
 loop control operators described in L<perlsyn> or with C<goto>.
@@ -4026,6 +4030,14 @@ Examples:
                            ||
                   $a->[2] cmp $b->[2]
            } map { [$_, /=(\d+)/, uc($_)] } @old;
+    
+    # using a prototype allows you to use any comparison subroutine
+    # as a sort subroutine (including other package's subroutines)
+    package other;
+    sub backwards ($$) { $_[1] cmp $_[0]; }    # $a and $b are not set here
+
+    package main;
+    @new = sort other::backwards @old;
 
 If you're using strict, you I<must not> declare $a
 and $b as lexicals.  They are package globals.  That means
diff --git a/pp_ctl.c b/pp_ctl.c
index ec7dfb8..54bd654 100644 (file)
--- a/pp_ctl.c
+++ b/pp_ctl.c
@@ -27,6 +27,8 @@
 #define DOCATCH(o) ((CATCH_GET == TRUE) ? docatch(o) : (o))
 
 static I32 sortcv(pTHXo_ SV *a, SV *b);
+static I32 sortcv_stacked(pTHXo_ SV *a, SV *b);
+static I32 sortcv_xsub(pTHXo_ SV *a, SV *b);
 static I32 sv_ncmp(pTHXo_ SV *a, SV *b);
 static I32 sv_i_ncmp(pTHXo_ SV *a, SV *b);
 static I32 amagic_ncmp(pTHXo_ SV *a, SV *b);
@@ -778,6 +780,8 @@ PP(pp_sort)
     I32 gimme = GIMME;
     OP* nextop = PL_op->op_next;
     I32 overloading = 0;
+    bool hasargs = FALSE;
+    I32 is_xsub = 0;
 
     if (gimme != G_ARRAY) {
        SP = MARK;
@@ -796,28 +800,38 @@ PP(pp_sort)
        }
        else {
            cv = sv_2cv(*++MARK, &stash, &gv, 0);
+           if (cv && SvPOK(cv)) {
+               STRLEN n_a;
+               char *proto = SvPV((SV*)cv, n_a);
+               if (proto && strEQ(proto, "$$")) {
+                   hasargs = TRUE;
+               }
+           }
            if (!(cv && CvROOT(cv))) {
-               if (gv) {
+               if (cv && CvXSUB(cv)) {
+                   is_xsub = 1;
+               }
+               else if (gv) {
                    SV *tmpstr = sv_newmortal();
                    gv_efullname3(tmpstr, gv, Nullch);
-                   if (cv && CvXSUB(cv))
-                       DIE(aTHX_ "Xsub \"%s\" called in sort", SvPVX(tmpstr));
                    DIE(aTHX_ "Undefined sort subroutine \"%s\" called",
                        SvPVX(tmpstr));
                }
-               if (cv) {
-                   if (CvXSUB(cv))
-                       DIE(aTHX_ "Xsub called in sort");
+               else {
                    DIE(aTHX_ "Undefined subroutine in sort");
                }
-               DIE(aTHX_ "Not a CODE reference in sort");
            }
-           PL_sortcop = CvSTART(cv);
-           SAVEVPTR(CvROOT(cv)->op_ppaddr);
-           CvROOT(cv)->op_ppaddr = PL_ppaddr[OP_NULL];
 
-           SAVEVPTR(PL_curpad);
-           PL_curpad = AvARRAY((AV*)AvARRAY(CvPADLIST(cv))[1]);
+           if (is_xsub)
+               PL_sortcop = (OP*)cv;
+           else {
+               PL_sortcop = CvSTART(cv);
+               SAVEVPTR(CvROOT(cv)->op_ppaddr);
+               CvROOT(cv)->op_ppaddr = PL_ppaddr[OP_NULL];
+
+               SAVEVPTR(PL_curpad);
+               PL_curpad = AvARRAY((AV*)AvARRAY(CvPADLIST(cv))[1]);
+            }
        }
     }
     else {
@@ -863,7 +877,6 @@ PP(pp_sort)
 
            PUSHBLOCK(cx, CXt_NULL, PL_stack_base);
            if (!(PL_op->op_flags & OPf_SPECIAL)) {
-               bool hasargs = FALSE;
                cx->cx_type = CXt_SUB;
                cx->blk_gimme = G_SCALAR;
                PUSHSUB(cx);
@@ -871,7 +884,19 @@ PP(pp_sort)
                    (void)SvREFCNT_inc(cv); /* in preparation for POPSUB */
            }
            PL_sortcxix = cxstack_ix;
-           qsortsv((myorigmark+1), max, sortcv);
+
+           if (hasargs && !is_xsub) {
+               /* This is mostly copied from pp_entersub */
+               AV *av = (AV*)PL_curpad[0];
+
+#ifndef USE_THREADS
+               cx->blk_sub.savearray = GvAV(PL_defgv);
+               GvAV(PL_defgv) = (AV*)SvREFCNT_inc(av);
+#endif /* USE_THREADS */
+               cx->blk_sub.argarray = av;
+           }
+           qsortsv((myorigmark+1), max,
+                   is_xsub ? sortcv_xsub : hasargs ? sortcv_stacked : sortcv);
 
            POPBLOCK(cx,PL_curpm);
            PL_stack_sp = newsp;
@@ -4148,6 +4173,74 @@ sortcv(pTHXo_ SV *a, SV *b)
     return result;
 }
 
+static I32
+sortcv_stacked(pTHXo_ SV *a, SV *b)
+{
+    dTHR;
+    I32 oldsaveix = PL_savestack_ix;
+    I32 oldscopeix = PL_scopestack_ix;
+    I32 result;
+    AV *av = GvAV(PL_defgv);
+
+    if (AvMAX(av) < 1) {
+       SV** ary = AvALLOC(av);
+       if (AvARRAY(av) != ary) {
+           AvMAX(av) += AvARRAY(av) - AvALLOC(av);
+           SvPVX(av) = (char*)ary;
+       }
+       if (AvMAX(av) < 1) {
+           AvMAX(av) = 1;
+           Renew(ary,2,SV*);
+           SvPVX(av) = (char*)ary;
+       }
+    }
+    AvFILLp(av) = 1;
+
+    AvARRAY(av)[0] = a;
+    AvARRAY(av)[1] = b;
+    PL_stack_sp = PL_stack_base;
+    PL_op = PL_sortcop;
+    CALLRUNOPS(aTHX);
+    if (PL_stack_sp != PL_stack_base + 1)
+       Perl_croak(aTHX_ "Sort subroutine didn't return single value");
+    if (!SvNIOKp(*PL_stack_sp))
+       Perl_croak(aTHX_ "Sort subroutine didn't return a numeric value");
+    result = SvIV(*PL_stack_sp);
+    while (PL_scopestack_ix > oldscopeix) {
+       LEAVE;
+    }
+    leave_scope(oldsaveix);
+    return result;
+}
+
+static I32
+sortcv_xsub(pTHXo_ SV *a, SV *b)
+{
+    dSP;
+    I32 oldsaveix = PL_savestack_ix;
+    I32 oldscopeix = PL_scopestack_ix;
+    I32 result;
+    CV *cv=(CV*)PL_sortcop;
+
+    SP = PL_stack_base;
+    PUSHMARK(SP);
+    EXTEND(SP, 2);
+    *++SP = a;
+    *++SP = b;
+    PUTBACK;
+    (void)(*CvXSUB(cv))(aTHXo_ cv);
+    if (PL_stack_sp != PL_stack_base + 1)
+       Perl_croak(aTHX_ "Sort subroutine didn't return single value");
+    if (!SvNIOKp(*PL_stack_sp))
+       Perl_croak(aTHX_ "Sort subroutine didn't return a numeric value");
+    result = SvIV(*PL_stack_sp);
+    while (PL_scopestack_ix > oldscopeix) {
+       LEAVE;
+    }
+    leave_scope(oldsaveix);
+    return result;
+}
+
 
 static I32
 sv_ncmp(pTHXo_ SV *a, SV *b)
diff --git a/t/op/sort.t b/t/op/sort.t
index 9abc410..6e3d2ca 100755 (executable)
--- a/t/op/sort.t
+++ b/t/op/sort.t
@@ -4,12 +4,13 @@ BEGIN {
     chdir 't' if -d 't';
     unshift @INC, '../lib';
 }
-print "1..38\n";
+print "1..49\n";
 
 # XXX known to leak scalars
 $ENV{PERL_DESTRUCT_LEVEL} = 0 unless $ENV{PERL_DESTRUCT_LEVEL} > 3;
 
 sub backwards { $a lt $b ? 1 : $a gt $b ? -1 : 0 }
+sub backwards_stacked($$) { my($a,$b) = @_; $a lt $b ? 1 : $a gt $b ? -1 : 0 }
 
 my $upperfirst = 'A' lt 'a';
 
@@ -40,96 +41,107 @@ $expected = $upperfirst ? 'xdogcatCainAbel' : 'CainAbelxdogcat';
 print "# 2: x = '$x', expected = '$expected'\n";
 print ($x eq $expected ? "ok 2\n" : "not ok 2\n");
 
+$x = join('', sort( backwards_stacked @harry));
+$expected = $upperfirst ? 'xdogcatCainAbel' : 'CainAbelxdogcat';
+print "# 3: x = '$x', expected = '$expected'\n";
+print ($x eq $expected ? "ok 3\n" : "not ok 3\n");
+
 $x = join('', sort @george, 'to', @harry);
 $expected = $upperfirst ?
     'AbelAxedCaincatchaseddoggonepunishedtoxyz' :
     'catchaseddoggonepunishedtoxyzAbelAxedCain' ;
-print "# 3: x = '$x', expected = '$expected'\n";
-print ($x eq $expected ?"ok 3\n":"not ok 3\n");
+print "# 4: x = '$x', expected = '$expected'\n";
+print ($x eq $expected ?"ok 4\n":"not ok 4\n");
 
 @a = ();
 @b = reverse @a;
-print ("@b" eq "" ? "ok 4\n" : "not ok 4 (@b)\n");
+print ("@b" eq "" ? "ok 5\n" : "not ok 5 (@b)\n");
 
 @a = (1);
 @b = reverse @a;
-print ("@b" eq "1" ? "ok 5\n" : "not ok 5 (@b)\n");
+print ("@b" eq "1" ? "ok 6\n" : "not ok 6 (@b)\n");
 
 @a = (1,2);
 @b = reverse @a;
-print ("@b" eq "2 1" ? "ok 6\n" : "not ok 6 (@b)\n");
+print ("@b" eq "2 1" ? "ok 7\n" : "not ok 7 (@b)\n");
 
 @a = (1,2,3);
 @b = reverse @a;
-print ("@b" eq "3 2 1" ? "ok 7\n" : "not ok 7 (@b)\n");
+print ("@b" eq "3 2 1" ? "ok 8\n" : "not ok 8 (@b)\n");
 
 @a = (1,2,3,4);
 @b = reverse @a;
-print ("@b" eq "4 3 2 1" ? "ok 8\n" : "not ok 8 (@b)\n");
+print ("@b" eq "4 3 2 1" ? "ok 9\n" : "not ok 9 (@b)\n");
 
 @a = (10,2,3,4);
 @b = sort {$a <=> $b;} @a;
-print ("@b" eq "2 3 4 10" ? "ok 9\n" : "not ok 9 (@b)\n");
+print ("@b" eq "2 3 4 10" ? "ok 10\n" : "not ok 10 (@b)\n");
 
 $sub = 'backwards';
 $x = join('', sort $sub @harry);
 $expected = $upperfirst ? 'xdogcatCainAbel' : 'CainAbelxdogcat';
-print "# 10: x = $x, expected = '$expected'\n";
-print ($x eq $expected ? "ok 10\n" : "not ok 10\n");
+print "# 11: x = $x, expected = '$expected'\n";
+print ($x eq $expected ? "ok 11\n" : "not ok 11\n");
+
+$sub = 'backwards_stacked';
+$x = join('', sort $sub @harry);
+$expected = $upperfirst ? 'xdogcatCainAbel' : 'CainAbelxdogcat';
+print "# 12: x = $x, expected = '$expected'\n";
+print ($x eq $expected ? "ok 12\n" : "not ok 12\n");
 
 # literals, combinations
 
 @b = sort (4,1,3,2);
-print ("@b" eq '1 2 3 4' ? "ok 11\n" : "not ok 11\n");
+print ("@b" eq '1 2 3 4' ? "ok 13\n" : "not ok 13\n");
 print "# x = '@b'\n";
 
 @b = sort grep { $_ } (4,1,3,2);
-print ("@b" eq '1 2 3 4' ? "ok 12\n" : "not ok 12\n");
+print ("@b" eq '1 2 3 4' ? "ok 14\n" : "not ok 14\n");
 print "# x = '@b'\n";
 
 @b = sort map { $_ } (4,1,3,2);
-print ("@b" eq '1 2 3 4' ? "ok 13\n" : "not ok 13\n");
+print ("@b" eq '1 2 3 4' ? "ok 15\n" : "not ok 15\n");
 print "# x = '@b'\n";
 
 @b = sort reverse (4,1,3,2);
-print ("@b" eq '1 2 3 4' ? "ok 14\n" : "not ok 14\n");
+print ("@b" eq '1 2 3 4' ? "ok 16\n" : "not ok 16\n");
 print "# x = '@b'\n";
 
 $^W = 0;
 # redefining sort sub inside the sort sub should fail
 sub twoface { *twoface = sub { $a <=> $b }; &twoface }
 eval { @b = sort twoface 4,1,3,2 };
-print ($@ =~ /redefine active sort/ ? "ok 15\n" : "not ok 15\n");
+print ($@ =~ /redefine active sort/ ? "ok 17\n" : "not ok 17\n");
 
 # redefining sort subs outside the sort should not fail
 eval { *twoface = sub { &backwards } };
-print $@ ? "not ok 16\n" : "ok 16\n";
+print $@ ? "not ok 18\n" : "ok 18\n";
 
 eval { @b = sort twoface 4,1,3,2 };
-print ("@b" eq '4 3 2 1' ? "ok 17\n" : "not ok 17 |@b|\n");
+print ("@b" eq '4 3 2 1' ? "ok 19\n" : "not ok 19 |@b|\n");
 
 *twoface = sub { *twoface = *backwards; $a <=> $b };
 eval { @b = sort twoface 4,1 };
-print ($@ =~ /redefine active sort/ ? "ok 18\n" : "not ok 18\n");
+print ($@ =~ /redefine active sort/ ? "ok 20\n" : "not ok 20\n");
 
 *twoface = sub {
                  eval 'sub twoface { $a <=> $b }';
-                die($@ =~ /redefine active sort/ ? "ok 19\n" : "not ok 19\n");
+                die($@ =~ /redefine active sort/ ? "ok 21\n" : "not ok 21\n");
                 $a <=> $b;
               };
 eval { @b = sort twoface 4,1 };
-print $@ ? "$@" : "not ok 19\n";
+print $@ ? "$@" : "not ok 21\n";
 
 eval <<'CODE';
     my @result = sort main'backwards 'one', 'two';
 CODE
-print $@ ? "not ok 20\n# $@" : "ok 20\n";
+print $@ ? "not ok 22\n# $@" : "ok 22\n";
 
 eval <<'CODE';
     # "sort 'one', 'two'" should not try to parse "'one" as a sort sub
     my @result = sort 'one', 'two';
 CODE
-print $@ ? "not ok 21\n# $@" : "ok 21\n";
+print $@ ? "not ok 23\n# $@" : "ok 23\n";
 
 {
   my $sortsub = \&backwards;
@@ -137,13 +149,28 @@ print $@ ? "not ok 21\n# $@" : "ok 21\n";
   my $sortglobr = \*backwards;
   my $sortname = 'backwards';
   @b = sort $sortsub 4,1,3,2;
-  print ("@b" eq '4 3 2 1' ? "ok 22\n" : "not ok 22 |@b|\n");
+  print ("@b" eq '4 3 2 1' ? "ok 24\n" : "not ok 24 |@b|\n");
   @b = sort $sortglob 4,1,3,2;
-  print ("@b" eq '4 3 2 1' ? "ok 23\n" : "not ok 23 |@b|\n");
+  print ("@b" eq '4 3 2 1' ? "ok 25\n" : "not ok 25 |@b|\n");
   @b = sort $sortname 4,1,3,2;
-  print ("@b" eq '4 3 2 1' ? "ok 24\n" : "not ok 24 |@b|\n");
+  print ("@b" eq '4 3 2 1' ? "ok 26\n" : "not ok 26 |@b|\n");
   @b = sort $sortglobr 4,1,3,2;
-  print ("@b" eq '4 3 2 1' ? "ok 25\n" : "not ok 25 |@b|\n");
+  print ("@b" eq '4 3 2 1' ? "ok 27\n" : "not ok 27 |@b|\n");
+}
+
+{
+  my $sortsub = \&backwards_stacked;
+  my $sortglob = *backwards_stacked;
+  my $sortglobr = \*backwards_stacked;
+  my $sortname = 'backwards_stacked';
+  @b = sort $sortsub 4,1,3,2;
+  print ("@b" eq '4 3 2 1' ? "ok 28\n" : "not ok 28 |@b|\n");
+  @b = sort $sortglob 4,1,3,2;
+  print ("@b" eq '4 3 2 1' ? "ok 29\n" : "not ok 29 |@b|\n");
+  @b = sort $sortname 4,1,3,2;
+  print ("@b" eq '4 3 2 1' ? "ok 30\n" : "not ok 30 |@b|\n");
+  @b = sort $sortglobr 4,1,3,2;
+  print ("@b" eq '4 3 2 1' ? "ok 31\n" : "not ok 31 |@b|\n");
 }
 
 {
@@ -152,13 +179,28 @@ print $@ ? "not ok 21\n# $@" : "ok 21\n";
   local $sortglobr = \*backwards;
   local $sortname = 'backwards';
   @b = sort $sortsub 4,1,3,2;
-  print ("@b" eq '4 3 2 1' ? "ok 26\n" : "not ok 26 |@b|\n");
+  print ("@b" eq '4 3 2 1' ? "ok 32\n" : "not ok 32 |@b|\n");
   @b = sort $sortglob 4,1,3,2;
-  print ("@b" eq '4 3 2 1' ? "ok 27\n" : "not ok 27 |@b|\n");
+  print ("@b" eq '4 3 2 1' ? "ok 33\n" : "not ok 33 |@b|\n");
   @b = sort $sortname 4,1,3,2;
-  print ("@b" eq '4 3 2 1' ? "ok 28\n" : "not ok 28 |@b|\n");
+  print ("@b" eq '4 3 2 1' ? "ok 34\n" : "not ok 34 |@b|\n");
   @b = sort $sortglobr 4,1,3,2;
-  print ("@b" eq '4 3 2 1' ? "ok 29\n" : "not ok 29 |@b|\n");
+  print ("@b" eq '4 3 2 1' ? "ok 35\n" : "not ok 35 |@b|\n");
+}
+
+{
+  local $sortsub = \&backwards_stacked;
+  local $sortglob = *backwards_stacked;
+  local $sortglobr = \*backwards_stacked;
+  local $sortname = 'backwards_stacked';
+  @b = sort $sortsub 4,1,3,2;
+  print ("@b" eq '4 3 2 1' ? "ok 36\n" : "not ok 36 |@b|\n");
+  @b = sort $sortglob 4,1,3,2;
+  print ("@b" eq '4 3 2 1' ? "ok 37\n" : "not ok 37 |@b|\n");
+  @b = sort $sortname 4,1,3,2;
+  print ("@b" eq '4 3 2 1' ? "ok 38\n" : "not ok 38 |@b|\n");
+  @b = sort $sortglobr 4,1,3,2;
+  print ("@b" eq '4 3 2 1' ? "ok 39\n" : "not ok 39 |@b|\n");
 }
 
 ## exercise sort builtins... ($a <=> $b already tested)
@@ -167,42 +209,46 @@ print $@ ? "not ok 21\n# $@" : "ok 21\n";
     my $dummy;         # force blockness
     return $b <=> $a
 } @a;
-print ("@b" eq '1996 255 90 19 5' ? "ok 30\n" : "not ok 30\n");
+print ("@b" eq '1996 255 90 19 5' ? "ok 40\n" : "not ok 40\n");
 print "# x = '@b'\n";
 $x = join('', sort { $a cmp $b } @harry);
 $expected = $upperfirst ? 'AbelCaincatdogx' : 'catdogxAbelCain';
-print ($x eq $expected ? "ok 31\n" : "not ok 31\n");
+print ($x eq $expected ? "ok 41\n" : "not ok 41\n");
 print "# x = '$x'; expected = '$expected'\n";
 $x = join('', sort { $b cmp $a } @harry);
 $expected = $upperfirst ? 'xdogcatCainAbel' : 'CainAbelxdogcat';
-print ($x eq $expected ? "ok 32\n" : "not ok 32\n");
+print ($x eq $expected ? "ok 42\n" : "not ok 42\n");
 print "# x = '$x'; expected = '$expected'\n";
 {
     use integer;
     @b = sort { $a <=> $b } @a;
-    print ("@b" eq '5 19 90 255 1996' ? "ok 33\n" : "not ok 33\n");
+    print ("@b" eq '5 19 90 255 1996' ? "ok 43\n" : "not ok 43\n");
     print "# x = '@b'\n";
     @b = sort { $b <=> $a } @a;
-    print ("@b" eq '1996 255 90 19 5' ? "ok 34\n" : "not ok 34\n");
+    print ("@b" eq '1996 255 90 19 5' ? "ok 44\n" : "not ok 44\n");
     print "# x = '@b'\n";
     $x = join('', sort { $a cmp $b } @harry);
     $expected = $upperfirst ? 'AbelCaincatdogx' : 'catdogxAbelCain';
-    print ($x eq $expected ? "ok 35\n" : "not ok 35\n");
+    print ($x eq $expected ? "ok 45\n" : "not ok 45\n");
     print "# x = '$x'; expected = '$expected'\n";
     $x = join('', sort { $b cmp $a } @harry);
     $expected = $upperfirst ? 'xdogcatCainAbel' : 'CainAbelxdogcat';
-    print ($x eq $expected ? "ok 36\n" : "not ok 36\n");
+    print ($x eq $expected ? "ok 46\n" : "not ok 46\n");
     print "# x = '$x'; expected = '$expected'\n";
 }
 
 # test that an optimized-away comparison block doesn't take any other
 # arguments away with it
 $x = join('', sort { $a <=> $b } 3, 1, 2);
-print $x eq "123" ? "ok 37\n" : "not ok 37\n";
+print $x eq "123" ? "ok 47\n" : "not ok 47\n";
 
 # test sorting in non-main package
 package Foo;
 @a = ( 5, 19, 1996, 255, 90 );
 @b = sort { $b <=> $a } @a;
-print ("@b" eq '1996 255 90 19 5' ? "ok 38\n" : "not ok 38\n");
+print ("@b" eq '1996 255 90 19 5' ? "ok 48\n" : "not ok 48\n");
+print "# x = '@b'\n";
+
+@b = sort main::backwards_stacked @a;
+print ("@b" eq '90 5 255 1996 19' ? "ok 49\n" : "not ok 49\n");
 print "# x = '@b'\n";
Unnamed repository; edit this file to name it for gitweb.