From patchwork Mon Jun 3 10:22:35 2013 Content-Type: text/plain; charset="utf-8" MIME-Version: 1.0 Content-Transfer-Encoding: 7bit X-Patchwork-Submitter: Tobias Burnus X-Patchwork-Id: 248224 Return-Path: X-Original-To: incoming@patchwork.ozlabs.org Delivered-To: patchwork-incoming@bilbo.ozlabs.org Received: from sourceware.org (server1.sourceware.org [209.132.180.131]) (using TLSv1 with cipher DHE-RSA-AES256-SHA (256/256 bits)) (Client CN "localhost", Issuer "www.qmailtoaster.com" (not verified)) by ozlabs.org (Postfix) with ESMTPS id B174A2C00A8 for ; Mon, 3 Jun 2013 20:22:59 +1000 (EST) DomainKey-Signature: a=rsa-sha1; c=nofws; d=gcc.gnu.org; h=list-id :list-unsubscribe:list-archive:list-post:list-help:sender :message-id:date:from:mime-version:to:subject:references :in-reply-to:content-type; q=dns; s=default; b=TFOEeE1x5IDV9OTq5 UBjX/Rio3AoQUkQzNkmZPKA7MubUajEdbrNl0wKBGhPO987ZtomYY/59copTriqB Y3bIfRBqe5OLE/twNc+0Th1LnuCifYwogrCXu7Ai3zXQpT2QCf3aK01VzVaCB+n4 swQIrqP9mrUhgYsSm485rNqZ1Y= DKIM-Signature: v=1; a=rsa-sha1; c=relaxed; d=gcc.gnu.org; h=list-id :list-unsubscribe:list-archive:list-post:list-help:sender :message-id:date:from:mime-version:to:subject:references :in-reply-to:content-type; s=default; bh=jDozFeT28L1t/tP3zTawONy FV6I=; b=l+yVr4lc6pg25Z+hSeh+5YN+HISU3Ba6//LKWJU8IcIE4sgvTXCjapf IVrqwFeztItqvuSFBKLkKS8WjpSLmCPCpwHt2TFGcNXoPewDp6Rn9gg8hWmjDfDV MeDudV7tfq17SoaSY72zVN68arDpODCkjqDmuGCkL1PVVUcKh/Eg= Received: (qmail 10387 invoked by alias); 3 Jun 2013 10:22:43 -0000 Mailing-List: contact gcc-patches-help@gcc.gnu.org; run by ezmlm Precedence: bulk List-Id: List-Unsubscribe: List-Archive: List-Post: List-Help: Sender: gcc-patches-owner@gcc.gnu.org Delivered-To: mailing list gcc-patches@gcc.gnu.org Received: (qmail 10328 invoked by uid 89); 3 Jun 2013 10:22:43 -0000 X-Spam-SWARE-Status: No, score=-2.1 required=5.0 tests=AWL, BAYES_05, KHOP_THREADED, RCVD_IN_DNSWL_NONE, TW_FN, TW_TM, TW_VP autolearn=ham version=3.3.1 X-Spam-User: qpsmtpd, 2 recipients Received: from mx02.qsc.de (HELO mx02.qsc.de) (213.148.130.14) by sourceware.org (qpsmtpd/0.84/v0.84-167-ge50287c) with ESMTP; Mon, 03 Jun 2013 10:22:40 +0000 Received: from archimedes.net-b.de (port-92-195-106-97.dynamic.qsc.de [92.195.106.97]) by mx02.qsc.de (Postfix) with ESMTP id CE56F23D1F; Mon, 3 Jun 2013 12:22:35 +0200 (CEST) Message-ID: <51AC6E6B.3020809@net-b.de> Date: Mon, 03 Jun 2013 12:22:35 +0200 From: Tobias Burnus User-Agent: Mozilla/5.0 (X11; Linux x86_64; rv:17.0) Gecko/20130510 Thunderbird/17.0.6 MIME-Version: 1.0 To: gcc patches , gfortran Subject: *ping* - Re: [Patch, Fortran] Enable FINALization/poly dealloc for allocatables References: <51A5BC22.3010600@net-b.de> <51A72907.3030107@net-b.de> <51A88346.4000509@net-b.de> <51A8D16B.3050701@net-b.de> In-Reply-To: <51A8D16B.3050701@net-b.de> X-Virus-Found: No * PING * Attached is just a re-diff. OK for the trunk? Tobias PS: This patch blocks the patch for finalization of nonallocatable intent(out) at http://gcc.gnu.org/ml/fortran/2013-05/msg00135.html (with additional test case at http://gcc.gnu.org/ml/fortran/2013-05/msg00141.html). It additionally blocks me from working on follow-up patches. On May 31, 2013, Tobias Burnus wrote: > And another one: I just realized that the following dead code can be > removed (twice): > + if (TREE_CODE (array) == ADDR_EXPR > + && POINTER_TYPE_P (TREE_TYPE (TREE_OPERAND (array, 0)))) > + tmp = TREE_OPERAND (array, 0); > As "tmp" is not used. That's part of gfc_build_final_call,thus, I > cannot easily do it as follow up patch. [...] >>> On Wed, May 29, 2013, Tobias Burnus wrote: >>>> this patch enables finalization (and polymorphic deallocation) for >>>> allocatables for: end of scope, DEALLOCATE and intent(out). >>>> >>>> As a side effect, an allocatable is no longer deallocated at the >>>> end of the main program. (Variables declared in the main program >>>> have automatically SAVE attribute; before finalization, it made no >>>> difference but with finalization it is detectable. And only >>>> finalizing nonfinalizable allocatables seems to be too much effort >>>> for too little gain.) >>> ... >>>> Build and regtested on x86-64-gnu-linux. >>>> OK for the trunk? >>>> >>>> Tobias >>>> >>>> PS: Fortran requires additional cases where finalization has to >>>> happen; those will be added in follow-up patches. 2013-06-03 Tobias Burnus PR fortran/37336 * trans.h (gfc_build_final_call): Remove prototype. (gfc_add_finalizer_call): Add prototype. * trans-array.c (gfc_trans_dealloc_allocated): Support finalization. (structure_alloc_comps): Update caller. (gfc_trans_deferred_array): Call finalizer. * trans-array.h (gfc_trans_dealloc_allocated): Update prototype. * trans-decl.c (gfc_trans_deferred_vars): Don't deallocate/finalize variables of the main program. * trans-expr.c (gfc_conv_procedure_call): Support finalization. * trans-openmp.c (gfc_omp_clause_dtor, gfc_trans_omp_array_reduction): Update calls. * trans-stmt.c (gfc_trans_deallocate): Avoid double deallocation of alloc components. * trans.c (gfc_add_finalizer_call): New function. (gfc_deallocate_with_status, gfc_deallocate_scalar_with_status): Call it (gfc_build_final_call): Fix handling of scalar coarrays, move up in the file and make static. 2013-06-03 Tobias Burnus PR fortran/37336 * gfortran.dg/finalize_12.f90: New. * gfortran.dg/alloc_comp_basics_1.f90: Add BLOCK for end of scope finalization. * gfortran.dg/alloc_comp_constructor_1.f90: Ditto. * gfortran.dg/allocatable_scalar_9.f90: Ditto. * gfortran.dg/auto_dealloc_2.f90: Ditto. * gfortran.dg/class_19.f03: Ditto. * gfortran.dg/coarray_lib_alloc_1.f90: Ditto. * gfortran.dg/coarray_lib_alloc_2.f90: Ditto. * gfortran.dg/extends_14.f03: Ditto. * gfortran.dg/move_alloc_4.f90: Ditto. * gfortran.dg/typebound_proc_27.f03: Ditto. diff --git a/gcc/fortran/trans-array.c b/gcc/fortran/trans-array.c index 8556278..89f26d7 100644 --- a/gcc/fortran/trans-array.c +++ b/gcc/fortran/trans-array.c @@ -7247,7 +7247,7 @@ gfc_conv_array_parameter (gfc_se * se, gfc_expr * expr, bool g77, /* Generate code to deallocate an array, if it is allocated. */ tree -gfc_trans_dealloc_allocated (tree descriptor, bool coarray) +gfc_trans_dealloc_allocated (tree descriptor, bool coarray, gfc_expr *expr) { tree tmp; tree var; @@ -7263,7 +7263,7 @@ gfc_trans_dealloc_allocated (tree descriptor, bool coarray) are already deallocated are ignored. */ tmp = gfc_deallocate_with_status (coarray ? descriptor : var, NULL_TREE, NULL_TREE, NULL_TREE, NULL_TREE, true, - NULL, coarray); + expr, coarray); gfc_add_expr_to_block (&block, tmp); /* Zero the data pointer. */ @@ -7552,7 +7552,7 @@ structure_alloc_comps (gfc_symbol * der_type, tree decl, { comp = fold_build3_loc (input_location, COMPONENT_REF, ctype, decl, cdecl, NULL_TREE); - tmp = gfc_trans_dealloc_allocated (comp, c->attr.codimension); + tmp = gfc_trans_dealloc_allocated (comp, c->attr.codimension, NULL); gfc_add_expr_to_block (&tmpblock, tmp); } else if (c->attr.allocatable) @@ -7584,7 +7584,7 @@ structure_alloc_comps (gfc_symbol * der_type, tree decl, if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (comp))) tmp = gfc_trans_dealloc_allocated (comp, - CLASS_DATA (c)->attr.codimension); + CLASS_DATA (c)->attr.codimension, NULL); else { tmp = gfc_deallocate_scalar_with_status (comp, NULL_TREE, true, NULL, @@ -8296,7 +8296,7 @@ gfc_trans_deferred_array (gfc_symbol * sym, gfc_wrapped_block * block) stmtblock_t cleanup; locus loc; int rank; - bool sym_has_alloc_comp; + bool sym_has_alloc_comp, has_finalizer; sym_has_alloc_comp = (sym->ts.type == BT_DERIVED || sym->ts.type == BT_CLASS) @@ -8383,8 +8383,12 @@ gfc_trans_deferred_array (gfc_symbol * sym, gfc_wrapped_block * block) /* Allocatable arrays need to be freed when they go out of scope. The allocatable components of pointers must not be touched. */ - if (sym_has_alloc_comp && !(sym->attr.function || sym->attr.result) - && !sym->attr.pointer && !sym->attr.save) + has_finalizer = sym->ts.type == BT_CLASS || sym->ts.type == BT_DERIVED + ? gfc_is_finalizable (sym->ts.u.derived, NULL) : false; + if ((!sym->attr.allocatable || !has_finalizer) + && sym_has_alloc_comp && !(sym->attr.function || sym->attr.result) + && !sym->attr.pointer && !sym->attr.save + && !sym->ns->proc_name->attr.is_main_program) { int rank; rank = sym->as ? sym->as->rank : 0; @@ -8393,10 +8397,13 @@ gfc_trans_deferred_array (gfc_symbol * sym, gfc_wrapped_block * block) } if (sym->attr.allocatable && (sym->attr.dimension || sym->attr.codimension) - && !sym->attr.save && !sym->attr.result) + && !sym->attr.save && !sym->attr.result + && !sym->ns->proc_name->attr.is_main_program) { tmp = gfc_trans_dealloc_allocated (sym->backend_decl, - sym->attr.codimension); + sym->attr.codimension, + has_finalizer + ? gfc_lval_expr_from_sym (sym) : NULL); gfc_add_expr_to_block (&cleanup, tmp); } diff --git a/gcc/fortran/trans-array.h b/gcc/fortran/trans-array.h index d00e156..8d9e461 100644 --- a/gcc/fortran/trans-array.h +++ b/gcc/fortran/trans-array.h @@ -42,7 +42,7 @@ void gfc_trans_dummy_array_bias (gfc_symbol *, tree, gfc_wrapped_block *); /* Generate entry and exit code for g77 calling convention arrays. */ void gfc_trans_g77_array (gfc_symbol *, gfc_wrapped_block *); /* Generate code to deallocate an array, if it is allocated. */ -tree gfc_trans_dealloc_allocated (tree, bool); +tree gfc_trans_dealloc_allocated (tree, bool, gfc_expr *); tree gfc_duplicate_allocatable (tree dest, tree src, tree type, int rank); diff --git a/gcc/fortran/trans-decl.c b/gcc/fortran/trans-decl.c index 100ec18..7521dee 100644 --- a/gcc/fortran/trans-decl.c +++ b/gcc/fortran/trans-decl.c @@ -3872,7 +3892,8 @@ gfc_trans_deferred_vars (gfc_symbol * proc_sym, gfc_wrapped_block * block) /* Deallocate when leaving the scope. Nullifying is not needed. */ - if (!sym->attr.result && !sym->attr.dummy) + if (!sym->attr.result && !sym->attr.dummy + && !sym->ns->proc_name->attr.is_main_program) { if (sym->ts.type == BT_CLASS && CLASS_DATA (sym)->attr.codimension) diff --git a/gcc/fortran/trans-expr.c b/gcc/fortran/trans-expr.c index 07b0fa6..9d07345 100644 --- a/gcc/fortran/trans-expr.c +++ b/gcc/fortran/trans-expr.c @@ -4274,10 +4274,8 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym, if (e->ts.type == BT_CLASS) ptr = gfc_class_data_get (ptr); - tmp = gfc_deallocate_with_status (ptr, NULL_TREE, - NULL_TREE, NULL_TREE, - NULL_TREE, true, NULL, - false); + tmp = gfc_deallocate_scalar_with_status (ptr, NULL_TREE, + true, e, e->ts); gfc_add_expr_to_block (&block, tmp); tmp = fold_build2_loc (input_location, MODIFY_EXPR, void_type_node, ptr, @@ -4409,8 +4407,8 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym, else tmp = gfc_finish_block (&block); - gfc_add_expr_to_block (&se->pre, tmp); -} + gfc_add_expr_to_block (&se->pre, tmp); + } /* The conversion does not repackage the reference to a class array - _data descriptor. */ @@ -4511,7 +4509,7 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym, { tmp = build_fold_indirect_ref_loc (input_location, parmse.expr); - tmp = gfc_trans_dealloc_allocated (tmp, false); + tmp = gfc_trans_dealloc_allocated (tmp, false, e); if (fsym->attr.optional && e->expr_type == EXPR_VARIABLE && e->symtree->n.sym->attr.optional) diff --git a/gcc/fortran/trans-openmp.c b/gcc/fortran/trans-openmp.c index 882927e..2765561 100644 --- a/gcc/fortran/trans-openmp.c +++ b/gcc/fortran/trans-openmp.c @@ -325,7 +325,7 @@ gfc_omp_clause_dtor (tree clause ATTRIBUTE_UNUSED, tree decl) /* Allocatable arrays in FIRSTPRIVATE/LASTPRIVATE etc. clauses need to be deallocated if they were allocated. */ - return gfc_trans_dealloc_allocated (decl, false); + return gfc_trans_dealloc_allocated (decl, false, NULL); } @@ -707,7 +707,8 @@ gfc_trans_omp_array_reduction (tree c, gfc_symbol *sym, locus where) gfc_start_block (&block); gfc_add_expr_to_block (&block, gfc_trans_assignment (e3, e4, false, true)); - gfc_add_expr_to_block (&block, gfc_trans_dealloc_allocated (decl, false)); + gfc_add_expr_to_block (&block, gfc_trans_dealloc_allocated (decl, false, + NULL)); stmt = gfc_finish_block (&block); } else diff --git a/gcc/fortran/trans-stmt.c b/gcc/fortran/trans-stmt.c index 7759b86..e2d0110 100644 --- a/gcc/fortran/trans-stmt.c +++ b/gcc/fortran/trans-stmt.c @@ -5398,7 +5398,8 @@ gfc_trans_deallocate (gfc_code *code) if (expr->rank || gfc_is_coarray (expr)) { - if (expr->ts.type == BT_DERIVED && expr->ts.u.derived->attr.alloc_comp) + if (expr->ts.type == BT_DERIVED && expr->ts.u.derived->attr.alloc_comp + && !gfc_is_finalizable (expr->ts.u.derived, NULL)) { gfc_ref *ref; gfc_ref *last = NULL; diff --git a/gcc/fortran/trans.c b/gcc/fortran/trans.c index 8211573..a1ea300 100644 --- a/gcc/fortran/trans.c +++ b/gcc/fortran/trans.c @@ -838,6 +838,223 @@ gfc_call_free (tree var) } +/* Build a call to a FINAL procedure, which finalizes "var". */ + +static 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; + symbol_attribute attr; + + 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) + { + se.descriptor_only = 1; + gfc_conv_expr_descriptor (&se, var); + array = se.expr; + } + else + { + gfc_conv_expr (&se, var); + gcc_assert (se.pre.head == NULL_TREE && se.post.head == NULL_TREE); + array = se.expr; + + /* No copy back needed, hence set attr's allocatable/pointer + to zero. */ + gfc_clear_attr (&attr); + gfc_init_se (&se, NULL); + array = gfc_conv_scalar_to_descriptor (&se, array, attr); + 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_init_se (&se, NULL); + se.want_pointer = 1; + if (array_expr->rank) + { + gfc_add_class_array_ref (array_expr); + se.descriptor_only = 1; + gfc_conv_expr_descriptor (&se, array_expr); + array = se.expr; + } + else + { + gfc_add_data_component (array_expr); + 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); + + if (!gfc_is_coarray (array_expr)) + { + /* No copy back needed, hence set attr's allocatable/pointer + to zero. */ + gfc_clear_attr (&attr); + gfc_init_se (&se, NULL); + array = gfc_conv_scalar_to_descriptor (&se, array, attr); + } + gcc_assert (se.post.head == NULL_TREE); + } + gfc_free_expr (array_expr); + } + + if (!POINTER_TYPE_P (TREE_TYPE (array))) + array = gfc_build_addr_expr (NULL, array); + + 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); +} + + +/* Add a call to the finalizer, using the passed *expr. Returns + true when a finalizer call has been inserted. */ + +bool +gfc_add_finalizer_call (stmtblock_t *block, gfc_expr *expr2) +{ + tree tmp; + gfc_ref *ref; + gfc_expr *expr; + gfc_expr *final_expr = NULL; + gfc_expr *elem_size = NULL; + bool has_finalizer = false; + + if (!expr2 || (expr2->ts.type != BT_DERIVED && expr2->ts.type != BT_CLASS)) + return false; + + if (expr2->ts.type == BT_DERIVED) + { + gfc_is_finalizable (expr2->ts.u.derived, &final_expr); + if (!final_expr) + return false; + } + + /* If we have a class array, we need go back to the class + container. */ + expr = gfc_copy_expr (expr2); + + if (expr->ref && expr->ref->next && !expr->ref->next->next + && expr->ref->next->type == REF_ARRAY + && expr->ref->type == REF_COMPONENT + && strcmp (expr->ref->u.c.component->name, "_data") == 0) + { + gfc_free_ref_list (expr->ref); + expr->ref = NULL; + } + else + for (ref = expr->ref; ref; ref = ref->next) + if (ref->next && ref->next->next && !ref->next->next->next + && ref->next->next->type == REF_ARRAY + && ref->next->type == REF_COMPONENT + && strcmp (ref->next->u.c.component->name, "_data") == 0) + { + gfc_free_ref_list (ref->next); + ref->next = NULL; + } + + if (expr->ts.type == BT_CLASS) + { + has_finalizer = gfc_is_finalizable (expr->ts.u.derived, NULL); + + if (!expr2->rank && !expr2->ref && CLASS_DATA (expr2->symtree->n.sym)->as) + expr->rank = CLASS_DATA (expr2->symtree->n.sym)->as->rank; + + 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"); + } + + gcc_assert (final_expr->expr_type == EXPR_VARIABLE); + + tmp = gfc_build_final_call (expr->ts, final_expr, expr, + false, elem_size); + + if (expr->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 (block, tmp); + + return true; +} + /* User-deallocate; we emit the code directly from the front-end, and the logic is the same as the previous library function: @@ -930,6 +1147,7 @@ gfc_deallocate_with_status (tree pointer, tree status, tree errmsg, /* When POINTER is not NULL, we free it. */ gfc_start_block (&non_null); + gfc_add_finalizer_call (&non_null, expr); if (!coarray || gfc_option.coarray != GFC_FCOARRAY_LIB) { tmp = build_call_expr_loc (input_location, @@ -1022,125 +1240,6 @@ 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; - symbol_attribute attr; - - 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); - - attr = gfc_expr_attr (var); - - 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 || attr.dimension - || (attr.codimension && attr.allocatable - && gfc_option.coarray == GFC_FCOARRAY_LIB)) - { - if (var->rank == 0) - se.want_coarray = 1; - 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 - { - 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_init_se (&se, NULL); - se.want_pointer = 1; - if (array_expr->rank || attr.dimension - || (attr.codimension && attr.allocatable - && gfc_option.coarray == GFC_FCOARRAY_LIB)) - { - gfc_add_class_array_ref (array_expr); - if (array_expr->rank == 0) - se.want_coarray = 1; - se.descriptor_only = 1; - gfc_conv_expr_descriptor (&se, array_expr); - array = se.expr; - if (! POINTER_TYPE_P (TREE_TYPE (array))) - array = gfc_build_addr_expr (NULL, array); - } - else - { - gfc_clear_attr (&attr); - gfc_add_data_component (array_expr); - 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/allocatable, - 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. */ @@ -1151,6 +1250,7 @@ gfc_deallocate_scalar_with_status (tree pointer, tree status, bool can_fail, { stmtblock_t null, non_null; tree cond, tmp, error; + bool finalizable; cond = fold_build2_loc (input_location, EQ_EXPR, boolean_type_node, pointer, build_int_cst (TREE_TYPE (pointer), 0)); @@ -1195,20 +1295,13 @@ 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) + finalizable = gfc_add_finalizer_call (&non_null, expr); + if (!finalizable && 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, tmp, 0); gfc_add_expr_to_block (&non_null, tmp); } - else if (ts.type == BT_CLASS - && ts.u.derived->components->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); - gfc_add_expr_to_block (&non_null, tmp); - } tmp = build_call_expr_loc (input_location, builtin_decl_explicit (BUILT_IN_FREE), 1, diff --git a/gcc/fortran/trans.h b/gcc/fortran/trans.h index 0c0fe5d..06cb63d 100644 --- a/gcc/fortran/trans.h +++ b/gcc/fortran/trans.h @@ -352,8 +352,7 @@ 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 *); +bool gfc_add_finalizer_call (stmtblock_t *, 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, diff --git a/gcc/testsuite/gfortran.dg/alloc_comp_basics_1.f90 b/gcc/testsuite/gfortran.dg/alloc_comp_basics_1.f90 index 9b08129..65724fe 100644 --- a/gcc/testsuite/gfortran.dg/alloc_comp_basics_1.f90 +++ b/gcc/testsuite/gfortran.dg/alloc_comp_basics_1.f90 @@ -33,8 +33,10 @@ program alloc integer, allocatable :: a2(:) end type alloc2 - type(alloc2) :: b integer :: i + + BLOCK ! To ensure that the allocatables are freed at the end of the scope + type(alloc2) :: b type(alloc2), allocatable :: c(:) if (allocated(b%a2) .OR. allocated(b%a1)) then @@ -64,7 +66,7 @@ program alloc deallocate(c) ! 7 calls to _gfortran_deallocate (b (3) and c(4) goes aout of scope) - + END BLOCK contains subroutine allocate_alloc2(b) diff --git a/gcc/testsuite/gfortran.dg/alloc_comp_constructor_1.f90 b/gcc/testsuite/gfortran.dg/alloc_comp_constructor_1.f90 index 969e703..8003c05 100644 --- a/gcc/testsuite/gfortran.dg/alloc_comp_constructor_1.f90 +++ b/gcc/testsuite/gfortran.dg/alloc_comp_constructor_1.f90 @@ -19,9 +19,12 @@ Program test_constructor type(thytype), allocatable :: q(:) end type mytype - type (mytype) :: x type (thytype) :: foo = thytype(reshape ([43, 100, 54, 76], [2,2])) integer :: y(0:1, -1:0) = reshape ([42, 99, 55, 77], [2,2]) + + BLOCK ! Add scoping unit as the vars are otherwise implicitly SAVEd + + type (mytype) :: x integer, allocatable :: yy(:,:) type (thytype), allocatable :: bar(:) integer :: i @@ -70,7 +73,7 @@ Program test_constructor ! Check that passing the constructor to a procedure works call check_mytype (mytype(y, [foo, foo])) - + END BLOCK contains subroutine check_mytype(x) diff --git a/gcc/testsuite/gfortran.dg/allocatable_scalar_9.f90 b/gcc/testsuite/gfortran.dg/allocatable_scalar_9.f90 index 3488c0d..fd0b4db 100644 --- a/gcc/testsuite/gfortran.dg/allocatable_scalar_9.f90 +++ b/gcc/testsuite/gfortran.dg/allocatable_scalar_9.f90 @@ -28,10 +28,12 @@ end type t4 end module m use m +block ! Start new scoping unit as otherwise the vars are implicitly SAVEd type(t1) :: na1, a1, aa1(:) type(t2) :: na2, a2, aa2(:) type(t3) :: na3, a3, aa3(:) type(t4) :: na4, a4, aa4(:) + allocatable :: a1, a2, a3, a4, aa1, aa2, aa3,aa4 if(allocated(a1)) call abort() @@ -47,6 +49,7 @@ if(allocated(na1%b1)) call abort() if(allocated(na2%b2)) call abort() if(allocated(na3%b3)) call abort() if(allocated(na4%b4)) call abort() +end block end ! { dg-final { scan-tree-dump-times "__builtin_free" 32 "original" } } diff --git a/gcc/testsuite/gfortran.dg/auto_dealloc_2.f90 b/gcc/testsuite/gfortran.dg/auto_dealloc_2.f90 index d261973..04ee7f2 100644 --- a/gcc/testsuite/gfortran.dg/auto_dealloc_2.f90 +++ b/gcc/testsuite/gfortran.dg/auto_dealloc_2.f90 @@ -11,11 +11,12 @@ type :: t integer, allocatable :: i(:) end type +block ! New block as the main program implies SAVE type(t) :: a call init(a) call init(a) - +end block contains subroutine init(x) diff --git a/gcc/testsuite/gfortran.dg/class_19.f03 b/gcc/testsuite/gfortran.dg/class_19.f03 index 6dcd99c..428015c 100644 --- a/gcc/testsuite/gfortran.dg/class_19.f03 +++ b/gcc/testsuite/gfortran.dg/class_19.f03 @@ -39,5 +39,5 @@ program main end program main -! { dg-final { scan-tree-dump-times "__builtin_free" 15 "original" } } +! { dg-final { scan-tree-dump-times "__builtin_free" 12 "original" } } ! { dg-final { cleanup-tree-dump "original" } } diff --git a/gcc/testsuite/gfortran.dg/coarray_lib_alloc_1.f90 b/gcc/testsuite/gfortran.dg/coarray_lib_alloc_1.f90 index c0d06a4..926d531 100644 --- a/gcc/testsuite/gfortran.dg/coarray_lib_alloc_1.f90 +++ b/gcc/testsuite/gfortran.dg/coarray_lib_alloc_1.f90 @@ -4,6 +4,7 @@ ! Allocate/deallocate with libcaf. ! + subroutine test() integer(4), allocatable :: xx[:], yy(:)[:] integer :: stat character(len=200) :: errmsg diff --git a/gcc/testsuite/gfortran.dg/coarray_lib_alloc_2.f90 b/gcc/testsuite/gfortran.dg/coarray_lib_alloc_2.f90 index 3aaff1e..472e0be 100644 --- a/gcc/testsuite/gfortran.dg/coarray_lib_alloc_2.f90 +++ b/gcc/testsuite/gfortran.dg/coarray_lib_alloc_2.f90 @@ -4,6 +4,7 @@ ! Allocate/deallocate with libcaf. ! + subroutine test() type t end type t class(t), allocatable :: xx[:], yy(:)[:] diff --git a/gcc/testsuite/gfortran.dg/extends_14.f03 b/gcc/testsuite/gfortran.dg/extends_14.f03 index 876e8c7..15e38ff 100644 --- a/gcc/testsuite/gfortran.dg/extends_14.f03 +++ b/gcc/testsuite/gfortran.dg/extends_14.f03 @@ -16,12 +16,13 @@ program evolve_aflow type, extends(state_t) :: astate_t end type + block ! New scoping unit as "a"/"b" are otherwise implicitly SAVEd type(astate_t) :: a,b allocate(a%U(1000)) a = b - + end block end program ! { dg-final { scan-tree-dump-times "__builtin_free" 3 "original" } } diff --git a/gcc/testsuite/gfortran.dg/move_alloc_4.f90 b/gcc/testsuite/gfortran.dg/move_alloc_4.f90 index 4dc493f..b23ef70 100644 --- a/gcc/testsuite/gfortran.dg/move_alloc_4.f90 +++ b/gcc/testsuite/gfortran.dg/move_alloc_4.f90 @@ -10,13 +10,14 @@ program testmv3 integer, allocatable :: ia(:), ja(:) end type + block ! For auto-dealloc, as PROGRAM implies SAVE type(bar), allocatable :: sm,sm2 allocate(sm) allocate(sm%ia(10),sm%ja(10)) call move_alloc(sm2,sm) - + end block end program testmv3 ! { dg-final { scan-tree-dump-times "__builtin_free" 9 "original" } } diff --git a/gcc/testsuite/gfortran.dg/typebound_proc_27.f03 b/gcc/testsuite/gfortran.dg/typebound_proc_27.f03 index 28c44df..ce845a0 100644 --- a/gcc/testsuite/gfortran.dg/typebound_proc_27.f03 +++ b/gcc/testsuite/gfortran.dg/typebound_proc_27.f03 @@ -33,6 +33,7 @@ program prog use m + block ! Start new scoping unit as PROGRAM implies SAVE type(tx) :: this type(tx), target :: that type(tx), pointer :: p @@ -64,6 +65,7 @@ program prog !print *,this%i if(any (this%i /= [8, 9])) call abort() + end block end program prog ! --- /dev/null 2013-05-30 08:32:37.588061020 +0200 +++ gcc/gcc/testsuite/gfortran.dg/finalize_12.f90 2013-05-30 12:09:03.928265984 +0200 @@ -0,0 +1,175 @@ +! { dg-do run } +! { dg-options "-fcoarray=single" } +! +! PR fortran/37336 +! +module m + implicit none + type t + integer :: i + contains + final :: fini, fini2 + end type t + integer :: global_count1, global_count2 +contains + subroutine fini(x) + type(t) :: x + !print *, 'fini:',x%i + if (global_count1 == -1) call abort () + if (x%i /= 42) call abort() + x%i = 33 + global_count1 = global_count1 + 1 + end subroutine fini + subroutine fini2(x) + type(t) :: x(:) + !print *, 'fini2', x%i + if (global_count2 == -1) call abort () + if (size(x) /= 5) call abort() + if (any (x%i /= [1,2,3,4,5]) .and. any (x%i /= [6,7,8,9,10])) call abort() + x%i = 33 + global_count2 = global_count2 + 10 + end subroutine fini2 +end module m + +program pp + use m + implicit none + type(t), allocatable :: ya + class(t), allocatable :: yc + type(t), allocatable :: yaa(:) + class(t), allocatable :: yca(:) + + type(t), allocatable :: ca[:] + class(t), allocatable :: cc[:] + type(t), allocatable :: caa(:)[:] + class(t), allocatable :: cca(:)[:] + + global_count1 = -1 + global_count2 = -1 + allocate (ya, yc, yaa(5), yca(5)) + global_count1 = 0 + global_count2 = 0 + ya%i = 42 + yc%i = 42 + yaa%i = [1,2,3,4,5] + yca%i = [1,2,3,4,5] + + call foo(ya, yc, yaa, yca) + if (global_count1 /= 2) call abort () + if (global_count2 /= 20) call abort () + + ! Coarray finalization + allocate (ca[*], cc[*], caa(5)[*], cca(5)[*]) + global_count1 = 0 + global_count2 = 0 + ca%i = 42 + cc%i = 42 + caa%i = [1,2,3,4,5] + cca%i = [1,2,3,4,5] + deallocate (ca, cc, caa, cca) + if (global_count1 /= 2) call abort () + if (global_count2 /= 20) call abort () + global_count1 = -1 + global_count2 = -1 + + block + type(t), allocatable :: za + class(t), allocatable :: zc + type(t), allocatable :: zaa(:) + class(t), allocatable :: zca(:) + + ! Test intent(out) finalization + allocate (za, zc, zaa(5), zca(5)) + global_count1 = 0 + global_count2 = 0 + za%i = 42 + zc%i = 42 + zaa%i = [1,2,3,4,5] + zca%i = [1,2,3,4,5] + + call foo(za, zc, zaa, zca) + if (global_count1 /= 2) call abort () + if (global_count2 /= 20) call abort () + + ! Test intent(out) finalization with optional + call foo_opt() + call opt() + + ! Test intent(out) finalization with optional + allocate (za, zc, zaa(5), zca(5)) + global_count1 = 0 + global_count2 = 0 + za%i = 42 + zc%i = 42 + zaa%i = [1,2,3,4,5] + zca%i = [1,2,3,4,5] + + call foo_opt(za, zc, zaa, zca) + if (global_count1 /= 2) call abort () + if (global_count2 /= 20) call abort () + + ! Test DEALLOCATE finalization + allocate (za, zc, zaa(5), zca(5)) + global_count1 = 0 + global_count2 = 0 + za%i = 42 + zc%i = 42 + zaa%i = [1,2,3,4,5] + zca%i = [6,7,8,9,10] + deallocate (za, zc, zaa, zca) + if (global_count1 /= 2) call abort () + if (global_count2 /= 20) call abort () + + ! Test end-of-scope finalization + allocate (za, zc, zaa(5), zca(5)) + global_count1 = 0 + global_count2 = 0 + za%i = 42 + zc%i = 42 + zaa%i = [1,2,3,4,5] + zca%i = [6,7,8,9,10] + end block + + if (global_count1 /= 2) call abort () + if (global_count2 /= 20) call abort () + + ! Test that no end-of-scope finalization occurs + ! for SAVED variable in main + allocate (ya, yc, yaa(5), yca(5)) + global_count1 = -1 + global_count2 = -1 + +contains + + subroutine opt(xa, xc, xaa, xca) + type(t), allocatable, optional :: xa + class(t), allocatable, optional :: xc + type(t), allocatable, optional :: xaa(:) + class(t), allocatable, optional :: xca(:) + call foo_opt(xc, xc, xaa) + !call foo_opt(xa, xc, xaa, xca) ! FIXME: Fails (ICE) due to PR 57445 + end subroutine opt + subroutine foo_opt(xa, xc, xaa, xca) + type(t), allocatable, intent(out), optional :: xa + class(t), allocatable, intent(out), optional :: xc + type(t), allocatable, intent(out), optional :: xaa(:) + class(t), allocatable, intent(out), optional :: xca(:) + + if (.not. present(xa)) & + return + if (allocated (xa)) call abort () + if (allocated (xc)) call abort () + if (allocated (xaa)) call abort () + if (allocated (xca)) call abort () + end subroutine foo_opt + subroutine foo(xa, xc, xaa, xca) + type(t), allocatable, intent(out) :: xa + class(t), allocatable, intent(out) :: xc + type(t), allocatable, intent(out) :: xaa(:) + class(t), allocatable, intent(out) :: xca(:) + if (allocated (xa)) call abort () + if (allocated (xc)) call abort () + if (allocated (xaa)) call abort () + if (allocated (xca)) call abort () + end subroutine foo +end program --- /dev/null 2013-05-30 08:32:37.588061020 +0200 +++ gcc/gcc/testsuite/gfortran.dg/finalize_13.f90 2013-05-30 11:14:23.121847304 +0200 @@ -0,0 +1,161 @@ +! { dg-do run } +! +! PR fortran/37336 +! +module m + implicit none + type t + integer :: i + contains + final :: fini3, fini2, fini_elm + end type t + + type, extends(t) :: t2 + integer :: j + contains + final :: f2ini2, f2ini_elm + end type t2 + + logical :: elem_call + logical :: rank2_call + logical :: rank3_call + integer :: cnt, cnt2 + integer :: fini_call + +contains + subroutine fini2 (x) + type(t), intent(in), contiguous :: x(:,:) + if (.not. rank2_call) call abort () + if (size(x,1) /= 2 .or. size(x,2) /= 3) call abort() + !print *, 'fini2:', x%i + if (any (x%i /= reshape([11, 12, 21, 22, 31, 32], [2,3]))) call abort() + fini_call = fini_call + 1 + end subroutine + + subroutine fini3 (x) + type(t), intent(in) :: x(2,2,*) + integer :: i,j,k + if (.not. elem_call) call abort () + if (.not. rank3_call) call abort () + if (cnt2 /= 9) call abort() + if (cnt /= 1) call abort() + do i = 1, 2 + do j = 1, 2 + do k = 1, 2 + !print *, k,j,i,x(k,j,i)%i + if (x(k,j,i)%i /= k+10*j+100*i) call abort() + end do + end do + end do + fini_call = fini_call + 1 + end subroutine + + impure elemental subroutine fini_elm (x) + type(t), intent(in) :: x + if (.not. elem_call) call abort () + if (rank3_call) call abort () + if (cnt2 /= 6) call abort() + if (cnt /= x%i) call abort() + !print *, 'fini_elm:', cnt, x%i + fini_call = fini_call + 1 + cnt = cnt + 1 + end subroutine + + subroutine f2ini2 (x) + type(t2), intent(in), target :: x(:,:) + if (.not. rank2_call) call abort () + if (size(x,1) /= 2 .or. size(x,2) /= 3) call abort() + !print *, 'f2ini2:', x%i + !print *, 'f2ini2:', x%j + if (any (x%i /= reshape([11, 12, 21, 22, 31, 32], [2,3]))) call abort() + if (any (x%j /= 100*reshape([11, 12, 21, 22, 31, 32], [2,3]))) call abort() + fini_call = fini_call + 1 + end subroutine + + impure elemental subroutine f2ini_elm (x) + type(t2), intent(in) :: x + integer, parameter :: exprected(*) & + = [111, 112, 121, 122, 211, 212, 221, 222] + + if (.not. elem_call) call abort () + !print *, 'f2ini_elm:', cnt2, x%i, x%j + if (rank3_call) then + if (x%i /= exprected(cnt2)) call abort () + if (x%j /= 1000*exprected(cnt2)) call abort () + else + if (cnt2 /= x%i .or. cnt2*10 /= x%j) call abort() + end if + cnt2 = cnt2 + 1 + fini_call = fini_call + 1 + end subroutine +end module m + + +program test + use m + implicit none + class(t), save, allocatable :: y(:), z(:,:), zz(:,:,:) + target :: z, zz + integer :: i,j,k + + elem_call = .false. + rank2_call = .false. + rank3_call = .false. + allocate (t2 :: y(5)) + select type (y) + type is (t2) + do i = 1, 5 + y(i)%i = i + y(i)%j = i*10 + end do + end select + cnt = 1 + cnt2 = 1 + fini_call = 0 + elem_call = .true. + deallocate (y) + if (fini_call /= 10) call abort () + + elem_call = .false. + rank2_call = .false. + rank3_call = .false. + allocate (t2 :: z(2,3)) + select type (z) + type is (t2) + do i = 1, 3 + do j = 1, 2 + z(j,i)%i = j+10*i + z(j,i)%j = (j+10*i)*100 + end do + end do + end select + cnt = 1 + cnt2 = 1 + fini_call = 0 + rank2_call = .true. + deallocate (z) + if (fini_call /= 2) call abort () + + elem_call = .false. + rank2_call = .false. + rank3_call = .false. + allocate (t2 :: zz(2,2,2)) + select type (zz) + type is (t2) + do i = 1, 2 + do j = 1, 2 + do k = 1, 2 + zz(k,j,i)%i = k+10*j+100*i + zz(k,j,i)%j = (k+10*j+100*i)*1000 + end do + end do + end do + end select + cnt = 1 + cnt2 = 1 + fini_call = 0 + rank3_call = .true. + elem_call = .true. + deallocate (zz) + if (fini_call /= 2*2*2+1) call abort () +end program test --- /dev/null 2013-05-30 08:32:37.588061020 +0200 +++ gcc/gcc/testsuite/gfortran.dg/finalize_14.f90 2013-05-30 11:40:24.611148683 +0200 @@ -0,0 +1,220 @@ +! { dg-do compile } +! +! PR fortran/37336 +! +! Started to fail when finalization was added. +! +! Contributed by Ian Chivers in PR fortran/44465 +! +module shape_module + + type shape_type + integer :: x_=0 + integer :: y_=0 + contains + procedure , pass(this) :: getx + procedure , pass(this) :: gety + procedure , pass(this) :: setx + procedure , pass(this) :: sety + procedure , pass(this) :: moveto + procedure , pass(this) :: draw + end type shape_type + +interface assignment(=) + module procedure generic_shape_assign +end interface + +contains + + integer function getx(this) + implicit none + class (shape_type) , intent(in) :: this + getx=this%x_ + end function getx + + integer function gety(this) + implicit none + class (shape_type) , intent(in) :: this + gety=this%y_ + end function gety + + subroutine setx(this,x) + implicit none + class (shape_type), intent(inout) :: this + integer , intent(in) :: x + this%x_=x + end subroutine setx + + subroutine sety(this,y) + implicit none + class (shape_type), intent(inout) :: this + integer , intent(in) :: y + this%y_=y + end subroutine sety + + subroutine moveto(this,newx,newy) + implicit none + class (shape_type), intent(inout) :: this + integer , intent(in) :: newx + integer , intent(in) :: newy + this%x_=newx + this%y_=newy + end subroutine moveto + + subroutine draw(this) + implicit none + class (shape_type), intent(in) :: this + print *,' x = ' , this%x_ + print *,' y = ' , this%y_ + end subroutine draw + + subroutine generic_shape_assign(lhs,rhs) + implicit none + class (shape_type) , intent(out) , allocatable :: lhs + class (shape_type) , intent(in) :: rhs + print *,' In generic_shape_assign' + if ( allocated(lhs) ) then + deallocate(lhs) + end if + allocate(lhs,source=rhs) + end subroutine generic_shape_assign + +end module shape_module + +! Circle_p.f90 + +module circle_module + +use shape_module + +type , extends(shape_type) :: circle_type + + integer :: radius_ + + contains + + procedure , pass(this) :: getradius + procedure , pass(this) :: setradius + procedure , pass(this) :: draw => draw_circle + +end type circle_type + + contains + + integer function getradius(this) + implicit none + class (circle_type) , intent(in) :: this + getradius=this%radius_ + end function getradius + + subroutine setradius(this,radius) + implicit none + class (circle_type) , intent(inout) :: this + integer , intent(in) :: radius + this%radius_=radius + end subroutine setradius + + subroutine draw_circle(this) + implicit none + class (circle_type), intent(in) :: this + print *,' x = ' , this%x_ + print *,' y = ' , this%y_ + print *,' radius = ' , this%radius_ + end subroutine draw_circle + +end module circle_module + + +! Rectangle_p.f90 + +module rectangle_module + +use shape_module + +type , extends(shape_type) :: rectangle_type + + integer :: width_ + integer :: height_ + + contains + + procedure , pass(this) :: getwidth + procedure , pass(this) :: setwidth + procedure , pass(this) :: getheight + procedure , pass(this) :: setheight + procedure , pass(this) :: draw => draw_rectangle + +end type rectangle_type + + contains + + integer function getwidth(this) + implicit none + class (rectangle_type) , intent(in) :: this + getwidth=this%width_ + end function getwidth + + subroutine setwidth(this,width) + implicit none + class (rectangle_type) , intent(inout) :: this + integer , intent(in) :: width + this%width_=width + end subroutine setwidth + + integer function getheight(this) + implicit none + class (rectangle_type) , intent(in) :: this + getheight=this%height_ + end function getheight + + subroutine setheight(this,height) + implicit none + class (rectangle_type) , intent(inout) :: this + integer , intent(in) :: height + this%height_=height + end subroutine setheight + + subroutine draw_rectangle(this) + implicit none + class (rectangle_type), intent(in) :: this + print *,' x = ' , this%x_ + print *,' y = ' , this%y_ + print *,' width = ' , this%width_ + print *,' height = ' , this%height_ + + end subroutine draw_rectangle + +end module rectangle_module + + + +program polymorphic + +use shape_module +use circle_module +use rectangle_module + +implicit none + +type shape_w + class (shape_type) , allocatable :: shape_v +end type shape_w + +type (shape_w) , dimension(3) :: p + + print *,' shape ' + + p(1)%shape_v=shape_type(10,20) + call p(1)%shape_v%draw() + + print *,' circle ' + + p(2)%shape_v=circle_type(100,200,300) + call p(2)%shape_v%draw() + + print *,' rectangle ' + + p(3)%shape_v=rectangle_type(1000,2000,3000,4000) + call p(3)%shape_v%draw() + +end program polymorphic