OpenE2K/gcc
2
0
Fork 0
Code Issues Pull Requests Projects Releases Wiki Activity

[multiple changes]

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

	PR fortran/43896
	* symbol.c (add_proc_component,copy_vtab_proc_comps): Remove
	initializers for PPC members of the vtabs.

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

	PR fortran/42274
	* symbol.c (add_proc_component,add_proc_comps): Correctly set the 'ppc'
	attribute for all PPC members of the vtypes.
	(copy_vtab_proc_comps): Copy the correct interface.
	* trans.h (gfc_trans_assign_vtab_procs): Modified prototype.
	* trans-expr.c (gfc_trans_assign_vtab_procs): Pass the derived type as
	a dummy argument and make sure all PPC members of the vtab are
	initialized correctly.
	(gfc_conv_derived_to_class,gfc_trans_class_assign): Additional argument
	in call to gfc_trans_assign_vtab_procs.
	* trans-stmt.c (gfc_trans_allocate): Ditto.

2010-04-29  Paul Thomas  <pault@gcc.gnu.org>

	PR fortran/43326
	* resolve.c (resolve_typebound_function): Renamed
	resolve_class_compcall.Do all the detection of class references
	here.
	(resolve_typebound_subroutine): resolve_class_typebound_call
	renamed. Otherwise same as resolve_typebound_function.
	(gfc_resolve_expr): Call resolve_typebound_function.
	(resolve_code): Call resolve_typebound_subroutine.

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

	PR fortran/43492
	* resolve.c (resolve_typebound_generic_call): For CLASS methods
	pass back the specific symtree name, rather than the target
	name.

2010-04-29  Paul Thomas  <pault@gcc.gnu.org>

	PR fortran/42353
	* resolve.c (resolve_structure_cons): Make the initializer of
	the vtab component 'extends' the same type as the component.

2010-04-29  Jerry DeLisle  <jvdelisle@gcc.gnu.org>

	PR fortran/42680
	* interface.c (check_interface1): Pass symbol name rather than NULL to
	gfc_compare_interfaces.(gfc_compare_interfaces): Add assert to
	trap MULL. (gfc_compare_derived_types): Revert previous change
	incorporated incorrectly during merge from trunk, r155778.
	* resolve.c (check_generic_tbp_ambiguity): Pass symbol name rather
	than NULL to gfc_compare_interfaces.
	* symbol.c (add_generic_specifics): Likewise.

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

	PR fortran/42353
	* interface.c (gfc_compare_derived_types): Add condition for vtype.
	* symbol.c (gfc_find_derived_vtab): Sey access to private.
	(gfc_find_derived_vtab): Likewise.
	* module.c (ab_attribute): Add enumerator AB_VTAB.
	(mio_symbol_attribute): Use new attribute, AB_VTAB.
	(check_for_ambiguous): Likewise.

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

	PR fortran/41829
	* trans-expr.c (select_class_proc): Remove function.
	(conv_function_val): Delete reference to previous.
	(gfc_conv_derived_to_class): Add second argument to the call to
	gfc_find_derived_vtab.
	(gfc_conv_structure): Exclude proc_pointer components when
	accessing $data field of class objects.
	(gfc_trans_assign_vtab_procs): New function.
	(gfc_trans_class_assign): Add second argument to the call to
	gfc_find_derived_vtab.
	* symbol.c (gfc_build_class_symbol): Add delayed_vtab arg and
	implement holding off searching for the vptr derived type.
	(add_proc_component): New function.
	(add_proc_comps): New function.
	(add_procs_to_declared_vtab1): New function.
	(copy_vtab_proc_comps): New function.
	(add_procs_to_declared_vtab): New function.
	(void add_generic_specifics): New function.
	(add_generics_to_declared_vtab): New function.
	(gfc_find_derived_vtab): Add second argument to the call to
	gfc_find_derived_vtab. Add the calls to
	add_procs_to_declared_vtab and add_generics_to_declared_vtab.
	* decl.c (build_sym, build_struct): Use new arg in calls to
	gfc_build_class_symbol.
	* gfortran.h : Add vtype bitfield to symbol_attr. Remove the
	definition of struct gfc_class_esym_list. Modify prototypes
	of gfc_build_class_symbol and gfc_find_derived_vtab.
	* trans-stmt.c (gfc_trans_allocate): Add second argument to the
	call to gfc_find_derived_vtab.
	* module.c : Add the vtype attribute.
	* trans.h : Add prototype for gfc_trans_assign_vtab_procs.
	* resolve.c (resolve_typebound_generic_call): Add second arg
	to pass along the generic name for class methods.
	(resolve_typebound_call): The same.
	(resolve_compcall): Use the second arg to carry the generic
	name from the above. Remove the reference to class_esym.
	(check_members, check_class_members, resolve_class_esym,
	hash_value_expr): Remove functions.
	(resolve_class_compcall, resolve_class_typebound_call): Modify
	to use vtable rather than member by member calls.
	(gfc_resolve_expr): Modify second arg in call to
	resolve_compcall.
	(resolve_select_type): Add second arg in call to
	gfc_find_derived_vtab.
	(resolve_code): Add second arg in call resolve_typebound_call.
	(resolve_fl_derived): Exclude vtypes from check for late
	procedure definitions. Likewise for checking of explicit
	interface and checking of pass arg.
	* iresolve.c (gfc_resolve_extends_type_of): Add second arg in
	calls to gfc_find_derived_vtab.
	* match.c (select_type_set_tmp): Use new arg in call to
	gfc_build_class_symbol.
	* trans-decl.c (gfc_get_symbol_decl): Complete vtable if
	necessary.
	* parse.c (endType): Finish incomplete classes.


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

	PR fortran/42274
	* gfortran.dg/class_16.f03: New test.

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

	PR fortran/42274
	* gfortran.dg/class_15.f03: New.

2010-04-29  Paul Thomas  <pault@gcc.gnu.org>

	PR fortran/43326
	* gfortran.dg/dynamic_dispatch_9.f03: New test.

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

	PR fortran/43492
	* gfortran.dg/generic_22.f03 : New test.

2010-04-29  Paul Thomas  <pault@gcc.gnu.org>

	PR fortran/42353
	* gfortran.dg/class_14.f03: New test.

2010-04-29  Jerry DeLisle  <jvdelisle@gcc.gnu.org>

	PR fortran/42680
	* gfortran.dg/interface_32.f90: New test.

2009-04-29  Paul Thomas  <pault@gcc.gnu.org>
	    Janus Weil  <janus@gcc.gnu.org>

	PR fortran/41829
	* gfortran.dg/dynamic_dispatch_5.f03 : Change to "run".
	* gfortran.dg/dynamic_dispatch_7.f03 : New test.
	* gfortran.dg/dynamic_dispatch_8.f03 : New test.

From-SVN: r158910
This commit is contained in:
Paul Thomas 2010-04-29 19:10:48 +00:00
parent 716a34815b
commit eece1eb9ac
24 changed files with 1232 additions and 457 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

124
gcc/fortran/ChangeLog
View File

