File Coverage

blib/lib/PDLA/PP.pm

Criterion	Covered	Total	%
statement	725	1021	71.0
branch	148	386	38.3
condition	28	105	26.6
subroutine	127	165	76.9
pod	17	88	19.3
total	1045	1765	59.2

#####################################################################
#####################################################################
##
##
## Here starts the actual thing.
##
## This is way too messy and uncommented. Still. :(
#
# DJB August 24 2006
#   begin cleaning up the code so that it all runs under use strict
# DJB August 31 2006
#   moved to use objects for the rule table (ie defvar) in the
#   hope it's more declarative (since the addition of "::" to
#   a statement makes it so much-more meaningful :-)
#

# How to convert from the old deftbl format to the new, object-based,
# system:
#
# What used to be, in $PDLA::PP::deftbl
#   [["Name1"], ["Name2"], $ref_to_sub]]
# is now
#   PDLA::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 their is no condition, the argument can be left out of the call
# (unless there is a doc string), so
#   [["Name1"], [], $ref_to_sub]]
# becomes
#   PDLA::PP::Rule->new("Name1", $ref_to_sub)
#
# The target and conditions can also be an array reference, so
#   [["Name1"], ["Name2","Name3"], $ref_to_sub]]
#   [["Name1","Name2"], ["Name3"], $ref_to_sub]]
#   [["Name1","Name2"], ["Name3","Name4"], $ref_to_sub]]
# become, respectively
#   PDLA::PP::Rule->new("Name1", ["Name2","Name3"], $ref_to_sub)
#   PDLA::PP::Rule->new(["Name1","Name2"], "Name3", $ref_to_sub)
#   PDLA::PP::Rule->new(["Name1","Name2"], ["Name3","Name4], $ref_to_sub)
#
# If the old rule had a document string, this is placed between
# the condition and the subroutine reference. To make processing
# simpler, 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:
#
# PDLA::PP::Rule::Returns->new($targets [,$conditions [,$doc]], $value)
# is used to return a constant. So
#   [["Name1"], [], sub { "foo" }]
# becomes
#   PDLA::PP::Rule::Returns->new("Name1", "foo")
#
# This class is specialized since there are some common return values:
#   PDLA::PP::Rule::Returns::Zero->new($targets [,$conditions [,$doc]])
#   PDLA::PP::Rule::Returns::One->new($targets [,$conditions [,$doc]])
#   PDLA::PP::Rule::Returns::EmptyString->new($targets [,$conditions [,$doc]])
#   PDLA::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
#   "foobar"
# The old rules
#  [["Foo"], ["Name"], sub { return "_pdl_$_[0]_bar"; }]
#  [["Foo"], ["Name","Arg2"], sub { return "_pdl_$_[0]_bar"; }]
# become
#  PDLA::PP::Rule::InsertName->new("Foo", '_pdl_${name}_bar')
#  PDLA::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(), ect)
# with the low-level C code to perform the macro.
#
# The Substitute class replaces the dosubst rule. The old rule
#   [["NewXSCoerceMustSubs"], ["NewXSCoerceMustSub1","NewXSSymTab","Name"],
#	 	      \&dosubst]
# becomes
#   PDLA::PP::Rule::Substitute("NewXSCoerceMustSubs", "NewXSCoerceMustSub1")
#
# PDLA::PP::Rule::Substitute->new($target,$condition)
#   $target and $condition must be scalars.
#
#   Implicit conditions are NewXSSymTab and Name
#
# The Substitute:Usual class replaces the dousualsubsts rule. The old rule
#   [["CacheBadFlagInit"], ["CacheBadFlagInitNS","NewXSSymTab","Name"],
#		      \&dousualsubsts],
# becomes
#   PDLA::PP::Rule::Substitute::Usual->new("CacheBadFlagInit", "CacheBadFlagInitNS")
#
# PDLA::PP::Rule::Substitute::Usual->new($target, $condition)
#   $target and $condition must be scalars.
#
#   Implicit conditions are NewXSSymTab and Name
#
# The MakeComp rule replaces the subst_makecomp routine. The old rule
#  [["MakeCompiledRepr"], ["MakeComp","CompNames","CompObjs"],
#		      sub {subst_makecomp("COMP",@_)}]
# becomes
#  PDLA::PP::Rule::MakeComp->new("MakeCompiledRepr", ["MakeComp","CompNames","CompObjs"],
#		      "COMP")
# PDLA::PP::Rule::MakeComp->new($target,$conditions,$symbol)
#   $target and $symbol must be scalars.
#

# Notes:
#   InsertName could become a subclass of Insert since there are
#   a few rules that just insert conditions into a text string.
#
#   Substitute, Substitute::Usual, MakeComp classes feel a bit
#   ugly. See next point. Also the get_std_childparent method is
#   a bit of a hack.
#
#   DJB thinks that the code fragments themselves could be objects
#   since they should 'know' what needs doing to them (eg the
#   substitutions). Not sure whether it would really clarify things.
#
# To do:
#   wrap_vfn could propbably be moved into a class.
#
#   move the PDLA::PP::Rule and subclasses into their own file?
#

package PDLA::PP::Rule;

use strict;
require PDLA::Core::Dev;

use Carp;
our @CARP_NOT;

my $INVALID_OTHERPARS_RE = qr/^(?:magicno|flags|vtable|freeproc|bvalflag|has_badvalue|badvalue|pdls|__datatype)\z/;

use overload ("\"\"" => \&PDLA::PP::Rule::stringify);
sub stringify {
    my $self = shift;

    my $str = ref $self;
    if ("PDLA::PP::Rule" eq $str) {
	$str = "Rule";
    } else {
	$str =~ s/PDLA::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
#
# It seems strange to make the subroutine reference an optional
# argument but this is being used to transition to a slightly-different
# object design
#
sub new {
    my $class = shift;

    my $self = {};
    bless $self, $class;

    my $usage = "Usage: PDLA::PP::Rule->new(\$targets[,\$conditions[,\$doc],] [,\$ref])\n";

    # handle arguments
    my $nargs = $#_;
    die $usage if $nargs < 0 or $nargs > 3;

    my $targets = shift;
    $targets = [$targets] unless ref $targets eq "ARRAY";
    $self->{targets} = $targets;

    if ($#_ != -1) {
        if (ref $_[-1] eq "CODE") {
            $self->{ref} = pop;
        }

        my ($conditions,$doc) = @_;

        if (defined $conditions) {
            $conditions = [$conditions] unless ref $conditions eq "ARRAY";
        } else {
            $conditions = [];
        }
        $self->{conditions} = $conditions;
        $self->{doc} = $doc if defined $doc;
    }

    return $self;
}

# $rule->check_if_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.
#
# Not 100% happy with use of report here. Needs re-thinking.
#
sub check_if_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->check_if_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.
#
# Not 100% happy with use of report here. Needs re-thinking.
#
sub check_if_conditions_exist {
    my $self = shift;
    my $pars = shift;

    my $conditions = $self->{conditions};

    foreach my $condition (@$conditions) {

	# skip if not a required condition
	next if substr($condition,0,1) eq "_";

	unless (exists $pars->{$condition}) {
	    $self->report("--skipping since CONDITION $condition does not exist\n");
	    return 0;
	}
    }

    return 1;
}

# $rule->is_valid($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 is_valid {
    my $self = shift;
    my $pars = shift;

    return 0 if $self->check_if_targets_exist($pars);
    return 0 unless $self->check_if_conditions_exist($pars);
    return 1;
}

# my @args = $self->extract_args($pars);
#
# If this method is called we assume that
#   $self->check_if_conditions_exist($pars)
# returns 1.
#
sub extract_args {
    my $self = shift;
    my $pars = shift;

    my $conditions = $self->{conditions};

    my @args;
    foreach (@$conditions) {
		# make a copy of each condition so that any changes to it are not
		# also made to the original array!
		my $condition = $_;
		# Remove any possible underscores (which indicate optional conditions):
		$condition =~ s/^_//;

		# Note: This will *not* create $pars->{$condition} if it did not already
		# exist:
		push @args, $pars->{$condition};
    }

    return @args;
}

# 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");

    # Is the rule valid?
    #
    return unless $self->is_valid($pars);

    # Create the argument array for the routine.
    #
    my @args = $self->extract_args($pars);

    # Run this rule's subroutine:
    my @retval = $self->{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 PDLA::PP::Rule::Croak;

# Croaks if all of the input variables are defined. Use this to identify
# incompatible arguments.
our @ISA = qw(PDLA::PP::Rule);
use Carp;
our @CARP_NOT;


sub new {
    croak('Usage: PDLA::PP::Ruel::Croak->new(["incompatible", "arguments"], "Croaking message")')
		unless @_ == 3;

    my $class = shift;
    my $self  = $class->SUPER::new([], @_);
    return bless $self, $class;
}

sub apply {
    my ($self, $pars) = @_;
    croak($self->{doc}) if $self->is_valid($pars);
}

package PDLA::PP::Rule::Returns;

use strict;

use Carp;
our @CARP_NOT;

##use PDLA::PP::Rule;
our @ISA = qw (PDLA::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);
    bless $self, $class;
    $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");

    # Is the rule valid?
    #
    return unless $self->is_valid($pars);

    # Set the value
    #
    $self->report ("--setting: $target\n");
    $pars->{$target} = $self->{"returns.value"};
}

package PDLA::PP::Rule::Returns::Zero;

use strict;

##use PDLA::PP::Rule::Returns;
our @ISA = qw (PDLA::PP::Rule::Returns);

sub new {
    my $class = shift;
    my @args  = @_;
    my $self  = $class->SUPER::new(@args,0);
    bless $self, $class;
    return $self;
}

package PDLA::PP::Rule::Returns::One;

use strict;

##use PDLA::PP::Rule::Returns;
our @ISA = qw (PDLA::PP::Rule::Returns);

sub new {
    my $class = shift;
    my @args  = @_;
    my $self  = $class->SUPER::new(@args,1);
    bless $self, $class;
    return $self;
}

package PDLA::PP::Rule::Returns::EmptyString;

use strict;

##use PDLA::PP::Rule::Returns;
our @ISA = qw (PDLA::PP::Rule::Returns);

sub new {
    my $class = shift;
    my @args  = @_;
    my $self  = $class->SUPER::new(@args,"");
    bless $self, $class;
    return $self;
}

package PDLA::PP::Rule::Returns::NULL;

use strict;

##use PDLA::PP::Rule::Returns;
our @ISA = qw (PDLA::PP::Rule::Returns);

sub new {
    my $class = shift;
    my @args  = @_;
    my $self  = $class->SUPER::new(@args,"NULL");
    bless $self, $class;
    return $self;
}

package PDLA::PP::Rule::InsertName;

use strict;

use Carp;
our @CARP_NOT;

##use PDLA::PP::Rule;
our @ISA = qw (PDLA::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);
    bless $self, $class;
    $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");

    # Is the rule valid?
    #
    return unless $self->is_valid($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"} . "\";";
}

# Poor name. This is the old "dosubst" routine
#
#   PDLA::PP::Rule->new("NewXSCoerceMustSubs", ["NewXSCoerceMustSub1","NewXSSymTab","Name"],
#	 	      \&dosubst),
#
# PDLA::PP::Rule::Substitute->new($target,$condition)
#   $target and $condition must be scalars.
#
#   Implicit conditions are NewXSSymTab and Name
#
package PDLA::PP::Rule::Substitute;

use strict;

use Carp;
our @CARP_NOT;

##use PDLA::PP::Rule;
our @ISA = qw (PDLA::PP::Rule);

# Probably want this directly in the apply routine but leave as is for now
#
sub dosubst_private {
    my ($src,$symtab,$name) = @_;
    my $ret = (ref $src ? $src->[0] : $src);
    my %syms = (
		((ref $src) ? %{$src->[1]} : ()),
		PRIV => sub {return "".$symtab->get_symname('_PDLA_ThisTrans').
			       "->$_[0]"},
		CROAK => sub {return "PDLA->pdl_barf(\"Error in $name:\" $_[0])"},
		NAME => sub {return $name},
		MODULE => sub {return $::PDLAMOD},

		SETPDLASTATEBAD  => sub { return "$_[0]\->state |= PDLA_BADVAL"; },
		SETPDLASTATEGOOD => sub { return "$_[0]\->state &= ~PDLA_BADVAL"; },
		ISPDLASTATEBAD   => sub { return "(($_[0]\->state & PDLA_BADVAL) > 0)"; },
		ISPDLASTATEGOOD  => sub { return "(($_[0]\->state & PDLA_BADVAL) == 0)"; },
		BADFLAGCACHE    => sub { return "badflag_cache"; },

		SETREVERSIBLE => sub {
		    return "if($_[0]) \$PRIV(flags) |= PDLA_ITRANS_REVERSIBLE;\n" .
		      "   else \$PRIV(flags) &= ~PDLA_ITRANS_REVERSIBLE;\n"
		  },
	       );
    while(
	  $ret =~ s/\$(\w+)\(([^()]*)\)/
	  (defined $syms{$1} or
	   confess("$1 not defined in '$ret'!")) and
	  (&{$syms{$1}}($2))/ge
	 ) {};
    $ret;
}

sub new {
    my $class = shift;

    die "Usage: PDLA::PP::Rule::Substitute->new(\$target,\$condition);"
      unless $#_ == 1;

    my $target = shift;
    my $condition = shift;

    die "\$target must be a scalar for PDLA::PP::Rule->Substitute" if ref $target;
    die "\$condition must be a scalar for PDLA::PP::Rule->Substitute" if ref $condition;

    my $self = $class->SUPER::new($target, [$condition, "NewXSSymTab", "Name"],
				  \&dosubst_private);
    bless $self, $class;

    return $self;
}

# Poor name. This is the old "dousualsubsts" routine
#
#   PDLA::PP::Rule->new("CacheBadFlagInit", ["CacheBadFlagInitNS","NewXSSymTab","Name"],
#		      \&dousualsubsts),
#
# PDLA::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 PDLA::PP::Rule::Substitute::Usual;

use strict;

use Carp;
our @CARP_NOT;

##use PDLA::PP::Rule;
our @ISA = qw (PDLA::PP::Rule::Substitute);

# This is a copy of the main one for now. Need a better solution.
#
my @std_childparent = (
	CHILD => sub {return '$PRIV(pdls[1]->'.(join ',',@_).")"},
	PARENT => sub {return '$PRIV(pdls[0]->'.(join ',',@_).")"},
	CHILD_P => sub {return '$PRIV(pdls[1]->'.(join ',',@_).")"},
	PARENT_P => sub {return '$PRIV(pdls[0]->'.(join ',',@_).")"},
	CHILD_PTR => sub {return '$PRIV(pdls[1])'},
	PARENT_PTR => sub {return '$PRIV(pdls[0])'},
	COMP => sub {return '$PRIV('.(join ',',@_).")"}
);

sub get_std_childparent { return @std_childparent; }

sub new {
    my $class = shift;

    my @args = @_;
    my $self = $class->SUPER::new(@args);
    bless $self, $class;

    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;

    # The conditions are [, NewXSSymTab, Name]
    #
    my $code   = $pars->{$self->{conditions}[0]};
    my $symtab = $pars->{$self->{conditions}[1]};
    my $name   = $pars->{$self->{conditions}[2]};

    return ([$code,{@std_childparent}],$symtab,$name);
}

# Poor name. This is the old "subst_makecomp" routine
#
#  PDLA::PP::Rule->new("MakeCompiledRepr", ["MakeComp","CompNames","CompObjs"],
#		      sub {subst_makecomp("COMP",@_)}),
#
# PDLA::PP::Rule::MakeComp->new($target,$conditions,$symbol)
#   $target and $symbol must be scalars.
#
package PDLA::PP::Rule::MakeComp;

use strict;

use Carp;
our @CARP_NOT;

##use PDLA::PP::Rule;
our @ISA = qw (PDLA::PP::Rule);

# This is a copy of the main one for now. Need a better solution.
#
my @std_redodims = (
		    SETNDIMS => sub {return "PDLA->reallocdims(__it,$_[0])"},
		    SETDIMS => sub {return "PDLA->setdims_careful(__it)"},
		    SETDELTATHREADIDS => sub {return '
		{int __ind; PDLA->reallocthreadids($CHILD_PTR(),
			$PARENT(nthreadids));
		for(__ind=0; __ind<$PARENT(nthreadids)+1; __ind++) {
			$CHILD(threadids[__ind]) =
				$PARENT(threadids[__ind]) + ('.$_[0].');
		}
		}
		'});

##sub get_std_redodims { return @std_redodims; }

# Probably want this directly in the apply routine but leave as is for now
#
sub subst_makecomp_private {
	my($which,$mc,$cn,$co) = @_;
	return [$mc,{
#		@::std_childparent,
		PDLA::PP::Rule::Substitute::Usual::get_std_childparent(),
		($cn ?
			(('DO'.$which.'DIMS') => sub {return join '',
				map{$$co{$_}->need_malloc ?
				    $$co{$_}->get_malloc('$PRIV('.$_.')') :
				    ()} @$cn}) :
			()
		),
		($which eq "PRIV" ?
			@std_redodims : ()),
		},
	];
}

sub new {
    my $class = shift;

    die "Usage: PDLA::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 PDLA::PP::Rule->MakeComp" if ref $target;
    die "\$symbol must be a scalar for PDLA::PP::Rule->MakeComp" if ref $symbol;

    my $self = $class->SUPER::new($target, $condition,
				  \&subst_makecomp_private);
    bless $self, $class;
    $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;

    # The conditions are [, conditions...]
    # - could use slicing here
    #
    my @args = ($self->{"makecomp.value"});
    foreach my $condition (@{$self->{conditions}}) {
      push @args, $pars->{$condition};
    }
    return @args;
}

package PDLA::PP;

use strict;

our $VERSION = "2.3";
$VERSION = eval $VERSION;

use PDLA::Types ':All';
use Config;
use FileHandle;
use Exporter;

use Data::Dumper;

our @ISA = qw(Exporter);

@PDLA::PP::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::boundscheck = 1;
$::PP_VERBOSE    = 0;

$PDLA::PP::done = 0;  # pp_done has not been called yet

END {
  pp_done() unless $PDLA::PP::done; # make sure we call this
}

use Carp;
our @CARP_NOT;

# check for bad value support
use PDLA::Config;
my $bvalflag = $PDLA::Config{WITH_BADVAL} || 0;

my $ntypes = $#PDLA::Types::names;

sub nopm { $::PDLAPACK eq 'NONE' } # flag that we don't want to generate a PM

sub import {
	my ($mod,$modname, $packname, $prefix, $callpack) = @_;
	# Allow for users to not specify the packname
	($packname, $prefix, $callpack) = ($modname, $packname, $prefix)
		if ($packname =~ m|/|);

	$::PDLAMOD=$modname; $::PDLAPACK=$packname; $::PDLAPREF=$prefix;
	$::CALLPACK = defined $callpack ? $callpack : $::PDLAMOD;
	$::PDLAOBJ = "PDLA"; # define pp-funcs in this package
	$::PDLAXS="";
	$::PDLABEGIN="";
	$::PDLAPMROUT="";
 	for ('Top','Bot','Middle') { $::PDLAPM{$_}="" }
	@::PDLAPMISA=('PDLA::Exporter', 'DynaLoader');
	@::PDLA_IFBEGINWRAP = ('','');
	$::PDLAVERSIONSET = '';
	$::PDLAMODVERSION = undef;
	$::DOCUMENTED = 0;
	$::PDLACOREIMPORT = "";  #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.
	@_=("PDLA::PP");
	goto &Exporter::import;
}


# 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 {
	@::PDLA_IFBEGINWRAP = ('BEGIN {','}');
}

sub pp_setversion {
	my ($ver) = @_;
	$::PDLAMODVERSION = '$VERSION';
	$::PDLAVERSIONSET = "\$$::PDLAPACK\::VERSION = $ver;";
}

sub pp_addhdr {
	my ($hdr) = @_;
	$::PDLAXSC .= $hdr;
}

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';
 	}
 	$::PDLAPM{$pos} .= "$pm\n\n";
}

