@@ -4226,6 +4226,51 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym,
}
else
gfc_conv_expr_reference (&parmse, e);
+#if 0
+ /* Finalize function results after their use as
+ actual argument. */
+ // FIXME: Cleanup of constructors
+ if (e->expr_type == EXPR_FUNCTION && fsym
+ && (fsym->ts.type == BT_CLASS
+ || (fsym->ts.type == BT_DERIVED
+ && gfc_is_finalizable (e->ts.u.derived, NULL))))
+ {
+ tree final_fndecl, size, array;
+ gfc_expr *final_expr;
+
+ if (fsym->ts.type == BT_CLASS)
+ {
+ gfc_is_finalizable (CLASS_DATA (e)->ts.u.derived,
+ &final_expr);
+ final_fndecl = gfc_vtable_final_get (parmse.expr);
+ size = gfc_vtable_size_get (parmse.expr);
+ array = gfc_class_data_get (parmse.expr);
+ }
+ else
+ {
+ gfc_se fse;
+ gfc_is_finalizable (e->ts.u.derived, &final_expr);
+ gfc_init_se (&fse, NULL);
+ gfc_conv_expr (&fse, final_expr);
+ final_fndecl = fse.expr;
+ size = gfc_typenode_for_spec (&e->ts);
+ size = TYPE_SIZE_UNIT (size);
+ size = fold_convert (gfc_array_index_type, size);
+ array = parmse.expr;
+ }
+ if (POINTER_TYPE_P (TREE_TYPE (final_fndecl)))
+ final_fndecl
+ = build_fold_indirect_ref_loc (input_location,
+ final_fndecl);
+ array = gfc_conv_scalar_to_descriptor (&parmse, array,
+ fsym->attr);
+ array = gfc_build_addr_expr (NULL_TREE, array);
+ tmp = build_call_expr_loc (input_location,
+ final_fndecl, 3, array,
+ size, boolean_false_node);
+ gfc_add_expr_to_block (&parmse.post, tmp);
+ }
+#endif
/* Catch base objects that are not variables. */
if (e->ts.type == BT_CLASS
@@ -5562,6 +5607,29 @@ gfc_conv_function_expr (gfc_se * se, gfc_expr * expr)
gfc_conv_procedure_call (se, sym, expr->value.function.actual, expr,
NULL);
+ /* Ensure that allocatable scalars get deallocated; we only handle
+ nonderived types as for TYPE/CLASS one runs into ordering problems
+ with allocatable components. On the other hand, TYPE and CLASS
+ can only occur with assignment and as actual argument, contrary to
+ intrinsic types. */
+ if (sym->ts.type != BT_CLASS && sym->ts.type != BT_DERIVED
+ && ((sym->result && !sym->result->as && sym->result->attr.allocatable)
+ || (!sym->result && !sym->as && sym->attr.allocatable)))
+ {
+ tree tmp;
+ bool undo_deref = !POINTER_TYPE_P (TREE_TYPE (se->expr));
+
+ if (undo_deref)
+ se->expr = gfc_build_addr_expr (NULL, se->expr);
+
+ tmp = gfc_create_var (TREE_TYPE (se->expr), NULL);
+ gfc_add_modify (&se->pre, tmp, se->expr);
+
+ se->expr = tmp;
+ if (undo_deref)
+ se->expr = build_fold_indirect_ref_loc (input_location, se->expr);
+ gfc_add_expr_to_block (&se->post, gfc_call_free (tmp));
+ }
}
@@ -5665,7 +5733,18 @@ gfc_conv_initializer (gfc_expr * expr, gfc_typespec * ts, tree type,
else if (pointer || procptr)
{
if (!expr || expr->expr_type == EXPR_NULL)
- return fold_convert (type, null_pointer_node);
+ {
+ if (ts->type == BT_CLASS)
+ {
+ gfc_init_se (&se, NULL);
+ gfc_conv_structure (&se, gfc_class_null_initializer(ts, expr), 1);
+ gcc_assert (TREE_CODE (se.expr) == CONSTRUCTOR);
+ TREE_STATIC (se.expr) = 1;
+ return se.expr;
+ }
+ else
+ return fold_convert (type, null_pointer_node);
+ }
else
{
gfc_init_se (&se, NULL);
@@ -7591,9 +7670,15 @@ is_scalar_reallocatable_lhs (gfc_expr *expr)
{
gfc_ref * ref;
+#if 0
+/* FIXME: Do we need to handle _data? */
+ if (expr->ts.type == BT_CLASS && CLASS_DATA (expr)->attr.allocatable)
+ return true;
+#endif
+
/* An allocatable variable with no reference. */
if (expr->symtree->n.sym->attr.allocatable
- && !expr->ref)
+ && !expr->ref)
return true;
/* All that can be left are allocatable components. */
@@ -7615,12 +7700,13 @@ is_scalar_reallocatable_lhs (gfc_expr *expr)
/* Allocate or reallocate scalar lhs, as necessary. */
+/* FIXME: If the RHS ise CLASS, we need the _size of the RHS and a temporary + we need to handle CLASS(*) on the LHS, including CLASS(*) = char and CLASS(*) = CLASS(*). */
+
static void
alloc_scalar_allocatable_for_assignment (stmtblock_t *block,
tree string_length,
gfc_expr *expr1,
gfc_expr *expr2)
-
{
tree cond;
tree tmp;
@@ -7644,6 +7730,11 @@ alloc_scalar_allocatable_for_assignment (stmtblock_t *block,
lse.want_pointer = 1;
gfc_conv_expr (&lse, expr1);
+#if 0
+ if (expr1->ts.type == BT_CLASS)
+ lse.expr = gfc_class_data_get (lse.expr);
+#endif
+
jump_label1 = gfc_build_label_decl (NULL_TREE);
jump_label2 = gfc_build_label_decl (NULL_TREE);
@@ -7660,7 +7751,9 @@ alloc_scalar_allocatable_for_assignment (stmtblock_t *block,
{
/* Use the rhs string length and the lhs element size. */
size = string_length;
- tmp = TREE_TYPE (gfc_typenode_for_spec (&expr1->ts));
+ tmp = TREE_TYPE (gfc_typenode_for_spec (/*expr1->ts.type == BT_CLASS
+ ? &CLASS_DATA (expr1)->ts
+ :*/ &expr1->ts));
tmp = TYPE_SIZE_UNIT (tmp);
size_in_bytes = fold_build2_loc (input_location, MULT_EXPR,
TREE_TYPE (tmp), tmp,
@@ -7669,7 +7762,8 @@ alloc_scalar_allocatable_for_assignment (stmtblock_t *block,
else
{
/* Otherwise use the length in bytes of the rhs. */
- size = TYPE_SIZE_UNIT (gfc_typenode_for_spec (&expr1->ts));
+ size = TYPE_SIZE_UNIT (gfc_typenode_for_spec (/*expr1->ts.type == BT_CLASS
+ ? &CLASS_DATA (expr1)->ts :*/ &expr1->ts));
size_in_bytes = size;
}