re PR fortran/29624 (Fortran 2003: Support intent for pointers)

fortran/
2007-01-05  Tobias Burnus  <burnus@net-b.de>

        PR fortran/29624
        * interface.c (compare_parameter_intent): New function.
          (check_intents): Support pointer intents.
        * symbol.c (check_conflict): Support pointer intents,
          better conflict_std message.
        * expr.c (gfc_check_assign,gfc_check_pointer_assign):
          Support pointer intents.
        * resolve.c (resolve_deallocate_expr,resolve_allocate_expr):
          Support pointer intents.

testsuite/
2006-01-05  Tobias Burnus  <burnus@net-b.de>

        PR fortran/29624
        * gfortran.dg/alloc_alloc_expr_1.f90: Add check for
          invalid deallocate.
        * gfortran.dg/allocatable_dummy_2.f90: Update dg-error.
        * gfortran.dg/protected_4.f90: Add pointer intent check.
        * gfortran.dg/protected_6.f90: Add pointer intent check.
        * gfortran.dg/pointer_intent_1.f90: New test.
        * gfortran.dg/pointer_intent_2.f90: New test.
        * gfortran.dg/pointer_intent_3.f90: New test.

From-SVN: r120472

5 files changed, 142 insertions, 57 deletions

diff --git a/gcc/fortran/ChangeLog b/gcc/fortran/ChangeLog
index c18d9ba..be3a9b5 100644
--- a/gcc/fortran/ChangeLog
+++ b/gcc/fortran/ChangeLog
@@ -1,3 +1,15 @@
+2007-01-05  Tobias Burnus  <burnus@net-b.de>
+
+	PR fortran/29624
+	* interface.c (compare_parameter_intent): New function.
+	  (check_intents): Support pointer intents.
+	* symbol.c (check_conflict): Support pointer intents,
+	  better conflict_std message.
+	* expr.c (gfc_check_assign,gfc_check_pointer_assign):
+	  Support pointer intents.
+	* resolve.c (resolve_deallocate_expr,resolve_allocate_expr):
+	  Support pointer intents.
+
 2007-01-03  Brooks Moses  <brooks.moses@codesourcery.com>
 
 	PR 30371
