File Coverage

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

Criterion	Covered	Total	%
statement	54	295	18.3
branch	2	76	2.6
condition	0	20	0.0
subroutine	12	49	24.4
pod	0	38	0.0
total	68	478	14.2

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

use strict;
use vars qw(@ISA @EXPORT_OK %EXPORT_TAGS %PROGS);
use Exporter;
use Carp qw(:DEFAULT cluck);
use Data::Dumper;
use File::Basename;
use String::Escape qw(quote printable);
use Anarres::Mud::Driver::Compiler::Type qw(:all);
use Anarres::Mud::Driver::Program::Variable;
use Anarres::Mud::Driver::Program::Method;
use Anarres::Mud::Driver::Program::Efun qw(efuns efunflags);

# This object is big and the 'context'-related stuff and possibly the
# 'generate'-related stuff could be split out.

@ISA = qw(Exporter);
	# Oddly enough, the PERL_* tags here must be in order.
@EXPORT_OK = (qw(package_to_path path_to_package
				PERL_HEAD PERL_USE PERL_VARS PERL_SUBS PERL_TAIL
				PERL_DOCS));
%EXPORT_TAGS = (
	sections	=> [ grep { /^PERL_/ } @EXPORT_OK ],
	all			=> \@EXPORT_OK,
		);

	# To insert various things into the Perl code.
sub PERL_HEAD	() { 0 }
sub PERL_USE	() { 1 }
sub PERL_VARS	() { 2 }
sub PERL_SUBS	() { 3 }
sub PERL_TAIL	() { 4 }
sub PERL_DOCS	() { 5 }

my $DEBUGLABELS = 0;

%PROGS = (
	"/foo/bar"	=> new Anarres::Mud::Driver::Program(Path=>"/foo/bar"),
		);

# Class methods

