re PR fortran/59493 ([OOP] ICE: Segfault on Class(*) pointer association)

2013-12-18  Janus Weil  <janus@gcc.gnu.org>

	PR fortran/59493
	* gfortran.h (gfc_find_intrinsic_vtab): Removed prototype.
	(gfc_find_vtab): New prototype.
	* class.c (gfc_find_intrinsic_vtab): Rename to 'find_intrinsic_vtab' and
	make static. Minor modifications.
	(gfc_find_vtab): New function.
	(gfc_class_initializer): Use new function 'gfc_find_vtab'.
	* check.c (gfc_check_move_alloc): Ditto.
	* expr.c (gfc_check_pointer_assign): Ditto.
	* interface.c (compare_actual_formal): Ditto.
	* resolve.c (resolve_allocate_expr, resolve_select_type): Ditto.
	* trans-expr.c (gfc_conv_intrinsic_to_class, gfc_trans_class_assign):
	Ditto.
	* trans-intrinsic.c (conv_intrinsic_move_alloc): Ditto.
	* trans-stmt.c (gfc_trans_allocate): Ditto.

From-SVN: r206101

diff --git a/gcc/fortran/ChangeLog b/gcc/fortran/ChangeLog
index 1a81bfcc0ccbf3cf3344eb5e2fd1afd4e2f50f9c..2a1e1972e70f2fcefa2ce0abba52a3635e8ac42d 100644 (file)
--- a/gcc/fortran/ChangeLog
+++ b/gcc/fortran/ChangeLog
@@ -1,3 +1,21 @@
+2013-12-18  Janus Weil  <janus@gcc.gnu.org>
+
+       PR fortran/59493
+       * gfortran.h (gfc_find_intrinsic_vtab): Removed prototype.
+       (gfc_find_vtab): New prototype.
+       * class.c (gfc_find_intrinsic_vtab): Rename to 'find_intrinsic_vtab' and
+       make static. Minor modifications.
+       (gfc_find_vtab): New function.
+       (gfc_class_initializer): Use new function 'gfc_find_vtab'.
+       * check.c (gfc_check_move_alloc): Ditto.
+       * expr.c (gfc_check_pointer_assign): Ditto.
+       * interface.c (compare_actual_formal): Ditto.
+       * resolve.c (resolve_allocate_expr, resolve_select_type): Ditto.
+       * trans-expr.c (gfc_conv_intrinsic_to_class, gfc_trans_class_assign):
+       Ditto.
+       * trans-intrinsic.c (conv_intrinsic_move_alloc): Ditto.
+       * trans-stmt.c (gfc_trans_allocate): Ditto.
+
 2013-12-16  Janus Weil  <janus@gcc.gnu.org>
 
        PR fortran/54949

diff --git a/gcc/fortran/check.c b/gcc/fortran/check.c
index 1508c7447241d359cbdd6881ab3e14f1e8990cac..0064761e17087c2e230d25d0e9a1c7c26c2178ca 100644 (file)
--- a/gcc/fortran/check.c
+++ b/gcc/fortran/check.c
@@ -2858,12 +2858,7 @@ gfc_check_move_alloc (gfc_expr *from, gfc_expr *to)
 
   /* CLASS arguments: Make sure the vtab of from is present.  */
   if (to->ts.type == BT_CLASS && !UNLIMITED_POLY (from))
-    {
-      if (from->ts.type == BT_CLASS || from->ts.type == BT_DERIVED)
-       gfc_find_derived_vtab (from->ts.u.derived);
-      else
-       gfc_find_intrinsic_vtab (&from->ts);
-    }
+    gfc_find_vtab (&from->ts);
 
   return true;
 }

diff --git a/gcc/fortran/class.c b/gcc/fortran/class.c
index b65cd892b1d4d2ec74ffcc6ee669e1d9b253ff6f..5c3a4ec37fb4020ac6ab3fd7870ed41531396a01 100644 (file)
--- a/gcc/fortran/class.c
+++ b/gcc/fortran/class.c
@@ -423,18 +423,11 @@ gfc_class_initializer (gfc_typespec *ts, gfc_expr *init_expr)
   gfc_expr *init;
   gfc_component *comp;
   gfc_symbol *vtab = NULL;
-  bool is_unlimited_polymorphic;
 
