* Re: [Fortran, Patch, PR{43366, 57117, 61337, 61376}, v1] Assign to polymorphic objects.
@ 2016-11-30 20:06 David Edelsohn
2016-11-30 20:51 ` Dominique d'Humières
0 siblings, 1 reply; 8+ messages in thread
From: David Edelsohn @ 2016-11-30 20:06 UTC (permalink / raw)
To: Andre Vehreschild, Paul Richard Thomas
Cc: GCC Patches, Fortran List, Dominique Dhumieres
Hi, Andre
I have noticed that the alloc_comp_class_5.f03 testcase fails on AIX.
Annotating the testcase a little, shows that the failure is at
if (any(x /= ["foo", "bar", "baz"])) call abort()
write (*,*) any
at the point of failure produces
"foobarba"
- David
^ permalink raw reply [flat|nested] 8+ messages in thread
* Re: [Fortran, Patch, PR{43366, 57117, 61337, 61376}, v1] Assign to polymorphic objects.
2016-11-30 20:06 [Fortran, Patch, PR{43366, 57117, 61337, 61376}, v1] Assign to polymorphic objects David Edelsohn
@ 2016-11-30 20:51 ` Dominique d'Humières
2016-12-01 18:32 ` Andre Vehreschild
0 siblings, 1 reply; 8+ messages in thread
From: Dominique d'Humières @ 2016-11-30 20:51 UTC (permalink / raw)
To: David Edelsohn
Cc: Andre Vehreschild, Paul Richard Thomas, GCC Patches, Fortran List
If I compile the test with an instrumented gfortran , I get
../../work/gcc/fortran/interface.c:2948:33: runtime error: load of value 1818451807, which is not a valid value for type ‘expr_t'
Dominique
> Le 30 nov. 2016 à 21:06, David Edelsohn <dje.gcc@gmail.com> a écrit :
>
> Hi, Andre
>
> I have noticed that the alloc_comp_class_5.f03 testcase fails on AIX.
> Annotating the testcase a little, shows that the failure is at
>
> if (any(x /= ["foo", "bar", "baz"])) call abort()
>
> write (*,*) any
>
> at the point of failure produces
>
> "foobarba"
>
> - David
^ permalink raw reply [flat|nested] 8+ messages in thread
* Re: [Fortran, Patch, PR{43366, 57117, 61337, 61376}, v1] Assign to polymorphic objects.
2016-11-30 20:51 ` Dominique d'Humières
@ 2016-12-01 18:32 ` Andre Vehreschild
2016-12-01 18:56 ` David Edelsohn
0 siblings, 1 reply; 8+ messages in thread
From: Andre Vehreschild @ 2016-12-01 18:32 UTC (permalink / raw)
To: Dominique d'Humières; +Cc: David Edelsohn, GCC Patches, Fortran List
Hi all,
I am sorry, but the initial mail as well as Dominique answer puzzles me:
David: I do expect to
write (*,*) any
not being compilable at all, because "any" is an intrinsic function and I
suppose that gfortran is not able to print it. At best it gives an address. So
am I right to assume that it should have been:
write (*,*) x
?
Which is a bit strange. Furthermore is it difficult for me to debug, because I
do not have access to an AIX machine. What address size does the machine have
32/48/64-bit? Is there a chance you send me the file that is generated
additionally by gfortran when called with -fdump-tree-original ? The file is
named alloc_comp_class_5.f03.003t.original usually.
Dominique: How did you get that? Do you have access to an AIX machine? What
kind of instrumentation was active in the compiler you mentioned?
- Andre
On Wed, 30 Nov 2016 21:51:30 +0100
Dominique d'Humières <dominiq@lps.ens.fr> wrote:
> If I compile the test with an instrumented gfortran , I get
>
> ../../work/gcc/fortran/interface.c:2948:33: runtime error: load of value
> 1818451807, which is not a valid value for type ‘expr_t'
>
> Dominique
>
> > Le 30 nov. 2016 à 21:06, David Edelsohn <dje.gcc@gmail.com> a écrit :
> >
> > Hi, Andre
> >
> > I have noticed that the alloc_comp_class_5.f03 testcase fails on AIX.
> > Annotating the testcase a little, shows that the failure is at
> >
> > if (any(x /= ["foo", "bar", "baz"])) call abort()
> >
> > write (*,*) any
> >
> > at the point of failure produces
> >
> > "foobarba"
> >
> > - David
>
--
Andre Vehreschild * Email: vehre ad gmx dot de
^ permalink raw reply [flat|nested] 8+ messages in thread
* Re: [Fortran, Patch, PR{43366, 57117, 61337, 61376}, v1] Assign to polymorphic objects.
2016-12-01 18:32 ` Andre Vehreschild
@ 2016-12-01 18:56 ` David Edelsohn
0 siblings, 0 replies; 8+ messages in thread
From: David Edelsohn @ 2016-12-01 18:56 UTC (permalink / raw)
To: Andre Vehreschild
Cc: Dominique d'Humières, GCC Patches, Fortran List
Dump sent privately.
Yes, I meant "x".
AIX defaults to 32 bit.
- David
On Thu, Dec 1, 2016 at 1:31 PM, Andre Vehreschild <vehre@gmx.de> wrote:
> Hi all,
>
> I am sorry, but the initial mail as well as Dominique answer puzzles me:
>
> David: I do expect to
>
> write (*,*) any
>
> not being compilable at all, because "any" is an intrinsic function and I
> suppose that gfortran is not able to print it. At best it gives an address. So
> am I right to assume that it should have been:
>
> write (*,*) x
>
> ?
>
> Which is a bit strange. Furthermore is it difficult for me to debug, because I
> do not have access to an AIX machine. What address size does the machine have
> 32/48/64-bit? Is there a chance you send me the file that is generated
> additionally by gfortran when called with -fdump-tree-original ? The file is
> named alloc_comp_class_5.f03.003t.original usually.
>
> Dominique: How did you get that? Do you have access to an AIX machine? What
> kind of instrumentation was active in the compiler you mentioned?
>
> - Andre
>
> On Wed, 30 Nov 2016 21:51:30 +0100
> Dominique d'Humières <dominiq@lps.ens.fr> wrote:
>
>> If I compile the test with an instrumented gfortran , I get
>>
>> ../../work/gcc/fortran/interface.c:2948:33: runtime error: load of value
>> 1818451807, which is not a valid value for type ‘expr_t'
>>
>> Dominique
>>
>> > Le 30 nov. 2016 à 21:06, David Edelsohn <dje.gcc@gmail.com> a écrit :
>> >
>> > Hi, Andre
>> >
>> > I have noticed that the alloc_comp_class_5.f03 testcase fails on AIX.
>> > Annotating the testcase a little, shows that the failure is at
>> >
>> > if (any(x /= ["foo", "bar", "baz"])) call abort()
>> >
>> > write (*,*) any
>> >
>> > at the point of failure produces
>> >
>> > "foobarba"
>> >
>> > - David
>>
>
>
> --
> Andre Vehreschild * Email: vehre ad gmx dot de
^ permalink raw reply [flat|nested] 8+ messages in thread
* Re: [Fortran, Patch, PR{43366, 57117, 61337, 61376}, v1] Assign to polymorphic objects.
2016-10-22 10:41 Paul Richard Thomas
@ 2016-10-22 12:36 ` Andre Vehreschild
0 siblings, 0 replies; 8+ messages in thread
From: Andre Vehreschild @ 2016-10-22 12:36 UTC (permalink / raw)
To: Paul Richard Thomas; +Cc: gcc-patches, fortran, Dominique Dhumieres
Hi Paul,
thanks for the review. Committed as r241439.
The first nit has gone to the patch for pr78053 as agreed upon.
The second nit:
> + class(r), allocatable :: foo ! Need this declared of copy_R is not
> generated.
has magically disappeared. I assume that it was necessary on an intermediate
stage of the patch only. I now have stripped the above line from the commit and
everything works fine.
Thanks again for the review.
Regards,
Andre
On Sat, 22 Oct 2016 12:41:19 +0200
Paul Richard Thomas <paul.richard.thomas@gmail.com> wrote:
> Dear Andre,
>
> For the bulk of the patch, I have no comments. However, for the
> testcase alloc_comp_class_5.f03, please eliminate the commented out
> lines and the TODO, as discussed on #gfortran. Add them to the
> testcase for for PR78053, as we agreed.
>
> In realloc_on_assign_27.f08, you have the following lines:
> + class(t), allocatable :: x
> + class(r), allocatable :: foo ! Need this declared of copy_R is not
> generated.
> + type(r) :: y = r (3, 42)
> +
> + x = y
>
> Surely, if you test for the existence of the vtable and create it if
> necessary for the rhs type in gfc_trans_class_assign, that would
> remove the need for 'foo'?
>
> The patch applies cleanly and regtests OK. Apart from the above nits,
> OK for trunk.
>
> Best regards
>
> Paul
>
> On 22 October 2016 at 12:19, Andre Vehreschild <vehre@gmx.de> wrote:
> > Hi Paul,
> >
> > here is the patch for pr78053 so far. It is based on the one for pr43366.
> > Compilation of the also attached testcase now works. Unfortunately produces
> > the patch a lot of regressions because the length of a char array is not
> > stored any longer in the vtab *and* in the _len component for deferred
> > length char arrays. That still has to be fixed. Given that you have
> > modified a lot on how SELECT TYPE works I fear, that when I change there,
> > too, we get a lot of conflicts. So when you have a version of your patch
> > for pr69834 I am happy to review it and continue work on pr78053
> > afterwards. I think this makes the most sense to avoid duplicate or
> > colliding work.
> >
> > Regards,
> > Andre
> >
--
Andre Vehreschild * Email: vehre ad gmx dot de
^ permalink raw reply [flat|nested] 8+ messages in thread
* Re: [Fortran, Patch, PR{43366, 57117, 61337, 61376}, v1] Assign to polymorphic objects.
@ 2016-10-22 10:41 Paul Richard Thomas
2016-10-22 12:36 ` Andre Vehreschild
0 siblings, 1 reply; 8+ messages in thread
From: Paul Richard Thomas @ 2016-10-22 10:41 UTC (permalink / raw)
To: Andre Vehreschild, gcc-patches, fortran; +Cc: Dominique Dhumieres
Dear Andre,
For the bulk of the patch, I have no comments. However, for the
testcase alloc_comp_class_5.f03, please eliminate the commented out
lines and the TODO, as discussed on #gfortran. Add them to the
testcase for for PR78053, as we agreed.
In realloc_on_assign_27.f08, you have the following lines:
+ class(t), allocatable :: x
+ class(r), allocatable :: foo ! Need this declared of copy_R is not
generated.
+ type(r) :: y = r (3, 42)
+
+ x = y
Surely, if you test for the existence of the vtable and create it if
necessary for the rhs type in gfc_trans_class_assign, that would
remove the need for 'foo'?
The patch applies cleanly and regtests OK. Apart from the above nits,
OK for trunk.
Best regards
Paul
On 22 October 2016 at 12:19, Andre Vehreschild <vehre@gmx.de> wrote:
> Hi Paul,
>
> here is the patch for pr78053 so far. It is based on the one for pr43366.
> Compilation of the also attached testcase now works. Unfortunately produces the
> patch a lot of regressions because the length of a char array is not stored any
> longer in the vtab *and* in the _len component for deferred length char arrays.
> That still has to be fixed. Given that you have modified a lot on how SELECT
> TYPE works I fear, that when I change there, too, we get a lot of conflicts. So
> when you have a version of your patch for pr69834 I am happy to review it and
> continue work on pr78053 afterwards. I think this makes the most sense to avoid
> duplicate or colliding work.
>
> Regards,
> Andre
>
^ permalink raw reply [flat|nested] 8+ messages in thread
* Re: [Fortran, Patch, PR{43366, 57117, 61337, 61376}, v1] Assign to polymorphic objects.
2016-10-13 12:42 Andre Vehreschild
@ 2016-10-19 17:37 ` Andre Vehreschild
0 siblings, 0 replies; 8+ messages in thread
From: Andre Vehreschild @ 2016-10-19 17:37 UTC (permalink / raw)
To: GCC-Patches-ML, GCC-Fortran-ML, Dominique Dhumieres
[-- Attachment #1: Type: text/plain, Size: 2708 bytes --]
Hi all,
attached is an enhanced version of the patch, which now catches all of the
testcases in the comments of pr61337. Thanks for reporting that I missed them,
Dominique.
For a detailed description see below. PR61337 needed just some more pre-code
joining and correct handling of class-typed array constructors.
Bootstraps and regtests ok on x86_64-linux/F23. Ok for trunk?
Regards,
Andre
On Thu, 13 Oct 2016 14:42:00 +0200
Andre Vehreschild <vehre@gmx.de> wrote:
> Hi all,
>
> attached patch fixes the PRs (as to my knowledge):
>
> PR43366 - [OOP][F08] Intrinsic assign to polymorphic variable
> PR57117 - [OOP] ICE for sourced allocation of a polymorphic entity using
> TRANSPOSE
> PR61337 - Wrong indexing and runtime crash with unlimited polymorphic array.
> PR61378 - Error using private statement in polymorphic derived type
>
> The latter two are more or less fixed by accident or have been fixed by
> previous patches, but have not been identified as such. Anyway, they are fixed
> now and will be closed once the patch hits trunk.
>
> As for PR43366: I did not indent to fix this one, but when going for PR57117 I
> once again stumbled over the deficiencies of gfc_trans_assigment's handling of
> class objects. Therefore I figured what would be needed to complete PR43366
> and this is it now.
>
> As for PR57117: The issue was that ALLOCATE () used gfc_copy_class_to_class ()
> when a class object was allocated. The function gfc_copy_class_to_class ()
> does not use the scalarizer correctly. I.e., a transpose of the source=
> expression would not be respected. I therefore decided to remove all this
> special casing for class objects in ALLOCATE () and let gfc_trans_assignment
> do the trick. This way ensuring, that any improvements of the scalarizer will
> benefit class objects, too. Unfortunately did this mean to add more logic to
> gfc_trans_assignment. While doing so, I learned that existing wrappers for
> class assignments were obsoleted by the work I did, so I removed them.
>
> I tried to get rid of the malicious copy_class_to_class, too, but at the
> moment it is still used at one location where components of derived types are
> assigned. I was not bold enough to replace this occurrence with
> trans_assignment yet.
>
> This patch shall make our lives easier, because now there is one routine to
> assign all sorts of objects and no special casing for class objects is needed
> anymore. I expect that some other parts of gfortran's code base may benefit
> from the changes and have their complexity reduced.
>
> Bootstrapped and regtested ok on x86_64-linux/F23. Ok for trunk?
>
> Regards,
> Andre
--
Andre Vehreschild * Email: vehre ad gmx dot de
[-- Attachment #2: pr43366_v2.clog --]
[-- Type: application/octet-stream, Size: 2534 bytes --]
gcc/fortran/ChangeLog:
2016-10-19 Andre Vehreschild <vehre@gcc.gnu.org>
PR fortran/43366
PR fortran/51864
PR fortran/57117
PR fortran/61337
PR fortran/61376
* primary.c (gfc_expr_attr): For transformational functions on classes
get the attrs from the class argument.
* resolve.c (resolve_ordinary_assign): Remove error message due to
feature implementation. Rewrite POINTER_ASSIGNS to ordinary ones when
the right-hand side is scalar class object (with some restrictions).
* trans-array.c (trans_array_constructor): Create the temporary from
class' inner type, i.e., the derived type.
(build_class_array_ref): Add support for class array's storage of the
class object or the array descriptor in the decl saved descriptor.
(gfc_conv_expr_descriptor): When creating temporaries for class objects
add the class object's handle into the decl saved descriptor.
(structure_alloc_comps): Use the common way to get the _data component.
(gfc_is_reallocatable_lhs): Add notion of allocatable class objects.
* trans-expr.c (gfc_find_and_cut_at_last_class_ref): Remove the only ref
only when the expression's type is BT_CLASS.
(gfc_trans_class_init_assign): Correctly handle class arrays.
(gfc_trans_class_assign): Joined into gfc_trans_assignment_1.
(gfc_conv_procedure_call): Support for class types as arguments.
(trans_get_upoly_len): For unlimited polymorphics retrieve the _len
component's tree.
(trans_class_vptr_len_assignment): Catch all ways to assign the _vptr
and _len components of a class object correctly.
(pointer_assignment_is_proc_pointer): Identify assignments of
procedure pointers.
(gfc_trans_pointer_assignment): Enhance support for class object pointer
assignments.
(gfc_trans_scalar_assign): Removed assert.
(trans_class_assignment): Assign to a class object.
(gfc_trans_assignment_1): Treat class objects correctly.
(gfc_trans_assignment): Propagate flags to trans_assignment_1.
* trans-stmt.c (gfc_trans_allocate): Use gfc_trans_assignment now
instead of copy_class_to_class.
* trans-stmt.h: Function prototype removed.
* trans.c (trans_code): Less special casing for class objects.
* trans.h: Added flags to gfc_trans_assignment () prototype.
gcc/testsuite/ChangeLog:
2016-10-19 Andre Vehreschild <vehre@gcc.gnu.org>
PR fortran/43366
PR fortran/57117
PR fortran/61337
* gfortran.dg/alloc_comp_class_5.f03: New test.
* gfortran.dg/class_allocate_21.f90: New test.
* gfortran.dg/class_allocate_22.f90: New test.
* gfortran.dg/realloc_on_assign_27.f08: New test.
[-- Attachment #3: pr43366_v2.patch --]
[-- Type: text/x-patch, Size: 57546 bytes --]
diff --git a/gcc/fortran/primary.c b/gcc/fortran/primary.c
index 85589ee..3803b88 100644
--- a/gcc/fortran/primary.c
+++ b/gcc/fortran/primary.c
@@ -2359,6 +2359,10 @@ gfc_expr_attr (gfc_expr *e)
attr.allocatable = CLASS_DATA (sym)->attr.allocatable;
}
}
+ else if (e->value.function.isym
+ && e->value.function.isym->transformational
+ && e->ts.type == BT_CLASS)
+ attr = CLASS_DATA (e)->attr;
else
attr = gfc_variable_attr (e, NULL);
diff --git a/gcc/fortran/resolve.c b/gcc/fortran/resolve.c
index 87178a4..3bb057d 100644
--- a/gcc/fortran/resolve.c
+++ b/gcc/fortran/resolve.c
@@ -9834,10 +9834,6 @@ resolve_ordinary_assign (gfc_code *code, gfc_namespace *ns)
"requires %<-frealloc-lhs%>", &lhs->where);
return false;
}
- /* See PR 43366. */
- gfc_error ("Assignment to an allocatable polymorphic variable at %L "
- "is not yet supported", &lhs->where);
- return false;
}
else if (lhs->ts.type == BT_CLASS)
{
@@ -10740,6 +10736,19 @@ start:
break;
gfc_check_pointer_assign (code->expr1, code->expr2);
+
+ /* Assigning a class object always is a regular assign. */
+ if (code->expr2->ts.type == BT_CLASS
+ && !CLASS_DATA (code->expr2)->attr.dimension
+ && !(UNLIMITED_POLY (code->expr2)
+ && code->expr1->ts.type == BT_DERIVED
+ && (code->expr1->ts.u.derived->attr.sequence
+ || code->expr1->ts.u.derived->attr.is_bind_c))
+ && !(gfc_expr_attr (code->expr1).proc_pointer
+ && code->expr2->expr_type == EXPR_VARIABLE
+ && code->expr2->symtree->n.sym->attr.flavor
+ == FL_PROCEDURE))
+ code->op = EXEC_ASSIGN;
break;
}
diff --git a/gcc/fortran/trans-array.c b/gcc/fortran/trans-array.c
index 37cca79..c59e872 100644
--- a/gcc/fortran/trans-array.c
+++ b/gcc/fortran/trans-array.c
@@ -2292,7 +2292,8 @@ trans_array_constructor (gfc_ss * ss, locus * where)
type = build_pointer_type (type);
}
else
- type = gfc_typenode_for_spec (&expr->ts);
+ type = gfc_typenode_for_spec (expr->ts.type == BT_CLASS
+ ? &CLASS_DATA (expr)->ts : &expr->ts);
/* See if the constructor determines the loop bounds. */
dynamic = false;
@@ -3036,50 +3037,57 @@ build_class_array_ref (gfc_se *se, tree base, tree index)
tree type;
tree size;
tree offset;
- tree decl;
+ tree decl = NULL_TREE;
tree tmp;
gfc_expr *expr = se->ss->info->expr;
gfc_ref *ref;
- gfc_ref *class_ref;
+ gfc_ref *class_ref = NULL;
gfc_typespec *ts;
- if (expr == NULL
- || (expr->ts.type != BT_CLASS
- && !gfc_is_alloc_class_array_function (expr)))
- return false;
-
- if (expr->symtree && expr->symtree->n.sym->ts.type == BT_CLASS)
- ts = &expr->symtree->n.sym->ts;
+ if (se->expr && DECL_P (se->expr) && DECL_LANG_SPECIFIC (se->expr)
+ && GFC_DECL_SAVED_DESCRIPTOR (se->expr)
+ && GFC_CLASS_TYPE_P (TREE_TYPE (GFC_DECL_SAVED_DESCRIPTOR (se->expr))))
+ decl = se->expr;
else
- ts = NULL;
- class_ref = NULL;
-
- for (ref = expr->ref; ref; ref = ref->next)
{
- if (ref->type == REF_COMPONENT
- && ref->u.c.component->ts.type == BT_CLASS
- && ref->next && ref->next->type == REF_COMPONENT
- && strcmp (ref->next->u.c.component->name, "_data") == 0
- && ref->next->next
- && ref->next->next->type == REF_ARRAY
- && ref->next->next->u.ar.type != AR_ELEMENT)
+ if (expr == NULL
+ || (expr->ts.type != BT_CLASS
+ && !gfc_is_alloc_class_array_function (expr)
+ && !gfc_is_class_array_ref (expr, NULL)))
+ return false;
+
+ if (expr->symtree && expr->symtree->n.sym->ts.type == BT_CLASS)
+ ts = &expr->symtree->n.sym->ts;
+ else
+ ts = NULL;
+
+ for (ref = expr->ref; ref; ref = ref->next)
{
- ts = &ref->u.c.component->ts;
- class_ref = ref;
- break;
+ if (ref->type == REF_COMPONENT
+ && ref->u.c.component->ts.type == BT_CLASS
+ && ref->next && ref->next->type == REF_COMPONENT
+ && strcmp (ref->next->u.c.component->name, "_data") == 0
+ && ref->next->next
+ && ref->next->next->type == REF_ARRAY
+ && ref->next->next->u.ar.type != AR_ELEMENT)
+ {
+ ts = &ref->u.c.component->ts;
+ class_ref = ref;
+ break;
+ }
}
- }
- if (ts == NULL)
- return false;
+ if (ts == NULL)
+ return false;
+ }
- if (class_ref == NULL && expr->symtree->n.sym->attr.function
+ if (class_ref == NULL && expr && expr->symtree->n.sym->attr.function
&& expr->symtree->n.sym == expr->symtree->n.sym->result)
{
gcc_assert (expr->symtree->n.sym->backend_decl == current_function_decl);
decl = gfc_get_fake_result_decl (expr->symtree->n.sym, 0);
}
- else if (gfc_is_alloc_class_array_function (expr))
+ else if (expr && gfc_is_alloc_class_array_function (expr))
{
size = NULL_TREE;
decl = NULL_TREE;
@@ -3105,7 +3113,8 @@ build_class_array_ref (gfc_se *se, tree base, tree index)
}
else if (class_ref == NULL)
{
- decl = expr->symtree->n.sym->backend_decl;
+ if (decl == NULL_TREE)
+ decl = expr->symtree->n.sym->backend_decl;
/* For class arrays the tree containing the class is stored in
GFC_DECL_SAVED_DESCRIPTOR of the sym's backend_decl.
For all others it's sym's backend_decl directly. */
@@ -3121,6 +3130,7 @@ build_class_array_ref (gfc_se *se, tree base, tree index)
class_ref->next = NULL;
gfc_init_se (&tmpse, NULL);
gfc_conv_expr (&tmpse, expr);
+ gfc_add_block_to_block (&se->pre, &tmpse.pre);
decl = tmpse.expr;
class_ref->next = ref;
}
@@ -7094,6 +7104,28 @@ gfc_conv_expr_descriptor (gfc_se *se, gfc_expr *expr)
loop.from, loop.to, 0,
GFC_ARRAY_UNKNOWN, false);
parm = gfc_create_var (parmtype, "parm");
+
+ /* When expression is a class object, then add the class' handle to
+ the parm_decl. */
+ if (expr->ts.type == BT_CLASS && expr->expr_type == EXPR_VARIABLE)
+ {
+ gfc_expr *class_expr = gfc_find_and_cut_at_last_class_ref (expr);
+ gfc_se classse;
+
+ /* class_expr can be NULL, when no _class ref is in expr.
+ We must not fix this here with a gfc_fix_class_ref (). */
+ if (class_expr)
+ {
+ gfc_init_se (&classse, NULL);
+ gfc_conv_expr (&classse, class_expr);
+ gfc_free_expr (class_expr);
+
+ gcc_assert (classse.pre.head == NULL_TREE
+ && classse.post.head == NULL_TREE);
+ gfc_allocate_lang_decl (parm);
+ GFC_DECL_SAVED_DESCRIPTOR (parm) = classse.expr;
+ }
+ }
}
offset = gfc_index_zero_node;
@@ -7255,6 +7287,13 @@ gfc_conv_expr_descriptor (gfc_se *se, gfc_expr *expr)
: base;
gfc_conv_descriptor_offset_set (&loop.pre, parm, tmp);
}
+ else if (IS_CLASS_ARRAY (expr) && !se->data_not_needed
+ && (!rank_remap || se->use_offset)
+ && GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (desc)))
+ {
+ gfc_conv_descriptor_offset_set (&loop.pre, parm,
+ gfc_conv_descriptor_offset_get (desc));
+ }
else if (onebased && (!rank_remap || se->use_offset)
&& expr->symtree
&& !(expr->symtree->n.sym && expr->symtree->n.sym->ts.type == BT_CLASS
@@ -7290,6 +7329,18 @@ gfc_conv_expr_descriptor (gfc_se *se, gfc_expr *expr)
GFC_DECL_SAVED_DESCRIPTOR (expr->symtree->n.sym->backend_decl)
: expr->symtree->n.sym->backend_decl;
}
+ else if (expr->expr_type == EXPR_ARRAY && VAR_P (desc)
+ && IS_CLASS_ARRAY (expr))
+ {
+ tree vtype;
+ gfc_allocate_lang_decl (desc);
+ tmp = gfc_create_var (expr->ts.u.derived->backend_decl, "class");
+ GFC_DECL_SAVED_DESCRIPTOR (desc) = tmp;
+ vtype = gfc_class_vptr_get (tmp);
+ gfc_add_modify (&se->pre, vtype,
+ gfc_build_addr_expr (TREE_TYPE (vtype),
+ gfc_find_vtab (&expr->ts)->backend_decl));
+ }
if (!se->direct_byref || se->byref_noassign)
{
/* Get a pointer to the new descriptor. */
@@ -8200,10 +8251,8 @@ structure_alloc_comps (gfc_symbol * der_type, tree decl,
/* Allocatable CLASS components. */
comp = fold_build3_loc (input_location, COMPONENT_REF, ctype,
decl, cdecl, NULL_TREE);
- /* Add reference to '_data' component. */
- tmp = CLASS_DATA (c)->backend_decl;
- comp = fold_build3_loc (input_location, COMPONENT_REF,
- TREE_TYPE (tmp), comp, tmp, NULL_TREE);
+
+ comp = gfc_class_data_get (comp);
if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (comp)))
gfc_conv_descriptor_data_set (&fnblock, comp, null_pointer_node);
else
@@ -8541,6 +8590,14 @@ gfc_is_reallocatable_lhs (gfc_expr *expr)
if (!expr->ref)
return false;
+ /* An allocatable class variable with no reference. */
+ if (expr->symtree->n.sym->ts.type == BT_CLASS
+ && CLASS_DATA (expr->symtree->n.sym)->attr.allocatable
+ && expr->ref && expr->ref->type == REF_COMPONENT
+ && strcmp (expr->ref->u.c.component->name, "_data") == 0
+ && expr->ref->next == NULL)
+ return true;
+
/* An allocatable variable. */
if (expr->symtree->n.sym->attr.allocatable
&& expr->ref
diff --git a/gcc/fortran/trans-expr.c b/gcc/fortran/trans-expr.c
index 6b974db..10fe9b9 100644
--- a/gcc/fortran/trans-expr.c
+++ b/gcc/fortran/trans-expr.c
@@ -350,7 +350,7 @@ gfc_expr *
gfc_find_and_cut_at_last_class_ref (gfc_expr *e)
{
gfc_expr *base_expr;
- gfc_ref *ref, *class_ref, *tail, *array_ref;
+ gfc_ref *ref, *class_ref, *tail = NULL, *array_ref;
/* Find the last class reference. */
class_ref = NULL;
@@ -383,7 +383,7 @@ gfc_find_and_cut_at_last_class_ref (gfc_expr *e)
tail = class_ref->next;
class_ref->next = NULL;
}
- else
+ else if (e->symtree && e->symtree->n.sym->ts.type == BT_CLASS)
{
tail = e->ref;
e->ref = NULL;
@@ -397,7 +397,7 @@ gfc_find_and_cut_at_last_class_ref (gfc_expr *e)
gfc_free_ref_list (class_ref->next);
class_ref->next = tail;
}
- else
+ else if (e->symtree && e->symtree->n.sym->ts.type == BT_CLASS)
{
gfc_free_ref_list (e->ref);
e->ref = tail;
@@ -1453,7 +1453,12 @@ gfc_trans_class_init_assign (gfc_code *code)
if (code->expr1->ts.type == BT_CLASS
&& CLASS_DATA (code->expr1)->attr.dimension)
- tmp = gfc_trans_class_array_init_assign (rhs, lhs, code->expr1);
+ {
+ gfc_array_spec *tmparr = gfc_get_array_spec ();
+ *tmparr = *CLASS_DATA (code->expr1)->as;
+ gfc_add_full_array_ref (lhs, tmparr);
+ tmp = gfc_trans_class_array_init_assign (rhs, lhs, code->expr1);
+ }
else
{
sz = gfc_copy_expr (code->expr1);
@@ -1498,114 +1503,6 @@ gfc_trans_class_init_assign (gfc_code *code)
}
-/* Translate an assignment to a CLASS object
- (pointer or ordinary assignment). */
-
-tree
-gfc_trans_class_assign (gfc_expr *expr1, gfc_expr *expr2, gfc_exec_op op)
-{
- stmtblock_t block;
- tree tmp;
- gfc_expr *lhs;
- gfc_expr *rhs;
- gfc_ref *ref;
-
- gfc_start_block (&block);
-
- ref = expr1->ref;
- while (ref && ref->next)
- ref = ref->next;
-
- /* Class valued proc_pointer assignments do not need any further
- preparation. */
- if (ref && ref->type == REF_COMPONENT
- && ref->u.c.component->attr.proc_pointer
- && expr2->expr_type == EXPR_VARIABLE
- && expr2->symtree->n.sym->attr.flavor == FL_PROCEDURE
- && op == EXEC_POINTER_ASSIGN)
- goto assign;
-
- if (expr2->ts.type != BT_CLASS)
- {
- /* Insert an additional assignment which sets the '_vptr' field. */
- gfc_symbol *vtab = NULL;
- gfc_symtree *st;
-
- lhs = gfc_copy_expr (expr1);
- gfc_add_vptr_component (lhs);
-
- if (UNLIMITED_POLY (expr1)
- && expr2->expr_type == EXPR_NULL && expr2->ts.type == BT_UNKNOWN)
- {
- rhs = gfc_get_null_expr (&expr2->where);
- goto assign_vptr;
- }
-
- if (expr2->expr_type == EXPR_NULL)
- vtab = gfc_find_vtab (&expr1->ts);
- else
- vtab = gfc_find_vtab (&expr2->ts);
- gcc_assert (vtab);
-
- rhs = gfc_get_expr ();
- rhs->expr_type = EXPR_VARIABLE;
- gfc_find_sym_tree (vtab->name, vtab->ns, 1, &st);
- rhs->symtree = st;
- rhs->ts = vtab->ts;
-assign_vptr:
- tmp = gfc_trans_pointer_assignment (lhs, rhs);
- gfc_add_expr_to_block (&block, tmp);
-
- gfc_free_expr (lhs);
- gfc_free_expr (rhs);
- }
- else if (expr1->ts.type == BT_DERIVED && UNLIMITED_POLY (expr2))
- {
- /* F2003:C717 only sequence and bind-C types can come here. */
- gcc_assert (expr1->ts.u.derived->attr.sequence
- || expr1->ts.u.derived->attr.is_bind_c);
- gfc_add_data_component (expr2);
- goto assign;
- }
- else if (CLASS_DATA (expr2)->attr.dimension && expr2->expr_type != EXPR_FUNCTION)
- {
- /* Insert an additional assignment which sets the '_vptr' field. */
- lhs = gfc_copy_expr (expr1);
- gfc_add_vptr_component (lhs);
-
- rhs = gfc_copy_expr (expr2);
- gfc_add_vptr_component (rhs);
-
- tmp = gfc_trans_pointer_assignment (lhs, rhs);
- gfc_add_expr_to_block (&block, tmp);
-
- gfc_free_expr (lhs);
- gfc_free_expr (rhs);
- }
-
- /* Do the actual CLASS assignment. */
- if (expr2->ts.type == BT_CLASS
- && !CLASS_DATA (expr2)->attr.dimension)
- op = EXEC_ASSIGN;
- else if (expr2->expr_type != EXPR_FUNCTION || expr2->ts.type != BT_CLASS
- || !CLASS_DATA (expr2)->attr.dimension)
- gfc_add_data_component (expr1);
-
-assign:
-
- if (op == EXEC_ASSIGN)
- tmp = gfc_trans_assignment (expr1, expr2, false, true);
- else if (op == EXEC_POINTER_ASSIGN)
- tmp = gfc_trans_pointer_assignment (expr1, expr2);
- else
- gcc_unreachable();
-
- gfc_add_expr_to_block (&block, tmp);
-
- return gfc_finish_block (&block);
-}
-
-
/* End of prototype trans-class.c */
@@ -5903,6 +5800,8 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym,
if (comp)
ts = comp->ts;
+ else if (sym->ts.type == BT_CLASS)
+ ts = CLASS_DATA (sym)->ts;
else
ts = sym->ts;
@@ -5973,7 +5872,7 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym,
&& GFC_DESCRIPTOR_TYPE_P
(TREE_TYPE (TREE_TYPE (TREE_TYPE (se->expr)))))
se->expr = build_fold_indirect_ref_loc (input_location,
- se->expr);
+ se->expr);
/* If the lhs of an assignment x = f(..) is allocatable and
f2003 is allowed, we must do the automatic reallocation.
@@ -6259,6 +6158,26 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym,
}
}
+ /* Associate the rhs class object's meta-data with the result, when the
+ result is a temporary. */
+ if (args && args->expr && args->expr->ts.type == BT_CLASS
+ && sym->ts.type == BT_CLASS && result != NULL_TREE && DECL_P (result)
+ && !GFC_CLASS_TYPE_P (TREE_TYPE (result)))
+ {
+ gfc_se parmse;
+ gfc_expr *class_expr = gfc_find_and_cut_at_last_class_ref (args->expr);
+
+ gfc_init_se (&parmse, NULL);
+ parmse.data_not_needed = 1;
+ gfc_conv_expr (&parmse, class_expr);
+ if (!DECL_LANG_SPECIFIC (result))
+ gfc_allocate_lang_decl (result);
+ GFC_DECL_SAVED_DESCRIPTOR (result) = parmse.expr;
+ gfc_free_expr (class_expr);
+ gcc_assert (parmse.pre.head == NULL_TREE
+ && parmse.post.head == NULL_TREE);
+ }
+
/* Follow the function call with the argument post block. */
if (byref)
{
@@ -7881,6 +7800,201 @@ gfc_conv_expr_reference (gfc_se * se, gfc_expr * expr)
}
+/* Get the _len component for an unlimited polymorphic expression. */
+
+static tree
+trans_get_upoly_len (stmtblock_t *block, gfc_expr *expr)
+{
+ gfc_se se;
+ gfc_ref *ref = expr->ref;
+
+ gfc_init_se (&se, NULL);
+ while (ref && ref->next)
+ ref = ref->next;
+ gfc_add_len_component (expr);
+ gfc_conv_expr (&se, expr);
+ gfc_add_block_to_block (block, &se.pre);
+ gcc_assert (se.post.head == NULL_TREE);
+ if (ref)
+ {
+ gfc_free_ref_list (ref->next);
+ ref->next = NULL;
+ }
+ else
+ {
+ gfc_free_ref_list (expr->ref);
+ expr->ref = NULL;
+ }
+ return se.expr;
+}
+
+
+/* Assign _vptr and _len components as appropriate. BLOCK should be a
+ statement-list outside of the scalarizer-loop. When code is generated, that
+ depends on the scalarized expression, it is added to RSE.PRE.
+ Returns le's _vptr tree and when set the len expressions in to_lenp and
+ from_lenp to form a le%_vptr%_copy (re, le, [from_lenp, to_lenp])
+ expression. */
+
+static tree
+trans_class_vptr_len_assignment (stmtblock_t *block, gfc_expr * le,
+ gfc_expr * re, gfc_se *rse,
+ tree * to_lenp, tree * from_lenp)
+{
+ gfc_se se;
+ gfc_expr * vptr_expr;
+ tree tmp, to_len = NULL_TREE, from_len = NULL_TREE, lhs_vptr;
+ bool set_vptr = false, temp_rhs = false;
+ stmtblock_t *pre = block;
+
+ /* Create a temporary for complicated expressions. */
+ if (re->expr_type != EXPR_VARIABLE && re->expr_type != EXPR_NULL
+ && rse->expr != NULL_TREE && !DECL_P (rse->expr))
+ {
+ tmp = gfc_create_var (TREE_TYPE (rse->expr), "rhs");
+ pre = &rse->pre;
+ gfc_add_modify (&rse->pre, tmp, rse->expr);
+ rse->expr = tmp;
+ temp_rhs = true;
+ }
+
+ /* Get the _vptr for the left-hand side expression. */
+ gfc_init_se (&se, NULL);
+ vptr_expr = gfc_find_and_cut_at_last_class_ref (le);
+ if (vptr_expr != NULL && gfc_expr_attr (vptr_expr).class_ok)
+ {
+ /* Care about _len for unlimited polymorphic entities. */
+ if (UNLIMITED_POLY (vptr_expr)
+ || (vptr_expr->ts.type == BT_DERIVED
+ && vptr_expr->ts.u.derived->attr.unlimited_polymorphic))
+ to_len = trans_get_upoly_len (block, vptr_expr);
+ gfc_add_vptr_component (vptr_expr);
+ set_vptr = true;
+ }
+ else
+ vptr_expr = gfc_lval_expr_from_sym (gfc_find_vtab (&le->ts));
+ se.want_pointer = 1;
+ gfc_conv_expr (&se, vptr_expr);
+ gfc_free_expr (vptr_expr);
+ gfc_add_block_to_block (block, &se.pre);
+ gcc_assert (se.post.head == NULL_TREE);
+ lhs_vptr = se.expr;
+ STRIP_NOPS (lhs_vptr);
+
+ /* Set the _vptr only when the left-hand side of the assignment is a
+ class-object. */
+ if (set_vptr)
+ {
+ /* Get the vptr from the rhs expression only, when it is variable.
+ Functions are expected to be assigned to a temporary beforehand. */
+ vptr_expr = re->expr_type == EXPR_VARIABLE
+ ? gfc_find_and_cut_at_last_class_ref (re)
+ : NULL;
+ if (vptr_expr != NULL && vptr_expr->ts.type == BT_CLASS)
+ {
+ if (to_len != NULL_TREE)
+ {
+ /* Get the _len information from the rhs. */
+ if (UNLIMITED_POLY (vptr_expr)
+ || (vptr_expr->ts.type == BT_DERIVED
+ && vptr_expr->ts.u.derived->attr.unlimited_polymorphic))
+ from_len = trans_get_upoly_len (block, vptr_expr);
+ }
+ gfc_add_vptr_component (vptr_expr);
+ }
+ else
+ {
+ if (re->expr_type == EXPR_VARIABLE
+ && DECL_P (re->symtree->n.sym->backend_decl)
+ && DECL_LANG_SPECIFIC (re->symtree->n.sym->backend_decl)
+ && GFC_DECL_SAVED_DESCRIPTOR (re->symtree->n.sym->backend_decl)
+ && GFC_CLASS_TYPE_P (TREE_TYPE (GFC_DECL_SAVED_DESCRIPTOR (
+ re->symtree->n.sym->backend_decl))))
+ {
+ vptr_expr = NULL;
+ se.expr = gfc_class_vptr_get (GFC_DECL_SAVED_DESCRIPTOR (
+ re->symtree->n.sym->backend_decl));
+ if (to_len)
+ from_len = gfc_class_len_get (GFC_DECL_SAVED_DESCRIPTOR (
+ re->symtree->n.sym->backend_decl));
+ }
+ else if (temp_rhs && re->ts.type == BT_CLASS)
+ {
+ vptr_expr = NULL;
+ se.expr = gfc_class_vptr_get (rse->expr);
+ }
+ else if (re->expr_type != EXPR_NULL)
+ /* Only when rhs is non-NULL use its declared type for vptr
+ initialisation. */
+ vptr_expr = gfc_lval_expr_from_sym (gfc_find_vtab (&re->ts));
+ else
+ /* When the rhs is NULL use the vtab of lhs' declared type. */
+ vptr_expr = gfc_lval_expr_from_sym (gfc_find_vtab (&le->ts));
+ }
+
+ if (vptr_expr)
+ {
+ gfc_init_se (&se, NULL);
+ se.want_pointer = 1;
+ gfc_conv_expr (&se, vptr_expr);
+ gfc_free_expr (vptr_expr);
+ gfc_add_block_to_block (block, &se.pre);
+ gcc_assert (se.post.head == NULL_TREE);
+ }
+ gfc_add_modify (pre, lhs_vptr, fold_convert (TREE_TYPE (lhs_vptr),
+ se.expr));
+
+ if (to_len != NULL_TREE)
+ {
+ /* The _len component needs to be set. Figure how to get the
+ value of the right-hand side. */
+ if (from_len == NULL_TREE)
+ {
+ if (rse->string_length != NULL_TREE)
+ from_len = rse->string_length;
+ else if (re->ts.type == BT_CHARACTER && re->ts.u.cl->length)
+ {
+ from_len = gfc_get_expr_charlen (re);
+ gfc_init_se (&se, NULL);
+ gfc_conv_expr (&se, re->ts.u.cl->length);
+ gfc_add_block_to_block (block, &se.pre);
+ gcc_assert (se.post.head == NULL_TREE);
+ from_len = gfc_evaluate_now (se.expr, block);
+ }
+ else
+ from_len = integer_zero_node;
+ }
+ gfc_add_modify (pre, to_len, fold_convert (TREE_TYPE (to_len),
+ from_len));
+ }
+ }
+
+ /* Return the _len trees only, when requested. */
+ if (to_lenp)
+ *to_lenp = to_len;
+ if (from_lenp)
+ *from_lenp = from_len;
+ return lhs_vptr;
+}
+
+/* Indentify class valued proc_pointer assignments. */
+
+static bool
+pointer_assignment_is_proc_pointer (gfc_expr * expr1, gfc_expr * expr2)
+{
+ gfc_ref * ref;
+
+ ref = expr1->ref;
+ while (ref && ref->next)
+ ref = ref->next;
+
+ return ref && ref->type == REF_COMPONENT
+ && ref->u.c.component->attr.proc_pointer
+ && expr2->expr_type == EXPR_VARIABLE
+ && expr2->symtree->n.sym->attr.flavor == FL_PROCEDURE;
+}
+
+
tree
gfc_trans_pointer_assign (gfc_code * code)
{
@@ -7893,20 +8007,22 @@ gfc_trans_pointer_assign (gfc_code * code)
tree
gfc_trans_pointer_assignment (gfc_expr * expr1, gfc_expr * expr2)
{
- gfc_expr *expr1_vptr = NULL;
gfc_se lse;
gfc_se rse;
stmtblock_t block;
tree desc;
tree tmp;
tree decl;
- bool scalar;
+ bool scalar, non_proc_pointer_assign;
gfc_ss *ss;
gfc_start_block (&block);
gfc_init_se (&lse, NULL);
+ /* Usually testing whether this is not a proc pointer assignment. */
+ non_proc_pointer_assign = !pointer_assignment_is_proc_pointer (expr1, expr2);
+
/* Check whether the expression is a scalar or not; we cannot use
expr1->rank as it can be nonzero for proc pointers. */
ss = gfc_walk_expr (expr1);
@@ -7915,7 +8031,7 @@ gfc_trans_pointer_assignment (gfc_expr * expr1, gfc_expr * expr2)
gfc_free_ss_chain (ss);
if (expr1->ts.type == BT_DERIVED && expr2->ts.type == BT_CLASS
- && expr2->expr_type != EXPR_FUNCTION)
+ && expr2->expr_type != EXPR_FUNCTION && non_proc_pointer_assign)
{
gfc_add_data_component (expr2);
/* The following is required as gfc_add_data_component doesn't
@@ -7932,6 +8048,13 @@ gfc_trans_pointer_assignment (gfc_expr * expr1, gfc_expr * expr2)
rse.want_pointer = 1;
gfc_conv_expr (&rse, expr2);
+ if (non_proc_pointer_assign && expr1->ts.type == BT_CLASS)
+ {
+ trans_class_vptr_len_assignment (&block, expr1, expr2, &rse, NULL,
+ NULL);
+ lse.expr = gfc_class_data_get (lse.expr);
+ }
+
if (expr1->symtree->n.sym->attr.proc_pointer
&& expr1->symtree->n.sym->attr.dummy)
lse.expr = build_fold_indirect_ref_loc (input_location,
@@ -7945,27 +8068,6 @@ gfc_trans_pointer_assignment (gfc_expr * expr1, gfc_expr * expr2)
gfc_add_block_to_block (&block, &lse.pre);
gfc_add_block_to_block (&block, &rse.pre);
- /* For string assignments to unlimited polymorphic pointers add an
- assignment of the string_length to the _len component of the
- pointer. */
- if ((expr1->ts.type == BT_CLASS || expr1->ts.type == BT_DERIVED)
- && expr1->ts.u.derived->attr.unlimited_polymorphic
- && (expr2->ts.type == BT_CHARACTER ||
- ((expr2->ts.type == BT_DERIVED || expr2->ts.type == BT_CLASS)
- && expr2->ts.u.derived->attr.unlimited_polymorphic)))
- {
- gfc_expr *len_comp;
- gfc_se se;
- len_comp = gfc_get_len_component (expr1);
- gfc_init_se (&se, NULL);
- gfc_conv_expr (&se, len_comp);
-
- /* ptr % _len = len (str) */
- gfc_add_modify (&block, se.expr, rse.string_length);
- lse.string_length = se.expr;
- gfc_free_expr (len_comp);
- }
-
/* Check character lengths if character expression. The test is only
really added if -fbounds-check is enabled. Exclude deferred
character length lefthand sides. */
@@ -7992,9 +8094,6 @@ gfc_trans_pointer_assignment (gfc_expr * expr1, gfc_expr * expr2)
build_int_cst (gfc_charlen_type_node, 0));
}
- if (expr1->ts.type == BT_DERIVED && expr2->ts.type == BT_CLASS)
- rse.expr = gfc_class_data_get (rse.expr);
-
gfc_add_modify (&block, lse.expr,
fold_convert (TREE_TYPE (lse.expr), rse.expr));
@@ -8005,6 +8104,7 @@ gfc_trans_pointer_assignment (gfc_expr * expr1, gfc_expr * expr2)
{
gfc_ref* remap;
bool rank_remap;
+ tree expr1_vptr = NULL_TREE;
tree strlen_lhs;
tree strlen_rhs = NULL_TREE;
@@ -8021,9 +8121,6 @@ gfc_trans_pointer_assignment (gfc_expr * expr1, gfc_expr * expr2)
gfc_init_se (&lse, NULL);
if (remap)
lse.descriptor_only = 1;
- if (expr2->expr_type == EXPR_FUNCTION && expr2->ts.type == BT_CLASS
- && expr1->ts.type == BT_CLASS)
- expr1_vptr = gfc_copy_expr (expr1);
gfc_conv_expr_descriptor (&lse, expr1);
strlen_lhs = lse.string_length;
desc = lse.expr;
@@ -8049,16 +8146,15 @@ gfc_trans_pointer_assignment (gfc_expr * expr1, gfc_expr * expr2)
rse.expr = gfc_class_data_get (rse.expr);
else
{
+ expr1_vptr = trans_class_vptr_len_assignment (&block, expr1,
+ expr2, &rse,
+ NULL, NULL);
gfc_add_block_to_block (&block, &rse.pre);
tmp = gfc_create_var (TREE_TYPE (rse.expr), "ptrtemp");
gfc_add_modify (&lse.pre, tmp, rse.expr);
- gfc_add_vptr_component (expr1_vptr);
- gfc_init_se (&rse, NULL);
- rse.want_pointer = 1;
- gfc_conv_expr (&rse, expr1_vptr);
- gfc_add_modify (&lse.pre, rse.expr,
- fold_convert (TREE_TYPE (rse.expr),
+ gfc_add_modify (&lse.pre, expr1_vptr,
+ fold_convert (TREE_TYPE (expr1_vptr),
gfc_class_vptr_get (tmp)));
rse.expr = gfc_class_data_get (tmp);
}
@@ -8086,6 +8182,10 @@ gfc_trans_pointer_assignment (gfc_expr * expr1, gfc_expr * expr2)
{
gfc_conv_expr_descriptor (&rse, expr2);
strlen_rhs = rse.string_length;
+ if (expr1->ts.type == BT_CLASS)
+ expr1_vptr = trans_class_vptr_len_assignment (&block, expr1,
+ expr2, &rse,
+ NULL, NULL);
}
}
else if (expr2->expr_type == EXPR_VARIABLE)
@@ -8104,12 +8204,22 @@ gfc_trans_pointer_assignment (gfc_expr * expr1, gfc_expr * expr2)
gfc_init_se (&rse, NULL);
rse.descriptor_only = 1;
gfc_conv_expr (&rse, expr2);
+ if (expr1->ts.type == BT_CLASS)
+ trans_class_vptr_len_assignment (&block, expr1, expr2, &rse,
+ NULL, NULL);
tmp = gfc_get_element_type (TREE_TYPE (rse.expr));
tmp = fold_convert (gfc_array_index_type, size_in_bytes (tmp));
if (!INTEGER_CST_P (tmp))
gfc_add_block_to_block (&lse.post, &rse.pre);
gfc_add_modify (&lse.post, GFC_DECL_SPAN(decl), tmp);
}
+ else if (expr1->ts.type == BT_CLASS)
+ {
+ rse.expr = NULL_TREE;
+ rse.string_length = NULL_TREE;
+ trans_class_vptr_len_assignment (&block, expr1, expr2, &rse,
+ NULL, NULL);
+ }
}
else if (expr2->expr_type == EXPR_FUNCTION && expr2->ts.type == BT_CLASS)
{
@@ -8123,16 +8233,15 @@ gfc_trans_pointer_assignment (gfc_expr * expr1, gfc_expr * expr2)
}
else
{
+ expr1_vptr = trans_class_vptr_len_assignment (&block, expr1,
+ expr2, &rse, NULL,
+ NULL);
gfc_add_block_to_block (&block, &rse.pre);
tmp = gfc_create_var (TREE_TYPE (rse.expr), "ptrtemp");
gfc_add_modify (&lse.pre, tmp, rse.expr);
- gfc_add_vptr_component (expr1_vptr);
- gfc_init_se (&rse, NULL);
- rse.want_pointer = 1;
- gfc_conv_expr (&rse, expr1_vptr);
- gfc_add_modify (&lse.pre, rse.expr,
- fold_convert (TREE_TYPE (rse.expr),
+ gfc_add_modify (&lse.pre, expr1_vptr,
+ fold_convert (TREE_TYPE (expr1_vptr),
gfc_class_vptr_get (tmp)));
rse.expr = gfc_class_data_get (tmp);
gfc_add_modify (&lse.pre, desc, rse.expr);
@@ -8151,9 +8260,6 @@ gfc_trans_pointer_assignment (gfc_expr * expr1, gfc_expr * expr2)
gfc_add_modify (&lse.pre, desc, tmp);
}
- if (expr1_vptr)
- gfc_free_expr (expr1_vptr);
-
gfc_add_block_to_block (&block, &lse.pre);
if (rank_remap)
gfc_add_block_to_block (&block, &rse.pre);
@@ -8403,7 +8509,6 @@ gfc_trans_scalar_assign (gfc_se * lse, gfc_se * rse, gfc_typespec ts,
if (rse->string_length != NULL_TREE)
{
- gcc_assert (rse->string_length != NULL_TREE);
gfc_conv_string_parameter (rse);
gfc_add_block_to_block (&block, &rse->pre);
rlen = rse->string_length;
@@ -9359,14 +9464,101 @@ is_runtime_conformable (gfc_expr *expr1, gfc_expr *expr2)
return false;
}
+
+static tree
+trans_class_assignment (stmtblock_t *block, gfc_expr *lhs, gfc_expr *rhs,
+ gfc_se *lse, gfc_se *rse, bool use_vptr_copy)
+{
+ tree tmp;
+ tree fcn;
+ tree stdcopy, to_len, from_len;
+ vec<tree, va_gc> *args = NULL;
+
+ tmp = trans_class_vptr_len_assignment (block, lhs, rhs, rse, &to_len,
+ &from_len);
+
+ fcn = gfc_vptr_copy_get (tmp);
+
+ tmp = GFC_CLASS_TYPE_P (TREE_TYPE (rse->expr))
+ ? gfc_class_data_get (rse->expr) : rse->expr;
+ if (use_vptr_copy)
+ {
+ if (!POINTER_TYPE_P (TREE_TYPE (tmp))
+ || INDIRECT_REF_P (tmp)
+ || (rhs->ts.type == BT_DERIVED
+ && rhs->ts.u.derived->attr.unlimited_polymorphic
+ && !rhs->ts.u.derived->attr.pointer
+ && !rhs->ts.u.derived->attr.allocatable)
+ || (UNLIMITED_POLY (rhs)
+ && !CLASS_DATA (rhs)->attr.pointer
+ && !CLASS_DATA (rhs)->attr.allocatable))
+ vec_safe_push (args, gfc_build_addr_expr (NULL_TREE, tmp));
+ else
+ vec_safe_push (args, tmp);
+ tmp = GFC_CLASS_TYPE_P (TREE_TYPE (lse->expr))
+ ? gfc_class_data_get (lse->expr) : lse->expr;
+ if (!POINTER_TYPE_P (TREE_TYPE (tmp))
+ || INDIRECT_REF_P (tmp)
+ || (lhs->ts.type == BT_DERIVED
+ && lhs->ts.u.derived->attr.unlimited_polymorphic
+ && !lhs->ts.u.derived->attr.pointer
+ && !lhs->ts.u.derived->attr.allocatable)
+ || (UNLIMITED_POLY (lhs)
+ && !CLASS_DATA (lhs)->attr.pointer
+ && !CLASS_DATA (lhs)->attr.allocatable))
+ vec_safe_push (args, gfc_build_addr_expr (NULL_TREE, tmp));
+ else
+ vec_safe_push (args, tmp);
+
+ stdcopy = build_call_vec (TREE_TYPE (TREE_TYPE (fcn)), fcn, args);
+
+ if (to_len != NULL_TREE && !integer_zerop (from_len))
+ {
+ tree extcopy;
+ vec_safe_push (args, from_len);
+ vec_safe_push (args, to_len);
+ extcopy = build_call_vec (TREE_TYPE (TREE_TYPE (fcn)), fcn, args);
+
+ tmp = fold_build2_loc (input_location, GT_EXPR,
+ boolean_type_node, from_len,
+ integer_zero_node);
+ return fold_build3_loc (input_location, COND_EXPR,
+ void_type_node, tmp,
+ extcopy, stdcopy);
+ }
+ else
+ return stdcopy;
+ }
+ else
+ {
+ tree rhst = GFC_CLASS_TYPE_P (TREE_TYPE (lse->expr))
+ ? gfc_class_data_get (lse->expr) : lse->expr;
+ stmtblock_t tblock;
+ gfc_init_block (&tblock);
+ if (!POINTER_TYPE_P (TREE_TYPE (tmp)))
+ tmp = gfc_build_addr_expr (NULL_TREE, tmp);
+ if (!POINTER_TYPE_P (TREE_TYPE (rhst)))
+ rhst = gfc_build_addr_expr (NULL_TREE, rhst);
+ /* When coming from a ptr_copy lhs and rhs are swapped. */
+ gfc_add_modify_loc (input_location, &tblock, rhst,
+ fold_convert (TREE_TYPE (rhst), tmp));
+ return gfc_finish_block (&tblock);
+ }
+}
+
/* Subroutine of gfc_trans_assignment that actually scalarizes the
assignment. EXPR1 is the destination/LHS and EXPR2 is the source/RHS.
init_flag indicates initialization expressions and dealloc that no
- deallocate prior assignment is needed (if in doubt, set true). */
+ deallocate prior assignment is needed (if in doubt, set true).
+ When PTR_COPY is set and expr1 is a class type, then use the _vptr-copy
+ routine instead of a pointer assignment. Alias resolution is only done,
+ when MAY_ALIAS is set (the default). This flag is used by ALLOCATE()
+ where it is known, that newly allocated memory on the lhs can never be
+ an alias of the rhs. */
static tree
gfc_trans_assignment_1 (gfc_expr * expr1, gfc_expr * expr2, bool init_flag,
- bool dealloc)
+ bool dealloc, bool use_vptr_copy, bool may_alias)
{
gfc_se lse;
gfc_se rse;
@@ -9382,7 +9574,7 @@ gfc_trans_assignment_1 (gfc_expr * expr1, gfc_expr * expr2, bool init_flag,
tree string_length;
int n;
bool maybe_workshare = false;
- symbol_attribute lhs_caf_attr, rhs_caf_attr;
+ symbol_attribute lhs_caf_attr, rhs_caf_attr, lhs_attr;
/* Assignment of the form lhs = rhs. */
gfc_start_block (&block);
@@ -9403,8 +9595,13 @@ gfc_trans_assignment_1 (gfc_expr * expr1, gfc_expr * expr2, bool init_flag,
|| gfc_is_alloc_class_scalar_function (expr2)))
expr2->must_finalize = 1;
- lhs_caf_attr = gfc_caf_attr (expr1);
- rhs_caf_attr = gfc_caf_attr (expr2);
+ /* Only analyze the expressions for coarray properties, when in coarray-lib
+ mode. */
+ if (flag_coarray == GFC_FCOARRAY_LIB)
+ {
+ lhs_caf_attr = gfc_caf_attr (expr1);
+ rhs_caf_attr = gfc_caf_attr (expr2);
+ }
if (lss != gfc_ss_terminator)
{
@@ -9437,7 +9634,8 @@ gfc_trans_assignment_1 (gfc_expr * expr1, gfc_expr * expr2, bool init_flag,
for (n = 0; n < GFC_MAX_DIMENSIONS; n++)
loop.reverse[n] = GFC_ENABLE_REVERSE;
/* Resolve any data dependencies in the statement. */
- gfc_conv_resolve_dependencies (&loop, lss, rss);
+ if (may_alias)
+ gfc_conv_resolve_dependencies (&loop, lss, rss);
/* Setup the scalarizing loops. */
gfc_conv_loop_setup (&loop, &expr2->where);
@@ -9584,9 +9782,26 @@ gfc_trans_assignment_1 (gfc_expr * expr1, gfc_expr * expr2, bool init_flag,
gfc_add_block_to_block (&loop.post, &rse.post);
}
- if (flag_coarray == GFC_FCOARRAY_LIB
- && lhs_caf_attr.codimension && rhs_caf_attr.codimension
- && lhs_caf_attr.alloc_comp && rhs_caf_attr.alloc_comp)
+ lhs_attr = gfc_expr_attr (expr1);
+ if ((use_vptr_copy || lhs_attr.pointer
+ || (lhs_attr.allocatable && !lhs_attr.dimension))
+ && (expr1->ts.type == BT_CLASS
+ || (gfc_is_class_array_ref (expr1, NULL)
+ || gfc_is_class_scalar_expr (expr1))
+ || (gfc_is_class_array_ref (expr2, NULL)
+ || gfc_is_class_scalar_expr (expr2))))
+ {
+ tmp = trans_class_assignment (&body, expr1, expr2, &lse, &rse,
+ use_vptr_copy || (lhs_attr.allocatable
+ && !lhs_attr.dimension));
+ /* Modify the expr1 after the assignment, to allow the realloc below.
+ Therefore only needed, when realloc_lhs is enabled. */
+ if (flag_realloc_lhs && !lhs_attr.pointer)
+ gfc_add_data_component (expr1);
+ }
+ else if (flag_coarray == GFC_FCOARRAY_LIB
+ && lhs_caf_attr.codimension && rhs_caf_attr.codimension
+ && lhs_caf_attr.alloc_comp && rhs_caf_attr.alloc_comp)
{
gfc_code code;
gfc_actual_arglist a1, a2;
@@ -9604,7 +9819,13 @@ gfc_trans_assignment_1 (gfc_expr * expr1, gfc_expr * expr2, bool init_flag,
|| scalar_to_array
|| expr2->expr_type == EXPR_ARRAY,
!(l_is_temp || init_flag) && dealloc);
+ /* Add the pre blocks to the body. */
+ gfc_add_block_to_block (&body, &rse.pre);
+ gfc_add_block_to_block (&body, &lse.pre);
gfc_add_expr_to_block (&body, tmp);
+ /* Add the post blocks to the body. */
+ gfc_add_block_to_block (&body, &rse.post);
+ gfc_add_block_to_block (&body, &lse.post);
if (lss == gfc_ss_terminator)
{
@@ -9719,7 +9940,7 @@ copyable_array_p (gfc_expr * expr)
tree
gfc_trans_assignment (gfc_expr * expr1, gfc_expr * expr2, bool init_flag,
- bool dealloc)
+ bool dealloc, bool use_vptr_copy, bool may_alias)
{
tree tmp;
@@ -9762,7 +9983,8 @@ gfc_trans_assignment (gfc_expr * expr1, gfc_expr * expr2, bool init_flag,
}
/* Fallback to the scalarizer to generate explicit loops. */
- return gfc_trans_assignment_1 (expr1, expr2, init_flag, dealloc);
+ return gfc_trans_assignment_1 (expr1, expr2, init_flag, dealloc,
+ use_vptr_copy, may_alias);
}
tree
diff --git a/gcc/fortran/trans-stmt.c b/gcc/fortran/trans-stmt.c
index ef5153e..4280b77 100644
--- a/gcc/fortran/trans-stmt.c
+++ b/gcc/fortran/trans-stmt.c
@@ -5439,7 +5439,10 @@ gfc_trans_allocate (gfc_code * code)
if (code->expr3->rank != 0
&& ((!attr.allocatable && !attr.pointer)
|| (code->expr3->expr_type == EXPR_FUNCTION
- && code->expr3->ts.type != BT_CLASS)))
+ && (code->expr3->ts.type != BT_CLASS
+ || (code->expr3->value.function.isym
+ && code->expr3->value.function.isym
+ ->transformational)))))
gfc_conv_expr_descriptor (&se, code->expr3);
else
gfc_conv_expr_reference (&se, code->expr3);
@@ -5623,73 +5626,6 @@ gfc_trans_allocate (gfc_code * code)
else
expr3_esize = TYPE_SIZE_UNIT (
gfc_typenode_for_spec (&code->expr3->ts));
-
- /* The routine gfc_trans_assignment () already implements all
- techniques needed. Unfortunately we may have a temporary
- variable for the source= expression here. When that is the
- case convert this variable into a temporary gfc_expr of type
- EXPR_VARIABLE and used it as rhs for the assignment. The
- advantage is, that we get scalarizer support for free,
- don't have to take care about scalar to array treatment and
- will benefit of every enhancements gfc_trans_assignment ()
- gets.
- No need to check whether e3_is is E3_UNSET, because that is
- done by expr3 != NULL_TREE.
- Exclude variables since the following block does not handle
- array sections. In any case, there is no harm in sending
- variables to gfc_trans_assignment because there is no
- evaluation of variables. */
- if (code->expr3->expr_type != EXPR_VARIABLE
- && e3_is != E3_MOLD && expr3 != NULL_TREE
- && DECL_P (expr3) && DECL_ARTIFICIAL (expr3))
- {
- /* Build a temporary symtree and symbol. Do not add it to
- the current namespace to prevent accidently modifying
- a colliding symbol's as. */
- newsym = XCNEW (gfc_symtree);
- /* The name of the symtree should be unique, because
- gfc_create_var () took care about generating the
- identifier. */
- newsym->name = gfc_get_string (IDENTIFIER_POINTER (
- DECL_NAME (expr3)));
- newsym->n.sym = gfc_new_symbol (newsym->name, NULL);
- /* The backend_decl is known. It is expr3, which is inserted
- here. */
- newsym->n.sym->backend_decl = expr3;
- e3rhs = gfc_get_expr ();
- e3rhs->ts = code->expr3->ts;
- e3rhs->rank = code->expr3->rank;
- e3rhs->symtree = newsym;
- /* Mark the symbol referenced or gfc_trans_assignment will
- bug. */
- newsym->n.sym->attr.referenced = 1;
- e3rhs->expr_type = EXPR_VARIABLE;
- e3rhs->where = code->expr3->where;
- /* Set the symbols type, upto it was BT_UNKNOWN. */
- newsym->n.sym->ts = e3rhs->ts;
- /* Check whether the expr3 is array valued. */
- if (e3rhs->rank)
- {
- gfc_array_spec *arr;
- arr = gfc_get_array_spec ();
- arr->rank = e3rhs->rank;
- arr->type = AS_DEFERRED;
- /* Set the dimension and pointer attribute for arrays
- to be on the safe side. */
- newsym->n.sym->attr.dimension = 1;
- newsym->n.sym->attr.pointer = 1;
- newsym->n.sym->as = arr;
- gfc_add_full_array_ref (e3rhs, arr);
- }
- else if (POINTER_TYPE_P (TREE_TYPE (expr3)))
- newsym->n.sym->attr.pointer = 1;
- /* The string length is known to. Set it for char arrays. */
- if (e3rhs->ts.type == BT_CHARACTER)
- newsym->n.sym->ts.u.cl->backend_decl = expr3_len;
- gfc_commit_symbol (newsym->n.sym);
- }
- else
- e3rhs = gfc_copy_expr (code->expr3);
}
gcc_assert (expr3_esize);
expr3_esize = fold_convert (sizetype, expr3_esize);
@@ -5723,6 +5659,95 @@ gfc_trans_allocate (gfc_code * code)
}
}
+ /* The routine gfc_trans_assignment () already implements all
+ techniques needed. Unfortunately we may have a temporary
+ variable for the source= expression here. When that is the
+ case convert this variable into a temporary gfc_expr of type
+ EXPR_VARIABLE and used it as rhs for the assignment. The
+ advantage is, that we get scalarizer support for free,
+ don't have to take care about scalar to array treatment and
+ will benefit of every enhancements gfc_trans_assignment ()
+ gets.
+ No need to check whether e3_is is E3_UNSET, because that is
+ done by expr3 != NULL_TREE.
+ Exclude variables since the following block does not handle
+ array sections. In any case, there is no harm in sending
+ variables to gfc_trans_assignment because there is no
+ evaluation of variables. */
+ if (code->expr3)
+ {
+ if (code->expr3->expr_type != EXPR_VARIABLE
+ && e3_is != E3_MOLD && expr3 != NULL_TREE
+ && DECL_P (expr3) && DECL_ARTIFICIAL (expr3))
+ {
+ /* Build a temporary symtree and symbol. Do not add it to the current
+ namespace to prevent accidently modifying a colliding
+ symbol's as. */
+ newsym = XCNEW (gfc_symtree);
+ /* The name of the symtree should be unique, because gfc_create_var ()
+ took care about generating the identifier. */
+ newsym->name = gfc_get_string (IDENTIFIER_POINTER (
+ DECL_NAME (expr3)));
+ newsym->n.sym = gfc_new_symbol (newsym->name, NULL);
+ /* The backend_decl is known. It is expr3, which is inserted
+ here. */
+ newsym->n.sym->backend_decl = expr3;
+ e3rhs = gfc_get_expr ();
+ e3rhs->rank = code->expr3->rank;
+ e3rhs->symtree = newsym;
+ /* Mark the symbol referenced or gfc_trans_assignment will bug. */
+ newsym->n.sym->attr.referenced = 1;
+ e3rhs->expr_type = EXPR_VARIABLE;
+ e3rhs->where = code->expr3->where;
+ /* Set the symbols type, upto it was BT_UNKNOWN. */
+ if (IS_CLASS_ARRAY (code->expr3)
+ && code->expr3->expr_type == EXPR_FUNCTION
+ && code->expr3->value.function.isym
+ && code->expr3->value.function.isym->transformational)
+ {
+ e3rhs->ts = CLASS_DATA (code->expr3)->ts;
+ }
+ else if (code->expr3->ts.type == BT_CLASS
+ && !GFC_CLASS_TYPE_P (TREE_TYPE (expr3)))
+ e3rhs->ts = CLASS_DATA (code->expr3)->ts;
+ else
+ e3rhs->ts = code->expr3->ts;
+ newsym->n.sym->ts = e3rhs->ts;
+ /* Check whether the expr3 is array valued. */
+ if (e3rhs->rank)
+ {
+ gfc_array_spec *arr;
+ arr = gfc_get_array_spec ();
+ arr->rank = e3rhs->rank;
+ arr->type = AS_DEFERRED;
+ /* Set the dimension and pointer attribute for arrays
+ to be on the safe side. */
+ newsym->n.sym->attr.dimension = 1;
+ newsym->n.sym->attr.pointer = 1;
+ newsym->n.sym->as = arr;
+ if (IS_CLASS_ARRAY (code->expr3)
+ && code->expr3->expr_type == EXPR_FUNCTION
+ && code->expr3->value.function.isym
+ && code->expr3->value.function.isym->transformational)
+ {
+ gfc_array_spec *tarr;
+ tarr = gfc_get_array_spec ();
+ *tarr = *arr;
+ e3rhs->ts.u.derived->as = tarr;
+ }
+ gfc_add_full_array_ref (e3rhs, arr);
+ }
+ else if (POINTER_TYPE_P (TREE_TYPE (expr3)))
+ newsym->n.sym->attr.pointer = 1;
+ /* The string length is known to. Set it for char arrays. */
+ if (e3rhs->ts.type == BT_CHARACTER)
+ newsym->n.sym->ts.u.cl->backend_decl = expr3_len;
+ gfc_commit_symbol (newsym->n.sym);
+ }
+ else
+ e3rhs = gfc_copy_expr (code->expr3);
+ }
+
/* Loop over all objects to allocate. */
for (al = code->ext.alloc.list; al != NULL; al = al->next)
{
@@ -5960,8 +5985,9 @@ gfc_trans_allocate (gfc_code * code)
gfc_add_expr_to_block (&block, tmp);
}
- /* Set the vptr. */
- if (al_vptr != NULL_TREE)
+ /* Set the vptr only when no source= is set. When source= is set, then
+ the trans_assignment below will set the vptr. */
+ if (al_vptr != NULL_TREE && (!code->expr3 || code->expr3->mold))
{
if (expr3_vptr != NULL_TREE)
/* The vtab is already known, so just assign it. */
@@ -6046,153 +6072,34 @@ gfc_trans_allocate (gfc_code * code)
if (code->expr3 && !code->expr3->mold && e3_is != E3_MOLD)
{
/* Initialization via SOURCE block (or static default initializer).
- Classes need some special handling, so catch them first. */
- if (expr3 != NULL_TREE
- && TREE_CODE (expr3) != POINTER_PLUS_EXPR
- && code->expr3->ts.type == BT_CLASS
- && (expr->ts.type == BT_CLASS
- || expr->ts.type == BT_DERIVED))
- {
- /* copy_class_to_class can be used for class arrays, too.
- It just needs to be ensured, that the decl_saved_descriptor
- has a way to get to the vptr. */
- tree to;
- to = VAR_P (se.expr) ? se.expr : TREE_OPERAND (se.expr, 0);
- tmp = gfc_copy_class_to_class (expr3, to,
- nelems, upoly_expr);
- }
- else if (al->expr->ts.type == BT_CLASS)
- {
- gfc_actual_arglist *actual, *last_arg;
- gfc_expr *ppc;
- gfc_code *ppc_code;
- gfc_ref *ref, *dataref;
- gfc_expr *rhs = e3rhs ? e3rhs : gfc_copy_expr (code->expr3);
-
- /* Do a polymorphic deep copy. */
- actual = gfc_get_actual_arglist ();
- actual->expr = gfc_copy_expr (rhs);
- if (rhs->ts.type == BT_CLASS)
- gfc_add_data_component (actual->expr);
- last_arg = actual->next = gfc_get_actual_arglist ();
- last_arg->expr = gfc_copy_expr (al->expr);
- last_arg->expr->ts.type = BT_CLASS;
- gfc_add_data_component (last_arg->expr);
-
- dataref = NULL;
- /* Make sure we go up through the reference chain to
- the _data reference, where the arrayspec is found. */
- for (ref = last_arg->expr->ref; ref; ref = ref->next)
- if (ref->type == REF_COMPONENT
- && strcmp (ref->u.c.component->name, "_data") == 0)
- dataref = ref;
-
- if (dataref && dataref->u.c.component->as)
- {
- gfc_array_spec *as = dataref->u.c.component->as;
- gfc_free_ref_list (dataref->next);
- dataref->next = NULL;
- gfc_add_full_array_ref (last_arg->expr, as);
- gfc_resolve_expr (last_arg->expr);
- gcc_assert (last_arg->expr->ts.type == BT_CLASS
- || last_arg->expr->ts.type == BT_DERIVED);
- last_arg->expr->ts.type = BT_CLASS;
- }
- if (rhs->ts.type == BT_CLASS)
- {
- if (rhs->ref)
- ppc = gfc_find_and_cut_at_last_class_ref (rhs);
- else
- ppc = gfc_copy_expr (rhs);
- gfc_add_vptr_component (ppc);
- }
- else
- ppc = gfc_lval_expr_from_sym (gfc_find_vtab (&rhs->ts));
- gfc_add_component_ref (ppc, "_copy");
-
- ppc_code = gfc_get_code (EXEC_CALL);
- ppc_code->resolved_sym = ppc->symtree->n.sym;
- ppc_code->loc = al->expr->where;
- /* Although '_copy' is set to be elemental in class.c, it is
- not staying that way. Find out why, sometime.... */
- ppc_code->resolved_sym->attr.elemental = 1;
- ppc_code->ext.actual = actual;
- ppc_code->expr1 = ppc;
- /* Since '_copy' is elemental, the scalarizer will take care
- of arrays in gfc_trans_call. */
- tmp = gfc_trans_call (ppc_code, true, NULL, NULL, false);
- /* We need to add the
- if (al_len > 0)
- al_vptr->copy (expr3_data, al_data, expr3_len, al_len);
- else
- al_vptr->copy (expr3_data, al_data);
- block, because al is unlimited polymorphic or a deferred
- length char array, whose copy routine needs the array lengths
- as third and fourth arguments. */
- if (al_len && UNLIMITED_POLY (code->expr3))
- {
- tree stdcopy, extcopy;
- /* Add al%_len. */
- last_arg->next = gfc_get_actual_arglist ();
- last_arg = last_arg->next;
- last_arg->expr = gfc_find_and_cut_at_last_class_ref (
- al->expr);
- gfc_add_len_component (last_arg->expr);
- /* Add expr3's length. */
- last_arg->next = gfc_get_actual_arglist ();
- last_arg = last_arg->next;
- if (code->expr3->ts.type == BT_CLASS)
- {
- last_arg->expr =
- gfc_find_and_cut_at_last_class_ref (code->expr3);
- gfc_add_len_component (last_arg->expr);
- }
- else if (code->expr3->ts.type == BT_CHARACTER)
- last_arg->expr =
- gfc_copy_expr (code->expr3->ts.u.cl->length);
- else
- gcc_unreachable ();
-
- stdcopy = tmp;
- extcopy = gfc_trans_call (ppc_code, true, NULL, NULL, false);
-
- tmp = fold_build2_loc (input_location, GT_EXPR,
- boolean_type_node, expr3_len,
- integer_zero_node);
- tmp = fold_build3_loc (input_location, COND_EXPR,
- void_type_node, tmp, extcopy, stdcopy);
- }
- gfc_free_statements (ppc_code);
- if (rhs != e3rhs)
- gfc_free_expr (rhs);
- }
- else
- {
- /* Switch off automatic reallocation since we have just
- done the ALLOCATE. */
- int realloc_lhs = flag_realloc_lhs;
- gfc_expr *init_expr = gfc_expr_to_initialize (expr);
- flag_realloc_lhs = 0;
- tmp = gfc_trans_assignment (init_expr, e3rhs, false, false);
- flag_realloc_lhs = realloc_lhs;
- /* Free the expression allocated for init_expr. */
- gfc_free_expr (init_expr);
- }
+ Switch off automatic reallocation since we have just done the
+ ALLOCATE. */
+ int realloc_lhs = flag_realloc_lhs;
+ gfc_expr *init_expr = gfc_expr_to_initialize (expr);
+ gfc_expr *rhs = e3rhs ? e3rhs : gfc_copy_expr (code->expr3);
+ flag_realloc_lhs = 0;
+ tmp = gfc_trans_assignment (init_expr, rhs, false, false, true,
+ false);
+ flag_realloc_lhs = realloc_lhs;
+ /* Free the expression allocated for init_expr. */
+ gfc_free_expr (init_expr);
+ if (rhs != e3rhs)
+ gfc_free_expr (rhs);
gfc_add_expr_to_block (&block, tmp);
}
- else if (code->expr3 && code->expr3->mold
- && code->expr3->ts.type == BT_CLASS)
+ else if (code->expr3 && code->expr3->mold
+ && code->expr3->ts.type == BT_CLASS)
{
- /* Since the _vptr has already been assigned to the allocate
- object, we can use gfc_copy_class_to_class in its
- initialization mode. */
- tmp = TREE_OPERAND (se.expr, 0);
- tmp = gfc_copy_class_to_class (NULL_TREE, tmp, nelems,
- upoly_expr);
+ /* Use class_init_assign to initialize expr. */
+ gfc_code *ini;
+ ini = gfc_get_code (EXEC_INIT_ASSIGN);
+ ini->expr1 = gfc_find_and_cut_at_last_class_ref (expr);
+ tmp = gfc_trans_class_init_assign (ini);
+ gfc_free_statements (ini);
gfc_add_expr_to_block (&block, tmp);
}
- gfc_free_expr (expr);
+ gfc_free_expr (expr);
} // for-loop
if (e3rhs)
diff --git a/gcc/fortran/trans-stmt.h b/gcc/fortran/trans-stmt.h
index f9c8e74..e4d4a67 100644
--- a/gcc/fortran/trans-stmt.h
+++ b/gcc/fortran/trans-stmt.h
@@ -32,7 +32,6 @@ tree gfc_trans_assign (gfc_code *);
tree gfc_trans_pointer_assign (gfc_code *);
tree gfc_trans_init_assign (gfc_code *);
tree gfc_trans_class_init_assign (gfc_code *);
-tree gfc_trans_class_assign (gfc_expr *, gfc_expr *, gfc_exec_op);
/* trans-stmt.c */
tree gfc_trans_cycle (gfc_code *);
diff --git a/gcc/fortran/trans.c b/gcc/fortran/trans.c
index 9210e0f..fba0d9a 100644
--- a/gcc/fortran/trans.c
+++ b/gcc/fortran/trans.c
@@ -1704,10 +1704,7 @@ trans_code (gfc_code * code, tree cond)
break;
case EXEC_ASSIGN:
- if (code->expr1->ts.type == BT_CLASS)
- res = gfc_trans_class_assign (code->expr1, code->expr2, code->op);
- else
- res = gfc_trans_assign (code);
+ res = gfc_trans_assign (code);
break;
case EXEC_LABEL_ASSIGN:
@@ -1715,16 +1712,7 @@ trans_code (gfc_code * code, tree cond)
break;
case EXEC_POINTER_ASSIGN:
- if (code->expr1->ts.type == BT_CLASS)
- res = gfc_trans_class_assign (code->expr1, code->expr2, code->op);
- else if (UNLIMITED_POLY (code->expr2)
- && code->expr1->ts.type == BT_DERIVED
- && (code->expr1->ts.u.derived->attr.sequence
- || code->expr1->ts.u.derived->attr.is_bind_c))
- /* F2003: C717 */
- res = gfc_trans_class_assign (code->expr1, code->expr2, code->op);
- else
- res = gfc_trans_pointer_assign (code);
+ res = gfc_trans_pointer_assign (code);
break;
case EXEC_INIT_ASSIGN:
diff --git a/gcc/fortran/trans.h b/gcc/fortran/trans.h
index 4d3d207..f76fff8 100644
--- a/gcc/fortran/trans.h
+++ b/gcc/fortran/trans.h
@@ -699,7 +699,8 @@ tree gfc_call_realloc (stmtblock_t *, tree, tree);
tree gfc_trans_structure_assign (tree, gfc_expr *, bool);
/* Generate code for an assignment, includes scalarization. */
-tree gfc_trans_assignment (gfc_expr *, gfc_expr *, bool, bool);
+tree gfc_trans_assignment (gfc_expr *, gfc_expr *, bool, bool, bool p = false,
+ bool a = true);
/* Generate code for a pointer assignment. */
tree gfc_trans_pointer_assignment (gfc_expr *, gfc_expr *);
diff --git a/gcc/testsuite/gfortran.dg/alloc_comp_class_5.f03 b/gcc/testsuite/gfortran.dg/alloc_comp_class_5.f03
new file mode 100644
index 0000000..1d9450f
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/alloc_comp_class_5.f03
@@ -0,0 +1,74 @@
+! { dg-do run }
+!
+! Contributed by Vladimir Fuka
+! Check that pr61337 is fixed.
+
+module array_list
+
+ type container
+ class(*), allocatable :: items(:)
+ end type
+
+contains
+
+ subroutine add_item(a, e)
+ type(container),allocatable,intent(inout) :: a(:)
+ class(*),intent(in) :: e(:)
+ type(container),allocatable :: tmp(:)
+
+ if (.not.allocated(a)) then
+ allocate(a(1))
+ allocate(a(1)%items(size(e)), source = e)
+ else
+ call move_alloc(a,tmp)
+ allocate(a(size(tmp)+1))
+ a(1:size(tmp)) = tmp
+ allocate(a(size(tmp)+1)%items(size(e)), source=e)
+ end if
+ end subroutine
+
+end module
+
+program test_pr61337
+
+ use array_list
+
+ type(container), allocatable :: a_list(:)
+ integer(kind = 8) :: i
+
+ call add_item(a_list, [1, 2])
+ call add_item(a_list, [3.0_8, 4.0_8])
+ call add_item(a_list, [.true., .false.])
+! call add_item(a_list, ["bar", "foo", "bla"])
+
+ if (size(a_list) /= 3) call abort()
+ do i = 1, size(a_list)
+ call checkarr(a_list(i))
+ end do
+
+ deallocate(a_list)
+
+contains
+
+ subroutine checkarr(c)
+ type(container) :: c
+
+ if (allocated(c%items)) then
+ select type (x=>c%items)
+ type is (integer)
+ if (any(x /= [1, 2])) call abort()
+ type is (real(kind=8))
+ if (any(x /= [3.0_8, 4.0_8])) call abort()
+ type is (logical)
+ if (any(x .neqv. [.true., .false.])) call abort()
+! TODO: ICE when the next line is present, pr???
+! type is (character(len=:))
+! if (any(x /= ["bar", "foo", "bla"])) call abort()
+ class default
+ call abort()
+ end select
+ else
+ call abort()
+ end if
+ end subroutine
+end
diff --git a/gcc/testsuite/gfortran.dg/class_allocate_21.f90 b/gcc/testsuite/gfortran.dg/class_allocate_21.f90
new file mode 100644
index 0000000..a8ed291
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/class_allocate_21.f90
@@ -0,0 +1,21 @@
+! { dg-do run }
+!
+! Testcase for pr57117
+
+implicit none
+
+ type :: ti
+ integer :: i
+ end type
+
+ class(ti), allocatable :: x(:,:), z(:)
+ integer :: i
+
+ allocate(x(3,3))
+ x%i = reshape([( i, i = 1, 9 )], [3, 3])
+ allocate(z(9), source=reshape(x, (/ 9 /)))
+
+ if (any( z%i /= [( i, i = 1, 9 )])) call abort()
+ deallocate (x, z)
+end
+
diff --git a/gcc/testsuite/gfortran.dg/class_allocate_22.f90 b/gcc/testsuite/gfortran.dg/class_allocate_22.f90
new file mode 100644
index 0000000..5fec72f
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/class_allocate_22.f90
@@ -0,0 +1,26 @@
+! { dg-do run }
+!
+! Check pr57117 is fixed.
+
+program pr57117
+ implicit none
+
+ type :: ti
+ integer :: i
+ end type
+
+ class(ti), allocatable :: x(:,:), y(:,:)
+ integer :: i
+
+ allocate(x(2,6))
+ select type (x)
+ class is (ti)
+ x%i = reshape([(i,i=1, 12)],[2,6])
+ end select
+ allocate(y, source=transpose(x))
+
+ if (any( ubound(y) /= [6,2])) call abort()
+ if (any(reshape(y(:,:)%i, [12]) /= [ 1,3,5,7,9,11, 2,4,6,8,10,12])) call abort()
+ deallocate (x,y)
+end
+
diff --git a/gcc/testsuite/gfortran.dg/realloc_on_assign_27.f08 b/gcc/testsuite/gfortran.dg/realloc_on_assign_27.f08
new file mode 100644
index 0000000..53b8330
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/realloc_on_assign_27.f08
@@ -0,0 +1,24 @@
+! { dg-do run }
+
+ type :: t
+ integer :: i
+ end type
+
+ type, extends(t) :: r
+ real :: r
+ end type
+
+ class(t), allocatable :: x
+ class(r), allocatable :: foo ! Need this declared of copy_R is not generated.
+ type(r) :: y = r (3, 42)
+
+ x = y
+ if (x%i /= 3) call abort()
+ select type(x)
+ class is (r)
+ if (x%r /= 42.0) call abort()
+ class default
+ call abort()
+ end select
+end
+
^ permalink raw reply [flat|nested] 8+ messages in thread
* [Fortran, Patch, PR{43366, 57117, 61337, 61376}, v1] Assign to polymorphic objects.
@ 2016-10-13 12:42 Andre Vehreschild
2016-10-19 17:37 ` Andre Vehreschild
0 siblings, 1 reply; 8+ messages in thread
From: Andre Vehreschild @ 2016-10-13 12:42 UTC (permalink / raw)
To: GCC-Patches-ML, GCC-Fortran-ML
[-- Attachment #1: Type: text/plain, Size: 2147 bytes --]
Hi all,
attached patch fixes the PRs (as to my knowledge):
PR43366 - [OOP][F08] Intrinsic assign to polymorphic variable
PR57117 - [OOP] ICE for sourced allocation of a polymorphic entity using
TRANSPOSE
PR61337 - Wrong indexing and runtime crash with unlimited polymorphic array.
PR61378 - Error using private statement in polymorphic derived type
The latter two are more or less fixed by accident or have been fixed by
previous patches, but have not been identified as such. Anyway, they are fixed
now and will be closed once the patch hits trunk.
As for PR43366: I did not indent to fix this one, but when going for PR57117 I
once again stumbled over the deficiencies of gfc_trans_assigment's handling of
class objects. Therefore I figured what would be needed to complete PR43366 and
this is it now.
As for PR57117: The issue was that ALLOCATE () used gfc_copy_class_to_class ()
when a class object was allocated. The function gfc_copy_class_to_class () does
not use the scalarizer correctly. I.e., a transpose of the source= expression
would not be respected. I therefore decided to remove all this special casing
for class objects in ALLOCATE () and let gfc_trans_assignment do the trick.
This way ensuring, that any improvements of the scalarizer will benefit class
objects, too. Unfortunately did this mean to add more logic to
gfc_trans_assignment. While doing so, I learned that existing wrappers for
class assignments were obsoleted by the work I did, so I removed them.
I tried to get rid of the malicious copy_class_to_class, too, but at the moment
it is still used at one location where components of derived types are
assigned. I was not bold enough to replace this occurrence with
trans_assignment yet.
This patch shall make our lives easier, because now there is one routine to
assign all sorts of objects and no special casing for class objects is needed
anymore. I expect that some other parts of gfortran's code base may benefit from
the changes and have their complexity reduced.
Bootstrapped and regtested ok on x86_64-linux/F23. Ok for trunk?
Regards,
Andre
--
Andre Vehreschild * Email: vehre ad gmx dot de
[-- Attachment #2: pr43366_1.clog --]
[-- Type: application/octet-stream, Size: 2376 bytes --]
gcc/fortran/ChangeLog:
2016-10-13 Andre Vehreschild <vehre@gcc.gnu.org>
PR fortran/43366
PR fortran/57117
PR fortran/61337
PR fortran/61376
* primary.c (gfc_expr_attr): For transformational functions on classes
get the attrs from the class argument.
* resolve.c (resolve_ordinary_assign): Remove error message due to
feature implementation. Rewrite POINTER_ASSIGNS to ordinary ones when
the right-hand side is scalar class object (with some restrictions).
* trans-array.c (trans_array_constructor): Create the temporary from
class' inner type, i.e., the derived type.
(build_class_array_ref): Add support for class array's storage of the
class object or the array descriptor in the decl saved descriptor.
(gfc_conv_expr_descriptor): When creating temporaries for class objects
add the class object's handle into the decl saved descriptor.
(gfc_is_reallocatable_lhs): Add notion of allocatable class objects.
* trans-expr.c (gfc_find_and_cut_at_last_class_ref): Remove the only ref
only when the expression's type is BT_CLASS.
(gfc_trans_class_init_assign): Correctly handle class arrays.
(gfc_trans_class_assign): Joined into gfc_trans_assignment_1.
(gfc_conv_procedure_call): Support for class types as arguments.
(trans_get_upoly_len): For unlimited polymorphics retrieve the _len
component's tree.
(trans_class_vptr_len_assignment): Catch all ways to assign the _vptr
and _len components of a class object correctly.
(pointer_assignment_is_proc_pointer): Identify assignments of
procedure pointers.
(gfc_trans_pointer_assignment): Enhance support for class object pointer
assignments.
(gfc_trans_scalar_assign): Removed assert.
(trans_class_assignment): Assign to a class object.
(gfc_trans_assignment_1): Treat class objects correctly.
(gfc_trans_assignment): Propagate flags to trans_assignment_1.
* trans-stmt.c (gfc_trans_allocate): Use gfc_trans_assignment now
instead of copy_class_to_class.
* trans-stmt.h: Function prototype removed.
* trans.c (trans_code): Less special casing for class objects.
* trans.h: Added flags to gfc_trans_assignment () prototype.
gcc/testsuite/ChangeLog:
2016-10-13 Andre Vehreschild <vehre@gcc.gnu.org>
PR fortran/43366
PR fortran/57117
* gfortran.dg/class_allocate_21.f90: New test.
* gfortran.dg/class_allocate_22.f90: New test.
* gfortran.dg/realloc_on_assign_27.f08: New test.
[-- Attachment #3: pr43366_1.patch --]
[-- Type: text/x-patch, Size: 53566 bytes --]
diff --git a/gcc/fortran/primary.c b/gcc/fortran/primary.c
index 85589ee..3803b88 100644
--- a/gcc/fortran/primary.c
+++ b/gcc/fortran/primary.c
@@ -2359,6 +2359,10 @@ gfc_expr_attr (gfc_expr *e)
attr.allocatable = CLASS_DATA (sym)->attr.allocatable;
}
}
+ else if (e->value.function.isym
+ && e->value.function.isym->transformational
+ && e->ts.type == BT_CLASS)
+ attr = CLASS_DATA (e)->attr;
else
attr = gfc_variable_attr (e, NULL);
diff --git a/gcc/fortran/resolve.c b/gcc/fortran/resolve.c
index 4645b57..42e3421 100644
--- a/gcc/fortran/resolve.c
+++ b/gcc/fortran/resolve.c
@@ -9829,10 +9829,6 @@ resolve_ordinary_assign (gfc_code *code, gfc_namespace *ns)
"requires %<-frealloc-lhs%>", &lhs->where);
return false;
}
- /* See PR 43366. */
- gfc_error ("Assignment to an allocatable polymorphic variable at %L "
- "is not yet supported", &lhs->where);
- return false;
}
else if (lhs->ts.type == BT_CLASS)
{
@@ -10735,6 +10731,19 @@ start:
break;
gfc_check_pointer_assign (code->expr1, code->expr2);
+
+ /* Assigning a class object always is a regular assign. */
+ if (code->expr2->ts.type == BT_CLASS
+ && !CLASS_DATA (code->expr2)->attr.dimension
+ && !(UNLIMITED_POLY (code->expr2)
+ && code->expr1->ts.type == BT_DERIVED
+ && (code->expr1->ts.u.derived->attr.sequence
+ || code->expr1->ts.u.derived->attr.is_bind_c))
+ && !(gfc_expr_attr (code->expr1).proc_pointer
+ && code->expr2->expr_type == EXPR_VARIABLE
+ && code->expr2->symtree->n.sym->attr.flavor
+ == FL_PROCEDURE))
+ code->op = EXEC_ASSIGN;
break;
}
diff --git a/gcc/fortran/trans-array.c b/gcc/fortran/trans-array.c
index 37cca79..4db55c1 100644
--- a/gcc/fortran/trans-array.c
+++ b/gcc/fortran/trans-array.c
@@ -2292,7 +2292,8 @@ trans_array_constructor (gfc_ss * ss, locus * where)
type = build_pointer_type (type);
}
else
- type = gfc_typenode_for_spec (&expr->ts);
+ type = gfc_typenode_for_spec (expr->ts.type == BT_CLASS
+ ? &CLASS_DATA (expr)->ts : &expr->ts);
/* See if the constructor determines the loop bounds. */
dynamic = false;
@@ -3036,50 +3037,57 @@ build_class_array_ref (gfc_se *se, tree base, tree index)
tree type;
tree size;
tree offset;
- tree decl;
+ tree decl = NULL_TREE;
tree tmp;
gfc_expr *expr = se->ss->info->expr;
gfc_ref *ref;
- gfc_ref *class_ref;
+ gfc_ref *class_ref = NULL;
gfc_typespec *ts;
- if (expr == NULL
- || (expr->ts.type != BT_CLASS
- && !gfc_is_alloc_class_array_function (expr)))
- return false;
-
- if (expr->symtree && expr->symtree->n.sym->ts.type == BT_CLASS)
- ts = &expr->symtree->n.sym->ts;
+ if (se->expr && DECL_P (se->expr) && DECL_LANG_SPECIFIC (se->expr)
+ && GFC_DECL_SAVED_DESCRIPTOR (se->expr)
+ && GFC_CLASS_TYPE_P (TREE_TYPE (GFC_DECL_SAVED_DESCRIPTOR (se->expr))))
+ decl = se->expr;
else
- ts = NULL;
- class_ref = NULL;
-
- for (ref = expr->ref; ref; ref = ref->next)
{
- if (ref->type == REF_COMPONENT
- && ref->u.c.component->ts.type == BT_CLASS
- && ref->next && ref->next->type == REF_COMPONENT
- && strcmp (ref->next->u.c.component->name, "_data") == 0
- && ref->next->next
- && ref->next->next->type == REF_ARRAY
- && ref->next->next->u.ar.type != AR_ELEMENT)
+ if (expr == NULL
+ || (expr->ts.type != BT_CLASS
+ && !gfc_is_alloc_class_array_function (expr)
+ && !gfc_is_class_array_ref (expr, NULL)))
+ return false;
+
+ if (expr->symtree && expr->symtree->n.sym->ts.type == BT_CLASS)
+ ts = &expr->symtree->n.sym->ts;
+ else
+ ts = NULL;
+
+ for (ref = expr->ref; ref; ref = ref->next)
{
- ts = &ref->u.c.component->ts;
- class_ref = ref;
- break;
+ if (ref->type == REF_COMPONENT
+ && ref->u.c.component->ts.type == BT_CLASS
+ && ref->next && ref->next->type == REF_COMPONENT
+ && strcmp (ref->next->u.c.component->name, "_data") == 0
+ && ref->next->next
+ && ref->next->next->type == REF_ARRAY
+ && ref->next->next->u.ar.type != AR_ELEMENT)
+ {
+ ts = &ref->u.c.component->ts;
+ class_ref = ref;
+ break;
+ }
}
- }
- if (ts == NULL)
- return false;
+ if (ts == NULL)
+ return false;
+ }
- if (class_ref == NULL && expr->symtree->n.sym->attr.function
+ if (class_ref == NULL && expr && expr->symtree->n.sym->attr.function
&& expr->symtree->n.sym == expr->symtree->n.sym->result)
{
gcc_assert (expr->symtree->n.sym->backend_decl == current_function_decl);
decl = gfc_get_fake_result_decl (expr->symtree->n.sym, 0);
}
- else if (gfc_is_alloc_class_array_function (expr))
+ else if (expr && gfc_is_alloc_class_array_function (expr))
{
size = NULL_TREE;
decl = NULL_TREE;
@@ -3105,7 +3113,8 @@ build_class_array_ref (gfc_se *se, tree base, tree index)
}
else if (class_ref == NULL)
{
- decl = expr->symtree->n.sym->backend_decl;
+ if (decl == NULL_TREE)
+ decl = expr->symtree->n.sym->backend_decl;
/* For class arrays the tree containing the class is stored in
GFC_DECL_SAVED_DESCRIPTOR of the sym's backend_decl.
For all others it's sym's backend_decl directly. */
@@ -7094,6 +7103,26 @@ gfc_conv_expr_descriptor (gfc_se *se, gfc_expr *expr)
loop.from, loop.to, 0,
GFC_ARRAY_UNKNOWN, false);
parm = gfc_create_var (parmtype, "parm");
+
+ /* When expression is a class object, then add the class' handle to
+ the parm_decl. */
+ if (expr->ts.type == BT_CLASS && expr->expr_type == EXPR_VARIABLE)
+ {
+ gfc_expr *class_expr = gfc_find_and_cut_at_last_class_ref (expr);
+ gfc_se classse;
+
+ /* class_expr can be NULL, when no _class ref is in expr.
+ We must not fix this here with a gfc_fix_class_ref (). */
+ if (class_expr)
+ {
+ gfc_init_se (&classse, NULL);
+ gfc_conv_expr (&classse, class_expr);
+ gfc_free_expr (class_expr);
+
+ gfc_allocate_lang_decl (parm);
+ GFC_DECL_SAVED_DESCRIPTOR (parm) = classse.expr;
+ }
+ }
}
offset = gfc_index_zero_node;
@@ -7255,6 +7284,13 @@ gfc_conv_expr_descriptor (gfc_se *se, gfc_expr *expr)
: base;
gfc_conv_descriptor_offset_set (&loop.pre, parm, tmp);
}
+ else if (IS_CLASS_ARRAY (expr) && !se->data_not_needed
+ && (!rank_remap || se->use_offset)
+ && GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (desc)))
+ {
+ gfc_conv_descriptor_offset_set (&loop.pre, parm,
+ gfc_conv_descriptor_offset_get (desc));
+ }
else if (onebased && (!rank_remap || se->use_offset)
&& expr->symtree
&& !(expr->symtree->n.sym && expr->symtree->n.sym->ts.type == BT_CLASS
@@ -8541,6 +8577,14 @@ gfc_is_reallocatable_lhs (gfc_expr *expr)
if (!expr->ref)
return false;
+ /* An allocatable class variable with no reference. */
+ if (expr->symtree->n.sym->ts.type == BT_CLASS
+ && CLASS_DATA (expr->symtree->n.sym)->attr.allocatable
+ && expr->ref && expr->ref->type == REF_COMPONENT
+ && strcmp (expr->ref->u.c.component->name, "_data") == 0
+ && expr->ref->next == NULL)
+ return true;
+
/* An allocatable variable. */
if (expr->symtree->n.sym->attr.allocatable
&& expr->ref
diff --git a/gcc/fortran/trans-expr.c b/gcc/fortran/trans-expr.c
index 6b974db..574d984 100644
--- a/gcc/fortran/trans-expr.c
+++ b/gcc/fortran/trans-expr.c
@@ -350,7 +350,7 @@ gfc_expr *
gfc_find_and_cut_at_last_class_ref (gfc_expr *e)
{
gfc_expr *base_expr;
- gfc_ref *ref, *class_ref, *tail, *array_ref;
+ gfc_ref *ref, *class_ref, *tail = NULL, *array_ref;
/* Find the last class reference. */
class_ref = NULL;
@@ -383,7 +383,7 @@ gfc_find_and_cut_at_last_class_ref (gfc_expr *e)
tail = class_ref->next;
class_ref->next = NULL;
}
- else
+ else if (e->symtree->n.sym->ts.type == BT_CLASS)
{
tail = e->ref;
e->ref = NULL;
@@ -397,7 +397,7 @@ gfc_find_and_cut_at_last_class_ref (gfc_expr *e)
gfc_free_ref_list (class_ref->next);
class_ref->next = tail;
}
- else
+ else if (e->symtree->n.sym->ts.type == BT_CLASS)
{
gfc_free_ref_list (e->ref);
e->ref = tail;
@@ -1453,7 +1453,12 @@ gfc_trans_class_init_assign (gfc_code *code)
if (code->expr1->ts.type == BT_CLASS
&& CLASS_DATA (code->expr1)->attr.dimension)
- tmp = gfc_trans_class_array_init_assign (rhs, lhs, code->expr1);
+ {
+ gfc_array_spec *tmparr = gfc_get_array_spec ();
+ *tmparr = *CLASS_DATA (code->expr1)->as;
+ gfc_add_full_array_ref (lhs, tmparr);
+ tmp = gfc_trans_class_array_init_assign (rhs, lhs, code->expr1);
+ }
else
{
sz = gfc_copy_expr (code->expr1);
@@ -1498,114 +1503,6 @@ gfc_trans_class_init_assign (gfc_code *code)
}
-/* Translate an assignment to a CLASS object
- (pointer or ordinary assignment). */
-
-tree
-gfc_trans_class_assign (gfc_expr *expr1, gfc_expr *expr2, gfc_exec_op op)
-{
- stmtblock_t block;
- tree tmp;
- gfc_expr *lhs;
- gfc_expr *rhs;
- gfc_ref *ref;
-
- gfc_start_block (&block);
-
- ref = expr1->ref;
- while (ref && ref->next)
- ref = ref->next;
-
- /* Class valued proc_pointer assignments do not need any further
- preparation. */
- if (ref && ref->type == REF_COMPONENT
- && ref->u.c.component->attr.proc_pointer
- && expr2->expr_type == EXPR_VARIABLE
- && expr2->symtree->n.sym->attr.flavor == FL_PROCEDURE
- && op == EXEC_POINTER_ASSIGN)
- goto assign;
-
- if (expr2->ts.type != BT_CLASS)
- {
- /* Insert an additional assignment which sets the '_vptr' field. */
- gfc_symbol *vtab = NULL;
- gfc_symtree *st;
-
- lhs = gfc_copy_expr (expr1);
- gfc_add_vptr_component (lhs);
-
- if (UNLIMITED_POLY (expr1)
- && expr2->expr_type == EXPR_NULL && expr2->ts.type == BT_UNKNOWN)
- {
- rhs = gfc_get_null_expr (&expr2->where);
- goto assign_vptr;
- }
-
- if (expr2->expr_type == EXPR_NULL)
- vtab = gfc_find_vtab (&expr1->ts);
- else
- vtab = gfc_find_vtab (&expr2->ts);
- gcc_assert (vtab);
-
- rhs = gfc_get_expr ();
- rhs->expr_type = EXPR_VARIABLE;
- gfc_find_sym_tree (vtab->name, vtab->ns, 1, &st);
- rhs->symtree = st;
- rhs->ts = vtab->ts;
-assign_vptr:
- tmp = gfc_trans_pointer_assignment (lhs, rhs);
- gfc_add_expr_to_block (&block, tmp);
-
- gfc_free_expr (lhs);
- gfc_free_expr (rhs);
- }
- else if (expr1->ts.type == BT_DERIVED && UNLIMITED_POLY (expr2))
- {
- /* F2003:C717 only sequence and bind-C types can come here. */
- gcc_assert (expr1->ts.u.derived->attr.sequence
- || expr1->ts.u.derived->attr.is_bind_c);
- gfc_add_data_component (expr2);
- goto assign;
- }
- else if (CLASS_DATA (expr2)->attr.dimension && expr2->expr_type != EXPR_FUNCTION)
- {
- /* Insert an additional assignment which sets the '_vptr' field. */
- lhs = gfc_copy_expr (expr1);
- gfc_add_vptr_component (lhs);
-
- rhs = gfc_copy_expr (expr2);
- gfc_add_vptr_component (rhs);
-
- tmp = gfc_trans_pointer_assignment (lhs, rhs);
- gfc_add_expr_to_block (&block, tmp);
-
- gfc_free_expr (lhs);
- gfc_free_expr (rhs);
- }
-
- /* Do the actual CLASS assignment. */
- if (expr2->ts.type == BT_CLASS
- && !CLASS_DATA (expr2)->attr.dimension)
- op = EXEC_ASSIGN;
- else if (expr2->expr_type != EXPR_FUNCTION || expr2->ts.type != BT_CLASS
- || !CLASS_DATA (expr2)->attr.dimension)
- gfc_add_data_component (expr1);
-
-assign:
-
- if (op == EXEC_ASSIGN)
- tmp = gfc_trans_assignment (expr1, expr2, false, true);
- else if (op == EXEC_POINTER_ASSIGN)
- tmp = gfc_trans_pointer_assignment (expr1, expr2);
- else
- gcc_unreachable();
-
- gfc_add_expr_to_block (&block, tmp);
-
- return gfc_finish_block (&block);
-}
-
-
/* End of prototype trans-class.c */
@@ -5903,6 +5800,8 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym,
if (comp)
ts = comp->ts;
+ else if (sym->ts.type == BT_CLASS)
+ ts = CLASS_DATA (sym)->ts;
else
ts = sym->ts;
@@ -5973,7 +5872,7 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym,
&& GFC_DESCRIPTOR_TYPE_P
(TREE_TYPE (TREE_TYPE (TREE_TYPE (se->expr)))))
se->expr = build_fold_indirect_ref_loc (input_location,
- se->expr);
+ se->expr);
/* If the lhs of an assignment x = f(..) is allocatable and
f2003 is allowed, we must do the automatic reallocation.
@@ -6259,6 +6158,25 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym,
}
}
+ /* Associate the rhs class object's meta-data with the result, when the
+ result is a temporary. */
+ if (args && args->expr && args->expr->ts.type == BT_CLASS
+ && sym->ts.type == BT_CLASS && result != NULL_TREE && DECL_P (result)
+ && !GFC_CLASS_TYPE_P (TREE_TYPE (result)))
+ {
+ gfc_se parmse;
+ gfc_expr *class_expr
+ = gfc_find_and_cut_at_last_class_ref (args->expr);
+
+ gfc_init_se (&parmse, NULL);
+ parmse.data_not_needed = 1;
+ gfc_conv_expr (&parmse, class_expr);
+ if (!DECL_LANG_SPECIFIC (result))
+ gfc_allocate_lang_decl (result);
+ GFC_DECL_SAVED_DESCRIPTOR (result) = parmse.expr;
+ gfc_free_expr (class_expr);
+ }
+
/* Follow the function call with the argument post block. */
if (byref)
{
@@ -7881,6 +7799,199 @@ gfc_conv_expr_reference (gfc_se * se, gfc_expr * expr)
}
+/* Get the _len component for an unlimited polymorphic expression. */
+
+static tree
+trans_get_upoly_len (stmtblock_t *block, gfc_expr *expr)
+{
+ gfc_se se;
+ gfc_ref *ref = expr->ref;
+
+ gfc_init_se (&se, NULL);
+ while (ref && ref->next)
+ ref = ref->next;
+ gfc_add_len_component (expr);
+ gfc_conv_expr (&se, expr);
+ gfc_add_block_to_block (block, &se.pre);
+ if (ref)
+ {
+ gfc_free_ref_list (ref->next);
+ ref->next = NULL;
+ }
+ else
+ {
+ gfc_free_ref_list (expr->ref);
+ expr->ref = NULL;
+ }
+ return se.expr;
+}
+
+
+/* Assign _vptr and _len components as appropriate. BLOCK should be a
+ statement-list outside of the scalarizer-loop. When code is generated, that
+ depends on the scalarized expression, it is added to RSE.PRE.
+ Returns le's _vptr tree and when set the len expressions in to_lenp and
+ from_lenp to form a le%_vptr%_copy (re, le, [from_lenp, to_lenp])
+ expression. */
+
+static tree
+trans_class_vptr_len_assignment (stmtblock_t *block, gfc_expr * le,
+ gfc_expr * re, gfc_se *rse,
+ tree * to_lenp, tree * from_lenp)
+{
+ gfc_se se;
+ gfc_expr * vptr_expr;
+ tree tmp, to_len = NULL_TREE, from_len = NULL_TREE, lhs_vptr;
+ bool set_vptr = false, temp_rhs = false;
+ stmtblock_t *pre = block;
+
+ /* Create a temporary for complicated expressions. */
+ if (re->expr_type != EXPR_VARIABLE && re->expr_type != EXPR_NULL
+ && rse->expr != NULL_TREE && !DECL_P (rse->expr))
+ {
+ tmp = gfc_create_var (TREE_TYPE (rse->expr), "rhs");
+ pre = &rse->pre;
+ gfc_add_modify (&rse->pre, tmp, rse->expr);
+ rse->expr = tmp;
+ temp_rhs = true;
+ }
+
+ /* Get the _vptr for the left-hand side expression. */
+ gfc_init_se (&se, NULL);
+ vptr_expr = gfc_find_and_cut_at_last_class_ref (le);
+ if (vptr_expr != NULL && gfc_expr_attr (vptr_expr).class_ok)
+ {
+ /* Care about _len for unlimited polymorphic entities. */
+ if (UNLIMITED_POLY (vptr_expr)
+ || (vptr_expr->ts.type == BT_DERIVED
+ && vptr_expr->ts.u.derived->attr.unlimited_polymorphic))
+ to_len = trans_get_upoly_len (block, vptr_expr);
+ gfc_add_vptr_component (vptr_expr);
+ set_vptr = true;
+ }
+ else
+ vptr_expr = gfc_lval_expr_from_sym (gfc_find_vtab (&le->ts));
+ se.want_pointer = 1;
+ gfc_conv_expr (&se, vptr_expr);
+ gfc_free_expr (vptr_expr);
+ gfc_add_block_to_block (block, &se.pre);
+ gcc_assert (se.post.head == NULL_TREE);
+ lhs_vptr = se.expr;
+ STRIP_NOPS (lhs_vptr);
+
+ /* Set the _vptr only when the left-hand side of the assignment is a
+ class-object. */
+ if (set_vptr)
+ {
+ /* Get the vptr from the rhs expression only, when it is variable.
+ Functions are expected to be assigned to a temporary beforehand. */
+ vptr_expr = re->expr_type == EXPR_VARIABLE
+ ? gfc_find_and_cut_at_last_class_ref (re)
+ : NULL;
+ if (vptr_expr != NULL && vptr_expr->ts.type == BT_CLASS)
+ {
+ if (to_len != NULL_TREE)
+ {
+ /* Get the _len information from the rhs. */
+ if (UNLIMITED_POLY (vptr_expr)
+ || (vptr_expr->ts.type == BT_DERIVED
+ && vptr_expr->ts.u.derived->attr.unlimited_polymorphic))
+ from_len = trans_get_upoly_len (block, vptr_expr);
+ }
+ gfc_add_vptr_component (vptr_expr);
+ }
+ else
+ {
+ if (re->expr_type == EXPR_VARIABLE
+ && DECL_P (re->symtree->n.sym->backend_decl)
+ && DECL_LANG_SPECIFIC (re->symtree->n.sym->backend_decl)
+ && GFC_DECL_SAVED_DESCRIPTOR (re->symtree->n.sym->backend_decl)
+ && GFC_CLASS_TYPE_P (TREE_TYPE (GFC_DECL_SAVED_DESCRIPTOR (
+ re->symtree->n.sym->backend_decl))))
+ {
+ vptr_expr = NULL;
+ se.expr = gfc_class_vptr_get (GFC_DECL_SAVED_DESCRIPTOR (
+ re->symtree->n.sym->backend_decl));
+ if (to_len)
+ from_len = gfc_class_len_get (GFC_DECL_SAVED_DESCRIPTOR (
+ re->symtree->n.sym->backend_decl));
+ }
+ else if (temp_rhs && re->ts.type == BT_CLASS)
+ {
+ vptr_expr = NULL;
+ se.expr = gfc_class_vptr_get (rse->expr);
+ }
+ else if (re->expr_type != EXPR_NULL)
+ /* Only when rhs is non-NULL use its declared type for vptr
+ initialisation. */
+ vptr_expr = gfc_lval_expr_from_sym (gfc_find_vtab (&re->ts));
+ else
+ /* When the rhs is NULL use the vtab of lhs' declared type. */
+ vptr_expr = gfc_lval_expr_from_sym (gfc_find_vtab (&le->ts));
+ }
+
+ if (vptr_expr)
+ {
+ gfc_init_se (&se, NULL);
+ se.want_pointer = 1;
+ gfc_conv_expr (&se, vptr_expr);
+ gfc_free_expr (vptr_expr);
+ gfc_add_block_to_block (block, &se.pre);
+ gcc_assert (se.post.head == NULL_TREE);
+ }
+ gfc_add_modify (pre, lhs_vptr, fold_convert (TREE_TYPE (lhs_vptr),
+ se.expr));
+
+ if (to_len != NULL_TREE)
+ {
+ /* The _len component needs to be set. Figure how to get the
+ value of the right-hand side. */
+ if (from_len == NULL_TREE)
+ {
+ if (rse->string_length != NULL_TREE)
+ from_len = rse->string_length;
+ else if (re->ts.type == BT_CHARACTER && re->ts.u.cl->length)
+ {
+ from_len = gfc_get_expr_charlen (re);
+ gfc_init_se (&se, NULL);
+ gfc_conv_expr (&se, re->ts.u.cl->length);
+ gfc_add_block_to_block (block, &se.pre);
+ from_len = gfc_evaluate_now (se.expr, block);
+ }
+ else
+ from_len = integer_zero_node;
+ }
+ gfc_add_modify (pre, to_len, fold_convert (TREE_TYPE (to_len),
+ from_len));
+ }
+ }
+
+ /* Return the _len trees only, when requested. */
+ if (to_lenp)
+ *to_lenp = to_len;
+ if (from_lenp)
+ *from_lenp = from_len;
+ return lhs_vptr;
+}
+
+/* Indentify class valued proc_pointer assignments. */
+
+static bool
+pointer_assignment_is_proc_pointer (gfc_expr * expr1, gfc_expr * expr2)
+{
+ gfc_ref * ref;
+
+ ref = expr1->ref;
+ while (ref && ref->next)
+ ref = ref->next;
+
+ return ref && ref->type == REF_COMPONENT
+ && ref->u.c.component->attr.proc_pointer
+ && expr2->expr_type == EXPR_VARIABLE
+ && expr2->symtree->n.sym->attr.flavor == FL_PROCEDURE;
+}
+
+
tree
gfc_trans_pointer_assign (gfc_code * code)
{
@@ -7893,20 +8004,22 @@ gfc_trans_pointer_assign (gfc_code * code)
tree
gfc_trans_pointer_assignment (gfc_expr * expr1, gfc_expr * expr2)
{
- gfc_expr *expr1_vptr = NULL;
gfc_se lse;
gfc_se rse;
stmtblock_t block;
tree desc;
tree tmp;
tree decl;
- bool scalar;
+ bool scalar, non_proc_pointer_assign;
gfc_ss *ss;
gfc_start_block (&block);
gfc_init_se (&lse, NULL);
+ /* Usually testing whether this is not a proc pointer assignment. */
+ non_proc_pointer_assign = !pointer_assignment_is_proc_pointer (expr1, expr2);
+
/* Check whether the expression is a scalar or not; we cannot use
expr1->rank as it can be nonzero for proc pointers. */
ss = gfc_walk_expr (expr1);
@@ -7915,7 +8028,7 @@ gfc_trans_pointer_assignment (gfc_expr * expr1, gfc_expr * expr2)
gfc_free_ss_chain (ss);
if (expr1->ts.type == BT_DERIVED && expr2->ts.type == BT_CLASS
- && expr2->expr_type != EXPR_FUNCTION)
+ && expr2->expr_type != EXPR_FUNCTION && non_proc_pointer_assign)
{
gfc_add_data_component (expr2);
/* The following is required as gfc_add_data_component doesn't
@@ -7932,6 +8045,13 @@ gfc_trans_pointer_assignment (gfc_expr * expr1, gfc_expr * expr2)
rse.want_pointer = 1;
gfc_conv_expr (&rse, expr2);
+ if (non_proc_pointer_assign && expr1->ts.type == BT_CLASS)
+ {
+ trans_class_vptr_len_assignment (&block, expr1, expr2, &rse, NULL,
+ NULL);
+ lse.expr = gfc_class_data_get (lse.expr);
+ }
+
if (expr1->symtree->n.sym->attr.proc_pointer
&& expr1->symtree->n.sym->attr.dummy)
lse.expr = build_fold_indirect_ref_loc (input_location,
@@ -7945,27 +8065,6 @@ gfc_trans_pointer_assignment (gfc_expr * expr1, gfc_expr * expr2)
gfc_add_block_to_block (&block, &lse.pre);
gfc_add_block_to_block (&block, &rse.pre);
- /* For string assignments to unlimited polymorphic pointers add an
- assignment of the string_length to the _len component of the
- pointer. */
- if ((expr1->ts.type == BT_CLASS || expr1->ts.type == BT_DERIVED)
- && expr1->ts.u.derived->attr.unlimited_polymorphic
- && (expr2->ts.type == BT_CHARACTER ||
- ((expr2->ts.type == BT_DERIVED || expr2->ts.type == BT_CLASS)
- && expr2->ts.u.derived->attr.unlimited_polymorphic)))
- {
- gfc_expr *len_comp;
- gfc_se se;
- len_comp = gfc_get_len_component (expr1);
- gfc_init_se (&se, NULL);
- gfc_conv_expr (&se, len_comp);
-
- /* ptr % _len = len (str) */
- gfc_add_modify (&block, se.expr, rse.string_length);
- lse.string_length = se.expr;
- gfc_free_expr (len_comp);
- }
-
/* Check character lengths if character expression. The test is only
really added if -fbounds-check is enabled. Exclude deferred
character length lefthand sides. */
@@ -7992,9 +8091,6 @@ gfc_trans_pointer_assignment (gfc_expr * expr1, gfc_expr * expr2)
build_int_cst (gfc_charlen_type_node, 0));
}
- if (expr1->ts.type == BT_DERIVED && expr2->ts.type == BT_CLASS)
- rse.expr = gfc_class_data_get (rse.expr);
-
gfc_add_modify (&block, lse.expr,
fold_convert (TREE_TYPE (lse.expr), rse.expr));
@@ -8005,6 +8101,7 @@ gfc_trans_pointer_assignment (gfc_expr * expr1, gfc_expr * expr2)
{
gfc_ref* remap;
bool rank_remap;
+ tree expr1_vptr = NULL_TREE;
tree strlen_lhs;
tree strlen_rhs = NULL_TREE;
@@ -8021,9 +8118,6 @@ gfc_trans_pointer_assignment (gfc_expr * expr1, gfc_expr * expr2)
gfc_init_se (&lse, NULL);
if (remap)
lse.descriptor_only = 1;
- if (expr2->expr_type == EXPR_FUNCTION && expr2->ts.type == BT_CLASS
- && expr1->ts.type == BT_CLASS)
- expr1_vptr = gfc_copy_expr (expr1);
gfc_conv_expr_descriptor (&lse, expr1);
strlen_lhs = lse.string_length;
desc = lse.expr;
@@ -8049,16 +8143,15 @@ gfc_trans_pointer_assignment (gfc_expr * expr1, gfc_expr * expr2)
rse.expr = gfc_class_data_get (rse.expr);
else
{
+ expr1_vptr = trans_class_vptr_len_assignment (&block, expr1,
+ expr2, &rse,
+ NULL, NULL);
gfc_add_block_to_block (&block, &rse.pre);
tmp = gfc_create_var (TREE_TYPE (rse.expr), "ptrtemp");
gfc_add_modify (&lse.pre, tmp, rse.expr);
- gfc_add_vptr_component (expr1_vptr);
- gfc_init_se (&rse, NULL);
- rse.want_pointer = 1;
- gfc_conv_expr (&rse, expr1_vptr);
- gfc_add_modify (&lse.pre, rse.expr,
- fold_convert (TREE_TYPE (rse.expr),
+ gfc_add_modify (&lse.pre, expr1_vptr,
+ fold_convert (TREE_TYPE (expr1_vptr),
gfc_class_vptr_get (tmp)));
rse.expr = gfc_class_data_get (tmp);
}
@@ -8086,6 +8179,10 @@ gfc_trans_pointer_assignment (gfc_expr * expr1, gfc_expr * expr2)
{
gfc_conv_expr_descriptor (&rse, expr2);
strlen_rhs = rse.string_length;
+ if (expr1->ts.type == BT_CLASS)
+ expr1_vptr = trans_class_vptr_len_assignment (&block, expr1,
+ expr2, &rse,
+ NULL, NULL);
}
}
else if (expr2->expr_type == EXPR_VARIABLE)
@@ -8104,12 +8201,22 @@ gfc_trans_pointer_assignment (gfc_expr * expr1, gfc_expr * expr2)
gfc_init_se (&rse, NULL);
rse.descriptor_only = 1;
gfc_conv_expr (&rse, expr2);
+ if (expr1->ts.type == BT_CLASS)
+ trans_class_vptr_len_assignment (&block, expr1, expr2, &rse,
+ NULL, NULL);
tmp = gfc_get_element_type (TREE_TYPE (rse.expr));
tmp = fold_convert (gfc_array_index_type, size_in_bytes (tmp));
if (!INTEGER_CST_P (tmp))
gfc_add_block_to_block (&lse.post, &rse.pre);
gfc_add_modify (&lse.post, GFC_DECL_SPAN(decl), tmp);
}
+ else if (expr1->ts.type == BT_CLASS)
+ {
+ rse.expr = NULL_TREE;
+ rse.string_length = NULL_TREE;
+ trans_class_vptr_len_assignment (&block, expr1, expr2, &rse,
+ NULL, NULL);
+ }
}
else if (expr2->expr_type == EXPR_FUNCTION && expr2->ts.type == BT_CLASS)
{
@@ -8123,16 +8230,15 @@ gfc_trans_pointer_assignment (gfc_expr * expr1, gfc_expr * expr2)
}
else
{
+ expr1_vptr = trans_class_vptr_len_assignment (&block, expr1,
+ expr2, &rse, NULL,
+ NULL);
gfc_add_block_to_block (&block, &rse.pre);
tmp = gfc_create_var (TREE_TYPE (rse.expr), "ptrtemp");
gfc_add_modify (&lse.pre, tmp, rse.expr);
- gfc_add_vptr_component (expr1_vptr);
- gfc_init_se (&rse, NULL);
- rse.want_pointer = 1;
- gfc_conv_expr (&rse, expr1_vptr);
- gfc_add_modify (&lse.pre, rse.expr,
- fold_convert (TREE_TYPE (rse.expr),
+ gfc_add_modify (&lse.pre, expr1_vptr,
+ fold_convert (TREE_TYPE (expr1_vptr),
gfc_class_vptr_get (tmp)));
rse.expr = gfc_class_data_get (tmp);
gfc_add_modify (&lse.pre, desc, rse.expr);
@@ -8151,9 +8257,6 @@ gfc_trans_pointer_assignment (gfc_expr * expr1, gfc_expr * expr2)
gfc_add_modify (&lse.pre, desc, tmp);
}
- if (expr1_vptr)
- gfc_free_expr (expr1_vptr);
-
gfc_add_block_to_block (&block, &lse.pre);
if (rank_remap)
gfc_add_block_to_block (&block, &rse.pre);
@@ -8403,7 +8506,6 @@ gfc_trans_scalar_assign (gfc_se * lse, gfc_se * rse, gfc_typespec ts,
if (rse->string_length != NULL_TREE)
{
- gcc_assert (rse->string_length != NULL_TREE);
gfc_conv_string_parameter (rse);
gfc_add_block_to_block (&block, &rse->pre);
rlen = rse->string_length;
@@ -9359,14 +9461,101 @@ is_runtime_conformable (gfc_expr *expr1, gfc_expr *expr2)
return false;
}
+
+static tree
+trans_class_assignment (stmtblock_t *block, gfc_expr *lhs, gfc_expr *rhs,
+ gfc_se *lse, gfc_se *rse, bool use_vptr_copy)
+{
+ tree tmp;
+ tree fcn;
+ tree stdcopy, to_len, from_len;
+ vec<tree, va_gc> *args = NULL;
+
+ tmp = trans_class_vptr_len_assignment (block, lhs, rhs, rse, &to_len,
+ &from_len);
+
+ fcn = gfc_vptr_copy_get (tmp);
+
+ tmp = GFC_CLASS_TYPE_P (TREE_TYPE (rse->expr))
+ ? gfc_class_data_get (rse->expr) : rse->expr;
+ if (use_vptr_copy)
+ {
+ if (!POINTER_TYPE_P (TREE_TYPE (tmp))
+ || INDIRECT_REF_P (tmp)
+ || (rhs->ts.type == BT_DERIVED
+ && rhs->ts.u.derived->attr.unlimited_polymorphic
+ && !rhs->ts.u.derived->attr.pointer
+ && !rhs->ts.u.derived->attr.allocatable)
+ || (UNLIMITED_POLY (rhs)
+ && !CLASS_DATA (rhs)->attr.pointer
+ && !CLASS_DATA (rhs)->attr.allocatable))
+ vec_safe_push (args, gfc_build_addr_expr (NULL_TREE, tmp));
+ else
+ vec_safe_push (args, tmp);
+ tmp = GFC_CLASS_TYPE_P (TREE_TYPE (lse->expr))
+ ? gfc_class_data_get (lse->expr) : lse->expr;
+ if (!POINTER_TYPE_P (TREE_TYPE (tmp))
+ || INDIRECT_REF_P (tmp)
+ || (lhs->ts.type == BT_DERIVED
+ && lhs->ts.u.derived->attr.unlimited_polymorphic
+ && !lhs->ts.u.derived->attr.pointer
+ && !lhs->ts.u.derived->attr.allocatable)
+ || (UNLIMITED_POLY (lhs)
+ && !CLASS_DATA (lhs)->attr.pointer
+ && !CLASS_DATA (lhs)->attr.allocatable))
+ vec_safe_push (args, gfc_build_addr_expr (NULL_TREE, tmp));
+ else
+ vec_safe_push (args, tmp);
+
+ stdcopy = build_call_vec (TREE_TYPE (TREE_TYPE (fcn)), fcn, args);
+
+ if (to_len != NULL_TREE && !integer_zerop (from_len))
+ {
+ tree extcopy;
+ vec_safe_push (args, from_len);
+ vec_safe_push (args, to_len);
+ extcopy = build_call_vec (TREE_TYPE (TREE_TYPE (fcn)), fcn, args);
+
+ tmp = fold_build2_loc (input_location, GT_EXPR,
+ boolean_type_node, from_len,
+ integer_zero_node);
+ return fold_build3_loc (input_location, COND_EXPR,
+ void_type_node, tmp,
+ extcopy, stdcopy);
+ }
+ else
+ return stdcopy;
+ }
+ else
+ {
+ tree rhst = GFC_CLASS_TYPE_P (TREE_TYPE (lse->expr))
+ ? gfc_class_data_get (lse->expr) : lse->expr;
+ stmtblock_t tblock;
+ gfc_init_block (&tblock);
+ if (!POINTER_TYPE_P (TREE_TYPE (tmp)))
+ tmp = gfc_build_addr_expr (NULL_TREE, tmp);
+ if (!POINTER_TYPE_P (TREE_TYPE (rhst)))
+ rhst = gfc_build_addr_expr (NULL_TREE, rhst);
+ /* When coming from a ptr_copy lhs and rhs are swapped. */
+ gfc_add_modify_loc (input_location, &tblock, rhst,
+ fold_convert (TREE_TYPE (rhst), tmp));
+ return gfc_finish_block (&tblock);
+ }
+}
+
/* Subroutine of gfc_trans_assignment that actually scalarizes the
assignment. EXPR1 is the destination/LHS and EXPR2 is the source/RHS.
init_flag indicates initialization expressions and dealloc that no
- deallocate prior assignment is needed (if in doubt, set true). */
+ deallocate prior assignment is needed (if in doubt, set true).
+ When PTR_COPY is set and expr1 is a class type, then use the _vptr-copy
+ routine instead of a pointer assignment. Alias resolution is only done,
+ when MAY_ALIAS is set (the default). This flag is used by ALLOCATE()
+ where it is known, that newly allocated memory on the lhs can never be
+ an alias of the rhs. */
static tree
gfc_trans_assignment_1 (gfc_expr * expr1, gfc_expr * expr2, bool init_flag,
- bool dealloc)
+ bool dealloc, bool use_vptr_copy, bool may_alias)
{
gfc_se lse;
gfc_se rse;
@@ -9382,7 +9571,7 @@ gfc_trans_assignment_1 (gfc_expr * expr1, gfc_expr * expr2, bool init_flag,
tree string_length;
int n;
bool maybe_workshare = false;
- symbol_attribute lhs_caf_attr, rhs_caf_attr;
+ symbol_attribute lhs_caf_attr, rhs_caf_attr, lhs_attr;
/* Assignment of the form lhs = rhs. */
gfc_start_block (&block);
@@ -9403,8 +9592,13 @@ gfc_trans_assignment_1 (gfc_expr * expr1, gfc_expr * expr2, bool init_flag,
|| gfc_is_alloc_class_scalar_function (expr2)))
expr2->must_finalize = 1;
- lhs_caf_attr = gfc_caf_attr (expr1);
- rhs_caf_attr = gfc_caf_attr (expr2);
+ /* Only analyze the expressions for coarray properties, when in coarray-lib
+ mode. */
+ if (flag_coarray == GFC_FCOARRAY_LIB)
+ {
+ lhs_caf_attr = gfc_caf_attr (expr1);
+ rhs_caf_attr = gfc_caf_attr (expr2);
+ }
if (lss != gfc_ss_terminator)
{
@@ -9437,7 +9631,8 @@ gfc_trans_assignment_1 (gfc_expr * expr1, gfc_expr * expr2, bool init_flag,
for (n = 0; n < GFC_MAX_DIMENSIONS; n++)
loop.reverse[n] = GFC_ENABLE_REVERSE;
/* Resolve any data dependencies in the statement. */
- gfc_conv_resolve_dependencies (&loop, lss, rss);
+ if (may_alias)
+ gfc_conv_resolve_dependencies (&loop, lss, rss);
/* Setup the scalarizing loops. */
gfc_conv_loop_setup (&loop, &expr2->where);
@@ -9584,9 +9779,26 @@ gfc_trans_assignment_1 (gfc_expr * expr1, gfc_expr * expr2, bool init_flag,
gfc_add_block_to_block (&loop.post, &rse.post);
}
- if (flag_coarray == GFC_FCOARRAY_LIB
- && lhs_caf_attr.codimension && rhs_caf_attr.codimension
- && lhs_caf_attr.alloc_comp && rhs_caf_attr.alloc_comp)
+ lhs_attr = gfc_expr_attr (expr1);
+ if ((use_vptr_copy || lhs_attr.pointer
+ || (lhs_attr.allocatable && !lhs_attr.dimension))
+ && (expr1->ts.type == BT_CLASS
+ || (gfc_is_class_array_ref (expr1, NULL)
+ || gfc_is_class_scalar_expr (expr1))
+ || (gfc_is_class_array_ref (expr2, NULL)
+ || gfc_is_class_scalar_expr (expr2))))
+ {
+ tmp = trans_class_assignment (&body, expr1, expr2, &lse, &rse,
+ use_vptr_copy || (lhs_attr.allocatable
+ && !lhs_attr.dimension));
+ /* Modify the expr1 after the assignment, to allow the realloc below.
+ Therefore only needed, when realloc_lhs is enabled. */
+ if (flag_realloc_lhs && !lhs_attr.pointer)
+ gfc_add_data_component (expr1);
+ }
+ else if (flag_coarray == GFC_FCOARRAY_LIB
+ && lhs_caf_attr.codimension && rhs_caf_attr.codimension
+ && lhs_caf_attr.alloc_comp && rhs_caf_attr.alloc_comp)
{
gfc_code code;
gfc_actual_arglist a1, a2;
@@ -9604,7 +9816,13 @@ gfc_trans_assignment_1 (gfc_expr * expr1, gfc_expr * expr2, bool init_flag,
|| scalar_to_array
|| expr2->expr_type == EXPR_ARRAY,
!(l_is_temp || init_flag) && dealloc);
+ /* Add the pre blocks to the body. */
+ gfc_add_block_to_block (&body, &rse.pre);
+ gfc_add_block_to_block (&body, &lse.pre);
gfc_add_expr_to_block (&body, tmp);
+ /* Add the post blocks to the body. */
+ gfc_add_block_to_block (&body, &rse.post);
+ gfc_add_block_to_block (&body, &lse.post);
if (lss == gfc_ss_terminator)
{
@@ -9719,7 +9937,7 @@ copyable_array_p (gfc_expr * expr)
tree
gfc_trans_assignment (gfc_expr * expr1, gfc_expr * expr2, bool init_flag,
- bool dealloc)
+ bool dealloc, bool use_vptr_copy, bool may_alias)
{
tree tmp;
@@ -9762,7 +9980,8 @@ gfc_trans_assignment (gfc_expr * expr1, gfc_expr * expr2, bool init_flag,
}
/* Fallback to the scalarizer to generate explicit loops. */
- return gfc_trans_assignment_1 (expr1, expr2, init_flag, dealloc);
+ return gfc_trans_assignment_1 (expr1, expr2, init_flag, dealloc,
+ use_vptr_copy, may_alias);
}
tree
diff --git a/gcc/fortran/trans-stmt.c b/gcc/fortran/trans-stmt.c
index ef5153e..4280b77 100644
--- a/gcc/fortran/trans-stmt.c
+++ b/gcc/fortran/trans-stmt.c
@@ -5439,7 +5439,10 @@ gfc_trans_allocate (gfc_code * code)
if (code->expr3->rank != 0
&& ((!attr.allocatable && !attr.pointer)
|| (code->expr3->expr_type == EXPR_FUNCTION
- && code->expr3->ts.type != BT_CLASS)))
+ && (code->expr3->ts.type != BT_CLASS
+ || (code->expr3->value.function.isym
+ && code->expr3->value.function.isym
+ ->transformational)))))
gfc_conv_expr_descriptor (&se, code->expr3);
else
gfc_conv_expr_reference (&se, code->expr3);
@@ -5623,73 +5626,6 @@ gfc_trans_allocate (gfc_code * code)
else
expr3_esize = TYPE_SIZE_UNIT (
gfc_typenode_for_spec (&code->expr3->ts));
-
- /* The routine gfc_trans_assignment () already implements all
- techniques needed. Unfortunately we may have a temporary
- variable for the source= expression here. When that is the
- case convert this variable into a temporary gfc_expr of type
- EXPR_VARIABLE and used it as rhs for the assignment. The
- advantage is, that we get scalarizer support for free,
- don't have to take care about scalar to array treatment and
- will benefit of every enhancements gfc_trans_assignment ()
- gets.
- No need to check whether e3_is is E3_UNSET, because that is
- done by expr3 != NULL_TREE.
- Exclude variables since the following block does not handle
- array sections. In any case, there is no harm in sending
- variables to gfc_trans_assignment because there is no
- evaluation of variables. */
- if (code->expr3->expr_type != EXPR_VARIABLE
- && e3_is != E3_MOLD && expr3 != NULL_TREE
- && DECL_P (expr3) && DECL_ARTIFICIAL (expr3))
- {
- /* Build a temporary symtree and symbol. Do not add it to
- the current namespace to prevent accidently modifying
- a colliding symbol's as. */
- newsym = XCNEW (gfc_symtree);
- /* The name of the symtree should be unique, because
- gfc_create_var () took care about generating the
- identifier. */
- newsym->name = gfc_get_string (IDENTIFIER_POINTER (
- DECL_NAME (expr3)));
- newsym->n.sym = gfc_new_symbol (newsym->name, NULL);
- /* The backend_decl is known. It is expr3, which is inserted
- here. */
- newsym->n.sym->backend_decl = expr3;
- e3rhs = gfc_get_expr ();
- e3rhs->ts = code->expr3->ts;
- e3rhs->rank = code->expr3->rank;
- e3rhs->symtree = newsym;
- /* Mark the symbol referenced or gfc_trans_assignment will
- bug. */
- newsym->n.sym->attr.referenced = 1;
- e3rhs->expr_type = EXPR_VARIABLE;
- e3rhs->where = code->expr3->where;
- /* Set the symbols type, upto it was BT_UNKNOWN. */
- newsym->n.sym->ts = e3rhs->ts;
- /* Check whether the expr3 is array valued. */
- if (e3rhs->rank)
- {
- gfc_array_spec *arr;
- arr = gfc_get_array_spec ();
- arr->rank = e3rhs->rank;
- arr->type = AS_DEFERRED;
- /* Set the dimension and pointer attribute for arrays
- to be on the safe side. */
- newsym->n.sym->attr.dimension = 1;
- newsym->n.sym->attr.pointer = 1;
- newsym->n.sym->as = arr;
- gfc_add_full_array_ref (e3rhs, arr);
- }
- else if (POINTER_TYPE_P (TREE_TYPE (expr3)))
- newsym->n.sym->attr.pointer = 1;
- /* The string length is known to. Set it for char arrays. */
- if (e3rhs->ts.type == BT_CHARACTER)
- newsym->n.sym->ts.u.cl->backend_decl = expr3_len;
- gfc_commit_symbol (newsym->n.sym);
- }
- else
- e3rhs = gfc_copy_expr (code->expr3);
}
gcc_assert (expr3_esize);
expr3_esize = fold_convert (sizetype, expr3_esize);
@@ -5723,6 +5659,95 @@ gfc_trans_allocate (gfc_code * code)
}
}
+ /* The routine gfc_trans_assignment () already implements all
+ techniques needed. Unfortunately we may have a temporary
+ variable for the source= expression here. When that is the
+ case convert this variable into a temporary gfc_expr of type
+ EXPR_VARIABLE and used it as rhs for the assignment. The
+ advantage is, that we get scalarizer support for free,
+ don't have to take care about scalar to array treatment and
+ will benefit of every enhancements gfc_trans_assignment ()
+ gets.
+ No need to check whether e3_is is E3_UNSET, because that is
+ done by expr3 != NULL_TREE.
+ Exclude variables since the following block does not handle
+ array sections. In any case, there is no harm in sending
+ variables to gfc_trans_assignment because there is no
+ evaluation of variables. */
+ if (code->expr3)
+ {
+ if (code->expr3->expr_type != EXPR_VARIABLE
+ && e3_is != E3_MOLD && expr3 != NULL_TREE
+ && DECL_P (expr3) && DECL_ARTIFICIAL (expr3))
+ {
+ /* Build a temporary symtree and symbol. Do not add it to the current
+ namespace to prevent accidently modifying a colliding
+ symbol's as. */
+ newsym = XCNEW (gfc_symtree);
+ /* The name of the symtree should be unique, because gfc_create_var ()
+ took care about generating the identifier. */
+ newsym->name = gfc_get_string (IDENTIFIER_POINTER (
+ DECL_NAME (expr3)));
+ newsym->n.sym = gfc_new_symbol (newsym->name, NULL);
+ /* The backend_decl is known. It is expr3, which is inserted
+ here. */
+ newsym->n.sym->backend_decl = expr3;
+ e3rhs = gfc_get_expr ();
+ e3rhs->rank = code->expr3->rank;
+ e3rhs->symtree = newsym;
+ /* Mark the symbol referenced or gfc_trans_assignment will bug. */
+ newsym->n.sym->attr.referenced = 1;
+ e3rhs->expr_type = EXPR_VARIABLE;
+ e3rhs->where = code->expr3->where;
+ /* Set the symbols type, upto it was BT_UNKNOWN. */
+ if (IS_CLASS_ARRAY (code->expr3)
+ && code->expr3->expr_type == EXPR_FUNCTION
+ && code->expr3->value.function.isym
+ && code->expr3->value.function.isym->transformational)
+ {
+ e3rhs->ts = CLASS_DATA (code->expr3)->ts;
+ }
+ else if (code->expr3->ts.type == BT_CLASS
+ && !GFC_CLASS_TYPE_P (TREE_TYPE (expr3)))
+ e3rhs->ts = CLASS_DATA (code->expr3)->ts;
+ else
+ e3rhs->ts = code->expr3->ts;
+ newsym->n.sym->ts = e3rhs->ts;
+ /* Check whether the expr3 is array valued. */
+ if (e3rhs->rank)
+ {
+ gfc_array_spec *arr;
+ arr = gfc_get_array_spec ();
+ arr->rank = e3rhs->rank;
+ arr->type = AS_DEFERRED;
+ /* Set the dimension and pointer attribute for arrays
+ to be on the safe side. */
+ newsym->n.sym->attr.dimension = 1;
+ newsym->n.sym->attr.pointer = 1;
+ newsym->n.sym->as = arr;
+ if (IS_CLASS_ARRAY (code->expr3)
+ && code->expr3->expr_type == EXPR_FUNCTION
+ && code->expr3->value.function.isym
+ && code->expr3->value.function.isym->transformational)
+ {
+ gfc_array_spec *tarr;
+ tarr = gfc_get_array_spec ();
+ *tarr = *arr;
+ e3rhs->ts.u.derived->as = tarr;
+ }
+ gfc_add_full_array_ref (e3rhs, arr);
+ }
+ else if (POINTER_TYPE_P (TREE_TYPE (expr3)))
+ newsym->n.sym->attr.pointer = 1;
+ /* The string length is known to. Set it for char arrays. */
+ if (e3rhs->ts.type == BT_CHARACTER)
+ newsym->n.sym->ts.u.cl->backend_decl = expr3_len;
+ gfc_commit_symbol (newsym->n.sym);
+ }
+ else
+ e3rhs = gfc_copy_expr (code->expr3);
+ }
+
/* Loop over all objects to allocate. */
for (al = code->ext.alloc.list; al != NULL; al = al->next)
{
@@ -5960,8 +5985,9 @@ gfc_trans_allocate (gfc_code * code)
gfc_add_expr_to_block (&block, tmp);
}
- /* Set the vptr. */
- if (al_vptr != NULL_TREE)
+ /* Set the vptr only when no source= is set. When source= is set, then
+ the trans_assignment below will set the vptr. */
+ if (al_vptr != NULL_TREE && (!code->expr3 || code->expr3->mold))
{
if (expr3_vptr != NULL_TREE)
/* The vtab is already known, so just assign it. */
@@ -6046,153 +6072,34 @@ gfc_trans_allocate (gfc_code * code)
if (code->expr3 && !code->expr3->mold && e3_is != E3_MOLD)
{
/* Initialization via SOURCE block (or static default initializer).
- Classes need some special handling, so catch them first. */
- if (expr3 != NULL_TREE
- && TREE_CODE (expr3) != POINTER_PLUS_EXPR
- && code->expr3->ts.type == BT_CLASS
- && (expr->ts.type == BT_CLASS
- || expr->ts.type == BT_DERIVED))
- {
- /* copy_class_to_class can be used for class arrays, too.
- It just needs to be ensured, that the decl_saved_descriptor
- has a way to get to the vptr. */
- tree to;
- to = VAR_P (se.expr) ? se.expr : TREE_OPERAND (se.expr, 0);
- tmp = gfc_copy_class_to_class (expr3, to,
- nelems, upoly_expr);
- }
- else if (al->expr->ts.type == BT_CLASS)
- {
- gfc_actual_arglist *actual, *last_arg;
- gfc_expr *ppc;
- gfc_code *ppc_code;
- gfc_ref *ref, *dataref;
- gfc_expr *rhs = e3rhs ? e3rhs : gfc_copy_expr (code->expr3);
-
- /* Do a polymorphic deep copy. */
- actual = gfc_get_actual_arglist ();
- actual->expr = gfc_copy_expr (rhs);
- if (rhs->ts.type == BT_CLASS)
- gfc_add_data_component (actual->expr);
- last_arg = actual->next = gfc_get_actual_arglist ();
- last_arg->expr = gfc_copy_expr (al->expr);
- last_arg->expr->ts.type = BT_CLASS;
- gfc_add_data_component (last_arg->expr);
-
- dataref = NULL;
- /* Make sure we go up through the reference chain to
- the _data reference, where the arrayspec is found. */
- for (ref = last_arg->expr->ref; ref; ref = ref->next)
- if (ref->type == REF_COMPONENT
- && strcmp (ref->u.c.component->name, "_data") == 0)
- dataref = ref;
-
- if (dataref && dataref->u.c.component->as)
- {
- gfc_array_spec *as = dataref->u.c.component->as;
- gfc_free_ref_list (dataref->next);
- dataref->next = NULL;
- gfc_add_full_array_ref (last_arg->expr, as);
- gfc_resolve_expr (last_arg->expr);
- gcc_assert (last_arg->expr->ts.type == BT_CLASS
- || last_arg->expr->ts.type == BT_DERIVED);
- last_arg->expr->ts.type = BT_CLASS;
- }
- if (rhs->ts.type == BT_CLASS)
- {
- if (rhs->ref)
- ppc = gfc_find_and_cut_at_last_class_ref (rhs);
- else
- ppc = gfc_copy_expr (rhs);
- gfc_add_vptr_component (ppc);
- }
- else
- ppc = gfc_lval_expr_from_sym (gfc_find_vtab (&rhs->ts));
- gfc_add_component_ref (ppc, "_copy");
-
- ppc_code = gfc_get_code (EXEC_CALL);
- ppc_code->resolved_sym = ppc->symtree->n.sym;
- ppc_code->loc = al->expr->where;
- /* Although '_copy' is set to be elemental in class.c, it is
- not staying that way. Find out why, sometime.... */
- ppc_code->resolved_sym->attr.elemental = 1;
- ppc_code->ext.actual = actual;
- ppc_code->expr1 = ppc;
- /* Since '_copy' is elemental, the scalarizer will take care
- of arrays in gfc_trans_call. */
- tmp = gfc_trans_call (ppc_code, true, NULL, NULL, false);
- /* We need to add the
- if (al_len > 0)
- al_vptr->copy (expr3_data, al_data, expr3_len, al_len);
- else
- al_vptr->copy (expr3_data, al_data);
- block, because al is unlimited polymorphic or a deferred
- length char array, whose copy routine needs the array lengths
- as third and fourth arguments. */
- if (al_len && UNLIMITED_POLY (code->expr3))
- {
- tree stdcopy, extcopy;
- /* Add al%_len. */
- last_arg->next = gfc_get_actual_arglist ();
- last_arg = last_arg->next;
- last_arg->expr = gfc_find_and_cut_at_last_class_ref (
- al->expr);
- gfc_add_len_component (last_arg->expr);
- /* Add expr3's length. */
- last_arg->next = gfc_get_actual_arglist ();
- last_arg = last_arg->next;
- if (code->expr3->ts.type == BT_CLASS)
- {
- last_arg->expr =
- gfc_find_and_cut_at_last_class_ref (code->expr3);
- gfc_add_len_component (last_arg->expr);
- }
- else if (code->expr3->ts.type == BT_CHARACTER)
- last_arg->expr =
- gfc_copy_expr (code->expr3->ts.u.cl->length);
- else
- gcc_unreachable ();
-
- stdcopy = tmp;
- extcopy = gfc_trans_call (ppc_code, true, NULL, NULL, false);
-
- tmp = fold_build2_loc (input_location, GT_EXPR,
- boolean_type_node, expr3_len,
- integer_zero_node);
- tmp = fold_build3_loc (input_location, COND_EXPR,
- void_type_node, tmp, extcopy, stdcopy);
- }
- gfc_free_statements (ppc_code);
- if (rhs != e3rhs)
- gfc_free_expr (rhs);
- }
- else
- {
- /* Switch off automatic reallocation since we have just
- done the ALLOCATE. */
- int realloc_lhs = flag_realloc_lhs;
- gfc_expr *init_expr = gfc_expr_to_initialize (expr);
- flag_realloc_lhs = 0;
- tmp = gfc_trans_assignment (init_expr, e3rhs, false, false);
- flag_realloc_lhs = realloc_lhs;
- /* Free the expression allocated for init_expr. */
- gfc_free_expr (init_expr);
- }
+ Switch off automatic reallocation since we have just done the
+ ALLOCATE. */
+ int realloc_lhs = flag_realloc_lhs;
+ gfc_expr *init_expr = gfc_expr_to_initialize (expr);
+ gfc_expr *rhs = e3rhs ? e3rhs : gfc_copy_expr (code->expr3);
+ flag_realloc_lhs = 0;
+ tmp = gfc_trans_assignment (init_expr, rhs, false, false, true,
+ false);
+ flag_realloc_lhs = realloc_lhs;
+ /* Free the expression allocated for init_expr. */
+ gfc_free_expr (init_expr);
+ if (rhs != e3rhs)
+ gfc_free_expr (rhs);
gfc_add_expr_to_block (&block, tmp);
}
- else if (code->expr3 && code->expr3->mold
- && code->expr3->ts.type == BT_CLASS)
+ else if (code->expr3 && code->expr3->mold
+ && code->expr3->ts.type == BT_CLASS)
{
- /* Since the _vptr has already been assigned to the allocate
- object, we can use gfc_copy_class_to_class in its
- initialization mode. */
- tmp = TREE_OPERAND (se.expr, 0);
- tmp = gfc_copy_class_to_class (NULL_TREE, tmp, nelems,
- upoly_expr);
+ /* Use class_init_assign to initialize expr. */
+ gfc_code *ini;
+ ini = gfc_get_code (EXEC_INIT_ASSIGN);
+ ini->expr1 = gfc_find_and_cut_at_last_class_ref (expr);
+ tmp = gfc_trans_class_init_assign (ini);
+ gfc_free_statements (ini);
gfc_add_expr_to_block (&block, tmp);
}
- gfc_free_expr (expr);
+ gfc_free_expr (expr);
} // for-loop
if (e3rhs)
diff --git a/gcc/fortran/trans-stmt.h b/gcc/fortran/trans-stmt.h
index f9c8e74..e4d4a67 100644
--- a/gcc/fortran/trans-stmt.h
+++ b/gcc/fortran/trans-stmt.h
@@ -32,7 +32,6 @@ tree gfc_trans_assign (gfc_code *);
tree gfc_trans_pointer_assign (gfc_code *);
tree gfc_trans_init_assign (gfc_code *);
tree gfc_trans_class_init_assign (gfc_code *);
-tree gfc_trans_class_assign (gfc_expr *, gfc_expr *, gfc_exec_op);
/* trans-stmt.c */
tree gfc_trans_cycle (gfc_code *);
diff --git a/gcc/fortran/trans.c b/gcc/fortran/trans.c
index 9210e0f..fba0d9a 100644
--- a/gcc/fortran/trans.c
+++ b/gcc/fortran/trans.c
@@ -1704,10 +1704,7 @@ trans_code (gfc_code * code, tree cond)
break;
case EXEC_ASSIGN:
- if (code->expr1->ts.type == BT_CLASS)
- res = gfc_trans_class_assign (code->expr1, code->expr2, code->op);
- else
- res = gfc_trans_assign (code);
+ res = gfc_trans_assign (code);
break;
case EXEC_LABEL_ASSIGN:
@@ -1715,16 +1712,7 @@ trans_code (gfc_code * code, tree cond)
break;
case EXEC_POINTER_ASSIGN:
- if (code->expr1->ts.type == BT_CLASS)
- res = gfc_trans_class_assign (code->expr1, code->expr2, code->op);
- else if (UNLIMITED_POLY (code->expr2)
- && code->expr1->ts.type == BT_DERIVED
- && (code->expr1->ts.u.derived->attr.sequence
- || code->expr1->ts.u.derived->attr.is_bind_c))
- /* F2003: C717 */
- res = gfc_trans_class_assign (code->expr1, code->expr2, code->op);
- else
- res = gfc_trans_pointer_assign (code);
+ res = gfc_trans_pointer_assign (code);
break;
case EXEC_INIT_ASSIGN:
diff --git a/gcc/fortran/trans.h b/gcc/fortran/trans.h
index 4d3d207..f76fff8 100644
--- a/gcc/fortran/trans.h
+++ b/gcc/fortran/trans.h
@@ -699,7 +699,8 @@ tree gfc_call_realloc (stmtblock_t *, tree, tree);
tree gfc_trans_structure_assign (tree, gfc_expr *, bool);
/* Generate code for an assignment, includes scalarization. */
-tree gfc_trans_assignment (gfc_expr *, gfc_expr *, bool, bool);
+tree gfc_trans_assignment (gfc_expr *, gfc_expr *, bool, bool, bool p = false,
+ bool a = true);
/* Generate code for a pointer assignment. */
tree gfc_trans_pointer_assignment (gfc_expr *, gfc_expr *);
diff --git a/gcc/testsuite/gfortran.dg/class_allocate_21.f90 b/gcc/testsuite/gfortran.dg/class_allocate_21.f90
new file mode 100644
index 0000000..a8ed291
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/class_allocate_21.f90
@@ -0,0 +1,21 @@
+! { dg-do run }
+!
+! Testcase for pr57117
+
+implicit none
+
+ type :: ti
+ integer :: i
+ end type
+
+ class(ti), allocatable :: x(:,:), z(:)
+ integer :: i
+
+ allocate(x(3,3))
+ x%i = reshape([( i, i = 1, 9 )], [3, 3])
+ allocate(z(9), source=reshape(x, (/ 9 /)))
+
+ if (any( z%i /= [( i, i = 1, 9 )])) call abort()
+ deallocate (x, z)
+end
+
diff --git a/gcc/testsuite/gfortran.dg/class_allocate_22.f90 b/gcc/testsuite/gfortran.dg/class_allocate_22.f90
new file mode 100644
index 0000000..5fec72f
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/class_allocate_22.f90
@@ -0,0 +1,26 @@
+! { dg-do run }
+!
+! Check pr57117 is fixed.
+
+program pr57117
+ implicit none
+
+ type :: ti
+ integer :: i
+ end type
+
+ class(ti), allocatable :: x(:,:), y(:,:)
+ integer :: i
+
+ allocate(x(2,6))
+ select type (x)
+ class is (ti)
+ x%i = reshape([(i,i=1, 12)],[2,6])
+ end select
+ allocate(y, source=transpose(x))
+
+ if (any( ubound(y) /= [6,2])) call abort()
+ if (any(reshape(y(:,:)%i, [12]) /= [ 1,3,5,7,9,11, 2,4,6,8,10,12])) call abort()
+ deallocate (x,y)
+end
+
diff --git a/gcc/testsuite/gfortran.dg/realloc_on_assign_27.f08 b/gcc/testsuite/gfortran.dg/realloc_on_assign_27.f08
new file mode 100644
index 0000000..53b8330
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/realloc_on_assign_27.f08
@@ -0,0 +1,24 @@
+! { dg-do run }
+
+ type :: t
+ integer :: i
+ end type
+
+ type, extends(t) :: r
+ real :: r
+ end type
+
+ class(t), allocatable :: x
+ class(r), allocatable :: foo ! Need this declared of copy_R is not generated.
+ type(r) :: y = r (3, 42)
+
+ x = y
+ if (x%i /= 3) call abort()
+ select type(x)
+ class is (r)
+ if (x%r /= 42.0) call abort()
+ class default
+ call abort()
+ end select
+end
+
^ permalink raw reply [flat|nested] 8+ messages in thread
end of thread, other threads:[~2016-12-01 18:56 UTC | newest]
Thread overview: 8+ messages (download: mbox.gz / follow: Atom feed)
-- links below jump to the message on this page --
2016-11-30 20:06 [Fortran, Patch, PR{43366, 57117, 61337, 61376}, v1] Assign to polymorphic objects David Edelsohn
2016-11-30 20:51 ` Dominique d'Humières
2016-12-01 18:32 ` Andre Vehreschild
2016-12-01 18:56 ` David Edelsohn
-- strict thread matches above, loose matches on Subject: below --
2016-10-22 10:41 Paul Richard Thomas
2016-10-22 12:36 ` Andre Vehreschild
2016-10-13 12:42 Andre Vehreschild
2016-10-19 17:37 ` Andre Vehreschild
This is a public inbox, see mirroring instructions
for how to clone and mirror all data and code used for this inbox;
as well as URLs for read-only IMAP folder(s) and NNTP newsgroup(s).