Hi All, Although I had undertaken to concentrate on PDTs, PR99819 so intrigued me that I became locked into it :-( After extensive, fruitless rummaging through decl.c and trans-decl.c, I realised that the problem was far simpler than it seemed and that it lay in class.c. After that PR was fixed, PR46691 was a trivial follow up.
The comments in the patch explain the fixes. I left a TODO for the extent checking of assumed size class arrays. I will try to fix it before pushing. Regtested on FC33/x86_64 and checked against the 'other brand'. OK for 12-branch and, perhaps, 11-branch? Regards Paul Fortran: Assumed and explicit size class arrays [PR46691/99819]. 2021-05-06 Paul Thomas <pa...@gcc.gnu.org> gcc/fortran/ChangeLog PR fortran/46691 PR fortran/99819 * class.c (gfc_build_class_symbol): 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_6.f90: New test.
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 e99980fd223..6d38ea78273 100644 --- a/gcc/fortran/trans-array.c +++ b/gcc/fortran/trans-array.c @@ -6524,7 +6524,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); @@ -6626,7 +6633,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 213f32b0a67..5f5479561c2 100644 --- a/gcc/fortran/trans-expr.c +++ b/gcc/fortran/trans-expr.c @@ -6420,6 +6420,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
! { dg-do run } ! ! Test the fix for PR46691 - enable class assumed size arrays ! ! Reported by Tobias Burnus <bur...@gcc.gnu.org> ! 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
! { dg-do run } ! ! Test the fix for PR99819 - explicit shape class arrays in different ! procedures caused an ICE. ! ! Contributed by Gerhard Steinmetz <gs...@t-online.de> ! 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