This is the mail archive of the
fortran@gcc.gnu.org
mailing list for the GNU Fortran project.
Re: [Patch, fortran-dev] ALLOCATE statements with CLASS variables
Hi all,
here is yet another version of the ALLOCATE patch. I now moved all the
initialization code form resolve_allocate_expr to gfc_trans_allocate,
where the whole thing can be done a bit simpler (and one avoids
certain problems).
For this I had to make 'expr_to_initialize' non-static. Consequently,
I should probably add a 'gfc_' prefix to its name.
The SIZE problem is still not solved (see below), but I added a
warning for the problematic cases (which is triggered by Salvatore's
code, for example). I haven't checked in detail if the second problem
I mentioned earlier persists.
Maybe I will just commit the patch in the attached form today, and
take care of the remaining problems later.
>> We have an intrinsic function SIZEOF (which is a GNU extension, but
>> that does not matter), so couldn't we just insert code to call this,
>> with 'y' as the argument, and use the result as the size to allocate?
>> Problem is: I can't figure out how to do this properly ...
>
> It's known as a vtable! ?This can contain, amongst other things
> derived type sizes, parentage, typebound procedures and so on.
Actually this was not what I meant. I was thinking of a way to
determine the allocated size of the source variable (or rather of
source.$data) at runtime. However, SIZEOF cannot be used, since it
operates at compile time of course (this I forgot).
Looking for an alternative, I found 'malloc_usable_size' (from glibc),
which should be able to do the job. Is this an option we might
consider? A possible problem here might be portability(?).
Other than that, I can think of no real alternative to a full vtable
implementation (as Paul suggested).
Err, maybe one: Extending our CLASS container, to hold not only
"$data" and "$vindex", but also an additional field called "$size",
which would mean 'the size of the $data field'. Question is whether
we'll need a vtable anyways.
Opinions?
Cheers,
Janus
Index: gcc/fortran/dump-parse-tree.c
===================================================================
--- gcc/fortran/dump-parse-tree.c (Revision 152114)
+++ gcc/fortran/dump-parse-tree.c (Arbeitskopie)
@@ -1453,7 +1453,7 @@ show_code_node (int level, gfc_code *c)
show_expr (c->expr2);
}
- for (a = c->ext.alloc_list; a; a = a->next)
+ for (a = c->ext.alloc.list; a; a = a->next)
{
fputc (' ', dumpfile);
show_expr (a->expr);
@@ -1475,7 +1475,7 @@ show_code_node (int level, gfc_code *c)
show_expr (c->expr2);
}
- for (a = c->ext.alloc_list; a; a = a->next)
+ for (a = c->ext.alloc.list; a; a = a->next)
{
fputc (' ', dumpfile);
show_expr (a->expr);
Index: gcc/fortran/gfortran.h
===================================================================
--- gcc/fortran/gfortran.h (Revision 152114)
+++ gcc/fortran/gfortran.h (Arbeitskopie)
@@ -2005,7 +2005,14 @@ typedef struct gfc_code
gfc_actual_arglist *actual;
gfc_case *case_list;
gfc_iterator *iterator;
- gfc_alloc *alloc_list;
+
+ struct
+ {
+ gfc_typespec ts;
+ gfc_alloc *list;
+ }
+ alloc;
+
gfc_open *open;
gfc_close *close;
gfc_filepos *filepos;
@@ -2615,6 +2622,7 @@ gfc_try gfc_resolve_dim_arg (gfc_expr *);
int gfc_is_formal_arg (void);
void gfc_resolve_substring_charlen (gfc_expr *);
match gfc_iso_c_sub_interface(gfc_code *, gfc_symbol *);
+gfc_expr *expr_to_initialize (gfc_expr *);
/* array.c */
Index: gcc/fortran/trans-stmt.c
===================================================================
--- gcc/fortran/trans-stmt.c (Revision 152114)
+++ gcc/fortran/trans-stmt.c (Arbeitskopie)
@@ -3962,7 +3962,7 @@ tree
gfc_trans_allocate (gfc_code * code)
{
gfc_alloc *al;
- gfc_expr *expr;
+ gfc_expr *expr, *init_e, *rhs;
gfc_se se;
tree tmp;
tree parm;
@@ -3971,7 +3971,7 @@ gfc_trans_allocate (gfc_code * code)
tree error_label;
stmtblock_t block;
- if (!code->ext.alloc_list)
+ if (!code->ext.alloc.list)
return NULL_TREE;
pstat = stat = error_label = tmp = NULL_TREE;
@@ -3990,7 +3990,7 @@ gfc_trans_allocate (gfc_code * code)
TREE_USED (error_label) = 1;
}
- for (al = code->ext.alloc_list; al != NULL; al = al->next)
+ for (al = code->ext.alloc.list; al != NULL; al = al->next)
{
expr = al->expr;
@@ -4004,8 +4004,25 @@ gfc_trans_allocate (gfc_code * code)
if (!gfc_array_allocate (&se, expr, pstat))
{
/* A scalar or derived type. */
- tmp = TYPE_SIZE_UNIT (TREE_TYPE (TREE_TYPE (se.expr)));
+ /* Determine allocate size. */
+ if (code->expr3 && code->expr3->ts.type == BT_CLASS)
+ {
+ gfc_typespec *ts;
+ /* TODO: Size must be determined at run time, since it must equal
+ the size of the dynamic type of SOURCE, not the declared type. */
+ gfc_warning ("Dynamic size allocation at %L not supported yet, "
+ "using size of declared type", &code->loc);
+ ts = &code->expr3->ts.u.derived->components->ts;
+ tmp = TYPE_SIZE_UNIT (gfc_typenode_for_spec (ts));
+ }
+ else if (code->expr3 && code->expr3->ts.type != BT_CLASS)
+ tmp = TYPE_SIZE_UNIT (gfc_typenode_for_spec (&code->expr3->ts));
+ else if (code->ext.alloc.ts.type != BT_UNKNOWN)
+ tmp = TYPE_SIZE_UNIT (gfc_typenode_for_spec (&code->ext.alloc.ts));
+ else
+ tmp = TYPE_SIZE_UNIT (TREE_TYPE (TREE_TYPE (se.expr)));
+
if (expr->ts.type == BT_CHARACTER && tmp == NULL_TREE)
tmp = se.string_length;
@@ -4035,6 +4052,23 @@ gfc_trans_allocate (gfc_code * code)
tmp = gfc_finish_block (&se.pre);
gfc_add_expr_to_block (&block, tmp);
+
+ /* Initialization via SOURCE block. */
+ if (code->expr3)
+ {
+ rhs = gfc_copy_expr (code->expr3);
+ if (rhs->ts.type == BT_CLASS)
+ gfc_add_component_ref (rhs, "$data");
+ tmp = gfc_trans_assignment (expr_to_initialize (expr), rhs, false);
+ gfc_add_expr_to_block (&block, tmp);
+ }
+ /* Add default initializer for those derived types that need them. */
+ else if (expr->ts.type == BT_DERIVED && (init_e = gfc_default_initializer (&expr->ts)))
+ {
+ tmp = gfc_trans_assignment (expr_to_initialize (expr), init_e, true);
+ gfc_add_expr_to_block (&block, tmp);
+ }
+
}
/* STAT block. */
@@ -4081,44 +4115,6 @@ gfc_trans_allocate (gfc_code * code)
gfc_add_expr_to_block (&block, tmp);
}
- /* SOURCE block. Note, by C631, we know that code->ext.alloc_list
- has a single entity. */
- if (code->expr3)
- {
- gfc_ref *ref;
- gfc_array_ref *ar;
- int n;
-
- /* If there is a terminating array reference, this is converted
- to a full array, so that gfc_trans_assignment can scalarize the
- expression for the source. */
- for (ref = code->ext.alloc_list->expr->ref; ref; ref = ref->next)
- {
- if (ref->next == NULL)
- {
- if (ref->type != REF_ARRAY)
- break;
-
- ref->u.ar.type = AR_FULL;
- ar = &ref->u.ar;
- ar->dimen = ar->as->rank;
- for (n = 0; n < ar->dimen; n++)
- {
- ar->dimen_type[n] = DIMEN_RANGE;
- gfc_free_expr (ar->start[n]);
- gfc_free_expr (ar->end[n]);
- gfc_free_expr (ar->stride[n]);
- ar->start[n] = NULL;
- ar->end[n] = NULL;
- ar->stride[n] = NULL;
- }
- }
- }
-
- tmp = gfc_trans_assignment (code->ext.alloc_list->expr, code->expr3, false);
- gfc_add_expr_to_block (&block, tmp);
- }
-
return gfc_finish_block (&block);
}
@@ -4156,7 +4152,7 @@ gfc_trans_deallocate (gfc_code *code)
gfc_add_modify (&block, astat, build_int_cst (TREE_TYPE (astat), 0));
}
- for (al = code->ext.alloc_list; al != NULL; al = al->next)
+ for (al = code->ext.alloc.list; al != NULL; al = al->next)
{
expr = al->expr;
gcc_assert (expr->expr_type == EXPR_VARIABLE);
Index: gcc/fortran/resolve.c
===================================================================
--- gcc/fortran/resolve.c (Revision 152114)
+++ gcc/fortran/resolve.c (Arbeitskopie)
@@ -5556,7 +5556,7 @@ gfc_find_sym_in_expr (gfc_symbol *sym, gfc_expr *e
derived types with default initializers, and derived types with allocatable
components that need nullification.) */
-static gfc_expr *
+gfc_expr *
expr_to_initialize (gfc_expr *e)
{
gfc_expr *result;
@@ -5594,7 +5594,6 @@ resolve_allocate_expr (gfc_expr *e, gfc_code *code
gfc_ref *ref, *ref2;
gfc_array_ref *ar;
gfc_code *init_st;
- gfc_expr *init_e;
gfc_symbol *sym;
gfc_alloc *a;
gfc_component *c;
@@ -5687,13 +5686,31 @@ resolve_allocate_expr (gfc_expr *e, gfc_code *code
if (e->ts.type == BT_CLASS)
{
/* Initialize VINDEX for CLASS objects. */
- int vindex = e->ts.u.derived->vindex;
init_st = gfc_get_code ();
init_st->loc = code->loc;
init_st->expr1 = expr_to_initialize (e);
init_st->op = EXEC_ASSIGN;
gfc_add_component_ref (init_st->expr1, "$vindex");
- init_st->expr2 = gfc_int_expr (vindex);
+ if (code->expr3 && code->expr3->ts.type == BT_CLASS)
+ {
+ /* vindex must be determined at run time. */
+ init_st->expr2 = gfc_copy_expr (code->expr3);
+ gfc_add_component_ref (init_st->expr2, "$vindex");
+ }
+ else
+ {
+ /* vindex is fixed at compile time. */
+ int vindex;
+ if (code->expr3)
+ vindex = code->expr3->ts.u.derived->vindex;
+ else if (code->ext.alloc.ts.type == BT_DERIVED)
+ vindex = code->ext.alloc.ts.u.derived->vindex;
+ else if (e->ts.type == BT_CLASS)
+ vindex = e->ts.u.derived->components->ts.u.derived->vindex;
+ else
+ vindex = e->ts.u.derived->vindex;
+ init_st->expr2 = gfc_int_expr (vindex);
+ }
init_st->expr2->where = init_st->expr1->where = init_st->loc;
init_st->next = code->next;
code->next = init_st;
@@ -5701,18 +5718,6 @@ resolve_allocate_expr (gfc_expr *e, gfc_code *code
gfc_add_component_ref (e, "$data");
}
- /* Add default initializer for those derived types that need them. */
- if (e->ts.type == BT_DERIVED && (init_e = gfc_default_initializer (&e->ts)))
- {
- init_st = gfc_get_code ();
- init_st->loc = code->loc;
- init_st->op = EXEC_INIT_ASSIGN;
- init_st->expr1 = expr_to_initialize (e);
- init_st->expr2 = init_e;
- init_st->next = code->next;
- code->next = init_st;
- }
-
if (pointer || dimension == 0)
return SUCCESS;
@@ -5757,7 +5762,7 @@ resolve_allocate_expr (gfc_expr *e, gfc_code *code
check_symbols:
- for (a = code->ext.alloc_list; a; a = a->next)
+ for (a = code->ext.alloc.list; a; a = a->next)
{
sym = a->expr->symtree->n.sym;
@@ -5809,7 +5814,7 @@ resolve_allocate_deallocate (gfc_code *code, const
gfc_error ("Stat-variable at %L must be a scalar INTEGER "
"variable", &stat->where);
- for (p = code->ext.alloc_list; p; p = p->next)
+ for (p = code->ext.alloc.list; p; p = p->next)
if (p->expr->symtree->n.sym->name == stat->symtree->n.sym->name)
gfc_error ("Stat-variable at %L shall not be %sd within "
"the same %s statement", &stat->where, fcn, fcn);
@@ -5838,7 +5843,7 @@ resolve_allocate_deallocate (gfc_code *code, const
gfc_error ("Errmsg-variable at %L must be a scalar CHARACTER "
"variable", &errmsg->where);
- for (p = code->ext.alloc_list; p; p = p->next)
+ for (p = code->ext.alloc.list; p; p = p->next)
if (p->expr->symtree->n.sym->name == errmsg->symtree->n.sym->name)
gfc_error ("Errmsg-variable at %L shall not be %sd within "
"the same %s statement", &errmsg->where, fcn, fcn);
@@ -5846,7 +5851,7 @@ resolve_allocate_deallocate (gfc_code *code, const
/* Check that an allocate-object appears only once in the statement.
FIXME: Checking derived types is disabled. */
- for (p = code->ext.alloc_list; p; p = p->next)
+ for (p = code->ext.alloc.list; p; p = p->next)
{
pe = p->expr;
if ((pe->ref && pe->ref->type != REF_COMPONENT)
@@ -5866,12 +5871,12 @@ resolve_allocate_deallocate (gfc_code *code, const
if (strcmp (fcn, "ALLOCATE") == 0)
{
- for (a = code->ext.alloc_list; a; a = a->next)
+ for (a = code->ext.alloc.list; a; a = a->next)
resolve_allocate_expr (a->expr, code);
}
else
{
- for (a = code->ext.alloc_list; a; a = a->next)
+ for (a = code->ext.alloc.list; a; a = a->next)
resolve_deallocate_expr (a->expr);
}
}
@@ -7233,43 +7238,38 @@ resolve_ordinary_assign (gfc_code *code, gfc_names
}
-/* Check a pointer assignment to a CLASS object. */
+/* Check an assignment to a CLASS object (pointer or ordinary assignment). */
static void
-check_class_pointer_assign (gfc_code **code)
+resolve_class_assign (gfc_code *code)
{
gfc_code *assign_code = gfc_get_code ();
/* Insert an additional assignment which sets the vindex. */
- assign_code->next = (*code)->next;
- (*code)->next = assign_code;
+ assign_code->next = code->next;
+ code->next = assign_code;
assign_code->op = EXEC_ASSIGN;
- assign_code->expr1 = gfc_copy_expr ((*code)->expr1);
+ assign_code->expr1 = gfc_copy_expr (code->expr1);
gfc_add_component_ref (assign_code->expr1, "$vindex");
- if ((*code)->expr2->ts.type == BT_DERIVED)
+ if (code->expr2->ts.type == BT_DERIVED)
{
/* vindex is constant, determined at compile time. */
- int vindex = (*code)->expr2->ts.u.derived->vindex;
+ int vindex = code->expr2->ts.u.derived->vindex;
assign_code->expr2 = gfc_int_expr (vindex);
}
- else if ((*code)->expr2->ts.type == BT_CLASS)
+ else if (code->expr2->ts.type == BT_CLASS)
{
/* vindex must be determined at run time. */
- assign_code->expr2 = gfc_copy_expr ((*code)->expr2);
+ assign_code->expr2 = gfc_copy_expr (code->expr2);
gfc_add_component_ref (assign_code->expr2, "$vindex");
}
else
gcc_unreachable ();
/* Modify the actual pointer assignment. */
- gfc_add_component_ref ((*code)->expr1, "$data");
- if ((*code)->expr2->ts.type == BT_CLASS)
- gfc_add_component_ref ((*code)->expr2, "$data");
-
- gfc_check_pointer_assign ((*code)->expr1, (*code)->expr2);
-
- if ((*code)->expr1->ts.type == BT_CLASS)
- (*code) = (*code)->next;
+ gfc_add_component_ref (code->expr1, "$data");
+ if (code->expr2->ts.type == BT_CLASS)
+ gfc_add_component_ref (code->expr2, "$data");
}
@@ -7395,6 +7395,9 @@ resolve_code (gfc_code *code, gfc_namespace *ns)
if (t == FAILURE)
break;
+ if (code->expr1->ts.type == BT_CLASS)
+ resolve_class_assign (code);
+
if (resolve_ordinary_assign (code, ns))
{
if (code->op == EXEC_COMPCALL)
@@ -7424,10 +7427,10 @@ resolve_code (gfc_code *code, gfc_namespace *ns)
break;
if (code->expr1->ts.type == BT_CLASS)
- check_class_pointer_assign (&code);
- else
- gfc_check_pointer_assign (code->expr1, code->expr2);
+ resolve_class_assign (code);
+ gfc_check_pointer_assign (code->expr1, code->expr2);
+
break;
case EXEC_ARITHMETIC_IF:
Index: gcc/fortran/st.c
===================================================================
--- gcc/fortran/st.c (Revision 152114)
+++ gcc/fortran/st.c (Arbeitskopie)
@@ -129,7 +129,7 @@ gfc_free_statement (gfc_code *p)
case EXEC_ALLOCATE:
case EXEC_DEALLOCATE:
- gfc_free_alloc_list (p->ext.alloc_list);
+ gfc_free_alloc_list (p->ext.alloc.list);
break;
case EXEC_OPEN:
Index: gcc/fortran/match.c
===================================================================
--- gcc/fortran/match.c (Revision 152114)
+++ gcc/fortran/match.c (Arbeitskopie)
@@ -2610,7 +2610,7 @@ alloc_opt_list:
gfc_resolve_expr (tmp);
- if (head->expr->ts.type != tmp->ts.type)
+ if (!gfc_type_compatible (&head->expr->ts, &tmp->ts))
{
gfc_error ("Type of entity at %L is type incompatible with "
"source-expr at %L", &head->expr->where, &tmp->where);
@@ -2651,7 +2651,8 @@ alloc_opt_list:
new_st.expr1 = stat;
new_st.expr2 = errmsg;
new_st.expr3 = source;
- new_st.ext.alloc_list = head;
+ new_st.ext.alloc.list = head;
+ new_st.ext.alloc.ts = ts;
return MATCH_YES;
@@ -2865,7 +2866,7 @@ dealloc_opt_list:
new_st.op = EXEC_DEALLOCATE;
new_st.expr1 = stat;
new_st.expr2 = errmsg;
- new_st.ext.alloc_list = head;
+ new_st.ext.alloc.list = head;
return MATCH_YES;