aboutsummaryrefslogtreecommitdiff
path: root/gcc/fortran
diff options
context:
space:
mode:
Diffstat (limited to 'gcc/fortran')
-rw-r--r--gcc/fortran/ChangeLog304
-rw-r--r--gcc/fortran/check.c22
-rw-r--r--gcc/fortran/class.c4
-rw-r--r--gcc/fortran/decl.c29
-rw-r--r--gcc/fortran/expr.c87
-rw-r--r--gcc/fortran/frontend-passes.c27
-rw-r--r--gcc/fortran/gfortran.h7
-rw-r--r--gcc/fortran/interface.c11
-rw-r--r--gcc/fortran/invoke.texi36
-rw-r--r--gcc/fortran/iresolve.c5
-rw-r--r--gcc/fortran/lang.opt7
-rw-r--r--gcc/fortran/match.c2
-rw-r--r--gcc/fortran/parse.c10
-rw-r--r--gcc/fortran/resolve.c211
-rw-r--r--gcc/fortran/symbol.c17
-rw-r--r--gcc/fortran/target-memory.c1
-rw-r--r--gcc/fortran/trans-array.c40
-rw-r--r--gcc/fortran/trans-decl.c126
-rw-r--r--gcc/fortran/trans-expr.c27
-rw-r--r--gcc/fortran/trans-intrinsic.c25
-rw-r--r--gcc/fortran/trans-openmp.c6
-rw-r--r--gcc/fortran/trans-stmt.c3
-rw-r--r--gcc/fortran/trans-types.c19
23 files changed, 831 insertions, 195 deletions
diff --git a/gcc/fortran/ChangeLog b/gcc/fortran/ChangeLog
index 2110c0a18e8..f7ddfdd6377 100644
--- a/gcc/fortran/ChangeLog
+++ b/gcc/fortran/ChangeLog
@@ -1,3 +1,307 @@
+2019-10-18 Steven G. Kargl <kargl@gcc.gnu.org>
+
+ PR fortran/69455
+ * trans-decl.c (generate_local_decl): Avoid misconstructed
+ intrinsic modules in a BLOCK construct.
+
+2019-10-07 Thomas Koenig <tkoenig@gcc.gnu.org>
+
+ Backport from trunk
+ PR fortran/84487
+ * trans-decl.c (gfc_get_symbol_decl): For __def_init, set
+ DECL_ARTIFICAL and do not set TREE_READONLY.
+
+2019-09-28 Paul Thomas <pault@gcc.gnu.org>
+
+ Backport from mainline
+ PR fortran/91588
+ * expr.c (check_inquiry): Remove extended component refs by
+ using symbol pointers. If a function argument is an associate
+ variable with a constant target, copy the target expression in
+ place of the argument expression. Check that the charlen is not
+ NULL before using the string length.
+
+2019-09-18 Thomas Koenig <tkoenig@gcc.gnu.org>
+
+ Backport from trunk
+ PR fortran/91550
+ * frontend-passes.c (do_subscript): If step equals
+ zero, a previuos error has been reported; do nothing
+ in this case.
+ * resolve.c (gfc_resolve_iterator): Move error checking
+ after type conversion.
+
+2019-09-15 Thomas Koenig <tkoenig@gcc.gnu.org>
+
+ Backport from trunk
+ PR fortran/91557
+ * trans-decl.c (generate_local_decl): Do not warn if the symbol
+ is artificial.
+ * trans-types.c (get_formal_from_actual_arglist): Set artificial
+ attribute on dummy arguments.
+
+2013-08-13 Thomas Koenig <tkoenig@gcc.gnu.org>
+
+ Backport from trunk
+ PR fortran/90563
+ * frontend-passes.c (insert_index): Suppress errors while
+ simplifying the resulting expression.
+
+2019-08-02 Thomas Koenig <tkoenig@gcc.gnu.org>
+ Paul Thomas <pault@gcc.gnu.org>
+
+ Backport from trunk
+ PR fortran/90786
+ PR fortran/90813
+ * trans-expr.c (pointer_assignment_is_proc_pointer) Remove as
+ it is very simple and only called from one place.
+ (gfc_trans_pointer_assignment): Rename non_proc_pointer_assign
+ as non_proc_ptr_assign. Assign to it directly, rather than call
+ to above, deleted function and use gfc_expr_attr instead of
+ only checking the reference chain.
+ * trans-decl.c (sym_identifier): New function.
+ (mangled_identifier): New function, doing most of the work
+ of gfc_sym_mangled_identifier.
+ (gfc_sym_mangled_identifier): Use mangled_identifier. Add mangled
+ identifier to global symbol table.
+ (get_proc_pointer_decl): Use backend decl from global identifier
+ if present.
+
+2019-07-07 Paul Thomas <pault@gcc.gnu.org>
+
+ Backport from trunk
+ PR fortran/91077
+ * trans-array.c (gfc_conv_scalarized_array_ref) Delete code
+ that gave symbol backend decl for subref arrays.
+
+2019-06-21 Thomas Koenig <tkoenig@gcc.gnu.org>
+
+ Backport from trunk
+ PR fortran/90937
+ * trans-types.c (get_formal_from_actual_arglist): Get symbol from
+ current namespace so it will be freed later. If symbol is of type
+ character, get an empty character length.
+
+2019-06-12 Thomas Koenig <tkoenig@gcc.gnu.org>
+ Tomáš Trnka <trnka@scm.com>
+
+ Backport from trunk
+ PR fortran/90744
+ * trans-types.c (get_formal_from_actual_arglist): Unset typespec
+ flags which make no sense for procedures without explicit
+ interface.
+
+2019-06-10 Paul Thomas <pault@gcc.gnu.org>
+
+ Backport from trunk
+ PR fortran/90498
+ * trans-stmt.c (trans_associate_var) Do not use the saved
+ descriptor if the expression is a COMPONENT_REF.
+
+2019-06-09 Paul Thomas <pault@gcc.gnu.org>
+
+ Backport from trunk
+ PR fortran/57284
+ * resolve.c (find_array_spec): If this is a class expression
+ and the symbol and component array specs are the same, this is
+ not an error.
+ *trans-intrinsic.c (gfc_conv_intrinsic_size): If a class symbol
+ argument, has no namespace, it has come from the interface
+ mapping and the _data component must be accessed directly.
+
+2019-05-30 Marek Polacek <polacek@redhat.com>
+
+ * lang.opt (ftail-call-workaround): Fix a typo.
+
+2019-05-30 Jakub Jelinek <jakub@redhat.com>
+
+ * lang.opt (ftail-call-workaround=): Fix a typo - lenghts to lengths.
+
+2019-05-29 Jakub Jelinek <jakub@redhat.com>
+
+ PR fortran/90329
+ Backported from mainline
+ 2019-05-29 Jakub Jelinek <jakub@redhat.com>
+
+ PR fortran/90329
+ * lang.opt (fbroken-callers): Remove.
+ (ftail-call-workaround, ftail-call-workaround=): New options.
+ * gfortran.h (struct gfc_namespace): Add implicit_interface_calls.
+ * interface.c (gfc_procedure_use): Set implicit_interface_calls
+ for calls to implicit interface procedures.
+ * trans-decl.c (create_function_arglist): Use flag_tail_call_workaround
+ instead of flag_broken_callers. If it is not 2, also require
+ sym->ns->implicit_interface_calls.
+ * invoke.texi (fbroken-callers): Remove documentation.
+ (ftail-call-workaround, ftail-call-workaround=): Document.
+
+ 2019-05-19 Thomas Koenig <tkoenig@gcc.gnu.org>
+
+ PR fortran/90329
+ * invoke.texi: Document -fbroken-callers.
+ * lang.opt: Add -fbroken-callers.
+ * trans-decl.c (create_function_arglist): Only set
+ DECL_HIDDEN_STRING_LENGTH if flag_broken_callers is set.
+
+ 2019-05-16 Jakub Jelinek <jakub@redhat.com>
+
+ PR fortran/90329
+ * trans-decl.c (create_function_arglist): Set
+ DECL_HIDDEN_STRING_LENGTH on hidden string length PARM_DECLs if
+ len is constant.
+
+2019-04-30 Jakub Jelinek <jakub@redhat.com>
+
+ Backported from mainline
+ 2019-03-11 Jakub Jelinek <jakub@redhat.com>
+
+ PR fortran/89651
+ * trans-openmp.c (gfc_omp_clause_default_ctor): Set TREE_NO_WARNING
+ on decl if adding COND_EXPR for allocatable.
+ (gfc_omp_clause_copy_ctor): Set TREE_NO_WARNING on dest.
+
+2019-04-24 Paul Thomas <pault@gcc.gnu.org>
+
+ Backport from mainline
+ PR fortran/87127
+ * resolve.c (check_host_association): If an external function
+ is typed but not declared explicitly to be external, change the
+ old symbol from a variable to an external function.
+
+2019-04-14 Thomas Koenig <tkoenig@gcc.gnu.org>
+
+ Backport from trunk
+ PR fortran/87352
+ * gfortran.h (gfc_component): Add finalized field.
+ * class.c (finalize_component): If the component is already
+ finalized, return early. Set component->finalized on exit.
+
+2019-04-14 Thomas Koenig <tkoenig@gcc.gnu.org>
+
+ Backport from trunk
+ PR fortran/89981
+ * resolve.c (resolve_global_procedure): If the global symbol is an
+ ENTRY, also look up its name among the entries.
+
+2019-04-10 Harald Anlauf <anlauf@gmx.de>
+
+ Backport from trunk
+ PR fortran/89904
+ * check.c (gfc_check_transfer): Reject procedures as actual
+ arguments for SOURCE and MOLD of TRANSFER intrinsic.
+
+2019-03-31 Harald Anlauf <anlauf@gmx.de>
+
+ PR fortran/83515
+ PR fortran/85797
+ * trans-types.c (gfc_typenode_for_spec): Handle conversion for
+ procedure pointers.
+ * target-memory.c (gfc_element_size): Handle size determination
+ for procedure pointers.
+
+2019-03-30 Thomas Koenig <tkoenig@gcc.gnu.org>
+
+ PR fortran/78865
+ Backport from trunk
+ * interface.c (compare_actual_formal): Change errors about
+ missing or extra to gfc_error_now to make sure they are issued.
+ Change "spec" to "specifier" in message.
+ * resolve.c (resolve_global_procedure): Also check for mismatching
+ interface with global symbols if the namespace has already been
+ resolved.
+
+2019-03-24 Janus Weil <janus@gcc.gnu.org>
+
+ PR fortran/71861
+ Backport from trunk
+ * symbol.c (check_conflict): ABSTRACT attribute conflicts with
+ INTRINSIC attribute.
+
+2019-03-23 Thomas Koenig <tkoeng@gcc.gnu.org>
+
+ PR fortran/68009
+ Backport from trunk
+ * iresolve.c: Include trans.h.
+ (gfc_resolve_fe_runtine_error): Set backend_decl on
+ resolved_sym.
+
+2019-03-17 Thomas Koenig <tkoenig@gcc.gnu.org>
+
+ PR fortran/84394
+ Backport from trunk
+ * symbol.c (gfc_add_subroutine): If we are encountering a
+ subrtoutine within a BLOCK DATA and the name starts with an
+ underscore, do not check.
+
+2019-03-16 Thomas Koenig <tkoenig@gcc.gnu.org>
+
+ PR fortran/66089
+ Backport from trunk
+ * trans-array.c (gfc_scalar_elemental_arg_saved_as_reference):
+ Return false if a scalar tempoary is needed.
+ (gfc_walk_variable_expr): Fix up class refs.
+
+2019-03-16 Thomas Koenig <tkoenig@gcc.gnu.org>
+
+ PR fortran/66695
+ PR fortran/77746
+ PR fortran/79485
+ Backport from trunk
+ * gfortran.h (gfc_symbol): Add bind_c component.
+ (gfc_get_gsymbol): Add argument bind_c.
+ * decl.c (add_global_entry): Add bind_c argument to
+ gfc_get_symbol.
+ * parse.c (parse_block_data): Likewise.
+ (parse_module): Likewise.
+ (add_global_procedure): Likewise.
+ (add_global_program): Likewise.
+ * resolve.c (resolve_common_blocks): Likewise.
+ (resolve_global_procedure): Likewise.
+ (gfc_verify_binding_labels): Likewise.
+ * symbol.c (gfc_get_gsymbol): Add argument bind_c. Set bind_c
+ in gsym.
+ * trans-decl.c (gfc_get_module_backend_decl): Add bind_c argument
+ to gfc_get_symbol.
+ (gfc_get_extern_function_decl): If the sym has a binding label
+ and it cannot be found in the global symbol tabel, it is the wrong
+ one and vice versa.
+
+2019-03-13 Thomas Koenig <tkoenig@gcc.gnu.org>
+
+ PR fortran/87673
+ Backport from trunk
+ * match.c (gfc_match_type_spec): Remove call to
+ gfc_resolve_expr for character length.
+
+2019-03-10 Thomas Koenig <tkoenig@gcc.gnu.org>
+
+ PR fortran/71544
+ Backport from trunk
+ * trans-types.c (gfc_typenode_for_spec) Set ts->is_c_interop of
+ C_PTR and C_FUNPTR.
+ (create_fn_spec): Mark argument as escaping if ts->is_c_interop is set.
+
+2019-03-10 Thomas Koenig <tkoenig@gcc.gnu.org>
+ Steven G. Kargl <kargl@gcc.gnu.org>
+
+ PR fortran/87734
+ Backort from trunk
+ * symbol.c (gfc_add_procedure): Only throw an error if the
+ procedure has not been declared either PUBLIC or PRIVATE.
+ * resolve.c (is_illegal_recursion): Remove an assert().
+
+2019-03-06 Harald Anlauf <anlauf@gmx.de>
+
+ Backport from trunk
+ PR fortran/71203
+ * expr.c (simplify_const_ref): Avoid null pointer dereference.
+
+2019-03-06 Thomas Koenig <tkoenig@gcc.gnu.org>
+
+ PR fortran/72714
+ Backport from trunk
+ * resolve.c (resolve_allocate_expr): Add some tests for coarrays.
+
2019-03-03 Harald Anlauf <anlauf@gmx.de>
Backport from trunk
diff --git a/gcc/fortran/check.c b/gcc/fortran/check.c
index febf77fd3e7..2a24147cfe6 100644
--- a/gcc/fortran/check.c
+++ b/gcc/fortran/check.c
@@ -5477,6 +5477,26 @@ gfc_check_transfer (gfc_expr *source, gfc_expr *mold, gfc_expr *size)
size_t source_size;
size_t result_size;
+ /* SOURCE shall be a scalar or array of any type. */
+ if (source->ts.type == BT_PROCEDURE
+ && source->symtree->n.sym->attr.subroutine == 1)
+ {
+ gfc_error ("%<SOURCE%> argument of %<TRANSFER%> intrinsic at %L "
+ "must not be a %s", &source->where,
+ gfc_basic_typename (source->ts.type));
+ return false;
+ }
+
+ /* MOLD shall be a scalar or array of any type. */
+ if (mold->ts.type == BT_PROCEDURE
+ && mold->symtree->n.sym->attr.subroutine == 1)
+ {
+ gfc_error ("%<MOLD%> argument of %<TRANSFER%> intrinsic at %L "
+ "must not be a %s", &mold->where,
+ gfc_basic_typename (mold->ts.type));
+ return false;
+ }
+
if (mold->ts.type == BT_HOLLERITH)
{
gfc_error ("%<MOLD%> argument of %<TRANSFER%> intrinsic at %L must not be"
@@ -5484,6 +5504,8 @@ gfc_check_transfer (gfc_expr *source, gfc_expr *mold, gfc_expr *size)
return false;
}
+ /* SIZE (optional) shall be an integer scalar. The corresponding actual
+ argument shall not be an optional dummy argument. */
if (size != NULL)
{
if (!type_check (size, 2, BT_INTEGER))
diff --git a/gcc/fortran/class.c b/gcc/fortran/class.c
index cb9f0d9f23d..23a0468dedd 100644
--- a/gcc/fortran/class.c
+++ b/gcc/fortran/class.c
@@ -907,6 +907,9 @@ finalize_component (gfc_expr *expr, gfc_symbol *derived, gfc_component *comp,
if (!comp_is_finalizable (comp))
return;
+ if (comp->finalized)
+ return;
+
e = gfc_copy_expr (expr);
if (!e->ref)
e->ref = ref = gfc_get_ref ();
@@ -1034,6 +1037,7 @@ finalize_component (gfc_expr *expr, gfc_symbol *derived, gfc_component *comp,
sub_ns);
gfc_free_expr (e);
}
+ comp->finalized = true;
}
diff --git a/gcc/fortran/decl.c b/gcc/fortran/decl.c
index 41b1a992a57..e138375607d 100644
--- a/gcc/fortran/decl.c
+++ b/gcc/fortran/decl.c
@@ -3899,7 +3899,6 @@ gfc_match_decl_type_spec (gfc_typespec *ts, int implicit_flag)
return MATCH_YES;
}
-
m = gfc_match (" type (");
matched_type = (m == MATCH_YES);
if (matched_type)
@@ -3948,7 +3947,10 @@ gfc_match_decl_type_spec (gfc_typespec *ts, int implicit_flag)
m = MATCH_YES;
if (matched_type && m == MATCH_YES && gfc_match_char (')') != MATCH_YES)
- m = MATCH_ERROR;
+ {
+ gfc_error ("Malformed type-spec at %C");
+ return MATCH_ERROR;
+ }
return m;
}
@@ -3971,8 +3973,12 @@ gfc_match_decl_type_spec (gfc_typespec *ts, int implicit_flag)
&& !gfc_notify_std (GFC_STD_F2008, "TYPE with "
"intrinsic-type-spec at %C"))
return MATCH_ERROR;
+
if (matched_type && gfc_match_char (')') != MATCH_YES)
- return MATCH_ERROR;
+ {
+ gfc_error ("Malformed type-spec at %C");
+ return MATCH_ERROR;
+ }
ts->type = BT_REAL;
ts->kind = gfc_default_double_kind;
@@ -4002,7 +4008,10 @@ gfc_match_decl_type_spec (gfc_typespec *ts, int implicit_flag)
return MATCH_ERROR;
if (matched_type && gfc_match_char (')') != MATCH_YES)
- return MATCH_ERROR;
+ {
+ gfc_error ("Malformed type-spec at %C");
+ return MATCH_ERROR;
+ }
ts->type = BT_COMPLEX;
ts->kind = gfc_default_double_kind;
@@ -4023,7 +4032,13 @@ gfc_match_decl_type_spec (gfc_typespec *ts, int implicit_flag)
if (m == MATCH_ERROR)
return m;
- m = gfc_match_char (')');
+ gfc_gobble_whitespace ();
+ if (gfc_peek_ascii_char () != ')')
+ {
+ gfc_error ("Malformed type-spec at %C");
+ return MATCH_ERROR;
+ }
+ m = gfc_match_char (')'); /* Burn closing ')'. */
}
if (m != MATCH_YES)
@@ -7164,7 +7179,7 @@ add_global_entry (const char *name, const char *binding_label, bool sub,
name is a global identifier. */
if (!binding_label || gfc_notification_std (GFC_STD_F2008))
{
- s = gfc_get_gsymbol (name);
+ s = gfc_get_gsymbol (name, false);
if (s->defined || (s->type != GSYM_UNKNOWN && s->type != type))
{
@@ -7186,7 +7201,7 @@ add_global_entry (const char *name, const char *binding_label, bool sub,
&& (!gfc_notification_std (GFC_STD_F2008)
|| strcmp (name, binding_label) != 0))
{
- s = gfc_get_gsymbol (binding_label);
+ s = gfc_get_gsymbol (binding_label, true);
if (s->defined || (s->type != GSYM_UNKNOWN && s->type != type))
{
diff --git a/gcc/fortran/expr.c b/gcc/fortran/expr.c
index 6ef4eb864e6..8a23374a6c9 100644
--- a/gcc/fortran/expr.c
+++ b/gcc/fortran/expr.c
@@ -1784,8 +1784,14 @@ simplify_const_ref (gfc_expr *p)
string_len = 0;
if (!p->ts.u.cl)
- p->ts.u.cl = gfc_new_charlen (p->symtree->n.sym->ns,
- NULL);
+ {
+ if (p->symtree)
+ p->ts.u.cl = gfc_new_charlen (p->symtree->n.sym->ns,
+ NULL);
+ else
+ p->ts.u.cl = gfc_new_charlen (gfc_current_ns,
+ NULL);
+ }
else
gfc_free_expr (p->ts.u.cl->length);
@@ -2390,6 +2396,8 @@ check_inquiry (gfc_expr *e, int not_restricted)
int i = 0;
gfc_actual_arglist *ap;
+ gfc_symbol *sym;
+ gfc_symbol *asym;
if (!e->value.function.isym
|| !e->value.function.isym->inquiry)
@@ -2399,20 +2407,22 @@ check_inquiry (gfc_expr *e, int not_restricted)
if (e->symtree == NULL)
return MATCH_NO;
- if (e->symtree->n.sym->from_intmod)
+ sym = e->symtree->n.sym;
+
+ if (sym->from_intmod)
{
- if (e->symtree->n.sym->from_intmod == INTMOD_ISO_FORTRAN_ENV
- && e->symtree->n.sym->intmod_sym_id != ISOFORTRAN_COMPILER_OPTIONS
- && e->symtree->n.sym->intmod_sym_id != ISOFORTRAN_COMPILER_VERSION)
+ if (sym->from_intmod == INTMOD_ISO_FORTRAN_ENV
+ && sym->intmod_sym_id != ISOFORTRAN_COMPILER_OPTIONS
+ && sym->intmod_sym_id != ISOFORTRAN_COMPILER_VERSION)
return MATCH_NO;
- if (e->symtree->n.sym->from_intmod == INTMOD_ISO_C_BINDING
- && e->symtree->n.sym->intmod_sym_id != ISOCBINDING_C_SIZEOF)
+ if (sym->from_intmod == INTMOD_ISO_C_BINDING
+ && sym->intmod_sym_id != ISOCBINDING_C_SIZEOF)
return MATCH_NO;
}
else
{
- name = e->symtree->n.sym->name;
+ name = sym->name;
functions = (gfc_option.warn_std & GFC_STD_F2003)
? inquiry_func_f2003 : inquiry_func_f95;
@@ -2434,41 +2444,48 @@ check_inquiry (gfc_expr *e, int not_restricted)
if (!ap->expr)
continue;
+ asym = ap->expr->symtree ? ap->expr->symtree->n.sym : NULL;
+
if (ap->expr->ts.type == BT_UNKNOWN)
{
- if (ap->expr->symtree->n.sym->ts.type == BT_UNKNOWN
- && !gfc_set_default_type (ap->expr->symtree->n.sym, 0, gfc_current_ns))
+ if (asym && asym->ts.type == BT_UNKNOWN
+ && !gfc_set_default_type (asym, 0, gfc_current_ns))
return MATCH_NO;
- ap->expr->ts = ap->expr->symtree->n.sym->ts;
+ ap->expr->ts = asym->ts;
}
- /* Assumed character length will not reduce to a constant expression
- with LEN, as required by the standard. */
- if (i == 5 && not_restricted && ap->expr->symtree
- && ap->expr->symtree->n.sym->ts.type == BT_CHARACTER
- && (ap->expr->symtree->n.sym->ts.u.cl->length == NULL
- || ap->expr->symtree->n.sym->ts.deferred))
- {
- gfc_error ("Assumed or deferred character length variable %qs "
- "in constant expression at %L",
- ap->expr->symtree->n.sym->name,
- &ap->expr->where);
- return MATCH_ERROR;
- }
- else if (not_restricted && !gfc_check_init_expr (ap->expr))
- return MATCH_ERROR;
+ if (asym && asym->assoc && asym->assoc->target
+ && asym->assoc->target->expr_type == EXPR_CONSTANT)
+ {
+ gfc_free_expr (ap->expr);
+ ap->expr = gfc_copy_expr (asym->assoc->target);
+ }
- if (not_restricted == 0
- && ap->expr->expr_type != EXPR_VARIABLE
- && !check_restricted (ap->expr))
+ /* Assumed character length will not reduce to a constant expression
+ with LEN, as required by the standard. */
+ if (i == 5 && not_restricted && asym
+ && asym->ts.type == BT_CHARACTER
+ && ((asym->ts.u.cl && asym->ts.u.cl->length == NULL)
+ || asym->ts.deferred))
+ {
+ gfc_error ("Assumed or deferred character length variable %qs "
+ "in constant expression at %L",
+ asym->name, &ap->expr->where);
return MATCH_ERROR;
+ }
+ else if (not_restricted && !gfc_check_init_expr (ap->expr))
+ return MATCH_ERROR;
+
+ if (not_restricted == 0
+ && ap->expr->expr_type != EXPR_VARIABLE
+ && !check_restricted (ap->expr))
+ return MATCH_ERROR;
- if (not_restricted == 0
- && ap->expr->expr_type == EXPR_VARIABLE
- && ap->expr->symtree->n.sym->attr.dummy
- && ap->expr->symtree->n.sym->attr.optional)
- return MATCH_NO;
+ if (not_restricted == 0
+ && ap->expr->expr_type == EXPR_VARIABLE
+ && asym->attr.dummy && asym->attr.optional)
+ return MATCH_NO;
}
return MATCH_YES;
diff --git a/gcc/fortran/frontend-passes.c b/gcc/fortran/frontend-passes.c
index 1394fbcdf58..2c1aafebb5f 100644
--- a/gcc/fortran/frontend-passes.c
+++ b/gcc/fortran/frontend-passes.c
@@ -2461,7 +2461,12 @@ insert_index (gfc_expr *e, gfc_symbol *sym, mpz_t val, mpz_t ret)
data.sym = sym;
mpz_init_set (data.val, val);
gfc_expr_walker (&n, callback_insert_index, (void *) &data);
+
+ /* Suppress errors here - we could get errors here such as an
+ out of bounds access for arrays, see PR 90563. */
+ gfc_push_suppress_errors ();
gfc_simplify_expr (n, 0);
+ gfc_pop_suppress_errors ();
if (n->expr_type == EXPR_CONSTANT)
{
@@ -2511,6 +2516,7 @@ do_subscript (gfc_expr **e)
bool have_do_start, have_do_end;
bool error_not_proven;
int warn;
+ int sgn;
dl = lp->c;
if (dl == NULL)
@@ -2539,7 +2545,16 @@ do_subscript (gfc_expr **e)
Do not warn in this case. */
if (dl->ext.iterator->step->expr_type == EXPR_CONSTANT)
- mpz_init_set (do_step, dl->ext.iterator->step->value.integer);
+ {
+ sgn = mpz_cmp_ui (dl->ext.iterator->step->value.integer, 0);
+ /* This can happen, but then the error has been
+ reported previusly. */
+ if (sgn == 0)
+ continue;
+
+ mpz_init_set (do_step, dl->ext.iterator->step->value.integer);
+ }
+
else
continue;
@@ -2563,6 +2578,16 @@ do_subscript (gfc_expr **e)
if (!have_do_start && !have_do_end)
return 0;
+ /* No warning inside a zero-trip loop. */
+ if (have_do_start && have_do_end)
+ {
+ int cmp;
+
+ cmp = mpz_cmp (do_end, do_start);
+ if ((sgn > 0 && cmp < 0) || (sgn < 0 && cmp > 0))
+ break;
+ }
+
/* May have to correct the end value if the step does not equal
one. */
if (have_do_start && have_do_end && mpz_cmp_ui (do_step, 1) != 0)
diff --git a/gcc/fortran/gfortran.h b/gcc/fortran/gfortran.h
index abdefe12ed2..16748a014e9 100644
--- a/gcc/fortran/gfortran.h
+++ b/gcc/fortran/gfortran.h
@@ -1080,6 +1080,7 @@ typedef struct gfc_component
struct gfc_typebound_proc *tb;
/* When allocatable/pointer and in a coarray the associated token. */
tree caf_token;
+ bool finalized;
}
gfc_component;
@@ -1856,6 +1857,9 @@ typedef struct gfc_namespace
/* Set to 1 for !$ACC ROUTINE namespaces. */
unsigned oacc_routine:1;
+
+ /* Set to 1 if there are any calls to procedures with implicit interface. */
+ unsigned implicit_interface_calls:1;
}
gfc_namespace;
@@ -1883,6 +1887,7 @@ typedef struct gfc_gsymbol
enum gfc_symbol_type type;
int defined, used;
+ bool bind_c;
locus where;
gfc_namespace *ns;
}
@@ -3059,7 +3064,7 @@ void gfc_enforce_clean_symbol_state (void);
void gfc_free_dt_list (void);
-gfc_gsymbol *gfc_get_gsymbol (const char *);
+gfc_gsymbol *gfc_get_gsymbol (const char *, bool bind_c);
gfc_gsymbol *gfc_find_gsymbol (gfc_gsymbol *, const char *);
gfc_gsymbol *gfc_find_case_gsymbol (gfc_gsymbol *, const char *);
diff --git a/gcc/fortran/interface.c b/gcc/fortran/interface.c
index 2e8dfd49900..04850b0406c 100644
--- a/gcc/fortran/interface.c
+++ b/gcc/fortran/interface.c
@@ -2941,17 +2941,19 @@ compare_actual_formal (gfc_actual_arglist **ap, gfc_formal_arglist *formal,
if (f->sym == NULL)
{
+ /* These errors have to be issued, otherwise an ICE can occur.
+ See PR 78865. */
if (where)
- gfc_error ("Missing alternate return spec in subroutine call "
- "at %L", where);
+ gfc_error_now ("Missing alternate return specifier in subroutine "
+ "call at %L", where);
return false;
}
if (a->expr == NULL)
{
if (where)
- gfc_error ("Unexpected alternate return spec in subroutine "
- "call at %L", where);
+ gfc_error_now ("Unexpected alternate return specifier in "
+ "subroutine call at %L", where);
return false;
}
@@ -3655,6 +3657,7 @@ gfc_procedure_use (gfc_symbol *sym, gfc_actual_arglist **ap, locus *where)
gfc_warning (OPT_Wimplicit_procedure,
"Procedure %qs called at %L is not explicitly declared",
sym->name, where);
+ gfc_find_proc_namespace (sym->ns)->implicit_interface_calls = 1;
}
if (sym->attr.if_source == IFSRC_UNKNOWN)
diff --git a/gcc/fortran/invoke.texi b/gcc/fortran/invoke.texi
index 3d64056591e..ded17ac0f47 100644
--- a/gcc/fortran/invoke.texi
+++ b/gcc/fortran/invoke.texi
@@ -181,7 +181,8 @@ and warnings}.
@item Code Generation Options
@xref{Code Gen Options,,Options for code generation conventions}.
@gccoptlist{-faggressive-function-elimination -fblas-matmul-limit=@var{n} @gol
--fbounds-check -fcheck-array-temporaries @gol
+-fbounds-check -ftail-call-workaround -ftail-call-workaround=@var{n} @gol
+-fcheck-array-temporaries @gol
-fcheck=@var{<all|array-temps|bounds|do|mem|pointer|recursion>} @gol
-fcoarray=@var{<none|single|lib>} -fexternal-blas -ff2c
-ffrontend-loop-interchange @gol
@@ -1580,6 +1581,39 @@ warnings for generated array temporaries.
@c Note: This option is also referred in gcc's manpage
Deprecated alias for @option{-fcheck=bounds}.
+@item -ftail-call-workaround
+@itemx -ftail-call-workaround=@var{n}
+@opindex @code{tail-call-workaround}
+Some C interfaces to Fortran codes violate the gfortran ABI by
+omitting the hidden character length arguments as described in
+@xref{Argument passing conventions}. This can lead to crashes
+because pushing arguments for tail calls can overflow the stack.
+
+To provide a workaround for existing binary packages, this option
+disables tail call optimization for gfortran procedures with character
+arguments. With @option{-ftail-call-workaround=2} tail call optimization
+is disabled in all gfortran procedures with character arguments,
+with @option{-ftail-call-workaround=1} or equivalent
+@option{-ftail-call-workaround} only in gfortran procedures with character
+arguments that call implicitly prototyped procedures.
+
+Using this option can lead to problems including crashes due to
+insufficient stack space.
+
+It is @emph{very strongly} recommended to fix the code in question.
+The @option{-fc-prototypes-external} option can be used to generate
+prototypes which conform to gfortran's ABI, for inclusion in the
+source code.
+
+Support for this option will likely be withdrawn in a future release
+of gfortran.
+
+The negative form, @option{-fno-tail-call-workaround} or equivalent
+@option{-ftail-call-workaround=0}, can be used to disable this option.
+
+Default is currently @option{-ftail-call-workaround}, this will change
+in future releases.
+
@item -fcheck-array-temporaries
@opindex @code{fcheck-array-temporaries}
Deprecated alias for @option{-fcheck=array-temps}.
diff --git a/gcc/fortran/iresolve.c b/gcc/fortran/iresolve.c
index f15b8f2773a..7e70a061acd 100644
--- a/gcc/fortran/iresolve.c
+++ b/gcc/fortran/iresolve.c
@@ -35,6 +35,7 @@ along with GCC; see the file COPYING3. If not see
#include "intrinsic.h"
#include "constructor.h"
#include "arith.h"
+#include "trans.h"
/* Given printf-like arguments, return a stable version of the result string.
@@ -2377,6 +2378,10 @@ gfc_resolve_fe_runtime_error (gfc_code *c)
a->name = "%VAL";
c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
+ /* We set the backend_decl here because runtime_error is a
+ variadic function and we would use the wrong calling
+ convention otherwise. */
+ c->resolved_sym->backend_decl = gfor_fndecl_runtime_error;
}
void
diff --git a/gcc/fortran/lang.opt b/gcc/fortran/lang.opt
index 1cb7b6b4f84..ec9c02228da 100644
--- a/gcc/fortran/lang.opt
+++ b/gcc/fortran/lang.opt
@@ -742,6 +742,13 @@ fsign-zero
Fortran Var(flag_sign_zero) Init(1)
Apply negative sign to zero values.
+ftail-call-workaround
+Fortran Alias(ftail-call-workaround=,1,0)
+
+ftail-call-workaround=
+Fortran RejectNegative Joined UInteger IntegerRange(0, 2) Var(flag_tail_call_workaround) Init(1)
+Disallow tail call optimization when a calling routine may have omitted character lengths.
+
funderscoring
Fortran Var(flag_underscoring) Init(1)
Append underscores to externally visible names.
diff --git a/gcc/fortran/match.c b/gcc/fortran/match.c
index 8185e51d5a9..d0a4b53da6b 100644
--- a/gcc/fortran/match.c
+++ b/gcc/fortran/match.c
@@ -2105,8 +2105,6 @@ gfc_match_type_spec (gfc_typespec *ts)
ts->type = BT_CHARACTER;
m = gfc_match_char_spec (ts);
- if (ts->u.cl && ts->u.cl->length)
- gfc_resolve_expr (ts->u.cl->length);
if (m == MATCH_NO)
m = MATCH_YES;
diff --git a/gcc/fortran/parse.c b/gcc/fortran/parse.c
index 4ce6eb42750..e920c71d569 100644
--- a/gcc/fortran/parse.c
+++ b/gcc/fortran/parse.c
@@ -5830,7 +5830,7 @@ parse_block_data (void)
}
else
{
- s = gfc_get_gsymbol (gfc_new_block->name);
+ s = gfc_get_gsymbol (gfc_new_block->name, false);
if (s->defined
|| (s->type != GSYM_UNKNOWN && s->type != GSYM_BLOCK_DATA))
gfc_global_used (s, &gfc_new_block->declared_at);
@@ -5912,7 +5912,7 @@ parse_module (void)
gfc_gsymbol *s;
bool error;
- s = gfc_get_gsymbol (gfc_new_block->name);
+ s = gfc_get_gsymbol (gfc_new_block->name, false);
if (s->defined || (s->type != GSYM_UNKNOWN && s->type != GSYM_MODULE))
gfc_global_used (s, &gfc_new_block->declared_at);
else
@@ -5976,7 +5976,7 @@ add_global_procedure (bool sub)
name is a global identifier. */
if (!gfc_new_block->binding_label || gfc_notification_std (GFC_STD_F2008))
{
- s = gfc_get_gsymbol (gfc_new_block->name);
+ s = gfc_get_gsymbol (gfc_new_block->name, false);
if (s->defined
|| (s->type != GSYM_UNKNOWN
@@ -6001,7 +6001,7 @@ add_global_procedure (bool sub)
&& (!gfc_notification_std (GFC_STD_F2008)
|| strcmp (gfc_new_block->name, gfc_new_block->binding_label) != 0))
{
- s = gfc_get_gsymbol (gfc_new_block->binding_label);
+ s = gfc_get_gsymbol (gfc_new_block->binding_label, true);
if (s->defined
|| (s->type != GSYM_UNKNOWN
@@ -6033,7 +6033,7 @@ add_global_program (void)
if (gfc_new_block == NULL)
return;
- s = gfc_get_gsymbol (gfc_new_block->name);
+ s = gfc_get_gsymbol (gfc_new_block->name, false);
if (s->defined || (s->type != GSYM_UNKNOWN && s->type != GSYM_PROGRAM))
gfc_global_used (s, &gfc_new_block->declared_at);
diff --git a/gcc/fortran/resolve.c b/gcc/fortran/resolve.c
index b2c907495a2..3aad0bfa79b 100644
--- a/gcc/fortran/resolve.c
+++ b/gcc/fortran/resolve.c
@@ -1045,7 +1045,7 @@ resolve_common_blocks (gfc_symtree *common_root)
}
if (!gsym)
{
- gsym = gfc_get_gsymbol (common_root->n.common->name);
+ gsym = gfc_get_gsymbol (common_root->n.common->name, false);
gsym->type = GSYM_COMMON;
gsym->where = common_root->n.common->where;
gsym->defined = 1;
@@ -1067,7 +1067,7 @@ resolve_common_blocks (gfc_symtree *common_root)
}
if (!gsym)
{
- gsym = gfc_get_gsymbol (common_root->n.common->binding_label);
+ gsym = gfc_get_gsymbol (common_root->n.common->binding_label, true);
gsym->type = GSYM_COMMON;
gsym->where = common_root->n.common->where;
gsym->defined = 1;
@@ -1681,8 +1681,6 @@ is_illegal_recursion (gfc_symbol* sym, gfc_namespace* context)
|| gfc_fl_struct (sym->attr.flavor))
return false;
- gcc_assert (sym->attr.flavor == FL_PROCEDURE);
-
/* If we've got an ENTRY, find real procedure. */
if (sym->attr.entry && sym->ns->entries)
proc_sym = sym->ns->entries->sym;
@@ -2484,7 +2482,8 @@ resolve_global_procedure (gfc_symbol *sym, locus *where,
type = sub ? GSYM_SUBROUTINE : GSYM_FUNCTION;
- gsym = gfc_get_gsymbol (sym->binding_label ? sym->binding_label : sym->name);
+ gsym = gfc_get_gsymbol (sym->binding_label ? sym->binding_label : sym->name,
+ sym->binding_label != NULL);
if ((gsym->type != GSYM_UNKNOWN && gsym->type != type))
gfc_global_used (gsym, where);
@@ -2494,64 +2493,64 @@ resolve_global_procedure (gfc_symbol *sym, locus *where,
&& gsym->type != GSYM_UNKNOWN
&& !gsym->binding_label
&& gsym->ns
- && gsym->ns->resolved != -1
&& gsym->ns->proc_name
&& not_in_recursive (sym, gsym->ns)
&& not_entry_self_reference (sym, gsym->ns))
{
gfc_symbol *def_sym;
+ def_sym = gsym->ns->proc_name;
/* Resolve the gsymbol namespace if needed. */
- if (!gsym->ns->resolved)
+ if (gsym->ns->resolved != -1)
{
- gfc_dt_list *old_dt_list;
+ if (!gsym->ns->resolved)
+ {
+ gfc_dt_list *old_dt_list;
- /* Stash away derived types so that the backend_decls do not
- get mixed up. */
- old_dt_list = gfc_derived_types;
- gfc_derived_types = NULL;
+ /* Stash away derived types so that the backend_decls
+ do not get mixed up. */
+ old_dt_list = gfc_derived_types;
+ gfc_derived_types = NULL;
- gfc_resolve (gsym->ns);
+ gfc_resolve (gsym->ns);
- /* Store the new derived types with the global namespace. */
- if (gfc_derived_types)
- gsym->ns->derived_types = gfc_derived_types;
+ /* Store the new derived types with the global namespace. */
+ if (gfc_derived_types)
+ gsym->ns->derived_types = gfc_derived_types;
- /* Restore the derived types of this namespace. */
- gfc_derived_types = old_dt_list;
- }
+ /* Restore the derived types of this namespace. */
+ gfc_derived_types = old_dt_list;
+ }
- /* Make sure that translation for the gsymbol occurs before
- the procedure currently being resolved. */
- ns = gfc_global_ns_list;
- for (; ns && ns != gsym->ns; ns = ns->sibling)
- {
- if (ns->sibling == gsym->ns)
+ /* Make sure that translation for the gsymbol occurs before
+ the procedure currently being resolved. */
+ ns = gfc_global_ns_list;
+ for (; ns && ns != gsym->ns; ns = ns->sibling)
{
- ns->sibling = gsym->ns->sibling;
- gsym->ns->sibling = gfc_global_ns_list;
- gfc_global_ns_list = gsym->ns;
- break;
+ if (ns->sibling == gsym->ns)
+ {
+ ns->sibling = gsym->ns->sibling;
+ gsym->ns->sibling = gfc_global_ns_list;
+ gfc_global_ns_list = gsym->ns;
+ break;
+ }
}
- }
- def_sym = gsym->ns->proc_name;
-
- /* This can happen if a binding name has been specified. */
- if (gsym->binding_label && gsym->sym_name != def_sym->name)
- gfc_find_symbol (gsym->sym_name, gsym->ns, 0, &def_sym);
+ /* This can happen if a binding name has been specified. */
+ if (gsym->binding_label && gsym->sym_name != def_sym->name)
+ gfc_find_symbol (gsym->sym_name, gsym->ns, 0, &def_sym);
- if (def_sym->attr.entry_master)
- {
- gfc_entry_list *entry;
- for (entry = gsym->ns->entries; entry; entry = entry->next)
- if (strcmp (entry->sym->name, sym->name) == 0)
- {
- def_sym = entry->sym;
- break;
- }
+ if (def_sym->attr.entry_master || def_sym->attr.entry)
+ {
+ gfc_entry_list *entry;
+ for (entry = gsym->ns->entries; entry; entry = entry->next)
+ if (strcmp (entry->sym->name, sym->name) == 0)
+ {
+ def_sym = entry->sym;
+ break;
+ }
+ }
}
-
if (sym->attr.function && !gfc_compare_types (&sym->ts, &def_sym->ts))
{
gfc_error ("Return type mismatch of function %qs at %L (%s/%s)",
@@ -4633,9 +4632,13 @@ find_array_spec (gfc_expr *e)
gfc_array_spec *as;
gfc_component *c;
gfc_ref *ref;
+ bool class_as = false;
if (e->symtree->n.sym->ts.type == BT_CLASS)
- as = CLASS_DATA (e->symtree->n.sym)->as;
+ {
+ as = CLASS_DATA (e->symtree->n.sym)->as;
+ class_as = true;
+ }
else
as = e->symtree->n.sym->as;
@@ -4654,7 +4657,7 @@ find_array_spec (gfc_expr *e)
c = ref->u.c.component;
if (c->attr.dimension)
{
- if (as != NULL)
+ if (as != NULL && !(class_as && as == c->as))
gfc_internal_error ("find_array_spec(): unused as(1)");
as = c->as;
}
@@ -5630,11 +5633,14 @@ resolve_procedure:
/* Checks to see that the correct symbol has been host associated.
- The only situation where this arises is that in which a twice
- contained function is parsed after the host association is made.
- Therefore, on detecting this, change the symbol in the expression
- and convert the array reference into an actual arglist if the old
- symbol is a variable. */
+ The only situations where this arises are:
+ (i) That in which a twice contained function is parsed after
+ the host association is made. On detecting this, change
+ the symbol in the expression and convert the array reference
+ into an actual arglist if the old symbol is a variable; or
+ (ii) That in which an external function is typed but not declared
+ explcitly to be external. Here, the old symbol is changed
+ from a variable to an external function. */
static bool
check_host_association (gfc_expr *e)
{
@@ -5724,6 +5730,26 @@ check_host_association (gfc_expr *e)
gfc_resolve_expr (e);
sym->refs++;
}
+ /* This case corresponds to a call, from a block or a contained
+ procedure, to an external function, which has not been declared
+ as being external in the main program but has been typed. */
+ else if (sym && old_sym != sym
+ && !e->ref
+ && sym->ts.type == BT_UNKNOWN
+ && old_sym->ts.type != BT_UNKNOWN
+ && sym->attr.flavor == FL_PROCEDURE
+ && old_sym->attr.flavor == FL_VARIABLE
+ && sym->ns->parent == old_sym->ns
+ && sym->ns->proc_name
+ && (sym->ns->proc_name->attr.flavor == FL_LABEL
+ || sym->ns->proc_name->attr.flavor == FL_PROCEDURE))
+ {
+ old_sym->attr.flavor = FL_PROCEDURE;
+ old_sym->attr.external = 1;
+ old_sym->attr.function = 1;
+ old_sym->result = old_sym;
+ gfc_resolve_expr (e);
+ }
}
/* This might have changed! */
return e->expr_type == EXPR_FUNCTION;
@@ -6903,19 +6929,6 @@ gfc_resolve_iterator (gfc_iterator *iter, bool real_ok, bool own_scope)
"Step expression in DO loop"))
return false;
- if (iter->step->expr_type == EXPR_CONSTANT)
- {
- if ((iter->step->ts.type == BT_INTEGER
- && mpz_cmp_ui (iter->step->value.integer, 0) == 0)
- || (iter->step->ts.type == BT_REAL
- && mpfr_sgn (iter->step->value.real) == 0))
- {
- gfc_error ("Step expression in DO loop at %L cannot be zero",
- &iter->step->where);
- return false;
- }
- }
-
/* Convert start, end, and step to the same type as var. */
if (iter->start->ts.kind != iter->var->ts.kind
|| iter->start->ts.type != iter->var->ts.type)
@@ -6929,6 +6942,19 @@ gfc_resolve_iterator (gfc_iterator *iter, bool real_ok, bool own_scope)
|| iter->step->ts.type != iter->var->ts.type)
gfc_convert_type (iter->step, &iter->var->ts, 1);
+ if (iter->step->expr_type == EXPR_CONSTANT)
+ {
+ if ((iter->step->ts.type == BT_INTEGER
+ && mpz_cmp_ui (iter->step->value.integer, 0) == 0)
+ || (iter->step->ts.type == BT_REAL
+ && mpfr_sgn (iter->step->value.real) == 0))
+ {
+ gfc_error ("Step expression in DO loop at %L cannot be zero",
+ &iter->step->where);
+ return false;
+ }
+ }
+
if (iter->start->expr_type == EXPR_CONSTANT
&& iter->end->expr_type == EXPR_CONSTANT
&& iter->step->expr_type == EXPR_CONSTANT)
@@ -7655,13 +7681,54 @@ resolve_allocate_expr (gfc_expr *e, gfc_code *code, bool *array_alloc_wo_spec)
if (codimension)
for (i = ar->dimen; i < ar->dimen + ar->codimen; i++)
- if (ar->dimen_type[i] == DIMEN_THIS_IMAGE)
- {
- gfc_error ("Coarray specification required in ALLOCATE statement "
- "at %L", &e->where);
- goto failure;
- }
+ {
+ switch (ar->dimen_type[i])
+ {
+ case DIMEN_THIS_IMAGE:
+ gfc_error ("Coarray specification required in ALLOCATE statement "
+ "at %L", &e->where);
+ goto failure;
+
+ case DIMEN_RANGE:
+ if (ar->start[i] == 0 || ar->end[i] == 0)
+ {
+ /* If ar->stride[i] is NULL, we issued a previous error. */
+ if (ar->stride[i] == NULL)
+ gfc_error ("Bad array specification in ALLOCATE statement "
+ "at %L", &e->where);
+ goto failure;
+ }
+ else if (gfc_dep_compare_expr (ar->start[i], ar->end[i]) == 1)
+ {
+ gfc_error ("Upper cobound is less than lower cobound at %L",
+ &ar->start[i]->where);
+ goto failure;
+ }
+ break;
+
+ case DIMEN_ELEMENT:
+ if (ar->start[i]->expr_type == EXPR_CONSTANT)
+ {
+ gcc_assert (ar->start[i]->ts.type == BT_INTEGER);
+ if (mpz_cmp_si (ar->start[i]->value.integer, 1) < 0)
+ {
+ gfc_error ("Upper cobound is less than lower cobound "
+ " of 1 at %L", &ar->start[i]->where);
+ goto failure;
+ }
+ }
+ break;
+
+ case DIMEN_STAR:
+ break;
+
+ default:
+ gfc_error ("Bad array specification in ALLOCATE statement at %L",
+ &e->where);
+ goto failure;
+ }
+ }
for (i = 0; i < ar->dimen; i++)
{
if (ar->type == AR_ELEMENT || ar->type == AR_FULL)
@@ -11665,7 +11732,7 @@ gfc_verify_binding_labels (gfc_symbol *sym)
&& (gsym->type == GSYM_FUNCTION || gsym->type == GSYM_SUBROUTINE)))
{
if (!gsym)
- gsym = gfc_get_gsymbol (sym->binding_label);
+ gsym = gfc_get_gsymbol (sym->binding_label, true);
gsym->where = sym->declared_at;
gsym->sym_name = sym->name;
gsym->binding_label = sym->binding_label;
diff --git a/gcc/fortran/symbol.c b/gcc/fortran/symbol.c
index 00d9303d290..e783319298c 100644
--- a/gcc/fortran/symbol.c
+++ b/gcc/fortran/symbol.c
@@ -554,6 +554,7 @@ check_conflict (symbol_attribute *attr, const char *name, locus *where)
conf (external, intrinsic);
conf (entry, intrinsic);
+ conf (abstract, intrinsic);
if ((attr->if_source == IFSRC_DECL && !attr->procedure) || attr->contained)
conf (external, subroutine);
@@ -1685,7 +1686,15 @@ gfc_add_subroutine (symbol_attribute *attr, const char *name, locus *where)
return false;
attr->subroutine = 1;
- return check_conflict (attr, name, where);
+
+ /* If we are looking at a BLOCK DATA statement and we encounter a
+ name with a leading underscore (which must be
+ compiler-generated), do not check. See PR 84394. */
+
+ if (name && *name != '_' && gfc_current_state () != COMP_BLOCK_DATA)
+ return check_conflict (attr, name, where);
+ else
+ return true;
}
@@ -1801,7 +1810,8 @@ gfc_add_procedure (symbol_attribute *attr, procedure_type t,
if (where == NULL)
where = &gfc_current_locus;
- if (attr->proc != PROC_UNKNOWN && !attr->module_procedure)
+ if (attr->proc != PROC_UNKNOWN && !attr->module_procedure
+ && attr->access == ACCESS_UNKNOWN)
{
if (attr->proc == PROC_ST_FUNCTION && t == PROC_INTERNAL
&& !gfc_notification_std (GFC_STD_F2008))
@@ -4352,7 +4362,7 @@ gsym_compare (void *_s1, void *_s2)
/* Get a global symbol, creating it if it doesn't exist. */
gfc_gsymbol *
-gfc_get_gsymbol (const char *name)
+gfc_get_gsymbol (const char *name, bool bind_c)
{
gfc_gsymbol *s;
@@ -4363,6 +4373,7 @@ gfc_get_gsymbol (const char *name)
s = XCNEW (gfc_gsymbol);
s->type = GSYM_UNKNOWN;
s->name = gfc_get_string ("%s", name);
+ s->bind_c = bind_c;
gfc_insert_bbt (&gfc_gsym_root, s, gsym_compare);
diff --git a/gcc/fortran/target-memory.c b/gcc/fortran/target-memory.c
index c924cb529d1..35a631aa878 100644
--- a/gcc/fortran/target-memory.c
+++ b/gcc/fortran/target-memory.c
@@ -120,6 +120,7 @@ gfc_element_size (gfc_expr *e, size_t *siz)
case BT_CLASS:
case BT_VOID:
case BT_ASSUMED:
+ case BT_PROCEDURE:
{
/* Determine type size without clobbering the typespec for ISO C
binding types. */
diff --git a/gcc/fortran/trans-array.c b/gcc/fortran/trans-array.c
index 8498dfb656e..9b898888e3d 100644
--- a/gcc/fortran/trans-array.c
+++ b/gcc/fortran/trans-array.c
@@ -1164,6 +1164,7 @@ gfc_trans_create_temp_array (stmtblock_t * pre, stmtblock_t * post, gfc_ss * ss,
tree nelem;
tree cond;
tree or_expr;
+ tree elemsize;
tree class_expr = NULL_TREE;
int n, dim, tmp_dim;
int total_dim = 0;
@@ -1329,21 +1330,21 @@ gfc_trans_create_temp_array (stmtblock_t * pre, stmtblock_t * post, gfc_ss * ss,
}
}
+ if (class_expr == NULL_TREE)
+ elemsize = fold_convert (gfc_array_index_type,
+ TYPE_SIZE_UNIT (gfc_get_element_type (type)));
+ else
+ elemsize = gfc_class_vtab_size_get (class_expr);
+
/* Get the size of the array. */
if (size && !callee_alloc)
{
- tree elemsize;
/* If or_expr is true, then the extent in at least one
dimension is zero and the size is set to zero. */
size = fold_build3_loc (input_location, COND_EXPR, gfc_array_index_type,
or_expr, gfc_index_zero_node, size);
nelem = size;
- if (class_expr == NULL_TREE)
- elemsize = fold_convert (gfc_array_index_type,
- TYPE_SIZE_UNIT (gfc_get_element_type (type)));
- else
- elemsize = gfc_class_vtab_size_get (class_expr);
size = fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type,
size, elemsize);
@@ -1354,6 +1355,10 @@ gfc_trans_create_temp_array (stmtblock_t * pre, stmtblock_t * post, gfc_ss * ss,
size = NULL_TREE;
}
+ /* Set the span. */
+ tmp = fold_convert (gfc_array_index_type, elemsize);
+ gfc_conv_descriptor_span_set (pre, desc, tmp);
+
gfc_trans_allocate_array_storage (pre, post, info, size, nelem, initial,
dynamic, dealloc);
@@ -2652,6 +2657,9 @@ gfc_scalar_elemental_arg_saved_as_reference (gfc_ss_info * ss_info)
if (ss_info->type != GFC_SS_REFERENCE)
return false;
+ if (ss_info->data.scalar.needs_temporary)
+ return false;
+
/* If the actual argument can be absent (in other words, it can
be a NULL reference), don't try to evaluate it; pass instead
the reference directly. */
@@ -3414,10 +3422,8 @@ gfc_conv_scalarized_array_ref (gfc_se * se, gfc_array_ref * ar)
if (build_class_array_ref (se, base, index))
return;
- if (expr && ((is_subref_array (expr)
- && GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (info->descriptor)))
- || (expr->ts.deferred && (expr->expr_type == EXPR_VARIABLE
- || expr->expr_type == EXPR_FUNCTION))))
+ if (expr && (expr->ts.deferred && (expr->expr_type == EXPR_VARIABLE
+ || expr->expr_type == EXPR_FUNCTION)))
decl = expr->symtree->n.sym->backend_decl;
/* A pointer array component can be detected from its field decl. Fix
@@ -9527,9 +9533,15 @@ gfc_is_reallocatable_lhs (gfc_expr *expr)
if (sym->ts.type == BT_CLASS
&& !sym->attr.associate_var
&& CLASS_DATA (sym)->attr.allocatable
- && expr->ref && expr->ref->type == REF_COMPONENT
- && strcmp (expr->ref->u.c.component->name, "_data") == 0
- && expr->ref->next == NULL)
+ && expr->ref
+ && ((expr->ref->type == REF_ARRAY && expr->ref->u.ar.type == AR_FULL
+ && expr->ref->next == NULL)
+ || (expr->ref->type == REF_COMPONENT
+ && strcmp (expr->ref->u.c.component->name, "_data") == 0
+ && (expr->ref->next == NULL
+ || (expr->ref->next->type == REF_ARRAY
+ && expr->ref->next->u.ar.type == AR_FULL
+ && expr->ref->next->next == NULL)))))
return true;
/* An allocatable variable. */
@@ -10350,6 +10362,8 @@ gfc_walk_variable_expr (gfc_ss * ss, gfc_expr * expr)
{
gfc_ref *ref;
+ gfc_fix_class_refs (expr);
+
for (ref = expr->ref; ref; ref = ref->next)
if (ref->type == REF_ARRAY && ref->u.ar.type != AR_ELEMENT)
break;
diff --git a/gcc/fortran/trans-decl.c b/gcc/fortran/trans-decl.c
index a2172c3ddeb..4e778be34c5 100644
--- a/gcc/fortran/trans-decl.c
+++ b/gcc/fortran/trans-decl.c
@@ -342,39 +342,45 @@ gfc_get_label_decl (gfc_st_label * lp)
}
}
+/* Return the name of an identifier. */
-/* Convert a gfc_symbol to an identifier of the same name. */
-
-static tree
-gfc_sym_identifier (gfc_symbol * sym)
+static const char *
+sym_identifier (gfc_symbol *sym)
{
if (sym->attr.is_main_program && strcmp (sym->name, "main") == 0)
- return (get_identifier ("MAIN__"));
+ return "MAIN__";
else
- return (get_identifier (sym->name));
+ return sym->name;
}
-
-/* Construct mangled name from symbol name. */
+/* Convert a gfc_symbol to an identifier of the same name. */
static tree
-gfc_sym_mangled_identifier (gfc_symbol * sym)
+gfc_sym_identifier (gfc_symbol * sym)
{
- char name[GFC_MAX_MANGLED_SYMBOL_LEN + 1];
+ return get_identifier (sym_identifier (sym));
+}
+/* Construct mangled name from symbol name. */
+
+static const char *
+mangled_identifier (gfc_symbol *sym)
+{
+ static char name[GFC_MAX_MANGLED_SYMBOL_LEN + 1];
/* Prevent the mangling of identifiers that have an assigned
binding label (mainly those that are bind(c)). */
+
if (sym->attr.is_bind_c == 1 && sym->binding_label)
- return get_identifier (sym->binding_label);
+ return sym->binding_label;
if (!sym->fn_result_spec)
{
if (sym->module == NULL)
- return gfc_sym_identifier (sym);
+ return sym_identifier (sym);
else
{
snprintf (name, sizeof name, "__%s_MOD_%s", sym->module, sym->name);
- return get_identifier (name);
+ return name;
}
}
else
@@ -389,17 +395,40 @@ gfc_sym_mangled_identifier (gfc_symbol * sym)
sym->ns->proc_name->module,
sym->ns->proc_name->name,
sym->name);
- return get_identifier (name);
+ return name;
}
else
{
snprintf (name, sizeof name, "__%s_PROC_%s",
sym->ns->proc_name->name, sym->name);
- return get_identifier (name);
+ return name;
}
}
}
+/* Get mangled identifier, adding the symbol to the global table if
+ it is not yet already there. */
+
+static tree
+gfc_sym_mangled_identifier (gfc_symbol * sym)
+{
+ tree result;
+ gfc_gsymbol *gsym;
+ const char *name;
+
+ name = mangled_identifier (sym);
+ result = get_identifier (name);
+
+ gsym = gfc_find_gsymbol (gfc_gsym_root, name);
+ if (gsym == NULL)
+ {
+ gsym = gfc_get_gsymbol (name, false);
+ gsym->ns = sym->ns;
+ gsym->sym_name = sym->name;
+ }
+
+ return result;
+}
/* Construct mangled function name from symbol name. */
@@ -839,7 +868,7 @@ gfc_get_module_backend_decl (gfc_symbol *sym)
{
if (!gsym)
{
- gsym = gfc_get_gsymbol (sym->module);
+ gsym = gfc_get_gsymbol (sym->module, false);
gsym->type = GSYM_MODULE;
gsym->ns = gfc_get_namespace (NULL, 0);
}
@@ -1865,7 +1894,7 @@ gfc_get_symbol_decl (gfc_symbol * sym)
if (sym->attr.vtab
|| (sym->name[0] == '_' && strncmp ("__def_init", sym->name, 10) == 0))
- TREE_READONLY (decl) = 1;
+ DECL_ARTIFICIAL (decl) = 1;
return decl;
}
@@ -1905,6 +1934,22 @@ get_proc_pointer_decl (gfc_symbol *sym)
tree decl;
tree attributes;
+ if (sym->module || sym->fn_result_spec)
+ {
+ const char *name;
+ gfc_gsymbol *gsym;
+
+ name = mangled_identifier (sym);
+ gsym = gfc_find_gsymbol (gfc_gsym_root, name);
+ if (gsym != NULL)
+ {
+ gfc_symbol *s;
+ gfc_find_symbol (sym->name, gsym->ns, 0, &s);
+ if (s && s->backend_decl)
+ return s->backend_decl;
+ }
+ }
+
decl = sym->backend_decl;
if (decl)
return decl;
@@ -2002,9 +2047,22 @@ gfc_get_extern_function_decl (gfc_symbol * sym, gfc_actual_arglist *actual_args)
return get_proc_pointer_decl (sym);
/* See if this is an external procedure from the same file. If so,
- return the backend_decl. */
- gsym = gfc_find_gsymbol (gfc_gsym_root, sym->binding_label
- ? sym->binding_label : sym->name);
+ return the backend_decl. If we are looking at a BIND(C)
+ procedure and the symbol is not BIND(C), or vice versa, we
+ haven't found the right procedure. */
+
+ if (sym->binding_label)
+ {
+ gsym = gfc_find_gsymbol (gfc_gsym_root, sym->binding_label);
+ if (gsym && !gsym->bind_c)
+ gsym = NULL;
+ }
+ else
+ {
+ gsym = gfc_find_gsymbol (gfc_gsym_root, sym->name);
+ if (gsym && gsym->bind_c)
+ gsym = NULL;
+ }
if (gsym && !gsym->defined)
gsym = NULL;
@@ -2500,6 +2558,17 @@ create_function_arglist (gfc_symbol * sym)
TREE_READONLY (length) = 1;
gfc_finish_decl (length);
+ /* Marking the length DECL_HIDDEN_STRING_LENGTH will lead
+ to tail calls being disabled. Only do that if we
+ potentially have broken callers. */
+ if (flag_tail_call_workaround
+ && f->sym->ts.u.cl
+ && f->sym->ts.u.cl->length
+ && f->sym->ts.u.cl->length->expr_type == EXPR_CONSTANT
+ && (flag_tail_call_workaround == 2
+ || f->sym->ns->implicit_interface_calls))
+ DECL_HIDDEN_STRING_LENGTH (length) = 1;
+
/* Remember the passed value. */
if (!f->sym->ts.u.cl || f->sym->ts.u.cl->passed_length)
{
@@ -5655,9 +5724,11 @@ generate_local_decl (gfc_symbol * sym)
}
else if (warn_unused_dummy_argument)
{
- gfc_warning (OPT_Wunused_dummy_argument,
- "Unused dummy argument %qs at %L", sym->name,
- &sym->declared_at);
+ if (!sym->attr.artificial)
+ gfc_warning (OPT_Wunused_dummy_argument,
+ "Unused dummy argument %qs at %L", sym->name,
+ &sym->declared_at);
+
if (sym->backend_decl != NULL_TREE)
TREE_NO_WARNING(sym->backend_decl) = 1;
}
@@ -5749,7 +5820,14 @@ generate_local_decl (gfc_symbol * sym)
if (sym->ns && sym->ns->construct_entities)
{
- if (sym->attr.referenced)
+ /* Construction of the intrinsic modules within a BLOCK
+ construct, where ONLY and RENAMED entities are included,
+ seems to be bogus. This is a workaround that can be removed
+ if someone ever takes on the task to creating full-fledge
+ modules. See PR 69455. */
+ if (sym->attr.referenced
+ && sym->from_intmod != INTMOD_ISO_C_BINDING
+ && sym->from_intmod != INTMOD_ISO_FORTRAN_ENV)
gfc_get_symbol_decl (sym);
sym->mark = 1;
}
diff --git a/gcc/fortran/trans-expr.c b/gcc/fortran/trans-expr.c
index b95cf8ddc4f..dd0cd86ebba 100644
--- a/gcc/fortran/trans-expr.c
+++ b/gcc/fortran/trans-expr.c
@@ -8389,23 +8389,6 @@ trans_caf_token_assign (gfc_se *lse, gfc_se *rse, gfc_expr *expr1,
}
}
-/* Indentify class valued proc_pointer assignments. */
-
-static bool
-pointer_assignment_is_proc_pointer (gfc_expr * expr1, gfc_expr * expr2)
-{
- gfc_ref * ref;
-
- ref = expr1->ref;
- while (ref && ref->next)
- ref = ref->next;
-
- return ref && ref->type == REF_COMPONENT
- && ref->u.c.component->attr.proc_pointer
- && expr2->expr_type == EXPR_VARIABLE
- && expr2->symtree->n.sym->attr.flavor == FL_PROCEDURE;
-}
-
/* Do everything that is needed for a CLASS function expr2. */
@@ -8458,7 +8441,7 @@ gfc_trans_pointer_assignment (gfc_expr * expr1, gfc_expr * expr2)
tree desc;
tree tmp;
tree expr1_vptr = NULL_TREE;
- bool scalar, non_proc_pointer_assign;
+ bool scalar, non_proc_ptr_assign;
gfc_ss *ss;
gfc_start_block (&block);
@@ -8466,7 +8449,9 @@ gfc_trans_pointer_assignment (gfc_expr * expr1, gfc_expr * expr2)
gfc_init_se (&lse, NULL);
/* Usually testing whether this is not a proc pointer assignment. */
- non_proc_pointer_assign = !pointer_assignment_is_proc_pointer (expr1, expr2);
+ non_proc_ptr_assign = !(gfc_expr_attr (expr1).proc_pointer
+ && expr2->expr_type == EXPR_VARIABLE
+ && expr2->symtree->n.sym->attr.flavor == FL_PROCEDURE);
/* Check whether the expression is a scalar or not; we cannot use
expr1->rank as it can be nonzero for proc pointers. */
@@ -8476,7 +8461,7 @@ gfc_trans_pointer_assignment (gfc_expr * expr1, gfc_expr * expr2)
gfc_free_ss_chain (ss);
if (expr1->ts.type == BT_DERIVED && expr2->ts.type == BT_CLASS
- && expr2->expr_type != EXPR_FUNCTION && non_proc_pointer_assign)
+ && expr2->expr_type != EXPR_FUNCTION && non_proc_ptr_assign)
{
gfc_add_data_component (expr2);
/* The following is required as gfc_add_data_component doesn't
@@ -8496,7 +8481,7 @@ gfc_trans_pointer_assignment (gfc_expr * expr1, gfc_expr * expr2)
else
gfc_conv_expr (&rse, expr2);
- if (non_proc_pointer_assign && expr1->ts.type == BT_CLASS)
+ if (non_proc_ptr_assign && expr1->ts.type == BT_CLASS)
{
trans_class_vptr_len_assignment (&block, expr1, expr2, &rse, NULL,
NULL);
diff --git a/gcc/fortran/trans-intrinsic.c b/gcc/fortran/trans-intrinsic.c
index dcb055ea38d..24c261d012d 100644
--- a/gcc/fortran/trans-intrinsic.c
+++ b/gcc/fortran/trans-intrinsic.c
@@ -6820,6 +6820,8 @@ gfc_conv_intrinsic_size (gfc_se * se, gfc_expr * expr)
tree fncall0;
tree fncall1;
gfc_se argse;
+ gfc_expr *e;
+ gfc_symbol *sym = NULL;
gfc_init_se (&argse, NULL);
actual = expr->value.function.actual;
@@ -6827,12 +6829,31 @@ gfc_conv_intrinsic_size (gfc_se * se, gfc_expr * expr)
if (actual->expr->ts.type == BT_CLASS)
gfc_add_class_array_ref (actual->expr);
+ e = actual->expr;
+
+ /* These are emerging from the interface mapping, when a class valued
+ function appears as the rhs in a realloc on assign statement, where
+ the size of the result is that of one of the actual arguments. */
+ if (e->expr_type == EXPR_VARIABLE
+ && e->symtree->n.sym->ns == NULL /* This is distinctive! */
+ && e->symtree->n.sym->ts.type == BT_CLASS
+ && e->ref && e->ref->type == REF_COMPONENT
+ && strcmp (e->ref->u.c.component->name, "_data") == 0)
+ sym = e->symtree->n.sym;
+
argse.data_not_needed = 1;
- if (gfc_is_class_array_function (actual->expr))
+ if (gfc_is_class_array_function (e))
{
/* For functions that return a class array conv_expr_descriptor is not
able to get the descriptor right. Therefore this special case. */
- gfc_conv_expr_reference (&argse, actual->expr);
+ gfc_conv_expr_reference (&argse, e);
+ argse.expr = gfc_build_addr_expr (NULL_TREE,
+ gfc_class_data_get (argse.expr));
+ }
+ else if (sym && sym->backend_decl)
+ {
+ gcc_assert (GFC_CLASS_TYPE_P (TREE_TYPE (sym->backend_decl)));
+ argse.expr = sym->backend_decl;
argse.expr = gfc_build_addr_expr (NULL_TREE,
gfc_class_data_get (argse.expr));
}
diff --git a/gcc/fortran/trans-openmp.c b/gcc/fortran/trans-openmp.c
index db21602b314..1eaad896503 100644
--- a/gcc/fortran/trans-openmp.c
+++ b/gcc/fortran/trans-openmp.c
@@ -548,6 +548,9 @@ gfc_omp_clause_default_ctor (tree clause, tree decl, tree outer)
build3_loc (input_location, COND_EXPR,
void_type_node, cond, then_b,
else_b));
+ /* Avoid -W*uninitialized warnings. */
+ if (DECL_P (decl))
+ TREE_NO_WARNING (decl) = 1;
}
else
gfc_add_expr_to_block (&block, then_b);
@@ -654,6 +657,9 @@ gfc_omp_clause_copy_ctor (tree clause, tree dest, tree src)
gfc_add_expr_to_block (&block,
build3_loc (input_location, COND_EXPR,
void_type_node, cond, then_b, else_b));
+ /* Avoid -W*uninitialized warnings. */
+ if (DECL_P (dest))
+ TREE_NO_WARNING (dest) = 1;
return gfc_finish_block (&block);
}
diff --git a/gcc/fortran/trans-stmt.c b/gcc/fortran/trans-stmt.c
index eb976c70a3a..32eb25dce79 100644
--- a/gcc/fortran/trans-stmt.c
+++ b/gcc/fortran/trans-stmt.c
@@ -1842,7 +1842,8 @@ trans_associate_var (gfc_symbol *sym, gfc_wrapped_block *block)
{
if (e->symtree
&& DECL_LANG_SPECIFIC (e->symtree->n.sym->backend_decl)
- && GFC_DECL_SAVED_DESCRIPTOR (e->symtree->n.sym->backend_decl))
+ && GFC_DECL_SAVED_DESCRIPTOR (e->symtree->n.sym->backend_decl)
+ && TREE_CODE (target_expr) != COMPONENT_REF)
/* Use the original class descriptor stored in the saved
descriptor to get the target_expr. */
target_expr =
diff --git a/gcc/fortran/trans-types.c b/gcc/fortran/trans-types.c
index b47475e1602..cc505aeb0bd 100644
--- a/gcc/fortran/trans-types.c
+++ b/gcc/fortran/trans-types.c
@@ -1213,7 +1213,8 @@ gfc_typenode_for_spec (gfc_typespec * spec, int codim)
{
spec->type = BT_INTEGER;
spec->kind = gfc_index_integer_kind;
- spec->f90_type = BT_VOID;
+ spec->f90_type = BT_VOID;
+ spec->is_c_interop = 1; /* Mark as escaping later. */
}
break;
case BT_VOID:
@@ -1230,6 +1231,9 @@ gfc_typenode_for_spec (gfc_typespec * spec, int codim)
basetype = pfunc_type_node;
}
break;
+ case BT_PROCEDURE:
+ basetype = pfunc_type_node;
+ break;
default:
gcc_unreachable ();
}
@@ -2978,7 +2982,8 @@ create_fn_spec (gfc_symbol *sym, tree fntype)
|| f->sym->ts.u.derived->attr.pointer_comp))
|| (f->sym->ts.type == BT_CLASS
&& (CLASS_DATA (f->sym)->ts.u.derived->attr.proc_pointer_comp
- || CLASS_DATA (f->sym)->ts.u.derived->attr.pointer_comp)))
+ || CLASS_DATA (f->sym)->ts.u.derived->attr.pointer_comp))
+ || (f->sym->ts.type == BT_INTEGER && f->sym->ts.is_c_interop))
spec[spec_len++] = '.';
else if (f->sym->attr.intent == INTENT_IN)
spec[spec_len++] = 'r';
@@ -3013,7 +3018,7 @@ get_formal_from_actual_arglist (gfc_symbol *sym, gfc_actual_arglist *actual_args
if (a->expr)
{
snprintf (name, GFC_MAX_SYMBOL_LEN, "_formal_%d", var_num ++);
- gfc_get_symbol (name, NULL, &s);
+ gfc_get_symbol (name, gfc_current_ns, &s);
if (a->expr->ts.type == BT_PROCEDURE)
{
s->attr.flavor = FL_PROCEDURE;
@@ -3021,6 +3026,13 @@ get_formal_from_actual_arglist (gfc_symbol *sym, gfc_actual_arglist *actual_args
else
{
s->ts = a->expr->ts;
+
+ if (s->ts.type == BT_CHARACTER)
+ s->ts.u.cl = gfc_get_charlen ();
+
+ s->ts.deferred = 0;
+ s->ts.is_iso_c = 0;
+ s->ts.is_c_interop = 0;
s->attr.flavor = FL_VARIABLE;
if (a->expr->rank > 0)
{
@@ -3030,6 +3042,7 @@ get_formal_from_actual_arglist (gfc_symbol *sym, gfc_actual_arglist *actual_args
}
}
s->attr.dummy = 1;
+ s->attr.artificial = 1;
s->attr.intent = INTENT_UNKNOWN;
(*f)->sym = s;
}
generated by cgit v1.2.3 (git 2.25.1) at 2024-06-13 17:46:58 +0000