pdl_from_array logic to treat unsigned correctly like ANYVAL_FROM_SV - …

…#511
PDLPorters · Dec 22, 2024 · 7f0f2e1 · 7f0f2e1
1 parent 008e233
commit 7f0f2e1
Show file tree

Hide file tree

Showing 5 changed files with 20 additions and 8 deletions.
diff --git a/Changes b/Changes
@@ -35,6 +35,7 @@
 - add Primitive::pchip_{chsp,chic,chim,chfe,chfd,chia,chid,chbs,bvalu}
 - repository directory structure now like a normal Perl distro with lib/ (#119)
 - IO::Dumper fixed to deal with multiple refs to same ndarray (#508,#509) - thanks @d-lamb for report, thanks @shawnlaffan for fix
+- stop pdl([-6,18446744073709551615,-4]) being pdl([-6,-1,-4]) (#511)
 
 2.095 2024-11-03
 - add PDL_GENTYPE_IS_{REAL,FLOATREAL,COMPLEX,SIGNED,UNSIGNED}_##ppsym (#502)

diff --git a/lib/PDL/Core/pdlcore.c b/lib/PDL/Core/pdlcore.c
@@ -742,7 +742,16 @@ PDL_Indx pdl_setav_ ## ppsym_dest(ctype_dest* dest_data, AV* av, \
         *dest_data = (ctype_dest) undefval; \
         undef_count++; \
       } else {              /* scalar case */ \
-        *dest_data = SvIOK(el) ? (ctype_dest) SvIV(el) : (ctype_dest) SvNV(el); \
+        if (!SvIOK(el)) { /* cf ANYVAL_FROM_SV, COPYCONVERT */ \
+          NV tmp_NV = SvNV(el); \
+          *dest_data = PDL_GENTYPE_IS_UNSIGNED_##ppsym_dest \
+            ? (ctype_dest)(intmax_t) tmp_NV \
+            : (ctype_dest)           tmp_NV; \
+        } else if (SvIsUV(el)) { \
+          *dest_data = (ctype_dest) SvUV(el); \
+        } else { \
+          *dest_data = (ctype_dest) SvIV(el); \
+        } \
       } \
       /* Pad dim if we are not deep enough */ \
       if (level < ndims-1) { \

diff --git a/lib/PDL/IO/Misc.pd b/lib/PDL/IO/Misc.pd
@@ -132,7 +132,7 @@ sub _burp_1D {
    } else {
       # could add POSIX::strtol for hex and octal support but
       # can't break float conversions (how?)
-      $data->slice("$start:$index") .= pdl($databox);
+      $data->slice("$start:$index") .= pdl($data->type, $databox);
    }
    $_[0] = [ $data, [] ];
 }

diff --git a/t/pdl_from_string.t b/t/pdl_from_string.t
@@ -345,11 +345,9 @@ like($@, qr/found disallowed character\(s\) 'po'/, 'Gives meaningful explanation
 
 # checks for croaking behavior for consecutive signs like +-2:
 eval{ pdl q[1 +-2 3] };
-isnt($@, '', 'Croaks when it finds consecutive signs');
-like($@, qr/found a \w+ sign/, 'Gives meaningful explanation of problem');
+like($@, qr/found a \w+ sign/, 'Good error when consecutive signs');
 eval{ pdl q[1 -+2 3] };
-isnt($@, '', 'Croaks when it finds consecutive signs');
-like($@, qr/found a \w+ sign/, 'Gives meaningful explanation of problem');
+like($@, qr/found a \w+ sign/, 'Good error when consecutive signs');
 
 # 'larger word' croak checks (36)
 foreach my $special (qw(bad inf pi)) {
@@ -403,6 +401,10 @@ while( my ($case_string, $expected_string) = each %$cases ) {
 	};
 }
 
+is pdl(ushort, ['-5'])."", "[65531]", "ushort-typed ['-5'] converted right";
+is pdl(ushort, '[-5]')."", "[65531]", "ushort-typed '[-5]' converted right";
+is pdl(ushort, [-5])."", "[65531]", "ushort-typed [-5] converted right";
+
 done_testing;
 
 # Basic 2D array

diff --git a/t/ufunc.t b/t/ufunc.t
@@ -139,14 +139,14 @@ is_pdl $x->modeover, longlong(3,0), "modeover";
 #   .... 0000 1010
 #   .... 1111 1100
 #OR:.... 1111 1110 = -2
-is pdl([10,0,-4])->borover(), -2, "borover with no BAD values";
+is longlong([10,0,-4])->borover(), -2, "borover with no BAD values";
 
 #     .... 1111 1111
 #     .... 1111 1010
 #     .... 1111 1100
 #AND: .... 1111 1000 = -8
 
-is( pdl([-6,~0,-4])->bandover(), -8, "bandover with no BAD values");
+is( longlong([-6,~0,-4])->bandover(), -8, "bandover with no BAD values");
 
 #   0000 1010
 #   1111 1100