2009-12-02 Basile Starynkevitch <basile@starynkevitch.net>

        MELT branch merged with trunk rev 154895
	{after more plugin events from ICI folks}



git-svn-id: svn+ssh://gcc.gnu.org/svn/gcc/branches/melt-branch@154896 138bc75d-0d04-0410-961f-82ee72b054a4

1 files changed, 168 insertions, 58 deletions

diff --git a/gcc/fortran/resolve.c b/gcc/fortran/resolve.c
index b6853129d59..bf705c6a09a 100644
--- a/gcc/fortran/resolve.c
+++ b/gcc/fortran/resolve.c
@@ -5218,41 +5218,35 @@ resolve_class_esym (gfc_expr *e)
 }
 
 
-/* Generate an expression for the vindex, given the reference to
+/* Generate an expression for the hash value, given the reference to
    the class of the final expression (class_ref), the base of the
    full reference list (new_ref), the declared type and the class
    object (st).  */
 static gfc_expr*
-vindex_expr (gfc_ref *class_ref, gfc_ref *new_ref,
-	     gfc_symbol *declared, gfc_symtree *st)
+hash_value_expr (gfc_ref *class_ref, gfc_ref *new_ref, gfc_symtree *st)
 {
-  gfc_expr *vindex;
-  gfc_ref *ref;
+  gfc_expr *hash_value;
 
-  /* Build an expression for the correct vindex; ie. that of the last
+  /* Build an expression for the correct hash_value; ie. that of the last
      CLASS reference.  */
-  ref = gfc_get_ref();
-  ref->type = REF_COMPONENT;
-  ref->u.c.component = declared->components->next;
-  ref->u.c.sym = declared;
-  ref->next = NULL;
   if (class_ref)
     {
-      class_ref->next = ref;
+      class_ref->next = NULL;
     }
   else
     {
       gfc_free_ref_list (new_ref);
-      new_ref = ref;
+      new_ref = NULL;
     }
-  vindex = gfc_get_expr ();
-  vindex->expr_type = EXPR_VARIABLE;
-  vindex->symtree = st;
-  vindex->symtree->n.sym->refs++;
-  vindex->ts = ref->u.c.component->ts;
-  vindex->ref = new_ref;
+  hash_value = gfc_get_expr ();
+  hash_value->expr_type = EXPR_VARIABLE;
+  hash_value->symtree = st;
+  hash_value->symtree->n.sym->refs++;
+  hash_value->ref = new_ref;
+  gfc_add_component_ref (hash_value, "$vptr");
+  gfc_add_component_ref (hash_value, "$hash");
 
-  return vindex;
+  return hash_value;
 }
 
 
@@ -5352,10 +5346,10 @@ resolve_class_compcall (gfc_expr* e)
   resolve_class_esym (e);
 
   /* More than one typebound procedure so transmit an expression for
-     the vindex as the selector.  */
+     the hash_value as the selector.  */
   if (e->value.function.class_esym != NULL)
-    e->value.function.class_esym->vindex
-		= vindex_expr (class_ref, new_ref, declared, st);
+    e->value.function.class_esym->hash_value
+		= hash_value_expr (class_ref, new_ref, st);
 
   return class_try;
 }
@@ -5407,10 +5401,10 @@ resolve_class_typebound_call (gfc_code *code)
   resolve_class_esym (code->expr1);
 
   /* More than one typebound procedure so transmit an expression for
-     the vindex as the selector.  */
+     the hash_value as the selector.  */
   if (code->expr1->value.function.class_esym != NULL)
-    code->expr1->value.function.class_esym->vindex
-		= vindex_expr (class_ref, new_ref, declared, st);
+    code->expr1->value.function.class_esym->hash_value
+		= hash_value_expr (class_ref, new_ref, st);
 
   return class_try;
 }
