view release on metacpan or  search on metacpan

lib/Driver/Compiler/Generate.pm  view on Meta::CPAN

	StmtTry			=> 'eval A; if ($@) { my B = $@; C; }',
												# This uses blocks
	StmtCatch		=> 'eval A ;',				# A MudOS hack

	# This NOGEN business is really developer support and can be removed
	map { $_ => 'NOGEN' } qw(
							Variable
							Index Range
							Lsh Rsh
							Add Sub Mul Div Mod
							Eq Ne Lt Gt Le Ge Or
							And Xor
							
							AddEq SubEq DivEq MulEq ModEq
							AndEq OrEq XorEq
							LshEq RshEq

							StmtForeach
							),
		);

# XXX For the purposes of things like Member, I need to be able to
# insert both expanded and nonexpanded versions of tokens.
# So I need to be able to insert "A", _A_ and @A@ tokens, for example.

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

	confess "No code template for opcode '$name'" unless defined $code;

	foreach ('A'..'F') {	# Say ...
		my $arg = ord($_) - ord('A');
		# XXX This 'quote' routine doesn't necessarily quote
		# appropriately.
		$code =~ s/"$_"/' . quote(\$self->value($arg)) . '/g;
		$code =~ s/\b_$_\_\b/' . \$self->value($arg) . '/g;
		$code =~ s/\b$_\b/' . \$self->value($arg)->generate(\@_) . '/g;
	}

	$code = qq{ sub (\$) { my \$self = shift; return '$code'; } };
	# Remove empty concatenations - careful with the templates
	$code =~ s/'' \. //g;
	$code =~ s/ \. ''//g;

	# print "$name becomes $code\n";
	my $subref = eval $code;
	die $@ if $@;
	return $subref;
}

# "Refactor", I hear you say?
# This needs a magic token for line number...
sub generate ($) {
	my $self = shift;

	my $name = $self->opcode;
	# print "Finding code for $name\n";
	my $code = $OPCODETABLE{$name};
	return "GEN($name)" unless defined $code;

	# This is mostly for debugging. It can be safely removed.
	if ($code eq 'NOGEN') {
		print "XXX Attempt to generate NOGEN opcode $name\n";
		return "GEN($name)";
	}

	my $subref = $self->gensub($name, $code);

	{
		# Backpatch our original package.
		no strict qw(refs);
		*{ ref($self) . '::generate' } = $subref;
	}

	return $subref->($self, @_);
}

{
	package Anarres::Mud::Driver::Compiler::Node::String;
	use String::Escape qw(quote printable);
	sub generate {
		my $str = printable($_[0]->value(0));
		$str =~ s/([\$\@\%])/\\$1/g;
		return quote $str;
	}
}

{
	package Anarres::Mud::Driver::Compiler::Node::Integer;
	sub generate { $_[0]->value(0) }
}

{
	package Anarres::Mud::Driver::Compiler::Node::Array;
	sub generate {
		my ($self, $indent, @rest) = @_;
		$indent++;

		my @vals = map { $_->generate($indent, @rest) } $self->values;

		return "[ ]" unless @vals;

		$indent--;
		my $isep = "\n" . ("\t" x $indent);
		my $sep = "," . $isep . "\t";
		return "[" . $isep . "\t" . join($sep, @vals) . $isep . "]";
	}
}

{
	package Anarres::Mud::Driver::Compiler::Node::Mapping;
	sub generate {
		my ($self, $indent, @rest) = @_;
		$indent++;

		my @vals = map { $_->generate($indent, @rest) } $self->values;
		return "{ }" unless @vals;

		my @out = ();
		while (my @tmp = splice(@vals, 0, 2)) {
			push(@out, $tmp[0] . "\t=> " . $tmp[1] . ",");