------- Additional Comments From tobi at gcc dot gnu dot org 2005-03-15 23:35
-------
This is a patch, which fixes the problem. I'm not submitting it, because the
error location it prints for Andrew's variation of the bug's theme is unusable,
also I've not yet convinced myself that there are cases where different orders
of calls to resolve_charlen with second argument 0 or 1 can make a difference, I
don't believe so, though. Feel free to extend, I have very little time these
days, so I can't guarantee I'll finish this for a while.
2005-03-16 Tobias Schl"uter <[EMAIL PROTECTED]>
PR fortran/18990
* gfortran.h (gfc_charlen): New field 'resolved'.
* expr.c (gfc_specification_expr): return early for NULL argument.
* resolve.c (resolve_derived, resolve_charlen): New function.
(resolve_symbol): Call 'resolve_derived'.
(gfc_resolve): Resolve charlens via new function.
Index: gfortran.h
===================================================================
RCS file: /cvs/gcc/gcc/gcc/fortran/gfortran.h,v
retrieving revision 1.60
diff -u -p -r1.60 gfortran.h
--- gfortran.h 12 Mar 2005 02:06:20 -0000 1.60
+++ gfortran.h 15 Mar 2005 23:28:54 -0000
@@ -510,6 +510,8 @@ typedef struct gfc_charlen
struct gfc_expr *length;
struct gfc_charlen *next;
tree backend_decl;
+
+ int resolved;
}
gfc_charlen;
Index: expr.c
===================================================================
RCS file: /cvs/gcc/gcc/gcc/fortran/expr.c,v
retrieving revision 1.24
diff -u -p -r1.24 expr.c
--- expr.c 4 Mar 2005 17:09:18 -0000 1.24
+++ expr.c 15 Mar 2005 23:28:55 -0000
@@ -1689,6 +1689,8 @@ check_restricted (gfc_expr * e)
try
gfc_specification_expr (gfc_expr * e)
{
+ if (e == NULL)
+ return SUCCESS;
if (e->ts.type != BT_INTEGER)
{
Index: resolve.c
===================================================================
RCS file: /cvs/gcc/gcc/gcc/fortran/resolve.c,v
retrieving revision 1.37
diff -u -p -r1.37 resolve.c
--- resolve.c 13 Mar 2005 18:46:34 -0000 1.37
+++ resolve.c 15 Mar 2005 23:28:56 -0000
@@ -3916,6 +3916,60 @@ 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, int const_flag)
+{
+ 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;
+
+ if (const_flag && cl->length == NULL)
+ {
+ gfc_error ("Character length in program unit ending at %C needs to "
+ "be a constant specification expression.");
+ return FAILURE;
+ }
+ else if (const_flag && !gfc_is_constant_expr (cl->length))
+ {
+ gfc_error ("Character length at %L needs to be a constant "
+ "specification expression.", &cl->length->where);
+ 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
+ && resolve_charlen (c->ts.cl, 1) == FAILURE)
+ 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. */
@@ -3942,6 +3996,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
@@ -4713,8 +4770,8 @@ resolve_equivalence (gfc_equiv *eq)
}
}
}
-
-
+
+
/* This function is called after a complete program unit has been compiled.
Its purpose is to examine all of the expressions associated with a program
unit, assign types to all intermediate expressions, make sure that all
@@ -4752,16 +4809,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, 0);
gfc_traverse_ns (ns, resolve_values);
--
http://gcc.gnu.org/bugzilla/show_bug.cgi?id=18990
