X-Git-Url: http://git.sourceforge.jp/view?p=pf3gnuchains%2Fgcc-fork.git;a=blobdiff_plain;f=gcc%2Ffortran%2Farray.c;h=c6bb5e857b9ae69f73772784a308c03bb1a8af3c;hp=6ab5f83b9a39ee60b504549e9f9ae138724ccfd0;hb=36eba48c3119a0236a818f0bb51b11c56b4f351e;hpb=4ee9c6840ad3fc92a9034343278a1e476ad6872a
diff --git a/gcc/fortran/array.c b/gcc/fortran/array.c
index 6ab5f83b9a3..c6bb5e857b9 100644
--- a/gcc/fortran/array.c
+++ b/gcc/fortran/array.c
@@ -1,36 +1,34 @@
/* Array things
- Copyright (C) 2000, 2001, 2002 Free Software Foundation, Inc.
+ Copyright (C) 2000, 2001, 2002, 2004, 2005, 2006, 2007, 2008
+ Free Software Foundation, Inc.
Contributed by Andy Vaught
-This file is part of GNU G95.
+This file is part of GCC.
-GNU G95 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 version.
+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 3, or (at your option) any later
+version.
-GNU G95 is distributed in the hope that it will be useful,
-but WITHOUT ANY WARRANTY; without even the implied warranty of
-MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
-GNU General Public License for more details.
+GCC is distributed in the hope that it will be useful, but WITHOUT ANY
+WARRANTY; without even the implied warranty of MERCHANTABILITY or
+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 GNU G95; see the file COPYING. If not, write to
-the Free Software Foundation, 59 Temple Place - Suite 330,
-Boston, MA 02111-1307, USA. */
+along with GCC; see the file COPYING3. If not see
+. */
#include "config.h"
+#include "system.h"
#include "gfortran.h"
#include "match.h"
-#include
-#include
-
/* This parameter is the size of the largest array constructor that we
will expand to an array constructor without iterators.
Constructors larger than this will remain in the iterator form. */
-#define GFC_MAX_AC_EXPAND 100
+#define GFC_MAX_AC_EXPAND 65535
/**************** Array reference matching subroutines *****************/
@@ -38,7 +36,7 @@ Boston, MA 02111-1307, USA. */
/* Copy an array reference structure. */
gfc_array_ref *
-gfc_copy_array_ref (gfc_array_ref * src)
+gfc_copy_array_ref (gfc_array_ref *src)
{
gfc_array_ref *dest;
int i;
@@ -70,14 +68,14 @@ gfc_copy_array_ref (gfc_array_ref * src)
expression. */
static match
-match_subscript (gfc_array_ref * ar, int init)
+match_subscript (gfc_array_ref *ar, int init)
{
match m;
int i;
i = ar->dimen;
- ar->c_where[i] = *gfc_current_locus ();
+ ar->c_where[i] = gfc_current_locus;
ar->start[i] = ar->end[i] = ar->stride[i] = NULL;
/* We can't be sure of the difference between DIMEN_ELEMENT and
@@ -120,7 +118,7 @@ end_element:
if (gfc_match_char (':') == MATCH_YES)
{
m = init ? gfc_match_init_expr (&ar->stride[i])
- : gfc_match_expr (&ar->stride[i]);
+ : gfc_match_expr (&ar->stride[i]);
if (m == MATCH_NO)
gfc_error ("Expected array subscript stride at %C");
@@ -137,13 +135,13 @@ end_element:
to consist of init expressions. */
match
-gfc_match_array_ref (gfc_array_ref * ar, gfc_array_spec * as, int init)
+gfc_match_array_ref (gfc_array_ref *ar, gfc_array_spec *as, int init)
{
match m;
memset (ar, '\0', sizeof (ar));
- ar->where = *gfc_current_locus ();
+ ar->where = gfc_current_locus;
ar->as = as;
if (gfc_match_char ('(') != MATCH_YES)
@@ -171,8 +169,8 @@ gfc_match_array_ref (gfc_array_ref * ar, gfc_array_spec * as, int init)
}
}
- gfc_error ("Array reference at %C cannot have more than "
- stringize (GFC_MAX_DIMENSIONS) " dimensions");
+ gfc_error ("Array reference at %C cannot have more than %d dimensions",
+ GFC_MAX_DIMENSIONS);
error:
return MATCH_ERROR;
@@ -190,7 +188,7 @@ matched:
specifications. */
void
-gfc_free_array_spec (gfc_array_spec * as)
+gfc_free_array_spec (gfc_array_spec *as)
{
int i;
@@ -211,9 +209,8 @@ gfc_free_array_spec (gfc_array_spec * as)
shape and check associated constraints. */
static try
-resolve_array_bound (gfc_expr * e, int check_constant)
+resolve_array_bound (gfc_expr *e, int check_constant)
{
-
if (e == NULL)
return SUCCESS;
@@ -236,7 +233,7 @@ resolve_array_bound (gfc_expr * e, int check_constant)
the shape and make sure everything is integral. */
try
-gfc_resolve_array_spec (gfc_array_spec * as, int check_constant)
+gfc_resolve_array_spec (gfc_array_spec *as, int check_constant)
{
gfc_expr *e;
int i;
@@ -253,6 +250,21 @@ gfc_resolve_array_spec (gfc_array_spec * as, int check_constant)
e = as->upper[i];
if (resolve_array_bound (e, check_constant) == FAILURE)
return FAILURE;
+
+ if ((as->lower[i] == NULL) || (as->upper[i] == NULL))
+ continue;
+
+ /* If the size is negative in this dimension, set it to zero. */
+ if (as->lower[i]->expr_type == EXPR_CONSTANT
+ && as->upper[i]->expr_type == EXPR_CONSTANT
+ && mpz_cmp (as->upper[i]->value.integer,
+ as->lower[i]->value.integer) < 0)
+ {
+ gfc_free_expr (as->upper[i]);
+ as->upper[i] = gfc_copy_expr (as->lower[i]);
+ mpz_sub_ui (as->upper[i]->value.integer,
+ as->upper[i]->value.integer, 1);
+ }
}
return SUCCESS;
@@ -265,14 +277,14 @@ gfc_resolve_array_spec (gfc_array_spec * as, int check_constant)
individual specifications make sense as a whole.
- Parsed Lower Upper Returned
- ------------------------------------
- : NULL NULL AS_DEFERRED (*)
- x 1 x AS_EXPLICIT
- x: x NULL AS_ASSUMED_SHAPE
- x:y x y AS_EXPLICIT
- x:* x NULL AS_ASSUMED_SIZE
- * 1 NULL AS_ASSUMED_SIZE
+ Parsed Lower Upper Returned
+ ------------------------------------
+ : NULL NULL AS_DEFERRED (*)
+ x 1 x AS_EXPLICIT
+ x: x NULL AS_ASSUMED_SHAPE
+ x:y x y AS_EXPLICIT
+ x:* x NULL AS_ASSUMED_SIZE
+ * 1 NULL AS_ASSUMED_SIZE
(*) For non-pointer dummy arrays this is AS_ASSUMED_SHAPE. This
is fixed during the resolution of formal interfaces.
@@ -280,7 +292,7 @@ gfc_resolve_array_spec (gfc_array_spec * as, int check_constant)
Anything else AS_UNKNOWN. */
static array_type
-match_array_element_spec (gfc_array_spec * as)
+match_array_element_spec (gfc_array_spec *as)
{
gfc_expr **upper, **lower;
match m;
@@ -329,7 +341,7 @@ match_array_element_spec (gfc_array_spec * as)
it is. */
match
-gfc_match_array_spec (gfc_array_spec ** asp)
+gfc_match_array_spec (gfc_array_spec **asp)
{
array_type current_type;
gfc_array_spec *as;
@@ -363,7 +375,7 @@ gfc_match_array_spec (gfc_array_spec ** asp)
}
else
switch (as->type)
- { /* See how current spec meshes with the existing */
+ { /* See how current spec meshes with the existing. */
case AS_UNKNOWN:
goto cleanup;
@@ -377,9 +389,8 @@ gfc_match_array_spec (gfc_array_spec ** asp)
if (current_type == AS_EXPLICIT)
break;
- gfc_error
- ("Bad array specification for an explicitly shaped array"
- " at %C");
+ gfc_error ("Bad array specification for an explicitly shaped "
+ "array at %C");
goto cleanup;
@@ -388,8 +399,8 @@ gfc_match_array_spec (gfc_array_spec ** asp)
|| (current_type == AS_DEFERRED))
break;
- gfc_error
- ("Bad array specification for assumed shape array at %C");
+ gfc_error ("Bad array specification for assumed shape "
+ "array at %C");
goto cleanup;
case AS_DEFERRED:
@@ -421,11 +432,17 @@ gfc_match_array_spec (gfc_array_spec ** asp)
if (as->rank >= GFC_MAX_DIMENSIONS)
{
- gfc_error ("Array specification at %C has more than "
- stringize (GFC_MAX_DIMENSIONS) " dimensions");
+ gfc_error ("Array specification at %C has more than %d dimensions",
+ GFC_MAX_DIMENSIONS);
goto cleanup;
}
+ if (as->rank > 7
+ && gfc_notify_std (GFC_STD_F2008, "Fortran 2008: Array "
+ "specification at %C with more than 7 dimensions")
+ == FAILURE)
+ goto cleanup;
+
as->rank++;
}
@@ -453,13 +470,12 @@ cleanup:
something goes wrong. On failure, the caller must free the spec. */
try
-gfc_set_array_spec (gfc_symbol * sym, gfc_array_spec * as, locus * error_loc)
+gfc_set_array_spec (gfc_symbol *sym, gfc_array_spec *as, locus *error_loc)
{
-
if (as == NULL)
return SUCCESS;
- if (gfc_add_dimension (&sym->attr, error_loc) == FAILURE)
+ if (gfc_add_dimension (&sym->attr, sym->name, error_loc) == FAILURE)
return FAILURE;
sym->as = as;
@@ -471,7 +487,7 @@ gfc_set_array_spec (gfc_symbol * sym, gfc_array_spec * as, locus * error_loc)
/* Copy an array specification. */
gfc_array_spec *
-gfc_copy_array_spec (gfc_array_spec * src)
+gfc_copy_array_spec (gfc_array_spec *src)
{
gfc_array_spec *dest;
int i;
@@ -492,11 +508,12 @@ gfc_copy_array_spec (gfc_array_spec * src)
return dest;
}
+
/* Returns nonzero if the two expressions are equal. Only handles integer
constants. */
static int
-compare_bounds (gfc_expr * bound1, gfc_expr * bound2)
+compare_bounds (gfc_expr *bound1, gfc_expr *bound2)
{
if (bound1 == NULL || bound2 == NULL
|| bound1->expr_type != EXPR_CONSTANT
@@ -511,11 +528,12 @@ compare_bounds (gfc_expr * bound1, gfc_expr * bound2)
return 0;
}
+
/* Compares two array specifications. They must be constant or deferred
shape. */
int
-gfc_compare_array_spec (gfc_array_spec * as1, gfc_array_spec * as2)
+gfc_compare_array_spec (gfc_array_spec *as1, gfc_array_spec *as2)
{
int i;
@@ -554,7 +572,7 @@ gfc_compare_array_spec (gfc_array_spec * as1, gfc_array_spec * as2)
elements and should be appended to by gfc_append_constructor(). */
gfc_expr *
-gfc_start_constructor (bt type, int kind, locus * where)
+gfc_start_constructor (bt type, int kind, locus *where)
{
gfc_expr *result;
@@ -574,7 +592,7 @@ gfc_start_constructor (bt type, int kind, locus * where)
node onto the constructor. */
void
-gfc_append_constructor (gfc_expr * base, gfc_expr * new)
+gfc_append_constructor (gfc_expr *base, gfc_expr *new)
{
gfc_constructor *c;
@@ -601,10 +619,11 @@ gfc_append_constructor (gfc_expr * base, gfc_expr * new)
constructor onto the base's one according to the offset. */
void
-gfc_insert_constructor (gfc_expr * base, gfc_constructor * c1)
+gfc_insert_constructor (gfc_expr *base, gfc_constructor *c1)
{
gfc_constructor *c, *pre;
expr_t type;
+ int t;
type = base->expr_type;
@@ -614,39 +633,40 @@ gfc_insert_constructor (gfc_expr * base, gfc_constructor * c1)
{
c = pre = base->value.constructor;
while (c)
- {
- if (type == EXPR_ARRAY)
- {
- if (mpz_cmp (c->n.offset, c1->n.offset) < 0)
- {
- pre = c;
- c = c->next;
- }
- else if (mpz_cmp (c->n.offset, c1->n.offset) == 0)
- {
- gfc_error ("duplicated initializer");
- break;
- }
- else
- break;
- }
- else
- {
- pre = c;
- c = c->next;
- }
- }
+ {
+ if (type == EXPR_ARRAY)
+ {
+ t = mpz_cmp (c->n.offset, c1->n.offset);
+ if (t < 0)
+ {
+ pre = c;
+ c = c->next;
+ }
+ else if (t == 0)
+ {
+ gfc_error ("duplicated initializer");
+ break;
+ }
+ else
+ break;
+ }
+ else
+ {
+ pre = c;
+ c = c->next;
+ }
+ }
if (pre != c)
- {
- pre->next = c1;
- c1->next = c;
- }
+ {
+ pre->next = c1;
+ c1->next = c;
+ }
else
- {
- c1->next = c;
- base->value.constructor = c1;
- }
+ {
+ c1->next = c;
+ base->value.constructor = c1;
+ }
}
}
@@ -658,7 +678,7 @@ gfc_get_constructor (void)
{
gfc_constructor *c;
- c = gfc_getmem (sizeof(gfc_constructor));
+ c = XCNEW (gfc_constructor);
c->expr = NULL;
c->iterator = NULL;
c->next = NULL;
@@ -671,7 +691,7 @@ gfc_get_constructor (void)
/* Free chains of gfc_constructor structures. */
void
-gfc_free_constructor (gfc_constructor * p)
+gfc_free_constructor (gfc_constructor *p)
{
gfc_constructor *next;
@@ -683,7 +703,7 @@ gfc_free_constructor (gfc_constructor * p)
next = p->next;
if (p->expr)
- gfc_free_expr (p->expr);
+ gfc_free_expr (p->expr);
if (p->iterator != NULL)
gfc_free_iterator (p->iterator, 1);
mpz_clear (p->n.offset);
@@ -699,7 +719,7 @@ gfc_free_constructor (gfc_constructor * p)
duplicate was found. */
static int
-check_duplicate_iterator (gfc_constructor * c, gfc_symbol * master)
+check_duplicate_iterator (gfc_constructor *c, gfc_symbol *master)
{
gfc_expr *e;
@@ -716,9 +736,8 @@ check_duplicate_iterator (gfc_constructor * c, gfc_symbol * master)
if (c->iterator->var->symtree->n.sym == master)
{
- gfc_error
- ("DO-iterator '%s' at %L is inside iterator of the same name",
- master->name, &c->where);
+ gfc_error ("DO-iterator '%s' at %L is inside iterator of the "
+ "same name", master->name, &c->where);
return 1;
}
@@ -734,7 +753,7 @@ static match match_array_cons_element (gfc_constructor **);
/* Match a list of array elements. */
static match
-match_array_list (gfc_constructor ** result)
+match_array_list (gfc_constructor **result)
{
gfc_constructor *p, *head, *tail, *new;
gfc_iterator iter;
@@ -743,7 +762,7 @@ match_array_list (gfc_constructor ** result)
match m;
int n;
- old_loc = *gfc_current_locus ();
+ old_loc = gfc_current_locus;
if (gfc_match_char ('(') == MATCH_NO)
return MATCH_NO;
@@ -809,7 +828,7 @@ match_array_list (gfc_constructor ** result)
e->value.constructor = head;
p = gfc_get_constructor ();
- p->where = *gfc_current_locus ();
+ p->where = gfc_current_locus;
p->iterator = gfc_get_iterator ();
*p->iterator = iter;
@@ -825,7 +844,7 @@ syntax:
cleanup:
gfc_free_constructor (head);
gfc_free_iterator (&iter, 0);
- gfc_set_locus (&old_loc);
+ gfc_current_locus = old_loc;
return m;
}
@@ -834,7 +853,7 @@ cleanup:
single expression or a list of elements. */
static match
-match_array_cons_element (gfc_constructor ** result)
+match_array_cons_element (gfc_constructor **result)
{
gfc_constructor *p;
gfc_expr *expr;
@@ -849,7 +868,7 @@ match_array_cons_element (gfc_constructor ** result)
return m;
p = gfc_get_constructor ();
- p->where = *gfc_current_locus ();
+ p->where = gfc_current_locus;
p->expr = expr;
*result = p;
@@ -860,21 +879,61 @@ match_array_cons_element (gfc_constructor ** result)
/* Match an array constructor. */
match
-gfc_match_array_constructor (gfc_expr ** result)
+gfc_match_array_constructor (gfc_expr **result)
{
gfc_constructor *head, *tail, *new;
gfc_expr *expr;
+ gfc_typespec ts;
locus where;
match m;
+ const char *end_delim;
+ bool seen_ts;
if (gfc_match (" (/") == MATCH_NO)
- return MATCH_NO;
+ {
+ if (gfc_match (" [") == MATCH_NO)
+ return MATCH_NO;
+ else
+ {
+ if (gfc_notify_std (GFC_STD_F2003, "Fortran 2003: [...] "
+ "style array constructors at %C") == FAILURE)
+ return MATCH_ERROR;
+ end_delim = " ]";
+ }
+ }
+ else
+ end_delim = " /)";
- where = *gfc_current_locus ();
+ where = gfc_current_locus;
head = tail = NULL;
+ seen_ts = false;
+
+ /* Try to match an optional "type-spec ::" */
+ if (gfc_match_type_spec (&ts, 0) == MATCH_YES)
+ {
+ seen_ts = (gfc_match (" ::") == MATCH_YES);
+
+ if (seen_ts)
+ {
+ if (gfc_notify_std (GFC_STD_F2003, "Fortran 2003: Array constructor "
+ "including type specification at %C") == FAILURE)
+ goto cleanup;
+ }
+ }
- if (gfc_match (" /)") == MATCH_YES)
- goto empty; /* Special case */
+ if (! seen_ts)
+ gfc_current_locus = where;
+
+ if (gfc_match (end_delim) == MATCH_YES)
+ {
+ if (seen_ts)
+ goto done;
+ else
+ {
+ gfc_error ("Empty array constructor at %C is not allowed");
+ goto cleanup;
+ }
+ }
for (;;)
{
@@ -895,10 +954,10 @@ gfc_match_array_constructor (gfc_expr ** result)
break;
}
- if (gfc_match (" /)") == MATCH_NO)
+ if (gfc_match (end_delim) == MATCH_NO)
goto syntax;
-empty:
+done:
expr = gfc_get_expr ();
expr->expr_type = EXPR_ARRAY;
@@ -906,6 +965,14 @@ empty:
expr->value.constructor = head;
/* Size must be calculated at resolution time. */
+ if (seen_ts)
+ expr->ts = ts;
+ else
+ expr->ts.type = BT_UNKNOWN;
+
+ if (expr->ts.cl)
+ expr->ts.cl->length_from_typespec = seen_ts;
+
expr->where = where;
expr->rank = 1;
@@ -936,11 +1003,10 @@ static enum
cons_state;
static int
-check_element_type (gfc_expr * expr)
+check_element_type (gfc_expr *expr, bool convert)
{
-
if (cons_state == CONS_BAD)
- return 0; /* Supress further errors */
+ return 0; /* Suppress further errors */
if (cons_state == CONS_START)
{
@@ -958,6 +1024,9 @@ check_element_type (gfc_expr * expr)
if (gfc_compare_types (&constructor_ts, &expr->ts))
return 0;
+ if (convert)
+ return gfc_convert_type (expr, &constructor_ts, 1) == SUCCESS ? 0 : 1;
+
gfc_error ("Element in %s array constructor at %L is %s",
gfc_typename (&constructor_ts), &expr->where,
gfc_typename (&expr->ts));
@@ -967,10 +1036,10 @@ check_element_type (gfc_expr * expr)
}
-/* Recursive work function for gfc_check_constructor_type(). */
+/* Recursive work function for gfc_check_constructor_type(). */
static try
-check_constructor_type (gfc_constructor * c)
+check_constructor_type (gfc_constructor *c, bool convert)
{
gfc_expr *e;
@@ -980,13 +1049,13 @@ check_constructor_type (gfc_constructor * c)
if (e->expr_type == EXPR_ARRAY)
{
- if (check_constructor_type (e->value.constructor) == FAILURE)
+ if (check_constructor_type (e->value.constructor, convert) == FAILURE)
return FAILURE;
continue;
}
- if (check_element_type (e))
+ if (check_element_type (e, convert))
return FAILURE;
}
@@ -998,14 +1067,24 @@ check_constructor_type (gfc_constructor * c)
On FAILURE, an error has been generated. */
try
-gfc_check_constructor_type (gfc_expr * e)
+gfc_check_constructor_type (gfc_expr *e)
{
try t;
- cons_state = CONS_START;
- gfc_clear_ts (&constructor_ts);
+ if (e->ts.type != BT_UNKNOWN)
+ {
+ cons_state = CONS_GOOD;
+ constructor_ts = e->ts;
+ }
+ else
+ {
+ cons_state = CONS_START;
+ gfc_clear_ts (&constructor_ts);
+ }
- t = check_constructor_type (e->value.constructor);
+ /* If e->ts.type != BT_UNKNOWN, the array constructor included a
+ typespec, and we will now convert the values on the fly. */
+ t = check_constructor_type (e->value.constructor, e->ts.type != BT_UNKNOWN);
if (t == SUCCESS && e->ts.type == BT_UNKNOWN)
e->ts = constructor_ts;
@@ -1023,15 +1102,14 @@ cons_stack;
static cons_stack *base;
-static try check_constructor (gfc_constructor *, try (*)(gfc_expr *));
+static try check_constructor (gfc_constructor *, try (*) (gfc_expr *));
/* Check an EXPR_VARIABLE expression in a constructor to make sure
that that variable is an iteration variables. */
try
-gfc_check_iter_variable (gfc_expr * expr)
+gfc_check_iter_variable (gfc_expr *expr)
{
-
gfc_symbol *sym;
cons_stack *c;
@@ -1050,7 +1128,7 @@ gfc_check_iter_variable (gfc_expr * expr)
constructor, giving variables with the names of iterators a pass. */
static try
-check_constructor (gfc_constructor * c, try (*check_function) (gfc_expr *))
+check_constructor (gfc_constructor *c, try (*check_function) (gfc_expr *))
{
cons_stack element;
gfc_expr *e;
@@ -1088,7 +1166,7 @@ check_constructor (gfc_constructor * c, try (*check_function) (gfc_expr *))
determined by the check_function. */
try
-gfc_check_constructor (gfc_expr * expr, try (*check_function) (gfc_expr *))
+gfc_check_constructor (gfc_expr *expr, try (*check_function) (gfc_expr *))
{
cons_stack *base_save;
try t;
@@ -1132,7 +1210,7 @@ static try expand_constructor (gfc_constructor *);
constructor. */
static try
-count_elements (gfc_expr * e)
+count_elements (gfc_expr *e)
{
mpz_t result;
@@ -1159,7 +1237,7 @@ count_elements (gfc_expr * e)
constructor, freeing the rest. */
static try
-extract_element (gfc_expr * e)
+extract_element (gfc_expr *e)
{
if (e->rank != 0)
@@ -1182,9 +1260,8 @@ extract_element (gfc_expr * e)
stringing new elements together. */
static try
-expand (gfc_expr * e)
+expand (gfc_expr *e)
{
-
if (current_expand.new_head == NULL)
current_expand.new_head = current_expand.new_tail =
gfc_get_constructor ();
@@ -1208,7 +1285,7 @@ expand (gfc_expr * e)
substitute the current value of the iteration variable. */
void
-gfc_simplify_iterator_var (gfc_expr * e)
+gfc_simplify_iterator_var (gfc_expr *e)
{
iterator_stack *p;
@@ -1231,9 +1308,8 @@ gfc_simplify_iterator_var (gfc_expr * e)
recursing into other constructors if present. */
static try
-expand_expr (gfc_expr * e)
+expand_expr (gfc_expr *e)
{
-
if (e->expr_type == EXPR_ARRAY)
return expand_constructor (e->value.constructor);
@@ -1250,7 +1326,7 @@ expand_expr (gfc_expr * e)
static try
-expand_iterator (gfc_constructor * c)
+expand_iterator (gfc_constructor *c)
{
gfc_expr *start, *end, *step;
iterator_stack frame;
@@ -1263,6 +1339,7 @@ expand_iterator (gfc_constructor * c)
mpz_init (trip);
mpz_init (frame.value);
+ frame.prev = NULL;
start = gfc_copy_expr (c->iterator->start);
if (gfc_simplify_expr (start, 1) == FAILURE)
@@ -1333,7 +1410,7 @@ cleanup:
passed expression. */
static try
-expand_constructor (gfc_constructor * c)
+expand_constructor (gfc_constructor *c)
{
gfc_expr *e;
@@ -1376,7 +1453,7 @@ expand_constructor (gfc_constructor * c)
constructor if they are small enough. */
try
-gfc_expand_constructor (gfc_expr * e)
+gfc_expand_constructor (gfc_expr *e)
{
expand_info expand_save;
gfc_expr *f;
@@ -1420,7 +1497,7 @@ done:
FAILURE if not so. */
static try
-constant_element (gfc_expr * e)
+constant_element (gfc_expr *e)
{
int rv;
@@ -1438,7 +1515,7 @@ constant_element (gfc_expr * e)
function that traverses the expression tree. FIXME. */
int
-gfc_constant_ac (gfc_expr * e)
+gfc_constant_ac (gfc_expr *e)
{
expand_info expand_save;
try rc;
@@ -1461,7 +1538,7 @@ gfc_constant_ac (gfc_expr * e)
expanded (no iterators) and zero if iterators are present. */
int
-gfc_expanded_ac (gfc_expr * e)
+gfc_expanded_ac (gfc_expr *e)
{
gfc_constructor *p;
@@ -1480,7 +1557,7 @@ gfc_expanded_ac (gfc_expr * e)
be of the same type. */
static try
-resolve_array_list (gfc_constructor * p)
+resolve_array_list (gfc_constructor *p)
{
try t;
@@ -1489,7 +1566,7 @@ resolve_array_list (gfc_constructor * p)
for (; p; p = p->next)
{
if (p->iterator != NULL
- && gfc_resolve_iterator (p->iterator) == FAILURE)
+ && gfc_resolve_iterator (p->iterator, false) == FAILURE)
t = FAILURE;
if (gfc_resolve_expr (p->expr) == FAILURE)
@@ -1499,12 +1576,143 @@ resolve_array_list (gfc_constructor * p)
return t;
}
+/* Resolve character array constructor. If it has a specified constant character
+ length, pad/trunkate the elements here; if the length is not specified and
+ all elements are of compile-time known length, emit an error as this is
+ invalid. */
-/* Resolve all of the expressions in an array list.
- TODO: String lengths. */
+try
+gfc_resolve_character_array_constructor (gfc_expr *expr)
+{
+ gfc_constructor *p;
+ int found_length;
+
+ gcc_assert (expr->expr_type == EXPR_ARRAY);
+ gcc_assert (expr->ts.type == BT_CHARACTER);
+
+ if (expr->ts.cl == NULL)
+ {
+ for (p = expr->value.constructor; p; p = p->next)
+ if (p->expr->ts.cl != NULL)
+ {
+ /* Ensure that if there is a char_len around that it is
+ used; otherwise the middle-end confuses them! */
+ expr->ts.cl = p->expr->ts.cl;
+ goto got_charlen;
+ }
+
+ expr->ts.cl = gfc_get_charlen ();
+ expr->ts.cl->next = gfc_current_ns->cl_list;
+ gfc_current_ns->cl_list = expr->ts.cl;
+ }
+
+got_charlen:
+
+ found_length = -1;
+
+ if (expr->ts.cl->length == NULL)
+ {
+ /* Check that all constant string elements have the same length until
+ we reach the end or find a variable-length one. */
+
+ for (p = expr->value.constructor; p; p = p->next)
+ {
+ int current_length = -1;
+ gfc_ref *ref;
+ for (ref = p->expr->ref; ref; ref = ref->next)
+ if (ref->type == REF_SUBSTRING
+ && ref->u.ss.start->expr_type == EXPR_CONSTANT
+ && ref->u.ss.end->expr_type == EXPR_CONSTANT)
+ break;
+
+ if (p->expr->expr_type == EXPR_CONSTANT)
+ current_length = p->expr->value.character.length;
+ else if (ref)
+ {
+ long j;
+ j = mpz_get_ui (ref->u.ss.end->value.integer)
+ - mpz_get_ui (ref->u.ss.start->value.integer) + 1;
+ current_length = (int) j;
+ }
+ else if (p->expr->ts.cl && p->expr->ts.cl->length
+ && p->expr->ts.cl->length->expr_type == EXPR_CONSTANT)
+ {
+ long j;
+ j = mpz_get_si (p->expr->ts.cl->length->value.integer);
+ current_length = (int) j;
+ }
+ else
+ return SUCCESS;
+
+ gcc_assert (current_length != -1);
+
+ if (found_length == -1)
+ found_length = current_length;
+ else if (found_length != current_length)
+ {
+ gfc_error ("Different CHARACTER lengths (%d/%d) in array"
+ " constructor at %L", found_length, current_length,
+ &p->expr->where);
+ return FAILURE;
+ }
+
+ gcc_assert (found_length == current_length);
+ }
+
+ gcc_assert (found_length != -1);
+
+ /* Update the character length of the array constructor. */
+ expr->ts.cl->length = gfc_int_expr (found_length);
+ }
+ else
+ {
+ /* We've got a character length specified. It should be an integer,
+ otherwise an error is signalled elsewhere. */
+ gcc_assert (expr->ts.cl->length);
+
+ /* If we've got a constant character length, pad according to this.
+ gfc_extract_int does check for BT_INTEGER and EXPR_CONSTANT and sets
+ max_length only if they pass. */
+ gfc_extract_int (expr->ts.cl->length, &found_length);
+
+ /* Now pad/trunkate the elements accordingly to the specified character
+ length. This is ok inside this conditional, as in the case above
+ (without typespec) all elements are verified to have the same length
+ anyway. */
+ if (found_length != -1)
+ for (p = expr->value.constructor; p; p = p->next)
+ if (p->expr->expr_type == EXPR_CONSTANT)
+ {
+ gfc_expr *cl = NULL;
+ int current_length = -1;
+ bool has_ts;
+
+ if (p->expr->ts.cl && p->expr->ts.cl->length)
+ {
+ cl = p->expr->ts.cl->length;
+ gfc_extract_int (cl, ¤t_length);
+ }
+
+ /* If gfc_extract_int above set current_length, we implicitly
+ know the type is BT_INTEGER and it's EXPR_CONSTANT. */
+
+ has_ts = (expr->ts.cl && expr->ts.cl->length_from_typespec);
+
+ if (! cl
+ || (current_length != -1 && current_length < found_length))
+ gfc_set_constant_character_len (found_length, p->expr,
+ has_ts ? -1 : found_length);
+ }
+ }
+
+ return SUCCESS;
+}
+
+
+/* Resolve all of the expressions in an array list. */
try
-gfc_resolve_array_constructor (gfc_expr * expr)
+gfc_resolve_array_constructor (gfc_expr *expr)
{
try t;
@@ -1512,6 +1720,10 @@ gfc_resolve_array_constructor (gfc_expr * expr)
if (t == SUCCESS)
t = gfc_check_constructor_type (expr);
+ /* gfc_resolve_character_array_constructor is called in gfc_resolve_expr after
+ the call to this function, so we don't need to call it here; if it was
+ called twice, an error message there would be duplicated. */
+
return t;
}
@@ -1519,7 +1731,7 @@ gfc_resolve_array_constructor (gfc_expr * expr)
/* Copy an iterator structure. */
static gfc_iterator *
-copy_iterator (gfc_iterator * src)
+copy_iterator (gfc_iterator *src)
{
gfc_iterator *dest;
@@ -1540,7 +1752,7 @@ copy_iterator (gfc_iterator * src)
/* Copy a constructor structure. */
gfc_constructor *
-gfc_copy_constructor (gfc_constructor * src)
+gfc_copy_constructor (gfc_constructor *src)
{
gfc_constructor *dest;
gfc_constructor *tail;
@@ -1579,7 +1791,7 @@ gfc_copy_constructor (gfc_constructor * src)
have to be particularly fast. */
gfc_expr *
-gfc_get_array_element (gfc_expr * array, int element)
+gfc_get_array_element (gfc_expr *array, int element)
{
expand_info expand_save;
gfc_expr *e;
@@ -1606,18 +1818,17 @@ gfc_get_array_element (gfc_expr * array, int element)
/********* Subroutines for determining the size of an array *********/
-/* These are needed just to accomodate RESHAPE(). There are no
+/* These are needed just to accommodate RESHAPE(). There are no
diagnostics here, we just return a negative number if something
- goes wrong. */
+ goes wrong. */
/* Get the size of single dimension of an array specification. The
array is guaranteed to be one dimensional. */
-static try
-spec_dimen_size (gfc_array_spec * as, int dimen, mpz_t * result)
+try
+spec_dimen_size (gfc_array_spec *as, int dimen, mpz_t *result)
{
-
if (as == NULL)
return FAILURE;
@@ -1626,7 +1837,9 @@ spec_dimen_size (gfc_array_spec * as, int dimen, mpz_t * result)
if (as->type != AS_EXPLICIT
|| as->lower[dimen]->expr_type != EXPR_CONSTANT
- || as->upper[dimen]->expr_type != EXPR_CONSTANT)
+ || as->upper[dimen]->expr_type != EXPR_CONSTANT
+ || as->lower[dimen]->ts.type != BT_INTEGER
+ || as->upper[dimen]->ts.type != BT_INTEGER)
return FAILURE;
mpz_init (*result);
@@ -1641,7 +1854,7 @@ spec_dimen_size (gfc_array_spec * as, int dimen, mpz_t * result)
try
-spec_size (gfc_array_spec * as, mpz_t * result)
+spec_size (gfc_array_spec *as, mpz_t *result)
{
mpz_t size;
int d;
@@ -1667,7 +1880,7 @@ spec_size (gfc_array_spec * as, mpz_t * result)
/* Get the number of elements in an array section. */
static try
-ref_dimen_size (gfc_array_ref * ar, int dimen, mpz_t * result)
+ref_dimen_size (gfc_array_ref *ar, int dimen, mpz_t *result)
{
mpz_t upper, lower, stride;
try t;
@@ -1755,7 +1968,7 @@ ref_dimen_size (gfc_array_ref * ar, int dimen, mpz_t * result)
static try
-ref_size (gfc_array_ref * ar, mpz_t * result)
+ref_size (gfc_array_ref *ar, mpz_t *result)
{
mpz_t size;
int d;
@@ -1784,7 +1997,7 @@ ref_size (gfc_array_ref * ar, mpz_t * result)
otherwise. */
try
-gfc_array_dimen_size (gfc_expr * array, int dimen, mpz_t * result)
+gfc_array_dimen_size (gfc_expr *array, int dimen, mpz_t *result)
{
gfc_ref *ref;
int i;
@@ -1814,6 +2027,12 @@ gfc_array_dimen_size (gfc_expr * array, int dimen, mpz_t * result)
}
}
+ if (array->shape && array->shape[dimen])
+ {
+ mpz_init_set (*result, array->shape[dimen]);
+ return SUCCESS;
+ }
+
if (spec_dimen_size (array->symtree->n.sym->as, dimen, result) == FAILURE)
return FAILURE;
@@ -1846,7 +2065,7 @@ gfc_array_dimen_size (gfc_expr * array, int dimen, mpz_t * result)
variable. Otherwise returns FAILURE. */
try
-gfc_array_size (gfc_expr * array, mpz_t * result)
+gfc_array_size (gfc_expr *array, mpz_t *result)
{
expand_info expand_save;
gfc_ref *ref;
@@ -1911,7 +2130,7 @@ gfc_array_size (gfc_expr * array, mpz_t * result)
array of mpz_t integers. */
try
-gfc_array_ref_shape (gfc_array_ref * ar, mpz_t * shape)
+gfc_array_ref_shape (gfc_array_ref *ar, mpz_t *shape)
{
int d;
int i;
@@ -1956,14 +2175,13 @@ cleanup:
characterizes the reference. */
gfc_array_ref *
-gfc_find_array_ref (gfc_expr * e)
+gfc_find_array_ref (gfc_expr *e)
{
gfc_ref *ref;
for (ref = e->ref; ref; ref = ref->next)
if (ref->type == REF_ARRAY
- && (ref->u.ar.type == AR_FULL
- || ref->u.ar.type == AR_SECTION))
+ && (ref->u.ar.type == AR_FULL || ref->u.ar.type == AR_SECTION))
break;
if (ref == NULL)
@@ -1971,3 +2189,22 @@ gfc_find_array_ref (gfc_expr * e)
return &ref->u.ar;
}
+
+
+/* Find out if an array shape is known at compile time. */
+
+int
+gfc_is_compile_time_shape (gfc_array_spec *as)
+{
+ int i;
+
+ if (as->type != AS_EXPLICIT)
+ return 0;
+
+ for (i = 0; i < as->rank; i++)
+ if (!gfc_is_constant_expr (as->lower[i])
+ || !gfc_is_constant_expr (as->upper[i]))
+ return 0;
+
+ return 1;
+}