sub pp_add_exported {
	# my ($this,$exp) = @_;
        my $exp = join ' ', @_; # get rid of this silly $this argument
	$::PDLAPMROUT .= $exp." ";
}

sub pp_addbegin {
	my ($cmd) = @_;
	if ($cmd =~ /^\s*BOOT\s*$/) {
		pp_beginwrap;
	} else {
		$::PDLABEGIN .= $cmd."\n";
	}
}

#  Sub to call to export nothing (i.e. for building OO package/object)
sub pp_export_nothing {
	$::PDLAPMROUT = ' ';
}

sub pp_add_isa {
	push @::PDLAPMISA,@_;
}

sub pp_add_boot {
	my ($boot) = @_;
	$::PDLAXSBOOT .= $boot." ";
}

sub pp_bless{
   my($new_package)=@_;
   $::PDLAOBJ = $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{
   $::PDLACOREIMPORT = $_[0];
}

sub printxs {
	shift;
	$::PDLAXS .= join'',@_;
}

sub pp_addxs {
	PDLA::PP->printxs("\nMODULE = $::PDLAMOD PACKAGE = $::CALLPACK\n\n",
                         @_,
                         "\nMODULE = $::PDLAMOD PACKAGE = $::PDLAOBJ\n\n");
}

# inserts #line directives into source text. Use like this:
#   ...
#   FirstKey => ...,
#   Code => pp_line_numbers (__LINE__, $a . $b . $c),
#   OtherKey => ...

sub pp_line_numbers ($$) {
	my ($line, $string) = @_;
	# The line needs to be incremented by one for the bookkeeping to work
	$line++;
	# Get the source filename using caller()
	my (undef, $filename) = caller;
	# Escape backslashes:
	$filename =~ s/\\/\\\\/g;
	my @to_return = "#line $line \"$filename\"";

	# Look for threadloops and loops and add # line directives
	foreach (split (/(\n)/, $string)) {
		# Always add the current line.
		push @to_return, $_;

		# If we need to add a # line directive, do so before incrementing
		push (@to_return, "\n#line $line \"$filename\"") if (/%\{/ or /%}/);

		$line++ if /\n/;
	}

	return join('', @to_return);
}

sub printxsc {
	shift;
	$::PDLAXSC .= join '',@_;
}

sub pp_done {
        return if $PDLA::PP::done; # do only once!
        $PDLA::PP::done = 1;
        $::FUNCSPOD = $::DOCUMENTED ? "\n\n=head1 FUNCTIONS\n\n\n\n=cut\n\n\n"
	  : '';
	print "DONE!\n" if $::PP_VERBOSE;
	print "Inline running PDLA::PP version $PDLA::PP::VERSION...\n" if nopm();
	(my $fh = FileHandle->new(">$::PDLAPREF.xs")) or die "Couldn't open xs file\n";
        my $pdl_boot = PDLA::Core::Dev::PDLA_BOOT('PDLA', $::PDLAMOD); # don't hardcode in more than one place

$fh->print(qq%
/*
 * THIS FILE WAS GENERATED BY PDLA::PP! Do not modify!
 */

#define PDLA_COMMENT(comment)
PDLA_COMMENT("This preprocessor symbol is used to add commentary in the PDLA  ")
PDLA_COMMENT("autogenerated code. Normally, one would use typical C-style    ")
PDLA_COMMENT("multiline comments (i.e. /* comment */). However, because such ")
PDLA_COMMENT("comments do not nest, it's not possible for PDLA::PP users to   ")
PDLA_COMMENT("comment-out sections of code using multiline comments, as is   ")
PDLA_COMMENT("often the practice when debugging, for example. So, when you   ")
PDLA_COMMENT("see something like this:                                       ")
PDLA_COMMENT("                                                               ")
                PDLA_COMMENT("Memory access")
PDLA_COMMENT("                                                               ")
PDLA_COMMENT("just think of it as a C multiline comment like:                ")
PDLA_COMMENT("                                                               ")
PDLA_COMMENT("   /* Memory access */                                         ")

#include "EXTERN.h"
#include "perl.h"
#include "XSUB.h"
#include "pdl.h"
#include "pdlcore.h"
static Core* PDLA; PDLA_COMMENT("Structure hold core C functions")
static int __pdl_debugging = 0;
static int __pdl_boundscheck = 0;
static SV* CoreSV;       PDLA_COMMENT("Gets pointer to perl var holding core structure")

#if ! $PP::boundscheck
# define PP_INDTERM(max, at) at
#else
# define PP_INDTERM(max, at) (__pdl_boundscheck? PDLA->safe_indterm(max,at, __FILE__, __LINE__) : at)
#endif

$::PDLAXSC

MODULE = $::PDLAMOD PACKAGE = $::PDLAMOD

PROTOTYPES: ENABLE

int
set_debugging(i)
	int i;
	CODE:
	RETVAL = __pdl_debugging;
	__pdl_debugging = i;
	OUTPUT:
	RETVAL

int
set_boundscheck(i)
       int i;
       CODE:
       if (! $PP::boundscheck)
         warn("Bounds checking is disabled for $::PDLAMOD");
       RETVAL = __pdl_boundscheck;
       __pdl_boundscheck = i;
       OUTPUT:
       RETVAL


MODULE = $::PDLAMOD PACKAGE = $::PDLAOBJ

$::PDLAXS

BOOT:

   PDLA_COMMENT("Get pointer to structure of core shared C routines")
   PDLA_COMMENT("make sure PDLA::Core is loaded")
   $pdl_boot
   $::PDLAXSBOOT
%);

unless (nopm) {
	$::PDLAPMISA = "'".join("','",@::PDLAPMISA)."'";
	$::PDLABEGIN = "BEGIN {\n$::PDLABEGIN\n}"
		unless $::PDLABEGIN =~ /^\s*$/;
	($fh = FileHandle->new(">$::PDLAPREF.pm")) or die "Couldn't open pm file\n";

	$fh->print(qq%
#
# GENERATED WITH PDLA::PP! Don't modify!
#
package $::PDLAPACK;

\@EXPORT_OK  = qw( $::PDLAPMROUT);
\%EXPORT_TAGS = (Func=>[\@EXPORT_OK]);

use PDLA::Core$::PDLACOREIMPORT;
use PDLA::Exporter;
use DynaLoader;


$::PDLA_IFBEGINWRAP[0]
   $::PDLAVERSIONSET
   \@ISA    = ( $::PDLAPMISA );
   push \@PDLA::Core::PP, __PACKAGE__;
   bootstrap $::PDLAMOD $::PDLAMODVERSION;
$::PDLA_IFBEGINWRAP[-1]

$::PDLABEGIN

$::PDLAPM{Top}

$::FUNCSPOD

$::PDLAPM{Middle};

$::PDLAPM{Bot}

# Exit with OK status

1;

		   %);  # end of print
      }  # unless (nopm) {...
} # end pp_done

sub pp_def {
	my($name,%obj) = @_;

	print "*** Entering pp_def for $name\n" if $::PP_VERBOSE;

	# See if the 'name' is multiline, in which case we extract the
	# name and add the FullDoc field
	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');
		}
		$obj{FullDoc} = $fulldoc;
	}

	$obj{Name} = $name;
	translate(\%obj,$PDLA::PP::deftbl);

	print "Output 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}; # and $obj{FreeFunc};

	PDLA::PP->printxsc(join "\n\n",@obj{'StructDecl','RedoDimsFunc',
		'CopyFunc',
		'ReadDataFunc','WriteBackDataFunc',
		'FreeFunc',
		'FooFunc',
		'VTableDef','NewXSInPrelude',
		}
		);
	PDLA::PP->printxs($obj{NewXSCode});
	pp_add_boot($obj{XSBootCode} . $obj{BootSetNewXS});
	PDLA::PP->pp_add_exported($name);
	PDLA::PP::pp_addpm("\n".$obj{PdlDoc}."\n") if $obj{PdlDoc};
	PDLA::PP::pp_addpm($obj{PMCode});
	PDLA::PP::pp_addpm($obj{PMFunc}."\n");

	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 = $::PDLAMOD;
  my $envvar = 'PDLA_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 of this module\n" .
    "This warning can be suppressed by setting the $envvar\n" .
    "environment variable\n";

  my $deprecation_notice = <
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'}, <
warn \"$warning_main\n$warning_suppression_runtime\" unless \$ENV{$envvar};
EOF


}

