view release on metacpan or  search on metacpan

Basic/Gen/PP.pm  view on Meta::CPAN

      $clause2 = "\n  else if (items == $ninout) { PDLA_COMMENT(\"all but temps on stack, read in output, create temps\")" .
	  "    nreturn = $noutca;\n";

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

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

  }

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

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

  # Bitwise ops may get five args
  my $bitwise_cond = $bitwise ? " || items == 5" : '';

  return<<END;

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

 PPCODE:

{
  PDLA_COMMENT("Check if you can get a package name for this input value.  ")
  PDLA_COMMENT("It can be either a PDLA (SVt_PVMG) or a hash which is a     ")
  PDLA_COMMENT("derived PDLA subclass (SVt_PVHV)                            ")

  if (SvROK(ST(0)) && ((SvTYPE(SvRV(ST(0))) == SVt_PVMG) || (SvTYPE(SvRV(ST(0))) == SVt_PVHV))) {
    parent = ST(0);
    if (sv_isobject(parent)){
	bless_stash = SvSTASH(SvRV(ST(0)));
	objname = HvNAME((bless_stash));  PDLA_COMMENT("The package to bless output vars into is taken from the first input var")
    }
  }
  if (items == $nmaxonstack) { PDLA_COMMENT("all variables on stack, read in output and temp vars")
    nreturn = $noutca;
$clause1
  }
$clause2
  else if (items == $nin$bitwise_cond) { PDLA_COMMENT("only input variables on stack, create outputs and temps")
    nreturn = $nallout;
$clause3
  }

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

} # sub: VarArgsXSHdr()

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

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

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

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

    my $ci = '  ';  # Current indenting

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