2021-05-06 Paul Thomas <pault@gcc.gnu.org>
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)
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,
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;
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;
/* 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);
&& 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)
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
--- /dev/null
+! { dg-do run }
+!
+! Test the fix for PR99819 - explicit shape class arrays in different
+! procedures caused an ICE.
+!
+! Contributed by Gerhard Steinmetz <gscfq@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
--- /dev/null
+! { dg-do run }
+!
+! Test the fix for PR46691 - enable class assumed size arrays
+!
+! Reported by Tobias Burnus <burnus@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
projects / thirdparty / gcc.git / commitdiff
