"Fossies" - the Fresh Open Source Software Archive  

Source code changes of the file "Basic/Gen/PP/CType.pm" between
PDL-2.082.tar.gz and PDL-2.083.tar.gz

About: PDL (Perl Data Language) aims to turn perl into an efficient numerical language for scientific computing (similar to IDL and MatLab).

CType.pm  (PDL-2.082)	:	CType.pm  (PDL-2.083)
skipping to change at line 20		skipping to change at line 20
# new PDL::PP::CType(resolveobj,str)		# new PDL::PP::CType(resolveobj,str)
sub new {		sub new {
my $this = bless {},shift;		my $this = bless {},shift;
$this->parsefrom(shift) if @_;		$this->parsefrom(shift) if @_;
return $this;		return $this;
}		}
sub stripptrs {		sub stripptrs {
my($this,$str) = @_;		my($this,$str) = @_;
		$this->{WasDollar} = 1 if $str =~ s/^\$//;
if($str =~ s/^\s*(\w+)\s*$/$1/g) {		if($str =~ s/^\s*(\w+)\s*$/$1/g) {
$this->{ProtoName} = $str;		$this->{ProtoName} = $str;
return [];		return [];
}		}
# Now, recall the different C syntaxes. First priority is a pointer:		# Now, recall the different C syntaxes. First priority is a pointer:
return [["PTR"], @{$this->stripptrs($1)}] if $str =~ /^\s*\*(.*)$/;		return [["PTR"], @{$this->stripptrs($1)}] if $str =~ /^\s*\*(.*)$/;
return $this->stripptrs($1) if $str =~ /^\s*\(.*\)\s*$/; # XXX Should try to see if a funccall.		return $this->stripptrs($1) if $str =~ /^\s*\(.*\)\s*$/; # XXX Should try to see if a funccall.
return [["ARR",$2], @{$this->stripptrs($1)}] if $str =~ /^(.*)\[([^]]*)\] \s*$/;		return [["ARR",$2], @{$this->stripptrs($1)}] if $str =~ /^(.*)\[([^]]*)\] \s*$/;
Carp::confess("Invalid C type '$str'");		Carp::confess("Invalid C type '$str'");
}		}
# XXX Correct to *real* parsing. This is only a subset.		# XXX Correct to *real* parsing. This is only a subset.
sub parsefrom {		sub parsefrom {
my($this,$str) = @_;		my($this,$str) = @_;
# First, take the words in the beginning		# First, take the words in the beginning
$str =~ /^\s*((?:\w+\b\s*)+)([^[].*)$/;		$str =~ /^\s*((?:\w+\b\s*)+)([^[].*)$/;
$this->{Base} = $1;		@$this{qw(Base Chain)} = ($1, $this->stripptrs($2));
$this->{Chain} = $this->stripptrs($2);
}		}
sub get_decl {		sub get_decl {
my($this,$name,$opts) = @_;		my($this,$name,$opts) = @_;
for(@{$this->{Chain}}) {		for(@{$this->{Chain}}) {
my ($type, $arg) = @$_;		my ($type, $arg) = @$_;
if($type eq "PTR") {$name = "*$name"}		if($type eq "PTR") {$name = "*$name"}
elsif($type eq "ARR") {		elsif($type eq "ARR") {
if($opts->{VarArrays2Ptrs}) {		if($opts->{VarArrays2Ptrs}) {
$name = "*$name";		$name = "*$name";
skipping to change at line 62		skipping to change at line 62
}		}
$name = "*$name" if $opts->{AddIndirect};		$name = "*$name" if $opts->{AddIndirect};
return "$this->{Base} $name";		return "$this->{Base} $name";
}		}
# Useful when parsing argument decls		# Useful when parsing argument decls
sub protoname { return shift->{ProtoName} }		sub protoname { return shift->{ProtoName} }
sub get_copy {		sub get_copy {
my($this,$from,$to) = @_;		my($this,$from,$to) = @_;
return "($to) = ($from);" if !@{$this->{Chain}};		return "($to) = ($from); /* CType.get_copy */" if !@{$this->{Chain}};
# strdup loses portability :(		# strdup loses portability :(
return "($to) = malloc(strlen($from)+1); strcpy($to,$from);"		return "($to) = malloc(strlen($from)+1); strcpy($to,$from); /* CType.get_ copy */"
if $this->{Base} =~ /^\s*char\s*$/;		if $this->{Base} =~ /^\s*char\s*$/;
return "($to) = newSVsv($from);" if $this->{Base} =~ /^\s*SV\s*$/;		return "($to) = newSVsv($from); /* CType.get_copy */" if $this->{Base} =~ /^\s*SV\s*$/;
my $code = $this->get_malloc($to,$from);		my $code = $this->get_malloc($to,$from);
return "($to) = ($from);" if !defined $code; # pointer		return "($to) = ($from); /* CType.get_copy */" if !defined $code; # point er
my ($deref0,$deref1,$prev,$close) = ($from,$to);		my ($deref0,$deref1,$prev,$close) = ($from,$to);
my $no = 0;		my $no = 0;
for(@{$this->{Chain}}) {		for(@{$this->{Chain}}) {
my ($type, $arg) = @$_;		my ($type, $arg) = @$_;
if($type eq "PTR") {confess("Cannot copy pointer, must be array") ;}		if($type eq "PTR") {confess("Cannot copy pointer, must be array") ;}
elsif($type eq "ARR") {		elsif($type eq "ARR") {
$no++;		$no++;
$arg = "$this->{ProtoName}_count" if $this->is_array;		$arg = "$this->{ProtoName}_count" if $this->is_array;
$prev .= PDL::PP::pp_line_numbers(__LINE__-1, "		$prev .= "
if(!$deref0) {$deref1=0;}		if(!$deref0) {$deref1=0;} /* CType.get_copy */
else {int __malloc_ind_$no;		else {int __malloc_ind_$no;
for(__malloc_ind_$no = 0;		for(__malloc_ind_$no = 0;
__malloc_ind_$no < $arg;		__malloc_ind_$no < $arg;
__malloc_ind_$no ++) {");		__malloc_ind_$no ++) {";
$deref0 = $deref0."[__malloc_ind_$no]";		$deref0 .= "[__malloc_ind_$no]";
$deref1 = $deref1."[__malloc_ind_$no]";		$deref1 .= "[__malloc_ind_$no]";
$close .= "}}";		$close .= "}}";
} else { confess("Invalid decl @$_") }		} else { confess("Invalid decl @$_") }
}		}
$code .= "$prev $deref1 = $deref0; $close";		$code .= "$prev $deref1 = $deref0; $close";
return $code;		return $code;
}		}
sub get_free {		sub get_free {
my($this,$from) = @_;		my($this,$from) = @_;
		my $single_ptr = @{$this->{Chain}} == 1 && $this->{Chain}[0][0] eq 'PTR';
		return "SvREFCNT_dec($from); /* CType.get_free */\n" if $this->{Base} =~
		/^\s*SV\s*$/ and $single_ptr;
		return "free($from); /* CType.get_free */\n" if $this->{Base} =~ /^\s*cha
		r\s*$/ and $single_ptr;
return "" if !@{$this->{Chain}} or $this->{Chain}[0][0] eq 'PTR';		return "" if !@{$this->{Chain}} or $this->{Chain}[0][0] eq 'PTR';
return "free($from);" if $this->{Base} =~ /^\s*char\s*$/;
return "SvREFCNT_dec($from);" if $this->{Base} =~ /^\s*SV\s*$/;
croak("Can only free one layer!\n") if @{$this->{Chain}} > 1;		croak("Can only free one layer!\n") if @{$this->{Chain}} > 1;
"free($from);";		"free($from); /* CType.get_free */\n";
}		}
sub need_malloc {		sub need_malloc {
my($this) = @_;		my($this) = @_;
grep /(ARR|PTR)/, map $_->[0], @{$this->{Chain}};		grep /(ARR|PTR)/, map $_->[0], @{$this->{Chain}};
}		}
# returns with the array string - undef if a pointer not needing malloc		# returns with the array string - undef if a pointer not needing malloc
sub get_malloc {		sub get_malloc {
my($this,$assignto) = @_;		my($this,$assignto) = @_;
my $str = "";		my $str = "";
for(@{$this->{Chain}}) {		for(@{$this->{Chain}}) {
my ($type, $arg) = @$_;		my ($type, $arg) = @$_;
if($type eq "PTR") {return}		if($type eq "PTR") {return}
elsif($type eq "ARR") {		elsif($type eq "ARR") {
$arg = "$this->{ProtoName}_count" if $this->is_array;		$arg = "$this->{ProtoName}_count" if $this->is_array;
$str .= PDL::PP::pp_line_numbers(__LINE__-1, "$assignto = malloc(sizeof(*$ assignto) * $arg);\n");		$str .= "$assignto = malloc(sizeof(*$assignto) * $arg); /* CType.get_mallo c */\n";
} else { confess("Invalid decl (@$_)") }		} else { confess("Invalid decl (@$_)") }
}		}
return $str;		return $str;
}		}
sub is_array {		sub is_array {
my ($self) = @_;		my ($self) = @_;
@{$self->{Chain}} &&		@{$self->{Chain}} &&
@{$self->{Chain}[0]} &&		@{$self->{Chain}[-1]} &&
$self->{Chain}[0][0] eq 'ARR' &&		$self->{Chain}[-1][0] eq 'ARR' &&
!$self->{Chain}[0][1];		!$self->{Chain}[-1][1];
}		}
1;		1;
End of changes. 13 change blocks.
18 lines changed or deleted		21 lines changed or added

---