"Fossies" - the Fresh Open Source Software Archive  

Source code changes of the file "Basic/Gen/PP.pm" between
PDL-2.079.tar.gz and PDL-2.080.tar.gz

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

PP.pm  (PDL-2.079):PP.pm  (PDL-2.080)
skipping to change at line 50 skipping to change at line 50
# PDL::PP::Rule::InsertName->new("Foo", "Arg2", '_pdl_${name}_bar') # PDL::PP::Rule::InsertName->new("Foo", "Arg2", '_pdl_${name}_bar')
# Note that the Name argument is automatically used as a condition, so # Note that the Name argument is automatically used as a condition, so
# it does not need to be supplied, and the return value should be # it does not need to be supplied, and the return value should be
# given as a single-quoted string and use the $name variable # given as a single-quoted string and use the $name variable
# #
# The Substitute rule replaces dollar-signed macros ($P(), $ISBAD(), etc) # The Substitute rule replaces dollar-signed macros ($P(), $ISBAD(), etc)
# with the low-level C code to perform the macro. # with the low-level C code to perform the macro.
# PDL::PP::Rule::Substitute("NewXSCoerceMustSubs", "NewXSCoerceMustSub1") # PDL::PP::Rule::Substitute("NewXSCoerceMustSubs", "NewXSCoerceMustSub1")
# PDL::PP::Rule::Substitute->new($target,$condition) # PDL::PP::Rule::Substitute->new($target,$condition)
# $target and $condition must be scalars. # $target and $condition must be scalars.
# Implicit conditions are NewXSSymTab and Name
#
# PDL::PP::Rule::Substitute::Usual->new($target, $condition)
# $target and $condition must be scalars.
# Implicit conditions are NewXSSymTab and Name
#
# The MakeComp rule creates the compiled representation accessed by $COMP()
# PDL::PP::Rule::MakeComp->new("MakeCompiledRepr", ["MakeComp","CompObj"],
# "COMP")
# PDL::PP::Rule::MakeComp->new($target,$conditions,$symbol)
# $target and $symbol must be scalars.
# Notes:
# Substitute, Substitute::Usual, MakeComp classes feel a bit
# ugly. See next point. Also the get_std_childparent method is
# a bit of a hack.
package PDL::PP::Rule; package PDL::PP::Rule;
use strict; use strict;
use warnings; use warnings;
use Carp; use Carp;
use overload ("\"\"" => \&PDL::PP::Rule::stringify); use overload ("\"\"" => \&PDL::PP::Rule::stringify);
sub stringify { sub stringify {
skipping to change at line 367 skipping to change at line 351
return unless $self->should_apply($pars); return unless $self->should_apply($pars);
# Set the value # Set the value
# #
my $target = $self->{targets}->[0]; my $target = $self->{targets}->[0];
my $name = $pars->{Name}; my $name = $pars->{Name};
$self->report ("--setting: $target (name=$name)\n"); $self->report ("--setting: $target (name=$name)\n");
$pars->{$target} = eval "return \"" . $self->{"insertname.value"} . "\";"; $pars->{$target} = eval "return \"" . $self->{"insertname.value"} . "\";";
} }
# PDL::PP::Rule->new("NewXSCoerceMustSubs", ["NewXSCoerceMustSub1","NewXSSymTa b","Name"], # PDL::PP::Rule->new("NewXSCoerceMustSubs", ["NewXSCoerceMustSub1","Name"],
# \&dosubst), # \&dosubst),
# #
# PDL::PP::Rule::Substitute->new($target,$condition) # PDL::PP::Rule::Substitute->new($target,$condition)
# $target and $condition must be scalars. # $target and $condition must be scalars.
#
# Implicit conditions are NewXSSymTab and Name
#
package PDL::PP::Rule::Substitute; package PDL::PP::Rule::Substitute;
use strict; use strict;
use Carp; use Carp;
our @ISA = qw (PDL::PP::Rule); our @ISA = qw (PDL::PP::Rule);
sub badflag_isset { sub badflag_isset {
PDL::PP::pp_line_numbers(__LINE__-1, "($_[0]->state & PDL_BADVAL)") PDL::PP::pp_line_numbers(__LINE__-1, "($_[0]->state & PDL_BADVAL)")
} }
# Probably want this directly in the apply routine but leave as is for now # Probably want this directly in the apply routine but leave as is for now
#
sub dosubst_private { sub dosubst_private {
my ($src,$sname,$pname,$name,$sig) = @_; my ($src,$sname,$pname,$name,$sig,$compobj,$privobj) = @_;
my $ret = (ref $src ? $src->[0] : $src); my $ret = (ref $src ? $src->[0] : $src);
my @pairs;
for ([$compobj,'COMP'], [$privobj,'PRIV']) {
my ($cobj, $which) = @$_;
my ($cn,$co) = map $cobj->$_, qw(othernames otherobjs);
push @pairs, 'DO'.$which.'ALLOC' => sub {
join '', map $$co{$_}->get_malloc("\$$which($_)"),
grep $$co{$_}->need_malloc, @$cn
};
}
my %syms = ( my %syms = (
@pairs,
((ref $src) ? %{$src->[1]} : ()), ((ref $src) ? %{$src->[1]} : ()),
PRIV => sub {return "$sname->$_[0]"}, PRIV => sub {return "$sname->$_[0]"},
COMP => sub {return "$pname->$_[0]"}, COMP => sub {return "$pname->$_[0]"},
CROAK => sub {PDL::PP::pp_line_numbers(__LINE__-1, "return PDL->make_error (PDL_EUSERERROR, \"Error in $name:\" $_[0])")}, CROAK => sub {PDL::PP::pp_line_numbers(__LINE__-1, "return PDL->make_error (PDL_EUSERERROR, \"Error in $name:\" @{[join ',', @_]})")},
NAME => sub {return $name}, NAME => sub {return $name},
MODULE => sub {return $::PDLMOD}, MODULE => sub {return $::PDLMOD},
SETPDLSTATEBAD => sub { PDL::PP::pp_line_numbers(__LINE__-1, "$_[0]\->sta te |= PDL_BADVAL") }, SETPDLSTATEBAD => sub { PDL::PP::pp_line_numbers(__LINE__-1, "$_[0]\->sta te |= PDL_BADVAL") },
SETPDLSTATEGOOD => sub { PDL::PP::pp_line_numbers(__LINE__-1, "$_[0]\->sta te &= ~PDL_BADVAL") }, SETPDLSTATEGOOD => sub { PDL::PP::pp_line_numbers(__LINE__-1, "$_[0]\->sta te &= ~PDL_BADVAL") },
ISPDLSTATEBAD => \&badflag_isset, ISPDLSTATEBAD => \&badflag_isset,
ISPDLSTATEGOOD => sub {"!".badflag_isset($_[0])}, ISPDLSTATEGOOD => sub {"!".badflag_isset($_[0])},
BADFLAGCACHE => sub { PDL::PP::pp_line_numbers(__LINE__-1, "badflag_cac he") }, BADFLAGCACHE => sub { PDL::PP::pp_line_numbers(__LINE__-1, "badflag_cac he") },
PDLSTATESETBAD => sub { PDL::PP::pp_line_numbers(__LINE__-1, ($sig->objs-> {$_[0]}//confess "Can't get PDLSTATESETBAD for unknown ndarray '$_[0]'")->do_pdl access."->state |= PDL_BADVAL") }, PDLSTATESETBAD => sub { PDL::PP::pp_line_numbers(__LINE__-1, ($sig->objs-> {$_[0]}//confess "Can't get PDLSTATESETBAD for unknown ndarray '$_[0]'")->do_pdl access."->state |= PDL_BADVAL") },
PDLSTATESETGOOD => sub { PDL::PP::pp_line_numbers(__LINE__-1, ($sig->objs- >{$_[0]}->do_pdlaccess//confess "Can't get PDLSTATESETGOOD for unknown ndarray ' $_[0]'")."->state &= ~PDL_BADVAL") }, PDLSTATESETGOOD => sub { PDL::PP::pp_line_numbers(__LINE__-1, ($sig->objs- >{$_[0]}->do_pdlaccess//confess "Can't get PDLSTATESETGOOD for unknown ndarray ' $_[0]'")."->state &= ~PDL_BADVAL") },
PDLSTATEISBAD => sub {badflag_isset(($sig->objs->{$_[0]}//confess "Can't g et PDLSTATEISBAD for unknown ndarray '$_[0]'")->do_pdlaccess)}, PDLSTATEISBAD => sub {badflag_isset(($sig->objs->{$_[0]}//confess "Can't g et PDLSTATEISBAD for unknown ndarray '$_[0]'")->do_pdlaccess)},
PDLSTATEISGOOD => sub {"!".badflag_isset(($sig->objs->{$_[0]}//confess "Ca n't get PDLSTATEISGOOD for unknown ndarray '$_[0]'")->do_pdlaccess)}, PDLSTATEISGOOD => sub {"!".badflag_isset(($sig->objs->{$_[0]}//confess "Ca n't get PDLSTATEISGOOD for unknown ndarray '$_[0]'")->do_pdlaccess)},
PP => sub { ($sig->objs->{$_[0]}//confess "Can't get PP for unknown ndarra y '$_[0]'")->do_physpointeraccess }, PP => sub { ($sig->objs->{$_[0]}//confess "Can't get PP for unknown ndarra y '$_[0]'")->do_physpointeraccess },
P => sub { (my $o = ($sig->objs->{$_[0]}//confess "Can't get P for unknown ndarray '$_[0]'"))->{FlagPhys} = 1; $o->do_pointeraccess; }, P => sub { (my $o = ($sig->objs->{$_[0]}//confess "Can't get P for unknown ndarray '$_[0]'"))->{FlagPhys} = 1; $o->do_pointeraccess; },
PDL => sub { ($sig->objs->{$_[0]}//confess "Can't get PDL for unknown ndar ray '$_[0]'")->do_pdlaccess }, PDL => sub { ($sig->objs->{$_[0]}//confess "Can't get PDL for unknown ndar ray '$_[0]'")->do_pdlaccess },
SIZE => sub { ($sig->ind_obj($_[0])//confess "Can't get SIZE of unknown di m '$_[0]'")->get_size }, SIZE => sub { ($sig->ind_obj($_[0])//confess "Can't get SIZE of unknown di m '$_[0]'")->get_size },
SETNDIMS => sub {PDL::PP::pp_line_numbers(__LINE__-1, "PDL_RETERROR(PDL_er
r, PDL->reallocdims(__it,$_[0]));")},
SETDIMS => sub {PDL::PP::pp_line_numbers(__LINE__-1, "PDL_RETERROR(PDL_err
, PDL->setdims_careful(__it));")},
SETDELTABROADCASTIDS => sub {PDL::PP::pp_line_numbers(__LINE__, <<EOF)},
{int __ind; PDL_RETERROR(PDL_err, PDL->reallocbroadcastids(\$PDL(CHILD), \$PDL(P
ARENT)->nbroadcastids));
for(__ind=0; __ind<\$PDL(PARENT)->nbroadcastids; __ind++)
\$PDL(CHILD)->broadcastids[__ind] = \$PDL(PARENT)->broadcastids[__ind] + ($_[0
]);
}
EOF
%PDL::PP::macros, %PDL::PP::macros,
); );
while (my ($before, $kw, $args, $other) = macro_extract($ret)) { my $known_pat = join '|', map quotemeta, sort keys %syms;
while (my ($before, $kw, $args, $other) = macro_extract($ret, $known_pat)) {
confess("$kw not defined in '$ret'!") if !$syms{$kw}; confess("$kw not defined in '$ret'!") if !$syms{$kw};
$ret = join '', $before, $syms{$kw}->($args), $other; $ret = join '', $before, $syms{$kw}->(split_cpp($args)), $other;
} }
$ret; $ret;
} }
# split like C pre-processor - on commas unless in "" or ()
my $extract_spec = [
sub {Text::Balanced::extract_delimited($_[0], '"')},
sub {Text::Balanced::extract_bracketed($_[0], '()')},
qr/\s+/,
qr/[^",\(\s]+/,
{ COMMA => qr/,/ },
];
sub split_cpp {
my ($text) = @_;
require Text::Balanced;
my ($thisstr, @parts);
while (defined(my $n = Text::Balanced::extract_multiple($text, $extract_spec,
undef, 1))) {
if (ref $n) { push @parts, $thisstr // ''; $thisstr = ''; }
else { $thisstr = '' if !defined $thisstr; $thisstr .= $n; }
}
push @parts, $thisstr if defined $thisstr;
s/^\s+//, s/\s+$// for @parts;
@parts;
}
sub macro_extract { sub macro_extract {
require Text::Balanced; require Text::Balanced;
my ($text) = @_; my ($text, $pat) = @_;
return unless $text =~ /\$(\w+)\s*(?=\()/; return unless $text =~ /\$($pat)\s*(?=\()/;
my ($before, $kw, $other) = ($`, $1, $'); my ($before, $kw, $other) = ($`, $1, $');
(my $bracketed, $other) = Text::Balanced::extract_bracketed($other, '(")'); (my $bracketed, $other) = Text::Balanced::extract_bracketed($other, '(")');
$bracketed = substr $bracketed, 1, -1; # chop off brackets $bracketed = substr $bracketed, 1, -1; # chop off brackets
$bracketed =~ s:^\s*(.*?)\s*$:$1:; $bracketed =~ s:^\s*(.*?)\s*$:$1:;
($before, $kw, $bracketed, $other); ($before, $kw, $bracketed, $other);
} }
sub new { sub new {
my $class = shift;
die "Usage: PDL::PP::Rule::Substitute->new(\$target,\$condition);" die "Usage: PDL::PP::Rule::Substitute->new(\$target,\$condition);"
unless $#_ == 1; unless @_ == 3;
my ($class, $target, $condition) = @_;
my $target = shift;
my $condition = shift;
die "\$target must be a scalar for PDL::PP::Rule::Substitute" if ref $target ; die "\$target must be a scalar for PDL::PP::Rule::Substitute" if ref $target ;
die "\$condition must be a scalar for PDL::PP::Rule::Substitute" if ref $con dition; die "\$condition must be a scalar for PDL::PP::Rule::Substitute" if ref $con dition;
$class->SUPER::new($target, [$condition, qw(StructName ParamStructName Name
$class->SUPER::new($target, [$condition, qw(StructName ParamStructName Name SignatureObj CompObj PrivObj)],
SignatureObj)],
\&dosubst_private); \&dosubst_private);
} }
# PDL::PP::Rule->new("CacheBadFlagInit", ["CacheBadFlagInitNS","NewXSSymTab","
Name"],
# \&dousualsubsts),
#
# PDL::PP::Rule::Substitute::Usual->new($target, $condition)
# $target and $condition must be scalars.
#
# Implicit conditions are NewXSSymTab and Name
#
# Need to think about @std_childparent as it is also used by
# other bits of code. At the moment provide a class method
# to access the array but there has to be better ways of
# doing this.
#
package PDL::PP::Rule::Substitute::Usual;
use strict;
use Carp;
our @ISA = qw (PDL::PP::Rule::Substitute);
# This is a copy of the main one for now. Need a better solution.
#
my @std_childparent = (
CHILD => sub {PDL::PP::pp_line_numbers(__LINE__-1, '$PRIV(pdls[1]->'.(joi
n ',',@_).")")},
PARENT => sub {PDL::PP::pp_line_numbers(__LINE__-1, '$PRIV(pdls[0]->'.(jo
in ',',@_).")")},
CHILD_PTR => sub {PDL::PP::pp_line_numbers(__LINE__-1, '$PRIV(pdls[1])')}
,
PARENT_PTR => sub {PDL::PP::pp_line_numbers(__LINE__-1, '$PRIV(pdls[0])')
},
);
sub get_std_childparent { return @std_childparent; }
# We modify the arguments from the conditions to include the
# extra information
#
# We simplify the base-class version since we assume that all
# conditions are required here.
#
sub extract_args {
my $self = shift;
my $pars = shift;
# The conditions are [<code>, NewXSSymTab, Name]
#
my $code = $pars->{$self->{conditions}[0]};
my $sname = $pars->{$self->{conditions}[1]};
my $name = $pars->{$self->{conditions}[2]};
return ([$code,{@std_childparent}],$sname,$name);
}
# PDL::PP::Rule::MakeComp->new($target,$conditions,$symbol)
# $target and $symbol must be scalars.
#
package PDL::PP::Rule::MakeComp;
use strict;
use Carp;
our @ISA = qw (PDL::PP::Rule);
# This is a copy of the main one for now. Need a better solution.
#
my @std_redodims = (
SETNDIMS => sub {PDL::PP::pp_line_numbers(__LINE__-1, "PDL_RETERROR(PDL_err, P
DL->reallocdims(__it,$_[0]));")},
SETDIMS => sub {PDL::PP::pp_line_numbers(__LINE__-1, "PDL_RETERROR(PDL_err, PD
L->setdims_careful(__it));")},
SETDELTABROADCASTIDS => sub {PDL::PP::pp_line_numbers(__LINE__, <<EOF)},
{int __ind; PDL_RETERROR(PDL_err, PDL->reallocbroadcastids(\$CHILD_PTR(), \$PARE
NT(nbroadcastids)));
for(__ind=0; __ind<\$PARENT(nbroadcastids); __ind++)
\$CHILD(broadcastids[__ind]) = \$PARENT(broadcastids[__ind]) + ($_[0]);
}
EOF
);
# Probably want this directly in the apply routine but leave as is for now
#
sub subst_makecomp_private {
my($which,$mc,$cobj) = @_;
my ($cn,$co) = !$cobj ? () : map $cobj->$_, qw(othernames otherobjs);
return [$mc,{
PDL::PP::Rule::Substitute::Usual::get_std_childparent(),
($cn ?
(('DO'.$which.'ALLOC') => sub {join('',
map $$co{$_}->get_malloc("\$$which($_)"),
grep $$co{$_}->need_malloc, @$cn)}) :
()
),
($which eq "PRIV" ?
@std_redodims : ()),
},
];
}
sub new {
my $class = shift;
die "Usage: PDL::PP::Rule::MakeComp->new(\$target,\$conditions,\$symbol);"
unless $#_ == 2;
my $target = shift;
my $condition = shift;
my $symbol = shift;
die "\$target must be a scalar for PDL::PP::Rule->MakeComp" if ref $target;
die "\$symbol must be a scalar for PDL::PP::Rule->MakeComp" if ref $symbol;
my $self = $class->SUPER::new($target, $condition,
\&subst_makecomp_private);
$self->{"makecomp.value"} = $symbol;
return $self;
}
# We modify the arguments from the conditions to include the
# extra information
#
# We simplify the base-class version since we assume that all
# conditions are required here.
#
sub extract_args {
my $self = shift;
my $pars = shift;
($self->{"makecomp.value"}, @$pars{@{$self->{conditions}}});
}
package PDL::PP; package PDL::PP;
use strict; use strict;
our $VERSION = "2.3"; our $VERSION = "2.3";
$VERSION = eval $VERSION; $VERSION = eval $VERSION;
our $macros_xs = <<'EOF'; our $macros_xs = <<'EOF';
#define PDL_XS_PREAMBLE \ #define PDL_XS_PREAMBLE \
char *objname = "PDL"; /* XXX maybe that class should actually depend on the v alue set \ char *objname = "PDL"; /* XXX maybe that class should actually depend on the v alue set \
skipping to change at line 1281 skipping to change at line 1171
# Look up the conversion from the INPUT typemap. Note that we need to do some # Look up the conversion from the INPUT typemap. Note that we need to do some
# massaging of this. # massaging of this.
my $input = $input_expr{$typemap_kind}; my $input = $input_expr{$typemap_kind};
$input =~ s/^(.*?)=\s*//s; # Remove all before = $input =~ s/^(.*?)=\s*//s; # Remove all before =
$input =~ s/\$(var|\{var\})/$oname/g; $input =~ s/\$(var|\{var\})/$oname/g;
$input =~ s/\$(arg|\{arg\})/$arg/g; $input =~ s/\$(arg|\{arg\})/$arg/g;
$input =~ s/\$(type|\{type\})/$full_type/g; $input =~ s/\$(type|\{type\})/$full_type/g;
return ($input); return ($input);
} }
sub wrap_vfn {
my (
$code,$rout,$func_header,
$all_func_header,$sname,$pname,$ptype,$extra_args,
) = @_;
my $str = join "\n", grep $_, $all_func_header, $func_header, $code;
my $opening = 'pdl_error PDL_err = {0, NULL, 0};';
my $closing = 'return PDL_err;';
PDL::PP::pp_line_numbers(__LINE__, <<EOF);
pdl_error $rout(pdl_trans *$sname$extra_args) {
$opening
@{[$ptype ? " $ptype *$pname = $sname->params;" : ""]}
$str$closing}
EOF
}
my @vfn_args_always = (\"AllFuncHeader", qw(StructName ParamStructName ParamStru
ctType));
sub make_vfn_args {
my ($which, $extra_args) = @_;
("${which}Func",
["${which}CodeSubd","${which}FuncName",\"${which}FuncHeader",
@vfn_args_always
],
sub {$_[1] eq 'NULL' ? '' : wrap_vfn(@_,$extra_args//'')}
);
}
sub make_xs_code { sub make_xs_code {
my($xscode_before,$xscode_after,$str, my($xscode_before,$xscode_after,$str,
$xs_c_headers, $xs_c_headers,
@bits) = @_; @bits) = @_;
my($boot,$prelude); my($boot,$prelude);
if($xs_c_headers) { if($xs_c_headers) {
$prelude = join '' => ($xs_c_headers->[0], @bits, $xs_c_headers->[1]); $prelude = join '' => ($xs_c_headers->[0], @bits, $xs_c_headers->[1]);
$boot = $xs_c_headers->[2]; $boot = $xs_c_headers->[2];
$str .= "\n"; $str .= "\n";
} else { } else {
skipping to change at line 1392 skipping to change at line 1256
# #
$PDL::PP::deftbl = $PDL::PP::deftbl =
[ [
PDL::PP::Rule->new( PDL::PP::Rule->new(
[qw(RedoDims EquivCPOffsCode HandleBad P2Child TwoWay)], [qw(RedoDims EquivCPOffsCode HandleBad P2Child TwoWay)],
["Identity"], ["Identity"],
"something to do with dataflow between CHILD & PARENT, I think.", "something to do with dataflow between CHILD & PARENT, I think.",
sub { sub {
(PDL::PP::pp_line_numbers(__LINE__-1, ' (PDL::PP::pp_line_numbers(__LINE__-1, '
int i; int i;
$SETNDIMS($PARENT(ndims)); $SETNDIMS($PDL(PARENT)->ndims);
for(i=0; i<$CHILD(ndims); i++) { for(i=0; i<$PDL(CHILD)->ndims; i++) {
$CHILD(dims[i]) = $PARENT(dims[i]); $PDL(CHILD)->dims[i] = $PDL(PARENT)->dims[i];
} }
$SETDIMS(); $SETDIMS();
$SETDELTABROADCASTIDS(0); $SETDELTABROADCASTIDS(0);
$PRIV(dims_redone) = 1; $PRIV(dims_redone) = 1;
'), '),
# NOTE: we use the same bit of code for all-good and bad data - # NOTE: we use the same bit of code for all-good and bad data -
# see the Code rule # see the Code rule
# we can NOT assume that PARENT and CHILD have the same type, # we can NOT assume that PARENT and CHILD have the same type,
# hence the version for bad code # hence the version for bad code
# #
skipping to change at line 1601 skipping to change at line 1465
} }
), ),
################## ##################
# Done with Docs # # Done with Docs #
################## ##################
# Notes # Notes
# Suffix 'NS' means, "Needs Substitution". In other words, the string # Suffix 'NS' means, "Needs Substitution". In other words, the string
# associated with a key that has the suffix "NS" must be run through a # associated with a key that has the suffix "NS" must be run through a
# Substitute or Substitute::Usual # Substitute
# The substituted version should then replace "NS" with "Subd" # The substituted version should then replace "NS" with "Subd"
# So: FreeCodeNS -> FreeCodeSubd # So: FreeCodeNS -> FreeCodeSubd
PDL::PP::Rule::Returns->new("StructName", "__privtrans"), PDL::PP::Rule::Returns->new("StructName", "__privtrans"),
PDL::PP::Rule::Returns->new("ParamStructName", "__params"), PDL::PP::Rule::Returns->new("ParamStructName", "__params"),
PDL::PP::Rule->new("HaveBroadcasting","HaveThreading", sub {@_}), # compat PDL::PP::Rule->new("HaveBroadcasting","HaveThreading", sub {@_}), # compat
PDL::PP::Rule::Croak->new([qw(P2Child GenericTypes)], PDL::PP::Rule::Croak->new([qw(P2Child GenericTypes)],
'Cannot have both P2Child and GenericTypes defined'), 'Cannot have both P2Child and GenericTypes defined'),
PDL::PP::Rule->new([qw(Pars HaveBroadcasting CallCopy GenericTypes DefaultFlo w AllFuncHeader RedoDimsFuncHeader)], PDL::PP::Rule->new([qw(Pars HaveBroadcasting CallCopy GenericTypes DefaultFlo w AllFuncHeader RedoDimsFuncHeader)],
skipping to change at line 1636 skipping to change at line 1500
sub {[PDL::Types::ppdefs()]}), sub {[PDL::Types::ppdefs()]}),
PDL::PP::Rule->new("ExtraGenericSwitches", "FTypes", PDL::PP::Rule->new("ExtraGenericSwitches", "FTypes",
'Makes ExtraGenericSwitches identical to FTypes if the latter exists and the former does not', 'Makes ExtraGenericSwitches identical to FTypes if the latter exists and the former does not',
sub {return $_[0]}), sub {return $_[0]}),
PDL::PP::Rule::Returns->new("ExtraGenericSwitches", [], PDL::PP::Rule::Returns->new("ExtraGenericSwitches", [],
'Sets ExtraGenericSwitches to an empty hash if it does not already exist' , {}), 'Sets ExtraGenericSwitches to an empty hash if it does not already exist' , {}),
PDL::PP::Rule::InsertName->new("VTableName", 'pdl_${name}_vtable'), PDL::PP::Rule::InsertName->new("VTableName", 'pdl_${name}_vtable'),
PDL::PP::Rule::Returns->new("Priv", "AffinePriv", 'PDL_Indx incs[$CHILD(ndims )];PDL_Indx offs; '), PDL::PP::Rule::Returns->new("Priv", "AffinePriv", 'PDL_Indx incs[$PDL(CHILD)- >ndims];PDL_Indx offs; '),
PDL::PP::Rule::Returns->new("IsAffineFlag", "AffinePriv", "PDL_ITRANS_ISAFFIN E"), PDL::PP::Rule::Returns->new("IsAffineFlag", "AffinePriv", "PDL_ITRANS_ISAFFIN E"),
PDL::PP::Rule::Returns::Zero->new("IsAffineFlag"), PDL::PP::Rule::Returns::Zero->new("IsAffineFlag"),
PDL::PP::Rule::Returns->new("TwoWayFlag", "TwoWay", "PDL_ITRANS_TWOWAY"), PDL::PP::Rule::Returns->new("TwoWayFlag", "TwoWay", "PDL_ITRANS_TWOWAY"),
PDL::PP::Rule::Returns::Zero->new("TwoWayFlag"), PDL::PP::Rule::Returns::Zero->new("TwoWayFlag"),
PDL::PP::Rule::Returns->new("DefaultFlowFlag", "DefaultFlow", "PDL_ITRANS_DO_ DATAFLOW_ANY"), PDL::PP::Rule::Returns->new("DefaultFlowFlag", "DefaultFlow", "PDL_ITRANS_DO_ DATAFLOW_ANY"),
PDL::PP::Rule::Returns::Zero->new("DefaultFlowFlag"), PDL::PP::Rule::Returns::Zero->new("DefaultFlowFlag"),
PDL::PP::Rule->new("RedoDims", ["EquivPDimExpr",\"EquivDimCheck"], PDL::PP::Rule->new("RedoDims", ["EquivPDimExpr",\"EquivDimCheck"],
sub { sub {
my($pdimexpr,$dimcheck) = @_; my($pdimexpr,$dimcheck) = @_;
$pdimexpr =~ s/\$CDIM\b/i/g; $pdimexpr =~ s/\$CDIM\b/i/g;
PDL::PP::pp_line_numbers(__LINE__-1, ' PDL::PP::pp_line_numbers(__LINE__-1, '
int i,cor; int i,cor;
'.$dimcheck.' '.$dimcheck.'
$SETNDIMS($PARENT(ndims)); $SETNDIMS($PDL(PARENT)->ndims);
$DOPRIVALLOC(); $DOPRIVALLOC();
$PRIV(offs) = 0; $PRIV(offs) = 0;
for(i=0; i<$CHILD(ndims); i++) { for(i=0; i<$PDL(CHILD)->ndims; i++) {
cor = '.$pdimexpr.'; cor = '.$pdimexpr.';
$CHILD(dims[i]) = $PARENT(dims[cor]); $PDL(CHILD)->dims[i] = $PDL(PARENT)->dims[cor];
$PRIV(incs[i]) = $PARENT(dimincs[cor]); $PRIV(incs[i]) = $PDL(PARENT)->dimincs[cor];
} }
$SETDIMS(); $SETDIMS();
$SETDELTABROADCASTIDS(0); $SETDELTABROADCASTIDS(0);
$PRIV(dims_redone) = 1; $PRIV(dims_redone) = 1;
'); ');
}), }),
PDL::PP::Rule->new("Code", ["EquivCPOffsCode","BadFlag"], PDL::PP::Rule->new("Code", ["EquivCPOffsCode","BadFlag"],
"create Code from EquivCPOffsCode", "create Code from EquivCPOffsCode",
# NOTE: EQUIVCPOFFS and EQUIVCPTRUNC both suffer from the macro-block # NOTE: EQUIVCPOFFS and EQUIVCPTRUNC both suffer from the macro-block
skipping to change at line 1742 skipping to change at line 1606
PDL::PP::Rule::Returns::Zero->new("Affine_Ok", "EquivCPOffsCode"), PDL::PP::Rule::Returns::Zero->new("Affine_Ok", "EquivCPOffsCode"),
PDL::PP::Rule::Returns::One->new("Affine_Ok"), PDL::PP::Rule::Returns::One->new("Affine_Ok"),
PDL::PP::Rule::Returns::NULL->new("ReadDataFuncName", "AffinePriv"), PDL::PP::Rule::Returns::NULL->new("ReadDataFuncName", "AffinePriv"),
PDL::PP::Rule::Returns::NULL->new("WriteBackDataFuncName", "AffinePriv"), PDL::PP::Rule::Returns::NULL->new("WriteBackDataFuncName", "AffinePriv"),
PDL::PP::Rule::InsertName->new("NewXSName", '_${name}_int'), PDL::PP::Rule::InsertName->new("NewXSName", '_${name}_int'),
PDL::PP::Rule::Returns::One->new("HaveBroadcasting"), PDL::PP::Rule::Returns::One->new("HaveBroadcasting"),
PDL::PP::Rule::Returns::EmptyString->new("Priv"),
PDL::PP::Rule->new("PrivObj", ["BadFlag","Priv"],
sub { PDL::PP::Signature->new('', @_) }),
# Parameters in the 'a(x,y); [o]b(y)' format, with # Parameters in the 'a(x,y); [o]b(y)' format, with
# fixed nos of real, unbroadcast-over dims. # fixed nos of real, unbroadcast-over dims.
# Also "Other pars", the parameters which are usually not pdls. # Also "Other pars", the parameters which are usually not pdls.
PDL::PP::Rule->new("SignatureObj", ["Pars","BadFlag","OtherPars"], PDL::PP::Rule->new("SignatureObj", ["Pars","BadFlag","OtherPars"],
sub { PDL::PP::Signature->new(@_) }), sub { PDL::PP::Signature->new(@_) }),
# Compiled representations i.e. what the RunFunc function leaves
# in the params structure. By default, copies of the parameters
# but in many cases (e.g. slice) a benefit can be obtained
# by parsing the string in that function.
# If the user wishes to specify their own MakeComp code and Comp content,
# The next definitions allow this.
PDL::PP::Rule->new("CompObj", ["BadFlag","Comp"],
sub { PDL::PP::Signature->new('', @_) }),
PDL::PP::Rule->new("CompObj", "SignatureObj", sub { @_ }), # provide default
PDL::PP::Rule->new("CompStructOther", "SignatureObj", sub {$_[0]->getcomp}),
PDL::PP::Rule->new("CompStructComp", [qw(CompObj Comp)], sub {$_[0]->getcomp}
),
PDL::PP::Rule->new("CompStruct", ["CompStructOther", \"CompStructComp"], sub
{ join "\n", grep $_, @_ }),
# Set CallCopy flag for simple functions (2-arg with 0-dim signatures) # Set CallCopy flag for simple functions (2-arg with 0-dim signatures)
# This will copy the $object->copy method, instead of initialize # This will copy the $object->copy method, instead of initialize
# for PDL-subclassed objects # for PDL-subclassed objects
# #
PDL::PP::Rule->new("CallCopy", ["SignatureObj", "Name"], PDL::PP::Rule->new("CallCopy", ["SignatureObj", "Name"],
sub { sub {
my ($sig, $Name, $hasp2c) = @_; my ($sig, $Name, $hasp2c) = @_;
my $noDimmedArgs = $sig->dims_count; my $noDimmedArgs = $sig->dims_count;
my $noArgs = @{$sig->names}; my $noArgs = @{$sig->names};
# Check for 2-arg function with 0-dim signatures # Check for 2-arg function with 0-dim signatures
skipping to change at line 1973 skipping to change at line 1854
PDL::PP::Rule->new("NewXSMakeNow", ["SignatureObj"], PDL::PP::Rule->new("NewXSMakeNow", ["SignatureObj"],
sub { join '', map PDL::PP::pp_line_numbers(__LINE__-1, "$_ = PDL->make_no w($_);\n"), @{ $_[0]->names } }), sub { join '', map PDL::PP::pp_line_numbers(__LINE__-1, "$_ = PDL->make_no w($_);\n"), @{ $_[0]->names } }),
PDL::PP::Rule->new("IgnoreTypesOf", ["FTypes","SignatureObj"], sub { PDL::PP::Rule->new("IgnoreTypesOf", ["FTypes","SignatureObj"], sub {
my ($ftypes, $sig) = @_; my ($ftypes, $sig) = @_;
my ($pnames, $pobjs) = ($sig->names_sorted, $sig->objs); my ($pnames, $pobjs) = ($sig->names_sorted, $sig->objs);
$_->{FlagIgnore} = 1 for grep $ftypes->{$_->{Name}}, @$pobjs{@$pnames}; $_->{FlagIgnore} = 1 for grep $ftypes->{$_->{Name}}, @$pobjs{@$pnames};
+{map +($_,1), keys %$ftypes}; +{map +($_,1), keys %$ftypes};
}), }),
PDL::PP::Rule::Returns->new("IgnoreTypesOf", {}), PDL::PP::Rule::Returns->new("IgnoreTypesOf", {}),
PDL::PP::Rule->new("NewXSCoerceMustNS", "FTypes",
sub {
my($ftypes) = @_;
join '', map
PDL::PP::pp_line_numbers(__LINE__, "$_->datatype = $ftypes->{$_};"),
sort keys %$ftypes;
}),
PDL::PP::Rule::Substitute::Usual->new("NewXSCoerceMustSubd", "NewXSCoerceMust
NS"),
PDL::PP::Rule->new("NewXSTypeCoerceNS", ["StructName"], PDL::PP::Rule->new("NewXSTypeCoerceNS", ["StructName"],
sub { sub {
PDL::PP::pp_line_numbers(__LINE__, <<EOF); PDL::PP::pp_line_numbers(__LINE__, <<EOF);
PDL_RETERROR(PDL_err, PDL->type_coerce($_[0])); PDL_RETERROR(PDL_err, PDL->type_coerce($_[0]));
EOF EOF
}), }),
PDL::PP::Rule::Substitute::Usual->new("NewXSTypeCoerceSubd", "NewXSTypeCoerce NS"), PDL::PP::Rule::Substitute->new("NewXSTypeCoerceSubd", "NewXSTypeCoerceNS"),
PDL::PP::Rule->new("NewXSSetTransPDLs", ["SignatureObj","StructName"], sub { PDL::PP::Rule->new("NewXSSetTransPDLs", ["SignatureObj","StructName"], sub {
my($sig,$trans) = @_; my($sig,$trans) = @_;
join '', join '',
map PDL::PP::pp_line_numbers(__LINE__, "$trans->pdls[$_->[0]] = $_->[2]; \n"), map PDL::PP::pp_line_numbers(__LINE__, "$trans->pdls[$_->[0]] = $_->[2]; \n"),
grep !$_->[1], $sig->names_sorted_tuples; grep !$_->[1], $sig->names_sorted_tuples;
}), }),
PDL::PP::Rule->new("NewXSExtractTransPDLs", ["SignatureObj","StructName"], su b { PDL::PP::Rule->new("NewXSExtractTransPDLs", ["SignatureObj","StructName"], su b {
my($sig,$trans) = @_; my($sig,$trans) = @_;
skipping to change at line 2010 skipping to change at line 1882
map PDL::PP::pp_line_numbers(__LINE__, "$_->[2] = $trans->pdls[$_->[0]]; \n"), map PDL::PP::pp_line_numbers(__LINE__, "$_->[2] = $trans->pdls[$_->[0]]; \n"),
grep !$_->[1], $sig->names_sorted_tuples; grep !$_->[1], $sig->names_sorted_tuples;
}), }),
PDL::PP::Rule->new("NewXSRunTrans", ["StructName"], sub { PDL::PP::Rule->new("NewXSRunTrans", ["StructName"], sub {
my($trans) = @_; my($trans) = @_;
PDL::PP::pp_line_numbers(__LINE__, PDL::PP::pp_line_numbers(__LINE__,
"PDL_RETERROR(PDL_err, PDL->make_trans_mutual($trans));\n"); "PDL_RETERROR(PDL_err, PDL->make_trans_mutual($trans));\n");
}), }),
PDL::PP::Rule->new(PDL::PP::Code::make_args("Code"),
sub { PDL::PP::Code->new(@_, undef, undef, 1); }),
PDL::PP::Rule->new(PDL::PP::Code::make_args("BackCode"),
sub { PDL::PP::Code->new(@_, undef, 1, 1); }),
# Compiled representations i.e. what the RunFunc function leaves
# in the params structure. By default, copies of the parameters
# but in many cases (e.g. slice) a benefit can be obtained
# by parsing the string in that function.
# If the user wishes to specify their own MakeComp code and Comp content,
# The next definitions allow this.
PDL::PP::Rule->new("CompObj", ["BadFlag","Comp"],
sub { PDL::PP::Signature->new('', @_) }),
PDL::PP::Rule->new("CompObj", "SignatureObj", sub { @_ }), # provide default
PDL::PP::Rule->new("MakeCompOther", "SignatureObj", sub { $_[0]->getcopy }),
PDL::PP::Rule->new("MakeCompTotal", ["MakeCompOther", \"MakeComp"], sub { joi
n "\n", grep $_, @_ }),
PDL::PP::Rule->new("CompStructOther", "SignatureObj", sub {$_[0]->getcomp}),
PDL::PP::Rule->new("CompStructComp", [qw(CompObj Comp)], sub {$_[0]->getcomp}
),
PDL::PP::Rule->new("CompStruct", ["CompStructOther", \"CompStructComp"], sub
{ join "\n", grep $_, @_ }),
PDL::PP::Rule::MakeComp->new("MakeCompiledReprNS", ["MakeCompTotal","CompObj"
],
"COMP"),
PDL::PP::Rule->new("CompFreeCodeOther", "SignatureObj", sub {$_[0]->getfree("
COMP")}),
PDL::PP::Rule->new("CompFreeCodeComp", [qw(CompObj Comp)], sub {$_[0]->getfre
e("COMP")}),
PDL::PP::Rule->new("CompFreeCode", ["CompFreeCodeOther", \"CompFreeCodeComp"]
, sub { join "\n", grep $_, @_ }),
PDL::PP::Rule->new(["StructDecl","ParamStructType"], PDL::PP::Rule->new(["StructDecl","ParamStructType"],
["CompStruct","Name"], ["CompStruct","Name"],
sub { sub {
my($comp,$name) = @_; my($comp,$name) = @_;
return ('', '') if !$comp; return ('', '') if !$comp;
my $ptype = "pdl_params_$name"; my $ptype = "pdl_params_$name";
(PDL::PP::pp_line_numbers(__LINE__-1, qq{typedef struct $ptype {\n$comp} $ptype;}), (PDL::PP::pp_line_numbers(__LINE__-1, qq{typedef struct $ptype {\n$comp} $ptype;}),
$ptype); $ptype);
}), }),
PDL::PP::Rule::Substitute->new("MakeCompiledReprSubd", "MakeCompiledReprNS"), do {
sub wrap_vfn {
my (
$code,$rout,$func_header,
$all_func_header,$sname,$pname,$ptype,$extra_args,
) = @_;
PDL::PP::pp_line_numbers(__LINE__, <<EOF);
pdl_error $rout(pdl_trans *$sname$extra_args) {
@{[join "\n ",
'pdl_error PDL_err = {0, NULL, 0};',
$ptype ? "$ptype *$pname = $sname->params;" : (),
(grep $_, $all_func_header, $func_header, $code), 'return PDL_err;'
]}
}
EOF
}
sub make_vfn_args {
my ($which, $extra_args) = @_;
("${which}Func",
["${which}CodeSubd","${which}FuncName",\"${which}FuncHeader",
\"AllFuncHeader", qw(StructName ParamStructName ParamStructType),
],
sub {$_[1] eq 'NULL' ? '' : wrap_vfn(@_,$extra_args//'')}
);
}
()},
PDL::PP::Rule->new("MakeCompOther", "SignatureObj", sub { $_[0]->getcopy }),
PDL::PP::Rule->new("MakeCompTotal", ["MakeCompOther", \"MakeComp"], sub { joi
n "\n", grep $_, @_ }),
PDL::PP::Rule::Substitute->new("MakeCompiledReprSubd", "MakeCompTotal"),
(map PDL::PP::Rule::Substitute->new("${_}ReadDataCodeUnparsed", "${_}Code"),
'', 'Bad'),
PDL::PP::Rule->new(PDL::PP::Code::make_args(qw(ReadData)),
sub { PDL::PP::Code->new(@_, undef, undef, 1); }),
PDL::PP::Rule::Substitute->new("ReadDataCodeSubd", "ReadDataCodeParsed"),
PDL::PP::Rule::InsertName->new("ReadDataFuncName", 'pdl_${name}_readdata'),
PDL::PP::Rule->new(make_vfn_args("ReadData")),
(map PDL::PP::Rule::Substitute->new("${_}WriteBackDataCodeUnparsed", "${_}Bac
kCode"), '', 'Bad'),
PDL::PP::Rule->new(PDL::PP::Code::make_args(qw(WriteBackData)),
sub { PDL::PP::Code->new(@_, undef, 1, 1); }),
PDL::PP::Rule::Substitute->new("WriteBackDataCodeSubd", "WriteBackDataCodePar
sed"),
PDL::PP::Rule::InsertName->new("WriteBackDataFuncName", "BackCode", 'pdl_${na
me}_writebackdata'),
PDL::PP::Rule::Returns::NULL->new("WriteBackDataFuncName", "Code"),
PDL::PP::Rule->new(make_vfn_args("WriteBackData")),
PDL::PP::Rule->new("DefaultRedoDims", PDL::PP::Rule->new("DefaultRedoDims",
["StructName"], ["StructName"],
sub { "PDL_RETERROR(PDL_err, PDL->redodims_default($_[0]));" }), sub { "PDL_RETERROR(PDL_err, PDL->redodims_default($_[0]));" }),
PDL::PP::Rule->new("DimsSetters", PDL::PP::Rule->new("DimsSetters",
["SignatureObj"], ["SignatureObj"],
sub { join "\n", sort map $_->get_initdim, $_[0]->dims_values }), sub { join "\n", sort map $_->get_initdim, $_[0]->dims_values }),
PDL::PP::Rule->new("RedoDimsFuncName", ["Name", \"RedoDims", \"RedoDimsCode", "DimsSetters"], PDL::PP::Rule->new("RedoDimsFuncName", ["Name", \"RedoDims", \"RedoDimsCode", "DimsSetters"],
sub { (scalar grep $_ && /\S/, @_[1..$#_]) ? "pdl_$_[0]_redodims" : 'NULL' }), sub { (scalar grep $_ && /\S/, @_[1..$#_]) ? "pdl_$_[0]_redodims" : 'NULL' }),
PDL::PP::Rule::Returns->new("RedoDimsCode", [], PDL::PP::Rule::Returns->new("RedoDimsCode", [],
'Code that can be inserted to set the size of outp ut ndarrays dynamically based on input ndarrays; is parsed', 'Code that can be inserted to set the size of outp ut ndarrays dynamically based on input ndarrays; is parsed',
''), ''),
PDL::PP::Rule->new(PDL::PP::Code::make_args("RedoDimsCode"), (map PDL::PP::Rule::Substitute->new("RedoDims${_}Unparsed", "RedoDims$_"), ''
, 'Code'),
PDL::PP::Rule->new(PDL::PP::Code::make_args(qw(RedoDims)),
'makes the parsed representation from the supplied RedoDimsCode', 'makes the parsed representation from the supplied RedoDimsCode',
sub { return '' if !$_[0]; PDL::PP::Code->new(@_, 1, undef, 0); }), sub { return '' if !$_[0]; PDL::PP::Code->new(@_, 1, undef, 0); }),
PDL::PP::Rule->new("RedoDimsCodeParsed","RedoDimsUnparsed", sub {@_}),
PDL::PP::Rule->new("RedoDims", PDL::PP::Rule->new("RedoDims",
["DimsSetters","ParsedRedoDimsCode","DefaultRedoDims"], ["DimsSetters","RedoDimsCodeParsed","DefaultRedoDims"],
'makes the redodims function from the various bits and pieces', 'makes the redodims function from the various bits and pieces',
sub { join "\n", grep $_ && /\S/, @_ }), sub { join "\n", grep $_ && /\S/, @_ }),
PDL::PP::Rule::Substitute->new("RedoDimsCodeSubd", "RedoDims"),
PDL::PP::Rule->new(make_vfn_args("RedoDims")),
PDL::PP::Rule::Returns::EmptyString->new("Priv"), PDL::PP::Rule->new("CompFreeCodeOther", "SignatureObj", sub {$_[0]->getfree("
COMP")}),
PDL::PP::Rule->new("PrivObj", ["BadFlag","Priv"], PDL::PP::Rule->new("CompFreeCodeComp", [qw(CompObj Comp)], sub {$_[0]->getfre
sub { PDL::PP::Signature->new('', @_) }), e("COMP")}),
PDL::PP::Rule->new("CompFreeCode", ["CompFreeCodeOther", \"CompFreeCodeComp"]
, sub { join "\n", grep $_, @_ }),
PDL::PP::Rule->new("NTPrivFreeCode", "PrivObj", sub {$_[0]->getfree("PRIV")}) , PDL::PP::Rule->new("NTPrivFreeCode", "PrivObj", sub {$_[0]->getfree("PRIV")}) ,
PDL::PP::Rule->new("FreeCodeNS", PDL::PP::Rule->new("FreeCodeNS",
["StructName","CompFreeCode","NTPrivFreeCode"], ["StructName","CompFreeCode","NTPrivFreeCode"],
sub { sub {
(grep $_, @_[1..$#_]) ? PDL::PP::pp_line_numbers(__LINE__-1, "PDL_FREE_ CODE($_[0], destroy, $_[1], $_[2])"): ''}), (grep $_, @_[1..$#_]) ? PDL::PP::pp_line_numbers(__LINE__-1, "PDL_FREE_ CODE($_[0], destroy, $_[1], $_[2])"): ''}),
PDL::PP::Rule::Substitute->new("FreeCodeSubd", "FreeCodeNS"),
PDL::PP::Rule->new("FreeFuncName",
["FreeCodeSubd","Name"],
sub {$_[0] ? "pdl_$_[1]_free" : 'NULL'}),
PDL::PP::Rule->new(make_vfn_args("Free", ", char destroy")),
PDL::PP::Rule::Substitute::Usual->new("FreeCodeSubd", "FreeCodeNS"), PDL::PP::Rule->new("NewXSCoerceMustNS", "FTypes",
sub {
PDL::PP::Rule::Returns::EmptyString->new("NewXSCoerceMustSubd"), my($ftypes) = @_;
join '', map
PDL::PP::Rule::MakeComp->new("NewXSCoerceMustCompNS", "NewXSCoerceMustSubd", PDL::PP::pp_line_numbers(__LINE__, "$_->datatype = $ftypes->{$_};"),
"FOO"), sort keys %$ftypes;
PDL::PP::Rule::Substitute->new("NewXSCoerceMustCompSubd", "NewXSCoerceMustCom }),
pNS"), PDL::PP::Rule::Returns::EmptyString->new("NewXSCoerceMustNS"),
PDL::PP::Rule::Substitute->new("NewXSCoerceMustCompSubd", "NewXSCoerceMustNS"
),
PDL::PP::Rule->new("NewXSFindBadStatusNS", ["StructName"], PDL::PP::Rule->new("NewXSFindBadStatusNS", ["StructName"],
"Rule to find the bad value status of the input ndarrays", "Rule to find the bad value status of the input ndarrays",
sub { sub {
PDL::PP::pp_line_numbers(__LINE__, <<EOF); PDL::PP::pp_line_numbers(__LINE__, <<EOF);
PDL_RETERROR(PDL_err, PDL->trans_check_pdls($_[0])); PDL_RETERROR(PDL_err, PDL->trans_check_pdls($_[0]));
char \$BADFLAGCACHE() = PDL->trans_badflag_from_inputs($_[0]); char \$BADFLAGCACHE() = PDL->trans_badflag_from_inputs($_[0]);
EOF EOF
}), }),
skipping to change at line 2121 skipping to change at line 2020
my ( $sig ) = @_; my ( $sig ) = @_;
return '' if @{$sig->names} == (my @outs = $sig->names_out); # no input pdls, no badflag copying needed return '' if @{$sig->names} == (my @outs = $sig->names_out); # no input pdls, no badflag copying needed
PDL::PP::pp_line_numbers(__LINE__, join '', PDL::PP::pp_line_numbers(__LINE__, join '',
"if (\$BADFLAGCACHE()) {\n", "if (\$BADFLAGCACHE()) {\n",
(map " \$SETPDLSTATEBAD($_);\n", @outs), (map " \$SETPDLSTATEBAD($_);\n", @outs),
"}\n"); "}\n");
}), }),
# expand macros in ...BadStatusCode # expand macros in ...BadStatusCode
# #
PDL::PP::Rule::Substitute::Usual->new("NewXSFindBadStatusSubd", "NewXSFindBad PDL::PP::Rule::Substitute->new("NewXSFindBadStatusSubd", "NewXSFindBadStatusN
StatusNS"), S"),
PDL::PP::Rule::Substitute::Usual->new("NewXSCopyBadStatusSubd", "NewXSCopyBad PDL::PP::Rule::Substitute->new("NewXSCopyBadStatusSubd", "NewXSCopyBadStatusN
StatusNS"), S"),
PDL::PP::Rule->new("NewXSStructInit0", PDL::PP::Rule->new("NewXSStructInit0",
["StructName","VTableName","ParamStructName","ParamStructTy pe"], ["StructName","VTableName","ParamStructName","ParamStructTy pe"],
"Rule to create and initialise the private trans structure" , "Rule to create and initialise the private trans structure" ,
sub { sub {
my( $sname, $vtable, $pname, $ptype ) = @_; my( $sname, $vtable, $pname, $ptype ) = @_;
PDL::PP::pp_line_numbers(__LINE__, <<EOF); PDL::PP::pp_line_numbers(__LINE__, <<EOF);
if (!PDL) croak("PDL core struct is NULL, can't continue"); if (!PDL) croak("PDL core struct is NULL, can't continue");
pdl_trans *$sname = PDL->create_trans(&$vtable); pdl_trans *$sname = PDL->create_trans(&$vtable);
@{[$ptype ? " $ptype *$pname = $sname->params;" : ""]} @{[$ptype ? " $ptype *$pname = $sname->params;" : ""]}
skipping to change at line 2172 skipping to change at line 2071
# if PMCode supplied, no var-args stuff # if PMCode supplied, no var-args stuff
PDL::PP::Rule->new(["NewXSCode","BootSetNewXS","NewXSInPrelude"], PDL::PP::Rule->new(["NewXSCode","BootSetNewXS","NewXSInPrelude"],
["PMCode","NewXSHdr", \"NewXSCHdrs", "RunFuncCall"], ["PMCode","NewXSHdr", \"NewXSCHdrs", "RunFuncCall"],
"Non-varargs XS code when PMCode given", "Non-varargs XS code when PMCode given",
sub {make_xs_code('CODE:',' XSRETURN(0);',@_[1..$#_])}), sub {make_xs_code('CODE:',' XSRETURN(0);',@_[1..$#_])}),
PDL::PP::Rule->new(["NewXSCode","BootSetNewXS","NewXSInPrelude"], PDL::PP::Rule->new(["NewXSCode","BootSetNewXS","NewXSInPrelude"],
[qw(VarArgsXSHdr), \"NewXSCHdrs", qw(RunFuncCall VarArgsXSReturn)], [qw(VarArgsXSHdr), \"NewXSCHdrs", qw(RunFuncCall VarArgsXSReturn)],
"Rule to print out XS code when variable argument list XS processing is en abled", "Rule to print out XS code when variable argument list XS processing is en abled",
sub {make_xs_code('','',@_)}), sub {make_xs_code('','',@_)}),
PDL::PP::Rule::MakeComp->new("RedoDimsCodeNS",
["RedoDims", "PrivObj"], "PRIV"),
PDL::PP::Rule::Substitute->new("RedoDimsCodeSubd", "RedoDimsCodeNS"),
PDL::PP::Rule->new(make_vfn_args("RedoDims")),
PDL::PP::Rule::MakeComp->new("ReadDataCodeNS", "ParsedCode", "FOO"),
PDL::PP::Rule::Substitute->new("ReadDataCodeSubd", "ReadDataCodeNS"),
PDL::PP::Rule::InsertName->new("ReadDataFuncName", 'pdl_${name}_readdata'),
PDL::PP::Rule->new(make_vfn_args("ReadData")),
PDL::PP::Rule::MakeComp->new("WriteBackDataCodeNS", "ParsedBackCode", "FOO"),
PDL::PP::Rule::Substitute->new("WriteBackDataCodeSubd", "WriteBackDataCodeNS"
),
PDL::PP::Rule::InsertName->new("WriteBackDataFuncName", "BackCode", 'pdl_${na
me}_writebackdata'),
PDL::PP::Rule::Returns::NULL->new("WriteBackDataFuncName", "Code"),
PDL::PP::Rule->new(make_vfn_args("WriteBackData")),
PDL::PP::Rule->new("FreeFuncName",
["FreeCodeSubd","Name"],
sub {$_[0] ? "pdl_$_[1]_free" : 'NULL'}),
PDL::PP::Rule->new(make_vfn_args("Free", ", char destroy")),
PDL::PP::Rule::Returns::Zero->new("NoPthread"), # assume we can pthread, unle ss indicated otherwise PDL::PP::Rule::Returns::Zero->new("NoPthread"), # assume we can pthread, unle ss indicated otherwise
PDL::PP::Rule->new("VTableDef", PDL::PP::Rule->new("VTableDef",
["VTableName","ParamStructType","RedoDimsFuncName","ReadDataFuncName", ["VTableName","ParamStructType","RedoDimsFuncName","ReadDataFuncName",
"WriteBackDataFuncName","FreeFuncName", "WriteBackDataFuncName","FreeFuncName",
"SignatureObj","Affine_Ok","HaveBroadcasting","NoPthread","Name", "SignatureObj","Affine_Ok","HaveBroadcasting","NoPthread","Name",
"GenericTypes","IsAffineFlag","TwoWayFlag","DefaultFlowFlag", "GenericTypes","IsAffineFlag","TwoWayFlag","DefaultFlowFlag",
"BadFlag"], "BadFlag"],
sub { sub {
my($vname,$ptype,$rdname,$rfname,$wfname,$ffname, my($vname,$ptype,$rdname,$rfname,$wfname,$ffname,
$sig,$affine_ok,$havebroadcasting, $noPthreadFlag, $name, $gentypes, $sig,$affine_ok,$havebroadcasting, $noPthreadFlag, $name, $gentypes,
 End of changes. 42 change blocks. 
296 lines changed or deleted 168 lines changed or added

Home  |  About  |  Features  |  All  |  Newest  |  Dox  |  Diffs  |  RSS Feeds  |  Screenshots  |  Comments  |  Imprint  |  Privacy  |  HTTP(S)