This is the mail archive of the
gcc-patches@gcc.gnu.org
mailing list for the GCC project.
[gomp merge] Fortran FE changes from gomp branch not dependent on OpenMP
- From: Jakub Jelinek <jakub at redhat dot com>
- To: gcc-patches at gcc dot gnu dot org, fortran at gcc dot gnu dot org
- Date: Tue, 17 Jan 2006 03:48:32 -0500
- Subject: [gomp merge] Fortran FE changes from gomp branch not dependent on OpenMP
- Reply-to: Jakub Jelinek <jakub at redhat dot com>
Hi!
This patch contains changes from gomp branch that don't rely on
OpenMP framework, two comment typos and code to make sure array times have
complete types whenever possible. For details, you can see:
http://gcc.gnu.org/ml/gcc-patches/2005-10/msg01299.html
http://gcc.gnu.org/ml/gcc-patches/2005-11/msg00361.html
http://gcc.gnu.org/ml/gcc-patches/2005-11/msg00447.html
http://gcc.gnu.org/ml/gcc-patches/2005-12/msg00332.html
Bootstrapped/regtested on i686-linux, ok for trunk?
2006-01-17 Jakub Jelinek <jakub@redhat.com>
Backport from gomp-20050608-branch
* trans-decl.c (gfc_get_symbol_decl): Revert explicit setting of
TYPE_SIZE_UNIT.
(gfc_trans_vla_type_sizes): Also "gimplify"
GFC_TYPE_ARRAY_DATAPTR_TYPE for GFC_DESCRIPTOR_TYPE_P types.
* trans-array.c (gfc_trans_deferred_array): Call
gfc_trans_vla_type_sizes.
* trans-decl.c (saved_function_decls, saved_parent_function_decls):
Remove unnecessary initialization.
(create_function_arglist): Make sure __result has complete type.
(gfc_get_fake_result_decl): Change current_fake_result_decl into
a tree chain. For entry master, create a separate variable
for each result name. For BT_CHARACTER results, call
gfc_finish_var_decl on length even if it has been already created,
but not pushdecl'ed.
(gfc_trans_vla_type_sizes): For function/entry result, adjust
result value type, not the FUNCTION_TYPE.
(gfc_generate_function_code): Adjust for current_fake_result_decl
changes.
(gfc_trans_deferred_vars): Likewise. Call gfc_trans_vla_type_sizes
even on result if it is assumed-length character.
* trans-decl.c (gfc_trans_dummy_character): Add SYM argument.
Call gfc_trans_vla_type_sizes.
(gfc_trans_auto_character_variable): Call gfc_trans_vla_type_sizes.
(gfc_trans_vla_one_sizepos, gfc_trans_vla_type_sizes_1,
gfc_trans_vla_type_sizes): New functions.
(gfc_trans_deferred_vars): Adjust gfc_trans_dummy_character
callers. Call gfc_trans_vla_type_sizes on assumed-length
character parameters.
* trans-array.c (gfc_trans_array_bounds,
gfc_trans_auto_array_allocation, gfc_trans_dummy_array_bias): Call
gfc_trans_vla_type_sizes.
* trans.h (gfc_trans_vla_type_sizes): New prototype.
* trans-decl.c (gfc_build_qualified_array): For non-assumed-size
arrays without constant size, create also an index var for
GFC_TYPE_ARRAY_SIZE (type). If the type is incomplete, complete
it as 0..size-1.
(gfc_create_string_length): Don't call gfc_defer_symbol_init
if just creating DECL_ARGUMENTS.
(gfc_get_symbol_decl): Call gfc_finish_var_decl and
gfc_defer_symbol_init even if ts.cl->backend_decl is already
set to a VAR_DECL that doesn't have DECL_CONTEXT yet.
(create_function_arglist): Rework, so that hidden length
arguments for CHARACTER parameters are created together with
the parameters. Resolve ts.cl->backend_decl for CHARACTER
parameters. If the argument is a non-constant length array
or CHARACTER, ensure PARM_DECL has different type than
its DECL_ARG_TYPE.
(generate_local_decl): Call gfc_get_symbol_decl even
for non-referenced non-constant length CHARACTER parameters
after optionally issuing warnings.
* trans-array.c (gfc_trans_array_bounds): Set last stride
to GFC_TYPE_ARRAY_SIZE (type) to initialize it as well.
(gfc_trans_dummy_array_bias): Initialize GFC_TYPE_ARRAY_SIZE (type)
variable as well.
* trans-expr.c (gfc_conv_expr_val): Fix comment typo.
* trans-stmt.c (gfc_trans_simple_do): Fix comment.
--- gcc/fortran/trans-stmt.c.jj 2006-01-16 10:59:37.000000000 +0100
+++ gcc/fortran/trans-stmt.c 2006-01-16 16:45:06.000000000 +0100
@@ -697,7 +697,7 @@ gfc_trans_simple_do (gfc_code * code, st
to:
[evaluate loop bounds and step]
- count = to + step - from;
+ count = (to + step - from) / step;
dovar = from;
for (;;)
{
--- gcc/fortran/trans-array.c.jj 2006-01-16 10:59:37.000000000 +0100
+++ gcc/fortran/trans-array.c 2006-01-16 16:45:06.000000000 +0100
@@ -3254,7 +3254,7 @@ gfc_trans_array_bounds (tree type, gfc_s
if (dim + 1 < as->rank)
stride = GFC_TYPE_ARRAY_STRIDE (type, dim + 1);
else
- stride = NULL_TREE;
+ stride = GFC_TYPE_ARRAY_SIZE (type);
if (ubound != NULL_TREE && !(stride && INTEGER_CST_P (stride)))
{
@@ -3272,6 +3272,8 @@ gfc_trans_array_bounds (tree type, gfc_s
size = stride;
}
+ gfc_trans_vla_type_sizes (sym, pblock);
+
*poffset = offset;
return size;
}
@@ -3308,6 +3310,8 @@ gfc_trans_auto_array_allocation (tree de
{
gfc_trans_init_string_length (sym->ts.cl, &block);
+ gfc_trans_vla_type_sizes (sym, &block);
+
/* Emit a DECL_EXPR for this variable, which will cause the
gimplifier to allocate storage, and all that good stuff. */
tmp = build1 (DECL_EXPR, TREE_TYPE (decl), decl);
@@ -3660,12 +3664,30 @@ gfc_trans_dummy_array_bias (gfc_symbol *
gfc_add_modify_expr (&block, stride, tmp);
}
}
+ else
+ {
+ stride = GFC_TYPE_ARRAY_SIZE (type);
+
+ if (stride && !INTEGER_CST_P (stride))
+ {
+ /* Calculate size = stride * (ubound + 1 - lbound). */
+ tmp = fold_build2 (MINUS_EXPR, gfc_array_index_type,
+ gfc_index_one_node, lbound);
+ tmp = fold_build2 (PLUS_EXPR, gfc_array_index_type,
+ ubound, tmp);
+ tmp = fold_build2 (MULT_EXPR, gfc_array_index_type,
+ GFC_TYPE_ARRAY_STRIDE (type, n), tmp);
+ gfc_add_modify_expr (&block, stride, tmp);
+ }
+ }
}
/* Set the offset. */
if (TREE_CODE (GFC_TYPE_ARRAY_OFFSET (type)) == VAR_DECL)
gfc_add_modify_expr (&block, GFC_TYPE_ARRAY_OFFSET (type), offset);
+ gfc_trans_vla_type_sizes (sym, &block);
+
stmt = gfc_finish_block (&block);
gfc_start_block (&block);
@@ -4267,7 +4289,10 @@ gfc_trans_deferred_array (gfc_symbol * s
if (sym->ts.type == BT_CHARACTER
&& !INTEGER_CST_P (sym->ts.cl->backend_decl))
- gfc_trans_init_string_length (sym->ts.cl, &fnblock);
+ {
+ gfc_trans_init_string_length (sym->ts.cl, &fnblock);
+ gfc_trans_vla_type_sizes (sym, &fnblock);
+ }
/* Dummy and use associated variables don't need anything special. */
if (sym->attr.dummy || sym->attr.use_assoc)
--- gcc/fortran/trans-decl.c.jj 2006-01-16 10:59:37.000000000 +0100
+++ gcc/fortran/trans-decl.c 2006-01-16 17:26:25.000000000 +0100
@@ -54,8 +54,8 @@ static GTY(()) tree current_function_ret
/* Holds the variable DECLs for the current function. */
-static GTY(()) tree saved_function_decls = NULL_TREE;
-static GTY(()) tree saved_parent_function_decls = NULL_TREE;
+static GTY(()) tree saved_function_decls;
+static GTY(()) tree saved_parent_function_decls;
/* The namespace of the module we're currently generating. Only used while
@@ -613,6 +613,30 @@ gfc_build_qualified_array (tree decl, gf
else
gfc_add_decl_to_function (GFC_TYPE_ARRAY_OFFSET (type));
}
+
+ if (GFC_TYPE_ARRAY_SIZE (type) == NULL_TREE
+ && sym->as->type != AS_ASSUMED_SIZE)
+ GFC_TYPE_ARRAY_SIZE (type) = create_index_var ("size", nest);
+
+ if (POINTER_TYPE_P (type))
+ {
+ gcc_assert (GFC_ARRAY_TYPE_P (TREE_TYPE (type)));
+ gcc_assert (TYPE_LANG_SPECIFIC (type)
+ == TYPE_LANG_SPECIFIC (TREE_TYPE (type)));
+ type = TREE_TYPE (type);
+ }
+
+ if (! COMPLETE_TYPE_P (type) && GFC_TYPE_ARRAY_SIZE (type))
+ {
+ tree size, range;
+
+ size = build2 (MINUS_EXPR, gfc_array_index_type,
+ GFC_TYPE_ARRAY_SIZE (type), gfc_index_one_node);
+ range = build_range_type (gfc_array_index_type, gfc_index_zero_node,
+ size);
+ TYPE_DOMAIN (type) = range;
+ layout_type (type);
+ }
}
@@ -761,7 +785,8 @@ gfc_create_string_length (gfc_symbol * s
gfc_charlen_type_node);
DECL_ARTIFICIAL (length) = 1;
TREE_USED (length) = 1;
- gfc_defer_symbol_init (sym);
+ if (sym->ns->proc_name->tlink != NULL)
+ gfc_defer_symbol_init (sym);
sym->ts.cl->backend_decl = length;
}
@@ -809,9 +834,7 @@ tree
gfc_get_symbol_decl (gfc_symbol * sym)
{
tree decl;
- tree etype = NULL_TREE;
tree length = NULL_TREE;
- tree tmp = NULL_TREE;
int byref;
gcc_assert (sym->attr.referenced);
@@ -842,28 +865,14 @@ gfc_get_symbol_decl (gfc_symbol * sym)
if (sym->ts.type == BT_CHARACTER)
{
if (sym->ts.cl->backend_decl == NULL_TREE)
+ length = gfc_create_string_length (sym);
+ else
+ length = sym->ts.cl->backend_decl;
+ if (TREE_CODE (length) == VAR_DECL
+ && DECL_CONTEXT (length) == NULL_TREE)
{
- length = gfc_create_string_length (sym);
- if (TREE_CODE (length) != INTEGER_CST)
- {
- gfc_finish_var_decl (length, sym);
- gfc_defer_symbol_init (sym);
- }
- }
-
- /* Set the element size of automatic and assumed character length
- length, dummy, pointer arrays. */
- if (sym->attr.pointer && sym->attr.dummy
- && sym->attr.dimension)
- {
- tmp = build_fold_indirect_ref (sym->backend_decl);
- etype = gfc_get_element_type (TREE_TYPE (tmp));
- if (TYPE_SIZE_UNIT (etype) == NULL_TREE)
- {
- tmp = TYPE_SIZE_UNIT (gfc_character1_type_node);
- tmp = fold_convert (TREE_TYPE (tmp), sym->ts.cl->backend_decl);
- TYPE_SIZE_UNIT (etype) = tmp;
- }
+ gfc_finish_var_decl (length, sym);
+ gfc_defer_symbol_init (sym);
}
}
@@ -1240,9 +1249,8 @@ create_function_arglist (gfc_symbol * sy
{
tree fndecl;
gfc_formal_arglist *f;
- tree typelist;
- tree arglist;
- tree length;
+ tree typelist, hidden_typelist;
+ tree arglist, hidden_arglist;
tree type;
tree parm;
@@ -1251,6 +1259,7 @@ create_function_arglist (gfc_symbol * sy
/* Build formal argument list. Make sure that their TREE_CONTEXT is
the new FUNCTION_DECL node. */
arglist = NULL_TREE;
+ hidden_arglist = NULL_TREE;
typelist = TYPE_ARG_TYPES (TREE_TYPE (fndecl));
if (sym->attr.entry_master)
@@ -1269,131 +1278,178 @@ create_function_arglist (gfc_symbol * sy
if (gfc_return_by_reference (sym))
{
- type = TREE_VALUE (typelist);
- parm = build_decl (PARM_DECL, get_identifier ("__result"), type);
-
- DECL_CONTEXT (parm) = fndecl;
- DECL_ARG_TYPE (parm) = type;
- TREE_READONLY (parm) = 1;
- DECL_ARTIFICIAL (parm) = 1;
- gfc_finish_decl (parm, NULL_TREE);
-
- arglist = chainon (arglist, parm);
- typelist = TREE_CHAIN (typelist);
+ tree type = TREE_VALUE (typelist), length = NULL;
if (sym->ts.type == BT_CHARACTER)
{
- gfc_allocate_lang_decl (parm);
-
/* Length of character result. */
- type = TREE_VALUE (typelist);
- gcc_assert (type == gfc_charlen_type_node);
+ tree len_type = TREE_VALUE (TREE_CHAIN (typelist));
+ gcc_assert (len_type == gfc_charlen_type_node);
length = build_decl (PARM_DECL,
get_identifier (".__result"),
- type);
+ len_type);
if (!sym->ts.cl->length)
{
sym->ts.cl->backend_decl = length;
TREE_USED (length) = 1;
}
gcc_assert (TREE_CODE (length) == PARM_DECL);
- arglist = chainon (arglist, length);
- typelist = TREE_CHAIN (typelist);
DECL_CONTEXT (length) = fndecl;
- DECL_ARG_TYPE (length) = type;
+ DECL_ARG_TYPE (length) = len_type;
TREE_READONLY (length) = 1;
DECL_ARTIFICIAL (length) = 1;
gfc_finish_decl (length, NULL_TREE);
- }
- }
-
- for (f = sym->formal; f; f = f->next)
- {
- if (f->sym != NULL) /* ignore alternate returns. */
- {
- length = NULL_TREE;
+ if (sym->ts.cl->backend_decl == NULL
+ || sym->ts.cl->backend_decl == length)
+ {
+ gfc_symbol *arg;
+ tree backend_decl;
- type = TREE_VALUE (typelist);
+ if (sym->ts.cl->backend_decl == NULL)
+ {
+ tree len = build_decl (VAR_DECL,
+ get_identifier ("..__result"),
+ gfc_charlen_type_node);
+ DECL_ARTIFICIAL (len) = 1;
+ TREE_USED (len) = 1;
+ sym->ts.cl->backend_decl = len;
+ }
- /* Build a the argument declaration. */
- parm = build_decl (PARM_DECL,
- gfc_sym_identifier (f->sym), type);
+ /* Make sure PARM_DECL type doesn't point to incomplete type. */
+ arg = sym->result ? sym->result : sym;
+ backend_decl = arg->backend_decl;
+ /* Temporary clear it, so that gfc_sym_type creates complete
+ type. */
+ arg->backend_decl = NULL;
+ type = gfc_sym_type (arg);
+ arg->backend_decl = backend_decl;
+ type = build_reference_type (type);
+ }
+ }
- /* Fill in arg stuff. */
- DECL_CONTEXT (parm) = fndecl;
- DECL_ARG_TYPE (parm) = type;
- /* All implementation args are read-only. */
- TREE_READONLY (parm) = 1;
+ parm = build_decl (PARM_DECL, get_identifier ("__result"), type);
- gfc_finish_decl (parm, NULL_TREE);
+ DECL_CONTEXT (parm) = fndecl;
+ DECL_ARG_TYPE (parm) = TREE_VALUE (typelist);
+ TREE_READONLY (parm) = 1;
+ DECL_ARTIFICIAL (parm) = 1;
+ gfc_finish_decl (parm, NULL_TREE);
- f->sym->backend_decl = parm;
+ arglist = chainon (arglist, parm);
+ typelist = TREE_CHAIN (typelist);
- arglist = chainon (arglist, parm);
+ if (sym->ts.type == BT_CHARACTER)
+ {
+ gfc_allocate_lang_decl (parm);
+ arglist = chainon (arglist, length);
typelist = TREE_CHAIN (typelist);
}
}
- /* Add the hidden string length parameters. */
- parm = arglist;
+ hidden_typelist = typelist;
+ for (f = sym->formal; f; f = f->next)
+ if (f->sym != NULL) /* Ignore alternate returns. */
+ hidden_typelist = TREE_CHAIN (hidden_typelist);
+
for (f = sym->formal; f; f = f->next)
{
char name[GFC_MAX_SYMBOL_LEN + 2];
+
/* Ignore alternate returns. */
if (f->sym == NULL)
continue;
- if (f->sym->ts.type != BT_CHARACTER)
- continue;
-
- parm = f->sym->backend_decl;
type = TREE_VALUE (typelist);
- gcc_assert (type == gfc_charlen_type_node);
- strcpy (&name[1], f->sym->name);
- name[0] = '_';
- length = build_decl (PARM_DECL, get_identifier (name), type);
+ if (f->sym->ts.type == BT_CHARACTER)
+ {
+ tree len_type = TREE_VALUE (hidden_typelist);
+ tree length = NULL_TREE;
+ gcc_assert (len_type == gfc_charlen_type_node);
- arglist = chainon (arglist, length);
- DECL_CONTEXT (length) = fndecl;
- DECL_ARTIFICIAL (length) = 1;
- DECL_ARG_TYPE (length) = type;
- TREE_READONLY (length) = 1;
- gfc_finish_decl (length, NULL_TREE);
-
- /* TODO: Check string lengths when -fbounds-check. */
-
- /* Use the passed value for assumed length variables. */
- if (!f->sym->ts.cl->length)
- {
- TREE_USED (length) = 1;
- if (!f->sym->ts.cl->backend_decl)
- f->sym->ts.cl->backend_decl = length;
- else
+ strcpy (&name[1], f->sym->name);
+ name[0] = '_';
+ length = build_decl (PARM_DECL, get_identifier (name), len_type);
+
+ hidden_arglist = chainon (hidden_arglist, length);
+ DECL_CONTEXT (length) = fndecl;
+ DECL_ARTIFICIAL (length) = 1;
+ DECL_ARG_TYPE (length) = len_type;
+ TREE_READONLY (length) = 1;
+ gfc_finish_decl (length, NULL_TREE);
+
+ /* TODO: Check string lengths when -fbounds-check. */
+
+ /* Use the passed value for assumed length variables. */
+ if (!f->sym->ts.cl->length)
{
- /* there is already another variable using this
- gfc_charlen node, build a new one for this variable
- and chain it into the list of gfc_charlens.
- This happens for e.g. in the case
- CHARACTER(*)::c1,c2
- since CHARACTER declarations on the same line share
- the same gfc_charlen node. */
- gfc_charlen *cl;
+ TREE_USED (length) = 1;
+ if (!f->sym->ts.cl->backend_decl)
+ f->sym->ts.cl->backend_decl = length;
+ else
+ {
+ /* there is already another variable using this
+ gfc_charlen node, build a new one for this variable
+ and chain it into the list of gfc_charlens.
+ This happens for e.g. in the case
+ CHARACTER(*)::c1,c2
+ since CHARACTER declarations on the same line share
+ the same gfc_charlen node. */
+ gfc_charlen *cl;
- cl = gfc_get_charlen ();
- cl->backend_decl = length;
- cl->next = f->sym->ts.cl->next;
- f->sym->ts.cl->next = cl;
- f->sym->ts.cl = cl;
+ cl = gfc_get_charlen ();
+ cl->backend_decl = length;
+ cl->next = f->sym->ts.cl->next;
+ f->sym->ts.cl->next = cl;
+ f->sym->ts.cl = cl;
+ }
+ }
+
+ hidden_typelist = TREE_CHAIN (hidden_typelist);
+
+ if (f->sym->ts.cl->backend_decl == NULL
+ || f->sym->ts.cl->backend_decl == length)
+ {
+ if (f->sym->ts.cl->backend_decl == NULL)
+ gfc_create_string_length (f->sym);
+
+ /* Make sure PARM_DECL type doesn't point to incomplete type. */
+ type = gfc_sym_type (f->sym);
}
}
- parm = TREE_CHAIN (parm);
+ /* For non-constant length array arguments, make sure they use
+ a different type node from TYPE_ARG_TYPES type. */
+ if (f->sym->attr.dimension
+ && type == TREE_VALUE (typelist)
+ && TREE_CODE (type) == POINTER_TYPE
+ && GFC_ARRAY_TYPE_P (type)
+ && f->sym->as->type != AS_ASSUMED_SIZE
+ && ! COMPLETE_TYPE_P (TREE_TYPE (type)))
+ type = gfc_sym_type (f->sym);
+
+ /* Build a the argument declaration. */
+ parm = build_decl (PARM_DECL, gfc_sym_identifier (f->sym), type);
+
+ /* Fill in arg stuff. */
+ DECL_CONTEXT (parm) = fndecl;
+ DECL_ARG_TYPE (parm) = TREE_VALUE (typelist);
+ /* All implementation args are read-only. */
+ TREE_READONLY (parm) = 1;
+
+ gfc_finish_decl (parm, NULL_TREE);
+
+ f->sym->backend_decl = parm;
+
+ arglist = chainon (arglist, parm);
typelist = TREE_CHAIN (typelist);
}
- gcc_assert (TREE_VALUE (typelist) == void_type_node);
+ /* Add the hidden string length parameters. */
+ arglist = chainon (arglist, hidden_arglist);
+
+ gcc_assert (TREE_VALUE (hidden_typelist) == void_type_node);
DECL_ARGUMENTS (fndecl) = arglist;
}
@@ -1657,18 +1713,24 @@ gfc_create_function_decl (gfc_namespace
tree
gfc_get_fake_result_decl (gfc_symbol * sym)
{
- tree decl;
- tree length;
+ tree decl, length;
char name[GFC_MAX_SYMBOL_LEN + 10];
if (sym
&& sym->ns->proc_name->backend_decl == current_function_decl
- && sym->ns->proc_name->attr.mixed_entry_master
+ && sym->ns->proc_name->attr.entry_master
&& sym != sym->ns->proc_name)
{
+ tree t = NULL, var;
+ if (current_fake_result_decl != NULL)
+ for (t = TREE_CHAIN (current_fake_result_decl); t; t = TREE_CHAIN (t))
+ if (strcmp (IDENTIFIER_POINTER (TREE_PURPOSE (t)), sym->name) == 0)
+ break;
+ if (t)
+ return TREE_VALUE (t);
decl = gfc_get_fake_result_decl (sym->ns->proc_name);
- if (decl)
+ if (decl && sym->ns->proc_name->attr.mixed_entry_master)
{
tree field;
@@ -1682,22 +1744,32 @@ gfc_get_fake_result_decl (gfc_symbol * s
decl = build3 (COMPONENT_REF, TREE_TYPE (field), decl, field,
NULL_TREE);
}
- return decl;
+ var = gfc_create_var (TREE_TYPE (decl), sym->name);
+ SET_DECL_VALUE_EXPR (var, decl);
+ DECL_HAS_VALUE_EXPR_P (var) = 1;
+ TREE_CHAIN (current_fake_result_decl)
+ = tree_cons (get_identifier (sym->name), var,
+ TREE_CHAIN (current_fake_result_decl));
+ return var;
}
if (current_fake_result_decl != NULL_TREE)
- return current_fake_result_decl;
+ return TREE_VALUE (current_fake_result_decl);
/* Only when gfc_get_fake_result_decl is called by gfc_trans_return,
sym is NULL. */
if (!sym)
return NULL_TREE;
- if (sym->ts.type == BT_CHARACTER
- && !sym->ts.cl->backend_decl)
+ if (sym->ts.type == BT_CHARACTER)
{
- length = gfc_create_string_length (sym);
- gfc_finish_var_decl (length, sym);
+ if (sym->ts.cl->backend_decl == NULL_TREE)
+ length = gfc_create_string_length (sym);
+ else
+ length = sym->ts.cl->backend_decl;
+ if (TREE_CODE (length) == VAR_DECL
+ && DECL_CONTEXT (length) == NULL_TREE)
+ gfc_finish_var_decl (length, sym);
}
if (gfc_return_by_reference (sym))
@@ -1730,7 +1802,7 @@ gfc_get_fake_result_decl (gfc_symbol * s
gfc_add_decl_to_function (decl);
}
- current_fake_result_decl = decl;
+ current_fake_result_decl = build_tree_list (NULL, decl);
return decl;
}
@@ -2173,7 +2245,7 @@ gfc_build_builtin_function_decls (void)
/* Evaluate the length of dummy character variables. */
static tree
-gfc_trans_dummy_character (gfc_charlen * cl, tree fnbody)
+gfc_trans_dummy_character (gfc_symbol *sym, gfc_charlen *cl, tree fnbody)
{
stmtblock_t body;
@@ -2183,7 +2255,9 @@ gfc_trans_dummy_character (gfc_charlen *
/* Evaluate the string length expression. */
gfc_trans_init_string_length (cl, &body);
-
+
+ gfc_trans_vla_type_sizes (sym, &body);
+
gfc_add_expr_to_block (&body, fnbody);
return gfc_finish_block (&body);
}
@@ -2206,6 +2280,8 @@ gfc_trans_auto_character_variable (gfc_s
/* Evaluate the string length expression. */
gfc_trans_init_string_length (sym->ts.cl, &body);
+ gfc_trans_vla_type_sizes (sym, &body);
+
decl = sym->backend_decl;
/* Emit a DECL_EXPR for this variable, which will cause the
@@ -2236,6 +2312,112 @@ gfc_trans_assign_aux_var (gfc_symbol * s
return gfc_finish_block (&body);
}
+static void
+gfc_trans_vla_one_sizepos (tree *tp, stmtblock_t *body)
+{
+ tree t = *tp, var, val;
+
+ if (t == NULL || t == error_mark_node)
+ return;
+ if (TREE_CONSTANT (t) || DECL_P (t))
+ return;
+
+ if (TREE_CODE (t) == SAVE_EXPR)
+ {
+ if (SAVE_EXPR_RESOLVED_P (t))
+ {
+ *tp = TREE_OPERAND (t, 0);
+ return;
+ }
+ val = TREE_OPERAND (t, 0);
+ }
+ else
+ val = t;
+
+ var = gfc_create_var_np (TREE_TYPE (t), NULL);
+ gfc_add_decl_to_function (var);
+ gfc_add_modify_expr (body, var, val);
+ if (TREE_CODE (t) == SAVE_EXPR)
+ TREE_OPERAND (t, 0) = var;
+ *tp = var;
+}
+
+static void
+gfc_trans_vla_type_sizes_1 (tree type, stmtblock_t *body)
+{
+ tree t;
+
+ if (type == NULL || type == error_mark_node)
+ return;
+
+ type = TYPE_MAIN_VARIANT (type);
+
+ if (TREE_CODE (type) == INTEGER_TYPE)
+ {
+ gfc_trans_vla_one_sizepos (&TYPE_MIN_VALUE (type), body);
+ gfc_trans_vla_one_sizepos (&TYPE_MAX_VALUE (type), body);
+
+ for (t = TYPE_NEXT_VARIANT (type); t; t = TYPE_NEXT_VARIANT (t))
+ {
+ TYPE_MIN_VALUE (t) = TYPE_MIN_VALUE (type);
+ TYPE_MAX_VALUE (t) = TYPE_MAX_VALUE (type);
+ }
+ }
+ else if (TREE_CODE (type) == ARRAY_TYPE)
+ {
+ gfc_trans_vla_type_sizes_1 (TREE_TYPE (type), body);
+ gfc_trans_vla_type_sizes_1 (TYPE_DOMAIN (type), body);
+ gfc_trans_vla_one_sizepos (&TYPE_SIZE (type), body);
+ gfc_trans_vla_one_sizepos (&TYPE_SIZE_UNIT (type), body);
+
+ for (t = TYPE_NEXT_VARIANT (type); t; t = TYPE_NEXT_VARIANT (t))
+ {
+ TYPE_SIZE (t) = TYPE_SIZE (type);
+ TYPE_SIZE_UNIT (t) = TYPE_SIZE_UNIT (type);
+ }
+ }
+}
+
+/* Make sure all type sizes and array domains are either constant,
+ or variable or parameter decls. This is a simplified variant
+ of gimplify_type_sizes, but we can't use it here, as none of the
+ variables in the expressions have been gimplified yet.
+ As type sizes and domains for various variable length arrays
+ contain VAR_DECLs that are only initialized at gfc_trans_deferred_vars
+ time, without this routine gimplify_type_sizes in the middle-end
+ could result in the type sizes being gimplified earlier than where
+ those variables are initialized. */
+
+void
+gfc_trans_vla_type_sizes (gfc_symbol *sym, stmtblock_t *body)
+{
+ tree type = TREE_TYPE (sym->backend_decl);
+
+ if (TREE_CODE (type) == FUNCTION_TYPE
+ && (sym->attr.function || sym->attr.result || sym->attr.entry))
+ {
+ if (! current_fake_result_decl)
+ return;
+
+ type = TREE_TYPE (TREE_VALUE (current_fake_result_decl));
+ }
+
+ while (POINTER_TYPE_P (type))
+ type = TREE_TYPE (type);
+
+ if (GFC_DESCRIPTOR_TYPE_P (type))
+ {
+ tree etype = GFC_TYPE_ARRAY_DATAPTR_TYPE (type);
+
+ while (POINTER_TYPE_P (etype))
+ etype = TREE_TYPE (etype);
+
+ gfc_trans_vla_type_sizes_1 (etype, body);
+ }
+
+ gfc_trans_vla_type_sizes_1 (type, body);
+}
+
/* Generate function entry and exit code, and add it to the function body.
This includes:
@@ -2249,6 +2431,8 @@ gfc_trans_deferred_vars (gfc_symbol * pr
{
locus loc;
gfc_symbol *sym;
+ gfc_formal_arglist *f;
+ stmtblock_t body;
/* Deal with implicit return variables. Explicit return variables will
already have been added. */
@@ -2268,14 +2452,14 @@ gfc_trans_deferred_vars (gfc_symbol * pr
}
else if (proc_sym->as)
{
- fnbody = gfc_trans_dummy_array_bias (proc_sym,
- current_fake_result_decl,
- fnbody);
+ tree result = TREE_VALUE (current_fake_result_decl);
+ fnbody = gfc_trans_dummy_array_bias (proc_sym, result, fnbody);
}
else if (proc_sym->ts.type == BT_CHARACTER)
{
if (TREE_CODE (proc_sym->ts.cl->backend_decl) == VAR_DECL)
- fnbody = gfc_trans_dummy_character (proc_sym->ts.cl, fnbody);
+ fnbody = gfc_trans_dummy_character (proc_sym, proc_sym->ts.cl,
+ fnbody);
}
else
gcc_assert (gfc_option.flag_f2c
@@ -2338,7 +2522,7 @@ gfc_trans_deferred_vars (gfc_symbol * pr
gfc_get_backend_locus (&loc);
gfc_set_backend_locus (&sym->declared_at);
if (sym->attr.dummy || sym->attr.result)
- fnbody = gfc_trans_dummy_character (sym->ts.cl, fnbody);
+ fnbody = gfc_trans_dummy_character (sym, sym->ts.cl, fnbody);
else
fnbody = gfc_trans_auto_character_variable (sym, fnbody);
gfc_set_backend_locus (&loc);
@@ -2354,7 +2538,26 @@ gfc_trans_deferred_vars (gfc_symbol * pr
gcc_unreachable ();
}
- return fnbody;
+ gfc_init_block (&body);
+
+ for (f = proc_sym->formal; f; f = f->next)
+ if (f->sym && f->sym->tlink == NULL && f->sym->ts.type == BT_CHARACTER)
+ {
+ gcc_assert (f->sym->ts.cl->backend_decl != NULL);
+ if (TREE_CODE (f->sym->ts.cl->backend_decl) == PARM_DECL)
+ gfc_trans_vla_type_sizes (f->sym, &body);
+ }
+
+ if (gfc_return_by_reference (proc_sym) && proc_sym->ts.type == BT_CHARACTER
+ && current_fake_result_decl != NULL)
+ {
+ gcc_assert (proc_sym->ts.cl->backend_decl != NULL);
+ if (TREE_CODE (proc_sym->ts.cl->backend_decl) == PARM_DECL)
+ gfc_trans_vla_type_sizes (proc_sym, &body);
+ }
+
+ gfc_add_expr_to_block (&body, fnbody);
+ return gfc_finish_block (&body);
}
@@ -2476,6 +2679,19 @@ generate_local_decl (gfc_symbol * sym)
else if (warn_unused_variable
&& !(sym->attr.in_common || sym->attr.use_assoc))
warning (0, "unused variable %qs", sym->name);
+ /* For variable length CHARACTER parameters, the PARM_DECL already
+ references the length variable, so force gfc_get_symbol_decl
+ even when not referenced. If optimize > 0, it will be optimized
+ away anyway. But do this only after emitting -Wunused-parameter
+ warning if requested. */
+ if (sym->attr.dummy && ! sym->attr.referenced
+ && sym->ts.type == BT_CHARACTER
+ && sym->ts.cl->backend_decl != NULL
+ && TREE_CODE (sym->ts.cl->backend_decl) == VAR_DECL)
+ {
+ sym->attr.referenced = 1;
+ gfc_get_symbol_decl (sym);
+ }
}
}
@@ -2654,7 +2870,10 @@ gfc_generate_function_code (gfc_namespac
{
if (sym->attr.subroutine || sym == sym->result)
{
- result = current_fake_result_decl;
+ if (current_fake_result_decl != NULL)
+ result = TREE_VALUE (current_fake_result_decl);
+ else
+ result = NULL_TREE;
current_fake_result_decl = NULL_TREE;
}
else
--- gcc/fortran/trans.h.jj 2006-01-16 10:59:37.000000000 +0100
+++ gcc/fortran/trans.h 2006-01-16 16:45:06.000000000 +0100
@@ -320,6 +320,8 @@ tree gfc_conv_string_tmp (gfc_se *, tree
tree gfc_get_expr_charlen (gfc_expr *);
/* Initialize a string length variable. */
void gfc_trans_init_string_length (gfc_charlen *, stmtblock_t *);
+/* Ensure type sizes can be gimplified. */
+void gfc_trans_vla_type_sizes (gfc_symbol *, stmtblock_t *);
/* Add an expression to the end of a block. */
void gfc_add_expr_to_block (stmtblock_t *, tree);
--- gcc/fortran/trans-expr.c.jj 2006-01-16 10:59:37.000000000 +0100
+++ gcc/fortran/trans-expr.c 2006-01-16 16:45:06.000000000 +0100
@@ -2415,7 +2415,7 @@ gfc_conv_expr_lhs (gfc_se * se, gfc_expr
}
/* Like gfc_conv_expr, but the POST block is guaranteed to be empty for
- numeric expressions. Used for scalar values whee inserting cleanup code
+ numeric expressions. Used for scalar values where inserting cleanup code
is inconvenient. */
void
gfc_conv_expr_val (gfc_se * se, gfc_expr * expr)
Jakub