Re: [gfortran] PR 14928: Fix two-argument variant of MINLOC/MAXLOC

[Tobias Schlüter <tobias dot schlueter at physik dot uni-muenchen dot de>]

Paul Brook wrote:
> You can't typecast a function pointer to (void *), it will break on targets 
> that use function descriptors (eg. ia64). You'll need to figure out another 
> way of doing this. Maybe add a new variant of add_sym_3, (similar to 
> gfc_add_sym_3s).
>
> Other than that, it looks ok.

Here's what I commited after testing. I added a new function, 
add_sym_3ml (ml for "minloc/maxloc"), and a new field f3ml to 
gfc_check_f. This new field is of the same type as the existing field 
f1m, if you prefer, I can unify them.

- Tobi

Index: ChangeLog
===================================================================
RCS file: /cvs/gcc/gcc/gcc/fortran/ChangeLog,v
retrieving revision 1.71
diff -u -p -r1.71 ChangeLog
--- ChangeLog   13 Jun 2004 23:23:24 -0000      1.71
+++ ChangeLog   14 Jun 2004 15:55:28 -0000
@@ -1,3 +1,15 @@
+2004-06-05  Tobias Schlueter  <tobias.schlueter@physik.uni-muenchen.de>
+        Andrew Vaught <andyv@firstinter.net>
+
+       PR fortran/14928
+       * gfortran.h (gfc_check_f): Add new field f3ml.
+       * check.c (gfc_check_minloc_maxloc): Take argument list instead
+       of individual arguments, reorder if necessary.
+       * intrinsic.h (gfc_check_minloc_maxloc): ... adapt prototype.
+       * intrinsic.c (add_sym_3ml): New function.
+       (add_functions): Change to add_sym_3ml for MINLOC, MAXLOC.
+       (check_specific): Catch special case MINLOC, MAXLOC.
+
 2004-06-14  Paul Brook  <paul@codesourcery.com>

        * intrinsic.c (add_sym_2s): Use correct function types.
