/* 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, 2010
+ 2009, 2010, 2011
Free Software Foundation, Inc.
Contributed by Andy Vaught & Katherine Holcomb
enum klass
{ CLASS_IMPURE = 0, CLASS_PURE, CLASS_ELEMENTAL,
- CLASS_INQUIRY, CLASS_TRANSFORMATIONAL };
+ CLASS_INQUIRY, CLASS_TRANSFORMATIONAL, CLASS_ATOMIC };
#define ACTUAL_NO 0
#define ACTUAL_YES 1
strcat (buf, name);
next_sym->lib_name = gfc_get_string (buf);
- /* There are no IMPURE ELEMENTAL intrinsics, thus the ELEMENTAL class
- also implies PURE. Additionally, there's the PURE class itself. */
- next_sym->pure = (cl == CLASS_ELEMENTAL || cl == CLASS_PURE);
-
+ next_sym->pure = (cl != CLASS_IMPURE);
next_sym->elemental = (cl == CLASS_ELEMENTAL);
next_sym->inquiry = (cl == CLASS_INQUIRY);
next_sym->transformational = (cl == CLASS_TRANSFORMATIONAL);
}
+gfc_intrinsic_sym *
+gfc_intrinsic_function_by_id (gfc_isym_id id)
+{
+ gfc_intrinsic_sym *start = functions;
+ int n = nfunc;
+
+ while (true)
+ {
+ gcc_assert (n > 0);
+ if (id == start->id)
+ return start;
+
+ start++;
+ n--;
+ }
+}
+
+
/* Given a name, find a function in the intrinsic function table.
Returns NULL if not found. */
gfc_intrinsic_sym *sym;
sym = find_sym (functions, nfunc, name);
- if (!sym)
+ if (!sym || sym->from_module)
sym = find_sym (conversion, nconv, name);
- return sym;
+ return (!sym || sym->from_module) ? NULL : sym;
}
gfc_intrinsic_sym *
gfc_find_subroutine (const char *name)
{
- return find_sym (subroutines, nsub, name);
+ gfc_intrinsic_sym *sym;
+ sym = find_sym (subroutines, nsub, name);
+ return (!sym || sym->from_module) ? NULL : sym;
}
gfc_intrinsic_sym *sym;
sym = gfc_find_function (name);
- return (sym == NULL) ? 0 : sym->generic;
+ return (!sym || sym->from_module) ? 0 : sym->generic;
}
gfc_intrinsic_sym *sym;
sym = gfc_find_function (name);
- return (sym == NULL) ? 0 : sym->specific;
+ return (!sym || sym->from_module) ? 0 : sym->specific;
}
next_sym[-1].noreturn = 1;
}
+
+/* Mark current intrinsic as module intrinsic. */
+static void
+make_from_module (void)
+{
+ if (sizing == SZ_NOTHING)
+ next_sym[-1].from_module = 1;
+}
+
/* Set the attr.value of the current procedure. */
static void
make_generic ("dprod", GFC_ISYM_DPROD, GFC_STD_F77);
- add_sym_1 ("dreal", GFC_ISYM_REAL, CLASS_ELEMENTAL, ACTUAL_NO, BT_REAL, dd, GFC_STD_GNU,
- NULL, NULL, NULL,
+ add_sym_1 ("dreal", GFC_ISYM_REAL, CLASS_ELEMENTAL, ACTUAL_NO,
+ BT_REAL, dd, GFC_STD_GNU, NULL, gfc_simplify_dreal, NULL,
a, BT_COMPLEX, dd, REQUIRED);
make_generic ("dreal", GFC_ISYM_REAL, GFC_STD_GNU);
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, gfc_resolve_extends_type_of,
+ gfc_check_same_type_as, gfc_simplify_extends_type_of,
+ gfc_resolve_extends_type_of,
a, BT_UNKNOWN, 0, REQUIRED,
mo, BT_UNKNOWN, 0, REQUIRED);
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,
+ add_sym_0 ("num_images", GFC_ISYM_NUM_IMAGES, 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,
make_generic ("range", GFC_ISYM_RANGE, GFC_STD_F95);
+ add_sym_1 ("rank", GFC_ISYM_RANK, CLASS_INQUIRY, ACTUAL_NO, BT_INTEGER, di,
+ GFC_STD_F2008_TS, gfc_check_rank, gfc_simplify_rank, NULL,
+ a, BT_REAL, dr, REQUIRED);
+ make_generic ("rank", GFC_ISYM_RANK, GFC_STD_F2008_TS);
+
add_sym_2 ("real", GFC_ISYM_REAL, CLASS_ELEMENTAL, ACTUAL_NO, BT_REAL, dr, GFC_STD_F77,
gfc_check_real, gfc_simplify_real, gfc_resolve_real,
a, BT_UNKNOWN, dr, REQUIRED, kind, BT_INTEGER, di, OPTIONAL);
add_sym_2 ("same_type_as", GFC_ISYM_SAME_TYPE_AS, CLASS_INQUIRY, ACTUAL_NO,
BT_LOGICAL, dl, GFC_STD_F2003,
- gfc_check_same_type_as, NULL, NULL,
+ gfc_check_same_type_as, gfc_simplify_same_type_as, NULL,
a, BT_UNKNOWN, 0, REQUIRED,
b, BT_UNKNOWN, 0, REQUIRED);
make_generic ("set_exponent", GFC_ISYM_SET_EXPONENT, GFC_STD_F95);
- add_sym_1 ("shape", GFC_ISYM_SHAPE, CLASS_INQUIRY, ACTUAL_NO, BT_INTEGER, di, GFC_STD_F95,
+ add_sym_2 ("shape", GFC_ISYM_SHAPE, CLASS_INQUIRY, ACTUAL_NO, BT_INTEGER, di, GFC_STD_F95,
gfc_check_shape, gfc_simplify_shape, gfc_resolve_shape,
- src, BT_REAL, dr, REQUIRED);
+ src, BT_REAL, dr, REQUIRED,
+ kind, BT_INTEGER, di, OPTIONAL);
make_generic ("shape", GFC_ISYM_SHAPE, GFC_STD_F95);
add_sym_2 ("signal", GFC_ISYM_SIGNAL, CLASS_IMPURE, ACTUAL_NO, BT_INTEGER,
di, GFC_STD_GNU, gfc_check_signal, NULL, gfc_resolve_signal,
- num, BT_INTEGER, di, REQUIRED, han, BT_UNKNOWN, 0, REQUIRED);
+ num, BT_INTEGER, di, REQUIRED, han, BT_VOID, 0, REQUIRED);
make_generic ("signal", GFC_ISYM_SIGNAL, GFC_STD_GNU);
x, BT_UNKNOWN, 0, REQUIRED);
make_generic ("sizeof", GFC_ISYM_SIZEOF, GFC_STD_GNU);
-
+
+ /* C_SIZEOF is part of ISO_C_BINDING. */
add_sym_1 ("c_sizeof", GFC_ISYM_C_SIZEOF, CLASS_INQUIRY, ACTUAL_NO,
BT_INTEGER, ii, GFC_STD_F2008, gfc_check_c_sizeof, NULL, NULL,
x, BT_UNKNOWN, 0, REQUIRED);
+ make_from_module();
+
+ /* COMPILER_OPTIONS and COMPILER_VERSION are part of ISO_FORTRAN_ENV. */
+ add_sym_0 ("compiler_options", GFC_ISYM_COMPILER_OPTIONS, CLASS_INQUIRY,
+ ACTUAL_NO, BT_CHARACTER, dc, GFC_STD_F2008,
+ NULL, gfc_simplify_compiler_options, NULL);
+ make_from_module();
+
+ add_sym_0 ("compiler_version", GFC_ISYM_COMPILER_VERSION, CLASS_INQUIRY,
+ ACTUAL_NO, BT_CHARACTER, dc, GFC_STD_F2008,
+ NULL, gfc_simplify_compiler_version, NULL);
+ make_from_module();
add_sym_1 ("spacing", GFC_ISYM_SPACING, CLASS_ELEMENTAL, ACTUAL_NO, BT_REAL, dr, GFC_STD_F95,
gfc_check_x, gfc_simplify_spacing, gfc_resolve_spacing,
make_noreturn();
+ add_sym_2s ("atomic_define", GFC_ISYM_ATOMIC_DEF, CLASS_ATOMIC,
+ BT_UNKNOWN, 0, GFC_STD_F2008,
+ gfc_check_atomic_def, NULL, gfc_resolve_atomic_def,
+ "atom", BT_INTEGER, di, REQUIRED, INTENT_OUT,
+ "value", BT_INTEGER, di, REQUIRED, INTENT_IN);
+
+ add_sym_2s ("atomic_ref", GFC_ISYM_ATOMIC_REF, CLASS_ATOMIC,
+ BT_UNKNOWN, 0, GFC_STD_F2008,
+ gfc_check_atomic_ref, NULL, gfc_resolve_atomic_ref,
+ "value", BT_INTEGER, di, REQUIRED, INTENT_OUT,
+ "atom", BT_INTEGER, di, REQUIRED, INTENT_IN);
+
add_sym_1s ("cpu_time", GFC_ISYM_CPU_TIME, CLASS_IMPURE, BT_UNKNOWN, 0,
GFC_STD_F95, gfc_check_cpu_time, NULL, gfc_resolve_cpu_time,
tm, BT_REAL, dr, REQUIRED, INTENT_OUT);
void
gfc_intrinsic_init_1 (void)
{
- int i;
-
nargs = nfunc = nsub = nconv = 0;
/* Create a namespace to hold the resolved intrinsic symbols. */
/* Character conversion intrinsics need to be treated separately. */
add_char_conversions ();
-
- /* Set the pure flag. All intrinsic functions are pure, and
- intrinsic subroutines are pure if they are elemental. */
-
- for (i = 0; i < nfunc; i++)
- functions[i].pure = 1;
-
- for (i = 0; i < nsub; i++)
- subroutines[i].pure = subroutines[i].elemental;
}
void
gfc_intrinsic_done_1 (void)
{
- gfc_free (functions);
- gfc_free (conversion);
- gfc_free (char_conversions);
+ free (functions);
+ free (conversion);
+ free (char_conversions);
gfc_free_namespace (gfc_intrinsic_namespace);
}
gfc_typename (&actual->expr->ts));
return FAILURE;
}
+
+ /* If the formal argument is INTENT([IN]OUT), check for definability. */
+ if (formal->intent == INTENT_INOUT || formal->intent == INTENT_OUT)
+ {
+ const char* context = (error_flag
+ ? _("actual argument to INTENT = OUT/INOUT")
+ : NULL);
+
+ /* No pointer arguments for intrinsics. */
+ if (gfc_check_vardef_context (actual->expr, false, false, context)
+ == FAILURE)
+ return FAILURE;
+ }
}
return SUCCESS;
symstd_msg = "new in Fortran 2008";
break;
+ case GFC_STD_F2008_TS:
+ symstd_msg = "new in TS 29113";
+ break;
+
case GFC_STD_GNU:
symstd_msg = "a GNU Fortran extension";
break;
name = expr->symtree->n.sym->name;
- isym = specific = gfc_find_function (name);
+ if (expr->symtree->n.sym->intmod_sym_id)
+ {
+ int id = expr->symtree->n.sym->intmod_sym_id;
+ isym = specific = gfc_intrinsic_function_by_id ((gfc_isym_id) id);
+ }
+ else
+ isym = specific = gfc_find_function (name);
+
if (isym == NULL)
{
if (!error_flag)
c->resolved_sym->attr.elemental = isym->elemental;
}
- if (gfc_pure (NULL) && !isym->elemental)
+ if (gfc_pure (NULL) && !isym->pure)
{
gfc_error ("Subroutine call to intrinsic '%s' at %L is not PURE", name,
&c->loc);
gfc_warning_now ("Conversion from %s to %s at %L",
gfc_typename (&from_ts), gfc_typename (ts),
&expr->where);
- else if (gfc_option.warn_conversion
+ else if (gfc_option.gfc_warn_conversion
&& from_ts.kind > ts->kind)
gfc_warning_now ("Possible change of value in conversion "
"from %s to %s at %L", gfc_typename (&from_ts),
/* Conversion from REAL/COMPLEX to INTEGER or COMPLEX to REAL
usually comes with a loss of information, regardless of kinds. */
if (gfc_option.warn_conversion_extra
- || gfc_option.warn_conversion)
+ || gfc_option.gfc_warn_conversion)
gfc_warning_now ("Possible change of value in conversion "
"from %s to %s at %L", gfc_typename (&from_ts),
gfc_typename (ts), &expr->where);
{
/* If HOLLERITH is involved, all bets are off. */
if (gfc_option.warn_conversion_extra
- || gfc_option.warn_conversion)
+ || gfc_option.gfc_warn_conversion)
gfc_warning_now ("Conversion from %s to %s at %L",
gfc_typename (&from_ts), gfc_typename (ts),
&expr->where);
*expr = *new_expr;
- gfc_free (new_expr);
+ free (new_expr);
expr->ts = *ts;
if (gfc_is_constant_expr (expr->value.function.actual->expr)
*expr = *new_expr;
- gfc_free (new_expr);
+ free (new_expr);
expr->ts = *ts;
if (gfc_is_constant_expr (expr->value.function.actual->expr)
OSDN Git Service
