re PR fortran/42418 (PROCEDURE: Rejects interface which is both specific and generic procedure)

2012-07-31  Janus Weil  <janus@gcc.gnu.org>

	PR fortran/42418
	* decl.c (match_procedure_interface): Move some checks to
	'resolve_procedure_interface'. Set flavor if appropriate.
	* expr.c (gfc_check_pointer_assign): Cleanup of 'gfc_is_intrinsic'.
	* intrinsic.c (gfc_is_intrinsic): Additional checks for attributes which
	identify a procedure as being non-intrinsic.
	* resolve.c (resolve_procedure_interface): Checks moved here from
	'match_procedure_interface'. Minor cleanup.
	(resolve_formal_arglist,resolve_symbol): Cleanup of
	'resolve_procedure_interface'
	(resolve_actual_arglist,is_external_proc): Cleanup of
	'gfc_is_intrinsic'.

2012-07-31  Janus Weil  <janus@gcc.gnu.org>

	PR fortran/42418
	* gfortran.dg/proc_decl_29.f90: New.

From-SVN: r190017

gcc/fortran/ChangeLog

 2012-07-31  Janus Weil  <janus@gcc.gnu.org>
 
+	PR fortran/42418
+	* decl.c (match_procedure_interface): Move some checks to
+	'resolve_procedure_interface'. Set flavor if appropriate.
+	* expr.c (gfc_check_pointer_assign): Cleanup of 'gfc_is_intrinsic'.
+	* intrinsic.c (gfc_is_intrinsic): Additional checks for attributes which
+	identify a procedure as being non-intrinsic.
+	* resolve.c (resolve_procedure_interface): Checks moved here from
+	'match_procedure_interface'. Minor cleanup.
+	(resolve_formal_arglist,resolve_symbol): Cleanup of
+	'resolve_procedure_interface'
+	(resolve_actual_arglist,is_external_proc): Cleanup of
+	'gfc_is_intrinsic'.
+
+2012-07-31  Janus Weil  <janus@gcc.gnu.org>
+
 	PR fortran/54134
 	* dependency.c (gfc_dep_compare_expr): Check if arguments are NULL.
 

gcc/fortran/decl.c

@@ -4792,42 +4792,21 @@ match_procedure_interface (gfc_symbol **proc_if)
   gfc_current_ns = old_ns;
   *proc_if = st->n.sym;
 
-  /* Various interface checks.  */
   if (*proc_if)
     {
       (*proc_if)->refs++;
       /* Resolve interface if possible. That way, attr.procedure is only set
 	 if it is declared by a later procedure-declaration-stmt, which is
-	 invalid per C1212.  */
+	 invalid per F08:C1216 (cf. resolve_procedure_interface).  */
       while ((*proc_if)->ts.interface)
 	*proc_if = (*proc_if)->ts.interface;
 
-      if ((*proc_if)->generic)
-	{
-	  gfc_error ("Interface '%s' at %C may not be generic",
-		     (*proc_if)->name);
-	  return MATCH_ERROR;
-	}
-      if ((*proc_if)->attr.proc == PROC_ST_FUNCTION)
-	{
-	  gfc_error ("Interface '%s' at %C may not be a statement function",
-		     (*proc_if)->name);
+      if ((*proc_if)->attr.flavor == FL_UNKNOWN
+	  && (*proc_if)->ts.type == BT_UNKNOWN
+	  && gfc_add_flavor (&(*proc_if)->attr, FL_PROCEDURE,
+			      (*proc_if)->name, NULL) == FAILURE)
 	return MATCH_ERROR;
     }
-      /* Handle intrinsic procedures.  */
-      if (!((*proc_if)->attr.external || (*proc_if)->attr.use_assoc
-	    || (*proc_if)->attr.if_source == IFSRC_IFBODY)
-	  && (gfc_is_intrinsic ((*proc_if), 0, gfc_current_locus)
-	      || gfc_is_intrinsic ((*proc_if), 1, gfc_current_locus)))
-	(*proc_if)->attr.intrinsic = 1;
-      if ((*proc_if)->attr.intrinsic
-	  && !gfc_intrinsic_actual_ok ((*proc_if)->name, 0))
-	{
-	  gfc_error ("Intrinsic procedure '%s' not allowed "
-		    "in PROCEDURE statement at %C", (*proc_if)->name);
-	  return MATCH_ERROR;
-	}
-    }
 
 got_ts:
   if (gfc_match (" )") != MATCH_YES)

