Remove KIND argument from INDEX so it does not mess up scalarization.

2019-12-30  Thomas Koenig  <tkoenig@gcc.gnu.org>

	PR fortran/91541
	* intrinsic.c (add_sym_4ind): New function.
	(add_functions): Use it for INDEX.
	(resolve_intrinsic): Also call f1m for INDEX.
	* intrinsic.h (gfc_resolve_index_func): Adjust prototype to
	take a gfc_arglist instead of individual arguments.
	* iresolve.c (gfc_resolve_index_func): Adjust arguments.
	Remove KIND argument if present, and make sure this is
	not done twice.
	* trans-decl.c: Include "intrinsic.h".
	(gfc_get_extern_function_decl): Special case for resolving INDEX.

2019-12-30  Thomas Koenig  <tkoenig@gcc.gnu.org>

	PR fortran/91541
	* gfortran.dg/index_3.f90: New test.

From-SVN: r279763

diff --git a/gcc/fortran/ChangeLog b/gcc/fortran/ChangeLog
index 5b92597641b86803eea664b5f77a1860d81db619..1e6d236910f8bd9b67bcf3310608c268d03deb6a 100644 (file)
--- a/gcc/fortran/ChangeLog
+++ b/gcc/fortran/ChangeLog
@@ -1,3 +1,17 @@
+2019-12-30  Thomas Koenig  <tkoenig@gcc.gnu.org>
+
+       PR fortran/91541
+       * intrinsic.c (add_sym_4ind): New function.
+       (add_functions): Use it for INDEX.
+       (resolve_intrinsic): Also call f1m for INDEX.
+       * intrinsic.h (gfc_resolve_index_func): Adjust prototype to
+       take a gfc_arglist instead of individual arguments.
+       * iresolve.c (gfc_resolve_index_func): Adjust arguments.
+       Remove KIND argument if present, and make sure this is
+       not done twice.
+       * trans-decl.c: Include "intrinsic.h".
+       (gfc_get_extern_function_decl): Special case for resolving INDEX.
+
 2019-12-30  Thomas Koenig  <tkoenig@gcc.gnu.org>
 
        PR fortran/92961

diff --git a/gcc/fortran/intrinsic.c b/gcc/fortran/intrinsic.c
index c913f5ab152fc4f8f73c3e31ce60bcb168f26fd7..9596018fe0aa99179568be2fe492a881f7ad0c14 100644 (file)
--- a/gcc/fortran/intrinsic.c
+++ b/gcc/fortran/intrinsic.c
@@ -851,6 +851,39 @@ add_sym_4 (const char *name, gfc_isym_id id, enum klass cl, int actual_ok, bt ty
           (void *) 0);
 }
 
+/* Add a symbol to the function list where the function takes 4
+   arguments and resolution may need to change the number or
+   arrangement of arguments. This is the case for INDEX, which needs
+   its KIND argument removed.  */
+
+static void
+add_sym_4ind (const char *name, gfc_isym_id id, enum klass cl, int actual_ok,
+             bt type, int kind, int standard,
+             bool (*check) (gfc_expr *, gfc_expr *, gfc_expr *, gfc_expr *),
+             gfc_expr *(*simplify) (gfc_expr *, gfc_expr *, gfc_expr *,
+                                    gfc_expr *),
+             void (*resolve) (gfc_expr *, gfc_actual_arglist *),
+             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,
+             const char *a4, bt type4, int kind4, int optional4 )
+{
+  gfc_check_f cf;
+  gfc_simplify_f sf;
+  gfc_resolve_f rf;
+
+  cf.f4 = check;
+  sf.f4 = simplify;
+  rf.f1m = resolve;
+
+  add_sym (name, id, cl, actual_ok, type, kind, standard, cf, sf, rf,
+          a1, type1, kind1, optional1, INTENT_IN,
+          a2, type2, kind2, optional2, INTENT_IN,
+          a3, type3, kind3, optional3, INTENT_IN,
+          a4, type4, kind4, optional4, INTENT_IN,
+          (void *) 0);
+}
+
 
 /* Add a symbol to the subroutine list where the subroutine takes
    4 arguments.  */
