# New Ticket Created by Allison Randal
# Please include the string: [perl #24559]
# in the subject line of all future correspondence about this issue.
# <URL: http://rt.perl.org/rt2/Ticket/Display.html?id=24559 >
This patch updates vector operators (from ^+ to >>+<<) and the XOR
operator (from ~~ to ^^) to match the current design. I still have a
few more tweaks I want to make (especially to how vector ops are
parsed), and a pile of other operator changes to make, but this was a
nice stopping point.
The two regex tests are still failing (I may have to fix those just so
they stop annoying me), but otherwise all the tests pass.
Allison
-- attachment 1 ------------------------------------------------------
url: http://rt.perl.org/rt2/attach/67828/50484/f0bc7c/p6c_update_vector_ops.patch
Index: languages/perl6/perl6
===================================================================
RCS file: /cvs/public/parrot/languages/perl6/perl6,v
retrieving revision 1.37
diff -u -r1.37 perl6
--- languages/perl6/perl6 31 Oct 2003 11:08:18 -0000 1.37
+++ languages/perl6/perl6 26 Nov 2003 23:29:01 -0000
@@ -77,7 +77,7 @@
-h|--help Print this message and exit
--help-(imcc|parrot|test|parser|global|output)
Print detailed help for one subpart
- -v|--verbose Print mesages about compile stages (repeat for
+ -v|--verbose Print messages about compile stages (repeat for
more verbosity)
-V|--version Print versions and exit
-w|--warnings Print warnings (repeat for more warnings)
Index: languages/perl6/P6C/Addcontext.pm
===================================================================
RCS file: /cvs/public/parrot/languages/perl6/P6C/Addcontext.pm,v
retrieving revision 1.20
diff -u -r1.20 Addcontext.pm
--- languages/perl6/P6C/Addcontext.pm 13 Oct 2003 17:00:40 -0000 1.20
+++ languages/perl6/P6C/Addcontext.pm 26 Nov 2003 23:29:05 -0000
@@ -52,7 +52,7 @@
# propagate values in their surrounding context (even though
# they may evaluate in boolean context?). So we can't quite
# do this:
-# bool => [ qw(&& ~~ ||) ],
+# bool => [ qw(&& ^^ ||) ],
);
while (my ($t, $ops) = each %opmap) {
@@ -91,6 +91,7 @@
my ($x, $ctx) = @_;
my $op = $x->op;
+ # Checking for stray assignment operators: "+=" or ">>+=<<".
if ((ref($op) && $op->isa('P6C::hype') && $op->op =~ /^([^=]+)=$/)
|| $op =~ /^([^=]+)=$/) {
# Turn this into a normal, non-inplace operator and try again.
Index: languages/perl6/P6C/IMCC.pm
===================================================================
RCS file: /cvs/public/parrot/languages/perl6/P6C/IMCC.pm,v
retrieving revision 1.29
diff -u -r1.29 IMCC.pm
--- languages/perl6/P6C/IMCC.pm 3 Nov 2003 15:05:17 -0000 1.29
+++ languages/perl6/P6C/IMCC.pm 26 Nov 2003 23:29:08 -0000
@@ -1347,7 +1347,7 @@
my $ltmp = $x->l->val;
my $rtmp = $x->r->val;
my $dest = newtmp 'PerlUndef';
- my $op = $x->op;
+ my $op = imcc_op($x->op);
code("\t$dest = $ltmp $op $rtmp\n");
return $dest;
}
@@ -1401,7 +1401,7 @@
'=' => \&do_assign,
'||' => \&do_logor,
'&&' => \&do_logand,
- '~~' => \&simple_binary,
+ '^^' => \&simple_binary,
'//' => \&do_defined,
',' => \&do_array,
'x' => \&do_repeat,
@@ -1413,39 +1413,41 @@
use vars '%op_is_array';
BEGIN {
- my @arrayops = qw(= .. x // ~~ && || _);
+ my @arrayops = qw(= .. x // ^^ && || _);
push(@arrayops, ',');
@[EMAIL PROTECTED] = (1) x @arrayops;
}
sub val {
my $x = shift;
+
if (ref($x->op) eq 'P6C::hype') {
+ check_assign_op($x->op->op);
return do_hyped($x->op->op, $x->l, $x->r);
}
+
my $ret;
my $op = $x->op;
if ($ops{$op}) {
$ret = $ops{$op}->($x);
- } elsif($op =~ /^([^=]+)=$/ && $ops{$1}) {
- # XXX:
- die "Internal error -- assignment op `$op' snuck into IMCC.pm";
-
- # Translate assignment operation into a binary operation.
- # XXX: Context propagation is broken for these, so we won't
- # ever do this.
- $op = $1;
- $ret = $ops{'='}->(new P6C::Binop op => '=', l => $x->l,
- r => P6C::Binop->new(op => $op, l => $x->l,
- r => $x->r));
} else {
- unimp $op;
+ check_assign_op($op);
+ unimp "Unimplemented operator $op";
}
if (!$op_is_array{$op}) {
return scalar_in_context($ret, $x->{ctx});
}
return $ret;
+}
+
+sub check_assign_op {
+ my $op = shift;
+ if($op =~ /^([^=]+)=$/ && $ops{$1}) {
+ # XXX: This should probably be checked at an earler stage.
+ die "Internal error -- assignment op `$op' snuck into IMCC.pm";
+ }
+ return 1;
}
######################################################################
Index: languages/perl6/P6C/Parser.pm
===================================================================
RCS file: /cvs/public/parrot/languages/perl6/P6C/Parser.pm,v
retrieving revision 1.27
diff -u -r1.27 Parser.pm
--- languages/perl6/P6C/Parser.pm 13 Oct 2003 17:00:41 -0000 1.27
+++ languages/perl6/P6C/Parser.pm 26 Nov 2003 23:29:09 -0000
@@ -229,7 +229,8 @@
use vars '$err_handler';
use vars qw(%KEYWORDS %CLASSES %WANT);
use vars qw($NAMEPART $COMPARE $CONTEXT $MULDIV $PREFIX $ADDSUB $INCR
- $LOG_OR $LOGOR $FILETEST $ASSIGN $HYPE $MATCH $BITSHIFT
+ $LOG_OR $LOGOR $FILETEST $ASSIGN $VOPEN $VCLOSE $MATCH
+ $BITSHIFT $BITOR $BITAND
$SOB $FLUSH $NUMPART $NUMBER $RXATOM $RXMETA $RXCHARCLASS
$SPECIAL_DELIM
$RXESCAPED $HEXCHAR $RXASSERTION);
@@ -246,7 +247,8 @@
# Regexen used in the parser:
BEGIN {
$SOB = qr|$Parse::RecDescent::skip(?<![^\n\s]){|o;
- $HYPE = qr/\^?/;
+ $VOPEN = qr/>>/;
+ $VCLOSE = qr/<</;
$NAMEPART = qr/[a-zA-Z_][\w_]*/;
$COMPARE = qr{(?:cmp|eq|[gnl]e|[gl]t)\b|<=>|[<>=!]=|<|>};
$CONTEXT = [EMAIL PROTECTED]&*_?]|\+(?!\+)};
@@ -260,9 +262,11 @@
$ADDSUB = qr{[-+_]};
$BITSHIFT = qr{<<|>>};
$LOG_OR = qr{(?:x?or|err)\b};
- $LOGOR = qr{\|\||~~|//};
+ $LOGOR = qr{\|\||\^\^|//};
+ $BITOR = qr{(?:\|(?!\|)|~(?!~))};
+ $BITAND = qr{&(?!&)};
$FILETEST = qr{-[rwxoRWXOezsfdlpSbctugkTBMAC]+\b};
- $ASSIGN = qr{(?:!|:|//|&&?|\|\|?|~~?|<<|>>|$ADDSUB|$MULDIV|\*\*)?=};
+ $ASSIGN = qr{(?:!|:|//|&&?|\|\|?|~|\^\^|<<|>>|$ADDSUB|$MULDIV|\*\*)?=};
# Used for flushing syntax errors
$FLUSH = qr/\w+|[^\s\w;}#'"]+/;
$NUMPART = qr/(?!_)[\d_]+(?<!_)/;
@@ -488,14 +492,14 @@
| subscript(s)
apply: <leftop: term apply_op apply_rhs>
-apply_op: /$HYPE\./o
+apply_op: /\.|$VOPEN\.$VCLOSE/o
incr: incr_op <commit> apply
| apply incr_op(?)
-incr_op: /$HYPE$INCR/o
+incr_op: /$INCR|$VOPEN$INCR$VCLOSE/o
pow: <leftop: incr pow_op prefix>
-pow_op: /$HYPE\*\*/o
+pow_op: /\*\*|$VOPEN\*\*$VCLOSE/o
prefix: filetest_op <commit> prefix
| prefix_op <commit> prefix
@@ -503,7 +507,7 @@
| pow
# prefix_op: '!' | '~' | '\\' | /-(?![->])/
-prefix_op: /$HYPE$PREFIX/o
+prefix_op: /$PREFIX|$VOPEN$PREFIX$VCLOSE/o
filetest_op: /$FILETEST/o
pair: namepart '=>' <commit> prefix
@@ -512,36 +516,36 @@
| prefix ('=>' prefix)(?)
match: <leftop: maybe_pair match_op maybe_pair>
-match_op: /$HYPE$MATCH/o
+match_op: /$MATCH|$VOPEN$MATCH$VCLOSE/o
muldiv: <leftop: match muldiv_op match>
# muldiv_op: '*' | '/' | '%' | 'x'
-muldiv_op: /$HYPE$MULDIV/o
+muldiv_op: /$MULDIV|$VOPEN$MULDIV$VCLOSE/o
addsub: <leftop: muldiv addsub_op muldiv>
# addsub_op: '+' | '-' | '_'
-addsub_op: /$HYPE$ADDSUB/o
+addsub_op: /$ADDSUB|$VOPEN$ADDSUB$VCLOSE/o
bitshift: <leftop: addsub bitshift_op addsub>
-bitshift_op: /$HYPE$BITSHIFT/o
+bitshift_op: /$BITSHIFT|$VOPEN$BITSHIFT$VCLOSE/o
compare: <leftop: bitshift compare_op bitshift>
-compare_op: /$HYPE$COMPARE/o
+compare_op: /$COMPARE|$VOPEN$COMPARE$VCLOSE/o
# compare_op: '<=>' | '<=' | '==' | '>=' | '<' | '>' | '!='
# | 'eq' | 'ge' | 'ne' | 'le' | 'lt' | 'gt' | 'cmp'
bitand: <leftop: compare bitand_op compare>
-bitand_op: /$HYPE&(?!&)/o
+bitand_op: /$BITAND|$VOPEN$BITAND$VCLOSE/o
bitor: <leftop: bitand bitor_op bitand>
-bitor_op: /$HYPE(?:\|(?!\|)|~(?!~))/o
+bitor_op: /$BITOR|$VOPEN$BITOR$VCLOSE/o
logand: <leftop: bitor logand_op bitor>
-logand_op: /$HYPE&&/o
+logand_op: /&&|$VOPEN&&$VCLOSE/o
logor: <leftop: logand logor_op logand>
-# logor_op: '||' | '~~' | '//'
-logor_op: /$HYPE$LOGOR/o
+# logor_op: '||' | '^^' | '//'
+logor_op: /$LOGOR|$VOPEN$LOGOR$VCLOSE/o
range: logor (range_op logor)(?)
range_op: '..'
@@ -571,7 +575,7 @@
| ternary
assign_rhs: assign_op scalar_expr
-assign_op: /$HYPE$ASSIGN/o
+assign_op: /$ASSIGN|$VOPEN$ASSIGN$VCLOSE/o
# assign_op: /[!:]?=/ <commit>
# | assignable_op <skip:''> '='
# assignable_op: '//'
@@ -595,11 +599,11 @@
adv_clause: /:(?!:)/ comma['scalar_expr']
log_AND: <leftop: adverb log_AND_op adverb>
-log_AND_op: /${HYPE}and\b/o
+log_AND_op: /and\b|${VOPEN}and\b$VCLOSE/o
log_OR: <leftop: log_AND log_OR_op log_AND>
# log_OR_op: 'or' | 'xor' | 'err'
-log_OR_op: /$HYPE$LOG_OR/o
+log_OR_op: /$LOG_OR|$VOPEN$LOG_OR$VCLOSE/o
expr: log_OR
Index: languages/perl6/P6C/Tree.pm
===================================================================
RCS file: /cvs/public/parrot/languages/perl6/P6C/Tree.pm,v
retrieving revision 1.24
diff -u -r1.24 Tree.pm
--- languages/perl6/P6C/Tree.pm 13 Oct 2003 17:00:41 -0000 1.24
+++ languages/perl6/P6C/Tree.pm 26 Nov 2003 23:29:11 -0000
@@ -124,7 +124,7 @@
# Having a separate rule for hyping is too expensive.
sub operator_tree {
local $_ = shift->[1];
- if (/^\^(.+)/) {
+ if (/^>>(.+)<</) {
return new P6C::hype op => $1;
}
return $_;
Index: languages/perl6/P6C/IMCC/Binop.pm
===================================================================
RCS file: /cvs/public/parrot/languages/perl6/P6C/IMCC/Binop.pm,v
retrieving revision 1.13
diff -u -r1.13 Binop.pm
--- languages/perl6/P6C/IMCC/Binop.pm 12 Sep 2002 14:34:42 -0000 1.13
+++ languages/perl6/P6C/IMCC/Binop.pm 26 Nov 2003 23:29:12 -0000
@@ -10,7 +10,7 @@
use vars qw(@ISA %EXPORT_TAGS @EXPORT_OK);
@ISA = qw(Exporter);
@EXPORT_OK = qw(do_pow do_logand do_logor do_defined do_concat do_repeat
- do_range do_smartmatch);
+ do_range do_smartmatch imcc_op);
%EXPORT_TAGS = (all => [EMAIL PROTECTED]);
sub do_pow ;
@@ -27,6 +27,16 @@
sub sm_hash_scalar ;
sub sm_expr_num ;
sub sm_expr_str ;
+
+# Remap operator names from P6 to IMCC.
+sub imcc_op {
+ my $op = shift;
+
+ return "~~" if ($op eq '^^');
+ return "." if ($op eq '_');
+
+ return $op;
+}
1;
Index: languages/perl6/P6C/IMCC/hype.pm
===================================================================
RCS file: /cvs/public/parrot/languages/perl6/P6C/IMCC/hype.pm,v
retrieving revision 1.4
diff -u -r1.4 hype.pm
--- languages/perl6/P6C/IMCC/hype.pm 26 Sep 2002 13:38:21 -0000 1.4
+++ languages/perl6/P6C/IMCC/hype.pm 26 Nov 2003 23:29:12 -0000
@@ -9,6 +9,7 @@
package P6C::IMCC::hype;
use SelfLoader;
use P6C::IMCC ':all';
+use P6C::IMCC::Binop 'imcc_op';
use P6C::Util qw(diag is_array_expr unimp);
require Exporter;
use vars qw(@ISA @EXPORT_OK);
@@ -20,7 +21,7 @@
use vars '%optype';
BEGIN {
- my %opmap = (int => [ qw(>> << | & ~ ~~)],
+ my %opmap = (int => [ qw(>> << | & ~ ^^)],
num => [ qw(+ - * / % **)],
str => [ qw(_) ]);
while (my ($t, $ops) = each %opmap) {
@@ -50,11 +51,12 @@
sub simple_hyped {
my ($op, $targ, $lindex, $rindex) = @_;
my $optype = $optype{$op} or unimp "Can't hype $op yet";
- $op = '.' if $op eq '_'; # XXX: should handle this elsewhere.
+ $op = imcc_op($op); # XXX: should handle this elsewhere.
my $ltmp = gentmp $optype;
my $rtmp = gentmp $optype;
my $dest = gentmp $optype;
return <<END;
+ # simple_hyped $op
$ltmp = $lindex
$rtmp = $rindex
$dest = $ltmp $op $rtmp
@@ -118,11 +120,11 @@
return hype_scalar_array(@_);
} else {
diag "Tried to hyper-operate two scalars";
- return simple_binary(@_);
+ return P6C::Binop::simple_binary(@_);
}
}
-# @xs ^op $y
+# @xs >>op<< $y
sub hype_array_scalar {
my ($op, $l, $r) = @_;
my $lval = $l->val;
@@ -141,7 +143,7 @@
return $op->{ctx} ? array_in_context($dest, $op->{ctx}) : $dest;
}
-# $x ^op @ys
+# $x >>op<< @ys
sub hype_scalar_array {
my ($op, $l, $r) = @_;
my $lval = $l->val;
@@ -160,7 +162,7 @@
return $op->{ctx} ? array_in_context($dest, $op->{ctx}) : $dest;
}
-# @xs ^op @ys
+# @xs >>op<< @ys
#
# Currently iterates over the number of elements in the _shorter_ of
# the two arrays, rather than the longer. This is useful for working
Index: languages/perl6/t/compiler/basic.t
===================================================================
RCS file: /cvs/public/parrot/languages/perl6/t/compiler/basic.t,v
retrieving revision 1.1
diff -u -r1.1 basic.t
--- languages/perl6/t/compiler/basic.t 13 Oct 2003 17:00:57 -0000 1.1
+++ languages/perl6/t/compiler/basic.t 26 Nov 2003 23:29:12 -0000
@@ -133,10 +133,10 @@
print1(2 && 0);
print1(0 && 2);
print1(0 && 0);
- print1(2 ~~ 3);
- print1(2 ~~ 0);
- print1(0 ~~ 2);
- print1(0 ~~ 0);
+ print1(2 ^^ 3);
+ print1(2 ^^ 0);
+ print1(0 ^^ 2);
+ print1(0 ^^ 0);
my $x;
print1($x // 0);
print1(0 // $x);
@@ -154,8 +154,8 @@
0
-1
-1
+2
+2
0
0
0
Index: languages/perl6/t/compiler/globals.t
===================================================================
RCS file: /cvs/public/parrot/languages/perl6/t/compiler/globals.t,v
retrieving revision 1.1
diff -u -r1.1 globals.t
--- languages/perl6/t/compiler/globals.t 13 Oct 2003 17:00:57 -0000 1.1
+++ languages/perl6/t/compiler/globals.t 26 Nov 2003 23:29:12 -0000
@@ -6,7 +6,7 @@
##############################
output_is(<<'CODE', <<'OUT', "globals");
sub foo() {
- print $x, " is ", @xs ^_ ' ', "\n";
+ print $x, " is ", @xs >>_<< ' ', "\n";
$y = 0;
for @xs { $y = $y + $_ }
}
Index: languages/perl6/t/compiler/hyper.t
===================================================================
RCS file: /cvs/public/parrot/languages/perl6/t/compiler/hyper.t,v
retrieving revision 1.2
diff -u -r1.2 hyper.t
--- languages/perl6/t/compiler/hyper.t 1 Nov 2003 12:07:09 -0000 1.2
+++ languages/perl6/t/compiler/hyper.t 26 Nov 2003 23:29:13 -0000
@@ -13,13 +13,13 @@
my @x = (3,4);
my @b = (5,6);
my $i = 2;
- parray @a ^* @x ^+ @b;
- parray $i ^* @x ^+ @b;
- parray @a * @x ^+ @b;
- parray 2 * 3 ^+ @b;
-# print1(@a ^* @x + @b); # Array math not in 0.0.7
+ parray @a >>*<< @x >>+<< @b;
+ parray $i >>*<< @x >>+<< @b;
+ parray @a * @x >>+<< @b;
+ parray 2 * 3 >>+<< @b;
+# print1(@a >>*<< @x + @b); # Array math not in 0.0.7
# IMCC clobbers too many registers with this:
-# @y = @a ^<< @a;
+# @y = @a >><<<< @a;
# print1('(' _ @y[0] _ ', ' _ @y[1] _ ')');
}
CODE
@@ -35,7 +35,7 @@
my $a = 2.1;
my @x = 1..1000;
my @b = 1001..2000;
- my @c = $a ^* @x ^+ @b;
+ my @c = $a >>*<< @x >>+<< @b;
print1(@c[0]);
print1(@c[9]);
print1(@c[99]);
@@ -61,11 +61,11 @@
parray(@c);
@c = @a || @b;
parray(@c);
- @c = @a ^&& @b;
+ @c = @a >>&&<< @b;
parray(@c);
- @c = @a ^|| @b;
+ @c = @a >>||<< @b;
parray(@c);
- @c = @a ^~~ @b;
+ @c = @a >>^^<< @b;
parray(@c);
}
CODE
@@ -81,18 +81,18 @@
sub main () {
my @a = (1..3);
my @b = (4..9);
- my @c = @a ^+ @b;
- print @c ^_ ' ',"x\n";
- @c = @b ^+ @a;
- print @c ^_ ' ',"x\n";
- @b = @b ^+ @a;
- print @b ^_ ' ',"x\n";
+ my @c = @a >>+<< @b;
+ print @c >>_<< ' ',"x\n";
+ @c = @b >>+<< @a;
+ print @c >>_<< ' ',"x\n";
+ @b = @b >>+<< @a;
+ print @b >>_<< ' ',"x\n";
@b = (4..9);
- @b ^+= @a;
- print @b ^_ ' ',"x\n";
+ @b >>+=<< @a;
+ print @b >>_<< ' ',"x\n";
@b = (4..9);
- @a ^+= @b;
- print @a ^_ ' ',"x\n";
+ @a >>+=<< @b;
+ print @a >>_<< ' ',"x\n";
}
CODE
5 7 9 7 8 9 x
@@ -108,31 +108,31 @@
my @b = 5..6;
my @c;
@c = @a;
[EMAIL PROTECTED] ^+= @b;
-print @c ^_ ' ',"x\n";
[EMAIL PROTECTED] >>+=<< @b;
+print @c >>_<< ' ',"x\n";
@c = @b;
[EMAIL PROTECTED] ^+= @a;
-print @c ^_ ' ',"x\n";
[EMAIL PROTECTED] >>+=<< @a;
+print @c >>_<< ' ',"x\n";
@c = @a;
[EMAIL PROTECTED] ^*= @b;
-print @c ^_ ' ',"x\n";
[EMAIL PROTECTED] >>*=<< @b;
+print @c >>_<< ' ',"x\n";
@c = @a;
[EMAIL PROTECTED] ^**= @b;
-print @c ^_ ' ',"x\n";
[EMAIL PROTECTED] >>**=<< @b;
+print @c >>_<< ' ',"x\n";
@c = @a;
[EMAIL PROTECTED] ^/= @b;
-print @c ^_ ' ',"x\n";
[EMAIL PROTECTED] >>/=<< @b;
+print @c >>_<< ' ',"x\n";
@c = @b;
[EMAIL PROTECTED] ^%= @a;
-print @c ^_ ' ',"x\n";
[EMAIL PROTECTED] >>%=<< @a;
+print @c >>_<< ' ',"x\n";
@c = @b;
[EMAIL PROTECTED] ^-= @a;
-print @c ^_ ' ',"x\n";
[EMAIL PROTECTED] >>-=<< @a;
+print @c >>_<< ' ',"x\n";
CODE
/7 9 4 x
7 9 4 x
Index: languages/perl6/t/compiler/qsort.t
===================================================================
RCS file: /cvs/public/parrot/languages/perl6/t/compiler/qsort.t,v
retrieving revision 1.1
diff -u -r1.1 qsort.t
--- languages/perl6/t/compiler/qsort.t 21 Jul 2002 16:09:27 -0000 1.1
+++ languages/perl6/t/compiler/qsort.t 26 Nov 2003 23:29:13 -0000
@@ -27,10 +27,10 @@
sub main() {
my @a = 1..10;
qsort @a, 0, @a - 1;
- print @a ^_ "\n";
+ print @a >>_<< "\n";
@a = (10,9,8,7,6,5,4,3,2,1);
qsort @a, 0, @a - 1;
- print @a ^_ "\n";
+ print @a >>_<< "\n";
}
CODE
10
