This is the mail archive of the
fortran@gcc.gnu.org
mailing list for the GNU Fortran project.
[fortran, patch] Add PROTECTED support (PR23994)
- From: Tobias Burnus <burnus at net-b dot de>
- To: "'fortran at gcc dot gnu dot org'" <fortran at gcc dot gnu dot org>, gcc-patches <gcc-patches at gcc dot gnu dot org>
- Date: Sun, 10 Dec 2006 12:50:04 +0100
- Subject: [fortran, patch] Add PROTECTED support (PR23994)
:ADDPATCH fortran:
This adds support of the PROTECTED attribute/statement to gfortran. I
think I cover all valid cases correctly and reject all invalid. The
excerpt of the standard can be found at the bottom of yesterday's email:
http://gcc.gnu.org/ml/fortran/2006-12/msg00147.html
Standard in one sentence: Don't allow modifying the value for protected
nonpointers and the association status for protected pointers, if they
are use associated. Only allowed PROTECTED attribute/specified in the
specification part of modules.
Changes compared to yesterday:
- Added another test case for invalid use (common, external,
equivalence, derived components: protected_5.f90)
and
Paul wrote:
> You need to add a line to copy the protected attribute in
symbol.c(copy_attr);
I knew it had to be something simple & stupid. I added this now. Thanks,
Paul.
Ok for the trunk? (Bootstapped and regression tested on
x86_64-unknown-linux-gnu).
Tobias
fortran/
2006-12-10 Tobias Burnus <burnus@net-b.de>
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 <burnus@net-b.de>
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.
Index: gcc/fortran/interface.c
===================================================================
*** gcc/fortran/interface.c (revision 119706)
--- gcc/fortran/interface.c (working copy)
*************** compare_actual_formal (gfc_actual_arglis
*** 1393,1398 ****
--- 1393,1419 ----
return 0;
}
+ /* Check whether the actual argument has PROTECTED attribute.
+ For nonpointers, their value may not be changed, for pointers
+ their association status may not be changed (contrary to its
+ target). */
+ if (a->expr->expr_type == EXPR_VARIABLE
+ && a->expr->symtree->n.sym->attr.protected
+ && a->expr->symtree->n.sym->attr.use_assoc
+ && (f->sym->attr.intent == INTENT_OUT
+ || f->sym->attr.intent == INTENT_INOUT)
+ && (!a->expr->symtree->n.sym->attr.pointer
+ || (a->expr->symtree->n.sym->attr.pointer
+ && f->sym->attr.pointer)))
+ {
+ 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;
Index: gcc/fortran/symbol.c
===================================================================
*** gcc/fortran/symbol.c (revision 119706)
--- gcc/fortran/symbol.c (working copy)
*************** check_conflict (symbol_attribute * attr,
*** 275,281 ****
*dimension = "DIMENSION", *in_equivalence = "EQUIVALENCE",
*use_assoc = "USE ASSOCIATED", *cray_pointer = "CRAY POINTER",
*cray_pointee = "CRAY POINTEE", *data = "DATA", *value = "VALUE",
! *volatile_ = "VOLATILE";
static const char *threadprivate = "THREADPRIVATE";
const char *a1, *a2;
--- 275,281 ----
*dimension = "DIMENSION", *in_equivalence = "EQUIVALENCE",
*use_assoc = "USE ASSOCIATED", *cray_pointer = "CRAY POINTER",
*cray_pointee = "CRAY POINTEE", *data = "DATA", *value = "VALUE",
! *volatile_ = "VOLATILE", *protected = "PROTECTED";
static const char *threadprivate = "THREADPRIVATE";
const char *a1, *a2;
*************** check_conflict (symbol_attribute * attr,
*** 404,409 ****
--- 404,413 ----
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)
*************** check_conflict (symbol_attribute * attr,
*** 451,456 ****
--- 455,461 ----
conf2 (save);
conf2 (volatile_);
conf2 (pointer);
+ conf2 (protected);
conf2 (target);
conf2 (external);
conf2 (intrinsic);
*************** check_conflict (symbol_attribute * attr,
*** 537,542 ****
--- 542,548 ----
conf2 (subroutine);
conf2 (entry);
conf2 (pointer);
+ conf2 (protected);
conf2 (target);
conf2 (dummy);
conf2 (in_common);
*************** gfc_add_cray_pointee (symbol_attribute *
*** 781,786 ****
--- 787,810 ----
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)
*************** gfc_copy_attr (symbol_attribute * dest,
*** 1293,1298 ****
--- 1317,1324 ----
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)
Index: gcc/fortran/decl.c
===================================================================
*** gcc/fortran/decl.c (revision 119706)
--- gcc/fortran/decl.c (working copy)
*************** match_attr_spec (void)
*** 2116,2123 ****
{ 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,
GFC_DECL_END /* Sentinel */
}
decl_types;
--- 2116,2124 ----
{ 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_PROTECTED, DECL_PRIVATE,
! DECL_PUBLIC, DECL_SAVE, DECL_TARGET, DECL_VALUE, DECL_VOLATILE,
! DECL_COLON, DECL_NONE,
GFC_DECL_END /* Sentinel */
}
decl_types;
*************** match_attr_spec (void)
*** 2136,2141 ****
--- 2137,2143 ----
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),
*************** match_attr_spec (void)
*** 2250,2255 ****
--- 2252,2260 ----
case DECL_POINTER:
attr = "POINTER";
break;
+ case DECL_PROTECTED:
+ attr = "PROTECTED";
+ break;
case DECL_PRIVATE:
attr = "PRIVATE";
break;
*************** match_attr_spec (void)
*** 2364,2369 ****
--- 2369,2391 ----
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]);
*************** done:
*** 3840,3845 ****
--- 3862,3928 ----
}
+ 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. */
Index: gcc/fortran/dump-parse-tree.c
===================================================================
*** gcc/fortran/dump-parse-tree.c (revision 119706)
--- gcc/fortran/dump-parse-tree.c (working copy)
*************** gfc_show_attr (symbol_attribute * attr)
*** 550,555 ****
--- 550,557 ----
gfc_status (" OPTIONAL");
if (attr->pointer)
gfc_status (" POINTER");
+ if (attr->protected)
+ gfc_status (" PROTECTED");
if (attr->save)
gfc_status (" SAVE");
if (attr->value)
Index: gcc/fortran/gfortran.h
===================================================================
*** gcc/fortran/gfortran.h (revision 119706)
--- gcc/fortran/gfortran.h (working copy)
*************** typedef struct
*** 483,488 ****
--- 483,489 ----
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. */
*************** try gfc_add_pointer (symbol_attribute *,
*** 1857,1862 ****
--- 1858,1864 ----
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 *);
Index: gcc/fortran/expr.c
===================================================================
*** gcc/fortran/expr.c (revision 119706)
--- gcc/fortran/expr.c (working copy)
*************** gfc_check_pointer_assign (gfc_expr * lva
*** 2414,2419 ****
--- 2414,2426 ----
return FAILURE;
}
+ if (attr.protected && attr.use_assoc)
+ {
+ gfc_error ("Pointer assigment target has PROTECTED "
+ "attribute at %L", &rvalue->where);
+ return FAILURE;
+ }
+
return SUCCESS;
}
Index: gcc/fortran/module.c
===================================================================
*** gcc/fortran/module.c (revision 119706)
--- gcc/fortran/module.c (working copy)
*************** typedef enum
*** 1491,1497 ****
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_attribute;
--- 1491,1497 ----
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_PROTECTED
}
ab_attribute;
*************** static const mstring attr_bits[] =
*** 1524,1529 ****
--- 1524,1530 ----
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)
};
*************** mio_symbol_attribute (symbol_attribute *
*** 1574,1579 ****
--- 1575,1582 ----
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)
*************** mio_symbol_attribute (symbol_attribute *
*** 1655,1660 ****
--- 1658,1666 ----
case AB_POINTER:
attr->pointer = 1;
break;
+ case AB_PROTECTED:
+ attr->protected = 1;
+ break;
case AB_SAVE:
attr->save = 1;
break;
Index: gcc/fortran/resolve.c
===================================================================
*** gcc/fortran/resolve.c (revision 119706)
--- gcc/fortran/resolve.c (working copy)
*************** resolve_equivalence_derived (gfc_symbol
*** 6632,6637 ****
--- 6632,6638 ----
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. */
*************** resolve_equivalence (gfc_equiv *eq)
*** 6646,6652 ****
locus *last_where = NULL;
seq_type eq_type, last_eq_type;
gfc_typespec *last_ts;
! int object;
const char *value_name;
const char *msg;
--- 6647,6653 ----
locus *last_where = NULL;
seq_type eq_type, last_eq_type;
gfc_typespec *last_ts;
! int object, cnt_protected;
const char *value_name;
const char *msg;
*************** resolve_equivalence (gfc_equiv *eq)
*** 6655,6660 ****
--- 6656,6663 ----
first_sym = eq->expr->symtree->n.sym;
+ cnt_protected = 0;
+
for (object = 1; eq; eq = eq->eq, object++)
{
e = eq->expr;
*************** resolve_equivalence (gfc_equiv *eq)
*** 6726,6731 ****
--- 6729,6745 ----
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)
Index: gcc/fortran/match.c
===================================================================
*** gcc/fortran/match.c (revision 119706)
--- gcc/fortran/match.c (working copy)
*************** gfc_match_assignment (void)
*** 852,857 ****
--- 852,866 ----
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)
*************** gfc_match_pointer_assignment (void)
*** 898,903 ****
--- 907,921 ----
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;
Index: gcc/fortran/match.h
===================================================================
*** gcc/fortran/match.h (revision 119706)
--- gcc/fortran/match.h (working copy)
*************** match gfc_match_intrinsic (void);
*** 142,147 ****
--- 142,148 ----
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);
Index: gcc/fortran/parse.c
===================================================================
*** gcc/fortran/parse.c (revision 119706)
--- gcc/fortran/parse.c (working copy)
*************** decode_statement (void)
*** 260,265 ****
--- 260,266 ----
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':
Index: gcc/fortran/primary.c
===================================================================
*** gcc/fortran/primary.c (revision 119706)
--- gcc/fortran/primary.c (working copy)
*************** match_variable (gfc_expr ** result, int
*** 2303,2308 ****
--- 2303,2313 ----
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:
Index: gcc/testsuite/gfortran.dg/protected_1.f90
===================================================================
*** gcc/testsuite/gfortran.dg/protected_1.f90 (revision 0)
--- gcc/testsuite/gfortran.dg/protected_1.f90 (revision 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" } }
Index: gcc/testsuite/gfortran.dg/protected_2.f90
===================================================================
*** gcc/testsuite/gfortran.dg/protected_2.f90 (revision 0)
--- gcc/testsuite/gfortran.dg/protected_2.f90 (revision 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" } }
Index: gcc/testsuite/gfortran.dg/protected_3.f90
===================================================================
*** gcc/testsuite/gfortran.dg/protected_3.f90 (revision 0)
--- gcc/testsuite/gfortran.dg/protected_3.f90 (revision 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
Index: gcc/testsuite/gfortran.dg/protected_4.f90
===================================================================
*** gcc/testsuite/gfortran.dg/protected_4.f90 (revision 0)
--- gcc/testsuite/gfortran.dg/protected_4.f90 (revision 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" } }
Index: gcc/testsuite/gfortran.dg/protected_5.f90
===================================================================
*** gcc/testsuite/gfortran.dg/protected_5.f90 (revision 0)
--- gcc/testsuite/gfortran.dg/protected_5.f90 (revision 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" } }
Index: gcc/testsuite/gfortran.dg/protected_6.f90
===================================================================
*** gcc/testsuite/gfortran.dg/protected_6.f90 (revision 0)
--- gcc/testsuite/gfortran.dg/protected_6.f90 (revision 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" } }