The attached bootstraps and regtests on FC30/x86_64 - OK for trunk?
It strikes me that this should be backported since the bug is rather
fundamental and ispresent all the way back to version 4.8. An obvious
question is how far back? To 8-branch?
Cheers
Paul
2019-09-15 Paul Thomas <pa...@gcc.gnu.org>
PR fortran/91588
* expr.c (check_inquiry): Remove extended component refs by
using symbol pointers. If a function argument is an associate
variable with a constant target, copy the target expression in
place of the argument expression. Check that the charlen is not
NULL before using the string length.
(gfc_check_assign): Remove extraneous space.
2019-09-15 Paul Thomas <pa...@gcc.gnu.org>
PR fortran/91588
* gfortran.dg/associate_49.f90 : New test.
Index: gcc/fortran/expr.c
===================================================================
*** gcc/fortran/expr.c (revision 275695)
--- gcc/fortran/expr.c (working copy)
*************** check_inquiry (gfc_expr *e, int not_rest
*** 2610,2615 ****
--- 2610,2617 ----
int i = 0;
gfc_actual_arglist *ap;
+ gfc_symbol *sym;
+ gfc_symbol *asym;
if (!e->value.function.isym
|| !e->value.function.isym->inquiry)
*************** check_inquiry (gfc_expr *e, int not_rest
*** 2619,2638 ****
if (e->symtree == NULL)
return MATCH_NO;
! if (e->symtree->n.sym->from_intmod)
{
! if (e->symtree->n.sym->from_intmod == INTMOD_ISO_FORTRAN_ENV
! && e->symtree->n.sym->intmod_sym_id != ISOFORTRAN_COMPILER_OPTIONS
! && e->symtree->n.sym->intmod_sym_id != ISOFORTRAN_COMPILER_VERSION)
return MATCH_NO;
! if (e->symtree->n.sym->from_intmod == INTMOD_ISO_C_BINDING
! && e->symtree->n.sym->intmod_sym_id != ISOCBINDING_C_SIZEOF)
return MATCH_NO;
}
else
{
! name = e->symtree->n.sym->name;
functions = inquiry_func_gnu;
if (gfc_option.warn_std & GFC_STD_F2003)
--- 2621,2642 ----
if (e->symtree == NULL)
return MATCH_NO;
! sym = e->symtree->n.sym;
!
! if (sym->from_intmod)
{
! if (sym->from_intmod == INTMOD_ISO_FORTRAN_ENV
! && sym->intmod_sym_id != ISOFORTRAN_COMPILER_OPTIONS
! && sym->intmod_sym_id != ISOFORTRAN_COMPILER_VERSION)
return MATCH_NO;
! if (sym->from_intmod == INTMOD_ISO_C_BINDING
! && sym->intmod_sym_id != ISOCBINDING_C_SIZEOF)
return MATCH_NO;
}
else
{
! name = sym->name;
functions = inquiry_func_gnu;
if (gfc_option.warn_std & GFC_STD_F2003)
*************** check_inquiry (gfc_expr *e, int not_rest
*** 2657,2697 ****
if (!ap->expr)
continue;
if (ap->expr->ts.type == BT_UNKNOWN)
{
! if (ap->expr->symtree->n.sym->ts.type == BT_UNKNOWN
! && !gfc_set_default_type (ap->expr->symtree->n.sym, 0, gfc_current_ns))
return MATCH_NO;
! ap->expr->ts = ap->expr->symtree->n.sym->ts;
}
! /* Assumed character length will not reduce to a constant expression
! with LEN, as required by the standard. */
! if (i == 5 && not_restricted && ap->expr->symtree
! && ap->expr->symtree->n.sym->ts.type == BT_CHARACTER
! && (ap->expr->symtree->n.sym->ts.u.cl->length == NULL
! || ap->expr->symtree->n.sym->ts.deferred))
! {
! gfc_error ("Assumed or deferred character length variable %qs "
! "in constant expression at %L",
! ap->expr->symtree->n.sym->name,
! &ap->expr->where);
! return MATCH_ERROR;
! }
! else if (not_restricted && !gfc_check_init_expr (ap->expr))
! return MATCH_ERROR;
! if (not_restricted == 0
! && ap->expr->expr_type != EXPR_VARIABLE
! && !check_restricted (ap->expr))
return MATCH_ERROR;
! if (not_restricted == 0
! && ap->expr->expr_type == EXPR_VARIABLE
! && ap->expr->symtree->n.sym->attr.dummy
! && ap->expr->symtree->n.sym->attr.optional)
! return MATCH_NO;
}
return MATCH_YES;
--- 2661,2708 ----
if (!ap->expr)
continue;
+ asym = ap->expr->symtree ? ap->expr->symtree->n.sym : NULL;
+
if (ap->expr->ts.type == BT_UNKNOWN)
{
! if (asym && asym->ts.type == BT_UNKNOWN
! && !gfc_set_default_type (asym, 0, gfc_current_ns))
return MATCH_NO;
! ap->expr->ts = asym->ts;
}
! if (asym && asym->assoc && asym->assoc->target
! && asym->assoc->target->expr_type == EXPR_CONSTANT)
! {
! gfc_free_expr (ap->expr);
! ap->expr = gfc_copy_expr (asym->assoc->target);
! }
! /* Assumed character length will not reduce to a constant expression
! with LEN, as required by the standard. */
! if (i == 5 && not_restricted && asym
! && asym->ts.type == BT_CHARACTER
! && ((asym->ts.u.cl && asym->ts.u.cl->length == NULL)
! || asym->ts.deferred))
! {
! gfc_error ("Assumed or deferred character length variable %qs "
! "in constant expression at %L",
! asym->name, &ap->expr->where);
return MATCH_ERROR;
+ }
+ else if (not_restricted && !gfc_check_init_expr (ap->expr))
+ return MATCH_ERROR;
! if (not_restricted == 0
! && ap->expr->expr_type != EXPR_VARIABLE
! && !check_restricted (ap->expr))
! return MATCH_ERROR;
!
! if (not_restricted == 0
! && ap->expr->expr_type == EXPR_VARIABLE
! && asym->attr.dummy && asym->attr.optional)
! return MATCH_NO;
}
return MATCH_YES;
*************** gfc_check_assign (gfc_expr *lvalue, gfc_
*** 3683,3689 ****
gfc_error ("BOZ literal constant near %L cannot be assigned to a "
"%qs variable", &rvalue->where, gfc_typename (&lvalue->ts));
!
return false;
}
--- 3694,3700 ----
gfc_error ("BOZ literal constant near %L cannot be assigned to a "
"%qs variable", &rvalue->where, gfc_typename (&lvalue->ts));
!
return false;
}
Index: gcc/testsuite/gfortran.dg/associate_49.f90
===================================================================
*** gcc/testsuite/gfortran.dg/associate_49.f90 (nonexistent)
--- gcc/testsuite/gfortran.dg/associate_49.f90 (working copy)
***************
*** 0 ****
--- 1,34 ----
+ ! { dg-do run }
+ !
+ ! Test the fix for PR91588, in which the declaration of 'a' caused
+ ! an ICE.
+ !
+ ! Contributed by Gerhardt Steinmetz <gs...@t-online.de>
+ !
+ program p
+ character(4), parameter :: parm = '7890'
+ associate (z => '1234')
+ block
+ integer(len(z)) :: a
+ if (kind(a) .ne. 4) stop 1
+ end block
+ end associate
+ associate (z => '123')
+ block
+ integer(len(z)+1) :: a
+ if (kind(a) .ne. 4) stop 2
+ end block
+ end associate
+ associate (z => 1_8)
+ block
+ integer(kind(z)) :: a
+ if (kind(a) .ne. 8) stop 3
+ end block
+ end associate
+ associate (z => parm)
+ block
+ integer(len(z)) :: a
+ if (kind(a) .ne. 4) stop 4
+ end block
+ end associate
+ end
