From 109b1eeba24e5091bf3bdb6caedf7101a9dcaa6a Mon Sep 17 00:00:00 2001
From: Jim MacArthur <jim.macarthur@codethink.co.uk>
Date: Wed, 18 Nov 2015 11:50:41 +0000
Subject: [PATCH 16/23] Allow calls to intrinsics with smaller types than
specified
This feature is enabled by the `-std=extra-legacy` compiler flag.
---
0016-Allow-calls-to-intrinsics-with-smaller-types-than-sp.patch
diff -Nrup a/gcc/fortran/gfortran.h b/gcc/fortran/gfortran.h
--- a/gcc/fortran/gfortran.h 2018-06-05 11:59:14.269337049 -0600
+++ b/gcc/fortran/gfortran.h 2018-06-05 11:59:52.830081690 -0600
@@ -656,6 +656,13 @@ enum gfc_param_spec_type
SPEC_DEFERRED
};
+enum match_type
+{
+ MATCH_EXACT,
+ MATCH_PROMOTABLE,
+ MATCH_INVALID
+};
+
/************************* Structures *****************************/
/* Used for keeping things in balanced binary trees. */
@@ -3251,7 +3253,7 @@ bool gfc_add_interface (gfc_symbol *);
gfc_interface *gfc_current_interface_head (void);
void gfc_set_current_interface_head (gfc_interface *);
gfc_symtree* gfc_find_sym_in_symtree (gfc_symbol*);
-bool gfc_arglist_matches_symbol (gfc_actual_arglist**, gfc_symbol*);
+bool gfc_arglist_matches_symbol (gfc_actual_arglist**, gfc_symbol*, enum match_type mtype);
bool gfc_check_operator_interface (gfc_symbol*, gfc_intrinsic_op, locus);
bool gfc_has_vector_subscript (gfc_expr*);
gfc_intrinsic_op gfc_equivalent_op (gfc_intrinsic_op);
diff -Nrup a/gcc/fortran/interface.c b/gcc/fortran/interface.c
--- a/gcc/fortran/interface.c 2018-03-03 06:51:39.000000000 -0700
+++ b/gcc/fortran/interface.c 2018-06-05 12:01:11.218559539 -0600
@@ -682,7 +682,7 @@ gfc_compare_derived_types (gfc_symbol *d
/* Compare two typespecs, recursively if necessary. */
bool
-gfc_compare_types (gfc_typespec *ts1, gfc_typespec *ts2)
+gfc_compare_types_generic (gfc_typespec *ts1, gfc_typespec *ts2, enum match_type mtype)
{
/* See if one of the typespecs is a BT_VOID, which is what is being used
to allow the funcs like c_f_pointer to accept any pointer type.
@@ -721,12 +721,23 @@ gfc_compare_types (gfc_typespec *ts1, gf
return compare_union_types (ts1->u.derived, ts2->u.derived);
if (ts1->type != BT_DERIVED && ts1->type != BT_CLASS)
- return (ts1->kind == ts2->kind);
+ {
+ if (mtype == MATCH_PROMOTABLE)
+ return (ts1->kind >= ts2->kind);
+ else
+ return (ts1->kind == ts2->kind);
+ }
+
/* Compare derived types. */
return gfc_type_compatible (ts1, ts2);
}
+bool
+gfc_compare_types (gfc_typespec *ts1, gfc_typespec *ts2)
+{
+ return gfc_compare_types_generic (ts1, ts2, MATCH_EXACT);
+}
static bool
compare_type (gfc_symbol *s1, gfc_symbol *s2)
@@ -743,7 +754,9 @@ compare_type (gfc_symbol *s1, gfc_symbol
return compare_type (s1, s2);
}
-
+/* Given two symbols that are formal arguments, compare their ranks
+ and types. Returns nonzero if they have the same rank and type,
+ zero otherwise. */
static bool
compare_rank (gfc_symbol *s1, gfc_symbol *s2)
{
@@ -2150,7 +2163,7 @@ argument_rank_mismatch (const char *name
static bool
compare_parameter (gfc_symbol *formal, gfc_expr *actual,
- int ranks_must_agree, int is_elemental, locus *where)
+ int ranks_must_agree, int is_elemental, locus *where, enum match_type mtype)
{
gfc_ref *ref;
bool rank_check, is_pointer;
@@ -2242,7 +2255,7 @@ compare_parameter (gfc_symbol *formal, g
&& actual->ts.type != BT_HOLLERITH
&& formal->ts.type != BT_ASSUMED
&& !(formal->attr.ext_attr & (1 << EXT_ATTR_NO_ARG_CHECK))
- && !gfc_compare_types (&formal->ts, &actual->ts)
+ && !gfc_compare_types_generic (&formal->ts, &actual->ts, mtype)
&& !(formal->ts.type == BT_DERIVED && actual->ts.type == BT_CLASS
&& gfc_compare_derived_types (formal->ts.u.derived,
CLASS_DATA (actual)->ts.u.derived)))
@@ -2792,7 +2805,8 @@ is_procptr_result (gfc_expr *expr)
static bool
compare_actual_formal (gfc_actual_arglist **ap, gfc_formal_arglist *formal,
int ranks_must_agree, int is_elemental,
- bool in_statement_function, locus *where)
+ bool in_statement_function, locus *where,
+ enum match_type mtype)
{
gfc_actual_arglist **new_arg, *a, *actual;
gfc_formal_arglist *f;
@@ -2918,7 +2932,7 @@ compare_actual_formal (gfc_actual_arglis
}
if (!compare_parameter (f->sym, a->expr, ranks_must_agree,
- is_elemental, where))
+ is_elemental, where, mtype))
return false;
/* TS 29113, 6.3p2. */
@@ -3666,7 +3680,7 @@ gfc_procedure_use (gfc_symbol *sym, gfc_
/* For a statement function, check that types and type parameters of actual
arguments and dummy arguments match. */
if (!compare_actual_formal (ap, dummy_args, 0, sym->attr.elemental,
- sym->attr.proc == PROC_ST_FUNCTION, where))
+ sym->attr.proc == PROC_ST_FUNCTION, where, MATCH_PROMOTABLE))
return false;
if (!check_intents (dummy_args, *ap))
@@ -3715,7 +3730,7 @@ gfc_ppc_use (gfc_component *comp, gfc_ac
}
if (!compare_actual_formal (ap, comp->ts.interface->formal, 0,
- comp->attr.elemental, false, where))
+ comp->attr.elemental, false, where, MATCH_EXACT))
return;
check_intents (comp->ts.interface->formal, *ap);
@@ -3729,7 +3744,7 @@ gfc_ppc_use (gfc_component *comp, gfc_ac
GENERIC resolution. */
bool
-gfc_arglist_matches_symbol (gfc_actual_arglist** args, gfc_symbol* sym)
+gfc_arglist_matches_symbol (gfc_actual_arglist** args, gfc_symbol* sym, enum match_type mtype)
{
gfc_formal_arglist *dummy_args;
bool r;
@@ -3740,7 +3755,7 @@ gfc_arglist_matches_symbol (gfc_actual_a
dummy_args = gfc_sym_get_dummy_args (sym);
r = !sym->attr.elemental;
- if (compare_actual_formal (args, dummy_args, r, !r, false, NULL))
+ if (compare_actual_formal (args, dummy_args, r, !r, false, NULL, mtype))
{
check_intents (dummy_args, *args);
if (warn_aliasing)
@@ -3766,7 +3781,8 @@ gfc_search_interface (gfc_interface *int
locus null_expr_loc;
gfc_actual_arglist *a;
bool has_null_arg = false;
-
+ enum match_type mtypes[] = { MATCH_EXACT, MATCH_PROMOTABLE };
+ int i;
for (a = *ap; a; a = a->next)
if (a->expr && a->expr->expr_type == EXPR_NULL
&& a->expr->ts.type == BT_UNKNOWN)
@@ -3776,38 +3792,43 @@ gfc_search_interface (gfc_interface *int
break;
}
- for (; intr; intr = intr->next)
+ for (i=0; i<2; i++)
{
+ for (; intr; intr = intr->next)
+ {
+ if (intr->sym->attr.flavor == FL_DERIVED)
+ continue;
if (gfc_fl_struct (intr->sym->attr.flavor))
continue;
- if (sub_flag && intr->sym->attr.function)
- continue;
- if (!sub_flag && intr->sym->attr.subroutine)
+ if (sub_flag && intr->sym->attr.function)
+ continue;
+ if (!sub_flag && intr->sym->attr.subroutine)
continue;
- if (gfc_arglist_matches_symbol (ap, intr->sym))
- {
- if (has_null_arg && null_sym)
- {
- gfc_error ("MOLD= required in NULL() argument at %L: Ambiguity "
- "between specific functions %s and %s",
- &null_expr_loc, null_sym->name, intr->sym->name);
- return NULL;
- }
- else if (has_null_arg)
+ if (gfc_arglist_matches_symbol (ap, intr->sym, mtypes[i]))
{
- null_sym = intr->sym;
- continue;
- }
+ if (has_null_arg && null_sym)
+ {
+ gfc_error ("MOLD= required in NULL() argument at %L: Ambiguity "
+ "between specific functions %s and %s",
+ &null_expr_loc, null_sym->name, intr->sym->name);
+ return NULL;
+ }
+ else if (has_null_arg)
+ {
+ null_sym = intr->sym;
+ continue;
+ }
- /* Satisfy 12.4.4.1 such that an elemental match has lower
- weight than a non-elemental match. */
- if (intr->sym->attr.elemental)
- {
- elem_sym = intr->sym;
- continue;
+ /* Satisfy 12.4.4.1 such that an elemental match has lower
+ weight than a non-elemental match. */
+ if (intr->sym->attr.elemental)
+ {
+ elem_sym = intr->sym;
+ continue;
+ }
+ return intr->sym;
}
- return intr->sym;
}
}
@@ -3942,7 +3963,7 @@ matching_typebound_op (gfc_expr** tb_bas
/* Check if this arglist matches the formal. */
argcopy = gfc_copy_actual_arglist (args);
- matches = gfc_arglist_matches_symbol (&argcopy, target);
+ matches = gfc_arglist_matches_symbol (&argcopy, target, MATCH_EXACT);
gfc_free_actual_arglist (argcopy);
/* Return if we found a match. */
diff -Nrup a/gcc/fortran/intrinsic.c b/gcc/fortran/intrinsic.c
--- a/gcc/fortran/intrinsic.c 2018-06-05 11:59:14.278336990 -0600
+++ b/gcc/fortran/intrinsic.c 2018-06-05 11:59:52.831081683 -0600
@@ -4229,6 +4229,16 @@ check_arglist (gfc_actual_arglist **ap,
if (ts.kind == 0)
ts.kind = actual->expr->ts.kind;
+ /* ts.kind is the argument spec. actual is what was passed. */
+
+ if (actual->expr->ts.kind < ts.kind
+ && ts.type == BT_INTEGER)
+ {
+ /* If it was OK to overwrite ts.kind in the previous case, it
+ should be fine here... */
+ ts.kind = actual->expr->ts.kind;
+ }
+
if (!gfc_compare_types (&ts, &actual->expr->ts))
{
if (error_flag)
diff -Nrup a/gcc/fortran/resolve.c b/gcc/fortran/resolve.c
--- a/gcc/fortran/resolve.c 2018-06-05 11:59:14.291336904 -0600
+++ b/gcc/fortran/resolve.c 2018-06-05 11:59:52.833081670 -0600
@@ -6055,7 +6055,7 @@ resolve_typebound_generic_call (gfc_expr
&& gfc_sym_get_dummy_args (target) == NULL);
/* Check if this arglist matches the formal. */
- matches = gfc_arglist_matches_symbol (&args, target);
+ matches = gfc_arglist_matches_symbol (&args, target, MATCH_EXACT);
/* Clean up and break out of the loop if we've found it. */
gfc_free_actual_arglist (args);