[rakudo]: Fix assignment metaoperators, add reduction operators (e.g.…

…, [+]).

git-svn-id: http://svn.perl.org/parrot/trunk/languages/perl6@33611 d31e2699-5ff4-0310-a27c-f18f2fbe73fe

build/gen_metaop_pir.pl

@@ -0,0 +1,81 @@
+#!/usr/bin/perl
+# Copyright (C) 2008, The Perl Foundation.
+# $Id$
+
+use strict;
+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
+);
+
+
+my $output = $ARGV[0] || '-';
+
+
+my $assignfmt = 
+    "    optable.'newtok'('infix:%s=', 'equiv'=>'infix::=', 'lvalue'=>1)\n";
+my $reducefmt =
+    "    optable.'newtok'('prefix:[%s]', 'equiv'=>'infix:=')\n";
+
+my @gtokens = ();
+my @code = ();
+
+while (@ops) {
+    my $opname   = shift @ops;
+    my $identity = shift @ops;
+
+    push @gtokens, sprintf( $assignfmt, $opname );
+    push @gtokens, sprintf( $reducefmt, $opname );
+
+    push @code, qq(
+        .sub 'infix:$opname='
+            .param pmc a
+            .param pmc b
+            .tailcall '!ASSIGNMETAOP'('$opname', a, b)
+        .end
+
+        .sub 'prefix:[$opname]'
+            .param pmc args    :slurpy
+            .tailcall '!REDUCEMETAOP'('$opname', $identity, args)
+        .end\n);
+}
+
+my $gtokens = join('', @gtokens);
+
+open my $fh, "> $output" or die "Could not write $output: $!";
+print $fh qq(
+.namespace []
+.sub '' :init :load
+    .local pmc optable
+    optable = get_hll_global ['Perl6';'Grammar'], '\$optable'
+$gtokens
+.end
+
+);
+
+print $fh @code;
+
+close $fh;
+0;

config/makefiles/root.in

@@ -42,6 +42,7 @@ SOURCES = perl6.pir \
   src/gen_grammar.pir \
   src/gen_actions.pir \
   src/gen_builtins.pir \
+  src/gen_metaop.pir \
   src/gen_junction.pir \
   src/parser/expression.pir \
   src/parser/quote_expression.pir \
@@ -134,6 +135,9 @@ src/gen_actions.pir: $(NQP) $(PCT) src/parser/actions.pm
 src/gen_builtins.pir: build/gen_builtins_pir.pl
 	$(PERL) build/gen_builtins_pir.pl $(BUILTINS_PIR) > src/gen_builtins.pir
 
+src/gen_metaop.pir: build/gen_metaop_pir.pl
+	$(PERL) build/gen_metaop_pir.pl > src/gen_metaop.pir
+
 src/gen_junction.pir: build/gen_junction_pir.pl
 	$(PERL) build/gen_junction_pir.pl src/gen_junction.pir
 
@@ -243,9 +247,7 @@ CLEANUPS = \
   perl6$(EXE) \
   installable_perl6$(EXE) \
   Test.pir \
