Re: [OOP] SELECT TYPE with CLASS IS

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

Hi all,

> here is an early shot at CLASS IS. As announced before, my
> implementation uses the library function "is_extension_of" that I
> introduced with the EXTENDS_TYPE_OF patch and translates the CLASS IS
> cases into a chain of IF/ELSE IF statements (you can have a look at
> the dump for the attached test case to see an example of the code it
> generates). The patch is not quite complete yet, since CLASS IS cases
> are not being sorted if they're in the wrong order. But apart from
> this, most things should work already. In particular the following
> cases:
>
> ?* SELECT TYPE statements with only one CLASS IS branch
> ?* those cases where the CLASS IS labels are not extensions of each other, or
> ?* cases where the CLASS IS labels are sorted in the right way
> manually (i.e. extensions before their parents)
>
> If anyone wants to try it out or have a look at the patch, that would
> be great (the patch has to be applied to the fortran-dev branch, btw).
> I'll try to get the sorting right soon.

the attached version of the patch adds the sorting, and should be able
to produce the right runtime-behavior for any combination of CLASS IS
blocks.

My first thought regarding the sorting of the CLASS IS cases was to
simply go through the list and for any given pair determine if one
type is an extension of the other. However, this naive plan has some
problems:
1) For each pair, you have to do two operations: Check if A is an
extension of B. If not, check if B is an extension of A. This check
would involve stepping through the inheritance tree (which can be
quite large in extreme cases).
2) In this way, you can not find a unique order of the blocks, since
some of the types may not be related at all.

It just occurred to me a few hours ago that there is a much more
elegant and efficient way to do the sorting. For this, I took the
attr.extension bitfield that Paul introduced when he implemented type
extensions, and expanded it by a few bits, so that it not only
determines if the type if an extension of another, but instead
contains a number which describes the "extension level" of the type.
That is, if you draw an inheritance tree based on a certain base
class, the "extension level" is simply the level at which a certain
type is located (the basetype having extension=0, its direct
descendants having extension=1, etc).

This is a natural generalization of the extension field, since
extension=0 still means the type is no extension, while extension>0
means it is. So all the present code which checks the extension field
still works. For now I chose to make the field 8 bits wide, so that
inheritance trees with up to 255 levels are possible (the actual
number of types in the tree can be much larger), which I think is hard
to exceed with any reasonable application (am I being too naive
here?).

But most importantly, this "extension level" provides a natural
ordering scheme: Highest extension levels must always come first in
the CLASS IS chain, which guarantees that descendants come before
their parents. For equal extension levels, ordering does not matter.
And that's it!

Then I just made sure to correctly set the 'extension' field, when
constructing a derived type, and implemented a simple bubble-sort on
the singly-linked list of CLASS IS blocks, based on the 'extension'
field.

I successfully checked the patch for regressions. Do you guys have any
comments or suggestions, or is it okay if I commit to fortran-dev?
(Will write a ChangeLog and dejagnuify my test case soonish.)

Cheers,
Janus

Index: gcc/testsuite/gfortran.dg/module_md5_1.f90
===================================================================
--- gcc/testsuite/gfortran.dg/module_md5_1.f90	(revision 154044)
+++ gcc/testsuite/gfortran.dg/module_md5_1.f90	(working copy)
@@ -10,5 +10,5 @@ program test
   use foo
   print *, pi
 end program test
-! { dg-final { scan-module "foo" "MD5:9c43cf4d713824ec6894b83250720e68" } }
+! { dg-final { scan-module "foo" "MD5:5632bcd379cf023bf7e663e91d52fa12" } }
 ! { dg-final { cleanup-modules "foo" } }
Index: gcc/testsuite/gfortran.dg/select_type_2.f03
===================================================================
--- gcc/testsuite/gfortran.dg/select_type_2.f03	(revision 154044)
+++ gcc/testsuite/gfortran.dg/select_type_2.f03	(working copy)
@@ -30,9 +30,8 @@
     i = 1
   type is (t2)
     i = 2
