X-Git-Url: http://git.sourceforge.jp/view?a=blobdiff_plain;f=gcc%2Ffortran%2Fdata.c;h=b1cfd6ec75b082c3270d4596022ad74b02fdf3af;hb=757fb7abad2d7d7a512cae4e1d8e836402f826f1;hp=2ab6f507bbebf00da6d92870d94831b5aba78d10;hpb=e7cf683e32bd972f5612bd4640c37bf60d3b53e6;p=pf3gnuchains%2Fgcc-fork.git diff --git a/gcc/fortran/data.c b/gcc/fortran/data.c index 2ab6f507bbe..b1cfd6ec75b 100644 --- a/gcc/fortran/data.c +++ b/gcc/fortran/data.c @@ -1,12 +1,13 @@ /* Supporting functions for resolving DATA statement. - Copyright (C) 2002, 2003, 2004, 2005 Free Software Foundation, Inc. + Copyright (C) 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009, 2010 + Free Software Foundation, Inc. Contributed by Lifang Zeng This file is part of GCC. GCC is free software; you can redistribute it and/or modify it under the terms of the GNU General Public License as published by the Free -Software Foundation; either version 2, or (at your option) any later +Software Foundation; either version 3, or (at your option) any later version. GCC is distributed in the hope that it will be useful, but WITHOUT ANY @@ -15,37 +16,38 @@ FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License for more details. You should have received a copy of the GNU General Public License -along with GCC; see the file COPYING. If not, write to the Free -Software Foundation, 51 Franklin Street, Fifth Floor,Boston, MA -02110-1301, USA. */ +along with GCC; see the file COPYING3. If not see +. */ /* Notes for DATA statement implementation: - + We first assign initial value to each symbol by gfc_assign_data_value - during resolveing DATA statement. Refer to check_data_variable and + during resolving DATA statement. Refer to check_data_variable and traverse_data_list in resolve.c. - + 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, etc., to convert the initial value. Refer to trans-expr.c and trans-array.c. */ #include "config.h" +#include "system.h" #include "gfortran.h" +#include "data.h" +#include "constructor.h" static void formalize_init_expr (gfc_expr *); /* Calculate the array element offset. */ static void -get_array_index (gfc_array_ref * ar, mpz_t * offset) +get_array_index (gfc_array_ref *ar, mpz_t *offset) { gfc_expr *e; int i; - try re; mpz_t delta; mpz_t tmp; @@ -55,19 +57,20 @@ get_array_index (gfc_array_ref * ar, mpz_t * offset) for (i = 0; i < ar->dimen; i++) { e = gfc_copy_expr (ar->start[i]); - re = gfc_simplify_expr (e, 1); + gfc_simplify_expr (e, 1); if ((gfc_is_constant_expr (ar->as->lower[i]) == 0) || (gfc_is_constant_expr (ar->as->upper[i]) == 0) || (gfc_is_constant_expr (e) == 0)) - gfc_error ("non-constant array in DATA statement %L.", &ar->where); + gfc_error ("non-constant array in DATA statement %L", &ar->where); + mpz_set (tmp, e->value.integer); mpz_sub (tmp, tmp, ar->as->lower[i]->value.integer); mpz_mul (tmp, tmp, delta); mpz_add (*offset, tmp, *offset); mpz_sub (tmp, ar->as->upper[i]->value.integer, - ar->as->lower[i]->value.integer); + ar->as->lower[i]->value.integer); mpz_add_ui (tmp, tmp, 1); mpz_mul (delta, tmp, delta); } @@ -75,95 +78,44 @@ get_array_index (gfc_array_ref * ar, mpz_t * offset) mpz_clear (tmp); } - -/* Find if there is a constructor which offset is equal to OFFSET. */ +/* Find if there is a constructor which component is equal to COM. + TODO: remove this, use symbol.c(gfc_find_component) instead. */ static gfc_constructor * -find_con_by_offset (mpz_t offset, gfc_constructor *con) +find_con_by_component (gfc_component *com, gfc_constructor_base base) { - mpz_t tmp; - gfc_constructor *ret = NULL; - - mpz_init (tmp); - - for (; con; con = con->next) - { - 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; - } - } - } - - mpz_clear (tmp); - return ret; -} - + gfc_constructor *c; -/* Find if there is a constructor which component is equal to COM. */ + for (c = gfc_constructor_first (base); c; c = gfc_constructor_next (c)) + if (com == c->n.component) + return c; -static gfc_constructor * -find_con_by_component (gfc_component *com, gfc_constructor *con) -{ - for (; con; con = con->next) - { - if (com == con->n.component) - return con; - } return NULL; } /* 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 + INIT is the 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) +create_character_initializer (gfc_expr *init, gfc_typespec *ts, + gfc_ref *ref, gfc_expr *rvalue) { - int len; - int start; - int end; - char *dest; + int len, start, end; + gfc_char_t *dest; - gfc_extract_int (ts->cl->length, &len); + gfc_extract_int (ts->u.cl->length, &len); if (init == NULL) { /* Create a new initializer. */ - init = gfc_get_expr (); - init->expr_type = EXPR_CONSTANT; + init = gfc_get_character_expr (ts->kind, NULL, NULL, len); 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 - dest = init->value.character.string; + + dest = init->value.character.string; if (ref) { @@ -172,14 +124,14 @@ create_character_intializer (gfc_expr * init, gfc_typespec * ts, gcc_assert (ref->type == REF_SUBSTRING); /* Only set a substring of the destination. Fortran substring bounds - are one-based [start, end], we want zero based [start, end). */ + are one-based [start, end], we want zero based [start, end). */ start_expr = gfc_copy_expr (ref->u.ss.start); end_expr = gfc_copy_expr (ref->u.ss.end); if ((gfc_simplify_expr (start_expr, 1) == FAILURE) - || (gfc_simplify_expr (end_expr, 1)) == FAILURE) + || (gfc_simplify_expr (end_expr, 1)) == FAILURE) { - gfc_error ("failure to simplify substring reference in DATA" + gfc_error ("failure to simplify substring reference in DATA " "statement at %L", &ref->u.ss.start->where); return NULL; } @@ -196,32 +148,51 @@ create_character_intializer (gfc_expr * init, gfc_typespec * ts, } /* Copy the initial value. */ - len = rvalue->value.character.length; + if (rvalue->ts.type == BT_HOLLERITH) + len = rvalue->representation.length - rvalue->ts.u.pad; + else + len = rvalue->value.character.length; + if (len > end - start) { + gfc_warning_now ("Initialization string starting at %L was " + "truncated to fit the variable (%d/%d)", + &rvalue->where, end - start, len); len = end - start; - gfc_warning_now ("initialization string truncated to match variable " - "at %L", &rvalue->where); } - memcpy (&dest[start], rvalue->value.character.string, len); + if (rvalue->ts.type == BT_HOLLERITH) + { + int i; + for (i = 0; i < len; i++) + dest[start+i] = rvalue->representation.string[i]; + } + else + memcpy (&dest[start], rvalue->value.character.string, + len * sizeof (gfc_char_t)); /* Pad with spaces. Substrings will already be blanked. */ if (len < end - start && ref == NULL) - memset (&dest[start + len], ' ', end - (start + len)); + gfc_wide_memset (&dest[start + len], ' ', end - (start + len)); if (rvalue->ts.type == BT_HOLLERITH) - init->from_H = 1; + { + init->representation.length = init->value.character.length; + init->representation.string + = gfc_widechar_to_char (init->value.character.string, + init->value.character.length); + } return init; } + /* Assign the initial value RVALUE to LVALUE's symbol->value. If the LVALUE already has an initialization, we extend this, otherwise we create a new one. */ -void -gfc_assign_data_value (gfc_expr * lvalue, gfc_expr * rvalue, mpz_t index) +gfc_try +gfc_assign_data_value (gfc_expr *lvalue, gfc_expr *rvalue, mpz_t index) { gfc_ref *ref; gfc_expr *init; @@ -250,7 +221,7 @@ gfc_assign_data_value (gfc_expr * lvalue, gfc_expr * rvalue, mpz_t index) } /* Use the existing initializer expression if it exists. Otherwise - create a new one. */ + create a new one. */ if (init == NULL) expr = gfc_get_expr (); else @@ -260,6 +231,22 @@ gfc_assign_data_value (gfc_expr * lvalue, gfc_expr * rvalue, mpz_t index) switch (ref->type) { case REF_ARRAY: + if (ref->u.ar.as->rank == 0) + { + gcc_assert (ref->u.ar.as->corank > 0); + if (init == NULL) + gfc_free (expr); + continue; + } + + 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); + goto abort; + } + if (init == NULL) { /* The element typespec will be the same as the array @@ -269,24 +256,42 @@ gfc_assign_data_value (gfc_expr * lvalue, gfc_expr * rvalue, mpz_t index) 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); + /* Check the bounds. */ + if (mpz_cmp_si (offset, 0) < 0) + { + gfc_error ("Data element below array lower bound at %L", + &lvalue->where); + goto abort; + } + 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); + goto abort; + } + mpz_clear (size); + } + } - if (con == NULL) + con = gfc_constructor_lookup (expr->value.constructor, + mpz_get_si (offset)); + if (!con) { - /* Create a new constructor. */ - con = gfc_get_constructor (); - mpz_set (con->n.offset, offset); - gfc_insert_constructor (expr, con); + con = gfc_constructor_insert_expr (&expr->value.constructor, + NULL, &rvalue->where, + mpz_get_si (offset)); } break; @@ -296,23 +301,22 @@ gfc_assign_data_value (gfc_expr * lvalue, gfc_expr * rvalue, mpz_t index) /* Setup the expression to hold the constructor. */ expr->expr_type = EXPR_STRUCTURE; expr->ts.type = BT_DERIVED; - expr->ts.derived = ref->u.c.sym; + expr->ts.u.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); + con = find_con_by_component (ref->u.c.component, + expr->value.constructor); if (con == NULL) { /* Create a new constructor. */ - con = gfc_get_constructor (); + con = gfc_constructor_append_expr (&expr->value.constructor, + NULL, NULL); con->n.component = ref->u.c.component; - con->next = expr->value.constructor; - expr->value.constructor = con; } break; @@ -332,27 +336,30 @@ gfc_assign_data_value (gfc_expr * lvalue, gfc_expr * rvalue, mpz_t index) last_con = con; } + mpz_clear (offset); + if (ref || last_ts->type == BT_CHARACTER) - expr = create_character_intializer (init, last_ts, ref, rvalue); + { + if (lvalue->ts.u.cl->length == NULL && !(ref && ref->u.ss.length != NULL)) + return FAILURE; + expr = create_character_initializer (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 + /* 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; -#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); + ? init : rvalue; + if (gfc_notify_std (GFC_STD_GNU,"Extension: " + "re-initialization of '%s' at %L", + symbol->name, &expr->where) == FAILURE) + return FAILURE; } expr = gfc_copy_expr (rvalue); @@ -364,156 +371,45 @@ gfc_assign_data_value (gfc_expr * lvalue, gfc_expr * rvalue, mpz_t index) symbol->value = expr; else last_con->expr = expr; + + return SUCCESS; + +abort: + mpz_clear (offset); + return FAILURE; } + /* 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. */ + value in RVALUE. */ -void -gfc_assign_data_value_range (gfc_expr * lvalue, gfc_expr * rvalue, +gfc_try +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; - } + mpz_t offset, last_offset; + gfc_try t; + + mpz_init (offset); + mpz_init (last_offset); + mpz_add (last_offset, index, repeat); + + t = SUCCESS; + for (mpz_set(offset, index) ; mpz_cmp(offset, last_offset) < 0; + mpz_add_ui (offset, offset, 1)) + if (gfc_assign_data_value (lvalue, rvalue, offset) == FAILURE) + { + t = FAILURE; + break; + } - 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); + mpz_clear (offset); + mpz_clear (last_offset); - 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 t; } + /* Modify the index of array section and re-calculate the array offset. */ void @@ -551,10 +447,9 @@ gfc_advance_section (mpz_t *section_index, gfc_array_ref *ar, else cmp = mpz_cmp (section_index[i], ar->as->upper[i]->value.integer); - if ((cmp > 0 && forwards) - || (cmp < 0 && ! forwards)) + if ((cmp > 0 && forwards) || (cmp < 0 && !forwards)) { - /* Reset index to start, then loop to advance the next index. */ + /* Reset index to start, then loop to advance the next index. */ if (ar->start[i]) mpz_set (section_index[i], ar->start[i]->value.integer); else @@ -574,7 +469,7 @@ gfc_advance_section (mpz_t *section_index, gfc_array_ref *ar, mpz_add (*offset_ret, tmp, *offset_ret); mpz_sub (tmp, ar->as->upper[i]->value.integer, - ar->as->lower[i]->value.integer); + ar->as->lower[i]->value.integer); mpz_add_ui (tmp, tmp, 1); mpz_mul (delta, tmp, delta); } @@ -587,69 +482,40 @@ gfc_advance_section (mpz_t *section_index, gfc_array_ref *ar, order. Also insert NULL entries if necessary. */ static void -formalize_structure_cons (gfc_expr * expr) +formalize_structure_cons (gfc_expr *expr) { - gfc_constructor *head; - gfc_constructor *tail; + gfc_constructor_base base = NULL; 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) + cur = gfc_constructor_first (expr->value.constructor); + if (!cur || cur->n.component == NULL) return; - head = tail = NULL; - for (order = expr->ts.derived->components; order; order = order->next) + for (order = expr->ts.u.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 (); - } + cur = find_con_by_component (order, expr->value.constructor); + if (cur) + gfc_constructor_append_expr (&base, cur->expr, &cur->expr->where); else - { - /* Remove it from the chain. */ - if (last == NULL) - c = cur->next; - else - last->next = cur->next; - cur->next = NULL; + gfc_constructor_append_expr (&base, NULL, NULL); + } - formalize_init_expr (cur->expr); - } + /* 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?! */ - /* 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; + expr->value.constructor = base; } -/* Make sure an initialization expression is in normalized form. Ie. all +/* Make sure an initialization expression is in normalized form, i.e., all elements of the constructors are in the correct order. */ static void -formalize_init_expr (gfc_expr * expr) +formalize_init_expr (gfc_expr *expr) { expr_t type; gfc_constructor *c; @@ -661,13 +527,11 @@ formalize_init_expr (gfc_expr * expr) switch (type) { case EXPR_ARRAY: - c = expr->value.constructor; - while (c) - { - formalize_init_expr (c->expr); - c = c->next; - } - break; + 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); @@ -728,7 +592,7 @@ gfc_get_section_index (gfc_array_ref *ar, mpz_t *section_index, mpz_t *offset) } mpz_sub (tmp, ar->as->upper[i]->value.integer, - ar->as->lower[i]->value.integer); + ar->as->lower[i]->value.integer); mpz_add_ui (tmp, tmp, 1); mpz_mul (delta, tmp, delta); }