/* Intrinsic function resolution.
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
#include "gfortran.h"
#include "intrinsic.h"
#include "constructor.h"
+#include "arith.h"
/* Given printf-like arguments, return a stable version of the result string.
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 **********************/
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);
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_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));
}
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)
{
- const char *name;
-
- f->ts = array->ts;
-
- if (mask)
- {
- if (mask->rank == 0)
- name = "ssum";
- else
- name = "msum";
-
- resolve_mask_arg (mask);
- }
- else
- name = "sum";
-
- 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);
+ resolve_transformational ("sum", f, array, dim, mask);
}
gfc_resolve_image_index (gfc_expr *f, gfc_expr *array ATTRIBUTE_UNUSED,
gfc_expr *sub ATTRIBUTE_UNUSED)
{
- static char this_image[] = "__image_index";
+ static char image_index[] = "__image_index";
+ f->ts.type = BT_INTEGER;
f->ts.kind = gfc_default_integer_kind;
- f->value.function.name = this_image;
+ f->value.function.name = image_index;
}
void
gfc_resolve_this_image (gfc_expr *f, gfc_expr *array, gfc_expr *dim)
{
- resolve_bound (f, array, dim, NULL, "__this_image", true);
+ 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_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
