2010-04-29 Janus Weil <janus@gcc.gnu.org>

[pf3gnuchains/gcc-fork.git] / gcc / fortran / trans-expr.c

diff --git a/gcc/fortran/trans-expr.c b/gcc/fortran/trans-expr.c
index 5f53768..4d48c05 100644 (file)
--- a/gcc/fortran/trans-expr.c
+++ b/gcc/fortran/trans-expr.c
@@ -4337,7 +4337,7 @@ gfc_conv_structure (gfc_se * se, gfc_expr * expr, int init)
       if (!c->expr || cm->attr.allocatable)
         continue;
 
-      if (cm->ts.type == BT_CLASS)
+      if (cm->ts.type == BT_CLASS && !cm->attr.proc_pointer)
        {
          gfc_component *data;
          data = gfc_find_component (cm->ts.u.derived, "$data", true, true);
@@ -5454,6 +5454,103 @@ gfc_trans_assign (gfc_code * code)
 }
 
 
+/* Generate code to assign typebound procedures to a derived vtab.  */
+void gfc_trans_assign_vtab_procs (stmtblock_t *block, gfc_symbol *dt,
+                                 gfc_symbol *vtab)
+{
+  gfc_component *cmp;
+  tree vtb;
+  tree ctree;
+  tree proc;
+  tree cond = NULL_TREE;
+  stmtblock_t body;
+  bool seen_extends;
+
+  /* Point to the first procedure pointer.  */
+  cmp = gfc_find_component (vtab->ts.u.derived, "$extends", true, true);
+
+  seen_extends = (cmp != NULL);
+
+  vtb = gfc_get_symbol_decl (vtab);
+
+  if (seen_extends)
+    {
+      cmp = cmp->next;
+      if (!cmp)
+       return;
+      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));
+    }
+  else
+    {
+      cmp = vtab->ts.u.derived->components; 
+    }
+
+  gfc_init_block (&body);
+  for (; cmp; cmp = cmp->next)
+    {
+      gfc_symbol *target = NULL;
+      
+      /* Generic procedure - build its vtab.  */
+      if (cmp->ts.type == BT_DERIVED && !cmp->tb)
+       {
+         gfc_symbol *vt = cmp->ts.interface;
+
+         if (vt == NULL)
+           {
+             /* Use association loses the interface.  Obtain the vtab
+                by name instead.  */
+             char name[2 * GFC_MAX_SYMBOL_LEN + 8];
+             sprintf (name, "vtab$%s$%s", vtab->ts.u.derived->name,
+                      cmp->name);
+             gfc_find_symbol (name, vtab->ns, 0, &vt);
+             if (vt == NULL)
+               continue;
+           }
+
+         gfc_trans_assign_vtab_procs (&body, dt, vt);
+         ctree = fold_build3 (COMPONENT_REF, TREE_TYPE (cmp->backend_decl),
+                              vtb, cmp->backend_decl, NULL_TREE);
+         proc = gfc_get_symbol_decl (vt);
+         proc = gfc_build_addr_expr (TREE_TYPE (ctree), proc);
+         gfc_add_modify (&body, ctree, proc);
+         continue;
+       }
+
+      /* This is required when typebound generic procedures are called
+        with derived type targets.  The specific procedures do not get
+        added to the vtype, which remains "empty".  */
+      if (cmp->tb && cmp->tb->u.specific && cmp->tb->u.specific->n.sym)
+       target = cmp->tb->u.specific->n.sym;
+      else
+       {
+         gfc_symtree *st;
+         st = gfc_find_typebound_proc (dt, NULL, cmp->name, false, NULL);
+         if (st->n.tb && st->n.tb->u.specific)
+           target = st->n.tb->u.specific->n.sym;
+       }
+
+      if (!target)
+       continue;
+
+      ctree = fold_build3 (COMPONENT_REF, TREE_TYPE (cmp->backend_decl),
+                          vtb, cmp->backend_decl, NULL_TREE);
+      proc = gfc_get_symbol_decl (target);
+      proc = gfc_build_addr_expr (TREE_TYPE (ctree), proc);
+      gfc_add_modify (&body, ctree, proc);
+    }
+
+  proc = gfc_finish_block (&body);
+
+  if (seen_extends)
+    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).  */