FreeChainXenon/gcc
1
0
Fork 0
Code Issues Pull requests Projects Releases Packages Wiki Activity Actions

backport: trans-decl.c (create_function_arglist): Handle dummy functions.

Browse source 
Backport from gomp-20050608-branch
	* trans-decl.c (create_function_arglist): Handle dummy functions.

	* 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.

From-SVN: r110653
This commit is contained in:
Jakub Jelinek 2006-02-06 18:15:51 +01:00 • committed by Jakub Jelinek
parent f44013ae3f
commit 417ab240ee
6 changed files with 461 additions and 140 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

67
gcc/fortran/ChangeLog
View file

@ -1,3 +1,70 @@
2006-02-06 Jakub Jelinek <jakub@redhat.com>
Backport from gomp-20050608-branch
* trans-decl.c (create_function_arglist): Handle dummy functions.
* 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.
2006-02-04 Roger Sayle <roger@eyesopen.com>
* dependency.c (gfc_check_dependency): Remove unused vars and nvars

29
gcc/fortran/trans-array.c
View file

@ -3255,7 +3255,7 @@ gfc_trans_array_bounds (tree type, gfc_symbol * sym, tree * poffset,
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)))
{
@ -3273,6 +3273,8 @@ gfc_trans_array_bounds (tree type, gfc_symbol * sym, tree * poffset,
size = stride;
}
gfc_trans_vla_type_sizes (sym, pblock);
*poffset = offset;
return size;
}
@ -3309,6 +3311,8 @@ gfc_trans_auto_array_allocation (tree decl, gfc_symbol * sym, tree fnbody)
{
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);
@ -3661,12 +3665,30 @@ gfc_trans_dummy_array_bias (gfc_symbol * sym, tree tmpdesc, tree body)
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);
@ -4268,7 +4290,10 @@ gfc_trans_deferred_array (gfc_symbol * sym, tree body)
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)

499
gcc/fortran/trans-decl.c
View file

