===================================================================
*************** 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