/* Intrinsic function resolution.
- 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
#include "tree.h"
#include "gfortran.h"
#include "intrinsic.h"
+#include "constructor.h"
/* Given printf-like arguments, return a stable version of the result string.
if (source->expr_type == EXPR_CONSTANT)
{
- source->ts.u.cl->length = gfc_int_expr (source->value.character.length);
+ source->ts.u.cl->length
+ = gfc_get_int_expr (gfc_default_integer_kind, NULL,
+ source->value.character.length);
source->rank = 0;
}
else if (source->expr_type == EXPR_ARRAY)
- source->ts.u.cl->length =
- gfc_int_expr (source->value.constructor->expr->value.character.length);
+ {
+ gfc_constructor *c = gfc_constructor_first (source->value.constructor);
+ source->ts.u.cl->length
+ = gfc_get_int_expr (gfc_default_integer_kind, NULL,
+ c->expr->value.character.length);
+ }
}
/* Helper function for resolving the "mask" argument. */
{
ts.type = BT_LOGICAL;
ts.kind = 1;
- gfc_convert_type (mask, &ts, 2);
+ gfc_convert_type_warn (mask, &ts, 2, 0);
}
}
}
+
+static void
+resolve_bound (gfc_expr *f, gfc_expr *array, gfc_expr *dim, gfc_expr *kind,
+ const char *name, bool coarray)
+{
+ f->ts.type = BT_INTEGER;
+ if (kind)
+ f->ts.kind = mpz_get_si (kind->value.integer);
+ else
+ f->ts.kind = gfc_default_integer_kind;
+
+ if (dim == NULL)
+ {
+ f->rank = 1;
+ f->shape = gfc_get_shape (1);
+ mpz_init_set_ui (f->shape[0], coarray ? gfc_get_corank (array)
+ : array->rank);
+ }
+
+ f->value.function.name = xstrdup (name);
+}
+
/********************** Resolution functions **********************/
f->ts.kind = (kind == NULL)
? gfc_default_character_kind : mpz_get_si (kind->value.integer);
f->ts.u.cl = gfc_new_charlen (gfc_current_ns, NULL);
- f->ts.u.cl->length = gfc_int_expr (1);
+ f->ts.u.cl->length = gfc_get_int_expr (gfc_default_integer_kind, NULL, 1);
f->value.function.name = gfc_get_string (name, f->ts.kind,
gfc_type_letter (x->ts.type),
void
+gfc_resolve_bessel_n2 (gfc_expr *f, gfc_expr *n1, gfc_expr *n2, gfc_expr *x)
+{
+ gfc_typespec ts;
+ gfc_clear_ts (&ts);
+
+ f->ts = x->ts;
+ f->rank = 1;
+ if (n1->expr_type == EXPR_CONSTANT && n2->expr_type == EXPR_CONSTANT)
+ {
+ f->shape = gfc_get_shape (1);
+ mpz_init (f->shape[0]);
+ mpz_sub (f->shape[0], n2->value.integer, n1->value.integer);
+ mpz_add_ui (f->shape[0], f->shape[0], 1);
+ }
+
+ if (n1->ts.kind != gfc_c_int_kind)
+ {
+ ts.type = BT_INTEGER;
+ ts.kind = gfc_c_int_kind;
+ gfc_convert_type (n1, &ts, 2);
+ }
+
+ if (n2->ts.kind != gfc_c_int_kind)
+ {
+ ts.type = BT_INTEGER;
+ ts.kind = gfc_c_int_kind;
+ gfc_convert_type (n2, &ts, 2);
+ }
+
+ if (f->value.function.isym->id == GFC_ISYM_JN2)
+ f->value.function.name = gfc_get_string (PREFIX ("bessel_jn_r%d"),
+ f->ts.kind);
+ else
+ f->value.function.name = gfc_get_string (PREFIX ("bessel_yn_r%d"),
+ f->ts.kind);
+}
+
+
+void
gfc_resolve_btest (gfc_expr *f, gfc_expr *i, gfc_expr *pos)
{
f->ts.type = BT_LOGICAL;
void
gfc_resolve_dcmplx (gfc_expr *f, gfc_expr *x, gfc_expr *y)
{
- gfc_resolve_cmplx (f, x, y, gfc_int_expr (gfc_default_double_kind));
+ gfc_resolve_cmplx (f, x, y, gfc_get_int_expr (gfc_default_integer_kind, NULL,
+ gfc_default_double_kind));
}
temp.value.op.op = INTRINSIC_NONE;
temp.value.op.op1 = a;
temp.value.op.op2 = b;
- gfc_type_convert_binary (&temp);
+ gfc_type_convert_binary (&temp, 1);
f->ts = temp.ts;
f->value.function.name
= gfc_get_string (PREFIX ("dot_product_%c%d"),
}
+/* Resolve the EXTENDS_TYPE_OF intrinsic function. */
+
+void
+gfc_resolve_extends_type_of (gfc_expr *f, gfc_expr *a, gfc_expr *mo)
+{
+ gfc_symbol *vtab;
+ gfc_symtree *st;
+
+ /* Prevent double resolution. */
+ if (f->ts.type == BT_LOGICAL)
+ return;
+
+ /* Replace the first argument with the corresponding vtab. */
+ if (a->ts.type == BT_CLASS)
+ gfc_add_component_ref (a, "$vptr");
+ else if (a->ts.type == BT_DERIVED)
+ {
+ vtab = gfc_find_derived_vtab (a->ts.u.derived);
+ /* Clear the old expr. */
+ gfc_free_ref_list (a->ref);
+ memset (a, '\0', sizeof (gfc_expr));
+ /* Construct a new one. */
+ a->expr_type = EXPR_VARIABLE;
+ st = gfc_find_symtree (vtab->ns->sym_root, vtab->name);
+ a->symtree = st;
+ a->ts = vtab->ts;
+ }
+
+ /* Replace the second argument with the corresponding vtab. */
+ if (mo->ts.type == BT_CLASS)
+ gfc_add_component_ref (mo, "$vptr");
+ else if (mo->ts.type == BT_DERIVED)
+ {
+ vtab = gfc_find_derived_vtab (mo->ts.u.derived);
+ /* Clear the old expr. */
+ gfc_free_ref_list (mo->ref);
+ memset (mo, '\0', sizeof (gfc_expr));
+ /* Construct a new one. */
+ mo->expr_type = EXPR_VARIABLE;
+ st = gfc_find_symtree (vtab->ns->sym_root, vtab->name);
+ mo->symtree = st;
+ mo->ts = vtab->ts;
+ }
+
+ f->ts.type = BT_LOGICAL;
+ f->ts.kind = 4;
+
+ f->value.function.isym->formal->ts = a->ts;
+ f->value.function.isym->formal->next->ts = mo->ts;
+
+ /* Call library function. */
+ f->value.function.name = gfc_get_string (PREFIX ("is_extension_of"));
+}
+
+
void
gfc_resolve_fdate (gfc_expr *f)
{
{
f->ts = x->ts;
f->value.function.name
- = gfc_get_string ("__gamma_%d", x->ts.kind);
+ = gfc_get_string ("__tgamma_%d", x->ts.kind);
}
void
gfc_resolve_lbound (gfc_expr *f, gfc_expr *array, gfc_expr *dim, gfc_expr *kind)
{
- static char lbound[] = "__lbound";
-
- f->ts.type = BT_INTEGER;
- if (kind)
- f->ts.kind = mpz_get_si (kind->value.integer);
- else
- f->ts.kind = gfc_default_integer_kind;
+ resolve_bound (f, array, dim, kind, "__lbound", false);
+}
- if (dim == NULL)
- {
- f->rank = 1;
- f->shape = gfc_get_shape (1);
- mpz_init_set_ui (f->shape[0], array->rank);
- }
- f->value.function.name = lbound;
+void
+gfc_resolve_lcobound (gfc_expr *f, gfc_expr *array, gfc_expr *dim, gfc_expr *kind)
+{
+ resolve_bound (f, array, dim, kind, "__lcobound", true);
}
temp.value.op.op = INTRINSIC_NONE;
temp.value.op.op1 = a;
temp.value.op.op2 = b;
- gfc_type_convert_binary (&temp);
+ gfc_type_convert_binary (&temp, 1);
f->ts = temp.ts;
}
void
+gfc_resolve_norm2 (gfc_expr *f, gfc_expr *array, gfc_expr *dim)
+{
+ f->ts = array->ts;
+
+ if (dim != NULL)
+ {
+ f->rank = array->rank - 1;
+ f->shape = gfc_copy_shape_excluding (array->shape, array->rank, dim);
+ gfc_resolve_dim_arg (dim);
+ }
+
+ f->value.function.name
+ = gfc_get_string (PREFIX ("norm2_r%d"), array->ts.kind);
+}
+
+
+void
gfc_resolve_not (gfc_expr *f, gfc_expr *i)
{
f->ts = i->ts;
void
+gfc_resolve_parity (gfc_expr *f, gfc_expr *array, gfc_expr *dim)
+{
+ f->ts = array->ts;
+
+ if (dim != NULL)
+ {
+ f->rank = array->rank - 1;
+ f->shape = gfc_copy_shape_excluding (array->shape, array->rank, dim);
+ gfc_resolve_dim_arg (dim);
+ }
+
+ resolve_mask_arg (array);
+
+ f->value.function.name
+ = gfc_get_string (PREFIX ("parity_l%d"), array->ts.kind);
+}
+
+
+void
gfc_resolve_product (gfc_expr *f, gfc_expr *array, gfc_expr *dim,
gfc_expr *mask)
{
{
gfc_constructor *c;
f->shape = gfc_get_shape (f->rank);
- c = shape->value.constructor;
+ c = gfc_constructor_first (shape->value.constructor);
for (i = 0; i < f->rank; i++)
{
mpz_init_set (f->shape[i], c->expr->value.integer);
- c = c->next;
+ c = gfc_constructor_next (c);
}
}
void
+gfc_resolve_storage_size (gfc_expr *f, gfc_expr *a ATTRIBUTE_UNUSED,
+ gfc_expr *kind)
+{
+ f->ts.type = BT_INTEGER;
+ if (kind)
+ f->ts.kind = mpz_get_si (kind->value.integer);
+ else
+ f->ts.kind = gfc_default_integer_kind;
+}
+
+
+void
gfc_resolve_sum (gfc_expr *f, gfc_expr *array, gfc_expr *dim, gfc_expr *mask)
{
const char *name;
void
+gfc_resolve_image_index (gfc_expr *f, gfc_expr *array ATTRIBUTE_UNUSED,
+ gfc_expr *sub ATTRIBUTE_UNUSED)
+{
+ static char this_image[] = "__image_index";
+ f->ts.kind = gfc_default_integer_kind;
+ f->value.function.name = this_image;
+}
+
+
+void
+gfc_resolve_this_image (gfc_expr *f, gfc_expr *array, gfc_expr *dim)
+{
+ resolve_bound (f, array, dim, NULL, "__this_image", true);
+}
+
+
+void
gfc_resolve_time (gfc_expr *f)
{
f->ts.type = BT_INTEGER;
{
int len;
if (mold->expr_type == EXPR_CONSTANT)
- mold->ts.u.cl->length = gfc_int_expr (mold->value.character.length);
+ {
+ len = mold->value.character.length;
+ mold->ts.u.cl->length = gfc_get_int_expr (gfc_default_integer_kind,
+ NULL, len);
+ }
else
{
- len = mold->value.constructor->expr->value.character.length;
- mold->ts.u.cl->length = gfc_int_expr (len);
+ gfc_constructor *c = gfc_constructor_first (mold->value.constructor);
+ len = c->expr->value.character.length;
+ mold->ts.u.cl->length = gfc_get_int_expr (gfc_default_integer_kind,
+ NULL, len);
}
}
void
gfc_resolve_ubound (gfc_expr *f, gfc_expr *array, gfc_expr *dim, gfc_expr *kind)
{
- static char ubound[] = "__ubound";
-
- f->ts.type = BT_INTEGER;
- if (kind)
- f->ts.kind = mpz_get_si (kind->value.integer);
- else
- f->ts.kind = gfc_default_integer_kind;
+ resolve_bound (f, array, dim, kind, "__ubound", false);
+}
- if (dim == NULL)
- {
- f->rank = 1;
- f->shape = gfc_get_shape (1);
- mpz_init_set_ui (f->shape[0], array->rank);
- }
- f->value.function.name = ubound;
+void
+gfc_resolve_ucobound (gfc_expr *f, gfc_expr *array, gfc_expr *dim, gfc_expr *kind)
+{
+ resolve_bound (f, array, dim, kind, "__ucobound", true);
}
}
+/* Resolve the EXECUTE_COMMAND_LINE intrinsic subroutine. */
+void
+gfc_resolve_execute_command_line (gfc_code *c)
+{
+ const char *name;
+ name = gfc_get_string (PREFIX ("execute_command_line_i%d"),
+ gfc_default_integer_kind);
+ c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
+}
+
+
/* Resolve the EXIT intrinsic subroutine. */
void
OSDN Git Service
