From mboxrd@z Thu Jan 1 00:00:00 1970 Return-Path: Received: by sourceware.org (Postfix, from userid 2071) id 594AE3858435; Sat, 28 Aug 2021 18:28:31 +0000 (GMT) DKIM-Filter: OpenDKIM Filter v2.11.0 sourceware.org 594AE3858435 MIME-Version: 1.0 Content-Transfer-Encoding: 7bit Content-Type: text/plain; charset="utf-8" From: Harald Anlauf To: gcc-cvs@gcc.gnu.org Subject: [gcc r11-8936] Fortran: Assumed and explicit size class arrays [PR46691/99819]. X-Act-Checkin: gcc X-Git-Author: Paul Thomas X-Git-Refname: refs/heads/releases/gcc-11 X-Git-Oldrev: 6e503ac734f6383530a65580d3af03a1027c5103 X-Git-Newrev: be64e725111fdb9caa05374823b4423b8ab49dc7 Message-Id: <20210828182831.594AE3858435@sourceware.org> Date: Sat, 28 Aug 2021 18:28:31 +0000 (GMT) X-BeenThere: gcc-cvs@gcc.gnu.org X-Mailman-Version: 2.1.29 Precedence: list List-Id: Gcc-cvs mailing list List-Unsubscribe: , List-Archive: List-Help: List-Subscribe: , X-List-Received-Date: Sat, 28 Aug 2021 18:28:31 -0000 https://gcc.gnu.org/g:be64e725111fdb9caa05374823b4423b8ab49dc7 commit r11-8936-gbe64e725111fdb9caa05374823b4423b8ab49dc7 Author: Paul Thomas Date: Thu May 6 14:41:33 2021 +0100 Fortran: Assumed and explicit size class arrays [PR46691/99819]. 2021-05-06 Paul Thomas gcc/fortran/ChangeLog PR fortran/46691 PR fortran/99819 * class.c (gfc_build_class_symbol): Remove the error that disables assumed size class arrays. Class array types that are not deferred shape or assumed rank are given a unique name and placed in the procedure namespace. * trans-array.c (gfc_trans_g77_array): Obtain the data pointer for class arrays. (gfc_trans_dummy_array_bias): Suppress the runtime error for extent violations in explicit shape class arrays because it always fails. * trans-expr.c (gfc_conv_procedure_call): Handle assumed size class actual arguments passed to non-descriptor formal args by using the data pointer, stored as the symbol's backend decl. gcc/testsuite/ChangeLog PR fortran/46691 PR fortran/99819 * gfortran.dg/class_dummy_6.f90: New test. * gfortran.dg/class_dummy_7.f90: New test. (cherry picked from commit a2c593009fef1564dbef2237ee71e9fd08f5361e) Diff: --- gcc/fortran/class.c | 33 +++++++++++---- gcc/fortran/trans-array.c | 12 +++++- gcc/fortran/trans-expr.c | 9 ++++ gcc/testsuite/gfortran.dg/class_dummy_6.f90 | 65 +++++++++++++++++++++++++++++ gcc/testsuite/gfortran.dg/class_dummy_7.f90 | 60 ++++++++++++++++++++++++++ 5 files changed, 169 insertions(+), 10 deletions(-) diff --git a/gcc/fortran/class.c b/gcc/fortran/class.c index 89353218417..93118ad3455 100644 --- a/gcc/fortran/class.c +++ b/gcc/fortran/class.c @@ -630,6 +630,7 @@ gfc_get_len_component (gfc_expr *e, int k) component '_vptr' which determines the dynamic type. When this CLASS entity is unlimited polymorphic, then also add a component '_len' to store the length of string when that is stored in it. */ +static int ctr = 0; bool gfc_build_class_symbol (gfc_typespec *ts, symbol_attribute *attr, @@ -645,13 +646,6 @@ gfc_build_class_symbol (gfc_typespec *ts, symbol_attribute *attr, gcc_assert (as); - if (*as && (*as)->type == AS_ASSUMED_SIZE) - { - gfc_error ("Assumed size polymorphic objects or components, such " - "as that at %C, have not yet been implemented"); - return false; - } - if (attr->class_ok) /* Class container has already been built. */ return true; @@ -693,7 +687,30 @@ gfc_build_class_symbol (gfc_typespec *ts, symbol_attribute *attr, else ns = ts->u.derived->ns; - gfc_find_symbol (name, ns, 0, &fclass); + /* Although this might seem to be counterintuitive, we can build separate + class types with different array specs because the TKR interface checks + work on the declared type. All array type other than deferred shape or + assumed rank are added to the function namespace to ensure that they + are properly distinguished. */ + if (attr->dummy && !attr->codimension && (*as) + && !((*as)->type == AS_DEFERRED || (*as)->type == AS_ASSUMED_RANK)) + { + char *sname; + ns = gfc_current_ns; + gfc_find_symbol (name, ns, 0, &fclass); + /* If a local class type with this name already exists, update the + name with an index. */ + if (fclass) + { + fclass = NULL; + sname = xasprintf ("%s_%d", name, ++ctr); + free (name); + name = sname; + } + } + else + gfc_find_symbol (name, ns, 0, &fclass); + if (fclass == NULL) { gfc_symtree *st; diff --git a/gcc/fortran/trans-array.c b/gcc/fortran/trans-array.c index c5d61f0065c..7eeef554c0f 100644 --- a/gcc/fortran/trans-array.c +++ b/gcc/fortran/trans-array.c @@ -6525,7 +6525,14 @@ gfc_trans_g77_array (gfc_symbol * sym, gfc_wrapped_block * block) /* Set the pointer itself if we aren't using the parameter directly. */ if (TREE_CODE (parm) != PARM_DECL) { - tmp = convert (TREE_TYPE (parm), GFC_DECL_SAVED_DESCRIPTOR (parm)); + tmp = GFC_DECL_SAVED_DESCRIPTOR (parm); + if (sym->ts.type == BT_CLASS) + { + tmp = build_fold_indirect_ref_loc (input_location, tmp); + tmp = gfc_class_data_get (tmp); + tmp = gfc_conv_descriptor_data_get (tmp); + } + tmp = convert (TREE_TYPE (parm), tmp); gfc_add_modify (&init, parm, tmp); } stmt = gfc_finish_block (&init); @@ -6627,7 +6634,8 @@ gfc_trans_dummy_array_bias (gfc_symbol * sym, tree tmpdesc, && VAR_P (sym->ts.u.cl->backend_decl)) gfc_conv_string_length (sym->ts.u.cl, NULL, &init); - checkparm = (as->type == AS_EXPLICIT + /* TODO: Fix the exclusion of class arrays from extent checking. */ + checkparm = (as->type == AS_EXPLICIT && !is_classarray && (gfc_option.rtcheck & GFC_RTCHECK_BOUNDS)); no_repack = !(GFC_DECL_PACKED_ARRAY (tmpdesc) diff --git a/gcc/fortran/trans-expr.c b/gcc/fortran/trans-expr.c index 7e3d484226e..3d00b64e537 100644 --- a/gcc/fortran/trans-expr.c +++ b/gcc/fortran/trans-expr.c @@ -6421,6 +6421,15 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym, fsym ? fsym->attr.intent : INTENT_INOUT, fsym && fsym->attr.pointer); + else if (e->ts.type == BT_CLASS && CLASS_DATA (e)->as + && CLASS_DATA (e)->as->type == AS_ASSUMED_SIZE + && nodesc_arg && fsym->ts.type == BT_DERIVED) + /* An assumed size class actual argument being passed to + a 'no descriptor' formal argument just requires the + data pointer to be passed. For class dummy arguments + this is stored in the symbol backend decl.. */ + parmse.expr = e->symtree->n.sym->backend_decl; + else if (gfc_is_class_array_ref (e, NULL) && fsym && fsym->ts.type == BT_DERIVED) /* The actual argument is a component reference to an diff --git a/gcc/testsuite/gfortran.dg/class_dummy_6.f90 b/gcc/testsuite/gfortran.dg/class_dummy_6.f90 new file mode 100644 index 00000000000..79f6e86daa7 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/class_dummy_6.f90 @@ -0,0 +1,65 @@ +! { dg-do run } +! +! Test the fix for PR99819 - explicit shape class arrays in different +! procedures caused an ICE. +! +! Contributed by Gerhard Steinmetz +! +program p + type t + integer :: i + end type + class(t), allocatable :: dum1(:), dum2(:), dum3(:,:) + + allocate (t :: dum1(3), dum2(10), dum3(2,5)) + dum2%i = [1,2,3,4,5,6,7,8,9,10] + dum3%i = reshape ([1,2,3,4,5,6,7,8,9,10],[2,5]) + +! Somewhat elaborated versions of the PR procedures. + if (f (dum1, dum2, dum3) .ne. 10) stop 1 + if (g (dum1) .ne. 3) stop 2 + +! Test the original versions of the procedures. + if (f_original (dum1, dum2) .ne. 3) stop 3 + if (g_original (dum2) .ne. 10) stop 4 + +contains + integer function f(x, y, z) + class(t) :: x(:) + class(t) :: y(size( x)) + class(t) :: z(2,*) + if (size (y) .ne. 3) stop 5 + if (size (z) .ne. 0) stop 6 + select type (y) + type is (t) + f = 1 + if (any (y%i .ne. [1,2,3])) stop 7 + class default + f = 0 + end select + select type (z) + type is (t) + f = f*10 + if (any (z(1,1:4)%i .ne. [1,3,5,7])) stop 8 + class default + f = 0 + end select + end + integer function g(z) + class(t) :: z(:) + type(t) :: u(size(z)) + g = size (u) + end + + integer function f_original(x, y) + class(t) :: x(:) + class(*) :: y(size (x)) + f_original = size (y) + end + + integer function g_original(z) + class(*) :: z(:) + type(t) :: u(size(z)) + g_original = size (u) + end +end diff --git a/gcc/testsuite/gfortran.dg/class_dummy_7.f90 b/gcc/testsuite/gfortran.dg/class_dummy_7.f90 new file mode 100644 index 00000000000..913426804f3 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/class_dummy_7.f90 @@ -0,0 +1,60 @@ +! { dg-do run } +! +! Test the fix for PR46691 - enable class assumed size arrays +! +! Reported by Tobias Burnus +! from http://j3-fortran.org/pipermail/j3/2010-December/004084.html +! submitted by Robert Corbett. +! + MODULE TYPES + PRIVATE + PUBLIC REC, REC2 + + TYPE REC + INTEGER A + END TYPE + + TYPE, EXTENDS(REC) :: REC2 + INTEGER B + END TYPE + END + + SUBROUTINE SUB1(A, N) + USE TYPES + CLASS(REC), INTENT(IN) :: A(*) + INTERFACE + SUBROUTINE SUB2(A, N, IARRAY) + USE TYPES + TYPE(REC) A(*) + INTEGER :: N, IARRAY(N) + END + END INTERFACE + + CALL SUB2(A, N,[1,2,2,3,3,4,4,5,5,6]) + select type (B => A(1:N)) + type is (REC2) + call SUB2(B%REC,N,[1,2,3,4,5,6,7,8,9,10]) + end select + + END + + SUBROUTINE SUB2(A, N, IARRAY) + USE TYPES + TYPE(REC) A(*) + INTEGER :: N, IARRAY(N) + if (any (A(:N)%A .ne. IARRAY(:N))) stop 1 + END + + PROGRAM MAIN + USE TYPES + CLASS(REC), ALLOCATABLE :: A(:) + INTERFACE + SUBROUTINE SUB1(A, N) + USE TYPES + CLASS(REC), INTENT(IN) :: A(*) + END SUBROUTINE + END INTERFACE + + A = [ (REC2(I, I+1), I = 1, 10) ] + CALL SUB1(A, 10) + END