/* 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, 2011
Free Software Foundation, Inc.
Contributed by Andy Vaught & Katherine Holcomb
#include "tree.h"
#include "gfortran.h"
#include "intrinsic.h"
+#include "constructor.h"
+#include "arith.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. */
}
}
+
+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);
+}
+
+
+static void
+resolve_transformational (const char *name, gfc_expr *f, gfc_expr *array,
+ gfc_expr *dim, gfc_expr *mask)
+{
+ const char *prefix;
+
+ f->ts = array->ts;
+
+ if (mask)
+ {
+ if (mask->rank == 0)
+ prefix = "s";
+ else
+ prefix = "m";
+
+ resolve_mask_arg (mask);
+ }
+ else
+ prefix = "";
+
+ 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 ("%s%s_%c%d"), prefix, name,
+ gfc_type_letter (array->ts.type), array->ts.kind);
+}
+
+
/********************** 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));
}
void
+gfc_resolve_dshift (gfc_expr *f, gfc_expr *i, gfc_expr *j ATTRIBUTE_UNUSED,
+ gfc_expr *shift ATTRIBUTE_UNUSED)
+{
+ f->ts = i->ts;
+ if (f->value.function.isym->id == GFC_ISYM_DSHIFTL)
+ f->value.function.name = gfc_get_string ("dshiftl_i%d", f->ts.kind);
+ else if (f->value.function.isym->id == GFC_ISYM_DSHIFTR)
+ f->value.function.name = gfc_get_string ("dshiftr_i%d", f->ts.kind);
+ else
+ gcc_unreachable ();
+}
+
+
+void
gfc_resolve_eoshift (gfc_expr *f, gfc_expr *array, gfc_expr *shift,
gfc_expr *boundary, gfc_expr *dim)
{
/* Replace the first argument with the corresponding vtab. */
if (a->ts.type == BT_CLASS)
- gfc_add_component_ref (a, "$vptr");
+ gfc_add_vptr_component (a);
else if (a->ts.type == BT_DERIVED)
{
vtab = gfc_find_derived_vtab (a->ts.u.derived);
/* Replace the second argument with the corresponding vtab. */
if (mo->ts.type == BT_CLASS)
- gfc_add_component_ref (mo, "$vptr");
+ gfc_add_vptr_component (mo);
else if (mo->ts.type == BT_DERIVED)
{
vtab = gfc_find_derived_vtab (mo->ts.u.derived);
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"));
}
{
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_iall (gfc_expr *f, gfc_expr *array, gfc_expr *dim, gfc_expr *mask)
+{
+ resolve_transformational ("iall", f, array, dim, mask);
+}
+
+
+void
gfc_resolve_iand (gfc_expr *f, gfc_expr *i, gfc_expr *j)
{
/* If the kind of i and j are different, then g77 cross-promoted the
void
+gfc_resolve_iany (gfc_expr *f, gfc_expr *array, gfc_expr *dim, gfc_expr *mask)
+{
+ resolve_transformational ("iany", f, array, dim, mask);
+}
+
+
+void
gfc_resolve_ibclr (gfc_expr *f, gfc_expr *i, gfc_expr *pos ATTRIBUTE_UNUSED)
{
f->ts = i->ts;
void
+gfc_resolve_iparity (gfc_expr *f, gfc_expr *array, gfc_expr *dim, gfc_expr *mask)
+{
+ resolve_transformational ("iparity", f, array, dim, mask);
+}
+
+
+void
gfc_resolve_isatty (gfc_expr *f, gfc_expr *u)
{
gfc_typespec ts;
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);
}
void
+gfc_resolve_mask (gfc_expr *f, gfc_expr *i ATTRIBUTE_UNUSED,
+ gfc_expr *kind)
+{
+ f->ts.type = BT_INTEGER;
+ f->ts.kind = kind ? mpz_get_si (kind->value.integer)
+ : gfc_default_integer_kind;
+
+ if (f->value.function.isym->id == GFC_ISYM_MASKL)
+ f->value.function.name = gfc_get_string ("__maskl_i%d", f->ts.kind);
+ else
+ f->value.function.name = gfc_get_string ("__maskr_i%d", f->ts.kind);
+}
+
+
+void
gfc_resolve_merge (gfc_expr *f, gfc_expr *tsource,
gfc_expr *fsource ATTRIBUTE_UNUSED,
gfc_expr *mask ATTRIBUTE_UNUSED)
void
+gfc_resolve_merge_bits (gfc_expr *f, gfc_expr *i,
+ gfc_expr *j ATTRIBUTE_UNUSED,
+ gfc_expr *mask ATTRIBUTE_UNUSED)
+{
+ f->ts = i->ts;
+ f->value.function.name = gfc_get_string ("__merge_bits_i%d", i->ts.kind);
+}
+
+
+void
gfc_resolve_min (gfc_expr *f, gfc_actual_arglist *args)
{
gfc_resolve_minmax ("__min_%c%d", f, args);
void
+gfc_resolve_norm2 (gfc_expr *f, gfc_expr *array, gfc_expr *dim)
+{
+ resolve_transformational ("norm2", f, array, dim, NULL);
+}
+
+
+void
gfc_resolve_not (gfc_expr *f, gfc_expr *i)
{
f->ts = i->ts;
void
-gfc_resolve_product (gfc_expr *f, gfc_expr *array, gfc_expr *dim,
- gfc_expr *mask)
+gfc_resolve_parity (gfc_expr *f, gfc_expr *array, gfc_expr *dim)
{
- const char *name;
-
- 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);
- }
-
- if (mask)
- {
- if (mask->rank == 0)
- name = "sproduct";
- else
- name = "mproduct";
+ resolve_transformational ("parity", f, array, dim, NULL);
+}
- resolve_mask_arg (mask);
- }
- else
- name = "product";
- f->value.function.name
- = gfc_get_string (PREFIX ("%s_%c%d"), name,
- gfc_type_letter (array->ts.type), array->ts.kind);
+void
+gfc_resolve_product (gfc_expr *f, gfc_expr *array, gfc_expr *dim,
+ gfc_expr *mask)
+{
+ resolve_transformational ("product", f, array, dim, mask);
}
void
gfc_resolve_repeat (gfc_expr *f, gfc_expr *string,
- gfc_expr *ncopies ATTRIBUTE_UNUSED)
+ gfc_expr *ncopies)
{
+ int len;
+ gfc_expr *tmp;
f->ts.type = BT_CHARACTER;
f->ts.kind = string->ts.kind;
f->value.function.name = gfc_get_string ("__repeat_%d", string->ts.kind);
+
+ /* If possible, generate a character length. */
+ if (f->ts.u.cl == NULL)
+ f->ts.u.cl = gfc_new_charlen (gfc_current_ns, NULL);
+
+ tmp = NULL;
+ if (string->expr_type == EXPR_CONSTANT)
+ {
+ len = string->value.character.length;
+ tmp = gfc_get_int_expr (gfc_default_integer_kind, NULL , len);
+ }
+ else if (string->ts.u.cl && string->ts.u.cl->length)
+ {
+ tmp = gfc_copy_expr (string->ts.u.cl->length);
+ }
+
+ if (tmp)
+ f->ts.u.cl->length = gfc_multiply (tmp, gfc_copy_expr (ncopies));
}
{
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_shape (gfc_expr *f, gfc_expr *array)
+gfc_resolve_shape (gfc_expr *f, gfc_expr *array, gfc_expr *kind)
{
f->ts.type = BT_INTEGER;
- f->ts.kind = gfc_default_integer_kind;
+
+ if (kind)
+ f->ts.kind = mpz_get_si (kind->value.integer);
+ else
+ f->ts.kind = gfc_default_integer_kind;
+
f->rank = 1;
f->shape = gfc_get_shape (1);
mpz_init_set_ui (f->shape[0], array->rank);
void
+gfc_resolve_shift (gfc_expr *f, gfc_expr *i, gfc_expr *shift ATTRIBUTE_UNUSED)
+{
+ f->ts = i->ts;
+ if (f->value.function.isym->id == GFC_ISYM_SHIFTA)
+ f->value.function.name = gfc_get_string ("shifta_i%d", f->ts.kind);
+ else if (f->value.function.isym->id == GFC_ISYM_SHIFTL)
+ f->value.function.name = gfc_get_string ("shiftl_i%d", f->ts.kind);
+ else if (f->value.function.isym->id == GFC_ISYM_SHIFTR)
+ f->value.function.name = gfc_get_string ("shiftr_i%d", f->ts.kind);
+ else
+ gcc_unreachable ();
+}
+
+
+void
gfc_resolve_sign (gfc_expr *f, gfc_expr *a, gfc_expr *b ATTRIBUTE_UNUSED)
{
f->ts = a->ts;
void
-gfc_resolve_sum (gfc_expr *f, gfc_expr *array, gfc_expr *dim, gfc_expr *mask)
+gfc_resolve_storage_size (gfc_expr *f, gfc_expr *a ATTRIBUTE_UNUSED,
+ gfc_expr *kind)
{
- const char *name;
-
- f->ts = array->ts;
-
- if (mask)
- {
- if (mask->rank == 0)
- name = "ssum";
- else
- name = "msum";
-
- resolve_mask_arg (mask);
- }
+ f->ts.type = BT_INTEGER;
+ if (kind)
+ f->ts.kind = mpz_get_si (kind->value.integer);
else
- name = "sum";
+ f->ts.kind = gfc_default_integer_kind;
+}
- 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 ("%s_%c%d"), name,
- gfc_type_letter (array->ts.type), array->ts.kind);
+void
+gfc_resolve_sum (gfc_expr *f, gfc_expr *array, gfc_expr *dim, gfc_expr *mask)
+{
+ resolve_transformational ("sum", f, array, dim, mask);
}
void
+gfc_resolve_image_index (gfc_expr *f, gfc_expr *array ATTRIBUTE_UNUSED,
+ gfc_expr *sub ATTRIBUTE_UNUSED)
+{
+ static char image_index[] = "__image_index";
+ f->ts.type = BT_INTEGER;
+ f->ts.kind = gfc_default_integer_kind;
+ f->value.function.name = image_index;
+}
+
+
+void
+gfc_resolve_this_image (gfc_expr *f, gfc_expr *array, gfc_expr *dim)
+{
+ static char this_image[] = "__this_image";
+ if (array)
+ resolve_bound (f, array, dim, NULL, "__this_image", true);
+ else
+ {
+ f->ts.type = BT_INTEGER;
+ f->ts.kind = gfc_default_integer_kind;
+ f->value.function.name = 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", 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);
}
void
+gfc_resolve_atomic_def (gfc_code *c)
+{
+ const char *name = "atomic_define";
+ c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
+}
+
+
+void
+gfc_resolve_atomic_ref (gfc_code *c)
+{
+ const char *name = "atomic_ref";
+ c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
+}
+
+
+void
gfc_resolve_mvbits (gfc_code *c)
{
static const sym_intent INTENTS[] = {INTENT_IN, INTENT_IN, INTENT_IN,
}
+/* 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
