diff --git a/lib/Kernel.cs b/lib/Kernel.cs index 856a7b5a..236f772e 100644 --- a/lib/Kernel.cs +++ b/lib/Kernel.cs @@ -303,6 +303,11 @@ public class Frame: IP6 { } } + public class NieczaException: Exception { + public NieczaException(string detail) : base(detail) {} + public NieczaException() : base() {} + } + // NOT IP6; these things should only be exposed through a ClassHOW-like // façade public class DynMetaObject { @@ -329,6 +334,8 @@ public List superclasses = new List(); public Dictionary local = new Dictionary(); + public Dictionary priv + = new Dictionary(); public List local_attr = new List(); public Dictionary slotMap = new Dictionary(); @@ -456,6 +463,16 @@ public List superclasses Invalidate(); } + public void AddPrivateMethod(string name, IP6 code) { + priv[name] = code; + } + + public IP6 GetPrivateMethod(string name) { + IP6 code = priv[name]; + if (code == null) { throw new NieczaException("private method lookup failed for " + name + " in class " + this.name); } + return code; + } + public void AddAttribute(string name) { local_attr.Add(name); Invalidate(); diff --git a/lib/SAFE.setting b/lib/SAFE.setting index 74a119c6..89829a3d 100644 --- a/lib/SAFE.setting +++ b/lib/SAFE.setting @@ -341,7 +341,7 @@ my class List is Cool { #| Takes an object and applies whatever semantics the List subclass #| needs to apply on stuff out of the iterator stack - method !elem is rawcall { Q:CgOp { (pos 1) } } + method _elem is rawcall { Q:CgOp { (pos 1) } } sub count-items($self) { Q:CgOp { (box Num (cast num (vvarlist_count (getslot items vvarlist (@ {$self}))))) @@ -384,7 +384,7 @@ my class List is Cool { (ternary (obj_isa (@ (l v)) (l ItMo)) (vvarlist_unshiftn (l rest) (unbox fvarlist (@ (methodcall (l v) reify)))) - (vvarlist_push (l items) (methodcall {self} !elem (l v))))))) + (vvarlist_push (l items) (methodcall {self} _elem (l v))))))) (box Bool (>= (vvarlist_count (l items)) (l nr)))) } } @@ -446,7 +446,7 @@ my class List is Cool { # exactly like List, but flattens, and with "is copy" semantics on stuff my class Seq is List { - method !elem($x) { my $y = $x; $y } + method _elem($x) { my $y = $x; $y } method Seq { self } } @@ -482,9 +482,9 @@ my class Array is List { } method at-pos($ix) { - self!fill($ix+1) - ?? self!item-at-pos($ix) - !! Any!butWHENCE(sub () is rawcall { + self!List::fill($ix+1) + ?? self!List::item-at-pos($ix) + !! Any!Any::butWHENCE(sub () is rawcall { self!extend($ix, Q:CgOp { (pos 0) }); }); } @@ -514,7 +514,7 @@ my class Hash { ?? Q:CgOp { (varhash_getindex [unbox str (@ {$key.Str})] [unbox varhash (@ {self})]) - } !! Any!butWHENCE({ self!extend($key, Q:CgOp { (pos 0) }) }); + } !! Any!Any::butWHENCE({ self!extend($key, Q:CgOp { (pos 0) }) }); } } @@ -540,12 +540,12 @@ sub postcircumfix:<[ ]> is rawcall { (Q:CgOp { (pos 0) }).defined ?? (Q:CgOp { (pos 0) }).at-pos($index) - !! Any!butWHENCE(sub () is rawcall { + !! Any!Any::butWHENCE(sub () is rawcall { my $ar := Q:CgOp { (getindex (int 0) (getfield pos (getfield outer (callframe)))) }; $ar.defined && die("Autovivification collision"); $ar = Array.new; - $ar!extend($index, Q:CgOp { (pos 0) }); + $ar!Array::extend($index, Q:CgOp { (pos 0) }); }); } @@ -554,12 +554,12 @@ sub postcircumfix:<{ }> is rawcall { (Q:CgOp { (pos 0) }).defined ?? (Q:CgOp { (pos 0) }).at-key($key) - !! Any!butWHENCE(sub () is rawcall { + !! Any!Any::butWHENCE(sub () is rawcall { my $ar := Q:CgOp { (getindex (int 0) (getfield pos (getfield outer (callframe)))) }; $ar.defined && die("Autovivification collision"); $ar = Hash.new; - $ar!extend($key, Q:CgOp { (pos 0) }); + $ar!Hash::extend($key, Q:CgOp { (pos 0) }); }); } diff --git a/src/CLRTypes.pm b/src/CLRTypes.pm index bb6bbe07..b81979de 100644 --- a/src/CLRTypes.pm +++ b/src/CLRTypes.pm @@ -28,6 +28,8 @@ my %typedata = ( AddMethod => [m => 'Void'], AddSuperclass=> [m => 'Void'], AddAttribute => [m => 'Void'], + AddPrivateMethod => [m => 'Void'], + GetPrivateMethod => [m => 'IP6'], typeObject => [f => 'IP6'], how => [f => 'IP6'], name => [f => 'String'] }, diff --git a/src/CSharpBackend.pm b/src/CSharpBackend.pm index bdd4749a..f4ecc1af 100644 --- a/src/CSharpBackend.pm +++ b/src/CSharpBackend.pm @@ -191,7 +191,8 @@ sub pkg3 { return unless $_->isa('Metamodel::Class'); my $p = $_->{peer}{mo}; for my $m (@{ $_->methods }) { - push @thaw, CgOp::rawcall(CgOp::rawsget($p), 'AddMethod', + push @thaw, CgOp::rawcall(CgOp::rawsget($p), + ($m->private ? 'AddPrivateMethod' : 'AddMethod'), CgOp::clr_string($m->name), CgOp::rawsget($unit->deref($m->body)->{peer}{ps})); } @@ -330,15 +331,15 @@ sub codegen_sub { my $ops; # TODO: Bind a return value here to catch non-ro sub use if ($_->gather_hack) { - $ops = CgOp::prog(@enter, CgOp::sink($_->code->cgop), + $ops = CgOp::prog(@enter, CgOp::sink($_->code->cgop($_)), CgOp::rawsccall('Kernel.Take', CgOp::scopedlex('EMPTY'))); } elsif ($_->returnable && defined($_->signature)) { $ops = CgOp::prog(@enter, CgOp::return(CgOp::span("rstart", "rend", - $_->code->cgop)), + $_->code->cgop($_))), CgOp::ehspan(4, undef, 0, "rstart", "rend", "rend")); } else { - $ops = CgOp::prog(@enter, CgOp::return($_->code->cgop)); + $ops = CgOp::prog(@enter, CgOp::return($_->code->cgop($_))); } local %haslet; diff --git a/src/Metamodel.pm b/src/Metamodel.pm index 9d9cc9ee..9b2ed751 100644 --- a/src/Metamodel.pm +++ b/src/Metamodel.pm @@ -143,8 +143,9 @@ our $unit; } sub add_method { - my ($self, $name, $body) = @_; - push @{ $self->methods }, Metamodel::Method->new(name => $name, body => $body); + my ($self, $type, $name, $body) = @_; + push @{ $self->methods }, Metamodel::Method->new(name => $name, + body => $body, private => ($type eq '!')); } sub push_multi_regex { @@ -188,8 +189,9 @@ our $unit; package Metamodel::Method; use Moose; - has name => (isa => 'Str', is => 'ro'); - has body => (is => 'ro'); + has name => (isa => 'Str', is => 'ro', required => 1); + has private => (isa => 'Bool', is => 'ro', required => 1); + has body => (is => 'ro', required => 1); no Moose; __PACKAGE__->meta->make_immutable; @@ -312,6 +314,7 @@ our $unit; has gather_hack => (isa => 'Bool', is => 'ro', default => 0); has strong_used => (isa => 'Bool', is => 'rw', default => 0); has body_of => (isa => 'Maybe[ArrayRef]', is => 'ro'); + has in_class => (isa => 'Maybe[ArrayRef]', is => 'ro'); has cur_pkg => (isa => 'Maybe[ArrayRef[Str]]', is => 'ro'); has name => (isa => 'Str', is => 'ro', default => 'ANON'); has returnable => (isa => 'Bool', is => 'ro', default => 0); @@ -649,6 +652,8 @@ sub Body::begin { unit => $unit, outer => $top, body_of => $args{body_of}, + in_class => $args{body_of} // (@opensubs ? $opensubs[-1]->in_class : + undef), cur_pkg => $args{cur_pkg} // (@opensubs ? $opensubs[-1]->cur_pkg : [ 'GLOBAL' ]), # cur_pkg does NOT propagate down from settings augmenting => $args{augmenting}, @@ -754,6 +759,21 @@ sub Op::Lexical::begin { } } +sub Op::CallMethod::begin { + my $self = shift; + + $self->Op::begin; + if ($self->private) { + if ($self->ppath) { + $self->pclass($unit->get_stash(@{ $opensubs[-1]->find_pkg($self->ppath) })->obj); + } elsif ($opensubs[-1]->in_class) { + $self->pclass($opensubs[-1]->in_class); + } else { + die "unable to resolve class of reference for method"; + } + } +} + sub Op::PackageVar::begin { my $self = shift; @@ -786,7 +806,7 @@ sub Op::Attribute::begin { $opensubs[-1]->create_static_pad; # for protosub instance $nb->strong_used(1); $opensubs[-1]->add_my_sub($self->name . '!a', $nb); - $ns->add_method($self->name, $unit->make_ref($nb)); + $ns->add_method('', $self->name, $unit->make_ref($nb)); } } @@ -814,7 +834,7 @@ sub Op::SubDef::begin { if (defined($self->method_too)) { $unit->deref($opensubs[-1]->body_of) - ->add_method($self->method_too, $r); + ->add_method(@{ $self->method_too }, $r); } if (defined($self->proto_too)) { diff --git a/src/Niecza/Actions.pm b/src/Niecza/Actions.pm index df5fe159..af6007f3 100644 --- a/src/Niecza/Actions.pm +++ b/src/Niecza/Actions.pm @@ -380,7 +380,7 @@ sub regex_def { my ($cl, $M) = @_; $ast = Optimizer::RxSimple::run($ast); $M->{_ast} = Op::SubDef->new( var => $var, - method_too => ($scope eq 'has' ? $name : undef), + method_too => ($scope eq 'has' ? ['', $name] : undef), proto_too => ($scope eq 'has' ? $unsymtext : undef), body => Body->new( ltm => $lad, @@ -1091,10 +1091,15 @@ sub POSTFIX { my ($cl, $M) = @_; name => $op->{metamethod}, args => $op->{args} // []); } elsif ($op->{name}) { + if ($op->{path} && !$op->{private}) { + $M->sorry("Qualified references to non-private methods NYI"); + } $M->{_ast} = Op::CallMethod->new(node($M), receiver => $arg, - name => ($op->{private} ? '!' . $op->{name} : $op->{name}), - args => $op->{args} // []); + private => $op->{private}, + ppath => $op->{path}, + name => $op->{name}, + args => $op->{args} // []); } elsif ($op->{postcall}) { if (@{ $op->{postcall} } > 1) { $M->sorry("Slicels NYI"); @@ -1190,8 +1195,10 @@ sub PRE { } sub methodop { my ($cl, $M) = @_; my %r; - $r{name} = $cl->unqual_longname($M->{longname}, - "Qualified method calls NYI") if $M->{longname}; + if ($M->{longname}) { + my $c = $cl->mangle_longname($M->{longname}); + @r{"name", "path"} = @$c{"name", "path"}; + } $r{quote} = $M->{quote}{_ast} if $M->{quote}; $r{ref} = $cl->do_variable_reference($M, $M->{variable}{_ast}) if $M->{variable}; @@ -2379,7 +2386,7 @@ sub method_def { my ($cl, $M) = @_; signature => $sig ? $sig->for_method : undef); $M->{_ast} = $cl->block_to_closure($M, $bl, outer_key => $sym, - method_too => ($scope ne 'anon' ? "$type$name" : undef)); + method_too => ($scope ne 'anon' ? [ $type, $name ] : undef)); } sub block { my ($cl, $M) = @_; diff --git a/src/Op.pm b/src/Op.pm index e8abe96b..c10fa0c2 100644 --- a/src/Op.pm +++ b/src/Op.pm @@ -185,12 +185,20 @@ use CgOp; has receiver => (isa => 'Op', is => 'ro', required => 1); has name => (isa => 'Str', is => 'ro', required => 1); + has private => (isa => 'Bool', is => 'ro', default => 0); + has ppath => (isa => 'Maybe[ArrayRef[Str]]', is => 'ro'); + has pclass => (isa => 'ArrayRef', is => 'rw'); sub zyg { $_[0]->receiver, $_[0]->SUPER::zyg } sub code { my ($self, $body) = @_; - CgOp::methodcall($self->receiver->cgop($body), - $self->name, $self->argblock($body)); + if ($self->private) { + # XXX encapsulation break + CgOp::subcall(CgOp::rawcall(CgOp::rawsget($body->unit->deref($self->pclass)->{peer}{mo}), "GetPrivateMethod", CgOp::clr_string($self->name)), $self->receiver->cgop($body), $self->argblock($body)); + } else { + CgOp::methodcall($self->receiver->cgop($body), + $self->name, $self->argblock($body)); + } } __PACKAGE__->meta->make_immutable; @@ -764,7 +772,7 @@ use CgOp; has var => (isa => 'Str', is => 'ro', required => 1); has body => (isa => 'Body', is => 'ro', required => 1); - has method_too => (isa => 'Maybe[Str]', is => 'ro', required => 0); + has method_too => (isa => 'Maybe[ArrayRef[Str]]', is => 'ro'); has proto_too => (isa => 'Maybe[Str]', is => 'ro', required => 0); has exports => (isa => 'ArrayRef[Str]', is => 'ro', default => sub { [] }); # Is candidate for beta-optimization. Not compatible with method_too, diff --git a/test.pl b/test.pl index f224fdd7..90b4e1a1 100644 --- a/test.pl +++ b/test.pl @@ -464,11 +464,11 @@ my $d = 0; my $e = 0; - (Any!butWHENCE({ $a = 1 })); - my $x := (Any!butWHENCE({ $b = 1 })); #OK not used - my $y ::= (Any!butWHENCE({ $c = 1 })); #OK not used - my $z = (Any!butWHENCE({ $d = 1 })); #OK not used - (Any!butWHENCE({ $e = 1 })) = 2; + (Any!Any::butWHENCE({ $a = 1 })); + my $x := (Any!Any::butWHENCE({ $b = 1 })); #OK not used + my $y ::= (Any!Any::butWHENCE({ $c = 1 })); #OK not used + my $z = (Any!Any::butWHENCE({ $d = 1 })); #OK not used + (Any!Any::butWHENCE({ $e = 1 })) = 2; ok !$a, "no autovivification in void context"; ok $b, "autovivification after rw bind";