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

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

13 files changed, 233 insertions, 5 deletions

diff --git a/gcc/fortran/ChangeLog b/gcc/fortran/ChangeLog
index c2a3464..d211080 100644
--- a/gcc/fortran/ChangeLog
+++ b/gcc/fortran/ChangeLog
@@ -1,3 +1,26 @@
+2006-12-10  Tobias Burnus  <burnus@net-b.de>
+
+	PR fortran/23994
+	* interface.c (compare_actual_formal): PROTECTED is incompatible
+	  with intent(out).
+	* symbol.c (check_conflict): Check for PROTECTED conflicts.
+	  (gfc_add_protected): New function.
+	  (gfc_copy_attr): Copy PROTECTED attribute.
+	* decl.c (match_attr_spec): Add PROTECTED support.
+	  (gfc_match_protected): New function.
+	* dump-parse-tree.c (gfc_show_attr): Add PROTECTED support.
+	* gfortran.h (gfc_symbol): Add protected flag.
+	  Add gfc_add_protected prototype.
+	* expr.c (gfc_check_pointer_assign): Add PROTECTED support.
+	* module.c (ab_attribute, attr_bits, mio_symbol_attribute,
+	  mio_symbol_attribute): Add PROTECTED support.
+	* resolve.c (resolve_equivalence): Add PROTECTED support.
+	* match.c (gfc_match_assignment,gfc_match_pointer_assignment):
+	  Check PROTECTED attribute.
+	* match.h: Add gfc_match_protected prototype.
+	* parse.c (decode_statement): Match PROTECTED statement.
+	* primary.c (match_variable): Add PROTECTED support.
+
 2006-12-09  Paul Thomas  <pault@gcc.gnu.org>
 
 	PR fortran/29975
diff --git a/gcc/fortran/decl.c b/gcc/fortran/decl.c
index 46c49ba..eb33237 100644
--- a/gcc/fortran/decl.c
+++ b/gcc/fortran/decl.c
@@ -2116,8 +2116,9 @@ match_attr_spec (void)
   { GFC_DECL_BEGIN = 0,
     DECL_ALLOCATABLE = GFC_DECL_BEGIN, DECL_DIMENSION, DECL_EXTERNAL,
     DECL_IN, DECL_OUT, DECL_INOUT, DECL_INTRINSIC, DECL_OPTIONAL,
-    DECL_PARAMETER, DECL_POINTER, DECL_PRIVATE, DECL_PUBLIC, DECL_SAVE,
-    DECL_TARGET, DECL_VALUE, DECL_VOLATILE, DECL_COLON, DECL_NONE,
+    DECL_PARAMETER, DECL_POINTER, DECL_PROTECTED, DECL_PRIVATE,
+    DECL_PUBLIC, DECL_SAVE, DECL_TARGET, DECL_VALUE, DECL_VOLATILE,
+    DECL_COLON, DECL_NONE,
     GFC_DECL_END /* Sentinel */
   }
   decl_types;
@@ -2136,6 +2137,7 @@ match_attr_spec (void)
     minit (", optional", DECL_OPTIONAL),
     minit (", parameter", DECL_PARAMETER),
     minit (", pointer", DECL_POINTER),
+    minit (", protected", DECL_PROTECTED),
     minit (", private", DECL_PRIVATE),
     minit (", public", DECL_PUBLIC),
     minit (", save", DECL_SAVE),
@@ -2250,6 +2252,9 @@ match_attr_spec (void)
 	  case DECL_POINTER:
 	    attr = "POINTER";
 	    break;
+	  case DECL_PROTECTED:
+	    attr = "PROTECTED";
+	    break;
 	  case DECL_PRIVATE:
 	    attr = "PRIVATE";
 	    break;
@@ -2364,6 +2369,23 @@ match_attr_spec (void)
 	  t = gfc_add_pointer (&current_attr, &seen_at[d]);
 	  break;
 
