re PR fortran/37336 ([F03] Finish derived-type finalization)
2012-11-03 Tobias Burnus <burnus@net-b.de> PR fortran/37336 * class.c (finalizer_insert_packed_call): New static function. (finalize_component, generate_finalization_wrapper): Fix coarray handling and packing. From-SVN: r194075
This commit is contained in:
parent
9cc263b852
commit
29a7d776ea
|
@ -1,3 +1,10 @@
|
||||||
|
2012-11-03 Tobias Burnus <burnus@net-b.de>
|
||||||
|
|
||||||
|
PR fortran/37336
|
||||||
|
* class.c (finalizer_insert_packed_call): New static function.
|
||||||
|
(finalize_component, generate_finalization_wrapper):
|
||||||
|
Fix coarray handling and packing.
|
||||||
|
|
||||||
2012-12-02 Paul Thomas <pault@gcc.gnu.org>
|
2012-12-02 Paul Thomas <pault@gcc.gnu.org>
|
||||||
|
|
||||||
* resolve.c (resolve_allocate_deallocate,
|
* resolve.c (resolve_allocate_deallocate,
|
||||||
|
@ -5,7 +12,7 @@
|
||||||
193778, which were accidentally reverted by the previous patch.
|
193778, which were accidentally reverted by the previous patch.
|
||||||
|
|
||||||
2012-12-01 Alessandro Fanfarillo <alessandro.fanfarillo@gmail.com>
|
2012-12-01 Alessandro Fanfarillo <alessandro.fanfarillo@gmail.com>
|
||||||
Paul Thomas <pault@gcc.gnu.org>
|
Paul Thomas <pault@gcc.gnu.org>
|
||||||
|
|
||||||
PR fortran/46897
|
PR fortran/46897
|
||||||
* gfortran.h : Add bit field 'defined_assign_comp' to
|
* gfortran.h : Add bit field 'defined_assign_comp' to
|
||||||
|
|
|
@ -731,7 +731,7 @@ has_finalizer_component (gfc_symbol *derived)
|
||||||
|
|
||||||
static void
|
static void
|
||||||
finalize_component (gfc_expr *expr, gfc_symbol *derived, gfc_component *comp,
|
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_expr *e;
|
||||||
gfc_ref *ref;
|
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;
|
e->rank = ref->next->u.ar.as->rank;
|
||||||
}
|
}
|
||||||
|
|
||||||
|
/* Call DEALLOCATE (comp, stat=ignore). */
|
||||||
if (comp->attr.allocatable
|
if (comp->attr.allocatable
|
||||||
|| (comp->ts.type == BT_CLASS && CLASS_DATA (comp)
|
|| (comp->ts.type == BT_CLASS && CLASS_DATA (comp)
|
||||||
&& CLASS_DATA (comp)->attr.allocatable))
|
&& CLASS_DATA (comp)->attr.allocatable))
|
||||||
{
|
{
|
||||||
/* Call DEALLOCATE (comp, stat=ignore). */
|
gfc_code *dealloc, *block = NULL;
|
||||||
gfc_code *dealloc;
|
|
||||||
|
/* 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 = XCNEW (gfc_code);
|
||||||
dealloc->op = EXEC_DEALLOCATE;
|
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 = gfc_get_alloc ();
|
||||||
dealloc->ext.alloc.list->expr = e;
|
dealloc->ext.alloc.list->expr = e;
|
||||||
|
dealloc->expr1 = gfc_lval_expr_from_sym (stat);
|
||||||
|
|
||||||
dealloc->expr1 = stat;
|
if (block)
|
||||||
if (*code)
|
block->next = dealloc;
|
||||||
|
else if (*code)
|
||||||
{
|
{
|
||||||
(*code)->next = dealloc;
|
(*code)->next = dealloc;
|
||||||
(*code) = (*code)->next;
|
(*code) = (*code)->next;
|
||||||
|
@ -839,7 +865,7 @@ finalize_component (gfc_expr *expr, gfc_symbol *derived, gfc_component *comp,
|
||||||
gfc_component *c;
|
gfc_component *c;
|
||||||
|
|
||||||
for (c = comp->ts.u.derived->components; c; c = c->next)
|
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);
|
gfc_free_expr (e);
|
||||||
}
|
}
|
||||||
}
|
}
|
||||||
|
@ -847,12 +873,11 @@ finalize_component (gfc_expr *expr, gfc_symbol *derived, gfc_component *comp,
|
||||||
|
|
||||||
/* Generate code equivalent to
|
/* Generate code equivalent to
|
||||||
CALL C_F_POINTER (TRANSFER (TRANSFER (C_LOC (array, cptr), c_intptr)
|
CALL C_F_POINTER (TRANSFER (TRANSFER (C_LOC (array, cptr), c_intptr)
|
||||||
+ idx * STORAGE_SIZE (array)/NUMERIC_STORAGE_SIZE., c_ptr),
|
+ idx * stride, c_ptr), ptr). */
|
||||||
ptr). */
|
|
||||||
|
|
||||||
static gfc_code *
|
static gfc_code *
|
||||||
finalization_scalarizer (gfc_symbol *idx, gfc_symbol *array, gfc_symbol *ptr,
|
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_code *block;
|
||||||
gfc_expr *expr, *expr2, *expr3;
|
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;
|
expr->ts.kind = gfc_index_integer_kind;
|
||||||
expr2->value.function.actual->expr = expr;
|
expr2->value.function.actual->expr = expr;
|
||||||
|
|
||||||
/* STORAGE_SIZE (...) / NUMERIC_STORAGE_SIZE. */
|
/* Offset calculation: idx * stride (in bytes). */
|
||||||
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). */
|
|
||||||
block->ext.actual->expr = gfc_get_expr ();
|
block->ext.actual->expr = gfc_get_expr ();
|
||||||
expr3 = block->ext.actual->expr;
|
expr3 = block->ext.actual->expr;
|
||||||
expr3->expr_type = EXPR_OP;
|
expr3->expr_type = EXPR_OP;
|
||||||
expr3->value.op.op = INTRINSIC_TIMES;
|
expr3->value.op.op = INTRINSIC_TIMES;
|
||||||
expr3->value.op.op1 = gfc_lval_expr_from_sym (idx);
|
expr3->value.op.op1 = gfc_lval_expr_from_sym (idx);
|
||||||
expr3->value.op.op2 = expr;
|
expr3->value.op.op2 = stride;
|
||||||
expr3->ts = expr->ts;
|
expr3->ts = expr->ts;
|
||||||
|
|
||||||
/* <array addr> + <offset>. */
|
/* <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
|
/* Generate the finalization/polymorphic freeing wrapper subroutine for the
|
||||||
derived type "derived". The function first calls the approriate FINAL
|
derived type "derived". The function first calls the approriate FINAL
|
||||||
subroutine, then it DEALLOCATEs (finalizes/frees) the allocatable
|
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
|
subroutine of the parent. The generated wrapper procedure takes as argument
|
||||||
an assumed-rank array.
|
an assumed-rank array.
|
||||||
If neither allocatable components nor FINAL subroutines exists, the vtab
|
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
|
static void
|
||||||
generate_finalization_wrapper (gfc_symbol *derived, gfc_namespace *ns,
|
generate_finalization_wrapper (gfc_symbol *derived, gfc_namespace *ns,
|
||||||
const char *tname, gfc_component *vtab_final)
|
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_symbol *ptr = NULL, *idx = NULL;
|
||||||
|
gfc_symtree *size_intr;
|
||||||
gfc_component *comp;
|
gfc_component *comp;
|
||||||
gfc_namespace *sub_ns;
|
gfc_namespace *sub_ns;
|
||||||
gfc_code *last_code;
|
gfc_code *last_code;
|
||||||
char name[GFC_MAX_SYMBOL_LEN+1];
|
char name[GFC_MAX_SYMBOL_LEN+1];
|
||||||
bool finalizable_comp = false;
|
bool finalizable_comp = false;
|
||||||
|
bool expr_null_wrapper = false;
|
||||||
gfc_expr *ancestor_wrapper = NULL;
|
gfc_expr *ancestor_wrapper = NULL;
|
||||||
|
|
||||||
/* Search for the ancestor's finalizers. */
|
/* Search for the ancestor's finalizers. */
|
||||||
|
@ -1011,40 +1277,44 @@ generate_finalization_wrapper (gfc_symbol *derived, gfc_namespace *ns,
|
||||||
}
|
}
|
||||||
}
|
}
|
||||||
|
|
||||||
/* No wrapper of the ancestor and no own FINAL subroutines and
|
/* No wrapper of the ancestor and no own FINAL subroutines and allocatable
|
||||||
allocatable components: Return a NULL() expression. */
|
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)
|
if ((!ancestor_wrapper || ancestor_wrapper->expr_type == EXPR_NULL)
|
||||||
&& !derived->attr.alloc_comp
|
&& !derived->attr.alloc_comp
|
||||||
&& (!derived->f2k_derived || !derived->f2k_derived->finalizers)
|
&& (!derived->f2k_derived || !derived->f2k_derived->finalizers)
|
||||||
&& !has_finalizer_component (derived))
|
&& !has_finalizer_component (derived))
|
||||||
{
|
expr_null_wrapper = true;
|
||||||
vtab_final->initializer = gfc_get_null_expr (NULL);
|
else
|
||||||
return;
|
/* Check whether there are new allocatable components. */
|
||||||
}
|
for (comp = derived->components; comp; comp = comp->next)
|
||||||
|
{
|
||||||
/* Check whether there are new allocatable components. */
|
if (comp == derived->components && derived->attr.extension
|
||||||
for (comp = derived->components; comp; comp = comp->next)
|
&& ancestor_wrapper && ancestor_wrapper->expr_type != EXPR_NULL)
|
||||||
{
|
|
||||||
if (comp == derived->components && derived->attr.extension
|
|
||||||
&& ancestor_wrapper && ancestor_wrapper->expr_type != EXPR_NULL)
|
|
||||||
continue;
|
continue;
|
||||||
|
|
||||||
if (comp->ts.type != BT_CLASS && !comp->attr.pointer
|
if (comp->ts.type != BT_CLASS && !comp->attr.pointer
|
||||||
&& (comp->attr.alloc_comp || comp->attr.allocatable
|
&& (comp->attr.allocatable
|
||||||
|| (comp->ts.type == BT_DERIVED
|
|| (comp->ts.type == BT_DERIVED
|
||||||
&& has_finalizer_component (comp->ts.u.derived))))
|
&& (comp->ts.u.derived->attr.alloc_comp
|
||||||
finalizable_comp = true;
|
|| has_finalizer_component (comp->ts.u.derived)
|
||||||
else if (comp->ts.type == BT_CLASS && CLASS_DATA (comp)
|
|| (comp->ts.u.derived->f2k_derived
|
||||||
&& CLASS_DATA (comp)->attr.allocatable)
|
&& comp->ts.u.derived->f2k_derived->finalizers)))))
|
||||||
finalizable_comp = true;
|
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
|
/* If there is no new finalizer and no new allocatable, return with
|
||||||
an expr to the ancestor's one. */
|
an expr to the ancestor's one. */
|
||||||
if ((!derived->f2k_derived || !derived->f2k_derived->finalizers)
|
if (!expr_null_wrapper && !finalizable_comp
|
||||||
&& !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->initializer = gfc_copy_expr (ancestor_wrapper);
|
||||||
|
vtab_final->ts.interface = vtab_final->initializer->symtree->n.sym;
|
||||||
return;
|
return;
|
||||||
}
|
}
|
||||||
|
|
||||||
|
@ -1057,12 +1327,13 @@ generate_finalization_wrapper (gfc_symbol *derived, gfc_namespace *ns,
|
||||||
3. Call the ancestor's finalizer. */
|
3. Call the ancestor's finalizer. */
|
||||||
|
|
||||||
/* Declare the wrapper function; it takes an assumed-rank array
|
/* Declare the wrapper function; it takes an assumed-rank array
|
||||||
as argument. */
|
and a VALUE logical as arguments. */
|
||||||
|
|
||||||
/* Set up the namespace. */
|
/* Set up the namespace. */
|
||||||
sub_ns = gfc_get_namespace (ns, 0);
|
sub_ns = gfc_get_namespace (ns, 0);
|
||||||
sub_ns->sibling = ns->contained;
|
sub_ns->sibling = ns->contained;
|
||||||
ns->contained = sub_ns;
|
if (!expr_null_wrapper)
|
||||||
|
ns->contained = sub_ns;
|
||||||
sub_ns->resolved = 1;
|
sub_ns->resolved = 1;
|
||||||
|
|
||||||
/* Set up the procedure symbol. */
|
/* 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);
|
gfc_get_symbol (name, sub_ns, &final);
|
||||||
sub_ns->proc_name = final;
|
sub_ns->proc_name = final;
|
||||||
final->attr.flavor = FL_PROCEDURE;
|
final->attr.flavor = FL_PROCEDURE;
|
||||||
final->attr.subroutine = 1;
|
final->attr.function = 1;
|
||||||
final->attr.pure = 1;
|
final->attr.pure = 0;
|
||||||
|
final->result = final;
|
||||||
|
final->ts.type = BT_INTEGER;
|
||||||
|
final->ts.kind = 4;
|
||||||
final->attr.artificial = 1;
|
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)
|
if (ns->proc_name->attr.flavor == FL_MODULE)
|
||||||
final->module = ns->proc_name->name;
|
final->module = ns->proc_name->name;
|
||||||
gfc_set_sym_referenced (final);
|
gfc_set_sym_referenced (final);
|
||||||
|
gfc_commit_symbol (final);
|
||||||
|
|
||||||
/* Set up formal argument. */
|
/* Set up formal argument. */
|
||||||
gfc_get_symbol ("array", sub_ns, &array);
|
gfc_get_symbol ("array", sub_ns, &array);
|
||||||
|
@ -1096,6 +1371,50 @@ generate_finalization_wrapper (gfc_symbol *derived, gfc_namespace *ns,
|
||||||
final->formal->sym = array;
|
final->formal->sym = array;
|
||||||
gfc_commit_symbol (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,
|
/* Obtain the size (number of elements) of "array" MINUS ONE,
|
||||||
which is used in the scalarization. */
|
which is used in the scalarization. */
|
||||||
gfc_get_symbol ("nelem", sub_ns, &nelem);
|
gfc_get_symbol ("nelem", sub_ns, &nelem);
|
||||||
|
@ -1107,7 +1426,8 @@ generate_finalization_wrapper (gfc_symbol *derived, gfc_namespace *ns,
|
||||||
gfc_commit_symbol (nelem);
|
gfc_commit_symbol (nelem);
|
||||||
|
|
||||||
/* Generate: nelem = SIZE (array) - 1. */
|
/* 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->op = EXEC_ASSIGN;
|
||||||
last_code->loc = gfc_current_locus;
|
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_intrinsic_function_by_id (GFC_ISYM_SIZE);
|
||||||
gfc_get_sym_tree ("size", sub_ns, &last_code->expr2->value.op.op1->symtree,
|
gfc_get_sym_tree ("size", sub_ns, &last_code->expr2->value.op.op1->symtree,
|
||||||
false);
|
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.flavor = FL_PROCEDURE;
|
||||||
last_code->expr2->value.op.op1->symtree->n.sym->attr.intrinsic = 1;
|
last_code->expr2->value.op.op1->symtree->n.sym->attr.intrinsic = 1;
|
||||||
gfc_commit_symbol (last_code->expr2->value.op.op1->symtree->n.sym);
|
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))
|
select case (rank (array))
|
||||||
case (3)
|
case (3)
|
||||||
|
! If needed, the array is packed
|
||||||
call final_rank3 (array)
|
call final_rank3 (array)
|
||||||
case default:
|
case default:
|
||||||
do i = 0, size (array)-1
|
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 c_f_pointer (transfer (addr, cptr), ptr)
|
||||||
call elemental_final (ptr)
|
call elemental_final (ptr)
|
||||||
end do
|
end do
|
||||||
|
@ -1168,6 +1490,23 @@ generate_finalization_wrapper (gfc_symbol *derived, gfc_namespace *ns,
|
||||||
gfc_finalizer *fini, *fini_elem = NULL;
|
gfc_finalizer *fini, *fini_elem = NULL;
|
||||||
gfc_code *block = 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)). */
|
/* SELECT CASE (RANK (array)). */
|
||||||
last_code->next = XCNEW (gfc_code);
|
last_code->next = XCNEW (gfc_code);
|
||||||
last_code = last_code->next;
|
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->high
|
||||||
= block->ext.block.case_list->low;
|
= block->ext.block.case_list->low;
|
||||||
|
|
||||||
/* CALL fini_rank (array). */
|
/* CALL fini_rank (array) - possibly with packing. */
|
||||||
block->next = XCNEW (gfc_code);
|
if (fini->proc_tree->n.sym->formal->sym->attr.dimension)
|
||||||
block->next->op = EXEC_CALL;
|
finalizer_insert_packed_call (block, fini, array, stride, idx, ptr,
|
||||||
block->next->loc = gfc_current_locus;
|
nelem, size_intr, sub_ns);
|
||||||
block->next->symtree = fini->proc_tree;
|
else
|
||||||
block->next->resolved_sym = fini->proc_tree->n.sym;
|
{
|
||||||
block->next->ext.actual = gfc_get_actual_arglist ();
|
block->next = XCNEW (gfc_code);
|
||||||
block->next->ext.actual->expr = gfc_lval_expr_from_sym (array);
|
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. */
|
/* Elemental call - scalarized. */
|
||||||
|
@ -1251,23 +1596,6 @@ generate_finalization_wrapper (gfc_symbol *derived, gfc_namespace *ns,
|
||||||
block->op = EXEC_SELECT;
|
block->op = EXEC_SELECT;
|
||||||
block->ext.block.case_list = gfc_get_case ();
|
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. */
|
/* Create loop. */
|
||||||
iter = gfc_get_iterator ();
|
iter = gfc_get_iterator ();
|
||||||
iter->var = gfc_lval_expr_from_sym (idx);
|
iter->var = gfc_lval_expr_from_sym (idx);
|
||||||
|
@ -1284,8 +1612,11 @@ generate_finalization_wrapper (gfc_symbol *derived, gfc_namespace *ns,
|
||||||
|
|
||||||
/* Create code for
|
/* Create code for
|
||||||
CALL C_F_POINTER (TRANSFER (TRANSFER (C_LOC (array, cptr), c_intptr)
|
CALL C_F_POINTER (TRANSFER (TRANSFER (C_LOC (array, cptr), c_intptr)
|
||||||
+ idx * STORAGE_SIZE (array), c_ptr), ptr). */
|
+ idx * stride, c_ptr), ptr). */
|
||||||
block->block->next = finalization_scalarizer (idx, array, ptr, sub_ns);
|
block->block->next
|
||||||
|
= finalization_scalarizer (idx, array, ptr,
|
||||||
|
gfc_lval_expr_from_sym (stride),
|
||||||
|
sub_ns);
|
||||||
block = block->block->next;
|
block = block->block->next;
|
||||||
|
|
||||||
/* CALL final_elemental (array). */
|
/* CALL final_elemental (array). */
|
||||||
|
@ -1356,8 +1687,11 @@ generate_finalization_wrapper (gfc_symbol *derived, gfc_namespace *ns,
|
||||||
|
|
||||||
/* Create code for
|
/* Create code for
|
||||||
CALL C_F_POINTER (TRANSFER (TRANSFER (C_LOC (array, cptr), c_intptr)
|
CALL C_F_POINTER (TRANSFER (TRANSFER (C_LOC (array, cptr), c_intptr)
|
||||||
+ idx * STORAGE_SIZE (array), c_ptr), ptr). */
|
+ idx * stride, c_ptr), ptr). */
|
||||||
last_code->block->next = finalization_scalarizer (idx, array, ptr, sub_ns);
|
last_code->block->next
|
||||||
|
= finalization_scalarizer (idx, array, ptr,
|
||||||
|
gfc_lval_expr_from_sym (stride),
|
||||||
|
sub_ns);
|
||||||
block = last_code->block->next;
|
block = last_code->block->next;
|
||||||
|
|
||||||
for (comp = derived->components; comp; comp = comp->next)
|
for (comp = derived->components; comp; comp = comp->next)
|
||||||
|
@ -1367,7 +1701,7 @@ generate_finalization_wrapper (gfc_symbol *derived, gfc_namespace *ns,
|
||||||
continue;
|
continue;
|
||||||
|
|
||||||
finalize_component (gfc_lval_expr_from_sym (ptr), derived, comp,
|
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)
|
if (!last_code->block->next)
|
||||||
last_code->block->next = block;
|
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 = gfc_get_actual_arglist ();
|
||||||
last_code->ext.actual->expr = gfc_lval_expr_from_sym (array);
|
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->initializer = gfc_lval_expr_from_sym (final);
|
||||||
vtab_final->ts.interface = final;
|
vtab_final->ts.interface = final;
|
||||||
}
|
}
|
||||||
|
@ -1419,7 +1757,7 @@ 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_symbol *
|
||||||
gfc_find_derived_vtab (gfc_symbol *derived)
|
gfc_find_derived_vtab (gfc_symbol *derived)
|
||||||
|
@ -1440,7 +1778,7 @@ gfc_find_derived_vtab (gfc_symbol *derived)
|
||||||
if (ns)
|
if (ns)
|
||||||
{
|
{
|
||||||
char name[GFC_MAX_SYMBOL_LEN+1], tname[GFC_MAX_SYMBOL_LEN+1];
|
char name[GFC_MAX_SYMBOL_LEN+1], tname[GFC_MAX_SYMBOL_LEN+1];
|
||||||
|
|
||||||
get_unique_hashed_string (tname, derived);
|
get_unique_hashed_string (tname, derived);
|
||||||
sprintf (name, "__vtab_%s", tname);
|
sprintf (name, "__vtab_%s", tname);
|
||||||
|
|
||||||
|
@ -1464,7 +1802,7 @@ gfc_find_derived_vtab (gfc_symbol *derived)
|
||||||
vtab->attr.access = ACCESS_PUBLIC;
|
vtab->attr.access = ACCESS_PUBLIC;
|
||||||
gfc_set_sym_referenced (vtab);
|
gfc_set_sym_referenced (vtab);
|
||||||
sprintf (name, "__vtype_%s", tname);
|
sprintf (name, "__vtype_%s", tname);
|
||||||
|
|
||||||
gfc_find_symbol (name, ns, 0, &vtype);
|
gfc_find_symbol (name, ns, 0, &vtype);
|
||||||
if (vtype == NULL)
|
if (vtype == NULL)
|
||||||
{
|
{
|
||||||
|
|
Loading…
Reference in New Issue