This is the mail archive of the fortran@gcc.gnu.org mailing list for the GNU Fortran project.


Index Nav: [Date Index] [Subject Index] [Author Index] [Thread Index]
Message Nav: [Date Prev] [Date Next] [Thread Prev] [Thread Next]
Other format: [Raw text]

PROTECTED attribute - almost working patch


Hello,

attached you can find my current patch. I think it is finished except
for a test of   common/external/intrinsic conflicts with protected. And
a test for equivalence (all or none of the objects need to be
protected). And except of the following:

I have a strange problem:

(a) Using the "protected :: " statement, everything works as expected.
(b) Using the ", protected" attribute everything behaves very oddly:

Looking at -fdump-parse-tree one finds no PROTECTED and using
use-associated protected variables is possible.
(I copied the implementation of VOLATILE, which works in
-fdump-parse-tree; -fdump-parse-tree works also with the protected
statement, which also uses "gfc_add_protected".)

I definitely call "gfc_add_protected" as one can also see by using 
"real, parameter, protected :: a" or "real, protected, parameter :: a",
which both gives the expected error (protected and parameter have a
conflict).

But "real, protected :: a; external a" does not give an error, while
"real :: a; external a; protected :: a" does.

The attribute "protected" seems to be reset right after reading one line
of source - and this resetting does not happen for other attributes nor
when using the protected statement.

Any idea? - I'm completely puzzled and have not the slightest idea why
this happens.

Tobias

Instead of a changelog (for which I wait for the final patch), an
excerpt of the Fortran 2003 standard:

---------------------------

5.1.2.12 PROTECTED attribute

The PROTECTED attribute imposes limitations on the usage of module
entities. Other than within the module in which an entity is given the
PROTECTED attribute, (1) if it is a nonpointer object, it is not
definable, and (2) if it is a pointer, its association status shall not
be changed except that it may become undefined if its target is
deallocated other than through the pointer (16.4.2.1.3) or if its target
becomes undefined by execution of a RETURN or END statement. If an
object has the PROTECTED attribute, all of its subobjects have the
PROTECTED attribute.

5.2.11 PROTECTED statement

R542 protected-stmt is PROTECTED [ :: ] entity-name-list
The PROTECTED statement specifies the PROTECTED attribute (5.1.2.12) for
a list of entities.



C534 (R503) The PROTECTED attribute is permitted only in the
specification part of a module.

C535 (R501) The PROTECTED attribute is permitted only for a procedure
pointer or named variable that is not in a common block.

C536 (R501) If the PROTECTED attribute is specified, the EXTERNAL,
INTRINSIC, or PARAMETER attribute shall not be specified.

C537 A nonpointer object that has the PROTECTED attribute and is
accessed by use association shall not appear in a variable definition
context (16.5.7) or as the data-target or proc-target in a
pointer-assignment-stmt.

C538 A pointer object that has the PROTECTED attribute and is accessed
by use association shall not appear as
 (1) A pointer-object in a nullify-stmt,
 (2) A data-pointer-object or proc-pointer-object in a
pointer-assignment-stmt,
 (3) An allocate-object in an allocate-stmt or deallocate-stmt, or
 (4) An actual argument in a reference to a procedure if the associated
dummy argument is a pointer with the INTENT(OUT) or INTENT(INOUT) attribute.
Index: gcc/fortran/interface.c
===================================================================
--- gcc/fortran/interface.c	(Revision 119697)
+++ gcc/fortran/interface.c	(Arbeitskopie)
@@ -1393,6 +1393,27 @@
           return 0;
         }
 
+      /* Check whether the actual argument has the PROTECTED attribute.
+         For nonpointers, their value may not be changed, for pointers
+         their association status may not be changed (contrary to the
+         value of the 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 119697)
+++ gcc/fortran/symbol.c	(Arbeitskopie)
@@ -275,7 +275,7 @@
     *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 @@
   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 @@
       conf2 (save);
       conf2 (volatile_);
       conf2 (pointer);
+      conf2 (protected);
       conf2 (target);
       conf2 (external);
       conf2 (intrinsic);
@@ -537,6 +542,7 @@
       conf2 (subroutine);
       conf2 (entry);
       conf2 (pointer);
+      conf2 (protected);
       conf2 (target);
       conf2 (dummy);
       conf2 (in_common);
@@ -781,7 +787,25 @@
   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)
 {
Index: gcc/fortran/decl.c
===================================================================
--- gcc/fortran/decl.c	(Revision 119697)
+++ gcc/fortran/decl.c	(Arbeitskopie)
@@ -2116,8 +2116,9 @@
   { 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 @@
     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 @@
 	  case DECL_POINTER:
 	    attr = "POINTER";
 	    break;
+	  case DECL_PROTECTED:
+	    attr = "PROTECTED";
+	    break;
 	  case DECL_PRIVATE:
 	    attr = "PRIVATE";
 	    break;
@@ -2364,6 +2369,23 @@
 	  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 @@
 }
 
 
+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 119697)
+++ gcc/fortran/dump-parse-tree.c	(Arbeitskopie)
@@ -550,6 +550,8 @@
     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 119697)
+++ gcc/fortran/gfortran.h	(Arbeitskopie)
@@ -483,6 +483,7 @@
     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_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 119697)
+++ gcc/fortran/expr.c	(Arbeitskopie)
@@ -2414,6 +2414,13 @@
       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 119697)
+++ gcc/fortran/module.c	(Arbeitskopie)
@@ -1491,7 +1491,7 @@
   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 @@
     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_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 @@
 	    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 119697)
+++ gcc/fortran/resolve.c	(Arbeitskopie)
@@ -6632,6 +6632,7 @@
    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 @@
   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 @@
 
   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 @@
 
       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 119697)
+++ gcc/fortran/match.c	(Arbeitskopie)
@@ -852,6 +852,15 @@
       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 @@
   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 119697)
+++ gcc/fortran/match.h	(Arbeitskopie)
@@ -142,6 +142,7 @@
 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 119697)
+++ gcc/fortran/parse.c	(Arbeitskopie)
@@ -260,6 +260,7 @@
       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 119697)
+++ gcc/fortran/primary.c	(Arbeitskopie)
@@ -2303,6 +2303,11 @@
   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,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,0 +1,59 @@
+! { 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,b
+  integer, protected, target  :: at,bt
+  integer, protected, pointer :: ap,bp
+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_3.f90
===================================================================
--- gcc/testsuite/gfortran.dg/protected_3.f90	(Revision 0)
+++ gcc/testsuite/gfortran.dg/protected_3.f90	(Revision 0)
@@ -0,0 +1,24 @@
+! { dg-run }
+! { 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 statement" }
+  integer, protected, target  :: at ! { dg-error "Fortran 2003: PROTECTED statement" }
+  integer, protected, pointer :: ap ! { dg-error "Fortran 2003: PROTECTED statement" }
+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,0 +1,49 @@
+! { dg-compile }
+! { 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,0 +1,49 @@
+! { dg-compile }
+! { 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 port2 ! { dg-error "Expected label.*Unexpected end" }
+
+! { dg-final { cleanup-modules "protmod" } }

Index Nav: [Date Index] [Subject Index] [Author Index] [Thread Index]
Message Nav: [Date Prev] [Date Next] [Thread Prev] [Thread Next]