# This file provides a class that parses the Code -member
# of the PDL::PP code.
#
# This is what makes the nice loops go around etc.
#
package PDL::PP::Code;
use Carp;
our @CARP_NOT;
use strict;
# check for bad value support
#
use PDL::Config;
#use vars qw ( $bvalflag $usenan );
my $bvalflag = $PDL::Config{WITH_BADVAL} || 0;
my $usenan   = $PDL::Config{BADVAL_USENAN} || 0;
sub get_pdls {my($this) = @_; return ($this->{ParNames},$this->{ParObjs});}
# we define the method separate_code() at the end of this
# file, so that it can call the constructors from the classes
# defined in this file. ugly...
# Do the appropriate substitutions in the code.
sub new {
    my($type,$code,$badcode,$parnames,$parobjs,$indobjs,$generictypes,
       $extrageneric,$havethreading,$name,
       $dont_add_thrloop, $nogeneric_loop, $backcode ) = @_;
    die "Error: missing name argument to PDL::PP::Code->new call!\n"
      unless defined $name;
    # simple way of handling bad code check
    $badcode = undef unless $bvalflag;
    my $handlebad = defined($badcode);
    # last three arguments may not be supplied
    # (in fact, the nogeneric_loop argument may never be supplied now?)
    #
    # "backcode" is a flag to the PDL::PP::Threadloop class indicating thre threadloop
    #   is for writeback code (typically used for writeback of data from child to parent PDL
    $dont_add_thrloop = 0 unless defined $dont_add_thrloop;
    $nogeneric_loop = 0 unless defined $nogeneric_loop;
    # C++ style comments
    #
    # This regexp isn't perfect because it doesn't cope with
    # literal string constants.
    #
    $code =~ s,//.*?\n,,g;
    if ($::PP_VERBOSE) {
        print "Processing code for $name\n";
        print "DONT_ADD_THRLOOP!\n" if $dont_add_thrloop;
        print "EXTRAGEN: {" .
          join(" ",
               map { "$_=>" . $$extrageneric{$_}} keys %$extrageneric)
            . "}\n";
        print "ParNAMES: ",(join ',',@$parnames),"\n";
        print "GENTYPES: ", @$generictypes, "\n";
        print "HandleBad: $handlebad\n";
    }
    my $this = bless {
        IndObjs => $indobjs,
        ParNames => $parnames,
        ParObjs => $parobjs,
        Gencurtype => [], # stack to hold GenType in generic loops
        types => 0,  # hack for PDL::PP::Types/GenericLoop
        pars => {},  # hack for PDL::PP::NaNSupport/GenericLoop
        Generictypes => $generictypes,   # so that MacroAccess can check it
        Name => $name,
    }, $type;
    my $inccode = join '',map {$_->get_incregisters();} (values %{$this->{ParObjs}});
    # First, separate the code into an array of C fragments (strings),
    # variable references (strings starting with $) and
    # loops (array references, 1. item = variable.
    #
    my ( $threadloops, $coderef, $sizeprivs ) =
        $this->separate_code( "{$inccode\n$code\n}" );
    # Now, if there is no explicit threadlooping in the code,
    # enclose everything into it.
    if(!$threadloops && !$dont_add_thrloop && $havethreading) {
        print "Adding threadloop...\n" if $::PP_VERBOSE;
        my $nc = $coderef;
        if( !$backcode ){ # Normal readbackdata threadloop
                $coderef = PDL::PP::ThreadLoop->new();
        }
        else{  # writebackcode threadloop
                $coderef = PDL::PP::BackCodeThreadLoop->new();
        }
        push @{$coderef},$nc;
    }
    # repeat for the bad code, then stick good and bad into
    # a BadSwitch object which creates the necessary
    # 'if (bad) { badcode } else { goodcode }' code
    #
    # NOTE: amalgamate sizeprivs from good and bad code
    #
    if ( $handlebad ) {
        print "Processing 'bad' code...\n" if $::PP_VERBOSE;
        my ( $bad_threadloops, $bad_coderef, $bad_sizeprivs ) =
            $this->separate_code( "{$inccode\n$badcode\n}" );
        if(!$bad_threadloops && !$dont_add_thrloop && $havethreading) {
            print "Adding 'bad' threadloop...\n" if $::PP_VERBOSE;
            my $nc = $bad_coderef;
            if( !$backcode ){ # Normal readbackdata threadloop
                    $bad_coderef = PDL::PP::ThreadLoop->new();
            }
            else{  # writebackcode threadloop
                    $bad_coderef = PDL::PP::BackCodeThreadLoop->new();
            }
            push @{$bad_coderef},$nc;
        }
        my $good_coderef = $coderef;
        $coderef = PDL::PP::BadSwitch->new( $good_coderef, $bad_coderef );
        # amalgamate sizeprivs from Code/BadCode segments
        # (sizeprivs is a simple hash, with each element
        # containing a string - see PDL::PP::Loop)
        while ( my ( $bad_key, $bad_str ) = each %$bad_sizeprivs ) {
            my $str = $$sizeprivs{$bad_key};
            if ( defined $str ) {
                die "ERROR: sizeprivs problem in PP/PDLCode.pm (BadVal stuff)\n"
                    unless $str eq $bad_str;
            }
            $$sizeprivs{$bad_key} = $bad_str;  # copy over
        }
    } # if: $handlebad
    print "SIZEPRIVSX: ",(join ',',%$sizeprivs),"\n" if $::PP_VERBOSE;
    # Enclose it all in a genericloop.
    unless ($nogeneric_loop) {
        # XXX Make genericloop understand denied pointers;...
        my $nc = $coderef;
        $coderef = PDL::PP::GenericLoop->new($generictypes,"",
              [grep {!$extrageneric->{$_}} @$parnames],'$PRIV(__datatype)');
        push @{$coderef},$nc;
    }
    # Do we have extra generic loops?
    # If we do, first reverse the hash:
    my %glh;
    for(keys %$extrageneric) {
        push @{$glh{$extrageneric->{$_}}},$_;
    }
    my $no = 0;
    for(keys %glh) {
        my $nc = $coderef;
        $coderef = PDL::PP::GenericLoop->new($generictypes,$no++,
                                            $glh{$_},$_);
        push @$coderef,$nc;
    }
    # Then, in this form, put it together what we want the code to actually do.
    print "SIZEPRIVS: ",(join ',',%$sizeprivs),"\n" if $::PP_VERBOSE;
    $this->{Code} = "{".(join '',values %$sizeprivs).
       $coderef->get_str($this,[])
       ."}";
    $this->{Code};
} # new()
# This sub determines the index name for this index.
# For example, a(x,y) and x0 becomes [x,x0]
sub make_loopind { my($this,$ind) = @_;
        my $orig = $ind;
        while(!$this->{IndObjs}{$ind}) {
                if(!((chop $ind) =~ /[0-9]/)) {
                        confess("Index not found for $_ ($ind)!\n");
                }
                }
        return [$ind,$orig];
}
#####################################################################
#
# Encapsulate the parsing code objects
#
# All objects have two methods:
#       new - constructor
#       get_str - get the string to be put into the xsub.
###########################
#
# Encapsulate a block
package PDL::PP::Block;
sub new { my($type) = @_; bless [],$type; }
sub myoffs { return 0; }
sub myprelude {}
sub myitem {return "";}
sub mypostlude {}
sub get_str {
    my ($this,$parent,$context) = @_;
    my $str = $this->myprelude($parent,$context);
    $str .= $this->get_str_int($parent,$context);
    $str .= $this->mypostlude($parent,$context);
    return $str;
}
sub get_str_int {
    my ( $this, $parent, $context ) = @_;
    my $nth=0;
    my $str = "";
  MYLOOP: while(1) {
      my $it = $this->myitem($parent,$nth);
      last MYLOOP if $nth and !$it;
      $str .= $it;
      $str .= (join '',map {ref $_ ? $_->get_str($parent,$context) : $_}
               @{$this}[$this->myoffs()..$#{$this}]);
      $nth++;
  }
    return $str;
} # get_str_int()
###########################
#
# Deal with bad code
# - ie create something like
#   if ( badflag ) { badcode } else { goodcode }
#
package PDL::PP::BadSwitch;
@PDL::PP::BadSwitch::ISA = "PDL::PP::Block";
sub new {
    my($type,$good,$bad) = @_;
    return bless [$good,$bad], $type;
}
sub get_str {
    my ($this,$parent,$context) = @_;
    my $good = $this->[0];
    my $bad  = $this->[1];
    my $str = "if ( \$PRIV(bvalflag) ) { PDL_COMMENT(\"** do 'bad' Code **\")\n";
    $str .= "\n#define PDL_BAD_CODE\n";
    $str .= $bad->get_str($parent,$context);
    $str .= "\n#undef PDL_BAD_CODE\n";
    $str .= "} else { PDL_COMMENT(\"** else do 'good' Code **\")\n";
    $str .= $good->get_str($parent,$context);
    $str .= "}\n";
    return $str;
}
###########################
#
# Encapsulate a loop
package PDL::PP::Loop;
@PDL::PP::Loop::ISA = "PDL::PP::Block";
sub new { my($type,$args,$sizeprivs,$parent) = @_;
        my $this = bless [$args],$type;
        for(@{$this->[0]}) {
                print "SIZP $sizeprivs, $_\n" if $::PP_VERBOSE;
                my $i = $parent->make_loopind($_);
                $sizeprivs->{$i->[0]} =
                  "register PDL_Indx __$i->[0]_size = \$PRIV(__$i->[0]_size);\n";
                print "SP :",(join ',',%$sizeprivs),"\n" if $::PP_VERBOSE;
        }
        return $this;
}
sub myoffs { return 1; }
sub myprelude { my($this,$parent,$context) = @_;
        my $text = ""; my $i;
        push @$context, map {
                $i = $parent->make_loopind($_);
# Used to be $PRIV(.._size) but now we have it in a register.
                $text .= "{PDL_COMMENT(\"Open $_\") register PDL_Indx $_;
                        for($_=0; $_<(__$i->[0]_size); $_++) {";
                $i;
        } @{$this->[0]};
        return $text;
}
sub mypostlude { my($this,$parent,$context) = @_;
        splice @$context, - ($#{$this->[0]}+1);
        return join '',map {"}} PDL_COMMENT(\"Close $_\")"} @{$this->[0]};
}
###########################
#
# Encapsulate a generic type loop
#
# we use the value of $parent->{types} [set by a PDL::PP::Types object]
# to determine whether to define/undefine the THISISxxx macros
# (makes the xs code easier to read)
#
package PDL::PP::GenericLoop;
@PDL::PP::GenericLoop::ISA = "PDL::PP::Block";
# Types: BSULFD
use PDL::Types ':All';
sub new {
    my($type,$types,$name,$varnames,$whattype) = @_;
    bless [(PDL::PP::get_generictyperecs($types)),$name,$varnames,
           $whattype],$type;
}
sub myoffs {4}
sub myprelude {
    my($this,$parent,$context) = @_;
    push @{$parent->{Gencurtype}},'PDL_undef'; # so that $GENERIC can get at it
    # horrible hack for PDL::PP::NaNSupport
    if ( $this->[1] ne "" ) {
        my ( @test ) = keys %{$parent->{pars}};
        die "ERROR: need to rethink NaNSupport in GenericLoop\n"
            if $#test != -1;
        $parent->{pars} = {};
    }
    my $thisis_loop = '';
    if ( $parent->{types} ) {
        $thisis_loop = join '',
        map {
            "#undef THISIS$this->[1]_$_\n#define THISIS$this->[1]_$_(a)\n"
            }
        (ppdefs);
    }
    return <<WARNING_EATER;
PDL_COMMENT("Start generic loop")
$thisis_loop
        switch($this->[3]) { case -42: PDL_COMMENT("Warning eater") {(void)1;
WARNING_EATER
}
sub myitem {
    my($this,$parent,$nth) = @_;
#       print "GENERICITEM\n";
    my $item = $this->[0]->[$nth];
    if(!$item) {return "";}
    $parent->{Gencurtype}->[-1] = $item->[1];
    # horrible hack for PDL::PP::NaNSupport
    if ( $this->[1] ne "" ) {
        foreach my $parname ( @{$this->[2]} ) {
            $parent->{pars}{$parname} = $item->[1];
        }
    }
    my $thisis_loop = '';
    if ( $parent->{types} ) {
        $thisis_loop = (
                        join '',
                        map {
                            "#undef THISIS$this->[1]_$_\n#define THISIS$this->[1]_$_(a)\n";
                        }
                        (ppdefs)
                        ) .
                            "#undef THISIS$this->[1]_$item->[3]\n" .
                                "#define THISIS$this->[1]_$item->[3](a) a\n";
    }
    return "\t} break; case $item->[0]: {\n".
        $thisis_loop .
            (join '',map{
                # print "DAPAT: '$_'\n";
                $parent->{ParObjs}{$_}->get_xsdatapdecl($item->[1]);
            } (@{$this->[2]})) ;
}
sub mypostlude {
    my($this,$parent,$context) = @_;
    pop @{$parent->{Gencurtype}};  # and clean up the Gentype stack
    # horrible hack for PDL::PP::NaNSupport
    if ( $this->[1] ne "" ) { $parent->{pars} = {}; }
    return "\tbreak;}
        default:barf(\"PP INTERNAL ERROR! PLEASE MAKE A BUG REPORT\\n\");}\n";
}
###########################
#
# Encapsulate a threadloop.
# There are several different
package PDL::PP::ThreadLoop;
sub new {
        return PDL::PP::ComplexThreadLoop->new(@_);
}
package PDL::PP::SimpleThreadLoop;
use Carp;
@PDL::PP::SimpleThreadLoop::ISA = "PDL::PP::Block";
our @CARP_NOT;
sub new { my($type) = @_; bless [],$type; }
sub myoffs { return 0; }
sub myprelude {my($this,$parent,$context) = @_;
 my $no;
 my ($ord,$pdls) = $parent->get_pdls();
'       PDL_COMMENT("THREADLOOPBEGIN")
 if(PDL->startthreadloop(&($PRIV(__pdlthread)),$PRIV(vtable)->readdata,
        __privtrans))) return;
   do {
 '.(join '',map {"${_}_datap += \$PRIV(__pdlthread).offs[".(0+$no++)."];\n"}
                @$ord).'
';
}
sub mypostlude {my($this,$parent,$context) = @_;
 my $no;
 my ($ord,$pdls) = $parent->get_pdls();
'       PDL_COMMENT("THREADLOOPEND")
 '.(join '',map {"${_}_datap -= \$PRIV(__pdlthread).offs[".(0+$no++)."];\n"}
                @$ord).'
      } while(PDL->iterthreadloop(&$PRIV(__pdlthread),0));
 '
}
####
#
# This relies on PP.pm making sure that initthreadloop always sets
# up the two first dimensions even when they are not necessary.
#
package PDL::PP::ComplexThreadLoop;
use Carp;
@PDL::PP::ComplexThreadLoop::ISA = "PDL::PP::Block";
our @CARP_NOT;
sub new {
        my $type   = shift;
        bless [],$type;
}
sub myoffs { return 0; }
sub myprelude {
    my($this,$parent,$context, $backcode) = @_;
    #  Set appropriate function from the vtable to supply to threadthreadloop.
    #    Function name from the vtable is readdata for normal code
    #    function name for backcode is writebackdata
    my $funcName = "readdata";
    $funcName = "writebackdata" if( $backcode );
    my ($ord,$pdls) = $parent->get_pdls();
    join( "\n   ",
          '',
          'PDL_COMMENT("THREADLOOPBEGIN")',
          'if ( PDL->startthreadloop(&($PRIV(__pdlthread)),$PRIV(vtable)->'.$funcName.', __tr) ) return;
           do { register PDL_Indx __tind1=0,__tind2=0;
                register PDL_Indx __tnpdls = $PRIV(__pdlthread).npdls;
                register PDL_Indx __tdims1 = $PRIV(__pdlthread.dims[1]);
                register PDL_Indx __tdims0 = $PRIV(__pdlthread.dims[0]);
                register PDL_Indx *__offsp = PDL->get_threadoffsp(&$PRIV(__pdlthread));',
          ( map { "register PDL_Indx __tinc0_${_} = \$PRIV(__pdlthread).incs[${_}];"} 0..$#{$ord}),
          ( map { "register PDL_Indx __tinc1_${_} = \$PRIV(__pdlthread).incs[__tnpdls+$_];"} 0.. $#{$ord}),
          ( map { $ord->[$_] ."_datap += __offsp[$_];"} 0..$#{$ord} ),
          'for( __tind2 = 0 ;
                __tind2 < __tdims1 ;
                __tind2++',
                ( map { "\t\t," . $ord->[$_] . "_datap += __tinc1_${_} - __tinc0_${_} * __tdims0"} 0..$#{$ord} ),
             ')',
          '{
             for( __tind1 = 0 ;
                  __tind1 < __tdims0 ;
                  __tind1++',
                  ( map { "\t\t," . $ord->[$_] . "_datap += __tinc0_${_}"} 0..$#{$ord}),
               ')',
           '{  PDL_COMMENT("This is the tightest threadloop. Make sure inside is optimal.")'
        );
}
# Should possibly fold out thread.dims[0] and [1].
sub mypostlude {my($this,$parent,$context) = @_;
 my ($ord,$pdls) = $parent->get_pdls();
 join( "\n      ",
       '',
       'PDL_COMMENT("THREADLOOPEND")',
       '}',
       '}',
       ( map { $ord->[$_] . "_datap -= __tinc1_${_} * __tdims1 + __offsp[${_}];"} 0..$#{$ord} ),
       '} while(PDL->iterthreadloop(&$PRIV(__pdlthread),2));'
     )
}
# Simple subclass of ComplexThreadLoop to implement writeback code
#
#
package PDL::PP::BackCodeThreadLoop;
use Carp;
@PDL::PP::BackCodeThreadLoop::ISA = "PDL::PP::ComplexThreadLoop";
our @CARP_NOT;
sub myprelude {
    my($this,$parent,$context, $backcode) = @_;
    # Set backcode flag if not defined. This will make the parent
    #   myprelude emit proper writeback code
    $backcode = 1 unless defined($backcode);
    $this->SUPER::myprelude($parent, $context, $backcode);
}
###########################
#
# Encapsulate a types() switch
#
# horrible hack:
#  set $parent->{types} if we create this object so that
#  PDL::PP::GenericLoop knows to define the THISIS ... macros
#
package PDL::PP::Types;
use Carp;
use PDL::Types ':All';
@PDL::PP::Types::ISA = "PDL::PP::Block";
our @CARP_NOT;
sub new {
    my($type,$ts,$parent) = @_;
    my $types = join '', ppdefs; # BSUL....
    $ts =~ /[$types]+/ or confess "Invalid type access with '$ts'!";
    $parent->{types} = 1; # hack for PDL::PP::GenericLoop
    bless [$ts],$type; }
sub myoffs { return 1; }
sub myprelude {
    my($this,$parent,$context) = @_;
    return "\n#if ". (join '||',map {"(THISIS_$_(1)+0)"} split '',$this->[0])."\n";
}
sub mypostlude {my($this,$parent,$context) = @_;
        "\n#endif\n"
}
###########################
#
# Encapsulate an access
package PDL::PP::Access;
use Carp;
our @CARP_NOT;
sub new { my($type,$str,$parent) = @_;
        $str =~ /^\$([a-zA-Z_]\w*)\s*\(([^)]*)\)/ or
                confess ("Access wrong: '$str'\n");
        my($pdl,$inds) = ($1,$2);
        if($pdl =~ /^T/) {new PDL::PP::MacroAccess($pdl,$inds,
                                                   $parent->{Generictypes},$parent->{Name});}
        elsif($pdl =~ /^P$/) {new PDL::PP::PointerAccess($pdl,$inds);}
        elsif($pdl =~ /^PP$/) {new PDL::PP::PhysPointerAccess($pdl,$inds);}
        elsif($pdl =~ /^SIZE$/) {new PDL::PP::SizeAccess($pdl,$inds);}
        elsif($pdl =~ /^RESIZE$/) {new PDL::PP::ReSizeAccess($pdl,$inds);}
        elsif($pdl =~ /^GENERIC$/) {new PDL::PP::GentypeAccess($pdl,$inds);}
        elsif($pdl =~ /^PDL$/) {new PDL::PP::PdlAccess($pdl,$inds);}
        elsif(!defined $parent->{ParObjs}{$pdl}) {new PDL::PP::OtherAccess($pdl,$inds);}
        else {
                bless [$pdl,$inds],$type;
        }
}
sub get_str { my($this,$parent,$context) = @_;
#       print "AC: $this->[0]\n";
        $parent->{ParObjs}{$this->[0]}->do_access($this->[1],$context)
         if defined($parent->{ParObjs}{$this->[0]});
}
###########################
#
# Just some other substituted thing.
package PDL::PP::OtherAccess;
sub new { my($type,$pdl,$inds) = @_; bless [$pdl,$inds],$type; }
sub get_str {my($this) = @_;return "\$$this->[0]($this->[1])"}
###########################
#
# used by BadAccess code to know when to use NaN support
# - the output depends on the value of the
#   BADVAL_USENAN option in perldl.conf
#   == 1 then we use NaN's
#      0             PDL.bvals.Float/Double
#
# note the *horrible hack* for piddles whose type have been
# specified using the FType option - see GenericLoop.
# There MUST be a better way than this...
#
package PDL::PP::NaNSupport;
use PDL::Types ':All'; # typefld et al.
# need to be lower-case because of FlagTyped stuff
#
# need to be able to handle signatures with fixed types
# which means parameters like 'int mask()',
# which means the hack to add 'int' to %use_nan
#
my %use_nan =
    map {(typefld($_,'convertfunc') => typefld($_,'usenan')*$usenan)} typesrtkeys;
$use_nan{int} = 0;
# original try
##my %use_nan =
##  map {(typefld($_,'convertfunc') => typefld($_,'usenan')*$usenan)} typesrtkeys;
# Was the following, before new Type "interface"
#     ( byte => 0, short => 0, ushort => 0, long => 0,
#       int => 0,  longlong => 0, # necessary for fixed-type piddles (or something)
#       float => $usenan,
#       double => $usenan
#       );
my %set_nan =
    (
     float  => 'PDL->bvals.Float',  PDL_Float  => 'PDL->bvals.Float',
     double => 'PDL->bvals.Double', PDL_Double => 'PDL->bvals.Double',
     );
sub use_nan ($) {
    my $type = shift;
    $type =~ s/^PDL_//;
    $type = lc $type;
    die "ERROR: Unknown type [$type] used in a 'Bad' macro."
        unless exists $use_nan{$type};
    return $use_nan{$type};
}
sub convert ($$$$$) {
    my ( $parent, $name, $lhs, $rhs, $opcode ) = @_;
    my $type = $parent->{Gencurtype}[-1];
    die "ERROR: unable to find type info for $opcode access"
        unless defined $type;
    # note: gentype may not be sensible because the
    # actual piddle could have a 'fixed' type
    die "ERROR: unable to find piddle $name in parent!"
        unless exists $parent->{ParObjs}{$name};
    my $pobj = $parent->{ParObjs}{$name};
    # based on code from from PdlParObj::ctype()
    # - want to handle FlagTplus case
    # - may not be correct
    # - extended to include hack to GenericLoop
    #
    if ( exists $parent->{pars}{$name} ) {
        $type = $parent->{pars}{$name};
        print "#DBG: hacked <$name> to type <$type>\n" if $::PP_VERBOSE;
    } elsif ( exists $pobj->{FlagTyped} and $pobj->{FlagTyped} ) {
        $type = $pobj->{Type};
        # this should use Dev.pm - fortunately only worried about double/float here
        # XXX - do I really know what I'm doing ?
        if ( $pobj->{FlagTplus} ) {
            my $gtype = $parent->{Gencurtype}[-1];
            if ( $gtype eq "PDL_Double" ) {
                $type = $gtype if $type ne "double";
            } elsif ( $gtype eq "PDL_Float" ) {
                $type = $gtype if $type !~ /^(float|double)$/;  # note: ignore doubles
            }
        }
    }
    if ( use_nan($type) ) {
        if ( $opcode eq "SETBAD" ) {
#           $rhs = "(0.0/0.0)";
            $rhs = $set_nan{$type};
        } else {
            $rhs = "0";
            $lhs = "finite($lhs)";
        }
    }
    return ( $lhs, $rhs );
}
###########################
#
# Encapsulate a check on whether a value is good or bad
# handles both checking (good/bad) and setting (bad)
#
# Integer types (BSUL) + floating point when no NaN (FD)
#   $ISBAD($a(n))  -> $a(n) == a_badval
#   $ISGOOD($a())     $a()  != a_badval
#   $SETBAD($a())     $a()   = a_badval
#
# floating point with NaN
#   $ISBAD($a(n))  -> finite($a(n)) == 0
#   $ISGOOD($a())     finite($a())  != 0
#   $SETBAD($a())     $a()           = PDL->bvals.Float (or .Double)
#
# I've also got it so that the $ on the pdl name is not
# necessary - so $ISBAD(a(n)) is also accepted, so as to reduce the
# amount of line noise. This is actually done by the regexp
# in the separate_code() sub at the end of the file.
#
# note:
#   we also expand out $a(n) etc as well here
#
# To do:
#   need to allow use of F,D without NaN
#
package PDL::PP::BadAccess;
use Carp;
our @CARP_NOT;
sub new {
    my ( $type, $opcode, $pdl_name, $inds, $parent ) = @_;
    # trying to avoid auto creation of hash elements
    my $check = $parent->{ParObjs};
    die "\nIt looks like you have tried a \$${opcode}() macro on an\n" .
        "  unknown piddle <$pdl_name($inds)>\n"
        unless exists($check->{$pdl_name}) and defined($check->{$pdl_name});
    return bless [$opcode, $pdl_name, $inds], $type;
}
our %ops = ( ISBAD => '==', ISGOOD => '!=', SETBAD => '=' );
sub get_str {
    my($this,$parent,$context) = @_;
    my $opcode = $this->[0];
    my $name   = $this->[1];
    my $inds   = $this->[2];
    print "PDL::PP::BadAccess sent [$opcode] [$name] [$inds]\n" if $::PP_VERBOSE;
    my $op = $ops{$opcode};
    die "ERROR: unknown check <$opcode> sent to PDL::PP::BadAccess\n"
        unless defined $op;
    my $obj = $parent->{ParObjs}{$name};
    die "ERROR: something screwy in PDL::PP::BadAccess (PP/PDLCode.pm)\n"
        unless defined( $obj );
    my $lhs = $obj->do_access($inds,$context);
    my $rhs = "${name}_badval";
    ( $lhs, $rhs ) =
      PDL::PP::NaNSupport::convert( $parent, $name, $lhs, $rhs, $opcode );
    print "DBG:  [$lhs $op $rhs]\n" if $::PP_VERBOSE;
    return "$lhs $op $rhs";
}
###########################
#
# Encapsulate a check on whether a value is good or bad
# handles both checking (good/bad) and setting (bad)
#
# Integer types (BSUL) + floating point when no NaN (FD)
#   $ISBADVAR(foo,a)  -> foo == a_badval
#   $ISGOODVAR(foo,a)    foo != a_badval
#   $SETBADVAR(foo,a)    foo  = a_badval
#
# floating point with NaN
#   $ISBADVAR(foo,a)  -> finite(foo) == 0
#   $ISGOODVAR(foo,a)    finite(foo) != 0
#   $SETBADVAR(foo,a)    foo          = PDL->bvals.Float (or .Double)
#
package PDL::PP::BadVarAccess;
use Carp;
our @CARP_NOT;
sub new {
    my ( $type, $opcode, $var_name, $pdl_name, $parent ) = @_;
    # trying to avoid auto creation of hash elements
    my $check = $parent->{ParObjs};
    die "\nIt looks like you have tried a \$${opcode}() macro on an\n" .
        "  unknown piddle <$pdl_name>\n"
        unless exists($check->{$pdl_name}) and defined($check->{$pdl_name});
    bless [$opcode, $var_name, $pdl_name], $type;
}
our %ops = ( ISBAD => '==', ISGOOD => '!=', SETBAD => '=' );
sub get_str {
    my($this,$parent,$context) = @_;
    my $opcode   = $this->[0];
    my $var_name = $this->[1];
    my $pdl_name = $this->[2];
    print "PDL::PP::BadVarAccess sent [$opcode] [$var_name] [$pdl_name]\n" if $::PP_VERBOSE;
    my $op = $ops{$opcode};
    die "ERROR: unknown check <$opcode> sent to PDL::PP::BadVarAccess\n"
        unless defined $op;
    my $obj = $parent->{ParObjs}{$pdl_name};
    die "ERROR: something screwy in PDL::PP::BadVarAccess (PP/PDLCode.pm)\n"
        unless defined( $obj );
    my $lhs = $var_name;
    my $rhs = "${pdl_name}_badval";
    ( $lhs, $rhs ) =
      PDL::PP::NaNSupport::convert( $parent, $pdl_name, $lhs, $rhs, $opcode );
    print "DBG:  [$lhs $op $rhs]\n" if $::PP_VERBOSE;
    return "$lhs $op $rhs";
}
###########################
#
# Encapsulate a check on whether a value is good or bad using PP
# handles both checking (good/bad) and setting (bad)
# this is only an initial attempt - it will, almost certainly,
# need more work as more code is converted to handle bad values
#
# currently it can only handle cases like
#  $PPISBAD(PARENT,[i])  -> PARENT_physdatap[i] == PARENT_badval
#  etc
#
# if we use NaN's, then
#  $PPISBAD(PARENT,[i])   -> finite(PARENT_physdatap[i]) == 0
#  $PPISGOOD(PARENT,[i])  -> finite(PARENT_physdatap[i]) != 0
#  $PPSETBAD(PARENT,[i])  -> PARENT_physdatap[i]          = PDL->bvals.Float (or .Double)
#
package PDL::PP::PPBadAccess;
use Carp;
our @CARP_NOT;
sub new {
    my ( $type, $opcode, $pdl_name, $inds, $parent ) = @_;
    $opcode =~ s/^PP//;
    bless [$opcode, $pdl_name, $inds], $type;
}
# PP is stripped in new()
our %ops = ( ISBAD => '==', ISGOOD => '!=', SETBAD => '=' );
sub get_str {
    my($this,$parent,$context) = @_;
    my $opcode = $this->[0];
    my $name   = $this->[1];
    my $inds   = $this->[2];
    print "PDL::PP::PPBadAccess sent [$opcode] [$name] [$inds]\n" if $::PP_VERBOSE;
    my $op = $ops{$opcode};
    die "\nERROR: unknown check <$opcode> sent to PDL::PP::PPBadAccess\n"
        unless defined $op;
    my $obj = $parent->{ParObjs}{$name};
    die "\nERROR: ParObjs does not seem to exist for <$name> = problem in PDL::PP::PPBadAccess\n"
        unless defined $obj;
    my $lhs = $obj->do_physpointeraccess() . "$inds";
    my $rhs = "${name}_badval";
    ( $lhs, $rhs ) =
      PDL::PP::NaNSupport::convert( $parent, $name, $lhs, $rhs, $opcode );
    print "DBG:  [$lhs $op $rhs]\n" if $::PP_VERBOSE;
    return "$lhs $op $rhs";
}
###########################
#
# Encapsulate a check on whether the state flag of a piddle
# is set/change this state
#
# $PDLSTATEISBAD(a)    ->  ($PDL(a)->state & PDL_BADVAL) > 0
# $PDLSTATEISGOOD(a)   ->  ($PDL(a)->state & PDL_BADVAL) == 0
#
# $PDLSTATESETBAD(a)   ->  ($PDL(a)->state |= PDL_BADVAL)
# $PDLSTATESETGOOD(a)  ->  ($PDL(a)->state &= ~PDL_BADVAL)
#
package PDL::PP::PDLStateBadAccess;
use Carp;
our @CARP_NOT;
sub new {
    my ( $type, $op, $val, $pdl_name, $parent ) = @_;
    # $op  is one of: IS SET
    # $val is one of: GOOD BAD
    # trying to avoid auto creation of hash elements
    my $check = $parent->{ParObjs};
    die "\nIt looks like you have tried a \$PDLSTATE${op}${val}() macro on an\n" .
        "  unknown piddle <$pdl_name>\n"
        unless exists($check->{$pdl_name}) and defined($check->{$pdl_name});
    bless [$op, $val, $pdl_name], $type;
}
our %ops  = (
             IS  => { GOOD => '== 0', BAD => '> 0' },
             SET => { GOOD => '&= ~', BAD => '|= ' },
             );
sub get_str {
    my($this,$parent,$context) = @_;
    my $op   = $this->[0];
    my $val  = $this->[1];
    my $name = $this->[2];
    print "PDL::PP::PDLStateBadAccess sent [$op] [$val] [$name]\n" if $::PP_VERBOSE;
    my $opcode = $ops{$op}{$val};
    my $type = $op . $val;
    die "ERROR: unknown check <$type> sent to PDL::PP::PDLStateBadAccess\n"
        unless defined $opcode;
    my $obj = $parent->{ParObjs}{$name};
    die "\nERROR: ParObjs does not seem to exist for <$name> = problem in PDL::PP::PDLStateBadAccess\n"
        unless defined $obj;
    my $state = $obj->do_pdlaccess() . "->state";
    my $str;
    if ( $op eq 'IS' ) {
        $str = "($state & PDL_BADVAL) $opcode";
    } elsif ( $op eq 'SET' ) {
        $str = "$state ${opcode}PDL_BADVAL";
    }
    print "DBG:  [$str]\n" if $::PP_VERBOSE;
    return $str;
}
###########################
#
# Encapsulate a Pointeraccess
package PDL::PP::PointerAccess;
use Carp;
our @CARP_NOT;
sub new { my($type,$pdl,$inds) = @_; bless [$inds],$type; }
sub get_str {my($this,$parent,$context) = @_;
        croak ("can't access undefined pdl ".$this->[0])
          unless defined($parent->{ParObjs}{$this->[0]});
#       $parent->{ParObjs}{$this->[0]}->{FlagPaccess} = 1;
        $parent->{ParObjs}{$this->[0]}->{FlagPhys} = 1;
        $parent->{ParObjs}{$this->[0]}->do_pointeraccess();
}
###########################
#
# Encapsulate a PhysPointeraccess
package PDL::PP::PhysPointerAccess;
use Carp;
our @CARP_NOT;
sub new { my($type,$pdl,$inds) = @_; bless [$inds],$type; }
sub get_str {my($this,$parent,$context) = @_;
        $parent->{ParObjs}{$this->[0]}->do_physpointeraccess()
         if defined($parent->{ParObjs}{$this->[0]});
}
###########################
#
# Encapsulate a PDLaccess
package PDL::PP::PdlAccess;
use Carp;
our @CARP_NOT;
sub new { my($type,$pdl,$inds) = @_; bless [$inds],$type; }
sub get_str {my($this,$parent,$context) = @_;
        croak ("can't access undefined pdl ".$this->[0])
          unless defined($parent->{ParObjs}{$this->[0]});
        $parent->{ParObjs}{$this->[0]}->do_pdlaccess();
}
###########################
#
# Encapsulate a macroaccess
package PDL::PP::MacroAccess;
use Carp;
use PDL::Types ':All';
my $types = join '',ppdefs;
our @CARP_NOT;
sub new { my($type,$pdl,$inds,$gentypes,$name) = @_;
          $pdl =~ /^\s*T([A-Z]+)\s*$/ or confess("Macroaccess wrong: $pdl\n");
          my @ilst = split '',$1;
          for my $gt (@$gentypes) {
            warn "$name has no Macro for generic type $gt (has $pdl)\n"
              unless grep {$gt eq $_} @ilst }
          for my $mtype (@ilst) {
            warn "Macro for unsupported generic type identifier $mtype".
              " (probably harmless)\n"
              unless grep {$mtype eq $_} @$gentypes;
          }
          return bless [$pdl,$inds,$name],
            $type; }
sub get_str {my($this,$parent,$context) = @_;
        my ($pdl,$inds,$name) = @{$this};
        $pdl =~ /^\s*T([A-Z]+)\s*$/
          or confess("Macroaccess wrong in $name (allowed types $types): was '$pdl'\n");
        my @lst = split ',',$inds;
        my @ilst = split '',$1;
        if($#lst != $#ilst) {confess("Macroaccess: different nos of args $pdl $inds\n");}
        croak "generic type access outside a generic loop in $name"
          unless defined $parent->{Gencurtype}->[-1];
        my $type = mapfld $parent->{Gencurtype}->[-1], 'ctype' => 'ppsym';
        #     print "Type access: $type\n";
        croak "unknown Type in $name (generic type currently $parent->{Gencurtype}->[-1]"
          unless defined $type;
        for (0..$#lst) {
          return "$lst[$_]" if $ilst[$_] =~ /$type/;
        }
}
###########################
#
# Encapsulate a SizeAccess
package PDL::PP::SizeAccess;
use Carp;
our @CARP_NOT;
sub new { my($type,$pdl,$inds) = @_; bless [$inds],$type; }
sub get_str {my($this,$parent,$context) = @_;
        croak "can't get SIZE of undefined dimension $this->[0]"
          unless defined($parent->{IndObjs}{$this->[0]});
        $parent->{IndObjs}{$this->[0]}->get_size();
}
###########################
#
# Encapsulate a ReSizeAccess
package PDL::PP::ReSizeAccess;
use Carp;
our @CARP_NOT;
sub new { my($type,$pdl,$inds) = @_; bless [$inds],$type; }
sub get_str {my($this,$parent,$context) = @_;
        $this->[0] =~ /^([^,]+),([^,]+)$/ or
                croak "Can't interpret resize str $this->[0]";
        croak "can't RESIZE undefined dimension $1"
          unless defined($parent->{IndObjs}{$1});
        my $s = $parent->{IndObjs}{$1}->get_size();
# XXX NOTE: All piddles must be output piddles, there must not be
# a loop over this var (at all!) etc. Should check for these,
# this is why not yet documented.
# FURTHER NOTE: RESIZE DOESN'T COPY DATA PROPERLY!
        my($ord,$pdls) = $parent->get_pdls();
        my @p;
        for(@$ord) {
                push @p, $_
                        if $pdls->{$_}->has_dim($1);
        }
        print "RESIZEACC: $1 $2, (",(join ',',@p),")\n";
        warn "RESIZE USED: DO YOU KNOW WHAT YOU ARE DOING???\n";
        return "$s = $2; ".(join '',map {$pdls->{$_}->do_resize($1,$2)} @p);
}
###########################
#
# Encapsulate a GentypeAccess
package PDL::PP::GentypeAccess;
use Carp;
our @CARP_NOT;
sub new { my($type,$pdl,$inds) = @_; bless [$inds],$type; }
sub get_str {my($this,$parent,$context) = @_;
             croak "generic type access outside a generic loop"
               unless defined $parent->{Gencurtype}->[-1];
             my $type = $parent->{Gencurtype}->[-1];
             if ($this->[0]) {
               croak "not a defined name"
                 unless defined($parent->{ParObjs}{$this->[0]});
               $type = $parent->{ParObjs}{$this->[0]}->ctype($type);
             }
             return $type;
}
########################
#
# Type coercion
#
# Now, if TYPES:F given and double arguments, will coerce.
package PDL::PP::TypeConv;
# make the typetable from info in PDL::Types
use PDL::Types ':All';
my @typetable = map {[$typehash{$_}->{ppsym},
                  $typehash{$_}->{ctype},
                  $typehash{$_}->{numval},
                 ]} typesrtkeys;
sub print_xscoerce { my($this) = @_;
        $this->printxs("\t__priv->datatype=PDL_B;\n");
# First, go through all the types, selecting the most general.
        for(@{$this->{PdlOrder}}) {
                $this->printxs($this->{Pdls}{$_}->get_xsdatatypetest());
        }
# See which types we are allowed to use.
        $this->printxs("\tif(0) {}\n");
        for(@{$this->get_generictypes()}) {
                $this->printxs("\telse if(__priv->datatype <= $_->[2]) __priv->datatype = $_->[2];\n");
        }
        $this->{Types} =~ /F/ and (
                $this->printxs("\telse if(__priv->datatype == PDL_D) {__priv->datatype = PDL_F; PDL_COMMENT(\"Cast double to float\")}\n"));
        $this->printxs(qq[\telse {croak("Too high type \%d given!\\n",__priv->datatype);}]);
# Then, coerce everything to this type.
        for(@{$this->{PdlOrder}}) {
                $this->printxs($this->{Pdls}{$_}->get_xscoerce());
        }
}
# XXX Should use PDL::Core::Dev;
no strict 'vars';
# STATIC!
sub PDL::PP::get_generictyperecs { my($types) = @_;
        my $foo;
        return [map {$foo = $_;
                ( grep {/$foo->[0]/} (@$types) ) ?
                  [mapfld($_->[0],'ppsym'=>'sym'),$_->[1],$_->[2],$_->[0]]
                  : ()
        }
               @typetable];
}
sub xxx_get_generictypes { my($this) = @_;
        return [map {
                $this->{Types} =~ /$_->[0]/ ? [mapfld($_->[0],'ppsym'=>'sym'),$_->[1],$_->[2],$_->[0]] : ()
        }
               @typetable];
}
package PDL::PP::Code;
# my ( $threadloops, $coderef, $sizeprivs ) = $this->separate_code( $code );
#
# umm, can't call classes defined later on in code ...
# hence moved to end of file
# (rather ugly...)
#
# XXX The above statement is almost certainly false. This module is parsed
#     before separate_code is ever called, so all of the class definitions
#     should exist. -- David Mertens, Dec 2 2011
#
# separates the code into an array of C fragments (strings),
# variable references (strings starting with $) and
# loops (array references, 1. item = variable.
#
sub separate_code {
   ## $DB::single=1;
    my ( $this, $code ) = @_;
    # First check for standard code errors:
    catch_code_errors($code);
    my $coderef = new PDL::PP::Block;
    my @stack = ($coderef);
    my $threadloops = 0;
    my $sizeprivs = {};
    local $_ = $code;
##    print "Code to parse = [$_]\n" if $::PP_VERBOSE;
    while($_) {
        # Parse next statement
        # I'm not convinced that having the checks twice is a good thing,
        # since it makes it easy (for me at least) to forget to update one
        # of them
        s/^(.*?) # First, some noise is allowed. This may be bad.
            ( \$(ISBAD|ISGOOD|SETBAD)\s*\(\s*\$?[a-zA-Z_]\w*\s*\([^)]*\)\s*\)   # $ISBAD($a(..)), ditto for ISGOOD and SETBAD
                |\$PP(ISBAD|ISGOOD|SETBAD)\s*\(\s*[a-zA-Z_]\w*\s*,\s*[^)]*\s*\)   # $PPISBAD(CHILD,[1]) etc
###                |\$STATE(IS|SET)(BAD|GOOD)\s*\(\s*[^)]*\s*\)      # $STATEISBAD(a) etc
                |\$PDLSTATE(IS|SET)(BAD|GOOD)\s*\(\s*[^)]*\s*\)   # $PDLSTATEISBAD(a) etc
                |\$[a-zA-Z_]\w*\s*\([^)]*\)  # $a(...): access
                |\bloop\s*\([^)]+\)\s*%\{   # loop(..) %{
                |\btypes\s*\([^)]+\)\s*%\{  # types(..) %{
                |\bthreadloop\s*%\{         # threadloop %{
                |%}                        # %}
                |$)//xs
                    or confess("Invalid program $_");
                my $control = $2;
                # Store the user code.
                # Some day we shall parse everything.
                push @{$stack[-1]},$1;
                if ( $control =~ /^\$STATE/ ) { print "\nDBG: - got [$control]\n\n"; }
                # Then, our control.
                if($control) {
                        if($control =~ /^loop\s*\(([^)]+)\)\s*%\{/) {
                                my $ob = new PDL::PP::Loop([split ',',$1],
                                                   $sizeprivs,$this);
                                print "SIZEPRIVSXX: $sizeprivs,",(join ',',%$sizeprivs),"\n" if $::PP_VERBOSE;
                                push @{$stack[-1]},$ob;
                                push @stack,$ob;
                        } elsif($control =~ /^types\s*\(([^)]+)\)\s*%\{/) {
                                my $ob = new PDL::PP::Types($1,$this);
                                push @{$stack[-1]},$ob;
                                push @stack,$ob;
                        } elsif($control =~ /^threadloop\s*%\{/) {
                                my $ob = new PDL::PP::ThreadLoop();
                                push @{$stack[-1]},$ob;
                                push @stack,$ob;
                                $threadloops ++;
                        } elsif($control =~ /^\$PP(ISBAD|ISGOOD|SETBAD)\s*\(\s*([a-zA-Z_]\w*)\s*,\s*([^)]*)\s*\)/) {
                                push @{$stack[-1]},new PDL::PP::PPBadAccess($1,$2,$3,$this);
                        } elsif($control =~ /^\$(ISBAD|ISGOOD|SETBAD)VAR\s*\(\s*([^)]*)\s*,\s*([^)]*)\s*\)/) {
                                push @{$stack[-1]},new PDL::PP::BadVarAccess($1,$2,$3,$this);
                        } elsif($control =~ /^\$(ISBAD|ISGOOD|SETBAD)\s*\(\s*\$?([a-zA-Z_]\w*)\s*\(([^)]*)\)\s*\)/) {
                                push @{$stack[-1]},new PDL::PP::BadAccess($1,$2,$3,$this);
        #           } elsif($control =~ /^\$STATE(IS|SET)(BAD|GOOD)\s*\(\s*([^)]*)\s*\)/) {
        #               push @{$stack[-1]},new PDL::PP::StateBadAccess($1,$2,$3,$this);
                        } elsif($control =~ /^\$PDLSTATE(IS|SET)(BAD|GOOD)\s*\(\s*([^)]*)\s*\)/) {
                                push @{$stack[-1]},new PDL::PP::PDLStateBadAccess($1,$2,$3,$this);
                        } elsif($control =~ /^\$[a-zA-Z_]\w*\s*\([^)]*\)/) {
                                push @{$stack[-1]},new PDL::PP::Access($control,$this);
                        } elsif($control =~ /^%}/) {
                            pop @stack;
                        } else {
                                confess("Invalid control: $control\n");
                        }
                } else {
                        print("No \$2!\n") if $::PP_VERBOSE;
                }
    } # while: $_
    return ( $threadloops, $coderef, $sizeprivs );
} # sub: separate_code()
# This is essentially a collection of regexes that look for standard code
# errors and croaks with an explanation if they are found.
sub catch_code_errors {
        my $code_string = shift;
        # Look for constructs like
        #   loop %{
        # which is invalid - you need to specify the dimension over which it
        # should loop
        report_error('Expected dimension name after "loop" and before "%{"', $1)
                if $code_string =~ /(.*\bloop\s*%\{)/s;
}
# Report an error as precisely as possible. If they have #line directives
# in the code string, use that in the reporting; otherwise, use standard
# Carp mechanisms
my $line_re = qr/#\s*line\s+(\d+)\s+"([^"]*)"/;
sub report_error {
        my ($message, $code) = @_;
        # Just croak if they didn't supply a #line directive:
        croak($message) if $code !~ $line_re;
        # Find the line at which the error occurred:
        my $line = 0;
        my $filename;
        LINE: foreach (split /\n/, $code) {
                $line++;
                if (/$line_re/) {
                        $line = $1;
                        $filename = $2;
                }
        }
        die "$message at $filename line $line\n";
}
# return true
1;