This is the mail archive of the gcc-patches@gcc.gnu.org mailing list for the GCC 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]

[fortran, patch] Add PROTECTED support (PR23994)


:ADDPATCH fortran:

This adds support of the PROTECTED attribute/statement to gfortran. I
think I cover all valid cases correctly and reject all invalid. The
excerpt of the standard can be found at the bottom of yesterday's email:
http://gcc.gnu.org/ml/fortran/2006-12/msg00147.html

Standard in one sentence: Don't allow modifying the value for protected
nonpointers and the association status for protected pointers, if they
are use associated. Only allowed PROTECTED attribute/specified in the
specification part of modules.


Changes compared to yesterday:

- Added another test case for invalid use (common, external,
equivalence, derived components: protected_5.f90)

and

Paul wrote:
> You need to add a line to copy the protected attribute in
symbol.c(copy_attr);

I knew it had to be something simple & stupid. I added this now. Thanks,
Paul.

Ok for the trunk? (Bootstapped  and regression tested on
x86_64-unknown-linux-gnu).

Tobias


fortran/
2006-12-10  Tobias Burnus  <burnus@net-b.de>

    PR fortran/23994
    * interface.c (compare_actual_formal): PROTECTED is incompatible
with intent(out).
    * symbol.c (check_conflict): Check for PROTECTED conflicts.
      (gfc_add_protected): New function.
      (gfc_copy_attr): Copy PROTECTED attribute.
    * decl.c (match_attr_spec): Add PROTECTED support.
      (gfc_match_protected): New function.
    * dump-parse-tree.c (gfc_show_attr): Add PROTECTED support.
    * gfortran.h (gfc_symbol): Add protected flag.
      Add gfc_add_protected prototype.
    * expr.c (gfc_check_pointer_assign): Add PROTECTED support.
    * module.c (ab_attribute, attr_bits, mio_symbol_attribute,
mio_symbol_attribute):
       Add PROTECTED support.
    * resolve.c (resolve_equivalence): Add PROTECTED support.
    * match.c (gfc_match_assignment,)gfc_match_pointer_assignment:
       Check PROTECTED attribute.
    * match.h: Add gfc_match_protected prototype.
    * parse.c (decode_statement): Match PROTECTED statement.
    * primary.c (match_variable): Add PROTECTED support.

testsuite/
2006-12-10  Tobias Burnus  <burnus@net-b.de>

    PR fortran/23994
    * gfortran.dg/protected_1.f90: New test.
    * gfortran.dg/protected_2.f90: New test.
    * gfortran.dg/protected_3.f90: New test.
    * gfortran.dg/protected_4.f90: New test.
    * gfortran.dg/protected_5.f90: New test.
    * gfortran.dg/protected_6.f90: New test.
Index: gcc/fortran/interface.c
===================================================================
*** gcc/fortran/interface.c	(revision 119706)
--- gcc/fortran/interface.c	(working copy)
*************** compare_actual_formal (gfc_actual_arglis
*** 1393,1398 ****
--- 1393,1419 ----
            return 0;
          }
  
+       /* Check whether the actual argument has PROTECTED attribute.
+          For nonpointers, their value may not be changed, for pointers
+          their association status may not be changed (contrary to its
+          target).  */
+       if (a->expr->expr_type == EXPR_VARIABLE
+           && a->expr->symtree->n.sym->attr.protected
+           && a->expr->symtree->n.sym->attr.use_assoc
+ 	  && (f->sym->attr.intent == INTENT_OUT
+ 	      || f->sym->attr.intent == INTENT_INOUT)
+           && (!a->expr->symtree->n.sym->attr.pointer
+               || (a->expr->symtree->n.sym->attr.pointer
+ 		  && f->sym->attr.pointer)))
+ 	{
+ 	  if (where)
+ 	    gfc_error ("Actual argument at %L is use-associated with "
+ 		       "PROTECTED attribute and dummy argument '%s' is "
+ 		       "INTENT = OUT/INOUT",
+ 		       &a->expr->where,f->sym->name);
+           return 0;
+ 	}
+ 
      match:
        if (a == actual)
  	na = i;
