diff options
Diffstat (limited to 'gcc')
20 files changed, 523 insertions, 39 deletions
diff --git a/gcc/fortran/ChangeLog b/gcc/fortran/ChangeLog index 4334c3c..145d10b 100644 --- a/gcc/fortran/ChangeLog +++ b/gcc/fortran/ChangeLog @@ -1,3 +1,35 @@ +2005-10-01 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 default numeric, default character, non-default + or mixed sequence. Add corresponding enum typespec. + (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-27 Jakub Jelinek <jakub@redhat.com> PR fortran/18518 diff --git a/gcc/fortran/gfortran.h b/gcc/fortran/gfortran.h index 9cd2845..1923826 100644 --- a/gcc/fortran/gfortran.h +++ b/gcc/fortran/gfortran.h @@ -1639,6 +1639,7 @@ try gfc_add_dummy (symbol_attribute *, const char *, locus *); 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 *); diff --git a/gcc/fortran/match.c b/gcc/fortran/match.c index 5a62633..3f94874 100644 --- a/gcc/fortran/match.c +++ b/gcc/fortran/match.c @@ -2622,6 +2622,13 @@ gfc_match_equivalence (void) 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) { @@ -2631,14 +2638,18 @@ gfc_match_equivalence (void) goto cleanup; } - if (set->expr->symtree->n.sym->attr.in_common) + 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 = set->expr->symtree->n.sym->common_head; + common_head = sym->common_head; } - set->expr->symtree->n.sym->attr.in_equivalence = 1; - if (gfc_match_char (')') == MATCH_YES) break; if (gfc_match_char (',') != MATCH_YES) diff --git a/gcc/fortran/resolve.c b/gcc/fortran/resolve.c index a048da5..192a18c3 100644 --- a/gcc/fortran/resolve.c +++ b/gcc/fortran/resolve.c @@ -25,6 +25,13 @@ Software Foundation, 51 Franklin Street, Fifth Floor,Boston, MA #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(). */ @@ -4124,6 +4131,8 @@ resolve_symbol (gfc_symbol * sym) gfc_symtree * symtree; gfc_symtree * this_symtree; gfc_namespace * ns; + gfc_component * c; + gfc_formal_arglist * arg; if (sym->attr.flavor == FL_UNKNOWN) { @@ -4274,6 +4283,48 @@ resolve_symbol (gfc_symbol * sym) } } + /* 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 @@ -4802,6 +4853,65 @@ warn_unused_label (gfc_namespace * ns) } +/* 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 @@ -4831,7 +4941,14 @@ resolve_equivalence_derived (gfc_symbol *derived, gfc_symbol *sym, gfc_expr *e) in the structure. */ if (c->pointer) { - gfc_error ("Derived type variable '%s' at %L has pointer componet(s) " + 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; } @@ -4841,22 +4958,38 @@ resolve_equivalence_derived (gfc_symbol *derived, gfc_symbol *sym, gfc_expr *e) /* 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 + 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. */ + 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; - for (; eq; eq = eq->eq) + first_sym = eq->expr->symtree->n.sym; + + for (object = 1; eq; eq = eq->eq, object++) { e = eq->expr; @@ -4926,38 +5059,31 @@ resolve_equivalence (gfc_equiv *eq) 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; - } + /* 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 be a pointer. */ - if (sym->attr.pointer) + /* 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 ("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; + 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. */ @@ -4972,6 +5098,69 @@ resolve_equivalence (gfc_equiv *eq) 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; diff --git a/gcc/fortran/symbol.c b/gcc/fortran/symbol.c index de2de4b..aceac5b 100644 --- a/gcc/fortran/symbol.c +++ b/gcc/fortran/symbol.c @@ -262,7 +262,8 @@ check_conflict (symbol_attribute * attr, const char * name, locus * where) *in_common = "COMMON", *result = "RESULT", *in_namelist = "NAMELIST", *public = "PUBLIC", *optional = "OPTIONAL", *entry = "ENTRY", *function = "FUNCTION", *subroutine = "SUBROUTINE", - *dimension = "DIMENSION"; + *dimension = "DIMENSION", *in_equivalence = "EQUIVALENCE", + *use_assoc = "USE ASSOCIATED"; const char *a1, *a2; @@ -323,6 +324,15 @@ check_conflict (symbol_attribute * attr, const char * name, locus * where) 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); @@ -726,6 +736,21 @@ gfc_add_in_common (symbol_attribute * attr, const char *name, locus * where) 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) diff --git a/gcc/testsuite/ChangeLog b/gcc/testsuite/ChangeLog index 65f5957..00b067a 100644 --- a/gcc/testsuite/ChangeLog +++ b/gcc/testsuite/ChangeLog @@ -1,3 +1,26 @@ +2005-10-01 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-2.f, 980628-3.f, 980628-9.f, + 980628-10.f: Assert std=gnu to permit mixing of + types in equivalence statements. + 2005-09-30 Janne Blomqvist <jblomqvi@cc.hut.fi> PR 24112 diff --git a/gcc/testsuite/gfortran.dg/equiv_constraint_1.f90 b/gcc/testsuite/gfortran.dg/equiv_constraint_1.f90 new file mode 100644 index 0000000..75c3aa8 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/equiv_constraint_1.f90 @@ -0,0 +1,10 @@ +! { 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 default CHARACTER EQUIVALENCE statement at" } + END + + diff --git a/gcc/testsuite/gfortran.dg/equiv_constraint_2.f90 b/gcc/testsuite/gfortran.dg/equiv_constraint_2.f90 new file mode 100644 index 0000000..2c3578d --- /dev/null +++ b/gcc/testsuite/gfortran.dg/equiv_constraint_2.f90 @@ -0,0 +1,74 @@ +! { 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 diff --git a/gcc/testsuite/gfortran.dg/equiv_constraint_3.f90 b/gcc/testsuite/gfortran.dg/equiv_constraint_3.f90 new file mode 100644 index 0000000..89d4fcb --- /dev/null +++ b/gcc/testsuite/gfortran.dg/equiv_constraint_3.f90 @@ -0,0 +1,13 @@ +! { 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 + + diff --git a/gcc/testsuite/gfortran.dg/equiv_constraint_4.f90 b/gcc/testsuite/gfortran.dg/equiv_constraint_4.f90 new file mode 100644 index 0000000..be9591a --- /dev/null +++ b/gcc/testsuite/gfortran.dg/equiv_constraint_4.f90 @@ -0,0 +1,16 @@ +! { 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 + + + diff --git a/gcc/testsuite/gfortran.dg/equiv_constraint_5.f90 b/gcc/testsuite/gfortran.dg/equiv_constraint_5.f90 new file mode 100644 index 0000000..1eefa81 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/equiv_constraint_5.f90 @@ -0,0 +1,18 @@ +! { 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 + diff --git a/gcc/testsuite/gfortran.dg/equiv_constraint_6.f90 b/gcc/testsuite/gfortran.dg/equiv_constraint_6.f90 new file mode 100644 index 0000000..9cc4c9b --- /dev/null +++ b/gcc/testsuite/gfortran.dg/equiv_constraint_6.f90 @@ -0,0 +1,8 @@ +! { 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 + diff --git a/gcc/testsuite/gfortran.dg/equiv_constraint_7.f90 b/gcc/testsuite/gfortran.dg/equiv_constraint_7.f90 new file mode 100644 index 0000000..ec4579f --- /dev/null +++ b/gcc/testsuite/gfortran.dg/equiv_constraint_7.f90 @@ -0,0 +1,9 @@ +! { 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 diff --git a/gcc/testsuite/gfortran.dg/equiv_constraint_8.f90 b/gcc/testsuite/gfortran.dg/equiv_constraint_8.f90 new file mode 100644 index 0000000..9a742ee --- /dev/null +++ b/gcc/testsuite/gfortran.dg/equiv_constraint_8.f90 @@ -0,0 +1,16 @@ +! { 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 + diff --git a/gcc/testsuite/gfortran.dg/g77/980628-10.f b/gcc/testsuite/gfortran.dg/g77/980628-10.f index 4a0eb23..b7429e4 100644 --- a/gcc/testsuite/gfortran.dg/g77/980628-10.f +++ b/gcc/testsuite/gfortran.dg/g77/980628-10.f @@ -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. diff --git a/gcc/testsuite/gfortran.dg/g77/980628-2.f b/gcc/testsuite/gfortran.dg/g77/980628-2.f index 6324876..89a9e23 100644 --- a/gcc/testsuite/gfortran.dg/g77/980628-2.f +++ b/gcc/testsuite/gfortran.dg/g77/980628-2.f @@ -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. diff --git a/gcc/testsuite/gfortran.dg/g77/980628-3.f b/gcc/testsuite/gfortran.dg/g77/980628-3.f index ca10f18..dea368d 100644 --- a/gcc/testsuite/gfortran.dg/g77/980628-3.f +++ b/gcc/testsuite/gfortran.dg/g77/980628-3.f @@ -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. diff --git a/gcc/testsuite/gfortran.dg/g77/980628-9.f b/gcc/testsuite/gfortran.dg/g77/980628-9.f index ea2dd54..7e2f227 100644 --- a/gcc/testsuite/gfortran.dg/g77/980628-9.f +++ b/gcc/testsuite/gfortran.dg/g77/980628-9.f @@ -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. diff --git a/gcc/testsuite/gfortran.dg/private_type_1.f90 b/gcc/testsuite/gfortran.dg/private_type_1.f90 new file mode 100644 index 0000000..e36e20a --- /dev/null +++ b/gcc/testsuite/gfortran.dg/private_type_1.f90 @@ -0,0 +1,19 @@ +! { 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 + diff --git a/gcc/testsuite/gfortran.dg/private_type_2.f90 b/gcc/testsuite/gfortran.dg/private_type_2.f90 new file mode 100644 index 0000000..6078293 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/private_type_2.f90 @@ -0,0 +1,15 @@ +! { 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 + |