This is the mail archive of the fortran@gcc.gnu.org mailing list for the GNU Fortran project.


Index Nav: [Date Index] [Subject Index] [Author Index] [Thread Index]
Message Nav: [Date Prev] [Date Next] [Thread Prev] [Thread Next]
Other format: [Raw text]

Re: [Patch, Fortran] PR41629: [OOP] gimplification error on valid code


> If I did not do any mistake, the patch in
> http://gcc.gnu.org/ml/fortran/2009-10/msg00116.html
> does not apply cleanly after the patch for pr41581.

That's right. Here is an update ...

Cheers,
Janus
Index: gcc/fortran/symbol.c
===================================================================
--- gcc/fortran/symbol.c	(Revision 152720)
+++ gcc/fortran/symbol.c	(Arbeitskopie)
@@ -4588,13 +4588,15 @@ gfc_type_compatible (gfc_typespec *ts1, gfc_typesp
   if ((ts1->type == BT_DERIVED || ts1->type == BT_CLASS)
       && (ts2->type == BT_DERIVED || ts2->type == BT_CLASS))
     {
-      if (ts1->type == BT_CLASS && ts2->type == BT_DERIVED)
-	return gfc_type_is_extension_of (ts1->u.derived->components->ts.u.derived,
-					 ts2->u.derived);
-      else if (ts1->type == BT_CLASS && ts2->type == BT_CLASS)
-	return gfc_type_is_extension_of (ts1->u.derived->components->ts.u.derived,
-					 ts2->u.derived->components->ts.u.derived);
-      else if (ts2->type != BT_CLASS)
+      if (ts1->type == BT_CLASS)
+	{
+	  if (ts1->u.derived->attr.is_class)
+	    ts1 = &ts1->u.derived->components->ts;
+	  if (ts2->u.derived->attr.is_class)
+	    ts2 = &ts2->u.derived->components->ts;
+	  return gfc_type_is_extension_of (ts1->u.derived, ts2->u.derived);
+	}
+      else if (ts1->type == BT_DERIVED && ts2->type == BT_DERIVED)
 	return gfc_compare_derived_types (ts1->u.derived, ts2->u.derived);
       else
 	return 0;
Index: gcc/fortran/decl.c
===================================================================
--- gcc/fortran/decl.c	(Revision 152720)
+++ gcc/fortran/decl.c	(Arbeitskopie)
@@ -1025,89 +1025,6 @@ verify_c_interop_param (gfc_symbol *sym)
 }
 
 
-/* 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 an integer component '$vindex'
-   which determines the dynamic type, and another integer '$size', which
-   contains the size of the dynamic type structure.  */
-
-static gfc_try
-encapsulate_class_symbol (gfc_typespec *ts, symbol_attribute *attr,
-			  gfc_array_spec **as)
-{
-  char name[GFC_MAX_SYMBOL_LEN + 5];
-  gfc_symbol *fclass;
-  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->vindex = ts->u.derived->vindex;
-      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.pointer = attr->pointer || attr->dummy;
-      c->attr.allocatable = attr->allocatable;
-      c->attr.dimension = attr->dimension;
-      c->attr.abstract = ts->u.derived->attr.abstract;
-      c->as = (*as);
-      c->initializer = gfc_get_expr ();
-      c->initializer->expr_type = EXPR_NULL;
-
-      /* Add component '$vindex'.  */
-      if (gfc_add_component (fclass, "$vindex", &c) == FAILURE)
-   	return FAILURE;
-      c->ts.type = BT_INTEGER;
-      c->ts.kind = 4;
-      c->attr.access = ACCESS_PRIVATE;
-      c->initializer = gfc_int_expr (0);
-
-      /* Add component '$size'.  */
-      if (gfc_add_component (fclass, "$size", &c) == FAILURE)
-   	return FAILURE;
-      c->ts.type = BT_INTEGER;
-      c->ts.kind = 4;
-      c->attr.access = ACCESS_PRIVATE;
-      c->initializer = gfc_int_expr (0);
-    }
-
-  fclass->attr.extension = 1;
-  fclass->attr.is_class = 1;
-  ts->u.derived = fclass;
-  attr->allocatable = attr->pointer = attr->dimension = 0;
-  (*as) = NULL;  /* XXX */
-  return SUCCESS;
-}
-
 /* Function called by variable_decl() that adds a name to the symbol table.  */
 
 static gfc_try
