[OOP] SELECT TYPE with CLASS IS

[Janus Weil-3]

Hi folks,

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.

Salvatore, do you have a version of your code which includes CLASS IS
cases? If yes, can you try the patch on it, or alternatively send your
code to me, so that I can try it? [Without the sorting, the runtime
behaviour can potentially be wrong, but hopefully there should be no
compile-time problems.]

Cheers,
Janus

[class_is.diff]

---

Index: gcc/fortran/resolve.c
===================================================================
--- gcc/fortran/resolve.c (revision 153995)
+++ 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,117 @@ 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 = gfc_default_logical_kind;
+  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);
+  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/match.c
===================================================================
--- gcc/fortran/match.c (revision 153995)
+++ 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:

---

[Rouson, Damian]

Janus,

Great work -- I remain very excited about the increasing OOP support in
gfortran.

I have code that uses CLASS IS and will be glad to do some testing once I
resolve my issues with building the code.  The two most convenient platforms
for me are Mac OS X and AIX, but I have trouble building on both of those.
Probably I should try doing it inside a Linux virtual machine. That would
make things a bit slow, but would presumably put me much more in the
mainstream.  I'll let you know if I get a chance to do that.

Damian


On 11/7/09 2:20 PM, "Janus Weil" <janus@...> wrote:

> Hi folks,
>
> 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.
>
> Salvatore, do you have a version of your code which includes CLASS IS
> cases? If yes, can you try the patch on it, or alternatively send your
> code to me, so that I can try it? [Without the sorting, the runtime
> behaviour can potentially be wrong, but hopefully there should be no
> compile-time problems.]
>
> Cheers,
> Janus
>

[Salvatore Filippone]

Yes, I have CLASS IS statements around (they were purged early on in the
version I sent you).
I will test this afternoon.

Regards
Salvatore

Il giorno sab, 07/11/2009 alle 23.20 +0100, Janus Weil ha scritto:

> Hi folks,
>
> 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.
>
> Salvatore, do you have a version of your code which includes CLASS IS
> cases? If yes, can you try the patch on it, or alternatively send your
> code to me, so that I can try it? [Without the sorting, the runtime
> behaviour can potentially be wrong, but hopefully there should be no
> compile-time problems.]
>
> Cheers,
> Janus

--
Salvatore Filippone
Dip. Ingegneria Meccanica, Universita' di Roma "Tor Vergata",
Via del Politecnico 1, I-00133,  Roma, Italy              
tel: [phone]    fax: [phone]
Cell.: ([phone]    e-mail:  salvatore.filippone@...
homepage: http://www.ce.uniroma2.it/people/filippone.html
"..ma misi me per l'alto mare aperto..." Dante
"whenever it is a damp, drizzly November in my soul...
  I account it high time to get to sea "  Melville

[Dominique Dhumieres]

Hi Janus,

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

Cheers

Dominique

PS done on i686-apple-darwin9

[Janus Weil-3]

Hi Damian,

> I have code that uses CLASS IS and will be glad to do some testing once I
> resolve my issues with building the code.  The two most convenient platforms
> for me are Mac OS X and AIX, but I have trouble building on both of those.

building GCC on darwin10 works fine for me at r154009. What problems
do you encounter? Still the dsymutil issue?

Dominique, what's the status of PR41473? Is this resolved, or is there
a workaround?

Cheers,
Janus

> On 11/7/09 2:20 PM, "Janus Weil" <janus@...> wrote:
>
>> Hi folks,
>>
>> 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.
>>
>> Salvatore, do you have a version of your code which includes CLASS IS
>> cases? If yes, can you try the patch on it, or alternatively send your
>> code to me, so that I can try it? [Without the sorting, the runtime
>> behaviour can potentially be wrong, but hopefully there should be no
>> compile-time problems.]
>>
>> Cheers,
>> Janus
>>
>
>
>

[Dominique Dhumieres]

> Dominique, what's the status of PR41473? Is this resolved, or is there
> a workaround?

AFAICT the problem is still there, but harmless for all features I use:
valgrind complains and there is no dSym directories built, but otherwise
I don't see anything else wrong. My latest bootstrap shows:

19157 - libtool: link: dsymutil .libs/libstdc++.6.dylib || :
19158 : Assertion failed: (orig_str), function FixReferences, file /SourceCache/dwarf_utilities/dwarf_utilities-70/source/DWARFdSYM.cpp, line 3641.
19159 + ../libtool: line 7996:  4754 Abort trap              dsymutil .libs/libstdc++.6.dylib
22034 - libtool: link: dsymutil .libs/libstdc++.6.dylib || :
22035 : Assertion failed: (orig_str), function FixReferences, file /SourceCache/dwarf_utilities/dwarf_utilities-70/source/DWARFdSYM.cpp, line 3641.
22036 + ../libtool: line 7996:  8228 Abort trap              dsymutil .libs/libstdc++.6.dylib
22374 - libtool: link: dsymutil .libs/libssp.0.dylib || :
22375 : Assertion failed: (orig_str), function FixReferences, file /SourceCache/dwarf_utilities/dwarf_utilities-70/source/DWARFdSYM.cpp, line 3641.
22376 + ./libtool: line 7982: 13162 Abort trap              dsymutil .libs/libssp.0.dylib
22500 - libtool: link: dsymutil .libs/libssp.0.dylib || :
22501 : Assertion failed: (orig_str), function FixReferences, file /SourceCache/dwarf_utilities/dwarf_utilities-70/source/DWARFdSYM.cpp, line 3641.
22502 + ./libtool: line 7982: 13770 Abort trap              dsymutil .libs/libssp.0.dylib
25592 - libtool: link: dsymutil .libs/libgfortran.3.dylib || :
25593 : Assertion failed: (orig_str), function FixReferences, file /SourceCache/dwarf_utilities/dwarf_utilities-70/source/DWARFdSYM.cpp, line 3641.
25594 + ./libtool: line 7996: 46318 Abort trap              dsymutil .libs/libgfortran.3.dylib
28137 - libtool: link: dsymutil .libs/libgfortran.3.dylib || :
28138 : Assertion failed: (orig_str), function FixReferences, file /SourceCache/dwarf_utilities/dwarf_utilities-70/source/DWARFdSYM.cpp, line 3641.
28139 + ./libtool: line 7996: 63117 Abort trap              dsymutil .libs/libgfortran.3.dylib
29054 - libtool: link: dsymutil .libs/libgcjgc.1.dylib || :
29055 : Assertion failed: (orig_str), function FixReferences, file /SourceCache/dwarf_utilities/dwarf_utilities-70/source/DWARFdSYM.cpp, line 3641.
29056 + ./libtool: line 7996: 74176 Abort trap              dsymutil .libs/libgcjgc.1.dylib
29292 - libtool: link: dsymutil .libs/libobjc-gnu.2.dylib || :
29293 : Assertion failed: (orig_str), function FixReferences, file /SourceCache/dwarf_utilities/dwarf_utilities-70/source/DWARFdSYM.cpp, line 3641.
29294 + ./libtool: line 7988: 75490 Abort trap              dsymutil .libs/libobjc-gnu.2.dylib
36129 - libtool: link: dsymutil .libs/libgcj.11.dylib || :
36130 : Assertion failed: (orig_str), function FixReferences, file /SourceCache/dwarf_utilities/dwarf_utilities-70/source/DWARFdSYM.cpp, line 3641.
36131 + ./libtool: line 7996: 82592 Abort trap              dsymutil .libs/libgcj.11.dylib
40529 - libtool: link: dsymutil .libs/libgcj.11.dylib || :
40530 : Assertion failed: (orig_str), function FixReferences, file /SourceCache/dwarf_utilities/dwarf_utilities-70/source/DWARFdSYM.cpp, line 3641.
40531 + warning: {0x00016a66} TAG_formal_parameter:  AT_location( 0x00008cda ) didn't have valid function low pc, the location list will be incorrect.
40938 - libtool: link: dsymutil .libs/libgomp.1.dylib || :
40939 : Assertion failed: (orig_str), function FixReferences, file /SourceCache/dwarf_utilities/dwarf_utilities-70/source/DWARFdSYM.cpp, line 3641.
40940 + ./libtool: line 7996: 58372 Abort trap              dsymutil .libs/libgomp.1.dylib
41099 - libtool: link: dsymutil .libs/libgomp.1.dylib || :
41100 : Assertion failed: (orig_str), function FixReferences, file /SourceCache/dwarf_utilities/dwarf_utilities-70/source/DWARFdSYM.cpp, line 3641.
41101 + ./libtool: line 7996: 59166 Abort trap              dsymutil .libs/libgomp.1.dylib

It is now pretty stable, but I don't see what can be done without gcc
guys telling us what they put in the files that triggers the error
(even if the assertion is Apple's fault).

I did not have bootstrap issues since quite a long time now.

Cheers

Dominique

[Janus Weil-3]

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

[class_is.diff]

---

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:

---

[Dominique Dhumieres]

> The update I'm attaching here should fix it.

Yes, it does fix it.

Thanks,

Dominique

[Salvatore Filippone]

Hi all,
Janus' patch seems to be working for me (at least at compile time).
However I am not making heavy use of the CLASS IS statement  right now,
so my tests are not stressing the compiler very much, and I cannot do
runtime tests until Paul's work on dynamic dispatch is included.

Moreover, with the new patch the current version of the library
compiles, but some parts of it take up an inordinate amount of time and
memory; I will soon send Janus an updated version of the source code
(off-list)

Salvatore

[Rouson, Damian]

This is a resend since my last message bounced due to being in HTML format.

The error messages I'm receiving when attempting to build on Mac OS X are
below.

Then when I try to compile, I get

gfortran: error trying to exec 'f951': execvp: No such file or directory

Damian



libtool: link: dsymutil .libs/libgomp.1.dylib || :
warning: {0x00008c70} TAG_subprogram:  AT_frame_base( 0x0000491e ) didn't
have valid function low pc, the location list will be incorrect.
old CU: {0x000082d6}: [0x0000000000000000 - 0x00000000000001ec)
new CU: {0xffffffff}: [0xffffffffffffffff - 0xffffffffffffffff)
warning: {0x00008c89} TAG_formal_parameter:  AT_location( 0x00004956 )
didn't have valid function low pc, the location list will be incorrect.
old CU: {0x000082d6}: [0x0000000000000000 - 0x00000000000001ec)
new CU: {0xffffffff}: [0xffffffffffffffff - 0xffffffffffffffff)
warning: {0x00008c97} TAG_formal_parameter:  AT_location( 0x0000496a )
didn't have valid function low pc, the location list will be incorrect.
old CU: {0x000082d6}: [0x0000000000000000 - 0x00000000000001ec)
new CU: {0xffffffff}: [0xffffffffffffffff - 0xffffffffffffffff)
warning: {0x00008ca6} TAG_formal_parameter:  AT_location( 0x0000497e )
didn't have valid function low pc, the location list will be incorrect.
old CU: {0x000082d6}: [0x0000000000000000 - 0x00000000000001ec)
new CU: {0xffffffff}: [0xffffffffffffffff - 0xffffffffffffffff)
warning: {0x00008cb5} TAG_formal_parameter:  AT_location( 0x000049a8 )
didn't have valid function low pc, the location list will be incorrect.
old CU: {0x000082d6}: [0x0000000000000000 - 0x00000000000001ec)
new CU: {0xffffffff}: [0xffffffffffffffff - 0xffffffffffffffff)
warning: {0x00008ce3} TAG_formal_parameter:  AT_location( 0x000000bc )
didn't have valid function low pc, the location list will be incorrect.
old CU: {0x000082d6}: [0x0000000000000000 - 0x00000000000001ec)
new CU: {0xffffffff}: [0xffffffffffffffff - 0xffffffffffffffff)
warning: {0x00008ceb} TAG_subprogram:  AT_frame_base( 0x00004a0c ) didn't
have valid function low pc, the location list will be incorrect.
old CU: {0x000082d6}: [0x0000000000000000 - 0x00000000000001ec)
new CU: {0xffffffff}: [0xffffffffffffffff - 0xffffffffffffffff)
warning: {0x00008d00} TAG_subprogram:  AT_frame_base( 0x00004a44 ) didn't
have valid function low pc, the location list will be incorrect.
old CU: {0x000082d6}: [0x0000000000000000 - 0x00000000000001ec)
new CU: {0xffffffff}: [0xffffffffffffffff - 0xffffffffffffffff)
./libtool: line 7996: 23953 Bus error               dsymutil
.libs/libgomp.1.dylib
libtool: link: (cd ".libs" && rm -f "libgomp.dylib" && ln -s
"libgomp.1.dylib" "libgomp.dylib")
libtool: link: ar rc .libs/libgomp.a  alloc.o barrier.o critical.o env.o
error.o iter.o iter_ull.o loop.o loop_ull.o ordered.o parallel.o sections.o
single.o task.o team.o work.o lock.o mutex.o proc.o sem.o bar.o ptrlock.o
time.o fortran.o affinity.o
ranlib: file: .libs/libgomp.a(mutex.o) has no symbols
ranlib: file: .libs/libgomp.a(ptrlock.o) has no symbols
libtool: link: ranlib -c .libs/libgomp.a
ranlib: file: .libs/libgomp.a(mutex.o) has no symbols
ranlib: file: .libs/libgomp.a(ptrlock.o) has no symbols
libtool: link: ( cd ".libs" && rm -f "libgomp.la" && ln -s "../libgomp.la"
"libgomp.la" )
true  DO=all multi-do # make

[Paul Richard Thomas]

Dear All,

Just to keep you up to date, I have attached the working version of my
patch, relative to trunk, to fix PR41289 and to implement a form of
vtables.  It does away completely with the previous form of dynamic
dispatch and replaces it with proc pointer calls from components of
the derived type vtab.

It breaks more than it fixes, at present!
(i) abstract types are broken again - both class_10.f03 and class_12.f03 ICE;
(ii) I still have not found a satisfactory way of dealing with generic
typebound procedures, with the result that dynamic_dispatch_[n].f03 is
broken.

This latter occurs when one specific in the generic is over-ridden by
a specific with a different name; eg. line 76 in
dynamic_dispatch_1.f03.

On the bright side, the testcases in PR41829 now work :-)

Cheers

Paul

[vptr0811.diff]

---

Index: gcc/fortran/trans-expr.c
===================================================================
*** gcc/fortran/trans-expr.c (revision 153993)
--- gcc/fortran/trans-expr.c (working copy)
*************** get_proc_ptr_comp (gfc_expr *e)
*** 1524,1660 ****
  }
 
 
