Implement binding

sorear · Jul 13, 2010 · 8c7971e · 8c7971e
1 parent 332b344
commit 8c7971e
Show file tree

Hide file tree

Showing 3 changed files with 51 additions and 4 deletions.
diff --git a/CodeGen.pm b/CodeGen.pm
@@ -117,7 +117,7 @@ use 5.010;
         }
     }
 
-    sub _swap {
+    sub swap {
         my ($self) = @_;
         $self->_undercheck(2);
         $self->_overcheck(1);
@@ -332,11 +332,22 @@ use 5.010;
         $self->_cpscall(undef, "$c.lv.container.Store(th, $v)");
     }
 
+    sub dup {
+        my ($self) = @_;
+        my $c = $self->_peek;
+        $self->_push($self->stacktype->[-1], $c);
+    }
+
+    sub drop {
+        my ($self) = @_;
+        $self->_pop;
+    }
+
     sub dup_fetch {
         my ($self) = @_;
         my $c = $self->_peek;
         $self->_cpscall('IP6', "$c.lv.container.Fetch(th)");
-        $self->_swap;
+        $self->swap;
     }
 
     sub pos {
@@ -496,9 +507,9 @@ use 5.010;
 
     sub attr_set {
         my ($self, $f) = @_;
-        $self->_swap;
+        $self->swap;
         $self->attr_var($f);
-        $self->_swap;
+        $self->swap;
         $self->store;
     }
 

diff --git a/Niecza/Actions.pm b/Niecza/Actions.pm
@@ -195,6 +195,12 @@ sub infixish { my ($cl, $M) = @_;
     $M->sorry("Adverbs NYI") if $M->{colonpair};
 }
 sub INFIX { my ($cl, $M) = @_;
+    if ($M->{infix}{sym} eq ':=') { #XXX macro
+        $M->{_ast} = Op::Bind->new(
+            lhs => $M->{left}{_ast}, rhs => $M->{right}{_ast},
+            readonly => 0);
+        return;
+    }
     $M->{_ast} = Op::CallSub->new(
         invocant => Op::Lexical->new(name => '&infix:<' . $M->{infix}{sym} . '>'),
         positionals => [ $M->{left}{_ast}, $M->{right}{_ast} ]);

diff --git a/Op.pm b/Op.pm
@@ -265,6 +265,36 @@ use 5.010;
     no Moose;
 }
 
+{
+    package Op::Bind;
+    use Moose;
+    extends 'Op';
+
+    has lhs => (isa => 'Op', is => 'ro', required => 1);
+    has rhs => (isa => 'Op', is => 'ro', required => 1);
+    has readonly => (isa => 'Bool', is => 'ro', required => 1);
+
+    sub item_cg {
+        my ($self, $cg, $body) = @_;
+        $self->lhs->item_cg($cg, $body);
+        $cg->dup;
+        $self->rhs->item_cg($cg, $body);
+        $cg->clr_field_get('lv');
+        $cg->clr_field_set('lv');
+    }
+
+    sub void_cg {
+        my ($self, $cg, $body) = @_;
+        $self->lhs->item_cg($cg, $body);
+        $self->rhs->item_cg($cg, $body);
+        $cg->clr_field_get('lv');
+        $cg->clr_field_set('lv');
+    }
+
+    __PACKAGE__->meta->make_immutable;
+    no Moose;
+}
+
 {
     package Op::Lexical;
     use Moose;