/* Implementation of Fortran 2003 Polymorphism.
- Copyright (C) 2009-2013 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>
(pointer/allocatable/dimension/...).
* _vptr: A pointer to the vtable entry (see below) of the dynamic type.
+ Only for unlimited polymorphic classes:
+ * _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'.
+
For each derived type we set up a "vtable" entry, i.e. a structure with the
following fields:
* _hash: A hash value serving as a unique identifier for this type.
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;
- new_ref = gfc_get_ref ();
- new_ref->type = REF_COMPONENT;
- new_ref->next = *ref;
- new_ref->u.c.sym = type_sym;
- new_ref->u.c.component = gfc_find_component (type_sym, name, true, true);
+ 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;
+
if (new_ref->next)
{
gfc_ref *next = NULL;
void
gfc_add_component_ref (gfc_expr *e, const char *name)
{
+ gfc_component *c;
gfc_ref **tail = &(e->ref);
- gfc_ref *next = NULL;
+ gfc_ref *ref, *next = NULL;
gfc_symbol *derived = e->symtree->n.sym->ts.u.derived;
while (*tail != NULL)
{
break;
tail = &((*tail)->next);
}
+ if (derived->components && derived->components->next &&
+ derived->components->next->ts.type == BT_DERIVED &&
+ derived->components->next->ts.u.derived == NULL)
+ {
+ /* Fix up missing vtype. */
+ gfc_symbol *vtab = gfc_find_derived_vtab (derived->components->ts.u.derived);
+ gcc_assert (vtab);
+ derived->components->next->ts.u.derived = vtab->ts.u.derived;
+ }
if (*tail != NULL && strcmp (name, "_data") == 0)
next = *tail;
- (*tail) = gfc_get_ref();
- (*tail)->next = next;
- (*tail)->type = REF_COMPONENT;
- (*tail)->u.c.sym = derived;
- (*tail)->u.c.component = gfc_find_component (derived, name, true, true);
- gcc_assert((*tail)->u.c.component);
- if (!next)
- e->ts = (*tail)->u.c.component->ts;
+ else
+ /* Avoid losing memory. */
+ gfc_free_ref_list (*tail);
+ c = gfc_find_component (derived, name, true, true, tail);
+
+ if (c) {
+ for (ref = *tail; ref->next; ref = ref->next)
+ ;
+ ref->next = next;
+ if (!next)
+ e->ts = c->ts;
+ }
}
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)
*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;
&& 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;
&& 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;
}
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);
if (derived->attr.unlimited_polymorphic)
strcpy (dt_name, "STAR");
else
- strcpy (dt_name, derived->name);
- dt_name[0] = TOUPPER (dt_name[0]);
+ strcpy (dt_name, gfc_dt_upper_string (derived->name));
if (derived->attr.unlimited_polymorphic)
sprintf (string, "_%s", dt_name);
else if (derived->module)
}
+/* Get the _len component from a class/derived object storing a string.
+ For unlimited polymorphic entities a ref to the _data component is available
+ while a ref to the _len component is needed. This routine traverese the
+ ref-chain and strips the last ref to a _data from it replacing it with a
+ ref to the _len component. */
+
+gfc_expr *
+gfc_get_len_component (gfc_expr *e, int k)
+{
+ gfc_expr *ptr;
+ gfc_ref *ref, **last;
+
+ ptr = gfc_copy_expr (e);
+
+ /* We need to remove the last _data component ref from ptr. */
+ last = &(ptr->ref);
+ ref = ptr->ref;
+ while (ref)
+ {
+ if (!ref->next
+ && ref->type == REF_COMPONENT
+ && strcmp ("_data", ref->u.c.component->name)== 0)
+ {
+ gfc_free_ref_list (ref);
+ *last = NULL;
+ break;
+ }
+ last = &(ref->next);
+ ref = ref->next;
+ }
+ /* 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;
+}
+
+
/* Build a polymorphic CLASS entity, using the symbol that comes from
build_sym. A CLASS entity is represented by an encapsulating type,
which contains the declared type as '_data' component, plus a pointer
- component '_vptr' which determines the dynamic type. */
+ component '_vptr' which determines the dynamic type. When this CLASS
+ entity is unlimited polymorphic, then also add a component '_len' to
+ store the length of string when that is stored in it. */
bool
gfc_build_class_symbol (gfc_typespec *ts, symbol_attribute *attr,
- gfc_array_spec **as, bool delayed_vtab)
+ 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_%d", 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", tname);
+ name = xasprintf ("__class_%s_t", tname);
if (ts->u.derived->attr.unlimited_polymorphic)
{
if (!gfc_add_component (fclass, "_vptr", &c))
return false;
c->ts.type = BT_DERIVED;
- if (delayed_vtab
- || (ts->u.derived->f2k_derived
- && ts->u.derived->f2k_derived->finalizers))
- c->ts.u.derived = NULL;
- else
+ c->attr.access = ACCESS_PRIVATE;
+ c->attr.pointer = 1;
+
+ if (ts->u.derived->attr.unlimited_polymorphic)
{
vtab = gfc_find_derived_vtab (ts->u.derived);
gcc_assert (vtab);
c->ts.u.derived = vtab->ts.u.derived;
+
+ /* Add component '_len'. Only unlimited polymorphic pointers may
+ have a string assigned to them, i.e., only those need the _len
+ component. */
+ if (!gfc_add_component (fclass, "_len", &c))
+ return false;
+ c->ts.type = BT_INTEGER;
+ c->ts.kind = gfc_charlen_int_kind;
+ c->attr.access = ACCESS_PRIVATE;
+ c->attr.artificial = 1;
}
- c->attr.access = ACCESS_PRIVATE;
- c->attr.pointer = 1;
+ else
+ /* Build vtab later. */
+ c->ts.u.derived = NULL;
}
if (!ts->u.derived->attr.unlimited_polymorphic)
up to 255 extension levels. */
if (ts->u.derived->attr.extension == 255)
{
- gfc_error ("Maximum extension level reached with type '%s' at %L",
+ gfc_error ("Maximum extension level reached with type %qs at %L",
ts->u.derived->name, &ts->u.derived->declared_at);
return false;
}
ts->u.derived = fclass;
attr->allocatable = attr->pointer = attr->dimension = attr->codimension = 0;
(*as) = NULL;
+ free (name);
return true;
}
{
gfc_component *c;
- if (tb->non_overridable)
+ if (tb->non_overridable && !tb->overridden)
return;
- c = gfc_find_component (vtype, name, true, true);
+ c = gfc_find_component (vtype, name, true, true, NULL);
if (c == NULL)
{
if (tb->u.specific)
{
- c->ts.interface = tb->u.specific->n.sym;
+ gfc_symbol *ifc = tb->u.specific->n.sym;
+ c->ts.interface = ifc;
if (!tb->deferred)
c->initializer = gfc_get_variable_expr (tb->u.specific);
+ c->attr.pure = ifc->attr.pure;
}
}
for (cmp = vtab->ts.u.derived->components; cmp; cmp = cmp->next)
{
- if (gfc_find_component (vtype, cmp->name, true, true))
+ if (gfc_find_component (vtype, cmp->name, true, true, NULL))
continue;
add_proc_comp (vtype, cmp->name, cmp->tb);
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;
-
- if (c->ts.type == BT_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;
}
+static bool
+comp_is_finalizable (gfc_component *comp)
+{
+ if (comp->attr.proc_pointer)
+ return false;
+ else if (comp->attr.allocatable && comp->ts.type != BT_CLASS)
+ return true;
+ else if (comp->ts.type == BT_DERIVED && !comp->attr.pointer
+ && (comp->ts.u.derived->attr.alloc_comp
+ || has_finalizer_component (comp->ts.u.derived)
+ || (comp->ts.u.derived->f2k_derived
+ && comp->ts.u.derived->f2k_derived->finalizers)))
+ return true;
+ else if (comp->ts.type == BT_CLASS && CLASS_DATA (comp)
+ && CLASS_DATA (comp)->attr.allocatable)
+ return true;
+ else
+ return false;
+}
+
+
/* Call DEALLOCATE for the passed component if it is allocatable, if it is
neither allocatable nor a pointer but has a finalizer, call it. If it
is a nonpointer component with allocatable components or has finalizers, walk
static void
finalize_component (gfc_expr *expr, gfc_symbol *derived, gfc_component *comp,
- gfc_symbol *stat, gfc_symbol *fini_coarray, gfc_code **code)
+ gfc_symbol *stat, gfc_symbol *fini_coarray, gfc_code **code,
+ gfc_namespace *sub_ns)
{
gfc_expr *e;
gfc_ref *ref;
- if (comp->ts.type != BT_DERIVED && comp->ts.type != BT_CLASS
- && !comp->attr.allocatable)
- return;
-
- if ((comp->ts.type == BT_DERIVED && comp->attr.pointer)
- || (comp->ts.type == BT_CLASS && CLASS_DATA (comp)
- && CLASS_DATA (comp)->attr.pointer))
+ if (!comp_is_finalizable (comp))
return;
- if (comp->ts.type == BT_DERIVED && !comp->attr.allocatable
- && (comp->ts.u.derived->f2k_derived == NULL
- || comp->ts.u.derived->f2k_derived->finalizers == NULL)
- && !has_finalizer_component (comp->ts.u.derived))
+ if (comp->finalized)
return;
e = gfc_copy_expr (expr);
/* Add IF (fini_coarray). */
if (comp->attr.codimension
|| (comp->ts.type == BT_CLASS && CLASS_DATA (comp)
- && CLASS_DATA (comp)->attr.allocatable))
+ && CLASS_DATA (comp)->attr.codimension))
{
block = gfc_get_code (EXEC_IF);
if (*code)
dealloc->ext.alloc.list->expr = e;
dealloc->expr1 = gfc_lval_expr_from_sym (stat);
+ gfc_code *cond = gfc_get_code (EXEC_IF);
+ 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;
+ cond->block->expr1->symtree->n.sym->result = cond->block->expr1->symtree->n.sym;
+ gfc_commit_symbol (cond->block->expr1->symtree->n.sym);
+ cond->block->expr1->ts.type = BT_LOGICAL;
+ cond->block->expr1->ts.kind = gfc_default_logical_kind;
+ cond->block->expr1->value.function.isym = gfc_intrinsic_function_by_id (GFC_ISYM_ASSOCIATED);
+ cond->block->expr1->value.function.actual = gfc_get_actual_arglist ();
+ cond->block->expr1->value.function.actual->expr = gfc_copy_expr (expr);
+ cond->block->expr1->value.function.actual->next = gfc_get_actual_arglist ();
+ cond->block->next = dealloc;
+
if (block)
- block->next = dealloc;
+ block->next = cond;
else if (*code)
{
- (*code)->next = dealloc;
+ (*code)->next = cond;
(*code) = (*code)->next;
}
else
- (*code) = dealloc;
+ (*code) = cond;
}
else if (comp->ts.type == BT_DERIVED
&& comp->ts.u.derived->f2k_derived
gfc_component *c;
for (c = comp->ts.u.derived->components; c; c = c->next)
- finalize_component (e, comp->ts.u.derived, c, stat, fini_coarray, code);
+ finalize_component (e, comp->ts.u.derived, c, stat, fini_coarray, code,
+ sub_ns);
gfc_free_expr (e);
}
+ comp->finalized = true;
}
block->ext.actual->next = gfc_get_actual_arglist ();
block->ext.actual->next->expr = gfc_get_int_expr (gfc_index_integer_kind,
NULL, 0);
- block->ext.actual->next->next = gfc_get_actual_arglist (); /* SIZE. */
+ block->ext.actual->next->next = gfc_get_actual_arglist (); /* SIZE. */
/* The <addr> part: TRANSFER (C_LOC (array), c_intptr_t). */
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;
}
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. */
/* 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);
block2->expr1 = gfc_lval_expr_from_sym (ptr2);
block2->expr2 = gfc_lval_expr_from_sym (ptr);
- /* Call now the user's final subroutine. */
+ /* Call now the user's final subroutine. */
block->next = gfc_get_code (EXEC_CALL);
block = block->next;
block->symtree = fini->proc_tree;
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;
return;
}
- /* Search for the ancestor's finalizers. */
+ /* Search for the ancestor's finalizers. */
if (derived->attr.extension && derived->components
&& (!derived->components->ts.u.derived->attr.abstract
|| has_finalizer_component (derived)))
&& ancestor_wrapper && ancestor_wrapper->expr_type != EXPR_NULL)
continue;
- if (comp->ts.type != BT_CLASS && !comp->attr.pointer
- && (comp->attr.allocatable
- || (comp->ts.type == BT_DERIVED
- && (comp->ts.u.derived->attr.alloc_comp
- || has_finalizer_component (comp->ts.u.derived)
- || (comp->ts.u.derived->f2k_derived
- && comp->ts.u.derived->f2k_derived->finalizers)))))
- finalizable_comp = true;
- else if (comp->ts.type == BT_CLASS && CLASS_DATA (comp)
- && CLASS_DATA (comp)->attr.allocatable)
- finalizable_comp = true;
+ finalizable_comp |= comp_is_finalizable (comp);
}
/* If there is no new finalizer and no new allocatable, return with
3. Call the ancestor's finalizer. */
/* Declare the wrapper function; it takes an assumed-rank array
- and a VALUE logical as arguments. */
+ and a VALUE logical as arguments. */
/* Set up the namespace. */
sub_ns = gfc_get_namespace (ns, 0);
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;
final->attr.artificial = 1;
+ final->attr.always_explicit = 1;
final->attr.if_source = expr_null_wrapper ? IFSRC_IFBODY : IFSRC_DECL;
if (ns->proc_name->attr.flavor == FL_MODULE)
final->module = ns->proc_name->name;
last_code->ext.iterator = iter;
last_code->block = gfc_get_code (EXEC_DO);
- /* strides(idx) = _F._stride(array,dim=idx). */
+ /* strides(idx) = _F._stride(array,dim=idx). */
last_code->block->next = gfc_get_code (EXEC_ASSIGN);
block = last_code->block->next;
gfc_lval_expr_from_sym (array),
gfc_lval_expr_from_sym (idx));
- /* sizes(idx) = sizes(idx-1) * size(array,dim=idx, kind=index_kind). */
+ /* sizes(idx) = sizes(idx-1) * size(array,dim=idx, kind=index_kind). */
block->next = gfc_get_code (EXEC_ASSIGN);
block = block->next;
- /* sizes(idx) = ... */
+ /* sizes(idx) = ... */
block->expr1 = gfc_lval_expr_from_sym (sizes);
block->expr1->ref = gfc_get_ref ();
block->expr1->ref->type = REF_ARRAY;
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). */
+ /* sizes(idx-1). */
block->expr2->value.op.op1 = gfc_lval_expr_from_sym (sizes);
block->expr2->value.op.op1->ref = gfc_get_ref ();
block->expr2->value.op.op1->ref->type = REF_ARRAY;
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_finalizer *fini, *fini_elem = NULL;
- gfc_get_symbol ("ptr", sub_ns, &ptr);
+ gfc_get_symbol ("ptr1", sub_ns, &ptr);
ptr->ts.type = BT_DERIVED;
ptr->ts.u.derived = derived;
ptr->attr.flavor = FL_VARIABLE;
for (fini = derived->f2k_derived->finalizers; fini; fini = fini->next)
{
- if (!fini->proc_tree)
- fini->proc_tree = gfc_find_sym_in_symtree (fini->proc_sym);
+ gcc_assert (fini->proc_tree); /* Should have been set in gfc_resolve_finalizers. */
if (fini->proc_tree->n.sym->attr.elemental)
{
fini_elem = fini;
if (!ptr)
{
- gfc_get_symbol ("ptr", sub_ns, &ptr);
+ gfc_get_symbol ("ptr2", sub_ns, &ptr);
ptr->ts.type = BT_DERIVED;
ptr->ts.u.derived = derived;
ptr->attr.flavor = FL_VARIABLE;
continue;
finalize_component (gfc_lval_expr_from_sym (ptr), derived, comp,
- stat, fini_coarray, &block);
+ stat, fini_coarray, &block, sub_ns);
if (!last_code->block->next)
last_code->block->next = block;
}
gfc_free_expr (rank);
vtab_final->initializer = gfc_lval_expr_from_sym (final);
vtab_final->ts.interface = final;
+ free (name);
}
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;
+
+ if (derived->attr.pdt_template)
+ return NULL;
/* Find the top-level namespace. */
for (ns = gfc_current_ns; ns; ns = 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)
+ 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];
+ 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. */
- 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)
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_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,
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);
+ /* 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. */
+ name = xasprintf ("__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);
vtab->ts.u.derived = vtype;
vtab->value = gfc_default_initializer (&vtab->ts);
}
+ free (name);
}
found_sym = vtab;
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 ();
/* 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)
- {
- gfc_error ("TODO: Deferred character length variable at %C cannot "
- "yet be associated with unlimited polymorphic entities");
- return NULL;
- }
-
- if (ts->type == BT_UNKNOWN)
- return NULL;
-
- /* Sometimes the typespec is passed from a single call. */
- if (ts->type == BT_DERIVED)
- 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];
+ char tname[GFC_MAX_SYMBOL_LEN+1];
+ char *name;
- 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);
+ name = xasprintf ("__vtab_%s", tname);
- sprintf (name, "__vtab_%s", tname);
-
- /* Look for the vtab symbol in various namespaces. */
- gfc_find_symbol (name, gfc_current_ns, 0, &vtab);
- if (vtab == NULL)
- gfc_find_symbol (name, ns, 0, &vtab);
+ /* Look for the vtab symbol in the top-level namespace only. */
+ gfc_find_symbol (name, ns, 0, &vtab);
if (vtab == NULL)
{
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
- target-memory.c/gfc_element_size for 'size'. */
+ target-memory.c/gfc_element_size for 'size'. Special handling
+ for character arrays, that are not constant sized: to support
+ len (str) * kind, only the kind information is stored in the
+ vtab. */
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,
- (int)gfc_element_size (e));
+ e_size);
gfc_free_expr (e);
/* Add component _extends. */
c->tb = XCNEW (gfc_typebound_proc);
c->tb->ppc = 1;
- /* Check to see if copy function already exists. Note
- that this is only used for characters of different
- lengths. */
- contained = ns->contained;
- for (; contained; contained = contained->sibling)
- if (contained->proc_name
- && strcmp (name, contained->proc_name->name) == 0)
- {
- copy = contained->proc_name;
- goto got_char_copy;
- }
+ if (ts->type != BT_CHARACTER)
+ name = xasprintf ("__copy_%s", tname);
+ else
+ {
+ /* __copy is always the same for characters.
+ Check to see if copy function already exists. */
+ name = xasprintf ("__copy_character_%d", ts->kind);
+ contained = ns->contained;
+ for (; contained; contained = contained->sibling)
+ if (contained->proc_name
+ && strcmp (name, contained->proc_name->name) == 0)
+ {
+ copy = contained->proc_name;
+ goto got_char_copy;
+ }
+ }
/* Set up namespace. */
sub_ns = gfc_get_namespace (ns, 0);
ns->contained = sub_ns;
sub_ns->resolved = 1;
/* Set up procedure symbol. */
- if (ts->type != BT_CHARACTER)
- sprintf (name, "__copy_%s", tname);
- else
- /* __copy is always the same for characters. */
- sprintf (name, "__copy_character_%d", ts->kind);
gfc_get_symbol (name, sub_ns, ©);
sub_ns->proc_name = copy;
copy->attr.flavor = FL_PROCEDURE;
/* 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;
}
+/* 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:
+ 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);
+ }
+}
+
+
/* General worker function to find either a type-bound procedure or a
type-bound user operator. */
&& res->n.tb->access == ACCESS_PRIVATE)
{
if (where)
- gfc_error ("'%s' of '%s' is PRIVATE at %L",
+ gfc_error ("%qs of %qs is PRIVATE at %L",
name, derived->name, where);
if (t)
*t = false;
&& res->access == ACCESS_PRIVATE)
{
if (where)
- gfc_error ("'%s' of '%s' is PRIVATE at %L",
+ gfc_error ("%qs of %qs is PRIVATE at %L",
gfc_op2string (op), derived->name, where);
if (t)
*t = false;
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);
}
projects / thirdparty / gcc.git / blobdiff