From mboxrd@z Thu Jan 1 00:00:00 1970 Return-Path: Received: (qmail 26089 invoked by alias); 7 May 2015 09:52:53 -0000 Mailing-List: contact gcc-patches-help@gcc.gnu.org; run by ezmlm Precedence: bulk List-Id: List-Archive: List-Post: List-Help: Sender: gcc-patches-owner@gcc.gnu.org Received: (qmail 25862 invoked by uid 89); 7 May 2015 09:52:51 -0000 Authentication-Results: sourceware.org; auth=none X-Virus-Found: No X-Spam-SWARE-Status: No, score=-1.6 required=5.0 tests=AWL,BAYES_00,FREEMAIL_FROM,RCVD_IN_DNSWL_NONE,SPF_PASS autolearn=ham version=3.3.2 X-Spam-User: qpsmtpd, 2 recipients X-HELO: mout.gmx.net Received: from mout.gmx.net (HELO mout.gmx.net) (212.227.17.20) by sourceware.org (qpsmtpd/0.93/v0.84-503-g423c35a) with (AES256-GCM-SHA384 encrypted) ESMTPS; Thu, 07 May 2015 09:52:48 +0000 Received: from localhost ([88.75.104.20]) by mail.gmx.com (mrgmx101) with ESMTPSA (Nemesis) id 0LqV4f-1ZTjq63EED-00e0tP; Thu, 07 May 2015 11:52:44 +0200 Date: Thu, 07 May 2015 09:52:00 -0000 From: Andre Vehreschild To: GCC-Patches-ML , GCC-Fortran-ML Subject: [Patch, fortran, pr65894, v1] [6 Regression] severe regression in gfortran 6.0.0 Message-ID: <20150507115242.10f4061c@gmx.de> MIME-Version: 1.0 Content-Type: multipart/mixed; boundary="MP_/TmMQsGpY+5LV=Lj0fXTHHRx" X-UI-Out-Filterresults: notjunk:1; X-SW-Source: 2015-05/txt/msg00529.txt.bz2 --MP_/TmMQsGpY+5LV=Lj0fXTHHRx Content-Type: text/plain; charset=US-ASCII Content-Transfer-Encoding: 7bit Content-Disposition: inline Content-length: 773 Hi all, my work on pr60322 caused a regression on trunk. This patch fixes it. The regression had two causes: 1. Not taking the correct attribute for BT_CLASS objects with allocatable components into account (chunk 1), and 2. taking the address of an address (chunk 2). When a class or derived typed scalar object is to be returned as a reference and a scalarizer is present, then the address of the address of the object was returned. The former code was meant to return the address of an array element for which taking the address was ok. The patch now prevents taking the additional address when the object is scalar. Bootstraps and regtests ok x86_64-linux-gnu/f21. Ok for trunk. Regards, Andre -- Andre Vehreschild * Email: vehre ad gmx dot de --MP_/TmMQsGpY+5LV=Lj0fXTHHRx Content-Type: application/octet-stream; name=pr65894_1.clog Content-Transfer-Encoding: base64 Content-Disposition: attachment; filename=pr65894_1.clog Content-length: 623 Z2NjL3Rlc3RzdWl0ZS9DaGFuZ2VMb2c6CgoyMDE1LTA1LTA3ICBBbmRyZSBW ZWhyZXNjaGlsZCAgPHZlaHJlQGdteC5kZT4KCglQUiBmb3J0cmFuLzY1ODk0 CgkqIGdmb3J0cmFuLmRnL2VsZW1lbnRhbF9zdWJyb3V0aW5lXzExLmY5MDog TmV3IHRlc3QuCgoKZ2NjL2ZvcnRyYW4vQ2hhbmdlTG9nOgoKMjAxNS0wNS0w NyAgQW5kcmUgVmVocmVzY2hpbGQgIDx2ZWhyZUBnbXguZGU+CgoJUFIgZm9y dHJhbi82NTg5NAoJKiB0cmFucy1leHByLmMgKGdmY19jb252X3Byb2NlZHVy ZV9jYWxsKTogRXh0ZW5kIHRlc3QgZm9yCglhbGxvY2F0YWJsZSBjb21wb25l bnRzIG9mIGNsYXNzIG9iamVjdHMuCgkoZ2ZjX2NvbnZfZXhwcl9yZWZlcmVu Y2UpOiBQcmV2ZW50IHRha2luZyB0aGUgYWRkcmVzcyBvZiBhCglwb2ludGVy IHdoZW4gdGhlIG9iamVjdCBpcyBhIHNjYWxhciBjbGFzcyBvciB0eXBlIGVu dGl0eS4KCg== --MP_/TmMQsGpY+5LV=Lj0fXTHHRx Content-Type: text/x-patch Content-Transfer-Encoding: 7bit Content-Disposition: attachment; filename=pr65894_1.patch Content-length: 9318 diff --git a/gcc/fortran/trans-expr.c b/gcc/fortran/trans-expr.c index 16e584a..19d0144 100644 --- a/gcc/fortran/trans-expr.c +++ b/gcc/fortran/trans-expr.c @@ -4741,13 +4741,16 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym, copied. */ if (fsym && (fsym->attr.value || (e->expr_type == EXPR_VARIABLE - && fsym->ts.type == BT_DERIVED - && e->ts.type == BT_DERIVED - && !e->ts.u.derived->attr.dimension && !e->rank - && (!e->symtree - || (!e->symtree->n.sym->attr.allocatable - && !e->symtree->n.sym->attr.pointer))))) + && ((fsym->ts.type == BT_DERIVED + && e->ts.type == BT_DERIVED + && !e->ts.u.derived->attr.dimension + && (!e->symtree + || (!e->symtree->n.sym->attr.allocatable + && !e->symtree->n.sym->attr.pointer))) + || (fsym->ts.type == BT_CLASS + && e->ts.type == BT_CLASS + && !CLASS_DATA (e)->attr.dimension))))) gfc_conv_expr (&parmse, e); else gfc_conv_expr_reference (&parmse, e); @@ -7461,7 +7464,13 @@ gfc_conv_expr_reference (gfc_se * se, gfc_expr * expr) if (expr->ts.type == BT_CHARACTER && expr->expr_type != EXPR_FUNCTION) gfc_conv_string_parameter (se); - else + /* Do not return the address of the expression, when it is already an + address. */ + else if (!(((expr->ts.type == BT_DERIVED + && expr->ts.u.derived->as == NULL) + || (expr->ts.type == BT_CLASS + && CLASS_DATA (expr)->as == NULL)) + && POINTER_TYPE_P (TREE_TYPE (se->expr)))) se->expr = gfc_build_addr_expr (NULL_TREE, se->expr); return; diff --git a/gcc/testsuite/gfortran.dg/elemental_subroutine_11.f90 b/gcc/testsuite/gfortran.dg/elemental_subroutine_11.f90 new file mode 100644 index 0000000..6b13e46 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/elemental_subroutine_11.f90 @@ -0,0 +1,250 @@ +! { dg-do run } +! +! Check error of pr65894 are fixed. +! Contributed by Juergen Reuter +! Andre Vehreschild + +module simple_string + ! Minimal iso_varying_string implementation needed. + implicit none + + type string_t + private + character(len=1), dimension(:), allocatable :: cs + end type string_t + +contains + elemental function var_str(c) result (s) + character(*), intent(in) :: c + type(string_t) :: s + integer :: l,i + + l = len(c) + allocate(s%cs(l)) + forall(i = 1:l) + s%cs(i) = c(i:i) + end forall + end function var_str + +end module simple_string +module model_data + use simple_string + + implicit none + private + + public :: field_data_t + public :: model_data_t + + type :: field_data_t + !private + integer :: pdg = 0 + type(string_t), dimension(:), allocatable :: name + contains + procedure :: init => field_data_init + procedure :: get_pdg => field_data_get_pdg + end type field_data_t + + type :: model_data_t + !private + type(string_t) :: name + type(field_data_t), dimension(:), allocatable :: field + contains + generic :: init => model_data_init + procedure, private :: model_data_init + generic :: get_pdg => & + model_data_get_field_pdg_index + procedure, private :: model_data_get_field_pdg_index + generic :: get_field_ptr => & + model_data_get_field_ptr_pdg + procedure, private :: model_data_get_field_ptr_pdg + procedure :: get_field_ptr_by_index => model_data_get_field_ptr_index + procedure :: init_sm_test => model_data_init_sm_test + end type model_data_t + +contains + + subroutine field_data_init (prt, pdg) + class(field_data_t), intent(out) :: prt + integer, intent(in) :: pdg + prt%pdg = pdg + end subroutine field_data_init + + elemental function field_data_get_pdg (prt) result (pdg) + integer :: pdg + class(field_data_t), intent(in) :: prt + pdg = prt%pdg + end function field_data_get_pdg + + subroutine model_data_init (model, name, & + n_field) + class(model_data_t), intent(out) :: model + type(string_t), intent(in) :: name + integer, intent(in) :: n_field + model%name = name + allocate (model%field (n_field)) + end subroutine model_data_init + + function model_data_get_field_pdg_index (model, i) result (pdg) + class(model_data_t), intent(in) :: model + integer, intent(in) :: i + integer :: pdg + pdg = model%field(i)%get_pdg () + end function model_data_get_field_pdg_index + + function model_data_get_field_ptr_pdg (model, pdg, check) result (ptr) + class(model_data_t), intent(in), target :: model + integer, intent(in) :: pdg + logical, intent(in), optional :: check + type(field_data_t), pointer :: ptr + integer :: i, pdg_abs + if (pdg == 0) then + ptr => null () + return + end if + pdg_abs = abs (pdg) + if (lbound(model%field, 1) /= 1) call abort() + if (ubound(model%field, 1) /= 19) call abort() + do i = 1, size (model%field) + if (model%field(i)%get_pdg () == pdg_abs) then + ptr => model%field(i) + return + end if + end do + ptr => null () + end function model_data_get_field_ptr_pdg + + function model_data_get_field_ptr_index (model, i) result (ptr) + class(model_data_t), intent(in), target :: model + integer, intent(in) :: i + type(field_data_t), pointer :: ptr + if (lbound(model%field, 1) /= 1) call abort() + if (ubound(model%field, 1) /= 19) call abort() + ptr => model%field(i) + end function model_data_get_field_ptr_index + + subroutine model_data_init_sm_test (model) + class(model_data_t), intent(out) :: model + type(field_data_t), pointer :: field + integer, parameter :: n_field = 19 + call model%init (var_str ("SM_test"), & + n_field) + field => model%get_field_ptr_by_index (1) + call field%init (1) + end subroutine model_data_init_sm_test + +end module model_data + +module flavors + use model_data + + implicit none + private + + public :: flavor_t + + type :: flavor_t + private + integer :: f = 0 + type(field_data_t), pointer :: field_data => null () + contains + generic :: init => & + flavor_init0_model + procedure, private :: flavor_init0_model + end type flavor_t + +contains + + impure elemental subroutine flavor_init0_model (flv, f, model) + class(flavor_t), intent(inout) :: flv + integer, intent(in) :: f + class(model_data_t), intent(in), target :: model + ! Check the field l/ubound at various stages, because w/o the patch + ! the bounds get mixed up. + if (lbound(model%field, 1) /= 1) call abort() + if (ubound(model%field, 1) /= 19) call abort() + flv%f = f + flv%field_data => model%get_field_ptr (f, check=.true.) + end subroutine flavor_init0_model +end module flavors + +module beams + use model_data + use flavors + implicit none + private + public :: beam_1 + public :: beam_2 +contains + subroutine beam_1 (u) + integer, intent(in) :: u + type(flavor_t), dimension(2) :: flv + real, dimension(2) :: pol_f + type(model_data_t), target :: model + call model%init_sm_test () + call flv%init ([1,-1], model) + pol_f(1) = 0.5 + end subroutine beam_1 + subroutine beam_2 (u, model) + integer, intent(in) :: u + type(flavor_t), dimension(2) :: flv + real, dimension(2) :: pol_f + class(model_data_t), intent(in), target :: model + call flv%init ([1,-1], model) + pol_f(1) = 0.5 + end subroutine beam_2 +end module beams + +module evaluators + ! This module is just here for a compile check. + implicit none + private + type :: quantum_numbers_mask_t + contains + generic :: operator(.or.) => quantum_numbers_mask_or + procedure, private :: quantum_numbers_mask_or + end type quantum_numbers_mask_t + + type :: index_map_t + integer, dimension(:), allocatable :: entry + end type index_map_t + type :: prt_mask_t + logical, dimension(:), allocatable :: entry + end type prt_mask_t + type :: qn_mask_array_t + type(quantum_numbers_mask_t), dimension(:), allocatable :: mask + end type qn_mask_array_t + +contains + elemental function quantum_numbers_mask_or (mask1, mask2) result (mask) + type(quantum_numbers_mask_t) :: mask + class(quantum_numbers_mask_t), intent(in) :: mask1, mask2 + end function quantum_numbers_mask_or + + subroutine make_product_interaction & + (prt_is_connected, qn_mask_in, qn_mask_rest) + type(prt_mask_t), dimension(2), intent(in) :: prt_is_connected + type(qn_mask_array_t), dimension(2), intent(in) :: qn_mask_in + type(quantum_numbers_mask_t), intent(in) :: qn_mask_rest + type(index_map_t), dimension(2) :: prt_index_in + integer :: i + type(quantum_numbers_mask_t), dimension(:), allocatable :: qn_mask + allocate (qn_mask (2)) + do i = 1, 2 + qn_mask(prt_index_in(i)%entry) = & + pack (qn_mask_in(i)%mask, prt_is_connected(i)%entry) & + .or. qn_mask_rest + ! Without the patch above line produced an ICE. + end do + end subroutine make_product_interaction +end module evaluators +program main + use beams + use model_data + type(model_data_t) :: model + call model%init_sm_test() + call beam_1 (6) + call beam_2 (6, model) +end program main + +! vim:ts=2:sts=2:sw=2:cindent: --MP_/TmMQsGpY+5LV=Lj0fXTHHRx--