"Fossies" - the Fresh Open Source Software Archive  

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

[ To the main PDL source changes report ]

PP.pm  (PDL-2.082):PP.pm  (PDL-2.083)
skipping to change at line 39 skipping to change at line 39
# This class is specialized since there are some common return values: # This class is specialized since there are some common return values:
# PDL::PP::Rule::Returns::Zero->new($targets [,$conditions [,$doc]]) # PDL::PP::Rule::Returns::Zero->new($targets [,$conditions [,$doc]])
# PDL::PP::Rule::Returns::One->new($targets [,$conditions [,$doc]]) # PDL::PP::Rule::Returns::One->new($targets [,$conditions [,$doc]])
# PDL::PP::Rule::Returns::EmptyString->new($targets [,$conditions [,$doc]]) # PDL::PP::Rule::Returns::EmptyString->new($targets [,$conditions [,$doc]])
# PDL::PP::Rule::Returns::NULL->new($targets [,$conditions [,$doc]]) # PDL::PP::Rule::Returns::NULL->new($targets [,$conditions [,$doc]])
# which return 0, 1, "", and "NULL" respectively # which return 0, 1, "", and "NULL" respectively
# #
# The InsertName class exists to allow you to return something like # The InsertName class exists to allow you to return something like
# "foo<routine name>bar" # "foo<routine name>bar"
# e.g. # e.g.
# PDL::PP::Rule::InsertName->new("Foo", '_pdl_${name}_bar') # PDL::PP::Rule::InsertName->new("Foo", '_pdl_%s_bar')
# PDL::PP::Rule::InsertName->new("Foo", "Arg2", '_pdl_${name}_bar') # PDL::PP::Rule::InsertName->new("Foo", "Arg2", '_pdl_%s_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 string and use a %s where the name goes
# #
# 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.
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 {
my $self = shift; my $self = shift;
my $str = ref $self; my $str = ref $self;
if ("PDL::PP::Rule" eq $str) { if ("PDL::PP::Rule" eq $str) {
$str = "Rule"; $str = "Rule";
} else { } else {
$str =~ s/PDL::PP::Rule:://; $str =~ s/PDL::PP::Rule:://;
} }
$str = "($str) "; $str = "($str) ";
$str .= exists $self->{doc} ? $str .= "[".join(",", @{$self->{targets}||[]})."]";
$self->{doc} : join(",", @{$self->{targets}}); $str .= "<-[".join(",", @{$self->{conditions}||[]})."] ";
$str .= $self->{doc} if exists $self->{doc};
return $str; return $str;
} }
# Takes two args: the calling object and the message, but we only care # Takes two args: the calling object and the message, but we only care
# about the message: # about the message:
sub report ($$) { print $_[1] if $::PP_VERBOSE; } sub report ($$) { print $_[1] if $::PP_VERBOSE; }
# Very limited error checking. # Very limited error checking.
# Allow scalars for targets and conditions to be optional # Allow scalars for targets and conditions to be optional
# #
skipping to change at line 126 skipping to change at line 127
return 0; return 0;
} }
# $rule->all_conditions_exist($pars); # $rule->all_conditions_exist($pars);
# #
# Returns 1 if all of the required conditions exist in $pars, 0 otherwise. # Returns 1 if all of the required conditions exist in $pars, 0 otherwise.
# A return value of 0 means that the rule should not be applied. # A return value of 0 means that the rule should not be applied.
sub all_conditions_exist { sub all_conditions_exist {
my $self = shift; my $self = shift;
my $pars = shift; my $pars = shift;
return 1 unless my @nonexist = grep !ref() && !exists $pars->{$_}, @{$self-> {conditions}}; return 1 unless my @nonexist = grep !/\?$/ && !exists $pars->{$_}, @{$self-> {conditions}};
$self->report("--skipping since CONDITIONs (@nonexist) do not exist\n"); $self->report("--skipping since CONDITIONs (@nonexist) do not exist\n");
0; 0;
} }
# $rule->should_apply($pars); # $rule->should_apply($pars);
# #
# Returns 1 if the rule should be applied (ie no targets already # Returns 1 if the rule should be applied (ie no targets already
# exist in $pars and all the required conditions exist in $pars), # exist in $pars and all the required conditions exist in $pars),
# otherwise 0. # otherwise 0.
# #
skipping to change at line 148 skipping to change at line 149
my $self = shift; my $self = shift;
my $pars = shift; my $pars = shift;
return 0 if $self->any_targets_exist($pars); return 0 if $self->any_targets_exist($pars);
return 0 unless $self->all_conditions_exist($pars); return 0 unless $self->all_conditions_exist($pars);
return 1; return 1;
} }
# my @args = $self->extract_args($pars); # my @args = $self->extract_args($pars);
sub extract_args { sub extract_args {
my ($self, $pars) = @_; my ($self, $pars) = @_;
@$pars{ map ref($_) eq "SCALAR" ? $$_ : $_, @{ $self->{conditions} } }; @$pars{ map {(my $r=$_)=~s/\?$//;$r} @{ $self->{conditions} } };
} }
# Apply the rule using the supplied $pars hash reference. # Apply the rule using the supplied $pars hash reference.
# #
sub apply { sub apply {
my $self = shift; my $self = shift;
my $pars = shift; my $pars = shift;
carp "Unable to apply rule $self as there is no subroutine reference!" carp "Unable to apply rule $self as there is no subroutine reference!"
unless exists $self->{ref}; unless exists $self->{ref};
skipping to change at line 214 skipping to change at line 215
use Carp; use Carp;
sub new { sub new {
croak('Usage: PDL::PP::Rule::Croak->new(["incompatible", "arguments"], "Croa king message")') croak('Usage: PDL::PP::Rule::Croak->new(["incompatible", "arguments"], "Croa king message")')
unless @_ == 3; unless @_ == 3;
shift->SUPER::new([], @_); shift->SUPER::new([], @_);
} }
sub apply { sub apply {
my ($self, $pars) = @_; my ($self, $pars) = @_;
$self->report("Applying: $self\n");
croak($self->{doc}) if $self->should_apply($pars); croak($self->{doc}) if $self->should_apply($pars);
} }
package PDL::PP::Rule::Returns; package PDL::PP::Rule::Returns;
use strict; use strict;
use Carp; use Carp;
our @ISA = qw (PDL::PP::Rule); our @ISA = qw (PDL::PP::Rule);
# This class does not treat return values of "DO NOT SET!!" # This class does not treat return values of "DO NOT SET!!"
skipping to change at line 304 skipping to change at line 306
} }
package PDL::PP::Rule::InsertName; package PDL::PP::Rule::InsertName;
use strict; use strict;
use Carp; use Carp;
our @ISA = qw (PDL::PP::Rule); our @ISA = qw (PDL::PP::Rule);
# This class does not treat return values of "DO NOT SET!!" # This class does not treat return values of "DO NOT SET!!"
# as special. # as special.
#
sub new { sub new {
my $class = shift; my $class = shift;
my $value = pop; my $value = pop;
my @args = @_; my @args = @_;
my $self = $class->SUPER::new(@args); my $self = $class->SUPER::new(@args);
$self->{"insertname.value"} = $value; $self->{"insertname.value"} = $value;
# Generate a default doc string
# Generate a defaul doc string $self->{doc} ||= "Sets $self->{targets}->[0] to \"$value\"";
unless (exists $self->{doc}) {
$self->{doc} = 'Sets ' . $self->{targets}->[0]
. ' to "' . $value . '"';
}
my $targets = $self->{targets}; my $targets = $self->{targets};
croak "There can only be 1 target for a $self, not " . (1+$#$targets) . "!" croak "There can only be 1 target for a $self, not " . (1+$#$targets) . "!"
unless $#$targets == 0; unless @$targets == 1;
unshift @{$self->{conditions}}, "Name"; # add "Name" as first condition
# we add "Name" as the first condition
#
my $conditions = $self->{conditions};
unshift @$conditions, "Name";
return $self; return $self;
} }
sub apply { sub apply {
my $self = shift; my $self = shift;
my $pars = shift; my $pars = shift;
carp "Unable to apply rule $self as there is no return value!" carp "Unable to apply rule $self as there is no return value!"
unless exists $self->{"insertname.value"}; unless exists $self->{"insertname.value"};
$self->report("Applying: $self\n"); $self->report("Applying: $self\n");
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]; $self->report ("--setting: $target (name=$pars->{Name})\n");
my $name = $pars->{Name}; $pars->{$target} = sprintf $self->{"insertname.value"}, $pars->{Name};
$self->report ("--setting: $target (name=$name)\n");
$pars->{$target} = eval "return \"" . $self->{"insertname.value"} . "\";";
} }
# PDL::PP::Rule->new("NewXSCoerceMustSubs", ["NewXSCoerceMustSub1","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.
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 { "($_[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,$compobj,$privobj) = @_; my ($src,$sname,$pname,$name,$sig,$compobj,$privobj) = @_;
my $ret = (ref $src ? $src->[0] : $src); my $ret = (ref $src ? $src->[0] : $src);
my @pairs; my @pairs;
for ([$compobj,'COMP'], [$privobj,'PRIV']) { for ([$compobj,'COMP'], [$privobj,'PRIV']) {
my ($cobj, $which) = @$_; my ($cobj, $which) = @$_;
my ($cn,$co) = map $cobj->$_, qw(othernames otherobjs); my ($cn,$co) = map $cobj->$_, qw(othernames otherobjs);
push @pairs, 'DO'.$which.'ALLOC' => sub { push @pairs, 'DO'.$which.'ALLOC' => sub {
join '', map $$co{$_}->get_malloc("\$$which($_)"), join '', map $$co{$_}->get_malloc("\$$which($_)"),
grep $$co{$_}->need_malloc, @$cn grep $$co{$_}->need_malloc, @$cn
}; };
} }
my %syms = ( my %syms = (
@pairs, @pairs,
((ref $src) ? %{$src->[1]} : ()), ((ref $src) ? %{$src->[1]} : ()),
PRIV => sub {return "$sname->$_[0]"}, PRIV => sub {return "$sname->$_[0]"},
COMP => sub {my $r="$pname->$_[0]";$sig->other_is_out($_[0])?"(*($r))":$r} COMP => sub {my $r="$pname->$_[0]";$sig->other_is_output($_[0])?"(*($r))":
, $r},
CROAK => sub {PDL::PP::pp_line_numbers(__LINE__-1, "return PDL->make_error CROAK => sub {"return PDL->make_error(PDL_EUSERERROR, \"Error in $name:\"
(PDL_EUSERERROR, \"Error in $name:\" @{[join ',', @_]})")}, @{[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 SETPDLSTATEBAD => sub { "$_[0]\->state |= PDL_BADVAL" },
te |= PDL_BADVAL") }, SETPDLSTATEGOOD => sub { "$_[0]\->state &= ~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 BADFLAGCACHE => sub { "badflag_cache" },
he") }, PDLSTATESETBAD => sub { ($sig->objs->{$_[0]}//confess "Can't get PDLSTATES
PDLSTATESETBAD => sub { PDL::PP::pp_line_numbers(__LINE__-1, ($sig->objs-> ETBAD for unknown ndarray '$_[0]'")->do_pdlaccess."->state |= PDL_BADVAL" },
{$_[0]}//confess "Can't get PDLSTATESETBAD for unknown ndarray '$_[0]'")->do_pdl PDLSTATESETGOOD => sub { ($sig->objs->{$_[0]}->do_pdlaccess//confess "Can'
access."->state |= PDL_BADVAL") }, 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 SETNDIMS => sub {"PDL_RETERROR(PDL_err, PDL->reallocdims(__it,$_[0]));"},
r, PDL->reallocdims(__it,$_[0]));")}, SETDIMS => sub {"PDL_RETERROR(PDL_err, PDL->setdims_careful(__it));"},
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)}, SETDELTABROADCASTIDS => sub {PDL::PP::pp_line_numbers(__LINE__, <<EOF)},
{int __ind; PDL_RETERROR(PDL_err, PDL->reallocbroadcastids(\$PDL(CHILD), \$PDL(P ARENT)->nbroadcastids)); {int __ind; PDL_RETERROR(PDL_err, PDL->reallocbroadcastids(\$PDL(CHILD), \$PDL(P ARENT)->nbroadcastids));
for(__ind=0; __ind<\$PDL(PARENT)->nbroadcastids; __ind++) for(__ind=0; __ind<\$PDL(PARENT)->nbroadcastids; __ind++)
\$PDL(CHILD)->broadcastids[__ind] = \$PDL(PARENT)->broadcastids[__ind] + ($_[0 ]); \$PDL(CHILD)->broadcastids[__ind] = \$PDL(PARENT)->broadcastids[__ind] + ($_[0 ]);
} }
EOF EOF
%PDL::PP::macros, %PDL::PP::macros,
); );
my $known_pat = join '|', map quotemeta, sort keys %syms; my $known_pat = join '|', map quotemeta, sort keys %syms;
while (my ($before, $kw, $args, $other) = macro_extract($ret, $known_pat)) { while (my ($before, $kw, $args, $other) = macro_extract($ret, $known_pat)) {
skipping to change at line 467 skipping to change at line 448
\&dosubst_private); \&dosubst_private);
} }
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 = pp_line_numbers(__LINE__, <<'EOF');
#include "pdlperl.h" #include "pdlperl.h"
#define PDL_XS_PREAMBLE \ #define PDL_XS_PREAMBLE(nret) \
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 \
by pp_bless ? (CS) */ \ by pp_bless ? (CS) */ \
HV *bless_stash = 0; \ HV *bless_stash = 0; \
SV *parent = 0; \ SV *parent = 0; \
int nreturn = 0; \ int nreturn = (nret); \
(void)nreturn; (void)nreturn; \
#define PDL_XS_PACKAGEGET \
PDL_COMMENT("Check if you can get a package name for this input value. ") \ PDL_COMMENT("Check if you can get a package name for this input value. ") \
PDL_COMMENT("It can be either a PDL (SVt_PVMG) or a hash which is a ") \ PDL_COMMENT("It can be either a PDL (SVt_PVMG) or a hash which is a ") \
PDL_COMMENT("derived PDL subclass (SVt_PVHV) ") \ PDL_COMMENT("derived PDL subclass (SVt_PVHV) ") \
if (SvROK(ST(0)) && ((SvTYPE(SvRV(ST(0))) == SVt_PVMG) || (SvTYPE(SvRV(ST(0))) do { \
== SVt_PVHV))) { \ if (SvROK(ST(0)) && ((SvTYPE(SvRV(ST(0))) == SVt_PVMG) || (SvTYPE(SvRV(ST(0)
parent = ST(0); \ )) == SVt_PVHV))) { \
if (sv_isobject(parent)){ \ parent = ST(0); \
bless_stash = SvSTASH(SvRV(ST(0))); \ if (sv_isobject(parent)){ \
objname = HvNAME((bless_stash)); PDL_COMMENT("The package to bless outpu bless_stash = SvSTASH(SvRV(ST(0))); \
t vars into is taken from the first input var") \ objname = HvNAME((bless_stash)); PDL_COMMENT("The package to bless ou
tput vars into is taken from the first input var") \
} \
} \ } \
} } while (0)
#define PDL_XS_PERLINIT(name, to_push, method) \ static inline pdl *PDL_XS_pdlinit(pTHX_ char *objname, HV *bless_stash, SV *to_p
if (strcmp(objname,"PDL") == 0) { PDL_COMMENT("shortcut if just PDL") \ ush, char *method, SV **svp) {
name ## _SV = sv_newmortal(); \ dSP;
name = PDL->pdlnew(); \ pdl *ret;
if (!name) PDL->pdl_barf("Error making null pdl"); \ if (strcmp(objname,"PDL") == 0) { PDL_COMMENT("shortcut if just PDL")
PDL->SetSV_PDL(name ## _SV, name); \ ret = PDL->pdlnew();
if (bless_stash) name ## _SV = sv_bless(name ## _SV, bless_stash); \ if (!ret) PDL->pdl_barf("Error making null pdl");
} else { \ if (svp) {
PUSHMARK(SP); \ *svp = sv_newmortal();
XPUSHs(to_push); \ PDL->SetSV_PDL(*svp, ret);
PUTBACK; \ if (bless_stash) *svp = sv_bless(*svp, bless_stash);
perl_call_method(#method, G_SCALAR); \ }
SPAGAIN; \ } else {
name ## _SV = POPs; \ PUSHMARK(SP);
PUTBACK; \ XPUSHs(to_push);
name = PDL->SvPDLV(name ## _SV); \ PUTBACK;
perl_call_method(method, G_SCALAR);
SPAGAIN;
SV *sv = POPs;
PUTBACK;
ret = PDL->SvPDLV(sv);
if (svp) *svp = sv;
} }
return ret;
}
#define PDL_XS_PERLINIT_init() \
PDL_XS_pdlinit(aTHX_ objname, bless_stash, sv_2mortal(newSVpv(objname, 0)), "i
nitialize", NULL)
#define PDL_XS_PERLINIT_initsv(sv) \
PDL_XS_pdlinit(aTHX_ objname, bless_stash, sv_2mortal(newSVpv(objname, 0)), "i
nitialize", &sv)
#define PDL_XS_PERLINIT_copy() \
PDL_XS_pdlinit(aTHX_ objname, bless_stash, parent, "copy", NULL)
#define PDL_XS_PERLINIT_copysv(sv) \
PDL_XS_pdlinit(aTHX_ objname, bless_stash, parent, "copy", &sv)
#define PDL_XS_RETURN(clause1) \ #define PDL_XS_RETURN(clause1) \
if (nreturn) { \ if (nreturn) { \
if (nreturn > 0) EXTEND (SP, nreturn); \ if (nreturn > 0) EXTEND (SP, nreturn); \
clause1; \ clause1; \
XSRETURN(nreturn); \ XSRETURN(nreturn); \
} else { \ } else { \
XSRETURN(0); \ XSRETURN(0); \
} }
#define PDL_XS_INPLACE(in, out, noutca) \ #define PDL_IS_INPLACE(in) ((in)->state & PDL_INPLACE)
if (in->state & PDL_INPLACE) { \ #define PDL_XS_INPLACE(in, out, whichinit) \
if (nreturn == noutca && out != in) { \ if (PDL_IS_INPLACE(in)) { \
barf("inplace input but different output given"); \ if (out ## _SV) barf("inplace input but different output given"); \
} else { \ out ## _SV = sv_newmortal(); \
in->state &= ~PDL_INPLACE; PDL_COMMENT("unset") \ in->state &= ~PDL_INPLACE; PDL_COMMENT("unset") \
out = in; \ out = in; \
PDL->SetSV_PDL(out ## _SV,out); \ PDL->SetSV_PDL(out ## _SV,out); \
} \ } else \
} out = out ## _SV ? PDL_CORE_(SvPDLV)(out ## _SV) : \
PDL_XS_PERLINIT_ ## whichinit ## sv(out ## _SV);
EOF EOF
our $header_c = pp_line_numbers(__LINE__, <<'EOF'); our $header_c = pp_line_numbers(__LINE__, <<'EOF');
/* /*
* THIS FILE WAS GENERATED BY PDL::PP! Do not modify! * THIS FILE WAS GENERATED BY PDL::PP! Do not modify!
*/ */
#define PDL_COMMENT(comment) #define PDL_COMMENT(comment)
PDL_COMMENT("This preprocessor symbol is used to add commentary in the PDL ") PDL_COMMENT("This preprocessor symbol is used to add commentary in the PDL ")
PDL_COMMENT("autogenerated code. Normally, one would use typical C-style ") PDL_COMMENT("autogenerated code. Normally, one would use typical C-style ")
skipping to change at line 564 skipping to change at line 561
ntpriv_free_code \ ntpriv_free_code \
} }
#include "EXTERN.h" #include "EXTERN.h"
#include "perl.h" #include "perl.h"
#include "XSUB.h" #include "XSUB.h"
#include "pdl.h" #include "pdl.h"
#include "pdlcore.h" #include "pdlcore.h"
#define PDL %s #define PDL %s
extern Core* PDL; PDL_COMMENT("Structure hold core C functions") extern Core* PDL; PDL_COMMENT("Structure hold core C functions")
static int __pdl_boundscheck = 0;
#if ! %s
# define PP_INDTERM(max, at) at
#else
# define PP_INDTERM(max, at) (__pdl_boundscheck? PDL->safe_indterm(max,at, __FIL
E__, __LINE__) : at)
#endif
EOF EOF
our $header_xs = pp_line_numbers(__LINE__, <<'EOF'); our $header_xs = <<'EOF';
Core* PDL = NULL; PDL_COMMENT("Structure hold core C functions") Core* PDL = NULL; PDL_COMMENT("Structure hold core C functions")
MODULE = %1$s PACKAGE = %1$s MODULE = %1$s PACKAGE = %2$s PREFIX=pdl_run_
PROTOTYPES: DISABLE PROTOTYPES: DISABLE
int EOF
set_boundscheck(i) our $header_xsboot = pp_line_numbers(__LINE__, <<'EOF');
int i;
CODE:
if (! %6$s)
warn("Bounds checking is disabled for %1$s");
RETVAL = __pdl_boundscheck;
__pdl_boundscheck = i;
OUTPUT:
RETVAL
MODULE = %1$s PACKAGE = %2$s
%3$s
BOOT: BOOT:
PDL_COMMENT("Get pointer to structure of core shared C routines") PDL_COMMENT("Get pointer to structure of core shared C routines")
PDL_COMMENT("make sure PDL::Core is loaded") PDL_COMMENT("make sure PDL::Core is loaded")
%4$s
%5$s
EOF EOF
use Config; use Config;
use Exporter; use Exporter;
use Data::Dumper; use Data::Dumper;
our @ISA = qw(Exporter); our @ISA = qw(Exporter);
our @EXPORT = qw/pp_addhdr pp_addpm pp_bless pp_def pp_done pp_add_boot our @EXPORT = qw/pp_addhdr pp_addpm pp_bless pp_def pp_done pp_add_boot
pp_add_exported pp_addxs pp_add_isa pp_export_nothing pp_add_exported pp_addxs pp_add_isa pp_export_nothing
pp_add_typemaps pp_add_typemaps
pp_core_importList pp_beginwrap pp_setversion pp_core_importList pp_beginwrap pp_setversion
pp_addbegin pp_boundscheck pp_line_numbers pp_addbegin pp_line_numbers
pp_deprecate_module pp_add_macros/; pp_deprecate_module pp_add_macros/;
$PP::boundscheck = 1;
$::PP_VERBOSE = 0; $::PP_VERBOSE = 0;
our $done = 0; # pp_done has not been called yet our $done = 0; # pp_done has not been called yet
use Carp; use Carp;
sub nopm { $::PDLPACK eq 'NONE' } # flag that we don't want to generate a PM sub nopm { $::PDLPACK eq 'NONE' } # flag that we don't want to generate a PM
sub import { sub import {
my ($mod,$modname, $packname, $prefix, $callpack, $multi_c) = @_; my ($mod,$modname, $packname, $prefix, $callpack, $multi_c) = @_;
skipping to change at line 672 skipping to change at line 645
@funcs; @funcs;
} }
our %macros; our %macros;
sub pp_add_macros { sub pp_add_macros {
confess "Usage: pp_add_macros(name=>sub {},...)" if @_%2; confess "Usage: pp_add_macros(name=>sub {},...)" if @_%2;
%macros = (%macros, @_); %macros = (%macros, @_);
} }
# query/set boundschecking
# if on the generated XS code will have optional boundschecking
# that can be turned on/off at runtime(!) using
# __PACKAGE__::set_boundscheck(arg); # arg should be 0/1
# if off code is speed optimized and no runtime boundschecking
# can be performed
# ON by default
sub pp_boundscheck {
my $ret = $PP::boundscheck;
$PP::boundscheck = $_[0] if $#_ > -1;
return $ret;
}
sub pp_beginwrap { sub pp_beginwrap {
@::PDL_IFBEGINWRAP = ('BEGIN {','}'); @::PDL_IFBEGINWRAP = ('BEGIN {','}');
} }
sub pp_setversion { sub pp_setversion {
my ($ver) = @_; my ($ver) = @_;
$ver = qq{'$ver'} if $ver !~ /['"]/; $ver = qq{'$ver'} if $ver !~ /['"]/;
$::PDLMODVERSION = '$VERSION'; $::PDLMODVERSION = '$VERSION';
$::PDLVERSIONSET = "our \$VERSION = $ver;"; $::PDLVERSIONSET = "our \$VERSION = $ver;";
} }
sub pp_addhdr { sub pp_addhdr {
my ($hdr) = @_; my ($hdr) = @_;
$::PDLXSC .= $hdr; $::PDLXSC .= $hdr;
$::PDLXSC_header .= $hdr if $::PDLMULTI_C; $::PDLXSC_header .= $hdr if $::PDLMULTI_C;
} }
sub pp_addpm { sub _pp_addpm_nolineno {
my $pm = shift; my $pm = shift;
my $pos; my $pos;
if (ref $pm) { if (ref $pm) {
my $opt = $pm; my $opt = $pm;
$pm = shift; $pm = shift;
croak "unknown option" unless defined $opt->{At} && croak "unknown option" unless defined $opt->{At} &&
$opt->{At} =~ /^(Top|Bot|Middle)$/; $opt->{At} =~ /^(Top|Bot|Middle)$/;
$pos = $opt->{At}; $pos = $opt->{At};
} else { } else {
$pos = 'Middle'; $pos = 'Middle';
} }
my @c = caller; $pm =~ s#\n{3,}#\n\n#g;
$::PDLPM{$pos} .= _pp_line_number_file($c[1], $c[2]-1, "\n$pm")."\n\n"; $::PDLPM{$pos} .= "\n$pm\n\n";
}
sub pp_addpm {
my @args = @_;
my $pmind = ref $_[0] ? 1 : 0;
my @c = caller;
$args[$pmind] = _pp_line_number_file($c[1], $c[2]-1, "\n$args[$pmind]");
$args[$pmind] =~ s#\n{3,}#\n\n#g;
_pp_addpm_nolineno(@args);
} }
sub pp_add_exported { sub pp_add_exported {
shift if !$_[0] or $_[0] eq __PACKAGE__; shift if !$_[0] or $_[0] eq __PACKAGE__;
$::PDLPMROUT .= join ' ', @_, ''; $::PDLPMROUT .= join ' ', @_, '';
} }
sub pp_addbegin { sub pp_addbegin {
my ($cmd) = @_; my ($cmd) = @_;
if ($cmd =~ /^\s*BOOT\s*$/) { if ($cmd =~ /^\s*BOOT\s*$/) {
skipping to change at line 766 skipping to change at line 735
} }
sub printxs { sub printxs {
shift; shift;
$::PDLXS .= join'',@_; $::PDLXS .= join'',@_;
} }
sub pp_addxs { sub pp_addxs {
PDL::PP->printxs("\nMODULE = $::PDLMOD PACKAGE = $::CALLPACK\n\n", PDL::PP->printxs("\nMODULE = $::PDLMOD PACKAGE = $::CALLPACK\n\n",
@_, @_,
"\nMODULE = $::PDLMOD PACKAGE = $::PDLOBJ\n\n"); "\nMODULE = $::PDLMOD PACKAGE = $::PDLOBJ PREFIX=pdl_ru n_\n\n");
} }
# inserts #line directives into source text. Use like this: # inserts #line directives into source text. Use like this:
# ... # ...
# FirstKey => ..., # FirstKey => ...,
# Code => pp_line_numbers(__LINE__, $x . $y . $c), # Code => pp_line_numbers(__LINE__, $x . $y . $c),
# OtherKey => ... # OtherKey => ...
sub pp_line_numbers { sub pp_line_numbers {
_pp_line_number_file((caller)[1], @_); _pp_line_number_file((caller)[1], @_);
} }
skipping to change at line 802 skipping to change at line 771
push @to_return, "PDL_LINENO_START $line \"$filename\"\n" ; push @to_return, "PDL_LINENO_START $line \"$filename\"\n" ;
} }
} }
push @to_return, "PDL_LINENO_END\n"; push @to_return, "PDL_LINENO_END\n";
return join('', @to_return); return join('', @to_return);
} }
my $LINE_RE = qr/^(\s*)PDL_LINENO_(?:START (\S+) "(.*)"|(END))$/; my $LINE_RE = qr/^(\s*)PDL_LINENO_(?:START (\S+) "(.*)"|(END))$/;
sub _pp_linenumber_fill { sub _pp_linenumber_fill {
local $_; # else get "Modification of a read-only value attempted" local $_; # else get "Modification of a read-only value attempted"
my ($file, $text) = @_; my ($file, $text) = @_;
my (@stack, @to_return) = [$file, 1]; my (@stack, @to_return) = [1, $file];
my @lines = split /\n/, $text; my @lines = split /\n/, $text;
while (defined($_ = shift @lines)) { REALLINE: while (defined($_ = shift @lines)) {
$_->[1]++ for @stack; $_->[0]++ for @stack;
push(@to_return, $_), next if !/$LINE_RE/; push(@to_return, $_), next if !/$LINE_RE/;
my ($ci, $new_line, $new_file, $is_end) = ($1, $2, $3, $4); my ($ci, $new_line, $new_file, $is_end) = ($1, $2, $3, $4);
if ($is_end) { if (!$is_end) {
@stack = [$file, $stack[0][1]]; # as soon as another block is entered, lin push @stack, [$new_line-1, $new_file];
e numbers for outer blocks become meaningless push @to_return, qq{$ci#line @{[$stack[-1][0]+1]} "$stack[-1][1]"} if @lin
if (@lines > 1 and !length($lines[0]) and $lines[1] =~ /$LINE_RE/) { es;
$stack[-1][1]--; next REALLINE;
} else { }
push @to_return, qq{$ci#line $stack[-1][1] "$stack[-1][0]"} if @lines; @stack = [$stack[0][0], $file]; # as soon as any block is left, line numbers
for outer blocks become meaningless
my ($seen_empty, $empty_first, $last_ci, @last_dir) = (0, undef, $ci); # lis
t=(line, file)
LINE: while (1) {
last REALLINE if !@lines;
if (!length $lines[0]) {
$seen_empty = 1;
shift @lines;
next LINE;
}
if ($lines[0] =~ /$LINE_RE/) { # directive
($last_ci, @last_dir) = ($1, !$4 ? ($2, $3) : ());
$empty_first //= $seen_empty;
shift @lines;
next LINE;
} else { # substantive
push @stack, \@last_dir if @last_dir;
push(@to_return, ''), $stack[0][0]++ if $seen_empty and $empty_first;
push @to_return, qq{$last_ci#line $stack[-1][0] "$stack[-1][1]"};
push(@to_return, ''), $stack[0][0]++ if $seen_empty and !$empty_first;
last LINE;
} }
} else {
push @stack, [$new_file, $new_line-1];
push @to_return, qq{$ci#line @{[$stack[-1][1]+1]} "$stack[-1][0]"} if @lin
es;
} }
} }
join '', map "$_\n", @to_return; join '', map "$_\n", @to_return;
} }
sub _file_same { sub _file_same {
my ($from_text, $to_file) = @_; my ($from_text, $to_file) = @_;
require File::Map; require File::Map;
File::Map::map_file(my $to_map, $to_file, '<'); File::Map::map_file(my $to_map, $to_file, '<');
s/^[^\n]*#line[^\n]*?\n//gm for $from_text, (my $to_text = $to_map); s/^[^\n]*#line[^\n]*?\n//gm for $from_text, (my $to_text = $to_map);
skipping to change at line 844 skipping to change at line 829
open my $fh, '>', $file or confess "open $file: $!"; open my $fh, '>', $file or confess "open $file: $!";
binmode $fh; # to guarantee length will be same for same contents binmode $fh; # to guarantee length will be same for same contents
print $fh $text; print $fh $text;
} }
sub printxsc { sub printxsc {
(undef, my $file) = (shift, shift); (undef, my $file) = (shift, shift);
my $text = join '',@_; my $text = join '',@_;
if (defined $file) { if (defined $file) {
(my $mod_underscores = $::PDLMOD) =~ s#::#_#g; (my $mod_underscores = $::PDLMOD) =~ s#::#_#g;
$text = join '', sprintf($PDL::PP::header_c, $mod_underscores, $PP::boundsch eck), $::PDLXSC_header//'', $text; $text = join '', sprintf($PDL::PP::header_c, $mod_underscores), $::PDLXSC_he ader//'', $text;
_write_file($file, $text); _write_file($file, $text);
} else { } else {
$::PDLXSC .= $text; $::PDLXSC .= $text;
} }
} }
sub pp_done { sub pp_done {
return if $PDL::PP::done; # do only once! return if $PDL::PP::done; # do only once!
$PDL::PP::done = 1; $PDL::PP::done = 1;
print "DONE!\n" if $::PP_VERBOSE; print "DONE!\n" if $::PP_VERBOSE;
print "Inline running PDL::PP version $PDL::PP::VERSION...\n" if nopm(); print "Inline running PDL::PP version $PDL::PP::VERSION...\n" if nopm();
require PDL::Core::Dev; require PDL::Core::Dev;
my $pdl_boot = PDL::Core::Dev::PDL_BOOT('PDL', $::PDLMOD); my $pdl_boot = PDL::Core::Dev::PDL_BOOT('PDL', $::PDLMOD);
my $user_boot = $::PDLXSBOOT//'';
$user_boot =~ s/^\s*(.*?)\n*$/ $1\n/ if $user_boot;
(my $mod_underscores = $::PDLMOD) =~ s#::#_#g; (my $mod_underscores = $::PDLMOD) =~ s#::#_#g;
my $text = join '', my $text = join '',
sprintf($PDL::PP::header_c, $mod_underscores, $PP::boundscheck), sprintf($PDL::PP::header_c, $mod_underscores),
$::PDLXSC//'', $::PDLXSC//'',
$PDL::PP::macros_xs, sprintf($PDL::PP::header_xs, $PDL::PP::macros_xs,
$::PDLMOD, $::PDLOBJ, $::PDLXS, sprintf($PDL::PP::header_xs, $::PDLMOD, $::PDLOBJ),
$pdl_boot, $::PDLXSBOOT//'', $PP::boundscheck, $::PDLXS, "\n",
); $PDL::PP::header_xsboot, $pdl_boot, $user_boot;
_write_file("$::PDLPREF.xs", $text); _write_file("$::PDLPREF.xs", $text);
return if nopm; return if nopm;
$::PDLPMISA = "'".join("','",@::PDLPMISA)."'"; $::PDLPMISA = "'".join("','",@::PDLPMISA)."'";
$::PDLBEGIN = "BEGIN {\n$::PDLBEGIN\n}" $::PDLBEGIN = "BEGIN {\n$::PDLBEGIN\n}"
unless $::PDLBEGIN =~ /^\s*$/; unless $::PDLBEGIN =~ /^\s*$/;
$::PDLMODVERSION //= ''; $::PDLMODVERSION //= '';
$::FUNCSPOD = $::DOCUMENTED ? "\n\n=head1 FUNCTIONS\n\n=cut\n\n" : ''; $::FUNCSPOD = $::DOCUMENTED ? "\n\n=head1 FUNCTIONS\n\n=cut\n\n" : '';
_write_file("$::PDLPREF.pm", join "\n\n", <<EOF, $::PDLBEGIN, $::PDLPM{T op}, $::FUNCSPOD, @::PDLPM{qw(Middle Bot)}, '# Exit with OK status', "1;\n"); _write_file("$::PDLPREF.pm", join "\n\n", <<EOF, $::PDLBEGIN, $::PDLPM{T op}, $::FUNCSPOD, @::PDLPM{qw(Middle Bot)}, '# Exit with OK status', "1;\n");
# #
# GENERATED WITH PDL::PP! Don't modify! # GENERATED WITH PDL::PP! Don't modify!
skipping to change at line 946 skipping to change at line 933
unless exists $obj{FreeFunc}; unless exists $obj{FreeFunc};
my $ctext = join("\n\n",grep $_, @obj{'StructDecl','RedoDimsFunc', my $ctext = join("\n\n",grep $_, @obj{'StructDecl','RedoDimsFunc',
'ReadDataFunc','WriteBackDataFunc', 'ReadDataFunc','WriteBackDataFunc',
'FreeFunc', 'FreeFunc',
'VTableDef','RunFunc', 'VTableDef','RunFunc',
} }
); );
if ($::PDLMULTI_C) { if ($::PDLMULTI_C) {
PDL::PP->printxsc(undef, <<EOF); PDL::PP->printxsc(undef, <<EOF);
extern pdl_transvtable $obj{VTableName};
$obj{RunFuncHdr}; $obj{RunFuncHdr};
EOF EOF
PDL::PP->printxsc("pp-$obj{Name}.c", $ctext); PDL::PP->printxsc("pp-$obj{Name}.c", $ctext);
} else { } else {
PDL::PP->printxsc(undef, $ctext); PDL::PP->printxsc(undef, $ctext);
} }
PDL::PP->printxs($obj{NewXSCode}); PDL::PP->printxs($obj{NewXSCode});
pp_add_boot($obj{BootSetNewXS}) if $obj{BootSetNewXS}; pp_add_boot($obj{BootSetNewXS}) if $obj{BootSetNewXS};
PDL::PP->pp_add_exported($name); PDL::PP->pp_add_exported($name);
PDL::PP::pp_addpm("\n".$obj{PdlDoc}."\n") if $obj{PdlDoc}; PDL::PP::_pp_addpm_nolineno("\n".$obj{PdlDoc}."\n") if $obj{PdlDoc};
PDL::PP::pp_addpm($obj{PMCode}) if defined $obj{PMCode}; PDL::PP::_pp_addpm_nolineno($obj{PMCode}) if defined $obj{PMCode};
PDL::PP::pp_addpm($obj{PMFunc}."\n") if defined $obj{PMFunc}; PDL::PP::_pp_addpm_nolineno($obj{PMFunc}."\n") if defined $obj{PMFunc};
print "*** Leaving pp_def for $name\n" if $::PP_VERBOSE; print "*** Leaving pp_def for $name\n" if $::PP_VERBOSE;
} }
# marks this module as deprecated. This handles the user warnings, and adds a # marks this module as deprecated. This handles the user warnings, and adds a
# notice into the documentation. Can take a {infavor => "newmodule"} option # notice into the documentation. Can take a {infavor => "newmodule"} option
sub pp_deprecate_module sub pp_deprecate_module
{ {
my $options; my $options;
if( ref $_[0] eq 'HASH' ) { $options = shift; } if( ref $_[0] eq 'HASH' ) { $options = shift; }
skipping to change at line 1007 skipping to change at line 993
my $deprecation_notice = <<EOF ; my $deprecation_notice = <<EOF ;
XXX=head1 DEPRECATION NOTICE XXX=head1 DEPRECATION NOTICE
$warning_main $warning_main
$warning_suppression_pod $warning_suppression_pod
XXX=cut XXX=cut
EOF EOF
$deprecation_notice =~ s/^XXX=/=/gms; $deprecation_notice =~ s/^XXX=/=/gms;
pp_addpm( {At => 'Top'}, $deprecation_notice ); _pp_addpm_nolineno( {At => 'Top'}, $deprecation_notice );
pp_addpm {At => 'Top'}, <<EOF; _pp_addpm_nolineno {At => 'Top'}, <<EOF;
warn \"$warning_main\n$warning_suppression_runtime\" unless \$ENV{$envvar}; warn "$warning_main\n$warning_suppression_runtime" unless \$ENV{$envvar};
EOF EOF
} }
use Carp; use Carp;
$SIG{__DIE__} = \&Carp::confess if $::PP_VERBOSE; $SIG{__DIE__} = \&Carp::confess if $::PP_VERBOSE;
my $typemap_obj; my $typemap_obj;
sub _load_typemap { sub _load_typemap {
require ExtUtils::Typemaps; require ExtUtils::Typemaps;
require PDL::Core::Dev; require PDL::Core::Dev;
skipping to change at line 1069 skipping to change at line 1055
pp_addxs($new_obj->as_embedded_typemap); pp_addxs($new_obj->as_embedded_typemap);
$typemap_obj->merge(typemap => $new_obj, replace => 1); $typemap_obj->merge(typemap => $new_obj, replace => 1);
} }
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 {
my $xscode = join '' => @bits; my $xscode = join '', @bits;
$str .= " $xscode_before\n $xscode$xscode_after\n\n"; $str .= "$xscode_before\n$xscode$xscode_after\n";
} }
$str =~ s/(\s*\n)+/\n/g; $str =~ s/(\s*\n)+/\n/g;
($str,$boot,$prelude) ($str,$boot,$prelude)
} }
sub indent($$) { sub indent($$) {
my ($text,$ind) = @_; my ($ind, $text) = @_;
$text =~ s/^(.*)$/$ind$1/mg; return $text if !length $text or !$ind;
$ind = ' ' x $ind;
$text =~ s/^(.+)$/$ind$1/mg;
return $text; return $text;
} }
# This subroutine generates the XS code needed to call the perl 'initialize' # This subroutine generates the XS code needed to call the perl 'initialize'
# routine in order to create new output PDLs # routine in order to create new output PDLs
sub callPerlInit { sub callPerlInit {
my ($names, $callcopy) = @_; my ($sv, $callcopy) = @_;
my $args = $callcopy ? 'parent, copy' : 'sv_2mortal(newSVpv(objname, 0)), in "PDL_XS_PERLINIT_".($callcopy ? "copy" : "init").($sv ? "sv($sv)" : "()");
itialize'; }
join '', map PDL::PP::pp_line_numbers(__LINE__-1, "PDL_XS_PERLINIT($_, $args
)\n"), @$names; sub callTypemap {
my ($x, $ptype) = @_;
my ($setter, $type) = typemap($ptype, 'get_inputmap');
my $ret = typemap_eval($setter, {var=>$x, type=>$type, arg=>("${x}_SV")});
$ret =~ s/^\s*(.*?)\s*$/$1/g;
$ret =~ s/\s*\n\s*/ /g;
$ret;
}
sub reorder_args {
my ($sig, $otherdefaults) = @_;
my %optionals = map +($_=>1), keys(%$otherdefaults);
my @other_mand = grep !$optionals{$_} && !$sig->other_is_out($_),
my @other = @{$sig->othernames(1, 1)};
my @other_opt = grep $optionals{$_}, @other;
($sig->names_in, @other_mand, @other_opt, $sig->names_out, $sig->other_out);
} }
########################################################### ###########################################################
# Name : extract_signature_from_fulldoc # Name : extract_signature_from_fulldoc
# Usage : $sig = extract_signature_from_fulldoc($fulldoc) # Usage : $sig = extract_signature_from_fulldoc($fulldoc)
# Purpose : pull out the signature from the fulldoc string # Purpose : pull out the signature from the fulldoc string
# Returns : whatever is in parentheses in the signature, or undef # Returns : whatever is in parentheses in the signature, or undef
# Parameters : $fulldoc # Parameters : $fulldoc
# Throws : never # Throws : never
# Notes : the signature must have the following form: # Notes : the signature must have the following form:
skipping to change at line 1168 skipping to change at line 1173
for(i=0; i<$PDL(CHILD)->nvals; i++) { for(i=0; i<$PDL(CHILD)->nvals; i++) {
$EQUIVCPOFFS(i,i); $EQUIVCPOFFS(i,i);
}'), }'),
1, 1, 1); 1, 1, 1);
}), }),
# used as a flag for many of the routines # used as a flag for many of the routines
# ie should we bother with bad values for this routine? # ie should we bother with bad values for this routine?
# 1 - yes, # 1 - yes,
# 0 - no, maybe issue a warning # 0 - no, maybe issue a warning
PDL::PP::Rule->new("BadFlag", \"HandleBad", PDL::PP::Rule->new("BadFlag", "HandleBad?",
"Sets BadFlag based upon HandleBad key", "Sets BadFlag based upon HandleBad key",
sub { $_[0] }), sub { $_[0] }),
#################### ####################
# FullDoc Handling # # FullDoc Handling #
#################### ####################
# Error processing: does FullDoc contain BadDoc, yet BadDoc specified? # Error processing: does FullDoc contain BadDoc, yet BadDoc specified?
PDL::PP::Rule::Croak->new(['FullDoc', 'BadDoc'], PDL::PP::Rule::Croak->new(['FullDoc', 'BadDoc'],
'Cannot have both FullDoc and BadDoc defined'), 'Cannot have both FullDoc and BadDoc defined'),
skipping to change at line 1265 skipping to change at line 1270
################################ ################################
# no docs by default # no docs by default
PDL::PP::Rule::Returns->new("Doc", [], 'Sets the default doc string', PDL::PP::Rule::Returns->new("Doc", [], 'Sets the default doc string',
"\n=for ref\n\ninfo not available\n"), "\n=for ref\n\ninfo not available\n"),
# try and automate the docs # try and automate the docs
# could be really clever and include the sig to see about # could be really clever and include the sig to see about
# input/output params, for instance # input/output params, for instance
PDL::PP::Rule->new("BadDoc", ["BadFlag","Name",\"CopyBadStatusCode"], PDL::PP::Rule->new("BadDoc", [qw(BadFlag Name CopyBadStatusCode?)],
'Sets the default documentation for handling of bad values', 'Sets the default documentation for handling of bad values',
sub { sub {
my ( $bf, $name, $code ) = @_; my ( $bf, $name, $code ) = @_;
my $str; my $str;
if ( not defined($bf) ) { if ( not defined($bf) ) {
$str = "$name does not process bad values.\n"; $str = "$name does not process bad values.\n";
} elsif ( $bf ) { } elsif ( $bf ) {
$str = "$name processes bad values.\n"; $str = "$name processes bad values.\n";
} else { } else {
$str = "$name ignores the bad-value flag of the input ndarrays.\n"; $str = "$name ignores the bad-value flag of the input ndarrays.\n";
skipping to change at line 1301 skipping to change at line 1306
# the docs # the docs
PDL::PP::Rule->new("PdlDoc", "FullDoc", sub { PDL::PP::Rule->new("PdlDoc", "FullDoc", sub {
my $fulldoc = shift; my $fulldoc = shift;
# Append a final cut if it doesn't exist due to heredoc shinanigans # Append a final cut if it doesn't exist due to heredoc shinanigans
$fulldoc .= "\n\n=cut\n" unless $fulldoc =~ /\n=cut\n*$/; $fulldoc .= "\n\n=cut\n" unless $fulldoc =~ /\n=cut\n*$/;
# Make sure the =head1 FUNCTIONS section gets added # Make sure the =head1 FUNCTIONS section gets added
$::DOCUMENTED++; $::DOCUMENTED++;
return $fulldoc; return $fulldoc;
} }
), ),
PDL::PP::Rule->new("PdlDoc", ["Name",\"Pars","OtherPars","Doc",\"BadDoc"], PDL::PP::Rule->new("PdlDoc", [qw(Name Pars? OtherPars Doc BadDoc?)],
sub { sub {
my ($name,$pars,$otherpars,$doc,$baddoc) = @_; my ($name,$pars,$otherpars,$doc,$baddoc) = @_;
return '' if !defined $doc # Allow explicit non-doc using Doc=>undef return '' if !defined $doc # Allow explicit non-doc using Doc=>undef
or $doc =~ /^\s*internal\s*$/i; or $doc =~ /^\s*internal\s*$/i;
# If the doc string is one line let's have two for the # If the doc string is one line let's have two for the
# reference card information as well # reference card information as well
$doc = "=for ref\n\n".$doc if $doc !~ /\n/; $doc = "=for ref\n\n".$doc if $doc !~ /\n/;
$::DOCUMENTED++; $::DOCUMENTED++;
$pars = "P(); C()" unless $pars; $pars = "P(); C()" unless $pars;
# Strip leading whitespace and trailing semicolons and whitespace # Strip leading whitespace and trailing semicolons and whitespace
skipping to change at line 1364 skipping to change at line 1369
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)],
["P2Child","Name","StructName"], ["P2Child","Name","StructName"],
sub { sub {
my (undef,$name,$sname) = @_; my (undef,$name,$sname) = @_;
("PARENT(); [oca]CHILD();",0,0,[PDL::Types::ppdefs_all()],1, ("PARENT(); [oca]CHILD();",0,0,[PDL::Types::ppdefs_all()],1,
pp_line_numbers(__LINE__-1,"\tpdl *__it = $sname->pdls[1];\n\tpdl *__p "pdl *__it = $sname->pdls[1];\n",
arent = $sname->pdls[0];\n"), "PDL->hdr_childcopy($sname); $sname->dims_redone = 1;\n",
pp_line_numbers(__LINE__-1,"PDL->hdr_childcopy($sname);\n$sname->dims_
redone = 1;\n"),
); );
}), }),
# Question: where is ppdefs defined? # Question: where is ppdefs defined?
# Answer: Core/Types.pm # Answer: Core/Types.pm
# #
PDL::PP::Rule->new("GenericTypes", [], PDL::PP::Rule->new("GenericTypes", [],
'Sets GenericTypes flag to all real types known to PDL::Types', 'Sets GenericTypes flag to all real types known to PDL::Types',
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_%s_vtable'),
PDL::PP::Rule::Returns->new("Priv", "AffinePriv", 'PDL_Indx incs[$PDL(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", [qw(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, ' ' int i,cor;
int i,cor;
'.$dimcheck.' '.$dimcheck.'
$SETNDIMS($PDL(PARENT)->ndims); $SETNDIMS($PDL(PARENT)->ndims);
$DOPRIVALLOC(); $DOPRIVALLOC();
$PRIV(offs) = 0; $PRIV(offs) = 0;
for(i=0; i<$PDL(CHILD)->ndims; i++) { for(i=0; i<$PDL(CHILD)->ndims; i++) {
cor = '.$pdimexpr.'; cor = '.$pdimexpr.';
$PDL(CHILD)->dims[i] = $PDL(PARENT)->dims[cor]; $PDL(CHILD)->dims[i] = $PDL(PARENT)->dims[cor];
$PRIV(incs)[i] = $PDL(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
# wart of C preprocessing. They look like statements but sometimes # wart of C preprocessing. They look like statements but sometimes
# process into blocks, so if/then/else constructs can get broken. # process into blocks, so if/then/else constructs can get broken.
# Either (1) use blocks for if/then/else, or (2) get excited and # Either (1) use blocks for if/then/else, or (2) get excited and
# use the "do {BLOCK} while(0)" block-to-statement conversion construct # use the "do {BLOCK} while(0)" block-to-statement conversion construct
# in the substitution. I'm too Lazy. --CED 27-Jan-2003 # in the substitution. I'm too Lazy. --CED 27-Jan-2003
skipping to change at line 1432 skipping to change at line 1436
my $good = shift; my $good = shift;
my $bflag = shift; my $bflag = shift;
my $bad = $good; my $bad = $good;
# parse 'good' code # parse 'good' code
$good =~ s/\$EQUIVCPOFFS\(([^()]+),([^()]+)\)/\$PP(CHILD)[$1] = \$PP(PAR ENT)[$2]/g; $good =~ s/\$EQUIVCPOFFS\(([^()]+),([^()]+)\)/\$PP(CHILD)[$1] = \$PP(PAR ENT)[$2]/g;
$good =~ s/\$EQUIVCPTRUNC\(([^()]+),([^()]+),([^()]+)\)/\$PP(CHILD)[$1] = ($3) ? 0 : \$PP(PARENT)[$2]/g; $good =~ s/\$EQUIVCPTRUNC\(([^()]+),([^()]+),([^()]+)\)/\$PP(CHILD)[$1] = ($3) ? 0 : \$PP(PARENT)[$2]/g;
return $good if !$bflag; return $good if !$bflag;
# parse 'bad' code # parse 'bad' code
$bad =~ s/\$EQUIVCPOFFS\(([^()]+),([^()]+)\)/if( \$PPISBAD(PARENT,[$2]) ) { \$PPSETBAD(CHILD,[$1]); } else { \$PP(CHILD)[$1] = \$PP(PARENT)[$2]; }/g; $bad =~ s/\$EQUIVCPOFFS\(([^()]+),([^()]+)\)/if( \$PPISBAD(PARENT,[$2]) ) { \$PPSETBAD(CHILD,[$1]); } else { \$PP(CHILD)[$1] = \$PP(PARENT)[$2]; }/g;
$bad =~ s/\$EQUIVCPTRUNC\(([^()]+),([^()]+),([^()]+)\)/ if( ($3) || \$PP ISBAD(PARENT,[$2]) ) { \$PPSETBAD(CHILD,[$1]); } else {\$PP(CHILD)[$1] = \$PP(PA RENT)[$2]; }/g; $bad =~ s/\$EQUIVCPTRUNC\(([^()]+),([^()]+),([^()]+)\)/ if( ($3) || \$PP ISBAD(PARENT,[$2]) ) { \$PPSETBAD(CHILD,[$1]); } else {\$PP(CHILD)[$1] = \$PP(PA RENT)[$2]; }/g;
PDL::PP::pp_line_numbers(__LINE__-1, 'if ( $PRIV(bvalflag) ) { ' . $bad . ' } else { ' . $good . '}'); 'if ( $PRIV(bvalflag) ) { ' . $bad . ' } else { ' . $good . '}';
}), }),
PDL::PP::Rule->new("BackCode", ["EquivCPOffsCode","BadFlag"], PDL::PP::Rule->new("BackCode", ["EquivCPOffsCode","BadFlag"],
"create BackCode from EquivCPOffsCode", "create BackCode from EquivCPOffsCode",
# If there is an EquivCPOffsCode and: # If there is an EquivCPOffsCode and:
# no bad-value support ==> use that # no bad-value support ==> use that
# bad value support ==> write a bit of code that does # bad value support ==> write a bit of code that does
# if ( $PRIV(bvalflag) ) { bad-EquivCPOffsCode } # if ( $PRIV(bvalflag) ) { bad-EquivCPOffsCode }
# else { good-EquivCPOffsCode } # else { good-EquivCPOffsCode }
# #
skipping to change at line 1477 skipping to change at line 1481
sub { sub {
my ($good, $bflag) = @_; my ($good, $bflag) = @_;
my $bad = $good; my $bad = $good;
# parse 'good' code # parse 'good' code
$good =~ s/\$EQUIVCPOFFS\(([^()]+),([^()]+)\)/\$PP(PARENT)[$2] = \$PP(CH ILD)[$1]/g; $good =~ s/\$EQUIVCPOFFS\(([^()]+),([^()]+)\)/\$PP(PARENT)[$2] = \$PP(CH ILD)[$1]/g;
$good =~ s/\$EQUIVCPTRUNC\(([^()]+),([^()]+),([^()]+)\)/if(!($3)) \$PP(P ARENT)[$2] = \$PP(CHILD)[$1] /g; $good =~ s/\$EQUIVCPTRUNC\(([^()]+),([^()]+),([^()]+)\)/if(!($3)) \$PP(P ARENT)[$2] = \$PP(CHILD)[$1] /g;
return $good if !$bflag; return $good if !$bflag;
# parse 'bad' code # parse 'bad' code
$bad =~ s/\$EQUIVCPOFFS\(([^()]+),([^()]+)\)/if( \$PPISBAD(CHILD,[$1]) ) { \$PPSETBAD(PARENT,[$2]); } else { \$PP(PARENT)[$2] = \$PP(CHILD)[$1]; }/g; $bad =~ s/\$EQUIVCPOFFS\(([^()]+),([^()]+)\)/if( \$PPISBAD(CHILD,[$1]) ) { \$PPSETBAD(PARENT,[$2]); } else { \$PP(PARENT)[$2] = \$PP(CHILD)[$1]; }/g;
$bad =~ s/\$EQUIVCPTRUNC\(([^()]+),([^()]+),([^()]+)\)/if(!($3)) { if( \ $PPISBAD(CHILD,[$1]) ) { \$PPSETBAD(PARENT,[$2]); } else { \$PP(PARENT)[$2] = \$ PP(CHILD)[$1]; } } /g; $bad =~ s/\$EQUIVCPTRUNC\(([^()]+),([^()]+),([^()]+)\)/if(!($3)) { if( \ $PPISBAD(CHILD,[$1]) ) { \$PPSETBAD(PARENT,[$2]); } else { \$PP(PARENT)[$2] = \$ PP(CHILD)[$1]; } } /g;
PDL::PP::pp_line_numbers(__LINE__-1, 'if ( $PRIV(bvalflag) ) { ' . $bad . ' } else { ' . $good . '}'); 'if ( $PRIV(bvalflag) ) { ' . $bad . ' } else { ' . $good . '}';
}), }),
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", '_%s_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::Returns::EmptyString->new("Priv"),
PDL::PP::Rule->new("PrivObj", ["BadFlag","Priv"], PDL::PP::Rule->new("PrivObj", ["BadFlag","Priv"],
sub { PDL::PP::Signature->new('', @_) }), 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 # Compiled representations i.e. what the RunFunc function leaves
# in the params structure. By default, copies of the parameters # in the params structure. By default, copies of the parameters
# but in many cases (e.g. slice) a benefit can be obtained # but in many cases (e.g. slice) a benefit can be obtained
# by parsing the string in that function. # by parsing the string in that function.
# If the user wishes to specify their own MakeComp code and Comp content, # If the user wishes to specify their own MakeComp code and Comp content,
# The next definitions allow this. # The next definitions allow this.
PDL::PP::Rule->new("CompObj", ["BadFlag","Comp"], PDL::PP::Rule->new("CompObj", [qw(BadFlag OtherPars Comp?)],
sub { PDL::PP::Signature->new('', @_) }), sub { PDL::PP::Signature->new('', $_[0], join(';', grep defined() && /[^\s
PDL::PP::Rule->new("CompObj", "SignatureObj", sub { @_ }), # provide default ;]/, @_[1..$#_])) }),
PDL::PP::Rule->new("CompStructOther", "SignatureObj", sub {$_[0]->getcomp}), PDL::PP::Rule->new("CompStruct", ["CompObj"], 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
return 0 if !($noDimmedArgs == 0 and $noArgs == 2); return 0 if !($noDimmedArgs == 0 and $noArgs == 2);
# Check to see if output arg is _not_ explicitly typed: # Check to see if output arg is _not_ explicitly typed:
!$sig->objs->{$sig->names->[1]}{FlagTyped}; !$sig->objs->{$sig->names->[1]}{FlagTypeOverride};
}), }),
PDL::PP::Rule->new(["InplaceCode"], ["SignatureObj","Inplace"], PDL::PP::Rule->new("InplaceNormalised", ["SignatureObj","Inplace"],
'Insert code (just after HdrCode) to ensure the routine can 'interpret Inplace and Signature to get input/output',
be done inplace',
# insert code, after the autogenerated xs argument processing code
# produced by VarArgsXSHdr and AFTER any in HdrCode
# - this code flags the routine as working inplace,
#
# Inplace can be supplied several values # Inplace can be supplied several values
# => 1 # => 1
# assumes fn has an input and output ndarray (eg 'a(); [o] b();') # assumes fn has an input and output ndarray (eg 'a(); [o] b();')
# => [ 'a' ] # => [ 'a' ]
# assumes several input ndarrays in sig, so 'a' labels which # assumes several input ndarrays in sig, so 'a' labels which
# one is to be marked inplace # one is to be marked inplace
# => [ 'a', 'b' ] # => [ 'a', 'b' ]
# input ndarray is a(), output ndarray is 'b' # input ndarray is a(), output ndarray is 'b'
# this will set InplaceNormalised to [input,output]
sub { sub {
my ( $sig, $arg ) = @_; my ($sig, $arg) = @_;
return '' if !$arg; confess 'Inplace given false value' if !$arg;
confess "Inplace array-ref (@$arg) > 2 elements" if ref($arg) eq "ARRAY" and @$arg > 2; confess "Inplace array-ref (@$arg) > 2 elements" if ref($arg) eq "ARRAY" and @$arg > 2;
# find input and output ndarrays # find input and output ndarrays
my @out = $sig->names_out; my %is_out = map +($_=>1), my @out = $sig->names_out;
my @in = $sig->names_in; my @in = $sig->names_in;
my $in = @in == 1 ? $in[0] : undef; my $in = @in == 1 ? $in[0] : undef;
my $out = @out == 1 ? $out[0] : undef; my $out = @out == 1 ? $out[0] : undef;
my %outca = map +($_=>1), $sig->names_oca; my $noutca = $sig->names_oca;
my $noutca = grep $_, values %outca; if (ref($arg) eq "ARRAY" and @$arg) {
if ( ref($arg) eq "ARRAY" and @$arg) {
$in = $$arg[0]; $in = $$arg[0];
$out = $$arg[1] if @$arg > 1; $out = $$arg[1] if @$arg > 1;
} }
confess "ERROR: Inplace does not know name of input ndarray\n" confess "ERROR: Inplace does not know name of input ndarray"
unless defined $in; unless defined $in;
confess "ERROR: Inplace does not know name of output ndarray\n" confess "ERROR: Inplace input ndarray '$in' is actually output"
if $is_out{$in};
confess "ERROR: Inplace does not know name of output ndarray"
unless defined $out; unless defined $out;
PDL::PP::pp_line_numbers(__LINE__-1, "PDL_XS_INPLACE($in, $out, $noutca) my ($in_obj, $out_obj) = map $sig->objs->{$_}, $in, $out;
\n"); confess "ERROR: Inplace output arg $out not [o]\n" if !$$out_obj{FlagW};
my ($in_inds, $out_inds) = map $_->{IndObjs}, $in_obj, $out_obj;
confess "ERROR: Inplace args $in and $out different number of dims"
if @$in_inds != @$out_inds;
for my $i (0..$#$in_inds) {
my ($in_ind, $out_ind) = map $_->[$i], $in_inds, $out_inds;
next if grep !defined $_->{Value}, $in_ind, $out_ind;
confess "ERROR: Inplace Pars $in and $out inds ".join('=',@$in_ind{qw(
Name Value)})." and ".join('=',@$out_ind{qw(Name Value)})." not compatible"
if $in_ind->{Value} != $out_ind->{Value};
}
[$in, $out];
}),
PDL::PP::Rule->new(["InplaceCode"], [qw(InplaceNormalised CallCopy)],
'code to implement working inplace',
# insert code, after the autogenerated xs argument processing code
# produced by VarArgsXSHdr and AFTER any in HdrCode
# - this code flags the routine as working inplace,
sub {
my ($arg, $callcopy) = @_;
my ($in, $out) = @$arg;
" PDL_XS_INPLACE($in, $out, @{[$callcopy ? 'copy' : 'init']})\n";
}), }),
PDL::PP::Rule::Returns::EmptyString->new("InplaceCode", []), PDL::PP::Rule::Returns::EmptyString->new("InplaceCode", []),
PDL::PP::Rule::Returns::EmptyString->new("HdrCode", [], PDL::PP::Rule::Returns::EmptyString->new("HdrCode", [],
'Code that will be inserted at the en 'Code that will be inserted before the call to the RunFunc'),
d of the autogenerated xs argument processing code VargArgsXSHdr'), PDL::PP::Rule::Returns::EmptyString->new("FtrCode", [],
'Code that will be inserted after the call to the RunFunc'),
PDL::PP::Rule->new([], [qw(Name SignatureObj ArgOrder OtherParsDefaults?)],
"Check for ArgOrder errors",
sub {
my ($name, $sig, $argorder, $otherdefaults) = @_;
return if $argorder and !ref $argorder;
confess "$name ArgOrder given false value" if !ref $argorder;
my @names = @{ $sig->allnames(1, 1) };
my %namehash = map +($_=>1), @names;
delete @namehash{@$argorder};
confess "$name ArgOrder missed params: ".join(' ', keys %namehash) if ke
ys %namehash;
my %orderhash = map +($_=>1), @$argorder;
delete @orderhash{@names};
confess "$name ArgOrder too many params: ".join(' ', keys %orderhash) if
keys %orderhash;
my %optionals = map +($_=>1), keys(%$otherdefaults), $sig->names_out, $s
ig->other_out;
my $optional = '';
for (@$argorder) {
$optional = $_, next if exists $optionals{$_};
confess "$name got mandatory argument '$_' after optional argument '$o
ptional'"
if $optional and !exists $optionals{$_};
}
();
}),
PDL::PP::Rule->new([], [qw(Name SignatureObj OtherParsDefaults)],
"Check the OtherPars defaults aren't for ones after ones without",
sub {
my ($name,$sig,$otherdefaults) = @_;
my @other_args = @{ $sig->othernames(1, 1) };
return if keys %$otherdefaults == @other_args;
my $default_seen = '';
for (@other_args) {
$default_seen = $_ if exists $otherdefaults->{$_};
confess "$name got default-less arg '$_' after default-ful arg '$defau
lt_seen'"
if $default_seen and !exists $otherdefaults->{$_};
}
}),
PDL::PP::Rule->new("VarArgsXSHdr", PDL::PP::Rule->new("VarArgsXSHdr",
["Name","SignatureObj", [qw(Name SignatureObj
"HdrCode","InplaceCode",\"CallCopy",\"OtherParsDefaults"], CallCopy? OtherParsDefaults? ArgOrder? InplaceNormalised?)],
'XS code to process input arguments based on supplied Pars argument to pp_ def; not done if GlobalNew or PMCode supplied', 'XS code to process input arguments based on supplied Pars argument to pp_ def; not done if GlobalNew or PMCode supplied',
sub { sub {
my($name,$sig, my($name,$sig,
$hdrcode,$inplacecode,$callcopy,$defaults) = @_; $callcopy,$otherdefaults,$argorder,$inplace) = @_;
$argorder = [reorder_args($sig, $otherdefaults)] if $argorder and !ref $
argorder;
my $optypes = $sig->otherobjs; my $optypes = $sig->otherobjs;
my @args = @{ $sig->allnames(1) }; my @args = @{ $argorder || $sig->allnames(1, 1) };
my %other = map +($_ => exists($$optypes{$_})), @args; my %other = map +($_=>1), @{$sig->othernames(1, 1)};
if (keys %{ $defaults ||= {} } < keys %other) { $otherdefaults ||= {};
my $default_seen = ''; my $ci = 2; # current indenting
for (@args) {
$default_seen = $_ if exists $defaults->{$_};
confess "got default-less arg '$_' after default-ful arg '$default_s
een'"
if $default_seen and !exists $defaults->{$_};
}
}
my $ci = ' '; # current indenting
my %ptypes = map +($_=>$$optypes{$_} ? $$optypes{$_}->get_decl('', {VarA rrays2Ptrs=>1}) : 'pdl *'), @args; my %ptypes = map +($_=>$$optypes{$_} ? $$optypes{$_}->get_decl('', {VarA rrays2Ptrs=>1}) : 'pdl *'), @args;
my %out = map +($_=>1), $sig->names_out_nca; my %out = map +($_=>1), $sig->names_out_nca;
my %outca = map +($_=>1), $sig->names_oca; my %outca = map +($_=>1), $sig->names_oca;
my @inargs = grep !$outca{$_}, @args;
my %other_out = map +($_=>1), $sig->other_out; my %other_out = map +($_=>1), $sig->other_out;
my %tmp = map +($_=>1), $sig->names_tmp; my $nout = keys(%out) + keys(%other_out);
# remember, otherpars *are* input vars my $noutca = keys %outca;
my $nout = grep $_, values %out;
my $noutca = grep $_, values %outca;
my $nother = grep $_, values %other;
my $ntmp = grep $_, values %tmp;
my $ntot = @args; my $ntot = @args;
my $nmaxonstack = $ntot - $noutca;
my $nin = $ntot - ($nout + $noutca);
my $ninout = $nin + $nout;
my $nallout = $nout + $noutca; my $nallout = $nout + $noutca;
my $ndefault = keys %$defaults; my $ndefault = keys %$otherdefaults;
my $usageargs = join ",", map exists $defaults->{$_} ? "$_=$defaults->{$ my %valid_itemcounts = ((my $nmaxonstack = $ntot - $noutca)=>1);
_}" : $_, grep !$tmp{$_}, @args; $valid_itemcounts{my $nin = $nmaxonstack - $nout} = 1;
# Generate declarations for SV * variables corresponding to pdl * output $valid_itemcounts{my $nin_minus_default = "($nin-$ndefault)"} = 1 if $nd
variables. efault;
# These are used in creating output variables. One variable (ex: SV * o my $only_one = keys(%valid_itemcounts) == 1;
utvar1_SV;) my $nretval = $argorder ? $nout :
# is needed for each output and output create always argument $only_one ? $noutca :
my $svdecls = join "\n", map indent("SV *${_}_SV = NULL;",$ci), $sig->na "(items == $nmaxonstack) ? $noutca : $nallout";
mes_out; my ($cnt, @preinit, @xsargs, %already_read, %name2cnts) = -1;
my ($xsargs, $xsdecls) = ('', ''); my %already_read; my $cnt = 0; my %ou my @inputdecls = map "PDL_Indx ${_}_count=0;", grep $other{$_} && $optyp
tother2cnt; es->{$_}->is_array, @inargs;
foreach my $x (@args) { foreach my $x (@inargs) {
next if $outca{$x}; if (!$argorder && ($out{$x} || $other_out{$x} || exists $otherdefaults
last if $out{$x} || ($other{$x} && exists $defaults->{$x}); ->{$x})) {
$already_read{$x} = 1; last if @xsargs + keys(%out) + $noutca != $ntot;
$xsargs .= "$x, "; $xsdecls .= "\n\t$ptypes{$x}$x"; $argorder = 1; # remaining all output ndarrays, engage
$outother2cnt{$x} = $cnt if $other{$x} && $other_out{$x}; }
$cnt++; $cnt++;
} $name2cnts{$x} = [$cnt, $cnt];
my $pars = join "\n",map indent("$_;",$ci), $sig->alldecls(0, 0, \%alrea $already_read{$x} = 1;
dy_read); push @xsargs, $x.(!$argorder ? '' :
$svdecls = join "\n", grep length, $svdecls, map indent(qq{SV *${_}_SV = exists $otherdefaults->{$x} ? "=$otherdefaults->{$x}" :
@{[defined($outother2cnt{$_})?"ST($outother2cnt{$_})":'NULL']};},$ci), $sig->ot !$out{$x} ? '' :
her_out; $inplace && $x eq $inplace->[1] ? "=$x" :
my @create = (); # The names of variables which need to be created by c "=".callPerlInit($x."_SV", $callcopy)
alling );
# the 'initialize' perl routine from the correct packa push @inputdecls, "$ptypes{$x}$x".($inplace && $x eq $inplace->[1] ? "
ge. =NO_INIT" : '');
$ci = ' '; # Current indenting
# clause for reading in all variables
my $clause1 = ''; $cnt = 0;
foreach my $x (@args) {
if ($outca{$x}) {
push @create, $x;
} else {
my ($setter, $type) = typemap($ptypes{$x}, 'get_inputmap');
$setter = typemap_eval($setter, {var=>$x, type=>$type, arg=>($ou
t{$x}||$other_out{$x} ? "${x}_SV = " : '')."ST($cnt)"});
$setter =~ s/.*?(?=$x\s*=\s*)//s; # zap any declarations like wh
ichdims_count
$clause1 .= indent("$setter;\n",$ci) if !$already_read{$x};
$cnt++;
}
} }
# Add code for creating output variables via call to 'initialize' perl r my $shortcnt = my $xs_arg_cnt = $cnt;
outine foreach my $x (@inargs[$cnt+1..$nmaxonstack-1]) {
$clause1 .= indent(callPerlInit(\@create, $callcopy),$ci); $cnt++;
@create = (); $name2cnts{$x} = [$cnt, undef];
# clause for reading in input and creating output vars $name2cnts{$x}[1] = ++$shortcnt if !($out{$x} || $other_out{$x});
my $clause3 = ''; push @xsargs, "$x=$x";
my $defaults_rawcond = $ndefault ? "items == ($nin-$ndefault)" : ''; push @inputdecls, "$ptypes{$x}$x".($other{$x} && !exists $otherdefault
$cnt = 0; s->{$x} ? "; { ".callTypemap($x, $ptypes{$x})."; }" : "=NO_INIT");
foreach my $x (@args) {
if ($out{$x} || $outca{$x}) {
push @create, $x;
} else {
my ($setter, $type) = typemap($ptypes{$x}, 'get_inputmap');
$setter = typemap_eval($setter, {var=>$x, type=>$type, arg=>($ot
her_out{$x} ? "${x}_SV = " : '')."ST($cnt)"});
$setter =~ s/^(.*?)=\s*//s, $setter = "$x = ($defaults_rawcond)
? ($defaults->{$x}) : ($setter)" if exists $defaults->{$x};
$clause3 .= indent("$setter;\n",$ci) if !$already_read{$x};
$cnt++;
}
} }
# Add code for creating output variables via call to 'initialize' perl r push @inputdecls, map "$ptypes{$_}$_=".callPerlInit($_."_SV", $callcopy)
outine .";", grep $outca{$_}, @args;
$clause3 .= indent(callPerlInit(\@create, $callcopy),$ci); @create = (); my $defaults_rawcond = $ndefault ? "items == $nin_minus_default" : '';
my $defaults_cond = $ndefault ? " || $defaults_rawcond" : ''; my $svdecls = join '', map "\n $_",
$clause3 = <<EOF . $clause3; (map "SV *${_}_SV = ".(
else if (items == $nin$defaults_cond) { PDL_COMMENT("only input variables on s !$name2cnts{$_} ? 'NULL' :
tack, create outputs") $argorder ? "items > $name2cnts{$_}[1] ? ST($name2cnts{$_}[1]) : ".(
nreturn = $nallout; $other_out{$_} ? "sv_newmortal()" : "NULL") :
EOF $name2cnts{$_}[0] == ($name2cnts{$_}[1]//-1) ? "ST($name2cnts{$_}[0]
$clause3 = '' if $nmaxonstack == $nin; )" :
my $clause3_coda = $clause3 ? ' }' : ''; "(items == $nmaxonstack) ? ST($name2cnts{$_}[0]) : ".
PDL::PP::pp_line_numbers(__LINE__, <<END); (!defined $name2cnts{$_}[1] ? ($other_out{$_} ? "sv_newmortal()" : "
\nvoid NULL") :
$name($xsargs...)$xsdecls defined $otherdefaults->{$_} ? "!($defaults_rawcond) ? ST($name2cn
PREINIT: ts{$_}[1]) : ".($other_out{$_} ? "sv_newmortal()" : "NULL") :
PDL_XS_PREAMBLE "ST($name2cnts{$_}[1])"
$svdecls )
$pars ).";", (grep !$already_read{$_}, $sig->names_in), $sig->names_out, @{$
sig->othernames(1, 1, \%already_read)}),
;
my $argcode =
indent(2, join '',
(map
"if (!${_}_SV) { $_ = ($otherdefaults->{$_}); } else ".
"{ ".callTypemap($_, $ptypes{$_})."; }\n",
grep !$argorder && exists $otherdefaults->{$_}, @{$sig->othernames
(1, 1)}),
(map callTypemap($_, $ptypes{$_}).";\n", grep !$already_read{$_}, $s
ig->names_in),
(map +("if (${_}_SV) { ".($argorder ? '' : callTypemap($_, $ptypes{$
_}))."; } else ")."$_ = ".callPerlInit($_."_SV", $callcopy).";\n", grep $out{$_}
&& !$already_read{$_} && !($inplace && $_ eq $inplace->[1]), @args)
);
push @preinit, qq[PDL_XS_PREAMBLE($nretval);] if $nallout;
push @preinit, qq{if (!(@{[join ' || ', map "(items == $_)", sort keys %
valid_itemcounts]}))
croak("Usage: ${main::PDLOBJ}::$name(@{[
join ",", map exists $otherdefaults->{$_} ? "$_=$otherdefaults->{$_}" :
$out{$_} || $other_out{$_} ? "[$_]" : $_, @inargs
]}) (you may leave [outputs] and values with =defaults out of list)");}
unless $only_one || $argorder || ($nmaxonstack - ($xs_arg_cnt+1) == ke
ys(%valid_itemcounts)-1);
my $preamble = @preinit ? qq[\n PREINIT:@{[join "\n ", "", @preinit]}\n
INPUT:\n] : '';
join '', qq[
\nNO_OUTPUT pdl_error
pdl_run_$name(@{[join ', ', @xsargs]})$svdecls
$preamble@{[join "\n ", "", @inputdecls]}
PPCODE: PPCODE:
if (items != $nmaxonstack && !(items == $nin$defaults_cond) && items != $ninou ], map "$_\n", $argcode;
t)
croak (\"Usage: PDL::$name($usageargs) (you may leave output variables out
of list)\");
PDL_XS_PACKAGEGET
if (items == $nmaxonstack) { PDL_COMMENT("all variables on stack, read in outp
ut vars")
nreturn = $noutca;
$clause1
}
$clause3$clause3_coda
$hdrcode
$inplacecode
END
}), }),
# globalnew implies internal usage, not XS # globalnew implies internal usage, not XS
PDL::PP::Rule::Returns->new("VarArgsXSReturn","GlobalNew",undef), PDL::PP::Rule::Returns->new("VarArgsXSReturn","GlobalNew",undef),
PDL::PP::Rule->new("FixArgsXSOtherOutDeclSV", PDL::PP::Rule->new("FixArgsXSOtherOutDeclSV",
["SignatureObj"], ["SignatureObj"],
"Generate XS to declare SVs for output OtherPars", "Generate XS to declare SVs for output OtherPars",
sub { sub {
my ($sig) = @_; my ($sig) = @_;
my $optypes = $sig->otherobjs; my $optypes = $sig->otherobjs;
my @args = @{ $sig->allnames(1) }; my @args = @{ $sig->allnames(1, 1) };
my %other = map +($_ => exists($$optypes{$_})), @args;
my %outca = map +($_=>1), $sig->names_oca; my %outca = map +($_=>1), $sig->names_oca;
my %other_out = map +($_=>1), $sig->other_out; my %other_output = map +($_=>1), my @other_output = ($sig->other_io, $si
my $ci = ' '; g->other_out);
my $ci = 2;
my $cnt = 0; my %outother2cnt; my $cnt = 0; my %outother2cnt;
foreach my $x (grep !$outca{$_}, @args) { foreach my $x (grep !$outca{$_}, @args) {
$outother2cnt{$x} = $cnt if $other{$x} && $other_out{$x}; $outother2cnt{$x} = $cnt if $other_output{$x};
$cnt++; $cnt++;
} }
join "\n", map indent(qq{SV *${_}_SV = ST($outother2cnt{$_});},$ci), $si g->other_out; join "\n", map indent($ci,qq{SV *${_}_SV = ST($outother2cnt{$_});}), @ot her_output;
}), }),
PDL::PP::Rule->new("XSOtherOutSet", PDL::PP::Rule->new("XSOtherOutSet",
["SignatureObj"], [qw(Name SignatureObj)],
"Generate XS to set SVs to output values for OtherPars", "Generate XS to set SVs to output values for OtherPars",
sub { sub {
my ($sig) = @_; my ($name, $sig) = @_;
my $clause1 = ''; my $clause1 = '';
my @other_out = $sig->other_out; my @other_output = ($sig->other_io, $sig->other_out);
my $optypes = $sig->otherobjs; my $optypes = $sig->otherobjs;
my %ptypes = map +($_=>$$optypes{$_}->get_decl('', {VarArrays2Ptrs=>1})) my %ptypes = map +($_=>$$optypes{$_}->get_decl('', {VarArrays2Ptrs=>1}))
, @other_out; , @other_output;
for my $x (@other_out) { for my $x (@other_output) {
my ($setter, $type) = typemap($ptypes{$x}, 'get_outputmap'); my ($setter, $type) = typemap($ptypes{$x}, 'get_outputmap');
$setter = typemap_eval($setter, {var=>$x, type=>$type, arg=>"tsv"}); $setter = typemap_eval($setter, {var=>$x, type=>$type, arg=>"tsv"});
$clause1 = <<EOF . $clause1; $clause1 .= <<EOF;
{ SV *tsv = sv_2mortal(newSV(0)); if (!${x}_SV)
PDL->pdl_barf("Internal error in $name: tried to output to NULL ${x}_SV");
{\n SV *tsv = sv_newmortal();
$setter $setter
sv_setsv(${x}_SV, tsv); } sv_setsv(${x}_SV, tsv);\n}
EOF EOF
} }
$clause1; indent(2, $clause1);
}), }),
PDL::PP::Rule->new("VarArgsXSReturn", PDL::PP::Rule->new("VarArgsXSReturn",
["SignatureObj","XSOtherOutSet"], ["SignatureObj"],
"Generate XS trailer to return output variables or leave them as modified input variables", "Generate XS trailer to return output variables or leave them as modified input variables",
sub { sub {
my ($sig,$other_out_set) = @_; my ($sig) = @_;
my @outs = $sig->names_out; # names of output ndarrays in calling order my $oc = my @outs = $sig->names_out; # output ndarrays in calling order
my $clause1 = join ';', map "ST($_) = $outs[$_]_SV", 0 .. $#outs; my @other_outputs = ($sig->other_io, $sig->other_out); # output OtherPar
$other_out_set.PDL::PP::pp_line_numbers(__LINE__-1, "PDL_XS_RETURN($clau s
se1)"); my $clause1 = join ';', (map "ST($_) = $outs[$_]_SV", 0 .. $#outs),
(map "ST(@{[$_+$oc]}) = $other_outputs[$_]_SV", 0 .. $#other_outputs);
$clause1 ? indent(2,"PDL_XS_RETURN($clause1)\n") : '';
}), }),
PDL::PP::Rule->new("NewXSHdr", ["NewXSName","SignatureObj"], PDL::PP::Rule->new("NewXSHdr", ["NewXSName","SignatureObj"],
sub { sub {
my($name,$sig) = @_; my($name,$sig) = @_;
my $shortpars = join ',', @{ $sig->allnames(1) }; my $shortpars = join ',', @{ $sig->allnames(1, 1) };
my $longpars = join "\n", map "\t$_", $sig->alldecls(1, 0); my $optypes = $sig->otherobjs;
my @counts = map "PDL_Indx ${_}_count=0;", grep $optypes->{$_}->is_array
, @{ $sig->othernames(1, 1) };
my $longpars = join "\n", map " $_", @counts, $sig->alldecls(1, 0, 1);
return<<END; return<<END;
\nvoid \nNO_OUTPUT pdl_error
$name($shortpars) $name($shortpars)
$longpars $longpars
END END
}), }),
PDL::PP::Rule::InsertName->new("RunFuncName", 'pdl_${name}_run'), PDL::PP::Rule::InsertName->new("RunFuncName", 'pdl_run_%s'),
PDL::PP::Rule->new("NewXSCHdrs", ["RunFuncName","SignatureObj","GlobalNew"], PDL::PP::Rule->new("NewXSCHdrs", ["RunFuncName","SignatureObj","GlobalNew"],
sub { sub {
my($name,$sig,$gname) = @_; my($name,$sig,$gname) = @_;
my $longpars = join ",", $sig->alldecls(0, 1); my $longpars = join ",", $sig->alldecls(0, 1);
my $opening = 'pdl_error PDL_err = {0, NULL, 0};'; my $opening = ' pdl_error PDL_err = {0, NULL, 0};';
my $closing = 'return PDL_err;'; my $closing = ' return PDL_err;';
return ["pdl_error $name($longpars) {$opening","$closing}", return ["pdl_error $name($longpars) {$opening","$closing}",
"PDL->$gname = $name;"]; " PDL->$gname = $name;"];
}), }),
PDL::PP::Rule->new(["RunFuncCall","RunFuncHdr"],["RunFuncName","SignatureObj" ], sub { PDL::PP::Rule->new(["RunFuncCall","RunFuncHdr"],["RunFuncName","SignatureObj" ], sub {
my ($func_name,$sig) = @_; my ($func_name,$sig) = @_;
my $shortpars = join ',', map $sig->other_is_out($_)?"&$_":$_, @{ $sig-> allnames(0) }; my $shortpars = join ',', map $sig->other_is_output($_)?"&$_":$_, @{ $si g->allnames(0) };
my $longpars = join ",", $sig->alldecls(0, 1); my $longpars = join ",", $sig->alldecls(0, 1);
(PDL::PP::pp_line_numbers(__LINE__-1, "PDL->barf_if_error($func_name($sh ortpars));"), (indent(2,"RETVAL = $func_name($shortpars);\nPDL->barf_if_error(RETVAL); \n"),
"pdl_error $func_name($longpars)"); "pdl_error $func_name($longpars)");
}), }),
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->make_now($_);\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("NewXSTypeCoerceNS", ["StructName"], PDL::PP::Rule->new("NewXSTypeCoerceNS", ["StructName"],
sub { sub { " PDL_RETERROR(PDL_err, PDL->type_coerce($_[0]));\n" }),
PDL::PP::pp_line_numbers(__LINE__, <<EOF);
PDL_RETERROR(PDL_err, PDL->type_coerce($_[0]));
EOF
}),
PDL::PP::Rule::Substitute->new("NewXSTypeCoerceSubd", "NewXSTypeCoerceNS"), PDL::PP::Rule::Substitute->new("NewXSTypeCoerceSubd", "NewXSTypeCoerceNS"),
PDL::PP::Rule->new("NewXSSetTransPDLs", ["SignatureObj","StructName"], sub {
my($sig,$trans) = @_;
join '',
map PDL::PP::pp_line_numbers(__LINE__-1, "$trans->pdls[$_->[0]] = $_->[2
];\n"),
grep !$_->[1], $sig->names_sorted_tuples;
}),
PDL::PP::Rule->new("NewXSExtractTransPDLs", ["SignatureObj","StructName"], su
b {
my($sig,$trans) = @_;
join '',
map PDL::PP::pp_line_numbers(__LINE__, "$_->[2] = $trans->pdls[$_->[0]];
\n"),
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_RETERROR(PDL_err, PDL->make_trans_mutual($trans));\n";
"PDL_RETERROR(PDL_err, PDL->make_trans_mutual($trans));\n");
}), }),
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]).qq[ $comp\n} $ptype;],
$ptype); $ptype);
}), }),
do { do {
sub wrap_vfn { sub wrap_vfn {
my ( my (
$code,$rout,$func_header, $code,$rout,$func_header,
$all_func_header,$sname,$pname,$ptype,$extra_args, $all_func_header,$sname,$pname,$ptype,$extra_args,
) = @_; ) = @_;
PDL::PP::pp_line_numbers(__LINE__, <<EOF); join "", PDL::PP::pp_line_numbers(__LINE__,
pdl_error $rout(pdl_trans *$sname$extra_args) { qq[pdl_error $rout(pdl_trans *$sname$extra_args) {
@{[join "\n ", pdl_error PDL_err = {0, NULL, 0};]),
'pdl_error PDL_err = {0, NULL, 0};', ($ptype ? " $ptype *$pname = $sname->params;\n" : ''),
$ptype ? "$ptype *$pname = $sname->params;" : (), indent(2, join '', grep $_, $all_func_header, $func_header, $code),
(grep $_, $all_func_header, $func_header, $code), 'return PDL_err;' " return PDL_err;\n}";
]}
}
EOF
} }
sub make_vfn_args { sub make_vfn_args {
my ($which, $extra_args) = @_; my ($which, $extra_args) = @_;
("${which}Func", ("${which}Func",
["${which}CodeSubd","${which}FuncName",\"${which}FuncHeader", ["${which}CodeSubd","${which}FuncName","${which}FuncHeader?",
\"AllFuncHeader", qw(StructName ParamStructName ParamStructType), qw(AllFuncHeader? StructName ParamStructName ParamStructType),
], ],
sub {$_[1] eq 'NULL' ? '' : wrap_vfn(@_,$extra_args//'')} sub {$_[1] eq 'NULL' ? '' : wrap_vfn(@_,$extra_args//'')}
); );
} }
()}, ()},
PDL::PP::Rule->new("MakeCompOther", [qw(SignatureObj ParamStructName)], sub { $_[0]->getcopy("$_[1]->%s") }), PDL::PP::Rule->new("MakeCompOther", [qw(SignatureObj ParamStructName)], sub { $_[0]->getcopy("$_[1]->%s") }),
PDL::PP::Rule->new("MakeCompTotal", ["MakeCompOther", \"MakeComp"], sub { joi n "\n", grep $_, @_ }), PDL::PP::Rule->new("MakeCompTotal", [qw(MakeCompOther MakeComp?)], sub { join "\n", grep $_, @_ }),
PDL::PP::Rule::Substitute->new("MakeCompiledReprSubd", "MakeCompTotal"), PDL::PP::Rule::Substitute->new("MakeCompiledReprSubd", "MakeCompTotal"),
PDL::PP::Rule->new("NewXSSetTransPDLs", ["SignatureObj","StructName"], sub {
my($sig,$trans) = @_;
join '',
map " $trans->pdls[$_->[0]] = $_->[2];\n",
grep !$_->[1], $sig->names_sorted_tuples;
}),
PDL::PP::Rule->new("NewXSExtractTransPDLs", [qw(SignatureObj StructName MakeC
omp?)], sub {
my($sig,$trans,$makecomp) = @_;
!$makecomp ? '' : join '',
map " $_->[2] = $trans->pdls[$_->[0]];\n",
grep !$_->[1], $sig->names_sorted_tuples;
}),
(map PDL::PP::Rule::Substitute->new("${_}ReadDataCodeUnparsed", "${_}Code"), '', 'Bad'), (map PDL::PP::Rule::Substitute->new("${_}ReadDataCodeUnparsed", "${_}Code"), '', 'Bad'),
PDL::PP::Rule->new(PDL::PP::Code::make_args(qw(ReadData)), PDL::PP::Rule->new(PDL::PP::Code::make_args(qw(ReadData)),
sub { PDL::PP::Code->new(@_, undef, undef, 1); }), sub { PDL::PP::Code->new(@_, undef, undef, 1); }),
PDL::PP::Rule::Substitute->new("ReadDataCodeSubd", "ReadDataCodeParsed"), PDL::PP::Rule::Substitute->new("ReadDataCodeSubd", "ReadDataCodeParsed"),
PDL::PP::Rule::InsertName->new("ReadDataFuncName", 'pdl_${name}_readdata'), PDL::PP::Rule::InsertName->new("ReadDataFuncName", 'pdl_%s_readdata'),
PDL::PP::Rule->new(make_vfn_args("ReadData")), PDL::PP::Rule->new(make_vfn_args("ReadData")),
(map PDL::PP::Rule::Substitute->new("${_}WriteBackDataCodeUnparsed", "${_}Bac kCode"), '', 'Bad'), (map PDL::PP::Rule::Substitute->new("${_}WriteBackDataCodeUnparsed", "${_}Bac kCode"), '', 'Bad'),
PDL::PP::Rule->new(PDL::PP::Code::make_args(qw(WriteBackData)), PDL::PP::Rule->new(PDL::PP::Code::make_args(qw(WriteBackData)),
sub { PDL::PP::Code->new(@_, undef, 1, 1); }), sub { PDL::PP::Code->new(@_, undef, 1, 1); }),
PDL::PP::Rule::Substitute->new("WriteBackDataCodeSubd", "WriteBackDataCodePar sed"), PDL::PP::Rule::Substitute->new("WriteBackDataCodeSubd", "WriteBackDataCodePar sed"),
PDL::PP::Rule::InsertName->new("WriteBackDataFuncName", "BackCode", 'pdl_${na me}_writebackdata'), PDL::PP::Rule::InsertName->new("WriteBackDataFuncName", "BackCode", 'pdl_%s_w ritebackdata'),
PDL::PP::Rule::Returns::NULL->new("WriteBackDataFuncName", "Code"), PDL::PP::Rule::Returns::NULL->new("WriteBackDataFuncName", "Code"),
PDL::PP::Rule->new(make_vfn_args("WriteBackData")), 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", [qw(Name RedoDims? RedoDimsCode? DimsS etters)],
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',
''), ''),
(map PDL::PP::Rule::Substitute->new("RedoDims${_}Unparsed", "RedoDims$_"), '' , 'Code'), (map PDL::PP::Rule::Substitute->new("RedoDims${_}Unparsed", "RedoDims$_"), '' , 'Code'),
PDL::PP::Rule->new(PDL::PP::Code::make_args(qw(RedoDims)), 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("RedoDimsCodeParsed","RedoDimsUnparsed", sub {@_}),
PDL::PP::Rule->new("RedoDims", PDL::PP::Rule->new("RedoDims",
["DimsSetters","RedoDimsCodeParsed","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::Substitute->new("RedoDimsCodeSubd", "RedoDims"),
PDL::PP::Rule->new(make_vfn_args("RedoDims")), PDL::PP::Rule->new(make_vfn_args("RedoDims")),
PDL::PP::Rule->new("CompFreeCodeOther", "SignatureObj", sub {$_[0]->getfree(" PDL::PP::Rule->new("CompFreeCode", [qw(CompObj CompFreeCodeComp?)],
COMP")}), "Free any OtherPars/Comp stuff, including user-supplied code (which is proba
PDL::PP::Rule->new("CompFreeCodeComp", [qw(CompObj Comp)], sub {$_[0]->getfre bly paired with own MakeComp)",
e("COMP")}), sub {join '', grep defined() && length, $_[0]->getfree("COMP"), @_[1..$#_]},
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_FREE_CODE($_[0], destroy, $_[1], $_[2])" : ''}),
PDL::PP::Rule::Substitute->new("FreeCodeSubd", "FreeCodeNS"), PDL::PP::Rule::Substitute->new("FreeCodeSubd", "FreeCodeNS"),
PDL::PP::Rule->new("FreeFuncName", PDL::PP::Rule->new("FreeFuncName",
["FreeCodeSubd","Name"], ["FreeCodeSubd","Name"],
sub {$_[0] ? "pdl_$_[1]_free" : 'NULL'}), sub {$_[0] ? "pdl_$_[1]_free" : 'NULL'}),
PDL::PP::Rule->new(make_vfn_args("Free", ", char destroy")), PDL::PP::Rule->new(make_vfn_args("Free", ", char destroy")),
PDL::PP::Rule->new("NewXSCoerceMustNS", "FTypes", PDL::PP::Rule->new("NewXSCoerceMustNS", "FTypes",
sub { sub {
my($ftypes) = @_; my($ftypes) = @_;
join '', map join '', map
PDL::PP::pp_line_numbers(__LINE__, "$_->datatype = $ftypes->{$_};"), PDL::PP::pp_line_numbers(__LINE__, "$_->datatype = $ftypes->{$_};"),
sort keys %$ftypes; sort keys %$ftypes;
}), }),
PDL::PP::Rule::Returns::EmptyString->new("NewXSCoerceMustNS"), PDL::PP::Rule::Returns::EmptyString->new("NewXSCoerceMustNS"),
PDL::PP::Rule::Substitute->new("NewXSCoerceMustCompSubd", "NewXSCoerceMustNS" ), PDL::PP::Rule::Substitute->new("NewXSCoerceMustCompSubd", "NewXSCoerceMustNS" ),
PDL::PP::Rule->new("NewXSFindBadStatusNS", ["StructName"], PDL::PP::Rule->new("NewXSFindBadStatusNS", [qw(StructName SignatureObj)],
"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); my $str = "PDL_RETERROR(PDL_err, PDL->trans_check_pdls($_[0]));\n";
PDL_RETERROR(PDL_err, PDL->trans_check_pdls($_[0])); $str .= "char \$BADFLAGCACHE() = PDL->trans_badflag_from_inputs($_[0]);\
char \$BADFLAGCACHE() = PDL->trans_badflag_from_inputs($_[0]); n" if $_[1]->names_out;
EOF indent(2, $str);
}), }),
PDL::PP::Rule->new("NewXSCopyBadStatusNS", PDL::PP::Rule->new("NewXSCopyBadStatusNS",
["CopyBadStatusCode"], ["CopyBadStatusCode"],
"Use CopyBadStatusCode if given", "Use CopyBadStatusCode if given",
sub { sub {
my ($badcode) = @_; my ($badcode) = @_;
confess "PDL::PP ERROR: CopyBadStatusCode contains '\$PRIV(bvalflag)'; r eplace with \$BADFLAGCACHE()" confess "PDL::PP ERROR: CopyBadStatusCode contains '\$PRIV(bvalflag)'; r eplace with \$BADFLAGCACHE()"
if $badcode =~ m/\$PRIV(bvalflag)/; if $badcode =~ m/\$PRIV(bvalflag)/;
$badcode; $badcode;
}), }),
PDL::PP::Rule->new("NewXSCopyBadStatusNS", PDL::PP::Rule->new("NewXSCopyBadStatusNS",
["SignatureObj"], ["SignatureObj"],
"Rule to copy the bad value status to the output ndarrays", "Rule to copy the bad value status to the output ndarrays",
# note: this is executed before the trans_mutual call # note: this is executed before the trans_mutual call
# is made, since the state may be changed by the # is made, since the state may be changed by the
# Code section # Code section
sub { sub {
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 '', !@outs ? '' : PDL::PP::indent(2, join '', # no outs, ditto
"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->new("NewXSFindBadStatusSubd", "NewXSFindBadStatusN S"), PDL::PP::Rule::Substitute->new("NewXSFindBadStatusSubd", "NewXSFindBadStatusN S"),
PDL::PP::Rule::Substitute->new("NewXSCopyBadStatusSubd", "NewXSCopyBadStatusN S"), PDL::PP::Rule::Substitute->new("NewXSCopyBadStatusSubd", "NewXSCopyBadStatusN 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); indent(2, <<EOF . ($ptype ? "$ptype *$pname = $sname->params;\n" : ""));
if (!PDL) return (pdl_error){PDL_EFATAL, "PDL core struct is NULL, can't continu e",0}; if (!PDL) return (pdl_error){PDL_EFATAL, "PDL core struct is NULL, can't continu e",0};
pdl_trans *$sname = PDL->create_trans(&$vtable); pdl_trans *$sname = PDL->create_trans(&$vtable);
if (!$sname) return PDL->make_error_simple(PDL_EFATAL, "Couldn't create trans"); if (!$sname) return PDL->make_error_simple(PDL_EFATAL, "Couldn't create trans");
@{[$ptype ? "$ptype *$pname = $sname->params;" : ""]}
EOF EOF
}), }),
PDL::PP::Rule->new(["RunFunc"], PDL::PP::Rule->new(["RunFunc"],
["RunFuncHdr", ["RunFuncHdr",
"NewXSStructInit0", "NewXSStructInit0",
"NewXSSetTransPDLs", "NewXSSetTransPDLs",
"NewXSFindBadStatusSubd", "NewXSFindBadStatusSubd",
# NewXSMakeNow, # this is unnecessary since families never got imple mented # NewXSMakeNow, # this is unnecessary since families never got imple mented
"NewXSTypeCoerceSubd", "NewXSTypeCoerceSubd",
"NewXSExtractTransPDLs", "NewXSExtractTransPDLs",
"MakeCompiledReprSubd", "MakeCompiledReprSubd",
"NewXSCoerceMustCompSubd", "NewXSCoerceMustCompSubd",
"NewXSRunTrans", "NewXSRunTrans",
"NewXSCopyBadStatusSubd", "NewXSCopyBadStatusSubd",
], ],
"Generate C function with idiomatic arg list to maybe call from XS", "Generate C function with idiomatic arg list to maybe call from XS",
sub { sub {
my ($xs_c_header, @bits) = @_; my ($xs_c_header, @bits) = @_;
my $opening = 'pdl_error PDL_err = {0, NULL, 0};'; my $opening = ' pdl_error PDL_err = {0, NULL, 0};';
my $closing = 'return PDL_err;'; my $closing = ' return PDL_err;';
PDL::PP::pp_line_numbers __LINE__-1, join '', "$xs_c_header {\n$opening\ join '', "$xs_c_header {\n$opening\n", @bits, "$closing\n}\n";
n", @bits, "$closing\n}\n";
}), }),
# internal usage, not XS - NewXSCHdrs only set if GlobalNew # internal usage, not XS - NewXSCHdrs only set if GlobalNew
PDL::PP::Rule->new(["NewXSCode","BootSetNewXS","NewXSInPrelude"], PDL::PP::Rule->new(["NewXSCode","BootSetNewXS","NewXSInPrelude"],
["NewXSHdr", "NewXSCHdrs", "RunFuncCall"], ["NewXSHdr", "NewXSCHdrs", "RunFuncCall"],
"Non-varargs XS code when GlobalNew given", "Non-varargs XS code when GlobalNew given",
sub {(undef,(make_xs_code('CODE:',' XSRETURN(0);',@_))[1..2])}), sub {(undef,(make_xs_code(' CODE:','',@_))[1..2])}),
# 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", qw(FixArgsXSOtherOutDeclSV RunFuncCal l XSOtherOutSet)], [qw(PMCode NewXSHdr NewXSCHdrs? FixArgsXSOtherOutDeclSV RunFuncCall XSOthe rOutSet)],
"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:','',@_[1..$#_])}),
PDL::PP::Rule->new(["NewXSCode","BootSetNewXS","NewXSInPrelude"], PDL::PP::Rule->new(["NewXSCode","BootSetNewXS","NewXSInPrelude"],
[qw(VarArgsXSHdr), \"NewXSCHdrs", qw(RunFuncCall VarArgsXSReturn)], [qw(VarArgsXSHdr NewXSCHdrs? HdrCode InplaceCode RunFuncCall FtrCode XSOth erOutSet 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::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"],
skipping to change at line 2028 skipping to change at line 2061
my $parnames = join(",",map qq|"$_"|, @$pnames) || '""'; my $parnames = join(",",map qq|"$_"|, @$pnames) || '""';
my $parflags = join(",\n ",map join('|', $_->cflags)||'0', @$pobjs{@$pn ames}) || '0'; my $parflags = join(",\n ",map join('|', $_->cflags)||'0', @$pobjs{@$pn ames}) || '0';
my $partypes = join(", ", map defined()?$_->sym:-1, map $_->{Type}, @$po bjs{@$pnames}) || '-1'; my $partypes = join(", ", map defined()?$_->sym:-1, map $_->{Type}, @$po bjs{@$pnames}) || '-1';
my $i = 0; my @starts = map { my $ci = $i; $i += $_; $ci } @realdims; my $i = 0; my @starts = map { my $ci = $i; $i += $_; $ci } @realdims;
my $realdim_ind_start = join(", ", @starts) || '0'; my $realdim_ind_start = join(", ", @starts) || '0';
my @rd_inds = map $_->get_index, map @{$_->{IndObjs}}, @$pobjs{@$pnames} ; my @rd_inds = map $_->get_index, map @{$_->{IndObjs}}, @$pobjs{@$pnames} ;
my $realdim_inds = join(", ", @rd_inds) || '0'; my $realdim_inds = join(", ", @rd_inds) || '0';
my @indnames = $sig->ind_names_sorted; my @indnames = $sig->ind_names_sorted;
my $indnames = join(",", map qq|"$_"|, @indnames) || '""'; my $indnames = join(",", map qq|"$_"|, @indnames) || '""';
my $sizeof = $ptype ? "sizeof($ptype)" : '0'; my $sizeof = $ptype ? "sizeof($ptype)" : '0';
PDL::PP::pp_line_numbers(__LINE__, <<EOF); <<EOF;
static pdl_datatypes ${vname}_gentypes[] = { $gentypes_txt }; static pdl_datatypes ${vname}_gentypes[] = { $gentypes_txt };
static char ${vname}_flags[] = { static char ${vname}_flags[] = {
$join_flags $join_flags
}; };
static PDL_Indx ${vname}_realdims[] = { $realdims }; static PDL_Indx ${vname}_realdims[] = { $realdims };
static char *${vname}_parnames[] = { $parnames }; static char *${vname}_parnames[] = { $parnames };
static short ${vname}_parflags[] = { static short ${vname}_parflags[] = {
$parflags $parflags
}; };
static pdl_datatypes ${vname}_partypes[] = { $partypes }; static pdl_datatypes ${vname}_partypes[] = { $partypes };
 End of changes. 136 change blocks. 
440 lines changed or deleted 463 lines changed or added
To the Perl Modules section of the PDL source changes report or the top of this page
Mainly generated by pkgdiff using rfcdiff
Home  |  About  |  Features  |  All  |  Newest  |  Dox  |  Diffs  |  RSS Feeds  |  Screenshots  |  Comments  |  Imprint  |  Privacy  |  HTTP(S)