static void forall_temp_array(g95_array_ref *ar, int c,
g95_forall_iterator *w) {
g95_expr *min_expr, *max_expr;
min_expr = g95_build_funcall(NULL, g95_copy_expr(w->start),
g95_copy_expr(w->end), NULL);
min_expr->value.function.isym = g95_find_function("min0");
min_expr->ts.type = BT_INTEGER;
min_expr->ts.kind = g95_default_integer_kind();
max_expr = g95_build_funcall(NULL, g95_copy_expr(w->start),
g95_copy_expr(w->end), NULL);
max_expr->value.function.isym = g95_find_function("max0");
max_expr->ts.type = BT_INTEGER;
max_expr->ts.kind = g95_default_integer_kind();
g95_simplify_expr(min_expr, 0);
g95_simplify_expr(max_expr, 0);
ar->start[c] = min_expr;
ar->end[c] = max_expr;
ar->dimen_type[c] = DIMEN_RANGE;
}
void g95_resolve_shape(g95_expr *y, g95_expr * array) {
y->ts.type = BT_INTEGER;
y->ts.kind = g95_default_integer_kind();
y->rank = 1;
y->value.function.name = PREFIX "shape";
}
void g95_resolve_exponent(g95_expr *o, g95_expr *x) {
o->ts.type = BT_INTEGER;
o->ts.kind = g95_default_integer_kind();
o->value.function.name = g95_get_string(PREFIX "exponent_%d", x->ts.kind);
}
void g95_resolve_ichar(g95_expr *i, g95_expr *l) {
i->ts.type = BT_INTEGER;
i->ts.kind = g95_default_integer_kind();
i->value.function.name = g95_get_string(PREFIX "ichar_%d", l->ts.kind);
}
void g95_resolve_scan(g95_expr *d, g95_expr *str, g95_expr *set,
g95_expr *back) {
d->ts.type = BT_INTEGER;
d->ts.kind = g95_default_integer_kind();
d->value.function.name = g95_get_string(PREFIX "scan_%d", str->ts.kind);
}
void g95_resolve_len_trim(g95_expr *k, g95_expr *str) {
k->ts.type = BT_INTEGER;
k->ts.kind = g95_default_integer_kind();
k->value.function.name = g95_get_string(PREFIX "len_trim_%d",
str->ts.kind);
}
void g95_resolve_verify(g95_expr *n, g95_expr *str, g95_expr *set,
g95_expr *back) {
n->ts.type = BT_INTEGER;
n->ts.kind = g95_default_integer_kind();
n->value.function.name = g95_get_string(PREFIX "verify_%d", str->ts.kind);
}
void g95_resolve_ceiling(g95_expr *t, g95_expr *d, g95_expr *k) {
t->ts.type = BT_INTEGER;
t->ts.kind = (k == NULL) ? g95_default_integer_kind()
: mpz_get_si(k->value.integer);
t->value.function.name = g95_get_string(PREFIX "ceiling_%d", d->ts.kind);
}
void g95_resolve_nint(g95_expr *v, g95_expr *n, g95_expr *kind) {
v->ts.type = BT_INTEGER;
v->ts.kind = (kind == NULL) ? g95_default_integer_kind()
: mpz_get_si(kind->value.integer);
v->value.function.name = g95_get_string(PREFIX "nint_%d", n->ts.kind);
}
void g95_resolve_floor(g95_expr *y, g95_expr *b, g95_expr *k) {
y->ts.type = BT_INTEGER;
y->ts.kind = (k == NULL) ? g95_default_integer_kind()
: mpz_get_si(k->value.integer);
y->value.function.name = g95_get_string(PREFIX "floor_%d", b->ts.kind);
}
void g95_resolve_ubound(g95_expr *d, g95_expr *block, g95_expr *r) {
static char ubound[] = PREFIX "ubound";
d->ts.type = BT_INTEGER;
d->ts.kind = g95_default_integer_kind();
d->value.function.name = ubound;
if (r == NULL) d->rank = 1;
}
void g95_resolve_int(g95_expr *n, g95_expr *m, g95_expr *knd) {
n->ts.type = BT_INTEGER;
n->ts.kind = (knd == NULL) ? g95_default_integer_kind()
: mpz_get_si(knd->value.integer);
n->value.function.name =
g95_get_string(PREFIX "int_%d_%c%d", n->ts.kind,
g95_type_letter(m->ts.type), m->ts.kind);
}
void g95_resolve_lbound(g95_expr *e, g95_expr *ap, g95_expr *d) {
static char lbound[] = PREFIX "lbound";
e->ts.type = BT_INTEGER;
e->ts.kind = g95_default_integer_kind();
e->value.function.name = lbound;
if (d == NULL) e->rank = 1;
}
void g95_resolve_ishftc(g95_expr *a, g95_expr *r, g95_expr *shift,
g95_expr *siz) {
int s_kind;
s_kind = (siz == NULL) ? g95_default_integer_kind() : shift->ts.kind;
a->ts = r->ts;
a->value.function.name =
g95_get_string(PREFIX "ishftc_%d_%d_%d", r->ts.kind, shift->ts.kind,
s_kind);
}
static void show_constant(g95_expr *p) {
switch(p->ts.type) {
case BT_INTEGER:
g95_status_char('\'');
fputs(bi_to_string(p->value.integer), stdout);
if (p->ts.kind != g95_default_integer_kind(0))
g95_status("_%d", p->ts.kind);
g95_status_char('\'');
break;
case BT_LOGICAL:
g95_status(p->value.logical ? "'.true.'" : "'.false.'");
break;
case BT_REAL:
g95_status_char('\'');
fputs(bg_to_string(p->value.real), stdout);
if (p->ts.kind != g95_default_real_kind(1))
g95_status("_%d", p->ts.kind);
g95_status_char('\'');
break;
case BT_CHARACTER:
show_string_constant(p->value.character.string,
p->value.character.length);
break;
case BT_COMPLEX:
g95_status_char('\'');
fputs(bg_to_string(p->value.complex.r), stdout);
if (p->ts.kind != g95_default_complex_kind())
g95_status("_%d", p->ts.kind);
g95_status_char(' ');
fputs(bg_to_string(p->value.complex.i), stdout);
if (p->ts.kind != g95_default_complex_kind())
g95_status("_%d", p->ts.kind);
g95_status_char('\'');
break;
default:
g95_internal_error("show_constant(): Bad type");
break;
}
}
void g95_resolve_count(g95_expr *k, g95_expr *mask, g95_expr *r) {
k->ts.type = BT_INTEGER;
k->ts.kind = g95_default_integer_kind();
if (r == NULL || mask->rank == 1)
k->value.function.name = g95_get_string(PREFIX "count_%d", mask->ts.kind);
else {
k->rank = mask->rank - 1;
k->value.function.name = g95_get_string(PREFIX "countd_%d", mask->ts.kind);
}
}
static void integer_select(g95_code *code) {
g95_typespec ts;
g95_code *body;
g95_case *p;
int kind;
kind = code->expr->ts.kind;
for(body=code->block; body; body=body->block)
for(p=body->ext.case_list; p; p=p->next) {
if (p->low != NULL && p->low->ts.kind > kind)
kind = p->low->ts.kind;
if (p->high != NULL && p->high->ts.kind > kind)
kind = p->high->ts.kind;
}
if (kind < g95_default_integer_kind(1))
kind = g95_default_integer_kind(1);
if (code->expr->ts.kind != kind) {
memset(&ts, '\0', sizeof(ts));
ts.type = BT_INTEGER;
ts.kind = kind;
g95_convert_type(code->expr, &ts, 1);
}
for(body=code->block; body; body=body->block)
for(p=body->ext.case_list; p; p=p->next) {
if (p->low != NULL)
p->low->ts.kind = kind;
if (p->high != NULL)
p->high->ts.kind = kind;
}
}
void g95_resolve_maxloc(g95_expr *h, g95_expr *ap, g95_expr *dim,
g95_expr *mask) {
char *suffix;
h->ts.type = BT_INTEGER;
h->ts.kind = g95_default_integer_kind();
if (dim == NULL) {
h->rank = 1;
suffix = "";
} else {
h->rank = ap->rank - 1;
suffix = (ap->rank == 1) ? "1" : "d";
}
h->value.function.name =
g95_get_string(PREFIX "maxloc%s_%c%d", suffix,
g95_type_letter(ap->ts.type), ap->ts.kind);
}
void g95_resolve_minloc(g95_expr *n, g95_expr *arr, g95_expr *dim,
g95_expr *msk) {
char *suffix;
n->ts.type = BT_INTEGER;
n->ts.kind = g95_default_integer_kind();
if (dim == NULL) {
n->rank = 1;
suffix = "";
} else {
n->rank = arr->rank - 1;
suffix = (arr->rank == 1) ? "1" : "d";
}
n->value.function.name =
g95_get_string(PREFIX "minloc%s_%c%d", suffix,
g95_type_letter(arr->ts.type), arr->ts.kind);
}
static void forall_body(g95_forall_iterator *m, int msk, g95_code *c) {
g95_ref *re, *alloc_ref;
g95_expr *e, *mask_expr;
g95_forall_iterator *p;
g95_symbol *v;
g95_code *r;
int k, rank;
if (!msk)
mask_expr = NULL;
else {
mask_expr = g95_build_funcall(NULL, NULL);
mask_expr->value.function.isym = &forall_get;
mask_expr->value.function.name = PREFIX "forall_get";
mask_expr->ts.type = BT_INTEGER;
mask_expr->ts.kind = g95_default_integer_kind();
}
switch(c->type) {
case EXEC_FORALL:
g95_expand_forall(c);
r = build_loops(m, mask_expr, c);
insert_post(r);
return;
case EXEC_WHERE:
g95_expand_where(&c);
r = build_loops(m, mask_expr, c);
insert_post(c);
return;
case EXEC_ASSIGN:
case EXEC_POINTER_ASSIGN:
break;
default:
g95_internal_error("g95_expand_forall(): Bad code node");
}
if (!find_mask_symbol(c->expr2, c->expr->symbol)) {
r = build_loops(m, mask_expr, c);
insert_post(r);
} else {
rank = 0;
for(p=m; p; p=p->next)
rank++;
v = g95_get_temporary(&c->expr->ts, rank);
r = g95_get_code();
r->type = EXEC_ALLOCATE;
r->where = c->expr->where;
r->ext.alloc_list = g95_get_alloc();
r->ext.alloc_list->expr = e = g95_get_expr();
e->type = EXPR_VARIABLE;
e->where = current_node->where;
e->ts = v->ts;
e->symbol = v;
e->ref = alloc_ref = g95_get_ref();
e->where = current_node->where;
alloc_ref->type = REF_ARRAY;
alloc_ref->u.ar.type = AR_SECTION;
p = m;
for(k=0; k<rank; k++) {
forall_temp_array(&alloc_ref->u.ar, k, p);
p = p->next;
}
alloc_ref->u.ar.dimen = rank;
insert_post(r);
e = c->expr;
c->expr = forall_temp_expr(v, m);
r = build_loops(m, g95_copy_expr(mask_expr), c);
insert_post(r);
/* Copy temp back */
r = g95_get_code();
r->type = EXEC_ASSIGN;
r->where = current_node->where;
r->expr = e;
r->expr2 = forall_temp_expr(v, m);
r = build_loops(m, g95_copy_expr(mask_expr), r);
insert_post(r);
r = g95_get_code();
r->type = EXEC_DEALLOCATE;
r->where = c->where;
r->ext.alloc_list = g95_get_alloc();
r->ext.alloc_list->expr = e = g95_get_expr();
e->type = EXPR_VARIABLE;
e->where = current_node->where;
e->ts = v->ts;
e->symbol = v;
e->ref = re = g95_get_ref();
e->rank = rank;
e->where = c->where;
re->type = REF_ARRAY;
re->u.ar.type = AR_FULL;
insert_post(r);
}
}
void g95_resolve_len(g95_expr *m, g95_expr *s) {
m->ts.type = BT_INTEGER;
m->ts.kind = g95_default_integer_kind();
m->value.function.name = g95_get_string(PREFIX "len_%d", s->ts.kind);
}
