1 files changed, 532 insertions, 398 deletions

diff --git a/gcc/fortran/expr.c b/gcc/fortran/expr.c
index 9e2beb6..700fd10 100644
--- a/gcc/fortran/expr.c
+++ b/gcc/fortran/expr.c
@@ -26,8 +26,19 @@ along with GCC; see the file COPYING3.  If not see
 #include "arith.h"
 #include "match.h"
 #include "target-memory.h" /* for gfc_convert_boz */
+#include "constructor.h"
 
-/* Get a new expr node.  */
+
+/* The following set of functions provide access to gfc_expr* of
+   various types - actual all but EXPR_FUNCTION and EXPR_VARIABLE.
+
+   There are two functions available elsewhere that provide
+   slightly different flavours of variables.  Namely:
+     expr.c (gfc_get_variable_expr)
+     symbol.c (gfc_lval_expr_from_sym)
+   TODO: Merge these functions, if possible.  */
+
+/* Get a new expression node.  */
 
 gfc_expr *
 gfc_get_expr (void)
@@ -39,92 +50,349 @@ gfc_get_expr (void)
   e->shape = NULL;
   e->ref = NULL;
   e->symtree = NULL;
-  e->con_by_offset = NULL;
   return e;
 }
 
 
-/* Free an argument list and everything below it.  */
+/* Get a new expression node that is an array constructor
+   of given type and kind.  */
 
-void
-gfc_free_actual_arglist (gfc_actual_arglist *a1)
+gfc_expr *
+gfc_get_array_expr (bt type, int kind, locus *where)
 {
-  gfc_actual_arglist *a2;
+  gfc_expr *e;
 
-  while (a1)
-    {
-      a2 = a1->next;
-      gfc_free_expr (a1->expr);
-      gfc_free (a1);
-      a1 = a2;
-    }
+  e = gfc_get_expr ();
+  e->expr_type = EXPR_ARRAY;
+  e->value.constructor = NULL;
+  e->rank = 1;
+  e->shape = NULL;
+
+  e->ts.type = type;
+  e->ts.kind = kind;
+  if (where)
+    e->where = *where;
+
+  return e;
 }
 
 
-/* Copy an arglist structure and all of the arguments.  */
+/* Get a new expression node that is the NULL expression.  */
 
-gfc_actual_arglist *
-gfc_copy_actual_arglist (gfc_actual_arglist *p)
+gfc_expr *
+gfc_get_null_expr (locus *where)
 {
-  gfc_actual_arglist *head, *tail, *new_arg;
+  gfc_expr *e;
 
-  head = tail = NULL;
+  e = gfc_get_expr ();
+  e->expr_type = EXPR_NULL;
+  e->ts.type = BT_UNKNOWN;
 
-  for (; p; p = p->next)
+  if (where)
+    e->where = *where;
+
+  return e;
+}
+
+
+/* Get a new expression node that is an operator expression node.  */
+
+gfc_expr *
+gfc_get_operator_expr (locus *where, gfc_intrinsic_op op,
+                      gfc_expr *op1, gfc_expr *op2)
+{
+  gfc_expr *e;
+
+  e = gfc_get_expr ();
+  e->expr_type = EXPR_OP;
+  e->value.op.op = op;
+  e->value.op.op1 = op1;
+  e->value.op.op2 = op2;
+
+  if (where)
+    e->where = *where;
+
+  return e;
+}
+
+
+/* Get a new expression node that is an structure constructor
+   of given type and kind.  */
+
+gfc_expr *
+gfc_get_structure_constructor_expr (bt type, int kind, locus *where)
+{
+  gfc_expr *e;
+
+  e = gfc_get_expr ();
+  e->expr_type = EXPR_STRUCTURE;
+  e->value.constructor = NULL;
+
+  e->ts.type = type;
+  e->ts.kind = kind;
+  if (where)
+    e->where = *where;
+
+  return e;
+}
+
+
+/* Get a new expression node that is an constant of given type and kind.  */
+
+gfc_expr *
+gfc_get_constant_expr (bt type, int kind, locus *where)
+{
+  gfc_expr *e;
+
+  if (!where)
+    gfc_internal_error ("gfc_get_constant_expr(): locus 'where' cannot be NULL");
+
+  e = gfc_get_expr ();
+
+  e->expr_type = EXPR_CONSTANT;
+  e->ts.type = type;
+  e->ts.kind = kind;
+  e->where = *where;
+
+  switch (type)
     {
-      new_arg = gfc_get_actual_arglist ();
-      *new_arg = *p;
+    case BT_INTEGER:
+      mpz_init (e->value.integer);
+      break;
 
-      new_arg->expr = gfc_copy_expr (p->expr);
-      new_arg->next = NULL;
+    case BT_REAL:
+      gfc_set_model_kind (kind);
+      mpfr_init (e->value.real);
+      break;
 
-      if (head == NULL)
-	head = new_arg;
-      else
-	tail->next = new_arg;
+    case BT_COMPLEX:
+      gfc_set_model_kind (kind);
+      mpc_init2 (e->value.complex, mpfr_get_default_prec());
+      break;
 
-      tail = new_arg;
+    default:
+      break;
     }
 
-  return head;
+  return e;
 }
 
 
-/* Free a list of reference structures.  */
+/* Get a new expression node that is an string constant.
+   If no string is passed, a string of len is allocated,
+   blanked and null-terminated.  */
 
