view release on metacpan or  search on metacpan

lib/PDL/PP.pm  view on Meta::CPAN

        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[
\nvoid
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) = @_;