* [Patch, fortran, pr65548, v1] [5 Regression] gfc_conv_procedure_call [not found] ` <bug-65548-26035-vcFxaNSRns@http.gcc.gnu.org/bugzilla/> @ 2015-03-25 13:36 ` Andre Vehreschild 2015-04-02 10:28 ` [Ping, Patch, " Andre Vehreschild 0 siblings, 1 reply; 17+ messages in thread From: Andre Vehreschild @ 2015-03-25 13:36 UTC (permalink / raw) To: GCC-Patches-ML, GCC-Fortran-ML; +Cc: dominiq at lps dot ens.fr [-- Attachment #1: Type: text/plain, Size: 368 bytes --] Hi all, please find attached a fix for the recently introduced regression when allocating arrays with an intrinsic function for source=. The patch addresses this issue by using gfc_conv_expr_descriptor () for intrinsic functions. Bootstraps and regtests ok on x86_64-linux-gnu/F20. Ok for trunk? Regards, Andre -- Andre Vehreschild * Email: vehre ad gmx dot de [-- Attachment #2: pr65548_1.clog --] [-- Type: application/octet-stream, Size: 324 bytes --] gcc/testsuite/ChangeLog: 2015-03-25 Andre Vehreschild <vehre@gmx.de> * gfortran.dg/allocate_with_source_5.f90: New test. gcc/fortran/ChangeLog: 2015-03-25 Andre Vehreschild <vehre@gmx.de> * trans-stmt.c (gfc_trans_allocate): For intrinsic functions use conv_expr_descriptor() instead of conv_expr_reference(). [-- Attachment #3: pr65548_1.patch --] [-- Type: text/x-patch, Size: 2733 bytes --] diff --git a/gcc/fortran/trans-stmt.c b/gcc/fortran/trans-stmt.c index 6ffae6e79e..68b343b 100644 --- a/gcc/fortran/trans-stmt.c +++ b/gcc/fortran/trans-stmt.c @@ -5075,12 +5075,17 @@ gfc_trans_allocate (gfc_code * code) /* In all other cases evaluate the expr3 and create a temporary. */ gfc_init_se (&se, NULL); - gfc_conv_expr_reference (&se, code->expr3); + if (code->expr3->rank != 0 + && code->expr3->expr_type == EXPR_FUNCTION + && code->expr3->value.function.isym) + gfc_conv_expr_descriptor (&se, code->expr3); + else + gfc_conv_expr_reference (&se, code->expr3); if (code->expr3->ts.type == BT_CLASS) gfc_conv_class_to_class (&se, code->expr3, code->expr3->ts, false, true, - false,false); + false, false); gfc_add_block_to_block (&block, &se.pre); gfc_add_block_to_block (&post, &se.post); /* Prevent aliasing, i.e., se.expr may be already a diff --git a/gcc/testsuite/gfortran.dg/allocate_with_source_5.f90 b/gcc/testsuite/gfortran.dg/allocate_with_source_5.f90 new file mode 100644 index 0000000..e934e08 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/allocate_with_source_5.f90 @@ -0,0 +1,52 @@ +! { dg-do run } +! +! Check that pr65548 is fixed. +! Contributed by Juergen Reuter <juergen.reuter@desy.de> + +module allocate_with_source_5_module + + type :: selector_t + integer, dimension(:), allocatable :: map + real, dimension(:), allocatable :: weight + contains + procedure :: init => selector_init + end type selector_t + +contains + + subroutine selector_init (selector, weight) + class(selector_t), intent(out) :: selector + real, dimension(:), intent(in) :: weight + real :: s + integer :: n, i + logical, dimension(:), allocatable :: mask + s = sum (weight) + allocate (mask (size (weight)), source = weight /= 0) + n = count (mask) + if (n > 0) then + allocate (selector%map (n), & + source = pack ([(i, i = 1, size (weight))], mask)) + allocate (selector%weight (n), & + source = pack (weight / s, mask)) + else + allocate (selector%map (1), source = 1) + allocate (selector%weight (1), source = 0.) + end if + end subroutine selector_init + +end module allocate_with_source_5_module + +program allocate_with_source_5 + use allocate_with_source_5_module + + class(selector_t), allocatable :: sel; + real, dimension(5) :: w = [ 1, 0, 2, 0, 3]; + + allocate (sel) + call sel%init(w) + + if (any(sel%map /= [ 1, 3, 5])) call abort() + if (any(abs(sel%weight - [1, 2, 3] / 6) < 1E-6)) call abort() +end program allocate_with_source_5 +! { dg-final { cleanup-modules "allocate_with_source_5_module" } } + ^ permalink raw reply [flat|nested] 17+ messages in thread
* Re: [Ping, Patch, fortran, pr65548, v1] [5 Regression] gfc_conv_procedure_call 2015-03-25 13:36 ` [Patch, fortran, pr65548, v1] [5 Regression] gfc_conv_procedure_call Andre Vehreschild @ 2015-04-02 10:28 ` Andre Vehreschild 2015-04-03 0:06 ` Jerry DeLisle 0 siblings, 1 reply; 17+ messages in thread From: Andre Vehreschild @ 2015-04-02 10:28 UTC (permalink / raw) To: GCC-Patches-ML, GCC-Fortran-ML; +Cc: Dominique Dhumieres Ping! This should be in 5.1. Dominique and I feel like this patch is nearly obvious. Regards, Andre On Wed, 25 Mar 2015 14:35:54 +0100 Andre Vehreschild <vehre@gmx.de> wrote: > Hi all, > > please find attached a fix for the recently introduced regression when > allocating arrays with an intrinsic function for source=. The patch addresses > this issue by using gfc_conv_expr_descriptor () for intrinsic functions. > > Bootstraps and regtests ok on x86_64-linux-gnu/F20. > > Ok for trunk? > > Regards, > Andre -- Andre Vehreschild * Email: vehre ad gmx dot de ^ permalink raw reply [flat|nested] 17+ messages in thread
* Re: [Ping, Patch, fortran, pr65548, v1] [5 Regression] gfc_conv_procedure_call 2015-04-02 10:28 ` [Ping, Patch, " Andre Vehreschild @ 2015-04-03 0:06 ` Jerry DeLisle 2015-04-07 14:12 ` Andre Vehreschild 0 siblings, 1 reply; 17+ messages in thread From: Jerry DeLisle @ 2015-04-03 0:06 UTC (permalink / raw) To: Andre Vehreschild, GCC-Patches-ML, GCC-Fortran-ML; +Cc: Dominique Dhumieres On 04/02/2015 03:28 AM, Andre Vehreschild wrote: > Ping! > > This should be in 5.1. Dominique and I feel like this patch is nearly obvious. > > Regards, > Andre > > On Wed, 25 Mar 2015 14:35:54 +0100 > Andre Vehreschild <vehre@gmx.de> wrote: > >> Hi all, >> >> please find attached a fix for the recently introduced regression when >> allocating arrays with an intrinsic function for source=. The patch addresses >> this issue by using gfc_conv_expr_descriptor () for intrinsic functions. >> >> Bootstraps and regtests ok on x86_64-linux-gnu/F20. >> >> Ok for trunk? Yes, ok for trunk. Thanks, Jerry ^ permalink raw reply [flat|nested] 17+ messages in thread
* Re: [Ping, Patch, fortran, pr65548, v1] [5 Regression] gfc_conv_procedure_call 2015-04-03 0:06 ` Jerry DeLisle @ 2015-04-07 14:12 ` Andre Vehreschild 2015-04-29 12:52 ` [Patch, fortran, pr65548, 2nd take] [5/6 " Andre Vehreschild 0 siblings, 1 reply; 17+ messages in thread From: Andre Vehreschild @ 2015-04-07 14:12 UTC (permalink / raw) To: Jerry DeLisle; +Cc: GCC-Patches-ML, GCC-Fortran-ML, Dominique Dhumieres [-- Attachment #1: Type: text/plain, Size: 887 bytes --] Hi Jerry, hi all, thank you for the review. Commited as r221897. Regards, Andre On Thu, 02 Apr 2015 17:06:07 -0700 Jerry DeLisle <jvdelisle@charter.net> wrote: > On 04/02/2015 03:28 AM, Andre Vehreschild wrote: > > Ping! > > > > This should be in 5.1. Dominique and I feel like this patch is nearly > > obvious. > > > > Regards, > > Andre > > > > On Wed, 25 Mar 2015 14:35:54 +0100 > > Andre Vehreschild <vehre@gmx.de> wrote: > > > >> Hi all, > >> > >> please find attached a fix for the recently introduced regression when > >> allocating arrays with an intrinsic function for source=. The patch > >> addresses this issue by using gfc_conv_expr_descriptor () for intrinsic > >> functions. > >> > >> Bootstraps and regtests ok on x86_64-linux-gnu/F20. > >> > >> Ok for trunk? > > Yes, ok for trunk. > > Thanks, > > Jerry > -- Andre Vehreschild * Email: vehre ad gmx dot de [-- Attachment #2: pr65548.patch --] [-- Type: text/x-patch, Size: 3658 bytes --] Index: gcc/fortran/ChangeLog =================================================================== --- gcc/fortran/ChangeLog (Revision 221896) +++ gcc/fortran/ChangeLog (Arbeitskopie) @@ -1,3 +1,9 @@ +2015-04-07 Andre Vehreschild <vehre@gmx.de> + + PR fortran/65548 + * trans-stmt.c (gfc_trans_allocate): For intrinsic functions + use conv_expr_descriptor() instead of conv_expr_reference(). + 2015-03-30 Jakub Jelinek <jakub@redhat.com> PR fortran/65597 Index: gcc/fortran/trans-stmt.c =================================================================== --- gcc/fortran/trans-stmt.c (Revision 221896) +++ gcc/fortran/trans-stmt.c (Arbeitskopie) @@ -5049,12 +5049,17 @@ /* In all other cases evaluate the expr3 and create a temporary. */ gfc_init_se (&se, NULL); - gfc_conv_expr_reference (&se, code->expr3); + if (code->expr3->rank != 0 + && code->expr3->expr_type == EXPR_FUNCTION + && code->expr3->value.function.isym) + gfc_conv_expr_descriptor (&se, code->expr3); + else + gfc_conv_expr_reference (&se, code->expr3); if (code->expr3->ts.type == BT_CLASS) gfc_conv_class_to_class (&se, code->expr3, code->expr3->ts, false, true, - false,false); + false, false); gfc_add_block_to_block (&block, &se.pre); gfc_add_block_to_block (&post, &se.post); /* Prevent aliasing, i.e., se.expr may be already a Index: gcc/testsuite/ChangeLog =================================================================== --- gcc/testsuite/ChangeLog (Revision 221896) +++ gcc/testsuite/ChangeLog (Arbeitskopie) @@ -1,3 +1,8 @@ +2015-04-07 Andre Vehreschild <vehre@gmx.de> + + PR fortran/65548 + * gfortran.dg/allocate_with_source_5.f90: New test. + 2015-04-07 Ilya Enkovich <ilya.enkovich@intel.com> * gcc.target/i386/mpx/chkp-thunk-comdat-1.cc: New. Index: gcc/testsuite/gfortran.dg/allocate_with_source_5.f90 =================================================================== --- gcc/testsuite/gfortran.dg/allocate_with_source_5.f90 (Revision 0) +++ gcc/testsuite/gfortran.dg/allocate_with_source_5.f90 (Arbeitskopie) @@ -0,0 +1,52 @@ +! { dg-do run } +! +! Check that pr65548 is fixed. +! Contributed by Juergen Reuter <juergen.reuter@desy.de> + +module allocate_with_source_5_module + + type :: selector_t + integer, dimension(:), allocatable :: map + real, dimension(:), allocatable :: weight + contains + procedure :: init => selector_init + end type selector_t + +contains + + subroutine selector_init (selector, weight) + class(selector_t), intent(out) :: selector + real, dimension(:), intent(in) :: weight + real :: s + integer :: n, i + logical, dimension(:), allocatable :: mask + s = sum (weight) + allocate (mask (size (weight)), source = weight /= 0) + n = count (mask) + if (n > 0) then + allocate (selector%map (n), & + source = pack ([(i, i = 1, size (weight))], mask)) + allocate (selector%weight (n), & + source = pack (weight / s, mask)) + else + allocate (selector%map (1), source = 1) + allocate (selector%weight (1), source = 0.) + end if + end subroutine selector_init + +end module allocate_with_source_5_module + +program allocate_with_source_5 + use allocate_with_source_5_module + + class(selector_t), allocatable :: sel; + real, dimension(5) :: w = [ 1, 0, 2, 0, 3]; + + allocate (sel) + call sel%init(w) + + if (any(sel%map /= [ 1, 3, 5])) call abort() + if (any(abs(sel%weight - [1, 2, 3] / 6) < 1E-6)) call abort() +end program allocate_with_source_5 +! { dg-final { cleanup-modules "allocate_with_source_5_module" } } + ^ permalink raw reply [flat|nested] 17+ messages in thread
* [Patch, fortran, pr65548, 2nd take] [5/6 Regression] gfc_conv_procedure_call 2015-04-07 14:12 ` Andre Vehreschild @ 2015-04-29 12:52 ` Andre Vehreschild 2015-04-30 13:30 ` [Patch, fortran, pr65548, 2nd take, v3] " Andre Vehreschild 0 siblings, 1 reply; 17+ messages in thread From: Andre Vehreschild @ 2015-04-29 12:52 UTC (permalink / raw) To: GCC-Patches-ML, GCC-Fortran-ML [-- Attachment #1: Type: text/plain, Size: 806 bytes --] Hi all, after the first patch to fix the issue reported in the pr, some more issues were reported, which are now fixed by this new patch, aka the 2nd take. The patch modifies the gfc_trans_allocate() in order to pre-evaluate all source= expressions. It no longer rejects array valued source= expressions, but just uses gfc_conv_expr_descriptor () for most of them. Furthermore, is the allocate now again able to allocate arrays of strings. This feature previously slipped my attention. Although the reporter has not yet reported, that the patch fixes his issue, I like to post it for review, because there are more patches in my pipeline, that depend on this one. Bootstraps and regtests ok on x86_64-linux-gnu/F21. Ok, for trunk? Regards, Andre -- Andre Vehreschild * Email: vehre ad gmx dot de [-- Attachment #2: pr65548_2.clog --] [-- Type: application/octet-stream, Size: 354 bytes --] gcc/fortran/ChangeLog: 2015-04-28 Andre Vehreschild <vehre@gmx.de> * trans-stmt.c (gfc_trans_allocate): Always retrieve the descriptor or a refrence to a source= expression now for arrays and non-arrays, respectively. gcc/testsuite/ChangeLog: 2015-04-28 Andre Vehreschild <vehre@gmx.de> * gfortran.dg/allocate_with_source_6.f90: New test. [-- Attachment #3: pr65548_2.patch --] [-- Type: text/x-patch, Size: 13906 bytes --] diff --git a/gcc/fortran/trans-stmt.c b/gcc/fortran/trans-stmt.c index 53e9bcc..1e435be 100644 --- a/gcc/fortran/trans-stmt.c +++ b/gcc/fortran/trans-stmt.c @@ -5148,14 +5148,11 @@ gfc_trans_allocate (gfc_code * code) TREE_USED (label_finish) = 0; } - /* When an expr3 is present, try to evaluate it only once. In most - cases expr3 is invariant for all elements of the allocation list. - Only exceptions are arrays. Furthermore the standards prevent a - dependency of expr3 on the objects in the allocate list. Therefore - it is safe to pre-evaluate expr3 for complicated expressions, i.e. - everything not a variable or constant. When an array allocation - is wanted, then the following block nevertheless evaluates the - _vptr, _len and element_size for expr3. */ + /* When an expr3 is present evaluate it only once. The standards prevent a + dependency of expr3 on the objects in the allocate list. An expr3 can + be pre-evaluated in all cases. One just has to make sure, to use the + correct way, i.e., to get the descriptor or to get a reference + expression. */ if (code->expr3) { bool vtab_needed = false; @@ -5168,75 +5165,86 @@ gfc_trans_allocate (gfc_code * code) al = al->next) vtab_needed = (al->expr->ts.type == BT_CLASS); - /* A array expr3 needs the scalarizer, therefore do not process it - here. */ - if (code->expr3->expr_type != EXPR_ARRAY - && (code->expr3->rank == 0 - || code->expr3->expr_type == EXPR_FUNCTION) - && (!code->expr3->symtree - || !code->expr3->symtree->n.sym->as) - && !gfc_is_class_array_ref (code->expr3, NULL)) - { - /* When expr3 is a variable, i.e., a very simple expression, + /* When expr3 is a variable, i.e., a very simple expression, then convert it once here. */ - if ((code->expr3->expr_type == EXPR_VARIABLE) - || code->expr3->expr_type == EXPR_CONSTANT) - { - if (!code->expr3->mold - || code->expr3->ts.type == BT_CHARACTER - || vtab_needed) - { - /* Convert expr3 to a tree. */ - gfc_init_se (&se, NULL); - se.want_pointer = 1; - gfc_conv_expr (&se, code->expr3); - if (!code->expr3->mold) - expr3 = se.expr; - else - expr3_tmp = se.expr; - expr3_len = se.string_length; - gfc_add_block_to_block (&block, &se.pre); - gfc_add_block_to_block (&post, &se.post); - } - /* else expr3 = NULL_TREE set above. */ - } - else + if (code->expr3->expr_type == EXPR_VARIABLE + || code->expr3->expr_type == EXPR_ARRAY + || code->expr3->expr_type == EXPR_CONSTANT) + { + if (!code->expr3->mold + || code->expr3->ts.type == BT_CHARACTER + || vtab_needed) { - /* In all other cases evaluate the expr3 and create a - temporary. */ + /* Convert expr3 to a tree. */ gfc_init_se (&se, NULL); - if (code->expr3->rank != 0 - && code->expr3->expr_type == EXPR_FUNCTION - && code->expr3->value.function.isym) + /* For all "simple" expression just get the descriptor or the + reference, respectively, depending on the rank of the expr. */ + if (code->expr3->rank != 0) gfc_conv_expr_descriptor (&se, code->expr3); else gfc_conv_expr_reference (&se, code->expr3); - if (code->expr3->ts.type == BT_CLASS) - gfc_conv_class_to_class (&se, code->expr3, - code->expr3->ts, - false, true, - false, false); + if (!code->expr3->mold) + expr3 = se.expr; + else + expr3_tmp = se.expr; + expr3_len = se.string_length; gfc_add_block_to_block (&block, &se.pre); gfc_add_block_to_block (&post, &se.post); - /* Prevent aliasing, i.e., se.expr may be already a + } + /* else expr3 = NULL_TREE set above. */ + } + else + { + /* In all other cases evaluate the expr3 and create a + temporary. */ + gfc_init_se (&se, NULL); + /* For more complicated expression, the decision when to get the + descriptor and when to get a reference is depending on more + conditions. The descriptor is only retrieved for functions + that are intrinsic, elemental user-defined and known, or neither + of the two, or are a class or type, that has a not deferred type + array_spec. */ + if (code->expr3->rank != 0 + && (code->expr3->expr_type != EXPR_FUNCTION + || code->expr3->value.function.isym + || (code->expr3->value.function.esym && + code->expr3->value.function.esym->attr.elemental) + || (!code->expr3->value.function.isym + && !code->expr3->value.function.esym) + || (code->expr3->ts.type == BT_DERIVED + && code->expr3->ts.u.derived->as + && code->expr3->ts.u.derived->as->type != AS_DEFERRED) + || (code->expr3->ts.type == BT_CLASS + && CLASS_DATA (code->expr3)->as + && CLASS_DATA (code->expr3)->as->type != AS_DEFERRED))) + gfc_conv_expr_descriptor (&se, code->expr3); + else + gfc_conv_expr_reference (&se, code->expr3); + if (code->expr3->ts.type == BT_CLASS) + gfc_conv_class_to_class (&se, code->expr3, + code->expr3->ts, + false, true, + false, false); + gfc_add_block_to_block (&block, &se.pre); + gfc_add_block_to_block (&post, &se.post); + /* Prevent aliasing, i.e., se.expr may be already a variable declaration. */ - if (!VAR_P (se.expr)) - { - tmp = build_fold_indirect_ref_loc (input_location, - se.expr); - tmp = gfc_evaluate_now (tmp, &block); - } - else - tmp = se.expr; - if (!code->expr3->mold) - expr3 = tmp; - else - expr3_tmp = tmp; - /* When he length of a char array is easily available - here, fix it for future use. */ - if (se.string_length) - expr3_len = gfc_evaluate_now (se.string_length, &block); + if (!VAR_P (se.expr)) + { + tmp = build_fold_indirect_ref_loc (input_location, + se.expr); + tmp = gfc_evaluate_now (tmp, &block); } + else + tmp = se.expr; + if (!code->expr3->mold) + expr3 = tmp; + else + expr3_tmp = tmp; + /* When he length of a char array is easily available + here, fix it for future use. */ + if (se.string_length) + expr3_len = gfc_evaluate_now (se.string_length, &block); } /* Figure how to get the _vtab entry. This also obtains the tree @@ -5246,11 +5254,15 @@ gfc_trans_allocate (gfc_code * code) if (code->expr3->ts.type == BT_CLASS) { gfc_expr *rhs; - /* Polymorphic SOURCE: VPTR must be determined at run time. */ - if (expr3 != NULL_TREE && (VAR_P (expr3) || !code->expr3->ref)) + /* Polymorphic SOURCE: VPTR must be determined at run time. + expr3 may be a temporary array declaration, therefore check for + GFC_CLASS_TYPE_P before trying to get the _vptr component. */ + if (expr3 != NULL_TREE && GFC_CLASS_TYPE_P (TREE_TYPE (expr3)) + && (VAR_P (expr3) || !code->expr3->ref)) tmp = gfc_class_vptr_get (expr3); else if (expr3_tmp != NULL_TREE - && (VAR_P (expr3_tmp) ||!code->expr3->ref)) + && GFC_CLASS_TYPE_P (TREE_TYPE (expr3_tmp)) + && (VAR_P (expr3_tmp) || !code->expr3->ref)) tmp = gfc_class_vptr_get (expr3_tmp); else { @@ -5634,7 +5646,7 @@ gfc_trans_allocate (gfc_code * code) if (expr3 != NULL_TREE && ((POINTER_TYPE_P (TREE_TYPE (expr3)) && TREE_CODE (expr3) != POINTER_PLUS_EXPR) - || VAR_P (expr3)) + || (VAR_P (expr3) && GFC_CLASS_TYPE_P (TREE_TYPE (expr3)))) && code->expr3->ts.type == BT_CLASS && (expr->ts.type == BT_CLASS || expr->ts.type == BT_DERIVED)) @@ -5646,14 +5658,50 @@ gfc_trans_allocate (gfc_code * code) } else if (code->expr3->ts.type == BT_CHARACTER) { - tmp = INDIRECT_REF_P (se.expr) ? + tree dst, src, dlen, slen; + /* For arrays of char arrays, a ref to the data component still + needs to be added, because se.expr upto now only contains the + descritor. */ + if (expr->ref && se.expr && TREE_TYPE (se.expr) != NULL_TREE + && GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (se.expr))) + { + dst = gfc_conv_array_data (se.expr); + src = gfc_conv_array_data (expr3); + /* For CHARACTER (len=string_length), dimension (nelems) + compute the total length of the string to copy. */ + if (nelems) + { + dlen = fold_build2_loc (input_location, MULT_EXPR, + size_type_node, + fold_convert (size_type_node, + se.string_length), + fold_convert (size_type_node, + nelems)); + slen = fold_build2_loc (input_location, MULT_EXPR, + size_type_node, + fold_convert (size_type_node, + expr3_len), + fold_convert (size_type_node, + nelems)); + } + else + { + dlen = se.string_length; + slen = expr3_len; + } + } + else + { + dst = INDIRECT_REF_P (se.expr) ? se.expr : build_fold_indirect_ref_loc (input_location, se.expr); - gfc_trans_string_copy (&block, al_len, tmp, - code->expr3->ts.kind, - expr3_len, expr3, - code->expr3->ts.kind); + src = expr3; + dlen = al_len; + slen = expr3_len; + } + gfc_trans_string_copy (&block, dlen, dst, code->expr3->ts.kind, + slen, src, code->expr3->ts.kind); tmp = NULL_TREE; } else if (al->expr->ts.type == BT_CLASS) diff --git a/gcc/testsuite/gfortran.dg/allocate_with_source_6.f90 b/gcc/testsuite/gfortran.dg/allocate_with_source_6.f90 new file mode 100644 index 0000000..d7c9ca0 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/allocate_with_source_6.f90 @@ -0,0 +1,159 @@ +! { dg-do run } +! +! Contributed by Juergen Reuter +! Check that pr65548 is fixed. +! + +module selectors + type :: selector_t + integer, dimension(:), allocatable :: map + real, dimension(:), allocatable :: weight + contains + procedure :: init => selector_init + end type selector_t + +contains + + subroutine selector_init (selector, weight) + class(selector_t), intent(out) :: selector + real, dimension(:), intent(in) :: weight + real :: s + integer :: n, i + logical, dimension(:), allocatable :: mask + s = sum (weight) + allocate (mask (size (weight)), source = weight /= 0) + n = count (mask) + if (n > 0) then + allocate (selector%map (n), & + source = pack ([(i, i = 1, size (weight))], mask)) + allocate (selector%weight (n), & + source = pack (weight / s, mask)) + else + allocate (selector%map (1), source = 1) + allocate (selector%weight (1), source = 0.) + end if + end subroutine selector_init + +end module selectors + +module phs_base + type :: flavor_t + contains + procedure :: get_mass => flavor_get_mass + end type flavor_t + + type :: phs_config_t + integer :: n_in = 0 + type(flavor_t), dimension(:,:), allocatable :: flv + end type phs_config_t + + type :: phs_t + class(phs_config_t), pointer :: config => null () + real, dimension(:), allocatable :: m_in + end type phs_t + +contains + + elemental function flavor_get_mass (flv) result (mass) + real :: mass + class(flavor_t), intent(in) :: flv + mass = 42.0 + end function flavor_get_mass + + subroutine phs_base_init (phs, phs_config) + class(phs_t), intent(out) :: phs + class(phs_config_t), intent(in), target :: phs_config + phs%config => phs_config + allocate (phs%m_in (phs%config%n_in), & + source = phs_config%flv(:phs_config%n_in, 1)%get_mass ()) + end subroutine phs_base_init + +end module phs_base + +module foo + type :: t + integer :: n + real, dimension(:,:), allocatable :: val + contains + procedure :: make => t_make + generic :: get_int => get_int_array, get_int_element + procedure :: get_int_array => t_get_int_array + procedure :: get_int_element => t_get_int_element + end type t + +contains + + subroutine t_make (this) + class(t), intent(inout) :: this + real, dimension(:), allocatable :: int + allocate (int (0:this%n-1), source=this%get_int()) + end subroutine t_make + + pure function t_get_int_array (this) result (array) + class(t), intent(in) :: this + real, dimension(this%n) :: array + array = this%val (0:this%n-1, 4) + end function t_get_int_array + + pure function t_get_int_element (this, set) result (element) + class(t), intent(in) :: this + integer, intent(in) :: set + real :: element + element = this%val (set, 4) + end function t_get_int_element +end module foo +module foo2 + type :: t2 + integer :: n + character(32), dimension(:), allocatable :: md5 + contains + procedure :: init => t2_init + end type t2 + +contains + + subroutine t2_init (this) + class(t2), intent(inout) :: this + character(32), dimension(:), allocatable :: md5 + allocate (md5 (this%n), source=this%md5) + if (md5(1) /= "tst ") call abort() + if (md5(2) /= " ") call abort() + if (md5(3) /= "fooblabar ") call abort() + end subroutine t2_init +end module foo2 + +program test + use selectors + use phs_base + use foo + use foo2 + + type(selector_t) :: sel + type(phs_t) :: phs + type(phs_config_t) :: phs_config + type(t) :: o + type(t2) :: o2 + + call sel%init([2., 0., 3., 0., 4.]) + + if (any(sel%map /= [1, 3, 5])) call abort() + if (any(sel%weight /= [2./9., 3./9., 4./9.])) call abort() + + phs_config%n_in = 2 + allocate (phs_config%flv (phs_config%n_in, 1)) + call phs_base_init (phs, phs_config) + + if (any (phs%m_in /= [42.0, 42.0])) call abort() + + o%n = 2 + allocate (o%val(2,4)) + call o%make() + + o2%n = 3 + allocate(o2%md5(o2%n)) + o2%md5(1) = "tst" + o2%md5(2) = "" + o2%md5(3) = "fooblabar" + call o2%init() +end program test + ^ permalink raw reply [flat|nested] 17+ messages in thread
* Re: [Patch, fortran, pr65548, 2nd take, v3] [5/6 Regression] gfc_conv_procedure_call 2015-04-29 12:52 ` [Patch, fortran, pr65548, 2nd take] [5/6 " Andre Vehreschild @ 2015-04-30 13:30 ` Andre Vehreschild 2015-05-12 22:04 ` Mikael Morin 0 siblings, 1 reply; 17+ messages in thread From: Andre Vehreschild @ 2015-04-30 13:30 UTC (permalink / raw) To: GCC-Patches-ML, GCC-Fortran-ML [-- Attachment #1: Type: text/plain, Size: 1502 bytes --] Hi all, this is just a service release. I encountered that the new testcase in the previous release included the testcase of the initial patch, that is already on trunk. I therefore replaced the testcase allocate_with_source_5.f90 by allocate_with_source_6.f90 (the extended testcase). Besides this there is no difference inbetween this and the patch in: https://gcc.gnu.org/ml/fortran/2015-04/msg00121.html Sorry for the mess. For a description of the original patches scope see below. Bootstraps and regtests ok on x86_64-linux-gnu/F21. Ok for trunk? Regards, Andre On Wed, 29 Apr 2015 14:31:01 +0200 Andre Vehreschild <vehre@gmx.de> wrote: > Hi all, > > after the first patch to fix the issue reported in the pr, some more issues > were reported, which are now fixed by this new patch, aka the 2nd take. > > The patch modifies the gfc_trans_allocate() in order to pre-evaluate all > source= expressions. It no longer rejects array valued source= expressions, > but just uses gfc_conv_expr_descriptor () for most of them. Furthermore, is > the allocate now again able to allocate arrays of strings. This feature > previously slipped my attention. > > Although the reporter has not yet reported, that the patch fixes his issue, I > like to post it for review, because there are more patches in my pipeline, > that depend on this one. > > Bootstraps and regtests ok on x86_64-linux-gnu/F21. > > Ok, for trunk? > > Regards, > Andre -- Andre Vehreschild * Email: vehre ad gmx dot de [-- Attachment #2: pr65548_3.clog --] [-- Type: application/octet-stream, Size: 393 bytes --] gcc/fortran/ChangeLog: 2015-04-28 Andre Vehreschild <vehre@gmx.de> PR fortran/65548 * trans-stmt.c (gfc_trans_allocate): Always retrieve the descriptor or a refrence to a source= expression now for arrays and non-arrays, respectively. gcc/testsuite/ChangeLog: 2015-04-28 Andre Vehreschild <vehre@gmx.de> PR fortran/65548 * gfortran.dg/allocate_with_source_5.f90: Extend test. [-- Attachment #3: pr65548_3.patch --] [-- Type: text/x-patch, Size: 14058 bytes --] diff --git a/gcc/fortran/trans-stmt.c b/gcc/fortran/trans-stmt.c index 53e9bcc..1e435be 100644 --- a/gcc/fortran/trans-stmt.c +++ b/gcc/fortran/trans-stmt.c @@ -5148,14 +5148,11 @@ gfc_trans_allocate (gfc_code * code) TREE_USED (label_finish) = 0; } - /* When an expr3 is present, try to evaluate it only once. In most - cases expr3 is invariant for all elements of the allocation list. - Only exceptions are arrays. Furthermore the standards prevent a - dependency of expr3 on the objects in the allocate list. Therefore - it is safe to pre-evaluate expr3 for complicated expressions, i.e. - everything not a variable or constant. When an array allocation - is wanted, then the following block nevertheless evaluates the - _vptr, _len and element_size for expr3. */ + /* When an expr3 is present evaluate it only once. The standards prevent a + dependency of expr3 on the objects in the allocate list. An expr3 can + be pre-evaluated in all cases. One just has to make sure, to use the + correct way, i.e., to get the descriptor or to get a reference + expression. */ if (code->expr3) { bool vtab_needed = false; @@ -5168,75 +5165,86 @@ gfc_trans_allocate (gfc_code * code) al = al->next) vtab_needed = (al->expr->ts.type == BT_CLASS); - /* A array expr3 needs the scalarizer, therefore do not process it - here. */ - if (code->expr3->expr_type != EXPR_ARRAY - && (code->expr3->rank == 0 - || code->expr3->expr_type == EXPR_FUNCTION) - && (!code->expr3->symtree - || !code->expr3->symtree->n.sym->as) - && !gfc_is_class_array_ref (code->expr3, NULL)) - { - /* When expr3 is a variable, i.e., a very simple expression, + /* When expr3 is a variable, i.e., a very simple expression, then convert it once here. */ - if ((code->expr3->expr_type == EXPR_VARIABLE) - || code->expr3->expr_type == EXPR_CONSTANT) - { - if (!code->expr3->mold - || code->expr3->ts.type == BT_CHARACTER - || vtab_needed) - { - /* Convert expr3 to a tree. */ - gfc_init_se (&se, NULL); - se.want_pointer = 1; - gfc_conv_expr (&se, code->expr3); - if (!code->expr3->mold) - expr3 = se.expr; - else - expr3_tmp = se.expr; - expr3_len = se.string_length; - gfc_add_block_to_block (&block, &se.pre); - gfc_add_block_to_block (&post, &se.post); - } - /* else expr3 = NULL_TREE set above. */ - } - else + if (code->expr3->expr_type == EXPR_VARIABLE + || code->expr3->expr_type == EXPR_ARRAY + || code->expr3->expr_type == EXPR_CONSTANT) + { + if (!code->expr3->mold + || code->expr3->ts.type == BT_CHARACTER + || vtab_needed) { - /* In all other cases evaluate the expr3 and create a - temporary. */ + /* Convert expr3 to a tree. */ gfc_init_se (&se, NULL); - if (code->expr3->rank != 0 - && code->expr3->expr_type == EXPR_FUNCTION - && code->expr3->value.function.isym) + /* For all "simple" expression just get the descriptor or the + reference, respectively, depending on the rank of the expr. */ + if (code->expr3->rank != 0) gfc_conv_expr_descriptor (&se, code->expr3); else gfc_conv_expr_reference (&se, code->expr3); - if (code->expr3->ts.type == BT_CLASS) - gfc_conv_class_to_class (&se, code->expr3, - code->expr3->ts, - false, true, - false, false); + if (!code->expr3->mold) + expr3 = se.expr; + else + expr3_tmp = se.expr; + expr3_len = se.string_length; gfc_add_block_to_block (&block, &se.pre); gfc_add_block_to_block (&post, &se.post); - /* Prevent aliasing, i.e., se.expr may be already a + } + /* else expr3 = NULL_TREE set above. */ + } + else + { + /* In all other cases evaluate the expr3 and create a + temporary. */ + gfc_init_se (&se, NULL); + /* For more complicated expression, the decision when to get the + descriptor and when to get a reference is depending on more + conditions. The descriptor is only retrieved for functions + that are intrinsic, elemental user-defined and known, or neither + of the two, or are a class or type, that has a not deferred type + array_spec. */ + if (code->expr3->rank != 0 + && (code->expr3->expr_type != EXPR_FUNCTION + || code->expr3->value.function.isym + || (code->expr3->value.function.esym && + code->expr3->value.function.esym->attr.elemental) + || (!code->expr3->value.function.isym + && !code->expr3->value.function.esym) + || (code->expr3->ts.type == BT_DERIVED + && code->expr3->ts.u.derived->as + && code->expr3->ts.u.derived->as->type != AS_DEFERRED) + || (code->expr3->ts.type == BT_CLASS + && CLASS_DATA (code->expr3)->as + && CLASS_DATA (code->expr3)->as->type != AS_DEFERRED))) + gfc_conv_expr_descriptor (&se, code->expr3); + else + gfc_conv_expr_reference (&se, code->expr3); + if (code->expr3->ts.type == BT_CLASS) + gfc_conv_class_to_class (&se, code->expr3, + code->expr3->ts, + false, true, + false, false); + gfc_add_block_to_block (&block, &se.pre); + gfc_add_block_to_block (&post, &se.post); + /* Prevent aliasing, i.e., se.expr may be already a variable declaration. */ - if (!VAR_P (se.expr)) - { - tmp = build_fold_indirect_ref_loc (input_location, - se.expr); - tmp = gfc_evaluate_now (tmp, &block); - } - else - tmp = se.expr; - if (!code->expr3->mold) - expr3 = tmp; - else - expr3_tmp = tmp; - /* When he length of a char array is easily available - here, fix it for future use. */ - if (se.string_length) - expr3_len = gfc_evaluate_now (se.string_length, &block); + if (!VAR_P (se.expr)) + { + tmp = build_fold_indirect_ref_loc (input_location, + se.expr); + tmp = gfc_evaluate_now (tmp, &block); } + else + tmp = se.expr; + if (!code->expr3->mold) + expr3 = tmp; + else + expr3_tmp = tmp; + /* When he length of a char array is easily available + here, fix it for future use. */ + if (se.string_length) + expr3_len = gfc_evaluate_now (se.string_length, &block); } /* Figure how to get the _vtab entry. This also obtains the tree @@ -5246,11 +5254,15 @@ gfc_trans_allocate (gfc_code * code) if (code->expr3->ts.type == BT_CLASS) { gfc_expr *rhs; - /* Polymorphic SOURCE: VPTR must be determined at run time. */ - if (expr3 != NULL_TREE && (VAR_P (expr3) || !code->expr3->ref)) + /* Polymorphic SOURCE: VPTR must be determined at run time. + expr3 may be a temporary array declaration, therefore check for + GFC_CLASS_TYPE_P before trying to get the _vptr component. */ + if (expr3 != NULL_TREE && GFC_CLASS_TYPE_P (TREE_TYPE (expr3)) + && (VAR_P (expr3) || !code->expr3->ref)) tmp = gfc_class_vptr_get (expr3); else if (expr3_tmp != NULL_TREE - && (VAR_P (expr3_tmp) ||!code->expr3->ref)) + && GFC_CLASS_TYPE_P (TREE_TYPE (expr3_tmp)) + && (VAR_P (expr3_tmp) || !code->expr3->ref)) tmp = gfc_class_vptr_get (expr3_tmp); else { @@ -5634,7 +5646,7 @@ gfc_trans_allocate (gfc_code * code) if (expr3 != NULL_TREE && ((POINTER_TYPE_P (TREE_TYPE (expr3)) && TREE_CODE (expr3) != POINTER_PLUS_EXPR) - || VAR_P (expr3)) + || (VAR_P (expr3) && GFC_CLASS_TYPE_P (TREE_TYPE (expr3)))) && code->expr3->ts.type == BT_CLASS && (expr->ts.type == BT_CLASS || expr->ts.type == BT_DERIVED)) @@ -5646,14 +5658,50 @@ gfc_trans_allocate (gfc_code * code) } else if (code->expr3->ts.type == BT_CHARACTER) { - tmp = INDIRECT_REF_P (se.expr) ? + tree dst, src, dlen, slen; + /* For arrays of char arrays, a ref to the data component still + needs to be added, because se.expr upto now only contains the + descritor. */ + if (expr->ref && se.expr && TREE_TYPE (se.expr) != NULL_TREE + && GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (se.expr))) + { + dst = gfc_conv_array_data (se.expr); + src = gfc_conv_array_data (expr3); + /* For CHARACTER (len=string_length), dimension (nelems) + compute the total length of the string to copy. */ + if (nelems) + { + dlen = fold_build2_loc (input_location, MULT_EXPR, + size_type_node, + fold_convert (size_type_node, + se.string_length), + fold_convert (size_type_node, + nelems)); + slen = fold_build2_loc (input_location, MULT_EXPR, + size_type_node, + fold_convert (size_type_node, + expr3_len), + fold_convert (size_type_node, + nelems)); + } + else + { + dlen = se.string_length; + slen = expr3_len; + } + } + else + { + dst = INDIRECT_REF_P (se.expr) ? se.expr : build_fold_indirect_ref_loc (input_location, se.expr); - gfc_trans_string_copy (&block, al_len, tmp, - code->expr3->ts.kind, - expr3_len, expr3, - code->expr3->ts.kind); + src = expr3; + dlen = al_len; + slen = expr3_len; + } + gfc_trans_string_copy (&block, dlen, dst, code->expr3->ts.kind, + slen, src, code->expr3->ts.kind); tmp = NULL_TREE; } else if (al->expr->ts.type == BT_CLASS) diff --git a/gcc/testsuite/gfortran.dg/allocate_with_source_5.f90 b/gcc/testsuite/gfortran.dg/allocate_with_source_5.f90 index e934e08..500f0f0 100644 --- a/gcc/testsuite/gfortran.dg/allocate_with_source_5.f90 +++ b/gcc/testsuite/gfortran.dg/allocate_with_source_5.f90 @@ -1,16 +1,16 @@ ! { dg-do run } ! +! Contributed by Juergen Reuter ! Check that pr65548 is fixed. -! Contributed by Juergen Reuter <juergen.reuter@desy.de> - -module allocate_with_source_5_module +! +module selectors type :: selector_t - integer, dimension(:), allocatable :: map - real, dimension(:), allocatable :: weight - contains - procedure :: init => selector_init - end type selector_t + integer, dimension(:), allocatable :: map + real, dimension(:), allocatable :: weight + contains + procedure :: init => selector_init + end type selector_t contains @@ -34,19 +34,126 @@ contains end if end subroutine selector_init -end module allocate_with_source_5_module +end module selectors + +module phs_base + type :: flavor_t + contains + procedure :: get_mass => flavor_get_mass + end type flavor_t + + type :: phs_config_t + integer :: n_in = 0 + type(flavor_t), dimension(:,:), allocatable :: flv + end type phs_config_t + + type :: phs_t + class(phs_config_t), pointer :: config => null () + real, dimension(:), allocatable :: m_in + end type phs_t + +contains + + elemental function flavor_get_mass (flv) result (mass) + real :: mass + class(flavor_t), intent(in) :: flv + mass = 42.0 + end function flavor_get_mass + + subroutine phs_base_init (phs, phs_config) + class(phs_t), intent(out) :: phs + class(phs_config_t), intent(in), target :: phs_config + phs%config => phs_config + allocate (phs%m_in (phs%config%n_in), & + source = phs_config%flv(:phs_config%n_in, 1)%get_mass ()) + end subroutine phs_base_init + +end module phs_base + +module foo + type :: t + integer :: n + real, dimension(:,:), allocatable :: val + contains + procedure :: make => t_make + generic :: get_int => get_int_array, get_int_element + procedure :: get_int_array => t_get_int_array + procedure :: get_int_element => t_get_int_element + end type t + +contains + + subroutine t_make (this) + class(t), intent(inout) :: this + real, dimension(:), allocatable :: int + allocate (int (0:this%n-1), source=this%get_int()) + end subroutine t_make + + pure function t_get_int_array (this) result (array) + class(t), intent(in) :: this + real, dimension(this%n) :: array + array = this%val (0:this%n-1, 4) + end function t_get_int_array + + pure function t_get_int_element (this, set) result (element) + class(t), intent(in) :: this + integer, intent(in) :: set + real :: element + element = this%val (set, 4) + end function t_get_int_element +end module foo +module foo2 + type :: t2 + integer :: n + character(32), dimension(:), allocatable :: md5 + contains + procedure :: init => t2_init + end type t2 + +contains + + subroutine t2_init (this) + class(t2), intent(inout) :: this + character(32), dimension(:), allocatable :: md5 + allocate (md5 (this%n), source=this%md5) + if (md5(1) /= "tst ") call abort() + if (md5(2) /= " ") call abort() + if (md5(3) /= "fooblabar ") call abort() + end subroutine t2_init +end module foo2 + +program test + use selectors + use phs_base + use foo + use foo2 + + type(selector_t) :: sel + type(phs_t) :: phs + type(phs_config_t) :: phs_config + type(t) :: o + type(t2) :: o2 + + call sel%init([2., 0., 3., 0., 4.]) + + if (any(sel%map /= [1, 3, 5])) call abort() + if (any(abs(sel%weight - [2., 3., 4.] / 9.) > 1E-6)) call abort() -program allocate_with_source_5 - use allocate_with_source_5_module + phs_config%n_in = 2 + allocate (phs_config%flv (phs_config%n_in, 1)) + call phs_base_init (phs, phs_config) - class(selector_t), allocatable :: sel; - real, dimension(5) :: w = [ 1, 0, 2, 0, 3]; + if (any(abs(phs%m_in - [42.0, 42.0]) > 1E-6)) call abort() - allocate (sel) - call sel%init(w) + o%n = 2 + allocate (o%val(2,4)) + call o%make() - if (any(sel%map /= [ 1, 3, 5])) call abort() - if (any(abs(sel%weight - [1, 2, 3] / 6) < 1E-6)) call abort() -end program allocate_with_source_5 -! { dg-final { cleanup-modules "allocate_with_source_5_module" } } + o2%n = 3 + allocate(o2%md5(o2%n)) + o2%md5(1) = "tst" + o2%md5(2) = "" + o2%md5(3) = "fooblabar" + call o2%init() +end program test ^ permalink raw reply [flat|nested] 17+ messages in thread
* Re: [Patch, fortran, pr65548, 2nd take, v3] [5/6 Regression] gfc_conv_procedure_call 2015-04-30 13:30 ` [Patch, fortran, pr65548, 2nd take, v3] " Andre Vehreschild @ 2015-05-12 22:04 ` Mikael Morin 2015-05-13 9:31 ` Andre Vehreschild 0 siblings, 1 reply; 17+ messages in thread From: Mikael Morin @ 2015-05-12 22:04 UTC (permalink / raw) To: Andre Vehreschild, GCC-Patches-ML, GCC-Fortran-ML Hello, Le 30/04/2015 15:07, Andre Vehreschild a écrit : > Hi all, > > this is just a service release. I encountered that the new testcase in the > previous release included the testcase of the initial patch, that is > already on trunk. I therefore replaced the testcase allocate_with_source_5.f90 > by allocate_with_source_6.f90 (the extended testcase). Besides this there is no > difference inbetween this and the patch in: > > https://gcc.gnu.org/ml/fortran/2015-04/msg00121.html > > Sorry for the mess. For a description of the original patches scope see below. > > Bootstraps and regtests ok on x86_64-linux-gnu/F21. > > Ok for trunk? > > Regards, > Andre > > On Wed, 29 Apr 2015 14:31:01 +0200 > Andre Vehreschild <vehre@gmx.de> wrote: > >> Hi all, >> >> after the first patch to fix the issue reported in the pr, some more issues >> were reported, which are now fixed by this new patch, aka the 2nd take. >> >> The patch modifies the gfc_trans_allocate() in order to pre-evaluate all >> source= expressions. It no longer rejects array valued source= expressions, >> but just uses gfc_conv_expr_descriptor () for most of them. Furthermore, is >> the allocate now again able to allocate arrays of strings. This feature >> previously slipped my attention. >> >> Although the reporter has not yet reported, that the patch fixes his issue, I >> like to post it for review, because there are more patches in my pipeline, >> that depend on this one. >> >> Bootstraps and regtests ok on x86_64-linux-gnu/F21. >> >> Ok, for trunk? >> questions below > > > *** trans-stmt.c 2015-05-12 14:42:17.882108651 +0200 > --- trans-stmt.c.modif 2015-05-12 14:42:11.300108561 +0200 > *************** > *** 5205,5213 **** > /* In all other cases evaluate the expr3 and create a > temporary. */ > gfc_init_se (&se, NULL); > if (code->expr3->rank != 0 > ! && code->expr3->expr_type == EXPR_FUNCTION > ! && code->expr3->value.function.isym) > gfc_conv_expr_descriptor (&se, code->expr3); > else > gfc_conv_expr_reference (&se, code->expr3); > --- 5198,5222 ---- > /* In all other cases evaluate the expr3 and create a > temporary. */ > gfc_init_se (&se, NULL); > + /* For more complicated expression, the decision when to get the > + descriptor and when to get a reference is depending on more > + conditions. The descriptor is only retrieved for functions > + that are intrinsic, elemental user-defined and known, or neither > + of the two, or are a class or type, that has a not deferred type > + array_spec. */ > if (code->expr3->rank != 0 > ! && (code->expr3->expr_type != EXPR_FUNCTION > ! || code->expr3->value.function.isym > ! || (code->expr3->value.function.esym && > ! code->expr3->value.function.esym->attr.elemental) > ! || (!code->expr3->value.function.isym > ! && !code->expr3->value.function.esym) > ! || (code->expr3->ts.type == BT_DERIVED > ! && code->expr3->ts.u.derived->as > ! && code->expr3->ts.u.derived->as->type != AS_DEFERRED) > ! || (code->expr3->ts.type == BT_CLASS > ! && CLASS_DATA (code->expr3)->as > ! && CLASS_DATA (code->expr3)->as->type != AS_DEFERRED))) > gfc_conv_expr_descriptor (&se, code->expr3); > else > gfc_conv_expr_reference (&se, code->expr3); What is the rationale for choosing between gfc_conv_expr_descriptor and gfc_conv_expr_reference? Is it contiguous array vs non-contiguous or needing an evaluation? For example why not use gfc_conv_expr_descriptor for derived type arrays? > *************** > *** 5646,5659 **** > } > else if (code->expr3->ts.type == BT_CHARACTER) > { > ! tmp = INDIRECT_REF_P (se.expr) ? > se.expr : > build_fold_indirect_ref_loc (input_location, > se.expr); > ! gfc_trans_string_copy (&block, al_len, tmp, > ! code->expr3->ts.kind, > ! expr3_len, expr3, > ! code->expr3->ts.kind); > tmp = NULL_TREE; > } > else if (al->expr->ts.type == BT_CLASS) > --- 5658,5707 ---- > } > else if (code->expr3->ts.type == BT_CHARACTER) > { > ! tree dst, src, dlen, slen; > ! /* For arrays of char arrays, a ref to the data component still > ! needs to be added, because se.expr upto now only contains the > ! descritor. */ > ! if (expr->ref && se.expr && TREE_TYPE (se.expr) != NULL_TREE > ! && GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (se.expr))) > ! { > ! dst = gfc_conv_array_data (se.expr); > ! src = gfc_conv_array_data (expr3); > ! /* For CHARACTER (len=string_length), dimension (nelems) > ! compute the total length of the string to copy. */ > ! if (nelems) > ! { > ! dlen = fold_build2_loc (input_location, MULT_EXPR, > ! size_type_node, > ! fold_convert (size_type_node, > ! se.string_length), > ! fold_convert (size_type_node, > ! nelems)); > ! slen = fold_build2_loc (input_location, MULT_EXPR, > ! size_type_node, > ! fold_convert (size_type_node, > ! expr3_len), > ! fold_convert (size_type_node, > ! nelems)); > ! } > ! else > ! { > ! dlen = se.string_length; > ! slen = expr3_len; > ! } > ! } > ! else > ! { > ! dst = INDIRECT_REF_P (se.expr) ? > se.expr : > build_fold_indirect_ref_loc (input_location, > se.expr); > ! src = expr3; > ! dlen = al_len; > ! slen = expr3_len; > ! } > ! gfc_trans_string_copy (&block, dlen, dst, code->expr3->ts.kind, > ! slen, src, code->expr3->ts.kind); > tmp = NULL_TREE; > } > else if (al->expr->ts.type == BT_CLASS) This seems to assume that the array is contiguous. Can't we just fall back to the default case for characters? The rest looks good. Mikael ^ permalink raw reply [flat|nested] 17+ messages in thread
* Re: [Patch, fortran, pr65548, 2nd take, v3] [5/6 Regression] gfc_conv_procedure_call 2015-05-12 22:04 ` Mikael Morin @ 2015-05-13 9:31 ` Andre Vehreschild 2015-05-14 9:49 ` [Patch, fortran, pr65548, 2nd take, v4] " Andre Vehreschild 0 siblings, 1 reply; 17+ messages in thread From: Andre Vehreschild @ 2015-05-13 9:31 UTC (permalink / raw) To: Mikael Morin; +Cc: GCC-Patches-ML, GCC-Fortran-ML Hi Mikael, <snip> > > --- 5198,5222 ---- > > /* In all other cases evaluate the expr3 and create a > > temporary. */ > > gfc_init_se (&se, NULL); > > + /* For more complicated expression, the decision when to get the > > + descriptor and when to get a reference is depending on more > > + conditions. The descriptor is only retrieved for functions > > + that are intrinsic, elemental user-defined and known, or > > neither > > + of the two, or are a class or type, that has a not deferred > > type > > + array_spec. */ > > if (code->expr3->rank != 0 > > ! && (code->expr3->expr_type != EXPR_FUNCTION > > ! || code->expr3->value.function.isym > > ! || (code->expr3->value.function.esym && > > ! code->expr3->value.function.esym->attr.elemental) > > ! || (!code->expr3->value.function.isym > > ! && !code->expr3->value.function.esym) > > ! || (code->expr3->ts.type == BT_DERIVED > > ! && code->expr3->ts.u.derived->as > > ! && code->expr3->ts.u.derived->as->type != > > AS_DEFERRED) ! || (code->expr3->ts.type == BT_CLASS > > ! && CLASS_DATA (code->expr3)->as > > ! && CLASS_DATA (code->expr3)->as->type != > > AS_DEFERRED))) gfc_conv_expr_descriptor (&se, code->expr3); > > else > > gfc_conv_expr_reference (&se, code->expr3); > What is the rationale for choosing between gfc_conv_expr_descriptor and > gfc_conv_expr_reference? The rationale is to get the array descriptor for all arrays, but deferred type ones. For deferred type ones gfc_conv_expr_descriptor either failed or the result does not satisfy further processing needs. > Is it contiguous array vs non-contiguous or needing an evaluation? Neither. How the array is shaped is not of my concern. > For example why not use gfc_conv_expr_descriptor for derived type arrays? But it does use gfc_conv_expr_descriptor for derived type arrays! It is just not used for deferred ones. > > *************** > > *** 5646,5659 **** > > } > > else if (code->expr3->ts.type == BT_CHARACTER) > > { > > ! tmp = INDIRECT_REF_P (se.expr) ? > > se.expr : > > build_fold_indirect_ref_loc (input_location, > > se.expr); > > ! gfc_trans_string_copy (&block, al_len, tmp, > > ! code->expr3->ts.kind, > > ! expr3_len, expr3, > > ! code->expr3->ts.kind); > > tmp = NULL_TREE; > > } > > else if (al->expr->ts.type == BT_CLASS) > > --- 5658,5707 ---- > > } > > else if (code->expr3->ts.type == BT_CHARACTER) > > { > > ! tree dst, src, dlen, slen; > > ! /* For arrays of char arrays, a ref to the data component > > still ! needs to be added, because se.expr upto now only > > contains the ! descritor. */ > > ! if (expr->ref && se.expr && TREE_TYPE (se.expr) != NULL_TREE > > ! && GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (se.expr))) > > ! { > > ! dst = gfc_conv_array_data (se.expr); > > ! src = gfc_conv_array_data (expr3); > > ! /* For CHARACTER (len=string_length), dimension (nelems) > > ! compute the total length of the string to copy. */ > > ! if (nelems) > > ! { > > ! dlen = fold_build2_loc (input_location, MULT_EXPR, > > ! size_type_node, > > ! fold_convert > > (size_type_node, ! > > se.string_length), ! > > fold_convert > > (size_type_node, ! > > nelems)); ! > > slen = fold_build2_loc (input_location, MULT_EXPR, ! > > size_type_node, ! > > fold_convert > > (size_type_node, ! > > expr3_len), ! > > fold_convert > > (size_type_node, ! > > nelems)); ! > > } ! else ! { ! > > dlen = se.string_length; ! slen > > = expr3_len; ! } ! } > > ! else > > ! { > > ! dst = INDIRECT_REF_P (se.expr) ? > > se.expr : > > build_fold_indirect_ref_loc (input_location, > > se.expr); > > ! src = expr3; > > ! dlen = al_len; > > ! slen = expr3_len; > > ! } > > ! gfc_trans_string_copy (&block, dlen, dst, > > code->expr3->ts.kind, ! slen, src, > > code->expr3->ts.kind); tmp = NULL_TREE; > > } > > else if (al->expr->ts.type == BT_CLASS) > This seems to assume that the array is contiguous. > Can't we just fall back to the default case for characters? What do you take as the default case for characters? You are right the above code assumes the array of char arrays is contiguous, which I admit to fail when the array isn't. Any experience of how to do this better? gfc_trans_string_copy is not capable of copying multiple strings, so how to do it most future safe? Any idea? Regards, Andre -- Andre Vehreschild * Email: vehre ad gmx dot de ^ permalink raw reply [flat|nested] 17+ messages in thread
* Re: [Patch, fortran, pr65548, 2nd take, v4] [5/6 Regression] gfc_conv_procedure_call 2015-05-13 9:31 ` Andre Vehreschild @ 2015-05-14 9:49 ` Andre Vehreschild 2015-05-19 8:52 ` [Patch, fortran, pr65548, 2nd take, v5] " Andre Vehreschild 0 siblings, 1 reply; 17+ messages in thread From: Andre Vehreschild @ 2015-05-14 9:49 UTC (permalink / raw) To: Mikael Morin; +Cc: GCC-Patches-ML, GCC-Fortran-ML [-- Attachment #1: Type: text/plain, Size: 950 bytes --] Hi Mikael, hi all, please find attached the new version of this patch, where most of the source= expression assignment to the object to allocate is handled by gfc_trans_assignment (). To use trans_assignment with temporaries introduced during the preparation of the source= expression, a gfc_expr is created from the temporary identifier in the tree of expr3. This creation is done only, when the tree is an artificial declaration, i.e., a temporary. The gfx_expr is created only once and only for non-class objects, because for the latter gfc_trans_assignment can't cope with class arrays, for which the gfc_trans_allocate () needs the array-descriptor, which is not as easy to transfer to gfc_trans_assignment (). For class objects gfc_trans_allocate () therefore cares about the assignment/data copy itself. Bootstraps and regtests ok on x86_64-linux-gnu/f21. Ok for trunk? Regards, Andre -- Andre Vehreschild * Email: vehre ad gmx dot de [-- Attachment #2: pr65548_4.clog --] [-- Type: text/plain, Size: 494 bytes --] gcc/fortran/ChangeLog: 2015-05-14 Andre Vehreschild <vehre@gmx.de> PR fortran/65548 * trans-stmt.c (gfc_trans_allocate): Always retrieve the descriptor or a reference to a source= expression now for arrays and non-arrays, respectively. Use a temporary symbol and gfc_trans_assignment for all source= assignments to allocated objects. gcc/testsuite/ChangeLog: 2015-05-14 Andre Vehreschild <vehre@gmx.de> PR fortran/65548 * gfortran.dg/allocate_with_source_5.f90: Extend test. [-- Attachment #3: pr65548_4.patch --] [-- Type: text/x-patch, Size: 18004 bytes --] diff --git a/gcc/fortran/trans-stmt.c b/gcc/fortran/trans-stmt.c index 814bdde..9688f71 100644 --- a/gcc/fortran/trans-stmt.c +++ b/gcc/fortran/trans-stmt.c @@ -5088,7 +5088,7 @@ tree gfc_trans_allocate (gfc_code * code) { gfc_alloc *al; - gfc_expr *expr; + gfc_expr *expr, *e3rhs = NULL; gfc_se se, se_sz; tree tmp; tree parm; @@ -5148,14 +5148,11 @@ gfc_trans_allocate (gfc_code * code) TREE_USED (label_finish) = 0; } - /* When an expr3 is present, try to evaluate it only once. In most - cases expr3 is invariant for all elements of the allocation list. - Only exceptions are arrays. Furthermore the standards prevent a - dependency of expr3 on the objects in the allocate list. Therefore - it is safe to pre-evaluate expr3 for complicated expressions, i.e. - everything not a variable or constant. When an array allocation - is wanted, then the following block nevertheless evaluates the - _vptr, _len and element_size for expr3. */ + /* When an expr3 is present evaluate it only once. The standards prevent a + dependency of expr3 on the objects in the allocate list. An expr3 can + be pre-evaluated in all cases. One just has to make sure, to use the + correct way, i.e., to get the descriptor or to get a reference + expression. */ if (code->expr3) { bool vtab_needed = false; @@ -5168,75 +5165,91 @@ gfc_trans_allocate (gfc_code * code) al = al->next) vtab_needed = (al->expr->ts.type == BT_CLASS); - /* A array expr3 needs the scalarizer, therefore do not process it - here. */ - if (code->expr3->expr_type != EXPR_ARRAY - && (code->expr3->rank == 0 - || code->expr3->expr_type == EXPR_FUNCTION) - && (!code->expr3->symtree - || !code->expr3->symtree->n.sym->as) - && !gfc_is_class_array_ref (code->expr3, NULL)) - { - /* When expr3 is a variable, i.e., a very simple expression, + /* When expr3 is a variable, i.e., a very simple expression, then convert it once here. */ - if ((code->expr3->expr_type == EXPR_VARIABLE) - || code->expr3->expr_type == EXPR_CONSTANT) - { - if (!code->expr3->mold - || code->expr3->ts.type == BT_CHARACTER - || vtab_needed) - { - /* Convert expr3 to a tree. */ - gfc_init_se (&se, NULL); - se.want_pointer = 1; - gfc_conv_expr (&se, code->expr3); - if (!code->expr3->mold) - expr3 = se.expr; - else - expr3_tmp = se.expr; - expr3_len = se.string_length; - gfc_add_block_to_block (&block, &se.pre); - gfc_add_block_to_block (&post, &se.post); - } - /* else expr3 = NULL_TREE set above. */ - } - else + if (code->expr3->expr_type == EXPR_VARIABLE + || code->expr3->expr_type == EXPR_ARRAY + || code->expr3->expr_type == EXPR_CONSTANT) + { + if (!code->expr3->mold + || code->expr3->ts.type == BT_CHARACTER + || vtab_needed) { - /* In all other cases evaluate the expr3 and create a - temporary. */ + /* Convert expr3 to a tree. */ gfc_init_se (&se, NULL); - if (code->expr3->rank != 0 - && code->expr3->expr_type == EXPR_FUNCTION - && code->expr3->value.function.isym) + /* For all "simple" expression just get the descriptor or the + reference, respectively, depending on the rank of the expr. */ + if (code->expr3->rank != 0) gfc_conv_expr_descriptor (&se, code->expr3); else gfc_conv_expr_reference (&se, code->expr3); - if (code->expr3->ts.type == BT_CLASS) - gfc_conv_class_to_class (&se, code->expr3, - code->expr3->ts, - false, true, - false, false); + if (!code->expr3->mold) + expr3 = se.expr; + else + expr3_tmp = se.expr; + expr3_len = se.string_length; gfc_add_block_to_block (&block, &se.pre); gfc_add_block_to_block (&post, &se.post); - /* Prevent aliasing, i.e., se.expr may be already a + } + /* else expr3 = NULL_TREE set above. */ + } + else + { + /* In all other cases evaluate the expr3 and create a + temporary. */ + gfc_init_se (&se, NULL); + /* For more complicated expression, the decision when to get the + descriptor and when to get a reference is depending on more + conditions. The descriptor is only retrieved for functions + that are intrinsic, elemental user-defined and known, or neither + of the two, or are a class or type, that has a not deferred type + array_spec. */ + if (code->expr3->rank != 0 + && (code->expr3->expr_type != EXPR_FUNCTION + || code->expr3->value.function.isym + || (code->expr3->value.function.esym && + code->expr3->value.function.esym->attr.elemental) + || (!code->expr3->value.function.isym + && !code->expr3->value.function.esym) + || (code->expr3->ts.type == BT_DERIVED + && code->expr3->ts.u.derived->as + && code->expr3->ts.u.derived->as->type != AS_DEFERRED) + || (code->expr3->ts.type == BT_CLASS + && CLASS_DATA (code->expr3)->as + && CLASS_DATA (code->expr3)->as->type != AS_DEFERRED))) + gfc_conv_expr_descriptor (&se, code->expr3); + else + gfc_conv_expr_reference (&se, code->expr3); + if (code->expr3->ts.type == BT_CLASS) + gfc_conv_class_to_class (&se, code->expr3, + code->expr3->ts, + false, true, + false, false); + gfc_add_block_to_block (&block, &se.pre); + gfc_add_block_to_block (&post, &se.post); + /* Prevent aliasing, i.e., se.expr may be already a variable declaration. */ - if (!VAR_P (se.expr)) - { - tmp = build_fold_indirect_ref_loc (input_location, - se.expr); - tmp = gfc_evaluate_now (tmp, &block); - } - else - tmp = se.expr; - if (!code->expr3->mold) - expr3 = tmp; - else - expr3_tmp = tmp; - /* When he length of a char array is easily available - here, fix it for future use. */ - if (se.string_length) - expr3_len = gfc_evaluate_now (se.string_length, &block); + if (!VAR_P (se.expr)) + { + tree var; + tmp = build_fold_indirect_ref_loc (input_location, + se.expr); + /* We need a regular (non-UID) symbol here, therefore give a + prefix. */ + var = gfc_create_var (TREE_TYPE (tmp), "atmp"); + gfc_add_modify_loc (input_location, &block, var, tmp); + tmp = var; } + else + tmp = se.expr; + if (!code->expr3->mold) + expr3 = tmp; + else + expr3_tmp = tmp; + /* When he length of a char array is easily available + here, fix it for future use. */ + if (se.string_length) + expr3_len = gfc_evaluate_now (se.string_length, &block); } /* Figure how to get the _vtab entry. This also obtains the tree @@ -5246,11 +5259,15 @@ gfc_trans_allocate (gfc_code * code) if (code->expr3->ts.type == BT_CLASS) { gfc_expr *rhs; - /* Polymorphic SOURCE: VPTR must be determined at run time. */ - if (expr3 != NULL_TREE && (VAR_P (expr3) || !code->expr3->ref)) + /* Polymorphic SOURCE: VPTR must be determined at run time. + expr3 may be a temporary array declaration, therefore check for + GFC_CLASS_TYPE_P before trying to get the _vptr component. */ + if (expr3 != NULL_TREE && GFC_CLASS_TYPE_P (TREE_TYPE (expr3)) + && (VAR_P (expr3) || !code->expr3->ref)) tmp = gfc_class_vptr_get (expr3); else if (expr3_tmp != NULL_TREE - && (VAR_P (expr3_tmp) ||!code->expr3->ref)) + && GFC_CLASS_TYPE_P (TREE_TYPE (expr3_tmp)) + && (VAR_P (expr3_tmp) || !code->expr3->ref)) tmp = gfc_class_vptr_get (expr3_tmp); else { @@ -5325,6 +5342,62 @@ 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. */ + e3rhs = gfc_copy_expr (code->expr3); + if (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. */ + gfc_symtree *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 temporary is likely to need no references, but a + full array ref, therefore clear the chain of refs. */ + gfc_free_ref_list (e3rhs->ref); + e3rhs->ref = NULL; + /* The backend_decl is known. It is expr3, which is inserted + here. */ + newsym->n.sym->backend_decl = expr3; + e3rhs->symtree = newsym; + /* Mark the symbol referenced or gfc_trans_assignment will + bug. */ + newsym->n.sym->attr.referenced = 1; + e3rhs->expr_type = EXPR_VARIABLE; + /* 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); + } + /* The string length is known to. Set it for char arrays. */ + if (code->expr3->ts.type == BT_CHARACTER) + newsym->n.sym->ts.u.cl->backend_decl = expr3_len; + gfc_commit_symbol (newsym->n.sym); + } } gcc_assert (expr3_esize); expr3_esize = fold_convert (sizetype, expr3_esize); @@ -5628,13 +5701,12 @@ gfc_trans_allocate (gfc_code * code) } if (code->expr3 && !code->expr3->mold) { - /* Initialization via SOURCE block - (or static default initializer). */ - gfc_expr *rhs = gfc_copy_expr (code->expr3); + /* Initialization via SOURCE block (or static default initializer). + Classes need some special handling, so catch them first. */ if (expr3 != NULL_TREE && ((POINTER_TYPE_P (TREE_TYPE (expr3)) && TREE_CODE (expr3) != POINTER_PLUS_EXPR) - || VAR_P (expr3)) + || (VAR_P (expr3) && GFC_CLASS_TYPE_P (TREE_TYPE (expr3)))) && code->expr3->ts.type == BT_CLASS && (expr->ts.type == BT_CLASS || expr->ts.type == BT_DERIVED)) @@ -5644,24 +5716,13 @@ gfc_trans_allocate (gfc_code * code) tmp = gfc_copy_class_to_class (expr3, to, nelems, upoly_expr); } - else if (code->expr3->ts.type == BT_CHARACTER) - { - tmp = INDIRECT_REF_P (se.expr) ? - se.expr : - build_fold_indirect_ref_loc (input_location, - se.expr); - gfc_trans_string_copy (&block, al_len, tmp, - code->expr3->ts.kind, - expr3_len, expr3, - code->expr3->ts.kind); - tmp = NULL_TREE; - } 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 = gfc_copy_expr (code->expr3); /* Do a polymorphic deep copy. */ actual = gfc_get_actual_arglist (); @@ -5688,8 +5749,8 @@ gfc_trans_allocate (gfc_code * code) gfc_ref *ref = dataref->next; ref->u.ar.type = AR_SECTION; /* We have to set up the array reference to give ranges - in all dimensions and ensure that the end and stride - are set so that the copy can be scalarized. */ + in all dimensions and ensure that the end and stride + are set so that the copy can be scalarized. */ dim = 0; for (; dim < dataref->u.c.component->as->rank; dim++) { @@ -5758,8 +5819,8 @@ gfc_trans_allocate (gfc_code * code) 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); + last_arg->expr = + gfc_copy_expr (code->expr3->ts.u.cl->length); else gcc_unreachable (); @@ -5773,6 +5834,7 @@ gfc_trans_allocate (gfc_code * code) void_type_node, tmp, extcopy, stdcopy); } gfc_free_statements (ppc_code); + gfc_free_expr (rhs); } else { @@ -5781,10 +5843,9 @@ gfc_trans_allocate (gfc_code * code) int realloc_lhs = flag_realloc_lhs; flag_realloc_lhs = 0; tmp = gfc_trans_assignment (gfc_expr_to_initialize (expr), - rhs, false, false); + e3rhs, false, false); flag_realloc_lhs = realloc_lhs; } - gfc_free_expr (rhs); gfc_add_expr_to_block (&block, tmp); } else if (code->expr3 && code->expr3->mold diff --git a/gcc/testsuite/gfortran.dg/allocate_with_source_5.f90 b/gcc/testsuite/gfortran.dg/allocate_with_source_5.f90 index e934e08..500f0f0 100644 --- a/gcc/testsuite/gfortran.dg/allocate_with_source_5.f90 +++ b/gcc/testsuite/gfortran.dg/allocate_with_source_5.f90 @@ -1,16 +1,16 @@ ! { dg-do run } ! +! Contributed by Juergen Reuter ! Check that pr65548 is fixed. -! Contributed by Juergen Reuter <juergen.reuter@desy.de> - -module allocate_with_source_5_module +! +module selectors type :: selector_t - integer, dimension(:), allocatable :: map - real, dimension(:), allocatable :: weight - contains - procedure :: init => selector_init - end type selector_t + integer, dimension(:), allocatable :: map + real, dimension(:), allocatable :: weight + contains + procedure :: init => selector_init + end type selector_t contains @@ -34,19 +34,126 @@ contains end if end subroutine selector_init -end module allocate_with_source_5_module +end module selectors + +module phs_base + type :: flavor_t + contains + procedure :: get_mass => flavor_get_mass + end type flavor_t + + type :: phs_config_t + integer :: n_in = 0 + type(flavor_t), dimension(:,:), allocatable :: flv + end type phs_config_t + + type :: phs_t + class(phs_config_t), pointer :: config => null () + real, dimension(:), allocatable :: m_in + end type phs_t + +contains + + elemental function flavor_get_mass (flv) result (mass) + real :: mass + class(flavor_t), intent(in) :: flv + mass = 42.0 + end function flavor_get_mass + + subroutine phs_base_init (phs, phs_config) + class(phs_t), intent(out) :: phs + class(phs_config_t), intent(in), target :: phs_config + phs%config => phs_config + allocate (phs%m_in (phs%config%n_in), & + source = phs_config%flv(:phs_config%n_in, 1)%get_mass ()) + end subroutine phs_base_init + +end module phs_base + +module foo + type :: t + integer :: n + real, dimension(:,:), allocatable :: val + contains + procedure :: make => t_make + generic :: get_int => get_int_array, get_int_element + procedure :: get_int_array => t_get_int_array + procedure :: get_int_element => t_get_int_element + end type t + +contains + + subroutine t_make (this) + class(t), intent(inout) :: this + real, dimension(:), allocatable :: int + allocate (int (0:this%n-1), source=this%get_int()) + end subroutine t_make + + pure function t_get_int_array (this) result (array) + class(t), intent(in) :: this + real, dimension(this%n) :: array + array = this%val (0:this%n-1, 4) + end function t_get_int_array + + pure function t_get_int_element (this, set) result (element) + class(t), intent(in) :: this + integer, intent(in) :: set + real :: element + element = this%val (set, 4) + end function t_get_int_element +end module foo +module foo2 + type :: t2 + integer :: n + character(32), dimension(:), allocatable :: md5 + contains + procedure :: init => t2_init + end type t2 + +contains + + subroutine t2_init (this) + class(t2), intent(inout) :: this + character(32), dimension(:), allocatable :: md5 + allocate (md5 (this%n), source=this%md5) + if (md5(1) /= "tst ") call abort() + if (md5(2) /= " ") call abort() + if (md5(3) /= "fooblabar ") call abort() + end subroutine t2_init +end module foo2 + +program test + use selectors + use phs_base + use foo + use foo2 + + type(selector_t) :: sel + type(phs_t) :: phs + type(phs_config_t) :: phs_config + type(t) :: o + type(t2) :: o2 + + call sel%init([2., 0., 3., 0., 4.]) + + if (any(sel%map /= [1, 3, 5])) call abort() + if (any(abs(sel%weight - [2., 3., 4.] / 9.) > 1E-6)) call abort() -program allocate_with_source_5 - use allocate_with_source_5_module + phs_config%n_in = 2 + allocate (phs_config%flv (phs_config%n_in, 1)) + call phs_base_init (phs, phs_config) - class(selector_t), allocatable :: sel; - real, dimension(5) :: w = [ 1, 0, 2, 0, 3]; + if (any(abs(phs%m_in - [42.0, 42.0]) > 1E-6)) call abort() - allocate (sel) - call sel%init(w) + o%n = 2 + allocate (o%val(2,4)) + call o%make() - if (any(sel%map /= [ 1, 3, 5])) call abort() - if (any(abs(sel%weight - [1, 2, 3] / 6) < 1E-6)) call abort() -end program allocate_with_source_5 -! { dg-final { cleanup-modules "allocate_with_source_5_module" } } + o2%n = 3 + allocate(o2%md5(o2%n)) + o2%md5(1) = "tst" + o2%md5(2) = "" + o2%md5(3) = "fooblabar" + call o2%init() +end program test ^ permalink raw reply [flat|nested] 17+ messages in thread
* Re: [Patch, fortran, pr65548, 2nd take, v5] [5/6 Regression] gfc_conv_procedure_call 2015-05-14 9:49 ` [Patch, fortran, pr65548, 2nd take, v4] " Andre Vehreschild @ 2015-05-19 8:52 ` Andre Vehreschild 2015-05-19 14:07 ` Mikael Morin 0 siblings, 1 reply; 17+ messages in thread From: Andre Vehreschild @ 2015-05-19 8:52 UTC (permalink / raw) To: Mikael Morin; +Cc: GCC-Patches-ML, GCC-Fortran-ML [-- Attachment #1: Type: text/plain, Size: 166 bytes --] Hi all, find attached latest version to fix 65548. Bootstraps and regtests ok on x86_64-linux-gnu/f21. - Andre -- Andre Vehreschild * Email: vehre ad gmx dot de [-- Attachment #2: pr65548_5.clog --] [-- Type: application/octet-stream, Size: 527 bytes --] gcc/fortran/ChangeLog: 2015-05-19 Andre Vehreschild <vehre@gmx.de> PR fortran/65548 * trans-stmt.c (gfc_trans_allocate): Always retrieve the descriptor or a reference to a source= expression for arrays and non-arrays, respectively. Use a temporary symbol and gfc_trans_assignment for all source= assignments to allocated objects besides for class and derived types. gcc/testsuite/ChangeLog: 2015-05-19 Andre Vehreschild <vehre@gmx.de> PR fortran/65548 * gfortran.dg/allocate_with_source_5.f90: Extend test. [-- Attachment #3: pr65548_5.patch --] [-- Type: text/x-patch, Size: 17748 bytes --] diff --git a/gcc/fortran/trans-stmt.c b/gcc/fortran/trans-stmt.c index 814bdde..6d565ae 100644 --- a/gcc/fortran/trans-stmt.c +++ b/gcc/fortran/trans-stmt.c @@ -5088,7 +5088,7 @@ tree gfc_trans_allocate (gfc_code * code) { gfc_alloc *al; - gfc_expr *expr; + gfc_expr *expr, *e3rhs = NULL; gfc_se se, se_sz; tree tmp; tree parm; @@ -5109,6 +5109,7 @@ gfc_trans_allocate (gfc_code * code) stmtblock_t post; tree nelems; bool upoly_expr, tmp_expr3_len_flag = false, al_len_needs_set; + gfc_symtree *newsym = NULL; if (!code->ext.alloc.list) return NULL_TREE; @@ -5148,14 +5149,11 @@ gfc_trans_allocate (gfc_code * code) TREE_USED (label_finish) = 0; } - /* When an expr3 is present, try to evaluate it only once. In most - cases expr3 is invariant for all elements of the allocation list. - Only exceptions are arrays. Furthermore the standards prevent a - dependency of expr3 on the objects in the allocate list. Therefore - it is safe to pre-evaluate expr3 for complicated expressions, i.e. - everything not a variable or constant. When an array allocation - is wanted, then the following block nevertheless evaluates the - _vptr, _len and element_size for expr3. */ + /* When an expr3 is present evaluate it only once. The standards prevent a + dependency of expr3 on the objects in the allocate list. An expr3 can + be pre-evaluated in all cases. One just has to make sure, to use the + correct way, i.e., to get the descriptor or to get a reference + expression. */ if (code->expr3) { bool vtab_needed = false; @@ -5168,75 +5166,77 @@ gfc_trans_allocate (gfc_code * code) al = al->next) vtab_needed = (al->expr->ts.type == BT_CLASS); - /* A array expr3 needs the scalarizer, therefore do not process it - here. */ - if (code->expr3->expr_type != EXPR_ARRAY - && (code->expr3->rank == 0 - || code->expr3->expr_type == EXPR_FUNCTION) - && (!code->expr3->symtree - || !code->expr3->symtree->n.sym->as) - && !gfc_is_class_array_ref (code->expr3, NULL)) - { - /* When expr3 is a variable, i.e., a very simple expression, + /* When expr3 is a variable, i.e., a very simple expression, then convert it once here. */ - if ((code->expr3->expr_type == EXPR_VARIABLE) - || code->expr3->expr_type == EXPR_CONSTANT) - { - if (!code->expr3->mold - || code->expr3->ts.type == BT_CHARACTER - || vtab_needed) - { - /* Convert expr3 to a tree. */ - gfc_init_se (&se, NULL); - se.want_pointer = 1; - gfc_conv_expr (&se, code->expr3); - if (!code->expr3->mold) - expr3 = se.expr; - else - expr3_tmp = se.expr; - expr3_len = se.string_length; - gfc_add_block_to_block (&block, &se.pre); - gfc_add_block_to_block (&post, &se.post); - } - /* else expr3 = NULL_TREE set above. */ - } - else + if (code->expr3->expr_type == EXPR_VARIABLE + || code->expr3->expr_type == EXPR_ARRAY + || code->expr3->expr_type == EXPR_CONSTANT) + { + if (!code->expr3->mold + || code->expr3->ts.type == BT_CHARACTER + || vtab_needed) { - /* In all other cases evaluate the expr3 and create a - temporary. */ + /* Convert expr3 to a tree. */ gfc_init_se (&se, NULL); - if (code->expr3->rank != 0 - && code->expr3->expr_type == EXPR_FUNCTION - && code->expr3->value.function.isym) + /* For all "simple" expression just get the descriptor or the + reference, respectively, depending on the rank of the expr. */ + if (code->expr3->rank != 0) gfc_conv_expr_descriptor (&se, code->expr3); else gfc_conv_expr_reference (&se, code->expr3); - if (code->expr3->ts.type == BT_CLASS) - gfc_conv_class_to_class (&se, code->expr3, - code->expr3->ts, - false, true, - false, false); + if (!code->expr3->mold) + expr3 = se.expr; + else + expr3_tmp = se.expr; + expr3_len = se.string_length; gfc_add_block_to_block (&block, &se.pre); gfc_add_block_to_block (&post, &se.post); - /* Prevent aliasing, i.e., se.expr may be already a + } + /* else expr3 = NULL_TREE set above. */ + } + else + { + /* In all other cases evaluate the expr3 and create a + temporary. */ + gfc_init_se (&se, NULL); + symbol_attribute attr; + /* Get the descriptor for all arrays, that are not allocatable or + pointer, because the latter are descriptors already. */ + attr = gfc_expr_attr (code->expr3); + if (code->expr3->rank != 0 && !attr.allocatable && !attr.pointer) + gfc_conv_expr_descriptor (&se, code->expr3); + else + gfc_conv_expr_reference (&se, code->expr3); + if (code->expr3->ts.type == BT_CLASS) + gfc_conv_class_to_class (&se, code->expr3, + code->expr3->ts, + false, true, + false, false); + gfc_add_block_to_block (&block, &se.pre); + gfc_add_block_to_block (&post, &se.post); + /* Prevent aliasing, i.e., se.expr may be already a variable declaration. */ - if (!VAR_P (se.expr)) - { - tmp = build_fold_indirect_ref_loc (input_location, - se.expr); - tmp = gfc_evaluate_now (tmp, &block); - } - else - tmp = se.expr; - if (!code->expr3->mold) - expr3 = tmp; - else - expr3_tmp = tmp; - /* When he length of a char array is easily available - here, fix it for future use. */ - if (se.string_length) - expr3_len = gfc_evaluate_now (se.string_length, &block); + if (!VAR_P (se.expr)) + { + tree var; + tmp = build_fold_indirect_ref_loc (input_location, + se.expr); + /* We need a regular (non-UID) symbol here, therefore give a + prefix. */ + var = gfc_create_var (TREE_TYPE (tmp), "atmp"); + gfc_add_modify_loc (input_location, &block, var, tmp); + tmp = var; } + else + tmp = se.expr; + if (!code->expr3->mold) + expr3 = tmp; + else + expr3_tmp = tmp; + /* When he length of a char array is easily available + here, fix it for future use. */ + if (se.string_length) + expr3_len = gfc_evaluate_now (se.string_length, &block); } /* Figure how to get the _vtab entry. This also obtains the tree @@ -5246,11 +5246,15 @@ gfc_trans_allocate (gfc_code * code) if (code->expr3->ts.type == BT_CLASS) { gfc_expr *rhs; - /* Polymorphic SOURCE: VPTR must be determined at run time. */ - if (expr3 != NULL_TREE && (VAR_P (expr3) || !code->expr3->ref)) + /* Polymorphic SOURCE: VPTR must be determined at run time. + expr3 may be a temporary array declaration, therefore check for + GFC_CLASS_TYPE_P before trying to get the _vptr component. */ + if (expr3 != NULL_TREE && GFC_CLASS_TYPE_P (TREE_TYPE (expr3)) + && (VAR_P (expr3) || !code->expr3->ref)) tmp = gfc_class_vptr_get (expr3); else if (expr3_tmp != NULL_TREE - && (VAR_P (expr3_tmp) ||!code->expr3->ref)) + && GFC_CLASS_TYPE_P (TREE_TYPE (expr3_tmp)) + && (VAR_P (expr3_tmp) || !code->expr3->ref)) tmp = gfc_class_vptr_get (expr3_tmp); else { @@ -5325,6 +5329,62 @@ 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. */ + if (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; + /* 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); + } + /* 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); @@ -5628,13 +5688,12 @@ gfc_trans_allocate (gfc_code * code) } if (code->expr3 && !code->expr3->mold) { - /* Initialization via SOURCE block - (or static default initializer). */ - gfc_expr *rhs = gfc_copy_expr (code->expr3); + /* Initialization via SOURCE block (or static default initializer). + Classes need some special handling, so catch them first. */ if (expr3 != NULL_TREE && ((POINTER_TYPE_P (TREE_TYPE (expr3)) && TREE_CODE (expr3) != POINTER_PLUS_EXPR) - || VAR_P (expr3)) + || (VAR_P (expr3) && GFC_CLASS_TYPE_P (TREE_TYPE (expr3)))) && code->expr3->ts.type == BT_CLASS && (expr->ts.type == BT_CLASS || expr->ts.type == BT_DERIVED)) @@ -5644,24 +5703,13 @@ gfc_trans_allocate (gfc_code * code) tmp = gfc_copy_class_to_class (expr3, to, nelems, upoly_expr); } - else if (code->expr3->ts.type == BT_CHARACTER) - { - tmp = INDIRECT_REF_P (se.expr) ? - se.expr : - build_fold_indirect_ref_loc (input_location, - se.expr); - gfc_trans_string_copy (&block, al_len, tmp, - code->expr3->ts.kind, - expr3_len, expr3, - code->expr3->ts.kind); - tmp = NULL_TREE; - } 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 = gfc_copy_expr (code->expr3); /* Do a polymorphic deep copy. */ actual = gfc_get_actual_arglist (); @@ -5688,8 +5736,8 @@ gfc_trans_allocate (gfc_code * code) gfc_ref *ref = dataref->next; ref->u.ar.type = AR_SECTION; /* We have to set up the array reference to give ranges - in all dimensions and ensure that the end and stride - are set so that the copy can be scalarized. */ + in all dimensions and ensure that the end and stride + are set so that the copy can be scalarized. */ dim = 0; for (; dim < dataref->u.c.component->as->rank; dim++) { @@ -5758,8 +5806,8 @@ gfc_trans_allocate (gfc_code * code) 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); + last_arg->expr = + gfc_copy_expr (code->expr3->ts.u.cl->length); else gcc_unreachable (); @@ -5773,6 +5821,7 @@ gfc_trans_allocate (gfc_code * code) void_type_node, tmp, extcopy, stdcopy); } gfc_free_statements (ppc_code); + gfc_free_expr (rhs); } else { @@ -5781,10 +5830,9 @@ gfc_trans_allocate (gfc_code * code) int realloc_lhs = flag_realloc_lhs; flag_realloc_lhs = 0; tmp = gfc_trans_assignment (gfc_expr_to_initialize (expr), - rhs, false, false); + e3rhs, false, false); flag_realloc_lhs = realloc_lhs; } - gfc_free_expr (rhs); gfc_add_expr_to_block (&block, tmp); } else if (code->expr3 && code->expr3->mold @@ -5802,6 +5850,15 @@ gfc_trans_allocate (gfc_code * code) gfc_free_expr (expr); } // for-loop + if (e3rhs) + { + if (newsym) + { + gfc_free_symbol (newsym->n.sym); + XDELETE (newsym); + } + gfc_free_expr (e3rhs); + } /* STAT. */ if (code->expr1) { diff --git a/gcc/testsuite/gfortran.dg/allocate_with_source_5.f90 b/gcc/testsuite/gfortran.dg/allocate_with_source_5.f90 index e934e08..500f0f0 100644 --- a/gcc/testsuite/gfortran.dg/allocate_with_source_5.f90 +++ b/gcc/testsuite/gfortran.dg/allocate_with_source_5.f90 @@ -1,16 +1,16 @@ ! { dg-do run } ! +! Contributed by Juergen Reuter ! Check that pr65548 is fixed. -! Contributed by Juergen Reuter <juergen.reuter@desy.de> - -module allocate_with_source_5_module +! +module selectors type :: selector_t - integer, dimension(:), allocatable :: map - real, dimension(:), allocatable :: weight - contains - procedure :: init => selector_init - end type selector_t + integer, dimension(:), allocatable :: map + real, dimension(:), allocatable :: weight + contains + procedure :: init => selector_init + end type selector_t contains @@ -34,19 +34,126 @@ contains end if end subroutine selector_init -end module allocate_with_source_5_module +end module selectors + +module phs_base + type :: flavor_t + contains + procedure :: get_mass => flavor_get_mass + end type flavor_t + + type :: phs_config_t + integer :: n_in = 0 + type(flavor_t), dimension(:,:), allocatable :: flv + end type phs_config_t + + type :: phs_t + class(phs_config_t), pointer :: config => null () + real, dimension(:), allocatable :: m_in + end type phs_t + +contains + + elemental function flavor_get_mass (flv) result (mass) + real :: mass + class(flavor_t), intent(in) :: flv + mass = 42.0 + end function flavor_get_mass + + subroutine phs_base_init (phs, phs_config) + class(phs_t), intent(out) :: phs + class(phs_config_t), intent(in), target :: phs_config + phs%config => phs_config + allocate (phs%m_in (phs%config%n_in), & + source = phs_config%flv(:phs_config%n_in, 1)%get_mass ()) + end subroutine phs_base_init + +end module phs_base + +module foo + type :: t + integer :: n + real, dimension(:,:), allocatable :: val + contains + procedure :: make => t_make + generic :: get_int => get_int_array, get_int_element + procedure :: get_int_array => t_get_int_array + procedure :: get_int_element => t_get_int_element + end type t + +contains + + subroutine t_make (this) + class(t), intent(inout) :: this + real, dimension(:), allocatable :: int + allocate (int (0:this%n-1), source=this%get_int()) + end subroutine t_make + + pure function t_get_int_array (this) result (array) + class(t), intent(in) :: this + real, dimension(this%n) :: array + array = this%val (0:this%n-1, 4) + end function t_get_int_array + + pure function t_get_int_element (this, set) result (element) + class(t), intent(in) :: this + integer, intent(in) :: set + real :: element + element = this%val (set, 4) + end function t_get_int_element +end module foo +module foo2 + type :: t2 + integer :: n + character(32), dimension(:), allocatable :: md5 + contains + procedure :: init => t2_init + end type t2 + +contains + + subroutine t2_init (this) + class(t2), intent(inout) :: this + character(32), dimension(:), allocatable :: md5 + allocate (md5 (this%n), source=this%md5) + if (md5(1) /= "tst ") call abort() + if (md5(2) /= " ") call abort() + if (md5(3) /= "fooblabar ") call abort() + end subroutine t2_init +end module foo2 + +program test + use selectors + use phs_base + use foo + use foo2 + + type(selector_t) :: sel + type(phs_t) :: phs + type(phs_config_t) :: phs_config + type(t) :: o + type(t2) :: o2 + + call sel%init([2., 0., 3., 0., 4.]) + + if (any(sel%map /= [1, 3, 5])) call abort() + if (any(abs(sel%weight - [2., 3., 4.] / 9.) > 1E-6)) call abort() -program allocate_with_source_5 - use allocate_with_source_5_module + phs_config%n_in = 2 + allocate (phs_config%flv (phs_config%n_in, 1)) + call phs_base_init (phs, phs_config) - class(selector_t), allocatable :: sel; - real, dimension(5) :: w = [ 1, 0, 2, 0, 3]; + if (any(abs(phs%m_in - [42.0, 42.0]) > 1E-6)) call abort() - allocate (sel) - call sel%init(w) + o%n = 2 + allocate (o%val(2,4)) + call o%make() - if (any(sel%map /= [ 1, 3, 5])) call abort() - if (any(abs(sel%weight - [1, 2, 3] / 6) < 1E-6)) call abort() -end program allocate_with_source_5 -! { dg-final { cleanup-modules "allocate_with_source_5_module" } } + o2%n = 3 + allocate(o2%md5(o2%n)) + o2%md5(1) = "tst" + o2%md5(2) = "" + o2%md5(3) = "fooblabar" + call o2%init() +end program test ^ permalink raw reply [flat|nested] 17+ messages in thread
* Re: [Patch, fortran, pr65548, 2nd take, v5] [5/6 Regression] gfc_conv_procedure_call 2015-05-19 8:52 ` [Patch, fortran, pr65548, 2nd take, v5] " Andre Vehreschild @ 2015-05-19 14:07 ` Mikael Morin 2015-05-20 8:31 ` Andre Vehreschild 0 siblings, 1 reply; 17+ messages in thread From: Mikael Morin @ 2015-05-19 14:07 UTC (permalink / raw) To: Andre Vehreschild; +Cc: GCC-Patches-ML, GCC-Fortran-ML Le 19/05/2015 10:50, Andre Vehreschild a écrit : > Hi all, > > find attached latest version to fix 65548. > > Bootstraps and regtests ok on x86_64-linux-gnu/f21. > OK. Thanks. Mikael ^ permalink raw reply [flat|nested] 17+ messages in thread
* Re: [Patch, fortran, pr65548, 2nd take, v5] [5/6 Regression] gfc_conv_procedure_call 2015-05-19 14:07 ` Mikael Morin @ 2015-05-20 8:31 ` Andre Vehreschild 2015-05-20 13:29 ` Mikael Morin 0 siblings, 1 reply; 17+ messages in thread From: Andre Vehreschild @ 2015-05-20 8:31 UTC (permalink / raw) To: Mikael Morin; +Cc: GCC-Patches-ML, GCC-Fortran-ML Hi Mikael, when I got you right on IRC, then you proposed this change about the pointer attribute: diff --git a/gcc/fortran/trans-stmt.c b/gcc/fortran/trans-stmt.c index 6d565ae..545f778 100644 --- a/gcc/fortran/trans-stmt.c +++ b/gcc/fortran/trans-stmt.c @@ -5361,6 +5361,7 @@ gfc_trans_allocate (gfc_code * code) /* Mark the symbol referenced or gfc_trans_assignment will bug. */ newsym->n.sym->attr.referenced = 1; + newsym->n.sym->attr.pointer = 1; e3rhs->expr_type = EXPR_VARIABLE; /* Set the symbols type, upto it was BT_UNKNOWN. */ newsym->n.sym->ts = e3rhs->ts; @@ -5374,7 +5375,6 @@ gfc_trans_allocate (gfc_code * code) /* 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); } Unfortunately does this lead to numerous regressions in the testsuite. For example: ./gfortran.sh -g allocate_alloc_opt_6.f90 -o allocate_alloc_opt_6 Fortraning using ***DEVelopment*** version... allocate_alloc_opt_6.f90:26:0: allocate(t, source=mytype(1.0,2)) ^ internal compiler error: Segmentation fault 0xe09a08 crash_signal /home/vehre/Projekte/c_gcc_fortran2003_enhancements_cmbant_freelancer//gcc/gcc/toplev.c:380 0xa9cbe1 useless_type_conversion_p(tree_node*, tree_node*) /home/vehre/Projekte/c_gcc_fortran2003_enhancements_cmbant_freelancer//gcc/gcc/gimple-expr.c:83 0x10622ae tree_ssa_useless_type_conversion(tree_node*) /home/vehre/Projekte/c_gcc_fortran2003_enhancements_cmbant_freelancer//gcc/gcc/tree-ssa.c:1178 0x10622fe tree_ssa_strip_useless_type_conversions(tree_node*) /home/vehre/Projekte/c_gcc_fortran2003_enhancements_cmbant_freelancer//gcc/gcc/tree-ssa.c:1190 0xb6c4ae gimplify_expr(tree_node**, gimple_statement_base**, gimple_statement_base**, bool (*)(tree_node*), int) /home/vehre/Projekte/c_gcc_fortran2003_enhancements_cmbant_freelancer//gcc/gcc/gimplify.c:7815 0xb5e883 gimplify_modify_expr /home/vehre/Projekte/c_gcc_fortran2003_enhancements_cmbant_freelancer//gcc/gcc/gimplify.c:4644 I therefore came to a more elaborate change (revert the above one before testing this): diff --git a/gcc/fortran/trans-stmt.c b/gcc/fortran/trans-stmt.c index 6d565ae..7b466de 100644 --- a/gcc/fortran/trans-stmt.c +++ b/gcc/fortran/trans-stmt.c @@ -5378,6 +5378,10 @@ gfc_trans_allocate (gfc_code * code) 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; + else + newsym->n.sym->attr.value = 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; This patch bootstraps and regtests fine again. Ok to commit? Regards, Andre On Tue, 19 May 2015 16:02:18 +0200 Mikael Morin <mikael.morin@sfr.fr> wrote: > Le 19/05/2015 10:50, Andre Vehreschild a écrit : > > Hi all, > > > > find attached latest version to fix 65548. > > > > Bootstraps and regtests ok on x86_64-linux-gnu/f21. > > > OK. Thanks. > > Mikael -- Andre Vehreschild * Email: vehre ad gmx dot de ^ permalink raw reply [flat|nested] 17+ messages in thread
* Re: [Patch, fortran, pr65548, 2nd take, v5] [5/6 Regression] gfc_conv_procedure_call 2015-05-20 8:31 ` Andre Vehreschild @ 2015-05-20 13:29 ` Mikael Morin 2015-05-20 15:28 ` Andre Vehreschild 0 siblings, 1 reply; 17+ messages in thread From: Mikael Morin @ 2015-05-20 13:29 UTC (permalink / raw) To: Andre Vehreschild; +Cc: GCC-Patches-ML, GCC-Fortran-ML Le 20/05/2015 10:24, Andre Vehreschild a écrit : > Hi Mikael, > > when I got you right on IRC, then you proposed this change about the pointer > attribute: > > diff --git a/gcc/fortran/trans-stmt.c b/gcc/fortran/trans-stmt.c > index 6d565ae..545f778 100644 > --- a/gcc/fortran/trans-stmt.c > +++ b/gcc/fortran/trans-stmt.c > @@ -5361,6 +5361,7 @@ gfc_trans_allocate (gfc_code * code) > /* Mark the symbol referenced or gfc_trans_assignment will > bug. */ > newsym->n.sym->attr.referenced = 1; > + newsym->n.sym->attr.pointer = 1; > e3rhs->expr_type = EXPR_VARIABLE; > /* Set the symbols type, upto it was BT_UNKNOWN. */ > newsym->n.sym->ts = e3rhs->ts; > @@ -5374,7 +5375,6 @@ gfc_trans_allocate (gfc_code * code) > /* 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); > } > > Unfortunately does this lead to numerous regressions in the testsuite. For > example: > > ./gfortran.sh -g allocate_alloc_opt_6.f90 -o allocate_alloc_opt_6 > Fortraning using ***DEVelopment*** version... > allocate_alloc_opt_6.f90:26:0: > > allocate(t, source=mytype(1.0,2)) > ^ > internal compiler error: Segmentation fault > 0xe09a08 crash_signal > /home/vehre/Projekte/c_gcc_fortran2003_enhancements_cmbant_freelancer//gcc/gcc/toplev.c:380 > 0xa9cbe1 useless_type_conversion_p(tree_node*, tree_node*) > /home/vehre/Projekte/c_gcc_fortran2003_enhancements_cmbant_freelancer//gcc/gcc/gimple-expr.c:83 > 0x10622ae tree_ssa_useless_type_conversion(tree_node*) > /home/vehre/Projekte/c_gcc_fortran2003_enhancements_cmbant_freelancer//gcc/gcc/tree-ssa.c:1178 > 0x10622fe tree_ssa_strip_useless_type_conversions(tree_node*) > /home/vehre/Projekte/c_gcc_fortran2003_enhancements_cmbant_freelancer//gcc/gcc/tree-ssa.c:1190 > 0xb6c4ae gimplify_expr(tree_node**, gimple_statement_base**, > gimple_statement_base**, bool (*)(tree_node*), int) > /home/vehre/Projekte/c_gcc_fortran2003_enhancements_cmbant_freelancer//gcc/gcc/gimplify.c:7815 > 0xb5e883 gimplify_modify_expr > /home/vehre/Projekte/c_gcc_fortran2003_enhancements_cmbant_freelancer//gcc/gcc/gimplify.c:4644 > > I therefore came to a more elaborate change (revert the above one before > testing this): > > diff --git a/gcc/fortran/trans-stmt.c b/gcc/fortran/trans-stmt.c > index 6d565ae..7b466de 100644 > --- a/gcc/fortran/trans-stmt.c > +++ b/gcc/fortran/trans-stmt.c > @@ -5378,6 +5378,10 @@ gfc_trans_allocate (gfc_code * code) > 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; > + else > + newsym->n.sym->attr.value = 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; > > This patch bootstraps and regtests fine again. Ok to commit? > You can drop the else branch. OK to commit with that change. Thanks. Mikael ^ permalink raw reply [flat|nested] 17+ messages in thread
* Re: [Patch, fortran, pr65548, 2nd take, v5] [5/6 Regression] gfc_conv_procedure_call 2015-05-20 13:29 ` Mikael Morin @ 2015-05-20 15:28 ` Andre Vehreschild 2015-05-26 17:34 ` [Patch, fortran, pr65548, addendum] " Andre Vehreschild 0 siblings, 1 reply; 17+ messages in thread From: Andre Vehreschild @ 2015-05-20 15:28 UTC (permalink / raw) To: GCC-Fortran-ML; +Cc: Mikael Morin, GCC-Patches-ML [-- Attachment #1: Type: text/plain, Size: 157 bytes --] Hi all, Mikael, thanks for the review. Committed as r223445 (without the else-branch). Regards, Andre -- Andre Vehreschild * Email: vehre ad gmx dot de [-- Attachment #2: submit.diff --] [-- Type: text/x-patch, Size: 18486 bytes --] Index: gcc/fortran/ChangeLog =================================================================== --- gcc/fortran/ChangeLog (Revision 223444) +++ gcc/fortran/ChangeLog (Arbeitskopie) @@ -1,3 +1,13 @@ +2015-05-20 Andre Vehreschild <vehre@gmx.de> + + PR fortran/65548 + * trans-stmt.c (gfc_trans_allocate): Always retrieve the + descriptor or a reference to a source= expression for + arrays and non-arrays, respectively. Use a temporary + symbol and gfc_trans_assignment for all source= + assignments to allocated objects besides for class and + derived types. + 2015-05-19 Jakub Jelinek <jakub@redhat.com> PR middle-end/66199 Index: gcc/fortran/trans-stmt.c =================================================================== --- gcc/fortran/trans-stmt.c (Revision 223444) +++ gcc/fortran/trans-stmt.c (Arbeitskopie) @@ -5088,7 +5088,7 @@ gfc_trans_allocate (gfc_code * code) { gfc_alloc *al; - gfc_expr *expr; + gfc_expr *expr, *e3rhs = NULL; gfc_se se, se_sz; tree tmp; tree parm; @@ -5109,6 +5109,7 @@ stmtblock_t post; tree nelems; bool upoly_expr, tmp_expr3_len_flag = false, al_len_needs_set; + gfc_symtree *newsym = NULL; if (!code->ext.alloc.list) return NULL_TREE; @@ -5148,14 +5149,11 @@ TREE_USED (label_finish) = 0; } - /* When an expr3 is present, try to evaluate it only once. In most - cases expr3 is invariant for all elements of the allocation list. - Only exceptions are arrays. Furthermore the standards prevent a - dependency of expr3 on the objects in the allocate list. Therefore - it is safe to pre-evaluate expr3 for complicated expressions, i.e. - everything not a variable or constant. When an array allocation - is wanted, then the following block nevertheless evaluates the - _vptr, _len and element_size for expr3. */ + /* When an expr3 is present evaluate it only once. The standards prevent a + dependency of expr3 on the objects in the allocate list. An expr3 can + be pre-evaluated in all cases. One just has to make sure, to use the + correct way, i.e., to get the descriptor or to get a reference + expression. */ if (code->expr3) { bool vtab_needed = false; @@ -5168,75 +5166,77 @@ al = al->next) vtab_needed = (al->expr->ts.type == BT_CLASS); - /* A array expr3 needs the scalarizer, therefore do not process it - here. */ - if (code->expr3->expr_type != EXPR_ARRAY - && (code->expr3->rank == 0 - || code->expr3->expr_type == EXPR_FUNCTION) - && (!code->expr3->symtree - || !code->expr3->symtree->n.sym->as) - && !gfc_is_class_array_ref (code->expr3, NULL)) + /* When expr3 is a variable, i.e., a very simple expression, + then convert it once here. */ + if (code->expr3->expr_type == EXPR_VARIABLE + || code->expr3->expr_type == EXPR_ARRAY + || code->expr3->expr_type == EXPR_CONSTANT) { - /* When expr3 is a variable, i.e., a very simple expression, - then convert it once here. */ - if ((code->expr3->expr_type == EXPR_VARIABLE) - || code->expr3->expr_type == EXPR_CONSTANT) + if (!code->expr3->mold + || code->expr3->ts.type == BT_CHARACTER + || vtab_needed) { - if (!code->expr3->mold - || code->expr3->ts.type == BT_CHARACTER - || vtab_needed) - { - /* Convert expr3 to a tree. */ - gfc_init_se (&se, NULL); - se.want_pointer = 1; - gfc_conv_expr (&se, code->expr3); - if (!code->expr3->mold) - expr3 = se.expr; - else - expr3_tmp = se.expr; - expr3_len = se.string_length; - gfc_add_block_to_block (&block, &se.pre); - gfc_add_block_to_block (&post, &se.post); - } - /* else expr3 = NULL_TREE set above. */ - } - else - { - /* In all other cases evaluate the expr3 and create a - temporary. */ + /* Convert expr3 to a tree. */ gfc_init_se (&se, NULL); - if (code->expr3->rank != 0 - && code->expr3->expr_type == EXPR_FUNCTION - && code->expr3->value.function.isym) + /* For all "simple" expression just get the descriptor or the + reference, respectively, depending on the rank of the expr. */ + if (code->expr3->rank != 0) gfc_conv_expr_descriptor (&se, code->expr3); else gfc_conv_expr_reference (&se, code->expr3); - if (code->expr3->ts.type == BT_CLASS) - gfc_conv_class_to_class (&se, code->expr3, - code->expr3->ts, - false, true, - false, false); + if (!code->expr3->mold) + expr3 = se.expr; + else + expr3_tmp = se.expr; + expr3_len = se.string_length; gfc_add_block_to_block (&block, &se.pre); gfc_add_block_to_block (&post, &se.post); - /* Prevent aliasing, i.e., se.expr may be already a + } + /* else expr3 = NULL_TREE set above. */ + } + else + { + /* In all other cases evaluate the expr3 and create a + temporary. */ + gfc_init_se (&se, NULL); + symbol_attribute attr; + /* Get the descriptor for all arrays, that are not allocatable or + pointer, because the latter are descriptors already. */ + attr = gfc_expr_attr (code->expr3); + if (code->expr3->rank != 0 && !attr.allocatable && !attr.pointer) + gfc_conv_expr_descriptor (&se, code->expr3); + else + gfc_conv_expr_reference (&se, code->expr3); + if (code->expr3->ts.type == BT_CLASS) + gfc_conv_class_to_class (&se, code->expr3, + code->expr3->ts, + false, true, + false, false); + gfc_add_block_to_block (&block, &se.pre); + gfc_add_block_to_block (&post, &se.post); + /* Prevent aliasing, i.e., se.expr may be already a variable declaration. */ - if (!VAR_P (se.expr)) - { - tmp = build_fold_indirect_ref_loc (input_location, - se.expr); - tmp = gfc_evaluate_now (tmp, &block); - } - else - tmp = se.expr; - if (!code->expr3->mold) - expr3 = tmp; - else - expr3_tmp = tmp; - /* When he length of a char array is easily available + if (!VAR_P (se.expr)) + { + tree var; + tmp = build_fold_indirect_ref_loc (input_location, + se.expr); + /* We need a regular (non-UID) symbol here, therefore give a + prefix. */ + var = gfc_create_var (TREE_TYPE (tmp), "atmp"); + gfc_add_modify_loc (input_location, &block, var, tmp); + tmp = var; + } + else + tmp = se.expr; + if (!code->expr3->mold) + expr3 = tmp; + else + expr3_tmp = tmp; + /* When he length of a char array is easily available here, fix it for future use. */ - if (se.string_length) - expr3_len = gfc_evaluate_now (se.string_length, &block); - } + if (se.string_length) + expr3_len = gfc_evaluate_now (se.string_length, &block); } /* Figure how to get the _vtab entry. This also obtains the tree @@ -5246,11 +5246,15 @@ if (code->expr3->ts.type == BT_CLASS) { gfc_expr *rhs; - /* Polymorphic SOURCE: VPTR must be determined at run time. */ - if (expr3 != NULL_TREE && (VAR_P (expr3) || !code->expr3->ref)) + /* Polymorphic SOURCE: VPTR must be determined at run time. + expr3 may be a temporary array declaration, therefore check for + GFC_CLASS_TYPE_P before trying to get the _vptr component. */ + if (expr3 != NULL_TREE && GFC_CLASS_TYPE_P (TREE_TYPE (expr3)) + && (VAR_P (expr3) || !code->expr3->ref)) tmp = gfc_class_vptr_get (expr3); else if (expr3_tmp != NULL_TREE - && (VAR_P (expr3_tmp) ||!code->expr3->ref)) + && GFC_CLASS_TYPE_P (TREE_TYPE (expr3_tmp)) + && (VAR_P (expr3_tmp) || !code->expr3->ref)) tmp = gfc_class_vptr_get (expr3_tmp); else { @@ -5325,6 +5329,64 @@ 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. */ + if (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; + /* 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); @@ -5628,13 +5690,12 @@ } if (code->expr3 && !code->expr3->mold) { - /* Initialization via SOURCE block - (or static default initializer). */ - gfc_expr *rhs = gfc_copy_expr (code->expr3); + /* Initialization via SOURCE block (or static default initializer). + Classes need some special handling, so catch them first. */ if (expr3 != NULL_TREE && ((POINTER_TYPE_P (TREE_TYPE (expr3)) && TREE_CODE (expr3) != POINTER_PLUS_EXPR) - || VAR_P (expr3)) + || (VAR_P (expr3) && GFC_CLASS_TYPE_P (TREE_TYPE (expr3)))) && code->expr3->ts.type == BT_CLASS && (expr->ts.type == BT_CLASS || expr->ts.type == BT_DERIVED)) @@ -5644,18 +5705,6 @@ tmp = gfc_copy_class_to_class (expr3, to, nelems, upoly_expr); } - else if (code->expr3->ts.type == BT_CHARACTER) - { - tmp = INDIRECT_REF_P (se.expr) ? - se.expr : - build_fold_indirect_ref_loc (input_location, - se.expr); - gfc_trans_string_copy (&block, al_len, tmp, - code->expr3->ts.kind, - expr3_len, expr3, - code->expr3->ts.kind); - tmp = NULL_TREE; - } else if (al->expr->ts.type == BT_CLASS) { gfc_actual_arglist *actual, *last_arg; @@ -5662,6 +5711,7 @@ gfc_expr *ppc; gfc_code *ppc_code; gfc_ref *ref, *dataref; + gfc_expr *rhs = gfc_copy_expr (code->expr3); /* Do a polymorphic deep copy. */ actual = gfc_get_actual_arglist (); @@ -5688,8 +5738,8 @@ gfc_ref *ref = dataref->next; ref->u.ar.type = AR_SECTION; /* We have to set up the array reference to give ranges - in all dimensions and ensure that the end and stride - are set so that the copy can be scalarized. */ + in all dimensions and ensure that the end and stride + are set so that the copy can be scalarized. */ dim = 0; for (; dim < dataref->u.c.component->as->rank; dim++) { @@ -5758,8 +5808,8 @@ 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); + last_arg->expr = + gfc_copy_expr (code->expr3->ts.u.cl->length); else gcc_unreachable (); @@ -5773,6 +5823,7 @@ void_type_node, tmp, extcopy, stdcopy); } gfc_free_statements (ppc_code); + gfc_free_expr (rhs); } else { @@ -5781,10 +5832,9 @@ int realloc_lhs = flag_realloc_lhs; flag_realloc_lhs = 0; tmp = gfc_trans_assignment (gfc_expr_to_initialize (expr), - rhs, false, false); + e3rhs, false, false); flag_realloc_lhs = realloc_lhs; } - gfc_free_expr (rhs); gfc_add_expr_to_block (&block, tmp); } else if (code->expr3 && code->expr3->mold @@ -5802,6 +5852,15 @@ gfc_free_expr (expr); } // for-loop + if (e3rhs) + { + if (newsym) + { + gfc_free_symbol (newsym->n.sym); + XDELETE (newsym); + } + gfc_free_expr (e3rhs); + } /* STAT. */ if (code->expr1) { Index: gcc/testsuite/ChangeLog =================================================================== --- gcc/testsuite/ChangeLog (Revision 223444) +++ gcc/testsuite/ChangeLog (Arbeitskopie) @@ -1,3 +1,8 @@ +2015-05-20 Andre Vehreschild <vehre@gmx.de> + + PR fortran/65548 + * gfortran.dg/allocate_with_source_5.f90: Extend test. + 2015-05-20 Bin Cheng <bin.cheng@arm.com> PR tree-optimization/65447 Index: gcc/testsuite/gfortran.dg/allocate_with_source_5.f90 =================================================================== --- gcc/testsuite/gfortran.dg/allocate_with_source_5.f90 (Revision 223444) +++ gcc/testsuite/gfortran.dg/allocate_with_source_5.f90 (Arbeitskopie) @@ -1,16 +1,16 @@ ! { dg-do run } ! +! Contributed by Juergen Reuter ! Check that pr65548 is fixed. -! Contributed by Juergen Reuter <juergen.reuter@desy.de> +! -module allocate_with_source_5_module - +module selectors type :: selector_t - integer, dimension(:), allocatable :: map - real, dimension(:), allocatable :: weight - contains - procedure :: init => selector_init - end type selector_t + integer, dimension(:), allocatable :: map + real, dimension(:), allocatable :: weight + contains + procedure :: init => selector_init + end type selector_t contains @@ -34,19 +34,126 @@ end if end subroutine selector_init -end module allocate_with_source_5_module +end module selectors -program allocate_with_source_5 - use allocate_with_source_5_module +module phs_base + type :: flavor_t + contains + procedure :: get_mass => flavor_get_mass + end type flavor_t - class(selector_t), allocatable :: sel; - real, dimension(5) :: w = [ 1, 0, 2, 0, 3]; + type :: phs_config_t + integer :: n_in = 0 + type(flavor_t), dimension(:,:), allocatable :: flv + end type phs_config_t - allocate (sel) - call sel%init(w) + type :: phs_t + class(phs_config_t), pointer :: config => null () + real, dimension(:), allocatable :: m_in + end type phs_t - if (any(sel%map /= [ 1, 3, 5])) call abort() - if (any(abs(sel%weight - [1, 2, 3] / 6) < 1E-6)) call abort() -end program allocate_with_source_5 -! { dg-final { cleanup-modules "allocate_with_source_5_module" } } +contains + elemental function flavor_get_mass (flv) result (mass) + real :: mass + class(flavor_t), intent(in) :: flv + mass = 42.0 + end function flavor_get_mass + + subroutine phs_base_init (phs, phs_config) + class(phs_t), intent(out) :: phs + class(phs_config_t), intent(in), target :: phs_config + phs%config => phs_config + allocate (phs%m_in (phs%config%n_in), & + source = phs_config%flv(:phs_config%n_in, 1)%get_mass ()) + end subroutine phs_base_init + +end module phs_base + +module foo + type :: t + integer :: n + real, dimension(:,:), allocatable :: val + contains + procedure :: make => t_make + generic :: get_int => get_int_array, get_int_element + procedure :: get_int_array => t_get_int_array + procedure :: get_int_element => t_get_int_element + end type t + +contains + + subroutine t_make (this) + class(t), intent(inout) :: this + real, dimension(:), allocatable :: int + allocate (int (0:this%n-1), source=this%get_int()) + end subroutine t_make + + pure function t_get_int_array (this) result (array) + class(t), intent(in) :: this + real, dimension(this%n) :: array + array = this%val (0:this%n-1, 4) + end function t_get_int_array + + pure function t_get_int_element (this, set) result (element) + class(t), intent(in) :: this + integer, intent(in) :: set + real :: element + element = this%val (set, 4) + end function t_get_int_element +end module foo +module foo2 + type :: t2 + integer :: n + character(32), dimension(:), allocatable :: md5 + contains + procedure :: init => t2_init + end type t2 + +contains + + subroutine t2_init (this) + class(t2), intent(inout) :: this + character(32), dimension(:), allocatable :: md5 + allocate (md5 (this%n), source=this%md5) + if (md5(1) /= "tst ") call abort() + if (md5(2) /= " ") call abort() + if (md5(3) /= "fooblabar ") call abort() + end subroutine t2_init +end module foo2 + +program test + use selectors + use phs_base + use foo + use foo2 + + type(selector_t) :: sel + type(phs_t) :: phs + type(phs_config_t) :: phs_config + type(t) :: o + type(t2) :: o2 + + call sel%init([2., 0., 3., 0., 4.]) + + if (any(sel%map /= [1, 3, 5])) call abort() + if (any(abs(sel%weight - [2., 3., 4.] / 9.) > 1E-6)) call abort() + + phs_config%n_in = 2 + allocate (phs_config%flv (phs_config%n_in, 1)) + call phs_base_init (phs, phs_config) + + if (any(abs(phs%m_in - [42.0, 42.0]) > 1E-6)) call abort() + + o%n = 2 + allocate (o%val(2,4)) + call o%make() + + o2%n = 3 + allocate(o2%md5(o2%n)) + o2%md5(1) = "tst" + o2%md5(2) = "" + o2%md5(3) = "fooblabar" + call o2%init() +end program test + ^ permalink raw reply [flat|nested] 17+ messages in thread
* Re: [Patch, fortran, pr65548, addendum] [5/6 Regression] gfc_conv_procedure_call 2015-05-20 15:28 ` Andre Vehreschild @ 2015-05-26 17:34 ` Andre Vehreschild 2015-05-27 8:28 ` Thomas Koenig 0 siblings, 1 reply; 17+ messages in thread From: Andre Vehreschild @ 2015-05-26 17:34 UTC (permalink / raw) To: GCC-Fortran-ML; +Cc: Mikael Morin, GCC-Patches-ML [-- Attachment #1: Type: text/plain, Size: 747 bytes --] Hi all, unfortunately introduced the latest optimization for this patch an ICE in pFUnit again. The issue occurs when the -fbounds-check is used while allocating an array of non-polymorphic or intrinsic type. It is caused by the location of the gfc_expr of e3rhs not set which is needed to generate the runtime error messages of the bounds check. Bootstraps and regtests ok on x86_64-linux-gnu/f21. Because this patch is obvious I plan to commit it tomorrow if no one objects?! Regards, Andre On Wed, 20 May 2015 16:58:19 +0200 Andre Vehreschild <vehre@gmx.de> wrote: > Hi all, > > Mikael, thanks for the review. Committed as r223445 (without the else-branch). > > Regards, > Andre -- Andre Vehreschild * Email: vehre ad gmx dot de [-- Attachment #2: pr65548_6.clog --] [-- Type: application/octet-stream, Size: 332 bytes --] gcc/fortran/ChangeLog: 2015-05-26 Andre Vehreschild <vehre@gmx.de> * trans-stmt.c (gfc_trans_allocate): Add missing location information for e3rhs. gcc/testsuite/ChangeLog: 2015-05-26 Andre Vehreschild <vehre@gmx.de> * gfortran.dg/allocate_with_source_5.f90: Add switch to test for correctly set location information. [-- Attachment #3: pr65548_6.patch --] [-- Type: text/x-patch, Size: 1110 bytes --] diff --git a/gcc/fortran/trans-stmt.c b/gcc/fortran/trans-stmt.c index 2c0304b..81943b0 100644 --- a/gcc/fortran/trans-stmt.c +++ b/gcc/fortran/trans-stmt.c @@ -5362,6 +5362,7 @@ gfc_trans_allocate (gfc_code * code) 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. */ diff --git a/gcc/testsuite/gfortran.dg/allocate_with_source_5.f90 b/gcc/testsuite/gfortran.dg/allocate_with_source_5.f90 index 500f0f0..06dfcad 100644 --- a/gcc/testsuite/gfortran.dg/allocate_with_source_5.f90 +++ b/gcc/testsuite/gfortran.dg/allocate_with_source_5.f90 @@ -1,4 +1,5 @@ ! { dg-do run } +! { dg-options "-fbounds-check" } ! ! Contributed by Juergen Reuter ! Check that pr65548 is fixed. @@ -146,7 +147,7 @@ program test if (any(abs(phs%m_in - [42.0, 42.0]) > 1E-6)) call abort() o%n = 2 - allocate (o%val(2,4)) + allocate (o%val(0:1,4)) call o%make() o2%n = 3 ^ permalink raw reply [flat|nested] 17+ messages in thread
* Re: [Patch, fortran, pr65548, addendum] [5/6 Regression] gfc_conv_procedure_call 2015-05-26 17:34 ` [Patch, fortran, pr65548, addendum] " Andre Vehreschild @ 2015-05-27 8:28 ` Thomas Koenig 2015-05-27 10:12 ` Andre Vehreschild 0 siblings, 1 reply; 17+ messages in thread From: Thomas Koenig @ 2015-05-27 8:28 UTC (permalink / raw) To: Andre Vehreschild, GCC-Fortran-ML; +Cc: Mikael Morin, GCC-Patches-ML Hi Andre, > Because this patch is obvious I plan to commit it tomorrow if no one objects?! The patch itself is obviously OK. About the test case: In general, it is better not to change existing test cases unless absolutely necessary (e.g. adjust an error message). This makes it easier to track regressions. I would prefer if you made a new test case from your existing one, with the changes you did and a small explanation of what was tested in the comments. If you are worried about runtime for an additonal test, you can use the ! { dg-do run } hack (notice the two spaces between the dg-do and the run) to have the test case execute only once. OK with that change. Regards Thomas ^ permalink raw reply [flat|nested] 17+ messages in thread
* Re: [Patch, fortran, pr65548, addendum] [5/6 Regression] gfc_conv_procedure_call 2015-05-27 8:28 ` Thomas Koenig @ 2015-05-27 10:12 ` Andre Vehreschild 0 siblings, 0 replies; 17+ messages in thread From: Andre Vehreschild @ 2015-05-27 10:12 UTC (permalink / raw) To: Thomas Koenig; +Cc: GCC-Fortran-ML, Mikael Morin, GCC-Patches-ML Hi Thomas, thanks for the review. Commited as r223738 with the changes (new testcase, double space in dg-do). Regards, Andre On Wed, 27 May 2015 08:38:07 +0200 Thomas Koenig <tkoenig@netcologne.de> wrote: > Hi Andre, > > > Because this patch is obvious I plan to commit it tomorrow if no one > > objects?! > > The patch itself is obviously OK. > > About the test case: In general, it is better not to change existing > test cases unless absolutely necessary (e.g. adjust an error message). > This makes it easier to track regressions. > > I would prefer if you made a new test case from your existing one, > with the changes you did and a small explanation of what was > tested in the comments. > > If you are worried about runtime for an additonal test, you can use the > > ! { dg-do run } > > hack (notice the two spaces between the dg-do and the run) to have the > test case execute only once. > > OK with that change. > > Regards > > Thomas > -- Andre Vehreschild * Email: vehre ad gmx dot de ^ permalink raw reply [flat|nested] 17+ messages in thread
end of thread, other threads:[~2015-05-27 8:50 UTC | newest]
Thread overview: 17+ messages (download: mbox.gz / follow: Atom feed)
-- links below jump to the message on this page --
[not found] <bug-65548-26035@http.gcc.gnu.org/bugzilla/>
[not found] ` <bug-65548-26035-vcFxaNSRns@http.gcc.gnu.org/bugzilla/>
2015-03-25 13:36 ` [Patch, fortran, pr65548, v1] [5 Regression] gfc_conv_procedure_call Andre Vehreschild
2015-04-02 10:28 ` [Ping, Patch, " Andre Vehreschild
2015-04-03 0:06 ` Jerry DeLisle
2015-04-07 14:12 ` Andre Vehreschild
2015-04-29 12:52 ` [Patch, fortran, pr65548, 2nd take] [5/6 " Andre Vehreschild
2015-04-30 13:30 ` [Patch, fortran, pr65548, 2nd take, v3] " Andre Vehreschild
2015-05-12 22:04 ` Mikael Morin
2015-05-13 9:31 ` Andre Vehreschild
2015-05-14 9:49 ` [Patch, fortran, pr65548, 2nd take, v4] " Andre Vehreschild
2015-05-19 8:52 ` [Patch, fortran, pr65548, 2nd take, v5] " Andre Vehreschild
2015-05-19 14:07 ` Mikael Morin
2015-05-20 8:31 ` Andre Vehreschild
2015-05-20 13:29 ` Mikael Morin
2015-05-20 15:28 ` Andre Vehreschild
2015-05-26 17:34 ` [Patch, fortran, pr65548, addendum] " Andre Vehreschild
2015-05-27 8:28 ` Thomas Koenig
2015-05-27 10:12 ` 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).