Re: [OOP] SELECT TYPE with CLASS IS

[Janus Weil <janus at gcc dot gnu dot org>]

Hi Dominique,

> I have applied your patch in http://gcc.gnu.org/ml/fortran/2009-11/msg00103.html
> on top of revision 154007 along with the two other required patches
> revision 153804 in fortran-dev and http://gcc.gnu.org/ml/fortran/2009-11/msg00070.html.
>
> Now class_is.f90 compiles but gives different results in 32 and 64 bit modes:
>
> [ibook-dhum] f90/bug% gfc -m32 class_is.f90
> [ibook-dhum] f90/bug% a.out
> ? ? ? ? ? 4
> ? ? ? ? ? 1
> ? ? ? ? ? 1
> ibook-dhum] f90/bug% gfc -m64 class_is.f90
> [ibook-dhum] f90/bug% a.out
> ? ? ? ? ? 3
> ? ? ? ? ? 1
> ? ? ? ? ? 4

thanks for testing. I can reproduce that behavior on
x86_64-unknown-linux-gnu. It was due to a stupid mistake (I just
forgot to add a $vptr reference when calling
_gfortran_is_extension_of). It's funny I didn't notice it earlier.

The update I'm attaching here should fix it. If anybody else wants to
try it, please use this version.

Cheers,
Janus

Index: gcc/fortran/resolve.c
===================================================================
--- gcc/fortran/resolve.c	(revision 154009)
+++ gcc/fortran/resolve.c	(working copy)
@@ -6853,8 +6853,9 @@ 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;
@@ -6867,9 +6868,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)
     {
@@ -6897,12 +6895,12 @@ resolve_select_type (gfc_code *code)
       if (c->ts.type == BT_UNKNOWN)
 	{
 	  /* Check F03:C818.  */
-	  if (default_case != NULL)
+	  if (default_case)
 	    gfc_error ("The DEFAULT CASE at %L cannot be followed "
 		       "by a second DEFAULT CASE at %L",
-		       &default_case->where, &c->where);
+		       &default_case->ext.case_list->where, &c->where);
 	  else
-	    default_case = c;
+	    default_case = body;
 	  continue;
 	}
     }
@@ -6942,39 +6940,118 @@ resolve_select_type (gfc_code *code)
   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->hash_value);
-      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)
+      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)
 	{
-	  /* 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);
+	  /* 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)
+	{
+	  /* TODO: Sort CLASS IS cases.  */
+	}
+	
+      /* 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);
Index: gcc/fortran/iresolve.c
===================================================================
--- gcc/fortran/iresolve.c	(revision 154009)
+++ gcc/fortran/iresolve.c	(working copy)
@@ -851,7 +851,7 @@ gfc_resolve_extends_type_of (gfc_expr *f, gfc_expr
     }
 
   f->ts.type = BT_LOGICAL;
-  f->ts.kind = gfc_default_logical_kind;
+  f->ts.kind = 4;
   /* Call library function.  */
   f->value.function.name = gfc_get_string (PREFIX ("is_extension_of"));
 }
Index: gcc/fortran/match.c
===================================================================
--- gcc/fortran/match.c	(revision 154009)
+++ gcc/fortran/match.c	(working copy)
@@ -3971,12 +3971,21 @@ select_type_set_tmp (gfc_typespec *ts)
   char name[GFC_MAX_SYMBOL_LEN];
   gfc_symtree *tmp;
 
-  sprintf (name, "tmp$%s", ts->u.derived->name);
+  if (ts->type == BT_CLASS)
+    sprintf (name, "tmp$class$%s", ts->u.derived->name);
+  else
+    sprintf (name, "tmp$type$%s", ts->u.derived->name);
   gfc_get_sym_tree (name, gfc_current_ns, &tmp, false);
   gfc_add_type (tmp->n.sym, ts, NULL);
   gfc_set_sym_referenced (tmp->n.sym);
   gfc_add_pointer (&tmp->n.sym->attr, NULL);
   gfc_add_flavor (&tmp->n.sym->attr, FL_VARIABLE, name, NULL);
+  if (ts->type == BT_CLASS)
+    {
+      gfc_build_class_symbol (&tmp->n.sym->ts, &tmp->n.sym->attr,
+			      &tmp->n.sym->as);
+      tmp->n.sym->attr.class_ok = 1;
+    }
 
   select_type_stack->tmp = tmp;
 }
@@ -4230,9 +4239,10 @@ gfc_match_class_is (void)
 
   new_st.op = EXEC_SELECT_TYPE;
   new_st.ext.case_list = c;
+  
+  /* Create temporary variable.  */
+  select_type_set_tmp (&c->ts);
 
-  gfc_error_now ("CLASS IS specification at %C is not yet supported");
-
   return MATCH_YES;
 
 syntax: