This is the mail archive of the
gcc-patches@gcc.gnu.org
mailing list for the GCC project.
[PATCH, fortran] Equivalence constraints and private types - redux
:ADDPATCH fortran:
This proposed patch applies a number of constraints, required by the f95
standard, that were missing from gfortran. These are mainly to do with
equivalence objects but two are connected with private types.
It is a rework of the previously posted patch that puts as many of the
constraints as possible in symbol.c(check_conflict) and handles
sequences of characters or numeric types more correctly. The standard
talks about non-default types and sequences of non-default types being
treated as separate types. This was getting to be such a pain to do
that I have not incorporated this coondition.
I have only made the constraint on equivalence mixing of
numeric/character/structure subject to the -std=f95 option for g77
compatibility and for general convenience.
Regtested on Cygwin/i686 and FC3/Athlon 1700.
OK for mainline and 4.03, when open?
Paul T
===================================================================
2005-09-23 Paul Thomas <pault@gcc.gnu.org>
PR fortran/16404
PR fortran/20835
PR fortran/20890
PR fortran/20899
PR fortran/20900
PR fortran/20901
PR fortran/20902
* gfortran.h: Prototype for gfc_add_in_equivalence.
* match.c (gfc_match_equivalence): Make a structure component
an explicit,rather than a syntax, error in an equivalence
group. Call gfc_add_in_equivalence to add the constraints
imposed in check_conflict.
* resolve.c (resolve_symbol): Add constraints: No public
structures with private-type components and no public
procedures with private-type dummy arguments.
(resolve_equivalence_derived): Add constraint that prevents
a structure equivalence member from having a default
initializer.
(sequence_type): New static function to determine whether an
object is numeric/character/mixed type or sequence.
(resolve_equivalence): Add constraints to equivalence groups
or their members: No more than one initialized member and
that different types are not equivalenced for std=f95. All
the simple constraints have been moved to check_conflict.
* symbol.c (check_conflict): Simple equivalence constraints
added, including those removed from resolve_symbol.
(gfc_add_in_equivalence): New function to interface calls
match_equivalence to check_conflict.
2005-09-23 Paul Thomas <pault@gcc.gnu.org>
PR fortran/16404
PR fortran/20835
PR fortran/20890
PR fortran/20899
PR fortran/20900
PR fortran/20901
PR fortran/20902
gfortran.dg/equiv_constraint_1.f90: New test.
gfortran.dg/equiv_constraint_2.f90: New test.
gfortran.dg/equiv_constraint_3.f90: New test.
gfortran.dg/equiv_constraint_4.f90: New test.
gfortran.dg/equiv_constraint_5.f90: New test.
gfortran.dg/equiv_constraint_6.f90: New test.
gfortran.dg/equiv_constraint_7.f90: New test.
gfortran.dg/equiv_constraint_8.f90: New test.
gfortran.dg/private_type_1.f90: New test.
gfortran.dg/private_type_2.f90: New test.
gfortran.dg/g77/980628-3.f, 980628-3.f, 980628-9.f,
980628-10.f: Assert std=gnu to permit mixing of
types in equivalence statements.
Index: gcc/gcc/fortran/gfortran.h
===================================================================
RCS file: /cvs/gcc/gcc/gcc/fortran/gfortran.h,v
retrieving revision 1.87
diff -c -p -r1.87 gfortran.h
*** gcc/gcc/fortran/gfortran.h 17 Sep 2005 18:57:59 -0000 1.87
--- gcc/gcc/fortran/gfortran.h 27 Sep 2005 04:23:54 -0000
*************** try gfc_add_dummy (symbol_attribute *, c
*** 1639,1644 ****
--- 1639,1645 ----
try gfc_add_generic (symbol_attribute *, const char *, locus *);
try gfc_add_common (symbol_attribute *, locus *);
try gfc_add_in_common (symbol_attribute *, const char *, locus *);
+ try gfc_add_in_equivalence (symbol_attribute *, const char *, locus *);
try gfc_add_data (symbol_attribute *, const char *, locus *);
try gfc_add_in_namelist (symbol_attribute *, const char *, locus *);
try gfc_add_sequence (symbol_attribute *, const char *, locus *);
Index: gcc/gcc/fortran/match.c
===================================================================
RCS file: /cvs/gcc/gcc/gcc/fortran/match.c,v
retrieving revision 1.45
diff -c -p -r1.45 match.c
*** gcc/gcc/fortran/match.c 9 Sep 2005 00:23:05 -0000 1.45
--- gcc/gcc/fortran/match.c 27 Sep 2005 04:23:58 -0000
*************** gfc_match_equivalence (void)
*** 2622,2627 ****
--- 2622,2634 ----
if (m == MATCH_NO)
goto syntax;
+ if (gfc_match_char ('%') == MATCH_YES)
+ {
+ gfc_error ("Derived type component %C is not a "
+ "permitted EQUIVALENCE member");
+ goto cleanup;
+ }
+
for (ref = set->expr->ref; ref; ref = ref->next)
if (ref->type == REF_ARRAY && ref->u.ar.type == AR_SECTION)
{
*************** gfc_match_equivalence (void)
*** 2631,2643 ****
goto cleanup;
}
! if (set->expr->symtree->n.sym->attr.in_common)
{
common_flag = TRUE;
! common_head = set->expr->symtree->n.sym->common_head;
}
! set->expr->symtree->n.sym->attr.in_equivalence = 1;
if (gfc_match_char (')') == MATCH_YES)
break;
--- 2638,2656 ----
goto cleanup;
}
! sym = set->expr->symtree->n.sym;
!
! if (gfc_add_in_equivalence (&sym->attr, sym->name, NULL)
! == FAILURE)
! goto cleanup;
!
! if (sym->attr.in_common)
{
common_flag = TRUE;
! common_head = sym->common_head;
}
! sym->attr.in_equivalence = 1;
if (gfc_match_char (')') == MATCH_YES)
break;
Index: gcc/gcc/fortran/resolve.c
===================================================================
RCS file: /cvs/gcc/gcc/gcc/fortran/resolve.c,v
retrieving revision 1.55
diff -c -p -r1.55 resolve.c
*** gcc/gcc/fortran/resolve.c 22 Sep 2005 21:51:58 -0000 1.55
--- gcc/gcc/fortran/resolve.c 27 Sep 2005 04:24:06 -0000
*************** resolve_symbol (gfc_symbol * sym)
*** 4124,4129 ****
--- 4124,4131 ----
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)
*** 4274,4279 ****
--- 4276,4323 ----
}
}
+ /* 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)
*** 4802,4807 ****
--- 4846,4892 ----
}
+ /* Returns the type of a symbol or sequence. BT_INTEGER for numeric,
+ BT_CHARACTER for characters and BT_UNKNOWN for mixed sequences. */
+
+ static bt
+ sequence_type (gfc_typespec ts)
+ {
+ bt result;
+ gfc_component *c;
+
+ switch (ts.type)
+ {
+ case BT_DERIVED:
+
+ if (ts.derived->components == NULL)
+ return BT_UNKNOWN;
+
+ result = sequence_type (ts.derived->components->ts);
+ for (c = ts.derived->components->next; c; c = c->next)
+ if (sequence_type (c->ts) != result)
+ return BT_UNKNOWN;
+
+ return result;
+
+ case BT_CHARACTER:
+ return BT_CHARACTER;
+
+ /* Use BT_INTEGER to signal default numeric types, assuming types
+ disallowed have already been caught. */
+ case BT_INTEGER:
+ case BT_REAL:
+ case BT_COMPLEX:
+ case BT_LOGICAL:
+
+ return BT_INTEGER;
+
+ default:
+ return BT_UNKNOWN;
+ }
+ }
+
+
/* Resolve derived type EQUIVALENCE object. */
static try
*************** resolve_equivalence_derived (gfc_symbol
*** 4831,4837 ****
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;
}
--- 4916,4929 ----
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
*** 4841,4860 ****
/* 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)
{
--- 4933,4963 ----
/* 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 *dt;
gfc_expr *e;
gfc_ref *r;
+ const char *value_name;
+ bt equiv_type, previous_equiv_type;
+
+ value_name = NULL;
+ previous_equiv_type = sequence_type (eq->expr->symtree->n.sym->ts);
+ dt = eq->expr->symtree->n.sym->ts.derived;
for (; eq; eq = eq->eq)
{
*************** resolve_equivalence (gfc_equiv *eq)
*** 4926,4963 ****
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. */
--- 5029,5121 ----
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;
! }
! /* 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.
! This has been implemented without checking for default types. */
!
!
! equiv_type = sequence_type (sym->ts);
!
! if (previous_equiv_type == BT_UNKNOWN || equiv_type == BT_UNKNOWN)
! {
! if (equiv_type != previous_equiv_type)
! {
! if (gfc_notify_std (GFC_STD_GNU,
! "Mixed types in EQUIVALENCE statement at %L",
! &e->where) == FAILURE)
! continue;
! }
! else
! {
! if (dt != sym->ts.derived
! && gfc_notify_std (GFC_STD_GNU,
! "Different derived types in EQUIVALENCE "
! "statement at %L", &e->where) == FAILURE)
! continue;
! }
! }
!
! dt = sym->ts.derived;
!
! if (previous_equiv_type == BT_CHARACTER)
! {
! if (equiv_type != BT_CHARACTER)
! {
! if (gfc_notify_std (GFC_STD_GNU,
! "Non-CHARACTER object '%s' in CHARACTER "
! "EQUIVALENCE statement at %L",
! sym->name, &e->where) == FAILURE)
! continue;
! }
! }
!
! if (previous_equiv_type == BT_INTEGER)
! {
! if (equiv_type != BT_INTEGER)
! {
! if (gfc_notify_std (GFC_STD_GNU,
! "Non-numeric object '%s' in numeric "
! "EQUIVALENCE statement at %L",
! sym->name, &e->where) == FAILURE)
! continue;
! }
! }
!
! previous_equiv_type = equiv_type;
!
! /* 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. */
Index: gcc/gcc/fortran/symbol.c
===================================================================
RCS file: /cvs/gcc/gcc/gcc/fortran/symbol.c,v
retrieving revision 1.34
diff -c -p -r1.34 symbol.c
*** gcc/gcc/fortran/symbol.c 17 Sep 2005 18:58:00 -0000 1.34
--- gcc/gcc/fortran/symbol.c 27 Sep 2005 04:24:08 -0000
*************** check_conflict (symbol_attribute * attr,
*** 262,268 ****
*in_common = "COMMON", *result = "RESULT", *in_namelist = "NAMELIST",
*public = "PUBLIC", *optional = "OPTIONAL", *entry = "ENTRY",
*function = "FUNCTION", *subroutine = "SUBROUTINE",
! *dimension = "DIMENSION";
const char *a1, *a2;
--- 262,269 ----
*in_common = "COMMON", *result = "RESULT", *in_namelist = "NAMELIST",
*public = "PUBLIC", *optional = "OPTIONAL", *entry = "ENTRY",
*function = "FUNCTION", *subroutine = "SUBROUTINE",
! *dimension = "DIMENSION", *in_equivalence = "EQUIVALENCE",
! *use_assoc = "USE ASSOCIATED";
const char *a1, *a2;
*************** check_conflict (symbol_attribute * attr,
*** 323,328 ****
--- 324,338 ----
conf (in_common, result);
conf (dummy, result);
+ conf (in_equivalence, use_assoc);
+ conf (in_equivalence, dummy);
+ conf (in_equivalence, target);
+ conf (in_equivalence, pointer);
+ conf (in_equivalence, function);
+ conf (in_equivalence, result);
+ conf (in_equivalence, entry);
+ conf (in_equivalence, allocatable);
+
conf (in_namelist, pointer);
conf (in_namelist, allocatable);
*************** gfc_add_in_common (symbol_attribute * at
*** 726,731 ****
--- 736,756 ----
return gfc_add_flavor (attr, FL_VARIABLE, name, where);
}
+ try
+ gfc_add_in_equivalence (symbol_attribute * attr, const char *name, locus * where)
+ {
+
+ /* Duplicate attribute already checked for. */
+ attr->in_equivalence = 1;
+ if (check_conflict (attr, name, where) == FAILURE)
+ return FAILURE;
+
+ if (attr->flavor == FL_VARIABLE)
+ return SUCCESS;
+
+ return gfc_add_flavor (attr, FL_VARIABLE, name, where);
+ }
+
try
gfc_add_data (symbol_attribute *attr, const char *name, locus *where)
? gcc/gcc/testsuite/gfortran.dg/equiv_constraint_2.f90
? gcc/gcc/testsuite/gfortran.dg/equiv_constraint_3.f90
? gcc/gcc/testsuite/gfortran.dg/equiv_constraint_4.f90
? gcc/gcc/testsuite/gfortran.dg/equiv_constraint_5.f90
? gcc/gcc/testsuite/gfortran.dg/equiv_constraint_6.f90
? gcc/gcc/testsuite/gfortran.dg/equiv_constraint_7.f90
? gcc/gcc/testsuite/gfortran.dg/equiv_constraint_8.f90
? gcc/gcc/testsuite/gfortran.dg/private_type_1.f90
? gcc/gcc/testsuite/gfortran.dg/private_type_2.f90
Index: gcc/gcc/testsuite/gfortran.dg/g77/980628-10.f
===================================================================
RCS file: /cvs/gcc/gcc/gcc/testsuite/gfortran.dg/g77/980628-10.f,v
retrieving revision 1.1
diff -c -p -r1.1 980628-10.f
*** gcc/gcc/testsuite/gfortran.dg/g77/980628-10.f 21 Jul 2004 00:00:24 -0000 1.1
--- gcc/gcc/testsuite/gfortran.dg/g77/980628-10.f 27 Sep 2005 04:27:43 -0000
***************
*** 1,4 ****
--- 1,5 ----
c { dg-do run }
+ c { dg-options "-std=gnu" }
* g77 0.5.23 and previous had bugs involving too little space
* allocated for EQUIVALENCE and COMMON areas needing initial
* padding to meet alignment requirements of the system.
Index: gcc/gcc/testsuite/gfortran.dg/g77/980628-2.f
===================================================================
RCS file: /cvs/gcc/gcc/gcc/testsuite/gfortran.dg/g77/980628-2.f,v
retrieving revision 1.1
diff -c -p -r1.1 980628-2.f
*** gcc/gcc/testsuite/gfortran.dg/g77/980628-2.f 21 Jul 2004 00:00:24 -0000 1.1
--- gcc/gcc/testsuite/gfortran.dg/g77/980628-2.f 27 Sep 2005 04:27:43 -0000
***************
*** 1,4 ****
--- 1,5 ----
c { dg-do run }
+ c { dg-options "-std=gnu" }
* g77 0.5.23 and previous had bugs involving too little space
* allocated for EQUIVALENCE and COMMON areas needing initial
* padding to meet alignment requirements of the system.
Index: gcc/gcc/testsuite/gfortran.dg/g77/980628-3.f
===================================================================
RCS file: /cvs/gcc/gcc/gcc/testsuite/gfortran.dg/g77/980628-3.f,v
retrieving revision 1.1
diff -c -p -r1.1 980628-3.f
*** gcc/gcc/testsuite/gfortran.dg/g77/980628-3.f 21 Jul 2004 00:00:24 -0000 1.1
--- gcc/gcc/testsuite/gfortran.dg/g77/980628-3.f 27 Sep 2005 04:27:43 -0000
***************
*** 1,4 ****
--- 1,6 ----
c { dg-do run }
+ c { dg-options "-std=gnu" }
+ c
* g77 0.5.23 and previous had bugs involving too little space
* allocated for EQUIVALENCE and COMMON areas needing initial
* padding to meet alignment requirements of the system.
Index: gcc/gcc/testsuite/gfortran.dg/g77/980628-9.f
===================================================================
RCS file: /cvs/gcc/gcc/gcc/testsuite/gfortran.dg/g77/980628-9.f,v
retrieving revision 1.1
diff -c -p -r1.1 980628-9.f
*** gcc/gcc/testsuite/gfortran.dg/g77/980628-9.f 21 Jul 2004 00:00:24 -0000 1.1
--- gcc/gcc/testsuite/gfortran.dg/g77/980628-9.f 27 Sep 2005 04:27:43 -0000
***************
*** 1,4 ****
--- 1,5 ----
c { dg-do run }
+ c { dg-options "-std=gnu" }
* g77 0.5.23 and previous had bugs involving too little space
* allocated for EQUIVALENCE and COMMON areas needing initial
* padding to meet alignment requirements of the system.
!======gfortran.dg/equiv_constraint_1.f90===========
! { dg-do compile }
! { dg-options "-std=f95" }
! PR20901 - F95 constrains mixing of types in equivalence.
! Contributed by Joost VandeVondele <jv244@cam.ac.uk>
character(len=4) :: a
integer :: i
equivalence(a,i) ! { dg-error "in CHARACTER EQUIVALENCE statement at" }
END
!======gfortran.dg/equiv_constraint_2.f90===========
! { dg-do compile }
! { dg-options "-std=f95" }
! PR20901 - F95 constrains mixing of types in equivalence.
! Contributed by Joost VandeVondele <jv244@cam.ac.uk>
TYPE data_type
SEQUENCE
character :: j
END TYPE data_type
INTEGER :: j
TYPE (data_type) :: d
EQUIVALENCE (d, J) ! { dg-error "in CHARACTER EQUIVALENCE statement" }
END
!======gfortran.dg/equiv_constraint_3.f90===========
! { dg-do compile }
! PR20900 - USE associated variables cannot be equivalenced.
! Contributed by Joost VandeVondele <jv244@cam.ac.uk>
MODULE TEST
INTEGER :: I
END MODULE
! note 11.7
USE TEST, ONLY : K=>I
INTEGER :: L
EQUIVALENCE(K,L) ! { dg-error "conflicts with USE ASSOCIATED attribute" }
END
!======gfortran.dg/equiv_constraint_4.f90===========
! { dg-do run }
! { dg-options "-O0" }
! PR20901 - check that derived/numeric equivalence works with std!=f95.
! Contributed by Joost VandeVondele <jv244@cam.ac.uk>
TYPE data_type
SEQUENCE
INTEGER :: I
END TYPE data_type
INTEGER :: J = 7
TYPE(data_type) :: dd
EQUIVALENCE(dd,J)
if (dd%i.ne.7) call abort ()
END
!======gfortran.dg/equiv_constraint_5.f90===========
! { dg-do compile }
! { dg-options "-O0" }
! PR20902 - Structure with default initializer cannot be equivalence memeber.
! Contributed by Joost VandeVondele <jv244@cam.ac.uk>
TYPE T1
sequence
integer :: i=1
END TYPE T1
TYPE T2
sequence
integer :: i ! drop original initializer to pick up error below.
END TYPE T2
TYPE(T1) :: a1
TYPE(T2) :: a2
EQUIVALENCE(a1,a2) ! { dg-error "initializer cannot be an EQUIVALENCE" }
write(6,*) a1,a2
END
!======gfortran.dg/equiv_constraint_6.f90===========
! { dg-do compile }
! PR16404 test 3 and PR20835 - Target cannot be equivalence object.
! Contributed by Joost VandeVondele <jv244@cam.ac.uk>
REAL :: A
REAL, TARGET :: B
EQUIVALENCE(A,B) ! { dg-error "conflicts with TARGET attribute" }
END
!======gfortran.dg/equiv_constraint_7.f90===========
! { dg-do compile }
! { dg-options "-O0" }
! PR20890 - Equivalence cannot contain more than one initialized variables.
! Contributed by Joost VandeVondele <jv244@cam.ac.uk>
BLOCK DATA
INTEGER :: I=1,J=2
EQUIVALENCE(I,J) ! { dg-error "cannot both be in the EQUIVALENCE" }
END BLOCK DATA
END
!======gfortran.dg/equiv_constraint_8.f90===========
! { dg-do compile }
! { dg-options "-O0" }
! PR20899 - Common block variables cannot be equivalenced in a pure procedure.
! Contributed by Joost VandeVondele <jv244@cam.ac.uk>
common /z/ i
contains
pure integer function test(j)
integer, intent(in) :: j
common /z/ i
integer :: k
equivalence(i,k) ! { dg-error "EQUIVALENCE object in the pure" }
k=1 ! { dg-error "in PURE procedure at" }
test=i*j
end function test
end
!======gfortran.dg/private_type_1.f90===============
! { dg-do compile }
! PR21986 - test based on original example.
! A public subroutine must not have private-type, dummy arguments.
! Contributed by Paul Thomas <pault@gcc.gnu.org>
module modboom
implicit none
private
public:: dummysub ! { dg-error "PRIVATE type and cannot be a dummy argument" }
type:: intwrapper
integer n
end type intwrapper
contains
subroutine dummysub(size, arg_array)
type(intwrapper) :: size
real, dimension(size%n) :: arg_array
real :: local_array(4)
end subroutine dummysub
end module modboom
!======gfortran.dg/private_type_2.f90===============
! { dg-do compile }
! PR16404 test 6 - A public type cannot have private-type components.
! Contributed by Joost VandeVondele <jv244@cam.ac.uk>
MODULE TEST
PRIVATE
TYPE :: info_type
INTEGER :: value
END TYPE info_type
TYPE :: all_type! { dg-error "PRIVATE type and cannot be a component" }
TYPE(info_type) :: info
END TYPE
public all_type
END MODULE
END