procyberian/gcc
1
0
Fork 0
Code Issues Pull requests Projects Releases Packages Wiki Activity Actions

Fortran: character length of pointer assignments in structure constructors

Browse source 
gcc/fortran/ChangeLog:

	PR fortran/50549
	* resolve.cc (resolve_structure_cons): Reject pointer assignments
	of character with different lengths in structure constructor.

gcc/testsuite/ChangeLog:

	PR fortran/50549
	* gfortran.dg/char_pointer_assign_7.f90: New test.
This commit is contained in:
Harald Anlauf 2022-03-27 21:35:15 +02:00
parent d886a5248e
commit 0712f35637
2 changed files with 50 additions and 1 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

13
gcc/fortran/resolve.cc
View file

@ -1375,11 +1375,22 @@ resolve_structure_cons (gfc_expr *expr, int init)
&& comp->ts.u.cl->length->expr_type == EXPR_CONSTANT
&& cons->expr->ts.u.cl && cons->expr->ts.u.cl->length
&& cons->expr->ts.u.cl->length->expr_type == EXPR_CONSTANT
&& cons->expr->rank != 0
&& mpz_cmp (cons->expr->ts.u.cl->length->value.integer,
comp->ts.u.cl->length->value.integer) != 0)
{
if (comp->attr.pointer)
{
HOST_WIDE_INT la, lb;
la = gfc_mpz_get_hwi (comp->ts.u.cl->length->value.integer);
lb = gfc_mpz_get_hwi (cons->expr->ts.u.cl->length->value.integer);
gfc_error ("Unequal character lengths (%wd/%wd) for pointer "
"component %qs in constructor at %L",
la, lb, comp->name, &cons->expr->where);
t = false;
}
if (cons->expr->expr_type == EXPR_VARIABLE
&& cons->expr->rank != 0
&& cons->expr->symtree->n.sym->attr.flavor == FL_PARAMETER)
{
/* Wrap the parameter in an array constructor (EXPR_ARRAY)

38
gcc/testsuite/gfortran.dg/char_pointer_assign_7.f90 Normal file
View file

@ -0,0 +1,38 @@
! { dg-do compile }
! PR fortran/50549 - should reject pointer assignments of different lengths
! in structure constructors
program test
implicit none
type t
character(2), pointer :: p2
end type t
type t2
character(2), pointer :: p(:)
end type t2
type td
character(:), pointer :: pd
end type td
interface
function f1 ()
character(1), pointer :: f1
end function f1
function f2 ()
character(2), pointer :: f2
end function f2
end interface
character(1), target :: p1
character(1), pointer :: q1(:)
character(2), pointer :: q2(:)
type(t) :: u
type(t2) :: u2
type(td) :: v
u = t(p1) ! { dg-error "Unequal character lengths" }
u = t(f1()) ! { dg-error "Unequal character lengths" }
u = t(f2()) ! OK
u2 = t2(q1) ! { dg-error "Unequal character lengths" }
u2 = t2(q2) ! OK
v = td(p1) ! OK
v = td(f1()) ! OK
end