+	case DECL_PROTECTED:
+	  if (gfc_current_ns->proc_name->attr.flavor != FL_MODULE)
+	    {
+	       gfc_error ("PROTECTED at %C only allowed in specification "
+			  "part of a module");
+	       t = FAILURE;
+	       break;
+	    }
+
+	  if (gfc_notify_std (GFC_STD_F2003,
+                              "Fortran 2003: PROTECTED attribute at %C")
+	      == FAILURE)
+	    t = FAILURE;
+	  else
+	    t = gfc_add_protected (&current_attr, NULL, &seen_at[d]);
+	  break;
+
 	case DECL_PRIVATE:
 	  t = gfc_add_access (&current_attr, ACCESS_PRIVATE, NULL,
 			      &seen_at[d]);
@@ -3840,6 +3862,67 @@ done:
 }
 
 
+match
+gfc_match_protected (void)
+{
+  gfc_symbol *sym;
+  match m;
+
+  if (gfc_current_ns->proc_name->attr.flavor != FL_MODULE)
+    {
+       gfc_error ("PROTECTED at %C only allowed in specification "
+		  "part of a module");
+       return MATCH_ERROR;
+
+    }
+
+  if (gfc_notify_std (GFC_STD_F2003, 
+		      "Fortran 2003: PROTECTED statement at %C")
+      == FAILURE)
+    return MATCH_ERROR;
+
+  if (gfc_match (" ::") == MATCH_NO && gfc_match_space () == MATCH_NO)
+    {
+      return MATCH_ERROR;
+    }
+
+  if (gfc_match_eos () == MATCH_YES)
+    goto syntax;
+
+  for(;;)
+    {
+      m = gfc_match_symbol (&sym, 0);
+      switch (m)
+	{
+	case MATCH_YES:
+	  if (gfc_add_protected (&sym->attr, sym->name,
+  			         &gfc_current_locus) == FAILURE)
+	    return MATCH_ERROR;
+	  goto next_item;
+
+	case MATCH_NO:
+	  break;
+
+	case MATCH_ERROR:
+	  return MATCH_ERROR;
+	}
+
+    next_item:
+      if (gfc_match_eos () == MATCH_YES)
+	break;
+      if (gfc_match_char (',') != MATCH_YES)
+	goto syntax;
+    }
+
+  return MATCH_YES;
+
+syntax:
+  gfc_error ("Syntax error in PROTECTED statement at %C");
+  return MATCH_ERROR;
+}
+
+
+
 /* The PRIVATE statement is a bit weird in that it can be a attribute
    declaration, but also works as a standlone statement inside of a
    type declaration or a module.  */
diff --git a/gcc/fortran/dump-parse-tree.c b/gcc/fortran/dump-parse-tree.c
index f53ee2e..17a7bf0 100644
--- a/gcc/fortran/dump-parse-tree.c
+++ b/gcc/fortran/dump-parse-tree.c
@@ -550,6 +550,8 @@ gfc_show_attr (symbol_attribute * attr)
     gfc_status (" OPTIONAL");
   if (attr->pointer)
     gfc_status (" POINTER");
+  if (attr->protected)
+    gfc_status (" PROTECTED");
   if (attr->save)
     gfc_status (" SAVE");
   if (attr->value)
diff --git a/gcc/fortran/expr.c b/gcc/fortran/expr.c
index 78cb9f0..7f6c699 100644
--- a/gcc/fortran/expr.c
+++ b/gcc/fortran/expr.c
@@ -2414,6 +2414,13 @@ gfc_check_pointer_assign (gfc_expr * lvalue, gfc_expr * rvalue)
       return FAILURE;
     }
 
+  if (attr.protected && attr.use_assoc)
+    {
+      gfc_error ("Pointer assigment target has PROTECTED "
+                 "attribute at %L", &rvalue->where);
+      return FAILURE;
+    }
+
   return SUCCESS;
 }
 
diff --git a/gcc/fortran/gfortran.h b/gcc/fortran/gfortran.h
index 8665ec9..0c67d10 100644
--- a/gcc/fortran/gfortran.h
+++ b/gcc/fortran/gfortran.h
@@ -483,6 +483,7 @@ typedef struct
     dummy:1, result:1, assign:1, threadprivate:1;
 
   unsigned data:1,		/* Symbol is named in a DATA statement.  */
+    protected:1,		/* Symbol has been marked as protected.  */
     use_assoc:1,		/* Symbol has been use-associated.  */
     use_only:1;			/* Symbol has been use-associated, with ONLY.  */
 
