+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
{ 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;
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),
case DECL_POINTER:
attr = "POINTER";
break;
+ case DECL_PROTECTED:
+ attr = "PROTECTED";
+ break;
case DECL_PRIVATE:
attr = "PRIVATE";
break;
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]);
}
+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. */
gfc_status (" OPTIONAL");
if (attr->pointer)
gfc_status (" POINTER");
+ if (attr->protected)
+ gfc_status (" PROTECTED");
if (attr->save)
gfc_status (" SAVE");
if (attr->value)
return FAILURE;
}
+ if (attr.protected && attr.use_assoc)
+ {
+ gfc_error ("Pointer assigment target has PROTECTED "
+ "attribute at %L", &rvalue->where);
+ return FAILURE;
+ }
+
return SUCCESS;
}
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_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 *);
}
+/* 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
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;
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)
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;
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);
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;
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_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)
case AB_POINTER:
attr->pointer = 1;
break;
+ case AB_PROTECTED:
+ attr->protected = 1;
+ break;
case AB_SAVE:
attr->save = 1;
break;
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':
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:
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. */
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;
first_sym = eq->expr->symtree->n.sym;
+ cnt_protected = 0;
+
for (object = 1; eq; eq = eq->eq, object++)
{
e = eq->expr;
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)
*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;
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)
conf2 (save);
conf2 (volatile_);
conf2 (pointer);
+ conf2 (protected);
conf2 (target);
conf2 (external);
conf2 (intrinsic);
conf2 (subroutine);
conf2 (entry);
conf2 (pointer);
+ conf2 (protected);
conf2 (target);
conf2 (dummy);
conf2 (in_common);
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)
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)
+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>
--- /dev/null
+! { 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" } }
--- /dev/null
+! { 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" } }
--- /dev/null
+! { 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
--- /dev/null
+! { 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" } }
--- /dev/null
+! { 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" } }
--- /dev/null
+! { 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" } }
git://gcc.gnu.org / gcc.git / commitdiff