@@ -2153,11 +2186,11 @@ add_functions (void)
 
   /* The resolution function for INDEX is called gfc_resolve_index_func
      because the name gfc_resolve_index is already used in resolve.c.  */
-  add_sym_4 ("index", GFC_ISYM_INDEX, CLASS_ELEMENTAL, ACTUAL_YES,
-            BT_INTEGER, di, GFC_STD_F77,
-            gfc_check_index, gfc_simplify_index, gfc_resolve_index_func,
-            stg, BT_CHARACTER, dc, REQUIRED, ssg, BT_CHARACTER, dc, REQUIRED,
-            bck, BT_LOGICAL, dl, OPTIONAL, kind, BT_INTEGER, di, OPTIONAL);
+  add_sym_4ind ("index", GFC_ISYM_INDEX, CLASS_ELEMENTAL, ACTUAL_YES,
+               BT_INTEGER, di, GFC_STD_F77,
+               gfc_check_index, gfc_simplify_index, gfc_resolve_index_func,
+               stg, BT_CHARACTER, dc, REQUIRED, ssg, BT_CHARACTER, dc, REQUIRED,
+               bck, BT_LOGICAL, dl, OPTIONAL, kind, BT_INTEGER, di, OPTIONAL);
 
   make_generic ("index", GFC_ISYM_INDEX, GFC_STD_F77);
 
@@ -4434,9 +4467,10 @@ resolve_intrinsic (gfc_intrinsic_sym *specific, gfc_expr *e)
 
   arg = e->value.function.actual;
 
