[svn:parrot] r33733 - in trunk/languages/perl6: build src/builtins

Author: jonathan
Date: Tue Dec  9 14:57:19 2008
New Revision: 33733

Modified:
   trunk/languages/perl6/build/gen_metaop_pir.pl
   trunk/languages/perl6/src/builtins/assign.pir

Log:
[rakudo] Implement cross meta-operator, which sicne now we have reduce and we already had infix:X was rather trivial (it's just the de-sugaring shown in S03).

Modified: trunk/languages/perl6/build/gen_metaop_pir.pl
==============================================================================
--- trunk/languages/perl6/build/gen_metaop_pir.pl	(original)
+++ trunk/languages/perl6/build/gen_metaop_pir.pl	Tue Dec  9 14:57:19 2008
@@ -60,6 +60,8 @@
 my $hyper_no_dwim_fmt =
     "    optable.'newtok'(%s, 'equiv'=>'infix:%s')\n" .
     "    optable.'newtok'('infix:%s', 'equiv'=>'infix:%s', 'subname'=>%s)\n";
+my $crossfmt =
+    "    optable.'newtok'('infix:X%sX', 'equiv'=>'infix:X')\n";
 
 my @gtokens = ();
 my @code = ();
@@ -89,6 +91,16 @@
             .tailcall '!REDUCEMETAOP$chain'('$opname', $identity, args)
         .end\n);
 
+    # Cross operators.
+    push @gtokens, sprintf( $crossfmt, $opname );
+    my $is_chaining = $op_type eq 'comp' ? 1 : 0;
+    push @code, qq(
+        .sub 'infix:X${opname}X'
+            .param pmc a
+            .param pmc b
+            .tailcall '!CROSSMETAOP'('$opname', $identity, $is_chaining, a, b)
+        .end\n);
+
     # Non-dwimming hyper ops.
     my $hypername = qq(unicode:"infix:\\u00ab$opname\\u00bb");
     push @gtokens, sprintf($hyper_no_dwim_fmt, $hypername, $opname, ">>$opname<<", $opname, $hypername);

Modified: trunk/languages/perl6/src/builtins/assign.pir
==============================================================================
--- trunk/languages/perl6/src/builtins/assign.pir	(original)
+++ trunk/languages/perl6/src/builtins/assign.pir	Tue Dec  9 14:57:19 2008
@@ -342,6 +342,39 @@
     'die'("Non-dwimmy hyperoperator cannot be used on arrays of different sizes or dimensions.")
 .end
 
+
+.sub '!CROSSMETAOP'
+    .param string opname
+    .param string identity
+    .param int chain
+    .param pmc a
+    .param pmc b
+
+    # Use the X operator to get all permutation lists.
+    .local pmc lists
+    lists = 'infix:X'(a, b)
+
+    # Go over the lists and combine them with reduce meta-op.
+    .local pmc result, it, combinder
+    if chain goto chain_reduce
+    combinder = find_name '!REDUCEMETAOP'
+    goto combinder_done
+  chain_reduce:
+    combinder = find_name '!REDUCEMETAOPCHAIN'
+  combinder_done:
+    result = 'list'()
+    it = iter lists
+  it_loop:
+    unless it goto it_loop_end
+    $P0 = shift it
+    $P0 = combinder(opname, identity, $P0)
+    push result, $P0
+    goto it_loop
+  it_loop_end:
+
+    .return (result)
+.end
+
 =back
 
 =cut

• [svn:parrot] r33733 - in trunk/languages/perl6: build src/builtins by jonathan