Skip to content

Commit

Permalink
[mm] Implement accessor generation
Browse files Browse the repository at this point in the history
  • Loading branch information
@sorear
sorear committed Sep 19, 2010
1 parent 2abfd12 commit 3b8eaf3
Show file tree
Hide file tree
Showing 3 changed files with 16 additions and 271 deletions.
236 changes: 0 additions & 236 deletions src/Decl.pm
View file
Expand Up @@ -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;
Expand Down Expand Up @@ -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<string,BValue>'))))));
}

CgOp::letn("pkg",
($self->ourpkg ? CgOp::bget($self->stash($body, '::')) :
CgOp::wrap(CgOp::rawnew('Dictionary<string,BValue>'))),
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;
Expand Down Expand Up @@ -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;
Expand Down
21 changes: 16 additions & 5 deletions src/Metamodel.pm
View file
Expand Up @@ -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";
}

Expand Down Expand Up @@ -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 {
Expand Down Expand Up @@ -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 {
Expand Down
30 changes: 0 additions & 30 deletions src/Op.pm
View file
Expand Up @@ -650,8 +650,6 @@ use CgOp;
use Moose;
extends 'Op::PackageDef';

sub decl_class { 'Decl::Module' }

__PACKAGE__->meta->make_immutable;
no Moose;
}
Expand All @@ -661,8 +659,6 @@ use CgOp;
use Moose;
extends 'Op::ModuleDef';

sub decl_class { 'Decl::Class' }

__PACKAGE__->meta->make_immutable;
no Moose;
}
Expand All @@ -672,8 +668,6 @@ use CgOp;
use Moose;
extends 'Op::ClassDef';

sub decl_class { 'Decl::Grammar' }

__PACKAGE__->meta->make_immutable;
no Moose;
}
Expand All @@ -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');
Expand All @@ -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');
Expand Down

0 comments on commit 3b8eaf3

Please sign in to comment.