unsigned g95_init_options(unsigned argc, const char *argv[]) {
memset(&g95_option, '\0', sizeof(g95_option));
g95_option.fixed_line_length = 72;
g95_option.form = FORM_UNKNOWN;
g95_option.q_kind = g95_default_double_kind();
g95_option.l1 = g95_default_logical_kind();
g95_option.max_frame_size = 250000;
g95_option.symbol_len = G95_MAX_SYMBOL_LEN;
g95_option.cpp = -1;
g95_option.short_circuit = 1;
g95_option.traditional = 1;
g95_option.globals = 1;
g95_option.no_backslash = HAVE_WINDOWS;
argc = 0;
argv = NULL;
#ifdef IN_GCC
flag_errno_math = 0;
#endif
#if STD_F
g95_option.fmode = 96;
g95_option.symbol_len = 31;
set_Wall();
g95_option.tr15581 = 1;
g95_option.bounds_check = 1;
g95_option.real_init = REAL_INIT_NAN;
g95_option.trace = TRACE_FULL;
#endif
return CL_F95;
}
void g95_resolve_btest(g95_expr *l, g95_expr *m, g95_expr *p) {
l->ts.type = BT_LOGICAL;
l->ts.kind = g95_default_logical_kind();
l->value.function.name = g95_get_string(PREFIX "btest_%d_%d", m->ts.kind,
p->ts.kind);
}
void g95_resolve_logical(g95_expr *d, g95_expr *s, g95_expr *kind) {
d->ts.type = BT_LOGICAL;
d->ts.kind = (kind == NULL) ? g95_default_logical_kind()
: mpz_get_si(kind->value.integer);
d->rank = s->rank;
d->value.function.name =
g95_get_string(PREFIX "logical_%d_%c%d", d->ts.kind,
g95_type_letter(s->ts.type), s->ts.kind);
}
static g95_code *build_loops(g95_forall_iterator *u, g95_expr *msk,
g95_code *bottom) {
g95_iterator *iter;
g95_code *m, *y;
g95_expr *a;
if (u != NULL) {
y = build_loops(u->next, msk, bottom);
m = g95_get_code();
m->type = EXEC_DO;
m->where = current_node->where;
m->block = y;
m->ext.iterator = iter = g95_get_iterator();
iter->var = g95_copy_expr(u->var);
iter->start = g95_copy_expr(u->start);
iter->end = g95_copy_expr(u->end);
iter->step = g95_copy_expr(u->stride);
if (u->next == NULL && msk != NULL)
m->block->block->ext.block = m; /* Point CYCLE to its DO-loop */
} else { /* Bottom level */
if (msk == NULL)
m = bottom;
else {
a = g95_get_expr();
a->type = EXPR_OP;
a->where = current_node->where;
a->operator = INTRINSIC_NOT;
a->ts.type = BT_LOGICAL;
a->ts.kind = g95_default_logical_kind();
a->op1 = msk;
m = g95_get_code();
m->where = current_node->where;
m->type = EXEC_IF;
m->expr = a;
m->block = y = g95_get_code();
y->where = current_node->where;
y->type = EXEC_CYCLE;
m->next = bottom;
}
}
return m;
}
void g95_resolve_dot_product(g95_expr *c, g95_expr *r, g95_expr *l) {
g95_expr temp;
if (r->ts.type == BT_LOGICAL && l->ts.type == BT_LOGICAL) {
c->ts.type = BT_LOGICAL;
c->ts.kind = g95_default_logical_kind();
} else {
temp.type = EXPR_OP;
g95_clear_ts(&temp.ts);
temp.operator = INTRINSIC_NONE;
temp.op1 = r;
temp.op2 = l;
g95_type_convert_binary(&temp);
c->ts = temp.ts;
}
c->value.function.name =
g95_get_string(PREFIX "dot_product_%c%d", g95_type_letter(c->ts.type),
c->ts.kind);
}
void g95_resolve_matmul(g95_expr *k, g95_expr *c, g95_expr *j) {
g95_expr t0;
if (c->ts.type == BT_LOGICAL && j->ts.type == BT_LOGICAL) {
k->ts.type = BT_LOGICAL;
k->ts.kind = g95_default_logical_kind();
} else {
t0.type = EXPR_OP;
g95_clear_ts(&t0.ts);
t0.operator = INTRINSIC_NONE;
t0.op1 = c;
t0.op2 = j;
g95_type_convert_binary(&t0);
k->ts = t0.ts;
}
k->rank = (c->rank == 2 && j->rank == 2) ? 2 : 1;
k->value.function.name =
g95_get_string(PREFIX "matmul%d%d_%c%d", c->rank, j->rank,
g95_type_letter(k->ts.type), k->ts.kind);
}
