[Patch, fortran] PR25084, PR20852, PR25085, PR25086 & PR25416 - assumed character length functions

[Paul Thomas <paulthomas2 at wanadoo dot fr>]

:ADDPATCH fortran:

This patch addresses itself to some of the issues with assumed character 
length functions.

There are two parts:

One is trivial and implements the constraints and conditions of 5.1.1.5 
of the standard. I hovered over adding an assumed charlen attribute and 
using check_conflict to implement this but went for implementation in 
resolve.c, on grounds of clarity and simplicity.

The other is less trivial but is straightforward. The first part of the 
patch prevents a function call from being converted that has a *-charlen 
reference, except in the legal case of intrinsics like SPREAD. Since all 
such cases have the source as the first actual argument, the actual 
argument character length is used to provide the backend_decl for
the result. Being unambiguous, no check is made for the name of the 
function. This part of the patch cures the ICE in PR25416.

The first test checks the new constraints and conditions, the second 
checks that the second part of the patch fixes PR25416 and the third 
makes sure that the bits that should work do so.

I notice that, according to B.2 of the standard, assumed character 
length functions are obsolescent in F95. Is it worth a warning if std=f95?

Regtested on FC3/Athlon:  OK for mainline and 4.1?

Paul   

2005-01-25  Paul Thomas  <pault@gcc.gnu.org>

   PR fortran/25084
   PR fortran/20852
   PR fortran/25085
   PR fortran/25086
   * resolve.c (resolve_function): Declare a gfc_symbol to replace the 
references
   through the symtree to the symbol associated with the function 
expresion. Give
   error on reference to an assumed character length function is 
defined in an
   interface or an external function that is not a dummy argument.
   (resolve_symbol): Give error if an assumed character length function 
is array-
   valued, pointer-valued, pure or recursive.

   PR fortran/25416
   * trans-expr.c (gfc_conv_function_call): The above patch to 
resolve.c prevents
   any assumed character length function call from getting here, except 
intrinsics
   such as SPREAD. In this case, ensure that no segfault occurs from 
referencing
   non-existent charlen->length->expr_type and provide a backend_decl 
for the
   charlen from the charlen of the first actual argument.

2005-01-25  Paul Thomas  <pault@gcc.gnu.org>

   PR fortran/25084
   PR fortran/20852
   PR fortran/25085
   PR fortran/25086
   * gfortran.dg/assumed_charlen_function_1.f90: New test for constraints.
   * gfortran.dg/assumed_charlen_function_3.f90: New test for what 
should compile.

   PR fortran/25416
   * gfortran.dg/assumed_charlen_function_2.f90: New test for *-charlen 