@@ -6862,11 +6856,13 @@ static void
 resolve_select_type (gfc_code *code)
 {
   gfc_symbol *selector_type;
-  gfc_code *body, *new_st;
-  gfc_case *c, *default_case;
+  gfc_code *body, *new_st, *if_st, *tail;
+  gfc_code *class_is = NULL, *default_case = NULL;
+  gfc_case *c;
   gfc_symtree *st;
   char name[GFC_MAX_SYMBOL_LEN];
   gfc_namespace *ns;
+  int error = 0;
 
   ns = code->ext.ns;
   gfc_resolve (ns);
@@ -6876,9 +6872,6 @@ resolve_select_type (gfc_code *code)
   else
     selector_type = code->expr1->ts.u.derived->components->ts.u.derived;
 
-  /* Assume there is no DEFAULT case.  */
-  default_case = NULL;
-
   /* Loop over TYPE IS / CLASS IS cases.  */
   for (body = code->block; body; body = body->block)
     {
@@ -6890,6 +6883,7 @@ resolve_select_type (gfc_code *code)
 	{
 	  gfc_error ("Derived type '%s' at %L must be extensible",
 		     c->ts.u.derived->name, &c->where);
+	  error++;
 	  continue;
 	}
 
@@ -6899,6 +6893,7 @@ resolve_select_type (gfc_code *code)
 	{
 	  gfc_error ("Derived type '%s' at %L must be an extension of '%s'",
 		     c->ts.u.derived->name, &c->where, selector_type->name);
+	  error++;
 	  continue;
 	}
 
@@ -6906,15 +6901,21 @@ resolve_select_type (gfc_code *code)
       if (c->ts.type == BT_UNKNOWN)
 	{
 	  /* Check F03:C818.  */
-	  if (default_case != NULL)
-	    gfc_error ("The DEFAULT CASE at %L cannot be followed "
-		       "by a second DEFAULT CASE at %L",
-		       &default_case->where, &c->where);
+	  if (default_case)
+	    {
+	      gfc_error ("The DEFAULT CASE at %L cannot be followed "
+			 "by a second DEFAULT CASE at %L",
+			 &default_case->ext.case_list->where, &c->where);
+	      error++;
+	      continue;
+	    }
 	  else
-	    default_case = c;
-	  continue;
+	    default_case = body;
 	}
     }
+    
+  if (error>0)
+    return;
 
   if (code->expr2)
     {
@@ -6944,45 +6945,153 @@ resolve_select_type (gfc_code *code)
 
   /* Transform to EXEC_SELECT.  */
   code->op = EXEC_SELECT;
-  gfc_add_component_ref (code->expr1, "$vindex");
+  gfc_add_component_ref (code->expr1, "$vptr");
+  gfc_add_component_ref (code->expr1, "$hash");
 
   /* Loop over TYPE IS / CLASS IS cases.  */
   for (body = code->block; body; body = body->block)
     {
       c = body->ext.case_list;
+      
       if (c->ts.type == BT_DERIVED)
-	c->low = c->high = gfc_int_expr (c->ts.u.derived->vindex);
-      else if (c->ts.type == BT_CLASS)
-	/* Currently IS CLASS blocks are simply ignored.
-	   TODO: Implement IS CLASS.  */
-	c->unreachable = 1;
-
-      if (c->ts.type != BT_DERIVED)
+	c->low = c->high = gfc_int_expr (c->ts.u.derived->hash_value);
+      else if (c->ts.type == BT_UNKNOWN)
 	continue;
+      
       /* Assign temporary to selector.  */
-      sprintf (name, "tmp$%s", c->ts.u.derived->name);
+      if (c->ts.type == BT_CLASS)
+	sprintf (name, "tmp$class$%s", c->ts.u.derived->name);
+      else
+	sprintf (name, "tmp$type$%s", c->ts.u.derived->name);
       st = gfc_find_symtree (ns->sym_root, name);
       new_st = gfc_get_code ();
-      new_st->op = EXEC_POINTER_ASSIGN;
       new_st->expr1 = gfc_get_variable_expr (st);
       new_st->expr2 = gfc_get_variable_expr (code->expr1->symtree);
-      gfc_add_component_ref (new_st->expr2, "$data");
+      if (c->ts.type == BT_DERIVED)
+	{
+	  new_st->op = EXEC_POINTER_ASSIGN;
+	  gfc_add_component_ref (new_st->expr2, "$data");
+	}
+      else
+	new_st->op = EXEC_POINTER_ASSIGN;
       new_st->next = body->next;
       body->next = new_st;
     }
+    
+  /* Take out CLASS IS cases for separate treatment.  */
+  body = code;
+  while (body && body->block)
+    {
+      if (body->block->ext.case_list->ts.type == BT_CLASS)
+	{
+	  /* Add to class_is list.  */
+	  if (class_is == NULL)
+	    { 
+	      class_is = body->block;
+	      tail = class_is;
+	    }
+	  else
+	    {
+	      for (tail = class_is; tail->block; tail = tail->block) ;
+	      tail->block = body->block;
+	      tail = tail->block;
+	    }
+	  /* Remove from EXEC_SELECT list.  */
+	  body->block = body->block->block;
+	  tail->block = NULL;
+	}
+      else
+	body = body->block;
+    }
 
-  /* Eliminate dead blocks.  */
-  for (body = code; body && body->block; body = body->block)
+  if (class_is)
     {
-      if (body->block->ext.case_list->unreachable)
+      gfc_symbol *vtab;
+      
+      if (!default_case)
+	{
+	  /* Add a default case to hold the CLASS IS cases.  */
+	  for (tail = code; tail->block; tail = tail->block) ;
+	  tail->block = gfc_get_code ();
+	  tail = tail->block;
+	  tail->op = EXEC_SELECT_TYPE;
+	  tail->ext.case_list = gfc_get_case ();
+	  tail->ext.case_list->ts.type = BT_UNKNOWN;
+	  tail->next = NULL;
+	  default_case = tail;
+	}
+      
+      /* More than one CLASS IS block?  */
+      if (class_is->block)
 	{
-	  /* Cut the unreachable block from the code chain.  */
-	  gfc_code *cd = body->block;
-	  body->block = cd->block;
-	  /* Kill the dead block, but not the blocks below it.  */
-	  cd->block = NULL;
-	  gfc_free_statements (cd);
+	  gfc_code **c1,*c2;
+	  bool swapped;
+	  /* Sort CLASS IS blocks by extension level.  */
+	  do
+	    {
+	      swapped = false;
+	      for (c1 = &class_is; (*c1) && (*c1)->block; c1 = &((*c1)->block))
+		{
+		  c2 = (*c1)->block;
+		  /* F03:C817 (check for doubles).  */
+		  if ((*c1)->ext.case_list->ts.u.derived->hash_value
+		      == c2->ext.case_list->ts.u.derived->hash_value)
+		    {
+		      gfc_error ("Double CLASS IS block in SELECT TYPE "
+				 "statement at %L", &c2->ext.case_list->where);
+		      return;
+		    }
+		  if ((*c1)->ext.case_list->ts.u.derived->attr.extension
+		      < c2->ext.case_list->ts.u.derived->attr.extension)
+		    {
+		      /* Swap.  */
+		      (*c1)->block = c2->block;
+		      c2->block = *c1;
+		      *c1 = c2;
+		      swapped = true;
+		    }
+		}
+	    }
+	  while (swapped);
 	}
+	
+      /* Generate IF chain.  */
+      if_st = gfc_get_code ();
+      if_st->op = EXEC_IF;
+      new_st = if_st;
+      for (body = class_is; body; body = body->block)
+	{
+	  new_st->block = gfc_get_code ();
+	  new_st = new_st->block;
+	  new_st->op = EXEC_IF;
+	  /* Set up IF condition: Call _gfortran_is_extension_of.  */
+	  new_st->expr1 = gfc_get_expr ();
+	  new_st->expr1->expr_type = EXPR_FUNCTION;
+	  new_st->expr1->ts.type = BT_LOGICAL;
+	  new_st->expr1->ts.kind = 4;
+	  new_st->expr1->value.function.name = gfc_get_string (PREFIX ("is_extension_of"));
+	  new_st->expr1->value.function.isym = XCNEW (gfc_intrinsic_sym);
+	  new_st->expr1->value.function.isym->id = GFC_ISYM_EXTENDS_TYPE_OF;
+	  /* Set up arguments.  */
+	  new_st->expr1->value.function.actual = gfc_get_actual_arglist ();
+	  new_st->expr1->value.function.actual->expr = gfc_get_variable_expr (code->expr1->symtree);
+	  gfc_add_component_ref (new_st->expr1->value.function.actual->expr, "$vptr");
+	  vtab = gfc_find_derived_vtab (body->ext.case_list->ts.u.derived);
+	  st = gfc_find_symtree (vtab->ns->sym_root, vtab->name);
+	  new_st->expr1->value.function.actual->next = gfc_get_actual_arglist ();
+	  new_st->expr1->value.function.actual->next->expr = gfc_get_variable_expr (st);
+	  new_st->next = body->next;
+	}
+	if (default_case->next)
+	  {
+	    new_st->block = gfc_get_code ();
+	    new_st = new_st->block;
+	    new_st->op = EXEC_IF;
+	    new_st->next = default_case->next;
+	  }
+	  
+	/* Replace CLASS DEFAULT code by the IF chain.  */
+	default_case->next = if_st;
     }
 
   resolve_select (code);
@@ -8751,7 +8860,8 @@ resolve_fl_variable_derived (gfc_symbol *sym, int no_init_flag)
       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);
+		     sym->ts.u.derived->components->ts.u.derived->name,
+		     sym->name, &sym->declared_at);
 	  return FAILURE;
 	}