-  is_unlimited_polymorphic = ts->u.derived
-      && ts->u.derived->components->ts.u.derived
-      && ts->u.derived->components->ts.u.derived->attr.unlimited_polymorphic;
-
-  if (is_unlimited_polymorphic && init_expr)
-    vtab = gfc_find_intrinsic_vtab (&ts->u.derived->components->ts);
-  else if (init_expr && init_expr->expr_type != EXPR_NULL)
-    vtab = gfc_find_derived_vtab (init_expr->ts.u.derived);
+  if (init_expr && init_expr->expr_type != EXPR_NULL)
+    vtab = gfc_find_vtab (&init_expr->ts);
   else
-    vtab = gfc_find_derived_vtab (ts->u.derived);
+    vtab = gfc_find_vtab (ts);
 
   init = gfc_get_structure_constructor_expr (ts->type, ts->kind,
                                             &ts->u.derived->declared_at);
@@ -2403,39 +2396,34 @@ yes:
 
 
 /* Find (or generate) the symbol for an intrinsic type's vtab.  This is
-   need to support unlimited polymorphism.  */
+   needed to support unlimited polymorphism.  */
 
-gfc_symbol *
-gfc_find_intrinsic_vtab (gfc_typespec *ts)
+static gfc_symbol *
+find_intrinsic_vtab (gfc_typespec *ts)
 {
   gfc_namespace *ns;
   gfc_symbol *vtab = NULL, *vtype = NULL, *found_sym = NULL;
   gfc_symbol *copy = NULL, *src = NULL, *dst = NULL;
   int charlen = 0;
 
-  if (ts->type == BT_CHARACTER && ts->deferred)
+  if (ts->type == BT_CHARACTER)
     {
-      gfc_error ("TODO: Deferred character length variable at %C cannot "
-                "yet be associated with unlimited polymorphic entities");
-      return NULL;
+      if (ts->deferred)
+       {
+         gfc_error ("TODO: Deferred character length variable at %C cannot "
+                    "yet be associated with unlimited polymorphic entities");
+         return NULL;
+       }
+      else if (ts->u.cl && ts->u.cl->length
+              && ts->u.cl->length->expr_type == EXPR_CONSTANT)
+       charlen = mpz_get_si (ts->u.cl->length->value.integer);
     }
 
-  if (ts->type == BT_UNKNOWN)
-    return NULL;
-
-  /* Sometimes the typespec is passed from a single call.  */
-  if (ts->type == BT_DERIVED || ts->type == BT_CLASS)
-    return gfc_find_derived_vtab (ts->u.derived);
-
   /* Find the top-level namespace.  */
   for (ns = gfc_current_ns; ns; ns = ns->parent)
     if (!ns->parent)
       break;
 
-  if (ts->type == BT_CHARACTER && ts->u.cl && ts->u.cl->length
-      && ts->u.cl->length->expr_type == EXPR_CONSTANT)
-    charlen = mpz_get_si (ts->u.cl->length->value.integer);
-
   if (ns)
     {
       char name[GFC_MAX_SYMBOL_LEN+1], tname[GFC_MAX_SYMBOL_LEN+1];
@@ -2636,6 +2624,25 @@ cleanup:
 }
 
 
+/*  Find (or generate) a vtab for an arbitrary type (derived or intrinsic).  */
+
+gfc_symbol *
+gfc_find_vtab (gfc_typespec *ts)
+{
+  switch (ts->type)
+    {
+    case BT_UNKNOWN:
+      return NULL;
+    case BT_DERIVED:
+      return gfc_find_derived_vtab (ts->u.derived);
+    case BT_CLASS:
+      return gfc_find_derived_vtab (ts->u.derived->components->ts.u.derived);
+    default:
+      return find_intrinsic_vtab (ts);
+    }
+}
+
+
 /* General worker function to find either a type-bound procedure or a
    type-bound user operator.  */
 

diff --git a/gcc/fortran/expr.c b/gcc/fortran/expr.c
index df96e5b4d351a0c743f76b055b01d0db35845e37..00a4beff62b60c8bd71f0cf1efedc213a3b2475e 100644 (file)
--- a/gcc/fortran/expr.c
+++ b/gcc/fortran/expr.c
@@ -3618,11 +3618,9 @@ gfc_check_pointer_assign (gfc_expr *lvalue, gfc_expr *rvalue)
       return false;
     }
 
