#####################################################################
#####################################################################
##
##
## Here starts the actual thing.
##
## This is way too messy and uncommented. Still. :(
#
package PDL::PP;
use PDL::Types ':All';
use Config;
use FileHandle;
use Exporter;
@ISA = qw(Exporter);

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

$PDL::PP::VERSION = 2.2;
$PDL::PP::done = 0;  # pp_done has not been called yet

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

use Carp;

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

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

# use strict qw/vars refs/;

use strict;

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

sub import {
	my ($mod,$modname, $packname, $prefix, $callpack) = @_;
	$::PDLMOD=$modname; $::PDLPACK=$packname; $::PDLPREF=$prefix;
	$::CALLPACK = defined $callpack ? $callpack : $::PDLMOD;
	$::PDLOBJ = "PDL"; # define pp-funcs in this package
	$::PDLXS="";
	$::PDLBEGIN="";
	$::PDLPMROUT="";
 	for ('Top','Bot','Middle') { $::PDLPM{$_}="" }
	@::PDLPMISA=('PDL::Exporter', 'DynaLoader');
	@::PDL_IFBEGINWRAP = ('','');
	$::PDLVERSIONSET = '';
	$::PDLMODVERSION = undef;
	$::DOCUMENTED = 0;
	$::PDLCOREIMPORT = "";  #import list from core, defaults to everything, i.e. use Core
				#  could be set to () for importing nothing from core. or qw/ barf / for
				# importing barf only.
	@_=("PDL::PP");
	goto &Exporter::import;
}


# query/set boungschecking
# if on the generated XS code will have optional boundschecking
# that can be turned on/off at runtime(!) using
#   __PACKAGE__::set_boundscheck(arg); # arg should be 0/1
# if off code is speed optimized and no runtime boundschecking
# can be performed
# ON by default
sub pp_boundscheck {
  my $ret = $PP::boundscheck;
  $PP::boundscheck = $_[0] if $#_ > -1;
  return $ret;
}

sub pp_beginwrap {
	@::PDL_IFBEGINWRAP = ('BEGIN {','}');
}

sub pp_setversion {
	my ($ver) = @_;
	$::PDLMODVERSION = '$VERSION';
	$::PDLVERSIONSET = "\$$::PDLPACK\::VERSION = $ver;";
}

sub pp_addhdr {
	my ($hdr) = @_;
	$::PDLXSC .= $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';
 	}
 	$::PDLPM{$pos} .= "$pm\n\n";
}

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

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

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

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

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

sub pp_bless{
   my($new_package)=@_;
   $::PDLOBJ = $new_package;
}

# sub to call to set the import list from core on the 'Use Core' line in the .pm file.
#   set to '()' to not import anything from Core, or 'qw/ barf /' to import barf.
sub pp_core_importList{
   $::PDLCOREIMPORT = $_[0];
}

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

sub pp_addxs {
	PDL::PP->printxs("\nMODULE = $::PDLMOD PACKAGE = $::CALLPACK\n\n",
                         @_,
                         "\nMODULE = $::PDLMOD PACKAGE = $::PDLOBJ\n\n");
}

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

