[gfortran] Fix PR18990: Non-constant charlens in derived types

[Tobias Schlüter <tobias dot schlueter at physik dot uni-muenchen dot de>]

This relatively straightforward patch fixes cases where we would allow
non-constant character lengths in derived types and then ice when trying to
make sense of this.

This patch works by 1) splitting out the resolving of character lengths into a
function of its own adding code to avoid the re-resolving of already resolved
gfc_charlens, 2) going through derived types and resolving their components
declarations, which currently means looking at their contingent character
lengths, and 3) preparing gfc_specification_expr for the NULL arguments it
will see in the case of assumed length characters.

I slightly shuffled the code from an incarantion of this patch Paul T already
approved off-list, so in order to give him a chance to glance over the final
version, I'll hold off committing this to the mainline until tomorrow evening,
and will not commit this to 4.1 before the 24th.  Paul, I split out the
special cases which were previously guarded by const_flag both in order to
make the function's interface easier and to make the error message more
expressive, apart from that it's the patch from the PR.  Thanks for bringing
it back to my attention.

A new testcase follows below, built and tested on i686-pc-linux.

Cheers, and merry christmas to all who care,
- Tobi

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.

Index: resolve.c
===================================================================
--- resolve.c   (revision 108900)
+++ resolve.c   (working copy)
@@ -4200,6 +4200,59 @@ resolve_values (gfc_symbol * sym)
 }


+/* Resolve a charlen structure.  If CONST_FLAG is set, require its length to
+   be a constant specification expression.  */
+
+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;
+}
+
+
+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.  */
@@ -4252,6 +4305,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
@@ -5449,16 +5505,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);

Index: gfortran.h
===================================================================
--- gfortran.h  (revision 108900)
+++ gfortran.h  (working copy)
@@ -571,6 +571,8 @@ typedef struct gfc_charlen
   struct gfc_expr *length;
   struct gfc_charlen *next;
   tree backend_decl;
+
+  int resolved;
 }
 gfc_charlen;

Index: expr.c
===================================================================
--- expr.c      (revision 108900)
+++ expr.c      (working copy)
@@ -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)
     {


! { 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