# Worst memleaks: not freeing things at redodims or
# final free time (thread, dimmed things).

use Carp;
$SIG{__DIE__} = sub {print Carp::longmess(@_); die;}
  if $::PP_VERBOSE;  # seems to give us trouble with 5.6.1

use PDLA::PP::Signature;
use PDLA::PP::Dims;
use PDLA::PP::CType;
use PDLA::PP::XS;
use PDLA::PP::SymTab;
use PDLA::PP::PDLACode;

$|=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)
#
# This is an extended typemap handler from the one earlier written by
# Doug Hunt. It should work exactly as the older version, but with extensions.
# Instead of handling a few special cases explicitly we now use Perl's
# built-in typemap handling using code taken straight from xsubpp.
#
# I have infact kept the old part of the code here because I belive any
# subsequent hackers might find it very helpful to refer to this code to
# understand what the following does. So here goes:
#
# ------------ OLD TYPEMAP PARSING: ------------------------
#
#   # Note that I now just look at the basetype.  I don't
#   # test whether it is a pointer to the base type or not.
#   # This is done because it is simpler and I know that the otherpars
#   # belong to a restricted set of types.  I know a char will really
#   # be a char *, for example.  I also know that an SV will be an SV *.
#   #    yes, but how about catching syntax errors in OtherPars (CS)?
#   #    shouldn't we really parse the perl typemap (we can steal the code
#   #    from xsubpp)?
#
#   my $OLD_PARSING=0;
#   if ($OLD_PARSING) {
#     my %typemap = (char     => "(char *)SvPV($arg,PL_na)",
# 		   short    => "(short)SvIV($arg)",
# 		   int      => "(int)SvIV($arg)",
# 		   long     => "(long)SvIV($arg)",
# 		   double   => "(double)SvNV($arg)",
# 		   float    => "(float)SvNV($arg)",
# 		   SV       => "$arg",
# 		  );
#     my $basetype = $type->{Base};
#     $basetype =~ s/\s+//g;  # get rid of whitespace
#
#     die "Cannot find $basetype in my (small) typemap" unless exists($typemap{$basetype});
#     return ($typemap{$basetype});
#   }
#
#--------- END OF THE OLD CODE ---------------
#
# 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)
  # if this does not work portably we should split out the typemap finding code
  # and make it as complex as necessary + save the typemap location
  # in the PDLA::Config hash
  my $_rootdir = $Config{privlibexp}.'/ExtUtils/';
#  print "_rootdir set to '$_rootdir'\n";

  # 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');
  # Finally tag onto the end, the current directory typemap. Ideally we should here pick
  # up the TYPEMAPS flag from ExtUtils::MakeMaker, but a) I don't know how and b)
  # it is only a slight inconvenience hopefully!
  #
  # 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, 'typemap';
  my $foundtm = 0;
  foreach $typemap (@tm) {
    next unless -f $typemap ;
    # skip directories, binary files etc.
    warn("Warning: ignoring non-text typemap file '$typemap'\n"), next
      unless -T $typemap ;
    $foundtm = 1;
    open(TYPEMAP, $typemap)
      or warn ("Warning: could not open typemap file '$typemap': $!\n"), next;
    $mode = 'Typemap';
    $junk = "" ;
    $current = \$junk;
    while () {
	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(TYPEMAP);
  }
  carp "**CRITICAL** PP found no typemap in $_rootdir/typemap; this will cause problems..."
      unless $foundtm;

  #
  # Do checks...
  #
  # First reconstruct the type declaration to look up in type_kind
  my $full_type=TidyType($type->get_decl('')); # 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};
  # Remove all before =:
  $input =~ s/^(.*?)=\s*//; # This should not be very expensive
  # Replace $arg with $arg
  $input =~ s/\$arg/$arg/;
  # And type with $full_type
  $input =~ s/\$type/$full_type/;

  return ($input);
}


sub identity2priv {
	return '
		int i;
		$SETNDIMS($PARENT(ndims));
		for(i=0; i<$CHILD(ndims); i++) {
			$CHILD(dims[i]) = $PARENT(dims[i]);
		}
		$SETDIMS();
		$SETDELTATHREADIDS(0);
	';
}

sub pdimexpr2priv {
	my($pdimexpr,$hdr,$dimcheck) = @_;
	$pdimexpr =~ s/\$CDIM\b/i/g;
	return '
		int i,cor;
		'.$dimcheck.'
		$SETNDIMS($PARENT(ndims));
		$DOPRIVDIMS();
		$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();
		$SETDELTATHREADIDS(0);
	';
}

# something to do with copying values between parent and children
#
# 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
#
sub equivcpoffscode {
    return
	'PDLA_Indx i;
         for(i=0; i<$CHILD_P(nvals); i++)  {
            $EQUIVCPOFFS(i,i);
         }';

} # sub: equivcpoffscode()

# Pars -> ParNames, Parobjs
#
# XXX
# - the need for BadFlag is due to hacked get_xsdatapdecl()
#   in PP/PdlParObj and because the PdlParObjs are created by
#   PDLA::PP::Signature (Doug Burke 07/08/00)
sub Pars_nft {
	my($str,$badflag) = @_;
	my $sig = PDLA::PP::Signature->new($str,$badflag);
	return ($sig->names,$sig->objs,1);
}

# ParNames,Parobjs -> DimObjs
sub ParObjs_DimObjs {
	my($pnames,$pobjs) = @_;
	my ($dimobjs) = PDLA::PP::PdlDimsObj->new();
	for(@$pnames) {
		$pobjs->{$_}->add_inds($dimobjs);
	}
	return ($dimobjs);
}

# Eliminate whitespace entries
sub nospacesplit {map {/^\s*$/?():$_} split $_[0],$_[1]}

sub OtherPars_nft {
    my($otherpars,$dimobjs) = @_;
    my(@names,%types,$type);
    # support 'int ndim => n;' syntax
    for (nospacesplit ';',$otherpars) {
	if (/^\s*([^=]+)\s*=>\s*(\S+)\s*$/) {
	    my ($ctype,$dim) = ($1,$2);
	    $ctype =~ s/(\S+)\s+$/$1/; # get rid of trailing ws
	    print "OtherPars: setting dim '$dim' from '$ctype'\n" if $::PP_VERBOSE;
	    $type = PDLA::PP::CType->new(undef,$ctype);
	    croak "can't set unknown dimension"
		unless defined($dimobjs->{$dim});
	    $dimobjs->{$dim}->set_from($type);
	} elsif(/^\s*pdl\s+\*\s*(\w+)$/) {
	    # It is a piddle -> make it a controlling one.
	    die("Not supported yet");
	} else {
	    $type = PDLA::PP::CType->new(undef,$_);
	}
	my $name = $type->protoname;
        if ($name =~ /$INVALID_OTHERPARS_RE/) {
            croak "Invalid OtherPars name: $name";
        }
	push @names,$name;
	$types{$name} = $type;
    }
    return (\@names,\%types);
}

sub NXArgs {
	my($parnames,$parobjs,$onames,$oobjs) = @_;
	my $pdltype = PDLA::PP::CType->new(undef,"pdl *__foo__");
	my $nxargs = [
		( map {[$_,$pdltype]} @$parnames ),
		( map {[$_,$oobjs->{$_}]} @$onames )
	];
	return $nxargs;
}

# XXX
# - the need for BadFlag is due to hacked get_xsdatapdecl()
#   in PP/PdlParObj and because the PdlParObjs are created by
#   PDLA::PP::Signature (Doug Burke 07/08/00)
sub NewParentChildPars {
    my($p2child,$name,$badflag) = @_;
    return (Pars_nft("PARENT(); [oca]CHILD();",$badflag),0,"${name}_NN");
}

# XXX
# - the need for BadFlag is due to hacked get_xsdatapdecl()
#   in PP/PdlParObj and because the PdlParObjs are created by
#   PDLA::PP::Signature (Doug Burke 07/08/00)
#
# however, it looks like this isn't being used anymore,
# so commenting out.
#
#sub ParentChildPars {
#	my($p2child,$name,$badflag) = @_;
#	return (Pars_nft("PARENT(); [oca]CHILD();",$badflag),0,"${name}_XX",
#	"
#	*$name = \\&PDLA::$name;
#	sub PDLA::$name {
#		my \$this = shift;
#		my \$foo=\$this->null;
#		PDLA::${name}_XX(\$this,\$foo,\@_);
#		\$foo
#	}
#	");
#}

sub mkstruct {
	my($pnames,$pobjs,$comp,$priv,$name) = @_;
	my $npdls = $#$pnames+1;
	my $decl = qq{typedef struct $name {
		PDLA_TRANS_START($npdls);
		$priv
		$comp
		char __ddone; PDLA_COMMENT("Dims done")
		} $name;};
	return $decl;
}

sub def_vtable {
    my($vname,$sname,$rdname,$rfname,$wfname,$cpfname,$ffname,
       $pnames,$pobjs,$affine_ok,$foofname) = @_;
    my $nparents = 0 + grep {! $pobjs->{$_}->{FlagW}} @$pnames;
    my $aff = ($affine_ok ? "PDLA_TPDLA_VAFFINE_OK" : 0);
    my $npdls = scalar @$pnames;
    my $join_flags = join",",map {$pobjs->{$pnames->[$_]}->{FlagPhys} ?
				      0 : $aff} 0..$npdls-1;
    if($Config{cc} eq 'cl') {
       $join_flags = '""' if $join_flags eq '';
    }
    return "static char ${vname}_flags[] =
	 	{ ". $join_flags . "};
	 pdl_transvtable $vname = {
		0,0, $nparents, $npdls, ${vname}_flags,
		$rdname, $rfname, $wfname,
		$ffname,NULL,NULL,$cpfname,
		sizeof($sname),\"$vname\"
	 };";
}

sub sort_pnobjs {
    my($pnames,$pobjs) = @_;
    my (@nn);
    for(@$pnames) { push ( @nn, $_ ) unless $pobjs->{$_}{FlagW}; }
    for(@$pnames) { push ( @nn, $_ ) if $pobjs->{$_}{FlagW}; }
    my $no = 0;
    for(@nn) { $pobjs->{$_}{Number} = $no++; }
    return (\@nn,$pobjs);
}

# XXX __privtrans explicit :(
sub wrap_vfn {
    my($code,$hdrinfo,$rout,$p2child,$name) = @_;
    my $type = ($name eq "copy" ? "pdl_trans *" : "void");
    my $sname = $hdrinfo->{StructName};
    my $oargs = ($name eq "foo" ? ",int i1,int i2,int i3" : "");

#	print "$rout\_$name: $p2child\n";
    my $p2decl = '';
    # Put p2child in simple boolean context rather than strict numerical equality
    if ( $p2child ) {
	$p2decl =
	    "pdl *__it = ((pdl_trans_affine *)(__tr))->pdls[1]; pdl *__parent = __tr->pdls[0];";
	if ( $name eq "redodims" ) {
	    $p2decl .= '
	     if (__parent->hdrsv && (__parent->state & PDLA_HDRCPY)) {
                  PDLA_COMMENT("call the perl routine _hdr_copy.")
                  int count;

                  dSP;
                  ENTER ;
                  SAVETMPS ;
                  PUSHMARK(SP) ;
                  XPUSHs( sv_mortalcopy((SV*)__parent->hdrsv) );
                  PUTBACK ;
                  count = call_pv("PDLA::_hdr_copy",G_SCALAR);
                  SPAGAIN ;
                  if(count != 1)
                      croak("PDLA::_hdr_copy didn\'t return a single value - please report this bug (B).");

                  { PDLA_COMMENT("convenience block for tmp var")
                    SV *tmp = (SV *) POPs ;
		    __it->hdrsv = (void*) tmp;
                    if(tmp != &PL_sv_undef )
                       (void)SvREFCNT_inc(tmp);
                  }

                  __it->state |= PDLA_HDRCPY;

                  FREETMPS ;
                  LEAVE ;
             }
        ';
	}
    } # if: $p2child == 1

    qq|$type $rout(pdl_trans *__tr $oargs) {
	int __dim;
	$sname *__privtrans = ($sname *) __tr;
	$p2decl
	{
	    $code
	}
    }
    |;

} # sub: wrap_vfn()

