[PATCH] Fix ICE on functions with no explicit nor implicit type (PR fortran/21729)

[Jakub Jelinek <jakub at redhat dot com>]

Hi!

This patch fixes an ICE on invalid code where an explicit type
is not given to a FUNCTION, IMPLICIT NONE is used and the return
value is not set in the function.  Then, only gfc_set_default_type (sym, 0,
NULL) was called on the function symbol, so no error was given and
it ICEd later on in gfc_typenode_for_spec.
Ok for HEAD/4.0?

2005-05-24  Jakub Jelinek  <jakub@redhat.com>

	PR fortran/21729
	* resolve.c (resolve_contained_fntype): Use sym->attr.untyped
	to avoid giving error multiple times.
	(resolve_entries): Don't error about BT_UNKNOWN here.
	(resolve_unknown_f): Capitalize IMPLICIT for consistency.
	(gfc_resolve): Issue error if function or its entries have
	no explicit nor implicit type.

	* gfortran.dg/implicit_5.f90: New test.

--- gcc/fortran/resolve.c.jj	2005-05-16 09:45:03.000000000 +0200
+++ gcc/fortran/resolve.c	2005-05-24 23:06:18.000000000 +0200
@@ -267,9 +267,12 @@ resolve_contained_fntype (gfc_symbol * s
     {
       t = gfc_set_default_type (sym, 0, ns);
 
-      if (t == FAILURE)
-	gfc_error ("Contained function '%s' at %L has no IMPLICIT type",
-		    sym->name, &sym->declared_at); /* FIXME */
+      if (t == FAILURE && !sym->attr.untyped)
+	{
+	  gfc_error ("Contained function '%s' at %L has no IMPLICIT type",
+		     sym->name, &sym->declared_at); /* FIXME */
+	  sym->attr.untyped = 1;
+	}
     }
 }
 
@@ -439,6 +442,10 @@ resolve_entries (gfc_namespace * ns)
 		      if (ts->kind == gfc_default_logical_kind)
 			sym = NULL;
 		      break;
+		    case BT_UNKNOWN:
+		      /* We will issue error elsewhere.  */
+		      sym = NULL;
+		      break;
 		    default:
 		      break;
 		    }
@@ -957,7 +964,7 @@ set_type:
 
       if (ts->type == BT_UNKNOWN)
 	{
-	  gfc_error ("Function '%s' at %L has no implicit type",
+	  gfc_error ("Function '%s' at %L has no IMPLICIT type",
 		     sym->name, &expr->where);
 	  return FAILURE;
 	}
@@ -4835,6 +4842,39 @@ gfc_resolve (gfc_namespace * ns)
 
   gfc_traverse_ns (ns, resolve_symbol);
 
+  if (ns->proc_name && ns->proc_name->attr.function)
+    {
+      gfc_entry_list *el;
+      gfc_symbol *sym;
+
+      if (ns->entries)
+	sym = ns->entries->sym;
+      else
+	sym = ns->proc_name;
+      if (sym->result == sym
+	  && sym->ts.type == BT_UNKNOWN
+	  && gfc_set_default_type (sym, 0, NULL) == FAILURE
+	  && !sym->attr.untyped)
+	{
+	  gfc_error ("Function '%s' at %L has no IMPLICIT type",
+		     sym->name, &sym->declared_at);
+	  sym->attr.untyped = 1;
+	}
+      if (ns->entries)
+	for (el = ns->entries->next; el; el = el->next)
+	  {
+	    if (el->sym->result == el->sym
+		&& el->sym->ts.type == BT_UNKNOWN
+		&& gfc_set_default_type (el->sym, 0, NULL) == FAILURE
+		&& !el->sym->attr.untyped)
+	      {
+		gfc_error ("ENTRY '%s' at %L has no IMPLICIT type",
+			   el->sym->name, &el->sym->declared_at);
+		el->sym->attr.untyped = 1;
+	      }
+	  }
+    }
+
   for (n = ns->contained; n; n = n->sibling)
     {
       if (gfc_pure (ns->proc_name) && !gfc_pure (n->proc_name))
--- gcc/testsuite/gfortran.dg/implicit_5.f90.jj	2005-05-24 22:59:49.000000000 +0200
+++ gcc/testsuite/gfortran.dg/implicit_5.f90	2005-05-24 23:22:46.000000000 +0200
@@ -0,0 +1,22 @@
+! PR fortran/21729
+! { dg-do compile }
+function f1 ()	! { dg-error "has no IMPLICIT type" "f1" }
+	implicit none
+end function f1
+function f2 () result (r2) ! { dg-error "has no IMPLICIT type" "r2" }
+	implicit none
+end function f2
+function f3 ()	! { dg-error "has no IMPLICIT type" "f3" }
+	implicit none
+entry e3 ()	! { dg-error "has no IMPLICIT type" "e3" }
+end function f3
+function f4 ()
+	implicit none
+	real f4
+entry e4 ()	! { dg-error "has no IMPLICIT type" "e4" }
+end function f4
+function f5 ()	! { dg-error "has no IMPLICIT type" "f5" }
+	implicit none
+entry e5 ()
+	real e5
+end function f5

	Jakub