- /* Select a class typebound procedure at runtime.  */
- static void
- select_class_proc (gfc_se *se, gfc_class_esym_list *elist,
-   tree declared, gfc_expr *expr)
- {
-   tree end_label;
-   tree label;
-   tree tmp;
-   tree vindex;
-   stmtblock_t body;
-   gfc_class_esym_list *next_elist, *tmp_elist;
-   gfc_se tmpse;
-
-   /* Convert the vindex expression.  */
-   gfc_init_se (&tmpse, NULL);
-   gfc_conv_expr (&tmpse, elist->vindex);
-   gfc_add_block_to_block (&se->pre, &tmpse.pre);
-   vindex = gfc_evaluate_now (tmpse.expr, &se->pre);
-   gfc_add_block_to_block (&se->post, &tmpse.post);
-
-   /* Fix the function type to be that of the declared type method.  */
-   declared = gfc_create_var (TREE_TYPE (declared), "method");
-
-   end_label = gfc_build_label_decl (NULL_TREE);
-
-   gfc_init_block (&body);
-
-   /* Go through the list of extensions.  */
-   for (; elist; elist = next_elist)
-     {
-       /* This case has already been added.  */
-       if (elist->derived == NULL)
- goto free_elist;
-
-       /* Run through the chain picking up all the cases that call the
- same procedure.  */
-       tmp_elist = elist;
-       for (; elist; elist = elist->next)
- {
-  tree cval;
-
-  if (elist->esym != tmp_elist->esym)
-    continue;
-
-  cval = build_int_cst (TREE_TYPE (vindex),
- elist->derived->vindex);
-  /* Build a label for the vindex value.  */
-  label = gfc_build_label_decl (NULL_TREE);
-  tmp = fold_build3 (CASE_LABEL_EXPR, void_type_node,
-     cval, NULL_TREE, label);
-  gfc_add_expr_to_block (&body, tmp);
-
-  /* Null the reference the derived type so that this case is
-     not used again.  */
-  elist->derived = NULL;
- }
-
-       elist = tmp_elist;
-
-       /* Get a pointer to the procedure,  */
-       tmp = gfc_get_symbol_decl (elist->esym);
-       if (!POINTER_TYPE_P (TREE_TYPE (tmp)))
- {
-  gcc_assert (TREE_CODE (tmp) == FUNCTION_DECL);
-  tmp = gfc_build_addr_expr (NULL_TREE, tmp);
- }
-
-       /* Assign the pointer to the appropriate procedure.  */
-       gfc_add_modify (&body, declared,
-      fold_convert (TREE_TYPE (declared), tmp));
-
-       /* Break to the end of the construct.  */
-       tmp = build1_v (GOTO_EXPR, end_label);
-       gfc_add_expr_to_block (&body, tmp);
-
-       /* Free the elists as we go; freeing them in gfc_free_expr causes
- segfaults because it occurs too early and too often.  */
-     free_elist:
-       next_elist = elist->next;
-       if (elist->vindex)
- gfc_free_expr (elist->vindex);
-       gfc_free (elist);
-       elist = NULL;
-     }
-
-   /* Default is an error.  */
-   label = gfc_build_label_decl (NULL_TREE);
-   tmp = fold_build3 (CASE_LABEL_EXPR, void_type_node,
-     NULL_TREE, NULL_TREE, label);
-   gfc_add_expr_to_block (&body, tmp);
-   tmp = gfc_trans_runtime_error (true, &expr->where,
- "internal error: bad vindex in dynamic dispatch");
-   gfc_add_expr_to_block (&body, tmp);
-
-   /* Write the switch expression.  */
-   tmp = gfc_finish_block (&body);
-   tmp = build3_v (SWITCH_EXPR, vindex, tmp, NULL_TREE);
-   gfc_add_expr_to_block (&se->pre, tmp);
-
-   tmp = build1_v (LABEL_EXPR, end_label);
-   gfc_add_expr_to_block (&se->pre, tmp);
-
-   se->expr = declared;
-   return;
- }
-
 
  static void
  conv_function_val (gfc_se * se, gfc_symbol * sym, gfc_expr * expr)
  {
    tree tmp;
 
-   if (expr && expr->symtree
- && expr->value.function.class_esym)
-     {
-       if (!sym->backend_decl)
- sym->backend_decl = gfc_get_extern_function_decl (sym);
-
-       tmp = sym->backend_decl;
-
-       if (!POINTER_TYPE_P (TREE_TYPE (tmp)))
- {
-  gcc_assert (TREE_CODE (tmp) == FUNCTION_DECL);
-  tmp = gfc_build_addr_expr (NULL_TREE, tmp);
- }
-
-       select_class_proc (se, expr->value.function.class_esym,
- tmp, expr);
-       return;
-     }
-
    if (gfc_is_proc_ptr_comp (expr, NULL))
      tmp = get_proc_ptr_comp (expr);
    else if (sym->attr.dummy)
--- 1524,1535 ----
*************** conv_arglist_function (gfc_se *se, gfc_e
*** 2533,2538 ****
--- 2408,2468 ----
  }
 
 
+ /* Takes a derived type expression and returns the address of a temporary
+    class object of the 'declared' type.  */
+ static void
+ gfc_conv_derived_to_class (gfc_se *parmse, gfc_expr *e,
+   gfc_typespec class_ts)
+ {
+   gfc_component *cmp;
+   gfc_symbol *vtab;
+   gfc_symbol *declared = class_ts.u.derived;
+   gfc_ss *ss;
+   tree ctree;
+   tree var;
+   tree tmp;
+
+   /* The derived type needs to be converted to a temporary
+      CLASS object.  */
+   tmp = gfc_typenode_for_spec (&class_ts);
+   var = gfc_create_var (tmp, "class");
+
+   /* Set the vptr.  */
+   cmp = gfc_find_component (declared, "$vptr", true, true);
+   ctree = fold_build3 (COMPONENT_REF, TREE_TYPE (cmp->backend_decl),
+       var, cmp->backend_decl, NULL_TREE);
+
+   /* Remember the vtab corresponds to the derived type
+     not to the class declared type.  */
+   vtab = gfc_find_derived_vtab (e->ts.u.derived);
+   gcc_assert (vtab);
+   gfc_trans_assign_vtab_procs (&parmse->pre, vtab);
+   tmp = gfc_build_addr_expr (NULL_TREE, gfc_get_symbol_decl (vtab));
+   gfc_add_modify (&parmse->pre, ctree,
+  fold_convert (TREE_TYPE (ctree), tmp));
+
+   /* Now set the data field.  */
+   cmp = gfc_find_component (declared, "$data", true, true);
+   ctree = fold_build3 (COMPONENT_REF, TREE_TYPE (cmp->backend_decl),
+       var, cmp->backend_decl, NULL_TREE);
+   ss = gfc_walk_expr (e);
+   if (ss == gfc_ss_terminator)
+     {
+       gfc_conv_expr_reference (parmse, e);
+       tmp = fold_convert (TREE_TYPE (ctree), parmse->expr);
+       gfc_add_modify (&parmse->pre, ctree, tmp);
+     }
+   else
+     {
+       gfc_conv_expr (parmse, e);
+       gfc_add_modify (&parmse->pre, ctree, parmse->expr);
+     }
+
+   /* Pass the address of the class object.  */
+   parmse->expr = gfc_build_addr_expr (NULL_TREE, var);
+ }
+
+
  /* Generate code for a procedure call.  Note can return se->post != NULL.
     If se->direct_byref is set then se->expr contains the return parameter.
     Return nonzero, if the call has alternate specifiers.
*************** gfc_conv_procedure_call (gfc_se * se, gf
*** 2776,2828 ****
        else if (fsym && fsym->ts.type == BT_CLASS
  && e->ts.type == BT_DERIVED)
  {
-  tree data;
-  tree vindex;
-  tree size;
-
   /* The derived type needs to be converted to a temporary
      CLASS object.  */
   gfc_init_se (&parmse, se);
!  type = gfc_typenode_for_spec (&fsym->ts);
!  var = gfc_create_var (type, "class");
!
!  /* Get the components.  */
!  tmp = fsym->ts.u.derived->components->backend_decl;
!  data = fold_build3 (COMPONENT_REF, TREE_TYPE (tmp),
!      var, tmp, NULL_TREE);
!  tmp = fsym->ts.u.derived->components->next->backend_decl;
!  vindex = fold_build3 (COMPONENT_REF, TREE_TYPE (tmp),
! var, tmp, NULL_TREE);
!  tmp = fsym->ts.u.derived->components->next->next->backend_decl;
!  size = fold_build3 (COMPONENT_REF, TREE_TYPE (tmp),
!      var, tmp, NULL_TREE);
!
!  /* Set the vindex.  */
!  tmp = build_int_cst (TREE_TYPE (vindex), e->ts.u.derived->vindex);
!  gfc_add_modify (&parmse.pre, vindex, tmp);
!
!  /* Set the size.  */
!  tmp = TYPE_SIZE_UNIT (gfc_typenode_for_spec (&e->ts));
!  gfc_add_modify (&parmse.pre, size,
!  fold_convert (TREE_TYPE (size), tmp));
!
!  /* Now set the data field.  */
!  argss = gfc_walk_expr (e);
!  if (argss == gfc_ss_terminator)
!             {
!      gfc_conv_expr_reference (&parmse, e);
!      tmp = fold_convert (TREE_TYPE (data),
!  parmse.expr);
!      gfc_add_modify (&parmse.pre, data, tmp);
!    }
!  else
!    {
!      gfc_conv_expr (&parmse, e);
!      gfc_add_modify (&parmse.pre, data, parmse.expr);
!    }
!
!  /* Pass the address of the class object.  */
!  parmse.expr = gfc_build_addr_expr (NULL_TREE, var);
  }
        else if (se->ss && se->ss->useflags)
  {
--- 2706,2715 ----
        else if (fsym && fsym->ts.type == BT_CLASS
  && e->ts.type == BT_DERIVED)
  {
   /* The derived type needs to be converted to a temporary
      CLASS object.  */
   gfc_init_se (&parmse, se);
!  gfc_conv_derived_to_class (&parmse, e, fsym->ts);
  }
        else if (se->ss && se->ss->useflags)
  {
*************** gfc_conv_structure (gfc_se * se, gfc_exp
*** 4213,4226 ****
 
        if (cm->ts.type == BT_CLASS)
  {
   val = gfc_conv_initializer (c->expr, &cm->ts,
!      TREE_TYPE (cm->ts.u.derived->components->backend_decl),
!      cm->ts.u.derived->components->attr.dimension,
!      cm->ts.u.derived->components->attr.pointer);
 
!  /* Append it to the constructor list.  */
!  CONSTRUCTOR_APPEND_ELT (v, cm->ts.u.derived->components->backend_decl,
!  val);
  }
        else
  {
--- 4100,4127 ----
 
        if (cm->ts.type == BT_CLASS)
  {
+  gfc_component *data;
+  data = gfc_find_component (cm->ts.u.derived, "$data", true, true);
   val = gfc_conv_initializer (c->expr, &cm->ts,
!      TREE_TYPE (data->backend_decl),
!      data->attr.dimension,
!      data->attr.pointer);
 
!  CONSTRUCTOR_APPEND_ELT (v, data->backend_decl, val);
! }
!       else if (strcmp (cm->name, "$size") == 0)
! {
!  val = TYPE_SIZE_UNIT (gfc_get_derived_type (cm->ts.u.derived));
!  CONSTRUCTOR_APPEND_ELT (v, cm->backend_decl, val);
! }
!       else if (cm->initializer && cm->initializer->expr_type != EXPR_NULL
!       && strcmp (cm->name, "$extends") == 0)
! {
!  tree vtab = NULL_TREE;
!  gfc_symbol *vtabs;
!  vtabs = cm->initializer->symtree->n.sym;
!  vtab = gfc_build_addr_expr (NULL_TREE, gfc_get_symbol_decl (vtabs));
!  CONSTRUCTOR_APPEND_ELT (v, cm->backend_decl, vtab);
  }
        else
  {
*************** gfc_trans_assign (gfc_code * code)
*** 5331,5336 ****
--- 5232,5278 ----
  }
 
 
+ /* Generate code to assign typebound procedures to a derived vtab.  */
+ void gfc_trans_assign_vtab_procs (stmtblock_t *block, gfc_symbol *vtab)
+ {
+   gfc_component *cmp;
+   tree vtb;
+   tree ctree;
+   tree proc;
+   tree cond;
+   stmtblock_t body;
+
+   /* Point to the first procedure pointer.  */
+   cmp = gfc_find_component (vtab->ts.u.derived, "$extends", true, true);
+   cmp = cmp->next;
+
+   if (cmp == NULL)
+     return;
+
+   vtb = gfc_get_symbol_decl (vtab);
+
+   ctree = fold_build3 (COMPONENT_REF, TREE_TYPE (cmp->backend_decl),
+       vtb, cmp->backend_decl, NULL_TREE);
+   cond = fold_build2 (EQ_EXPR, boolean_type_node, ctree,
+      build_int_cst (TREE_TYPE (ctree), 0));
+
+   gfc_init_block (&body);
+   for (; cmp; cmp = cmp->next)
+     {
+       ctree = fold_build3 (COMPONENT_REF, TREE_TYPE (cmp->backend_decl),
+   vtb, cmp->backend_decl, NULL_TREE);
+
+       proc = gfc_get_symbol_decl (cmp->tb->u.specific->n.sym);
+       proc = gfc_build_addr_expr (TREE_TYPE (ctree), proc);
+       gfc_add_modify (&body, ctree, proc);
+     }
+
+   proc = gfc_finish_block (&body);
+   proc = build3_v (COND_EXPR, cond, proc, build_empty_stmt (input_location));
+   gfc_add_expr_to_block (block, proc);
+ }
+
+
  /* Translate an assignment to a CLASS object
     (pointer or ordinary assignment).  */
 
*************** gfc_trans_class_assign (gfc_code *code)
*** 5339,5385 ****
  {
    stmtblock_t block;
    tree tmp;
 
    gfc_start_block (&block);
 
    if (code->expr2->ts.type != BT_CLASS)
      {
!       /* Insert an additional assignment which sets the '$vindex' field.  */
!       gfc_expr *lhs,*rhs;
!       lhs = gfc_copy_expr (code->expr1);
!       gfc_add_component_ref (lhs, "$vindex");
!       if (code->expr2->ts.type == BT_DERIVED)
! /* vindex is constant, determined at compile time.  */
! rhs = gfc_int_expr (code->expr2->ts.u.derived->vindex);
!       else if (code->expr2->expr_type == EXPR_NULL)
! rhs = gfc_int_expr (0);
!       else
! gcc_unreachable ();
!       tmp = gfc_trans_assignment (lhs, rhs, false);
!       gfc_add_expr_to_block (&block, tmp);
!
!       /* Insert another assignment which sets the '$size' field.  */
        lhs = gfc_copy_expr (code->expr1);
!       gfc_add_component_ref (lhs, "$size");
        if (code->expr2->ts.type == BT_DERIVED)
  {
!  /* Size is fixed at compile time.  */
!  gfc_se lse;
!  gfc_init_se (&lse, NULL);
!  gfc_conv_expr (&lse, lhs);
!  tmp = TYPE_SIZE_UNIT (gfc_typenode_for_spec (&code->expr2->ts));
!  gfc_add_modify (&block, lse.expr,
!  fold_convert (TREE_TYPE (lse.expr), tmp));
  }
        else if (code->expr2->expr_type == EXPR_NULL)
! {
!  rhs = gfc_int_expr (0);
!  tmp = gfc_trans_assignment (lhs, rhs, false);
!  gfc_add_expr_to_block (&block, tmp);
! }
        else
  gcc_unreachable ();
 
        gfc_free_expr (lhs);
        gfc_free_expr (rhs);
      }
--- 5281,5317 ----
  {
    stmtblock_t block;
    tree tmp;
+   gfc_expr *lhs;
+   gfc_expr *rhs;
 
    gfc_start_block (&block);
 
    if (code->expr2->ts.type != BT_CLASS)
      {
!       /* Insert an additional assignment which sets the '$vptr' field.  */
        lhs = gfc_copy_expr (code->expr1);
!       gfc_add_component_ref (lhs, "$vptr");
        if (code->expr2->ts.type == BT_DERIVED)
  {
!  gfc_symbol *vtab;
!  gfc_symtree *st;
!  vtab = gfc_find_derived_vtab (code->expr2->ts.u.derived);
!  gcc_assert (vtab);
!  gfc_trans_assign_vtab_procs (&block, vtab);
!  rhs = gfc_get_expr ();
!  rhs->expr_type = EXPR_VARIABLE;
!  gfc_find_sym_tree (vtab->name, NULL, 1, &st);
!  rhs->symtree = st;
!  rhs->ts = vtab->ts;
  }
        else if (code->expr2->expr_type == EXPR_NULL)
! rhs = gfc_int_expr (0);
        else
  gcc_unreachable ();
 
+       tmp = gfc_trans_pointer_assignment (lhs, rhs);
+       gfc_add_expr_to_block (&block, tmp);
+
        gfc_free_expr (lhs);
        gfc_free_expr (rhs);
      }
Index: gcc/fortran/symbol.c
===================================================================
*** gcc/fortran/symbol.c (revision 153993)
--- gcc/fortran/symbol.c (working copy)
*************** gfc_add_save (symbol_attribute *attr, co
*** 1045,1051 ****
        return FAILURE;
      }
 
!   if (attr->save == SAVE_EXPLICIT)
      {
  if (gfc_notify_std (GFC_STD_LEGACY,
     "Duplicate SAVE attribute specified at %L",
--- 1045,1051 ----
        return FAILURE;
      }
 
!   if (attr->save == SAVE_EXPLICIT && !attr->vtab)
      {
  if (gfc_notify_std (GFC_STD_LEGACY,
     "Duplicate SAVE attribute specified at %L",
*************** gfc_type_is_extension_of (gfc_symbol *t1
*** 4592,4613 ****
  bool
  gfc_type_compatible (gfc_typespec *ts1, gfc_typespec *ts2)
  {
!   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)
! return gfc_compare_derived_types (ts1->u.derived, ts2->u.derived);
!       else
  return 0;
      }
    else
!     return (ts1->type == ts2->type);
  }
 
 
--- 4592,4916 ----
  bool
  gfc_type_compatible (gfc_typespec *ts1, gfc_typespec *ts2)
  {
!   gfc_component *cmp1, *cmp2;
!
!   bool is_class1 = (ts1->type == BT_CLASS);
!   bool is_class2 = (ts2->type == BT_CLASS);
!   bool is_derived1 = (ts1->type == BT_DERIVED);
!   bool is_derived2 = (ts2->type == BT_DERIVED);
!
!   if (!is_derived1 && !is_derived2 && !is_class1 && !is_class2)
!     return (ts1->type == ts2->type);
!
!   if (is_derived1 && is_derived2)
!     return gfc_compare_derived_types (ts1->u.derived, ts2->u.derived);
!
!   cmp1 = cmp2 = NULL;
!
!   if (is_class1)
      {
!       cmp1 = gfc_find_component (ts1->u.derived, "$data", true, false);
!       if (cmp1 == NULL)
  return 0;
      }
+
+   if (is_class2)
+     {
+       cmp2 = gfc_find_component (ts2->u.derived, "$data", true, false);
+       if (cmp2 == NULL)
+ return 0;
+     }
+
+   if (is_class1 && is_derived2)
+     return gfc_type_is_extension_of (cmp1->ts.u.derived, ts2->u.derived);
+
+   else if (is_class1 && is_class2)
+     return gfc_type_is_extension_of (cmp1->ts.u.derived, cmp2->ts.u.derived);
+
    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, bool delayed_vtab)
! {
!   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.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 '$vptr'.  */
!       if (gfc_add_component (fclass, "$vptr", &c) == FAILURE)
! return FAILURE;
!       c->ts.type = BT_DERIVED;
!       if (delayed_vtab)
! c->ts.u.derived = NULL;
!       else
! {
!  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;
!     }
!
!   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;
! }
!
!
! static void
! add_procs_to_declared_vtab1 (gfc_symtree *st, gfc_symbol *vtype)
! {
!   gfc_component *c;
!
!   if (st->left)
!     add_procs_to_declared_vtab1 (st->left, vtype);
!
!   if (st->right)
!     add_procs_to_declared_vtab1 (st->right, vtype);
!
!   if (!st->n.tb->is_generic && st->n.tb->u.specific)
!     {
!       c = gfc_find_component (vtype, st->name, true, true);
!
!       if (c == NULL)
! {
!  /* Add procedure component.  */
!  if (gfc_add_component (vtype, st->name, &c) == FAILURE)
!    return;
!  c->tb = XCNEW (gfc_typebound_proc);
!  *c->tb = *st->n.tb;
!  c->attr.procedure = 1;
!  c->attr.proc_pointer = 1;
!  c->attr.flavor = FL_PROCEDURE;
!  c->attr.access = ACCESS_PRIVATE;
!  c->attr.external = 1;
!  c->ts.interface = st->n.tb->u.specific->n.sym;
!  c->attr.untyped = 1;
!  c->attr.if_source = IFSRC_IFBODY;
!
!  /* A static initializer cannot be used here because the specific
!     function is not a constant; internal compiler error: in
!     output_constant, at varasm.c:4623  */
!  c->initializer = gfc_get_expr ();
!  c->initializer->expr_type = EXPR_NULL;
! }
!       else if (c->attr.proc_pointer && c->tb)
! {
!  *c->tb = *st->n.tb;
!  c->ts.interface = st->n.tb->u.specific->n.sym;  
! }
!     }
! }
!
!
! static void
! copy_vtab_proc_comps (gfc_symbol *declared, gfc_symbol *vtype)
! {
!   gfc_component *c, *cmp;
!   gfc_symbol *vtab;
!
!   vtab = gfc_find_derived_vtab (declared);
!
!   for (cmp = vtab->ts.u.derived->components; cmp; cmp = cmp->next)
!     {
!       if (gfc_find_component (vtype, cmp->name, true, true))
! continue;
!
!       if (gfc_add_component (vtype, cmp->name, &c) == FAILURE)
! return;
!
!       c->tb = XCNEW (gfc_typebound_proc);
!       *c->tb = *cmp->tb;
!       c->attr.procedure = 1;
!       c->attr.proc_pointer = 1;
!       c->attr.flavor = FL_PROCEDURE;
!       c->attr.access = ACCESS_PRIVATE;
!       c->attr.external = 1;
!       c->ts.interface = cmp->tb->u.specific->n.sym;
!       c->attr.untyped = 1;
!       c->attr.if_source = IFSRC_IFBODY;
!       c->initializer = gfc_get_expr ();
!       c->initializer->expr_type = EXPR_NULL;
!     }
! }
!
! static void
! add_procs_to_declared_vtab (gfc_symbol *declared, gfc_symbol *vtype,
!    gfc_symbol *derived)
! {
!   gfc_symbol* super_type;
!
!   super_type = gfc_get_derived_super_type (declared);
!
!   if (super_type && (super_type != declared))
!     add_procs_to_declared_vtab (super_type, vtype, derived);
!
!   if (declared != derived)
!     copy_vtab_proc_comps (declared, vtype);
!
!   if (declared->f2k_derived && declared->f2k_derived->tb_sym_root)
!     add_procs_to_declared_vtab1 (declared->f2k_derived->tb_sym_root, vtype);
!
!   if (declared->f2k_derived && declared->f2k_derived->tb_uop_root)
!     add_procs_to_declared_vtab1 (declared->f2k_derived->tb_uop_root, vtype);
! }
!
!
! /* 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->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);
!
!      /* 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;
! }
!      add_procs_to_declared_vtab (derived, vtype, derived);
!      vtype->attr.vtype = 1;
!    }
!
!  vtab->ts.u.derived = vtype;
!  vtab->value = gfc_default_initializer (&vtab->ts);
! }
!     }
!
!   return vtab;
  }
 
 
Index: gcc/fortran/decl.c
===================================================================
*** gcc/fortran/decl.c (revision 153993)
--- gcc/fortran/decl.c (working copy)
*************** verify_c_interop_param (gfc_symbol *sym)
*** 1025,1112 ****
  }
 
 
- /* 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.  */
 
--- 1025,1030 ----
*************** build_sym (const char *name, gfc_charlen
*** 1185,1191 ****
        sym->attr.class_ok = (sym->attr.dummy
       || sym->attr.pointer
       || sym->attr.allocatable) ? 1 : 0;
!       encapsulate_class_symbol (&sym->ts, &sym->attr, &sym->as);
      }
 
    return SUCCESS;
--- 1103,1109 ----
        sym->attr.class_ok = (sym->attr.dummy
       || sym->attr.pointer
       || sym->attr.allocatable) ? 1 : 0;
!       gfc_build_class_symbol (&sym->ts, &sym->attr, &sym->as, false);
      }
 
    return SUCCESS;
*************** build_struct (const char *name, gfc_char
*** 1594,1600 ****
 
  scalar:
    if (c->ts.type == BT_CLASS)
!     encapsulate_class_symbol (&c->ts, &c->attr, &c->as);
 
    return t;
  }
--- 1512,1518 ----
 
  scalar:
    if (c->ts.type == BT_CLASS)
!     gfc_build_class_symbol (&c->ts, &c->attr, &c->as, true);
 
    return t;
  }
*************** gfc_match_derived_decl (void)
*** 6943,6951 ****
        st->n.sym = sym;
      }
 
!   if (!sym->vindex)
!     /* Set the vindex for this type.  */
!     sym->vindex = hash_value (sym);
 
    /* Take over the ABSTRACT attribute.  */
    sym->attr.abstract = attr.abstract;
--- 6861,6869 ----
        st->n.sym = sym;
      }
 
!   if (!sym->hash_value)
!     /* Set the hash for the compound name for this type.  */
!     sym->hash_value = hash_value (sym);
 
    /* Take over the ABSTRACT attribute.  */
    sym->attr.abstract = attr.abstract;
Index: gcc/fortran/dump-parse-tree.c
===================================================================
*** gcc/fortran/dump-parse-tree.c (revision 153993)
--- gcc/fortran/dump-parse-tree.c (working copy)
*************** show_symbol (gfc_symbol *sym)
*** 827,834 ****
    if (sym->f2k_derived)
      {
        show_indent ();
!       if (sym->vindex)
! fprintf (dumpfile, "vindex: %d", sym->vindex);
        show_f2k_derived (sym->f2k_derived);
      }
 
--- 827,834 ----
    if (sym->f2k_derived)
      {
        show_indent ();
!       if (sym->hash_value)
! fprintf (dumpfile, "hash: %d", sym->hash_value);
        show_f2k_derived (sym->f2k_derived);
      }
 
Index: gcc/fortran/gfortran.h
===================================================================
*** gcc/fortran/gfortran.h (revision 153993)
--- gcc/fortran/gfortran.h (working copy)
*************** typedef struct
*** 673,678 ****
--- 673,680 ----
    unsigned extension:1; /* extends 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, pointed to by CLASS objects.  */
+   unsigned vtype:1; /* is a derived type of a vtab.  */
 
    /* These flags are both in the typespec and attribute.  The attribute
       list is what gets read from/written to a module file.  The typespec
*************** typedef struct gfc_symbol
*** 1137,1144 ****
 
    int entry_id; /* Used in resolve.c for entries.  */
 
!   /* CLASS vindex for declared and dynamic types in the class.  */
!   int vindex;
 
    struct gfc_symbol *common_next; /* Links for COMMON syms */
 
--- 1139,1146 ----
 
    int entry_id; /* Used in resolve.c for entries.  */
 
!   /* CLASS hashed name for declared and dynamic types in the class.  */
!   int hash_value;
 
    struct gfc_symbol *common_next; /* Links for COMMON syms */
 
*************** typedef struct gfc_intrinsic_sym
*** 1595,1611 ****
  gfc_intrinsic_sym;
 
 
- typedef struct gfc_class_esym_list
- {
-   gfc_symbol *derived;
-   gfc_symbol *esym;
-   struct gfc_expr *vindex;
-   struct gfc_class_esym_list *next;
- }
- gfc_class_esym_list;
-
- #define gfc_get_class_esym_list() XCNEW (gfc_class_esym_list)
-
  /* Expression nodes.  The expression node types deserve explanations,
     since the last couple can be easily misconstrued:
 
--- 1597,1602 ----
*************** typedef struct gfc_expr
*** 1718,1724 ****
        const char *name; /* Points to the ultimate name of the function */
        gfc_intrinsic_sym *isym;
        gfc_symbol *esym;
-       gfc_class_esym_list *class_esym;
      }
      function;
 
--- 1709,1714 ----
*************** gfc_try gfc_check_any_c_kind (gfc_typesp
*** 2380,2385 ****
--- 2370,2376 ----
  int gfc_validate_kind (bt, int, bool);
  int gfc_get_int_kind_from_width_isofortranenv (int size);
  int gfc_get_real_kind_from_width_isofortranenv (int size);
+ tree gfc_get_derived_type (gfc_symbol * derived);
  extern int gfc_index_integer_kind;
  extern int gfc_default_integer_kind;
  extern int gfc_max_integer_kind;
*************** void gfc_free_dt_list (void);
*** 2517,2522 ****
--- 2508,2516 ----
  gfc_gsymbol *gfc_get_gsymbol (const char *);
  gfc_gsymbol *gfc_find_gsymbol (gfc_gsymbol *, const char *);
 
+ gfc_try gfc_build_class_symbol (gfc_typespec *, symbol_attribute *,
+ gfc_array_spec **, bool);
+ gfc_symbol *gfc_find_derived_vtab (gfc_symbol *);
  gfc_typebound_proc* gfc_get_typebound_proc (void);
  gfc_symbol* gfc_get_derived_super_type (gfc_symbol*);
  gfc_symbol* gfc_get_ultimate_derived_super_type (gfc_symbol*);
Index: gcc/fortran/trans-stmt.c
===================================================================
*** gcc/fortran/trans-stmt.c (revision 153993)
--- gcc/fortran/trans-stmt.c (working copy)
*************** gfc_trans_allocate (gfc_code * code)
*** 4029,4034 ****
--- 4029,4035 ----
       gfc_expr *sz;
       gfc_se se_sz;
       sz = gfc_copy_expr (code->expr3);
+      gfc_add_component_ref (sz, "$vptr");
       gfc_add_component_ref (sz, "$size");
       gfc_init_se (&se_sz, NULL);
       gfc_conv_expr (&se_sz, sz);
*************** gfc_trans_allocate (gfc_code * code)
*** 4124,4165 ****
  {
   gfc_expr *lhs,*rhs;
   gfc_se lse;
!  /* Initialize VINDEX for CLASS objects.  */
   lhs = gfc_expr_to_initialize (expr);
!  gfc_add_component_ref (lhs, "$vindex");
   if (code->expr3 && code->expr3->ts.type == BT_CLASS)
     {
!      /* vindex must be determined at run time.  */
       rhs = gfc_copy_expr (code->expr3);
!      gfc_add_component_ref (rhs, "$vindex");
     }
   else
     {
!      /* vindex is fixed at compile time.  */
!      int vindex;
       if (code->expr3)
! vindex = code->expr3->ts.u.derived->vindex;
       else if (code->ext.alloc.ts.type == BT_DERIVED)
! vindex = code->ext.alloc.ts.u.derived->vindex;
       else if (expr->ts.type == BT_CLASS)
! vindex = expr->ts.u.derived->components->ts.u.derived->vindex;
       else
! vindex = expr->ts.u.derived->vindex;
!      rhs = gfc_int_expr (vindex);
!    }
!  tmp = gfc_trans_assignment (lhs, rhs, false);
!  gfc_free_expr (lhs);
!  gfc_free_expr (rhs);
!  gfc_add_expr_to_block (&block, tmp);
 
!  /* Initialize SIZE for CLASS objects.  */
!  lhs = gfc_expr_to_initialize (expr);
!  gfc_add_component_ref (lhs, "$size");
!  gfc_init_se (&lse, NULL);
!  gfc_conv_expr (&lse, lhs);
!  gfc_add_modify (&block, lse.expr,
!  fold_convert (TREE_TYPE (lse.expr), memsz));
!  gfc_free_expr (lhs);
  }
 
      }
--- 4125,4174 ----
  {
   gfc_expr *lhs,*rhs;
   gfc_se lse;
!
!  /* Initialize VPTR for CLASS objects.  */
   lhs = gfc_expr_to_initialize (expr);
!  gfc_add_component_ref (lhs, "$vptr");
!  rhs = NULL;
   if (code->expr3 && code->expr3->ts.type == BT_CLASS)
     {
!      /* VPTR must be determined at run time.  */
       rhs = gfc_copy_expr (code->expr3);
!      gfc_add_component_ref (rhs, "$vptr");
!      tmp = gfc_trans_pointer_assignment (lhs, rhs);
!      gfc_add_expr_to_block (&block, tmp);
!      gfc_free_expr (rhs);
     }
   else
     {
!      /* VPTR is fixed at compile time.  */
!      gfc_symbol *vtab;
!      gfc_typespec *ts;
       if (code->expr3)
! ts = &code->expr3->ts;
!      else if (expr->ts.type == BT_DERIVED)
! ts = &expr->ts;
       else if (code->ext.alloc.ts.type == BT_DERIVED)
! ts = &code->ext.alloc.ts;
       else if (expr->ts.type == BT_CLASS)
! ts = &expr->ts.u.derived->components->ts;
       else
! ts = &expr->ts;
 
!      if (ts->type == BT_DERIVED)
! {
!  vtab = gfc_find_derived_vtab (ts->u.derived);
!  gcc_assert (vtab);
!  gfc_trans_assign_vtab_procs (&block, vtab);
!  gfc_init_se (&lse, NULL);
!  lse.want_pointer = 1;
!  gfc_conv_expr (&lse, lhs);
!  tmp = gfc_build_addr_expr (NULL_TREE,
!     gfc_get_symbol_decl (vtab));
!  gfc_add_modify (&block, lse.expr,
! fold_convert (TREE_TYPE (lse.expr), tmp));
! }
!    }
  }
 
      }
Index: gcc/fortran/module.c
===================================================================
*** gcc/fortran/module.c (revision 153993)
--- gcc/fortran/module.c (working copy)
*************** mio_symbol (gfc_symbol *sym)
*** 3575,3581 ****
    mio_integer (&(sym->intmod_sym_id));
 
    if (sym->attr.flavor == FL_DERIVED)
!     mio_integer (&(sym->vindex));
 
    mio_rparen ();
  }
--- 3575,3581 ----
    mio_integer (&(sym->intmod_sym_id));
 
    if (sym->attr.flavor == FL_DERIVED)
!     mio_integer (&(sym->hash_value));
 
    mio_rparen ();
  }
Index: gcc/fortran/trans-types.c
===================================================================
*** gcc/fortran/trans-types.c (revision 153993)
--- gcc/fortran/trans-types.c (working copy)
*************** along with GCC; see the file COPYING3.  
*** 53,60 ****
  /* array of structs so we don't have to worry about xmalloc or free */
  CInteropKind_t c_interop_kinds_table[ISOCBINDING_NUMBER];
 
- static tree gfc_get_derived_type (gfc_symbol * derived);
-
  tree gfc_array_index_type;
  tree gfc_array_range_type;
  tree gfc_character1_type_node;
--- 53,58 ----
*************** gfc_get_ppc_type (gfc_component* c)
*** 1941,1947 ****
     at the same time.  If an equal derived type has been built
     in a parent namespace, this is used.  */
 
! static tree
  gfc_get_derived_type (gfc_symbol * derived)
  {
    tree typenode = NULL, field = NULL, field_type = NULL, fieldlist = NULL;
--- 1939,1945 ----
     at the same time.  If an equal derived type has been built
     in a parent namespace, this is used.  */
 
! tree
  gfc_get_derived_type (gfc_symbol * derived)
  {
    tree typenode = NULL, field = NULL, field_type = NULL, fieldlist = NULL;
Index: gcc/fortran/trans.h
===================================================================
*** gcc/fortran/trans.h (revision 153993)
--- gcc/fortran/trans.h (working copy)
*************** tree gfc_trans_assignment (gfc_expr *, g
*** 490,495 ****
--- 490,498 ----
  /* Generate code for a pointer assignment.  */
  tree gfc_trans_pointer_assignment (gfc_expr *, gfc_expr *);
 
+ /* Generate code to assign typebound procedures to a derived vtab.  */
+ void gfc_trans_assign_vtab_procs (stmtblock_t*, gfc_symbol*);
+
  /* Initialize function decls for library functions.  */
  void gfc_build_intrinsic_lib_fndecls (void);
  /* Create function decls for IO library functions.  */
Index: gcc/fortran/resolve.c
===================================================================
*** gcc/fortran/resolve.c (revision 153993)
--- gcc/fortran/resolve.c (working copy)
*************** resolve_typebound_static (gfc_expr* e, g
*** 4919,4925 ****
     the expression into a call of that binding.  */
 
  static gfc_try
! resolve_typebound_generic_call (gfc_expr* e)
  {
    gfc_typebound_proc* genproc;
    const char* genname;
--- 4919,4925 ----
     the expression into a call of that binding.  */
 
  static gfc_try
! resolve_typebound_generic_call (gfc_expr* e, const char **name)
  {
    gfc_typebound_proc* genproc;
    const char* genname;
*************** resolve_typebound_generic_call (gfc_expr
*** 4975,4980 ****
--- 4975,4984 ----
   if (matches)
     {
       e->value.compcall.tbp = g->specific;
+      /* Pass along the name for CLASS methods, where the vtab
+ procedure pointer component has to be referenced.  */
+      if (name)
+ *name = g->specific->u.specific->name;
       goto success;
     }
  }
*************** success:
*** 4993,4999 ****
  /* Resolve a call to a type-bound subroutine.  */
 
  static gfc_try
! resolve_typebound_call (gfc_code* c)
  {
    gfc_actual_arglist* newactual;
    gfc_symtree* target;
--- 4997,5003 ----
  /* Resolve a call to a type-bound subroutine.  */
 
  static gfc_try
! resolve_typebound_call (gfc_code* c, const char **name)
  {
    gfc_actual_arglist* newactual;
    gfc_symtree* target;
*************** resolve_typebound_call (gfc_code* c)
*** 5009,5015 ****
    if (check_typebound_baseobject (c->expr1) == FAILURE)
      return FAILURE;
 
!   if (resolve_typebound_generic_call (c->expr1) == FAILURE)
      return FAILURE;
 
    /* Transform into an ordinary EXEC_CALL for now.  */
--- 5013,5024 ----
    if (check_typebound_baseobject (c->expr1) == FAILURE)
      return FAILURE;
 
!   /* Pass along the name for CLASS methods, where the vtab
!      procedure pointer component has to be referenced.  */
!   if (name)
!     *name = c->expr1->value.compcall.name;
!
!   if (resolve_typebound_generic_call (c->expr1, name) == FAILURE)
      return FAILURE;
 
    /* Transform into an ordinary EXEC_CALL for now.  */
*************** resolve_typebound_call (gfc_code* c)
*** 5033,5063 ****
  }
 
 
! /* Resolve a component-call expression.  This originally was intended
!    only to see functions.  However, it is convenient to use it in
!    resolving subroutine class methods, since we do not have to add a
!    gfc_code each time. */
  static gfc_try
! resolve_compcall (gfc_expr* e, bool fcn)
  {
    gfc_actual_arglist* newactual;
    gfc_symtree* target;
 
    /* Check that's really a FUNCTION.  */
!   if (fcn && !e->value.compcall.tbp->function)
      {
        gfc_error ("'%s' at %L should be a FUNCTION",
  e->value.compcall.name, &e->where);
        return FAILURE;
      }
-   else if (!fcn && !e->value.compcall.tbp->subroutine)
-     {
-       /* To resolve class member calls, we borrow this bit
-          of code to select the specific procedures.  */
-       gfc_error ("'%s' at %L should be a SUBROUTINE",
- e->value.compcall.name, &e->where);
-       return FAILURE;
-     }
 
    /* These must not be assign-calls!  */
    gcc_assert (!e->value.compcall.assign);
--- 5042,5061 ----
  }
 
 
! /* Resolve a component-call expression.  */
  static gfc_try
! resolve_compcall (gfc_expr* e, const char **name)
  {
    gfc_actual_arglist* newactual;
    gfc_symtree* target;
 
    /* Check that's really a FUNCTION.  */
!   if (!e->value.compcall.tbp->function)
      {
        gfc_error ("'%s' at %L should be a FUNCTION",
  e->value.compcall.name, &e->where);
        return FAILURE;
      }
 
    /* These must not be assign-calls!  */
    gcc_assert (!e->value.compcall.assign);
*************** resolve_compcall (gfc_expr* e, bool fcn)
*** 5065,5071 ****
    if (check_typebound_baseobject (e) == FAILURE)
      return FAILURE;
 
!   if (resolve_typebound_generic_call (e) == FAILURE)
      return FAILURE;
    gcc_assert (!e->value.compcall.tbp->is_generic);
 
--- 5063,5074 ----
    if (check_typebound_baseobject (e) == FAILURE)
      return FAILURE;
 
!   /* Pass along the name for CLASS methods, where the vtab
!      procedure pointer component has to be referenced.  */
!   if (name)
!     *name = e->value.compcall.name;
!
!   if (resolve_typebound_generic_call (e, name) == FAILURE)
      return FAILURE;
    gcc_assert (!e->value.compcall.tbp->is_generic);
 
*************** resolve_compcall (gfc_expr* e, bool fcn)
*** 5082,5088 ****
    e->value.function.actual = newactual;
    e->value.function.name = e->value.compcall.name;
    e->value.function.esym = target->n.sym;
-   e->value.function.class_esym = NULL;
    e->value.function.isym = NULL;
    e->symtree = target;
    e->ts = target->n.sym->ts;
--- 5085,5090 ----
*************** resolve_compcall (gfc_expr* e, bool fcn)
*** 5091,5264 ****
    /* Resolution is not necessary if this is a class subroutine; this
       function only has to identify the specific proc. Resolution of
       the call will be done next in resolve_typebound_call.  */
!   return fcn ? gfc_resolve_expr (e) : SUCCESS;
! }
!
!
! /* Resolve a typebound call for the members in a class.  This group of
!    functions implements dynamic dispatch in the provisional version
!    of f03 OOP.  As soon as vtables are in place and contain pointers
!    to methods, this will no longer be necessary.  */
! static gfc_expr *list_e;
! static void check_class_members (gfc_symbol *);
! static gfc_try class_try;
! static bool fcn_flag;
! static gfc_symbol *class_object;
!
!
! static void
! check_members (gfc_symbol *derived)
! {
!   if (derived->attr.flavor == FL_DERIVED)
!     check_class_members (derived);
! }
!
!
! static void
! check_class_members (gfc_symbol *derived)
! {
!   gfc_symbol* tbp_sym;
!   gfc_expr *e;
!   gfc_symtree *tbp;
!   gfc_class_esym_list *etmp;
!
!   e = gfc_copy_expr (list_e);
!
!   tbp = gfc_find_typebound_proc (derived, &class_try,
! e->value.compcall.name,
! false, &e->where);
!
!   if (tbp == NULL)
!     {
!       gfc_error ("no typebound available procedure named '%s' at %L",
! e->value.compcall.name, &e->where);
!       return;
!     }
!
!   if (tbp->n.tb->is_generic)
!     {
!       tbp_sym = NULL;
!
!       /* If we have to match a passed class member, force the actual
! expression to have the correct type.  */
!       if (!tbp->n.tb->nopass)
! {
!  if (e->value.compcall.base_object == NULL)
!    e->value.compcall.base_object =
! extract_compcall_passed_object (e);
!
!           e->value.compcall.base_object->ts.type = BT_DERIVED;
!           e->value.compcall.base_object->ts.u.derived = derived;
! }
!     }
!   else
!     tbp_sym = tbp->n.tb->u.specific->n.sym;
!
!   e->value.compcall.tbp = tbp->n.tb;
!   e->value.compcall.name = tbp->name;
!
!   /* Let the original expresssion catch the assertion in
!      resolve_compcall, since this flag does not appear to be reset or
!      copied in some systems.  */
!   e->value.compcall.assign = 0;
!
!   /* Do the renaming, PASSing, generic => specific and other
!      good things for each class member.  */
!   class_try = (resolve_compcall (e, fcn_flag) == SUCCESS)
! ? class_try : FAILURE;
!
!   /* Now transfer the found symbol to the esym list.  */
!   if (class_try == SUCCESS)
!     {
!       etmp = list_e->value.function.class_esym;
!       list_e->value.function.class_esym
! = gfc_get_class_esym_list();
!       list_e->value.function.class_esym->next = etmp;
!       list_e->value.function.class_esym->derived = derived;
!       list_e->value.function.class_esym->esym
! = e->value.function.esym;
!     }
!
!   gfc_free_expr (e);
!  
!   /* Burrow down into grandchildren types.  */
!   if (derived->f2k_derived)
!     gfc_traverse_ns (derived->f2k_derived, check_members);
! }
!
!
! /* Eliminate esym_lists where all the members point to the
!    typebound procedure of the declared type; ie. one where
!    type selection has no effect..  */
! static void
! resolve_class_esym (gfc_expr *e)
! {
!   gfc_class_esym_list *p, *q;
!   bool empty = true;
!
!   gcc_assert (e && e->expr_type == EXPR_FUNCTION);
!
!   p = e->value.function.class_esym;
!   if (p == NULL)
!     return;
!
!   for (; p; p = p->next)
!     empty = empty && (e->value.function.esym == p->esym);
!
!   if (empty)
!     {
!       p = e->value.function.class_esym;
!       for (; p; p = q)
! {
!  q = p->next;
!  gfc_free (p);
! }
!       e->value.function.class_esym = NULL;
!    }
! }
!
!
! /* Generate an expression for the vindex, 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)
! {
!   gfc_expr *vindex;
!   gfc_ref *ref;
!
!   /* Build an expression for the correct vindex; 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;
!     }
!   else
!     {
!       gfc_free_ref_list (new_ref);
!       new_ref = ref;
!     }
!   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;
!
!   return vindex;
  }
 
 
  /* Get the ultimate declared type from an expression.  In addition,
     return the last class/derived type reference and the copy of the
     reference list.  */
  static gfc_symbol*
  get_declared_from_expr (gfc_ref **class_ref, gfc_ref **new_ref,
  gfc_expr *e)
--- 5093,5106 ----
    /* Resolution is not necessary if this is a class subroutine; this
       function only has to identify the specific proc. Resolution of
       the call will be done next in resolve_typebound_call.  */
!   return gfc_resolve_expr (e);
  }
 
 
  /* Get the ultimate declared type from an expression.  In addition,
     return the last class/derived type reference and the copy of the
     reference list.  */
+
  static gfc_symbol*
  get_declared_from_expr (gfc_ref **class_ref, gfc_ref **new_ref,
  gfc_expr *e)
*************** get_declared_from_expr (gfc_ref **class_
*** 5289,5321 ****
  }
 
 
- /* Resolve the argument expressions so that any arguments expressions
-    that include class methods are resolved before the current call.
-    This is necessary because of the static variables used in CLASS
-    method resolution.  */
- static void
- resolve_arg_exprs (gfc_actual_arglist *arg)
- {
-   /* Resolve the actual arglist expressions.  */
-   for (; arg; arg = arg->next)
-     {
-       if (arg->expr)
- gfc_resolve_expr (arg->expr);
-     }
- }
-
-
  /* Resolve a CLASS typebound function, or 'method'.  */
  static gfc_try
  resolve_class_compcall (gfc_expr* e)
  {
!   gfc_symbol *derived, *declared;
    gfc_ref *new_ref;
    gfc_ref *class_ref;
    gfc_symtree *st;
 
    st = e->symtree;
-   class_object = st->n.sym;
 
    /* Get the CLASS declared type.  */
    declared = get_declared_from_expr (&class_ref, &new_ref, e);
--- 5131,5148 ----
  }
 
 
  /* Resolve a CLASS typebound function, or 'method'.  */
+
  static gfc_try
  resolve_class_compcall (gfc_expr* e)
  {
!   gfc_symbol *declared;
    gfc_ref *new_ref;
    gfc_ref *class_ref;
    gfc_symtree *st;
+   const char *name;
 
    st = e->symtree;
 
    /* Get the CLASS declared type.  */
    declared = get_declared_from_expr (&class_ref, &new_ref, e);
*************** resolve_class_compcall (gfc_expr* e)
*** 5324,5376 ****
    if (class_ref && class_ref->u.c.component->ts.type == BT_DERIVED)
      {
        gfc_free_ref_list (new_ref);
!       return resolve_compcall (e, true);
      }
 
!   /* Resolve the argument expressions,  */
!   resolve_arg_exprs (e->value.function.actual);
!
!   /* Get the data component, which is of the declared type.  */
!   derived = declared->components->ts.u.derived;
!
!   /* Resolve the function call for each member of the class.  */
!   class_try = SUCCESS;
!   fcn_flag = true;
!   list_e = gfc_copy_expr (e);
!   check_class_members (derived);
 
!   class_try = (resolve_compcall (e, true) == SUCCESS)
! ? class_try : FAILURE;
 
!   /* Transfer the class list to the original expression.  Note that
!      the class_esym list is cleaned up in trans-expr.c, as the calls
!      are translated.  */
!   e->value.function.class_esym = list_e->value.function.class_esym;
!   list_e->value.function.class_esym = NULL;
!   gfc_free_expr (list_e);
!
!   resolve_class_esym (e);
 
!   /* More than one typebound procedure so transmit an expression for
!      the vindex as the selector.  */
!   if (e->value.function.class_esym != NULL)
!     e->value.function.class_esym->vindex
! = vindex_expr (class_ref, new_ref, declared, st);
 
!   return class_try;
  }
 
  /* Resolve a CLASS typebound subroutine, or 'method'.  */
  static gfc_try
  resolve_class_typebound_call (gfc_code *code)
  {
!   gfc_symbol *derived, *declared;
    gfc_ref *new_ref;
    gfc_ref *class_ref;
    gfc_symtree *st;
 
    st = code->expr1->symtree;
-   class_object = st->n.sym;
 
    /* Get the CLASS declared type.  */
    declared = get_declared_from_expr (&class_ref, &new_ref, code->expr1);
--- 5151,5191 ----
    if (class_ref && class_ref->u.c.component->ts.type == BT_DERIVED)
      {
        gfc_free_ref_list (new_ref);
!       return resolve_compcall (e, NULL);
      }
 
!   /* Treat the call as if it is a typebound procedure, in order to roll
!      out the correct name for the specific function.  */
!   resolve_compcall (e, &name);
 
!   /* Then convert the expression to a procedure pointer component call.  */
!   e->value.function.esym = NULL;
!   e->symtree = st;
 
!   if (class_ref)  
!     {
!       gfc_free_ref_list (class_ref->next);
!       e->ref = new_ref;
!     }
 
!   /* '$vptr' points to the vtab, which contains the procedure pointers.  */
!   gfc_add_component_ref (e, "$vptr");
!   gfc_add_component_ref (e, name);
 
!   return SUCCESS;
  }
 
  /* Resolve a CLASS typebound subroutine, or 'method'.  */
  static gfc_try
  resolve_class_typebound_call (gfc_code *code)
  {
!   gfc_symbol *declared;
    gfc_ref *new_ref;
    gfc_ref *class_ref;
    gfc_symtree *st;
+   const char *name;
 
    st = code->expr1->symtree;
 
    /* Get the CLASS declared type.  */
    declared = get_declared_from_expr (&class_ref, &new_ref, code->expr1);
*************** resolve_class_typebound_call (gfc_code *
*** 5379,5418 ****
    if (class_ref && class_ref->u.c.component->ts.type == BT_DERIVED)
      {
        gfc_free_ref_list (new_ref);
!       return resolve_typebound_call (code);
      }
 
!   /* Resolve the argument expressions,  */
!   resolve_arg_exprs (code->expr1->value.compcall.actual);
 
!   /* Get the data component, which is of the declared type.  */
!   derived = declared->components->ts.u.derived;
 
!   class_try = SUCCESS;
!   fcn_flag = false;
!   list_e = gfc_copy_expr (code->expr1);
!   check_class_members (derived);
!
!   class_try = (resolve_typebound_call (code) == SUCCESS)
! ? class_try : FAILURE;
!
!   /* Transfer the class list to the original expression.  Note that
!      the class_esym list is cleaned up in trans-expr.c, as the calls
!      are translated.  */
!   code->expr1->value.function.class_esym
! = list_e->value.function.class_esym;
!   list_e->value.function.class_esym = NULL;
!   gfc_free_expr (list_e);
!
!   resolve_class_esym (code->expr1);
!
!   /* More than one typebound procedure so transmit an expression for
!      the vindex 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);
 
!   return class_try;
  }
 
 
--- 5194,5219 ----
    if (class_ref && class_ref->u.c.component->ts.type == BT_DERIVED)
      {
        gfc_free_ref_list (new_ref);
!       return resolve_typebound_call (code, NULL);
      }
 
!   resolve_typebound_call (code, &name);
 
!   /* Then convert the expression to a procedure pointer component call.  */
!   code->expr1->value.function.esym = NULL;
!   code->expr1->symtree = st;
 
!   if (class_ref)  
!     {
!       gfc_free_ref_list (class_ref->next);
!       code->expr1->ref = new_ref;
!     }
!
!   /* '$vptr' points to the vtab, which contains the procedure pointers.  */
!   gfc_add_component_ref (code->expr1, "$vptr");
!   gfc_add_component_ref (code->expr1, name);
 
!   return SUCCESS;
  }
 
 
*************** gfc_resolve_expr (gfc_expr *e)
*** 5529,5535 ****
        if (e->symtree && e->symtree->n.sym->ts.type == BT_CLASS)
  t = resolve_class_compcall (e);
        else
! t = resolve_compcall (e, true);
        break;
 
      case EXPR_SUBSTRING:
--- 5330,5336 ----
        if (e->symtree && e->symtree->n.sym->ts.type == BT_CLASS)
  t = resolve_class_compcall (e);
        else
! t = resolve_compcall (e, NULL);
        break;
 
      case EXPR_SUBSTRING:
*************** resolve_select_type (gfc_code *code)
*** 6944,6957 ****
 
    /* Transform to EXEC_SELECT.  */
    code->op = EXEC_SELECT;
!   gfc_add_component_ref (code->expr1, "$vindex");
 
    /* 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.  */
--- 6745,6759 ----
 
    /* Transform to EXEC_SELECT.  */
    code->op = EXEC_SELECT;
!   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->hash_value);
        else if (c->ts.type == BT_CLASS)
  /* Currently IS CLASS blocks are simply ignored.
    TODO: Implement IS CLASS.  */
*************** resolve_code (gfc_code *code, gfc_namesp
*** 7942,7948 ****
  && code->expr1->symtree->n.sym->ts.type == BT_CLASS)
     resolve_class_typebound_call (code);
   else
!    resolve_typebound_call (code);
   break;
 
  case EXEC_CALL_PPC:
--- 7744,7750 ----
  && code->expr1->symtree->n.sym->ts.type == BT_CLASS)
     resolve_class_typebound_call (code);
   else
!    resolve_typebound_call (code, NULL);
   break;
 
  case EXEC_CALL_PPC:
*************** resolve_fl_derived (gfc_symbol *sym)
*** 10226,10231 ****
--- 10028,10036 ----
  {
   gfc_symbol* me_arg;
 
+  if (c->ts.interface && c->ts.interface->formal && !c->formal)
+    c->formal = c->ts.interface->formal;
+
   if (c->tb->pass_arg)
     {
       gfc_formal_arglist* i;
*************** resolve_fl_derived (gfc_symbol *sym)
*** 10274,10280 ****
   gcc_assert (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
   && me_arg->ts.u.derived->components->ts.u.derived != sym))
     {
       gfc_error ("Argument '%s' of '%s' with PASS(%s) at %L must be of"
--- 10079,10085 ----
   gcc_assert (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)
!      || (!sym->attr.vtype && me_arg->ts.type == BT_CLASS
   && me_arg->ts.u.derived->components->ts.u.derived != sym))
     {
       gfc_error ("Argument '%s' of '%s' with PASS(%s) at %L must be of"
Index: gcc/fortran/trans-decl.c
===================================================================
*** gcc/fortran/trans-decl.c (revision 153993)
--- gcc/fortran/trans-decl.c (working copy)
*************** gfc_create_module_variable (gfc_symbol *
*** 3405,3411 ****
        && (sym->equiv_built || sym->attr.in_equivalence))
      return;
 
!   if (sym->backend_decl)
      internal_error ("backend decl for module variable %s already exists",
     sym->name);
 
--- 3405,3411 ----
        && (sym->equiv_built || sym->attr.in_equivalence))
      return;
 
!   if (sym->backend_decl && !sym->attr.vtab)
      internal_error ("backend decl for module variable %s already exists",
     sym->name);
 
Index: gcc/fortran/parse.c
===================================================================
*** gcc/fortran/parse.c (revision 153993)
--- gcc/fortran/parse.c (working copy)
*************** endType:
*** 2091,2096 ****
--- 2091,2112 ----
   || c->attr.access == ACCESS_PRIVATE
   || (c->ts.type == BT_DERIVED && c->ts.u.derived->attr.private_comp))
  sym->attr.private_comp = 1;
+
+      /* Fix up incomplete CLASS components.  */
+      if (c->ts.type == BT_CLASS)
+ {
+  gfc_component *data;
+  gfc_component *vptr;
+  gfc_symbol *vtab;
+  data = gfc_find_component (c->ts.u.derived, "$data", true, true);
+  vptr = gfc_find_component (c->ts.u.derived, "$vptr", true, true);
+  if (vptr->ts.u.derived == NULL)
+    {
+      vtab = gfc_find_derived_vtab (data->ts.u.derived);
+      gcc_assert (vtab);
+      vptr->ts.u.derived = vtab->ts.u.derived;
+    }
+ }
      }
 
    if (!seen_component)
Index: gcc/fortran/trans-intrinsic.c
===================================================================
*** gcc/fortran/trans-intrinsic.c (revision 153993)
--- gcc/fortran/trans-intrinsic.c (working copy)
*************** gfc_conv_same_type_as (gfc_se *se, gfc_e
*** 4721,4734 ****
    b = expr->value.function.actual->next->expr;
 
    if (a->ts.type == BT_CLASS)
!     gfc_add_component_ref (a, "$vindex");
    else if (a->ts.type == BT_DERIVED)
!     a = gfc_int_expr (a->ts.u.derived->vindex);
 
    if (b->ts.type == BT_CLASS)
!     gfc_add_component_ref (b, "$vindex");
    else if (b->ts.type == BT_DERIVED)
!     b = gfc_int_expr (b->ts.u.derived->vindex);
 
    gfc_conv_expr (&se1, a);
    gfc_conv_expr (&se2, b);
--- 4721,4740 ----
    b = expr->value.function.actual->next->expr;
 
    if (a->ts.type == BT_CLASS)
!     {
!       gfc_add_component_ref (a, "$vptr");
!       gfc_add_component_ref (a, "$hash");
!     }
    else if (a->ts.type == BT_DERIVED)
!     a = gfc_int_expr (a->ts.u.derived->hash_value);
 
    if (b->ts.type == BT_CLASS)
!     {
!       gfc_add_component_ref (b, "$vptr");
!       gfc_add_component_ref (b, "$hash");
!     }
    else if (b->ts.type == BT_DERIVED)
!     b = gfc_int_expr (b->ts.u.derived->hash_value);
 
    gfc_conv_expr (&se1, a);
    gfc_conv_expr (&se2, b);

---

[Dominique Dhumieres]

Damian,

Usual questions: which OS, bootstrap compiler, config line ...?
Are doing your build in parallel? If yes, could you try to build
in serial mode (in parallel mode the error could be hidden).
Are you redirecting the building output to a log file?
If no, try to do it: it is then easier to look for patterns.

Note that the

ranlib: file: .libs/libgomp.a(mutex.o) has no symbols
...

are harmless (I don't know why they are there).
Did you send the end of the bootstrap messages? If yes
you may want to try make install.

Dominique

[Rouson, Damian]

Dominique,

Here¹s the requested info:

Mac OS X 10.5.8

Bootstrap compiler:
i686-apple-darwin9-gcc-4.0.1 (GCC) 4.0.1 (Apple Inc. build 5490)

Config line:
/Users/rouson/fortran-dev/configure --program-suffix=-4.5 \
--enable-checking=release --prefix=/usr/local/gfortran \
--enable-languages=c,fortran --enable-version-specific-runtime-libs \
--build=i686-apple-darwin9 --host=i686-apple-darwin9 \
--target=i686-apple-darwin9 --disable-bootstrap --disable-multilib \
--with-gmp=/opt/local  --with-mpfr=/opt/local

I don¹t know how to do a parallel build (unless you¹re referring to the ³-j²
option on make, which I¹m not using), so presumably I¹m doing a serial
build.

Attached are the output of configure, make and make install.  It appears
appears configure, make, and make install are completing successfully (I had
to find my old configure line), but I get the same error when I compile a
"Hello, world!" program:

$ /Users/rouson/fortran-obj/gcc/gfortran hello.f90
gfortran: error trying to exec 'f951': execvp: No such file or directory

Damian



On 11/8/09 12:38 PM, "dominiq@..." <dominiq@...> wrote:

> Damian,
>
> Usual questions: which OS, bootstrap compiler, config line ...?
> Are doing your build in parallel? If yes, could you try to build
> in serial mode (in parallel mode the error could be hidden).
> Are you redirecting the building output to a log file?
> If no, try to do it: it is then easier to look for patterns.
>
> Note that the
>
> ranlib: file: .libs/libgomp.a(mutex.o) has no symbols
> ...
>
> are harmless (I don't know why they are there).
> Did you send the end of the bootstrap messages? If yes
> you may want to try make install.
>
> Dominique
>
>

[Rouson, Damian]

It appears it's working.  I was trying to run the compiler executable that
was in my build try when I should have been running it in the location
specified by my configure line --prefix argument.  I'm now going to do some
testing of the latest OOP features.

Hopefully once I get in the habit of updating and building more frequently
to keep up with the latest features, I'll also become better at building.

Damian


On 11/8/09 12:38 PM, "dominiq@..." <dominiq@...> wrote:

> Damian,
>
> Usual questions: which OS, bootstrap compiler, config line ...?
> Are doing your build in parallel? If yes, could you try to build
> in serial mode (in parallel mode the error could be hidden).
> Are you redirecting the building output to a log file?
> If no, try to do it: it is then easier to look for patterns.
>
> Note that the
>
> ranlib: file: .libs/libgomp.a(mutex.o) has no symbols
> ...
>
> are harmless (I don't know why they are there).
> Did you send the end of the bootstrap messages? If yes
> you may want to try make install.
>
> Dominique
>
>

[Salvatore Filippone]

Paul,
I tried (in a rather careless fashion) to apply the patch to the
fortran-dev branch, but it does not apply cleanly and bootstrap is
broken, presumably because of it, with a bunch of errors in resolve.c.
../../gcc-dev/gcc/fortran/resolve.c: In function ‘resolve_compcall’:
../../gcc-dev/gcc/fortran/resolve.c:5093:10: error: ‘fcn’ undeclared (first use in this function)
../../gcc-dev/gcc/fortran/resolve.c:5093:10: error: (Each undeclared identifier is reported only once
../../gcc-dev/gcc/fortran/resolve.c:5093:10: error: for each function it appears in.)
cc1: warnings being treated as errors
../../gcc-dev/gcc/fortran/resolve.c: In function ‘check_class_members’:
../../gcc-dev/gcc/fortran/resolve.c:5166:3: error: passing argument 2 of ‘resolve_compcall’ makes pointer from integer without a cast
../../gcc-dev/gcc/fortran/resolve.c:5044:1: note: expected ‘const char **’ but argument is of type ‘unsigned char’
../../gcc-dev/gcc/fortran/resolve.c:5172:36: error: ‘struct <anonymous>’ has no member named ‘class_esym’
........


Is there anything obvious I am missing, or should I just wait a little
bit more?

Thanks
Salvatore

[Paul Richard Thomas]

Salvatore,

You will note that the patch is "relative to trunk".  Janus quite
correctly took me to task for this :-)  My excuse is that I only have
room for trunk on my laptop!  I will try to make the conversion to
fortran-dev in the next 48 hours.  I have a fix in mind for generic
procedures, which I will try at the same time.


> Is there anything obvious I am missing, or should I just wait a little
> bit more?

You missed the qualifier, relative to trunk, but "no" apart from that :-)

Thanks for the help.

Paul

[Salvatore Filippone]

Il giorno lun, 09/11/2009 alle 13.19 +0100, Paul Richard Thomas ha
scritto:
> Salvatore,
>
> You will note that the patch is "relative to trunk".  Janus quite
> correctly took me to task for this :-)  My excuse is that I only have
> room for trunk on my laptop!  I will try to make the conversion to
> fortran-dev in the next 48 hours.  I have a fix in mind for generic
> procedures, which I will try at the same time.
>
Great; without generics there are very few runtime tests I can
perform....

Standing by

Salvatore

[Janus Weil-3]

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

[class_is_sort.diff]

---

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:

---

[Janus Weil-3]

> 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.)

Here you go. Enjoy :)

Cheers,
Janus


2009-11-09  Janus Weil  <janus@...>

        * decl.c (gfc_match_derived_decl): Set extension level.
        * gfortran.h (symbol_attribute): Expand 'extension' bitfield to 8 bit.
        * iresolve.c (gfc_resolve_extends_type_of): Return value of
        'is_extension_of' has kind=4.
        * match.c (select_type_set_tmp,gfc_match_class_is): Create temporary
        for CLASS IS blocks.
        * module.c (ab_attribute,attr_bits): Remove AB_EXTENSION.
        (mio_symbol_attribute): Handle expanded 'extension' field.
        * resolve.c (resolve_select_type): Implement CLASS IS blocks.
        (resolve_fl_variable_derived): Show correct type name.
        * symbol.c (gfc_build_class_symbol): Set extension level.


2009-11-09  Janus Weil  <janus@...>

        * gfortran.dg/extends_type_of_1.f03: Fix invalid test case.
        * gfortran.dg/module_md5_1.f90: Adjusted MD5 sum.
        * gfortran.dg/select_type_1.f03: Remove FIXMEs.
        * gfortran.dg/select_type_2.f03: Ditto.
        * gfortran.dg/select_type_8.f03: New test.

[Paul Richard Thomas]

Dear Janus,

The patch looks OK to me - apply it to the branch if you have not
already done so.

I too think that 255 ancestors should be quite enough :-)  However,
+  fclass->attr.extension = ts->u.derived->attr.extension + 1;
could do with an error or a warning if the result overflows.

I have now cleared all the obstacles to implementing generic methods;
it turned out to be a bit more cumbersome than anticipated; a
vtab-like object is needed for each generic procedure, which carries
pointers to the specific procedures.  It'll be out in a day or two.

Cheers

Paul

On Mon, Nov 9, 2009 at 9:17 PM, Janus Weil <janus@...> wrote:

> 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
>

--
The knack of flying is learning how to throw yourself at the ground and miss.
       --Hitchhikers Guide to the Galaxy