@@ -1857,6 +1858,7 @@ try gfc_add_pointer (symbol_attribute *, locus *);
 try gfc_add_cray_pointer (symbol_attribute *, locus *);
 try gfc_add_cray_pointee (symbol_attribute *, locus *);
 try gfc_mod_pointee_as (gfc_array_spec *as);
+try gfc_add_protected (symbol_attribute *, const char *, locus *);
 try gfc_add_result (symbol_attribute *, const char *, locus *);
 try gfc_add_save (symbol_attribute *, const char *, locus *);
 try gfc_add_threadprivate (symbol_attribute *, const char *, locus *);
diff --git a/gcc/fortran/interface.c b/gcc/fortran/interface.c
index bcf95f5..28747e0 100644
--- a/gcc/fortran/interface.c
+++ b/gcc/fortran/interface.c
@@ -1206,6 +1206,36 @@ compare_parameter (gfc_symbol * formal, gfc_expr * actual,
 }
 
 
+/* Given a symbol of a formal argument list and an expression, see if
+   the two are compatible as arguments.  Returns nonzero if
+   compatible, zero if not compatible.  */
+
+static int
+compare_parameter_protected (gfc_symbol * formal, gfc_expr * actual)
+{
+  if (actual->expr_type != EXPR_VARIABLE)
+    return 1;
+
+  if (!actual->symtree->n.sym->attr.protected)
+    return 1;
+
+  if (!actual->symtree->n.sym->attr.use_assoc)
+    return 1;
+
+  if (formal->attr.intent == INTENT_IN
+      || formal->attr.intent == INTENT_UNKNOWN)
+    return 1;
+
+  if (!actual->symtree->n.sym->attr.pointer)
+    return 0;
+
+  if (actual->symtree->n.sym->attr.pointer && formal->attr.pointer)
+    return 0;
+
+  return 1;
+}
+
+
 /* Given formal and actual argument lists, see if they are compatible.
    If they are compatible, the actual argument list is sorted to
    correspond with the formal list, and elements for missing optional
@@ -1393,6 +1423,16 @@ compare_actual_formal (gfc_actual_arglist ** ap,
           return 0;
         }
 
+      if (!compare_parameter_protected(f->sym, a->expr))
+	{
+	  if (where)
+	    gfc_error ("Actual argument at %L is use-associated with "
+		       "PROTECTED attribute and dummy argument '%s' is "
+		       "INTENT = OUT/INOUT",
+		       &a->expr->where,f->sym->name);
+          return 0;
+	}
+
     match:
       if (a == actual)
 	na = i;
diff --git a/gcc/fortran/match.c b/gcc/fortran/match.c
index 413487d..0dc2c72 100644
--- a/gcc/fortran/match.c
+++ b/gcc/fortran/match.c
@@ -852,6 +852,15 @@ gfc_match_assignment (void)
       return MATCH_NO;
     }
 
+  if (lvalue->symtree->n.sym->attr.protected
+      && lvalue->symtree->n.sym->attr.use_assoc)
+    {
+      gfc_current_locus = old_loc;
+      gfc_free_expr (lvalue);
+      gfc_error ("Setting value of PROTECTED variable at %C");
+      return MATCH_ERROR;
+    }
+
   rvalue = NULL;
   m = gfc_match (" %e%t", &rvalue);
   if (m != MATCH_YES)
@@ -898,6 +907,15 @@ gfc_match_pointer_assignment (void)
   if (m != MATCH_YES)
     goto cleanup;
 
+  if (lvalue->symtree->n.sym->attr.protected
+      && lvalue->symtree->n.sym->attr.use_assoc)
+    {
+      gfc_error ("Assigning to a PROTECTED pointer at %C");
+      m = MATCH_ERROR;
+      goto cleanup;
+    }
+
+
   new_st.op = EXEC_POINTER_ASSIGN;
   new_st.expr = lvalue;
   new_st.expr2 = rvalue;
diff --git a/gcc/fortran/match.h b/gcc/fortran/match.h
index cc0207b..2209c0d 100644
--- a/gcc/fortran/match.h
+++ b/gcc/fortran/match.h
@@ -142,6 +142,7 @@ match gfc_match_intrinsic (void);
 match gfc_match_optional (void);
 match gfc_match_parameter (void);
 match gfc_match_pointer (void);
+match gfc_match_protected (void);
 match gfc_match_private (gfc_statement *);
 match gfc_match_public (gfc_statement *);
 match gfc_match_save (void);
diff --git a/gcc/fortran/module.c b/gcc/fortran/module.c
index ca4e091..f54ef8e 100644
--- a/gcc/fortran/module.c
+++ b/gcc/fortran/module.c
@@ -1491,7 +1491,7 @@ typedef enum
   AB_IN_NAMELIST, AB_IN_COMMON, AB_FUNCTION, AB_SUBROUTINE, AB_SEQUENCE,
   AB_ELEMENTAL, AB_PURE, AB_RECURSIVE, AB_GENERIC, AB_ALWAYS_EXPLICIT,
   AB_CRAY_POINTER, AB_CRAY_POINTEE, AB_THREADPRIVATE, AB_ALLOC_COMP,
-  AB_VALUE, AB_VOLATILE
+  AB_VALUE, AB_VOLATILE, AB_PROTECTED
 }
 ab_attribute;
 
@@ -1524,6 +1524,7 @@ static const mstring attr_bits[] =
     minit ("CRAY_POINTER", AB_CRAY_POINTER),
     minit ("CRAY_POINTEE", AB_CRAY_POINTEE),
     minit ("ALLOC_COMP", AB_ALLOC_COMP),
+    minit ("PROTECTED", AB_PROTECTED),
     minit (NULL, -1)
 };
 
@@ -1574,6 +1575,8 @@ mio_symbol_attribute (symbol_attribute * attr)
 	MIO_NAME(ab_attribute) (AB_OPTIONAL, attr_bits);
       if (attr->pointer)
 	MIO_NAME(ab_attribute) (AB_POINTER, attr_bits);
+      if (attr->protected)
+	MIO_NAME(ab_attribute) (AB_PROTECTED, attr_bits);
       if (attr->save)
 	MIO_NAME(ab_attribute) (AB_SAVE, attr_bits);
       if (attr->value)
@@ -1655,6 +1658,9 @@ mio_symbol_attribute (symbol_attribute * attr)
 	    case AB_POINTER:
 	      attr->pointer = 1;
 	      break;
+	    case AB_PROTECTED:
+	      attr->protected = 1;
+	      break;
 	    case AB_SAVE:
 	      attr->save = 1;
 	      break;
diff --git a/gcc/fortran/parse.c b/gcc/fortran/parse.c
index d237373..cbbf734 100644
--- a/gcc/fortran/parse.c
+++ b/gcc/fortran/parse.c
@@ -260,6 +260,7 @@ decode_statement (void)
       match ("program", gfc_match_program, ST_PROGRAM);
       if (gfc_match_public (&st) == MATCH_YES)
 	return st;
+      match ("protected", gfc_match_protected, ST_ATTR_DECL);
       break;
 
     case 'r':
diff --git a/gcc/fortran/primary.c b/gcc/fortran/primary.c
index 2c34072..66ac2f1 100644
--- a/gcc/fortran/primary.c
+++ b/gcc/fortran/primary.c
@@ -2303,6 +2303,11 @@ match_variable (gfc_expr ** result, int equiv_flag, int host_flag)
   switch (sym->attr.flavor)
     {
     case FL_VARIABLE:
+      if (sym->attr.protected && sym->attr.use_assoc)
+        {
+	  gfc_error ("Assigning to PROTECTED variable at %C");
+          return MATCH_ERROR;
+        }
       break;
 
     case FL_UNKNOWN:
diff --git a/gcc/fortran/resolve.c b/gcc/fortran/resolve.c
index 0690dca..33ef748 100644
--- a/gcc/fortran/resolve.c
+++ b/gcc/fortran/resolve.c
@@ -6632,6 +6632,7 @@ resolve_equivalence_derived (gfc_symbol *derived, gfc_symbol *sym, gfc_expr *e)
    the preceding objects.  A substring shall not have length zero.  A
    derived type shall not have components with default initialization nor
    shall two objects of an equivalence group be initialized.
+   Either all or none of the objects shall have an protected attribute.
    The simple constraints are done in symbol.c(check_conflict) and the rest
    are implemented here.  */
 