-  /* Special case hacks for MIN and MAX.  */
+  /* Special case hacks for MIN, MAX and INDEX.  */
   if (specific->resolve.f1m == gfc_resolve_max
-      || specific->resolve.f1m == gfc_resolve_min)
+      || specific->resolve.f1m == gfc_resolve_min
+      || specific->resolve.f1m == gfc_resolve_index_func)
     {
       (*specific->resolve.f1m) (e, arg);
       return;

diff --git a/gcc/fortran/intrinsic.h b/gcc/fortran/intrinsic.h
index 0c60dab839082bc0a1cbe4d46e8d1e5b5b8f0e22..f7d0a15f379f25ec83a6e098ce06f305eec087a5 100644 (file)
--- a/gcc/fortran/intrinsic.h
+++ b/gcc/fortran/intrinsic.h
@@ -517,8 +517,7 @@ void gfc_resolve_ibits (gfc_expr *, gfc_expr *, gfc_expr *, gfc_expr *);
 void gfc_resolve_ibset (gfc_expr *, gfc_expr *, gfc_expr *);
 void gfc_resolve_image_index (gfc_expr *, gfc_expr *, gfc_expr *);
 void gfc_resolve_image_status (gfc_expr *, gfc_expr *, gfc_expr *);
-void gfc_resolve_index_func (gfc_expr *, gfc_expr *, gfc_expr *, gfc_expr *,
-                            gfc_expr *);
+void gfc_resolve_index_func (gfc_expr *, gfc_actual_arglist *);
 void gfc_resolve_ierrno (gfc_expr *);
 void gfc_resolve_ieor (gfc_expr *, gfc_expr *, gfc_expr *);
 void gfc_resolve_ichar (gfc_expr *, gfc_expr *, gfc_expr *);

diff --git a/gcc/fortran/iresolve.c b/gcc/fortran/iresolve.c
index 53338dda0a7feace2ae19ad30e9478e068a8aa01..2a44a0a9978f528a87f036240ed1c58458045876 100644 (file)
--- a/gcc/fortran/iresolve.c
+++ b/gcc/fortran/iresolve.c
@@ -1352,16 +1352,31 @@ gfc_resolve_ior (gfc_expr *f, gfc_expr *i, gfc_expr *j)
 
 
 void
-gfc_resolve_index_func (gfc_expr *f, gfc_expr *str,
-                       gfc_expr *sub_str ATTRIBUTE_UNUSED, gfc_expr *back,
-                       gfc_expr *kind)
+gfc_resolve_index_func (gfc_expr *f, gfc_actual_arglist *a)
 {
   gfc_typespec ts;
   gfc_clear_ts (&ts);
+  gfc_expr *str, *back, *kind;
+  gfc_actual_arglist *a_sub_str, *a_back, *a_kind;
+
+  if (f->do_not_resolve_again)
+    return;
+
+  a_sub_str = a->next;
+  a_back = a_sub_str->next;
+  a_kind = a_back->next;
+
+  str = a->expr;
+  back = a_back->expr;
+  kind = a_kind->expr;
 
   f->ts.type = BT_INTEGER;
   if (kind)
-    f->ts.kind = mpz_get_si (kind->value.integer);
+    {
+      f->ts.kind = mpz_get_si ((kind)->value.integer);
+      a_back->next = NULL;
+      gfc_free_actual_arglist (a_kind);
+    }
   else
     f->ts.kind = gfc_default_integer_kind;
 
@@ -1376,6 +1391,8 @@ gfc_resolve_index_func (gfc_expr *f, gfc_expr *str,
 
   f->value.function.name
     = gfc_get_string ("__index_%d_i%d", str->ts.kind, f->ts.kind);
+
+  f->do_not_resolve_again = 1;
 }
 
 

diff --git a/gcc/fortran/trans-decl.c b/gcc/fortran/trans-decl.c
index d0fc5d38e20df28b96e86a7aea038ea2e5f67165..a8fe7b997c2b74fe5ac5bfcc4d02cadefaf9e0c6 100644 (file)
--- a/gcc/fortran/trans-decl.c
+++ b/gcc/fortran/trans-decl.c
@@ -42,6 +42,7 @@ along with GCC; see the file COPYING3.  If not see
 #include "trans-types.h"
 #include "trans-array.h"
 #include "trans-const.h"
+#include "intrinsic.h"                 /* For gfc_resolve_index_func.  */
 /* Only for gfc_trans_code.  Shouldn't need to include this.  */
 #include "trans-stmt.h"
 #include "gomp-constants.h"
@@ -2210,7 +2211,28 @@ module_sym:
                {
                  /* All specific intrinsics take less than 5 arguments.  */
                  gcc_assert (isym->formal->next->next->next->next == NULL);
-                 isym->resolve.f4 (&e, &argexpr, NULL, NULL, NULL);
+                 if (isym->resolve.f1m == gfc_resolve_index_func)
+                   {
+                     /* gfc_resolve_index_func is special because it takes a
+                        gfc_actual_arglist instead of individual arguments.  */
+                     gfc_actual_arglist *a, *n;
+                     int i;
+                     a = gfc_get_actual_arglist();
+                     n = a;
+
+                     for (i = 0; i < 4; i++)
+                       {
+                         n->next = gfc_get_actual_arglist();
+                         n = n->next;
+                       }
+
+                     a->expr = &argexpr;
+                     isym->resolve.f1m (&e, a);
+                     a->expr = NULL;
+                     gfc_free_actual_arglist (a);
+                   }
+                 else
+                   isym->resolve.f4 (&e, &argexpr, NULL, NULL, NULL);
                }
            }
        }

diff --git a/gcc/testsuite/ChangeLog b/gcc/testsuite/ChangeLog
index d7044518a0257a78e4eba20e2e575f3c11c7610c..8cb6f299f7cb60f048d35f44037971c70de19e25 100644 (file)
--- a/gcc/testsuite/ChangeLog
+++ b/gcc/testsuite/ChangeLog
@@ -1,3 +1,8 @@
+2019-12-30  Thomas Koenig  <tkoenig@gcc.gnu.org>
+
+       PR fortran/91541
+       * gfortran.dg/index_3.f90: New test.
+
 2019-12-30  Thomas Koenig  <tkoenig@gcc.gnu.org>
 
        PR fortran/92961

diff --git a/gcc/testsuite/gfortran.dg/index_3.f90 b/gcc/testsuite/gfortran.dg/index_3.f90
new file mode 100644 (file)
index 0000000..40c476a
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/index_3.f90
@@ -0,0 +1,8 @@
+! { dg-do run }
+! PR 91541 - this used to give an ICE.
+! Bug report by Gerhard Steinmetz.
+program p
+   integer :: z(2)
+   z = index('100101', '10', [.false.,.true.],kind=4)
+   if (z(1) /= 1 .or. z(2) /= 4) stop 1
+end