@ -1,3 +1,127 @@
2010-04-29 Janus Weil <janus@gcc.gnu.org>
PR fortran/43896
* symbol.c (add_proc_component,copy_vtab_proc_comps): Remove
initializers for PPC members of the vtabs.
2010-04-29 Janus Weil <janus@gcc.gnu.org>
PR fortran/42274
* symbol.c (add_proc_component,add_proc_comps): Correctly set the 'ppc'
attribute for all PPC members of the vtypes.
(copy_vtab_proc_comps): Copy the correct interface.
* trans.h (gfc_trans_assign_vtab_procs): Modified prototype.
* trans-expr.c (gfc_trans_assign_vtab_procs): Pass the derived type as
a dummy argument and make sure all PPC members of the vtab are
initialized correctly.
(gfc_conv_derived_to_class,gfc_trans_class_assign): Additional argument
in call to gfc_trans_assign_vtab_procs.
* trans-stmt.c (gfc_trans_allocate): Ditto.
2010-04-29 Paul Thomas <pault@gcc.gnu.org>
PR fortran/43326
* resolve.c (resolve_typebound_function): Renamed
resolve_class_compcall.Do all the detection of class references
here.
(resolve_typebound_subroutine): resolve_class_typebound_call
renamed. Otherwise same as resolve_typebound_function.
(gfc_resolve_expr): Call resolve_typebound_function.
(resolve_code): Call resolve_typebound_subroutine.
2010-04-29 Janus Weil <janus@gcc.gnu.org>
PR fortran/43492
* resolve.c (resolve_typebound_generic_call): For CLASS methods
pass back the specific symtree name, rather than the target
name.
2010-04-29 Paul Thomas <pault@gcc.gnu.org>
PR fortran/42353
* resolve.c (resolve_structure_cons): Make the initializer of
the vtab component 'extends' the same type as the component.
2010-04-29 Jerry DeLisle <jvdelisle@gcc.gnu.org>
PR fortran/42680
* interface.c (check_interface1): Pass symbol name rather than NULL to
gfc_compare_interfaces.(gfc_compare_interfaces): Add assert to
trap MULL. (gfc_compare_derived_types): Revert previous change
incorporated incorrectly during merge from trunk, r155778.
* resolve.c (check_generic_tbp_ambiguity): Pass symbol name rather
than NULL to gfc_compare_interfaces.
* symbol.c (add_generic_specifics): Likewise.
2010-02-29 Janus Weil <janus@gcc.gnu.org>
PR fortran/42353
* interface.c (gfc_compare_derived_types): Add condition for vtype.
* symbol.c (gfc_find_derived_vtab): Sey access to private.
(gfc_find_derived_vtab): Likewise.
* module.c (ab_attribute): Add enumerator AB_VTAB.
(mio_symbol_attribute): Use new attribute, AB_VTAB.
(check_for_ambiguous): Likewise.
2010-04-29 Paul Thomas <pault@gcc.gnu.org>
Janus Weil <janus@gcc.gnu.org>
PR fortran/41829
* trans-expr.c (select_class_proc): Remove function.
(conv_function_val): Delete reference to previous.
(gfc_conv_derived_to_class): Add second argument to the call to
gfc_find_derived_vtab.
(gfc_conv_structure): Exclude proc_pointer components when
accessing $data field of class objects.
(gfc_trans_assign_vtab_procs): New function.
(gfc_trans_class_assign): Add second argument to the call to
gfc_find_derived_vtab.
* symbol.c (gfc_build_class_symbol): Add delayed_vtab arg and
implement holding off searching for the vptr derived type.
(add_proc_component): New function.
(add_proc_comps): New function.
(add_procs_to_declared_vtab1): New function.
(copy_vtab_proc_comps): New function.
(add_procs_to_declared_vtab): New function.
(void add_generic_specifics): New function.
(add_generics_to_declared_vtab): New function.
(gfc_find_derived_vtab): Add second argument to the call to
gfc_find_derived_vtab. Add the calls to
add_procs_to_declared_vtab and add_generics_to_declared_vtab.
* decl.c (build_sym, build_struct): Use new arg in calls to
gfc_build_class_symbol.
* gfortran.h : Add vtype bitfield to symbol_attr. Remove the
definition of struct gfc_class_esym_list. Modify prototypes
of gfc_build_class_symbol and gfc_find_derived_vtab.
* trans-stmt.c (gfc_trans_allocate): Add second argument to the
call to gfc_find_derived_vtab.
* module.c : Add the vtype attribute.
* trans.h : Add prototype for gfc_trans_assign_vtab_procs.
* resolve.c (resolve_typebound_generic_call): Add second arg
to pass along the generic name for class methods.
(resolve_typebound_call): The same.
(resolve_compcall): Use the second arg to carry the generic
name from the above. Remove the reference to class_esym.
(check_members, check_class_members, resolve_class_esym,
hash_value_expr): Remove functions.
(resolve_class_compcall, resolve_class_typebound_call): Modify
to use vtable rather than member by member calls.
(gfc_resolve_expr): Modify second arg in call to
resolve_compcall.
(resolve_select_type): Add second arg in call to
gfc_find_derived_vtab.
(resolve_code): Add second arg in call resolve_typebound_call.
(resolve_fl_derived): Exclude vtypes from check for late
procedure definitions. Likewise for checking of explicit
interface and checking of pass arg.
* iresolve.c (gfc_resolve_extends_type_of): Add second arg in
calls to gfc_find_derived_vtab.
* match.c (select_type_set_tmp): Use new arg in call to
gfc_build_class_symbol.
* trans-decl.c (gfc_get_symbol_decl): Complete vtable if
necessary.
* parse.c (endType): Finish incomplete classes.
2010-04-28 Tobias Burnus <burnus@net-b.de>
PR fortran/18918

4
gcc/fortran/decl.c
View File

@ -1160,7 +1160,7 @@ build_sym (const char *name, gfc_charlen *cl,
sym->attr.class_ok = (sym->attr.dummy
|| sym->attr.pointer
|| sym->attr.allocatable) ? 1 : 0;
gfc_build_class_symbol (&sym->ts, &sym->attr, &sym->as);
gfc_build_class_symbol (&sym->ts, &sym->attr, &sym->as, false);
}
return SUCCESS;
@ -1570,7 +1570,7 @@ build_struct (const char *name, gfc_charlen *cl, gfc_expr **init,
scalar:
if (c->ts.type == BT_CLASS)
gfc_build_class_symbol (&c->ts, &c->attr, &c->as);
gfc_build_class_symbol (&c->ts, &c->attr, &c->as, true);
return t;
}

19
gcc/fortran/gfortran.h
View File

@ -691,7 +691,8 @@ typedef struct
unsigned extension:8; /* extension level of a derived type. */
unsigned is_class:1; /* is a CLASS container. */
unsigned class_ok:1; /* is a CLASS object with correct attributes. */
unsigned vtab:1; /* is a derived type vtab. */
unsigned vtab:1; /* is a derived type vtab, pointed to by CLASS objects. */
unsigned vtype:1; /* is a derived type of a vtab. */
/* These flags are both in the typespec and attribute. The attribute
list is what gets read from/written to a module file. The typespec
@ -1615,17 +1616,6 @@ typedef struct gfc_intrinsic_sym
gfc_intrinsic_sym;
typedef struct gfc_class_esym_list
{
gfc_symbol *derived;
gfc_symbol *esym;
struct gfc_expr *hash_value;
struct gfc_class_esym_list *next;
}
gfc_class_esym_list;
#define gfc_get_class_esym_list() XCNEW (gfc_class_esym_list)
/* Expression nodes. The expression node types deserve explanations,
since the last couple can be easily misconstrued:
@ -1717,7 +1707,6 @@ typedef struct gfc_expr
const char *name; /* Points to the ultimate name of the function */
gfc_intrinsic_sym *isym;
gfc_symbol *esym;
gfc_class_esym_list *class_esym;
}
function;
@ -2526,8 +2515,8 @@ gfc_gsymbol *gfc_get_gsymbol (const char *);
gfc_gsymbol *gfc_find_gsymbol (gfc_gsymbol *, const char *);
gfc_try gfc_build_class_symbol (gfc_typespec *, symbol_attribute *,
gfc_array_spec **);
gfc_symbol *gfc_find_derived_vtab (gfc_symbol *);
gfc_array_spec **, bool);
gfc_symbol *gfc_find_derived_vtab (gfc_symbol *, bool);
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*);

4
gcc/fortran/interface.c
View File

@ -1129,8 +1129,8 @@ check_interface1 (gfc_interface *p, gfc_interface *q0,
if (p->sym->name == q->sym->name && p->sym->module == q->sym->module)
continue;
if (gfc_compare_interfaces (p->sym, q->sym, q->sym->name, generic_flag, 0,
NULL, 0))
if (gfc_compare_interfaces (p->sym, q->sym, q->sym->name, generic_flag,
0, NULL, 0))
{
if (referenced)
gfc_error ("Ambiguous interfaces '%s' and '%s' in %s at %L",

4
gcc/fortran/iresolve.c
View File

@ -832,7 +832,7 @@ gfc_resolve_extends_type_of (gfc_expr *f, gfc_expr *a, gfc_expr *mo)
gfc_add_component_ref (a, "$vptr");
else if (a->ts.type == BT_DERIVED)
{
vtab = gfc_find_derived_vtab (a->ts.u.derived);
vtab = gfc_find_derived_vtab (a->ts.u.derived, false);
/* Clear the old expr. */
gfc_free_ref_list (a->ref);
memset (a, '\0', sizeof (gfc_expr));
@ -848,7 +848,7 @@ gfc_resolve_extends_type_of (gfc_expr *f, gfc_expr *a, gfc_expr *mo)
gfc_add_component_ref (mo, "$vptr");
else if (mo->ts.type == BT_DERIVED)
{
vtab = gfc_find_derived_vtab (mo->ts.u.derived);
vtab = gfc_find_derived_vtab (mo->ts.u.derived, false);
/* Clear the old expr. */
gfc_free_ref_list (mo->ref);
memset (mo, '\0', sizeof (gfc_expr));

2
gcc/fortran/match.c
View File

@ -4280,7 +4280,7 @@ select_type_set_tmp (gfc_typespec *ts)
if (ts->type == BT_CLASS)
{
gfc_build_class_symbol (&tmp->n.sym->ts, &tmp->n.sym->attr,
&tmp->n.sym->as);
&tmp->n.sym->as, false);
tmp->n.sym->attr.class_ok = 1;
}

17
gcc/fortran/module.c
View File

@ -1674,7 +1674,7 @@ typedef enum
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_IS_CLASS, AB_PROCEDURE, AB_PROC_POINTER, AB_ASYNCHRONOUS, AB_CODIMENSION,
AB_COARRAY_COMP
AB_COARRAY_COMP, AB_VTYPE, AB_VTAB
}
ab_attribute;
@ -1720,6 +1720,8 @@ static const mstring attr_bits[] =
minit ("IS_CLASS", AB_IS_CLASS),
minit ("PROCEDURE", AB_PROCEDURE),
minit ("PROC_POINTER", AB_PROC_POINTER),
minit ("VTYPE", AB_VTYPE),
minit ("VTAB", AB_VTAB),
minit (NULL, -1)
};
@ -1880,6 +1882,10 @@ mio_symbol_attribute (symbol_attribute *attr)
MIO_NAME (ab_attribute) (AB_PROCEDURE, attr_bits);
if (attr->proc_pointer)
MIO_NAME (ab_attribute) (AB_PROC_POINTER, attr_bits);
if (attr->vtype)
MIO_NAME (ab_attribute) (AB_VTYPE, attr_bits);
if (attr->vtab)
MIO_NAME (ab_attribute) (AB_VTAB, attr_bits);
mio_rparen ();
@ -2016,6 +2022,12 @@ mio_symbol_attribute (symbol_attribute *attr)
case AB_PROC_POINTER:
attr->proc_pointer = 1;
break;
case AB_VTYPE:
attr->vtype = 1;
break;
case AB_VTAB:
attr->vtab = 1;
break;
}
}
}
@ -4201,6 +4213,9 @@ check_for_ambiguous (gfc_symbol *st_sym, pointer_info *info)
if (st_sym == rsym)
return false;
if (st_sym->attr.vtab || st_sym->attr.vtype)
return false;
/* If the existing symbol is generic from a different module and
the new symbol is generic there can be no ambiguity. */
if (st_sym->attr.generic

16
gcc/fortran/parse.c
View File

@ -2110,6 +2110,22 @@ endType:
|| c->attr.access == ACCESS_PRIVATE
|| (c->ts.type == BT_DERIVED && c->ts.u.derived->attr.private_comp))
sym->attr.private_comp = 1;
/* Fix up incomplete CLASS components. */
if (c->ts.type == BT_CLASS)
{
gfc_component *data;
gfc_component *vptr;
gfc_symbol *vtab;
data = gfc_find_component (c->ts.u.derived, "$data", true, true);
vptr = gfc_find_component (c->ts.u.derived, "$vptr", true, true);
if (vptr->ts.u.derived == NULL)
{
vtab = gfc_find_derived_vtab (data->ts.u.derived, false);
gcc_assert (vtab);
vptr->ts.u.derived = vtab->ts.u.derived;
}
}
}
if (!seen_component)

