X-Git-Url: http://git.sourceforge.jp/view?a=blobdiff_plain;f=gcc%2Ffortran%2Fdata.c;h=67da371ad543ebbb2885f72e67095108374364f2;hb=c0ef5bbc20f511354de87f6bf2d40667f33c4761;hp=2999af2a8607877aa15ed3442586b0b6bab1c75f;hpb=5770ea9d10dc3655426087045d6aae84e35c58be;p=pf3gnuchains%2Fgcc-fork.git

diff --git a/gcc/fortran/data.c b/gcc/fortran/data.c
index 2999af2a860..67da371ad54 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 Free Software Foundation, Inc.
+   Copyright (C) 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009, 2010, 2011
+   Free Software Foundation, Inc.
    Contributed by Lifang Zeng <zlf605@hotmail.com>
 
 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,38 +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, 59 Temple Place - Suite 330,Boston, MA
-02111-1307, USA.  */
+along with GCC; see the file COPYING3.  If not see
+<http://www.gnu.org/licenses/>.  */
 
 
 /* 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 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,
    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 "assert.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;
 
@@ -56,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);
     }
@@ -76,105 +78,67 @@ 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 intialization expression from 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
+   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)
     {
-      assert (ref->type == REF_SUBSTRING);
+      gfc_expr *start_expr, *end_expr;
+
+      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).  */
-      gfc_extract_int (ref->u.ss.start, &start);
+	 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_error ("failure to simplify substring reference in DATA "
+		     "statement at %L", &ref->u.ss.start->where);
+	  return NULL;
+	}
+
+      gfc_extract_int (start_expr, &start);
       start--;
-      gfc_extract_int (ref->u.ss.end, &end);
+      gfc_extract_int (end_expr, &end);
     }
   else
     {
@@ -184,24 +148,54 @@ 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)
-    len = end - start;
-  memcpy (&dest[start], rvalue->value.character.string, len);
+    {
+      gfc_warning_now ("Initialization string starting at %L was "
+		       "truncated to fit the variable (%d/%d)",
+		       &rvalue->where, end - start, len);
+      len = end - start;
+    }
+
+  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->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.  */
+   create a new one.  If REPEAT is non-NULL, initialize *REPEAT
+   consecutive values in LVALUE the same value in RVALUE.  In that case,
+   LVALUE must refer to a full array, not an array section.  */
 
-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,
+		       mpz_t *repeat)
 {
   gfc_ref *ref;
   gfc_expr *init;
@@ -224,13 +218,13 @@ gfc_assign_data_value (gfc_expr * lvalue, gfc_expr * rvalue, mpz_t index)
       /* Break out of the loop if we find a substring.  */
       if (ref->type == REF_SUBSTRING)
 	{
-	  /* A substring should always br the last subobject reference.  */
-	  assert (ref->next == NULL);
+	  /* 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.  */
+	 create a new one.  */
       if (init == NULL)
 	expr = gfc_get_expr ();
       else
@@ -240,6 +234,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)
+		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
@@ -249,168 +259,163 @@ 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
-	    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)
+	  /* Check the bounds.  */
+	  if (mpz_cmp_si (offset, 0) < 0)
 	    {
-	      /* Create a new constructor.  */
-	      con = gfc_get_constructor ();
-	      mpz_set (con->n.offset, offset);
-	      gfc_insert_constructor (expr, con);
+	      gfc_error ("Data element below array lower bound at %L",
+			 &lvalue->where);
+	      goto abort;
 	    }
-	  break;
-
-	case REF_COMPONENT:
-	  if (init == NULL)
+	  else if (repeat != NULL
+		   && ref->u.ar.type != AR_ELEMENT)
 	    {
-	      /* 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
-	    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;
+	      mpz_t size, end;
+	      gcc_assert (ref->u.ar.type == AR_FULL
+			  && ref->next == NULL);
+	      mpz_init_set (end, offset);
+	      mpz_add (end, end, *repeat);
+	      if (spec_size (ref->u.ar.as, &size) == SUCCESS)
+		{
+		  if (mpz_cmp (end, size) > 0)
+		    {
+		      mpz_clear (size);
+		      gfc_error ("Data element above array upper bound at %L",
+				 &lvalue->where);
+		      goto abort;
+		    }
+		  mpz_clear (size);
+		}
+
+	      con = gfc_constructor_lookup (expr->value.constructor,
+					    mpz_get_si (offset));
+	      if (!con)
+		{
+		  con = gfc_constructor_lookup_next (expr->value.constructor,
+						     mpz_get_si (offset));
+		  if (con != NULL && mpz_cmp (con->offset, end) >= 0)
+		    con = NULL;
+		}
+
+	      /* Overwriting an existing initializer is non-standard but
+		 usually only provokes a warning from other compilers.  */
+	      if (con != NULL && con->expr != 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.  */
+		  gfc_expr *exprd;
+		  exprd = (LOCATION_LINE (con->expr->where.lb->location)
+			   > LOCATION_LINE (rvalue->where.lb->location))
+			  ? con->expr : rvalue;
+		  if (gfc_notify_std (GFC_STD_GNU,"Extension: "
+				      "re-initialization of '%s' at %L",
+				      symbol->name, &exprd->where) == FAILURE)
+		    return FAILURE;
+		}
+
+	      while (con != NULL)
+		{
+		  gfc_constructor *next_con = gfc_constructor_next (con);
+
+		  if (mpz_cmp (con->offset, end) >= 0)
+		    break;
+		  if (mpz_cmp (con->offset, offset) < 0)
+		    {
+		      gcc_assert (mpz_cmp_si (con->repeat, 1) > 0);
+		      mpz_sub (con->repeat, offset, con->offset);
+		    }
+		  else if (mpz_cmp_si (con->repeat, 1) > 0
+			   && mpz_get_si (con->offset)
+			      + mpz_get_si (con->repeat) > mpz_get_si (end))
+		    {
+		      int endi;
+		      splay_tree_node node
+			= splay_tree_lookup (con->base,
+					     mpz_get_si (con->offset));
+		      gcc_assert (node
+				  && con == (gfc_constructor *) node->value
+				  && node->key == (splay_tree_key)
+						  mpz_get_si (con->offset));
+		      endi = mpz_get_si (con->offset)
+			     + mpz_get_si (con->repeat);
+		      if (endi > mpz_get_si (end) + 1)
+			mpz_set_si (con->repeat, endi - mpz_get_si (end));
+		      else
+			mpz_set_si (con->repeat, 1);
+		      mpz_set (con->offset, end);
+		      node->key = (splay_tree_key) mpz_get_si (end);
+		      break;
+		    }
+		  else
+		    gfc_constructor_remove (con);
+		  con = next_con;
+		}
+
+	      con = gfc_constructor_insert_expr (&expr->value.constructor,
+						 NULL, &rvalue->where,
+						 mpz_get_si (offset));
+	      mpz_set (con->repeat, *repeat);
+	      repeat = NULL;
+	      mpz_clear (end);
+	      break;
 	    }
