diff --git a/gcc/fortran/class.c b/gcc/fortran/class.c index 61d65e7..bc9818e 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); @@ -995,21 +995,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=. */ @@ -1023,25 +1014,52 @@ finalization_scalarizer (gfc_symbol *idx, gfc_symbol *array, gfc_symbol *ptr, /* Insert code of the following form: - if (stride == STORAGE_SIZE (array)/NUMERIC_STORAGE_SIZE - || 0 == STORAGE_SIZE (array)) then - call final_rank3 (array) - else - block - type(t) :: tmp(shape (array)) - - do i = 0, size (array)-1 - addr = transfer (c_loc (array), addr) + i * stride - call c_f_pointer (transfer (addr, cptr), ptr) - - addr = transfer (c_loc (tmp), addr) - + i * STORAGE_SIZE (array)/NUMERIC_STORAGE_SIZE - call c_f_pointer (transfer (addr, cptr), ptr2) - ptr2 = ptr + block + integer(c_intprt_t) :: strides(max (rank (array), 1)), + sizes(max (rank (array), 1)) + logical :: is_contiguous + integer(c_intptr_t) :: i + + is_contiguous = .true. + if (rank == 0) then + sizes(1) = 1 + strides(1) = 1 + else + do i = 1, rank (array) + sizes(i) = size (array, i) + strides (i) = _F.stride (array, i) ! GFC_PREFIX("stride") + if (i > 1 && strides(i) /= sizes(i-1)) is_contiguous = .false. end do - call final_rank3 (tmp) - end block - end if */ + if (strides(1) /= 1) is_contiguous = .false. + end if + + if ((stride == STORAGE_SIZE (array)/NUMERIC_STORAGE_SIZE + && (is_contiguous || !final_rank3->attr.contiguous)) + || 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 = mod(i,sizes(1))*strides(1) + do j = 2, rank(array) + offset = offset * mod( i/sizes(j-1), sizes(j)) + end do + offset = offset * 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, @@ -1051,7 +1069,7 @@ finalizer_insert_packed_call (gfc_code *block, gfc_finalizer *fini, gfc_namespace *sub_ns) { gfc_symbol *tmp_array, *ptr2; - gfc_expr *size_expr; + gfc_expr *size_expr, *offset, *offset2; gfc_namespace *ns; gfc_iterator *iter; int i; @@ -1168,7 +1186,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,14 +1234,29 @@ finalizer_insert_packed_call (gfc_code *block, gfc_finalizer *fini, block->block = gfc_get_code (); block->block->op = EXEC_DO; + /* Offset calculation: idx * stride (in bytes). */ + offset = gfc_get_expr (); + offset = block->ext.actual->expr; + offset->expr_type = EXPR_OP; + offset->value.op.op = INTRINSIC_TIMES; + offset->value.op.op1 = gfc_lval_expr_from_sym (idx); + offset->value.op.op2 = gfc_lval_expr_from_sym (stride); + offset->ts = stride->ts; + + /* Offset calculation: 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 = stride->ts; + /* 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), + block->block->next = finalization_scalarizer (array, ptr, offset, sub_ns); + block->block->next->next = finalization_scalarizer (tmp_array, ptr2, offset2, sub_ns); /* ptr2 = ptr. */ block->block->next->next->next = XCNEW (gfc_code); @@ -1264,12 +1296,9 @@ finalizer_insert_packed_call (gfc_code *block, gfc_finalizer *fini, /* 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), + + offset, c_ptr), ptr). */ + block->block->next = finalization_scalarizer (array, ptr, offset, sub_ns); + block->block->next->next = finalization_scalarizer (tmp_array, ptr2, offset2, sub_ns); /* ptr = ptr2. */ block->block->next->next->next = XCNEW (gfc_code); @@ -1438,7 +1467,7 @@ generate_finalization_wrapper (gfc_symbol *derived, gfc_namespace *ns, /* 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; @@ -1631,6 +1660,7 @@ generate_finalization_wrapper (gfc_symbol *derived, gfc_namespace *ns, if (fini_elem) { gfc_iterator *iter; + gfc_expr *offset; /* CASE DEFAULT. */ if (block) @@ -1661,13 +1691,20 @@ generate_finalization_wrapper (gfc_symbol *derived, gfc_namespace *ns, block->block = gfc_get_code (); block->block->op = EXEC_DO; + /* Offset calculation: idx * stride (in bytes). */ + offset = gfc_get_expr (); + offset = block->ext.actual->expr; + offset->expr_type = EXPR_OP; + offset->value.op.op = INTRINSIC_TIMES; + offset->value.op.op1 = gfc_lval_expr_from_sym (idx); + offset->value.op.op2 = gfc_lval_expr_from_sym (stride); + offset->ts = stride->ts; + /* Create code for CALL C_F_POINTER (TRANSFER (TRANSFER (C_LOC (array, cptr), c_intptr) - + idx * stride, c_ptr), ptr). */ + + offset, c_ptr), ptr). */ block->block->next - = finalization_scalarizer (idx, array, ptr, - gfc_lval_expr_from_sym (stride), - sub_ns); + = finalization_scalarizer (array, ptr, offset, sub_ns); block = block->block->next; /* CALL final_elemental (array). */ @@ -1690,6 +1727,7 @@ generate_finalization_wrapper (gfc_symbol *derived, gfc_namespace *ns, gfc_symbol *stat; gfc_code *block = NULL; gfc_iterator *iter; + gfc_expr *offset; if (!idx) { @@ -1736,13 +1774,19 @@ generate_finalization_wrapper (gfc_symbol *derived, gfc_namespace *ns, last_code->block = gfc_get_code (); last_code->block->op = EXEC_DO; + /* Offset calculation: idx * stride (in bytes). */ + offset = gfc_get_expr (); + offset->expr_type = EXPR_OP; + offset->value.op.op = INTRINSIC_TIMES; + offset->value.op.op1 = gfc_lval_expr_from_sym (idx); + offset->value.op.op2 = gfc_lval_expr_from_sym (stride); + offset->ts = stride->ts; + /* 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); + = finalization_scalarizer (array, ptr, offset, sub_ns); block = last_code->block->next; for (comp = derived->components; comp; comp = comp->next) @@ -2024,9 +2068,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 +2076,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 +2351,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..2834835 100644 --- a/gcc/fortran/intrinsic.c +++ b/gcc/fortran/intrinsic.c @@ -2640,6 +2640,13 @@ 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); + 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; } @@ -13640,6 +13636,32 @@ resolve_symbol (gfc_symbol *sym) return; } + if (sym->ts.type == BT_LOGICAL + && ((sym->attr.function && sym->attr.is_bind_c && sym->result == sym) + || ((sym->attr.dummy || sym->attr.result) && sym->ns->proc_name + && sym->ns->proc_name->attr.is_bind_c))) + { + int i; + for (i = 0; gfc_logical_kinds[i].kind; i++) + if (gfc_logical_kinds[i].kind == sym->ts.kind) + break; + if (!gfc_logical_kinds[i].c_bool && sym->attr.dummy + && gfc_notify_std (GFC_STD_GNU, "LOGICAL dummy argument '%s' at %L " + "with non-C_Bool kind in BIND(C) procedure '%s'", + sym->name, &sym->declared_at, + sym->ns->proc_name->name) == FAILURE) + return; + else if (!gfc_logical_kinds[i].c_bool + && gfc_notify_std (GFC_STD_GNU, "LOGICAL result variable '%s' at" + " %L with non-C_Bool kind in BIND(C) " + "procedure '%s'", sym->name, + &sym->declared_at, + sym->attr.function ? sym->name + : sym->ns->proc_name->name) + == FAILURE) + return; + } + switch (sym->attr.flavor) { case FL_VARIABLE: 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..fac0b20 100644 --- a/gcc/fortran/trans-intrinsic.c +++ b/gcc/fortran/trans-intrinsic.c @@ -1657,6 +1657,33 @@ 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; + + 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); + se->expr = gfc_conv_descriptor_stride_get (desc, argse.expr); +} + + +static void gfc_conv_intrinsic_abs (gfc_se * se, gfc_expr * expr) { tree arg, cabs; @@ -6806,7 +6833,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-types.c b/gcc/fortran/trans-types.c index 8394bf9..73ed5aa 100644 --- a/gcc/fortran/trans-types.c +++ b/gcc/fortran/trans-types.c @@ -2128,6 +2128,25 @@ gfc_sym_type (gfc_symbol * sym) && sym->ns->proc_name && sym->ns->proc_name->attr.is_bind_c))) type = gfc_character1_type_node; + else if (sym->ts.type == BT_LOGICAL + && ((sym->attr.function && sym->attr.is_bind_c) + || ((sym->attr.dummy || sym->attr.result) && sym->ns->proc_name + && sym->ns->proc_name->attr.is_bind_c))) + { + /* For LOGICAL dummy arguments or result value of a C binding procedure, + which do not match _Bool (C_Bool kind), a normal integer variable + is used instead of a BOOLEAN_TYPE with a TYPE_PRECISION of 1. The + reason is that on the C side, a normal integer such as "int" is used, + implying that any integer value could be used - not only 0 and 1. */ + int i; + for (i = 0; gfc_logical_kinds[i].kind; i++) + if (gfc_logical_kinds[i].kind == sym->ts.kind) + break; + if (!gfc_logical_kinds[i].c_bool) + type = gfc_get_int_type (sym->ts.kind); + else + type = gfc_typenode_for_spec (&sym->ts); + } else type = gfc_typenode_for_spec (&sym->ts); diff --git a/gcc/fortran/trans.c b/gcc/fortran/trans.c index 70f06ff..de90705 100644 --- a/gcc/fortran/trans.c +++ b/gcc/fortran/trans.c @@ -1023,6 +1023,118 @@ 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; + + /* FIXME: scalars. */ + array = null_pointer_node; + + 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 (&se, var); + gcc_assert (se.pre.head == NULL_TREE && se.post.head == NULL_TREE); + 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 (&se, array_expr); + gcc_assert (se.pre.head == NULL_TREE && se.post.head == NULL_TREE); + 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_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 +1189,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" } }