"Fossies" - the Fresh Open Source Software Archive

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


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

    1 # 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 
    9 use strict;
   10 use warnings;
   11 use Carp;
   12 
   13 sub get_pdls {my($this) = @_; return ($this->{ParNames},$this->{ParObjs});}
   14 
   15 my @code_args_always = qw(BadFlag SignatureObj GenericTypes ExtraGenericSwitches HaveBroadcasting Name);
   16 sub make_args {
   17   my ($target) = @_;
   18   ("${target}CodeParsed", ["${target}CodeUnparsed",\"Bad${target}CodeUnparsed",@code_args_always]);
   19 }
   20 
   21 # Do the appropriate substitutions in the code.
   22 sub new {
   23     my($class,$code,$badcode,
   24        $handlebad, $sig,$generictypes,$extrageneric,$havebroadcasting,$name,
   25        $dont_add_brcloop, $backcode, $nulldatacheck) = @_;
   26     my $parnames = $sig->names_sorted;
   27 
   28     die "Error: missing name argument to PDL::PP::Code->new call!\n"
   29       unless defined $name;
   30     confess "Error: empty or undefined GenericTypes!\n"
   31       unless @{$generictypes || []};
   32 
   33     $badcode //= $code if $handlebad;
   34 
   35     # last two arguments may not be supplied
   36     #
   37     # "backcode" is a flag to the PDL::PP::Broadcastloop class indicating the broadcastloop
   38     #   is for writeback code (typically used for writeback of data from child to parent PDL
   39 
   40     $dont_add_brcloop ||= !$havebroadcasting; # two have identical (though inverted) meaning so only track one
   41 
   42     # C++ style comments
   43     #
   44     # This regexp isn't perfect because it doesn't cope with
   45     # literal string constants.
   46     #
   47     $code =~ s,//.*?\n,,g;
   48 
   49     if ($::PP_VERBOSE) {
   50     print "Processing code for $name\n";
   51     print "DONT_ADD_BRCLOOP!\n" if $dont_add_brcloop;
   52     print "EXTRAGEN: {" .
   53       join(" ",
   54            map "$_=>$$extrageneric{$_}", sort keys %$extrageneric)
   55         . "}\n";
   56     print "ParNAMES: ",(join ',',@$parnames),"\n";
   57     print "GENTYPES: ", @$generictypes, "\n";
   58     print "HandleBad: $handlebad\n";
   59     }
   60     my $this = bless {
   61     IndObjs => $sig->dims_obj,
   62     ParNames => $parnames,
   63     ParObjs => $sig->objs,
   64     Sig => $sig,
   65     Gencurtype => [], # stack to hold GenType in generic loops
   66     ftypes_vars => {},
   67     ftypes_type => undef,
   68         Generictypes => $generictypes,   # so that MacroAccess can check it
   69         Name => $name,
   70         NullDataCheck => $nulldatacheck,
   71     }, $class;
   72 
   73     # First, separate the code into an array of C fragments (strings),
   74     # variable references (strings starting with $) and
   75     # loops (array references, 1. item = variable.
   76     #
   77     my ( $broadcastloops, $coderef, $sizeprivs ) =
   78     $this->separate_code( "{\n$code\n}" );
   79 
   80     # Now, if there is no explicit broadcastlooping in the code,
   81     # enclose everything into it.
   82     if(!$broadcastloops && !$dont_add_brcloop) {
   83     print "Adding broadcastloop...\n" if $::PP_VERBOSE;
   84     my $nc = $coderef;
   85     $coderef = $backcode
   86       ? PDL::PP::BackCodeBroadcastLoop->new() : PDL::PP::BroadcastLoop->new();
   87     push @{$coderef},$nc;
   88     }
   89 
   90     # repeat for the bad code, then stick good and bad into
   91     # a BadSwitch object which creates the necessary
   92     # 'if (bad) { badcode } else { goodcode }' code
   93     #
   94     # NOTE: amalgamate sizeprivs from good and bad code
   95     #
   96     if ( $handlebad && ($code ne $badcode || $badcode =~ /PDL_BAD_CODE|PDL_IF_BAD/) ) {
   97     print "Processing 'bad' code...\n" if $::PP_VERBOSE;
   98     my ( $bad_broadcastloops, $bad_coderef, $bad_sizeprivs ) =
   99         $this->separate_code( "{\n$badcode\n}" );
  100 
  101     if(!$bad_broadcastloops && !$dont_add_brcloop) {
  102         print "Adding 'bad' broadcastloop...\n" if $::PP_VERBOSE;
  103         my $nc = $bad_coderef;
  104         if( !$backcode ){ # Normal readbackdata broadcastloop
  105             $bad_coderef = PDL::PP::BroadcastLoop->new();
  106         }
  107         else{  # writebackcode broadcastloop
  108             $bad_coderef = PDL::PP::BackCodeBroadcastLoop->new();
  109         }
  110         push @{$bad_coderef},$nc;
  111     }
  112 
  113     my $good_coderef = $coderef;
  114     $coderef = PDL::PP::BadSwitch->new( $good_coderef, $bad_coderef );
  115 
  116     # amalgamate sizeprivs from Code/BadCode segments
  117     # (sizeprivs is a simple hash, with each element
  118     # containing a string - see PDL::PP::Loop)
  119     while ( my ( $bad_key, $bad_str ) = each %$bad_sizeprivs ) {
  120         my $str = $$sizeprivs{$bad_key};
  121         die "ERROR: sizeprivs problem in PP/PDLCode.pm (BadVal stuff)\n"
  122         if defined $str and $str ne $bad_str;
  123         $$sizeprivs{$bad_key} = $bad_str;  # copy over
  124     }
  125 
  126     } # if: $handlebad
  127 
  128     print "SIZEPRIVSX: ",(join ',',%$sizeprivs),"\n" if $::PP_VERBOSE;
  129 
  130     # Enclose it all in a genericloop.
  131     my $nc = $coderef;
  132     $coderef = PDL::PP::GenericSwitch->new($generictypes, undef,
  133       [grep {!$extrageneric->{$_}} @$parnames],'$PRIV(__datatype)');
  134     push @{$coderef},$nc;
  135 
  136     # Do we have extra generic loops?
  137     # If we do, first reverse the hash:
  138     my %glh;
  139     for(sort keys %$extrageneric) {
  140     push @{$glh{$extrageneric->{$_}}},$_;
  141     }
  142     my $no = 0;
  143     for(sort keys %glh) {
  144     my $nc = $coderef;
  145     $coderef = PDL::PP::GenericSwitch->new($generictypes,$no++,
  146                         $glh{$_},$_);
  147     push @$coderef,$nc;
  148     }
  149 
  150     my $pobjs = $sig->objs;
  151     # Then, in this form, put it together what we want the code to actually do.
  152     print "SIZEPRIVS: ",(join ',',%$sizeprivs),"\n" if $::PP_VERBOSE;
  153     $this->{Code} = (join '',sort values %$sizeprivs).
  154        ($dont_add_brcloop?'':PDL::PP::pp_line_numbers __LINE__, join "\n",
  155         'PDL_COMMENT("broadcastloop declarations")',
  156         'int __brcloopval;',
  157         'register PDL_Indx __tind0,__tind1; PDL_COMMENT("counters along dim")',
  158         'register PDL_Indx __tnpdls = $PRIV(broadcast).npdls;',
  159         'PDL_COMMENT("dims here are how many steps along those dims")',
  160         (map "register PDL_Indx __tinc0_$parnames->[$_] = PDL_BRC_INC(\$PRIV(broadcast).incs,__tnpdls,$_,0);", 0..$#$parnames),
  161         (map "register PDL_Indx __tinc1_$parnames->[$_] = PDL_BRC_INC(\$PRIV(broadcast).incs,__tnpdls,$_,1);", 0..$#$parnames),
  162        ).
  163        $this->params_declare.
  164        join('',map $_->get_incregisters, @$pobjs{sort keys %$pobjs}).
  165        $coderef->get_str($this,[])
  166        ;
  167     $this->{Code};
  168 
  169 } # new()
  170 
  171 sub params_declare {
  172     my ($this) = @_;
  173     my ($ord,$pdls) = $this->get_pdls;
  174     my @decls = map $_->get_xsdatapdecl("PDL_PARAMTYPE_".$_->name, $this->{NullDataCheck}),
  175       map $pdls->{$_}, @$ord;
  176     my @param_names = map "PDL_PARAMTYPE_$_", @$ord;
  177     PDL::PP::pp_line_numbers(__LINE__, <<EOF);
  178 #ifndef PDL_DECLARE_PARAMS_$this->{Name}_$this->{NullDataCheck}
  179 #define PDL_DECLARE_PARAMS_$this->{Name}_$this->{NullDataCheck}(@{[join ',', @param_names]}) \\
  180   @{[join " \\\n", @decls]}
  181 #endif
  182 EOF
  183 }
  184 
  185 sub func_name { $_[1] ? "writebackdata" : "readdata" }
  186 
  187 sub broadcastloop_start {
  188     my ($this, $funcname) = @_;
  189     my ($ord,$pdls) = $this->get_pdls;
  190     <<EOF;
  191 PDL_BROADCASTLOOP_START(
  192 $funcname,
  193 \$PRIV(broadcast),
  194 \$PRIV(vtable),
  195 @{[ join "", map "\t".$pdls->{$ord->[$_]}->do_pointeraccess." += __offsp[$_];\n", 0..$#$ord ]},
  196 (@{[ join "", map "\t,".$pdls->{$ord->[$_]}->do_pointeraccess." += __tinc1_$ord->[$_] - __tinc0_$ord->[$_] * __tdims0\n", 0..$#$ord ]}),
  197 (@{[ join "", map "\t,".$pdls->{$ord->[$_]}->do_pointeraccess." += __tinc0_$ord->[$_]\n", 0..$#{$ord} ]})
  198 )
  199 EOF
  200 }
  201 
  202 sub broadcastloop_end {
  203     my ($this) = @_;
  204     my ($ord,$pdls) = $this->get_pdls();
  205     <<EOF;
  206 PDL_BROADCASTLOOP_END(
  207 \$PRIV(broadcast),
  208 @{[ join "", map $pdls->{$ord->[$_]}->do_pointeraccess." -= __tinc1_$ord->[$_] * __tdims1 + __offsp[$_];\n", 0..$#$ord ]}
  209 )
  210 EOF
  211 }
  212 
  213 sub sig {$_[0]->{Sig}}
  214 
  215 # This sub determines the index name for this index.
  216 # For example, a(x,y) and x0 becomes [x,x0]
  217 sub make_loopind { my($this,$ind) = @_;
  218     my $orig = $ind;
  219     while(!$this->{IndObjs}{$ind}) {
  220         if(!((chop $ind) =~ /[0-9]/)) {
  221             confess("Index not found for $_ ($ind)!\n");
  222         }
  223         }
  224     return [$ind,$orig];
  225 }
  226 
  227 my %access2class = (
  228   GENERIC => 'PDL::PP::GentypeAccess',
  229   PPSYM => 'PDL::PP::PpsymAccess',
  230 );
  231 
  232 sub process {
  233     my ($this, $code, $stack_ref, $broadcastloops_ref, $sizeprivs) = @_;
  234     while($code) {
  235     # Parse next statement
  236     $code =~ s/^(.*?) # First, some noise is allowed. This may be bad.
  237         ( \$(ISBAD|ISGOOD|SETBAD)\s*\(\s*\$?[a-zA-Z_]\w*\s*\([^)]*\)\s*\)   # $ISBAD($a(..)), ditto for ISGOOD and SETBAD
  238             |\$[a-zA-Z_]\w*\s*\([^)]*\)  # $a(...): access
  239         |\bloop\s*\([^)]+\)\s*%\{   # loop(..) %{
  240         |\btypes\s*\([^)]+\)\s*%\{  # types(..) %{
  241         |\b(?:thread|broadcast)loop\s*%\{         # broadcastloop %{
  242         |%}                        # %}
  243         |$)//xs
  244             or confess("Invalid program $code");
  245     my $control = $2;
  246     # Store the user code.
  247     # Some day we shall parse everything.
  248     push @{$stack_ref->[-1]},$1;
  249     # Then, our control.
  250     if (!$control) { print("No \$2!\n") if $::PP_VERBOSE; next; }
  251     if($control =~ /^loop\s*\(([^)]+)\)\s*%\{/) {
  252         my $ob = PDL::PP::Loop->new([split ',',$1], $sizeprivs,$this);
  253         print "SIZEPRIVSXX: $sizeprivs,",(join ',',%$sizeprivs),"\n" if $::PP_VERBOSE;
  254         push @{$stack_ref->[-1]},$ob;
  255         push @$stack_ref,$ob;
  256     } elsif($control =~ /^types\s*\(([^)]+)\)\s*%\{/) {
  257         my $ob = PDL::PP::Types->new($1,$this);
  258         push @{$stack_ref->[-1]},$ob;
  259         push @$stack_ref,$ob;
  260     } elsif($control =~ /^(?:thread|broadcast)loop\s*%\{/) {
  261         my $ob = PDL::PP::BroadcastLoop->new;
  262         push @{$stack_ref->[-1]},$ob;
  263         push @$stack_ref,$ob;
  264         $$broadcastloops_ref++;
  265     } elsif($control =~ /^%}/) {
  266         pop @$stack_ref;
  267     } else {
  268         my ($rest, @add) = $this->expand($control.$code);
  269         push @{$stack_ref->[-1]}, @add;
  270         $code = $rest;
  271     }
  272     } # while: $code
  273 }
  274 
  275 # my ( $broadcastloops, $coderef, $sizeprivs ) = $this->separate_code( $code );
  276 #
  277 # separates the code into an array of C fragments (strings),
  278 # variable references (strings starting with $) and
  279 # loops (array references, 1. item = variable.
  280 #
  281 sub separate_code {
  282     my ( $this, $code ) = @_;
  283     # First check for standard code errors:
  284     catch_code_errors($code);
  285     my @stack = my $coderef = PDL::PP::Block->new;
  286     my $broadcastloops = 0;
  287     my $sizeprivs = {};
  288     $this->process($code, \@stack, \$broadcastloops, $sizeprivs);
  289     ( $broadcastloops, $coderef, $sizeprivs );
  290 } # sub: separate_code()
  291 
  292 my $macro_pat = qr/\w+/;
  293 sub expand {
  294     my ($this, $text) = @_;
  295     my (undef, $pdl, $inds, $rest) = PDL::PP::Rule::Substitute::macro_extract($text, $macro_pat);
  296     my @add;
  297     if($pdl =~ /^T/) {@add = PDL::PP::MacroAccess->new($pdl,$inds,
  298                $this->{Generictypes},$this->{Name});}
  299     elsif(my $c = $access2class{$pdl}) {@add = $c->new($pdl,$inds)}
  300     elsif($pdl =~ /^(PP|)(ISBAD|ISGOOD|SETBAD)(VAR|)$/) {
  301     my ($opcode, $name) = ($2);
  302     my $get = $1 || $3;
  303     if (!$get) {
  304         $inds =~ s/^\$?([a-zA-Z_]\w*)\s*//; # $ is optional
  305         $name = $1;
  306         $inds = substr $inds, 1, -1; # chop off brackets
  307     } elsif ($get eq 'PP') {
  308         ($name, $inds) = PDL::PP::Rule::Substitute::split_cpp($inds);
  309     } else {
  310         ($inds, $name) = PDL::PP::Rule::Substitute::split_cpp($inds);
  311     }
  312     @add = PDL::PP::BadAccess->new($opcode,$get,$name,$inds,$this);
  313     }
  314     elsif($this->{ParObjs}{$pdl}) {@add = PDL::PP::Access->new($pdl,$inds)}
  315     else {
  316     confess "unknown construct $pdl($inds)";
  317     }
  318     ($rest, @add);
  319 }
  320 
  321 # This is essentially a collection of regexes that look for standard code
  322 # errors and croaks with an explanation if they are found.
  323 sub catch_code_errors {
  324     my $code_string = shift;
  325     # Look for constructs like
  326     #   loop %{
  327     # which is invalid - you need to specify the dimension over which it
  328     # should loop
  329     report_error('Expected dimension name after "loop" and before "%{"', $1)
  330         if $code_string =~ /(.*\bloop\s*%\{)/s;
  331 }
  332 
  333 # Report an error as precisely as possible. If they have #line directives
  334 # in the code string, use that in the reporting; otherwise, use standard
  335 # Carp mechanisms
  336 my $line_re = qr/#\s*line\s+(\d+)\s+"([^"]*)"/;
  337 sub report_error {
  338     my ($message, $code) = @_;
  339     # Just croak if they didn't supply a #line directive:
  340     confess($message) if $code !~ $line_re;
  341     # Find the line at which the error occurred:
  342     my $line = 0;
  343     my $filename;
  344     LINE: foreach (split /\n/, $code) {
  345         $line++;
  346         if (/$line_re/) {
  347             $line = $1;
  348             $filename = $2;
  349         }
  350     }
  351     die "$message at $filename line $line\n";
  352 }
  353 
  354 #####################################################################
  355 #
  356 # Encapsulate the parsing code objects
  357 #
  358 # All objects have two methods:
  359 #   new - constructor
  360 #   get_str - get the string to be put into the xsub.
  361 
  362 package PDL::PP::Block;
  363 
  364 sub new { my($type) = @_; bless [],$type; }
  365 
  366 sub myoffs { 0 }
  367 sub myprelude {}
  368 sub mypostlude {}
  369 
  370 sub get_str {
  371     my ($this,$parent,$context) = @_;
  372     my $str = $this->myprelude($parent,$context);
  373     $str .= $this->get_str_int($parent,$context)//'';
  374     $str .= $this->mypostlude($parent,$context)//'';
  375     return $str;
  376 }
  377 
  378 sub get_str_int {
  379   my ( $this, $parent, $context ) = @_;
  380   my $nth=0;
  381   my $str = "";
  382   MYLOOP: while(1) {
  383     my $it = $this->can('myitemstart') && $this->myitemstart($parent,$nth);
  384     last MYLOOP if $nth and !$it;
  385     $str .= $it//'';
  386     $str .= join '', $this->get_contained($parent,$context);
  387     $str .= $it if $it = $this->can('myitemend') && $this->myitemend($parent,$nth);
  388     $nth++;
  389   }
  390   return $str;
  391 } # get_str_int()
  392 
  393 sub get_contained {
  394   my ($this, $parent, $context) = @_;
  395   map ref($_) ? $_->get_str($parent, $context) : $_,
  396     @$this[$this->myoffs..$#$this];
  397 }
  398 
  399 ###########################
  400 #
  401 # Deal with bad code
  402 # - ie create something like
  403 #   if ( badflag ) { badcode } else { goodcode }
  404 #
  405 package PDL::PP::BadSwitch;
  406 our @ISA = "PDL::PP::Block";
  407 
  408 sub new {
  409     my($type,$good,$bad) = @_;
  410     return bless [$good,$bad], $type;
  411 }
  412 
  413 sub get_str {
  414     my ($this,$parent,$context) = @_;
  415     my $good = $this->[0];
  416     my $bad  = $this->[1];
  417     my $str = PDL::PP::pp_line_numbers(__LINE__, <<EOF);
  418 if ( \$PRIV(bvalflag) ) { PDL_COMMENT("** do 'bad' Code **")
  419 #define PDL_BAD_CODE
  420 #define PDL_IF_BAD(t,f) t
  421   @{[ $bad->get_str($parent,$context) ]}
  422 #undef PDL_BAD_CODE
  423 #undef PDL_IF_BAD
  424 } else { PDL_COMMENT("** else do 'good' Code **")
  425 #define PDL_IF_BAD(t,f) f
  426   @{[ $good->get_str($parent,$context) ]}
  427 #undef PDL_IF_BAD
  428 }
  429 EOF
  430 }
  431 
  432 package PDL::PP::Loop;
  433 our @ISA = "PDL::PP::Block";
  434 
  435 sub new { my($type,$args,$sizeprivs,$parent) = @_;
  436     my $this = bless [$args],$type;
  437     for(@{$this->[0]}) {
  438         print "SIZP $sizeprivs, $_\n" if $::PP_VERBOSE;
  439         my $i = $parent->make_loopind($_);
  440         my $i_size = $parent->sig->ind_obj($i->[0])->get_size;
  441         $sizeprivs->{$i->[0]} =
  442           "register PDL_Indx __$i->[0]_size = $i_size;\n";
  443         print "SP :",(join ',',%$sizeprivs),"\n" if $::PP_VERBOSE;
  444     }
  445     return $this;
  446 }
  447 
  448 sub myoffs { return 1; }
  449 sub myprelude { my($this,$parent,$context) = @_;
  450     my $text = "";
  451     push @$context, map {
  452         my $i = $parent->make_loopind($_);
  453 # Used to be $PRIV(.._size) but now we have it in a register.
  454         $text .= PDL::PP::pp_line_numbers(__LINE__, <<EOF);
  455 {PDL_COMMENT(\"Open $_\") register PDL_Indx $_;
  456 for($_=0; $_<(__$i->[0]_size); $_++) {
  457 EOF
  458         $i;
  459     } @{$this->[0]};
  460     $text;
  461 }
  462 sub mypostlude { my($this,$parent,$context) = @_;
  463     splice @$context, - ($#{$this->[0]}+1);
  464     return join '', map PDL::PP::pp_line_numbers(__LINE__-1, "}} PDL_COMMENT(\"Close $_\")"), @{$this->[0]};
  465 }
  466 
  467 package PDL::PP::GenericSwitch;
  468 our @ISA = "PDL::PP::Block";
  469 
  470 # make the typetable from info in PDL::Types
  471 use PDL::Types ':All';
  472 my @typetable = map [$_->ppsym, $_], types();
  473 sub get_generictyperecs { my($types) = @_;
  474     my %wanted; @wanted{@$types} = ();
  475     [ map $_->[1], grep exists $wanted{$_->[0]}, @typetable ];
  476 }
  477 
  478 # Types: BSULFD
  479 sub new {
  480     my ($type,$types,$name,$varnames,$whattype) = @_;
  481     my %vars; @vars{@$varnames} = ();
  482     bless [get_generictyperecs($types), $name, \%vars, $whattype], $type;
  483 }
  484 
  485 sub myoffs {4}
  486 
  487 sub myprelude {
  488     my ($this,$parent,$context) = @_;
  489     push @{$parent->{Gencurtype}}, undef; # so that $GENERIC can get at it
  490     die "ERROR: need to rethink NaN support in GenericSwitch\n"
  491     if defined $this->[1] and $parent->{ftypes_type};
  492     qq[PDL_COMMENT("Start generic loop")\n\tswitch($this->[3]) {\n];
  493 }
  494 
  495 my @GENTYPE_ATTRS = qw(integer real unsigned);
  496 sub myitemstart {
  497     my ($this,$parent,$nth) = @_;
  498     my $item = $this->[0][$nth] || return "";
  499     $parent->{Gencurtype}[-1] = $item;
  500     @$parent{qw(ftypes_type ftypes_vars)} = ($item, $this->[2]) if defined $this->[1];
  501     my ($ord,$pdls) = $parent->get_pdls;
  502     my @param_ctypes = map $pdls->{$_}->adjusted_type($item)->ctype, @$ord;
  503     my $decls = keys %{$this->[2]} == @$ord
  504       ? PDL::PP::pp_line_numbers(__LINE__-1, "\t\tPDL_DECLARE_PARAMS_$parent->{Name}_$parent->{NullDataCheck}(@{[join ',', @param_ctypes]})\n")
  505       : join '', map $_->get_xsdatapdecl($_->adjusted_type($item)->ctype, $parent->{NullDataCheck}),
  506           map $parent->{ParObjs}{$_}, sort keys %{$this->[2]};
  507     my @gentype_decls = map "#define PDL_IF_GENTYPE_".uc($_)."(t,f) ".
  508     ($item->$_ ? 't' : 'f')."\n",
  509     @GENTYPE_ATTRS;
  510     join '',
  511     PDL::PP::pp_line_numbers(__LINE__-1, "case @{[$item->sym]}: {\n"),
  512     @gentype_decls,
  513     $decls;
  514 }
  515 
  516 sub myitemend {
  517     my ($this,$parent,$nth) = @_;
  518     my $item = $this->[0][$nth] || return "";
  519     join '',
  520     "\n",
  521     (map "#undef PDL_IF_GENTYPE_".uc($_)."\n", @GENTYPE_ATTRS),
  522     PDL::PP::pp_line_numbers(__LINE__-1, "} break;\n");
  523 }
  524 
  525 sub mypostlude {
  526     my($this,$parent,$context) = @_;
  527     pop @{$parent->{Gencurtype}};  # and clean up the Gentype stack
  528     $parent->{ftypes_type} = undef if defined $this->[1];
  529     my $supported = join '', map $_->ppsym, @{$this->[0]};
  530     "\n\tdefault:return PDL->make_error(PDL_EUSERERROR, \"PP INTERNAL ERROR in $parent->{Name}: unhandled datatype(%d), only handles ($supported)! PLEASE MAKE A BUG REPORT\\n\", $this->[3]);}\n";
  531 }
  532 
  533 ####
  534 #
  535 # This relies on PP.pm making sure that initbroadcaststruct always sets
  536 # up the two first dimensions even when they are not necessary.
  537 #
  538 package PDL::PP::BroadcastLoop;
  539 use Carp;
  540 our @ISA = "PDL::PP::Block";
  541 
  542 sub new {
  543     my $type   = shift;
  544     bless [],$type;
  545 }
  546 sub myoffs { return 0; }
  547 sub myprelude {
  548     my($this,$parent,$context, $backcode) = @_;
  549     $parent->broadcastloop_start($parent->func_name($backcode));
  550 }
  551 
  552 sub mypostlude {my($this,$parent,$context) = @_;
  553     $parent->broadcastloop_end;
  554 }
  555 
  556 # Simple subclass of BroadcastLoop to implement writeback code
  557 #
  558 #
  559 package PDL::PP::BackCodeBroadcastLoop;
  560 use Carp;
  561 our @ISA = "PDL::PP::BroadcastLoop";
  562 
  563 sub myprelude {
  564     my($this,$parent,$context, $backcode) = @_;
  565 
  566     # Set backcode flag if not defined. This will make the parent
  567     #   myprelude emit proper writeback code
  568     $backcode = 1 unless defined($backcode);
  569 
  570     $this->SUPER::myprelude($parent, $context, $backcode);
  571 }
  572 
  573 
  574 ###########################
  575 #
  576 # Encapsulate a types() switch
  577 #
  578 package PDL::PP::Types;
  579 use Carp;
  580 use PDL::Types ':All';
  581 our @ISA = "PDL::PP::Block";
  582 my %types = map +($_=>1), ppdefs_all; # BSUL....
  583 
  584 sub new {
  585     my($type,$ts,$parent) = @_;
  586     my @bad = grep !$types{$_}, my @ts = split '', $ts;
  587     confess "Invalid type access (@bad) in '$ts'!" if @bad;
  588     bless [+{map +($_=>1), @ts}],$type; }
  589 sub myoffs { return 1; }
  590 
  591 sub get_str {
  592   my ($this,$parent,$context) = @_;
  593   confess "types() outside a generic loop"
  594     unless defined(my $type = $parent->{Gencurtype}[-1]);
  595   return '' if !$this->[0]{$type->ppsym};
  596   join '', $this->get_contained($parent,$context);
  597 }
  598 
  599 
  600 package PDL::PP::Access;
  601 use Carp;
  602 
  603 sub new { my($type,$pdl,$inds) = @_;
  604     bless [$pdl,$inds],$type;
  605 }
  606 
  607 sub get_str { my($this,$parent,$context) = @_;
  608     $parent->{ParObjs}{$this->[0]}->do_access($this->[1],$context)
  609     if defined($parent->{ParObjs}{$this->[0]});
  610 }
  611 
  612 ###########################
  613 # Encapsulate a check on whether a value is good or bad
  614 # handles both checking (good/bad) and setting (bad)
  615 package PDL::PP::BadAccess;
  616 use Carp;
  617 
  618 sub new {
  619     my ( $type, $opcode, $get, $name, $inds, $parent ) = @_;
  620     die "\nIt looks like you have tried a $get \$${opcode}() macro on an" .
  621     " unknown ndarray <$name($inds)>\n"
  622     unless defined($parent->{ParObjs}{$name});
  623     bless [$opcode, $get, $name, $inds], $type;
  624 }
  625 
  626 sub _isbad { "PDL_ISBAD($_[0],$_[1],$_[2])" }
  627 our %ops = (
  628     ISBAD => \&_isbad,
  629     ISGOOD => sub {'!'.&_isbad},
  630     SETBAD => sub{join '=', @_[0,1]},
  631 );
  632 my %getters = (
  633     '' => sub {my ($obj, $inds, $context)=@_; $obj->do_access($inds,$context)},
  634     PP => sub {my ($obj, $inds)=@_; $obj->do_physpointeraccess.$inds},
  635     VAR => sub {my ($obj, $inds)=@_; $inds},
  636 );
  637 
  638 sub get_str {
  639     my ($this,$parent,$context) = @_;
  640     my ($opcode, $get, $name, $inds) = @$this;
  641     confess "generic type access outside a generic loop in $name"
  642       unless defined $parent->{Gencurtype}[-1];
  643     print "PDL::PP::BadAccess sent [$opcode] [$name] [$inds]\n" if $::PP_VERBOSE;
  644     die "ERROR: unknown check <$opcode> sent to PDL::PP::BadAccess\n"
  645     unless defined( my $op = $ops{$opcode} );
  646     die "ERROR: something screwy in PDL::PP::BadAccess (PP/PDLCode.pm)\n"
  647     unless defined( my $obj = $parent->{ParObjs}{$name} );
  648     my $lhs = $getters{$get}->($obj, $inds, $context);
  649     my $rhs = "${name}_badval";
  650     print "DBG:  [$lhs $op $rhs]\n" if $::PP_VERBOSE;
  651     my $type = exists $parent->{ftypes_vars}{$name}
  652     ? $parent->{ftypes_type}
  653     : $obj->adjusted_type($parent->{Gencurtype}[-1]);
  654     $op->($lhs, $rhs, $type->ppsym);
  655 }
  656 
  657 
  658 package PDL::PP::MacroAccess;
  659 use Carp;
  660 use PDL::Types ':All';
  661 my $types = join '',ppdefs_all;
  662 
  663 sub new {
  664     my ($type, $pdl, $inds, $gentypes, $name) = @_;
  665     $pdl =~ /^\s*T([A-Z]+)\s*$/
  666       or confess("Macroaccess wrong in $name (allowed types $types): was '$pdl'\n");
  667     my @ilst = split '', $1;
  668     my @lst = PDL::PP::Rule::Substitute::split_cpp($inds);
  669     confess "Macroaccess: different nos of args $pdl (@{[scalar @lst]}=@lst) vs (@{[scalar @ilst]}=@ilst)\n" if @lst != @ilst;
  670     my %type2value; @type2value{@ilst} = @lst;
  671     confess "$name has no Macro for generic type $_ (has $pdl)\n"
  672     for grep !exists $type2value{$_}, @$gentypes;
  673     my %gts; @gts{@$gentypes} = ();
  674     warn "Macro for unsupported generic type identifier $_\n"
  675     for grep !exists $gts{$_}, @ilst;
  676     bless [\%type2value, $name], $type;
  677 }
  678 
  679 sub get_str {
  680     my ($this, $parent, $context) = @_;
  681     my ($type2value, $name) = @{$this};
  682     confess "generic type access outside a generic loop in $name"
  683       unless defined $parent->{Gencurtype}[-1];
  684     $type2value->{$parent->{Gencurtype}[-1]->ppsym};
  685 }
  686 
  687 package PDL::PP::GentypeAccess;
  688 use Carp;
  689 
  690 sub new { my($type,$pdl,$inds) = @_; bless [$inds],$type; }
  691 
  692 sub get_str {my($this,$parent,$context) = @_;
  693   confess "generic type access outside a generic loop"
  694     unless defined(my $type = $parent->{Gencurtype}[-1]);
  695   return $type->ctype if !$this->[0];
  696   my $pobj = $parent->{ParObjs}{$this->[0]} // confess "not a defined parname";
  697   $pobj->adjusted_type($type)->ctype;
  698 }
  699 
  700 package PDL::PP::PpsymAccess;
  701 use Carp;
  702 
  703 sub new { my($type,$pdl,$inds) = @_; bless [$inds],$type; }
  704 
  705 sub get_str {my($this,$parent,$context) = @_;
  706   confess "generic type access outside a generic loop"
  707     unless defined(my $type = $parent->{Gencurtype}[-1]);
  708   return $type->ppsym if !$this->[0];
  709   my $pobj = $parent->{ParObjs}{$this->[0]} // confess "not a defined parname";
  710   $pobj->adjusted_type($type)->ctype;
  711 }
  712 
  713 1;