From: burnus Date: Sun, 10 Dec 2006 19:53:07 +0000 (+0000) Subject: fortran/ X-Git-Url: http://git.sourceforge.jp/view?p=pf3gnuchains%2Fgcc-fork.git;a=commitdiff_plain;h=3ea52af31c6ee2b96ce6be5ac7c4aa336a05f01e fortran/ 2006-12-10 Tobias Burnus PR fortran/23994 * interface.c (compare_actual_formal): PROTECTED is incompatible with intent(out). * symbol.c (check_conflict): Check for PROTECTED conflicts. (gfc_add_protected): New function. (gfc_copy_attr): Copy PROTECTED attribute. * decl.c (match_attr_spec): Add PROTECTED support. (gfc_match_protected): New function. * dump-parse-tree.c (gfc_show_attr): Add PROTECTED support. * gfortran.h (gfc_symbol): Add protected flag. Add gfc_add_protected prototype. * expr.c (gfc_check_pointer_assign): Add PROTECTED support. * module.c (ab_attribute, attr_bits, mio_symbol_attribute, mio_symbol_attribute): Add PROTECTED support. * resolve.c (resolve_equivalence): Add PROTECTED support. * match.c (gfc_match_assignment,)gfc_match_pointer_assignment: Check PROTECTED attribute. * match.h: Add gfc_match_protected prototype. * parse.c (decode_statement): Match PROTECTED statement. * primary.c (match_variable): Add PROTECTED support. testsuite/ 2006-12-10 Tobias Burnus PR fortran/23994 * gfortran.dg/protected_1.f90: New test. * gfortran.dg/protected_2.f90: New test. * gfortran.dg/protected_3.f90: New test. * gfortran.dg/protected_4.f90: New test. * gfortran.dg/protected_5.f90: New test. * gfortran.dg/protected_6.f90: New test. git-svn-id: svn+ssh://gcc.gnu.org/svn/gcc/trunk@119709 138bc75d-0d04-0410-961f-82ee72b054a4 --- diff --git a/gcc/fortran/ChangeLog b/gcc/fortran/ChangeLog index c2a3464d54c..d211080eae5 100644 --- a/gcc/fortran/ChangeLog +++ b/gcc/fortran/ChangeLog @@ -1,3 +1,26 @@ +2006-12-10 Tobias Burnus + + PR fortran/23994 + * interface.c (compare_actual_formal): PROTECTED is incompatible + with intent(out). + * symbol.c (check_conflict): Check for PROTECTED conflicts. + (gfc_add_protected): New function. + (gfc_copy_attr): Copy PROTECTED attribute. + * decl.c (match_attr_spec): Add PROTECTED support. + (gfc_match_protected): New function. + * dump-parse-tree.c (gfc_show_attr): Add PROTECTED support. + * gfortran.h (gfc_symbol): Add protected flag. + Add gfc_add_protected prototype. + * expr.c (gfc_check_pointer_assign): Add PROTECTED support. + * module.c (ab_attribute, attr_bits, mio_symbol_attribute, + mio_symbol_attribute): Add PROTECTED support. + * resolve.c (resolve_equivalence): Add PROTECTED support. + * match.c (gfc_match_assignment,gfc_match_pointer_assignment): + Check PROTECTED attribute. + * match.h: Add gfc_match_protected prototype. + * parse.c (decode_statement): Match PROTECTED statement. + * primary.c (match_variable): Add PROTECTED support. + 2006-12-09 Paul Thomas PR fortran/29975 diff --git a/gcc/fortran/decl.c b/gcc/fortran/decl.c index 46c49ba9e8c..eb3323733ee 100644 --- a/gcc/fortran/decl.c +++ b/gcc/fortran/decl.c @@ -2116,8 +2116,9 @@ match_attr_spec (void) { GFC_DECL_BEGIN = 0, DECL_ALLOCATABLE = GFC_DECL_BEGIN, DECL_DIMENSION, DECL_EXTERNAL, DECL_IN, DECL_OUT, DECL_INOUT, DECL_INTRINSIC, DECL_OPTIONAL, - DECL_PARAMETER, DECL_POINTER, DECL_PRIVATE, DECL_PUBLIC, DECL_SAVE, - DECL_TARGET, DECL_VALUE, DECL_VOLATILE, DECL_COLON, DECL_NONE, + DECL_PARAMETER, DECL_POINTER, DECL_PROTECTED, DECL_PRIVATE, + DECL_PUBLIC, DECL_SAVE, DECL_TARGET, DECL_VALUE, DECL_VOLATILE, + DECL_COLON, DECL_NONE, GFC_DECL_END /* Sentinel */ } decl_types; @@ -2136,6 +2137,7 @@ match_attr_spec (void) minit (", optional", DECL_OPTIONAL), minit (", parameter", DECL_PARAMETER), minit (", pointer", DECL_POINTER), + minit (", protected", DECL_PROTECTED), minit (", private", DECL_PRIVATE), minit (", public", DECL_PUBLIC), minit (", save", DECL_SAVE), @@ -2250,6 +2252,9 @@ match_attr_spec (void) case DECL_POINTER: attr = "POINTER"; break; + case DECL_PROTECTED: + attr = "PROTECTED"; + break; case DECL_PRIVATE: attr = "PRIVATE"; break; @@ -2364,6 +2369,23 @@ match_attr_spec (void) t = gfc_add_pointer (¤t_attr, &seen_at[d]); break; + case DECL_PROTECTED: + if (gfc_current_ns->proc_name->attr.flavor != FL_MODULE) + { + gfc_error ("PROTECTED at %C only allowed in specification " + "part of a module"); + t = FAILURE; + break; + } + + if (gfc_notify_std (GFC_STD_F2003, + "Fortran 2003: PROTECTED attribute at %C") + == FAILURE) + t = FAILURE; + else + t = gfc_add_protected (¤t_attr, NULL, &seen_at[d]); + break; + case DECL_PRIVATE: t = gfc_add_access (¤t_attr, ACCESS_PRIVATE, NULL, &seen_at[d]); @@ -3840,6 +3862,67 @@ done: } +match +gfc_match_protected (void) +{ + gfc_symbol *sym; + match m; + + if (gfc_current_ns->proc_name->attr.flavor != FL_MODULE) + { + gfc_error ("PROTECTED at %C only allowed in specification " + "part of a module"); + return MATCH_ERROR; + + } + + if (gfc_notify_std (GFC_STD_F2003, + "Fortran 2003: PROTECTED statement at %C") + == FAILURE) + return MATCH_ERROR; + + if (gfc_match (" ::") == MATCH_NO && gfc_match_space () == MATCH_NO) + { + return MATCH_ERROR; + } + + if (gfc_match_eos () == MATCH_YES) + goto syntax; + + for(;;) + { + m = gfc_match_symbol (&sym, 0); + switch (m) + { + case MATCH_YES: + if (gfc_add_protected (&sym->attr, sym->name, + &gfc_current_locus) == FAILURE) + return MATCH_ERROR; + goto next_item; + + case MATCH_NO: + break; + + case MATCH_ERROR: + return MATCH_ERROR; + } + + next_item: + if (gfc_match_eos () == MATCH_YES) + break; + if (gfc_match_char (',') != MATCH_YES) + goto syntax; + } + + return MATCH_YES; + +syntax: + gfc_error ("Syntax error in PROTECTED statement at %C"); + return MATCH_ERROR; +} + + + /* The PRIVATE statement is a bit weird in that it can be a attribute declaration, but also works as a standlone statement inside of a type declaration or a module. */ diff --git a/gcc/fortran/dump-parse-tree.c b/gcc/fortran/dump-parse-tree.c index f53ee2e8598..17a7bf06052 100644 --- a/gcc/fortran/dump-parse-tree.c +++ b/gcc/fortran/dump-parse-tree.c @@ -550,6 +550,8 @@ gfc_show_attr (symbol_attribute * attr) gfc_status (" OPTIONAL"); if (attr->pointer) gfc_status (" POINTER"); + if (attr->protected) + gfc_status (" PROTECTED"); if (attr->save) gfc_status (" SAVE"); if (attr->value) diff --git a/gcc/fortran/expr.c b/gcc/fortran/expr.c index 78cb9f07443..7f6c699de59 100644 --- a/gcc/fortran/expr.c +++ b/gcc/fortran/expr.c @@ -2414,6 +2414,13 @@ gfc_check_pointer_assign (gfc_expr * lvalue, gfc_expr * rvalue) return FAILURE; } + if (attr.protected && attr.use_assoc) + { + gfc_error ("Pointer assigment target has PROTECTED " + "attribute at %L", &rvalue->where); + return FAILURE; + } + return SUCCESS; } diff --git a/gcc/fortran/gfortran.h b/gcc/fortran/gfortran.h index 8665ec9bb6a..0c67d10cf7e 100644 --- a/gcc/fortran/gfortran.h +++ b/gcc/fortran/gfortran.h @@ -483,6 +483,7 @@ typedef struct dummy:1, result:1, assign:1, threadprivate:1; unsigned data:1, /* Symbol is named in a DATA statement. */ + protected:1, /* Symbol has been marked as protected. */ use_assoc:1, /* Symbol has been use-associated. */ use_only:1; /* Symbol has been use-associated, with ONLY. */ @@ -1857,6 +1858,7 @@ try gfc_add_pointer (symbol_attribute *, locus *); try gfc_add_cray_pointer (symbol_attribute *, locus *); try gfc_add_cray_pointee (symbol_attribute *, locus *); try gfc_mod_pointee_as (gfc_array_spec *as); +try gfc_add_protected (symbol_attribute *, const char *, locus *); try gfc_add_result (symbol_attribute *, const char *, locus *); try gfc_add_save (symbol_attribute *, const char *, locus *); try gfc_add_threadprivate (symbol_attribute *, const char *, locus *); diff --git a/gcc/fortran/interface.c b/gcc/fortran/interface.c index bcf95f51ee0..28747e05be5 100644 --- a/gcc/fortran/interface.c +++ b/gcc/fortran/interface.c @@ -1206,6 +1206,36 @@ compare_parameter (gfc_symbol * formal, gfc_expr * actual, } +/* Given a symbol of a formal argument list and an expression, see if + the two are compatible as arguments. Returns nonzero if + compatible, zero if not compatible. */ + +static int +compare_parameter_protected (gfc_symbol * formal, gfc_expr * actual) +{ + if (actual->expr_type != EXPR_VARIABLE) + return 1; + + if (!actual->symtree->n.sym->attr.protected) + return 1; + + if (!actual->symtree->n.sym->attr.use_assoc) + return 1; + + if (formal->attr.intent == INTENT_IN + || formal->attr.intent == INTENT_UNKNOWN) + return 1; + + if (!actual->symtree->n.sym->attr.pointer) + return 0; + + if (actual->symtree->n.sym->attr.pointer && formal->attr.pointer) + return 0; + + return 1; +} + + /* Given formal and actual argument lists, see if they are compatible. If they are compatible, the actual argument list is sorted to correspond with the formal list, and elements for missing optional @@ -1393,6 +1423,16 @@ compare_actual_formal (gfc_actual_arglist ** ap, return 0; } + if (!compare_parameter_protected(f->sym, a->expr)) + { + if (where) + gfc_error ("Actual argument at %L is use-associated with " + "PROTECTED attribute and dummy argument '%s' is " + "INTENT = OUT/INOUT", + &a->expr->where,f->sym->name); + return 0; + } + match: if (a == actual) na = i; diff --git a/gcc/fortran/match.c b/gcc/fortran/match.c index 413487d6f4b..0dc2c7295b1 100644 --- a/gcc/fortran/match.c +++ b/gcc/fortran/match.c @@ -852,6 +852,15 @@ gfc_match_assignment (void) return MATCH_NO; } + if (lvalue->symtree->n.sym->attr.protected + && lvalue->symtree->n.sym->attr.use_assoc) + { + gfc_current_locus = old_loc; + gfc_free_expr (lvalue); + gfc_error ("Setting value of PROTECTED variable at %C"); + return MATCH_ERROR; + } + rvalue = NULL; m = gfc_match (" %e%t", &rvalue); if (m != MATCH_YES) @@ -898,6 +907,15 @@ gfc_match_pointer_assignment (void) if (m != MATCH_YES) goto cleanup; + if (lvalue->symtree->n.sym->attr.protected + && lvalue->symtree->n.sym->attr.use_assoc) + { + gfc_error ("Assigning to a PROTECTED pointer at %C"); + m = MATCH_ERROR; + goto cleanup; + } + + new_st.op = EXEC_POINTER_ASSIGN; new_st.expr = lvalue; new_st.expr2 = rvalue; diff --git a/gcc/fortran/match.h b/gcc/fortran/match.h index cc0207b9916..2209c0ded6d 100644 --- a/gcc/fortran/match.h +++ b/gcc/fortran/match.h @@ -142,6 +142,7 @@ match gfc_match_intrinsic (void); match gfc_match_optional (void); match gfc_match_parameter (void); match gfc_match_pointer (void); +match gfc_match_protected (void); match gfc_match_private (gfc_statement *); match gfc_match_public (gfc_statement *); match gfc_match_save (void); diff --git a/gcc/fortran/module.c b/gcc/fortran/module.c index ca4e0913b18..f54ef8e67cd 100644 --- a/gcc/fortran/module.c +++ b/gcc/fortran/module.c @@ -1491,7 +1491,7 @@ typedef enum AB_IN_NAMELIST, AB_IN_COMMON, AB_FUNCTION, AB_SUBROUTINE, AB_SEQUENCE, AB_ELEMENTAL, AB_PURE, AB_RECURSIVE, AB_GENERIC, AB_ALWAYS_EXPLICIT, AB_CRAY_POINTER, AB_CRAY_POINTEE, AB_THREADPRIVATE, AB_ALLOC_COMP, - AB_VALUE, AB_VOLATILE + AB_VALUE, AB_VOLATILE, AB_PROTECTED } ab_attribute; @@ -1524,6 +1524,7 @@ static const mstring attr_bits[] = minit ("CRAY_POINTER", AB_CRAY_POINTER), minit ("CRAY_POINTEE", AB_CRAY_POINTEE), minit ("ALLOC_COMP", AB_ALLOC_COMP), + minit ("PROTECTED", AB_PROTECTED), minit (NULL, -1) }; @@ -1574,6 +1575,8 @@ mio_symbol_attribute (symbol_attribute * attr) MIO_NAME(ab_attribute) (AB_OPTIONAL, attr_bits); if (attr->pointer) MIO_NAME(ab_attribute) (AB_POINTER, attr_bits); + if (attr->protected) + MIO_NAME(ab_attribute) (AB_PROTECTED, attr_bits); if (attr->save) MIO_NAME(ab_attribute) (AB_SAVE, attr_bits); if (attr->value) @@ -1655,6 +1658,9 @@ mio_symbol_attribute (symbol_attribute * attr) case AB_POINTER: attr->pointer = 1; break; + case AB_PROTECTED: + attr->protected = 1; + break; case AB_SAVE: attr->save = 1; break; diff --git a/gcc/fortran/parse.c b/gcc/fortran/parse.c index d23737356ab..cbbf7341d59 100644 --- a/gcc/fortran/parse.c +++ b/gcc/fortran/parse.c @@ -260,6 +260,7 @@ decode_statement (void) match ("program", gfc_match_program, ST_PROGRAM); if (gfc_match_public (&st) == MATCH_YES) return st; + match ("protected", gfc_match_protected, ST_ATTR_DECL); break; case 'r': diff --git a/gcc/fortran/primary.c b/gcc/fortran/primary.c index 2c340724fcb..66ac2f15963 100644 --- a/gcc/fortran/primary.c +++ b/gcc/fortran/primary.c @@ -2303,6 +2303,11 @@ match_variable (gfc_expr ** result, int equiv_flag, int host_flag) switch (sym->attr.flavor) { case FL_VARIABLE: + if (sym->attr.protected && sym->attr.use_assoc) + { + gfc_error ("Assigning to PROTECTED variable at %C"); + return MATCH_ERROR; + } break; case FL_UNKNOWN: diff --git a/gcc/fortran/resolve.c b/gcc/fortran/resolve.c index 0690dca46e5..33ef7481470 100644 --- a/gcc/fortran/resolve.c +++ b/gcc/fortran/resolve.c @@ -6632,6 +6632,7 @@ resolve_equivalence_derived (gfc_symbol *derived, gfc_symbol *sym, gfc_expr *e) 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. + Either all or none of the objects shall have an protected attribute. The simple constraints are done in symbol.c(check_conflict) and the rest are implemented here. */ @@ -6646,7 +6647,7 @@ resolve_equivalence (gfc_equiv *eq) locus *last_where = NULL; seq_type eq_type, last_eq_type; gfc_typespec *last_ts; - int object; + int object, cnt_protected; const char *value_name; const char *msg; @@ -6655,6 +6656,8 @@ resolve_equivalence (gfc_equiv *eq) first_sym = eq->expr->symtree->n.sym; + cnt_protected = 0; + for (object = 1; eq; eq = eq->eq, object++) { e = eq->expr; @@ -6726,6 +6729,17 @@ resolve_equivalence (gfc_equiv *eq) sym = e->symtree->n.sym; + if (sym->attr.protected) + cnt_protected++; + if (cnt_protected > 0 && cnt_protected != object) + { + gfc_error ("Either all or none of the objects in the " + "EQUIVALENCE set at %L shall have the " + "PROTECTED attribute", + &e->where); + break; + } + /* An equivalence statement cannot have more than one initialized object. */ if (sym->value) diff --git a/gcc/fortran/symbol.c b/gcc/fortran/symbol.c index a8090824718..12c5749acec 100644 --- a/gcc/fortran/symbol.c +++ b/gcc/fortran/symbol.c @@ -275,7 +275,7 @@ check_conflict (symbol_attribute * attr, const char * name, locus * where) *dimension = "DIMENSION", *in_equivalence = "EQUIVALENCE", *use_assoc = "USE ASSOCIATED", *cray_pointer = "CRAY POINTER", *cray_pointee = "CRAY POINTEE", *data = "DATA", *value = "VALUE", - *volatile_ = "VOLATILE"; + *volatile_ = "VOLATILE", *protected = "PROTECTED"; static const char *threadprivate = "THREADPRIVATE"; const char *a1, *a2; @@ -404,6 +404,10 @@ check_conflict (symbol_attribute * attr, const char * name, locus * where) conf (data, allocatable); conf (data, use_assoc); + conf (protected, intrinsic) + conf (protected, external) + conf (protected, in_common) + conf (value, pointer) conf (value, allocatable) conf (value, subroutine) @@ -451,6 +455,7 @@ check_conflict (symbol_attribute * attr, const char * name, locus * where) conf2 (save); conf2 (volatile_); conf2 (pointer); + conf2 (protected); conf2 (target); conf2 (external); conf2 (intrinsic); @@ -537,6 +542,7 @@ check_conflict (symbol_attribute * attr, const char * name, locus * where) conf2 (subroutine); conf2 (entry); conf2 (pointer); + conf2 (protected); conf2 (target); conf2 (dummy); conf2 (in_common); @@ -781,6 +787,24 @@ gfc_add_cray_pointee (symbol_attribute * attr, locus * where) return check_conflict (attr, NULL, where); } +try +gfc_add_protected (symbol_attribute * attr, const char *name, locus * where) +{ + if (check_used (attr, name, where)) + return FAILURE; + + if (attr->protected) + { + if (gfc_notify_std (GFC_STD_LEGACY, + "Duplicate PROTECTED attribute specified at %L", + where) + == FAILURE) + return FAILURE; + } + + attr->protected = 1; + return check_conflict (attr, name, where); +} try gfc_add_result (symbol_attribute * attr, const char *name, locus * where) @@ -1293,6 +1317,8 @@ gfc_copy_attr (symbol_attribute * dest, symbol_attribute * src, locus * where) goto fail; if (src->pointer && gfc_add_pointer (dest, where) == FAILURE) goto fail; + if (src->protected && gfc_add_protected (dest, NULL, where) == FAILURE) + goto fail; if (src->save && gfc_add_save (dest, NULL, where) == FAILURE) goto fail; if (src->value && gfc_add_value (dest, NULL, where) == FAILURE) diff --git a/gcc/testsuite/ChangeLog b/gcc/testsuite/ChangeLog index 2402aa803c0..cfdc64b5132 100644 --- a/gcc/testsuite/ChangeLog +++ b/gcc/testsuite/ChangeLog @@ -1,3 +1,13 @@ +2006-12-10 Tobias Burnus + + PR fortran/23994 + * gfortran.dg/protected_1.f90: New test. + * gfortran.dg/protected_2.f90: New test. + * gfortran.dg/protected_3.f90: New test. + * gfortran.dg/protected_4.f90: New test. + * gfortran.dg/protected_5.f90: New test. + * gfortran.dg/protected_6.f90: New test. + 2006-12-09 Paul Thomas Tobias Burnus diff --git a/gcc/testsuite/gfortran.dg/protected_1.f90 b/gcc/testsuite/gfortran.dg/protected_1.f90 new file mode 100644 index 00000000000..c1679f27e9d --- /dev/null +++ b/gcc/testsuite/gfortran.dg/protected_1.f90 @@ -0,0 +1,61 @@ +! { dg-run } +! { dg-options "-std=f2003 -fall-intrinsics" } +! PR fortran/23994 +! +! Test PROTECTED attribute. Within the module everything is allowed. +! Outside (use-associated): For pointers, their association status +! may not be changed. For nonpointers, their value may not be changed. +! +! Test of a valid code + +module protmod + implicit none + integer :: a,b + integer, target :: at,bt + integer, pointer :: ap,bp + protected :: a, at + protected :: ap +contains + subroutine setValue() + a = 43 + ap => null() + nullify(ap) + ap => at + ap = 3 + allocate(ap) + ap = 73 + call increment(a,ap,at) + if(a /= 44 .or. ap /= 74 .or. at /= 4) call abort() + end subroutine setValue + subroutine increment(a1,a2,a3) + integer, intent(inout) :: a1, a2, a3 + a1 = a1 + 1 + a2 = a2 + 1 + a3 = a3 + 1 + end subroutine increment +end module protmod + +program main + use protmod + implicit none + b = 5 + bp => bt + bp = 4 + bt = 7 + call setValue() + if(a /= 44 .or. ap /= 74 .or. at /= 4) call abort() + call plus5(ap) + if(a /= 44 .or. ap /= 79 .or. at /= 4) call abort() + call checkVal(a,ap,at) +contains + subroutine plus5(j) + integer, intent(inout) :: j + j = j + 5 + end subroutine plus5 + subroutine checkVal(x,y,z) + integer, intent(in) :: x, y, z + if(a /= 44 .or. ap /= 79 .or. at /= 4) call abort() + end subroutine +end program main + +! { dg-final { cleanup-modules "protmod" } } diff --git a/gcc/testsuite/gfortran.dg/protected_2.f90 b/gcc/testsuite/gfortran.dg/protected_2.f90 new file mode 100644 index 00000000000..bba011571a9 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/protected_2.f90 @@ -0,0 +1,55 @@ +! { dg-run } +! { dg-options "-std=f2003 -fall-intrinsics" } +! PR fortran/23994 +! +! Test PROTECTED attribute. Within the module everything is allowed. +! Outside (use-associated): For pointers, their association status +! may not be changed. For nonpointers, their value may not be changed. +! +! Test of a valid code + +module protmod + implicit none + integer, protected :: a + integer, protected, target :: at + integer, protected, pointer :: ap +contains + subroutine setValue() + a = 43 + ap => null() + nullify(ap) + ap => at + ap = 3 + allocate(ap) + ap = 73 + call increment(a,ap,at) + if(a /= 44 .or. ap /= 74 .or. at /= 4) call abort() + end subroutine setValue + subroutine increment(a1,a2,a3) + integer, intent(inout) :: a1, a2, a3 + a1 = a1 + 1 + a2 = a2 + 1 + a3 = a3 + 1 + end subroutine increment +end module protmod + +program main + use protmod + implicit none + call setValue() + if(a /= 44 .or. ap /= 74 .or. at /= 4) call abort() + call plus5(ap) + if(a /= 44 .or. ap /= 79 .or. at /= 4) call abort() + call checkVal(a,ap,at) +contains + subroutine plus5(j) + integer, intent(inout) :: j + j = j + 5 + end subroutine plus5 + subroutine checkVal(x,y,z) + integer, intent(in) :: x, y, z + if(a /= 44 .or. ap /= 79 .or. at /= 4) call abort() + end subroutine +end program main + +! { dg-final { cleanup-modules "protmod" } } diff --git a/gcc/testsuite/gfortran.dg/protected_3.f90 b/gcc/testsuite/gfortran.dg/protected_3.f90 new file mode 100644 index 00000000000..a709b50d6f9 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/protected_3.f90 @@ -0,0 +1,25 @@ +! { dg-run } +! { dg-shouldfail "Fortran 2003 code with -std=f95" } +! { dg-options "-std=f95 -fall-intrinsics" } +! PR fortran/23994 +! +! Test PROTECTED attribute. Within the module everything is allowed. +! Outside (use-associated): For pointers, their association status +! may not be changed. For nonpointers, their value may not be changed. +! +! Reject in Fortran 95 + +module protmod + implicit none + integer :: a + integer, target :: at + integer, pointer :: ap + protected :: a, at, ap ! { dg-error "Fortran 2003: PROTECTED statement" } +end module protmod + +module protmod2 + implicit none + integer, protected :: a ! { dg-error "Fortran 2003: PROTECTED attribute" } + integer, protected, target :: at ! { dg-error "Fortran 2003: PROTECTED attribute" } + integer, protected, pointer :: ap ! { dg-error "Fortran 2003: PROTECTED attribute" } +end module protmod2 diff --git a/gcc/testsuite/gfortran.dg/protected_4.f90 b/gcc/testsuite/gfortran.dg/protected_4.f90 new file mode 100644 index 00000000000..be35b6bf60b --- /dev/null +++ b/gcc/testsuite/gfortran.dg/protected_4.f90 @@ -0,0 +1,50 @@ +! { dg-compile } +! { dg-shouldfail "Invalid Fortran 2003 code" } +! { dg-options "-std=f2003 -fall-intrinsics" } +! PR fortran/23994 +! +! Test PROTECTED attribute. Within the module everything is allowed. +! Outside (use-associated): For pointers, their association status +! may not be changed. For nonpointers, their value may not be changed. +! +! Test of a invalid code + +module protmod + implicit none + integer :: a + integer, target :: at + integer, pointer :: ap + protected :: a, at, ap +end module protmod + +program main + use protmod + implicit none + integer :: j + protected :: j ! { dg-error "only allowed in specification part of a module" } + a = 43 ! { dg-error "Assigning to PROTECTED variable" } + ap => null() ! { dg-error "Assigning to PROTECTED variable" } + nullify(ap) ! { dg-error "Assigning to PROTECTED variable" } + ap => at ! { dg-error "Assigning to PROTECTED variable" } + ap = 3 ! { dg-error "Assigning to PROTECTED variable" } + allocate(ap) ! { dg-error "Assigning to PROTECTED variable" } + ap = 73 ! { dg-error "Assigning to PROTECTED variable" } + call increment(a,at) ! { dg-error "use-associated with PROTECTED attribute" } +contains + subroutine increment(a1,a3) + integer, intent(inout) :: a1, a3 + a1 = a1 + 1 + a3 = a3 + 1 + end subroutine increment + subroutine pointer_assignments(p) + integer, pointer :: p ! with [pointer] intent(out) + p => null() ! this is invalid + end subroutine pointer_assignments +end program main + +module test + real :: a + protected :: test ! { dg-error "MODULE attribute conflicts with PROTECTED" } +end module test + +! { dg-final { cleanup-modules "protmod" } } diff --git a/gcc/testsuite/gfortran.dg/protected_5.f90 b/gcc/testsuite/gfortran.dg/protected_5.f90 new file mode 100644 index 00000000000..24676340eca --- /dev/null +++ b/gcc/testsuite/gfortran.dg/protected_5.f90 @@ -0,0 +1,57 @@ +! { dg-compile } +! { dg-shouldfail "Invalid Fortran 2003 code" } +! { dg-options "-std=f2003 -fall-intrinsics" } +! PR fortran/23994 +! +! Test PROTECTED attribute. Within the module everything is allowed. +! Outside (use-associated): For pointers, their association status +! may not be changed. For nonpointers, their value may not be changed. +! +! Test of a invalid code + +module good1 + implicit none + integer :: a + integer :: b,c + protected :: c + equivalence (a,c) ! { dg-error "Either all or none of the objects in the EQUIVALENCE" } +end module good1 + + +module bad1 + implicit none + integer, protected :: a + integer :: b,c + protected :: c + equivalence (a,b) ! { dg-error "Either all or none of the objects in the EQUIVALENCE" } +end module bad1 + +module bad2 + implicit none + integer, protected :: a + integer :: b,c,d + protected :: c + common /one/ a,b ! { dg-error "PROTECTED attribute conflicts with COMMON" } + common /two/ c,d ! { dg-error "PROTECTED attribute conflicts with COMMON" } +end module bad2 + +module good2 + implicit none + type myT + integer :: j + integer, pointer :: p + real, allocatable, dimension(:) :: array + end type myT + type(myT), save :: t + protected :: t +end module good2 + +program main + use good2 + implicit none + t%j = 15 ! { dg-error "Assigning to PROTECTED variable" } + nullify(t%p) ! { dg-error "Assigning to PROTECTED variable" } + allocate(t%array(15))! { dg-error "Assigning to PROTECTED variable" } +end program main + +! { dg-final { cleanup-modules "good1 good2 bad1 bad2" } } diff --git a/gcc/testsuite/gfortran.dg/protected_6.f90 b/gcc/testsuite/gfortran.dg/protected_6.f90 new file mode 100644 index 00000000000..50729495c8f --- /dev/null +++ b/gcc/testsuite/gfortran.dg/protected_6.f90 @@ -0,0 +1,50 @@ +! { dg-compile } +! { dg-shouldfail "Invalid Fortran 2003 code" } +! { dg-options "-std=f2003 -fall-intrinsics" } +! PR fortran/23994 +! +! Test PROTECTED attribute. Within the module everything is allowed. +! Outside (use-associated): For pointers, their association status +! may not be changed. For nonpointers, their value may not be changed. +! +! Test of a invalid code + +module protmod + implicit none + integer, Protected :: a + integer, protected, target :: at + integer, protected, pointer :: ap +end module protmod + +program main + use protmod + implicit none + a = 43 ! { dg-error "Assigning to PROTECTED variable" } + ap => null() ! { dg-error "Assigning to PROTECTED variable" } + nullify(ap) ! { dg-error "Assigning to PROTECTED variable" } + ap => at ! { dg-error "Assigning to PROTECTED variable" } + ap = 3 ! { dg-error "Assigning to PROTECTED variable" } + allocate(ap) ! { dg-error "Assigning to PROTECTED variable" } + ap = 73 ! { dg-error "Assigning to PROTECTED variable" } + call increment(a,at) ! { dg-error "use-associated with PROTECTED attribute" } +contains + subroutine increment(a1,a3) + integer, intent(inout) :: a1, a3 + a1 = a1 + 1 + a3 = a3 + 1 + end subroutine increment + subroutine pointer_assignments(p) + integer, pointer :: p ! with [pointer] intent(out) + p => null() ! this is invalid + end subroutine pointer_assignments +end program main + +module prot2 + implicit none +contains + subroutine bar + real, protected :: b ! { dg-error "only allowed in specification part of a module" } + end subroutine bar +end module prot2 + +! { dg-final { cleanup-modules "protmod" } }