aboutsummaryrefslogtreecommitdiff
diff options
context:
space:
mode:
Diffstat
-rw-r--r--gcc/fortran/ChangeLog7
-rw-r--r--gcc/fortran/match.c8
-rw-r--r--gcc/fortran/resolve.c85
-rw-r--r--gcc/testsuite/ChangeLog6
-rw-r--r--gcc/testsuite/gfortran.dg/common_10.f9055
-rw-r--r--gcc/testsuite/gfortran.dg/namelist_14.f901
6 files changed, 116 insertions, 46 deletions
diff --git a/gcc/fortran/ChangeLog b/gcc/fortran/ChangeLog
index 2597164..fe7ae49 100644
--- a/gcc/fortran/ChangeLog
+++ b/gcc/fortran/ChangeLog
@@ -1,5 +1,12 @@
2007-08-26 Tobias Burnus <burnus@net-b.de>
+ PR fortran/32985
+ * match.c (gfc_match_common): Remove SEQUENCE diagnostics.
+ * resolve.c (resolve_common_blocks): Add SEQUENCE diagnostics;
+ fix walking through the tree.
+
+2007-08-26 Tobias Burnus <burnus@net-b.de>
+
PR fortran/32980
* intrinsic.h (gfc_simplify_gamma,gfc_simplify_lgamma,
gfc_resolve_gamma,gfc_resolve_lgamma): New function declations.
diff --git a/gcc/fortran/match.c b/gcc/fortran/match.c
index 5773aa2..dcf6ad1 100644
--- a/gcc/fortran/match.c
+++ b/gcc/fortran/match.c
@@ -2885,14 +2885,6 @@ gfc_match_common (void)
if (gfc_add_in_common (&sym->attr, sym->name, NULL) == FAILURE)
goto cleanup;
- /* Derived type names must have the SEQUENCE attribute. */
- if (sym->ts.type == BT_DERIVED && !sym->ts.derived->attr.sequence)
- {
- gfc_error ("Derived type variable in COMMON at %C does not "
- "have the SEQUENCE attribute");
- goto cleanup;
- }
-
if (tail != NULL)
tail->common_next = sym;
else
diff --git a/gcc/fortran/resolve.c b/gcc/fortran/resolve.c
index fbb7a03..4610c08 100644
--- a/gcc/fortran/resolve.c
+++ b/gcc/fortran/resolve.c
@@ -606,49 +606,58 @@ resolve_entries (gfc_namespace *ns)
static void
resolve_common_blocks (gfc_symtree *common_root)
{
- gfc_symtree *symtree;
- gfc_symbol *sym;
+ gfc_symbol *sym, *csym;
- if (common_root == NULL)
- return;
+ if (common_root == NULL)
+ return;
- for (symtree = common_root; symtree->left; symtree = symtree->left);
+ if (common_root->left)
+ resolve_common_blocks (common_root->left);
+ if (common_root->right)
+ resolve_common_blocks (common_root->right);
- for (; symtree; symtree = symtree->right)
- {
- gfc_find_symbol (symtree->name, gfc_current_ns, 0, &sym);
- if (sym == NULL)
- continue;
+ for (csym = common_root->n.common->head; csym; csym = csym->common_next)
+ {
+ if (csym->ts.type == BT_DERIVED
+ && !(csym->ts.derived->attr.sequence
+ || csym->ts.derived->attr.is_bind_c))
+ {
+ gfc_error_now ("Derived type variable '%s' in COMMON at %L "
+ "has neither the SEQUENCE nor the BIND(C) "
+ "attribute", csym->name,
+ &csym->declared_at);
+ }
+ else if (csym->ts.type == BT_DERIVED
+ && csym->ts.derived->attr.alloc_comp)
+ {
+ gfc_error_now ("Derived type variable '%s' in COMMON at %L "
+ "has an ultimate component that is "
+ "allocatable", csym->name,
+ &csym->declared_at);
+ }
+ }
- 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);
- }
+ gfc_find_symbol (common_root->name, gfc_current_ns, 0, &sym);
+ if (sym == NULL)
+ return;
- 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);
- }
- }
+ if (sym->attr.flavor == FL_PARAMETER)
+ gfc_error ("COMMON block '%s' at %L is used as PARAMETER at %L",
+ sym->name, &common_root->n.common->where, &sym->declared_at);
+
+ if (sym->attr.intrinsic)
+ gfc_error ("COMMON block '%s' at %L is also an intrinsic procedure",
+ sym->name, &common_root->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,
+ &common_root->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,
+ &common_root->n.common->where);
}
diff --git a/gcc/testsuite/ChangeLog b/gcc/testsuite/ChangeLog
index ae2f57b..5d2f257 100644
--- a/gcc/testsuite/ChangeLog
+++ b/gcc/testsuite/ChangeLog
@@ -1,3 +1,9 @@
+2007-08-26 Tobias Burnus <burnus@net-b.de>
+
+ PR fortran/32985
+ * gfortran.dg/namelist_14.f90: Make test case valid.
+ * gfortran.dg/common_10.f90: New.
+
2007-08-26 H.J. Lu <hongjiu.lu@intel.com>
PR middle-end/33181
diff --git a/gcc/testsuite/gfortran.dg/common_10.f90 b/gcc/testsuite/gfortran.dg/common_10.f90
new file mode 100644
index 0000000..cec443a
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/common_10.f90
@@ -0,0 +1,55 @@
+use iso_c_binding
+implicit none
+
+type, bind(C) :: mytype1
+ integer(c_int) :: x
+ real(c_float) :: y
+end type mytype1
+
+type mytype2
+ sequence
+ integer :: x
+ real :: y
+end type mytype2
+
+type mytype3
+ integer :: x
+ real :: y
+end type mytype3
+
+type mytype4
+ sequence
+ integer, allocatable, dimension(:) :: x
+end type mytype4
+
+type mytype5
+ sequence
+ integer, pointer :: x
+ integer :: y
+end type mytype5
+
+type mytype6
+ sequence
+ type(mytype5) :: t
+end type mytype6
+
+type mytype7
+ sequence
+ type(mytype4) :: t
+end type mytype7
+
+common /a/ t1
+common /b/ t2
+common /c/ t3 ! { dg-error "has neither the SEQUENCE nor the BIND.C. attribute" }
+common /d/ t4 ! { dg-error "has an ultimate component that is allocatable" }
+common /e/ t5
+common /f/ t6
+common /f/ t7 ! { dg-error "has an ultimate component that is allocatable" }
+type(mytype1) :: t1
+type(mytype2) :: t2
+type(mytype3) :: t3
+type(mytype4) :: t4
+type(mytype5) :: t5
+type(mytype6) :: t6
+type(mytype7) :: t7
+end
diff --git a/gcc/testsuite/gfortran.dg/namelist_14.f90 b/gcc/testsuite/gfortran.dg/namelist_14.f90
index e95495a..729f1b2 100644
--- a/gcc/testsuite/gfortran.dg/namelist_14.f90
+++ b/gcc/testsuite/gfortran.dg/namelist_14.f90
@@ -6,6 +6,7 @@
module global
type :: mt
+ sequence
integer :: ii(4)
end type mt
end module global
generated by cgit v1.1 at 2024-11-05 16:22:13 +0000