sub pp_done {
        return if $PDL::PP::done; # do only once!
        $PDL::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 PDL::PP version $PDL::PP::VERSION...\n" if nopm();
	(my $fh = new FileHandle(">$::PDLPREF.xs")) or die "Couldn't open xs file\n";

$fh->print(qq%
/*
 * THIS FILE WAS GENERATED BY PDL::PP! Do not modify!
 */
#include "EXTERN.h"
#include "perl.h"
#include "XSUB.h"
#include "pdl.h"
#include "pdlcore.h"
static Core* PDL; /* Structure hold core C functions */
static int __pdl_debugging = 0;
static int __pdl_boundscheck = 0;
static SV* CoreSV;       /* Gets pointer to perl var holding core structure */

/* we need to handle croak ourserlves */
/* #undef croak
   #define croak barf
 */

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

$::PDLXSC

MODULE = $::PDLMOD PACKAGE = $::PDLMOD

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 $::PDLMOD");
       RETVAL = __pdl_boundscheck;
       __pdl_boundscheck = i;
       OUTPUT:
       RETVAL


MODULE = $::PDLMOD PACKAGE = $::PDLOBJ

$::PDLXS

BOOT:

   /* Get pointer to structure of core shared C routines */
   /* make sure PDL::Core is loaded */
   perl_require_pv("PDL::Core");
   CoreSV = perl_get_sv("PDL::SHARE",FALSE);  /* SV* value */
#ifndef aTHX_
#define aTHX_
#endif
   if (CoreSV==NULL)
     Perl_croak(aTHX_ "Can't load PDL::Core module");
   PDL = INT2PTR(Core*, SvIV( CoreSV ));  /* Core* value */
   if (PDL->Version != PDL_CORE_VERSION)
     Perl_croak(aTHX_ "$::PDLMOD needs to be recompiled against the newly installed PDL");
   $::PDLXSBOOT
%);

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

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

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

use PDL::Core$::PDLCOREIMPORT;
use PDL::Exporter;
use DynaLoader;


$::PDL_IFBEGINWRAP[0]
   $::PDLVERSIONSET
   \@ISA    = ( $::PDLPMISA );
   push \@PDL::Core::PP, __PACKAGE__;
   bootstrap $::PDLMOD $::PDLMODVERSION;
$::PDL_IFBEGINWRAP[-1]

$::PDLBEGIN

$::PDLPM{Top}

$::FUNCSPOD

$::PDLPM{Middle};

$::PDLPM{Bot}

# Exit with OK status

1;

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

sub pp_def {
	my($name,%hash) = @_;
	$hash{Name} = $name;
	translate(\%hash,$PDL::PP::deftbl);
	my $obj = \%hash;
	if($hash{Dump}) {
		print Dumper(\%hash)if $::PP_VERBOSE ;
	}
	if(!$obj->{FreeFunc}) {
		croak("Cannot free this obj!\n");
	}
	PDL::PP->printxsc(join "\n\n",@$obj{'StructDecl','RedoDimsFunc',
		'CopyFunc',
		'ReadDataFunc','WriteBackDataFunc',
		'FreeFunc',
		'FooFunc',
		'VTableDef','NewXSInPrelude',
		}
		);
	PDL::PP->printxs($$obj{NewXSCode});
	pp_add_boot($$obj{XSBootCode} . $$obj{BootSetNewXS});
	PDL::PP->pp_add_exported($name);
	PDL::PP::pp_addpm("\n".$$obj{PdlDoc}."\n") if $$obj{PdlDoc};
	PDL::PP::pp_addpm($$obj{PMCode});
	if(defined($$obj{PMFunc})) {
		pp_addpm($$obj{PMFunc}."\n");
	}else{
                pp_addpm($::PDL_IFBEGINWRAP[0].'*'.$name.' = \&'.$::PDLOBJ.
                         '::'.$name.";\n".$::PDL_IFBEGINWRAP[1]);
	}
}


# 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

# Rule table syntax:
# make  $_->[0] from $_->[1].
# use "=" to assign to 1. unless "_" appended to parname, then use ".="

use PDL::PP::Signature;
use PDL::PP::Dims;
use PDL::PP::CType;
use PDL::PP::XS;
use PDL::PP::SymTab;
use PDL::PP::PDLCode;

$|=1;

# don't bother with strictness here, as it would mean to much to change
no strict;

$PDL::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
    # 
 [[BadFlag], [_HandleBad], 
           sub { return (defined $_[0]) ? ($bvalflag and $_[0]) : undef; }],

 [[CopyName],	[],	sub {"__copy"}],
 [[DefaultFlow], [],	sub {0}],
 [[DefaultFlowCodeNS] ,[DefaultFlow],
 	sub {$_[0]?'$PRIV(flags) |= PDL_ITRANS_DO_DATAFLOW_F | PDL_ITRANS_DO_DATAFLOW_B;':"/* No flow: $_[0] */"}],

# no docs by default
    [[Doc],        [],     sub {"\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
#
    [[BadDoc],   [BadFlag,Name,_CopyBadStatusCode], 
          sub { return undef unless $bvalflag;  
		my ( $bf, $name, $code ) = @_;
		my $str;
		if ( ! defined($bf) ) {
		    $str = "$name does not process bad values.\n";
		} elsif ( $bf ) {
		    $str = "$name does handle bad values.\n";
		} else {
		    $str = "$name ignores the bad-value flag of the input piddles.\n";
		}
		if ( ! 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";
		}
	    }],
 
# no p2child by default
 [ [HASP2Child],   [P2Child],   sub {return $_[0] != 0}],
 [ [HASP2Child],   [],     sub {0}],
# Default: no otherpars
 [[OtherPars],	[],	sub {""}],
# [[Comp],	[],	sub {""}],
# some defaults
 [[GenericTypes],	[],	sub {[ppdefs]}],
 [[ExtraGenericLoops],	[FTypes],	sub {return $_[0]}],
 [[ExtraGenericLoops],	[],	sub {return {}}],
# Naming of the struct and the virtual table.
 [[StructName],		[Name],			"defstructname"],
 [[FHdrInfo],		[Name,StructName],		"mkfhdrinfo"],
 [[VTableName],		[Name],			"defvtablename"],

# 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.
 [[AffinePriv],		[XCHGOnly],		"direct"],
 [[Priv],	[AffinePriv],		"affinepriv"],
 [[IsAffineFlag],	[AffinePriv],	sub {"PDL_ITRANS_ISAFFINE"}],

 [[RedoDims],		[EquivPDimExpr,FHdrInfo,_EquivDimCheck],
 				"pdimexpr2priv"],
 [[RedoDims],		[Identity,FHdrInfo],	"identity2priv"],

 # NOTE: we use the same bit of code for all-good and bad data -
 #  see the Code rule
 [[EquivCPOffsCode],	[Identity],	"equivcpoffscode",
    "something to do with dataflow between CHILD & PARENT, I think."],

 [[Code],	[EquivCPOffsCode,BadFlag],   "CodefromEquivCPOffsCode",
    "create Code from EquivCPOffsCode"],

 [[BackCode],	[EquivCPOffsCode,BadFlag],   "BackCodefromEquivCPOffsCode",
    "create BackCode from EquivCPOffsCode"],

 [[Affine_Ok],	[EquivCPOffsCode],	sub {0}],
 [[Affine_Ok],	[],			sub {1}],

 [[ReadDataFuncName],	[AffinePriv],	sub {NULL}],
 [[WriteBackDataFuncName],	[AffinePriv],	sub {NULL}],

 [[BootStruct],	[AffinePriv,VTableName], 
    sub {return "   $_[1].readdata = PDL->readdata_affine;\n" .
	     "   $_[1].writebackdata = PDL->writebackdata_affine;\n"}],

 [[ReadDataFuncName],	[Name],	sub {"pdl_$_[0]_readdata"}],
 [[CopyFuncName],	[Name],	sub {"pdl_$_[0]_copy"}],
 [[FreeFuncName],	[Name],	sub {"pdl_$_[0]_free"}],
# [[WriteBackDataFuncName],	[Name],	sub {"pdl_$_[0]_writebackdata"}],
 [[RedoDimsFuncName],	[Name],	sub {"pdl_$_[0]_redodims"}],

 [[XSBootCode],	[BootStruct],	sub {join '',@_}],


# Parameters in the form 'parent and child(this)'.
# The names are PARENT and CHILD.
#
# P2Child implicitly means "no data type changes".
# [[USParNames,USParObjs,FOOFOONoConversion,HaveThreading,NewXSName,PMFunc,
# 	PMCode],   [P2Child,Name],
# 		"ParentChildPars"],
# the new rule makes no PMCode anymore, all handled in XS now

 [[USParNames,USParObjs,FOOFOONoConversion,HaveThreading,NewXSName],
   [P2Child,Name,BadFlag],
 		"NewParentChildPars"],
 [[NewXSName],	[Name],	sub {"_$_[0]_int"}],

 [[EquivPThreadIdExpr],[P2Child],sub {'$CTID-$PARENT(ndims)+$CHILD(ndims)'}],

 [[HaveThreading],	[],	sub {1}],

# the docs
 [[PdlDoc],             [Name,_Pars,OtherPars,Doc,_BadDoc],  "GenDocs"],

# 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
#   PDL::PP::Signature (Doug Burke 07/08/00)
 [[USParNames,USParObjs,DimmedPars], 	[Pars,BadFlag], 		"Pars_nft"],
 [[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 PDL-subclassed objects
 [[CallCopy], [DimObjs, USParNames, USParObjs, Name, HASP2Child],             
 	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.
 [[OtherParNames,
   OtherParTypes],	[OtherPars,DimObjs],		"OtherPars_nft"],

 [[ParNames,ParObjs],	[USParNames,USParObjs],	"sort_pnobjs"],


 [[DefSyms],		[StructName],			"MkDefSyms"],
 [[NewXSArgs],		[USParNames,USParObjs,OtherParNames,OtherParTypes],
 						"NXArgs"],

 # now we do not autogenerate PMCode any longer, so the rule after this
 # one could really go
 [[PMCode],             [],           sub { return undef; }],

 [[PMCode]	,	[Name,NewXSName,ParNames,ParObjs,OtherParNames,
 			OtherParTypes], "pmcode"],

 [[NewXSSymTab],	[DefSyms,NewXSArgs],	"AddArgsyms"],

 [[InplaceCode],        [Name,NewXSArgs,USParObjs,_Inplace],           "InplaceCode",
  'Insert code (just after HdrCode) to ensure the routine can be done inplace'],
 [[HdrCode],            [],           sub { return '' },
  'Code that will be inserted at the end of the autogenerated
   xs argument processing code L<VargArgsXSHdr>'],
#  [[HdrParsedCode],      [HdrCode,ParNames,ParObjs,DimObjs,
#                          GenericTypes,ExtraGenericLoops,HaveThreading],
#   sub { print "parsing extra code...\n";return "/* no extra argument processing */"
# 	  if $_[0] =~ m|^/s*$|;
# 	# trailing 1,1 means no threadloop and no generic loop
# 	new PDL::PP::Code(@_,1,1)},  
#   'makes the parsed representation from the supplied processing code, L<HdrCode>'],
#  [[HdrParsedCodeSubst],  [HdrParsedCode,NewXSSymTab,Name], "dousualsubsts"],

 # 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
 [[VarArgsXSHdr],
  [Name,NewXSArgs,USParObjs,OtherParTypes,HASP2Child,PMCode,HdrCode,InplaceCode,
   _GlobalNew,_CallCopy],
  "VarArgsXSHdr", 'creates xs code to process arguments on stack based on supplied
   Pars argument to pp_def; GlobalNew has implications how/if this is done'],

 ## 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
 [[VarArgsXSReturn],	[NewXSArgs,USParObjs,_GlobalNew],         
    "VarArgsXSReturn",
    "Rule to generate XS trailer for returning output variables"],

 [[NewXSHdr],		[NewXSName,NewXSArgs],	"XSHdr"],
 [[NewXSCHdrs],		[NewXSName,NewXSArgs,GlobalNew],	"XSCHdrs"],
 [[NewXSLocals],	[NewXSSymTab],		"Sym2Loc"],
 [[IsAffineFlag],	[],	sub {return "0"}],
 [[NoPdlThread],	[],	sub {0}],

# hmm, need to check on conditional check here (or rather, other bits of code prob need
# to include it too; see Ops.xs, PDL::assgn)
##
##           sub { return (defined $_[0]) ? "int \$BADFLAGCACHE() = 0;" : ""; } ],
##
 [[CacheBadFlagInitNS], [_HandleBad],
           sub { return $bvalflag ? "\n  int \$BADFLAGCACHE() = 0;\n" : ""; } ],
 [[CacheBadFlagInit], [CacheBadFlagInitNS,NewXSSymTab,Name], "dousualsubsts"],

    # 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...)
    #
 [[NewXSStructInit0], [NewXSSymTab,VTableName,IsAffineFlag,NoPdlThread],  
    "MkPrivStructInit", "Rule to create and initialise the private trans structure"],

 [[NewXSMakeNow],	[ParNames,NewXSSymTab],	"MakeNows"],
 [[IgnoreTypesOf],	[FTypes],	sub {return {map {($_,1)} keys %{$_[0]}}}],
 [[IgnoreTypesOf],	[],	sub {{}}],

 [[NewXSCoerceMustNS],	[FTypes],	"make_newcoerce"],
 [[NewXSCoerceMust],	[NewXSCoerceMustNS,NewXSSymTab,Name], "dousualsubsts"],

 [[DefaultFlowCode],	[DefaultFlowCodeNS,NewXSSymTab,Name], "dousualsubsts"],

#  [[GenericTypes],	[],	sub {[F,D]}],

 [[NewXSFindDatatypeNS],	[ParNames,ParObjs,IgnoreTypesOf,NewXSSymTab,
				GenericTypes,HASP2Child],
 						"find_datatype"],

 [[NewXSFindDatatype],	[NewXSFindDatatypeNS,NewXSSymTab,Name],
 						"dousualsubsts"],
 [[NewXSTypeCoerce],	[NoConversion],		sub {""}],

 [[NewXSTypeCoerceNS],	[ParNames,ParObjs,IgnoreTypesOf,NewXSSymTab,HASP2Child],
 						"coerce_types"],

 [[NewXSTypeCoerce],	[NewXSTypeCoerceNS,NewXSSymTab,Name], "dousualsubsts"],

 [[NewXSStructInit1],	[ParNames,NewXSSymTab],	"CopyPDLPars"],
 [[NewXSSetTrans],	[ParNames,ParObjs,NewXSSymTab],	"makesettrans"],

 [["ParsedCode"],	[Code,_BadCode,ParNames,ParObjs,DimObjs,GenericTypes,
 			 ExtraGenericLoops,HaveThreading,Name],
 				sub {new PDL::PP::Code(@_)}],
 [["ParsedBackCode"],	[BackCode,_BadBackCode,ParNames,ParObjs,DimObjs,GenericTypes,
 			 ExtraGenericLoops,HaveThreading,Name],
 				sub {new PDL::PP::Code(@_)}],

# 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 + ...
 [[CompNames,CompObjs],	[Comp],			"OtherPars_nft"],
 [[CompiledRepr],	[CompNames,CompObjs],	"NT2Decls_p"],
 [[MakeCompiledRepr],	[MakeComp,CompNames,CompObjs],
 						sub {subst_makecomp(COMP,@_)}],

 [[CompCopyCode],	[CompNames,CompObjs,CopyName], "NT2Copies_p"],
 [[CompFreeCode],	[CompNames,CompObjs], 	"NT2Free_p"],

# This is the default
 [[MakeCompiledRepr],	[OtherParNames,OtherParTypes,
  			 NewXSSymTab],
 						"CopyOtherPars"],
 [[CompiledRepr],	[OtherParNames,OtherParTypes],
 						"NT2Decls"],
 [[CompCopyCode],	[OtherParNames,OtherParTypes,CopyName], "NT2Copies_p"],
 [[CompFreeCode],	[OtherParNames,OtherParTypes], "NT2Free_p"],



# Threads
 [[Priv,PrivIsInc],	[ParNames,ParObjs,DimObjs,HaveThreading],"make_incsizes"],
 [[PrivCopyCode],	[ParNames,ParObjs,DimObjs,CopyName,HaveThreading],
 	"make_incsize_copy"],
 [[PrivFreeCode],	[ParNames,ParObjs,DimObjs,HaveThreading],
 	"make_incsize_free"], # Frees thread.
 [[RedoDimsCode],       [],      sub {"/* none */"},
  'Code that can be inserted to set the size of output piddles
   dynamically based on input piddles; is parsed'],
 [[RedoDimsParsedCode], [RedoDimsCode,_BadRedoDimsCode,ParNames,ParObjs,DimObjs,
                         GenericTypes,ExtraGenericLoops,HaveThreading,Name],
 				sub { return "/* no RedoDimsCode */"
					if $_[0] =~ m|^/[*] none [*]/$|;
				      new PDL::PP::Code(@_,1)},
  'makes the parsed representation from the supplied RedoDimsCode'],
 [[RedoDims],	[ParNames,ParObjs,DimObjs,DimmedPars,RedoDimsParsedCode],
  "make_redodims_thread",
  'makes the redodims function from the various bits and pieces'],

 [[Priv],	[],			"nothing"],

 [[PrivNames,PrivObjs],	[Priv],			"OtherPars_nft"],
 [[PrivateRepr],	[PrivNames,PrivObjs],	"NT2Decls_p"],
 [[PrivCopyCode],	[PrivNames,PrivObjs,CopyName], "NT2Copies_p"],
# avoid clash with freecode above?
 [[NTPrivFreeCode],	[PrivNames,PrivObjs], "NT2Free_p"],

 [[IsReversibleCodeNS],	[Reversible],	"ToIsReversible"],
 [[IsReversibleCode],	[IsReversibleCodeNS,NewXSSymTab,Name], "dousualsubsts"],

 [[NewXSStructInit2],	[MakeCompiledRepr, NewXSSymTab,Name],	sub {"{".dosubst(@_)."}"}],

 [[CopyCodeNS],	[PrivCopyCode,CompCopyCode,StructName,NoPdlThread],	sub {return "$_[2] *__copy
 			= malloc(sizeof($_[2]));" .
			($_[3] ? "" : "PDL_THR_CLRMAGIC(&__copy->__pdlthread);") .
"			PDL_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;"}],

 [[FreeCodeNS],	[PrivFreeCode,CompFreeCode,NTPrivFreeCode],	sub {"
			PDL_TR_CLRMAGIC(__privtrans);
			$_[1]
			if(__privtrans->__ddone) {
				$_[0]
				$_[2]
			}
			"}],

 [[CopyCode],	[CopyCodeNS,NewXSSymTab,Name], "dousualsubsts"],
 [[FreeCode],	[FreeCodeNS,NewXSSymTab,Name], "dousualsubsts"],
 [[FooCodeSub], [FooCode,NewXSSymTab,Name], "dousualsubsts"],

 [[NewXSCoerceMust],	[],	sub {""}],
 [[NewXSCoerceMustSub1], [NewXSCoerceMust],	sub{subst_makecomp(FOO,@_)}],
 [[NewXSCoerceMustSubs], [NewXSCoerceMustSub1,NewXSSymTab,Name],	"dosubst"],
 [[NewXSClearThread], [HaveThreading], sub {$_[0] ? "__privtrans->__pdlthread.inds = 0;" : ""}],

 [[NewXSFindBadStatusNS], 
    [BadFlag,_FindBadStatusCode,NewXSArgs,USParObjs,OtherParTypes,NewXSSymTab,Name], 
    "findbadstatus",
    "Rule to find the bad value status of the input piddles"],

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

 [[NewXSCopyBadStatusNS], [BadFlag,_CopyBadStatusCode,NewXSArgs,USParObjs,NewXSSymTab], 
    "copybadstatus",
    "Rule to copy the bad value status to the output piddles"],

 # expand macros in ...BadStatusCode
 [[NewXSFindBadStatus], [NewXSFindBadStatusNS,NewXSSymTab,Name], "dousualsubsts"],
 [[NewXSCopyBadStatus], [NewXSCopyBadStatusNS,NewXSSymTab,Name], "dousualsubsts"],

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

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

 [[StructDecl],		[ParNames,ParObjs, CompiledRepr,
                         PrivateRepr,StructName],
			 			"mkstruct"],
 [[RedoDimsSub],	[RedoDims,PrivNames,PrivObjs,_DimObjs],
				sub {
				 my $do = $_[3];
				 my $r = subst_makecomp(PRIV,"$_[0] \$PRIV(__ddone) = 1;",@_[1,2]);
				 $r->[1]{SIZE} = sub {
					croak "can't get SIZE of undefined dimension $this->[0]"
					  unless defined($do->{$_[0]});
					return $do->{$_[0]}->get_size();
				  };
				 return $r;
				 }],
 [[RedoDimsSubd],	[RedoDimsSub,NewXSSymTab,Name],	"dosubst"],
 [[RedoDimsFunc], 	[RedoDimsSubd,FHdrInfo,RedoDimsFuncName,HASP2Child],
 				sub {wrap_vfn(@_,"redodims")}],

#  [[ReGenedCode],	[ParsedCode,ParObjs,DimObjs],	sub {$_[0]->gen($_[1,2])}],
 [[ReadDataSub],	[ParsedCode],
 				sub {subst_makecomp(FOO,@_)}],
 [[ReadDataSubd],	[ReadDataSub,NewXSSymTab,Name],	"dosubst"],
 [[ReadDataFunc], 	[ReadDataSubd,FHdrInfo,ReadDataFuncName,HASP2Child],
 			sub {wrap_vfn(@_,"readdata")}],

 [[WriteBackDataSub],	[ParsedBackCode],	sub {subst_makecomp(FOO,@_)}],
 [[WriteBackDataSubd],	[WriteBackDataSub,NewXSSymTab,Name],	"dosubst"],

 [[WriteBackDataFuncName],	[BackCode,Name],	sub {"pdl_$_[1]_writebackdata"}],
 [[WriteBackDataFuncName],	[Code],	sub {"NULL"}],

 [[WriteBackDataFunc], 	[WriteBackDataSubd,FHdrInfo,WriteBackDataFuncName,HASP2Child],
 	sub {wrap_vfn(@_,"writebackdata")}],

 [[CopyFunc],	[CopyCode,FHdrInfo,CopyFuncName,HASP2Child],sub {wrap_vfn(@_,"copy")}],
 [[FreeFunc],	[FreeCode,FHdrInfo,FreeFuncName,HASP2Child],sub {wrap_vfn(@_,"free")}],

 [[FoofName],	[FooCodeSub],	sub {"foomethod"}],
 [[FooFunc],	[FooCodeSub,FHdrInfo,FoofName,HASP2Child], sub {wrap_vfn(@_,"foo")}],

 [[FoofName], [],	sub {"NULL"}],

 [[VTableDef],	[VTableName, StructName, RedoDimsFuncName,ReadDataFuncName,
 		 WriteBackDataFuncName,CopyFuncName,FreeFuncName,
		 ParNames,ParObjs,Affine_Ok,FoofName],	"def_vtable"],
];

# back to strictness
use strict;

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;
  $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 ) {
      $baddoc =~ s/\n(=cut\s*\n)+(\s*\n)*$/\n/m;
      $baddoc = "=for bad\n\n$baddoc";
  }

  return << "EOD";

=head2 $name

=for sig

  Signature: ($sig)

$doc

$baddoc

=cut

EOD
}

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

# use Data::Dumper;

use Carp;
# use Data::Dumper;

sub translate {
    my($pars,$tbl) = @_;
    my $rule;
    no strict 'refs'; # using strings as subroutine references
  RULE: for $rule(@$tbl) {
# Are all prerequisites there;
      my @args;
#		print "Trying rule ",Dumper($rule) if $::PP_VERBOSE;

      print "$rule->[3]\n" if ($::PP_VERBOSE && (@$rule == 3));

      # make output, when verbose, a bit more legible
      my $rule_id = ref($rule->[2]) eq "CODE" ? "ANONYMOUS SUBROUTINE" : $rule->[2];

      # If any of the rule[0]s exist, don't apply rule
      for(@{$rule->[0]}) {
	  if(exists $pars->{$_}) {
	      print "Not applying rule $rule_id, resexist\n"
		  if $::PP_VERBOSE;
	      next RULE
	      }
      }

      # Unless all rule[1]s exist, don't apply rule
      # except if a rule is prefixed by '_'
      for(@{$rule->[1]}) {
	  my $foo = $_;
	  if(/^_/) {
	      $foo =~ s/^_//;
	  } elsif(!exists $pars->{$_}) {
	      print "Component $_ not found for $rule_id, next rule\n" if $::PP_VERBOSE;
	      next RULE
	      }
	  push @args, $pars->{$foo};
      }
#		print "Applying rule $rule->[2]\n",Dumper($rule);
      print "Applying rule $rule_id\n" if $::PP_VERBOSE;
      my @res = &{$rule->[2]}(@args);
      print "Setting " if $::PP_VERBOSE;
      for(@{$rule->[0]}) {
	  if(exists $pars->{$_}) {
	      confess "Cannot have several meanings yet\n";
	  }
	  my $res = shift @res;
	  unless ($res eq 'DO NOT SET!!') {
	      $pars->{$_} = $res;
	      print "$_ " if $::PP_VERBOSE;
	  }
	  
      }
      print "\n" if $::PP_VERBOSE;
  } # RULE:
#	print Dumper($pars);
    print "GOING OUT!\n" if $::PP_VERBOSE;
    use strict; # a bit pointless ?
    return $pars;
} # sub: translate()

use Carp;

# ==== FCN ====

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" if $hasp2child;
	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 = "PDLMAX($dtype,\$PRIV(__datatype))"
		if $po->{FlagTplus};
	} else {
	    $dtype = "\$PRIV(__datatype)";
	}

	if ( $po->{FlagCreateAlways} ) {
	    $str .= "$_->datatype = $dtype; ";
	} else {
	    $str .= 
	 "if( ($_->state & PDL_NOMYDIMS) && $_->trans == NULL ) {
	     $_->datatype = $dtype;
	  } else " 
	      if $po->{FlagCreat};
	    $str .= "if($dtype != $_->datatype) {
	     $_ = PDL->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"
    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 & PDL_NOMYDIMS) &&
		       $_->trans == NULL) && "
			   if $po->{FlagCreat};
	$str .= "$dtype < $_->datatype) {
		 	$dtype = $_->datatype;
		    }\n";
    } # foreach: @$parnames
    
    $str .= join '', map { "if($dtype == PDL_$_) {}\nelse " }(@$gentypes);

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

sub make_incsizes {
	my($parnames,$parobjs,$dimobjs,$havethreading) = @_;
      ($havethreading?"pdl_thread __pdlthread; ":"").
	 (join '',map {$parobjs->{$_}->get_incdecls} @$parnames).
	 (join '',map {$_->get_decldim} values %$dimobjs);
}

sub make_incsize_copy {
	my($parnames,$parobjs,$dimobjs,$copyname,$havethreading) = @_;
	($havethreading?
      "PDL->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 ?
      'PDL->freethreadloop(&($PRIV(__pdlthread)));'
	: ''
}

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

sub make_redodims_thread {
    my($pnames,$pobjs,$dobjs,$dpars,$pcode) = @_;
    my $str; my $npdls = @$pnames;
    
    my $nn = $#$pnames;
    my @privname = map { "\$PRIV(pdls[$_])" } ( 0 .. $nn );
    $str .= "int __creating[$npdls];\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 .= "PDL_CR_SETDIMSCOND(__privtrans,$privname[$_]);\n";
	} else {
	    $str .= "0;\n";
	}
    } # foreach: 0 .. $nn
 
##############################
#
# These tests don't appear to do anything useful,
#  and they cause trouble with null PDLs ... 
#  so I've commented them out.
#    --CED 4-Nov-2003 (re: bug 779312)
#
#    foreach ( 0 .. $nn ) {
#	my $po = $pobjs->{$pnames->[$_]};
#	$str .= "if(";
#	$str .= "(!__creating[$_]) && " if $po->{FlagCreat};
#	$str .= "($privname[$_]\->state & PDL_NOMYDIMS) && $privname[$_]\->trans == 0)\n" .
#	    "   \$CROAK(\"CANNOT CREATE PARAMETER $po->{Name}\");\n";
#    }

    $str .= " {\n$pcode\n}\n";
    $str .= " {\n " . make_parnames($pnames,$pobjs,$dobjs) . "
		 PDL->initthreadstruct(2,\$PRIV(pdls),
			__realdims,__creating,$npdls,
                      &__einfo,&(\$PRIV(__pdlthread)),
                        \$PRIV(vtable->per_pdl_flags));
		}\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()


##############################
# 
# hdrcheck -- examine the various PDLs that form the output PDL,
# 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 PDL::_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 PDL::_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 PDL::_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 = "
{ /* 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 & PDL_HDRCPY) 
	 ) {
	hdrp = $names[$_]\->hdrsv;
	propagate_hdrcpy = (($names[$_]\->state & PDL_HDRCPY) != 0);
      }
HdRCHECK1
  ;
  }

  $str .= << 'DeePcOPY'
if (hdrp) {
  if(hdrp == &PL_sv_undef) 
    hdr_copy = &PL_sv_undef;
  else  {  /* Call the perl routine _hdr_copy... */
    int count;
    /* Call the perl routine PDL::_hdr_copy(hdrp) */
    dSP;
    ENTER ;
    SAVETMPS ;
    PUSHMARK(SP) ;
    XPUSHs( hdrp );
    PUTBACK ;
    count = call_pv("PDL::_hdr_copy",G_SCALAR);
    SPAGAIN ;
    if(count != 1) 
	croak("PDL::_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)
       SvREFCNT_inc(hdr_copy); /*Keep hdr_copy from vanishing during FREETMPS*/

    FREETMPS ;
    LEAVE ;


  } /* 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)  
             SvREFCNT_dec( $names[$_]\->hdrsv ); 
	 if( hdr_copy != &PL_sv_undef ) 
             SvREFCNT_inc(hdr_copy); 
	 $names[$_]\->hdrsv = hdr_copy;
       }
     if(propagate_hdrcpy)
       $names[$_]\->state |= PDL_HDRCPY;
HdRCHECK2
      if ( $pobjs->{$pnames->[$_]}{FlagCreat} );
   }

  $str .= 
"    if(hdr_copy != &PL_sv_undef) \n".
"      SvREFCNT_dec(hdr_copy); /* make hdr_copy mortal again */\n".
"   } /* end of if(hdrp) block */\n} /* end of conv. block */\n";

  return $str;

} # sub: hdrcheck()

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 ? "PDL_TPDL_VAFFINE_OK" : 0);
    my $npdls = scalar @$pnames;
    return "static char ${vname}_flags[] =
	 	{ ".
		    (join",",map {$pobjs->{$pnames->[$_]}->{FlagPhys} ?
				      0 : $aff} 0..$npdls-1).
					  "};
	 pdl_transvtable $vname = {
		0,0, $nparents, $npdls, ${vname}_flags,
		$rdname, $rfname, $wfname,
		$ffname,NULL,NULL,$cpfname,NULL,
		sizeof($sname),\"$vname\",
		$foofname
	 };";
}

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);
}