gcc/fortran/expr.c

@@ -3426,8 +3426,6 @@ gfc_check_pointer_assign (gfc_expr *lvalue, gfc_expr *rvalue)
       	  /* Check for intrinsics.  */
 	  gfc_symbol *sym = rvalue->symtree->n.sym;
 	  if (!sym->attr.intrinsic
-	      && !(sym->attr.contained || sym->attr.use_assoc
-		   || sym->attr.external || sym->attr.if_source == IFSRC_IFBODY)
 	      && (gfc_is_intrinsic (sym, 0, sym->declared_at)
 		  || gfc_is_intrinsic (sym, 1, sym->declared_at)))
 	    {

gcc/fortran/intrinsic.c

@@ -902,9 +902,9 @@ gfc_intrinsic_actual_ok (const char *name, const bool subroutine_flag)
 }
 
 
-/* Given a symbol, find out if it is (and is to be treated) an intrinsic.  If
-   it's name refers to an intrinsic but this intrinsic is not included in the
-   selected standard, this returns FALSE and sets the symbol's external
+/* Given a symbol, find out if it is (and is to be treated as) an intrinsic.
+   If its name refers to an intrinsic, but this intrinsic is not included in
+   the selected standard, this returns FALSE and sets the symbol's external
    attribute.  */
 
 bool
@@ -913,10 +913,13 @@ gfc_is_intrinsic (gfc_symbol* sym, int subroutine_flag, locus loc)
   gfc_intrinsic_sym* isym;
   const char* symstd;
 
-  /* If INTRINSIC/EXTERNAL state is already known, return.  */
+  /* If INTRINSIC attribute is already known, return.  */
   if (sym->attr.intrinsic)
     return true;
-  if (sym->attr.external)
+
+  /* Check for attributes which prevent the symbol from being INTRINSIC.  */
+  if (sym->attr.external || sym->attr.contained
+      || sym->attr.if_source == IFSRC_IFBODY)
     return false;
 
   if (subroutine_flag)

gcc/fortran/resolve.c

@@ -146,24 +146,58 @@ static void resolve_symbol (gfc_symbol *sym);
 static gfc_try
 resolve_procedure_interface (gfc_symbol *sym)
 {
-  if (sym->ts.interface == sym)
+  gfc_symbol *ifc = sym->ts.interface;
+
+  if (!ifc)
+    return SUCCESS;
+
+  /* Several checks for F08:C1216.  */
+  if (ifc == sym)
     {
       gfc_error ("PROCEDURE '%s' at %L may not be used as its own interface",
 		 sym->name, &sym->declared_at);
       return FAILURE;
     }
-  if (sym->ts.interface->attr.procedure)
+  if (ifc->attr.procedure)
     {
       gfc_error ("Interface '%s', used by procedure '%s' at %L, is declared "
-		 "in a later PROCEDURE statement", sym->ts.interface->name,
+		 "in a later PROCEDURE statement", ifc->name,
 		 sym->name, &sym->declared_at);
       return FAILURE;
     }
+  if (ifc->generic)
+    {
+      /* For generic interfaces, check if there is
+	 a specific procedure with the same name.  */
+      gfc_interface *gen = ifc->generic;
+      while (gen && strcmp (gen->sym->name, ifc->name) != 0)
+	gen = gen->next;
+      if (!gen)
+	{
+	  gfc_error ("Interface '%s' at %L may not be generic",
+		     ifc->name, &sym->declared_at);
+	  return FAILURE;
+	}
+    }
+  if (ifc->attr.proc == PROC_ST_FUNCTION)
+    {
+      gfc_error ("Interface '%s' at %L may not be a statement function",
+		 ifc->name, &sym->declared_at);
+      return FAILURE;
+    }
+  if (gfc_is_intrinsic (ifc, 0, ifc->declared_at)
+      || gfc_is_intrinsic (ifc, 1, ifc->declared_at))
+    ifc->attr.intrinsic = 1;
+  if (ifc->attr.intrinsic && !gfc_intrinsic_actual_ok (ifc->name, 0))
+    {
+      gfc_error ("Intrinsic procedure '%s' not allowed in "
+		 "PROCEDURE statement at %L", ifc->name, &sym->declared_at);
+      return FAILURE;
+    }
 
   /* Get the attributes from the interface (now resolved).  */
-  if (sym->ts.interface->attr.if_source || sym->ts.interface->attr.intrinsic)
+  if (ifc->attr.if_source || ifc->attr.intrinsic)
     {
-      gfc_symbol *ifc = sym->ts.interface;
       resolve_symbol (ifc);
 
       if (ifc->attr.intrinsic)
@@ -212,10 +246,10 @@ resolve_procedure_interface (gfc_symbol *sym)
 	    return FAILURE;
 	}
     }
