re PR fortran/31154 (IMPORT fails for "<imported symbol> FUNCTION (...)" kind of procedures)

2007-10-02  Paul Thomas  <pault@gcc.gnu.org>

	PR fortran/31154
	PR fortran/31229
	PR fortran/33334
	* decl.c : Declare gfc_function_kind_locs and
	gfc_function_type_locus.
	(gfc_match_kind_spec): Add second argument kind_expr_only.
	Store locus before trying to match the expression. If the
	current state corresponds to a function declaration and there
	is no match to the expression, read to the parenthesis, return
	kind = -1, dump the expression and return.
	(gfc_match_type_spec): Renamed from match_type_spec and all
	references changed.  If an interface or an external function,
	store the locus, set kind = -1 and return.  Otherwise, if kind
	is already = -1, use gfc_find_symbol to try to find a use
	associated or imported type.
	match.h : Prototype for gfc_match_type_spec.
	* parse.c (match_deferred_characteristics): New function.
	(parse_spec): If in a function, statement is USE or IMPORT
	or DERIVED_DECL and the function kind=-1, call
	match_deferred_characteristics.  If kind=-1 at the end of the
	specification expressions, this is an error.
	* parse.h : Declare external gfc_function_kind_locs and
	gfc_function_type_locus.

2007-10-02  Paul Thomas  <pault@gcc.gnu.org>

	PR fortran/31154
	PR fortran/31229
	PR fortran/33334
	* gfortran.dg/function_kinds_1.f90: New test.
	* gfortran.dg/function_kinds_2.f90: New test.
	* gfortran.dg/derived_function_interface_1.f90: Correct illegal
	use association into interfaces.

From-SVN: r128948

10 files changed, 300 insertions, 22 deletions

diff --git a/gcc/fortran/ChangeLog b/gcc/fortran/ChangeLog
index 3f18b8e..d6ae6dc 100644
--- a/gcc/fortran/ChangeLog
+++ b/gcc/fortran/ChangeLog
@@ -1,3 +1,29 @@
+2007-10-02  Paul Thomas  <pault@gcc.gnu.org>
+
+	PR fortran/31154
+	PR fortran/31229
+	PR fortran/33334
+	* decl.c : Declare gfc_function_kind_locs and
+	gfc_function_type_locus.
+	(gfc_match_kind_spec): Add second argument kind_expr_only.
+	Store locus before trying to match the expression. If the
+	current state corresponds to a function declaration and there
+	is no match to the expression, read to the parenthesis, return
+	kind = -1, dump the expression and return.
+	(gfc_match_type_spec): Renamed from match_type_spec and all
+	references changed.  If an interface or an external function,
+	store the locus, set kind = -1 and return.  Otherwise, if kind
+	is already = -1, use gfc_find_symbol to try to find a use
+	associated or imported type.
+	match.h : Prototype for gfc_match_type_spec.
+	* parse.c (match_deferred_characteristics): New function.
+	(parse_spec): If in a function, statement is USE or IMPORT
+	or DERIVED_DECL and the function kind=-1, call
+	match_deferred_characteristics.  If kind=-1 at the end of the
+	specification expressions, this is an error.
+	* parse.h : Declare external gfc_function_kind_locs and
+	gfc_function_type_locus.
+
 2007-09-27  Kaveh R. Ghazi  <ghazi@caip.rutgers.edu>
 
 	* module.c (mio_expr): Avoid -Wcast-qual warning.
diff --git a/gcc/fortran/decl.c b/gcc/fortran/decl.c
index 7fa8548..e25389f 100644
--- a/gcc/fortran/decl.c
+++ b/gcc/fortran/decl.c
@@ -78,6 +78,9 @@ static enumerator_history *max_enum = NULL;
 
 gfc_symbol *gfc_new_block;
 
+locus gfc_function_kind_locus;
+locus gfc_function_type_locus;
+
 
 /********************* DATA statement subroutines *********************/
 
@@ -1762,17 +1765,21 @@ gfc_match_old_kind_spec (gfc_typespec *ts)
    string is found, then we know we have an error.  */
 
 match
