[Patch, fortran] PR91588 - ICE in check_inquiry, at fortran/expr.c:2673

[Paul Richard Thomas <paul.richard.thomas@gmail.com>]

[-- Attachment #1: Type: text/plain, Size: 799 bytes --]

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.

[-- Attachment #2: submit.diff --]
[-- Type: text/x-patch, Size: 6191 bytes --]

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