@@ -6646,7 +6647,7 @@ resolve_equivalence (gfc_equiv *eq)
   locus *last_where = NULL;
   seq_type eq_type, last_eq_type;
   gfc_typespec *last_ts;
-  int object;
+  int object, cnt_protected;
   const char *value_name;
   const char *msg;
 
@@ -6655,6 +6656,8 @@ resolve_equivalence (gfc_equiv *eq)
 
   first_sym = eq->expr->symtree->n.sym;
 
+  cnt_protected = 0;
+
   for (object = 1; eq; eq = eq->eq, object++)
     {
       e = eq->expr;
@@ -6726,6 +6729,17 @@ resolve_equivalence (gfc_equiv *eq)
 
       sym = e->symtree->n.sym;
 
+      if (sym->attr.protected)
+	cnt_protected++;
+      if (cnt_protected > 0 && cnt_protected != object)
+       	{
+	      gfc_error ("Either all or none of the objects in the "
+			 "EQUIVALENCE set at %L shall have the "
+			 "PROTECTED attribute",
+			 &e->where);
+	      break;
+        }
+
       /* An equivalence statement cannot have more than one initialized
 	 object.  */
       if (sym->value)
diff --git a/gcc/fortran/symbol.c b/gcc/fortran/symbol.c
index a809082..12c5749 100644
--- a/gcc/fortran/symbol.c
+++ b/gcc/fortran/symbol.c
@@ -275,7 +275,7 @@ check_conflict (symbol_attribute * attr, const char * name, locus * where)
     *dimension = "DIMENSION", *in_equivalence = "EQUIVALENCE",
     *use_assoc = "USE ASSOCIATED", *cray_pointer = "CRAY POINTER",
     *cray_pointee = "CRAY POINTEE", *data = "DATA", *value = "VALUE",
-    *volatile_ = "VOLATILE";
+    *volatile_ = "VOLATILE", *protected = "PROTECTED";
   static const char *threadprivate = "THREADPRIVATE";
 
   const char *a1, *a2;
@@ -404,6 +404,10 @@ check_conflict (symbol_attribute * attr, const char * name, locus * where)
   conf (data, allocatable);
   conf (data, use_assoc);
 
+  conf (protected, intrinsic)
+  conf (protected, external)
+  conf (protected, in_common)
+
   conf (value, pointer)
   conf (value, allocatable)
   conf (value, subroutine)
@@ -451,6 +455,7 @@ check_conflict (symbol_attribute * attr, const char * name, locus * where)
       conf2 (save);
       conf2 (volatile_);
       conf2 (pointer);
+      conf2 (protected);
       conf2 (target);
       conf2 (external);
       conf2 (intrinsic);
@@ -537,6 +542,7 @@ check_conflict (symbol_attribute * attr, const char * name, locus * where)
       conf2 (subroutine);
       conf2 (entry);
       conf2 (pointer);
+      conf2 (protected);
       conf2 (target);
       conf2 (dummy);
       conf2 (in_common);
@@ -781,6 +787,24 @@ gfc_add_cray_pointee (symbol_attribute * attr, locus * where)
   return check_conflict (attr, NULL, where);
 }
 
+try
+gfc_add_protected (symbol_attribute * attr, const char *name, locus * where)
+{
+  if (check_used (attr, name, where))
+    return FAILURE;
+
+  if (attr->protected)
+    {
+	if (gfc_notify_std (GFC_STD_LEGACY, 
+			    "Duplicate PROTECTED attribute specified at %L",
+			    where) 
+	    == FAILURE)
+	  return FAILURE;
+    }
+
+  attr->protected = 1;
+  return check_conflict (attr, name, where);
+}
 
 try
 gfc_add_result (symbol_attribute * attr, const char *name, locus * where)
@@ -1293,6 +1317,8 @@ gfc_copy_attr (symbol_attribute * dest, symbol_attribute * src, locus * where)
     goto fail;
   if (src->pointer && gfc_add_pointer (dest, where) == FAILURE)
     goto fail;
+  if (src->protected && gfc_add_protected (dest, NULL, where) == FAILURE)
+    goto fail;
   if (src->save && gfc_add_save (dest, NULL, where) == FAILURE)
     goto fail;
   if (src->value && gfc_add_value (dest, NULL, where) == FAILURE)