PR fortran/36031

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

diff --git a/gcc/fortran/primary.c b/gcc/fortran/primary.c
index cab8f82..96fbddc 100644 (file)
--- a/gcc/fortran/primary.c
+++ b/gcc/fortran/primary.c
@@ -1708,10 +1708,13 @@ extend_ref (gfc_expr *primary, gfc_ref *tail)
    variable like member references or substrings.  If equiv_flag is
    set we only match stuff that is allowed inside an EQUIVALENCE
    statement.  sub_flag tells whether we expect a type-bound procedure found
-   to be a subroutine as part of CALL or a FUNCTION.  */
+   to be a subroutine as part of CALL or a FUNCTION. For procedure pointer
+   components, 'ppc_arg' determines whether the PPC may be called (with an
+   argument list), or whether it may just be referred to as a pointer.  */
 
 match
-gfc_match_varspec (gfc_expr *primary, int equiv_flag, bool sub_flag)
+gfc_match_varspec (gfc_expr *primary, int equiv_flag, bool sub_flag,
+                  bool ppc_arg)
 {
   char name[GFC_MAX_SYMBOL_LEN + 1];
   gfc_ref *substring, *tail;
@@ -1754,7 +1757,7 @@ gfc_match_varspec (gfc_expr *primary, int equiv_flag, bool sub_flag)
     return MATCH_YES;
 
   if (sym->ts.type == BT_UNKNOWN && gfc_peek_ascii_char () == '%'
-      && gfc_get_default_type (sym, sym->ns)->type == BT_DERIVED)
+      && gfc_get_default_type (sym->name, sym->ns)->type == BT_DERIVED)
     gfc_set_default_type (sym, 0, sym->ns);
 
   if (sym->ts.type != BT_DERIVED || gfc_match_char ('%') != MATCH_YES)
@@ -1784,19 +1787,19 @@ gfc_match_varspec (gfc_expr *primary, int equiv_flag, bool sub_flag)
          gcc_assert (!tail || !tail->next);
          gcc_assert (primary->expr_type == EXPR_VARIABLE);
 
-         if (tbp->typebound->is_generic)
+         if (tbp->n.tb->is_generic)
            tbp_sym = NULL;
          else
-           tbp_sym = tbp->typebound->u.specific->n.sym;
+           tbp_sym = tbp->n.tb->u.specific->n.sym;
 
          primary->expr_type = EXPR_COMPCALL;
-         primary->value.compcall.tbp = tbp->typebound;
+         primary->value.compcall.tbp = tbp->n.tb;
          primary->value.compcall.name = tbp->name;
          gcc_assert (primary->symtree->n.sym->attr.referenced);
          if (tbp_sym)
            primary->ts = tbp_sym->ts;
 
-         m = gfc_match_actual_arglist (tbp->typebound->subroutine,
+         m = gfc_match_actual_arglist (tbp->n.tb->subroutine,
                                        &primary->value.compcall.actual);
          if (m == MATCH_ERROR)
            return MATCH_ERROR;
@@ -1811,8 +1814,6 @@ gfc_match_varspec (gfc_expr *primary, int equiv_flag, bool sub_flag)
                }
            }
 
-         gfc_set_sym_referenced (tbp->n.sym);
-
          break;
        }
 
@@ -1828,6 +1829,20 @@ gfc_match_varspec (gfc_expr *primary, int equiv_flag, bool sub_flag)
 
       primary->ts = component->ts;
 