sub makesettrans {
    my($pnames,$pobjs,$symtab) = @_;
    my $trans = $symtab->get_symname('_PDLA_ThisTrans');
    my $no=0;
    return (join '',map {
	"$trans->pdls[".($no++)."] = $_;\n"
	} @$pnames).
	    "PDLA->make_trans_mutual((pdl_trans *)$trans);\n";
}

sub CopyOtherPars {
	my($onames,$otypes,$symtab) = @_; my $repr;
	my $sname = $symtab->get_symname('_PDLA_ThisTrans');
	for(@$onames) {
		$repr .= $otypes->{$_}->get_copy("$_","$sname->$_");
	}
	return $repr;
}

sub mkxscat {
	my($glb,$xs_c_headers,$hdr,@bits) = @_;
	my($boot,$prelude,$str);
	if($glb) {
		$prelude = join '' => ($xs_c_headers->[0], @bits, $xs_c_headers->[1]);
		$boot = $xs_c_headers->[3];
		$str = "$hdr\n";
	} else {
		my $xscode = join '' => @bits;
		$str = "$hdr CODE:\n { $xscode XSRETURN(0);\n}\n\n";
	}
	$str =~ s/(\s*\n)+/\n/g;
	($str,$boot,$prelude)
}

sub mkVarArgsxscat {
	my($glb,$xs_c_headers,$hdr,@bits) = @_;
	my($boot,$prelude,$str);
	if($glb) {
		$prelude = join '' => ($xs_c_headers->[0], @bits, $xs_c_headers->[1]);
		$boot = $xs_c_headers->[3];
		$str = "$hdr\n";
	} else {
		my $xscode = join '' => @bits;
		$str = "$hdr \n { $xscode \n}\n\n";
	}
	$str =~ s/(\s*\n)+/\n/g;
	($str,$boot,$prelude)
}


sub MakeNows {
    my($pnames, $symtab) = @_;
    my $str = "\n";
    for(@$pnames) { $str .= "$_ = PDLA->make_now($_);\n"; }
    return $str;
}

sub Sym2Loc { return $_[0]->decl_locals(); }

sub MkPrivStructInit {
    my( $symtab, $vtable, $affflag, $nopdlthread ) = @_;
    my $sname = $symtab->get_symname('_PDLA_ThisTrans');

    my $ci = '   ';
    return
	"\n${ci}$sname = malloc(sizeof(*$sname));\n" .
	($nopdlthread ? "" : "${ci}PDLA_THR_CLRMAGIC(&$sname->__pdlthread);\n") .
	"${ci}PDLA_TR_SETMAGIC($sname);\n" .
	"${ci}$sname->flags = $affflag;\n" .
	"${ci}$sname->__ddone = 0;\n" .
	"${ci}$sname->vtable = &$vtable;\n" .
	"${ci}$sname->freeproc = PDLA->trans_mallocfreeproc;\n";

} # sub: MkPrivStructInit()

sub MkDefSyms {
    return PDLA::PP::SymTab->new(
		       _PDLA_ThisTrans => ["__privtrans",PDLA::PP::CType->new(undef,"$_[0] *foo")],
		      );
}

sub AddArgsyms {
	my($symtab,$args) = @_;
	$symtab->add_params(
		map {($_->[0],$_->[0])} @$args
	);
	return $symtab;
}

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 PDLAs
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) {
	unless ($callcopy) { $ret .= << "EOC"}

if (strcmp(objname,"PDLA") == 0) { PDLA_COMMENT("shortcut if just PDLA")
   $name\_SV = sv_newmortal();
   $name = PDLA->null();
   PDLA->SetSV_PDLA($name\_SV,$name);
   if (bless_stash) $name\_SV = sv_bless($name\_SV, bless_stash);
} else {
   PUSHMARK(SP);
   XPUSHs(sv_2mortal(newSVpv(objname, 0)));
   PUTBACK;
   perl_call_method(\"initialize\", G_SCALAR);
   SPAGAIN;
   $name\_SV = POPs;
   PUTBACK;
   $name = PDLA->SvPDLAV($name\_SV);
}

EOC

    else { $ret .= << "EOD" }

if (strcmp(objname,"PDLA") == 0) { PDLA_COMMENT("shortcut if just PDLA")
   $name\_SV = sv_newmortal();
   $name = PDLA->null();
   PDLA->SetSV_PDLA($name\_SV,$name);
   if (bless_stash) $name\_SV = sv_bless($name\_SV, bless_stash);
} else {
   /* XXX should these commented lines be removed? See also a 8 lines down */
   /* warn("possibly relying on deprecated automatic copy call in derived class\n")
   warn("please modify your initialize method to avoid future problems\n");
   */
   PUSHMARK(SP);
   XPUSHs(parent);
   PUTBACK;
   perl_call_method(\"copy\", G_SCALAR);
   /* perl_call_method(\"initialize\", G_SCALAR); */
   SPAGAIN;
   $name\_SV = POPs;
   PUTBACK;
   $name = PDLA->SvPDLAV($name\_SV);
}
EOD

  } # doreach: $name

  return indent($ret,$ci);

} #sub callPerlInit()

# This subroutine is called when no 'otherpars' exist.
# This writes an XS header which handles variable argument lists,
# thus avoiding the perl layer in calling the routine. D. Hunt 4/11/00
#
# The use of 'DO NOT SET!!' looks ugly.
#
# Removing useless use of hasp2child in this function. DCM Sept 12, 2011
sub VarArgsXSHdr {
  my($name,$xsargs,$parobjs,$optypes,#$hasp2child,
     $pmcode,$hdrcode,$inplacecode,$globalnew,$callcopy) = @_;

  # Don't do var args processing if the user has pre-defined pmcode
  return 'DO NOT SET!!' if ($pmcode);

  # don't generate a HDR if globalnew is set
  # globalnew implies internal usage, not XS
  return undef if $globalnew;

  my $ci = '  ';  # current indenting
  my $pars = join "\n",map {$ci.$_->[1]->get_decl($_->[0]).";"} @$xsargs;

  my @args   = map { $_->[0] } @$xsargs;
  my %out    = map { $_ => exists($$parobjs{$_})
		       && exists($$parobjs{$_}{FlagOut})
				 && !exists($$parobjs{$_}{FlagCreateAlways})}
		     @args;
  my %outca = map { $_ => exists($$parobjs{$_})
		       && exists($$parobjs{$_}{FlagOut})
				 && exists($$parobjs{$_}{FlagCreateAlways})}
		     @args;
  my %tmp    = map { $_ => exists($$parobjs{$_}) && exists($$parobjs{$_}{FlagTemp}) } @args;
  my %other  = map { $_ => exists($$optypes{$_}) } @args;

  # remember, othervars *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 + $ntmp);
  my $ninout = $nin + $nout;
  my $nallout = $nout + $noutca;
  my $usageargs = join (",", @args);

  $ci = '  ';  # Current indenting

  # Generate declarations for SV * variables corresponding to pdl * output variables.
  # These are used in creating output and temp 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;" } grep { $out{$_} || $outca{$_} || $tmp{$_} } @args);

  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 = ''; my $cnt = 0;
  foreach my $i ( 0 .. $#args ) {
      my $x = $args[$i];
      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 = PDLA->SvPDLAV(ST($cnt));\n";
	  $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 output vars and creating temps
  my $clause2;
  # skip this clause if there are no temps
  if ($nmaxonstack == $ninout) {
      $clause2 = '';
  } else {
      $clause2 = "\n  else if (items == $ninout) { PDLA_COMMENT(\"all but temps on stack, read in output, create temps\")" .
	  "    nreturn = $noutca;\n";

      $cnt = 0;
      foreach my $i ( 0 .. $#args ) {
	  my $x = $args[$i];
	  if ($other{$x}) {
	      $clause2 .= "$ci$x = " . typemap($x, $$optypes{$x}, "ST($cnt)") . ";\n";
	      $cnt++;
	  } elsif ($tmp{$x} || $outca{$x}) {
	      # a temporary or always create variable
	      push (@create, $x);
	  } else { # an input or output variable
	      $clause2 .= "$ci$x = PDLA->SvPDLAV(ST($cnt));\n";
	      $cnt++;
	  }
      }

      # Add code for creating output variables via call to 'initialize' perl routine
      $clause2 .= callPerlInit (\@create, $ci, $callcopy);
      $clause2 .= "}\n";
      @create = ();

  }

  # clause for reading in input and creating output and temp vars
  my $clause3 = '';
  $cnt = 0;
  foreach my $i ( 0 .. $#args ) {
      my $x = $args[$i];
      if ($other{$x}) {
	  $clause3 .= "$ci$x = " . typemap($x, $$optypes{$x}, "ST($cnt)") . ";\n";
	  $cnt++;
      } elsif ($out{$x} || $tmp{$x} || $outca{$x}) {
	  push (@create, $x);
      } else {
	  $clause3 .= "$ci$x = PDLA->SvPDLAV(ST($cnt));\n";
	  $cnt++;
      }
  }

  # Add code for creating output variables via call to 'initialize' perl routine
  $clause3 .= callPerlInit (\@create, $ci, $callcopy); @create = ();

  return<

void
$name(...)
 PREINIT:
  char *objname = "PDLA"; /* XXX maybe that class should actually depend on the value set
                            by pp_bless ? (CS) */
  HV *bless_stash = 0;
  SV *parent = 0;
  int   nreturn;
$svdecls
$pars

 PPCODE:

{
  PDLA_COMMENT("Check if you can get a package name for this input value.  ")
  PDLA_COMMENT("It can be either a PDLA (SVt_PVMG) or a hash which is a     ")
  PDLA_COMMENT("derived PDLA 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));  PDLA_COMMENT("The package to bless output vars into is taken from the first input var")
    }
  }
  if (items == $nmaxonstack) { PDLA_COMMENT("all variables on stack, read in output and temp vars")
    nreturn = $noutca;
$clause1
  }
$clause2
  else if (items == $nin) { PDLA_COMMENT("only input variables on stack, create outputs and temps")
    nreturn = $nallout;
$clause3
  }

  else {
    croak (\"Usage:  PDLA::$name($usageargs) (you may leave temporaries or output variables out of list)\");
  }
}
{
$hdrcode
$inplacecode
}
END

} # sub: VarArgsXSHdr()

# This subroutine produces the code which returns output variables
# or leaves them as modified input variables.  D. Hunt 4/10/00
sub VarArgsXSReturn {
    my($xsargs, $parobjs, $globalnew ) = @_;

    # don't generate a HDR if globalnew is set
    # globalnew implies internal usage, not XS
    return undef if $globalnew;

    # names of output variables    (in calling order)
    my @outs;

    # beware of existance tests like this:  $$parobjs{$arg->[0]}{FlagOut}  !
    # this will cause $$parobjs{$arg->[0]} to spring into existance even if $$parobjs{$arg->[0]}{FlagOut}
    # does not exist!!
    foreach my $arg (@$xsargs) {
	my $x = $arg->[0];
	push (@outs, $x) if (exists ($$parobjs{$x}) and exists ($$parobjs{$x}{FlagOut}));
    }

    my $ci = '  ';  # Current indenting

    my $clause1 = '';
    foreach my $i ( 0 .. $#outs ) {
	$clause1 .= "${ci}ST($i) = $outs[$i]_SV;\n";
    }

return <<"END"
if (nreturn) {
  if (nreturn - items > 0) EXTEND (SP, nreturn - items);
$clause1
  XSRETURN(nreturn);
} else {
  XSRETURN(0);
}
END

} # sub: VarArgsXSReturn()


sub XSCHdrs {
	my($name,$pars,$gname) = @_;
	# Hmmm, do we need $shortpars at all?
	#my $shortpars = join ',',map {$_->[0]} @$pars;
	my $longpars = join ",",map {$_->[1]->get_decl($_->[0])} @$pars;
	return ["void $name($longpars) {","}","",
		"PDLA->$gname = $name;"];
}

# abstract the access to the bad value status
# - means we can easily change the representation without too
#   many changes
#
# it's also used in one place in PP/PDLACode.pm
# -- there it's hard-coded
#
sub set_badflag   { return '$PRIV(bvalflag) = 1;' . "\n"; }
sub clear_badflag { return '$PRIV(bvalflag) = 0;' . "\n"; }
sub get_badflag   { return '$PRIV(bvalflag)'; }

sub get_badflag_priv { return '$PRIV(bvalflag)'; }

sub set_badstate {
    my $pdl = shift;
    return "\$SETPDLASTATEBAD($pdl)";
}

sub clear_badstate {
    my $pdl = shift;
    return "\$SETPDLASTATEGOOD($pdl)";
}

sub get_badstate {
    my $pdl = shift;
    return "\$ISPDLASTATEBAD($pdl)";
}

# checks the input piddles to see if the routine
# is being any data containing bad values
#
# if FindBadStatusCode is set, use it,
# otherwise create the code automatically.
#
# - in the automatic code creation,
# if $badflag is 0, rather than being undefined, then
# we issue a warning if any piddles contain bad values
# (and set the bvalflag to 0)
#
# XXX it looks like output piddles are included in the
# check. I *think* this is just wasted code, but I'm
# not sure.
#
sub findbadstatus {
    my ( $badflag, $badcode, $xsargs, $parobjs, $optypes, $symtab, $name ) = @_;
    return '' unless $bvalflag;

    return $badcode if defined $badcode;

    my $sname = $symtab->get_symname('_PDLA_ThisTrans');

    my @args   = map { $_->[0] } @$xsargs;
    my %out    = map {
	$_ =>
	    exists($$parobjs{$_}) && exists($$parobjs{$_}{FlagOut})
		&& !exists($$parobjs{$_}{FlagCreateAlways})
	    } @args;
    my %outca = map {
	$_ =>
	    exists($$parobjs{$_}) && exists($$parobjs{$_}{FlagOut})
		&& exists($$parobjs{$_}{FlagCreateAlways})
	    } @args;
    my %tmp    = map {
	$_ =>
	    exists($$parobjs{$_}) && exists($$parobjs{$_}{FlagTemp})
	    } @args;
    my %other  = map { $_ => exists($$optypes{$_}) } @args;

    my $clear_bad = clear_badflag();
    my $set_bad   = set_badflag();
    my $get_bad   = get_badflag();

    my $str = $clear_bad;

    # set the badflag_cache variable if any input piddle has the bad flag set
    #
    my $add = 0;
    my $badflag_str = "  \$BADFLAGCACHE() = ";
    foreach my $i ( 0 .. $#args ) {
	my $x = $args[$i];
	unless ( $other{$x} or $out{$x} or $tmp{$x} or $outca{$x}) {
	    if ($add) { $badflag_str .= " || "; }
	    else      { $add = 1; }
	    $badflag_str .= get_badstate($args[$i]);
	}
    }

    # It is possible, at present, for $add to be 0. I think this is when
    # the routine has no input piddles, such as fibonacci in primitive.pd,
    # but there may be other cases. These routines could/should (?)
    # be marked as NoBadCode to avoid this, or maybe the code here made
    # smarter. Left as is for now as do not want to add instability into
    # the 2.4.3 release if I can help it - DJB 23 Jul 2006
    #
    if ($add != 0) {
	$str .= $badflag_str . ";\n  if (\$BADFLAGCACHE()) ${set_bad}\n";
    } else {
	print "\nNOTE: $name has no input bad piddles.\n\n" if $::PP_VERBOSE;
    }

    if ( defined($badflag) and $badflag == 0 ) {
	$str .=
"  if ( $get_bad ) {
      printf(\"WARNING: $name does not handle bad values.\\n\");
      $clear_bad
  }\n";
	print "\nNOTE: $name does not handle bad values.\n\n" if $::PP_VERBOSE;
    } # if: $badflag

    return $str;

} # sub: findbadstatus


# copies over the bad value state to the output piddles
#
# if CopyBadStatusCode is set, use it,
# otherwise create the code automatically.
#
# note: this is executed before the trans_mutual call
# is made, since the state may be changed by the
# Code section
#
sub copybadstatus {
    my ( $badflag, $badcode, $xsargs, $parobjs, $symtab ) = @_;
##    return '' unless $bvalflag or $badflag == 0;
    return '' unless $bvalflag;

    if (defined $badcode) {
	# realised in 2.4.3 testing that use of $PRIV at this stage is
	# dangerous since it may have been freed. So I introduced the
	# $BFLACACHE variable which stores the $PRIV(bvalflag) value
	# for use here.
	# For now make the substitution automatic but it will likely become an
	# error to use $PRIV(bvalflag) here.
	#
	if ($badcode =~ m/\$PRIV(bvalflag)/) {
	    $badcode =~ s/\$PRIV(bvalflag)/\$BADFLAGCACHE()/;
	    print "\nPDLA::PP WARNING: copybadstatus contains '\$PRIV(bvalflag)'; replace with \$BADFLAGCACHE()\n\n";
	}
	return $badcode;
    }

    # names of output variables    (in calling order)
    my @outs;

    # beware of existance tests like this:  $$parobjs{$arg->[0]}{FlagOut}  !
    # this will cause $$parobjs{$arg->[0]} to spring into existance even if $$parobjs{$arg->[0]}{FlagOut}
    # does not exist!!
    foreach my $arg (@$xsargs) {
	my $x = $arg->[0];
	push (@outs, $x) if (exists ($$parobjs{$x}) and exists ($$parobjs{$x}{FlagOut}));
    }

    my $sname = $symtab->get_symname('_PDLA_ThisTrans');
    my $str = '';

# It appears that some code in Bad.xs sets the cache value but then
# this bit of code never gets called. Is this an efficiency issue (ie
# should we try and optimise away those ocurrences) or does it perform
# some purpose?
#
    $str = "if (\$BADFLAGCACHE()) {\n";
    foreach my $arg ( @outs ) {
	$str .= "  " . set_badstate($arg) . ";\n";
    }
    $str .= "}\n";

    return $str;

} # sub: copybadstatus()

# 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 inout and output piddle (eg 'a(); [o] b();')
#
#   => [ 'a' ]
#     assumes several input piddles in sig, so 'a' labels which
#     one is to be marked inplace
#
#   => [ 'a', 'b' ]
#     input piddle is a(), output pidle is 'b'
#
sub InplaceCode {
    my ( $ppname, $xsargs, $parobjs, $arg ) = @_;
    return '' unless defined $arg;

    # find input and output piddles
    my ( @in, @out );
    foreach my $arg (@$xsargs) {
	my $name = $arg->[0];
	if ( exists $$parobjs{$name} ) {
	    if ( exists $$parobjs{$name}{FlagOut} ) {
		push @out, $name;
	    } elsif ( ! exists $$parobjs{$name}{FlagTemp} ) {
		push @in, $name;
	    }
	}
    }

    # handle different values of arg
    my ( $in, $out );

    # default vals - only set if we have one input/output piddle
    $in  = $in[0]  if $#in == 0;
    $out = $out[0] if $#out == 0;

    if ( ref($arg) eq "ARRAY" ) {
	my $narg = $#$arg;
	if ( $narg > -1 ) {
	    $in = $$arg[0];
	    $out = $$arg[1] if $narg > 0;
	}
    } elsif ( ref($arg) eq "" ) {
	return '' unless $arg;
	# use default values
    } else {
	die "ERROR: Inplace rule [$ppname] must be sent either an array ref or a scalar.\n";
    }

    die "ERROR: Inplace [$ppname] does not know name of input piddle\n"
	unless defined $in;
    die "ERROR: Inplace [$ppname] does not know name of output piddle\n"
	unless defined $out;

    my $instate = $in . "->state";
    return
	qq{\tif ( $instate & PDLA_INPLACE && ($out != $in)) {
              $instate &= ~PDLA_INPLACE; PDLA_COMMENT("unset")
              $out = $in;             PDLA_COMMENT("discard output value, leak ?")
              PDLA->SetSV_PDLA(${out}_SV,${out});
          }},

} # sub: InplaceCode

# 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 'threadloop %{', we can't rely on
#  PDLACode 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
#
# sent [EquivCPOffsCode,BadFlag]

#
# 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 CodefromEquivCPOffsCode {
    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;

    my $str = $good;

    if ( defined $bflag and $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;

	$str = 'if( $PRIV(bvalflag) ) { ' . $bad . ' } else { ' . $good . '}';
    }

    return $str;

} # sub: CodefromEquivCPOffsCode

# this just reverses PARENT & CHILD in the expansion of
# the $EQUIVCPOFFS macro (ie compared to CodefromEquivCPOffsCode)
#
sub BackCodefromEquivCPOffsCode {
    my $good = shift;
    my $bflag = shift;

    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;

    my $str = $good;

    if ( defined $bflag and $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;

	$str = 'if ( $PRIV(bvalflag) ) { ' . $bad . ' } else { ' . $good . '}';
    }

    return $str;

} # sub: BackCodefromEquivCPOffsCode

sub GenDocs {
  my ($name,$pars,$otherpars,$doc,$baddoc) = @_;

  # Allow explcit non-doc using Doc=>undef

  return '' if $doc eq '' && (!defined $doc) && $doc==undef;
  return '' if $doc =~ /^\s*internal\s*$/i;

  # remove any 'bad' documentation if we're not compiling support
  $baddoc = undef unless $bvalflag;

  # If the doc string is one line let's have to for the
  # reference card information as well
  my @splitRes; # temp split variable to get rid of
                #  'implicit split to @_ is deprecated' messages
  $doc = "=for ref\n\n".$doc if( scalar(@splitRes = split("\n", $doc)) <= 1);

  $::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;
}

sub ToIsReversible {
	my($rev) = @_;
	if($rev eq "1") {
		'$SETREVERSIBLE(1)'
	} else {
		$rev
	}
}

sub make_newcoerce {
	my($ftypes) = @_;
	join '',map {
		"$_->datatype = $ftypes->{$_}; "
	} (keys %$ftypes);
}

# Assuming that, if HASP2Child is true, we only have
# PARENT; CHILD parameters, so we can just take the
# datatype to be that of PARENT (which is set up by
# find_datatype()). Little bit complicated because
# we need to set CHILD's datatype under certain
# circumstances
#
sub coerce_types {
    my($parnames,$parobjs,$ignore,$newstab,$hasp2child) = @_;

    # assume [oca]CHILD();, although there might be an ignore
    if ( $hasp2child ) {
	my $child = $$parnames[1];
	return "" if $ignore->{$child};

	die "ERROR: expected $child to be [oca]\n"
	    unless $parobjs->{$child}{FlagCreateAlways};

	return "$child\->datatype = \$PRIV(__datatype);\n$child\->has_badvalue = \$PRIV(has_badvalue);\n$child\->badvalue = \$PRIV(badvalue);\n" if $hasp2child;
    }

    my $str = "";
    foreach ( @$parnames ) {
	next if $ignore->{$_};

	my $po = $parobjs->{$_};

	my $dtype;
	if ( $po->{FlagTyped} ) {
	    $dtype = $po->cenum();
	    $dtype = "PDLAMAX($dtype,\$PRIV(__datatype))"
		if $po->{FlagTplus};
	} else {
	    $dtype = "\$PRIV(__datatype)";
	}

	if ( $po->{FlagCreateAlways} ) {
	    $str .= "$_->datatype = $dtype; ";
	} else {
	    $str .=
	 "if( ($_->state & PDLA_NOMYDIMS) && $_->trans == NULL ) {
	     $_->datatype = $dtype;
	  } else "
	      if $po->{FlagCreat};
	    $str .= "if($dtype != $_->datatype) {
	     $_ = PDLA->get_convertedpdl($_,$dtype);
	  }";
	}
    } # foreach: @$parnames

    return $str;
} # sub: coerce_types()

