GSP
Quick Navigator

Search Site

Unix VPS
A - Starter
B - Basic
C - Preferred
D - Commercial
MPS - Dedicated
Previous VPSs
* Sign Up! *

Support
Contact Us
Online Help
Handbooks
Domain Status
Man Pages

FAQ
Virtual Servers
Pricing
Billing
Technical

Network
Facilities
Connectivity
Topology Map

Miscellaneous
Server Agreement
Year 2038
Credits
 

USA Flag

 

 

Man Pages
PDL::PP(3) User Contributed Perl Documentation PDL::PP(3)

$miscdocs

XXX=cut

EOD
$baddoc_function_pod =~ s/^XXX=/=/gms;
$baddoc_function_pod;
}
),

   PDL::PP::Rule::Returns::EmptyString->new("HdrCode", [],
    'Code that will be inserted before the call to the RunFunc'),
   PDL::PP::Rule::Returns::EmptyString->new("FtrCode", [],
    'Code that will be inserted after the call to the RunFunc'),
   PDL::PP::Rule->new("VarArgsXSHdr",
      [qw(Name SignatureObj
       OtherParsDefaults? ArgOrder? InplaceNormalised?)],
      'XS code to process input arguments based on supplied Pars argument to pp_def; not done if GlobalNew or PMCode supplied',
      sub {
        my($name,$sig,
           $otherdefaults,$argorder,$inplace) = @_;
        my @args = @{ $sig->args_callorder };
        my %other = map +($_=>1), @{$sig->othernames(1, 1)};
        $otherdefaults ||= {};
        my $ci = 2;  # current indenting
        my $optypes = $sig->otherobjs;
        my %ptypes = map +($_=>$$optypes{$_} ? $$optypes{$_}->get_decl('', {VarArrays2Ptrs=>1}) : 'pdl *'), @args;
        my %out = map +($_=>1), $sig->names_out_nca;
        my %outca = map +($_=>1), $sig->names_oca;
        my @inargs = grep !$outca{$_}, @args;
        my %other_out = map +($_=>1), $sig->other_out;
        my $nout   = keys(%out) + keys(%other_out);
        my $noutca = keys %outca;
        my $ntot   = @args;
        my $nallout = $nout + $noutca;
        my $ndefault = keys %$otherdefaults;
        my %valid_itemcounts = ((my $nmaxonstack = $ntot - $noutca)=>1);
        $valid_itemcounts{my $nin = $nmaxonstack - $nout} = 1;
        $valid_itemcounts{my $nin_minus_default = "($nin-$ndefault)"} = 1 if $ndefault;
        my $only_one = keys(%valid_itemcounts) == 1;
        my $nretval = $argorder ? $nout :
          $only_one ? $noutca :
          "(items == $nmaxonstack) ? $noutca : $nallout";
        my ($cnt, @preinit, @xsargs, %already_read, %name2cnts) = -1;
        my @inputdecls = map "PDL_Indx ${_}_count=0;", grep $other{$_} && $optypes->{$_}->is_array, @inargs;
        foreach my $x (@inargs) {
          if (!$argorder && ($out{$x} || $other_out{$x} || exists $otherdefaults->{$x})) {
            last if @xsargs + keys(%out) + $noutca != $ntot;
            $argorder = 1; # remaining all output ndarrays, engage
          }
          $cnt++;
          $name2cnts{$x} = [$cnt, $cnt];
          $already_read{$x} = 1;
          push @xsargs, $x.(!$argorder ? '' :
            exists $otherdefaults->{$x} ? "=$otherdefaults->{$x}" :
            !$out{$x} ? '' :
            $inplace && $x eq $inplace->[1] ? "=$x" :
            "=".callPerlInit($x."_SV")
            );
          push @inputdecls, "$ptypes{$x}$x".($inplace && $x eq $inplace->[1] ? "=NO_INIT" : '');
        }
        my $shortcnt = my $xs_arg_cnt = $cnt;
        foreach my $x (@inargs[$cnt+1..$nmaxonstack-1]) {
          $cnt++;
          $name2cnts{$x} = [$cnt, undef];
          $name2cnts{$x}[1] = ++$shortcnt if !($out{$x} || $other_out{$x});
          push @xsargs, "$x=$x";
          push @inputdecls, "$ptypes{$x}$x".($other{$x} && !exists $otherdefaults->{$x} ? "; { ".callTypemap($x, $ptypes{$x}, $name)."; }" : "=NO_INIT");
        }
        push @inputdecls, map "$ptypes{$_}$_=".callPerlInit($_."_SV").";", grep $outca{$_}, @args;
        my $defaults_rawcond = $ndefault ? "items == $nin_minus_default" : '';
        my $svdecls = join '', map "\n  $_",
          (map "SV *${_}_SV = ".(
            !$name2cnts{$_} ? 'NULL' :
            ($argorder || (defined $otherdefaults->{$_} && !$nout)) ? "items > $name2cnts{$_}[1] ? ST($name2cnts{$_}[1]) : ".($other_out{$_} ? "sv_newmortal()" : "NULL") :
            $name2cnts{$_}[0] == ($name2cnts{$_}[1]//-1) ? "ST($name2cnts{$_}[0])" :
            "(items == $nmaxonstack) ? ST($name2cnts{$_}[0]) : ".
            (!defined $name2cnts{$_}[1] ? ($other_out{$_} ? "sv_newmortal()" : "NULL") :
              defined $otherdefaults->{$_} ? "!($defaults_rawcond) ? ST($name2cnts{$_}[1]) : ".($other_out{$_} ? "sv_newmortal()" : "NULL") :
              "ST($name2cnts{$_}[1])"
            )
          ).";", (grep !$already_read{$_}, $sig->names_in), $sig->names_out, @{$sig->othernames(1, 1, \%already_read)}),
          ;
        my $argcode =
          indent(2, join '',
            (map
              "if (!${_}_SV) { $_ = ($otherdefaults->{$_}); } else ".
              "{ ".callTypemap($_, $ptypes{$_}, $name)."; }\n",
              grep !$argorder && exists $otherdefaults->{$_}, @{$sig->othernames(1, 1)}),
            (map callTypemap($_, $ptypes{$_}, $name).";\n", grep !$already_read{$_}, $sig->names_in),
            (map +("if (${_}_SV) { ".($argorder ? '' : callTypemap($_, $ptypes{$_}, $name))."; } else ")."$_ = ".callPerlInit($_."_SV").";\n", grep $out{$_} && !$already_read{$_} && !($inplace && $_ eq $inplace->[1]), @args)
          );
        push @preinit, qq[PDL_XS_PREAMBLE($nretval);] if $nallout;
        push @preinit, qq{if (!(@{[join ' || ', map "(items == $_)", sort keys %valid_itemcounts]}))
    croak("Usage: ${main::PDLOBJ}::$name(@{[
        join ",", map exists $otherdefaults->{$_} ? "$_=$otherdefaults->{$_}" :
             $out{$_} || $other_out{$_} ? "[$_]" : $_, @inargs
    ]}) (you may leave [outputs] and values with =defaults out of list)");}
          unless $only_one || $argorder || ($nmaxonstack == keys(%valid_itemcounts) + $xs_arg_cnt);
        my $preamble = @preinit ? qq[\n PREINIT:@{[join "\n  ", "", @preinit]}\n INPUT:\n] : '';
        join '', qq[
\nNO_OUTPUT pdl_error
pdl_run_$name(@{[join ', ', @xsargs]})$svdecls
$preamble@{[join "\n  ", "", @inputdecls]}
 PPCODE:
], map "$_\n", $argcode;
      }),
   # globalnew implies internal usage, not XS
   PDL::PP::Rule::Returns->new("VarArgsXSReturn","GlobalNew",undef),
   PDL::PP::Rule->new("FixArgsXSOtherOutDeclSV",
      ["SignatureObj"],
      "Generate XS to declare SVs for output OtherPars",
      sub {
        my ($sig) = @_;
        my $optypes = $sig->otherobjs;
        my @args = @{ $sig->allnames(1, 1) };
        my %outca = map +($_=>1), $sig->names_oca;
        my %other_output = map +($_=>1), my @other_output = ($sig->other_io, $sig->other_out);
        my $ci = 2;
        my $cnt = 0; my %outother2cnt;
        foreach my $x (grep !$outca{$_}, @args) {
            $outother2cnt{$x} = $cnt if $other_output{$x};
            $cnt++;
        }
        join "\n", map indent($ci,qq{SV *${_}_SV = ST($outother2cnt{$_});}), @other_output;
      }),
   PDL::PP::Rule->new("XSOtherOutSet",
      [qw(Name SignatureObj)],
      "Generate XS to set SVs to output values for OtherPars",
      sub {
        my ($name, $sig) = @_;
        my $clause1 = '';
        my @other_output = ($sig->other_io, $sig->other_out);
        my $optypes = $sig->otherobjs;
        my %ptypes = map +($_=>$$optypes{$_}->get_decl('', {VarArrays2Ptrs=>1})), @other_output;
        for my $x (@other_output) {
          my ($setter, $type) = typemap($ptypes{$x}, 'get_outputmap');
          $setter = typemap_eval($setter, {var=>$x, type=>$type, arg=>"tsv",
              pname=>$name});
          $clause1 .= <<EOF;
if (!${x}_SV)
  PDL->pdl_barf("Internal error in $name: tried to output to NULL ${x}_SV");
{\n  SV *tsv = sv_newmortal();
$setter
  sv_setsv(${x}_SV, tsv);\n}
EOF
        }
        indent(2, $clause1);
      }),
   PDL::PP::Rule->new("VarArgsXSReturn",
      ["SignatureObj"],
      "Generate XS trailer to return output variables or leave them as modified input variables",
      sub {
        my ($sig) = @_;
        my $oc = my @outs = $sig->names_out; # output ndarrays in calling order
        my @other_outputs = ($sig->other_io, $sig->other_out); # output OtherPars
        my $clause1 = join ';', (map "ST($_) = $outs[$_]_SV", 0 .. $#outs),
          (map "ST(@{[$_+$oc]}) = $other_outputs[$_]_SV", 0 .. $#other_outputs);
        $clause1 ? indent(2,"PDL_XS_RETURN($clause1)\n") : '';
      }),
   PDL::PP::Rule->new("NewXSHdr", ["NewXSName","SignatureObj"],
      sub {
        my($name,$sig) = @_;
        my $shortpars = join ',', @{ $sig->allnames(1, 1) };
        my $optypes = $sig->otherobjs;
        my @counts = map "PDL_Indx ${_}_count=0;", grep $optypes->{$_}->is_array, @{ $sig->othernames(1, 1) };
        my $longpars = join "\n", map "  $_", @counts, $sig->alldecls(1, 0, 1);
        return<<END;
\nNO_OUTPUT pdl_error
$name($shortpars)
$longpars
END
      }),
   PDL::PP::Rule::InsertName->new("RunFuncName", 'pdl_run_%s'),
   PDL::PP::Rule->new("NewXSCHdrs", ["RunFuncName","SignatureObj","GlobalNew"],
      sub {
        my($name,$sig,$gname) = @_;
        my $longpars = join ",", $sig->alldecls(0, 1);
        my $opening = '  pdl_error PDL_err = {0, NULL, 0};';
        my $closing = '  return PDL_err;';
        return ["pdl_error $name($longpars) {$opening","$closing}",
                "  PDL->$gname = $name;"];
      }),
   PDL::PP::Rule->new(["RunFuncCall","RunFuncHdr"],["RunFuncName","SignatureObj"], sub {
        my ($func_name,$sig) = @_;
        my $shortpars = join ',', map $sig->other_is_output($_)?"&$_":$_, @{ $sig->allnames(0) };
        my $longpars = join ",", $sig->alldecls(0, 1);
        (indent(2,"RETVAL = $func_name($shortpars);\nPDL->barf_if_error(RETVAL);\n"),
          "pdl_error $func_name($longpars)");
      }),
   PDL::PP::Rule->new("IgnoreTypesOf", ["FTypes","SignatureObj"], sub {
      my ($ftypes, $sig) = @_;
      my ($pnames, $pobjs) = ($sig->names_sorted, $sig->objs);
      $_->{FlagIgnore} = 1 for grep $ftypes->{$_->{Name}}, @$pobjs{@$pnames};
      +{map +($_,1), keys %$ftypes};
   }),
   PDL::PP::Rule::Returns->new("IgnoreTypesOf", {}),
   PDL::PP::Rule->new("NewXSTypeCoerceNS", ["StructName"],
      sub { "  PDL_RETERROR(PDL_err, PDL->type_coerce($_[0]));\n" }),
   PDL::PP::Rule::Substitute->new("NewXSTypeCoerceSubd", "NewXSTypeCoerceNS"),
   PDL::PP::Rule->new("NewXSRunTrans", ["StructName"], sub {
      my($trans) = @_;
      "  PDL_RETERROR(PDL_err, PDL->make_trans_mutual($trans));\n";
   }),
   PDL::PP::Rule->new(["StructDecl","ParamStructType"],
      ["CompStruct","Name"],
      sub {
        my($comp,$name) = @_;
        return ('', '') if !$comp;
        my $ptype = "pdl_params_$name";
        (PDL::PP::pp_line_numbers(__LINE__-1, qq[typedef struct $ptype {\n]).qq[$comp\n} $ptype;],
        $ptype);
      }),

do { sub wrap_vfn {
my (
$code,$rout,$func_header,
$all_func_header,$sname,$pname,$ptype,$extra_args,
) = @_;
join "", PDL::PP::pp_line_numbers(__LINE__, qq[pdl_error $rout(pdl_trans *$sname$extra_args) {
pdl_error PDL_err = {0, NULL, 0};]),
($ptype ? " $ptype *$pname = $sname->params; (void)$pname;\n" : ''),
indent(2, join '', grep $_, $all_func_header, $func_header, $code),
" return PDL_err;\n}"; } sub make_vfn_args {
my ($which, $extra_args) = @_;
("${which}Func",
["${which}CodeSubd","${which}FuncName","${which}FuncHeader?",
qw(AllFuncHeader? StructName ParamStructName ParamStructType),
],
sub {$_[1] eq 'NULL' ? '' : wrap_vfn(@_,$extra_args//'')}
); } ()},

   PDL::PP::Rule->new("MakeCompOther", [qw(SignatureObj ParamStructName)], sub { $_[0]->getcopy("$_[1]->%s") }),
   PDL::PP::Rule->new("MakeCompTotal", [qw(MakeCompOther MakeComp?)], sub { join "\n", grep $_, @_ }),
   PDL::PP::Rule::Substitute->new("MakeCompiledReprSubd", "MakeCompTotal"),
   PDL::PP::Rule->new("NewXSSetTransPDLs", ["SignatureObj","StructName"], sub {
      my($sig,$trans) = @_;
      join '',
        map "  $trans->pdls[$_->[0]] = $_->[2];\n",
        grep !$_->[1], $sig->names_sorted_tuples;
   }),
   PDL::PP::Rule->new("NewXSExtractTransPDLs", [qw(SignatureObj StructName MakeComp?)], sub {
      my($sig,$trans,$makecomp) = @_;
      !$makecomp ? '' : join '',
        map "  $_->[2] = $trans->pdls[$_->[0]];\n",
        grep !$_->[1], $sig->names_sorted_tuples;
   }),
   (map PDL::PP::Rule::Substitute->new("${_}ReadDataCodeUnparsed", "${_}Code"), '', 'Bad'),
   PDL::PP::Rule->new(PDL::PP::Code::make_args(qw(ReadData)),
                      sub { PDL::PP::Code->new(@_, undef, undef, 1); }),
   PDL::PP::Rule::Substitute->new("ReadDataCodeSubd", "ReadDataCodeParsed"),
   PDL::PP::Rule::InsertName->new("ReadDataFuncName", 'pdl_%s_readdata'),
   PDL::PP::Rule->new(make_vfn_args("ReadData")),
   (map PDL::PP::Rule::Substitute->new("${_}WriteBackDataCodeUnparsed", "${_}BackCode"), '', 'Bad'),
   PDL::PP::Rule->new(PDL::PP::Code::make_args(qw(WriteBackData)),
                      sub { PDL::PP::Code->new(@_, undef, 1, 1); }),
   PDL::PP::Rule::Substitute->new("WriteBackDataCodeSubd", "WriteBackDataCodeParsed"),
   PDL::PP::Rule::InsertName->new("WriteBackDataFuncName", "BackCode", 'pdl_%s_writebackdata'),
   PDL::PP::Rule::Returns::NULL->new("WriteBackDataFuncName", "Code"),
   PDL::PP::Rule->new(make_vfn_args("WriteBackData")),
   # CORE21 move this into pdlapi so RedoDims without Code can broadcast
   PDL::PP::Rule->new("DefaultRedoDims",
      ["StructName"],
      sub { "PDL_RETERROR(PDL_err, PDL->redodims_default($_[0]));\n" }),
   PDL::PP::Rule->new("DimsSetters",
      ["SignatureObj"],
      sub { $_[0]->dims_init }),
   PDL::PP::Rule->new("RedoDimsFuncName", [qw(Name RedoDims? RedoDimsCode? DimsSetters)],
      sub { (scalar grep $_ && /\S/, @_[1..$#_]) ? "pdl_$_[0]_redodims" : 'NULL'}),
   PDL::PP::Rule::Returns->new("RedoDimsCode", [],
                               'Code that can be inserted to set the size of output ndarrays dynamically based on input ndarrays; is parsed',
                               ''),
   (map PDL::PP::Rule::Substitute->new("RedoDims${_}Unparsed", "RedoDims$_"), '', 'Code'),
   PDL::PP::Rule->new(PDL::PP::Code::make_args(qw(RedoDims)),
      'makes the parsed representation from the supplied RedoDimsCode',
      sub { return '' if !$_[0]; PDL::PP::Code->new(@_, 1, undef, 0); }),
   PDL::PP::Rule->new("RedoDimsCodeParsed","RedoDimsUnparsed", sub {@_}),
   PDL::PP::Rule->new("RedoDims",
      ["DimsSetters","RedoDimsCodeParsed","DefaultRedoDims"],
      'makes the redodims function from the various bits and pieces',
      sub { join "\n", grep $_ && /\S/, @_ }),
   PDL::PP::Rule::Substitute->new("RedoDimsCodeSubd", "RedoDims"),
   PDL::PP::Rule->new(make_vfn_args("RedoDims")),
   PDL::PP::Rule->new("CompFreeCode", [qw(CompObj CompFreeCodeComp?)],
    "Free any OtherPars/Comp stuff, including user-supplied code (which is probably paired with own MakeComp)",
    sub {join '', grep defined() && length, $_[0]->getfree("COMP"), @_[1..$#_]},
   ),
   PDL::PP::Rule->new("NTPrivFreeCode", "PrivObj", sub {$_[0]->getfree("PRIV")}),
   PDL::PP::Rule->new("FreeCodeNS",
      ["StructName","CompFreeCode","NTPrivFreeCode"],
      sub {
          (grep $_, @_[1..$#_]) ? "PDL_FREE_CODE($_[0], destroy, $_[1], $_[2])" : ''}),
   PDL::PP::Rule::Substitute->new("FreeCodeSubd", "FreeCodeNS"),
   PDL::PP::Rule->new("FreeFuncName",
                      ["FreeCodeSubd","Name"],
                      sub {$_[0] ? "pdl_$_[1]_free" : 'NULL'}),
   PDL::PP::Rule->new(make_vfn_args("Free", ", char destroy")),
   PDL::PP::Rule->new("NewXSCoerceMustNS", "FTypes",
      sub {
        my($ftypes) = @_;
        join '', map
          PDL::PP::pp_line_numbers(__LINE__, "$_->datatype = $ftypes->{$_};"),
          sort keys %$ftypes;
      }),
   PDL::PP::Rule::Returns::EmptyString->new("NewXSCoerceMustNS"),
   PDL::PP::Rule::Substitute->new("NewXSCoerceMustCompSubd", "NewXSCoerceMustNS"),
   PDL::PP::Rule->new("NewXSStructInit0",
                      ["StructName","VTableName","ParamStructName","ParamStructType"],
                      "Rule to create and initialise the private trans structure",
      sub {
        my( $sname, $vtable, $pname, $ptype ) = @_;
        indent(2, <<EOF . ($ptype ? "$ptype *$pname = $sname->params;\n" : ""));
if (!PDL) return (pdl_error){PDL_EFATAL, "PDL core struct is NULL, can't continue",0};
pdl_trans *$sname = PDL->create_trans(&$vtable);
if (!$sname) return PDL->make_error_simple(PDL_EFATAL, "Couldn't create trans");
EOF
      }),
   PDL::PP::Rule->new(["RunFunc"],
      ["RunFuncHdr",
        "NewXSStructInit0",
        "NewXSSetTransPDLs",
        "NewXSTypeCoerceSubd",
        "NewXSExtractTransPDLs",
        "MakeCompiledReprSubd",
        "NewXSCoerceMustCompSubd",
        "NewXSRunTrans",
      ],
      "Generate C function with idiomatic arg list to maybe call from XS",
      sub {
        my ($xs_c_header, @bits) = @_;
        my $opening = '  pdl_error PDL_err = {0, NULL, 0};';
        my $closing = '  return PDL_err;';
        join '', "$xs_c_header {\n$opening\n", @bits, "$closing\n}\n";
      }),
   # internal usage, not XS - NewXSCHdrs only set if GlobalNew
   PDL::PP::Rule->new(["NewXSCode","BootSetNewXS","NewXSInPrelude"],
      ["NewXSHdr", "NewXSCHdrs", "RunFuncCall"],
      "Non-varargs XS code when GlobalNew given",
      sub {(undef,(make_xs_code(' CODE:','',@_))[1..2])}),
   # if PMCode supplied, no var-args stuff
   PDL::PP::Rule->new(["NewXSCode","BootSetNewXS","NewXSInPrelude"],
      [qw(PMCode NewXSHdr NewXSCHdrs? FixArgsXSOtherOutDeclSV HdrCode RunFuncCall FtrCode XSOtherOutSet)],
      "Non-varargs XS code when PMCode given",
      sub {make_xs_code(' CODE:','',@_[1..$#_])}),
   PDL::PP::Rule->new(["NewXSCode","BootSetNewXS","NewXSInPrelude"],
      [qw(VarArgsXSHdr NewXSCHdrs? HdrCode InplaceCode RunFuncCall FtrCode XSOtherOutSet VarArgsXSReturn)],
      "Rule to print out XS code when variable argument list XS processing is enabled",
      sub {make_xs_code('','',@_)}),
   PDL::PP::Rule->new("VTableDef",
      ["VTableName","ParamStructType","RedoDimsFuncName","ReadDataFuncName",
       "WriteBackDataFuncName","FreeFuncName",
       "SignatureObj","HaveBroadcasting","NoPthread","Name",
       "GenericTypes","IsAffineFlag","TwoWayFlag","DefaultFlowFlag",
       "BadFlag"],
      sub {
        my($vname,$ptype,$rdname,$rfname,$wfname,$ffname,
           $sig,$havebroadcasting, $noPthreadFlag, $name, $gentypes,
           $affflag, $revflag, $flowflag, $badflag) = @_;
        my ($pnames, $pobjs) = ($sig->names_sorted, $sig->objs);
        my $nparents = 0 + grep !$pobjs->{$_}->{FlagW}, @$pnames;
        my $npdls = scalar @$pnames;
        my @op_flags;
        push @op_flags, 'PDL_TRANS_DO_BROADCAST' if $havebroadcasting;
        push @op_flags, 'PDL_TRANS_BADPROCESS' if $badflag;
        push @op_flags, 'PDL_TRANS_BADIGNORE' if defined $badflag and !$badflag;
        push @op_flags, 'PDL_TRANS_NO_PARALLEL' if $noPthreadFlag;
        push @op_flags, 'PDL_TRANS_OUTPUT_OTHERPAR' if $sig->other_any_out;
        my $op_flags = join('|', @op_flags) || '0';
        my $iflags = join('|', grep $_, $affflag, $revflag, $flowflag) || '0';
        my $gentypes_txt = join(", ", (map PDL::Type->new($_)->sym, @$gentypes), '-1');
        my @realdims = map 0+@{$_->{IndObjs}}, @$pobjs{@$pnames};
        my $realdims = join(", ", @realdims) || '0';
        my $parnames = join(",",map qq|"$_"|, @$pnames) || '""';
        my $parflags = join(",\n  ",map join('|', $_->cflags)||'0', @$pobjs{@$pnames}) || '0';
        my $partypes = join(", ", map defined()?$_->sym:-1, map $_->{Type}, @$pobjs{@$pnames}) || '-1';
        my $i = 0; my @starts = map { my $ci = $i; $i += $_; $ci } @realdims;
        my $realdim_ind_start = join(", ", @starts) || '0';
        my @rd_inds = map $_->get_index, map @{$_->{IndObjs}}, @$pobjs{@$pnames};
        my $realdim_inds = join(", ", @rd_inds) || '0';
        my @indnames = sort $sig->dims_obj->ind_names;
        my $indnames = join(",", map qq|"$_"|, @indnames) || '""';
        my $sizeof = $ptype ? "sizeof($ptype)" : '0';
        <<EOF;
static pdl_datatypes ${vname}_gentypes[] = { $gentypes_txt };
static PDL_Indx ${vname}_realdims[] = { $realdims };
static char *${vname}_parnames[] = { $parnames };
static short ${vname}_parflags[] = {
  $parflags
};
static pdl_datatypes ${vname}_partypes[] = { $partypes };
static PDL_Indx ${vname}_realdims_starts[] = { $realdim_ind_start };
static PDL_Indx ${vname}_realdims_ind_ids[] = { $realdim_inds };
static char *${vname}_indnames[] = { $indnames };
pdl_transvtable $vname = {
  $op_flags, $iflags, ${vname}_gentypes, $nparents, $npdls, NULL /*CORE21*/,
  ${vname}_realdims, ${vname}_parnames,
  ${vname}_parflags, ${vname}_partypes,
  ${vname}_realdims_starts, ${vname}_realdims_ind_ids, @{[scalar @rd_inds]},
  @{[scalar @indnames]}, ${vname}_indnames,
  $rdname, $rfname, $wfname,
  $ffname,
  $sizeof,"$::PDLMOD\::$name"
};
EOF
      }),
   PDL::PP::Rule->new('PMFunc', 'Name',
     'Sets PMFunc to default symbol table manipulations',
     sub {
         my ($name) = @_;
         $::PDL_IFBEGINWRAP[0].'*'.$name.' = \&'.$::PDLOBJ.
                   '::'.$name.";\n".$::PDL_IFBEGINWRAP[1]
     }
   ),
   PDL::PP::Rule->new([], [qw(Lvalue Name)],
     'If Lvalue key, make the XS routine be lvalue with CvLVALUE_on',
     sub {
       my (undef, $name) = @_;
       push @::PDL_LVALUE_SUBS, $name;
       ();
     }
   ),

]; }

1;

2025-03-27 perl v5.40.2

Search for    or go to Top of page |  Section 3 |  Main Index

Powered by GSP Visit the GSP FreeBSD Man Page Interface.
Output converted with ManDoc.