From 109b1eeba24e5091bf3bdb6caedf7101a9dcaa6a Mon Sep 17 00:00:00 2001 From: Jim MacArthur 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);