Fortran: Fix default type bugs in gfortran [PR99139, PR99368]

2023-07-08  Steve Kargl  <sgk@troutmask.apl.washington.edu>

gcc/fortran
	PR fortran/99139
	PR fortran/99368
	* match.cc (gfc_match_namelist): Check for host associated or
	defined types before applying default type.
	(gfc_match_select_rank): Apply default type to selector of
	unknown type if possible.
	* resolve.cc (resolve_fl_variable): Do not apply local default
	initialization to assumed rank entities.

gcc/testsuite/
	PR fortran/99139
	* gfortran.dg/pr99139.f90 : New test

	PR fortran/99368
	* gfortran.dg/pr99368.f90 : New test

diff --git a/gcc/fortran/match.cc b/gcc/fortran/match.cc
index ca64e59029ed1a2ce2881e05ab13d6f8291189d2..7335d98f22246776f3e7978218e1f03542777ab8 100644 (file)
--- a/gcc/fortran/match.cc
+++ b/gcc/fortran/match.cc
@@ -5622,10 +5622,31 @@ gfc_match_namelist (void)
                  gfc_error_check ();
                }
              else
-               /* If the type is not set already, we set it here to the
-                  implicit default type.  It is not allowed to set it
-                  later to any other type.  */
-               gfc_set_default_type (sym, 0, gfc_current_ns);
+               {
+                 /* Before the symbol is given an implicit type, check to
+                    see if the symbol is already available in the namespace,
+                    possibly through host association.  Importantly, the
+                    symbol may be a user defined type.  */
+
+                 gfc_symbol *tmp;
+
+                 gfc_find_symbol (sym->name, NULL, 1, &tmp);
+                 if (tmp && tmp->attr.generic
+                     && (tmp = gfc_find_dt_in_generic (tmp)))
+                   {
+                     if (tmp->attr.flavor == FL_DERIVED)
+                       {
+                         gfc_error ("Derived type %qs at %L conflicts with "
+                                    "namelist object %qs at %C",
+                                    tmp->name, &tmp->declared_at, sym->name);
+                         goto error;
+                       }
+                   }
+
+                 /* Set type of the symbol to its implicit default type.  It is
+                    not allowed to set it later to any other type.  */
+                 gfc_set_default_type (sym, 0, gfc_current_ns);
+               }
            }
          if (sym->attr.in_namelist == 0
              && !gfc_add_in_namelist (&sym->attr, sym->name, NULL))
@@ -6805,8 +6826,20 @@ gfc_match_select_rank (void)
 
   gfc_current_ns = gfc_build_block_ns (ns);
   m = gfc_match (" %n => %e", name, &expr2);
+
   if (m == MATCH_YES)
     {
+      /* If expr2 corresponds to an implicitly typed variable, then the
+        actual type of the variable may not have been set.  Set it here.  */
+      if (!gfc_current_ns->seen_implicit_none
+         && expr2->expr_type == EXPR_VARIABLE
+         && expr2->ts.type == BT_UNKNOWN
+         && expr2->symtree && expr2->symtree->n.sym)
+       {
+         gfc_set_default_type (expr2->symtree->n.sym, 0, gfc_current_ns);
+         expr2->ts.type = expr2->symtree->n.sym->ts.type;
+       }
+
       expr1 = gfc_get_expr ();
       expr1->expr_type = EXPR_VARIABLE;
       expr1->where = expr2->where;

diff --git a/gcc/fortran/resolve.cc b/gcc/fortran/resolve.cc
index 8e018b6e7e83c173b69ab39046c8c6f67145e767..f7cfdfc133faab39d10b9fc8a9ebc9542eb1f416 100644 (file)
--- a/gcc/fortran/resolve.cc
+++ b/gcc/fortran/resolve.cc
@@ -13510,7 +13510,8 @@ resolve_fl_variable (gfc_symbol *sym, int mp_flag)
        }
     }
 
-  if (sym->value == NULL && sym->attr.referenced)
+  if (sym->value == NULL && sym->attr.referenced
+      && !(sym->as && sym->as->type == AS_ASSUMED_RANK))
     apply_default_init_local (sym); /* Try to apply a default initialization.  */
 
   /* Determine if the symbol may not have an initializer.  */

diff --git a/gcc/testsuite/gfortran.dg/pr99139.f90 b/gcc/testsuite/gfortran.dg/pr99139.f90
new file mode 100644 (file)
index 0000000..a064103
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/pr99139.f90
@@ -0,0 +1,24 @@
+! { dg-do compile }
+! { dg-options "-finit-local-zero" }
+!
+! Contributed by Gerhard Steinmetz  <gscfq@t-online.de>
+!
+! Original implicitly typed 'x' gave a bad symbol ICE
+subroutine s1(x)
+   target :: x(..)
+   select rank (y => x)
+   rank (1)
+   rank (2)
+   end select
+end
+
+! Comment #2: Failed with above option
+subroutine s2(x, z)
+   real, target :: x(..)
+   real :: z(10)
+   select rank (y => x) ! Error was:Assumed-rank variable y at (1) may only be
+                        ! used as actual argument
+   rank (1)
+   rank (2)
+   end select
+end

diff --git a/gcc/testsuite/gfortran.dg/pr99368.f90 b/gcc/testsuite/gfortran.dg/pr99368.f90
new file mode 100644 (file)
index 0000000..9ba0425
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/pr99368.f90
@@ -0,0 +1,17 @@
+! { dg-do compile }
+!
+! Contributed by Gerhard Steinmetz  <gscfq@t-online.de>
+!
+program p
+   type y ! { dg-error "Derived type" }
+   end type
+contains
+   subroutine s1
+      namelist /x/ y ! { dg-error "conflicts with namelist object" }
+      character(3) y
+   end
+   subroutine s2
+      namelist /z/ y ! { dg-error "conflicts with namelist object" }
+      character(3) y
+   end
+end
\ No newline at end of file