File Coverage

blib/lib/PDL/PP/CType.pm

Criterion	Covered	Total	%
statement	37	104	35.5
branch	6	42	14.2
condition			n/a
subroutine	7	15	46.6
pod			n/a
total	50	161	31.0

# Represent any C type.
# Type contains the size of arrays, which is either constant
# or resolved (into an object) from resolveobj.

package C::Type;
use Carp;

# new C::Type(resolveobj,str)

sub new {
	my $this = bless {},shift;
	$this->{Resolve} = shift;
	if(@_) {
		$this->parsefrom(shift);
	}
	return $this;
}

sub stripptrs {
	my($this,$str) = @_;
	if($str =~ /^\s*\w+\s*$/) {
		$str =~ s/\s//g;
		$this->{ProtoName} = $str;
		return [];
	} else {
# Now, recall the different C syntaxes. First priority is a pointer:
		my $decl;
		if($str =~ /^\s*\*(.*)$/) {
			$decl = $this->stripptrs($1);
			unshift @$decl,"PTR";
		} elsif($str =~ /^\s*\(.*\)\s*$/) {
# XXX Should try to see if a funccall.
			return $this->stripptrs($1);
		} elsif($str =~ /^(.*)\[([^]]+)\]\s*$/) {
			my $siz = $2;
			print "ARR($str): ($siz)\n" if $::PP_VERBOSE;
			$decl = $this->stripptrs($1);
			unshift @$decl,"ARR($siz)";
			print "ARR($str): ($siz)\n" if $::PP_VERBOSE;
		} else {
			die("Invalid C type '$str'");
		}
		return $decl;
	}
}

# XXX Correct to *real* parsing. This is only a subset.
sub parsefrom {
	my($this,$str) = @_;
# First, take the words in the beginning
	$str =~ /^\s*((?:\w+\b\s*)+)([^[].*)$/;
	my $base = $1; my $decl = $2;
	my $foo = $this->stripptrs($decl);
	$this->{Base} = $base;
	$this->{Chain} = $foo;
}

sub get_decl {
	my($this,$name,$opts) = @_;
	for(@{$this->{Chain}}) {
		if($_ eq "PTR") {$name = "*$name"}
		elsif($_ =~/^ARR\((.*)\)$/) {
			if($opts->{VarArrays2Ptrs}) {
				$name = "*$name";
			} else {
				$name = "($name)[$1]";
			}
		}
		else { confess("Invalid decl") }
	}
	return "$this->{Base} $name";
}

# Useful when parsing argument decls
sub protoname { return shift->{ProtoName} }

sub get_copy {
	my($this,$from,$to) = @_;
	my ($prev,$close);
	if($#{$this->{Chain}} >= 0) {
		# strdup loses portability :(
		return "($to) = malloc(strlen($from)+1); strcpy($to,$from);"
		 if $this->{Base} =~ /^\s*char\s*$/;
                return "($to) = newSVsv($from);"
                 if $this->{Base} =~ /^\s*SV\s*$/;
		my $code = $this->get_malloc($to,$from);
		my ($deref0,$deref1) = ($from,$to);
		for(@{$this->{Chain}}) {
			if($_ eq "PTR") {confess("Cannot alloc pointer, must be array");}
			elsif($_ =~/^ARR\((.*)\)$/) {
				$no++;
				$prev .= "
				  if(!$deref0) {$deref1=0;}
				  else {int __malloc_ind_$no;
					for(__malloc_ind_$no = 0;
						__malloc_ind_$no < $1;
						__malloc_ind_$no ++) {";
				$deref0 = $deref0."[__malloc_ind_$no]";
				$deref1 = $deref1."[__malloc_ind_$no]";
				$close .= "}}";
			} else { confess("Invalid decl $_") }
		}
		$code .= "$prev $deref1 = $deref0; $close";
		return $code;
	}
	return "($to) = ($from);";
}

sub get_free {
	my($this,$from) = @_;
	my ($prev,$close);
	if($#{$this->{Chain}} >= 0) {
		return "free($from);"
		 if $this->{Base} =~ /^\s*char\s*$/;
                return "SvREFCNT_dec($from);"
                 if $this->{Base} =~ /^\s*SV\s*$/;
		my @mallocs;
		my $str = "{";
		my $deref = "$from";
		my $prev = undef;
		my $close = undef;
		my $no = 0;
		for(@{$this->{Chain}}) {
			$no++;
			if($no > 1) {croak("Can only free one layer!\n");}
#			if($_ eq "PTR") {confess("Cannot free pointer, must be array ;) (FIX CType.pm)");}
			return "free($from);\n ";
		}
	} else {
		"";
	}
}

sub need_malloc {
	my($this) = @_;
	return scalar grep /(ARR|PTR)/,(@{$this->{Chain}})
}

# Just returns with the array string.
sub get_malloc {
	my($this,$assignto) = @_;
	my $str = "{";
	my $deref = "$assignto";
	my $prev = undef;
	my $close = undef;
	my $no = 0;
	for(@{$this->{Chain}}) {
		if($_ eq "PTR") {confess("Cannot alloc pointer, must be array");}
		elsif($_ =~/^ARR\((.*)\)$/) {
			$str .= "$prev $assignto =
				malloc(sizeof(* $assignto) * $1);
				";
			$no++;
			$prev = "{int __malloc_ind_$no;
				for(__malloc_ind_$no = 0;
					__malloc_ind_$no < $1;
					__malloc_ind_$no ++) {";
			$deref = $deref."[__malloc_ind_$no]";
			$close .= "}}";
		} else { confess("Invalid decl $_") }
	}
	$str .= "}";
	return $str;
}

sub getvar {
}

# Determine if everything constant and can just declare
sub need_alloc {
}

sub alloccode {
}

sub copycode {
}

sub freecode {
}

1;