re PR fortran/18990 (ICE in gfc_get_derived_type, at fortran/trans-types.c)

fortran/
	PR fortran/18990
	* gfortran.h (gfc_charlen): Add resolved field.
	* expr.c (gfc_specification_expr): Accept NULL argument.
	* resolve.c (gfc_resolve_charlen, gfc_resolve_derived): New.
	(gfc_resolve_symbol): Resolve derived type definitions.  Use
	resolve_charlen to resolve character lengths.
testsuite/
	PR fortran/18990
	* gfortran.dg/der_charlen_1.f90: New.

From-SVN: r108946

gcc/fortran/ChangeLog

@@ -1,3 +1,12 @@
+2005-12-22  Tobias Schl"uter  <tobias.schlueter@physik.uni-muenchen.de>
+
+	PR fortran/18990
+	* gfortran.h (gfc_charlen): Add resolved field.
+	* expr.c (gfc_specification_expr): Accept NULL argument.
+	* resolve.c (gfc_resolve_charlen, gfc_resolve_derived): New.
+	(gfc_resolve_symbol): Resolve derived type definitions.  Use
+	resolve_charlen to resolve character lengths.
+
 2005-12-22  Paul Thomas  <pault@gcc.gnu.org>
 
 	PR fortran/20889

gcc/fortran/expr.c

@@ -1768,6 +1768,8 @@ check_restricted (gfc_expr * e)
 try
 gfc_specification_expr (gfc_expr * e)
 {
+  if (e == NULL)
+    return SUCCESS;
 
   if (e->ts.type != BT_INTEGER)
     {

gcc/fortran/gfortran.h

@@ -571,6 +571,8 @@ typedef struct gfc_charlen
   struct gfc_expr *length;
   struct gfc_charlen *next;
   tree backend_decl;
+
+  int resolved;
 }
 gfc_charlen;
 

gcc/fortran/resolve.c

@@ -4328,6 +4328,60 @@ resolve_values (gfc_symbol * sym)
 }
 
 
+/* Resolve a charlen structure.  */
+
+static try
+resolve_charlen (gfc_charlen *cl)
+{
+  if (cl->resolved)
+    return SUCCESS;
+
+  cl->resolved = 1;
+
+  if (gfc_resolve_expr (cl->length) == FAILURE)
+    return FAILURE;
+
+  if (gfc_simplify_expr (cl->length, 0) == FAILURE)
+    return FAILURE;
+
+  if (gfc_specification_expr (cl->length) == FAILURE)
+    return FAILURE;
+
+  return SUCCESS;
+}
+
+
+/* Resolve the components of a derived type.  */
+
+static try
+resolve_derived (gfc_symbol *sym)
+{
+  gfc_component *c;
+
+  for (c = sym->components; c != NULL; c = c->next)
+    {
+      if (c->ts.type == BT_CHARACTER)
+	{
+         if (resolve_charlen (c->ts.cl) == FAILURE)
+	   return FAILURE;
+	 
+	 if (c->ts.cl->length == NULL
+	     || !gfc_is_constant_expr (c->ts.cl->length))
+	   {
+	     gfc_error ("Character length of component '%s' needs to "
+			"be a constant specification expression at %L.",
+			c->name,
+			c->ts.cl->length ? &c->ts.cl->length->where : &c->loc);
+	     return FAILURE;
+	   }
+	}
+
+      /* TODO: Anything else that should be done here?  */
+    }
+
+  return SUCCESS;
+}
+
 /* Do anything necessary to resolve a symbol.  Right now, we just
    assume that an otherwise unknown symbol is a variable.  This sort
    of thing commonly happens for symbols in module.  */
@@ -4380,6 +4434,9 @@ resolve_symbol (gfc_symbol * sym)
 	}
     }
 
+  if (sym->attr.flavor == FL_DERIVED && resolve_derived (sym) == FAILURE)
+    return;
+
   /* Symbols that are module procedures with results (functions) have
      the types and array specification copied for type checking in
      procedures that call them, as well as for saving to a module
@@ -5588,16 +5645,7 @@ gfc_resolve (gfc_namespace * ns)
   gfc_check_interfaces (ns);
 
   for (cl = ns->cl_list; cl; cl = cl->next)
-    {
-      if (cl->length == NULL || gfc_resolve_expr (cl->length) == FAILURE)
-	continue;
-
-      if (gfc_simplify_expr (cl->length, 0) == FAILURE)
-	continue;
-
-      if (gfc_specification_expr (cl->length) == FAILURE)
-	continue;
-    }
+    resolve_charlen (cl);
 
   gfc_traverse_ns (ns, resolve_values);
 

gcc/testsuite/ChangeLog

@@ -1,3 +1,8 @@
+2005-12-22  Tobias Schl"uter  <tobias.schlueter@physik.uni-muenchen.de>
+
+	PR fortran/18990
+	* gfortran.dg/der_charlen_1.f90: New.
+
 2005-12-22  Paul Thomas  <pault@gcc.gnu.org>
 
 	PR fortran/20889

gcc/testsuite/gfortran.dg/der_charlen_1.f90

@@ -0,0 +1,24 @@
+! { dg-do compile }
+! PR 18990
+! we used to ICE on these examples
+module core
+  type, public  :: T
+     character(len=I)  :: str ! { dg-error "needs to be a constant specification expression" }
+  end type T
+  private
+CONTAINS
+  subroutine FOO(X)
+    type(T), intent(in)          :: X
+  end subroutine
+end module core
+
+module another_core
+  type :: T
+     character(len=*)  :: s ! { dg-error "needs to be a constant specification expr" }
+  end type T
+  private
+CONTAINS
+  subroutine FOO(X)
+    type(T), intent(in)          :: X
+  end subroutine
+end module another_core