2009-05-08 Janus Weil <janus@gcc.gnu.org>

[pf3gnuchains/gcc-fork.git] / gcc / fortran / expr.c

diff --git a/gcc/fortran/expr.c b/gcc/fortran/expr.c
index 02143c2..feaa625 100644 (file)
--- a/gcc/fortran/expr.c
+++ b/gcc/fortran/expr.c
@@ -182,6 +182,7 @@ free_expr0 (gfc_expr *e)
       break;
 
     case EXPR_COMPCALL:
+    case EXPR_PPC:
       gfc_free_actual_arglist (e->value.compcall.actual);
       break;
 
@@ -507,6 +508,7 @@ gfc_copy_expr (gfc_expr *p)
       break;
 
     case EXPR_COMPCALL:
+    case EXPR_PPC:
       q->value.compcall.actual =
        gfc_copy_actual_arglist (p->value.compcall.actual);
       q->value.compcall.tbp = p->value.compcall.tbp;
@@ -1728,6 +1730,7 @@ gfc_simplify_expr (gfc_expr *p, int type)
       break;
 
     case EXPR_COMPCALL:
+    case EXPR_PPC:
       gcc_unreachable ();
       break;
     }
@@ -3038,7 +3041,7 @@ gfc_check_pointer_assign (gfc_expr *lvalue, gfc_expr *rvalue)
   symbol_attribute attr;
   gfc_ref *ref;
   int is_pure;
-  int pointer, check_intent_in;
+  int pointer, check_intent_in, proc_pointer;
 
   if (lvalue->symtree->n.sym->ts.type == BT_UNKNOWN
       && !lvalue->symtree->n.sym->attr.proc_pointer)
@@ -3062,16 +3065,19 @@ gfc_check_pointer_assign (gfc_expr *lvalue, gfc_expr *rvalue)
   /* 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
-             | lvalue->symtree->n.sym->attr.proc_pointer;
+  pointer = lvalue->symtree->n.sym->attr.pointer;
+  proc_pointer = lvalue->symtree->n.sym->attr.proc_pointer;
 
   for (ref = lvalue->ref; ref; ref = ref->next)
     {
       if (pointer)
        check_intent_in = 0;
 
-      if (ref->type == REF_COMPONENT && ref->u.c.component->attr.pointer)
-       pointer = 1;
+      if (ref->type == REF_COMPONENT)
+       {
+         pointer = ref->u.c.component->attr.pointer;
+         proc_pointer = ref->u.c.component->attr.proc_pointer;
+       }
 
       if (ref->type == REF_ARRAY && ref->next == NULL)
        {
@@ -3107,7 +3113,7 @@ gfc_check_pointer_assign (gfc_expr *lvalue, gfc_expr *rvalue)
       return FAILURE;
     }
 
-  if (!pointer)
+  if (!pointer && !proc_pointer)
     {
       gfc_error ("Pointer assignment to non-POINTER at %L", &lvalue->where);
       return FAILURE;
@@ -3129,11 +3135,12 @@ gfc_check_pointer_assign (gfc_expr *lvalue, gfc_expr *rvalue)
     return SUCCESS;
 
   /* Checks on rvalue for procedure pointer assignments.  */
-  if (lvalue->symtree->n.sym->attr.proc_pointer)
+  if (proc_pointer)
     {
       attr = gfc_expr_attr (rvalue);
       if (!((rvalue->expr_type == EXPR_NULL)
            || (rvalue->expr_type == EXPR_FUNCTION && attr.proc_pointer)
+           || (rvalue->expr_type == EXPR_VARIABLE && attr.proc_pointer)
            || (rvalue->expr_type == EXPR_VARIABLE
                && attr.flavor == FL_PROCEDURE)))
        {
@@ -3146,9 +3153,28 @@ gfc_check_pointer_assign (gfc_expr *lvalue, gfc_expr *rvalue)
          gfc_error ("Abstract interface '%s' is invalid "
                     "in procedure pointer assignment at %L",
                     rvalue->symtree->name, &rvalue->where);
+         return FAILURE;
        }
+      /* Check for C727.  */
+      if (attr.flavor == FL_PROCEDURE)
+       {
+         if (attr.proc == PROC_ST_FUNCTION)
+           {
+             gfc_error ("Statement function '%s' is invalid "
+                        "in procedure pointer assignment at %L",
+                        rvalue->symtree->name, &rvalue->where);
+             return FAILURE;
+           }
+         if (attr.proc == PROC_INTERNAL &&
+             gfc_notify_std (GFC_STD_F2008, "Internal procedure '%s' is "
+                             "invalid in procedure pointer assignment at %L",
+                             rvalue->symtree->name, &rvalue->where) == FAILURE)
+           return FAILURE;
+       }
+      /* TODO: Enable interface check for PPCs.  */
+      if (is_proc_ptr_comp (rvalue, NULL))
+       return SUCCESS;
       if (rvalue->expr_type == EXPR_VARIABLE
-         && lvalue->symtree->n.sym->attr.if_source != IFSRC_UNKNOWN
          && !gfc_compare_interfaces (lvalue->symtree->n.sym,
                                      rvalue->symtree->n.sym, 0))
        {
@@ -3481,6 +3507,34 @@ gfc_expr_set_symbols_referenced (gfc_expr *expr)
 }
 
 
+/* Determine if an expression is a procedure pointer component. If yes, the
+   argument 'comp' will point to the component (provided that 'comp' was
+   provided).  */
+
+bool
+is_proc_ptr_comp (gfc_expr *expr, gfc_component **comp)
+{
+  gfc_ref *ref;
+  bool ppc = false;
+
+  if (!expr || !expr->ref)
+    return false;
+
+  ref = expr->ref;
+  while (ref->next)
+    ref = ref->next;
+
+  if (ref->type == REF_COMPONENT)
+    {
+      ppc = ref->u.c.component->attr.proc_pointer;
+      if (ppc && comp)
+       *comp = ref->u.c.component;
+    }
+
+  return ppc;
+}
+
+
 /* Walk an expression tree and check each variable encountered for being typed.
    If strict is not set, a top-level variable is tolerated untyped in -std=gnu
    mode as is a basic arithmetic expression using those; this is for things in