"Fossies" - the Fresh Open Source Software Archive

Member "PDL-2.080/Basic/Gen/PP/PdlParObj.pm" (19 May 2022, 7242 Bytes) of package /linux/misc/PDL-2.080.tar.gz:


As a special service "Fossies" has tried to format the requested source page into HTML format using (guessed) Perl source code syntax highlighting (style: standard) with prefixed line numbers and code folding option. Alternatively you can here view or download the uninterpreted source code file. For more information about "PdlParObj.pm" see the Fossies "Dox" file reference documentation and the latest Fossies "Diffs" side-by-side code changes report: 2.079_vs_2.080.

    1 package PDL::PP::PdlParObj;
    2 
    3 use strict;
    4 use warnings;
    5 use Carp;
    6 use PDL::Types ':All';
    7 
    8 our %INVALID_PAR = map +($_=>1), qw(
    9   I
   10 );
   11 
   12 my $typeregex = join '|', map $_->ppforcetype, types;
   13 my $complex_regex = join '|', qw(real complex);
   14 our $pars_re = qr/^
   15     \s*(?:($complex_regex|$typeregex)\b([+]*)|)\s*  # $1,2: first option then plus
   16     (?:
   17     \[([^]]*)\] # $3: The initial [option] part
   18     )?\s*
   19     (\w+)       # $4: The name
   20     \(([^)]*)\) # $5: The indices
   21 /x;
   22 my %flag2info = (
   23   io => [[qw(FlagW)]],
   24   nc => [[qw(FlagNCreat)]],
   25   o => [[qw(FlagOut FlagCreat FlagW)]],
   26   oca => [[qw(FlagOut FlagCreat FlagW FlagCreateAlways)]],
   27   t => [[qw(FlagTemp FlagCreat FlagW)]],
   28   phys => [[qw(FlagPhys)]],
   29   real => [[qw(FlagReal)]],
   30   complex => [[qw(FlagComplex)]],
   31   (map +($_->ppforcetype => [[qw(FlagTyped)], 'Type']), types),
   32 );
   33 my %flag2c = qw(
   34   FlagReal PDL_PARAM_ISREAL
   35   FlagComplex PDL_PARAM_ISCOMPLEX
   36   FlagTyped PDL_PARAM_ISTYPED
   37   FlagTplus PDL_PARAM_ISTPLUS
   38   FlagCreat PDL_PARAM_ISCREAT
   39   FlagCreateAlways PDL_PARAM_ISCREATEALWAYS
   40   FlagOut PDL_PARAM_ISOUT
   41   FlagTemp PDL_PARAM_ISTEMP
   42   FlagW PDL_PARAM_ISWRITE
   43   FlagPhys PDL_PARAM_ISPHYS
   44   FlagIgnore PDL_PARAM_ISIGNORE
   45 );
   46 sub new {
   47     my($type,$string,$badflag,$sig) = @_;
   48     $badflag ||= 0;
   49     my $this = bless {Number => "PDL_UNDEF_NUMBER", BadFlag => $badflag, Sig => $sig},$type;
   50     # Parse the parameter string. Note that the regexes for this match were
   51     # originally defined here, but were moved to PDL::PP for FullDoc parsing.
   52     $string =~ $pars_re
   53          or confess "Invalid pdl def $string (regex $pars_re)\n";
   54     my($opt1,$opt_plus,$opt2,$name,$inds) = map $_ // '', ($1,$2,$3,$4,$5);
   55     print "PDL: '$opt1$opt_plus', '$opt2', '$name', '$inds'\n"
   56           if $::PP_VERBOSE;
   57     croak "Invalid Pars name: $name"
   58       if $INVALID_PAR{$name};
   59 # Set my internal variables
   60     $this->{Name} = $name;
   61     $this->{Flags} = [(split ',',$opt2),($opt1?$opt1:())];
   62     for(@{$this->{Flags}}) {
   63         confess("Invalid flag $_ given for $string\n")
   64             unless my ($set, $store) = @{ $flag2info{$_} || [] };
   65         $this->{$store} = $_ if $store;
   66         $this->{$_} = 1 for @$set;
   67     }
   68     if ($this->{FlagTyped} && $opt_plus) {
   69       $this->{FlagTplus} = 1;
   70     }
   71     $this->{Type} &&= PDL::Type->new($this->{Type});
   72     if($this->{FlagNCreat}) {
   73         delete $this->{FlagCreat};
   74         delete $this->{FlagCreateAlways};
   75     }
   76     $this->{RawInds} = [map{
   77         s/\s//g;        # Remove spaces
   78         $_;
   79     } split ',', $inds];
   80     return $this;
   81 }
   82 
   83 sub cflags {
   84   my ($this) = @_;
   85   map $flag2c{$_}, grep $this->{$_}, sort keys %flag2c;
   86 }
   87 
   88 sub name {return (shift)->{Name}}
   89 
   90 sub add_inds {
   91     my($this,$dimsobj) = @_;
   92     $this->{IndObjs} = [map {$dimsobj->get_indobj_make($_)}
   93         @{$this->{RawInds}}];
   94     my %indcount;
   95     $this->{IndCounts} = [
   96         map {
   97             0+($indcount{$_->name}++);
   98         } @{$this->{IndObjs}}
   99     ];
  100     $this->{IndTotCounts} = [
  101         map {
  102             ($indcount{$_->name});
  103         } @{$this->{IndObjs}}
  104     ];
  105 }
  106 
  107 
  108 # do the dimension checking for perl level broadcasting
  109 # assumes that IndObjs have been created
  110 sub perldimcheck {
  111   my ($this,$pdl) = @_;
  112   croak ("can't create ".$this->name) if $pdl->isnull &&
  113     !$this->{FlagCreat};
  114   return 1 if $pdl->isnull;
  115   my $rdims = @{$this->{RawInds}};
  116   croak ("not enough dimensions for ".$this->name)
  117     if ($pdl->broadcastids)[0] < $rdims;
  118   my @dims = $pdl->dims;
  119   my ($i,$ind) = (0,undef);
  120   for $ind (@{$this->{IndObjs}}) {
  121     $ind->add_value($dims[$i++]);
  122   }
  123   return 0; # not creating
  124 }
  125 
  126 sub finalcheck {
  127   my ($this,$pdl) = @_;
  128   return [] if $pdl->isnull;
  129   my @corr = ();
  130   my @dims = $pdl->dims;
  131   my ($i,$ind) = (0,undef);
  132   for $ind (@{$this->{IndObjs}}) {
  133     push @corr,[$i-1,$ind->{Value},$dims[$i-1]] if $dims[$i++] != $ind->{Value};
  134   }
  135   return [@corr];
  136 }
  137 
  138 # get index sizes for a parameter that has to be created
  139 sub getcreatedims {
  140   my $this = shift;
  141   return map
  142     { croak "can't create: index size ".$_->name." not initialised"
  143     if !defined($_->{Value}) || $_->{Value} < 1;
  144       $_->{Value} } @{$this->{IndObjs}};
  145 }
  146 
  147 sub adjusted_type {
  148   my ($this, $generic) = @_;
  149   confess "adjusted_type given undefined generic type\n" if !defined $generic;
  150   return $generic->realversion if $this->{FlagReal};
  151   return $generic->complexversion if $this->{FlagComplex};
  152   return $generic unless $this->{FlagTyped};
  153   return $this->{Type}->numval > $generic->numval
  154     ? $this->{Type} : $generic
  155     if $this->{FlagTplus};
  156   $this->{Type};
  157 }
  158 
  159 sub get_nname{ my($this) = @_;
  160     "(\$PRIV(pdls[$this->{Number}]))";
  161 }
  162 
  163 sub get_nnflag { my($this) = @_;
  164     "(\$PRIV(vtable->per_pdl_flags[$this->{Number}]))";
  165 }
  166 
  167 sub get_incname {
  168     my($this,$ind,$for_local) = @_;
  169     return "inc_sizes[PDL_INC_ID(__privtrans->vtable,$this->{Number},$ind)]" if !$for_local;
  170     if($this->{IndTotCounts}[$ind] > 1) {
  171         "__inc_".$this->{Name}."_".($this->{IndObjs}[$ind]->name).$this->{IndCounts}[$ind];
  172     } else {
  173         "__inc_".$this->{Name}."_".($this->{IndObjs}[$ind]->name);
  174     }
  175 }
  176 
  177 sub get_incregisters {
  178     my($this) = @_;
  179     if(scalar(@{$this->{IndObjs}}) == 0) {return "";}
  180     (join '',map {
  181         my $x = $_;
  182         my ($name, $for_local) = map $this->get_incname($x, $_), 0, 1;
  183         "register PDL_Indx $for_local = __privtrans->$name; (void)$for_local;\n";
  184     } (0..$#{$this->{IndObjs}}) )
  185 }
  186 
  187 # Print an access part.
  188 sub do_access {
  189     my($this,$inds,$context) = @_;
  190     my $pdl = $this->{Name};
  191 # Parse substitutions into hash
  192     my %subst = map
  193      {/^\s*(\w+)\s*=>\s*(\S*)\s*$/ or confess "Invalid subst $_ in ($inds) (no spaces in => value)\n"; ($1,$2)}
  194         PDL::PP::Rule::Substitute::split_cpp($inds);
  195 # Generate the text
  196     my $text;
  197     $text = "(${pdl}_datap)"."[";
  198     $text .= join '+','0',map {
  199         $this->do_indterm($pdl,$_,\%subst,$context);
  200     } (0..$#{$this->{IndObjs}});
  201     $text .= "]";
  202 # If not all substitutions made, the user probably made a spelling
  203 # error. Barf.
  204     if(scalar(keys %subst) != 0) {
  205         confess("Substitutions left: ".(join ',',sort keys %subst)."\n");
  206     }
  207        $text;
  208 }
  209 
  210 sub do_pdlaccess {
  211     my($this) = @_;
  212     PDL::PP::pp_line_numbers(__LINE__-1, '$PRIV(pdls['.$this->{Number}.'])');
  213 }
  214 
  215 sub do_pointeraccess {
  216     my($this) = @_;
  217     return $this->{Name}."_datap";
  218 }
  219 
  220 sub do_physpointeraccess {
  221     my($this) = @_;
  222     return $this->{Name}."_physdatap";
  223 }
  224 
  225 sub do_indterm { my($this,$pdl,$ind,$subst,$context) = @_;
  226 # Get informed
  227     my $indname = $this->{IndObjs}[$ind]->name;
  228     my $indno = $this->{IndCounts}[$ind];
  229     my $indtot = $this->{IndTotCounts}[$ind];
  230 # See if substitutions
  231     my $substname = ($indtot>1 ? $indname.$indno : $indname);
  232     my $incname = $indname.($indtot>1 ? $indno : "");
  233     my $index;
  234     if(defined $subst->{$substname}) {$index = delete $subst->{$substname};}
  235     else {
  236 # No => get the one from the nearest context.
  237         for(reverse @$context) {
  238             if($_->[0] eq $indname) {$index = $_->[1]; last;}
  239         }
  240     }
  241     if(!defined $index) {confess "Access Index not found: $pdl, $ind, $indname
  242         On stack:".(join ' ',map {"($_->[0],$_->[1])"} @$context)."\n" ;}
  243        return "(".($this->get_incname($ind,1))."*".
  244                "PP_INDTERM(".$this->{IndObjs}[$ind]->get_size().", $index))";
  245 }
  246 
  247 sub get_xsdatapdecl { 
  248     my($this,$ctype,$nulldatacheck) = @_;
  249     my $pdl = $this->get_nname;
  250     my $flag = $this->get_nnflag;
  251     my $name = $this->{Name};
  252     my $macro = "PDL_DECLARE_PARAMETER".($this->{BadFlag} ? "_BADVAL" : "");
  253     "$macro($ctype, $flag, $name, $pdl, $nulldatacheck)";
  254 }
  255 
  256 1;