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); }