-void
-gfc_free_ref_list (gfc_ref *p)
+gfc_expr *
+gfc_get_character_expr (int kind, locus *where, const char *src, int len)
 {
-  gfc_ref *q;
-  int i;
+  gfc_expr *e;
+  gfc_char_t *dest;
 
-  for (; p; p = q)
+  if (!src)
     {
-      q = p->next;
+      dest = gfc_get_wide_string (len + 1);
+      gfc_wide_memset (dest, ' ', len);
+      dest[len] = '\0';
+    }
+  else
+    dest = gfc_char_to_widechar (src);
 
-      switch (p->type)
+  e = gfc_get_constant_expr (BT_CHARACTER, kind,
+                            where ? where : &gfc_current_locus);
+  e->value.character.string = dest;
+  e->value.character.length = len;
+
+  return e;
+}
+
+
+/* Get a new expression node that is an integer constant.  */
+
+gfc_expr *
+gfc_get_int_expr (int kind, locus *where, int value)
+{
+  gfc_expr *p;
+  p = gfc_get_constant_expr (BT_INTEGER, kind,
+			     where ? where : &gfc_current_locus);
+
+  mpz_init_set_si (p->value.integer, value);
+
+  return p;
+}
+
+
+/* Get a new expression node that is a logical constant.  */
+
+gfc_expr *
+gfc_get_logical_expr (int kind, locus *where, bool value)
+{
+  gfc_expr *p;
+  p = gfc_get_constant_expr (BT_LOGICAL, kind,
+			     where ? where : &gfc_current_locus);
+
+  p->value.logical = value;
+
+  return p;
+}
+
+
+gfc_expr *
+gfc_get_iokind_expr (locus *where, io_kind k)
+{
+  gfc_expr *e;
+
+  /* Set the types to something compatible with iokind. This is needed to
+     get through gfc_free_expr later since iokind really has no Basic Type,
+     BT, of its own.  */
+
+  e = gfc_get_expr ();
+  e->expr_type = EXPR_CONSTANT;
+  e->ts.type = BT_LOGICAL;
+  e->value.iokind = k;
+  e->where = *where;
+
+  return e;
+}
+
+
+/* Given an expression pointer, return a copy of the expression.  This
+   subroutine is recursive.  */
+
+gfc_expr *
+gfc_copy_expr (gfc_expr *p)
+{
+  gfc_expr *q;
+  gfc_char_t *s;
+  char *c;
+
+  if (p == NULL)
+    return NULL;
+
+  q = gfc_get_expr ();
+  *q = *p;
+
+  switch (q->expr_type)
+    {
+    case EXPR_SUBSTRING:
+      s = gfc_get_wide_string (p->value.character.length + 1);
+      q->value.character.string = s;
+      memcpy (s, p->value.character.string,
+	      (p->value.character.length + 1) * sizeof (gfc_char_t));
+      break;
+
+    case EXPR_CONSTANT:
+      /* Copy target representation, if it exists.  */
+      if (p->representation.string)
 	{
-	case REF_ARRAY:
-	  for (i = 0; i < GFC_MAX_DIMENSIONS; i++)
+	  c = XCNEWVEC (char, p->representation.length + 1);
+	  q->representation.string = c;
+	  memcpy (c, p->representation.string, (p->representation.length + 1));
+	}
+
+      /* Copy the values of any pointer components of p->value.  */
+      switch (q->ts.type)
+	{
+	case BT_INTEGER:
+	  mpz_init_set (q->value.integer, p->value.integer);
+	  break;
+
+	case BT_REAL:
+	  gfc_set_model_kind (q->ts.kind);
+	  mpfr_init (q->value.real);
+	  mpfr_set (q->value.real, p->value.real, GFC_RND_MODE);
+	  break;
+
+	case BT_COMPLEX:
+	  gfc_set_model_kind (q->ts.kind);
+	  mpc_init2 (q->value.complex, mpfr_get_default_prec());
+	  mpc_set (q->value.complex, p->value.complex, GFC_MPC_RND_MODE);
+	  break;
+
+	case BT_CHARACTER:
+	  if (p->representation.string)
+	    q->value.character.string
+	      = gfc_char_to_widechar (q->representation.string);
+	  else
 	    {
-	      gfc_free_expr (p->u.ar.start[i]);
-	      gfc_free_expr (p->u.ar.end[i]);
-	      gfc_free_expr (p->u.ar.stride[i]);
-	    }
+	      s = gfc_get_wide_string (p->value.character.length + 1);
+	      q->value.character.string = s;
 
+	      /* This is the case for the C_NULL_CHAR named constant.  */
+	      if (p->value.character.length == 0
+		  && (p->ts.is_c_interop || p->ts.is_iso_c))
+		{
+		  *s = '\0';
+		  /* Need to set the length to 1 to make sure the NUL
+		     terminator is copied.  */
+		  q->value.character.length = 1;
+		}
+	      else
+		memcpy (s, p->value.character.string,
+			(p->value.character.length + 1) * sizeof (gfc_char_t));
+	    }
 	  break;
 
-	case REF_SUBSTRING:
-	  gfc_free_expr (p->u.ss.start);
-	  gfc_free_expr (p->u.ss.end);
+	case BT_HOLLERITH:
+	case BT_LOGICAL:
+	case BT_DERIVED:
+	case BT_CLASS:
+	  break;		/* Already done.  */
+
+	case BT_PROCEDURE:
+        case BT_VOID:
+           /* Should never be reached.  */
+	case BT_UNKNOWN:
+	  gfc_internal_error ("gfc_copy_expr(): Bad expr node");
+	  /* Not reached.  */
+	}
+
+      break;
+
+    case EXPR_OP:
+      switch (q->value.op.op)
+	{
+	case INTRINSIC_NOT:
+	case INTRINSIC_PARENTHESES:
+	case INTRINSIC_UPLUS:
+	case INTRINSIC_UMINUS:
+	  q->value.op.op1 = gfc_copy_expr (p->value.op.op1);
 	  break;
 
-	case REF_COMPONENT:
+	default:		/* Binary operators.  */
+	  q->value.op.op1 = gfc_copy_expr (p->value.op.op1);
+	  q->value.op.op2 = gfc_copy_expr (p->value.op.op2);
 	  break;
 	}
 
-      gfc_free (p);
+      break;
+
+    case EXPR_FUNCTION:
+      q->value.function.actual =
+	gfc_copy_actual_arglist (p->value.function.actual);
+      break;
+
+    case EXPR_COMPCALL:
+    case EXPR_PPC:
+      q->value.compcall.actual =
+	gfc_copy_actual_arglist (p->value.compcall.actual);
+      q->value.compcall.tbp = p->value.compcall.tbp;
+      break;
+
+    case EXPR_STRUCTURE:
+    case EXPR_ARRAY:
+      q->value.constructor = gfc_constructor_copy (p->value.constructor);
+      break;
+
+    case EXPR_VARIABLE:
+    case EXPR_NULL:
+      break;
     }