-  src/gen_grammar.pir \
-  src/gen_actions.pir \
-  src/gen_builtins.pir \
+  src/gen_*.pir \
   $(PMC_DIR)/*.h \
   $(PMC_DIR)/*.c \
   $(PMC_DIR)/*.dump \

perl6.pir

@@ -222,6 +222,7 @@ to the Perl 6 compiler.
 .include 'src/parser/expression.pir'
 .include 'src/parser/quote_expression.pir'
 .include 'src/gen_actions.pir'
+.include 'src/gen_metaop.pir'
 .include 'src/gen_junction.pir'
 
 

src/builtins/assign.pir

@@ -74,185 +74,56 @@ src/builtins/inplace.pir - Inplace assignments
 .end
 
 
-.sub '!INIT_IF_PROTO'
-    .param pmc var
-    .param pmc val
-    $I0 = defined var
-    if $I0 goto done
-    'infix:='(var, val)
-  done:
-    .return ()
-.end
-
-
-.sub 'infix:~='
-    .param pmc a
-    .param pmc b
-    '!INIT_IF_PROTO'(a, '')
-    concat a, b
-    .return (a)
-.end
-
-
-.sub 'infix:+='
-    .param pmc a
-    .param pmc b
-    '!INIT_IF_PROTO'(a, 0)
-    a += b
-    .return (a)
-.end
-
-
-.sub 'infix:-='
-    .param pmc a
-    .param pmc b
-    '!INIT_IF_PROTO'(a, 0)
-    a -= b
-    .return (a)
-.end
-
-
-.sub 'infix:*='
-    .param pmc a
-    .param pmc b
-    '!INIT_IF_PROTO'(a, 1)
-    a *= b
-    .return (a)
-.end
-
-
-.sub 'infix:/='
-    .param pmc a
-    .param pmc b
-    a /= b
-    .return (a)
-.end
-
-
-.sub 'infix:%='
-    .param pmc a
-    .param pmc b
-    a %= b
-    .return (a)
-.end
-
-
-.sub 'infix:x='
-    .param pmc a
-    .param pmc b
-    repeat a, b
-    .return (a)
-.end
-
-
-## TODO: infix:Y=
-.sub 'infix:**='
-    .param pmc a
-    .param pmc b
-    '!INIT_IF_PROTO'(a, 1)
-    pow $P0, a, b
+.sub '!REDUCEMETAOP'
+    .param string opname
+    .param pmc identity
+    .param pmc args                # already :slurpy array by caller
+
+    args.'!flatten'()
+    if args goto reduce
+    if identity == 'fail' goto fail
+    .return (identity)
+
+  fail:
+    .tailcall '!FAIL'()
+
+  reduce:
+    opname = concat 'infix:', opname
+    .local pmc opfunc
+    opfunc = find_name opname
+    .local pmc result
+    result = shift args
+  reduce_loop:
+    unless args goto reduce_done
+    $P0 = shift args
+    result = opfunc(result, $P0)
+    goto reduce_loop
+  reduce_done:
+    .return (result)
+.end
+
+
+.sub '!ASSIGNMETAOP'
+    .param string opname
+    .param pmc a
+    .param pmc b
+
+    $I0 = defined a
+    if $I0 goto have_a
+    $S0 = concat 'prefix:[', opname
+    concat $S0, ']'
+    $P1 = find_name $S0
+    $P0 = $P1()
     'infix:='(a, $P0)
-    .return (a)
-.end
-
-
-## TODO: infix:xx= infix:||= infix:&&= infix://= infix:^^=
-
-
-.sub 'infix:+<='
-    .param pmc a
-    .param pmc b
-    a <<= b
-    .return (a)
-.end
-
+  have_a:
 
-.sub 'infix:+>='
-    .param pmc a
-    .param pmc b
-    a >>= b
-    .return (a)
-.end
-
-
-.sub 'infix:+&='
-    .param pmc a
-    .param pmc b
-    band a, b
-    .return (a)
-.end
-
-
-.sub 'infix:+|='
-    .param pmc a
-    .param pmc b
-    bor a, b
-    .return (a)
-.end
-
-
-.sub 'infix:+^='
-    .param pmc a
-    .param pmc b
-    bxor a, b
-    .return (a)
-.end
-
-
-.sub 'infix:~&='
-    .param pmc a
-    .param pmc b
-    a = bands a, b
-    .return (a)
-.end
-
-
-.sub 'infix:~|='
-    .param pmc a
-    .param pmc b
-    bors a, b
-    .return (a)
-.end
-
-
-.sub 'infix:~^='
-    .param pmc a
-    .param pmc b
-    bxors a, b
-    .return (a)
-.end
-
-
-.sub 'infix:?&='
-    .param pmc a
-    .param pmc b
-    band a, b
-    $I0 = istrue a
-    a = $I0
-    .return (a)
-.end
-
-
-.sub 'infix:?|='
-    .param pmc a
-    .param pmc b
-    bor a, b
-    $I0 = istrue a
-    a = $I0
-    .return (a)
-.end
-
-
-.sub 'infix:?^='
-    .param pmc a
-    .param pmc b
-    bxor a, b
-    $I0 = istrue a
-    a = $I0
+    opname = concat 'infix:', opname
+    $P1 = find_name opname
+    $P0 = $P1(a, b)
+    'infix:='(a, $P0)
     .return (a)
 .end
 
-
 =back
 
 =cut

src/builtins/op.pir

@@ -31,31 +31,43 @@ src/builtins/op.pir - Perl6 builtin operators
 .sub 'postfix:++' :multi(_)
     .param pmc a
     $P0 = clone a
-    '!INIT_IF_PROTO'(a, 0)
+    $I0 = defined a
+    if $I0 goto have_a
+    'infix:='(a, 0)
+  have_a:
     inc a
     .return ($P0)
 .end
 
 .sub 'postfix:--' :multi(_)
     .param pmc a
     $P0 = clone a
-    '!INIT_IF_PROTO'(a, 0)
+    $I0 = defined a
+    if $I0 goto have_a
+    'infix:='(a, 0)
+  have_a:
     dec a
     .return ($P0)
 .end
 
 
 .sub 'prefix:++' :multi(_)
     .param pmc a
-    '!INIT_IF_PROTO'(a, 0)
+    $I0 = defined a
+    if $I0 goto have_a
+    'infix:='(a, 0)
+  have_a:
     inc a
     .return (a)
 .end
 
 
 .sub 'prefix:--' :multi(_)
     .param pmc a
-    '!INIT_IF_PROTO'(a, 0)
+    $I0 = defined a
+    if $I0 goto have_a
+    'infix:='(a, 0)
+  have_a:
     dec a
     .return (a)
 .end