@@ -1180,9 +1097,6 @@ build_sym (const char *name, gfc_charlen *cl,
 
   sym->attr.implied_index = 0;
 
-  if (sym->ts.type == BT_CLASS)
-    encapsulate_class_symbol (&sym->ts, &sym->attr, &sym->as);
-
   return SUCCESS;
 }
 
@@ -1554,9 +1468,6 @@ build_struct (const char *name, gfc_charlen *cl, g
 	}
     }
 
-  if (c->ts.type == BT_CLASS)
-    encapsulate_class_symbol (&c->ts, &c->attr, &c->as);
-
   /* Check array components.  */
   if (!c->attr.dimension)
     return SUCCESS;
Index: gcc/fortran/resolve.c
===================================================================
--- gcc/fortran/resolve.c	(Revision 152720)
+++ gcc/fortran/resolve.c	(Arbeitskopie)
@@ -5833,6 +5833,58 @@ gfc_expr_to_initialize (gfc_expr *e)
 }
 
 
+/* Used in resolve_allocate_expr to check that a allocation-object and
+   a source-expr are conformable.  This does not catch all possible 
+   cases; in particular a runtime checking is needed.  */
+
+static gfc_try
+conformable_arrays (gfc_expr *e1, gfc_expr *e2)
+{
+  /* First compare rank.  */
+  if (e2->ref && e1->rank != e2->ref->u.ar.as->rank)
+    {
+      gfc_error ("Source-expr at %L must be scalar or have the "
+		 "same rank as the allocate-object at %L",
+		 &e1->where, &e2->where);
+      return FAILURE;
+    }
+
+  if (e1->shape)
+    {
+      int i;
+      mpz_t s;
+
+      mpz_init (s);
+
+      for (i = 0; i < e1->rank; i++)
+	{
+	  if (e2->ref->u.ar.end[i])
+	    {
+	      mpz_set (s, e2->ref->u.ar.end[i]->value.integer);
+	      mpz_sub (s, s, e2->ref->u.ar.start[i]->value.integer);
+	      mpz_add_ui (s, s, 1);
+	    }
+	  else
+	    {
+	      mpz_set (s, e2->ref->u.ar.start[i]->value.integer);
+	    }
+
+	  if (mpz_cmp (e1->shape[i], s) != 0)
+	    {
+	      gfc_error ("Source-expr at %L and allocate-object at %L must "
+			 "have the same shape", &e1->where, &e2->where);
+	      mpz_clear (s);
+   	      return FAILURE;
+	    }
+	}
+
+      mpz_clear (s);
+    }
+
+  return SUCCESS;
+}
+
+
 /* Resolve the expression in an ALLOCATE statement, doing the additional
    checks to see whether the expression is OK or not.  The expression must
    have a trailing array reference that gives the size of the array.  */
@@ -5932,8 +5984,33 @@ resolve_allocate_expr (gfc_expr *e, gfc_code *code
       return FAILURE;
     }
 
