2007-07-03 Tobias Burnus <burnus@net-b.de>

	PR fortran/25062
	* resolve.c (resolve_common_blocks): New check function.
	(resolve_types): Use it.

2007-07-03  Tobias Burnus  <burnus@net-b.de>

	PR fortran/25062
	* common_7.f90: New.
	* common_8.f90: New.
	* common_9.f90: New.

git-svn-id: svn+ssh://gcc.gnu.org/svn/gcc/trunk@126279 138bc75d-0d04-0410-961f-82ee72b054a4

diff --git a/gcc/fortran/ChangeLog b/gcc/fortran/ChangeLog
index 1bd7a50..2208812 100644 (file)
--- a/gcc/fortran/ChangeLog
+++ b/gcc/fortran/ChangeLog
@@ -1,5 +1,11 @@
 2007-07-03  Tobias Burnus  <burnus@net-b.de>
 
+       PR fortran/25062
+       * resolve.c (resolve_common_blocks): New check function.
+       (resolve_types): Use it.
+
+2007-07-03  Tobias Burnus  <burnus@net-b.de>
+
        PR fortran/30940
        * interface.c (get_sym_storage_size): New function.
        (get_sym_storage_size): New function.

diff --git a/gcc/fortran/resolve.c b/gcc/fortran/resolve.c
index b249f30..615d85e 100644 (file)
--- a/gcc/fortran/resolve.c
+++ b/gcc/fortran/resolve.c
@@ -594,6 +594,56 @@ resolve_entries (gfc_namespace *ns)
 }
 
 
+/* Resolve common blocks.  */
+static void
+resolve_common_blocks (gfc_symtree *common_root)
+{
+   gfc_symtree *symtree;
+   gfc_symbol *sym;
+
+   if (common_root == NULL)
+     return;
+
+   for (symtree = common_root; symtree->left; symtree = symtree->left);
+
+   for (; symtree; symtree = symtree->right)
+     {
+       gfc_find_symbol (symtree->name, gfc_current_ns, 0, &sym);
+       if (sym == NULL)
+         continue;
+
+       if (sym->attr.flavor == FL_PARAMETER)
+         {
+           gfc_error ("COMMON block '%s' at %L is used as PARAMETER at %L",
+                      sym->name, &symtree->n.common->where,
+                      &sym->declared_at);
+         }
+
+       if (sym->attr.intrinsic)
+         {
+           gfc_error ("COMMON block '%s' at %L is also an intrinsic "
+                      "procedure", sym->name,
+                      &symtree->n.common->where);
+         }
+       else if (sym->attr.result
+                ||(sym->attr.function && gfc_current_ns->proc_name == sym))
+         {
+           gfc_notify_std (GFC_STD_F2003, "Fortran 2003: COMMON block '%s' "
+                           "at %L that is also a function result", sym->name,
+                           &symtree->n.common->where);
+         }
+       else if (sym->attr.flavor == FL_PROCEDURE
+               && sym->attr.proc != PROC_INTERNAL
+               && sym->attr.proc != PROC_ST_FUNCTION)
+         {
+           gfc_notify_std (GFC_STD_F2003, "Fortran 2003: COMMON block '%s' "
+                           "at %L that is also a global procedure", sym->name,
+                           &symtree->n.common->where);
+         }
+     }
+}
+
+
 /* Resolve contained function types.  Because contained functions can call one
    another, they have to be worked out before any of the contained procedures
    can be resolved.
@@ -8197,6 +8247,8 @@ resolve_types (gfc_namespace *ns)
 
   resolve_entries (ns);
 
+  resolve_common_blocks (ns->common_root);
+
   resolve_contained_functions (ns);
 
   gfc_traverse_ns (ns, resolve_bind_c_derived_types);

diff --git a/gcc/testsuite/ChangeLog b/gcc/testsuite/ChangeLog
index 934a38b..e6b2268 100644 (file)
--- a/gcc/testsuite/ChangeLog
+++ b/gcc/testsuite/ChangeLog
@@ -1,5 +1,12 @@
 2007-07-03  Tobias Burnus  <burnus@net-b.de>
 
+       PR fortran/25062
+       * common_7.f90: New.
+       * common_8.f90: New.
+       * common_9.f90: New.
+
+2007-07-03  Tobias Burnus  <burnus@net-b.de>
+
        PR fortran/30940
        * gfortran.dg/argument_checking_1.f90: New.
        * gfortran.dg/argument_checking_2.f90: New.

diff --git a/gcc/testsuite/gfortran.dg/common_7.f90 b/gcc/testsuite/gfortran.dg/common_7.f90
new file mode 100644 (file)
index 0000000..2736cad
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/common_7.f90
@@ -0,0 +1,11 @@
+! { dg-do compile }
+!
+! F2003: 16.2.1
+! "A name that identifies a common block in a scoping unit shall not be used 
+!  to identify a constant or an intrinsic procedure in that scoping unit."
+!
+subroutine x134
+ INTEGER, PARAMETER ::  C1=1  ! { dg-error "COMMON block 'c1' at \\(1\\) is used as PARAMETER" } 
+ COMMON /C1/ I  ! { dg-error "COMMON block 'c1' at \\(1\\) is used as PARAMETER" } 
+end subroutine
+end

diff --git a/gcc/testsuite/gfortran.dg/common_8.f90 b/gcc/testsuite/gfortran.dg/common_8.f90
new file mode 100644 (file)
index 0000000..5d08fcd
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/common_8.f90
@@ -0,0 +1,32 @@
+! { dg-do compile }
+!
+! PR fortran/25062
+!
+! F2003: 16.2.1
+! "A name that identifies a common block in a scoping unit shall not be used 
+!  to identify a constant or an intrinsic procedure in that scoping unit."
+!
+subroutine try
+ implicit none
+ COMMON /s/ J
+ COMMON /bar/ I
+ INTEGER I, J
+ real s, x
+ s(x)=sin(x)
+ print *, s(5.0)
+ call bar()
+contains
+ subroutine bar
+   print *, 'Hello world'
+ end subroutine bar
+
+end subroutine try
+
+program test
+ implicit none
+ COMMON /abs/ J ! { dg-error "is also an intrinsic procedure" }
+ intrinsic :: abs
+ INTEGER J
+ external try
+ call try
+end program test

diff --git a/gcc/testsuite/gfortran.dg/common_9.f90 b/gcc/testsuite/gfortran.dg/common_9.f90
new file mode 100644 (file)
index 0000000..a567eb3
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/common_9.f90
@@ -0,0 +1,23 @@
+! { dg-do compile }
+! { dg-options "-std=f95" }
+
+! PR fortran/25062
+!
+! F95: 14.1.2.1:
+! "A common block name in a scoping unit also may be the name of any local
+!  entity other than a named constant, intrinsic procedure, or a local variable
+!  that is also an external function in a function subprogram."
+!
+! F2003: 16.2.1
+! "A name that identifies a common block in a scoping unit shall not be used 
+!  to identify a constant or an intrinsic procedure in that scoping unit. If
+!  a local identifier is also the name of a common block, the appearance of
+!  that name in any context other than as a common block name in a COMMON
+!  or SAVE statement is an appearance of the local identifier."
+!
+function func1() result(res)
+  implicit none
+  real res, r
+  common /res/ r ! { dg-error "is also a function result" }
+end function func1
+end