re PR fortran/43227 (ICE: segmentation fault in mio_expr)

2010-04-20  Paul Thomas  <pault@gcc.gnu.org>

	PR fortran/43227
	* resolve.c (resolve_fl_derived): If a component character
	length has not been resolved, do so now.
	(resolve_symbol): The same as above for a symbol character
	length.
	* trans-decl.c (gfc_create_module_variable): A 'length' decl is
	not needed for a character valued, procedure pointer.

	PR fortran/43266
	* resolve.c (ensure_not_abstract_walker): If 'overriding' is
	not found, return FAILURE rather than ICEing.

2010-04-20  Paul Thomas  <pault@gcc.gnu.org>

	PR fortran/43227
	* gfortran.dg/proc_decl_23.f90: New test.

	PR fortran/43266
	* gfortran.dg/abstract_type_6.f03: New test.

From-SVN: r158570

gcc/fortran/ChangeLog

+2010-04-20  Paul Thomas  <pault@gcc.gnu.org>
+
+	PR fortran/43227
+	* resolve.c (resolve_fl_derived): If a component character
+	length has not been resolved, do so now.
+	(resolve_symbol): The same as above for a symbol character
+	length.
+	* trans-decl.c (gfc_create_module_variable): A 'length' decl is
+	not needed for a character valued, procedure pointer.
+
+	PR fortran/43266
+	* resolve.c (ensure_not_abstract_walker): If 'overriding' is
+	not found, return FAILURE rather than ICEing.
+
 2010-04-19  Jakub Jelinek  <jakub@redhat.com>
 
 	PR fortran/43339

gcc/fortran/resolve.c

