develooper Front page | perl.cvs.parrot | Postings from December 2008

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

From:
jonathan
Date:
December 9, 2008 10:28
Subject:
[svn:parrot] r33719 - in trunk/languages/perl6: build src/builtins
Message ID:
20081209182829.0BA04CB9AF@x12.develooper.com
Author: jonathan
Date: Tue Dec  9 10:28:28 2008
New Revision: 33719

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

Log:
[rakudo] Add the various dwimmy variants of infix hyperoperators.

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 10:28:28 2008
@@ -59,7 +59,7 @@
     "    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";
+    "    optable.'newtok'('infix:%s', 'equiv'=>'infix:%s', 'subname'=>%s)\n";
 
 my @gtokens = ();
 my @code = ();
@@ -91,12 +91,42 @@
 
     # Non-dwimming hyper ops.
     my $hypername = qq(unicode:"infix:\\u00ab$opname\\u00bb");
-    push @gtokens, sprintf($hyper_no_dwim_fmt, $hypername, $opname, $opname, $opname, $hypername);
+    push @gtokens, sprintf($hyper_no_dwim_fmt, $hypername, $opname, ">>$opname<<", $opname, $hypername);
     push @code, qq(
         .sub $hypername
             .param pmc a
             .param pmc b
-            .tailcall '!HYPEROPNODWIM'('$opname', a, b)
+            .tailcall '!HYPEROP'('$opname', a, b, 0, 0)
+        .end\n);
+
+    # LHS-dwimming hyper ops.
+    my $hypername = qq(unicode:"infix:\u00bbb$opname\\u00bb");
+    push @gtokens, sprintf($hyper_no_dwim_fmt, $hypername, $opname, "<<$opname<<", $opname, $hypername);
+    push @code, qq(
+        .sub $hypername
+            .param pmc a
+            .param pmc b
+            .tailcall '!HYPEROP'('$opname', a, b, 1, 0)
+        .end\n);
+
+    # RHS-dwimming hyper ops.
+    my $hypername = qq(unicode:"infix:\\u00ab$opname\\u00ab");
+    push @gtokens, sprintf($hyper_no_dwim_fmt, $hypername, $opname, ">>$opname>>", $opname, $hypername);
+    push @code, qq(
+        .sub $hypername
+            .param pmc a
+            .param pmc b
+            .tailcall '!HYPEROP'('$opname', a, b, 0, 1)
+        .end\n);
+
+    # Dwimming hyper ops.
+    my $hypername = qq(unicode:"infix:\\u00bb$opname\\u00ab");
+    push @gtokens, sprintf($hyper_no_dwim_fmt, $hypername, $opname, "<<$opname>>", $opname, $hypername);
+    push @code, qq(
+        .sub $hypername
+            .param pmc a
+            .param pmc b
+            .tailcall '!HYPEROP'('$opname', a, b, 1, 1)
         .end\n);
 }
 

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 10:28:28 2008
@@ -247,47 +247,92 @@
 .end
 
 
-.sub '!HYPEROPNODWIM'
+.sub '!HYPEROP'
     .param string opname
     .param pmc a
     .param pmc b
+    .param int dwim_lhs
+    .param int dwim_rhs
 
     # Make sure they're both lists. XXX Need to handle hashes in future.
     a = a.'list'()
     b = b.'list'()
 
     # Ensure lengths are the same.
-    $I0 = a.'elems'()
-    $I1 = b.'elems'()
-    if $I0 != $I1 goto incompatible
+    .local int elems_a, elems_b
+    elems_a = a.'elems'()
+    elems_b = b.'elems'()
+    if elems_a < elems_b goto extend_lhs
+    if elems_b < elems_a goto extend_rhs
+    goto go_hyper
+
+    # Extend LHS if needed.
+    .local pmc extend_with
+  extend_lhs:
+    unless dwim_lhs goto incompatible
+    if elems_a > 0 goto have_elems_a
+    extend_with = '!FAIL'()
+    a = 'infix:xx'(extend_with, elems_b)
+    goto go_hyper
+  have_elems_a:
+    extend_with = a[-1]
+    $I0 = elems_b - elems_a
+    extend_with = 'infix:xx'(extend_with, $I0)
+    a = 'list'(a, extend_with)
+    goto go_hyper
+
+    # Extend RHS if needed.
+  extend_rhs:
+    unless dwim_rhs goto incompatible
+    if elems_b > 0 goto have_elems_b
+    extend_with = '!FAIL'()
+    b = 'infix:xx'(extend_with, elems_a)
+    goto go_hyper
+  have_elems_b:
+    extend_with = b[-1]
+    $I0 = elems_a - elems_b
+    extend_with = 'infix:xx'(extend_with, $I0)
+    b = 'list'(b, extend_with)
+    goto go_hyper
 
     # Create result list and get iterators over the two.
+  go_hyper:
     .local pmc result, it_a, it_b
     result = new 'Perl6Array'
     it_a = iter a
     it_b = iter b
 
     # Go over them and do the op, recursing if we see a nested array.
-    .local pmc opfunc
+    .local pmc opfunc, cur_a, cur_b
+    .local int array_a, array_b
     $S0 = concat 'infix:', opname
     opfunc = find_name $S0
   loop:
     unless it_a goto loop_end
-    $P0 = shift it_a
-    $P1 = shift it_b
-    $I0 = isa $P0, 'Perl6Array'
-    if $I0 goto nested_array
-    $P2 = opfunc($P0, $P1)
-    push result, $P2
+    cur_a = shift it_a
+    cur_b = shift it_b
+    array_a = isa cur_a, 'Perl6Array'
+    array_b = isa cur_b, 'Perl6Array'
+    if array_a goto nested_array_lhs
+    if array_b goto nested_array_rhs
+    $P0 = opfunc(cur_a, cur_b)
+    push result, $P0
     goto loop
 
-    # If it's a nested array on LHS, must be on RHS too.
-  nested_array:
-    $I0 = isa $P1, 'Perl6Array'
-    unless $I0 goto incompatible
-    $P2 = '!HYPEROPNODWIM'(opname, $P0, $P1)
-    $P2 = new 'ObjectRef', $P2
-    push result, $P2
+    # Handle nested arrays.
+  nested_array_lhs:
+    if array_b goto recurse
+    unless dwim_rhs goto incompatible
+    cur_b = 'list'(cur_b)
+    goto recurse
+  nested_array_rhs:
+    if array_a goto recurse
+    unless dwim_lhs goto incompatible
+    cur_a = 'list'(cur_a)
+  recurse:
+    $P0 = '!HYPEROP'(opname, cur_a, cur_b, dwim_lhs, dwim_rhs)
+    $P0 = new 'ObjectRef', $P0
+    push result, $P0
     goto loop
   
   loop_end:    



nntp.perl.org: Perl Programming lists via nntp and http.
Comments to Ask Bjørn Hansen at ask@perl.org | Group listing | About