# First, finds the greatest datatype, then, if not supported, takes
# the largest type supported by the function.
# Not yet optimal.
#
# Assuming that, if HASP2Child is true, we only have
# PARENT; CHILD parameters, so we can just take the
# datatype to be that of PARENT (see also coerce_types())
#
sub find_datatype {
    my($parnames,$parobjs,$ignore,$newstab,$gentypes,$hasp2child) = @_;

    my $dtype = "\$PRIV(__datatype)";

    # TODO XXX
    #  the check can probably be removed, but left in since I don't know
    #  what I'm doing (DJB)
    die "ERROR: gentypes != $ntypes with p2child\n"
	if $hasp2child and $#$gentypes != $ntypes;

    return "$dtype = $$parnames[0]\->datatype;\n\$PRIV(has_badvalue) = $$parnames[0]\->has_badvalue;\n\$PRIV(badvalue) = $$parnames[0]\->badvalue;\n"
	if $hasp2child;

    my $str = "$dtype = 0;";
    foreach ( @$parnames ) {
	my $po = $parobjs->{$_};
	next if $ignore->{$_} or $po->{FlagTyped} or $po->{FlagCreateAlways};

	$str .= "if(";
	$str .= "!(($_->state & PDLA_NOMYDIMS) &&
		       $_->trans == NULL) && "
			   if $po->{FlagCreat};
	$str .= "$dtype < $_->datatype) {
		 	$dtype = $_->datatype;
		    }\n";
    } # foreach: @$parnames

    $str .= join '', map { "if($dtype == PDLA_$_) {}\nelse " }(@$gentypes);

    return $str .= "$dtype = PDLA_$gentypes->[-1];\n";
} # sub: find_datatype()

sub NT2Decls_p {&NT2Decls__({ToPtrs=>1},@_);}

sub NT2Copies_p {&NT2Copies__({ToPtrs=>1},@_);}

sub NT2Free_p {&NT2Free__({ToPtrs=>1},@_);}

sub NT2Decls {&NT2Decls__({},@_);}

sub NT2Decls__ {
    my($opts,$onames,$otypes) = @_;
    my $decl;
    my $dopts = {};
    $dopts->{VarArrays2Ptrs} = 1 if $opts->{ToPtrs};
    for(@$onames) {
	$decl .= $otypes->{$_}->get_decl($_,$dopts).";";
    }
    return $decl;
}

sub NT2Copies__ {
    my($opts,$onames,$otypes,$copyname) = @_;
    my $decl;
    my $dopts = {};
    $dopts->{VarArrays2Ptrs} = 1 if $opts->{ToPtrs};
    for(@$onames) {
	$decl .= $otypes->{$_}->get_copy("\$PRIV($_)","$copyname->$_",
					 $dopts).";";
    }
    return $decl;
}

sub NT2Free__ {
    my($opts,$onames,$otypes) = @_;
    my $decl;
    my $dopts = {};
    $dopts->{VarArrays2Ptrs} = 1 if $opts->{ToPtrs};
    for(@$onames) {
	$decl .= $otypes->{$_}->get_free("\$PRIV($_)",
					 $dopts).";";
    }
    return $decl;
}