sub mkfhdrinfo {
    my($name,$sname) = @_;
    return {
	Name => $name,
	StructName => $sname,
    };
}

# 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 = '';
    if ( $p2child == 1 ) {
	$p2decl = 
	    "pdl *__it = __tr->pdls[1]; pdl *__parent = __tr->pdls[0];";
	if ( $name eq "redodims" ) {
	    $p2decl .= '
	     if (__parent->hdrsv && (__parent->state & PDL_HDRCPY)) {
                  /* call the perl routine _hdr_copy. */
                  int count;

                  dSP;
                  ENTER ;
                  SAVETMPS ;
                  PUSHMARK(SP) ;
                  XPUSHs( sv_mortalcopy((SV*)__parent->hdrsv) );
                  PUTBACK ;
                  count = call_pv("PDL::_hdr_copy",G_SCALAR);
                  SPAGAIN ;
                  if(count != 1) 
                      croak("PDL::_hdr_copy didn\'t return a single value - please report this bug (B).");
  
                  { /* convenience block for tmp var */
                    SV *tmp = (SV *) POPs ;
		    __it->hdrsv = (void*) tmp;
                    if(tmp != &PL_sv_undef ) 
                       SvREFCNT_inc(tmp);
                  }

                  __it->state |= PDL_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('_PDL_ThisTrans');
    my $no=0;
    return (join '',map {
	"$trans->pdls[".($no++)."] = $_;\n"
	} @$pnames).
	    "PDL->make_trans_mutual((pdl_trans *)$trans);\n";
}

sub identity2priv {
	'
		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;
	'
		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);
	'
}

sub affinepriv {
	'PDL_Long incs[$CHILD(ndims)];PDL_Long offs; '
}

sub dousualsubsts {
	my($src,$symtab,$name) = @_;
	return dosubst([$src,
		{@::std_childparent}
	     ],$symtab,$name);
}

sub dosubst {
	my($src,$symtab,$name) = @_;
#	print "DOSUBST on ",Dumper($src),"\n";
	my $ret = (ref $src ? $src->[0] : $src);
	my %syms = (
		    ((ref $src) ? %{$src->[1]} : ()),
		    PRIV => sub {return "".$symtab->get_symname('_PDL_ThisTrans').
				     "->$_[0]"},
		    CROAK => sub {return "barf(\"Error in $name:\" $_[0])"},
		    NAME => sub {return $name},
		    MODULE => sub {return $::PDLMOD},

		    SETPDLSTATEBAD  => sub { return "$_[0]\->state |= PDL_BADVAL"; },
		    SETPDLSTATEGOOD => sub { return "$_[0]\->state &= ~PDL_BADVAL"; },
		    ISPDLSTATEBAD   => sub { return "(($_[0]\->state & PDL_BADVAL) > 0)"; },
		    ISPDLSTATEGOOD  => sub { return "(($_[0]\->state & PDL_BADVAL) == 0)"; },
		    BADFLAGCACHE    => sub { return "badflag_cache"; },

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

BEGIN {
@::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 ',',@_).")"},
);
@::std_redodims = (
	SETNDIMS => sub {return "PDL->reallocdims(__it,$_[0])"},
	SETDIMS => sub {return "PDL->setdims_careful(__it)"},
	SETDELTATHREADIDS => sub {return '
		{int __ind; PDL->reallocthreadids($CHILD_PTR(),
			$PARENT(nthreadids));
		for(__ind=0; __ind<$PARENT(nthreadids)+1; __ind++) {
			$CHILD(threadids[__ind]) =
				$PARENT(threadids[__ind]) + ('.$_[0].');
		}
		}
		'}

);
}


sub subst_makecomp {
	my($which,$mc,$cn,$co) = @_;
	return [$mc,{
		@::std_childparent,
		($cn ?
			(('DO'.$which.'DIMS') => sub {return join '',
				map{$$co{$_}->need_malloc ?
				    $$co{$_}->get_malloc('$PRIV('.$_.')') :
				    ()} @$cn}) :
			()
		),
		($which eq "PRIV" ?
			@::std_redodims : ()),
		},
	];
}

# XXX
# - the need for BadFlag is due to hacked get_xsdatapdecl()
#   in PP/PdlParObj and because the PdlParObjs are created by
#   PDL::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
#   PDL::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 = \\&PDL::$name;
#	sub PDL::$name {
#		my \$this = shift;
#		my \$foo=\$this->null;
#		PDL::${name}_XX(\$this,\$foo,\@_);
#		\$foo
#	}
#	");
#}

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

sub nothing {return "";}

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

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

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

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


# Not necessary ?
sub CopyPDLPars {
if(0) {
	my($pnames,$symtab) = @_;
	my $tt = $symtab->get_symname('_PDL_ThisTrans');
	my $str; my $no=0;
	for(@$pnames) {
		$str .= "$tt->pdls[$no] = ".$_.";\n";
		$no++;
	}
	$str
}
	""
}

sub direct {return @_;}

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

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

sub defstructname {return "pdl_$_[0]_struct"}
sub defvtablename {return "pdl_$_[0]_vtable"}

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

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

} # sub: MkPrivStructInit()

