File Coverage

/usr/local/lib/perl5/site_perl/5.26.1/x86_64-linux/PDL/PP/PDLCode.pm
Criterion Covered Total %
statement 52 54 96.3
branch 335 1248 26.8
condition n/a
subroutine n/a
pod n/a
total 387 1302 29.7


line stmt bran cond sub pod time code
1             # This file provides a class that parses the Code -member
2             # of the PDL::PP code.
3             #
4             # This is what makes the nice loops go around etc.
5             #
6              
7             package PDL::PP::Code;
8             use Carp;
9             our @CARP_NOT;
10              
11             use strict;
12              
13             # check for bad value support
14             #
15             use PDL::Config;
16             #use vars qw ( $bvalflag $usenan );
17             my $bvalflag = $PDL::Config{WITH_BADVAL} || 0;
18             my $usenan = $PDL::Config{BADVAL_USENAN} || 0;
19              
20             sub get_pdls {my($this) = @_; return ($this->{ParNames},$this->{ParObjs});}
21              
22             # we define the method separate_code() at the end of this
23             # file, so that it can call the constructors from the classes
24             # defined in this file. ugly...
25              
26             # Do the appropriate substitutions in the code.
27             sub new {
28             my($type,$code,$badcode,$parnames,$parobjs,$indobjs,$generictypes,
29             $extrageneric,$havethreading,$name,
30             $dont_add_thrloop, $nogeneric_loop, $backcode ) = @_;
31              
32             die "Error: missing name argument to PDL::PP::Code->new call!\n"
33             unless defined $name;
34              
35             # simple way of handling bad code check
36             $badcode = undef unless $bvalflag;
37             my $handlebad = defined($badcode);
38              
39             # last three arguments may not be supplied
40             # (in fact, the nogeneric_loop argument may never be supplied now?)
41             #
42             # "backcode" is a flag to the PDL::PP::Threadloop class indicating thre threadloop
43             # is for writeback code (typically used for writeback of data from child to parent PDL
44              
45             $dont_add_thrloop = 0 unless defined $dont_add_thrloop;
46             $nogeneric_loop = 0 unless defined $nogeneric_loop;
47              
48              
49             # C++ style comments
50             #
51             # This regexp isn't perfect because it doesn't cope with
52             # literal string constants.
53             #
54             $code =~ s,//.*?\n,,g;
55              
56             if ($::PP_VERBOSE) {
57             print "Processing code for $name\n";
58             print "DONT_ADD_THRLOOP!\n" if $dont_add_thrloop;
59             print "EXTRAGEN: {" .
60             join(" ",
61             map { "$_=>" . $$extrageneric{$_}} keys %$extrageneric)
62             . "}\n";
63             print "ParNAMES: ",(join ',',@$parnames),"\n";
64             print "GENTYPES: ", @$generictypes, "\n";
65             print "HandleBad: $handlebad\n";
66             }
67             my $this = bless {
68             IndObjs => $indobjs,
69             ParNames => $parnames,
70             ParObjs => $parobjs,
71             Gencurtype => [], # stack to hold GenType in generic loops
72             types => 0, # hack for PDL::PP::Types/GenericLoop
73             pars => {}, # hack for PDL::PP::NaNSupport/GenericLoop
74             Generictypes => $generictypes, # so that MacroAccess can check it
75             Name => $name,
76             }, $type;
77              
78             my $inccode = join '',map {$_->get_incregisters();} (sort values %{$this->{ParObjs}});
79              
80             # First, separate the code into an array of C fragments (strings),
81             # variable references (strings starting with $) and
82             # loops (array references, 1. item = variable.
83             #
84             my ( $threadloops, $coderef, $sizeprivs ) =
85             $this->separate_code( "{$inccode\n$code\n}" );
86              
87             # Now, if there is no explicit threadlooping in the code,
88             # enclose everything into it.
89             if(!$threadloops && !$dont_add_thrloop && $havethreading) {
90             print "Adding threadloop...\n" if $::PP_VERBOSE;
91             my $nc = $coderef;
92             if( !$backcode ){ # Normal readbackdata threadloop
93             $coderef = PDL::PP::ThreadLoop->new();
94             }
95             else{ # writebackcode threadloop
96             $coderef = PDL::PP::BackCodeThreadLoop->new();
97             }
98             push @{$coderef},$nc;
99             }
100              
101             # repeat for the bad code, then stick good and bad into
102             # a BadSwitch object which creates the necessary
103             # 'if (bad) { badcode } else { goodcode }' code
104             #
105             # NOTE: amalgamate sizeprivs from good and bad code
106             #
107             if ( $handlebad ) {
108             print "Processing 'bad' code...\n" if $::PP_VERBOSE;
109             my ( $bad_threadloops, $bad_coderef, $bad_sizeprivs ) =
110             $this->separate_code( "{$inccode\n$badcode\n}" );
111              
112             if(!$bad_threadloops && !$dont_add_thrloop && $havethreading) {
113             print "Adding 'bad' threadloop...\n" if $::PP_VERBOSE;
114             my $nc = $bad_coderef;
115             if( !$backcode ){ # Normal readbackdata threadloop
116             $bad_coderef = PDL::PP::ThreadLoop->new();
117             }
118             else{ # writebackcode threadloop
119             $bad_coderef = PDL::PP::BackCodeThreadLoop->new();
120             }
121             push @{$bad_coderef},$nc;
122             }
123              
124             my $good_coderef = $coderef;
125             $coderef = PDL::PP::BadSwitch->new( $good_coderef, $bad_coderef );
126              
127             # amalgamate sizeprivs from Code/BadCode segments
128             # (sizeprivs is a simple hash, with each element
129             # containing a string - see PDL::PP::Loop)
130             while ( my ( $bad_key, $bad_str ) = each %$bad_sizeprivs ) {
131             my $str = $$sizeprivs{$bad_key};
132             if ( defined $str ) {
133             die "ERROR: sizeprivs problem in PP/PDLCode.pm (BadVal stuff)\n"
134             unless $str eq $bad_str;
135             }
136             $$sizeprivs{$bad_key} = $bad_str; # copy over
137             }
138              
139             } # if: $handlebad
140              
141             print "SIZEPRIVSX: ",(join ',',%$sizeprivs),"\n" if $::PP_VERBOSE;
142              
143             # Enclose it all in a genericloop.
144             unless ($nogeneric_loop) {
145             # XXX Make genericloop understand denied pointers;...
146             my $nc = $coderef;
147             $coderef = PDL::PP::GenericLoop->new($generictypes,"",
148             [grep {!$extrageneric->{$_}} @$parnames],'$PRIV(__datatype)');
149             push @{$coderef},$nc;
150             }
151              
152             # Do we have extra generic loops?
153             # If we do, first reverse the hash:
154             my %glh;
155             for(keys %$extrageneric) {
156             push @{$glh{$extrageneric->{$_}}},$_;
157             }
158             my $no = 0;
159             for(keys %glh) {
160             my $nc = $coderef;
161             $coderef = PDL::PP::GenericLoop->new($generictypes,$no++,
162             $glh{$_},$_);
163             push @$coderef,$nc;
164             }
165              
166             # Then, in this form, put it together what we want the code to actually do.
167             print "SIZEPRIVS: ",(join ',',%$sizeprivs),"\n" if $::PP_VERBOSE;
168             $this->{Code} = "{".(join '',sort values %$sizeprivs).
169             $coderef->get_str($this,[])
170             ."}";
171             $this->{Code};
172              
173             } # new()
174              
175             # This sub determines the index name for this index.
176             # For example, a(x,y) and x0 becomes [x,x0]
177             sub make_loopind { my($this,$ind) = @_;
178             my $orig = $ind;
179             while(!$this->{IndObjs}{$ind}) {
180             if(!((chop $ind) =~ /[0-9]/)) {
181             confess("Index not found for $_ ($ind)!\n");
182             }
183             }
184             return [$ind,$orig];
185             }
186              
187              
188             #####################################################################
189             #
190             # Encapsulate the parsing code objects
191             #
192             # All objects have two methods:
193             # new - constructor
194             # get_str - get the string to be put into the xsub.
195              
196             ###########################
197             #
198             # Encapsulate a block
199              
200             package PDL::PP::Block;
201              
202             sub new { my($type) = @_; bless [],$type; }
203              
204             sub myoffs { return 0; }
205             sub myprelude {}
206             sub myitem {return "";}
207             sub mypostlude {}
208              
209             sub get_str {
210             my ($this,$parent,$context) = @_;
211             my $str = $this->myprelude($parent,$context);
212             $str .= $this->get_str_int($parent,$context);
213             $str .= $this->mypostlude($parent,$context);
214             return $str;
215             }
216              
217             sub get_str_int {
218             my ( $this, $parent, $context ) = @_;
219              
220             my $nth=0;
221             my $str = "";
222             MYLOOP: while(1) {
223             my $it = $this->myitem($parent,$nth);
224             last MYLOOP if $nth and !$it;
225             $str .= $it;
226             $str .= (join '',map {ref $_ ? $_->get_str($parent,$context) : $_}
227             @{$this}[$this->myoffs()..$#{$this}]);
228             $nth++;
229             }
230             return $str;
231             } # get_str_int()
232              
233             ###########################
234             #
235             # Deal with bad code
236             # - ie create something like
237             # if ( badflag ) { badcode } else { goodcode }
238             #
239             package PDL::PP::BadSwitch;
240             @PDL::PP::BadSwitch::ISA = "PDL::PP::Block";
241              
242             sub new {
243             my($type,$good,$bad) = @_;
244             return bless [$good,$bad], $type;
245             }
246              
247             sub get_str {
248             my ($this,$parent,$context) = @_;
249              
250             my $good = $this->[0];
251             my $bad = $this->[1];
252              
253             my $str = PDL::PP::pp_line_numbers(__LINE__, "if ( \$PRIV(bvalflag) ) { PDL_COMMENT(\"** do 'bad' Code **\")\n");
254 132 0         $str .= "\n#define PDL_BAD_CODE\n";
    100          
    0          
    100          
    0          
    100          
    0          
    100          
    0          
    100          
    0          
    100          
    0          
    100          
    0          
    100          
    0          
    100          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    50          
    0          
    50          
255             $str .= $bad->get_str($parent,$context);
256             $str .= "\n#undef PDL_BAD_CODE\n";
257             $str .= "} else { PDL_COMMENT(\"** else do 'good' Code **\")\n";
258             $str .= $good->get_str($parent,$context);
259             $str .= "}\n";
260              
261             return $str;
262             }
263              
264             ###########################
265             #
266             # Encapsulate a loop
267              
268             package PDL::PP::Loop;
269             @PDL::PP::Loop::ISA = "PDL::PP::Block";
270              
271             sub new { my($type,$args,$sizeprivs,$parent) = @_;
272             my $this = bless [$args],$type;
273             for(@{$this->[0]}) {
274             print "SIZP $sizeprivs, $_\n" if $::PP_VERBOSE;
275             my $i = $parent->make_loopind($_);
276             $sizeprivs->{$i->[0]} =
277             "register PDL_Indx __$i->[0]_size = \$PRIV(__$i->[0]_size);\n";
278             print "SP :",(join ',',%$sizeprivs),"\n" if $::PP_VERBOSE;
279             }
280             return $this;
281             }
282              
283             sub myoffs { return 1; }
284             sub myprelude { my($this,$parent,$context) = @_;
285             my $text = ""; my $i;
286             push @$context, map {
287             $i = $parent->make_loopind($_);
288             # Used to be $PRIV(.._size) but now we have it in a register.
289             $text .= "{PDL_COMMENT(\"Open $_\") register PDL_Indx $_;
290             for($_=0; $_<(__$i->[0]_size); $_++) {";
291             $i;
292             } @{$this->[0]};
293             return PDL::PP::pp_line_numbers(__LINE__, $text);
294             }
295 4813 0         sub mypostlude { my($this,$parent,$context) = @_;
    0          
    100          
    100          
    0          
    0          
    0          
    0          
    100          
    100          
    100          
    100          
    0          
    0          
    0          
    0          
    100          
    100          
    100          
    100          
    0          
    0          
    100          
    100          
    0          
    0          
    100          
    100          
    0          
    0          
    100          
    100          
    0          
    0          
    0          
    0          
    0          
    100          
    100          
    0          
    100          
    100          
    0          
    0          
    0          
    0          
    100          
    100          
    100          
    100          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    100          
    100          
    0          
    0          
    0          
    0          
    100          
    100          
    0          
296             splice @$context, - ($#{$this->[0]}+1);
297 4657 0         return join '',map {"}} PDL_COMMENT(\"Close $_\")"} @{$this->[0]};
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    50          
    100          
    50          
    50          
    50          
    100          
    50          
    50          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    50          
    100          
    50          
    100          
    50          
    50          
    100          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    50          
    50          
    100          
    50          
    50          
    50          
    50          
    50          
    0          
    0          
    0          
    0          
    0          
    0          
    50          
    100          
    50          
    100          
    50          
    50          
    0          
    0          
    0          
    0          
    0          
    0          
    50          
    100          
    50          
    100          
    50          
    50          
    0          
    0          
    0          
    0          
    0          
    0          
    50          
    100          
    50          
    100          
    50          
    50          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    50          
    100          
    50          
    100          
    0          
    50          
    50          
    100          
    50          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    50          
    100          
    50          
    100          
    50          
    50          
    50          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    50          
    100          
    50          
    100          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    50          
    100          
    50          
    100          
    0          
    0          
298 61 0         }
    0          
    0          
    50          
    50          
    100          
    0          
    0          
    50          
    50          
    0          
    0          
    0          
    50          
    50          
    50          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    50          
    50          
    50          
    0          
    0          
    0          
    50          
    50          
    50          
299 50 0          
    0          
    0          
    0          
    50          
    100          
    50          
    50          
    0          
    50          
    0          
    0          
    50          
    50          
    0          
    0          
    50          
    50          
    0          
    0          
    50          
    50          
    0          
    0          
    0          
    0          
    50          
    50          
    50          
    50          
300 14           ###########################
301 19 0         #
    0          
    0          
    50          
    50          
    50          
    0          
    50          
    0          
    50          
302 6 0         # Encapsulate a generic type loop
    50          
    0          
    50          
    0          
    100          
303 4 0         #
    50          
    0          
    50          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    50          
304 6 0         # we use the value of $parent->{types} [set by a PDL::PP::Types object]
    0          
    100          
    50          
305 5 0         # to determine whether to define/undefine the THISISxxx macros
    50          
306             # (makes the xs code easier to read)
307             #
308             package PDL::PP::GenericLoop;
309             @PDL::PP::GenericLoop::ISA = "PDL::PP::Block";
310              
311             # Types: BSULFD
312             use PDL::Types ':All';
313             sub new {
314             my($type,$types,$name,$varnames,$whattype) = @_;
315             bless [(PDL::PP::get_generictyperecs($types)),$name,$varnames,
316             $whattype],$type;
317             }
318              
319             sub myoffs {4}
320              
321             sub myprelude {
322             my($this,$parent,$context) = @_;
323             push @{$parent->{Gencurtype}},'PDL_undef'; # so that $GENERIC can get at it
324              
325             # horrible hack for PDL::PP::NaNSupport
326             if ( $this->[1] ne "" ) {
327             my ( @test ) = keys %{$parent->{pars}};
328             die "ERROR: need to rethink NaNSupport in GenericLoop\n"
329             if $#test != -1;
330             $parent->{pars} = {};
331             }
332              
333             my $thisis_loop = '';
334             if ( $parent->{types} ) {
335             $thisis_loop = join '',
336             map {
337             "#undef THISIS$this->[1]_$_\n#define THISIS$this->[1]_$_(a)\n"
338             }
339             (ppdefs);
340             }
341              
342             return <
343             PDL_COMMENT("Start generic loop")
344             $thisis_loop
345             switch($this->[3]) { case -42: PDL_COMMENT("Warning eater") {(void)1;
346             WARNING_EATER
347             }
348              
349             sub myitem {
350             my($this,$parent,$nth) = @_;
351             # print "GENERICITEM\n";
352             my $item = $this->[0]->[$nth];
353             if(!$item) {return "";}
354             $parent->{Gencurtype}->[-1] = $item->[1];
355              
356             # horrible hack for PDL::PP::NaNSupport
357             if ( $this->[1] ne "" ) {
358             foreach my $parname ( @{$this->[2]} ) {
359             $parent->{pars}{$parname} = $item->[1];
360             }
361             }
362              
363             my $thisis_loop = '';
364             if ( $parent->{types} ) {
365             $thisis_loop = (
366             join '',
367             map {
368             "#undef THISIS$this->[1]_$_\n#define THISIS$this->[1]_$_(a)\n";
369             }
370             (ppdefs)
371             ) .
372             "#undef THISIS$this->[1]_$item->[3]\n" .
373             "#define THISIS$this->[1]_$item->[3](a) a\n";
374             }
375              
376             return PDL::PP::pp_line_numbers(__LINE__, "\t} break; case $item->[0]: {\n".
377 0           $thisis_loop .
378             (join '',map{
379             # print "DAPAT: '$_'\n";
380             $parent->{ParObjs}{$_}->get_xsdatapdecl($item->[1]);
381             } (@{$this->[2]})));
382             }
383              
384             sub mypostlude {
385             my($this,$parent,$context) = @_;
386             pop @{$parent->{Gencurtype}}; # and clean up the Gentype stack
387              
388             # horrible hack for PDL::PP::NaNSupport
389             if ( $this->[1] ne "" ) { $parent->{pars} = {}; }
390              
391             return "\tbreak;}
392             default:barf(\"PP INTERNAL ERROR! PLEASE MAKE A BUG REPORT\\n\");}\n";
393             }
394              
395              
396             ###########################
397             #
398             # Encapsulate a threadloop.
399             # There are several different
400              
401             package PDL::PP::ThreadLoop;
402             sub new {
403             return PDL::PP::ComplexThreadLoop->new(@_);
404             }
405              
406             package PDL::PP::SimpleThreadLoop;
407             use Carp;
408             @PDL::PP::SimpleThreadLoop::ISA = "PDL::PP::Block";
409             our @CARP_NOT;
410              
411             sub new { my($type) = @_; bless [],$type; }
412             sub myoffs { return 0; }
413             sub myprelude {my($this,$parent,$context) = @_;
414             my $no;
415             my ($ord,$pdls) = $parent->get_pdls();
416             PDL::PP::pp_line_numbers(__LINE__, ' PDL_COMMENT("THREADLOOPBEGIN")
417             if(PDL->startthreadloop(&($PRIV(__pdlthread)),$PRIV(vtable)->readdata,
418             __privtrans))) return;
419             do {
420             '.(join '',map {"${_}_datap += \$PRIV(__pdlthread).offs[".(0+$no++)."];\n"}
421             @$ord).'
422             ');
423             }
424              
425             sub mypostlude {my($this,$parent,$context) = @_;
426             my $no;
427             my ($ord,$pdls) = $parent->get_pdls();
428             ' PDL_COMMENT("THREADLOOPEND")
429             '.(join '',map {"${_}_datap -= \$PRIV(__pdlthread).offs[".(0+$no++)."];\n"}
430             @$ord).'
431             } while(PDL->iterthreadloop(&$PRIV(__pdlthread),0));
432             '
433             }
434              
435             ####
436             #
437             # This relies on PP.pm making sure that initthreadloop always sets
438             # up the two first dimensions even when they are not necessary.
439             #
440             package PDL::PP::ComplexThreadLoop;
441             use Carp;
442             @PDL::PP::ComplexThreadLoop::ISA = "PDL::PP::Block";
443             our @CARP_NOT;
444              
445              
446             sub new {
447             my $type = shift;
448             bless [],$type;
449             }
450             sub myoffs { return 0; }
451             sub myprelude {
452             my($this,$parent,$context, $backcode) = @_;
453              
454             # Set appropriate function from the vtable to supply to threadthreadloop.
455             # Function name from the vtable is readdata for normal code
456             # function name for backcode is writebackdata
457             my $funcName = "readdata";
458             $funcName = "writebackdata" if( $backcode );
459              
460             my ($ord,$pdls) = $parent->get_pdls();
461              
462             PDL::PP::pp_line_numbers(__LINE__, join "\n ",
463             '',
464             'PDL_COMMENT("THREADLOOPBEGIN")',
465 132 0         'if ( PDL->startthreadloop(&($PRIV(__pdlthread)),$PRIV(vtable)->'.$funcName.', __tr) ) return;
    0          
    50          
    50          
    0          
    0          
    50          
    50          
    0          
    0          
    50          
    50          
    0          
    0          
    50          
    50          
    0          
    0          
    50          
    50          
    0          
    0          
    50          
    50          
    0          
    0          
    50          
    50          
    0          
    0          
    50          
    50          
    0          
    0          
    50          
    50          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    50          
    0          
    0          
    0          
    50          
    0          
466 132           do { register PDL_Indx __tind1=0,__tind2=0;
467 132           register PDL_Indx __tnpdls = $PRIV(__pdlthread).npdls;
468 132           register PDL_Indx __tdims1 = $PRIV(__pdlthread.dims[1]);
469 132           register PDL_Indx __tdims0 = $PRIV(__pdlthread.dims[0]);
470 132           register PDL_Indx *__offsp = PDL->get_threadoffsp(&$PRIV(__pdlthread));',
471 132           ( map { "register PDL_Indx __tinc0_${_} = \$PRIV(__pdlthread).incs[${_}];"} 0..$#{$ord}),
472 132           ( map { "register PDL_Indx __tinc1_${_} = \$PRIV(__pdlthread).incs[__tnpdls+$_];"} 0.. $#{$ord}),
473 132           ( map { $ord->[$_] ."_datap += __offsp[$_];"} 0..$#{$ord} ),
474 132           'for( __tind2 = 0 ;
475 132           __tind2 < __tdims1 ;
476 132           __tind2++',
477 22 0         ( map { "\t\t," . $ord->[$_] . "_datap += __tinc1_${_} - __tinc0_${_} * __tdims0"} 0..$#{$ord} ),
    0          
    100          
    100          
    0          
    0          
    100          
    100          
    0          
    0          
    100          
    100          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    100          
    0          
    0          
    0          
    100          
    0          
478 121           ')',
479 132           '{
480 243 0         for( __tind1 = 0 ;
    0          
    100          
    100          
    0          
    0          
    100          
    100          
    0          
    0          
    100          
    100          
    0          
    0          
    100          
    100          
    0          
    0          
    100          
    100          
    0          
    0          
    100          
    100          
481 11           __tind1 < __tdims0 ;
482 122           __tind1++',
483 122           ( map { "\t\t," . $ord->[$_] . "_datap += __tinc0_${_}"} 0..$#{$ord}),
484 26 0         ')',
    0          
    100          
    100          
    0          
    0          
    100          
    100          
    0          
    0          
    100          
    100          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    100          
    0          
    0          
    0          
    100          
    0          
485 122           '{ PDL_COMMENT("This is the tightest threadloop. Make sure inside is optimal.")'
486 15           );
487 15           }
488 273 0          
    0          
    100          
    100          
    0          
    0          
    100          
    100          
    0          
    0          
    100          
    100          
    0          
    0          
    100          
    100          
    0          
    0          
    100          
    100          
    0          
    0          
    100          
    100          
489             # Should possibly fold out thread.dims[0] and [1].
490 136           sub mypostlude {my($this,$parent,$context) = @_;
491 151            
492 149           my ($ord,$pdls) = $parent->get_pdls();
493 136           PDL::PP::pp_line_numbers(__LINE__, join "\n ",
494             '',
495 3           'PDL_COMMENT("THREADLOOPEND")',
496 139           '}',
497 138           '}',
498 7 0         ( map { $ord->[$_] . "_datap -= __tinc1_${_} * __tdims1 + __offsp[${_}];"} 0..$#{$ord} ),
    0          
    0          
    100          
    50          
499 6 100         '} while(PDL->iterthreadloop(&$PRIV(__pdlthread),2));'
500 11 0         )
    0          
    50          
    50          
    0          
    0          
    50          
    50          
    0          
    0          
    50          
    50          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    50          
    0          
    0          
    0          
    50          
    0          
501 121 0         }
    0          
    50          
    50          
    0          
    0          
    50          
    50          
    0          
    0          
    50          
    50          
    0          
    0          
    50          
    50          
    0          
    0          
    50          
    50          
    0          
    0          
    50          
    50          
502 16 0          
503 126 100         # Simple subclass of ComplexThreadLoop to implement writeback code
504 0           #
505             #
506             package PDL::PP::BackCodeThreadLoop;
507             use Carp;
508             @PDL::PP::BackCodeThreadLoop::ISA = "PDL::PP::ComplexThreadLoop";
509             our @CARP_NOT;
510              
511 11           sub myprelude {
512 121           my($this,$parent,$context, $backcode) = @_;
513 11            
514 121           # Set backcode flag if not defined. This will make the parent
515             # myprelude emit proper writeback code
516             $backcode = 1 unless defined($backcode);
517              
518             $this->SUPER::myprelude($parent, $context, $backcode);
519             }
520              
521              
522             ###########################
523             #
524             # Encapsulate a types() switch
525             #
526             # horrible hack:
527             # set $parent->{types} if we create this object so that
528             # PDL::PP::GenericLoop knows to define the THISIS ... macros
529             #
530             package PDL::PP::Types;
531             use Carp;
532             use PDL::Types ':All';
533             @PDL::PP::Types::ISA = "PDL::PP::Block";
534             our @CARP_NOT;
535              
536             sub new {
537             my($type,$ts,$parent) = @_;
538             my $types = join '', ppdefs; # BSUL....
539             $ts =~ /[$types]+/ or confess "Invalid type access with '$ts'!";
540             $parent->{types} = 1; # hack for PDL::PP::GenericLoop
541             bless [$ts],$type; }
542             sub myoffs { return 1; }
543             sub myprelude {
544             my($this,$parent,$context) = @_;
545             return "\n#if ". (join '||',map {"(THISIS_$_(1)+0)"} split '',$this->[0])."\n";
546             }
547              
548             sub mypostlude {my($this,$parent,$context) = @_;
549             "\n#endif\n"
550             }
551              
552              
553             ###########################
554             #
555             # Encapsulate an access
556              
557             package PDL::PP::Access;
558             use Carp;
559             our @CARP_NOT;
560              
561             sub new { my($type,$str,$parent) = @_;
562             $str =~ /^\$([a-zA-Z_]\w*)\s*\(([^)]*)\)/ or
563             confess ("Access wrong: '$str'\n");
564             my($pdl,$inds) = ($1,$2);
565             if($pdl =~ /^T/) {new PDL::PP::MacroAccess($pdl,$inds,
566             $parent->{Generictypes},$parent->{Name});}
567             elsif($pdl =~ /^P$/) {new PDL::PP::PointerAccess($pdl,$inds);}
568             elsif($pdl =~ /^PP$/) {new PDL::PP::PhysPointerAccess($pdl,$inds);}
569             elsif($pdl =~ /^SIZE$/) {new PDL::PP::SizeAccess($pdl,$inds);}
570             elsif($pdl =~ /^RESIZE$/) {new PDL::PP::ReSizeAccess($pdl,$inds);}
571             elsif($pdl =~ /^GENERIC$/) {new PDL::PP::GentypeAccess($pdl,$inds);}
572             elsif($pdl =~ /^PDL$/) {new PDL::PP::PdlAccess($pdl,$inds);}
573             elsif(!defined $parent->{ParObjs}{$pdl}) {new PDL::PP::OtherAccess($pdl,$inds);}
574             else {
575             bless [$pdl,$inds],$type;
576             }
577             }
578              
579             sub get_str { my($this,$parent,$context) = @_;
580             # print "AC: $this->[0]\n";
581             $parent->{ParObjs}{$this->[0]}->do_access($this->[1],$context)
582             if defined($parent->{ParObjs}{$this->[0]});
583             }
584              
585             ###########################
586             #
587             # Just some other substituted thing.
588              
589             package PDL::PP::OtherAccess;
590             sub new { my($type,$pdl,$inds) = @_; bless [$pdl,$inds],$type; }
591             sub get_str {my($this) = @_;return "\$$this->[0]($this->[1])"}
592              
593              
594             ###########################
595             #
596             # used by BadAccess code to know when to use NaN support
597             # - the output depends on the value of the
598             # BADVAL_USENAN option in perldl.conf
599             # == 1 then we use NaN's
600             # 0 PDL.bvals.Float/Double
601             #
602             # note the *horrible hack* for piddles whose type have been
603             # specified using the FType option - see GenericLoop.
604             # There MUST be a better way than this...
605             #
606             package PDL::PP::NaNSupport;
607             use PDL::Types ':All'; # typefld et al.
608              
609             # need to be lower-case because of FlagTyped stuff
610             #
611             # need to be able to handle signatures with fixed types
612             # which means parameters like 'int mask()',
613             # which means the hack to add 'int' to %use_nan
614             #
615             my %use_nan =
616             map {(typefld($_,'convertfunc') => typefld($_,'usenan')*$usenan)} typesrtkeys;
617             $use_nan{int} = 0;
618              
619             # original try
620             ##my %use_nan =
621             ## map {(typefld($_,'convertfunc') => typefld($_,'usenan')*$usenan)} typesrtkeys;
622              
623             # Was the following, before new Type "interface"
624             # ( byte => 0, short => 0, ushort => 0, long => 0,
625             # int => 0, longlong => 0, # necessary for fixed-type piddles (or something)
626             # float => $usenan,
627             # double => $usenan
628             # );
629              
630             my %set_nan =
631             (
632             float => 'PDL->bvals.Float', PDL_Float => 'PDL->bvals.Float',
633             double => 'PDL->bvals.Double', PDL_Double => 'PDL->bvals.Double',
634             );
635              
636             sub use_nan ($) {
637             my $type = shift;
638              
639             $type =~ s/^PDL_//;
640             $type = lc $type;
641             die "ERROR: Unknown type [$type] used in a 'Bad' macro."
642             unless exists $use_nan{$type};
643             return $use_nan{$type};
644             }
645              
646             sub convert ($$$$$) {
647             my ( $parent, $name, $lhs, $rhs, $opcode ) = @_;
648              
649             my $type = $parent->{Gencurtype}[-1];
650             die "ERROR: unable to find type info for $opcode access"
651             unless defined $type;
652              
653             # note: gentype may not be sensible because the
654             # actual piddle could have a 'fixed' type
655             die "ERROR: unable to find piddle $name in parent!"
656             unless exists $parent->{ParObjs}{$name};
657             my $pobj = $parent->{ParObjs}{$name};
658              
659             # based on code from from PdlParObj::ctype()
660             # - want to handle FlagTplus case
661             # - may not be correct
662             # - extended to include hack to GenericLoop
663             #
664             if ( exists $parent->{pars}{$name} ) {
665             $type = $parent->{pars}{$name};
666             print "#DBG: hacked <$name> to type <$type>\n" if $::PP_VERBOSE;
667             } elsif ( exists $pobj->{FlagTyped} and $pobj->{FlagTyped} ) {
668             $type = $pobj->{Type};
669              
670             # this should use Dev.pm - fortunately only worried about double/float here
671             # XXX - do I really know what I'm doing ?
672             if ( $pobj->{FlagTplus} ) {
673             my $gtype = $parent->{Gencurtype}[-1];
674             if ( $gtype eq "PDL_Double" ) {
675             $type = $gtype if $type ne "double";
676             } elsif ( $gtype eq "PDL_Float" ) {
677             $type = $gtype if $type !~ /^(float|double)$/; # note: ignore doubles
678             }
679             }
680             }
681              
682             if ( use_nan($type) ) {
683             if ( $opcode eq "SETBAD" ) {
684             # $rhs = "(0.0/0.0)";
685             $rhs = $set_nan{$type};
686             } else {
687             $rhs = "0";
688             $lhs = "finite($lhs)";
689             }
690             }
691              
692             return ( $lhs, $rhs );
693             }
694              
695             ###########################
696             #
697             # Encapsulate a check on whether a value is good or bad
698             # handles both checking (good/bad) and setting (bad)
699             #
700             # Integer types (BSUL) + floating point when no NaN (FD)
701             # $ISBAD($a(n)) -> $a(n) == a_badval
702             # $ISGOOD($a()) $a() != a_badval
703             # $SETBAD($a()) $a() = a_badval
704             #
705             # floating point with NaN
706             # $ISBAD($a(n)) -> finite($a(n)) == 0
707             # $ISGOOD($a()) finite($a()) != 0
708             # $SETBAD($a()) $a() = PDL->bvals.Float (or .Double)
709             #
710             # I've also got it so that the $ on the pdl name is not
711             # necessary - so $ISBAD(a(n)) is also accepted, so as to reduce the
712             # amount of line noise. This is actually done by the regexp
713             # in the separate_code() sub at the end of the file.
714             #
715             # note:
716             # we also expand out $a(n) etc as well here
717             #
718             # To do:
719             # need to allow use of F,D without NaN
720             #
721              
722             package PDL::PP::BadAccess;
723             use Carp;
724             our @CARP_NOT;
725              
726             sub new {
727             my ( $type, $opcode, $pdl_name, $inds, $parent ) = @_;
728              
729             # trying to avoid auto creation of hash elements
730             my $check = $parent->{ParObjs};
731             die "\nIt looks like you have tried a \$${opcode}() macro on an\n" .
732             " unknown piddle <$pdl_name($inds)>\n"
733             unless exists($check->{$pdl_name}) and defined($check->{$pdl_name});
734              
735             return bless [$opcode, $pdl_name, $inds], $type;
736             }
737              
738             our %ops = ( ISBAD => '==', ISGOOD => '!=', SETBAD => '=' );
739              
740             sub get_str {
741             my($this,$parent,$context) = @_;
742              
743             my $opcode = $this->[0];
744             my $name = $this->[1];
745             my $inds = $this->[2];
746              
747             print "PDL::PP::BadAccess sent [$opcode] [$name] [$inds]\n" if $::PP_VERBOSE;
748              
749             my $op = $ops{$opcode};
750             die "ERROR: unknown check <$opcode> sent to PDL::PP::BadAccess\n"
751             unless defined $op;
752              
753             my $obj = $parent->{ParObjs}{$name};
754             die "ERROR: something screwy in PDL::PP::BadAccess (PP/PDLCode.pm)\n"
755             unless defined( $obj );
756              
757             my $lhs = $obj->do_access($inds,$context);
758             my $rhs = "${name}_badval";
759              
760             ( $lhs, $rhs ) =
761             PDL::PP::NaNSupport::convert( $parent, $name, $lhs, $rhs, $opcode );
762              
763             print "DBG: [$lhs $op $rhs]\n" if $::PP_VERBOSE;
764             return "$lhs $op $rhs";
765             }
766              
767              
768             ###########################
769             #
770             # Encapsulate a check on whether a value is good or bad
771             # handles both checking (good/bad) and setting (bad)
772             #
773             # Integer types (BSUL) + floating point when no NaN (FD)
774             # $ISBADVAR(foo,a) -> foo == a_badval
775             # $ISGOODVAR(foo,a) foo != a_badval
776             # $SETBADVAR(foo,a) foo = a_badval
777             #
778             # floating point with NaN
779             # $ISBADVAR(foo,a) -> finite(foo) == 0
780             # $ISGOODVAR(foo,a) finite(foo) != 0
781             # $SETBADVAR(foo,a) foo = PDL->bvals.Float (or .Double)
782             #
783              
784             package PDL::PP::BadVarAccess;
785             use Carp;
786             our @CARP_NOT;
787              
788             sub new {
789             my ( $type, $opcode, $var_name, $pdl_name, $parent ) = @_;
790              
791             # trying to avoid auto creation of hash elements
792             my $check = $parent->{ParObjs};
793             die "\nIt looks like you have tried a \$${opcode}() macro on an\n" .
794             " unknown piddle <$pdl_name>\n"
795             unless exists($check->{$pdl_name}) and defined($check->{$pdl_name});
796              
797             bless [$opcode, $var_name, $pdl_name], $type;
798             }
799              
800             our %ops = ( ISBAD => '==', ISGOOD => '!=', SETBAD => '=' );
801              
802             sub get_str {
803             my($this,$parent,$context) = @_;
804              
805             my $opcode = $this->[0];
806             my $var_name = $this->[1];
807             my $pdl_name = $this->[2];
808              
809             print "PDL::PP::BadVarAccess sent [$opcode] [$var_name] [$pdl_name]\n" if $::PP_VERBOSE;
810              
811             my $op = $ops{$opcode};
812             die "ERROR: unknown check <$opcode> sent to PDL::PP::BadVarAccess\n"
813             unless defined $op;
814              
815             my $obj = $parent->{ParObjs}{$pdl_name};
816             die "ERROR: something screwy in PDL::PP::BadVarAccess (PP/PDLCode.pm)\n"
817             unless defined( $obj );
818              
819             my $lhs = $var_name;
820             my $rhs = "${pdl_name}_badval";
821              
822             ( $lhs, $rhs ) =
823             PDL::PP::NaNSupport::convert( $parent, $pdl_name, $lhs, $rhs, $opcode );
824              
825             print "DBG: [$lhs $op $rhs]\n" if $::PP_VERBOSE;
826             return "$lhs $op $rhs";
827             }
828              
829              
830             ###########################
831             #
832             # Encapsulate a check on whether a value is good or bad using PP
833             # handles both checking (good/bad) and setting (bad)
834              
835             # this is only an initial attempt - it will, almost certainly,
836             # need more work as more code is converted to handle bad values
837             #
838             # currently it can only handle cases like
839             # $PPISBAD(PARENT,[i]) -> PARENT_physdatap[i] == PARENT_badval
840             # etc
841             #
842             # if we use NaN's, then
843             # $PPISBAD(PARENT,[i]) -> finite(PARENT_physdatap[i]) == 0
844             # $PPISGOOD(PARENT,[i]) -> finite(PARENT_physdatap[i]) != 0
845             # $PPSETBAD(PARENT,[i]) -> PARENT_physdatap[i] = PDL->bvals.Float (or .Double)
846             #
847              
848             package PDL::PP::PPBadAccess;
849             use Carp;
850             our @CARP_NOT;
851              
852             sub new {
853             my ( $type, $opcode, $pdl_name, $inds, $parent ) = @_;
854              
855             $opcode =~ s/^PP//;
856             bless [$opcode, $pdl_name, $inds], $type;
857             }
858              
859             # PP is stripped in new()
860             our %ops = ( ISBAD => '==', ISGOOD => '!=', SETBAD => '=' );
861              
862             sub get_str {
863             my($this,$parent,$context) = @_;
864              
865             my $opcode = $this->[0];
866             my $name = $this->[1];
867             my $inds = $this->[2];
868              
869             print "PDL::PP::PPBadAccess sent [$opcode] [$name] [$inds]\n" if $::PP_VERBOSE;
870              
871             my $op = $ops{$opcode};
872             die "\nERROR: unknown check <$opcode> sent to PDL::PP::PPBadAccess\n"
873             unless defined $op;
874              
875             my $obj = $parent->{ParObjs}{$name};
876             die "\nERROR: ParObjs does not seem to exist for <$name> = problem in PDL::PP::PPBadAccess\n"
877             unless defined $obj;
878              
879             my $lhs = $obj->do_physpointeraccess() . "$inds";
880             my $rhs = "${name}_badval";
881              
882             ( $lhs, $rhs ) =
883             PDL::PP::NaNSupport::convert( $parent, $name, $lhs, $rhs, $opcode );
884              
885             print "DBG: [$lhs $op $rhs]\n" if $::PP_VERBOSE;
886             return "$lhs $op $rhs";
887             }
888              
889              
890             ###########################
891             #
892             # Encapsulate a check on whether the state flag of a piddle
893             # is set/change this state
894             #
895             # $PDLSTATEISBAD(a) -> ($PDL(a)->state & PDL_BADVAL) > 0
896             # $PDLSTATEISGOOD(a) -> ($PDL(a)->state & PDL_BADVAL) == 0
897             #
898             # $PDLSTATESETBAD(a) -> ($PDL(a)->state |= PDL_BADVAL)
899             # $PDLSTATESETGOOD(a) -> ($PDL(a)->state &= ~PDL_BADVAL)
900             #
901              
902             package PDL::PP::PDLStateBadAccess;
903             use Carp;
904             our @CARP_NOT;
905              
906             sub new {
907             my ( $type, $op, $val, $pdl_name, $parent ) = @_;
908              
909             # $op is one of: IS SET
910             # $val is one of: GOOD BAD
911              
912             # trying to avoid auto creation of hash elements
913             my $check = $parent->{ParObjs};
914             die "\nIt looks like you have tried a \$PDLSTATE${op}${val}() macro on an\n" .
915             " unknown piddle <$pdl_name>\n"
916             unless exists($check->{$pdl_name}) and defined($check->{$pdl_name});
917              
918             bless [$op, $val, $pdl_name], $type;
919             }
920              
921             our %ops = (
922             IS => { GOOD => '== 0', BAD => '> 0' },
923             SET => { GOOD => '&= ~', BAD => '|= ' },
924             );
925              
926             sub get_str {
927             my($this,$parent,$context) = @_;
928              
929             my $op = $this->[0];
930             my $val = $this->[1];
931             my $name = $this->[2];
932              
933             print "PDL::PP::PDLStateBadAccess sent [$op] [$val] [$name]\n" if $::PP_VERBOSE;
934              
935             my $opcode = $ops{$op}{$val};
936             my $type = $op . $val;
937             die "ERROR: unknown check <$type> sent to PDL::PP::PDLStateBadAccess\n"
938             unless defined $opcode;
939              
940             my $obj = $parent->{ParObjs}{$name};
941             die "\nERROR: ParObjs does not seem to exist for <$name> = problem in PDL::PP::PDLStateBadAccess\n"
942             unless defined $obj;
943              
944             my $state = $obj->do_pdlaccess() . "->state";
945              
946             my $str;
947             if ( $op eq 'IS' ) {
948             $str = "($state & PDL_BADVAL) $opcode";
949             } elsif ( $op eq 'SET' ) {
950             $str = "$state ${opcode}PDL_BADVAL";
951             }
952              
953             print "DBG: [$str]\n" if $::PP_VERBOSE;
954             return $str;
955             }
956              
957              
958             ###########################
959             #
960             # Encapsulate a Pointeraccess
961              
962             package PDL::PP::PointerAccess;
963             use Carp;
964             our @CARP_NOT;
965              
966             sub new { my($type,$pdl,$inds) = @_; bless [$inds],$type; }
967              
968             sub get_str {my($this,$parent,$context) = @_;
969             croak ("can't access undefined pdl ".$this->[0])
970             unless defined($parent->{ParObjs}{$this->[0]});
971             # $parent->{ParObjs}{$this->[0]}->{FlagPaccess} = 1;
972             $parent->{ParObjs}{$this->[0]}->{FlagPhys} = 1;
973             $parent->{ParObjs}{$this->[0]}->do_pointeraccess();
974             }
975              
976              
977             ###########################
978             #
979             # Encapsulate a PhysPointeraccess
980              
981             package PDL::PP::PhysPointerAccess;
982             use Carp;
983             our @CARP_NOT;
984              
985             sub new { my($type,$pdl,$inds) = @_; bless [$inds],$type; }
986              
987             sub get_str {my($this,$parent,$context) = @_;
988             $parent->{ParObjs}{$this->[0]}->do_physpointeraccess()
989             if defined($parent->{ParObjs}{$this->[0]});
990             }
991              
992             ###########################
993             #
994             # Encapsulate a PDLaccess
995              
996             package PDL::PP::PdlAccess;
997             use Carp;
998             our @CARP_NOT;
999              
1000             sub new { my($type,$pdl,$inds) = @_; bless [$inds],$type; }
1001              
1002             sub get_str {my($this,$parent,$context) = @_;
1003             croak ("can't access undefined pdl ".$this->[0])
1004             unless defined($parent->{ParObjs}{$this->[0]});
1005             $parent->{ParObjs}{$this->[0]}->do_pdlaccess();
1006             }
1007              
1008             ###########################
1009             #
1010             # Encapsulate a macroaccess
1011              
1012             package PDL::PP::MacroAccess;
1013             use Carp;
1014             use PDL::Types ':All';
1015             my $types = join '',ppdefs;
1016             our @CARP_NOT;
1017              
1018             sub new { my($type,$pdl,$inds,$gentypes,$name) = @_;
1019             $pdl =~ /^\s*T([A-Z]+)\s*$/ or confess("Macroaccess wrong: $pdl\n");
1020             my @ilst = split '',$1;
1021             for my $gt (@$gentypes) {
1022             warn "$name has no Macro for generic type $gt (has $pdl)\n"
1023             unless grep {$gt eq $_} @ilst }
1024             for my $mtype (@ilst) {
1025             warn "Macro for unsupported generic type identifier $mtype".
1026             " (probably harmless)\n"
1027             unless grep {$mtype eq $_} @$gentypes;
1028             }
1029             return bless [$pdl,$inds,$name],
1030             $type; }
1031              
1032             sub get_str {my($this,$parent,$context) = @_;
1033             my ($pdl,$inds,$name) = @{$this};
1034             $pdl =~ /^\s*T([A-Z]+)\s*$/
1035             or confess("Macroaccess wrong in $name (allowed types $types): was '$pdl'\n");
1036             my @lst = split ',',$inds;
1037             my @ilst = split '',$1;
1038             if($#lst != $#ilst) {confess("Macroaccess: different nos of args $pdl $inds\n");}
1039             croak "generic type access outside a generic loop in $name"
1040             unless defined $parent->{Gencurtype}->[-1];
1041             my $type = mapfld $parent->{Gencurtype}->[-1], 'ctype' => 'ppsym';
1042             # print "Type access: $type\n";
1043             croak "unknown Type in $name (generic type currently $parent->{Gencurtype}->[-1]"
1044             unless defined $type;
1045             for (0..$#lst) {
1046             return "$lst[$_]" if $ilst[$_] =~ /$type/;
1047             }
1048             }
1049              
1050              
1051             ###########################
1052             #
1053             # Encapsulate a SizeAccess
1054              
1055             package PDL::PP::SizeAccess;
1056             use Carp;
1057             our @CARP_NOT;
1058              
1059             sub new { my($type,$pdl,$inds) = @_; bless [$inds],$type; }
1060              
1061             sub get_str {my($this,$parent,$context) = @_;
1062             croak "can't get SIZE of undefined dimension $this->[0]"
1063             unless defined($parent->{IndObjs}{$this->[0]});
1064             $parent->{IndObjs}{$this->[0]}->get_size();
1065             }
1066              
1067             ###########################
1068             #
1069             # Encapsulate a ReSizeAccess
1070              
1071             package PDL::PP::ReSizeAccess;
1072             use Carp;
1073             our @CARP_NOT;
1074              
1075             sub new { my($type,$pdl,$inds) = @_; bless [$inds],$type; }
1076              
1077             sub get_str {my($this,$parent,$context) = @_;
1078             $this->[0] =~ /^([^,]+),([^,]+)$/ or
1079             croak "Can't interpret resize str $this->[0]";
1080             croak "can't RESIZE undefined dimension $1"
1081             unless defined($parent->{IndObjs}{$1});
1082              
1083             my $s = $parent->{IndObjs}{$1}->get_size();
1084              
1085             # XXX NOTE: All piddles must be output piddles, there must not be
1086             # a loop over this var (at all!) etc. Should check for these,
1087             # this is why not yet documented.
1088             # FURTHER NOTE: RESIZE DOESN'T COPY DATA PROPERLY!
1089              
1090             my($ord,$pdls) = $parent->get_pdls();
1091             my @p;
1092              
1093             for(@$ord) {
1094             push @p, $_
1095             if $pdls->{$_}->has_dim($1);
1096             }
1097             print "RESIZEACC: $1 $2, (",(join ',',@p),")\n";
1098             warn "RESIZE USED: DO YOU KNOW WHAT YOU ARE DOING???\n";
1099              
1100             return "$s = $2; ".(join '',map {$pdls->{$_}->do_resize($1,$2)} @p);
1101             }
1102              
1103              
1104             ###########################
1105             #
1106             # Encapsulate a GentypeAccess
1107              
1108             package PDL::PP::GentypeAccess;
1109             use Carp;
1110             our @CARP_NOT;
1111              
1112             sub new { my($type,$pdl,$inds) = @_; bless [$inds],$type; }
1113              
1114             sub get_str {my($this,$parent,$context) = @_;
1115             croak "generic type access outside a generic loop"
1116             unless defined $parent->{Gencurtype}->[-1];
1117             my $type = $parent->{Gencurtype}->[-1];
1118             if ($this->[0]) {
1119             croak "not a defined name"
1120             unless defined($parent->{ParObjs}{$this->[0]});
1121             $type = $parent->{ParObjs}{$this->[0]}->ctype($type);
1122             }
1123             return $type;
1124             }
1125              
1126             ########################
1127             #
1128             # Type coercion
1129             #
1130             # Now, if TYPES:F given and double arguments, will coerce.
1131              
1132             package PDL::PP::TypeConv;
1133              
1134             # make the typetable from info in PDL::Types
1135             use PDL::Types ':All';
1136             my @typetable = map {[$typehash{$_}->{ppsym},
1137             $typehash{$_}->{ctype},
1138             $typehash{$_}->{numval},
1139             ]} typesrtkeys;
1140              
1141             sub print_xscoerce { my($this) = @_;
1142             $this->printxs("\t__priv->datatype=PDL_B;\n");
1143             # First, go through all the types, selecting the most general.
1144             for(@{$this->{PdlOrder}}) {
1145             $this->printxs($this->{Pdls}{$_}->get_xsdatatypetest());
1146             }
1147             # See which types we are allowed to use.
1148             $this->printxs("\tif(0) {}\n");
1149             for(@{$this->get_generictypes()}) {
1150             $this->printxs("\telse if(__priv->datatype <= $_->[2]) __priv->datatype = $_->[2];\n");
1151             }
1152             $this->{Types} =~ /F/ and (
1153             $this->printxs("\telse if(__priv->datatype == PDL_D) {__priv->datatype = PDL_F; PDL_COMMENT(\"Cast double to float\")}\n"));
1154             $this->printxs(qq[\telse {croak("Too high type \%d given!\\n",__priv->datatype);}]);
1155             # Then, coerce everything to this type.
1156             for(@{$this->{PdlOrder}}) {
1157             $this->printxs($this->{Pdls}{$_}->get_xscoerce());
1158             }
1159             }
1160             # XXX Should use PDL::Core::Dev;
1161              
1162             no strict 'vars';
1163              
1164             # STATIC!
1165             sub PDL::PP::get_generictyperecs { my($types) = @_;
1166             my $foo;
1167             return [map {$foo = $_;
1168             ( grep {/$foo->[0]/} (@$types) ) ?
1169             [mapfld($_->[0],'ppsym'=>'sym'),$_->[1],$_->[2],$_->[0]]
1170             : ()
1171             }
1172             @typetable];
1173             }
1174              
1175             sub xxx_get_generictypes { my($this) = @_;
1176             return [map {
1177             $this->{Types} =~ /$_->[0]/ ? [mapfld($_->[0],'ppsym'=>'sym'),$_->[1],$_->[2],$_->[0]] : ()
1178             }
1179             @typetable];
1180             }
1181              
1182              
1183             package PDL::PP::Code;
1184              
1185             # my ( $threadloops, $coderef, $sizeprivs ) = $this->separate_code( $code );
1186             #
1187             # umm, can't call classes defined later on in code ...
1188             # hence moved to end of file
1189             # (rather ugly...)
1190             #
1191             # XXX The above statement is almost certainly false. This module is parsed
1192             # before separate_code is ever called, so all of the class definitions
1193             # should exist. -- David Mertens, Dec 2 2011
1194             #
1195             # separates the code into an array of C fragments (strings),
1196             # variable references (strings starting with $) and
1197             # loops (array references, 1. item = variable.
1198             #
1199             sub separate_code {
1200             ## $DB::single=1;
1201             my ( $this, $code ) = @_;
1202              
1203             # First check for standard code errors:
1204             catch_code_errors($code);
1205              
1206             my $coderef = new PDL::PP::Block;
1207              
1208             my @stack = ($coderef);
1209             my $threadloops = 0;
1210             my $sizeprivs = {};
1211              
1212             local $_ = $code;
1213             ## print "Code to parse = [$_]\n" if $::PP_VERBOSE;
1214             while($_) {
1215             # Parse next statement
1216              
1217             # I'm not convinced that having the checks twice is a good thing,
1218             # since it makes it easy (for me at least) to forget to update one
1219             # of them
1220              
1221             s/^(.*?) # First, some noise is allowed. This may be bad.
1222             ( \$(ISBAD|ISGOOD|SETBAD)\s*\(\s*\$?[a-zA-Z_]\w*\s*\([^)]*\)\s*\) # $ISBAD($a(..)), ditto for ISGOOD and SETBAD
1223             |\$PP(ISBAD|ISGOOD|SETBAD)\s*\(\s*[a-zA-Z_]\w*\s*,\s*[^)]*\s*\) # $PPISBAD(CHILD,[1]) etc
1224             ### |\$STATE(IS|SET)(BAD|GOOD)\s*\(\s*[^)]*\s*\) # $STATEISBAD(a) etc
1225             |\$PDLSTATE(IS|SET)(BAD|GOOD)\s*\(\s*[^)]*\s*\) # $PDLSTATEISBAD(a) etc
1226             |\$[a-zA-Z_]\w*\s*\([^)]*\) # $a(...): access
1227             |\bloop\s*\([^)]+\)\s*%\{ # loop(..) %{
1228             |\btypes\s*\([^)]+\)\s*%\{ # types(..) %{
1229             |\bthreadloop\s*%\{ # threadloop %{
1230             |%} # %}
1231             |$)//xs
1232             or confess("Invalid program $_");
1233             my $control = $2;
1234             # Store the user code.
1235             # Some day we shall parse everything.
1236             push @{$stack[-1]},$1;
1237              
1238             if ( $control =~ /^\$STATE/ ) { print "\nDBG: - got [$control]\n\n"; }
1239              
1240             # Then, our control.
1241             if($control) {
1242             if($control =~ /^loop\s*\(([^)]+)\)\s*%\{/) {
1243             my $ob = new PDL::PP::Loop([split ',',$1],
1244             $sizeprivs,$this);
1245             print "SIZEPRIVSXX: $sizeprivs,",(join ',',%$sizeprivs),"\n" if $::PP_VERBOSE;
1246             push @{$stack[-1]},$ob;
1247             push @stack,$ob;
1248             } elsif($control =~ /^types\s*\(([^)]+)\)\s*%\{/) {
1249             my $ob = new PDL::PP::Types($1,$this);
1250             push @{$stack[-1]},$ob;
1251             push @stack,$ob;
1252             } elsif($control =~ /^threadloop\s*%\{/) {
1253             my $ob = new PDL::PP::ThreadLoop();
1254             push @{$stack[-1]},$ob;
1255             push @stack,$ob;
1256             $threadloops ++;
1257             } elsif($control =~ /^\$PP(ISBAD|ISGOOD|SETBAD)\s*\(\s*([a-zA-Z_]\w*)\s*,\s*([^)]*)\s*\)/) {
1258             push @{$stack[-1]},new PDL::PP::PPBadAccess($1,$2,$3,$this);
1259             } elsif($control =~ /^\$(ISBAD|ISGOOD|SETBAD)VAR\s*\(\s*([^)]*)\s*,\s*([^)]*)\s*\)/) {
1260             push @{$stack[-1]},new PDL::PP::BadVarAccess($1,$2,$3,$this);
1261             } elsif($control =~ /^\$(ISBAD|ISGOOD|SETBAD)\s*\(\s*\$?([a-zA-Z_]\w*)\s*\(([^)]*)\)\s*\)/) {
1262             push @{$stack[-1]},new PDL::PP::BadAccess($1,$2,$3,$this);
1263             # } elsif($control =~ /^\$STATE(IS|SET)(BAD|GOOD)\s*\(\s*([^)]*)\s*\)/) {
1264             # push @{$stack[-1]},new PDL::PP::StateBadAccess($1,$2,$3,$this);
1265             } elsif($control =~ /^\$PDLSTATE(IS|SET)(BAD|GOOD)\s*\(\s*([^)]*)\s*\)/) {
1266             push @{$stack[-1]},new PDL::PP::PDLStateBadAccess($1,$2,$3,$this);
1267             } elsif($control =~ /^\$[a-zA-Z_]\w*\s*\([^)]*\)/) {
1268             push @{$stack[-1]},new PDL::PP::Access($control,$this);
1269             } elsif($control =~ /^%}/) {
1270             pop @stack;
1271             } else {
1272             confess("Invalid control: $control\n");
1273             }
1274             } else {
1275             print("No \$2!\n") if $::PP_VERBOSE;
1276             }
1277             } # while: $_
1278              
1279             return ( $threadloops, $coderef, $sizeprivs );
1280              
1281             } # sub: separate_code()
1282              
1283             # This is essentially a collection of regexes that look for standard code
1284             # errors and croaks with an explanation if they are found.
1285             sub catch_code_errors {
1286             my $code_string = shift;
1287              
1288             # Look for constructs like
1289             # loop %{
1290             # which is invalid - you need to specify the dimension over which it
1291             # should loop
1292             report_error('Expected dimension name after "loop" and before "%{"', $1)
1293             if $code_string =~ /(.*\bloop\s*%\{)/s;
1294              
1295             }
1296              
1297             # Report an error as precisely as possible. If they have #line directives
1298             # in the code string, use that in the reporting; otherwise, use standard
1299             # Carp mechanisms
1300             my $line_re = qr/#\s*line\s+(\d+)\s+"([^"]*)"/;
1301             sub report_error {
1302             my ($message, $code) = @_;
1303              
1304             # Just croak if they didn't supply a #line directive:
1305             croak($message) if $code !~ $line_re;
1306              
1307             # Find the line at which the error occurred:
1308             my $line = 0;
1309             my $filename;
1310             LINE: foreach (split /\n/, $code) {
1311             $line++;
1312             if (/$line_re/) {
1313             $line = $1;
1314             $filename = $2;
1315             }
1316             }
1317              
1318             die "$message at $filename line $line\n";
1319             }
1320              
1321             # return true
1322             1;