Skip to content

Commit

Permalink
fix select-function declarations for C23 - #30
Browse files Browse the repository at this point in the history
  • Loading branch information
@mohawk2
mohawk2 committed Feb 19, 2025
1 parent f99115b commit 793fd8f
Show file tree
Hide file tree
Showing 3 changed files with 32 additions and 68 deletions.
2 changes: 2 additions & 0 deletions Changes
View file
Original file line number Diff line number Diff line change
@@ -1,3 +1,5 @@
- fix select-function declarations for C23 (#30) - thanks @sebastic for report

0.433 2025-01-06
- make Trans::toreal do nothing if given real-typed data

Expand Down
47 changes: 14 additions & 33 deletions lib/PDL/LinearAlgebra/Complex.pd
View file
Original file line number Diff line number Diff line change
Expand Up @@ -32,18 +32,14 @@ typedef PDL_Long logical;
typedef PDL_Long integer;
typedef PDL_Long ftnlen;

#ifdef __cplusplus
typedef logical (*L_fp)(...);
#else
typedef logical (*L_fp)();
#endif

#ifndef min
#define min(a,b) ((a) <= (b) ? (a) : (b))
#endif
#ifndef max
#define max(a,b) ((a) >= (b) ? (a) : (b))
#endif
#define DEF_SEL_FUNC(letter, letter2, args) \
void letter ## letter2 ## select_func_set(SV* func); \
logical letter ## letter2 ## select_wrapper args; \
typedef logical (*L_ ## letter ## letter2 ## p) args;
DEF_SEL_FUNC(f, , (complex float *p))
DEF_SEL_FUNC(d, , (complex double *p))
DEF_SEL_FUNC(f, g, (complex float *p, complex float *q))
DEF_SEL_FUNC(d, g, (complex double *p, complex double *q))

extern integer FORTRAN(ilaenv)(integer *ispec, char *name__, char *opts, integer *n1,
integer *n2, integer *n3, integer *n4, ftnlen name_len, ftnlen
Expand Down Expand Up @@ -810,16 +806,9 @@ EOF
}
');

pp_addhdr('
void fselect_func_set(SV* func);
void dselect_func_set(SV* func);
PDL_Long fselect_wrapper(float *p);
PDL_Long dselect_wrapper(double *p);
');

pp_defc("gees",
_decl => <<'EOF',
extern int FORTRAN($TFD(c,z)gees)(char *jobvs, char *sort, L_fp select, integer *n,
extern int FORTRAN($TFD(c,z)gees)(char *jobvs, char *sort, L_$TFD(f,d)p select, integer *n,
$GENERIC() *a, integer *lda, integer *sdim, $GENERIC() *w,
$GENERIC() *vs, integer *ldvs, $GENERIC() *work,
integer *lwork, $GENERIC() *rwork, logical *bwork, integer *info);
Expand Down Expand Up @@ -906,7 +895,7 @@ Complex version of L<PDL::LinearAlgebra::Real/gees>

pp_defc("geesx",
_decl => <<'EOF',
extern int FORTRAN($TFD(c,z)geesx)(char *jobvs, char *sort, L_fp select, char * sense,
extern int FORTRAN($TFD(c,z)geesx)(char *jobvs, char *sort, L_$TFD(f,d)p select, char * sense,
integer *n, $GENERIC() *a, integer *lda, integer *sdim, $GENERIC() *w,
$GENERIC() *vs, integer *ldvs, $GENERIC() *rconde, $GENERIC() *rcondv,
$GENERIC() *work, integer *lwork, $GENERIC() *rwork,
Expand Down Expand Up @@ -1007,16 +996,9 @@ Complex version of L<PDL::LinearAlgebra::Real/geesx>
case info is set to N+2.
');

pp_addhdr('
void fgselect_func_set(SV* func);
void dgselect_func_set(SV* func);
PDL_Long fgselect_wrapper(float *p);
PDL_Long dgselect_wrapper(double *p);
');

pp_defc("gges",
_decl => <<'EOF',
extern int FORTRAN($TFD(c,z)gges)(char *jobvsl, char *jobvsr, char *sort, L_fp
extern int FORTRAN($TFD(c,z)gges)(char *jobvsl, char *jobvsr, char *sort, L_$TFD(f,d)gp
delctg, integer *n, $GENERIC() *a, integer *lda, $GENERIC() *b,
integer *ldb, integer *sdim, $GENERIC() *alpha,
$GENERIC() *beta, $GENERIC() *vsl, integer *ldvsl, $GENERIC() *vsr,
Expand Down Expand Up @@ -1116,7 +1098,7 @@ Complex version of L<PDL::LinearAlgebra::Real/ggees>

pp_defc("ggesx",
_decl => <<'EOF',
extern int FORTRAN($TFD(c,z)ggesx)(char *jobvsl, char *jobvsr, char *sort, L_fp
extern int FORTRAN($TFD(c,z)ggesx)(char *jobvsl, char *jobvsr, char *sort, L_$TFD(f,d)gp
delctg, char *sense, integer *n, $GENERIC() *a, integer *lda, $GENERIC() *b,
integer *ldb, integer *sdim, $GENERIC() *alpha,
$GENERIC() *beta, $GENERIC() *vsl, integer *ldvsl, $GENERIC() *vsr,
Expand Down Expand Up @@ -1174,10 +1156,10 @@ EOF
integer i__1 = maxwrk;
integer i__2 = $SIZE(n) + $SIZE(n) * FORTRAN(ilaenv)(&c__1, "ZUNGQR"
, " ", &(integer){$SIZE(n)}, &c__1, &(integer){$SIZE(n)}, &c_n1, (ftnlen)6, (ftnlen)1);
maxwrk = max(i__1,i__2);
maxwrk = PDLMAX(i__1,i__2);
pjobvsl = \'V\';
}
lwork = max(maxwrk,minwrk);
lwork = PDLMAX(maxwrk,minwrk);

{
$GENERIC() *work = ($GENERIC() *)malloc( 2 * lwork * sizeof($GENERIC()));
Expand Down Expand Up @@ -2582,7 +2564,6 @@ EOF
# COMPUTATIONAL LEVEL ROUTINES
#
################################################################################
# TODO IPIV = min(m,n)
pp_defc("getrf",
_decl => <<'EOF',
extern int FORTRAN($TFD(c,z)getrf)(integer *m, integer *n, $GENERIC() *a, integer *
Expand Down
51 changes: 16 additions & 35 deletions lib/PDL/LinearAlgebra/Real.pd
View file
Original file line number Diff line number Diff line change
Expand Up @@ -46,18 +46,14 @@ typedef PDL_Long logical;
typedef PDL_Long integer;
typedef PDL_Long ftnlen;

#ifdef __cplusplus
typedef logical (*L_fp)(...);
#else
typedef logical (*L_fp)();
#endif

#ifndef min
#define min(a,b) ((a) <= (b) ? (a) : (b))
#endif
#ifndef max
#define max(a,b) ((a) >= (b) ? (a) : (b))
#endif
#define DEF_SEL_FUNC(letter, letter2, args) \
void letter ## letter2 ## select_func_set(SV* func); \
logical letter ## letter2 ## select_wrapper args; \
typedef logical (*L_ ## letter ## letter2 ## p) args;
DEF_SEL_FUNC(f, , (float *wr, float *wi))
DEF_SEL_FUNC(d, , (double *wr, double *wi))
DEF_SEL_FUNC(f, g, (float *zr, float *zi, float *d))
DEF_SEL_FUNC(d, g, (double *zr, double *zi, double *d))

static integer c_zero = 0;
static integer c_nine = 9;
Expand Down Expand Up @@ -423,8 +419,8 @@ pp_def("gesdd",
$GENERIC() *work;
if (tra == \'N\'){
smlsiz = FORTRAN(ilaenv)(&c_nine, "SGESDD", " ", &c_zero, &c_zero, &c_zero, &c_zero, (ftnlen)6, (ftnlen)1);
lwork = max(14*min($SIZE(m),$SIZE(n))+4, 10*min($SIZE(m),
$SIZE(n))+2+ smlsiz*(smlsiz+8)) + max($SIZE(m),$SIZE(n));
lwork = PDLMAX(14*PDLMIN($SIZE(m),$SIZE(n))+4, 10*PDLMIN($SIZE(m),
$SIZE(n))+2+ smlsiz*(smlsiz+8)) + PDLMAX($SIZE(m),$SIZE(n));
}
work = ($GENERIC() *) malloc(lwork * sizeof($GENERIC()));
FORTRAN($TFD(s,d)gesdd)(
Expand Down Expand Up @@ -1664,13 +1660,6 @@ and rcondv, see section 4.11 of LAPACK User\'s Guide.

');

pp_addhdr('
void fselect_func_set(SV* func);
void dselect_func_set(SV* func);
PDL_Long fselect_wrapper(float *wr, float *wi);
PDL_Long dselect_wrapper(double *wr, double *wi);
');

pp_def("gees",
HandleBad => 0,
Pars => '[io]A(n,n); int jobvs(); int sort(); [o]wr(n); [o]wi(n); [o]vs(p,p); int [o]sdim(); int [o]info(); int [t]bwork(bworkn);',
Expand All @@ -1685,7 +1674,7 @@ pp_def("gees",
char psort = \'N\';
integer lwork = -1;

extern int FORTRAN($TFD(s,d)gees)(char *jobvs, char *sort, L_fp select, integer *n,
extern int FORTRAN($TFD(s,d)gees)(char *jobvs, char *sort, L_$TFD(f,d)p select, integer *n,
$GENERIC() *a, integer *lda, integer *sdim, $GENERIC() *wr,
$GENERIC() *wi, $GENERIC() *vs, integer *ldvs, $GENERIC() *work,
integer *lwork, logical *bwork, integer *info);
Expand Down Expand Up @@ -1853,7 +1842,7 @@ pp_def("geesx",
integer liwork = 1;
integer *iwork;
char sens;
extern int FORTRAN($TFD(s,d)geesx)(char *jobvs, char *sort, L_fp select, char * sense,
extern int FORTRAN($TFD(s,d)geesx)(char *jobvs, char *sort, L_$TFD(f,d)p select, char * sense,
integer *n, $GENERIC() *a, integer *lda, integer *sdim, $GENERIC() *wr,
$GENERIC() *wi, $GENERIC() *vs, integer *ldvs, $GENERIC() *rconde, $GENERIC() *rcondv,
$GENERIC() *work, integer *lwork, integer *iwork, integer *liwork,
Expand Down Expand Up @@ -2038,13 +2027,6 @@ the form

');

pp_addhdr('
void fgselect_func_set(SV* func);
void dgselect_func_set(SV* func);
PDL_Long fgselect_wrapper(float *zr, float *zi, float *d);
PDL_Long dgselect_wrapper(double *zr, double *zi, double *d);
');

pp_def("gges",
HandleBad => 0,
Pars => '[io]A(n,n); int jobvsl();int jobvsr();int sort();[io]B(n,n);[o]alphar(n);[o]alphai(n);[o]beta(n);[o]VSL(m,m);[o]VSR(p,p);int [o]sdim();int [o]info(); int [t]bwork(bworkn);',
Expand All @@ -2058,7 +2040,7 @@ pp_def("gges",
Code => generate_code '
integer lwork = -1;
char pjobvsl = \'N\', pjobvsr = \'N\', psort = \'N\';
extern int FORTRAN($TFD(s,d)gges)(char *jobvsl, char *jobvsr, char *sort, L_fp
extern int FORTRAN($TFD(s,d)gges)(char *jobvsl, char *jobvsr, char *sort, L_$TFD(f,d)gp
delctg, integer *n, $GENERIC() *a, integer *lda, $GENERIC() *b,
integer *ldb, integer *sdim, $GENERIC() *alphar, $GENERIC() *alphai,
$GENERIC() *beta, $GENERIC() *vsl, integer *ldvsl, $GENERIC() *vsr,
Expand Down Expand Up @@ -2286,7 +2268,7 @@ pp_def("ggesx",
char psort = \'N\';
char psens = \'N\';
integer *iwork;
extern int FORTRAN($TFD(s,d)ggesx)(char *jobvsl, char *jobvsr, char *sort, L_fp
extern int FORTRAN($TFD(s,d)ggesx)(char *jobvsl, char *jobvsr, char *sort, L_$TFD(f,d)gp
delctg, char *sense, integer *n, $GENERIC() *a, integer *lda, $GENERIC() *b,
integer *ldb, integer *sdim, $GENERIC() *alphar, $GENERIC() *alphai,
$GENERIC() *beta, $GENERIC() *vsl, integer *ldvsl, $GENERIC() *vsr,
Expand Down Expand Up @@ -2327,10 +2309,10 @@ pp_def("ggesx",
integer i__1 = maxwrk;
integer i__2 = minwrk + $SIZE(n) * (integer)FORTRAN(ilaenv)(&c__1, "DORGQR"
, " ", &(integer){$SIZE(n)}, &c__1, &(integer){$SIZE(n)}, &c_n1, (ftnlen)6, (ftnlen)1);
maxwrk = (integer ) max(i__1,i__2);
maxwrk = (integer ) PDLMAX(i__1,i__2);
pjobvsl = \'V\';
}
lwork = (integer ) max(maxwrk,minwrk);
lwork = (integer ) PDLMAX(maxwrk,minwrk);

{
$GENERIC() *work = ($GENERIC() *)malloc(lwork * sizeof($GENERIC()));
Expand Down Expand Up @@ -5492,7 +5474,6 @@ problem
# COMPUTATIONAL LEVEL ROUTINES
#
################################################################################
# TODO IPIV = min(m,n)
pp_def("getrf",
HandleBad => 0,
Pars => '[io]A(m,n); int [o]ipiv(p=CALC(PDLMIN($SIZE(m),$SIZE(n)))); int [o]info()',
Expand Down

0 comments on commit 793fd8f

Please sign in to comment.