/* Supporting functions for resolving DATA statement.
- Copyright (C) 2002, 2003, 2004 Free Software Foundation, Inc.
+ Copyright (C) 2002, 2003, 2004, 2005 Free Software Foundation, Inc.
Contributed by Lifang Zeng <zlf605@hotmail.com>
This file is part of GCC.
during resolveing DATA statement. Refer to check_data_variable and
traverse_data_list in resolve.c.
- The complexity exists in the handleing of array section, implied do
+ The complexity exists in the handling of array section, implied do
and array of struct appeared in DATA statement.
We call gfc_conv_structure, gfc_con_array_array_initializer,
trans-array.c. */
#include "config.h"
-#include "system.h"
-#include "coretypes.h"
-#include "toplev.h"
#include "gfortran.h"
-#include "assert.h"
-#include "trans.h"
static void formalize_init_expr (gfc_expr *);
static gfc_constructor *
find_con_by_offset (mpz_t offset, gfc_constructor *con)
{
+ mpz_t tmp;
+ gfc_constructor *ret = NULL;
+
+ mpz_init (tmp);
+
for (; con; con = con->next)
{
- if (mpz_cmp (offset, con->n.offset) == 0)
- return con;
+ int cmp = mpz_cmp (offset, con->n.offset);
+
+ /* We retain a sorted list, so if we're too large, we're done. */
+ if (cmp < 0)
+ break;
+
+ /* Yaye for exact matches. */
+ if (cmp == 0)
+ {
+ ret = con;
+ break;
+ }
+
+ /* If the constructor element is a range, match any element. */
+ if (mpz_cmp_ui (con->repeat, 1) > 0)
+ {
+ mpz_add (tmp, con->n.offset, con->repeat);
+ if (mpz_cmp (offset, tmp) < 0)
+ {
+ ret = con;
+ break;
+ }
+ }
}
- return NULL;
+
+ mpz_clear (tmp);
+ return ret;
}
return NULL;
}
-/* Assign RVALUE to LVALUE where we assume that LVALUE is a substring
- reference. We do a little more than that: if LVALUE already has an
- initialization, we put RVALUE into the existing initialization as
- per the rules of assignment to a substring. If LVALUE has no
- initialization yet, we initialize it to all blanks, then filling in
- the RVALUE. */
-static void
-assign_substring_data_value (gfc_expr * lvalue, gfc_expr * rvalue)
+/* Create a character type initialization expression from RVALUE.
+ TS [and REF] describe [the substring of] the variable being initialized.
+ INIT is thh existing initializer, not NULL. Initialization is performed
+ according to normal assignment rules. */
+
+static gfc_expr *
+create_character_intializer (gfc_expr * init, gfc_typespec * ts,
+ gfc_ref * ref, gfc_expr * rvalue)
{
- gfc_symbol *symbol;
- gfc_expr *expr, *init;
- gfc_ref *ref;
- int len, i;
- int start, end;
- char *c, *d;
+ int len;
+ int start;
+ int end;
+ char *dest;
- symbol = lvalue->symtree->n.sym;
- ref = lvalue->ref;
- init = symbol->value;
-
- assert (symbol->ts.type == BT_CHARACTER);
- assert (symbol->ts.cl->length->expr_type == EXPR_CONSTANT);
- assert (symbol->ts.cl->length->ts.type == BT_INTEGER);
- assert (symbol->ts.kind == 1);
+ gfc_extract_int (ts->cl->length, &len);
- gfc_extract_int (symbol->ts.cl->length, &len);
-
if (init == NULL)
{
- /* Setup the expression to hold the constructor. */
- expr = gfc_get_expr ();
- expr->expr_type = EXPR_CONSTANT;
- expr->ts.type = BT_CHARACTER;
- expr->ts.kind = 1;
-
- expr->value.character.length = len;
- expr->value.character.string = gfc_getmem (len);
- memset (expr->value.character.string, ' ', len);
-
- symbol->value = expr;
+ /* Create a new initializer. */
+ init = gfc_get_expr ();
+ init->expr_type = EXPR_CONSTANT;
+ init->ts = *ts;
+
+ dest = gfc_getmem (len);
+ init->value.character.length = len;
+ init->value.character.string = dest;
+ /* Blank the string if we're only setting a substring. */
+ if (ref != NULL)
+ memset (dest, ' ', len);
}
else
- expr = init;
-
- /* Now that we have allocated the memory for the string,
- fill in the initialized places, truncating the
- intialization string if necessary, i.e.
- DATA a(1:2) /'123'/
- doesn't initialize a(3:3). */
-
- gfc_extract_int (ref->u.ss.start, &start);
- gfc_extract_int (ref->u.ss.end, &end);
-
- assert (start >= 1);
- assert (end <= len);
+ dest = init->value.character.string;
- len = rvalue->value.character.length;
- c = rvalue->value.character.string;
- d = &expr->value.character.string[start - 1];
+ if (ref)
+ {
+ gcc_assert (ref->type == REF_SUBSTRING);
- for (i = 0; i <= end - start && i < len; i++)
- d[i] = c[i];
+ /* Only set a substring of the destination. Fortran substring bounds
+ are one-based [start, end], we want zero based [start, end). */
+ gfc_extract_int (ref->u.ss.start, &start);
+ start--;
+ gfc_extract_int (ref->u.ss.end, &end);
+ }
+ else
+ {
+ /* Set the whole string. */
+ start = 0;
+ end = len;
+ }
- /* Pad with spaces. I.e.
- DATA a(1:2) /'a'/
- intializes a(1:2) to 'a ' per the rules for assignment.
- If init == NULL we don't need to do this, as we have
- intialized the whole string to blanks above. */
+ /* Copy the initial value. */
+ len = rvalue->value.character.length;
+ if (len > end - start)
+ len = end - start;
+ memcpy (&dest[start], rvalue->value.character.string, len);
- if (init != NULL)
- for (; i <= end - start; i++)
- d[i] = ' ';
+ /* Pad with spaces. Substrings will already be blanked. */
+ if (len < end - start && ref == NULL)
+ memset (&dest[start + len], ' ', end - (start + len));
- return;
+ return init;
}
/* Assign the initial value RVALUE to LVALUE's symbol->value. If the
gfc_constructor *con;
gfc_constructor *last_con;
gfc_symbol *symbol;
+ gfc_typespec *last_ts;
mpz_t offset;
- ref = lvalue->ref;
- if (ref != NULL && ref->type == REF_SUBSTRING)
- {
- /* No need to go through the for (; ref; ref->next) loop, since
- a single substring lvalue will only refer to a single
- substring, and therefore ref->next == NULL. */
- assert (ref->next == NULL);
- assign_substring_data_value (lvalue, rvalue);
- return;
- }
-
symbol = lvalue->symtree->n.sym;
init = symbol->value;
+ last_ts = &symbol->ts;
last_con = NULL;
mpz_init_set_si (offset, 0);
- for (; ref; ref = ref->next)
+ /* 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 br 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)
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;
- if (ref->next)
- {
- assert (ref->next->type == REF_COMPONENT);
- expr->ts.type = BT_DERIVED;
- }
- else
- expr->ts = rvalue->ts;
expr->rank = ref->u.ar.as->rank;
}
else
- assert (expr->expr_type == EXPR_ARRAY);
+ gcc_assert (expr->expr_type == EXPR_ARRAY);
if (ref->u.ar.type == AR_ELEMENT)
get_array_index (&ref->u.ar, &offset);
if (con == NULL)
{
/* Create a new constructor. */
- con = gfc_get_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
+ {
+ /* 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;
+}
+
+/* Similarly, but initialize REPEAT consecutive values in LVALUE the same
+ value in RVALUE. For the nonce, LVALUE must refer to a full array, not
+ an array section. */
+
+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:
expr->ts.derived = ref->u.c.sym;
}
else
- assert (expr->expr_type == EXPR_STRUCTURE);
+ 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->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: dealt with separately above. */
-
+ case REF_SUBSTRING:
default:
- abort ();
+ gcc_unreachable ();
}
if (init == NULL)
last_con = con;
}
+ /* 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
- {
- assert (!last_con->expr);
- last_con->expr = expr;
- }
+ last_con->expr = expr;
}
-
/* Modify the index of array section and re-calculate the array offset. */
void
/* Rearrange a structure constructor so the elements are in the specified
- order. Also insert NULL entries if neccessary. */
+ order. Also insert NULL entries if necessary. */
static void
formalize_structure_cons (gfc_expr * expr)
c = expr->value.constructor;
- /* Constructor is already fomalized. */
+ /* Constructor is already formalized. */
if (c->n.component == NULL)
return;
tail = tail->next;
}
}
- assert (c == NULL);
+ gcc_assert (c == NULL);
expr->value.constructor = head;
}
break;
case DIMEN_VECTOR:
- gfc_todo_error ("Vectors sections in data statements");
+ gfc_internal_error ("TODO: Vector sections in data statements");
default:
- abort ();
+ gcc_unreachable ();
}
mpz_sub (tmp, ar->as->upper[i]->value.integer,
OSDN Git Service
