fortran/

[pf3gnuchains/gcc-fork.git] / gcc / fortran / class.c

diff --git a/gcc/fortran/class.c b/gcc/fortran/class.c
index 27c7d23..bcb2d0b 100644 (file)
--- a/gcc/fortran/class.c
+++ b/gcc/fortran/class.c
@@ -83,7 +83,8 @@ gfc_add_component_ref (gfc_expr *e, const char *name)
 
 
 /* Build a NULL initializer for CLASS pointers,
-   initializing the _data and _vptr components to zero.  */
+   initializing the _data component to NULL and
+   the _vptr component to the declared type.  */
 
 gfc_expr *
 gfc_class_null_initializer (gfc_typespec *ts)
@@ -98,9 +99,10 @@ gfc_class_null_initializer (gfc_typespec *ts)
   for (comp = ts->u.derived->components; comp; comp = comp->next)
     {
       gfc_constructor *ctor = gfc_constructor_get();
-      ctor->expr = gfc_get_expr ();
-      ctor->expr->expr_type = EXPR_NULL;
-      ctor->expr->ts = comp->ts;
+      if (strcmp (comp->name, "_vptr") == 0)
+       ctor->expr = gfc_lval_expr_from_sym (gfc_find_derived_vtab (ts->u.derived));
+      else
+       ctor->expr = gfc_get_null_expr (NULL);
       gfc_constructor_append (&init->value.constructor, ctor);
     }
 
@@ -114,13 +116,16 @@ gfc_class_null_initializer (gfc_typespec *ts)
 
 static void
 get_unique_type_string (char *string, gfc_symbol *derived)
-{  
+{
+  char dt_name[GFC_MAX_SYMBOL_LEN+1];
+  sprintf (dt_name, "%s", derived->name);
+  dt_name[0] = TOUPPER (dt_name[0]);
   if (derived->module)
-    sprintf (string, "%s_%s", derived->module, derived->name);
+    sprintf (string, "%s_%s", derived->module, dt_name);
   else if (derived->ns->proc_name)
-    sprintf (string, "%s_%s", derived->ns->proc_name->name, derived->name);
+    sprintf (string, "%s_%s", derived->ns->proc_name->name, dt_name);
   else
-    sprintf (string, "_%s", derived->name);
+    sprintf (string, "_%s", dt_name);
 }
 
 
@@ -132,9 +137,9 @@ get_unique_hashed_string (char *string, gfc_symbol *derived)
 {
   char tmp[2*GFC_MAX_SYMBOL_LEN+2];
   get_unique_type_string (&tmp[0], derived);
-  /* If string is too long, use hash value in hex representation
-     (allow for extra decoration, cf. gfc_build_class_symbol)*/
-  if (strlen (tmp) > GFC_MAX_SYMBOL_LEN - 10)
+  /* If string is too long, use hash value in hex representation (allow for
+     extra decoration, cf. gfc_build_class_symbol & gfc_find_derived_vtab).  */
+  if (strlen (tmp) > GFC_MAX_SYMBOL_LEN - 11)
     {
       int h = gfc_hash_value (derived);
       sprintf (string, "%X", h);
@@ -178,6 +183,22 @@ gfc_build_class_symbol (gfc_typespec *ts, symbol_attribute *attr,
   gfc_symbol *fclass;
   gfc_symbol *vtab;
   gfc_component *c;
+  
+  if (attr->class_ok)
+    /* Class container has already been built.  */
+    return SUCCESS;
+
+  attr->class_ok = attr->dummy || attr->pointer || attr->allocatable;
+  
+  if (!attr->class_ok)
+    /* We can not build the class container yet.  */
+    return SUCCESS;
+
+  if (*as)
+    {
+      gfc_fatal_error ("Polymorphic array at %C not yet supported");
+      return FAILURE;
+    }
 
   /* Determine the name of the encapsulating type.  */
   get_unique_hashed_string (tname, ts->u.derived);
@@ -267,6 +288,10 @@ static void
 add_proc_comp (gfc_symbol *vtype, const char *name, gfc_typebound_proc *tb)
 {
   gfc_component *c;
+
+  if (tb->non_overridable)
+    return;
+  
   c = gfc_find_component (vtype, name, true, true);
 
   if (c == NULL)
@@ -403,11 +428,11 @@ gfc_find_derived_vtab (gfc_symbol *derived)
        {
          gfc_get_symbol (name, ns, &vtab);
          vtab->ts.type = BT_DERIVED;
-         if (gfc_add_flavor (&vtab->attr, FL_VARIABLE, NULL,
+         if (gfc_add_flavor (&vtab->attr, FL_PARAMETER, NULL,
                              &gfc_current_locus) == FAILURE)
            goto cleanup;
          vtab->attr.target = 1;
-         vtab->attr.save = SAVE_EXPLICIT;
+         vtab->attr.save = SAVE_IMPLICIT;
          vtab->attr.vtab = 1;
          vtab->attr.access = ACCESS_PUBLIC;
          gfc_set_sym_referenced (vtab);
@@ -495,9 +520,9 @@ gfc_find_derived_vtab (gfc_symbol *derived)
                  sprintf (name, "__def_init_%s", tname);
                  gfc_get_symbol (name, ns, &def_init);
                  def_init->attr.target = 1;
-                 def_init->attr.save = SAVE_EXPLICIT;
+                 def_init->attr.save = SAVE_IMPLICIT;
                  def_init->attr.access = ACCESS_PUBLIC;
-                 def_init->attr.flavor = FL_VARIABLE;
+                 def_init->attr.flavor = FL_PARAMETER;
                  gfc_set_sym_referenced (def_init);
                  def_init->ts.type = BT_DERIVED;
                  def_init->ts.u.derived = derived;
@@ -527,7 +552,10 @@ gfc_find_derived_vtab (gfc_symbol *derived)
                  gfc_get_symbol (name, sub_ns, &copy);
                  sub_ns->proc_name = copy;
                  copy->attr.flavor = FL_PROCEDURE;
+                 copy->attr.subroutine = 1;
                  copy->attr.if_source = IFSRC_DECL;
+                 if (ns->proc_name->attr.flavor == FL_MODULE)
+                   copy->module = ns->proc_name->name;
                  gfc_set_sym_referenced (copy);
                  /* Set up formal arguments.  */
                  gfc_get_symbol ("src", sub_ns, &src);
@@ -548,7 +576,7 @@ gfc_find_derived_vtab (gfc_symbol *derived)
                  copy->formal->next->sym = dst;
                  /* Set up code.  */
                  sub_ns->code = gfc_get_code ();
-                 sub_ns->code->op = EXEC_ASSIGN;
+                 sub_ns->code->op = EXEC_INIT_ASSIGN;
                  sub_ns->code->expr1 = gfc_lval_expr_from_sym (dst);
                  sub_ns->code->expr2 = gfc_lval_expr_from_sym (src);
                  /* Set initializer.  */