summaryrefslogtreecommitdiff
path: root/gcc/fortran
diff options
context:
space:
mode:
Diffstat (limited to 'gcc/fortran')
-rw-r--r--gcc/fortran/ChangeLog174
-rw-r--r--gcc/fortran/arith.c18
-rw-r--r--gcc/fortran/check.c121
-rw-r--r--gcc/fortran/class.c3
-rw-r--r--gcc/fortran/decl.c10
-rw-r--r--gcc/fortran/error.c20
-rw-r--r--gcc/fortran/expr.c54
-rw-r--r--gcc/fortran/frontend-passes.c6
-rw-r--r--gcc/fortran/gfortran.h2
-rw-r--r--gcc/fortran/gfortran.texi27
-rw-r--r--gcc/fortran/interface.c28
-rw-r--r--gcc/fortran/invoke.texi15
-rw-r--r--gcc/fortran/io.c50
-rw-r--r--gcc/fortran/ioparm.def1
-rw-r--r--gcc/fortran/iresolve.c8
-rw-r--r--gcc/fortran/lang.opt4
-rw-r--r--gcc/fortran/match.c6
-rw-r--r--gcc/fortran/parse.c4
-rw-r--r--gcc/fortran/primary.c58
-rw-r--r--gcc/fortran/resolve.c114
-rw-r--r--gcc/fortran/symbol.c2
-rw-r--r--gcc/fortran/trans-array.c8
-rw-r--r--gcc/fortran/trans-common.c4
-rw-r--r--gcc/fortran/trans-expr.c8
-rw-r--r--gcc/fortran/trans-io.c3
-rw-r--r--gcc/fortran/trans-stmt.c57
-rw-r--r--gcc/fortran/trans-types.c24
27 files changed, 619 insertions, 210 deletions
diff --git a/gcc/fortran/ChangeLog b/gcc/fortran/ChangeLog
index 625189fd8e8..bb0beb713e9 100644
--- a/gcc/fortran/ChangeLog
+++ b/gcc/fortran/ChangeLog
@@ -1,3 +1,177 @@
+2016-11-09 Paul Thomas <pault@gcc.gnu.org>
+
+ * check.c (gfc_check_move_alloc): Prevent error that avoids
+ aliasing between to and from arguments from rejecting valid
+ code.
+
+2016-11-09 Janus Weil <janus@gcc.gnu.org>
+
+ PR fortran/71894
+ * class.c (gfc_add_component_ref): Add safety checks to avoid ICE.
+
+2016-11-08 Janus Weil <janus@gcc.gnu.org>
+
+ PR fortran/68440
+ * expr.c (check_alloc_comp_init): Loosen an assert.
+ * resolve.c (resolve_fl_parameter): Reject class parameters.
+
+2016-11-08 Janus Weil <janus@gcc.gnu.org>
+
+ PR fortran/77596
+ * expr.c (gfc_check_pointer_assign): Add special check for procedure-
+ pointer component with absent interface.
+
+2016-11-07 Thomas Koenig <tkoenig@gcc.gnu.org>
+
+ PR fortran/78226
+ * expr.c (gfc_generate_initializer): Add where to EXPR_NULL
+ statement.
+ * iresolve.c (gfc_resolve_extends_type_of): Add where to
+ both arguments of the function.
+ * resolve.c (resolve_select_type): Add where to the
+ second argument of the new statement.
+
+2016-11-07 Thomas Koenig <tkoenig@gcc.gnu.org>
+
+ PR fortran/78226
+ * match.c (gfc_match_select_type): Add where for expr1.
+ * resolve.c (resolev_select_type): Add where for expr1 of new
+ statement.
+
+2016-11-06 Thomas Koenig <tkoenig@gcc.gnu.org>
+
+ PR fortran/78226
+ resolve.c (build_loc_call): Add location to return value.
+
+2016-11-06 Andre Vehreschild <vehre@gcc.gnu.org>
+
+ * expr.c (is_non_empty_structure_constructor): New function to detect
+ non-empty structure constructor.
+ (gfc_has_default_initializer): Analyse initializers.
+ * resolve.c (cond_init): Removed.
+ (resolve_allocate_expr): Removed dead code. Moved invariant code out
+ of the loop over all objects to allocate.
+ (resolve_allocate_deallocate): Added the invariant code remove from
+ resolve_allocate_expr.
+ * trans-array.c (gfc_array_allocate): Removed nullify of structure
+ components in favour of doing this in gfc_trans_allocate for both
+ scalars and arrays in the same place.
+ * trans-expr.c (gfc_trans_init_assign): Always using _vptr->copy for
+ class objects.
+ * trans-stmt.c (allocate_get_initializer): Get the initializer
+ expression for object allocated.
+ (gfc_trans_allocate): Nullify a derived type only, when no SOURCE=
+ or MOLD= is present preventing duplicate work. Moved the creation
+ of the init-expression here to prevent code for conditions that
+ can not occur on freshly allocated object, like checking for the need
+ to free allocatable components.
+
+2016-11-06 Thomas Koenig <tkoenig@gcc.gnu.org>
+
+ PR fortran/78221
+ * arith.c (gfc_complex2real): Change gfc_warning_now to
+ gfc_warning.
+
+2016-11-05 Paul Thomas <pault@gcc.gnu.org>
+
+ * check.c (gfc_check_move_alloc): Introduce error to prevent
+ aliasing between to and from arguments.
+
+2016-11-05 Janus Weil <janus@gcc.gnu.org>
+ Manuel Lopez-Ibanez <manu@gcc.gnu.org>
+
+ PR fortran/69495
+ * invoke.texi: Mention -Wpedantic as an alias of -pedantic.
+ * check.c (gfc_check_transfer): Mention responsible flag in warning
+ message.
+ * frontend-passes.c (do_warn_function_elimination): Ditto.
+ * resolve.c (resolve_elemental_actual): Ditto.
+ (resolve_operator): Ditto.
+ (warn_unused_fortran_label): Ditto.
+ * trans-common.c (translate_common): Ditto.
+
+2016-11-05 Paul Thomas <pault@gcc.gnu.org>
+
+ PR fortran/67564
+ * trans-expr.c (gfc_conv_class_to_class): Return _len component
+ of unlimited polymorphic entities.
+
+2016-11-04 Paul Thomas <pault@gcc.gnu.org>
+
+ PR fortran/64933
+ * primary.c (gfc_match_varspec): If selector expression is
+ unambiguously an array, make sure that the associate name
+ is an array and has an array spec. Modify the original
+ condition for doing this to exclude character types.
+
+2016-11-03 Fritz Reese <fritzoreese@gmail.com>
+
+ * gfortran.texi: Document.
+ * gfortran.h (gfc_dt): New field default_exp.
+ * primary.c (match_real_constant): Default exponent with -fdec.
+ * io.c (match_io): Set dt.default_exp with -fdec.
+ * ioparm.def (IOPARM_dt_default_exp): New.
+ * trans-io.c (build_dt): Set IOPARM_dt_default_exp with -fdec.
+
+2016-11-03 Fritz O. Reese <fritzoreese@gmail.com>
+
+ * decl.c (gfc_match_parameter): Allow omitted '()' with -std=legacy.
+ * parse.c (decode_statement): Match "parameter" before assignments.
+ * gfortran.texi: Document.
+
+2016-11-02 Fritz O. Reese <fritzoreese@gmail.com>
+
+ * lang.opt, invoke.texi: New argument -Wargument-mismatch.
+ * interface.c (compare_parameter, compare_actual_formal,
+ gfc_check_typebound_override, argument_rank_mismatch): Control argument
+ mismatch warnings with -Wargument-mismatch.
+ * resolve.c (resolve_structure_cons, resolve_global_procedure): Ditto.
+
+2016-11-02 Fritz Reese <fritzoreese@gmail.com>
+
+ * gfortran.h (gfc_error): New declaration for gfc_error with 'opt'.
+ * error.c (gfc_error): Add optional 'opt' argument.
+ * error.c (gfc_notify_std): Call fully-qualified gfc_error.
+
+2016-11-01 Thomas Koenig <tkoenig@gcc.gnu.org>
+
+ PR fortran/78178
+ * match.c (match_simple_where): Fill in locus for assigment
+ in simple WHERE statement.
+
+2016-11-01 Thomas Koenig <tkoenig@gcc.gnu.org>
+
+ PR fortran/69544
+ * match.c (gfc_match_where): Fill in locus for assigment
+ in simple WHERE statement.
+
+2016-10-31 Jerry DeLisle <jvdelisle@gcc.gnu.org>
+
+ PR fortran/54679
+ * io.c (check_format): Adjust checks for FMT_L to treat a zero
+ width as an extension, giving warnings or error as appropriate.
+ Improve messages.
+
+2016-10-31 Jakub Jelinek <jakub@redhat.com>
+
+ * trans-types.c (gfc_get_array_descr_info): For -gdwarf-5 or
+ -gno-strict-dwarf, handle assumed rank arrays the way dwarf2out
+ expects.
+
+2016-10-30 Thomas Koenig <tkoenig@gcc.gnu.org>
+
+ PR fortran/67219
+ * arith.c (gfc_int2real): Change gfc_warning_now
+ to gfc_warning.
+ * primary.c (match_complex_constant): If there
+ is no comma, throw away any warning which might have
+ been issued by gfc_int2real.
+
+2016-10-28 Steven G. Kargl <kargl@gcc.gnu.org>
+
+ PR fortran/71891
+ * symbol.c (gfc_type_compatible): Fix typo.
+
2016-10-27 Jakub Jelinek <jakub@redhat.com>
PR fortran/78026
diff --git a/gcc/fortran/arith.c b/gcc/fortran/arith.c
index 8af75400d80..2781f103841 100644
--- a/gcc/fortran/arith.c
+++ b/gcc/fortran/arith.c
@@ -2072,11 +2072,11 @@ gfc_int2real (gfc_expr *src, int kind)
if (warn_conversion
&& wprecision_int_real (src->value.integer, result->value.real))
- gfc_warning_now (OPT_Wconversion, "Change of value in conversion "
- "from %qs to %qs at %L",
- gfc_typename (&src->ts),
- gfc_typename (&result->ts),
- &src->where);
+ gfc_warning (OPT_Wconversion, "Change of value in conversion "
+ "from %qs to %qs at %L",
+ gfc_typename (&src->ts),
+ gfc_typename (&result->ts),
+ &src->where);
return result;
}
@@ -2369,10 +2369,10 @@ gfc_complex2real (gfc_expr *src, int kind)
/* See if we discarded an imaginary part. */
if (mpfr_cmp_si (mpc_imagref (src->value.complex), 0) != 0)
{
- gfc_warning_now (w, "Non-zero imaginary part discarded "
- "in conversion from %qs to %qs at %L",
- gfc_typename(&src->ts), gfc_typename (&result->ts),
- &src->where);
+ gfc_warning (w, "Non-zero imaginary part discarded "
+ "in conversion from %qs to %qs at %L",
+ gfc_typename(&src->ts), gfc_typename (&result->ts),
+ &src->where);
did_warn = true;
}
diff --git a/gcc/fortran/check.c b/gcc/fortran/check.c
index ff5e80b9df5..265fe22594f 100644
--- a/gcc/fortran/check.c
+++ b/gcc/fortran/check.c
@@ -880,7 +880,7 @@ gfc_check_a_p (gfc_expr *a, gfc_expr *p)
if (a->ts.kind != p->ts.kind)
{
- if (!gfc_notify_std (GFC_STD_GNU, "Different type kinds at %L",
+ if (!gfc_notify_std (GFC_STD_GNU, "Different type kinds at %L",
&p->where))
return false;
}
@@ -1797,7 +1797,7 @@ gfc_check_count (gfc_expr *mask, gfc_expr *dim, gfc_expr *kind)
if (!kind_check (kind, 2, BT_INTEGER))
return false;
if (kind && !gfc_notify_std (GFC_STD_F2003, "%qs intrinsic "
- "with KIND argument at %L",
+ "with KIND argument at %L",
gfc_current_intrinsic, &kind->where))
return false;
@@ -2127,11 +2127,11 @@ gfc_check_eoshift (gfc_expr *array, gfc_expr *shift, gfc_expr *boundary,
}
else if (boundary->rank == array->rank - 1)
{
- if (!gfc_check_conformance (shift, boundary,
+ if (!gfc_check_conformance (shift, boundary,
"arguments '%s' and '%s' for "
- "intrinsic %s",
- gfc_current_intrinsic_arg[1]->name,
- gfc_current_intrinsic_arg[2]->name,
+ "intrinsic %s",
+ gfc_current_intrinsic_arg[1]->name,
+ gfc_current_intrinsic_arg[2]->name,
gfc_current_intrinsic))
return false;
}
@@ -2156,7 +2156,7 @@ gfc_check_float (gfc_expr *a)
if ((a->ts.kind != gfc_default_integer_kind)
&& !gfc_notify_std (GFC_STD_GNU, "non-default INTEGER "
- "kind argument to %s intrinsic at %L",
+ "kind argument to %s intrinsic at %L",
gfc_current_intrinsic, &a->where))
return false;
@@ -2283,7 +2283,7 @@ gfc_check_iand (gfc_expr *i, gfc_expr *j)
if (i->ts.kind != j->ts.kind)
{
- if (!gfc_notify_std (GFC_STD_GNU, "Different type kinds at %L",
+ if (!gfc_notify_std (GFC_STD_GNU, "Different type kinds at %L",
&i->where))
return false;
}
@@ -2329,7 +2329,7 @@ gfc_check_ichar_iachar (gfc_expr *c, gfc_expr *kind)
return false;
if (kind && !gfc_notify_std (GFC_STD_F2003, "%qs intrinsic "
- "with KIND argument at %L",
+ "with KIND argument at %L",
gfc_current_intrinsic, &kind->where))
return false;
@@ -2409,7 +2409,7 @@ gfc_check_ieor (gfc_expr *i, gfc_expr *j)
if (i->ts.kind != j->ts.kind)
{
- if (!gfc_notify_std (GFC_STD_GNU, "Different type kinds at %L",
+ if (!gfc_notify_std (GFC_STD_GNU, "Different type kinds at %L",
&i->where))
return false;
}
@@ -2432,7 +2432,7 @@ gfc_check_index (gfc_expr *string, gfc_expr *substring, gfc_expr *back,
if (!kind_check (kind, 3, BT_INTEGER))
return false;
if (kind && !gfc_notify_std (GFC_STD_F2003, "%qs intrinsic "
- "with KIND argument at %L",
+ "with KIND argument at %L",
gfc_current_intrinsic, &kind->where))
return false;
@@ -2483,7 +2483,7 @@ gfc_check_ior (gfc_expr *i, gfc_expr *j)
if (i->ts.kind != j->ts.kind)
{
- if (!gfc_notify_std (GFC_STD_GNU, "Different type kinds at %L",
+ if (!gfc_notify_std (GFC_STD_GNU, "Different type kinds at %L",
&i->where))
return false;
}
@@ -2633,7 +2633,7 @@ gfc_check_lbound (gfc_expr *array, gfc_expr *dim, gfc_expr *kind)
if (!kind_check (kind, 2, BT_INTEGER))
return false;
if (kind && !gfc_notify_std (GFC_STD_F2003, "%qs intrinsic "
- "with KIND argument at %L",
+ "with KIND argument at %L",
gfc_current_intrinsic, &kind->where))
return false;
@@ -2678,7 +2678,7 @@ gfc_check_len_lentrim (gfc_expr *s, gfc_expr *kind)
if (!kind_check (kind, 1, BT_INTEGER))
return false;
if (kind && !gfc_notify_std (GFC_STD_F2003, "%qs intrinsic "
- "with KIND argument at %L",
+ "with KIND argument at %L",
gfc_current_intrinsic, &kind->where))
return false;
@@ -2948,7 +2948,7 @@ gfc_check_min_max (gfc_actual_arglist *arg)
if (x->ts.type == BT_CHARACTER)
{
if (!gfc_notify_std (GFC_STD_F2003, "%qs intrinsic "
- "with CHARACTER argument at %L",
+ "with CHARACTER argument at %L",
gfc_current_intrinsic, &x->where))
return false;
}
@@ -3118,10 +3118,10 @@ gfc_check_minloc_maxloc (gfc_actual_arglist *ap)
return false;
if (m != NULL
- && !gfc_check_conformance (a, m,
- "arguments '%s' and '%s' for intrinsic %s",
- gfc_current_intrinsic_arg[0]->name,
- gfc_current_intrinsic_arg[2]->name,
+ && !gfc_check_conformance (a, m,
+ "arguments '%s' and '%s' for intrinsic %s",
+ gfc_current_intrinsic_arg[0]->name,
+ gfc_current_intrinsic_arg[2]->name,
gfc_current_intrinsic))
return false;
@@ -3172,10 +3172,10 @@ check_reduction (gfc_actual_arglist *ap)
return false;
if (m != NULL
- && !gfc_check_conformance (a, m,
- "arguments '%s' and '%s' for intrinsic %s",
- gfc_current_intrinsic_arg[0]->name,
- gfc_current_intrinsic_arg[2]->name,
+ && !gfc_check_conformance (a, m,
+ "arguments '%s' and '%s' for intrinsic %s",
+ gfc_current_intrinsic_arg[0]->name,
+ gfc_current_intrinsic_arg[2]->name,
gfc_current_intrinsic))
return false;
@@ -3342,6 +3342,46 @@ gfc_check_move_alloc (gfc_expr *from, gfc_expr *to)
return false;
}
+ /* This is based losely on F2003 12.4.1.7. It is intended to prevent
+ the likes of to = sym->cmp1->cmp2 and from = sym->cmp1, where cmp1
+ and cmp2 are allocatable. After the allocation is transferred,
+ the 'to' chain is broken by the nullification of the 'from'. A bit
+ of reflection reveals that this can only occur for derived types
+ with recursive allocatable components. */
+ if (to->expr_type == EXPR_VARIABLE && from->expr_type == EXPR_VARIABLE
+ && !strcmp (to->symtree->n.sym->name, from->symtree->n.sym->name))
+ {
+ gfc_ref *to_ref, *from_ref;
+ to_ref = to->ref;
+ from_ref = from->ref;
+ bool aliasing = true;
+
+ for (; from_ref && to_ref;
+ from_ref = from_ref->next, to_ref = to_ref->next)
+ {
+ if (to_ref->type != from->ref->type)
+ aliasing = false;
+ else if (to_ref->type == REF_ARRAY
+ && to_ref->u.ar.type != AR_FULL
+ && from_ref->u.ar.type != AR_FULL)
+ /* Play safe; assume sections and elements are different. */
+ aliasing = false;
+ else if (to_ref->type == REF_COMPONENT
+ && to_ref->u.c.component != from_ref->u.c.component)
+ aliasing = false;
+
+ if (!aliasing)
+ break;
+ }
+
+ if (aliasing)
+ {
+ gfc_error ("The FROM and TO arguments at %L violate aliasing "
+ "restrictions (F2003 12.4.1.7)", &to->where);
+ return false;
+ }
+ }
+
/* CLASS arguments: Make sure the vtab of from is present. */
if (to->ts.type == BT_CLASS && !UNLIMITED_POLY (from))
gfc_find_vtab (&from->ts);
@@ -3447,10 +3487,10 @@ gfc_check_pack (gfc_expr *array, gfc_expr *mask, gfc_expr *vector)
if (!type_check (mask, 1, BT_LOGICAL))
return false;
- if (!gfc_check_conformance (array, mask,
- "arguments '%s' and '%s' for intrinsic '%s'",
- gfc_current_intrinsic_arg[0]->name,
- gfc_current_intrinsic_arg[1]->name,
+ if (!gfc_check_conformance (array, mask,
+ "arguments '%s' and '%s' for intrinsic '%s'",
+ gfc_current_intrinsic_arg[0]->name,
+ gfc_current_intrinsic_arg[1]->name,
gfc_current_intrinsic))
return false;
@@ -3989,7 +4029,7 @@ gfc_check_scan (gfc_expr *x, gfc_expr *y, gfc_expr *z, gfc_expr *kind)
if (!kind_check (kind, 3, BT_INTEGER))
return false;
if (kind && !gfc_notify_std (GFC_STD_F2003, "%qs intrinsic "
- "with KIND argument at %L",
+ "with KIND argument at %L",
gfc_current_intrinsic, &kind->where))
return false;
@@ -4050,7 +4090,7 @@ gfc_check_selected_real_kind (gfc_expr *p, gfc_expr *r, gfc_expr *radix)
{
if (p == NULL && r == NULL
&& !gfc_notify_std (GFC_STD_F2008, "SELECTED_REAL_KIND with"
- " neither %<P%> nor %<R%> argument at %L",
+ " neither %<P%> nor %<R%> argument at %L",
gfc_current_intrinsic_where))
return false;
@@ -4081,7 +4121,7 @@ gfc_check_selected_real_kind (gfc_expr *p, gfc_expr *r, gfc_expr *radix)
return false;
if (!gfc_notify_std (GFC_STD_F2008, "%qs intrinsic with "
- "RADIX argument at %L", gfc_current_intrinsic,
+ "RADIX argument at %L", gfc_current_intrinsic,
&radix->where))
return false;
}
@@ -4123,7 +4163,7 @@ gfc_check_shape (gfc_expr *source, gfc_expr *kind)
if (!kind_check (kind, 1, BT_INTEGER))
return false;
if (kind && !gfc_notify_std (GFC_STD_F2003, "%qs intrinsic "
- "with KIND argument at %L",
+ "with KIND argument at %L",
gfc_current_intrinsic, &kind->where))
return false;
@@ -4178,7 +4218,7 @@ gfc_check_size (gfc_expr *array, gfc_expr *dim, gfc_expr *kind)
if (!kind_check (kind, 2, BT_INTEGER))
return false;
if (kind && !gfc_notify_std (GFC_STD_F2003, "%qs intrinsic "
- "with KIND argument at %L",
+ "with KIND argument at %L",
gfc_current_intrinsic, &kind->where))
return false;
@@ -4621,9 +4661,9 @@ gfc_check_c_loc (gfc_expr *x)
&x->where);
return false;
}
-
+
if (x->rank
- && !gfc_notify_std (GFC_STD_F2008_TS,
+ && !gfc_notify_std (GFC_STD_F2008_TS,
"Noninteroperable array at %L as"
" argument to C_LOC: %s", &x->where, msg))
return false;
@@ -4634,7 +4674,7 @@ gfc_check_c_loc (gfc_expr *x)
if (ar->as->type != AS_EXPLICIT && ar->as->type != AS_ASSUMED_SIZE
&& !attr.allocatable
- && !gfc_notify_std (GFC_STD_F2008,
+ && !gfc_notify_std (GFC_STD_F2008,
"Array of interoperable type at %L "
"to C_LOC which is nonallocatable and neither "
"assumed size nor explicit size", &x->where))
@@ -4669,7 +4709,7 @@ gfc_check_sngl (gfc_expr *a)
if ((a->ts.kind != gfc_default_double_kind)
&& !gfc_notify_std (GFC_STD_GNU, "non double precision "
- "REAL argument to %s intrinsic at %L",
+ "REAL argument to %s intrinsic at %L",
gfc_current_intrinsic, &a->where))
return false;
@@ -5182,12 +5222,13 @@ gfc_check_transfer (gfc_expr *source, gfc_expr *mold, gfc_expr *size)
/* If we can't calculate the sizes, we cannot check any more.
Return true for that case. */
- if (!gfc_calculate_transfer_sizes (source, mold, size, &source_size,
+ if (!gfc_calculate_transfer_sizes (source, mold, size, &source_size,
&result_size, NULL))
return true;
if (source_size < result_size)
- gfc_warning (0, "Intrinsic TRANSFER at %L has partly undefined result: "
+ gfc_warning (OPT_Wsurprising,
+ "Intrinsic TRANSFER at %L has partly undefined result: "
"source size %ld < result size %ld", &source->where,
(long) source_size, (long) result_size);
@@ -5220,7 +5261,7 @@ gfc_check_ubound (gfc_expr *array, gfc_expr *dim, gfc_expr *kind)
if (!kind_check (kind, 2, BT_INTEGER))
return false;
if (kind && !gfc_notify_std (GFC_STD_F2003, "%qs intrinsic "
- "with KIND argument at %L",
+ "with KIND argument at %L",
gfc_current_intrinsic, &kind->where))
return false;
@@ -5349,7 +5390,7 @@ gfc_check_verify (gfc_expr *x, gfc_expr *y, gfc_expr *z, gfc_expr *kind)
if (!kind_check (kind, 3, BT_INTEGER))
return false;
if (kind && !gfc_notify_std (GFC_STD_F2003, "%qs intrinsic "
- "with KIND argument at %L",
+ "with KIND argument at %L",
gfc_current_intrinsic, &kind->where))
return false;
diff --git a/gcc/fortran/class.c b/gcc/fortran/class.c
index 400c22abaf5..b7f68d2f19a 100644
--- a/gcc/fortran/class.c
+++ b/gcc/fortran/class.c
@@ -224,7 +224,8 @@ gfc_add_component_ref (gfc_expr *e, const char *name)
break;
tail = &((*tail)->next);
}
- if (derived->components->next->ts.type == BT_DERIVED &&
+ if (derived->components && derived->components->next &&
+ derived->components->next->ts.type == BT_DERIVED &&
derived->components->next->ts.u.derived == NULL)
{
/* Fix up missing vtype. */
diff --git a/gcc/fortran/decl.c b/gcc/fortran/decl.c
index f18eb41bc50..0120cebb322 100644
--- a/gcc/fortran/decl.c
+++ b/gcc/fortran/decl.c
@@ -7821,10 +7821,16 @@ cleanup:
match
gfc_match_parameter (void)
{
+ const char *term = " )%t";
match m;
if (gfc_match_char ('(') == MATCH_NO)
- return MATCH_NO;
+ {
+ /* With legacy PARAMETER statements, don't expect a terminating ')'. */
+ if (!gfc_notify_std (GFC_STD_LEGACY, "PARAMETER without '()' at %C"))
+ return MATCH_NO;
+ term = " %t";
+ }
for (;;)
{
@@ -7832,7 +7838,7 @@ gfc_match_parameter (void)
if (m != MATCH_YES)
break;
- if (gfc_match (" )%t") == MATCH_YES)
+ if (gfc_match (term) == MATCH_YES)
break;
if (gfc_match_char (',') != MATCH_YES)
diff --git a/gcc/fortran/error.c b/gcc/fortran/error.c
index fe91419ce44..0fd8a4e74e3 100644
--- a/gcc/fortran/error.c
+++ b/gcc/fortran/error.c
@@ -67,7 +67,7 @@ gfc_push_suppress_errors (void)
}
static void
-gfc_error (const char *gmsgid, va_list ap) ATTRIBUTE_GCC_GFC(1,0);
+gfc_error (int opt, const char *gmsgid, va_list ap) ATTRIBUTE_GCC_GFC(2,0);
static bool
gfc_warning (int opt, const char *gmsgid, va_list ap) ATTRIBUTE_GCC_GFC(2,0);
@@ -902,7 +902,7 @@ gfc_notify_std (int std, const char *gmsgid, ...)
if (warning)
gfc_warning (0, buffer, argp);
else
- gfc_error (buffer, argp);
+ gfc_error (0, buffer, argp);
va_end (argp);
return (warning && !warnings_are_errors) ? true : false;
@@ -1233,7 +1233,7 @@ gfc_warning_check (void)
/* Issue an error. */
static void
-gfc_error (const char *gmsgid, va_list ap)
+gfc_error (int opt, const char *gmsgid, va_list ap)
{
va_list argp;
va_copy (argp, ap);
@@ -1241,7 +1241,7 @@ gfc_error (const char *gmsgid, va_list ap)
if (warnings_not_errors)
{
- gfc_warning (/*opt=*/0, gmsgid, argp);
+ gfc_warning (opt, gmsgid, argp);
va_end (argp);
return;
}
@@ -1289,11 +1289,21 @@ gfc_error (const char *gmsgid, va_list ap)
void
+gfc_error (int opt, const char *gmsgid, ...)
+{
+ va_list argp;
+ va_start (argp, gmsgid);
+ gfc_error (opt, gmsgid, argp);
+ va_end (argp);
+}
+
+
+void
gfc_error (const char *gmsgid, ...)
{
va_list argp;
va_start (argp, gmsgid);
- gfc_error (gmsgid, argp);
+ gfc_error (0, gmsgid, argp);
va_end (argp);
}
diff --git a/gcc/fortran/expr.c b/gcc/fortran/expr.c
index bb183d411e6..b2ffaae246a 100644
--- a/gcc/fortran/expr.c
+++ b/gcc/fortran/expr.c
@@ -2206,7 +2206,7 @@ check_alloc_comp_init (gfc_expr *e)
gfc_constructor *ctor;
gcc_assert (e->expr_type == EXPR_STRUCTURE);
- gcc_assert (e->ts.type == BT_DERIVED);
+ gcc_assert (e->ts.type == BT_DERIVED || e->ts.type == BT_CLASS);
for (comp = e->ts.u.derived->components,
ctor = gfc_constructor_first (e->value.constructor);
@@ -3445,7 +3445,7 @@ gfc_check_pointer_assign (gfc_expr *lvalue, gfc_expr *rvalue)
{
char err[200];
gfc_symbol *s1,*s2;
- gfc_component *comp;
+ gfc_component *comp1, *comp2;
const char *name;
attr = gfc_expr_attr (rvalue);
@@ -3549,9 +3549,9 @@ gfc_check_pointer_assign (gfc_expr *lvalue, gfc_expr *rvalue)
}
}
- comp = gfc_get_proc_ptr_comp (lvalue);
- if (comp)
- s1 = comp->ts.interface;
+ comp1 = gfc_get_proc_ptr_comp (lvalue);
+ if (comp1)
+ s1 = comp1->ts.interface;
else
{
s1 = lvalue->symtree->n.sym;
@@ -3559,18 +3559,18 @@ gfc_check_pointer_assign (gfc_expr *lvalue, gfc_expr *rvalue)
s1 = s1->ts.interface;
}
- comp = gfc_get_proc_ptr_comp (rvalue);
- if (comp)
+ comp2 = gfc_get_proc_ptr_comp (rvalue);
+ if (comp2)
{
if (rvalue->expr_type == EXPR_FUNCTION)
{
- s2 = comp->ts.interface->result;
+ s2 = comp2->ts.interface->result;
name = s2->name;
}
else
{
- s2 = comp->ts.interface;
- name = comp->name;
+ s2 = comp2->ts.interface;
+ name = comp2->name;
}
}
else if (rvalue->expr_type == EXPR_FUNCTION)
@@ -3591,6 +3591,15 @@ gfc_check_pointer_assign (gfc_expr *lvalue, gfc_expr *rvalue)
if (s2 && s2->attr.proc_pointer && s2->ts.interface)
s2 = s2->ts.interface;
+ /* Special check for the case of absent interface on the lvalue.
+ * All other interface checks are done below. */
+ if (!s1 && comp1 && comp1->attr.subroutine && s2 && s2->attr.function)
+ {
+ gfc_error ("Interface mismatch in procedure pointer assignment "
+ "at %L: '%s' is not a subroutine", &rvalue->where, name);
+ return false;
+ }
+
if (s1 == s2 || !s1 || !s2)
return true;
@@ -4131,6 +4140,26 @@ gfc_apply_init (gfc_typespec *ts, symbol_attribute *attr, gfc_expr *init)
}
+/* Check whether an expression is a structure constructor and whether it has
+ other values than NULL. */
+
+bool
+is_non_empty_structure_constructor (gfc_expr * e)
+{
+ if (e->expr_type != EXPR_STRUCTURE)
+ return false;
+
+ gfc_constructor *cons = gfc_constructor_first (e->value.constructor);
+ while (cons)
+ {
+ if (!cons->expr || cons->expr->expr_type != EXPR_NULL)
+ return true;
+ cons = gfc_constructor_next (cons);
+ }
+ return false;
+}
+
+
/* Check for default initializer; sym->value is not enough
as it is also set for EXPR_NULL of allocatables. */
@@ -4145,7 +4174,9 @@ gfc_has_default_initializer (gfc_symbol *der)
{
if (!c->attr.pointer && !c->attr.proc_pointer
&& !(c->attr.allocatable && der == c->ts.u.derived)
- && gfc_has_default_initializer (c->ts.u.derived))
+ && ((c->initializer
+ && is_non_empty_structure_constructor (c->initializer))
+ || gfc_has_default_initializer (c->ts.u.derived)))
return true;
if (c->attr.pointer && c->initializer)
return true;
@@ -4345,6 +4376,7 @@ gfc_generate_initializer (gfc_typespec *ts, bool generate)
{
ctor->expr = gfc_get_expr ();
ctor->expr->expr_type = EXPR_NULL;
+ ctor->expr->where = init->where;
ctor->expr->ts = comp->ts;
}
diff --git a/gcc/fortran/frontend-passes.c b/gcc/fortran/frontend-passes.c
index e61673fc6e4..1ad797b579c 100644
--- a/gcc/fortran/frontend-passes.c
+++ b/gcc/fortran/frontend-passes.c
@@ -747,10 +747,12 @@ do_warn_function_elimination (gfc_expr *e)
if (e->expr_type != EXPR_FUNCTION)
return;
if (e->value.function.esym)
- gfc_warning (0, "Removing call to function %qs at %L",
+ gfc_warning (OPT_Wfunction_elimination,
+ "Removing call to function %qs at %L",
e->value.function.esym->name, &(e->where));
else if (e->value.function.isym)
- gfc_warning (0, "Removing call to function %qs at %L",
+ gfc_warning (OPT_Wfunction_elimination,
+ "Removing call to function %qs at %L",
e->value.function.isym->name, &(e->where));
}
/* Callback function for the code walker for doing common function
diff --git a/gcc/fortran/gfortran.h b/gcc/fortran/gfortran.h
index ea4437c5d83..3fb6f4152ce 100644
--- a/gcc/fortran/gfortran.h
+++ b/gcc/fortran/gfortran.h
@@ -2336,6 +2336,7 @@ typedef struct
gfc_expr *io_unit, *format_expr, *rec, *advance, *iostat, *size, *iomsg,
*id, *pos, *asynchronous, *blank, *decimal, *delim, *pad, *round,
*sign, *extra_comma, *dt_io_kind, *udtio;
+ char default_exp;
gfc_symbol *namelist;
/* A format_label of `format_asterisk' indicates the "*" format */
@@ -2730,6 +2731,7 @@ bool gfc_warning_now_at (location_t loc, int opt, const char *gmsgid, ...)
void gfc_clear_warning (void);
void gfc_warning_check (void);
+void gfc_error (int opt, const char *, ...) ATTRIBUTE_GCC_GFC(2,3);
void gfc_error (const char *, ...) ATTRIBUTE_GCC_GFC(1,2);
void gfc_error_now (const char *, ...) ATTRIBUTE_GCC_GFC(1,2);
void gfc_fatal_error (const char *, ...) ATTRIBUTE_NORETURN ATTRIBUTE_GCC_GFC(1,2);
diff --git a/gcc/fortran/gfortran.texi b/gcc/fortran/gfortran.texi
index e65c2decad2..6de6c9bfeeb 100644
--- a/gcc/fortran/gfortran.texi
+++ b/gcc/fortran/gfortran.texi
@@ -1471,6 +1471,8 @@ compatibility extensions along with those enabled by @option{-std=legacy}.
* .XOR. operator::
* Bitwise logical operators::
* Extended I/O specifiers::
+* Legacy PARAMETER statements::
+* Default exponents::
@end menu
@node Old-style kind specifications
@@ -2696,6 +2698,31 @@ supported on other systems.
@end table
+@node Legacy PARAMETER statements
+@subsection Legacy PARAMETER statements
+@cindex PARAMETER
+
+For compatibility, GNU Fortran supports legacy PARAMETER statements without
+parentheses with @option{-std=legacy}. A warning is emitted if used with
+@option{-std=gnu}, and an error is acknowledged with a real Fortran standard
+flag (@option{-std=f95}, etc...). These statements take the following form:
+
+@smallexample
+implicit real (E)
+parameter e = 2.718282
+real c
+parameter c = 3.0e8
+@end smallexample
+
+@node Default exponents
+@subsection Default exponents
+@cindex exponent
+
+For compatibility, GNU Fortran supports a default exponent of zero in real
+constants with @option{-fdec}. For example, @code{9e} would be
+interpreted as @code{9e0}, rather than an error.
+
+
@node Extensions not implemented in GNU Fortran
@section Extensions not implemented in GNU Fortran
@cindex extensions, not implemented
diff --git a/gcc/fortran/interface.c b/gcc/fortran/interface.c
index b851d5a425b..4dd432ef23d 100644
--- a/gcc/fortran/interface.c
+++ b/gcc/fortran/interface.c
@@ -2139,17 +2139,17 @@ argument_rank_mismatch (const char *name, locus *where,
}
else if (rank1 == 0)
{
- gfc_error ("Rank mismatch in argument %qs at %L "
+ gfc_error (OPT_Wargument_mismatch, "Rank mismatch in argument %qs at %L "
"(scalar and rank-%d)", name, where, rank2);
}
else if (rank2 == 0)
{
- gfc_error ("Rank mismatch in argument %qs at %L "
+ gfc_error (OPT_Wargument_mismatch, "Rank mismatch in argument %qs at %L "
"(rank-%d and scalar)", name, where, rank1);
}
else
{
- gfc_error ("Rank mismatch in argument %qs at %L "
+ gfc_error (OPT_Wargument_mismatch, "Rank mismatch in argument %qs at %L "
"(rank-%d and rank-%d)", name, where, rank1, rank2);
}
}
@@ -2200,7 +2200,8 @@ compare_parameter (gfc_symbol *formal, gfc_expr *actual,
sizeof(err), NULL, NULL))
{
if (where)
- gfc_error ("Interface mismatch in dummy procedure %qs at %L: %s",
+ gfc_error (OPT_Wargument_mismatch,
+ "Interface mismatch in dummy procedure %qs at %L: %s",
formal->name, &actual->where, err);
return 0;
}
@@ -2227,7 +2228,8 @@ compare_parameter (gfc_symbol *formal, gfc_expr *actual,
err, sizeof(err), NULL, NULL))
{
if (where)
- gfc_error ("Interface mismatch in dummy procedure %qs at %L: %s",
+ gfc_error (OPT_Wargument_mismatch,
+ "Interface mismatch in dummy procedure %qs at %L: %s",
formal->name, &actual->where, err);
return 0;
}
@@ -2253,7 +2255,8 @@ compare_parameter (gfc_symbol *formal, gfc_expr *actual,
CLASS_DATA (actual)->ts.u.derived)))
{
if (where)
- gfc_error ("Type mismatch in argument %qs at %L; passed %s to %s",
+ gfc_error (OPT_Wargument_mismatch,
+ "Type mismatch in argument %qs at %L; passed %s to %s",
formal->name, where, gfc_typename (&actual->ts),
gfc_typename (&formal->ts));
return 0;
@@ -2957,7 +2960,7 @@ compare_actual_formal (gfc_actual_arglist **ap, gfc_formal_arglist *formal,
f->sym->ts.u.cl->length->value.integer) != 0))
{
if (where && (f->sym->attr.pointer || f->sym->attr.allocatable))
- gfc_warning (0,
+ gfc_warning (OPT_Wargument_mismatch,
"Character length mismatch (%ld/%ld) between actual "
"argument and pointer or allocatable dummy argument "
"%qs at %L",
@@ -2965,7 +2968,7 @@ compare_actual_formal (gfc_actual_arglist **ap, gfc_formal_arglist *formal,
mpz_get_si (f->sym->ts.u.cl->length->value.integer),
f->sym->name, &a->expr->where);
else if (where)
- gfc_warning (0,
+ gfc_warning (OPT_Wargument_mismatch,
"Character length mismatch (%ld/%ld) between actual "
"argument and assumed-shape dummy argument %qs "
"at %L",
@@ -2997,12 +3000,14 @@ compare_actual_formal (gfc_actual_arglist **ap, gfc_formal_arglist *formal,
&& f->sym->attr.flavor != FL_PROCEDURE)
{
if (a->expr->ts.type == BT_CHARACTER && !f->sym->as && where)
- gfc_warning (0, "Character length of actual argument shorter "
+ gfc_warning (OPT_Wargument_mismatch,
+ "Character length of actual argument shorter "
"than of dummy argument %qs (%lu/%lu) at %L",
f->sym->name, actual_size, formal_size,
&a->expr->where);
else if (where)
- gfc_warning (0, "Actual argument contains too few "
+ gfc_warning (OPT_Wargument_mismatch,
+ "Actual argument contains too few "
"elements for dummy argument %qs (%lu/%lu) at %L",
f->sym->name, actual_size, formal_size,
&a->expr->where);
@@ -4547,7 +4552,8 @@ gfc_check_typebound_override (gfc_symtree* proc, gfc_symtree* old)
if (!gfc_check_dummy_characteristics (proc_formal->sym, old_formal->sym,
check_type, err, sizeof(err)))
{
- gfc_error ("Argument mismatch for the overriding procedure "
+ gfc_error (OPT_Wargument_mismatch,
+ "Argument mismatch for the overriding procedure "
"%qs at %L: %s", proc->name, &where, err);
return false;
}
diff --git a/gcc/fortran/invoke.texi b/gcc/fortran/invoke.texi
index ebf3aba8d4a..39a0232f71a 100644
--- a/gcc/fortran/invoke.texi
+++ b/gcc/fortran/invoke.texi
@@ -141,7 +141,7 @@ by type. Explanations are in the following sections.
@item Error and Warning Options
@xref{Error and Warning Options,,Options to request or suppress errors
and warnings}.
-@gccoptlist{-Waliasing -Wall -Wampersand -Warray-bounds
+@gccoptlist{-Waliasing -Wall -Wampersand -Wargument-mismatch -Warray-bounds
-Wc-binding-type -Wcharacter-truncation @gol
-Wconversion -Wfunction-elimination -Wimplicit-interface @gol
-Wimplicit-procedure -Wintrinsic-shadow -Wuse-without-only -Wintrinsics-std @gol
@@ -749,8 +749,10 @@ Check the code for syntax errors, but do not actually compile it. This
will generate module files for each module present in the code, but no
other output file.
-@item -pedantic
+@item -Wpedantic
+@itemx -pedantic
@opindex @code{pedantic}
+@opindex @code{Wpedantic}
Issue warnings for uses of extensions to Fortran 95.
@option{-pedantic} also applies to C-language constructs where they
occur in GNU Fortran source files, such as use of @samp{\e} in a
@@ -821,6 +823,15 @@ given in a continued character constant, GNU Fortran assumes continuation
at the first non-comment, non-whitespace character after the ampersand
that initiated the continuation.
+@item -Wargument-mismatch
+@opindex @code{Wargument-mismatch}
+@cindex warnings, argument mismatch
+@cindex warnings, parameter mismatch
+@cindex warnings, interface mismatch
+Warn about type, rank, and other mismatches between formal parameters and actual
+arguments to functions and subroutines. These warnings are recommended and
+thus enabled by default.
+
@item -Warray-temporaries
@opindex @code{Warray-temporaries}
@cindex warnings, array temporaries
diff --git a/gcc/fortran/io.c b/gcc/fortran/io.c
index dce0f7cd970..04cc1a25358 100644
--- a/gcc/fortran/io.c
+++ b/gcc/fortran/io.c
@@ -601,7 +601,7 @@ check_format (bool is_input)
const char *unexpected_end = _("Unexpected end of format string");
const char *zero_width = _("Zero width in format descriptor");
- const char *error;
+ const char *error = NULL;
format_token t, u;
int level;
int repeat;
@@ -867,27 +867,31 @@ data_desc:
goto fail;
if (t == FMT_POSINT)
break;
-
- switch (gfc_notification_std (GFC_STD_GNU))
+ if (mode != MODE_FORMAT)
+ format_locus.nextc += format_string_pos;
+ if (t == FMT_ZERO)
{
- case WARNING:
- if (mode != MODE_FORMAT)
- format_locus.nextc += format_string_pos;
- gfc_warning (0, "Extension: Missing positive width after L "
- "descriptor at %L", &format_locus);
- saved_token = t;
- break;
-
- case ERROR:
- error = posint_required;
- goto syntax;
-
- case SILENT:
- saved_token = t;
- break;
-
- default:
- gcc_unreachable ();
+ switch (gfc_notification_std (GFC_STD_GNU))
+ {
+ case WARNING:
+ gfc_warning (0, "Extension: Zero width after L "
+ "descriptor at %L", &format_locus);
+ break;
+ case ERROR:
+ gfc_error ("Extension: Zero width after L "
+ "descriptor at %L", &format_locus);
+ goto fail;
+ case SILENT:
+ break;
+ default:
+ gcc_unreachable ();
+ }
+ }
+ else
+ {
+ saved_token = t;
+ gfc_notify_std (GFC_STD_GNU, "Missing positive width after "
+ "L descriptor at %L", &format_locus);
}
break;
@@ -4163,6 +4167,10 @@ get_io_list:
goto syntax;
}
+ /* See if we want to use defaults for missing exponents in real transfers. */
+ if (flag_dec)
+ dt->default_exp = 1;
+
/* A full IO statement has been matched. Check the constraints. spec_end is
supplied for cases where no locus is supplied. */
m = check_io_constraints (k, dt, io_code, &spec_end);
diff --git a/gcc/fortran/ioparm.def b/gcc/fortran/ioparm.def
index f1bf7330fd0..46691874e10 100644
--- a/gcc/fortran/ioparm.def
+++ b/gcc/fortran/ioparm.def
@@ -118,4 +118,5 @@ IOPARM (dt, round, 1 << 23, char2)
IOPARM (dt, sign, 1 << 24, char1)
#define IOPARM_dt_f2003 (1 << 25)
#define IOPARM_dt_dtio (1 << 26)
+#define IOPARM_dt_default_exp (1 << 27)
IOPARM (dt, u, 0, pad)
diff --git a/gcc/fortran/iresolve.c b/gcc/fortran/iresolve.c
index 078e47dbaa0..b289c9f6840 100644
--- a/gcc/fortran/iresolve.c
+++ b/gcc/fortran/iresolve.c
@@ -1044,15 +1044,19 @@ gfc_resolve_extends_type_of (gfc_expr *f, gfc_expr *a, gfc_expr *mo)
gfc_add_vptr_component (a);
else if (a->ts.type == BT_DERIVED)
{
+ locus where;
+
vtab = gfc_find_derived_vtab (a->ts.u.derived);
/* Clear the old expr. */
gfc_free_ref_list (a->ref);
+ where = a->where;
memset (a, '\0', sizeof (gfc_expr));
/* Construct a new one. */
a->expr_type = EXPR_VARIABLE;
st = gfc_find_symtree (vtab->ns->sym_root, vtab->name);
a->symtree = st;
a->ts = vtab->ts;
+ a->where = where;
}
/* Replace the second argument with the corresponding vtab. */
@@ -1060,8 +1064,11 @@ gfc_resolve_extends_type_of (gfc_expr *f, gfc_expr *a, gfc_expr *mo)
gfc_add_vptr_component (mo);
else if (mo->ts.type == BT_DERIVED)
{
+ locus where;
+
vtab = gfc_find_derived_vtab (mo->ts.u.derived);
/* Clear the old expr. */
+ where = mo->where;
gfc_free_ref_list (mo->ref);
memset (mo, '\0', sizeof (gfc_expr));
/* Construct a new one. */
@@ -1069,6 +1076,7 @@ gfc_resolve_extends_type_of (gfc_expr *f, gfc_expr *a, gfc_expr *mo)
st = gfc_find_symtree (vtab->ns->sym_root, vtab->name);
mo->symtree = st;
mo->ts = vtab->ts;
+ mo->where = where;
}
f->ts.type = BT_LOGICAL;
diff --git a/gcc/fortran/lang.opt b/gcc/fortran/lang.opt
index 2e7640302ee..e39e555792f 100644
--- a/gcc/fortran/lang.opt
+++ b/gcc/fortran/lang.opt
@@ -209,6 +209,10 @@ Warray-temporaries
Fortran Warning Var(warn_array_temporaries)
Warn about creation of array temporaries.
+Wargument-mismatch
+Fortran Warning Var(warn_argument_mismatch) Init(1)
+Warn about type and rank mismatches between arguments and parameters.
+
Wc-binding-type
Fortran Var(warn_c_binding_type) Warning LangEnabledBy(Fortran,Wall)
Warn if the type of a variable might be not interoperable with C.
diff --git a/gcc/fortran/match.c b/gcc/fortran/match.c
index 0996a9efae6..5a7451ec9c4 100644
--- a/gcc/fortran/match.c
+++ b/gcc/fortran/match.c
@@ -5898,6 +5898,7 @@ gfc_match_select_type (void)
{
expr1 = gfc_get_expr ();
expr1->expr_type = EXPR_VARIABLE;
+ expr1->where = expr2->where;
if (gfc_get_sym_tree (name, NULL, &expr1->symtree, false))
{
m = MATCH_ERROR;
@@ -6219,6 +6220,7 @@ match_simple_where (void)
c->next = XCNEW (gfc_code);
*c->next = new_st;
+ c->next->loc = gfc_current_locus;
gfc_clear_new_st ();
new_st.op = EXEC_WHERE;
@@ -6275,8 +6277,12 @@ gfc_match_where (gfc_statement *st)
c = gfc_get_code (EXEC_WHERE);
c->expr1 = expr;
+ /* Put in the assignment. It will not be processed by add_statement, so we
+ need to copy the location here. */
+
c->next = XCNEW (gfc_code);
*c->next = new_st;
+ c->next->loc = gfc_current_locus;
gfc_clear_new_st ();
new_st.op = EXEC_WHERE;
diff --git a/gcc/fortran/parse.c b/gcc/fortran/parse.c
index 2aa2afc24e8..0ee054a014c 100644
--- a/gcc/fortran/parse.c
+++ b/gcc/fortran/parse.c
@@ -352,6 +352,9 @@ decode_statement (void)
}
gfc_matching_function = false;
+ /* Legacy parameter statements are ambiguous with assignments so try parameter
+ first. */
+ match ("parameter", gfc_match_parameter, ST_PARAMETER);
/* Match statements whose error messages are meant to be overwritten
by something better. */
@@ -528,7 +531,6 @@ decode_statement (void)
case 'p':
match ("print", gfc_match_print, ST_WRITE);
- match ("parameter", gfc_match_parameter, ST_PARAMETER);
match ("pause", gfc_match_pause, ST_PAUSE);
match ("pointer", gfc_match_pointer, ST_ATTR_DECL);
if (gfc_match_private (&st) == MATCH_YES)
diff --git a/gcc/fortran/primary.c b/gcc/fortran/primary.c
index bcbaeaa6369..50d7072b670 100644
--- a/gcc/fortran/primary.c
+++ b/gcc/fortran/primary.c
@@ -483,7 +483,7 @@ backup:
static match
match_real_constant (gfc_expr **result, int signflag)
{
- int kind, count, seen_dp, seen_digits, is_iso_c;
+ int kind, count, seen_dp, seen_digits, is_iso_c, default_exponent;
locus old_loc, temp_loc;
char *p, *buffer, c, exp_char;
gfc_expr *e;
@@ -494,6 +494,7 @@ match_real_constant (gfc_expr **result, int signflag)
e = NULL;
+ default_exponent = 0;
count = 0;
seen_dp = 0;
seen_digits = 0;
@@ -575,8 +576,14 @@ match_real_constant (gfc_expr **result, int signflag)
if (!ISDIGIT (c))
{
- gfc_error ("Missing exponent in real number at %C");
- return MATCH_ERROR;
+ /* With -fdec, default exponent to 0 instead of complaining. */
+ if (flag_dec)
+ default_exponent = 1;
+ else
+ {
+ gfc_error ("Missing exponent in real number at %C");
+ return MATCH_ERROR;
+ }
}
while (ISDIGIT (c))
@@ -597,8 +604,8 @@ done:
gfc_current_locus = old_loc;
gfc_gobble_whitespace ();
- buffer = (char *) alloca (count + 1);
- memset (buffer, '\0', count + 1);
+ buffer = (char *) alloca (count + default_exponent + 1);
+ memset (buffer, '\0', count + default_exponent + 1);
p = buffer;
c = gfc_next_ascii_char ();
@@ -621,6 +628,8 @@ done:
c = gfc_next_ascii_char ();
}
+ if (default_exponent)
+ *p++ = '0';
kind = get_kind (&is_iso_c);
if (kind == -1)
@@ -1353,6 +1362,10 @@ match_complex_constant (gfc_expr **result)
if (gfc_match_char (',') == MATCH_NO)
{
+ /* It is possible that gfc_int2real issued a warning when
+ converting an integer to real. Throw this away here. */
+
+ gfc_clear_warning ();
gfc_pop_error (&old_error);
m = MATCH_NO;
goto cleanup;
@@ -1918,15 +1931,36 @@ gfc_match_varspec (gfc_expr *primary, int equiv_flag, bool sub_flag,
}
/* For associate names, we may not yet know whether they are arrays or not.
- Thus if we have one and parentheses follow, we have to assume that it
- actually is one for now. The final decision will be made at
- resolution time, of course. */
- if (sym->assoc && gfc_peek_ascii_char () == '('
- && !(sym->assoc->dangling && sym->assoc->st
+ If the selector expression is unambiguously an array; eg. a full array
+ or an array section, then the associate name must be an array and we can
+ fix it now. Otherwise, if parentheses follow and it is not a character
+ type, we have to assume that it actually is one for now. The final
+ decision will be made at resolution, of course. */
+ if (sym->assoc
+ && gfc_peek_ascii_char () == '('
+ && sym->ts.type != BT_CLASS
+ && !sym->attr.dimension)
+ {
+ if ((!sym->assoc->dangling
+ && sym->assoc->target
+ && sym->assoc->target->ref
+ && sym->assoc->target->ref->type == REF_ARRAY
+ && (sym->assoc->target->ref->u.ar.type == AR_FULL
+ || sym->assoc->target->ref->u.ar.type == AR_SECTION))
+ ||
+ (!(sym->assoc->dangling || sym->ts.type == BT_CHARACTER)
+ && sym->assoc->st
&& sym->assoc->st->n.sym
- && sym->assoc->st->n.sym->attr.dimension == 0)
- && sym->ts.type != BT_CLASS)
+ && sym->assoc->st->n.sym->attr.dimension == 0))
+ {
sym->attr.dimension = 1;
+ if (sym->as == NULL && sym->assoc
+ && sym->assoc->st
+ && sym->assoc->st->n.sym
+ && sym->assoc->st->n.sym->as)
+ sym->as = gfc_copy_array_spec (sym->assoc->st->n.sym->as);
+ }
+ }
if ((equiv_flag && gfc_peek_ascii_char () == '(')
|| gfc_peek_ascii_char () == '[' || sym->attr.codimension
diff --git a/gcc/fortran/resolve.c b/gcc/fortran/resolve.c
index f9d11be5997..f4d346ed0f3 100644
--- a/gcc/fortran/resolve.c
+++ b/gcc/fortran/resolve.c
@@ -1317,7 +1317,8 @@ resolve_structure_cons (gfc_expr *expr, int init)
if (s2 && !gfc_compare_interfaces (comp->ts.interface, s2, name, 0, 1,
err, sizeof (err), NULL, NULL))
{
- gfc_error ("Interface mismatch for procedure-pointer component "
+ gfc_error (OPT_Wargument_mismatch,
+ "Interface mismatch for procedure-pointer component "
"%qs in structure constructor at %L: %s",
comp->name, &cons->expr->where, err);
return false;
@@ -2139,7 +2140,8 @@ resolve_elemental_actual (gfc_expr *expr, gfc_code *c)
&& (set_by_optional || arg->expr->rank != rank)
&& !(isym && isym->id == GFC_ISYM_CONVERSION))
{
- gfc_warning (0, "%qs at %L is an array and OPTIONAL; IF IT IS "
+ gfc_warning (OPT_Wpedantic,
+ "%qs at %L is an array and OPTIONAL; IF IT IS "
"MISSING, it cannot be the actual argument of an "
"ELEMENTAL procedure unless there is a non-optional "
"argument with the same rank (12.4.1.5)",
@@ -2469,7 +2471,8 @@ resolve_global_procedure (gfc_symbol *sym, locus *where,
if (!gfc_compare_interfaces (sym, def_sym, sym->name, 0, 1,
reason, sizeof(reason), NULL, NULL))
{
- gfc_error ("Interface mismatch in global procedure %qs at %L: %s ",
+ gfc_error (OPT_Wargument_mismatch,
+ "Interface mismatch in global procedure %qs at %L: %s ",
sym->name, &sym->declared_at, reason);
goto done;
}
@@ -3809,7 +3812,8 @@ resolve_operator (gfc_expr *e)
else
msg = "Inequality comparison for %s at %L";
- gfc_warning (0, msg, gfc_typename (&op1->ts), &op1->where);
+ gfc_warning (OPT_Wcompare_reals, msg,
+ gfc_typename (&op1->ts), &op1->where);
}
}
@@ -7044,35 +7048,6 @@ conformable_arrays (gfc_expr *e1, gfc_expr *e2)
return true;
}
-static void
-cond_init (gfc_code *code, gfc_expr *e, int pointer, gfc_expr *init_e)
-{
- gfc_code *block;
- gfc_expr *cond;
- gfc_code *init_st;
- gfc_expr *e_to_init = gfc_expr_to_initialize (e);
-
- cond = pointer
- ? gfc_build_intrinsic_call (gfc_current_ns, GFC_ISYM_ASSOCIATED,
- "associated", code->loc, 2, gfc_copy_expr (e_to_init), NULL)
- : gfc_build_intrinsic_call (gfc_current_ns, GFC_ISYM_ALLOCATED,
- "allocated", code->loc, 1, gfc_copy_expr (e_to_init));
-
- init_st = gfc_get_code (EXEC_INIT_ASSIGN);
- init_st->loc = code->loc;
- init_st->expr1 = e_to_init;
- init_st->expr2 = init_e;
-
- block = gfc_get_code (EXEC_IF);
- block->loc = code->loc;
- block->block = gfc_get_code (EXEC_IF);
- block->block->loc = code->loc;
- block->block->expr1 = cond;
- block->block->next = init_st;
- block->next = code->next;
-
- code->next = block;
-}
/* Resolve the expression in an ALLOCATE statement, doing the additional
checks to see whether the expression is OK or not. The expression must
@@ -7323,34 +7298,6 @@ resolve_allocate_expr (gfc_expr *e, gfc_code *code, bool *array_alloc_wo_spec)
/* We have to zero initialize the integer variable. */
code->expr3 = gfc_get_int_expr (gfc_default_integer_kind, &e->where, 0);
}
- else if (!code->expr3)
- {
- /* Set up default initializer if needed. */
- gfc_typespec ts;
- gfc_expr *init_e;
-
- if (gfc_bt_struct (code->ext.alloc.ts.type))
- ts = code->ext.alloc.ts;
- else
- ts = e->ts;
-
- if (ts.type == BT_CLASS)
- ts = ts.u.derived->components->ts;
-
- if (gfc_bt_struct (ts.type) && (init_e = gfc_default_initializer (&ts)))
- cond_init (code, e, pointer, init_e);
- }
- else if (code->expr3->mold && code->expr3->ts.type == BT_DERIVED)
- {
- /* Default initialization via MOLD (non-polymorphic). */
- gfc_expr *rhs = gfc_default_initializer (&code->expr3->ts);
- if (rhs != NULL)
- {
- gfc_resolve_expr (rhs);
- gfc_free_expr (code->expr3);
- code->expr3 = rhs;
- }
- }
if (e->ts.type == BT_CLASS && !unlimited && !UNLIMITED_POLY (code->expr3))
{
@@ -7362,10 +7309,9 @@ resolve_allocate_expr (gfc_expr *e, gfc_code *code, bool *array_alloc_wo_spec)
else if (code->ext.alloc.ts.type == BT_DERIVED)
ts = code->ext.alloc.ts;
+ /* Finding the vtab also publishes the type's symbol. Therefore this
+ statement is necessary. */
gfc_find_derived_vtab (ts.u.derived);
-
- if (dimension)
- e = gfc_expr_to_initialize (e);
}
else if (unlimited && !UNLIMITED_POLY (code->expr3))
{
@@ -7379,10 +7325,9 @@ resolve_allocate_expr (gfc_expr *e, gfc_code *code, bool *array_alloc_wo_spec)
gcc_assert (ts);
+ /* Finding the vtab also publishes the type's symbol. Therefore this
+ statement is necessary. */
gfc_find_vtab (ts);
-
- if (dimension)
- e = gfc_expr_to_initialize (e);
}
if (dimension == 0 && codimension == 0)
@@ -7686,6 +7631,22 @@ resolve_allocate_deallocate (gfc_code *code, const char *fcn)
if (strcmp (fcn, "ALLOCATE") == 0)
{
bool arr_alloc_wo_spec = false;
+
+ /* Resolving the expr3 in the loop over all objects to allocate would
+ execute loop invariant code for each loop item. Therefore do it just
+ once here. */
+ if (code->expr3 && code->expr3->mold
+ && code->expr3->ts.type == BT_DERIVED)
+ {
+ /* Default initialization via MOLD (non-polymorphic). */
+ gfc_expr *rhs = gfc_default_initializer (&code->expr3->ts);
+ if (rhs != NULL)
+ {
+ gfc_resolve_expr (rhs);
+ gfc_free_expr (code->expr3);
+ code->expr3 = rhs;
+ }
+ }
for (a = code->ext.alloc.list; a; a = a->next)
resolve_allocate_expr (a->expr, code, &arr_alloc_wo_spec);
@@ -8496,6 +8457,7 @@ build_loc_call (gfc_expr *sym_expr)
loc_call->value.function.isym = gfc_intrinsic_function_by_id (GFC_ISYM_LOC);
loc_call->value.function.actual = gfc_get_actual_arglist ();
loc_call->value.function.actual->expr = sym_expr;
+ loc_call->where = sym_expr->where;
return loc_call;
}
@@ -8895,11 +8857,13 @@ resolve_select_type (gfc_code *code, gfc_namespace *old_ns)
new_st->expr1->value.function.actual = gfc_get_actual_arglist ();
new_st->expr1->value.function.actual->expr = gfc_get_variable_expr (selector_expr->symtree);
new_st->expr1->value.function.actual->expr->where = code->loc;
+ new_st->expr1->where = code->loc;
gfc_add_vptr_component (new_st->expr1->value.function.actual->expr);
vtab = gfc_find_derived_vtab (body->ext.block.case_list->ts.u.derived);
st = gfc_find_symtree (vtab->ns->sym_root, vtab->name);
new_st->expr1->value.function.actual->next = gfc_get_actual_arglist ();
new_st->expr1->value.function.actual->next->expr = gfc_get_variable_expr (st);
+ new_st->expr1->value.function.actual->next->expr->where = code->loc;
new_st->next = body->next;
}
if (default_case->next)
@@ -14037,6 +14001,15 @@ resolve_fl_parameter (gfc_symbol *sym)
&sym->value->where);
return false;
}
+
+ /* F03:C509,C514. */
+ if (sym->ts.type == BT_CLASS)
+ {
+ gfc_error ("CLASS variable %qs at %L cannot have the PARAMETER attribute",
+ sym->name, &sym->declared_at);
+ return false;
+ }
+
return true;
}
@@ -15391,12 +15364,13 @@ warn_unused_fortran_label (gfc_st_label *label)
switch (label->referenced)
{
case ST_LABEL_UNKNOWN:
- gfc_warning (0, "Label %d at %L defined but not used", label->value,
- &label->where);
+ gfc_warning (OPT_Wunused_label, "Label %d at %L defined but not used",
+ label->value, &label->where);
break;
case ST_LABEL_BAD_TARGET:
- gfc_warning (0, "Label %d at %L defined but cannot be used",
+ gfc_warning (OPT_Wunused_label,
+ "Label %d at %L defined but cannot be used",
label->value, &label->where);
break;
diff --git a/gcc/fortran/symbol.c b/gcc/fortran/symbol.c
index cbe4347351f..85ed375e297 100644
--- a/gcc/fortran/symbol.c
+++ b/gcc/fortran/symbol.c
@@ -4901,7 +4901,7 @@ gfc_type_compatible (gfc_typespec *ts1, gfc_typespec *ts2)
&& !is_union1 && !is_union2)
return (ts1->type == ts2->type);
- if ((is_derived1 && is_derived2) || (is_union1 && is_union1))
+ if ((is_derived1 && is_derived2) || (is_union1 && is_union2))
return gfc_compare_derived_types (ts1->u.derived, ts2->u.derived);
if (is_derived1 && is_class2)
diff --git a/gcc/fortran/trans-array.c b/gcc/fortran/trans-array.c
index 74935b181f6..1708f7c8e44 100644
--- a/gcc/fortran/trans-array.c
+++ b/gcc/fortran/trans-array.c
@@ -5623,14 +5623,6 @@ gfc_array_allocate (gfc_se * se, gfc_expr * expr, tree status, tree errmsg,
else
gfc_add_expr_to_block (&se->pre, set_descriptor);
- if (expr->ts.type == BT_DERIVED && expr->ts.u.derived->attr.alloc_comp
- && !coarray)
- {
- tmp = gfc_nullify_alloc_comp (expr->ts.u.derived, se->expr,
- ref->u.ar.as->rank);
- gfc_add_expr_to_block (&se->pre, tmp);
- }
-
return true;
}
diff --git a/gcc/fortran/trans-common.c b/gcc/fortran/trans-common.c
index ee12fa22dc0..0c030584b68 100644
--- a/gcc/fortran/trans-common.c
+++ b/gcc/fortran/trans-common.c
@@ -1149,13 +1149,13 @@ translate_common (gfc_common_head *common, gfc_symbol *var_list)
if (warn_align_commons)
{
if (strcmp (common->name, BLANK_COMMON_NAME))
- gfc_warning (0,
+ gfc_warning (OPT_Walign_commons,
"Padding of %d bytes required before %qs in "
"COMMON %qs at %L; reorder elements or use "
"-fno-align-commons", (int)offset,
s->sym->name, common->name, &common->where);
else
- gfc_warning (0,
+ gfc_warning (OPT_Walign_commons,
"Padding of %d bytes required before %qs in "
"COMMON at %L; reorder elements or use "
"-fno-align-commons", (int)offset,
diff --git a/gcc/fortran/trans-expr.c b/gcc/fortran/trans-expr.c
index 7159b172eea..61214295f66 100644
--- a/gcc/fortran/trans-expr.c
+++ b/gcc/fortran/trans-expr.c
@@ -1091,6 +1091,12 @@ gfc_conv_class_to_class (gfc_se *parmse, gfc_expr *e, gfc_typespec class_ts,
tmp = integer_zero_node;
gfc_add_modify (&parmse->pre, ctree,
fold_convert (TREE_TYPE (ctree), tmp));
+
+ /* Return the len component, except in the case of scalarized array
+ references, where the dynamic type cannot change. */
+ if (!elemental && full_array && copyback)
+ gfc_add_modify (&parmse->post, tmp,
+ fold_convert (TREE_TYPE (tmp), ctree));
}
if (optional)
@@ -10036,7 +10042,7 @@ gfc_trans_assignment (gfc_expr * expr1, gfc_expr * expr2, bool init_flag,
tree
gfc_trans_init_assign (gfc_code * code)
{
- return gfc_trans_assignment (code->expr1, code->expr2, true, false);
+ return gfc_trans_assignment (code->expr1, code->expr2, true, false, true);
}
tree
diff --git a/gcc/fortran/trans-io.c b/gcc/fortran/trans-io.c
index 285e551585c..253a5ac70a9 100644
--- a/gcc/fortran/trans-io.c
+++ b/gcc/fortran/trans-io.c
@@ -1911,6 +1911,9 @@ build_dt (tree function, gfc_code * code)
if (dt->udtio)
mask |= IOPARM_dt_dtio;
+ if (dt->default_exp)
+ mask |= IOPARM_dt_default_exp;
+
if (dt->namelist)
{
if (dt->format_expr || dt->format_label)
diff --git a/gcc/fortran/trans-stmt.c b/gcc/fortran/trans-stmt.c
index c52066ffd20..490b18dae31 100644
--- a/gcc/fortran/trans-stmt.c
+++ b/gcc/fortran/trans-stmt.c
@@ -5450,13 +5450,41 @@ gfc_trans_exit (gfc_code * code)
}
+/* Get the initializer expression for the code and expr of an allocate.
+ When no initializer is needed return NULL. */
+
+static gfc_expr *
+allocate_get_initializer (gfc_code * code, gfc_expr * expr)
+{
+ if (!gfc_bt_struct (expr->ts.type) && expr->ts.type != BT_CLASS)
+ return NULL;
+
+ /* An explicit type was given in allocate ( T:: object). */
+ if (code->ext.alloc.ts.type == BT_DERIVED
+ && (code->ext.alloc.ts.u.derived->attr.alloc_comp
+ || gfc_has_default_initializer (code->ext.alloc.ts.u.derived)))
+ return gfc_default_initializer (&code->ext.alloc.ts);
+
+ if (gfc_bt_struct (expr->ts.type)
+ && (expr->ts.u.derived->attr.alloc_comp
+ || gfc_has_default_initializer (expr->ts.u.derived)))
+ return gfc_default_initializer (&expr->ts);
+
+ if (expr->ts.type == BT_CLASS
+ && (CLASS_DATA (expr)->ts.u.derived->attr.alloc_comp
+ || gfc_has_default_initializer (CLASS_DATA (expr)->ts.u.derived)))
+ return gfc_default_initializer (&CLASS_DATA (expr)->ts);
+
+ return NULL;
+}
+
/* Translate the ALLOCATE statement. */
tree
gfc_trans_allocate (gfc_code * code)
{
gfc_alloc *al;
- gfc_expr *expr, *e3rhs = NULL;
+ gfc_expr *expr, *e3rhs = NULL, *init_expr;
gfc_se se, se_sz;
tree tmp;
tree parm;
@@ -6080,14 +6108,6 @@ gfc_trans_allocate (gfc_code * code)
label_finish, expr, 0);
else
gfc_allocate_using_malloc (&se.pre, se.expr, memsz, stat);
-
- if (al->expr->ts.type == BT_DERIVED
- && expr->ts.u.derived->attr.alloc_comp)
- {
- tmp = build_fold_indirect_ref_loc (input_location, se.expr);
- tmp = gfc_nullify_alloc_comp (expr->ts.u.derived, tmp, 0);
- gfc_add_expr_to_block (&se.pre, tmp);
- }
}
else
{
@@ -6217,6 +6237,8 @@ gfc_trans_allocate (gfc_code * code)
fold_convert (TREE_TYPE (al_len),
integer_zero_node));
}
+
+ init_expr = NULL;
if (code->expr3 && !code->expr3->mold && e3_is != E3_MOLD)
{
/* Initialization via SOURCE block (or static default initializer).
@@ -6246,6 +6268,23 @@ gfc_trans_allocate (gfc_code * code)
gfc_free_statements (ini);
gfc_add_expr_to_block (&block, tmp);
}
+ else if ((init_expr = allocate_get_initializer (code, expr)))
+ {
+ /* Use class_init_assign to initialize expr. */
+ gfc_code *ini;
+ int realloc_lhs = flag_realloc_lhs;
+ ini = gfc_get_code (EXEC_INIT_ASSIGN);
+ ini->expr1 = gfc_expr_to_initialize (expr);
+ ini->expr2 = init_expr;
+ flag_realloc_lhs = 0;
+ tmp= gfc_trans_init_assign (ini);
+ flag_realloc_lhs = realloc_lhs;
+ gfc_free_statements (ini);
+ /* Init_expr is freeed by above free_statements, just need to null
+ it here. */
+ init_expr = NULL;
+ gfc_add_expr_to_block (&block, tmp);
+ }
gfc_free_expr (expr);
} // for-loop
diff --git a/gcc/fortran/trans-types.c b/gcc/fortran/trans-types.c
index eda0351119a..6f9bc381df6 100644
--- a/gcc/fortran/trans-types.c
+++ b/gcc/fortran/trans-types.c
@@ -3139,7 +3139,7 @@ gfc_get_array_descr_info (const_tree type, struct array_descr_info *info)
int rank, dim;
bool indirect = false;
tree etype, ptype, field, t, base_decl;
- tree data_off, dim_off, dim_size, elem_size;
+ tree data_off, dim_off, dtype_off, dim_size, elem_size;
tree lower_suboff, upper_suboff, stride_suboff;
if (! GFC_DESCRIPTOR_TYPE_P (type))
@@ -3203,6 +3203,7 @@ gfc_get_array_descr_info (const_tree type, struct array_descr_info *info)
data_off = byte_position (field);
field = DECL_CHAIN (field);
field = DECL_CHAIN (field);
+ dtype_off = byte_position (field);
field = DECL_CHAIN (field);
dim_off = byte_position (field);
dim_size = TYPE_SIZE_UNIT (TREE_TYPE (TREE_TYPE (field)));
@@ -3225,6 +3226,24 @@ gfc_get_array_descr_info (const_tree type, struct array_descr_info *info)
|| GFC_TYPE_ARRAY_AKIND (type) == GFC_ARRAY_POINTER_CONT)
info->associated = build2 (NE_EXPR, boolean_type_node,
info->data_location, null_pointer_node);
+ if ((GFC_TYPE_ARRAY_AKIND (type) == GFC_ARRAY_ASSUMED_RANK
+ || GFC_TYPE_ARRAY_AKIND (type) == GFC_ARRAY_ASSUMED_RANK_CONT)
+ && dwarf_version >= 5)
+ {
+ rank = 1;
+ info->ndimensions = 1;
+ t = base_decl;
+ if (!integer_zerop (dtype_off))
+ t = fold_build_pointer_plus (t, dtype_off);
+ t = build1 (NOP_EXPR, build_pointer_type (gfc_array_index_type), t);
+ t = build1 (INDIRECT_REF, gfc_array_index_type, t);
+ info->rank = build2 (BIT_AND_EXPR, gfc_array_index_type, t,
+ build_int_cst (gfc_array_index_type,
+ GFC_DTYPE_RANK_MASK));
+ t = build0 (PLACEHOLDER_EXPR, TREE_TYPE (dim_off));
+ t = size_binop (MULT_EXPR, t, dim_size);
+ dim_off = build2 (PLUS_EXPR, TREE_TYPE (dim_off), t, dim_off);
+ }
for (dim = 0; dim < rank; dim++)
{
@@ -3260,7 +3279,8 @@ gfc_get_array_descr_info (const_tree type, struct array_descr_info *info)
t = build1 (INDIRECT_REF, gfc_array_index_type, t);
t = build2 (MULT_EXPR, gfc_array_index_type, t, elem_size);
info->dimen[dim].stride = t;
- dim_off = size_binop (PLUS_EXPR, dim_off, dim_size);
+ if (dim + 1 < rank)
+ dim_off = size_binop (PLUS_EXPR, dim_off, dim_size);
}
return true;
View Lorry Controller Status