From patchwork Tue Apr 14 17:00:54 2015 Content-Type: text/plain; charset="utf-8" MIME-Version: 1.0 Content-Transfer-Encoding: 8bit X-Patchwork-Submitter: Andre Vehreschild X-Patchwork-Id: 461203 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.2 with cipher ECDHE-RSA-AES256-GCM-SHA384 (256/256 bits)) (No client certificate requested) by ozlabs.org (Postfix) with ESMTPS id 0BCA114011B for ; Wed, 15 Apr 2015 03:01:28 +1000 (AEST) Authentication-Results: ozlabs.org; dkim=pass reason="1024-bit key; unprotected key" header.d=gcc.gnu.org header.i=@gcc.gnu.org header.b=dH/aBhwQ; dkim-adsp=none (unprotected policy); dkim-atps=neutral DomainKey-Signature: a=rsa-sha1; c=nofws; d=gcc.gnu.org; h=list-id :list-unsubscribe:list-archive:list-post:list-help:sender:date :from:to:cc:subject:message-id:in-reply-to:references :mime-version:content-type; q=dns; s=default; b=Ar6opbafgjNGXn+q 55ugiuh9a7qEKvulWctTh36WH9OqpqcjHV79Y7feaQ5GgqinRGwOF5SUJ/KIZ8BR oLluTKN3BE3pHvodbkUKvccSOhjH4WW7G3ZOz5TpJQTIHzGdgvPDzQSdoBMCM4BE HjvtZscNK0THuxNV8YTQHzKJdRk= 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:date :from:to:cc:subject:message-id:in-reply-to:references :mime-version:content-type; s=default; bh=ap+Bsq4VdGjbgFzeWdO2lI r7LF8=; b=dH/aBhwQ+nJWKto3jXeLwvTAuud/v5IZsJg4nRdt7oaD5pFfLMlUX0 teza1OKQbqMpuxqbrWorXf9NwwvRUiLYYBPhcJjaWRASAySmzHN5wWjNZ80oUALj ZJf2p755ebBke2VbaQcvNzeGMJ+DysuIOISor6g250NMSQV24dd6M= Received: (qmail 130236 invoked by alias); 14 Apr 2015 17:01:16 -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 130213 invoked by uid 89); 14 Apr 2015 17:01:15 -0000 Authentication-Results: sourceware.org; auth=none X-Virus-Found: No X-Spam-SWARE-Status: No, score=-0.4 required=5.0 tests=AWL, BAYES_50, FREEMAIL_FROM, RCVD_IN_DNSWL_NONE, SPF_PASS autolearn=ham version=3.3.2 X-Spam-User: qpsmtpd, 2 recipients X-HELO: mout.gmx.net Received: from mout.gmx.net (HELO mout.gmx.net) (212.227.17.21) by sourceware.org (qpsmtpd/0.93/v0.84-503-g423c35a) with (AES256-GCM-SHA384 encrypted) ESMTPS; Tue, 14 Apr 2015 17:01:05 +0000 Received: from localhost ([88.75.104.20]) by mail.gmx.com (mrgmx103) with ESMTPSA (Nemesis) id 0LcSWg-1Z852E1UkI-00jt65; Tue, 14 Apr 2015 19:00:57 +0200 Date: Tue, 14 Apr 2015 19:00:54 +0200 From: Andre Vehreschild To: Paul Richard Thomas Cc: Mikael Morin , GCC-Fortran-ML , GCC-Patches-ML , Antony Lewis , Dominique Dhumieres Subject: Re: [Patch, Fortran, pr60322, addendum] was: [Patch 1/2, Fortran, pr60322] [OOP] Incorrect bounds on polymorphic dummy array Message-ID: <20150414190054.473a9bbb@gmx.de> In-Reply-To: <20150409143709.6d33aa8c@vepi2> References: <20150226181717.480e282c@vepi2> <551006FF.1080704@sfr.fr> <20150323134357.6af740d1@vepi2> <20150324180620.3c72960e@vepi2> <20150409143709.6d33aa8c@vepi2> MIME-Version: 1.0 X-UI-Out-Filterresults: notjunk:1; Hi all, during further testing of a big Fortran software I encounter two bugs with class arrays, that are somehow connected to pr60322. I therefore propose an extended patch for pr60322. Because Paul has already reviewed most the extended patch, I give you two patches: 1. a full patch, fixing all the issues connected to pr60322, and 2. a delta patch to get from the reviewed patch to the latest version. With the second patch I hope to get a faster review, because it is significantly shorter. Now what was the issue? To be precise there were two issues: i. a pointer to a class array (CLASS_DATA(sym).attr.class_pointer == 1) was dereferenced, which lead to an ICE (the patch for this in the delta is chunk 5 in gfc_conv_expr_descriptor, and ii. (and this was a severe brain cracker) in chains of references consisting of more then one class-(array)-ref always the _vptr of the first symbol was taken and not the _vptr of the currently dereferenced class object. This occurred when fortran code similiar to this was executed: type innerT integer, allocatable :: arr(:) end type type T class(innerT) :: mat(:,:) end type class(T) :: o allocate(o%mat(2,2)) allocate(o%mat(:,:)%arr(10)) ! This is obviously pseudo code, ! but I think you get what is meant. o%mat(1,1)%arr(1) = 1 In the last line the address to get to arr(1) was computed using the _vptr->size of o and not of o%mat(1,1). To fix this gfc_component_ref () now computes the class' _vptr-ref whenever it does a _data-ref (chunk 1 of trans-expr.c in the delta patch). The _vptr-ref is stored in gfc_se, where I added the new member class_vptr. The gfc_se->class_vptr is then used in array-refs (chunk 2 of trans.c) to get the size of the array elements of the correct level. The other chunks of the delta patch are: - parameter passing fixes, and - documentation fixes as requested for the version 5 of the pr60322 patch. I hope this helps in getting the patch reviewed quickly. Bootstraps and regtests ok on x86_64-linux-gnu/F21. Ok for trunk -> 6.0? Ok, for backport to 5.2, once available? Note, the patches may apply with shifts, as I forgot to update before taking the diffs. Regards, Andre On Thu, 9 Apr 2015 14:37:09 +0200 Andre Vehreschild wrote: > Hi Paul, hi all, > > Paul, thanks for the review. Answers to your questions are inline below: > > On Sun, 5 Apr 2015 11:13:05 +0200 > Paul Richard Thomas wrote: > > > + /* The dummy is returned for pointer, allocatable or assumed rank arrays. > > + The check for pointerness needs to be repeated here (it is done in > > + IS_CLASS_ARRAY (), too), because for class arrays that are pointers, > > as > > + is the one of the sym, which is incorrect here. */ > > > > What does this mean, please? > > The first sentence is about regular arrays and should be unchanged from the > original source. Then I have to check for class (arrays) that are pointers, > i.e., independent of whether the sym is a class array or a regular pointer to > a class object. (The latter shouldn't make it into the routine anyway.) > IS_CLASS_ARRAY () returns false for too many reasons to be of use here. I have > to apologize and confess that the comment was a mere note to myself to not > return to use is_classarray in the if below. Let me rephrase the comment to > be: > > /* The dummy is returned for pointer, allocatable or assumed rank arrays. > For class arrays the information if sym is an allocatable or pointer > object needs to be checked explicitly (IS_CLASS_ARRAY can be false for > too many reasons to be of use here). */ > > > + /* Returning the descriptor for dummy class arrays is hazardous, > > because > > + some caller is expecting an expression to apply the component refs to. > > + Therefore the descriptor is only created and stored in > > + sym->backend_decl's GFC_DECL_SAVED_DESCRIPTOR. The caller is then > > + responsible to extract it from there, when the descriptor is > > + desired. */ > > + if (IS_CLASS_ARRAY (sym) > > + && (!DECL_LANG_SPECIFIC (sym->backend_decl) > > + || !GFC_DECL_SAVED_DESCRIPTOR (sym->backend_decl))) > > + { > > + decl = gfc_build_dummy_array_decl (sym, sym->backend_decl); > > + /* Prevent the dummy from being detected as unused if it is copied. > > */ > > + if (sym->backend_decl != NULL && decl != sym->backend_decl) > > + DECL_ARTIFICIAL (sym->backend_decl) = 1; > > + sym->backend_decl = decl; > > + } > > > > The comments, such as the above are often going well beyond column 72, > > into the 80's. I know that much of the existing code violates this > > style requirement but there is no need to do so if clarity is not > > reduced thereby. > > Er, the document at > > https://gcc.gnu.org/codingconventions.html#C_Formatting > > says that line length is 80, or is there another convention, that I am not > aware of? > > > In trans-stmt.c s/standart/standard/ > > Fixed. > > > Don't forget to put the PR numbers in the ChangeLogs. > > I won't anymore, already got told off :-) > > > For this submission, I would have appreciated some a description of > > what each chunk in the patch is doing, just because there is so much > > of it. I suppose that it was good for my imortal soul to sort it out > > for myself but it took a little while :-) > > I initially tried to split the submission in two parts to make it more > manageable. One part with the brain-dead substitutions of as and array_attr > and one with the new code. Albeit I failed to get the brain-dead part right > and made some mistakes there already, which Mikael pointed out. I therefore > went for the big submission. > > Now doing a description of what each "chunk" does is quite tedious. I really > would like to spend my time more productive. Would you be satisfied, when I > write a story about the patch, referring to some parts more explicitly, like > > "Chunk 4 of file trans-stmt.c is the heart of the patch and does this and > that. The remaining chunks are more or less putting the data together." > > (This is not correct for this patch of course. Just an example.) More > elaborate of course, but just to give an idea. > > Thanks again. I will commit as soon as 5.2/6.0 commit window is open. > > Regards, > Andre > > > > > Cheers and many thanks for the patch. > > > > Paul > > > > On 27 March 2015 at 13:48, Paul Richard Thomas > > wrote: > > > Dear Andre, > > > > > > I am in the UK as of last night. Before leaving, I bootstrapped and > > > regtested your patch and all was well. I must drive to Cambridge this > > > afternoon to see my mother and will try to get to it either this > > > evening or tomorrow morning. There is so much of it and it touches > > > many places; so I must give it a very careful looking over before > > > giving the green light. Bear with me please. > > > > > > Great work though! > > > > > > Paul > > > > > > On 24 March 2015 at 18:06, Andre Vehreschild wrote: > > >> Hi all, > > >> > > >> I have worked on the comments Mikael gave me. I am now checking for > > >> class_pointer in the way he pointed out. > > >> > > >> Furthermore did I *join the two parts* of the patch into this one, > > >> because keeping both in sync was no benefit but only tedious and did not > > >> prove to be reviewed faster. > > >> > > >> Paul, Dominique: I have addressed the LOC issue that came up lately. Or > > >> rather the patch addressed it already. I feel like this is not tested > > >> very well, not the loc() call nor the sizeof() call as given in the 57305 > > >> second's download. Unfortunately, is that download not runable. I would > > >> love to see a test similar to that download, but couldn't come up with > > >> one, that satisfied me. Given that the patch's review will last some > > >> days, I still have enough time to come up with something beautiful which > > >> I will add then. > > >> > > >> Bootstraps and regtests ok on x86_64-linux-gnu/F20. > > >> > > >> Regards, > > >> Andre > > >> > > >> > > >> On Tue, 24 Mar 2015 11:13:27 +0100 > > >> Paul Richard Thomas wrote: > > >> > > >>> Dear Andre, > > >>> > > >>> Dominique pointed out to me that the 'loc' patch causes a ICE in the > > >>> testsuite. It seems that 'loc' should provide the address of the class > > >>> container in some places and the address of the data in others. I will > > >>> put my thinking cap on tonight :-) > > >>> > > >>> Cheers > > >>> > > >>> Paul > > >>> > > >>> On 23 March 2015 at 13:43, Andre Vehreschild wrote: > > >>> > Hi Mikael, > > >>> > > > >>> > thanks for looking at the patch. Please note, that Paul has sent an > > >>> > addendum to the patches for 60322, which I deliberately have attached. > > >>> > > > >>> >> 26/02/2015 18:17, Andre Vehreschild a écrit : > > >>> >> > This first patch is only preparatory and does not change any of the > > >>> >> > semantics of gfortran at all. > > >>> >> Sure? > > >>> > > > >>> > With the counterexample you found below, this of course is a wrong > > >>> > statement. > > >>> > > > >>> >> > diff --git a/gcc/fortran/expr.c b/gcc/fortran/expr.c > > >>> >> > index ab6f7a5..d28cf77 100644 > > >>> >> > --- a/gcc/fortran/expr.c > > >>> >> > +++ b/gcc/fortran/expr.c > > >>> >> > @@ -4059,10 +4060,10 @@ gfc_lval_expr_from_sym (gfc_symbol *sym) > > >>> >> > lval->symtree = gfc_find_symtree (sym->ns->sym_root, sym->name); > > >>> >> > > > >>> >> > /* It will always be a full array. */ > > >>> >> > - lval->rank = sym->as ? sym->as->rank : 0; > > >>> >> > + as = sym->as; > > >>> >> > + lval->rank = as ? as->rank : 0; > > >>> >> > if (lval->rank) > > >>> >> > - gfc_add_full_array_ref (lval, sym->ts.type == BT_CLASS ? > > >>> >> > - CLASS_DATA (sym)->as : sym->as); > > >>> >> > + gfc_add_full_array_ref (lval, as); > > >>> >> > > >>> >> This is a change of semantics. Or do you know that sym->ts.type != > > >>> >> BT_CLASS? > > >>> > > > >>> > You are completely right. I have made a mistake here. I have to tell > > >>> > the truth, I never ran a regtest with only part 1 of the patches > > >>> > applied. The second part of the patch will correct this, by setting > > >>> > the variable as depending on whether type == BT_CLASS or not. Sorry > > >>> > for the mistake. > > >>> > > > >>> >> > diff --git a/gcc/fortran/trans-decl.c b/gcc/fortran/trans-decl.c > > >>> >> > index 3664824..e571a17 100644 > > >>> >> > --- a/gcc/fortran/trans-decl.c > > >>> >> > +++ b/gcc/fortran/trans-decl.c > > >>> >> > @@ -1013,16 +1017,24 @@ gfc_build_dummy_array_decl (gfc_symbol * > > >>> >> > sym, tree dummy) tree decl; > > >>> >> > tree type; > > >>> >> > gfc_array_spec *as; > > >>> >> > + symbol_attribute *array_attr; > > >>> >> > char *name; > > >>> >> > gfc_packed packed; > > >>> >> > int n; > > >>> >> > bool known_size; > > >>> >> > > > >>> >> > - if (sym->attr.pointer || sym->attr.allocatable > > >>> >> > - || (sym->as && sym->as->type == AS_ASSUMED_RANK)) > > >>> >> > + /* Use the array as and attr. */ > > >>> >> > + as = sym->as; > > >>> >> > + array_attr = &sym->attr; > > >>> >> > + > > >>> >> > + /* The pointer attribute is always set on a _data component, > > >>> >> > therefore check > > >>> >> > + the sym's attribute only. */ > > >>> >> > + if (sym->attr.pointer || array_attr->allocatable > > >>> >> > + || (as && as->type == AS_ASSUMED_RANK)) > > >>> >> > return dummy; > > >>> >> > > > >>> >> Any reason to sometimes use array_attr, sometimes not, like here? > > >>> >> By the way, the comment is misleading: for classes, there is the > > >>> >> class_pointer attribute (and it is a pain, I know). > > >>> > > > >>> > Yes, and a good one. Array_attr is sometimes sym->attr and sometimes > > >>> > CLASS_DATA(sym)->attr aka sym->ts.u.derived->components->attr. In the > > >>> > later case .pointer is always set to 1 in the _data component's attr. > > >>> > I.e., the above if, would always yield true for a class_array, which > > >>> > is not intended, but rather destructive. I know about the > > >>> > class_pointer attribute, but I figured, that it is not relevant here. > > >>> > Any idea how to formulate the comment better, to reflect what I just > > >>> > explained? > > >>> > > > >>> > Regards, > > >>> > Andre > > >>> > -- > > >>> > Andre Vehreschild * Email: vehre ad gmx dot de > > >>> > > > >>> > > > >>> > ---------- Forwarded message ---------- > > >>> > From: Paul Richard Thomas > > >>> > To: Andre Vehreschild , Dominique Dhumieres > > >>> > Cc: > > >>> > Date: Sun, 22 Mar 2015 21:20:20 +0100 > > >>> > Subject: Bug in intrinsic LOC for scalar class objects > > >>> > Dear Andre and Dominique, > > >>> > > > >>> > I have found that LOC is returning the address of the class container > > >>> > rather than the _data component for class scalars. See the source > > >>> > below, which you will recognise! A fix is attached. > > >>> > > > >>> > Note that the scalar allocate fails with MOLD= and so I substituted > > >>> > SOURCE=. > > >>> > > > >>> > Cheers > > >>> > > > >>> > Paul > > >>> > > > >>> > class(*), allocatable :: a(:), e ! Change 'e' to an array and > > >>> > second memcpy works correctly > > >>> > ! Problem is with loc(e), which > > >>> > returns the address of the > > >>> > ! class container. > > >>> > allocate (e, source = 99.0) > > >>> > allocate (a(2), source = [1.0, 2.0]) > > >>> > call add_element_poly (a,e) > > >>> > select type (a) > > >>> > type is (real) > > >>> > print *, a > > >>> > end select > > >>> > > > >>> > contains > > >>> > > > >>> > subroutine add_element_poly(a,e) > > >>> > use iso_c_binding > > >>> > class(*),allocatable,intent(inout),target :: a(:) > > >>> > class(*),intent(in),target :: e > > >>> > class(*),allocatable,target :: tmp(:) > > >>> > type(c_ptr) :: dummy > > >>> > > > >>> > interface > > >>> > function memcpy(dest,src,n) bind(C,name="memcpy") result(res) > > >>> > import > > >>> > type(c_ptr) :: res > > >>> > integer(c_intptr_t),value :: dest > > >>> > integer(c_intptr_t),value :: src > > >>> > integer(c_size_t),value :: n > > >>> > end function > > >>> > end interface > > >>> > > > >>> > if (.not.allocated(a)) then > > >>> > allocate(a(1), source=e) > > >>> > else > > >>> > allocate(tmp(size(a)),source=a) > > >>> > deallocate(a) > > >>> > allocate(a(size(tmp)+1),source=e) ! mold gives a segfault > > >>> > dummy = memcpy(loc(a(1)),loc(tmp),sizeof(tmp)) > > >>> > dummy = memcpy(loc(a(size(tmp)+1)),loc(e),sizeof(e)) > > >>> > end if > > >>> > end subroutine > > >>> > end > > >>> > > > >>> > > >>> > > >>> > > >> > > >> > > >> -- > > >> Andre Vehreschild * Email: vehre ad gmx dot de > > > > > > > > > > > > -- > > > Outside of a dog, a book is a man's best friend. Inside of a dog it's > > > too dark to read. > > > > > > Groucho Marx > > > > > > > > diff --git a/gcc/fortran/trans-array.c b/gcc/fortran/trans-array.c index 0804d45..3803cf8 100644 --- a/gcc/fortran/trans-array.c +++ b/gcc/fortran/trans-array.c @@ -3165,7 +3165,7 @@ add_to_offset (tree *cst_offset, tree *offset, tree t) static tree -build_array_ref (tree desc, tree offset, tree decl) +build_array_ref (tree desc, tree offset, tree decl, tree vptr) { tree tmp; tree type; @@ -3212,7 +3212,7 @@ build_array_ref (tree desc, tree offset, tree decl) tmp = gfc_conv_array_data (desc); tmp = build_fold_indirect_ref_loc (input_location, tmp); - tmp = gfc_build_array_ref (tmp, offset, decl); + tmp = gfc_build_array_ref (tmp, offset, decl, vptr); return tmp; } @@ -3375,7 +3375,8 @@ gfc_conv_array_ref (gfc_se * se, gfc_array_ref * ar, gfc_expr *expr, offset = fold_build2_loc (input_location, PLUS_EXPR, gfc_array_index_type, offset, cst_offset); - se->expr = build_array_ref (se->expr, offset, sym->backend_decl); + se->expr = build_array_ref (se->expr, offset, sym->ts.type == BT_CLASS ? + NULL_TREE : sym->backend_decl, se->class_vptr); } @@ -6270,7 +6271,7 @@ gfc_get_dataptr_offset (stmtblock_t *block, tree parm, tree desc, tree offset, return; } - tmp = build_array_ref (desc, offset, NULL); + tmp = build_array_ref (desc, offset, NULL, NULL); /* Offset the data pointer for pointer assignments from arrays with subreferences; e.g. my_integer => my_type(:)%integer_component. */ @@ -7029,6 +7030,8 @@ gfc_conv_expr_descriptor (gfc_se *se, gfc_expr *expr) pointer/allocatable or associated. */ if (onebased && se->use_offset && expr->symtree + && !(expr->symtree->n.sym && expr->symtree->n.sym->ts.type == BT_CLASS + && !CLASS_DATA (expr->symtree->n.sym)->attr.class_pointer) && !expr->symtree->n.sym->attr.allocatable && !expr->symtree->n.sym->attr.pointer && !expr->symtree->n.sym->attr.host_assoc diff --git a/gcc/fortran/trans-decl.c b/gcc/fortran/trans-decl.c index 895733b..4c18920 100644 --- a/gcc/fortran/trans-decl.c +++ b/gcc/fortran/trans-decl.c @@ -1031,9 +1031,9 @@ gfc_build_dummy_array_decl (gfc_symbol * sym, tree dummy) array_attr = is_classarray ? &CLASS_DATA (sym)->attr : &sym->attr; /* The dummy is returned for pointer, allocatable or assumed rank arrays. - The check for pointerness needs to be repeated here (it is done in - IS_CLASS_ARRAY (), too), because for class arrays that are pointers, as - is the one of the sym, which is incorrect here. */ + For class arrays the information if sym is an allocatable or pointer + object needs to be checked explicitly (IS_CLASS_ARRAY can be false for + too many reasons to be of use here). */ if ((sym->ts.type != BT_CLASS && sym->attr.pointer) || (sym->ts.type == BT_CLASS && CLASS_DATA (sym)->attr.class_pointer) || array_attr->allocatable diff --git a/gcc/fortran/trans-expr.c b/gcc/fortran/trans-expr.c index 790d537..81b72273 100644 --- a/gcc/fortran/trans-expr.c +++ b/gcc/fortran/trans-expr.c @@ -2273,6 +2273,16 @@ gfc_conv_component_ref (gfc_se * se, gfc_ref * ref) field = f2; } + if (ref->u.c.sym && ref->u.c.sym->ts.type == BT_CLASS + && strcmp ("_data", c->name) == 0) + { + /* Found a ref to the _data component. Store the associated ref to + the vptr in se->class_vptr. */ + se->class_vptr = gfc_class_vptr_get (decl); + } + else + se->class_vptr = NULL_TREE; + tmp = fold_build3_loc (input_location, COMPONENT_REF, TREE_TYPE (field), decl, field, NULL_TREE); diff --git a/gcc/fortran/trans.c b/gcc/fortran/trans.c index 394745e..6da464a 100644 --- a/gcc/fortran/trans.c +++ b/gcc/fortran/trans.c @@ -321,7 +321,7 @@ gfc_build_addr_expr (tree type, tree t) /* Build an ARRAY_REF with its natural type. */ tree -gfc_build_array_ref (tree base, tree offset, tree decl) +gfc_build_array_ref (tree base, tree offset, tree decl, tree vptr) { tree type = TREE_TYPE (base); tree tmp; @@ -353,37 +353,47 @@ gfc_build_array_ref (tree base, tree offset, tree decl) /* If the array reference is to a pointer, whose target contains a subreference, use the span that is stored with the backend decl and reference the element with pointer arithmetic. */ - if (decl && (TREE_CODE (decl) == FIELD_DECL - || TREE_CODE (decl) == VAR_DECL - || TREE_CODE (decl) == PARM_DECL) - && ((GFC_DECL_SUBREF_ARRAY_P (decl) - && !integer_zerop (GFC_DECL_SPAN(decl))) + if ((decl && (TREE_CODE (decl) == FIELD_DECL + || TREE_CODE (decl) == VAR_DECL + || TREE_CODE (decl) == PARM_DECL) + && ((GFC_DECL_SUBREF_ARRAY_P (decl) + && !integer_zerop (GFC_DECL_SPAN (decl))) || GFC_DECL_CLASS (decl))) + || vptr) { - if (GFC_DECL_CLASS (decl)) + if (decl) { - /* When a temporary is in place for the class array, then the original - class' declaration is stored in the saved descriptor. */ - if (DECL_LANG_SPECIFIC (decl) && GFC_DECL_SAVED_DESCRIPTOR (decl)) - decl = GFC_DECL_SAVED_DESCRIPTOR (decl); - else + if (GFC_DECL_CLASS (decl)) { - /* Allow for dummy arguments and other good things. */ - if (POINTER_TYPE_P (TREE_TYPE (decl))) - decl = build_fold_indirect_ref_loc (input_location, decl); - - /* Check if '_data' is an array descriptor. If it is not, - the array must be one of the components of the class object, - so return a normal array reference. */ - if (!GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (gfc_class_data_get (decl)))) - return build4_loc (input_location, ARRAY_REF, type, base, - offset, NULL_TREE, NULL_TREE); + /* When a temporary is in place for the class array, then the + original class' declaration is stored in the saved + descriptor. */ + if (DECL_LANG_SPECIFIC (decl) && GFC_DECL_SAVED_DESCRIPTOR (decl)) + decl = GFC_DECL_SAVED_DESCRIPTOR (decl); + else + { + /* Allow for dummy arguments and other good things. */ + if (POINTER_TYPE_P (TREE_TYPE (decl))) + decl = build_fold_indirect_ref_loc (input_location, decl); + + /* Check if '_data' is an array descriptor. If it is not, + the array must be one of the components of the class + object, so return a normal array reference. */ + if (!GFC_DESCRIPTOR_TYPE_P (TREE_TYPE ( + gfc_class_data_get (decl)))) + return build4_loc (input_location, ARRAY_REF, type, base, + offset, NULL_TREE, NULL_TREE); + } + + span = gfc_class_vtab_size_get (decl); } - - span = gfc_class_vtab_size_get (decl); + else if (GFC_DECL_SUBREF_ARRAY_P (decl)) + span = GFC_DECL_SPAN (decl); + else + gcc_unreachable (); } - else if (GFC_DECL_SUBREF_ARRAY_P (decl)) - span = GFC_DECL_SPAN(decl); + else if (vptr) + span = gfc_vptr_size_get (vptr); else gcc_unreachable (); diff --git a/gcc/fortran/trans.h b/gcc/fortran/trans.h index 1998358..e2a1fea 100644 --- a/gcc/fortran/trans.h +++ b/gcc/fortran/trans.h @@ -49,6 +49,10 @@ typedef struct gfc_se /* The length of a character string value. */ tree string_length; + /* When expr is a reference to a class object, store its vptr access + here. */ + tree class_vptr; + /* If set gfc_conv_variable will return an expression for the array descriptor. When set, want_pointer should also be set. If not set scalarizing variables will be substituted. */ @@ -528,7 +532,7 @@ tree gfc_get_function_decl (gfc_symbol *); tree gfc_build_addr_expr (tree, tree); /* Build an ARRAY_REF. */ -tree gfc_build_array_ref (tree, tree, tree); +tree gfc_build_array_ref (tree, tree, tree, tree vptr = NULL_TREE); /* Creates a label. Decl is artificial if label_id == NULL_TREE. */ tree gfc_build_label_decl (tree); diff --git a/gcc/testsuite/gfortran.dg/class_array_21.f03 b/gcc/testsuite/gfortran.dg/class_array_21.f03 new file mode 100644 index 0000000..1e89d38 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/class_array_21.f03 @@ -0,0 +1,97 @@ +! {dg-do run} +! +! Contributed by Andre Vehreschild +! Check more elaborate class array addressing. + +module m1 + + type InnerBaseT + integer, allocatable :: a(:) + end type InnerBaseT + + type, extends(InnerBaseT) :: InnerT + integer :: i + end type InnerT + + type BaseT + class(InnerT), allocatable :: arr(:,:) + contains + procedure P + end type BaseT + +contains + + subroutine indir(this, mat) + class(BaseT) :: this + class(InnerT), intent(inout) :: mat(:,:) + + call this%P(mat) + end subroutine indir + + subroutine P(this, mat) + class(BaseT) :: this + class(InnerT), intent(inout) :: mat(:,:) + integer :: i,j + + mat%i = 42 + do i= 1, ubound(mat, 1) + do j= 1, ubound(mat, 2) + if (.not. allocated(mat(i,j)%a)) then + allocate(mat(i,j)%a(10), source = 72) + end if + end do + end do + mat(1,1)%i = 9 + mat(1,1)%a(5) = 1 + end subroutine + +end module m1 + +program test + use m1 + + class(BaseT), allocatable, target :: o + class(InnerT), pointer :: i_p(:,:) + class(InnerBaseT), allocatable :: i_a(:,:) + integer i,j,l + + allocate(o) + allocate(o%arr(2,2)) + allocate(InnerT::i_a(2,2)) + o%arr%i = 1 + + i_p => o%arr + call o%P(i_p) + if (any(o%arr%i /= reshape([9,42,42,42],[2,2]))) call abort() + do l= 1, 10 + do i= 1, 2 + do j= 1,2 + if ((i == 1 .and. j == 1 .and. l == 5 .and. & + o%arr(i,j)%a(5) /= 1) & + .or. (.not. (i == 1 .and. j == 1 .and. l == 5) & + .and. o%arr(i,j)%a(l) /= 72)) call abort() + end do + end do + end do + + select type (i_a) + type is (InnerT) + call o%P(i_a) + do l= 1, 10 + do i= 1, 2 + do j= 1,2 + if ((i == 1 .and. j == 1 .and. l == 5 .and. & + i_a(i,j)%a(5) /= 1) & + .or. (.not. (i == 1 .and. j == 1 .and. l == 5) & + .and. i_a(i,j)%a(l) /= 72)) call abort() + end do + end do + end do + end select + + i_p%i = 4 + call indir(o, i_p) + if (any(o%arr%i /= reshape([9,42,42,42],[2,2]))) call abort() +end program test + +! vim:ts=2:sts=2:cindent:sw=2:tw=80: