2012-11-27 Tobias Burnus <burnus@net-b.de>
PR fortran/37336
* class.c (find_derived_vtab): New static function.
(gfc_get_derived_vtab): Renamed from gfc_find_derived_vtab.
(gfc_find_derived_vtab): New function.
(gfc_class_null_initializer, get_unique_hashed_string,
gfc_build_class_symbol, copy_vtab_proc_comps,
): Use gfc_get_derived_vtab instead
of gfc_find_derived_vtab.
(finalizer_insert_packed_call): New static function.
(finalize_component, generate_finalization_wrapper):
Fix coarray handling and packing.
* gfortran.h (gfc_get_derived_vtab): New prototype.
* check.c (gfc_check_move_alloc): Use it.
* expr.c (gfc_check_pointer_assign): Ditto.
* interface.c (compare_parameter): Ditto.
* iresolve.c (gfc_resolve_extends_type_of): Ditto.
* trans-decl.c (gfc_get_symbol_decl): Ditto.
* trans-expr.c (gfc_conv_derived_to_class,
gfc_trans_class_assign): Ditto.
* trans-intrinsic.c (conv_intrinsic_move_alloc): Ditto.
* trans-stmt.c (gfc_trans_allocate,
gfc_trans_deallocate): Ditto.
* resolve.c (resolve_typebound_function,
resolve_typebound_subroutine, resolve_allocate_expr,
resolve_select_type, gfc_resolve_finalizers,
resolve_typebound_procedures, resolve_fl_derived): Ditto.
(resolve_symbol): Return early if attr.artificial.
@@ -2801,7 +2801,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)
- gfc_find_derived_vtab (from->ts.u.derived);
+ gfc_get_derived_vtab (from->ts.u.derived);
return SUCCESS;
}
@@ -416,7 +416,7 @@ gfc_class_null_initializer (gfc_typespec *ts)
{
gfc_constructor *ctor = gfc_constructor_get();
if (strcmp (comp->name, "_vptr") == 0)
- ctor->expr = gfc_lval_expr_from_sym (gfc_find_derived_vtab (ts->u.derived));
+ ctor->expr = gfc_lval_expr_from_sym (gfc_get_derived_vtab (ts->u.derived));
else
ctor->expr = gfc_get_null_expr (NULL);
gfc_constructor_append (&init->value.constructor, ctor);
@@ -454,7 +454,7 @@ get_unique_hashed_string (char *string, gfc_symbol *derived)
char tmp[2*GFC_MAX_SYMBOL_LEN+2];
get_unique_type_string (&tmp[0], derived);
/* If string is too long, use hash value in hex representation (allow for
- extra decoration, cf. gfc_build_class_symbol & gfc_find_derived_vtab).
+ extra decoration, cf. gfc_build_class_symbol & gfc_get_derived_vtab).
We need space to for 15 characters "__class_" + symbol name + "_%d_%da",
where %d is the (co)rank which can be up to n = 15. */
if (strlen (tmp) > GFC_MAX_SYMBOL_LEN - 15)
@@ -583,7 +583,7 @@ gfc_build_class_symbol (gfc_typespec *ts, symbol_attribute *attr,
c->ts.u.derived = NULL;
else
{
- vtab = gfc_find_derived_vtab (ts->u.derived);
+ vtab = gfc_get_derived_vtab (ts->u.derived);
gcc_assert (vtab);
c->ts.u.derived = vtab->ts.u.derived;
}
@@ -684,7 +684,7 @@ copy_vtab_proc_comps (gfc_symbol *declared, gfc_symbol *vtype)
gfc_component *cmp;
gfc_symbol *vtab;
- vtab = gfc_find_derived_vtab (declared);
+ vtab = gfc_get_derived_vtab (declared);
for (cmp = vtab->ts.u.derived->components; cmp; cmp = cmp->next)
{
@@ -731,7 +731,7 @@ has_finalizer_component (gfc_symbol *derived)
static void
finalize_component (gfc_expr *expr, gfc_symbol *derived, gfc_component *comp,
- gfc_expr *stat, gfc_code **code)
+ gfc_symbol *stat, gfc_symbol *fini_coarray, gfc_code **code)
{
gfc_expr *e;
gfc_ref *ref;
@@ -779,12 +779,36 @@ finalize_component (gfc_expr *expr, gfc_symbol *derived, gfc_component *comp,
e->rank = ref->next->u.ar.as->rank;
}
+ /* Call DEALLOCATE (comp, stat=ignore). */
if (comp->attr.allocatable
|| (comp->ts.type == BT_CLASS && CLASS_DATA (comp)
&& CLASS_DATA (comp)->attr.allocatable))
{
- /* Call DEALLOCATE (comp, stat=ignore). */
- gfc_code *dealloc;
+ gfc_code *dealloc, *block = NULL;
+
+ /* Add IF (fini_coarray). */
+ if (comp->attr.codimension
+ || (comp->ts.type == BT_CLASS && CLASS_DATA (comp)
+ && CLASS_DATA (comp)->attr.allocatable))
+ {
+ block = XCNEW (gfc_code);
+ if (*code)
+ {
+ (*code)->next = block;
+ (*code) = (*code)->next;
+ }
+ else
+ (*code) = block;
+
+ block->loc = gfc_current_locus;
+ block->op = EXEC_IF;
+
+ block->block = XCNEW (gfc_code);
+ block = block->block;
+ block->loc = gfc_current_locus;
+ block->op = EXEC_IF;
+ block->expr1 = gfc_lval_expr_from_sym (fini_coarray);
+ }
dealloc = XCNEW (gfc_code);
dealloc->op = EXEC_DEALLOCATE;
@@ -792,9 +816,11 @@ finalize_component (gfc_expr *expr, gfc_symbol *derived, gfc_component *comp,
dealloc->ext.alloc.list = gfc_get_alloc ();
dealloc->ext.alloc.list->expr = e;
+ dealloc->expr1 = gfc_lval_expr_from_sym (stat);
- dealloc->expr1 = stat;
- if (*code)
+ if (block)
+ block->next = dealloc;
+ else if (*code)
{
(*code)->next = dealloc;
(*code) = (*code)->next;
@@ -811,7 +837,7 @@ finalize_component (gfc_expr *expr, gfc_symbol *derived, gfc_component *comp,
gfc_symbol *vtab;
gfc_component *c;
- vtab = gfc_find_derived_vtab (comp->ts.u.derived);
+ vtab = gfc_get_derived_vtab (comp->ts.u.derived);
for (c = vtab->ts.u.derived->components; c; c = c->next)
if (strcmp (c->name, "_final") == 0)
break;
@@ -839,7 +865,7 @@ finalize_component (gfc_expr *expr, gfc_symbol *derived, gfc_component *comp,
gfc_component *c;
for (c = comp->ts.u.derived->components; c; c = c->next)
- finalize_component (e, c->ts.u.derived, c, stat, code);
+ finalize_component (e, comp->ts.u.derived, c, stat, fini_coarray, code);
gfc_free_expr (e);
}
}
@@ -847,12 +873,11 @@ finalize_component (gfc_expr *expr, gfc_symbol *derived, gfc_component *comp,
/* Generate code equivalent to
CALL C_F_POINTER (TRANSFER (TRANSFER (C_LOC (array, cptr), c_intptr)
- + idx * STORAGE_SIZE (array)/NUMERIC_STORAGE_SIZE., c_ptr),
- ptr). */
+ + idx * stride, c_ptr), ptr). */
static gfc_code *
finalization_scalarizer (gfc_symbol *idx, gfc_symbol *array, gfc_symbol *ptr,
- gfc_namespace *sub_ns)
+ gfc_expr *stride, gfc_namespace *sub_ns)
{
gfc_code *block;
gfc_expr *expr, *expr2, *expr3;
@@ -919,40 +944,13 @@ finalization_scalarizer (gfc_symbol *idx, gfc_symbol *array, gfc_symbol *ptr,
expr->ts.kind = gfc_index_integer_kind;
expr2->value.function.actual->expr = expr;
- /* STORAGE_SIZE (...) / NUMERIC_STORAGE_SIZE. */
- block->ext.actual->expr = gfc_get_expr ();
- expr = block->ext.actual->expr;
- expr->expr_type = EXPR_OP;
- expr->value.op.op = INTRINSIC_DIVIDE;
-
- /* STORAGE_SIZE (array,kind=c_intptr_t). */
- expr->value.op.op1 = gfc_get_expr ();
- expr->value.op.op1->expr_type = EXPR_FUNCTION;
- expr->value.op.op1->value.function.isym
- = gfc_intrinsic_function_by_id (GFC_ISYM_STORAGE_SIZE);
- gfc_get_sym_tree ("storage_size", sub_ns, &expr->value.op.op1->symtree,
- false);
- expr->value.op.op1->symtree->n.sym->attr.flavor = FL_PROCEDURE;
- expr->value.op.op1->symtree->n.sym->attr.intrinsic = 1;
- gfc_commit_symbol (expr->value.op.op1->symtree->n.sym);
- expr->value.op.op1->value.function.actual = gfc_get_actual_arglist ();
- expr->value.op.op1->value.function.actual->expr
- = gfc_lval_expr_from_sym (array);
- expr->value.op.op1->value.function.actual->next = gfc_get_actual_arglist ();
- expr->value.op.op1->value.function.actual->next->expr
- = gfc_get_int_expr (gfc_index_integer_kind, NULL, 0);
- expr->value.op.op2 = gfc_get_int_expr (gfc_index_integer_kind, NULL,
- gfc_character_storage_size);
- expr->value.op.op1->ts = expr->value.op.op2->ts;
- expr->ts = expr->value.op.op1->ts;
-
- /* Offset calculation: idx * (STORAGE_SIZE (...) / NUMERIC_STORAGE_SIZE). */
+ /* Offset calculation: idx * stride (in bytes). */
block->ext.actual->expr = gfc_get_expr ();
expr3 = block->ext.actual->expr;
expr3->expr_type = EXPR_OP;
expr3->value.op.op = INTRINSIC_TIMES;
expr3->value.op.op1 = gfc_lval_expr_from_sym (idx);
- expr3->value.op.op2 = expr;
+ expr3->value.op.op2 = stride;
expr3->ts = expr->ts;
/* <array addr> + <offset>. */
@@ -972,6 +970,265 @@ finalization_scalarizer (gfc_symbol *idx, gfc_symbol *array, gfc_symbol *ptr,
}
+/* Insert code of the following form:
+
+ if (stride == STORAGE_SIZE (array)/NUMERIC_STORAGE_SIZE
+ || 0 == STORAGE_SIZE (array)) then
+ call final_rank3 (array)
+ else
+ block
+ type(t) :: tmp(shape (array))
+
+ do i = 0, size (array)-1
+ addr = transfer (c_loc (array), addr) + i * stride
+ call c_f_pointer (transfer (addr, cptr), ptr)
+
+ addr = transfer (c_loc (tmp), addr)
+ + i * STORAGE_SIZE (array)/NUMERIC_STORAGE_SIZE
+ call c_f_pointer (transfer (addr, cptr), ptr2)
+ ptr2 = ptr
+ end do
+ call final_rank3 (tmp)
+ end block
+ end if */
+
+static void
+finalizer_insert_packed_call (gfc_code *block, gfc_finalizer *fini,
+ gfc_symbol *array, gfc_symbol *stride,
+ gfc_symbol *idx, gfc_symbol *ptr,
+ gfc_symbol *nelem, gfc_symtree *size_intr,
+ gfc_namespace *sub_ns)
+{
+ gfc_symbol *tmp_array, *ptr2;
+ gfc_expr *size_expr;
+ gfc_namespace *ns;
+ gfc_iterator *iter;
+ int i;
+
+ block->next = XCNEW (gfc_code);
+ block = block->next;
+ block->loc = gfc_current_locus;
+ block->op = EXEC_IF;
+
+ block->block = XCNEW (gfc_code);
+ block = block->block;
+ block->loc = gfc_current_locus;
+ block->op = EXEC_IF;
+
+ /* size_expr = STORAGE_SIZE (...) / NUMERIC_STORAGE_SIZE. */
+ size_expr = gfc_get_expr ();
+ size_expr->where = gfc_current_locus;
+ size_expr->expr_type = EXPR_OP;
+ size_expr->value.op.op = INTRINSIC_DIVIDE;
+
+ /* STORAGE_SIZE (array,kind=c_intptr_t). */
+ size_expr->value.op.op1 = gfc_get_expr ();
+ size_expr->value.op.op1->where = gfc_current_locus;
+ size_expr->value.op.op1->expr_type = EXPR_FUNCTION;
+ size_expr->value.op.op1->value.function.isym
+ = gfc_intrinsic_function_by_id (GFC_ISYM_STORAGE_SIZE);
+ gfc_get_sym_tree ("storage_size", sub_ns, &size_expr->value.op.op1->symtree,
+ false);
+ size_expr->value.op.op1->symtree->n.sym->attr.flavor = FL_PROCEDURE;
+ size_expr->value.op.op1->symtree->n.sym->attr.intrinsic = 1;
+ gfc_commit_symbol (size_expr->value.op.op1->symtree->n.sym);
+ size_expr->value.op.op1->value.function.actual = gfc_get_actual_arglist ();
+ size_expr->value.op.op1->value.function.actual->expr
+ = gfc_lval_expr_from_sym (array);
+ size_expr->value.op.op1->value.function.actual->next = gfc_get_actual_arglist ();
+ size_expr->value.op.op1->value.function.actual->next->expr
+ = gfc_get_int_expr (gfc_index_integer_kind, NULL, 0);
+
+ /* NUMERIC_STORAGE_SIZE. */
+ size_expr->value.op.op2 = gfc_get_int_expr (gfc_index_integer_kind, NULL,
+ gfc_character_storage_size);
+ size_expr->value.op.op1->ts = size_expr->value.op.op2->ts;
+ size_expr->ts = size_expr->value.op.op1->ts;
+
+ /* IF condition: stride == size_expr || 0 == size_expr. */
+ block->expr1 = gfc_get_expr ();
+ block->expr1->expr_type = EXPR_FUNCTION;
+ block->expr1->ts.type = BT_LOGICAL;
+ block->expr1->ts.kind = 4;
+ block->expr1->expr_type = EXPR_OP;
+ block->expr1->where = gfc_current_locus;
+
+ block->expr1->value.op.op = INTRINSIC_OR;
+
+ /* stride == size_expr */
+ block->expr1->value.op.op1 = gfc_get_expr ();
+ block->expr1->value.op.op1->expr_type = EXPR_FUNCTION;
+ block->expr1->value.op.op1->ts.type = BT_LOGICAL;
+ block->expr1->value.op.op1->ts.kind = 4;
+ block->expr1->value.op.op1->expr_type = EXPR_OP;
+ block->expr1->value.op.op1->where = gfc_current_locus;
+ block->expr1->value.op.op1->value.op.op = INTRINSIC_EQ;
+ block->expr1->value.op.op1->value.op.op1 = gfc_lval_expr_from_sym (stride);
+ block->expr1->value.op.op1->value.op.op2 = size_expr;
+
+ /* 0 == size_expr */
+ block->expr1->value.op.op2 = gfc_get_expr ();
+ block->expr1->value.op.op2->expr_type = EXPR_FUNCTION;
+ block->expr1->value.op.op2->ts.type = BT_LOGICAL;
+ block->expr1->value.op.op2->ts.kind = 4;
+ block->expr1->value.op.op2->expr_type = EXPR_OP;
+ block->expr1->value.op.op2->where = gfc_current_locus;
+ block->expr1->value.op.op2->value.op.op = INTRINSIC_EQ;
+ block->expr1->value.op.op2->value.op.op1 =
+ gfc_get_int_expr (gfc_index_integer_kind, NULL, 0);
+ block->expr1->value.op.op2->value.op.op2 = gfc_copy_expr (size_expr);
+
+ /* IF body: call final subroutine. */
+ block->next = XCNEW (gfc_code);
+ block->next->op = EXEC_CALL;
+ block->next->loc = gfc_current_locus;
+ block->next->symtree = fini->proc_tree;
+ 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);
+
+ /* ELSE. */
+
+ block->block = XCNEW (gfc_code);
+ block = block->block;
+ block->loc = gfc_current_locus;
+ block->op = EXEC_IF;
+
+ block->next = XCNEW (gfc_code);
+ block = block->next;
+
+ /* BLOCK ... END BLOCK. */
+ block->op = EXEC_BLOCK;
+ block->loc = gfc_current_locus;
+ ns = gfc_build_block_ns (sub_ns);
+ block->ext.block.ns = ns;
+ block->ext.block.assoc = NULL;
+
+ gfc_get_symbol ("ptr2", ns, &ptr2);
+ ptr2->ts.type = BT_DERIVED;
+ ptr2->ts.u.derived = array->ts.u.derived;
+ ptr2->attr.flavor = FL_VARIABLE;
+ ptr2->attr.pointer = 1;
+ ptr2->attr.artificial = 1;
+ gfc_set_sym_referenced (ptr2);
+ gfc_commit_symbol (ptr2);
+
+ gfc_get_symbol ("tmp_array", ns, &tmp_array);
+ tmp_array->ts.type = BT_DERIVED;
+ tmp_array->ts.u.derived = array->ts.u.derived;
+ tmp_array->attr.flavor = FL_VARIABLE;
+ tmp_array->attr.contiguous = 1;
+ tmp_array->attr.dimension = 1;
+ tmp_array->attr.artificial = 1;
+ tmp_array->as = gfc_get_array_spec();
+ tmp_array->attr.intent = INTENT_INOUT;
+ tmp_array->as->type = AS_EXPLICIT;
+ tmp_array->as->rank = fini->proc_tree->n.sym->formal->sym->as->rank;
+
+ for (i = 0; i < tmp_array->as->rank; i++)
+ {
+ gfc_expr *shape_expr;
+ tmp_array->as->lower[i] = gfc_get_int_expr (gfc_default_integer_kind,
+ NULL, 1);
+ /* SIZE (array, dim=i+1, kind=default_kind). */
+ shape_expr = gfc_get_expr ();
+ shape_expr->expr_type = EXPR_FUNCTION;
+ shape_expr->value.function.isym
+ = gfc_intrinsic_function_by_id (GFC_ISYM_SIZE);
+ shape_expr->symtree = size_intr;
+ shape_expr->value.function.actual = gfc_get_actual_arglist ();
+ shape_expr->value.function.actual->expr = gfc_lval_expr_from_sym (array);
+ shape_expr->value.function.actual->next = gfc_get_actual_arglist ();
+ shape_expr->value.function.actual->next->expr
+ = gfc_get_int_expr (gfc_default_integer_kind, NULL, i+1);
+ shape_expr->value.function.actual->next->next = gfc_get_actual_arglist ();
+ shape_expr->value.function.actual->next->next->expr
+ = gfc_get_int_expr (gfc_default_integer_kind, NULL, 0);
+ shape_expr->ts = shape_expr->value.function.isym->ts;
+
+ tmp_array->as->upper[i] = shape_expr;
+ }
+ gfc_set_sym_referenced (tmp_array);
+ gfc_commit_symbol (tmp_array);
+
+ /* Create loop. */
+ iter = gfc_get_iterator ();
+ iter->var = gfc_lval_expr_from_sym (idx);
+ iter->start = gfc_get_int_expr (gfc_index_integer_kind, NULL, 0);
+ iter->end = gfc_lval_expr_from_sym (nelem);
+ iter->step = gfc_get_int_expr (gfc_index_integer_kind, NULL, 1);
+
+ block = XCNEW (gfc_code);
+ ns->code = block;
+ block->op = EXEC_DO;
+ block->loc = gfc_current_locus;
+ block->ext.iterator = iter;
+ block->block = gfc_get_code ();
+ block->block->op = EXEC_DO;
+
+ /* Create code for
+ CALL C_F_POINTER (TRANSFER (TRANSFER (C_LOC (array, cptr), c_intptr)
+ + idx * stride, c_ptr), ptr). */
+ block->block->next = finalization_scalarizer (idx, array, ptr,
+ gfc_lval_expr_from_sym (stride),
+ sub_ns);
+ block->block->next->next = finalization_scalarizer (idx, tmp_array, ptr2,
+ gfc_copy_expr (size_expr),
+ sub_ns);
+ /* ptr2 = ptr. */
+ block->block->next->next->next = XCNEW (gfc_code);
+ block->block->next->next->next->op = EXEC_ASSIGN;
+ block->block->next->next->next->loc = gfc_current_locus;
+ block->block->next->next->next->expr1 = gfc_lval_expr_from_sym (ptr2);
+ block->block->next->next->next->expr2 = gfc_lval_expr_from_sym (ptr);
+
+ block->next = XCNEW (gfc_code);
+ block = block->next;
+ block->op = EXEC_CALL;
+ block->loc = gfc_current_locus;
+ block->symtree = fini->proc_tree;
+ block->resolved_sym = fini->proc_tree->n.sym;
+ block->ext.actual = gfc_get_actual_arglist ();
+ block->ext.actual->expr = gfc_lval_expr_from_sym (tmp_array);
+
+ if (fini->proc_tree->n.sym->formal->sym->attr.intent == INTENT_IN)
+ return;
+
+ /* Copy back. */
+
+ /* Loop. */
+ iter = gfc_get_iterator ();
+ iter->var = gfc_lval_expr_from_sym (idx);
+ iter->start = gfc_get_int_expr (gfc_index_integer_kind, NULL, 0);
+ iter->end = gfc_lval_expr_from_sym (nelem);
+ iter->step = gfc_get_int_expr (gfc_index_integer_kind, NULL, 1);
+
+ block->next = XCNEW (gfc_code);
+ block = block->next;
+ block->op = EXEC_DO;
+ block->loc = gfc_current_locus;
+ block->ext.iterator = iter;
+ block->block = gfc_get_code ();
+ block->block->op = EXEC_DO;
+
+ /* Create code for
+ CALL C_F_POINTER (TRANSFER (TRANSFER (C_LOC (array, cptr), c_intptr)
+ + idx * stride, c_ptr), ptr). */
+ block->block->next = finalization_scalarizer (idx, array, ptr,
+ gfc_lval_expr_from_sym (stride),
+ sub_ns);
+ block->block->next->next = finalization_scalarizer (idx, tmp_array, ptr2,
+ gfc_copy_expr (size_expr),
+ sub_ns);
+ /* ptr = ptr2. */
+ block->block->next->next->next = XCNEW (gfc_code);
+ block->block->next->next->next->op = EXEC_ASSIGN;
+ block->block->next->next->next->loc = gfc_current_locus;
+ block->block->next->next->next->expr1 = gfc_lval_expr_from_sym (ptr);
+ block->block->next->next->next->expr2 = gfc_lval_expr_from_sym (ptr2);
+}
+
+
/* Generate the finalization/polymorphic freeing wrapper subroutine for the
derived type "derived". The function first calls the approriate FINAL
subroutine, then it DEALLOCATEs (finalizes/frees) the allocatable
@@ -979,19 +1236,28 @@ finalization_scalarizer (gfc_symbol *idx, gfc_symbol *array, gfc_symbol *ptr,
subroutine of the parent. The generated wrapper procedure takes as argument
an assumed-rank array.
If neither allocatable components nor FINAL subroutines exists, the vtab
- will contain a NULL pointer. */
+ will contain a NULL pointer.
+ The generated function has the form
+ _final(assumed-rank array, stride, skip_corarray)
+ where the array has to be contiguous (except of the lowest dimension). The
+ stride (in bytes) is used to allow different sizes for ancestor types by
+ skipping over the additionally added components in the scalarizer. If
+ "fini_coarray" is false, coarray components are not finalized to allow for
+ the correct semantic with intrinsic assignment. */
static void
generate_finalization_wrapper (gfc_symbol *derived, gfc_namespace *ns,
const char *tname, gfc_component *vtab_final)
{
- gfc_symbol *final, *array, *nelem;
+ gfc_symbol *final, *array, *nelem, *fini_coarray, *stride;
gfc_symbol *ptr = NULL, *idx = NULL;
+ gfc_symtree *size_intr;
gfc_component *comp;
gfc_namespace *sub_ns;
gfc_code *last_code;
char name[GFC_MAX_SYMBOL_LEN+1];
bool finalizable_comp = false;
+ bool expr_null_wrapper = false;
gfc_expr *ancestor_wrapper = NULL;
/* Search for the ancestor's finalizers. */
@@ -1002,7 +1268,7 @@ generate_finalization_wrapper (gfc_symbol *derived, gfc_namespace *ns,
gfc_symbol *vtab;
gfc_component *comp;
- vtab = gfc_find_derived_vtab (derived->components->ts.u.derived);
+ vtab = gfc_get_derived_vtab (derived->components->ts.u.derived);
for (comp = vtab->ts.u.derived->components; comp; comp = comp->next)
if (comp->name[0] == '_' && comp->name[1] == 'f')
{
@@ -1011,40 +1277,44 @@ generate_finalization_wrapper (gfc_symbol *derived, gfc_namespace *ns,
}
}
- /* No wrapper of the ancestor and no own FINAL subroutines and
- allocatable components: Return a NULL() expression. */
+ /* No wrapper of the ancestor and no own FINAL subroutines and allocatable
+ components: Return a NULL() expression; we defer this a bit to have have
+ an interface declaration. */
if ((!ancestor_wrapper || ancestor_wrapper->expr_type == EXPR_NULL)
&& !derived->attr.alloc_comp
&& (!derived->f2k_derived || !derived->f2k_derived->finalizers)
&& !has_finalizer_component (derived))
- {
- vtab_final->initializer = gfc_get_null_expr (NULL);
- return;
- }
-
- /* Check whether there are new allocatable components. */
- for (comp = derived->components; comp; comp = comp->next)
- {
- if (comp == derived->components && derived->attr.extension
- && ancestor_wrapper && ancestor_wrapper->expr_type != EXPR_NULL)
+ expr_null_wrapper = true;
+ else
+ /* Check whether there are new allocatable components. */
+ for (comp = derived->components; comp; comp = comp->next)
+ {
+ if (comp == derived->components && derived->attr.extension
+ && ancestor_wrapper && ancestor_wrapper->expr_type != EXPR_NULL)
continue;
- if (comp->ts.type != BT_CLASS && !comp->attr.pointer
- && (comp->attr.alloc_comp || comp->attr.allocatable
- || (comp->ts.type == BT_DERIVED
- && has_finalizer_component (comp->ts.u.derived))))
- finalizable_comp = true;
- else if (comp->ts.type == BT_CLASS && CLASS_DATA (comp)
- && CLASS_DATA (comp)->attr.allocatable)
- finalizable_comp = true;
- }
+ 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;
+ }
/* If there is no new finalizer and no new allocatable, return with
an expr to the ancestor's one. */
- if ((!derived->f2k_derived || !derived->f2k_derived->finalizers)
- && !finalizable_comp)
+ if (!expr_null_wrapper && !finalizable_comp
+ && (!derived->f2k_derived || !derived->f2k_derived->finalizers))
{
+ gcc_assert (ancestor_wrapper && ancestor_wrapper->ref == NULL
+ && ancestor_wrapper->expr_type == EXPR_VARIABLE);
vtab_final->initializer = gfc_copy_expr (ancestor_wrapper);
+ vtab_final->ts.interface = vtab_final->initializer->symtree->n.sym;
return;
}
@@ -1057,12 +1327,13 @@ generate_finalization_wrapper (gfc_symbol *derived, gfc_namespace *ns,
3. Call the ancestor's finalizer. */
/* Declare the wrapper function; it takes an assumed-rank array
- as argument. */
+ and a VALUE logical as arguments. */
/* Set up the namespace. */
sub_ns = gfc_get_namespace (ns, 0);
sub_ns->sibling = ns->contained;
- ns->contained = sub_ns;
+ if (!expr_null_wrapper)
+ ns->contained = sub_ns;
sub_ns->resolved = 1;
/* Set up the procedure symbol. */
@@ -1070,13 +1341,17 @@ generate_finalization_wrapper (gfc_symbol *derived, gfc_namespace *ns,
gfc_get_symbol (name, sub_ns, &final);
sub_ns->proc_name = final;
final->attr.flavor = FL_PROCEDURE;
- final->attr.subroutine = 1;
- final->attr.pure = 1;
+ final->attr.function = 1;
+ final->attr.pure = 0;
+ final->result = final;
+ final->ts.type = BT_INTEGER;
+ final->ts.kind = 4;
final->attr.artificial = 1;
- final->attr.if_source = IFSRC_DECL;
+ 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;
gfc_set_sym_referenced (final);
+ gfc_commit_symbol (final);
/* Set up formal argument. */
gfc_get_symbol ("array", sub_ns, &array);
@@ -1096,6 +1371,50 @@ generate_finalization_wrapper (gfc_symbol *derived, gfc_namespace *ns,
final->formal->sym = array;
gfc_commit_symbol (array);
+ /* Set up formal argument. */
+ gfc_get_symbol ("stride", sub_ns, &stride);
+ stride->ts.type = BT_INTEGER;
+ stride->ts.kind = gfc_index_integer_kind;
+ stride->attr.flavor = FL_VARIABLE;
+ stride->attr.dummy = 1;
+ stride->attr.value = 1;
+ stride->attr.artificial = 1;
+ gfc_set_sym_referenced (stride);
+ final->formal->next = gfc_get_formal_arglist ();
+ final->formal->next->sym = stride;
+ gfc_commit_symbol (stride);
+
+ /* Set up formal argument. */
+ gfc_get_symbol ("fini_coarray", sub_ns, &fini_coarray);
+ fini_coarray->ts.type = BT_LOGICAL;
+ fini_coarray->ts.kind = 4;
+ fini_coarray->attr.flavor = FL_VARIABLE;
+ fini_coarray->attr.dummy = 1;
+ fini_coarray->attr.value = 1;
+ fini_coarray->attr.artificial = 1;
+ gfc_set_sym_referenced (fini_coarray);
+ final->formal->next->next = gfc_get_formal_arglist ();
+ final->formal->next->next->sym = fini_coarray;
+ gfc_commit_symbol (fini_coarray);
+
+ /* Return with a NULL() expression but with an interface which has
+ the formal arguments. */
+ if (expr_null_wrapper)
+ {
+ vtab_final->initializer = gfc_get_null_expr (NULL);
+ vtab_final->ts.interface = final;
+ return;
+ }
+
+
+ /* Set return value to 0. */
+ last_code = XCNEW (gfc_code);
+ last_code->op = EXEC_ASSIGN;
+ last_code->loc = gfc_current_locus;
+ last_code->expr1 = gfc_lval_expr_from_sym (final);
+ last_code->expr2 = gfc_get_int_expr (4, NULL, 0);
+ sub_ns->code = last_code;
+
/* Obtain the size (number of elements) of "array" MINUS ONE,
which is used in the scalarization. */
gfc_get_symbol ("nelem", sub_ns, &nelem);
@@ -1107,7 +1426,8 @@ generate_finalization_wrapper (gfc_symbol *derived, gfc_namespace *ns,
gfc_commit_symbol (nelem);
/* Generate: nelem = SIZE (array) - 1. */
- last_code = XCNEW (gfc_code);
+ last_code->next = XCNEW (gfc_code);
+ last_code = last_code->next;
last_code->op = EXEC_ASSIGN;
last_code->loc = gfc_current_locus;
@@ -1126,6 +1446,7 @@ generate_finalization_wrapper (gfc_symbol *derived, gfc_namespace *ns,
= gfc_intrinsic_function_by_id (GFC_ISYM_SIZE);
gfc_get_sym_tree ("size", sub_ns, &last_code->expr2->value.op.op1->symtree,
false);
+ size_intr = last_code->expr2->value.op.op1->symtree;
last_code->expr2->value.op.op1->symtree->n.sym->attr.flavor = FL_PROCEDURE;
last_code->expr2->value.op.op1->symtree->n.sym->attr.intrinsic = 1;
gfc_commit_symbol (last_code->expr2->value.op.op1->symtree->n.sym);
@@ -1154,10 +1475,11 @@ generate_finalization_wrapper (gfc_symbol *derived, gfc_namespace *ns,
select case (rank (array))
case (3)
+ ! If needed, the array is packed
call final_rank3 (array)
case default:
do i = 0, size (array)-1
- addr = transfer (c_loc (array), addr) + i * STORAGE_SIZE (array)
+ addr = transfer (c_loc (array), addr) + i * stride
call c_f_pointer (transfer (addr, cptr), ptr)
call elemental_final (ptr)
end do
@@ -1168,6 +1490,23 @@ generate_finalization_wrapper (gfc_symbol *derived, gfc_namespace *ns,
gfc_finalizer *fini, *fini_elem = NULL;
gfc_code *block = NULL;
+ gfc_get_symbol ("idx", sub_ns, &idx);
+ idx->ts.type = BT_INTEGER;
+ idx->ts.kind = gfc_index_integer_kind;
+ idx->attr.flavor = FL_VARIABLE;
+ idx->attr.artificial = 1;
+ gfc_set_sym_referenced (idx);
+ gfc_commit_symbol (idx);
+
+ gfc_get_symbol ("ptr", sub_ns, &ptr);
+ ptr->ts.type = BT_DERIVED;
+ ptr->ts.u.derived = derived;
+ ptr->attr.flavor = FL_VARIABLE;
+ ptr->attr.pointer = 1;
+ ptr->attr.artificial = 1;
+ gfc_set_sym_referenced (ptr);
+ gfc_commit_symbol (ptr);
+
/* SELECT CASE (RANK (array)). */
last_code->next = XCNEW (gfc_code);
last_code = last_code->next;
@@ -1221,14 +1560,20 @@ generate_finalization_wrapper (gfc_symbol *derived, gfc_namespace *ns,
block->ext.block.case_list->high
= block->ext.block.case_list->low;
- /* CALL fini_rank (array). */
- block->next = XCNEW (gfc_code);
- block->next->op = EXEC_CALL;
- block->next->loc = gfc_current_locus;
- block->next->symtree = fini->proc_tree;
- 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);
+ /* CALL fini_rank (array) - possibly with packing. */
+ if (fini->proc_tree->n.sym->formal->sym->attr.dimension)
+ finalizer_insert_packed_call (block, fini, array, stride, idx, ptr,
+ nelem, size_intr, sub_ns);
+ else
+ {
+ block->next = XCNEW (gfc_code);
+ block->next->op = EXEC_CALL;
+ block->next->loc = gfc_current_locus;
+ block->next->symtree = fini->proc_tree;
+ 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);
+ }
}
/* Elemental call - scalarized. */
@@ -1251,23 +1596,6 @@ generate_finalization_wrapper (gfc_symbol *derived, gfc_namespace *ns,
block->op = EXEC_SELECT;
block->ext.block.case_list = gfc_get_case ();
- gfc_get_symbol ("idx", sub_ns, &idx);
- idx->ts.type = BT_INTEGER;
- idx->ts.kind = gfc_index_integer_kind;
- idx->attr.flavor = FL_VARIABLE;
- idx->attr.artificial = 1;
- gfc_set_sym_referenced (idx);
- gfc_commit_symbol (idx);
-
- gfc_get_symbol ("ptr", sub_ns, &ptr);
- ptr->ts.type = BT_DERIVED;
- ptr->ts.u.derived = derived;
- ptr->attr.flavor = FL_VARIABLE;
- ptr->attr.pointer = 1;
- ptr->attr.artificial = 1;
- gfc_set_sym_referenced (ptr);
- gfc_commit_symbol (ptr);
-
/* Create loop. */
iter = gfc_get_iterator ();
iter->var = gfc_lval_expr_from_sym (idx);
@@ -1284,8 +1612,11 @@ generate_finalization_wrapper (gfc_symbol *derived, gfc_namespace *ns,
/* Create code for
CALL C_F_POINTER (TRANSFER (TRANSFER (C_LOC (array, cptr), c_intptr)
- + idx * STORAGE_SIZE (array), c_ptr), ptr). */
- block->block->next = finalization_scalarizer (idx, array, ptr, sub_ns);
+ + idx * stride, c_ptr), ptr). */
+ block->block->next
+ = finalization_scalarizer (idx, array, ptr,
+ gfc_lval_expr_from_sym (stride),
+ sub_ns);
block = block->block->next;
/* CALL final_elemental (array). */
@@ -1356,8 +1687,11 @@ generate_finalization_wrapper (gfc_symbol *derived, gfc_namespace *ns,
/* Create code for
CALL C_F_POINTER (TRANSFER (TRANSFER (C_LOC (array, cptr), c_intptr)
- + idx * STORAGE_SIZE (array), c_ptr), ptr). */
- last_code->block->next = finalization_scalarizer (idx, array, ptr, sub_ns);
+ + idx * stride, c_ptr), ptr). */
+ last_code->block->next
+ = finalization_scalarizer (idx, array, ptr,
+ gfc_lval_expr_from_sym (stride),
+ sub_ns);
block = last_code->block->next;
for (comp = derived->components; comp; comp = comp->next)
@@ -1367,7 +1701,7 @@ generate_finalization_wrapper (gfc_symbol *derived, gfc_namespace *ns,
continue;
finalize_component (gfc_lval_expr_from_sym (ptr), derived, comp,
- gfc_lval_expr_from_sym (stat), &block);
+ stat, fini_coarray, &block);
if (!last_code->block->next)
last_code->block->next = block;
}
@@ -1386,9 +1720,13 @@ generate_finalization_wrapper (gfc_symbol *derived, gfc_namespace *ns,
last_code->ext.actual = gfc_get_actual_arglist ();
last_code->ext.actual->expr = gfc_lval_expr_from_sym (array);
+ last_code->ext.actual->next = gfc_get_actual_arglist ();
+ last_code->ext.actual->next->expr = gfc_lval_expr_from_sym (stride);
+ last_code->ext.actual->next->next = gfc_get_actual_arglist ();
+ last_code->ext.actual->next->next->expr
+ = gfc_lval_expr_from_sym (fini_coarray);
}
- gfc_commit_symbol (final);
vtab_final->initializer = gfc_lval_expr_from_sym (final);
vtab_final->ts.interface = final;
}
@@ -1419,10 +1757,10 @@ add_procs_to_declared_vtab (gfc_symbol *derived, gfc_symbol *vtype)
}
-/* Find (or generate) the symbol for a derived type's vtab. */
+/* Find or generate the symbol for a derived type's vtab. */
-gfc_symbol *
-gfc_find_derived_vtab (gfc_symbol *derived)
+static gfc_symbol *
+find_derived_vtab (gfc_symbol *derived, bool generate)
{
gfc_namespace *ns;
gfc_symbol *vtab = NULL, *vtype = NULL, *found_sym = NULL, *def_init = NULL;
@@ -1440,7 +1778,7 @@ gfc_find_derived_vtab (gfc_symbol *derived)
if (ns)
{
char name[GFC_MAX_SYMBOL_LEN+1], tname[GFC_MAX_SYMBOL_LEN+1];
-
+
get_unique_hashed_string (tname, derived);
sprintf (name, "__vtab_%s", tname);
@@ -1451,6 +1789,9 @@ gfc_find_derived_vtab (gfc_symbol *derived)
if (vtab == NULL)
gfc_find_symbol (name, derived->ns, 0, &vtab);
+ if (!generate && !vtab)
+ return NULL;
+
if (vtab == NULL)
{
gfc_get_symbol (name, ns, &vtab);
@@ -1464,7 +1805,7 @@ gfc_find_derived_vtab (gfc_symbol *derived)
vtab->attr.access = ACCESS_PUBLIC;
gfc_set_sym_referenced (vtab);
sprintf (name, "__vtype_%s", tname);
-
+
gfc_find_symbol (name, ns, 0, &vtype);
if (vtype == NULL)
{
@@ -1509,7 +1850,7 @@ gfc_find_derived_vtab (gfc_symbol *derived)
parent = gfc_get_derived_super_type (derived);
if (parent)
{
- parent_vtab = gfc_find_derived_vtab (parent);
+ parent_vtab = gfc_get_derived_vtab (parent);
c->ts.type = BT_DERIVED;
c->ts.u.derived = parent_vtab->ts.u.derived;
c->initializer = gfc_get_expr ();
@@ -1675,6 +2016,20 @@ cleanup:
}
+gfc_symbol *
+gfc_find_derived_vtab (gfc_symbol *derived)
+{
+ return find_derived_vtab (derived, false);
+}
+
+
+gfc_symbol *
+gfc_get_derived_vtab (gfc_symbol *derived)
+{
+ return find_derived_vtab (derived, true);
+}
+
+
/* General worker function to find either a type-bound procedure or a
type-bound user operator. */
@@ -3571,7 +3571,7 @@ gfc_check_pointer_assign (gfc_expr *lvalue, gfc_expr *rvalue)
if (lvalue->ts.type == BT_CLASS && rvalue->ts.type == BT_DERIVED)
/* Make sure the vtab is present. */
- gfc_find_derived_vtab (rvalue->ts.u.derived);
+ gfc_get_derived_vtab (rvalue->ts.u.derived);
/* Check rank remapping. */
if (rank_remap)
@@ -2956,6 +2956,7 @@ unsigned int gfc_hash_value (gfc_symbol *);
gfc_try gfc_build_class_symbol (gfc_typespec *, symbol_attribute *,
gfc_array_spec **, bool);
gfc_symbol *gfc_find_derived_vtab (gfc_symbol *);
+gfc_symbol *gfc_get_derived_vtab (gfc_symbol *);
gfc_symtree* gfc_find_typebound_proc (gfc_symbol*, gfc_try*,
const char*, bool, locus*);
gfc_symtree* gfc_find_typebound_user_op (gfc_symbol*, gfc_try*,
@@ -1847,7 +1847,7 @@ compare_parameter (gfc_symbol *formal, gfc_expr *actual,
if (formal->ts.type == BT_CLASS && actual->ts.type == BT_DERIVED)
/* Make sure the vtab symbol is present when
the module variables are generated. */
- gfc_find_derived_vtab (actual->ts.u.derived);
+ gfc_get_derived_vtab (actual->ts.u.derived);
if (actual->ts.type == BT_PROCEDURE)
{
@@ -945,7 +945,7 @@ gfc_resolve_extends_type_of (gfc_expr *f, gfc_expr *a, gfc_expr *mo)
gfc_add_vptr_component (a);
else if (a->ts.type == BT_DERIVED)
{
- vtab = gfc_find_derived_vtab (a->ts.u.derived);
+ vtab = gfc_get_derived_vtab (a->ts.u.derived);
/* Clear the old expr. */
gfc_free_ref_list (a->ref);
memset (a, '\0', sizeof (gfc_expr));
@@ -961,7 +961,7 @@ gfc_resolve_extends_type_of (gfc_expr *f, gfc_expr *a, gfc_expr *mo)
gfc_add_vptr_component (mo);
else if (mo->ts.type == BT_DERIVED)
{
- vtab = gfc_find_derived_vtab (mo->ts.u.derived);
+ vtab = gfc_get_derived_vtab (mo->ts.u.derived);
/* Clear the old expr. */
gfc_free_ref_list (mo->ref);
memset (mo, '\0', sizeof (gfc_expr));
@@ -6214,7 +6214,7 @@ resolve_typebound_function (gfc_expr* e)
declared = ts.u.derived;
c = gfc_find_component (declared, "_vptr", true, true);
if (c->ts.u.derived == NULL)
- c->ts.u.derived = gfc_find_derived_vtab (declared);
+ c->ts.u.derived = gfc_get_derived_vtab (declared);
if (resolve_compcall (e, &name) == FAILURE)
return FAILURE;
@@ -6342,7 +6342,7 @@ resolve_typebound_subroutine (gfc_code *code)
declared = expr->ts.u.derived;
c = gfc_find_component (declared, "_vptr", true, true);
if (c->ts.u.derived == NULL)
- c->ts.u.derived = gfc_find_derived_vtab (declared);
+ c->ts.u.derived = gfc_get_derived_vtab (declared);
if (resolve_typebound_call (code, &name) == FAILURE)
return FAILURE;
@@ -7369,7 +7369,7 @@ resolve_allocate_expr (gfc_expr *e, gfc_code *code)
ts = code->expr3->ts;
else if (code->ext.alloc.ts.type == BT_DERIVED)
ts = code->ext.alloc.ts;
- gfc_find_derived_vtab (ts.u.derived);
+ gfc_get_derived_vtab (ts.u.derived);
if (dimension)
e = gfc_expr_to_initialize (e);
}
@@ -8567,7 +8567,7 @@ resolve_select_type (gfc_code *code, gfc_namespace *old_ns)
new_st->expr1->value.function.actual->expr = gfc_get_variable_expr (code->expr1->symtree);
new_st->expr1->value.function.actual->expr->where = code->loc;
gfc_add_vptr_component (new_st->expr1->value.function.actual->expr);
- vtab = gfc_find_derived_vtab (body->ext.block.case_list->ts.u.derived);
+ vtab = gfc_get_derived_vtab (body->ext.block.case_list->ts.u.derived);
st = gfc_find_symtree (vtab->ns->sym_root, vtab->name);
new_st->expr1->value.function.actual->next = gfc_get_actual_arglist ();
new_st->expr1->value.function.actual->next->expr = gfc_get_variable_expr (st);
@@ -11290,7 +11290,7 @@ error:
gfc_error ("Finalization at %L is not yet implemented",
&derived->declared_at);
- gfc_find_derived_vtab (derived);
+ gfc_get_derived_vtab (derived);
return result;
}
@@ -11850,7 +11850,7 @@ resolve_typebound_procedures (gfc_symbol* derived)
resolve_bindings_result = SUCCESS;
/* Make sure the vtab has been generated. */
- gfc_find_derived_vtab (derived);
+ gfc_get_derived_vtab (derived);
if (derived->f2k_derived->tb_sym_root)
gfc_traverse_symtree (derived->f2k_derived->tb_sym_root,
@@ -12405,7 +12405,7 @@ resolve_fl_derived (gfc_symbol *sym)
gfc_component *vptr = gfc_find_component (sym, "_vptr", true, true);
if (vptr->ts.u.derived == NULL)
{
- gfc_symbol *vtab = gfc_find_derived_vtab (data->ts.u.derived);
+ gfc_symbol *vtab = gfc_get_derived_vtab (data->ts.u.derived);
gcc_assert (vtab);
vptr->ts.u.derived = vtab->ts.u.derived;
}
@@ -12618,6 +12618,9 @@ resolve_symbol (gfc_symbol *sym)
if (sym->attr.artificial)
return;
+ if (sym->attr.artificial)
+ return;
+
if (sym->attr.flavor == FL_UNKNOWN
|| (sym->attr.flavor == FL_PROCEDURE && !sym->attr.intrinsic
&& !sym->attr.generic && !sym->attr.external
@@ -1206,7 +1206,7 @@ gfc_get_symbol_decl (gfc_symbol * sym)
gfc_component *c = CLASS_DATA (sym);
if (!c->ts.u.derived->backend_decl)
{
- gfc_find_derived_vtab (c->ts.u.derived);
+ gfc_get_derived_vtab (c->ts.u.derived);
gfc_get_derived_type (sym->ts.u.derived);
}
}
@@ -263,7 +263,7 @@ gfc_conv_derived_to_class (gfc_se *parmse, gfc_expr *e,
{
/* In this case the vtab corresponds to the derived type and the
vptr must point to it. */
- vtab = gfc_find_derived_vtab (e->ts.u.derived);
+ vtab = gfc_get_derived_vtab (e->ts.u.derived);
gcc_assert (vtab);
tmp = gfc_build_addr_expr (NULL_TREE, gfc_get_symbol_decl (vtab));
}
@@ -859,9 +859,9 @@ gfc_trans_class_assign (gfc_expr *expr1, gfc_expr *expr2, gfc_exec_op op)
gfc_add_vptr_component (lhs);
if (expr2->ts.type == BT_DERIVED)
- vtab = gfc_find_derived_vtab (expr2->ts.u.derived);
+ vtab = gfc_get_derived_vtab (expr2->ts.u.derived);
else if (expr2->expr_type == EXPR_NULL)
- vtab = gfc_find_derived_vtab (expr1->ts.u.derived);
+ vtab = gfc_get_derived_vtab (expr1->ts.u.derived);
gcc_assert (vtab);
rhs = gfc_get_expr ();
@@ -7356,7 +7356,7 @@ conv_intrinsic_move_alloc (gfc_code *code)
else
{
gfc_symbol *vtab;
- vtab = gfc_find_derived_vtab (from_expr->ts.u.derived);
+ vtab = gfc_get_derived_vtab (from_expr->ts.u.derived);
gcc_assert (vtab);
tmp = gfc_build_addr_expr (NULL_TREE, gfc_get_symbol_decl (vtab));
}
@@ -7387,7 +7387,7 @@ conv_intrinsic_move_alloc (gfc_code *code)
else
{
gfc_symbol *vtab;
- vtab = gfc_find_derived_vtab (from_expr->ts.u.derived);
+ vtab = gfc_get_derived_vtab (from_expr->ts.u.derived);
gcc_assert (vtab);
tmp = gfc_build_addr_expr (NULL_TREE, gfc_get_symbol_decl (vtab));
}
@@ -5099,7 +5099,7 @@ gfc_trans_allocate (gfc_code * code)
if (ts->type == BT_DERIVED)
{
- vtab = gfc_find_derived_vtab (ts->u.derived);
+ vtab = gfc_get_derived_vtab (ts->u.derived);
gcc_assert (vtab);
gfc_init_se (&lse, NULL);
lse.want_pointer = 1;
@@ -5186,7 +5186,7 @@ gfc_trans_allocate (gfc_code * code)
}
else
ppc = gfc_lval_expr_from_sym
- (gfc_find_derived_vtab (rhs->ts.u.derived));
+ (gfc_get_derived_vtab (rhs->ts.u.derived));
gfc_add_component_ref (ppc, "_copy");
ppc_code = gfc_get_code ();
@@ -5393,7 +5393,7 @@ gfc_trans_deallocate (gfc_code *code)
{
/* Reset _vptr component to declared type. */
gfc_expr *rhs, *lhs = gfc_copy_expr (al->expr);
- gfc_symbol *vtab = gfc_find_derived_vtab (al->expr->ts.u.derived);
+ gfc_symbol *vtab = gfc_get_derived_vtab (al->expr->ts.u.derived);
gfc_add_vptr_component (lhs);
rhs = gfc_lval_expr_from_sym (vtab);
tmp = gfc_trans_pointer_assignment (lhs, rhs);