Index: gcc/fortran/symbol.c
===================================================================
*** gcc/fortran/symbol.c	(revision 119706)
--- gcc/fortran/symbol.c	(working copy)
*************** check_conflict (symbol_attribute * attr,
*** 275,281 ****
      *dimension = "DIMENSION", *in_equivalence = "EQUIVALENCE",
      *use_assoc = "USE ASSOCIATED", *cray_pointer = "CRAY POINTER",
      *cray_pointee = "CRAY POINTEE", *data = "DATA", *value = "VALUE",
!     *volatile_ = "VOLATILE";
    static const char *threadprivate = "THREADPRIVATE";
  
    const char *a1, *a2;
--- 275,281 ----
      *dimension = "DIMENSION", *in_equivalence = "EQUIVALENCE",
      *use_assoc = "USE ASSOCIATED", *cray_pointer = "CRAY POINTER",
      *cray_pointee = "CRAY POINTEE", *data = "DATA", *value = "VALUE",
!     *volatile_ = "VOLATILE", *protected = "PROTECTED";
    static const char *threadprivate = "THREADPRIVATE";
  
    const char *a1, *a2;
*************** check_conflict (symbol_attribute * attr,
*** 404,409 ****
--- 404,413 ----
    conf (data, allocatable);
    conf (data, use_assoc);
  
+   conf (protected, intrinsic)
+   conf (protected, external)
+   conf (protected, in_common)
+ 
    conf (value, pointer)
    conf (value, allocatable)
    conf (value, subroutine)
*************** check_conflict (symbol_attribute * attr,
*** 451,456 ****
--- 455,461 ----
        conf2 (save);
        conf2 (volatile_);
        conf2 (pointer);
+       conf2 (protected);
        conf2 (target);
        conf2 (external);
        conf2 (intrinsic);
*************** check_conflict (symbol_attribute * attr,
*** 537,542 ****
--- 542,548 ----
        conf2 (subroutine);
        conf2 (entry);
        conf2 (pointer);
+       conf2 (protected);
        conf2 (target);
        conf2 (dummy);
        conf2 (in_common);
*************** gfc_add_cray_pointee (symbol_attribute *
*** 781,786 ****
--- 787,810 ----
    return check_conflict (attr, NULL, where);
  }
  
+ try
+ gfc_add_protected (symbol_attribute * attr, const char *name, locus * where)
+ {
+   if (check_used (attr, name, where))
+     return FAILURE;
+ 
+   if (attr->protected)
+     {
+ 	if (gfc_notify_std (GFC_STD_LEGACY, 
+ 			    "Duplicate PROTECTED attribute specified at %L",
+ 			    where) 
+ 	    == FAILURE)
+ 	  return FAILURE;
+     }
+ 
+   attr->protected = 1;
+   return check_conflict (attr, name, where);
+ }
  
  try
  gfc_add_result (symbol_attribute * attr, const char *name, locus * where)
*************** gfc_copy_attr (symbol_attribute * dest, 
*** 1293,1298 ****
--- 1317,1324 ----
      goto fail;
    if (src->pointer && gfc_add_pointer (dest, where) == FAILURE)
      goto fail;
+   if (src->protected && gfc_add_protected (dest, NULL, where) == FAILURE)
+     goto fail;
    if (src->save && gfc_add_save (dest, NULL, where) == FAILURE)
      goto fail;
    if (src->value && gfc_add_value (dest, NULL, where) == FAILURE)
Index: gcc/fortran/decl.c
===================================================================
*** gcc/fortran/decl.c	(revision 119706)
--- gcc/fortran/decl.c	(working copy)
*************** match_attr_spec (void)
*** 2116,2123 ****
    { GFC_DECL_BEGIN = 0,
      DECL_ALLOCATABLE = GFC_DECL_BEGIN, DECL_DIMENSION, DECL_EXTERNAL,
      DECL_IN, DECL_OUT, DECL_INOUT, DECL_INTRINSIC, DECL_OPTIONAL,
!     DECL_PARAMETER, DECL_POINTER, DECL_PRIVATE, DECL_PUBLIC, DECL_SAVE,
!     DECL_TARGET, DECL_VALUE, DECL_VOLATILE, DECL_COLON, DECL_NONE,
      GFC_DECL_END /* Sentinel */
    }
    decl_types;
--- 2116,2124 ----
    { GFC_DECL_BEGIN = 0,
      DECL_ALLOCATABLE = GFC_DECL_BEGIN, DECL_DIMENSION, DECL_EXTERNAL,
      DECL_IN, DECL_OUT, DECL_INOUT, DECL_INTRINSIC, DECL_OPTIONAL,
!     DECL_PARAMETER, DECL_POINTER, DECL_PROTECTED, DECL_PRIVATE,
!     DECL_PUBLIC, DECL_SAVE, DECL_TARGET, DECL_VALUE, DECL_VOLATILE,
!     DECL_COLON, DECL_NONE,
      GFC_DECL_END /* Sentinel */
    }
    decl_types;
*************** match_attr_spec (void)
*** 2136,2141 ****
--- 2137,2143 ----
      minit (", optional", DECL_OPTIONAL),
      minit (", parameter", DECL_PARAMETER),
      minit (", pointer", DECL_POINTER),
+     minit (", protected", DECL_PROTECTED),
      minit (", private", DECL_PRIVATE),
      minit (", public", DECL_PUBLIC),
      minit (", save", DECL_SAVE),
*************** match_attr_spec (void)
*** 2250,2255 ****
--- 2252,2260 ----
  	  case DECL_POINTER:
  	    attr = "POINTER";
  	    break;
+ 	  case DECL_PROTECTED:
+ 	    attr = "PROTECTED";
+ 	    break;
  	  case DECL_PRIVATE:
  	    attr = "PRIVATE";
  	    break;
*************** match_attr_spec (void)
*** 2364,2369 ****
--- 2369,2391 ----
  	  t = gfc_add_pointer (&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]);
*************** done:
*** 3840,3845 ****
--- 3862,3928 ----
  }
  
  
+ match
+ gfc_match_protected (void)
+ {
+   gfc_symbol *sym;
+   match m;
+ 
+   if (gfc_current_ns->proc_name->attr.flavor != FL_MODULE)
+     {
+        gfc_error ("PROTECTED at %C only allowed in specification "
+ 		  "part of a module");
+        return MATCH_ERROR;
+ 
+     }
+ 
+   if (gfc_notify_std (GFC_STD_F2003, 
+ 		      "Fortran 2003: PROTECTED statement at %C")
+       == FAILURE)
+     return MATCH_ERROR;
+ 
+   if (gfc_match (" ::") == MATCH_NO && gfc_match_space () == MATCH_NO)
+     {
+       return MATCH_ERROR;
+     }
+ 
+   if (gfc_match_eos () == MATCH_YES)
+     goto syntax;
+ 
+   for(;;)
+     {
+       m = gfc_match_symbol (&sym, 0);
+       switch (m)
+ 	{
+ 	case MATCH_YES:
+ 	  if (gfc_add_protected (&sym->attr, sym->name,
+   			         &gfc_current_locus) == FAILURE)
+ 	    return MATCH_ERROR;
+ 	  goto next_item;
+ 
+ 	case MATCH_NO:
+ 	  break;
+ 
+ 	case MATCH_ERROR:
+ 	  return MATCH_ERROR;
+ 	}
+ 
+     next_item:
+       if (gfc_match_eos () == MATCH_YES)
+ 	break;
+       if (gfc_match_char (',') != MATCH_YES)
+ 	goto syntax;
+     }
+ 
+   return MATCH_YES;
+ 
+ syntax:
+   gfc_error ("Syntax error in PROTECTED statement at %C");
+   return MATCH_ERROR;
+ }
+ 
+ 
+ 
  /* The PRIVATE statement is a bit weird in that it can be a attribute
     declaration, but also works as a standlone statement inside of a
     type declaration or a module.  */
Index: gcc/fortran/dump-parse-tree.c
===================================================================
*** gcc/fortran/dump-parse-tree.c	(revision 119706)
--- gcc/fortran/dump-parse-tree.c	(working copy)
*************** gfc_show_attr (symbol_attribute * attr)
*** 550,555 ****
--- 550,557 ----
      gfc_status (" OPTIONAL");
    if (attr->pointer)
      gfc_status (" POINTER");
+   if (attr->protected)
+     gfc_status (" PROTECTED");
    if (attr->save)
      gfc_status (" SAVE");
    if (attr->value)
Index: gcc/fortran/gfortran.h
===================================================================
*** gcc/fortran/gfortran.h	(revision 119706)
--- gcc/fortran/gfortran.h	(working copy)
*************** typedef struct
*** 483,488 ****
--- 483,489 ----
      dummy:1, result:1, assign:1, threadprivate:1;
  
    unsigned data:1,		/* Symbol is named in a DATA statement.  */
+     protected:1,		/* Symbol has been marked as protected.  */
      use_assoc:1,		/* Symbol has been use-associated.  */
      use_only:1;			/* Symbol has been use-associated, with ONLY.  */
  
*************** try gfc_add_pointer (symbol_attribute *,
*** 1857,1862 ****
--- 1858,1864 ----
  try gfc_add_cray_pointer (symbol_attribute *, locus *);
  try gfc_add_cray_pointee (symbol_attribute *, locus *);
  try gfc_mod_pointee_as (gfc_array_spec *as);
+ try gfc_add_protected (symbol_attribute *, const char *, locus *);
  try gfc_add_result (symbol_attribute *, const char *, locus *);
  try gfc_add_save (symbol_attribute *, const char *, locus *);
  try gfc_add_threadprivate (symbol_attribute *, const char *, locus *);
Index: gcc/fortran/expr.c
===================================================================
*** gcc/fortran/expr.c	(revision 119706)
--- gcc/fortran/expr.c	(working copy)
*************** gfc_check_pointer_assign (gfc_expr * lva
*** 2414,2419 ****
--- 2414,2426 ----
        return FAILURE;
      }
  
+   if (attr.protected && attr.use_assoc)
+     {
+       gfc_error ("Pointer assigment target has PROTECTED "
+                  "attribute at %L", &rvalue->where);
+       return FAILURE;
+     }
+ 
    return SUCCESS;
  }
  
Index: gcc/fortran/module.c
===================================================================
*** gcc/fortran/module.c	(revision 119706)
--- gcc/fortran/module.c	(working copy)
*************** typedef enum
*** 1491,1497 ****
    AB_IN_NAMELIST, AB_IN_COMMON, AB_FUNCTION, AB_SUBROUTINE, AB_SEQUENCE,
    AB_ELEMENTAL, AB_PURE, AB_RECURSIVE, AB_GENERIC, AB_ALWAYS_EXPLICIT,
    AB_CRAY_POINTER, AB_CRAY_POINTEE, AB_THREADPRIVATE, AB_ALLOC_COMP,
!   AB_VALUE, AB_VOLATILE
  }
  ab_attribute;
  
--- 1491,1497 ----
    AB_IN_NAMELIST, AB_IN_COMMON, AB_FUNCTION, AB_SUBROUTINE, AB_SEQUENCE,
    AB_ELEMENTAL, AB_PURE, AB_RECURSIVE, AB_GENERIC, AB_ALWAYS_EXPLICIT,
    AB_CRAY_POINTER, AB_CRAY_POINTEE, AB_THREADPRIVATE, AB_ALLOC_COMP,
!   AB_VALUE, AB_VOLATILE, AB_PROTECTED
  }
  ab_attribute;
  
*************** static const mstring attr_bits[] =
*** 1524,1529 ****
--- 1524,1530 ----
      minit ("CRAY_POINTER", AB_CRAY_POINTER),
      minit ("CRAY_POINTEE", AB_CRAY_POINTEE),
      minit ("ALLOC_COMP", AB_ALLOC_COMP),
+     minit ("PROTECTED", AB_PROTECTED),
      minit (NULL, -1)
  };
  