+      if (component->attr.proc_pointer && ppc_arg
+         && !gfc_matching_procptr_assignment)
+       {
+         primary->expr_type = EXPR_PPC;
+         m = gfc_match_actual_arglist (component->attr.subroutine,
+                                       &primary->value.compcall.actual);
+         if (m == MATCH_ERROR)
+           return MATCH_ERROR;
+         if (m == MATCH_NO)
+           primary->value.compcall.actual = NULL;
+
+          break;
+       }
+
       if (component->as != NULL)
        {
          tail = extend_ref (primary, tail);
@@ -1849,7 +1864,7 @@ check_substring:
   unknown = false;
   if (primary->ts.type == BT_UNKNOWN)
     {
-      if (gfc_get_default_type (sym, sym->ns)->type == BT_CHARACTER)
+      if (gfc_get_default_type (sym->name, sym->ns)->type == BT_CHARACTER)
        {
         gfc_set_default_type (sym, 0, sym->ns);
         primary->ts = sym->ts;
@@ -1927,7 +1942,7 @@ gfc_variable_attr (gfc_expr *expr, gfc_typespec *ts)
   allocatable = attr.allocatable;
 
   target = attr.target;
-  if (pointer)
+  if (pointer || attr.proc_pointer)
     target = 1;
 
   if (ts != NULL && expr->ts.type == BT_UNKNOWN)
@@ -1973,7 +1988,7 @@ gfc_variable_attr (gfc_expr *expr, gfc_typespec *ts)
 
        pointer = ref->u.c.component->attr.pointer;
        allocatable = ref->u.c.component->attr.allocatable;
-       if (pointer)
+       if (pointer || attr.proc_pointer)
          target = 1;
 
        break;
@@ -2480,7 +2495,7 @@ gfc_match_rvalue (gfc_expr **result)
       e->expr_type = EXPR_VARIABLE;
       e->symtree = symtree;
 
-      m = gfc_match_varspec (e, 0, false);
+      m = gfc_match_varspec (e, 0, false, true);
       break;
 
     case FL_PARAMETER:
@@ -2497,7 +2512,7 @@ gfc_match_rvalue (gfc_expr **result)
        }
 
       e->symtree = symtree;
-      m = gfc_match_varspec (e, 0, false);
+      m = gfc_match_varspec (e, 0, false, true);
 
       if (sym->ts.is_c_interop || sym->ts.is_iso_c)
        break;
@@ -2553,7 +2568,7 @@ gfc_match_rvalue (gfc_expr **result)
          e = gfc_get_expr ();
          e->expr_type = EXPR_VARIABLE;
          e->symtree = symtree;
-         m = gfc_match_varspec (e, 0, false);
+         m = gfc_match_varspec (e, 0, false, true);
          break;
        }
 
@@ -2580,7 +2595,7 @@ gfc_match_rvalue (gfc_expr **result)
          e->symtree = symtree;
          e->expr_type = EXPR_VARIABLE;
 
-         m = gfc_match_varspec (e, 0, false);
+         m = gfc_match_varspec (e, 0, false, true);
          break;
        }
 
@@ -2660,7 +2675,7 @@ gfc_match_rvalue (gfc_expr **result)
 
       if (gfc_peek_ascii_char () == '%'
          && sym->ts.type == BT_UNKNOWN
-         && gfc_get_default_type (sym, sym->ns)->type == BT_DERIVED)
+         && gfc_get_default_type (sym->name, sym->ns)->type == BT_DERIVED)
        gfc_set_default_type (sym, 0, sym->ns);
 
       /* If the symbol has a dimension attribute, the expression is a
@@ -2678,7 +2693,7 @@ gfc_match_rvalue (gfc_expr **result)
          e = gfc_get_expr ();
          e->symtree = symtree;
          e->expr_type = EXPR_VARIABLE;
-         m = gfc_match_varspec (e, 0, false);
+         m = gfc_match_varspec (e, 0, false, true);
          break;
        }
 
@@ -2703,7 +2718,7 @@ gfc_match_rvalue (gfc_expr **result)
 
          /*FIXME:??? gfc_match_varspec does set this for us: */
          e->ts = sym->ts;
-         m = gfc_match_varspec (e, 0, false);
+         m = gfc_match_varspec (e, 0, false, true);
          break;
        }
 
@@ -2727,7 +2742,7 @@ gfc_match_rvalue (gfc_expr **result)
          implicit_char = false;
          if (sym->ts.type == BT_UNKNOWN)
            {
-             ts = gfc_get_default_type (sym,NULL);
+             ts = gfc_get_default_type (sym->name, NULL);
              if (ts->type == BT_CHARACTER)
                implicit_char = true;
            }
@@ -2792,7 +2807,7 @@ gfc_match_rvalue (gfc_expr **result)
       /* If our new function returns a character, array or structure
         type, it might have subsequent references.  */
 
-      m = gfc_match_varspec (e, 0, false);
+      m = gfc_match_varspec (e, 0, false, true);
       if (m == MATCH_NO)
        m = MATCH_YES;
 
@@ -2965,7 +2980,7 @@ match_variable (gfc_expr **result, int equiv_flag, int host_flag)
        
       if (gfc_peek_ascii_char () == '%'
          && sym->ts.type == BT_UNKNOWN
-         && gfc_get_default_type (sym, implicit_ns)->type == BT_DERIVED)
+         && gfc_get_default_type (sym->name, implicit_ns)->type == BT_DERIVED)
        gfc_set_default_type (sym, 0, implicit_ns);
     }
 
@@ -2977,7 +2992,7 @@ match_variable (gfc_expr **result, int equiv_flag, int host_flag)
   expr->where = where;
 
   /* Now see if we have to do more.  */
-  m = gfc_match_varspec (expr, equiv_flag, false);
+  m = gfc_match_varspec (expr, equiv_flag, false, false);
   if (m != MATCH_YES)
     {
       gfc_free_expr (expr);