-  if (is_abstract && !code->expr3 && code->ext.alloc.ts.type == BT_UNKNOWN)
+  /* Some checks for the SOURCE tag.  */
+  if (code->expr3)
     {
+      /* Check F03:C631.  */
+      if (!gfc_type_compatible (&e->ts, &code->expr3->ts))
+	{
+	  gfc_error ("Type of entity at %L is type incompatible with "
+		     "source-expr at %L", &e->where, &code->expr3->where);
+	  return FAILURE;
+	}
+
+      /* Check F03:C632 and restriction following Note 6.18.  */
+      if (code->expr3->rank > 0
+	  && conformable_arrays (code->expr3, e) == FAILURE)
+	return FAILURE;
+
+      /* Check F03:C633.  */
+      if (code->expr3->ts.kind != e->ts.kind)
+	{
+	  gfc_error ("The allocate-object at %L and the source-expr at %L "
+		     "shall have the same kind type parameter",
+		     &e->where, &code->expr3->where);
+	  return FAILURE;
+	}
+    }
+  else if (is_abstract && code->ext.alloc.ts.type == BT_UNKNOWN)
+    {
       gcc_assert (e->ts.type == BT_CLASS);
       gfc_error ("Allocating %s of ABSTRACT base type at %L requires a "
 		 "type-spec or SOURCE=", sym->name, &e->where);
@@ -7601,6 +7678,10 @@ resolve_code (gfc_code *code, gfc_namespace *ns)
       if (gfc_resolve_expr (code->expr2) == FAILURE)
 	t = FAILURE;
 
+      if (code->op == EXEC_ALLOCATE
+	  && gfc_resolve_expr (code->expr3) == FAILURE)
+	t = FAILURE;
+
       switch (code->op)
 	{
 	case EXEC_NOP:
@@ -8483,7 +8564,7 @@ resolve_fl_variable_derived (gfc_symbol *sym, int
      associated by the presence of another class I symbol in the same
      namespace.  14.6.1.3 of the standard and the discussion on
      comp.lang.fortran.  */
-  if (sym->ns != sym->ts.u.derived->ns
+  if (sym->ns != sym->ts.u.derived->ns && sym->ns->proc_name
       && sym->ns->proc_name->attr.if_source != IFSRC_IFBODY)
     {
       gfc_symbol *s;
@@ -8519,27 +8600,6 @@ resolve_fl_variable_derived (gfc_symbol *sym, int
       return FAILURE;
     }
 
-  if (sym->ts.type == BT_CLASS)
-    {
-      /* C502.  */
-      if (!gfc_type_is_extensible (sym->ts.u.derived->components->ts.u.derived))
-	{
-	  gfc_error ("Type '%s' of CLASS variable '%s' at %L is not extensible",
-		     sym->ts.u.derived->name, sym->name, &sym->declared_at);
-	  return FAILURE;
-	}
-
-      /* C509.  */
-      if (!(sym->attr.dummy || sym->attr.allocatable || sym->attr.pointer
-	      || sym->ts.u.derived->components->attr.allocatable
-	      || sym->ts.u.derived->components->attr.pointer))
-	{
-	  gfc_error ("CLASS variable '%s' at %L must be dummy, allocatable "
-		     "or pointer", sym->name, &sym->declared_at);
-	  return FAILURE;
-	}
-    }
-
   /* Assign default initializer.  */
   if (!(sym->value || sym->attr.pointer || sym->attr.allocatable)
       && (!no_init_flag || sym->attr.intent == INTENT_OUT))
@@ -9610,6 +9670,9 @@ error:
 }
 
 
+static void resolve_symbol (gfc_symbol *sym);
+
+
 /* Resolve the type-bound procedures for a derived type.  */
 
 static void
@@ -9715,6 +9778,7 @@ resolve_typebound_procedure (gfc_symtree* stree)
 
       /* Now check that the argument-type matches.  */
       gcc_assert (me_arg);
+      resolve_symbol (me_arg);
       if (me_arg->ts.type != BT_CLASS)
 	{
 	  gfc_error ("Non-polymorphic passed-object dummy argument of '%s'"
@@ -9889,9 +9953,98 @@ ensure_not_abstract (gfc_symbol* sub, gfc_symbol*
 }
 
 
-static void resolve_symbol (gfc_symbol *sym);
+/* Build a polymorphic CLASS entity.
+   A CLASS entity is represented by an encapsulating type, which contains the
+   declared type as '$data' component, plus an integer component '$vindex'
+   which determines the dynamic type, and another integer '$size', which
+   contains the size of the dynamic type structure.  */
 
+static gfc_try
+encapsulate_class_symbol (gfc_typespec *ts, symbol_attribute *attr,
+			  gfc_array_spec **as, locus *where)
+{
+  char name[GFC_MAX_SYMBOL_LEN + 5];
+  gfc_symbol *fclass;
+  gfc_component *c;
 
+  /* F03:C502.  */
+  if (!gfc_type_is_extensible (ts->u.derived))
+    {
+      gfc_error ("Type '%s' of CLASS variable at %L is not extensible",
+		 ts->u.derived->name, where);
+      return FAILURE;
+    }
+
+  /* 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->vindex = ts->u.derived->vindex;
+      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.pointer = attr->pointer || attr->dummy;
+      c->attr.allocatable = attr->allocatable;
+      c->attr.dimension = attr->dimension;
+      c->attr.abstract = ts->u.derived->attr.abstract;
+      c->as = (*as);
+      c->initializer = gfc_get_expr ();
+      c->initializer->expr_type = EXPR_NULL;
+
+      /* Add component '$vindex'.  */
+      if (gfc_add_component (fclass, "$vindex", &c) == FAILURE)
+   	return FAILURE;
+      c->ts.type = BT_INTEGER;
+      c->ts.kind = 4;
+      c->attr.access = ACCESS_PRIVATE;
+      c->initializer = gfc_int_expr (0);
+
+      /* Add component '$size'.  */
+      if (gfc_add_component (fclass, "$size", &c) == FAILURE)
+   	return FAILURE;
+      c->ts.type = BT_INTEGER;
+      c->ts.kind = 4;
+      c->attr.access = ACCESS_PRIVATE;
+      c->initializer = gfc_int_expr (0);
+    }
+
+  fclass->attr.extension = 1;
+  fclass->attr.is_class = 1;
+  ts->u.derived = fclass;
+  attr->allocatable = attr->pointer = attr->dimension = 0;
+  (*as) = NULL;  /* XXX */
+  return SUCCESS;
+}
+
+
 /* Resolve the components of a derived type.  */
 
 static gfc_try
@@ -10044,6 +10197,7 @@ resolve_fl_derived (gfc_symbol *sym)
 
 	  /* Now check that the argument-type matches.  */
 	  gcc_assert (me_arg);
+	  resolve_symbol (me_arg);
 	  if ((me_arg->ts.type != BT_DERIVED && me_arg->ts.type != BT_CLASS)
 	      || (me_arg->ts.type == BT_DERIVED && me_arg->ts.u.derived != sym)
 	      || (me_arg->ts.type == BT_CLASS
@@ -10144,7 +10298,8 @@ resolve_fl_derived (gfc_symbol *sym)
 	    }
 	}
 
-      if (c->ts.type == BT_DERIVED && c->attr.pointer
+      if ((c->ts.type == BT_DERIVED || c->ts.type == BT_CLASS)
+	  && c->attr.pointer
 	  && c->ts.u.derived->components == NULL
 	  && !c->ts.u.derived->attr.zero_comp)
 	{
@@ -10154,14 +10309,19 @@ resolve_fl_derived (gfc_symbol *sym)
 	  return FAILURE;
 	}
 
-      /* C437.  */
-      if (c->ts.type == BT_CLASS
-	  && !(c->ts.u.derived->components->attr.pointer
-	       || c->ts.u.derived->components->attr.allocatable))
+      if (c->ts.type == BT_CLASS && !c->ts.u.derived->attr.is_class)
 	{
-	  gfc_error ("Component '%s' with CLASS at %L must be allocatable "
-		     "or pointer", c->name, &c->loc);
-	  return FAILURE;
+	  /* F03:C437.  */
+	  if (!(c->attr.pointer || c->attr.allocatable))
+	    {
+	      gfc_error ("Component '%s' with CLASS at %L must be allocatable "
+			"or pointer", c->name, &c->loc);
+	      return FAILURE;
+	    }
+
+	  if (encapsulate_class_symbol (&c->ts, &c->attr, &c->as, &c->loc)
+	      == FAILURE)
+	    return FAILURE;
 	}
 
       /* Ensure that all the derived type components are put on the
@@ -10766,6 +10926,21 @@ resolve_symbol (gfc_symbol *sym)
       break;
     }
 
+  if (sym->ts.type == BT_CLASS && !sym->ts.u.derived->attr.is_class)
+    {
+      /* F03:C509.  */
+      if (!(sym->attr.dummy || sym->attr.allocatable || sym->attr.pointer))
+	{
+	  gfc_error ("CLASS variable at %L must be dummy, allocatable or "
+		     "pointer", &sym->declared_at);
+	  return;
+	}
+
+      if (encapsulate_class_symbol (&sym->ts, &sym->attr, &sym->as,
+				    &sym->declared_at) == FAILURE)
+	return;
+    }
+
   /* Resolve array specifier. Check as well some constraints
      on COMMON blocks.  */
 
Index: gcc/fortran/match.c
===================================================================
--- gcc/fortran/match.c	(Revision 152720)
+++ gcc/fortran/match.c	(Arbeitskopie)
@@ -2388,58 +2388,6 @@ char_selector:
 }
 
 
-/* Used in gfc_match_allocate to check that a allocation-object and
-   a source-expr are conformable.  This does not catch all possible 
-   cases; in particular a runtime checking is needed.  */
-
-static gfc_try
-conformable_arrays (gfc_expr *e1, gfc_expr *e2)
-{
-  /* First compare rank.  */
-  if (e2->ref && e1->rank != e2->ref->u.ar.as->rank)
-    {
-      gfc_error ("Source-expr at %L must be scalar or have the "
-		 "same rank as the allocate-object at %L",
-		 &e1->where, &e2->where);
-      return FAILURE;
-    }
-
-  if (e1->shape)
-    {
-      int i;
-      mpz_t s;
-
-      mpz_init (s);
-
-      for (i = 0; i < e1->rank; i++)
-	{
-	  if (e2->ref->u.ar.end[i])
-	    {
-	      mpz_set (s, e2->ref->u.ar.end[i]->value.integer);
-	      mpz_sub (s, s, e2->ref->u.ar.start[i]->value.integer);
-	      mpz_add_ui (s, s, 1);
-	    }
-	  else
-	    {
-	      mpz_set (s, e2->ref->u.ar.start[i]->value.integer);
-	    }
-
-	  if (mpz_cmp (e1->shape[i], s) != 0)
-	    {
-	      gfc_error ("Source-expr at %L and allocate-object at %L must "
-			 "have the same shape", &e1->where, &e2->where);
-	      mpz_clear (s);
-   	      return FAILURE;
-	    }
-	}
-
-      mpz_clear (s);
-    }
-
-  return SUCCESS;
-}
-
-
 /* Match an ALLOCATE statement.  */
 
 match
@@ -2537,12 +2485,8 @@ gfc_match_allocate (void)
       b1 = !(tail->expr->ref
 	   && (tail->expr->ref->type == REF_COMPONENT
 		|| tail->expr->ref->type == REF_ARRAY));
-      if (sym && sym->ts.type == BT_CLASS)
-	b2 = !(sym->ts.u.derived->components->attr.allocatable
-	       || sym->ts.u.derived->components->attr.pointer);
-      else
-	b2 = sym && !(sym->attr.allocatable || sym->attr.pointer
-		      || sym->attr.proc_pointer);
+      b2 = sym && !(sym->attr.allocatable || sym->attr.pointer
+		    || sym->attr.proc_pointer);
       b3 = sym && sym->ns && sym->ns->proc_name
 	   && (sym->ns->proc_name->attr.allocatable
 		|| sym->ns->proc_name->attr.pointer
@@ -2620,7 +2564,7 @@ alloc_opt_list:
 	      goto cleanup;
 	    }
 
-	  /* The next 3 conditionals check C631.  */
+	  /* The next 2 conditionals check F03:C631.  */
 	  if (ts.type != BT_UNKNOWN)
 	    {
 	      gfc_error ("SOURCE tag at %L conflicts with the typespec at %L",
@@ -2635,28 +2579,6 @@ alloc_opt_list:
 	      goto cleanup;
             }
 
-	  gfc_resolve_expr (tmp);
-
-	  if (!gfc_type_compatible (&head->expr->ts, &tmp->ts))
-	    {
-	      gfc_error ("Type of entity at %L is type incompatible with "
-			 "source-expr at %L", &head->expr->where, &tmp->where);
-	      goto cleanup;
-	    }
-
-	  /* Check C633.  */
-	  if (tmp->ts.kind != head->expr->ts.kind)
-	    {
-	      gfc_error ("The allocate-object at %L and the source-expr at %L "
-			 "shall have the same kind type parameter",
-			 &head->expr->where, &tmp->where);
-	      goto cleanup;
-	    }
-
-	  /* Check C632 and restriction following Note 6.18.  */
-	  if (tmp->rank > 0 && conformable_arrays (tmp, head->expr) == FAILURE)
-	    goto cleanup;
-
 	  source = tmp;
 	  saw_source = true;
 
@@ -2818,12 +2740,8 @@ gfc_match_deallocate (void)
       b1 = !(tail->expr->ref
 	   && (tail->expr->ref->type == REF_COMPONENT
 	       || tail->expr->ref->type == REF_ARRAY));
-      if (sym && sym->ts.type == BT_CLASS)
-	b2 = !(sym->ts.u.derived->components->attr.allocatable
-	       || sym->ts.u.derived->components->attr.pointer);
-      else
-	b2 = sym && !(sym->attr.allocatable || sym->attr.pointer
-		      || sym->attr.proc_pointer);
+      b2 = sym && !(sym->attr.allocatable || sym->attr.pointer
+		    || sym->attr.proc_pointer);
       if (b1 && b2)
 	{
 	  gfc_error ("Allocate-object at %C is not a nonprocedure pointer "
@@ -4079,6 +3997,7 @@ gfc_match_select_type (void)
       if (gfc_get_sym_tree (name, NULL, &expr1->symtree, false))
 	return MATCH_ERROR;
       expr1->symtree->n.sym->ts = expr2->ts;
+      expr1->symtree->n.sym->attr.pointer = 1;
       expr1->symtree->n.sym->attr.referenced = 1;
     }
   else
@@ -4097,7 +4016,7 @@ gfc_match_select_type (void)
     {
       gfc_error ("Selector in SELECT TYPE at %C is not a named variable; "
 		 "use associate-name=>");
-      return MATCH_ERROR;
+      goto error;
     }
 
   /* Check for F03:C813.  */
@@ -4105,7 +4024,7 @@ gfc_match_select_type (void)
     {
       gfc_error ("Selector shall be polymorphic in SELECT TYPE statement "
 		 "at %C");
-      return MATCH_ERROR;
+      goto error;
     }
 
   new_st.op = EXEC_SELECT_TYPE;
@@ -4116,6 +4035,10 @@ gfc_match_select_type (void)
   select_type_push (expr1->symtree->n.sym);
 
   return MATCH_YES;
+
+error:
+  gfc_current_ns = gfc_current_ns->parent;
+  return MATCH_ERROR;
 }
 
 
Index: gcc/fortran/primary.c
===================================================================
--- gcc/fortran/primary.c	(Revision 152720)
+++ gcc/fortran/primary.c	(Arbeitskopie)
@@ -1733,9 +1733,7 @@ gfc_match_varspec (gfc_expr *primary, int equiv_fl
       || (sym->attr.dimension && !sym->attr.proc_pointer
 	  && !gfc_is_proc_ptr_comp (primary, NULL)
 	  && !(gfc_matching_procptr_assignment
-	       && sym->attr.flavor == FL_PROCEDURE))
-      || (sym->ts.type == BT_CLASS
-	  && sym->ts.u.derived->components->attr.dimension))
+	       && sym->attr.flavor == FL_PROCEDURE)))
     {
       /* In EQUIVALENCE, we don't know yet whether we are seeing
 	 an array, character variable or array of character
@@ -1868,20 +1866,7 @@ gfc_match_varspec (gfc_expr *primary, int equiv_fl
 	  if (m != MATCH_YES)
 	    return m;
 	}
-      else if (component->ts.type == BT_CLASS
-	       && component->ts.u.derived->components->as != NULL
-	       && !component->attr.proc_pointer)
-	{
-	  tail = extend_ref (primary, tail);
-	  tail->type = REF_ARRAY;
 
-	  m = gfc_match_array_ref (&tail->u.ar,
-				   component->ts.u.derived->components->as,
-				   equiv_flag);
-	  if (m != MATCH_YES)
-	    return m;
-	}
-
       if ((component->ts.type != BT_DERIVED && component->ts.type != BT_CLASS)
 	  || gfc_match_char ('%') != MATCH_YES)
 	break;
@@ -1961,6 +1946,7 @@ gfc_variable_attr (gfc_expr *expr, gfc_typespec *t
   gfc_ref *ref;
   gfc_symbol *sym;
   gfc_component *comp;
+  gfc_typespec tmp_ts;
 
   if (expr->expr_type != EXPR_VARIABLE && expr->expr_type != EXPR_FUNCTION)
     gfc_internal_error ("gfc_variable_attr(): Expression isn't a variable");
@@ -1986,9 +1972,11 @@ gfc_variable_attr (gfc_expr *expr, gfc_typespec *t
   if (pointer || attr.proc_pointer)
     target = 1;
 
-  if (ts != NULL && expr->ts.type == BT_UNKNOWN)
+  if (ts != NULL && (expr->ts.type == BT_UNKNOWN || expr->ts.type == BT_CLASS))
     *ts = sym->ts;
 
+  tmp_ts = sym->ts;
+
   for (; ref; ref = ref->next)
     switch (ref->type)
       {
@@ -2018,6 +2006,11 @@ gfc_variable_attr (gfc_expr *expr, gfc_typespec *t
       case REF_COMPONENT:
 	comp = ref->u.c.component;
 	attr = comp->attr;
+	/* CLASS variables changes their type at resolution stage.
+	   Update the reference.  */
+	if (tmp_ts.type == BT_CLASS)
+	  ref->u.c.sym = tmp_ts.u.derived;
+	tmp_ts = comp->ts;
 	if (ts != NULL)
 	  {
 	    *ts = comp->ts;

Index Nav: [Date Index] [Subject Index] [Author Index] [Thread Index]
Message Nav: [Date Prev] [Date Next] [Thread Prev] [Thread Next]