+
+  q->shape = gfc_copy_shape (p->shape, p->rank);
+
+  q->ref = gfc_copy_ref (p->ref);
+
+  return q;
 }
 
 
@@ -191,7 +459,7 @@ free_expr0 (gfc_expr *e)
 
     case EXPR_ARRAY:
     case EXPR_STRUCTURE:
-      gfc_free_constructor (e->value.constructor);
+      gfc_constructor_free (e->value.constructor);
       break;
 
     case EXPR_SUBSTRING:
@@ -227,13 +495,95 @@ gfc_free_expr (gfc_expr *e)
 {
   if (e == NULL)
     return;
-  if (e->con_by_offset)
-    splay_tree_delete (e->con_by_offset); 
   free_expr0 (e);
   gfc_free (e);
 }
 
 
+/* Free an argument list and everything below it.  */
+
+void
+gfc_free_actual_arglist (gfc_actual_arglist *a1)
+{
+  gfc_actual_arglist *a2;
+
+  while (a1)
+    {
+      a2 = a1->next;
+      gfc_free_expr (a1->expr);
+      gfc_free (a1);
+      a1 = a2;
+    }
+}
+
+
+/* Copy an arglist structure and all of the arguments.  */
+
+gfc_actual_arglist *
+gfc_copy_actual_arglist (gfc_actual_arglist *p)
+{
+  gfc_actual_arglist *head, *tail, *new_arg;
+
+  head = tail = NULL;
+
+  for (; p; p = p->next)
+    {
+      new_arg = gfc_get_actual_arglist ();
+      *new_arg = *p;
+
+      new_arg->expr = gfc_copy_expr (p->expr);
+      new_arg->next = NULL;
+
+      if (head == NULL)
+	head = new_arg;
+      else
+	tail->next = new_arg;
+
+      tail = new_arg;
+    }
+
+  return head;
+}
+
+
+/* Free a list of reference structures.  */
+
+void
+gfc_free_ref_list (gfc_ref *p)
+{
+  gfc_ref *q;
+  int i;
+
+  for (; p; p = q)
+    {
+      q = p->next;
+
+      switch (p->type)
+	{
+	case REF_ARRAY:
+	  for (i = 0; i < GFC_MAX_DIMENSIONS; i++)
+	    {
+	      gfc_free_expr (p->u.ar.start[i]);
+	      gfc_free_expr (p->u.ar.end[i]);
+	      gfc_free_expr (p->u.ar.stride[i]);
+	    }
+
+	  break;
+
+	case REF_SUBSTRING:
+	  gfc_free_expr (p->u.ss.start);
+	  gfc_free_expr (p->u.ss.end);
+	  break;
+
+	case REF_COMPONENT:
+	  break;
+	}
+
+      gfc_free (p);
+    }
+}
+
+
 /* Graft the *src expression onto the *dest subexpression.  */
 
 void
@@ -420,147 +770,6 @@ gfc_copy_shape_excluding (mpz_t *shape, int rank, gfc_expr *dim)
 }
 
 
