static void show_constructor (gfc_constructor_base base) { gfc_constructor *c; for (c = gfc_constructor_first (base); c; c = gfc_constructor_next (c)) { if (c->iterator == NULL) show_expr (c->expr); else { fputc ('(', dumpfile); show_expr (c->expr); fputc (' ', dumpfile); show_expr (c->iterator->var); fputc ('=', dumpfile); show_expr (c->iterator->start); fputc (',', dumpfile); show_expr (c->iterator->end); fputc (',', dumpfile); show_expr (c->iterator->step); fputc (')', dumpfile); } if (gfc_constructor_next (c) != NULL) fputs (" , ", dumpfile); } }
static void formalize_init_expr (gfc_expr *expr) { expr_t type; gfc_constructor *c; if (expr == NULL) return; type = expr->expr_type; switch (type) { case EXPR_ARRAY: for (c = gfc_constructor_first (expr->value.constructor); c; c = gfc_constructor_next (c)) formalize_init_expr (c->expr); break; case EXPR_STRUCTURE: formalize_structure_cons (expr); break; default: break; } }
static void formalize_structure_cons (gfc_expr *expr) { gfc_constructor_base base = NULL; gfc_constructor *cur; gfc_component *order; /* Constructor is already formalized. */ cur = gfc_constructor_first (expr->value.constructor); if (!cur || cur->n.component == NULL) return; for (order = expr->ts.u.derived->components; order; order = order->next) { cur = find_con_by_component (order, expr->value.constructor); if (cur) gfc_constructor_append_expr (&base, cur->expr, &cur->expr->where); else gfc_constructor_append_expr (&base, NULL, NULL); } /* For all what it's worth, one would expect gfc_constructor_free (expr->value.constructor); here. However, if the constructor is actually free'd, hell breaks loose in the testsuite?! */ expr->value.constructor = base; }
size_t gfc_merge_initializers (gfc_typespec ts, gfc_expr *e, unsigned char *data, unsigned char *chk, size_t length) { size_t len = 0; gfc_constructor * c; switch (e->expr_type) { case EXPR_CONSTANT: case EXPR_STRUCTURE: len = expr_to_char (e, &data[0], &chk[0], length); break; case EXPR_ARRAY: for (c = gfc_constructor_first (e->value.constructor); c; c = gfc_constructor_next (c)) { size_t elt_size = gfc_target_expr_size (c->expr); if (c->offset) len = elt_size * (size_t)mpz_get_si (c->offset); len = len + gfc_merge_initializers (ts, c->expr, &data[len], &chk[len], length - len); } break; default: return 0; } return len; }
static int encode_derived (gfc_expr *source, unsigned char *buffer, size_t buffer_size) { gfc_constructor *c; gfc_component *cmp; int ptr; tree type; type = gfc_typenode_for_spec (&source->ts); for (c = gfc_constructor_first (source->value.constructor), cmp = source->ts.u.derived->components; c; c = gfc_constructor_next (c), cmp = cmp->next) { gcc_assert (cmp); if (!c->expr) continue; ptr = TREE_INT_CST_LOW(DECL_FIELD_OFFSET(cmp->backend_decl)) + TREE_INT_CST_LOW(DECL_FIELD_BIT_OFFSET(cmp->backend_decl))/8; if (c->expr->expr_type == EXPR_NULL) memset (&buffer[ptr], 0, int_size_in_bytes (TREE_TYPE (cmp->backend_decl))); else gfc_target_encode_expr (c->expr, &buffer[ptr], buffer_size - ptr); } return int_size_in_bytes (type); }
static size_t size_array (gfc_expr *e) { mpz_t array_size; gfc_constructor *c = gfc_constructor_first (e->value.constructor); size_t elt_size = gfc_target_expr_size (c->expr); gfc_array_size (e, &array_size); return (size_t)mpz_get_ui (array_size) * elt_size; }
static gfc_constructor * find_con_by_component (gfc_component *com, gfc_constructor_base base) { gfc_constructor *c; for (c = gfc_constructor_first (base); c; c = gfc_constructor_next (c)) if (com == c->n.component) return c; return NULL; }
static size_t expr_to_char (gfc_expr *e, unsigned char *data, unsigned char *chk, size_t len) { int i; int ptr; gfc_constructor *c; gfc_component *cmp; unsigned char *buffer; if (e == NULL) return 0; /* Take a derived type, one component at a time, using the offsets from the backend declaration. */ if (e->ts.type == BT_DERIVED) { for (c = gfc_constructor_first (e->value.constructor), cmp = e->ts.u.derived->components; c; c = gfc_constructor_next (c), cmp = cmp->next) { gcc_assert (cmp && cmp->backend_decl); if (!c->expr) continue; ptr = TREE_INT_CST_LOW(DECL_FIELD_OFFSET(cmp->backend_decl)) + TREE_INT_CST_LOW(DECL_FIELD_BIT_OFFSET(cmp->backend_decl))/8; expr_to_char (c->expr, &data[ptr], &chk[ptr], len); } return len; } /* Otherwise, use the target-memory machinery to write a bitwise image, appropriate to the target, in a buffer and check off the initialized part of the buffer. */ len = gfc_target_expr_size (e); buffer = (unsigned char*)alloca (len); len = gfc_target_encode_expr (e, buffer, len); for (i = 0; i < (int)len; i++) { if (chk[i] && (buffer[i] != data[i])) { gfc_error ("Overlapping unequal initializers in EQUIVALENCE " "at %L", &e->where); return 0; } chk[i] = 0xFF; } memcpy (data, buffer, len); return len; }
int gfc_check_dependency (gfc_expr *expr1, gfc_expr *expr2, bool identical) { gfc_actual_arglist *actual; gfc_constructor *c; int n; gcc_assert (expr1->expr_type == EXPR_VARIABLE); switch (expr2->expr_type) { case EXPR_OP: n = gfc_check_dependency (expr1, expr2->value.op.op1, identical); if (n) return n; if (expr2->value.op.op2) return gfc_check_dependency (expr1, expr2->value.op.op2, identical); return 0; case EXPR_VARIABLE: /* The interesting cases are when the symbols don't match. */ if (expr1->symtree->n.sym != expr2->symtree->n.sym) { gfc_typespec *ts1 = &expr1->symtree->n.sym->ts; gfc_typespec *ts2 = &expr2->symtree->n.sym->ts; /* Return 1 if expr1 and expr2 are equivalenced arrays. */ if (gfc_are_equivalenced_arrays (expr1, expr2)) return 1; /* Symbols can only alias if they have the same type. */ if (ts1->type != BT_UNKNOWN && ts2->type != BT_UNKNOWN && ts1->type != BT_DERIVED && ts2->type != BT_DERIVED) { if (ts1->type != ts2->type || ts1->kind != ts2->kind) return 0; } /* If either variable is a pointer, assume the worst. */ /* TODO: -fassume-no-pointer-aliasing */ if (gfc_is_data_pointer (expr1) || gfc_is_data_pointer (expr2)) { if (check_data_pointer_types (expr1, expr2) && check_data_pointer_types (expr2, expr1)) return 0; return 1; } else { gfc_symbol *sym1 = expr1->symtree->n.sym; gfc_symbol *sym2 = expr2->symtree->n.sym; if (sym1->attr.target && sym2->attr.target && ((sym1->attr.dummy && !sym1->attr.contiguous && (!sym1->attr.dimension || sym2->as->type == AS_ASSUMED_SHAPE)) || (sym2->attr.dummy && !sym2->attr.contiguous && (!sym2->attr.dimension || sym2->as->type == AS_ASSUMED_SHAPE)))) return 1; } /* Otherwise distinct symbols have no dependencies. */ return 0; } if (identical) return 1; /* Identical and disjoint ranges return 0, overlapping ranges return 1. */ if (expr1->ref && expr2->ref) return gfc_dep_resolver (expr1->ref, expr2->ref, NULL); return 1; case EXPR_FUNCTION: if (expr2->inline_noncopying_intrinsic) identical = 1; /* Remember possible differences between elemental and transformational functions. All functions inside a FORALL will be pure. */ for (actual = expr2->value.function.actual; actual; actual = actual->next) { if (!actual->expr) continue; n = gfc_check_dependency (expr1, actual->expr, identical); if (n) return n; } return 0; case EXPR_CONSTANT: case EXPR_NULL: return 0; case EXPR_ARRAY: /* Loop through the array constructor's elements. */ for (c = gfc_constructor_first (expr2->value.constructor); c; c = gfc_constructor_next (c)) { /* If this is an iterator, assume the worst. */ if (c->iterator) return 1; /* Avoid recursion in the common case. */ if (c->expr->expr_type == EXPR_CONSTANT) continue; if (gfc_check_dependency (expr1, c->expr, 1)) return 1; } return 0; default: return 1; } }
static bool contains_forall_index_p (gfc_expr *expr) { gfc_actual_arglist *arg; gfc_constructor *c; gfc_ref *ref; int i; if (!expr) return false; switch (expr->expr_type) { case EXPR_VARIABLE: if (expr->symtree->n.sym->forall_index) return true; break; case EXPR_OP: if (contains_forall_index_p (expr->value.op.op1) || contains_forall_index_p (expr->value.op.op2)) return true; break; case EXPR_FUNCTION: for (arg = expr->value.function.actual; arg; arg = arg->next) if (contains_forall_index_p (arg->expr)) return true; break; case EXPR_CONSTANT: case EXPR_NULL: case EXPR_SUBSTRING: break; case EXPR_STRUCTURE: case EXPR_ARRAY: for (c = gfc_constructor_first (expr->value.constructor); c; gfc_constructor_next (c)) if (contains_forall_index_p (c->expr)) return true; break; default: gcc_unreachable (); } for (ref = expr->ref; ref; ref = ref->next) switch (ref->type) { case REF_ARRAY: for (i = 0; i < ref->u.ar.dimen; i++) if (contains_forall_index_p (ref->u.ar.start[i]) || contains_forall_index_p (ref->u.ar.end[i]) || contains_forall_index_p (ref->u.ar.stride[i])) return true; break; case REF_COMPONENT: break; case REF_SUBSTRING: if (contains_forall_index_p (ref->u.ss.start) || contains_forall_index_p (ref->u.ss.end)) return true; break; default: gcc_unreachable (); } return false; }