[perl #63292] [PATCH] Implementation of triangle form of reduce metaops.

[via RT]

# New Ticket Created by  Vasily Chekalkin 
# Please include the string:  [perl #63292]
# in the subject line of all future correspondence about this issue. 
# <URL: http://rt.perl.org/rt3/Ticket/Display.html?id=63292 >


Hello.

There is implementation of triangle form of reduce metaop.
Tests are coming.


-- 
Bacek

commit 1134af2b6f8b7b18734ba8daff09fd2fbc515d4b
Author: Vasily Chekalkin <ba...@bacek.com>
Date:   Wed Feb 18 09:01:06 2009 +1100

    Implement triangle form of reduce metaop

diff --git a/build/gen_metaop_pir.pl b/build/gen_metaop_pir.pl
index 710dfff..afb5aaf 100644
--- a/build/gen_metaop_pir.pl
+++ b/build/gen_metaop_pir.pl
@@ -58,7 +58,8 @@ my $output = $ARGV[0] || '-';
 my $assignfmt =
     "    optable.'newtok'('infix:%s=', 'equiv'=>'infix::=', 'lvalue'=>1)\n";
 my $reducefmt =
-    "    optable.'newtok'('prefix:[%s]', 'equiv'=>'infix:=')\n";
+    "    optable.'newtok'('prefix:[%s]', 'equiv'=>'infix:=')\n" .
+    "    optable.'newtok'('prefix:[\\%s]', 'equiv'=>'infix:=')\n";
 my $hyper_no_dwim_fmt =
     "    optable.'newtok'(%s, 'equiv'=>'infix:%s')\n" .
     "    optable.'newtok'('infix:%s', 'equiv'=>'infix:%s', 'subname'=>%s)\n";
@@ -85,12 +86,17 @@ while (@ops) {
     }
 
     # All ops work for reductions.
-    push @gtokens, sprintf( $reducefmt, $opname );
+    push @gtokens, sprintf( $reducefmt, $opname, $opname );
     my $chain = $op_type eq 'comp' ? 'CHAIN' : '';
     push @code, qq(
         .sub 'prefix:[$opname]'
             .param pmc args    :slurpy
-            .tailcall '!REDUCEMETAOP$chain'('$opname', $identity, args)
+            .tailcall '!REDUCEMETAOP$chain'('$opname', $identity, args, 0 :named('triangle'))
+        .end\n);
+    push @code, qq(
+        .sub 'prefix:[\\\\$opname]'
+            .param pmc args    :slurpy
+            .tailcall '!REDUCEMETAOP$chain'('$opname', $identity, args, 1 :named('triangle'))
         .end\n);
 
     # Cross operators.
diff --git a/src/builtins/assign.pir b/src/builtins/assign.pir
index 106f26d..2c8c995 100644
--- a/src/builtins/assign.pir
+++ b/src/builtins/assign.pir
@@ -164,6 +164,8 @@ src/builtins/assign.pir - assignments
     .param string opname
     .param pmc identity
     .param pmc args                # already :slurpy array by caller
+    .param int triangle     :named('triangle')
+
 
     args.'!flatten'()
     if args goto reduce
@@ -174,17 +176,29 @@ src/builtins/assign.pir - assignments
     .tailcall '!FAIL'()
 
   reduce:
+    .local pmc result_list
+    unless triangle goto do_reduce
+    result_list = 'list'()
+  do_reduce:
     opname = concat 'infix:', opname
     .local pmc opfunc
     opfunc = find_name opname
     .local pmc result
     result = shift args
+    unless triangle goto reduce_loop
+    result_list.'push'(result)
   reduce_loop:
     unless args goto reduce_done
     $P0 = shift args
     result = opfunc(result, $P0)
+    unless triangle goto reduce_loop
+    result_list.'push'(result)
     goto reduce_loop
   reduce_done:
+
+    unless triangle goto done
+    result = result_list
+  done:
     .return (result)
 .end