diff --git a/gcc/fortran/class.c b/gcc/fortran/class.c index 61d65e7..84f383e 100644 --- a/gcc/fortran/class.c +++ b/gcc/fortran/class.c @@ -597,7 +597,7 @@ gfc_build_class_symbol (gfc_typespec *ts, symbol_attribute *attr, fclass->refs++; fclass->ts.type = BT_UNKNOWN; if (!ts->u.derived->attr.unlimited_polymorphic) - fclass->attr.abstract = ts->u.derived->attr.abstract; + fclass->attr.abstract = ts->u.derived->attr.abstract; fclass->f2k_derived = gfc_get_namespace (NULL, 0); if (gfc_add_flavor (&fclass->attr, FL_DERIVED, NULL, &gfc_current_locus) == FAILURE) @@ -924,14 +924,14 @@ finalize_component (gfc_expr *expr, gfc_symbol *derived, gfc_component *comp, /* Generate code equivalent to CALL C_F_POINTER (TRANSFER (TRANSFER (C_LOC (array, cptr), c_intptr) - + idx * 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); @@ -961,6 +961,7 @@ finalization_scalarizer (gfc_symbol *idx, gfc_symbol *array, gfc_symbol *ptr, = 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); @@ -995,21 +996,12 @@ finalization_scalarizer (gfc_symbol *idx, gfc_symbol *array, gfc_symbol *ptr, 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; - /* + . */ 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=. */ @@ -1021,39 +1013,182 @@ 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)) / size(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_namespace *sub_ns) + gfc_symbol *strides, gfc_symbol *sizes, + gfc_symbol *idx2, gfc_symbol *offset, + gfc_expr *rank, gfc_namespace *sub_ns) { gfc_symbol *tmp_array, *ptr2; - gfc_expr *size_expr; + gfc_expr *size_expr, *offset2; gfc_namespace *ns; gfc_iterator *iter; + gfc_code *block2; int i; block->next = XCNEW (gfc_code); @@ -1080,6 +1215,8 @@ finalizer_insert_packed_call (gfc_code *block, gfc_finalizer *fini, = 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); @@ -1096,32 +1233,33 @@ finalizer_insert_packed_call (gfc_code *block, gfc_finalizer *fini, 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 || 0 == size_expr. */ /* FIXME: add ASSUMED_SHAPE||!contiguous check. */ 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 */ + /* byte_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->ts.kind = gfc_default_logical_kind; 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.op1 + = gfc_lval_expr_from_sym (byte_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->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; @@ -1168,7 +1306,6 @@ finalizer_insert_packed_call (gfc_code *block, gfc_finalizer *fini, 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(); @@ -1217,22 +1354,36 @@ finalizer_insert_packed_call (gfc_code *block, gfc_finalizer *fini, 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; @@ -1262,21 +1413,26 @@ finalizer_insert_packed_call (gfc_code *block, gfc_finalizer *fini, 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); } @@ -1300,16 +1456,17 @@ static void 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 @@ -1423,22 +1580,22 @@ generate_finalization_wrapper (gfc_symbol *derived, gfc_namespace *ns, 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; @@ -1457,7 +1614,92 @@ generate_finalization_wrapper (gfc_symbol *derived, gfc_namespace *ns, 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); + + +/* FIXME: How to handle this one? For coarrays? Or remove it and change __final to a subroutine? */ /* Set return value to 0. */ last_code = XCNEW (gfc_code); last_code->op = EXEC_ASSIGN; @@ -1466,6 +1708,207 @@ generate_finalization_wrapper (gfc_symbol *derived, gfc_namespace *ns, 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->expr_type = EXPR_FUNCTION; + 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); @@ -1476,7 +1919,7 @@ generate_finalization_wrapper (gfc_symbol *derived, gfc_namespace *ns, 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; @@ -1491,32 +1934,14 @@ generate_finalization_wrapper (gfc_symbol *derived, gfc_namespace *ns, = 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 @@ -1539,15 +1964,6 @@ generate_finalization_wrapper (gfc_symbol *derived, gfc_namespace *ns, 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; @@ -1563,20 +1979,8 @@ generate_finalization_wrapper (gfc_symbol *derived, gfc_namespace *ns, 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) { @@ -1613,8 +2017,9 @@ generate_finalization_wrapper (gfc_symbol *derived, gfc_namespace *ns, /* 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, rank, sub_ns); else { block->next = XCNEW (gfc_code); @@ -1630,8 +2035,6 @@ generate_finalization_wrapper (gfc_symbol *derived, gfc_namespace *ns, /* Elemental call - scalarized. */ if (fini_elem) { - gfc_iterator *iter; - /* CASE DEFAULT. */ if (block) { @@ -1661,14 +2064,19 @@ generate_finalization_wrapper (gfc_symbol *derived, gfc_namespace *ns, 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); @@ -1689,18 +2097,6 @@ generate_finalization_wrapper (gfc_symbol *derived, gfc_namespace *ns, { 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) { @@ -1736,14 +2132,18 @@ generate_finalization_wrapper (gfc_symbol *derived, gfc_namespace *ns, 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) { @@ -1772,12 +2172,13 @@ generate_finalization_wrapper (gfc_symbol *derived, gfc_namespace *ns, last_code->ext.actual = gfc_get_actual_arglist (); last_code->ext.actual->expr = gfc_lval_expr_from_sym (array); last_code->ext.actual->next = gfc_get_actual_arglist (); - last_code->ext.actual->next->expr = gfc_lval_expr_from_sym (stride); + last_code->ext.actual->next->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; } @@ -2024,9 +2425,7 @@ gfc_find_derived_vtab (gfc_symbol *derived) components and the calls to finalization subroutines. Note: The actual wrapper function can only be generated at resolution time. */ - /* FIXME: Enable ABI-breaking "_final" generation. */ - if (0) - { + if (gfc_add_component (vtype, "_final", &c) == FAILURE) goto cleanup; c->attr.proc_pointer = 1; @@ -2034,7 +2433,6 @@ gfc_find_derived_vtab (gfc_symbol *derived) c->tb = XCNEW (gfc_typebound_proc); c->tb->ppc = 1; generate_finalization_wrapper (derived, ns, tname, c); - } /* Add procedure pointers for type-bound procedures. */ if (!derived->attr.unlimited_polymorphic) @@ -2310,6 +2708,15 @@ gfc_find_intrinsic_vtab (gfc_typespec *ts) /* Set initializer. */ c->initializer = gfc_lval_expr_from_sym (copy); c->ts.interface = copy; + + /* Add component _final. */ + if (gfc_add_component (vtype, "_final", &c) == FAILURE) + goto cleanup; + c->attr.proc_pointer = 1; + c->attr.access = ACCESS_PRIVATE; + c->tb = XCNEW (gfc_typebound_proc); + c->tb->ppc = 1; + c->initializer = gfc_get_null_expr (NULL); } vtab->ts.u.derived = vtype; vtab->value = gfc_default_initializer (&vtab->ts); diff --git a/gcc/fortran/gfortran.h b/gcc/fortran/gfortran.h index a419af3..027cab6 100644 --- a/gcc/fortran/gfortran.h +++ b/gcc/fortran/gfortran.h @@ -521,6 +521,7 @@ enum gfc_isym_id GFC_ISYM_SR_KIND, GFC_ISYM_STAT, GFC_ISYM_STORAGE_SIZE, + GFC_ISYM_STRIDE, GFC_ISYM_SUM, GFC_ISYM_SYMLINK, GFC_ISYM_SYMLNK, diff --git a/gcc/fortran/intrinsic.c b/gcc/fortran/intrinsic.c index 274c921..8328b9b 100644 --- a/gcc/fortran/intrinsic.c +++ b/gcc/fortran/intrinsic.c @@ -2640,6 +2640,14 @@ add_functions (void) make_generic ("size", GFC_ISYM_SIZE, GFC_STD_F95); + /* Obtain the stride for a given dimensions; to be used only internally. + "make_from_module" makes inaccessible for external users. */ + add_sym_2 (GFC_PREFIX ("stride"), GFC_ISYM_STRIDE, CLASS_INQUIRY, ACTUAL_NO, + BT_INTEGER, gfc_index_integer_kind, GFC_STD_GNU, + NULL, NULL, gfc_resolve_stride, + ar, BT_REAL, dr, REQUIRED, dm, BT_INTEGER, ii, OPTIONAL); + make_from_module(); + add_sym_1 ("sizeof", GFC_ISYM_SIZEOF, CLASS_IMPURE, ACTUAL_NO, BT_INTEGER, ii, GFC_STD_GNU, gfc_check_sizeof, NULL, NULL, x, BT_UNKNOWN, 0, REQUIRED); diff --git a/gcc/fortran/intrinsic.h b/gcc/fortran/intrinsic.h index 2635ba6..4540ad8 100644 --- a/gcc/fortran/intrinsic.h +++ b/gcc/fortran/intrinsic.h @@ -546,6 +546,7 @@ void gfc_resolve_signal (gfc_expr *, gfc_expr *, gfc_expr *); void gfc_resolve_sin (gfc_expr *, gfc_expr *); void gfc_resolve_sinh (gfc_expr *, gfc_expr *); void gfc_resolve_size (gfc_expr *, gfc_expr *, gfc_expr *, gfc_expr *); +void gfc_resolve_stride (gfc_expr *, gfc_expr *, gfc_expr *); void gfc_resolve_spacing (gfc_expr *, gfc_expr *); void gfc_resolve_spread (gfc_expr *, gfc_expr *, gfc_expr *, gfc_expr *); void gfc_resolve_sqrt (gfc_expr *, gfc_expr *); diff --git a/gcc/fortran/iresolve.c b/gcc/fortran/iresolve.c index 3f981d8..c884fc1 100644 --- a/gcc/fortran/iresolve.c +++ b/gcc/fortran/iresolve.c @@ -2314,6 +2314,15 @@ gfc_resolve_size (gfc_expr *f, gfc_expr *array ATTRIBUTE_UNUSED, void +gfc_resolve_stride (gfc_expr *f, gfc_expr *array ATTRIBUTE_UNUSED, + gfc_expr *dim ATTRIBUTE_UNUSED) +{ + f->ts.type = BT_INTEGER; + f->ts.kind = gfc_index_integer_kind; +} + + +void gfc_resolve_spacing (gfc_expr *f, gfc_expr *x) { f->ts = x->ts; diff --git a/gcc/fortran/resolve.c b/gcc/fortran/resolve.c index 873400a..5963acd 100644 --- a/gcc/fortran/resolve.c +++ b/gcc/fortran/resolve.c @@ -11747,10 +11747,6 @@ error: " defined at %L, suggest also scalar one", derived->name, &derived->declared_at); - /* TODO: Remove this error when finalization is finished. */ - gfc_error ("Finalization at %L is not yet implemented", - &derived->declared_at); - gfc_find_derived_vtab (derived); return result; } diff --git a/gcc/fortran/trans-decl.c b/gcc/fortran/trans-decl.c index 88f9c56..19a628b 100644 --- a/gcc/fortran/trans-decl.c +++ b/gcc/fortran/trans-decl.c @@ -1421,7 +1421,12 @@ gfc_get_symbol_decl (gfc_symbol * sym) && !sym->attr.data && !sym->attr.allocatable && (sym->value && !sym->ns->proc_name->attr.is_main_program) - && !(sym->attr.use_assoc && !intrinsic_array_parameter))) + && !(sym->attr.use_assoc && !intrinsic_array_parameter)) + /* Finalization. */ + || (sym->ts.type == BT_DERIVED && gfc_is_finalizable (sym->ts.u.derived, NULL) + && !sym->attr.pointer && !sym->attr.allocatable && !sym->attr.dummy + && !sym->attr.result && sym->attr.save == SAVE_NONE + && !sym->ns->proc_name->attr.is_main_program)) gfc_defer_symbol_init (sym); gfc_finish_var_decl (decl, sym); @@ -3458,7 +3463,30 @@ init_intent_out_dt (gfc_symbol * proc_sym, gfc_wrapped_block * block) && !f->sym->attr.pointer && f->sym->ts.type == BT_DERIVED) { - if (f->sym->ts.u.derived->attr.alloc_comp && !f->sym->value) + gfc_expr *final_expr = NULL; + gfc_is_finalizable (f->sym->ts.u.derived, &final_expr); + + if (final_expr) + { + f->sym->attr.referenced = 1; + tmp = gfc_build_final_call (f->sym->ts, final_expr, + gfc_lval_expr_from_sym (f->sym), false, NULL); + + if (f->sym->attr.optional + || f->sym->ns->proc_name->attr.entry_master) + { + present = gfc_conv_expr_present (f->sym); + tmp = build3_loc (input_location, COND_EXPR, TREE_TYPE (tmp), + present, tmp, + build_empty_stmt (input_location)); + } + + gfc_add_expr_to_block (&init, tmp); + + if (f->sym->value) + gfc_init_default_dt (f->sym, &init, false); + } + else if (f->sym->ts.u.derived->attr.alloc_comp && !f->sym->value) { tmp = gfc_deallocate_alloc_comp (f->sym->ts.u.derived, f->sym->backend_decl, @@ -3480,25 +3508,65 @@ init_intent_out_dt (gfc_symbol * proc_sym, gfc_wrapped_block * block) } else if (f->sym && f->sym->attr.intent == INTENT_OUT && f->sym->ts.type == BT_CLASS - && !CLASS_DATA (f->sym)->attr.class_pointer - && CLASS_DATA (f->sym)->ts.u.derived->attr.alloc_comp) + && !CLASS_DATA (f->sym)->attr.class_pointer) { - tmp = gfc_class_data_get (f->sym->backend_decl); - if (CLASS_DATA (f->sym)->as == NULL) - tmp = build_fold_indirect_ref_loc (input_location, tmp); - tmp = gfc_deallocate_alloc_comp (CLASS_DATA (f->sym)->ts.u.derived, - tmp, - CLASS_DATA (f->sym)->as ? - CLASS_DATA (f->sym)->as->rank : 0); - - if (f->sym->attr.optional || f->sym->ns->proc_name->attr.entry_master) + gfc_expr *final_expr = NULL; + gfc_expr *vptr_size; + bool has_finalizer; + + has_finalizer = gfc_is_finalizable (f->sym->ts.u.derived, NULL); + /* Make sure the vtab is available. */ + if (!UNLIMITED_POLY (f->sym)) + gfc_find_derived_vtab (f->sym->ts.u.derived); + final_expr = gfc_lval_expr_from_sym (f->sym); + vptr_size = gfc_lval_expr_from_sym (f->sym); + gfc_add_vptr_component (final_expr); + gfc_add_component_ref (final_expr, "_final"); + gfc_add_vptr_component (vptr_size); + gfc_add_component_ref (vptr_size, "_size"); + + f->sym->attr.referenced = 1; + tmp = gfc_build_final_call (f->sym->ts, final_expr, + gfc_lval_expr_from_sym (f->sym), false, + vptr_size); + + if (!has_finalizer) { - present = gfc_conv_expr_present (f->sym); + tree cond; +/* FIXME: For OPTIONAL, the condition is completely missing, see: PR fortran/54618 */ +/* cond = gfc_class_data_get (f->sym->backend_decl); + if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (cond))) + cond = gfc_conv_descriptor_data_get (cond); + else if (!POINTER_TYPE_P (TREE_TYPE (cond))) + cond = gfc_build_addr_expr (NULL_TREE, cond); */ + + cond = gfc_vtable_final_get (f->sym->backend_decl); + cond = fold_build2_loc (input_location, NE_EXPR, boolean_type_node, + cond, build_int_cst (TREE_TYPE (cond), 0)); + + /* For CLASS(*) not only sym->_vtab->_final can be NULL but already + sym->_vtab itself. */ + if (UNLIMITED_POLY (f->sym)) + { + tree cond2; + cond2 = gfc_class_vptr_get (f->sym->backend_decl); + cond2 = fold_build2_loc (input_location, NE_EXPR, boolean_type_node, + cond2, build_int_cst (TREE_TYPE (cond2), 0)); + cond = fold_build2_loc (input_location, TRUTH_ANDIF_EXPR, + boolean_type_node, cond2, cond); + } + + if (f->sym->attr.optional + || f->sym->ns->proc_name->attr.entry_master) + { + present = gfc_conv_expr_present (f->sym); + cond = fold_build2_loc (input_location, TRUTH_ANDIF_EXPR, + boolean_type_node, present, cond); + } + tmp = build3_loc (input_location, COND_EXPR, TREE_TYPE (tmp), - present, tmp, - build_empty_stmt (input_location)); + cond, tmp, build_empty_stmt (input_location)); } - gfc_add_expr_to_block (&init, tmp); } @@ -3508,12 +3576,13 @@ init_intent_out_dt (gfc_symbol * proc_sym, gfc_wrapped_block * block) /* Generate function entry and exit code, and add it to the function body. This includes: - Allocation and initialization of array variables. - Allocation of character string variables. - Initialization and possibly repacking of dummy arrays. - Initialization of ASSIGN statement auxiliary variable. - Initialization of ASSOCIATE names. - Automatic deallocation. */ + - Allocation and initialization of array variables. + - Allocation of character string variables. + - Initialization and possibly repacking of dummy arrays. + - Initialization of ASSIGN statement auxiliary variable. + - Initialization of ASSOCIATE names. + - Automatic deallocation. + - Finalization. */ void gfc_trans_deferred_vars (gfc_symbol * proc_sym, gfc_wrapped_block * block) diff --git a/gcc/fortran/trans-expr.c b/gcc/fortran/trans-expr.c index 452f2bc..ed95739 100644 --- a/gcc/fortran/trans-expr.c +++ b/gcc/fortran/trans-expr.c @@ -61,8 +61,8 @@ get_scalar_to_descriptor_type (tree scalar, symbol_attribute attr) akind, !(attr.pointer || attr.target)); } -static tree -conv_scalar_to_descriptor (gfc_se *se, tree scalar, symbol_attribute attr) +tree +gfc_conv_scalar_to_descriptor (gfc_se *se, tree scalar, symbol_attribute attr) { tree desc, type; @@ -1850,7 +1850,8 @@ gfc_conv_unary_op (enum tree_code code, gfc_se * se, gfc_expr * expr) We must convert it to a compare to 0 (e.g. EQ_EXPR (op1, 0)). All other unary operators have an equivalent GIMPLE unary operator. */ if (code == TRUTH_NOT_EXPR) - se->expr = fold_build2_loc (input_location, EQ_EXPR, type, operand.expr, + se->expr = fold_build2_loc (input_location, EQ_EXPR, type, + fold_convert (type, operand.expr), build_int_cst (type, 0)); else se->expr = fold_build1_loc (input_location, code, type, operand.expr); @@ -4355,8 +4356,8 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym, if (TREE_CODE (tmp) == ADDR_EXPR && POINTER_TYPE_P (TREE_TYPE (TREE_OPERAND (tmp, 0)))) tmp = TREE_OPERAND (tmp, 0); - parmse.expr = conv_scalar_to_descriptor (&parmse, tmp, - fsym->attr); + parmse.expr = gfc_conv_scalar_to_descriptor (&parmse, tmp, + fsym->attr); parmse.expr = gfc_build_addr_expr (NULL_TREE, parmse.expr); } diff --git a/gcc/fortran/trans-intrinsic.c b/gcc/fortran/trans-intrinsic.c index 5a89be1..8447180 100644 --- a/gcc/fortran/trans-intrinsic.c +++ b/gcc/fortran/trans-intrinsic.c @@ -1657,6 +1657,35 @@ conv_intrinsic_cobound (gfc_se * se, gfc_expr * expr) static void +conv_intrinsic_stride (gfc_se * se, gfc_expr * expr) +{ + gfc_actual_arglist *array_arg; + gfc_actual_arglist *dim_arg; + gfc_se argse; + tree desc, tmp; + + array_arg = expr->value.function.actual; + dim_arg = array_arg->next; + + gcc_assert (array_arg->expr->expr_type == EXPR_VARIABLE); + + gfc_init_se (&argse, NULL); + gfc_conv_expr_descriptor (&argse, array_arg->expr); + gfc_add_block_to_block (&se->pre, &argse.pre); + gfc_add_block_to_block (&se->post, &argse.post); + desc = argse.expr; + + gcc_assert (dim_arg->expr); + gfc_init_se (&argse, NULL); + gfc_conv_expr_type (&argse, dim_arg->expr, gfc_array_index_type); + gfc_add_block_to_block (&se->pre, &argse.pre); + tmp = fold_build2_loc (input_location, MINUS_EXPR, gfc_array_index_type, + argse.expr, gfc_index_one_node); + se->expr = gfc_conv_descriptor_stride_get (desc, tmp); +} + + +static void gfc_conv_intrinsic_abs (gfc_se * se, gfc_expr * expr) { tree arg, cabs; @@ -6806,7 +6835,11 @@ gfc_conv_intrinsic_function (gfc_se * se, gfc_expr * expr) gfc_conv_intrinsic_spacing (se, expr); break; - case GFC_ISYM_SUM: + case GFC_ISYM_STRIDE: + conv_intrinsic_stride (se, expr); + break; + + case GFC_ISYM_SUM: gfc_conv_intrinsic_arith (se, expr, PLUS_EXPR, false); break; diff --git a/gcc/fortran/trans-stmt.c b/gcc/fortran/trans-stmt.c index e41a0c7..e2b2b2e 100644 --- a/gcc/fortran/trans-stmt.c +++ b/gcc/fortran/trans-stmt.c @@ -5239,6 +5239,7 @@ gfc_trans_allocate (gfc_code * code) gfc_add_component_ref (ppc, "_copy"); ppc_code = gfc_get_code (); + /* FIXME: Probably, the interface is not avilable, cf. _final ...*/ ppc_code->resolved_sym = ppc->symtree->n.sym; /* Although '_copy' is set to be elemental in class.c, it is not staying that way. Find out why, sometime.... */ @@ -5422,13 +5423,85 @@ gfc_trans_deallocate (gfc_code *code) gfc_init_se (&se, NULL); gfc_start_block (&se.pre); +/* FIXME: HOW is var == NULL handled? And how are coarrays error stats handled? */ se.want_pointer = 1; se.descriptor_only = 1; gfc_conv_expr (&se, expr); if (expr->rank || gfc_is_coarray (expr)) { - if (expr->ts.type == BT_DERIVED && expr->ts.u.derived->attr.alloc_comp) + gfc_expr *final_expr = NULL; + gfc_expr *elem_size = NULL; + bool has_finalizer = false; + + if (al->expr->ts.type == BT_CLASS) + { + gfc_is_finalizable (al->expr->ts.u.derived, NULL); + + final_expr = gfc_copy_expr (al->expr); + gfc_add_vptr_component (final_expr); + gfc_add_component_ref (final_expr, "_final"); + + elem_size = gfc_copy_expr (al->expr); + gfc_add_vptr_component (elem_size); + gfc_add_component_ref (elem_size, "_size"); + } + else if (al->expr->ts.type == BT_DERIVED) + gfc_is_finalizable (al->expr->ts.u.derived, &final_expr); + + if (final_expr) + { + tree cond; + + tmp = gfc_conv_descriptor_data_get (se.expr); + STRIP_NOPS (se.expr); + + cond = fold_build2_loc (input_location, NE_EXPR, + boolean_type_node, tmp, + null_pointer_node); + + if (al->expr->ts.type == BT_CLASS && !has_finalizer) + { + tree cond2; + gfc_se se2; + + /* For CLASS(*) not only sym->_vtab->_final can be NULL + but already sym->_vtab itself. */ + if (UNLIMITED_POLY (al->expr)) + { + cond2 = gfc_class_vptr_get (se.expr); + cond2 = fold_build2_loc (input_location, NE_EXPR, + boolean_type_node, + cond2, + build_int_cst (TREE_TYPE (cond2), + 0)); + cond = fold_build2_loc (input_location, TRUTH_ANDIF_EXPR, + boolean_type_node, cond, cond2); + } + + gfc_init_se (&se2, NULL); + se2.want_pointer = 1; + gfc_conv_expr (&se2, final_expr); + cond2 = fold_build2_loc (input_location, NE_EXPR, + boolean_type_node, se2.expr, + build_int_cst (TREE_TYPE (se2.expr), + 0)); + cond = fold_build2_loc (input_location, TRUTH_AND_EXPR, + boolean_type_node, cond, cond2); + } + + tmp = gfc_build_final_call (al->expr->ts, final_expr, + gfc_copy_expr (expr), false, + elem_size); + + tmp = fold_build3_loc (input_location, COND_EXPR, void_type_node, + cond, tmp, + build_empty_stmt (input_location)); + gfc_add_expr_to_block (&se.pre, tmp); + } + + if (!final_expr && expr->ts.type == BT_DERIVED + && expr->ts.u.derived->attr.alloc_comp) { gfc_ref *ref; gfc_ref *last = NULL; diff --git a/gcc/fortran/trans.c b/gcc/fortran/trans.c index 70f06ff..9296e06 100644 --- a/gcc/fortran/trans.c +++ b/gcc/fortran/trans.c @@ -1023,6 +1023,116 @@ gfc_deallocate_with_status (tree pointer, tree status, tree errmsg, } +/* Build a call to a FINAL procedure, which finalizes "var". */ + +tree +gfc_build_final_call (gfc_typespec ts, gfc_expr *final_wrapper, gfc_expr *var, + bool fini_coarray, gfc_expr *class_size) +{ + stmtblock_t block; + gfc_se se; + tree final_fndecl, array, size, tmp; + + gcc_assert (final_wrapper->expr_type == EXPR_VARIABLE); + gcc_assert (var); + + gfc_init_se (&se, NULL); + gfc_conv_expr (&se, final_wrapper); + final_fndecl = se.expr; + if (POINTER_TYPE_P (TREE_TYPE (final_fndecl))) + final_fndecl = build_fold_indirect_ref_loc (input_location, final_fndecl); + + if (ts.type == BT_DERIVED) + { + tree elem_size; + + gcc_assert (!class_size); + elem_size = gfc_typenode_for_spec (&ts); + elem_size = TYPE_SIZE_UNIT (elem_size); + size = fold_convert (gfc_array_index_type, elem_size); + + gfc_init_se (&se, NULL); + se.want_pointer = 1; + if (var->rank || gfc_expr_attr (var).dimension) + { + se.descriptor_only = 1; + gfc_conv_expr_descriptor (&se, var); + array = se.expr; + if (!POINTER_TYPE_P (TREE_TYPE (array))) + array = gfc_build_addr_expr (NULL, array); + } + else + { + symbol_attribute attr; + gfc_clear_attr (&attr); + gfc_conv_expr (&se, var); + gcc_assert (se.pre.head == NULL_TREE && se.post.head == NULL_TREE); + array = se.expr; + if (TREE_CODE (array) == ADDR_EXPR + && POINTER_TYPE_P (TREE_TYPE (TREE_OPERAND (array, 0)))) + tmp = TREE_OPERAND (array, 0); + + gfc_init_se (&se, NULL); + array = gfc_conv_scalar_to_descriptor (&se, array, attr); + array = gfc_build_addr_expr (NULL, array); + gcc_assert (se.post.head == NULL_TREE); + } + } + else + { + gfc_expr *array_expr; + gcc_assert (class_size); + gfc_init_se (&se, NULL); + gfc_conv_expr (&se, class_size); + gcc_assert (se.pre.head == NULL_TREE && se.post.head == NULL_TREE); + size = se.expr; + + array_expr = gfc_copy_expr (var); + gfc_add_data_component (array_expr); + gfc_init_se (&se, NULL); + se.want_pointer = 1; + if (array_expr->rank || gfc_expr_attr (array_expr).dimension) + { + se.descriptor_only = 1; + gfc_conv_expr_descriptor (&se, var); + array = se.expr; + if (! POINTER_TYPE_P (TREE_TYPE (array))) + array = gfc_build_addr_expr (NULL, array); + } + else + { + symbol_attribute attr; + + gfc_clear_attr (&attr); + gfc_conv_expr (&se, array_expr); + gcc_assert (se.pre.head == NULL_TREE && se.post.head == NULL_TREE); + array = se.expr; + if (TREE_CODE (array) == ADDR_EXPR + && POINTER_TYPE_P (TREE_TYPE (TREE_OPERAND (array, 0)))) + tmp = TREE_OPERAND (array, 0); + + /* attr: Argument is neither a pointer/allocatble, + i.e. no copy back needed */ + gfc_init_se (&se, NULL); + array = gfc_conv_scalar_to_descriptor (&se, array, attr); + array = gfc_build_addr_expr (NULL, array); + gcc_assert (se.post.head == NULL_TREE); + } + gfc_free_expr (array_expr); + } + + gfc_start_block (&block); + gfc_add_block_to_block (&block, &se.pre); + tmp = build_call_expr_loc (input_location, + final_fndecl, 3, array, + size, fini_coarray ? boolean_true_node + : boolean_false_node); + gfc_add_block_to_block (&block, &se.post); + gfc_add_expr_to_block (&block, tmp); + return gfc_finish_block (&block); +} + + /* Generate code for deallocation of allocatable scalars (variables or components). Before the object itself is freed, any allocatable subcomponents are being deallocated. */ @@ -1077,21 +1187,86 @@ gfc_deallocate_scalar_with_status (tree pointer, tree status, bool can_fail, gfc_start_block (&non_null); /* Free allocatable components. */ - if (ts.type == BT_DERIVED && ts.u.derived->attr.alloc_comp) +{ + gfc_expr *final_expr = NULL; + gfc_expr *elem_size = NULL; + bool has_finalizer = false; + +/* FIXME: !expr && ts.type == BT_CLASS shouldn't happen. + Cf. trans-array.c's structure_alloc_comps for a case where it does occur. */ + if (expr && ts.type == BT_CLASS) { - tmp = build_fold_indirect_ref_loc (input_location, pointer); - tmp = gfc_deallocate_alloc_comp (ts.u.derived, tmp, 0); + has_finalizer = gfc_is_finalizable (ts.u.derived, NULL); + + final_expr = gfc_copy_expr (expr); + gfc_add_vptr_component (final_expr); + gfc_add_component_ref (final_expr, "_final"); + + elem_size = gfc_copy_expr (expr); + gfc_add_vptr_component (elem_size); + gfc_add_component_ref (elem_size, "_size"); + } + else if (expr && ts.type == BT_DERIVED) + gfc_is_finalizable (ts.u.derived, &final_expr); + + if (final_expr) + { + gcc_assert (expr); + gcc_assert (final_expr->expr_type == EXPR_VARIABLE); + + tmp = gfc_build_final_call (ts, final_expr, + gfc_copy_expr (expr), false, + elem_size); + + if (ts.type == BT_CLASS && !has_finalizer) + { + tree cond; + gfc_se se; + + gfc_init_se (&se, NULL); + se.want_pointer = 1; + gfc_conv_expr (&se, final_expr); + cond = fold_build2_loc (input_location, NE_EXPR, boolean_type_node, + se.expr, + build_int_cst (TREE_TYPE (se.expr), 0)); + + /* For CLASS(*) not only sym->_vtab->_final can be NULL + but already sym->_vtab itself. */ + if (UNLIMITED_POLY (expr)) + { + tree cond2; + gfc_expr *vptr_expr; + + vptr_expr = gfc_copy_expr (expr); + gfc_add_vptr_component (vptr_expr); + + gfc_init_se (&se, NULL); + se.want_pointer = 1; + gfc_conv_expr (&se, vptr_expr); + gfc_free_expr (vptr_expr); + + cond2 = fold_build2_loc (input_location, NE_EXPR, + boolean_type_node, se.expr, + build_int_cst (TREE_TYPE (se.expr), + 0)); + cond = fold_build2_loc (input_location, TRUTH_ANDIF_EXPR, + boolean_type_node, cond2, cond); + } + + tmp = fold_build3_loc (input_location, COND_EXPR, void_type_node, + cond, tmp, build_empty_stmt (input_location)); + } + gfc_add_expr_to_block (&non_null, tmp); } - else if (ts.type == BT_CLASS - && ts.u.derived->components->ts.u.derived->attr.alloc_comp) + + if (!final_expr && ts.type == BT_DERIVED && ts.u.derived->attr.alloc_comp) { tmp = build_fold_indirect_ref_loc (input_location, pointer); - tmp = gfc_deallocate_alloc_comp (ts.u.derived->components->ts.u.derived, - tmp, 0); + tmp = gfc_deallocate_alloc_comp (ts.u.derived, tmp, 0); gfc_add_expr_to_block (&non_null, tmp); } - +} tmp = build_call_expr_loc (input_location, builtin_decl_explicit (BUILT_IN_FREE), 1, fold_convert (pvoid_type_node, pointer)); diff --git a/gcc/fortran/trans.h b/gcc/fortran/trans.h index 1779575..2818fae 100644 --- a/gcc/fortran/trans.h +++ b/gcc/fortran/trans.h @@ -352,6 +352,8 @@ tree gfc_vtable_final_get (tree); tree gfc_get_vptr_from_expr (tree); tree gfc_get_class_array_ref (tree, tree); tree gfc_copy_class_to_class (tree, tree, tree); +tree gfc_build_final_call (gfc_typespec, gfc_expr *, gfc_expr *, bool, + gfc_expr *); void gfc_conv_derived_to_class (gfc_se *, gfc_expr *, gfc_typespec, tree, bool, bool); void gfc_conv_class_to_class (gfc_se *, gfc_expr *, gfc_typespec, bool, bool, @@ -403,6 +405,9 @@ void gfc_conv_expr_lhs (gfc_se * se, gfc_expr * expr); void gfc_conv_expr_reference (gfc_se * se, gfc_expr *); void gfc_conv_expr_type (gfc_se * se, gfc_expr *, tree); +tree gfc_conv_scalar_to_descriptor (gfc_se *, tree, symbol_attribute); + + /* trans-expr.c */ void gfc_conv_scalar_char_value (gfc_symbol *sym, gfc_se *se, gfc_expr **expr); tree gfc_string_to_single_character (tree len, tree str, int kind); diff --git a/gcc/testsuite/gfortran.dg/typebound_call_21.f03 b/gcc/testsuite/gfortran.dg/typebound_call_21.f03 index e31bd6d..810ebfc 100644 --- a/gcc/testsuite/gfortran.dg/typebound_call_21.f03 +++ b/gcc/testsuite/gfortran.dg/typebound_call_21.f03 @@ -33,5 +33,5 @@ end module m print *,x%testfun() end -! { dg-final { scan-tree-dump-times "_vptr->" 0 "original" } } +! { dg-final { scan-tree-dump-times "_vptr->test" 0 "original" } } ! { dg-final { cleanup-tree-dump "original" } }