From 3b8eaf37dcb11962fe8b2f348b951d04ef5acfab Mon Sep 17 00:00:00 2001 From: Stefan O'Rear Date: Sun, 19 Sep 2010 14:35:35 -0700 Subject: [PATCH] [mm] Implement accessor generation --- src/Decl.pm | 236 ----------------------------------------------- src/Metamodel.pm | 21 ++++- src/Op.pm | 30 ------ 3 files changed, 16 insertions(+), 271 deletions(-) diff --git a/src/Decl.pm b/src/Decl.pm index 7c51c404..5baa9498 100644 --- a/src/Decl.pm +++ b/src/Decl.pm @@ -24,33 +24,6 @@ use CgOp; no Moose; } -{ - package Decl::PreInit; - use Moose; - extends 'Decl'; - - has var => (isa => 'Str', is => 'ro', predicate => 'has_var'); - has code => (isa => 'Body', is => 'ro', required => 1); - - sub bodies { $_[0]->code } - - sub used_slots { - my ($self) = @_; - $self->has_var ? [$self->var, 'Variable', 1] : (); - } - - sub needs_protopad { 1 } - sub preinit_code { - my ($self, $body) = @_; - my $c = CgOp::prog(CgOp::protosub($self->code), - CgOp::subcall(CgOp::sub_obj($self->code))); - $self->has_var ? CgOp::proto_var($self->var, $c) : CgOp::sink($c); - } - - __PACKAGE__->meta->make_immutable; - no Moose; -} - { package Decl::Sub; use Moose; @@ -246,165 +219,6 @@ use CgOp; no Moose; } -{ - package Decl::Augment; - use Moose; - extends 'Decl'; - - has body => (is => 'ro', isa => 'Body', required => 1); - has bodyvar => (is => 'ro', isa => 'Str', required => 1); - has name => (is => 'ro', isa => 'Str', required => 1); - has pkg => (is => 'ro', isa => 'ArrayRef[Str]', required => 1); - - sub bodies { $_[0]->body } - - sub stash { - my ($self, $body, $suf) = @_; - ($body->lookup_pkg(@{ $self->pkg }, $self->name . $suf))[1]; - } - - sub used_slots { - my ($self) = @_; - [$self->bodyvar, 'Variable', $_[1] ? 1 : 4]; - } - - sub needs_protopad { 1 } - sub preinit_code { - my ($self, $body) = @_; - - CgOp::letn("pkg", CgOp::bget($self->stash($body, '::')), - CgOp::letn("how", CgOp::newscalar(CgOp::how( - CgOp::fetch(CgOp::bget($self->stash($body, ''))))), - CgOp::protosub($self->body), - CgOp::proto_var($self->bodyvar, CgOp::sub_var($self->body)))); - } - - sub enter_code { - my ($self, $body) = @_; - ($body->mainline) ? CgOp::noop : - CgOp::scopedlex($self->bodyvar, CgOp::sub_var($self->body)); - } - - __PACKAGE__->meta->make_immutable; - no Moose; -} - -{ - package Decl::Package; - use Moose; - extends 'Decl'; - - has var => (is => 'ro', isa => 'Str', required => 1); - has body => (is => 'ro', isa => 'Body'); - has bodyvar => (is => 'ro', isa => 'Str'); - has stub => (is => 'ro', isa => 'Bool', default => 0); - has name => (is => 'ro', isa => 'Str', predicate => 'has_name'); - # my packages always have a unique stash, our ones just alias part of GLOBAL - has ourpkg => (is => 'ro', isa => 'Maybe[ArrayRef[Str]]'); - - sub bodies { $_[0]->body ? $_[0]->body : () } - sub stashvar { $_[0]->var . '::' } - - sub stash { - my ($self, $body, $suf) = @_; - ($body->lookup_pkg(@{ $self->ourpkg }, $self->name . $suf))[1]; - } - - sub used_slots { - my ($self) = @_; - [$self->var, 'Variable', 3], [$self->stashvar, 'Variable', 3], - (!$self->stub ? [$self->bodyvar, 'Variable', $_[1] ? 1 : 4] : ()); - } - - sub make_how { CgOp::newscalar(CgOp::null('IP6')); } - sub finish_obj { CgOp::noop; } - - sub needs_protopad { 1 } - sub preinit_code { - my ($self, $body) = @_; - - if ($self->stub) { - return CgOp::prog( - CgOp::proto_var($self->var, CgOp::null('IP6')), - CgOp::proto_var($self->stashvar, CgOp::fetch( - ($self->ourpkg ? CgOp::bget($self->stash($body, '::')) : - CgOp::wrap(CgOp::rawnew('Dictionary')))))); - } - - CgOp::letn("pkg", - ($self->ourpkg ? CgOp::bget($self->stash($body, '::')) : - CgOp::wrap(CgOp::rawnew('Dictionary'))), - CgOp::letn("how", $self->make_how, - # catch usages before the closing brace - CgOp::proto_var($self->var, CgOp::null('IP6')), - CgOp::proto_var($self->stashvar, CgOp::fetch(CgOp::letvar("pkg"))), - - CgOp::protosub($self->body), - CgOp::proto_var($self->bodyvar, CgOp::sub_var($self->body)), - $self->finish_obj($body))); - } - - sub enter_code { - my ($self, $body) = @_; - ($self->stub || $body->mainline) ? CgOp::noop : - CgOp::scopedlex($self->bodyvar, CgOp::sub_var($self->body)); - } - - __PACKAGE__->meta->make_immutable; - no Moose; -} - -{ - package Decl::Module; - use Moose; - extends 'Decl::Package'; - - __PACKAGE__->meta->make_immutable; - no Moose; -} - -{ - package Decl::Class; - use Moose; - extends 'Decl::Module'; - - sub make_how { - my ($self) = @_; - CgOp::methodcall(CgOp::scopedlex("ClassHOW"), "new", - CgOp::string_var($self->name // 'ANON')); - } - - sub defsuper { 'Any' } - - sub finish_obj { - my ($self, $body) = @_; - my @r; - if (!grep { $_->isa('Decl::Super') } @{ $self->body->decls }) { - push @r, CgOp::sink(CgOp::methodcall(CgOp::letvar("how"), - "add-super", CgOp::scopedlex($self->defsuper))); - } - push @r, CgOp::scopedlex($self->var, - CgOp::methodcall(CgOp::letvar("how"), "create-typeobject")); - push @r, CgOp::bset($self->stash($body, ''), - CgOp::newboundvar(1, 0, CgOp::scopedlex($self->var))) if $self->ourpkg; - @r; - } - - __PACKAGE__->meta->make_immutable; - no Moose; -} - -{ - package Decl::Grammar; - use Moose; - extends 'Decl::Class'; - - sub defsuper { 'Grammar' } - - __PACKAGE__->meta->make_immutable; - no Moose; -} - { package Decl::HasMethod; use Moose; @@ -449,56 +263,6 @@ use CgOp; no Moose; } -{ - package Decl::Super; - use Moose; - extends 'Decl'; - - has name => (is => 'ro', isa => 'Str', required => 1); - - sub needs_protopad { 1 } - sub preinit_code { - my ($self, $body) = @_; - if ($body->type ne 'class' && $body->type ne 'grammar' && - $body->type ne 'role') { - #TODO: Make this a sorry. - die "Tried to set a superclass outside an initial class!"; - } - - CgOp::sink( - CgOp::methodcall(CgOp::letvar('how'), "add-super", - CgOp::scopedlex($self->name))); - } - - __PACKAGE__->meta->make_immutable; - no Moose; -} - -{ - package Decl::Attribute; - use Moose; - extends 'Decl'; - - has name => (is => 'ro', isa => 'Str', required => 1); - - sub needs_protopad { 1 } - sub preinit_code { - my ($self, $body) = @_; - if ($body->type ne 'class' && $body->type ne 'grammar' && - $body->type ne 'role') { - #TODO: Make this a sorry. - die "Tried to set an attribute outside a class!"; - } - - CgOp::sink( - CgOp::methodcall(CgOp::letvar('how'), "add-attribute", - CgOp::string_var($self->name))); - } - - __PACKAGE__->meta->make_immutable; - no Moose; -} - # XXX CHEAP HACK ALERT { package Decl::VarAlias; diff --git a/src/Metamodel.pm b/src/Metamodel.pm index a310861d..10084e68 100644 --- a/src/Metamodel.pm +++ b/src/Metamodel.pm @@ -83,7 +83,7 @@ our $global; has name => (isa => 'Str', is => 'ro', default => 'ANON'); sub add_attribute { - my ($self, $name, $accessor) = @_; + my ($self, $name) = @_; die "attribute $name defined in a lowly package"; } @@ -125,15 +125,13 @@ our $global; default => sub { [] }); sub add_attribute { - my ($self, $name, $accessor) = @_; + my ($self, $name) = @_; push @{ $self->attributes }, $name; - # TODO $accessor } sub add_method { my ($self, $name, $body) = @_; push @{ $self->methods }, Metamodel::Method->new(name => $name, body => $body); - # TODO $accessor } sub add_super { @@ -438,7 +436,20 @@ sub Op::Attribute::begin { " declared outside of any class"); die "attribute $self->name declared in an augment" if $opensubs[-1]->augmenting; - $ns->add_attribute($self->name, $self->accessor); + $ns->add_attribute($self->name); + if ($self->accessor) { + my $nb = Metamodel::StaticSub->new( + outer => $opensubs[-1], + name => $self->name, + cur_pkg => $opensubs[-1]->cur_pkg, + returnable => 0, + class => 'Sub', + run_once => 0, + do => Op::GetSlot->new(name => $self->name, + object => Op::CgOp->new(optree => [ pos => 0 ]))); + $opensubs[-1]->add_my_sub($self->name . '!a', $nb); + $ns->add_method($self->name, $nb); + } } sub Op::Super::begin { diff --git a/src/Op.pm b/src/Op.pm index fe5e7bdc..a98c2335 100644 --- a/src/Op.pm +++ b/src/Op.pm @@ -650,8 +650,6 @@ use CgOp; use Moose; extends 'Op::PackageDef'; - sub decl_class { 'Decl::Module' } - __PACKAGE__->meta->make_immutable; no Moose; } @@ -661,8 +659,6 @@ use CgOp; use Moose; extends 'Op::ModuleDef'; - sub decl_class { 'Decl::Class' } - __PACKAGE__->meta->make_immutable; no Moose; } @@ -672,8 +668,6 @@ use CgOp; use Moose; extends 'Op::ClassDef'; - sub decl_class { 'Decl::Grammar' } - __PACKAGE__->meta->make_immutable; no Moose; } @@ -685,11 +679,6 @@ use CgOp; has name => (isa => 'Str', is => 'ro'); - sub lift_decls { - my ($self) = @_; - Decl::Super->new(name => $self->name); - } - sub code { my ($self, $body) = @_; CgOp::null('Variable'); @@ -707,25 +696,6 @@ use CgOp; has name => (isa => 'Str', is => 'ro'); has accessor => (isa => 'Bool', is => 'ro'); - sub lift_decls { - my ($self) = @_; - my @r; - push @r, Decl::Attribute->new(name => $self->name); - if ($self->accessor) { - push @r, Decl::Sub->new(var => ($self->name . '!a'), - code => Body->new( - name => $self->name, - signature => Sig->new(params => [])->for_method, - type => 'sub', - do => Op::GetSlot->new( - object => Op::Lexical->new(name => "self"), - name => $self->name))); - push @r, Decl::HasMethod->new(name => $self->name, - var => $self->name . '!a'); - } - @r; - } - sub code { my ($self, $body) = @_; CgOp::null('Variable');