-/* Given an expression pointer, return a copy of the expression.  This
-   subroutine is recursive.  */
-
-gfc_expr *
-gfc_copy_expr (gfc_expr *p)
-{
-  gfc_expr *q;
-  gfc_char_t *s;
-  char *c;
-
-  if (p == NULL)
-    return NULL;
-
-  q = gfc_get_expr ();
-  *q = *p;
-
-  switch (q->expr_type)
-    {
-    case EXPR_SUBSTRING:
-      s = gfc_get_wide_string (p->value.character.length + 1);
-      q->value.character.string = s;
-      memcpy (s, p->value.character.string,
-	      (p->value.character.length + 1) * sizeof (gfc_char_t));
-      break;
-
-    case EXPR_CONSTANT:
-      /* Copy target representation, if it exists.  */
-      if (p->representation.string)
-	{
-	  c = XCNEWVEC (char, p->representation.length + 1);
-	  q->representation.string = c;
-	  memcpy (c, p->representation.string, (p->representation.length + 1));
-	}
-
-      /* Copy the values of any pointer components of p->value.  */
-      switch (q->ts.type)
-	{
-	case BT_INTEGER:
-	  mpz_init_set (q->value.integer, p->value.integer);
-	  break;
-
-	case BT_REAL:
-	  gfc_set_model_kind (q->ts.kind);
-	  mpfr_init (q->value.real);
-	  mpfr_set (q->value.real, p->value.real, GFC_RND_MODE);
-	  break;
-
-	case BT_COMPLEX:
-	  gfc_set_model_kind (q->ts.kind);
-	  mpc_init2 (q->value.complex, mpfr_get_default_prec());
-	  mpc_set (q->value.complex, p->value.complex, GFC_MPC_RND_MODE);
-	  break;
-
-	case BT_CHARACTER:
-	  if (p->representation.string)
-	    q->value.character.string
-	      = gfc_char_to_widechar (q->representation.string);
-	  else
-	    {
-	      s = gfc_get_wide_string (p->value.character.length + 1);
-	      q->value.character.string = s;
-
-	      /* This is the case for the C_NULL_CHAR named constant.  */
-	      if (p->value.character.length == 0
-		  && (p->ts.is_c_interop || p->ts.is_iso_c))
-		{
-		  *s = '\0';
-		  /* Need to set the length to 1 to make sure the NUL
-		     terminator is copied.  */
-		  q->value.character.length = 1;
-		}
-	      else
-		memcpy (s, p->value.character.string,
-			(p->value.character.length + 1) * sizeof (gfc_char_t));
-	    }
-	  break;
-
-	case BT_HOLLERITH:
-	case BT_LOGICAL:
-	case BT_DERIVED:
-	case BT_CLASS:
-	  break;		/* Already done.  */
-
-	case BT_PROCEDURE:
-        case BT_VOID:
-           /* Should never be reached.  */
-	case BT_UNKNOWN:
-	  gfc_internal_error ("gfc_copy_expr(): Bad expr node");
-	  /* Not reached.  */
-	}
-
-      break;
-
-    case EXPR_OP:
-      switch (q->value.op.op)
-	{
-	case INTRINSIC_NOT:
-	case INTRINSIC_PARENTHESES:
-	case INTRINSIC_UPLUS:
-	case INTRINSIC_UMINUS:
-	  q->value.op.op1 = gfc_copy_expr (p->value.op.op1);
-	  break;
-
-	default:		/* Binary operators.  */
-	  q->value.op.op1 = gfc_copy_expr (p->value.op.op1);
-	  q->value.op.op2 = gfc_copy_expr (p->value.op.op2);
-	  break;
-	}
-
-      break;
-
-    case EXPR_FUNCTION:
-      q->value.function.actual =
-	gfc_copy_actual_arglist (p->value.function.actual);
-      break;
-
-    case EXPR_COMPCALL:
-    case EXPR_PPC:
-      q->value.compcall.actual =
-	gfc_copy_actual_arglist (p->value.compcall.actual);
-      q->value.compcall.tbp = p->value.compcall.tbp;
-      break;
-
-    case EXPR_STRUCTURE:
-    case EXPR_ARRAY:
-      q->value.constructor = gfc_copy_constructor (p->value.constructor);
-      break;
-
-    case EXPR_VARIABLE:
-    case EXPR_NULL:
-      break;
-    }
-
-  q->shape = gfc_copy_shape (p->shape, p->rank);
-
-  q->ref = gfc_copy_ref (p->ref);
-
-  return q;
-}
-
-
 /* Return the maximum kind of two expressions.  In general, higher
    kind numbers mean more precision for numeric types.  */
 
@@ -589,48 +798,6 @@ gfc_numeric_ts (gfc_typespec *ts)
 }
 
 
-/* Returns an expression node that is an integer constant.  */
-
-gfc_expr *
-gfc_int_expr (int i)
-{
-  gfc_expr *p;
-
-  p = gfc_get_expr ();
-
-  p->expr_type = EXPR_CONSTANT;
-  p->ts.type = BT_INTEGER;
-  p->ts.kind = gfc_default_integer_kind;
-
-  p->where = gfc_current_locus;
-  mpz_init_set_si (p->value.integer, i);
-
-  return p;
-}
-
-
-/* Returns an expression node that is a logical constant.  */
-
-gfc_expr *
-gfc_logical_expr (int i, locus *where)
-{
-  gfc_expr *p;
-
-  p = gfc_get_expr ();
-
-  p->expr_type = EXPR_CONSTANT;
-  p->ts.type = BT_LOGICAL;
-  p->ts.kind = gfc_default_logical_kind;
-
-  if (where == NULL)
-    where = &gfc_current_locus;
-  p->where = *where;
-  p->value.logical = i;
-
-  return p;
-}
-
-
 /* Return an expression node with an optional argument list attached.
    A variable number of gfc_expr pointers are strung together in an
    argument list with a NULL pointer terminating the list.  */
