trans-expr.c (gfc_conv_procedure_call): Fix handling of polymorphic arguments.

2012-07-19  Tobias Burnus  <burnus@net-b.de>

        * trans-expr.c (gfc_conv_procedure_call): Fix handling
        of polymorphic arguments.
        * resolve.c (resolve_formal_arglist): Ditto, mark polymorphic
        assumed-shape arrays as such.

From-SVN: r189678

diff --git a/gcc/fortran/ChangeLog b/gcc/fortran/ChangeLog
index 3d6bf6dce96216f4539dd93e2371c23a98fa1f4c..6100796aaaedde20f64a2164963feb2bd7ba0752 100644 (file)
--- a/gcc/fortran/ChangeLog
+++ b/gcc/fortran/ChangeLog
@@ -1,3 +1,10 @@
+2012-07-19  Tobias Burnus  <burnus@net-b.de>
+
+       * trans-expr.c (gfc_conv_procedure_call): Fix handling
+       of polymorphic arguments.
+       * resolve.c (resolve_formal_arglist): Ditto, mark polymorphic
+       assumed-shape arrays as such.
+
 2012-07-19  Tobias Burnus  <burnus@net-b.de>
 
        * interface.c (compare_parameter, compare_actual_formal): Fix

diff --git a/gcc/fortran/resolve.c b/gcc/fortran/resolve.c
index 73a9731c0cfbbdc31f9a092e4d2580465d4666df..753f1c7939fdf563ab5f592e466a8fb2bdc29ef8 100644 (file)
--- a/gcc/fortran/resolve.c
+++ b/gcc/fortran/resolve.c
@@ -251,6 +251,7 @@ resolve_formal_arglist (gfc_symbol *proc)
   for (f = proc->formal; f; f = f->next)
     {
       sym = f->sym;
+      gfc_array_spec *as;
 
       if (sym == NULL)
        {
@@ -284,23 +285,33 @@ resolve_formal_arglist (gfc_symbol *proc)
            gfc_set_default_type (sym, 1, sym->ns);
        }
 
-      gfc_resolve_array_spec (sym->as, 0);
+      as = sym->ts.type == BT_CLASS && sym->attr.class_ok
+          ? CLASS_DATA (sym)->as : sym->as;
+
+      gfc_resolve_array_spec (as, 0);
 
       /* We can't tell if an array with dimension (:) is assumed or deferred
         shape until we know if it has the pointer or allocatable attributes.
       */
-      if (sym->as && sym->as->rank > 0 && sym->as->type == AS_DEFERRED
-         && !(sym->attr.pointer || sym->attr.allocatable)
+      if (as && as->rank > 0 && as->type == AS_DEFERRED
+         && ((sym->ts.type != BT_CLASS
+              && !(sym->attr.pointer || sym->attr.allocatable))
+              || (sym->ts.type == BT_CLASS
+                 && !(CLASS_DATA (sym)->attr.class_pointer
+                      || CLASS_DATA (sym)->attr.allocatable)))
          && sym->attr.flavor != FL_PROCEDURE)
        {
-         sym->as->type = AS_ASSUMED_SHAPE;
-         for (i = 0; i < sym->as->rank; i++)
-           sym->as->lower[i] = gfc_get_int_expr (gfc_default_integer_kind,
-                                                 NULL, 1);
+         as->type = AS_ASSUMED_SHAPE;
+         for (i = 0; i < as->rank; i++)
+           as->lower[i] = gfc_get_int_expr (gfc_default_integer_kind, NULL, 1);
        }
 
-      if ((sym->as && sym->as->rank > 0 && sym->as->type == AS_ASSUMED_SHAPE)
+      if ((as && as->rank > 0 && as->type == AS_ASSUMED_SHAPE)
          || sym->attr.pointer || sym->attr.allocatable || sym->attr.target
+         || (sym->ts.type == BT_CLASS && sym->attr.class_ok
+             && (CLASS_DATA (sym)->attr.class_pointer
+                 || CLASS_DATA (sym)->attr.allocatable
+                 || CLASS_DATA (sym)->attr.target))
          || sym->attr.optional)
        {
          proc->attr.always_explicit = 1;

diff --git a/gcc/fortran/trans-expr.c b/gcc/fortran/trans-expr.c
index 34e0f699cd253c2233c85be28ab1fe517e8413aa..17964bb2c6404d86971ef409be77779f169e1f99 100644 (file)
--- a/gcc/fortran/trans-expr.c
+++ b/gcc/fortran/trans-expr.c
@@ -3620,10 +3620,15 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym,
                parmse.string_length = build_int_cst (gfc_charlen_type_node, 0);
            }
        }
-      else if (arg->expr->expr_type == EXPR_NULL && fsym && !fsym->attr.pointer)
+      else if (arg->expr->expr_type == EXPR_NULL
+              && fsym && !fsym->attr.pointer
+              && (fsym->ts.type != BT_CLASS
+                  || !CLASS_DATA (fsym)->attr.class_pointer))
        {
          /* Pass a NULL pointer to denote an absent arg.  */
-         gcc_assert (fsym->attr.optional && !fsym->attr.allocatable);
+         gcc_assert (fsym->attr.optional && !fsym->attr.allocatable
+                     && (fsym->ts.type != BT_CLASS
+                         || !CLASS_DATA (fsym)->attr.allocatable));
          gfc_init_se (&parmse, NULL);
          parmse.expr = null_pointer_node;
          if (arg->missing_arg_type == BT_CHARACTER)