re PR fortran/71156 (PURE interface/definition inconsistency: accepts invalid, reject...

2016-06-01  Paul Thomas  <pault@gcc.gnu.org>

	PR fortran/71156
	* decl.c (copy_prefix): Add checks that the module procedure
	declaration prefixes are compliant with the interface. Invert
	order of existing elemental and pure checks.
	* resolve.c (resolve_fl_procedure): Invert order of elemental
	and pure errors.

2016-06-01  Paul Thomas  <pault@gcc.gnu.org>

	PR fortran/71156
	* gfortran.dg/submodule_14.f08: Add missing recursive prefix
	to the module procedure declaration.
	* gfortran.dg/submodule_16.f08: New test.

From-SVN: r236996

diff --git a/gcc/fortran/ChangeLog b/gcc/fortran/ChangeLog
index 8cff148fa979885d835af1c3173ccb98f07cb72b..1cc998e78b586e18f25a3fd51c9289d3557ea676 100644 (file)
--- a/gcc/fortran/ChangeLog
+++ b/gcc/fortran/ChangeLog
@@ -1,3 +1,12 @@
+2016-06-01  Paul Thomas  <pault@gcc.gnu.org>
+
+       PR fortran/71156
+       * decl.c (copy_prefix): Add checks that the module procedure
+       declaration prefixes are compliant with the interface. Invert
+       order of existing elemental and pure checks.
+       * resolve.c (resolve_fl_procedure): Invert order of elemental
+       and pure errors.
+
 2016-06-01  Jakub Jelinek  <jakub@redhat.com>
 
        * parse.c (case_decl): Move ST_OMP_* to ...

diff --git a/gcc/fortran/decl.c b/gcc/fortran/decl.c
index 0b8787ac2b2ec4f4e3db0af769ee0b8e68286a8a..724f14f7ff12a248e509299c31b6b9937193bcbe 100644 (file)
--- a/gcc/fortran/decl.c
+++ b/gcc/fortran/decl.c
@@ -608,10 +608,10 @@ cleanup:
 
 /* Like gfc_match_init_expr, but matches a 'clist' (old-style initialization
    list). The difference here is the expression is a list of constants
-   and is surrounded by '/'. 
+   and is surrounded by '/'.
    The typespec ts must match the typespec of the variable which the
    clist is initializing.
-   The arrayspec tells whether this should match a list of constants 
+   The arrayspec tells whether this should match a list of constants
    corresponding to array elements or a scalar (as == NULL).  */
 
 static match
@@ -1848,7 +1848,7 @@ build_struct (const char *name, gfc_charlen *cl, gfc_expr **init,
 
   /* If we are in a nested union/map definition, gfc_add_component will not
      properly find repeated components because:
-       (i) gfc_add_component does a flat search, where components of unions 
+       (i) gfc_add_component does a flat search, where components of unions
            and maps are implicity chained so nested components may conflict.
       (ii) Unions and maps are not linked as components of their parent
            structures until after they are parsed.
@@ -4978,12 +4978,51 @@ error:
 static bool
 copy_prefix (symbol_attribute *dest, locus *where)
 {
-  if (current_attr.pure && !gfc_add_pure (dest, where))
-    return false;
+  if (dest->module_procedure)
+    {
+      if (current_attr.elemental)
+       dest->elemental = 1;
+
+      if (current_attr.pure)
+       dest->pure = 1;
+
+      if (current_attr.recursive)
+       dest->recursive = 1;
+
+      /* Module procedures are unusual in that the 'dest' is copied from
+        the interface declaration. However, this is an oportunity to
+        check that the submodule declaration is compliant with the
+        interface.  */
+      if (dest->elemental && !current_attr.elemental)
+       {
+         gfc_error ("ELEMENTAL prefix in MODULE PROCEDURE interface is "
+                    "missing at %L", where);
+         return false;
+       }
+
+      if (dest->pure && !current_attr.pure)
+       {
+         gfc_error ("PURE prefix in MODULE PROCEDURE interface is "
+                    "missing at %L", where);
+         return false;
+       }
+
+      if (dest->recursive && !current_attr.recursive)
+       {
+         gfc_error ("RECURSIVE prefix in MODULE PROCEDURE interface is "
+                    "missing at %L", where);
+         return false;
+       }
+
+      return true;
+    }
 
   if (current_attr.elemental && !gfc_add_elemental (dest, where))
     return false;
 
+  if (current_attr.pure && !gfc_add_pure (dest, where))
+    return false;
+
   if (current_attr.recursive && !gfc_add_recursive (dest, where))
     return false;
 
@@ -8327,7 +8366,7 @@ gfc_get_type_attr_spec (symbol_attribute *attr, char *name)
    does NOT have a generic symbol matching the name given by the user.
    STRUCTUREs can share names with variables and PARAMETERs so we must allow
    for the creation of an independent symbol.
-   Other parameters are a message to prefix errors with, the name of the new 
+   Other parameters are a message to prefix errors with, the name of the new
    type to be created, and the flavor to add to the resulting symbol. */
 
 static bool
@@ -8355,7 +8394,7 @@ get_struct_decl (const char *name, sym_flavor fl, locus *decl,
 
   if (sym->components != NULL || sym->attr.zero_comp)
     {
-      gfc_error ("Type definition of '%s' at %C was already defined at %L", 
+      gfc_error ("Type definition of '%s' at %C was already defined at %L",
                  sym->name, &sym->declared_at);
       return false;
     }

diff --git a/gcc/fortran/resolve.c b/gcc/fortran/resolve.c
index 2c68af2b7e83c766dca87be109e65c8bbadd4673..77f8c10bf7ec45ef1871956ec8d5f52ea93e0490 100644 (file)
--- a/gcc/fortran/resolve.c
+++ b/gcc/fortran/resolve.c
@@ -11965,17 +11965,17 @@ resolve_fl_procedure (gfc_symbol *sym, int mp_flag)
        goto check_formal;
 
       /* Check the procedure characteristics.  */
-      if (sym->attr.pure != iface->attr.pure)
+      if (sym->attr.elemental != iface->attr.elemental)
        {
-         gfc_error ("Mismatch in PURE attribute between MODULE "
+         gfc_error ("Mismatch in ELEMENTAL attribute between MODULE "
                     "PROCEDURE at %L and its interface in %s",
                     &sym->declared_at, module_name);
          return false;
        }
 
-      if (sym->attr.elemental != iface->attr.elemental)
+      if (sym->attr.pure != iface->attr.pure)
        {
-         gfc_error ("Mismatch in ELEMENTAL attribute between MODULE "
+         gfc_error ("Mismatch in PURE attribute between MODULE "
                     "PROCEDURE at %L and its interface in %s",
                     &sym->declared_at, module_name);
          return false;

diff --git a/gcc/testsuite/ChangeLog b/gcc/testsuite/ChangeLog
index e8e8e3bb23176198d9f05d4da8a9f3ca49556f29..49fe8c0e9a30f57dcedaf752c2819cae663e6828 100644 (file)
--- a/gcc/testsuite/ChangeLog
+++ b/gcc/testsuite/ChangeLog
@@ -1,3 +1,10 @@
+2016-06-01  Paul Thomas  <pault@gcc.gnu.org>
+
+       PR fortran/71156
+       * gfortran.dg/submodule_14.f08: Add missing recursive prefix
+       to the module procedure declaration.
+       * gfortran.dg/submodule_16.f08: New test.
+
 2016-06-01  Jakub Jelinek  <jakub@redhat.com>
 
        PR middle-end/71371
@@ -322,7 +329,7 @@
 2016-05-26  Jiong Wang  <jiong.wang@arm.com>
 
        * gcc.target/aarch64/simd/vmul_elem_1.c: Force result variables to be
-       kept in memory. 
+       kept in memory.
 
 2016-05-25  Jeff Law  <law@redhat.com>
 

diff --git a/gcc/testsuite/gfortran.dg/submodule_14.f08 b/gcc/testsuite/gfortran.dg/submodule_14.f08
index 0e257d1b92e2eef75c866964066d3f911896bf57..cbfc3d1d4b17aa626c28d7e9f0abee59a20334c1 100644 (file)
--- a/gcc/testsuite/gfortran.dg/submodule_14.f08
+++ b/gcc/testsuite/gfortran.dg/submodule_14.f08
@@ -27,7 +27,7 @@ contains
         Call sub1 (x)
     End If
   End Procedure sub1
-  module function fcn1 (x) result(res)
+  recursive module function fcn1 (x) result(res)
     integer, intent (inout) :: x
     integer :: res
     res = x - 1

diff --git a/gcc/testsuite/gfortran.dg/submodule_16.f08 b/gcc/testsuite/gfortran.dg/submodule_16.f08
new file mode 100644 (file)
index 0000000..6e555b6
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/submodule_16.f08
@@ -0,0 +1,53 @@
+! { dg-do compile }
+!
+! Tests the fix for PR71156 in which the valid code (f7, f8 and f9 below)
+! triggered an error, while the invalid code (f1 to f6) compiled.
+!
+! Contributed by Damian Rousn  <damian@sourceryinstitute.org>
+!
+module my_interface
+  implicit none
+  interface
+    module subroutine f1
+    end subroutine
+    module subroutine f2
+    end subroutine
+    module subroutine f3
+    end subroutine
+    elemental module subroutine f4
+    end subroutine
+    pure module subroutine f5
+    end subroutine
+    recursive module subroutine f6
+    end subroutine
+    elemental module subroutine f7
+    end subroutine
+    pure module subroutine f8
+    end subroutine
+    recursive module subroutine f9
+    end subroutine
+  end interface
+end module
+
+submodule(my_interface) my_implementation
+  implicit none
+contains
+    elemental module subroutine f1 ! { dg-error "Mismatch in ELEMENTAL attribute" }
+    end subroutine
+    pure module subroutine f2 ! { dg-error "Mismatch in PURE attribute" }
+    end subroutine
+    recursive module subroutine f3 ! { dg-error "Mismatch in RECURSIVE attribute" }
+    end subroutine
+    module subroutine f4 ! { dg-error "ELEMENTAL prefix" }
+    end subroutine
+    module subroutine f5 ! { dg-error "PURE prefix" }
+    end subroutine
+    module subroutine f6 ! { dg-error "RECURSIVE prefix" }
+    end subroutine
+    elemental module subroutine f7
+    end subroutine
+    pure module subroutine f8
+    end subroutine
+    recursive module subroutine f9
+    end subroutine
+end submodule