*************** mio_symbol_attribute (symbol_attribute *
*** 1574,1579 ****
--- 1575,1582 ----
  	MIO_NAME(ab_attribute) (AB_OPTIONAL, attr_bits);
        if (attr->pointer)
  	MIO_NAME(ab_attribute) (AB_POINTER, attr_bits);
+       if (attr->protected)
+ 	MIO_NAME(ab_attribute) (AB_PROTECTED, attr_bits);
        if (attr->save)
  	MIO_NAME(ab_attribute) (AB_SAVE, attr_bits);
        if (attr->value)
*************** mio_symbol_attribute (symbol_attribute *
*** 1655,1660 ****
--- 1658,1666 ----
  	    case AB_POINTER:
  	      attr->pointer = 1;
  	      break;
+ 	    case AB_PROTECTED:
+ 	      attr->protected = 1;
+ 	      break;
  	    case AB_SAVE:
  	      attr->save = 1;
  	      break;
Index: gcc/fortran/resolve.c
===================================================================
*** gcc/fortran/resolve.c	(revision 119706)
--- gcc/fortran/resolve.c	(working copy)
*************** resolve_equivalence_derived (gfc_symbol 
*** 6632,6637 ****
--- 6632,6638 ----
     the preceding objects.  A substring shall not have length zero.  A
     derived type shall not have components with default initialization nor
     shall two objects of an equivalence group be initialized.
+    Either all or none of the objects shall have an protected attribute.
     The simple constraints are done in symbol.c(check_conflict) and the rest
     are implemented here.  */
  
*************** resolve_equivalence (gfc_equiv *eq)
*** 6646,6652 ****
    locus *last_where = NULL;
    seq_type eq_type, last_eq_type;
    gfc_typespec *last_ts;
!   int object;
    const char *value_name;
    const char *msg;
  
--- 6647,6653 ----
    locus *last_where = NULL;
    seq_type eq_type, last_eq_type;
    gfc_typespec *last_ts;
!   int object, cnt_protected;
    const char *value_name;
    const char *msg;
  
*************** resolve_equivalence (gfc_equiv *eq)
*** 6655,6660 ****
--- 6656,6663 ----
  
    first_sym = eq->expr->symtree->n.sym;
  
+   cnt_protected = 0;
+ 
    for (object = 1; eq; eq = eq->eq, object++)
      {
        e = eq->expr;
*************** resolve_equivalence (gfc_equiv *eq)
*** 6726,6731 ****
--- 6729,6745 ----
  
        sym = e->symtree->n.sym;
  
+       if (sym->attr.protected)
+ 	cnt_protected++;
+       if (cnt_protected > 0 && cnt_protected != object)
+        	{
+ 	      gfc_error ("Either all or none of the objects in the "
+ 			 "EQUIVALENCE set at %L shall have the "
+ 			 "PROTECTED attribute",
+ 			 &e->where);
+ 	      break;
+         }
+ 
        /* An equivalence statement cannot have more than one initialized
  	 object.  */
        if (sym->value)
Index: gcc/fortran/match.c
===================================================================
*** gcc/fortran/match.c	(revision 119706)
--- gcc/fortran/match.c	(working copy)
*************** gfc_match_assignment (void)
*** 852,857 ****
--- 852,866 ----
        return MATCH_NO;
      }
  
+   if (lvalue->symtree->n.sym->attr.protected
+       && lvalue->symtree->n.sym->attr.use_assoc)
+     {
+       gfc_current_locus = old_loc;
+       gfc_free_expr (lvalue);
+       gfc_error ("Setting value of PROTECTED variable at %C");
+       return MATCH_ERROR;
+     }
+ 
    rvalue = NULL;
    m = gfc_match (" %e%t", &rvalue);
    if (m != MATCH_YES)
*************** gfc_match_pointer_assignment (void)
*** 898,903 ****
--- 907,921 ----
    if (m != MATCH_YES)
      goto cleanup;
  
+   if (lvalue->symtree->n.sym->attr.protected
+       && lvalue->symtree->n.sym->attr.use_assoc)
+     {
+       gfc_error ("Assigning to a PROTECTED pointer at %C");
+       m = MATCH_ERROR;
+       goto cleanup;
+     }
+ 
+ 
    new_st.op = EXEC_POINTER_ASSIGN;
    new_st.expr = lvalue;
    new_st.expr2 = rvalue;
Index: gcc/fortran/match.h
===================================================================
*** gcc/fortran/match.h	(revision 119706)
--- gcc/fortran/match.h	(working copy)
*************** match gfc_match_intrinsic (void);
*** 142,147 ****
--- 142,148 ----
  match gfc_match_optional (void);
  match gfc_match_parameter (void);
  match gfc_match_pointer (void);
+ match gfc_match_protected (void);
  match gfc_match_private (gfc_statement *);
  match gfc_match_public (gfc_statement *);
  match gfc_match_save (void);
Index: gcc/fortran/parse.c
===================================================================
*** gcc/fortran/parse.c	(revision 119706)
--- gcc/fortran/parse.c	(working copy)
*************** decode_statement (void)
*** 260,265 ****
--- 260,266 ----
        match ("program", gfc_match_program, ST_PROGRAM);
        if (gfc_match_public (&st) == MATCH_YES)
  	return st;
+       match ("protected", gfc_match_protected, ST_ATTR_DECL);
        break;
  
      case 'r':
Index: gcc/fortran/primary.c
===================================================================
*** gcc/fortran/primary.c	(revision 119706)
--- gcc/fortran/primary.c	(working copy)
*************** match_variable (gfc_expr ** result, int 
*** 2303,2308 ****
--- 2303,2313 ----
    switch (sym->attr.flavor)
      {
      case FL_VARIABLE:
+       if (sym->attr.protected && sym->attr.use_assoc)
+         {
+ 	  gfc_error ("Assigning to PROTECTED variable at %C");
+           return MATCH_ERROR;
+         }
        break;
  
      case FL_UNKNOWN:
Index: gcc/testsuite/gfortran.dg/protected_1.f90
===================================================================
*** gcc/testsuite/gfortran.dg/protected_1.f90	(revision 0)
--- gcc/testsuite/gfortran.dg/protected_1.f90	(revision 0)
***************
*** 0 ****
--- 1,61 ----
+ ! { dg-run }
+ ! { dg-options "-std=f2003 -fall-intrinsics" }
+ ! PR fortran/23994
+ !
+ ! Test PROTECTED attribute. Within the module everything is allowed.
+ ! Outside (use-associated): For pointers, their association status
+ ! may not be changed. For nonpointers, their value may not be changed.
+ !
+ ! Test of a valid code
+ 
+ module protmod
+   implicit none
+   integer          :: a,b
+   integer, target  :: at,bt
+   integer, pointer :: ap,bp
+   protected :: a, at
+   protected :: ap
+ contains
+   subroutine setValue()
+     a = 43
+     ap => null()
+     nullify(ap)
+     ap => at
+     ap = 3
+     allocate(ap)
+     ap = 73
+     call increment(a,ap,at)
+     if(a /= 44 .or. ap /= 74 .or. at /= 4) call abort()
+   end subroutine setValue
+   subroutine increment(a1,a2,a3)
+     integer, intent(inout) :: a1, a2, a3
+     a1 = a1 + 1
+     a2 = a2 + 1
+     a3 = a3 + 1
+   end subroutine increment
+ end module protmod
+ 
+ program main
+   use protmod
+   implicit none
+   b = 5
+   bp => bt
+   bp = 4
+   bt = 7
+   call setValue()
+   if(a /= 44 .or. ap /= 74 .or. at /= 4) call abort()
+   call plus5(ap)
+   if(a /= 44 .or. ap /= 79 .or. at /= 4) call abort()
+   call checkVal(a,ap,at)
+ contains
+   subroutine plus5(j)
+     integer, intent(inout) :: j
+     j = j + 5
+   end subroutine plus5
+   subroutine checkVal(x,y,z)
+     integer, intent(in) :: x, y, z
+     if(a /= 44 .or. ap /= 79 .or. at /= 4) call abort()
+   end subroutine
+ end program main
+ 
+ ! { dg-final { cleanup-modules "protmod" } }
Index: gcc/testsuite/gfortran.dg/protected_2.f90
===================================================================
*** gcc/testsuite/gfortran.dg/protected_2.f90	(revision 0)
--- gcc/testsuite/gfortran.dg/protected_2.f90	(revision 0)
***************
*** 0 ****
--- 1,55 ----
+ ! { dg-run }
+ ! { dg-options "-std=f2003 -fall-intrinsics" }
+ ! PR fortran/23994
+ !
+ ! Test PROTECTED attribute. Within the module everything is allowed.
+ ! Outside (use-associated): For pointers, their association status
+ ! may not be changed. For nonpointers, their value may not be changed.
+ !
+ ! Test of a valid code
+ 
+ module protmod
+   implicit none
+   integer, protected          :: a
+   integer, protected, target  :: at
+   integer, protected, pointer :: ap
+ contains
+   subroutine setValue()
+     a = 43
+     ap => null()
+     nullify(ap)
+     ap => at
+     ap = 3
+     allocate(ap)
+     ap = 73
+     call increment(a,ap,at)
+     if(a /= 44 .or. ap /= 74 .or. at /= 4) call abort()
+   end subroutine setValue
+   subroutine increment(a1,a2,a3)
+     integer, intent(inout) :: a1, a2, a3
+     a1 = a1 + 1
+     a2 = a2 + 1
+     a3 = a3 + 1
+   end subroutine increment
+ end module protmod
+ 
+ program main
+   use protmod
+   implicit none
+   call setValue()
+   if(a /= 44 .or. ap /= 74 .or. at /= 4) call abort()
+   call plus5(ap)
+   if(a /= 44 .or. ap /= 79 .or. at /= 4) call abort()
+   call checkVal(a,ap,at)
+ contains
+   subroutine plus5(j)
+     integer, intent(inout) :: j
+     j = j + 5
+   end subroutine plus5
+   subroutine checkVal(x,y,z)
+     integer, intent(in) :: x, y, z
+     if(a /= 44 .or. ap /= 79 .or. at /= 4) call abort()
+   end subroutine
+ end program main
+ 
+ ! { dg-final { cleanup-modules "protmod" } }
Index: gcc/testsuite/gfortran.dg/protected_3.f90
===================================================================
*** gcc/testsuite/gfortran.dg/protected_3.f90	(revision 0)
--- gcc/testsuite/gfortran.dg/protected_3.f90	(revision 0)
***************
*** 0 ****
--- 1,25 ----
+ ! { dg-run }
+ ! { dg-shouldfail "Fortran 2003 code with -std=f95" }
+ ! { dg-options "-std=f95 -fall-intrinsics" }
+ ! PR fortran/23994
+ !
+ ! Test PROTECTED attribute. Within the module everything is allowed.
+ ! Outside (use-associated): For pointers, their association status
+ ! may not be changed. For nonpointers, their value may not be changed.
+ !
+ ! Reject in Fortran 95
+ 
+ module protmod
+   implicit none
+   integer          :: a
+   integer, target  :: at
+   integer, pointer :: ap
+   protected :: a, at, ap ! { dg-error "Fortran 2003: PROTECTED statement" }
+ end module protmod
+ 
+ module protmod2
+   implicit none
+   integer, protected          :: a  ! { dg-error "Fortran 2003: PROTECTED attribute" }
+   integer, protected, target  :: at ! { dg-error "Fortran 2003: PROTECTED attribute" }
+   integer, protected, pointer :: ap ! { dg-error "Fortran 2003: PROTECTED attribute" }
+ end module protmod2
Index: gcc/testsuite/gfortran.dg/protected_4.f90
===================================================================
*** gcc/testsuite/gfortran.dg/protected_4.f90	(revision 0)
--- gcc/testsuite/gfortran.dg/protected_4.f90	(revision 0)
***************
*** 0 ****
--- 1,50 ----
+ ! { dg-compile }
+ ! { dg-shouldfail "Invalid Fortran 2003 code" }
+ ! { dg-options "-std=f2003 -fall-intrinsics" }
+ ! PR fortran/23994
+ !
+ ! Test PROTECTED attribute. Within the module everything is allowed.
+ ! Outside (use-associated): For pointers, their association status
+ ! may not be changed. For nonpointers, their value may not be changed.
+ !
+ ! Test of a invalid code
+ 
+ module protmod
+   implicit none
+   integer          :: a
+   integer, target  :: at
+   integer, pointer :: ap
+   protected :: a, at, ap
+ end module protmod
+ 
+ program main
+   use protmod
+   implicit none
+   integer   :: j 
+   protected :: j ! { dg-error "only allowed in specification part of a module" }
+   a = 43       ! { dg-error "Assigning to PROTECTED variable" }
+   ap => null() ! { dg-error "Assigning to PROTECTED variable" }
+   nullify(ap)  ! { dg-error "Assigning to PROTECTED variable" }
+   ap => at     ! { dg-error "Assigning to PROTECTED variable" }
+   ap = 3       ! { dg-error "Assigning to PROTECTED variable" }
+   allocate(ap) ! { dg-error "Assigning to PROTECTED variable" }
+   ap = 73      ! { dg-error "Assigning to PROTECTED variable" }
+   call increment(a,at) ! { dg-error "use-associated with PROTECTED attribute" }
+ contains
+   subroutine increment(a1,a3)
+     integer, intent(inout) :: a1, a3
+     a1 = a1 + 1
+     a3 = a3 + 1
+   end subroutine increment
+   subroutine pointer_assignments(p)
+     integer, pointer :: p ! with [pointer] intent(out)
+     p => null()           ! this is invalid
+   end subroutine pointer_assignments
+ end program main
+ 
+ module test
+   real :: a
+   protected :: test ! { dg-error "MODULE attribute conflicts with PROTECTED" }
+ end module test
+ 
+ ! { dg-final { cleanup-modules "protmod" } }
Index: gcc/testsuite/gfortran.dg/protected_5.f90
===================================================================
*** gcc/testsuite/gfortran.dg/protected_5.f90	(revision 0)
--- gcc/testsuite/gfortran.dg/protected_5.f90	(revision 0)
***************
*** 0 ****
--- 1,57 ----
+ ! { dg-compile }
+ ! { dg-shouldfail "Invalid Fortran 2003 code" }
+ ! { dg-options "-std=f2003 -fall-intrinsics" }
+ ! PR fortran/23994
+ !
+ ! Test PROTECTED attribute. Within the module everything is allowed.
+ ! Outside (use-associated): For pointers, their association status
+ ! may not be changed. For nonpointers, their value may not be changed.
+ !
+ ! Test of a invalid code
+ 
+ module good1
+   implicit none
+   integer              :: a
+   integer              :: b,c
+   protected            :: c
+   equivalence (a,c) ! { dg-error "Either all or none of the objects in the EQUIVALENCE" }
+ end module good1
+ 
+ 
+ module bad1
+   implicit none
+   integer, protected   :: a
+   integer              :: b,c
+   protected            :: c
+   equivalence (a,b) ! { dg-error "Either all or none of the objects in the EQUIVALENCE" }
+ end module bad1
+ 
+ module bad2
+   implicit none
+   integer, protected   :: a
+   integer              :: b,c,d
+   protected            :: c
+   common /one/ a,b  ! { dg-error "PROTECTED attribute conflicts with COMMON" }
+   common /two/ c,d  ! { dg-error "PROTECTED attribute conflicts with COMMON" }
+ end module bad2
+ 
+ module good2
+   implicit none
+   type myT
+      integer :: j
+      integer, pointer :: p
+      real, allocatable, dimension(:) :: array
+   end type myT
+   type(myT), save :: t
+   protected :: t
+ end module good2
+ 
+ program main
+   use good2
+   implicit none
+   t%j = 15             ! { dg-error "Assigning to PROTECTED variable" }
+   nullify(t%p)         ! { dg-error "Assigning to PROTECTED variable" }
+   allocate(t%array(15))! { dg-error "Assigning to PROTECTED variable" }
+ end program main
+ 
+ ! { dg-final { cleanup-modules "good1 good2 bad1 bad2" } }
Index: gcc/testsuite/gfortran.dg/protected_6.f90
===================================================================
*** gcc/testsuite/gfortran.dg/protected_6.f90	(revision 0)
--- gcc/testsuite/gfortran.dg/protected_6.f90	(revision 0)
***************
*** 0 ****
--- 1,50 ----
+ ! { dg-compile }
+ ! { dg-shouldfail "Invalid Fortran 2003 code" }
+ ! { dg-options "-std=f2003 -fall-intrinsics" }
+ ! PR fortran/23994
+ !
+ ! Test PROTECTED attribute. Within the module everything is allowed.
+ ! Outside (use-associated): For pointers, their association status
+ ! may not be changed. For nonpointers, their value may not be changed.
+ !
+ ! Test of a invalid code
+ 
+ module protmod
+   implicit none
+   integer, Protected          :: a
+   integer, protected, target  :: at
+   integer, protected, pointer :: ap
+ end module protmod
+ 
+ program main
+   use protmod
+   implicit none
+   a = 43       ! { dg-error "Assigning to PROTECTED variable" }
+   ap => null() ! { dg-error "Assigning to PROTECTED variable" }
+   nullify(ap)  ! { dg-error "Assigning to PROTECTED variable" }
+   ap => at     ! { dg-error "Assigning to PROTECTED variable" }
+   ap = 3       ! { dg-error "Assigning to PROTECTED variable" }
+   allocate(ap) ! { dg-error "Assigning to PROTECTED variable" }
+   ap = 73      ! { dg-error "Assigning to PROTECTED variable" }
+   call increment(a,at) ! { dg-error "use-associated with PROTECTED attribute" }
+ contains
+   subroutine increment(a1,a3)
+     integer, intent(inout) :: a1, a3
+     a1 = a1 + 1
+     a3 = a3 + 1
+   end subroutine increment
+   subroutine pointer_assignments(p)
+     integer, pointer :: p ! with [pointer] intent(out)
+     p => null()           ! this is invalid
+   end subroutine pointer_assignments
+ end program main
+ 
+ module prot2
+   implicit none
+ contains
+   subroutine bar
+     real, protected :: b ! { dg-error "only allowed in specification part of a module" }
+   end subroutine bar
+ end module prot2
+ 
+ ! { dg-final { cleanup-modules "protmod" } }

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