Anarres-Mud-Driver
12 results

 view release on metacpan or  search on metacpan

Compiler/junk  view on Meta::CPAN 


SV *
array(self, num = 1)
	Anarres::Mud::Driver::Compiler::Type	 self
	int		num
	CODE:
		{
			/* I can't quite get the typemap to bless an output
			 * reference to a scalar. */

			int		 i;
			SV		*out;

			out = newSVpvn("", 0);
			for (i = 0; i < num; i++) {
				sv_catpvn(out, "*", 1);
			}
			sv_catsv(out, self);

			RETVAL = sv_bless(newRV_noinc(out),
					gv_stashpv(_AMD "::Compiler::Type", TRUE));
		}
	OUTPUT:
		RETVAL

SV *
mapping(self, num = 1)
	Anarres::Mud::Driver::Compiler::Type	 self
	int		num
	CODE:
		{
			/* I can't quite get the typemap to bless an output
			 * reference to a scalar. */

			int		 i;
			SV		*out;

			out = newSVpvn("", 0);
			for (i = 0; i < num; i++) {
				sv_catpvn(out, "#", 1);
			}
			sv_catsv(out, self);

			RETVAL = sv_bless(newRV_noinc(out),
					gv_stashpv(_AMD "::Compiler::Type", TRUE));
		}
	OUTPUT:
		RETVAL

Compiler/parser.c  view on Meta::CPAN 


	FREETMPS;
	LEAVE;

	/* In the outer scope. Let's hope this doesn't get dested. */
	sv_2mortal(node);

	return node;

#if 0
	return sv_bless(newRV_noinc(stars),
			gv_stashpv(_AMD "::Compiler::Type", TRUE));
#endif
}

/* Can I pass mods as a primitive integer, and not bother if they
 * are zero? This applies to functions as well. */
static SV *
amd_yyparse_variable(SV *name, const char *type, SV *stars, SV *mods)
{
	static SV	*class = NULL;

Compiler/parser.y  view on Meta::CPAN 


	FREETMPS;
	LEAVE;

	/* In the outer scope. Let's hope this doesn't get dested. */
	sv_2mortal(node);

	return node;

#if 0
	return sv_bless(newRV_noinc(stars),
			gv_stashpv(_AMD "::Compiler::Type", TRUE));
#endif
}

/* Can I pass mods as a primitive integer, and not bother if they
 * are zero? This applies to functions as well. */
