[Bug fortran/46990] [OOP] gfortran rejects passing a CLASS variable to TYPE

[janus at gcc dot gnu.org]

http://gcc.gnu.org/bugzilla/show_bug.cgi?id=46990

janus at gcc dot gnu.org changed:

           What    |Removed                     |Added
----------------------------------------------------------------------------
             Status|UNCONFIRMED                 |ASSIGNED
   Last reconfirmed|2010-12-17 20:43:55         |2010.12.17 22:04:35
         AssignedTo|unassigned at gcc dot       |janus at gcc dot gnu.org
                   |gnu.org                     |
     Ever Confirmed|0                           |1

--- Comment #4 from janus at gcc dot gnu.org 2010-12-17 22:04:35 UTC ---
Here is a preliminary patch. Hope I got the logic right ...


Index: gcc/fortran/symbol.c
===================================================================
--- gcc/fortran/symbol.c    (revision 167977)
+++ gcc/fortran/symbol.c    (working copy)
@@ -4770,21 +4770,24 @@ gfc_type_compatible (gfc_typespec *ts1, gfc_typesp
   bool is_class2 = (ts2->type == BT_CLASS);
   bool is_derived1 = (ts1->type == BT_DERIVED);
   bool is_derived2 = (ts2->type == BT_DERIVED);
+  gfc_symbol *t1,*t2;

-  if (!is_derived1 && !is_derived2 && !is_class1 && !is_class2)
+  if (!(is_derived1 || is_class1) || !(is_derived2 || is_class2))
     return (ts1->type == ts2->type);

-  if (is_derived1 && is_derived2)
-    return gfc_compare_derived_types (ts1->u.derived, ts2->u.derived);
+  t1 = ts1->u.derived;
+  t2 = ts2->u.derived;
+  
+  if (is_class2)
+    t2 = t2->components->ts.u.derived;

-  if (is_class1 && is_derived2)
-    return gfc_type_is_extension_of (ts1->u.derived->components->ts.u.derived,
-                     ts2->u.derived);
-  else if (is_class1 && is_class2)
-    return gfc_type_is_extension_of (ts1->u.derived->components->ts.u.derived,
-                     ts2->u.derived->components->ts.u.derived);
+  if (is_derived1)
+    return gfc_compare_derived_types (t1, t2);
   else
-    return 0;
+    {
+      t1 = t1->components->ts.u.derived;
+      return gfc_type_is_extension_of (t1, t2);
+    }
 }