-    /* Make sure the vtab is present.  */
-  if (lvalue->ts.type == BT_CLASS && rvalue->ts.type == BT_DERIVED)
-    gfc_find_derived_vtab (rvalue->ts.u.derived);
-  else if (UNLIMITED_POLY (lvalue) && !UNLIMITED_POLY (rvalue))
-    gfc_find_intrinsic_vtab (&rvalue->ts);
+  /* Make sure the vtab is present.  */
+  if (lvalue->ts.type == BT_CLASS && !UNLIMITED_POLY (rvalue))
+    gfc_find_vtab (&rvalue->ts);
 
   /* Check rank remapping.  */
   if (rank_remap)

diff --git a/gcc/fortran/gfortran.h b/gcc/fortran/gfortran.h
index ff3ffb5a1c3daa93bff094af9eb74e49fc7cccc4..03d9136d01bf8109a25901d805f3e0e8f50f1bc5 100644 (file)
--- a/gcc/fortran/gfortran.h
+++ b/gcc/fortran/gfortran.h
@@ -2990,7 +2990,7 @@ unsigned int gfc_hash_value (gfc_symbol *);
 bool gfc_build_class_symbol (gfc_typespec *, symbol_attribute *,
                                gfc_array_spec **, bool);
 gfc_symbol *gfc_find_derived_vtab (gfc_symbol *);