404
gcc/fortran/resolve.c
View File

@ -898,7 +898,15 @@ resolve_structure_cons (gfc_expr *expr)
if (!gfc_compare_types (&cons->expr->ts, &comp->ts))
{
t = FAILURE;
if (comp->attr.pointer && cons->expr->ts.type != BT_UNKNOWN)
if (strcmp (comp->name, "$extends") == 0)
{
/* Can afford to be brutal with the $extends initializer.
The derived type can get lost because it is PRIVATE
but it is not usage constrained by the standard. */
cons->expr->ts = comp->ts;
t = SUCCESS;
}
else if (comp->attr.pointer && cons->expr->ts.type != BT_UNKNOWN)
gfc_error ("The element in the derived type constructor at %L, "
"for pointer component '%s', is %s but should be %s",
&cons->expr->where, comp->name,
@ -1874,13 +1882,12 @@ resolve_global_procedure (gfc_symbol *sym, locus *where,
/* Non-assumed length character functions. */
if (sym->attr.function && sym->ts.type == BT_CHARACTER
&& gsym->ns->proc_name->ts.u.cl != NULL
&& gsym->ns->proc_name->ts.u.cl->length != NULL)
&& gsym->ns->proc_name->ts.u.cl->length != NULL)
{
gfc_charlen *cl = sym->ts.u.cl;
if (!sym->attr.entry_master && sym->attr.if_source == IFSRC_UNKNOWN
&& cl && cl->length && cl->length->expr_type != EXPR_CONSTANT)
&& cl && cl->length && cl->length->expr_type != EXPR_CONSTANT)
{
gfc_error ("Nonconstant character-length function '%s' at %L "
"must have an explicit interface", sym->name,
@ -5121,7 +5128,7 @@ resolve_typebound_static (gfc_expr* e, gfc_symtree** target,
the expression into a call of that binding. */
static gfc_try
resolve_typebound_generic_call (gfc_expr* e)
resolve_typebound_generic_call (gfc_expr* e, const char **name)
{
gfc_typebound_proc* genproc;
const char* genname;
@ -5177,6 +5184,10 @@ resolve_typebound_generic_call (gfc_expr* e)
if (matches)
{
e->value.compcall.tbp = g->specific;
/* Pass along the name for CLASS methods, where the vtab
procedure pointer component has to be referenced. */
if (name)
*name = g->specific_st->name;
goto success;
}
}
@ -5195,7 +5206,7 @@ success:
/* Resolve a call to a type-bound subroutine. */
static gfc_try
resolve_typebound_call (gfc_code* c)
resolve_typebound_call (gfc_code* c, const char **name)
{
gfc_actual_arglist* newactual;
gfc_symtree* target;
@ -5211,7 +5222,12 @@ resolve_typebound_call (gfc_code* c)
if (check_typebound_baseobject (c->expr1) == FAILURE)
return FAILURE;
if (resolve_typebound_generic_call (c->expr1) == FAILURE)
/* Pass along the name for CLASS methods, where the vtab
procedure pointer component has to be referenced. */
if (name)
*name = c->expr1->value.compcall.name;
if (resolve_typebound_generic_call (c->expr1, name) == FAILURE)
return FAILURE;
/* Transform into an ordinary EXEC_CALL for now. */
@ -5235,31 +5251,20 @@ resolve_typebound_call (gfc_code* c)
}
/* Resolve a component-call expression. This originally was intended
only to see functions. However, it is convenient to use it in
resolving subroutine class methods, since we do not have to add a
gfc_code each time. */
/* Resolve a component-call expression. */
static gfc_try
resolve_compcall (gfc_expr* e, bool fcn, bool class_members)
resolve_compcall (gfc_expr* e, const char **name)
{
gfc_actual_arglist* newactual;
gfc_symtree* target;
/* Check that's really a FUNCTION. */
if (fcn && !e->value.compcall.tbp->function)
if (!e->value.compcall.tbp->function)
{
gfc_error ("'%s' at %L should be a FUNCTION",
e->value.compcall.name, &e->where);
return FAILURE;
}
else if (!fcn && !e->value.compcall.tbp->subroutine)
{
/* To resolve class member calls, we borrow this bit
of code to select the specific procedures. */
gfc_error ("'%s' at %L should be a SUBROUTINE",
e->value.compcall.name, &e->where);
return FAILURE;
}
/* These must not be assign-calls! */
gcc_assert (!e->value.compcall.assign);
@ -5267,7 +5272,12 @@ resolve_compcall (gfc_expr* e, bool fcn, bool class_members)
if (check_typebound_baseobject (e) == FAILURE)
return FAILURE;
if (resolve_typebound_generic_call (e) == FAILURE)
/* Pass along the name for CLASS methods, where the vtab
procedure pointer component has to be referenced. */
if (name)
*name = e->value.compcall.name;
if (resolve_typebound_generic_call (e, name) == FAILURE)
return FAILURE;
gcc_assert (!e->value.compcall.tbp->is_generic);
@ -5284,169 +5294,15 @@ resolve_compcall (gfc_expr* e, bool fcn, bool class_members)
e->value.function.actual = newactual;
e->value.function.name = NULL;
e->value.function.esym = target->n.sym;
e->value.function.class_esym = NULL;
e->value.function.isym = NULL;
e->symtree = target;
e->ts = target->n.sym->ts;
e->expr_type = EXPR_FUNCTION;
/* Resolution is not necessary when constructing component calls
for class members, since this must only be done for the
declared type, which is done afterwards. */
return !class_members ? gfc_resolve_expr (e) : SUCCESS;
}
/* Resolve a typebound call for the members in a class. This group of
functions implements dynamic dispatch in the provisional version
of f03 OOP. As soon as vtables are in place and contain pointers
to methods, this will no longer be necessary. */
static gfc_expr *list_e;
static gfc_try check_class_members (gfc_symbol *);
static gfc_try class_try;
static bool fcn_flag;
static void
check_members (gfc_symbol *derived)
{
if (derived->attr.flavor == FL_DERIVED)
(void) check_class_members (derived);
}
static gfc_try
check_class_members (gfc_symbol *derived)
{
gfc_expr *e;
gfc_symtree *tbp;
gfc_class_esym_list *etmp;
e = gfc_copy_expr (list_e);
tbp = gfc_find_typebound_proc (derived, &class_try,
e->value.compcall.name,
false, &e->where);
if (tbp == NULL)
{
gfc_error ("no typebound available procedure named '%s' at %L",
e->value.compcall.name, &e->where);
return FAILURE;
}
/* If we have to match a passed class member, force the actual
expression to have the correct type. */
if (!tbp->n.tb->nopass)
{
if (e->value.compcall.base_object == NULL)
e->value.compcall.base_object = extract_compcall_passed_object (e);
if (e->value.compcall.base_object == NULL)
return FAILURE;
if (!derived->attr.abstract)
{
e->value.compcall.base_object->ts.type = BT_DERIVED;
e->value.compcall.base_object->ts.u.derived = derived;
}
}
e->value.compcall.tbp = tbp->n.tb;
e->value.compcall.name = tbp->name;
/* Let the original expresssion catch the assertion in
resolve_compcall, since this flag does not appear to be reset or
copied in some systems. */
e->value.compcall.assign = 0;
/* Do the renaming, PASSing, generic => specific and other
good things for each class member. */
class_try = (resolve_compcall (e, fcn_flag, true) == SUCCESS)
? class_try : FAILURE;
/* Now transfer the found symbol to the esym list. */
if (class_try == SUCCESS)
{
etmp = list_e->value.function.class_esym;
list_e->value.function.class_esym
= gfc_get_class_esym_list();
list_e->value.function.class_esym->next = etmp;
list_e->value.function.class_esym->derived = derived;
list_e->value.function.class_esym->esym
= e->value.function.esym;
}
gfc_free_expr (e);
/* Burrow down into grandchildren types. */
if (derived->f2k_derived)
gfc_traverse_ns (derived->f2k_derived, check_members);
return SUCCESS;
}
/* Eliminate esym_lists where all the members point to the
typebound procedure of the declared type; ie. one where
type selection has no effect.. */
static void
resolve_class_esym (gfc_expr *e)
{
gfc_class_esym_list *p, *q;
bool empty = true;
gcc_assert (e && e->expr_type == EXPR_FUNCTION);
p = e->value.function.class_esym;
if (p == NULL)
return;
for (; p; p = p->next)
empty = empty && (e->value.function.esym == p->esym);
if (empty)
{
p = e->value.function.class_esym;
for (; p; p = q)
{
q = p->next;
gfc_free (p);
}
e->value.function.class_esym = NULL;
}
}
/* Generate an expression for the hash value, given the reference to
the class of the final expression (class_ref), the base of the
full reference list (new_ref), the declared type and the class
object (st). */
static gfc_expr*
hash_value_expr (gfc_ref *class_ref, gfc_ref *new_ref, gfc_symtree *st)
{
gfc_expr *hash_value;
/* Build an expression for the correct hash_value; ie. that of the last
CLASS reference. */
if (class_ref)
{
class_ref->next = NULL;
}
else
{
gfc_free_ref_list (new_ref);
new_ref = NULL;
}
hash_value = gfc_get_expr ();
hash_value->expr_type = EXPR_VARIABLE;
hash_value->symtree = st;
hash_value->symtree->n.sym->refs++;
hash_value->ref = new_ref;
gfc_add_component_ref (hash_value, "$vptr");
gfc_add_component_ref (hash_value, "$hash");
return hash_value;
/* Resolution is not necessary if this is a class subroutine; this
function only has to identify the specific proc. Resolution of
the call will be done next in resolve_typebound_call. */
return gfc_resolve_expr (e);
}
@ -5483,146 +5339,151 @@ get_declared_from_expr (gfc_ref **class_ref, gfc_ref **new_ref,
}
/* Resolve the argument expressions so that any arguments expressions
that include class methods are resolved before the current call.
This is necessary because of the static variables used in CLASS
method resolution. */
static void
resolve_arg_exprs (gfc_actual_arglist *arg)
{
/* Resolve the actual arglist expressions. */
for (; arg; arg = arg->next)
{
if (arg->expr)
gfc_resolve_expr (arg->expr);
}
}
/* Resolve a typebound function, or 'method'. First separate all
the non-CLASS references by calling resolve_compcall directly.
Then treat the CLASS references by resolving for each of the class
members in turn. */
/* Resolve a typebound function, or 'method'. First separate all
the non-CLASS references by calling resolve_compcall directly. */
static gfc_try
resolve_typebound_function (gfc_expr* e)
{
gfc_symbol *derived, *declared;
gfc_symbol *declared;
gfc_component *c;
gfc_ref *new_ref;
gfc_ref *class_ref;
gfc_symtree *st;
const char *name;
const char *genname;
gfc_typespec ts;
st = e->symtree;
if (st == NULL)
return resolve_compcall (e, true, false);
return resolve_compcall (e, NULL);
/* Get the CLASS declared type. */
declared = get_declared_from_expr (&class_ref, &new_ref, e);
/* Weed out cases of the ultimate component being a derived type. */
if ((class_ref && class_ref->u.c.component->ts.type == BT_DERIVED)
|| (!class_ref && st->n.sym->ts.type != BT_CLASS))
|| (!class_ref && st->n.sym->ts.type != BT_CLASS))
{
gfc_free_ref_list (new_ref);
return resolve_compcall (e, true, false);
return resolve_compcall (e, NULL);
}
/* Resolve the argument expressions, */
resolve_arg_exprs (e->value.function.actual);
c = gfc_find_component (declared, "$data", true, true);
declared = c->ts.u.derived;
/* Get the data component, which is of the declared type. */
derived = declared->components->ts.u.derived;
/* Keep the generic name so that the vtab reference can be made. */
genname = NULL;
if (e->value.compcall.tbp->is_generic)
genname = e->value.compcall.name;
/* Resolve the function call for each member of the class. */
class_try = SUCCESS;
fcn_flag = true;
list_e = gfc_copy_expr (e);
/* Treat the call as if it is a typebound procedure, in order to roll
out the correct name for the specific function. */
resolve_compcall (e, &name);
ts = e->ts;
if (check_class_members (derived) == FAILURE)
return FAILURE;
/* Then convert the expression to a procedure pointer component call. */
e->value.function.esym = NULL;
e->symtree = st;
class_try = (resolve_compcall (e, true, false) == SUCCESS)
? class_try : FAILURE;
if (class_ref)
{
gfc_free_ref_list (class_ref->next);
e->ref = new_ref;
}
/* Transfer the class list to the original expression. Note that
the class_esym list is cleaned up in trans-expr.c, as the calls
are translated. */
e->value.function.class_esym = list_e->value.function.class_esym;
list_e->value.function.class_esym = NULL;
gfc_free_expr (list_e);
/* '$vptr' points to the vtab, which contains the procedure pointers. */
gfc_add_component_ref (e, "$vptr");
if (genname)
{
/* A generic procedure needs the subsidiary vtabs and vtypes for
the specific procedures to have been build. */
gfc_symbol *vtab;
vtab = gfc_find_derived_vtab (declared, true);
gcc_assert (vtab);
gfc_add_component_ref (e, genname);
}
gfc_add_component_ref (e, name);
resolve_class_esym (e);
/* More than one typebound procedure so transmit an expression for
the hash_value as the selector. */
if (e->value.function.class_esym != NULL)
e->value.function.class_esym->hash_value
= hash_value_expr (class_ref, new_ref, st);
return class_try;
/* Recover the typespec for the expression. This is really only
necessary for generic procedures, where the additional call
to gfc_add_component_ref seems to throw the collection of the
correct typespec. */
e->ts = ts;
return SUCCESS;
}
/* Resolve a typebound subroutine, or 'method'. First separate all
the non-CLASS references by calling resolve_typebound_call directly.
Then treat the CLASS references by resolving for each of the class
members in turn. */
/* Resolve a typebound subroutine, or 'method'. First separate all
the non-CLASS references by calling resolve_typebound_call
directly. */
static gfc_try
resolve_typebound_subroutine (gfc_code *code)
{
gfc_symbol *derived, *declared;
gfc_symbol *declared;
gfc_component *c;
gfc_ref *new_ref;
gfc_ref *class_ref;
gfc_symtree *st;
const char *genname;
const char *name;
gfc_typespec ts;
st = code->expr1->symtree;
if (st == NULL)
return resolve_typebound_call (code);
return resolve_typebound_call (code, NULL);
/* Get the CLASS declared type. */
declared = get_declared_from_expr (&class_ref, &new_ref, code->expr1);
/* Weed out cases of the ultimate component being a derived type. */
if ((class_ref && class_ref->u.c.component->ts.type == BT_DERIVED)
|| (!class_ref && st->n.sym->ts.type != BT_CLASS))
|| (!class_ref && st->n.sym->ts.type != BT_CLASS))
{
gfc_free_ref_list (new_ref);
return resolve_typebound_call (code);
return resolve_typebound_call (code, NULL);
}
/* Resolve the argument expressions, */
resolve_arg_exprs (code->expr1->value.compcall.actual);
c = gfc_find_component (declared, "$data", true, true);
declared = c->ts.u.derived;
/* Get the data component, which is of the declared type. */
derived = declared->components->ts.u.derived;
/* Keep the generic name so that the vtab reference can be made. */
genname = NULL;
if (code->expr1->value.compcall.tbp->is_generic)
genname = code->expr1->value.compcall.name;
class_try = SUCCESS;
fcn_flag = false;
list_e = gfc_copy_expr (code->expr1);
resolve_typebound_call (code, &name);
ts = code->expr1->ts;
if (check_class_members (derived) == FAILURE)
return FAILURE;
/* Then convert the expression to a procedure pointer component call. */
code->expr1->value.function.esym = NULL;
code->expr1->symtree = st;
class_try = (resolve_typebound_call (code) == SUCCESS)
? class_try : FAILURE;
if (class_ref)
{
gfc_free_ref_list (class_ref->next);
code->expr1->ref = new_ref;
}
/* Transfer the class list to the original expression. Note that
the class_esym list is cleaned up in trans-expr.c, as the calls
are translated. */
code->expr1->value.function.class_esym
= list_e->value.function.class_esym;
list_e->value.function.class_esym = NULL;
gfc_free_expr (list_e);
/* '$vptr' points to the vtab, which contains the procedure pointers. */
gfc_add_component_ref (code->expr1, "$vptr");
if (genname)
{
/* A generic procedure needs the subsidiary vtabs and vtypes for
the specific procedures to have been build. */
gfc_symbol *vtab;
vtab = gfc_find_derived_vtab (declared, true);
gcc_assert (vtab);
gfc_add_component_ref (code->expr1, genname);
}
gfc_add_component_ref (code->expr1, name);
resolve_class_esym (code->expr1);
/* More than one typebound procedure so transmit an expression for
the hash_value as the selector. */
if (code->expr1->value.function.class_esym != NULL)
code->expr1->value.function.class_esym->hash_value
= hash_value_expr (class_ref, new_ref, st);
return class_try;
/* Recover the typespec for the expression. This is really only
necessary for generic procedures, where the additional call
to gfc_add_component_ref seems to throw the collection of the
correct typespec. */
code->expr1->ts = ts;
return SUCCESS;
}
@ -7372,7 +7233,7 @@ resolve_select_type (gfc_code *code)
tail->next = NULL;
default_case = tail;
}
/* More than one CLASS IS block? */
if (class_is->block)
{
@ -7428,7 +7289,7 @@ resolve_select_type (gfc_code *code)
new_st->expr1->value.function.actual = gfc_get_actual_arglist ();
new_st->expr1->value.function.actual->expr = gfc_get_variable_expr (code->expr1->symtree);
gfc_add_component_ref (new_st->expr1->value.function.actual->expr, "$vptr");
vtab = gfc_find_derived_vtab (body->ext.case_list->ts.u.derived);
vtab = gfc_find_derived_vtab (body->ext.case_list->ts.u.derived, true);
st = gfc_find_symtree (vtab->ns->sym_root, vtab->name);
new_st->expr1->value.function.actual->next = gfc_get_actual_arglist ();
new_st->expr1->value.function.actual->next->expr = gfc_get_variable_expr (st);
@ -10743,7 +10604,7 @@ resolve_fl_derived (gfc_symbol *sym)
if (c->attr.proc_pointer && c->ts.interface)
{
if (c->ts.interface->attr.procedure)
if (c->ts.interface->attr.procedure && !sym->attr.vtype)
gfc_error ("Interface '%s', used by procedure pointer component "
"'%s' at %L, is declared in a later PROCEDURE statement",
c->ts.interface->name, c->name, &c->loc);
@ -10807,7 +10668,7 @@ resolve_fl_derived (gfc_symbol *sym)
c->ts.u.cl = cl;
}
}
else if (c->ts.interface->name[0] != '\0')
else if (c->ts.interface->name[0] != '\0' && !sym->attr.vtype)
{
gfc_error ("Interface '%s' of procedure pointer component "
"'%s' at %L must be explicit", c->ts.interface->name,
@ -10823,7 +10684,8 @@ resolve_fl_derived (gfc_symbol *sym)
}
/* Procedure pointer components: Check PASS arg. */
if (c->attr.proc_pointer && !c->tb->nopass && c->tb->pass_arg_num == 0)
if (c->attr.proc_pointer && !c->tb->nopass && c->tb->pass_arg_num == 0
&& !sym->attr.vtype)
{
gfc_symbol* me_arg;

375
gcc/fortran/symbol.c
View File

@ -4708,7 +4708,7 @@ gfc_type_compatible (gfc_typespec *ts1, gfc_typespec *ts2)
gfc_try
gfc_build_class_symbol (gfc_typespec *ts, symbol_attribute *attr,
gfc_array_spec **as)
gfc_array_spec **as, bool delayed_vtab)
{
char name[GFC_MAX_SYMBOL_LEN + 5];
gfc_symbol *fclass;
@ -4763,9 +4763,14 @@ gfc_build_class_symbol (gfc_typespec *ts, symbol_attribute *attr,
if (gfc_add_component (fclass, "$vptr", &c) == FAILURE)
return FAILURE;
c->ts.type = BT_DERIVED;
vtab = gfc_find_derived_vtab (ts->u.derived);
gcc_assert (vtab);
c->ts.u.derived = vtab->ts.u.derived;
if (delayed_vtab)
c->ts.u.derived = NULL;
else
{
vtab = gfc_find_derived_vtab (ts->u.derived, false);
gcc_assert (vtab);
c->ts.u.derived = vtab->ts.u.derived;
}
c->attr.pointer = 1;
}
@ -4787,10 +4792,344 @@ gfc_build_class_symbol (gfc_typespec *ts, symbol_attribute *attr,
}
/* Find the symbol for a derived type's vtab. */
static void
add_proc_component (gfc_component *c, gfc_symbol *vtype,
gfc_symtree *st, gfc_symbol *specific,
bool is_generic, bool is_generic_specific)
{
/* Add procedure component. */
if (is_generic)
{
if (gfc_add_component (vtype, specific->name, &c) == FAILURE)
return;
c->ts.interface = specific;
}
else if (c && is_generic_specific)
{
c->ts.interface = st->n.tb->u.specific->n.sym;
}
else
{
c = gfc_find_component (vtype, st->name, true, true);
if (!c && gfc_add_component (vtype, st->name, &c) == FAILURE)
return;
c->ts.interface = st->n.tb->u.specific->n.sym;
}
if (!c->tb)
c->tb = XCNEW (gfc_typebound_proc);
*c->tb = *st->n.tb;
c->tb->ppc = 1;
c->attr.procedure = 1;
c->attr.proc_pointer = 1;
c->attr.flavor = FL_PROCEDURE;
c->attr.access = ACCESS_PRIVATE;
c->attr.external = 1;
c->attr.untyped = 1;
c->attr.if_source = IFSRC_IFBODY;
/* A static initializer cannot be used here because the specific
function is not a constant; internal compiler error: in
output_constant, at varasm.c:4623 */
c->initializer = NULL;
}
static void
add_proc_comps (gfc_component *c, gfc_symbol *vtype,
gfc_symtree *st, bool is_generic)
{
if (c == NULL && !is_generic)
{
add_proc_component (c, vtype, st, NULL, false, false);
}
else if (is_generic && st->n.tb && vtype->components == NULL)
{
gfc_tbp_generic* g;
gfc_symbol * specific;
for (g = st->n.tb->u.generic; g; g = g->next)
{
if (!g->specific)
continue;
specific = g->specific->u.specific->n.sym;
add_proc_component (NULL, vtype, st, specific, true, false);
}
}
else if (c->attr.proc_pointer && c->tb)
{
*c->tb = *st->n.tb;
c->tb->ppc = 1;
c->ts.interface = st->n.tb->u.specific->n.sym;
}
}
static void
add_procs_to_declared_vtab1 (gfc_symtree *st, gfc_symbol *vtype,
bool resolved)
{
gfc_component *c;
gfc_symbol *generic;
char name[3 * GFC_MAX_SYMBOL_LEN + 10];
if (!st)
return;
if (st->left)
add_procs_to_declared_vtab1 (st->left, vtype, resolved);
if (st->right)
add_procs_to_declared_vtab1 (st->right, vtype, resolved);
if (!st->n.tb)
return;
if (!st->n.tb->is_generic && st->n.tb->u.specific)
{
c = gfc_find_component (vtype, st->name, true, true);
add_proc_comps (c, vtype, st, false);
}
else if (st->n.tb->is_generic)
{
c = gfc_find_component (vtype, st->name, true, true);
if (c == NULL)
{
/* Add derived type component with generic name. */
if (gfc_add_component (vtype, st->name, &c) == FAILURE)
return;
c->ts.type = BT_DERIVED;
c->attr.flavor = FL_VARIABLE;
c->attr.pointer = 1;
/* Add a special empty derived type as a placeholder. */
sprintf (name, "$empty");
gfc_find_symbol (name, vtype->ns, 0, &generic);
if (generic == NULL)
{
gfc_get_symbol (name, vtype->ns, &generic);
generic->attr.flavor = FL_DERIVED;
generic->refs++;
gfc_set_sym_referenced (generic);
generic->ts.type = BT_UNKNOWN;
generic->attr.zero_comp = 1;
}
c->ts.u.derived = generic;
}
}
}
static void
copy_vtab_proc_comps (gfc_symbol *declared, gfc_symbol *vtype,
bool resolved)
{
gfc_component *c, *cmp;
gfc_symbol *vtab;
vtab = gfc_find_derived_vtab (declared, resolved);
for (cmp = vtab->ts.u.derived->components; cmp; cmp = cmp->next)
{
if (gfc_find_component (vtype, cmp->name, true, true))
continue;
if (gfc_add_component (vtype, cmp->name, &c) == FAILURE)
return;
if (cmp->ts.type == BT_DERIVED)
{
c->ts = cmp->ts;
c->ts.u.derived = cmp->ts.u.derived;
c->attr.flavor = FL_VARIABLE;
c->attr.pointer = 1;
c->initializer = NULL;
continue;
}
c->tb = XCNEW (gfc_typebound_proc);
*c->tb = *cmp->tb;
c->attr.procedure = 1;
c->attr.proc_pointer = 1;
c->attr.flavor = FL_PROCEDURE;
c->attr.access = ACCESS_PRIVATE;
c->attr.external = 1;
c->ts.interface = cmp->ts.interface;
c->attr.untyped = 1;
c->attr.if_source = IFSRC_IFBODY;
c->initializer = NULL;
}
}
static void
add_procs_to_declared_vtab (gfc_symbol *declared, gfc_symbol *vtype,
gfc_symbol *derived, bool resolved)
{
gfc_symbol* super_type;
super_type = gfc_get_derived_super_type (declared);
if (super_type && (super_type != declared))
add_procs_to_declared_vtab (super_type, vtype, derived, resolved);
if (declared != derived)
copy_vtab_proc_comps (declared, vtype, resolved);
if (declared->f2k_derived && declared->f2k_derived->tb_sym_root)
add_procs_to_declared_vtab1 (declared->f2k_derived->tb_sym_root,
vtype, resolved);
if (declared->f2k_derived && declared->f2k_derived->tb_uop_root)
add_procs_to_declared_vtab1 (declared->f2k_derived->tb_uop_root,
vtype, resolved);
}
static
void add_generic_specifics (gfc_symbol *declared, gfc_symbol *vtab,
const char *name)
{
gfc_tbp_generic* g;
gfc_symbol * specific1;
gfc_symbol * specific2;
gfc_symtree *st = NULL;
gfc_component *c;
/* Find the generic procedure using the component name. */
st = gfc_find_typebound_proc (declared, NULL, name, true, NULL);
if (st == NULL)
st = gfc_find_typebound_user_op (declared, NULL, name, true, NULL);
if (st == NULL)
return;
/* Add procedure pointer components for the specific procedures. */
for (g = st->n.tb->u.generic; g; g = g->next)
{
if (!g->specific)
continue;
specific1 = g->specific_st->n.tb->u.specific->n.sym;
c = vtab->ts.u.derived->components;
specific2 = NULL;
/* Override identical specific interface. */
if (vtab->ts.u.derived->components)
{
for (; c; c= c->next)
{
specific2 = c->ts.interface;
if (gfc_compare_interfaces (specific2, specific1,
specific1->name, 0, 0, NULL, 0))
break;
}
}
add_proc_component (c, vtab->ts.u.derived, g->specific_st,
NULL, false, true);
vtab->ts.u.derived->attr.zero_comp = 0;
}
}
static void
add_generics_to_declared_vtab (gfc_symbol *declared, gfc_symbol *vtype,
gfc_symbol *derived, bool resolved)
{
gfc_component *cmp;
gfc_symtree *st = NULL;
gfc_symbol * vtab;
char name[2 * GFC_MAX_SYMBOL_LEN + 8];
gfc_symbol* super_type;
gcc_assert (resolved);
for (cmp = vtype->components; cmp; cmp = cmp->next)
{
if (cmp->ts.type != BT_DERIVED)
continue;
/* The only derived type that does not represent a generic
procedure is the pointer to the parent vtab. */
if (cmp->ts.u.derived
&& strcmp (cmp->ts.u.derived->name, "$extends") == 0)
continue;
/* Find the generic procedure using the component name. */
st = gfc_find_typebound_proc (declared, NULL, cmp->name,
true, NULL);
if (st == NULL)
st = gfc_find_typebound_user_op (declared, NULL, cmp->name,
true, NULL);
/* Should be an error but we pass on it for now. */
if (st == NULL || !st->n.tb->is_generic)
continue;
vtab = NULL;
/* Build a vtab and a special vtype, with only the procedure
pointer fields, to carry the pointers to the specific
procedures. Should this name ever be changed, the same
should be done in trans-expr.c(gfc_trans_assign_vtab_procs). */
sprintf (name, "vtab$%s$%s", vtype->name, cmp->name);
gfc_find_symbol (name, derived->ns, 0, &vtab);
if (vtab == NULL)
{
gfc_get_symbol (name, derived->ns, &vtab);
vtab->ts.type = BT_DERIVED;
vtab->attr.flavor = FL_VARIABLE;
vtab->attr.target = 1;
vtab->attr.save = SAVE_EXPLICIT;
vtab->attr.vtab = 1;
vtab->refs++;
gfc_set_sym_referenced (vtab);
sprintf (name, "%s$%s", vtype->name, cmp->name);
gfc_find_symbol (name, derived->ns, 0, &cmp->ts.u.derived);
if (cmp->ts.u.derived == NULL
|| (strcmp (cmp->ts.u.derived->name, "$empty") == 0))
{
gfc_get_symbol (name, derived->ns, &cmp->ts.u.derived);
if (gfc_add_flavor (&cmp->ts.u.derived->attr, FL_DERIVED,
NULL, &gfc_current_locus) == FAILURE)
return;
cmp->ts.u.derived->refs++;
gfc_set_sym_referenced (cmp->ts.u.derived);
cmp->ts.u.derived->attr.vtype = 1;
cmp->ts.u.derived->attr.zero_comp = 1;
}
vtab->ts.u.derived = cmp->ts.u.derived;
}
/* Store this for later use in setting the pointer. */
cmp->ts.interface = vtab;
if (vtab->ts.u.derived->components)
continue;
super_type = gfc_get_derived_super_type (declared);
if (super_type && (super_type != declared))
add_generic_specifics (super_type, vtab, cmp->name);
add_generic_specifics (declared, vtab, cmp->name);
}
}
/* Find the symbol for a derived type's vtab. A vtab has the following
fields:
$hash a hash value used to identify the derived type
$size the size in bytes of the derived type
$extends a pointer to the vtable of the parent derived type
then:
procedure pointer components for the specific typebound procedures
structure pointers to reduced vtabs that contain procedure
pointers to the specific procedures. */
gfc_symbol *
gfc_find_derived_vtab (gfc_symbol *derived)
gfc_find_derived_vtab (gfc_symbol *derived, bool resolved)
{
gfc_namespace *ns;
gfc_symbol *vtab = NULL, *vtype = NULL;
@ -4815,7 +5154,6 @@ gfc_find_derived_vtab (gfc_symbol *derived)
vtab->attr.target = 1;
vtab->attr.save = SAVE_EXPLICIT;
vtab->attr.vtab = 1;
vtab->attr.access = ACCESS_PRIVATE;
vtab->refs++;
gfc_set_sym_referenced (vtab);
sprintf (name, "vtype$%s", derived->name);
@ -4832,7 +5170,6 @@ gfc_find_derived_vtab (gfc_symbol *derived)
return NULL;
vtype->refs++;
gfc_set_sym_referenced (vtype);
vtype->attr.access = ACCESS_PRIVATE;
/* Add component '$hash'. */
if (gfc_add_component (vtype, "$hash", &c) == FAILURE)
@ -4864,13 +5201,13 @@ gfc_find_derived_vtab (gfc_symbol *derived)
parent = gfc_get_derived_super_type (derived);
if (parent)
{
parent_vtab = gfc_find_derived_vtab (parent);
parent_vtab = gfc_find_derived_vtab (parent, resolved);
c->ts.type = BT_DERIVED;
c->ts.u.derived = parent_vtab->ts.u.derived;
c->initializer = gfc_get_expr ();
c->initializer->expr_type = EXPR_VARIABLE;
gfc_find_sym_tree (parent_vtab->name, parent_vtab->ns, 0,
&c->initializer->symtree);
gfc_find_sym_tree (parent_vtab->name, parent_vtab->ns,
0, &c->initializer->symtree);
}
else
{
@ -4878,13 +5215,25 @@ gfc_find_derived_vtab (gfc_symbol *derived)
c->ts.u.derived = vtype;
c->initializer = gfc_get_null_expr (NULL);
}
}
vtab->ts.u.derived = vtype;
add_procs_to_declared_vtab (derived, vtype, derived, resolved);
vtype->attr.vtype = 1;
}
vtab->ts.u.derived = vtype;
vtab->value = gfc_default_initializer (&vtab->ts);
}
}
/* Catch the call just before the backend declarations are built, so that
the generic procedures have been resolved and the specific procedures
have formal interfaces that can be compared. */
if (resolved
&& vtab->ts.u.derived
&& vtab->ts.u.derived->backend_decl == NULL)
add_generics_to_declared_vtab (derived, vtab->ts.u.derived,
derived, resolved);
return vtab;
}

