===================================================================
*************** check_inquiry (gfc_expr *e, int not_rest
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
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)
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
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;
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_
gfc_error ("BOZ literal constant near %L cannot be assigned to a "
"%qs variable", &rvalue->where, gfc_typename (&lvalue->ts));
!
return false;
}
gfc_error ("BOZ literal constant near %L cannot be assigned to a "
"%qs variable", &rvalue->where, gfc_typename (&lvalue->ts));
!
return false;
}
===================================================================
***************
+ ! { dg-do run }
+ !
+ ! Test the fix for PR91588, in which the declaration of 'a' caused
+ ! an ICE.
+ !
+ ! Contributed by Gerhardt Steinmetz <gscfq@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
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 <pault@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 <pault@gcc.gnu.org> PR fortran/91588 * gfortran.dg/associate_49.f90 : New test.