-gfc_match_kind_spec (gfc_typespec *ts)
+gfc_match_kind_spec (gfc_typespec *ts, bool kind_expr_only)
 {
-  locus where;
+  locus where, loc;
   gfc_expr *e;
   match m, n;
   const char *msg;
 
   m = MATCH_NO;
+  n = MATCH_YES;
   e = NULL;
 
-  where = gfc_current_locus;
+  where = loc = gfc_current_locus;
+
+  if (kind_expr_only)
+    goto kind_expr;
 
   if (gfc_match_char ('(') == MATCH_NO)
     return MATCH_NO;
@@ -1781,11 +1788,42 @@ gfc_match_kind_spec (gfc_typespec *ts)
   if (gfc_match (" kind = ") == MATCH_YES)
     m = MATCH_ERROR;
 
+  loc = gfc_current_locus;
+
+kind_expr:
   n = gfc_match_init_expr (&e);
-  if (n == MATCH_NO)
-    gfc_error ("Expected initialization expression at %C");
+
   if (n != MATCH_YES)
-    return MATCH_ERROR;
+    {
+      if (gfc_current_state () == COMP_INTERFACE
+            || gfc_current_state () == COMP_NONE
+            || gfc_current_state () == COMP_CONTAINS)
+	{
+	  /* Signal using kind = -1 that the expression might include
+	     use associated or imported parameters and try again after
+	     the specification expressions.....  */
+	  if (gfc_match_char (')') != MATCH_YES)
+	    {
+	      gfc_error ("Missing right parenthesis at %C");
+	      m = MATCH_ERROR;
+	      goto no_match;
+	    }
+
+	  gfc_free_expr (e);
+	  ts->kind = -1;
+	  gfc_function_kind_locus = loc;
+	  gfc_undo_symbols ();
+	  return MATCH_YES;
+	}
+      else
+	{
+	  /* ....or else, the match is real.  */
+	  if (n == MATCH_NO)
+	    gfc_error ("Expected initialization expression at %C");
+	  if (n != MATCH_YES)
+	    return MATCH_ERROR;
+	}
+    }
 
   if (e->rank != 0)
     {
@@ -1826,7 +1864,7 @@ gfc_match_kind_spec (gfc_typespec *ts)
   else if (gfc_match_char (')') != MATCH_YES)
     {
       gfc_error ("Missing right parenthesis at %C");
-     m = MATCH_ERROR;
+      m = MATCH_ERROR;
     }
   else
      /* All tests passed.  */
@@ -2033,13 +2071,14 @@ done:
    kind specification.  Not doing so is needed for matching an IMPLICIT
    statement correctly.  */
 
-static match
-match_type_spec (gfc_typespec *ts, int implicit_flag)
+match
+gfc_match_type_spec (gfc_typespec *ts, int implicit_flag)
 {
   char name[GFC_MAX_SYMBOL_LEN + 1];
   gfc_symbol *sym;
   match m;
   int c;
+  locus loc = gfc_current_locus;
 
   gfc_clear_ts (ts);
 
@@ -2123,12 +2162,34 @@ match_type_spec (gfc_typespec *ts, int implicit_flag)
   if (m != MATCH_YES)
     return m;
 
-  /* Search for the name but allow the components to be defined later.  */
-  if (gfc_get_ha_symbol (name, &sym))
+  if (gfc_current_state () == COMP_INTERFACE
+	|| gfc_current_state () == COMP_NONE)
+    {
+      gfc_function_type_locus = loc;
+      ts->type = BT_UNKNOWN;
+      ts->kind = -1;
+      return MATCH_YES;
+    }
+
+  /* Search for the name but allow the components to be defined later.  If
+     type = -1, this typespec has been seen in a function declaration but
+     the type could not legally be accessed at that point.  */
+  if (ts->kind != -1 && gfc_get_ha_symbol (name, &sym))
     {
       gfc_error ("Type name '%s' at %C is ambiguous", name);
       return MATCH_ERROR;
     }
+  else if (ts->kind == -1)
+    {
+      if (gfc_find_symbol (name, NULL, 0, &sym))
+	{       
+	  gfc_error ("Type name '%s' at %C is ambiguous", name);
+	  return MATCH_ERROR;
+	}
+
+      if (sym == NULL)
+	return MATCH_NO;
+    }
 
   if (sym->attr.flavor != FL_DERIVED
       && gfc_add_flavor (&sym->attr, FL_DERIVED, sym->name, NULL) == FAILURE)
@@ -2154,7 +2215,7 @@ get_kind:
        return MATCH_NO;
     }
 
-  m = gfc_match_kind_spec (ts);
+  m = gfc_match_kind_spec (ts, false);
   if (m == MATCH_NO && ts->type != BT_CHARACTER)
     m = gfc_match_old_kind_spec (ts);
 
@@ -2301,7 +2362,7 @@ gfc_match_implicit (void)
       gfc_clear_new_implicit ();
 
       /* A basic type is mandatory here.  */
-      m = match_type_spec (&ts, 1);
+      m = gfc_match_type_spec (&ts, 1);
       if (m == MATCH_ERROR)
 	goto error;
       if (m == MATCH_NO)
@@ -2344,7 +2405,7 @@ gfc_match_implicit (void)
 	m = match_char_spec (&ts);
       else
 	{
-	  m = gfc_match_kind_spec (&ts);
+	  m = gfc_match_kind_spec (&ts, false);
 	  if (m == MATCH_NO)
 	    {
 	      m = gfc_match_old_kind_spec (&ts);
@@ -3390,7 +3451,7 @@ gfc_match_data_decl (void)
 
   num_idents_on_line = 0;
   
-  m = match_type_spec (&current_ts, 0);
+  m = gfc_match_type_spec (&current_ts, 0);
   if (m != MATCH_YES)
     return m;
 
@@ -3492,7 +3553,7 @@ match_prefix (gfc_typespec *ts)
 
 loop:
   if (!seen_type && ts != NULL
-      && match_type_spec (ts, 0) == MATCH_YES
+      && gfc_match_type_spec (ts, 0) == MATCH_YES
       && gfc_match_space () == MATCH_YES)
     {
 
@@ -3798,7 +3859,7 @@ match_procedure_decl (void)
 
   /* Get the type spec. for the procedure interface.  */
   old_loc = gfc_current_locus;
-  m = match_type_spec (&current_ts, 0);
+  m = gfc_match_type_spec (&current_ts, 0);
   if (m == MATCH_YES || (m == MATCH_NO && gfc_peek_char () == ')'))
     goto got_ts;
 
diff --git a/gcc/fortran/match.h b/gcc/fortran/match.h
index 4841f33..f9d6aea 100644
--- a/gcc/fortran/match.h
+++ b/gcc/fortran/match.h
@@ -127,8 +127,9 @@ match gfc_match_omp_end_single (void);
 
 match gfc_match_data (void);
 match gfc_match_null (gfc_expr **);
-match gfc_match_kind_spec (gfc_typespec *);
+match gfc_match_kind_spec (gfc_typespec *, bool);
 match gfc_match_old_kind_spec (gfc_typespec *);
+match gfc_match_type_spec (gfc_typespec *, int);
 
 match gfc_match_end (gfc_statement *);
 match gfc_match_data_decl (void);
diff --git a/gcc/fortran/parse.c b/gcc/fortran/parse.c
index a6672f4..86e486c 100644
--- a/gcc/fortran/parse.c
+++ b/gcc/fortran/parse.c
@@ -1866,6 +1866,35 @@ done:
 }
 
 
+/* Recover use associated or imported function characteristics.  */
+
+static try
+match_deferred_characteristics (gfc_typespec * ts)
+{
+  locus loc;
+  match m;
+
+  loc = gfc_current_locus;
+
+  if (gfc_current_block ()->ts.type != BT_UNKNOWN)
+    {
+      /* Kind expression for an intrinsic type.  */
+      gfc_current_locus = gfc_function_kind_locus;
+      m = gfc_match_kind_spec (ts, true);
+    }
+  else
+    {
+      /* A derived type.  */
+      gfc_current_locus = gfc_function_type_locus;
+      m = gfc_match_type_spec (ts, 0);
+    }
+
+  gfc_current_ns->proc_name->result->ts = *ts;
+  gfc_current_locus =loc;
+  return m;
+}
+
+
 /* Parse a set of specification statements.  Returns the statement
    that doesn't fit.  */
 
@@ -1951,6 +1980,15 @@ loop:
 	}
 
       accept_statement (st);
+
+      /* Look out for function kind/type information that used
+	 use associated or imported parameter.  This is signalled
+	 by kind = -1.  */
+      if (gfc_current_state () == COMP_FUNCTION
+	    && (st == ST_USE || st == ST_IMPORT || st == ST_DERIVED_DECL)
+	    && gfc_current_block ()->ts.kind == -1)
+	match_deferred_characteristics (&gfc_current_block ()->ts);
+
       st = next_statement ();
       goto loop;
 
@@ -1964,6 +2002,19 @@ loop:
       break;
     }
 
+  /* If we still have kind = -1 at the end of the specification block,
+     then there is an error. */
+  if (gfc_current_state () == COMP_FUNCTION
+	&& gfc_current_block ()->ts.kind == -1)
+    {
+      if (gfc_current_block ()->ts.type != BT_UNKNOWN)
+	gfc_error ("Bad kind expression for function '%s' at %L",
+		   gfc_current_block ()->name, &gfc_function_kind_locus);
+      else
+	gfc_error ("The type for function '%s' at %L is not accessible",
+		   gfc_current_block ()->name, &gfc_function_type_locus);
+    }
+
   return st;
 }
 
diff --git a/gcc/fortran/parse.h b/gcc/fortran/parse.h
index 92806ba..307d59a 100644
--- a/gcc/fortran/parse.h
+++ b/gcc/fortran/parse.h
@@ -66,5 +66,7 @@ const char *gfc_ascii_statement (gfc_statement);
 match gfc_match_enum (void);
 match gfc_match_enumerator_def (void);
 void gfc_free_enum_history (void);
+extern locus gfc_function_kind_locus;
+extern locus gfc_function_type_locus;
 
 #endif  /* GFC_PARSE_H  */
diff --git a/gcc/testsuite/ChangeLog b/gcc/testsuite/ChangeLog
index 308826e..1cc26f8 100644
--- a/gcc/testsuite/ChangeLog
+++ b/gcc/testsuite/ChangeLog
@@ -1,3 +1,13 @@
+2007-10-02  Paul Thomas  <pault@gcc.gnu.org>
+
+	PR fortran/31154
+	PR fortran/31229
+	PR fortran/33334
+	* gfortran.dg/function_kinds_1.f90: New test.
+	* gfortran.dg/function_kinds_2.f90: New test.
+	* gfortran.dg/derived_function_interface_1.f90: Correct illegal
+	use association into interfaces.
+
 2007-10-01  John David Anglin  <dave.anglin@nrc-cnrc.gc.ca>
 
 	PR testsuite/31828
diff --git a/gcc/testsuite/gfortran.dg/derived_function_interface_1.f90 b/gcc/testsuite/gfortran.dg/derived_function_interface_1.f90
index 88acbb7..a9e4041 100644
--- a/gcc/testsuite/gfortran.dg/derived_function_interface_1.f90
+++ b/gcc/testsuite/gfortran.dg/derived_function_interface_1.f90
@@ -6,24 +6,28 @@
 !
 ! Contributed by Francois-Xavier Coudert  <fxcoudert@gcc.gnu.org>
 !
-type(foo) function ext_fun()
+module kinds
   type foo
     integer :: i
   end type foo
+end module
+
+type(foo) function ext_fun()
+  use kinds
   ext_fun%i = 1
 end function ext_fun
 
-  type foo
-    integer :: i
-  end type foo
+  use kinds
 
   interface fun_interface
     type(foo) function fun()
+      use kinds
     end function fun
   end interface
 
   interface ext_fun_interface
     type(foo) function ext_fun()
+      use kinds
     end function ext_fun
   end interface
 
@@ -38,3 +42,4 @@ contains
   end function fun  ! { dg-error "Expecting END PROGRAM" }
 
 end ! { dg-warning "CONTAINS statement without FUNCTION or SUBROUTINE statement" }
+! { dg-final { cleanup-modules "kinds" } }
diff --git a/gcc/testsuite/gfortran.dg/function_kinds_1.f90 b/gcc/testsuite/gfortran.dg/function_kinds_1.f90
new file mode 100644
index 0000000..f0140df
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/function_kinds_1.f90
@@ -0,0 +1,54 @@
+! { dg-do run }
+! Tests the fix for PR31229, PR31154 and PR33334, in which
+! the KIND and TYPE parameters in the function declarations
+! would cause errors.
+!
+! Contributed by Brooks Moses <brooks@gcc.gnu.org>
+!           and Tobias Burnus <burnus@gcc.gnu.org>
+!
+module kinds
+  implicit none
+  integer, parameter :: dp = selected_real_kind(6)
+  type t
+     integer :: i
+  end type t
+  interface
+    real(dp) function y()
+      import
+    end function
+  end interface
+end module kinds
+
+type(t) function func() ! The legal bit of PR33334
+  use kinds
+  func%i = 5
+end function func
+
+real(dp) function another_dp_before_defined ()
+  use kinds
+  another_dp_before_defined = real (kind (4.0_DP))
+end function
+
+module mymodule;
+contains
+  REAL(2*DP) function declared_dp_before_defined()
+    use kinds, only: dp
+    real (dp) :: x
+    declared_dp_before_defined = 1.0_dp
+    x = 1.0_dp
+    declared_dp_before_defined = real (kind (x))
+  end function
+end module mymodule
+
+  use kinds
+  use mymodule
+  type(t), external :: func
+  type(t) :: z
+  if (kind (y ()) .ne. 4) call abort ()
+  if (kind (declared_dp_before_defined ()) .ne. 8) call abort ()
+  if (int (declared_dp_before_defined ()) .ne. 4) call abort ()
+  if (int (another_dp_before_defined ()) .ne. 4) call abort ()
+  z = func()
+  if (z%i .ne. 5) call abort ()
+end
+! { dg-final { cleanup-modules "kinds mymodule" } }
diff --git a/gcc/testsuite/gfortran.dg/function_kinds_2.f90 b/gcc/testsuite/gfortran.dg/function_kinds_2.f90
new file mode 100644
index 0000000..f14453d
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/function_kinds_2.f90
@@ -0,0 +1,21 @@
+! Tests the fix for PR33334, in which the TYPE in the function
+! declaration cannot be legally accessed.
+!
+! Contributed by Tobias Burnus <burnus@gcc.gnu.org>
+!
+module types
+ implicit none
+ type t
+   integer :: i = 99
+ end type t
+end module
+
+module x
+ use types
+ interface
+   type(t) function bar() ! { dg-error "is not accessible" }
+   end function
+ end interface
+end module
+! { dg-final { cleanup-modules "types x" } }
+
diff --git a/gcc/testsuite/gfortran.dg/intent_out_2.f90 b/gcc/testsuite/gfortran.dg/intent_out_2.f90
new file mode 100644
index 0000000..0fad1b8
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/intent_out_2.f90
@@ -0,0 +1,47 @@
+! { dg-do -run }

+! Tests the fix for PR33554, in which the default initialization
+! of temp, in construct_temp, caused a segfault because it was
+! being done before the array offset and lower bound were
+! available.
+!
+! Contributed by Harald Anlauf <anlauf@gmx.de> 
+!

+module gfcbug72

+  implicit none

+

+  type t_datum

+    character(len=8) :: mn = 'abcdefgh'

+  end type t_datum

+

+  type t_temp

+    type(t_datum) :: p

+  end type t_temp

+

+contains

+

+  subroutine setup ()

+    integer :: i

+    type (t_temp), pointer :: temp(:) => NULL ()

+

+    do i=1,2

+       allocate (temp (2))

+       call construct_temp (temp)

+       if (any (temp % p% mn .ne. 'ijklmnop')) call abort ()

+       deallocate (temp)

+    end do

+  end subroutine setup

+  !--

+  subroutine construct_temp (temp)

+    type (t_temp), intent(out) :: temp (:)

+    if (any (temp % p% mn .ne. 'abcdefgh')) call abort ()

+    temp(:)% p% mn = 'ijklmnop'

+  end subroutine construct_temp

+end module gfcbug72

+

+program test

+  use gfcbug72

+  implicit none

+  call setup ()

+end program test

+! { dg-final { cleanup-modules "gfcbug72" } }
+