@@ -10617,7 +10617,9 @@ ensure_not_abstract_walker (gfc_symbol* sub, gfc_symtree* st)
     {
       gfc_symtree* overriding;
       overriding = gfc_find_typebound_proc (sub, NULL, st->name, true, NULL);
-      gcc_assert (overriding && overriding->n.tb);
+      if (!overriding)
+	return FAILURE;
+      gcc_assert (overriding->n.tb);
       if (overriding->n.tb->deferred)
 	{
 	  gfc_error ("Derived-type '%s' declared at %L must be ABSTRACT because"
@@ -10784,8 +10786,12 @@ resolve_fl_derived (gfc_symbol *sym)
 	      /* Copy char length.  */
 	      if (ifc->ts.type == BT_CHARACTER && ifc->ts.u.cl)
 		{
-		  c->ts.u.cl = gfc_new_charlen (sym->ns, ifc->ts.u.cl);
-		  gfc_expr_replace_comp (c->ts.u.cl->length, c);
+		  gfc_charlen *cl = gfc_new_charlen (sym->ns, ifc->ts.u.cl);
+		  gfc_expr_replace_comp (cl->length, c);
+		  if (cl->length && !cl->resolved
+		        && gfc_resolve_expr (cl->length) == FAILURE)
+		    return FAILURE;
+		  c->ts.u.cl = cl;
 		}
 	    }
 	  else if (c->ts.interface->name[0] != '\0')
@@ -11298,6 +11304,9 @@ resolve_symbol (gfc_symbol *sym)
 	    {
 	      sym->ts.u.cl = gfc_new_charlen (sym->ns, ifc->ts.u.cl);
 	      gfc_expr_replace_symbols (sym->ts.u.cl->length, sym);
+	      if (sym->ts.u.cl->length && !sym->ts.u.cl->resolved
+		    && gfc_resolve_expr (sym->ts.u.cl->length) == FAILURE)
+		return;
 	    }
 	}
       else if (sym->ts.interface->name[0] != '\0')

gcc/fortran/trans-decl.c

@@ -3477,7 +3477,8 @@ gfc_create_module_variable (gfc_symbol * sym)
       tree length;
 
       length = sym->ts.u.cl->backend_decl;
-      if (!INTEGER_CST_P (length))
+      gcc_assert (length || sym->attr.proc_pointer);
+      if (length && !INTEGER_CST_P (length))
         {
           pushdecl (length);
           rest_of_decl_compilation (length, 1, 0);

gcc/testsuite/ChangeLog

+2010-04-20  Paul Thomas  <pault@gcc.gnu.org>
+
+	PR fortran/43227
+	* gfortran.dg/proc_decl_23.f90: New test.
+
+	PR fortran/43266
+	* gfortran.dg/abstract_type_6.f03: New test.
+
 2010-04-20  Xinliang David Li  <davidxl@google.com>
 
 	* g++.dg/tree-ssa/fold-compare.C: New.

gcc/testsuite/gfortran.dg/abstract_type_6.f03

+! { dg-do "compile" }
+! Test the fix for PR43266, in which an ICE followed correct error messages.
+!
+! Contributed by Tobias Burnus <burnus@gcc.gnu.org>
+! Reported in http://groups.google.ca/group/comp.lang.fortran/browse_thread/thread/f5ec99089ea72b79
+!
+!----------------
+! library code
+
+module m
+TYPE, ABSTRACT :: top
+CONTAINS
+   PROCEDURE(xxx), DEFERRED :: proc_a ! { dg-error "must be a module procedure" }
+   ! some useful default behaviour
+   PROCEDURE :: proc_c => top_c ! { dg-error "must be a module procedure" }
+END TYPE top
+
+! Concrete middle class with useful behaviour
+TYPE, EXTENDS(top) :: middle
+CONTAINS
+   ! do nothing, empty proc just to make middle concrete
+   PROCEDURE :: proc_a => dummy_middle_a ! { dg-error "must be a module procedure" }
+   ! some useful default behaviour
+   PROCEDURE :: proc_b => middle_b ! { dg-error "must be a module procedure" }
+END TYPE middle
+
+!----------------
+! client code
+
+TYPE, EXTENDS(middle) :: bottom
+CONTAINS
+   ! useful proc to satisfy deferred procedure in top. Because we've
+   ! extended middle we wouldn't get told off if we forgot this.
+   PROCEDURE :: proc_a => bottom_a
+   ! calls middle%proc_b and then provides extra behaviour
+   PROCEDURE :: proc_b => bottom_b
+   ! calls top_c and then provides extra behaviour
+   PROCEDURE :: proc_c => bottom_c
+END TYPE bottom
+contains
+SUBROUTINE bottom_b(obj)
+   CLASS(Bottom) :: obj
+   CALL obj%middle%proc_b ! { dg-error "should be a SUBROUTINE" }
+   ! other stuff
+END SUBROUTINE bottom_b
+
+SUBROUTINE bottom_c(obj)
+   CLASS(Bottom) :: obj
+   CALL top_c(obj)
+   ! other stuff
+END SUBROUTINE bottom_c 
+end module
+! { dg-final { cleanup-modules "m" } }

gcc/testsuite/gfortran.dg/proc_decl_23.f90

+! { dg-do compile }
+! Test the fix for PR43227, in which the lines below would segfault.
+!
+! Dominique d'Humieres <dominiq@lps.ens.fr>
+!
+function char1 (s) result(res)
+  character, dimension(:), intent(in) :: s
+  character(len=size(s)) :: res
+  do i = 1, size(s)
+    res(i:i) = s(i)
+  end do
+end function char1
+
+module m_string
+
+  procedure(string_to_char) :: char1                    ! segfault
+  procedure(string_to_char), pointer :: char2           ! segfault
+  type t_string
+    procedure(string_to_char), pointer, nopass :: char3 ! segfault
+  end type t_string
+
+contains
+
+  function string_to_char (s) result(res)
+    character, dimension(:), intent(in) :: s
+    character(len=size(s)) :: res
+    do i = 1, size(s)
+      res(i:i) = s(i)
+    end do
+  end function string_to_char
+
+end module m_string
+
+  use m_string
+  type(t_string) :: t
+  print *, string_to_char (["a","b","c"])
+  char2 => string_to_char
+  print *, char2 (["d","e","f"])
+  t%char3 => string_to_char
+  print *, t%char3 (["g","h","i"])
+  print *, char1 (["j","k","l"])
+end
+! { dg-final { cleanup-tree-dump "m_string" } }