in SPREAD.
Index: gcc/fortran/trans-expr.c
===================================================================
*** gcc/fortran/trans-expr.c	(revision 110174)
--- gcc/fortran/trans-expr.c	(working copy)
*************** gfc_conv_function_call (gfc_se * se, gfc
*** 1807,1814 ****
  
    gfc_init_interface_mapping (&mapping);
    need_interface_mapping = ((sym->ts.type == BT_CHARACTER
! 			     && sym->ts.cl->length->expr_type != EXPR_CONSTANT)
! 			    || sym->attr.dimension);
    formal = sym->formal;
    /* Evaluate the arguments.  */
    for (; arg != NULL; arg = arg->next, formal = formal ? formal->next : NULL)
--- 1807,1816 ----
  
    gfc_init_interface_mapping (&mapping);
    need_interface_mapping = ((sym->ts.type == BT_CHARACTER
! 				  && sym->ts.cl->length
! 				  && sym->ts.cl->length->expr_type
! 						!= EXPR_CONSTANT)
! 			      || sym->attr.dimension);
    formal = sym->formal;
    /* Evaluate the arguments.  */
    for (; arg != NULL; arg = arg->next, formal = formal ? formal->next : NULL)
*************** gfc_conv_function_call (gfc_se * se, gfc
*** 1905,1923 ****
    ts = sym->ts;
    if (ts.type == BT_CHARACTER)
      {
!       /* Calculate the length of the returned string.  */
!       gfc_init_se (&parmse, NULL);
!       if (need_interface_mapping)
! 	gfc_apply_interface_mapping (&mapping, &parmse, sym->ts.cl->length);
        else
! 	gfc_conv_expr (&parmse, sym->ts.cl->length);
!       gfc_add_block_to_block (&se->pre, &parmse.pre);
!       gfc_add_block_to_block (&se->post, &parmse.post);
  
        /* Set up a charlen structure for it.  */
        cl.next = NULL;
        cl.length = NULL;
-       cl.backend_decl = fold_convert (gfc_charlen_type_node, parmse.expr);
        ts.cl = &cl;
  
        len = cl.backend_decl;
--- 1907,1937 ----
    ts = sym->ts;
    if (ts.type == BT_CHARACTER)
      {
!       if (sym->ts.cl->length == NULL)
! 	{
! 	  /* Assumed character length results are not allowed by 5.1.1.5 of the
! 	     standard; except in the case of SPREAD(and other intrinsics?). All
! 	     other calls with *-charlen results are trapped in resolve.c. Since
! 	     it is unambiguously an intrinsic like SPREAD that gets us here, we
! 	     take the character length of the first argument for the result.  */
! 	  cl.backend_decl = TREE_VALUE (stringargs);
! 	}
        else
! 	{
! 	  /* Calculate the length of the returned string.  */
! 	  gfc_init_se (&parmse, NULL);
! 	  if (need_interface_mapping)
! 	    gfc_apply_interface_mapping (&mapping, &parmse, sym->ts.cl->length);
! 	  else
! 	    gfc_conv_expr (&parmse, sym->ts.cl->length);
! 	  gfc_add_block_to_block (&se->pre, &parmse.pre);
! 	  gfc_add_block_to_block (&se->post, &parmse.post);
! 	  cl.backend_decl = fold_convert (gfc_charlen_type_node, parmse.expr);
! 	}
  
        /* Set up a charlen structure for it.  */
        cl.next = NULL;
        cl.length = NULL;
        ts.cl = &cl;
  
        len = cl.backend_decl;
Index: gcc/fortran/resolve.c
===================================================================
*** gcc/fortran/resolve.c	(revision 110174)
--- gcc/fortran/resolve.c	(working copy)
*************** static try
*** 1183,1199 ****
  resolve_function (gfc_expr * expr)
  {
    gfc_actual_arglist *arg;
    const char *name;
    try t;
    int temp;
  
    /* If the procedure is not internal or module, it must be external and
       should be checked for usage.  */
!   if (expr->symtree && expr->symtree->n.sym
! 	&& !expr->symtree->n.sym->attr.dummy
! 	&& !expr->symtree->n.sym->attr.contained
! 	&& !expr->symtree->n.sym->attr.use_assoc)
!     resolve_global_procedure (expr->symtree->n.sym, &expr->where, 0);
  
    /* Switch off assumed size checking and do this again for certain kinds
       of procedure, once the procedure itself is resolved.  */
--- 1183,1201 ----
  resolve_function (gfc_expr * expr)
  {
    gfc_actual_arglist *arg;
+   gfc_symbol * sym;
    const char *name;
    try t;
    int temp;
  
+   sym = NULL;
+   if (expr->symtree)
+     sym = expr->symtree->n.sym;
+ 
    /* If the procedure is not internal or module, it must be external and
       should be checked for usage.  */
!   if (sym && !sym->attr.dummy && !sym->attr.contained && !sym->attr.use_assoc)
!     resolve_global_procedure (sym, &expr->where, 0);
  
    /* Switch off assumed size checking and do this again for certain kinds
       of procedure, once the procedure itself is resolved.  */
*************** resolve_function (gfc_expr * expr)
*** 1205,1223 ****
    /* Resume assumed_size checking. */
    need_full_assumed_size--;
  
  /* See if function is already resolved.  */
  
    if (expr->value.function.name != NULL)
      {
        if (expr->ts.type == BT_UNKNOWN)
! 	expr->ts = expr->symtree->n.sym->ts;
        t = SUCCESS;
      }
    else
      {
        /* Apply the rules of section 14.1.2.  */
  
!       switch (procedure_kind (expr->symtree->n.sym))
  	{
  	case PTYPE_GENERIC:
  	  t = resolve_generic_f (expr);
--- 1207,1250 ----
    /* Resume assumed_size checking. */
    need_full_assumed_size--;
  
+   if (sym && sym->ts.type == BT_CHARACTER
+ 	  && sym->ts.cl && sym->ts.cl->length == NULL)
+     {
+       if (sym->attr.if_source == IFSRC_IFBODY)
+ 	{
+ 	  /* This follows from a slightly odd requirement at 5.1.1.5 in the
+ 	     standard that allows assumed character length functions to be
+ 	     declared in interfaces but not used.  Picking up the symbol here,
+ 	     rather than resolve_symbol, accomplishes that.  */
+ 	  gfc_error ("Function '%s' can be declared in an interface to "
+ 		     "return CHARACTER(*) but cannot be used at %L",
+ 		     sym->name, &expr->where);
+ 	  return FAILURE;
+ 	}
+ 
+       /* Internal procedures are taken care of in resolve_contained_fntype.  */
+       if (!sym->attr.dummy && !sym->attr.contained)
+ 	{
+ 	  gfc_error ("Function '%s' is declared CHARACTER(*) and cannot "
+ 		     "be used at %L since it is not a dummy argument",
+ 		     sym->name, &expr->where);
+ 	  return FAILURE;
+ 	}
+     }
+ 
  /* See if function is already resolved.  */
  
    if (expr->value.function.name != NULL)
      {
        if (expr->ts.type == BT_UNKNOWN)
! 	expr->ts = sym->ts;
        t = SUCCESS;
      }
    else
      {
        /* Apply the rules of section 14.1.2.  */
  
!       switch (procedure_kind (sym))
  	{
  	case PTYPE_GENERIC:
  	  t = resolve_generic_f (expr);
*************** resolve_symbol (gfc_symbol * sym)
*** 4861,4866 ****
--- 4888,4922 ----
  	  return;
  	}
  
+       /* 5.1.1.5 of the Standard: A function name declared with an asterisk
+ 	 char-len-param shall not be array-valued, pointer-valued, recursive
+ 	 or pure.  ....snip... A character value of * may only be used in the
+ 	 following ways: (i) Dummy arg of procedure - dummy associates with
+ 	 actual length; (ii) To declare a named constant; or (iii) External
+ 	 function - but length must be declared in calling scoping unit.  */
+       if (sym->attr.function
+ 	    && sym->ts.type == BT_CHARACTER
+ 	    && sym->ts.cl && sym->ts.cl->length == NULL
+ 	    && ((sym->as && sym->as->rank) || (sym->attr.pointer)
+ 		  || (sym->attr.recursive) || (sym->attr.pure)))
+ 	{
+ 	  const char * type;
+ 	  if (sym->as && sym->as->rank)
+ 	    type = "array-valued";
+ 	  else if (sym->attr.pointer)
+ 	    type = "pointer-valued";
+ 	  else if (sym->attr.pure)
+ 	    type = "pure";
+ 	  else if (sym->attr.recursive)
+ 	    type = "recursive";
+ 	  else
+ 	    type = "";
+ 
+ 	  gfc_error ("CHARACTER(*) function '%s' at %L cannot be %s",
+ 		     sym->name, &sym->declared_at, type);
+ 	  return;
+ 	}
+ 
        break;
  
      case FL_DERIVED:

! { dg-do compile }
! Tests the patch for PRs 25084, 20852, 25085 and 25086, all of
! which involve assumed character length functions.
! Compiled from original PR testcases, which were all contributed
! by Joost VandeVondele  <jv244@cam.ac.uk>
!
! PR25084 - the error is not here but in any use of .IN.
! It is OK to define an assumed character length function
! in an interface but it cannot be invoked (5.1.1.5).

MODULE M1
 TYPE  SET
  INTEGER  CARD
 END  TYPE  SET
END MODULE M1

MODULE  INTEGER_SETS
 INTERFACE  OPERATOR  (.IN.)
  FUNCTION ELEMENT(X,A)
     USE M1
     CHARACTER(LEN=*)      :: ELEMENT
     INTEGER, INTENT(IN)   ::  X
     TYPE(SET), INTENT(IN) ::   A
  END FUNCTION ELEMENT
 END  INTERFACE
END MODULE

! 5.1.1.5 of the Standard: A function name declared with an asterisk
! char-len-param shall not be array-valued, pointer-valued, recursive
! or pure
! 
! PR20852
RECURSIVE FUNCTION TEST() ! { dg-error "cannot be recursive" }
 CHARACTER(LEN=*) :: TEST
 TEST = ""
END FUNCTION

!PR25085
FUNCTION F1()             ! { dg-error "cannot be array-valued" }
  CHARACTER(LEN=*), DIMENSION(10) :: F1
  F1 = ""
END FUNCTION F1

!PR25086
FUNCTION F2() result(f4)  ! { dg-error "cannot be pointer-valued" }
  CHARACTER(LEN=*), POINTER  :: f4
  f4 = ""
END FUNCTION F2

!PR?????
pure FUNCTION F3()        ! { dg-error "cannot be pure" }
  CHARACTER(LEN=*)  :: F3
  F3 = ""
END FUNCTION F3

function not_OK (ch)
  character(*) not_OK, ch          ! OK in an external function
  not_OK = ch
end function not_OK

  use INTEGER_SETS
  use m1

  character(4) :: answer
  character(*), external :: not_OK
  integer :: i
  type (set) :: z

  interface
    function ext (i)
      character(*) :: ext
      integer :: i
    end function ext
  end interface

  answer = i.IN.z   ! { dg-error "cannot be used|Operands of user operator" }
  answer = ext (2)  ! { dg-error "but cannot be used" }

  answer = not_OK ("unOK") ! { dg-error "since it is not a dummy" }

END

! { dg-do compile }
! Tests the fix for PR25416, which ICED in gfc_conv_function_call, when
! treating SPREAD in the statement below.
!
! Contributed by Ulrich Weigand  <uweigand@gcc.gnu.org>
function bug(self,strvec) result(res)
  character(*) :: self
  character(*), dimension(:), intent(in) :: strvec
  logical(kind=kind(.true.)) :: res

  res = any(index(strvec,spread(self,1,size(strvec))) /= 0)
end function

! { dg-do compile }
! Tests the patch for PRs 25084, 20852, 25085 and 25086, all of
! which involve assumed character length functions.
! This test checks the things that should not emit errors.
!
! Contributed by Paul Thomas  <pault@gcc.gnu.org>
!
function is_OK (ch)
  character(*) is_OK, ch           ! OK in an external function
  is_OK = ch
end function is_OK

function more_OK (ch, fcn)
  character(*) more_OK, ch
  character (*), external :: fcn   ! OK as a dummy argument
  more_OK = fcn (ch)
end function more_OK

  character(4) :: answer
  character(4), external :: is_OK, more_OK

  answer = is_OK ("isOK")          ! LEN defined in calling scope
  print *, answer

  answer = more_OK ("okay", is_OK) ! Actual arg has defined LEN
  print *, answer

  answer = also_OK ("OKOK")
  print *, answer

contains
  function also_OK (ch)
    character(4) also_OK
    character(*) ch
    also_OK = is_OK (ch)            ! LEN obtained by host association
  end function also_OK
END