"Fossies" - the Fresh Open Source Software Archive

Member "PDL-2.080/Basic/Gen/PP.pm" (19 May 2022, 77583 Bytes) of package /linux/misc/PDL-2.080.tar.gz:


As a special service "Fossies" has tried to format the requested source page into HTML format using (guessed) Perl source code syntax highlighting (style: standard) with prefixed line numbers and code folding option. Alternatively you can here view or download the uninterpreted source code file. For more information about "PP.pm" see the Fossies "Dox" file reference documentation and the latest Fossies "Diffs" side-by-side code changes report: 2.079_vs_2.080.

    1 # $PDL::PP::deftbl is an array-ref of
    2 #   PDL::PP::Rule->new("Name1", "Name2", $ref_to_sub)
    3 # where Name1 represents the target of the rule, Name2 the condition,
    4 # and the subroutine reference is the routine called when the rule is
    5 # applied.
    6 #
    7 # If there is no condition, the argument can be left out of the call
    8 # (unless there is a doc string), so
    9 #   PDL::PP::Rule->new("Name1", $ref_to_sub)
   10 #
   11 # The target and conditions can also be an array reference, so
   12 #   PDL::PP::Rule->new("Name1", ["Name2","Name3"], $ref_to_sub)
   13 #   PDL::PP::Rule->new(["Name1","Name2"], "Name3", $ref_to_sub)
   14 #   PDL::PP::Rule->new(["Name1","Name2"], ["Name3","Name4], $ref_to_sub)
   15 #
   16 # If a doc string exists then the condition must also
   17 # be supplied, even if it is just [] (ie no condition).
   18 #
   19 # There are specialized rules for common situations. The rules for the
   20 # target, condition, and doc arguments hold from the base class (ie
   21 # whether scalar or array values are used, ...)
   22 #
   23 # Return a constant:
   24 #
   25 # PDL::PP::Rule::Returns->new($targets [,$conditions [,$doc]], $value)
   26 # is used to return a constant. So
   27 #   PDL::PP::Rule::Returns->new("Name1", "foo")
   28 #
   29 # This class is specialized since there are some common return values:
   30 #   PDL::PP::Rule::Returns::Zero->new($targets [,$conditions [,$doc]])
   31 #   PDL::PP::Rule::Returns::One->new($targets [,$conditions [,$doc]])
   32 #   PDL::PP::Rule::Returns::EmptyString->new($targets [,$conditions [,$doc]])
   33 #   PDL::PP::Rule::Returns::NULL->new($targets [,$conditions [,$doc]])
   34 # which return 0, 1, "", and "NULL" respectively
   35 #
   36 # The InsertName class exists to allow you to return something like
   37 #   "foo<routine name>bar"
   38 # e.g.
   39 #  PDL::PP::Rule::InsertName->new("Foo", '_pdl_${name}_bar')
   40 #  PDL::PP::Rule::InsertName->new("Foo", "Arg2", '_pdl_${name}_bar')
   41 # Note that the Name argument is automatically used as a condition, so
   42 # it does not need to be supplied, and the return value should be
   43 # given as a single-quoted string and use the $name variable
   44 #
   45 # The Substitute rule replaces dollar-signed macros ($P(), $ISBAD(), etc)
   46 # with the low-level C code to perform the macro.
   47 #   PDL::PP::Rule::Substitute("NewXSCoerceMustSubs", "NewXSCoerceMustSub1")
   48 # PDL::PP::Rule::Substitute->new($target,$condition)
   49 #   $target and $condition must be scalars.
   50 
   51 package PDL::PP::Rule;
   52 
   53 use strict;
   54 use warnings;
   55 
   56 use Carp;
   57 
   58 use overload ("\"\"" => \&PDL::PP::Rule::stringify);
   59 sub stringify {
   60     my $self = shift;
   61 
   62     my $str = ref $self;
   63     if ("PDL::PP::Rule" eq $str) {
   64     $str = "Rule";
   65     } else {
   66     $str =~ s/PDL::PP::Rule:://;
   67     }
   68     $str = "($str) ";
   69     $str .= exists $self->{doc} ?
   70        $self->{doc} : join(",", @{$self->{targets}});
   71     return $str;
   72 }
   73 
   74 # Takes two args: the calling object and the message, but we only care
   75 # about the message:
   76 sub report ($$) { print $_[1] if $::PP_VERBOSE; }
   77 
   78 # Very limited error checking.
   79 # Allow scalars for targets and conditions to be optional
   80 #
   81 # At present you have to have a conditions argument if you supply
   82 # a doc string
   83 my $rule_usage = "Usage: PDL::PP::Rule->new(\$targets[,\$conditions[,\$doc],] [,\$ref])\n";
   84 sub new {
   85     die $rule_usage if @_ < 2 or @_ > 5;
   86     my $class = shift;
   87     my $self = bless {}, $class;
   88     my $targets = shift;
   89     $targets = [$targets] unless ref $targets eq "ARRAY";
   90     $self->{targets} = $targets;
   91     return $self if !@_;
   92     $self->{ref} = pop if ref $_[-1] eq "CODE";
   93     my $conditions = shift // [];
   94     $conditions = [$conditions] unless ref $conditions eq "ARRAY";
   95     $self->{conditions} = $conditions;
   96     $self->{doc} = shift if defined $_[0];
   97     $self;
   98 }
   99 
  100 # $rule->any_targets_exist($pars);
  101 #
  102 # Returns 1 if any of the targets exist in $pars, 0 otherwise.
  103 # A return value of 1 means that the rule should not be applied.
  104 sub any_targets_exist {
  105     my $self = shift;
  106     my $pars = shift;
  107 
  108     my $targets = $self->{targets};
  109 
  110     foreach my $target (@$targets) {
  111     if (exists $pars->{$target}) {
  112         $self->report("--skipping since TARGET $target exists\n");
  113         return 1;
  114     }
  115     }
  116     return 0;
  117 }
  118 
  119 # $rule->all_conditions_exist($pars);
  120 #
  121 # Returns 1 if all of the required conditions exist in $pars, 0 otherwise.
  122 # A return value of 0 means that the rule should not be applied.
  123 sub all_conditions_exist {
  124     my $self = shift;
  125     my $pars = shift;
  126     return 1 unless my @nonexist = grep !ref() && !exists $pars->{$_}, @{$self->{conditions}};
  127     $self->report("--skipping since CONDITIONs (@nonexist) do not exist\n");
  128     0;
  129 }
  130 
  131 # $rule->should_apply($pars);
  132 #
  133 # Returns 1 if the rule should be applied (ie no targets already
  134 # exist in $pars and all the required conditions exist in $pars),
  135 # otherwise 0.
  136 #
  137 sub should_apply {
  138     my $self = shift;
  139     my $pars = shift;
  140     return 0 if $self->any_targets_exist($pars);
  141     return 0 unless $self->all_conditions_exist($pars);
  142     return 1;
  143 }
  144 
  145 # my @args = $self->extract_args($pars);
  146 sub extract_args {
  147     my ($self, $pars) = @_;
  148     @$pars{ map ref($_) eq "SCALAR" ? $$_ : $_, @{ $self->{conditions} } };
  149 }
  150 
  151 # Apply the rule using the supplied $pars hash reference.
  152 #
  153 sub apply {
  154     my $self = shift;
  155     my $pars = shift;
  156 
  157     carp "Unable to apply rule $self as there is no subroutine reference!"
  158       unless exists $self->{ref};
  159 
  160     my $targets = $self->{targets};
  161     my $conditions = $self->{conditions};
  162     my $ref = $self->{ref};
  163 
  164     $self->report("Applying: $self\n");
  165 
  166     return unless $self->should_apply($pars);
  167 
  168     # Create the argument array for the routine.
  169     #
  170     my @args = $self->extract_args($pars);
  171 
  172     # Run this rule's subroutine:
  173     my @retval = $ref->(@args);
  174 
  175     # Check for any inconsistencies:
  176     confess "Internal error: rule '$self' returned " . (1+$#retval)
  177       . " items and expected " . (1+$#$targets)
  178         unless $#retval == $#$targets;
  179 
  180     $self->report("--setting:");
  181     foreach my $target (@$targets) {
  182         $self->report(" $target");
  183         confess "Cannot have multiple meanings for target $target!"
  184           if exists $pars->{$target};
  185         my $result = shift @retval;
  186 
  187         # The following test suggests that things could/should be
  188         # improved in the code generation.
  189         #
  190         if (defined $result and $result eq 'DO NOT SET!!') {
  191             $self->report (" is 'DO NOT SET!!'");
  192         } else {
  193             $pars->{$target} = $result;
  194         }
  195     }
  196     $self->report("\n");
  197 }
  198 
  199 
  200 package PDL::PP::Rule::Croak;
  201 
  202 # Croaks if all of the input variables are defined. Use this to identify
  203 # incompatible arguments.
  204 our @ISA = qw(PDL::PP::Rule);
  205 use Carp;
  206 
  207 sub new {
  208     croak('Usage: PDL::PP::Rule::Croak->new(["incompatible", "arguments"], "Croaking message")')
  209         unless @_ == 3;
  210     shift->SUPER::new([], @_);
  211 }
  212 
  213 sub apply {
  214     my ($self, $pars) = @_;
  215     croak($self->{doc}) if $self->should_apply($pars);
  216 }
  217 
  218 package PDL::PP::Rule::Returns;
  219 use strict;
  220 use Carp;
  221 
  222 our @ISA = qw (PDL::PP::Rule);
  223 
  224 # This class does not treat return values of "DO NOT SET!!"
  225 # as special.
  226 #
  227 sub new {
  228     my $class = shift;
  229     my $value = pop;
  230     my $self  = $class->SUPER::new(@_);
  231     $self->{"returns.value"} = $value;
  232     my $targets = $self->{targets};
  233     croak "There can only be 1 target for a $self, not " . (1+$#$targets) . "!"
  234       unless $#$targets == 0;
  235     return $self;
  236 }
  237 
  238 sub apply {
  239     my $self = shift;
  240     my $pars = shift;
  241 
  242     carp "Unable to apply rule $self as there is no return value!"
  243       unless exists $self->{"returns.value"};
  244 
  245     my $target = $self->{targets}->[0];
  246 
  247     $self->report("Applying: $self\n");
  248 
  249     return unless $self->should_apply($pars);
  250 
  251     # Set the value
  252     #
  253     $self->report ("--setting: $target\n");
  254     $pars->{$target} = $self->{"returns.value"};
  255 }
  256 
  257 package PDL::PP::Rule::Returns::Zero;
  258 
  259 use strict;
  260 
  261 our @ISA = qw (PDL::PP::Rule::Returns);
  262 
  263 sub new {
  264     shift->SUPER::new(@_,0);
  265 }
  266 
  267 package PDL::PP::Rule::Returns::One;
  268 
  269 use strict;
  270 
  271 our @ISA = qw (PDL::PP::Rule::Returns);
  272 
  273 sub new {
  274     shift->SUPER::new(@_,1);
  275 }
  276 
  277 package PDL::PP::Rule::Returns::EmptyString;
  278 
  279 use strict;
  280 
  281 our @ISA = qw (PDL::PP::Rule::Returns);
  282 
  283 sub new {
  284     shift->SUPER::new(@_,"");
  285 }
  286 
  287 package PDL::PP::Rule::Returns::NULL;
  288 
  289 use strict;
  290 
  291 our @ISA = qw (PDL::PP::Rule::Returns);
  292 
  293 sub new {
  294     shift->SUPER::new(@_,"NULL");
  295 }
  296 
  297 package PDL::PP::Rule::InsertName;
  298 
  299 use strict;
  300 use Carp;
  301 our @ISA = qw (PDL::PP::Rule);
  302 
  303 # This class does not treat return values of "DO NOT SET!!"
  304 # as special.
  305 #
  306 sub new {
  307     my $class = shift;
  308 
  309     my $value = pop;
  310 
  311     my @args  = @_;
  312     my $self  = $class->SUPER::new(@args);
  313     $self->{"insertname.value"} = $value;
  314 
  315     # Generate a defaul doc string
  316     unless (exists $self->{doc}) {
  317         $self->{doc} = 'Sets ' . $self->{targets}->[0]
  318             . ' to "' . $value . '"';
  319     }
  320 
  321     my $targets = $self->{targets};
  322     croak "There can only be 1 target for a $self, not " . (1+$#$targets) . "!"
  323       unless $#$targets == 0;
  324 
  325     # we add "Name" as the first condition
  326     #
  327     my $conditions = $self->{conditions};
  328     unshift @$conditions, "Name";
  329 
  330     return $self;
  331 }
  332 
  333 sub apply {
  334     my $self = shift;
  335     my $pars = shift;
  336 
  337     carp "Unable to apply rule $self as there is no return value!"
  338       unless exists $self->{"insertname.value"};
  339 
  340     $self->report("Applying: $self\n");
  341 
  342     return unless $self->should_apply($pars);
  343 
  344     # Set the value
  345     #
  346     my $target = $self->{targets}->[0];
  347     my $name   = $pars->{Name};
  348     $self->report ("--setting: $target (name=$name)\n");
  349     $pars->{$target} = eval "return \"" . $self->{"insertname.value"} . "\";";
  350 }
  351 
  352 #   PDL::PP::Rule->new("NewXSCoerceMustSubs", ["NewXSCoerceMustSub1","Name"],
  353 #             \&dosubst),
  354 #
  355 # PDL::PP::Rule::Substitute->new($target,$condition)
  356 #   $target and $condition must be scalars.
  357 package PDL::PP::Rule::Substitute;
  358 
  359 use strict;
  360 use Carp;
  361 our @ISA = qw (PDL::PP::Rule);
  362 
  363 sub badflag_isset {
  364   PDL::PP::pp_line_numbers(__LINE__-1, "($_[0]->state & PDL_BADVAL)")
  365 }
  366 
  367 # Probably want this directly in the apply routine but leave as is for now
  368 sub dosubst_private {
  369     my ($src,$sname,$pname,$name,$sig,$compobj,$privobj) = @_;
  370     my $ret = (ref $src ? $src->[0] : $src);
  371     my @pairs;
  372     for ([$compobj,'COMP'], [$privobj,'PRIV']) {
  373         my ($cobj, $which) = @$_;
  374     my ($cn,$co) = map $cobj->$_, qw(othernames otherobjs);
  375         push @pairs, 'DO'.$which.'ALLOC' => sub {
  376           join '', map $$co{$_}->get_malloc("\$$which($_)"),
  377             grep $$co{$_}->need_malloc, @$cn
  378         };
  379     }
  380     my %syms = (
  381       @pairs,
  382       ((ref $src) ? %{$src->[1]} : ()),
  383       PRIV => sub {return "$sname->$_[0]"},
  384       COMP => sub {return "$pname->$_[0]"},
  385       CROAK => sub {PDL::PP::pp_line_numbers(__LINE__-1, "return PDL->make_error(PDL_EUSERERROR, \"Error in $name:\" @{[join ',', @_]})")},
  386       NAME => sub {return $name},
  387       MODULE => sub {return $::PDLMOD},
  388       SETPDLSTATEBAD  => sub { PDL::PP::pp_line_numbers(__LINE__-1, "$_[0]\->state |= PDL_BADVAL") },
  389       SETPDLSTATEGOOD => sub { PDL::PP::pp_line_numbers(__LINE__-1, "$_[0]\->state &= ~PDL_BADVAL") },
  390       ISPDLSTATEBAD   => \&badflag_isset,
  391       ISPDLSTATEGOOD  => sub {"!".badflag_isset($_[0])},
  392       BADFLAGCACHE    => sub { PDL::PP::pp_line_numbers(__LINE__-1, "badflag_cache") },
  393       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") },
  394       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") },
  395       PDLSTATEISBAD => sub {badflag_isset(($sig->objs->{$_[0]}//confess "Can't get PDLSTATEISBAD for unknown ndarray '$_[0]'")->do_pdlaccess)},
  396       PDLSTATEISGOOD => sub {"!".badflag_isset(($sig->objs->{$_[0]}//confess "Can't get PDLSTATEISGOOD for unknown ndarray '$_[0]'")->do_pdlaccess)},
  397       PP => sub { ($sig->objs->{$_[0]}//confess "Can't get PP for unknown ndarray '$_[0]'")->do_physpointeraccess },
  398       P => sub { (my $o = ($sig->objs->{$_[0]}//confess "Can't get P for unknown ndarray '$_[0]'"))->{FlagPhys} = 1; $o->do_pointeraccess; },
  399       PDL => sub { ($sig->objs->{$_[0]}//confess "Can't get PDL for unknown ndarray '$_[0]'")->do_pdlaccess },
  400       SIZE => sub { ($sig->ind_obj($_[0])//confess "Can't get SIZE of unknown dim '$_[0]'")->get_size },
  401       SETNDIMS => sub {PDL::PP::pp_line_numbers(__LINE__-1, "PDL_RETERROR(PDL_err, PDL->reallocdims(__it,$_[0]));")},
  402       SETDIMS => sub {PDL::PP::pp_line_numbers(__LINE__-1, "PDL_RETERROR(PDL_err, PDL->setdims_careful(__it));")},
  403       SETDELTABROADCASTIDS => sub {PDL::PP::pp_line_numbers(__LINE__, <<EOF)},
  404 {int __ind; PDL_RETERROR(PDL_err, PDL->reallocbroadcastids(\$PDL(CHILD), \$PDL(PARENT)->nbroadcastids));
  405 for(__ind=0; __ind<\$PDL(PARENT)->nbroadcastids; __ind++)
  406   \$PDL(CHILD)->broadcastids[__ind] = \$PDL(PARENT)->broadcastids[__ind] + ($_[0]);
  407 }
  408 EOF
  409       %PDL::PP::macros,
  410     );
  411     my $known_pat = join '|', map quotemeta, sort keys %syms;
  412     while (my ($before, $kw, $args, $other) = macro_extract($ret, $known_pat)) {
  413       confess("$kw not defined in '$ret'!") if !$syms{$kw};
  414       $ret = join '', $before, $syms{$kw}->(split_cpp($args)), $other;
  415     }
  416     $ret;
  417 }
  418 
  419 # split like C pre-processor - on commas unless in "" or ()
  420 my $extract_spec = [
  421   sub {Text::Balanced::extract_delimited($_[0], '"')},
  422   sub {Text::Balanced::extract_bracketed($_[0], '()')},
  423   qr/\s+/,
  424   qr/[^",\(\s]+/,
  425   { COMMA => qr/,/ },
  426 ];
  427 sub split_cpp {
  428   my ($text) = @_;
  429   require Text::Balanced;
  430   my ($thisstr, @parts);
  431   while (defined(my $n = Text::Balanced::extract_multiple($text, $extract_spec, undef, 1))) {
  432     if (ref $n) { push @parts, $thisstr // ''; $thisstr = ''; }
  433     else { $thisstr = '' if !defined $thisstr; $thisstr .= $n; }
  434   }
  435   push @parts, $thisstr if defined $thisstr;
  436   s/^\s+//, s/\s+$// for @parts;
  437   @parts;
  438 }
  439 
  440 sub macro_extract {
  441   require Text::Balanced;
  442   my ($text, $pat) = @_;
  443   return unless $text =~ /\$($pat)\s*(?=\()/;
  444   my ($before, $kw, $other) = ($`, $1, $');
  445   (my $bracketed, $other) = Text::Balanced::extract_bracketed($other, '(")');
  446   $bracketed = substr $bracketed, 1, -1; # chop off brackets
  447   $bracketed =~ s:^\s*(.*?)\s*$:$1:;
  448   ($before, $kw, $bracketed, $other);
  449 }
  450 
  451 sub new {
  452     die "Usage: PDL::PP::Rule::Substitute->new(\$target,\$condition);"
  453       unless @_ == 3;
  454     my ($class, $target, $condition) = @_;
  455     die "\$target must be a scalar for PDL::PP::Rule::Substitute" if ref $target;
  456     die "\$condition must be a scalar for PDL::PP::Rule::Substitute" if ref $condition;
  457     $class->SUPER::new($target, [$condition, qw(StructName ParamStructName Name SignatureObj CompObj PrivObj)],
  458                   \&dosubst_private);
  459 }
  460 
  461 package PDL::PP;
  462 
  463 use strict;
  464 
  465 our $VERSION = "2.3";
  466 $VERSION = eval $VERSION;
  467 
  468 our $macros_xs = <<'EOF';
  469 #define PDL_XS_PREAMBLE \
  470   char *objname = "PDL"; /* XXX maybe that class should actually depend on the value set \
  471                             by pp_bless ? (CS) */ \
  472   HV *bless_stash = 0; \
  473   SV *parent = 0; \
  474   int   nreturn = 0; \
  475   (void)nreturn;
  476 
  477 #define PDL_XS_PACKAGEGET \
  478   PDL_COMMENT("Check if you can get a package name for this input value.  ") \
  479   PDL_COMMENT("It can be either a PDL (SVt_PVMG) or a hash which is a     ") \
  480   PDL_COMMENT("derived PDL subclass (SVt_PVHV)                            ") \
  481   if (SvROK(ST(0)) && ((SvTYPE(SvRV(ST(0))) == SVt_PVMG) || (SvTYPE(SvRV(ST(0))) == SVt_PVHV))) { \
  482     parent = ST(0); \
  483     if (sv_isobject(parent)){ \
  484     bless_stash = SvSTASH(SvRV(ST(0))); \
  485     objname = HvNAME((bless_stash));  PDL_COMMENT("The package to bless output vars into is taken from the first input var") \
  486     } \
  487   }
  488 
  489 #define PDL_XS_PERLINIT(name, to_push, method) \
  490   if (strcmp(objname,"PDL") == 0) { PDL_COMMENT("shortcut if just PDL") \
  491      name ## _SV = sv_newmortal(); \
  492      name = PDL->pdlnew(); \
  493      if (!name) PDL->pdl_barf("Error making null pdl"); \
  494      PDL->SetSV_PDL(name ## _SV, name); \
  495      if (bless_stash) name ## _SV = sv_bless(name ## _SV, bless_stash); \
  496   } else { \
  497      PUSHMARK(SP); \
  498      XPUSHs(to_push); \
  499      PUTBACK; \
  500      perl_call_method(#method, G_SCALAR); \
  501      SPAGAIN; \
  502      name ## _SV = POPs; \
  503      PUTBACK; \
  504      name = PDL->SvPDLV(name ## _SV); \
  505   }
  506 
  507 #define PDL_XS_RETURN(clause1) \
  508     if (nreturn) { \
  509       if (nreturn > 0) EXTEND (SP, nreturn); \
  510       clause1; \
  511       XSRETURN(nreturn); \
  512     } else { \
  513       XSRETURN(0); \
  514     }
  515 
  516 #define PDL_XS_INPLACE(in, out) \
  517     if (in->state & PDL_INPLACE && (out != in)) { \
  518     in->state &= ~PDL_INPLACE; PDL_COMMENT("unset") \
  519     out = in; \
  520     PDL->SetSV_PDL(out ## _SV,out); \
  521     }
  522 
  523 #define PDL_XS_INPLACE_CHECK(in) \
  524     if (in->state & PDL_INPLACE) barf("inplace input but output given");
  525 EOF
  526 
  527 our $header_c = pp_line_numbers(__LINE__, <<'EOF');
  528 /*
  529  * THIS FILE WAS GENERATED BY PDL::PP! Do not modify!
  530  */
  531 
  532 #define PDL_COMMENT(comment)
  533 PDL_COMMENT("This preprocessor symbol is used to add commentary in the PDL  ")
  534 PDL_COMMENT("autogenerated code. Normally, one would use typical C-style    ")
  535 PDL_COMMENT("multiline comments (i.e. /* comment */). However, because such ")
  536 PDL_COMMENT("comments do not nest, it's not possible for PDL::PP users to   ")
  537 PDL_COMMENT("comment-out sections of code using multiline comments, as is   ")
  538 PDL_COMMENT("often the practice when debugging, for example. So, when you   ")
  539 PDL_COMMENT("see something like this:                                       ")
  540 PDL_COMMENT("                                                               ")
  541                 PDL_COMMENT("Memory access")
  542 PDL_COMMENT("                                                               ")
  543 PDL_COMMENT("just think of it as a C multiline comment like:                ")
  544 PDL_COMMENT("                                                               ")
  545 PDL_COMMENT("   /* Memory access */                                         ")
  546 
  547 #define PDL_FREE_CODE(trans, destroy, comp_free_code, ntpriv_free_code) \
  548     if (destroy) { \
  549     comp_free_code \
  550     } \
  551     if ((trans)->dims_redone) { \
  552     ntpriv_free_code \
  553     }
  554 
  555 #include "EXTERN.h"
  556 #include "perl.h"
  557 #include "XSUB.h"
  558 #include "pdl.h"
  559 #include "pdlcore.h"
  560 #define PDL %s
  561 extern Core* PDL; PDL_COMMENT("Structure hold core C functions")
  562 static int __pdl_boundscheck = 0;
  563 static SV* CoreSV;       PDL_COMMENT("Gets pointer to perl var holding core structure")
  564 
  565 #if ! %s
  566 # define PP_INDTERM(max, at) at
  567 #else
  568 # define PP_INDTERM(max, at) (__pdl_boundscheck? PDL->safe_indterm(max,at, __FILE__, __LINE__) : at)
  569 #endif
  570 EOF
  571 our $header_xs = pp_line_numbers(__LINE__, <<'EOF');
  572 
  573 Core* PDL = NULL; PDL_COMMENT("Structure hold core C functions")
  574 
  575 MODULE = %1$s PACKAGE = %1$s
  576 
  577 PROTOTYPES: ENABLE
  578 
  579 int
  580 set_boundscheck(i)
  581        int i;
  582        CODE:
  583        if (! %6$s)
  584          warn("Bounds checking is disabled for %1$s");
  585        RETVAL = __pdl_boundscheck;
  586        __pdl_boundscheck = i;
  587        OUTPUT:
  588        RETVAL
  589 
  590 
  591 MODULE = %1$s PACKAGE = %2$s
  592 
  593 %3$s
  594 
  595 BOOT:
  596 
  597    PDL_COMMENT("Get pointer to structure of core shared C routines")
  598    PDL_COMMENT("make sure PDL::Core is loaded")
  599    %4$s
  600    %5$s
  601 EOF
  602 
  603 use Config;
  604 use Exporter;
  605 use Data::Dumper;
  606 
  607 our @ISA = qw(Exporter);
  608 
  609 our @EXPORT = qw/pp_addhdr pp_addpm pp_bless pp_def pp_done pp_add_boot
  610                       pp_add_exported pp_addxs pp_add_isa pp_export_nothing
  611               pp_core_importList pp_beginwrap pp_setversion
  612                       pp_addbegin pp_boundscheck pp_line_numbers
  613                       pp_deprecate_module pp_add_macros/;
  614 
  615 $PP::boundscheck = 1;
  616 $::PP_VERBOSE    = 0;
  617 
  618 our $done = 0;  # pp_done has not been called yet
  619 
  620 use Carp;
  621 
  622 sub nopm { $::PDLPACK eq 'NONE' } # flag that we don't want to generate a PM
  623 
  624 sub import {
  625     my ($mod,$modname, $packname, $prefix, $callpack, $multi_c) = @_;
  626     # Allow for users to not specify the packname
  627     ($packname, $prefix, $callpack) = ($modname, $packname, $prefix)
  628         if ($packname =~ m|/|);
  629 
  630     $::PDLMOD=$modname; $::PDLPACK=$packname; $::PDLPREF=$prefix;
  631     $::CALLPACK = $callpack || $::PDLMOD;
  632     $::PDLMULTI_C = $multi_c; # one pp-*.c per function
  633     $::PDLOBJ = "PDL"; # define pp-funcs in this package
  634     $::PDLXS="";
  635     $::PDLBEGIN="";
  636     $::PDLPMROUT="";
  637     for ('Top','Bot','Middle') { $::PDLPM{$_}="" }
  638     @::PDLPMISA=('PDL::Exporter', 'DynaLoader');
  639     @::PDL_IFBEGINWRAP = ('','');
  640     $::PDLVERSIONSET = '';
  641     $::PDLMODVERSION = undef;
  642     $::DOCUMENTED = 0;
  643     $::PDLCOREIMPORT = "";  #import list from core, defaults to everything, i.e. use Core
  644                 #  could be set to () for importing nothing from core. or qw/ barf / for
  645                 # importing barf only.
  646     @_=("PDL::PP");
  647     goto &Exporter::import;
  648 }
  649 
  650 sub list_functions {
  651   my ($file) = @_;
  652   my @funcs;
  653   undef &PDL::PP::pp_def;
  654   local *PDL::PP::pp_def = sub { push @funcs, (_pp_parsename($_[0]))[0]};
  655   undef &PDL::PP::pp_done;
  656   local *PDL::PP::pp_done = sub {};
  657   $_ = '' for $::PDLMOD, $::CALLPACK, $::PDLOBJ; # stop warnings
  658   require File::Spec::Functions;
  659   do ''.File::Spec::Functions::rel2abs($file);
  660   die $@ if $@;
  661   @funcs;
  662 }
  663 
  664 our %macros;
  665 
  666 sub pp_add_macros {
  667   confess "Usage: pp_add_macros(name=>sub {},...)" if @_%2;
  668   %macros = (%macros, @_);
  669 }
  670 
  671 # query/set boundschecking
  672 # if on the generated XS code will have optional boundschecking
  673 # that can be turned on/off at runtime(!) using
  674 #   __PACKAGE__::set_boundscheck(arg); # arg should be 0/1
  675 # if off code is speed optimized and no runtime boundschecking
  676 # can be performed
  677 # ON by default
  678 sub pp_boundscheck {
  679   my $ret = $PP::boundscheck;
  680   $PP::boundscheck = $_[0] if $#_ > -1;
  681   return $ret;
  682 }
  683 
  684 sub pp_beginwrap {
  685     @::PDL_IFBEGINWRAP = ('BEGIN {','}');
  686 }
  687 
  688 sub pp_setversion {
  689     my ($ver) = @_;
  690     $ver = qq{'$ver'} if $ver !~ /['"]/;
  691     $::PDLMODVERSION = '$VERSION';
  692     $::PDLVERSIONSET = "our \$VERSION = $ver;";
  693 }
  694 
  695 sub pp_addhdr {
  696     my ($hdr) = @_;
  697     $::PDLXSC .= $hdr;
  698     $::PDLXSC_header .= $hdr if $::PDLMULTI_C;
  699 }
  700 
  701 sub pp_addpm {
  702     my $pm = shift;
  703     my $pos;
  704     if (ref $pm) {
  705       my $opt = $pm;
  706       $pm = shift;
  707       croak "unknown option" unless defined $opt->{At} &&
  708         $opt->{At} =~ /^(Top|Bot|Middle)$/;
  709       $pos = $opt->{At};
  710     } else {
  711       $pos = 'Middle';
  712     }
  713     my @c = caller;
  714     $::PDLPM{$pos} .= _pp_line_number_file($c[1], $c[2]-1, "\n$pm")."\n\n";
  715 }
  716 
  717 sub pp_add_exported {
  718   shift if !$_[0] or $_[0] eq __PACKAGE__;
  719   $::PDLPMROUT .= join ' ', @_, '';
  720 }
  721 
  722 sub pp_addbegin {
  723     my ($cmd) = @_;
  724     if ($cmd =~ /^\s*BOOT\s*$/) {
  725         pp_beginwrap;
  726     } else {
  727         $::PDLBEGIN .= $cmd."\n";
  728     }
  729 }
  730 
  731 #  Sub to call to export nothing (i.e. for building OO package/object)
  732 sub pp_export_nothing {
  733     $::PDLPMROUT = ' ';
  734 }
  735 
  736 sub pp_add_isa {
  737     push @::PDLPMISA,@_;
  738 }
  739 
  740 sub pp_add_boot {
  741     my ($boot) = @_;
  742     $boot =~ s/^\s*\n//gm; # XS doesn't like BOOT having blank lines
  743     $::PDLXSBOOT .= $boot;
  744 }
  745 
  746 sub pp_bless{
  747    my($new_package)=@_;
  748    $::PDLOBJ = $new_package;
  749 }
  750 
  751 # sub to call to set the import list from core on the 'Use Core' line in the .pm file.
  752 #   set to '()' to not import anything from Core, or 'qw/ barf /' to import barf.
  753 sub pp_core_importList{
  754    $::PDLCOREIMPORT = $_[0];
  755 }
  756 
  757 sub printxs {
  758     shift;
  759     $::PDLXS .= join'',@_;
  760 }
  761 
  762 sub pp_addxs {
  763     PDL::PP->printxs("\nMODULE = $::PDLMOD PACKAGE = $::CALLPACK\n\n",
  764                          @_,
  765                          "\nMODULE = $::PDLMOD PACKAGE = $::PDLOBJ\n\n");
  766 }
  767 
  768 # inserts #line directives into source text. Use like this:
  769 #   ...
  770 #   FirstKey => ...,
  771 #   Code => pp_line_numbers(__LINE__, $x . $y . $c),
  772 #   OtherKey => ...
  773 sub pp_line_numbers {
  774   _pp_line_number_file((caller)[1], @_);
  775 }
  776 sub _pp_line_number_file {
  777     my ($filename, $line, $string) = @_;
  778     confess "pp_line_numbers called with undef" if !defined $string;
  779     # The line needs to be incremented by one for the bookkeeping to work
  780     $line++;
  781     $filename =~ s/\\/\\\\/g; # Escape backslashes
  782     my @to_return = "\nPDL_LINENO_START $line \"$filename\"\n";
  783     # Look for broadcastloops and loops and add # line directives
  784     foreach (split (/\n/, $string)) {
  785         # Always add the current line.
  786         push @to_return, "$_\n";
  787         # If we need to add a # line directive, do so after incrementing
  788         $line++;
  789         if (/%\{/ or /%}/) {
  790             push @to_return, "PDL_LINENO_END\n";
  791             push @to_return, "PDL_LINENO_START $line \"$filename\"\n";
  792         }
  793     }
  794     push @to_return, "PDL_LINENO_END\n";
  795     return join('', @to_return);
  796 }
  797 sub _pp_linenumber_fill {
  798   my ($file, $text) = @_;
  799   my (@stack, @to_return) = [$file, 1];
  800   foreach (split (/\n/, $text)) {
  801     $_->[1]++ for @stack;
  802     push(@to_return, $_), next if !/^(\s*)PDL_LINENO_(?:START (\S+) "(.*)"|(END))$/;
  803     my ($ci, $new_line, $new_file, $is_end) = ($1, $2, $3, $4);
  804     if ($is_end) {
  805       pop @stack;
  806       push @to_return, qq{$ci#line $stack[-1][1] "$stack[-1][0]"};
  807     } else {
  808       push @stack, [$new_file, $new_line-1];
  809       push @to_return, qq{$ci#line @{[$stack[-1][1]+1]} "$stack[-1][0]"};
  810     }
  811   }
  812   join '', map "$_\n", @to_return;
  813 }
  814 
  815 sub _file_same {
  816   my ($from_text, $to_file) = @_;
  817   require File::Map;
  818   File::Map::map_file(my $to_map, $to_file, '<');
  819   s/^[^\n]*#line[^\n]*?\n//gm for $from_text, (my $to_text = $to_map);
  820   $from_text eq $to_text;
  821 }
  822 sub _write_file {
  823   my ($file, $text) = @_;
  824   $text = _pp_linenumber_fill($file, $text);
  825   return if -f $file && _file_same($text, $file);
  826   open my $fh, '>', $file or confess "open $file: $!";
  827   binmode $fh; # to guarantee length will be same for same contents
  828   print $fh $text;
  829 }
  830 
  831 sub printxsc {
  832   (undef, my $file) = (shift, shift);
  833   my $text = join '',@_;
  834   if (defined $file) {
  835     (my $mod_underscores = $::PDLMOD) =~ s#::#_#g;
  836     $text = join '', sprintf($PDL::PP::header_c, $mod_underscores, $PP::boundscheck), $::PDLXSC_header//'', $text;
  837     _write_file($file, $text);
  838   } else {
  839     $::PDLXSC .= $text;
  840   }
  841 }
  842 
  843 sub pp_done {
  844         return if $PDL::PP::done; # do only once!
  845         $PDL::PP::done = 1;
  846     print "DONE!\n" if $::PP_VERBOSE;
  847     print "Inline running PDL::PP version $PDL::PP::VERSION...\n" if nopm();
  848         require PDL::Core::Dev;
  849         my $pdl_boot = PDL::Core::Dev::PDL_BOOT('PDL', $::PDLMOD);
  850         (my $mod_underscores = $::PDLMOD) =~ s#::#_#g;
  851         my $text = join '',
  852           sprintf($PDL::PP::header_c, $mod_underscores, $PP::boundscheck),
  853           $::PDLXSC//'',
  854           $PDL::PP::macros_xs, sprintf($PDL::PP::header_xs,
  855             $::PDLMOD, $::PDLOBJ, $::PDLXS,
  856             $pdl_boot, $::PDLXSBOOT//'', $PP::boundscheck,
  857           );
  858         _write_file("$::PDLPREF.xs", $text);
  859         return if nopm;
  860     $::PDLPMISA = "'".join("','",@::PDLPMISA)."'";
  861     $::PDLBEGIN = "BEGIN {\n$::PDLBEGIN\n}"
  862         unless $::PDLBEGIN =~ /^\s*$/;
  863         $::PDLMODVERSION //= '';
  864         $::FUNCSPOD = $::DOCUMENTED ? "\n\n=head1 FUNCTIONS\n\n=cut\n\n" : '';
  865         _write_file("$::PDLPREF.pm", join "\n\n", <<EOF, $::PDLBEGIN, $::PDLPM{Top}, $::FUNCSPOD, @::PDLPM{qw(Middle Bot)}, '# Exit with OK status', "1;\n");
  866 #
  867 # GENERATED WITH PDL::PP! Don't modify!
  868 #
  869 package $::PDLPACK;
  870 
  871 our \@EXPORT_OK = qw($::PDLPMROUT);
  872 our %EXPORT_TAGS = (Func=>\\\@EXPORT_OK);
  873 
  874 use PDL::Core$::PDLCOREIMPORT;
  875 use PDL::Exporter;
  876 use DynaLoader;
  877 
  878 $::PDL_IFBEGINWRAP[0]
  879    $::PDLVERSIONSET
  880    our \@ISA = ( $::PDLPMISA );
  881    push \@PDL::Core::PP, __PACKAGE__;
  882    bootstrap $::PDLMOD $::PDLMODVERSION;
  883 $::PDL_IFBEGINWRAP[-1]
  884 EOF
  885 } # end pp_done
  886 
  887 sub _pp_parsename {
  888   my ($name) = @_;
  889   # See if the 'name' is multiline, in which case we extract the
  890   # name and add the FullDoc field
  891   return ($name, undef) if $name !~ /\n/;
  892   my $fulldoc = $name;
  893   # See if the very first thing is a word. That is going to be the
  894   # name of the function under consideration
  895   if ($fulldoc =~ s/^(\w+)//) {
  896     $name = $1;
  897   } elsif ($fulldoc =~ /=head2 (\w+)/) {
  898     $name = $1;
  899   } else {
  900     croak('Unable to extract name');
  901   }
  902   ($name, $fulldoc);
  903 }
  904 
  905 sub pp_def {
  906     require PDL::Core::Dev;
  907     require PDL::Types;
  908     require PDL::PP::PdlParObj;
  909     require PDL::PP::Signature;
  910     require PDL::PP::Dims;
  911     require PDL::PP::CType;
  912     require PDL::PP::PDLCode;
  913     PDL::PP::load_deftable() if !$PDL::PP::deftbl;
  914     my($name,%obj) = @_;
  915     print "*** Entering pp_def for $name\n" if $::PP_VERBOSE;
  916     ($name, my $fulldoc) = _pp_parsename($name);
  917     $obj{FullDoc} = $fulldoc if defined $fulldoc;
  918     $obj{Name} = $name;
  919     croak("ERROR: pp_def=$name given empty GenericTypes!\n")
  920       if exists $obj{GenericTypes} and !@{ $obj{GenericTypes} || [] };
  921     foreach my $rule (@$PDL::PP::deftbl) {
  922         $rule->apply(\%obj);
  923     }
  924     print "Result of translate for $name:\n" . Dumper(\%obj) . "\n"
  925       if exists $obj{Dump} and $obj{Dump} and $::PP_VERBOSE;
  926 
  927     croak("ERROR: No FreeFunc for pp_def=$name!\n")
  928       unless exists $obj{FreeFunc};
  929 
  930     my $ctext = join("\n\n",grep $_, @obj{'StructDecl','RedoDimsFunc',
  931         'ReadDataFunc','WriteBackDataFunc',
  932         'FreeFunc',
  933         'VTableDef','RunFunc',
  934         }
  935         );
  936     if ($::PDLMULTI_C) {
  937       PDL::PP->printxsc(undef, <<EOF);
  938 extern pdl_transvtable $obj{VTableName};
  939 $obj{RunFuncHdr};
  940 EOF
  941       PDL::PP->printxsc("pp-$obj{Name}.c", $ctext);
  942     } else {
  943       PDL::PP->printxsc(undef, $ctext);
  944     }
  945     PDL::PP->printxs($obj{NewXSCode});
  946     pp_add_boot($obj{BootSetNewXS}) if $obj{BootSetNewXS};
  947     PDL::PP->pp_add_exported($name);
  948     PDL::PP::pp_addpm("\n".$obj{PdlDoc}."\n") if $obj{PdlDoc};
  949     PDL::PP::pp_addpm($obj{PMCode}) if defined $obj{PMCode};
  950     PDL::PP::pp_addpm($obj{PMFunc}."\n") if defined $obj{PMFunc};
  951 
  952     print "*** Leaving pp_def for $name\n" if $::PP_VERBOSE;
  953 }
  954 
  955 # marks this module as deprecated. This handles the user warnings, and adds a
  956 # notice into the documentation. Can take a {infavor => "newmodule"} option
  957 sub pp_deprecate_module
  958 {
  959   my $options;
  960   if( ref $_[0] eq 'HASH' )  { $options = shift;  }
  961   else                       { $options = { @_ }; }
  962 
  963   my $infavor;
  964 
  965   if( $options && ref $options eq 'HASH' && $options->{infavor} )
  966   {
  967     $infavor = $options->{infavor};
  968   }
  969 
  970   my $mod = $::PDLMOD;
  971   my $envvar = 'PDL_SUPPRESS_DEPRECATION_WARNING__' . uc $mod;
  972   $envvar =~ s/::/_/g;
  973 
  974   my $warning_main =
  975     "$mod is deprecated.";
  976   $warning_main .=
  977     " Please use $infavor instead." if $infavor;
  978 
  979   my $warning_suppression_runtime =
  980     "This module will be removed in the future; please update your code.\n" .
  981     "Set the environment variable $envvar\n" .
  982     "to suppress this warning\n";
  983 
  984   my $warning_suppression_pod =
  985     "A warning will be generated at runtime upon a C<use> of this module\n" .
  986     "This warning can be suppressed by setting the $envvar\n" .
  987     "environment variable\n";
  988 
  989   my $deprecation_notice = <<EOF ;
  990 XXX=head1 DEPRECATION NOTICE
  991 
  992 $warning_main
  993 $warning_suppression_pod
  994 
  995 XXX=cut
  996 
  997 EOF
  998   $deprecation_notice =~ s/^XXX=/=/gms;
  999   pp_addpm( {At => 'Top'}, $deprecation_notice );
 1000 
 1001   pp_addpm {At => 'Top'}, <<EOF;
 1002 warn \"$warning_main\n$warning_suppression_runtime\" unless \$ENV{$envvar};
 1003 EOF
 1004 
 1005 
 1006 }
 1007 
 1008 use Carp;
 1009 $SIG{__DIE__} = \&Carp::confess if $::PP_VERBOSE;
 1010 
 1011 $|=1;
 1012 
 1013 #
 1014 # This is ripped from xsubpp to ease the parsing of the typemap.
 1015 #
 1016 our $proto_re = "[" . quotemeta('\$%&*@;[]') . "]" ;
 1017 
 1018 sub ValidProtoString ($)
 1019 {
 1020     my($string) = @_ ;
 1021 
 1022     if ( $string =~ /^$proto_re+$/ ) {
 1023         return $string ;
 1024     }
 1025 
 1026     return 0 ;
 1027 }
 1028 
 1029 sub C_string ($)
 1030 {
 1031     my($string) = @_ ;
 1032 
 1033     $string =~ s[\\][\\\\]g ;
 1034     $string ;
 1035 }
 1036 
 1037 sub TrimWhitespace
 1038 {
 1039     $_[0] =~ s/^\s+|\s+$//go ;
 1040 }
 1041 sub TidyType
 1042 {
 1043     local ($_) = @_ ;
 1044 
 1045     # rationalise any '*' by joining them into bunches and removing whitespace
 1046     s#\s*(\*+)\s*#$1#g;
 1047     s#(\*+)# $1 #g ;
 1048 
 1049     # change multiple whitespace into a single space
 1050     s/\s+/ /g ;
 1051 
 1052     # trim leading & trailing whitespace
 1053     TrimWhitespace($_) ;
 1054 
 1055     $_ ;
 1056 }
 1057 
 1058 
 1059 
 1060 #------------------------------------------------------------------------------
 1061 # Typemap handling in PP.
 1062 #
 1063 # This subroutine does limited input typemap conversion.
 1064 # Given a variable name (to set), its type, and the source
 1065 # for the variable, returns the correct input typemap entry.
 1066 # Original version: D. Hunt 4/13/00  - Current version J. Brinchmann (06/05/05)
 1067 #
 1068 # The code loads the typemap from the Perl typemap using the loading logic of
 1069 # xsubpp. Do note that I  made the assumption that
 1070 # $Config{installprivlib}/ExtUtils was the right root directory for the search.
 1071 # This could break on some systems?
 1072 #
 1073 # Also I do _not_ parse the Typemap argument from ExtUtils::MakeMaker because I don't
 1074 # know how to catch it here! This would be good to fix! It does look for a file
 1075 # called typemap in the current directory however.
 1076 #
 1077 # The parsing of the typemap is mechanical and taken straight from xsubpp and
 1078 # the resulting hash lookup is then used to convert the input type to the
 1079 # necessary outputs (as seen in the old code above)
 1080 #
 1081 # JB 06/05/05
 1082 #
 1083 sub typemap {
 1084   my $oname  = shift;
 1085   my $type   = shift;
 1086   my $arg    = shift;
 1087 
 1088   # Modification to parse Perl's typemap here.
 1089   #
 1090   # The default search path for the typemap taken from xsubpp. It seems it is
 1091   # necessary to prepend the installprivlib/ExtUtils directory to find the typemap.
 1092   # It is not clear to me how this is to be done.
 1093   #
 1094   my ($typemap, $mode, $junk, $current, %input_expr,
 1095       %proto_letter, %output_expr, %type_kind);
 1096 
 1097   # according to MM_Unix 'privlibexp' is the right directory
 1098   #     seems to work even on OS X (where installprivlib breaks things)
 1099   my $_rootdir = $Config{privlibexp}.'/ExtUtils/';
 1100 
 1101   # First the system typemaps..
 1102   my @tm = ($_rootdir.'../../../../lib/ExtUtils/typemap',
 1103         $_rootdir.'../../../lib/ExtUtils/typemap',
 1104         $_rootdir.'../../lib/ExtUtils/typemap',
 1105         $_rootdir.'../../../typemap',
 1106         $_rootdir.'../../typemap', $_rootdir.'../typemap',
 1107         $_rootdir.'typemap');
 1108   # Note that the OUTPUT typemap is unlikely to be of use here, but I have kept
 1109   # the source code from xsubpp for tidiness.
 1110   push @tm, &PDL::Core::Dev::PDL_TYPEMAP, '../../typemap', '../typemap', 'typemap';
 1111   carp "**CRITICAL** PP found no typemap in $_rootdir/typemap; this will cause problems..."
 1112       unless my @typemaps = grep -f $_ && -T _, @tm;
 1113   foreach $typemap (@typemaps) {
 1114     open(my $fh, $typemap)
 1115       or warn("Warning: could not open typemap file '$typemap': $!\n"), next;
 1116     $mode = 'Typemap';
 1117     $junk = "" ;
 1118     $current = \$junk;
 1119     local $_; # else get "Modification of a read-only value attempted"
 1120     while (<$fh>) {
 1121     next if /^\s*#/;
 1122         my $line_no = $. + 1;
 1123     if (/^INPUT\s*$/)   { $mode = 'Input';   $current = \$junk;  next; }
 1124     if (/^OUTPUT\s*$/)  { $mode = 'Output';  $current = \$junk;  next; }
 1125     if (/^TYPEMAP\s*$/) { $mode = 'Typemap'; $current = \$junk;  next; }
 1126     if ($mode eq 'Typemap') {
 1127         chomp;
 1128         my $line = $_ ;
 1129             TrimWhitespace($_) ;
 1130         # skip blank lines and comment lines
 1131         next if /^$/ or /^#/ ;
 1132         my($t_type,$kind, $proto) = /^\s*(.*?\S)\s+(\S+)\s*($proto_re*)\s*$/ or
 1133         warn("Warning: File '$typemap' Line $. '$line' TYPEMAP entry needs 2 or 3 columns\n"), next;
 1134             $t_type = TidyType($t_type) ;
 1135         $type_kind{$t_type} = $kind ;
 1136             # prototype defaults to '$'
 1137             $proto = "\$" unless $proto ;
 1138             warn("Warning: File '$typemap' Line $. '$line' Invalid prototype '$proto'\n")
 1139                 unless ValidProtoString($proto) ;
 1140             $proto_letter{$t_type} = C_string($proto) ;
 1141     }
 1142     elsif (/^\s/) {
 1143         $$current .= $_;
 1144     }
 1145     elsif ($mode eq 'Input') {
 1146         s/\s+$//;
 1147         $input_expr{$_} = '';
 1148         $current = \$input_expr{$_};
 1149     }
 1150     else {
 1151         s/\s+$//;
 1152         $output_expr{$_} = '';
 1153         $current = \$output_expr{$_};
 1154     }
 1155     }
 1156     close $fh;
 1157   }
 1158 
 1159   #
 1160   # Do checks...
 1161   #
 1162   # First reconstruct the type declaration to look up in type_kind
 1163   my $full_type=TidyType($type->get_decl('', {VarArrays2Ptrs=>1})); # Skip the variable name
 1164   die "The type =$full_type= does not have a typemap entry!\n" unless exists($type_kind{$full_type});
 1165   my $typemap_kind = $type_kind{$full_type};
 1166   # Look up the conversion from the INPUT typemap. Note that we need to do some
 1167   # massaging of this.
 1168   my $input = $input_expr{$typemap_kind};
 1169   $input =~ s/^(.*?)=\s*//s; # Remove all before =
 1170   $input =~ s/\$(var|\{var\})/$oname/g;
 1171   $input =~ s/\$(arg|\{arg\})/$arg/g;
 1172   $input =~ s/\$(type|\{type\})/$full_type/g;
 1173   return ($input);
 1174 }
 1175 
 1176 sub make_xs_code {
 1177   my($xscode_before,$xscode_after,$str,
 1178     $xs_c_headers,
 1179     @bits) = @_;
 1180   my($boot,$prelude);
 1181   if($xs_c_headers) {
 1182     $prelude = join '' => ($xs_c_headers->[0], @bits, $xs_c_headers->[1]);
 1183     $boot = $xs_c_headers->[2];
 1184     $str .= "\n";
 1185   } else {
 1186     my $xscode = join '' => @bits;
 1187     $str .= " $xscode_before\n $xscode$xscode_after\n\n";
 1188   }
 1189   $str =~ s/(\s*\n)+/\n/g;
 1190   ($str,$boot,$prelude)
 1191 }
 1192 
 1193 sub indent($$) {
 1194     my ($text,$ind) = @_;
 1195     $text =~ s/^(.*)$/$ind$1/mg;
 1196     return $text;
 1197 }
 1198 
 1199 # This subroutine generates the XS code needed to call the perl 'initialize'
 1200 # routine in order to create new output PDLs
 1201 sub callPerlInit {
 1202     my $names = shift; # names of variables to initialize
 1203     my $ci    = shift; # current indenting
 1204     my $callcopy = $#_ > -1 ? shift : 0;
 1205     my $ret = '';
 1206     foreach my $name (@$names) {
 1207     my ($to_push, $method) = $callcopy
 1208         ? ('parent', 'copy')
 1209         : ('sv_2mortal(newSVpv(objname, 0))', 'initialize');
 1210     $ret .= PDL::PP::pp_line_numbers(__LINE__-1, "PDL_XS_PERLINIT($name, $to_push, $method)\n");
 1211     }
 1212     indent($ret,$ci);
 1213 } #sub callPerlInit()
 1214 
 1215 ###########################################################
 1216 # Name       : extract_signature_from_fulldoc
 1217 # Usage      : $sig = extract_signature_from_fulldoc($fulldoc)
 1218 # Purpose    : pull out the signature from the fulldoc string
 1219 # Returns    : whatever is in parentheses in the signature, or undef
 1220 # Parameters : $fulldoc
 1221 # Throws     : never
 1222 # Notes      : the signature must have the following form:
 1223 #            : 
 1224 #            : =for sig
 1225 #            : <blank>
 1226 #            :   Signature: (<signature can
 1227 #            :                be multiline>)
 1228 #            : <blank>
 1229 #            : 
 1230 #            : The two spaces before "Signature" are required, as are
 1231 #            : the parentheses.
 1232 sub extract_signature_from_fulldoc {
 1233     my $fulldoc = shift;
 1234     if ($fulldoc =~ /=for sig\n\n  Signature: \(([^\n]*)\n/g) {
 1235         # Extract the signature and remove the final parenthesis
 1236         my $sig = $1;
 1237         $sig .= $1 while $fulldoc =~ /\G\h+([^\n]*)\n/g;
 1238         $sig =~ s/\)\s*$//;
 1239         return $sig;
 1240     }
 1241     return;
 1242 }
 1243 
 1244 # function to be run by real pp_def so fake pp_def can do without other modules
 1245 sub load_deftable {
 1246 # Build the valid-types regex and valid Pars argument only once. These are
 1247 # also used in PDL::PP::PdlParObj, which is why they are globally available.
 1248 my $pars_re = $PDL::PP::PdlParObj::pars_re;
 1249 
 1250 # Set up the rules for translating the pp_def contents.
 1251 #
 1252 $PDL::PP::deftbl =
 1253   [
 1254    PDL::PP::Rule->new(
 1255       [qw(RedoDims EquivCPOffsCode HandleBad P2Child TwoWay)],
 1256       ["Identity"],
 1257       "something to do with dataflow between CHILD & PARENT, I think.",
 1258       sub {
 1259         (PDL::PP::pp_line_numbers(__LINE__-1, '
 1260           int i;
 1261           $SETNDIMS($PDL(PARENT)->ndims);
 1262           for(i=0; i<$PDL(CHILD)->ndims; i++) {
 1263             $PDL(CHILD)->dims[i] = $PDL(PARENT)->dims[i];
 1264           }
 1265           $SETDIMS();
 1266           $SETDELTABROADCASTIDS(0);
 1267           $PRIV(dims_redone) = 1;
 1268         '),
 1269         # NOTE: we use the same bit of code for all-good and bad data -
 1270         #  see the Code rule
 1271         # we can NOT assume that PARENT and CHILD have the same type,
 1272         # hence the version for bad code
 1273         #
 1274         # NOTE: we use the same code for 'good' and 'bad' cases - it's
 1275         # just that when we use it for 'bad' data, we have to change the
 1276         # definition of the EQUIVCPOFFS macro - see the Code rule
 1277         PDL::PP::pp_line_numbers(__LINE__,
 1278             'PDL_Indx i;
 1279              for(i=0; i<$PDL(CHILD)->nvals; i++)  {
 1280                 $EQUIVCPOFFS(i,i);
 1281              }'),
 1282         1, 1, 1);
 1283       }),
 1284 
 1285    # used as a flag for many of the routines
 1286    # ie should we bother with bad values for this routine?
 1287    # 1     - yes,
 1288    # 0     - no, maybe issue a warning
 1289    PDL::PP::Rule->new("BadFlag", \"HandleBad",
 1290               "Sets BadFlag based upon HandleBad key",
 1291               sub { $_[0] }),
 1292 
 1293    ####################
 1294    # FullDoc Handling #
 1295    ####################
 1296 
 1297    # Error processing: does FullDoc contain BadDoc, yet BadDoc specified?
 1298    PDL::PP::Rule::Croak->new(['FullDoc', 'BadDoc'],
 1299        'Cannot have both FullDoc and BadDoc defined'),
 1300    PDL::PP::Rule::Croak->new(['FullDoc', 'Doc'],
 1301        'Cannot have both FullDoc and Doc defined'),
 1302    # Note: no error processing on Pars; it's OK for the docs to gloss over
 1303    # the details.
 1304 
 1305    # Add the Pars section based on the signature of the FullDoc if the Pars
 1306    # section doesn't already exist
 1307    PDL::PP::Rule->new('Pars', 'FullDoc',
 1308       'Sets the Pars from the FullDoc if Pars is not explicitly specified',
 1309       # Purpose    : extract the Pars from the signature from the fulldoc string,
 1310       #            : the part of the signature that specifies the ndarrays
 1311       # Returns    : a string appropriate for the Pars key
 1312       # Parameters : $fulldoc
 1313       # Throws     : if there is no signature 
 1314       #            : if there is no extractable Pars section
 1315       #            : if some PDL arguments come after the OtherPars arguments start
 1316       # Notes      : This is meant to be used directly in a Rule. Therefore, it
 1317       #            : is only called if the Pars key does not yet exist, so if it
 1318       #            : is not possible to extract the Pars section, it dies.
 1319       sub {
 1320         my $fulldoc = shift;
 1321         # Get the signature or die
 1322         my $sig = extract_signature_from_fulldoc($fulldoc)
 1323           or confess('No Pars specified and none could be extracted from FullDoc');
 1324         # Everything is semicolon-delimited
 1325         my @args = split /\s*;\s*/, $sig;
 1326         my @pars;
 1327         my $switched_to_other_pars = 0;
 1328         for my $arg (@args) {
 1329           confess('All PDL args must come before other pars in FullDoc signature')
 1330             if $switched_to_other_pars and $arg =~ $pars_re;
 1331           if ($arg =~ $pars_re) {
 1332             push @pars, $arg;
 1333           } else {
 1334             $switched_to_other_pars = 1;
 1335           }
 1336         }
 1337         # Make sure there's something there
 1338         confess('FullDoc signature contains no PDL arguments') if @pars == 0;
 1339         # All done!
 1340         return join('; ', @pars);
 1341       }
 1342    ),
 1343    PDL::PP::Rule->new('OtherPars', 'FullDoc',
 1344       'Sets the OtherPars from the FullDoc if OtherPars is not explicitly specified',
 1345       # Purpose    : extract the OtherPars from the signature from the fulldoc
 1346       #            : string, the part of the signature that specifies non-ndarray
 1347       #            : arguments
 1348       # Returns    : a string appropriate for the OtherPars key
 1349       # Parameters : $fulldoc
 1350       # Throws     : if some OtherPars arguments come before the last PDL argument
 1351       # Notes      : This is meant to be used directly in a Rule. Therefore, it
 1352       #            : is only called if the OtherPars key does not yet exist.
 1353       sub {
 1354         my $fulldoc = shift;
 1355         # Get the signature or do not set
 1356         my $sig = extract_signature_from_fulldoc($fulldoc)
 1357                 or return 'DO NOT SET!!';
 1358         # Everything is semicolon-delimited
 1359         my @args = split /\s*;\s*/, $sig;
 1360         my @otherpars;
 1361         for my $arg (@args) {
 1362           confess('All PDL args must come before other pars in FullDoc signature')
 1363             if @otherpars > 0 and $arg =~ $pars_re;
 1364           if ($arg !~ $pars_re) {
 1365             push @otherpars, $arg;
 1366           }
 1367         }
 1368         # All done!
 1369         return 'DO NOT SET!!'if @otherpars == 0;
 1370         return join('; ', @otherpars);
 1371       }
 1372    ),
 1373 
 1374    ################################
 1375    # Other Documentation Handling #
 1376    ################################
 1377    
 1378    # no docs by default
 1379    PDL::PP::Rule::Returns->new("Doc", [], 'Sets the default doc string',
 1380     "\n=for ref\n\ninfo not available\n"),
 1381    
 1382    # try and automate the docs
 1383    # could be really clever and include the sig to see about
 1384    # input/output params, for instance
 1385    
 1386    PDL::PP::Rule->new("BadDoc", ["BadFlag","Name",\"CopyBadStatusCode"],
 1387               'Sets the default documentation for handling of bad values',
 1388       sub {
 1389          my ( $bf, $name, $code ) = @_;
 1390          my $str;
 1391          if ( not defined($bf) ) {
 1392             $str = "$name does not process bad values.\n";
 1393          } elsif ( $bf ) {
 1394             $str = "$name processes bad values.\n";
 1395          } else {
 1396             $str = "$name ignores the bad-value flag of the input ndarrays.\n";
 1397          }
 1398          if ( not defined($code) ) {
 1399             $str .= "It will set the bad-value flag of all output ndarrays if " .
 1400             "the flag is set for any of the input ndarrays.\n";
 1401          } elsif (  $code eq '' ) {
 1402             $str .= "The output ndarrays will NOT have their bad-value flag set.\n";
 1403          } else {
 1404             $str .= "The state of the bad-value flag of the output ndarrays is unknown.\n";
 1405          }
 1406       }
 1407    ),
 1408 
 1409    # Default: no otherpars
 1410    PDL::PP::Rule::Returns::EmptyString->new("OtherPars"),
 1411 
 1412    # the docs
 1413    PDL::PP::Rule->new("PdlDoc", "FullDoc", sub {
 1414          my $fulldoc = shift;
 1415          # Append a final cut if it doesn't exist due to heredoc shinanigans
 1416          $fulldoc .= "\n\n=cut\n" unless $fulldoc =~ /\n=cut\n*$/;
 1417          # Make sure the =head1 FUNCTIONS section gets added
 1418          $::DOCUMENTED++;
 1419          return $fulldoc;
 1420       }
 1421    ),
 1422    PDL::PP::Rule->new("PdlDoc", ["Name",\"Pars","OtherPars","Doc",\"BadDoc"],
 1423       sub {
 1424         my ($name,$pars,$otherpars,$doc,$baddoc) = @_;
 1425         return '' if !defined $doc # Allow explicit non-doc using Doc=>undef
 1426             or $doc =~ /^\s*internal\s*$/i;
 1427         # If the doc string is one line let's have two for the
 1428         # reference card information as well
 1429         $doc = "=for ref\n\n".$doc if $doc !~ /\n/;
 1430         $::DOCUMENTED++;
 1431         $pars = "P(); C()" unless $pars;
 1432         # Strip leading whitespace and trailing semicolons and whitespace
 1433         $pars =~ s/^\s*(.+[^;])[;\s]*$/$1/;
 1434         $otherpars =~ s/^\s*(.+[^;])[;\s]*$/$1/ if $otherpars;
 1435         my $sig = "$pars".( $otherpars ? "; $otherpars" : "");
 1436         $doc =~ s/\n(=cut\s*\n)+(\s*\n)*$/\n/m; # Strip extra =cut's
 1437         if ( defined $baddoc ) {
 1438                 # Strip leading newlines and any =cut markings
 1439             $baddoc =~ s/\n(=cut\s*\n)+(\s*\n)*$/\n/m;
 1440             $baddoc =~ s/^\n+//;
 1441             $baddoc = "=for bad\n\n$baddoc";
 1442         }
 1443         my $baddoc_function_pod = <<"EOD" ;
 1444 
 1445 XXX=head2 $name
 1446 
 1447 XXX=for sig
 1448 
 1449   Signature: ($sig)
 1450 
 1451 $doc
 1452 
 1453 $baddoc
 1454 
 1455 XXX=cut
 1456 
 1457 EOD
 1458         $baddoc_function_pod =~ s/^XXX=/=/gms;
 1459         return $baddoc_function_pod;
 1460       }
 1461    ),
 1462 
 1463    ##################
 1464    # Done with Docs #
 1465    ##################
 1466 
 1467    # Notes
 1468    # Suffix 'NS' means, "Needs Substitution". In other words, the string
 1469    # associated with a key that has the suffix "NS" must be run through a
 1470    # Substitute
 1471    # The substituted version should then replace "NS" with "Subd"
 1472    # So: FreeCodeNS -> FreeCodeSubd
 1473 
 1474    PDL::PP::Rule::Returns->new("StructName", "__privtrans"),
 1475    PDL::PP::Rule::Returns->new("ParamStructName", "__params"),
 1476 
 1477    PDL::PP::Rule->new("HaveBroadcasting","HaveThreading", sub {@_}), # compat
 1478    PDL::PP::Rule::Croak->new([qw(P2Child GenericTypes)],
 1479        'Cannot have both P2Child and GenericTypes defined'),
 1480    PDL::PP::Rule->new([qw(Pars HaveBroadcasting CallCopy GenericTypes DefaultFlow AllFuncHeader RedoDimsFuncHeader)],
 1481               ["P2Child","Name","StructName"],
 1482       sub {
 1483         my (undef,$name,$sname) = @_;
 1484         ("PARENT(); [oca]CHILD();",0,0,[PDL::Types::ppdefs_all()],1,
 1485           pp_line_numbers(__LINE__-1,"\tpdl *__it = $sname->pdls[1];\n\tpdl *__parent = $sname->pdls[0];\n"),
 1486           pp_line_numbers(__LINE__-1,"PDL->hdr_childcopy($sname);\n$sname->dims_redone = 1;\n"),
 1487         );
 1488       }),
 1489 
 1490 # Question: where is ppdefs defined?
 1491 # Answer: Core/Types.pm
 1492 #
 1493    PDL::PP::Rule->new("GenericTypes", [],
 1494        'Sets GenericTypes flag to all real types known to PDL::Types',
 1495        sub {[PDL::Types::ppdefs()]}),
 1496 
 1497    PDL::PP::Rule->new("ExtraGenericSwitches", "FTypes",
 1498        'Makes ExtraGenericSwitches identical to FTypes if the latter exists and the former does not',
 1499        sub {return $_[0]}),
 1500    PDL::PP::Rule::Returns->new("ExtraGenericSwitches", [],
 1501        'Sets ExtraGenericSwitches to an empty hash if it does not already exist', {}),
 1502 
 1503    PDL::PP::Rule::InsertName->new("VTableName", 'pdl_${name}_vtable'),
 1504 
 1505    PDL::PP::Rule::Returns->new("Priv", "AffinePriv", 'PDL_Indx incs[$PDL(CHILD)->ndims];PDL_Indx offs; '),
 1506    PDL::PP::Rule::Returns->new("IsAffineFlag", "AffinePriv", "PDL_ITRANS_ISAFFINE"),
 1507    PDL::PP::Rule::Returns::Zero->new("IsAffineFlag"),
 1508    PDL::PP::Rule::Returns->new("TwoWayFlag", "TwoWay", "PDL_ITRANS_TWOWAY"),
 1509    PDL::PP::Rule::Returns::Zero->new("TwoWayFlag"),
 1510    PDL::PP::Rule::Returns->new("DefaultFlowFlag", "DefaultFlow", "PDL_ITRANS_DO_DATAFLOW_ANY"),
 1511    PDL::PP::Rule::Returns::Zero->new("DefaultFlowFlag"),
 1512 
 1513    PDL::PP::Rule->new("RedoDims", ["EquivPDimExpr",\"EquivDimCheck"],
 1514       sub {
 1515         my($pdimexpr,$dimcheck) = @_;
 1516         $pdimexpr =~ s/\$CDIM\b/i/g;
 1517         PDL::PP::pp_line_numbers(__LINE__-1, '
 1518           int i,cor;
 1519           '.$dimcheck.'
 1520           $SETNDIMS($PDL(PARENT)->ndims);
 1521           $DOPRIVALLOC();
 1522           $PRIV(offs) = 0;
 1523           for(i=0; i<$PDL(CHILD)->ndims; i++) {
 1524             cor = '.$pdimexpr.';
 1525             $PDL(CHILD)->dims[i] = $PDL(PARENT)->dims[cor];
 1526             $PRIV(incs[i]) = $PDL(PARENT)->dimincs[cor];
 1527           }
 1528           $SETDIMS();
 1529           $SETDELTABROADCASTIDS(0);
 1530           $PRIV(dims_redone) = 1;
 1531         ');
 1532       }),
 1533 
 1534    PDL::PP::Rule->new("Code", ["EquivCPOffsCode","BadFlag"],
 1535       "create Code from EquivCPOffsCode",
 1536       # NOTE: EQUIVCPOFFS and EQUIVCPTRUNC both suffer from the macro-block
 1537       # wart of C preprocessing.  They look like statements but sometimes
 1538       # process into blocks, so if/then/else constructs can get broken.
 1539       # Either (1) use blocks for if/then/else, or (2) get excited and
 1540       # use the "do {BLOCK} while(0)" block-to-statement conversion construct
 1541       # in the substitution.  I'm too Lazy. --CED 27-Jan-2003
 1542       sub {
 1543         my $good  = shift;
 1544         my $bflag = shift;
 1545         my $bad = $good;
 1546         # parse 'good' code
 1547         $good =~ s/\$EQUIVCPOFFS\(([^()]+),([^()]+)\)/\$PP(CHILD)[$1] = \$PP(PARENT)[$2]/g;
 1548         $good =~ s/\$EQUIVCPTRUNC\(([^()]+),([^()]+),([^()]+)\)/\$PP(CHILD)[$1] = ($3) ? 0 : \$PP(PARENT)[$2]/g;
 1549         return $good if !$bflag;
 1550         # parse 'bad' code
 1551         $bad  =~ s/\$EQUIVCPOFFS\(([^()]+),([^()]+)\)/if( \$PPISBAD(PARENT,[$2]) ) { \$PPSETBAD(CHILD,[$1]); } else { \$PP(CHILD)[$1] = \$PP(PARENT)[$2]; }/g;
 1552         $bad =~ s/\$EQUIVCPTRUNC\(([^()]+),([^()]+),([^()]+)\)/ if( ($3) || \$PPISBAD(PARENT,[$2]) ) { \$PPSETBAD(CHILD,[$1]); } else {\$PP(CHILD)[$1] = \$PP(PARENT)[$2]; }/g;
 1553         PDL::PP::pp_line_numbers(__LINE__-1, 'if ( $PRIV(bvalflag) ) { ' . $bad . ' } else { ' . $good . '}');
 1554       }),
 1555 
 1556    PDL::PP::Rule->new("BackCode", ["EquivCPOffsCode","BadFlag"],
 1557       "create BackCode from EquivCPOffsCode",
 1558       # If there is an EquivCPOffsCode and:
 1559       #    no bad-value support ==> use that
 1560       #    bad value support ==> write a bit of code that does
 1561       #      if ( $PRIV(bvalflag) ) { bad-EquivCPOffsCode }
 1562       #      else                   { good-EquivCPOffsCode }
 1563       #
 1564       #  Note: since EquivCPOffsCode doesn't (or I haven't seen any that
 1565       #  do) use 'loop %{' or 'broadcastloop %{', we can't rely on
 1566       #  PDLCode to automatically write code like above, hence the
 1567       #  explicit definition here.
 1568       #
 1569       #  Note: I *assume* that bad-Equiv..Code == good-Equiv..Code *EXCEPT*
 1570       #        that we re-define the meaning of the $EQUIVCPOFFS macro to
 1571       #        check for bad values when copying things over.
 1572       #        This means having to write less code.
 1573       #
 1574       # Since PARENT & CHILD need NOT be the same type we cannot just copy
 1575       # values from one to the other - we have to check for the presence
 1576       # of bad values, hence the expansion for the $bad code
 1577       #
 1578       # Some operators (notably range) also have an out-of-range flag; they use
 1579       # the macro EQUIVCPTRUNC instead of EQUIVCPOFFS.
 1580       # $EQUIVCPTRUNC does the same as EQUIVCPOFFS but accepts a
 1581       # child-out-of-bounds flag.  If the out-of-bounds flag is set, the
 1582       # forward code puts BAD/0 into the child, and reverse code refrains
 1583       # from copying.
 1584       #                    --CED 27-Jan-2003
 1585       #
 1586       # this just reverses PARENT & CHILD in the expansion of
 1587       # the $EQUIVCPOFFS macro (ie compared to Code from EquivCPOffsCode)
 1588       sub {
 1589         my ($good, $bflag) = @_;
 1590         my $bad  = $good;
 1591         # parse 'good' code
 1592         $good =~ s/\$EQUIVCPOFFS\(([^()]+),([^()]+)\)/\$PP(PARENT)[$2] = \$PP(CHILD)[$1]/g;
 1593         $good =~ s/\$EQUIVCPTRUNC\(([^()]+),([^()]+),([^()]+)\)/if(!($3)) \$PP(PARENT)[$2] = \$PP(CHILD)[$1] /g;
 1594         return $good if !$bflag;
 1595         # parse 'bad' code
 1596         $bad  =~ s/\$EQUIVCPOFFS\(([^()]+),([^()]+)\)/if( \$PPISBAD(CHILD,[$1]) ) { \$PPSETBAD(PARENT,[$2]); } else { \$PP(PARENT)[$2] = \$PP(CHILD)[$1]; }/g;
 1597         $bad =~ s/\$EQUIVCPTRUNC\(([^()]+),([^()]+),([^()]+)\)/if(!($3)) { if( \$PPISBAD(CHILD,[$1]) ) { \$PPSETBAD(PARENT,[$2]); } else { \$PP(PARENT)[$2] = \$PP(CHILD)[$1]; } } /g;
 1598         PDL::PP::pp_line_numbers(__LINE__-1, 'if ( $PRIV(bvalflag) ) { ' . $bad . ' } else { ' . $good . '}');
 1599       }),
 1600 
 1601    PDL::PP::Rule::Returns::Zero->new("Affine_Ok", "EquivCPOffsCode"),
 1602    PDL::PP::Rule::Returns::One->new("Affine_Ok"),
 1603 
 1604    PDL::PP::Rule::Returns::NULL->new("ReadDataFuncName", "AffinePriv"),
 1605    PDL::PP::Rule::Returns::NULL->new("WriteBackDataFuncName", "AffinePriv"),
 1606 
 1607    PDL::PP::Rule::InsertName->new("NewXSName", '_${name}_int'),
 1608 
 1609    PDL::PP::Rule::Returns::One->new("HaveBroadcasting"),
 1610 
 1611    PDL::PP::Rule::Returns::EmptyString->new("Priv"),
 1612    PDL::PP::Rule->new("PrivObj", ["BadFlag","Priv"],
 1613       sub { PDL::PP::Signature->new('', @_) }),
 1614 
 1615 # Parameters in the 'a(x,y); [o]b(y)' format, with
 1616 # fixed nos of real, unbroadcast-over dims.
 1617 # Also "Other pars", the parameters which are usually not pdls.
 1618    PDL::PP::Rule->new("SignatureObj", ["Pars","BadFlag","OtherPars"],
 1619       sub { PDL::PP::Signature->new(@_) }),
 1620 
 1621 # Compiled representations i.e. what the RunFunc function leaves
 1622 # in the params structure. By default, copies of the parameters
 1623 # but in many cases (e.g. slice) a benefit can be obtained
 1624 # by parsing the string in that function.
 1625 # If the user wishes to specify their own MakeComp code and Comp content,
 1626 # The next definitions allow this.
 1627    PDL::PP::Rule->new("CompObj", ["BadFlag","Comp"],
 1628       sub { PDL::PP::Signature->new('', @_) }),
 1629    PDL::PP::Rule->new("CompObj", "SignatureObj", sub { @_ }), # provide default
 1630    PDL::PP::Rule->new("CompStructOther", "SignatureObj", sub {$_[0]->getcomp}),
 1631    PDL::PP::Rule->new("CompStructComp", [qw(CompObj Comp)], sub {$_[0]->getcomp}),
 1632    PDL::PP::Rule->new("CompStruct", ["CompStructOther", \"CompStructComp"], sub { join "\n", grep $_, @_ }),
 1633 
 1634  # Set CallCopy flag for simple functions (2-arg with 0-dim signatures)
 1635  #   This will copy the $object->copy method, instead of initialize
 1636  #   for PDL-subclassed objects
 1637  #
 1638    PDL::PP::Rule->new("CallCopy", ["SignatureObj", "Name"],
 1639       sub {
 1640       my ($sig, $Name, $hasp2c) = @_;
 1641       my $noDimmedArgs = $sig->dims_count;
 1642       my $noArgs = @{$sig->names};
 1643       # Check for 2-arg function with 0-dim signatures
 1644       return 0 if !($noDimmedArgs == 0 and $noArgs == 2);
 1645       # Check to see if output arg is _not_ explicitly typed:
 1646       !$sig->objs->{$sig->names->[1]}{FlagTyped};
 1647       }),
 1648 
 1649    PDL::PP::Rule->new(["InplaceCode","InplaceCheck"], ["SignatureObj","Inplace"],
 1650               'Insert code (just after HdrCode) to ensure the routine can be done inplace',
 1651       # insert code, after the autogenerated xs argument processing code
 1652       # produced by VarArgsXSHdr and AFTER any in HdrCode
 1653       # - this code flags the routine as working inplace,
 1654       #
 1655       # Inplace can be supplied several values
 1656       #   => 1
 1657       #     assumes fn has an input and output ndarray (eg 'a(); [o] b();')
 1658       #   => [ 'a' ]
 1659       #     assumes several input ndarrays in sig, so 'a' labels which
 1660       #     one is to be marked inplace
 1661       #   => [ 'a', 'b' ]
 1662       #     input ndarray is a(), output ndarray is 'b'
 1663       sub {
 1664         my ( $sig, $arg ) = @_;
 1665         return '' if !$arg;
 1666         confess "Inplace array-ref (@$arg) > 2 elements" if ref($arg) eq "ARRAY" and @$arg > 2;
 1667         # find input and output ndarrays
 1668         my @out = $sig->names_out;
 1669         my @in = $sig->names_in;
 1670         my $in = @in == 1 ? $in[0] : undef;
 1671         my $out = @out == 1 ? $out[0] : undef;
 1672         if ( ref($arg) eq "ARRAY" and @$arg) {
 1673           $in = $$arg[0];
 1674           $out = $$arg[1] if @$arg > 1;
 1675         }
 1676         confess "ERROR: Inplace does not know name of input ndarray\n"
 1677             unless defined $in;
 1678         confess "ERROR: Inplace does not know name of output ndarray\n"
 1679             unless defined $out;
 1680         (
 1681          PDL::PP::pp_line_numbers(__LINE__-1, "PDL_XS_INPLACE($in, $out)\n"),
 1682          PDL::PP::pp_line_numbers(__LINE__-1, "PDL_XS_INPLACE_CHECK($in)\n"),
 1683         );
 1684       }),
 1685    PDL::PP::Rule::Returns::EmptyString->new("InplaceCode", []),
 1686    PDL::PP::Rule::Returns::EmptyString->new("InplaceCheck", []),
 1687 
 1688    PDL::PP::Rule::Returns::EmptyString->new("HdrCode", [],
 1689                         'Code that will be inserted at the end of the autogenerated xs argument processing code VargArgsXSHdr'),
 1690 
 1691    PDL::PP::Rule->new("VarArgsXSHdr",
 1692       ["Name","SignatureObj",
 1693        "HdrCode","InplaceCode","InplaceCheck",\"CallCopy",\"OtherParsDefaults"],
 1694       'XS code to process input arguments based on supplied Pars argument to pp_def; not done if GlobalNew or PMCode supplied',
 1695       sub {
 1696         my($name,$sig,
 1697            $hdrcode,$inplacecode,$inplacecheck,$callcopy,$defaults) = @_;
 1698         my $optypes = $sig->otherobjs(1);
 1699         my @args = $sig->alldecls(0, 1);
 1700         my %other  = map +($_ => exists($$optypes{$_})), @args;
 1701         if (keys %{ $defaults ||= {} } < keys %other) {
 1702           my $default_seen = '';
 1703           for (@args) {
 1704             $default_seen = $_ if exists $defaults->{$_};
 1705             confess "got default-less arg '$_' after default-ful arg '$default_seen'"
 1706               if $default_seen and !exists $defaults->{$_};
 1707           }
 1708         }
 1709         my $ci = '  ';  # current indenting
 1710         my $pars = join "\n",map "$ci$_ = 0;", $sig->alldecls(1, 0);
 1711         my %out = map +($_=>1), $sig->names_out_nca;
 1712         my %outca = map +($_=>1), $sig->names_oca;
 1713         my %tmp = map +($_=>1), $sig->names_tmp;
 1714         # remember, otherpars *are* input vars
 1715         my $nout   = grep $_, values %out;
 1716         my $noutca = grep $_, values %outca;
 1717         my $nother = grep $_, values %other;
 1718         my $ntmp   = grep $_, values %tmp;
 1719         my $ntot   = @args;
 1720         my $nmaxonstack = $ntot - $noutca;
 1721         my $nin    = $ntot - ($nout + $noutca);
 1722         my $ninout = $nin + $nout;
 1723         my $nallout = $nout + $noutca;
 1724         my $ndefault = keys %$defaults;
 1725         my $usageargs = join ",", map exists $defaults->{$_} ? "$_=$defaults->{$_}" : $_, grep !$tmp{$_}, @args;
 1726         # Generate declarations for SV * variables corresponding to pdl * output variables.
 1727         # These are used in creating output variables.  One variable (ex: SV * outvar1_SV;)
 1728         # is needed for each output and output create always argument
 1729         my $svdecls = join "\n", map "${ci}SV *${_}_SV = NULL;", $sig->names_out;
 1730         my $clause_inputs = ''; my %already_read; my $cnt = 0;
 1731         foreach my $x (@args) {
 1732             last if $out{$x} || $outca{$x} || $other{$x};
 1733             $already_read{$x} = 1;
 1734             $clause_inputs .= "$ci$x = PDL->SvPDLV(ST($cnt));\n";
 1735             $cnt++;
 1736         }
 1737         my @create = ();  # The names of variables which need to be created by calling
 1738                           # the 'initialize' perl routine from the correct package.
 1739         $ci = '    ';  # Current indenting
 1740         # clause for reading in all variables
 1741         my $clause1 = $inplacecheck; $cnt = 0;
 1742         foreach my $x (@args) {
 1743             if ($other{$x}) {  # other par
 1744                 $clause1 .= "$ci$x = " . typemap($x, $$optypes{$x}, "ST($cnt)") . ";\n";
 1745                 $cnt++;
 1746             } elsif ($outca{$x}) {
 1747                 push (@create, $x);
 1748             } else {
 1749                 $clause1 .= "$ci$x = PDL->SvPDLV(".
 1750           ($out{$x} ? "${x}_SV = " : '').
 1751           "ST($cnt));\n" if !$already_read{$x};
 1752                 $cnt++;
 1753             }
 1754         }
 1755         # Add code for creating output variables via call to 'initialize' perl routine
 1756         $clause1 .= callPerlInit (\@create, $ci, $callcopy);
 1757         @create = ();
 1758         # clause for reading in input and creating output vars
 1759         my $clause3 = '';
 1760         my $defaults_rawcond = $ndefault ? "items == ($nin-$ndefault)" : '';
 1761         $cnt = 0;
 1762         foreach my $x (@args) {
 1763             if ($other{$x}) {
 1764                 my $setter = typemap($x, $$optypes{$x}, "ST($cnt)");
 1765                 $clause3 .= "$ci$x = " . (exists $defaults->{$x}
 1766                   ? "($defaults_rawcond) ? ($defaults->{$x}) : ($setter)"
 1767                   : $setter) . ";\n";
 1768                 $cnt++;
 1769             } elsif ($out{$x} || $outca{$x}) {
 1770                 push (@create, $x);
 1771             } else {
 1772                 $clause3 .= "$ci$x = PDL->SvPDLV(ST($cnt));\n" if !$already_read{$x};
 1773                 $cnt++;
 1774             }
 1775         }
 1776         # Add code for creating output variables via call to 'initialize' perl routine
 1777         $clause3 .= callPerlInit (\@create, $ci, $callcopy); @create = ();
 1778         my $defaults_cond = $ndefault ? " || $defaults_rawcond" : '';
 1779         $clause3 = <<EOF . $clause3;
 1780   else if (items == $nin$defaults_cond) { PDL_COMMENT("only input variables on stack, create outputs")
 1781     nreturn = $nallout;
 1782 EOF
 1783         $clause3 = '' if $nmaxonstack == $nin;
 1784         my $clause3_coda = $clause3 ? '  }' : '';
 1785         PDL::PP::pp_line_numbers(__LINE__, <<END);
 1786 
 1787 void
 1788 $name(...)
 1789  PREINIT:
 1790   PDL_XS_PREAMBLE
 1791 $svdecls
 1792 $pars
 1793  PPCODE:
 1794   if (items != $nmaxonstack && !(items == $nin$defaults_cond) && items != $ninout)
 1795     croak (\"Usage:  PDL::$name($usageargs) (you may leave output variables out of list)\");
 1796   PDL_XS_PACKAGEGET
 1797 $clause_inputs
 1798   if (items == $nmaxonstack) { PDL_COMMENT("all variables on stack, read in output vars")
 1799     nreturn = $noutca;
 1800 $clause1
 1801   }
 1802 $clause3$clause3_coda
 1803 $hdrcode
 1804 $inplacecode
 1805 END
 1806       }),
 1807 
 1808    # globalnew implies internal usage, not XS
 1809    PDL::PP::Rule::Returns->new("VarArgsXSReturn","GlobalNew",undef),
 1810    PDL::PP::Rule->new("VarArgsXSReturn",
 1811       ["SignatureObj"],
 1812       "Generate XS trailer to return output variables or leave them as modified input variables",
 1813       sub {
 1814         my @outs = $_[0]->names_out; # names of output variables (in calling order)
 1815         my $clause1 = join ';', map "ST($_) = $outs[$_]_SV", 0 .. $#outs;
 1816         PDL::PP::pp_line_numbers(__LINE__-1, "PDL_XS_RETURN($clause1)");
 1817       }),
 1818 
 1819    PDL::PP::Rule->new("NewXSHdr", ["NewXSName","SignatureObj"],
 1820       sub {
 1821         my($name,$sig) = @_;
 1822         my $shortpars = join ',', $sig->alldecls(0, 1);
 1823         my $longpars = join "\n", map "\t$_", $sig->alldecls(1, 1);
 1824         return<<END;
 1825 
 1826 void
 1827 $name($shortpars)
 1828 $longpars
 1829 END
 1830       }),
 1831    PDL::PP::Rule::InsertName->new("RunFuncName", 'pdl_${name}_run'),
 1832    PDL::PP::Rule->new("NewXSCHdrs", ["RunFuncName","SignatureObj","GlobalNew"],
 1833       sub {
 1834         my($name,$sig,$gname) = @_;
 1835         my $longpars = join ",", $sig->alldecls(1, 0);
 1836         my $opening = 'pdl_error PDL_err = {0, NULL, 0};';
 1837         my $closing = 'return PDL_err;';
 1838         return ["pdl_error $name($longpars) {$opening","$closing}",
 1839                 "PDL->$gname = $name;"];
 1840       }),
 1841    PDL::PP::Rule->new(["RunFuncCall","RunFuncHdr"],["RunFuncName","SignatureObj"], sub {
 1842         my ($func_name,$sig) = @_;
 1843         my $shortpars = join ',', $sig->alldecls(0, 0);
 1844         my $longpars = join ",", $sig->alldecls(1, 0);
 1845         (PDL::PP::pp_line_numbers(__LINE__-1, "PDL->barf_if_error($func_name($shortpars));"),
 1846           "pdl_error $func_name($longpars)");
 1847       }),
 1848 
 1849    PDL::PP::Rule->new("NewXSMakeNow", ["SignatureObj"],
 1850       sub { join '', map PDL::PP::pp_line_numbers(__LINE__-1, "$_ = PDL->make_now($_);\n"), @{ $_[0]->names } }),
 1851    PDL::PP::Rule->new("IgnoreTypesOf", ["FTypes","SignatureObj"], sub {
 1852       my ($ftypes, $sig) = @_;
 1853       my ($pnames, $pobjs) = ($sig->names_sorted, $sig->objs);
 1854       $_->{FlagIgnore} = 1 for grep $ftypes->{$_->{Name}}, @$pobjs{@$pnames};
 1855       +{map +($_,1), keys %$ftypes};
 1856    }),
 1857    PDL::PP::Rule::Returns->new("IgnoreTypesOf", {}),
 1858 
 1859    PDL::PP::Rule->new("NewXSTypeCoerceNS", ["StructName"],
 1860       sub {
 1861         PDL::PP::pp_line_numbers(__LINE__, <<EOF);
 1862 PDL_RETERROR(PDL_err, PDL->type_coerce($_[0]));
 1863 EOF
 1864       }),
 1865    PDL::PP::Rule::Substitute->new("NewXSTypeCoerceSubd", "NewXSTypeCoerceNS"),
 1866 
 1867    PDL::PP::Rule->new("NewXSSetTransPDLs", ["SignatureObj","StructName"], sub {
 1868       my($sig,$trans) = @_;
 1869       join '',
 1870         map PDL::PP::pp_line_numbers(__LINE__, "$trans->pdls[$_->[0]] = $_->[2];\n"),
 1871         grep !$_->[1], $sig->names_sorted_tuples;
 1872    }),
 1873 
 1874    PDL::PP::Rule->new("NewXSExtractTransPDLs", ["SignatureObj","StructName"], sub {
 1875       my($sig,$trans) = @_;
 1876       join '',
 1877         map PDL::PP::pp_line_numbers(__LINE__, "$_->[2] = $trans->pdls[$_->[0]];\n"),
 1878         grep !$_->[1], $sig->names_sorted_tuples;
 1879    }),
 1880 
 1881    PDL::PP::Rule->new("NewXSRunTrans", ["StructName"], sub {
 1882       my($trans) = @_;
 1883       PDL::PP::pp_line_numbers(__LINE__,
 1884       "PDL_RETERROR(PDL_err, PDL->make_trans_mutual($trans));\n");
 1885    }),
 1886 
 1887    PDL::PP::Rule->new(["StructDecl","ParamStructType"],
 1888       ["CompStruct","Name"],
 1889       sub {
 1890         my($comp,$name) = @_;
 1891         return ('', '') if !$comp;
 1892         my $ptype = "pdl_params_$name";
 1893         (PDL::PP::pp_line_numbers(__LINE__-1, qq{typedef struct $ptype {\n$comp} $ptype;}),
 1894         $ptype);
 1895       }),
 1896 
 1897 do {
 1898 sub wrap_vfn {
 1899   my (
 1900     $code,$rout,$func_header,
 1901     $all_func_header,$sname,$pname,$ptype,$extra_args,
 1902   ) = @_;
 1903   PDL::PP::pp_line_numbers(__LINE__, <<EOF);
 1904 pdl_error $rout(pdl_trans *$sname$extra_args) {
 1905   @{[join "\n  ",
 1906   'pdl_error PDL_err = {0, NULL, 0};',
 1907   $ptype ? "$ptype *$pname = $sname->params;" : (),
 1908   (grep $_, $all_func_header, $func_header, $code), 'return PDL_err;'
 1909 ]}
 1910 }
 1911 EOF
 1912 }
 1913 sub make_vfn_args {
 1914   my ($which, $extra_args) = @_;
 1915   ("${which}Func",
 1916     ["${which}CodeSubd","${which}FuncName",\"${which}FuncHeader",
 1917       \"AllFuncHeader", qw(StructName ParamStructName ParamStructType),
 1918     ],
 1919     sub {$_[1] eq 'NULL' ? '' : wrap_vfn(@_,$extra_args//'')}
 1920   );
 1921 }
 1922 ()},
 1923 
 1924    PDL::PP::Rule->new("MakeCompOther", "SignatureObj", sub { $_[0]->getcopy }),
 1925    PDL::PP::Rule->new("MakeCompTotal", ["MakeCompOther", \"MakeComp"], sub { join "\n", grep $_, @_ }),
 1926    PDL::PP::Rule::Substitute->new("MakeCompiledReprSubd", "MakeCompTotal"),
 1927 
 1928    (map PDL::PP::Rule::Substitute->new("${_}ReadDataCodeUnparsed", "${_}Code"), '', 'Bad'),
 1929    PDL::PP::Rule->new(PDL::PP::Code::make_args(qw(ReadData)),
 1930               sub { PDL::PP::Code->new(@_, undef, undef, 1); }),
 1931    PDL::PP::Rule::Substitute->new("ReadDataCodeSubd", "ReadDataCodeParsed"),
 1932    PDL::PP::Rule::InsertName->new("ReadDataFuncName", 'pdl_${name}_readdata'),
 1933    PDL::PP::Rule->new(make_vfn_args("ReadData")),
 1934 
 1935    (map PDL::PP::Rule::Substitute->new("${_}WriteBackDataCodeUnparsed", "${_}BackCode"), '', 'Bad'),
 1936    PDL::PP::Rule->new(PDL::PP::Code::make_args(qw(WriteBackData)),
 1937               sub { PDL::PP::Code->new(@_, undef, 1, 1); }),
 1938    PDL::PP::Rule::Substitute->new("WriteBackDataCodeSubd", "WriteBackDataCodeParsed"),
 1939    PDL::PP::Rule::InsertName->new("WriteBackDataFuncName", "BackCode", 'pdl_${name}_writebackdata'),
 1940    PDL::PP::Rule::Returns::NULL->new("WriteBackDataFuncName", "Code"),
 1941    PDL::PP::Rule->new(make_vfn_args("WriteBackData")),
 1942 
 1943    PDL::PP::Rule->new("DefaultRedoDims",
 1944       ["StructName"],
 1945       sub { "PDL_RETERROR(PDL_err, PDL->redodims_default($_[0]));" }),
 1946    PDL::PP::Rule->new("DimsSetters",
 1947       ["SignatureObj"],
 1948       sub { join "\n", sort map $_->get_initdim, $_[0]->dims_values }),
 1949    PDL::PP::Rule->new("RedoDimsFuncName", ["Name", \"RedoDims", \"RedoDimsCode", "DimsSetters"],
 1950       sub { (scalar grep $_ && /\S/, @_[1..$#_]) ? "pdl_$_[0]_redodims" : 'NULL'}),
 1951    PDL::PP::Rule::Returns->new("RedoDimsCode", [],
 1952                    'Code that can be inserted to set the size of output ndarrays dynamically based on input ndarrays; is parsed',
 1953                    ''),
 1954    (map PDL::PP::Rule::Substitute->new("RedoDims${_}Unparsed", "RedoDims$_"), '', 'Code'),
 1955    PDL::PP::Rule->new(PDL::PP::Code::make_args(qw(RedoDims)),
 1956       'makes the parsed representation from the supplied RedoDimsCode',
 1957       sub { return '' if !$_[0]; PDL::PP::Code->new(@_, 1, undef, 0); }),
 1958    PDL::PP::Rule->new("RedoDimsCodeParsed","RedoDimsUnparsed", sub {@_}),
 1959    PDL::PP::Rule->new("RedoDims",
 1960       ["DimsSetters","RedoDimsCodeParsed","DefaultRedoDims"],
 1961       'makes the redodims function from the various bits and pieces',
 1962       sub { join "\n", grep $_ && /\S/, @_ }),
 1963    PDL::PP::Rule::Substitute->new("RedoDimsCodeSubd", "RedoDims"),
 1964    PDL::PP::Rule->new(make_vfn_args("RedoDims")),
 1965 
 1966    PDL::PP::Rule->new("CompFreeCodeOther", "SignatureObj", sub {$_[0]->getfree("COMP")}),
 1967    PDL::PP::Rule->new("CompFreeCodeComp", [qw(CompObj Comp)], sub {$_[0]->getfree("COMP")}),
 1968    PDL::PP::Rule->new("CompFreeCode", ["CompFreeCodeOther", \"CompFreeCodeComp"], sub { join "\n", grep $_, @_ }),
 1969    PDL::PP::Rule->new("NTPrivFreeCode", "PrivObj", sub {$_[0]->getfree("PRIV")}),
 1970    PDL::PP::Rule->new("FreeCodeNS",
 1971       ["StructName","CompFreeCode","NTPrivFreeCode"],
 1972       sub {
 1973       (grep $_, @_[1..$#_]) ? PDL::PP::pp_line_numbers(__LINE__-1, "PDL_FREE_CODE($_[0], destroy, $_[1], $_[2])"): ''}),
 1974    PDL::PP::Rule::Substitute->new("FreeCodeSubd", "FreeCodeNS"),
 1975    PDL::PP::Rule->new("FreeFuncName",
 1976               ["FreeCodeSubd","Name"],
 1977               sub {$_[0] ? "pdl_$_[1]_free" : 'NULL'}),
 1978    PDL::PP::Rule->new(make_vfn_args("Free", ", char destroy")),
 1979 
 1980    PDL::PP::Rule->new("NewXSCoerceMustNS", "FTypes",
 1981       sub {
 1982         my($ftypes) = @_;
 1983         join '', map
 1984           PDL::PP::pp_line_numbers(__LINE__, "$_->datatype = $ftypes->{$_};"),
 1985           sort keys %$ftypes;
 1986       }),
 1987    PDL::PP::Rule::Returns::EmptyString->new("NewXSCoerceMustNS"),
 1988    PDL::PP::Rule::Substitute->new("NewXSCoerceMustCompSubd", "NewXSCoerceMustNS"),
 1989 
 1990    PDL::PP::Rule->new("NewXSFindBadStatusNS", ["StructName"],
 1991       "Rule to find the bad value status of the input ndarrays",
 1992       sub {
 1993         PDL::PP::pp_line_numbers(__LINE__, <<EOF);
 1994 PDL_RETERROR(PDL_err, PDL->trans_check_pdls($_[0]));
 1995 char \$BADFLAGCACHE() = PDL->trans_badflag_from_inputs($_[0]);
 1996 EOF
 1997       }),
 1998 
 1999    PDL::PP::Rule->new("NewXSCopyBadStatusNS",
 2000       ["CopyBadStatusCode"],
 2001       "Use CopyBadStatusCode if given",
 2002       sub {
 2003         my ($badcode) = @_;
 2004         confess "PDL::PP ERROR: CopyBadStatusCode contains '\$PRIV(bvalflag)'; replace with \$BADFLAGCACHE()"
 2005           if $badcode =~ m/\$PRIV(bvalflag)/;
 2006         $badcode;
 2007       }),
 2008    PDL::PP::Rule->new("NewXSCopyBadStatusNS",
 2009       ["SignatureObj"],
 2010       "Rule to copy the bad value status to the output ndarrays",
 2011       # note: this is executed before the trans_mutual call
 2012       # is made, since the state may be changed by the
 2013       # Code section
 2014       sub {
 2015         my ( $sig ) = @_;
 2016         return '' if @{$sig->names} == (my @outs = $sig->names_out); # no input pdls, no badflag copying needed
 2017         PDL::PP::pp_line_numbers(__LINE__, join '',
 2018           "if (\$BADFLAGCACHE()) {\n",
 2019           (map "  \$SETPDLSTATEBAD($_);\n", @outs),
 2020           "}\n");
 2021       }),
 2022 
 2023  # expand macros in ...BadStatusCode
 2024  #
 2025    PDL::PP::Rule::Substitute->new("NewXSFindBadStatusSubd", "NewXSFindBadStatusNS"),
 2026    PDL::PP::Rule::Substitute->new("NewXSCopyBadStatusSubd", "NewXSCopyBadStatusNS"),
 2027 
 2028    PDL::PP::Rule->new("NewXSStructInit0",
 2029               ["StructName","VTableName","ParamStructName","ParamStructType"],
 2030               "Rule to create and initialise the private trans structure",
 2031       sub {
 2032         my( $sname, $vtable, $pname, $ptype ) = @_;
 2033         PDL::PP::pp_line_numbers(__LINE__, <<EOF);
 2034 if (!PDL) croak("PDL core struct is NULL, can't continue");
 2035 pdl_trans *$sname = PDL->create_trans(&$vtable);
 2036 @{[$ptype ? "  $ptype *$pname = $sname->params;" : ""]}
 2037 EOF
 2038       }),
 2039 
 2040    PDL::PP::Rule->new(["RunFunc"],
 2041       ["RunFuncHdr",
 2042         "NewXSStructInit0",
 2043         "NewXSSetTransPDLs",
 2044         "NewXSFindBadStatusSubd",
 2045         #     NewXSMakeNow, # this is unnecessary since families never got implemented
 2046         "NewXSTypeCoerceSubd",
 2047         "NewXSExtractTransPDLs",
 2048         "MakeCompiledReprSubd",
 2049         "NewXSCoerceMustCompSubd",
 2050         "NewXSRunTrans",
 2051         "NewXSCopyBadStatusSubd",
 2052       ],
 2053       "Generate C function with idiomatic arg list to maybe call from XS",
 2054       sub {
 2055         my ($xs_c_header, @bits) = @_;
 2056         my $opening = 'pdl_error PDL_err = {0, NULL, 0};';
 2057         my $closing = 'return PDL_err;';
 2058         PDL::PP::pp_line_numbers __LINE__-1, join '', "$xs_c_header {\n$opening\n", @bits, "$closing\n}\n";
 2059       }),
 2060 
 2061    # internal usage, not XS - NewXSCHdrs only set if GlobalNew
 2062    PDL::PP::Rule->new(["NewXSCode","BootSetNewXS","NewXSInPrelude"],
 2063       ["NewXSHdr", "NewXSCHdrs", "RunFuncCall"],
 2064       "Non-varargs XS code when GlobalNew given",
 2065       sub {(undef,(make_xs_code('CODE:',' XSRETURN(0);',@_))[1..2])}),
 2066    # if PMCode supplied, no var-args stuff
 2067    PDL::PP::Rule->new(["NewXSCode","BootSetNewXS","NewXSInPrelude"],
 2068       ["PMCode","NewXSHdr", \"NewXSCHdrs", "RunFuncCall"],
 2069       "Non-varargs XS code when PMCode given",
 2070       sub {make_xs_code('CODE:',' XSRETURN(0);',@_[1..$#_])}),
 2071    PDL::PP::Rule->new(["NewXSCode","BootSetNewXS","NewXSInPrelude"],
 2072       [qw(VarArgsXSHdr), \"NewXSCHdrs", qw(RunFuncCall VarArgsXSReturn)],
 2073       "Rule to print out XS code when variable argument list XS processing is enabled",
 2074       sub {make_xs_code('','',@_)}),
 2075 
 2076    PDL::PP::Rule::Returns::Zero->new("NoPthread"), # assume we can pthread, unless indicated otherwise
 2077    PDL::PP::Rule->new("VTableDef",
 2078       ["VTableName","ParamStructType","RedoDimsFuncName","ReadDataFuncName",
 2079        "WriteBackDataFuncName","FreeFuncName",
 2080        "SignatureObj","Affine_Ok","HaveBroadcasting","NoPthread","Name",
 2081        "GenericTypes","IsAffineFlag","TwoWayFlag","DefaultFlowFlag",
 2082        "BadFlag"],
 2083       sub {
 2084         my($vname,$ptype,$rdname,$rfname,$wfname,$ffname,
 2085            $sig,$affine_ok,$havebroadcasting, $noPthreadFlag, $name, $gentypes,
 2086            $affflag, $revflag, $flowflag, $badflag) = @_;
 2087         my ($pnames, $pobjs) = ($sig->names_sorted, $sig->objs);
 2088         my $nparents = 0 + grep {! $pobjs->{$_}->{FlagW}} @$pnames;
 2089         my $aff = ($affine_ok ? "PDL_TPDL_VAFFINE_OK" : 0);
 2090         my $npdls = scalar @$pnames;
 2091         my $join_flags = join(", ",map {$pobjs->{$pnames->[$_]}->{FlagPhys} ?
 2092                                           0 : $aff} 0..$npdls-1) || '0';
 2093         my @op_flags;
 2094         push @op_flags, 'PDL_TRANS_DO_BROADCAST' if $havebroadcasting;
 2095         push @op_flags, 'PDL_TRANS_BADPROCESS' if $badflag;
 2096         push @op_flags, 'PDL_TRANS_BADIGNORE' if defined $badflag and !$badflag;
 2097         push @op_flags, 'PDL_TRANS_NO_PARALLEL' if $noPthreadFlag;
 2098         my $op_flags = join('|', @op_flags) || '0';
 2099         my $iflags = join('|', grep $_, $affflag, $revflag, $flowflag) || '0';
 2100         my $gentypes_txt = join(", ", (map PDL::Type->new($_)->sym, @$gentypes), '-1');
 2101         my @realdims = map 0+@{$_->{IndObjs}}, @$pobjs{@$pnames};
 2102         my $realdims = join(", ", @realdims) || '0';
 2103         my $parnames = join(",",map qq|"$_"|, @$pnames) || '""';
 2104         my $parflags = join(",\n  ",map join('|', $_->cflags)||'0', @$pobjs{@$pnames}) || '0';
 2105         my $partypes = join(", ", map defined()?$_->sym:-1, map $_->{Type}, @$pobjs{@$pnames}) || '-1';
 2106         my $i = 0; my @starts = map { my $ci = $i; $i += $_; $ci } @realdims;
 2107         my $realdim_ind_start = join(", ", @starts) || '0';
 2108         my @rd_inds = map $_->get_index, map @{$_->{IndObjs}}, @$pobjs{@$pnames};
 2109         my $realdim_inds = join(", ", @rd_inds) || '0';
 2110         my @indnames = $sig->ind_names_sorted;
 2111         my $indnames = join(",", map qq|"$_"|, @indnames) || '""';
 2112         my $sizeof = $ptype ? "sizeof($ptype)" : '0';
 2113         PDL::PP::pp_line_numbers(__LINE__, <<EOF);
 2114 static pdl_datatypes ${vname}_gentypes[] = { $gentypes_txt };
 2115 static char ${vname}_flags[] = {
 2116   $join_flags
 2117 };
 2118 static PDL_Indx ${vname}_realdims[] = { $realdims };
 2119 static char *${vname}_parnames[] = { $parnames };
 2120 static short ${vname}_parflags[] = {
 2121   $parflags
 2122 };
 2123 static pdl_datatypes ${vname}_partypes[] = { $partypes };
 2124 static PDL_Indx ${vname}_realdims_starts[] = { $realdim_ind_start };
 2125 static PDL_Indx ${vname}_realdims_ind_ids[] = { $realdim_inds };
 2126 static char *${vname}_indnames[] = { $indnames };
 2127 pdl_transvtable $vname = {
 2128   $op_flags, $iflags, ${vname}_gentypes, $nparents, $npdls, ${vname}_flags,
 2129   ${vname}_realdims, ${vname}_parnames,
 2130   ${vname}_parflags, ${vname}_partypes,
 2131   ${vname}_realdims_starts, ${vname}_realdims_ind_ids, @{[scalar @rd_inds]},
 2132   @{[scalar @indnames]}, ${vname}_indnames,
 2133   $rdname, $rfname, $wfname,
 2134   $ffname,
 2135   $sizeof,"$::PDLMOD\::$name"
 2136 };
 2137 EOF
 2138       }),
 2139 
 2140    PDL::PP::Rule->new('PMFunc', 'Name',
 2141      'Sets PMFunc to default symbol table manipulations',
 2142      sub {
 2143          my ($name) = @_;
 2144          $::PDL_IFBEGINWRAP[0].'*'.$name.' = \&'.$::PDLOBJ.
 2145                    '::'.$name.";\n".$::PDL_IFBEGINWRAP[1]
 2146      }
 2147    ),
 2148 
 2149 ];
 2150 }
 2151 
 2152 1;