[Bps-public-commit] r12681 - in pie/branches/named-params: lib/PIE
clkao at bestpractical.com
clkao at bestpractical.com
Sun May 25 10:20:08 EDT 2008
Author: clkao
Date: Sun May 25 10:20:07 2008
New Revision: 12681
Modified:
pie/branches/named-params/lib/PIE/Block.pm
pie/branches/named-params/lib/PIE/Evaluator.pm
pie/branches/named-params/lib/PIE/Expression.pm
pie/branches/named-params/lib/PIE/Lambda.pm
pie/branches/named-params/t/let.t
Log:
implement closed-over variables.
Modified: pie/branches/named-params/lib/PIE/Block.pm
==============================================================================
--- pie/branches/named-params/lib/PIE/Block.pm (original)
+++ pie/branches/named-params/lib/PIE/Block.pm Sun May 25 10:20:07 2008
@@ -9,8 +9,46 @@
default => sub { ++$BLOCK_IDS },
);
-has outter_scope => (
- is => 'ro',
- isa => 'Num',
- default => sub { 0 },
+has outter_block => (
+ is => 'rw',
+ weak_ref => 1,
+ default => sub { undef },
);
+
+around 'new' => sub {
+ my $next = shift;
+ my $class = shift;
+ my $self = $class->$next(@_);
+ return $self if ref($self) eq 'PIE::Lambda::Native';
+ $self->_walk( $self,
+ sub { my $block = shift;
+ return unless $block->does('PIE::Block');
+ $block->outter_block($self);
+ return 1;
+ } );
+
+ return $self;
+};
+
+sub _walk {
+ my ($self, $exp, $cb) = @_;
+
+ if ($exp->can('nodes')) {
+ for (@{$exp->nodes}) {
+ next unless ref($_);
+ $cb->($_) and next;
+ $self->_walk($_, $cb);
+ }
+ }
+ else {
+ for (keys %{$exp->signature}) {
+ next unless ref($exp->args->{$_});
+ $cb->($exp->args->{$_}) and next;
+ $self->_walk($exp->args->{$_}, $cb);
+ }
+ }
+
+}
+
+
+1;
Modified: pie/branches/named-params/lib/PIE/Evaluator.pm
==============================================================================
--- pie/branches/named-params/lib/PIE/Evaluator.pm (original)
+++ pie/branches/named-params/lib/PIE/Evaluator.pm Sun May 25 10:20:07 2008
@@ -10,7 +10,7 @@
isa => 'PIE::EvaluatorResult',
default => sub { return PIE::EvaluatorResult->new()}
);
-
+
has global_symbols => (
metaclass => 'Collection::Hash',
is => 'rw',
@@ -21,6 +21,12 @@
set => 'set_global_symbol',
});
+has lex_block_map => (
+ is => 'rw',
+ isa => 'HashRef[ArrayRef[Num]]',
+ default => sub { {} },
+);
+
has stack_vars => (
is => 'rw',
metaclass => 'Collection::Array',
@@ -32,6 +38,17 @@
}
);
+has stack_block => (
+ is => 'rw',
+ metaclass => 'Collection::Array',
+ isa => 'ArrayRef[PIE::Block]',
+ default => sub { [] },
+ provides => {
+ 'push' => 'push_stack_block',
+ 'pop' => 'pop_stack_block',
+ }
+);
+
has stack_depth => (
is => 'rw',
isa => 'Int',
@@ -41,17 +58,23 @@
sub enter_stack_frame {
my $self = shift;
- my %args = validate(@_, {args => 1});
+ my %args = validate(@_, {args => 1, block => 1});
$self->stack_depth($self->stack_depth+1);
$self->push_stack_vars($args{'args'});
+ $self->push_stack_block($args{'block'});
+
+ push @{ $self->lex_block_map->{ $args{'block'}->block_id } ||= [] }, $#{ $self->stack_vars };
}
sub leave_stack_frame {
my $self = shift;
die "Trying to leave stack frame 0. Too many returns. Something relaly bad happened" if ($self->stack_depth == 0);
$self->pop_stack_vars();
+ my $block = $self->pop_stack_block();
$self->stack_depth($self->stack_depth-1);
+
+ pop @{ $self->lex_block_map->{ $block->block_id } };
}
sub run {
@@ -75,11 +98,26 @@
return $self->result->success;
}
+sub lookup_lex_name {
+ my ($self, $name) = @_;
+
+ return unless @{ $self->stack_block };
+
+ my $block = $self->stack_block->[-1];
+ do {
+ my $stack = $self->stack_vars->[ $self->lex_block_map->{ $block->block_id }[-1] ];
+ return $stack->{$name} if exists $stack->{$name};
+ } while ($block = $block->outter_block);
+
+ return;
+}
+
sub resolve_symbol_name {
my ($self, $name) = @_;
my $stack = $self->stack_vars->[-1] || {};
Carp::cluck if ref($name);
- $stack->{$name} || $self->get_global_symbol($name) || die "Could not find symbol $name in the current lexical context.";
+ $stack->{$name} || $self->lookup_lex_name($name) || $self->get_global_symbol($name)
+ || die "Could not find symbol $name in the current lexical context.";
}
sub apply_script {
@@ -92,7 +130,8 @@
{ ISA => "HASHREF" }
);
Carp::confess unless($lambda);
- my $ret = $lambda->apply( $self => $args);
+# Carp::cluck Dumper($lambda); use Data::Dumper;
+ my $ret = $lambda->apply( $self => $args );
$self->result->value($ret);
$self->result->success(1);
return $self->result->value;
Modified: pie/branches/named-params/lib/PIE/Expression.pm
==============================================================================
--- pie/branches/named-params/lib/PIE/Expression.pm (original)
+++ pie/branches/named-params/lib/PIE/Expression.pm Sun May 25 10:20:07 2008
@@ -156,13 +156,12 @@
class_has signature => (
is => 'ro',
default => sub { { symbol => PIE::FunctionArgument->new( name => 'symbol', type => 'Str')}});
-
-
+
sub evaluate {
my ($self, $eval) = validate_pos(@_, { isa => 'PIE::Expression'}, { isa => 'PIE::Evaluator'});
my $symbol = $self->{'args'}->{'symbol'}->evaluate($eval);
my $result = $eval->resolve_symbol_name($symbol);
- return $result->meta->does_role('PIE::Evaluatable') ? $result->evaluate($eval): $result; # XXX: figure out evaluation order here
+ return ref($result) && $result->meta->does_role('PIE::Evaluatable') ? $result->evaluate($eval): $result; # XXX: figure out evaluation order here
}
package PIE::Expression::Let;
@@ -186,7 +185,7 @@
progn => PIE::Expression::ProgN->new( nodes => $self->nodes ),
signature => $self->mk_signature,
block_id => $self->block_id,
- outter_scope => $self->outter_scope,
+ outter_block => $self->outter_block,
);
},
);
@@ -209,9 +208,7 @@
sub evaluate {
my ($self, $evaluator) = @_;
- $evaluator->apply_script( $self->lambda, $self->bindings );
-
+ $self->lambda->apply( $evaluator, $self->bindings );
}
1;
-
Modified: pie/branches/named-params/lib/PIE/Lambda.pm
==============================================================================
--- pie/branches/named-params/lib/PIE/Lambda.pm (original)
+++ pie/branches/named-params/lib/PIE/Lambda.pm Sun May 25 10:20:07 2008
@@ -13,6 +13,7 @@
has signature => (
is => 'rw',
+ default => sub { {} },
isa => 'HashRef[PIE::FunctionArgument]');
sub check_args {
@@ -58,7 +59,7 @@
$self->validate_args_or_die($args);
- $evaluator->enter_stack_frame( args => $args);
+ $evaluator->enter_stack_frame( args => $args, block => $self );
my $res = $self->progn->evaluate($evaluator);
$evaluator->leave_stack_frame();
Modified: pie/branches/named-params/t/let.t
==============================================================================
--- pie/branches/named-params/t/let.t (original)
+++ pie/branches/named-params/t/let.t Sun May 25 10:20:07 2008
@@ -58,11 +58,10 @@
ok(exists $script->progn->nodes->[0]->bindings->{REGEXP});
isa_ok($script->progn->nodes->[0]->bindings->{REGEXP}, 'PIE::Expression');
-TODO: {
- local $TODO = 'lexical loopup in outter blocks';
+
lives_ok {
-$eval->apply_script( $script, { 'tested-string', 'you do love software' } );
+ $eval->apply_script( $script, { 'tested-string', 'you do love software' } );
};
ok( $eval->result->success, $eval->result->error );
is( $eval->result->value, 'hate' );
-};
+
More information about the Bps-public-commit
mailing list