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 05:16:54 +0000 (14:16 +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

12 files changed:
gcc/fortran/ChangeLog
gcc/fortran/array.c
gcc/fortran/decl.c
gcc/fortran/gfortran.h
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..bc4c640 100644 (file)
@@ -413,6 +413,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 +530,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 +538,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 +562,7 @@ coarray:
            case AS_EXPLICIT:
              if (current_type == AS_ASSUMED_SIZE)
                {
-                 as->cotype = AS_ASSUMED_SIZE;
+                 coarray_type = AS_ASSUMED_SIZE;
                  break;
                }
 
@@ -581,7 +589,7 @@ coarray:
 
              if (current_type == AS_ASSUMED_SHAPE)
                {
-                 as->cotype = AS_ASSUMED_SHAPE;
+                 as->type = AS_ASSUMED_SHAPE;
                  break;
                }
 
@@ -616,11 +624,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)
@@ -677,13 +684,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++)
        {
index 12dcf84..c527307 100644 (file)
@@ -3101,18 +3101,7 @@ match_attr_spec (void)
 
       if (d == DECL_DIMENSION || d == DECL_CODIMENSION)
        {
-         gfc_array_spec *as = NULL;
-
-         m = gfc_match_array_spec (&as, d == DECL_DIMENSION,
-                                   d == DECL_CODIMENSION);
-
-         if (current_as == NULL)
-           current_as = as;
-         else if (m == MATCH_YES)
-           {
-             merge_array_spec (as, current_as, false);
-             gfc_free (as);
-           }
+         m = gfc_match_array_spec (&current_as, true, false);
 
          if (m == MATCH_NO)
            {
@@ -3126,6 +3115,20 @@ match_attr_spec (void)
          if (m == MATCH_ERROR)
            goto cleanup;
        }
+
+      if (d == DECL_CODIMENSION)
+       {
+         m = gfc_match_array_spec (&current_as, false, true);
+
+         if (m == MATCH_NO)
+           {
+             gfc_error ("Missing codimension specification at %C");
+             m = MATCH_ERROR;
+           }
+
+         if (m == MATCH_ERROR)
+           goto cleanup;
+       }
     }
 
   /* Since we've seen a double colon, we have to be looking at an
index c14bcce..a1c3cdb 100644 (file)
@@ -880,7 +880,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.  */
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 20e4836..4fad5d2 100644 (file)
@@ -1674,7 +1674,7 @@ typedef enum
   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_CODIMENSION,
-  AB_COARRAY_COMP, AB_VTYPE, AB_VTAB
+  AB_COARRAY_COMP
 }
 ab_attribute;
 
index 9320069..aa16b22 100644 (file)
@@ -2101,8 +2101,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.  */
index 1197792..7bcade3 100644 (file)
@@ -10748,8 +10748,8 @@ resolve_fl_derived (gfc_symbol *sym)
   for (c = sym->components; c != NULL; c = c->next)
     {
       /* F2008, C442.  */
-      if (c->attr.codimension /* FIXME: c->as check due to PR 43412.  */
-         && (!c->attr.allocatable || (c->as && c->as->type != AS_DEFERRED)))
+      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);
@@ -10767,8 +10767,7 @@ resolve_fl_derived (gfc_symbol *sym)
 
       /* F2008, C444.  */
       if (c->ts.type == BT_DERIVED && c->ts.u.derived->attr.coarray_comp
-         && (c->attr.codimension || c->attr.pointer || c->attr.dimension
-             || c->attr.allocatable))
+         && (c->attr.codimension || c->attr.pointer || c->attr.dimension))
        {
          gfc_error ("Component '%s' at %L with coarray component "
                     "shall be a nonpointer, nonallocatable scalar",
@@ -11628,6 +11627,11 @@ 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)
@@ -11659,16 +11663,6 @@ resolve_symbol (gfc_symbol *sym)
     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, C528.  */  /* FIXME: sym->as check due to PR 43412.  */
-  else if (sym->attr.codimension && !sym->attr.allocatable
-      && sym->as && sym->as->cotype == AS_DEFERRED)
-    gfc_error ("Coarray variable '%s' at %L shall not have codimensions with "
-               "deferred shape", sym->name, &sym->declared_at);
-  else if (sym->attr.codimension && sym->attr.allocatable
-      && (sym->as->type != AS_DEFERRED || sym->as->cotype != AS_DEFERRED))
-    gfc_error ("Allocatable coarray variable '%s' at %L must have "
-              "deferred shape", sym->name, &sym->declared_at);
-
 
   /* F2008, C541.  */
   if (((sym->ts.type == BT_DERIVED && sym->ts.u.derived->attr.coarray_comp)
index b719de1..42d7b25 100644 (file)
@@ -4699,3 +4699,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 7faa70e..65526d8 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