# The undef is just so that PrivIsInc gets set. Is this really
# needed (well, it is since the rule fails if there aren't 2
# return values; what I meant is what does PrivIsInc do for
# us?)
#
sub make_incsizes {
	my($parnames,$parobjs,$dimobjs,$havethreading) = @_;
	my $str = ($havethreading?"pdl_thread __pdlthread; ":"").
	  (join '',map {$parobjs->{$_}->get_incdecls} @$parnames).
	    (join '',map {$_->get_decldim} values %$dimobjs);
	return ($str,undef);
}

sub make_incsize_copy {
	my($parnames,$parobjs,$dimobjs,$copyname,$havethreading) = @_;
	($havethreading?
      "PDLA->thread_copy(&(\$PRIV(__pdlthread)),&($copyname->__pdlthread));"
	 : "").
	 (join '',map {$parobjs->{$_}->get_incdecl_copy(sub{"\$PRIV($_[0])"},
	 						sub{"$copyname->$_[0]"})} @$parnames).
	 (join '',map {$_->get_copydim(sub{"\$PRIV($_[0])"},
						sub{"$copyname->$_[0]"})} values %$dimobjs);

}

sub make_incsize_free {
	my($parnames,$parobjs,$dimobjs,$havethreading) = @_;
	$havethreading ?
      'PDLA->freethreadloop(&($PRIV(__pdlthread)));'
	: ''
}

sub make_parnames {
	my($pnames,$pobjs,$dobjs) = @_;
	my @pdls = map {$pobjs->{$_}} @$pnames;
	my $npdls = $#pdls+1;
      my $join__parnames = join ",",map {qq|"$_"|} @$pnames;
      my $join__realdims = join ",",map {$#{$_->{IndObjs}}+1} @pdls;
      if($Config{cc} eq 'cl') {
         $join__parnames = '""' if $join__parnames eq '';
         $join__realdims = '0' if $join__realdims eq '';
      }
	return("static char *__parnames[] = {". $join__parnames ."};
		static PDLA_Indx __realdims[] = {". $join__realdims . "};
		static char __funcname[] = \"\$MODULE()::\$NAME()\";
		static pdl_errorinfo __einfo = {
			__funcname, __parnames, $npdls
		};
		");
}

##############################
#
# hdrcheck -- examine the various PDLAs that form the output PDLA,
# and copy headers as necessary.  The last header found with the hdrcpy
# bit set is used.  This used to do just a simple ref copy but now
# it uses the perl routine PDLA::_hdr_copy to do the dirty work.  That
# routine makes a deep copy of the header.  Copies of the deep copy
# are distributed to all the names of the piddle that are not the source
# of the header.  I believe that is the Right Thing to do but I could be
# wrong.
#
# It's hard to read this sort of macro stuff so here's the flow:
#   - Check the hdrcpy flag.  If it's set, then check the header
#     to see if it exists.  If it doees, we need to call the
#     perl-land PDLA::_hdr_copy routine.  There are some shenanigans
#     to keep the return value from evaporating before we've had a
#     chance to do our bit with it.
#   - For each output argument in the function signature, try to put
#     a reference to the new header into that argument's header slot.
#     (For functions with multiple outputs, this produces multiple linked
#     headers -- that could be Wrong; fixing it would require making
#     yet more explicit copies!)
#   - Remortalize the return value from PDLA::_hdr_copy, so that we don't
#     leak memory.
#
#   --CED 12-Apr-2003
#

sub hdrcheck {
  my ($pnames,$pobjs) = @_;

  my $nn = $#$pnames;
  my @names = map { "\$PRIV(pdls[$_])" } 0..$nn;

  # from make_redodims_thread() we know that __creating[] == 0 unless
  # ...{FlagCreat} is true
  #
  my $str = "
{ PDLA_COMMENT(\"convenience block\")
  void *hdrp = NULL;
  char propagate_hdrcpy = 0;
  SV *hdr_copy = NULL;
";

  # Find a header among the possible names
  foreach ( 0 .. $nn ) {
    my $aux = $pobjs->{$pnames->[$_]}{FlagCreat} ? "!__creating[$_] && \n" : "";
    $str .= <<"HdRCHECK1"
      if(!hdrp &&
	 $aux     $names[$_]\->hdrsv &&
	 ($names[$_]\->state & PDLA_HDRCPY)
	 ) {
	hdrp = $names[$_]\->hdrsv;
	propagate_hdrcpy = (($names[$_]\->state & PDLA_HDRCPY) != 0);
      }
HdRCHECK1
  ;
  }

  $str .= << 'DeePcOPY'
if (hdrp) {
  if(hdrp == &PL_sv_undef)
    hdr_copy = &PL_sv_undef;
  else  {  PDLA_COMMENT("Call the perl routine _hdr_copy...")
    int count;
    PDLA_COMMENT("Call the perl routine PDLA::_hdr_copy(hdrp)")
    dSP;
    ENTER ;
    SAVETMPS ;
    PUSHMARK(SP) ;
    XPUSHs( hdrp );
    PUTBACK ;
    count = call_pv("PDLA::_hdr_copy",G_SCALAR);
    SPAGAIN ;
    if(count != 1)
	croak("PDLA::_hdr_copy didn't return a single value - please report this bug (A).");

    hdr_copy = (SV *)POPs;

    if(hdr_copy && hdr_copy != &PL_sv_undef) {
       (void)SvREFCNT_inc(hdr_copy); PDLA_COMMENT("Keep hdr_copy from vanishing during FREETMPS")
    }

    FREETMPS ;
    LEAVE ;


  } PDLA_COMMENT("end of callback  block")

DeePcOPY
    ;
# if(hdrp) block is still open -- now reassign all the aliases...

  # Found the header -- now copy it into all the right places.
  foreach ( 0 .. $nn ) {
     $str .= <<"HdRCHECK2"
       if ( $names[$_]\->hdrsv != hdrp ){
	 if( $names[$_]\->hdrsv && $names[$_]\->hdrsv != &PL_sv_undef)
             (void)SvREFCNT_dec( $names[$_]\->hdrsv );
	 if( hdr_copy != &PL_sv_undef )
             (void)SvREFCNT_inc(hdr_copy);
	 $names[$_]\->hdrsv = hdr_copy;
       }
     if(propagate_hdrcpy)
       $names[$_]\->state |= PDLA_HDRCPY;
HdRCHECK2

      # QUESTION: what is the following line doing?
      #
      if ( $pobjs->{$pnames->[$_]}{FlagCreat} );
   }

  $str .= '
         if(hdr_copy != &PL_sv_undef)
            SvREFCNT_dec(hdr_copy); PDLA_COMMENT("make hdr_copy mortal again")
      } PDLA_COMMENT("end of if(hdrp) block")
   } PDLA_COMMENT("end of conv. block")
';
  return $str;

} # sub: hdrcheck()

sub make_redodims_thread {
    #my($pnames,$pobjs,$dobjs,$dpars,$pcode ) = @_;
    my($pnames,$pobjs,$dobjs,$dpars,$pcode, $noPthreadFlag) = @_;
    my $str; my $npdls = @$pnames;

    $noPthreadFlag = 0 unless( defined $noPthreadFlag ); # assume we can pthread, unless indicated otherwise

    my $nn = $#$pnames;
    my @privname = map { "\$PRIV(pdls[$_])" } ( 0 .. $nn );
    $str .= $npdls ? "PDLA_Indx __creating[$npdls];\n" : "PDLA_Indx __creating[1];\n";
    $str .= join '',map {$_->get_initdim."\n"} values %$dobjs;

    # if FlagCreat is NOT true, then we set __creating[] to 0
    # and we can use this knowledge below, and in hdrcheck()
    # and in PP/PdlParObj (get_xsnormdimchecks())
    #
    foreach ( 0 .. $nn ) {
	$str .= "__creating[$_] = ";
	if ( $pobjs->{$pnames->[$_]}{FlagCreat} ) {
	    $str .= "PDLA_CR_SETDIMSCOND(__privtrans,$privname[$_]);\n";
	} else {
	    $str .= "0;\n";
	}
    } # foreach: 0 .. $nn

    $str .= " {\n$pcode\n}\n";
    $str .= " {\n " . make_parnames($pnames,$pobjs,$dobjs) . "
		 PDLA->initthreadstruct(2,\$PRIV(pdls),
			__realdims,__creating,$npdls,
                      &__einfo,&(\$PRIV(__pdlthread)),
                        \$PRIV(vtable->per_pdl_flags),
			$noPthreadFlag );
		}\n";
    $str .= join '',map {$pobjs->{$_}->get_xsnormdimchecks()} @$pnames;
    $str .= hdrcheck($pnames,$pobjs);
    $str .= join '',map {$pobjs->{$pnames->[$_]}->
			     get_incsets($privname[$_])} 0..$nn;
    return $str;

} # sub: make_redodims_thread()

sub XSHdr {
	my($xsname,$nxargs) = @_;
	return PDLA::PP::XS::mkproto($xsname,$nxargs);
}

###########################################################
# 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
#            :
#            :   Signature: (
#            :                be multiline>)
#            :
#            :
#            : 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;
}


# Build the valid-types regex and valid Pars argument only once. These are
# also used in PDLA::PP::PdlParObj, which is why they are globally available.
use PDLA::PP::PdlParObj;
my $pars_re = $PDLA::PP::PdlParObj::pars_re;

###########################################################
# Name       : build_pars_from_fulldoc
# Usage      : $pars = build_pars_from_fulldoc($fulldoc)
# Purpose    : extract the Pars from the signature from the fulldoc string,
#            : the part of the signature that specifies the piddles
# 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 PDLA 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 build_pars_from_fulldoc {
	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 PDLA 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 PDLA arguments') if @pars == 0;

	# All done!
	return join('; ', @pars);
}

###########################################################
# Name       : build_otherpars_from_fulldoc
# Usage      : $otherpars = build_otherpars_from_fulldoc($fulldoc)
# Purpose    : extract the OtherPars from the signature from the fulldoc
#            : string, the part of the signature that specifies non-piddle
#            : arguments
# Returns    : a string appropriate for the OtherPars key
# Parameters : $fulldoc
# Throws     : if some OtherPars arguments come before the last PDLA 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 build_otherpars_from_fulldoc {
	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 PDLA 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);
}

# Set up the rules for translating the pp_def contents.
#
$PDLA::PP::deftbl =
  [
   # 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
   # undef - we're not compiling with bad value support
   #
   PDLA::PP::Rule->new("BadFlag", "_HandleBad",
		      "Sets BadFlag based upon HandleBad key and PDLA's ability to handle bad values",
		      sub { return (defined $_[0]) ? ($bvalflag and $_[0]) : undef; }),

   ####################
   # FullDoc Handling #
   ####################

   # Error processing: does FullDoc contain BadDoc, yet BadDoc specified?
   PDLA::PP::Rule::Croak->new(['FullDoc', 'BadDoc'],
       'Cannot have both FullDoc and BadDoc defined'),
   PDLA::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
   PDLA::PP::Rule->new('Pars', 'FullDoc',
      'Sets the Pars from the FullDoc if Pars is not explicitly specified',
      \&build_pars_from_fulldoc
   ),
   PDLA::PP::Rule->new('OtherPars', 'FullDoc',
      'Sets the OtherPars from the FullDoc if OtherPars is not explicitly specified',
      \&build_otherpars_from_fulldoc
   ),

   ################################
   # Other Documentation Handling #
   ################################

   # no docs by default
   PDLA::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

   PDLA::PP::Rule->new("BadDoc", ["BadFlag","Name","_CopyBadStatusCode"],
              'Sets the default documentation for handling of bad values',
      sub {
         return undef unless $bvalflag;
         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 piddles.\n";
         }
         if ( not defined($code) ) {
            $str .= "It will set the bad-value flag of all output piddles if " .
            "the flag is set for any of the input piddles.\n";
         } elsif (  $code eq '' ) {
            $str .= "The output piddles will NOT have their bad-value flag set.\n";
         } else {
            $str .= "The state of the bad-value flag of the output piddles is unknown.\n";
         }
      }
   ),

   # Default: no otherpars
   PDLA::PP::Rule::Returns::EmptyString->new("OtherPars"),

   # the docs
   PDLA::PP::Rule->new("PdlDoc", "FullDoc", sub {
         my $fulldoc = shift;

         # Remove bad documentation if bad values are not supported
         $fulldoc =~ s/=for bad\n\n.*?\n\n//s unless $bvalflag;

         # 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;
      }
   ),
   PDLA::PP::Rule->new("PdlDoc", ["Name","_Pars","OtherPars","Doc","_BadDoc"], \&GenDocs),

   ##################
   # 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

# some defaults
#
   PDLA::PP::Rule::Returns->new("CopyName", [],
       'Sets the CopyName key to the default: __copy', "__copy"),

   PDLA::PP::Rule->new("DefaultFlowCodeNS", "_DefaultFlow",
       'Sets the code to handle dataflow flags, if applicable',
		      sub { $_[0] ?
			      '$PRIV(flags) |= PDLA_ITRANS_DO_DATAFLOW_F | PDLA_ITRANS_DO_DATAFLOW_B;'
				: 'PDLA_COMMENT("No flow")'}),

# Question: where is ppdefs defined?
# Answer: Core/Types.pm
#
   PDLA::PP::Rule->new("GenericTypes", [],
       'Sets GenericTypes flag to all types known to PDLA::Types',
       sub {[ppdefs]}),

   PDLA::PP::Rule->new("ExtraGenericLoops", "FTypes",
       'Makes ExtraGenericLoops identical to FTypes if the latter exists and the former does not',
       sub {return $_[0]}),
   PDLA::PP::Rule::Returns->new("ExtraGenericLoops", [],
		'Sets ExtraGenericLoops to an empty hash if it does not already exist', {}),

   PDLA::PP::Rule::InsertName->new("StructName", 'pdl_${name}_struct'),
   PDLA::PP::Rule::InsertName->new("VTableName", 'pdl_${name}_vtable'),

   PDLA::PP::Rule->new("FHdrInfo", ["Name","StructName"],
		      sub { return { Name => $_[0], StructName => $_[1], }; }),

