(Perl Data Language) aims to turn perl into an efficient numerical language for scientific computing (similar to IDL and MatLab).
| 01-pptest.t (PDL-2.082) | : | 01-pptest.t (PDL-2.083) |
|---|
| | |
| skipping to change at line 38 | | skipping to change at line 38 |
|---|
| 'ppcp.c' => <<'EOF', | | 'ppcp.c' => <<'EOF', |
| #include "pdl.h" | | #include "pdl.h" |
| /* to test the $P vaffining */ | | /* to test the $P vaffining */ |
| void ppcp(PDL_Byte *dst, PDL_Byte *src, int len) | | void ppcp(PDL_Byte *dst, PDL_Byte *src, int len) |
| { | | { |
| int i; | | int i; |
| for (i=0;i<len;i++) | | for (i=0;i<len;i++) |
| *dst++=*src++; | | *dst++=*src++; |
| } | | } |
| | |
|
| void tinplace_c1(int n, PDL_Float* data) | | |
| { | | |
| int i; | | |
| for (i=0;i<n;i++) { | | |
| data[i] = 599.0; | | |
| } | | |
| } | | |
| | | |
| void tinplace_c2(int n, PDL_Float* data1, PDL_Float* data2) | | void tinplace_c2(int n, PDL_Float* data1, PDL_Float* data2) |
| { | | { |
| int i; | | int i; |
| for (i=0;i<n;i++) { | | for (i=0;i<n;i++) { |
| data1[i] = 599.0; | | data1[i] = 599.0; |
| data2[i] = 699.0; | | data2[i] = 699.0; |
| } | | } |
| } | | } |
|
| | | |
| void tinplace_c3(int n, PDL_Float* data1, PDL_Float* data2, PDL_Float* data3) | | |
| { | | |
| int i; | | |
| for (i=0;i<n;i++) { | | |
| data1[i] = 599.0; | | |
| data2[i] = 699.0; | | |
| data3[i] = 799.0; | | |
| } | | |
| } | | |
| EOF | | EOF |
| | |
| 'tests.pd' => <<'EOF', | | 'tests.pd' => <<'EOF', |
| # make sure the deprecation mechanism throws warnings | | # make sure the deprecation mechanism throws warnings |
| pp_deprecate_module( infavor => "PDL::Test::Fancy" ); | | pp_deprecate_module( infavor => "PDL::Test::Fancy" ); |
| our $VERSION = '0.01'; # so the Makefile.PL's VERSION_FROM picks it up | | our $VERSION = '0.01'; # so the Makefile.PL's VERSION_FROM picks it up |
| pp_setversion(qq{'0.01'}); # this doesn't use $VERSION only to check a bug is fi
xed | | pp_setversion(qq{'0.01'}); # this doesn't use $VERSION only to check a bug is fi
xed |
| pp_add_macros(SUCC => sub { "($_[0] + 1)" }); | | pp_add_macros(SUCC => sub { "($_[0] + 1)" }); |
| | |
|
| sub pp_deft { | | |
| my ($name,%hash) = @_; | | |
| ## $hash{Doc} = "=for ref\n\ninternal\n\nonly for internal testing purposes\n | | |
| "; | | |
| $hash{Doc} = undef; | | |
| $name = "test_$name"; # prepend test_ to name | | |
| pp_def($name,%hash); | | |
| } | | |
| | | |
| pp_addhdr(' | | pp_addhdr(' |
| void ppcp(PDL_Byte *dst, PDL_Byte *src, int len); | | void ppcp(PDL_Byte *dst, PDL_Byte *src, int len); |
| '); | | '); |
| | |
| # test the $P vaffine behaviour | | # test the $P vaffine behaviour |
| # when 'phys' flag is in. | | # when 'phys' flag is in. |
|
| pp_deft('foop', | | pp_def('foop', |
| Pars => 'byte [phys]a1(n); byte [o,phys]b(n)', | | Pars => 'byte [phys]a1(n); byte [o,phys]b(n)', |
| GenericTypes => [B], | | GenericTypes => [B], |
| Code => 'ppcp($P(b),$P(a1),$SIZE(n));', | | Code => 'ppcp($P(b),$P(a1),$SIZE(n));', |
| ); | | ); |
| | |
| # test single-used phys dim of 1 ok | | # test single-used phys dim of 1 ok |
|
| pp_deft('foop1', | | pp_def('foop1', |
| Pars => 'byte a1(z); byte [o,phys]b(n)', | | Pars => 'byte a1(z); byte [o,phys]b(n)', |
| GenericTypes => [B], | | GenericTypes => [B], |
| Code => 'ppcp($P(b),$P(a1),$SIZE(n));', | | Code => 'ppcp($P(b),$P(a1),$SIZE(n));', |
| ); | | ); |
| | |
| # float qualifier | | # float qualifier |
| # and also test if numerals in variable name work | | # and also test if numerals in variable name work |
|
| pp_deft( | | pp_def( |
| 'fsumover', | | 'fsumover', |
| Pars => 'a1(n); float [o]b();', | | Pars => 'a1(n); float [o]b();', |
| Code => 'PDL_Float tmp = 0; | | Code => 'PDL_Float tmp = 0; |
| loop(n) %{ tmp += $a1(); %} | | loop(n) %{ tmp += $a1(); %} |
| $b() = tmp;' | | $b() = tmp;' |
| ); | | ); |
| | |
| # test GENERIC with type+ qualifier | | # test GENERIC with type+ qualifier |
|
| pp_deft( | | pp_def( |
| 'nsumover', | | 'nsumover', |
| Pars => 'a(n); int+ [o]b();', | | Pars => 'a(n); int+ [o]b();', |
| Code => '$GENERIC(b) tmp = 0; | | Code => '$GENERIC(b) tmp = 0; |
| loop(n) %{ tmp += $a(); %} | | loop(n) %{ tmp += $a(); %} |
| $b() = tmp;' | | $b() = tmp;' |
| ); | | ); |
| | |
| # test to set named dim with 'OtherPar' | | # test to set named dim with 'OtherPar' |
|
| pp_deft('setdim', | | pp_def('setdim', |
| Pars => '[o] a(n)', | | Pars => '[o] a(n)', |
| OtherPars => 'int ns => n', | | OtherPars => 'int ns => n', |
| Code => 'loop(n) %{ $a() = n; %}', | | Code => 'loop(n) %{ $a() = n; %}', |
| ); | | ); |
| | |
|
| pp_deft("gelsd", | | pp_def("gelsd", |
| Pars => '[io,phys]A(m,n); [io,phys]B(p,q); [phys]rcond(); [o,phys]s(r);
int [o,phys]rank();int [o,phys]info()', | | Pars => '[io,phys]A(m,n); [io,phys]B(p,q); [phys]rcond(); [o,phys]s(r);
int [o,phys]rank();int [o,phys]info()', |
| RedoDimsCode => '$SIZE(r) = PDLMIN($SIZE(m),$SIZE(n));', | | RedoDimsCode => '$SIZE(r) = PDLMIN($SIZE(m),$SIZE(n));', |
| GenericTypes => ['F'], | | GenericTypes => ['F'], |
| Code => '$CROAK("croaking");' | | Code => '$CROAK("croaking");' |
| ); | | ); |
| | |
|
| pp_deft('fooseg', | | pp_def('fooseg', |
| Pars => 'a(n); [o]b(n);', | | Pars => 'a(n); [o]b(n);', |
| Code => ' | | Code => ' |
| loop(n) %{ $b() = $a(); %} | | loop(n) %{ $b() = $a(); %} |
| '); | | '); |
| | |
| # adapted from PDL::NDBin: if in=null and b is a scalar, was SEGV-ing | | # adapted from PDL::NDBin: if in=null and b is a scalar, was SEGV-ing |
|
| pp_deft( '_flatten_into', | | pp_def( '_flatten_into', |
| Pars => "in(m); indx b(m); [o] idx(m)", | | Pars => "in(m); indx b(m); [o] idx(m)", |
| Code => ' | | Code => ' |
| loop(m) %{ $idx() = $in(); %} | | loop(m) %{ $idx() = $in(); %} |
| ', | | ', |
| ); | | ); |
| | |
| pp_addhdr << 'EOH'; | | pp_addhdr << 'EOH'; |
|
| void tinplace_c1(int n, PDL_Float* data); | | |
| void tinplace_c2(int n, PDL_Float* data1, PDL_Float* data2); | | void tinplace_c2(int n, PDL_Float* data1, PDL_Float* data2); |
|
| void tinplace_c3(int n, PDL_Float* data1, PDL_Float* data2, PDL_Float* data3); | | |
| EOH | | EOH |
| | |
|
| pp_deft('fooflow1', | | pp_def('fooflow2', |
| Pars => '[o,nc]a(n)', | | Pars => '[io]a(n);[io]b(n)', |
| GenericTypes => ['F'], | | |
| Code => 'tinplace_c1($SIZE(n),$P(a));', | | |
| ); | | |
| | |
| pp_deft('fooflow2', | | |
| Pars => '[o,nc]a(n);[o,nc]b(n)', | | |
| GenericTypes => ['F'], | | GenericTypes => ['F'], |
| Code => 'tinplace_c2($SIZE(n),$P(a),$P(b));', | | Code => 'tinplace_c2($SIZE(n),$P(a),$P(b));', |
| ); | | ); |
| | |
|
| pp_deft('fooflow3', | | pp_def( 'broadcastloop_continue', |
| Pars => '[o,nc]a(n);[o,nc]b(n);[o,nc]c(n)', | | |
| GenericTypes => ['F'], | | |
| Code => 'tinplace_c3($SIZE(n),$P(a),$P(b),$P(c));', | | |
| ); | | |
| | |
| pp_deft( 'broadcastloop_continue', | | |
| Pars => 'in(); [o] out()', | | Pars => 'in(); [o] out()', |
| Code => q[ | | Code => q[ |
| int cnt = 0; | | int cnt = 0; |
| threadloop %{ | | threadloop %{ |
| | |
| if ( ++cnt %2 ) | | if ( ++cnt %2 ) |
| continue; | | continue; |
| | |
| $out() = $in(); | | $out() = $in(); |
| %} | | %} |
| ], | | ], |
| ); | | ); |
| | |
|
| pp_deft('succ', | | pp_def('succ', |
| Pars => 'a(); [o] b()', | | Pars => 'a(); [o] b()', |
| GenericTypes => ['F'], | | GenericTypes => ['F'], |
| Code => '$b() = $SUCC($a());', | | Code => '$b() = $SUCC($a());', |
| ); | | ); |
| | |
| # test whitespace problem with POD and pp_addxs | | # test whitespace problem with POD and pp_addxs |
| pp_addxs( '', <<'EOXS' ); | | pp_addxs( '', <<'EOXS' ); |
| | |
| int | | int |
| just_one() | | just_one() |
| | |
| skipping to change at line 219 | | skipping to change at line 179 |
|---|
| =cut | | =cut |
| | |
| EOXS | | EOXS |
| | |
| # test whitespace problem with pp_line_numbers and pp_add_boot | | # test whitespace problem with pp_line_numbers and pp_add_boot |
| pp_add_boot pp_line_numbers(__LINE__, q{ | | pp_add_boot pp_line_numbers(__LINE__, q{ |
| /* nothing happening here */ | | /* nothing happening here */ |
| }); | | }); |
| | |
| # test fixed value for named dim, wrong Code for simplicity | | # test fixed value for named dim, wrong Code for simplicity |
|
| pp_deft('Cpow', | | pp_def('Cpow', |
| Pars => 'a(m=2); b(m=2); [o]c(m=2)', | | Pars => 'a(m=2); b(m=2); [o]c(m=2)', |
| Code => '$c(m => 0) = $a(m => 0) + $b(m => 0);', | | Code => '$c(m => 0) = $a(m => 0) + $b(m => 0);', |
| ); | | ); |
| | |
| # test XS args with OtherPars | | # test XS args with OtherPars |
|
| pp_deft('gl_arrows', | | pp_def('gl_arrows', |
| Pars => 'coords(tri=3,n); int indsa(); int indsb();', | | Pars => 'coords(tri=3,n); int indsa(); int indsb();', |
| OtherPars => 'float headlen; float width;', | | OtherPars => 'float headlen; float width;', |
| Code => ';', # do nothing | | Code => ';', # do nothing |
| ); | | ); |
| | |
| # test XS args with funky Pars ordering | | # test XS args with funky Pars ordering |
|
| pp_deft('polyfill_pp', | | pp_def('polyfill_pp', |
| Pars => 'int [o,nc] im(m,n); float ps(two=2,np); int col()', | | Pars => 'int [io] im(m,n); float ps(two=2,np); int col()', |
| Code => ';', # do nothing | | Code => ';', # do nothing |
| ); | | ); |
| | |
| # test valid non-single-letter GenericTypes arg | | # test valid non-single-letter GenericTypes arg |
|
| pp_deft("rice_compress", | | pp_def("rice_compress", |
| Pars => 'in(n); [o]out(m); int[o]len(); lbuf(n)', | | Pars => 'in(n); [o]out(m); int[o]len(); lbuf(n)', |
| GenericTypes =>['B','S','US','L'], | | GenericTypes =>['B','S','US','L'], |
| Code => ';', # do nothing | | Code => ';', # do nothing |
| ); | | ); |
| | |
|
| pp_deft('output_op', | | pp_def('output_op', |
| Pars => 'in(n=2)', | | Pars => 'in(n=2)', |
| OtherPars => '[o] PDL_Anyval v0; [o] PDL_Anyval v1', | | OtherPars => '[o] PDL_Anyval v0; [o] PDL_Anyval v1', |
| Code => ' | | Code => ' |
| pdl_datatypes dt = $PDL(in)->datatype; | | pdl_datatypes dt = $PDL(in)->datatype; |
| ANYVAL_FROM_CTYPE($COMP(v0), dt, $in(n=>0)); | | ANYVAL_FROM_CTYPE($COMP(v0), dt, $in(n=>0)); |
| ANYVAL_FROM_CTYPE($COMP(v1), dt, $in(n=>1)); | | ANYVAL_FROM_CTYPE($COMP(v1), dt, $in(n=>1)); |
| ', | | ', |
| ); | | ); |
|
| pp_deft('output_op2', | | pp_def('output_op2', |
| Pars => 'in(n=2); [o] out()', | | Pars => 'in(n=2); [o] out()', |
| OtherPars => '[o] PDL_Anyval v0; [o] PDL_Anyval v1', | | OtherPars => '[o] PDL_Anyval v0; [o] PDL_Anyval v1', |
| Code => ' | | Code => ' |
| pdl_datatypes dt = $PDL(in)->datatype; | | pdl_datatypes dt = $PDL(in)->datatype; |
| ANYVAL_FROM_CTYPE($COMP(v0), dt, $in(n=>0)); | | ANYVAL_FROM_CTYPE($COMP(v0), dt, $in(n=>0)); |
| ANYVAL_FROM_CTYPE($COMP(v1), dt, $in(n=>1)); | | ANYVAL_FROM_CTYPE($COMP(v1), dt, $in(n=>1)); |
| ', | | ', |
| ); | | ); |
|
| pp_deft('output_op3', | | pp_def('output_op3', |
| Pars => 'in(n=2); [o] out()', | | Pars => 'in(n=2); [o] out()', |
| OtherPars => '[o] PDL_Anyval v0; [o] PDL_Anyval v1', | | OtherPars => '[o] PDL_Anyval v0; [o] PDL_Anyval v1', |
| Code => ' | | Code => ' |
| pdl_datatypes dt = $PDL(in)->datatype; | | pdl_datatypes dt = $PDL(in)->datatype; |
| ANYVAL_FROM_CTYPE($COMP(v0), dt, $in(n=>0)); | | ANYVAL_FROM_CTYPE($COMP(v0), dt, $in(n=>0)); |
| ANYVAL_FROM_CTYPE($COMP(v1), dt, $in(n=>1)); | | ANYVAL_FROM_CTYPE($COMP(v1), dt, $in(n=>1)); |
| ', | | ', |
|
| PMCode => 'sub PDL::test_output_op3 { goto &PDL::_test_output_op3_int }', | | PMCode => 'sub PDL::output_op3 { goto &PDL::_output_op3_int }', |
| | ); |
| | |
| | pp_def('incomp_dim', |
| | Pars => '[o] a();', |
| | OtherPars => 'PDL_Indx d[];', |
| | Code => '$a() = $COMP(d_count);', |
| ); | | ); |
| | |
| pp_addhdr(' | | pp_addhdr(' |
| typedef NV NV_ADD1; | | typedef NV NV_ADD1; |
| '); | | '); |
| pp_add_typemaps(string=><<'EOT'); | | pp_add_typemaps(string=><<'EOT'); |
| TYPEMAP: <<END_OF_TYPEMAP | | TYPEMAP: <<END_OF_TYPEMAP |
| TYPEMAP | | TYPEMAP |
| NV_ADD1 T_NV_ADD1 | | NV_ADD1 T_NV_ADD1 |
| | |
| INPUT | | INPUT |
| T_NV_ADD1 | | T_NV_ADD1 |
|
| $var = SvNV($arg) + 1; | | $var = SvNV($arg) + 1 |
| | |
| OUTPUT | | OUTPUT |
| T_NV_ADD1 | | T_NV_ADD1 |
| sv_setnv($arg, $var - 1); | | sv_setnv($arg, $var - 1); |
| END_OF_TYPEMAP | | END_OF_TYPEMAP |
| EOT | | EOT |
|
| pp_deft('typem', | | pp_def('typem', |
| Pars => 'int [o] out()', | | Pars => 'int [o] out()', |
|
| OtherPars => '[o] NV_ADD1 v1', | | OtherPars => '[io] NV_ADD1 v1', |
| Code => '$out() = $COMP(v1); $COMP(v1) = 8;', | | Code => '$out() = $COMP(v1); $COMP(v1) = 8;', |
| ); | | ); |
| | |
|
| | pp_def('incomp_in', |
| | Pars => '[o] out()', |
| | OtherPars => 'pdl *ins[]', |
| | RedoDimsCode => <<'EOC', |
| | pdl **ins = $COMP(ins); |
| | PDL_Indx i; |
| | for (i = 0; i < $COMP(ins_count); i++) { |
| | pdl *in = ins[i]; |
| | PDL_RETERROR(PDL_err, PDL->make_physdims(in)); |
| | if (in->ndims != 1) |
| | $CROAK("input ndarray %"IND_FLAG" has %"IND_FLAG" dims, not 1", i, in->ndims |
| | ); |
| | if (!$PRIV(bvalflag) && (in->state & PDL_BADVAL)) $PRIV(bvalflag) = 1; |
| | } |
| | EOC |
| | Code => <<'EOC', |
| | pdl **ins = $COMP(ins); |
| | PDL_Indx i; |
| | for (i = 0; i < $COMP(ins_count); i++) |
| | PDL_RETERROR(PDL_err, PDL->make_physical(ins[i])); |
| | $out() = 0; |
| | for (i = 0; i < $COMP(ins_count); i++) { |
| | pdl *in = ins[i]; |
| | PDL_Indx j; |
| | #define X_CAT_INNER(datatype_in, ctype_in, ppsym_in, ...) \ |
| | PDL_DECLARE_PARAMETER_BADVAL(ctype_in, 0, in, (in), 1) \ |
| | for(j=0; j<in->nvals; j++) { \ |
| | if ($PRIV(bvalflag) && PDL_ISBAD(in_physdatap[j], in_badval, ppsym_in)) cont |
| | inue; \ |
| | $out() += in_physdatap[j]; \ |
| | } |
| | PDL_GENERICSWITCH(PDL_TYPELIST2_ALL, in->datatype, X_CAT_INNER, $CROAK("Not a |
| | known data type code=%d", in->datatype)) |
| | #undef X_CAT_INNER |
| | } |
| | EOC |
| | ); |
| | |
| | pp_def('incomp_out', |
| | Pars => 'in(n)', |
| | OtherPars => 'PDL_Indx howmany; [o] pdl *outs[]', |
| | HandleBad => 1, |
| | CallCopy => 0, |
| | GenericTypes => [PDL::Types::ppdefs_all()], |
| | Code => <<'EOC', |
| | pdl **outs = malloc(($COMP(outs_count) = $COMP(howmany)) * sizeof(pdl*)); |
| | $COMP(outs) = outs; |
| | PDL_Indx i, ndims = $PDL(in)->ndims, dims[ndims]; |
| | for (i = 0; i < ndims; i++) dims[i] = $PDL(in)->dims[i]; |
| | for (i = 0; i < $COMP(outs_count); i++) { |
| | pdl *o = outs[i] = PDL->pdlnew(); |
| | if (!o) { for (i--; i >= 0; i--) PDL->destroy(outs[i]); free(outs); $CROAK("Fa |
| | iled to create ndarray"); } |
| | o->datatype = $PDL(in)->datatype; |
| | PDL_err = PDL->setdims(o, dims, ndims); |
| | if (PDL_err.error) { for (; i >= 0; i--) PDL->destroy(outs[i]); free(outs); re |
| | turn PDL_err; } |
| | PDL_err = PDL->allocdata(o); |
| | if (PDL_err.error) { for (; i >= 0; i--) PDL->destroy(outs[i]); free(outs); re |
| | turn PDL_err; } |
| | PDL_DECLARE_PARAMETER_BADVAL($GENERIC(in), 0, o, (o), 1) |
| | loop(n) %{ o_datap[n] = $in(); %} |
| | } |
| | EOC |
| | ); |
| | |
| | pp_def('index_prec', # check $a(n=>x+1) works |
| | Pars => 'in(n); [o]out()', |
| | Code => 'loop (n) %{ if (n > 1) $out() += $in(n=>n-1); %}', |
| | ); |
| | |
| | pp_def("diff_central", |
| | Pars => 'double x(); double [o] res();', |
| | OtherPars => 'SV* function;', |
| | Code => ';', |
| | ); |
| | |
| | # previously in t/inline-comment-test.t |
| | pp_addpm(pp_line_numbers(__LINE__-1, q{ sub myfunc { } })); |
| | |
| | pp_def('testinc', |
| | Pars => 'a(); [o] b()', |
| | Code => q{ |
| | /* emulate user debugging */ |
| | |
| | /* Why doesn't this work???!!!! */ |
| | threadloop %{ |
| | /* printf(" %f, %f\r", $a(), $b()); |
| | printf(" Here\n"); |
| | */ |
| | |
| | /* Sanity check */ |
| | $b() = $a() + 1; |
| | |
| | %} |
| | |
| | }, |
| | ); |
| | |
| | # make sure that if the word "broadcastloop" appears, later automatic broadcastl |
| | oops |
| | # will not be generated, even if the original broadcastloop was commented-out |
| | |
| | pp_def('testinc2', |
| | Pars => 'a(); [o] b()', |
| | Code => q{ |
| | /* emulate user debugging */ |
| | |
| | /* Why doesn't this work???!!!! */ |
| | /* threadloop %{ |
| | printf(" %f, %f\r", $a(), $b()); |
| | printf(" Here\n"); |
| | %} |
| | */ |
| | /* Sanity check */ |
| | $b() = $a() + 1; |
| | |
| | }, |
| | ); |
| | |
| | pp_def('or2', |
| | Pars => 'a(); b(); [o]c();', |
| | OtherPars => 'int swap; char *ign; int ign2', |
| | OtherParsDefaults => { swap => 0, ign=>'""', ign2=>0 }, |
| | ArgOrder => 1, |
| | Code => '$c() = $a() | $b();', |
| | GenericTypes => [qw(A B S U L K N P Q)], |
| | ); |
| | |
| | # from HMM |
| | pp_def('logadd', |
| | Pars => 'a(); b(); [o]c()', |
| | GenericTypes => [qw(F D LD)], |
| | Inplace=>['a'], ##-- can run inplace on a() |
| | Code => ';', |
| | ); |
| | |
| | pp_def('ftr', |
| | Pars => 'a(); [o]b()', |
| | Code => ';', |
| | FtrCode => " sv_setiv(perl_get_sv(\"main::FOOTERVAL\",TRUE), 1);\n", |
| | ); |
| | |
| pp_done; | | pp_done; |
| | |
| # this tests the bug with a trailing comment and *no* newline | | # this tests the bug with a trailing comment and *no* newline |
| EOF | | EOF |
| | |
| 't/all.t' => <<'EOF', | | 't/all.t' => <<'EOF', |
| use strict; | | use strict; |
| use warnings; | | use warnings; |
| use Test::More; | | use Test::More; |
| use Test::Warn; | | use Test::Warn; |
| | |
| skipping to change at line 329 | | skipping to change at line 431 |
|---|
| my($x,$y) = @_; | | my($x,$y) = @_; |
| my $c = abs($x-$y); | | my $c = abs($x-$y); |
| my $d = max($c); | | my $d = max($c); |
| return $d < 0.01; | | return $d < 0.01; |
| } | | } |
| | |
| my $x = xvals(zeroes(byte, 2, 4)); | | my $x = xvals(zeroes(byte, 2, 4)); |
| my $y; | | my $y; |
| | |
| # $P() affine tests | | # $P() affine tests |
|
| test_foop($x,($y=null)); | | foop($x,($y=null)); |
| ok( tapprox($x,$y) ) | | ok( tapprox($x,$y) ) |
| or diag $y; | | or diag $y; |
| | |
|
| test_foop($x->transpose,($y=null)); | | foop($x->transpose,($y=null)); |
| ok( tapprox($x->transpose,$y) ) | | ok( tapprox($x->transpose,$y) ) |
| or diag $y; | | or diag $y; |
| | |
| my $vaff = $x->dummy(2,3)->xchg(1,2); | | my $vaff = $x->dummy(2,3)->xchg(1,2); |
|
| test_foop($vaff,($y=null)); | | foop($vaff,($y=null)); |
| ok( tapprox($vaff,$y) ) | | ok( tapprox($vaff,$y) ) |
| or diag ($vaff, $vaff->dump); | | or diag ($vaff, $vaff->dump); |
| | |
|
| eval { test_foop($x,($y=pdl([1]))) }; | | eval { foop($x,($y=pdl([1]))) }; |
| isnt $@, '', '[phys] with multi-used mismatched dim of 1 throws exception'; | | isnt $@, '', '[phys] with multi-used mismatched dim of 1 throws exception'; |
| | |
|
| eval { test_foop(pdl([1]),($y=pdl([1]))) }; | | eval { foop(pdl([1]),($y=pdl([1]))) }; |
| is $@, '', '[phys] with multi-used matched dim of 1 no exception'; | | is $@, '', '[phys] with multi-used matched dim of 1 no exception'; |
| | |
|
| eval { test_foop1($x,($y=pdl([1]))) }; | | eval { foop1($x,($y=pdl([1]))) }; |
| is $@, '', '[phys] with single-used dim of 1 no exception'; | | is $@, '', '[phys] with single-used dim of 1 no exception'; |
| | |
| # float qualifier | | # float qualifier |
| $x = ones(byte,3000); | | $x = ones(byte,3000); |
|
| test_fsumover($x,($y=null)); | | fsumover($x,($y=null)); |
| is( $y->get_datatype, $PDL_F ); | | is( $y->get_datatype, $PDL_F ); |
| is( $y->at, 3000 ); | | is( $y->at, 3000 ); |
| | |
| # int+ qualifier | | # int+ qualifier |
| for (byte,short,ushort,long,float,double) { | | for (byte,short,ushort,long,float,double) { |
| $x = ones($_,3000); | | $x = ones($_,3000); |
|
| test_nsumover($x,($y=null)); | | nsumover($x,($y=null)); |
| is( $y->get_datatype, (($PDL_L > $_->[0]) ? $PDL_L : $_->[0]) ); | | is( $y->get_datatype, (($PDL_L > $_->[0]) ? $PDL_L : $_->[0]) ); |
| is( $y->at, 3000 ); | | is( $y->at, 3000 ); |
| } | | } |
| | |
|
| test_setdim(($x=null),10); | | setdim(($x=null),10); |
| is( join(',',$x->dims), "10" ); | | is( join(',',$x->dims), "10" ); |
| ok( tapprox($x,sequence(10)) ); | | ok( tapprox($x,sequence(10)) ); |
| | |
| { | | { |
| my @msg; | | my @msg; |
| local $SIG{__WARN__} = sub { push @msg, @_ }; | | local $SIG{__WARN__} = sub { push @msg, @_ }; |
|
| eval { nan(2,2)->test_gelsd(nan(2,2), -3) }; | | eval { nan(2,2)->gelsd(nan(2,2), -3) }; |
| like $@, qr/croaking/, 'right error message'; | | like $@, qr/croaking/, 'right error message'; |
| is_deeply \@msg, [], 'no warnings' or diag explain \@msg; | | is_deeply \@msg, [], 'no warnings' or diag explain \@msg; |
| } | | } |
| | |
| # this used to segv under solaris according to Karl | | # this used to segv under solaris according to Karl |
| { | | { |
| my $ny=7; | | my $ny=7; |
| $x = double xvals zeroes (20,$ny); | | $x = double xvals zeroes (20,$ny); |
|
| test_fooseg $x, $y=null; | | fooseg $x, $y=null; |
| ok( 1 ); # if we get here at all that is alright | | ok( 1 ); # if we get here at all that is alright |
| ok( tapprox($x,$y) ) | | ok( tapprox($x,$y) ) |
| or diag($x, "\n", $y); | | or diag($x, "\n", $y); |
| } | | } |
| | |
|
| eval { test__flatten_into(null, 2) }; | | eval { _flatten_into(null, 2) }; |
| ok 1; #was also segfaulting | | ok 1; #was also segfaulting |
| | |
| # test the bug alluded to in the comments in pdl_changed (pdlapi.c) | | # test the bug alluded to in the comments in pdl_changed (pdlapi.c) |
| # used to segfault | | # used to segfault |
| my $xx=ones(float,3,4); | | my $xx=ones(float,3,4); |
| my $sl1 = $xx->slice('(0)'); | | my $sl1 = $xx->slice('(0)'); |
| my $sl11 = $sl1->slice(''); | | my $sl11 = $sl1->slice(''); |
| my $sl2 = $xx->slice('(1)'); | | my $sl2 = $xx->slice('(1)'); |
| my $sl22 = $sl2->slice(''); | | my $sl22 = $sl2->slice(''); |
| | |
|
| test_fooflow2($sl11, $sl22); | | fooflow2($sl11, $sl22); |
| | |
| ok(all $xx->slice('(0)') == 599); | | ok(all $xx->slice('(0)') == 599); |
| ok(all $xx->slice('(1)') == 699); | | ok(all $xx->slice('(1)') == 699); |
| | |
| # test that continues in a broadcastloop work | | # test that continues in a broadcastloop work |
| { | | { |
| my $in = sequence(10); | | my $in = sequence(10); |
| my $got = $in->zeroes; | | my $got = $in->zeroes; |
| my $exp = $in->copy; | | my $exp = $in->copy; |
| my $tmp = $exp->where( ! ($in % 2) ); | | my $tmp = $exp->where( ! ($in % 2) ); |
| $tmp .= 0; | | $tmp .= 0; |
| | |
|
| test_broadcastloop_continue( $in, $got ); | | broadcastloop_continue( $in, $got ); |
| | |
| ok( tapprox( $got, $exp ), "continue works in broadcastloop" ) | | ok( tapprox( $got, $exp ), "continue works in broadcastloop" ) |
| or do { diag "got : $got"; diag "expected: $exp" }; | | or do { diag "got : $got"; diag "expected: $exp" }; |
| } | | } |
| | |
|
| test_Cpow(sequence(2), 1); | | Cpow(sequence(2), 1); |
| | |
|
| test_polyfill_pp(zeroes(5,5), ones(2,3), 1); | | polyfill_pp(zeroes(5,5), ones(2,3), 1); |
| | eval { polyfill_pp(ones(2,3), 1) }; |
| | like $@, qr/Usage/; |
| | |
|
| is test_succ(2)."", 3, 'test pp_add_macros works'; | | is succ(2)."", 3, 'test pp_add_macros works'; |
| | |
|
| test_output_op([5,7], my $v0, my $v1); | | output_op([5,7], my $v0, my $v1); |
| is_deeply [$v0,$v1], [5,7], 'output OtherPars work'; | | is_deeply [$v0,$v1], [5,7], 'output OtherPars work'; |
|
| eval { test_output_op(sequence(2,3), my $v0, my $v1) }; | | ($v0, $v1) = output_op([5,7]); |
| | is_deeply [$v0,$v1], [5,7], 'output OtherPars work 1a'; |
| | eval { output_op(sequence(2,3), my $v0, my $v1) }; |
| isnt $@, '', 'broadcast with output OtherPars throws'; | | isnt $@, '', 'broadcast with output OtherPars throws'; |
| | |
|
| test_output_op2([5,7], my $v0_2, my $v1_2); | | output_op2([5,7], my $n=PDL->null, my $v0_2, my $v1_2); |
| is_deeply [$v0_2,$v1_2], [5,7], 'output OtherPars work 2'; | | is_deeply [$v0_2,$v1_2], [5,7], 'output OtherPars work 2'; |
|
| eval { test_output_op2(sequence(2,3), my $v0_2, my $v1_2) }; | | (undef, $v0_2, $v1_2) = output_op2([5,7]); |
| isnt $@, '', 'broadcast with output OtherPars throws 2'; | | is_deeply [$v0_2,$v1_2], [5,7], 'output OtherPars work 2a'; |
| | eval { output_op2(sequence(2,3), my $n=PDL->null, my $v0_2, my $v1_2) }; |
| | like $@, qr/Can't broadcast/, 'broadcast with output OtherPars throws 2'; |
| | |
|
| test_output_op3([5,7], my $out3 = PDL->null, my $v0_3, my $v1_3); | | output_op3([5,7], my $out3 = PDL->null, my $v0_3, my $v1_3); |
| is_deeply [$v0_3,$v1_3], [5,7], 'output OtherPars work 3' or diag "got: ",$v0_3,
" ",$v1_3; | | is_deeply [$v0_3,$v1_3], [5,7], 'output OtherPars work 3' or diag "got: ",$v0_3,
" ",$v1_3; |
| | |
|
| my $o = test_typem(my $oth = 3); | | incomp_dim(my $o = PDL->null, [0..3]); |
| | is "$o", 4; |
| | $o = incomp_dim([0..3]); |
| is "$o", 4; | | is "$o", 4; |
|
| is "$oth", 7; | | |
| | |
| done_testing; | | |
| EOF | | |
| | |
| ); | | |
| | |
| my %BADOTHERPARSFILES = ( | | |
| 'Makefile.PL' => <<'EOF', | | |
| use strict; | | |
| use warnings; | | |
| use ExtUtils::MakeMaker; | | |
| use PDL::Core::Dev; | | |
| my @pack = (["otherpars.pd", qw(Otherpars PDL::Otherpars)]); | | |
| sub MY::postamble { pdlpp_postamble(@pack) } | | |
| WriteMakefile(pdlpp_stdargs(@pack)); | | |
| EOF | | |
| 'otherpars.pd' => <<'EOF', | | |
| pp_def( "myexternalfunc", | | |
| Pars => " p(m); x(n); [o] y(); [t] work(wn); ", | | |
| OtherPars => 'int flags;', | | |
| RedoDimsCode => ' | | |
| int im = $PDL(p)->dims[0]; | | |
| int in = $PDL(x)->dims[0]; | | |
| int min = in + im * im; | | |
| int inw = $PDL(work)->dims[0]; | | |
| $SIZE(wn) = inw >= min ? inw : min;', | | |
| Code => 'int foo = 1; '); | | |
| | |
| pp_def( "myexternalfunc2", | | |
| Pars => "x(m);", | | |
| OtherPars => 'int I;', | | |
| Code => 'int foo = 1; ' | | |
| ); | | |
| | |
| pp_done(); | | |
| EOF | | |
| | |
| 't/all.t' => <<'EOF', | | |
| use strict; | | |
| use warnings; | | |
| use Test::More tests => 1; | | |
| use PDL::LiteF; | | |
| use_ok 'PDL::Otherpars'; | | |
| EOF | | |
| | |
| ); | | |
| | |
| my %BADPARSFILES = ( | | |
| 'Makefile.PL' => <<'EOF', | | |
| use strict; | | |
| use warnings; | | |
| use ExtUtils::MakeMaker; | | |
| use PDL::Core::Dev; | | |
| my @pack = (["otherpars.pd", qw(Otherpars PDL::Otherpars)]); | | |
| sub MY::postamble { pdlpp_postamble(@pack) } | | |
| WriteMakefile(pdlpp_stdargs(@pack)); | | |
| EOF | | |
| 'otherpars.pd' => <<'EOF', | | |
| pp_def( "myexternalfunc3", | | |
| Pars => "I(m);", | | |
| Code => 'int foo = 1; ' | | |
| ); | | |
| pp_done(); | | |
| EOF | | |
| | |
| 't/all.t' => <<'EOF', | | |
| use strict; | | |
| use warnings; | | |
| use Test::More tests => 1; | | |
| use PDL::LiteF; | | |
| use_ok 'PDL::Otherpars'; | | |
| EOF | | |
| | |
| ); | | |
| | |
| my %THREADTESTFILES = ( | | |
| 'Makefile.PL' => <<'EOF', | | |
| use strict; | | |
| use warnings; | | |
| use ExtUtils::MakeMaker; | | |
| use PDL::Core::Dev; | | |
| my @pack = (["threadtest.pd", qw(ThreadTest PDL::ThreadTest)]); | | |
| sub MY::postamble { | | |
| pdlpp_postamble(@pack); | | |
| }; # Add genpp rule | | |
| WriteMakefile(pdlpp_stdargs(@pack)); | | |
| EOF | | |
| | |
| 'threadtest.pd' => <<'EOF', | | |
| # previously in t/inline-comment-test.t | | |
| | |
| pp_addpm(pp_line_numbers(__LINE__-1, q{ sub myfunc { } })); | | |
| | |
| pp_def('testinc', | | |
| Pars => 'a(); [o] b()', | | |
| Code => q{ | | |
| /* emulate user debugging */ | | |
| | |
| /* Why doesn't this work???!!!! */ | | |
| threadloop %{ | | |
| /* printf(" %f, %f\r", $a(), $b()); | | |
| printf(" Here\n"); | | |
| */ | | |
| | |
| /* Sanity check */ | | |
| $b() = $a() + 1; | | |
| | |
| %} | | |
| | |
| }, | | |
| ); | | |
| | |
| # make sure that if the word "broadcastloop" appears, later automatic broadcastl | | |
| oops | | |
| # will not be generated, even if the original broadcastloop was commented-out | | |
| | |
|
| pp_def('testinc2', | | $o = typem(my $oth = 3); |
| Pars => 'a(); [o] b()', | | is "$o", 4; |
| Code => q{ | | is "$oth", 7; |
| /* emulate user debugging */ | | |
| | |
|
| /* Why doesn't this work???!!!! */ | | typem($o = PDL->null, $oth = 3); |
| /* threadloop %{ | | is "$o", 4; |
| printf(" %f, %f\r", $a(), $b()); | | is "$oth", 7; |
| printf(" Here\n"); | | |
| %} | | |
| */ | | |
| /* Sanity check */ | | |
| $b() = $a() + 1; | | |
| | |
|
| }, | | incomp_in($o = PDL->null, [sequence(3), sequence(byte, 4)]); |
| ); | | is "$o", 9; |
| | $o = incomp_in([sequence(3), sequence(byte, 4)]); |
| | is "$o", 9; |
| | my $one_bad = sequence(byte, 4); |
| | $one_bad->badflag(1); |
| | $one_bad->badvalue(2); |
| | $o = incomp_in([sequence(3), $one_bad]); |
| | is "$o", 7; |
| | incomp_in($o = PDL->null, []); |
| | is "$o", 0; |
| | incomp_in($o = PDL->null, undef); |
| | is "$o", 0; |
| | eval { incomp_in($o = PDL->null, 'hello') }; |
| | isnt $@, ''; |
| | |
| | incomp_out(sequence(3), 2, my $nds); |
| | is 0+@$nds, 2; |
| | is +($nds->[0]//'undef').'', "[0 1 2]"; |
| | $nds = incomp_out(sequence(3), 2); |
| | is 0+@$nds, 2; |
| | is +($nds->[0]//'undef').'', "[0 1 2]"; |
| | |
|
| pp_done(); | | is index_prec(sequence(2,6)->slice('(1)')).'', 24, 'index precedence OK'; |
| EOF | | |
| | |
|
| 't/all.t' => <<'EOF', | | eval { diff_central(pdl(1), sub {}) }; |
| use strict; | | is $@, ''; |
| use warnings; | | |
| use Test::More; | | |
| use PDL::LiteF; | | |
| use_ok 'PDL::ThreadTest'; | | |
| | |
|
| | { |
| my $x = sequence(3,3); | | my $x = sequence(3,3); |
| | |
| my $y = $x->testinc; | | my $y = $x->testinc; |
| | |
| ok(all ($y == $x+1), 'Sanity check runs correctly'); | | ok(all ($y == $x+1), 'Sanity check runs correctly'); |
| | |
| # Test the inability to comment-out a broadcastloop. This is documented on the | | # Test the inability to comment-out a broadcastloop. This is documented on the |
| # 11th page of the PDL::PP chapter of the PDL book. If somebody ever fixes this | | # 11th page of the PDL::PP chapter of the PDL book. If somebody ever fixes this |
| # wart, this test will fail, in which case the book's text should be updated. | | # wart, this test will fail, in which case the book's text should be updated. |
| $y = $x->testinc2; | | $y = $x->testinc2; |
| TODO: { | | TODO: { |
| # Note: This test appears to fail on Cygwin and some flavors of Linux. | | # Note: This test appears to fail on Cygwin and some flavors of Linux. |
| local $TODO = 'This test inexplicably passes on some machines'; | | local $TODO = 'This test inexplicably passes on some machines'; |
| ok(not (all $y == $x + 1), 'WART: commenting out a broadcastloop does no
t work') | | ok(not (all $y == $x + 1), 'WART: commenting out a broadcastloop does no
t work') |
| or diag("\$x is $x and \$y is $y"); | | or diag("\$x is $x and \$y is $y"); |
| } | | } |
|
| | } |
| | |
| | eval { is ''.or2(pdl(1), pdl(1), 0), '1' }; |
| | is $@, ''; |
| | |
| | eval { ldouble(4)->logadd(3) }; |
| | is $@, ''; |
| | |
| | undef $main::FOOTERVAL; |
| | ftr(1); |
| | is $main::FOOTERVAL, 1; |
| | |
| done_testing; | | done_testing; |
| EOF | | EOF |
| | |
| ); | | ); |
| | |
|
| do_tests(\%THREADTESTFILES); | | |
| do_tests(\%PPTESTFILES); | | do_tests(\%PPTESTFILES); |
|
| do_tests(\%BADOTHERPARSFILES, qr/Invalid OtherPars name/); | | |
| do_tests(\%BADPARSFILES, qr/Invalid Pars name/); | | |
| | |
| sub do_tests { | | sub do_tests { |
| my ($hash, $error_re, $dir) = @_; | | my ($hash, $error_re, $dir) = @_; |
| in_dir( | | in_dir( |
| sub { | | sub { |
| hash2files(File::Spec->curdir, $hash); | | hash2files(File::Spec->curdir, $hash); |
| local $ENV{PERL5LIB} = join $Config{path_sep}, @INC; | | local $ENV{PERL5LIB} = join $Config{path_sep}, @INC; |
| run_ok(qq{"$^X" Makefile.PL}); | | run_ok(qq{"$^X" Makefile.PL}); |
| run_ok(qq{"$Config{make}" test}, $error_re); | | run_ok(qq{"$Config{make}" test}, $error_re); |
| }, | | }, |
| | | |
| End of changes. 61 change blocks. |
|---|
| 230 lines changed or deleted | | 248 lines changed or added |
|---|
"Fossies" - the Fresh Open Source Software Archive 