From 63f4e9a3ead9297fa38607211eb484e4acb6f7ed Mon Sep 17 00:00:00 2001
From: Stefan O'Rear <stefanor@cox.net>
Date: Sun, 26 Dec 2010 23:55:08 -0800
Subject: [PATCH] Add &&= and company

---
 src/Niecza/Actions.pm | 42 ++++++++++++++++++++++++++----------------
 src/Op.pm             | 37 +++++++++++++++++++++++++++++++++++++
 test2.pl              | 11 +++++++++++
 3 files changed, 74 insertions(+), 16 deletions(-)

diff --git a/src/Niecza/Actions.pm b/src/Niecza/Actions.pm
index b00a894b..a235f8aa 100644
--- a/src/Niecza/Actions.pm
+++ b/src/Niecza/Actions.pm
@@ -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;
diff --git a/src/Op.pm b/src/Op.pm
index 94995952..4d47dff8 100644
--- a/src/Op.pm
+++ b/src/Op.pm
@@ -442,6 +442,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;
diff --git a/test2.pl b/test2.pl
index 58fc2ed4..2dec9ded 100644
--- a/test2.pl
+++ b/test2.pl
@@ -2,6 +2,17 @@
 use Test;
 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;