9
gcc/fortran/trans-decl.c
View File

@ -1070,6 +1070,15 @@ gfc_get_symbol_decl (gfc_symbol * sym)
else
byref = 0;
/* Make sure that the vtab for the declared type is completed. */
if (sym->ts.type == BT_CLASS)
{
gfc_component *c = gfc_find_component (sym->ts.u.derived,
"$data", true, true);
if (!c->ts.u.derived->backend_decl)
gfc_find_derived_vtab (c->ts.u.derived, true);
}
if ((sym->attr.dummy && ! sym->attr.function) || (sym->attr.result && byref))
{
/* Return via extra parameter. */

241
gcc/fortran/trans-expr.c
View File

@ -1532,141 +1532,11 @@ get_proc_ptr_comp (gfc_expr *e)
}
/* Select a class typebound procedure at runtime. */
static void
select_class_proc (gfc_se *se, gfc_class_esym_list *elist,
tree declared, gfc_expr *expr)
{
tree end_label;
tree label;
tree tmp;
tree hash;
stmtblock_t body;
gfc_class_esym_list *next_elist, *tmp_elist;
gfc_se tmpse;
/* Convert the hash expression. */
gfc_init_se (&tmpse, NULL);
gfc_conv_expr (&tmpse, elist->hash_value);
gfc_add_block_to_block (&se->pre, &tmpse.pre);
hash = gfc_evaluate_now (tmpse.expr, &se->pre);
gfc_add_block_to_block (&se->post, &tmpse.post);
/* Fix the function type to be that of the declared type method. */
declared = gfc_create_var (TREE_TYPE (declared), "method");
end_label = gfc_build_label_decl (NULL_TREE);
gfc_init_block (&body);
/* Go through the list of extensions. */
for (; elist; elist = next_elist)
{
/* This case has already been added. */
if (elist->derived == NULL)
goto free_elist;
/* Skip abstract base types. */
if (elist->derived->attr.abstract)
goto free_elist;
/* Run through the chain picking up all the cases that call the
same procedure. */
tmp_elist = elist;
for (; elist; elist = elist->next)
{
tree cval;
if (elist->esym != tmp_elist->esym)
continue;
cval = build_int_cst (TREE_TYPE (hash),
elist->derived->hash_value);
/* Build a label for the hash value. */
label = gfc_build_label_decl (NULL_TREE);
tmp = fold_build3 (CASE_LABEL_EXPR, void_type_node,
cval, NULL_TREE, label);
gfc_add_expr_to_block (&body, tmp);
/* Null the reference the derived type so that this case is
not used again. */
elist->derived = NULL;
}
elist = tmp_elist;
/* Get a pointer to the procedure, */
tmp = gfc_get_symbol_decl (elist->esym);
if (!POINTER_TYPE_P (TREE_TYPE (tmp)))
{
gcc_assert (TREE_CODE (tmp) == FUNCTION_DECL);
tmp = gfc_build_addr_expr (NULL_TREE, tmp);
}
/* Assign the pointer to the appropriate procedure. */
gfc_add_modify (&body, declared,
fold_convert (TREE_TYPE (declared), tmp));
/* Break to the end of the construct. */
tmp = build1_v (GOTO_EXPR, end_label);
gfc_add_expr_to_block (&body, tmp);
/* Free the elists as we go; freeing them in gfc_free_expr causes
segfaults because it occurs too early and too often. */
free_elist:
next_elist = elist->next;
if (elist->hash_value)
gfc_free_expr (elist->hash_value);
gfc_free (elist);
elist = NULL;
}
/* Default is an error. */
label = gfc_build_label_decl (NULL_TREE);
tmp = fold_build3 (CASE_LABEL_EXPR, void_type_node,
NULL_TREE, NULL_TREE, label);
gfc_add_expr_to_block (&body, tmp);
tmp = gfc_trans_runtime_error (true, &expr->where,
"internal error: bad hash value in dynamic dispatch");
gfc_add_expr_to_block (&body, tmp);
/* Write the switch expression. */
tmp = gfc_finish_block (&body);
tmp = build3_v (SWITCH_EXPR, hash, tmp, NULL_TREE);
gfc_add_expr_to_block (&se->pre, tmp);
tmp = build1_v (LABEL_EXPR, end_label);
gfc_add_expr_to_block (&se->pre, tmp);
se->expr = declared;
return;
}
static void
conv_function_val (gfc_se * se, gfc_symbol * sym, gfc_expr * expr)
{
tree tmp;
if (expr && expr->symtree
&& expr->value.function.class_esym)
{
if (!sym->backend_decl)
sym->backend_decl = gfc_get_extern_function_decl (sym);
tmp = sym->backend_decl;
if (!POINTER_TYPE_P (TREE_TYPE (tmp)))
{
gcc_assert (TREE_CODE (tmp) == FUNCTION_DECL);
tmp = gfc_build_addr_expr (NULL_TREE, tmp);
}
select_class_proc (se, expr->value.function.class_esym,
tmp, expr);
return;
}
if (gfc_is_proc_ptr_comp (expr, NULL))
tmp = get_proc_ptr_comp (expr);
else if (sym->attr.dummy)
@ -2614,8 +2484,9 @@ gfc_conv_derived_to_class (gfc_se *parmse, gfc_expr *e,
/* Remember the vtab corresponds to the derived type
not to the class declared type. */
vtab = gfc_find_derived_vtab (e->ts.u.derived);
vtab = gfc_find_derived_vtab (e->ts.u.derived, true);
gcc_assert (vtab);
gfc_trans_assign_vtab_procs (&parmse->pre, e->ts.u.derived, vtab);
tmp = gfc_build_addr_expr (NULL_TREE, gfc_get_symbol_decl (vtab));
gfc_add_modify (&parmse->pre, ctree,
fold_convert (TREE_TYPE (ctree), tmp));
@ -4463,7 +4334,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);
@ -4484,10 +4355,11 @@ gfc_conv_structure (gfc_se * se, gfc_expr * expr, int init)
else if (cm->initializer && cm->initializer->expr_type != EXPR_NULL
&& strcmp (cm->name, "$extends") == 0)
{
tree vtab;
gfc_symbol *vtabs;
vtabs = cm->initializer->symtree->n.sym;
val = gfc_build_addr_expr (NULL_TREE, gfc_get_symbol_decl (vtabs));
CONSTRUCTOR_APPEND_ELT (v, cm->backend_decl, val);
vtab = gfc_build_addr_expr (NULL_TREE, gfc_get_symbol_decl (vtabs));
CONSTRUCTOR_APPEND_ELT (v, cm->backend_decl, vtab);
}
else
{
@ -5579,6 +5451,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). */
@ -5620,9 +5589,9 @@ gfc_trans_class_assign (gfc_code *code)
{
gfc_symbol *vtab;
gfc_symtree *st;
vtab = gfc_find_derived_vtab (code->expr2->ts.u.derived);
vtab = gfc_find_derived_vtab (code->expr2->ts.u.derived, true);
gcc_assert (vtab);
gfc_trans_assign_vtab_procs (&block, code->expr2->ts.u.derived, vtab);
rhs = gfc_get_expr ();
rhs->expr_type = EXPR_VARIABLE;
gfc_find_sym_tree (vtab->name, NULL, 1, &st);

3
gcc/fortran/trans-stmt.c
View File

@ -4278,8 +4278,9 @@ gfc_trans_allocate (gfc_code * code)
if (ts->type == BT_DERIVED)
{
vtab = gfc_find_derived_vtab (ts->u.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);

3
gcc/fortran/trans.h
View File

@ -492,6 +492,9 @@ tree gfc_trans_assignment (gfc_expr *, gfc_expr *, bool, bool);
/* Generate code for a pointer assignment. */
tree gfc_trans_pointer_assignment (gfc_expr *, gfc_expr *);
/* Generate code to assign typebound procedures to a derived vtab. */
void gfc_trans_assign_vtab_procs (stmtblock_t*, gfc_symbol*, gfc_symbol*);
/* Initialize function decls for library functions. */
void gfc_build_intrinsic_lib_fndecls (void);
/* Create function decls for IO library functions. */

38
gcc/testsuite/ChangeLog
View File

@ -1,3 +1,41 @@
2010-04-29 Janus Weil <janus@gcc.gnu.org>
PR fortran/42274
* gfortran.dg/class_16.f03: New test.
2010-04-29 Janus Weil <janus@gcc.gnu.org>
PR fortran/42274
* gfortran.dg/class_15.f03: New.
2010-04-29 Paul Thomas <pault@gcc.gnu.org>
PR fortran/43326
* gfortran.dg/dynamic_dispatch_9.f03: New test.
2010-04-29 Janus Weil <janus@gcc.gnu.org>
PR fortran/43492
* gfortran.dg/generic_22.f03 : New test.
2010-04-29 Paul Thomas <pault@gcc.gnu.org>
PR fortran/42353
* gfortran.dg/class_14.f03: New test.
2010-04-29 Jerry DeLisle <jvdelisle@gcc.gnu.org>
PR fortran/42680
* gfortran.dg/interface_32.f90: New test.
2009-04-29 Paul Thomas <pault@gcc.gnu.org>
Janus Weil <janus@gcc.gnu.org>
PR fortran/41829
* gfortran.dg/dynamic_dispatch_5.f03 : Change to "run".
* gfortran.dg/dynamic_dispatch_7.f03 : New test.
* gfortran.dg/dynamic_dispatch_8.f03 : New test.
2010-04-28 Mike Stump <mikestump@comcast.net>
* g++.dg/uninit-pred-1_b.C: Use dg-message instead of

54
gcc/testsuite/gfortran.dg/class_14.f03 Normal file
View File

@ -0,0 +1,54 @@
! { dg-do "compile" }
! Test the final fix for PR42353, in which a compilation error was
! occurring because the derived type of the initializer of the vtab
! component '$extends' was not the same as that of the component.
!
! Contributed by Harald Anlauf <anlauf@gmx.de>
!
module abstract_vector
implicit none
type, abstract :: vector_class
end type vector_class
end module abstract_vector
!-------------------------
module concrete_vector
use abstract_vector
implicit none
type, extends(vector_class) :: trivial_vector_type
end type trivial_vector_type
private :: my_assign
contains
subroutine my_assign (this,v)
class(trivial_vector_type), intent(inout) :: this
class(vector_class), intent(in) :: v
end subroutine my_assign
end module concrete_vector
!---------------------------
module concrete_gradient
use abstract_vector
implicit none
type, abstract, extends(vector_class) :: gradient_class
end type gradient_class
type, extends(gradient_class) :: trivial_gradient_type
end type trivial_gradient_type
private :: my_assign
contains
subroutine my_assign (this,v)
class(trivial_gradient_type), intent(inout) :: this
class(vector_class), intent(in) :: v
end subroutine my_assign
end module concrete_gradient
!----------------------------
module concrete_inner_product
use concrete_vector
use concrete_gradient
implicit none
end module concrete_inner_product
! { dg-final { cleanup-modules "abstract_vector concrete_vector" } }
! { dg-final { cleanup-modules "concrete_gradient concrete_inner_product" } }

43
gcc/testsuite/gfortran.dg/class_15.f03 Normal file
View File

@ -0,0 +1,43 @@
! { dg-do compile }
!
! PR 42274: [fortran-dev Regression] ICE: segmentation fault
!
! Original test case by Salvatore Filippone <sfilippone@uniroma2.it>
! Modified by Janus Weil <janus@gcc.gnu.org>
module mod_A
type :: t1
contains
procedure,nopass :: fun
end type
contains
logical function fun()
end function
end module
module mod_B
use mod_A
type, extends(t1) :: t2
contains
procedure :: sub1
end type
contains
subroutine sub1(a)
class(t2) :: a
end subroutine
end module
module mod_C
contains
subroutine sub2(b)
use mod_B
type(t2) :: b
end subroutine
end module
module mod_D
use mod_A
use mod_C
end module
! { dg-final { cleanup-modules "mod_A mod_B mod_C mod_D" } }

23
gcc/testsuite/gfortran.dg/class_16.f03 Normal file
View File

@ -0,0 +1,23 @@
! { dg-do compile }
!
! PR 43896: [fortran-dev Regression] ICE in gfc_conv_variable, at fortran/trans-expr.c:551
!
! Contributed by Fran Martinez Fadrique <fmartinez@gmv.com>
module m_rotation_matrix
type t_rotation_matrix
contains
procedure :: array => rotation_matrix_array
end type
contains
function rotation_matrix_array( rot ) result(array)
class(t_rotation_matrix) :: rot
double precision, dimension(3,3) :: array
end function
end module
! { dg-final { cleanup-modules "m_rotation_matrix" } }

6
gcc/testsuite/gfortran.dg/dynamic_dispatch_5.f03
View File

@ -1,4 +1,4 @@
! { dg-do compile }
! { dg-do run }
! Tests the fix for PR4164656 in which the call to a%a%scal failed to compile.
!
! Contributed by Salvatore Filippone <sfilippone@uniroma2.it>
@ -166,7 +166,8 @@ contains
integer :: err_act
character(len=20) :: name='csnmi'
logical, parameter :: debug=.false.
print *, "s_scals"
! print *, "s_scals"
info = 0
call a%a%scal(d,info)
return
end subroutine s_scals
@ -180,6 +181,7 @@ end module s_mat_mod
b%a => c
a => b
call a%scal (1.0_spk_, info)
if (info .ne. 700) call abort
end
! { dg-final { cleanup-modules "const_mod base_mat_mod s_base_mat_mod s_mat_mod" } }

19
gcc/testsuite/gfortran.dg/dynamic_dispatch_7.f03
View File

@ -7,8 +7,8 @@
! Contributed by Janus Weil <janus@gcc.gnu.org>
!
module m1
type :: t1
contains
type :: t1
contains
procedure :: sizeof
end type
contains
@ -17,11 +17,10 @@ contains
sizeof = 1
end function sizeof
end module
module m2
use m1
type, extends(t1) :: t2
type, extends(t1) :: t2
contains
procedure :: sizeof => sizeof2
end type
@ -32,19 +31,18 @@ contains
end function
end module
module m3
use m2
type :: t3
class(t1), pointer :: a
class(t1), pointer :: a
contains
procedure :: sizeof => sizeof3
end type
contains
contains
integer function sizeof3(a)
class(t3) :: a
sizeof3 = a%a%sizeof()
end function
end function
end module
use m1
@ -57,8 +55,7 @@ end module
if ((z%sizeof() .ne. 1) .or. (z%a%sizeof() .ne. 1)) call abort
z%a => y
if ((z%sizeof() .ne. 2) .or. (z%a%sizeof() .ne. 2)) call abort
end
! { dg-final { cleanup-modules "m1 m2 m3" } }

108
gcc/testsuite/gfortran.dg/dynamic_dispatch_8.f03 Normal file
View File

@ -0,0 +1,108 @@
! { dg-do run }
!
! PR 41829: [OOP] Runtime error with dynamic dispatching. Tests
! dynamic dispatch in a case where the caller knows nothing about
! the dynamic type at compile time.
!
! Contributed by Salvatore Filippone <sfilippone@uniroma2.it>
!
module foo_mod
type foo
integer :: i
contains
procedure, pass(a) :: doit
procedure, pass(a) :: getit
end type foo
private doit,getit
contains
subroutine doit(a)
class(foo) :: a
a%i = 1
! write(*,*) 'FOO%DOIT base version'
end subroutine doit
function getit(a) result(res)
class(foo) :: a
integer :: res
res = a%i
end function getit
end module foo_mod
module foo2_mod
use foo_mod
type, extends(foo) :: foo2
integer :: j
contains
procedure, pass(a) :: doit => doit2
procedure, pass(a) :: getit => getit2
end type foo2
private doit2, getit2
contains
subroutine doit2(a)
class(foo2) :: a
a%i = 2
a%j = 3
! write(*,*) 'FOO2%DOIT derived version'
end subroutine doit2
function getit2(a) result(res)
class(foo2) :: a
integer :: res
res = a%j
end function getit2
end module foo2_mod
module bar_mod
use foo_mod
type bar
class(foo), allocatable :: a
contains
procedure, pass(a) :: doit
procedure, pass(a) :: getit
end type bar
private doit,getit
contains
subroutine doit(a)
class(bar) :: a
call a%a%doit()
end subroutine doit
function getit(a) result(res)
class(bar) :: a
integer :: res
res = a%a%getit()
end function getit
end module bar_mod
program testd10
use foo_mod
use foo2_mod
use bar_mod
type(bar) :: a
allocate(foo :: a%a)
call a%doit()
! write(*,*) 'Getit value : ', a%getit()
if (a%getit() .ne. 1) call abort
deallocate(a%a)
allocate(foo2 :: a%a)
call a%doit()
! write(*,*) 'Getit value : ', a%getit()
if (a%getit() .ne. 3) call abort
end program testd10
! { dg-final { cleanup-modules "foo_mod foo2_mod bar_mod" } }

54
gcc/testsuite/gfortran.dg/dynamic_dispatch_9.f03 Normal file
View File

@ -0,0 +1,54 @@
! { dg-do run }
!
! [OOP] Ensure that different specifc interfaces are
! handled properly by dynamic dispatch.
!
! Contributed by Salvatore Filippone <sfilippone@uniroma2.it>
!
module m
type :: t
contains
procedure :: a
generic :: gen => a
end type
type,extends(t) :: t2
contains
procedure :: b
generic :: gen => b
end type
contains
real function a(ct,x)
class(t) :: ct
real :: x
a=2*x
end function
integer function b(ct,x)
class(t2) :: ct
integer :: x
b=3*x
end function
end
use m
class(t), allocatable :: o1
type (t) :: t1
class(t2), allocatable :: o2
allocate(o1)
allocate(o2)
if (t1%gen(2.0) .ne. o1%gen(2.0)) call abort
if (t1%gen(2.0) .ne. o2%gen(2.0)) call abort
if (o2%gen(3) .ne. 9) call abort
end
! { dg-final { cleanup-modules "m" } }

38
gcc/testsuite/gfortran.dg/generic_22.f03 Normal file
View File

@ -0,0 +1,38 @@
! { dg-do compile }
! Test the fix for PR43492, in which the generic call caused and ICE.
!
! Contributed by Salvatore Filippone <sfilippone@uniroma2.it>
!
module base_mod
type :: base_mat
integer, private :: m, n
contains
procedure, pass(a) :: transp1 => base_transp1
generic, public :: transp => transp1
procedure, pass(a) :: transc1 => base_transc1
generic, public :: transc => transc1
end type base_mat
contains
subroutine base_transp1(a)
implicit none
class(base_mat), intent(inout) :: a
integer :: itmp
itmp = a%m
a%m = a%n
a%n = itmp
end subroutine base_transp1
subroutine base_transc1(a)
implicit none
class(base_mat), intent(inout) :: a
call a%transp()
!!$ call a%transp1()
end subroutine base_transc1
end module base_mod
! { dg-final { cleanup-modules "m" } }

81
gcc/testsuite/gfortran.dg/interface_32.f90 Normal file
View File

@ -0,0 +1,81 @@
! { dg-do compile }
module m1
implicit none
type, abstract :: vector_class
end type vector_class
end module m1
!---------------------------------------------------------------
module m2
use m1
implicit none
type, abstract :: inner_product_class
contains
procedure(dot), deferred :: dot_v_v
procedure(dot), deferred :: dot_g_g
procedure(sub), deferred :: D_times_v
procedure(sub), deferred :: D_times_g
end type inner_product_class
abstract interface
function dot (this,a,b)
import :: inner_product_class
import :: vector_class
class(inner_product_class), intent(in) :: this
class(vector_class), intent(in) :: a,b
real :: dot
end function
subroutine sub (this,a)
import :: inner_product_class
import :: vector_class
class(inner_product_class), intent(in) :: this
class(vector_class), intent(inout) :: a
end subroutine
end interface
end module m2
!---------------------------------------------------------------
module m3
use :: m1
use :: m2
implicit none
private
public :: gradient_class
type, abstract, extends(vector_class) :: gradient_class
class(inner_product_class), pointer :: my_inner_product => NULL()
contains
procedure, non_overridable :: inquire_inner_product
procedure(op_g_v), deferred :: to_vector
end type gradient_class
abstract interface
subroutine op_g_v(this,v)
import vector_class
import gradient_class
class(gradient_class), intent(in) :: this
class(vector_class), intent(inout) :: v
end subroutine
end interface
contains
function inquire_inner_product (this)
class(gradient_class) :: this
class(inner_product_class), pointer :: inquire_inner_product
inquire_inner_product => this%my_inner_product
end function inquire_inner_product
end module m3
!---------------------------------------------------------------
module m4
use m3
use m2
implicit none
contains
subroutine cg (g_initial)
class(gradient_class), intent(in) :: g_initial
class(inner_product_class), pointer :: ip_save
ip_save => g_initial%inquire_inner_product()
end subroutine cg
end module m4
! { dg-final { cleanup-modules "m1 m2 m3 m4" } }