-gfc_symbol *gfc_find_intrinsic_vtab (gfc_typespec *);
+gfc_symbol *gfc_find_vtab (gfc_typespec *);
 gfc_symtree* gfc_find_typebound_proc (gfc_symbol*, bool*,
                                      const char*, bool, locus*);
 gfc_symtree* gfc_find_typebound_user_op (gfc_symbol*, bool*,

diff --git a/gcc/fortran/interface.c b/gcc/fortran/interface.c
index 1cd1c2b0e3a66e965a9c8a0be5bac99cef37bd14..243b0f12150e27f657a98d58980ea480a969bdf8 100644 (file)
--- a/gcc/fortran/interface.c
+++ b/gcc/fortran/interface.c
@@ -2606,7 +2606,7 @@ compare_actual_formal (gfc_actual_arglist **ap, gfc_formal_arglist *formal,
       if (UNLIMITED_POLY (f->sym)
          && a->expr->ts.type != BT_DERIVED
          && a->expr->ts.type != BT_CLASS)
-       gfc_find_intrinsic_vtab (&a->expr->ts);
+       gfc_find_vtab (&a->expr->ts);
 
       if (a->expr->expr_type == EXPR_NULL
          && ((f->sym->ts.type != BT_CLASS && !f->sym->attr.pointer

diff --git a/gcc/fortran/resolve.c b/gcc/fortran/resolve.c
index db2f5eb705af6abc90910b2e3a65b45265525227..57e6cbb979ed72108cab1fbd4b782d9ef75dfc6a 100644 (file)
--- a/gcc/fortran/resolve.c
+++ b/gcc/fortran/resolve.c
@@ -6930,10 +6930,7 @@ resolve_allocate_expr (gfc_expr *e, gfc_code *code)
 
       gcc_assert (ts);
 
-      if (ts->type == BT_CLASS || ts->type == BT_DERIVED)
-        gfc_find_derived_vtab (ts->u.derived);
-      else
-        gfc_find_intrinsic_vtab (ts);
+      gfc_find_vtab (ts);
 
       if (dimension)
        e = gfc_expr_to_initialize (e);
@@ -8054,7 +8051,7 @@ resolve_select_type (gfc_code *code, gfc_namespace *old_ns)
          gfc_symbol *ivtab;
          gfc_expr *e;
 
-         ivtab = gfc_find_intrinsic_vtab (&c->ts);
+         ivtab = gfc_find_vtab (&c->ts);
          gcc_assert (ivtab && CLASS_DATA (ivtab)->initializer);
          e = CLASS_DATA (ivtab)->initializer;
          c->low = c->high = gfc_copy_expr (e);

diff --git a/gcc/fortran/trans-expr.c b/gcc/fortran/trans-expr.c
index 62ba93203cd3f0ef7a866e203d7fc7daa09f5064..d6498ae607a8d29fa6a3f271ff6fc3cdcd23da13 100644 (file)
--- a/gcc/fortran/trans-expr.c
+++ b/gcc/fortran/trans-expr.c
@@ -558,7 +558,7 @@ gfc_conv_intrinsic_to_class (gfc_se *parmse, gfc_expr *e,
   /* Set the vptr.  */
   ctree =  gfc_class_vptr_get (var);
 
-  vtab = gfc_find_intrinsic_vtab (&e->ts);
+  vtab = gfc_find_vtab (&e->ts);
   gcc_assert (vtab);
   tmp = gfc_build_addr_expr (NULL_TREE, gfc_get_symbol_decl (vtab));
   gfc_add_modify (&parmse->pre, ctree,
@@ -1015,12 +1015,10 @@ gfc_trans_class_assign (gfc_expr *expr1, gfc_expr *expr2, gfc_exec_op op)
          goto assign_vptr;
        }
 
-      if (expr2->ts.type == BT_DERIVED)
-       vtab = gfc_find_derived_vtab (expr2->ts.u.derived);
-      else if (expr2->expr_type == EXPR_NULL)
-       vtab = gfc_find_derived_vtab (expr1->ts.u.derived);
+      if (expr2->expr_type == EXPR_NULL)
+       vtab = gfc_find_vtab (&expr1->ts);
       else
-       vtab = gfc_find_intrinsic_vtab (&expr2->ts);
+       vtab = gfc_find_vtab (&expr2->ts);
       gcc_assert (vtab);
 
       rhs = gfc_get_expr ();

diff --git a/gcc/fortran/trans-intrinsic.c b/gcc/fortran/trans-intrinsic.c
index 4acdc8dc7564ed73a5670079a39b16cf3ab0d7fb..1f5d6154befafc6d7c2821791a692bf74c526481 100644 (file)
--- a/gcc/fortran/trans-intrinsic.c
+++ b/gcc/fortran/trans-intrinsic.c
@@ -7657,10 +7657,7 @@ conv_intrinsic_move_alloc (gfc_code *code)
            }
          else
            {
-             if (from_expr->ts.type != BT_DERIVED)
-               vtab = gfc_find_intrinsic_vtab (&from_expr->ts);
-             else
-               vtab = gfc_find_derived_vtab (from_expr->ts.u.derived);
+             vtab = gfc_find_vtab (&from_expr->ts);
              gcc_assert (vtab);
              tmp = gfc_build_addr_expr (NULL_TREE, gfc_get_symbol_decl (vtab));
              gfc_add_modify_loc (input_location, &block, to_se.expr,
@@ -7714,10 +7711,7 @@ conv_intrinsic_move_alloc (gfc_code *code)
        }
       else
        {
-         if (from_expr->ts.type != BT_DERIVED)
-           vtab = gfc_find_intrinsic_vtab (&from_expr->ts);
-         else
-           vtab = gfc_find_derived_vtab (from_expr->ts.u.derived);
+         vtab = gfc_find_vtab (&from_expr->ts);
          gcc_assert (vtab);
          tmp = gfc_build_addr_expr (NULL_TREE, gfc_get_symbol_decl (vtab));
          gfc_add_modify_loc (input_location, &block, to_se.expr,

diff --git a/gcc/fortran/trans-stmt.c b/gcc/fortran/trans-stmt.c
index 4f211975581e39b1c0c1e96f7b25e1b56df68e0c..51d037e90f9acbe90f0664b356898fb1092ab0d6 100644 (file)
--- a/gcc/fortran/trans-stmt.c
+++ b/gcc/fortran/trans-stmt.c
@@ -5144,10 +5144,7 @@ gfc_trans_allocate (gfc_code * code)
 
              if (ts->type == BT_DERIVED || UNLIMITED_POLY (e))
                {
-                 if (ts->type == BT_DERIVED)
-                 vtab = gfc_find_derived_vtab (ts->u.derived);
-                 else
-                   vtab = gfc_find_intrinsic_vtab (ts);
+                 vtab = gfc_find_vtab (ts);
                  gcc_assert (vtab);
                  gfc_init_se (&lse, NULL);
                  lse.want_pointer = 1;
@@ -5232,12 +5229,8 @@ gfc_trans_allocate (gfc_code * code)
                  ppc = gfc_copy_expr (rhs);
                  gfc_add_vptr_component (ppc);
                }
-             else if (rhs->ts.type == BT_DERIVED)
-               ppc = gfc_lval_expr_from_sym
-                               (gfc_find_derived_vtab (rhs->ts.u.derived));
              else
-               ppc = gfc_lval_expr_from_sym
-                               (gfc_find_intrinsic_vtab (&rhs->ts));
+               ppc = gfc_lval_expr_from_sym (gfc_find_vtab (&rhs->ts));
              gfc_add_component_ref (ppc, "_copy");
 
              ppc_code = gfc_get_code (EXEC_CALL);