sub MkDefSyms {
    return new SymTab(
		      _PDL_ThisTrans => ["__privtrans",new C::Type(undef,"$_[0] *foo")],
		      );
}

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

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

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

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

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 = new C::Type(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 = new C::Type(undef,$_);
	}
	my $name = $type->protoname;
	push @names,$name;
	$types{$name} = $type;
    }
    return (\@names,\%types);
}

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

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

sub indent($$) {
    my ($text,$ind) = @_;
    $text =~ s/^(.*)$/$ind$1/mg;
    return $text;
}

# This subroutine generates the XS code needed to call the perl 'initialize'
# routine in order to create new output PDLs
sub callPerlInit {
    my $names = shift; # names of variables to initialize
    my $ci    = shift; # current indenting
    my $callcopy = $#_ > -1 ? shift : 0;
    my $ret = '';
  
    foreach my $name (@$names) {
	unless ($callcopy) { $ret .= << "EOC"}

if (strcmp(objname,"PDL") == 0) { /* shortcut if just PDL */
   $name\_SV = sv_newmortal();
   $name = PDL->null();
   PDL->SetSV_PDL($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 = PDL->SvPDLV($name\_SV);
}

EOC

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

if (strcmp(objname,"PDL") == 0) { /* shortcut if just PDL */
   $name\_SV = sv_newmortal();
   $name = PDL->null();
   PDL->SetSV_PDL($name\_SV,$name);
   if (bless_stash) $name\_SV = sv_bless($name\_SV, bless_stash);
} else {
   /* 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 = PDL->SvPDLV($name\_SV);
}
EOD

  } # doreach: $name

  return indent($ret,$ci);

} #sub callPerlInit()

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

  # A slightly edited version of the search path in xsubpp with a $installprivlib/ExtUtils
  # directory prepended. 
  my $_rootdir=$Config{installprivlib}."/ExtUtils/";
  # First the system typemaps..
  my @tm = ($_rootdir.'../../../../lib/ExtUtils/typemap',
	    $_rootdir.'../../../lib/ExtUtils/typemap',
	    $_rootdir.'../../lib/ExtUtils/typemap',
	    $_rootdir.'../../../typemap',
	    $_rootdir.'../../typemap', $_rootdir.'../typemap',
	    $_rootdir.'typemap');
  # 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';
  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 ;
    open(TYPEMAP, $typemap)
      or warn ("Warning: could not open typemap file '$typemap': $!\n"), next;
    $mode = 'Typemap';
    $junk = "" ;
    $current = \$junk;
    while (<TYPEMAP>) {
	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);
  }

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

# 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
#
sub VarArgsXSHdr {
  my($name,$xsargs,$parobjs,$optypes,$hasp2child,$pmcode,
     $hdrcode,$inplacecode,$globalnew,$callcopy) = @_;

  # Don't do var args processing if 'has p2 child' whatever *that* means
  # the p2child restriction has been removed; CS 4/15/00
  # return 'DO NOT SET!!' if ($hasp2child);

  # 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 = PDL->SvPDLV(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) { /* 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 = PDL->SvPDLV(ST($cnt));\n";
	      $cnt++;
	  }
      }
      
      # Add code for creating output variables via call to 'initialize' perl routine
      $clause2 .= callPerlInit (\@create, $ci, $callcopy); @create = ();
      
      $clause2 .= "}\n";

  }
  
  # 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 = PDL->SvPDLV(ST($cnt));\n";
	  $cnt++;
      }
  }

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

  return<<END;


void
$name(...)
 PREINIT:
  char *objname = "PDL"; /* 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:

{
  /* Check if you can get a package name for this input value.  It can be either a PDL (SVt_PVMG) or 
     a hash which is a derived PDL subclass (SVt_PVHV) */
  if (SvROK(ST(0)) && ((SvTYPE(SvRV(ST(0))) == SVt_PVMG) || (SvTYPE(SvRV(ST(0))) == SVt_PVHV))) {
    parent = ST(0);
    if (sv_isobject(parent))
      objname = HvNAME((bless_stash = SvSTASH(SvRV(ST(0)))));  /* The package to bless output vars into is taken from the first input var */
  }
  if (items == $nmaxonstack) { /* all variables on stack, read in output and temp vars */
    nreturn = $noutca;
$clause1
  } 
$clause2
  else if (items == $nin) { /* only input variables on stack, create outputs and temps */
    nreturn = $nallout;
$clause3
  } 

  else {
    croak (\"Usage:  PDL::$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) = @_;
	my $shortpars = join ',',map {$_->[0]} @$pars;
	my $longpars = join ",",map {$_->[1]->get_decl($_->[0])} @$pars;
	return ["void $name($longpars) {","}","",
		"PDL->$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/PDLCode.pm
# -- there it's hard-coded
#
sub set_badflag {
    my $sname = shift;
    return "\$PRIV(bvalflag) = 1;\n";
#    return "$sname\->bvalflag = 1;\n";
##    return "$sname\->flags |= PDL_ITRANS_HAVE_BADVAL;\n";
}

sub clear_badflag {
    my $sname = shift;
    return "\$PRIV(bvalflag) = 0;\n";
#    return "$sname\->bvalflag = 0;\n";
##    return "$sname\->flags &= ~PDL_ITRANS_HAVE_BADVAL;\n";
}

sub get_badflag {
    my $sname = shift;
    return "\$PRIV(bvalflag)";
#    return "$sname\->bvalflag";
##    return "($sname\->flags & PDL_ITRANS_HAVE_BADVAL)";
}

sub get_badflag_priv {
    return '$PRIV(bvalflag)';
##    return '($PRIV(flags) & PDL_ITRANS_HAVE_BADVAL)';
}    

# abstract the access to the bad value status of a piddle
# - means we can easily change the representation without too 
#   many changes
#
sub set_badstate {
    my $pdl = shift;
    return "\$SETPDLSTATEBAD($pdl)";
#    return "${pdl}->state |= PDL_BADVAL";
}

sub clear_badstate {
    my $pdl = shift;
    return "\$SETPDLSTATEGOOD($pdl)";
#    return "${pdl}->state &= ~PDL_BADVAL";
}

sub get_badstate {
    my $pdl = shift;
    return "\$ISPDLSTATEBAD($pdl)";
#    return "((${pdl}->state & PDL_BADVAL) > 0)";
}

# 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('_PDL_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: routine 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 "\nPDL::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('_PDL_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()

# 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  
	'int i;
         for(i=0; i<$CHILD_P(nvals); i++)  {
            $EQUIVCPOFFS(i,i);
         }';

} # sub: equivcpoffscode()

# 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 
	"\tif ( $instate & PDL_INPLACE ) {
              $instate &= ~PDL_INPLACE; /* unset */
              $out = $in;             /* discard output value, leak ? */
              PDL->SetSV_PDL(${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
#  PDLCode to automatically write code like above, hence the
#  explicit definition here.
#
#  Note: I *assume* that bad-Equiv..Code == good-Equiv..Code *EXCEPT*
#        that we re-define the meaning of the $EQUIVCPOFFS macro to
#        check for bad values when copying things over.
#        This means having to write less code.
#
# Since PARENT & CHILD need NOT be the same type we cannot just copy
# values from one to the other - we have to check for the presence
# of bad values, hence the expansion for the $bad code
#
# Some operators (notably range) also have an out-of-range flag; they use
# the macro EQUIVCPTRUNC instead of EQUIVCPOFFS. 
# $EQUIVCPTRUNC does the same as EQUIVCPOFFS but accepts a child-out-of-bounds
# flag.  If the out-of-bounds flag is set, the forward code puts BAD/0 into 
# the child, and reverse code refrains from copying. 
#                    --CED 27-Jan-2003
#
# 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


# Make the pm code to massage the arguments if not given enough.
# This function is troublesome because perl5.004_0[0123]
# all contain a bug in 'splice @_,...'.
# However, we can't use just assign because of e.g. otherpars
# and strange argument orderings.
sub pmcode {
	my($name,$newxsname,$parnames,$parobjs,$onames,$oobjs) = @_;

	my ($acnt,$tcnt,$icnt)=(0,0,0) ;
	my ($tspl, $ispl);
	my (@tmap,@imap); # maps: number to get argument n from
	$acnt = 0;
	for(@$parnames) {
		if($parobjs->{$_}->{FlagOut}) {
			push @tmap,$tcnt;
			push @imap,-2;
			$tcnt++;
                       $ispl .= "push \@ret,$::PDLOBJ->nullcreate(\$a[0]);    # Create a null using nullcreate
                       \$a[$acnt] = \$ret[-1];";
		} elsif($parobjs->{$_}->{FlagTemp}) {
			push @tmap,-1;
			push @imap,-1;
                       my $spl = "\$a[$acnt] = $::PDLOBJ->nullcreate(\$a[0]);"; # Create a null using nullcreate
			$tspl .= $spl; $ispl .= $spl
		} else {
			push @tmap,$tcnt;
			push @imap,$icnt;
			$tcnt++;
			$icnt++;
		}
		$acnt ++
	}
	for(@$onames) {
		push @tmap,$tcnt++;
		push @imap,$icnt++;
	}
	my $icode = "";
	my $tcode = "";
	my $ind;
	for $ind (reverse 0..$#imap) {
		if($imap[$ind] == -2) {
                       $icode .= "unshift \@ret,(\$a[$ind] = $::PDLOBJ->nullcreate(\$a[0]) );\n"; # Create a null using nullcreate
		} elsif($imap[$ind] == -1) {
                       $icode .= "\$a[$ind] = $::PDLOBJ->nullcreate(\$a[0]);\n"; # Create a null using nullcreate
		} else {
                       $icode .= "\$a[$ind] = \$a[$imap[$ind]];\n"
                           if $ind != $imap[$ind];
		}
	}
	for $ind (reverse 0..$#tmap) {
		if($tmap[$ind] == -1) {
                       $tcode .= "\$a[$ind] = $::PDLOBJ->nullcreate(\$a[0])\n;"; # Create a null using nullcreate
		} else {
                       $tcode .= "\$a[$ind] = \$a[$tmap[$ind]];\n"
                           if $ind != $tmap[$ind];
		}
	}
#	print "COUNTS0: $acnt $tcnt $icnt\n";
	$acnt += scalar(@$onames);
#	print "COUNTS: $acnt $tcnt $icnt\n";

	return "sub ".$::PDLOBJ."::$name {
               my \@a = \@_;
               if(\$#a == ". ($acnt-1) ." || \$#a == -1 ) { &".$::PDLOBJ."::".$newxsname."; }
                elsif(\$#a == ". ($tcnt-1) .") {
		 	$tcode
                       &".$::PDLOBJ."::".$newxsname."(\@a);\@a=();
               } elsif(\$#a == ". ($icnt-1) .") {
			my \@ret;
			$icode
                       &".$::PDLOBJ."::".$newxsname."(\@a);\@a=();
			return wantarray?(\@ret):\$ret[0];
		} else {
			barf \"Invalid number of arguments for $name\";
		}
		}";
# THIS IS BAD: ASSIGNMENTS DON'T WORK.
	return "sub ".$::PDLOBJ."::$name {
		if(\$#_ == ". ($acnt-1) ." || \$#_ == -1 ) { &".$::PDLOBJ."::".$newxsname."; }
		 elsif(\$#_ == ". ($tcnt-1) .") {
		 	$tspl
			&".$::PDLOBJ."::".$newxsname.";
		} elsif(\$#_ == ". ($icnt-1) .") {
			my \@ret;
			$ispl
			&".$::PDLOBJ."::".$newxsname.";
			return wantarray?(\@ret):\$ret[0];
		}
		}";
}