static void
check_charlen_present (gfc_expr *source)
{
- if (source->expr_type == EXPR_CONSTANT && source->ts.cl == NULL)
+ if (source->ts.cl == NULL)
{
source->ts.cl = gfc_get_charlen ();
source->ts.cl->next = gfc_current_ns->cl_list;
gfc_current_ns->cl_list = source->ts.cl;
+ }
+
+ if (source->expr_type == EXPR_CONSTANT)
+ {
source->ts.cl->length = gfc_int_expr (source->value.character.length);
source->rank = 0;
}
+ else if (source->expr_type == EXPR_ARRAY)
+ {
+ source->ts.cl->length =
+ gfc_int_expr (source->value.constructor->expr->value.character.length);
+ source->rank = 1;
+ }
}
/* Helper function for resolving the "mask" argument. */
static void
resolve_mask_arg (gfc_expr *mask)
{
- int newkind;
-
- /* The mask can be kind 4 or 8 for the array case.
- For the scalar case, coerce it to kind=4 unconditionally
- (because this is the only kind we have a library function
- for). */
- newkind = 0;
+ gfc_typespec ts;
if (mask->rank == 0)
{
+ /* For the scalar case, coerce the mask to kind=4 unconditionally
+ (because this is the only kind we have a library function
+ for). */
+
if (mask->ts.kind != 4)
- newkind = 4;
+ {
+ ts.type = BT_LOGICAL;
+ ts.kind = 4;
+ gfc_convert_type (mask, &ts, 2);
+ }
}
else
{
- if (mask->ts.kind < 4)
- newkind = gfc_default_logical_kind;
- }
-
- if (newkind)
- {
- gfc_typespec ts;
-
- ts.type = BT_LOGICAL;
- ts.kind = newkind;
- gfc_convert_type (mask, &ts, 2);
+ /* In the library, we access the mask with a GFC_LOGICAL_1
+ argument. No need to waste memory if we are about to create
+ a temporary array. */
+ if (mask->expr_type == EXPR_OP)
+ {
+ ts.type = BT_LOGICAL;
+ ts.kind = 1;
+ gfc_convert_type (mask, &ts, 2);
+ }
}
}
}
-void
-gfc_resolve_achar (gfc_expr *f, gfc_expr *x)
+static void
+gfc_resolve_char_achar (gfc_expr *f, gfc_expr *x, gfc_expr *kind,
+ const char *name)
{
-
f->ts.type = BT_CHARACTER;
- f->ts.kind = gfc_default_character_kind;
+ f->ts.kind = (kind == NULL)
+ ? gfc_default_character_kind : mpz_get_si (kind->value.integer);
f->ts.cl = gfc_get_charlen ();
f->ts.cl->next = gfc_current_ns->cl_list;
gfc_current_ns->cl_list = f->ts.cl;
f->ts.cl->length = gfc_int_expr (1);
- f->value.function.name
- = gfc_get_string ("__achar_%c%d", gfc_type_letter (x->ts.type), x->ts.kind);
+ f->value.function.name = gfc_get_string (name, f->ts.kind,
+ gfc_type_letter (x->ts.type),
+ x->ts.kind);
+}
+
+
+void
+gfc_resolve_achar (gfc_expr *f, gfc_expr *x, gfc_expr *kind)
+{
+ gfc_resolve_char_achar (f, x, kind, "__achar_%d_%c%d");
}
void
gfc_resolve_char (gfc_expr *f, gfc_expr *a, gfc_expr *kind)
{
- f->ts.type = BT_CHARACTER;
- f->ts.kind = (kind == NULL)
- ? gfc_default_character_kind : mpz_get_si (kind->value.integer);
- f->value.function.name
- = gfc_get_string ("__char_%d_%c%d", f->ts.kind,
- gfc_type_letter (a->ts.type), a->ts.kind);
+ gfc_resolve_char_achar (f, a, kind, "__char_%d_%c%d");
}
gfc_resolve_cshift (gfc_expr *f, gfc_expr *array, gfc_expr *shift,
gfc_expr *dim)
{
- int n;
+ int n, m;
+
+ if (array->ts.type == BT_CHARACTER && array->ref)
+ gfc_resolve_substring_charlen (array);
f->ts = array->ts;
f->rank = array->rank;
else
n = 0;
- /* Convert shift to at least gfc_default_integer_kind, so we don't need
- kind=1 and kind=2 versions of the library functions. */
- if (shift->ts.kind < gfc_default_integer_kind)
+ /* If dim kind is greater than default integer we need to use the larger. */
+ m = gfc_default_integer_kind;
+ if (dim != NULL)
+ m = m < dim->ts.kind ? dim->ts.kind : m;
+
+ /* Convert shift to at least m, so we don't need
+ kind=1 and kind=2 versions of the library functions. */
+ if (shift->ts.kind < m)
{
gfc_typespec ts;
ts.type = BT_INTEGER;
- ts.kind = gfc_default_integer_kind;
+ ts.kind = m;
gfc_convert_type_warn (shift, &ts, 2, 0);
}
-
+
if (dim != NULL)
{
- gfc_resolve_dim_arg (dim);
- /* Convert dim to shift's kind, so we don't need so many variations. */
- if (dim->ts.kind != shift->ts.kind)
- gfc_convert_type_warn (dim, &shift->ts, 2, 0);
+ if (dim->expr_type != EXPR_CONSTANT && dim->symtree->n.sym->attr.optional)
+ {
+ /* Mark this for later setting the type in gfc_conv_missing_dummy. */
+ dim->representation.length = shift->ts.kind;
+ }
+ else
+ {
+ gfc_resolve_dim_arg (dim);
+ /* Convert dim to shift's kind to reduce variations. */
+ if (dim->ts.kind != shift->ts.kind)
+ gfc_convert_type_warn (dim, &shift->ts, 2, 0);
+ }
}
+
f->value.function.name
= gfc_get_string (PREFIX ("cshift%d_%d%s"), n, shift->ts.kind,
array->ts.type == BT_CHARACTER ? "_char" : "");
gfc_resolve_eoshift (gfc_expr *f, gfc_expr *array, gfc_expr *shift,
gfc_expr *boundary, gfc_expr *dim)
{
- int n;
+ int n, m;
+
+ if (array->ts.type == BT_CHARACTER && array->ref)
+ gfc_resolve_substring_charlen (array);
f->ts = array->ts;
f->rank = array->rank;
if (boundary && boundary->rank > 0)
n = n | 2;
- /* Convert shift to at least gfc_default_integer_kind, so we don't need
- kind=1 and kind=2 versions of the library functions. */
- if (shift->ts.kind < gfc_default_integer_kind)
+ /* If dim kind is greater than default integer we need to use the larger. */
+ m = gfc_default_integer_kind;
+ if (dim != NULL)
+ m = m < dim->ts.kind ? dim->ts.kind : m;
+
+ /* Convert shift to at least m, so we don't need
+ kind=1 and kind=2 versions of the library functions. */
+ if (shift->ts.kind < m)
{
gfc_typespec ts;
ts.type = BT_INTEGER;
- ts.kind = gfc_default_integer_kind;
+ ts.kind = m;
gfc_convert_type_warn (shift, &ts, 2, 0);
}
-
+
if (dim != NULL)
{
- gfc_resolve_dim_arg (dim);
- /* Convert dim to shift's kind, so we don't need so many variations. */
- if (dim->ts.kind != shift->ts.kind)
- gfc_convert_type_warn (dim, &shift->ts, 2, 0);
+ if (dim->expr_type != EXPR_CONSTANT && dim->symtree->n.sym->attr.optional)
+ {
+ /* Mark this for later setting the type in gfc_conv_missing_dummy. */
+ dim->representation.length = shift->ts.kind;
+ }
+ else
+ {
+ gfc_resolve_dim_arg (dim);
+ /* Convert dim to shift's kind to reduce variations. */
+ if (dim->ts.kind != shift->ts.kind)
+ gfc_convert_type_warn (dim, &shift->ts, 2, 0);
+ }
}
f->value.function.name
void
+gfc_resolve_gamma (gfc_expr *f, gfc_expr *x)
+{
+ f->ts = x->ts;
+ f->value.function.name
+ = gfc_get_string ("__gamma_%d", x->ts.kind);
+}
+
+
+void
gfc_resolve_getcwd (gfc_expr *f, gfc_expr *n ATTRIBUTE_UNUSED)
{
f->ts.type = BT_INTEGER;
void
+gfc_resolve_lgamma (gfc_expr *f, gfc_expr *x)
+{
+ f->ts = x->ts;
+ f->value.function.name
+ = gfc_get_string ("__lgamma_%d", x->ts.kind);
+}
+
+
+void
gfc_resolve_link (gfc_expr *f, gfc_expr *p1 ATTRIBUTE_UNUSED,
gfc_expr *p2 ATTRIBUTE_UNUSED)
{
gfc_expr *fsource ATTRIBUTE_UNUSED,
gfc_expr *mask ATTRIBUTE_UNUSED)
{
+ if (tsource->ts.type == BT_CHARACTER && tsource->ref)
+ gfc_resolve_substring_charlen (tsource);
+
+ if (fsource->ts.type == BT_CHARACTER && fsource->ref)
+ gfc_resolve_substring_charlen (fsource);
+
if (tsource->ts.type == BT_CHARACTER)
check_charlen_present (tsource);
}
void
-gfc_resolve_nearest (gfc_expr *f, gfc_expr *a, gfc_expr *p ATTRIBUTE_UNUSED)
+gfc_resolve_nearest (gfc_expr *f, gfc_expr *a, gfc_expr *p)
{
+ if (p->ts.kind != a->ts.kind)
+ gfc_convert_type (p, &a->ts, 2);
+
f->ts = a->ts;
f->value.function.name
= gfc_get_string ("__nearest_%c%d", gfc_type_letter (a->ts.type),
gfc_resolve_pack (gfc_expr *f, gfc_expr *array, gfc_expr *mask,
gfc_expr *vector ATTRIBUTE_UNUSED)
{
+ if (array->ts.type == BT_CHARACTER && array->ref)
+ gfc_resolve_substring_charlen (array);
+
f->ts = array->ts;
f->rank = 1;
int kind;
int i;
+ if (source->ts.type == BT_CHARACTER && source->ref)
+ gfc_resolve_substring_charlen (source);
+
f->ts = source->ts;
gfc_array_size (shape, &rank);
gfc_resolve_spread (gfc_expr *f, gfc_expr *source, gfc_expr *dim,
gfc_expr *ncopies)
{
+ if (source->ts.type == BT_CHARACTER && source->ref)
+ gfc_resolve_substring_charlen (source);
+
if (source->ts.type == BT_CHARACTER)
check_charlen_present (source);
/* TODO: Make this do something meaningful. */
static char transfer0[] = "__transfer0", transfer1[] = "__transfer1";
+ if (mold->ts.type == BT_CHARACTER && !mold->ts.cl->length
+ && !(mold->expr_type == EXPR_VARIABLE && mold->symtree->n.sym->attr.dummy))
+ mold->ts.cl->length = gfc_int_expr (mold->value.character.length);
+
f->ts = mold->ts;
if (size == NULL && mold->rank == 0)
void
gfc_resolve_transpose (gfc_expr *f, gfc_expr *matrix)
{
+
+ if (matrix->ts.type == BT_CHARACTER && matrix->ref)
+ gfc_resolve_substring_charlen (matrix);
+
f->ts = matrix->ts;
f->rank = 2;
if (matrix->shape)
gfc_resolve_unpack (gfc_expr *f, gfc_expr *vector, gfc_expr *mask,
gfc_expr *field ATTRIBUTE_UNUSED)
{
+ if (vector->ts.type == BT_CHARACTER && vector->ref)
+ gfc_resolve_substring_charlen (vector);
+
f->ts = vector->ts;
f->rank = mask->rank;
resolve_mask_arg (mask);
name = gfc_get_string (PREFIX ("mvbits_i%d"),
c->ext.actual->expr->ts.kind);
c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
+ /* Mark as elemental subroutine as this does not happen automatically. */
+ c->resolved_sym->attr.elemental = 1;
}
}
-/* G77 compatibility subroutines etime() and dtime(). */
+/* G77 compatibility subroutines dtime() and etime(). */
+
+void
+gfc_resolve_dtime_sub (gfc_code *c)
+{
+ const char *name;
+ name = gfc_get_string (PREFIX ("dtime_sub"));
+ c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
+}
void
gfc_resolve_etime_sub (gfc_code *c)
gfc_resolve_getarg (gfc_code *c)
{
const char *name;
- int kind;
- kind = gfc_default_integer_kind;
- name = gfc_get_string (PREFIX ("getarg_i%d"), kind);
+
+ if (c->ext.actual->expr->ts.kind != gfc_default_integer_kind)
+ {
+ gfc_typespec ts;
+
+ ts.type = BT_INTEGER;
+ ts.kind = gfc_default_integer_kind;
+
+ gfc_convert_type (c->ext.actual->expr, &ts, 2);
+ }
+
+ name = gfc_get_string (PREFIX ("getarg_i%d"), gfc_default_integer_kind);
c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
}
OSDN Git Service
