Implement the is rw parameter trait

sorear · Oct 5, 2010 · 2dd2dee · 2dd2dee
1 parent 94c51c8
commit 2dd2dee
Show file tree

Hide file tree

Showing 3 changed files with 23 additions and 14 deletions.
diff --git a/lib/SAFE.setting b/lib/SAFE.setting
@@ -3,9 +3,8 @@ my module SAFE;
 
 # Fundamental types {{{
 my class Mu {
-    # rawcall to avoid putting a rw binding on self... TODO
-    method defined is rawcall {
-        Q:CgOp { (box Bool (obj_is_defined (@ (pos 0)))) }
+    method defined() {
+        Q:CgOp { (box Bool (obj_is_defined (@ {self}))) }
     }
     method head() { @(self).head }
     method Bool() { self.defined }
@@ -228,10 +227,10 @@ sub infix:<=> is rawcall { Q:CgOp { (prog [assign (pos 0) (pos 1)] (pos 0)) } }
 
 # Buglet in STD: standard infix operators look custom inside the setting, and
 # forget their precedence.
-sub prefix:<-->($v) { $v = ($v - 1); $v }
-sub prefix:<++>($v) { $v = ($v + 1); $v }
-sub postfix:<-->($v) { my $old = $v; $v = ($v - 1); $old }
-sub postfix:<++>($v) { my $old = $v; $v = ($v + 1); $old }
+sub prefix:<-->($v is rw) { $v = ($v - 1); $v }
+sub prefix:<++>($v is rw) { $v = ($v + 1); $v }
+sub postfix:<-->($v is rw) { my $old = $v; $v = ($v - 1); $old }
+sub postfix:<++>($v is rw) { my $old = $v; $v = ($v + 1); $old }
 
 sub prefix:<~>($v) { $v.Str } # should be Stringy
 sub prefix:<?>($v) { $v.Bool }

diff --git a/src/Niecza/Actions.pm b/src/Niecza/Actions.pm
@@ -1591,9 +1591,13 @@ sub param_var { my ($cl, $M) = @_;
 
 # :: Sig::Parameter
 sub parameter { my ($cl, $M) = @_;
-    if (@{ $M->{trait} } > 0) {
-        $M->sorry('Parameter traits NYI');
-        return;
+    my $rw;
+
+    for (@{ $M->{trait} }) {
+        if ($_->{_ast}{rw}) { $rw = 1 }
+        else {
+            $M->sorry('Unhandled trait ' . (keys(%{ $_->{_ast} }))[0]);
+        }
     }
 
     if (@{ $M->{post_constraint} } > 0) {
@@ -1625,7 +1629,8 @@ sub parameter { my ($cl, $M) = @_;
     my $p = $M->{param_var} // $M->{named_param};
 
     $M->{_ast} = Sig::Parameter->new(name => $M->Str, default => $default,
-        optional => $optional, slurpy => $slurpy, %{ $p->{_ast} });
+        optional => $optional, slurpy => $slurpy, readonly => !$rw,
+        %{ $p->{_ast} });
 }
 
 # signatures exist in several syntactic contexts so just make an object for now
@@ -2195,6 +2200,8 @@ sub trait_mod__S_is { my ($cl, $M) = @_;
         $noparm = 'Export tags NYI';
     } elsif ($trait eq 'rawcall') {
         $M->{_ast} = { nobinder => 1 };
+    } elsif ($trait eq 'rw') {
+        $M->{_ast} = { rw => 1 };
     } else {
         $M->sorry('Unhandled trait ' . $trait);
     }

diff --git a/src/Sig.pm b/src/Sig.pm
@@ -18,6 +18,7 @@ use 5.010;
     has list => (is => 'ro', isa => 'Bool', default => 0);
     has hash => (is => 'ro', isa => 'Bool', default => 0);
     has type => (is => 'ro', isa => 'Str', default => 'Any');
+    has tclass => (is => 'rw', isa => 'ArrayRef');
 
     sub slurpy_get {
         my ($self) = @_;
@@ -143,19 +144,21 @@ use 5.010;
 
     sub for_method {
         my $self = shift;
-        my $sp = Sig::Parameter->new(slot => 'self', name => 'self');
+        my $sp = Sig::Parameter->new(slot => 'self', name => 'self',
+            readonly => 1);
         Sig->new(params => [ $sp, @{ $self->params } ]);
     }
 
     sub for_regex {
         my ($self) = @_;
-        my $sp = Sig::Parameter->new(slot => '$¢', name => '$¢');
+        my $sp = Sig::Parameter->new(slot => '$¢', name => '$¢', readonly => 1);
         Sig->new(params => [ $sp, @{ $self->params } ]);
     }
 
     sub simple {
         my ($class, @names) = @_;
-        Sig->new(params => [map { Sig::Parameter->new(slot => $_, name => $_)
+        Sig->new(params => [map { Sig::Parameter->new(slot => $_, name => $_,
+                readonly => 1)
             } @names]);
     }