This is the mail archive of the
fortran@gcc.gnu.org
mailing list for the GNU Fortran project.
Patch for PR 16946: sum (array, mask) is not accepted
- From: Erik Schnetter <schnetter at aei dot mpg dot de>
- To: fortran at gcc dot gnu dot org
- Date: Tue, 10 Aug 2004 17:28:48 +0200
- Subject: Patch for PR 16946: sum (array, mask) is not accepted
-----BEGIN PGP SIGNED MESSAGE-----
Hash: SHA1
The enclosed patch implements the alternative syntaxes for the maxval,
minval, product, and sum intrinsics as of Fortran 2k draft, section
13.5.12. This syntax is also present in my Fortran 95 draft. This
should close PR 16946.
I implemented this in the same way in which the maxloc and minloc
intrinsics were already implemented. I used different routines because
in the Fortran 2k draft, maxloc and minloc have a different argument
list (an additional kind argument), although this is currently not
implemented in gfortran.
2004-08-10 Erik Schnetter <schnetter@aei.mpg.de>
PR fortran/16946
* check.c (gfc_check_reduction): New function.
(gfc_check_minval_maxval): Removed.
(gfc_check_product): Removed.
(gfc_check_sum): Removed.
* intrinsic.h: Add/remove declarations for these.
* gfortran.h: Add field f3red to union gfc_check_f.
* intrinsic.c (add_sym_3red): New function.
(add_functions): Register maxval, minval, product, and sum intrinsics
through add_sym_3red.
(check_specific): Handle f3red union field.
* iresolve.c: Whitespace change.
- -erik
- --
Erik Schnetter <schnetter@aei.mpg.de> http://www.aei.mpg.de/~eschnett/
My email is as private as my paper mail. I therefore support encrypting
and signing email messages. Get my PGP key from www.keyserver.net.
-----BEGIN PGP SIGNATURE-----
Version: GnuPG v1.2.4 (GNU/Linux)
iD8DBQFBGOmxm3uiSwno3f0RAuNnAKCIDpXbyovjs29Uaq/P8jvty5gL0gCgseVf
hjulJ5ljpeZe07FsQ1MchPI=
=umaK
-----END PGP SIGNATURE-----
Index: check.c
===================================================================
RCS file: /cvs/gcc/gcc/gcc/fortran/check.c,v
retrieving revision 1.7
diff -u -r1.7 check.c
--- check.c 14 Jun 2004 15:56:48 -0000 1.7
+++ check.c 10 Aug 2004 15:03:27 -0000
@@ -1135,20 +1135,50 @@
}
+/* Similar to minloc/maxloc, the argument list might need to be
+ reordered for the MINVAL, MAXVAL, PRODUCT, and SUM intrinsics. The
+ difference is that MINLOC/MAXLOC take an additional KIND argument.
+ The possibilities are:
+
+ Arg #2 Arg #3
+ NULL NULL
+ DIM NULL
+ MASK NULL
+ NULL MASK minval(array, mask=m)
+ DIM MASK
+
+ I.e. in the case of minval(array,mask), mask will be in the second
+ position of the argument list and we'll have to fix that up. */
+
try
-gfc_check_minval_maxval (gfc_expr * array, gfc_expr * dim, gfc_expr * mask)
+gfc_check_reduction (gfc_actual_arglist * ap)
{
+ gfc_expr *a, *m, *d;
- if (array_check (array, 0) == FAILURE)
+ a = ap->expr;
+ if (int_or_real_check (a, 0) == FAILURE
+ || array_check (a, 0) == FAILURE)
return FAILURE;
- if (int_or_real_check (array, 0) == FAILURE)
- return FAILURE;
+ d = ap->next->expr;
+ m = ap->next->next->expr;
- if (dim_check (dim, 1, 1) == FAILURE)
+ if (m == NULL && d != NULL && d->ts.type == BT_LOGICAL
+ && ap->next->name[0] == '\0')
+ {
+ m = d;
+ d = NULL;
+
+ ap->next->expr = NULL;
+ ap->next->next->expr = m;
+ }
+
+ if (d != NULL
+ && (scalar_check (d, 1) == FAILURE
+ || type_check (d, 1, BT_INTEGER) == FAILURE))
return FAILURE;
- if (mask != NULL && logical_array_check (mask, 2) == FAILURE)
+ if (m != NULL && type_check (m, 2, BT_LOGICAL) == FAILURE)
return FAILURE;
return SUCCESS;
@@ -1277,26 +1307,6 @@
try
-gfc_check_product (gfc_expr * array, gfc_expr * dim, gfc_expr * mask)
-{
-
- if (array_check (array, 0) == FAILURE)
- return FAILURE;
-
- if (numeric_check (array, 0) == FAILURE)
- return FAILURE;
-
- if (dim_check (dim, 1, 1) == FAILURE)
- return FAILURE;
-
- if (mask != NULL && logical_array_check (mask, 2) == FAILURE)
- return FAILURE;
-
- return SUCCESS;
-}
-
-
-try
gfc_check_radix (gfc_expr * x)
{
@@ -1553,26 +1563,6 @@
try
-gfc_check_sum (gfc_expr * array, gfc_expr * dim, gfc_expr * mask)
-{
-
- if (array_check (array, 0) == FAILURE)
- return FAILURE;
-
- if (numeric_check (array, 0) == FAILURE)
- return FAILURE;
-
- if (dim_check (dim, 1, 1) == FAILURE)
- return FAILURE;
-
- if (mask != NULL && logical_array_check (mask, 2) == FAILURE)
- return FAILURE;
-
- return SUCCESS;
-}
-
-
-try
gfc_check_transfer (gfc_expr * source ATTRIBUTE_UNUSED,
gfc_expr * mold ATTRIBUTE_UNUSED,
gfc_expr * size)
Index: gfortran.h
===================================================================
RCS file: /cvs/gcc/gcc/gcc/fortran/gfortran.h,v
retrieving revision 1.21
diff -u -r1.21 gfortran.h
--- gfortran.h 8 Aug 2004 12:28:25 -0000 1.21
+++ gfortran.h 10 Aug 2004 15:03:27 -0000
@@ -857,6 +857,7 @@
try (*f2)(struct gfc_expr *, struct gfc_expr *);
try (*f3)(struct gfc_expr *, struct gfc_expr *, struct gfc_expr *);
try (*f3ml)(gfc_actual_arglist *);
+ try (*f3red)(gfc_actual_arglist *);
try (*f4)(struct gfc_expr *, struct gfc_expr *, struct gfc_expr *,
struct gfc_expr *);
try (*f5)(struct gfc_expr *, struct gfc_expr *, struct gfc_expr *,
Index: intrinsic.c
===================================================================
RCS file: /cvs/gcc/gcc/gcc/fortran/intrinsic.c,v
retrieving revision 1.14
diff -u -r1.14 intrinsic.c
--- intrinsic.c 6 Aug 2004 21:46:56 -0000 1.14
+++ intrinsic.c 10 Aug 2004 15:03:28 -0000
@@ -506,6 +506,33 @@
(void*)0);
}
+/* MINVAL, MAXVAL, PRODUCT, and SUM also get special treatment because
+ their argument also might have to be reordered. */
+
+static void add_sym_3red (const char *name, int elemental,
+ int actual_ok, bt type, int kind,
+ try (*check)(gfc_actual_arglist *),
+ gfc_expr*(*simplify)(gfc_expr *,gfc_expr *,gfc_expr *),
+ void (*resolve)(gfc_expr *,gfc_expr *,gfc_expr *,gfc_expr *),
+ const char* a1, bt type1, int kind1, int optional1,
+ const char* a2, bt type2, int kind2, int optional2,
+ const char* a3, bt type3, int kind3, int optional3
+ ) {
+ gfc_check_f cf;
+ gfc_simplify_f sf;
+ gfc_resolve_f rf;
+
+ cf.f3red = check;
+ sf.f3 = simplify;
+ rf.f3 = resolve;
+
+ add_sym (name, elemental, actual_ok, type, kind, cf, sf, rf,
+ a1, type1, kind1, optional1,
+ a2, type2, kind2, optional2,
+ a3, type3, kind3, optional3,
+ (void*)0);
+}
+
/* Add the name of an intrinsic subroutine with three arguments to the list
of intrinsic names. */
@@ -1376,10 +1403,10 @@
make_generic ("maxloc", GFC_ISYM_MAXLOC);
- add_sym_3 ("maxval", 0, 1, BT_REAL, dr,
- gfc_check_minval_maxval, NULL, gfc_resolve_maxval,
- ar, BT_REAL, dr, 0, dm, BT_INTEGER, ii, 1,
- msk, BT_LOGICAL, dl, 1);
+ add_sym_3red ("maxval", 0, 1, BT_REAL, dr,
+ gfc_check_reduction, NULL, gfc_resolve_maxval,
+ ar, BT_REAL, dr, 0, dm, BT_INTEGER, ii, 1,
+ msk, BT_LOGICAL, dl, 1);
make_generic ("maxval", GFC_ISYM_MAXVAL);
@@ -1431,10 +1458,10 @@
make_generic ("minloc", GFC_ISYM_MINLOC);
- add_sym_3 ("minval", 0, 1, BT_REAL, dr,
- gfc_check_minval_maxval, NULL, gfc_resolve_minval,
- ar, BT_REAL, dr, 0, dm, BT_INTEGER, ii, 1,
- msk, BT_LOGICAL, dl, 1);
+ add_sym_3red ("minval", 0, 1, BT_REAL, dr,
+ gfc_check_reduction, NULL, gfc_resolve_minval,
+ ar, BT_REAL, dr, 0, dm, BT_INTEGER, ii, 1,
+ msk, BT_LOGICAL, dl, 1);
make_generic ("minval", GFC_ISYM_MINVAL);
@@ -1504,10 +1531,10 @@
make_generic ("present", GFC_ISYM_PRESENT);
- add_sym_3 ("product", 0, 1, BT_REAL, dr,
- gfc_check_product, NULL, gfc_resolve_product,
- ar, BT_REAL, dr, 0, dm, BT_INTEGER, ii, 1,
- msk, BT_LOGICAL, dl, 1);
+ add_sym_3red ("product", 0, 1, BT_REAL, dr,
+ gfc_check_reduction, NULL, gfc_resolve_product,
+ ar, BT_REAL, dr, 0, dm, BT_INTEGER, ii, 1,
+ msk, BT_LOGICAL, dl, 1);
make_generic ("product", GFC_ISYM_PRODUCT);
@@ -1686,10 +1713,10 @@
make_generic ("sqrt", GFC_ISYM_SQRT);
- add_sym_3 ("sum", 0, 1, BT_UNKNOWN, 0,
- gfc_check_sum, NULL, gfc_resolve_sum,
- ar, BT_REAL, dr, 0, dm, BT_INTEGER, ii, 1,
- msk, BT_LOGICAL, dl, 1);
+ add_sym_3red ("sum", 0, 1, BT_UNKNOWN, 0,
+ gfc_check_reduction, NULL, gfc_resolve_sum,
+ ar, BT_REAL, dr, 0, dm, BT_INTEGER, ii, 1,
+ msk, BT_LOGICAL, dl, 1);
make_generic ("sum", GFC_ISYM_SUM);
@@ -2460,7 +2487,15 @@
&expr->where) == FAILURE)
return FAILURE;
- if (specific->check.f3ml != gfc_check_minloc_maxloc)
+ if (specific->check.f3ml == gfc_check_minloc_maxloc)
+ /* This is special because we might have to reorder the argument
+ list. */
+ t = gfc_check_minloc_maxloc (*ap);
+ else if (specific->check.f3red == gfc_check_reduction)
+ /* This is also special because we also might have to reorder the
+ argument list. */
+ t = gfc_check_reduction (*ap);
+ else
{
if (specific->check.f1 == NULL)
{
@@ -2471,10 +2506,6 @@
else
t = do_check (specific, *ap);
}
- else
- /* This is special because we might have to reorder the argument
- list. */
- t = gfc_check_minloc_maxloc (*ap);
/* Check ranks for elemental intrinsics. */
if (t == SUCCESS && specific->elemental)
Index: intrinsic.h
===================================================================
RCS file: /cvs/gcc/gcc/gcc/fortran/intrinsic.h,v
retrieving revision 1.9
diff -u -r1.9 intrinsic.h
--- intrinsic.h 6 Aug 2004 21:46:56 -0000 1.9
+++ intrinsic.h 10 Aug 2004 15:03:28 -0000
@@ -70,17 +70,16 @@
try gfc_check_matmul (gfc_expr *, gfc_expr *);
try gfc_check_merge (gfc_expr *, gfc_expr *, gfc_expr *);
try gfc_check_minloc_maxloc (gfc_actual_arglist *);
-try gfc_check_minval_maxval (gfc_expr *, gfc_expr *, gfc_expr *);
try gfc_check_nearest (gfc_expr *, gfc_expr *);
try gfc_check_null (gfc_expr *);
try gfc_check_pack (gfc_expr *, gfc_expr *, gfc_expr *);
try gfc_check_precision (gfc_expr *);
try gfc_check_present (gfc_expr *);
-try gfc_check_product (gfc_expr *, gfc_expr *, gfc_expr *);
try gfc_check_radix (gfc_expr *);
try gfc_check_rand (gfc_expr *);
try gfc_check_range (gfc_expr *);
try gfc_check_real (gfc_expr *, gfc_expr *);
+try gfc_check_reduction (gfc_actual_arglist *);
try gfc_check_repeat (gfc_expr *, gfc_expr *);
try gfc_check_reshape (gfc_expr *, gfc_expr *, gfc_expr *, gfc_expr *);
try gfc_check_scale (gfc_expr *, gfc_expr *);
Index: iresolve.c
===================================================================
RCS file: /cvs/gcc/gcc/gcc/fortran/iresolve.c,v
retrieving revision 1.10
diff -u -r1.10 iresolve.c
--- iresolve.c 8 Aug 2004 12:28:25 -0000 1.10
+++ iresolve.c 10 Aug 2004 15:03:29 -0000
@@ -882,6 +882,7 @@
gfc_type_letter (array->ts.type), array->ts.kind);
}
+
void
gfc_resolve_minval (gfc_expr * f, gfc_expr * array, gfc_expr * dim,
gfc_expr * mask)