@@ -764,7 +931,6 @@ gfc_is_constant_expr (gfc_expr *e)
 {
   gfc_constructor *c;
   gfc_actual_arglist *arg;
-  int rv;
 
   if (e == NULL)
     return 1;
@@ -772,68 +938,55 @@ gfc_is_constant_expr (gfc_expr *e)
   switch (e->expr_type)
     {
     case EXPR_OP:
-      rv = (gfc_is_constant_expr (e->value.op.op1)
-	    && (e->value.op.op2 == NULL
-		|| gfc_is_constant_expr (e->value.op.op2)));
-      break;
+      return (gfc_is_constant_expr (e->value.op.op1)
+	      && (e->value.op.op2 == NULL
+		  || gfc_is_constant_expr (e->value.op.op2)));
 
     case EXPR_VARIABLE:
-      rv = 0;
-      break;
+      return 0;
 
     case EXPR_FUNCTION:
     case EXPR_PPC:
     case EXPR_COMPCALL:
       /* Specification functions are constant.  */
       if (check_specification_function (e) == MATCH_YES)
-	{
-	  rv = 1;
-	  break;
-	}
+	return 1;
 
       /* Call to intrinsic with at least one argument.  */
-      rv = 0;
       if (e->value.function.isym && e->value.function.actual)
 	{
 	  for (arg = e->value.function.actual; arg; arg = arg->next)
-	    {
-	      if (!gfc_is_constant_expr (arg->expr))
-		break;
-	    }
-	  if (arg == NULL)
-	    rv = 1;
+	    if (!gfc_is_constant_expr (arg->expr))
+	      return 0;
+
+	  return 1;
 	}
-      break;
+      else
+	return 0;
 
     case EXPR_CONSTANT:
     case EXPR_NULL:
-      rv = 1;
-      break;
+      return 1;
 
     case EXPR_SUBSTRING:
-      rv = e->ref == NULL || (gfc_is_constant_expr (e->ref->u.ss.start)
-			      && gfc_is_constant_expr (e->ref->u.ss.end));
-      break;
+      return e->ref == NULL || (gfc_is_constant_expr (e->ref->u.ss.start)
+				&& gfc_is_constant_expr (e->ref->u.ss.end));
 
     case EXPR_STRUCTURE:
-      rv = 0;
-      for (c = e->value.constructor; c; c = c->next)
+      for (c = gfc_constructor_first (e->value.constructor);
+	   c; c = gfc_constructor_next (c))
 	if (!gfc_is_constant_expr (c->expr))
-	  break;
+	  return 0;
 
-      if (c == NULL)
-	rv = 1;
-      break;
+      return 1;
 
     case EXPR_ARRAY:
-      rv = gfc_constant_ac (e);
-      break;
+      return gfc_constant_ac (e);
 
     default:
       gfc_internal_error ("gfc_is_constant_expr(): Unknown expression type");
+      return 0;
     }
-
-  return rv;
 }
 
 
@@ -1005,11 +1158,12 @@ simplify_intrinsic_op (gfc_expr *p, int type)
    with gfc_simplify_expr().  */
 
 static gfc_try
