aboutsummaryrefslogtreecommitdiff
diff options
context:
space:
mode:
Diffstat
-rw-r--r--gcc/fortran/ChangeLog23
-rw-r--r--gcc/fortran/decl.c87
-rw-r--r--gcc/fortran/dump-parse-tree.c2
-rw-r--r--gcc/fortran/expr.c7
-rw-r--r--gcc/fortran/gfortran.h2
-rw-r--r--gcc/fortran/interface.c40
-rw-r--r--gcc/fortran/match.c18
-rw-r--r--gcc/fortran/match.h1
-rw-r--r--gcc/fortran/module.c8
-rw-r--r--gcc/fortran/parse.c1
-rw-r--r--gcc/fortran/primary.c5
-rw-r--r--gcc/fortran/resolve.c16
-rw-r--r--gcc/fortran/symbol.c28
-rw-r--r--gcc/testsuite/ChangeLog10
-rw-r--r--gcc/testsuite/gfortran.dg/protected_1.f9061
-rw-r--r--gcc/testsuite/gfortran.dg/protected_2.f9055
-rw-r--r--gcc/testsuite/gfortran.dg/protected_3.f9025
-rw-r--r--gcc/testsuite/gfortran.dg/protected_4.f9050
-rw-r--r--gcc/testsuite/gfortran.dg/protected_5.f9057
-rw-r--r--gcc/testsuite/gfortran.dg/protected_6.f9050
20 files changed, 541 insertions, 5 deletions
diff --git a/gcc/fortran/ChangeLog b/gcc/fortran/ChangeLog
index c2a3464..d211080 100644
--- a/gcc/fortran/ChangeLog
+++ b/gcc/fortran/ChangeLog
@@ -1,3 +1,26 @@
+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.
+
2006-12-09 Paul Thomas <pault@gcc.gnu.org>
PR fortran/29975
diff --git a/gcc/fortran/decl.c b/gcc/fortran/decl.c
index 46c49ba..eb33237 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 (&current_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 (&current_attr, NULL, &seen_at[d]);
+ break;
+
case DECL_PRIVATE:
t = gfc_add_access (&current_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 f53ee2e..17a7bf0 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 78cb9f0..7f6c699 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 8665ec9..0c67d10 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 bcf95f5..28747e0 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 413487d..0dc2c72 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 cc0207b..2209c0d 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 ca4e091..f54ef8e 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 d237373..cbbf734 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 2c34072..66ac2f1 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 0690dca..33ef748 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 a809082..12c5749 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 2402aa8..cfdc64b 100644
--- a/gcc/testsuite/ChangeLog
+++ b/gcc/testsuite/ChangeLog
@@ -1,3 +1,13 @@
+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.
+
2006-12-09 Paul Thomas <pault@gcc.gnu.org>
Tobias Burnus <burnus@gcc.gnu.org>
diff --git a/gcc/testsuite/gfortran.dg/protected_1.f90 b/gcc/testsuite/gfortran.dg/protected_1.f90
new file mode 100644
index 0000000..c1679f2
--- /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 0000000..bba0115
--- /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 0000000..a709b50
--- /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 0000000..be35b6b
--- /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 0000000..2467634
--- /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 0000000..5072949
--- /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" } }
generated by cgit v1.1 at 2024-11-04 18:57:40 +0000