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

1 files changed, 35 insertions, 28 deletions

diff --git a/gcc/fortran/class.c b/gcc/fortran/class.c
index b65cd89..5c3a4ec 100644
--- 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.  */