# $PDL::PP::deftbl is an array-ref of
# PDL::PP::Rule->new("Name1", "Name2", $ref_to_sub)
# where Name1 represents the target of the rule, Name2 the condition,
# and the subroutine reference is the routine called when the rule is
# applied.
#
# If there is no condition, the argument can be left out of the call
# (unless there is a doc string), so
# PDL::PP::Rule->new("Name1", $ref_to_sub)
#
# The target and conditions can also be an array reference, so
# PDL::PP::Rule->new("Name1", ["Name2","Name3"], $ref_to_sub)
# PDL::PP::Rule->new(["Name1","Name2"], "Name3", $ref_to_sub)
# PDL::PP::Rule->new(["Name1","Name2"], ["Name3","Name4], $ref_to_sub)
#
# If a doc string exists then the condition must also
# be supplied, even if it is just [] (ie no condition).
#
# There are specialized rules for common situations. The rules for the
# target, condition, and doc arguments hold from the base class (ie
# whether scalar or array values are used, ...)
#
# Return a constant:
#
# PDL::PP::Rule::Returns->new($targets [,$conditions [,$doc]], $value)
# is used to return a constant. So
# PDL::PP::Rule::Returns->new("Name1", "foo")
#
# This class is specialized since there are some common return values:
# PDL::PP::Rule::Returns::Zero->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::NULL->new($targets [,$conditions [,$doc]])
# which return 0, 1, "", and "NULL" respectively
#
# The InsertName class exists to allow you to return something like
# "foo<routine name>bar"
# e.g.
# PDL::PP::Rule::InsertName->new("Foo", '_pdl_${name}_bar')
# PDL::PP::Rule::InsertName->new("Foo", "Arg2", '_pdl_${name}_bar')
# Note that the Name argument is automatically used as a condition, so
# it does not need to be supplied, and the return value should be
# given as a single-quoted string and use the $name variable
#
# The Substitute rule replaces dollar-signed macros ($P(), $ISBAD(), etc)
# with the low-level C code to perform the macro.
# PDL::PP::Rule::Substitute("NewXSCoerceMustSubs", "NewXSCoerceMustSub1")
# PDL::PP::Rule::Substitute->new($target,$condition)
# $target and $condition must be scalars.
# Implicit conditions are NewXSSymTab and Name
#
# PDL::PP::Rule::Substitute::Usual->new($target, $condition)
# $target and $condition must be scalars.
# Implicit conditions are NewXSSymTab and Name
#
# The MakeComp rule creates the compiled representation accessed by $COMP()
# PDL::PP::Rule::MakeComp->new("MakeCompiledRepr", ["MakeComp","CompObj"],
# "COMP")
# PDL::PP::Rule::MakeComp->new($target,$conditions,$symbol)
# $target and $symbol must be scalars.
# Notes:
# Substitute, Substitute::Usual, MakeComp classes feel a bit
# ugly. See next point. Also the get_std_childparent method is
# a bit of a hack.
package PDL::PP::Rule;
use strict;
use warnings;
use Carp;
use overload ("\"\"" => \&PDL::PP::Rule::stringify);
sub stringify {
my $self = shift;
my $str = ref $self;
if ("PDL::PP::Rule" eq $str) {
$str = "Rule";
} else {
$str =~ s/PDL::PP::Rule:://;
}
$str = "($str) ";
$str .= exists $self->{doc} ?
$self->{doc} : join(",", @{$self->{targets}});
return $str;
}
# Takes two args: the calling object and the message, but we only care
# about the message:
sub report ($$) { print $_[1] if $::PP_VERBOSE; }
# Very limited error checking.
# Allow scalars for targets and conditions to be optional
#
# At present you have to have a conditions argument if you supply
# a doc string
my $rule_usage = "Usage: PDL::PP::Rule->new(\$targets[,\$conditions[,\$doc],] [,\$ref])\n";
sub new {
die $rule_usage if @_ < 2 or @_ > 5;
my $class = shift;
my $self = bless {}, $class;
my $targets = shift;
$targets = [$targets] unless ref $targets eq "ARRAY";
$self->{targets} = $targets;
return $self if !@_;
$self->{ref} = pop if ref $_[-1] eq "CODE";
my $conditions = shift // [];
$conditions = [$conditions] unless ref $conditions eq "ARRAY";
$self->{conditions} = $conditions;
$self->{doc} = shift if defined $_[0];
$self;
}
# $rule->any_targets_exist($pars);
#
# Returns 1 if any of the targets exist in $pars, 0 otherwise.
# A return value of 1 means that the rule should not be applied.
sub any_targets_exist {
my $self = shift;
my $pars = shift;
my $targets = $self->{targets};
foreach my $target (@$targets) {
if (exists $pars->{$target}) {
$self->report("--skipping since TARGET $target exists\n");
return 1;
}
}
return 0;
}
# $rule->all_conditions_exist($pars);
#
# 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.
sub all_conditions_exist {
my $self = shift;
my $pars = shift;
return 1 unless my @nonexist = grep !ref() && !exists $pars->{$_}, @{$self->{conditions}};
$self->report("--skipping since CONDITIONs (@nonexist) do not exist\n");
0;
}
# $rule->should_apply($pars);
#
# Returns 1 if the rule should be applied (ie no targets already
# exist in $pars and all the required conditions exist in $pars),
# otherwise 0.
#
sub should_apply {
my $self = shift;
my $pars = shift;
return 0 if $self->any_targets_exist($pars);
return 0 unless $self->all_conditions_exist($pars);
return 1;
}
# my @args = $self->extract_args($pars);
sub extract_args {
my ($self, $pars) = @_;
@$pars{ map ref($_) eq "SCALAR" ? $$_ : $_, @{ $self->{conditions} } };
}
# Apply the rule using the supplied $pars hash reference.
#
sub apply {
my $self = shift;
my $pars = shift;
carp "Unable to apply rule $self as there is no subroutine reference!"
unless exists $self->{ref};
my $targets = $self->{targets};
my $conditions = $self->{conditions};
my $ref = $self->{ref};
$self->report("Applying: $self\n");
return unless $self->should_apply($pars);
# Create the argument array for the routine.
#
my @args = $self->extract_args($pars);
# Run this rule's subroutine:
my @retval = $ref->(@args);
# Check for any inconsistencies:
confess "Internal error: rule '$self' returned " . (1+$#retval)
. " items and expected " . (1+$#$targets)
unless $#retval == $#$targets;
$self->report("--setting:");
foreach my $target (@$targets) {
$self->report(" $target");
confess "Cannot have multiple meanings for target $target!"
if exists $pars->{$target};
my $result = shift @retval;
# The following test suggests that things could/should be
# improved in the code generation.
#
if (defined $result and $result eq 'DO NOT SET!!') {
$self->report (" is 'DO NOT SET!!'");
} else {
$pars->{$target} = $result;
}
}
$self->report("\n");
}
package PDL::PP::Rule::Croak;
# Croaks if all of the input variables are defined. Use this to identify
# incompatible arguments.
our @ISA = qw(PDL::PP::Rule);
use Carp;
sub new {
croak('Usage: PDL::PP::Rule::Croak->new(["incompatible", "arguments"], "Croaking message")')
unless @_ == 3;
shift->SUPER::new([], @_);
}
sub apply {
my ($self, $pars) = @_;
croak($self->{doc}) if $self->should_apply($pars);
}
package PDL::PP::Rule::Returns;
use strict;
use Carp;
our @ISA = qw (PDL::PP::Rule);
# This class does not treat return values of "DO NOT SET!!"
# as special.
#
sub new {
my $class = shift;
my $value = pop;
my $self = $class->SUPER::new(@_);
$self->{"returns.value"} = $value;
my $targets = $self->{targets};
croak "There can only be 1 target for a $self, not " . (1+$#$targets) . "!"
unless $#$targets == 0;
return $self;
}
sub apply {
my $self = shift;
my $pars = shift;
carp "Unable to apply rule $self as there is no return value!"
unless exists $self->{"returns.value"};
my $target = $self->{targets}->[0];
$self->report("Applying: $self\n");
return unless $self->should_apply($pars);
# Set the value
#
$self->report ("--setting: $target\n");
$pars->{$target} = $self->{"returns.value"};
}
package PDL::PP::Rule::Returns::Zero;
use strict;
our @ISA = qw (PDL::PP::Rule::Returns);
sub new {
shift->SUPER::new(@_,0);
}
package PDL::PP::Rule::Returns::One;
use strict;
our @ISA = qw (PDL::PP::Rule::Returns);
sub new {
shift->SUPER::new(@_,1);
}
package PDL::PP::Rule::Returns::EmptyString;
use strict;
our @ISA = qw (PDL::PP::Rule::Returns);
sub new {
shift->SUPER::new(@_,"");
}
package PDL::PP::Rule::Returns::NULL;
use strict;
our @ISA = qw (PDL::PP::Rule::Returns);
sub new {
shift->SUPER::new(@_,"NULL");
}
package PDL::PP::Rule::InsertName;
use strict;
use Carp;
our @ISA = qw (PDL::PP::Rule);
# This class does not treat return values of "DO NOT SET!!"
# as special.
#
sub new {
my $class = shift;
my $value = pop;
my @args = @_;
my $self = $class->SUPER::new(@args);
$self->{"insertname.value"} = $value;
# Generate a defaul doc string
unless (exists $self->{doc}) {
$self->{doc} = 'Sets ' . $self->{targets}->[0]
. ' to "' . $value . '"';
}
my $targets = $self->{targets};
croak "There can only be 1 target for a $self, not " . (1+$#$targets) . "!"
unless $#$targets == 0;
# we add "Name" as the first condition
#
my $conditions = $self->{conditions};
unshift @$conditions, "Name";
return $self;
}
sub apply {
my $self = shift;
my $pars = shift;
carp "Unable to apply rule $self as there is no return value!"
unless exists $self->{"insertname.value"};
$self->report("Applying: $self\n");
return unless $self->should_apply($pars);
# Set the value
#
my $target = $self->{targets}->[0];
my $name = $pars->{Name};
$self->report ("--setting: $target (name=$name)\n");
$pars->{$target} = eval "return \"" . $self->{"insertname.value"} . "\";";
}
# PDL::PP::Rule->new("NewXSCoerceMustSubs", ["NewXSCoerceMustSub1","NewXSSymTab","Name"],
# \&dosubst),
#
# PDL::PP::Rule::Substitute->new($target,$condition)
# $target and $condition must be scalars.
#
# Implicit conditions are NewXSSymTab and Name
#
package PDL::PP::Rule::Substitute;
use strict;
use Carp;
our @ISA = qw (PDL::PP::Rule);
sub badflag_isset {
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
#
sub dosubst_private {
my ($src,$sname,$pname,$name,$sig) = @_;
my $ret = (ref $src ? $src->[0] : $src);
my %syms = (
((ref $src) ? %{$src->[1]} : ()),
PRIV => sub {return "$sname->$_[0]"},
COMP => sub {return "$pname->$_[0]"},
CROAK => sub {PDL::PP::pp_line_numbers(__LINE__-1, "return PDL->make_error(PDL_EUSERERROR, \"Error in $name:\" $_[0])")},
NAME => sub {return $name},
MODULE => sub {return $::PDLMOD},
SETPDLSTATEBAD => sub { PDL::PP::pp_line_numbers(__LINE__-1, "$_[0]\->state |= PDL_BADVAL") },
SETPDLSTATEGOOD => sub { PDL::PP::pp_line_numbers(__LINE__-1, "$_[0]\->state &= ~PDL_BADVAL") },
ISPDLSTATEBAD => \&badflag_isset,
ISPDLSTATEGOOD => sub {"!".badflag_isset($_[0])},
BADFLAGCACHE => sub { PDL::PP::pp_line_numbers(__LINE__-1, "badflag_cache") },
PDLSTATESETBAD => sub { PDL::PP::pp_line_numbers(__LINE__-1, ($sig->objs->{$_[0]}//confess "Can't get PDLSTATESETBAD for unknown ndarray '$_[0]'")->do_pdlaccess."->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 get PDLSTATEISBAD for unknown ndarray '$_[0]'")->do_pdlaccess)},
PDLSTATEISGOOD => sub {"!".badflag_isset(($sig->objs->{$_[0]}//confess "Can't get PDLSTATEISGOOD for unknown ndarray '$_[0]'")->do_pdlaccess)},
PP => sub { ($sig->objs->{$_[0]}//confess "Can't get PP for unknown ndarray '$_[0]'")->do_physpointeraccess },
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 ndarray '$_[0]'")->do_pdlaccess },
SIZE => sub { ($sig->ind_obj($_[0])//confess "Can't get SIZE of unknown dim '$_[0]'")->get_size },
%PDL::PP::macros,
);
while (my ($before, $kw, $args, $other) = macro_extract($ret)) {
confess("$kw not defined in '$ret'!") if !$syms{$kw};
$ret = join '', $before, $syms{$kw}->($args), $other;
}
$ret;
}
sub macro_extract {
require Text::Balanced;
my ($text) = @_;
return unless $text =~ /\$(\w+)\s*(?=\()/;
my ($before, $kw, $other) = ($`, $1, $');
(my $bracketed, $other) = Text::Balanced::extract_bracketed($other, '(")');
$bracketed = substr $bracketed, 1, -1; # chop off brackets
$bracketed =~ s:^\s*(.*?)\s*$:$1:;
($before, $kw, $bracketed, $other);
}
sub new {
my $class = shift;
die "Usage: PDL::PP::Rule::Substitute->new(\$target,\$condition);"
unless $#_ == 1;
my $target = shift;
my $condition = shift;
die "\$target must be a scalar for PDL::PP::Rule::Substitute" if ref $target;
die "\$condition must be a scalar for PDL::PP::Rule::Substitute" if ref $condition;
$class->SUPER::new($target, [$condition, qw(StructName ParamStructName Name SignatureObj)],
\&dosubst_private);
}
# PDL::PP::Rule->new("CacheBadFlagInit", ["CacheBadFlagInitNS","NewXSSymTab","Name"],
# \&dousualsubsts),
#
# PDL::PP::Rule::Substitute::Usual->new($target, $condition)
# $target and $condition must be scalars.
#
# Implicit conditions are NewXSSymTab and Name
#
# Need to think about @std_childparent as it is also used by
# other bits of code. At the moment provide a class method
# to access the array but there has to be better ways of
# doing this.
#
package PDL::PP::Rule::Substitute::Usual;
use strict;
use Carp;
our @ISA = qw (PDL::PP::Rule::Substitute);
# This is a copy of the main one for now. Need a better solution.
#
my @std_childparent = (
CHILD => sub {PDL::PP::pp_line_numbers(__LINE__-1, '$PRIV(pdls[1]->'.(join ',',@_).")")},
PARENT => sub {PDL::PP::pp_line_numbers(__LINE__-1, '$PRIV(pdls[0]->'.(join ',',@_).")")},
CHILD_PTR => sub {PDL::PP::pp_line_numbers(__LINE__-1, '$PRIV(pdls[1])')},
PARENT_PTR => sub {PDL::PP::pp_line_numbers(__LINE__-1, '$PRIV(pdls[0])')},
);
sub get_std_childparent { return @std_childparent; }
# We modify the arguments from the conditions to include the
# extra information
#
# We simplify the base-class version since we assume that all
# conditions are required here.
#
sub extract_args {
my $self = shift;
my $pars = shift;
# The conditions are [<code>, NewXSSymTab, Name]
#
my $code = $pars->{$self->{conditions}[0]};
my $sname = $pars->{$self->{conditions}[1]};
my $name = $pars->{$self->{conditions}[2]};
return ([$code,{@std_childparent}],$sname,$name);
}
# PDL::PP::Rule::MakeComp->new($target,$conditions,$symbol)
# $target and $symbol must be scalars.
#
package PDL::PP::Rule::MakeComp;
use strict;
use Carp;
our @ISA = qw (PDL::PP::Rule);
# This is a copy of the main one for now. Need a better solution.
#
my @std_redodims = (
SETNDIMS => sub {PDL::PP::pp_line_numbers(__LINE__-1, "PDL_RETERROR(PDL_err, PDL->reallocdims(__it,$_[0]));")},
SETDIMS => sub {PDL::PP::pp_line_numbers(__LINE__-1, "PDL_RETERROR(PDL_err, PDL->setdims_careful(__it));")},
SETDELTABROADCASTIDS => sub {PDL::PP::pp_line_numbers(__LINE__, <<EOF)},
{int __ind; PDL_RETERROR(PDL_err, PDL->reallocbroadcastids(\$CHILD_PTR(), \$PARENT(nbroadcastids)));
for(__ind=0; __ind<\$PARENT(nbroadcastids); __ind++)
\$CHILD(broadcastids[__ind]) = \$PARENT(broadcastids[__ind]) + ($_[0]);
}
EOF
);
# Probably want this directly in the apply routine but leave as is for now
#
sub subst_makecomp_private {
my($which,$mc,$cobj) = @_;
my ($cn,$co) = !$cobj ? () : map $cobj->$_, qw(othernames otherobjs);
return [$mc,{
PDL::PP::Rule::Substitute::Usual::get_std_childparent(),
($cn ?
(('DO'.$which.'ALLOC') => sub {join('',
map $$co{$_}->get_malloc("\$$which($_)"),
grep $$co{$_}->need_malloc, @$cn)}) :
()
),
($which eq "PRIV" ?
@std_redodims : ()),
},
];
}
sub new {
my $class = shift;
die "Usage: PDL::PP::Rule::MakeComp->new(\$target,\$conditions,\$symbol);"
unless $#_ == 2;
my $target = shift;
my $condition = shift;
my $symbol = shift;
die "\$target must be a scalar for PDL::PP::Rule->MakeComp" if ref $target;
die "\$symbol must be a scalar for PDL::PP::Rule->MakeComp" if ref $symbol;
my $self = $class->SUPER::new($target, $condition,
\&subst_makecomp_private);
$self->{"makecomp.value"} = $symbol;
return $self;
}
# We modify the arguments from the conditions to include the
# extra information
#
# We simplify the base-class version since we assume that all
# conditions are required here.
#
sub extract_args {
my $self = shift;
my $pars = shift;
($self->{"makecomp.value"}, @$pars{@{$self->{conditions}}});
}
package PDL::PP;
use strict;
our $VERSION = "2.3";
$VERSION = eval $VERSION;
our $macros_xs = <<'EOF';
#define PDL_XS_PREAMBLE \
char *objname = "PDL"; /* XXX maybe that class should actually depend on the value set \
by pp_bless ? (CS) */ \
HV *bless_stash = 0; \
SV *parent = 0; \
int nreturn = 0; \
(void)nreturn;
#define PDL_XS_PACKAGEGET \
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("derived PDL subclass (SVt_PVHV) ") \
if (SvROK(ST(0)) && ((SvTYPE(SvRV(ST(0))) == SVt_PVMG) || (SvTYPE(SvRV(ST(0))) == SVt_PVHV))) { \
parent = ST(0); \
if (sv_isobject(parent)){ \
bless_stash = SvSTASH(SvRV(ST(0))); \
objname = HvNAME((bless_stash)); PDL_COMMENT("The package to bless output vars into is taken from the first input var") \
} \
}
#define PDL_XS_PERLINIT(name, to_push, method) \
if (strcmp(objname,"PDL") == 0) { PDL_COMMENT("shortcut if just PDL") \
name ## _SV = sv_newmortal(); \
name = PDL->pdlnew(); \
if (!name) PDL->pdl_barf("Error making null pdl"); \
PDL->SetSV_PDL(name ## _SV, name); \
if (bless_stash) name ## _SV = sv_bless(name ## _SV, bless_stash); \
} else { \
PUSHMARK(SP); \
XPUSHs(to_push); \
PUTBACK; \
perl_call_method(#method, G_SCALAR); \
SPAGAIN; \
name ## _SV = POPs; \
PUTBACK; \
name = PDL->SvPDLV(name ## _SV); \
}
#define PDL_XS_RETURN(clause1) \
if (nreturn) { \
if (nreturn > 0) EXTEND (SP, nreturn); \
clause1; \
XSRETURN(nreturn); \
} else { \
XSRETURN(0); \
}
#define PDL_XS_INPLACE(in, out) \
if (in->state & PDL_INPLACE && (out != in)) { \
in->state &= ~PDL_INPLACE; PDL_COMMENT("unset") \
out = in; \
PDL->SetSV_PDL(out ## _SV,out); \
}
#define PDL_XS_INPLACE_CHECK(in) \
if (in->state & PDL_INPLACE) barf("inplace input but output given");
EOF
our $header_c = pp_line_numbers(__LINE__, <<'EOF');
/*
* THIS FILE WAS GENERATED BY PDL::PP! Do not modify!
*/
#define PDL_COMMENT(comment)
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("multiline comments (i.e. /* comment */). However, because such ")
PDL_COMMENT("comments do not nest, it's not possible for PDL::PP users to ")
PDL_COMMENT("comment-out sections of code using multiline comments, as is ")
PDL_COMMENT("often the practice when debugging, for example. So, when you ")
PDL_COMMENT("see something like this: ")
PDL_COMMENT(" ")
PDL_COMMENT("Memory access")
PDL_COMMENT(" ")
PDL_COMMENT("just think of it as a C multiline comment like: ")
PDL_COMMENT(" ")
PDL_COMMENT(" /* Memory access */ ")
#define PDL_FREE_CODE(trans, destroy, comp_free_code, ntpriv_free_code) \
if (destroy) { \
comp_free_code \
} \
if ((trans)->dims_redone) { \
ntpriv_free_code \
}
#include "EXTERN.h"
#include "perl.h"
#include "XSUB.h"
#include "pdl.h"
#include "pdlcore.h"
#define PDL %s
extern Core* PDL; PDL_COMMENT("Structure hold core C functions")
static int __pdl_boundscheck = 0;
static SV* CoreSV; PDL_COMMENT("Gets pointer to perl var holding core structure")
#if ! %s
# define PP_INDTERM(max, at) at
#else
# define PP_INDTERM(max, at) (__pdl_boundscheck? PDL->safe_indterm(max,at, __FILE__, __LINE__) : at)
#endif
EOF
our $header_xs = pp_line_numbers(__LINE__, <<'EOF');
Core* PDL = NULL; PDL_COMMENT("Structure hold core C functions")
MODULE = %1$s PACKAGE = %1$s
PROTOTYPES: ENABLE
int
set_boundscheck(i)
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:
PDL_COMMENT("Get pointer to structure of core shared C routines")
PDL_COMMENT("make sure PDL::Core is loaded")
%4$s
%5$s
EOF
use Config;
use Exporter;
use Data::Dumper;
our @ISA = qw(Exporter);
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_core_importList pp_beginwrap pp_setversion
pp_addbegin pp_boundscheck pp_line_numbers
pp_deprecate_module pp_add_macros/;
$PP::boundscheck = 1;
$::PP_VERBOSE = 0;
our $done = 0; # pp_done has not been called yet
use Carp;
sub nopm { $::PDLPACK eq 'NONE' } # flag that we don't want to generate a PM
sub import {
my ($mod,$modname, $packname, $prefix, $callpack, $multi_c) = @_;
# Allow for users to not specify the packname
($packname, $prefix, $callpack) = ($modname, $packname, $prefix)
if ($packname =~ m|/|);
$::PDLMOD=$modname; $::PDLPACK=$packname; $::PDLPREF=$prefix;
$::CALLPACK = $callpack || $::PDLMOD;
$::PDLMULTI_C = $multi_c; # one pp-*.c per function
$::PDLOBJ = "PDL"; # define pp-funcs in this package
$::PDLXS="";
$::PDLBEGIN="";
$::PDLPMROUT="";
for ('Top','Bot','Middle') { $::PDLPM{$_}="" }
@::PDLPMISA=('PDL::Exporter', 'DynaLoader');
@::PDL_IFBEGINWRAP = ('','');
$::PDLVERSIONSET = '';
$::PDLMODVERSION = undef;
$::DOCUMENTED = 0;
$::PDLCOREIMPORT = ""; #import list from core, defaults to everything, i.e. use Core
# could be set to () for importing nothing from core. or qw/ barf / for
# importing barf only.
@_=("PDL::PP");
goto &Exporter::import;
}
sub list_functions {
my ($file) = @_;
my @funcs;
undef &PDL::PP::pp_def;
local *PDL::PP::pp_def = sub { push @funcs, (_pp_parsename($_[0]))[0]};
undef &PDL::PP::pp_done;
local *PDL::PP::pp_done = sub {};
$_ = '' for $::PDLMOD, $::CALLPACK, $::PDLOBJ; # stop warnings
require File::Spec::Functions;
do ''.File::Spec::Functions::rel2abs($file);
die $@ if $@;
@funcs;
}
our %macros;
sub pp_add_macros {
confess "Usage: pp_add_macros(name=>sub {},...)" if @_%2;
%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 {
@::PDL_IFBEGINWRAP = ('BEGIN {','}');
}
sub pp_setversion {
my ($ver) = @_;
$ver = qq{'$ver'} if $ver !~ /['"]/;
$::PDLMODVERSION = '$VERSION';
$::PDLVERSIONSET = "our \$VERSION = $ver;";
}
sub pp_addhdr {
my ($hdr) = @_;
$::PDLXSC .= $hdr;
$::PDLXSC_header .= $hdr if $::PDLMULTI_C;
}
sub pp_addpm {
my $pm = shift;
my $pos;
if (ref $pm) {
my $opt = $pm;
$pm = shift;
croak "unknown option" unless defined $opt->{At} &&
$opt->{At} =~ /^(Top|Bot|Middle)$/;
$pos = $opt->{At};
} else {
$pos = 'Middle';
}
my @c = caller;
$::PDLPM{$pos} .= _pp_line_number_file($c[1], $c[2]-1, "\n$pm")."\n\n";
}
sub pp_add_exported {
shift if !$_[0] or $_[0] eq __PACKAGE__;
$::PDLPMROUT .= join ' ', @_, '';
}
sub pp_addbegin {
my ($cmd) = @_;
if ($cmd =~ /^\s*BOOT\s*$/) {
pp_beginwrap;
} else {
$::PDLBEGIN .= $cmd."\n";
}
}
# Sub to call to export nothing (i.e. for building OO package/object)
sub pp_export_nothing {
$::PDLPMROUT = ' ';
}
sub pp_add_isa {
push @::PDLPMISA,@_;
}
sub pp_add_boot {
my ($boot) = @_;
$boot =~ s/^\s*\n//gm; # XS doesn't like BOOT having blank lines
$::PDLXSBOOT .= $boot;
}
sub pp_bless{
my($new_package)=@_;
$::PDLOBJ = $new_package;
}
# sub to call to set the import list from core on the 'Use Core' line in the .pm file.
# set to '()' to not import anything from Core, or 'qw/ barf /' to import barf.
sub pp_core_importList{
$::PDLCOREIMPORT = $_[0];
}
sub printxs {
shift;
$::PDLXS .= join'',@_;
}
sub pp_addxs {
PDL::PP->printxs("\nMODULE = $::PDLMOD PACKAGE = $::CALLPACK\n\n",
@_,
"\nMODULE = $::PDLMOD PACKAGE = $::PDLOBJ\n\n");
}
# inserts #line directives into source text. Use like this:
# ...
# FirstKey => ...,
# Code => pp_line_numbers(__LINE__, $x . $y . $c),
# OtherKey => ...
sub pp_line_numbers {
_pp_line_number_file((caller)[1], @_);
}
sub _pp_line_number_file {
my ($filename, $line, $string) = @_;
confess "pp_line_numbers called with undef" if !defined $string;
# The line needs to be incremented by one for the bookkeeping to work
$line++;
$filename =~ s/\\/\\\\/g; # Escape backslashes
my @to_return = "\nPDL_LINENO_START $line \"$filename\"\n";
# Look for broadcastloops and loops and add # line directives
foreach (split (/\n/, $string)) {
# Always add the current line.
push @to_return, "$_\n";
# If we need to add a # line directive, do so after incrementing
$line++;
if (/%\{/ or /%}/) {
push @to_return, "PDL_LINENO_END\n";
push @to_return, "PDL_LINENO_START $line \"$filename\"\n";
}
}
push @to_return, "PDL_LINENO_END\n";
return join('', @to_return);
}
sub _pp_linenumber_fill {
my ($file, $text) = @_;
my (@stack, @to_return) = [$file, 1];
foreach (split (/\n/, $text)) {
$_->[1]++ for @stack;
push(@to_return, $_), next if !/^(\s*)PDL_LINENO_(?:START (\S+) "(.*)"|(END))$/;
my ($ci, $new_line, $new_file, $is_end) = ($1, $2, $3, $4);
if ($is_end) {
pop @stack;
push @to_return, qq{$ci#line $stack[-1][1] "$stack[-1][0]"};
} else {
push @stack, [$new_file, $new_line-1];
push @to_return, qq{$ci#line @{[$stack[-1][1]+1]} "$stack[-1][0]"};
}
}
join '', map "$_\n", @to_return;
}
sub _file_same {
my ($from_text, $to_file) = @_;
require File::Map;
File::Map::map_file(my $to_map, $to_file, '<');
s/^[^\n]*#line[^\n]*?\n//gm for $from_text, (my $to_text = $to_map);
$from_text eq $to_text;
}
sub _write_file {
my ($file, $text) = @_;
$text = _pp_linenumber_fill($file, $text);
return if -f $file && _file_same($text, $file);
open my $fh, '>', $file or confess "open $file: $!";
binmode $fh; # to guarantee length will be same for same contents
print $fh $text;
}
sub printxsc {
(undef, my $file) = (shift, shift);
my $text = join '',@_;
if (defined $file) {
(my $mod_underscores = $::PDLMOD) =~ s#::#_#g;
$text = join '', sprintf($PDL::PP::header_c, $mod_underscores, $PP::boundscheck), $::PDLXSC_header//'', $text;
_write_file($file, $text);
} else {
$::PDLXSC .= $text;
}
}
sub pp_done {
return if $PDL::PP::done; # do only once!
$PDL::PP::done = 1;
print "DONE!\n" if $::PP_VERBOSE;
print "Inline running PDL::PP version $PDL::PP::VERSION...\n" if nopm();
require PDL::Core::Dev;
my $pdl_boot = PDL::Core::Dev::PDL_BOOT('PDL', $::PDLMOD);
(my $mod_underscores = $::PDLMOD) =~ s#::#_#g;
my $text = join '',
sprintf($PDL::PP::header_c, $mod_underscores, $PP::boundscheck),
$::PDLXSC//'',
$PDL::PP::macros_xs, sprintf($PDL::PP::header_xs,
$::PDLMOD, $::PDLOBJ, $::PDLXS,
$pdl_boot, $::PDLXSBOOT//'', $PP::boundscheck,
);
_write_file("$::PDLPREF.xs", $text);
return if nopm;
$::PDLPMISA = "'".join("','",@::PDLPMISA)."'";
$::PDLBEGIN = "BEGIN {\n$::PDLBEGIN\n}"
unless $::PDLBEGIN =~ /^\s*$/;
$::PDLMODVERSION //= '';
$::FUNCSPOD = $::DOCUMENTED ? "\n\n=head1 FUNCTIONS\n\n=cut\n\n" : '';
_write_file("$::PDLPREF.pm", join "\n\n", <<EOF, $::PDLBEGIN, $::PDLPM{Top}, $::FUNCSPOD, @::PDLPM{qw(Middle Bot)}, '# Exit with OK status', "1;\n");
#
# GENERATED WITH PDL::PP! Don't modify!
#
package $::PDLPACK;
our \@EXPORT_OK = qw($::PDLPMROUT);
our %EXPORT_TAGS = (Func=>\\\@EXPORT_OK);
use PDL::Core$::PDLCOREIMPORT;
use PDL::Exporter;
use DynaLoader;
$::PDL_IFBEGINWRAP[0]
$::PDLVERSIONSET
our \@ISA = ( $::PDLPMISA );
push \@PDL::Core::PP, __PACKAGE__;
bootstrap $::PDLMOD $::PDLMODVERSION;
$::PDL_IFBEGINWRAP[-1]
EOF
} # end pp_done
sub _pp_parsename {
my ($name) = @_;
# See if the 'name' is multiline, in which case we extract the
# name and add the FullDoc field
return ($name, undef) if $name !~ /\n/;
my $fulldoc = $name;
# See if the very first thing is a word. That is going to be the
# name of the function under consideration
if ($fulldoc =~ s/^(\w+)//) {
$name = $1;
} elsif ($fulldoc =~ /=head2 (\w+)/) {
$name = $1;
} else {
croak('Unable to extract name');
}
($name, $fulldoc);
}
sub pp_def {
require PDL::Core::Dev;
require PDL::Types;
require PDL::PP::PdlParObj;
require PDL::PP::Signature;
require PDL::PP::Dims;
require PDL::PP::CType;
require PDL::PP::PDLCode;
PDL::PP::load_deftable() if !$PDL::PP::deftbl;
my($name,%obj) = @_;
print "*** Entering pp_def for $name\n" if $::PP_VERBOSE;
($name, my $fulldoc) = _pp_parsename($name);
$obj{FullDoc} = $fulldoc if defined $fulldoc;
$obj{Name} = $name;
croak("ERROR: pp_def=$name given empty GenericTypes!\n")
if exists $obj{GenericTypes} and !@{ $obj{GenericTypes} || [] };
foreach my $rule (@$PDL::PP::deftbl) {
$rule->apply(\%obj);
}
print "Result of translate for $name:\n" . Dumper(\%obj) . "\n"
if exists $obj{Dump} and $obj{Dump} and $::PP_VERBOSE;
croak("ERROR: No FreeFunc for pp_def=$name!\n")
unless exists $obj{FreeFunc};
my $ctext = join("\n\n",grep $_, @obj{'StructDecl','RedoDimsFunc',
'ReadDataFunc','WriteBackDataFunc',
'FreeFunc',
'VTableDef','RunFunc',
}
);
if ($::PDLMULTI_C) {
PDL::PP->printxsc(undef, <<EOF);
extern pdl_transvtable $obj{VTableName};
$obj{RunFuncHdr};
EOF
PDL::PP->printxsc("pp-$obj{Name}.c", $ctext);
} else {
PDL::PP->printxsc(undef, $ctext);
}
PDL::PP->printxs($obj{NewXSCode});
pp_add_boot($obj{BootSetNewXS}) if $obj{BootSetNewXS};
PDL::PP->pp_add_exported($name);
PDL::PP::pp_addpm("\n".$obj{PdlDoc}."\n") if $obj{PdlDoc};
PDL::PP::pp_addpm($obj{PMCode}) if defined $obj{PMCode};
PDL::PP::pp_addpm($obj{PMFunc}."\n") if defined $obj{PMFunc};
print "*** Leaving pp_def for $name\n" if $::PP_VERBOSE;
}
# marks this module as deprecated. This handles the user warnings, and adds a
# notice into the documentation. Can take a {infavor => "newmodule"} option
sub pp_deprecate_module
{
my $options;
if( ref $_[0] eq 'HASH' ) { $options = shift; }
else { $options = { @_ }; }
my $infavor;
if( $options && ref $options eq 'HASH' && $options->{infavor} )
{
$infavor = $options->{infavor};
}
my $mod = $::PDLMOD;
my $envvar = 'PDL_SUPPRESS_DEPRECATION_WARNING__' . uc $mod;
$envvar =~ s/::/_/g;
my $warning_main =
"$mod is deprecated.";
$warning_main .=
" Please use $infavor instead." if $infavor;
my $warning_suppression_runtime =
"This module will be removed in the future; please update your code.\n" .
"Set the environment variable $envvar\n" .
"to suppress this warning\n";
my $warning_suppression_pod =
"A warning will be generated at runtime upon a C<use> of this module\n" .
"This warning can be suppressed by setting the $envvar\n" .
"environment variable\n";
my $deprecation_notice = <<EOF ;
XXX=head1 DEPRECATION NOTICE
$warning_main
$warning_suppression_pod
XXX=cut
EOF
$deprecation_notice =~ s/^XXX=/=/gms;
pp_addpm( {At => 'Top'}, $deprecation_notice );
pp_addpm {At => 'Top'}, <<EOF;
warn \"$warning_main\n$warning_suppression_runtime\" unless \$ENV{$envvar};
EOF
}
use Carp;
$SIG{__DIE__} = \&Carp::confess if $::PP_VERBOSE;
$|=1;
#
# This is ripped from xsubpp to ease the parsing of the typemap.
#
our $proto_re = "[" . quotemeta('\$%&*@;[]') . "]" ;
sub ValidProtoString ($)
{
my($string) = @_ ;
if ( $string =~ /^$proto_re+$/ ) {
return $string ;
}
return 0 ;
}
sub C_string ($)
{
my($string) = @_ ;
$string =~ s[\\][\\\\]g ;
$string ;
}
sub TrimWhitespace
{
$_[0] =~ s/^\s+|\s+$//go ;
}
sub TidyType
{
local ($_) = @_ ;
# rationalise any '*' by joining them into bunches and removing whitespace
s#\s*(\*+)\s*#$1#g;
s#(\*+)# $1 #g ;
# change multiple whitespace into a single space
s/\s+/ /g ;
# trim leading & trailing whitespace
TrimWhitespace($_) ;
$_ ;
}
#------------------------------------------------------------------------------
# Typemap handling in PP.
#
# This subroutine does limited input typemap conversion.
# Given a variable name (to set), its type, and the source
# for the variable, returns the correct input typemap entry.
# Original version: D. Hunt 4/13/00 - Current version J. Brinchmann (06/05/05)
#
# The code loads the typemap from the Perl typemap using the loading logic of
# xsubpp. Do note that I made the assumption that
# $Config{installprivlib}/ExtUtils was the right root directory for the search.
# This could break on some systems?
#
# Also I do _not_ parse the Typemap argument from ExtUtils::MakeMaker because I don't
# know how to catch it here! This would be good to fix! It does look for a file
# called typemap in the current directory however.
#
# The parsing of the typemap is mechanical and taken straight from xsubpp and
# the resulting hash lookup is then used to convert the input type to the
# necessary outputs (as seen in the old code above)
#
# JB 06/05/05
#
sub typemap {
my $oname = shift;
my $type = shift;
my $arg = shift;
# Modification to parse Perl's typemap here.
#
# The default search path for the typemap taken from xsubpp. It seems it is
# necessary to prepend the installprivlib/ExtUtils directory to find the typemap.
# It is not clear to me how this is to be done.
#
my ($typemap, $mode, $junk, $current, %input_expr,
%proto_letter, %output_expr, %type_kind);
# according to MM_Unix 'privlibexp' is the right directory
# seems to work even on OS X (where installprivlib breaks things)
my $_rootdir = $Config{privlibexp}.'/ExtUtils/';
# First the system typemaps..
my @tm = ($_rootdir.'../../../../lib/ExtUtils/typemap',
$_rootdir.'../../../lib/ExtUtils/typemap',
$_rootdir.'../../lib/ExtUtils/typemap',
$_rootdir.'../../../typemap',
$_rootdir.'../../typemap', $_rootdir.'../typemap',
$_rootdir.'typemap');
# Note that the OUTPUT typemap is unlikely to be of use here, but I have kept
# the source code from xsubpp for tidiness.
push @tm, &PDL::Core::Dev::PDL_TYPEMAP, '../../typemap', '../typemap', 'typemap';
carp "**CRITICAL** PP found no typemap in $_rootdir/typemap; this will cause problems..."
unless my @typemaps = grep -f $_ && -T _, @tm;
foreach $typemap (@typemaps) {
open(my $fh, $typemap)
or warn("Warning: could not open typemap file '$typemap': $!\n"), next;
$mode = 'Typemap';
$junk = "" ;
$current = \$junk;
local $_; # else get "Modification of a read-only value attempted"
while (<$fh>) {
next if /^\s*#/;
my $line_no = $. + 1;
if (/^INPUT\s*$/) { $mode = 'Input'; $current = \$junk; next; }
if (/^OUTPUT\s*$/) { $mode = 'Output'; $current = \$junk; next; }
if (/^TYPEMAP\s*$/) { $mode = 'Typemap'; $current = \$junk; next; }
if ($mode eq 'Typemap') {
chomp;
my $line = $_ ;
TrimWhitespace($_) ;
# skip blank lines and comment lines
next if /^$/ or /^#/ ;
my($t_type,$kind, $proto) = /^\s*(.*?\S)\s+(\S+)\s*($proto_re*)\s*$/ or
warn("Warning: File '$typemap' Line $. '$line' TYPEMAP entry needs 2 or 3 columns\n"), next;
$t_type = TidyType($t_type) ;
$type_kind{$t_type} = $kind ;
# prototype defaults to '$'
$proto = "\$" unless $proto ;
warn("Warning: File '$typemap' Line $. '$line' Invalid prototype '$proto'\n")
unless ValidProtoString($proto) ;
$proto_letter{$t_type} = C_string($proto) ;
}
elsif (/^\s/) {
$$current .= $_;
}
elsif ($mode eq 'Input') {
s/\s+$//;
$input_expr{$_} = '';
$current = \$input_expr{$_};
}
else {
s/\s+$//;
$output_expr{$_} = '';
$current = \$output_expr{$_};
}
}
close $fh;
}
#
# Do checks...
#
# First reconstruct the type declaration to look up in type_kind
my $full_type=TidyType($type->get_decl('', {VarArrays2Ptrs=>1})); # Skip the variable name
die "The type =$full_type= does not have a typemap entry!\n" unless exists($type_kind{$full_type});
my $typemap_kind = $type_kind{$full_type};
# Look up the conversion from the INPUT typemap. Note that we need to do some
# massaging of this.
my $input = $input_expr{$typemap_kind};
$input =~ s/^(.*?)=\s*//s; # Remove all before =
$input =~ s/\$(var|\{var\})/$oname/g;
$input =~ s/\$(arg|\{arg\})/$arg/g;
$input =~ s/\$(type|\{type\})/$full_type/g;
return ($input);
}
sub wrap_vfn {
my (
$code,$rout,$func_header,
$all_func_header,$sname,$pname,$ptype,$extra_args,
) = @_;
my $str = join "\n", grep $_, $all_func_header, $func_header, $code;
my $opening = 'pdl_error PDL_err = {0, NULL, 0};';
my $closing = 'return PDL_err;';
PDL::PP::pp_line_numbers(__LINE__, <<EOF);
pdl_error $rout(pdl_trans *$sname$extra_args) {
$opening
@{[$ptype ? " $ptype *$pname = $sname->params;" : ""]}
$str$closing}
EOF
}
my @vfn_args_always = (\"AllFuncHeader", qw(StructName ParamStructName ParamStructType));
sub make_vfn_args {
my ($which, $extra_args) = @_;
("${which}Func",
["${which}CodeSubd","${which}FuncName",\"${which}FuncHeader",
@vfn_args_always
],
sub {$_[1] eq 'NULL' ? '' : wrap_vfn(@_,$extra_args//'')}
);
}
sub make_xs_code {
my($xscode_before,$xscode_after,$str,
$xs_c_headers,
@bits) = @_;
my($boot,$prelude);
if($xs_c_headers) {
$prelude = join '' => ($xs_c_headers->[0], @bits, $xs_c_headers->[1]);
$boot = $xs_c_headers->[2];
$str .= "\n";
} else {
my $xscode = join '' => @bits;
$str .= " $xscode_before\n $xscode$xscode_after\n\n";
}
$str =~ s/(\s*\n)+/\n/g;
($str,$boot,$prelude)
}
sub indent($$) {
my ($text,$ind) = @_;
$text =~ s/^(.*)$/$ind$1/mg;
return $text;
}
# This subroutine generates the XS code needed to call the perl 'initialize'
# routine in order to create new output PDLs
sub callPerlInit {
my $names = shift; # names of variables to initialize
my $ci = shift; # current indenting
my $callcopy = $#_ > -1 ? shift : 0;
my $ret = '';
foreach my $name (@$names) {
my ($to_push, $method) = $callcopy
? ('parent', 'copy')
: ('sv_2mortal(newSVpv(objname, 0))', 'initialize');
$ret .= PDL::PP::pp_line_numbers(__LINE__-1, "PDL_XS_PERLINIT($name, $to_push, $method)\n");
}
indent($ret,$ci);
} #sub callPerlInit()
###########################################################
# Name : extract_signature_from_fulldoc
# Usage : $sig = extract_signature_from_fulldoc($fulldoc)
# Purpose : pull out the signature from the fulldoc string
# Returns : whatever is in parentheses in the signature, or undef
# Parameters : $fulldoc
# Throws : never
# Notes : the signature must have the following form:
# :
# : =for sig
# : <blank>
# : Signature: (<signature can
# : be multiline>)
# : <blank>
# :
# : The two spaces before "Signature" are required, as are
# : the parentheses.
sub extract_signature_from_fulldoc {
my $fulldoc = shift;
if ($fulldoc =~ /=for sig\n\n Signature: \(([^\n]*)\n/g) {
# Extract the signature and remove the final parenthesis
my $sig = $1;
$sig .= $1 while $fulldoc =~ /\G\h+([^\n]*)\n/g;
$sig =~ s/\)\s*$//;
return $sig;
}
return;
}
# function to be run by real pp_def so fake pp_def can do without other modules
sub load_deftable {
# Build the valid-types regex and valid Pars argument only once. These are
# also used in PDL::PP::PdlParObj, which is why they are globally available.
my $pars_re = $PDL::PP::PdlParObj::pars_re;
# Set up the rules for translating the pp_def contents.
#
$PDL::PP::deftbl =
[
PDL::PP::Rule->new(
[qw(RedoDims EquivCPOffsCode HandleBad P2Child TwoWay)],
["Identity"],
"something to do with dataflow between CHILD & PARENT, I think.",
sub {
(PDL::PP::pp_line_numbers(__LINE__-1, '
int i;
$SETNDIMS($PARENT(ndims));
for(i=0; i<$CHILD(ndims); i++) {
$CHILD(dims[i]) = $PARENT(dims[i]);
}
$SETDIMS();
$SETDELTABROADCASTIDS(0);
$PRIV(dims_redone) = 1;
'),
# NOTE: we use the same bit of code for all-good and bad data -
# see the Code rule
# we can NOT assume that PARENT and CHILD have the same type,
# hence the version for bad code
#
# NOTE: we use the same code for 'good' and 'bad' cases - it's
# just that when we use it for 'bad' data, we have to change the
# definition of the EQUIVCPOFFS macro - see the Code rule
PDL::PP::pp_line_numbers(__LINE__,
'PDL_Indx i;
for(i=0; i<$PDL(CHILD)->nvals; i++) {
$EQUIVCPOFFS(i,i);
}'),
1, 1, 1);
}),
# used as a flag for many of the routines
# ie should we bother with bad values for this routine?
# 1 - yes,
# 0 - no, maybe issue a warning
PDL::PP::Rule->new("BadFlag", \"HandleBad",
"Sets BadFlag based upon HandleBad key",
sub { $_[0] }),
####################
# FullDoc Handling #
####################
# Error processing: does FullDoc contain BadDoc, yet BadDoc specified?
PDL::PP::Rule::Croak->new(['FullDoc', 'BadDoc'],
'Cannot have both FullDoc and BadDoc defined'),
PDL::PP::Rule::Croak->new(['FullDoc', 'Doc'],
'Cannot have both FullDoc and Doc defined'),
# Note: no error processing on Pars; it's OK for the docs to gloss over
# the details.
# Add the Pars section based on the signature of the FullDoc if the Pars
# section doesn't already exist
PDL::PP::Rule->new('Pars', 'FullDoc',
'Sets the Pars from the FullDoc if Pars is not explicitly specified',
# Purpose : extract the Pars from the signature from the fulldoc string,
# : the part of the signature that specifies the ndarrays
# Returns : a string appropriate for the Pars key
# Parameters : $fulldoc
# Throws : if there is no signature
# : if there is no extractable Pars section
# : if some PDL arguments come after the OtherPars arguments start
# Notes : This is meant to be used directly in a Rule. Therefore, it
# : is only called if the Pars key does not yet exist, so if it
# : is not possible to extract the Pars section, it dies.
sub {
my $fulldoc = shift;
# Get the signature or die
my $sig = extract_signature_from_fulldoc($fulldoc)
or confess('No Pars specified and none could be extracted from FullDoc');
# Everything is semicolon-delimited
my @args = split /\s*;\s*/, $sig;
my @pars;
my $switched_to_other_pars = 0;
for my $arg (@args) {
confess('All PDL args must come before other pars in FullDoc signature')
if $switched_to_other_pars and $arg =~ $pars_re;
if ($arg =~ $pars_re) {
push @pars, $arg;
} else {
$switched_to_other_pars = 1;
}
}
# Make sure there's something there
confess('FullDoc signature contains no PDL arguments') if @pars == 0;
# All done!
return join('; ', @pars);
}
),
PDL::PP::Rule->new('OtherPars', 'FullDoc',
'Sets the OtherPars from the FullDoc if OtherPars is not explicitly specified',
# Purpose : extract the OtherPars from the signature from the fulldoc
# : string, the part of the signature that specifies non-ndarray
# : arguments
# Returns : a string appropriate for the OtherPars key
# Parameters : $fulldoc
# Throws : if some OtherPars arguments come before the last PDL argument
# Notes : This is meant to be used directly in a Rule. Therefore, it
# : is only called if the OtherPars key does not yet exist.
sub {
my $fulldoc = shift;
# Get the signature or do not set
my $sig = extract_signature_from_fulldoc($fulldoc)
or return 'DO NOT SET!!';
# Everything is semicolon-delimited
my @args = split /\s*;\s*/, $sig;
my @otherpars;
for my $arg (@args) {
confess('All PDL args must come before other pars in FullDoc signature')
if @otherpars > 0 and $arg =~ $pars_re;
if ($arg !~ $pars_re) {
push @otherpars, $arg;
}
}
# All done!
return 'DO NOT SET!!'if @otherpars == 0;
return join('; ', @otherpars);
}
),
################################
# Other Documentation Handling #
################################
# no docs by default
PDL::PP::Rule::Returns->new("Doc", [], 'Sets the default doc string',
"\n=for ref\n\ninfo not available\n"),
# try and automate the docs
# could be really clever and include the sig to see about
# input/output params, for instance
PDL::PP::Rule->new("BadDoc", ["BadFlag","Name",\"CopyBadStatusCode"],
'Sets the default documentation for handling of bad values',
sub {
my ( $bf, $name, $code ) = @_;
my $str;
if ( not defined($bf) ) {
$str = "$name does not process bad values.\n";
} elsif ( $bf ) {
$str = "$name processes bad values.\n";
} else {
$str = "$name ignores the bad-value flag of the input ndarrays.\n";
}
if ( not defined($code) ) {
$str .= "It will set the bad-value flag of all output ndarrays if " .
"the flag is set for any of the input ndarrays.\n";
} elsif ( $code eq '' ) {
$str .= "The output ndarrays will NOT have their bad-value flag set.\n";
} else {
$str .= "The state of the bad-value flag of the output ndarrays is unknown.\n";
}
}
),
# Default: no otherpars
PDL::PP::Rule::Returns::EmptyString->new("OtherPars"),
# the docs
PDL::PP::Rule->new("PdlDoc", "FullDoc", sub {
my $fulldoc = shift;
# Append a final cut if it doesn't exist due to heredoc shinanigans
$fulldoc .= "\n\n=cut\n" unless $fulldoc =~ /\n=cut\n*$/;
# Make sure the =head1 FUNCTIONS section gets added
$::DOCUMENTED++;
return $fulldoc;
}
),
PDL::PP::Rule->new("PdlDoc", ["Name",\"Pars","OtherPars","Doc",\"BadDoc"],
sub {
my ($name,$pars,$otherpars,$doc,$baddoc) = @_;
return '' if !defined $doc # Allow explicit non-doc using Doc=>undef
or $doc =~ /^\s*internal\s*$/i;
# If the doc string is one line let's have two for the
# reference card information as well
$doc = "=for ref\n\n".$doc if $doc !~ /\n/;
$::DOCUMENTED++;
$pars = "P(); C()" unless $pars;
# Strip leading whitespace and trailing semicolons and whitespace
$pars =~ s/^\s*(.+[^;])[;\s]*$/$1/;
$otherpars =~ s/^\s*(.+[^;])[;\s]*$/$1/ if $otherpars;
my $sig = "$pars".( $otherpars ? "; $otherpars" : "");
$doc =~ s/\n(=cut\s*\n)+(\s*\n)*$/\n/m; # Strip extra =cut's
if ( defined $baddoc ) {
# Strip leading newlines and any =cut markings
$baddoc =~ s/\n(=cut\s*\n)+(\s*\n)*$/\n/m;
$baddoc =~ s/^\n+//;
$baddoc = "=for bad\n\n$baddoc";
}
my $baddoc_function_pod = <<"EOD" ;
XXX=head2 $name
XXX=for sig
Signature: ($sig)
$doc
$baddoc
XXX=cut
EOD
$baddoc_function_pod =~ s/^XXX=/=/gms;
return $baddoc_function_pod;
}
),
##################
# Done with Docs #
##################
# Notes
# Suffix 'NS' means, "Needs Substitution". In other words, the string
# associated with a key that has the suffix "NS" must be run through a
# Substitute or Substitute::Usual
# The substituted version should then replace "NS" with "Subd"
# So: FreeCodeNS -> FreeCodeSubd
PDL::PP::Rule::Returns->new("StructName", "__privtrans"),
PDL::PP::Rule::Returns->new("ParamStructName", "__params"),
PDL::PP::Rule->new("HaveBroadcasting","HaveThreading", sub {@_}), # compat
PDL::PP::Rule::Croak->new([qw(P2Child GenericTypes)],
'Cannot have both P2Child and GenericTypes defined'),
PDL::PP::Rule->new([qw(Pars HaveBroadcasting CallCopy GenericTypes DefaultFlow AllFuncHeader RedoDimsFuncHeader)],
["P2Child","Name","StructName"],
sub {
my (undef,$name,$sname) = @_;
("PARENT(); [oca]CHILD();",0,0,[PDL::Types::ppdefs_all()],1,
pp_line_numbers(__LINE__-1,"\tpdl *__it = $sname->pdls[1];\n\tpdl *__parent = $sname->pdls[0];\n"),
pp_line_numbers(__LINE__-1,"PDL->hdr_childcopy($sname);\n$sname->dims_redone = 1;\n"),
);
}),
# Question: where is ppdefs defined?
# Answer: Core/Types.pm
#
PDL::PP::Rule->new("GenericTypes", [],
'Sets GenericTypes flag to all real types known to PDL::Types',
sub {[PDL::Types::ppdefs()]}),
PDL::PP::Rule->new("ExtraGenericSwitches", "FTypes",
'Makes ExtraGenericSwitches identical to FTypes if the latter exists and the former does not',
sub {return $_[0]}),
PDL::PP::Rule::Returns->new("ExtraGenericSwitches", [],
'Sets ExtraGenericSwitches to an empty hash if it does not already exist', {}),
PDL::PP::Rule::InsertName->new("VTableName", 'pdl_${name}_vtable'),
PDL::PP::Rule::Returns->new("Priv", "AffinePriv", 'PDL_Indx incs[$CHILD(ndims)];PDL_Indx offs; '),
PDL::PP::Rule::Returns->new("IsAffineFlag", "AffinePriv", "PDL_ITRANS_ISAFFINE"),
PDL::PP::Rule::Returns::Zero->new("IsAffineFlag"),
PDL::PP::Rule::Returns->new("TwoWayFlag", "TwoWay", "PDL_ITRANS_TWOWAY"),
PDL::PP::Rule::Returns::Zero->new("TwoWayFlag"),
PDL::PP::Rule::Returns->new("DefaultFlowFlag", "DefaultFlow", "PDL_ITRANS_DO_DATAFLOW_ANY"),
PDL::PP::Rule::Returns::Zero->new("DefaultFlowFlag"),
PDL::PP::Rule->new("RedoDims", ["EquivPDimExpr",\"EquivDimCheck"],
sub {
my($pdimexpr,$dimcheck) = @_;
$pdimexpr =~ s/\$CDIM\b/i/g;
PDL::PP::pp_line_numbers(__LINE__-1, '
int i,cor;
'.$dimcheck.'
$SETNDIMS($PARENT(ndims));
$DOPRIVALLOC();
$PRIV(offs) = 0;
for(i=0; i<$CHILD(ndims); i++) {
cor = '.$pdimexpr.';
$CHILD(dims[i]) = $PARENT(dims[cor]);
$PRIV(incs[i]) = $PARENT(dimincs[cor]);
}
$SETDIMS();
$SETDELTABROADCASTIDS(0);
$PRIV(dims_redone) = 1;
');
}),
PDL::PP::Rule->new("Code", ["EquivCPOffsCode","BadFlag"],
"create Code from EquivCPOffsCode",
# NOTE: EQUIVCPOFFS and EQUIVCPTRUNC both suffer from the macro-block
# wart of C preprocessing. They look like statements but sometimes
# process into blocks, so if/then/else constructs can get broken.
# Either (1) use blocks for if/then/else, or (2) get excited and
# use the "do {BLOCK} while(0)" block-to-statement conversion construct
# in the substitution. I'm too Lazy. --CED 27-Jan-2003
sub {
my $good = shift;
my $bflag = shift;
my $bad = $good;
# parse 'good' code
$good =~ s/\$EQUIVCPOFFS\(([^()]+),([^()]+)\)/\$PP(CHILD)[$1] = \$PP(PARENT)[$2]/g;
$good =~ s/\$EQUIVCPTRUNC\(([^()]+),([^()]+),([^()]+)\)/\$PP(CHILD)[$1] = ($3) ? 0 : \$PP(PARENT)[$2]/g;
return $good if !$bflag;
# parse 'bad' code
$bad =~ s/\$EQUIVCPOFFS\(([^()]+),([^()]+)\)/if( \$PPISBAD(PARENT,[$2]) ) { \$PPSETBAD(CHILD,[$1]); } else { \$PP(CHILD)[$1] = \$PP(PARENT)[$2]; }/g;
$bad =~ s/\$EQUIVCPTRUNC\(([^()]+),([^()]+),([^()]+)\)/ if( ($3) || \$PPISBAD(PARENT,[$2]) ) { \$PPSETBAD(CHILD,[$1]); } else {\$PP(CHILD)[$1] = \$PP(PARENT)[$2]; }/g;
PDL::PP::pp_line_numbers(__LINE__-1, 'if ( $PRIV(bvalflag) ) { ' . $bad . ' } else { ' . $good . '}');
}),
PDL::PP::Rule->new("BackCode", ["EquivCPOffsCode","BadFlag"],
"create BackCode from EquivCPOffsCode",
# If there is an EquivCPOffsCode and:
# no bad-value support ==> use that
# bad value support ==> write a bit of code that does
# if ( $PRIV(bvalflag) ) { bad-EquivCPOffsCode }
# else { good-EquivCPOffsCode }
#
# Note: since EquivCPOffsCode doesn't (or I haven't seen any that
# do) use 'loop %{' or 'broadcastloop %{', we can't rely on
# PDLCode to automatically write code like above, hence the
# explicit definition here.
#
# Note: I *assume* that bad-Equiv..Code == good-Equiv..Code *EXCEPT*
# that we re-define the meaning of the $EQUIVCPOFFS macro to
# check for bad values when copying things over.
# This means having to write less code.
#
# Since PARENT & CHILD need NOT be the same type we cannot just copy
# values from one to the other - we have to check for the presence
# of bad values, hence the expansion for the $bad code
#
# Some operators (notably range) also have an out-of-range flag; they use
# the macro EQUIVCPTRUNC instead of EQUIVCPOFFS.
# $EQUIVCPTRUNC does the same as EQUIVCPOFFS but accepts a
# child-out-of-bounds flag. If the out-of-bounds flag is set, the
# forward code puts BAD/0 into the child, and reverse code refrains
# from copying.
# --CED 27-Jan-2003
#
# this just reverses PARENT & CHILD in the expansion of
# the $EQUIVCPOFFS macro (ie compared to Code from EquivCPOffsCode)
sub {
my ($good, $bflag) = @_;
my $bad = $good;
# parse 'good' code
$good =~ s/\$EQUIVCPOFFS\(([^()]+),([^()]+)\)/\$PP(PARENT)[$2] = \$PP(CHILD)[$1]/g;
$good =~ s/\$EQUIVCPTRUNC\(([^()]+),([^()]+),([^()]+)\)/if(!($3)) \$PP(PARENT)[$2] = \$PP(CHILD)[$1] /g;
return $good if !$bflag;
# parse 'bad' code
$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;
PDL::PP::pp_line_numbers(__LINE__-1, 'if ( $PRIV(bvalflag) ) { ' . $bad . ' } else { ' . $good . '}');
}),
PDL::PP::Rule::Returns::Zero->new("Affine_Ok", "EquivCPOffsCode"),
PDL::PP::Rule::Returns::One->new("Affine_Ok"),
PDL::PP::Rule::Returns::NULL->new("ReadDataFuncName", "AffinePriv"),
PDL::PP::Rule::Returns::NULL->new("WriteBackDataFuncName", "AffinePriv"),
PDL::PP::Rule::InsertName->new("NewXSName", '_${name}_int'),
PDL::PP::Rule::Returns::One->new("HaveBroadcasting"),
# Parameters in the 'a(x,y); [o]b(y)' format, with
# fixed nos of real, unbroadcast-over dims.
# Also "Other pars", the parameters which are usually not pdls.
PDL::PP::Rule->new("SignatureObj", ["Pars","BadFlag","OtherPars"],
sub { PDL::PP::Signature->new(@_) }),
# Set CallCopy flag for simple functions (2-arg with 0-dim signatures)
# This will copy the $object->copy method, instead of initialize
# for PDL-subclassed objects
#
PDL::PP::Rule->new("CallCopy", ["SignatureObj", "Name"],
sub {
my ($sig, $Name, $hasp2c) = @_;
my $noDimmedArgs = $sig->dims_count;
my $noArgs = @{$sig->names};
# Check for 2-arg function with 0-dim signatures
return 0 if !($noDimmedArgs == 0 and $noArgs == 2);
# Check to see if output arg is _not_ explicitly typed:
!$sig->objs->{$sig->names->[1]}{FlagTyped};
}),
PDL::PP::Rule->new(["InplaceCode","InplaceCheck"], ["SignatureObj","Inplace"],
'Insert code (just after HdrCode) to ensure the routine can 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
# => 1
# assumes fn has an input and output ndarray (eg 'a(); [o] b();')
# => [ 'a' ]
# assumes several input ndarrays in sig, so 'a' labels which
# one is to be marked inplace
# => [ 'a', 'b' ]
# input ndarray is a(), output ndarray is 'b'
sub {
my ( $sig, $arg ) = @_;
return '' if !$arg;
confess "Inplace array-ref (@$arg) > 2 elements" if ref($arg) eq "ARRAY" and @$arg > 2;
# find input and output ndarrays
my @out = $sig->names_out;
my @in = $sig->names_in;
my $in = @in == 1 ? $in[0] : undef;
my $out = @out == 1 ? $out[0] : undef;
if ( ref($arg) eq "ARRAY" and @$arg) {
$in = $$arg[0];
$out = $$arg[1] if @$arg > 1;
}
confess "ERROR: Inplace does not know name of input ndarray\n"
unless defined $in;
confess "ERROR: Inplace does not know name of output ndarray\n"
unless defined $out;
(
PDL::PP::pp_line_numbers(__LINE__-1, "PDL_XS_INPLACE($in, $out)\n"),
PDL::PP::pp_line_numbers(__LINE__-1, "PDL_XS_INPLACE_CHECK($in)\n"),
);
}),
PDL::PP::Rule::Returns::EmptyString->new("InplaceCode", []),
PDL::PP::Rule::Returns::EmptyString->new("InplaceCheck", []),
PDL::PP::Rule::Returns::EmptyString->new("HdrCode", [],
'Code that will be inserted at the end of the autogenerated xs argument processing code VargArgsXSHdr'),
PDL::PP::Rule->new("VarArgsXSHdr",
["Name","SignatureObj",
"HdrCode","InplaceCode","InplaceCheck",\"CallCopy",\"OtherParsDefaults"],
'XS code to process input arguments based on supplied Pars argument to pp_def; not done if GlobalNew or PMCode supplied',
sub {
my($name,$sig,
$hdrcode,$inplacecode,$inplacecheck,$callcopy,$defaults) = @_;
my $optypes = $sig->otherobjs(1);
my @args = $sig->alldecls(0, 1);
my %other = map +($_ => exists($$optypes{$_})), @args;
if (keys %{ $defaults ||= {} } < keys %other) {
my $default_seen = '';
for (@args) {
$default_seen = $_ if exists $defaults->{$_};
confess "got default-less arg '$_' after default-ful arg '$default_seen'"
if $default_seen and !exists $defaults->{$_};
}
}
my $ci = ' '; # current indenting
my $pars = join "\n",map "$ci$_ = 0;", $sig->alldecls(1, 0);
my %out = map +($_=>1), $sig->names_out_nca;
my %outca = map +($_=>1), $sig->names_oca;
my %tmp = map +($_=>1), $sig->names_tmp;
# remember, otherpars *are* input vars
my $nout = grep $_, values %out;
my $noutca = grep $_, values %outca;
my $nother = grep $_, values %other;
my $ntmp = grep $_, values %tmp;
my $ntot = @args;
my $nmaxonstack = $ntot - $noutca;
my $nin = $ntot - ($nout + $noutca);
my $ninout = $nin + $nout;
my $nallout = $nout + $noutca;
my $ndefault = keys %$defaults;
my $usageargs = join ",", map exists $defaults->{$_} ? "$_=$defaults->{$_}" : $_, grep !$tmp{$_}, @args;
# Generate declarations for SV * variables corresponding to pdl * output variables.
# These are used in creating output variables. One variable (ex: SV * outvar1_SV;)
# is needed for each output and output create always argument
my $svdecls = join "\n", map "${ci}SV *${_}_SV = NULL;", $sig->names_out;
my $clause_inputs = ''; my %already_read; my $cnt = 0;
foreach my $x (@args) {
last if $out{$x} || $outca{$x} || $other{$x};
$already_read{$x} = 1;
$clause_inputs .= "$ci$x = PDL->SvPDLV(ST($cnt));\n";
$cnt++;
}
my @create = (); # The names of variables which need to be created by calling
# the 'initialize' perl routine from the correct package.
$ci = ' '; # Current indenting
# clause for reading in all variables
my $clause1 = $inplacecheck; $cnt = 0;
foreach my $x (@args) {
if ($other{$x}) { # other par
$clause1 .= "$ci$x = " . typemap($x, $$optypes{$x}, "ST($cnt)") . ";\n";
$cnt++;
} elsif ($outca{$x}) {
push (@create, $x);
} else {
$clause1 .= "$ci$x = PDL->SvPDLV(".
($out{$x} ? "${x}_SV = " : '').
"ST($cnt));\n" if !$already_read{$x};
$cnt++;
}
}
# Add code for creating output variables via call to 'initialize' perl routine
$clause1 .= callPerlInit (\@create, $ci, $callcopy);
@create = ();
# clause for reading in input and creating output vars
my $clause3 = '';
my $defaults_rawcond = $ndefault ? "items == ($nin-$ndefault)" : '';
$cnt = 0;
foreach my $x (@args) {
if ($other{$x}) {
my $setter = typemap($x, $$optypes{$x}, "ST($cnt)");
$clause3 .= "$ci$x = " . (exists $defaults->{$x}
? "($defaults_rawcond) ? ($defaults->{$x}) : ($setter)"
: $setter) . ";\n";
$cnt++;
} elsif ($out{$x} || $outca{$x}) {
push (@create, $x);
} else {
$clause3 .= "$ci$x = PDL->SvPDLV(ST($cnt));\n" if !$already_read{$x};
$cnt++;
}
}
# Add code for creating output variables via call to 'initialize' perl routine
$clause3 .= callPerlInit (\@create, $ci, $callcopy); @create = ();
my $defaults_cond = $ndefault ? " || $defaults_rawcond" : '';
$clause3 = <<EOF . $clause3;
else if (items == $nin$defaults_cond) { PDL_COMMENT("only input variables on stack, create outputs")
nreturn = $nallout;
EOF
$clause3 = '' if $nmaxonstack == $nin;
my $clause3_coda = $clause3 ? ' }' : '';
PDL::PP::pp_line_numbers(__LINE__, <<END);
void
$name(...)
PREINIT:
PDL_XS_PREAMBLE
$svdecls
$pars
PPCODE:
if (items != $nmaxonstack && !(items == $nin$defaults_cond) && items != $ninout)
croak (\"Usage: PDL::$name($usageargs) (you may leave output variables out of list)\");
PDL_XS_PACKAGEGET
$clause_inputs
if (items == $nmaxonstack) { PDL_COMMENT("all variables on stack, read in output vars")
nreturn = $noutca;
$clause1
}
$clause3$clause3_coda
$hdrcode
$inplacecode
END
}),
# globalnew implies internal usage, not XS
PDL::PP::Rule::Returns->new("VarArgsXSReturn","GlobalNew",undef),
PDL::PP::Rule->new("VarArgsXSReturn",
["SignatureObj"],
"Generate XS trailer to return output variables or leave them as modified input variables",
sub {
my @outs = $_[0]->names_out; # names of output variables (in calling order)
my $clause1 = join ';', map "ST($_) = $outs[$_]_SV", 0 .. $#outs;
PDL::PP::pp_line_numbers(__LINE__-1, "PDL_XS_RETURN($clause1)");
}),
PDL::PP::Rule->new("NewXSHdr", ["NewXSName","SignatureObj"],
sub {
my($name,$sig) = @_;
my $shortpars = join ',', $sig->alldecls(0, 1);
my $longpars = join "\n", map "\t$_", $sig->alldecls(1, 1);
return<<END;
void
$name($shortpars)
$longpars
END
}),
PDL::PP::Rule::InsertName->new("RunFuncName", 'pdl_${name}_run'),
PDL::PP::Rule->new("NewXSCHdrs", ["RunFuncName","SignatureObj","GlobalNew"],
sub {
my($name,$sig,$gname) = @_;
my $longpars = join ",", $sig->alldecls(1, 0);
my $opening = 'pdl_error PDL_err = {0, NULL, 0};';
my $closing = 'return PDL_err;';
return ["pdl_error $name($longpars) {$opening","$closing}",
"PDL->$gname = $name;"];
}),
PDL::PP::Rule->new(["RunFuncCall","RunFuncHdr"],["RunFuncName","SignatureObj"], sub {
my ($func_name,$sig) = @_;
my $shortpars = join ',', $sig->alldecls(0, 0);
my $longpars = join ",", $sig->alldecls(1, 0);
(PDL::PP::pp_line_numbers(__LINE__-1, "PDL->barf_if_error($func_name($shortpars));"),
"pdl_error $func_name($longpars)");
}),
PDL::PP::Rule->new("NewXSMakeNow", ["SignatureObj"],
sub { join '', map PDL::PP::pp_line_numbers(__LINE__-1, "$_ = PDL->make_now($_);\n"), @{ $_[0]->names } }),
PDL::PP::Rule->new("IgnoreTypesOf", ["FTypes","SignatureObj"], sub {
my ($ftypes, $sig) = @_;
my ($pnames, $pobjs) = ($sig->names_sorted, $sig->objs);
$_->{FlagIgnore} = 1 for grep $ftypes->{$_->{Name}}, @$pobjs{@$pnames};
+{map +($_,1), keys %$ftypes};
}),
PDL::PP::Rule::Returns->new("IgnoreTypesOf", {}),
PDL::PP::Rule->new("NewXSCoerceMustNS", "FTypes",
sub {
my($ftypes) = @_;
join '', map
PDL::PP::pp_line_numbers(__LINE__, "$_->datatype = $ftypes->{$_};"),
sort keys %$ftypes;
}),
PDL::PP::Rule::Substitute::Usual->new("NewXSCoerceMustSubd", "NewXSCoerceMustNS"),
PDL::PP::Rule->new("NewXSTypeCoerceNS", ["StructName"],
sub {
PDL::PP::pp_line_numbers(__LINE__, <<EOF);
PDL_RETERROR(PDL_err, PDL->type_coerce($_[0]));
EOF
}),
PDL::PP::Rule::Substitute::Usual->new("NewXSTypeCoerceSubd", "NewXSTypeCoerceNS"),
PDL::PP::Rule->new("NewXSSetTransPDLs", ["SignatureObj","StructName"], sub {
my($sig,$trans) = @_;
join '',
map PDL::PP::pp_line_numbers(__LINE__, "$trans->pdls[$_->[0]] = $_->[2];\n"),
grep !$_->[1], $sig->names_sorted_tuples;
}),
PDL::PP::Rule->new("NewXSExtractTransPDLs", ["SignatureObj","StructName"], sub {
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 {
my($trans) = @_;
PDL::PP::pp_line_numbers(__LINE__,
"PDL_RETERROR(PDL_err, PDL->make_trans_mutual($trans));\n");
}),
PDL::PP::Rule->new(PDL::PP::Code::make_args("Code"),
sub { PDL::PP::Code->new(@_, undef, undef, 1); }),
PDL::PP::Rule->new(PDL::PP::Code::make_args("BackCode"),
sub { PDL::PP::Code->new(@_, undef, 1, 1); }),
# Compiled representations i.e. what the RunFunc function leaves
# in the params structure. By default, copies of the parameters
# but in many cases (e.g. slice) a benefit can be obtained
# by parsing the string in that function.
# If the user wishes to specify their own MakeComp code and Comp content,
# The next definitions allow this.
PDL::PP::Rule->new("CompObj", ["BadFlag","Comp"],
sub { PDL::PP::Signature->new('', @_) }),
PDL::PP::Rule->new("CompObj", "SignatureObj", sub { @_ }), # provide default
PDL::PP::Rule->new("MakeCompOther", "SignatureObj", sub { $_[0]->getcopy }),
PDL::PP::Rule->new("MakeCompTotal", ["MakeCompOther", \"MakeComp"], sub { join "\n", grep $_, @_ }),
PDL::PP::Rule->new("CompStructOther", "SignatureObj", sub {$_[0]->getcomp}),
PDL::PP::Rule->new("CompStructComp", [qw(CompObj Comp)], sub {$_[0]->getcomp}),
PDL::PP::Rule->new("CompStruct", ["CompStructOther", \"CompStructComp"], sub { join "\n", grep $_, @_ }),
PDL::PP::Rule::MakeComp->new("MakeCompiledReprNS", ["MakeCompTotal","CompObj"],
"COMP"),
PDL::PP::Rule->new("CompFreeCodeOther", "SignatureObj", sub {$_[0]->getfree("COMP")}),
PDL::PP::Rule->new("CompFreeCodeComp", [qw(CompObj Comp)], sub {$_[0]->getfree("COMP")}),
PDL::PP::Rule->new("CompFreeCode", ["CompFreeCodeOther", \"CompFreeCodeComp"], sub { join "\n", grep $_, @_ }),
PDL::PP::Rule->new(["StructDecl","ParamStructType"],
["CompStruct","Name"],
sub {
my($comp,$name) = @_;
return ('', '') if !$comp;
my $ptype = "pdl_params_$name";
(PDL::PP::pp_line_numbers(__LINE__-1, qq{typedef struct $ptype {\n$comp} $ptype;}),
$ptype);
}),
PDL::PP::Rule::Substitute->new("MakeCompiledReprSubd", "MakeCompiledReprNS"),
PDL::PP::Rule->new("DefaultRedoDims",
["StructName"],
sub { "PDL_RETERROR(PDL_err, PDL->redodims_default($_[0]));" }),
PDL::PP::Rule->new("DimsSetters",
["SignatureObj"],
sub { join "\n", sort map $_->get_initdim, $_[0]->dims_values }),
PDL::PP::Rule->new("RedoDimsFuncName", ["Name", \"RedoDims", \"RedoDimsCode", "DimsSetters"],
sub { (scalar grep $_ && /\S/, @_[1..$#_]) ? "pdl_$_[0]_redodims" : 'NULL'}),
PDL::PP::Rule::Returns->new("RedoDimsCode", [],
'Code that can be inserted to set the size of output ndarrays dynamically based on input ndarrays; is parsed',
''),
PDL::PP::Rule->new(PDL::PP::Code::make_args("RedoDimsCode"),
'makes the parsed representation from the supplied RedoDimsCode',
sub { return '' if !$_[0]; PDL::PP::Code->new(@_, 1, undef, 0); }),
PDL::PP::Rule->new("RedoDims",
["DimsSetters","ParsedRedoDimsCode","DefaultRedoDims"],
'makes the redodims function from the various bits and pieces',
sub { join "\n", grep $_ && /\S/, @_ }),
PDL::PP::Rule::Returns::EmptyString->new("Priv"),
PDL::PP::Rule->new("PrivObj", ["BadFlag","Priv"],
sub { PDL::PP::Signature->new('', @_) }),
PDL::PP::Rule->new("NTPrivFreeCode", "PrivObj", sub {$_[0]->getfree("PRIV")}),
PDL::PP::Rule->new("FreeCodeNS",
["StructName","CompFreeCode","NTPrivFreeCode"],
sub {
(grep $_, @_[1..$#_]) ? PDL::PP::pp_line_numbers(__LINE__-1, "PDL_FREE_CODE($_[0], destroy, $_[1], $_[2])"): ''}),
PDL::PP::Rule::Substitute::Usual->new("FreeCodeSubd", "FreeCodeNS"),
PDL::PP::Rule::Returns::EmptyString->new("NewXSCoerceMustSubd"),
PDL::PP::Rule::MakeComp->new("NewXSCoerceMustCompNS", "NewXSCoerceMustSubd", "FOO"),
PDL::PP::Rule::Substitute->new("NewXSCoerceMustCompSubd", "NewXSCoerceMustCompNS"),
PDL::PP::Rule->new("NewXSFindBadStatusNS", ["StructName"],
"Rule to find the bad value status of the input ndarrays",
sub {
PDL::PP::pp_line_numbers(__LINE__, <<EOF);
PDL_RETERROR(PDL_err, PDL->trans_check_pdls($_[0]));
char \$BADFLAGCACHE() = PDL->trans_badflag_from_inputs($_[0]);
EOF
}),
PDL::PP::Rule->new("NewXSCopyBadStatusNS",
["CopyBadStatusCode"],
"Use CopyBadStatusCode if given",
sub {
my ($badcode) = @_;
confess "PDL::PP ERROR: CopyBadStatusCode contains '\$PRIV(bvalflag)'; replace with \$BADFLAGCACHE()"
if $badcode =~ m/\$PRIV(bvalflag)/;
$badcode;
}),
PDL::PP::Rule->new("NewXSCopyBadStatusNS",
["SignatureObj"],
"Rule to copy the bad value status to the output ndarrays",
# note: this is executed before the trans_mutual call
# is made, since the state may be changed by the
# Code section
sub {
my ( $sig ) = @_;
return '' if @{$sig->names} == (my @outs = $sig->names_out); # no input pdls, no badflag copying needed
PDL::PP::pp_line_numbers(__LINE__, join '',
"if (\$BADFLAGCACHE()) {\n",
(map " \$SETPDLSTATEBAD($_);\n", @outs),
"}\n");
}),
# expand macros in ...BadStatusCode
#
PDL::PP::Rule::Substitute::Usual->new("NewXSFindBadStatusSubd", "NewXSFindBadStatusNS"),
PDL::PP::Rule::Substitute::Usual->new("NewXSCopyBadStatusSubd", "NewXSCopyBadStatusNS"),
PDL::PP::Rule->new("NewXSStructInit0",
["StructName","VTableName","ParamStructName","ParamStructType"],
"Rule to create and initialise the private trans structure",
sub {
my( $sname, $vtable, $pname, $ptype ) = @_;
PDL::PP::pp_line_numbers(__LINE__, <<EOF);
if (!PDL) croak("PDL core struct is NULL, can't continue");
pdl_trans *$sname = PDL->create_trans(&$vtable);
@{[$ptype ? " $ptype *$pname = $sname->params;" : ""]}
EOF
}),
PDL::PP::Rule->new(["RunFunc"],
["RunFuncHdr",
"NewXSStructInit0",
"NewXSSetTransPDLs",
"NewXSFindBadStatusSubd",
# NewXSMakeNow, # this is unnecessary since families never got implemented
"NewXSTypeCoerceSubd",
"NewXSExtractTransPDLs",
"MakeCompiledReprSubd",
"NewXSCoerceMustCompSubd",
"NewXSRunTrans",
"NewXSCopyBadStatusSubd",
],
"Generate C function with idiomatic arg list to maybe call from XS",
sub {
my ($xs_c_header, @bits) = @_;
my $opening = 'pdl_error PDL_err = {0, NULL, 0};';
my $closing = 'return PDL_err;';
PDL::PP::pp_line_numbers __LINE__-1, join '', "$xs_c_header {\n$opening\n", @bits, "$closing\n}\n";
}),
# internal usage, not XS - NewXSCHdrs only set if GlobalNew
PDL::PP::Rule->new(["NewXSCode","BootSetNewXS","NewXSInPrelude"],
["NewXSHdr", "NewXSCHdrs", "RunFuncCall"],
"Non-varargs XS code when GlobalNew given",
sub {(undef,(make_xs_code('CODE:',' XSRETURN(0);',@_))[1..2])}),
# if PMCode supplied, no var-args stuff
PDL::PP::Rule->new(["NewXSCode","BootSetNewXS","NewXSInPrelude"],
["PMCode","NewXSHdr", \"NewXSCHdrs", "RunFuncCall"],
"Non-varargs XS code when PMCode given",
sub {make_xs_code('CODE:',' XSRETURN(0);',@_[1..$#_])}),
PDL::PP::Rule->new(["NewXSCode","BootSetNewXS","NewXSInPrelude"],
[qw(VarArgsXSHdr), \"NewXSCHdrs", qw(RunFuncCall VarArgsXSReturn)],
"Rule to print out XS code when variable argument list XS processing is enabled",
sub {make_xs_code('','',@_)}),
PDL::PP::Rule::MakeComp->new("RedoDimsCodeNS",
["RedoDims", "PrivObj"], "PRIV"),
PDL::PP::Rule::Substitute->new("RedoDimsCodeSubd", "RedoDimsCodeNS"),
PDL::PP::Rule->new(make_vfn_args("RedoDims")),
PDL::PP::Rule::MakeComp->new("ReadDataCodeNS", "ParsedCode", "FOO"),
PDL::PP::Rule::Substitute->new("ReadDataCodeSubd", "ReadDataCodeNS"),
PDL::PP::Rule::InsertName->new("ReadDataFuncName", 'pdl_${name}_readdata'),
PDL::PP::Rule->new(make_vfn_args("ReadData")),
PDL::PP::Rule::MakeComp->new("WriteBackDataCodeNS", "ParsedBackCode", "FOO"),
PDL::PP::Rule::Substitute->new("WriteBackDataCodeSubd", "WriteBackDataCodeNS"),
PDL::PP::Rule::InsertName->new("WriteBackDataFuncName", "BackCode", 'pdl_${name}_writebackdata'),
PDL::PP::Rule::Returns::NULL->new("WriteBackDataFuncName", "Code"),
PDL::PP::Rule->new(make_vfn_args("WriteBackData")),
PDL::PP::Rule->new("FreeFuncName",
["FreeCodeSubd","Name"],
sub {$_[0] ? "pdl_$_[1]_free" : 'NULL'}),
PDL::PP::Rule->new(make_vfn_args("Free", ", char destroy")),
PDL::PP::Rule::Returns::Zero->new("NoPthread"), # assume we can pthread, unless indicated otherwise
PDL::PP::Rule->new("VTableDef",
["VTableName","ParamStructType","RedoDimsFuncName","ReadDataFuncName",
"WriteBackDataFuncName","FreeFuncName",
"SignatureObj","Affine_Ok","HaveBroadcasting","NoPthread","Name",
"GenericTypes","IsAffineFlag","TwoWayFlag","DefaultFlowFlag",
"BadFlag"],
sub {
my($vname,$ptype,$rdname,$rfname,$wfname,$ffname,
$sig,$affine_ok,$havebroadcasting, $noPthreadFlag, $name, $gentypes,
$affflag, $revflag, $flowflag, $badflag) = @_;
my ($pnames, $pobjs) = ($sig->names_sorted, $sig->objs);
my $nparents = 0 + grep {! $pobjs->{$_}->{FlagW}} @$pnames;
my $aff = ($affine_ok ? "PDL_TPDL_VAFFINE_OK" : 0);
my $npdls = scalar @$pnames;
my $join_flags = join(", ",map {$pobjs->{$pnames->[$_]}->{FlagPhys} ?
0 : $aff} 0..$npdls-1) || '0';
my @op_flags;
push @op_flags, 'PDL_TRANS_DO_BROADCAST' if $havebroadcasting;
push @op_flags, 'PDL_TRANS_BADPROCESS' if $badflag;
push @op_flags, 'PDL_TRANS_BADIGNORE' if defined $badflag and !$badflag;
push @op_flags, 'PDL_TRANS_NO_PARALLEL' if $noPthreadFlag;
my $op_flags = join('|', @op_flags) || '0';
my $iflags = join('|', grep $_, $affflag, $revflag, $flowflag) || '0';
my $gentypes_txt = join(", ", (map PDL::Type->new($_)->sym, @$gentypes), '-1');
my @realdims = map 0+@{$_->{IndObjs}}, @$pobjs{@$pnames};
my $realdims = join(", ", @realdims) || '0';
my $parnames = join(",",map qq|"$_"|, @$pnames) || '""';
my $parflags = join(",\n ",map join('|', $_->cflags)||'0', @$pobjs{@$pnames}) || '0';
my $partypes = join(", ", map defined()?$_->sym:-1, map $_->{Type}, @$pobjs{@$pnames}) || '-1';
my $i = 0; my @starts = map { my $ci = $i; $i += $_; $ci } @realdims;
my $realdim_ind_start = join(", ", @starts) || '0';
my @rd_inds = map $_->get_index, map @{$_->{IndObjs}}, @$pobjs{@$pnames};
my $realdim_inds = join(", ", @rd_inds) || '0';
my @indnames = $sig->ind_names_sorted;
my $indnames = join(",", map qq|"$_"|, @indnames) || '""';
my $sizeof = $ptype ? "sizeof($ptype)" : '0';
PDL::PP::pp_line_numbers(__LINE__, <<EOF);
static pdl_datatypes ${vname}_gentypes[] = { $gentypes_txt };
static char ${vname}_flags[] = {
$join_flags
};
static PDL_Indx ${vname}_realdims[] = { $realdims };
static char *${vname}_parnames[] = { $parnames };
static short ${vname}_parflags[] = {
$parflags
};
static pdl_datatypes ${vname}_partypes[] = { $partypes };
static PDL_Indx ${vname}_realdims_starts[] = { $realdim_ind_start };
static PDL_Indx ${vname}_realdims_ind_ids[] = { $realdim_inds };
static char *${vname}_indnames[] = { $indnames };
pdl_transvtable $vname = {
$op_flags, $iflags, ${vname}_gentypes, $nparents, $npdls, ${vname}_flags,
${vname}_realdims, ${vname}_parnames,
${vname}_parflags, ${vname}_partypes,
${vname}_realdims_starts, ${vname}_realdims_ind_ids, @{[scalar @rd_inds]},
@{[scalar @indnames]}, ${vname}_indnames,
$rdname, $rfname, $wfname,
$ffname,
$sizeof,"$::PDLMOD\::$name"
};
EOF
}),
PDL::PP::Rule->new('PMFunc', 'Name',
'Sets PMFunc to default symbol table manipulations',
sub {
my ($name) = @_;
$::PDL_IFBEGINWRAP[0].'*'.$name.' = \&'.$::PDLOBJ.
'::'.$name.";\n".$::PDL_IFBEGINWRAP[1]
}
),
];
}
1;