# Treat exchanges as affines. Affines assumed to be parent->child.
# Exchanges may, if the want, handle threadids as well.
# Same number of dimensions is assumed, though.
#
   PDLA::PP::Rule->new("AffinePriv", "XCHGOnly", sub { return @_; }),
   PDLA::PP::Rule::Returns->new("Priv", "AffinePriv", 'PDLA_Indx incs[$CHILD(ndims)];PDLA_Indx offs; '),
   PDLA::PP::Rule::Returns->new("IsAffineFlag", "AffinePriv", "PDLA_ITRANS_ISAFFINE"),

   PDLA::PP::Rule->new("RedoDims", ["EquivPDimExpr","FHdrInfo","_EquivDimCheck"],
		      \&pdimexpr2priv),
   PDLA::PP::Rule->new("RedoDims", ["Identity","FHdrInfo"],
		      \&identity2priv),

 # NOTE: we use the same bit of code for all-good and bad data -
 #  see the Code rule
#
   PDLA::PP::Rule->new("EquivCPOffsCode", "Identity",
		      "something to do with dataflow between CHILD & PARENT, I think.",
		      \&equivcpoffscode),

   PDLA::PP::Rule->new("Code", ["EquivCPOffsCode","BadFlag"],
		      "create Code from EquivCPOffsCode",
		      \&CodefromEquivCPOffsCode),

   PDLA::PP::Rule->new("BackCode", ["EquivCPOffsCode","BadFlag"],
		      "create BackCode from EquivCPOffsCode",
		      \&BackCodefromEquivCPOffsCode),

   PDLA::PP::Rule::Returns::Zero->new("Affine_Ok", "EquivCPOffsCode"),
   PDLA::PP::Rule::Returns::One->new("Affine_Ok"),

   PDLA::PP::Rule::Returns::NULL->new("ReadDataFuncName", "AffinePriv"),
   PDLA::PP::Rule::Returns::NULL->new("WriteBackDataFuncName", "AffinePriv"),

   PDLA::PP::Rule::InsertName->new("ReadDataFuncName", 'pdl_${name}_readdata'),
   PDLA::PP::Rule::InsertName->new("CopyFuncName",     'pdl_${name}_copy'),
   PDLA::PP::Rule::InsertName->new("FreeFuncName",     'pdl_${name}_free'),
   PDLA::PP::Rule::InsertName->new("RedoDimsFuncName", 'pdl_${name}_redodims'),

   # There used to be a BootStruct rule which just became copied to the XSBootCode
   # rule, so it has been removed.
   #
   PDLA::PP::Rule->new("XSBootCode", ["AffinePriv","VTableName"],
		      sub {return "   $_[1].readdata = PDLA->readdata_affine;\n" .
			     "   $_[1].writebackdata = PDLA->writebackdata_affine;\n"}),

# Parameters in the form 'parent and child(this)'.
# The names are PARENT and CHILD.
#
# P2Child implicitly means "no data type changes".

   PDLA::PP::Rule->new(["USParNames","USParObjs","FOOFOONoConversion","HaveThreading","NewXSName"],
		      ["P2Child","Name","BadFlag"],
		      \&NewParentChildPars),

   PDLA::PP::Rule::InsertName->new("NewXSName", '_${name}_int'),

   PDLA::PP::Rule::Returns->new("EquivPThreadIdExpr", "P2Child",
			       '$CTID-$PARENT(ndims)+$CHILD(ndims)'),

   PDLA::PP::Rule::Returns::One->new("HaveThreading"),

# Parameters in the 'a(x,y); [o]b(y)' format, with
# fixed nos of real, unthreaded-over dims.
#
# XXX
# - the need for BadFlag is due to hacked get_xsdatapdecl()
#   in PP/PdlParObj and because the PdlParObjs are created by
#   PDLA::PP::Signature (Doug Burke 07/08/00)

   PDLA::PP::Rule->new(["USParNames","USParObjs","DimmedPars"], ["Pars","BadFlag"], \&Pars_nft),
   PDLA::PP::Rule->new("DimObjs", ["USParNames","USParObjs"], \&ParObjs_DimObjs),

 # Set CallCopy flag for simple functions (2-arg with 0-dim signatures)
 #   This will copy the $object->copy method, instead of initialize
 #   for PDLA-subclassed objects
 #
   PDLA::PP::Rule->new("CallCopy", ["DimObjs", "USParNames", "USParObjs", "Name", "_P2Child"],
		      sub {
			  my ($dimObj, $USParNames, $USParObjs, $Name, $hasp2c) = @_;
			  return 0 if $hasp2c;
			  my $noDimmedArgs = scalar(keys %$dimObj);
			  my $noArgs = scalar(@$USParNames);
			  if( $noDimmedArgs == 0 and $noArgs == 2  ){
			      # Check for 2-arg functgion with 0-dim signatures
			      # Check to see if output arg is _not_ explicitly typed:
			      my $arg2 = $USParNames->[1];
			      my $ParObj = $USParObjs->{$arg2};
			      if( $ParObj->ctype('generic') eq 'generic'){
				  # print "Calling Copy for function '$Name'\n";
				  return 1;
			      }
			  }
			  return 0;
		      }),

# "Other pars", the parameters which are usually not pdls.

   PDLA::PP::Rule->new(["OtherParNames","OtherParTypes"], ["OtherPars","DimObjs"], \&OtherPars_nft),

   PDLA::PP::Rule->new(["ParNames","ParObjs"], ["USParNames","USParObjs"], \&sort_pnobjs),

   PDLA::PP::Rule->new("DefSyms", "StructName", \&MkDefSyms),
   PDLA::PP::Rule->new("NewXSArgs", ["USParNames","USParObjs","OtherParNames","OtherParTypes"],
		      \&NXArgs),

   PDLA::PP::Rule::Returns->new("PMCode", undef),

   PDLA::PP::Rule->new("NewXSSymTab", ["DefSyms","NewXSArgs"], \&AddArgsyms),

   PDLA::PP::Rule->new("InplaceCode", ["Name","NewXSArgs","USParObjs","_Inplace"],
		      'Insert code (just after HdrCode) to ensure the routine can be done inplace',
		      \&InplaceCode),

   PDLA::PP::Rule::Returns::EmptyString->new("HdrCode", [],
					    'Code that will be inserted at the end of the autogenerated xs argument processing code VargArgsXSHdr'),


 # Create header for variable argument list.  Used if no 'other pars' specified.
 # D. Hunt 4/11/00
 # make sure it is not used when the GlobalNew flag is set ; CS 4/15/00
   PDLA::PP::Rule->new("VarArgsXSHdr",
		      ["Name","NewXSArgs","USParObjs","OtherParTypes",
		       "PMCode","HdrCode","InplaceCode","_GlobalNew","_CallCopy"],
		      'XS code to process arguments on stack based on supplied Pars argument to pp_def; GlobalNew has implications how/if this is done',
		      \&VarArgsXSHdr),

 ## Added new line for returning (or not returning) variables.  D. Hunt 4/7/00
 # make sure it is not used when the GlobalNew flag is set ; CS 4/15/00
 #
   PDLA::PP::Rule->new("VarArgsXSReturn",
		      ["NewXSArgs","USParObjs","_GlobalNew"],
		      "Generate XS trailer for returning output variables",
		      \&VarArgsXSReturn),

   PDLA::PP::Rule->new("NewXSHdr", ["NewXSName","NewXSArgs"], \&XSHdr),
   PDLA::PP::Rule->new("NewXSCHdrs", ["NewXSName","NewXSArgs","GlobalNew"], \&XSCHdrs),
   PDLA::PP::Rule->new("NewXSLocals", "NewXSSymTab", \&Sym2Loc),

   PDLA::PP::Rule::Returns::Zero->new("IsAffineFlag"),
   PDLA::PP::Rule::Returns::Zero->new("NoPdlThread"),

# hmm, need to check on conditional check here (or rather, other bits of code prob need
# to include it too; see Ops.xs, PDLA::assgn)
##
##           sub { return (defined $_[0]) ? "int \$BADFLAGCACHE() = 0;" : ""; } ],
##
## why have I got a "_HandleBad" condition here? it isn't used in the routine
## and isn't required to fire the rule. Or should we actually check the value of
## HandleBad (ie to optimize for code that explicitly doesn't handle bad code)?
## TO DO: Check assgn in ops for this? Not obvious, or at least we need other
## bits of code work with us (eg the checking of $BADFLAGCACHE in some other
## rule)
##
##    PDLA::PP::Rule->new("CacheBadFlagInitNS", "_HandleBad",
##		      sub { return $bvalflag ? "\n  int \$BADFLAGCACHE() = 0;\n" : ""; }),
    PDLA::PP::Rule->new("CacheBadFlagInitNS",
		      sub { return $bvalflag ? "\n  int \$BADFLAGCACHE() = 0;\n" : ""; }),
# The next rule, if done in place of the above, causes Ops.xs to fail to compile
#    PDLA::PP::Rule->new("CacheBadFlagInitNS", "BadFlag",
#		      sub { return $_[0] ? "\n  int \$BADFLAGCACHE() = 0;\n" : ""; }),
   PDLA::PP::Rule::Substitute::Usual->new("CacheBadFlagInit", "CacheBadFlagInitNS"),

    # need special cases for
    # a) bad values
    # b) bad values + GlobalNew
    # c) bad values + PMCode
    # - perhaps I should have separate rules (but b and c produce the
    #   same output...)
    #
   PDLA::PP::Rule->new("NewXSStructInit0",
		      ["NewXSSymTab","VTableName","IsAffineFlag","NoPdlThread"],
		      "Rule to create and initialise the private trans structure",
		      \&MkPrivStructInit),

   PDLA::PP::Rule->new("NewXSMakeNow", ["ParNames","NewXSSymTab"], \&MakeNows),
   PDLA::PP::Rule->new("IgnoreTypesOf", "FTypes", sub {return {map {($_,1)} keys %{$_[0]}}}),
   PDLA::PP::Rule::Returns->new("IgnoreTypesOf", {}),

   PDLA::PP::Rule->new("NewXSCoerceMustNS", "FTypes", \&make_newcoerce),
   PDLA::PP::Rule::Substitute::Usual->new("NewXSCoerceMust", "NewXSCoerceMustNS"),

   PDLA::PP::Rule::Substitute::Usual->new("DefaultFlowCode", "DefaultFlowCodeNS"),

   PDLA::PP::Rule->new("NewXSFindDatatypeNS",
		      ["ParNames","ParObjs","IgnoreTypesOf","NewXSSymTab","GenericTypes","_P2Child"],
		      \&find_datatype),
   PDLA::PP::Rule::Substitute::Usual->new("NewXSFindDatatype", "NewXSFindDatatypeNS"),

   PDLA::PP::Rule::Returns::EmptyString->new("NewXSTypeCoerce", "NoConversion"),

   PDLA::PP::Rule->new("NewXSTypeCoerceNS",
		      ["ParNames","ParObjs","IgnoreTypesOf","NewXSSymTab","_P2Child"],
		      \&coerce_types),
   PDLA::PP::Rule::Substitute::Usual->new("NewXSTypeCoerce", "NewXSTypeCoerceNS"),

   PDLA::PP::Rule::Returns::EmptyString->new("NewXSStructInit1", ["ParNames","NewXSSymTab"]),

   PDLA::PP::Rule->new("NewXSSetTrans", ["ParNames","ParObjs","NewXSSymTab"], \&makesettrans),

   PDLA::PP::Rule->new("ParsedCode",
		      ["Code","_BadCode","ParNames","ParObjs","DimObjs","GenericTypes",
		       "ExtraGenericLoops","HaveThreading","Name"],
		      sub { return PDLA::PP::Code->new(@_); }),
   PDLA::PP::Rule->new("ParsedBackCode",
		      ["BackCode","_BadBackCode","ParNames","ParObjs","DimObjs","GenericTypes",
		       "ExtraGenericLoops","HaveThreading","Name"],
		      sub { return PDLA::PP::Code->new(@_, undef, undef, 'BackCode2'); }),

# Compiled representations i.e. what the xsub function leaves
# in the trans 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 his own code and compiled representation,
# The next two definitions allow this.
# Because of substitutions that will be there,
# makecompiledrepr et al are array refs, 0th element = string,
# 1th element = hashref of translated names
# This makes the objects: type + ...
#
   PDLA::PP::Rule->new(["CompNames","CompObjs"], "Comp", \&OtherPars_nft),
   PDLA::PP::Rule->new("CompiledRepr", ["CompNames","CompObjs"], \&NT2Decls_p),
   PDLA::PP::Rule::MakeComp->new("MakeCompiledRepr", ["MakeComp","CompNames","CompObjs"],
				"COMP"),

   PDLA::PP::Rule->new("CompCopyCode", ["CompNames","CompObjs","CopyName"], \&NT2Copies_p),
   PDLA::PP::Rule->new("CompFreeCode", ["CompNames","CompObjs"], \&NT2Free_p),

