gcc-7.1.0gcc-7.1.0

1 files changed, 159 insertions, 54 deletions

diff --git a/gcc/fortran/class.c b/gcc/fortran/class.c
index 3627828d21..2d72e9570d 100644
--- a/gcc/fortran/class.c
+++ b/gcc/fortran/class.c
@@ -1,5 +1,5 @@
 /* Implementation of Fortran 2003 Polymorphism.
-   Copyright (C) 2009-2016 Free Software Foundation, Inc.
+   Copyright (C) 2009-2017 Free Software Foundation, Inc.
    Contributed by Paul Richard Thomas <pault@gcc.gnu.org>
    and Janus Weil <janus@gcc.gnu.org>
 
@@ -224,7 +224,8 @@ gfc_add_component_ref (gfc_expr *e, const char *name)
 	break;
       tail = &((*tail)->next);
     }
-  if (derived->components->next->ts.type == BT_DERIVED &&
+  if (derived->components && derived->components->next &&
+      derived->components->next->ts.type == BT_DERIVED &&
       derived->components->next->ts.u.derived == NULL)
     {
       /* Fix up missing vtype.  */
@@ -238,12 +239,14 @@ gfc_add_component_ref (gfc_expr *e, const char *name)
     /* Avoid losing memory.  */
     gfc_free_ref_list (*tail);
   c = gfc_find_component (derived, name, true, true, tail);
-  gcc_assert (c);
-  for (ref = *tail; ref->next; ref = ref->next)
-    ;
-  ref->next = next;
-  if (!next)
-    e->ts = c->ts;
+
+  if (c) {
+    for (ref = *tail; ref->next; ref = ref->next)
+      ;
+    ref->next = next;
+    if (!next)
+      e->ts = c->ts;
+  }
 }
 
 
@@ -257,7 +260,7 @@ gfc_add_class_array_ref (gfc_expr *e)
   int rank = CLASS_DATA (e)->as->rank;
   gfc_array_spec *as = CLASS_DATA (e)->as;
   gfc_ref *ref = NULL;
-  gfc_add_component_ref (e, "_data");
+  gfc_add_data_component (e);
   e->rank = rank;
   for (ref = e->ref; ref; ref = ref->next)
     if (!ref->next)
@@ -375,7 +378,8 @@ gfc_is_class_scalar_expr (gfc_expr *e)
 	&& CLASS_DATA (e->symtree->n.sym)
 	&& !CLASS_DATA (e->symtree->n.sym)->attr.dimension
 	&& (e->ref == NULL
-	    || (strcmp (e->ref->u.c.component->name, "_data") == 0
+	    || (e->ref->type == REF_COMPONENT
+		&& strcmp (e->ref->u.c.component->name, "_data") == 0
 		&& e->ref->next == NULL)))
     return true;
 
@@ -387,7 +391,8 @@ gfc_is_class_scalar_expr (gfc_expr *e)
 	    && CLASS_DATA (ref->u.c.component)
 	    && !CLASS_DATA (ref->u.c.component)->attr.dimension
 	    && (ref->next == NULL
-		|| (strcmp (ref->next->u.c.component->name, "_data") == 0
+		|| (ref->next->type == REF_COMPONENT
+		    && strcmp (ref->next->u.c.component->name, "_data") == 0
 		    && ref->next->next == NULL)))
 	return true;
     }
@@ -582,7 +587,7 @@ gfc_get_len_component (gfc_expr *e)
       ref = ref->next;
     }
   /* And replace if with a ref to the _len component.  */
-  gfc_add_component_ref (ptr, "_len");
+  gfc_add_len_component (ptr);
   return ptr;
 }
 
@@ -705,7 +710,7 @@ gfc_build_class_symbol (gfc_typespec *ts, symbol_attribute *attr,
 	  if (!gfc_add_component (fclass, "_len", &c))
 	    return false;
 	  c->ts.type = BT_INTEGER;
-	  c->ts.kind = 4;
+	  c->ts.kind = gfc_charlen_int_kind;
 	  c->attr.access = ACCESS_PRIVATE;
 	  c->attr.artificial = 1;
 	}
