diff --git a/gcc/fortran/class.c b/gcc/fortran/class.c index 1271300..8a8a54a 100644 --- a/gcc/fortran/class.c +++ b/gcc/fortran/class.c @@ -2013,6 +2013,48 @@ cleanup: } +/* Check if a derived type is finalizable. That is the case if it + (1) has a FINAL subroutine or + (2) has a nonpointer nonallocatable component of finalizable type. + If it is finalizable, return an expression containing the + finalization wrapper. */ + +bool +gfc_is_finalizable (gfc_symbol *derived, gfc_expr **final_expr) +{ + gfc_symbol *vtab; + gfc_component *c; + + /* (1) Check for FINAL subroutines. */ + if (derived->f2k_derived && derived->f2k_derived->finalizers) + goto yes; + + /* (2) Check for components of finalizable type. */ + for (c = derived->components; c; c = c->next) + if (c->ts.type == BT_DERIVED + && !c->attr.pointer && !c->attr.proc_pointer && !c->attr.allocatable + && gfc_is_finalizable (c->ts.u.derived, NULL)) + goto yes; + + return false; + +yes: + /* Make sure vtab is generated. */ + vtab = gfc_find_derived_vtab (derived); + if (final_expr) + { + /* Return finalizer expression. */ + gfc_component *final; + final = vtab->ts.u.derived->components->next->next->next->next->next; + gcc_assert (strcmp (final->name, "_final") == 0); + gcc_assert (final->initializer + && final->initializer->expr_type != EXPR_NULL); + *final_expr = final->initializer; + } + return true; +} + + /* General worker function to find either a type-bound procedure or a type-bound user operator. */ diff --git a/gcc/fortran/config-lang.in b/gcc/fortran/config-lang.in index 43aab7a..6402adb 100644 --- a/gcc/fortran/config-lang.in +++ b/gcc/fortran/config-lang.in @@ -27,7 +27,7 @@ language="fortran" compilers="f951\$(exeext)" -target_libs=target-libgfortran +target_libs="target-libgfortran target-libbacktrace" gtfiles="\$(srcdir)/fortran/f95-lang.c \$(srcdir)/fortran/trans-decl.c \$(srcdir)/fortran/trans-intrinsic.c \$(srcdir)/fortran/trans-io.c \$(srcdir)/fortran/trans-stmt.c \$(srcdir)/fortran/trans-types.c \$(srcdir)/fortran/trans-types.h \$(srcdir)/fortran/trans.h \$(srcdir)/fortran/trans-const.h" diff --git a/gcc/fortran/gfortran.h b/gcc/fortran/gfortran.h index 4942c1c..bf767b2 100644 --- a/gcc/fortran/gfortran.h +++ b/gcc/fortran/gfortran.h @@ -2951,6 +2951,7 @@ void gfc_add_class_array_ref (gfc_expr *); #define gfc_add_hash_component(e) gfc_add_component_ref(e,"_hash") #define gfc_add_size_component(e) gfc_add_component_ref(e,"_size") #define gfc_add_def_init_component(e) gfc_add_component_ref(e,"_def_init") +#define gfc_add_final_component(e) gfc_add_component_ref(e,"_final") bool gfc_is_class_array_ref (gfc_expr *, bool *); bool gfc_is_class_scalar_expr (gfc_expr *); bool gfc_is_class_container_ref (gfc_expr *e); @@ -2967,6 +2968,7 @@ gfc_typebound_proc* gfc_find_typebound_intrinsic_op (gfc_symbol*, gfc_try*, gfc_intrinsic_op, bool, locus*); gfc_symtree* gfc_get_tbp_symtree (gfc_symtree**, const char*); +bool gfc_is_finalizable (gfc_symbol *, gfc_expr **); #define CLASS_DATA(sym) sym->ts.u.derived->components diff --git a/gcc/fortran/module.c b/gcc/fortran/module.c index 89c45b7..cde5739 100644 --- a/gcc/fortran/module.c +++ b/gcc/fortran/module.c @@ -2597,7 +2597,7 @@ mio_component (gfc_component *c, int vtype) c->attr.class_ok = 1; c->attr.access = MIO_NAME (gfc_access) (c->attr.access, access_types); - if (!vtype) + if (!vtype || strcmp (c->name, "_final") == 0) mio_expr (&c->initializer); if (c->attr.proc_pointer) @@ -6157,6 +6157,8 @@ gfc_use_module (gfc_use_list *module) "intrinsic module at %C") != FAILURE) { use_iso_fortran_env_module (); + free_rename (module->rename); + module->rename = NULL; gfc_current_locus = old_locus; module->intrinsic = true; return; @@ -6167,6 +6169,8 @@ gfc_use_module (gfc_use_list *module) "ISO_C_BINDING module at %C") != FAILURE) { import_iso_c_binding_module(); + free_rename (module->rename); + module->rename = NULL; gfc_current_locus = old_locus; module->intrinsic = true; return; @@ -6359,8 +6363,6 @@ gfc_use_modules (void) next = module_list->next; rename_list_remove_duplicate (module_list->rename); gfc_use_module (module_list); - if (module_list->intrinsic) - free_rename (module_list->rename); free (module_list); } gfc_rename_list = NULL; diff --git a/gcc/fortran/resolve.c b/gcc/fortran/resolve.c index 7d434dd..b96e99a 100644 --- a/gcc/fortran/resolve.c +++ b/gcc/fortran/resolve.c @@ -428,7 +428,11 @@ resolve_formal_arglist (gfc_symbol *proc) if (!gfc_pure(sym)) proc->attr.implicit_pure = 0; } - else if (!sym->attr.pointer) + else if ((sym->ts.type != BT_CLASS && sym->attr.pointer) + || (sym->ts.type == BT_CLASS && CLASS_DATA (sym) + && CLASS_DATA (sym)->attr.class_pointer)) + proc->attr.implicit_pure = 0; + else { if (proc->attr.function && sym->attr.intent != INTENT_IN && !sym->value) @@ -11694,10 +11698,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; } @@ -12814,6 +12814,10 @@ resolve_fl_derived0 (gfc_symbol *sym) /* Add derived type to the derived type list. */ add_dt_to_dt_list (sym); + /* Check if the type is finalizable. This is done in order to ensure that the + finalization wrapper is generated early enough. */ + gfc_is_finalizable (sym, NULL); + return SUCCESS; } @@ -13069,6 +13073,9 @@ resolve_symbol (gfc_symbol *sym) if (sym->attr.artificial) return; + if (sym->attr.artificial) + return; + if (sym->attr.flavor == FL_UNKNOWN || (sym->attr.flavor == FL_PROCEDURE && !sym->attr.intrinsic && !sym->attr.generic && !sym->attr.external diff --git a/gcc/fortran/trans-array.c b/gcc/fortran/trans-array.c index 24adfde..0689892 100644 --- a/gcc/fortran/trans-array.c +++ b/gcc/fortran/trans-array.c @@ -7589,7 +7589,7 @@ structure_alloc_comps (gfc_symbol * der_type, tree decl, CLASS_DATA (c)->attr.codimension); else { - tmp = gfc_deallocate_scalar_with_status (comp, NULL, true, NULL, + tmp = gfc_deallocate_scalar_with_status (comp, NULL_TREE, true, NULL, CLASS_DATA (c)->ts); gfc_add_expr_to_block (&tmpblock, tmp); called_dealloc_with_status = true; diff --git a/gcc/fortran/trans-decl.c b/gcc/fortran/trans-decl.c index 3bee178..6d4599e 100644 --- a/gcc/fortran/trans-decl.c +++ b/gcc/fortran/trans-decl.c @@ -3430,7 +3430,65 @@ 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_symbol *vtab = gfc_find_derived_vtab (f->sym->ts.u.derived); + gfc_expr *final_expr = NULL; + + if (vtab) + { + gfc_component *final; + + final = vtab->ts.u.derived->components->next->next->next->next->next; + gcc_assert (strcmp (final->name, "_final") == 0); + + if (final->initializer && final->initializer->expr_type != EXPR_NULL) + final_expr = final->initializer; + } + + if (final_expr) + { + gfc_code *code; + tree elem_size; + + f->sym->attr.referenced = 1; + code = gfc_get_code (); + if (f->sym->ts.type == BT_DERIVED) + code->resolved_sym = final_expr->symtree->n.sym; + else /* FIXME: This shouldn't be reachable for INTENT(OUT), should it? */ + code->resolved_sym = gfc_get_proc_ptr_comp (final_expr)->ts.interface; + + elem_size = gfc_typenode_for_spec (&f->sym->ts); + elem_size = TYPE_SIZE_UNIT (elem_size); + gcc_assert (TREE_INT_CST_HIGH (elem_size) == 0); + + code->ext.actual = gfc_get_actual_arglist (); + code->ext.actual->expr = gfc_lval_expr_from_sym (f->sym); + code->ext.actual->next = gfc_get_actual_arglist (); + code->ext.actual->next->expr + = gfc_get_int_expr (gfc_index_integer_kind, NULL, + TREE_INT_CST_LOW (elem_size)); + code->ext.actual->next->next = gfc_get_actual_arglist (); + code->ext.actual->next->next->expr + = gfc_get_logical_expr (4, NULL, true); + code->expr1 = gfc_copy_expr (final_expr); + code->op = EXEC_CALL; + tmp = gfc_trans_call (code, true, NULL, NULL, false); + + 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); + gfc_free_statements (code); + + 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, @@ -3452,25 +3510,68 @@ 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) - { - present = gfc_conv_expr_present (f->sym); + gfc_expr *final_expr = NULL; + gfc_expr *vptr_size; + gfc_code *code; + gfc_symbol *vtab; + gfc_component *final; + + /* Make sure the vtab is available. */ + 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; + code = gfc_get_code (); + code->resolved_sym = gfc_get_proc_ptr_comp (final_expr)->ts.interface; + code->ext.actual = gfc_get_actual_arglist (); + code->ext.actual->expr = gfc_lval_expr_from_sym (f->sym); + code->ext.actual->next = gfc_get_actual_arglist (); + code->ext.actual->next->expr = vptr_size; + code->ext.actual->next->next = gfc_get_actual_arglist (); + code->ext.actual->next->next->expr = gfc_get_logical_expr (4, NULL, + true); + code->expr1 = gfc_copy_expr (final_expr); + code->op = EXEC_CALL; + tmp = gfc_trans_call (code, true, NULL, NULL, false); + + /* We don't need add a run-time check when we know that a + finalization wrapper exists. */ + vtab = gfc_find_derived_vtab (f->sym->ts.u.derived); + gcc_assert (vtab); + final = vtab->ts.u.derived->components->next->next->next->next->next; + gcc_assert (strcmp (final->name, "_final") == 0); + + if (!final->initializer || final->initializer->expr_type == EXPR_NULL) + { + 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)); + + 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); } @@ -3780,9 +3881,10 @@ gfc_trans_deferred_vars (gfc_symbol * proc_sym, gfc_wrapped_block * block) NULL_TREE, true, NULL, true); else - tmp = gfc_deallocate_scalar_with_status (se.expr, NULL, - true, NULL, - sym->ts); + tmp = gfc_deallocate_scalar_with_status (se.expr, NULL_TREE, + true, + gfc_lval_expr_from_sym (sym), + sym->ts); } if (sym->ts.type == BT_CLASS) { diff --git a/gcc/fortran/trans-expr.c b/gcc/fortran/trans-expr.c index d6410d3..42f6e0c 100644 --- a/gcc/fortran/trans-expr.c +++ b/gcc/fortran/trans-expr.c @@ -95,6 +95,7 @@ conv_scalar_to_descriptor (gfc_se *se, tree scalar, symbol_attribute attr) #define VTABLE_EXTENDS_FIELD 2 #define VTABLE_DEF_INIT_FIELD 3 #define VTABLE_COPY_FIELD 4 +#define VTABLE_FINAL_FIELD 5 tree @@ -180,6 +181,13 @@ gfc_vtable_copy_get (tree decl) } +tree +gfc_vtable_final_get (tree decl) +{ + return gfc_vtable_field_get (decl, VTABLE_FINAL_FIELD); +} + + #undef CLASS_DATA_FIELD #undef CLASS_VPTR_FIELD #undef VTABLE_HASH_FIELD @@ -187,6 +195,7 @@ gfc_vtable_copy_get (tree decl) #undef VTABLE_EXTENDS_FIELD #undef VTABLE_DEF_INIT_FIELD #undef VTABLE_COPY_FIELD +#undef VTABLE_FINAL_FIELD /* Obtain the vptr of the last class reference in an expression. */ @@ -1510,7 +1519,7 @@ conv_parent_component_references (gfc_se * se, gfc_ref * ref) dt = ref->u.c.sym; c = ref->u.c.component; - /* Return if the component is not in the parent type. */ + /* Return if the component is in the parent type. */ for (cmp = dt->components; cmp; cmp = cmp->next) if (strcmp (c->name, cmp->name) == 0) return; @@ -1714,6 +1723,9 @@ gfc_conv_variable (gfc_se * se, gfc_expr * expr) conv_parent_component_references (se, ref); gfc_conv_component_ref (se, ref); + if (!ref->next && ref->u.c.sym->attr.codimension + && se->want_pointer && se->descriptor_only) + return; break; diff --git a/gcc/fortran/trans-intrinsic.c b/gcc/fortran/trans-intrinsic.c index e9eb307..504a9f3 100644 --- a/gcc/fortran/trans-intrinsic.c +++ b/gcc/fortran/trans-intrinsic.c @@ -7321,7 +7321,7 @@ conv_intrinsic_move_alloc (gfc_code *code) /* Deallocate "to". */ tmp = gfc_deallocate_scalar_with_status (to_se.expr, NULL_TREE, true, - to_expr2, to_expr->ts); + to_expr, to_expr->ts); gfc_add_expr_to_block (&block, tmp); /* Assign (_data) pointers. */ diff --git a/gcc/fortran/trans-stmt.c b/gcc/fortran/trans-stmt.c index 79dc27d..38db662 100644 --- a/gcc/fortran/trans-stmt.c +++ b/gcc/fortran/trans-stmt.c @@ -5190,6 +5190,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.... */ @@ -5349,13 +5350,107 @@ 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; + gfc_code *code; + + if (al->expr->ts.type == BT_CLASS) + { + 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_symbol *vtab = gfc_find_derived_vtab (al->expr->ts.u.derived); + if (vtab) + { + gfc_component *final; + final = vtab->ts.u.derived->components; + final = final->next->next->next->next->next; + gcc_assert (strcmp (final->name, "_final") == 0); + + if (final->initializer + && final->initializer->expr_type != EXPR_NULL) + { + tree size; + + final_expr = final->initializer; + + size = gfc_typenode_for_spec (&al->expr->ts); + size = TYPE_SIZE_UNIT (size); + gcc_assert (TREE_INT_CST_HIGH (size) == 0); + elem_size = gfc_get_int_expr (gfc_index_integer_kind, + NULL, + TREE_INT_CST_LOW (size)); + } + } + } + + 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) + { + tree cond2; + gfc_se se2; + + 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); + } + + code = gfc_get_code (); + if (al->expr->ts.type == BT_DERIVED) + code->resolved_sym = final_expr->symtree->n.sym; + else /* FIXME: Is this reachable? */ + code->resolved_sym = gfc_get_proc_ptr_comp (final_expr)->ts.interface; + + code->ext.actual = gfc_get_actual_arglist (); + code->ext.actual->expr = gfc_copy_expr (expr); + code->ext.actual->next = gfc_get_actual_arglist (); + code->ext.actual->next->expr = elem_size; + code->ext.actual->next->next = gfc_get_actual_arglist (); + code->ext.actual->next->next->expr = gfc_get_logical_expr (4, NULL, + true); + code->expr1 = gfc_copy_expr (final_expr); + code->op = EXEC_CALL; + tmp = gfc_trans_call (code, true, NULL, NULL, false); + + tmp = fold_build3_loc (input_location, COND_EXPR, void_type_node, + cond, tmp, + build_empty_stmt (input_location)); + gfc_free_statements (code); + 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; @@ -5380,7 +5475,7 @@ gfc_trans_deallocate (gfc_code *code) else { tmp = gfc_deallocate_scalar_with_status (se.expr, pstat, false, - expr, expr->ts); + al->expr, al->expr->ts); gfc_add_expr_to_block (&se.pre, tmp); /* Set to zero after deallocation. */ diff --git a/gcc/fortran/trans-types.c b/gcc/fortran/trans-types.c index 35a39c5..caf9eb6 100644 --- a/gcc/fortran/trans-types.c +++ b/gcc/fortran/trans-types.c @@ -2654,7 +2654,7 @@ create_fn_spec (gfc_symbol *sym, tree fntype) { gfc_symbol *result = sym->result ? sym->result : sym; - if (result->attr.pointer || sym->attr.proc_pointer) + if (result->attr.pointer || result->attr.proc_pointer) spec[spec_len++] = '.'; else spec[spec_len++] = 'w'; diff --git a/gcc/fortran/trans.c b/gcc/fortran/trans.c index 6365213..0b0752a 100644 --- a/gcc/fortran/trans.c +++ b/gcc/fortran/trans.c @@ -1077,21 +1077,96 @@ 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; + gfc_code *code; + +/* 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); + 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_symbol *vtab = gfc_find_derived_vtab (ts.u.derived); + if (vtab) + { + gfc_component *final; + final = vtab->ts.u.derived->components->next->next->next->next->next; + gcc_assert (strcmp (final->name, "_final") == 0); + + if (final->initializer && final->initializer->expr_type != EXPR_NULL) + { + tree size; + + final_expr = final->initializer; + + size = gfc_typenode_for_spec (&ts); + size = TYPE_SIZE_UNIT (size); + gcc_assert (TREE_INT_CST_HIGH (size) == 0); + elem_size = gfc_get_int_expr (gfc_index_integer_kind, NULL, + TREE_INT_CST_LOW (size)); + } + } + } + + if (final_expr) + { + gcc_assert (expr); + gcc_assert (final_expr->expr_type == EXPR_VARIABLE); + + code = gfc_get_code (); + if (ts.type == BT_DERIVED) + code->resolved_sym = final_expr->symtree->n.sym; + else /* FIXME: IS this properly reachable and makes sense? and initialized above? */ + code->resolved_sym = gfc_get_proc_ptr_comp (final_expr)->ts.interface; + + code->ext.actual = gfc_get_actual_arglist (); + code->ext.actual->expr = gfc_copy_expr (expr); + code->ext.actual->next = gfc_get_actual_arglist (); + code->ext.actual->next->expr = elem_size; + code->ext.actual->next->next = gfc_get_actual_arglist (); + code->ext.actual->next->next->expr = gfc_get_logical_expr (4, NULL, + true); + code->expr1 = gfc_copy_expr (final_expr); + code->op = EXEC_CALL; + tmp = gfc_trans_call (code, true, NULL, NULL, false); + + if (ts.type == BT_CLASS) + { + 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)); + + tmp = fold_build3_loc (input_location, COND_EXPR, void_type_node, + cond, tmp, build_empty_stmt (input_location)); + } + + gfc_free_statements (code); 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 954dcd3..1779575 100644 --- a/gcc/fortran/trans.h +++ b/gcc/fortran/trans.h @@ -348,6 +348,7 @@ tree gfc_vtable_size_get (tree); tree gfc_vtable_extends_get (tree); tree gfc_vtable_def_init_get (tree); tree gfc_vtable_copy_get (tree); +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);