# This is the default
#
   PDLA::PP::Rule->new("MakeCompiledRepr",
		      ["OtherParNames","OtherParTypes","NewXSSymTab"],
		      \&CopyOtherPars),
   PDLA::PP::Rule->new("CompiledRepr",
		      ["OtherParNames","OtherParTypes"],
		      \&NT2Decls),
   PDLA::PP::Rule->new("CompCopyCode",
		      ["OtherParNames","OtherParTypes","CopyName"],
		      \&NT2Copies_p),
   PDLA::PP::Rule->new("CompFreeCode", ["OtherParNames","OtherParTypes"], \&NT2Free_p),

# Threads
#
   PDLA::PP::Rule->new(["Priv","PrivIsInc"],
		      ["ParNames","ParObjs","DimObjs","HaveThreading"],
		      \&make_incsizes),
   PDLA::PP::Rule->new("PrivCopyCode",
		      ["ParNames","ParObjs","DimObjs","CopyName","HaveThreading"],
		      \&make_incsize_copy),
   PDLA::PP::Rule->new("PrivFreeCode",
		      ["ParNames","ParObjs","DimObjs","HaveThreading"],
		      "Frees the thread",
		      \&make_incsize_free),

   PDLA::PP::Rule::Returns->new("RedoDimsCode", [],
			       'Code that can be inserted to set the size of output piddles dynamically based on input piddles; is parsed',
			       'PDLA_COMMENT("none")'),
   PDLA::PP::Rule->new("RedoDimsParsedCode",
		      ["RedoDimsCode","_BadRedoDimsCode","ParNames","ParObjs","DimObjs",
		       "GenericTypes","ExtraGenericLoops","HaveThreading","Name"],
		      'makes the parsed representation from the supplied RedoDimsCode',
		      sub {
			  return 'PDLA_COMMENT("no RedoDimsCode")'
			    if $_[0] =~ m|^/[*] none [*]/$|;
			  PDLA::PP::Code->new(@_,1); }),
   PDLA::PP::Rule->new("RedoDims",
		      ["ParNames","ParObjs","DimObjs","DimmedPars","RedoDimsParsedCode", '_NoPthread'],
		      'makes the redodims function from the various bits and pieces',
		      \&make_redodims_thread),

   PDLA::PP::Rule::Returns::EmptyString->new("Priv"),

   PDLA::PP::Rule->new(["PrivNames","PrivObjs"], "Priv", \&OtherPars_nft),
   PDLA::PP::Rule->new("PrivateRepr", ["PrivNames","PrivObjs"], \&NT2Decls_p),
   PDLA::PP::Rule->new("PrivCopyCode", ["PrivNames","PrivObjs","CopyName"], \&NT2Copies_p),

# avoid clash with freecode above?
#
   PDLA::PP::Rule->new("NTPrivFreeCode", ["PrivNames","PrivObjs"], \&NT2Free_p),

   PDLA::PP::Rule->new("IsReversibleCodeNS", "Reversible", \&ToIsReversible),
   PDLA::PP::Rule::Substitute::Usual->new("IsReversibleCode", "IsReversibleCodeNS"),

   # Needs cleaning up. NewXSStructInit2DJB has been added to make use
   # of the PDLA::PP::Rule::Substitute class.
   #
   PDLA::PP::Rule::Substitute->new("NewXSStructInit2DJB", "MakeCompiledRepr"),
   PDLA::PP::Rule->new("NewXSStructInit2", "NewXSStructInit2DJB",
 		      sub { return "{".$_[0]."}"; }),

   PDLA::PP::Rule->new("CopyCodeNS",
		      ["PrivCopyCode","CompCopyCode","StructName","NoPdlThread"],
		      sub {
			  return
			    "$_[2] *__copy = malloc(sizeof($_[2]));\n" .
			($_[3] ? "" : "PDLA_THR_CLRMAGIC(&__copy->__pdlthread);") .
"			PDLA_TR_CLRMAGIC(__copy);
                        __copy->has_badvalue = \$PRIV(has_badvalue);
                        __copy->badvalue = \$PRIV(badvalue);
			__copy->flags = \$PRIV(flags);
			__copy->vtable = \$PRIV(vtable);
			__copy->__datatype = \$PRIV(__datatype);
			__copy->freeproc = NULL;
			__copy->__ddone = \$PRIV(__ddone);
			{int i;
			 for(i=0; i<__copy->vtable->npdls; i++)
				__copy->pdls[i] = \$PRIV(pdls[i]);
			}
			$_[1]
			if(__copy->__ddone) {
				$_[0]
			}
			return (pdl_trans*)__copy;"; }),

   PDLA::PP::Rule->new("FreeCodeNS",
		      ["PrivFreeCode","CompFreeCode","NTPrivFreeCode"],
		      sub {
			  return "
			PDLA_TR_CLRMAGIC(__privtrans);
			$_[1]
			if(__privtrans->__ddone) {
				$_[0]
				$_[2]
			}
			"; }),

   PDLA::PP::Rule::Substitute::Usual->new("CopyCode", "CopyCodeNS"),
   PDLA::PP::Rule::Substitute::Usual->new("FreeCode", "FreeCodeNS"),
   PDLA::PP::Rule::Substitute::Usual->new("FooCodeSub", "FooCode"),

   PDLA::PP::Rule::Returns::EmptyString->new("NewXSCoerceMust"),

   PDLA::PP::Rule::MakeComp->new("NewXSCoerceMustSub1", "NewXSCoerceMust", "FOO"),
   PDLA::PP::Rule::Substitute->new("NewXSCoerceMustSub1d", "NewXSCoerceMustSub1"),

   PDLA::PP::Rule->new("NewXSClearThread", "HaveThreading",
		      sub {$_[0] ? "__privtrans->__pdlthread.inds = 0;" : ""}),

   PDLA::PP::Rule->new("NewXSFindBadStatusNS",
		      ["BadFlag","_FindBadStatusCode","NewXSArgs","USParObjs","OtherParTypes","NewXSSymTab","Name"],
		      "Rule to find the bad value status of the input piddles",
		      \&findbadstatus),

    # this can be removed once the default bad values are stored in a C structure
    # (rather than as a perl array in PDLA::Types)
    # which it now is, hence the comments (DJB 07/10/00)
    # - left around in case we move to per-piddle bad values
    # - NOTE: now we have the experimental per-piddle bad values I need to remember
    #         what I was doing here
# [[NewXSCopyBadValues], [BadFlag,NewXSSymTab],
#    "copybadvalues",
#    "Rule to copy the default bad values into the trnas structure"],

   PDLA::PP::Rule->new("NewXSCopyBadStatusNS",
		      ["BadFlag","_CopyBadStatusCode","NewXSArgs","USParObjs","NewXSSymTab"],
		      "Rule to copy the bad value status to the output piddles",
		      \©badstatus),

 # expand macros in ...BadStatusCode
 #
   PDLA::PP::Rule::Substitute::Usual->new("NewXSFindBadStatus", "NewXSFindBadStatusNS"),
   PDLA::PP::Rule::Substitute::Usual->new("NewXSCopyBadStatus", "NewXSCopyBadStatusNS"),

 # Generates XS code with variable argument list.  If this rule succeeds, the next rule
 # will not be executed. D. Hunt 4/11/00
 #
   PDLA::PP::Rule->new(["NewXSCode","BootSetNewXS","NewXSInPrelude"],
		      ["_GlobalNew","_NewXSCHdrs","VarArgsXSHdr","NewXSLocals",
		       "CacheBadFlagInit",
		       "NewXSStructInit0",
		       "NewXSFindBadStatus",
		       #     NewXSCopyBadValues,
		       #     NewXSMakeNow,  # this is unnecessary since families never got implemented
		       "NewXSFindDatatype","NewXSTypeCoerce",
		       "NewXSStructInit1",
		       "NewXSStructInit2",
		       "NewXSCoerceMustSub1d","_IsReversibleCode","DefaultFlowCode",
		       "NewXSClearThread",
		       "NewXSSetTrans",
		       "NewXSCopyBadStatus",
		       "VarArgsXSReturn"
		      ],
		      "Rule to print out XS code when variable argument list XS processing is enabled",
		      \&mkVarArgsxscat),

 # This rule will fail if the preceding rule succeeds
 # D. Hunt 4/11/00
 #
   PDLA::PP::Rule->new(["NewXSCode","BootSetNewXS","NewXSInPrelude"],
		      ["_GlobalNew","_NewXSCHdrs","NewXSHdr","NewXSLocals",
		       "CacheBadFlagInit",
		       "NewXSStructInit0",
		       "NewXSFindBadStatus",
		       #     NewXSCopyBadValues,
		       #     NewXSMakeNow, # this is unnecessary since families never got implemented
		       "NewXSFindDatatype","NewXSTypeCoerce",
		       "NewXSStructInit1",
		       "NewXSStructInit2",
		       "NewXSCoerceMustSub1d","_IsReversibleCode","DefaultFlowCode",
		       "NewXSClearThread",
		       "NewXSSetTrans",
		       "NewXSCopyBadStatus"
		      ],
		      "Rule to print out XS code when variable argument list XS processing is disabled",
		      \&mkxscat),

   PDLA::PP::Rule->new("StructDecl",
		      ["ParNames","ParObjs","CompiledRepr","PrivateRepr","StructName"],
		      \&mkstruct),

   # The RedoDimsSub rule is a bit weird since it takes in the RedoDims target
   # twice (directly and via RedoDims-PostComp). Can this be cleaned up?
   #
   PDLA::PP::Rule->new("RedoDims-PreComp", "RedoDims",
		      sub { return $_[0] . ' $PRIV(__ddone) = 1;'; }),
   PDLA::PP::Rule::MakeComp->new("RedoDims-PostComp",
				["RedoDims-PreComp", "PrivNames", "PrivObjs"], "PRIV"),
   PDLA::PP::Rule->new("RedoDimsSub",
		      ["RedoDims", "RedoDims-PostComp", "_DimObjs"],
		      sub {
			my $redodims = $_[0];
			my $result   = $_[1];
			my $dimobjs  = $_[2];

			$result->[1]{"SIZE"} = sub {
			  croak "can't get SIZE of undefined dimension (RedoDims=$redodims)."
			    unless defined $dimobjs->{$redodims};
			  return $dimobjs->{$redodims}->get_size();
			};
			return $result;
		      }),
   PDLA::PP::Rule::Substitute->new("RedoDimsSubd", "RedoDimsSub"),
   PDLA::PP::Rule->new("RedoDimsFunc",
		      ["RedoDimsSubd","FHdrInfo","RedoDimsFuncName","_P2Child"],
		      sub {wrap_vfn(@_,"redodims")}),

   PDLA::PP::Rule::MakeComp->new("ReadDataSub", "ParsedCode", "FOO"),
   PDLA::PP::Rule::Substitute->new("ReadDataSubd", "ReadDataSub"),
   PDLA::PP::Rule->new("ReadDataFunc",
		      ["ReadDataSubd","FHdrInfo","ReadDataFuncName","_P2Child"],
		      sub {wrap_vfn(@_,"readdata")}),

   PDLA::PP::Rule::MakeComp->new("WriteBackDataSub", "ParsedBackCode", "FOO"),
   PDLA::PP::Rule::Substitute->new("WriteBackDataSubd", "WriteBackDataSub"),

   PDLA::PP::Rule::InsertName->new("WriteBackDataFuncName", "BackCode", 'pdl_${name}_writebackdata'),
   PDLA::PP::Rule::Returns::NULL->new("WriteBackDataFuncName", "Code"),

   PDLA::PP::Rule->new("WriteBackDataFunc",
		      ["WriteBackDataSubd","FHdrInfo","WriteBackDataFuncName","_P2Child"],
		      sub {wrap_vfn(@_,"writebackdata")}),,

   PDLA::PP::Rule->new("CopyFunc",
		      ["CopyCode","FHdrInfo","CopyFuncName","_P2Child"],
		      sub {wrap_vfn(@_,"copy")}),
   PDLA::PP::Rule->new("FreeFunc",
		      ["FreeCode","FHdrInfo","FreeFuncName","_P2Child"],
		      sub {wrap_vfn(@_,"free")}),

   PDLA::PP::Rule::Returns->new("FoofName", "FooCodeSub", "foomethod"),
   PDLA::PP::Rule->new("FooFunc", ["FooCodeSub","FHdrInfo","FoofName","_P2Child"],
		      sub {wrap_vfn(@_,"foo")}),

   PDLA::PP::Rule::Returns::NULL->new("FoofName"),

   PDLA::PP::Rule->new("VTableDef",
		      ["VTableName","StructName","RedoDimsFuncName","ReadDataFuncName",
		       "WriteBackDataFuncName","CopyFuncName","FreeFuncName",
		       "ParNames","ParObjs","Affine_Ok","FoofName"],
		      \&def_vtable),

   # Maybe accomplish this with an InsertName rule?
   PDLA::PP::Rule->new('PMFunc', 'Name',
           'Sets PMFunc to default symbol table manipulations',
           sub {
               my ($name) = @_;
               $::PDLA_IFBEGINWRAP[0].'*'.$name.' = \&'.$::PDLAOBJ.
                         '::'.$name.";\n".$::PDLA_IFBEGINWRAP[1]
           }
    ),

];

sub printtrans {
	my($bar) = @_;
	for (qw/StructDecl RedoDimsFunc ReadDataFunc WriteBackFunc
		VTableDef NewXSCode/) {
		print "\n\n================================================
	$_
=========================================\n",$bar->{$_},"\n" if $::PP_VERBOSE;
	}
}

sub translate {
    my ($pars,$tbl) = @_;

    foreach my $rule (@$tbl) {
	$rule->apply($pars);
    }

#	print Dumper($pars);
    print "GOING OUT!\n" if $::PP_VERBOSE;
    return $pars;
} # sub: translate()

## End
#