/* 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
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);
+ }
}
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;
}
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);
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);
}
}
{
tree fndecl;
gfc_formal_arglist *f;
- tree typelist;
- tree arglist;
- tree length;
+ tree typelist, hidden_typelist;
+ tree arglist, hidden_arglist;
tree type;
tree parm;
/* 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)
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);
+ strcpy (&name[1], f->sym->name);
+ name[0] = '_';
+ length = build_decl (PARM_DECL, get_identifier (name), len_type);
- /* TODO: Check string lengths when -fbounds-check. */
+ 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);
- /* 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
+ /* 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;
}
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;
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))
gfc_add_decl_to_function (decl);
}
- current_fake_result_decl = decl;
+ current_fake_result_decl = build_tree_list (NULL, decl);
return decl;
}
/* 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;
/* 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);
}
/* 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
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:
{
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. */
}
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
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);
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);
}
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);
+ }
}
}
{
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
projects / gcc.git / commitdiff