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

Author: jonathan
Date: Tue Dec  9 07:55:28 2008
New Revision: 33713

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

Log:
[rakudo] Make reduction meta-operator work with chaining comparrison operators.

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 07:55:28 2008
@@ -6,28 +6,47 @@
 use warnings;
 
 my @ops = qw(
-  **        1
-  *         1
-  /         'fail'
-  %         'fail'
-  x         'fail'
-  xx        'fail'
-  +&        -1
-  +<        'fail'
-  +>        'fail'
-  ~&        'fail'
-  ~<        'fail'
-  ~>        'fail'
-  ?&        1
-  +         0
-  -         0
-  ~         ''
-  +|        0
-  +^        0
-  ~|        ''
-  ~^        ''
-  ?|        0
-  ?^        0
+  **        1           op
+  *         1           op
+  /         'fail'      op
+  %         'fail'      op
+  x         'fail'      op
+  xx        'fail'      op
+  +&        -1          op
+  +<        'fail'      op
+  +>        'fail'      op
+  ~&        'fail'      op
+  ~<        'fail'      op
+  ~>        'fail'      op
+  ?&        1           op
+  +         0           op
+  -         0           op
+  ~         ''          op
+  +|        0           op
+  +^        0           op
+  ~|        ''          op
+  ~^        ''          op
+  ?|        0           op
+  ?^        0           op
+  !==       'False'     comp
+  !=        'False'     comp
+  ==        'True'      comp
+  <         'True'      comp
+  <=        'True'      comp
+  >         'True'      comp
+  >=        'True'      comp
+  ~~        'True'      comp
+  !~~       'False'     comp
+  eq        'True'      comp
+  ne        'False'     comp
+  lt        'True'      comp
+  le        'True'      comp
+  gt        'True'      comp
+  ge        'True'      comp
+  ===       'True'      comp
+  !===      'False'     comp
+  =:=       'True'      comp
+  !=:=      'False'     comp
 );
 
 
@@ -45,20 +64,26 @@
 while (@ops) {
     my $opname   = shift @ops;
     my $identity = shift @ops;
+    my $op_type  = shift @ops;
 
-    push @gtokens, sprintf( $assignfmt, $opname );
-    push @gtokens, sprintf( $reducefmt, $opname );
-
-    push @code, qq(
+    # Only emit assignment meta-ops for standard ops.
+    if ($op_type eq 'op') {
+        push @gtokens, sprintf( $assignfmt, $opname );
+        push @code, qq(
         .sub 'infix:$opname='
             .param pmc a
             .param pmc b
             .tailcall '!ASSIGNMETAOP'('$opname', a, b)
-        .end
+        .end\n);
+    }
 
+    # All ops work for reductions.
+    push @gtokens, sprintf( $reducefmt, $opname );
+    my $chain = $op_type eq 'comp' ? 'CHAIN' : '';
+    push @code, qq(
         .sub 'prefix:[$opname]'
             .param pmc args    :slurpy
-            .tailcall '!REDUCEMETAOP'('$opname', $identity, args)
+            .tailcall '!REDUCEMETAOP$chain'('$opname', $identity, args)
         .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 07:55:28 2008
@@ -188,6 +188,43 @@
 .end
 
 
+.sub '!REDUCEMETAOPCHAIN'
+    .param string opname
+    .param string identity
+    .param pmc args                # already :slurpy array by caller
+
+    .local int want_true
+    want_true = identity == 'True'
+
+    args.'!flatten'()
+    $I0 = elements args
+    if $I0 > 1 goto reduce
+    if want_true goto true
+  false:
+    $P0 = get_hll_global [ 'Bool' ], 'False'
+    .return ($P0)
+  true:
+    $P0 = get_hll_global [ 'Bool' ], 'True'
+    .return ($P0)
+
+  reduce:
+    opname = concat 'infix:', opname
+    .local pmc opfunc
+    opfunc = find_name opname
+    .local pmc a, b
+    b = shift args
+  reduce_loop:
+    unless args goto reduce_done
+    a = b
+    b = shift args
+    $I0 = opfunc(a, b)
+    unless $I0 goto false
+    goto reduce_loop
+  reduce_done:
+    goto true
+.end
+
+
 .sub '!ASSIGNMETAOP'
     .param string opname
     .param pmc a

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