add Pars type-spec "!complex" - #511

Changes

@@ -38,6 +38,7 @@
 - stop pdl([-6,18446744073709551615,-4]) being pdl([-6,-1,-4]) (#511)
 - bswap{12,24} added as long double can be 12 bytes
 - Core::trans_children in scalar context now returns how many
+- add Pars type-spec "!complex" which make it an error to supply complex values (#511)
 
 2.095 2024-11-03
 - add PDL_GENTYPE_IS_{REAL,FLOATREAL,COMPLEX,SIGNED,UNSIGNED}_##ppsym (#502)

lib/PDL/Core/pdlapi.c

@@ -1,8 +1,11 @@
 /* pdlapi.c - functions for manipulating pdl structs  */
 
 #include "pdl.h"      /* Data structure declarations */
+#define PDL_IN_CORE
 #include "pdlcore.h"  /* Core declarations */
 
+extern Core PDL; /* for PDL_TYPENAME */
+
 /* CORE21 incorporate error in here if no vtable function */
 #define VTABLE_OR_DEFAULT(errcall, trans, is_fwd, func, default_func) \
   do { \
@@ -1097,11 +1100,16 @@ static inline pdl_error pdl__transtype_select(
     short flags = vtable->par_flags[i];
     if (flags & (PDL_PARAM_ISIGNORE|PDL_PARAM_ISTYPED|PDL_PARAM_ISCREATEALWAYS))
       continue;
-    if (*retval < pdl->datatype && (
+    pdl_datatypes new_transtype = pdl->datatype;
+    if (flags & PDL_PARAM_ISNOTCOMPLEX && new_transtype >= PDL_CF)
+      return pdl_make_error(PDL_EUSERERROR,
+        "%s: ndarray %s must be real, but is type %s",
+        vtable->name, vtable->par_names[i], PDL_TYPENAME(new_transtype));
+    if (*retval < new_transtype && (
       !(flags & PDL_PARAM_ISCREAT) ||
       ((flags & PDL_PARAM_ISCREAT) && !((pdl->state & PDL_NOMYDIMS) && pdl->trans_parent == NULL))
     ))
-      *retval = pdl->datatype;
+      *retval = new_transtype;
   }
   for (i=0; vtable->gentypes[i]!=-1; i++) {
     last_dtype = vtable->gentypes[i];
@@ -1135,7 +1143,7 @@ pdl_error pdl_type_coerce(pdl_trans *trans) {
     if (flags & PDL_PARAM_ISTYPED) {
       new_dtype = vtable->par_types[i];
       if (flags & PDL_PARAM_ISTPLUS) new_dtype = PDLMAX(new_dtype, trans_dtype);
-    } else if (flags & PDL_PARAM_ISREAL) {
+    } else if (flags & (PDL_PARAM_ISREAL|PDL_PARAM_ISNOTCOMPLEX)) {
       if (trans_dtype >= PDL_CF) new_dtype = trans_dtype - (PDL_CF - PDL_F);
     } else if (flags & PDL_PARAM_ISCOMPLEX) {
       if (trans_dtype < PDL_CF) new_dtype = PDLMAX(PDL_CF, trans_dtype + (PDL_CF - PDL_F));

lib/PDL/PP.pod

@@ -909,6 +909,10 @@ and C<Doc> omitted):
     Code => '$c() = $r();'
   );
 
+As of 2.096, there is also a C<!complex> type, which means if a
+complex-valued ndarray is supplied to the operation, an error will
+be thrown. In the normal case, its type will be as if C<real> were given.
+
 Finally, there are the C<type+> qualifiers. Let's illustrate the C<int+>
 qualifier with the actual definition of sumover:
 

lib/PDL/PP/PdlParObj.pm

@@ -10,7 +10,7 @@ our %INVALID_PAR = map +($_=>1), qw(
 );
 
 my $typeregex = join '|', map $_->ppforcetype, types;
-my $complex_regex = join '|', qw(real complex);
+my $complex_regex = join '|', qw(real complex !complex);
 our $sqbr_re = qr/\[([^]]*)\]/x;
 our $pars_re = qr/^
 	\s*(?:($complex_regex|$typeregex)\b([+]*)|)\s*	# $1,2: first option then plus
@@ -27,11 +27,13 @@ my %flag2info = (
   phys => [[qw(FlagPhys)]],
   real => [[qw(FlagTypeOverride FlagReal)]],
   complex => [[qw(FlagTypeOverride FlagComplex)]],
+  '!complex' => [[qw(FlagTypeOverride FlagNotComplex)]],
   (map +($_->ppforcetype => [[qw(FlagTypeOverride FlagTyped)], 'Type']), types),
 );
 my %flag2c = qw(
   FlagReal PDL_PARAM_ISREAL
   FlagComplex PDL_PARAM_ISCOMPLEX
+  FlagNotComplex PDL_PARAM_ISNOTCOMPLEX
   FlagTyped PDL_PARAM_ISTYPED
   FlagTplus PDL_PARAM_ISTPLUS
   FlagCreat PDL_PARAM_ISCREAT
@@ -144,7 +146,7 @@ sub getcreatedims {
 sub adjusted_type {
   my ($this, $generic) = @_;
   confess "adjusted_type given undefined generic type\n" if !defined $generic;
-  return $generic->realversion if $this->{FlagReal};
+  return $generic->realversion if $this->{FlagReal} || $this->{FlagNotComplex};
   return $generic->complexversion if $this->{FlagComplex};
   return $generic unless $this->{FlagTyped};
   return $this->{Type}->numval > $generic->numval

lib/PDL/Primitive.pd

@@ -2986,22 +2986,11 @@ for my $func ( [
 ###############################################################
 
 pp_def('interpolate',
-       HandleBad => 0,
-       BadDoc => 'needs major (?) work to handles bad values',
-	Pars => 'real xi(); real x(n); y(n); [o] yi(); int [o] err()',
-	GenericTypes => $AF,
-	PMCode=>pp_line_numbers(__LINE__, <<'EOD'),
-		sub PDL::interpolate {
-			my ($xi, $x, $y, $yi, $err) = @_;
-			croak "x must be real" if (ref($x) && ! $x->type->real);
-			croak "xi must be real" if (ref($xi) && ! $xi->type->real);
-			$yi //= PDL->null;
-			$err //= PDL->null;
-			PDL::_interpolate_int($xi, $x, $y, $yi, $err);
-			($yi, $err);
-		}
-EOD
-	Code => '
+  HandleBad => 0,
+  BadDoc => 'needs major (?) work to handles bad values',
+  Pars => '!complex xi(); !complex x(n); y(n); [o] yi(); int [o] err()',
+  GenericTypes => $AF,
+  Code => pp_line_numbers(__LINE__, <<'EOF'),
 PDL_Indx n = $SIZE(n), n1 = n-1;
 broadcastloop %{
   PDL_Indx jl = -1, jh = n;
@@ -3027,8 +3016,8 @@ broadcastloop %{
   $yi() = d*$y(n => jl) + (1-d)*$y(n => jh);
   $err() = carp;
 %}
-', Doc=><<'EOD');
-
+EOF
+  Doc => <<'EOD',
 =for ref
 
 routine for 1D linear interpolation
@@ -3061,6 +3050,7 @@ C<$x> and C<$xi> must be real.
 =cut
 
 EOD
+);
 
 pp_add_exported('', 'interpol');
 pp_addpm(<<'EOD');