@ -55,8 +55,8 @@ static GTY(()) tree current_function_return_label;
/* 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
@ -614,6 +614,30 @@ gfc_build_qualified_array (tree decl, gfc_symbol * sym)
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);
}
}
@ -762,7 +786,8 @@ gfc_create_string_length (gfc_symbol * sym)
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;
}
@ -810,9 +835,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);
@ -843,28 +866,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);
}
}
@ -1241,9 +1250,8 @@ create_function_arglist (gfc_symbol * sym)
{
tree fndecl;
gfc_formal_arglist *f;
tree typelist;
tree arglist;
tree length;
tree typelist, hidden_typelist;
tree arglist, hidden_arglist;
tree type;
tree parm;
@ -1252,6 +1260,7 @@ create_function_arglist (gfc_symbol * sym)
/* 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)
@ -1270,11 +1279,60 @@ create_function_arglist (gfc_symbol * sym)
if (gfc_return_by_reference (sym))
{
type = TREE_VALUE (typelist);
tree type = TREE_VALUE (typelist), length = NULL;
if (sym->ts.type == BT_CHARACTER)
{
/* Length of character result. */
tree len_type = TREE_VALUE (TREE_CHAIN (typelist));
gcc_assert (len_type == gfc_charlen_type_node);
length = build_decl (PARM_DECL,
get_identifier (".__result"),
len_type);
if (!sym->ts.cl->length)
{
sym->ts.cl->backend_decl = length;
TREE_USED (length) = 1;
}
gcc_assert (TREE_CODE (length) == PARM_DECL);
DECL_CONTEXT (length) = fndecl;
DECL_ARG_TYPE (length) = len_type;
TREE_READONLY (length) = 1;
DECL_ARTIFICIAL (length) = 1;
gfc_finish_decl (length, NULL_TREE);
if (sym->ts.cl->backend_decl == NULL
|| sym->ts.cl->backend_decl == length)
{
gfc_symbol *arg;
tree backend_decl;
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;
}
/* 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);
}
}
parm = build_decl (PARM_DECL, get_identifier ("__result"), type);
DECL_CONTEXT (parm) = fndecl;
DECL_ARG_TYPE (parm) = type;
DECL_ARG_TYPE (parm) = TREE_VALUE (typelist);
TREE_READONLY (parm) = 1;
DECL_ARTIFICIAL (parm) = 1;
gfc_finish_decl (parm, NULL_TREE);
@ -1285,116 +1343,122 @@ create_function_arglist (gfc_symbol * sym)
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);
length = build_decl (PARM_DECL,
get_identifier (".__result"),
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;
TREE_READONLY (length) = 1;
DECL_ARTIFICIAL (length) = 1;
gfc_finish_decl (length, NULL_TREE);
}
}
hidden_typelist = typelist;
for (f = sym->formal; f; f = f->next)
{
if (f->sym != NULL) /* ignore alternate returns. */
{
length = NULL_TREE;
if (f->sym != NULL) /* Ignore alternate returns. */
hidden_typelist = TREE_CHAIN (hidden_typelist);
type = TREE_VALUE (typelist);
/* 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) = type;
/* 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);
}
}
/* Add the hidden string length parameters. */
parm = arglist;
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);
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)
if (f->sym->ts.type == BT_CHARACTER)
{
TREE_USED (length) = 1;
if (!f->sym->ts.cl->backend_decl)
f->sym->ts.cl->backend_decl = length;
else
tree len_type = TREE_VALUE (hidden_typelist);
tree length = NULL_TREE;
gcc_assert (len_type == gfc_charlen_type_node);
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. */
if (f->sym->attr.flavor == FL_PROCEDURE)
type = build_pointer_type (gfc_get_function_type (f->sym));
else
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)))
{
if (f->sym->attr.flavor == FL_PROCEDURE)
type = build_pointer_type (gfc_get_function_type (f->sym));
else
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;
}
@ -1658,18 +1722,24 @@ gfc_create_function_decl (gfc_namespace * ns)
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;
@ -1683,22 +1753,32 @@ gfc_get_fake_result_decl (gfc_symbol * sym)
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))
@ -1731,7 +1811,7 @@ gfc_get_fake_result_decl (gfc_symbol * sym)
gfc_add_decl_to_function (decl);
}
current_fake_result_decl = decl;
current_fake_result_decl = build_tree_list (NULL, decl);
return decl;
}
@ -2174,7 +2254,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;
@ -2184,7 +2264,9 @@ gfc_trans_dummy_character (gfc_charlen * cl, tree fnbody)
/* 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);
}
@ -2207,6 +2289,8 @@ gfc_trans_auto_character_variable (gfc_symbol * sym, tree fnbody)
/* 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
@ -2237,6 +2321,112 @@ gfc_trans_assign_aux_var (gfc_symbol * sym, tree fnbody)
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:
@ -2250,6 +2440,8 @@ gfc_trans_deferred_vars (gfc_symbol * proc_sym, tree fnbody)
{
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. */
@ -2269,14 +2461,14 @@ gfc_trans_deferred_vars (gfc_symbol * proc_sym, tree fnbody)
}
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
@ -2339,7 +2531,7 @@ gfc_trans_deferred_vars (gfc_symbol * proc_sym, tree fnbody)
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);
@ -2355,7 +2547,26 @@ gfc_trans_deferred_vars (gfc_symbol * proc_sym, tree fnbody)
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);
}
@ -2477,6 +2688,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);
}
}
}
@ -2655,7 +2879,10 @@ gfc_generate_function_code (gfc_namespace * ns)
{
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

2
gcc/fortran/trans-expr.c
View file

@ -2656,7 +2656,7 @@ gfc_conv_expr_lhs (gfc_se * se, gfc_expr * 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)

2
gcc/fortran/trans-stmt.c
View file

@ -701,7 +701,7 @@ gfc_trans_simple_do (gfc_code * code, stmtblock_t *pblock, tree dovar,
to:
[evaluate loop bounds and step]
count = to + step - from;
count = (to + step - from) / step;
dovar = from;
for (;;)
{

2
gcc/fortran/trans.h
View file

@ -320,6 +320,8 @@ tree gfc_conv_string_tmp (gfc_se *, tree, 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);