"Fossies" - the Fresh Open Source Software Archive  

Source code changes of the file "Basic/Gen/PP.pm" between
PDL-2.080.tar.gz and PDL-2.081.tar.gz

About: PDL (Perl Data Language) aims to turn perl into an efficient numerical language for scientific computing (similar to IDL and MatLab).

[ To the main PDL source changes report ]

PP.pm  (PDL-2.080):PP.pm  (PDL-2.081)
skipping to change at line 383 skipping to change at line 383
my ($cn,$co) = map $cobj->$_, qw(othernames otherobjs); my ($cn,$co) = map $cobj->$_, qw(othernames otherobjs);
push @pairs, 'DO'.$which.'ALLOC' => sub { push @pairs, 'DO'.$which.'ALLOC' => sub {
join '', map $$co{$_}->get_malloc("\$$which($_)"), join '', map $$co{$_}->get_malloc("\$$which($_)"),
grep $$co{$_}->need_malloc, @$cn grep $$co{$_}->need_malloc, @$cn
}; };
} }
my %syms = ( my %syms = (
@pairs, @pairs,
((ref $src) ? %{$src->[1]} : ()), ((ref $src) ? %{$src->[1]} : ()),
PRIV => sub {return "$sname->$_[0]"}, PRIV => sub {return "$sname->$_[0]"},
COMP => sub {return "$pname->$_[0]"}, COMP => sub {my $r="$pname->$_[0]";$sig->other_is_out($_[0])?"(*($r))":$r} ,
CROAK => sub {PDL::PP::pp_line_numbers(__LINE__-1, "return PDL->make_error (PDL_EUSERERROR, \"Error in $name:\" @{[join ',', @_]})")}, CROAK => sub {PDL::PP::pp_line_numbers(__LINE__-1, "return PDL->make_error (PDL_EUSERERROR, \"Error in $name:\" @{[join ',', @_]})")},
NAME => sub {return $name}, NAME => sub {return $name},
MODULE => sub {return $::PDLMOD}, MODULE => sub {return $::PDLMOD},
SETPDLSTATEBAD => sub { PDL::PP::pp_line_numbers(__LINE__-1, "$_[0]\->sta te |= PDL_BADVAL") }, SETPDLSTATEBAD => sub { PDL::PP::pp_line_numbers(__LINE__-1, "$_[0]\->sta te |= PDL_BADVAL") },
SETPDLSTATEGOOD => sub { PDL::PP::pp_line_numbers(__LINE__-1, "$_[0]\->sta te &= ~PDL_BADVAL") }, SETPDLSTATEGOOD => sub { PDL::PP::pp_line_numbers(__LINE__-1, "$_[0]\->sta te &= ~PDL_BADVAL") },
ISPDLSTATEBAD => \&badflag_isset, ISPDLSTATEBAD => \&badflag_isset,
ISPDLSTATEGOOD => sub {"!".badflag_isset($_[0])}, ISPDLSTATEGOOD => sub {"!".badflag_isset($_[0])},
BADFLAGCACHE => sub { PDL::PP::pp_line_numbers(__LINE__-1, "badflag_cac he") }, BADFLAGCACHE => sub { PDL::PP::pp_line_numbers(__LINE__-1, "badflag_cac he") },
PDLSTATESETBAD => sub { PDL::PP::pp_line_numbers(__LINE__-1, ($sig->objs-> {$_[0]}//confess "Can't get PDLSTATESETBAD for unknown ndarray '$_[0]'")->do_pdl access."->state |= PDL_BADVAL") }, PDLSTATESETBAD => sub { PDL::PP::pp_line_numbers(__LINE__-1, ($sig->objs-> {$_[0]}//confess "Can't get PDLSTATESETBAD for unknown ndarray '$_[0]'")->do_pdl access."->state |= PDL_BADVAL") },
PDLSTATESETGOOD => sub { PDL::PP::pp_line_numbers(__LINE__-1, ($sig->objs- >{$_[0]}->do_pdlaccess//confess "Can't get PDLSTATESETGOOD for unknown ndarray ' $_[0]'")."->state &= ~PDL_BADVAL") }, PDLSTATESETGOOD => sub { PDL::PP::pp_line_numbers(__LINE__-1, ($sig->objs- >{$_[0]}->do_pdlaccess//confess "Can't get PDLSTATESETGOOD for unknown ndarray ' $_[0]'")."->state &= ~PDL_BADVAL") },
skipping to change at line 468 skipping to change at line 468
} }
package PDL::PP; package PDL::PP;
use strict; use strict;
our $VERSION = "2.3"; our $VERSION = "2.3";
$VERSION = eval $VERSION; $VERSION = eval $VERSION;
our $macros_xs = <<'EOF'; our $macros_xs = <<'EOF';
#include "pdlperl.h"
#define PDL_XS_PREAMBLE \ #define PDL_XS_PREAMBLE \
char *objname = "PDL"; /* XXX maybe that class should actually depend on the v alue set \ char *objname = "PDL"; /* XXX maybe that class should actually depend on the v alue set \
by pp_bless ? (CS) */ \ by pp_bless ? (CS) */ \
HV *bless_stash = 0; \ HV *bless_stash = 0; \
SV *parent = 0; \ SV *parent = 0; \
int nreturn = 0; \ int nreturn = 0; \
(void)nreturn; (void)nreturn;
#define PDL_XS_PACKAGEGET \ #define PDL_XS_PACKAGEGET \
PDL_COMMENT("Check if you can get a package name for this input value. ") \ PDL_COMMENT("Check if you can get a package name for this input value. ") \
skipping to change at line 562 skipping to change at line 564
} }
#include "EXTERN.h" #include "EXTERN.h"
#include "perl.h" #include "perl.h"
#include "XSUB.h" #include "XSUB.h"
#include "pdl.h" #include "pdl.h"
#include "pdlcore.h" #include "pdlcore.h"
#define PDL %s #define PDL %s
extern Core* PDL; PDL_COMMENT("Structure hold core C functions") extern Core* PDL; PDL_COMMENT("Structure hold core C functions")
static int __pdl_boundscheck = 0; static int __pdl_boundscheck = 0;
static SV* CoreSV; PDL_COMMENT("Gets pointer to perl var holding core stru cture")
#if ! %s #if ! %s
# define PP_INDTERM(max, at) at # define PP_INDTERM(max, at) at
#else #else
# define PP_INDTERM(max, at) (__pdl_boundscheck? PDL->safe_indterm(max,at, __FIL E__, __LINE__) : at) # define PP_INDTERM(max, at) (__pdl_boundscheck? PDL->safe_indterm(max,at, __FIL E__, __LINE__) : at)
#endif #endif
EOF EOF
our $header_xs = pp_line_numbers(__LINE__, <<'EOF'); our $header_xs = pp_line_numbers(__LINE__, <<'EOF');
Core* PDL = NULL; PDL_COMMENT("Structure hold core C functions") Core* PDL = NULL; PDL_COMMENT("Structure hold core C functions")
MODULE = %1$s PACKAGE = %1$s MODULE = %1$s PACKAGE = %1$s
PROTOTYPES: ENABLE PROTOTYPES: DISABLE
int int
set_boundscheck(i) set_boundscheck(i)
int i; int i;
CODE: CODE:
if (! %6$s) if (! %6$s)
warn("Bounds checking is disabled for %1$s"); warn("Bounds checking is disabled for %1$s");
RETVAL = __pdl_boundscheck; RETVAL = __pdl_boundscheck;
__pdl_boundscheck = i; __pdl_boundscheck = i;
OUTPUT: OUTPUT:
skipping to change at line 1002 skipping to change at line 1003
XXX=cut XXX=cut
EOF EOF
$deprecation_notice =~ s/^XXX=/=/gms; $deprecation_notice =~ s/^XXX=/=/gms;
pp_addpm( {At => 'Top'}, $deprecation_notice ); pp_addpm( {At => 'Top'}, $deprecation_notice );
pp_addpm {At => 'Top'}, <<EOF; pp_addpm {At => 'Top'}, <<EOF;
warn \"$warning_main\n$warning_suppression_runtime\" unless \$ENV{$envvar}; warn \"$warning_main\n$warning_suppression_runtime\" unless \$ENV{$envvar};
EOF EOF
} }
use Carp; use Carp;
$SIG{__DIE__} = \&Carp::confess if $::PP_VERBOSE; $SIG{__DIE__} = \&Carp::confess if $::PP_VERBOSE;
$|=1; my $typemap_obj;
sub _load_typemap {
# require ExtUtils::Typemaps;
# 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)
#
# 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 typem
ap.
# 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);
# according to MM_Unix 'privlibexp' is the right directory # according to MM_Unix 'privlibexp' is the right directory
# seems to work even on OS X (where installprivlib breaks things) # seems to work even on OS X (where installprivlib breaks things)
my $_rootdir = $Config{privlibexp}.'/ExtUtils/'; my $_rootdir = $Config{privlibexp}.'/ExtUtils/';
# First the system typemaps.. # First the system typemaps..
my @tm = ($_rootdir.'../../../../lib/ExtUtils/typemap', my @tm = ($_rootdir.'../../../../lib/ExtUtils/typemap',
$_rootdir.'../../../lib/ExtUtils/typemap', $_rootdir.'../../../lib/ExtUtils/typemap',
$_rootdir.'../../lib/ExtUtils/typemap', $_rootdir.'../../lib/ExtUtils/typemap',
$_rootdir.'../../../typemap', $_rootdir.'../../../typemap',
$_rootdir.'../../typemap', $_rootdir.'../typemap', $_rootdir.'../../typemap', $_rootdir.'../typemap',
$_rootdir.'typemap'); $_rootdir.'typemap');
# 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, &PDL::Core::Dev::PDL_TYPEMAP, '../../typemap', '../typemap', 'typema p'; push @tm, &PDL::Core::Dev::PDL_TYPEMAP, '../../typemap', '../typemap', 'typema p';
carp "**CRITICAL** PP found no typemap in $_rootdir/typemap; this will cause p roblems..." carp "**CRITICAL** PP found no typemaps in (@tm)"
unless my @typemaps = grep -f $_ && -T _, @tm; unless my @typemaps = grep -f $_ && -T _, @tm;
foreach $typemap (@typemaps) { $typemap_obj = ExtUtils::Typemaps->new;
open(my $fh, $typemap) $typemap_obj->merge(file => $_, replace => 1) for @typemaps;
or warn("Warning: could not open typemap file '$typemap': $!\n"), next; $typemap_obj;
$mode = 'Typemap'; }
$junk = "" ; sub typemap {
$current = \$junk; my ($type, $method) = @_;
local $_; # else get "Modification of a read-only value attempted" $typemap_obj ||= _load_typemap();
while (<$fh>) { $type=ExtUtils::Typemaps::tidy_type($type);
next if /^\s*#/; my $inputmap = $typemap_obj->$method(ctype => $type);
my $line_no = $. + 1; die "The type =$type= does not have a typemap entry!\n" unless $inputmap;
if (/^INPUT\s*$/) { $mode = 'Input'; $current = \$junk; next; } ($inputmap->code, $type);
if (/^OUTPUT\s*$/) { $mode = 'Output'; $current = \$junk; next; } }
if (/^TYPEMAP\s*$/) { $mode = 'Typemap'; $current = \$junk; next; } sub typemap_eval { # lifted from ExtUtils::ParseXS::Eval, ignoring eg $ALIAS
if ($mode eq 'Typemap') { my ($code, $varhash) = @_;
chomp; my ($var, $type, $num, $init, $printed_name, $arg, $ntype, $argoff, $subtype)
my $line = $_ ; = @$varhash{qw(var type num init printed_name arg ntype argoff subtype)};
TrimWhitespace($_) ; my $rv = eval qq("$code");
# skip blank lines and comment lines die $@ if $@;
next if /^$/ or /^#/ ; $rv;
my($t_type,$kind, $proto) = /^\s*(.*?\S)\s+(\S+)\s*($proto_re*)\s*$/
or
warn("Warning: File '$typemap' Line $. '$line' TYPEMAP entry need
s 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 '$p
roto'\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 $fh;
}
#
# Do checks...
#
# First reconstruct the type declaration to look up in type_kind
my $full_type=TidyType($type->get_decl('', {VarArrays2Ptrs=>1})); # Skip the v
ariable name
die "The type =$full_type= does not have a typemap entry!\n" unless exists($ty
pe_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};
$input =~ s/^(.*?)=\s*//s; # Remove all before =
$input =~ s/\$(var|\{var\})/$oname/g;
$input =~ s/\$(arg|\{arg\})/$arg/g;
$input =~ s/\$(type|\{type\})/$full_type/g;
return ($input);
} }
sub make_xs_code { sub make_xs_code {
my($xscode_before,$xscode_after,$str, my($xscode_before,$xscode_after,$str,
$xs_c_headers, $xs_c_headers,
@bits) = @_; @bits) = @_;
my($boot,$prelude); my($boot,$prelude);
if($xs_c_headers) { if($xs_c_headers) {
$prelude = join '' => ($xs_c_headers->[0], @bits, $xs_c_headers->[1]); $prelude = join '' => ($xs_c_headers->[0], @bits, $xs_c_headers->[1]);
$boot = $xs_c_headers->[2]; $boot = $xs_c_headers->[2];
skipping to change at line 1197 skipping to change at line 1071
sub indent($$) { sub indent($$) {
my ($text,$ind) = @_; my ($text,$ind) = @_;
$text =~ s/^(.*)$/$ind$1/mg; $text =~ s/^(.*)$/$ind$1/mg;
return $text; return $text;
} }
# This subroutine generates the XS code needed to call the perl 'initialize' # This subroutine generates the XS code needed to call the perl 'initialize'
# routine in order to create new output PDLs # routine in order to create new output PDLs
sub callPerlInit { sub callPerlInit {
my $names = shift; # names of variables to initialize my ($names, $callcopy) = @_;
my $ci = shift; # current indenting my $args = $callcopy ? 'parent, copy' : 'sv_2mortal(newSVpv(objname, 0)), in
my $callcopy = $#_ > -1 ? shift : 0; itialize';
my $ret = ''; join '', map PDL::PP::pp_line_numbers(__LINE__-1, "PDL_XS_PERLINIT($_, $args
foreach my $name (@$names) { )\n"), @$names;
my ($to_push, $method) = $callcopy }
? ('parent', 'copy')
: ('sv_2mortal(newSVpv(objname, 0))', 'initialize');
$ret .= PDL::PP::pp_line_numbers(__LINE__-1, "PDL_XS_PERLINIT($name, $to_
push, $method)\n");
}
indent($ret,$ci);
} #sub callPerlInit()
########################################################### ###########################################################
# Name : extract_signature_from_fulldoc # Name : extract_signature_from_fulldoc
# Usage : $sig = extract_signature_from_fulldoc($fulldoc) # Usage : $sig = extract_signature_from_fulldoc($fulldoc)
# Purpose : pull out the signature from the fulldoc string # Purpose : pull out the signature from the fulldoc string
# Returns : whatever is in parentheses in the signature, or undef # Returns : whatever is in parentheses in the signature, or undef
# Parameters : $fulldoc # Parameters : $fulldoc
# Throws : never # Throws : never
# Notes : the signature must have the following form: # Notes : the signature must have the following form:
# : # :
skipping to change at line 1693 skipping to change at line 1559
PDL::PP::Rule::Returns::EmptyString->new("HdrCode", [], PDL::PP::Rule::Returns::EmptyString->new("HdrCode", [],
'Code that will be inserted at the en d of the autogenerated xs argument processing code VargArgsXSHdr'), 'Code that will be inserted at the en d of the autogenerated xs argument processing code VargArgsXSHdr'),
PDL::PP::Rule->new("VarArgsXSHdr", PDL::PP::Rule->new("VarArgsXSHdr",
["Name","SignatureObj", ["Name","SignatureObj",
"HdrCode","InplaceCode","InplaceCheck",\"CallCopy",\"OtherParsDefaults"], "HdrCode","InplaceCode","InplaceCheck",\"CallCopy",\"OtherParsDefaults"],
'XS code to process input arguments based on supplied Pars argument to pp_ def; not done if GlobalNew or PMCode supplied', 'XS code to process input arguments based on supplied Pars argument to pp_ def; not done if GlobalNew or PMCode supplied',
sub { sub {
my($name,$sig, my($name,$sig,
$hdrcode,$inplacecode,$inplacecheck,$callcopy,$defaults) = @_; $hdrcode,$inplacecode,$inplacecheck,$callcopy,$defaults) = @_;
my $optypes = $sig->otherobjs(1); my $optypes = $sig->otherobjs;
my @args = $sig->alldecls(0, 1); my @args = @{ $sig->allnames(1) };
my %other = map +($_ => exists($$optypes{$_})), @args; my %other = map +($_ => exists($$optypes{$_})), @args;
if (keys %{ $defaults ||= {} } < keys %other) { if (keys %{ $defaults ||= {} } < keys %other) {
my $default_seen = ''; my $default_seen = '';
for (@args) { for (@args) {
$default_seen = $_ if exists $defaults->{$_}; $default_seen = $_ if exists $defaults->{$_};
confess "got default-less arg '$_' after default-ful arg '$default_s een'" confess "got default-less arg '$_' after default-ful arg '$default_s een'"
if $default_seen and !exists $defaults->{$_}; if $default_seen and !exists $defaults->{$_};
} }
} }
my $ci = ' '; # current indenting my $ci = ' '; # current indenting
my $pars = join "\n",map "$ci$_ = 0;", $sig->alldecls(1, 0); my %ptypes = map +($_=>$$optypes{$_} ? $$optypes{$_}->get_decl('', {VarA rrays2Ptrs=>1}) : 'pdl *'), @args;
my %out = map +($_=>1), $sig->names_out_nca; my %out = map +($_=>1), $sig->names_out_nca;
my %outca = map +($_=>1), $sig->names_oca; my %outca = map +($_=>1), $sig->names_oca;
my %other_out = map +($_=>1), $sig->other_out;
my %tmp = map +($_=>1), $sig->names_tmp; my %tmp = map +($_=>1), $sig->names_tmp;
# remember, otherpars *are* input vars # remember, otherpars *are* input vars
my $nout = grep $_, values %out; my $nout = grep $_, values %out;
my $noutca = grep $_, values %outca; my $noutca = grep $_, values %outca;
my $nother = grep $_, values %other; my $nother = grep $_, values %other;
my $ntmp = grep $_, values %tmp; my $ntmp = grep $_, values %tmp;
my $ntot = @args; my $ntot = @args;
my $nmaxonstack = $ntot - $noutca; my $nmaxonstack = $ntot - $noutca;
my $nin = $ntot - ($nout + $noutca); my $nin = $ntot - ($nout + $noutca);
my $ninout = $nin + $nout; my $ninout = $nin + $nout;
my $nallout = $nout + $noutca; my $nallout = $nout + $noutca;
my $ndefault = keys %$defaults; my $ndefault = keys %$defaults;
my $usageargs = join ",", map exists $defaults->{$_} ? "$_=$defaults->{$ _}" : $_, grep !$tmp{$_}, @args; my $usageargs = join ",", map exists $defaults->{$_} ? "$_=$defaults->{$ _}" : $_, grep !$tmp{$_}, @args;
# Generate declarations for SV * variables corresponding to pdl * output variables. # Generate declarations for SV * variables corresponding to pdl * output variables.
# These are used in creating output variables. One variable (ex: SV * o utvar1_SV;) # These are used in creating output variables. One variable (ex: SV * o utvar1_SV;)
# is needed for each output and output create always argument # is needed for each output and output create always argument
my $svdecls = join "\n", map "${ci}SV *${_}_SV = NULL;", $sig->names_out my $svdecls = join "\n", map indent("SV *${_}_SV = NULL;",$ci), $sig->na
; mes_out;
my $clause_inputs = ''; my %already_read; my $cnt = 0; my ($xsargs, $xsdecls) = ('', ''); my %already_read; my $cnt = 0; my %ou
tother2cnt;
foreach my $x (@args) { foreach my $x (@args) {
last if $out{$x} || $outca{$x} || $other{$x}; next if $outca{$x};
last if $out{$x} || ($other{$x} && exists $defaults->{$x});
$already_read{$x} = 1; $already_read{$x} = 1;
$clause_inputs .= "$ci$x = PDL->SvPDLV(ST($cnt));\n"; $xsargs .= "$x, "; $xsdecls .= "\n\t$ptypes{$x}$x";
$outother2cnt{$x} = $cnt if $other{$x} && $other_out{$x};
$cnt++; $cnt++;
} }
my $pars = join "\n",map indent("$_;",$ci), $sig->alldecls(0, 0, \%alrea
dy_read);
$svdecls = join "\n", grep length, $svdecls, map indent(qq{SV *${_}_SV =
@{[defined($outother2cnt{$_})?"ST($outother2cnt{$_})":'NULL']};},$ci), $sig->ot
her_out;
my @create = (); # The names of variables which need to be created by c alling my @create = (); # The names of variables which need to be created by c alling
# the 'initialize' perl routine from the correct packa ge. # the 'initialize' perl routine from the correct packa ge.
$ci = ' '; # Current indenting $ci = ' '; # Current indenting
# clause for reading in all variables # clause for reading in all variables
my $clause1 = $inplacecheck; $cnt = 0; my $clause1 = $inplacecheck; $cnt = 0;
foreach my $x (@args) { foreach my $x (@args) {
if ($other{$x}) { # other par if ($outca{$x}) {
$clause1 .= "$ci$x = " . typemap($x, $$optypes{$x}, "ST($cnt)") push @create, $x;
. ";\n";
$cnt++;
} elsif ($outca{$x}) {
push (@create, $x);
} else { } else {
$clause1 .= "$ci$x = PDL->SvPDLV(". my ($setter, $type) = typemap($ptypes{$x}, 'get_inputmap');
($out{$x} ? "${x}_SV = " : ''). $setter = typemap_eval($setter, {var=>$x, type=>$type, arg=>($ou
"ST($cnt));\n" if !$already_read{$x}; t{$x}||$other_out{$x} ? "${x}_SV = " : '')."ST($cnt)"});
$setter =~ s/.*?(?=$x\s*=\s*)//s; # zap any declarations like wh
ichdims_count
$clause1 .= indent("$setter;\n",$ci) if !$already_read{$x};
$cnt++; $cnt++;
} }
} }
# Add code for creating output variables via call to 'initialize' perl r outine # Add code for creating output variables via call to 'initialize' perl r outine
$clause1 .= callPerlInit (\@create, $ci, $callcopy); $clause1 .= indent(callPerlInit(\@create, $callcopy),$ci);
@create = (); @create = ();
# clause for reading in input and creating output vars # clause for reading in input and creating output vars
my $clause3 = ''; my $clause3 = '';
my $defaults_rawcond = $ndefault ? "items == ($nin-$ndefault)" : ''; my $defaults_rawcond = $ndefault ? "items == ($nin-$ndefault)" : '';
$cnt = 0; $cnt = 0;
foreach my $x (@args) { foreach my $x (@args) {
if ($other{$x}) { if ($out{$x} || $outca{$x}) {
my $setter = typemap($x, $$optypes{$x}, "ST($cnt)"); push @create, $x;
$clause3 .= "$ci$x = " . (exists $defaults->{$x}
? "($defaults_rawcond) ? ($defaults->{$x}) : ($setter)"
: $setter) . ";\n";
$cnt++;
} elsif ($out{$x} || $outca{$x}) {
push (@create, $x);
} else { } else {
$clause3 .= "$ci$x = PDL->SvPDLV(ST($cnt));\n" if !$already_read my ($setter, $type) = typemap($ptypes{$x}, 'get_inputmap');
{$x}; $setter = typemap_eval($setter, {var=>$x, type=>$type, arg=>($ot
her_out{$x} ? "${x}_SV = " : '')."ST($cnt)"});
$setter =~ s/^(.*?)=\s*//s, $setter = "$x = ($defaults_rawcond)
? ($defaults->{$x}) : ($setter)" if exists $defaults->{$x};
$clause3 .= indent("$setter;\n",$ci) if !$already_read{$x};
$cnt++; $cnt++;
} }
} }
# Add code for creating output variables via call to 'initialize' perl r outine # Add code for creating output variables via call to 'initialize' perl r outine
$clause3 .= callPerlInit (\@create, $ci, $callcopy); @create = (); $clause3 .= indent(callPerlInit(\@create, $callcopy),$ci); @create = ();
my $defaults_cond = $ndefault ? " || $defaults_rawcond" : ''; my $defaults_cond = $ndefault ? " || $defaults_rawcond" : '';
$clause3 = <<EOF . $clause3; $clause3 = <<EOF . $clause3;
else if (items == $nin$defaults_cond) { PDL_COMMENT("only input variables on s tack, create outputs") else if (items == $nin$defaults_cond) { PDL_COMMENT("only input variables on s tack, create outputs")
nreturn = $nallout; nreturn = $nallout;
EOF EOF
$clause3 = '' if $nmaxonstack == $nin; $clause3 = '' if $nmaxonstack == $nin;
my $clause3_coda = $clause3 ? ' }' : ''; my $clause3_coda = $clause3 ? ' }' : '';
PDL::PP::pp_line_numbers(__LINE__, <<END); PDL::PP::pp_line_numbers(__LINE__, <<END);
\nvoid
void $name($xsargs...)$xsdecls
$name(...)
PREINIT: PREINIT:
PDL_XS_PREAMBLE PDL_XS_PREAMBLE
$svdecls $svdecls
$pars $pars
PPCODE: PPCODE:
if (items != $nmaxonstack && !(items == $nin$defaults_cond) && items != $ninou t) if (items != $nmaxonstack && !(items == $nin$defaults_cond) && items != $ninou t)
croak (\"Usage: PDL::$name($usageargs) (you may leave output variables out of list)\"); croak (\"Usage: PDL::$name($usageargs) (you may leave output variables out of list)\");
PDL_XS_PACKAGEGET PDL_XS_PACKAGEGET
$clause_inputs
if (items == $nmaxonstack) { PDL_COMMENT("all variables on stack, read in outp ut vars") if (items == $nmaxonstack) { PDL_COMMENT("all variables on stack, read in outp ut vars")
nreturn = $noutca; nreturn = $noutca;
$clause1 $clause1
} }
$clause3$clause3_coda $clause3$clause3_coda
$hdrcode $hdrcode
$inplacecode $inplacecode
END END
}), }),
# globalnew implies internal usage, not XS # globalnew implies internal usage, not XS
PDL::PP::Rule::Returns->new("VarArgsXSReturn","GlobalNew",undef), PDL::PP::Rule::Returns->new("VarArgsXSReturn","GlobalNew",undef),
PDL::PP::Rule->new("VarArgsXSReturn", PDL::PP::Rule->new("VarArgsXSReturn",
["SignatureObj"], ["SignatureObj"],
"Generate XS trailer to return output variables or leave them as modified input variables", "Generate XS trailer to return output variables or leave them as modified input variables",
sub { sub {
my @outs = $_[0]->names_out; # names of output variables (in calling ord my ($sig) = @_;
er) my @outs = $sig->names_out; # names of output ndarrays in calling order
my $clause1 = join ';', map "ST($_) = $outs[$_]_SV", 0 .. $#outs; my $clause1 = join ';', map "ST($_) = $outs[$_]_SV", 0 .. $#outs;
PDL::PP::pp_line_numbers(__LINE__-1, "PDL_XS_RETURN($clause1)"); $clause1 = PDL::PP::pp_line_numbers(__LINE__-1, "PDL_XS_RETURN($clause1)
");
my @other_out = $sig->other_out;
my $optypes = $sig->otherobjs;
my %ptypes = map +($_=>$$optypes{$_}->get_decl('', {VarArrays2Ptrs=>1}))
, @other_out;
for my $x (@other_out) {
my ($setter, $type) = typemap($ptypes{$x}, 'get_outputmap');
$setter = typemap_eval($setter, {var=>$x, type=>$type, arg=>"tsv"});
$clause1 = <<EOF . $clause1;
{ SV *tsv = NULL;
$setter
sv_setsv(${x}_SV, tsv); sv_2mortal(tsv); }
EOF
}
$clause1;
}), }),
PDL::PP::Rule->new("NewXSHdr", ["NewXSName","SignatureObj"], PDL::PP::Rule->new("NewXSHdr", ["NewXSName","SignatureObj"],
sub { sub {
my($name,$sig) = @_; my($name,$sig) = @_;
my $shortpars = join ',', $sig->alldecls(0, 1); my $shortpars = join ',', @{ $sig->allnames(1) };
my $longpars = join "\n", map "\t$_", $sig->alldecls(1, 1); my $longpars = join "\n", map "\t$_", $sig->alldecls(1, 0);
return<<END; return<<END;
\nvoid
void
$name($shortpars) $name($shortpars)
$longpars $longpars
END END
}), }),
PDL::PP::Rule::InsertName->new("RunFuncName", 'pdl_${name}_run'), PDL::PP::Rule::InsertName->new("RunFuncName", 'pdl_${name}_run'),
PDL::PP::Rule->new("NewXSCHdrs", ["RunFuncName","SignatureObj","GlobalNew"], PDL::PP::Rule->new("NewXSCHdrs", ["RunFuncName","SignatureObj","GlobalNew"],
sub { sub {
my($name,$sig,$gname) = @_; my($name,$sig,$gname) = @_;
my $longpars = join ",", $sig->alldecls(1, 0); my $longpars = join ",", $sig->alldecls(0, 1);
my $opening = 'pdl_error PDL_err = {0, NULL, 0};'; my $opening = 'pdl_error PDL_err = {0, NULL, 0};';
my $closing = 'return PDL_err;'; my $closing = 'return PDL_err;';
return ["pdl_error $name($longpars) {$opening","$closing}", return ["pdl_error $name($longpars) {$opening","$closing}",
"PDL->$gname = $name;"]; "PDL->$gname = $name;"];
}), }),
PDL::PP::Rule->new(["RunFuncCall","RunFuncHdr"],["RunFuncName","SignatureObj" ], sub { PDL::PP::Rule->new(["RunFuncCall","RunFuncHdr"],["RunFuncName","SignatureObj" ], sub {
my ($func_name,$sig) = @_; my ($func_name,$sig) = @_;
my $shortpars = join ',', $sig->alldecls(0, 0); my $shortpars = join ',', map $sig->other_is_out($_)?"&$_":$_, @{ $sig->
my $longpars = join ",", $sig->alldecls(1, 0); allnames(0) };
my $longpars = join ",", $sig->alldecls(0, 1);
(PDL::PP::pp_line_numbers(__LINE__-1, "PDL->barf_if_error($func_name($sh ortpars));"), (PDL::PP::pp_line_numbers(__LINE__-1, "PDL->barf_if_error($func_name($sh ortpars));"),
"pdl_error $func_name($longpars)"); "pdl_error $func_name($longpars)");
}), }),
PDL::PP::Rule->new("NewXSMakeNow", ["SignatureObj"], PDL::PP::Rule->new("NewXSMakeNow", ["SignatureObj"],
sub { join '', map PDL::PP::pp_line_numbers(__LINE__-1, "$_ = PDL->make_no w($_);\n"), @{ $_[0]->names } }), sub { join '', map PDL::PP::pp_line_numbers(__LINE__-1, "$_ = PDL->make_no w($_);\n"), @{ $_[0]->names } }),
PDL::PP::Rule->new("IgnoreTypesOf", ["FTypes","SignatureObj"], sub { PDL::PP::Rule->new("IgnoreTypesOf", ["FTypes","SignatureObj"], sub {
my ($ftypes, $sig) = @_; my ($ftypes, $sig) = @_;
my ($pnames, $pobjs) = ($sig->names_sorted, $sig->objs); my ($pnames, $pobjs) = ($sig->names_sorted, $sig->objs);
$_->{FlagIgnore} = 1 for grep $ftypes->{$_->{Name}}, @$pobjs{@$pnames}; $_->{FlagIgnore} = 1 for grep $ftypes->{$_->{Name}}, @$pobjs{@$pnames};
skipping to change at line 1865 skipping to change at line 1742
sub { sub {
PDL::PP::pp_line_numbers(__LINE__, <<EOF); PDL::PP::pp_line_numbers(__LINE__, <<EOF);
PDL_RETERROR(PDL_err, PDL->type_coerce($_[0])); PDL_RETERROR(PDL_err, PDL->type_coerce($_[0]));
EOF EOF
}), }),
PDL::PP::Rule::Substitute->new("NewXSTypeCoerceSubd", "NewXSTypeCoerceNS"), PDL::PP::Rule::Substitute->new("NewXSTypeCoerceSubd", "NewXSTypeCoerceNS"),
PDL::PP::Rule->new("NewXSSetTransPDLs", ["SignatureObj","StructName"], sub { PDL::PP::Rule->new("NewXSSetTransPDLs", ["SignatureObj","StructName"], sub {
my($sig,$trans) = @_; my($sig,$trans) = @_;
join '', join '',
map PDL::PP::pp_line_numbers(__LINE__, "$trans->pdls[$_->[0]] = $_->[2]; \n"), map PDL::PP::pp_line_numbers(__LINE__-1, "$trans->pdls[$_->[0]] = $_->[2 ];\n"),
grep !$_->[1], $sig->names_sorted_tuples; grep !$_->[1], $sig->names_sorted_tuples;
}), }),
PDL::PP::Rule->new("NewXSExtractTransPDLs", ["SignatureObj","StructName"], su b { PDL::PP::Rule->new("NewXSExtractTransPDLs", ["SignatureObj","StructName"], su b {
my($sig,$trans) = @_; my($sig,$trans) = @_;
join '', join '',
map PDL::PP::pp_line_numbers(__LINE__, "$_->[2] = $trans->pdls[$_->[0]]; \n"), map PDL::PP::pp_line_numbers(__LINE__, "$_->[2] = $trans->pdls[$_->[0]]; \n"),
grep !$_->[1], $sig->names_sorted_tuples; grep !$_->[1], $sig->names_sorted_tuples;
}), }),
skipping to change at line 1919 skipping to change at line 1796
my ($which, $extra_args) = @_; my ($which, $extra_args) = @_;
("${which}Func", ("${which}Func",
["${which}CodeSubd","${which}FuncName",\"${which}FuncHeader", ["${which}CodeSubd","${which}FuncName",\"${which}FuncHeader",
\"AllFuncHeader", qw(StructName ParamStructName ParamStructType), \"AllFuncHeader", qw(StructName ParamStructName ParamStructType),
], ],
sub {$_[1] eq 'NULL' ? '' : wrap_vfn(@_,$extra_args//'')} sub {$_[1] eq 'NULL' ? '' : wrap_vfn(@_,$extra_args//'')}
); );
} }
()}, ()},
PDL::PP::Rule->new("MakeCompOther", "SignatureObj", sub { $_[0]->getcopy }), PDL::PP::Rule->new("MakeCompOther", [qw(SignatureObj ParamStructName)], sub { $_[0]->getcopy("$_[1]->%s") }),
PDL::PP::Rule->new("MakeCompTotal", ["MakeCompOther", \"MakeComp"], sub { joi n "\n", grep $_, @_ }), PDL::PP::Rule->new("MakeCompTotal", ["MakeCompOther", \"MakeComp"], sub { joi n "\n", grep $_, @_ }),
PDL::PP::Rule::Substitute->new("MakeCompiledReprSubd", "MakeCompTotal"), PDL::PP::Rule::Substitute->new("MakeCompiledReprSubd", "MakeCompTotal"),
(map PDL::PP::Rule::Substitute->new("${_}ReadDataCodeUnparsed", "${_}Code"), '', 'Bad'), (map PDL::PP::Rule::Substitute->new("${_}ReadDataCodeUnparsed", "${_}Code"), '', 'Bad'),
PDL::PP::Rule->new(PDL::PP::Code::make_args(qw(ReadData)), PDL::PP::Rule->new(PDL::PP::Code::make_args(qw(ReadData)),
sub { PDL::PP::Code->new(@_, undef, undef, 1); }), sub { PDL::PP::Code->new(@_, undef, undef, 1); }),
PDL::PP::Rule::Substitute->new("ReadDataCodeSubd", "ReadDataCodeParsed"), PDL::PP::Rule::Substitute->new("ReadDataCodeSubd", "ReadDataCodeParsed"),
PDL::PP::Rule::InsertName->new("ReadDataFuncName", 'pdl_${name}_readdata'), PDL::PP::Rule::InsertName->new("ReadDataFuncName", 'pdl_${name}_readdata'),
PDL::PP::Rule->new(make_vfn_args("ReadData")), PDL::PP::Rule->new(make_vfn_args("ReadData")),
skipping to change at line 2029 skipping to change at line 1906
# #
PDL::PP::Rule::Substitute->new("NewXSFindBadStatusSubd", "NewXSFindBadStatusN S"), PDL::PP::Rule::Substitute->new("NewXSFindBadStatusSubd", "NewXSFindBadStatusN S"),
PDL::PP::Rule::Substitute->new("NewXSCopyBadStatusSubd", "NewXSCopyBadStatusN S"), PDL::PP::Rule::Substitute->new("NewXSCopyBadStatusSubd", "NewXSCopyBadStatusN S"),
PDL::PP::Rule->new("NewXSStructInit0", PDL::PP::Rule->new("NewXSStructInit0",
["StructName","VTableName","ParamStructName","ParamStructTy pe"], ["StructName","VTableName","ParamStructName","ParamStructTy pe"],
"Rule to create and initialise the private trans structure" , "Rule to create and initialise the private trans structure" ,
sub { sub {
my( $sname, $vtable, $pname, $ptype ) = @_; my( $sname, $vtable, $pname, $ptype ) = @_;
PDL::PP::pp_line_numbers(__LINE__, <<EOF); PDL::PP::pp_line_numbers(__LINE__, <<EOF);
if (!PDL) croak("PDL core struct is NULL, can't continue"); if (!PDL) return (pdl_error){PDL_EFATAL, "PDL core struct is NULL, can't continu e",0};
pdl_trans *$sname = PDL->create_trans(&$vtable); pdl_trans *$sname = PDL->create_trans(&$vtable);
@{[$ptype ? " $ptype *$pname = $sname->params;" : ""]} if (!$sname) return PDL->make_error_simple(PDL_EFATAL, "Couldn't create trans");
@{[$ptype ? "$ptype *$pname = $sname->params;" : ""]}
EOF EOF
}), }),
PDL::PP::Rule->new(["RunFunc"], PDL::PP::Rule->new(["RunFunc"],
["RunFuncHdr", ["RunFuncHdr",
"NewXSStructInit0", "NewXSStructInit0",
"NewXSSetTransPDLs", "NewXSSetTransPDLs",
"NewXSFindBadStatusSubd", "NewXSFindBadStatusSubd",
# NewXSMakeNow, # this is unnecessary since families never got imple mented # NewXSMakeNow, # this is unnecessary since families never got imple mented
"NewXSTypeCoerceSubd", "NewXSTypeCoerceSubd",
skipping to change at line 2093 skipping to change at line 1971
my $nparents = 0 + grep {! $pobjs->{$_}->{FlagW}} @$pnames; my $nparents = 0 + grep {! $pobjs->{$_}->{FlagW}} @$pnames;
my $aff = ($affine_ok ? "PDL_TPDL_VAFFINE_OK" : 0); my $aff = ($affine_ok ? "PDL_TPDL_VAFFINE_OK" : 0);
my $npdls = scalar @$pnames; my $npdls = scalar @$pnames;
my $join_flags = join(", ",map {$pobjs->{$pnames->[$_]}->{FlagPhys} ? my $join_flags = join(", ",map {$pobjs->{$pnames->[$_]}->{FlagPhys} ?
0 : $aff} 0..$npdls-1) || '0'; 0 : $aff} 0..$npdls-1) || '0';
my @op_flags; my @op_flags;
push @op_flags, 'PDL_TRANS_DO_BROADCAST' if $havebroadcasting; push @op_flags, 'PDL_TRANS_DO_BROADCAST' if $havebroadcasting;
push @op_flags, 'PDL_TRANS_BADPROCESS' if $badflag; push @op_flags, 'PDL_TRANS_BADPROCESS' if $badflag;
push @op_flags, 'PDL_TRANS_BADIGNORE' if defined $badflag and !$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_NO_PARALLEL' if $noPthreadFlag;
push @op_flags, 'PDL_TRANS_OUTPUT_OTHERPAR' if $sig->other_any_out;
my $op_flags = join('|', @op_flags) || '0'; my $op_flags = join('|', @op_flags) || '0';
my $iflags = join('|', grep $_, $affflag, $revflag, $flowflag) || '0'; my $iflags = join('|', grep $_, $affflag, $revflag, $flowflag) || '0';
my $gentypes_txt = join(", ", (map PDL::Type->new($_)->sym, @$gentypes), '-1'); my $gentypes_txt = join(", ", (map PDL::Type->new($_)->sym, @$gentypes), '-1');
my @realdims = map 0+@{$_->{IndObjs}}, @$pobjs{@$pnames}; my @realdims = map 0+@{$_->{IndObjs}}, @$pobjs{@$pnames};
my $realdims = join(", ", @realdims) || '0'; my $realdims = join(", ", @realdims) || '0';
my $parnames = join(",",map qq|"$_"|, @$pnames) || '""'; my $parnames = join(",",map qq|"$_"|, @$pnames) || '""';
my $parflags = join(",\n ",map join('|', $_->cflags)||'0', @$pobjs{@$pn ames}) || '0'; my $parflags = join(",\n ",map join('|', $_->cflags)||'0', @$pobjs{@$pn ames}) || '0';
my $partypes = join(", ", map defined()?$_->sym:-1, map $_->{Type}, @$po bjs{@$pnames}) || '-1'; my $partypes = join(", ", map defined()?$_->sym:-1, map $_->{Type}, @$po bjs{@$pnames}) || '-1';
my $i = 0; my @starts = map { my $ci = $i; $i += $_; $ci } @realdims; my $i = 0; my @starts = map { my $ci = $i; $i += $_; $ci } @realdims;
my $realdim_ind_start = join(", ", @starts) || '0'; my $realdim_ind_start = join(", ", @starts) || '0';
 End of changes. 37 change blocks. 
220 lines changed or deleted 101 lines changed or added
To the Perl Modules section of the PDL source changes report or the top of this page
Mainly generated by pkgdiff using rfcdiff
Home  |  About  |  Features  |  All  |  Newest  |  Dox  |  Diffs  |  RSS Feeds  |  Screenshots  |  Comments  |  Imprint  |  Privacy  |  HTTP(S)