-simplify_constructor (gfc_constructor *c, int type)
+simplify_constructor (gfc_constructor_base base, int type)
 {
+  gfc_constructor *c;
   gfc_expr *p;
 
-  for (; c; c = c->next)
+  for (c = gfc_constructor_first (base); c; c = gfc_constructor_next (c))
     {
       if (c->iterator
 	  && (gfc_simplify_expr (c->iterator->start, type) == FAILURE
@@ -1041,7 +1195,7 @@ simplify_constructor (gfc_constructor *c, int type)
 /* Pull a single array element out of an array constructor.  */
 
 static gfc_try
-find_array_element (gfc_constructor *cons, gfc_array_ref *ar,
+find_array_element (gfc_constructor_base base, gfc_array_ref *ar,
 		    gfc_constructor **rval)
 {
   unsigned long nelemen;
@@ -1050,6 +1204,7 @@ find_array_element (gfc_constructor *cons, gfc_array_ref *ar,
   mpz_t offset;
   mpz_t span;
   mpz_t tmp;
+  gfc_constructor *cons;
   gfc_expr *e;
   gfc_try t;
 
@@ -1104,16 +1259,13 @@ find_array_element (gfc_constructor *cons, gfc_array_ref *ar,
       mpz_mul (span, span, tmp);
     }
 
-  for (nelemen = mpz_get_ui (offset); nelemen > 0; nelemen--)
+  for (cons = gfc_constructor_first (base), nelemen = mpz_get_ui (offset);
+       cons && nelemen > 0; cons = gfc_constructor_next (cons), nelemen--)
     {
-      if (cons)
+      if (cons->iterator)
 	{
-	  if (cons->iterator)
-	    {
-	      cons = NULL;
-	      goto depart;
-	    }
-	  cons = cons->next;
+	  cons = NULL;
+	  goto depart;
 	}
     }
 
@@ -1132,20 +1284,21 @@ depart:
 /* Find a component of a structure constructor.  */
 
 static gfc_constructor *
-find_component_ref (gfc_constructor *cons, gfc_ref *ref)
+find_component_ref (gfc_constructor_base base, gfc_ref *ref)
 {
   gfc_component *comp;
   gfc_component *pick;
+  gfc_constructor *c = gfc_constructor_first (base);
 
   comp = ref->u.c.sym->components;
   pick = ref->u.c.component;
   while (comp != pick)
     {
       comp = comp->next;
-      cons = cons->next;
+      c = gfc_constructor_next (c);
     }
 
-  return cons;
+  return c;
 }
 
 
@@ -1190,15 +1343,13 @@ find_array_section (gfc_expr *expr, gfc_ref *ref)
   mpz_t tmp_mpz;
   mpz_t nelts;
   mpz_t ptr;
-  mpz_t index;
-  gfc_constructor *cons;
-  gfc_constructor *base;
+  gfc_constructor_base base;
+  gfc_constructor *cons, *vecsub[GFC_MAX_DIMENSIONS];
   gfc_expr *begin;
   gfc_expr *finish;
   gfc_expr *step;
   gfc_expr *upper;
   gfc_expr *lower;
-  gfc_constructor *vecsub[GFC_MAX_DIMENSIONS], *c;
   gfc_try t;
 
   t = SUCCESS;
@@ -1240,6 +1391,7 @@ find_array_section (gfc_expr *expr, gfc_ref *ref)
 
       if (ref->u.ar.dimen_type[d] == DIMEN_VECTOR)  /* Vector subscript.  */
 	{
+	  gfc_constructor *ci;
 	  gcc_assert (begin);
 
 	  if (begin->expr_type != EXPR_ARRAY || !gfc_is_constant_expr (begin))
@@ -1256,16 +1408,16 @@ find_array_section (gfc_expr *expr, gfc_ref *ref)
 	      break;
 	    }
 
-	  vecsub[d] = begin->value.constructor;
+	  vecsub[d] = gfc_constructor_first (begin->value.constructor);
 	  mpz_set (ctr[d], vecsub[d]->expr->value.integer);
 	  mpz_mul (nelts, nelts, begin->shape[0]);
 	  mpz_set (expr->shape[shape_i++], begin->shape[0]);
 
 	  /* Check bounds.  */
-	  for (c = vecsub[d]; c; c = c->next)
+	  for (ci = vecsub[d]; ci; ci = gfc_constructor_next (ci))
 	    {
-	      if (mpz_cmp (c->expr->value.integer, upper->value.integer) > 0
-		  || mpz_cmp (c->expr->value.integer,
+	      if (mpz_cmp (ci->expr->value.integer, upper->value.integer) > 0
+		  || mpz_cmp (ci->expr->value.integer,
 			      lower->value.integer) < 0)
 		{
 		  gfc_error ("index in dimension %d is out of bounds "
@@ -1346,9 +1498,8 @@ find_array_section (gfc_expr *expr, gfc_ref *ref)
       mpz_mul (delta_mpz, delta_mpz, tmp_mpz);
     }
 
-  mpz_init (index);
   mpz_init (ptr);
-  cons = base;
+  cons = gfc_constructor_first (base);
 
   /* Now clock through the array reference, calculating the index in
      the source constructor and transferring the elements to the new
@@ -1374,11 +1525,11 @@ find_array_section (gfc_expr *expr, gfc_ref *ref)
 	    {
 	      gcc_assert(vecsub[d]);
 
-	      if (!vecsub[d]->next)
-		vecsub[d] = ref->u.ar.start[d]->value.constructor;
+	      if (!gfc_constructor_next (vecsub[d]))
+		vecsub[d] = gfc_constructor_first (ref->u.ar.start[d]->value.constructor);
 	      else
 		{
-		  vecsub[d] = vecsub[d]->next;
+		  vecsub[d] = gfc_constructor_next (vecsub[d]);
 		  incr_ctr = false;
 		}
 	      mpz_set (ctr[d], vecsub[d]->expr->value.integer);
@@ -1396,25 +1547,13 @@ find_array_section (gfc_expr *expr, gfc_ref *ref)
 	    }
 	}
 
-      /* There must be a better way of dealing with negative strides
-	 than resetting the index and the constructor pointer!  */ 
-      if (mpz_cmp (ptr, index) < 0)
-	{
-	  mpz_set_ui (index, 0);
-	  cons = base;
-	}
-
-      while (cons && cons->next && mpz_cmp (ptr, index) > 0)
-	{
-	  mpz_add_ui (index, index, one);
-	  cons = cons->next;
-	}
-
-      gfc_append_constructor (expr, gfc_copy_expr (cons->expr));
+      cons = gfc_constructor_lookup (base, mpz_get_ui (ptr));
+      gcc_assert (cons);
+      gfc_constructor_append_expr (&expr->value.constructor,
+				   gfc_copy_expr (cons->expr), NULL);
     }
 
   mpz_clear (ptr);
-  mpz_clear (index);
 
 cleanup:
 
@@ -1429,7 +1568,7 @@ cleanup:
       mpz_clear (ctr[d]);
       mpz_clear (stride[d]);
     }
-  gfc_free_constructor (base);
+  gfc_constructor_free (base);
   return t;
 }
 
@@ -1470,7 +1609,7 @@ find_substring_ref (gfc_expr *p, gfc_expr **newp)
 static gfc_try
 simplify_const_ref (gfc_expr *p)
 {
-  gfc_constructor *cons;
+  gfc_constructor *cons, *c;
   gfc_expr *newp;
   gfc_ref *last_ref;
 
@@ -1510,20 +1649,20 @@ simplify_const_ref (gfc_expr *p)
 	      if (p->ref->next != NULL
 		  && (p->ts.type == BT_CHARACTER || p->ts.type == BT_DERIVED))
 		{
-		  cons = p->value.constructor;
-		  for (; cons; cons = cons->next)
+		  for (c = gfc_constructor_first (p->value.constructor);
+		       c; c = gfc_constructor_next (c))
 		    {
-		      cons->expr->ref = gfc_copy_ref (p->ref->next);
-		      if (simplify_const_ref (cons->expr) == FAILURE)
+		      c->expr->ref = gfc_copy_ref (p->ref->next);
+		      if (simplify_const_ref (c->expr) == FAILURE)
 			return FAILURE;
 		    }
 
 		  if (p->ts.type == BT_DERIVED
 			&& p->ref->next
-			&& p->value.constructor)
+			&& (c = gfc_constructor_first (p->value.constructor)))
 		    {
 		      /* There may have been component references.  */
-		      p->ts = p->value.constructor->expr->ts;
+		      p->ts = c->expr->ts;
 		    }
 
 		  last_ref = p->ref;
@@ -1537,9 +1676,9 @@ simplify_const_ref (gfc_expr *p)
 			 character length according to the first element
 			 (as all should have the same length).  */
 		      int string_len;
-		      if (p->value.constructor)
+		      if ((c = gfc_constructor_first (p->value.constructor)))
 			{
-			  const gfc_expr* first = p->value.constructor->expr;
+			  const gfc_expr* first = c->expr;
 			  gcc_assert (first->expr_type == EXPR_CONSTANT);
 			  gcc_assert (first->ts.type == BT_CHARACTER);
 			  string_len = first->value.character.length;
@@ -1553,7 +1692,9 @@ simplify_const_ref (gfc_expr *p)
 		      else
 			gfc_free_expr (p->ts.u.cl->length);
 
-		      p->ts.u.cl->length = gfc_int_expr (string_len);
+		      p->ts.u.cl->length
+			= gfc_get_int_expr (gfc_default_integer_kind,
+					    NULL, string_len);
 		    }
 		}
 	      gfc_free_ref_list (p->ref);
@@ -1724,7 +1865,9 @@ gfc_simplify_expr (gfc_expr *p, int type)
 	  p->value.character.string = s;
 	  p->value.character.length = end - start;
 	  p->ts.u.cl = gfc_new_charlen (gfc_current_ns, NULL);
-	  p->ts.u.cl->length = gfc_int_expr (p->value.character.length);
+	  p->ts.u.cl->length = gfc_get_int_expr (gfc_default_integer_kind,
+						 NULL,
+						 p->value.character.length);
 	  gfc_free_ref_list (p->ref);
 	  p->ref = NULL;
 	  p->expr_type = EXPR_CONSTANT;
@@ -1812,10 +1955,12 @@ static gfc_try
 scalarize_intrinsic_call (gfc_expr *e)
 {
   gfc_actual_arglist *a, *b;
-  gfc_constructor *args[5], *ctor, *new_ctor;
+  gfc_constructor_base ctor;
+  gfc_constructor *args[5];
+  gfc_constructor *ci, *new_ctor;
   gfc_expr *expr, *old;
   int n, i, rank[5], array_arg;
-
+  
   /* Find which, if any, arguments are arrays.  Assume that the old
      expression carries the type information and that the first arg
      that is an array expression carries all the shape information.*/
@@ -1836,9 +1981,8 @@ scalarize_intrinsic_call (gfc_expr *e)
 
   old = gfc_copy_expr (e);
 
-  gfc_free_constructor (expr->value.constructor);
+  gfc_constructor_free (expr->value.constructor);
   expr->value.constructor = NULL;
-
   expr->ts = old->ts;
   expr->where = old->where;
   expr->expr_type = EXPR_ARRAY;
@@ -1858,7 +2002,7 @@ scalarize_intrinsic_call (gfc_expr *e)
 	{
 	  rank[n] = a->expr->rank;
 	  ctor = a->expr->symtree->n.sym->value->value.constructor;
-	  args[n] = gfc_copy_constructor (ctor);
+	  args[n] = gfc_constructor_first (ctor);
 	}
       else if (a->expr && a->expr->expr_type == EXPR_ARRAY)
 	{
@@ -1866,10 +2010,12 @@ scalarize_intrinsic_call (gfc_expr *e)
 	    rank[n] = a->expr->rank;
 	  else
 	    rank[n] = 1;
-	  args[n] = gfc_copy_constructor (a->expr->value.constructor);
+	  ctor = gfc_constructor_copy (a->expr->value.constructor);
+	  args[n] = gfc_constructor_first (ctor);
 	}
       else
 	args[n] = NULL;
+
       n++;
     }
 
@@ -1877,53 +2023,46 @@ scalarize_intrinsic_call (gfc_expr *e)
   /* Using the array argument as the master, step through the array
      calling the function for each element and advancing the array
      constructors together.  */
-  ctor = args[array_arg - 1];
-  new_ctor = NULL;
-  for (; ctor; ctor = ctor->next)
+  for (ci = args[array_arg - 1]; ci; ci = gfc_constructor_next (ci))
     {
-	  if (expr->value.constructor == NULL)
-	    expr->value.constructor
-		= new_ctor = gfc_get_constructor ();
+      new_ctor = gfc_constructor_append_expr (&expr->value.constructor,
+					      gfc_copy_expr (old), NULL);
+
+      gfc_free_actual_arglist (new_ctor->expr->value.function.actual);
+      a = NULL;
+      b = old->value.function.actual;
+      for (i = 0; i < n; i++)
+	{
+	  if (a == NULL)
+	    new_ctor->expr->value.function.actual
+			= a = gfc_get_actual_arglist ();
 	  else
 	    {
-	      new_ctor->next = gfc_get_constructor ();
-	      new_ctor = new_ctor->next;
+	      a->next = gfc_get_actual_arglist ();
+	      a = a->next;
 	    }
-	  new_ctor->expr = gfc_copy_expr (old);
-	  gfc_free_actual_arglist (new_ctor->expr->value.function.actual);
-	  a = NULL;
-	  b = old->value.function.actual;
-	  for (i = 0; i < n; i++)
-	    {
-	      if (a == NULL)
-		new_ctor->expr->value.function.actual
-			= a = gfc_get_actual_arglist ();
-	      else
-		{
-		  a->next = gfc_get_actual_arglist ();
-		  a = a->next;
-		}
-	      if (args[i])
-		a->expr = gfc_copy_expr (args[i]->expr);
-	      else
-		a->expr = gfc_copy_expr (b->expr);
 
-	      b = b->next;
-	    }
+	  if (args[i])
+	    a->expr = gfc_copy_expr (args[i]->expr);
+	  else
+	    a->expr = gfc_copy_expr (b->expr);
 
-	  /* Simplify the function calls.  If the simplification fails, the
-	     error will be flagged up down-stream or the library will deal
-	     with it.  */
-	  gfc_simplify_expr (new_ctor->expr, 0);
+	  b = b->next;
+	}
 
-	  for (i = 0; i < n; i++)
-	    if (args[i])
-	      args[i] = args[i]->next;
+      /* Simplify the function calls.  If the simplification fails, the
+	 error will be flagged up down-stream or the library will deal
+	 with it.  */
+      gfc_simplify_expr (new_ctor->expr, 0);
 
-	  for (i = 1; i < n; i++)
-	    if (rank[i] && ((args[i] != NULL && args[array_arg - 1] == NULL)
-			 || (args[i] == NULL && args[array_arg - 1] != NULL)))
-	      goto compliance;
+      for (i = 0; i < n; i++)
+	if (args[i])
+	  args[i] = gfc_constructor_next (args[i]);
+
+      for (i = 1; i < n; i++)
+	if (rank[i] && ((args[i] != NULL && args[array_arg - 1] == NULL)
+			|| (args[i] == NULL && args[array_arg - 1] != NULL)))
+	  goto compliance;
     }
 
   free_expr0 (e);
@@ -2063,21 +2202,22 @@ not_numeric:
 static gfc_try
 check_alloc_comp_init (gfc_expr *e)
 {
-  gfc_component *c;
+  gfc_component *comp;
   gfc_constructor *ctor;
 
   gcc_assert (e->expr_type == EXPR_STRUCTURE);
   gcc_assert (e->ts.type == BT_DERIVED);
 
-  for (c = e->ts.u.derived->components, ctor = e->value.constructor;
-       c; c = c->next, ctor = ctor->next)
+  for (comp = e->ts.u.derived->components,
+       ctor = gfc_constructor_first (e->value.constructor);
+       comp; comp = comp->next, ctor = gfc_constructor_next (ctor))
     {
-      if (c->attr.allocatable
+      if (comp->attr.allocatable
           && ctor->expr->expr_type != EXPR_NULL)
         {
 	  gfc_error("Invalid initialization expression for ALLOCATABLE "
 	            "component '%s' in structure constructor at %L",
-	            c->name, &ctor->expr->where);
+	            comp->name, &ctor->expr->where);
 	  return FAILURE;
 	}
     }
@@ -3444,45 +3584,38 @@ gfc_check_assign_symbol (gfc_symbol *sym, gfc_expr *rvalue)
 gfc_expr *
 gfc_default_initializer (gfc_typespec *ts)
 {
-  gfc_constructor *tail;
   gfc_expr *init;
-  gfc_component *c;
+  gfc_component *comp;
 
   /* See if we have a default initializer.  */
-  for (c = ts->u.derived->components; c; c = c->next)
-    if (c->initializer || c->attr.allocatable)
+  for (comp = ts->u.derived->components; comp; comp = comp->next)
+    if (comp->initializer || comp->attr.allocatable)
       break;
 
-  if (!c)
+  if (!comp)
     return NULL;
 
-  /* Build the constructor.  */
-  init = gfc_get_expr ();
-  init->expr_type = EXPR_STRUCTURE;
+  init = gfc_get_structure_constructor_expr (ts->type, ts->kind,
+					     &ts->u.derived->declared_at);
   init->ts = *ts;
-  init->where = ts->u.derived->declared_at;
 
-  tail = NULL;
-  for (c = ts->u.derived->components; c; c = c->next)
+  for (comp = ts->u.derived->components; comp; comp = comp->next)
     {
-      if (tail == NULL)
-	init->value.constructor = tail = gfc_get_constructor ();
-      else
-	{
-	  tail->next = gfc_get_constructor ();
-	  tail = tail->next;
-	}
+      gfc_constructor *ctor = gfc_constructor_get();
 
-      if (c->initializer)
-	tail->expr = gfc_copy_expr (c->initializer);
+      if (comp->initializer)
+	ctor->expr = gfc_copy_expr (comp->initializer);
 
-      if (c->attr.allocatable)
+      if (comp->attr.allocatable)
 	{
-	  tail->expr = gfc_get_expr ();
-	  tail->expr->expr_type = EXPR_NULL;
-	  tail->expr->ts = c->ts;
+	  ctor->expr = gfc_get_expr ();
+	  ctor->expr->expr_type = EXPR_NULL;
+	  ctor->expr->ts = comp->ts;
 	}
+
+      gfc_constructor_append (&init->value.constructor, ctor);
     }
+
   return init;
 }
 
@@ -3611,7 +3744,8 @@ gfc_traverse_expr (gfc_expr *expr, gfc_symbol *sym,
 
     case EXPR_STRUCTURE:
     case EXPR_ARRAY:
-      for (c = expr->value.constructor; c; c = c->next)
+      for (c = gfc_constructor_first (expr->value.constructor);
+	   c; c = gfc_constructor_next (c))
 	{
 	  if (gfc_traverse_expr (c->expr, sym, func, f))
 	    return true;