"Fossies" - the Fresh Open Source Software Archive  

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

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

PDLCode.pm  (PDL-2.079):PDLCode.pm  (PDL-2.080)
skipping to change at line 17 skipping to change at line 17
package PDL::PP::Code; package PDL::PP::Code;
use strict; use strict;
use warnings; use warnings;
use Carp; use Carp;
sub get_pdls {my($this) = @_; return ($this->{ParNames},$this->{ParObjs});} sub get_pdls {my($this) = @_; return ($this->{ParNames},$this->{ParObjs});}
my @code_args_always = qw(BadFlag SignatureObj GenericTypes ExtraGenericSwitches HaveBroadcasting Name); my @code_args_always = qw(BadFlag SignatureObj GenericTypes ExtraGenericSwitches HaveBroadcasting Name);
sub make_args { sub make_args {
my ($which) = @_; my ($target) = @_;
("Parsed$which", [$which,\"Bad$which",@code_args_always]); ("${target}CodeParsed", ["${target}CodeUnparsed",\"Bad${target}CodeUnparsed",@
code_args_always]);
} }
# Do the appropriate substitutions in the code. # Do the appropriate substitutions in the code.
sub new { sub new {
my($class,$code,$badcode, my($class,$code,$badcode,
$handlebad, $sig,$generictypes,$extrageneric,$havebroadcasting,$name, $handlebad, $sig,$generictypes,$extrageneric,$havebroadcasting,$name,
$dont_add_brcloop, $backcode, $nulldatacheck) = @_; $dont_add_brcloop, $backcode, $nulldatacheck) = @_;
my $parnames = $sig->names_sorted; my $parnames = $sig->names_sorted;
die "Error: missing name argument to PDL::PP::Code->new call!\n" die "Error: missing name argument to PDL::PP::Code->new call!\n"
skipping to change at line 292 skipping to change at line 292
my ( $this, $code ) = @_; my ( $this, $code ) = @_;
# First check for standard code errors: # First check for standard code errors:
catch_code_errors($code); catch_code_errors($code);
my @stack = my $coderef = PDL::PP::Block->new; my @stack = my $coderef = PDL::PP::Block->new;
my $broadcastloops = 0; my $broadcastloops = 0;
my $sizeprivs = {}; my $sizeprivs = {};
$this->process($code, \@stack, \$broadcastloops, $sizeprivs); $this->process($code, \@stack, \$broadcastloops, $sizeprivs);
( $broadcastloops, $coderef, $sizeprivs ); ( $broadcastloops, $coderef, $sizeprivs );
} # sub: separate_code() } # sub: separate_code()
my $macro_pat = qr/\w+/;
sub expand { sub expand {
my ($this, $text) = @_; my ($this, $text) = @_;
my (undef, $pdl, $inds, $rest) = PDL::PP::Rule::Substitute::macro_extract($t ext); my (undef, $pdl, $inds, $rest) = PDL::PP::Rule::Substitute::macro_extract($t ext, $macro_pat);
my @add; my @add;
if($pdl =~ /^T/) {@add = PDL::PP::MacroAccess->new($pdl,$inds, if($pdl =~ /^T/) {@add = PDL::PP::MacroAccess->new($pdl,$inds,
$this->{Generictypes},$this->{Name});} $this->{Generictypes},$this->{Name});}
elsif(my $c = $access2class{$pdl}) {@add = $c->new($pdl,$inds)} elsif(my $c = $access2class{$pdl}) {@add = $c->new($pdl,$inds)}
elsif($pdl =~ /^(PP|)(ISBAD|ISGOOD|SETBAD)(VAR|)$/) { elsif($pdl =~ /^(PP|)(ISBAD|ISGOOD|SETBAD)(VAR|)$/) {
my ($opcode, $name) = ($2); my ($opcode, $name) = ($2);
my $get = $1 || $3; my $get = $1 || $3;
if (!$get) { if (!$get) {
$inds =~ s/^\$?([a-zA-Z_]\w*)\s*//; # $ is optional $inds =~ s/^\$?([a-zA-Z_]\w*)\s*//; # $ is optional
$name = $1; $name = $1;
$inds = substr $inds, 1, -1; # chop off brackets $inds = substr $inds, 1, -1; # chop off brackets
} elsif ($get eq 'PP') { } elsif ($get eq 'PP') {
($name, $inds) = split /\s*,\s*/, $inds; ($name, $inds) = PDL::PP::Rule::Substitute::split_cpp($inds);
} else { } else {
($inds, $name) = $inds =~ /(.*)\s*,\s*(\w+)/; ($inds, $name) = PDL::PP::Rule::Substitute::split_cpp($inds);
} }
@add = PDL::PP::BadAccess->new($opcode,$get,$name,$inds,$this); @add = PDL::PP::BadAccess->new($opcode,$get,$name,$inds,$this);
} }
elsif($this->{ParObjs}{$pdl}) {@add = PDL::PP::Access->new($pdl,$inds)} elsif($this->{ParObjs}{$pdl}) {@add = PDL::PP::Access->new($pdl,$inds)}
else { else {
@add = "\$$pdl("; confess "unknown construct $pdl($inds)";
# assumption: the only "control" that will happen in macro args is anothe
r macro
$this->process($inds, [\@add], undef, undef);
push @add, ")";
} }
($rest, @add); ($rest, @add);
} }
# This is essentially a collection of regexes that look for standard code # This is essentially a collection of regexes that look for standard code
# errors and croaks with an explanation if they are found. # errors and croaks with an explanation if they are found.
sub catch_code_errors { sub catch_code_errors {
my $code_string = shift; my $code_string = shift;
# Look for constructs like # Look for constructs like
# loop %{ # loop %{
skipping to change at line 603 skipping to change at line 601
my ($this,$parent,$context) = @_; my ($this,$parent,$context) = @_;
confess "types() outside a generic loop" confess "types() outside a generic loop"
unless defined(my $type = $parent->{Gencurtype}[-1]); unless defined(my $type = $parent->{Gencurtype}[-1]);
return '' if !$this->[0]{$type->ppsym}; return '' if !$this->[0]{$type->ppsym};
join '', $this->get_contained($parent,$context); join '', $this->get_contained($parent,$context);
} }
package PDL::PP::Access; package PDL::PP::Access;
use Carp; use Carp;
sub new { my($type,$pdl,$inds,$parent) = @_; sub new { my($type,$pdl,$inds) = @_;
bless [$pdl,$inds],$type; bless [$pdl,$inds],$type;
} }
sub get_str { my($this,$parent,$context) = @_; sub get_str { my($this,$parent,$context) = @_;
$parent->{ParObjs}{$this->[0]}->do_access($this->[1],$context) $parent->{ParObjs}{$this->[0]}->do_access($this->[1],$context)
if defined($parent->{ParObjs}{$this->[0]}); if defined($parent->{ParObjs}{$this->[0]});
} }
########################### ###########################
# Encapsulate a check on whether a value is good or bad # Encapsulate a check on whether a value is good or bad
# handles both checking (good/bad) and setting (bad) # handles both checking (good/bad) and setting (bad)
package PDL::PP::BadAccess; package PDL::PP::BadAccess;
use Carp; use Carp;
sub new { sub new {
my ( $type, $opcode, $get, $name, $inds, $parent ) = @_; my ( $type, $opcode, $get, $name, $inds, $parent ) = @_;
die "\nIt looks like you have tried a \$${opcode}() macro on an\n" . die "\nIt looks like you have tried a $get \$${opcode}() macro on an" .
" unknown ndarray <$name($inds)>\n" " unknown ndarray <$name($inds)>\n"
unless defined($parent->{ParObjs}{$name}); unless defined($parent->{ParObjs}{$name});
bless [$opcode, $get, $name, $inds], $type; bless [$opcode, $get, $name, $inds], $type;
} }
sub _isbad { "PDL_ISBAD($_[0],$_[1],$_[2])" } sub _isbad { "PDL_ISBAD($_[0],$_[1],$_[2])" }
our %ops = ( our %ops = (
ISBAD => \&_isbad, ISBAD => \&_isbad,
ISGOOD => sub {'!'.&_isbad}, ISGOOD => sub {'!'.&_isbad},
SETBAD => sub{join '=', @_[0,1]}, SETBAD => sub{join '=', @_[0,1]},
); );
skipping to change at line 667 skipping to change at line 665
package PDL::PP::MacroAccess; package PDL::PP::MacroAccess;
use Carp; use Carp;
use PDL::Types ':All'; use PDL::Types ':All';
my $types = join '',ppdefs_all; my $types = join '',ppdefs_all;
sub new { sub new {
my ($type, $pdl, $inds, $gentypes, $name) = @_; my ($type, $pdl, $inds, $gentypes, $name) = @_;
$pdl =~ /^\s*T([A-Z]+)\s*$/ $pdl =~ /^\s*T([A-Z]+)\s*$/
or confess("Macroaccess wrong in $name (allowed types $types): was '$pdl'\ n"); or confess("Macroaccess wrong in $name (allowed types $types): was '$pdl'\ n");
my @ilst = split '', $1; my @ilst = split '', $1;
my @lst = split ',', $inds, -1; my @lst = PDL::PP::Rule::Substitute::split_cpp($inds);
confess "Macroaccess: different nos of args $pdl $inds\n" if @lst != @ilst; confess "Macroaccess: different nos of args $pdl (@{[scalar @lst]}=@lst) vs
(@{[scalar @ilst]}=@ilst)\n" if @lst != @ilst;
my %type2value; @type2value{@ilst} = @lst; my %type2value; @type2value{@ilst} = @lst;
confess "$name has no Macro for generic type $_ (has $pdl)\n" confess "$name has no Macro for generic type $_ (has $pdl)\n"
for grep !exists $type2value{$_}, @$gentypes; for grep !exists $type2value{$_}, @$gentypes;
my %gts; @gts{@$gentypes} = (); my %gts; @gts{@$gentypes} = ();
warn "Macro for unsupported generic type identifier $_\n" warn "Macro for unsupported generic type identifier $_\n"
for grep !exists $gts{$_}, @ilst; for grep !exists $gts{$_}, @ilst;
bless [\%type2value, $name], $type; bless [\%type2value, $name], $type;
} }
sub get_str { sub get_str {
 End of changes. 9 change blocks. 
15 lines changed or deleted 14 lines changed or added

Home  |  About  |  Features  |  All  |  Newest  |  Dox  |  Diffs  |  RSS Feeds  |  Screenshots  |  Comments  |  Imprint  |  Privacy  |  HTTP(S)