FreeChainXenon/gcc
1
0
Fork 0
Code Issues Pull requests Projects Releases Packages Wiki Activity Actions

re PR fortran/23994 (PROTECTED attribute (F2003) is not implemented)

Browse source 
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.

From-SVN: r119709
This commit is contained in:
Tobias Burnus 2006-12-10 20:53:07 +01:00 • committed by Tobias Burnus
parent 42c1cd8a7a
commit ee7e677fdd
20 changed files with 541 additions and 5 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

23
gcc/fortran/ChangeLog
View file

@ -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

87
gcc/fortran/decl.c
View file

@ -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. */

2
gcc/fortran/dump-parse-tree.c
View file

@ -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)

7
gcc/fortran/expr.c
View file

@ -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;
}

2
gcc/fortran/gfortran.h
View file

@ -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 *);

40
gcc/fortran/interface.c
View file

@ -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;

18
gcc/fortran/match.c
View file

@ -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;

1
gcc/fortran/match.h
View file

@ -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);

8
gcc/fortran/module.c
View file

@ -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;

1
gcc/fortran/parse.c
View file

@ -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':

5
gcc/fortran/primary.c
View file

@ -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:

16
gcc/fortran/resolve.c
View file

@ -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)

28
gcc/fortran/symbol.c
View file

@ -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)

10
gcc/testsuite/ChangeLog
View file

@ -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>

61
gcc/testsuite/gfortran.dg/protected_1.f90 Normal file
View file

@ -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" } }

55
gcc/testsuite/gfortran.dg/protected_2.f90 Normal file
View file

@ -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" } }

25
gcc/testsuite/gfortran.dg/protected_3.f90 Normal file
View file

@ -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

50
gcc/testsuite/gfortran.dg/protected_4.f90 Normal file
View file

@ -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" } }

57
gcc/testsuite/gfortran.dg/protected_5.f90 Normal file
View file

@ -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" } }

50
gcc/testsuite/gfortran.dg/protected_6.f90 Normal file
View file

@ -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" } }