OSDN Git Service

2010-04-06 Tobias Burnus <burnus@net-b.de>
authorburnus <burnus@138bc75d-0d04-0410-961f-82ee72b054a4>
Tue, 6 Apr 2010 18:16:13 +0000 (18:16 +0000)
committerMasaki Muranaka <monaka@monami-software.com>
Sun, 23 May 2010 00:46:43 +0000 (09:46 +0900)
        PR fortran/18918
        * array.c (gfc_free_array_spec,gfc_resolve_array_spec,
        match_array_element_spec,gfc_copy_array_spec,
        gfc_compare_array_spec): Include corank.
        (match_array_element_spec,gfc_set_array_spec): Support codimension.
        * decl.c (build_sym,build_struct,variable_decl,
        match_attr_spec,attr_decl1,cray_pointer_decl,
        gfc_match_volatile): Add codimension.
        (gfc_match_codimension): New function.
        * dump-parse-tree.c (show_array_spec,show_attr): Support
        * codimension.
        * gfortran.h (symbol_attribute,gfc_array_spec): Ditto.
        (gfc_add_codimension): New function prototype.
        * match.h (gfc_match_codimension): New function prototype.
        (gfc_match_array_spec): Update prototype
        * match.c (gfc_match_common): Update gfc_match_array_spec call.
        * module.c (MOD_VERSION): Bump.
        (mio_symbol_attribute): Support coarray attributes.
        (mio_array_spec): Add corank support.
        * parse.c (decode_specification_statement,decode_statement,
        parse_derived): Add coarray support.
        * resolve.c (resolve_formal_arglist, was_declared,
        is_non_constant_shape_array, resolve_fl_variable,
        resolve_fl_derived, resolve_symbol): Add coarray support.
        * symbol.c (check_conflict, gfc_add_volatile, gfc_copy_attr,
        gfc_build_class_symbol): Add coarray support.
        (gfc_add_codimension): New function.

2010-04-06  Tobias Burnus  <burnus@net-b.de>

        PR fortran/18918
        * gfortran.dg/coarray_4.f90: New test.
        * gfortran.dg/coarray_5.f90: New test.
        * gfortran.dg/coarray_6.f90: New test.

git-svn-id: svn+ssh://gcc.gnu.org/svn/gcc/trunk@158012 138bc75d-0d04-0410-961f-82ee72b054a4

13 files changed:
gcc/fortran/ChangeLog
gcc/fortran/array.c
gcc/fortran/decl.c
gcc/fortran/gfortran.h
gcc/fortran/match.c
gcc/fortran/match.h
gcc/fortran/module.c
gcc/fortran/parse.c
gcc/fortran/resolve.c
gcc/fortran/symbol.c
gcc/testsuite/ChangeLog
gcc/testsuite/gfortran.dg/coarray_4.f90
gcc/testsuite/gfortran.dg/coarray_6.f90

index f68a6ca..f6cfcfd 100644 (file)
@@ -1,6 +1,35 @@
 2010-04-06  Tobias Burnus  <burnus@net-b.de>
 
        PR fortran/18918
+       * array.c (gfc_free_array_spec,gfc_resolve_array_spec,
+       match_array_element_spec,gfc_copy_array_spec,
+       gfc_compare_array_spec): Include corank.
+       (match_array_element_spec,gfc_set_array_spec): Support codimension.
+       * decl.c (build_sym,build_struct,variable_decl,
+       match_attr_spec,attr_decl1,cray_pointer_decl,
+       gfc_match_volatile): Add codimension.
+       (gfc_match_codimension): New function.
+       * dump-parse-tree.c (show_array_spec,show_attr): Support codimension.
+       * gfortran.h (symbol_attribute,gfc_array_spec): Ditto.
+       (gfc_add_codimension): New function prototype.
+       * match.h (gfc_match_codimension): New function prototype.
+       (gfc_match_array_spec): Update prototype
+       * match.c (gfc_match_common): Update gfc_match_array_spec call.
+       * module.c (MOD_VERSION): Bump.
+       (mio_symbol_attribute): Support coarray attributes.
+       (mio_array_spec): Add corank support.
+       * parse.c (decode_specification_statement,decode_statement,
+       parse_derived): Add coarray support.
+       * resolve.c (resolve_formal_arglist, was_declared,
+       is_non_constant_shape_array, resolve_fl_variable,
+       resolve_fl_derived, resolve_symbol): Add coarray support.
+       * symbol.c (check_conflict, gfc_add_volatile, gfc_copy_attr,
+       gfc_build_class_symbol): Add coarray support.
+       (gfc_add_codimension): New function.
+
+2010-04-06  Tobias Burnus  <burnus@net-b.de>
+
+       PR fortran/18918
        * iso-fortran-env.def: Add the integer parameters atomic_int_kind,
        atomic_logical_kind, iostat_inquire_internal_unit, stat_locked,
        stat_locked_other_image, stat_stopped_image and stat_unlocked of
index 3ffc397..4b2ccf6 100644 (file)
@@ -23,7 +23,6 @@ along with GCC; see the file COPYING3.  If not see
 #include "system.h"
 #include "gfortran.h"
 #include "match.h"
-#include "constructor.h"
 
 /**************** Array reference matching subroutines *****************/
 
@@ -62,13 +61,12 @@ gfc_copy_array_ref (gfc_array_ref *src)
    expression.  */
 
 static match
-match_subscript (gfc_array_ref *ar, int init, bool match_star)
+match_subscript (gfc_array_ref *ar, int init)
 {
   match m;
-  bool star = false;
   int i;
 
-  i = ar->dimen + ar->codimen;
+  i = ar->dimen;
 
   ar->c_where[i] = gfc_current_locus;
   ar->start[i] = ar->end[i] = ar->stride[i] = NULL;
@@ -83,12 +81,9 @@ match_subscript (gfc_array_ref *ar, int init, bool match_star)
     goto end_element;
 
   /* Get start element.  */
-  if (match_star && (m = gfc_match_char ('*')) == MATCH_YES)
-    star = true;
-
-  if (!star && init)
+  if (init)
     m = gfc_match_init_expr (&ar->start[i]);
-  else if (!star)
+  else
     m = gfc_match_expr (&ar->start[i]);
 
   if (m == MATCH_NO)
@@ -97,22 +92,14 @@ match_subscript (gfc_array_ref *ar, int init, bool match_star)
     return MATCH_ERROR;
 
   if (gfc_match_char (':') == MATCH_NO)
-    goto matched;
-
-  if (star)
-    {
-      gfc_error ("Unexpected '*' in coarray subscript at %C");
-      return MATCH_ERROR;
-    }
+    return MATCH_YES;
 
   /* Get an optional end element.  Because we've seen the colon, we
      definitely have a range along this dimension.  */
 end_element:
   ar->dimen_type[i] = DIMEN_RANGE;
 
-  if (match_star && (m = gfc_match_char ('*')) == MATCH_YES)
-    star = true;
-  else if (init)
+  if (init)
     m = gfc_match_init_expr (&ar->end[i]);
   else
     m = gfc_match_expr (&ar->end[i]);
@@ -123,12 +110,6 @@ end_element:
   /* See if we have an optional stride.  */
   if (gfc_match_char (':') == MATCH_YES)
     {
-      if (star)
-       {
-         gfc_error ("Strides not allowed in coarray subscript at %C");
-         return MATCH_ERROR;
-       }
-
       m = init ? gfc_match_init_expr (&ar->stride[i])
               : gfc_match_expr (&ar->stride[i]);
 
@@ -138,10 +119,6 @@ end_element:
        return MATCH_ERROR;
     }
 
-matched:
-  if (star)
-    ar->dimen_type[i] = DIMEN_STAR;
-
   return MATCH_YES;
 }
 
@@ -151,23 +128,14 @@ matched:
    to consist of init expressions.  */
 
 match
-gfc_match_array_ref (gfc_array_ref *ar, gfc_array_spec *as, int init,
-                    int corank)
+gfc_match_array_ref (gfc_array_ref *ar, gfc_array_spec *as, int init)
 {
   match m;
-  bool matched_bracket = false;
 
   memset (ar, '\0', sizeof (ar));
 
   ar->where = gfc_current_locus;
   ar->as = as;
-  ar->type = AR_UNKNOWN;
-
-  if (gfc_match_char ('[') == MATCH_YES)
-    {
-       matched_bracket = true;
-       goto coarray;
-    }
 
   if (gfc_match_char ('(') != MATCH_YES)
     {
@@ -176,73 +144,34 @@ gfc_match_array_ref (gfc_array_ref *ar, gfc_array_spec *as, int init,
       return MATCH_YES;
     }
 
+  ar->type = AR_UNKNOWN;
+
   for (ar->dimen = 0; ar->dimen < GFC_MAX_DIMENSIONS; ar->dimen++)
     {
-      m = match_subscript (ar, init, false);
+      m = match_subscript (ar, init);
       if (m == MATCH_ERROR)
-       return MATCH_ERROR;
+       goto error;
 
       if (gfc_match_char (')') == MATCH_YES)
-       {
-         ar->dimen++;
-         goto coarray;
-       }
+       goto matched;
 
       if (gfc_match_char (',') != MATCH_YES)
        {
          gfc_error ("Invalid form of array reference at %C");
-         return MATCH_ERROR;
+         goto error;
        }
     }
 
   gfc_error ("Array reference at %C cannot have more than %d dimensions",
             GFC_MAX_DIMENSIONS);
-  return MATCH_ERROR;
-
-coarray:
-  if (!matched_bracket && gfc_match_char ('[') != MATCH_YES)
-    {
-      if (ar->dimen > 0)
-       return MATCH_YES;
-      else
-       return MATCH_ERROR;
-    }
-
-  if (gfc_option.coarray == GFC_FCOARRAY_NONE)
-    {
-      gfc_fatal_error ("Coarrays disabled at %C, use -fcoarray= to enable");
-      return MATCH_ERROR;
-    }
-
-  if (corank == 0)
-    {
-       gfc_error ("Unexpected coarray designator at %C");
-       return MATCH_ERROR;
-    }
-
-  for (ar->codimen = 0; ar->codimen + ar->dimen < GFC_MAX_DIMENSIONS; ar->codimen++)
-    {
-      m = match_subscript (ar, init, ar->codimen == (corank - 1));
-      if (m == MATCH_ERROR)
-       return MATCH_ERROR;
 
-      if (gfc_match_char (']') == MATCH_YES)
-       {
-         ar->codimen++;
-         return MATCH_YES;
-       }
-
-      if (gfc_match_char (',') != MATCH_YES)
-       {
-         gfc_error ("Invalid form of coarray reference at %C");
-         return MATCH_ERROR;
-       }
-    }
-
-  gfc_error ("Array reference at %C cannot have more than %d dimensions",
-            GFC_MAX_DIMENSIONS);
+error:
   return MATCH_ERROR;
 
+matched:
+  ar->dimen++;
+
+  return MATCH_YES;
 }
 
 
@@ -366,7 +295,7 @@ match_array_element_spec (gfc_array_spec *as)
 
   if (gfc_match_char ('*') == MATCH_YES)
     {
-      *lower = gfc_get_int_expr (gfc_default_integer_kind, NULL, 1);
+      *lower = gfc_int_expr (1);
       return AS_ASSUMED_SIZE;
     }
 
@@ -383,7 +312,7 @@ match_array_element_spec (gfc_array_spec *as)
 
   if (gfc_match_char (':') == MATCH_NO)
     {
-      *lower = gfc_get_int_expr (gfc_default_integer_kind, NULL, 1);
+      *lower = gfc_int_expr (1);
       return AS_EXPLICIT;
     }
 
@@ -413,6 +342,7 @@ match
 gfc_match_array_spec (gfc_array_spec **asp, bool match_dim, bool match_codim)
 {
   array_type current_type;
+  array_type coarray_type = AS_UNKNOWN;
   gfc_array_spec *as;
   int i;
  
@@ -529,12 +459,6 @@ coarray:
       == FAILURE)
     goto cleanup;
 
-  if (gfc_option.coarray == GFC_FCOARRAY_NONE)
-    {
-      gfc_fatal_error ("Coarrays disabled at %C, use -fcoarray= to enable");
-      goto cleanup;
-    }
-
   for (;;)
     {
       as->corank++;
@@ -543,10 +467,23 @@ coarray:
       if (current_type == AS_UNKNOWN)
        goto cleanup;
 
+      if (as->rank && as->type != AS_DEFERRED && current_type == AS_DEFERRED)
+       {
+         gfc_error ("Array at %C has non-deferred shape and deferred "
+                    "coshape");
+          goto cleanup;
+       }
+      if (as->rank && as->type == AS_DEFERRED && current_type != AS_DEFERRED)
+       {
+         gfc_error ("Array at %C has deferred shape and non-deferred "
+                    "coshape");
+          goto cleanup;
+       }
+
       if (as->corank == 1)
-       as->cotype = current_type;
+       coarray_type = current_type;
       else
-       switch (as->cotype)
+       switch (coarray_type)
          { /* See how current spec meshes with the existing.  */
            case AS_UNKNOWN:
              goto cleanup;
@@ -554,7 +491,7 @@ coarray:
            case AS_EXPLICIT:
              if (current_type == AS_ASSUMED_SIZE)
                {
-                 as->cotype = AS_ASSUMED_SIZE;
+                 coarray_type = AS_ASSUMED_SIZE;
                  break;
                }
 
@@ -581,7 +518,7 @@ coarray:
 
              if (current_type == AS_ASSUMED_SHAPE)
                {
-                 as->cotype = AS_ASSUMED_SHAPE;
+                 as->type = AS_ASSUMED_SHAPE;
                  break;
                }
 
@@ -616,11 +553,10 @@ coarray:
       goto cleanup;
     }
 
-  if (as->cotype == AS_ASSUMED_SIZE)
-    as->cotype = AS_EXPLICIT;
-
-  if (as->rank == 0)
-    as->type = as->cotype;
+  if (as->rank == 0 && coarray_type == AS_ASSUMED_SIZE)
+    as->type = AS_EXPLICIT;
+  else if (as->rank == 0)
+    as->type = coarray_type;
 
 done:
   if (as->rank == 0 && as->corank == 0)
@@ -636,7 +572,7 @@ done:
       for (i = 0; i < as->rank + as->corank; i++)
        {
          if (as->lower[i] == NULL)
-           as->lower[i] = gfc_get_int_expr (gfc_default_integer_kind, NULL, 1);
+           as->lower[i] = gfc_int_expr (1);
        }
     }
 
@@ -677,13 +613,26 @@ gfc_set_array_spec (gfc_symbol *sym, gfc_array_spec *as, locus *error_loc)
       return SUCCESS;
     }
 