@@ -746,7 +751,7 @@ add_proc_comp (gfc_symbol *vtype, const char *name, gfc_typebound_proc *tb)
 {
   gfc_component *c;
 
-  if (tb->non_overridable)
+  if (tb->non_overridable && !tb->overridden)
     return;
 
   c = gfc_find_component (vtype, name, true, true, NULL);
@@ -836,20 +841,19 @@ has_finalizer_component (gfc_symbol *derived)
    gfc_component *c;
 
   for (c = derived->components; c; c = c->next)
-    {
-      if (c->ts.type == BT_DERIVED && c->ts.u.derived->f2k_derived
-	  && c->ts.u.derived->f2k_derived->finalizers)
-	return true;
-
-      /* Stop infinite recursion through this function by inhibiting
-	 calls when the derived type and that of the component are
-	 the same.  */
-      if (c->ts.type == BT_DERIVED
-	  && !gfc_compare_derived_types (derived, c->ts.u.derived)
-	  && !c->attr.pointer && !c->attr.allocatable
-	  && has_finalizer_component (c->ts.u.derived))
-	return true;
-    }
+    if (c->ts.type == BT_DERIVED && !c->attr.pointer && !c->attr.allocatable)
+      {
+	if (c->ts.u.derived->f2k_derived
+	    && c->ts.u.derived->f2k_derived->finalizers)
+	  return true;
+
+	/* Stop infinite recursion through this function by inhibiting
+	  calls when the derived type and that of the component are
+	  the same.  */
+	if (!gfc_compare_derived_types (derived, c->ts.u.derived)
+	    && has_finalizer_component (c->ts.u.derived))
+	  return true;
+      }
   return false;
 }
 