Index: check.c
===================================================================
RCS file: /cvs/gcc/gcc/gcc/fortran/check.c,v
retrieving revision 1.6
diff -u -p -r1.6 check.c
--- check.c     12 Jun 2004 17:34:44 -0000      1.6
+++ check.c     14 Jun 2004 15:55:28 -0000
@@ -1096,54 +1096,41 @@ gfc_check_matmul (gfc_expr * matrix_a, g
          MASK       NULL
          NULL       MASK             minloc(array, mask=m)
          DIM        MASK
-*/
+
+   I.e. in the case of minloc(array,mask), mask will be in the second
+   position of the argument list and we'll have to fix that up.  */

 try
-gfc_check_minloc_maxloc (gfc_expr * array, gfc_expr * a2, gfc_expr * a3)
+gfc_check_minloc_maxloc (gfc_actual_arglist * ap)
 {
+  gfc_expr *a, *m, *d;

-  if (int_or_real_check (array, 0) == FAILURE)
+  a = ap->expr;
+  if (int_or_real_check (a, 0) == FAILURE
+      || array_check (a, 0) == FAILURE)
     return FAILURE;

-  if (array_check (array, 0) == FAILURE)
-    return FAILURE;
+  d = ap->next->expr;
+  m = ap->next->next->expr;

-  if (a3 != NULL)
+  if (m == NULL && d != NULL && d->ts.type == BT_LOGICAL
+      && ap->next->name[0] == '\0')
     {
-      if (logical_array_check (a3, 2) == FAILURE)
-       return FAILURE;
+      m = d;
+      d = NULL;

-      if (a2 != NULL)
-       {
-         if (scalar_check (a2, 1) == FAILURE)
-           return FAILURE;
-         if (type_check (a2, 1, BT_INTEGER) == FAILURE)
-           return FAILURE;
-       }
-    }
-  else
-    {
-      if (a2 != NULL)
-       {
-         switch (a2->ts.type)
-           {
-           case BT_INTEGER:
-             if (scalar_check (a2, 1) == FAILURE)
-               return FAILURE;
-             break;
-
-           case BT_LOGICAL:    /* The '2' makes the error message 
correct */
-             if (logical_array_check (a2, 2) == FAILURE)
-               return FAILURE;
-             break;
-
-           default:
-             type_check (a2, 1, BT_INTEGER);   /* Guaranteed to fail */
-             return FAILURE;
-           }
-       }
+      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 (m != NULL && type_check (m, 2, BT_LOGICAL) == FAILURE)
+    return FAILURE;
+
   return SUCCESS;
 }

Index: gfortran.h
===================================================================
RCS file: /cvs/gcc/gcc/gcc/fortran/gfortran.h,v
retrieving revision 1.12
diff -u -p -r1.12 gfortran.h
--- gfortran.h  12 Jun 2004 17:34:44 -0000      1.12
+++ gfortran.h  14 Jun 2004 15:55:28 -0000
@@ -821,6 +821,7 @@ typedef union
   try (*f1m)(gfc_actual_arglist *);
   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 (*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.9
diff -u -p -r1.9 intrinsic.c
--- intrinsic.c 13 Jun 2004 23:23:24 -0000      1.9
+++ intrinsic.c 14 Jun 2004 15:55:29 -0000
@@ -479,6 +479,33 @@ static void add_sym_3 (const char *name,
           (void*)0);
 }

+/* MINLOC and MAXLOC get special treatment because their argument
+   might have to be reordered.  */
+
+static void add_sym_3ml (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.f3ml = 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. */

@@ -1281,10 +1308,10 @@ add_functions (void)

   make_generic ("maxexponent", GFC_ISYM_NONE);

-  add_sym_3 ("maxloc", 0, 1, BT_INTEGER, di,
-            gfc_check_minloc_maxloc, NULL, gfc_resolve_maxloc,
-            ar, BT_REAL, dr, 0, dm, BT_INTEGER, ii, 1,
-            msk, BT_LOGICAL, dl, 1);
+  add_sym_3ml ("maxloc", 0, 1, BT_INTEGER, di,
+              gfc_check_minloc_maxloc, NULL, gfc_resolve_maxloc,
+              ar, BT_REAL, dr, 0, dm, BT_INTEGER, ii, 1,
+              msk, BT_LOGICAL, dl, 1);

   make_generic ("maxloc", GFC_ISYM_MAXLOC);

@@ -1336,10 +1363,10 @@ add_functions (void)

   make_generic ("minexponent", GFC_ISYM_NONE);

-  add_sym_3 ("minloc", 0, 1, BT_INTEGER, di,
-            gfc_check_minloc_maxloc, NULL, gfc_resolve_minloc,
-            ar, BT_REAL, dr, 0, dm, BT_INTEGER, ii, 1,
-            msk, BT_LOGICAL, dl, 1);
+  add_sym_3ml ("minloc", 0, 1, BT_INTEGER, di,
+              gfc_check_minloc_maxloc, NULL, gfc_resolve_minloc,
+              ar, BT_REAL, dr, 0, dm, BT_INTEGER, ii, 1,
+              msk, BT_LOGICAL, dl, 1);

   make_generic ("minloc", GFC_ISYM_MINLOC);

@@ -2331,14 +2358,21 @@ check_specific (gfc_intrinsic_sym * spec
                   &expr->where) == FAILURE)
     return FAILURE;

-  if (specific->check.f1 == NULL)
-    {
-      t = check_arglist (ap, specific, error_flag);
-      if (t == SUCCESS)
-       expr->ts = specific->ts;
-    }
+  if (specific->check.f3ml != gfc_check_minloc_maxloc)
+     {
+       if (specific->check.f1 == NULL)
+        {
+          t = check_arglist (ap, specific, error_flag);
+          if (t == SUCCESS)
+            expr->ts = specific->ts;
+        }
+       else
+        t = do_check (specific, *ap);
+     }
   else
-    t = do_check (specific, *ap);
+    /* 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.6
diff -u -p -r1.6 intrinsic.h
--- intrinsic.h 12 Jun 2004 17:34:45 -0000      1.6
+++ intrinsic.h 14 Jun 2004 15:55:29 -0000
@@ -69,7 +69,7 @@ try gfc_check_min_max_real (gfc_actual_a
 try gfc_check_min_max_double (gfc_actual_arglist *);
 try gfc_check_matmul (gfc_expr *, gfc_expr *);
 try gfc_check_merge (gfc_expr *, gfc_expr *, gfc_expr *);
-try gfc_check_minloc_maxloc (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 *);