[Patch, Fortran, OOP] PR 60232: The rank of the element in the structure constructor does not match that of the component

[Janus Weil]

Hi all,

here is a small patch for an OOP-related rejects-valid problem, which
is technically not a regression, but I hope the patch is simple enough
to still make it into trunk.

The problem is this: When using a dimensionful function as an
EXPR_VARIABLE (e.g. as the target in a procedure pointer assignment),
we wrongly add a REF_ARRAY, because we are tricked to believe that the
expression is dimensionful (which is not the case). In the test case
at hand this problem appears in an OOP context, where we have a
dimensionful type-bound procedure, which then appears as the target to
the corresponding procedure-pointer component in the vtab.

The patch was regtested on x86_64-unknown-linux-gnu. Ok for trunk?

Cheers,
Janus


2014-02-19  Janus Weil  <ja...@gcc.gnu.org>

    PR fortran/60232
    * expr.c (gfc_get_variable_expr): Don't add REF_ARRAY for dimensionful
    functions, which are used as procedure pointer target.


2014-02-19  Janus Weil  <ja...@gcc.gnu.org>

    PR fortran/60232
    * gfortran.dg/typebound_proc_33.f90: New.

Index: gcc/fortran/expr.c
===================================================================
--- gcc/fortran/expr.c  (revision 207846)
+++ gcc/fortran/expr.c  (working copy)
@@ -3962,9 +3962,10 @@ gfc_get_variable_expr (gfc_symtree *var)
   e->symtree = var;
   e->ts = var->n.sym->ts;
 
-  if ((var->n.sym->as != NULL && var->n.sym->ts.type != BT_CLASS)
-      || (var->n.sym->ts.type == BT_CLASS && CLASS_DATA (var->n.sym)
-         && CLASS_DATA (var->n.sym)->as))
+  if (var->n.sym->attr.flavor != FL_PROCEDURE
+      && ((var->n.sym->as != NULL && var->n.sym->ts.type != BT_CLASS)
+          || (var->n.sym->ts.type == BT_CLASS && CLASS_DATA (var->n.sym)
+              && CLASS_DATA (var->n.sym)->as)))
     {
       e->rank = var->n.sym->ts.type == BT_CLASS
                ? CLASS_DATA (var->n.sym)->as->rank : var->n.sym->as->rank;

! { dg-do compile }
!
! PR 60232: [OOP] The rank of the element in the structure constructor does not match that of the component
!
! Contributed by Antony Lewis <ant...@cosmologist.info>

module ObjectLists
  implicit none

  Type TObjectList
  contains
    procedure :: ArrayItem
  end Type

contains

  function ArrayItem(L) result(P)
    Class(TObjectList) :: L
    Class(TObjectList), pointer :: P(:)
  end function

end module


  use ObjectLists
  implicit none

  Type, extends(TObjectList):: TSampleList
  end Type

contains

  subroutine TSampleList_ConfidVal(L)
    Class(TSampleList) :: L
  end subroutine

end

! { dg-final { cleanup-modules "ObjectLists" } }