# New Ticket Created by John Williams
# Please include the string: [perl #17397]
# in the subject line of all future correspondence about this issue.
# <URL: http://rt.perl.org/rt2/Ticket/Display.html?id=17397 >
The attached patch makes assignment hyper operators (^+= etc) work in the
perl6 compiler.
It also fixes a bug where @a ^+ @b (or any other hyper-op) always chose
the length of the right side, instead of the longest length.
A test case is included as well.
~ John Williams
-- attachment 1 ------------------------------------------------------
url: http://rt.perl.org/rt2/attach/37993/30884/d8be89/assignhyper.patch
Index: languages/perl6/P6C/Addcontext.pm
===================================================================
RCS file: /cvs/public/parrot/languages/perl6/P6C/Addcontext.pm,v
retrieving revision 1.17
diff -u -r1.17 Addcontext.pm
--- languages/perl6/P6C/Addcontext.pm 12 Sep 2002 14:34:40 -0000 1.17
+++ languages/perl6/P6C/Addcontext.pm 18 Sep 2002 04:33:27 -0000
@@ -90,7 +90,21 @@
sub P6C::Binop::ctx_right {
my ($x, $ctx) = @_;
my $op = $x->op;
- if (ref($op) && $op->isa('P6C::hype')) {
+
+ if ((ref($op) && $op->isa('P6C::hype') && $op->op =~ /^([^=]+)=$/)
+ || $op =~ /^([^=]+)=$/) {
+ # Turn this into a normal, non-inplace operator and try again.
+ # Yuck.
+ my $new_op = $1;
+ $new_op = new P6C::hype op => $1 if ref $op;
+ my $ltmp = deep_copy($x->l);
+ my $new_rhs = new P6C::Binop op => $new_op, l => $ltmp, r => $x->r;
+ $x->op('=');
+ $x->r($new_rhs);
+ $x->ctx_right($ctx);
+ return;
+
+ } elsif (ref($op) && $op->isa('P6C::hype')) {
# XXX: is_array_expr is a hack, so this may cause some
# problems. However, it works in straightforward cases.
my $newctx = new P6C::Context;
@@ -109,16 +123,6 @@
$x->l->ctx_left($x->r, $ctx);
# give incoming context to left side
$x->l->ctx_right($ctx);
-
- } elsif ($op =~ /^([^=]+)=$/) {
- # Turn this into a normal, non-inplace operator and try again.
- # Yuck.
- my $ltmp = deep_copy($x->l);
- my $new_rhs = new P6C::Binop op => $1, l => $ltmp, r => $x->r;
- $x->op('=');
- $x->r($new_rhs);
- $x->ctx_right($ctx);
- return;
} elsif ($op eq ',') {
# List of items.
Index: languages/perl6/P6C/IMCC/hype.pm
===================================================================
RCS file: /cvs/public/parrot/languages/perl6/P6C/IMCC/hype.pm,v
retrieving revision 1.3
diff -u -r1.3 hype.pm
--- languages/perl6/P6C/IMCC/hype.pm 24 Aug 2002 23:25:25 -0000 1.3
+++ languages/perl6/P6C/IMCC/hype.pm 18 Sep 2002 04:33:28 -0000
@@ -185,8 +185,8 @@
# hype_array_array
$llen = $lval
$rlen = $rval
- if $llen > $rlen goto $cntlabel
- $llen = $rlen
+ if $llen < $rlen goto $cntlabel
+ $rlen = $llen
$cntlabel:
$dest = $llen
END
Index: languages/perl6/t/compiler/1.t
===================================================================
RCS file: /cvs/public/parrot/languages/perl6/t/compiler/1.t,v
retrieving revision 1.7
diff -u -r1.7 1.t
--- languages/perl6/t/compiler/1.t 24 Aug 2002 23:26:28 -0000 1.7
+++ languages/perl6/t/compiler/1.t 18 Sep 2002 04:33:29 -0000
@@ -1,6 +1,6 @@
#!perl
use strict;
-use P6C::TestCompiler tests => 12;
+use P6C::TestCompiler tests => 13;
use Test::More qw(skip);
##############################
@@ -274,5 +274,47 @@
(, , 1)
(1, 0, 1)
(1, 0, 0)
+OUT
+
+
+##############################
+output_is(<<'CODE', <<'OUT', 'Hyper Assign');
+my @a = 2..4;
+my @b = 5..6;
+my @c;
+@c = @a;
+@c ^+= @b;
+print @c ^_ ' ',"\n";
+@c = @b;
+@c ^+= @a;
+print @c ^_ ' ',"\n";
+
+@c = @a;
+@c ^*= @b;
+print @c ^_ ' ',"\n";
+
+@c = @a;
+@c ^**= @b;
+print @c ^_ ' ',"\n";
+
+@c = @a;
+@c ^/= @b;
+print @c ^_ ' ',"\n";
+
+@c = @b;
+@c ^%= @a;
+print @c ^_ ' ',"\n";
+
+@c = @b;
+@c ^-= @a;
+print @c ^_ ' ',"\n";
+CODE
+7.000000 9.000000 4.000000
+7.000000 9.000000 4.000000
+10.000000 18.000000 0.000000
+32.000000 729.000000 1.000000
+0.400000 0.500000 inf
+1.000000 0.000000 0.000000
+3.000000 3.000000 -4.000000
OUT