-! FIXME: CLASS IS is not yet supported
-!  class is (t1)
-!    i = 3
+  class is (t1)
+    i = 3
   end select
 
   if (i /= 1) call abort()
@@ -45,9 +44,8 @@
     i = 1
   type is (t2)
     i = 2
-! FIXME: CLASS IS is not yet supported
-!  class is (t2)
-!    i = 3
+  class is (t2)
+    i = 3
   end select
 
   if (i /= 2) call abort()
Index: gcc/testsuite/gfortran.dg/select_type_1.f03
===================================================================
--- gcc/testsuite/gfortran.dg/select_type_1.f03	(revision 154044)
+++ gcc/testsuite/gfortran.dg/select_type_1.f03	(working copy)
@@ -40,16 +40,14 @@
     print *,"a is TYPE(t1)"
   type is (t2)
     print *,"a is TYPE(t2)"
-! FIXME: CLASS IS specification is not yet supported
-!  class is (ts)  ! { FIXME: error "must be extensible" }
-!    print *,"a is TYPE(ts)"
+  class is (ts)  ! { dg-error "must be extensible" }
+    print *,"a is TYPE(ts)"
   type is (t3)   ! { dg-error "must be an extension of" }
     print *,"a is TYPE(t3)"
   type is (t4)   ! { dg-error "is not an accessible derived type" }
     print *,"a is TYPE(t3)"
-! FIXME: CLASS IS specification is not yet supported
-!  class is (t1)
-!    print *,"a is CLASS(t1)"
+  class is (t1)
+    print *,"a is CLASS(t1)"
   class is (t2) label  ! { dg-error "Syntax error" }
     print *,"a is CLASS(t2)"
   class default  ! { dg-error "cannot be followed by a second DEFAULT CASE" }
Index: gcc/testsuite/gfortran.dg/extends_type_of_1.f03
===================================================================
--- gcc/testsuite/gfortran.dg/extends_type_of_1.f03	(revision 154044)
+++ gcc/testsuite/gfortran.dg/extends_type_of_1.f03	(working copy)
@@ -7,7 +7,6 @@
  implicit none
 
  intrinsic :: extends_type_of
- integer :: extends_type_of
 
  type :: t1
    integer :: i = 42
Index: gcc/fortran/symbol.c
===================================================================
--- gcc/fortran/symbol.c	(revision 154044)
+++ gcc/fortran/symbol.c	(working copy)
@@ -4701,7 +4701,7 @@ gfc_build_class_symbol (gfc_typespec *ts, symbol_a
       c->initializer->expr_type = EXPR_NULL;
     }
 
-  fclass->attr.extension = 1;
+  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;
Index: gcc/fortran/decl.c
===================================================================
--- gcc/fortran/decl.c	(revision 154044)
+++ gcc/fortran/decl.c	(working copy)
@@ -6846,13 +6846,15 @@ gfc_match_derived_decl (void)
 
       /* Add the extended derived type as the first component.  */
       gfc_add_component (sym, parent, &p);
-      sym->attr.extension = attr.extension;
       extended->refs++;
       gfc_set_sym_referenced (extended);
 
       p->ts.type = BT_DERIVED;
       p->ts.u.derived = extended;
       p->initializer = gfc_default_initializer (&p->ts);
+      
+      /* Set extension level.  */
+      sym->attr.extension = extended->attr.extension + 1;
 
       /* Provide the links between the extended type and its extension.  */
       if (!extended->f2k_derived)
Index: gcc/fortran/gfortran.h
===================================================================
--- gcc/fortran/gfortran.h	(revision 154044)
+++ gcc/fortran/gfortran.h	(working copy)
@@ -670,7 +670,7 @@ typedef struct
   unsigned untyped:1;		/* No implicit type could be found.  */
 
   unsigned is_bind_c:1;		/* say if is bound to C.  */
