better error on PP mistakes

Basic/Gen/PP.pm

@@ -1454,13 +1454,13 @@ EOD
    PDL::PP::Rule::Returns::One->new("HaveBroadcasting"),
 
    PDL::PP::Rule::Returns::EmptyString->new("Priv"),
-   PDL::PP::Rule->new("PrivObj", ["BadFlag","Priv"],
+   PDL::PP::Rule->new("PrivObj", [qw(Name BadFlag Priv)],
       sub { PDL::PP::Signature->new('', @_) }),
 
 # Parameters in the 'a(x,y); [o]b(y)' format, with
 # fixed nos of real, unbroadcast-over dims.
 # Also "Other pars", the parameters which are usually not pdls.
-   PDL::PP::Rule->new("SignatureObj", ["Pars","BadFlag","OtherPars"],
+   PDL::PP::Rule->new("SignatureObj", [qw(Pars Name BadFlag OtherPars)],
       sub { PDL::PP::Signature->new(@_) }),
 
 # Compiled representations i.e. what the RunFunc function leaves
@@ -1469,8 +1469,8 @@ EOD
 # by parsing the string in that function.
 # If the user wishes to specify their own MakeComp code and Comp content,
 # The next definitions allow this.
-   PDL::PP::Rule->new("CompObj", [qw(BadFlag OtherPars Comp?)],
-      sub { PDL::PP::Signature->new('', $_[0], join(';', grep defined() && /[^\s;]/, @_[1..$#_])) }),
+   PDL::PP::Rule->new("CompObj", [qw(Name BadFlag OtherPars Comp?)],
+      sub { PDL::PP::Signature->new('', @_[0,1], join(';', grep defined() && /[^\s;]/, @_[2..$#_])) }),
    PDL::PP::Rule->new("CompStruct", ["CompObj"], sub {$_[0]->getcomp}),
 
  # Set CallCopy flag for simple functions (2-arg with 0-dim signatures)

Basic/Gen/PP/PDLCode.pm

@@ -26,7 +26,7 @@ sub new {
     my $parnames = $sig->names_sorted;
     $handlebad = !!$handlebad;
 
-    die "Error: missing name argument to PDL::PP::Code->new call!\n"
+    confess "Error: missing name argument to PDL::PP::Code->new call!\n"
       unless defined $name;
     confess "Error: empty or undefined GenericTypes!\n"
       unless @{$generictypes || []};
@@ -273,7 +273,7 @@ sub process {
 sub separate_code {
     my ( $this, $code ) = @_;
     # First check for standard code errors:
-    catch_code_errors($code);
+    $this->catch_code_errors($code);
     my @stack = my $coderef = PDL::PP::Block->new;
     my $broadcastloops = 0;
     my $sizeprivs = {};
@@ -313,23 +313,22 @@ sub expand {
 # 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;
+  my ($this, $code_string) = @_;
+  my $prefix = "pp_def($this->{Name}): ";
+  report_error("${prefix}Expected dimension name after 'loop' and before '%{'", $1)
+    if $code_string =~ /(.*\bloop\s*%\{)/s;
+  report_error("${prefix}Expected brackets after var name '$2'", $1)
+    if $code_string =~ /(.*?)(\$[a-zA-Z_]\w*\s*)[^\(\w]/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+"([^"]*)"/;
+my $line_re = qr/(?:PDL_LINENO_START|#\s*line)\s+(\d+)\s+"([^"]*)"/;
 sub report_error {
     my ($message, $code) = @_;
     # Just croak if they didn't supply a #line directive:
-    confess($message) if $code !~ $line_re;
+    croak($message) if $code !~ $line_re;
     # Find the line at which the error occurred:
     my $line = 0;
     my $filename;

Basic/Gen/PP/PdlParObj.pm

@@ -61,16 +61,16 @@ sub new {
   my ($type,$string,$badflag,$sig) = @_;
   $badflag ||= 0;
   my $this = bless {Number => "PDL_UNDEF_NUMBER", BadFlag => $badflag, Sig => $sig},$type;
-  $string =~ $pars_re or confess "Invalid pdl def $string (regex $pars_re)\n";
+  $string =~ $pars_re or croak "pp_def($this->{Sig}{OpName}): Invalid pdl def $string (regex $pars_re)\n";
   my($opt1,$opt_plus,$sqbr_opt,$name,$inds) = map $_ // '', $1,$2,$3,$4,$5;
   print "PDL: '$opt1$opt_plus', '$sqbr_opt', '$name', '$inds'\n"
     if $::PP_VERBOSE;
-  croak "Invalid Pars name: $name" if $INVALID_PAR{$name};
+  croak "pp_def($this->{Sig}{OpName}): Invalid Pars name: $name" if $INVALID_PAR{$name};
 # Set my internal variables
   $this->{Name} = $name;
   $this->{Flags} = [(split ',',$sqbr_opt),($opt1?$opt1:())];
   for(@{$this->{Flags}}) {
-    confess("Invalid flag $_ given for $string\n")
+    croak("pp_def($this->{Sig}{OpName}): Invalid flag $_ given for $string\n")
       unless my ($set, $store) = @{ $flag2info{$_} || [] };
     $this->{$store} = $_ if $store;
     $this->{$_} = 1 for @$set;
@@ -136,7 +136,7 @@ sub finalcheck {
 sub getcreatedims {
   my $this = shift;
   return map
-    { croak "can't create: index size ".$_->name." not initialised"
+    { croak "pp_def($this->{Sig}{OpName}): can't create: index size ".$_->name." not initialised"
 	if !defined($_->{Value}) || $_->{Value} < 1;
       $_->{Value} } @{$this->{IndObjs}};
 }
@@ -163,9 +163,9 @@ sub get_substname {
 }
 
 sub get_incname {
-	my($this,$ind,$for_local) = @_;
-	return "inc_sizes[PDL_INC_ID(__privtrans->vtable,$this->{Number},$ind)]" if !$for_local;
-	"__inc_$this->{Name}_".$this->get_substname($ind);
+  my($this,$ind,$for_local) = @_;
+  return "inc_sizes[PDL_INC_ID(__privtrans->vtable,$this->{Number},$ind)]" if !$for_local;
+  "__inc_$this->{Name}_".$this->get_substname($ind);
 }
 
 sub get_incregisters {
@@ -180,22 +180,25 @@ sub get_incregisters {
 
 # Print an access part.
 sub do_access {
-	my($this,$inds,$context) = @_;
-	my $pdl = $this->{Name};
-# Parse substitutions into hash
-	my %subst = map
-	 {/^\s*(\w+)\s*=>\s*(\S*)\s*$/ or confess "Invalid subst $_ in ($inds) (no spaces in => value)\n"; ($1,$2)}
-		PDL::PP::Rule::Substitute::split_cpp($inds);
-# Generate the text
-	my $text = "(${pdl}_datap)[" . join('+','0', map
-		$this->do_indterm($pdl,$_,\%subst,$context),
-	0..$#{$this->{IndObjs}}) . "]";
-# If not all substitutions made, the user probably made a spelling
-# error. Barf.
-	if(scalar(keys %subst) != 0) {
-		confess("Substitutions left: ".(join ',',sort keys %subst)."\n");
-	}
-	$text;
+  my($this,$inds,$context) = @_;
+  my $pdl = $this->{Name};
+  my %subst = map {
+    if (!/^\s*(\w+)\s*=>\s*(\S*)\s*$/) {
+      my $msg = "Invalid subst '$_' in \$$pdl($inds):";
+      $msg .= " no '=>' seen" if !/=>/;
+      $msg .= " invalid dim name '$1'" if /^\s*([^\w]*?)\s*=>/;
+      $msg .= " (no spaces in => value)" if /=>\s*\S\s*\S/;
+      croak "pp_def($this->{Sig}{OpName}): $msg\n";
+    }
+    ($1,$2)
+  } PDL::PP::Rule::Substitute::split_cpp($inds);
+  my $text = "(${pdl}_datap)[" .
+    join('+','0', map $this->do_indterm($pdl,$_,\%subst,$context), 0..$#{$this->{IndObjs}})
+  . "]";
+  # If not all substitutions made, the user probably made a spelling error
+  croak "pp_def($this->{Sig}{OpName}): Substitutions left for \$$pdl($inds): ".(join ',',sort keys %subst)."\n"
+    if keys(%subst) != 0;
+  $text;
 }
 
 sub do_pdlaccess {
@@ -214,7 +217,7 @@ sub do_indterm { my($this,$pdl,$ind,$subst,$context) = @_;
   my $index = delete($subst->{$substname}) //
 # No => get the one from the nearest context.
     (grep $_ eq $substname, map $_->[1], reverse @$context)[0];
-  confess "Access Index not found: $pdl, $ind, @{[$this->{IndObjs}[$ind]->name]}
+  croak "pp_def($this->{Sig}{OpName}): Access Index not found: $pdl, $ind, @{[$this->{IndObjs}[$ind]->name]}
 	  On stack:".(join ' ',map {"($_->[0],$_->[1])"} @$context)."\n"
 	  if !defined $index;
   return "(".($this->get_incname($ind,1))."*($index))";

Basic/Gen/PP/Signature.pm

@@ -23,9 +23,9 @@ Internal module to handle signatures
 sub nospacesplit {grep /\S/, split $_[0],$_[1]}
 
 sub new {
-  my ($type,$pars,$bvalflag,$otherpars) = @_;
+  my ($type,$pars,$opname,$bvalflag,$otherpars) = @_;
   $bvalflag ||= 0;
-  my $this = bless {}, $type;
+  my $this = bless {OpName=>$opname}, $type;
   my @objects = map PDL::PP::PdlParObj->new($_,$bvalflag, $this), nospacesplit ';',$pars;
   $this->{Names} = [ map $_->name, @objects ];
   $this->{Objects} = { map +($_->name => $_), @objects };
@@ -47,9 +47,9 @@ sub _otherPars_nft {
 	my (%flags);
 	if (s/^\s*$PDL::PP::PdlParObj::sqbr_re\s*//) {
 	  %flags = my %lflags = map +($_=>1), split /\s*,\s*/, my $opts = $1;
-	  confess "Can't have both [io] and [o]" if $lflags{o} && $lflags{io};
+	  croak "pp_def($sig->{OpName}): Can't have both [io] and [o]" if $lflags{o} && $lflags{io};
 	  my $this_out = delete($lflags{o}) || delete($lflags{io});
-	  confess "Invalid options '$opts' in '$_'" if keys %lflags;
+	  croak "pp_def($sig->{OpName}): Invalid options '$opts' in '$_'" if keys %lflags;
 	  $any_out ||= $this_out;
 	}
 	if (/^\s*([^=]+?)\s*=>\s*(\S+)\s*$/) {
@@ -62,7 +62,7 @@ sub _otherPars_nft {
 	    $type = PDL::PP::CType->new($_);
 	}
 	my $name = $type->protoname;
-	confess "Invalid OtherPars name: $name"
+	croak "pp_def($sig->{OpName}): Invalid OtherPars name: $name"
 	  if $PDL::PP::PdlParObj::INVALID_PAR{$name};
 	push @names,$name;
 	$types{$name} = $type;

Basic/Ops/ops.pd

@@ -104,10 +104,8 @@ sub biop {
   }
 EOH
     # handle exceptions
-    my $badcode = '   ( $PDLSTATEISBAD(a) && $ISBAD(a()) )
-                   || ( $PDLSTATEISBAD(b) && $ISBAD(b()) )';
     if ( exists $extra{Exception} ) {
-	# NOTE This option is unused ($badcode is not set).
+# NOTE This option is unused.
 	#      See also `ufunc()`.
 	delete $extra{Exception};
     }
@@ -133,7 +131,8 @@ EOF
 	   Code => pp_line_numbers(__LINE__-1, <<EOF),
 PDL_IF_BAD(char anybad = 0;,)
 broadcastloop %{
-  PDL_IF_BAD(if ( $badcode ) { \$SETBAD(c()); anybad = 1; } else,)
+  PDL_IF_BAD(if ( ( \$PDLSTATEISBAD(a) && \$ISBAD(a()) )
+               || ( \$PDLSTATEISBAD(b) && \$ISBAD(b()) )) { \$SETBAD(c()); anybad = 1; } else,)
      \$c() = \$a() $op \$b();
 %}
 PDL_IF_BAD(if (anybad) \$PDLSTATESETBAD(c);,)
@@ -283,11 +282,9 @@ sub ufunc {
 	if !$got_complex and $extra{GenericTypes};
 
     # handle exceptions
-    my $badcode = '$ISBAD(a())';
     if ( exists $extra{Exception} ) {
-#	$badcode .= " || $extra{Exception}";
 #	print "Warning: ignored exception for $name\n";
-	# NOTE This option is unused ($badcode is commented out above).
+# NOTE This option is unused.
 	#      See also `biop()`.
 	delete $extra{Exception};
     }
@@ -310,7 +307,7 @@ sub ufunc {
 	   NoBadifNaN => 1,
 	   Inplace => 1,
 	   Code => pp_line_numbers(__LINE__-1, <<EOF),
-PDL_IF_BAD(if ( $badcode ) \$SETBAD(b()); else {,)
+PDL_IF_BAD(if ( \$ISBAD(a()) ) \$SETBAD(b()); else {,)
   $codestr
 PDL_IF_BAD(},)
 EOF

t/pp_croaking.t

@@ -13,18 +13,13 @@ eval {pp_addpm({At=>'Mid'}, "blah")};
 like $@, qr/Middle/, 'pp_addpm says valid options';
 
 # Check the loop malformed call:
-eval {
-	pp_def(test1 =>
-		Pars => 'a(n)',
-		Code => q{
-			loop %{
-				$a()++;
-			%}
-		}
-	);
-};
+eval {pp_def(test1 => Pars => 'a(n)', Code => 'loop %{ $a()++; %}')};
 like $@, qr/Expected.*loop.*%\{/, 'loop without dim name should explain error';
 
+# Check the malformed var access:
+eval {pp_def(test1 => Pars => 'a(n)', Code => '$a++;')};
+like $@, qr/Expected brackets/, 'var access without ()';
+
 eval {
   pp_def(test1 =>
     Pars => 'a(n)',
@@ -147,15 +142,25 @@ eval { pp_def( "func", Code => ';',
 ) };
 like $@, qr/INVALID/, 'invalid GenericTypes caught';
 
+eval { pp_def( "func", Code => '$a(n);',
+  Pars => "a(n=2); [o] b(m=3);",
+) };
+like $@, qr/no '=>' seen/, 'useful error when no "=>" in ndarray access';
+
+eval { pp_def( "func", Code => '$a(n=>1 + 2);',
+  Pars => "a(n=2); [o] b(m=3);",
+) };
+like $@, qr/func\).*no spaces/, 'useful error when no "=>" in ndarray access';
+
 my $got = [PDL::PP::reorder_args(my $sig = PDL::PP::Signature->new(
-   "a(n=2); [o] b(m=3);", 1, "int x; char *y"
+   "a(n=2); [o] b(m=3);", 'name', 1, "int x; char *y"
 ), {})];
 is_deeply $got, [qw(a x y b)], 'right reorder no defaults' or diag explain $got;
 is_deeply $got = [PDL::PP::reorder_args($sig, {x=>1})], [qw(a y x b)],
   'right reorder with default'
   or diag explain $got;
 is_deeply $got = [PDL::PP::reorder_args($sig = PDL::PP::Signature->new(
-   "a(n=2); [o] b(m=3);", 1, "[o] int x; char *y; double z"
+   "a(n=2); [o] b(m=3);", 'name', 1, "[o] int x; char *y; double z"
 ), {})], [qw(a y z b x)], 'right reorder, output other, no defaults'
   or diag explain $got;
 is_deeply $got = [PDL::PP::reorder_args($sig, {y=>'""'})], [qw(a z y b x)],