File Coverage

blib/lib/PDLA/PP/PdlParObj.pm
Criterion Covered Total %
statement 111 239 46.4
branch 19 94 20.2
condition 4 78 5.1
subroutine 19 32 59.3
pod 0 26 0.0
total 153 469 32.6


line stmt bran cond sub pod time code
1             ##############################################
2              
3             ##############################################
4              
5             package PDLA::PP::PdlParObj;
6              
7 2     2   8 use Carp;
  2         5  
  2         100  
8 2     2   8 use PDLA::Types;
  2         3  
  2         311  
9              
10             # check for bad value support
11             #
12 2     2   10 use PDLA::Config;
  2         4  
  2         101  
13             my $usenan = $PDLA::Config{BADVAL_USENAN} || 0;
14              
15             our %Typemap = ();
16 2     2   10 use PDLA::Types ':All';
  2         2  
  2         3549  
17              
18             # build a typemap for our translation purposes
19             # again from info in PDLA::Types
20             for my $typ (typesrtkeys) {
21             $Typemap{typefld($typ,'ppforcetype')} = {
22             Ctype => typefld($typ,'ctype'),
23             Cenum => typefld($typ,'sym'),
24             Val => typefld($typ,'numval'),
25             };
26             }
27              
28             # Try to load Text::Balanced
29             my $hasTB = 0;
30 2     2   2109 eval q{
  2         20793  
  2         107  
31             use Text::Balanced;
32             $hasTB = 1;
33             };
34              
35             # split regex $re separated arglist
36             # but ignore bracket-protected bits
37             # (i.e. text that is within matched brackets)
38             # fallback to simple split if we can't find Text::Balanced
39             my $prebrackreg = qr/^([^\(\{\[]*)/;
40             sub splitprotected ($$) {
41 0     0 0 0 my ($re,$txt) = @_;
42 0 0       0 return split $re, $txt unless $hasTB;
43 0 0 0     0 return () if !defined $txt || $txt =~ /^\s*$/;
44 0         0 my ($got,$pre) = (1,'');
45 0         0 my @chunks = ('');
46 0         0 my $ct = 0; # infinite loop protection
47 0   0     0 while ($got && $txt =~ /[({\[]/ && $ct++ < 1000) {
      0        
48             # print "iteration $ct\n";
49 0         0 ($got,$txt,$pre) =
50             Text::Balanced::extract_bracketed($txt,'{}()[]',$prebrackreg);
51 0         0 my @partialargs = split $re, $pre, -1;
52 0 0       0 $chunks[-1] .= shift @partialargs if @partialargs;
53 0         0 push @chunks, @partialargs;
54 0         0 $chunks[-1] .= $got;
55             }
56 0 0       0 confess "possible infinite parse loop, splitting '$txt' "
57             if $ct >= 1000;
58 0         0 my @partialargs = split $re, $txt, -1;
59 0 0       0 $chunks[-1] .= shift @partialargs if @partialargs;
60 0 0       0 push @chunks, @partialargs if @partialargs;
61             # print STDERR "args found: $#chunks\n";
62             # print STDERR "splitprotected $txt on $re: [",join('|',@chunks),"]\n";
63 0         0 return @chunks;
64             }
65              
66             # null != [0]
67             # - in Core.
68              
69             #{package PDLA;
70             # sub isnull {
71             # my $this = shift;
72             # return ($this->getndims==1 && $this->getdim(0)==0) ? 1:0 }
73             #}
74              
75             1;
76              
77             #__DATA__
78              
79             # need for $badflag is due to hacked get_xsdatapdecl()
80             # - this should disappear when (if?) things are done sensibly
81             #
82             my $typeregex = join '|', map {typefld($_,'ppforcetype')} typesrtkeys;
83             our $pars_re = qr/^
84             \s*((?:$typeregex)[+]*|)\s* # $1: first option
85             (?:
86             \[([^]]*)\] # $2: The initial [option] part
87             )?\s*
88             (\w+) # $3: The name
89             \(([^)]*)\) # $4: The indices
90             /x;
91             sub new {
92 2     2 0 3121 my($type,$string,$number,$badflag) = @_;
93 2   50     16 $badflag ||= 0;
94 2         9 my $this = bless {Number => $number, BadFlag => $badflag},$type;
95             # Parse the parameter string. Note that the regexes for this match were
96             # originally defined here, but were moved to PDLA::PP for FullDoc parsing.
97 2 50       25 $string =~ $pars_re
98             or confess "Invalid pdl def $string (regex $typeregex)\n";
99 2         19 my($opt1,$opt2,$name,$inds) = ($1,$2,$3,$4);
100 2 100       4 map {$_ = '' unless defined($_)} ($opt1,$opt2,$inds); # shut up -w
  6         24  
101 2 50       14 print "PDLA: '$opt1', '$opt2', '$name', '$inds'\n"
102             if $::PP_VERBOSE;
103             # Set my internal variables
104 2         13 $this->{Name} = $name;
105 2 50       11 $this->{Flags} = [(split ',',$opt2),($opt1?$opt1:())];
106 2         4 for(@{$this->{Flags}}) {
  2         8  
107             /^io$/ and $this->{FlagW}=1 or
108             /^nc$/ and $this->{FlagNCreat}=1 or
109             /^o$/ and $this->{FlagOut}=1 and $this->{FlagCreat}=1 and $this->{FlagW}=1 or
110             /^oca$/ and $this->{FlagOut}=1 and $this->{FlagCreat}=1 and $this->{FlagW}=1
111             and $this->{FlagCreateAlways}=1 or
112             /^t$/ and $this->{FlagTemp}=1 and $this->{FlagCreat}=1 and $this->{FlagW}=1 or
113             /^phys$/ and $this->{FlagPhys} = 1 or
114 0 0 0     0 /^((?:$typeregex)[+]*)$/ and $this->{Type} = $1 and $this->{FlagTyped} = 1 or
      0        
      0        
      0        
      0        
      0        
      0        
      0        
      0        
      0        
      0        
      0        
      0        
      0        
      0        
      0        
      0        
      0        
      0        
      0        
      0        
115             confess("Invalid flag $_ given for $string\n");
116             }
117             # if($this->{FlagPhys}) {
118             # # warn("Warning: physical flag not implemented yet");
119             # }
120 2 50 33     10 if ($this->{FlagTyped} && $this->{Type} =~ s/[+]$// ) {
121 0         0 $this->{FlagTplus} = 1;
122             }
123 2 50       10 if($this->{FlagNCreat}) {
124 0         0 delete $this->{FlagCreat};
125 0         0 delete $this->{FlagCreateAlways};
126             }
127             my @inds = map{
128 2         6 s/\s//g; # Remove spaces
  2         5  
129 2         9 $_;
130             } split ',', $inds;
131 2         8 $this->{RawInds} = [@inds];
132 2         8 return $this;
133             }
134              
135 4     4 0 30 sub name {return (shift)->{Name}}
136              
137             sub add_inds {
138 2     2 0 5 my($this,$dimsobj) = @_;
139 2         11 $this->{IndObjs} = [map {$dimsobj->get_indobj_make($_)}
140 2         4 @{$this->{RawInds}}];
  2         6  
141 2         4 my %indcount;
142             $this->{IndCounts} = [
143             map {
144 2         10 0+($indcount{$_->name}++);
145 2         4 } @{$this->{IndObjs}}
  2         5  
146             ];
147             $this->{IndTotCounts} = [
148             map {
149 2         8 ($indcount{$_->name});
150 2         4 } @{$this->{IndObjs}}
  2         5  
151             ];
152             }
153              
154              
155             # do the dimension checking for perl level threading
156             # assumes that IndObjs have been created
157             sub perldimcheck {
158 0     0 0 0 my ($this,$pdl) = @_;
159             croak ("can't create ".$this->name) if $pdl->isnull &&
160 0 0 0     0 !$this->{FlagCreat};
161 0 0       0 return 1 if $pdl->isnull;
162 0         0 my $rdims = @{$this->{RawInds}};
  0         0  
163 0 0       0 croak ("not enough dimensions for ".$this->name)
164             if ($pdl->threadids)[0] < $rdims;
165 0         0 my @dims = $pdl->dims;
166 0         0 my ($i,$ind) = (0,undef);
167 0         0 for $ind (@{$this->{IndObjs}}) {
  0         0  
168 0         0 $ind->add_value($dims[$i++]);
169             }
170 0         0 return 0; # not creating
171             }
172              
173             sub finalcheck {
174 0     0 0 0 my ($this,$pdl) = @_;
175 0 0       0 return [] if $pdl->isnull;
176 0         0 my @corr = ();
177 0         0 my @dims = $pdl->dims;
178 0         0 my ($i,$ind) = (0,undef);
179 0         0 for $ind (@{$this->{IndObjs}}) {
  0         0  
180 0 0       0 push @corr,[$i-1,$ind->{Value},$dims[$i-1]] if $dims[$i++] != $ind->{Value};
181             }
182 0         0 return [@corr];
183             }
184              
185             # get index sizes for a parameter that has to be created
186             sub getcreatedims {
187 0     0 0 0 my $this = shift;
188             return map
189             { croak "can't create: index size ".$_->name." not initialised"
190 0 0 0     0 if !defined($_->{Value}) || $_->{Value} < 1;
191 0         0 $_->{Value} } @{$this->{IndObjs}};
  0         0  
  0         0  
192             }
193              
194              
195             # find the value for a given PDLA type
196             sub typeval {
197 0     0 0 0 my $ctype = shift;
198 0         0 my @match = grep {$Typemap{$_}->{Ctype} =~ /^$ctype$/} keys(%Typemap);
  0         0  
199 0 0       0 if ($#match < 0) {
200 2     2   14 use Data::Dumper;
  2         2  
  2         4653  
201 0         0 print Dumper \%Typemap;
202 0         0 croak "unknown PDLA type '$ctype'" ;
203             }
204 0         0 return $Typemap{$match[0]}->{Val};
205             }
206              
207             # return the PDLA type for this pdl
208             sub ctype {
209 4     4 0 7 my ($this,$generic) = @_;
210 4 50       11 return $generic unless $this->{FlagTyped};
211             croak "ctype: unknownn type"
212 0 0       0 unless defined($Typemap{$this->{Type}});
213 0         0 my $type = $Typemap{$this->{Type}}->{Ctype};
214 0 0       0 if ($this->{FlagTplus}) {
215             $type = $Typemap{$this->{Type}}->{Val} >
216             PDLA::PP::PdlParObj::typeval($generic) ?
217 0 0       0 $Typemap{$this->{Type}}->{Ctype} : $generic;
218             }
219 0         0 return $type;
220             }
221              
222             # return the enum type for a parobj; it'd better be typed
223             sub cenum {
224 0     0 0 0 my $this = shift;
225             croak "cenum: unknown type [" . $this->{Type} . "]"
226 0 0       0 unless defined($PDLA::PP::PdlParObj::Typemap{$this->{Type}});
227 0         0 return $PDLA::PP::PdlParObj::Typemap{$this->{Type}}->{Cenum};
228             }
229              
230 5     5 0 6 sub get_nname{ my($this) = @_;
231 5         14 "(\$PRIV(pdls[$this->{Number}]))";
232             }
233              
234 4     4 0 6 sub get_nnflag { my($this) = @_;
235 4         8 "(\$PRIV(vtable->per_pdl_flags[$this->{Number}]))";
236             }
237              
238              
239             # XXX There might be weird backprop-of-changed stuff for [phys].
240             #
241             # Have changed code to assume that, if(!$this->{FlagCreat})
242             # then __creating[] will == 0
243             # -- see make_redodims_thread() in ../PP.pm
244             #
245             sub get_xsnormdimchecks {
246 1     1 0 2 my($this) = @_;
247 1         3 my $pdl = $this->get_nname;
248 1         3 my $iref = $this->{IndObjs};
249 1         1 my $ninds = 0+scalar(@$iref);
250              
251 1         2 my $str = "";
252 1 50       4 $str .= "if(!__creating[$this->{Number}]) {\n" if $this->{FlagCreat};
253            
254             # Dimensional Promotion when number of dims is less than required:
255             # Previous warning message now commented out,
256             # which means we only need include the code if $ninds > 0
257             #
258 1 50       3 if ( $ninds > 0 ) {
259             $str .= " if(($pdl)->ndims < $ninds) {\n" .
260             join('', map {
261 1         11 my $size = $iref->[$_-1]->get_size();
  1         6  
262 1         19 " if (($pdl)->ndims < $_ && $size <= 1) $size = 1;\n"
263             } (1..$ninds))
264             # XXX why is this here, commented, and not removed? If re-inserted, be sure to use PDLA_COMMENT
265             ## ." /* \$CROAK(\"Too few dimensions for argument \'$this->{Name}\'\\n\"); */\n"
266             . " }\n";
267             }
268              
269             # Now, the real check.
270 1         2 my $no = 0;
271 1         4 for( @$iref ) {
272 1         3 my $siz = $_->get_size();
273 1         4 my $dim = "($pdl)->dims[$no]";
274 1         2 my $ndims = "($pdl)->ndims";
275 1         13 $str .= " if($siz == -1 || ($ndims > $no && $siz == 1)) {\n" .
276             " $siz = $dim;\n" .
277             " } else if($ndims > $no && $siz != $dim) {\n" .
278             # XXX should these lines simply be removed? If re-inserted, be sure to use PDLA_COMMENT
279             # " if($dim == 1) {\n" .
280             # " /* Do nothing */ /* XXX Careful, increment? */" .
281             # " } else {\n" .
282             " if($dim != 1) {\n" .
283             " \$CROAK(\"Wrong dims\\n\");\n" .
284             " }\n }\n";
285 1         2 $no++;
286             }
287              
288 1 50       3 $str .= "PDLA->make_physical(($pdl));\n" if $this->{FlagPhys};
289              
290 1 50       4 if ( $this->{FlagCreat} ) {
291 0         0 $str .= "} else {\n";
292            
293             # We are creating this pdl.
294 0         0 $str .= " PDLA_Indx dims[".($ninds+1)."]; PDLA_COMMENT(\"Use ninds+1 to avoid smart (stupid) compilers\")";
295             $str .= join "",
296 0         0 (map {"dims[$_] = ".$iref->[$_]->get_size().";"} 0 .. $#$iref);
  0         0  
297 0 0       0 my $istemp = $this->{FlagTemp} ? 1 : 0;
298 0         0 $str .="\n PDLA->thread_create_parameter(&\$PRIV(__pdlthread),$this->{Number},dims,$istemp);\n";
299 0         0 $str .= "}";
300             }
301 1         5 return $str;
302            
303             } # sub: get_xsnormdimchecks()
304              
305             sub get_incname {
306 10     10 0 16 my($this,$ind) = @_;
307 10 50       26 if($this->{IndTotCounts}[$ind] > 1) {
308 0         0 "__inc_".$this->{Name}."_".($this->{IndObjs}[$ind]->name).$this->{IndCounts}[$ind];
309             } else {
310 10         34 "__inc_".$this->{Name}."_".($this->{IndObjs}[$ind]->name);
311             }
312             }
313              
314             sub get_incdecls {
315 1     1 0 2 my($this) = @_;
316 1 50       2 if(scalar(@{$this->{IndObjs}}) == 0) {return "";}
  1         4  
  0         0  
317             (join '',map {
318 1         3 "PDLA_Indx ".($this->get_incname($_)).";";
319 1         2 } (0..$#{$this->{IndObjs}}) ) . ";"
  1         3  
320             }
321              
322             sub get_incregisters {
323 3     3 0 6 my($this) = @_;
324 3 50       4 if(scalar(@{$this->{IndObjs}}) == 0) {return "";}
  3         12  
  0         0  
325             (join '',map {
326 3         13 "register PDLA_Indx ".($this->get_incname($_))." = \$PRIV(".
327             ($this->get_incname($_)).");\n";
328 3         6 } (0..$#{$this->{IndObjs}}) )
  3         9  
329             }
330              
331             sub get_incdecl_copy {
332 1     1 0 2 my($this,$fromsub,$tosub) = @_;
333             join '',map {
334 1         3 my $iname = $this->get_incname($_);
335 1         4 &$fromsub($iname)."=".&$tosub($iname).";";
336 1         2 } (0..$#{$this->{IndObjs}})
  1         3  
337             }
338              
339             sub get_incsets {
340 1     1 0 3 my($this,$str) = @_;
341 1         2 my $no=0;
342             (join '',map {
343             "if($str->ndims <= $_ || $str->dims[$_] <= 1)
344             \$PRIV(".($this->get_incname($_)).") = 0; else
345             \$PRIV(".($this->get_incname($_)).
346             ") = ".($this->{FlagPhys}?
347 1 50       6 "$str->dimincs[$_];" :
348             "PDLA_REPRINC($str,$_);");
349 1         2 } (0..$#{$this->{IndObjs}}) )
  1         2  
350             }
351              
352             # Print an access part.
353             sub do_access {
354 0     0 0 0 my($this,$inds,$context) = @_;
355 0         0 my $pdl = $this->{Name};
356             # Parse substitutions into hash
357             my %subst = map
358 0 0       0 {/^\s*(\w+)\s*=>\s*(\S*)\s*$/ or confess "Invalid subst $_\n"; ($1,$2)}
  0         0  
  0         0  
359             splitprotected ',',$inds;
360             # Generate the text
361 0         0 my $text;
362 0         0 $text = "(${pdl}_datap)"."[";
363             $text .= join '+','0',map {
364 0         0 $this->do_indterm($pdl,$_,\%subst,$context);
365 0         0 } (0..$#{$this->{IndObjs}});
  0         0  
366 0         0 $text .= "]";
367             # If not all substitutions made, the user probably made a spelling
368             # error. Barf.
369 0 0       0 if(scalar(keys %subst) != 0) {
370 0         0 confess("Substitutions left: ".(join ',',keys %subst)."\n");
371             }
372 0         0 return "$text PDLA_COMMENT(\"ACCESS($access)\") ";
373             }
374              
375             sub has_dim {
376 0     0 0 0 my($this,$ind) = @_;
377 0         0 my $h = 0;
378 0         0 for(@{$this->{IndObjs}}) {
  0         0  
379 0 0       0 $h++ if $_->name eq $ind;
380             }
381 0         0 return $h;
382             }
383              
384             sub do_resize {
385 0     0 0 0 my($this,$ind,$size) = @_;
386 0         0 my @c;my $index = 0;
  0         0  
387 0         0 for(@{$this->{IndObjs}}) {
  0         0  
388 0 0       0 push @c,$index if $_->name eq $ind; $index ++;
  0         0  
389             }
390 0         0 my $pdl = $this->get_nname;
391 0         0 return (join '',map {"$pdl->dims[$_] = $size;\n"} @c).
  0         0  
392             "PDLA->resize_defaultincs($pdl);PDLA->allocdata($pdl);".
393             $this->get_xsdatapdecl(undef,1);
394             }
395              
396             sub do_pdlaccess {
397 0     0 0 0 my($this) = @_;
398 0         0 return '$PRIV(pdls['.$this->{Number}.'])';
399              
400             }
401              
402             sub do_pointeraccess {
403 0     0 0 0 my($this) = @_;
404 0         0 return $this->{Name}."_datap";
405             }
406              
407             sub do_physpointeraccess {
408 0     0 0 0 my($this) = @_;
409 0         0 return $this->{Name}."_physdatap";
410             }
411              
412 0     0 0 0 sub do_indterm { my($this,$pdl,$ind,$subst,$context) = @_;
413             # Get informed
414 0         0 my $indname = $this->{IndObjs}[$ind]->name;
415 0         0 my $indno = $this->{IndCounts}[$ind];
416 0         0 my $indtot = $this->{IndTotCounts}[$ind];
417             # See if substitutions
418 0 0       0 my $substname = ($indtot>1 ? $indname.$indno : $indname);
419 0 0       0 my $incname = $indname.($indtot>1 ? $indno : "");
420 0         0 my $index;
421 0 0       0 if(defined $subst->{$substname}) {$index = delete $subst->{$substname};}
  0         0  
422             else {
423             # No => get the one from the nearest context.
424 0         0 for(reverse @$context) {
425 0 0       0 if($_->[0] eq $indname) {$index = $_->[1]; last;}
  0         0  
  0         0  
426             }
427             }
428 0 0       0 if(!defined $index) {confess "Access Index not found: $pdl, $ind, $indname
429 0         0 On stack:".(join ' ',map {"($_->[0],$_->[1])"} @$context)."\n" ;}
  0         0  
430             # return "\$PRIV(".($this->get_incname($ind))."*". $index .")";
431             # Now we have them in register variables -> no PRIV
432             return ("(".($this->get_incname($ind))."*".
433 0         0 "PP_INDTERM(".$this->{IndObjs}[$ind]->get_size().", $index))");
434             }
435              
436             # XXX hacked to create a variable containing the bad value for
437             # this piddle.
438             # This is a HACK (Doug Burke 07/08/00)
439             # XXX
440             #
441             sub get_xsdatapdecl {
442 4     4 0 6 my($this,$genlooptype,$asgnonly) = @_;
443 4         5 my $type;
444 4         10 my $pdl = $this->get_nname;
445 4         10 my $flag = $this->get_nnflag;
446 4         7 my $name = $this->{Name};
447 4 50       15 $type = $this->ctype($genlooptype) if defined $genlooptype;
448 4 50       10 my $declini = ($asgnonly ? "" : "\t$type *");
449 4 50       10 my $cast = ($type ? "($type *)" : "");
450             # ThreadLoop does this for us.
451             # return "$declini ${name}_datap = ($cast((${_})->data)) + (${_})->offs;\n";
452            
453 4         18 my $str = "$declini ${name}_datap = ($cast(PDLA_REPRP_TRANS($pdl,$flag)));\n" .
454             "$declini ${name}_physdatap = ($cast($pdl->data));\n";
455              
456             # assuming we always need this
457             # - may not be true - eg if $asgnonly ??
458             # - not needed for floating point types when using NaN as bad values
459 4 0 33     48 if ( $this->{BadFlag} and $type and
      0        
      33        
460             ( $usenan == 0 or $type !~ /^PDLA_(Float|Double)$/ ) ) {
461 0         0 my $cname = $type; $cname =~ s/^PDLA_//;
  0         0  
462             # $str .= "\t$type ${name}_badval = PDLA->bvals.$cname;\n";
463 0         0 $str .= "\t$type ${name}_badval = ($type) PDLA->get_pdl_badvalue($pdl);\n";
464             }
465              
466 4         20 return "$str\n";
467             }
468              
469             1;