"Fossies" - the Fresh Open Source Software Archive  

Source code changes of the file "Basic/Ops/ops.pd" 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).

ops.pd  (PDL-2.082)	:	ops.pd  (PDL-2.083)
skipping to change at line 89		skipping to change at line 89
my %char2escape = ('>'=>'E<gt>','<'=>'E<lt>');		my %char2escape = ('>'=>'E<gt>','<'=>'E<lt>');
my $chars = '(['.join('', map quotemeta, sort keys %char2escape).'])';		my $chars = '(['.join('', map quotemeta, sort keys %char2escape).'])';
sub protect_chars {		sub protect_chars {
my ($txt) = @_;		my ($txt) = @_;
$txt =~ s/$chars/$char2escape{$1}/g;		$txt =~ s/$chars/$char2escape{$1}/g;
return $txt;		return $txt;
}		}
# simple binary operators		# simple binary operators
		pp_addhdr(pp_line_numbers(__LINE__, <<'EOF'));
		#define PDL_BADVAL_WARN(var) \
		{ \
		PDL_Anyval bad_anyval = PDL->get_pdl_badvalue(var); \
		if (bad_anyval.type < 0) \
		barf("Error getting badvalue, type=%d", bad_anyval.type); \
		complex double bad_c; \
		ANYVAL_TO_CTYPE(bad_c, complex double, bad_anyval); \
		if( bad_c == 0 || bad_c == 1 ) \
		warn(#var " badvalue is set to 0 or 1. This will cause data loss when usin
		g badvalues for comparison operators."); \
		}
		EOF
sub biop {		sub biop {
my ($name,$op,$mutator,$doc,%extra) = @_;		my ($name,$op,$mutator,$doc,%extra) = @_;
my $optxt = protect_chars ref $op eq 'ARRAY' ? $op->[1] : $op;		my $optxt = protect_chars ref $op eq 'ARRAY' ? $op->[1] : $op;
$op = $op->[0] if ref $op eq 'ARRAY';		$op = $op->[0] if ref $op eq 'ARRAY';
$extra{HdrCode} = << 'EOH';		$extra{HdrCode} = << 'EOH';
pdl *tmp;
if (swap) {		if (swap) {
tmp = a;		pdl *tmp = a;
a = b;		a = b;
b = tmp;		b = tmp;
}		}
EOH		EOH
# handle exceptions		# handle exceptions
my $badcode = ' ( $PDLSTATEISBAD(a) && $ISBAD(a()) )		my $badcode = ' ( $PDLSTATEISBAD(a) && $ISBAD(a()) )
|| ( $PDLSTATEISBAD(b) && $ISBAD(b()) )';		|| ( $PDLSTATEISBAD(b) && $ISBAD(b()) )';
if ( exists $extra{Exception} ) {		if ( exists $extra{Exception} ) {
# NOTE This option is unused ($badcode is not set).		# NOTE This option is unused ($badcode is not set).
# See also `ufunc()`.		# See also `ufunc()`.
delete $extra{Exception};		delete $extra{Exception};
}		}
if ($extra{Comparison}) {		if ($extra{Comparison}) {
my $first_complex = $Ctypes[0]->sym;		my $first_complex = $Ctypes[0]->sym;
$extra{HdrCode} .= <<EOF if $extra{Comparison} > 1;		$extra{HdrCode} .= <<EOF if $extra{Comparison} > 1;
if ((a->datatype >= $first_complex) || (b->datatype >= $first_complex		if ((a->datatype >= $first_complex) || (b->datatype >= $first_complex))
))		barf("Can't compare complex numbers");
barf("Can't compare complex numbers");
EOF		EOF
$extra{HdrCode} .= <<'EOH';		$extra{HdrCode} .= " PDL_BADVAL_WARN(a)\n PDL_BADVAL_WARN(b)\n";
{
complex double bad_a, bad_b;
PDL_Anyval a_badval = PDL->get_pdl_badvalue(a);
if (a_badval.type < 0) barf("Error getting badvalue, type=%d", a_ba
dval.type);
ANYVAL_TO_CTYPE(bad_a, complex double, a_badval);
PDL_Anyval b_badval = PDL->get_pdl_badvalue(b);
if (b_badval.type < 0) barf("Error getting badvalue, type=%d", b_ba
dval.type);
ANYVAL_TO_CTYPE(bad_b, complex double, b_badval);
if( bad_a == 0 || bad_a == 1 || bad_b == 0 || bad_b == 1 ) {
warn("Badvalue is set to 0 or 1. This will cause data loss when u
sing badvalues for comparison operators.");
}
}
EOH
delete $extra{Comparison};		delete $extra{Comparison};
}		}
pp_addpm(make_overload($op, $name, $mutator, delete $extra{Bitwise}));		pp_addpm(make_overload($op, $name, $mutator));
		my $bitwise = delete $extra{Bitwise};
pp_def($name,		pp_def($name,
Pars => 'a(); b(); [o]c();',		Pars => 'a(); b(); [o]c();',
OtherPars => 'int swap',		OtherPars => 'int $swap'.($bitwise ? '; SV *$ign; int $ign2' : ''),
OtherParsDefaults => { swap => 0 },		OtherParsDefaults => { swap => 0, ($bitwise ? (ign=>'&PL_sv_undef', ig
		n2=>0) : ()) },
		ArgOrder => 1,
HandleBad => 1,		HandleBad => 1,
NoBadifNaN => 1,		NoBadifNaN => 1,
Inplace => [ 'a' ], # quick and dirty solution to get ->inplace do its job		Inplace => [ 'a' ], # quick and dirty solution to get ->inplace do its job
Code => pp_line_numbers(__LINE__-1, qq{		Code => pp_line_numbers(__LINE__-1, <<EOF),
char anybad = 0;		char anybad = 0;
broadcastloop %{		broadcastloop %{
PDL_IF_BAD(if ( $badcode ) { \$SETBAD(c()); anybad = 1; } else,)		PDL_IF_BAD(if ( $badcode ) { \$SETBAD(c()); anybad = 1; } else,)
\$c() = \$a() $op \$b();		\$c() = \$a() $op \$b();
%}		%}
if (anybad) \$PDLSTATESETBAD(c);		if (anybad) \$PDLSTATESETBAD(c);
}),		EOF
%extra,		%extra,
Doc => << "EOD");		Doc => << "EOD");
=for ref		=for ref
$doc		$doc
=for example		=for example
\$c = \$x $op \$y; # overloaded call		\$c = \$x $op \$y; # overloaded call
\$c = $name \$x, \$y; # explicit call with default swap of 0		\$c = $name \$x, \$y; # explicit call with default swap of 0
skipping to change at line 172		skipping to change at line 172
This function is used to overload the binary C<$optxt> operator.		This function is used to overload the binary C<$optxt> operator.
As of 2.065, when calling this function explicitly you can omit		As of 2.065, when calling this function explicitly you can omit
the third argument (see second example), or supply it (see third one).		the third argument (see second example), or supply it (see third one).
=cut		=cut
EOD		EOD
} # sub: biop()		} # sub: biop()
sub make_overload {		sub make_overload {
my ($op, $name, $mutator, $bitwise, $one_arg) = @_;		my ($op, $name, $mutator, $one_arg) = @_;
my $ret;		my $ret;
my $bitwise_passon = $bitwise ? '$_[2]?@_[1,0]:@_[0,1]' : '@_';
if ($one_arg) {		if ($one_arg) {
$ret = <<EOF;		$ret = pp_line_numbers(__LINE__, <<EOF);
BEGIN { \$OVERLOADS{'$op'} = sub { PDL::$name(\$_[0]) } }		BEGIN { \$OVERLOADS{'$op'} = sub { PDL::$name(\$_[0]) } }
EOF		EOF
} else {		} else {
$ret = <<EOF;		$ret = pp_line_numbers(__LINE__, <<EOF);
{		{
my (\$foo, \$overload_sub);		my (\$foo, \$overload_sub);
BEGIN { \$OVERLOADS{'$op'} = \$overload_sub = sub(;\@) {		BEGIN { \$OVERLOADS{'$op'} = \$overload_sub = sub(;\@) {
return PDL::$name($bitwise_passon) unless ref \$_[1]		goto &PDL::$name unless ref \$_[1]
&& (ref \$_[1] ne 'PDL')		&& (ref \$_[1] ne 'PDL')
&& defined(\$foo = overload::Method(\$_[1], '$op'))		&& defined(\$foo = overload::Method(\$_[1], '$op'))
&& \$foo != \$overload_sub; # recursion guard		&& \$foo != \$overload_sub; # recursion guard
\$foo->(\$_[1], \$_[0], !\$_[2]);		goto &\$foo;
}; }		}; }
}		}
EOF		EOF
}		}
$ret .= <<EOF if $mutator;		$ret .= pp_line_numbers(__LINE__, <<EOF) if $mutator;
BEGIN {		BEGIN {
# in1, in2, out, swap if true		# in1, in2, out, swap if true
\$OVERLOADS{'$op='} = sub { PDL::$name(\$_[0], \$_[1], \$_[0], 0); \$_[0] };		\$OVERLOADS{'$op='} = sub { PDL::$name(\$_[0]->inplace, \$_[1]); \$_[0] };
}		}
EOF		EOF
$ret;		$ret;
}		}
#simple binary functions		#simple binary functions
sub bifunc {		sub bifunc {
my ($name,$func,$mutator,$doc,%extra) = @_;		my ($name,$func,$mutator,$doc,%extra) = @_;
my $funcov = ref $func eq 'ARRAY' ? $func->[1] : $func;		my $funcov = ref $func eq 'ARRAY' ? $func->[1] : $func;
my $isop=0; if ($funcov =~ s/^op//) { $isop = 1; }		my $isop=0; if ($funcov =~ s/^op//) { $isop = 1; }
my $funcovp = protect_chars $funcov;		my $funcovp = protect_chars $funcov;
$func = $func->[0] if ref $func eq 'ARRAY';		$func = $func->[0] if ref $func eq 'ARRAY';
my $got_complex = PDL::Core::Dev::got_complex_version($func, 2);		my $got_complex = PDL::Core::Dev::got_complex_version($func, 2);
$extra{GenericTypes} = [ grep exists $is_real{$_}, @{$extra{GenericTypes}} ]		$extra{GenericTypes} = [ grep exists $is_real{$_}, @{$extra{GenericTypes}} ]
if !$got_complex and $extra{GenericTypes};		if !$got_complex and $extra{GenericTypes};
$extra{HdrCode} .= << 'EOH';		$extra{HdrCode} .= << 'EOH';
pdl *tmp;
if (swap) {		if (swap) {
tmp = a;		pdl *tmp = a;
a = b;		a = b;
b = tmp;		b = tmp;
}		}
EOH		EOH
my $ovcall;		my $ovcall;
# is this one to be used as a function or operator ?		# is this one to be used as a function or operator ?
if ($isop) { $ovcall = "\$c = \$a $funcov \$b; # overloaded use"; }		if ($isop) { $ovcall = "\$c = \$a $funcov \$b; # overloaded use"; }
else { $ovcall = "\$c = $funcov \$a, \$b; # overloaded use"; }		else { $ovcall = "\$c = $funcov \$a, \$b; # overloaded use"; }
my $codestr;		my $codestr;
skipping to change at line 246		skipping to change at line 244
} else {		} else {
$codestr = '$c() = ($GENERIC(c))'.$func.'($a(),$b());';		$codestr = '$c() = ($GENERIC(c))'.$func.'($a(),$b());';
}		}
delete $extra{unsigned}; #remove the key so it doesn't get added in pp_def.		delete $extra{unsigned}; #remove the key so it doesn't get added in pp_def.
pp_addpm(make_overload($funcov, $name, $mutator));		pp_addpm(make_overload($funcov, $name, $mutator));
pp_def($name,		pp_def($name,
HandleBad => 1,		HandleBad => 1,
NoBadifNaN => 1,		NoBadifNaN => 1,
Pars => 'a(); b(); [o]c();',		Pars => 'a(); b(); [o]c();',
OtherPars => 'int swap',		OtherPars => 'int $swap',
OtherParsDefaults => { swap => 0 },		OtherParsDefaults => { swap => 0 },
Inplace => [ 'a' ], # quick and dirty solution to get ->inplace do its		ArgOrder => 1,
job		Inplace => [ 'a' ],
Code => pp_line_numbers(__LINE__, qq{		Code => pp_line_numbers(__LINE__-1, <<EOF),
char anybad = 0;		char anybad = 0;
broadcastloop %{		broadcastloop %{
PDL_IF_BAD(if ( \$ISBAD(a()) || \$ISBAD(b()) ) { anybad = 1; \$SETBAD(c()); } else ,){		PDL_IF_BAD(if ( \$ISBAD(a()) || \$ISBAD(b()) ) { anybad = 1; \$SETBAD(c()); } else ,) {
$codestr		$codestr
}		}
%}		%}
if (anybad) \$PDLSTATESETBAD(c);		if (anybad) \$PDLSTATESETBAD(c);
}),		EOF
%extra,		%extra,
Doc => << "EOD");		Doc => << "EOD");
=for ref		=for ref
$doc		$doc
=for example		=for example
\$c = \$x->$name(\$y); # explicit call with default swap of 0		\$c = \$x->$name(\$y); # explicit call with default swap of 0
\$c = \$x->$name(\$y, 1); # explicit call with trailing 1 to swap args		\$c = \$x->$name(\$y, 1); # explicit call with trailing 1 to swap args
skipping to change at line 308		skipping to change at line 307
delete $extra{Exception};		delete $extra{Exception};
}		}
my $codestr = '$b() = ($GENERIC(b))'.$func.'($a());';		my $codestr = '$b() = ($GENERIC(b))'.$func.'($a());';
if (delete $extra{NoTgmath} and $got_complex) {		if (delete $extra{NoTgmath} and $got_complex) {
# don't bother if not got complex version		# don't bother if not got complex version
$codestr = join "\n",		$codestr = join "\n",
'types('.join('', map $_->ppsym, @Rtypes).') %{'.$codestr.'%}',		'types('.join('', map $_->ppsym, @Rtypes).') %{'.$codestr.'%}',
(map 'types('.$_->ppsym.') %{$b() = c'.$func.$_->floatsuffix.'($a()) ;%}', @Ctypes),		(map 'types('.$_->ppsym.') %{$b() = c'.$func.$_->floatsuffix.'($a()) ;%}', @Ctypes),
;		;
}		}
pp_addpm(make_overload($funcov, $name, 0, 0, 1)) if $overload;		pp_addpm(make_overload($funcov, $name, 0, 1)) if $overload;
# do not have to worry about propagation of the badflag when		# do not have to worry about propagation of the badflag when
# inplace since only input ndarray is a, hence its badflag		# inplace since only input ndarray is a, hence its badflag
# won't change		# won't change
# UNLESS an exception occurs...		# UNLESS an exception occurs...
pp_def($name,		pp_def($name,
Pars => 'a(); [o]b()',		Pars => 'a(); [o]b()',
HandleBad => 1,		HandleBad => 1,
NoBadifNaN => 1,		NoBadifNaN => 1,
Inplace => 1,		Inplace => 1,
Code => pp_line_numbers(__LINE__, qq{		Code => pp_line_numbers(__LINE__-1, <<EOF),
PDL_IF_BAD(if ( $badcode ) \$SETBAD(b()); else {,)		PDL_IF_BAD(if ( $badcode ) \$SETBAD(b()); else {,)
$codestr		$codestr
PDL_IF_BAD(},)		PDL_IF_BAD(},)
}),		EOF
%extra,		%extra,
Doc => << "EOD");		Doc => << "EOD");
=for ref		=for ref
$doc		$doc
=for example		=for example
\$y = $funcov \$x;		\$y = $funcov \$x;
\$x->inplace->$name; # modify \$x inplace		\$x->inplace->$name; # modify \$x inplace
skipping to change at line 414		skipping to change at line 413
ufunc('exp','exp',1,'the exponential function',GenericTypes => [@$C, @$F]);		ufunc('exp','exp',1,'the exponential function',GenericTypes => [@$C, @$F]);
ufunc('log','log',1,'the natural logarithm',GenericTypes => [@$C, @$F], Exceptio n => '$a() <= 0');		ufunc('log','log',1,'the natural logarithm',GenericTypes => [@$C, @$F], Exceptio n => '$a() <= 0');
# no export these because clash with Test::Deep (re) or internal (_*abs)		# no export these because clash with Test::Deep (re) or internal (_*abs)
cfunc('re', 'creal', 1, 'Returns the real part of a complex number.',		cfunc('re', 'creal', 1, 'Returns the real part of a complex number.',
'$complexv() = $b() + I * cimag($complexv());'		'$complexv() = $b() + I * cimag($complexv());'
);		);
cfunc('im', 'cimag', 1, 'Returns the imaginary part of a complex number.',		cfunc('im', 'cimag', 1, 'Returns the imaginary part of a complex number.',
'$complexv() = creal($complexv()) + I * $b();'		'$complexv() = creal($complexv()) + I * $b();'
);		);
cfunc('_cabs', 'cabs', 1, 'Returns the absolute (length) of a complex number.', undef,		cfunc('_cabs', 'fabs', 1, 'Returns the absolute (length) of a complex number.', undef,
PMFunc=>'',		PMFunc=>'',
);		);
my $rabs_code = '		my $rabs_code = '
types('.join('', @$U).') %{ $b()=$a(); %}		types('.join('', @$U).') %{ $b()=$a(); %}
types('.join('', @$S).') %{ $b()=ABS($a()); %}		types('.join('', @$S).') %{ $b()=ABS($a()); %}
';		';
pp_def ( '_rabs',		pp_def ( '_rabs',
Pars=>'a(); [o]b()',		Pars=>'a(); [o]b()',
HandleBad => 1,		HandleBad => 1,
NoBadifNaN => 1,		NoBadifNaN => 1,
Inplace => 1,		Inplace => 1,
Code => pp_line_numbers(__LINE__, qq{		Code => pp_line_numbers(__LINE__, qq{
PDL_IF_BAD(if ( \$ISBAD(a()) ) \$SETBAD(b()); else,)		PDL_IF_BAD(if ( \$ISBAD(a()) ) \$SETBAD(b()); else,)
$rabs_code		$rabs_code
}),		}),
Doc=>undef,		Doc=>undef,
PMFunc=>'',		PMFunc=>'',
);		);
pp_export_nothing();		pp_export_nothing();
# make log10() work on scalars (returning scalars)		# make log10() work on scalars (returning scalars)
# as well as ndarrays		# as well as ndarrays
ufunc('log10','log10',0,'the base 10 logarithm', GenericTypes => $A,		ufunc('log10','log10',0,'the base 10 logarithm', GenericTypes => $A,
skipping to change at line 468		skipping to change at line 467
};		};
'		'
);		);
pp_def(		pp_def(
'assgn',		'assgn',
HandleBad => 1,		HandleBad => 1,
GenericTypes => $A,		GenericTypes => $A,
Pars => 'a(); [o]b();',		Pars => 'a(); [o]b();',
Code => pp_line_numbers(__LINE__-1, q{		Code => pp_line_numbers(__LINE__-1, q{
char anybad = 0;		char anybad = 0;
broadcastloop %{		broadcastloop %{
PDL_IF_BAD(if ( $ISBAD(a()) ) { anybad = 1; $SETBAD(b()); } else,)		PDL_IF_BAD(if ( $ISBAD(a()) ) { anybad = 1; $SETBAD(b()); } else,)
$b() = $a();		$b() = $a();
%}		%}
PDL_IF_BAD(if (anybad) $PDLSTATESETBAD(b);,)		PDL_IF_BAD(if (anybad) $PDLSTATESETBAD(b);,)
}),		}),
Doc =>		Doc =>
'Plain numerical assignment. This is used to implement the ".=" operator',		'Plain numerical assignment. This is used to implement the ".=" operator',
);		);
# special functions for complex data types that don't work well with		# special functions for complex data types that don't work well with
# the ufunc/bifunc logic		# the ufunc/bifunc logic
sub cfunc {		sub cfunc {
my ($name, $func, $make_real, $doc, $backcode, %extra) = @_;		my ($name, $func, $make_real, $doc, $backcode, %extra) = @_;
my $codestr = pp_line_numbers(__LINE__-1,"\$b() = $func(\$complexv());");		my $codestr = pp_line_numbers(__LINE__-1,"\$b() = $func(\$complexv());");
pp_def($name,		pp_def($name,
GenericTypes=>$C,		GenericTypes=>$C,
Pars => 'complexv(); '.($make_real ? 'real' : '').' [o]b()',		Pars => 'complexv(); '.($make_real ? 'real' : '').' [o]b()',
HandleBad => 1,		HandleBad => 1,
NoBadifNaN => 1,		NoBadifNaN => 1,
Inplace => 1,		Inplace => 1,
Code => pp_line_numbers(__LINE__, qq{		Code => pp_line_numbers(__LINE__, qq{
PDL_IF_BAD(if ( \$ISBAD(complexv()) ) \$SETBAD(b()); else,)		PDL_IF_BAD(if ( \$ISBAD(complexv()) ) \$SETBAD(b()); else,)
$codestr		$codestr
}),		}),
!$backcode ? () : (		!$backcode ? () : (
DefaultFlow => 1,		DefaultFlow => 1,
TwoWay => 1,		TwoWay => 1,
BackCode => pp_line_numbers(__LINE__, qq{		BackCode => pp_line_numbers(__LINE__, qq{
PDL_IF_BAD(if ( \$ISBAD(b()) ) \$SETBAD(complexv()); else {,)		PDL_IF_BAD(if ( \$ISBAD(b()) ) \$SETBAD(complexv()); else {,)
$backcode		$backcode
PDL_IF_BAD(},)		PDL_IF_BAD(},)
}),		}),
),		),
skipping to change at line 543		skipping to change at line 542
It can be made to work inplace with the C<\$x-E<gt>inplace> syntax.		It can be made to work inplace with the C<\$x-E<gt>inplace> syntax.
Algorithm from L<Wikipedia|http://en.wikipedia.org/wiki/Exponentiation_by_squari ng>		Algorithm from L<Wikipedia|http://en.wikipedia.org/wiki/Exponentiation_by_squari ng>
=cut		=cut
},		},
Pars => 'a(); indx b(); [o] ans()',		Pars => 'a(); indx b(); [o] ans()',
GenericTypes => $AF,		GenericTypes => $AF,
Code => pp_line_numbers(__LINE__, q{		Code => pp_line_numbers(__LINE__, q{
PDL_Indx n = $b();		PDL_Indx n = $b();
$GENERIC() y = 1;		$GENERIC() y = 1;
$GENERIC() x = $a();		$GENERIC() x = $a();
if (n < 0) {		if (n < 0) {
x = 1 / x;		x = 1 / x;
n = -n;		n = -n;
}		}
if (n == 0) {		if (n == 0) {
$ans() = 1;		$ans() = 1;
} else {		} else {
while (n > 1) {		while (n > 1) {
if (n % 2 == 0) {		if (n % 2 == 0) {
x = x * x;		x = x * x;
n = n / 2;		n = n / 2;
} else {		} else {
y = x * y;		y = x * y;
x = x * x;		x = x * x;
n = (n - 1) / 2;		n = (n - 1) / 2;
}		}
}		}
$ans() = x * y;		$ans() = x * y;
}		}
})		})
);		);
pp_addpm(<<'EOPM');		pp_addpm(<<'EOPM');
=head2 abs		=head2 abs
=for ref		=for ref
Returns the absolute value of a number.		Returns the absolute value of a number.
=cut		=cut
sub PDL::abs { $_[0]->type->real ? goto &PDL::_rabs : goto &PDL::_cabs }		sub PDL::abs { $_[0]->type->real ? goto &PDL::_rabs : goto &PDL::_cabs }
EOPM		EOPM
pp_addpm(make_overload(qw(abs abs), 0, 0, 1));		pp_addpm(make_overload(qw(abs abs), 0, 1));
pp_addpm(<<'EOPM');		pp_addpm(<<'EOPM');
=head2 abs2		=head2 abs2
=for ref		=for ref
Returns the square of the absolute value of a number.		Returns the square of the absolute value of a number.
=cut		=cut
End of changes. 32 change blocks.
86 lines changed or deleted		82 lines changed or added

---