This is the mail archive of the
fortran@gcc.gnu.org
mailing list for the GNU Fortran project.
Re: [Patch, Fortran, F03] PR 40996: Allocatable Scalars
Dear All,
I made an attack on OOP yesterday afternoon, which resulted in the
attached patch. I does nothing as yet other than generating the
vindex for each type in a class and a corresponding vtable. I have
taken the highest level derived type in a hierarchy of extended
derived types. This might not be declared to be a class but it is
assumed that it could be.
The vtable will be an array of derived types, whose components are
pointers to the all the type bound procedures of all of the class
members. Building up the components of the derived type and
generating the pointer assignments will be the next step.
Following this, class methods will be implemented by substituting the
class object's symbol with that of the vtable and inserting an array
reference to the 'vindex' member of the array. I have not yet decided
how to encapsulate the class object and it's associated vindex. This
could either be done in the same way as character lengths or by
putting the object and it's vindex in a container. I favour the
latter but have not thought through all the wrinkles yet.
It will be noted that all of the implementation can, in principle, be
done using the gfortran front-end. I think that this will be quite a
useful feature:-)
The attached bit of fortran compiles but does not produce the correct
results yet because the dynamic despatch is not yet implmented. It is
instructive yet to look at the parse tree and see the vindices of the
derived types and the vtable and vtable_type in the appropriate
namespaces.
> I think you can just do
> t = gfc_get_super_type (t);
> instead -- this seems much more understandable to me.
Note my gfc_get_ultimate_super_type, which goes all the way up the
inheritance tree.
Cheers
Paul
Index: gcc/fortran/trans-expr.c
===================================================================
--- gcc/fortran/trans-expr.c (revision 150678)
+++ gcc/fortran/trans-expr.c (working copy)
@@ -1527,7 +1527,7 @@
assign the pointer to it and use it for the call. This
will do for now! */
tmp = convert (build_pointer_type (TREE_TYPE (tmp)),
- gfc_get_symbol_decl (sym->cp_pointer));
+ gfc_get_symbol_decl (sym->u1.cp_pointer));
tmp = gfc_evaluate_now (tmp, &se->pre);
}
@@ -2633,7 +2633,7 @@
a type given by the expression. */
gfc_conv_expr (&parmse, e);
type = build_pointer_type (TREE_TYPE (parmse.expr));
- tmp = gfc_get_symbol_decl (e->symtree->n.sym->cp_pointer);
+ tmp = gfc_get_symbol_decl (e->symtree->n.sym->u1.cp_pointer);
parmse.expr = convert (type, tmp);
}
else if (fsym && fsym->attr.value)
Index: gcc/fortran/symbol.c
===================================================================
--- gcc/fortran/symbol.c (revision 150678)
+++ gcc/fortran/symbol.c (working copy)
@@ -4523,6 +4523,23 @@
}
+/* Get the ultimate super-type of a given derived type. */
+
+gfc_symbol*
+gfc_get_ultimate_derived_super_type (gfc_symbol* derived)
+{
+ if (!derived->attr.extension)
+ return NULL;
+
+ derived = gfc_get_derived_super_type (derived);
+
+ if (derived->attr.extension)
+ return gfc_get_ultimate_derived_super_type (derived);
+ else
+ return derived;
+}
+
+
/* General worker function to find either a type-bound procedure or a
type-bound user operator. */
Index: gcc/fortran/decl.c
===================================================================
--- gcc/fortran/decl.c (revision 150678)
+++ gcc/fortran/decl.c (working copy)
@@ -2374,10 +2374,6 @@
if (m != MATCH_YES)
return m;
ts->is_class = 1;
-
- /* TODO: Implement Polymorphism. */
- gfc_warning ("Polymorphic entities are not yet implemented. "
- "CLASS will be treated like TYPE at %C");
}
ts->type = BT_DERIVED;
@@ -5805,7 +5801,7 @@
}
/* Point the Pointee at the Pointer. */
- cpte->cp_pointer = cptr;
+ cpte->u1.cp_pointer = cptr;
if (gfc_match_char (')') != MATCH_YES)
{
@@ -6754,6 +6750,7 @@
{
gfc_component *p;
gfc_symtree *st;
+ gfc_symbol *declared_type;
/* Add the extended derived type as the first component. */
gfc_add_component (sym, parent, &p);
@@ -6770,6 +6767,41 @@
extended->f2k_derived = gfc_get_namespace (NULL, 0);
st = gfc_new_symtree (&extended->f2k_derived->sym_root, sym->name);
st->n.sym = sym;
+
+ /* Increment the VINDEX of the top-level declared type and set
+ the VINDEX for this one. This is done so that the size of
+ the VTABLE entries for the top-level derived type is VINDEX*/
+ declared_type = gfc_get_ultimate_derived_super_type (sym);
+ if (declared_type->u2.vindex == 0)
+ declared_type->u2.vindex++;
+ sym->u2.vindex = declared_type->u2.vindex++;
+
+ if (declared_type->u1.vtable == NULL)
+ {
+ sprintf (parent, "vtable.%s_", sym->name);
+ gfc_get_ha_sym_tree (parent, &st);
+ gfc_set_sym_referenced (st->n.sym);
+ st->n.sym->refs++;
+ declared_type->u1.vtable = st->n.sym;
+ st->n.sym->ts.type = BT_DERIVED;
+ st->n.sym->attr.is_vtable = 1;
+ if (gfc_add_flavor (&st->n.sym->attr, FL_VARIABLE,
+ NULL, &declared_type->declared_at) == FAILURE)
+ return MATCH_ERROR;
+
+ sprintf (parent, "vtable_type.%s_", sym->name);
+ gfc_get_ha_sym_tree (parent, &st);
+ gfc_set_sym_referenced (st->n.sym);
+ st->n.sym->refs++;
+ declared_type->u1.vtable->ts.u.derived = st->n.sym;
+ st->n.sym->ts.type = BT_UNKNOWN;
+ st->n.sym->attr.is_vtable = 1;
+ if (gfc_add_flavor (&st->n.sym->attr, FL_DERIVED,
+ NULL, &declared_type->declared_at) == FAILURE)
+ return MATCH_ERROR;
+ }
+
+ sym->u1.vtable = declared_type->u1.vtable;
}
/* Take over the ABSTRACT attribute. */
Index: gcc/fortran/dump-parse-tree.c
===================================================================
--- gcc/fortran/dump-parse-tree.c (revision 150678)
+++ gcc/fortran/dump-parse-tree.c (working copy)
@@ -803,6 +803,10 @@
if (sym->f2k_derived)
{
show_indent ();
+ if (sym->u2.vindex)
+ fprintf (dumpfile, "vindex: %d vtable: %s\n",
+ sym->u2.vindex, sym->u1.vtable->name);
+ show_indent ();
fputs ("Procedure bindings:\n", dumpfile);
show_f2k_derived (sym->f2k_derived);
}
Index: gcc/fortran/gfortran.h
===================================================================
--- gcc/fortran/gfortran.h (revision 150678)
+++ gcc/fortran/gfortran.h (working copy)
@@ -720,6 +720,8 @@
/* Special attributes for Cray pointers, pointees. */
unsigned cray_pointer:1, cray_pointee:1;
+ unsigned is_vtable:1;
+
/* The symbol is a derived type with allocatable components, pointer
components or private components, procedure pointer components,
possibly nested. zero_comp is true if the derived type has no
@@ -1122,9 +1124,22 @@
struct gfc_symbol *result; /* function result symbol */
gfc_component *components; /* Derived type components */
- /* Defined only for Cray pointees; points to their pointer. */
- struct gfc_symbol *cp_pointer;
+ union
+ {
+ /* Defined only for Cray pointees; points to their pointer. */
+ struct gfc_symbol *cp_pointer;
+ /* Defined only for derived types; points to the VTABLE symbol. */
+ struct gfc_symbol *vtable;
+ }
+ u1;
+ union
+ {
+ int entry_id; /* Used in resolve.c for entries. */
+ int vindex; /* Derived type VINDEX. */
+ }
+ u2;
+
struct gfc_symbol *common_next; /* Links for COMMON syms */
/* This is in fact a gfc_common_head but it is only used for pointer
@@ -1135,8 +1150,6 @@
order. */
int dummy_order;
- int entry_id;
-
gfc_namelist *namelist, *namelist_tail;
/* Change management fields. Symbols that might be modified by the
@@ -2451,6 +2464,7 @@
gfc_typebound_proc* gfc_get_typebound_proc (void);
gfc_symbol* gfc_get_derived_super_type (gfc_symbol*);
+gfc_symbol* gfc_get_ultimate_derived_super_type (gfc_symbol*);
gfc_symtree* gfc_find_typebound_proc (gfc_symbol*, gfc_try*, const char*, bool);
gfc_symtree* gfc_find_typebound_user_op (gfc_symbol*, gfc_try*,
const char*, bool);
Index: gcc/fortran/expr.c
===================================================================
--- gcc/fortran/expr.c (revision 150678)
+++ gcc/fortran/expr.c (working copy)
@@ -3228,7 +3228,7 @@
return SUCCESS;
}
- if (!gfc_compare_types (&lvalue->ts, &rvalue->ts))
+ if (!lvalue->ts.is_class && !gfc_compare_types (&lvalue->ts, &rvalue->ts))
{
gfc_error ("Different types in pointer assignment at %L; attempted "
"assignment of %s to %s", &lvalue->where,
@@ -3236,7 +3236,7 @@
return FAILURE;
}
- if (lvalue->ts.kind != rvalue->ts.kind)
+ if (!lvalue->ts.is_class && lvalue->ts.kind != rvalue->ts.kind)
{
gfc_error ("Different kind type parameters in pointer "
"assignment at %L", &lvalue->where);
Index: gcc/fortran/module.c
===================================================================
--- gcc/fortran/module.c (revision 150678)
+++ gcc/fortran/module.c (working copy)
@@ -1653,7 +1653,7 @@
AB_CRAY_POINTER, AB_CRAY_POINTEE, AB_THREADPRIVATE, AB_ALLOC_COMP,
AB_POINTER_COMP, AB_PRIVATE_COMP, AB_VALUE, AB_VOLATILE, AB_PROTECTED,
AB_IS_BIND_C, AB_IS_C_INTEROP, AB_IS_ISO_C, AB_ABSTRACT, AB_ZERO_COMP,
- AB_EXTENSION, AB_PROCEDURE, AB_PROC_POINTER
+ AB_EXTENSION, AB_PROCEDURE, AB_PROC_POINTER, AB_IS_VTABLE
}
ab_attribute;
@@ -1696,6 +1696,7 @@
minit ("EXTENSION", AB_EXTENSION),
minit ("PROCEDURE", AB_PROCEDURE),
minit ("PROC_POINTER", AB_PROC_POINTER),
+ minit ("IS_VTABLE", AB_IS_VTABLE),
minit (NULL, -1)
};
@@ -1845,6 +1846,8 @@
MIO_NAME (ab_attribute) (AB_PROCEDURE, attr_bits);
if (attr->proc_pointer)
MIO_NAME (ab_attribute) (AB_PROC_POINTER, attr_bits);
+ if (attr->is_vtable)
+ MIO_NAME (ab_attribute) (AB_IS_VTABLE, attr_bits);
mio_rparen ();
@@ -1972,6 +1975,9 @@
case AB_PROC_POINTER:
attr->proc_pointer = 1;
break;
+ case AB_IS_VTABLE:
+ attr->is_vtable = 1;
+ break;
}
}
}
@@ -2031,6 +2037,7 @@
static void
mio_typespec (gfc_typespec *ts)
{
+ int is_class;
mio_lparen ();
ts->type = MIO_NAME (bt) (ts->type, bt_types);
@@ -2040,6 +2047,12 @@
else
mio_symbol_ref (&ts->derived);
+ /* Variable is a CLASS. */
+ is_class = ts->is_class ? 1 : 0;
+ mio_integer (&is_class);
+ if (iomode == IO_OUTPUT)
+ ts->is_class = is_class ? 1 : 0;
+
/* Add info for C interop and is_iso_c. */
mio_integer (&ts->is_c_interop);
mio_integer (&ts->is_iso_c);
@@ -3441,10 +3454,11 @@
mio_symbol (gfc_symbol *sym)
{
int intmod = INTMOD_NONE;
-
+
mio_lparen ();
+
+ mio_symbol_attribute (&sym->attr);
- mio_symbol_attribute (&sym->attr);
mio_typespec (&sym->ts);
if (iomode == IO_OUTPUT)
@@ -3472,7 +3486,7 @@
mio_symbol_ref (&sym->result);
if (sym->attr.cray_pointee)
- mio_symbol_ref (&sym->cp_pointer);
+ mio_symbol_ref (&sym->u1.cp_pointer);
/* Note that components are always saved, even if they are supposed
to be private. Component access is checked during searching. */
@@ -3503,7 +3517,12 @@
}
mio_integer (&(sym->intmod_sym_id));
-
+
+ if (sym->attr.flavor == FL_DERIVED)
+ {
+ mio_integer (&(sym->u2.vindex));
+ mio_symbol_ref (&sym->u1.vtable);
+ }
mio_rparen ();
}
Index: gcc/fortran/resolve.c
===================================================================
--- gcc/fortran/resolve.c (revision 150678)
+++ gcc/fortran/resolve.c (working copy)
@@ -4364,7 +4364,7 @@
/* Deal with forward references to entries during resolve_code, to
satisfy, at least partially, 12.5.2.5. */
if (gfc_current_ns->entries
- && current_entry_id == sym->entry_id
+ && current_entry_id == sym->u2.entry_id
&& cs_base
&& cs_base->current
&& cs_base->current->op != EXEC_ENTRY)
@@ -4424,7 +4424,7 @@
if (t == SUCCESS)
/* Update the symbol's entry level. */
- sym->entry_id = current_entry_id + 1;
+ sym->u2.entry_id = current_entry_id + 1;
}
resolve_procedure:
@@ -7925,6 +7925,41 @@
}
+/* Build the vtable for the ultimate declared type. */
+
+static void
+build_vtable (gfc_symbol *derived)
+{
+ gfc_symbol *declared_type, *vtable;
+
+ /* Find the top level declared type. This might not be actually
+ declared in a class but it helps to ensure that all the
+ inherited methods are present in the vtable. */
+ declared_type = gfc_get_ultimate_derived_super_type (derived);
+ if (declared_type == NULL)
+ declared_type = derived;
+ vtable = declared_type->u1.vtable;
+
+ /* Ensure that the array is large enough for all the dynamic
+ types in the super class. The array might need enlarging
+ when a host or use associated class is extended. */
+ if (vtable->as)
+ {
+ if (vtable->as->rank >= declared_type->u2.vindex)
+ return;
+ gfc_free_array_spec (vtable->as);
+ }
+
+ /* Build the array_spec. */
+ vtable->as = gfc_get_array_spec ();
+ vtable->attr.dimension = 1;
+ vtable->as->rank = 1;
+ vtable->as->type = AS_EXPLICIT;
+ vtable->as->lower[0] = gfc_int_expr (1);
+ vtable->as->upper[0] = gfc_int_expr (declared_type->u2.vindex);
+}
+
+
/* Additional checks for symbols with flavor variable and derived
type. To be called from resolve_fl_variable. */
@@ -7990,6 +8025,11 @@
"or pointer", sym->name, &sym->declared_at);
return FAILURE;
}
+
+ /* Build the vtable for extended derived types. */
+ if (sym->ts.u.derived->u2.vindex > 0
+ && sym->ts.u.derived->u1.vtable)
+ build_vtable (sym->ts.u.derived);
}
/* Assign default initializer. */
@@ -10149,8 +10189,10 @@
the type is not declared in the scope of the implicit
statement. Change the type to BT_UNKNOWN, both because it is so
and to prevent an ICE. */
- if (sym->ts.type == BT_DERIVED && sym->ts.u.derived->components == NULL
- && !sym->ts.u.derived->attr.zero_comp)
+ if (!sym->attr.is_vtable
+ && sym->ts.type == BT_DERIVED
+ && sym->ts.u.derived->components == NULL
+ && !sym->ts.u.derived->attr.zero_comp)
{
gfc_error ("The derived type '%s' at %L is of type '%s', "
"which has not been defined", sym->name,
Index: gcc/fortran/trans-decl.c
===================================================================
--- gcc/fortran/trans-decl.c (revision 150678)
+++ gcc/fortran/trans-decl.c (working copy)
@@ -411,11 +411,11 @@
static void
gfc_finish_cray_pointee (tree decl, gfc_symbol *sym)
{
- tree ptr_decl = gfc_get_symbol_decl (sym->cp_pointer);
+ tree ptr_decl = gfc_get_symbol_decl (sym->u1.cp_pointer);
tree value;
/* Parameters need to be dereferenced. */
- if (sym->cp_pointer->attr.dummy)
+ if (sym->u1.cp_pointer->attr.dummy)
ptr_decl = build_fold_indirect_ref_loc (input_location,
ptr_decl);
module m
type :: null_type
end type
type :: t1
integer :: i = 42
procedure(make_real), pointer :: ptr
contains
procedure, pass :: real => make_real
procedure, pass :: make_integer
procedure, pass :: prod => i_m_j
generic, public :: extract => real, make_integer
end type t1
type, extends(t1) :: t2
integer :: j = 99
contains
procedure, pass :: real => make_real2
procedure, pass :: make_integer_2
procedure, pass :: prod => i_m_j_2
generic, public :: extract => real, make_integer_2
end type t2
contains
real function make_real (arg)
class(t1), intent(in) :: arg
make_real = real (arg%i)
end function make_real
real function make_real2 (arg)
class(t2), intent(in) :: arg
make_real2 = real (arg%j)
end function make_real2
integer function make_integer (arg, arg2)
class(t1), intent(in) :: arg
integer :: arg2
make_integer = arg%i * arg2
end function make_integer
integer function make_integer_2 (arg, arg2)
class(t2), intent(in) :: arg
integer(8) :: arg2
make_integer_2 = arg%j * arg2
end function make_integer_2
integer function i_m_j (arg)
class(t1), intent(in) :: arg
print *, arg%i
i_m_j = arg%i
end function i_m_j
integer function i_m_j_2 (arg)
class(t2), intent(in) :: arg
print *, arg%j
i_m_j_2 = arg%j
end function i_m_j_2
end module m
use m
class(t1), pointer :: a
type(t1), target :: b
type(t2), target :: c
a => b
print *, a%real(), a%prod()
a => c
print *, a%real(), a%prod()
end
- References:
- [Patch, Fortran, F03] PR 40996: Allocatable Scalars
- Re: [Patch, Fortran, F03] PR 40996: Allocatable Scalars
- From: Paul Richard Thomas
- Re: [Patch, Fortran, F03] PR 40996: Allocatable Scalars
- Re: [Patch, Fortran, F03] PR 40996: Allocatable Scalars
- Re: [Patch, Fortran, F03] PR 40996: Allocatable Scalars
- Re: [Patch, Fortran, F03] PR 40996: Allocatable Scalars
- Re: [Patch, Fortran, F03] PR 40996: Allocatable Scalars