#####################################################################
#####################################################################
##
##
## 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];
}
}";
}
syntax highlighted by Code2HTML, v. 0.9.1