Permalink
Browse files

Add &&= and company

  • Loading branch information...
1 parent 4d1cb46 commit 63f4e9a3ead9297fa38607211eb484e4acb6f7ed @sorear committed Dec 27, 2010
Showing with 74 additions and 16 deletions.
  1. +26 −16 src/Niecza/Actions.pm
  2. +37 −0 src/Op.pm
  3. +11 −0 test2.pl
View
@@ -1208,9 +1208,16 @@ sub infixish { my ($cl, $M) = @_;
}
}
+my %loose2tight = (
+ '&&' => '&&', '||' => '||', '//' => '//', 'andthen' => 'andthen',
+ 'orelse' => '//', 'and' => '&&', 'or' => '||',
+);
+
sub INFIX { my ($cl, $M) = @_;
my $fn = $M->{infix}{_ast};
- my $s = $fn->isa('Op::Lexical') ? $fn->name : '';
+ my $s = $fn->isa('Op::Lexical') ? $fn->name :
+ ($fn->isa('Op::CallSub') && $fn->invocant->isa('Op::Lexical')) ?
+ $fn->invocant->name : '';
my ($st,$l,$r) = $cl->whatever_precheck($s, $M->{left}{_ast},
$M->{right}{_ast});
@@ -1229,21 +1236,28 @@ sub INFIX { my ($cl, $M) = @_;
push @r, $l->isa('Op::SimpleParcel') ? @{ $l->items } : ($l);
push @r, $r->isa('Op::SimpleParcel') ? @{ $r->items } : ($r);
$M->{_ast} = Op::SimpleParcel->new(items => \@r);
+ } elsif ($s eq '&assignop' && $fn->args->[0]->isa('Op::Lexical') &&
+ ($fn->args->[0]->name =~ /&infix:<(.*)>/) &&
+ $loose2tight{$1}) {
+ $M->{_ast} = Op::ShortCircuitAssign->new(node($M),
+ kind => $loose2tight{$1}, lhs => $l, rhs => $r);
} else {
$M->{_ast} = Op::CallSub->new(node($M), invocant => $fn,
positionals => [ $l, $r ]);
- if ($s eq '&infix:<=>' && $l->isa('Op::Lexical') && $l->state_decl) {
- # Assignments (and assign metaops, but we don't do that yet) to has
- # and state declarators are rewritten into an appropriate phaser
- my $cv = $cl->gensym;
- $M->{_ast} = Op::StatementList->new(node($M), children => [
- Op::Start->new(condvar => $cv, body => $M->{_ast}),
- Op::Lexical->new(name => $l->name)]);
- }
- elsif ($s eq '&infix:<=>' && $l->isa('Op::ConstantDecl') && !$l->init) {
- $l->init($r);
- $M->{_ast} = $l;
+ if ($s eq '&infix:<=>' || $s eq '&assignop') {
+ # Assignments to has and state declarators are rewritten into
+ # an appropriate phaser
+ if ($l->isa('Op::Lexical') && $l->state_decl) {
+ my $cv = $cl->gensym;
+ $M->{_ast} = Op::StatementList->new(node($M), children => [
+ Op::Start->new(condvar => $cv, body => $M->{_ast}),
+ Op::Lexical->new(name => $l->name)]);
+ }
+ elsif ($l->isa('Op::ConstantDecl') && !$l->init) {
+ $l->init($r);
+ $M->{_ast} = $l;
+ }
}
}
$M->{_ast} = $cl->whatever_postcheck($M, $st, $M->{_ast});
@@ -1276,10 +1290,6 @@ sub CHAIN { my ($cl, $M) = @_;
$M->{_ast} = $cl->whatever_postcheck($M, $st, $M->{_ast});
}
-my %loose2tight = (
- '&&' => '&&', '||' => '||', '//' => '//', 'andthen' => 'andthen',
- 'orelse' => '//', 'and' => '&&', 'or' => '||',
-);
sub LIST { my ($cl, $M) = @_;
if ($M->isa('STD::Regex')) {
goto &LISTrx;
View
@@ -443,6 +443,43 @@ use CgOp;
}
{
+ package Op::ShortCircuitAssign;
+ use Moose;
+ extends 'Op';
+
+ has kind => (isa => 'Str', is => 'ro', required => 1);
+ has lhs => (isa => 'Op', is => 'ro', required => 1);
+ has rhs => (isa => 'Op', is => 'ro', required => 1);
+ sub zyg { $_[0]->lhs, $_[0]->rhs }
+
+ sub code {
+ my ($self, $body) = @_;
+
+ my $sym = Niecza::Actions->gensym;
+ my $assn = CgOp::assign(CgOp::letvar($sym), $self->rhs->cgop($body));
+ my $cond = CgOp::letvar($sym);
+ my $cassn;
+
+ given ($self->kind) {
+ when ("&&") {
+ $cassn = CgOp::ternary(CgOp::obj_getbool($cond), $assn, CgOp::noop);
+ }
+ when ("||") {
+ $cassn = CgOp::ternary(CgOp::obj_getbool($cond), CgOp::noop, $assn);
+ }
+ when ("andthen") {
+ $cassn = CgOp::ternary(CgOp::obj_getdef($cond), $assn, CgOp::noop);
+ }
+ when ("//") {
+ $cassn = CgOp::ternary(CgOp::obj_getdef($cond), CgOp::noop, $assn);
+ }
+ }
+
+ CgOp::letn($sym, $self->lhs->code($body), $cassn, $cond);
+ }
+}
+
+{
package Op::StringLiteral;
use Moose;
extends 'Op';
View
@@ -3,6 +3,17 @@
use MONKEY_TYPING;
{
+ my $a = 3; $a &&= 4; is $a, 4, '&&= works (T)';
+ my $b = 0; $b &&= 4; is $b, 0, '&&= works (F)';
+ my $c = 3; $c ||= 4; is $c, 3, '||= works (T)';
+ my $d = 0; $d ||= 4; is $d, 4, '||= works (F)';
+ my $e = 0; $e andthen= 4; is $e, 4, 'andthen= works (D)';
+ my $f = Any; $f andthen= 4; is $f, Any, 'andthen= works (U)';
+ my $g = 0; $g //= 4; is $g, 0, '//= works (D)';
+ my $h = Any; $h //= 4; is $h, 4, '//= works (U)';
+}
+
+{
my $str = '';
$str ~= 1;
INIT $str ~= 2;

0 comments on commit 63f4e9a

Please sign in to comment.