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

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

diff --git a/gcc/fortran/ChangeLog b/gcc/fortran/ChangeLog
index 7eb4db4b2aadf46c66166c33d19981c682bf9e1e..08dce7f3f5851228d694efbb2490d28fa9bf7929 100644 (file)
--- a/gcc/fortran/ChangeLog
+++ b/gcc/fortran/ChangeLog
@@ -1,3 +1,18 @@
+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

diff --git a/gcc/fortran/decl.c b/gcc/fortran/decl.c
index 39c0493eef5f9c734dd896d42179a32f7d8ea9fc..083326ed37db9df16d0b1afe42e970028328750d 100644 (file)
--- a/gcc/fortran/decl.c
+++ b/gcc/fortran/decl.c
@@ -4792,41 +4792,20 @@ 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);
-         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;
-       }
+      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;
     }
 
 got_ts:

diff --git a/gcc/fortran/expr.c b/gcc/fortran/expr.c
index f43bc6f8a99b277a1cb18d6900052476dc8ac68d..3a3ba9a9132b2b5e4bbe8c81cd1d55f85649a284 100644 (file)
--- a/gcc/fortran/expr.c
+++ b/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)))
            {

diff --git a/gcc/fortran/intrinsic.c b/gcc/fortran/intrinsic.c
index dbfadb42b118cde0695c3056380f93dfb8f3890e..60c68feb624c03fdbb05311f1c80ae92d45c7738 100644 (file)
--- a/gcc/fortran/intrinsic.c
+++ b/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)

diff --git a/gcc/fortran/resolve.c b/gcc/fortran/resolve.c
index dcce3f56ce1fb13b71eab8aa8ef564e8ac95bd59..a6dd0dacdd0c74aed81a9ba8f2f96d6d8e3a8e61 100644 (file)
--- a/gcc/fortran/resolve.c
+++ b/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;
 

diff --git a/gcc/testsuite/ChangeLog b/gcc/testsuite/ChangeLog
index 00c8b7090bd48d3a150f8e9e3b4f21ab556f0d6e..e210d005d1fc090af516671f5dad59fb14e80bcc 100644 (file)
--- a/gcc/testsuite/ChangeLog
+++ b/gcc/testsuite/ChangeLog
@@ -1,3 +1,8 @@
+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.

diff --git a/gcc/testsuite/gfortran.dg/proc_decl_29.f90 b/gcc/testsuite/gfortran.dg/proc_decl_29.f90
new file mode 100644 (file)
index 0000000..6a92118
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/proc_decl_29.f90
@@ -0,0 +1,30 @@
+! { 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