+
+ /* Initialization via SOURCE block. */
+ if (code->expr3)
+ {
+ gfc_expr *rhs = gfc_copy_expr (code->expr3);
+ if (al->expr->ts.type == BT_CLASS)
+ {
+ gfc_se dst,src;
+ if (rhs->ts.type == BT_CLASS)
+ gfc_add_component_ref (rhs, "$data");
+ gfc_init_se (&dst, NULL);
+ gfc_init_se (&src, NULL);
+ gfc_conv_expr (&dst, expr);
+ gfc_conv_expr (&src, rhs);
+ gfc_add_block_to_block (&block, &src.pre);
+ tmp = gfc_build_memcpy_call (dst.expr, src.expr, memsz);
+ }
+ else
+ tmp = gfc_trans_assignment (gfc_expr_to_initialize (expr),
+ rhs, false, false);
+ gfc_free_expr (rhs);
+ gfc_add_expr_to_block (&block, tmp);
+ }
+
+ /* Allocation of CLASS entities. */
+ gfc_free_expr (expr);
+ expr = al->expr;
+ if (expr->ts.type == BT_CLASS)
+ {
+ 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, true);
+ gcc_assert (vtab);
+ gfc_trans_assign_vtab_procs (&block, ts->u.derived, 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));
+ }
+ }
+ }
+