diff options
Diffstat (limited to 'gcc/fortran/intrinsic.c')
| -rw-r--r-- | gcc/fortran/intrinsic.c | 218 |
1 files changed, 172 insertions, 46 deletions
diff --git a/gcc/fortran/intrinsic.c b/gcc/fortran/intrinsic.c index 4c55a2c99ba..9b11db4bb64 100644 --- a/gcc/fortran/intrinsic.c +++ b/gcc/fortran/intrinsic.c @@ -175,7 +175,7 @@ find_char_conv (gfc_typespec *from, gfc_typespec *to) and call the proper check function rather than forcing each function to manipulate the argument list. */ -static try +static gfc_try do_check (gfc_intrinsic_sym *specific, gfc_actual_arglist *arg) { gfc_expr *a1, *a2, *a3, *a4, *a5; @@ -334,7 +334,7 @@ add_sym (const char *name, gfc_isym_id id, enum klass cl, int actual_ok, bt type static void add_sym_0 (const char *name, gfc_isym_id id, enum klass cl, int actual_ok, bt type, int kind, int standard, - try (*check) (void), + gfc_try (*check) (void), gfc_expr *(*simplify) (void), void (*resolve) (gfc_expr *)) { @@ -376,7 +376,7 @@ add_sym_0s (const char *name, gfc_isym_id id, int standard, void (*resolve) (gfc static void add_sym_1 (const char *name, gfc_isym_id id, enum klass cl, int actual_ok, bt type, int kind, int standard, - try (*check) (gfc_expr *), + gfc_try (*check) (gfc_expr *), gfc_expr *(*simplify) (gfc_expr *), void (*resolve) (gfc_expr *, gfc_expr *), const char *a1, bt type1, int kind1, int optional1) @@ -400,7 +400,7 @@ add_sym_1 (const char *name, gfc_isym_id id, enum klass cl, int actual_ok, bt ty static void add_sym_1s (const char *name, gfc_isym_id id, enum klass cl, bt type, int kind, int standard, - try (*check) (gfc_expr *), + gfc_try (*check) (gfc_expr *), gfc_expr *(*simplify) (gfc_expr *), void (*resolve) (gfc_code *), const char *a1, bt type1, int kind1, int optional1) @@ -425,7 +425,7 @@ add_sym_1s (const char *name, gfc_isym_id id, enum klass cl, bt type, int kind, static void add_sym_1m (const char *name, gfc_isym_id id, enum klass cl, int actual_ok, bt type, int kind, int standard, - try (*check) (gfc_actual_arglist *), + gfc_try (*check) (gfc_actual_arglist *), gfc_expr *(*simplify) (gfc_expr *), void (*resolve) (gfc_expr *, gfc_actual_arglist *), const char *a1, bt type1, int kind1, int optional1, @@ -452,7 +452,7 @@ add_sym_1m (const char *name, gfc_isym_id id, enum klass cl, int actual_ok, bt t static void add_sym_2 (const char *name, gfc_isym_id id, enum klass cl, int actual_ok, bt type, int kind, int standard, - try (*check) (gfc_expr *, gfc_expr *), + gfc_try (*check) (gfc_expr *, gfc_expr *), gfc_expr *(*simplify) (gfc_expr *, gfc_expr *), void (*resolve) (gfc_expr *, gfc_expr *, gfc_expr *), const char *a1, bt type1, int kind1, int optional1, @@ -478,7 +478,7 @@ add_sym_2 (const char *name, gfc_isym_id id, enum klass cl, int actual_ok, bt ty static void add_sym_2s (const char *name, gfc_isym_id id, enum klass cl, bt type, int kind, int standard, - try (*check) (gfc_expr *, gfc_expr *), + gfc_try (*check) (gfc_expr *, gfc_expr *), gfc_expr *(*simplify) (gfc_expr *, gfc_expr *), void (*resolve) (gfc_code *), const char *a1, bt type1, int kind1, int optional1, @@ -505,7 +505,7 @@ add_sym_2s (const char *name, gfc_isym_id id, enum klass cl, bt type, int kind, static void add_sym_3 (const char *name, gfc_isym_id id, enum klass cl, int actual_ok, bt type, int kind, int standard, - try (*check) (gfc_expr *, gfc_expr *, gfc_expr *), + gfc_try (*check) (gfc_expr *, gfc_expr *, gfc_expr *), gfc_expr *(*simplify) (gfc_expr *, gfc_expr *, gfc_expr *), void (*resolve) (gfc_expr *, gfc_expr *, gfc_expr *, gfc_expr *), const char *a1, bt type1, int kind1, int optional1, @@ -534,7 +534,7 @@ add_sym_3 (const char *name, gfc_isym_id id, enum klass cl, int actual_ok, bt ty static void add_sym_3ml (const char *name, gfc_isym_id id, enum klass cl, int actual_ok, bt type, int kind, int standard, - try (*check) (gfc_actual_arglist *), + gfc_try (*check) (gfc_actual_arglist *), gfc_expr *(*simplify) (gfc_expr *, gfc_expr *, gfc_expr *), void (*resolve) (gfc_expr *, gfc_expr *, gfc_expr *, gfc_expr *), const char *a1, bt type1, int kind1, int optional1, @@ -563,7 +563,7 @@ add_sym_3ml (const char *name, gfc_isym_id id, enum klass cl, int actual_ok, bt static void add_sym_3red (const char *name, gfc_isym_id id, enum klass cl, int actual_ok, bt type, int kind, int standard, - try (*check) (gfc_actual_arglist *), + gfc_try (*check) (gfc_actual_arglist *), gfc_expr *(*simplify) (gfc_expr *, gfc_expr *, gfc_expr *), void (*resolve) (gfc_expr *, gfc_expr *, gfc_expr *, gfc_expr *), const char *a1, bt type1, int kind1, int optional1, @@ -591,7 +591,7 @@ add_sym_3red (const char *name, gfc_isym_id id, enum klass cl, int actual_ok, bt static void add_sym_3s (const char *name, gfc_isym_id id, enum klass cl, bt type, int kind, int standard, - try (*check) (gfc_expr *, gfc_expr *, gfc_expr *), + gfc_try (*check) (gfc_expr *, gfc_expr *, gfc_expr *), gfc_expr *(*simplify) (gfc_expr *, gfc_expr *, gfc_expr *), void (*resolve) (gfc_code *), const char *a1, bt type1, int kind1, int optional1, @@ -620,7 +620,7 @@ add_sym_3s (const char *name, gfc_isym_id id, enum klass cl, bt type, int kind, static void add_sym_4 (const char *name, gfc_isym_id id, enum klass cl, int actual_ok, bt type, int kind, int standard, - try (*check) (gfc_expr *, gfc_expr *, gfc_expr *, gfc_expr *), + gfc_try (*check) (gfc_expr *, gfc_expr *, gfc_expr *, gfc_expr *), gfc_expr *(*simplify) (gfc_expr *, gfc_expr *, gfc_expr *, gfc_expr *), void (*resolve) (gfc_expr *, gfc_expr *, gfc_expr *, gfc_expr *, @@ -652,7 +652,7 @@ add_sym_4 (const char *name, gfc_isym_id id, enum klass cl, int actual_ok, bt ty static void add_sym_4s (const char *name, gfc_isym_id id, enum klass cl, bt type, int kind, int standard, - try (*check) (gfc_expr *, gfc_expr *, gfc_expr *, gfc_expr *), + gfc_try (*check) (gfc_expr *, gfc_expr *, gfc_expr *, gfc_expr *), gfc_expr *(*simplify) (gfc_expr *, gfc_expr *, gfc_expr *, gfc_expr *), void (*resolve) (gfc_code *), @@ -683,7 +683,7 @@ add_sym_4s (const char *name, gfc_isym_id id, enum klass cl, bt type, int kind, static void add_sym_5s (const char *name, gfc_isym_id id, enum klass cl, bt type, int kind, int standard, - try (*check) (gfc_expr *, gfc_expr *, gfc_expr *, gfc_expr *, + gfc_try (*check) (gfc_expr *, gfc_expr *, gfc_expr *, gfc_expr *, gfc_expr *), gfc_expr *(*simplify) (gfc_expr *, gfc_expr *, gfc_expr *, gfc_expr *, gfc_expr *), @@ -807,15 +807,47 @@ gfc_intrinsic_actual_ok (const char *name, const bool subroutine_flag) } -/* Given a string, figure out if it is the name of an intrinsic - subroutine or function. There are no generic intrinsic - subroutines, they are all specific. */ +/* Given a symbol, find out if it is (and is to be treated) an intrinsic. If + it's name refers to an intrinsic but this intrinsic is not included in the + selected standard, this returns FALSE and sets the symbol's external + attribute. */ -int -gfc_intrinsic_name (const char *name, int subroutine_flag) +bool +gfc_is_intrinsic (gfc_symbol* sym, int subroutine_flag, locus loc) { - return subroutine_flag ? gfc_find_subroutine (name) != NULL - : gfc_find_function (name) != NULL; + gfc_intrinsic_sym* isym; + const char* symstd; + + /* If INTRINSIC/EXTERNAL state is already known, return. */ + if (sym->attr.intrinsic) + return true; + if (sym->attr.external) + return false; + + if (subroutine_flag) + isym = gfc_find_subroutine (sym->name); + else + isym = gfc_find_function (sym->name); + + /* No such intrinsic available at all? */ + if (!isym) + return false; + + /* See if this intrinsic is allowed in the current standard. */ + if (gfc_check_intrinsic_standard (isym, &symstd, false, loc) == FAILURE) + { + if (gfc_option.warn_intrinsics_std) + gfc_warning_now ("The intrinsic '%s' at %L is not included in the" + " selected standard but %s and '%s' will be treated as" + " if declared EXTERNAL. Use an appropriate -std=*" + " option or define -fall-intrinsics to allow this" + " intrinsic.", sym->name, &loc, symstd, sym->name); + sym->attr.external = 1; + + return false; + } + + return true; } @@ -2992,7 +3024,7 @@ remove_nullargs (gfc_actual_arglist **ap) wrong (say, a missing required argument) we abort sorting and return FAILURE. */ -static try +static gfc_try sort_actual (const char *name, gfc_actual_arglist **ap, gfc_intrinsic_arg *formal, locus *where) { @@ -3113,7 +3145,7 @@ do_sort: list. The lists are checked for agreement of type. We don't check for arrayness here. */ -static try +static gfc_try check_arglist (gfc_actual_arglist **ap, gfc_intrinsic_sym *sym, int error_flag) { @@ -3245,7 +3277,7 @@ resolve_intrinsic (gfc_intrinsic_sym *specific, gfc_expr *e) of the simplification, SUCCESS if the simplification worked, even if nothing has changed in the expression itself. */ -static try +static gfc_try do_simplify (gfc_intrinsic_sym *specific, gfc_expr *e) { gfc_expr *result, *a1, *a2, *a3, *a4, *a5; @@ -3374,11 +3406,11 @@ init_arglist (gfc_intrinsic_sym *isym) intrinsic's formal argument list. Return SUCCESS if the expression and intrinsic match, FAILURE otherwise. */ -static try +static gfc_try check_specific (gfc_intrinsic_sym *specific, gfc_expr *expr, int error_flag) { gfc_actual_arglist *arg, **ap; - try t; + gfc_try t; ap = &expr->value.function.actual; @@ -3448,21 +3480,82 @@ check_specific (gfc_intrinsic_sym *specific, gfc_expr *expr, int error_flag) /* Check whether an intrinsic belongs to whatever standard the user - has chosen. */ - -static try -check_intrinsic_standard (const char *name, int standard, locus *where) + has chosen, taking also into account -fall-intrinsics. Here, no + warning/error is emitted; but if symstd is not NULL, it is pointed to a + textual representation of the symbols standard status (like + "new in Fortran 2008", "a GNU extension" or "obsolescent in Fortran 95") that + can be used to construct a detailed warning/error message in case of + a FAILURE. */ + +gfc_try +gfc_check_intrinsic_standard (const gfc_intrinsic_sym* isym, + const char** symstd, bool silent, locus where) { - /* Do not warn about GNU-extensions if -std=gnu. */ - if (!gfc_option.warn_nonstd_intrinsics - || (standard == GFC_STD_GNU && gfc_option.warn_std & GFC_STD_GNU)) + const char* symstd_msg; + + /* For -fall-intrinsics, just succeed. */ + if (gfc_option.flag_all_intrinsics) return SUCCESS; - if (gfc_notify_std (standard, "Intrinsic '%s' at %L is not included " - "in the selected standard", name, where) == FAILURE) - return FAILURE; + /* Find the symbol's standard message for later usage. */ + switch (isym->standard) + { + case GFC_STD_F77: + symstd_msg = "available since Fortran 77"; + break; - return SUCCESS; + case GFC_STD_F95_OBS: + symstd_msg = "obsolescent in Fortran 95"; + break; + + case GFC_STD_F95_DEL: + symstd_msg = "deleted in Fortran 95"; + break; + + case GFC_STD_F95: + symstd_msg = "new in Fortran 95"; + break; + + case GFC_STD_F2003: + symstd_msg = "new in Fortran 2003"; + break; + + case GFC_STD_F2008: + symstd_msg = "new in Fortran 2008"; + break; + + case GFC_STD_GNU: + symstd_msg = "a GNU Fortran extension"; + break; + + case GFC_STD_LEGACY: + symstd_msg = "for backward compatibility"; + break; + + default: + gfc_internal_error ("Invalid standard code on intrinsic '%s' (%d)", + isym->name, isym->standard); + } + + /* If warning about the standard, warn and succeed. */ + if (gfc_option.warn_std & isym->standard) + { + /* Do only print a warning if not a GNU extension. */ + if (!silent && isym->standard != GFC_STD_GNU) + gfc_warning ("Intrinsic '%s' (is %s) is used at %L", + isym->name, _(symstd_msg), &where); + + return SUCCESS; + } + + /* If allowing the symbol's standard, succeed, too. */ + if (gfc_option.allow_std & isym->standard) + return SUCCESS; + + /* Otherwise, fail. */ + if (symstd) + *symstd = _(symstd_msg); + return FAILURE; } @@ -3508,9 +3601,6 @@ gfc_intrinsic_func_interface (gfc_expr *expr, int error_flag) return MATCH_NO; } - if (check_intrinsic_standard (name, isym->standard, &expr->where) == FAILURE) - return MATCH_ERROR; - if ((isym->id == GFC_ISYM_REAL || isym->id == GFC_ISYM_DBLE || isym->id == GFC_ISYM_CMPLX) && gfc_init_expr @@ -3605,9 +3695,6 @@ gfc_intrinsic_sub_interface (gfc_code *c, int error_flag) if (isym == NULL) return MATCH_NO; - if (check_intrinsic_standard (name, isym->standard, &c->loc) == FAILURE) - return MATCH_ERROR; - gfc_suppress_error = !error_flag; init_arglist (isym); @@ -3657,7 +3744,7 @@ fail: /* Call gfc_convert_type() with warning enabled. */ -try +gfc_try gfc_convert_type (gfc_expr *expr, gfc_typespec *ts, int eflag) { return gfc_convert_type_warn (expr, ts, eflag, 1); @@ -3674,7 +3761,7 @@ gfc_convert_type (gfc_expr *expr, gfc_typespec *ts, int eflag) 'wflag' controls the warning related to conversion. */ -try +gfc_try gfc_convert_type_warn (gfc_expr *expr, gfc_typespec *ts, int eflag, int wflag) { gfc_intrinsic_sym *sym; @@ -3773,7 +3860,7 @@ bad: } -try +gfc_try gfc_convert_chartype (gfc_expr *expr, gfc_typespec *ts) { gfc_intrinsic_sym *sym; @@ -3827,3 +3914,42 @@ gfc_convert_chartype (gfc_expr *expr, gfc_typespec *ts) return SUCCESS; } + + +/* Check if the passed name is name of an intrinsic (taking into account the + current -std=* and -fall-intrinsic settings). If it is, see if we should + warn about this as a user-procedure having the same name as an intrinsic + (-Wintrinsic-shadow enabled) and do so if we should. */ + +void +gfc_warn_intrinsic_shadow (const gfc_symbol* sym, bool in_module, bool func) +{ + gfc_intrinsic_sym* isym; + + /* If the warning is disabled, do nothing at all. */ + if (!gfc_option.warn_intrinsic_shadow) + return; + + /* Try to find an intrinsic of the same name. */ + if (func) + isym = gfc_find_function (sym->name); + else + isym = gfc_find_subroutine (sym->name); + + /* If no intrinsic was found with this name or it's not included in the + selected standard, everything's fine. */ + if (!isym || gfc_check_intrinsic_standard (isym, NULL, true, + sym->declared_at) == FAILURE) + return; + + /* Emit the warning. */ + if (in_module) + gfc_warning ("'%s' declared at %L may shadow the intrinsic of the same" + " name. In order to call the intrinsic, explicit INTRINSIC" + " declarations may be required.", + sym->name, &sym->declared_at); + else + gfc_warning ("'%s' declared at %L is also the name of an intrinsic. It can" + " only be called via an explicit interface or if declared" + " EXTERNAL.", sym->name, &sym->declared_at); +} |