File Coverage

blib/lib/PDLA/PP/PdlParObj.pm
Criterion Covered Total %
statement 136 241 56.4
branch 27 94 28.7
condition 14 78 17.9
subroutine 22 32 68.7
pod 0 26 0.0
total 199 471 42.2


line stmt bran cond sub pod time code
1             ##############################################
2              
3             ##############################################
4              
5             package PDLA::PP::PdlParObj;
6              
7 3     3   24 use Carp;
  3         9  
  3         183  
8 3     3   19 use PDLA::Types;
  3         5  
  3         436  
9              
10             # check for bad value support
11             #
12 3     3   439 use PDLA::Config;
  3         7  
  3         251  
13             my $usenan = $PDLA::Config{BADVAL_USENAN} || 0;
14              
15             our %Typemap = ();
16 3     3   21 use PDLA::Types ':All';
  3         6  
  3         5008  
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 3     3   1365 eval q{
  3         19767  
  3         134  
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 9     9 0 5315 my($type,$string,$number,$badflag) = @_;
93 9   50     47 $badflag ||= 0;
94 9         36 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 9 50       73 $string =~ $pars_re
98             or confess "Invalid pdl def $string (regex $typeregex)\n";
99 9         51 my($opt1,$opt2,$name,$inds) = ($1,$2,$3,$4);
100 9 100       20 map {$_ = '' unless defined($_)} ($opt1,$opt2,$inds); # shut up -w
  27         92  
101 9 50       25 print "PDLA: '$opt1', '$opt2', '$name', '$inds'\n"
102             if $::PP_VERBOSE;
103             # Set my internal variables
104 9         35 $this->{Name} = $name;
105 9 50       38 $this->{Flags} = [(split ',',$opt2),($opt1?$opt1:())];
106 9         15 for(@{$this->{Flags}}) {
  9         26  
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 1 0 50     35 /^((?:$typeregex)[+]*)$/ and $this->{Type} = $1 and $this->{FlagTyped} = 1 or
      50        
      33        
      50        
      50        
      50        
      33        
      0        
      0        
      0        
      0        
      33        
      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 9 50 33     34 if ($this->{FlagTyped} && $this->{Type} =~ s/[+]$// ) {
121 0         0 $this->{FlagTplus} = 1;
122             }
123 9 50       23 if($this->{FlagNCreat}) {
124 0         0 delete $this->{FlagCreat};
125 0         0 delete $this->{FlagCreateAlways};
126             }
127             my @inds = map{
128 9         24 s/\s//g; # Remove spaces
  9         21  
129 9         27 $_;
130             } split ',', $inds;
131 9         28 $this->{RawInds} = [@inds];
132 9         26 return $this;
133             }
134              
135 18     18 0 90 sub name {return (shift)->{Name}}
136              
137             sub add_inds {
138 11     11 0 87 my($this,$dimsobj) = @_;
139 11         32 $this->{IndObjs} = [map {$dimsobj->get_indobj_make($_)}
140 11         19 @{$this->{RawInds}}];
  11         26  
141 11         24 my %indcount;
142             $this->{IndCounts} = [
143             map {
144 11         30 0+($indcount{$_->name}++);
145 11         17 } @{$this->{IndObjs}}
  11         23  
146             ];
147             $this->{IndTotCounts} = [
148             map {
149 11         23 ($indcount{$_->name});
150 11         22 } @{$this->{IndObjs}}
  11         25  
151             ];
152             }
153              
154              
155             # do the dimension checking for perl level threading
156             # assumes that IndObjs have been created
157             sub perldimcheck {
158 9     9 0 70 my ($this,$pdl) = @_;
159             croak ("can't create ".$this->name) if $pdl->isnull &&
160 9 50 66     51 !$this->{FlagCreat};
161 9 100       28 return 1 if $pdl->isnull;
162 8         12 my $rdims = @{$this->{RawInds}};
  8         17  
163 8 50       35 croak ("not enough dimensions for ".$this->name)
164             if ($pdl->threadids)[0] < $rdims;
165 8         20 my @dims = $pdl->dims;
166 8         20 my ($i,$ind) = (0,undef);
167 8         12 for $ind (@{$this->{IndObjs}}) {
  8         18  
168 9         35 $ind->add_value($dims[$i++]);
169             }
170 6         23 return 0; # not creating
171             }
172              
173             sub finalcheck {
174 6     6 0 67 my ($this,$pdl) = @_;
175 6 100       24 return [] if $pdl->isnull;
176 5         20 my @corr = ();
177 5         15 my @dims = $pdl->dims;
178 5         11 my ($i,$ind) = (0,undef);
179 5         9 for $ind (@{$this->{IndObjs}}) {
  5         13  
180 6 100       20 push @corr,[$i-1,$ind->{Value},$dims[$i-1]] if $dims[$i++] != $ind->{Value};
181             }
182 5         16 return [@corr];
183             }
184              
185             # get index sizes for a parameter that has to be created
186             sub getcreatedims {
187 1     1 0 14 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 1         2 $_->{Value} } @{$this->{IndObjs}};
  0         0  
  1         4  
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 3     3   676 use Data::Dumper;
  3         6794  
  3         7366  
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 8 my ($this,$generic) = @_;
210 4 50       13 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         16 "(\$PRIV(pdls[$this->{Number}]))";
232             }
233              
234 4     4 0 9 sub get_nnflag { my($this) = @_;
235 4         16 "(\$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 3 my($this) = @_;
247 1         3 my $pdl = $this->get_nname;
248 1         2 my $iref = $this->{IndObjs};
249 1         3 my $ninds = 0+scalar(@$iref);
250              
251 1         2 my $str = "";
252 1 50       3 $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         5 my $size = $iref->[$_-1]->get_size();
  1         5  
262 1         7 " 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         3 for( @$iref ) {
272 1         2 my $siz = $_->get_size();
273 1         4 my $dim = "($pdl)->dims[$no]";
274 1         2 my $ndims = "($pdl)->ndims";
275 1         10 $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         3 $no++;
286             }
287              
288 1 50       4 $str .= "PDLA->make_physical(($pdl));\n" if $this->{FlagPhys};
289              
290 1 50       3 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 23 my($this,$ind) = @_;
307 10 50       30 if($this->{IndTotCounts}[$ind] > 1) {
308 0         0 "__inc_".$this->{Name}."_".($this->{IndObjs}[$ind]->name).$this->{IndCounts}[$ind];
309             } else {
310 10         38 "__inc_".$this->{Name}."_".($this->{IndObjs}[$ind]->name);
311             }
312             }
313              
314             sub get_incdecls {
315 1     1 0 3 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         3 } (0..$#{$this->{IndObjs}}) ) . ";"
  1         3  
320             }
321              
322             sub get_incregisters {
323 3     3 0 10 my($this) = @_;
324 3 50       5 if(scalar(@{$this->{IndObjs}}) == 0) {return "";}
  3         14  
  0         0  
325             (join '',map {
326 3         15 "register PDLA_Indx ".($this->get_incname($_))." = \$PRIV(".
327             ($this->get_incname($_)).");\n";
328 3         92 } (0..$#{$this->{IndObjs}}) )
  3         71  
329             }
330              
331             sub get_incdecl_copy {
332 1     1 0 3 my($this,$fromsub,$tosub) = @_;
333             join '',map {
334 1         3 my $iname = $this->get_incname($_);
335 1         3 &$fromsub($iname)."=".&$tosub($iname).";";
336 1         3 } (0..$#{$this->{IndObjs}})
  1         3  
337             }
338              
339             sub get_incsets {
340 1     1 0 4 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         3  
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 10 my($this,$genlooptype,$asgnonly) = @_;
443 4         6 my $type;
444 4         11 my $pdl = $this->get_nname;
445 4         9 my $flag = $this->get_nnflag;
446 4         14 my $name = $this->{Name};
447 4 50       16 $type = $this->ctype($genlooptype) if defined $genlooptype;
448 4 50       13 my $declini = ($asgnonly ? "" : "\t$type *");
449 4 50       12 my $cast = ($type ? "($type *)" : "");
450             # ThreadLoop does this for us.
451             # return "$declini ${name}_datap = ($cast((${_})->data)) + (${_})->offs;\n";
452            
453 4         17 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     11 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 0         0 $str .= "\t$type ${name}_badval = 0;\n";
463 0         0 $str .= "\tPDLA_Anyval ${name}_anyval_badval = PDLA->get_pdl_badvalue($pdl);\n";
464 0         0 $str .= "\tANYVAL_TO_CTYPE(${name}_badval, ${type}, ${name}_anyval_badval);\n";
465             }
466              
467 4         355 return "$str\n";
468             }
469              
470             1;