diff --git a/gcc/fortran/expr.c b/gcc/fortran/expr.c
index 7f6c699..7c2069c 100644
--- a/gcc/fortran/expr.c
+++ b/gcc/fortran/expr.c
@@ -2188,12 +2188,25 @@ try
 gfc_check_assign (gfc_expr * lvalue, gfc_expr * rvalue, int conform)
 {
   gfc_symbol *sym;
+  gfc_ref *ref;
+  int has_pointer;
 
   sym = lvalue->symtree->n.sym;
 
-  if (sym->attr.intent == INTENT_IN)
+  /* Check INTENT(IN), unless the object itself is the component or
+     sub-component of a pointer.  */
+  has_pointer = sym->attr.pointer;
+
+  for (ref = lvalue->ref; ref; ref = ref->next)
+    if (ref->type == REF_COMPONENT && ref->u.c.component->pointer)
+      {
+	has_pointer = 1;
+	break;
+      }
+
+  if (!has_pointer && sym->attr.intent == INTENT_IN)
     {
-      gfc_error ("Can't assign to INTENT(IN) variable '%s' at %L",
+      gfc_error ("Cannot assign to INTENT(IN) variable '%s' at %L",
 		 sym->name, &lvalue->where);
       return FAILURE;
     }
@@ -2318,7 +2331,9 @@ try
 gfc_check_pointer_assign (gfc_expr * lvalue, gfc_expr * rvalue)
 {
   symbol_attribute attr;
+  gfc_ref *ref;
   int is_pure;
+  int pointer, check_intent_in;
 
   if (lvalue->symtree->n.sym->ts.type == BT_UNKNOWN)
     {
@@ -2336,8 +2351,29 @@ gfc_check_pointer_assign (gfc_expr * lvalue, gfc_expr * rvalue)
       return FAILURE;
     }
 
-  attr = gfc_variable_attr (lvalue, NULL);
-  if (!attr.pointer)
+
+  /* Check INTENT(IN), unless the object itself is the component or
+     sub-component of a pointer.  */
+  check_intent_in = 1;
+  pointer = lvalue->symtree->n.sym->attr.pointer;
+
+  for (ref = lvalue->ref; ref; ref = ref->next)
+    {
+      if (pointer)
+        check_intent_in = 0;
+
+      if (ref->type == REF_COMPONENT && ref->u.c.component->pointer)
+        pointer = 1;
+    }
+
+  if (check_intent_in && lvalue->symtree->n.sym->attr.intent == INTENT_IN)
+    {
+      gfc_error ("Cannot assign to INTENT(IN) variable '%s' at %L",
+                 lvalue->symtree->n.sym->name, &lvalue->where);
+      return FAILURE;
+    }
+
+  if (!pointer)
     {
       gfc_error ("Pointer assignment to non-POINTER at %L", &lvalue->where);
       return FAILURE;
diff --git a/gcc/fortran/interface.c b/gcc/fortran/interface.c
index 7b0c423..8a1987d 100644
--- a/gcc/fortran/interface.c
+++ b/gcc/fortran/interface.c
@@ -1664,6 +1664,27 @@ check_some_aliasing (gfc_formal_arglist * f, gfc_actual_arglist * a)
 }
 
 
+/* Given a symbol of a formal argument list and an expression,
+   return non-zero if their intents are compatible, zero otherwise.  */
+
+static int
+compare_parameter_intent (gfc_symbol * formal, gfc_expr * actual)
+{
+  if (actual->symtree->n.sym->attr.pointer
+      && !formal->attr.pointer)
+    return 1;
+
+  if (actual->symtree->n.sym->attr.intent != INTENT_IN)
+    return 1;
+
+  if (formal->attr.intent == INTENT_INOUT
+      || formal->attr.intent == INTENT_OUT)
+    return 0;
+
+  return 1;
+}
+
+
 /* Given formal and actual argument lists that correspond to one
    another, check that they are compatible in the sense that intents
    are not mismatched.  */
@@ -1671,7 +1692,7 @@ check_some_aliasing (gfc_formal_arglist * f, gfc_actual_arglist * a)
 static try
 check_intents (gfc_formal_arglist * f, gfc_actual_arglist * a)
 {
-  sym_intent a_intent, f_intent;
+  sym_intent f_intent;
 
   for (;; f = f->next, a = a->next)
     {
@@ -1683,12 +1704,9 @@ check_intents (gfc_formal_arglist * f, gfc_actual_arglist * a)
       if (a->expr == NULL || a->expr->expr_type != EXPR_VARIABLE)
 	continue;
 
-      a_intent = a->expr->symtree->n.sym->attr.intent;
       f_intent = f->sym->attr.intent;
 
-      if (a_intent == INTENT_IN
-	  && (f_intent == INTENT_INOUT
-	      || f_intent == INTENT_OUT))
+      if (!compare_parameter_intent(f->sym, a->expr))
 	{
 
 	  gfc_error ("Procedure argument at %L is INTENT(IN) while interface "
diff --git a/gcc/fortran/resolve.c b/gcc/fortran/resolve.c
index 650a5a2..3c28d45 100644
--- a/gcc/fortran/resolve.c
+++ b/gcc/fortran/resolve.c
@@ -3446,48 +3446,57 @@ static try
 resolve_deallocate_expr (gfc_expr * e)
 {
   symbol_attribute attr;
-  int allocatable;
+  int allocatable, pointer, check_intent_in;
   gfc_ref *ref;
 
+  /* Check INTENT(IN), unless the object is a sub-component of a pointer.  */
+  check_intent_in = 1;
+
   if (gfc_resolve_expr (e) == FAILURE)
     return FAILURE;
 
-  attr = gfc_expr_attr (e);
-  if (attr.pointer)
-    return SUCCESS;
-
   if (e->expr_type != EXPR_VARIABLE)
     goto bad;
 
   allocatable = e->symtree->n.sym->attr.allocatable;
+  pointer = e->symtree->n.sym->attr.pointer;
   for (ref = e->ref; ref; ref = ref->next)
-    switch (ref->type)
-      {
-      case REF_ARRAY:
-	if (ref->u.ar.type != AR_FULL)
-	  allocatable = 0;
-	break;
+    {
+      if (pointer)
+        check_intent_in = 0;
 
-      case REF_COMPONENT:
-	allocatable = (ref->u.c.component->as != NULL
-		       && ref->u.c.component->as->type == AS_DEFERRED);
-	break;
+      switch (ref->type)
+        {
+        case REF_ARRAY:
+	  if (ref->u.ar.type != AR_FULL)
+	    allocatable = 0;
+	  break;
 
-      case REF_SUBSTRING:
-	allocatable = 0;
-	break;
-      }
+        case REF_COMPONENT:
+	  allocatable = (ref->u.c.component->as != NULL
+		         && ref->u.c.component->as->type == AS_DEFERRED);
+	  pointer = ref->u.c.component->pointer;
+	  break;
 
-  if (allocatable == 0)
+        case REF_SUBSTRING:
+	  allocatable = 0;
+	  break;
+        }
+    }
+
+  attr = gfc_expr_attr (e);
+
+  if (allocatable == 0 && attr.pointer == 0)
     {
     bad:
       gfc_error ("Expression in DEALLOCATE statement at %L must be "
 		 "ALLOCATABLE or a POINTER", &e->where);
     }
 
-  if (e->symtree->n.sym->attr.intent == INTENT_IN)
+  if (check_intent_in
+      && e->symtree->n.sym->attr.intent == INTENT_IN)
     {
-      gfc_error ("Can't deallocate INTENT(IN) variable '%s' at %L",
+      gfc_error ("Cannot deallocate INTENT(IN) variable '%s' at %L",
                  e->symtree->n.sym->name, &e->where);
       return FAILURE;
     }
@@ -3609,7 +3618,7 @@ expr_to_initialize (gfc_expr * e)
 static try
 resolve_allocate_expr (gfc_expr * e, gfc_code * code)
 {
-  int i, pointer, allocatable, dimension;
+  int i, pointer, allocatable, dimension, check_intent_in;
   symbol_attribute attr;
   gfc_ref *ref, *ref2;
   gfc_array_ref *ar;
@@ -3618,6 +3627,9 @@ resolve_allocate_expr (gfc_expr * e, gfc_code * code)
   gfc_symbol *sym;
   gfc_alloc *a;
 
+  /* Check INTENT(IN), unless the object is a sub-component of a pointer.  */
+  check_intent_in = 1;
+
   if (gfc_resolve_expr (e) == FAILURE)
     return FAILURE;
 
@@ -3655,26 +3667,31 @@ resolve_allocate_expr (gfc_expr * e, gfc_code * code)
 	}
 
       for (ref = e->ref; ref; ref2 = ref, ref = ref->next)
-	switch (ref->type)
-	  {
-	  case REF_ARRAY:
-	    if (ref->next != NULL)
-	      pointer = 0;
-	    break;
-
-	  case REF_COMPONENT:
-	    allocatable = (ref->u.c.component->as != NULL
-			   && ref->u.c.component->as->type == AS_DEFERRED);
-
-	    pointer = ref->u.c.component->pointer;
-	    dimension = ref->u.c.component->dimension;
-	    break;
+        {
+	  if (pointer)
+	    check_intent_in = 0;
 
-	  case REF_SUBSTRING:
-	    allocatable = 0;
-	    pointer = 0;
-	    break;
-	  }
+	  switch (ref->type)
+	    {
+ 	      case REF_ARRAY:
+	        if (ref->next != NULL)
+	          pointer = 0;
+	        break;
+
+	      case REF_COMPONENT:
+	        allocatable = (ref->u.c.component->as != NULL
+			      && ref->u.c.component->as->type == AS_DEFERRED);
+
+	        pointer = ref->u.c.component->pointer;
+	        dimension = ref->u.c.component->dimension;
+	        break;
+
+	      case REF_SUBSTRING:
+	        allocatable = 0;
+	        pointer = 0;
+	        break;
+	    }
+       }
     }
 
   if (allocatable == 0 && pointer == 0)
@@ -3684,9 +3701,10 @@ resolve_allocate_expr (gfc_expr * e, gfc_code * code)
       return FAILURE;
     }
 
-  if (e->symtree->n.sym->attr.intent == INTENT_IN)
+  if (check_intent_in
+      && e->symtree->n.sym->attr.intent == INTENT_IN)
     {
-      gfc_error ("Can't allocate INTENT(IN) variable '%s' at %L",
+      gfc_error ("Cannot allocate INTENT(IN) variable '%s' at %L",
                  e->symtree->n.sym->name, &e->where);
       return FAILURE;
     }
diff --git a/gcc/fortran/symbol.c b/gcc/fortran/symbol.c
index 12c5749..a1aaae8 100644
--- a/gcc/fortran/symbol.c
+++ b/gcc/fortran/symbol.c
@@ -288,7 +288,8 @@ check_conflict (symbol_attribute * attr, const char * name, locus * where)
     {
       a1 = pointer;
       a2 = intent;
-      goto conflict;
+      standard = GFC_STD_F2003;
+      goto conflict_std;
     }
 
   /* Check for attributes not allowed in a BLOCK DATA.  */
@@ -571,14 +572,14 @@ conflict:
 conflict_std:
   if (name == NULL)
     {
-      return gfc_notify_std (standard, "In the selected standard, %s attribute "
+      return gfc_notify_std (standard, "Fortran 2003: %s attribute "
                              "conflicts with %s attribute at %L", a1, a2,
                              where);
     }
   else
     {
-      return gfc_notify_std (standard, "In the selected standard, %s attribute "
-                             "conflicts with %s attribute in '%s' at %L",
+      return gfc_notify_std (standard, "Fortran 2003: %s attribute "
+			     "with %s attribute in '%s' at %L",
                              a1, a2, name, where);
     }
 }