-  unsigned extension:1;		/* extends a derived type.  */
+  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.  */
Index: gcc/fortran/module.c
===================================================================
--- gcc/fortran/module.c	(revision 154044)
+++ gcc/fortran/module.c	(working copy)
@@ -1672,7 +1672,7 @@ 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_EXTENSION, AB_IS_CLASS, AB_PROCEDURE, AB_PROC_POINTER
+  AB_IS_CLASS, AB_PROCEDURE, AB_PROC_POINTER
 }
 ab_attribute;
 
@@ -1712,7 +1712,6 @@ static const mstring attr_bits[] =
     minit ("ZERO_COMP", AB_ZERO_COMP),
     minit ("PROTECTED", AB_PROTECTED),
     minit ("ABSTRACT", AB_ABSTRACT),
-    minit ("EXTENSION", AB_EXTENSION),
     minit ("IS_CLASS", AB_IS_CLASS),
     minit ("PROCEDURE", AB_PROCEDURE),
     minit ("PROC_POINTER", AB_PROC_POINTER),
@@ -1772,7 +1771,7 @@ static void
 mio_symbol_attribute (symbol_attribute *attr)
 {
   atom_type t;
-  unsigned ext_attr;
+  unsigned ext_attr,extension_level;
 
   mio_lparen ();
 
@@ -1781,10 +1780,15 @@ mio_symbol_attribute (symbol_attribute *attr)
   attr->proc = MIO_NAME (procedure_type) (attr->proc, procedures);
   attr->if_source = MIO_NAME (ifsrc) (attr->if_source, ifsrc_types);
   attr->save = MIO_NAME (save_state) (attr->save, save_status);
+  
   ext_attr = attr->ext_attr;
   mio_integer ((int *) &ext_attr);
   attr->ext_attr = ext_attr;
 
+  extension_level = attr->extension;
+  mio_integer ((int *) &extension_level);
+  attr->extension = extension_level;
+
   if (iomode == IO_OUTPUT)
     {
       if (attr->allocatable)
@@ -1859,8 +1863,6 @@ mio_symbol_attribute (symbol_attribute *attr)
 	MIO_NAME (ab_attribute) (AB_PRIVATE_COMP, attr_bits);
       if (attr->zero_comp)
 	MIO_NAME (ab_attribute) (AB_ZERO_COMP, attr_bits);
-      if (attr->extension)
-	MIO_NAME (ab_attribute) (AB_EXTENSION, attr_bits);
       if (attr->is_class)
 	MIO_NAME (ab_attribute) (AB_IS_CLASS, attr_bits);
       if (attr->procedure)
@@ -1985,9 +1987,6 @@ mio_symbol_attribute (symbol_attribute *attr)
 	    case AB_ZERO_COMP:
 	      attr->zero_comp = 1;
 	      break;
-	    case AB_EXTENSION:
-	      attr->extension = 1;
-	      break;
 	    case AB_IS_CLASS:
 	      attr->is_class = 1;
 	      break;
Index: gcc/fortran/resolve.c
===================================================================
--- gcc/fortran/resolve.c	(revision 154044)
+++ gcc/fortran/resolve.c	(working copy)
@@ -6856,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);
@@ -6870,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)
     {
@@ -6884,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;
 	}
 
@@ -6893,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;
 	}
 
@@ -6900,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)
     {
@@ -6945,39 +6952,138 @@ 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)
+	{
+	  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;
+		  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);
@@ -8749,7 +8855,8 @@ resolve_fl_variable_derived (gfc_symbol *sym, int
       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;
 	}
 
Index: gcc/fortran/iresolve.c
===================================================================
--- gcc/fortran/iresolve.c	(revision 154044)
+++ 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 154044)
+++ gcc/fortran/match.c	(working copy)
@@ -3970,13 +3970,25 @@ select_type_set_tmp (gfc_typespec *ts)
 {
   char name[GFC_MAX_SYMBOL_LEN];
   gfc_symtree *tmp;
+  
+  if (!gfc_type_is_extensible (ts->u.derived))
+    return;
 
-  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 +4242,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: