/* Build up a list of intrinsic subroutines and functions for the
name-resolution stage.
- Copyright (C) 2000, 2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009
+ Copyright (C) 2000, 2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008,
+ 2009, 2010
Free Software Foundation, Inc.
Contributed by Andy Vaught & Katherine Holcomb
/* Namespace to hold the resolved symbols for intrinsic subroutines. */
static gfc_namespace *gfc_intrinsic_namespace;
-int gfc_init_expr = 0;
+bool gfc_init_expr_flag = false;
/* Pointers to an intrinsic function and its argument names that are being
checked. */
/* See if this intrinsic is allowed in the current standard. */
if (gfc_check_intrinsic_standard (isym, &symstd, false, loc) == FAILURE)
{
- if (sym->attr.proc == PROC_UNKNOWN)
- {
- 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);
- gfc_add_external (&sym->attr, &loc);
- }
+ if (sym->attr.proc == PROC_UNKNOWN
+ && 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);
return false;
}
*y = "y", *sz = "size", *sta = "string_a", *stb = "string_b",
*z = "z", *ln = "len", *ut = "unit", *han = "handler",
*num = "number", *tm = "time", *nm = "name", *md = "mode",
- *vl = "values", *p1 = "path1", *p2 = "path2", *com = "command";
+ *vl = "values", *p1 = "path1", *p2 = "path2", *com = "command",
+ *ca = "coarray", *sub = "sub";
int di, dr, dd, dl, dc, dz, ii;
add_sym_2 ("extends_type_of", GFC_ISYM_EXTENDS_TYPE_OF, CLASS_INQUIRY,
ACTUAL_NO, BT_LOGICAL, dl, GFC_STD_F2003,
- gfc_check_same_type_as, NULL, NULL,
+ gfc_check_same_type_as, NULL, gfc_resolve_extends_type_of,
a, BT_UNKNOWN, 0, REQUIRED,
mo, BT_UNKNOWN, 0, REQUIRED);
make_generic ("fput", GFC_ISYM_FPUT, GFC_STD_GNU);
- add_sym_1 ("gamma", GFC_ISYM_GAMMA, CLASS_ELEMENTAL, ACTUAL_NO, BT_REAL, dr,
+ add_sym_1 ("gamma", GFC_ISYM_TGAMMA, CLASS_ELEMENTAL, ACTUAL_NO, BT_REAL, dr,
GFC_STD_F2008, gfc_check_fn_r, gfc_simplify_gamma,
gfc_resolve_gamma, x, BT_REAL, dr, REQUIRED);
- add_sym_1 ("dgamma", GFC_ISYM_GAMMA, CLASS_ELEMENTAL, ACTUAL_NO, BT_REAL, dr, GFC_STD_GNU,
+ add_sym_1 ("dgamma", GFC_ISYM_TGAMMA, CLASS_ELEMENTAL, ACTUAL_NO, BT_REAL, dr, GFC_STD_GNU,
gfc_check_fn_d, gfc_simplify_gamma, gfc_resolve_gamma,
x, BT_REAL, dr, REQUIRED);
- make_generic ("gamma", GFC_ISYM_GAMMA, GFC_STD_F2008);
+ make_generic ("gamma", GFC_ISYM_TGAMMA, GFC_STD_F2008);
/* Unix IDs (g77 compatibility) */
add_sym_1 ("getcwd", GFC_ISYM_GETCWD, NO_CLASS, ACTUAL_NO, BT_INTEGER, di, GFC_STD_GNU,
make_generic ("ierrno", GFC_ISYM_IERRNO, GFC_STD_GNU);
+ add_sym_2 ("image_index", GFC_ISYM_IMAGE_INDEX, CLASS_INQUIRY, ACTUAL_NO, BT_INTEGER, di, GFC_STD_F2008,
+ gfc_check_image_index, gfc_simplify_image_index, gfc_resolve_image_index,
+ ca, BT_REAL, dr, REQUIRED, sub, BT_INTEGER, ii, REQUIRED);
+
/* The resolution function for INDEX is called gfc_resolve_index_func
because the name gfc_resolve_index is already used in resolve.c. */
add_sym_4 ("index", GFC_ISYM_INDEX, CLASS_ELEMENTAL, ACTUAL_YES,
make_generic ("lbound", GFC_ISYM_LBOUND, GFC_STD_F95);
+ add_sym_3 ("lcobound", GFC_ISYM_LCOBOUND, CLASS_INQUIRY, ACTUAL_NO,
+ BT_INTEGER, di, GFC_STD_F2008,
+ gfc_check_lcobound, gfc_simplify_lcobound, gfc_resolve_lcobound,
+ ca, BT_REAL, dr, REQUIRED, dm, BT_INTEGER, ii, OPTIONAL,
+ kind, BT_INTEGER, di, OPTIONAL);
+
+ make_generic ("lcobound", GFC_ISYM_LCOBOUND, GFC_STD_F2008);
+
add_sym_1 ("leadz", GFC_ISYM_LEADZ, CLASS_ELEMENTAL, ACTUAL_NO,
BT_INTEGER, di, GFC_STD_F2008,
gfc_check_i, gfc_simplify_leadz, NULL,
make_generic ("null", GFC_ISYM_NULL, GFC_STD_F95);
+ add_sym_0 ("num_images", GFC_ISYM_NUMIMAGES, CLASS_INQUIRY, ACTUAL_NO, BT_INTEGER, di, GFC_STD_F2008,
+ NULL, gfc_simplify_num_images, NULL);
+
add_sym_3 ("pack", GFC_ISYM_PACK, CLASS_TRANSFORMATIONAL, ACTUAL_NO, BT_REAL, dr, GFC_STD_F95,
gfc_check_pack, gfc_simplify_pack, gfc_resolve_pack,
ar, BT_REAL, dr, REQUIRED, msk, BT_LOGICAL, dl, REQUIRED,
make_generic ("tanh", GFC_ISYM_TANH, GFC_STD_F77);
+ add_sym_2 ("this_image", GFC_ISYM_THIS_IMAGE, CLASS_INQUIRY, ACTUAL_NO, BT_INTEGER, di, GFC_STD_F2008,
+ gfc_check_this_image, gfc_simplify_this_image, gfc_resolve_this_image,
+ ca, BT_REAL, dr, OPTIONAL, dm, BT_INTEGER, ii, OPTIONAL);
+
add_sym_0 ("time", GFC_ISYM_TIME, NO_CLASS, ACTUAL_NO, BT_INTEGER, di, GFC_STD_GNU,
NULL, NULL, gfc_resolve_time);
make_generic ("ubound", GFC_ISYM_UBOUND, GFC_STD_F95);
+ add_sym_3 ("ucobound", GFC_ISYM_UCOBOUND, CLASS_INQUIRY, ACTUAL_NO,
+ BT_INTEGER, di, GFC_STD_F2008,
+ gfc_check_ucobound, gfc_simplify_ucobound, gfc_resolve_ucobound,
+ ca, BT_REAL, dr, REQUIRED, dm, BT_INTEGER, ii, OPTIONAL,
+ kind, BT_INTEGER, di, OPTIONAL);
+
+ make_generic ("ucobound", GFC_ISYM_UCOBOUND, GFC_STD_F2008);
+
/* g77 compatibility for UMASK. */
add_sym_1 ("umask", GFC_ISYM_UMASK, NO_CLASS, ACTUAL_NO, BT_INTEGER, di,
GFC_STD_GNU, gfc_check_umask, NULL, gfc_resolve_umask,
if (f->actual != NULL)
{
- gfc_error ("Argument '%s' is appears twice in call to '%s' at %L",
+ gfc_error ("Argument '%s' appears twice in call to '%s' at %L",
f->name, name, where);
return FAILURE;
}
if ((isym->id == GFC_ISYM_REAL || isym->id == GFC_ISYM_DBLE
|| isym->id == GFC_ISYM_CMPLX)
- && gfc_init_expr
+ && gfc_init_expr_flag
&& gfc_notify_std (GFC_STD_F2003, "Fortran 2003: Function '%s' "
"as initialization expression at %L", name,
&expr->where) == FAILURE)
(4) A reference to an elemental standard intrinsic function,
where each argument is an initialization expression */
- if (gfc_init_expr && isym->elemental && flag
+ if (gfc_init_expr_flag && isym->elemental && flag
&& gfc_notify_std (GFC_STD_F2003, "Fortran 2003: Elemental function "
"as initialization expression with non-integer/non-"
"character arguments at %L", &expr->where) == FAILURE)
gfc_warning_now ("Extension: Conversion from %s to %s at %L",
gfc_typename (&from_ts), gfc_typename (ts), &expr->where);
else if (wflag && gfc_option.warn_conversion)
- gfc_warning_now ("Conversion from %s to %s at %L",
- gfc_typename (&from_ts), gfc_typename (ts), &expr->where);
+ {
+ /* If the types are the same (but not LOGICAL), and if from-kind
+ is larger than to-kind, this may indicate a loss of precision.
+ The same holds for conversions from REAL to COMPLEX. */
+ if (((from_ts.type == ts->type && from_ts.type != BT_LOGICAL)
+ && from_ts.kind > ts->kind)
+ || ((from_ts.type == BT_REAL && ts->type == BT_COMPLEX)
+ && from_ts.kind > ts->kind))
+ gfc_warning_now ("Possible loss of precision in conversion "
+ "from %s to %s at %L", gfc_typename (&from_ts),
+ gfc_typename (ts), &expr->where);
+
+ /* If INTEGER is converted to REAL/COMPLEX, this is generally ok if
+ the kind of the INTEGER value is less or equal to the kind of the
+ REAL/COMPLEX one. Otherwise the value may not fit.
+ Assignment of an overly large integer constant also generates
+ an overflow error with range checking. */
+ else if (from_ts.type == BT_INTEGER
+ && (ts->type == BT_REAL || ts->type == BT_COMPLEX)
+ && from_ts.kind > ts->kind)
+ gfc_warning_now ("Possible loss of digits in conversion "
+ "from %s to %s at %L", gfc_typename (&from_ts),
+ gfc_typename (ts), &expr->where);
+
+ /* If REAL/COMPLEX is converted to INTEGER, or COMPLEX is converted
+ to REAL we almost certainly have a loss of digits, regardless of
+ the respective kinds. */
+ else if (((from_ts.type == BT_REAL || from_ts.type == BT_COMPLEX)
+ && ts->type == BT_INTEGER)
+ || (from_ts.type == BT_COMPLEX && ts->type == BT_REAL))
+ gfc_warning_now ("Likely loss of digits in conversion from"
+ "%s to %s at %L", gfc_typename (&from_ts),
+ gfc_typename (ts), &expr->where);
+ }
/* Insert a pre-resolved function call to the right function. */
old_where = expr->where;
gfc_convert_chartype (gfc_expr *expr, gfc_typespec *ts)
{
gfc_intrinsic_sym *sym;
- gfc_typespec from_ts;
locus old_where;
gfc_expr *new_expr;
int rank;
mpz_t *shape;
gcc_assert (expr->ts.type == BT_CHARACTER && ts->type == BT_CHARACTER);
- from_ts = expr->ts; /* expr->ts gets clobbered */
sym = find_char_conv (&expr->ts, ts);
gcc_assert (sym);