/* Generate code equivalent to
CALL C_F_POINTER (TRANSFER (TRANSFER (C_LOC (array, cptr), c_intptr)
- + idx * stride, c_ptr), ptr). */
+ + offset, c_ptr), ptr). */
static gfc_code *
-finalization_scalarizer (gfc_symbol *idx, gfc_symbol *array, gfc_symbol *ptr,
- gfc_expr *stride, gfc_namespace *sub_ns)
+finalization_scalarizer (gfc_symbol *array, gfc_symbol *ptr,
+ gfc_expr *offset, gfc_namespace *sub_ns)
{
gfc_code *block;
- gfc_expr *expr, *expr2, *expr3;
+ gfc_expr *expr, *expr2;
/* C_F_POINTER(). */
block = XCNEW (gfc_code);
= gfc_intrinsic_function_by_id (GFC_ISYM_TRANSFER);
/* Set symtree for -fdump-parse-tree. */
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.intrinsic = 1;
gfc_commit_symbol (expr2->symtree->n.sym);
expr->ts.kind = gfc_index_integer_kind;
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>. */
block->ext.actual->expr = gfc_get_expr ();
block->ext.actual->expr->expr_type = EXPR_OP;
block->ext.actual->expr->value.op.op = INTRINSIC_PLUS;
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;
/* C_F_POINTER's 2nd arg: ptr -- and its absent shape=. */
}
+/* 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:
- 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 */
+ block
+ integer(c_intptr_t) :: i
+
+ if ((byte_stride == STORAGE_SIZE (array)/NUMERIC_STORAGE_SIZE
+ && (is_contiguous || !final_rank3->attr.contiguous
+ || final_rank3->as->type != AS_ASSUMED_SHAPE))
+ || 0 == STORAGE_SIZE (array)) then
+ call final_rank3 (array)
+ else
+ block
+ integer(c_intptr_t) :: offset, j
+ type(t) :: tmp(shape (array))
+
+ do i = 0, size (array)-1
+ offset = obtain_offset(i, strides, sizes, byte_stride)
+ addr = transfer (c_loc (array), addr) + offset
+ 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
+ block */
static void
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 *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_symbol *tmp_array, *ptr2;
- gfc_expr *size_expr;
+ gfc_expr *size_expr, *offset2, *expr;
gfc_namespace *ns;
gfc_iterator *iter;
+ gfc_code *block2;
int i;
block->next = XCNEW (gfc_code);
= 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->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.intrinsic = 1;
gfc_commit_symbol (size_expr->value.op.op1->symtree->n.sym);
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. */
+ /* 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->expr_type = EXPR_FUNCTION;
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->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;
+ /* byte_stride == size_expr */
+ expr = gfc_get_expr ();
+ expr->ts.type = BT_LOGICAL;
+ expr->ts.kind = gfc_default_logical_kind;
+ expr->expr_type = EXPR_OP;
+ expr->where = gfc_current_locus;
+ expr->value.op.op = INTRINSIC_EQ;
+ expr->value.op.op1
+ = gfc_lval_expr_from_sym (byte_stride);
+ 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 */
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->ts.kind = gfc_default_logical_kind;
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;
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();
block->block = gfc_get_code ();
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
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);
+ block2->next = finalization_scalarizer (array, ptr,
+ gfc_lval_expr_from_sym (offset),
+ sub_ns);
+ block2 = block2->next;
+ block2->next = finalization_scalarizer (tmp_array, ptr2, offset2, 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);
+ block2->next = XCNEW (gfc_code);
+ block2->next->op = EXEC_ASSIGN;
+ block2->next->loc = gfc_current_locus;
+ block2->next->expr1 = gfc_lval_expr_from_sym (ptr2);
+ block2->next->expr2 = gfc_lval_expr_from_sym (ptr);
+ /* Call now the user's final subroutine. */
block->next = XCNEW (gfc_code);
block = block->next;
block->op = EXEC_CALL;
block->block = gfc_get_code ();
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
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);
+ + offset, c_ptr), ptr). */
+ block2->next = finalization_scalarizer (array, ptr,
+ gfc_lval_expr_from_sym (offset),
+ sub_ns);
+ block2 = block2->next;
+ block2->next = finalization_scalarizer (tmp_array, ptr2, offset2, sub_ns);
+ block2 = block2->next;
+
/* 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);
+ block2->next = XCNEW (gfc_code);
+ block2->next->op = EXEC_ASSIGN;
+ block2->next->loc = gfc_current_locus;
+ block2->next->expr1 = gfc_lval_expr_from_sym (ptr);
+ block2->next->expr2 = gfc_lval_expr_from_sym (ptr2);
}
generate_finalization_wrapper (gfc_symbol *derived, gfc_namespace *ns,
const char *tname, gfc_component *vtab_final)
{
- gfc_symbol *final, *array, *nelem, *fini_coarray, *stride;
- gfc_symbol *ptr = NULL, *idx = NULL;
+ gfc_symbol *final, *array, *fini_coarray, *byte_stride, *sizes, *strides;
+ gfc_symbol *ptr = NULL, *idx, *idx2, *is_contiguous, *offset, *nelem;
gfc_symtree *size_intr;
gfc_component *comp;
gfc_namespace *sub_ns;
- gfc_code *last_code;
+ gfc_code *last_code, *block;
char name[GFC_MAX_SYMBOL_LEN+1];
bool finalizable_comp = 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. */
if (derived->attr.extension && derived->components
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);
+ gfc_get_symbol ("byte_stride", sub_ns, &byte_stride);
+ byte_stride->ts.type = BT_INTEGER;
+ byte_stride->ts.kind = gfc_index_integer_kind;
+ byte_stride->attr.flavor = FL_VARIABLE;
+ byte_stride->attr.dummy = 1;
+ byte_stride->attr.value = 1;
+ byte_stride->attr.artificial = 1;
+ gfc_set_sym_referenced (byte_stride);
final->formal->next = gfc_get_formal_arglist ();
- final->formal->next->sym = stride;
- gfc_commit_symbol (stride);
+ final->formal->next->sym = byte_stride;
+ gfc_commit_symbol (byte_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->ts.kind = 1;
fini_coarray->attr.flavor = FL_VARIABLE;
fini_coarray->attr.dummy = 1;
fini_coarray->attr.value = 1;
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. */
last_code = XCNEW (gfc_code);
last_code->expr2 = gfc_get_int_expr (4, NULL, 0);
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,
which is used in the scalarization. */
gfc_get_symbol ("nelem", sub_ns, &nelem);
gfc_set_sym_referenced (nelem);
gfc_commit_symbol (nelem);
- /* Generate: nelem = SIZE (array) - 1. */
+ /* nelem = sizes (rank) - 1. */
last_code->next = XCNEW (gfc_code);
last_code = last_code->next;
last_code->op = EXEC_ASSIGN;
= gfc_get_int_expr (gfc_index_integer_kind, NULL, 1);
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->expr_type = EXPR_FUNCTION;
- last_code->expr2->value.op.op1->value.function.isym
- = 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);
- 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;
+ last_code->expr2->value.op.op1 = gfc_lval_expr_from_sym (sizes);
+ last_code->expr2->value.op.op1->ref = gfc_get_ref ();
+ last_code->expr2->value.op.op1->ref->type = REF_ARRAY;
+ last_code->expr2->value.op.op1->ref->u.ar.type = AR_ELEMENT;
+ last_code->expr2->value.op.op1->ref->u.ar.dimen = 1;
+ last_code->expr2->value.op.op1->ref->u.ar.dimen_type[0] = DIMEN_ELEMENT;
+ last_code->expr2->value.op.op1->ref->u.ar.start[0] = gfc_copy_expr (rank);
+ last_code->expr2->value.op.op1->ref->u.ar.as = sizes->as;
/* Call final subroutines. We now generate code like:
use iso_c_binding
if (derived->f2k_derived && derived->f2k_derived->finalizers)
{
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;
last_code = last_code->next;
last_code->op = EXEC_SELECT;
last_code->loc = gfc_current_locus;
-
- last_code->expr1 = gfc_get_expr ();
- 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;
+ last_code->expr1 = gfc_copy_expr (rank);
+ block = NULL;
for (fini = derived->f2k_derived->finalizers; fini; fini = fini->next)
{
/* 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);
+ finalizer_insert_packed_call (block, fini, array, byte_stride,
+ idx, ptr, nelem, size_intr, strides,
+ sizes, idx2, offset, is_contiguous,
+ rank, sub_ns);
else
{
block->next = XCNEW (gfc_code);
/* Elemental call - scalarized. */
if (fini_elem)
{
- gfc_iterator *iter;
-
/* CASE DEFAULT. */
if (block)
{
block->block = gfc_get_code ();
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
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->block->next;
+ + offset, c_ptr), ptr). */
+ block->next
+ = finalization_scalarizer (array, ptr,
+ gfc_lval_expr_from_sym (offset),
+ sub_ns);
+ block = block->next;
/* CALL final_elemental (array). */
block->next = XCNEW (gfc_code);
{
gfc_symbol *stat;
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)
{
last_code->block = gfc_get_code ();
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
CALL C_F_POINTER (TRANSFER (TRANSFER (C_LOC (array, cptr), c_intptr)
+ 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;
+ block->next = finalization_scalarizer (array, ptr,
+ gfc_lval_expr_from_sym(offset),
+ sub_ns);
+ block = block->next;
for (comp = derived->components; comp; comp = comp->next)
{
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->expr = gfc_lval_expr_from_sym (byte_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_free_expr (rank);
vtab_final->initializer = gfc_lval_expr_from_sym (final);
vtab_final->ts.interface = final;
}
projects / thirdparty / gcc.git / commitdiff
