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

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

From:
jonathan
Date:
December 9, 2008 08:58
Subject:
[svn:parrot] r33715 - in trunk/languages/perl6: build src/builtins
Message ID:
20081209165756.08319CBA89@x12.develooper.com
Author: jonathan
Date: Tue Dec  9 08:57:55 2008
New Revision: 33715

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

Log:
[rakudo] First cut on non-dwimmy hyper ops. The non-unicode quote forms now work, there's some problem with the unicode forms.

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 08:57:55 2008
@@ -57,6 +57,9 @@
     "    optable.'newtok'('infix:%s=', 'equiv'=>'infix::=', 'lvalue'=>1)\n";
 my $reducefmt =
     "    optable.'newtok'('prefix:[%s]', 'equiv'=>'infix:=')\n";
+my $hyper_no_dwim_fmt =
+    "    optable.'newtok'('infix:>>%s<<', 'equiv'=>'infix:%s')\n" .
+    "    optable.'newtok'(unicode:\"infix:\\u00ab%s\\u00bb\", 'equiv'=>'infix:%s', 'subname'=>'infix:>>%s<<')\n";
 
 my @gtokens = ();
 my @code = ();
@@ -85,6 +88,15 @@
             .param pmc args    :slurpy
             .tailcall '!REDUCEMETAOP$chain'('$opname', $identity, args)
         .end\n);
+
+    # Non-dwimming hyper ops.
+    push @gtokens, sprintf( $hyper_no_dwim_fmt, ($opname) x 5 );
+    push @code, qq(
+        .sub 'infix:>>$opname<<'
+            .param pmc a
+            .param pmc b
+            .tailcall '!HYPEROPNODWIM'('$opname', a, b)
+        .end\n);
 }
 
 my $gtokens = join('', @gtokens);

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 08:57:55 2008
@@ -246,6 +246,57 @@
     .return (a)
 .end
 
+
+.sub '!HYPEROPNODWIM'
+    .param string opname
+    .param pmc a
+    .param pmc b
+
+    # 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
+
+    # Create result list and get iterators over the two.
+    .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
+    $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
+    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
+    goto loop
+  
+  loop_end:    
+    .return (result)
+    
+  incompatible:
+    'die'("Non-dwimmy hyperoperator cannot be used on arrays of different sizes or dimensions.")
+.end
+
 =back
 
 =cut



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