From 794391454e4f93a1d153e5b4f2cfd0b53aae06b3 Mon Sep 17 00:00:00 2001 From: Stefan O'Rear Date: Sat, 10 Jul 2010 23:24:40 -0700 Subject: [PATCH] More steps towards class decls. Allow lexget et al to directly access protopads. --- Body.pm | 53 +++++++++++++++++++++++++++++++++++++++++++++++++---- CodeGen.pm | 41 +++++++++++++++++++++++++++++++++++------ Decl.pm | 28 ++++++++++++---------------- Unit.pm | 3 ++- 4 files changed, 98 insertions(+), 27 deletions(-) diff --git a/Body.pm b/Body.pm index 4c0a9a0f..06f939b6 100644 --- a/Body.pm +++ b/Body.pm @@ -21,25 +21,70 @@ use CodeGen (); if ($self->codegen) { return $self->codegen } $self->codegen(CodeGen->new(name => $self->name)); my $cg = $self->codegen; - $_->enter($cg, $self) for @{ $self->decls }; - $_->void_cg($cg, $self) for @{ $self->enter }; + $self->do_enter($cg); $self->do->item_cg($cg, $self); # TODO: Bind a return value here to catch non-ro sub use $cg->return(1) unless $cg->unreach; return $cg; } + sub do_enter { + my ($self, $cg) = @_; + $_->do_enter($cg, $self) for @{ $self->decls }; + $_->void_cg($cg, $self) for @{ $self->enter }; + } + sub write { my ($self) = @_; $self->code->write; $_->write($self) for (@{ $self->decls }); } - sub preinit { + sub do_preinit { my ($self, $cg) = @_; - $_->preinit($cg, $self) for @{ $self->decls }; + $_->do_preinit($cg, $self) for @{ $self->decls }; } __PACKAGE__->meta->make_immutable; no Moose; } + +# Like a normal body, but creates a protoobject during preinit and run! +{ + package Body::Class; + use Moose; + extends 'Body'; + + has 'var' => (is => 'rw', isa => 'Str'); + + sub makeproto { + my ($self, $cg) = @_; + $cg->lextypes('!plist', 'List'); + $cg->clr_new('List', 0); + $cg->lexput(0, '!plist'); + # TODO handle superclasses here! + $cg->lexget(1, $self->var . '!HOW'); + $cg->dup_fetch; + $cg->callframe; + $cg->clr_call_direct('Kernel.NewROVar', 1); + $cg->lexget(0, '!plist'); + $cg->clr_wrap; + $cg->call_method(1, "create-protoobject", 2); + $cg->lexput(1, $self->var); + } + + before do_enter => sub { + my ($self, $cg) = @_; + $self->makeproto($cg); + }; + + after do_preinit => sub { + my ($self, $cg) = @_; + $self->makeproto($cg); + }; + + __PACKAGE__->meta->make_immutable; + no Moose; +} + +1; diff --git a/CodeGen.pm b/CodeGen.pm index d406772e..416b8403 100644 --- a/CodeGen.pm +++ b/CodeGen.pm @@ -140,19 +140,19 @@ use 5.010; my ($self, $which) = @_; my $var = "aux!${which}!" . ($self->auxdepths->{$which}++); $self->lextypes($var, $self->auxtypes->{$which}); - $self->lexput(0, $var); + $self->rawlexput($var); } sub pop_aux { my ($self, $which) = @_; my $var = "aux!${which}!" . (--$self->auxdepths->{$which}); - $self->lexget(0, $var); + $self->rawlexget($var); } sub peek_aux { my ($self, $which) = @_; my $var = "aux!${which}!" . ($self->auxdepths->{$which} - 1); - $self->lexget(0, $var); + $self->rawlexget($var); } sub label { @@ -192,6 +192,7 @@ use 5.010; sub lextypes { my ($self, @args) = @_; + #say STDERR "lextypes: @args"; %{ $self->lex2type } = (%{ $self->lex2type }, @args); } @@ -209,15 +210,37 @@ use 5.010; $self->lexget($order, $name); } + sub rawlexget { + my ($self, $name) = @_; + $self->_push($self->lex2type->{$name}, "th.lex[" . qm($name) . "]"); + } + + sub rawlexput { + my ($self, $name) = @_; + $self->_emit("th.lex[" . qm($name) . "] = " . $self->_pop); + } + sub lexget { my ($self, $order, $name) = @_; + my $frame = 'th.'; + if ($self->auxdepths->{'protopad'}) { + $frame = '((Frame)th.lex[' . + qm('aux!protopad!' . ($self->auxdepths->{'protopad'} - 1)) . + ']).'; + } $self->_push(($order ? 'Variable' : $self->lex2type->{$name}), - "th." . ("outer." x $order) . "lex[" . qm($name) . "]"); + $frame . ("outer." x $order) . "lex[" . qm($name) . "]"); } sub lexput { my ($self, $order, $name) = @_; - $self->_emit("th." . ("outer." x $order) . "lex[" . qm($name) . "] = " . $self->_pop); + my $frame = 'th.'; + if ($self->auxdepths->{'protopad'}) { + $frame = '((Frame)th.lex[' . + qm('aux!protopad!' . ($self->auxdepths->{'protopad'} - 1)) . + ']).'; + } + $self->_emit($frame . ("outer." x $order) . "lex[" . qm($name) . "] = " . $self->_pop); } sub string_var { @@ -233,7 +256,13 @@ use 5.010; sub callframe { my ($self) = @_; - $self->_push("Frame", "th"); + my $frame = 'th'; + if ($self->auxdepths->{'protopad'}) { + $frame = '((Frame)th.lex[' . + qm('aux!protopad!' . ($self->auxdepths->{'protopad'} - 1)) . + '])'; + } + $self->_push("Frame", $frame); } sub fetch { diff --git a/Decl.pm b/Decl.pm index ee4415a2..bdb3c3fe 100644 --- a/Decl.pm +++ b/Decl.pm @@ -6,9 +6,9 @@ use 5.010; package Decl; use Moose; - sub preinit {} - sub enter {} - sub write {} + sub do_preinit {} + sub do_enter {} + sub write {} __PACKAGE__->meta->make_immutable; no Moose; @@ -23,17 +23,17 @@ use 5.010; has code => (isa => 'Body', is => 'ro', required => 1); has shared => (isa => 'Bool', is => 'ro', default => 0); - sub preinit { + sub do_preinit { my ($self, $cg, $body) = @_; $self->code->outer($body); $cg->open_protopad; - $self->code->preinit($cg); + $self->code->do_preinit($cg); $cg->close_sub($self->code->code); $cg->call_sub($self->has_var, 0); $cg->proto_var($self->var) if $self->has_var; } - sub enter { + sub do_enter { my ($self, $cg, $body) = @_; return unless $self->has_var; if ($self->shared) { @@ -61,17 +61,17 @@ use 5.010; has var => (isa => 'Str', is => 'ro', required => 1); has code => (isa => 'Body', is => 'ro', required => 1); - sub preinit { + sub do_preinit { my ($self, $cg, $body) = @_; $self->code->outer($body); $cg->open_protopad; - $self->code->preinit($cg); + $self->code->do_preinit($cg); $cg->close_sub($self->code->code); $cg->clr_call_direct('Kernel.NewROVar', 1); $cg->proto_var($self->var); } - sub enter { + sub do_enter { my ($self, $cg, $body) = @_; $cg->clone_lex($self->var); } @@ -100,7 +100,7 @@ use 5.010; # preinit has body => (is => 'ro', isa => 'Body::Class', required => 1); - sub preinit { + sub do_preinit { my ($self, $cg, $body) = @_; $cg->scopelexget("ClassHOW", $body); $cg->dup_fetch; @@ -126,19 +126,15 @@ use 5.010; $cg->clr_call_direct('Kernel.NewROVar', 1); $cg->call_method(0, "push-scope", 1); - $self->body->preinit($cg); + $self->body->do_preinit($cg); $cg->close_sub($self->body->code); $cg->proto_var($self->var . '!BODY'); } - sub enter { + sub do_enter { my ($self, $cg, $body) = @_; $cg->share_lex($self->var . '!HOW'); $cg->clone_lex($self->var . '!BODY'); - $cg->lexget($self->var . '!BODY'); - $cg->fetch; - $cg->call_sub(0, 0); - # the body will set $self->var at ENTER time } sub write { my ($self, $body) = @_; diff --git a/Unit.pm b/Unit.pm index 5ce3f2f3..5730d9e2 100644 --- a/Unit.pm +++ b/Unit.pm @@ -20,7 +20,7 @@ use 5.010; $cg->push_null('Frame'); $cg->push_aux('protopad'); $cg->open_protopad; - $self->mainline->preinit($cg); + $self->mainline->do_preinit($cg); $cg->close_sub($self->mainline->code); $cg->call_sub(0,0); $cg->return; @@ -30,6 +30,7 @@ use 5.010; sub write { my ($self) = @_; + #say STDERR (YAML::XS::Dump($self)); print <