From patchwork Tue Nov 27 18:29:15 2012 Content-Type: text/plain; charset="utf-8" MIME-Version: 1.0 Content-Transfer-Encoding: 8bit X-Patchwork-Submitter: Tobias Burnus X-Patchwork-Id: 202278 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]) by ozlabs.org (Postfix) with SMTP id EB3062C0040 for ; Wed, 28 Nov 2012 05:29:45 +1100 (EST) Comment: DKIM? See http://www.dkim.org DKIM-Signature: v=1; a=rsa-sha1; c=relaxed/relaxed; d=gcc.gnu.org; s=default; x=1354645786; h=Comment: DomainKey-Signature:Received:Received:Received:Received: Message-ID:Date:From:User-Agent:MIME-Version:To:Subject: Content-Type:Mailing-List:Precedence:List-Id:List-Unsubscribe: List-Archive:List-Post:List-Help:Sender:Delivered-To; bh=1uSPDw2 HimFj8x3BbQpoperSHZ4=; b=PevNmaXBoauCNCD83E376MTMSnDsFHpEBF3qBgF 8/tekEXs6Y+Zn5oJuKwdUvzuTrBsSGC09tFp5Y7ZDUIgzb39naLmo/siv0LUXtK3 clA8M8ZgdxCsvR6ZTGrNrHDuz1prznpQ1svfJi25LbCiWbSpahO6hOWCFz30O1+8 uKQs= Comment: DomainKeys? See http://antispam.yahoo.com/domainkeys DomainKey-Signature: a=rsa-sha1; q=dns; c=nofws; s=default; d=gcc.gnu.org; h=Received:Received:X-SWARE-Spam-Status:X-Spam-Check-By:Received:Received:Message-ID:Date:From:User-Agent:MIME-Version:To:Subject:Content-Type:Mailing-List:Precedence:List-Id:List-Unsubscribe:List-Archive:List-Post:List-Help:Sender:Delivered-To; b=N0vCPW4gtiiNJl4Vb/IzcWKTTDUgFyjhFG6acyKXSgdrXn0CHuDn3yCm+413WZ dfJMkzaOYQYAwwnQ1hgaWp7L7qtwdZ1JZzgHZJaU66B9RKPiyfNMUX03lEGYPXfo ssI0SstmTB+bCbBJhfQcY5u+KbG3w9r83oBvAXQ+aILbw=; Received: (qmail 28158 invoked by alias); 27 Nov 2012 18:29:31 -0000 Received: (qmail 28140 invoked by uid 22791); 27 Nov 2012 18:29:29 -0000 X-SWARE-Spam-Status: No, hits=0.6 required=5.0 tests=AWL, BAYES_00, KAM_STOCKTIP, RCVD_IN_DNSWL_NONE, RCVD_IN_HOSTKARMA_NO, TW_VP X-Spam-Check-By: sourceware.org Received: from mx01.qsc.de (HELO mx01.qsc.de) (213.148.129.14) by sourceware.org (qpsmtpd/0.43rc1) with ESMTP; Tue, 27 Nov 2012 18:29:18 +0000 Received: from [192.168.178.25] (port-92-195-33-30.dynamic.qsc.de [92.195.33.30]) by mx01.qsc.de (Postfix) with ESMTP id 360D63CD45; Tue, 27 Nov 2012 19:29:15 +0100 (CET) Message-ID: <50B5067B.9070005@net-b.de> Date: Tue, 27 Nov 2012 19:29:15 +0100 From: Tobias Burnus User-Agent: Mozilla/5.0 (X11; Linux x86_64; rv:17.0) Gecko/17.0 Thunderbird/17.0 MIME-Version: 1.0 To: gcc patches , gfortran , Janus Weil Subject: [Patch, Fortran] No-op Patch - a.k.a. FINAL wrapper update 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 Dear all, effectively, this patch doesn't do anything. Except, it updates the – deactivated – finalization wrapper. Note: This patch does not include any code to actually call the finalization wrapper. Nor is the modified code ever called in gfortran. However, that patch paves the road to a proper finalization (and polymorphic deallocation) support. When I mention below that I tested the patch: That was with the larger but incomplete final-2012-11-27-v2.diff patch, available at https://userpage.physik.fu-berlin.de/~tburnus/final/ Note that the patch there has known issues and does not incorporate all of Janus changes. Changes relative to the trunk: * Properly handles coarray components: Those may not be finalized for intrinsic assignment; with this patch there is now a generated "IF" condition to ensure this in the wrapper. * While arrays arguments to the wrapper have to be contiguous, the new version takes a "stride" argument which allows noncontiguity in the lowest dimension. That is: One can pass a contiguous array directly to the parent's finalizer even if it then isn't anymore contiguous (for the parent type). If the finalizers are all elemental (or scalar), no copy-in/copy-out is needed. However, if it is passed to an array final subroutine, the array is packed using the following code: if (stride == STORAGE_SIZE (array)/NUMERIC_STORAGE_SIZE || 0 == STORAGE_SIZE (array)) then call final_rank3 (array) else block type(t) :: tmp(shape (array)) do i = 0, size (array)-1 addr = transfer (c_loc (array), addr) + i * stride call c_f_pointer (transfer (addr, cptr), ptr) addr = transfer (c_loc (tmp), addr) + i * STORAGE_SIZE (array)/NUMERIC_STORAGE_SIZE call c_f_pointer (transfer (addr, cptr), ptr2) ptr2 = ptr end do call final_rank3 (tmp) end block end if Build and regtested on x86-64-gnu-linux. OK for the trunk? Tobias PS: I don't know when I will have time to continue working on the patch. The next steps from my side are: First, submit some smaller bits from the final-2012-11-27-v2.diff patch, even if they will be unused. Secondly, do some cleanup and fix a few issues and merge Janus' patch. (My patch is based on the 2012-10-26 version of the patch, Janus' latest patch was 2012-11-04.) At that point, one might consider enabling the FINAL feature partially (e.g. only polymorphic deallocation by not allowing FINAL) or fully. PPS: The patch was successfully tested with the following test case (and some small variations of it): module m type t integer :: i contains final :: fini end type t type, extends(t) :: t2 integer :: j contains final :: fini2 end type t2 contains subroutine fini(x) ! type(t), intent(in) :: x(:,:) type(t), intent(inout) :: x(:,:) print *, 'SHAPE:', shape(x) print *, x end subroutine fini impure elemental subroutine fini2(x) type(t2), intent(inout) :: x print *, 'FINI2 - elemental: ', x%i x%i = x%i+10*x%i end subroutine fini2 end module m use m class(t2), allocatable :: x(:,:) allocate(t2 :: x(2,3)) x(:,:)%i = reshape([1,2,3,4,5,6],[2,3]) print *, 'HELLO: ', x%i deallocate(x) end 2012-11-27 Tobias Burnus PR fortran/37336 * class.c (find_derived_vtab): New static function. (gfc_get_derived_vtab): Renamed from gfc_find_derived_vtab. (gfc_find_derived_vtab): New function. (gfc_class_null_initializer, get_unique_hashed_string, gfc_build_class_symbol, copy_vtab_proc_comps, ): Use gfc_get_derived_vtab instead of gfc_find_derived_vtab. (finalizer_insert_packed_call): New static function. (finalize_component, generate_finalization_wrapper): Fix coarray handling and packing. * gfortran.h (gfc_get_derived_vtab): New prototype. * check.c (gfc_check_move_alloc): Use it. * expr.c (gfc_check_pointer_assign): Ditto. * interface.c (compare_parameter): Ditto. * iresolve.c (gfc_resolve_extends_type_of): Ditto. * trans-decl.c (gfc_get_symbol_decl): Ditto. * trans-expr.c (gfc_conv_derived_to_class, gfc_trans_class_assign): Ditto. * trans-intrinsic.c (conv_intrinsic_move_alloc): Ditto. * trans-stmt.c (gfc_trans_allocate, gfc_trans_deallocate): Ditto. * resolve.c (resolve_typebound_function, resolve_typebound_subroutine, resolve_allocate_expr, resolve_select_type, gfc_resolve_finalizers, resolve_typebound_procedures, resolve_fl_derived): Ditto. (resolve_symbol): Return early if attr.artificial. diff --git a/gcc/fortran/check.c b/gcc/fortran/check.c index a490238..20d6bbd 100644 --- a/gcc/fortran/check.c +++ b/gcc/fortran/check.c @@ -2801,7 +2801,7 @@ gfc_check_move_alloc (gfc_expr *from, gfc_expr *to) /* CLASS arguments: Make sure the vtab of from is present. */ if (to->ts.type == BT_CLASS) - gfc_find_derived_vtab (from->ts.u.derived); + gfc_get_derived_vtab (from->ts.u.derived); return SUCCESS; } diff --git a/gcc/fortran/class.c b/gcc/fortran/class.c index 2e347cb..ab3bcc1 100644 --- a/gcc/fortran/class.c +++ b/gcc/fortran/class.c @@ -416,7 +416,7 @@ gfc_class_null_initializer (gfc_typespec *ts) { gfc_constructor *ctor = gfc_constructor_get(); if (strcmp (comp->name, "_vptr") == 0) - ctor->expr = gfc_lval_expr_from_sym (gfc_find_derived_vtab (ts->u.derived)); + ctor->expr = gfc_lval_expr_from_sym (gfc_get_derived_vtab (ts->u.derived)); else ctor->expr = gfc_get_null_expr (NULL); gfc_constructor_append (&init->value.constructor, ctor); @@ -454,7 +454,7 @@ get_unique_hashed_string (char *string, gfc_symbol *derived) char tmp[2*GFC_MAX_SYMBOL_LEN+2]; get_unique_type_string (&tmp[0], derived); /* If string is too long, use hash value in hex representation (allow for - extra decoration, cf. gfc_build_class_symbol & gfc_find_derived_vtab). + extra decoration, cf. gfc_build_class_symbol & gfc_get_derived_vtab). We need space to for 15 characters "__class_" + symbol name + "_%d_%da", where %d is the (co)rank which can be up to n = 15. */ if (strlen (tmp) > GFC_MAX_SYMBOL_LEN - 15) @@ -583,7 +583,7 @@ gfc_build_class_symbol (gfc_typespec *ts, symbol_attribute *attr, c->ts.u.derived = NULL; else { - vtab = gfc_find_derived_vtab (ts->u.derived); + vtab = gfc_get_derived_vtab (ts->u.derived); gcc_assert (vtab); c->ts.u.derived = vtab->ts.u.derived; } @@ -684,7 +684,7 @@ copy_vtab_proc_comps (gfc_symbol *declared, gfc_symbol *vtype) gfc_component *cmp; gfc_symbol *vtab; - vtab = gfc_find_derived_vtab (declared); + vtab = gfc_get_derived_vtab (declared); for (cmp = vtab->ts.u.derived->components; cmp; cmp = cmp->next) { @@ -731,7 +731,7 @@ has_finalizer_component (gfc_symbol *derived) static void finalize_component (gfc_expr *expr, gfc_symbol *derived, gfc_component *comp, - gfc_expr *stat, gfc_code **code) + gfc_symbol *stat, gfc_symbol *fini_coarray, gfc_code **code) { gfc_expr *e; gfc_ref *ref; @@ -779,12 +779,36 @@ finalize_component (gfc_expr *expr, gfc_symbol *derived, gfc_component *comp, e->rank = ref->next->u.ar.as->rank; } + /* Call DEALLOCATE (comp, stat=ignore). */ if (comp->attr.allocatable || (comp->ts.type == BT_CLASS && CLASS_DATA (comp) && CLASS_DATA (comp)->attr.allocatable)) { - /* Call DEALLOCATE (comp, stat=ignore). */ - gfc_code *dealloc; + gfc_code *dealloc, *block = NULL; + + /* Add IF (fini_coarray). */ + if (comp->attr.codimension + || (comp->ts.type == BT_CLASS && CLASS_DATA (comp) + && CLASS_DATA (comp)->attr.allocatable)) + { + block = XCNEW (gfc_code); + if (*code) + { + (*code)->next = block; + (*code) = (*code)->next; + } + else + (*code) = block; + + block->loc = gfc_current_locus; + block->op = EXEC_IF; + + block->block = XCNEW (gfc_code); + block = block->block; + block->loc = gfc_current_locus; + block->op = EXEC_IF; + block->expr1 = gfc_lval_expr_from_sym (fini_coarray); + } dealloc = XCNEW (gfc_code); dealloc->op = EXEC_DEALLOCATE; @@ -792,9 +816,11 @@ finalize_component (gfc_expr *expr, gfc_symbol *derived, gfc_component *comp, dealloc->ext.alloc.list = gfc_get_alloc (); dealloc->ext.alloc.list->expr = e; + dealloc->expr1 = gfc_lval_expr_from_sym (stat); - dealloc->expr1 = stat; - if (*code) + if (block) + block->next = dealloc; + else if (*code) { (*code)->next = dealloc; (*code) = (*code)->next; @@ -811,7 +837,7 @@ finalize_component (gfc_expr *expr, gfc_symbol *derived, gfc_component *comp, gfc_symbol *vtab; gfc_component *c; - vtab = gfc_find_derived_vtab (comp->ts.u.derived); + vtab = gfc_get_derived_vtab (comp->ts.u.derived); for (c = vtab->ts.u.derived->components; c; c = c->next) if (strcmp (c->name, "_final") == 0) break; @@ -839,7 +865,7 @@ finalize_component (gfc_expr *expr, gfc_symbol *derived, gfc_component *comp, gfc_component *c; for (c = comp->ts.u.derived->components; c; c = c->next) - finalize_component (e, c->ts.u.derived, c, stat, code); + finalize_component (e, comp->ts.u.derived, c, stat, fini_coarray, code); gfc_free_expr (e); } } @@ -847,12 +873,11 @@ 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 * STORAGE_SIZE (array)/NUMERIC_STORAGE_SIZE., c_ptr), - ptr). */ + + idx * stride, c_ptr), ptr). */ static gfc_code * finalization_scalarizer (gfc_symbol *idx, gfc_symbol *array, gfc_symbol *ptr, - gfc_namespace *sub_ns) + gfc_expr *stride, gfc_namespace *sub_ns) { gfc_code *block; gfc_expr *expr, *expr2, *expr3; @@ -919,40 +944,13 @@ finalization_scalarizer (gfc_symbol *idx, gfc_symbol *array, gfc_symbol *ptr, expr->ts.kind = gfc_index_integer_kind; expr2->value.function.actual->expr = expr; - /* STORAGE_SIZE (...) / NUMERIC_STORAGE_SIZE. */ - block->ext.actual->expr = gfc_get_expr (); - expr = block->ext.actual->expr; - expr->expr_type = EXPR_OP; - expr->value.op.op = INTRINSIC_DIVIDE; - - /* STORAGE_SIZE (array,kind=c_intptr_t). */ - expr->value.op.op1 = gfc_get_expr (); - expr->value.op.op1->expr_type = EXPR_FUNCTION; - expr->value.op.op1->value.function.isym - = gfc_intrinsic_function_by_id (GFC_ISYM_STORAGE_SIZE); - gfc_get_sym_tree ("storage_size", sub_ns, &expr->value.op.op1->symtree, - false); - expr->value.op.op1->symtree->n.sym->attr.flavor = FL_PROCEDURE; - expr->value.op.op1->symtree->n.sym->attr.intrinsic = 1; - gfc_commit_symbol (expr->value.op.op1->symtree->n.sym); - expr->value.op.op1->value.function.actual = gfc_get_actual_arglist (); - expr->value.op.op1->value.function.actual->expr - = gfc_lval_expr_from_sym (array); - expr->value.op.op1->value.function.actual->next = gfc_get_actual_arglist (); - expr->value.op.op1->value.function.actual->next->expr - = gfc_get_int_expr (gfc_index_integer_kind, NULL, 0); - expr->value.op.op2 = gfc_get_int_expr (gfc_index_integer_kind, NULL, - gfc_character_storage_size); - expr->value.op.op1->ts = expr->value.op.op2->ts; - expr->ts = expr->value.op.op1->ts; - - /* Offset calculation: idx * (STORAGE_SIZE (...) / NUMERIC_STORAGE_SIZE). */ + /* 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 = expr; + expr3->value.op.op2 = stride; expr3->ts = expr->ts; /* + . */ @@ -972,6 +970,265 @@ 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 + end do + call final_rank3 (tmp) + end block + end if */ + +static void +finalizer_insert_packed_call (gfc_code *block, gfc_finalizer *fini, + gfc_symbol *array, gfc_symbol *stride, + gfc_symbol *idx, gfc_symbol *ptr, + gfc_symbol *nelem, gfc_symtree *size_intr, + gfc_namespace *sub_ns) +{ + gfc_symbol *tmp_array, *ptr2; + gfc_expr *size_expr; + gfc_namespace *ns; + gfc_iterator *iter; + int i; + + block->next = XCNEW (gfc_code); + block = block->next; + block->loc = gfc_current_locus; + block->op = EXEC_IF; + + block->block = XCNEW (gfc_code); + block = block->block; + block->loc = gfc_current_locus; + block->op = EXEC_IF; + + /* size_expr = STORAGE_SIZE (...) / NUMERIC_STORAGE_SIZE. */ + size_expr = gfc_get_expr (); + size_expr->where = gfc_current_locus; + size_expr->expr_type = EXPR_OP; + size_expr->value.op.op = INTRINSIC_DIVIDE; + + /* STORAGE_SIZE (array,kind=c_intptr_t). */ + size_expr->value.op.op1 = gfc_get_expr (); + size_expr->value.op.op1->where = gfc_current_locus; + size_expr->value.op.op1->expr_type = EXPR_FUNCTION; + size_expr->value.op.op1->value.function.isym + = gfc_intrinsic_function_by_id (GFC_ISYM_STORAGE_SIZE); + gfc_get_sym_tree ("storage_size", sub_ns, &size_expr->value.op.op1->symtree, + false); + size_expr->value.op.op1->symtree->n.sym->attr.flavor = FL_PROCEDURE; + size_expr->value.op.op1->symtree->n.sym->attr.intrinsic = 1; + gfc_commit_symbol (size_expr->value.op.op1->symtree->n.sym); + size_expr->value.op.op1->value.function.actual = gfc_get_actual_arglist (); + size_expr->value.op.op1->value.function.actual->expr + = gfc_lval_expr_from_sym (array); + size_expr->value.op.op1->value.function.actual->next = gfc_get_actual_arglist (); + size_expr->value.op.op1->value.function.actual->next->expr + = gfc_get_int_expr (gfc_index_integer_kind, NULL, 0); + + /* NUMERIC_STORAGE_SIZE. */ + size_expr->value.op.op2 = gfc_get_int_expr (gfc_index_integer_kind, NULL, + gfc_character_storage_size); + size_expr->value.op.op1->ts = size_expr->value.op.op2->ts; + size_expr->ts = size_expr->value.op.op1->ts; + + /* IF condition: stride == size_expr || 0 == size_expr. */ + block->expr1 = gfc_get_expr (); + block->expr1->expr_type = EXPR_FUNCTION; + block->expr1->ts.type = BT_LOGICAL; + block->expr1->ts.kind = 4; + block->expr1->expr_type = EXPR_OP; + block->expr1->where = gfc_current_locus; + + block->expr1->value.op.op = INTRINSIC_OR; + + /* stride == size_expr */ + block->expr1->value.op.op1 = gfc_get_expr (); + block->expr1->value.op.op1->expr_type = EXPR_FUNCTION; + block->expr1->value.op.op1->ts.type = BT_LOGICAL; + block->expr1->value.op.op1->ts.kind = 4; + block->expr1->value.op.op1->expr_type = EXPR_OP; + block->expr1->value.op.op1->where = gfc_current_locus; + block->expr1->value.op.op1->value.op.op = INTRINSIC_EQ; + block->expr1->value.op.op1->value.op.op1 = gfc_lval_expr_from_sym (stride); + block->expr1->value.op.op1->value.op.op2 = size_expr; + + /* 0 == size_expr */ + block->expr1->value.op.op2 = gfc_get_expr (); + block->expr1->value.op.op2->expr_type = EXPR_FUNCTION; + block->expr1->value.op.op2->ts.type = BT_LOGICAL; + block->expr1->value.op.op2->ts.kind = 4; + block->expr1->value.op.op2->expr_type = EXPR_OP; + block->expr1->value.op.op2->where = gfc_current_locus; + block->expr1->value.op.op2->value.op.op = INTRINSIC_EQ; + block->expr1->value.op.op2->value.op.op1 = + gfc_get_int_expr (gfc_index_integer_kind, NULL, 0); + block->expr1->value.op.op2->value.op.op2 = gfc_copy_expr (size_expr); + + /* IF body: call final subroutine. */ + block->next = XCNEW (gfc_code); + block->next->op = EXEC_CALL; + block->next->loc = gfc_current_locus; + block->next->symtree = fini->proc_tree; + block->next->resolved_sym = fini->proc_tree->n.sym; + block->next->ext.actual = gfc_get_actual_arglist (); + block->next->ext.actual->expr = gfc_lval_expr_from_sym (array); + + /* ELSE. */ + + block->block = XCNEW (gfc_code); + block = block->block; + block->loc = gfc_current_locus; + block->op = EXEC_IF; + + block->next = XCNEW (gfc_code); + block = block->next; + + /* BLOCK ... END BLOCK. */ + block->op = EXEC_BLOCK; + block->loc = gfc_current_locus; + ns = gfc_build_block_ns (sub_ns); + block->ext.block.ns = ns; + block->ext.block.assoc = NULL; + + gfc_get_symbol ("ptr2", ns, &ptr2); + ptr2->ts.type = BT_DERIVED; + ptr2->ts.u.derived = array->ts.u.derived; + ptr2->attr.flavor = FL_VARIABLE; + ptr2->attr.pointer = 1; + ptr2->attr.artificial = 1; + gfc_set_sym_referenced (ptr2); + gfc_commit_symbol (ptr2); + + gfc_get_symbol ("tmp_array", ns, &tmp_array); + 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(); + tmp_array->attr.intent = INTENT_INOUT; + tmp_array->as->type = AS_EXPLICIT; + tmp_array->as->rank = fini->proc_tree->n.sym->formal->sym->as->rank; + + for (i = 0; i < tmp_array->as->rank; i++) + { + gfc_expr *shape_expr; + tmp_array->as->lower[i] = gfc_get_int_expr (gfc_default_integer_kind, + NULL, 1); + /* SIZE (array, dim=i+1, kind=default_kind). */ + shape_expr = gfc_get_expr (); + shape_expr->expr_type = EXPR_FUNCTION; + shape_expr->value.function.isym + = gfc_intrinsic_function_by_id (GFC_ISYM_SIZE); + shape_expr->symtree = size_intr; + shape_expr->value.function.actual = gfc_get_actual_arglist (); + shape_expr->value.function.actual->expr = gfc_lval_expr_from_sym (array); + shape_expr->value.function.actual->next = gfc_get_actual_arglist (); + shape_expr->value.function.actual->next->expr + = gfc_get_int_expr (gfc_default_integer_kind, NULL, i+1); + shape_expr->value.function.actual->next->next = gfc_get_actual_arglist (); + shape_expr->value.function.actual->next->next->expr + = gfc_get_int_expr (gfc_default_integer_kind, NULL, 0); + shape_expr->ts = shape_expr->value.function.isym->ts; + + tmp_array->as->upper[i] = shape_expr; + } + gfc_set_sym_referenced (tmp_array); + gfc_commit_symbol (tmp_array); + + /* Create loop. */ + iter = gfc_get_iterator (); + iter->var = gfc_lval_expr_from_sym (idx); + iter->start = gfc_get_int_expr (gfc_index_integer_kind, NULL, 0); + iter->end = gfc_lval_expr_from_sym (nelem); + iter->step = gfc_get_int_expr (gfc_index_integer_kind, NULL, 1); + + block = XCNEW (gfc_code); + ns->code = block; + block->op = EXEC_DO; + block->loc = gfc_current_locus; + block->ext.iterator = iter; + block->block = gfc_get_code (); + block->block->op = EXEC_DO; + + /* Create code for + CALL C_F_POINTER (TRANSFER (TRANSFER (C_LOC (array, cptr), c_intptr) + + idx * stride, c_ptr), ptr). */ + block->block->next = finalization_scalarizer (idx, array, ptr, + gfc_lval_expr_from_sym (stride), + sub_ns); + block->block->next->next = finalization_scalarizer (idx, tmp_array, ptr2, + gfc_copy_expr (size_expr), + sub_ns); + /* ptr2 = ptr. */ + block->block->next->next->next = XCNEW (gfc_code); + block->block->next->next->next->op = EXEC_ASSIGN; + block->block->next->next->next->loc = gfc_current_locus; + block->block->next->next->next->expr1 = gfc_lval_expr_from_sym (ptr2); + block->block->next->next->next->expr2 = gfc_lval_expr_from_sym (ptr); + + block->next = XCNEW (gfc_code); + block = block->next; + block->op = EXEC_CALL; + block->loc = gfc_current_locus; + block->symtree = fini->proc_tree; + block->resolved_sym = fini->proc_tree->n.sym; + block->ext.actual = gfc_get_actual_arglist (); + block->ext.actual->expr = gfc_lval_expr_from_sym (tmp_array); + + if (fini->proc_tree->n.sym->formal->sym->attr.intent == INTENT_IN) + return; + + /* Copy back. */ + + /* Loop. */ + iter = gfc_get_iterator (); + iter->var = gfc_lval_expr_from_sym (idx); + iter->start = gfc_get_int_expr (gfc_index_integer_kind, NULL, 0); + iter->end = gfc_lval_expr_from_sym (nelem); + iter->step = gfc_get_int_expr (gfc_index_integer_kind, NULL, 1); + + block->next = XCNEW (gfc_code); + block = block->next; + block->op = EXEC_DO; + block->loc = gfc_current_locus; + block->ext.iterator = iter; + block->block = gfc_get_code (); + block->block->op = EXEC_DO; + + /* Create code for + CALL C_F_POINTER (TRANSFER (TRANSFER (C_LOC (array, cptr), c_intptr) + + idx * stride, c_ptr), ptr). */ + block->block->next = finalization_scalarizer (idx, array, ptr, + gfc_lval_expr_from_sym (stride), + sub_ns); + block->block->next->next = finalization_scalarizer (idx, tmp_array, ptr2, + gfc_copy_expr (size_expr), + sub_ns); + /* ptr = ptr2. */ + block->block->next->next->next = XCNEW (gfc_code); + block->block->next->next->next->op = EXEC_ASSIGN; + block->block->next->next->next->loc = gfc_current_locus; + block->block->next->next->next->expr1 = gfc_lval_expr_from_sym (ptr); + block->block->next->next->next->expr2 = gfc_lval_expr_from_sym (ptr2); +} + + /* Generate the finalization/polymorphic freeing wrapper subroutine for the derived type "derived". The function first calls the approriate FINAL subroutine, then it DEALLOCATEs (finalizes/frees) the allocatable @@ -979,19 +1236,28 @@ finalization_scalarizer (gfc_symbol *idx, gfc_symbol *array, gfc_symbol *ptr, subroutine of the parent. The generated wrapper procedure takes as argument an assumed-rank array. If neither allocatable components nor FINAL subroutines exists, the vtab - will contain a NULL pointer. */ + will contain a NULL pointer. + The generated function has the form + _final(assumed-rank array, stride, skip_corarray) + where the array has to be contiguous (except of the lowest dimension). The + stride (in bytes) is used to allow different sizes for ancestor types by + skipping over the additionally added components in the scalarizer. If + "fini_coarray" is false, coarray components are not finalized to allow for + the correct semantic with intrinsic assignment. */ static void generate_finalization_wrapper (gfc_symbol *derived, gfc_namespace *ns, const char *tname, gfc_component *vtab_final) { - gfc_symbol *final, *array, *nelem; + gfc_symbol *final, *array, *nelem, *fini_coarray, *stride; gfc_symbol *ptr = NULL, *idx = NULL; + gfc_symtree *size_intr; gfc_component *comp; gfc_namespace *sub_ns; gfc_code *last_code; char name[GFC_MAX_SYMBOL_LEN+1]; bool finalizable_comp = false; + bool expr_null_wrapper = false; gfc_expr *ancestor_wrapper = NULL; /* Search for the ancestor's finalizers. */ @@ -1002,7 +1268,7 @@ generate_finalization_wrapper (gfc_symbol *derived, gfc_namespace *ns, gfc_symbol *vtab; gfc_component *comp; - vtab = gfc_find_derived_vtab (derived->components->ts.u.derived); + vtab = gfc_get_derived_vtab (derived->components->ts.u.derived); for (comp = vtab->ts.u.derived->components; comp; comp = comp->next) if (comp->name[0] == '_' && comp->name[1] == 'f') { @@ -1011,40 +1277,44 @@ generate_finalization_wrapper (gfc_symbol *derived, gfc_namespace *ns, } } - /* No wrapper of the ancestor and no own FINAL subroutines and - allocatable components: Return a NULL() expression. */ + /* No wrapper of the ancestor and no own FINAL subroutines and allocatable + components: Return a NULL() expression; we defer this a bit to have have + an interface declaration. */ if ((!ancestor_wrapper || ancestor_wrapper->expr_type == EXPR_NULL) && !derived->attr.alloc_comp && (!derived->f2k_derived || !derived->f2k_derived->finalizers) && !has_finalizer_component (derived)) - { - vtab_final->initializer = gfc_get_null_expr (NULL); - return; - } - - /* Check whether there are new allocatable components. */ - for (comp = derived->components; comp; comp = comp->next) - { - if (comp == derived->components && derived->attr.extension - && ancestor_wrapper && ancestor_wrapper->expr_type != EXPR_NULL) + expr_null_wrapper = true; + else + /* Check whether there are new allocatable components. */ + for (comp = derived->components; comp; comp = comp->next) + { + if (comp == derived->components && derived->attr.extension + && ancestor_wrapper && ancestor_wrapper->expr_type != EXPR_NULL) continue; - if (comp->ts.type != BT_CLASS && !comp->attr.pointer - && (comp->attr.alloc_comp || comp->attr.allocatable - || (comp->ts.type == BT_DERIVED - && has_finalizer_component (comp->ts.u.derived)))) - finalizable_comp = true; - else if (comp->ts.type == BT_CLASS && CLASS_DATA (comp) - && CLASS_DATA (comp)->attr.allocatable) - finalizable_comp = true; - } + if (comp->ts.type != BT_CLASS && !comp->attr.pointer + && (comp->attr.allocatable + || (comp->ts.type == BT_DERIVED + && (comp->ts.u.derived->attr.alloc_comp + || has_finalizer_component (comp->ts.u.derived) + || (comp->ts.u.derived->f2k_derived + && comp->ts.u.derived->f2k_derived->finalizers))))) + finalizable_comp = true; + else if (comp->ts.type == BT_CLASS && CLASS_DATA (comp) + && CLASS_DATA (comp)->attr.allocatable) + finalizable_comp = true; + } /* If there is no new finalizer and no new allocatable, return with an expr to the ancestor's one. */ - if ((!derived->f2k_derived || !derived->f2k_derived->finalizers) - && !finalizable_comp) + if (!expr_null_wrapper && !finalizable_comp + && (!derived->f2k_derived || !derived->f2k_derived->finalizers)) { + gcc_assert (ancestor_wrapper && ancestor_wrapper->ref == NULL + && ancestor_wrapper->expr_type == EXPR_VARIABLE); vtab_final->initializer = gfc_copy_expr (ancestor_wrapper); + vtab_final->ts.interface = vtab_final->initializer->symtree->n.sym; return; } @@ -1057,12 +1327,13 @@ generate_finalization_wrapper (gfc_symbol *derived, gfc_namespace *ns, 3. Call the ancestor's finalizer. */ /* Declare the wrapper function; it takes an assumed-rank array - as argument. */ + and a VALUE logical as arguments. */ /* Set up the namespace. */ sub_ns = gfc_get_namespace (ns, 0); sub_ns->sibling = ns->contained; - ns->contained = sub_ns; + if (!expr_null_wrapper) + ns->contained = sub_ns; sub_ns->resolved = 1; /* Set up the procedure symbol. */ @@ -1070,13 +1341,17 @@ generate_finalization_wrapper (gfc_symbol *derived, gfc_namespace *ns, gfc_get_symbol (name, sub_ns, &final); sub_ns->proc_name = final; final->attr.flavor = FL_PROCEDURE; - final->attr.subroutine = 1; - final->attr.pure = 1; + final->attr.function = 1; + final->attr.pure = 0; + final->result = final; + final->ts.type = BT_INTEGER; + final->ts.kind = 4; final->attr.artificial = 1; - final->attr.if_source = IFSRC_DECL; + final->attr.if_source = expr_null_wrapper ? IFSRC_IFBODY : IFSRC_DECL; if (ns->proc_name->attr.flavor == FL_MODULE) final->module = ns->proc_name->name; gfc_set_sym_referenced (final); + gfc_commit_symbol (final); /* Set up formal argument. */ gfc_get_symbol ("array", sub_ns, &array); @@ -1096,6 +1371,50 @@ generate_finalization_wrapper (gfc_symbol *derived, gfc_namespace *ns, final->formal->sym = array; gfc_commit_symbol (array); + /* Set up formal argument. */ + gfc_get_symbol ("stride", sub_ns, &stride); + stride->ts.type = BT_INTEGER; + stride->ts.kind = gfc_index_integer_kind; + stride->attr.flavor = FL_VARIABLE; + stride->attr.dummy = 1; + stride->attr.value = 1; + stride->attr.artificial = 1; + gfc_set_sym_referenced (stride); + final->formal->next = gfc_get_formal_arglist (); + final->formal->next->sym = stride; + gfc_commit_symbol (stride); + + /* Set up formal argument. */ + gfc_get_symbol ("fini_coarray", sub_ns, &fini_coarray); + fini_coarray->ts.type = BT_LOGICAL; + fini_coarray->ts.kind = 4; + fini_coarray->attr.flavor = FL_VARIABLE; + fini_coarray->attr.dummy = 1; + fini_coarray->attr.value = 1; + fini_coarray->attr.artificial = 1; + gfc_set_sym_referenced (fini_coarray); + final->formal->next->next = gfc_get_formal_arglist (); + final->formal->next->next->sym = fini_coarray; + gfc_commit_symbol (fini_coarray); + + /* Return with a NULL() expression but with an interface which has + the formal arguments. */ + if (expr_null_wrapper) + { + vtab_final->initializer = gfc_get_null_expr (NULL); + vtab_final->ts.interface = final; + return; + } + + + /* Set return value to 0. */ + last_code = XCNEW (gfc_code); + last_code->op = EXEC_ASSIGN; + last_code->loc = gfc_current_locus; + last_code->expr1 = gfc_lval_expr_from_sym (final); + last_code->expr2 = gfc_get_int_expr (4, NULL, 0); + sub_ns->code = last_code; + /* Obtain the size (number of elements) of "array" MINUS ONE, which is used in the scalarization. */ gfc_get_symbol ("nelem", sub_ns, &nelem); @@ -1107,7 +1426,8 @@ generate_finalization_wrapper (gfc_symbol *derived, gfc_namespace *ns, gfc_commit_symbol (nelem); /* Generate: nelem = SIZE (array) - 1. */ - last_code = XCNEW (gfc_code); + last_code->next = XCNEW (gfc_code); + last_code = last_code->next; last_code->op = EXEC_ASSIGN; last_code->loc = gfc_current_locus; @@ -1126,6 +1446,7 @@ generate_finalization_wrapper (gfc_symbol *derived, gfc_namespace *ns, = gfc_intrinsic_function_by_id (GFC_ISYM_SIZE); gfc_get_sym_tree ("size", sub_ns, &last_code->expr2->value.op.op1->symtree, false); + size_intr = last_code->expr2->value.op.op1->symtree; last_code->expr2->value.op.op1->symtree->n.sym->attr.flavor = FL_PROCEDURE; last_code->expr2->value.op.op1->symtree->n.sym->attr.intrinsic = 1; gfc_commit_symbol (last_code->expr2->value.op.op1->symtree->n.sym); @@ -1154,10 +1475,11 @@ generate_finalization_wrapper (gfc_symbol *derived, gfc_namespace *ns, select case (rank (array)) case (3) + ! If needed, the array is packed call final_rank3 (array) case default: do i = 0, size (array)-1 - addr = transfer (c_loc (array), addr) + i * STORAGE_SIZE (array) + addr = transfer (c_loc (array), addr) + i * stride call c_f_pointer (transfer (addr, cptr), ptr) call elemental_final (ptr) end do @@ -1168,6 +1490,23 @@ generate_finalization_wrapper (gfc_symbol *derived, gfc_namespace *ns, gfc_finalizer *fini, *fini_elem = NULL; gfc_code *block = NULL; + gfc_get_symbol ("idx", sub_ns, &idx); + idx->ts.type = BT_INTEGER; + idx->ts.kind = gfc_index_integer_kind; + idx->attr.flavor = FL_VARIABLE; + idx->attr.artificial = 1; + gfc_set_sym_referenced (idx); + gfc_commit_symbol (idx); + + gfc_get_symbol ("ptr", sub_ns, &ptr); + ptr->ts.type = BT_DERIVED; + ptr->ts.u.derived = derived; + ptr->attr.flavor = FL_VARIABLE; + ptr->attr.pointer = 1; + ptr->attr.artificial = 1; + gfc_set_sym_referenced (ptr); + gfc_commit_symbol (ptr); + /* SELECT CASE (RANK (array)). */ last_code->next = XCNEW (gfc_code); last_code = last_code->next; @@ -1221,14 +1560,20 @@ generate_finalization_wrapper (gfc_symbol *derived, gfc_namespace *ns, block->ext.block.case_list->high = block->ext.block.case_list->low; - /* CALL fini_rank (array). */ - block->next = XCNEW (gfc_code); - block->next->op = EXEC_CALL; - block->next->loc = gfc_current_locus; - block->next->symtree = fini->proc_tree; - block->next->resolved_sym = fini->proc_tree->n.sym; - block->next->ext.actual = gfc_get_actual_arglist (); - block->next->ext.actual->expr = gfc_lval_expr_from_sym (array); + /* CALL fini_rank (array) - possibly with packing. */ + if (fini->proc_tree->n.sym->formal->sym->attr.dimension) + finalizer_insert_packed_call (block, fini, array, stride, idx, ptr, + nelem, size_intr, sub_ns); + else + { + block->next = XCNEW (gfc_code); + block->next->op = EXEC_CALL; + block->next->loc = gfc_current_locus; + block->next->symtree = fini->proc_tree; + block->next->resolved_sym = fini->proc_tree->n.sym; + block->next->ext.actual = gfc_get_actual_arglist (); + block->next->ext.actual->expr = gfc_lval_expr_from_sym (array); + } } /* Elemental call - scalarized. */ @@ -1251,23 +1596,6 @@ generate_finalization_wrapper (gfc_symbol *derived, gfc_namespace *ns, block->op = EXEC_SELECT; block->ext.block.case_list = gfc_get_case (); - gfc_get_symbol ("idx", sub_ns, &idx); - idx->ts.type = BT_INTEGER; - idx->ts.kind = gfc_index_integer_kind; - idx->attr.flavor = FL_VARIABLE; - idx->attr.artificial = 1; - gfc_set_sym_referenced (idx); - gfc_commit_symbol (idx); - - gfc_get_symbol ("ptr", sub_ns, &ptr); - ptr->ts.type = BT_DERIVED; - ptr->ts.u.derived = derived; - ptr->attr.flavor = FL_VARIABLE; - ptr->attr.pointer = 1; - ptr->attr.artificial = 1; - gfc_set_sym_referenced (ptr); - gfc_commit_symbol (ptr); - /* Create loop. */ iter = gfc_get_iterator (); iter->var = gfc_lval_expr_from_sym (idx); @@ -1284,8 +1612,11 @@ generate_finalization_wrapper (gfc_symbol *derived, gfc_namespace *ns, /* Create code for CALL C_F_POINTER (TRANSFER (TRANSFER (C_LOC (array, cptr), c_intptr) - + idx * STORAGE_SIZE (array), c_ptr), ptr). */ - block->block->next = finalization_scalarizer (idx, array, ptr, sub_ns); + + idx * stride, c_ptr), ptr). */ + block->block->next + = finalization_scalarizer (idx, array, ptr, + gfc_lval_expr_from_sym (stride), + sub_ns); block = block->block->next; /* CALL final_elemental (array). */ @@ -1356,8 +1687,11 @@ generate_finalization_wrapper (gfc_symbol *derived, gfc_namespace *ns, /* Create code for CALL C_F_POINTER (TRANSFER (TRANSFER (C_LOC (array, cptr), c_intptr) - + idx * STORAGE_SIZE (array), c_ptr), ptr). */ - last_code->block->next = finalization_scalarizer (idx, array, ptr, sub_ns); + + idx * stride, c_ptr), ptr). */ + last_code->block->next + = finalization_scalarizer (idx, array, ptr, + gfc_lval_expr_from_sym (stride), + sub_ns); block = last_code->block->next; for (comp = derived->components; comp; comp = comp->next) @@ -1367,7 +1701,7 @@ generate_finalization_wrapper (gfc_symbol *derived, gfc_namespace *ns, continue; finalize_component (gfc_lval_expr_from_sym (ptr), derived, comp, - gfc_lval_expr_from_sym (stat), &block); + stat, fini_coarray, &block); if (!last_code->block->next) last_code->block->next = block; } @@ -1386,9 +1720,13 @@ generate_finalization_wrapper (gfc_symbol *derived, gfc_namespace *ns, last_code->ext.actual = gfc_get_actual_arglist (); last_code->ext.actual->expr = gfc_lval_expr_from_sym (array); + last_code->ext.actual->next = gfc_get_actual_arglist (); + last_code->ext.actual->next->expr = gfc_lval_expr_from_sym (stride); + last_code->ext.actual->next->next = gfc_get_actual_arglist (); + last_code->ext.actual->next->next->expr + = gfc_lval_expr_from_sym (fini_coarray); } - gfc_commit_symbol (final); vtab_final->initializer = gfc_lval_expr_from_sym (final); vtab_final->ts.interface = final; } @@ -1419,10 +1757,10 @@ add_procs_to_declared_vtab (gfc_symbol *derived, gfc_symbol *vtype) } -/* Find (or generate) the symbol for a derived type's vtab. */ +/* Find or generate the symbol for a derived type's vtab. */ -gfc_symbol * -gfc_find_derived_vtab (gfc_symbol *derived) +static gfc_symbol * +find_derived_vtab (gfc_symbol *derived, bool generate) { gfc_namespace *ns; gfc_symbol *vtab = NULL, *vtype = NULL, *found_sym = NULL, *def_init = NULL; @@ -1440,7 +1778,7 @@ gfc_find_derived_vtab (gfc_symbol *derived) if (ns) { char name[GFC_MAX_SYMBOL_LEN+1], tname[GFC_MAX_SYMBOL_LEN+1]; - + get_unique_hashed_string (tname, derived); sprintf (name, "__vtab_%s", tname); @@ -1451,6 +1789,9 @@ gfc_find_derived_vtab (gfc_symbol *derived) if (vtab == NULL) gfc_find_symbol (name, derived->ns, 0, &vtab); + if (!generate && !vtab) + return NULL; + if (vtab == NULL) { gfc_get_symbol (name, ns, &vtab); @@ -1464,7 +1805,7 @@ gfc_find_derived_vtab (gfc_symbol *derived) vtab->attr.access = ACCESS_PUBLIC; gfc_set_sym_referenced (vtab); sprintf (name, "__vtype_%s", tname); - + gfc_find_symbol (name, ns, 0, &vtype); if (vtype == NULL) { @@ -1509,7 +1850,7 @@ gfc_find_derived_vtab (gfc_symbol *derived) parent = gfc_get_derived_super_type (derived); if (parent) { - parent_vtab = gfc_find_derived_vtab (parent); + parent_vtab = gfc_get_derived_vtab (parent); c->ts.type = BT_DERIVED; c->ts.u.derived = parent_vtab->ts.u.derived; c->initializer = gfc_get_expr (); @@ -1675,6 +2016,20 @@ cleanup: } +gfc_symbol * +gfc_find_derived_vtab (gfc_symbol *derived) +{ + return find_derived_vtab (derived, false); +} + + +gfc_symbol * +gfc_get_derived_vtab (gfc_symbol *derived) +{ + return find_derived_vtab (derived, true); +} + + /* General worker function to find either a type-bound procedure or a type-bound user operator. */ diff --git a/gcc/fortran/expr.c b/gcc/fortran/expr.c index 211f304..32e8c49 100644 --- a/gcc/fortran/expr.c +++ b/gcc/fortran/expr.c @@ -3571,7 +3571,7 @@ gfc_check_pointer_assign (gfc_expr *lvalue, gfc_expr *rvalue) if (lvalue->ts.type == BT_CLASS && rvalue->ts.type == BT_DERIVED) /* Make sure the vtab is present. */ - gfc_find_derived_vtab (rvalue->ts.u.derived); + gfc_get_derived_vtab (rvalue->ts.u.derived); /* Check rank remapping. */ if (rank_remap) diff --git a/gcc/fortran/gfortran.h b/gcc/fortran/gfortran.h index fabc16a..00f5055 100644 --- a/gcc/fortran/gfortran.h +++ b/gcc/fortran/gfortran.h @@ -2956,6 +2956,7 @@ unsigned int gfc_hash_value (gfc_symbol *); gfc_try gfc_build_class_symbol (gfc_typespec *, symbol_attribute *, gfc_array_spec **, bool); gfc_symbol *gfc_find_derived_vtab (gfc_symbol *); +gfc_symbol *gfc_get_derived_vtab (gfc_symbol *); gfc_symtree* gfc_find_typebound_proc (gfc_symbol*, gfc_try*, const char*, bool, locus*); gfc_symtree* gfc_find_typebound_user_op (gfc_symbol*, gfc_try*, diff --git a/gcc/fortran/interface.c b/gcc/fortran/interface.c index d90fc73..d2a4ec9 100644 --- a/gcc/fortran/interface.c +++ b/gcc/fortran/interface.c @@ -1847,7 +1847,7 @@ compare_parameter (gfc_symbol *formal, gfc_expr *actual, if (formal->ts.type == BT_CLASS && actual->ts.type == BT_DERIVED) /* Make sure the vtab symbol is present when the module variables are generated. */ - gfc_find_derived_vtab (actual->ts.u.derived); + gfc_get_derived_vtab (actual->ts.u.derived); if (actual->ts.type == BT_PROCEDURE) { diff --git a/gcc/fortran/iresolve.c b/gcc/fortran/iresolve.c index 3f981d8..83a896a 100644 --- a/gcc/fortran/iresolve.c +++ b/gcc/fortran/iresolve.c @@ -945,7 +945,7 @@ gfc_resolve_extends_type_of (gfc_expr *f, gfc_expr *a, gfc_expr *mo) gfc_add_vptr_component (a); else if (a->ts.type == BT_DERIVED) { - vtab = gfc_find_derived_vtab (a->ts.u.derived); + vtab = gfc_get_derived_vtab (a->ts.u.derived); /* Clear the old expr. */ gfc_free_ref_list (a->ref); memset (a, '\0', sizeof (gfc_expr)); @@ -961,7 +961,7 @@ gfc_resolve_extends_type_of (gfc_expr *f, gfc_expr *a, gfc_expr *mo) gfc_add_vptr_component (mo); else if (mo->ts.type == BT_DERIVED) { - vtab = gfc_find_derived_vtab (mo->ts.u.derived); + vtab = gfc_get_derived_vtab (mo->ts.u.derived); /* Clear the old expr. */ gfc_free_ref_list (mo->ref); memset (mo, '\0', sizeof (gfc_expr)); diff --git a/gcc/fortran/resolve.c b/gcc/fortran/resolve.c index f3d3beb..dfa5066 100644 --- a/gcc/fortran/resolve.c +++ b/gcc/fortran/resolve.c @@ -6214,7 +6214,7 @@ resolve_typebound_function (gfc_expr* e) declared = ts.u.derived; c = gfc_find_component (declared, "_vptr", true, true); if (c->ts.u.derived == NULL) - c->ts.u.derived = gfc_find_derived_vtab (declared); + c->ts.u.derived = gfc_get_derived_vtab (declared); if (resolve_compcall (e, &name) == FAILURE) return FAILURE; @@ -6342,7 +6342,7 @@ resolve_typebound_subroutine (gfc_code *code) declared = expr->ts.u.derived; c = gfc_find_component (declared, "_vptr", true, true); if (c->ts.u.derived == NULL) - c->ts.u.derived = gfc_find_derived_vtab (declared); + c->ts.u.derived = gfc_get_derived_vtab (declared); if (resolve_typebound_call (code, &name) == FAILURE) return FAILURE; @@ -7369,7 +7369,7 @@ resolve_allocate_expr (gfc_expr *e, gfc_code *code) ts = code->expr3->ts; else if (code->ext.alloc.ts.type == BT_DERIVED) ts = code->ext.alloc.ts; - gfc_find_derived_vtab (ts.u.derived); + gfc_get_derived_vtab (ts.u.derived); if (dimension) e = gfc_expr_to_initialize (e); } @@ -8567,7 +8567,7 @@ resolve_select_type (gfc_code *code, gfc_namespace *old_ns) new_st->expr1->value.function.actual->expr = gfc_get_variable_expr (code->expr1->symtree); new_st->expr1->value.function.actual->expr->where = code->loc; gfc_add_vptr_component (new_st->expr1->value.function.actual->expr); - vtab = gfc_find_derived_vtab (body->ext.block.case_list->ts.u.derived); + vtab = gfc_get_derived_vtab (body->ext.block.case_list->ts.u.derived); st = gfc_find_symtree (vtab->ns->sym_root, vtab->name); new_st->expr1->value.function.actual->next = gfc_get_actual_arglist (); new_st->expr1->value.function.actual->next->expr = gfc_get_variable_expr (st); @@ -11290,7 +11290,7 @@ error: gfc_error ("Finalization at %L is not yet implemented", &derived->declared_at); - gfc_find_derived_vtab (derived); + gfc_get_derived_vtab (derived); return result; } @@ -11850,7 +11850,7 @@ resolve_typebound_procedures (gfc_symbol* derived) resolve_bindings_result = SUCCESS; /* Make sure the vtab has been generated. */ - gfc_find_derived_vtab (derived); + gfc_get_derived_vtab (derived); if (derived->f2k_derived->tb_sym_root) gfc_traverse_symtree (derived->f2k_derived->tb_sym_root, @@ -12405,7 +12405,7 @@ resolve_fl_derived (gfc_symbol *sym) gfc_component *vptr = gfc_find_component (sym, "_vptr", true, true); if (vptr->ts.u.derived == NULL) { - gfc_symbol *vtab = gfc_find_derived_vtab (data->ts.u.derived); + gfc_symbol *vtab = gfc_get_derived_vtab (data->ts.u.derived); gcc_assert (vtab); vptr->ts.u.derived = vtab->ts.u.derived; } @@ -12618,6 +12618,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-decl.c b/gcc/fortran/trans-decl.c index 3bee178..84cdfa0 100644 --- a/gcc/fortran/trans-decl.c +++ b/gcc/fortran/trans-decl.c @@ -1206,7 +1206,7 @@ gfc_get_symbol_decl (gfc_symbol * sym) gfc_component *c = CLASS_DATA (sym); if (!c->ts.u.derived->backend_decl) { - gfc_find_derived_vtab (c->ts.u.derived); + gfc_get_derived_vtab (c->ts.u.derived); gfc_get_derived_type (sym->ts.u.derived); } } diff --git a/gcc/fortran/trans-expr.c b/gcc/fortran/trans-expr.c index d6410d3..3188ee5 100644 --- a/gcc/fortran/trans-expr.c +++ b/gcc/fortran/trans-expr.c @@ -263,7 +263,7 @@ gfc_conv_derived_to_class (gfc_se *parmse, gfc_expr *e, { /* In this case the vtab corresponds to the derived type and the vptr must point to it. */ - vtab = gfc_find_derived_vtab (e->ts.u.derived); + vtab = gfc_get_derived_vtab (e->ts.u.derived); gcc_assert (vtab); tmp = gfc_build_addr_expr (NULL_TREE, gfc_get_symbol_decl (vtab)); } @@ -859,9 +859,9 @@ gfc_trans_class_assign (gfc_expr *expr1, gfc_expr *expr2, gfc_exec_op op) gfc_add_vptr_component (lhs); if (expr2->ts.type == BT_DERIVED) - vtab = gfc_find_derived_vtab (expr2->ts.u.derived); + vtab = gfc_get_derived_vtab (expr2->ts.u.derived); else if (expr2->expr_type == EXPR_NULL) - vtab = gfc_find_derived_vtab (expr1->ts.u.derived); + vtab = gfc_get_derived_vtab (expr1->ts.u.derived); gcc_assert (vtab); rhs = gfc_get_expr (); diff --git a/gcc/fortran/trans-intrinsic.c b/gcc/fortran/trans-intrinsic.c index e9eb307..3bb6eb3 100644 --- a/gcc/fortran/trans-intrinsic.c +++ b/gcc/fortran/trans-intrinsic.c @@ -7356,7 +7356,7 @@ conv_intrinsic_move_alloc (gfc_code *code) else { gfc_symbol *vtab; - vtab = gfc_find_derived_vtab (from_expr->ts.u.derived); + vtab = gfc_get_derived_vtab (from_expr->ts.u.derived); gcc_assert (vtab); tmp = gfc_build_addr_expr (NULL_TREE, gfc_get_symbol_decl (vtab)); } @@ -7387,7 +7387,7 @@ conv_intrinsic_move_alloc (gfc_code *code) else { gfc_symbol *vtab; - vtab = gfc_find_derived_vtab (from_expr->ts.u.derived); + vtab = gfc_get_derived_vtab (from_expr->ts.u.derived); gcc_assert (vtab); tmp = gfc_build_addr_expr (NULL_TREE, gfc_get_symbol_decl (vtab)); } diff --git a/gcc/fortran/trans-stmt.c b/gcc/fortran/trans-stmt.c index bdc559b..01431a9 100644 --- a/gcc/fortran/trans-stmt.c +++ b/gcc/fortran/trans-stmt.c @@ -5099,7 +5099,7 @@ gfc_trans_allocate (gfc_code * code) if (ts->type == BT_DERIVED) { - vtab = gfc_find_derived_vtab (ts->u.derived); + vtab = gfc_get_derived_vtab (ts->u.derived); gcc_assert (vtab); gfc_init_se (&lse, NULL); lse.want_pointer = 1; @@ -5186,7 +5186,7 @@ gfc_trans_allocate (gfc_code * code) } else ppc = gfc_lval_expr_from_sym - (gfc_find_derived_vtab (rhs->ts.u.derived)); + (gfc_get_derived_vtab (rhs->ts.u.derived)); gfc_add_component_ref (ppc, "_copy"); ppc_code = gfc_get_code (); @@ -5393,7 +5393,7 @@ gfc_trans_deallocate (gfc_code *code) { /* Reset _vptr component to declared type. */ gfc_expr *rhs, *lhs = gfc_copy_expr (al->expr); - gfc_symbol *vtab = gfc_find_derived_vtab (al->expr->ts.u.derived); + gfc_symbol *vtab = gfc_get_derived_vtab (al->expr->ts.u.derived); gfc_add_vptr_component (lhs); rhs = gfc_lval_expr_from_sym (vtab); tmp = gfc_trans_pointer_assignment (lhs, rhs);