This is the mail archive of the
gcc-patches@gcc.gnu.org
mailing list for the GCC project.
Re: [PATCH, fortran] Equivalence constraints and private types -redux
Tobi
! sym->attr.in_equivalence = 1;
the last line is redundant.
Done:
This doesn't catch all incorrect cases:
equivalence (i,x) ! <- allowed
integer*8 j
equivalence (j,y) ! <- not allowed
I'm also not too fond of overloading the meaning of the BT_*. A new enum can
be used to solve both these issues at the same time.
I have attached a new version of the part of the patch that applies to
resolve.c and a test case to replace the original equiv_constraint_2.f90
(Although I have run it in addition to #2, hence the file name.).
Strictly, equiv_constraint_1.f90 is now redundant but it does answer
directly to the original PR so I have left it in the package.
The attached patch answers to both these points and distinguishes
default and non-default types.
The attached patch now makes gfortran, with -std=f95, as picky about
the constraints for equivalences as ifort.
Bubblestrapped and regtested on Cygwin_NT/i686 and FC3/Athlon.
OK for mainline and 4.0?
Paul T
Index: gcc/gcc/fortran/resolve.c
===================================================================
RCS file: /cvsroot/gcc/gcc/gcc/fortran/resolve.c,v
retrieving revision 1.52
diff -c -p -r1.52 resolve.c
*** gcc/gcc/fortran/resolve.c 31 Aug 2005 12:31:30 -0000 1.52
--- gcc/gcc/fortran/resolve.c 29 Sep 2005 13:57:30 -0000
*************** Software Foundation, 51 Franklin Street,
*** 25,30 ****
--- 25,37 ----
#include "gfortran.h"
#include "arith.h" /* For gfc_compare_expr(). */
+ /* Types used in equivalence statements. */
+
+ typedef enum seq_type
+ {
+ SEQ_NONDEFAULT, SEQ_NUMERIC, SEQ_CHARACTER, SEQ_MIXED
+ }
+ seq_type;
/* Stack to push the current if we descend into a block during
resolution. See resolve_branch() and resolve_code(). */
*************** resolve_symbol (gfc_symbol * sym)
*** 4074,4079 ****
--- 4081,4088 ----
gfc_symtree * symtree;
gfc_symtree * this_symtree;
gfc_namespace * ns;
+ gfc_component * c;
+ gfc_formal_arglist * arg;
if (sym->attr.flavor == FL_UNKNOWN)
{
*************** resolve_symbol (gfc_symbol * sym)
*** 4221,4226 ****
--- 4230,4277 ----
}
}
+ /* Ensure that derived type components of a public derived type
+ are not of a private type. */
+ if (sym->attr.flavor == FL_DERIVED
+ && gfc_check_access(sym->attr.access, sym->ns->default_access))
+ {
+ for (c = sym->components; c; c = c->next)
+ {
+ if (c->ts.type == BT_DERIVED
+ && !c->ts.derived->attr.use_assoc
+ && !gfc_check_access(c->ts.derived->attr.access,
+ c->ts.derived->ns->default_access))
+ {
+ gfc_error ("The component '%s' is a PRIVATE type and cannot be "
+ "a component of '%s', which is PUBLIC at %L",
+ c->name, sym->name, &sym->declared_at);
+ return;
+ }
+ }
+ }
+
+ /* Ensure that derived type formal arguments of a public procedure
+ are not of a private type. */
+ if (sym->attr.flavor == FL_PROCEDURE
+ && gfc_check_access(sym->attr.access, sym->ns->default_access))
+ {
+ for (arg = sym->formal; arg; arg = arg->next)
+ {
+ if (arg->sym
+ && arg->sym->ts.type == BT_DERIVED
+ && !gfc_check_access(arg->sym->ts.derived->attr.access,
+ arg->sym->ts.derived->ns->default_access))
+ {
+ gfc_error_now ("'%s' is a PRIVATE type and cannot be "
+ "a dummy argument of '%s', which is PUBLIC at %L",
+ arg->sym->name, sym->name, &sym->declared_at);
+ /* Stop this message from recurring. */
+ arg->sym->ts.derived->attr.access = ACCESS_PUBLIC;
+ return;
+ }
+ }
+ }
+
/* Constraints on deferred shape variable. */
if (sym->attr.flavor == FL_VARIABLE
|| (sym->attr.flavor == FL_PROCEDURE
*************** warn_unused_label (gfc_namespace * ns)
*** 4748,4753 ****
--- 4799,4863 ----
}
+ /* Returns the sequence type of a symbol or sequence. */
+
+ static seq_type
+ sequence_type (gfc_typespec ts)
+ {
+ seq_type result;
+ gfc_component *c;
+
+ switch (ts.type)
+ {
+ case BT_DERIVED:
+
+ if (ts.derived->components == NULL)
+ return SEQ_NONDEFAULT;
+
+ result = sequence_type (ts.derived->components->ts);
+ for (c = ts.derived->components->next; c; c = c->next)
+ if (sequence_type (c->ts) != result)
+ return SEQ_MIXED;
+
+ return result;
+
+ case BT_CHARACTER:
+ if (ts.kind != gfc_default_character_kind)
+ return SEQ_NONDEFAULT;
+
+ return SEQ_CHARACTER;
+
+ case BT_INTEGER:
+ if (ts.kind != gfc_default_integer_kind)
+ return SEQ_NONDEFAULT;
+
+ return SEQ_NUMERIC;
+
+ case BT_REAL:
+ if (!(ts.kind == gfc_default_real_kind
+ || ts.kind == gfc_default_double_kind))
+ return SEQ_NONDEFAULT;
+
+ return SEQ_NUMERIC;
+
+ case BT_COMPLEX:
+ if (ts.kind != gfc_default_complex_kind)
+ return SEQ_NONDEFAULT;
+
+ return SEQ_NUMERIC;
+
+ case BT_LOGICAL:
+ if (ts.kind != gfc_default_logical_kind)
+ return SEQ_NONDEFAULT;
+
+ return SEQ_NUMERIC;
+
+ default:
+ return SEQ_NONDEFAULT;
+ }
+ }
+
+
/* Resolve derived type EQUIVALENCE object. */
static try
*************** resolve_equivalence_derived (gfc_symbol
*** 4777,4783 ****
in the structure. */
if (c->pointer)
{
! gfc_error ("Derived type variable '%s' at %L has pointer componet(s) "
"cannot be an EQUIVALENCE object", sym->name, &e->where);
return FAILURE;
}
--- 4887,4900 ----
in the structure. */
if (c->pointer)
{
! gfc_error ("Derived type variable '%s' at %L with pointer component(s) "
! "cannot be an EQUIVALENCE object", sym->name, &e->where);
! return FAILURE;
! }
!
! if (c->initializer)
! {
! gfc_error ("Derived type variable '%s' at %L with default initializer "
"cannot be an EQUIVALENCE object", sym->name, &e->where);
return FAILURE;
}
*************** resolve_equivalence_derived (gfc_symbol
*** 4787,4808 ****
/* Resolve equivalence object.
! An EQUIVALENCE object shall not be a dummy argument, a pointer, an
! allocatable array, an object of nonsequence derived type, an object of
sequence derived type containing a pointer at any level of component
selection, an automatic object, a function name, an entry name, a result
name, a named constant, a structure component, or a subobject of any of
! the preceding objects. A substring shall not have length zero. */
static void
resolve_equivalence (gfc_equiv *eq)
{
gfc_symbol *sym;
gfc_symbol *derived;
gfc_expr *e;
gfc_ref *r;
! for (; eq; eq = eq->eq)
{
e = eq->expr;
--- 4904,4941 ----
/* Resolve equivalence object.
! An EQUIVALENCE object shall not be a dummy argument, a pointer, a target,
! an allocatable array, an object of nonsequence derived type, an object of
sequence derived type containing a pointer at any level of component
selection, an automatic object, a function name, an entry name, a result
name, a named constant, a structure component, or a subobject of any of
! the preceding objects. A substring shall not have length zero. A
! derived type shall not have components with default initialization nor
! shall two objects of an equivalence group be initialized.
! The simple constraints are done in symbol.c(check_conflict) and the rest
! are implemented here. */
static void
resolve_equivalence (gfc_equiv *eq)
{
gfc_symbol *sym;
gfc_symbol *derived;
+ gfc_symbol *first_sym;
gfc_expr *e;
gfc_ref *r;
+ locus *last_where = NULL;
+ seq_type eq_type, last_eq_type;
+ gfc_typespec *last_ts;
+ int object;
+ const char *value_name;
+ const char *msg;
! value_name = NULL;
! last_ts = &eq->expr->symtree->n.sym->ts;
!
! first_sym = eq->expr->symtree->n.sym;
!
! for (object = 1; eq; eq = eq->eq, object++)
{
e = eq->expr;
*************** resolve_equivalence (gfc_equiv *eq)
*** 4872,4909 ****
continue;
sym = e->symtree->n.sym;
-
- /* Shall not be a dummy argument. */
- if (sym->attr.dummy)
- {
- gfc_error ("Dummy argument '%s' at %L cannot be an EQUIVALENCE "
- "object", sym->name, &e->where);
- continue;
- }
! /* Shall not be an allocatable array. */
! if (sym->attr.allocatable)
! {
! gfc_error ("Allocatable array '%s' at %L cannot be an EQUIVALENCE "
! "object", sym->name, &e->where);
! continue;
! }
! /* Shall not be a pointer. */
! if (sym->attr.pointer)
{
! gfc_error ("Pointer '%s' at %L cannot be an EQUIVALENCE object",
! sym->name, &e->where);
! continue;
! }
!
! /* Shall not be a function name, ... */
! if (sym->attr.function || sym->attr.result || sym->attr.entry
! || sym->attr.subroutine)
! {
! gfc_error ("Entity '%s' at %L cannot be an EQUIVALENCE object",
! sym->name, &e->where);
! continue;
}
/* Shall not be a named constant. */
--- 5005,5035 ----
continue;
sym = e->symtree->n.sym;
! /* An equivalence statement cannot have more than one initialized
! object. */
! if (sym->value)
! {
! if (value_name != NULL)
! {
! gfc_error ("Initialized objects '%s' and '%s' cannot both "
! "be in the EQUIVALENCE statement at %L",
! value_name, sym->name, &e->where);
! continue;
! }
! else
! value_name = sym->name;
! }
! /* Shall not equivalence common block variables in a PURE procedure. */
! if (sym->ns->proc_name
! && sym->ns->proc_name->attr.pure
! && sym->attr.in_common)
{
! gfc_error ("Common block member '%s' at %L cannot be an EQUIVALENCE "
! "object in the pure procedure '%s'",
! sym->name, &e->where, sym->ns->proc_name->name);
! break;
}
/* Shall not be a named constant. */
*************** resolve_equivalence (gfc_equiv *eq)
*** 4917,4922 ****
--- 5043,5111 ----
derived = e->ts.derived;
if (derived && resolve_equivalence_derived (derived, sym, e) == FAILURE)
continue;
+
+ /* Check that the types correspond correctly:
+ Note 5.28:
+ A numeric sequence structure may be equivalenced to another sequence
+ structure, an object of default integer type, default real type, double
+ precision real type, default logical type such that components of the
+ structure ultimately only become associated to objects of the same
+ kind. A character sequence structure may be equivalenced to an object
+ of default character kind or another character sequence structure.
+ Other objects may be equivalenced only to objects of the same type and
+ kind parameters. */
+
+ /* Identical types are unconditionally OK. */
+ if (object == 1 || gfc_compare_types (last_ts, &sym->ts))
+ goto identical_types;
+
+ last_eq_type = sequence_type (*last_ts);
+ eq_type = sequence_type (sym->ts);
+
+ /* Since the pair of objects is not of the same type, mixed or
+ non-default sequences can be rejected. */
+
+ msg = "Sequence %s with mixed components in EQUIVALENCE "
+ "statement at %L with different type objects";
+ if ((object ==2
+ && last_eq_type == SEQ_MIXED
+ && gfc_notify_std (GFC_STD_GNU, msg, first_sym->name,
+ last_where) == FAILURE)
+ || (eq_type == SEQ_MIXED
+ && gfc_notify_std (GFC_STD_GNU, msg,sym->name,
+ &e->where) == FAILURE))
+ continue;
+
+ msg = "Non-default type object or sequence %s in EQUIVALENCE "
+ "statement at %L with objects of different type";
+ if ((object ==2
+ && last_eq_type == SEQ_NONDEFAULT
+ && gfc_notify_std (GFC_STD_GNU, msg, first_sym->name,
+ last_where) == FAILURE)
+ || (eq_type == SEQ_NONDEFAULT
+ && gfc_notify_std (GFC_STD_GNU, msg, sym->name,
+ &e->where) == FAILURE))
+ continue;
+
+ msg ="Non-CHARACTER object '%s' in default CHARACTER "
+ "EQUIVALENCE statement at %L";
+ if (last_eq_type == SEQ_CHARACTER
+ && eq_type != SEQ_CHARACTER
+ && gfc_notify_std (GFC_STD_GNU, msg, sym->name,
+ &e->where) == FAILURE)
+ continue;
+
+ msg ="Non-NUMERIC object '%s' in default NUMERIC "
+ "EQUIVALENCE statement at %L";
+ if (last_eq_type == SEQ_NUMERIC
+ && eq_type != SEQ_NUMERIC
+ && gfc_notify_std (GFC_STD_GNU, msg, sym->name,
+ &e->where) == FAILURE)
+ continue;
+
+ identical_types:
+ last_ts =&sym->ts;
+ last_where = &e->where;
if (!e->ref)
continue;
! { dg-do compile }
! { dg-options "-std=f95" }
!
! PR20901 - Checks resolution of types in EQUIVALENCE statement when
! f95 standard is imposed.
!
! Contributed by Paul Thomas <pault@gcc.gnu.org>
!
type :: numeric_type
sequence
integer :: i
real :: x
real*8 :: d
complex :: z
logical :: l
end type numeric_type
type (numeric_type) :: my_num, thy_num
type :: numeric_type2
sequence
integer :: i
real :: x
real*8 :: d
complex :: z
logical :: l
end type numeric_type2
type (numeric_type2) :: his_num
type :: char_type
sequence
character*4 :: ch
character*4 :: cha (6)
end type char_type
type (char_type) :: my_char
type :: mixed_type
sequence
integer*4 :: i(4)
character*4 :: cha (6)
end type mixed_type
type (mixed_type) :: my_mixed, thy_mixed
character(len=4) :: ch
integer :: num
integer*8 :: non_def
complex*16 :: my_z, thy_z
! Permitted: character with character sequence
! numeric with numeric sequence
! numeric sequence with numeric sequence
! non-default of same type
! mixed sequences of same type
equivalence (ch, my_char)
equivalence (num, my_num)
equivalence (my_num, his_num, thy_num)
equivalence (my_z, thy_z)
equivalence (my_mixed, thy_mixed)
! Not permitted by the standard - OK with -std=gnu
equivalence (my_mixed, my_num) ! { dg-error "with mixed components in EQUIVALENCE" }
equivalence (my_z, num) ! { dg-error "Non-default type object or sequence" }
equivalence (my_char, my_num) ! { dg-error "in default CHARACTER EQUIVALENCE" }
equivalence (ch, my_num) ! { dg-error "in default CHARACTER EQUIVALENCE" }
equivalence (my_num, ch) ! { dg-error "in default NUMERIC EQUIVALENCE" }
equivalence (num, my_char) ! { dg-error "in default NUMERIC EQUIVALENCE" }
equivalence (my_char, num) ! { dg-error "in default CHARACTER EQUIVALENCE" }
equivalence (non_def, ch) ! { dg-error "Non-default type object or sequence" }
equivalence (my_z, ch) ! { dg-error "Non-default type object or sequence" }
equivalence (my_z, num) ! { dg-error "Non-default type object or sequence" }
END