static SV *
yyparse_variable(SV *name, const char *type, SV *stars, SV *mods)
{
	static SV	*class = NULL;

Compiler/parser.y  view on Meta::CPAN 

%left '.'
%left '+' '-'
%left '*' '%' '/'
%right '!' '~'
%nonassoc L_INC L_DEC

/* These aren't strictly necessary, but they help debugging. */

%token '{' '}' ',' ';' ':' '(' ')' '[' ']' '=' '$'

	/* I should have a new type 'node' in here for blessed objects
	 * which are specifically parse nodes. */
	/* It is very very tempting to expand this to say 12 bytes
	 * to save on the use of AVs for type declarators. */
%union {
	int			 number;
	const char	*str;
	SV			*sv;
	SV			*obj;
	AV			*av;
	struct _assoc_t {

Compiler/typemap  view on Meta::CPAN 

############################
INPUT
T_BLESS_SVREF
	if (sv_isa($arg, \"${ntype}\"))
		$var = SvPV_nolen(SvRV($arg));
	else
		croak(\"$var is not of type ${ntype}\");
############################
OUTPUT
T_BLESS_SVREF
	sv_setsv($arg, sv_bless(newRV_noinc(newSVpv($var, 0)),
					gv_stashpv("$Package", TRUE)));

Efun/Core/Core.pm  view on Meta::CPAN 

# XXX Where should I be requiring these: before or after bootstrap?

use Anarres::Mud::Driver::Compiler::Type qw(:all);	# We do this twice?!

# Efuns need to be normal functions in a program symbol table but
# will not inherit or issue a warning if redefined.

# Note that we don't actually register all available efuns. We
# register only those which are visible as efuns to the LPC code.
# We may have more efuns, an individual efun typecheck_call method
# may decide to rebless the node into a different efun class.
# For example, map => map_array or map_mapping. In this way we
# can use the Perl object oriented dispatch mechanism to speed up
# many operations where a pure Perl conditional would be slower.

require DynaLoader;

$VERSION = 0.10;
@ISA = qw(DynaLoader);

bootstrap Anarres::Mud::Driver::Efun::Core;

Type/Type.xs  view on Meta::CPAN 


	len = strlen(str);

	svp = hv_fetch(amd_typecache, str, len, FALSE);
	if (svp)
		return *svp;

	// fprintf(stderr, "Creating new type %s\n", str);

	sv = newSVpvn(str, len);
	bsv = sv_bless(
			newRV_noinc(sv),
					gv_stashpv(_AMD "::Compiler::Type", TRUE));
	hv_store(amd_typecache, str, len, bsv, 0);
	return bsv;
}

#define EXPORT_TYPE(x) do { code[0] = C_ ## x; \
			sv = amd_type_new(code); \
			newCONSTSUB(stash, "T_" #x, sv); \
			av_push(export, newSVpv("T_" #x, strlen(#x) + 2)); \

Type/typemap  view on Meta::CPAN 

############################
INPUT
T_BLESS_SVREF
	if (sv_isa($arg, \"${ntype}\"))
		$var = SvPV_nolen(SvRV($arg));
	else
		croak(\"$var is not of type ${ntype}\");
############################
OUTPUT
T_BLESS_SVREF
	sv_setsv($arg, sv_bless(newRV_noinc(newSVpv($var, 0)),
					gv_stashpv("$Package", TRUE)));

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


	return @errors if @errors;

	# Hack the node gratuitously. Should I use 2+$#tvals?
	splice(@$self, 2, $#$self, @tvals);
	$self->settype($rettype);

	# We might also have a package change.
	my $package = ref($self);
	$package =~ s/::[^:]*$/::$opcode/;
	bless $self, $package;

	return ();
}

sub choose {
	my ($self, $program, @rest) = @_;

	$self->tc_start;

	my $opcode = $self->opcode;

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

		}
		# elsif ($var = $program->static($name)) {
		#	$class ='Anarres::Mud::Driver::Compiler::Node::VarStatic';
		# }
		else {
			$program->error("Variable $name not found");
			# XXX Should we fake something up? We end up
			# dying later if we leave a Variable in the tree.
			return $self->tc_fail;
		}
		bless $self, $class;
		$self->settype($var->type);
		return $self->tc_end;
	}
	# XXX As an rvalue? Delegate to a basic type infer method.
	# XXX If it's an rvalue then it must be initialised. Also for ++, --
}

{
	package Anarres::Mud::Driver::Compiler::Node::VarStatic;
	sub lvaluep { 1; }

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

		$idx->check($program, @rest)
			or push(@errors, "Failed to check index " . $idx->opcode);
		$val->type->is_array
			or push(@errors, "Cannot perform array index on " .
							$val->type->name);
		$idx->type->equals(T_INTEGER)
			or push(@errors, "Cannot index on array with " .
							$idx->type->name);
		return @errors if @errors;
		$self->settype($val->type->dereference);
		bless $self, __PACKAGE__;
		return ();
	}
}

{
	package Anarres::Mud::Driver::Compiler::Node::MapIndex;
	__PACKAGE__->steal("Index", "lvaluep");

	sub convert {
		my ($self, $program, @rest) = @_;

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

		# XXX Make this use promotion properly.
		$idx->type->equals(T_STRING)
			||
		$idx->type->equals(T_INTEGER)
			or push(@errors, "Cannot index on mapping with " .
							$idx->type->name);
		return @errors if @errors;
		$endp
			and $program->error("Cannot index from end of mapping");
		$self->settype($val->type->dereference);
		bless $self, __PACKAGE__;
		return ();
	}
}

{
	package Anarres::Mud::Driver::Compiler::Node::Member;
	sub lvaluep {
		if ($_[0]->value(0)->lvaluep) {
			$_[0]->setflag(F_LVALUE);
			return 1;

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

		my $type = $program->class_type($cname);
		$self->settype($type);	# Might be T_FAILED
		return $self->tc_end;
	}
}

# 1. Promote things to blocks.
# 2. Check children
# 3. Check that things are lvalues.
# 4. Check that things are appropriate types.
# 5. Rebless the current node.
# 6. Set the type of the current node.
# 7. Return a success or failure.

{
	package Anarres::Mud::Driver::Compiler::Node::Sscanf;
	# This should be $_[1], @{$_[2]}
	sub check {
		my ($self, $program, $flags, @rest) = @_;
		my @values = $self->values;
		$self->tc_start;

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


{
	package Anarres::Mud::Driver::Compiler::Node::StmtForeach;
	# This method does a lot of the common stuff for the two
	# 'subclasses'. I could alternatively use a 'choose' here...
	sub check {
		my ($self, $program, @rest) = @_;
		my $ret;
		$self->tc_start;

		# Actually, I can rebless before I check the children!
		if ($self->value(1)) {	# Second lvalue
			bless $self, ref($self) . "Map";
		}
		else {
			bless $self, ref($self) . "Arr";
		}
		$self->settype(T_VOID);

		$self->idx_promote_to_block(3);
		my @values = $self->values;
		$self->check_children(\@values, $program, @rest)
						or return undef;

		return $self->check($program, @rest);
	}

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

# use Anarres::Mud::Driver::Compiler::Check;
# use Anarres::Mud::Driver::Compiler::Generate;

# Meanwhile, back in the Node package...

sub new {
	my ($class, @vals) = @_;
	# die "Construct invalid node type $class" unless $class =~ /::/;
	# print "Construct node $class with " . scalar(@vals) . " values\n";
	my $self = [ undef, 0, @vals ];	# type, flags, vals
	return bless $self, $class;
}

# The format of a node is [ type, flags, value0, value1, ... ]

sub type	{ $_[0]->[0] }
sub settype { $_[0]->[0] = $_[1] }

sub value	{ $_[0]->[2 + $_[1]] }
sub setvalue{ $_[0]->[2 + $_[1]] = $_[2] }
sub values	{ @{$_[0]}[2..$#{$_[0]}] }

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


sub opcode {
	(my $name = (ref($_[0]) || $_[0])) =~ s/.*:://;
	return $name;
}

sub setopcode {
	my ($self, $newopcode) = @_;
	my $class = ref($self);
	$class =~ s/[^:]+$/$newopcode/;
	bless $self, $class;
	return 1;
}

1;

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

use strict;
use warnings;
use vars qw(@ISA);
use Exporter;

@ISA = qw(Exporter);

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

sub visit_child {
	my ($self, $node, $index) = @_;
	my $child = $node->value($index);
	$child->accept($self);
}

lib/Driver/Program.pm  view on Meta::CPAN 


	$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$//;

lib/Driver/Program.pm  view on Meta::CPAN 

	$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__');

lib/Driver/Program/Variable.pm  view on Meta::CPAN 


# New representation will be [ Type, Flags, Name, Args, Code ]
# Args and Code are only relevant for Method objects.

sub new {
	my $class = shift;
	my $self = ($#_ == 0) ? { %{ (shift) } } : { @_ };
	# Avoid some 'undefined value' warnings late.
	$self->{Flags} = 0 unless exists $self->{Flags};
	die "No type when creating $class\n" unless $self->{Type};
	return bless $self, $class;
}

sub name  { return $_[0]->{Name};  }
sub type  { return $_[0]->{Type};  }
sub flags { return $_[0]->{Flags}; }

sub dump {
	my $self = shift;
	return "([" . $self->type->dump(@_) . "] var " . $self->name . ")";
}



( run in 1.769 second using v1.01-cache-2.11-cpan-b32c08c6d1a )