-  else if (sym->ts.interface->name[0] != '\0')
+  else if (ifc->name[0] != '\0')
     {
       gfc_error ("Interface '%s' of procedure '%s' at %L must be explicit",
-		 sym->ts.interface->name, sym->name, &sym->declared_at);
+		 ifc->name, sym->name, &sym->declared_at);
       return FAILURE;
     }
 
@@ -273,9 +307,9 @@ resolve_formal_arglist (gfc_symbol *proc)
 		       &proc->declared_at);
 	  continue;
 	}
-      else if (sym->attr.procedure && sym->ts.interface
-	       && sym->attr.if_source != IFSRC_DECL)
-	resolve_procedure_interface (sym);
+      else if (sym->attr.procedure && sym->attr.if_source != IFSRC_DECL
+	       && resolve_procedure_interface (sym) == FAILURE)
+	return;
 
       if (sym->attr.if_source != IFSRC_UNKNOWN)
 	resolve_formal_arglist (sym);
@@ -1672,10 +1706,7 @@ resolve_actual_arglist (gfc_actual_arglist *arg, procedure_type ptype,
 
 	  /* If a procedure is not already determined to be something else
 	     check if it is intrinsic.  */
-	  if (!sym->attr.intrinsic
-	      && !(sym->attr.external || sym->attr.use_assoc
-		   || sym->attr.if_source == IFSRC_IFBODY)
-	      && gfc_is_intrinsic (sym, sym->attr.subroutine, e->where))
+	  if (gfc_is_intrinsic (sym, sym->attr.subroutine, e->where))
 	    sym->attr.intrinsic = 1;
 
 	  if (sym->attr.proc == PROC_ST_FUNCTION)
@@ -2601,8 +2632,7 @@ static bool
 is_external_proc (gfc_symbol *sym)
 {
   if (!sym->attr.dummy && !sym->attr.contained
-	&& !(sym->attr.intrinsic
-	      || gfc_is_intrinsic (sym, sym->attr.subroutine, sym->declared_at))
+	&& !gfc_is_intrinsic (sym, sym->attr.subroutine, sym->declared_at)
 	&& sym->attr.proc != PROC_ST_FUNCTION
 	&& !sym->attr.proc_pointer
 	&& !sym->attr.use_assoc
@@ -12516,8 +12546,7 @@ resolve_symbol (gfc_symbol *sym)
   if (sym->attr.external && sym->ts.type != BT_UNKNOWN && !sym->attr.function)
     gfc_add_function (&sym->attr, sym->name, &sym->declared_at);
 
-  if (sym->attr.procedure && sym->ts.interface
-      && sym->attr.if_source != IFSRC_DECL
+  if (sym->attr.procedure && sym->attr.if_source != IFSRC_DECL
       && resolve_procedure_interface (sym) == FAILURE)
     return;
 

gcc/testsuite/ChangeLog

+2012-07-31  Janus Weil  <janus@gcc.gnu.org>
+
+	PR fortran/42418
+	* gfortran.dg/proc_decl_29.f90: New.
+
 2012-07-31  Dehao Chen  <dehao@google.com>
 
 	* gcc.dg/predict-7.c: New test.

gcc/testsuite/gfortran.dg/proc_decl_29.f90

+! { dg-do compile }
+!
+! PR 42418: PROCEDURE: Rejects interface which is both specific and generic procedure
+!
+! Contributed by Tobias Burnus <burnus@gcc.gnu.org>
+
+  interface gen
+    procedure gen
+  end interface
+
+  procedure(gen)  :: p1
+  procedure(gen2) :: p2  ! { dg-error "may not be generic" }
+  procedure(sf)   :: p3  ! { dg-error "may not be a statement function" }
+  procedure(char) :: p4
+
+  interface gen2
+    procedure char
+  end interface
+
+  sf(x) = x**2  ! { dg-warning "Obsolescent feature" }
+
+contains
+
+  subroutine gen
+  end subroutine
+
+  subroutine char
+  end subroutine
+
+end