summaryrefslogtreecommitdiff
path: root/gcc/fortran
diff options
context:
space:
mode:
authorbstarynk <bstarynk@138bc75d-0d04-0410-961f-82ee72b054a4>2012-05-15 11:35:22 +0000
committerbstarynk <bstarynk@138bc75d-0d04-0410-961f-82ee72b054a4>2012-05-15 11:35:22 +0000
commit74fa23922a189845dad4cca1e8854de624b0ca12 (patch)
tree95f19784c581a1f85cb35235a5b5aea1f6c73e5b /gcc/fortran
parentb6297c58cda06dc31302af6bcf3878d96fdcce33 (diff)
downloadgcc-74fa23922a189845dad4cca1e8854de624b0ca12.tar.gz
2012-05-15 Basile Starynkevitch <basile@starynkevitch.net>
MELT branch merged with trunk rev 187525 using svnmerge git-svn-id: svn+ssh://gcc.gnu.org/svn/gcc/branches/melt-branch@187527 138bc75d-0d04-0410-961f-82ee72b054a4
Diffstat (limited to 'gcc/fortran')
-rw-r--r--gcc/fortran/ChangeLog72
-rw-r--r--gcc/fortran/frontend-passes.c152
-rw-r--r--gcc/fortran/gfortran.texi8
-rw-r--r--gcc/fortran/invoke.texi13
-rw-r--r--gcc/fortran/options.c11
-rw-r--r--gcc/fortran/resolve.c4
-rw-r--r--gcc/fortran/trans-decl.c36
-rw-r--r--gcc/fortran/trans-expr.c56
8 files changed, 263 insertions, 89 deletions
diff --git a/gcc/fortran/ChangeLog b/gcc/fortran/ChangeLog
index b26b5c72735..59cfa32297a 100644
--- a/gcc/fortran/ChangeLog
+++ b/gcc/fortran/ChangeLog
@@ -1,5 +1,75 @@
+2012-05-14 Janne Blomqvist <jb@gcc.gnu.org>
+
+ PR fortran/52428
+ * gfortran.texi: Update _gfortran_set_options documentation.
+ * invoke.texi: Remove runtime behavior description of
+ -fno-range-check.
+ * trans-decl.c (create_main_function): Don't pass the range-check
+ setting to the library.
+
+2012-05-14 Tobias Burnus <burnus@net-b.de>
+
+ PR fortran/49110
+ PR fortran/51055
+ PR fortran/53329
+ * trans-expr.c (gfc_trans_assignment_1): Fix allocation
+ handling for assignment of function results to allocatable
+ deferred-length strings.
+ * trans-decl.c (gfc_create_string_length): For deferred-length
+ module variables, include module name in the assembler name.
+ (gfc_get_symbol_decl): Don't override the assembler name.
+
+2012-05-14 Manuel López-Ibáñez <manu@gcc.gnu.org>
+
+ PR 53063
+ * options.c (gfc_handle_option): Call lang-specific generated function.
+
+2012-05-13 Alessandro Fanfarillo <fanfarillo.gcc@gmail.com>
+ Tobias Burnus <burnus@net-b.de>
+
+ PR fortran/52158
+ PR fortran/45170
+ PR fortran/49430
+ * resolve.c (resolve_fl_derived0): Deferred character length
+ procedure components are supported.
+ * trans-expr.c (gfc_conv_procedure_call): Handle TBP with
+ deferred-length results.
+ (gfc_string_to_single_character): Add a new check to prevent
+ NULL read.
+ (gfc_conv_procedure_call): Remove unuseful checks on
+ symbol's attributes. Add new checks to prevent NULL read on
+ string length.
+
+2012-05-12 Tobias Burnus <burnus@net-b.de>
+
+ PR fortran/49110
+ PR fortran/52843
+ * resolve.c (resolve_fl_procedure): Don't regard
+ character(len=:) as character(*) in the diagnostic.
+
+2012-05-11 Thomas Koenig <tkoenig@gcc.gnu.org>
+
+ PR fortran/52537
+ * frontend-passes.c (optimize_op): Change
+ old-style comparison operators to new-style, simplify
+ switch as a result.
+ (empty_string): New function.
+ (get_len_trim_call): New function.
+ (optimize_comparison): If comparing to an empty string,
+ use comparison of len_trim to zero.
+ Use new-style comparison operators only.
+ (optimize_trim): Use get_len_trim_call.
+
+2012-05-11 Manuel López-Ibáñez <manu@gcc.gnu.org>
+
+ PR 53063
+ * options.c: Include diagnostics.h instead of
+ diagnostics-core.h.
+ (set_Wall): Do not see warn_unused here.
+ (gfc_handle_option): Set it here using handle_generated_option.
+
2012-05-08 Jan Hubicka <jh@suse.cz>
-
+
* trans-common.c (create_common): Do not fake TREE_ASM_WRITTEN.
* trans-decl.c (gfc_finish_cray_pointee): Likewise.
diff --git a/gcc/fortran/frontend-passes.c b/gcc/fortran/frontend-passes.c
index 92a3f8fb3b2..5361d86c543 100644
--- a/gcc/fortran/frontend-passes.c
+++ b/gcc/fortran/frontend-passes.c
@@ -806,20 +806,45 @@ optimize_op (gfc_expr *e)
{
gfc_intrinsic_op op = e->value.op.op;
+ /* Only use new-style comparisions. */
+ switch(op)
+ {
+ case INTRINSIC_EQ_OS:
+ op = INTRINSIC_EQ;
+ break;
+
+ case INTRINSIC_GE_OS:
+ op = INTRINSIC_GE;
+ break;
+
+ case INTRINSIC_LE_OS:
+ op = INTRINSIC_LE;
+ break;
+
+ case INTRINSIC_NE_OS:
+ op = INTRINSIC_NE;
+ break;
+
+ case INTRINSIC_GT_OS:
+ op = INTRINSIC_GT;
+ break;
+
+ case INTRINSIC_LT_OS:
+ op = INTRINSIC_LT;
+ break;
+
+ default:
+ break;
+ }
+
switch (op)
{
case INTRINSIC_EQ:
- case INTRINSIC_EQ_OS:
case INTRINSIC_GE:
- case INTRINSIC_GE_OS:
case INTRINSIC_LE:
- case INTRINSIC_LE_OS:
case INTRINSIC_NE:
- case INTRINSIC_NE_OS:
case INTRINSIC_GT:
- case INTRINSIC_GT_OS:
case INTRINSIC_LT:
- case INTRINSIC_LT_OS:
return optimize_comparison (e, op);
default:
@@ -829,6 +854,63 @@ optimize_op (gfc_expr *e)
return false;
}
+
+/* Return true if a constant string contains only blanks. */
+
+static bool
+empty_string (gfc_expr *e)
+{
+ int i;
+
+ if (e->ts.type != BT_CHARACTER || e->expr_type != EXPR_CONSTANT)
+ return false;
+
+ for (i=0; i < e->value.character.length; i++)
+ {
+ if (e->value.character.string[i] != ' ')
+ return false;
+ }
+
+ return true;
+}
+
+
+/* Insert a call to the intrinsic len_trim. Use a different name for
+ the symbol tree so we don't run into trouble when the user has
+ renamed len_trim for some reason. */
+
+static gfc_expr*
+get_len_trim_call (gfc_expr *str, int kind)
+{
+ gfc_expr *fcn;
+ gfc_actual_arglist *actual_arglist, *next;
+
+ fcn = gfc_get_expr ();
+ fcn->expr_type = EXPR_FUNCTION;
+ fcn->value.function.isym = gfc_intrinsic_function_by_id (GFC_ISYM_LEN_TRIM);
+ actual_arglist = gfc_get_actual_arglist ();
+ actual_arglist->expr = str;
+ next = gfc_get_actual_arglist ();
+ next->expr = gfc_get_int_expr (gfc_default_integer_kind, NULL, kind);
+ actual_arglist->next = next;
+
+ fcn->value.function.actual = actual_arglist;
+ fcn->where = str->where;
+ fcn->ts.type = BT_INTEGER;
+ fcn->ts.kind = gfc_charlen_int_kind;
+
+ gfc_get_sym_tree ("__internal_len_trim", current_ns, &fcn->symtree, false);
+ fcn->symtree->n.sym->ts = fcn->ts;
+ fcn->symtree->n.sym->attr.flavor = FL_PROCEDURE;
+ fcn->symtree->n.sym->attr.function = 1;
+ fcn->symtree->n.sym->attr.elemental = 1;
+ fcn->symtree->n.sym->attr.referenced = 1;
+ fcn->symtree->n.sym->attr.access = ACCESS_PRIVATE;
+ gfc_commit_symbol (fcn->symtree->n.sym);
+
+ return fcn;
+}
+
/* Optimize expressions for equality. */
static bool
@@ -872,6 +954,45 @@ optimize_comparison (gfc_expr *e, gfc_intrinsic_op op)
if (e->rank > 0)
return change;
+ /* Replace a == '' with len_trim(a) == 0 and a /= '' with
+ len_trim(a) != 0 */
+ if (op1->ts.type == BT_CHARACTER && op2->ts.type == BT_CHARACTER
+ && (op == INTRINSIC_EQ || op == INTRINSIC_NE))
+ {
+ bool empty_op1, empty_op2;
+ empty_op1 = empty_string (op1);
+ empty_op2 = empty_string (op2);
+
+ if (empty_op1 || empty_op2)
+ {
+ gfc_expr *fcn;
+ gfc_expr *zero;
+ gfc_expr *str;
+
+ /* This can only happen when an error for comparing
+ characters of different kinds has already been issued. */
+ if (empty_op1 && empty_op2)
+ return false;
+
+ zero = gfc_get_int_expr (gfc_charlen_int_kind, &e->where, 0);
+ str = empty_op1 ? op2 : op1;
+
+ fcn = get_len_trim_call (str, gfc_charlen_int_kind);
+
+
+ if (empty_op1)
+ gfc_free_expr (op1);
+ else
+ gfc_free_expr (op2);
+
+ op1 = fcn;
+ op2 = zero;
+ e->value.op.op1 = fcn;
+ e->value.op.op2 = zero;
+ }
+ }
+
+
/* Don't compare REAL or COMPLEX expressions when honoring NaNs. */
if (flag_finite_math_only
@@ -945,32 +1066,26 @@ optimize_comparison (gfc_expr *e, gfc_intrinsic_op op)
switch (op)
{
case INTRINSIC_EQ:
- case INTRINSIC_EQ_OS:
result = eq == 0;
break;
case INTRINSIC_GE:
- case INTRINSIC_GE_OS:
result = eq >= 0;
break;
case INTRINSIC_LE:
- case INTRINSIC_LE_OS:
result = eq <= 0;
break;
case INTRINSIC_NE:
- case INTRINSIC_NE_OS:
result = eq != 0;
break;
case INTRINSIC_GT:
- case INTRINSIC_GT_OS:
result = eq > 0;
break;
case INTRINSIC_LT:
- case INTRINSIC_LT_OS:
result = eq < 0;
break;
@@ -1002,7 +1117,6 @@ optimize_trim (gfc_expr *e)
gfc_expr *a;
gfc_ref *ref;
gfc_expr *fcn;
- gfc_actual_arglist *actual_arglist, *next;
gfc_ref **rr = NULL;
/* Don't do this optimization within an argument list, because
@@ -1051,17 +1165,7 @@ optimize_trim (gfc_expr *e)
/* Build the function call to len_trim(x, gfc_defaul_integer_kind). */
- fcn = gfc_get_expr ();
- fcn->expr_type = EXPR_FUNCTION;
- fcn->value.function.isym =
- gfc_intrinsic_function_by_id (GFC_ISYM_LEN_TRIM);
- actual_arglist = gfc_get_actual_arglist ();
- actual_arglist->expr = gfc_copy_expr (e);
- next = gfc_get_actual_arglist ();
- next->expr = gfc_get_int_expr (gfc_default_integer_kind, NULL,
- gfc_default_integer_kind);
- actual_arglist->next = next;
- fcn->value.function.actual = actual_arglist;
+ fcn = get_len_trim_call (gfc_copy_expr (e), gfc_default_integer_kind);
/* Set the end of the reference to the call to len_trim. */
diff --git a/gcc/fortran/gfortran.texi b/gcc/fortran/gfortran.texi
index 96662c49423..ffcd3ece2d7 100644
--- a/gcc/fortran/gfortran.texi
+++ b/gcc/fortran/gfortran.texi
@@ -2740,15 +2740,13 @@ Default: enabled.
are (bitwise or-ed): GFC_RTCHECK_BOUNDS (1), GFC_RTCHECK_ARRAY_TEMPS (2),
GFC_RTCHECK_RECURSION (4), GFC_RTCHECK_DO (16), GFC_RTCHECK_POINTER (32).
Default: disabled.
-@item @var{option}[7] @tab If non zero, range checking is enabled.
-Default: enabled. See -frange-check (@pxref{Code Gen Options}).
@end multitable
@item @emph{Example}:
@smallexample
- /* Use gfortran 4.7 default options. */
- static int options[] = @{68, 511, 0, 0, 1, 1, 0, 1@};
- _gfortran_set_options (8, &options);
+ /* Use gfortran 4.8 default options. */
+ static int options[] = @{68, 511, 0, 0, 1, 1, 0@};
+ _gfortran_set_options (7, &options);
@end smallexample
@end table
diff --git a/gcc/fortran/invoke.texi b/gcc/fortran/invoke.texi
index 8db869bfa68..658ed2375fc 100644
--- a/gcc/fortran/invoke.texi
+++ b/gcc/fortran/invoke.texi
@@ -166,8 +166,7 @@ and warnings}.
@item Runtime Options
@xref{Runtime Options,,Options for influencing runtime behavior}.
-@gccoptlist{-fconvert=@var{conversion} -fmax-subrecord-length=@var{length}
--fno-range-check @gol
+@gccoptlist{-fconvert=@var{conversion} -fmax-subrecord-length=@var{length} @gol
-frecord-marker=@var{length} -fsign-zero
}
@@ -1116,16 +1115,6 @@ representation for unformatted files.
The @code{CONVERT} specifier and the GFORTRAN_CONVERT_UNIT environment
variable override the default specified by @option{-fconvert}.}
-
-@item -fno-range-check
-@opindex @code{fno-range-check}
-Disable range checking of input values during integer @code{READ} operations.
-For example, GNU Fortran will give an error if an input value is
-outside of the relevant range of [@code{-HUGE()}:@code{HUGE()}]. In other words,
-with @code{INTEGER (kind=4) :: i} , attempting to read @math{-2147483648} will
-give an error unless @option{-fno-range-check} is given.
-
-
@item -frecord-marker=@var{length}
@opindex @code{frecord-marker=}@var{length}
Specify the length of record markers for unformatted files.
diff --git a/gcc/fortran/options.c b/gcc/fortran/options.c
index dde7ff2f382..f1721ce0a9b 100644
--- a/gcc/fortran/options.c
+++ b/gcc/fortran/options.c
@@ -34,7 +34,7 @@ along with GCC; see the file COPYING3. If not see
#include "gfortran.h"
#include "target.h"
#include "cpp.h"
-#include "diagnostic-core.h" /* For sorry. */
+#include "diagnostic.h" /* For global_dc. */
#include "tm.h"
gfc_option_t gfc_option;
@@ -474,7 +474,6 @@ set_Wall (int setting)
gfc_option.warn_real_q_constant = setting;
gfc_option.warn_unused_dummy_argument = setting;
- warn_unused = setting;
warn_return_type = setting;
warn_switch = setting;
warn_uninitialized = setting;
@@ -612,6 +611,10 @@ gfc_handle_option (size_t scode, const char *arg, int value,
break;
case OPT_Wall:
+ handle_generated_option (&global_options, &global_options_set,
+ OPT_Wunused, NULL, value,
+ gfc_option_lang_mask (), kind, loc,
+ handlers, global_dc);
set_Wall (value);
break;
@@ -1087,6 +1090,10 @@ gfc_handle_option (size_t scode, const char *arg, int value,
break;
}
+ Fortran_handle_option_auto (&global_options, &global_options_set,
+ scode, arg, value,
+ gfc_option_lang_mask (), kind,
+ loc, handlers, global_dc);
return result;
}
diff --git a/gcc/fortran/resolve.c b/gcc/fortran/resolve.c
index b3a23ed73c9..9814c14753a 100644
--- a/gcc/fortran/resolve.c
+++ b/gcc/fortran/resolve.c
@@ -10726,7 +10726,7 @@ resolve_fl_procedure (gfc_symbol *sym, int mp_flag)
actual length; (ii) To declare a named constant; or (iii) External
function - but length must be declared in calling scoping unit. */
if (sym->attr.function
- && sym->ts.type == BT_CHARACTER
+ && sym->ts.type == BT_CHARACTER && !sym->ts.deferred
&& sym->ts.u.cl && sym->ts.u.cl->length == NULL)
{
if ((sym->as && sym->as->rank) || (sym->attr.pointer)
@@ -11665,7 +11665,7 @@ resolve_fl_derived0 (gfc_symbol *sym)
for ( ; c != NULL; c = c->next)
{
/* See PRs 51550, 47545, 48654, 49050, 51075 - and 45170. */
- if (c->ts.type == BT_CHARACTER && c->ts.deferred)
+ if (c->ts.type == BT_CHARACTER && c->ts.deferred && !c->attr.function)
{
gfc_error ("Deferred-length character component '%s' at %L is not "
"yet supported", c->name, &c->loc);
diff --git a/gcc/fortran/trans-decl.c b/gcc/fortran/trans-decl.c
index b03d393aa8e..0480f956c84 100644
--- a/gcc/fortran/trans-decl.c
+++ b/gcc/fortran/trans-decl.c
@@ -1087,11 +1087,14 @@ gfc_create_string_length (gfc_symbol * sym)
if (sym->ts.u.cl->backend_decl == NULL_TREE)
{
tree length;
- char name[GFC_MAX_MANGLED_SYMBOL_LEN + 2];
+ const char *name;
/* Also prefix the mangled name. */
- strcpy (&name[1], sym->name);
- name[0] = '.';
+ if (sym->module)
+ name = gfc_get_string (".__%s_MOD_%s", sym->module, sym->name);
+ else
+ name = gfc_get_string (".%s", sym->name);
+
length = build_decl (input_location,
VAR_DECL, get_identifier (name),
gfc_charlen_type_node);
@@ -1101,6 +1104,13 @@ gfc_create_string_length (gfc_symbol * sym)
gfc_defer_symbol_init (sym);
sym->ts.u.cl->backend_decl = length;
+
+ if (sym->attr.save || sym->ns->proc_name->attr.flavor == FL_MODULE)
+ TREE_STATIC (length) = 1;
+
+ if (sym->ns->proc_name->attr.flavor == FL_MODULE
+ && (sym->attr.access != ACCESS_PRIVATE || sym->attr.public_used))
+ TREE_PUBLIC (length) = 1;
}
gcc_assert (sym->ts.u.cl->backend_decl != NULL_TREE);
@@ -1402,17 +1412,6 @@ gfc_get_symbol_decl (gfc_symbol * sym)
if (TREE_CODE (length) != INTEGER_CST)
{
- char name[GFC_MAX_MANGLED_SYMBOL_LEN + 2];
-
- if (sym->module)
- {
- /* Also prefix the mangled name for symbols from modules. */
- strcpy (&name[1], sym->name);
- name[0] = '.';
- strcpy (&name[1],
- IDENTIFIER_POINTER (DECL_ASSEMBLER_NAME (length)));
- gfc_set_decl_assembler_name (decl, get_identifier (name));
- }
gfc_finish_var_decl (length, sym);
gcc_assert (!sym->value);
}
@@ -5040,12 +5039,17 @@ create_main_function (tree fndecl)
build_int_cst (integer_type_node,
(gfc_option.rtcheck
& GFC_RTCHECK_BOUNDS)));
+ /* TODO: This is the -frange-check option, which no longer affects
+ library behavior; when bumping the library ABI this slot can be
+ reused for something else. As it is the last element in the
+ array, we can instead leave it out altogether.
CONSTRUCTOR_APPEND_ELT (v, NULL_TREE,
build_int_cst (integer_type_node,
gfc_option.flag_range_check));
+ */
array_type = build_array_type (integer_type_node,
- build_index_type (size_int (7)));
+ build_index_type (size_int (6)));
array = build_constructor (array_type, v);
TREE_CONSTANT (array) = 1;
TREE_STATIC (array) = 1;
@@ -5060,7 +5064,7 @@ create_main_function (tree fndecl)
tmp = build_call_expr_loc (input_location,
gfor_fndecl_set_options, 2,
- build_int_cst (integer_type_node, 8), var);
+ build_int_cst (integer_type_node, 7), var);
gfc_add_expr_to_block (&body, tmp);
}
diff --git a/gcc/fortran/trans-expr.c b/gcc/fortran/trans-expr.c
index 8045b1f029b..9d48a09e129 100644
--- a/gcc/fortran/trans-expr.c
+++ b/gcc/fortran/trans-expr.c
@@ -2073,7 +2073,8 @@ tree
gfc_string_to_single_character (tree len, tree str, int kind)
{
- if (!INTEGER_CST_P (len) || TREE_INT_CST_HIGH (len) != 0
+ if (len == NULL
+ || !INTEGER_CST_P (len) || TREE_INT_CST_HIGH (len) != 0
|| !POINTER_TYPE_P (TREE_TYPE (str)))
return NULL_TREE;
@@ -4175,7 +4176,7 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym,
we take the character length of the first argument for the result.
For dummies, we have to look through the formal argument list for
this function and use the character length found there.*/
- if (ts.deferred && (sym->attr.allocatable || sym->attr.pointer))
+ if (ts.deferred)
cl.backend_decl = gfc_create_var (gfc_charlen_type_node, "slen");
else if (!sym->attr.dummy)
cl.backend_decl = VEC_index (tree, stringargs, 0);
@@ -4186,6 +4187,7 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym,
if (strcmp (formal->sym->name, sym->name) == 0)
cl.backend_decl = formal->sym->ts.u.cl->backend_decl;
}
+ len = cl.backend_decl;
}
else
{
@@ -4343,9 +4345,13 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym,
if ((!comp && sym->attr.allocatable)
|| (comp && comp->attr.allocatable))
- gfc_add_modify (&se->pre, var,
- fold_convert (TREE_TYPE (var),
- null_pointer_node));
+ {
+ gfc_add_modify (&se->pre, var,
+ fold_convert (TREE_TYPE (var),
+ null_pointer_node));
+ tmp = gfc_call_free (convert (pvoid_type_node, var));
+ gfc_add_expr_to_block (&se->post, tmp);
+ }
/* Provide an address expression for the function arguments. */
var = gfc_build_addr_expr (NULL_TREE, var);
@@ -4364,17 +4370,16 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym,
VEC_safe_push (tree, gc, retargs, var);
}
- if (ts.type == BT_CHARACTER && ts.deferred
- && (sym->attr.allocatable || sym->attr.pointer))
+ /* Add the string length to the argument list. */
+ if (ts.type == BT_CHARACTER && ts.deferred)
{
tmp = len;
if (TREE_CODE (tmp) != VAR_DECL)
tmp = gfc_evaluate_now (len, &se->pre);
- len = gfc_build_addr_expr (NULL_TREE, tmp);
+ tmp = gfc_build_addr_expr (NULL_TREE, tmp);
+ VEC_safe_push (tree, gc, retargs, tmp);
}
-
- /* Add the string length to the argument list. */
- if (ts.type == BT_CHARACTER)
+ else if (ts.type == BT_CHARACTER)
VEC_safe_push (tree, gc, retargs, len);
}
gfc_free_interface_mapping (&mapping);
@@ -4483,10 +4488,7 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym,
else
se->expr = var;
- if (!ts.deferred)
- se->string_length = len;
- else if (sym->attr.allocatable || sym->attr.pointer)
- se->string_length = cl.backend_decl;
+ se->string_length = len;
}
else
{
@@ -5776,8 +5778,7 @@ gfc_trans_pointer_assignment (gfc_expr * expr1, gfc_expr * expr2)
really added if -fbounds-check is enabled. Exclude deferred
character length lefthand sides. */
if (expr1->ts.type == BT_CHARACTER && expr2->expr_type != EXPR_NULL
- && !(expr1->ts.deferred
- && (TREE_CODE (lse.string_length) == VAR_DECL))
+ && !expr1->ts.deferred
&& !expr1->symtree->n.sym->attr.proc_pointer
&& !gfc_is_proc_ptr_comp (expr1, NULL))
{
@@ -5790,11 +5791,11 @@ gfc_trans_pointer_assignment (gfc_expr * expr1, gfc_expr * expr2)
/* The assignment to an deferred character length sets the string
length to that of the rhs. */
- if (expr1->ts.deferred && (TREE_CODE (lse.string_length) == VAR_DECL))
+ if (expr1->ts.deferred)
{
- if (expr2->expr_type != EXPR_NULL)
+ if (expr2->expr_type != EXPR_NULL && lse.string_length != NULL)
gfc_add_modify (&block, lse.string_length, rse.string_length);
- else
+ else if (lse.string_length != NULL)
gfc_add_modify (&block, lse.string_length,
build_int_cst (gfc_charlen_type_node, 0));
}
@@ -7004,13 +7005,14 @@ gfc_trans_assignment_1 (gfc_expr * expr1, gfc_expr * expr2, bool init_flag,
gfc_add_expr_to_block (&loop.post, tmp);
}
- /* For a deferred character length function, the function call must
- happen before the (re)allocation of the lhs, otherwise the character
- length of the result is not known. */
- def_clen_func = (((expr2->expr_type == EXPR_FUNCTION)
- || (expr2->expr_type == EXPR_COMPCALL)
- || (expr2->expr_type == EXPR_PPC))
- && expr2->ts.deferred);
+ /* When assigning a character function result to a deferred-length variable,
+ the function call must happen before the (re)allocation of the lhs -
+ otherwise the character length of the result is not known.
+ NOTE: This relies on having the exact dependence of the length type
+ parameter available to the caller; gfortran saves it in the .mod files. */
+ def_clen_func = (expr2->expr_type == EXPR_FUNCTION
+ || expr2->expr_type == EXPR_COMPCALL
+ || expr2->expr_type == EXPR_PPC);
if (gfc_option.flag_realloc_lhs
&& expr2->ts.type == BT_CHARACTER
&& (def_clen_func || expr2->expr_type == EXPR_OP)
View Lorry Controller Status