/* Intrinsic function resolution.
- Copyright (C) 2000, 2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008
+ 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)
+{
+ 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], 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_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, false);
+ /* 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, false);
+ /* 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;
+ /* 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");
+}
- 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");
}
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;
}
{
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_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");
+}
+
+
+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");
+}
- 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");
}
gfc_resolve_alarm_sub (gfc_code *c)
{
const char *name;
- gfc_expr *seconds, *handler, *status;
+ gfc_expr *seconds, *handler;
gfc_typespec ts;
gfc_clear_ts (&ts);
seconds = c->ext.actual->expr;
handler = c->ext.actual->next->expr;
- status = c->ext.actual->next->next->expr;
ts.type = BT_INTEGER;
ts.kind = gfc_c_int_kind;
gfc_expr *unit;
gfc_expr *offset;
gfc_expr *whence;
- gfc_expr *status;
gfc_typespec ts;
gfc_clear_ts (&ts);
unit = c->ext.actual->expr;
offset = c->ext.actual->next->expr;
whence = c->ext.actual->next->next->expr;
- status = c->ext.actual->next->next->next->expr;
if (unit->ts.kind != gfc_c_int_kind)
{