Skip to content

R
riscv-gcc-1
Commit 9e04287b by Tobias Burnus Committed by Tobias Burnus
Options

class.c (finalize_component): Used passed offset expr. 

2013-01-05  Tobias Burnus  <burnus@net-b.de>

        * class.c (finalize_component): Used passed offset expr.
        (finalization_get_offset): New static function.
        (finalizer_insert_packed_call, generate_finalization_wrapper):
        Use it to handle noncontiguous arrays.

From-SVN: r194927
parent 87f397d7
Showing with 594 additions and 166 deletions
gcc/fortran/ChangeLog
2013-01-05 Tobias Burnus <burnus@net-b.de>
* class.c (finalize_component): Used passed offset expr.
(finalization_get_offset): New static function.
(finalizer_insert_packed_call, generate_finalization_wrapper): Use it
to handle noncontiguous arrays.
2013-01-04 Tobias Burnus <burnus@net-b.de> 2013-01-04 Tobias Burnus <burnus@net-b.de>
* trans.c (gfc_build_final_call): New function. * trans.c (gfc_build_final_call): New function.
......
gcc/fortran/class.c
...@@ -924,14 +924,14 @@ finalize_component (gfc_expr *expr, gfc_symbol *derived, gfc_component *comp, ...@@ -924,14 +924,14 @@ 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 * stride, c_ptr), ptr). */ + offset, c_ptr), ptr). */
static gfc_code * static gfc_code *
finalization_scalarizer (gfc_symbol *idx, gfc_symbol *array, gfc_symbol *ptr, finalization_scalarizer (gfc_symbol *array, gfc_symbol *ptr,
gfc_expr *stride, gfc_namespace *sub_ns) gfc_expr *offset, gfc_namespace *sub_ns)
{ {
gfc_code *block; gfc_code *block;
gfc_expr *expr, *expr2, *expr3; gfc_expr *expr, *expr2;
/* C_F_POINTER(). */ /* C_F_POINTER(). */
block = XCNEW (gfc_code); block = XCNEW (gfc_code);
...@@ -961,6 +961,7 @@ finalization_scalarizer (gfc_symbol *idx, gfc_symbol *array, gfc_symbol *ptr, ...@@ -961,6 +961,7 @@ finalization_scalarizer (gfc_symbol *idx, gfc_symbol *array, gfc_symbol *ptr,
= gfc_intrinsic_function_by_id (GFC_ISYM_TRANSFER); = gfc_intrinsic_function_by_id (GFC_ISYM_TRANSFER);
/* Set symtree for -fdump-parse-tree. */ /* Set symtree for -fdump-parse-tree. */
gfc_get_sym_tree ("transfer", sub_ns, &expr2->symtree, false); gfc_get_sym_tree ("transfer", sub_ns, &expr2->symtree, false);
expr2->symtree->n.sym->intmod_sym_id = GFC_ISYM_TRANSFER;
expr2->symtree->n.sym->attr.flavor = FL_PROCEDURE; expr2->symtree->n.sym->attr.flavor = FL_PROCEDURE;
expr2->symtree->n.sym->attr.intrinsic = 1; expr2->symtree->n.sym->attr.intrinsic = 1;
gfc_commit_symbol (expr2->symtree->n.sym); gfc_commit_symbol (expr2->symtree->n.sym);
...@@ -995,21 +996,12 @@ finalization_scalarizer (gfc_symbol *idx, gfc_symbol *array, gfc_symbol *ptr, ...@@ -995,21 +996,12 @@ 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;
/* 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 = stride;
expr3->ts = expr->ts;
/* <array addr> + <offset>. */ /* <array addr> + <offset>. */
block->ext.actual->expr = gfc_get_expr (); block->ext.actual->expr = gfc_get_expr ();
block->ext.actual->expr->expr_type = EXPR_OP; block->ext.actual->expr->expr_type = EXPR_OP;
block->ext.actual->expr->value.op.op = INTRINSIC_PLUS; block->ext.actual->expr->value.op.op = INTRINSIC_PLUS;
block->ext.actual->expr->value.op.op1 = expr2; block->ext.actual->expr->value.op.op1 = expr2;
block->ext.actual->expr->value.op.op2 = expr3; block->ext.actual->expr->value.op.op2 = offset;
block->ext.actual->expr->ts = expr->ts; block->ext.actual->expr->ts = expr->ts;
/* C_F_POINTER's 2nd arg: ptr -- and its absent shape=. */ /* C_F_POINTER's 2nd arg: ptr -- and its absent shape=. */
...@@ -1021,39 +1013,183 @@ finalization_scalarizer (gfc_symbol *idx, gfc_symbol *array, gfc_symbol *ptr, ...@@ -1021,39 +1013,183 @@ finalization_scalarizer (gfc_symbol *idx, gfc_symbol *array, gfc_symbol *ptr,
} }
/* Calculates the offset to the (idx+1)th element of an array, taking the
stride into account. It generates the code:
offset = 0
do idx2 = 1, rank
offset = offset + mod (idx, sizes(idx2)) / sizes(idx2-1) * strides(idx2)
end do
offset = offset * byte_stride. */
static gfc_code*
finalization_get_offset (gfc_symbol *idx, gfc_symbol *idx2, gfc_symbol *offset,
gfc_symbol *strides, gfc_symbol *sizes,
gfc_symbol *byte_stride, gfc_expr *rank,
gfc_code *block, gfc_namespace *sub_ns)
{
gfc_iterator *iter;
gfc_expr *expr, *expr2;
/* offset = 0. */
block->next = XCNEW (gfc_code);
block = block->next;
block->op = EXEC_ASSIGN;
block->loc = gfc_current_locus;
block->expr1 = gfc_lval_expr_from_sym (offset);
block->expr2 = gfc_get_int_expr (gfc_index_integer_kind, NULL, 0);
/* Create loop. */
iter = gfc_get_iterator ();
iter->var = gfc_lval_expr_from_sym (idx2);
iter->start = gfc_get_int_expr (gfc_index_integer_kind, NULL, 1);
iter->end = gfc_copy_expr (rank);
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;
/* Loop body: offset = offset + mod (idx, sizes(idx2)) / sizes(idx2-1)
* strides(idx2). */
/* mod (idx, sizes(idx2)). */
expr = gfc_get_expr ();
expr->expr_type = EXPR_FUNCTION;
expr->value.function.isym = gfc_intrinsic_function_by_id (GFC_ISYM_MOD);
gfc_get_sym_tree ("mod", sub_ns, &expr->symtree, false);
expr->symtree->n.sym->intmod_sym_id = GFC_ISYM_MOD;
expr->symtree->n.sym->attr.flavor = FL_PROCEDURE;
expr->symtree->n.sym->attr.intrinsic = 1;
gfc_commit_symbol (expr->symtree->n.sym);
expr->value.function.actual = gfc_get_actual_arglist ();
expr->value.function.actual->expr = gfc_lval_expr_from_sym (idx);
expr->value.function.actual->next = gfc_get_actual_arglist ();
expr->value.function.actual->next->expr = gfc_lval_expr_from_sym (sizes);
expr->value.function.actual->next->expr->ref = gfc_get_ref ();
expr->value.function.actual->next->expr->ref->type = REF_ARRAY;
expr->value.function.actual->next->expr->ref->u.ar.as = sizes->as;
expr->value.function.actual->next->expr->ref->u.ar.type = AR_ELEMENT;
expr->value.function.actual->next->expr->ref->u.ar.dimen = 1;
expr->value.function.actual->next->expr->ref->u.ar.dimen_type[0]
= DIMEN_ELEMENT;
expr->value.function.actual->next->expr->ref->u.ar.start[0]
= gfc_lval_expr_from_sym (idx2);
expr->ts = idx->ts;
/* (...) / sizes(idx2-1). */
expr2 = gfc_get_expr ();
expr2->expr_type = EXPR_OP;
expr2->value.op.op = INTRINSIC_DIVIDE;
expr2->value.op.op1 = expr;
expr2->value.op.op2 = gfc_lval_expr_from_sym (sizes);
expr2->value.op.op2->ref = gfc_get_ref ();
expr2->value.op.op2->ref->type = REF_ARRAY;
expr2->value.op.op2->ref->u.ar.as = sizes->as;
expr2->value.op.op2->ref->u.ar.type = AR_ELEMENT;
expr2->value.op.op2->ref->u.ar.dimen = 1;
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]->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]->value.op.op2
= gfc_get_int_expr (gfc_index_integer_kind, NULL, 1);
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;
/* ... * strides(idx2). */
expr = gfc_get_expr ();
expr->expr_type = EXPR_OP;
expr->value.op.op = INTRINSIC_TIMES;
expr->value.op.op1 = expr2;
expr->value.op.op2 = gfc_lval_expr_from_sym (strides);
expr->value.op.op2->ref = gfc_get_ref ();
expr->value.op.op2->ref->type = REF_ARRAY;
expr->value.op.op2->ref->u.ar.type = AR_ELEMENT;
expr->value.op.op2->ref->u.ar.dimen = 1;
expr->value.op.op2->ref->u.ar.dimen_type[0] = DIMEN_ELEMENT;
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;
/* offset = offset + ... */
block->block->next = XCNEW (gfc_code);
block->block->next->op = EXEC_ASSIGN;
block->block->next->loc = gfc_current_locus;
block->block->next->expr1 = gfc_lval_expr_from_sym (offset);
block->block->next->expr2 = gfc_get_expr ();
block->block->next->expr2->expr_type = EXPR_OP;
block->block->next->expr2->value.op.op = INTRINSIC_PLUS;
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;
/* After the loop: offset = offset * byte_stride. */
block->next = XCNEW (gfc_code);
block = block->next;
block->op = EXEC_ASSIGN;
block->loc = gfc_current_locus;
block->expr1 = gfc_lval_expr_from_sym (offset);
block->expr2 = gfc_get_expr ();
block->expr2->expr_type = EXPR_OP;
block->expr2->value.op.op = INTRINSIC_TIMES;
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;
return block;
}
/* Insert code of the following form: /* Insert code of the following form:
if (stride == STORAGE_SIZE (array)/NUMERIC_STORAGE_SIZE block
|| 0 == STORAGE_SIZE (array)) then integer(c_intptr_t) :: i
call final_rank3 (array)
else if ((byte_stride == STORAGE_SIZE (array)/NUMERIC_STORAGE_SIZE
block && (is_contiguous || !final_rank3->attr.contiguous
type(t) :: tmp(shape (array)) || final_rank3->as->type != AS_ASSUMED_SHAPE))
|| 0 == STORAGE_SIZE (array)) then
do i = 0, size (array)-1 call final_rank3 (array)
addr = transfer (c_loc (array), addr) + i * stride else
call c_f_pointer (transfer (addr, cptr), ptr) block
integer(c_intptr_t) :: offset, j
addr = transfer (c_loc (tmp), addr) type(t) :: tmp(shape (array))
+ i * STORAGE_SIZE (array)/NUMERIC_STORAGE_SIZE
call c_f_pointer (transfer (addr, cptr), ptr2) do i = 0, size (array)-1
ptr2 = ptr offset = obtain_offset(i, strides, sizes, byte_stride)
end do addr = transfer (c_loc (array), addr) + offset
call final_rank3 (tmp) call c_f_pointer (transfer (addr, cptr), ptr)
end block
end if */ 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
block */
static void static void
finalizer_insert_packed_call (gfc_code *block, gfc_finalizer *fini, finalizer_insert_packed_call (gfc_code *block, gfc_finalizer *fini,
gfc_symbol *array, gfc_symbol *stride, gfc_symbol *array, gfc_symbol *byte_stride,
gfc_symbol *idx, gfc_symbol *ptr, gfc_symbol *idx, gfc_symbol *ptr,
gfc_symbol *nelem, gfc_symtree *size_intr, gfc_symbol *nelem, gfc_symtree *size_intr,
gfc_symbol *strides, gfc_symbol *sizes,
gfc_symbol *idx2, gfc_symbol *offset,
gfc_symbol *is_contiguous, gfc_expr *rank,
gfc_namespace *sub_ns) gfc_namespace *sub_ns)
{ {
gfc_symbol *tmp_array, *ptr2; gfc_symbol *tmp_array, *ptr2;
gfc_expr *size_expr; gfc_expr *size_expr, *offset2, *expr;
gfc_namespace *ns; gfc_namespace *ns;
gfc_iterator *iter; gfc_iterator *iter;
gfc_code *block2;
int i; int i;
block->next = XCNEW (gfc_code); block->next = XCNEW (gfc_code);
...@@ -1080,6 +1216,8 @@ finalizer_insert_packed_call (gfc_code *block, gfc_finalizer *fini, ...@@ -1080,6 +1216,8 @@ finalizer_insert_packed_call (gfc_code *block, gfc_finalizer *fini,
= gfc_intrinsic_function_by_id (GFC_ISYM_STORAGE_SIZE); = gfc_intrinsic_function_by_id (GFC_ISYM_STORAGE_SIZE);
gfc_get_sym_tree ("storage_size", sub_ns, &size_expr->value.op.op1->symtree, gfc_get_sym_tree ("storage_size", sub_ns, &size_expr->value.op.op1->symtree,
false); false);
size_expr->value.op.op1->symtree->n.sym->intmod_sym_id
= GFC_ISYM_STORAGE_SIZE;
size_expr->value.op.op1->symtree->n.sym->attr.flavor = FL_PROCEDURE; size_expr->value.op.op1->symtree->n.sym->attr.flavor = FL_PROCEDURE;
size_expr->value.op.op1->symtree->n.sym->attr.intrinsic = 1; size_expr->value.op.op1->symtree->n.sym->attr.intrinsic = 1;
gfc_commit_symbol (size_expr->value.op.op1->symtree->n.sym); gfc_commit_symbol (size_expr->value.op.op1->symtree->n.sym);
...@@ -1096,32 +1234,53 @@ finalizer_insert_packed_call (gfc_code *block, gfc_finalizer *fini, ...@@ -1096,32 +1234,53 @@ finalizer_insert_packed_call (gfc_code *block, gfc_finalizer *fini,
size_expr->value.op.op1->ts = size_expr->value.op.op2->ts; size_expr->value.op.op1->ts = size_expr->value.op.op2->ts;
size_expr->ts = size_expr->value.op.op1->ts; size_expr->ts = size_expr->value.op.op1->ts;
/* IF condition: stride == size_expr || 0 == size_expr. */ /* IF condition: (stride == size_expr
&& ((fini's as->ASSUMED_SIZE && !fini's attr.contiguous)
|| is_contiguous)
|| 0 == size_expr. */
block->expr1 = gfc_get_expr (); block->expr1 = gfc_get_expr ();
block->expr1->expr_type = EXPR_FUNCTION; block->expr1->expr_type = EXPR_FUNCTION;
block->expr1->ts.type = BT_LOGICAL; block->expr1->ts.type = BT_LOGICAL;
block->expr1->ts.kind = 4; block->expr1->ts.kind = gfc_default_logical_kind;
block->expr1->expr_type = EXPR_OP; block->expr1->expr_type = EXPR_OP;
block->expr1->where = gfc_current_locus; block->expr1->where = gfc_current_locus;
block->expr1->value.op.op = INTRINSIC_OR; block->expr1->value.op.op = INTRINSIC_OR;
/* stride == size_expr */ /* byte_stride == size_expr */
block->expr1->value.op.op1 = gfc_get_expr (); expr = gfc_get_expr ();
block->expr1->value.op.op1->expr_type = EXPR_FUNCTION; expr->ts.type = BT_LOGICAL;
block->expr1->value.op.op1->ts.type = BT_LOGICAL; expr->ts.kind = gfc_default_logical_kind;
block->expr1->value.op.op1->ts.kind = 4; expr->expr_type = EXPR_OP;
block->expr1->value.op.op1->expr_type = EXPR_OP; expr->where = gfc_current_locus;
block->expr1->value.op.op1->where = gfc_current_locus; expr->value.op.op = INTRINSIC_EQ;
block->expr1->value.op.op1->value.op.op = INTRINSIC_EQ; expr->value.op.op1
block->expr1->value.op.op1->value.op.op1 = gfc_lval_expr_from_sym (stride); = gfc_lval_expr_from_sym (byte_stride);
block->expr1->value.op.op1->value.op.op2 = size_expr; expr->value.op.op2 = size_expr;
/* If strides aren't allowd (not assumed shape or CONTIGUOUS),
add is_contiguous check. */
if (fini->proc_tree->n.sym->formal->sym->as->type != AS_ASSUMED_SHAPE
|| fini->proc_tree->n.sym->formal->sym->attr.contiguous)
{
gfc_expr *expr2;
expr2 = gfc_get_expr ();
expr2->ts.type = BT_LOGICAL;
expr2->ts.kind = gfc_default_logical_kind;
expr2->expr_type = EXPR_OP;
expr2->where = gfc_current_locus;
expr2->value.op.op = INTRINSIC_AND;
expr2->value.op.op1 = expr;
expr2->value.op.op2 = gfc_lval_expr_from_sym (is_contiguous);
expr = expr2;
}
block->expr1->value.op.op1 = expr;
/* 0 == size_expr */ /* 0 == size_expr */
block->expr1->value.op.op2 = gfc_get_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.type = BT_LOGICAL;
block->expr1->value.op.op2->ts.kind = 4; block->expr1->value.op.op2->ts.kind = gfc_default_logical_kind;
block->expr1->value.op.op2->expr_type = EXPR_OP; block->expr1->value.op.op2->expr_type = EXPR_OP;
block->expr1->value.op.op2->where = gfc_current_locus; 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.op = INTRINSIC_EQ;
...@@ -1168,7 +1327,6 @@ finalizer_insert_packed_call (gfc_code *block, gfc_finalizer *fini, ...@@ -1168,7 +1327,6 @@ finalizer_insert_packed_call (gfc_code *block, gfc_finalizer *fini,
tmp_array->ts.type = BT_DERIVED; tmp_array->ts.type = BT_DERIVED;
tmp_array->ts.u.derived = array->ts.u.derived; tmp_array->ts.u.derived = array->ts.u.derived;
tmp_array->attr.flavor = FL_VARIABLE; tmp_array->attr.flavor = FL_VARIABLE;
tmp_array->attr.contiguous = 1;
tmp_array->attr.dimension = 1; tmp_array->attr.dimension = 1;
tmp_array->attr.artificial = 1; tmp_array->attr.artificial = 1;
tmp_array->as = gfc_get_array_spec(); tmp_array->as = gfc_get_array_spec();
...@@ -1217,22 +1375,36 @@ finalizer_insert_packed_call (gfc_code *block, gfc_finalizer *fini, ...@@ -1217,22 +1375,36 @@ finalizer_insert_packed_call (gfc_code *block, gfc_finalizer *fini,
block->block = gfc_get_code (); block->block = gfc_get_code ();
block->block->op = EXEC_DO; block->block->op = EXEC_DO;
/* Offset calculation for the new array: idx * size of type (in bytes). */
offset2 = gfc_get_expr ();
offset2 = block->ext.actual->expr;
offset2->expr_type = EXPR_OP;
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);
offset2->ts = byte_stride->ts;
/* Offset calculation of "array". */
block2 = finalization_get_offset (idx, idx2, offset, strides, sizes,
byte_stride, rank, block->block, sub_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 * stride, c_ptr), ptr). */ + idx * stride, c_ptr), ptr). */
block->block->next = finalization_scalarizer (idx, array, ptr, block2->next = finalization_scalarizer (array, ptr,
gfc_lval_expr_from_sym (stride), gfc_lval_expr_from_sym (offset),
sub_ns); sub_ns);
block->block->next->next = finalization_scalarizer (idx, tmp_array, ptr2, block2 = block2->next;
gfc_copy_expr (size_expr), block2->next = finalization_scalarizer (tmp_array, ptr2, offset2, sub_ns);
sub_ns);
/* ptr2 = ptr. */ /* ptr2 = ptr. */
block->block->next->next->next = XCNEW (gfc_code); block2->next = XCNEW (gfc_code);
block->block->next->next->next->op = EXEC_ASSIGN; block2->next->op = EXEC_ASSIGN;
block->block->next->next->next->loc = gfc_current_locus; block2->next->loc = gfc_current_locus;
block->block->next->next->next->expr1 = gfc_lval_expr_from_sym (ptr2); block2->next->expr1 = gfc_lval_expr_from_sym (ptr2);
block->block->next->next->next->expr2 = gfc_lval_expr_from_sym (ptr); block2->next->expr2 = gfc_lval_expr_from_sym (ptr);
/* Call now the user's final subroutine. */
block->next = XCNEW (gfc_code); block->next = XCNEW (gfc_code);
block = block->next; block = block->next;
block->op = EXEC_CALL; block->op = EXEC_CALL;
...@@ -1262,21 +1434,26 @@ finalizer_insert_packed_call (gfc_code *block, gfc_finalizer *fini, ...@@ -1262,21 +1434,26 @@ finalizer_insert_packed_call (gfc_code *block, gfc_finalizer *fini,
block->block = gfc_get_code (); block->block = gfc_get_code ();
block->block->op = EXEC_DO; block->block->op = EXEC_DO;
/* Offset calculation of "array". */
block2 = finalization_get_offset (idx, idx2, offset, strides, sizes,
byte_stride, rank, block->block, sub_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 * stride, c_ptr), ptr). */ + offset, c_ptr), ptr). */
block->block->next = finalization_scalarizer (idx, array, ptr, block2->next = finalization_scalarizer (array, ptr,
gfc_lval_expr_from_sym (stride), gfc_lval_expr_from_sym (offset),
sub_ns); sub_ns);
block->block->next->next = finalization_scalarizer (idx, tmp_array, ptr2, block2 = block2->next;
gfc_copy_expr (size_expr), block2->next = finalization_scalarizer (tmp_array, ptr2, offset2, sub_ns);
sub_ns); block2 = block2->next;
/* ptr = ptr2. */ /* ptr = ptr2. */
block->block->next->next->next = XCNEW (gfc_code); block2->next = XCNEW (gfc_code);
block->block->next->next->next->op = EXEC_ASSIGN; block2->next->op = EXEC_ASSIGN;
block->block->next->next->next->loc = gfc_current_locus; block2->next->loc = gfc_current_locus;
block->block->next->next->next->expr1 = gfc_lval_expr_from_sym (ptr); block2->next->expr1 = gfc_lval_expr_from_sym (ptr);
block->block->next->next->next->expr2 = gfc_lval_expr_from_sym (ptr2); block2->next->expr2 = gfc_lval_expr_from_sym (ptr2);
} }
...@@ -1300,16 +1477,17 @@ static void ...@@ -1300,16 +1477,17 @@ 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, *fini_coarray, *stride; gfc_symbol *final, *array, *fini_coarray, *byte_stride, *sizes, *strides;
gfc_symbol *ptr = NULL, *idx = NULL; gfc_symbol *ptr = NULL, *idx, *idx2, *is_contiguous, *offset, *nelem;
gfc_symtree *size_intr; 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, *block;
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; bool expr_null_wrapper = false;
gfc_expr *ancestor_wrapper = NULL; gfc_expr *ancestor_wrapper = NULL, *rank;
gfc_iterator *iter;
/* Search for the ancestor's finalizers. */ /* Search for the ancestor's finalizers. */
if (derived->attr.extension && derived->components if (derived->attr.extension && derived->components
...@@ -1423,22 +1601,22 @@ generate_finalization_wrapper (gfc_symbol *derived, gfc_namespace *ns, ...@@ -1423,22 +1601,22 @@ generate_finalization_wrapper (gfc_symbol *derived, gfc_namespace *ns,
gfc_commit_symbol (array); gfc_commit_symbol (array);
/* Set up formal argument. */ /* Set up formal argument. */
gfc_get_symbol ("stride", sub_ns, &stride); gfc_get_symbol ("byte_stride", sub_ns, &byte_stride);
stride->ts.type = BT_INTEGER; byte_stride->ts.type = BT_INTEGER;
stride->ts.kind = gfc_index_integer_kind; byte_stride->ts.kind = gfc_index_integer_kind;
stride->attr.flavor = FL_VARIABLE; byte_stride->attr.flavor = FL_VARIABLE;
stride->attr.dummy = 1; byte_stride->attr.dummy = 1;
stride->attr.value = 1; byte_stride->attr.value = 1;
stride->attr.artificial = 1; byte_stride->attr.artificial = 1;
gfc_set_sym_referenced (stride); gfc_set_sym_referenced (byte_stride);
final->formal->next = gfc_get_formal_arglist (); final->formal->next = gfc_get_formal_arglist ();
final->formal->next->sym = stride; final->formal->next->sym = byte_stride;
gfc_commit_symbol (stride); gfc_commit_symbol (byte_stride);
/* Set up formal argument. */ /* Set up formal argument. */
gfc_get_symbol ("fini_coarray", sub_ns, &fini_coarray); gfc_get_symbol ("fini_coarray", sub_ns, &fini_coarray);
fini_coarray->ts.type = BT_LOGICAL; fini_coarray->ts.type = BT_LOGICAL;
fini_coarray->ts.kind = 4; fini_coarray->ts.kind = 1;
fini_coarray->attr.flavor = FL_VARIABLE; fini_coarray->attr.flavor = FL_VARIABLE;
fini_coarray->attr.dummy = 1; fini_coarray->attr.dummy = 1;
fini_coarray->attr.value = 1; fini_coarray->attr.value = 1;
...@@ -1457,6 +1635,90 @@ generate_finalization_wrapper (gfc_symbol *derived, gfc_namespace *ns, ...@@ -1457,6 +1635,90 @@ generate_finalization_wrapper (gfc_symbol *derived, gfc_namespace *ns,
return; return;
} }
/* Local variables. */
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 ("idx2", sub_ns, &idx2);
idx2->ts.type = BT_INTEGER;
idx2->ts.kind = gfc_index_integer_kind;
idx2->attr.flavor = FL_VARIABLE;
idx2->attr.artificial = 1;
gfc_set_sym_referenced (idx2);
gfc_commit_symbol (idx2);
gfc_get_symbol ("offset", sub_ns, &offset);
offset->ts.type = BT_INTEGER;
offset->ts.kind = gfc_index_integer_kind;
offset->attr.flavor = FL_VARIABLE;
offset->attr.artificial = 1;
gfc_set_sym_referenced (offset);
gfc_commit_symbol (offset);
/* Create RANK expression. */
rank = gfc_get_expr ();
rank->expr_type = EXPR_FUNCTION;
rank->value.function.isym = gfc_intrinsic_function_by_id (GFC_ISYM_RANK);
gfc_get_sym_tree ("rank", sub_ns, &rank->symtree, false);
rank->symtree->n.sym->intmod_sym_id = GFC_ISYM_RANK;
rank->symtree->n.sym->attr.flavor = FL_PROCEDURE;
rank->symtree->n.sym->attr.intrinsic = 1;
gfc_commit_symbol (rank->symtree->n.sym);
rank->value.function.actual = gfc_get_actual_arglist ();
rank->value.function.actual->expr = gfc_lval_expr_from_sym (array);
rank->ts = rank->value.function.isym->ts;
gfc_convert_type (rank, &idx->ts, 2);
/* Create is_contiguous variable. */
gfc_get_symbol ("is_contiguous", sub_ns, &is_contiguous);
is_contiguous->ts.type = BT_LOGICAL;
is_contiguous->ts.kind = gfc_default_logical_kind;
is_contiguous->attr.flavor = FL_VARIABLE;
is_contiguous->attr.artificial = 1;
gfc_set_sym_referenced (is_contiguous);
gfc_commit_symbol (is_contiguous);
/* Create "sizes(0..rank)" variable, which contains the multiplied
up extent of the dimensions, i.e. sizes(0) = 1, sizes(1) = extent(dim=1),
sizes(2) = sizes(1) * extent(dim=2) etc. */
gfc_get_symbol ("sizes", sub_ns, &sizes);
sizes->ts.type = BT_INTEGER;
sizes->ts.kind = gfc_index_integer_kind;
sizes->attr.flavor = FL_VARIABLE;
sizes->attr.dimension = 1;
sizes->attr.artificial = 1;
sizes->as = gfc_get_array_spec();
sizes->attr.intent = INTENT_INOUT;
sizes->as->type = AS_EXPLICIT;
sizes->as->rank = 1;
sizes->as->lower[0] = gfc_get_int_expr (gfc_index_integer_kind, NULL, 0);
sizes->as->upper[0] = gfc_copy_expr (rank);
gfc_set_sym_referenced (sizes);
gfc_commit_symbol (sizes);
/* Create "strides(1..rank)" variable, which contains the strides per
dimension. */
gfc_get_symbol ("strides", sub_ns, &strides);
strides->ts.type = BT_INTEGER;
strides->ts.kind = gfc_index_integer_kind;
strides->attr.flavor = FL_VARIABLE;
strides->attr.dimension = 1;
strides->attr.artificial = 1;
strides->as = gfc_get_array_spec();
strides->attr.intent = INTENT_INOUT;
strides->as->type = AS_EXPLICIT;
strides->as->rank = 1;
strides->as->lower[0] = gfc_get_int_expr (gfc_index_integer_kind, NULL, 1);
strides->as->upper[0] = gfc_copy_expr (rank);
gfc_set_sym_referenced (strides);
gfc_commit_symbol (strides);
/* Set return value to 0. */ /* Set return value to 0. */
last_code = XCNEW (gfc_code); last_code = XCNEW (gfc_code);
...@@ -1466,6 +1728,206 @@ generate_finalization_wrapper (gfc_symbol *derived, gfc_namespace *ns, ...@@ -1466,6 +1728,206 @@ generate_finalization_wrapper (gfc_symbol *derived, gfc_namespace *ns,
last_code->expr2 = gfc_get_int_expr (4, NULL, 0); last_code->expr2 = gfc_get_int_expr (4, NULL, 0);
sub_ns->code = last_code; sub_ns->code = last_code;
/* Set: is_contiguous = .true. */
last_code->next = XCNEW (gfc_code);
last_code = last_code->next;
last_code->op = EXEC_ASSIGN;
last_code->loc = gfc_current_locus;
last_code->expr1 = gfc_lval_expr_from_sym (is_contiguous);
last_code->expr2 = gfc_get_logical_expr (gfc_default_logical_kind,
&gfc_current_locus, true);
/* Set: sizes(0) = 1. */
last_code->next = XCNEW (gfc_code);
last_code = last_code->next;
last_code->op = EXEC_ASSIGN;
last_code->loc = gfc_current_locus;
last_code->expr1 = gfc_lval_expr_from_sym (sizes);
last_code->expr1->ref = gfc_get_ref ();
last_code->expr1->ref->type = REF_ARRAY;
last_code->expr1->ref->u.ar.type = AR_ELEMENT;
last_code->expr1->ref->u.ar.dimen = 1;
last_code->expr1->ref->u.ar.dimen_type[0] = DIMEN_ELEMENT;
last_code->expr1->ref->u.ar.start[0]
= gfc_get_int_expr (gfc_index_integer_kind, NULL, 0);
last_code->expr1->ref->u.ar.as = sizes->as;
last_code->expr2 = gfc_get_int_expr (gfc_default_integer_kind, NULL, 1);
/* Create:
DO idx = 1, rank
strides(idx) = _F._stride (array, dim=idx)
sizes(idx) = sizes(i-1) * size(array, dim=idx, kind=index_kind)
if (strides(idx) /= sizes(i-1)) is_contiguous = .false.
END DO. */
/* 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, 1);
iter->end = gfc_copy_expr (rank);
iter->step = gfc_get_int_expr (gfc_index_integer_kind, NULL, 1);
last_code->next = XCNEW (gfc_code);
last_code = last_code->next;
last_code->op = EXEC_DO;
last_code->loc = gfc_current_locus;
last_code->ext.iterator = iter;
last_code->block = gfc_get_code ();
last_code->block->op = EXEC_DO;
/* strides(idx) = _F._stride(array,dim=idx). */
last_code->block->next = XCNEW (gfc_code);
block = last_code->block->next;
block->op = EXEC_ASSIGN;
block->loc = gfc_current_locus;
block->expr1 = gfc_lval_expr_from_sym (strides);
block->expr1->ref = gfc_get_ref ();
block->expr1->ref->type = REF_ARRAY;
block->expr1->ref->u.ar.type = AR_ELEMENT;
block->expr1->ref->u.ar.dimen = 1;
block->expr1->ref->u.ar.dimen_type[0] = DIMEN_ELEMENT;
block->expr1->ref->u.ar.start[0] = gfc_lval_expr_from_sym (idx);
block->expr1->ref->u.ar.as = strides->as;
block->expr2 = gfc_get_expr ();
block->expr2->expr_type = EXPR_FUNCTION;
block->expr2->value.function.isym
= gfc_intrinsic_function_by_id (GFC_ISYM_STRIDE);
gfc_get_sym_tree (GFC_PREFIX ("stride"), sub_ns,
&block->expr2->symtree, false);
block->expr2->symtree->n.sym->intmod_sym_id = GFC_ISYM_STRIDE;
block->expr2->symtree->n.sym->attr.flavor = FL_PROCEDURE;
block->expr2->symtree->n.sym->attr.intrinsic = 1;
gfc_commit_symbol (block->expr2->symtree->n.sym);
block->expr2->value.function.actual = gfc_get_actual_arglist ();
block->expr2->value.function.actual->expr = gfc_lval_expr_from_sym (array);
/* dim=idx. */
block->expr2->value.function.actual->next = gfc_get_actual_arglist ();
block->expr2->value.function.actual->next->expr
= gfc_lval_expr_from_sym (idx);
block->expr2->ts = block->expr2->value.function.isym->ts;
/* sizes(idx) = sizes(idx-1) * size(array,dim=idx, kind=index_kind). */
block->next = XCNEW (gfc_code);
block = block->next;
block->op = EXEC_ASSIGN;
block->loc = gfc_current_locus;
/* sizes(idx) = ... */
block->expr1 = gfc_lval_expr_from_sym (sizes);
block->expr1->ref = gfc_get_ref ();
block->expr1->ref->type = REF_ARRAY;
block->expr1->ref->u.ar.type = AR_ELEMENT;
block->expr1->ref->u.ar.dimen = 1;
block->expr1->ref->u.ar.dimen_type[0] = DIMEN_ELEMENT;
block->expr1->ref->u.ar.start[0] = gfc_lval_expr_from_sym (idx);
block->expr1->ref->u.ar.as = sizes->as;
block->expr2 = gfc_get_expr ();
block->expr2->expr_type = EXPR_OP;
block->expr2->value.op.op = INTRINSIC_TIMES;
/* 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.as = sizes->as;
block->expr2->value.op.op1->ref->u.ar.type = AR_ELEMENT;
block->expr2->value.op.op1->ref->u.ar.dimen = 1;
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]->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->expr2->value.op.op1->ref->u.ar.start[0]->value.op.op2
= gfc_get_int_expr (gfc_index_integer_kind, NULL, 1);
block->expr2->value.op.op1->ref->u.ar.start[0]->ts
= block->expr2->value.op.op1->ref->u.ar.start[0]->value.op.op1->ts;
/* size(array, dim=idx, kind=index_kind). */
block->expr2->value.op.op2 = gfc_get_expr ();
block->expr2->value.op.op2->expr_type = EXPR_FUNCTION;
block->expr2->value.op.op2->value.function.isym
= gfc_intrinsic_function_by_id (GFC_ISYM_SIZE);
gfc_get_sym_tree ("size", sub_ns, &block->expr2->value.op.op2->symtree,
false);
size_intr = block->expr2->value.op.op2->symtree;
block->expr2->value.op.op2->symtree->n.sym->intmod_sym_id = GFC_ISYM_SIZE;
block->expr2->value.op.op2->symtree->n.sym->attr.flavor = FL_PROCEDURE;
block->expr2->value.op.op2->symtree->n.sym->attr.intrinsic = 1;
gfc_commit_symbol (block->expr2->value.op.op2->symtree->n.sym);
block->expr2->value.op.op2->value.function.actual
= gfc_get_actual_arglist ();
block->expr2->value.op.op2->value.function.actual->expr
= gfc_lval_expr_from_sym (array);
/* dim=idx. */
block->expr2->value.op.op2->value.function.actual->next
= gfc_get_actual_arglist ();
block->expr2->value.op.op2->value.function.actual->next->expr
= gfc_lval_expr_from_sym (idx);
/* kind=c_intptr_t. */
block->expr2->value.op.op2->value.function.actual->next->next
= gfc_get_actual_arglist ();
block->expr2->value.op.op2->value.function.actual->next->next->expr
= gfc_get_int_expr (gfc_index_integer_kind, NULL, 0);
block->expr2->value.op.op2->ts = idx->ts;
block->expr2->ts = idx->ts;
/* if (strides(idx) /= sizes(idx-1)) is_contiguous = .false. */
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;
/* if condition: strides(idx) /= sizes(idx-1). */
block->expr1 = gfc_get_expr ();
block->expr1->ts.type = BT_LOGICAL;
block->expr1->ts.kind = gfc_default_logical_kind;
block->expr1->expr_type = EXPR_OP;
block->expr1->where = gfc_current_locus;
block->expr1->value.op.op = INTRINSIC_NE;
block->expr1->value.op.op1 = gfc_lval_expr_from_sym (strides);
block->expr1->value.op.op1->ref = gfc_get_ref ();
block->expr1->value.op.op1->ref->type = REF_ARRAY;
block->expr1->value.op.op1->ref->u.ar.type = AR_ELEMENT;
block->expr1->value.op.op1->ref->u.ar.dimen = 1;
block->expr1->value.op.op1->ref->u.ar.dimen_type[0] = DIMEN_ELEMENT;
block->expr1->value.op.op1->ref->u.ar.start[0] = gfc_lval_expr_from_sym (idx);
block->expr1->value.op.op1->ref->u.ar.as = strides->as;
block->expr1->value.op.op2 = gfc_lval_expr_from_sym (sizes);
block->expr1->value.op.op2->ref = gfc_get_ref ();
block->expr1->value.op.op2->ref->type = REF_ARRAY;
block->expr1->value.op.op2->ref->u.ar.as = sizes->as;
block->expr1->value.op.op2->ref->u.ar.type = AR_ELEMENT;
block->expr1->value.op.op2->ref->u.ar.dimen = 1;
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]->value.op.op = INTRINSIC_MINUS;
block->expr1->value.op.op2->ref->u.ar.start[0]->value.op.op1
= gfc_lval_expr_from_sym (idx);
block->expr1->value.op.op2->ref->u.ar.start[0]->value.op.op2
= gfc_get_int_expr (gfc_index_integer_kind, NULL, 1);
block->expr1->value.op.op2->ref->u.ar.start[0]->ts
= block->expr1->value.op.op2->ref->u.ar.start[0]->value.op.op1->ts;
/* if body: is_contiguous = .false. */
block->next = XCNEW (gfc_code);
block = block->next;
block->op = EXEC_ASSIGN;
block->loc = gfc_current_locus;
block->expr1 = gfc_lval_expr_from_sym (is_contiguous);
block->expr2 = gfc_get_logical_expr (gfc_default_logical_kind,
&gfc_current_locus, false);
/* 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);
...@@ -1476,7 +1938,7 @@ generate_finalization_wrapper (gfc_symbol *derived, gfc_namespace *ns, ...@@ -1476,7 +1938,7 @@ generate_finalization_wrapper (gfc_symbol *derived, gfc_namespace *ns,
gfc_set_sym_referenced (nelem); gfc_set_sym_referenced (nelem);
gfc_commit_symbol (nelem); gfc_commit_symbol (nelem);
/* Generate: nelem = SIZE (array) - 1. */ /* nelem = sizes (rank) - 1. */
last_code->next = XCNEW (gfc_code); last_code->next = XCNEW (gfc_code);
last_code = last_code->next; last_code = last_code->next;
last_code->op = EXEC_ASSIGN; last_code->op = EXEC_ASSIGN;
...@@ -1491,32 +1953,14 @@ generate_finalization_wrapper (gfc_symbol *derived, gfc_namespace *ns, ...@@ -1491,32 +1953,14 @@ generate_finalization_wrapper (gfc_symbol *derived, gfc_namespace *ns,
= gfc_get_int_expr (gfc_index_integer_kind, NULL, 1); = gfc_get_int_expr (gfc_index_integer_kind, NULL, 1);
last_code->expr2->ts = last_code->expr2->value.op.op2->ts; last_code->expr2->ts = last_code->expr2->value.op.op2->ts;
last_code->expr2->value.op.op1 = gfc_get_expr (); last_code->expr2->value.op.op1 = gfc_lval_expr_from_sym (sizes);
last_code->expr2->value.op.op1->expr_type = EXPR_FUNCTION; last_code->expr2->value.op.op1->ref = gfc_get_ref ();
last_code->expr2->value.op.op1->value.function.isym last_code->expr2->value.op.op1->ref->type = REF_ARRAY;
= gfc_intrinsic_function_by_id (GFC_ISYM_SIZE); last_code->expr2->value.op.op1->ref->u.ar.type = AR_ELEMENT;
gfc_get_sym_tree ("size", sub_ns, &last_code->expr2->value.op.op1->symtree, last_code->expr2->value.op.op1->ref->u.ar.dimen = 1;
false); last_code->expr2->value.op.op1->ref->u.ar.dimen_type[0] = DIMEN_ELEMENT;
size_intr = last_code->expr2->value.op.op1->symtree; last_code->expr2->value.op.op1->ref->u.ar.start[0] = gfc_copy_expr (rank);
last_code->expr2->value.op.op1->symtree->n.sym->attr.flavor = FL_PROCEDURE; last_code->expr2->value.op.op1->ref->u.ar.as = sizes->as;
last_code->expr2->value.op.op1->symtree->n.sym->attr.intrinsic = 1;
gfc_commit_symbol (last_code->expr2->value.op.op1->symtree->n.sym);
last_code->expr2->value.op.op1->value.function.actual
= gfc_get_actual_arglist ();
last_code->expr2->value.op.op1->value.function.actual->expr
= gfc_lval_expr_from_sym (array);
/* dim=NULL. */
last_code->expr2->value.op.op1->value.function.actual->next
= gfc_get_actual_arglist ();
/* kind=c_intptr_t. */
last_code->expr2->value.op.op1->value.function.actual->next->next
= gfc_get_actual_arglist ();
last_code->expr2->value.op.op1->value.function.actual->next->next->expr
= gfc_get_int_expr (gfc_index_integer_kind, NULL, 0);
last_code->expr2->value.op.op1->ts
= last_code->expr2->value.op.op1->value.function.isym->ts;
sub_ns->code = last_code;
/* Call final subroutines. We now generate code like: /* Call final subroutines. We now generate code like:
use iso_c_binding use iso_c_binding
...@@ -1539,15 +1983,6 @@ generate_finalization_wrapper (gfc_symbol *derived, gfc_namespace *ns, ...@@ -1539,15 +1983,6 @@ generate_finalization_wrapper (gfc_symbol *derived, gfc_namespace *ns,
if (derived->f2k_derived && derived->f2k_derived->finalizers) if (derived->f2k_derived && derived->f2k_derived->finalizers)
{ {
gfc_finalizer *fini, *fini_elem = NULL; 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); gfc_get_symbol ("ptr", sub_ns, &ptr);
ptr->ts.type = BT_DERIVED; ptr->ts.type = BT_DERIVED;
...@@ -1563,20 +1998,8 @@ generate_finalization_wrapper (gfc_symbol *derived, gfc_namespace *ns, ...@@ -1563,20 +1998,8 @@ generate_finalization_wrapper (gfc_symbol *derived, gfc_namespace *ns,
last_code = last_code->next; last_code = last_code->next;
last_code->op = EXEC_SELECT; last_code->op = EXEC_SELECT;
last_code->loc = gfc_current_locus; last_code->loc = gfc_current_locus;
last_code->expr1 = gfc_copy_expr (rank);
last_code->expr1 = gfc_get_expr (); block = NULL;
last_code->expr1->expr_type = EXPR_FUNCTION;
last_code->expr1->value.function.isym
= gfc_intrinsic_function_by_id (GFC_ISYM_RANK);
gfc_get_sym_tree ("rank", sub_ns, &last_code->expr1->symtree,
false);
last_code->expr1->symtree->n.sym->attr.flavor = FL_PROCEDURE;
last_code->expr1->symtree->n.sym->attr.intrinsic = 1;
gfc_commit_symbol (last_code->expr1->symtree->n.sym);
last_code->expr1->value.function.actual = gfc_get_actual_arglist ();
last_code->expr1->value.function.actual->expr
= gfc_lval_expr_from_sym (array);
last_code->expr1->ts = last_code->expr1->value.function.isym->ts;
for (fini = derived->f2k_derived->finalizers; fini; fini = fini->next) for (fini = derived->f2k_derived->finalizers; fini; fini = fini->next)
{ {
...@@ -1613,8 +2036,10 @@ generate_finalization_wrapper (gfc_symbol *derived, gfc_namespace *ns, ...@@ -1613,8 +2036,10 @@ generate_finalization_wrapper (gfc_symbol *derived, gfc_namespace *ns,
/* CALL fini_rank (array) - possibly with packing. */ /* CALL fini_rank (array) - possibly with packing. */
if (fini->proc_tree->n.sym->formal->sym->attr.dimension) if (fini->proc_tree->n.sym->formal->sym->attr.dimension)
finalizer_insert_packed_call (block, fini, array, stride, idx, ptr, finalizer_insert_packed_call (block, fini, array, byte_stride,
nelem, size_intr, sub_ns); idx, ptr, nelem, size_intr, strides,
sizes, idx2, offset, is_contiguous,
rank, sub_ns);
else else
{ {
block->next = XCNEW (gfc_code); block->next = XCNEW (gfc_code);
...@@ -1630,8 +2055,6 @@ generate_finalization_wrapper (gfc_symbol *derived, gfc_namespace *ns, ...@@ -1630,8 +2055,6 @@ generate_finalization_wrapper (gfc_symbol *derived, gfc_namespace *ns,
/* Elemental call - scalarized. */ /* Elemental call - scalarized. */
if (fini_elem) if (fini_elem)
{ {
gfc_iterator *iter;
/* CASE DEFAULT. */ /* CASE DEFAULT. */
if (block) if (block)
{ {
...@@ -1661,14 +2084,19 @@ generate_finalization_wrapper (gfc_symbol *derived, gfc_namespace *ns, ...@@ -1661,14 +2084,19 @@ generate_finalization_wrapper (gfc_symbol *derived, gfc_namespace *ns,
block->block = gfc_get_code (); block->block = gfc_get_code ();
block->block->op = EXEC_DO; block->block->op = EXEC_DO;
/* Offset calculation. */
block = finalization_get_offset (idx, idx2, offset, strides, sizes,
byte_stride, rank, block->block,
sub_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 * stride, c_ptr), ptr). */ + offset, c_ptr), ptr). */
block->block->next block->next
= finalization_scalarizer (idx, array, ptr, = finalization_scalarizer (array, ptr,
gfc_lval_expr_from_sym (stride), gfc_lval_expr_from_sym (offset),
sub_ns); sub_ns);
block = block->block->next; block = block->next;
/* CALL final_elemental (array). */ /* CALL final_elemental (array). */
block->next = XCNEW (gfc_code); block->next = XCNEW (gfc_code);
...@@ -1689,18 +2117,6 @@ generate_finalization_wrapper (gfc_symbol *derived, gfc_namespace *ns, ...@@ -1689,18 +2117,6 @@ generate_finalization_wrapper (gfc_symbol *derived, gfc_namespace *ns,
{ {
gfc_symbol *stat; gfc_symbol *stat;
gfc_code *block = NULL; gfc_code *block = NULL;
gfc_iterator *iter;
if (!idx)
{
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);
}
if (!ptr) if (!ptr)
{ {
...@@ -1736,14 +2152,18 @@ generate_finalization_wrapper (gfc_symbol *derived, gfc_namespace *ns, ...@@ -1736,14 +2152,18 @@ generate_finalization_wrapper (gfc_symbol *derived, gfc_namespace *ns,
last_code->block = gfc_get_code (); last_code->block = gfc_get_code ();
last_code->block->op = EXEC_DO; last_code->block->op = EXEC_DO;
/* Offset calculation. */
block = finalization_get_offset (idx, idx2, offset, strides, sizes,
byte_stride, rank, last_code->block,
sub_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 * stride, c_ptr), ptr). */ + idx * stride, c_ptr), ptr). */
last_code->block->next block->next = finalization_scalarizer (array, ptr,
= finalization_scalarizer (idx, array, ptr, gfc_lval_expr_from_sym(offset),
gfc_lval_expr_from_sym (stride), sub_ns);
sub_ns); block = block->next;
block = last_code->block->next;
for (comp = derived->components; comp; comp = comp->next) for (comp = derived->components; comp; comp = comp->next)
{ {
...@@ -1772,12 +2192,13 @@ generate_finalization_wrapper (gfc_symbol *derived, gfc_namespace *ns, ...@@ -1772,12 +2192,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 = gfc_get_actual_arglist ();
last_code->ext.actual->next->expr = gfc_lval_expr_from_sym (stride); last_code->ext.actual->next->expr = gfc_lval_expr_from_sym (byte_stride);
last_code->ext.actual->next->next = gfc_get_actual_arglist (); last_code->ext.actual->next->next = gfc_get_actual_arglist ();
last_code->ext.actual->next->next->expr last_code->ext.actual->next->next->expr
= gfc_lval_expr_from_sym (fini_coarray); = gfc_lval_expr_from_sym (fini_coarray);
} }
gfc_free_expr (rank);
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;
} }
......
Markdown is supported
0% or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment