File Coverage

blib/lib/Anarres/Mud/Driver/Program/Method.pm

Criterion	Covered	Total	%
statement	18	88	20.4
branch	0	20	0.0
condition			n/a
subroutine	6	14	42.8
pod	0	8	0.0
total	24	130	18.4

package Anarres::Mud::Driver::Program::Method;

use strict;
use vars qw(@ISA @EXPORT);
use Data::Dumper;
use Carp qw(cluck);
use Anarres::Mud::Driver::Program::Variable;
use Anarres::Mud::Driver::Compiler::Type qw(:all);

@ISA = qw(Anarres::Mud::Driver::Program::Variable);
*EXPORT = \@Anarres::Mud::Driver::Program::Variable::EXPORT;

sub args { return $_[0]->{Args}; }

# Code is added later in the parser (was?)
sub code {
	my ($self, $code) = @_;
	# cluck "Add code $code to method $self->{Name}\n" if $code;
	if (defined $code) {
		$self->{Code} = $code;
		# print Dumper($code);
	}
	return $self->{Code};
}

sub check {
	my ($self, $program, @rest) = @_;
	# print "Typechecking method " . $self->name . " (top level)\n";
	# print $self->dump, "\n";

	# Start adding locals, etc, etc.

	$program->reset_labels;
	$program->save_locals;
	foreach (@{ $self->args }) {
		$program->local($_->name, $_);
	}
	my $code = $self->code;
	if ($code) {
		$code->check($program, @rest);
	}
	else {
		$program->error("No code in method " . $self->name);
	}
	$program->restore_locals;
	# print $self->dump, "\n";
}

sub dump {
	my $self = shift;
	my $indent = shift;
	$indent++;

	my $sep = "\n" . ("\t" x $indent);

	# XXX No types
	my $out = "([" . $self->type->dump(@_) . "] method " . $self->name;
	# my $out = "(method " . $self->name;
	my $args = join("", map { " " . $_->dump($indent, @_) } @{$self->args});
	my $code = ! $self->code				? "(nocode)"
			: ref($self->code) !~ /::/		? ref($self->code)
			: $self->code->dump($indent, @_)
		;

	$out  = $out .
		$sep . "(args" . $args . ")" .
		$sep . $code . ")";

	return $out;
}

	# This should generate Perl code for the method
sub generate {
	my $self = shift;
	my $indent = shift;
	$indent++;

	return "\n\n# No code in " . $self->name . "\n\n\n"
					unless $self->code;

	my $proto = '$' . ('$' x @{$self->args});
	my $rtproto = join("", map { ${ $_->type } } @{ $self->args });
	my $head =
		"# method " . $self->name . " proto o" . $rtproto . "\n" .
		"sub _M_" . $self->name . " ($proto) {\n";
	# XXX Generate warning if no return from nonvoid function.
	my $tail = "\n\treturn undef;\n}\n";

	my @args = map { ', $_L_' . $_->name } @{ $self->args };
	my $args = "\t" . 'my ($self' . join('', @args) . ') = @_;' .
					"\n\t";

	return $head . $args . $self->code->generate($indent, @_) . $tail;
}

	# This has a weird prototype for a typecheck method.
sub typecheck_call {
	my ($self, $program, $values, @rest) = @_;

	if ($self->flags & M_UNKNOWN) {
		return $self->type;
	}

	# print "Typecheck call: " . Dumper($values) . "\n";
	# print "Typecheck call: " . Dumper($self) . "\n";

	my @values = @$values;
	my $method = shift @values;

	my @args = @{ $self->args };

	if (@values < @args) {
		$program->error("Too few arguments (" . scalar(@values) .
						") to function " .  $method->name .
						", try " .  scalar(@args));
		return $self->type;
	}
	elsif (@values > @args) {
		$program->error("Too many arguments (" . scalar(@values) .
						") to function " . $method->name .
						", try " .  scalar(@args));
		return $self->type;
	}

	my $i = 1;
	foreach my $decl (@args) {
		my $val = $values->[$i];
		# print "Matching arg " . $val->dump . " against " . $decl->dump . "\n";
		my $arg = $val->promote($decl->type);
		if (! $arg) {
			$program->error("Argument $i to " . $self->name .
							" is type " . $val->type->name .
							" not type " . $decl->type->name);
		}
		elsif ($arg != $val) {
			$arg->check($program, undef, @rest);
			$values->[$i] = $arg;
		}
		# print "OK\n";
	}
	continue {
		$i++;
	}

#		print "Funcall " . $method->name . " checked and becomes type "
#						. ${$method->type} . "\n" if 0;
	return $self->type;
}

sub generate_call {
	my ($self, @args) = @_;
	return '$self->_M_' . $self->name . "(" . join(", ", @args) .")";
}

sub proto {
	my ($self) = @_;
	return $self->type->deparse . " " . $self->name . "(...)";
}

1;