view release on metacpan or  search on metacpan

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

					# eval the args once outside scope of $__* vars
					# XXX Use the XSUB in Core
	StrRangeCstLL	=> 'substr(A, B, (C) - (B))',
	StrRangeCstLR	=> 'substr(A, B, (B) - (C))',
	StrRangeCstRL	=> 'substr(A, -(B), (C) - (B))',
	StrRangeCstRR	=> 'substr(A, -(B), (B) - (C))',

	StrRangeVarLL	=> 'do { my ($__a, $__b, $__c) = ((A), (B), (C)); '.
					'substr($__a, $__b, ($__c - $__b)) }',
	StrRangeVarLR	=> 'do { my ($__a, $__b, $__c) = ((A), (B), (C)); '.
					'substr($__a, $__b, ($__b - $__c)) }',
	StrRangeVarRL	=> 'do { my ($__a, $__b, $__c) = ((A), (B), (C)); '.
					'substr($__a, - $__b, ($__c - $__b)) }',
	StrRangeVarRR	=> 'do { my ($__a, $__b, $__c) = ((A), (B), (C)); '.
					'substr($__a, - $__b, ($__b - $__c)) }',

	ArrAdd			=> '[ @{A}, @{B} ]',
	ArrSub			=> 'do { my %__a = map { $_ => 1 } @{B}; ' .
					'[ grep { ! $__a{$_} } @{ A } ] }',

	MapAdd			=> '{ %{A}, %{B} }',

	Assign			=> 'A = B',
	Catch			=> 'do { eval { A; }, $@; }',

	StmtReturn		=> 'return A;',
	StmtContinue	=> 'next;',

	# We can add extra braces around statement|block tokens
	# This lot are all strictly cheating anyway! If this works ...
	StmtExp			=> 'A;',
	# Should we promote_to_block() B in these statements?
	# Bear in mind what happens if we do an empty block...?
	StmtDo			=> 'do { B } while (A);',
	StmtWhile		=> 'while (A) { B }',
	StmtFor			=> 'for (A; B; C) D',
	StmtForeachArr	=> 'foreach my A (@{ C }) D',
	StmtForeachMap	=> 'foreach my A (keys %{ C }) D',	# XXX FIXME: B
	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;