int gfc_interpret_derived (unsigned char *buffer, size_t buffer_size, gfc_expr *result) { gfc_component *cmp; gfc_constructor *head = NULL, *tail = NULL; int ptr; tree type; /* The attributes of the derived type need to be bolted to the floor. */ result->expr_type = EXPR_STRUCTURE; type = gfc_typenode_for_spec (&result->ts); cmp = result->ts.derived->components; /* Run through the derived type components. */ for (;cmp; cmp = cmp->next) { if (head == NULL) head = tail = gfc_get_constructor (); else { tail->next = gfc_get_constructor (); tail = tail->next; } /* The constructor points to the component. */ tail->n.component = cmp; tail->expr = gfc_constant_result (cmp->ts.type, cmp->ts.kind, &result->where); tail->expr->ts = cmp->ts; /* Copy shape, if needed. */ if (cmp->as && cmp->as->rank) { int n; tail->expr->expr_type = EXPR_ARRAY; tail->expr->rank = cmp->as->rank; tail->expr->shape = gfc_get_shape (tail->expr->rank); for (n = 0; n < tail->expr->rank; n++) { mpz_init_set_ui (tail->expr->shape[n], 1); mpz_add (tail->expr->shape[n], tail->expr->shape[n], cmp->as->upper[n]->value.integer); mpz_sub (tail->expr->shape[n], tail->expr->shape[n], cmp->as->lower[n]->value.integer); } } ptr = TREE_INT_CST_LOW (DECL_FIELD_OFFSET (cmp->backend_decl)); gfc_target_interpret_expr (&buffer[ptr], buffer_size - ptr, tail->expr); result->value.constructor = head; } return int_size_in_bytes (type); }
static void formalize_structure_cons (gfc_expr * expr) { gfc_constructor *head; gfc_constructor *tail; gfc_constructor *cur; gfc_constructor *last; gfc_constructor *c; gfc_component *order; c = expr->value.constructor; /* Constructor is already formalized. */ if (c->n.component == NULL) return; head = tail = NULL; for (order = expr->ts.derived->components; order; order = order->next) { /* Find the next component. */ last = NULL; cur = c; while (cur != NULL && cur->n.component != order) { last = cur; cur = cur->next; } if (cur == NULL) { /* Create a new one. */ cur = gfc_get_constructor (); } else { /* Remove it from the chain. */ if (last == NULL) c = cur->next; else last->next = cur->next; cur->next = NULL; formalize_init_expr (cur->expr); } /* Add it to the new constructor. */ if (head == NULL) head = tail = cur; else { tail->next = cur; tail = tail->next; } } gcc_assert (c == NULL); expr->value.constructor = head; }
static int interpret_array (unsigned char *buffer, size_t buffer_size, gfc_expr *result) { int array_size = 1; int i; int ptr = 0; gfc_constructor *head = NULL, *tail = NULL; /* Calculate array size from its shape and rank. */ gcc_assert (result->rank > 0 && result->shape); for (i = 0; i < result->rank; i++) array_size *= (int)mpz_get_ui (result->shape[i]); /* Iterate over array elements, producing constructors. */ for (i = 0; i < array_size; i++) { if (head == NULL) head = tail = gfc_get_constructor (); else { tail->next = gfc_get_constructor (); tail = tail->next; } tail->where = result->where; tail->expr = gfc_constant_result (result->ts.type, result->ts.kind, &result->where); tail->expr->ts = result->ts; if (tail->expr->ts.type == BT_CHARACTER) tail->expr->value.character.length = result->value.character.length; ptr += gfc_target_interpret_expr (&buffer[ptr], buffer_size - ptr, tail->expr); } result->value.constructor = head; return ptr; }
void gfc_assign_data_value_range (gfc_expr * lvalue, gfc_expr * rvalue, mpz_t index, mpz_t repeat) { gfc_ref *ref; gfc_expr *init, *expr; gfc_constructor *con, *last_con; gfc_symbol *symbol; gfc_typespec *last_ts; mpz_t offset; symbol = lvalue->symtree->n.sym; init = symbol->value; last_ts = &symbol->ts; last_con = NULL; mpz_init_set_si (offset, 0); /* Find/create the parent expressions for subobject references. */ for (ref = lvalue->ref; ref; ref = ref->next) { /* Use the existing initializer expression if it exists. Otherwise create a new one. */ if (init == NULL) expr = gfc_get_expr (); else expr = init; /* Find or create this element. */ switch (ref->type) { case REF_ARRAY: if (init == NULL) { /* The element typespec will be the same as the array typespec. */ expr->ts = *last_ts; /* Setup the expression to hold the constructor. */ expr->expr_type = EXPR_ARRAY; expr->rank = ref->u.ar.as->rank; } else gcc_assert (expr->expr_type == EXPR_ARRAY); if (ref->u.ar.type == AR_ELEMENT) { get_array_index (&ref->u.ar, &offset); /* This had better not be the bottom of the reference. We can still get to a full array via a component. */ gcc_assert (ref->next != NULL); } else { mpz_set (offset, index); /* We're at a full array or an array section. This means that we've better have found a full array, and that we're at the bottom of the reference. */ gcc_assert (ref->u.ar.type == AR_FULL); gcc_assert (ref->next == NULL); } /* Find the same element in the existing constructor. */ con = expr->value.constructor; con = find_con_by_offset (offset, con); /* Create a new constructor. */ if (con == NULL) { con = gfc_get_constructor (); mpz_set (con->n.offset, offset); if (ref->next == NULL) mpz_set (con->repeat, repeat); gfc_insert_constructor (expr, con); } else gcc_assert (ref->next != NULL); break; case REF_COMPONENT: if (init == NULL) { /* Setup the expression to hold the constructor. */ expr->expr_type = EXPR_STRUCTURE; expr->ts.type = BT_DERIVED; expr->ts.derived = ref->u.c.sym; } else gcc_assert (expr->expr_type == EXPR_STRUCTURE); last_ts = &ref->u.c.component->ts; /* Find the same element in the existing constructor. */ con = expr->value.constructor; con = find_con_by_component (ref->u.c.component, con); if (con == NULL) { /* Create a new constructor. */ con = gfc_get_constructor (); con->n.component = ref->u.c.component; con->next = expr->value.constructor; expr->value.constructor = con; } /* Since we're only intending to initialize arrays here, there better be an inner reference. */ gcc_assert (ref->next != NULL); break; case REF_SUBSTRING: default: gcc_unreachable (); } if (init == NULL) { /* Point the container at the new expression. */ if (last_con == NULL) symbol->value = expr; else last_con->expr = expr; } init = con->expr; last_con = con; } if (last_ts->type == BT_CHARACTER) expr = create_character_intializer (init, last_ts, NULL, rvalue); else { /* We should never be overwriting an existing initializer. */ gcc_assert (!init); expr = gfc_copy_expr (rvalue); if (!gfc_compare_types (&lvalue->ts, &expr->ts)) gfc_convert_type (expr, &lvalue->ts, 0); } if (last_con == NULL) symbol->value = expr; else last_con->expr = expr; }
void gfc_assign_data_value (gfc_expr * lvalue, gfc_expr * rvalue, mpz_t index) { gfc_ref *ref; gfc_expr *init; gfc_expr *expr; gfc_constructor *con; gfc_constructor *last_con; gfc_symbol *symbol; gfc_typespec *last_ts; mpz_t offset; symbol = lvalue->symtree->n.sym; init = symbol->value; last_ts = &symbol->ts; last_con = NULL; mpz_init_set_si (offset, 0); /* Find/create the parent expressions for subobject references. */ for (ref = lvalue->ref; ref; ref = ref->next) { /* Break out of the loop if we find a substring. */ if (ref->type == REF_SUBSTRING) { /* A substring should always be the last subobject reference. */ gcc_assert (ref->next == NULL); break; } /* Use the existing initializer expression if it exists. Otherwise create a new one. */ if (init == NULL) expr = gfc_get_expr (); else expr = init; /* Find or create this element. */ switch (ref->type) { case REF_ARRAY: if (init == NULL) { /* The element typespec will be the same as the array typespec. */ expr->ts = *last_ts; /* Setup the expression to hold the constructor. */ expr->expr_type = EXPR_ARRAY; expr->rank = ref->u.ar.as->rank; } else gcc_assert (expr->expr_type == EXPR_ARRAY); if (ref->u.ar.type == AR_ELEMENT) get_array_index (&ref->u.ar, &offset); else mpz_set (offset, index); /* Find the same element in the existing constructor. */ con = expr->value.constructor; con = find_con_by_offset (offset, con); if (con == NULL) { /* Create a new constructor. */ con = gfc_get_constructor (); mpz_set (con->n.offset, offset); gfc_insert_constructor (expr, con); } break; case REF_COMPONENT: if (init == NULL) { /* Setup the expression to hold the constructor. */ expr->expr_type = EXPR_STRUCTURE; expr->ts.type = BT_DERIVED; expr->ts.derived = ref->u.c.sym; } else gcc_assert (expr->expr_type == EXPR_STRUCTURE); last_ts = &ref->u.c.component->ts; /* Find the same element in the existing constructor. */ con = expr->value.constructor; con = find_con_by_component (ref->u.c.component, con); if (con == NULL) { /* Create a new constructor. */ con = gfc_get_constructor (); con->n.component = ref->u.c.component; con->next = expr->value.constructor; expr->value.constructor = con; } break; default: gcc_unreachable (); } if (init == NULL) { /* Point the container at the new expression. */ if (last_con == NULL) symbol->value = expr; else last_con->expr = expr; } init = con->expr; last_con = con; } if (ref || last_ts->type == BT_CHARACTER) expr = create_character_intializer (init, last_ts, ref, rvalue); else { /* Overwriting an existing initializer is non-standard but usually only provokes a warning from other compilers. */ if (init != NULL) { /* Order in which the expressions arrive here depends on whether they are from data statements or F95 style declarations. Therefore, check which is the most recent. */ #ifdef USE_MAPPED_LOCATION expr = (LOCATION_LINE (init->where.lb->location) > LOCATION_LINE (rvalue->where.lb->location)) ? init : rvalue; #else expr = (init->where.lb->linenum > rvalue->where.lb->linenum) ? init : rvalue; #endif gfc_notify_std (GFC_STD_GNU, "Extension: re-initialization " "of '%s' at %L", symbol->name, &expr->where); } expr = gfc_copy_expr (rvalue); if (!gfc_compare_types (&lvalue->ts, &expr->ts)) gfc_convert_type (expr, &lvalue->ts, 0); } if (last_con == NULL) symbol->value = expr; else last_con->expr = expr; }
gfc_try gfc_assign_data_value (gfc_expr *lvalue, gfc_expr *rvalue, mpz_t index) { gfc_ref *ref; gfc_expr *init; gfc_expr *expr; gfc_constructor *con; gfc_constructor *last_con; gfc_constructor *pred; gfc_symbol *symbol; gfc_typespec *last_ts; mpz_t offset; splay_tree spt; splay_tree_node sptn; symbol = lvalue->symtree->n.sym; init = symbol->value; last_ts = &symbol->ts; last_con = NULL; mpz_init_set_si (offset, 0); /* Find/create the parent expressions for subobject references. */ for (ref = lvalue->ref; ref; ref = ref->next) { /* Break out of the loop if we find a substring. */ if (ref->type == REF_SUBSTRING) { /* A substring should always be the last subobject reference. */ gcc_assert (ref->next == NULL); break; } /* Use the existing initializer expression if it exists. Otherwise create a new one. */ if (init == NULL) expr = gfc_get_expr (); else expr = init; /* Find or create this element. */ switch (ref->type) { case REF_ARRAY: if (init && expr->expr_type != EXPR_ARRAY) { gfc_error ("'%s' at %L already is initialized at %L", lvalue->symtree->n.sym->name, &lvalue->where, &init->where); return FAILURE; } if (init == NULL) { /* The element typespec will be the same as the array typespec. */ expr->ts = *last_ts; /* Setup the expression to hold the constructor. */ expr->expr_type = EXPR_ARRAY; expr->rank = ref->u.ar.as->rank; } if (ref->u.ar.type == AR_ELEMENT) get_array_index (&ref->u.ar, &offset); else mpz_set (offset, index); /* Check the bounds. */ if (mpz_cmp_si (offset, 0) < 0) { gfc_error ("Data element below array lower bound at %L", &lvalue->where); return FAILURE; } else { mpz_t size; if (spec_size (ref->u.ar.as, &size) == SUCCESS) { if (mpz_cmp (offset, size) >= 0) { mpz_clear (size); gfc_error ("Data element above array upper bound at %L", &lvalue->where); return FAILURE; } mpz_clear (size); } } /* Splay tree containing offset and gfc_constructor. */ spt = expr->con_by_offset; if (spt == NULL) { spt = splay_tree_new (splay_tree_compare_ints, NULL, NULL); expr->con_by_offset = spt; con = NULL; } else con = find_con_by_offset (spt, offset); if (con == NULL) { splay_tree_key j; /* Create a new constructor. */ con = gfc_get_constructor (); mpz_set (con->n.offset, offset); j = (splay_tree_key) mpz_get_si (offset); sptn = splay_tree_insert (spt, j, (splay_tree_value) con); /* Fix up the linked list. */ sptn = splay_tree_predecessor (spt, j); if (sptn == NULL) { /* Insert at the head. */ con->next = expr->value.constructor; expr->value.constructor = con; } else { /* Insert in the chain. */ pred = (gfc_constructor*) sptn->value; con->next = pred->next; pred->next = con; } } break; case REF_COMPONENT: if (init == NULL) { /* Setup the expression to hold the constructor. */ expr->expr_type = EXPR_STRUCTURE; expr->ts.type = BT_DERIVED; expr->ts.derived = ref->u.c.sym; } else gcc_assert (expr->expr_type == EXPR_STRUCTURE); last_ts = &ref->u.c.component->ts; /* Find the same element in the existing constructor. */ con = expr->value.constructor; con = find_con_by_component (ref->u.c.component, con); if (con == NULL) { /* Create a new constructor. */ con = gfc_get_constructor (); con->n.component = ref->u.c.component; con->next = expr->value.constructor; expr->value.constructor = con; } break; default: gcc_unreachable (); } if (init == NULL) { /* Point the container at the new expression. */ if (last_con == NULL) symbol->value = expr; else last_con->expr = expr; } init = con->expr; last_con = con; } if (ref || last_ts->type == BT_CHARACTER) expr = create_character_intializer (init, last_ts, ref, rvalue); else { /* Overwriting an existing initializer is non-standard but usually only provokes a warning from other compilers. */ if (init != NULL) { /* Order in which the expressions arrive here depends on whether they are from data statements or F95 style declarations. Therefore, check which is the most recent. */ expr = (LOCATION_LINE (init->where.lb->location) > LOCATION_LINE (rvalue->where.lb->location)) ? init : rvalue; gfc_notify_std (GFC_STD_GNU, "Extension: re-initialization " "of '%s' at %L", symbol->name, &expr->where); } expr = gfc_copy_expr (rvalue); if (!gfc_compare_types (&lvalue->ts, &expr->ts)) gfc_convert_type (expr, &lvalue->ts, 0); } if (last_con == NULL) symbol->value = expr; else last_con->expr = expr; return SUCCESS; }
int gfc_interpret_derived (unsigned char *buffer, size_t buffer_size, gfc_expr *result) { gfc_component *cmp; gfc_constructor *head = NULL, *tail = NULL; int ptr; tree type; /* The attributes of the derived type need to be bolted to the floor. */ result->expr_type = EXPR_STRUCTURE; type = gfc_typenode_for_spec (&result->ts); cmp = result->ts.u.derived->components; /* Run through the derived type components. */ for (;cmp; cmp = cmp->next) { if (head == NULL) head = tail = gfc_get_constructor (); else { tail->next = gfc_get_constructor (); tail = tail->next; } /* The constructor points to the component. */ tail->n.component = cmp; tail->expr = gfc_constant_result (cmp->ts.type, cmp->ts.kind, &result->where); tail->expr->ts = cmp->ts; /* Copy shape, if needed. */ if (cmp->as && cmp->as->rank) { int n; tail->expr->expr_type = EXPR_ARRAY; tail->expr->rank = cmp->as->rank; tail->expr->shape = gfc_get_shape (tail->expr->rank); for (n = 0; n < tail->expr->rank; n++) { mpz_init_set_ui (tail->expr->shape[n], 1); mpz_add (tail->expr->shape[n], tail->expr->shape[n], cmp->as->upper[n]->value.integer); mpz_sub (tail->expr->shape[n], tail->expr->shape[n], cmp->as->lower[n]->value.integer); } } /* Calculate the offset, which consists of the the FIELD_OFFSET in bytes, which appears in multiples of DECL_OFFSET_ALIGN-bit-sized, and additional bits of FIELD_BIT_OFFSET. The code assumes that all sizes of the components are multiples of BITS_PER_UNIT, i.e. there are, e.g., no bit fields. */ ptr = TREE_INT_CST_LOW (DECL_FIELD_BIT_OFFSET (cmp->backend_decl)); gcc_assert (ptr % 8 == 0); ptr = ptr/8 + TREE_INT_CST_LOW (DECL_FIELD_OFFSET (cmp->backend_decl)); gfc_target_interpret_expr (&buffer[ptr], buffer_size - ptr, tail->expr); result->value.constructor = head; } return int_size_in_bytes (type); }