[Patch, Fortran] PR 47569 - fix ICE (regression) and fix diagnostic

[Mikael Morin]

On Saturday 12 February 2011 00:26:57 Tobias Burnus wrote:
> PR 47569 is about a 4.3/4.4/4.5/4.6 regression where
> "component%substring(1:2)" gave an ICE. Looking closer at the issue, I
> saw that the checks were a bit incomplete and inconsistent. I hope that
> with the patch the diagnostic is now correct.
> 
>  From the standards:
> 
> F97: "If the actual argument is scalar, the corresponding dummy argument
> shall be scalar unless the actual argument is an element of an array
> that is not an assumed-shape or pointer array, or a substring of such an
> element."
> 
> F2003: "If the actual argument is scalar, the corresponding dummy
> argument shall be scalar unless the actual argument is of type default
> character, of type character with the C character kind (15.1), or is an
> element or substring of an element of an array that is not an
> assumed-shape or pointer array."
> 
> F2008 quote ("12.5.2.4 Ordinary dummy variables"):
> "If the actual argument is a noncoindexed scalar, the corresponding dummy
> argument shall be scalar unless the actual argument is default character,
> of type character with the C character kind (15.2.2), 
If I understand this correctly, anything of default character kind type is 
allowed. Thus...

> or is an element or
> substring of an element of an array that is not an assumed-shape,
> pointer, or
> polymorphic array."
> 
>
> 
> diff --git a/gcc/fortran/interface.c b/gcc/fortran/interface.c
> index 1e5df61..b555c3d 100644
> --- a/gcc/fortran/interface.c
> +++ b/gcc/fortran/interface.c
> @@ -1461,7 +1461,7 @@ compare_parameter (gfc_symbol *formal, gfc_expr 
*actual,
>                    int ranks_must_agree, int is_elemental, locus *where)
>  {
>    gfc_ref *ref;
> -  bool rank_check;
> +  bool rank_check, is_pointer;
>  
>    /* If the formal arg has type BT_VOID, it's to one of the iso_c_binding
>       procs c_f_pointer or c_f_procpointer, and we need to accept most
> @@ -1672,23 +1672,58 @@ compare_parameter (gfc_symbol *formal, gfc_expr 
*actual,
>      return 1;
>  
>    /* At this point, we are considering a scalar passed to an array.   This
> -     is valid (cf. F95 12.4.1.1; F2003 12.4.1.2),
> +     is valid (cf. F95 12.4.1.1, F2003 12.4.1.2, and F2008 12.5.2.4),
>       - if the actual argument is (a substring of) an element of a
> -       non-assumed-shape/non-pointer array;
> -     - (F2003) if the actual argument is of type character.  */
> +       non-assumed-shape/non-pointer/non-polymorphic array;
> +     - (F2003) if the actual argument is of type character of 
default/c_char
> +       kind.  */

... one could/should return early here for default (or C_CHAR) kind characters 
?
That would mean some lines previously marked as "! Valid F2003" in the 
testsuite could/should remain so. 

> +
> +  is_pointer = actual->expr_type == EXPR_VARIABLE
> +              ? actual->symtree->n.sym->attr.pointer : false;
>  
>    for (ref = actual->ref; ref; ref = ref->next)
> -    if (ref->type == REF_ARRAY && ref->u.ar.type == AR_ELEMENT
> -       && ref->u.ar.dimen > 0)
> -      break;
> +    {
> +      if (ref->type == REF_COMPONENT)
> +       is_pointer = ref->u.c.component->attr.pointer;
> +      else if (ref->type == REF_ARRAY && ref->u.ar.type == AR_ELEMENT
> +              && ref->u.ar.dimen > 0
> +              && (!ref->next 
> +                  || (ref->next->type == REF_SUBSTRING && !ref->next-
>next)))
> +        break;
> +    }
> +
> +  if (actual->expr_type != EXPR_NULL
> +      && (is_pointer || (ref && ref->u.ar.as->type == AS_ASSUMED_SHAPE)))
> +    {
> +      if (where)
> +       gfc_error ("Scalar pointer or element of assumed-shaped or pointer "
> +                  "array passed to array dummy argument '%s' at %L",
> +                  formal->name, &actual->where);
> +      return 0;
> +    }
> +
> +  if (actual->ts.type == BT_CLASS && actual->expr_type != EXPR_NULL)
> +    {
> +      if (where)
> +       gfc_error ("Polymorphic scalar passed to array dummy argument '%s' "
> +                  "at %L", formal->name, &actual->where);
> +      return 0;
> +    }
>  
> -  /* Not an array element.  */
> -  if (formal->ts.type == BT_CHARACTER
> -      && (ref == NULL
> -          || (actual->expr_type == EXPR_VARIABLE
> -             && (actual->symtree->n.sym->as->type == AS_ASSUMED_SHAPE
> -                 || actual->symtree->n.sym->attr.pointer))))
> +  if (formal->ts.type == BT_CHARACTER && actual->expr_type != EXPR_NULL && 
!ref)
>      {
> +      if (formal->ts.kind == 4 && where
> +         && (gfc_option.allow_std & GFC_STD_GNU) == 0)
> +       {
> +         gfc_error ("Extension: Scalar ISO-10646 CHARACTER actual argument 
"
> +                    "with array dummy argument '%s' at %L",
> +                    formal->name, &actual->where);
> +         return 0;
> +       }
> +
> +      if (formal->ts.kind == 4 && (gfc_option.allow_std & GFC_STD_GNU) == 
0)
> +       return 0;
- I find it clearer to have the conditions merged and the error under a "if 
(where)" like you did elsewhere. 
- Is there a reason not to use gfc_notify_std ?
- Also, I think the error message above could be interpreted as if the problem 
is the presence of non-ascii characters in the actual argument. So I would 
preferably stick to the standard wording (non either default or C kind 
character actual argument) even if it doesn't sound great.
- Last but not least, shouldn't actual->ts.kind be tested instead of formal-
>ts.kind ?

> +
>        if (where && (gfc_option.allow_std & GFC_STD_F2003) == 0)
>         {
>           gfc_error ("Fortran 2003: Scalar CHARACTER actual argument with "
> @@ -1709,17 +1744,6 @@ compare_parameter (gfc_symbol *formal, gfc_expr 
*actual,
>        return 0;
>      }
>  
> -  if (actual->expr_type == EXPR_VARIABLE
> -      && actual->symtree->n.sym->as
> -      && (actual->symtree->n.sym->as->type == AS_ASSUMED_SHAPE
> -         || actual->symtree->n.sym->attr.pointer))
> -    {
> -      if (where)
> -       gfc_error ("Element of assumed-shaped array passed to dummy "
> -                  "argument '%s' at %L", formal->name, &actual->where);
> -      return 0;
> -    }
> -
>    return 1;
>  }
>  

The rest (pointer, class and assumed shape) seem properly handled. 

Mikael