+  if (sym->as->type == AS_DEFERRED && as->type != AS_DEFERRED)
+    {
+      gfc_error ("'%s' at %L has deferred shape and non-deferred coshape",
+                sym->name, error_loc);
+      return FAILURE;
+    }
+
+  if (sym->as->type != AS_DEFERRED && as->type == AS_DEFERRED)
+    {
+      gfc_error ("'%s' at %L has non-deferred shape and deferred coshape",
+                sym->name, error_loc);
+      return FAILURE;
+    }
+
   if (as->corank)
     {
       /* The "sym" has no corank (checked via gfc_add_codimension). Thus
         the codimension is simply added.  */
       gcc_assert (as->rank == 0 && sym->as->corank == 0);
 
-      sym->as->cotype = as->cotype;
       sym->as->corank = as->corank;
       for (i = 0; i < as->corank; i++)
        {
@@ -807,6 +756,151 @@ gfc_compare_array_spec (gfc_array_spec *as1, gfc_array_spec *as2)
 
 /****************** Array constructor functions ******************/
 
+/* Start an array constructor.  The constructor starts with zero
+   elements and should be appended to by gfc_append_constructor().  */
+
+gfc_expr *
+gfc_start_constructor (bt type, int kind, locus *where)
+{
+  gfc_expr *result;
+
+  result = gfc_get_expr ();
+
+  result->expr_type = EXPR_ARRAY;
+  result->rank = 1;
+
+  result->ts.type = type;
+  result->ts.kind = kind;
+  result->where = *where;
+  return result;
+}
+
+
+/* Given an array constructor expression, append the new expression
+   node onto the constructor.  */
+
+void
+gfc_append_constructor (gfc_expr *base, gfc_expr *new_expr)
+{
+  gfc_constructor *c;
+
+  if (base->value.constructor == NULL)
+    base->value.constructor = c = gfc_get_constructor ();
+  else
+    {
+      c = base->value.constructor;
+      while (c->next)
+       c = c->next;
+
+      c->next = gfc_get_constructor ();
+      c = c->next;
+    }
+
+  c->expr = new_expr;
+
+  if (new_expr
+      && (new_expr->ts.type != base->ts.type || new_expr->ts.kind != base->ts.kind))
+    gfc_internal_error ("gfc_append_constructor(): New node has wrong kind");
+}
+
+
+/* Given an array constructor expression, insert the new expression's
+   constructor onto the base's one according to the offset.  */
+
+void
+gfc_insert_constructor (gfc_expr *base, gfc_constructor *c1)
+{
+  gfc_constructor *c, *pre;
+  expr_t type;
+  int t;
+
+  type = base->expr_type;
+
+  if (base->value.constructor == NULL)
+    base->value.constructor = c1;
+  else
+    {
+      c = pre = base->value.constructor;
+      while (c)
+       {
+         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;
+       }
+      else
+       {
+         c1->next = c;
+         base->value.constructor = c1;
+       }
+    }
+}
+
+
+/* Get a new constructor.  */
+
+gfc_constructor *
+gfc_get_constructor (void)
+{
+  gfc_constructor *c;
+
+  c = XCNEW (gfc_constructor);
+  c->expr = NULL;
+  c->iterator = NULL;
+  c->next = NULL;
+  mpz_init_set_si (c->n.offset, 0);
+  mpz_init_set_si (c->repeat, 0);
+  return c;
+}
+
+
+/* Free chains of gfc_constructor structures.  */
+
+void
+gfc_free_constructor (gfc_constructor *p)
+{
+  gfc_constructor *next;
+
+  if (p == NULL)
+    return;
+
+  for (; p; p = next)
+    {
+      next = p->next;
+
+      if (p->expr)
+       gfc_free_expr (p->expr);
+      if (p->iterator != NULL)
+       gfc_free_iterator (p->iterator, 1);
+      mpz_clear (p->n.offset);
+      mpz_clear (p->repeat);
+      gfc_free (p);
+    }
+}
+
 
 /* Given an expression node that might be an array constructor and a
    symbol, make sure that no iterators in this or child constructors
@@ -814,12 +908,11 @@ gfc_compare_array_spec (gfc_array_spec *as1, gfc_array_spec *as2)
    duplicate was found.  */
 
 static int
-check_duplicate_iterator (gfc_constructor_base base, gfc_symbol *master)
+check_duplicate_iterator (gfc_constructor *c, gfc_symbol *master)
 {
-  gfc_constructor *c;
   gfc_expr *e;
 
-  for (c = gfc_constructor_first (base); c; c = gfc_constructor_next (c))
+  for (; c; c = c->next)
     {
       e = c->expr;
 
@@ -844,15 +937,14 @@ check_duplicate_iterator (gfc_constructor_base base, gfc_symbol *master)
 
 
 /* Forward declaration because these functions are mutually recursive.  */
-static match match_array_cons_element (gfc_constructor_base *);
+static match match_array_cons_element (gfc_constructor **);
 
 /* Match a list of array elements.  */
 
 static match
-match_array_list (gfc_constructor_base *result)
+match_array_list (gfc_constructor **result)
 {
-  gfc_constructor_base head;
-  gfc_constructor *p;
+  gfc_constructor *p, *head, *tail, *new_cons;
   gfc_iterator iter;
   locus old_loc;
   gfc_expr *e;
@@ -871,6 +963,8 @@ match_array_list (gfc_constructor_base *result)
   if (m != MATCH_YES)
     goto cleanup;
 
+  tail = head;
+
   if (gfc_match_char (',') != MATCH_YES)
     {
       m = MATCH_NO;
@@ -885,7 +979,7 @@ match_array_list (gfc_constructor_base *result)
       if (m == MATCH_ERROR)
        goto cleanup;
 
-      m = match_array_cons_element (&head);
+      m = match_array_cons_element (&new_cons);
       if (m == MATCH_ERROR)
        goto cleanup;
       if (m == MATCH_NO)
@@ -896,6 +990,9 @@ match_array_list (gfc_constructor_base *result)
          goto cleanup;         /* Could be a complex constant */
        }
 
+      tail->next = new_cons;
+      tail = new_cons;
+
       if (gfc_match_char (',') != MATCH_YES)
        {
          if (n > 2)
@@ -914,13 +1011,19 @@ match_array_list (gfc_constructor_base *result)
       goto cleanup;
     }
 
-  e = gfc_get_array_expr (BT_UNKNOWN, 0, &old_loc);
+  e = gfc_get_expr ();
+  e->expr_type = EXPR_ARRAY;
+  e->where = old_loc;
   e->value.constructor = head;
 
-  p = gfc_constructor_append_expr (result, e, &gfc_current_locus);
+  p = gfc_get_constructor ();
+  p->where = gfc_current_locus;
   p->iterator = gfc_get_iterator ();
   *p->iterator = iter;
 
+  p->expr = e;
+  *result = p;
+
   return MATCH_YES;
 
 syntax:
@@ -928,7 +1031,7 @@ syntax:
   m = MATCH_ERROR;
 
 cleanup:
-  gfc_constructor_free (head);
+  gfc_free_constructor (head);
   gfc_free_iterator (&iter, 0);
   gfc_current_locus = old_loc;
   return m;
@@ -939,8 +1042,9 @@ cleanup:
    single expression or a list of elements.  */
 
 static match
-match_array_cons_element (gfc_constructor_base *result)
+match_array_cons_element (gfc_constructor **result)
 {
+  gfc_constructor *p;
   gfc_expr *expr;
   match m;
 
@@ -952,7 +1056,11 @@ match_array_cons_element (gfc_constructor_base *result)
   if (m != MATCH_YES)
     return m;
 
-  gfc_constructor_append_expr (result, expr, &gfc_current_locus);
+  p = gfc_get_constructor ();
+  p->where = gfc_current_locus;
+  p->expr = expr;
+
+  *result = p;
   return MATCH_YES;
 }
 
@@ -962,7 +1070,7 @@ match_array_cons_element (gfc_constructor_base *result)
 match
 gfc_match_array_constructor (gfc_expr **result)
 {
-  gfc_constructor_base head, new_cons;
+  gfc_constructor *head, *tail, *new_cons;
   gfc_expr *expr;
   gfc_typespec ts;
   locus where;
@@ -986,7 +1094,7 @@ gfc_match_array_constructor (gfc_expr **result)
     end_delim = " /)";
 
   where = gfc_current_locus;
-  head = new_cons = NULL;
+  head = tail = NULL;
   seen_ts = false;
 
   /* Try to match an optional "type-spec ::"  */
@@ -1018,12 +1126,19 @@ gfc_match_array_constructor (gfc_expr **result)
 
   for (;;)
     {
-      m = match_array_cons_element (&head);
+      m = match_array_cons_element (&new_cons);
       if (m == MATCH_ERROR)
        goto cleanup;
       if (m == MATCH_NO)
        goto syntax;
 
+      if (head == NULL)
+       head = new_cons;
+      else
+       tail->next = new_cons;
+
+      tail = new_cons;
+
       if (gfc_match_char (',') == MATCH_NO)
        break;
     }
@@ -1032,19 +1147,24 @@ gfc_match_array_constructor (gfc_expr **result)
     goto syntax;
 
 done:
+  expr = gfc_get_expr ();
+
+  expr->expr_type = EXPR_ARRAY;
+
+  expr->value.constructor = head;
   /* Size must be calculated at resolution time.  */
+
   if (seen_ts)
-    {
-      expr = gfc_get_array_expr (ts.type, ts.kind, &where);
-      expr->ts = ts;
-    }
+    expr->ts = ts;
   else
-    expr = gfc_get_array_expr (BT_UNKNOWN, 0, &where);
-
-  expr->value.constructor = head;
+    expr->ts.type = BT_UNKNOWN;
+  
   if (expr->ts.u.cl)
     expr->ts.u.cl->length_from_typespec = seen_ts;
 
+  expr->where = where;
+  expr->rank = 1;
+
   *result = expr;
   return MATCH_YES;
 
@@ -1052,7 +1172,7 @@ syntax:
   gfc_error ("Syntax error in array constructor at %C");
 
 cleanup:
-  gfc_constructor_free (head);
+  gfc_free_constructor (head);
   return MATCH_ERROR;
 }
 
@@ -1108,12 +1228,11 @@ check_element_type (gfc_expr *expr, bool convert)
 /* Recursive work function for gfc_check_constructor_type().  */
 
 static gfc_try
-check_constructor_type (gfc_constructor_base base, bool convert)
+check_constructor_type (gfc_constructor *c, bool convert)
 {
-  gfc_constructor *c;
   gfc_expr *e;
 
-  for (c = gfc_constructor_first (base); c; c = gfc_constructor_next (c))
+  for (; c; c = c->next)
     {
       e = c->expr;
 
@@ -1172,7 +1291,7 @@ cons_stack;
 
 static cons_stack *base;
 
-static gfc_try check_constructor (gfc_constructor_base, gfc_try (*) (gfc_expr *));
+static gfc_try check_constructor (gfc_constructor *, gfc_try (*) (gfc_expr *));
 
 /* Check an EXPR_VARIABLE expression in a constructor to make sure
    that that variable is an iteration variables.  */
@@ -1198,14 +1317,13 @@ gfc_check_iter_variable (gfc_expr *expr)
    constructor, giving variables with the names of iterators a pass.  */
 
 static gfc_try
-check_constructor (gfc_constructor_base ctor, gfc_try (*check_function) (gfc_expr *))
+check_constructor (gfc_constructor *c, gfc_try (*check_function) (gfc_expr *))
 {
   cons_stack element;
   gfc_expr *e;
   gfc_try t;
-  gfc_constructor *c;
 
-  for (c = gfc_constructor_first (ctor); c; c = gfc_constructor_next (c))
+  for (; c; c = c->next)
     {
       e = c->expr;
 
@@ -1259,13 +1377,14 @@ iterator_stack *iter_stack;
 
 typedef struct
 {
-  gfc_constructor_base base;
+  gfc_constructor *new_head, *new_tail;
   int extract_count, extract_n;
   gfc_expr *extracted;
   mpz_t *count;
 
   mpz_t *offset;
   gfc_component *component;
+  mpz_t *repeat;
 
   gfc_try (*expand_work_function) (gfc_expr *);
 }
@@ -1273,7 +1392,7 @@ expand_info;
 
 static expand_info current_expand;
 
-static gfc_try expand_constructor (gfc_constructor_base);
+static gfc_try expand_constructor (gfc_constructor *);
 
 
 /* Work function that counts the number of elements present in a
@@ -1332,10 +1451,21 @@ extract_element (gfc_expr *e)
 static gfc_try
 expand (gfc_expr *e)
 {
-  gfc_constructor *c = gfc_constructor_append_expr (&current_expand.base,
-                                                   e, &e->where);
+  if (current_expand.new_head == NULL)
+    current_expand.new_head = current_expand.new_tail =
+      gfc_get_constructor ();
+  else
+    {
+      current_expand.new_tail->next = gfc_get_constructor ();
+      current_expand.new_tail = current_expand.new_tail->next;
+    }
+
+  current_expand.new_tail->where = e->where;
+  current_expand.new_tail->expr = e;
 
-  c->n.component = current_expand.component;
+  mpz_set (current_expand.new_tail->n.offset, *current_expand.offset);
+  current_expand.new_tail->n.component = current_expand.component;
+  mpz_set (current_expand.new_tail->repeat, *current_expand.repeat);
   return SUCCESS;
 }
 
@@ -1355,7 +1485,7 @@ gfc_simplify_iterator_var (gfc_expr *e)
   if (p == NULL)
     return;            /* Variable not found */
 
-  gfc_replace_expr (e, gfc_get_int_expr (gfc_default_integer_kind, NULL, 0));
+  gfc_replace_expr (e, gfc_int_expr (0));
 
   mpz_set (e->value.integer, p->value);
 
@@ -1469,12 +1599,11 @@ cleanup:
    passed expression.  */
 
 static gfc_try
-expand_constructor (gfc_constructor_base base)
+expand_constructor (gfc_constructor *c)
 {
-  gfc_constructor *c;
   gfc_expr *e;
 
-  for (c = gfc_constructor_first (base); c; c = gfc_constructor_next(c))
+  for (; c; c = c->next)
     {
       if (c->iterator != NULL)
        {
@@ -1499,8 +1628,9 @@ expand_constructor (gfc_constructor_base base)
          gfc_free_expr (e);
          return FAILURE;
        }
-      current_expand.offset = &c->offset;
+      current_expand.offset = &c->n.offset;
       current_expand.component = c->n.component;
+      current_expand.repeat = &c->repeat;
       if (current_expand.expand_work_function (e) == FAILURE)
        return FAILURE;
     }
@@ -1508,39 +1638,6 @@ expand_constructor (gfc_constructor_base base)
 }
 
 
-/* Given an array expression and an element number (starting at zero),
-   return a pointer to the array element.  NULL is returned if the
-   size of the array has been exceeded.  The expression node returned
-   remains a part of the array and should not be freed.  Access is not
-   efficient at all, but this is another place where things do not
-   have to be particularly fast.  */
-
-static gfc_expr *
-gfc_get_array_element (gfc_expr *array, int element)
-{
-  expand_info expand_save;
-  gfc_expr *e;
-  gfc_try rc;
-
-  expand_save = current_expand;
-  current_expand.extract_n = element;
-  current_expand.expand_work_function = extract_element;
-  current_expand.extracted = NULL;
-  current_expand.extract_count = 0;
-
-  iter_stack = NULL;
-
-  rc = expand_constructor (array->value.constructor);
-  e = current_expand.extracted;
-  current_expand = expand_save;
-
-  if (rc == FAILURE)
-    return NULL;
-
-  return e;
-}
-
-
 /* Top level subroutine for expanding constructors.  We only expand
    constructor if they are small enough.  */
 
@@ -1551,8 +1648,6 @@ gfc_expand_constructor (gfc_expr *e)
   gfc_expr *f;
   gfc_try rc;
 
-  /* If we can successfully get an array element at the max array size then
-     the array is too big to expand, so we just return.  */
   f = gfc_get_array_element (e, gfc_option.flag_max_array_constructor);
   if (f != NULL)
     {
@@ -1560,9 +1655,8 @@ gfc_expand_constructor (gfc_expr *e)
       return SUCCESS;
     }
 
-  /* We now know the array is not too big so go ahead and try to expand it.  */
   expand_save = current_expand;
-  current_expand.base = NULL;
+  current_expand.new_head = current_expand.new_tail = NULL;
 
   iter_stack = NULL;
 
@@ -1570,13 +1664,13 @@ gfc_expand_constructor (gfc_expr *e)
 
   if (expand_constructor (e->value.constructor) == FAILURE)
     {
-      gfc_constructor_free (current_expand.base);
+      gfc_free_constructor (current_expand.new_head);
       rc = FAILURE;
       goto done;
     }
 
-  gfc_constructor_free (e->value.constructor);
-  e->value.constructor = current_expand.base;
+  gfc_free_constructor (e->value.constructor);
+  e->value.constructor = current_expand.new_head;
 
   rc = SUCCESS;
 
@@ -1614,14 +1708,37 @@ gfc_constant_ac (gfc_expr *e)
 {
   expand_info expand_save;
   gfc_try rc;
+  gfc_constructor * con;
+  
+  rc = SUCCESS;
 
-  iter_stack = NULL;
-  expand_save = current_expand;
-  current_expand.expand_work_function = is_constant_element;
+  if (e->value.constructor
+      && e->value.constructor->expr->expr_type == EXPR_ARRAY)
+    {
+      /* Expand the constructor.  */
+      iter_stack = NULL;
+      expand_save = current_expand;
+      current_expand.expand_work_function = is_constant_element;
 
-  rc = expand_constructor (e->value.constructor);
+      rc = expand_constructor (e->value.constructor);
+
+      current_expand = expand_save;
+    }
+  else
+    {
+      /* No need to expand this further.  */
+      for (con = e->value.constructor; con; con = con->next)
+       {
+         if (con->expr->expr_type == EXPR_CONSTANT)
+           continue;
+         else
+           {
+             if (!gfc_is_constant_expr (con->expr))
+               rc = FAILURE;
+           }
+       }
+    }
 
-  current_expand = expand_save;
   if (rc == FAILURE)
     return 0;
 
@@ -1635,12 +1752,11 @@ gfc_constant_ac (gfc_expr *e)
 int
 gfc_expanded_ac (gfc_expr *e)
 {
-  gfc_constructor *c;
+  gfc_constructor *p;
 
   if (e->expr_type == EXPR_ARRAY)
-    for (c = gfc_constructor_first (e->value.constructor);
-        c; c = gfc_constructor_next (c))
-      if (c->iterator != NULL || !gfc_expanded_ac (c->expr))
+    for (p = e->value.constructor; p; p = p->next)
+      if (p->iterator != NULL || !gfc_expanded_ac (p->expr))
        return 0;
 
   return 1;
@@ -1653,20 +1769,19 @@ gfc_expanded_ac (gfc_expr *e)
    be of the same type.  */
 
 static gfc_try
-resolve_array_list (gfc_constructor_base base)
+resolve_array_list (gfc_constructor *p)
 {
   gfc_try t;
-  gfc_constructor *c;
 
   t = SUCCESS;
 
-  for (c = gfc_constructor_first (base); c; c = gfc_constructor_next (c))
+  for (; p; p = p->next)
     {
-      if (c->iterator != NULL
-         && gfc_resolve_iterator (c->iterator, false) == FAILURE)
+      if (p->iterator != NULL
+         && gfc_resolve_iterator (p->iterator, false) == FAILURE)
        t = FAILURE;
 
-      if (gfc_resolve_expr (c->expr) == FAILURE)
+      if (gfc_resolve_expr (p->expr) == FAILURE)
        t = FAILURE;
     }
 
@@ -1689,8 +1804,7 @@ gfc_resolve_character_array_constructor (gfc_expr *expr)
 
   if (expr->ts.u.cl == NULL)
     {
-      for (p = gfc_constructor_first (expr->value.constructor);
-          p; p = gfc_constructor_next (p))
+      for (p = expr->value.constructor; p; p = p->next)
        if (p->expr->ts.u.cl != NULL)
          {
            /* Ensure that if there is a char_len around that it is
@@ -1711,8 +1825,7 @@ got_charlen:
       /* Check that all constant string elements have the same length until
         we reach the end or find a variable-length one.  */
 
-      for (p = gfc_constructor_first (expr->value.constructor);
-          p; p = gfc_constructor_next (p))
+      for (p = expr->value.constructor; p; p = p->next)
        {
          int current_length = -1;
          gfc_ref *ref;
@@ -1759,8 +1872,7 @@ got_charlen:
       gcc_assert (found_length != -1);
 
       /* Update the character length of the array constructor.  */
-      expr->ts.u.cl->length = gfc_get_int_expr (gfc_default_integer_kind,
-                                               NULL, found_length);
+      expr->ts.u.cl->length = gfc_int_expr (found_length);
     }
   else 
     {
@@ -1778,8 +1890,7 @@ got_charlen:
         (without typespec) all elements are verified to have the same length
         anyway.  */
       if (found_length != -1)
-       for (p = gfc_constructor_first (expr->value.constructor);
-            p; p = gfc_constructor_next (p))
+       for (p = expr->value.constructor; p; p = p->next)
          if (p->expr->expr_type == EXPR_CONSTANT)
            {
              gfc_expr *cl = NULL;
@@ -1829,8 +1940,8 @@ gfc_resolve_array_constructor (gfc_expr *expr)
 
 /* Copy an iterator structure.  */
 
-gfc_iterator *
-gfc_copy_iterator (gfc_iterator *src)
+static gfc_iterator *
+copy_iterator (gfc_iterator *src)
 {
   gfc_iterator *dest;
 
@@ -1848,6 +1959,73 @@ gfc_copy_iterator (gfc_iterator *src)
 }
 
 
+/* Copy a constructor structure.  */
+
+gfc_constructor *
+gfc_copy_constructor (gfc_constructor *src)
+{
+  gfc_constructor *dest;
+  gfc_constructor *tail;
+
+  if (src == NULL)
+    return NULL;
+
+  dest = tail = NULL;
+  while (src)
+    {
+      if (dest == NULL)
+       dest = tail = gfc_get_constructor ();
+      else
+       {
+         tail->next = gfc_get_constructor ();
+         tail = tail->next;
+       }
+      tail->where = src->where;
+      tail->expr = gfc_copy_expr (src->expr);
+      tail->iterator = copy_iterator (src->iterator);
+      mpz_set (tail->n.offset, src->n.offset);
+      tail->n.component = src->n.component;
+      mpz_set (tail->repeat, src->repeat);
+      src = src->next;
+    }
+
+  return dest;
+}
+
+
+/* Given an array expression and an element number (starting at zero),
+   return a pointer to the array element.  NULL is returned if the
+   size of the array has been exceeded.  The expression node returned
+   remains a part of the array and should not be freed.  Access is not
+   efficient at all, but this is another place where things do not
+   have to be particularly fast.  */
+
+gfc_expr *
+gfc_get_array_element (gfc_expr *array, int element)
+{
+  expand_info expand_save;
+  gfc_expr *e;
+  gfc_try rc;
+
+  expand_save = current_expand;
+  current_expand.extract_n = element;
+  current_expand.expand_work_function = extract_element;
+  current_expand.extracted = NULL;
+  current_expand.extract_count = 0;
+
+  iter_stack = NULL;
+
+  rc = expand_constructor (array->value.constructor);
+  e = current_expand.extracted;
+  current_expand = expand_save;
+
+  if (rc == FAILURE)
+    return NULL;
+
+  return e;
+}
+
+
 /********* Subroutines for determining the size of an array *********/
 
 /* These are needed just to accommodate RESHAPE().  There are no
@@ -2221,8 +2399,7 @@ gfc_find_array_ref (gfc_expr *e)
 
   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_ELEMENT && ref->u.ar.dimen == 0)))
+       && (ref->u.ar.type == AR_FULL || ref->u.ar.type == AR_SECTION))
       break;
 
   if (ref == NULL)
index 12dcf84..b376192 100644 (file)
@@ -25,7 +25,7 @@ along with GCC; see the file COPYING3.  If not see
 #include "match.h"
 #include "parse.h"
 #include "flags.h"
-#include "constructor.h"
+
 
 /* Macros to access allocate memory for gfc_data_variable,
    gfc_data_value and gfc_data.  */
@@ -570,62 +570,6 @@ cleanup:
 
 /************************ Declaration statements *********************/
 
-
-/* Auxilliary function to merge DIMENSION and CODIMENSION array specs.  */
-
-static void
-merge_array_spec (gfc_array_spec *from, gfc_array_spec *to, bool copy)
-{
-  int i;
-
-  if (to->rank == 0 && from->rank > 0)
-    {
-      to->rank = from->rank;
-      to->type = from->type;
-      to->cray_pointee = from->cray_pointee;
-      to->cp_was_assumed = from->cp_was_assumed;
-
-      for (i = 0; i < to->corank; i++)
-       {
-         to->lower[from->rank + i] = to->lower[i];
-         to->upper[from->rank + i] = to->upper[i];
-       }
-      for (i = 0; i < from->rank; i++)
-       {
-         if (copy)
-           {
-             to->lower[i] = gfc_copy_expr (from->lower[i]);
-             to->upper[i] = gfc_copy_expr (from->upper[i]);
-           }
-         else
-           {
-             to->lower[i] = from->lower[i];
-             to->upper[i] = from->upper[i];
-           }
-       }
-    }
-  else if (to->corank == 0 && from->corank > 0)
-    {
-      to->corank = from->corank;
-      to->cotype = from->cotype;
-
-      for (i = 0; i < from->corank; i++)
-       {
-         if (copy)
-           {
-             to->lower[to->rank + i] = gfc_copy_expr (from->lower[i]);
-             to->upper[to->rank + i] = gfc_copy_expr (from->upper[i]);
-           }
-         else
-           {
-             to->lower[to->rank + i] = from->lower[i];
-             to->upper[to->rank + i] = from->upper[i];
-           }
-       }
-    }
-}
-
-
 /* Match an intent specification.  Since this can only happen after an
    INTENT word, a legal intent-spec must follow.  */
 
@@ -714,7 +658,7 @@ match_char_length (gfc_expr **expr)
       if (gfc_notify_std (GFC_STD_F95_OBS, "Obsolescent feature: "
                          "Old-style character length at %C") == FAILURE)
        return MATCH_ERROR;
-      *expr = gfc_get_int_expr (gfc_default_integer_kind, NULL, length);
+      *expr = gfc_int_expr (length);
       return m;
     }
 
@@ -1160,7 +1104,7 @@ build_sym (const char *name, gfc_charlen *cl,
       sym->attr.class_ok = (sym->attr.dummy
                              || sym->attr.pointer
                              || sym->attr.allocatable) ? 1 : 0;
-      gfc_build_class_symbol (&sym->ts, &sym->attr, &sym->as, false);
+      gfc_build_class_symbol (&sym->ts, &sym->attr, &sym->as);
     }
 
   return SUCCESS;
@@ -1339,18 +1283,13 @@ add_init_expr_to_sym (const char *name, gfc_expr **initp, locus *var_locus)
                  if (init->expr_type == EXPR_CONSTANT)
                    {
                      clen = init->value.character.length;
-                     sym->ts.u.cl->length
-                               = gfc_get_int_expr (gfc_default_integer_kind,
-                                                   NULL, clen);
+                     sym->ts.u.cl->length = gfc_int_expr (clen);
                    }
                  else if (init->expr_type == EXPR_ARRAY)
                    {
-                     gfc_constructor *c;
-                     c = gfc_constructor_first (init->value.constructor);
-                     clen = c->expr->value.character.length;
-                     sym->ts.u.cl->length
-                               = gfc_get_int_expr (gfc_default_integer_kind,
-                                                   NULL, clen);
+                     gfc_expr *p = init->value.constructor->expr;
+                     clen = p->value.character.length;
+                     sym->ts.u.cl->length = gfc_int_expr (clen);
                    }
                  else if (init->ts.u.cl && init->ts.u.cl->length)
                    sym->ts.u.cl->length =
@@ -1361,21 +1300,19 @@ add_init_expr_to_sym (const char *name, gfc_expr **initp, locus *var_locus)
          else if (sym->ts.u.cl->length->expr_type == EXPR_CONSTANT)
            {
              int len = mpz_get_si (sym->ts.u.cl->length->value.integer);
+             gfc_constructor * p;
 
              if (init->expr_type == EXPR_CONSTANT)
                gfc_set_constant_character_len (len, init, -1);
              else if (init->expr_type == EXPR_ARRAY)
                {
-                 gfc_constructor *c;
-
                  /* Build a new charlen to prevent simplification from
                     deleting the length before it is resolved.  */
                  init->ts.u.cl = gfc_new_charlen (gfc_current_ns, NULL);
                  init->ts.u.cl->length = gfc_copy_expr (sym->ts.u.cl->length);
 
-                 for (c = gfc_constructor_first (init->value.constructor);
-                      c; c = gfc_constructor_next (c))
-                   gfc_set_constant_character_len (len, c->expr, -1);
+                 for (p = init->value.constructor; p; p = p->next)
+                   gfc_set_constant_character_len (len, p->expr, -1);
                }
            }
        }
@@ -1399,27 +1336,38 @@ add_init_expr_to_sym (const char *name, gfc_expr **initp, locus *var_locus)
          if (init->ts.is_iso_c)
            sym->ts.f90_type = init->ts.f90_type;
        }
-
+      
       /* Add initializer.  Make sure we keep the ranks sane.  */
       if (sym->attr.dimension && init->rank == 0)
        {
          mpz_t size;
          gfc_expr *array;
+         gfc_constructor *c;
          int n;
          if (sym->attr.flavor == FL_PARAMETER
                && init->expr_type == EXPR_CONSTANT
                && spec_size (sym->as, &size) == SUCCESS
                && mpz_cmp_si (size, 0) > 0)
            {
-             array = gfc_get_array_expr (init->ts.type, init->ts.kind,
-                                         &init->where);
-             for (n = 0; n < (int)mpz_get_si (size); n++)
-               gfc_constructor_append_expr (&array->value.constructor,
-                                            n == 0
-                                               ? init
-                                               : gfc_copy_expr (init),
+             array = gfc_start_constructor (init->ts.type, init->ts.kind,
                                             &init->where);
-               
+
+             array->value.constructor = c = NULL;
+             for (n = 0; n < (int)mpz_get_si (size); n++)
+               {
+                 if (array->value.constructor == NULL)
+                   {
+                     array->value.constructor = c = gfc_get_constructor ();
+                     c->expr = init;
+                   }
+                 else
+                   {
+                     c->next = gfc_get_constructor ();
+                     c = c->next;
+                     c->expr = gfc_copy_expr (init);
+                   }
+               }
+
              array->shape = gfc_get_shape (sym->as->rank);
              for (n = 0; n < sym->as->rank; n++)
                spec_dimen_size (sym->as, n, &array->shape[n]);
@@ -1509,14 +1457,15 @@ build_struct (const char *name, gfc_charlen *cl, gfc_expr **init,
       else if (mpz_cmp (c->ts.u.cl->length->value.integer,
                        c->initializer->ts.u.cl->length->value.integer))
        {
-         gfc_constructor *ctor;
-         ctor = gfc_constructor_first (c->initializer->value.constructor);
+         bool has_ts;
+         gfc_constructor *ctor = c->initializer->value.constructor;
+
+         has_ts = (c->initializer->ts.u.cl
+                   && c->initializer->ts.u.cl->length_from_typespec);
 
          if (ctor)
            {
              int first_len;
-             bool has_ts = (c->initializer->ts.u.cl
-                            && c->initializer->ts.u.cl->length_from_typespec);
 
              /* Remember the length of the first element for checking
                 that all elements *in the constructor* have the same
@@ -1525,12 +1474,11 @@ build_struct (const char *name, gfc_charlen *cl, gfc_expr **init,
              gcc_assert (ctor->expr->ts.type == BT_CHARACTER);
              first_len = ctor->expr->value.character.length;
 
-             for ( ; ctor; ctor = gfc_constructor_next (ctor))
-               if (ctor->expr->expr_type == EXPR_CONSTANT)
+             for (; ctor; ctor = ctor->next)
                {
-                 gfc_set_constant_character_len (len, ctor->expr,
-                                                 has_ts ? -1 : first_len);
-                 ctor->expr->ts.u.cl->length = gfc_copy_expr (c->ts.u.cl->length);
+                 if (ctor->expr->expr_type == EXPR_CONSTANT)
+                   gfc_set_constant_character_len (len, ctor->expr,
+                                                   has_ts ? -1 : first_len);
                }
            }
        }
@@ -1570,7 +1518,7 @@ build_struct (const char *name, gfc_charlen *cl, gfc_expr **init,
 
 scalar:
   if (c->ts.type == BT_CLASS)
-    gfc_build_class_symbol (&c->ts, &c->attr, &c->as, true);
+    gfc_build_class_symbol (&c->ts, &c->attr, &c->as);
 
   return t;
 }
@@ -1582,6 +1530,7 @@ match
 gfc_match_null (gfc_expr **result)
 {
   gfc_symbol *sym;
+  gfc_expr *e;
   match m;
 
   m = gfc_match (" null ( )");
@@ -1603,7 +1552,12 @@ gfc_match_null (gfc_expr **result)
          || gfc_add_function (&sym->attr, sym->name, NULL) == FAILURE))
     return MATCH_ERROR;
 
-  *result = gfc_get_null_expr (&gfc_current_locus);
+  e = gfc_get_expr ();
+  e->where = gfc_current_locus;
+  e->expr_type = EXPR_NULL;
+  e->ts.type = BT_UNKNOWN;
+
+  *result = e;
 
   return MATCH_YES;
 }
@@ -1649,8 +1603,6 @@ variable_decl (int elem)
 
   if (m == MATCH_NO)
     as = gfc_copy_array_spec (current_as);
-  else if (current_as)
-    merge_array_spec (current_as, as, true);
 
   char_len = NULL;
   cl = NULL;
@@ -2299,7 +2251,7 @@ done:
   cl = gfc_new_charlen (gfc_current_ns, NULL);
 
   if (seen_length == 0)
-    cl->length = gfc_get_int_expr (gfc_default_integer_kind, NULL, 1);
+    cl->length = gfc_int_expr (1);
   else
     cl->length = len;
 
@@ -2680,8 +2632,7 @@ gfc_match_implicit (void)
                {
                  ts.kind = gfc_default_character_kind;
                  ts.u.cl = gfc_new_charlen (gfc_current_ns, NULL);
-                 ts.u.cl->length = gfc_get_int_expr (gfc_default_integer_kind,
-                                                     NULL, 1);
+                 ts.u.cl->length = gfc_int_expr (1);
                }
 
              /* Record the Successful match.  */
@@ -3099,27 +3050,27 @@ match_attr_spec (void)
       seen[d]++;
       seen_at[d] = gfc_current_locus;
 
-      if (d == DECL_DIMENSION || d == DECL_CODIMENSION)
+      if (d == DECL_DIMENSION)
        {
-         gfc_array_spec *as = NULL;
-
-         m = gfc_match_array_spec (&as, d == DECL_DIMENSION,
-                                   d == DECL_CODIMENSION);
+         m = gfc_match_array_spec (&current_as, true, false);
 
-         if (current_as == NULL)
-           current_as = as;
-         else if (m == MATCH_YES)
+         if (m == MATCH_NO)
            {
-             merge_array_spec (as, current_as, false);
-             gfc_free (as);
+             gfc_error ("Missing dimension specification at %C");
+             m = MATCH_ERROR;
            }
 
+         if (m == MATCH_ERROR)
+           goto cleanup;
+       }
+
+      if (d == DECL_CODIMENSION)
+       {
+         m = gfc_match_array_spec (&current_as, false, true);
+
          if (m == MATCH_NO)
            {
-             if (d == DECL_CODIMENSION)
-               gfc_error ("Missing codimension specification at %C");
-             else
-               gfc_error ("Missing dimension specification at %C");
+             gfc_error ("Missing codimension specification at %C");
              m = MATCH_ERROR;
            }
 
@@ -7138,7 +7089,12 @@ static gfc_expr *
 enum_initializer (gfc_expr *last_initializer, locus where)
 {
   gfc_expr *result;
-  result = gfc_get_constant_expr (BT_INTEGER, gfc_c_int_kind, &where);
+
+  result = gfc_get_expr ();
+  result->expr_type = EXPR_CONSTANT;
+  result->ts.type = BT_INTEGER;
+  result->ts.kind = gfc_c_int_kind;
+  result->where = where;
 
   mpz_init (result->value.integer);
 
index ec334c5..a2e385d 100644 (file)
@@ -404,7 +404,6 @@ enum gfc_isym_id
   GFC_ISYM_IDATE,
   GFC_ISYM_IEOR,
   GFC_ISYM_IERRNO,
-  GFC_ISYM_IMAGE_INDEX,
   GFC_ISYM_INDEX,
   GFC_ISYM_INT,
   GFC_ISYM_INT2,
@@ -424,7 +423,6 @@ enum gfc_isym_id
   GFC_ISYM_KILL,
   GFC_ISYM_KIND,
   GFC_ISYM_LBOUND,
-  GFC_ISYM_LCOBOUND,
   GFC_ISYM_LEADZ,
   GFC_ISYM_LEN,
   GFC_ISYM_LEN_TRIM,
@@ -511,7 +509,6 @@ enum gfc_isym_id
   GFC_ISYM_SYSTEM_CLOCK,
   GFC_ISYM_TAN,
   GFC_ISYM_TANH,
-  GFC_ISYM_THIS_IMAGE,
   GFC_ISYM_TIME,
   GFC_ISYM_TIME8,
   GFC_ISYM_TINY,
@@ -521,7 +518,6 @@ enum gfc_isym_id
   GFC_ISYM_TRIM,
   GFC_ISYM_TTYNAM,
   GFC_ISYM_UBOUND,
-  GFC_ISYM_UCOBOUND,
   GFC_ISYM_UMASK,
   GFC_ISYM_UNLINK,
   GFC_ISYM_UNPACK,
@@ -567,13 +563,6 @@ typedef enum
 }
 init_local_integer;
 
-typedef enum
-{
-  GFC_FCOARRAY_NONE = 0,
-  GFC_FCOARRAY_SINGLE
-}
-gfc_fcoarray;
-
 /************************* Structures *****************************/
 
 /* Used for keeping things in balanced binary trees.  */
@@ -691,8 +680,7 @@ typedef struct
   unsigned extension:8;                /* extension level of a derived type.  */
   unsigned is_class:1;         /* is a CLASS container.  */
   unsigned class_ok:1;         /* is a CLASS object with correct attributes.  */
-  unsigned vtab:1;             /* is a derived type vtab, pointed to by CLASS objects.  */
-  unsigned vtype:1;            /* is a derived type of a vtab.  */
+  unsigned vtab:1;             /* is a derived type vtab.  */
 
   /* These flags are both in the typespec and attribute.  The attribute
      list is what gets read from/written to a module file.  The typespec
@@ -880,7 +868,7 @@ typedef struct
 {
   int rank;    /* A rank of zero means that a variable is a scalar.  */
   int corank;
-  array_type type, cotype;
+  array_type type;
   struct gfc_expr *lower[GFC_MAX_DIMENSIONS], *upper[GFC_MAX_DIMENSIONS];
 
   /* These two fields are used with the Cray Pointer extension.  */
@@ -1449,15 +1437,13 @@ extern gfc_interface_info current_interface;
 
 enum gfc_array_ref_dimen_type
 {
-  DIMEN_ELEMENT = 1, DIMEN_RANGE, DIMEN_VECTOR, DIMEN_STAR, DIMEN_UNKNOWN
+  DIMEN_ELEMENT = 1, DIMEN_RANGE, DIMEN_VECTOR, DIMEN_UNKNOWN
 };
 
 typedef struct gfc_array_ref
 {
   ar_type type;
   int dimen;                   /* # of components in the reference */
-  int codimen;
-  bool in_allocate;            /* For coarray checks. */
   locus where;
   gfc_array_spec *as;
 
@@ -1616,6 +1602,17 @@ typedef struct gfc_intrinsic_sym
 gfc_intrinsic_sym;
 
 
+typedef struct gfc_class_esym_list
+{
+  gfc_symbol *derived;
+  gfc_symbol *esym;
+  struct gfc_expr *hash_value;
+  struct gfc_class_esym_list *next;
+}
+gfc_class_esym_list;
+
+#define gfc_get_class_esym_list() XCNEW (gfc_class_esym_list)
+
 /* Expression nodes.  The expression node types deserve explanations,
    since the last couple can be easily misconstrued:
 
@@ -1637,8 +1634,6 @@ gfc_intrinsic_sym;
 #define GFC_RND_MODE GMP_RNDN
 #define GFC_MPC_RND_MODE MPC_RNDNN
 
-typedef splay_tree gfc_constructor_base;
-
 typedef struct gfc_expr
 {
   expr_t expr_type;
@@ -1670,6 +1665,9 @@ typedef struct gfc_expr
      a function call in interface.c(gfc_extend_expr).  */
   unsigned int user_operator : 1;
 
+  /* Used to quickly find a given constructor by its offset.  */
+  splay_tree con_by_offset;
+
   /* If an expression comes from a Hollerith constant or compile-time
      evaluation of a transfer statement, it may have a prescribed target-
      memory representation, and these cannot always be backformed from
@@ -1707,6 +1705,7 @@ typedef struct gfc_expr
       const char *name;        /* Points to the ultimate name of the function */
       gfc_intrinsic_sym *isym;
       gfc_symbol *esym;
+      gfc_class_esym_list *class_esym;
     }
     function;
 
@@ -1737,7 +1736,7 @@ typedef struct gfc_expr
     }
     character;
 
-    gfc_constructor_base constructor;
+    struct gfc_constructor *constructor;
   }
   value;
 
@@ -2105,7 +2104,6 @@ typedef struct
   int warn_aliasing;
   int warn_ampersand;
   int warn_conversion;
-  int warn_conversion_extra;
   int warn_implicit_interface;
   int warn_implicit_procedure;
   int warn_line_truncation;
@@ -2117,7 +2115,6 @@ typedef struct
   int warn_character_truncation;
   int warn_array_temp;
   int warn_align_commons;
-  int warn_unused_dummy_argument;
   int max_errors;
 
   int flag_all_intrinsics;
@@ -2161,7 +2158,6 @@ typedef struct
 
   int fpe;
   int rtcheck;
-  gfc_fcoarray coarray;
 
   int warn_std;
   int allow_std;
@@ -2176,19 +2172,19 @@ extern gfc_option_t gfc_option;
 /* Constructor nodes for array and structure constructors.  */
 typedef struct gfc_constructor
 {
-  gfc_constructor_base base;
-  mpz_t offset;               /* Offset within a constructor, used as
-                                key within base. */
-
   gfc_expr *expr;
   gfc_iterator *iterator;
   locus where;
-
-  union
+  struct gfc_constructor *next;
+  struct
   {
-     gfc_component *component; /* Record the component being initialized.  */
+    mpz_t offset; /* Record the offset of array element which appears in
+                     data statement like "data a(5)/4/".  */
+    gfc_component *component; /* Record the component being initialized.  */
   }
   n;
+  mpz_t repeat; /* Record the repeat number of initial values in data
+                 statement like "data a/5*10/".  */
 }
 gfc_constructor;
 
@@ -2312,7 +2308,7 @@ int get_c_kind (const char *, CInteropKind_t *);
 
 /* options.c */
 unsigned int gfc_init_options (unsigned int, const char **);
-int gfc_handle_option (size_t, const char *, int, int);
+int gfc_handle_option (size_t, const char *, int);
 bool gfc_post_options (const char **);
 
 /* f95-lang.c */
@@ -2514,11 +2510,22 @@ void gfc_free_dt_list (void);
 gfc_gsymbol *gfc_get_gsymbol (const char *);
 gfc_gsymbol *gfc_find_gsymbol (gfc_gsymbol *, const char *);
 
+gfc_try gfc_build_class_symbol (gfc_typespec *, symbol_attribute *,
+                               gfc_array_spec **);
+gfc_symbol *gfc_find_derived_vtab (gfc_symbol *);
 gfc_typebound_proc* gfc_get_typebound_proc (void);
 gfc_symbol* gfc_get_derived_super_type (gfc_symbol*);
 gfc_symbol* gfc_get_ultimate_derived_super_type (gfc_symbol*);
 bool gfc_type_is_extension_of (gfc_symbol *, gfc_symbol *);
 bool gfc_type_compatible (gfc_typespec *, gfc_typespec *);
+gfc_symtree* gfc_find_typebound_proc (gfc_symbol*, gfc_try*,
+                                     const char*, bool, locus*);
+gfc_symtree* gfc_find_typebound_user_op (gfc_symbol*, gfc_try*,
+                                        const char*, bool, locus*);
+gfc_typebound_proc* gfc_find_typebound_intrinsic_op (gfc_symbol*, gfc_try*,
+                                                    gfc_intrinsic_op, bool,
+                                                    locus*);
+gfc_symtree* gfc_get_tbp_symtree (gfc_symtree**, const char*);
 
 void gfc_copy_formal_args (gfc_symbol *, gfc_symbol *);
 void gfc_copy_formal_args_intr (gfc_symbol *, gfc_intrinsic_sym *);
@@ -2528,8 +2535,8 @@ void gfc_free_finalizer (gfc_finalizer *el); /* Needed in resolve.c, too  */
 
 gfc_try gfc_check_symbol_typed (gfc_symbol*, gfc_namespace*, bool, locus);
 
-/* intrinsic.c -- true if working in an init-expr, false otherwise.  */
-extern bool gfc_init_expr_flag;
+/* intrinsic.c */
+extern int gfc_init_expr;
 
 /* Given a symbol that we have decided is intrinsic, mark it as such
    by placing it into a special module that is otherwise impossible to
@@ -2584,6 +2591,7 @@ gfc_actual_arglist *gfc_copy_actual_arglist (gfc_actual_arglist *);
 const char *gfc_extract_int (gfc_expr *, int *);
 bool is_subref_array (gfc_expr *);
 
+void gfc_add_component_ref (gfc_expr *, const char *);
 gfc_expr *gfc_build_conversion (gfc_expr *);
 void gfc_free_ref_list (gfc_ref *);
 void gfc_type_convert_binary (gfc_expr *, int);
@@ -2592,18 +2600,10 @@ gfc_try gfc_simplify_expr (gfc_expr *, int);
 int gfc_has_vector_index (gfc_expr *);
 
 gfc_expr *gfc_get_expr (void);
-gfc_expr *gfc_get_array_expr (bt type, int kind, locus *);
-gfc_expr *gfc_get_null_expr (locus *);
-gfc_expr *gfc_get_operator_expr (locus *, gfc_intrinsic_op,gfc_expr *, gfc_expr *);
-gfc_expr *gfc_get_structure_constructor_expr (bt, int, locus *);
-gfc_expr *gfc_get_constant_expr (bt, int, locus *);
-gfc_expr *gfc_get_character_expr (int, locus *, const char *, int len);
-gfc_expr *gfc_get_int_expr (int, locus *, int);
-gfc_expr *gfc_get_logical_expr (int, locus *, bool);
-gfc_expr *gfc_get_iokind_expr (locus *, io_kind);
-
 void gfc_free_expr (gfc_expr *);
 void gfc_replace_expr (gfc_expr *, gfc_expr *);
+gfc_expr *gfc_int_expr (int);
+gfc_expr *gfc_logical_expr (int, locus *);
 mpz_t *gfc_copy_shape (mpz_t *, int);
 mpz_t *gfc_copy_shape_excluding (mpz_t *, int, gfc_expr *);
 gfc_expr *gfc_copy_expr (gfc_expr *);
@@ -2619,7 +2619,6 @@ gfc_try gfc_check_assign (gfc_expr *, gfc_expr *, int);
 gfc_try gfc_check_pointer_assign (gfc_expr *, gfc_expr *);
 gfc_try gfc_check_assign_symbol (gfc_symbol *, gfc_expr *);
 
-bool gfc_has_default_initializer (gfc_symbol *);
 gfc_expr *gfc_default_initializer (gfc_typespec *);
 gfc_expr *gfc_get_variable_expr (gfc_symtree *);
 
@@ -2635,11 +2634,6 @@ void gfc_expr_replace_comp (gfc_expr *, gfc_component *);
 
 bool gfc_is_proc_ptr_comp (gfc_expr *, gfc_component **);
 
-bool gfc_is_coindexed (gfc_expr *);
-bool gfc_has_ultimate_allocatable (gfc_expr *);
-bool gfc_has_ultimate_pointer (gfc_expr *);
-
-
 /* st.c */
 extern gfc_code new_st;
 
@@ -2668,8 +2662,6 @@ bool gfc_type_is_extensible (gfc_symbol *sym);
 
 
 /* array.c */
-gfc_iterator *gfc_copy_iterator (gfc_iterator *);
-
 void gfc_free_array_spec (gfc_array_spec *);
 gfc_array_ref *gfc_copy_array_ref (gfc_array_ref *);
 
@@ -2679,6 +2671,9 @@ gfc_try gfc_resolve_array_spec (gfc_array_spec *, int);
 
 int gfc_compare_array_spec (gfc_array_spec *, gfc_array_spec *);
 
+gfc_expr *gfc_start_constructor (bt, int, locus *);
+void gfc_append_constructor (gfc_expr *, gfc_expr *);
+void gfc_free_constructor (gfc_constructor *);
 void gfc_simplify_iterator_var (gfc_expr *);
 gfc_try gfc_expand_constructor (gfc_expr *);
 int gfc_constant_ac (gfc_expr *);
@@ -2688,10 +2683,14 @@ gfc_try gfc_resolve_array_constructor (gfc_expr *);
 gfc_try gfc_check_constructor_type (gfc_expr *);
 gfc_try gfc_check_iter_variable (gfc_expr *);
 gfc_try gfc_check_constructor (gfc_expr *, gfc_try (*)(gfc_expr *));
+gfc_constructor *gfc_copy_constructor (gfc_constructor *);
+gfc_expr *gfc_get_array_element (gfc_expr *, int);
 gfc_try gfc_array_size (gfc_expr *, mpz_t *);
 gfc_try gfc_array_dimen_size (gfc_expr *, int, mpz_t *);
 gfc_try gfc_array_ref_shape (gfc_array_ref *, mpz_t *);
 gfc_array_ref *gfc_find_array_ref (gfc_expr *);
+void gfc_insert_constructor (gfc_expr *, gfc_constructor *);
+gfc_constructor *gfc_get_constructor (void);
 tree gfc_conv_array_initializer (tree type, gfc_expr *);
 gfc_try spec_size (gfc_array_spec *, mpz_t *);
 gfc_try spec_dimen_size (gfc_array_spec *, int, mpz_t *);
@@ -2775,19 +2774,4 @@ int gfc_is_data_pointer (gfc_expr *);
 /* check.c */
 gfc_try gfc_check_same_strlen (const gfc_expr*, const gfc_expr*, const char*);
 
-/* class.c */
-void gfc_add_component_ref (gfc_expr *, const char *);
-gfc_expr *gfc_class_null_initializer (gfc_typespec *);
-gfc_try gfc_build_class_symbol (gfc_typespec *, symbol_attribute *,
-                               gfc_array_spec **, bool);
-gfc_symbol *gfc_find_derived_vtab (gfc_symbol *, bool);
-gfc_symtree* gfc_find_typebound_proc (gfc_symbol*, gfc_try*,
-                                     const char*, bool, locus*);
-gfc_symtree* gfc_find_typebound_user_op (gfc_symbol*, gfc_try*,
-                                        const char*, bool, locus*);
-gfc_typebound_proc* gfc_find_typebound_intrinsic_op (gfc_symbol*, gfc_try*,
-                                                    gfc_intrinsic_op, bool,
-                                                    locus*);
-gfc_symtree* gfc_get_tbp_symtree (gfc_symtree**, const char*);
-
 #endif /* GCC_GFORTRAN_H  */
index 48bb733..e719628 100644 (file)
@@ -3562,7 +3562,7 @@ gfc_match_common (void)
 
          /* Deal with an optional array specification after the
             symbol name.  */
-         m = gfc_match_array_spec (&as);
+         m = gfc_match_array_spec (&as, true, true);
          if (m == MATCH_ERROR)
            goto cleanup;
 
index 67e7741..7a0f847 100644 (file)
@@ -216,7 +216,7 @@ match gfc_match_init_expr (gfc_expr **);
 
 /* array.c.  */
 match gfc_match_array_spec (gfc_array_spec **, bool, bool);
-match gfc_match_array_ref (gfc_array_ref *, gfc_array_spec *, int, int);
+match gfc_match_array_ref (gfc_array_ref *, gfc_array_spec *, int);
 match gfc_match_array_constructor (gfc_expr **);
 
 /* interface.c.  */
index 666fd84..5c574bb 100644 (file)
@@ -78,7 +78,7 @@ along with GCC; see the file COPYING3.  If not see
 
 /* Don't put any single quote (') in MOD_VERSION, 
    if yout want it to be recognized.  */
-#define MOD_VERSION "4"
+#define MOD_VERSION "5"
 
 
 /* Structure that describes a position within a module file.  */
@@ -1672,7 +1672,8 @@ typedef enum
   AB_CRAY_POINTER, AB_CRAY_POINTEE, AB_THREADPRIVATE, AB_ALLOC_COMP,
   AB_POINTER_COMP, AB_PRIVATE_COMP, AB_VALUE, AB_VOLATILE, AB_PROTECTED,
   AB_IS_BIND_C, AB_IS_C_INTEROP, AB_IS_ISO_C, AB_ABSTRACT, AB_ZERO_COMP,
-  AB_IS_CLASS, AB_PROCEDURE, AB_PROC_POINTER, AB_ASYNCHRONOUS
+  AB_IS_CLASS, AB_PROCEDURE, AB_PROC_POINTER, AB_ASYNCHRONOUS, AB_CODIMENSION,
+  AB_COARRAY_COMP
 }
 ab_attribute;
 
@@ -1681,6 +1682,7 @@ static const mstring attr_bits[] =
     minit ("ALLOCATABLE", AB_ALLOCATABLE),
     minit ("ASYNCHRONOUS", AB_ASYNCHRONOUS),
     minit ("DIMENSION", AB_DIMENSION),
+    minit ("CODIMENSION", AB_CODIMENSION),
     minit ("EXTERNAL", AB_EXTERNAL),
     minit ("INTRINSIC", AB_INTRINSIC),
     minit ("OPTIONAL", AB_OPTIONAL),
@@ -1708,6 +1710,7 @@ static const mstring attr_bits[] =
     minit ("IS_ISO_C", AB_IS_ISO_C),
     minit ("VALUE", AB_VALUE),
     minit ("ALLOC_COMP", AB_ALLOC_COMP),
+    minit ("COARRAY_COMP", AB_COARRAY_COMP),
     minit ("POINTER_COMP", AB_POINTER_COMP),
     minit ("PRIVATE_COMP", AB_PRIVATE_COMP),
     minit ("ZERO_COMP", AB_ZERO_COMP),
@@ -1798,6 +1801,8 @@ mio_symbol_attribute (symbol_attribute *attr)
        MIO_NAME (ab_attribute) (AB_ASYNCHRONOUS, attr_bits);
       if (attr->dimension)
        MIO_NAME (ab_attribute) (AB_DIMENSION, attr_bits);
+      if (attr->codimension)
+       MIO_NAME (ab_attribute) (AB_CODIMENSION, attr_bits);
       if (attr->external)
        MIO_NAME (ab_attribute) (AB_EXTERNAL, attr_bits);
       if (attr->intrinsic)
@@ -1864,6 +1869,8 @@ mio_symbol_attribute (symbol_attribute *attr)
        MIO_NAME (ab_attribute) (AB_POINTER_COMP, attr_bits);
       if (attr->private_comp)
        MIO_NAME (ab_attribute) (AB_PRIVATE_COMP, attr_bits);
+      if (attr->coarray_comp)
+       MIO_NAME (ab_attribute) (AB_COARRAY_COMP, attr_bits);
       if (attr->zero_comp)
        MIO_NAME (ab_attribute) (AB_ZERO_COMP, attr_bits);
       if (attr->is_class)
@@ -1897,6 +1904,9 @@ mio_symbol_attribute (symbol_attribute *attr)
            case AB_DIMENSION:
              attr->dimension = 1;
              break;
+           case AB_CODIMENSION:
+             attr->codimension = 1;
+             break;
            case AB_EXTERNAL:
              attr->external = 1;
              break;
@@ -1984,6 +1994,9 @@ mio_symbol_attribute (symbol_attribute *attr)
            case AB_ALLOC_COMP:
              attr->alloc_comp = 1;
              break;
+           case AB_COARRAY_COMP:
+             attr->coarray_comp = 1;
+             break;
            case AB_POINTER_COMP:
              attr->pointer_comp = 1;
              break;
@@ -2131,9 +2144,10 @@ mio_array_spec (gfc_array_spec **asp)
     }
 
   mio_integer (&as->rank);
+  mio_integer (&as->corank);
   as->type = MIO_NAME (array_type) (as->type, array_spec_types);
 
-  for (i = 0; i < as->rank; i++)
+  for (i = 0; i < as->rank + as->corank; i++)
     {
       mio_expr (&as->lower[i]);
       mio_expr (&as->upper[i]);
index dfc5893..b68afba 100644 (file)
@@ -1968,12 +1968,14 @@ parse_derived_contains (void)
 static void
 parse_derived (void)
 {
-  int compiling_type, seen_private, seen_sequence, seen_component;
+  int compiling_type, seen_private, seen_sequence, seen_component, error_flag;
   gfc_statement st;
   gfc_state_data s;
   gfc_symbol *sym;
   gfc_component *c;
 
+  error_flag = 0;
+
   accept_statement (ST_DERIVED_DECL);
   push_state (&s, COMP_DERIVED, gfc_new_block);
 
@@ -2000,15 +2002,18 @@ parse_derived (void)
 
        case ST_FINAL:
          gfc_error ("FINAL declaration at %C must be inside CONTAINS");
+         error_flag = 1;
          break;
 
        case ST_END_TYPE:
 endType:
          compiling_type = 0;
 
-         if (!seen_component)
-           gfc_notify_std (GFC_STD_F2003, "Fortran 2003: Derived type "
-                           "definition at %C without components");
+         if (!seen_component
+             && (gfc_notify_std (GFC_STD_F2003, "Fortran 2003: Derived type "
+                                "definition at %C without components")
+                 == FAILURE))
+           error_flag = 1;
 
          accept_statement (ST_END_TYPE);
          break;
@@ -2018,6 +2023,7 @@ endType:
            {
              gfc_error ("PRIVATE statement in TYPE at %C must be inside "
                         "a MODULE");
+             error_flag = 1;
              break;
            }
 
@@ -2025,11 +2031,15 @@ endType:
            {
              gfc_error ("PRIVATE statement at %C must precede "
                         "structure components");
+             error_flag = 1;
              break;
            }
 
          if (seen_private)
-           gfc_error ("Duplicate PRIVATE statement at %C");
+           {
+             gfc_error ("Duplicate PRIVATE statement at %C");
+             error_flag = 1;
+           }
 
          s.sym->component_access = ACCESS_PRIVATE;
 
@@ -2042,6 +2052,7 @@ endType:
            {
              gfc_error ("SEQUENCE statement at %C must precede "
                         "structure components");
+             error_flag = 1;
              break;
            }
 
@@ -2052,6 +2063,7 @@ endType:
          if (seen_sequence)
            {
              gfc_error ("Duplicate SEQUENCE statement at %C");
+             error_flag = 1;
            }
 
          seen_sequence = 1;
@@ -2060,12 +2072,14 @@ endType:
          break;
 
        case ST_CONTAINS:
-         gfc_notify_std (GFC_STD_F2003,
-                         "Fortran 2003:  CONTAINS block in derived type"
-                         " definition at %C");
+         if (gfc_notify_std (GFC_STD_F2003,
+                             "Fortran 2003:  CONTAINS block in derived type"
+                             " definition at %C") == FAILURE)
+           error_flag = 1;
 
          accept_statement (ST_CONTAINS);
-         parse_derived_contains ();
+         if (parse_derived_contains ())
+           error_flag = 1;
          goto endType;
 
        default:
@@ -2101,8 +2115,7 @@ endType:
        sym->attr.proc_pointer_comp = 1;
 
       /* Looking for coarray components.  */
-      if (c->attr.codimension
-         || (c->attr.coarray_comp && !c->attr.pointer && !c->attr.allocatable))
+      if (c->attr.codimension || c->attr.coarray_comp)
        sym->attr.coarray_comp = 1;
 
       /* Look for private components.  */
@@ -2124,11 +2137,14 @@ endType:
 static void
 parse_enum (void)
 {
+  int error_flag;
   gfc_statement st;
   int compiling_enum;
   gfc_state_data s;
   int seen_enumerator = 0;
 
+  error_flag = 0;
+
   push_state (&s, COMP_ENUM, gfc_new_block);
 
   compiling_enum = 1;
@@ -2150,7 +2166,10 @@ parse_enum (void)
        case ST_END_ENUM:
          compiling_enum = 0;
          if (!seen_enumerator)
-           gfc_error ("ENUM declaration at %C has no ENUMERATORS");
+           {
+             gfc_error ("ENUM declaration at %C has no ENUMERATORS");
+             error_flag = 1;
+           }
          accept_statement (st);
          break;
 
@@ -2248,9 +2267,9 @@ loop:
     {
       if (current_state == COMP_NONE)
        {
-         if (new_state == COMP_FUNCTION && sym)
+         if (new_state == COMP_FUNCTION)
            gfc_add_function (&sym->attr, sym->name, NULL);
-         else if (new_state == COMP_SUBROUTINE && sym)
+         else if (new_state == COMP_SUBROUTINE)
            gfc_add_subroutine (&sym->attr, sym->name, NULL);
 
          current_state = new_state;
index 8ef347d..55c0d12 100644 (file)
@@ -258,6 +258,14 @@ resolve_formal_arglist (gfc_symbol *proc)
 
       if (gfc_elemental (proc))
        {
+         /* F2008, C1289.  */
+         if (sym->attr.codimension)
+           {
+             gfc_error ("Coarray dummy argument '%s' at %L to elemental "
+                        "procedure", sym->name, &sym->declared_at);
+             continue;
+           }
+
          if (sym->as != NULL)
            {
              gfc_error ("Argument '%s' of elemental procedure at %L must "
@@ -955,7 +963,7 @@ was_declared (gfc_symbol *sym)
   if (a.allocatable || a.dimension || a.dummy || a.external || a.intrinsic
       || a.optional || a.pointer || a.save || a.target || a.volatile_
       || a.value || a.access != ACCESS_UNKNOWN || a.intent != INTENT_UNKNOWN
-      || a.asynchronous)
+      || a.asynchronous || a.codimension)
     return 1;
 
   return 0;
@@ -8691,13 +8699,12 @@ is_non_constant_shape_array (gfc_symbol *sym)
       /* Unfortunately, !gfc_is_compile_time_shape hits a legal case that
         has not been simplified; parameter array references.  Do the
         simplification now.  */
-      for (i = 0; i < sym->as->rank; i++)
+      for (i = 0; i < sym->as->rank + sym->as->corank; i++)
        {
          e = sym->as->lower[i];
          if (e && (resolve_index_expr (e) == FAILURE
                    || !gfc_is_constant_expr (e)))
            not_constant = true;
-
          e = sym->as->upper[i];
          if (e && (resolve_index_expr (e) == FAILURE
                    || !gfc_is_constant_expr (e)))
@@ -9147,7 +9154,7 @@ resolve_fl_variable (gfc_symbol *sym, int mp_flag)
   if (sym->attr.allocatable || sym->attr.external || sym->attr.dummy
       || sym->attr.intrinsic || sym->attr.result)
     no_init_flag = 1;
-  else if (sym->attr.dimension && !sym->attr.pointer
+  else if ((sym->attr.dimension || sym->attr.codimension) && !sym->attr.pointer
           && is_non_constant_shape_array (sym))
     {
       no_init_flag = automatic_flag = 1;
@@ -10431,6 +10438,15 @@ resolve_fl_derived (gfc_symbol *sym)
 
   super_type = gfc_get_derived_super_type (sym);
 
+  /* F2008, C432. */
+  if (super_type && sym->attr.coarray_comp && !super_type->attr.coarray_comp)
+    {
+      gfc_error ("As extending type '%s' at %L has a coarray component, "
+                "parent type '%s' shall also have one", sym->name,
+                &sym->declared_at, super_type->name);
+      return FAILURE;
+    }
+
   /* Ensure the extended type gets resolved before we do.  */
   if (super_type && resolve_fl_derived (super_type) == FAILURE)
     return FAILURE;
@@ -10445,6 +10461,34 @@ resolve_fl_derived (gfc_symbol *sym)
 
   for (c = sym->components; c != NULL; c = c->next)
     {
+      /* F2008, C442.  */
+      if (c->attr.codimension
+         && (!c->attr.allocatable || c->as->type != AS_DEFERRED))
+       {
+         gfc_error ("Coarray component '%s' at %L must be allocatable with "
+                    "deferred shape", c->name, &c->loc);
+         return FAILURE;
+       }
+
+      /* F2008, C443.  */
+      if (c->attr.codimension && c->ts.type == BT_DERIVED
+         && c->ts.u.derived->ts.is_iso_c)
+       {
+         gfc_error ("Component '%s' at %L of TYPE(C_PTR) or TYPE(C_FUNPTR) "
+                    "shall not be a coarray", c->name, &c->loc);
+         return FAILURE;
+       }
+
+      /* F2008, C444.  */
+      if (c->ts.type == BT_DERIVED && c->ts.u.derived->attr.coarray_comp
+         && (c->attr.codimension || c->attr.pointer || c->attr.dimension))
+       {
+         gfc_error ("Component '%s' at %L with coarray component "
+                    "shall be a nonpointer, nonallocatable scalar",
+                    c->name, &c->loc);
+         return FAILURE;
+       }
+
       if (c->attr.proc_pointer && c->ts.interface)
        {
          if (c->ts.interface->attr.procedure)
@@ -11275,6 +11319,57 @@ resolve_symbol (gfc_symbol *sym)
        }
     }
 
+  if (sym->attr.codimension && sym->attr.allocatable
+      && sym->as->type != AS_DEFERRED)
+    gfc_error ("Allocatable coarray variable '%s' at %L must have "
+              "deferred shape", sym->name, &sym->declared_at);
+
+  /* F2008, C526.  */
+  if (((sym->ts.type == BT_DERIVED && sym->ts.u.derived->attr.coarray_comp)
+       || sym->attr.codimension)
+      && sym->attr.result)
+    gfc_error ("Function result '%s' at %L shall not be a coarray or have "
+              "a coarray component", sym->name, &sym->declared_at);
+
+  /* F2008, C524.  */
+  if (sym->attr.codimension && sym->ts.type == BT_DERIVED
+      && sym->ts.u.derived->ts.is_iso_c)
+    gfc_error ("Variable '%s' at %L of TYPE(C_PTR) or TYPE(C_FUNPTR) "
+              "shall not be a coarray", sym->name, &sym->declared_at);
+
+  /* F2008, C525.  */
+  if (sym->ts.type == BT_DERIVED && sym->ts.u.derived->attr.coarray_comp
+      && (sym->attr.codimension || sym->attr.pointer || sym->attr.dimension
+         || sym->attr.allocatable))
+    gfc_error ("Variable '%s' at %L with coarray component "
+              "shall be a nonpointer, nonallocatable scalar",
+              sym->name, &sym->declared_at);
+
+  /* F2008, C526.  The function-result case was handled above.  */
+  if (((sym->ts.type == BT_DERIVED && sym->ts.u.derived->attr.coarray_comp)
+       || sym->attr.codimension)
+      && !(sym->attr.allocatable || sym->attr.dummy || sym->attr.save
+          || sym->ns->proc_name->attr.flavor == FL_MODULE
+          || sym->ns->proc_name->attr.is_main_program
+          || sym->attr.function || sym->attr.result || sym->attr.use_assoc))
+    gfc_error ("Variable '%s' at %L is a coarray or has a coarray "
+              "component and is not ALLOCATABLE, SAVE nor a "
+              "dummy argument", sym->name, &sym->declared_at);
+
+  /* F2008, C541.  */
+  if (((sym->ts.type == BT_DERIVED && sym->ts.u.derived->attr.coarray_comp)
+       || (sym->attr.codimension && sym->attr.allocatable))
+      && sym->attr.dummy && sym->attr.intent == INTENT_OUT)
+    gfc_error ("Variable '%s' at %L is INTENT(OUT) and can thus not be an "
+              "allocatable coarray or have coarray components",
+              sym->name, &sym->declared_at);
+
+  if (sym->attr.codimension && sym->attr.dummy
+      && sym->ns->proc_name && sym->ns->proc_name->attr.is_bind_c)
+    gfc_error ("Coarray dummy variable '%s' at %L not allowed in BIND(C) "
+              "procedure '%s'", sym->name, &sym->declared_at,
+              sym->ns->proc_name->name);
+
   switch (sym->attr.flavor)
     {
     case FL_VARIABLE:
index b719de1..dbbc97c 100644 (file)
@@ -27,7 +27,6 @@ along with GCC; see the file COPYING3.  If not see
 #include "gfortran.h"
 #include "parse.h"
 #include "match.h"
-#include "constructor.h"
 
 
 /* Strings for all symbol attributes.  We use these for dumping the
@@ -3665,7 +3664,6 @@ gen_special_c_interop_ptr (int ptr_id, const char *ptr_name,
 {
   gfc_symtree *tmp_symtree;
   gfc_symbol *tmp_sym;
-  gfc_constructor *c;
 
   tmp_symtree = gfc_find_symtree (gfc_current_ns->sym_root, ptr_name);
         
@@ -3727,11 +3725,10 @@ gen_special_c_interop_ptr (int ptr_id, const char *ptr_name,
   tmp_sym->value->expr_type = EXPR_STRUCTURE;
   tmp_sym->value->ts.type = BT_DERIVED;
   tmp_sym->value->ts.u.derived = tmp_sym->ts.u.derived;
-  gfc_constructor_append_expr (&tmp_sym->value->value.constructor, NULL, NULL);
-  c = gfc_constructor_first (tmp_sym->value->value.constructor);
-  c->expr = gfc_get_expr ();
-  c->expr->expr_type = EXPR_NULL;
-  c->expr->ts.is_iso_c = 1;
+  tmp_sym->value->value.constructor = gfc_get_constructor ();
+  tmp_sym->value->value.constructor->expr = gfc_get_expr ();
+  tmp_sym->value->value.constructor->expr->expr_type = EXPR_NULL;
+  tmp_sym->value->value.constructor->expr->ts.is_iso_c = 1;
   /* Must declare c_null_ptr and c_null_funptr as having the
      PARAMETER attribute so they can be used in init expressions.  */
   tmp_sym->attr.flavor = FL_PARAMETER;
@@ -3937,8 +3934,7 @@ gen_shape_param (gfc_formal_arglist **head,
       param_sym->as->upper[i] = NULL;
     }
   param_sym->as->rank = 1;
-  param_sym->as->lower[0] = gfc_get_int_expr (gfc_default_integer_kind,
-                                             NULL, 1);
+  param_sym->as->lower[0] = gfc_int_expr (1);
 
   /* The extent is unknown until we get it.  The length give us
      the rank the incoming pointer.  */
@@ -4281,8 +4277,7 @@ generate_isocbinding_symbol (const char *mod_name, iso_c_binding_symbol s,
 #define NAMED_CHARKNDCST(a,b,c) case a :
 #include "iso-c-binding.def"
 
-       tmp_sym->value = gfc_get_int_expr (gfc_default_integer_kind, NULL,
-                                          c_interop_kinds_table[s].value);
+       tmp_sym->value = gfc_int_expr (c_interop_kinds_table[s].value);
 
        /* Initialize an integer constant expression node.  */
        tmp_sym->attr.flavor = FL_PARAMETER;
@@ -4312,16 +4307,20 @@ generate_isocbinding_symbol (const char *mod_name, iso_c_binding_symbol s,
 
        /* Initialize an integer constant expression node for the
           length of the character.  */
-       tmp_sym->value = gfc_get_character_expr (gfc_default_character_kind,
-                                                &gfc_current_locus, NULL, 1);
+       tmp_sym->value = gfc_get_expr (); 
+       tmp_sym->value->expr_type = EXPR_CONSTANT;
+       tmp_sym->value->ts.type = BT_CHARACTER;
+       tmp_sym->value->ts.kind = gfc_default_character_kind;
+       tmp_sym->value->where = gfc_current_locus;
        tmp_sym->value->ts.is_c_interop = 1;
        tmp_sym->value->ts.is_iso_c = 1;
        tmp_sym->value->value.character.length = 1;
+       tmp_sym->value->value.character.string = gfc_get_wide_string (2);
        tmp_sym->value->value.character.string[0]
          = (gfc_char_t) c_interop_kinds_table[s].value;
+       tmp_sym->value->value.character.string[1] = '\0';
        tmp_sym->ts.u.cl = gfc_new_charlen (gfc_current_ns, NULL);
-       tmp_sym->ts.u.cl->length = gfc_get_int_expr (gfc_default_integer_kind,
-                                                    NULL, 1);
+       tmp_sym->ts.u.cl->length = gfc_int_expr (1);
 
        /* May not need this in both attr and ts, but do need in
           attr for writing module file.  */
@@ -4699,3 +4698,344 @@ gfc_type_compatible (gfc_typespec *ts1, gfc_typespec *ts2)
   else
     return 0;
 }
+
+
+/* Build a polymorphic CLASS entity, using the symbol that comes from
+   build_sym. A CLASS entity is represented by an encapsulating type,
+   which contains the declared type as '$data' component, plus a pointer
+   component '$vptr' which determines the dynamic type.  */
+
+gfc_try
+gfc_build_class_symbol (gfc_typespec *ts, symbol_attribute *attr,
+                       gfc_array_spec **as)
+{
+  char name[GFC_MAX_SYMBOL_LEN + 5];
+  gfc_symbol *fclass;
+  gfc_symbol *vtab;
+  gfc_component *c;
+
+  /* Determine the name of the encapsulating type.  */
+  if ((*as) && (*as)->rank && attr->allocatable)
+    sprintf (name, ".class.%s.%d.a", ts->u.derived->name, (*as)->rank);
+  else if ((*as) && (*as)->rank)
+    sprintf (name, ".class.%s.%d", ts->u.derived->name, (*as)->rank);
+  else if (attr->allocatable)
+    sprintf (name, ".class.%s.a", ts->u.derived->name);
+  else
+    sprintf (name, ".class.%s", ts->u.derived->name);
+
+  gfc_find_symbol (name, ts->u.derived->ns, 0, &fclass);
+  if (fclass == NULL)
+    {
+      gfc_symtree *st;
+      /* If not there, create a new symbol.  */
+      fclass = gfc_new_symbol (name, ts->u.derived->ns);
+      st = gfc_new_symtree (&ts->u.derived->ns->sym_root, name);
+      st->n.sym = fclass;
+      gfc_set_sym_referenced (fclass);
+      fclass->refs++;
+      fclass->ts.type = BT_UNKNOWN;
+      fclass->attr.abstract = ts->u.derived->attr.abstract;
+      if (ts->u.derived->f2k_derived)
+       fclass->f2k_derived = gfc_get_namespace (NULL, 0);
+      if (gfc_add_flavor (&fclass->attr, FL_DERIVED,
+         NULL, &gfc_current_locus) == FAILURE)
+       return FAILURE;
+
+      /* Add component '$data'.  */
+      if (gfc_add_component (fclass, "$data", &c) == FAILURE)
+       return FAILURE;
+      c->ts = *ts;
+      c->ts.type = BT_DERIVED;
+      c->attr.access = ACCESS_PRIVATE;
+      c->ts.u.derived = ts->u.derived;
+      c->attr.class_pointer = attr->pointer;
+      c->attr.pointer = attr->pointer || attr->dummy;
+      c->attr.allocatable = attr->allocatable;
+      c->attr.dimension = attr->dimension;
+      c->attr.codimension = attr->codimension;
+      c->attr.abstract = ts->u.derived->attr.abstract;
+      c->as = (*as);
+      c->initializer = gfc_get_expr ();
+      c->initializer->expr_type = EXPR_NULL;
+
+      /* Add component '$vptr'.  */
+      if (gfc_add_component (fclass, "$vptr", &c) == FAILURE)
+       return FAILURE;
+      c->ts.type = BT_DERIVED;
+      vtab = gfc_find_derived_vtab (ts->u.derived);
+      gcc_assert (vtab);
+      c->ts.u.derived = vtab->ts.u.derived;
+      c->attr.pointer = 1;
+      c->initializer = gfc_get_expr ();
+      c->initializer->expr_type = EXPR_NULL;
+    }
+
+  /* Since the extension field is 8 bit wide, we can only have
+     up to 255 extension levels.  */
+  if (ts->u.derived->attr.extension == 255)
+    {
+      gfc_error ("Maximum extension level reached with type '%s' at %L",
+                ts->u.derived->name, &ts->u.derived->declared_at);
+      return FAILURE;
+    }
+    
+  fclass->attr.extension = ts->u.derived->attr.extension + 1;
+  fclass->attr.is_class = 1;
+  ts->u.derived = fclass;
+  attr->allocatable = attr->pointer = attr->dimension = 0;
+  (*as) = NULL;  /* XXX */
+  return SUCCESS;
+}
+
+
+/* Find the symbol for a derived type's vtab.  */
+
+gfc_symbol *
+gfc_find_derived_vtab (gfc_symbol *derived)
+{
+  gfc_namespace *ns;
+  gfc_symbol *vtab = NULL, *vtype = NULL;
+  char name[2 * GFC_MAX_SYMBOL_LEN + 8];
+
+  ns = gfc_current_ns;
+
+  for (; ns; ns = ns->parent)
+    if (!ns->parent)
+      break;
+
+  if (ns)
+    {
+      sprintf (name, "vtab$%s", derived->name);
+      gfc_find_symbol (name, ns, 0, &vtab);
+
+      if (vtab == NULL)
+       {
+         gfc_get_symbol (name, ns, &vtab);
+         vtab->ts.type = BT_DERIVED;
+         vtab->attr.flavor = FL_VARIABLE;
+         vtab->attr.target = 1;
+         vtab->attr.save = SAVE_EXPLICIT;
+         vtab->attr.vtab = 1;
+         vtab->attr.access = ACCESS_PRIVATE;
+         vtab->refs++;
+         gfc_set_sym_referenced (vtab);
+         sprintf (name, "vtype$%s", derived->name);
+         
+         gfc_find_symbol (name, ns, 0, &vtype);
+         if (vtype == NULL)
+           {
+             gfc_component *c;
+             gfc_symbol *parent = NULL, *parent_vtab = NULL;
+
+             gfc_get_symbol (name, ns, &vtype);
+             if (gfc_add_flavor (&vtype->attr, FL_DERIVED,
+                                 NULL, &gfc_current_locus) == FAILURE)
+               return NULL;
+             vtype->refs++;
+             gfc_set_sym_referenced (vtype);
+             vtype->attr.access = ACCESS_PRIVATE;
+
+             /* Add component '$hash'.  */
+             if (gfc_add_component (vtype, "$hash", &c) == FAILURE)
+               return NULL;
+             c->ts.type = BT_INTEGER;
+             c->ts.kind = 4;
+             c->attr.access = ACCESS_PRIVATE;
+             c->initializer = gfc_int_expr (derived->hash_value);
+
+             /* Add component '$size'.  */
+             if (gfc_add_component (vtype, "$size", &c) == FAILURE)
+               return NULL;
+             c->ts.type = BT_INTEGER;
+             c->ts.kind = 4;
+             c->attr.access = ACCESS_PRIVATE;
+             /* Remember the derived type in ts.u.derived,
+                so that the correct initializer can be set later on
+                (in gfc_conv_structure).  */
+             c->ts.u.derived = derived;
+             c->initializer = gfc_int_expr (0);
+
+             /* Add component $extends.  */
+             if (gfc_add_component (vtype, "$extends", &c) == FAILURE)
+               return NULL;
+             c->attr.pointer = 1;
+             c->attr.access = ACCESS_PRIVATE;
+             c->initializer = gfc_get_expr ();
+             parent = gfc_get_derived_super_type (derived);
+             if (parent)
+               {
+                 parent_vtab = gfc_find_derived_vtab (parent);
+                 c->ts.type = BT_DERIVED;
+                 c->ts.u.derived = parent_vtab->ts.u.derived;
+                 c->initializer->expr_type = EXPR_VARIABLE;
+                 gfc_find_sym_tree (parent_vtab->name, parent_vtab->ns, 0,
+                                    &c->initializer->symtree);
+               }
+             else
+               {
+                 c->ts.type = BT_DERIVED;
+                 c->ts.u.derived = vtype;
+                 c->initializer->expr_type = EXPR_NULL;
+               }
+           }
+         vtab->ts.u.derived = vtype;
+
+         vtab->value = gfc_default_initializer (&vtab->ts);
+       }
+    }
+
+  return vtab;
+}
+
+
+/* General worker function to find either a type-bound procedure or a
+   type-bound user operator.  */
+
+static gfc_symtree*
+find_typebound_proc_uop (gfc_symbol* derived, gfc_try* t,
+                        const char* name, bool noaccess, bool uop,
+                        locus* where)
+{
+  gfc_symtree* res;
+  gfc_symtree* root;
+
+  /* Set correct symbol-root.  */
+  gcc_assert (derived->f2k_derived);
+  root = (uop ? derived->f2k_derived->tb_uop_root
+             : derived->f2k_derived->tb_sym_root);
+
+  /* Set default to failure.  */
+  if (t)
+    *t = FAILURE;
+
+  /* Try to find it in the current type's namespace.  */
+  res = gfc_find_symtree (root, name);
+  if (res && res->n.tb && !res->n.tb->error)
+    {
+      /* We found one.  */
+      if (t)
+       *t = SUCCESS;
+
+      if (!noaccess && derived->attr.use_assoc
+         && res->n.tb->access == ACCESS_PRIVATE)
+       {
+         if (where)
+           gfc_error ("'%s' of '%s' is PRIVATE at %L",
+                      name, derived->name, where);
+         if (t)
+           *t = FAILURE;
+       }
+
+      return res;
+    }
+
+  /* Otherwise, recurse on parent type if derived is an extension.  */
+  if (derived->attr.extension)
+    {
+      gfc_symbol* super_type;
+      super_type = gfc_get_derived_super_type (derived);
+      gcc_assert (super_type);
+
+      return find_typebound_proc_uop (super_type, t, name,
+                                     noaccess, uop, where);
+    }
+
+  /* Nothing found.  */
+  return NULL;
+}
+
+
+/* Find a type-bound procedure or user operator by name for a derived-type
+   (looking recursively through the super-types).  */
+
+gfc_symtree*
+gfc_find_typebound_proc (gfc_symbol* derived, gfc_try* t,
+                        const char* name, bool noaccess, locus* where)
+{
+  return find_typebound_proc_uop (derived, t, name, noaccess, false, where);
+}
+
+gfc_symtree*
+gfc_find_typebound_user_op (gfc_symbol* derived, gfc_try* t,
+                           const char* name, bool noaccess, locus* where)
+{
+  return find_typebound_proc_uop (derived, t, name, noaccess, true, where);
+}
+
+
+/* Find a type-bound intrinsic operator looking recursively through the
+   super-type hierarchy.  */
+
+gfc_typebound_proc*
+gfc_find_typebound_intrinsic_op (gfc_symbol* derived, gfc_try* t,
+                                gfc_intrinsic_op op, bool noaccess,
+                                locus* where)
+{
+  gfc_typebound_proc* res;
+
+  /* Set default to failure.  */
+  if (t)
+    *t = FAILURE;
+
+  /* Try to find it in the current type's namespace.  */
+  if (derived->f2k_derived)
+    res = derived->f2k_derived->tb_op[op];
+  else  
+    res = NULL;
+
+  /* Check access.  */
+  if (res && !res->error)
+    {
+      /* We found one.  */
+      if (t)
+       *t = SUCCESS;
+
+      if (!noaccess && derived->attr.use_assoc
+         && res->access == ACCESS_PRIVATE)
+       {
+         if (where)
+           gfc_error ("'%s' of '%s' is PRIVATE at %L",
+                      gfc_op2string (op), derived->name, where);
+         if (t)
+           *t = FAILURE;
+       }
+
+      return res;
+    }
+
+  /* Otherwise, recurse on parent type if derived is an extension.  */
+  if (derived->attr.extension)
+    {
+      gfc_symbol* super_type;
+      super_type = gfc_get_derived_super_type (derived);
+      gcc_assert (super_type);
+
+      return gfc_find_typebound_intrinsic_op (super_type, t, op,
+                                             noaccess, where);
+    }
+
+  /* Nothing found.  */
+  return NULL;
+}
+
+
+/* Get a typebound-procedure symtree or create and insert it if not yet
+   present.  This is like a very simplified version of gfc_get_sym_tree for
+   tbp-symtrees rather than regular ones.  */
+
+gfc_symtree*
+gfc_get_tbp_symtree (gfc_symtree **root, const char *name)
+{
+  gfc_symtree *result;
+
+  result = gfc_find_symtree (*root, name);
+  if (!result)
+    {
+      result = gfc_new_symtree (root, name);
+      gcc_assert (result);
+      result->n.tb = NULL;
+    }
+
+  return result;
+}
index 4053293..bcbc8d3 100644 (file)
@@ -1,6 +1,13 @@
 2010-04-06  Tobias Burnus  <burnus@net-b.de>
 
        PR fortran/18918
+       * gfortran.dg/coarray_4.f90: New test.
+       * gfortran.dg/coarray_5.f90: New test.
+       * gfortran.dg/coarray_6.f90: New test.
+
+2010-04-06  Tobias Burnus  <burnus@net-b.de>
+
+       PR fortran/18918
        * gfortran.dg/iso_fortran_env_5.f90: New test.
        * gfortran.dg/iso_fortran_env_6.f90: New test.
 
index 5607ec9..71fbf98 100644 (file)
@@ -1,5 +1,4 @@
 ! { dg-do compile }
-! { dg-options "-fcoarray=single" }
 !
 ! Coarray support -- corank declarations
 ! PR fortran/18918
@@ -49,7 +48,7 @@ subroutine invalid(n)
   integer, save :: hf4(5)[n,*] ! { dg-error "cannot have the SAVE attribute" }
 
   integer, allocatable :: a2[*] ! { dg-error "must have deferred shape" }
-  integer, allocatable :: a3(:)[*] ! { dg-error "must have deferred shape" }
+  integer, allocatable :: a3(:)[*] ! { dg-error "deferred shape and non-deferred coshape" }
   integer, allocatable :: a4[*] ! { dg-error "must have deferred shape" }
 end subroutine invalid
 
index d3c600b..f122fd4 100644 (file)
@@ -1,5 +1,4 @@
 ! { dg-do compile }
-! { dg-options "-fcoarray=single" }
 !
 ! Coarray support -- corank declarations
 ! PR fortran/18918
@@ -52,32 +51,6 @@ function func() result(func2) ! { dg-error "shall not be a coarray or have a coa
   type(t) :: func2
 end function func
 
-subroutine invalid()
-  type t
-    integer, allocatable :: a[:]
-  end type t
-  type t2
-    type(t), allocatable :: b ! { dg-error "nonpointer, nonallocatable scalar" }
-  end type t2
-  type t3
-    type(t), pointer :: c ! { dg-error "nonpointer, nonallocatable scalar" }
-  end type t3
-  type t4
-    type(t) :: d(4) ! { dg-error "nonpointer, nonallocatable scalar" }
-  end type t4
-end subroutine invalid
-
-subroutine valid(a)
-  integer :: a(:)[4,-1:6,4:*]
-  type t
-    integer, allocatable :: a[:]
-  end type t
-  type t2
-    type(t) :: b
-  end type t2
-  type(t2), save :: xt2[*]
-end subroutine valid
-
 program main
   integer :: A[*] ! Valid, implicit SAVE attribute
 end program main