/* 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)
+ if (mask->expr_type == EXPR_OP && mask->ts.kind != 1)
{
ts.type = BT_LOGICAL;
ts.kind = 1;
}
}
- f->value.function.name
- = gfc_get_string (PREFIX ("cshift%d_%d%s"), n, shift->ts.kind,
- array->ts.type == BT_CHARACTER ? "_char" : "");
+ if (array->ts.type == BT_CHARACTER)
+ {
+ if (array->ts.kind == gfc_default_character_kind)
+ f->value.function.name
+ = gfc_get_string (PREFIX ("cshift%d_%d_char"), n, shift->ts.kind);
+ else
+ f->value.function.name
+ = gfc_get_string (PREFIX ("cshift%d_%d_char%d"), n, shift->ts.kind,
+ array->ts.kind);
+ }
+ else
+ f->value.function.name
+ = gfc_get_string (PREFIX ("cshift%d_%d"), n, shift->ts.kind);
}
temp.expr_type = EXPR_OP;
gfc_clear_ts (&temp.ts);
- temp.value.op.operator = INTRINSIC_NONE;
+ temp.value.op.op = INTRINSIC_NONE;
temp.value.op.op1 = a;
temp.value.op.op2 = b;
gfc_type_convert_binary (&temp);
}
}
- f->value.function.name
- = gfc_get_string (PREFIX ("eoshift%d_%d%s"), n, shift->ts.kind,
- array->ts.type == BT_CHARACTER ? "_char" : "");
+ if (array->ts.type == BT_CHARACTER)
+ {
+ if (array->ts.kind == gfc_default_character_kind)
+ f->value.function.name
+ = gfc_get_string (PREFIX ("eoshift%d_%d_char"), n, shift->ts.kind);
+ else
+ f->value.function.name
+ = gfc_get_string (PREFIX ("eoshift%d_%d_char%d"), n, shift->ts.kind,
+ array->ts.kind);
+ }
+ else
+ f->value.function.name
+ = gfc_get_string (PREFIX ("eoshift%d_%d"), n, shift->ts.kind);
}
{
temp.expr_type = EXPR_OP;
gfc_clear_ts (&temp.ts);
- temp.value.op.operator = INTRINSIC_NONE;
+ temp.value.op.op = INTRINSIC_NONE;
temp.value.op.op1 = a;
temp.value.op.op2 = b;
gfc_type_convert_binary (&temp);
f->rank = (a->rank == 2 && b->rank == 2) ? 2 : 1;
+ if (a->rank == 2 && b->rank == 2)
+ {
+ if (a->shape && b->shape)
+ {
+ f->shape = gfc_get_shape (f->rank);
+ mpz_init_set (f->shape[0], a->shape[0]);
+ mpz_init_set (f->shape[1], b->shape[1]);
+ }
+ }
+ else if (a->rank == 1)
+ {
+ if (b->shape)
+ {
+ f->shape = gfc_get_shape (f->rank);
+ mpz_init_set (f->shape[0], b->shape[1]);
+ }
+ }
+ else
+ {
+ /* b->rank == 1 and a->rank == 2 here, all other cases have
+ been caught in check.c. */
+ if (a->shape)
+ {
+ f->shape = gfc_get_shape (f->rank);
+ mpz_init_set (f->shape[0], a->shape[0]);
+ }
+ }
+
f->value.function.name
= gfc_get_string (PREFIX ("matmul_%c%d"), gfc_type_letter (f->ts.type),
f->ts.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);
}
if (dim != NULL)
{
f->rank = array->rank - 1;
+ f->shape = gfc_copy_shape_excluding (array->shape, array->rank, dim);
gfc_resolve_dim_arg (dim);
}
}
+/* Create a formal arglist based on an actual one and set the INTENTs given. */
+
+static gfc_formal_arglist*
+create_formal_for_intents (gfc_actual_arglist* actual, const sym_intent* ints)
+{
+ gfc_formal_arglist* head;
+ gfc_formal_arglist* tail;
+ int i;
+
+ if (!actual)
+ return NULL;
+
+ head = tail = gfc_get_formal_arglist ();
+ for (i = 0; actual; actual = actual->next, tail = tail->next, ++i)
+ {
+ gfc_symbol* sym;
+
+ sym = gfc_new_symbol ("dummyarg", NULL);
+ sym->ts = actual->expr->ts;
+
+ sym->attr.intent = ints[i];
+ tail->sym = sym;
+
+ if (actual->next)
+ tail->next = gfc_get_formal_arglist ();
+ }
+
+ return head;
+}
+
+
void
gfc_resolve_mvbits (gfc_code *c)
{
+ static const sym_intent INTENTS[] = {INTENT_IN, INTENT_IN, INTENT_IN,
+ INTENT_INOUT, INTENT_IN};
+
const char *name;
gfc_typespec ts;
gfc_clear_ts (&ts);
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;
+
+ /* Create a dummy formal arglist so the INTENTs are known later for purpose
+ of creating temporaries. */
+ c->resolved_sym->formal = create_formal_for_intents (c->ext.actual, INTENTS);
}