-	  break;
-
-	default:
-	  abort ();
-	}
-
-      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.  */
-      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 consectutive 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;
+	      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);
+		}
 	    }
-	  else
-	    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.  */
-	      assert (ref->next != NULL);
-	    }
-	  else
+	  con = gfc_constructor_lookup (expr->value.constructor,
+					mpz_get_si (offset));
+	  if (!con)
 	    {
-	      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.  */
-	      assert (ref->u.ar.type == AR_FULL);
-	      assert (ref->next == NULL);
+	      con = gfc_constructor_insert_expr (&expr->value.constructor,
+						 NULL, &rvalue->where,
+						 mpz_get_si (offset));
 	    }
-
-	  /* 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)
+	  else if (mpz_cmp_si (con->repeat, 1) > 0)
 	    {
-	      con = gfc_get_constructor ();
-	      mpz_set (con->n.offset, offset);
-	      if (ref->next == NULL)
-		mpz_set (con->repeat, repeat);
-	      gfc_insert_constructor (expr, con);
+	      /* Need to split a range.  */
+	      if (mpz_cmp (con->offset, offset) < 0)
+		{
+		  gfc_constructor *pred_con = con;
+		  con = gfc_constructor_insert_expr (&expr->value.constructor,
+						     NULL, &con->where,
+						     mpz_get_si (offset));
+		  con->expr = gfc_copy_expr (pred_con->expr);
+		  mpz_add (con->repeat, pred_con->offset, pred_con->repeat);
+		  mpz_sub (con->repeat, con->repeat, offset);
+		  mpz_sub (pred_con->repeat, offset, pred_con->offset);
+		}
+	      if (mpz_cmp_si (con->repeat, 1) > 0)
+		{
+		  gfc_constructor *succ_con;
+		  succ_con
+		    = gfc_constructor_insert_expr (&expr->value.constructor,
+						   NULL, &con->where,
+						   mpz_get_si (offset) + 1);
+		  succ_con->expr = gfc_copy_expr (con->expr);
+		  mpz_sub_ui (succ_con->repeat, con->repeat, 1);
+		  mpz_set_si (con->repeat, 1);
+		}
 	    }
-	  else
-	    assert (ref->next != NULL);
 	  break;
 
 	case REF_COMPONENT:
@@ -419,33 +424,27 @@ gfc_assign_data_value_range (gfc_expr * lvalue, gfc_expr * rvalue,
 	      /* 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
-	    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 = 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;
 	    }
-
-	  /* Since we're only intending to initialize arrays here,
-	     there better be an inner reference.  */
-	  assert (ref->next != NULL);
 	  break;
 
-	case REF_SUBSTRING:
 	default:
-	  abort ();
+	  gcc_unreachable ();
 	}
 
       if (init == NULL)
@@ -460,19 +459,51 @@ gfc_assign_data_value_range (gfc_expr * lvalue, gfc_expr * rvalue,
       last_con = con;
     }
 
-  /* We should never be overwriting an existing initializer.  */
-  assert (!init);
+  mpz_clear (offset);
+  gcc_assert (repeat == NULL);
 
-  expr = gfc_copy_expr (rvalue);
-  if (!gfc_compare_types (&lvalue->ts, &expr->ts))
-    gfc_convert_type (expr, &lvalue->ts, 0);
+  if (ref || last_ts->type == BT_CHARACTER)
+    {
+      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.  */
+	  expr = (LOCATION_LINE (init->where.lb->location)
+		  > LOCATION_LINE (rvalue->where.lb->location))
+	       ? 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);
+      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;
+
+abort:
+  mpz_clear (offset);
+  return FAILURE;
 }
 
+
 /* Modify the index of array section and re-calculate the array offset.  */
 
 void 
@@ -510,10 +541,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
@@ -533,7 +563,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);
     }
@@ -543,72 +573,43 @@ gfc_advance_section (mpz_t *section_index, gfc_array_ref *ar,
 
 
 /* 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)
+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 fomalized.  */
-  if (c->n.component == NULL)
+  /* Constructor is already formalized.  */
+  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;
-	}
-    }
-  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;
@@ -620,13 +621,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);
@@ -683,11 +682,11 @@ gfc_get_section_index (gfc_array_ref *ar, mpz_t *section_index, mpz_t *offset)
 	  gfc_internal_error ("TODO: Vector sections in data statements");
 
 	default:
-	  abort ();
+	  gcc_unreachable ();
 	}
 
       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);
     }