[Patch, fortran] PR34429 - Fails: character(len=use_associated_const) function foo()

["Paul Richard Thomas" <paul dot richard dot thomas at gmail dot com>]

:ADDPATCH fortran:

This patch is not strictly speaking a regression but it does fix a
rather important rejects invalid and, strictly speaking, it fixes a
wrong code bug.  Tobias and I are agreed that it can and should go
into 4.3.0.

It turns out that there was an error in the treatment of function
characteristics: Character functions were being matched at the end of
the specification block, rather than  after all the USE and IMPORT
statements.  The result was that various ad-hoc kludges had to be
used.  These have been put right in this patch and, as far as I can
tell, all legal function declarations now work.

Regtested on Cygwin_NT/amd64 - will bootstrap and regtest tonight on x86_ia64.

OK for trunk?

Paul

2008-01-30  Paul Thomas  <pault@gcc.gnu.org>

	PR fortran/34429
	* decl.c (match_char_spec): Remove the constraint on deferred
	matching of functions and free the length expression.
	delete_symtree to gfc_delete_symtree.
	(gfc_match_type_spec): Whitespace.
	(gfc_match_function_decl): Defer characteristic association for
	all types except BT_UNKNOWN.
	* parse.c (decode_specification_statement): Only derived type
	function matching is delayed to the end of specification.

2008-01-30  Paul Thomas  <pault@gcc.gnu.org>

	PR fortran/34429
	* gfortran.dg/function_charlen_2.f90: New test.

Index: gcc/fortran/decl.c
===================================================================
*** gcc/fortran/decl.c	(revision 131741)
--- gcc/fortran/decl.c	(working copy)
*************** syntax:
*** 2151,2163 ****
    return m;
  
  done:
!   /* Except in the case of the length being a function, where symbol
!      association looks after itself, deal with character functions
!      after the specification statements.  */
!   if (gfc_matching_function
! 	&& !(len && len->expr_type != EXPR_VARIABLE
! 		 && len->expr_type != EXPR_OP))
      {
        gfc_undo_symbols ();
        return MATCH_YES;
      }
--- 2151,2160 ----
    return m;
  
  done:
!   /* Deal with character functions after USE and IMPORT statements.  */
!   if (gfc_matching_function)
      {
+       gfc_free_expr (len);
        gfc_undo_symbols ();
        return MATCH_YES;
      }
*************** gfc_match_type_spec (gfc_typespec *ts, i
*** 2222,2229 ****
    /* A belt and braces check that the typespec is correctly being treated
       as a deferred characteristic association.  */
    seen_deferred_kind = (gfc_current_state () == COMP_FUNCTION)
! 					&& (gfc_current_block ()->result->ts.kind == -1)
! 					&& (ts->kind == -1);
    gfc_clear_ts (ts);
    if (seen_deferred_kind)
      ts->kind = -1;
--- 2219,2226 ----
    /* A belt and braces check that the typespec is correctly being treated
       as a deferred characteristic association.  */
    seen_deferred_kind = (gfc_current_state () == COMP_FUNCTION)
! 			  && (gfc_current_block ()->result->ts.kind == -1)
! 			  && (ts->kind == -1);
    gfc_clear_ts (ts);
    if (seen_deferred_kind)
      ts->kind = -1;
*************** gfc_match_function_decl (void)
*** 4358,4378 ****
  	  goto cleanup;
  	}
  
!       /* Except in the case of a function valued character length,
! 	 delay matching the function characteristics until after the
  	 specification block by signalling kind=-1.  */
!       if (!(current_ts.type == BT_CHARACTER
! 	      && current_ts.cl
! 	      && current_ts.cl->length
! 	      && current_ts.cl->length->expr_type != EXPR_OP
! 	      && current_ts.cl->length->expr_type != EXPR_VARIABLE))
! 	{
! 	  sym->declared_at = old_loc;
! 	  if (current_ts.type != BT_UNKNOWN)
! 	    current_ts.kind = -1;
! 	  else
! 	    current_ts.kind = 0;
! 	}
  
        if (result == NULL)
  	{
--- 4355,4367 ----
  	  goto cleanup;
  	}
  
!       /* Delay matching the function characteristics until after the
  	 specification block by signalling kind=-1.  */
!       sym->declared_at = old_loc;
!       if (current_ts.type != BT_UNKNOWN)
! 	current_ts.kind = -1;
!       else
! 	current_ts.kind = 0;
  
        if (result == NULL)
  	{
Index: gcc/fortran/parse.c
===================================================================
*** gcc/fortran/parse.c	(revision 131741)
--- gcc/fortran/parse.c	(working copy)
*************** decode_specification_statement (void)
*** 110,116 ****
    match ("import", gfc_match_import, ST_IMPORT);
    match ("use", gfc_match_use, ST_USE);
  
!   if (gfc_numeric_ts (&gfc_current_block ()->ts))
      goto end_of_block;
  
    match (NULL, gfc_match_st_function, ST_STATEMENT_FUNCTION);
--- 110,116 ----
    match ("import", gfc_match_import, ST_IMPORT);
    match ("use", gfc_match_use, ST_USE);
  
!   if (gfc_current_block ()->ts.type != BT_DERIVED)
      goto end_of_block;
  
    match (NULL, gfc_match_st_function, ST_STATEMENT_FUNCTION);
Index: gcc/testsuite/gfortran.dg/function_charlen_2.f90
===================================================================
*** gcc/testsuite/gfortran.dg/function_charlen_2.f90	(revision 0)
--- gcc/testsuite/gfortran.dg/function_charlen_2.f90	(revision 0)
***************
*** 0 ****
--- 1,31 ----
+ ! { dg-do compile }
+ ! Tests the fix for PR34429 in which function charlens that were
+ ! USE associated would cause an error.
+ !
+ ! Contributed by Tobias Burnus <burnus@gcc.gnu.org>
+ !
+ module m
+   integer, parameter :: l = 2
+   character(2) :: cl
+ end module m
+ 
+ program test
+   implicit none
+   integer, parameter :: l = 5
+   character(len = 10) :: c
+   character(4) :: cl
+   c = f ()
+   if (g () /= "2") call abort
+ contains
+   character(len = l) function f ()
+     use m
+     if (len (f) /= 2) call abort
+     f = "a"
+   end function f
+   character(len = len (cl)) function g ()
+     use m
+     g = "4"
+     if (len (g) == 2) g= "2"
+   end function g
+ end program test
+ ! { dg-final { cleanup-modules "m" } }