https://gcc.gnu.org/g:fc062c12ff59b22061bea98a3539da857968bccb
commit r13-9282-gfc062c12ff59b22061bea98a3539da857968bccb
Author: Paul Thomas <pa...@gcc.gnu.org>
Date: Tue May 16 06:35:40 2023 +0100
Fortran: Fix an assortment of bugs
2023-05-16 Paul Thomas <pa...@gcc.gnu.org>
gcc/fortran
PR fortran/105152
* interface.cc (gfc_compare_actual_formal): Emit an error if an
unlimited polymorphic actual is not matched either to an
unlimited or assumed type formal argument.
PR fortran/100193
* resolve.cc (resolve_ordinary_assign): Emit an error if the
var expression of an ordinary assignment is a proc pointer
component.
PR fortran/87496
* trans-array.cc (gfc_walk_array_ref): Provide assumed shape
arrays coming from interface mapping with a viable arrayspec.
PR fortran/103389
* trans-expr.cc (gfc_conv_intrinsic_to_class): Tidy up flagging
of unlimited polymorphic 'class_ts'.
(gfc_conv_gfc_desc_to_cfi_desc): Assumed type is unlimited
polymorphic and should accept any actual type.
PR fortran/104429
(gfc_conv_procedure_call): Replace dreadful kludge with a call
to gfc_finalize_tree_expr. Avoid dereferencing a void pointer
by giving it the pointer type of the actual argument.
PR fortran/82774
(alloc_scalar_allocatable_subcomponent): Shorten the function
name and replace the symbol argument with the se string length.
If a deferred length character length is either not present or
is not a variable, give the typespec a variable and assign the
string length to that. Use gfc_deferred_strlen to find the
hidden string length component.
(gfc_trans_subcomponent_assign): Convert the expression before
the call to alloc_scalar_allocatable_subcomponent so that a
good string length is provided.
(gfc_trans_structure_assign): Remove the unneeded derived type
symbol from calls to gfc_trans_subcomponent_assign.
gcc/testsuite/
PR fortran/105152
* gfortran.dg/pr105152.f90 : New test
PR fortran/100193
* gfortran.dg/pr100193.f90 : New test
PR fortran/87946
* gfortran.dg/pr87946.f90 : New test
PR fortran/103389
* gfortran.dg/pr103389.f90 : New test
PR fortran/104429
* gfortran.dg/pr104429.f90 : New test
PR fortran/82774
* gfortran.dg/pr82774.f90 : New test
(cherry picked from commit 6c95fe9bc0553743098eeaa739f14b885050fa42)
Diff:
---
gcc/fortran/interface.cc | 10 ++++
gcc/fortran/resolve.cc | 11 ++++
gcc/fortran/trans-array.cc | 6 +++
gcc/fortran/trans-expr.cc | 96 +++++++++++++++-------------------
gcc/testsuite/gfortran.dg/pr100193.f90 | 20 +++++++
gcc/testsuite/gfortran.dg/pr103389.f90 | 23 ++++++++
gcc/testsuite/gfortran.dg/pr104429.f90 | 35 +++++++++++++
gcc/testsuite/gfortran.dg/pr105152.f90 | 19 +++++++
gcc/testsuite/gfortran.dg/pr82774.f90 | 15 ++++++
gcc/testsuite/gfortran.dg/pr87946.f90 | 42 +++++++++++++++
10 files changed, 223 insertions(+), 54 deletions(-)
diff --git a/gcc/fortran/interface.cc b/gcc/fortran/interface.cc
index 05c92ab8f678..48bec125d346 100644
--- a/gcc/fortran/interface.cc
+++ b/gcc/fortran/interface.cc
@@ -3360,6 +3360,16 @@ gfc_compare_actual_formal (gfc_actual_arglist **ap,
gfc_formal_arglist *formal,
}
}
+ if (UNLIMITED_POLY (a->expr)
+ && !(f->sym->ts.type == BT_ASSUMED || UNLIMITED_POLY (f->sym)))
+ {
+ gfc_error ("Unlimited polymorphic actual argument at %L is not "
+ "matched with either an unlimited polymorphic or "
+ "assumed type dummy argument", &a->expr->where);
+ ok = false;
+ goto match;
+ }
+
/* Special case for character arguments. For allocatable, pointer
and assumed-shape dummies, the string length needs to match
exactly. */
diff --git a/gcc/fortran/resolve.cc b/gcc/fortran/resolve.cc
index 6f13725cac57..b9c027ccc0f0 100644
--- a/gcc/fortran/resolve.cc
+++ b/gcc/fortran/resolve.cc
@@ -11201,6 +11201,17 @@ resolve_ordinary_assign (gfc_code *code, gfc_namespace
*ns)
lhs = code->expr1;
rhs = code->expr2;
+ if ((lhs->symtree->n.sym->ts.type == BT_DERIVED
+ || lhs->symtree->n.sym->ts.type == BT_CLASS)
+ && !lhs->symtree->n.sym->attr.proc_pointer
+ && gfc_expr_attr (lhs).proc_pointer)
+ {
+ gfc_error ("Variable in the ordinary assignment at %L is a procedure "
+ "pointer component",
+ &lhs->where);
+ return false;
+ }
+
if ((gfc_numeric_ts (&lhs->ts) || lhs->ts.type == BT_LOGICAL)
&& rhs->ts.type == BT_CHARACTER
&& (rhs->expr_type != EXPR_CONSTANT || !flag_dec_char_conversions))
diff --git a/gcc/fortran/trans-array.cc b/gcc/fortran/trans-array.cc
index 77faf3070ab1..6e159e0557cb 100644
--- a/gcc/fortran/trans-array.cc
+++ b/gcc/fortran/trans-array.cc
@@ -11589,6 +11589,12 @@ gfc_walk_array_ref (gfc_ss * ss, gfc_expr * expr,
gfc_ref * ref)
break;
case AR_FULL:
+ /* Assumed shape arrays from interface mapping need this fix. */
+ if (!ar->as && expr->symtree->n.sym->as)
+ {
+ ar->as = gfc_get_array_spec();
+ *ar->as = *expr->symtree->n.sym->as;
+ }
newss = gfc_get_array_ss (ss, expr, ar->as->rank, GFC_SS_SECTION);
newss->info->data.array.ref = ref;
diff --git a/gcc/fortran/trans-expr.cc b/gcc/fortran/trans-expr.cc
index 571916654129..6cf1692913d8 100644
--- a/gcc/fortran/trans-expr.cc
+++ b/gcc/fortran/trans-expr.cc
@@ -998,6 +998,12 @@ gfc_conv_intrinsic_to_class (gfc_se *parmse, gfc_expr *e,
tree var;
tree tmp;
int dim;
+ bool unlimited_poly;
+
+ unlimited_poly = class_ts.type == BT_CLASS
+ && class_ts.u.derived->components->ts.type == BT_DERIVED
+ && class_ts.u.derived->components->ts.u.derived
+ ->attr.unlimited_polymorphic;
/* The intrinsic type needs to be converted to a temporary
CLASS object. */
@@ -1069,9 +1075,7 @@ gfc_conv_intrinsic_to_class (gfc_se *parmse, gfc_expr *e,
}
gcc_assert (class_ts.type == BT_CLASS);
- if (class_ts.u.derived->components->ts.type == BT_DERIVED
- && class_ts.u.derived->components->ts.u.derived
- ->attr.unlimited_polymorphic)
+ if (unlimited_poly)
{
ctree = gfc_class_len_get (var);
/* When the actual arg is a char array, then set the _len component of
the
@@ -1118,10 +1122,7 @@ gfc_conv_intrinsic_to_class (gfc_se *parmse, gfc_expr *e,
gfc_add_modify (&parmse->pre, ctree, fold_convert (TREE_TYPE (ctree),
tmp));
}
- else if (class_ts.type == BT_CLASS
- && class_ts.u.derived->components
- && class_ts.u.derived->components->ts.u
- .derived->attr.unlimited_polymorphic)
+ else if (unlimited_poly)
{
ctree = gfc_class_len_get (var);
gfc_add_modify (&parmse->pre, ctree,
@@ -5694,7 +5695,7 @@ gfc_conv_gfc_desc_to_cfi_desc (gfc_se *parmse, gfc_expr
*e, gfc_symbol *fsym)
itype = CFI_type_other; // FIXME: Or CFI_type_cptr ?
break;
case BT_CLASS:
- if (UNLIMITED_POLY (e) && fsym->ts.type == BT_ASSUMED)
+ if (fsym->ts.type == BT_ASSUMED)
{
// F2017: 7.3.2.2: "An entity that is declared using the TYPE(*)
// type specifier is assumed-type and is an unlimited polymorphic
@@ -6730,20 +6731,11 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym,
{
tree zero;
- gfc_expr *var;
-
- /* Borrow the function symbol to make a call to
- gfc_add_finalizer_call and then restore it. */
- tmp = e->symtree->n.sym->backend_decl;
- e->symtree->n.sym->backend_decl
- = TREE_OPERAND (parmse.expr, 0);
- e->symtree->n.sym->attr.flavor = FL_VARIABLE;
- var = gfc_lval_expr_from_sym (e->symtree->n.sym);
- finalized = gfc_add_finalizer_call (&parmse.post,
- var);
- gfc_free_expr (var);
- e->symtree->n.sym->backend_decl = tmp;
- e->symtree->n.sym->attr.flavor = FL_PROCEDURE;
+ /* Finalize the expression. */
+ gfc_finalize_tree_expr (&parmse, NULL,
+ gfc_expr_attr (e), e->rank);
+ gfc_add_block_to_block (&parmse.post,
+ &parmse.finalblock);
/* Then free the class _data. */
zero = build_int_cst (TREE_TYPE (parmse.expr), 0);
@@ -7183,7 +7175,15 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym,
types passed to class formals need the _data component. */
tmp = gfc_class_data_get (tmp);
if (!CLASS_DATA (fsym)->attr.dimension)
- tmp = build_fold_indirect_ref_loc (input_location, tmp);
+ {
+ if (UNLIMITED_POLY (fsym))
+ {
+ tree type = gfc_typenode_for_spec (&e->ts);
+ type = build_pointer_type (type);
+ tmp = fold_convert (type, tmp);
+ }
+ tmp = build_fold_indirect_ref_loc (input_location, tmp);
+ }
}
if (e->expr_type == EXPR_OP
@@ -8833,11 +8833,9 @@ gfc_trans_alloc_subarray_assign (tree dest,
gfc_component * cm,
/* Allocate or reallocate scalar component, as necessary. */
static void
-alloc_scalar_allocatable_for_subcomponent_assignment (stmtblock_t *block,
- tree comp,
- gfc_component *cm,
- gfc_expr *expr2,
- gfc_symbol *sym)
+alloc_scalar_allocatable_subcomponent (stmtblock_t *block, tree comp,
+ gfc_component *cm, gfc_expr *expr2,
+ tree slen)
{
tree tmp;
tree ptr;
@@ -8855,26 +8853,20 @@ alloc_scalar_allocatable_for_subcomponent_assignment
(stmtblock_t *block,
if (cm->ts.type == BT_CHARACTER && cm->ts.deferred)
{
- char name[GFC_MAX_SYMBOL_LEN+9];
- gfc_component *strlen;
- /* Use the rhs string length and the lhs element size. */
gcc_assert (expr2->ts.type == BT_CHARACTER);
- if (!expr2->ts.u.cl->backend_decl)
- {
- gfc_conv_string_length (expr2->ts.u.cl, expr2, block);
- gcc_assert (expr2->ts.u.cl->backend_decl);
- }
+ if (!expr2->ts.u.cl->backend_decl
+ || !VAR_P (expr2->ts.u.cl->backend_decl))
+ expr2->ts.u.cl->backend_decl = gfc_create_var (TREE_TYPE (slen),
+ "slen");
+ gfc_add_modify (block, expr2->ts.u.cl->backend_decl, slen);
size = expr2->ts.u.cl->backend_decl;
- /* Ensure that cm->ts.u.cl->backend_decl is a componentref to _%s_length
- component. */
- sprintf (name, "_%s_length", cm->name);
- strlen = gfc_find_component (sym, name, true, true, NULL);
+ gfc_deferred_strlen (cm, &tmp);
lhs_cl_size = fold_build3_loc (input_location, COMPONENT_REF,
gfc_charlen_type_node,
TREE_OPERAND (comp, 0),
- strlen->backend_decl, NULL_TREE);
+ tmp, NULL_TREE);
tmp = TREE_TYPE (gfc_typenode_for_spec (&cm->ts));
tmp = TYPE_SIZE_UNIT (tmp);
@@ -8947,8 +8939,8 @@ alloc_scalar_allocatable_for_subcomponent_assignment
(stmtblock_t *block,
/* Assign a single component of a derived type constructor. */
static tree
-gfc_trans_subcomponent_assign (tree dest, gfc_component * cm, gfc_expr * expr,
- gfc_symbol *sym, bool init)
+gfc_trans_subcomponent_assign (tree dest, gfc_component * cm,
+ gfc_expr * expr, bool init)
{
gfc_se se;
gfc_se lse;
@@ -9042,19 +9034,17 @@ gfc_trans_subcomponent_assign (tree dest, gfc_component
* cm, gfc_expr * expr,
|| (cm->ts.type == BT_CLASS && CLASS_DATA (cm)->attr.allocatable
&& expr->ts.type != BT_CLASS)))
{
+ gfc_init_se (&se, NULL);
+ gfc_conv_expr (&se, expr);
+
/* Take care about non-array allocatable components here. The alloc_*
routine below is motivated by the alloc_scalar_allocatable_for_
assignment() routine, but with the realloc portions removed and
different input. */
- alloc_scalar_allocatable_for_subcomponent_assignment (&block,
- dest,
- cm,
- expr,
- sym);
+ alloc_scalar_allocatable_subcomponent (&block, dest, cm, expr,
+ se.string_length);
/* The remainder of these instructions follow the if (cm->attr.pointer)
if (!cm->attr.dimension) part above. */
- gfc_init_se (&se, NULL);
- gfc_conv_expr (&se, expr);
gfc_add_block_to_block (&block, &se.pre);
if (expr->symtree && expr->symtree->n.sym->attr.proc_pointer
@@ -9318,13 +9308,11 @@ gfc_trans_structure_assign (tree dest, gfc_expr * expr,
bool init, bool coarray)
if (!c->expr)
{
gfc_expr *e = gfc_get_null_expr (NULL);
- tmp = gfc_trans_subcomponent_assign (tmp, cm, e, expr->ts.u.derived,
- init);
+ tmp = gfc_trans_subcomponent_assign (tmp, cm, e, init);
gfc_free_expr (e);
}
else
- tmp = gfc_trans_subcomponent_assign (tmp, cm, c->expr,
- expr->ts.u.derived, init);
+ tmp = gfc_trans_subcomponent_assign (tmp, cm, c->expr, init);
gfc_add_expr_to_block (&block, tmp);
}
return gfc_finish_block (&block);
diff --git a/gcc/testsuite/gfortran.dg/pr100193.f90
b/gcc/testsuite/gfortran.dg/pr100193.f90
new file mode 100644
index 000000000000..07a3634cb063
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/pr100193.f90
@@ -0,0 +1,20 @@
+! { dg-do compile }
+!
+! Contributed by Gerhard Steinmetz <gs...@t-online.de>
+!
+module m
+ implicit none
+ type t
+ procedure(f), pointer, nopass :: g
+ end type
+contains
+ function f()
+ character(:), allocatable :: f
+ f = 'abc'
+ end
+ subroutine s
+ type(t) :: z
+ z%g = 'x' ! { dg-error "is a procedure pointer" }
+ if ( z%g() /= 'abc' ) stop
+ end
+end
diff --git a/gcc/testsuite/gfortran.dg/pr103389.f90
b/gcc/testsuite/gfortran.dg/pr103389.f90
new file mode 100644
index 000000000000..565551564e39
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/pr103389.f90
@@ -0,0 +1,23 @@
+! { dg-do run }
+!
+! Contributed by Gerhard Steinmetz <gs...@t-online.de>
+!
+program p
+ type t
+ integer, allocatable :: a(:)
+ end type
+ type(t) :: y
+ y%a = [1,2]
+ call s((y))
+ if (any (y%a .ne. [3,4])) stop 1
+contains
+ subroutine s(x)
+ class(*) :: x
+ select type (x)
+ type is (t)
+ x%a = x%a + 2
+ class default
+ stop 2
+ end select
+ end
+end
diff --git a/gcc/testsuite/gfortran.dg/pr104429.f90
b/gcc/testsuite/gfortran.dg/pr104429.f90
new file mode 100644
index 000000000000..39761fd59fa6
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/pr104429.f90
@@ -0,0 +1,35 @@
+! { dg-do run }
+!
+! Contributed by Gerhard Steinmetz <gs...@t-online.de>
+!
+module m
+ type t
+ real :: r
+ contains
+ procedure :: op
+ procedure :: assign
+ generic :: operator(*) => op
+ generic :: assignment(=) => assign
+ end type
+contains
+ function op (x, y)
+ class(t), allocatable :: op
+ class(t), intent(in) :: x
+ real, intent(in) :: y
+ allocate (op, source = t (x%r * y))
+ end
+ subroutine assign (z, x)
+ type(t), intent(in) :: x
+ class(t), intent(out) :: z
+ z%r = x%r
+ end
+end
+program p
+ use m
+ class(t), allocatable :: x
+ real :: y = 2
+ allocate (x, source = t (2.0))
+ x = x * y
+ if (int (x%r) .ne. 4) stop 1
+ if (allocated (x)) deallocate (x)
+end
diff --git a/gcc/testsuite/gfortran.dg/pr105152.f90
b/gcc/testsuite/gfortran.dg/pr105152.f90
new file mode 100644
index 000000000000..561b2a6c75d6
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/pr105152.f90
@@ -0,0 +1,19 @@
+! { dg-do compile }
+!
+! Contributed by Gerhard Steinmetz <gs...@t-online.de>
+!
+program p
+ use iso_c_binding
+ type, bind(c) :: t
+ integer(c_int) :: a
+ end type
+ interface
+ function f(x) bind(c) result(z)
+ import :: c_int, t
+ type(t) :: x(:)
+ integer(c_int) :: z
+ end
+ end interface
+ class(*), allocatable :: y(:)
+ n = f(y) ! { dg-error "either an unlimited polymorphic or assumed type" }
+end
diff --git a/gcc/testsuite/gfortran.dg/pr82774.f90
b/gcc/testsuite/gfortran.dg/pr82774.f90
new file mode 100644
index 000000000000..81c22ab38286
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/pr82774.f90
@@ -0,0 +1,15 @@
+! { dg-do run }
+!
+! Contributed by Steve Kargl <ka...@gcc.gnu.org>
+!
+program main
+ implicit none
+ type stuff
+ character(:), allocatable :: key
+ end type stuff
+ type(stuff) nonsense, total
+ nonsense = stuff('Xe')
+ total = stuff(nonsense%key) ! trim nonsense%key made this work
+ if (nonsense%key /= total%key) call abort
+ if (len(total%key) /= 2) call abort
+end program main
diff --git a/gcc/testsuite/gfortran.dg/pr87946.f90
b/gcc/testsuite/gfortran.dg/pr87946.f90
new file mode 100644
index 000000000000..793d37a7f399
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/pr87946.f90
@@ -0,0 +1,42 @@
+! { dg-do run }
+!
+! Contributed by Gerhard Steinmetz <gs...@t-online.de>
+!
+module m
+ type t
+ contains
+ generic :: h => g
+ procedure, private :: g
+ end type
+contains
+ function g(x, y) result(z)
+ class(t), intent(in) :: x
+ real, intent(in) :: y(:, :)
+ real :: z(size(y, 2))
+ integer :: i
+ do i = 1, size(y, 2)
+ z(i) = i
+ end do
+ end
+end
+module m2
+ use m
+ type t2
+ class(t), allocatable :: u(:)
+ end type
+end
+ use m2
+ type(t2) :: x
+ real :: y(1,5)
+ allocate (x%u(1))
+ if (any (int(f (x, y)) .ne. [1,2,3,4,5])) stop 1
+ deallocate (x%u)
+contains
+ function f(x, y) result(z)
+ use m2
+ type(t2) :: x
+ real :: y(:, :)
+ real :: z(size(y, 2))
+ z = x%u(1)%h(y) ! Used to segfault here
+ end
+end