@@ -960,6 +964,7 @@ finalize_component (gfc_expr *expr, gfc_symbol *derived, gfc_component *comp,
       cond->block = gfc_get_code (EXEC_IF);
       cond->block->expr1 = gfc_get_expr ();
       cond->block->expr1->expr_type = EXPR_FUNCTION;
+      cond->block->expr1->where = gfc_current_locus;
       gfc_get_sym_tree ("associated", sub_ns, &cond->block->expr1->symtree, false);
       cond->block->expr1->symtree->n.sym->attr.flavor = FL_PROCEDURE;
       cond->block->expr1->symtree->n.sym->attr.intrinsic = 1;
@@ -1072,6 +1077,7 @@ finalization_scalarizer (gfc_symbol *array, gfc_symbol *ptr,
   gfc_commit_symbol (expr->symtree->n.sym);
   expr->ts.type = BT_INTEGER;
   expr->ts.kind = gfc_index_integer_kind;
+  expr->where = gfc_current_locus;
 
   /* TRANSFER.  */
   expr2 = gfc_build_intrinsic_call (sub_ns, GFC_ISYM_TRANSFER, "transfer",
@@ -1088,6 +1094,7 @@ finalization_scalarizer (gfc_symbol *array, gfc_symbol *ptr,
   block->ext.actual->expr->value.op.op1 = expr2;
   block->ext.actual->expr->value.op.op2 = offset;
   block->ext.actual->expr->ts = expr->ts;
+  block->ext.actual->expr->where = gfc_current_locus;
 
   /* C_F_POINTER's 2nd arg: ptr -- and its absent shape=.  */
   block->ext.actual->next = gfc_get_actual_arglist ();
@@ -1144,6 +1151,7 @@ finalization_get_offset (gfc_symbol *idx, gfc_symbol *idx2, gfc_symbol *offset,
   expr->ref->u.ar.dimen = 1;
   expr->ref->u.ar.dimen_type[0] = DIMEN_ELEMENT;
   expr->ref->u.ar.start[0] = gfc_lval_expr_from_sym (idx2);
+  expr->where = sizes->declared_at;
 
   expr = gfc_build_intrinsic_call (sub_ns, GFC_ISYM_MOD, "mod",
 				   gfc_current_locus, 2,
@@ -1164,6 +1172,7 @@ finalization_get_offset (gfc_symbol *idx, gfc_symbol *idx2, gfc_symbol *offset,
   expr2->value.op.op2->ref->u.ar.dimen_type[0] = DIMEN_ELEMENT;
   expr2->value.op.op2->ref->u.ar.start[0] = gfc_get_expr ();
   expr2->value.op.op2->ref->u.ar.start[0]->expr_type = EXPR_OP;
+  expr2->value.op.op2->ref->u.ar.start[0]->where = gfc_current_locus;
   expr2->value.op.op2->ref->u.ar.start[0]->value.op.op = INTRINSIC_MINUS;
   expr2->value.op.op2->ref->u.ar.start[0]->value.op.op1
 	= gfc_lval_expr_from_sym (idx2);
@@ -1172,6 +1181,7 @@ finalization_get_offset (gfc_symbol *idx, gfc_symbol *idx2, gfc_symbol *offset,
   expr2->value.op.op2->ref->u.ar.start[0]->ts
 	= expr2->value.op.op2->ref->u.ar.start[0]->value.op.op1->ts;
   expr2->ts = idx->ts;
+  expr2->where = gfc_current_locus;
 
   /* ... * strides(idx2).  */
   expr = gfc_get_expr ();
@@ -1187,6 +1197,7 @@ finalization_get_offset (gfc_symbol *idx, gfc_symbol *idx2, gfc_symbol *offset,
   expr->value.op.op2->ref->u.ar.start[0] = gfc_lval_expr_from_sym (idx2);
   expr->value.op.op2->ref->u.ar.as = strides->as;
   expr->ts = idx->ts;
+  expr->where = gfc_current_locus;
 
   /* offset = offset + ...  */
   block->block->next = gfc_get_code (EXEC_ASSIGN);
@@ -1197,6 +1208,7 @@ finalization_get_offset (gfc_symbol *idx, gfc_symbol *idx2, gfc_symbol *offset,
   block->block->next->expr2->value.op.op1 = gfc_lval_expr_from_sym (offset);
   block->block->next->expr2->value.op.op2 = expr;
   block->block->next->expr2->ts = idx->ts;
+  block->block->next->expr2->where = gfc_current_locus;
 
   /* After the loop:  offset = offset * byte_stride.  */
   block->next = gfc_get_code (EXEC_ASSIGN);
@@ -1208,6 +1220,7 @@ finalization_get_offset (gfc_symbol *idx, gfc_symbol *idx2, gfc_symbol *offset,
   block->expr2->value.op.op1 = gfc_lval_expr_from_sym (offset);
   block->expr2->value.op.op2 = gfc_lval_expr_from_sym (byte_stride);
   block->expr2->ts = block->expr2->value.op.op1->ts;
+  block->expr2->where = gfc_current_locus;
   return block;
 }
 
@@ -1345,6 +1358,8 @@ finalizer_insert_packed_call (gfc_code *block, gfc_finalizer *fini,
   block->next->resolved_sym = fini->proc_tree->n.sym;
   block->next->ext.actual = gfc_get_actual_arglist ();
   block->next->ext.actual->expr = gfc_lval_expr_from_sym (array);
+  block->next->ext.actual->next = gfc_get_actual_arglist ();
+  block->next->ext.actual->next->expr = gfc_copy_expr (size_expr);
 
   /* ELSE.  */
 
@@ -1415,6 +1430,7 @@ finalizer_insert_packed_call (gfc_code *block, gfc_finalizer *fini,
   /* Offset calculation for the new array: idx * size of type (in bytes).  */
   offset2 = gfc_get_expr ();
   offset2->expr_type = EXPR_OP;
+  offset2->where = gfc_current_locus;
   offset2->value.op.op = INTRINSIC_TIMES;
   offset2->value.op.op1 = gfc_lval_expr_from_sym (idx);
   offset2->value.op.op2 = gfc_copy_expr (size_expr);
@@ -1597,6 +1613,7 @@ generate_finalization_wrapper (gfc_symbol *derived, gfc_namespace *ns,
   final->attr.flavor = FL_PROCEDURE;
   final->attr.function = 1;
   final->attr.pure = 0;
+  final->attr.recursive = 1;
   final->result = final;
   final->ts.type = BT_INTEGER;
   final->ts.kind = 4;
@@ -1819,6 +1836,7 @@ generate_finalization_wrapper (gfc_symbol *derived, gfc_namespace *ns,
   block->expr2 = gfc_get_expr ();
   block->expr2->expr_type = EXPR_OP;
   block->expr2->value.op.op = INTRINSIC_TIMES;
+  block->expr2->where = gfc_current_locus;
 
   /* sizes(idx-1).  */
   block->expr2->value.op.op1 = gfc_lval_expr_from_sym (sizes);
@@ -1830,6 +1848,7 @@ generate_finalization_wrapper (gfc_symbol *derived, gfc_namespace *ns,
   block->expr2->value.op.op1->ref->u.ar.dimen_type[0] = DIMEN_ELEMENT;
   block->expr2->value.op.op1->ref->u.ar.start[0] = gfc_get_expr ();
   block->expr2->value.op.op1->ref->u.ar.start[0]->expr_type = EXPR_OP;
+  block->expr2->value.op.op1->ref->u.ar.start[0]->where = gfc_current_locus;
   block->expr2->value.op.op1->ref->u.ar.start[0]->value.op.op = INTRINSIC_MINUS;
   block->expr2->value.op.op1->ref->u.ar.start[0]->value.op.op1
 	= gfc_lval_expr_from_sym (idx);
@@ -1883,6 +1902,7 @@ generate_finalization_wrapper (gfc_symbol *derived, gfc_namespace *ns,
   block->expr1->value.op.op2->ref->u.ar.dimen_type[0] = DIMEN_ELEMENT;
   block->expr1->value.op.op2->ref->u.ar.start[0] = gfc_get_expr ();
   block->expr1->value.op.op2->ref->u.ar.start[0]->expr_type = EXPR_OP;
+  block->expr1->value.op.op2->ref->u.ar.start[0]->where = gfc_current_locus;
   block->expr1->value.op.op2->ref->u.ar.start[0]->value.op.op = INTRINSIC_MINUS;
   block->expr1->value.op.op2->ref->u.ar.start[0]->value.op.op1
 	= gfc_lval_expr_from_sym (idx);
@@ -1920,6 +1940,7 @@ generate_finalization_wrapper (gfc_symbol *derived, gfc_namespace *ns,
   last_code->expr2->value.op.op2
 	= gfc_get_int_expr (gfc_index_integer_kind, NULL, 1);
   last_code->expr2->ts = last_code->expr2->value.op.op2->ts;
+  last_code->expr2->where = gfc_current_locus;
 
   last_code->expr2->value.op.op1 = gfc_lval_expr_from_sym (sizes);
   last_code->expr2->value.op.op1->ref = gfc_get_ref ();
@@ -2188,6 +2209,8 @@ gfc_find_derived_vtab (gfc_symbol *derived)
   gfc_namespace *ns;
   gfc_symbol *vtab = NULL, *vtype = NULL, *found_sym = NULL, *def_init = NULL;
   gfc_symbol *copy = NULL, *src = NULL, *dst = NULL;
+  gfc_gsymbol *gsym = NULL;
+  gfc_symbol *dealloc = NULL, *arg = NULL;
 
   /* Find the top-level namespace.  */
   for (ns = gfc_current_ns; ns; ns = ns->parent)
@@ -2198,6 +2221,20 @@ gfc_find_derived_vtab (gfc_symbol *derived)
   if (!derived->attr.unlimited_polymorphic && derived->attr.is_class)
     derived = gfc_get_derived_super_type (derived);
 
+  /* Find the gsymbol for the module of use associated derived types.  */
+  if ((derived->attr.use_assoc || derived->attr.used_in_submodule)
+       && !derived->attr.vtype && !derived->attr.is_class)
+    gsym =  gfc_find_gsymbol (gfc_gsym_root, derived->module);
+  else
+    gsym = NULL;
+
+  /* Work in the gsymbol namespace if the top-level namespace is a module.
+     This ensures that the vtable is unique, which is required since we use
+     its address in SELECT TYPE.  */
+  if (gsym && gsym->ns && ns && ns->proc_name
+      && ns->proc_name->attr.flavor == FL_MODULE)
+    ns = gsym->ns;
+
   if (ns)
     {
       char name[GFC_MAX_SYMBOL_LEN+1], tname[GFC_MAX_SYMBOL_LEN+1];
@@ -2206,7 +2243,14 @@ gfc_find_derived_vtab (gfc_symbol *derived)
       sprintf (name, "__vtab_%s", tname);
 
       /* Look for the vtab symbol in various namespaces.  */
-      gfc_find_symbol (name, gfc_current_ns, 0, &vtab);
+      if (gsym && gsym->ns)
+	{
+	  gfc_find_symbol (name, gsym->ns, 0, &vtab);
+	  if (vtab)
+	    ns = gsym->ns;
+	}
+      if (vtab == NULL)
+	gfc_find_symbol (name, gfc_current_ns, 0, &vtab);
       if (vtab == NULL)
 	gfc_find_symbol (name, ns, 0, &vtab);
       if (vtab == NULL)
@@ -2231,6 +2275,20 @@ gfc_find_derived_vtab (gfc_symbol *derived)
 	    {
 	      gfc_component *c;
 	      gfc_symbol *parent = NULL, *parent_vtab = NULL;
+	      bool rdt = false;
+
+	      /* Is this a derived type with recursive allocatable
+		 components?  */
+	      c = (derived->attr.unlimited_polymorphic
+		   || derived->attr.abstract) ?
+		  NULL : derived->components;
+	      for (; c; c= c->next)
+		if (c->ts.type == BT_DERIVED
+		    && c->ts.u.derived == derived)
+		  {
+		    rdt = true;
+		    break;
+		  }
 
 	      gfc_get_symbol (name, ns, &vtype);
 	      if (!gfc_add_flavor (&vtype->attr, FL_DERIVED, NULL,
@@ -2403,6 +2461,66 @@ gfc_find_derived_vtab (gfc_symbol *derived)
 	      c->tb->ppc = 1;
 	      generate_finalization_wrapper (derived, ns, tname, c);
 
+	      /* Add component _deallocate.  */
+	      if (!gfc_add_component (vtype, "_deallocate", &c))
+		goto cleanup;
+	      c->attr.proc_pointer = 1;
+	      c->attr.access = ACCESS_PRIVATE;
+	      c->tb = XCNEW (gfc_typebound_proc);
+	      c->tb->ppc = 1;
+	      if (derived->attr.unlimited_polymorphic
+		  || derived->attr.abstract
+		  || !rdt)
+		c->initializer = gfc_get_null_expr (NULL);
+	      else
+		{
+		  /* Set up namespace.  */
+		  gfc_namespace *sub_ns = gfc_get_namespace (ns, 0);
+
+		  sub_ns->sibling = ns->contained;
+		  ns->contained = sub_ns;
+		  sub_ns->resolved = 1;
+		  /* Set up procedure symbol.  */
+		  sprintf (name, "__deallocate_%s", tname);
+		  gfc_get_symbol (name, sub_ns, &dealloc);
+		  sub_ns->proc_name = dealloc;
+		  dealloc->attr.flavor = FL_PROCEDURE;
+		  dealloc->attr.subroutine = 1;
+		  dealloc->attr.pure = 1;
+		  dealloc->attr.artificial = 1;
+		  dealloc->attr.if_source = IFSRC_DECL;
+
+		  if (ns->proc_name->attr.flavor == FL_MODULE)
+		    dealloc->module = ns->proc_name->name;
+		  gfc_set_sym_referenced (dealloc);
+		  /* Set up formal argument.  */
+		  gfc_get_symbol ("arg", sub_ns, &arg);
+		  arg->ts.type = BT_DERIVED;
+		  arg->ts.u.derived = derived;
+		  arg->attr.flavor = FL_VARIABLE;
+		  arg->attr.dummy = 1;
+		  arg->attr.artificial = 1;
+		  arg->attr.intent = INTENT_INOUT;
+		  arg->attr.dimension = 1;
+		  arg->attr.allocatable = 1;
+		  arg->as = gfc_get_array_spec();
+		  arg->as->type = AS_ASSUMED_SHAPE;
+		  arg->as->rank = 1;
+		  arg->as->lower[0] = gfc_get_int_expr (gfc_default_integer_kind,
+							NULL, 1);
+		  gfc_set_sym_referenced (arg);
+		  dealloc->formal = gfc_get_formal_arglist ();
+		  dealloc->formal->sym = arg;
+		  /* Set up code.  */
+		  sub_ns->code = gfc_get_code (EXEC_DEALLOCATE);
+		  sub_ns->code->ext.alloc.list = gfc_get_alloc ();
+		  sub_ns->code->ext.alloc.list->expr
+				= gfc_lval_expr_from_sym (arg);
+		  /* Set initializer.  */
+		  c->initializer = gfc_lval_expr_from_sym (dealloc);
+		  c->ts.interface = dealloc;
+		}
+
 	      /* Add procedure pointers for type-bound procedures.  */
 	      if (!derived->attr.unlimited_polymorphic)
 		add_procs_to_declared_vtab (derived, vtype);
@@ -2432,6 +2550,10 @@ cleanup:
 	gfc_commit_symbol (src);
       if (dst)
 	gfc_commit_symbol (dst);
+      if (dealloc)
+	gfc_commit_symbol (dealloc);
+      if (arg)
+	gfc_commit_symbol (arg);
     }
   else
     gfc_undo_symbols ();
@@ -2491,11 +2613,6 @@ 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 && 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);
 
   /* Find the top-level namespace.  */
   for (ns = gfc_current_ns; ns; ns = ns->parent)
@@ -2506,12 +2623,10 @@ find_intrinsic_vtab (gfc_typespec *ts)
     {
       char name[GFC_MAX_SYMBOL_LEN+1], tname[GFC_MAX_SYMBOL_LEN+1];
 
-      if (ts->type == BT_CHARACTER)
-	sprintf (tname, "%s_%d_%d", gfc_basic_typename (ts->type),
-		 charlen, ts->kind);
-      else
-	sprintf (tname, "%s_%d_", gfc_basic_typename (ts->type), ts->kind);
-
+      /* Encode all types as TYPENAME_KIND_ including especially character
+	 arrays, whose length is now consistently stored in the _len component
+	 of the class-variable.  */
+      sprintf (tname, "%s_%d_", gfc_basic_typename (ts->type), ts->kind);
       sprintf (name, "__vtab_%s", tname);
 
       /* Look for the vtab symbol in the top-level namespace only.  */
@@ -2576,9 +2691,8 @@ find_intrinsic_vtab (gfc_typespec *ts)
 	      c->initializer = gfc_get_int_expr (gfc_default_integer_kind,
 						 NULL,
 						 ts->type == BT_CHARACTER
-						 && charlen == 0 ?
-						   ts->kind :
-						   (int)gfc_element_size (e));
+						 ? ts->kind
+						 : (int)gfc_element_size (e));
 	      gfc_free_expr (e);
 
 	      /* Add component _extends.  */
@@ -2865,15 +2979,6 @@ gfc_find_typebound_intrinsic_op (gfc_symbol* derived, bool* t,
 gfc_symtree*
 gfc_get_tbp_symtree (gfc_symtree **root, const char *name)
 {
-  gfc_symtree *result;
-
-  result = gfc_find_symtree (*root, name);
-  if (!result)
-    {
-      result = gfc_new_symtree (root, name);
-      gcc_assert (result);
-      result->n.tb = NULL;
-    }
-
-  return result;
+  gfc_symtree *result = gfc_find_symtree (*root, name);
+  return result ? result : gfc_new_symtree (root, name);
 }