sub new {
	my $class = shift;
	my $self = ($#_ == 0) ? { %{ (shift) } } : { @_ };

	confess "No Path in program" unless $self->{Path};

	$self->{Perl} = [ ];
	$self->{PerlGlobals} = [ ];

	$self->{Inherits} = { };
	$self->{Statics} = { };
	$self->{Globals} = { };
	$self->{Locals} = { };
	$self->{Labels} = { };
	$self->{LabelDefault} = undef;
	$self->{Methods} = efuns;
	$self->{MethodFlags} = efunflags;

	$self->{ScopeStack} = [ ];
	$self->{LabelStack} = [ ];

	$self->{Warnings} = [ ];
	$self->{Errors} = [ ];

	$self->{Label} = 0;

	$self->{Closures} = [ ];

	$self->{Classes} = { };

	return bless $self, $class;
}

sub find {	# find Anarres::Mud::Driver::Program $path
	return $PROGS{$_[1]};
}

sub path_to_package {
	my $path = shift;
	$path =~ s,/,::,g;
	$path =~ s/\.c$//;
	$path =~ s,^/*,,;
	return "Anarres::Mud::Library::" . $path;
}

sub package_to_path {
	my $package = shift;
	die "package_to_path: Invalid package name"
			unless $package =~ s/^Anarres::Mud::Library//;
	$package =~ s,::,/,g;
	return $package;
}

# Debugging methods

sub warning {
	my $self = shift;
	print "WARNING: $_\n" foreach @_;
	push(@{ $self->{Warnings} }, @_);
}

sub error {
	my $self = shift;
	print "ERROR: $_\n" foreach @_;
	push(@{ $self->{Errors} }, @_);
}

# Instance query methods

sub path { return $_[0]->{Path}; }
sub source { return $_[0]->{Source}; }
sub ppsource { return $_[0]->{PPSource}; }
sub package { return path_to_package $_[0]->{Path}; }

sub methods	{ return values %{ $_[0]->{Methods} }; }
# sub locals	{ return values %{ $_[0]->{Globals} }; }
sub globals	{ return values %{ $_[0]->{Globals} }; }

sub variable {
	my ($self, $name) = @_;
	return $self->{Locals}->{$name}
		|| $self->{Globals}->{$name}
		|| undef;
}

# Instance modification methods

sub closure {
	my ($self, $clousure) = @_;
	return (push(@{ $self->{Closures} }, $clousure) - 1);
}

sub reset_labels {
	my $self = shift;
	# invoke for new method?
	die "Label stack not empty" if @{ $self->{LabelStack} };
	$self->{LabelDefault} = undef;
	$self->{Labels} = { };
	$self->{LabelCurrent} = undef;
	$self->{LabelStack} = [ ];
	$self->{BreakTarget} = undef;
	$self->{BreakStack} = [ ];
	print "Label stack reset\n" if $DEBUGLABELS;
}

sub switch_start {
	my ($self, $type) = @_;		# Do something with 'type'
	push(@{$self->{LabelStack}},
			[
				$self->{Labels},
				$self->{LabelDefault},
			]);
	$self->{LabelDefault} = undef;
	$self->{Labels} = { };
	push(@{$self->{BreakStack}}, $self->{BreakTarget});
	$self->{BreakTarget} = $self->label(undef);
	print "Start switch: Push labels: " .
							scalar(@{ $self->{LabelStack} }) . "\n"
					if $DEBUGLABELS;
	return $self->{BreakTarget};
}

sub switch_end {
	my $self = shift;
	my $ret = [ $self->{Labels}, $self->{LabelDefault} ];
	my ($labels, $default) = @{ pop(@{ $self->{LabelStack} }) };
	$self->{Labels} = { %{$self->{Labels}}, %$labels, };
	$self->{LabelDefault} ||= $default;
	$self->{BreakTarget} = pop(@{$self->{BreakStack}});
	print "End switch: Pop labels: " .
							scalar(@{ $self->{LabelStack} }) . "\n"
					if $DEBUGLABELS;
	return $ret;
}

sub loop_start {
	my $self = shift;
	$self->{BreakTarget} = undef;
	$self->{ContinueTarget} = $self->label(undef);
}

sub loop_end {
	my $self = shift;
	$self->{BreakTarget} = pop(@{$self->{BreakStack}});
	return $self->{BreakTarget};	# Make the return explicit
}

# XXX This mechanism isn't currently used.
sub statement {
	$_[0]->{LabelCurrent} = undef;
}

sub label {
	my ($self, $val) = @_;
	return undef if $self->{LabelCurrent};
	my $label = '__AMD_LABEL' . $self->{Label}++;
	if (defined $val) {
		print "Adding label $label => " . $val->dump . "\n"
					if $DEBUGLABELS;
		$self->{Labels}->{$label} = $val
	}
	return $label;
}

sub default {
	my $self = shift;
	print "Adding DEFAULT label\n"
				if $DEBUGLABELS;
	return ($self->{LabelDefault} = $self->label(undef));
}

# This should return a label in a switch or undef in a loop.
sub getbreaktarget {
	$_[0]->{BreakTarget};
}

sub save_locals {
	my $self = shift;
	my %saved = %{ $self->{Locals} };
	push(@{$self->{ScopeStack}}, \%saved);
}

sub restore_locals {
	my $self = shift;
	$self->{Locals} = pop(@{ $self->{ScopeStack} });
}

	# XXX Check that we don't declare a variable of type void.

sub local {
	my ($self, $name, $var) = @_;
	# print STDERR "local($name, $var)\n";
	return $self->{Locals}->{$name} unless $var;
	$self->warning("Local $name masks previous definition")
			if $self->{Locals}->{$name}
			|| $self->{Globals}->{$name}
			|| $self->{Statics}->{$name};
	# print "Storing local variable " . $var->dump . "\n";
	$self->{Locals}->{$name} = $var;
	return ();
}

sub global {
	my ($self, $name, $var) = @_;
	# print STDERR "global($name, $var)\n";
	return $self->{Globals}->{$name} unless $var;
	$self->error("Global $name masks previous definition in file XXX")
			if $self->{Globals}->{$name}
			|| $self->{Statics}->{$name};
	# print "Storing variable $name\n";
	$self->{Globals}->{$name} = $var;
	return ();
}

sub static {
	my ($self, $name, $var) = @_;
	# print STDERR "static($name, $var)\n";
	return $self->{Statics}->{$name} unless $var;
	$self->error("Static $name masks previous definition in file XXX")
			if $self->{Statics}->{$name};
	# print "Storing variable $name\n";
	$self->{Statics}->{$name} = $var;
	return ();
}

sub method {
	my ($self, $name, $method) = @_;

	# print STDERR "method($name, $method)\n";

	# print STDERR "program->method($method)\n";

	unless ($method) {
		$name =~ s/^.*:://;	# XXX Remove and do properly.
		my $ob = $self->{Methods}->{$name};
		if (!$ob) {
			$self->error("Method $name not found") unless $ob;
			# warn "Autodefining method $name for bison yyparse";
			$ob ||= new Anarres::Mud::Driver::Program::Method(
							Type	=> T_INTEGER,
							Name	=> $name,
							Args	=> [],
							Flags	=> M_UNKNOWN,
								);
			$self->{Methods}->{$name} = $ob;
			$self->{MethodFlags}->{$name} = 0;	# XXX UNDEFINED!
		}
		return $ob;
	}

	my $proto = $self->{Methods}->{$name};
	if ($proto) {
		# XXX Check that types match!
		warn "Method $name already defined"
				if $proto->code;
	}

	# print STDERR "Defining method $name\n";

	# XXX Check prototype match with superclass
	# XXX Check sanity of modifiers

	$self->{Methods}->{$name} = $method;
	$self->{MethodFlags}->{$name} = 0
					unless exists $self->{MethodFlags}->{$name};

	return ();
}

sub inherit {
	my ($self, $name, $path) = @_;

	my $inh = $PROGS{$path};
	return "Could not find inherited program '$path'" unless $inh;

	$name = basename($path, ".c") unless $name;		# Also support DGD
	return "Already inheriting file named $name"
					if $self->{Inherits}->{$path};

	$self->{Inherits}->{$name} = $inh;

	my @errors;

	foreach ($inh->globals) {
		my $err = $self->global($_);
		push(@errors, $err), next if $err;
		# Variable flags? Accessibility.
	}

	foreach ($inh->methods) {
		next if $_->flags & (M_EFUN | M_UNKNOWN | M_PRIVATE);
		my $err = $self->method($_->name, $_);	# XXX Mark inherited
		push(@errors, $err) if $err;
		$err = $self->method($name . "::" . $_->name, $_);
		push(@errors, $err) if $err;
	}

	return @errors;
}

sub class {
	my ($self, $cname, $fields) = @_;

	unless ($fields) {
		# Search for the class; return a valid type for it.
		my $class = $self->{Classes}->{$cname};
		return $class if $class;
		$self->error("No class named $cname");
		return undef;
	}

	my (%class, @types);
	foreach (@$fields) {
		my ($name, $type) = ($_->name, $_->type);
		push(@types, $type);

		if ($class{$name}) {
			$self->error("Field name $name multiply defined in class " .
							$cname);
			next;
		}
		$class{$name} = $type;
	}

	my $type = T_CLASS($cname, @types);

	$self->{Classes}->{$cname} = {
					Data	=> $fields,
					Fields	=> \%class,
					Type	=> $type,
						};

	# print Dumper($fields);
	# print STDERR "New class type is " . $$type . "\n";

	return 1;
}

sub class_type {
	my ($self, $cname) = @_;

	my $class = $self->class($cname);
	unless ($class) {
		$self->error("No such class $cname");
		return T_FAILED;
	}

	return $class->{Type};
}

sub class_field_type {
	my ($self, $cname, $fname) = @_;

	my $class = $self->{Classes}->{$cname};
	unless ($class) {
		$self->error("No such class $cname");
		return T_FAILED;
	}

	my $ftype = $class->{Fields}->{$fname};
	unless ($ftype) {
		$self->error("No such field $fname in class $cname");
		return T_FAILED;
	}

	return $ftype;
}

# Debugging

sub dump {
	my ($self) = @_;

	my @inh = map { "(inherit " .
					quote(printable $_) . " " .
					quote(printable $self->{Inherits}->{$_}->path)
					. ")" }
					keys %{$self->{Inherits}};
	my @glob = sort map { $_->dump(1) } values %{$self->{Globals}};
	my @meth = sort keys %{$self->{Methods}};
	@meth = grep { ! ($self->{MethodFlags}->{$_} & M_EFUN) } @meth;
	@meth = map { $self->{Methods}->{$_}->dump(1) } @meth;

	my $out = "(program\n\t" . join("\n\t", @inh, @glob, @meth) . "\n)";

	return $out;
}

# Semantics

sub check {
	my $self = shift;

	my @meth = grep { ! ($self->{MethodFlags}->{$_} & M_EFUN) }
					keys %{$self->{Methods}};

	my $ret = 1;
	foreach (@meth) {
		my $tcm = $self->{Methods}->{$_}->check($self, 0);
		$ret &&= $tcm;
	}

	return $ret;
}

# Output

sub perl {
	my ($self, $section, @code) = @_;
	if (@code) {
		push(@{ $self->{Perl}->[$section] }, @code);
		return ();
	}
	else {
		return join("\n", @{ $self->{Perl}->[$section] });
	}
}

sub perl_global {
	my ($self, @globals) = @_;
	push( @{ $self->{PerlGlobals} }, @globals);
}

sub generate {
	my ($self) = @_;

	my $path = $self->{Path};
	my $package = $self->package;

	$self->perl(PERL_HEAD, "# program $path;");
	$self->perl(PERL_HEAD, "package $package;");
	$self->perl(PERL_USE, "use strict;");
	$self->perl(PERL_USE, "use warnings;");

	$self->perl_global(q[$PROGRAM]);

	if (scalar %{ $self->{Inherits} }) {
		my $inh = join " ",
				map { $_->package }
						values %{ $self->{Inherits} };
		$self->perl_global(q[@ISA]);
		$self->perl(PERL_VARS, qq[\@ISA = qw($inh);]);
	}
	else {
		$self->perl(PERL_SUBS, qq[sub new { bless { }, shift; }\n]);
	}

	$self->perl(PERL_USE, 'use vars qw(' .
							join(" ", @{ $self->{PerlGlobals} }) .
							");");
	# XXX $path forms part of a Perl program. Beware.
	$self->perl(PERL_VARS,
			'*PROGRAM = \$' . __PACKAGE__ . "::PROGS{'$path'};");
	$self->perl(PERL_TAIL, '1;');
	$self->perl(PERL_TAIL, '__END__');

	# These have a very large extent.
	local *::methods = $self->{Methods};
	local *::methodflags = $self->{MethodFlags};

	# Should we be doing these in order of definition? I've just
	# put them into alpha order so I can find methods more easily
	# in the generated Perl, but we lose definition order in the
	# hash.
	my @meth = map { $::methods{$_}->generate(0, $path) }
				grep { ! ($::methodflags{$_} & M_EFUN) }
					sort keys %::methods;


	$self->perl(PERL_SUBS, @meth);

	my $out = '';
	foreach (0..$#{$self->{Perl}}) {
		$out .= "# === Section " .
						$EXPORT_TAGS{sections}->[$_] . "\n";
		$out .= $self->perl($_) . "\n\n";
	}
	return $out;
}

1;