"Fossies" - the Fresh Open Source Software Archive  

Source code changes of the file "Basic/Gen/PP/PDLCode.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).

PDLCode.pm  (PDL-2.082)	:	PDLCode.pm  (PDL-2.083)
skipping to change at line 13		skipping to change at line 13
#		#
# This is what makes the nice loops go around etc.		# This is what makes the nice loops go around etc.
#		#
package PDL::PP::Code;		package PDL::PP::Code;
use strict;		use strict;
use warnings;		use warnings;
use Carp;		use Carp;
sub get_pdls {my($this) = @_; return ($this->{ParNames},$this->{ParObjs});}		sub get_pdls { @{$_[0]}{qw(ParNames ParObjs)} }
my @code_args_always = qw(BadFlag SignatureObj GenericTypes ExtraGenericSwitches HaveBroadcasting Name);		my @code_args_always = qw(BadFlag SignatureObj GenericTypes ExtraGenericSwitches HaveBroadcasting Name);
sub make_args {		sub make_args {
my ($target) = @_;		my ($target) = @_;
("${target}CodeParsed", ["${target}CodeUnparsed",\"Bad${target}CodeUnparsed",@ code_args_always]);		("${target}CodeParsed", ["${target}CodeUnparsed","Bad${target}CodeUnparsed?",@ code_args_always]);
}		}
# Do the appropriate substitutions in the code.		# Do the appropriate substitutions in the code.
sub new {		sub new {
my($class,$code,$badcode,		my($class,$code,$badcode,
$handlebad, $sig,$generictypes,$extrageneric,$havebroadcasting,$name,		$handlebad, $sig,$generictypes,$extrageneric,$havebroadcasting,$name,
$dont_add_brcloop, $backcode, $nulldatacheck) = @_;		$dont_add_brcloop, $backcode, $nulldatacheck) = @_;
my $parnames = $sig->names_sorted;		my $parnames = $sig->names_sorted;
die "Error: missing name argument to PDL::PP::Code->new call!\n"		die "Error: missing name argument to PDL::PP::Code->new call!\n"
skipping to change at line 65		skipping to change at line 65
. "}\n";		. "}\n";
print "ParNAMES: ",(join ',',@$parnames),"\n";		print "ParNAMES: ",(join ',',@$parnames),"\n";
print "GENTYPES: ", @$generictypes, "\n";		print "GENTYPES: ", @$generictypes, "\n";
print "HandleBad: $handlebad\n";		print "HandleBad: $handlebad\n";
}		}
my $this = bless {		my $this = bless {
IndObjs => $sig->dims_obj,		IndObjs => $sig->dims_obj,
ParNames => $parnames,		ParNames => $parnames,
ParObjs => $sig->objs,		ParObjs => $sig->objs,
Sig => $sig,		Sig => $sig,
Gencurtype => [], # stack to hold GenType in generic loops		Gencurtype => [], # stack to hold GenType in generic switches
ftypes_vars => {},		ftypes_vars => {},
ftypes_type => undef,		ftypes_type => undef,
Generictypes => $generictypes, # so that MacroAccess can check it		Generictypes => $generictypes, # so that MacroAccess can check it
Name => $name,		Name => $name,
NullDataCheck => $nulldatacheck,		NullDataCheck => $nulldatacheck,
}, $class;		}, $class;
# First, separate the code into an array of C fragments (strings),		my @codes = $code;
# variable references (strings starting with $) and		push @codes, $badcode if $handlebad && ($code ne $badcode || $badcode =~ /PD
# loops (array references, 1. item = variable.		L_BAD_CODE|PDL_IF_BAD/);
#		my (@coderefs, @sizeprivs);
my ( $broadcastloops, $coderef, $sizeprivs ) =		for my $c (@codes) {
$this->separate_code( "{\n$code\n}" );		# First, separate the code into an array of C fragments (strings),
		# variable references (strings starting with $) and
# Now, if there is no explicit broadcastlooping in the code,		# loops (array references, 1. item = variable.
# enclose everything into it.		my ( $broadcastloops, $coderef, $sizeprivs ) =
if(!$broadcastloops && !$dont_add_brcloop) {		$this->separate_code( "{$c}" );
print "Adding broadcastloop...\n" if $::PP_VERBOSE;		# Now, if there is no explicit broadcastlooping in the code,
my $nc = $coderef;		# enclose everything into it.
$coderef = $backcode		if(!$broadcastloops && !$dont_add_brcloop) {
? PDL::PP::BackCodeBroadcastLoop->new() : PDL::PP::BroadcastLoop->new()		print "Adding broadcastloop...\n" if $::PP_VERBOSE;
;		$coderef = $coderef->enter(('PDL::PP::'.($backcode ? 'BackCode' : '').
push @{$coderef},$nc;		'BroadcastLoop')->new);
		}
		# Enclose it all in a generic switch.
		my $if_gentype = ($code.($badcode//'')) =~ /PDL_IF_GENTYPE_/;
		$coderef = $coderef->enter(PDL::PP::GenericSwitch->new($generictypes, unde
		f,
		[grep {!$extrageneric->{$_}} @$parnames],'$PRIV(__datatype)',$if_gentype
		));
		# Do we have extra generic switches?
		# If we do, first reverse the hash:
		my %glh;
		push @{$glh{$extrageneric->{$_}}},$_ for sort keys %$extrageneric;
		my $no = 0;
		$coderef = $coderef->enter(PDL::PP::GenericSwitch->new($generictypes,$no++
		,
		$glh{$_},$_,$if_gentype)) for sort keys %glh;
		push @coderefs, $coderef;
		push @sizeprivs, $sizeprivs;
}		}
		amalgamate_sizeprivs(@sizeprivs) if @sizeprivs > 1;
# repeat for the bad code, then stick good and bad into		my $sizeprivs = $sizeprivs[0];
# a BadSwitch object which creates the necessary		my $coderef = @coderefs > 1 ? PDL::PP::BadSwitch->new( @coderefs ) : $codere
# 'if (bad) { badcode } else { goodcode }' code		fs[0];
#
# NOTE: amalgamate sizeprivs from good and bad code
#
if ( $handlebad && ($code ne $badcode || $badcode =~ /PDL_BAD_CODE|PDL_IF_BA
D/) ) {
print "Processing 'bad' code...\n" if $::PP_VERBOSE;
my ( $bad_broadcastloops, $bad_coderef, $bad_sizeprivs ) =
$this->separate_code( "{\n$badcode\n}" );
if(!$bad_broadcastloops && !$dont_add_brcloop) {
print "Adding 'bad' broadcastloop...\n" if $::PP_VERBOSE;
my $nc = $bad_coderef;
if( !$backcode ){ # Normal readbackdata broadcastloop
$bad_coderef = PDL::PP::BroadcastLoop->new();
}
else{ # writebackcode broadcastloop
$bad_coderef = PDL::PP::BackCodeBroadcastLoop->new();
}
push @{$bad_coderef},$nc;
}
my $good_coderef = $coderef;
$coderef = PDL::PP::BadSwitch->new( $good_coderef, $bad_coderef );
# amalgamate sizeprivs from Code/BadCode segments
# (sizeprivs is a simple hash, with each element
# containing a string - see PDL::PP::Loop)
while ( my ( $bad_key, $bad_str ) = each %$bad_sizeprivs ) {
my $str = $$sizeprivs{$bad_key};
die "ERROR: sizeprivs problem in PP/PDLCode.pm (BadVal stuff)\n"
if defined $str and $str ne $bad_str;
$$sizeprivs{$bad_key} = $bad_str; # copy over
}
} # if: $handlebad
print "SIZEPRIVSX: ",(join ',',%$sizeprivs),"\n" if $::PP_VERBOSE;		print "SIZEPRIVSX: ",(join ',',%$sizeprivs),"\n" if $::PP_VERBOSE;
# Enclose it all in a genericloop.
my $nc = $coderef;
my $if_gentype = ($code.($badcode//'')) =~ /PDL_IF_GENTYPE_/;
$coderef = PDL::PP::GenericSwitch->new($generictypes, undef,
[grep {!$extrageneric->{$_}} @$parnames],'$PRIV(__datatype)',$if_gentyp
e);
push @{$coderef},$nc;
# Do we have extra generic loops?
# If we do, first reverse the hash:
my %glh;
for(sort keys %$extrageneric) {
push @{$glh{$extrageneric->{$_}}},$_;
}
my $no = 0;
for(sort keys %glh) {
my $nc = $coderef;
$coderef = PDL::PP::GenericSwitch->new($generictypes,$no++,
$glh{$_},$_,$if_gentype);
push @$coderef,$nc;
}
my $pobjs = $sig->objs;		my $pobjs = $sig->objs;
# Then, in this form, put it together what we want the code to actually do.		# Then, in this form, put it together what we want the code to actually do.
print "SIZEPRIVS: ",(join ',',%$sizeprivs),"\n" if $::PP_VERBOSE;		print "SIZEPRIVS: ",(join ',',%$sizeprivs),"\n" if $::PP_VERBOSE;
$this->{Code} = (join '',sort values %$sizeprivs).		$this->{Code} = (join '',sort values %$sizeprivs).
($dont_add_brcloop?'':PDL::PP::pp_line_numbers __LINE__, join "\n",		($dont_add_brcloop?'':join '', map "$_\n",
'PDL_COMMENT("broadcastloop declarations")',		'PDL_COMMENT("broadcastloop declarations")',
'int __brcloopval;',		'int __brcloopval;',
'register PDL_Indx __tind0,__tind1; PDL_COMMENT("counters along dim")',		'register PDL_Indx __tind0,__tind1; PDL_COMMENT("counters along dim")',
'register PDL_Indx __tnpdls = $PRIV(broadcast).npdls;',		'register PDL_Indx __tnpdls = $PRIV(broadcast).npdls;',
'PDL_COMMENT("dims here are how many steps along those dims")',		'PDL_COMMENT("dims here are how many steps along those dims")',
(map "register PDL_Indx __tinc0_$parnames->[$_] = PDL_BRC_INC(\$PRIV(bro adcast).incs,__tnpdls,$_,0);", 0..$#$parnames),		(map "register PDL_Indx __tinc0_$parnames->[$_] = PDL_BRC_INC(\$PRIV(bro adcast).incs,__tnpdls,$_,0);", 0..$#$parnames),
(map "register PDL_Indx __tinc1_$parnames->[$_] = PDL_BRC_INC(\$PRIV(bro adcast).incs,__tnpdls,$_,1);", 0..$#$parnames),		(map "register PDL_Indx __tinc1_$parnames->[$_] = PDL_BRC_INC(\$PRIV(bro adcast).incs,__tnpdls,$_,1);", 0..$#$parnames),
eol_protect(		eol_protect(
"#define ".$this->broadcastloop_macroname($backcode, 'START') . " " .		"#define ".$this->broadcastloop_macroname($backcode, 'START') . " " .
$this->broadcastloop_start($this->func_name($backcode))		$this->broadcastloop_start($this->func_name($backcode))
)."\n",		),
eol_protect(		eol_protect(
"#define ".$this->broadcastloop_macroname($backcode, 'END') . " " .		"#define ".$this->broadcastloop_macroname($backcode, 'END') . " " .
$this->broadcastloop_end		$this->broadcastloop_end
)."\n",		),
join('',map $_->get_incregisters, @$pobjs{sort keys %$pobjs}),		(grep $_, map $_->get_incregisters, @$pobjs{sort keys %$pobjs}),
).		).
$this->params_declare.		$this->params_declare.
$coderef->get_str($this,[])		$coderef->get_str($this,[])
;		;
$this->{Code};		$this->{Code};
		} # new
} # new()		# amalgamate sizeprivs from Code/BadCode segments
		# (sizeprivs is a simple hash, with each element
		# containing a string - see PDL::PP::Loop)
		sub amalgamate_sizeprivs {
		my ($sizeprivs, $bad_sizeprivs) = @_;
		while ( my ( $bad_key, $bad_str ) = each %$bad_sizeprivs ) {
		my $str = $$sizeprivs{$bad_key};
		die "ERROR: sizeprivs problem in PP/PDLCode.pm (BadVal stuff)\n"
		if defined $str and $str ne $bad_str;
		$$sizeprivs{$bad_key} = $bad_str; # copy over
		}
		}
sub eol_protect {		sub eol_protect {
my ($text) = @_;		my ($text) = @_;
join " \\\n", split /\n/, $text;		join " \\\n", grep /\S/, split /\n/, $text;
}		}
sub params_declare {		sub params_declare {
my ($this) = @_;		my ($this) = @_;
my ($ord,$pdls) = $this->get_pdls;		my ($ord,$pdls) = $this->get_pdls;
my @decls = map $_->get_xsdatapdecl("PDL_PARAMTYPE_".$_->name, $this->{NullD		my %istyped = map +($_=>1), grep $pdls->{$_}{FlagTypeOverride}, @$ord;
ataCheck}),		my @decls = map $_->get_xsdatapdecl($istyped{$_->name} ? "PDL_TYPE_PARAM_".$
		_->name : "PDL_TYPE_OP", $this->{NullDataCheck}),
map $pdls->{$_}, @$ord;		map $pdls->{$_}, @$ord;
my @param_names = map "PDL_PARAMTYPE_$_", @$ord;		my @param_names = ("PDL_TYPE_OP", map "PDL_TYPE_PARAM_$_", grep $istyped{$_}
PDL::PP::pp_line_numbers(__LINE__, <<EOF);		, @$ord);
		<<EOF;
#ifndef PDL_DECLARE_PARAMS_$this->{Name}_$this->{NullDataCheck}		#ifndef PDL_DECLARE_PARAMS_$this->{Name}_$this->{NullDataCheck}
#define PDL_DECLARE_PARAMS_$this->{Name}_$this->{NullDataCheck}(@{[join ',', @pa ram_names]}) \\		#define PDL_DECLARE_PARAMS_$this->{Name}_$this->{NullDataCheck}(@{[join ',', @pa ram_names]}) \\
@{[join " \\\n", @decls]}		@{[join " \\\n ", @decls]}
#endif		#endif
EOF		EOF
}		}
sub func_name { $_[1] ? "writebackdata" : "readdata" }		sub func_name { $_[1] ? "writebackdata" : "readdata" }
sub broadcastloop_macroname {		sub broadcastloop_macroname {
my ($this, $backcode, $which) = @_;		my ($this, $backcode, $which) = @_;
"PDL_BROADCASTLOOP_${which}_$this->{Name}_".$this->func_name($backcode);		"PDL_BROADCASTLOOP_${which}_$this->{Name}_".$this->func_name($backcode);
}		}
sub broadcastloop_start {		sub broadcastloop_start {
my ($this, $funcname) = @_;		my ($this, $funcname) = @_;
my ($ord,$pdls) = $this->get_pdls;		my ($ord,$pdls) = $this->get_pdls;
<<EOF;		<<EOF;
PDL_BROADCASTLOOP_START(		PDL_BROADCASTLOOP_START(
$funcname,		$funcname,
\$PRIV(broadcast),		\$PRIV(broadcast),
\$PRIV(vtable),		\$PRIV(vtable),
@{[ join "", map "\t".$pdls->{$ord->[$_]}->do_pointeraccess." += __offsp[$_];\n"		@{[ PDL::PP::indent 2, join "", map $pdls->{$ord->[$_]}->do_pointeraccess." += _
, 0..$#$ord ]},		_offsp[$_];\n", 0..$#$ord ]} ,
(@{[ join "", map "\t,".$pdls->{$ord->[$_]}->do_pointeraccess." += __tinc1_$ord-		(@{[ PDL::PP::indent 2, join "", map ",".$pdls->{$ord->[$_]}->do_pointeraccess
>[$_] - __tinc0_$ord->[$_] * __tdims0\n", 0..$#$ord ]}),		." += __tinc1_$ord->[$_] - __tinc0_$ord->[$_] * __tdims0\n", 0..$#$ord ]} ),
(@{[ join "", map "\t,".$pdls->{$ord->[$_]}->do_pointeraccess." += __tinc0_$ord-		(@{[ PDL::PP::indent 2, join "", map ",".$pdls->{$ord->[$_]}->do_pointeraccess
>[$_]\n", 0..$#{$ord} ]})		." += __tinc0_$ord->[$_]\n", 0..$#{$ord} ]} )
)		)
EOF		EOF
}		}
sub broadcastloop_end {		sub broadcastloop_end {
my ($this) = @_;		my ($this) = @_;
my ($ord,$pdls) = $this->get_pdls();		my ($ord,$pdls) = $this->get_pdls();
<<EOF;		<<EOF;
PDL_BROADCASTLOOP_END(		PDL_BROADCASTLOOP_END(
\$PRIV(broadcast),		\$PRIV(broadcast),
@{[ join "", map $pdls->{$ord->[$_]}->do_pointeraccess." -= __tinc1_$ord->[$_] *		@{[ PDL::PP::indent 2, join "", map $pdls->{$ord->[$_]}->do_pointeraccess." -= _
__tdims1 + __offsp[$_];\n", 0..$#$ord ]}		_tinc1_$ord->[$_] * __tdims1 + __offsp[$_];\n", 0..$#$ord ]}
)		)
EOF		EOF
}		}
sub sig {$_[0]->{Sig}}		sub sig {$_[0]->{Sig}}
# This sub determines the index name for this index.		# This sub determines the index name for this index.
# For example, a(x,y) and x0 becomes [x,x0]		# For example, a(x,y) and x0 becomes [x,x0]
sub make_loopind { my($this,$ind) = @_;		sub make_loopind { my($this,$ind) = @_;
my $orig = $ind;		my $orig = $ind;
skipping to change at line 386		skipping to change at line 355
#		#
# All objects have two methods:		# All objects have two methods:
# new - constructor		# new - constructor
# get_str - get the string to be put into the xsub.		# get_str - get the string to be put into the xsub.
package PDL::PP::Block;		package PDL::PP::Block;
sub new { my($type) = @_; bless [],$type; }		sub new { my($type) = @_; bless [],$type; }
sub myoffs { 0 }		sub myoffs { 0 }
		sub myextraindent { 0 }
sub myprelude {}		sub myprelude {}
sub mypostlude {}		sub mypostlude {}
sub get_str {		sub get_str {
my ($this,$parent,$context) = @_;		my ($this,$parent,$context) = @_;
my $str = $this->myprelude($parent,$context);		my $str = $this->myprelude($parent,$context);
$str .= $this->get_str_int($parent,$context)//'';		$str .= PDL::PP::indent 2, $this->get_str_int($parent,$context)//'';
$str .= $this->mypostlude($parent,$context)//'';		$str .= $this->mypostlude($parent,$context)//'';
return $str;		return $str;
}		}
sub get_str_int {		sub get_str_int {
my ( $this, $parent, $context ) = @_;		my ( $this, $parent, $context ) = @_;
my $nth=0;		my $nth=0;
my $str = "";		my $str = "";
MYLOOP: while(1) {		MYLOOP: while(1) {
my $it = $this->can('myitemstart') && $this->myitemstart($parent,$nth);		my $it = $this->can('myitemstart') && $this->myitemstart($parent,$nth);
last MYLOOP if $nth and !$it;		last MYLOOP if $nth and !$it;
$str .= $it//'';		$str .= $it//'';
$str .= join '', $this->get_contained($parent,$context);		$str .= PDL::PP::indent $this->myextraindent, join '', $this->get_contained( $parent,$context);
$str .= $it if $it = $this->can('myitemend') && $this->myitemend($parent,$nt h);		$str .= $it if $it = $this->can('myitemend') && $this->myitemend($parent,$nt h);
$nth++;		$nth++;
}		}
return $str;		return $str;
} # get_str_int()		} # get_str_int()
sub get_contained {		sub get_contained {
my ($this, $parent, $context) = @_;		my ($this, $parent, $context) = @_;
map ref($_) ? $_->get_str($parent, $context) : $_,		map ref($_) ? $_->get_str($parent, $context) : $_,
@$this[$this->myoffs..$#$this];		@$this[$this->myoffs..$#$this];
}		}
		sub enter {
		my ($this, $new) = @_;
		push @$new, $this;
		$new;
		}
###########################		###########################
#		#
# Deal with bad code		# Deal with bad code
# - ie create something like		# - ie create something like
# if ( badflag ) { badcode } else { goodcode }		# if ( badflag ) { badcode } else { goodcode }
#		#
package PDL::PP::BadSwitch;		package PDL::PP::BadSwitch;
our @ISA = "PDL::PP::Block";		our @ISA = "PDL::PP::Block";
sub new {		sub new {
my($type,$good,$bad) = @_;		my($type,$good,$bad) = @_;
return bless [$good,$bad], $type;		return bless [$good,$bad], $type;
}		}
sub get_str {		sub get_str {
my ($this,$parent,$context) = @_;		my ($this,$parent,$context) = @_;
my $good = $this->[0];		my $good = $this->[0];
my $bad = $this->[1];		my $bad = $this->[1];
my $str = PDL::PP::pp_line_numbers(__LINE__, <<EOF);		my $str = <<EOF;
if ( \$PRIV(bvalflag) ) { PDL_COMMENT("** do 'bad' Code **")		if ( \$PRIV(bvalflag) ) { PDL_COMMENT("** do 'bad' Code **")
#define PDL_BAD_CODE		#define PDL_BAD_CODE
#define PDL_IF_BAD(t,f) t		#define PDL_IF_BAD(t,f) t
@{[ $bad->get_str($parent,$context) ]}		@{[ PDL::PP::indent 2, $bad->get_str($parent,$context)
#undef PDL_BAD_CODE		]} #undef PDL_BAD_CODE
#undef PDL_IF_BAD		#undef PDL_IF_BAD
} else { PDL_COMMENT("** else do 'good' Code **")		} else { PDL_COMMENT("** else do 'good' Code **")
#define PDL_IF_BAD(t,f) f		#define PDL_IF_BAD(t,f) f
@{[ $good->get_str($parent,$context) ]}		@{[ PDL::PP::indent 2, $good->get_str($parent,$context)
#undef PDL_IF_BAD		]} #undef PDL_IF_BAD
}		}
EOF		EOF
}		}
package PDL::PP::Loop;		package PDL::PP::Loop;
our @ISA = "PDL::PP::Block";		our @ISA = "PDL::PP::Block";
sub new { my($type,$args,$sizeprivs,$parent) = @_;		sub new { my($type,$args,$sizeprivs,$parent) = @_;
my $this = bless [$args],$type;		my $this = bless [$args],$type;
for(@{$this->[0]}) {		for(@{$this->[0]}) {
skipping to change at line 473		skipping to change at line 449
}		}
return $this;		return $this;
}		}
sub myoffs { return 1; }		sub myoffs { return 1; }
sub myprelude { my($this,$parent,$context) = @_;		sub myprelude { my($this,$parent,$context) = @_;
my $text = "";		my $text = "";
push @$context, map {		push @$context, map {
my $i = $parent->make_loopind($_);		my $i = $parent->make_loopind($_);
# Used to be $PRIV(.._size) but now we have it in a register.		# Used to be $PRIV(.._size) but now we have it in a register.
$text .= PDL::PP::pp_line_numbers(__LINE__, <<EOF);		$text .= "{PDL_COMMENT(\"Open $_\") register PDL_Indx $_; for($_=
{PDL_COMMENT(\"Open $_\") register PDL_Indx $_;		0; $_<(__$i->[0]_size); $_++) {";
for($_=0; $_<(__$i->[0]_size); $_++) {
EOF
$i;		$i;
} @{$this->[0]};		} @{$this->[0]};
$text;		$text;
}		}
sub mypostlude { my($this,$parent,$context) = @_;		sub mypostlude { my($this,$parent,$context) = @_;
splice @$context, - ($#{$this->[0]}+1);		splice @$context, - ($#{$this->[0]}+1);
return join '', map PDL::PP::pp_line_numbers(__LINE__-1, "}} PDL_COMMENT( \"Close $_\")"), @{$this->[0]};		return join '', map "}} PDL_COMMENT(\"Close $_\")", @{$this->[0]};
}		}
package PDL::PP::GenericSwitch;		package PDL::PP::GenericSwitch;
		use Carp;
our @ISA = "PDL::PP::Block";		our @ISA = "PDL::PP::Block";
# make the typetable from info in PDL::Types		# make the typetable from info in PDL::Types
use PDL::Types ':All';		use PDL::Types ':All';
		my %type2canonical = map +($_->ppsym=>$_,$_->identifier=>$_), types();
my @typetable = map [$_->ppsym, $_], types();		my @typetable = map [$_->ppsym, $_], types();
sub get_generictyperecs { my($types) = @_;		sub get_generictyperecs { my($types) = @_;
my %wanted; @wanted{@$types} = ();		my @bad = grep !$type2canonical{$_}, @$types;
		confess "Invalid GenericType (@bad)!" if @bad;
		my %wanted; @wanted{map $type2canonical{$_}->ppsym, @$types} = ();
[ map $_->[1], grep exists $wanted{$_->[0]}, @typetable ];		[ map $_->[1], grep exists $wanted{$_->[0]}, @typetable ];
}		}
# Types: BSULFD		# Types: BSULFD
sub new {		sub new {
my ($type,$types,$name,$varnames,$whattype,$if_gentype) = @_;		my ($type,$types,$name,$varnames,$whattype,$if_gentype) = @_;
my %vars; @vars{@$varnames} = ();		my %vars; @vars{@$varnames} = ();
bless [get_generictyperecs($types), $name, \%vars, $whattype, $if_gentype], $type;		bless [get_generictyperecs($types), $name, \%vars, $whattype, $if_gentype], $type;
}		}
sub myoffs {5}		sub myoffs {5}
		sub myextraindent { 2 }
sub myprelude {		sub myprelude {
my ($this,$parent,$context) = @_;		my ($this,$parent,$context) = @_;
push @{$parent->{Gencurtype}}, undef; # so that $GENERIC can get at it		push @{$parent->{Gencurtype}}, undef; # so that $GENERIC can get at it
die "ERROR: need to rethink NaN support in GenericSwitch\n"		die "ERROR: need to rethink NaN support in GenericSwitch\n"
if defined $this->[1] and $parent->{ftypes_type};		if defined $this->[1] and $parent->{ftypes_type};
qq[PDL_COMMENT("Start generic loop")\n\tswitch($this->[3]) {\n];		qq[switch ($this->[3]) { PDL_COMMENT("Start generic switch")\n];
}		}
my @GENTYPE_ATTRS = qw(integer real unsigned);		my @GENTYPE_ATTRS = qw(integer real unsigned);
sub myitemstart {		sub myitemstart {
my ($this,$parent,$nth) = @_;		my ($this,$parent,$nth) = @_;
my $item = $this->[0][$nth] || return "";		my $item = $this->[0][$nth] || return "";
$parent->{Gencurtype}[-1] = $item;		$parent->{Gencurtype}[-1] = $item;
@$parent{qw(ftypes_type ftypes_vars)} = ($item, $this->[2]) if defined $this ->[1];		@$parent{qw(ftypes_type ftypes_vars)} = ($item, $this->[2]) if defined $this ->[1];
my ($ord,$pdls) = $parent->get_pdls;		my ($ord,$pdls) = $parent->get_pdls;
my @param_ctypes = map $pdls->{$_}->adjusted_type($item)->ctype, @$ord;		my %istyped = map +($_=>1), grep $pdls->{$_}{FlagTypeOverride}, @$ord;
		my @param_ctypes = ($item->ctype, map $pdls->{$_}->adjusted_type($item)->cty
		pe, grep $istyped{$_}, @$ord);
my $decls = keys %{$this->[2]} == @$ord		my $decls = keys %{$this->[2]} == @$ord
? PDL::PP::pp_line_numbers(__LINE__-1, "\t\tPDL_DECLARE_PARAMS_$parent->{N ame}_$parent->{NullDataCheck}(@{[join ',', @param_ctypes]})\n")		? "PDL_DECLARE_PARAMS_$parent->{Name}_$parent->{NullDataCheck}(@{[join ',' , @param_ctypes]})\n"
: join '', map $_->get_xsdatapdecl($_->adjusted_type($item)->ctype, $paren t->{NullDataCheck}),		: join '', map $_->get_xsdatapdecl($_->adjusted_type($item)->ctype, $paren t->{NullDataCheck}),
map $parent->{ParObjs}{$_}, sort keys %{$this->[2]};		map $parent->{ParObjs}{$_}, sort keys %{$this->[2]};
my @gentype_decls = !$this->[4] ? () : map "#define PDL_IF_GENTYPE_".uc($_). "(t,f) ".		my @gentype_decls = !$this->[4] ? () : map "#define PDL_IF_GENTYPE_".uc($_). "(t,f) ".
($item->$_ ? 't' : 'f')."\n",		($item->$_ ? 't' : 'f')."\n",
@GENTYPE_ATTRS;		@GENTYPE_ATTRS;
join '',		"case @{[$item->sym]}: {\n" .
PDL::PP::pp_line_numbers(__LINE__-1, "case @{[$item->sym]}: {\n"),		PDL::PP::indent 2, join '',
@gentype_decls,		@gentype_decls,
$decls;		$decls;
}		}
sub myitemend {		sub myitemend {
my ($this,$parent,$nth) = @_;		my ($this,$parent,$nth) = @_;
my $item = $this->[0][$nth] || return "";		my $item = $this->[0][$nth] || return "";
join '',		join '',
"\n",		"\n",
(!$this->[4] ? () : map "#undef PDL_IF_GENTYPE_".uc($_)."\n", @GENTYPE_AT TRS),		(!$this->[4] ? () : map "#undef PDL_IF_GENTYPE_".uc($_)."\n", @GENTYPE_AT TRS),
PDL::PP::pp_line_numbers(__LINE__-1, "} break;\n");		"} break;\n";
}		}
sub mypostlude {		sub mypostlude {
my($this,$parent,$context) = @_;		my($this,$parent,$context) = @_;
pop @{$parent->{Gencurtype}}; # and clean up the Gentype stack		pop @{$parent->{Gencurtype}}; # and clean up the Gentype stack
$parent->{ftypes_type} = undef if defined $this->[1];		$parent->{ftypes_type} = undef if defined $this->[1];
my $supported = join '', map $_->ppsym, @{$this->[0]};		my $supported = join '', map $_->ppsym, @{$this->[0]};
"\n\tdefault:return PDL->make_error(PDL_EUSERERROR, \"PP INTERNAL ERROR in $ parent->{Name}: unhandled datatype(%d), only handles ($supported)! PLEASE MAKE A BUG REPORT\\n\", $this->[3]);}\n";		" default: return PDL->make_error(PDL_EUSERERROR, \"PP INTERNAL ERROR in $p arent->{Name}: unhandled datatype(%d), only handles ($supported)! PLEASE MAKE A BUG REPORT\\n\", $this->[3]);\n}\n";
}		}
####		####
#		#
# This relies on PP.pm making sure that initbroadcaststruct always sets		# This relies on PP.pm making sure that initbroadcaststruct always sets
# up the two first dimensions even when they are not necessary.		# up the two first dimensions even when they are not necessary.
#		#
package PDL::PP::BroadcastLoop;		package PDL::PP::BroadcastLoop;
use Carp;		use Carp;
our @ISA = "PDL::PP::Block";		our @ISA = "PDL::PP::Block";
sub new {		sub new {
my $type = shift;		my $type = shift;
bless [],$type;		bless [],$type;
}		}
sub myoffs { return 0; }		sub myoffs { return 0; }
sub myprelude {		sub myprelude {
my($this,$parent,$context,$backcode) = @_;		my($this,$parent,$context,$backcode) = @_;
$parent->broadcastloop_macroname($backcode, 'START') . "\n";		$parent->broadcastloop_macroname($backcode, 'START');
}		}
sub mypostlude {my($this,$parent,$context,$backcode) = @_;		sub mypostlude {my($this,$parent,$context,$backcode) = @_;
$parent->broadcastloop_macroname($backcode, 'END') . "\n";		$parent->broadcastloop_macroname($backcode, 'END');
}		}
# Simple subclass of BroadcastLoop to implement writeback code		# Simple subclass of BroadcastLoop to implement writeback code
#		#
#		#
package PDL::PP::BackCodeBroadcastLoop;		package PDL::PP::BackCodeBroadcastLoop;
use Carp;		use Carp;
our @ISA = "PDL::PP::BroadcastLoop";		our @ISA = "PDL::PP::BroadcastLoop";
sub myprelude {		sub myprelude {
skipping to change at line 615		skipping to change at line 594
sub new {		sub new {
my($type,$ts,$parent) = @_;		my($type,$ts,$parent) = @_;
my @bad = grep !$types{$_}, my @ts = split '', $ts;		my @bad = grep !$types{$_}, my @ts = split '', $ts;
confess "Invalid type access (@bad) in '$ts'!" if @bad;		confess "Invalid type access (@bad) in '$ts'!" if @bad;
bless [+{map +($_=>1), @ts}],$type; }		bless [+{map +($_=>1), @ts}],$type; }
sub myoffs { return 1; }		sub myoffs { return 1; }
sub get_str {		sub get_str {
my ($this,$parent,$context) = @_;		my ($this,$parent,$context) = @_;
confess "types() outside a generic loop"		confess "types() outside a generic switch"
unless defined(my $type = $parent->{Gencurtype}[-1]);		unless defined(my $type = $parent->{Gencurtype}[-1]);
return '' if !$this->[0]{$type->ppsym};		return '' if !$this->[0]{$type->ppsym};
join '', $this->get_contained($parent,$context);		join '', $this->get_contained($parent,$context);
}		}
package PDL::PP::Access;		package PDL::PP::Access;
use Carp;		use Carp;
sub new { my($type,$pdl,$inds) = @_;		sub new { my($type,$pdl,$inds) = @_;
bless [$pdl,$inds],$type;		bless [$pdl,$inds],$type;
skipping to change at line 662		skipping to change at line 641
);		);
my %getters = (		my %getters = (
'' => sub {my ($obj, $inds, $context)=@_; $obj->do_access($inds,$context)},		'' => sub {my ($obj, $inds, $context)=@_; $obj->do_access($inds,$context)},
PP => sub {my ($obj, $inds)=@_; $obj->do_physpointeraccess.$inds},		PP => sub {my ($obj, $inds)=@_; $obj->do_physpointeraccess.$inds},
VAR => sub {my ($obj, $inds)=@_; $inds},		VAR => sub {my ($obj, $inds)=@_; $inds},
);		);
sub get_str {		sub get_str {
my ($this,$parent,$context) = @_;		my ($this,$parent,$context) = @_;
my ($opcode, $get, $name, $inds) = @$this;		my ($opcode, $get, $name, $inds) = @$this;
confess "generic type access outside a generic loop in $name"		confess "generic type access outside a generic switch in $name"
unless defined $parent->{Gencurtype}[-1];		unless defined $parent->{Gencurtype}[-1];
print "PDL::PP::BadAccess sent [$opcode] [$name] [$inds]\n" if $::PP_VERBOSE ;		print "PDL::PP::BadAccess sent [$opcode] [$name] [$inds]\n" if $::PP_VERBOSE ;
die "ERROR: unknown check <$opcode> sent to PDL::PP::BadAccess\n"		die "ERROR: unknown check <$opcode> sent to PDL::PP::BadAccess\n"
unless defined( my $op = $ops{$opcode} );		unless defined( my $op = $ops{$opcode} );
die "ERROR: something screwy in PDL::PP::BadAccess (PP/PDLCode.pm)\n"		die "ERROR: something screwy in PDL::PP::BadAccess (PP/PDLCode.pm)\n"
unless defined( my $obj = $parent->{ParObjs}{$name} );		unless defined( my $obj = $parent->{ParObjs}{$name} );
my $lhs = $getters{$get}->($obj, $inds, $context);		my $lhs = $getters{$get}->($obj, $inds, $context);
my $rhs = "${name}_badval";		my $rhs = "${name}_badval";
print "DBG: [$lhs $op $rhs]\n" if $::PP_VERBOSE;		print "DBG: [$lhs $op $rhs]\n" if $::PP_VERBOSE;
my $type = exists $parent->{ftypes_vars}{$name}		my $type = exists $parent->{ftypes_vars}{$name}
skipping to change at line 702		skipping to change at line 681
for grep !exists $type2value{$_}, @$gentypes;		for grep !exists $type2value{$_}, @$gentypes;
my %gts; @gts{@$gentypes} = ();		my %gts; @gts{@$gentypes} = ();
warn "Macro for unsupported generic type identifier $_\n"		warn "Macro for unsupported generic type identifier $_\n"
for grep !exists $gts{$_}, @ilst;		for grep !exists $gts{$_}, @ilst;
bless [\%type2value, $name], $type;		bless [\%type2value, $name], $type;
}		}
sub get_str {		sub get_str {
my ($this, $parent, $context) = @_;		my ($this, $parent, $context) = @_;
my ($type2value, $name) = @{$this};		my ($type2value, $name) = @{$this};
confess "generic type access outside a generic loop in $name"		confess "generic type access outside a generic switch in $name"
unless defined $parent->{Gencurtype}[-1];		unless defined $parent->{Gencurtype}[-1];
$type2value->{$parent->{Gencurtype}[-1]->ppsym};		$type2value->{$parent->{Gencurtype}[-1]->ppsym};
}		}
package PDL::PP::GentypeAccess;		package PDL::PP::GentypeAccess;
use Carp;		use Carp;
sub new { my($type,$pdl,$inds) = @_; bless [$inds],$type; }		sub new { my($type,$pdl,$inds) = @_; bless [$inds],$type; }
sub get_str {my($this,$parent,$context) = @_;		sub get_str {my($this,$parent,$context) = @_;
confess "generic type access outside a generic loop"		confess "generic type access outside a generic switch"
unless defined(my $type = $parent->{Gencurtype}[-1]);		unless defined(my $type = $parent->{Gencurtype}[-1]);
return $type->ctype if !$this->[0];		return $type->ctype if !$this->[0];
my $pobj = $parent->{ParObjs}{$this->[0]} // confess "not a defined parname";		my $pobj = $parent->{ParObjs}{$this->[0]} // confess "not a defined parname";
$pobj->adjusted_type($type)->ctype;		$pobj->adjusted_type($type)->ctype;
}		}
package PDL::PP::PpsymAccess;		package PDL::PP::PpsymAccess;
use Carp;		use Carp;
sub new { my($type,$pdl,$inds) = @_; bless [$inds],$type; }		sub new { my($type,$pdl,$inds) = @_; bless [$inds],$type; }
sub get_str {my($this,$parent,$context) = @_;		sub get_str {my($this,$parent,$context) = @_;
confess "generic type access outside a generic loop"		confess "generic type access outside a generic switch"
unless defined(my $type = $parent->{Gencurtype}[-1]);		unless defined(my $type = $parent->{Gencurtype}[-1]);
return $type->ppsym if !$this->[0];		return $type->ppsym if !$this->[0];
my $pobj = $parent->{ParObjs}{$this->[0]} // confess "not a defined parname";		my $pobj = $parent->{ParObjs}{$this->[0]} // confess "not a defined parname";
$pobj->adjusted_type($type)->ppsym;		$pobj->adjusted_type($type)->ppsym;
}		}
1;		1;
End of changes. 43 change blocks.
135 lines changed or deleted		120 lines changed or added

---