/* Implementation of Fortran 2003 Polymorphism.
- Copyright (C) 2009-2016 Free Software Foundation, Inc.
+ Copyright (C) 2009-2020 Free Software Foundation, Inc.
Contributed by Paul Richard Thomas <pault@gcc.gnu.org>
and Janus Weil <janus@gcc.gnu.org>
* _vptr: A pointer to the vtable entry (see below) of the dynamic type.
Only for unlimited polymorphic classes:
- * _len: An integer(4) to store the string length when the unlimited
+ * _len: An integer(C_SIZE_T) to store the string length when the unlimited
polymorphic pointer is used to point to a char array. The '_len'
component will be zero when no character array is stored in
'_data'.
static void
insert_component_ref (gfc_typespec *ts, gfc_ref **ref, const char * const name)
{
- gfc_symbol *type_sym;
gfc_ref *new_ref;
+ int wcnt, ecnt;
gcc_assert (ts->type == BT_DERIVED || ts->type == BT_CLASS);
- type_sym = ts->u.derived;
- gfc_find_component (type_sym, name, true, true, &new_ref);
+ gfc_find_component (ts->u.derived, name, true, true, &new_ref);
+
+ gfc_get_errors (&wcnt, &ecnt);
+ if (ecnt > 0 && !new_ref)
+ return;
gcc_assert (new_ref->u.c.component);
+
while (new_ref->next)
new_ref = new_ref->next;
new_ref->next = *ref;
*full_array = true;
}
else if (ref->next && ref->next->type == REF_ARRAY
- && !ref->next->next
&& ref->type == REF_COMPONENT
- && ref->next->type == REF_ARRAY
&& ref->next->u.ar.type != AR_ELEMENT)
{
with_data = true;
ref to the _len component. */
gfc_expr *
-gfc_get_len_component (gfc_expr *e)
+gfc_get_len_component (gfc_expr *e, int k)
{
gfc_expr *ptr;
gfc_ref *ref, **last;
}
/* And replace if with a ref to the _len component. */
gfc_add_len_component (ptr);
+ if (k != ptr->ts.kind)
+ {
+ gfc_typespec ts;
+ gfc_clear_ts (&ts);
+ ts.type = BT_INTEGER;
+ ts.kind = k;
+ gfc_convert_type_warn (ptr, &ts, 2, 0);
+ }
return ptr;
}
gfc_build_class_symbol (gfc_typespec *ts, symbol_attribute *attr,
gfc_array_spec **as)
{
- char name[GFC_MAX_SYMBOL_LEN+1], tname[GFC_MAX_SYMBOL_LEN+1];
+ char tname[GFC_MAX_SYMBOL_LEN+1];
+ char *name;
gfc_symbol *fclass;
gfc_symbol *vtab;
gfc_component *c;
|| attr->select_type_temporary || attr->associate_var;
if (!attr->class_ok)
- /* We can not build the class container yet. */
+ /* We cannot build the class container yet. */
return true;
/* Determine the name of the encapsulating type. */
rank = !(*as) || (*as)->rank == -1 ? GFC_MAX_DIMENSIONS : (*as)->rank;
get_unique_hashed_string (tname, ts->u.derived);
if ((*as) && attr->allocatable)
- sprintf (name, "__class_%s_%d_%da", tname, rank, (*as)->corank);
+ name = xasprintf ("__class_%s_%d_%da", tname, rank, (*as)->corank);
else if ((*as) && attr->pointer)
- sprintf (name, "__class_%s_%d_%dp", tname, rank, (*as)->corank);
+ name = xasprintf ("__class_%s_%d_%dp", tname, rank, (*as)->corank);
else if ((*as))
- sprintf (name, "__class_%s_%d_%dt", tname, rank, (*as)->corank);
+ name = xasprintf ("__class_%s_%d_%dt", tname, rank, (*as)->corank);
else if (attr->pointer)
- sprintf (name, "__class_%s_p", tname);
+ name = xasprintf ("__class_%s_p", tname);
else if (attr->allocatable)
- sprintf (name, "__class_%s_a", tname);
+ name = xasprintf ("__class_%s_a", tname);
else
- sprintf (name, "__class_%s_t", tname);
+ name = xasprintf ("__class_%s_t", tname);
if (ts->u.derived->attr.unlimited_polymorphic)
{
ts->u.derived = fclass;
attr->allocatable = attr->pointer = attr->dimension = attr->codimension = 0;
(*as) = NULL;
+ free (name);
return true;
}
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;
}
if (!comp_is_finalizable (comp))
return;
+ if (comp->finalized)
+ return;
+
e = gfc_copy_expr (expr);
if (!e->ref)
e->ref = ref = gfc_get_ref ();
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;
sub_ns);
gfc_free_expr (e);
}
+ comp->finalized = true;
}
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",
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 ();
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,
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);
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 ();
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);
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);
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;
}
/* 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);
gfc_component *comp;
gfc_namespace *sub_ns;
gfc_code *last_code, *block;
- char name[GFC_MAX_SYMBOL_LEN+1];
+ char *name;
bool finalizable_comp = false;
bool expr_null_wrapper = false;
gfc_expr *ancestor_wrapper = NULL, *rank;
sub_ns->resolved = 1;
/* Set up the procedure symbol. */
- sprintf (name, "__final_%s", tname);
+ name = xasprintf ("__final_%s", tname);
gfc_get_symbol (name, sub_ns, &final);
sub_ns->proc_name = final;
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;
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);
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);
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);
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 ();
gfc_free_expr (rank);
vtab_final->initializer = gfc_lval_expr_from_sym (final);
vtab_final->ts.interface = final;
+ free (name);
}
gfc_gsymbol *gsym = NULL;
gfc_symbol *dealloc = NULL, *arg = NULL;
+ if (derived->attr.pdt_template)
+ return NULL;
+
/* Find the top-level namespace. */
for (ns = gfc_current_ns; ns; ns = ns->parent)
if (!ns->parent)
if (!derived->attr.unlimited_polymorphic && derived->attr.is_class)
derived = gfc_get_derived_super_type (derived);
+ if (!derived)
+ return NULL;
+
/* 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)
if (ns)
{
- char name[GFC_MAX_SYMBOL_LEN+1], tname[GFC_MAX_SYMBOL_LEN+1];
+ char tname[GFC_MAX_SYMBOL_LEN+1];
+ char *name;
get_unique_hashed_string (tname, derived);
- sprintf (name, "__vtab_%s", tname);
+ name = xasprintf ("__vtab_%s", tname);
/* Look for the vtab symbol in various namespaces. */
if (gsym && gsym->ns)
vtab->attr.vtab = 1;
vtab->attr.access = ACCESS_PUBLIC;
gfc_set_sym_referenced (vtab);
- sprintf (name, "__vtype_%s", tname);
+ name = xasprintf ("__vtype_%s", tname);
gfc_find_symbol (name, ns, 0, &vtype);
if (vtype == NULL)
if (!gfc_add_component (vtype, "_size", &c))
goto cleanup;
c->ts.type = BT_INTEGER;
- c->ts.kind = 4;
+ c->ts.kind = gfc_size_kind;
c->attr.access = ACCESS_PRIVATE;
/* Remember the derived type in ts.u.derived,
so that the correct initializer can be set later on
(in gfc_conv_structure). */
c->ts.u.derived = derived;
- c->initializer = gfc_get_int_expr (gfc_default_integer_kind,
+ c->initializer = gfc_get_int_expr (gfc_size_kind,
NULL, 0);
/* Add component _extends. */
else
{
/* Construct default initialization variable. */
- sprintf (name, "__def_init_%s", tname);
+ name = xasprintf ("__def_init_%s", tname);
gfc_get_symbol (name, ns, &def_init);
def_init->attr.target = 1;
def_init->attr.artificial = 1;
ns->contained = sub_ns;
sub_ns->resolved = 1;
/* Set up procedure symbol. */
- sprintf (name, "__copy_%s", tname);
+ name = xasprintf ("__copy_%s", tname);
gfc_get_symbol (name, sub_ns, ©);
sub_ns->proc_name = copy;
copy->attr.flavor = FL_PROCEDURE;
goto cleanup;
c->attr.proc_pointer = 1;
c->attr.access = ACCESS_PRIVATE;
+ c->attr.artificial = 1;
c->tb = XCNEW (gfc_typebound_proc);
c->tb->ppc = 1;
generate_finalization_wrapper (derived, ns, tname, c);
ns->contained = sub_ns;
sub_ns->resolved = 1;
/* Set up procedure symbol. */
- sprintf (name, "__deallocate_%s", tname);
+ name = xasprintf ("__deallocate_%s", tname);
gfc_get_symbol (name, sub_ns, &dealloc);
sub_ns->proc_name = dealloc;
dealloc->attr.flavor = FL_PROCEDURE;
vtab->ts.u.derived = vtype;
vtab->value = gfc_default_initializer (&vtab->ts);
}
+ free (name);
}
found_sym = vtab;
if (ns)
{
- char name[GFC_MAX_SYMBOL_LEN+1], tname[GFC_MAX_SYMBOL_LEN+1];
+ char tname[GFC_MAX_SYMBOL_LEN+1];
+ char *name;
/* 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);
+ name = xasprintf ("__vtab_%s", tname);
/* Look for the vtab symbol in the top-level namespace only. */
gfc_find_symbol (name, ns, 0, &vtab);
vtab->attr.vtab = 1;
vtab->attr.access = ACCESS_PUBLIC;
gfc_set_sym_referenced (vtab);
- sprintf (name, "__vtype_%s", tname);
+ name = xasprintf ("__vtype_%s", tname);
gfc_find_symbol (name, ns, 0, &vtype);
if (vtype == NULL)
gfc_namespace *sub_ns;
gfc_namespace *contained;
gfc_expr *e;
+ size_t e_size;
gfc_get_symbol (name, ns, &vtype);
if (!gfc_add_flavor (&vtype->attr, FL_DERIVED, NULL,
if (!gfc_add_component (vtype, "_size", &c))
goto cleanup;
c->ts.type = BT_INTEGER;
- c->ts.kind = 4;
+ c->ts.kind = gfc_size_kind;
c->attr.access = ACCESS_PRIVATE;
/* Build a minimal expression to make use of
e = gfc_get_expr ();
e->ts = *ts;
e->expr_type = EXPR_VARIABLE;
- c->initializer = gfc_get_int_expr (gfc_default_integer_kind,
+ if (ts->type == BT_CHARACTER)
+ e_size = ts->kind;
+ else
+ gfc_element_size (e, &e_size);
+ c->initializer = gfc_get_int_expr (gfc_size_kind,
NULL,
- ts->type == BT_CHARACTER
- ? ts->kind
- : (int)gfc_element_size (e));
+ e_size);
gfc_free_expr (e);
/* Add component _extends. */
c->tb->ppc = 1;
if (ts->type != BT_CHARACTER)
- sprintf (name, "__copy_%s", tname);
+ name = xasprintf ("__copy_%s", tname);
else
{
/* __copy is always the same for characters.
Check to see if copy function already exists. */
- sprintf (name, "__copy_character_%d", ts->kind);
+ name = xasprintf ("__copy_character_%d", ts->kind);
contained = ns->contained;
for (; contained; contained = contained->sibling)
if (contained->proc_name
/* This is elemental so that arrays are automatically
treated correctly by the scalarizer. */
copy->attr.elemental = 1;
- if (ns->proc_name->attr.flavor == FL_MODULE)
+ if (ns->proc_name && ns->proc_name->attr.flavor == FL_MODULE)
copy->module = ns->proc_name->name;
- gfc_set_sym_referenced (copy);
+ gfc_set_sym_referenced (copy);
/* Set up formal arguments. */
gfc_get_symbol ("src", sub_ns, &src);
src->ts.type = ts->type;
goto cleanup;
c->attr.proc_pointer = 1;
c->attr.access = ACCESS_PRIVATE;
+ c->attr.artificial = 1;
c->tb = XCNEW (gfc_typebound_proc);
c->tb->ppc = 1;
c->initializer = gfc_get_null_expr (NULL);
vtab->ts.u.derived = vtype;
vtab->value = gfc_default_initializer (&vtab->ts);
}
+ free (name);
}
found_sym = vtab;
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);
+ if (ts->u.derived->components && ts->u.derived->components->ts.u.derived)
+ return gfc_find_derived_vtab (ts->u.derived->components->ts.u.derived);
+ else
+ return NULL;
default:
return find_intrinsic_vtab (ts);
}
projects / thirdparty / gcc.git / blobdiff