backport: re PR fortran/42053 ([OOP] SELECT TYPE: reject duplicate CLASS IS blocks)

merge from fortran-dev branch:


gcc/fortran/

2009-11-30  Janus Weil  <janus@gcc.gnu.org>

	PR fortran/42053
	* resolve.c (resolve_select_type): Check for duplicate CLASS IS blocks.

2009-11-30  Janus Weil  <janus@gcc.gnu.org>

	PR fortran/41631
	* decl.c (gfc_match_derived_decl): Set extension level.
	* gfortran.h (symbol_attribute): Expand 'extension' bit field to 8 bit.
	* iresolve.c (gfc_resolve_extends_type_of): Return value of
	'is_extension_of' has kind=4.
	* match.c (select_type_set_tmp,gfc_match_class_is): Create temporary
	for CLASS IS blocks.
	* module.c (MOD_VERSION): Bump module version.
	(ab_attribute,attr_bits): Remove AB_EXTENSION.
	(mio_symbol_attribute): Handle expanded 'extension' field.
	* resolve.c (resolve_select_type): Implement CLASS IS blocks.
	(resolve_fl_variable_derived): Show correct type name.
	* symbol.c (gfc_build_class_symbol): Set extension level.

2009-11-30  Janus Weil  <janus@gcc.gnu.org>

	* intrinsic.h (gfc_resolve_extends_type_of): Add prototype.
	* intrinsic.c (add_functions): Use 'gfc_resolve_extends_type_of'.
	* iresolve.c (gfc_resolve_extends_type_of): New function, which
	replaces the call to EXTENDS_TYPE_OF by the library function
	'is_extension_of' and modifies the arguments.
	* trans-intrinsic.c (gfc_conv_extends_type_of): Removed.
	(gfc_conv_intrinsic_function): FOR EXTENDS_TYPE_OF, don't call
	gfc_conv_extends_type_of but gfc_conv_intrinsic_funcall.

2009-11-30  Paul Thomas  <pault@gcc.gnu.org>
	    Janus Weil  <janus@gcc.gnu.org>

	* decl.c (encapsulate_class_symbol): Replaced by
	'gfc_build_class_symbol'.
	(build_sym,build_struct): Call 'gfc_build_class_symbol'.
	(gfc_match_derived_decl): Replace vindex by hash_value.
	* dump-parse-tree.c (show_symbol): Replace vindex by hash_value.
	* gfortran.h (symbol_attribute): Add field 'vtab'.
	(gfc_symbol): Replace vindex by hash_value.
	(gfc_class_esym_list): Ditto.
	(gfc_get_derived_type,gfc_build_class_symbol,gfc_find_derived_vtab):
	New prototypes.
	* module.c (mio_symbol): Replace vindex by hash_value.
	* resolve.c (vindex_expr): Rename to 'hash_value_expr'.
	(resolve_class_compcall,resolve_class_typebound_call): Renamed
	'vindex_expr'.
	(resolve_select_type): Replace $vindex by $vptr->$hash.
	* symbol.c (gfc_add_save): Handle vtab symbols.
	(gfc_type_compatible): Rewrite.
	(gfc_build_class_symbol): New function which replaces
	'encapsulate_class_symbol'.
	(gfc_find_derived_vtab): New function to set up a vtab symbol for a
	derived type.
	* trans-decl.c (gfc_create_module_variable): Handle vtab symbols.
	* trans-expr.c (select_class_proc): Replace vindex by hash_value.
	(gfc_conv_derived_to_class): New function to construct a temporary
	CLASS variable from a derived type expression.
	(gfc_conv_procedure_call): Call 'gfc_conv_derived_to_class'.
	(gfc_conv_structure): Initialize the $extends and $size fields of
	vtab symbols.
	(gfc_trans_class_assign): Replace $vindex by $vptr. Remove the $size
	assignment.
	* trans-intrinsic.c (gfc_conv_same_type_as): Replace $vindex by
	$vptr->$hash, and replace vindex by hash_value.
	* trans-stmt.c (gfc_trans_allocate): Insert $vptr references, replace
	$vindex by $vptr. Remove the $size assignment.
	* trans-types.c (gfc_get_derived_type): Make it non-static.


gcc/testsuite/

2009-11-30  Janus Weil  <janus@gcc.gnu.org>

	PR fortran/42053
	* gfortran.dg/select_type_9.f03: New.

2009-11-30  Janus Weil  <janus@gcc.gnu.org>

	PR fortran/41631
	* gfortran.dg/extends_type_of_1.f03: Fix invalid test case.
	* gfortran.dg/module_md5_1.f90: Adjusted MD5 sum.
	* gfortran.dg/select_type_1.f03: Remove FIXMEs.
	* gfortran.dg/select_type_2.f03: Ditto.
	* gfortran.dg/select_type_8.f03: New test.

2009-11-30  Janus Weil  <janus@gcc.gnu.org>

	* gfortran.dg/extends_type_of_1.f03: New test.
	* gfortran.dg/same_type_as_1.f03: Extended.

2009-11-30  Paul Thomas  <pault@gcc.gnu.org>

	* gfortran.dg/class_4c.f03: Add dg-additional-sources.
	* gfortran.dg/class_4d.f03: Rename module. Cleanup modules.


libgfortran/

2009-11-30  Janus Weil  <janus@gcc.gnu.org>

	* gfortran.map: Add _gfortran_is_extension_of.
	* Makefile.am: Add intrinsics/extends_type_of.c.
	* Makefile.in: Regenerated.
	* intrinsics/extends_type_of.c: New file.

From-SVN: r154840
This commit is contained in:
Janus Weil 2009-11-30 21:43:06 +01:00
parent 8146bb5887
commit 7c1dab0d8b
31 changed files with 1018 additions and 356 deletions

View File

@ -1,3 +1,74 @@
2009-11-30 Janus Weil <janus@gcc.gnu.org>
PR fortran/42053
* resolve.c (resolve_select_type): Check for duplicate CLASS IS blocks.
2009-11-30 Janus Weil <janus@gcc.gnu.org>
PR fortran/41631
* decl.c (gfc_match_derived_decl): Set extension level.
* gfortran.h (symbol_attribute): Expand 'extension' bit field to 8 bit.
* iresolve.c (gfc_resolve_extends_type_of): Return value of
'is_extension_of' has kind=4.
* match.c (select_type_set_tmp,gfc_match_class_is): Create temporary
for CLASS IS blocks.
* module.c (MOD_VERSION): Bump module version.
(ab_attribute,attr_bits): Remove AB_EXTENSION.
(mio_symbol_attribute): Handle expanded 'extension' field.
* resolve.c (resolve_select_type): Implement CLASS IS blocks.
(resolve_fl_variable_derived): Show correct type name.
* symbol.c (gfc_build_class_symbol): Set extension level.
2009-11-30 Janus Weil <janus@gcc.gnu.org>
* intrinsic.h (gfc_resolve_extends_type_of): Add prototype.
* intrinsic.c (add_functions): Use 'gfc_resolve_extends_type_of'.
* iresolve.c (gfc_resolve_extends_type_of): New function, which
replaces the call to EXTENDS_TYPE_OF by the library function
'is_extension_of' and modifies the arguments.
* trans-intrinsic.c (gfc_conv_extends_type_of): Removed.
(gfc_conv_intrinsic_function): FOR EXTENDS_TYPE_OF, don't call
gfc_conv_extends_type_of but gfc_conv_intrinsic_funcall.
2009-11-30 Paul Thomas <pault@gcc.gnu.org>
Janus Weil <janus@gcc.gnu.org>
* decl.c (encapsulate_class_symbol): Replaced by
'gfc_build_class_symbol'.
(build_sym,build_struct): Call 'gfc_build_class_symbol'.
(gfc_match_derived_decl): Replace vindex by hash_value.
* dump-parse-tree.c (show_symbol): Replace vindex by hash_value.
* gfortran.h (symbol_attribute): Add field 'vtab'.
(gfc_symbol): Replace vindex by hash_value.
(gfc_class_esym_list): Ditto.
(gfc_get_derived_type,gfc_build_class_symbol,gfc_find_derived_vtab):
New prototypes.
* module.c (mio_symbol): Replace vindex by hash_value.
* resolve.c (vindex_expr): Rename to 'hash_value_expr'.
(resolve_class_compcall,resolve_class_typebound_call): Renamed
'vindex_expr'.
(resolve_select_type): Replace $vindex by $vptr->$hash.
* symbol.c (gfc_add_save): Handle vtab symbols.
(gfc_type_compatible): Rewrite.
(gfc_build_class_symbol): New function which replaces
'encapsulate_class_symbol'.
(gfc_find_derived_vtab): New function to set up a vtab symbol for a
derived type.
* trans-decl.c (gfc_create_module_variable): Handle vtab symbols.
* trans-expr.c (select_class_proc): Replace vindex by hash_value.
(gfc_conv_derived_to_class): New function to construct a temporary
CLASS variable from a derived type expression.
(gfc_conv_procedure_call): Call 'gfc_conv_derived_to_class'.
(gfc_conv_structure): Initialize the $extends and $size fields of
vtab symbols.
(gfc_trans_class_assign): Replace $vindex by $vptr. Remove the $size
assignment.
* trans-intrinsic.c (gfc_conv_same_type_as): Replace $vindex by
$vptr->$hash, and replace vindex by hash_value.
* trans-stmt.c (gfc_trans_allocate): Insert $vptr references, replace
$vindex by $vptr. Remove the $size assignment.
* trans-types.c (gfc_get_derived_type): Make it non-static.
2009-11-30 Thomas Koenig <tkoenig@gcc.gnu.org>
PR fortran/42131

View File

@ -1025,88 +1025,6 @@ verify_c_interop_param (gfc_symbol *sym)
}
/* Build a polymorphic CLASS entity, using the symbol that comes from build_sym.
A CLASS entity is represented by an encapsulating type, which contains the
declared type as '$data' component, plus an integer component '$vindex'
which determines the dynamic type, and another integer '$size', which
contains the size of the dynamic type structure. */
static gfc_try
encapsulate_class_symbol (gfc_typespec *ts, symbol_attribute *attr,
gfc_array_spec **as)
{
char name[GFC_MAX_SYMBOL_LEN + 5];
gfc_symbol *fclass;
gfc_component *c;
/* Determine the name of the encapsulating type. */
if ((*as) && (*as)->rank && attr->allocatable)
sprintf (name, ".class.%s.%d.a", ts->u.derived->name, (*as)->rank);
else if ((*as) && (*as)->rank)
sprintf (name, ".class.%s.%d", ts->u.derived->name, (*as)->rank);
else if (attr->allocatable)
sprintf (name, ".class.%s.a", ts->u.derived->name);
else
sprintf (name, ".class.%s", ts->u.derived->name);
gfc_find_symbol (name, ts->u.derived->ns, 0, &fclass);
if (fclass == NULL)
{
gfc_symtree *st;
/* If not there, create a new symbol. */
fclass = gfc_new_symbol (name, ts->u.derived->ns);
st = gfc_new_symtree (&ts->u.derived->ns->sym_root, name);
st->n.sym = fclass;
gfc_set_sym_referenced (fclass);
fclass->refs++;
fclass->ts.type = BT_UNKNOWN;
fclass->vindex = ts->u.derived->vindex;
fclass->attr.abstract = ts->u.derived->attr.abstract;
if (ts->u.derived->f2k_derived)
fclass->f2k_derived = gfc_get_namespace (NULL, 0);
if (gfc_add_flavor (&fclass->attr, FL_DERIVED,
NULL, &gfc_current_locus) == FAILURE)
return FAILURE;
/* Add component '$data'. */
if (gfc_add_component (fclass, "$data", &c) == FAILURE)
return FAILURE;
c->ts = *ts;
c->ts.type = BT_DERIVED;
c->attr.access = ACCESS_PRIVATE;
c->ts.u.derived = ts->u.derived;
c->attr.pointer = attr->pointer || attr->dummy;
c->attr.allocatable = attr->allocatable;
c->attr.dimension = attr->dimension;
c->attr.abstract = ts->u.derived->attr.abstract;
c->as = (*as);
c->initializer = gfc_get_expr ();
c->initializer->expr_type = EXPR_NULL;
/* Add component '$vindex'. */
if (gfc_add_component (fclass, "$vindex", &c) == FAILURE)
return FAILURE;
c->ts.type = BT_INTEGER;
c->ts.kind = 4;
c->attr.access = ACCESS_PRIVATE;
c->initializer = gfc_int_expr (0);
/* Add component '$size'. */
if (gfc_add_component (fclass, "$size", &c) == FAILURE)
return FAILURE;
c->ts.type = BT_INTEGER;
c->ts.kind = 4;
c->attr.access = ACCESS_PRIVATE;
c->initializer = gfc_int_expr (0);
}
fclass->attr.extension = 1;
fclass->attr.is_class = 1;
ts->u.derived = fclass;
attr->allocatable = attr->pointer = attr->dimension = 0;
(*as) = NULL; /* XXX */
return SUCCESS;
}
/* Function called by variable_decl() that adds a name to the symbol table. */
@ -1185,7 +1103,7 @@ build_sym (const char *name, gfc_charlen *cl,
sym->attr.class_ok = (sym->attr.dummy
|| sym->attr.pointer
|| sym->attr.allocatable) ? 1 : 0;
encapsulate_class_symbol (&sym->ts, &sym->attr, &sym->as);
gfc_build_class_symbol (&sym->ts, &sym->attr, &sym->as);
}
return SUCCESS;
@ -1594,7 +1512,7 @@ build_struct (const char *name, gfc_charlen *cl, gfc_expr **init,
scalar:
if (c->ts.type == BT_CLASS)
encapsulate_class_symbol (&c->ts, &c->attr, &c->as);
gfc_build_class_symbol (&c->ts, &c->attr, &c->as);
return t;
}
@ -6926,13 +6844,23 @@ gfc_match_derived_decl (void)
/* Add the extended derived type as the first component. */
gfc_add_component (sym, parent, &p);
sym->attr.extension = attr.extension;
extended->refs++;
gfc_set_sym_referenced (extended);
p->ts.type = BT_DERIVED;
p->ts.u.derived = extended;
p->initializer = gfc_default_initializer (&p->ts);
/* Set extension level. */
if (extended->attr.extension == 255)
{
/* Since the extension field is 8 bit wide, we can only have
up to 255 extension levels. */
gfc_error ("Maximum extension level reached with type '%s' at %L",
extended->name, &extended->declared_at);
return MATCH_ERROR;
}
sym->attr.extension = extended->attr.extension + 1;
/* Provide the links between the extended type and its extension. */
if (!extended->f2k_derived)
@ -6941,9 +6869,9 @@ gfc_match_derived_decl (void)
st->n.sym = sym;
}
if (!sym->vindex)
/* Set the vindex for this type. */
sym->vindex = hash_value (sym);
if (!sym->hash_value)
/* Set the hash for the compound name for this type. */
sym->hash_value = hash_value (sym);
/* Take over the ABSTRACT attribute. */
sym->attr.abstract = attr.abstract;

View File

@ -827,8 +827,8 @@ show_symbol (gfc_symbol *sym)
if (sym->f2k_derived)
{
show_indent ();
if (sym->vindex)
fprintf (dumpfile, "vindex: %d", sym->vindex);
if (sym->hash_value)
fprintf (dumpfile, "hash: %d", sym->hash_value);
show_f2k_derived (sym->f2k_derived);
}

View File

@ -670,9 +670,10 @@ typedef struct
unsigned untyped:1; /* No implicit type could be found. */
unsigned is_bind_c:1; /* say if is bound to C. */
unsigned extension:1; /* extends a derived type. */
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. */
/* These flags are both in the typespec and attribute. The attribute
list is what gets read from/written to a module file. The typespec
@ -1137,8 +1138,8 @@ typedef struct gfc_symbol
int entry_id; /* Used in resolve.c for entries. */
/* CLASS vindex for declared and dynamic types in the class. */
int vindex;
/* CLASS hashed name for declared and dynamic types in the class. */
int hash_value;
struct gfc_symbol *common_next; /* Links for COMMON syms */
@ -1599,7 +1600,7 @@ typedef struct gfc_class_esym_list
{
gfc_symbol *derived;
gfc_symbol *esym;
struct gfc_expr *vindex;
struct gfc_expr *hash_value;
struct gfc_class_esym_list *next;
}
gfc_class_esym_list;
@ -2380,6 +2381,7 @@ gfc_try gfc_check_any_c_kind (gfc_typespec *);
int gfc_validate_kind (bt, int, bool);
int gfc_get_int_kind_from_width_isofortranenv (int size);
int gfc_get_real_kind_from_width_isofortranenv (int size);
tree gfc_get_derived_type (gfc_symbol * derived);
extern int gfc_index_integer_kind;
extern int gfc_default_integer_kind;
extern int gfc_max_integer_kind;
@ -2517,6 +2519,9 @@ void gfc_free_dt_list (void);
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_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*);

View File

@ -1601,7 +1601,7 @@ add_functions (void)
add_sym_2 ("extends_type_of", GFC_ISYM_EXTENDS_TYPE_OF, CLASS_INQUIRY,
ACTUAL_NO, BT_LOGICAL, dl, GFC_STD_F2003,
gfc_check_same_type_as, NULL, NULL,
gfc_check_same_type_as, NULL, gfc_resolve_extends_type_of,
a, BT_UNKNOWN, 0, REQUIRED,
mo, BT_UNKNOWN, 0, REQUIRED);

View File

@ -390,6 +390,7 @@ void gfc_resolve_eoshift (gfc_expr *, gfc_expr *, gfc_expr *, gfc_expr *,
void gfc_resolve_etime_sub (gfc_code *);
void gfc_resolve_exp (gfc_expr *, gfc_expr *);
void gfc_resolve_exponent (gfc_expr *, gfc_expr *);
void gfc_resolve_extends_type_of (gfc_expr *, gfc_expr *, gfc_expr *);
void gfc_resolve_fdate (gfc_expr *);
void gfc_resolve_floor (gfc_expr *, gfc_expr *, gfc_expr *);
void gfc_resolve_fnum (gfc_expr *, gfc_expr *);

View File

@ -806,6 +806,57 @@ gfc_resolve_exponent (gfc_expr *f, gfc_expr *x)
}
/* Resolve the EXTENDS_TYPE_OF intrinsic function. */
void
gfc_resolve_extends_type_of (gfc_expr *f, gfc_expr *a, gfc_expr *mo)
{
gfc_symbol *vtab;
gfc_symtree *st;
/* Prevent double resolution. */
if (f->ts.type == BT_LOGICAL)
return;
/* Replace the first argument with the corresponding vtab. */
if (a->ts.type == BT_CLASS)
gfc_add_component_ref (a, "$vptr");
else if (a->ts.type == BT_DERIVED)
{
vtab = gfc_find_derived_vtab (a->ts.u.derived);
/* Clear the old expr. */
gfc_free_ref_list (a->ref);
memset (a, '\0', sizeof (gfc_expr));
/* Construct a new one. */
a->expr_type = EXPR_VARIABLE;
st = gfc_find_symtree (vtab->ns->sym_root, vtab->name);
a->symtree = st;
a->ts = vtab->ts;
}
/* Replace the second argument with the corresponding vtab. */
if (mo->ts.type == BT_CLASS)
gfc_add_component_ref (mo, "$vptr");
else if (mo->ts.type == BT_DERIVED)
{
vtab = gfc_find_derived_vtab (mo->ts.u.derived);
/* Clear the old expr. */
gfc_free_ref_list (mo->ref);
memset (mo, '\0', sizeof (gfc_expr));
/* Construct a new one. */
mo->expr_type = EXPR_VARIABLE;
st = gfc_find_symtree (vtab->ns->sym_root, vtab->name);
mo->symtree = st;
mo->ts = vtab->ts;
}
f->ts.type = BT_LOGICAL;
f->ts.kind = 4;
/* Call library function. */
f->value.function.name = gfc_get_string (PREFIX ("is_extension_of"));
}
void
gfc_resolve_fdate (gfc_expr *f)
{

View File

@ -3968,13 +3968,25 @@ select_type_set_tmp (gfc_typespec *ts)
{
char name[GFC_MAX_SYMBOL_LEN];
gfc_symtree *tmp;
if (!gfc_type_is_extensible (ts->u.derived))
return;
sprintf (name, "tmp$%s", ts->u.derived->name);
if (ts->type == BT_CLASS)
sprintf (name, "tmp$class$%s", ts->u.derived->name);
else
sprintf (name, "tmp$type$%s", ts->u.derived->name);
gfc_get_sym_tree (name, gfc_current_ns, &tmp, false);
gfc_add_type (tmp->n.sym, ts, NULL);
gfc_set_sym_referenced (tmp->n.sym);
gfc_add_pointer (&tmp->n.sym->attr, NULL);
gfc_add_flavor (&tmp->n.sym->attr, FL_VARIABLE, name, NULL);
if (ts->type == BT_CLASS)
{
gfc_build_class_symbol (&tmp->n.sym->ts, &tmp->n.sym->attr,
&tmp->n.sym->as);
tmp->n.sym->attr.class_ok = 1;
}
select_type_stack->tmp = tmp;
}
@ -4228,8 +4240,9 @@ gfc_match_class_is (void)
new_st.op = EXEC_SELECT_TYPE;
new_st.ext.case_list = c;
gfc_error_now ("CLASS IS specification at %C is not yet supported");
/* Create temporary variable. */
select_type_set_tmp (&c->ts);
return MATCH_YES;

View File

@ -77,7 +77,7 @@ along with GCC; see the file COPYING3. If not see
/* Don't put any single quote (') in MOD_VERSION,
if yout want it to be recognized. */
#define MOD_VERSION "3"
#define MOD_VERSION "4"
/* Structure that describes a position within a module file. */
@ -1671,7 +1671,7 @@ typedef enum
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_IS_CLASS, AB_PROCEDURE, AB_PROC_POINTER
AB_IS_CLASS, AB_PROCEDURE, AB_PROC_POINTER
}
ab_attribute;
@ -1711,7 +1711,6 @@ static const mstring attr_bits[] =
minit ("ZERO_COMP", AB_ZERO_COMP),
minit ("PROTECTED", AB_PROTECTED),
minit ("ABSTRACT", AB_ABSTRACT),
minit ("EXTENSION", AB_EXTENSION),
minit ("IS_CLASS", AB_IS_CLASS),
minit ("PROCEDURE", AB_PROCEDURE),
minit ("PROC_POINTER", AB_PROC_POINTER),
@ -1771,7 +1770,7 @@ static void
mio_symbol_attribute (symbol_attribute *attr)
{
atom_type t;
unsigned ext_attr;
unsigned ext_attr,extension_level;
mio_lparen ();
@ -1780,10 +1779,15 @@ mio_symbol_attribute (symbol_attribute *attr)
attr->proc = MIO_NAME (procedure_type) (attr->proc, procedures);
attr->if_source = MIO_NAME (ifsrc) (attr->if_source, ifsrc_types);
attr->save = MIO_NAME (save_state) (attr->save, save_status);
ext_attr = attr->ext_attr;
mio_integer ((int *) &ext_attr);
attr->ext_attr = ext_attr;
extension_level = attr->extension;
mio_integer ((int *) &extension_level);
attr->extension = extension_level;
if (iomode == IO_OUTPUT)
{
if (attr->allocatable)
@ -1858,8 +1862,6 @@ mio_symbol_attribute (symbol_attribute *attr)
MIO_NAME (ab_attribute) (AB_PRIVATE_COMP, attr_bits);
if (attr->zero_comp)
MIO_NAME (ab_attribute) (AB_ZERO_COMP, attr_bits);
if (attr->extension)
MIO_NAME (ab_attribute) (AB_EXTENSION, attr_bits);
if (attr->is_class)
MIO_NAME (ab_attribute) (AB_IS_CLASS, attr_bits);
if (attr->procedure)
@ -1984,9 +1986,6 @@ mio_symbol_attribute (symbol_attribute *attr)
case AB_ZERO_COMP:
attr->zero_comp = 1;
break;
case AB_EXTENSION:
attr->extension = 1;
break;
case AB_IS_CLASS:
attr->is_class = 1;
break;
@ -3574,7 +3573,7 @@ mio_symbol (gfc_symbol *sym)
mio_integer (&(sym->intmod_sym_id));
if (sym->attr.flavor == FL_DERIVED)
mio_integer (&(sym->vindex));
mio_integer (&(sym->hash_value));
mio_rparen ();
}

View File

@ -5218,41 +5218,35 @@ resolve_class_esym (gfc_expr *e)
}
/* Generate an expression for the vindex, given the reference to
/* 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*
vindex_expr (gfc_ref *class_ref, gfc_ref *new_ref,
gfc_symbol *declared, gfc_symtree *st)
hash_value_expr (gfc_ref *class_ref, gfc_ref *new_ref, gfc_symtree *st)
{
gfc_expr *vindex;
gfc_ref *ref;
gfc_expr *hash_value;
/* Build an expression for the correct vindex; ie. that of the last
/* Build an expression for the correct hash_value; ie. that of the last
CLASS reference. */
ref = gfc_get_ref();
ref->type = REF_COMPONENT;
ref->u.c.component = declared->components->next;
ref->u.c.sym = declared;
ref->next = NULL;
if (class_ref)
{
class_ref->next = ref;
class_ref->next = NULL;
}
else
{
gfc_free_ref_list (new_ref);
new_ref = ref;
new_ref = NULL;
}
vindex = gfc_get_expr ();
vindex->expr_type = EXPR_VARIABLE;
vindex->symtree = st;
vindex->symtree->n.sym->refs++;
vindex->ts = ref->u.c.component->ts;
vindex->ref = new_ref;
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 vindex;
return hash_value;
}
@ -5352,10 +5346,10 @@ resolve_class_compcall (gfc_expr* e)
resolve_class_esym (e);
/* More than one typebound procedure so transmit an expression for
the vindex as the selector. */
the hash_value as the selector. */
if (e->value.function.class_esym != NULL)
e->value.function.class_esym->vindex
= vindex_expr (class_ref, new_ref, declared, st);
e->value.function.class_esym->hash_value
= hash_value_expr (class_ref, new_ref, st);
return class_try;
}
@ -5407,10 +5401,10 @@ resolve_class_typebound_call (gfc_code *code)
resolve_class_esym (code->expr1);
/* More than one typebound procedure so transmit an expression for
the vindex as the selector. */
the hash_value as the selector. */
if (code->expr1->value.function.class_esym != NULL)
code->expr1->value.function.class_esym->vindex
= vindex_expr (class_ref, new_ref, declared, st);
code->expr1->value.function.class_esym->hash_value
= hash_value_expr (class_ref, new_ref, st);
return class_try;
}
@ -6862,11 +6856,13 @@ static void
resolve_select_type (gfc_code *code)
{
gfc_symbol *selector_type;
gfc_code *body, *new_st;
gfc_case *c, *default_case;
gfc_code *body, *new_st, *if_st, *tail;
gfc_code *class_is = NULL, *default_case = NULL;
gfc_case *c;
gfc_symtree *st;
char name[GFC_MAX_SYMBOL_LEN];
gfc_namespace *ns;
int error = 0;
ns = code->ext.ns;
gfc_resolve (ns);
@ -6876,9 +6872,6 @@ resolve_select_type (gfc_code *code)
else
selector_type = code->expr1->ts.u.derived->components->ts.u.derived;
/* Assume there is no DEFAULT case. */
default_case = NULL;
/* Loop over TYPE IS / CLASS IS cases. */
for (body = code->block; body; body = body->block)
{
@ -6890,6 +6883,7 @@ resolve_select_type (gfc_code *code)
{
gfc_error ("Derived type '%s' at %L must be extensible",
c->ts.u.derived->name, &c->where);
error++;
continue;
}
@ -6899,6 +6893,7 @@ resolve_select_type (gfc_code *code)
{
gfc_error ("Derived type '%s' at %L must be an extension of '%s'",
c->ts.u.derived->name, &c->where, selector_type->name);
error++;
continue;
}
@ -6906,15 +6901,21 @@ resolve_select_type (gfc_code *code)
if (c->ts.type == BT_UNKNOWN)
{
/* Check F03:C818. */
if (default_case != NULL)
gfc_error ("The DEFAULT CASE at %L cannot be followed "
"by a second DEFAULT CASE at %L",
&default_case->where, &c->where);
if (default_case)
{
gfc_error ("The DEFAULT CASE at %L cannot be followed "
"by a second DEFAULT CASE at %L",
&default_case->ext.case_list->where, &c->where);
error++;
continue;
}
else
default_case = c;
continue;
default_case = body;
}
}
if (error>0)
return;
if (code->expr2)
{
@ -6944,45 +6945,153 @@ resolve_select_type (gfc_code *code)
/* Transform to EXEC_SELECT. */
code->op = EXEC_SELECT;
gfc_add_component_ref (code->expr1, "$vindex");
gfc_add_component_ref (code->expr1, "$vptr");
gfc_add_component_ref (code->expr1, "$hash");
/* Loop over TYPE IS / CLASS IS cases. */
for (body = code->block; body; body = body->block)
{
c = body->ext.case_list;
if (c->ts.type == BT_DERIVED)
c->low = c->high = gfc_int_expr (c->ts.u.derived->vindex);
else if (c->ts.type == BT_CLASS)
/* Currently IS CLASS blocks are simply ignored.
TODO: Implement IS CLASS. */
c->unreachable = 1;
if (c->ts.type != BT_DERIVED)
c->low = c->high = gfc_int_expr (c->ts.u.derived->hash_value);
else if (c->ts.type == BT_UNKNOWN)
continue;
/* Assign temporary to selector. */
sprintf (name, "tmp$%s", c->ts.u.derived->name);
if (c->ts.type == BT_CLASS)
sprintf (name, "tmp$class$%s", c->ts.u.derived->name);
else
sprintf (name, "tmp$type$%s", c->ts.u.derived->name);
st = gfc_find_symtree (ns->sym_root, name);
new_st = gfc_get_code ();
new_st->op = EXEC_POINTER_ASSIGN;
new_st->expr1 = gfc_get_variable_expr (st);
new_st->expr2 = gfc_get_variable_expr (code->expr1->symtree);
gfc_add_component_ref (new_st->expr2, "$data");
if (c->ts.type == BT_DERIVED)
{
new_st->op = EXEC_POINTER_ASSIGN;
gfc_add_component_ref (new_st->expr2, "$data");
}
else
new_st->op = EXEC_POINTER_ASSIGN;
new_st->next = body->next;
body->next = new_st;
}
/* Eliminate dead blocks. */
for (body = code; body && body->block; body = body->block)
/* Take out CLASS IS cases for separate treatment. */
body = code;
while (body && body->block)
{
if (body->block->ext.case_list->unreachable)
if (body->block->ext.case_list->ts.type == BT_CLASS)
{
/* Cut the unreachable block from the code chain. */
gfc_code *cd = body->block;
body->block = cd->block;
/* Kill the dead block, but not the blocks below it. */
cd->block = NULL;
gfc_free_statements (cd);
/* Add to class_is list. */
if (class_is == NULL)
{
class_is = body->block;
tail = class_is;
}
else
{
for (tail = class_is; tail->block; tail = tail->block) ;
tail->block = body->block;
tail = tail->block;
}
/* Remove from EXEC_SELECT list. */
body->block = body->block->block;
tail->block = NULL;
}
else
body = body->block;
}
if (class_is)
{
gfc_symbol *vtab;
if (!default_case)
{
/* Add a default case to hold the CLASS IS cases. */
for (tail = code; tail->block; tail = tail->block) ;
tail->block = gfc_get_code ();
tail = tail->block;
tail->op = EXEC_SELECT_TYPE;
tail->ext.case_list = gfc_get_case ();
tail->ext.case_list->ts.type = BT_UNKNOWN;
tail->next = NULL;
default_case = tail;
}
/* More than one CLASS IS block? */
if (class_is->block)
{
gfc_code **c1,*c2;
bool swapped;
/* Sort CLASS IS blocks by extension level. */
do
{
swapped = false;
for (c1 = &class_is; (*c1) && (*c1)->block; c1 = &((*c1)->block))
{
c2 = (*c1)->block;
/* F03:C817 (check for doubles). */
if ((*c1)->ext.case_list->ts.u.derived->hash_value
== c2->ext.case_list->ts.u.derived->hash_value)
{
gfc_error ("Double CLASS IS block in SELECT TYPE "
"statement at %L", &c2->ext.case_list->where);
return;
}
if ((*c1)->ext.case_list->ts.u.derived->attr.extension
< c2->ext.case_list->ts.u.derived->attr.extension)
{
/* Swap. */
(*c1)->block = c2->block;
c2->block = *c1;
*c1 = c2;
swapped = true;
}
}
}
while (swapped);
}
/* Generate IF chain. */
if_st = gfc_get_code ();
if_st->op = EXEC_IF;
new_st = if_st;
for (body = class_is; body; body = body->block)
{
new_st->block = gfc_get_code ();
new_st = new_st->block;
new_st->op = EXEC_IF;
/* Set up IF condition: Call _gfortran_is_extension_of. */
new_st->expr1 = gfc_get_expr ();
new_st->expr1->expr_type = EXPR_FUNCTION;
new_st->expr1->ts.type = BT_LOGICAL;
new_st->expr1->ts.kind = 4;
new_st->expr1->value.function.name = gfc_get_string (PREFIX ("is_extension_of"));
new_st->expr1->value.function.isym = XCNEW (gfc_intrinsic_sym);
new_st->expr1->value.function.isym->id = GFC_ISYM_EXTENDS_TYPE_OF;
/* Set up arguments. */
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);
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);
new_st->next = body->next;
}
if (default_case->next)
{
new_st->block = gfc_get_code ();
new_st = new_st->block;
new_st->op = EXEC_IF;
new_st->next = default_case->next;
}
/* Replace CLASS DEFAULT code by the IF chain. */
default_case->next = if_st;
}
resolve_select (code);
@ -8751,7 +8860,8 @@ resolve_fl_variable_derived (gfc_symbol *sym, int no_init_flag)
if (!gfc_type_is_extensible (sym->ts.u.derived->components->ts.u.derived))
{
gfc_error ("Type '%s' of CLASS variable '%s' at %L is not extensible",
sym->ts.u.derived->name, sym->name, &sym->declared_at);
sym->ts.u.derived->components->ts.u.derived->name,
sym->name, &sym->declared_at);
return FAILURE;
}

View File

@ -1045,7 +1045,7 @@ gfc_add_save (symbol_attribute *attr, const char *name, locus *where)
return FAILURE;
}
if (attr->save == SAVE_EXPLICIT)
if (attr->save == SAVE_EXPLICIT && !attr->vtab)
{
if (gfc_notify_std (GFC_STD_LEGACY,
"Duplicate SAVE attribute specified at %L",
@ -4592,22 +4592,228 @@ gfc_type_is_extension_of (gfc_symbol *t1, gfc_symbol *t2)
bool
gfc_type_compatible (gfc_typespec *ts1, gfc_typespec *ts2)
{
if ((ts1->type == BT_DERIVED || ts1->type == BT_CLASS)
&& (ts2->type == BT_DERIVED || ts2->type == BT_CLASS))
gfc_component *cmp1, *cmp2;
bool is_class1 = (ts1->type == BT_CLASS);
bool is_class2 = (ts2->type == BT_CLASS);
bool is_derived1 = (ts1->type == BT_DERIVED);
bool is_derived2 = (ts2->type == BT_DERIVED);
if (!is_derived1 && !is_derived2 && !is_class1 && !is_class2)
return (ts1->type == ts2->type);
if (is_derived1 && is_derived2)
return gfc_compare_derived_types (ts1->u.derived, ts2->u.derived);
cmp1 = cmp2 = NULL;
if (is_class1)
{
if (ts1->type == BT_CLASS && ts2->type == BT_DERIVED)
return gfc_type_is_extension_of (ts1->u.derived->components->ts.u.derived,
ts2->u.derived);
else if (ts1->type == BT_CLASS && ts2->type == BT_CLASS)
return gfc_type_is_extension_of (ts1->u.derived->components->ts.u.derived,
ts2->u.derived->components->ts.u.derived);
else if (ts2->type != BT_CLASS)
return gfc_compare_derived_types (ts1->u.derived, ts2->u.derived);
else
cmp1 = gfc_find_component (ts1->u.derived, "$data", true, false);
if (cmp1 == NULL)
return 0;
}
if (is_class2)
{
cmp2 = gfc_find_component (ts2->u.derived, "$data", true, false);
if (cmp2 == NULL)
return 0;
}
if (is_class1 && is_derived2)
return gfc_type_is_extension_of (cmp1->ts.u.derived, ts2->u.derived);
else if (is_class1 && is_class2)
return gfc_type_is_extension_of (cmp1->ts.u.derived, cmp2->ts.u.derived);
else
return (ts1->type == ts2->type);
return 0;
}
/* Build a polymorphic CLASS entity, using the symbol that comes from
build_sym. A CLASS entity is represented by an encapsulating type,
which contains the declared type as '$data' component, plus a pointer
component '$vptr' which determines the dynamic type. */
gfc_try
gfc_build_class_symbol (gfc_typespec *ts, symbol_attribute *attr,
gfc_array_spec **as)
{
char name[GFC_MAX_SYMBOL_LEN + 5];
gfc_symbol *fclass;
gfc_symbol *vtab;
gfc_component *c;
/* Determine the name of the encapsulating type. */
if ((*as) && (*as)->rank && attr->allocatable)
sprintf (name, ".class.%s.%d.a", ts->u.derived->name, (*as)->rank);
else if ((*as) && (*as)->rank)
sprintf (name, ".class.%s.%d", ts->u.derived->name, (*as)->rank);
else if (attr->allocatable)
sprintf (name, ".class.%s.a", ts->u.derived->name);
else
sprintf (name, ".class.%s", ts->u.derived->name);
gfc_find_symbol (name, ts->u.derived->ns, 0, &fclass);
if (fclass == NULL)
{
gfc_symtree *st;
/* If not there, create a new symbol. */
fclass = gfc_new_symbol (name, ts->u.derived->ns);
st = gfc_new_symtree (&ts->u.derived->ns->sym_root, name);
st->n.sym = fclass;
gfc_set_sym_referenced (fclass);
fclass->refs++;
fclass->ts.type = BT_UNKNOWN;
fclass->attr.abstract = ts->u.derived->attr.abstract;
if (ts->u.derived->f2k_derived)
fclass->f2k_derived = gfc_get_namespace (NULL, 0);
if (gfc_add_flavor (&fclass->attr, FL_DERIVED,
NULL, &gfc_current_locus) == FAILURE)
return FAILURE;
/* Add component '$data'. */
if (gfc_add_component (fclass, "$data", &c) == FAILURE)
return FAILURE;
c->ts = *ts;
c->ts.type = BT_DERIVED;
c->attr.access = ACCESS_PRIVATE;
c->ts.u.derived = ts->u.derived;
c->attr.pointer = attr->pointer || attr->dummy;
c->attr.allocatable = attr->allocatable;
c->attr.dimension = attr->dimension;
c->attr.abstract = ts->u.derived->attr.abstract;
c->as = (*as);
c->initializer = gfc_get_expr ();
c->initializer->expr_type = EXPR_NULL;
/* Add component '$vptr'. */
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;
c->attr.pointer = 1;
c->initializer = gfc_get_expr ();
c->initializer->expr_type = EXPR_NULL;
}
/* Since the extension field is 8 bit wide, we can only have
up to 255 extension levels. */
if (ts->u.derived->attr.extension == 255)
{
gfc_error ("Maximum extension level reached with type '%s' at %L",
ts->u.derived->name, &ts->u.derived->declared_at);
return FAILURE;
}
fclass->attr.extension = ts->u.derived->attr.extension + 1;
fclass->attr.is_class = 1;
ts->u.derived = fclass;
attr->allocatable = attr->pointer = attr->dimension = 0;
(*as) = NULL; /* XXX */
return SUCCESS;
}
/* Find the symbol for a derived type's vtab. */
gfc_symbol *
gfc_find_derived_vtab (gfc_symbol *derived)
{
gfc_namespace *ns;
gfc_symbol *vtab = NULL, *vtype = NULL;
char name[2 * GFC_MAX_SYMBOL_LEN + 8];
ns = gfc_current_ns;
for (; ns; ns = ns->parent)
if (!ns->parent)
break;
if (ns)
{
sprintf (name, "vtab$%s", derived->name);
gfc_find_symbol (name, ns, 0, &vtab);
if (vtab == NULL)
{
gfc_get_symbol (name, 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, "vtype$%s", derived->name);
gfc_find_symbol (name, ns, 0, &vtype);
if (vtype == NULL)
{
gfc_component *c;
gfc_symbol *parent = NULL, *parent_vtab = NULL;
gfc_get_symbol (name, ns, &vtype);
if (gfc_add_flavor (&vtype->attr, FL_DERIVED,
NULL, &gfc_current_locus) == FAILURE)
return NULL;
vtype->refs++;
gfc_set_sym_referenced (vtype);
/* Add component '$hash'. */
if (gfc_add_component (vtype, "$hash", &c) == FAILURE)
return NULL;
c->ts.type = BT_INTEGER;
c->ts.kind = 4;
c->attr.access = ACCESS_PRIVATE;
c->initializer = gfc_int_expr (derived->hash_value);
/* Add component '$size'. */
if (gfc_add_component (vtype, "$size", &c) == FAILURE)
return NULL;
c->ts.type = BT_INTEGER;
c->ts.kind = 4;
c->attr.access = ACCESS_PRIVATE;
/* Remember the derived type in ts.u.derived,
so that the correct initializer can be set later on
(in gfc_conv_structure). */
c->ts.u.derived = derived;
c->initializer = gfc_int_expr (0);
/* Add component $extends. */
if (gfc_add_component (vtype, "$extends", &c) == FAILURE)
return NULL;
c->attr.pointer = 1;
c->attr.access = ACCESS_PRIVATE;
c->initializer = gfc_get_expr ();
parent = gfc_get_derived_super_type (derived);
if (parent)
{
parent_vtab = gfc_find_derived_vtab (parent);
c->ts.type = BT_DERIVED;
c->ts.u.derived = parent_vtab->ts.u.derived;
c->initializer->expr_type = EXPR_VARIABLE;
gfc_find_sym_tree (parent_vtab->name, parent_vtab->ns, 0,
&c->initializer->symtree);
}
else
{
c->ts.type = BT_DERIVED;
c->ts.u.derived = vtype;
c->initializer->expr_type = EXPR_NULL;
}
}
vtab->ts.u.derived = vtype;
vtab->value = gfc_default_initializer (&vtab->ts);
}
}
return vtab;
}

View File

@ -3405,7 +3405,7 @@ gfc_create_module_variable (gfc_symbol * sym)
&& (sym->equiv_built || sym->attr.in_equivalence))
return;
if (sym->backend_decl)
if (sym->backend_decl && !sym->attr.vtab)
internal_error ("backend decl for module variable %s already exists",
sym->name);

View File

@ -1530,16 +1530,16 @@ select_class_proc (gfc_se *se, gfc_class_esym_list *elist,
tree end_label;
tree label;
tree tmp;
tree vindex;
tree hash;
stmtblock_t body;
gfc_class_esym_list *next_elist, *tmp_elist;
gfc_se tmpse;
/* Convert the vindex expression. */
/* Convert the hash expression. */
gfc_init_se (&tmpse, NULL);
gfc_conv_expr (&tmpse, elist->vindex);
gfc_conv_expr (&tmpse, elist->hash_value);
gfc_add_block_to_block (&se->pre, &tmpse.pre);
vindex = gfc_evaluate_now (tmpse.expr, &se->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. */
@ -1566,9 +1566,9 @@ select_class_proc (gfc_se *se, gfc_class_esym_list *elist,
if (elist->esym != tmp_elist->esym)
continue;
cval = build_int_cst (TREE_TYPE (vindex),
elist->derived->vindex);
/* Build a label for the vindex value. */
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);
@ -1601,8 +1601,8 @@ select_class_proc (gfc_se *se, gfc_class_esym_list *elist,
segfaults because it occurs too early and too often. */
free_elist:
next_elist = elist->next;
if (elist->vindex)
gfc_free_expr (elist->vindex);
if (elist->hash_value)
gfc_free_expr (elist->hash_value);
gfc_free (elist);
elist = NULL;
}
@ -1613,12 +1613,12 @@ select_class_proc (gfc_se *se, gfc_class_esym_list *elist,
NULL_TREE, NULL_TREE, label);
gfc_add_expr_to_block (&body, tmp);
tmp = gfc_trans_runtime_error (true, &expr->where,
"internal error: bad vindex in dynamic dispatch");
"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, vindex, tmp, NULL_TREE);
tmp = build3_v (SWITCH_EXPR, hash, tmp, NULL_TREE);
gfc_add_expr_to_block (&se->pre, tmp);
tmp = build1_v (LABEL_EXPR, end_label);
@ -2531,6 +2531,60 @@ conv_arglist_function (gfc_se *se, gfc_expr *expr, const char *name)
}
/* Takes a derived type expression and returns the address of a temporary
class object of the 'declared' type. */
static void
gfc_conv_derived_to_class (gfc_se *parmse, gfc_expr *e,
gfc_typespec class_ts)
{
gfc_component *cmp;
gfc_symbol *vtab;
gfc_symbol *declared = class_ts.u.derived;
gfc_ss *ss;
tree ctree;
tree var;
tree tmp;
/* The derived type needs to be converted to a temporary
CLASS object. */
tmp = gfc_typenode_for_spec (&class_ts);
var = gfc_create_var (tmp, "class");
/* Set the vptr. */
cmp = gfc_find_component (declared, "$vptr", true, true);
ctree = fold_build3 (COMPONENT_REF, TREE_TYPE (cmp->backend_decl),
var, cmp->backend_decl, NULL_TREE);
/* Remember the vtab corresponds to the derived type
not to the class declared type. */
vtab = gfc_find_derived_vtab (e->ts.u.derived);
gcc_assert (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));
/* Now set the data field. */
cmp = gfc_find_component (declared, "$data", true, true);
ctree = fold_build3 (COMPONENT_REF, TREE_TYPE (cmp->backend_decl),
var, cmp->backend_decl, NULL_TREE);
ss = gfc_walk_expr (e);
if (ss == gfc_ss_terminator)
{
gfc_conv_expr_reference (parmse, e);
tmp = fold_convert (TREE_TYPE (ctree), parmse->expr);
gfc_add_modify (&parmse->pre, ctree, tmp);
}
else
{
gfc_conv_expr (parmse, e);
gfc_add_modify (&parmse->pre, ctree, parmse->expr);
}
/* Pass the address of the class object. */
parmse->expr = gfc_build_addr_expr (NULL_TREE, var);
}
/* The following routine generates code for the intrinsic
procedures from the ISO_C_BINDING module:
* C_LOC (function)
@ -2800,53 +2854,10 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym,
else if (fsym && fsym->ts.type == BT_CLASS
&& e->ts.type == BT_DERIVED)
{
tree data;
tree vindex;
tree size;
/* The derived type needs to be converted to a temporary
CLASS object. */
gfc_init_se (&parmse, se);
type = gfc_typenode_for_spec (&fsym->ts);
var = gfc_create_var (type, "class");
/* Get the components. */
tmp = fsym->ts.u.derived->components->backend_decl;
data = fold_build3 (COMPONENT_REF, TREE_TYPE (tmp),
var, tmp, NULL_TREE);
tmp = fsym->ts.u.derived->components->next->backend_decl;
vindex = fold_build3 (COMPONENT_REF, TREE_TYPE (tmp),
var, tmp, NULL_TREE);
tmp = fsym->ts.u.derived->components->next->next->backend_decl;
size = fold_build3 (COMPONENT_REF, TREE_TYPE (tmp),
var, tmp, NULL_TREE);
/* Set the vindex. */
tmp = build_int_cst (TREE_TYPE (vindex), e->ts.u.derived->vindex);
gfc_add_modify (&parmse.pre, vindex, tmp);
/* Set the size. */
tmp = TYPE_SIZE_UNIT (gfc_typenode_for_spec (&e->ts));
gfc_add_modify (&parmse.pre, size,
fold_convert (TREE_TYPE (size), tmp));
/* Now set the data field. */
argss = gfc_walk_expr (e);
if (argss == gfc_ss_terminator)
{
gfc_conv_expr_reference (&parmse, e);
tmp = fold_convert (TREE_TYPE (data),
parmse.expr);
gfc_add_modify (&parmse.pre, data, tmp);
}
else
{
gfc_conv_expr (&parmse, e);
gfc_add_modify (&parmse.pre, data, parmse.expr);
}
/* Pass the address of the class object. */
parmse.expr = gfc_build_addr_expr (NULL_TREE, var);
gfc_conv_derived_to_class (&parmse, e, fsym->ts);
}
else if (se->ss && se->ss->useflags)
{
@ -4240,14 +4251,27 @@ gfc_conv_structure (gfc_se * se, gfc_expr * expr, int init)
if (cm->ts.type == BT_CLASS)
{
gfc_component *data;
data = gfc_find_component (cm->ts.u.derived, "$data", true, true);
val = gfc_conv_initializer (c->expr, &cm->ts,
TREE_TYPE (cm->ts.u.derived->components->backend_decl),
cm->ts.u.derived->components->attr.dimension,
cm->ts.u.derived->components->attr.pointer);
TREE_TYPE (data->backend_decl),
data->attr.dimension,
data->attr.pointer);
/* Append it to the constructor list. */
CONSTRUCTOR_APPEND_ELT (v, cm->ts.u.derived->components->backend_decl,
val);
CONSTRUCTOR_APPEND_ELT (v, data->backend_decl, val);
}
else if (strcmp (cm->name, "$size") == 0)
{
val = TYPE_SIZE_UNIT (gfc_get_derived_type (cm->ts.u.derived));
CONSTRUCTOR_APPEND_ELT (v, cm->backend_decl, val);
}
else if (cm->initializer && cm->initializer->expr_type != EXPR_NULL
&& strcmp (cm->name, "$extends") == 0)
{
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);
}
else
{
@ -5366,46 +5390,36 @@ gfc_trans_class_assign (gfc_code *code)
{
stmtblock_t block;
tree tmp;
gfc_expr *lhs;
gfc_expr *rhs;
gfc_start_block (&block);
if (code->expr2->ts.type != BT_CLASS)
{
/* Insert an additional assignment which sets the '$vindex' field. */
gfc_expr *lhs,*rhs;
/* Insert an additional assignment which sets the '$vptr' field. */
lhs = gfc_copy_expr (code->expr1);
gfc_add_component_ref (lhs, "$vindex");
gfc_add_component_ref (lhs, "$vptr");
if (code->expr2->ts.type == BT_DERIVED)
/* vindex is constant, determined at compile time. */
rhs = gfc_int_expr (code->expr2->ts.u.derived->vindex);
{
gfc_symbol *vtab;
gfc_symtree *st;
vtab = gfc_find_derived_vtab (code->expr2->ts.u.derived);
gcc_assert (vtab);
rhs = gfc_get_expr ();
rhs->expr_type = EXPR_VARIABLE;
gfc_find_sym_tree (vtab->name, NULL, 1, &st);
rhs->symtree = st;
rhs->ts = vtab->ts;
}
else if (code->expr2->expr_type == EXPR_NULL)
rhs = gfc_int_expr (0);
else
gcc_unreachable ();
tmp = gfc_trans_assignment (lhs, rhs, false);
gfc_add_expr_to_block (&block, tmp);
/* Insert another assignment which sets the '$size' field. */
lhs = gfc_copy_expr (code->expr1);
gfc_add_component_ref (lhs, "$size");
if (code->expr2->ts.type == BT_DERIVED)
{
/* Size is fixed at compile time. */
gfc_se lse;
gfc_init_se (&lse, NULL);
gfc_conv_expr (&lse, lhs);
tmp = TYPE_SIZE_UNIT (gfc_typenode_for_spec (&code->expr2->ts));
gfc_add_modify (&block, lse.expr,
fold_convert (TREE_TYPE (lse.expr), tmp));
}
else if (code->expr2->expr_type == EXPR_NULL)
{
rhs = gfc_int_expr (0);
tmp = gfc_trans_assignment (lhs, rhs, false);
gfc_add_expr_to_block (&block, tmp);
}
else
gcc_unreachable ();
tmp = gfc_trans_pointer_assignment (lhs, rhs);
gfc_add_expr_to_block (&block, tmp);
gfc_free_expr (lhs);
gfc_free_expr (rhs);

View File

@ -4715,14 +4715,20 @@ gfc_conv_same_type_as (gfc_se *se, gfc_expr *expr)
b = expr->value.function.actual->next->expr;
if (a->ts.type == BT_CLASS)
gfc_add_component_ref (a, "$vindex");
{
gfc_add_component_ref (a, "$vptr");
gfc_add_component_ref (a, "$hash");
}
else if (a->ts.type == BT_DERIVED)
a = gfc_int_expr (a->ts.u.derived->vindex);
a = gfc_int_expr (a->ts.u.derived->hash_value);
if (b->ts.type == BT_CLASS)
gfc_add_component_ref (b, "$vindex");
{
gfc_add_component_ref (b, "$vptr");
gfc_add_component_ref (b, "$hash");
}
else if (b->ts.type == BT_DERIVED)
b = gfc_int_expr (b->ts.u.derived->vindex);
b = gfc_int_expr (b->ts.u.derived->hash_value);
gfc_conv_expr (&se1, a);
gfc_conv_expr (&se2, b);
@ -4733,21 +4739,6 @@ gfc_conv_same_type_as (gfc_se *se, gfc_expr *expr)
}
/* Generate code for the EXTENDS_TYPE_OF intrinsic. */
static void
gfc_conv_extends_type_of (gfc_se *se, gfc_expr *expr)
{
gfc_expr *e;
/* TODO: Implement EXTENDS_TYPE_OF. */
gfc_error ("Intrinsic EXTENDS_TYPE_OF at %L not yet implemented",
&expr->where);
/* Just return 'false' for now. */
e = gfc_logical_expr (false, &expr->where);
gfc_conv_expr (se, e);
}
/* Generate code for SELECTED_CHAR_KIND (NAME) intrinsic function. */
static void
@ -5157,10 +5148,6 @@ gfc_conv_intrinsic_function (gfc_se * se, gfc_expr * expr)
gfc_conv_same_type_as (se, expr);
break;
case GFC_ISYM_EXTENDS_TYPE_OF:
gfc_conv_extends_type_of (se, expr);
break;
case GFC_ISYM_ABS:
gfc_conv_intrinsic_abs (se, expr);
break;
@ -5538,6 +5525,7 @@ gfc_conv_intrinsic_function (gfc_se * se, gfc_expr * expr)
case GFC_ISYM_CHMOD:
case GFC_ISYM_DTIME:
case GFC_ISYM_ETIME:
case GFC_ISYM_EXTENDS_TYPE_OF:
case GFC_ISYM_FGET:
case GFC_ISYM_FGETC:
case GFC_ISYM_FNUM:

View File

@ -4046,6 +4046,7 @@ gfc_trans_allocate (gfc_code * code)
gfc_expr *sz;
gfc_se se_sz;
sz = gfc_copy_expr (code->expr3);
gfc_add_component_ref (sz, "$vptr");
gfc_add_component_ref (sz, "$size");
gfc_init_se (&se_sz, NULL);
gfc_conv_expr (&se_sz, sz);
@ -4141,42 +4142,49 @@ gfc_trans_allocate (gfc_code * code)
{
gfc_expr *lhs,*rhs;
gfc_se lse;
/* Initialize VINDEX for CLASS objects. */
/* Initialize VPTR for CLASS objects. */
lhs = gfc_expr_to_initialize (expr);
gfc_add_component_ref (lhs, "$vindex");
gfc_add_component_ref (lhs, "$vptr");
rhs = NULL;
if (code->expr3 && code->expr3->ts.type == BT_CLASS)
{
/* vindex must be determined at run time. */
/* VPTR must be determined at run time. */
rhs = gfc_copy_expr (code->expr3);
gfc_add_component_ref (rhs, "$vindex");
gfc_add_component_ref (rhs, "$vptr");
tmp = gfc_trans_pointer_assignment (lhs, rhs);
gfc_add_expr_to_block (&block, tmp);
gfc_free_expr (rhs);
}
else
{
/* vindex is fixed at compile time. */
int vindex;
/* VPTR is fixed at compile time. */
gfc_symbol *vtab;
gfc_typespec *ts;
if (code->expr3)
vindex = code->expr3->ts.u.derived->vindex;
ts = &code->expr3->ts;
else if (expr->ts.type == BT_DERIVED)
ts = &expr->ts;
else if (code->ext.alloc.ts.type == BT_DERIVED)
vindex = code->ext.alloc.ts.u.derived->vindex;
ts = &code->ext.alloc.ts;
else if (expr->ts.type == BT_CLASS)
vindex = expr->ts.u.derived->components->ts.u.derived->vindex;
ts = &expr->ts.u.derived->components->ts;
else
vindex = expr->ts.u.derived->vindex;
rhs = gfc_int_expr (vindex);
}
tmp = gfc_trans_assignment (lhs, rhs, false);
gfc_free_expr (lhs);
gfc_free_expr (rhs);
gfc_add_expr_to_block (&block, tmp);
ts = &expr->ts;
/* Initialize SIZE for CLASS objects. */
lhs = gfc_expr_to_initialize (expr);
gfc_add_component_ref (lhs, "$size");
gfc_init_se (&lse, NULL);
gfc_conv_expr (&lse, lhs);
gfc_add_modify (&block, lse.expr,
fold_convert (TREE_TYPE (lse.expr), memsz));
gfc_free_expr (lhs);
if (ts->type == BT_DERIVED)
{
vtab = gfc_find_derived_vtab (ts->u.derived);
gcc_assert (vtab);
gfc_init_se (&lse, NULL);
lse.want_pointer = 1;
gfc_conv_expr (&lse, lhs);
tmp = gfc_build_addr_expr (NULL_TREE,
gfc_get_symbol_decl (vtab));
gfc_add_modify (&block, lse.expr,
fold_convert (TREE_TYPE (lse.expr), tmp));
}
}
}
}

View File

@ -53,8 +53,6 @@ along with GCC; see the file COPYING3. If not see
/* array of structs so we don't have to worry about xmalloc or free */
CInteropKind_t c_interop_kinds_table[ISOCBINDING_NUMBER];
static tree gfc_get_derived_type (gfc_symbol * derived);
tree gfc_array_index_type;
tree gfc_array_range_type;
tree gfc_character1_type_node;
@ -1941,7 +1939,7 @@ gfc_get_ppc_type (gfc_component* c)
at the same time. If an equal derived type has been built
in a parent namespace, this is used. */
static tree
tree
gfc_get_derived_type (gfc_symbol * derived)
{
tree typenode = NULL, field = NULL, field_type = NULL, fieldlist = NULL;

View File

@ -1,3 +1,27 @@
2009-11-30 Janus Weil <janus@gcc.gnu.org>
PR fortran/42053
* gfortran.dg/select_type_9.f03: New.
2009-11-30 Janus Weil <janus@gcc.gnu.org>
PR fortran/41631
* gfortran.dg/extends_type_of_1.f03: Fix invalid test case.
* gfortran.dg/module_md5_1.f90: Adjusted MD5 sum.
* gfortran.dg/select_type_1.f03: Remove FIXMEs.
* gfortran.dg/select_type_2.f03: Ditto.
* gfortran.dg/select_type_8.f03: New test.
2009-11-30 Janus Weil <janus@gcc.gnu.org>
* gfortran.dg/extends_type_of_1.f03: New test.
* gfortran.dg/same_type_as_1.f03: Extended.
2009-11-30 Paul Thomas <pault@gcc.gnu.org>
* gfortran.dg/class_4c.f03: Add dg-additional-sources.
* gfortran.dg/class_4d.f03: Rename module. Cleanup modules.
2009-11-30 Janis Johnson <janis187@us.ibm.com>
PR testsuite/42212

View File

@ -1,4 +1,5 @@
! { dg-do run }
! { dg-additional-sources class_4a.f03 class_4b.f03 }
!
! Test the fix for PR41583, in which the different source files
! would generate the same 'vindex' for different class declared

View File

@ -8,8 +8,8 @@
!
! Contributed by Tobias Burnus <burnus@gcc.gnu.org>
!
module m
module m3
type t
end type t
end module m
! { dg-final { cleanup-modules "m m2" } }
end module m3
! { dg-final { cleanup-modules "m m2 m3" } }

View File

@ -0,0 +1,48 @@
! { dg-do run }
!
! Verifying the runtime behavior of the intrinsic function EXTENDS_TYPE_OF.
!
! Contributed by Janus Weil <janus@gcc.gnu.org>
implicit none
intrinsic :: extends_type_of
type :: t1
integer :: i = 42
end type
type, extends(t1) :: t2
integer :: j = 43
end type
type, extends(t2) :: t3
class(t1),pointer :: cc
end type
class(t1), pointer :: c1,c2
type(t1), target :: x
type(t2), target :: y
type(t3), target :: z
c1 => x
c2 => y
z%cc => y
if (.not. extends_type_of (c1, c1)) call abort()
if ( extends_type_of (c1, c2)) call abort()
if (.not. extends_type_of (c2, c1)) call abort()
if (.not. extends_type_of (x, x)) call abort()
if ( extends_type_of (x, y)) call abort()
if (.not. extends_type_of (y, x)) call abort()
if (.not. extends_type_of (c1, x)) call abort()
if ( extends_type_of (c1, y)) call abort()
if (.not. extends_type_of (x, c1)) call abort()
if (.not. extends_type_of (y, c1)) call abort()
if (.not. extends_type_of (z, c1)) call abort()
if ( extends_type_of (z%cc, z)) call abort()
end

View File

@ -10,5 +10,5 @@ program test
use foo
print *, pi
end program test
! { dg-final { scan-module "foo" "MD5:9c43cf4d713824ec6894b83250720e68" } }
! { dg-final { scan-module "foo" "MD5:5632bcd379cf023bf7e663e91d52fa12" } }
! { dg-final { cleanup-modules "foo" } }

View File

@ -1,6 +1,6 @@
! { dg-do compile }
!
! Error checking for the intrinsic function SAME_TYPE_AS.
! Error checking for the intrinsic functions SAME_TYPE_AS and EXTENDS_TYPE_OF.
!
! Contributed by Janus Weil <janus@gcc.gnu.org>
@ -18,7 +18,10 @@
integer :: i
print *, SAME_TYPE_AS (l,x1) ! { dg-error "must be of a derived type" }
print *, SAME_TYPE_AS (i,x1) ! { dg-error "must be of a derived type" }
print *, SAME_TYPE_AS (x1,x2) ! { dg-error "must be of an extensible type" }
print *, EXTENDS_TYPE_OF (i,x1) ! { dg-error "must be of a derived type" }
print *, EXTENDS_TYPE_OF (x1,x2) ! { dg-error "must be of an extensible type" }
end

View File

@ -40,16 +40,14 @@
print *,"a is TYPE(t1)"
type is (t2)
print *,"a is TYPE(t2)"
! FIXME: CLASS IS specification is not yet supported
! class is (ts) ! { FIXME: error "must be extensible" }
! print *,"a is TYPE(ts)"
class is (ts) ! { dg-error "must be extensible" }
print *,"a is TYPE(ts)"
type is (t3) ! { dg-error "must be an extension of" }
print *,"a is TYPE(t3)"
type is (t4) ! { dg-error "is not an accessible derived type" }
print *,"a is TYPE(t3)"
! FIXME: CLASS IS specification is not yet supported
! class is (t1)
! print *,"a is CLASS(t1)"
class is (t1)
print *,"a is CLASS(t1)"
class is (t2) label ! { dg-error "Syntax error" }
print *,"a is CLASS(t2)"
class default ! { dg-error "cannot be followed by a second DEFAULT CASE" }

View File

@ -30,9 +30,8 @@
i = 1
type is (t2)
i = 2
! FIXME: CLASS IS is not yet supported
! class is (t1)
! i = 3
class is (t1)
i = 3
end select
if (i /= 1) call abort()
@ -45,9 +44,8 @@
i = 1
type is (t2)
i = 2
! FIXME: CLASS IS is not yet supported
! class is (t2)
! i = 3
class is (t2)
i = 3
end select
if (i /= 2) call abort()

View File

@ -0,0 +1,98 @@
! { dg-do run }
!
! executing SELECT TYPE statements with CLASS IS blocks
!
! Contributed by Janus Weil <janus@gcc.gnu.org>
implicit none
type :: t1
integer :: i
end type t1
type, extends(t1) :: t2
integer :: j
end type t2
type, extends(t2) :: t3
real :: r
end type
class(t1), pointer :: cp
type(t1), target :: a
type(t2), target :: b
type(t3), target :: c
integer :: i
cp => c
i = 0
select type (cp)
type is (t1)
i = 1
type is (t2)
i = 2
class is (t1)
i = 3
class default
i = 4
end select
print *,i
if (i /= 3) call abort()
cp => a
select type (cp)
type is (t1)
i = 1
type is (t2)
i = 2
class is (t1)
i = 3
end select
print *,i
if (i /= 1) call abort()
cp => b
select type (cp)
type is (t1)
i = 1
class is (t3)
i = 3
class is (t2)
i = 4
class is (t1)
i = 5
end select
print *,i
if (i /= 4) call abort()
cp => b
select type (cp)
type is (t1)
i = 1
class is (t1)
i = 5
class is (t2)
i = 4
class is (t3)
i = 3
end select
print *,i
if (i /= 4) call abort()
cp => a
select type (cp)
type is (t2)
i = 1
class is (t2)
i = 2
class default
i = 3
class is (t3)
i = 4
type is (t3)
i = 5
end select
print *,i
if (i /= 3) call abort()
end

View File

@ -0,0 +1,20 @@
! { dg-do compile }
!
! PR 42053: [OOP] SELECT TYPE: reject duplicate CLASS IS blocks
!
! Contributed by Janus Weil <janus@gcc.gnu.org>
type :: t
integer :: i
end type
CLASS(t),pointer :: x
select type (x)
class is (t)
print *,"a"
class is (t) ! { dg-error "Double CLASS IS block" }
print *,"b"
end select
end

View File

@ -1,3 +1,10 @@
2009-11-30 Janus Weil <janus@gcc.gnu.org>
* gfortran.map: Add _gfortran_is_extension_of.
* Makefile.am: Add intrinsics/extends_type_of.c.
* Makefile.in: Regenerated.
* intrinsics/extends_type_of.c: New file.
2009-11-30 Kai Tietz <Kai.Tietz@onevision.com>
* io/unix.c (find_file): Add variable id conditionally for

View File

@ -85,6 +85,7 @@ intrinsics/eoshift2.c \
intrinsics/erfc_scaled.c \
intrinsics/etime.c \
intrinsics/exit.c \
intrinsics/extends_type_of.c \
intrinsics/fnum.c \
intrinsics/gerror.c \
intrinsics/getcwd.c \

View File

@ -433,15 +433,15 @@ am__libgfortran_la_SOURCES_DIST = runtime/backtrace.c runtime/bounds.c \
intrinsics/date_and_time.c intrinsics/dtime.c intrinsics/env.c \
intrinsics/eoshift0.c intrinsics/eoshift2.c \
intrinsics/erfc_scaled.c intrinsics/etime.c intrinsics/exit.c \
intrinsics/fnum.c intrinsics/gerror.c intrinsics/getcwd.c \
intrinsics/getlog.c intrinsics/getXid.c intrinsics/hostnm.c \
intrinsics/ierrno.c intrinsics/ishftc.c \
intrinsics/iso_c_generated_procs.c intrinsics/iso_c_binding.c \
intrinsics/kill.c intrinsics/link.c intrinsics/malloc.c \
intrinsics/mvbits.c intrinsics/move_alloc.c \
intrinsics/pack_generic.c intrinsics/perror.c \
intrinsics/selected_char_kind.c intrinsics/signal.c \
intrinsics/size.c intrinsics/sleep.c \
intrinsics/extends_type_of.c intrinsics/fnum.c \
intrinsics/gerror.c intrinsics/getcwd.c intrinsics/getlog.c \
intrinsics/getXid.c intrinsics/hostnm.c intrinsics/ierrno.c \
intrinsics/ishftc.c intrinsics/iso_c_generated_procs.c \
intrinsics/iso_c_binding.c intrinsics/kill.c intrinsics/link.c \
intrinsics/malloc.c intrinsics/mvbits.c \
intrinsics/move_alloc.c intrinsics/pack_generic.c \
intrinsics/perror.c intrinsics/selected_char_kind.c \
intrinsics/signal.c intrinsics/size.c intrinsics/sleep.c \
intrinsics/spread_generic.c intrinsics/string_intrinsics.c \
intrinsics/system.c intrinsics/rand.c intrinsics/random.c \
intrinsics/rename.c intrinsics/reshape_generic.c \
@ -725,15 +725,16 @@ am__objects_36 = associated.lo abort.lo access.lo args.lo \
bit_intrinsics.lo c99_functions.lo chdir.lo chmod.lo clock.lo \
cpu_time.lo cshift0.lo ctime.lo date_and_time.lo dtime.lo \
env.lo eoshift0.lo eoshift2.lo erfc_scaled.lo etime.lo exit.lo \
fnum.lo gerror.lo getcwd.lo getlog.lo getXid.lo hostnm.lo \
ierrno.lo ishftc.lo iso_c_generated_procs.lo iso_c_binding.lo \
kill.lo link.lo malloc.lo mvbits.lo move_alloc.lo \
pack_generic.lo perror.lo selected_char_kind.lo signal.lo \
size.lo sleep.lo spread_generic.lo string_intrinsics.lo \
system.lo rand.lo random.lo rename.lo reshape_generic.lo \
reshape_packed.lo selected_int_kind.lo selected_real_kind.lo \
stat.lo symlnk.lo system_clock.lo time.lo transpose_generic.lo \
umask.lo unlink.lo unpack_generic.lo in_pack_generic.lo \
extends_type_of.lo fnum.lo gerror.lo getcwd.lo getlog.lo \
getXid.lo hostnm.lo ierrno.lo ishftc.lo \
iso_c_generated_procs.lo iso_c_binding.lo kill.lo link.lo \
malloc.lo mvbits.lo move_alloc.lo pack_generic.lo perror.lo \
selected_char_kind.lo signal.lo size.lo sleep.lo \
spread_generic.lo string_intrinsics.lo system.lo rand.lo \
random.lo rename.lo reshape_generic.lo reshape_packed.lo \
selected_int_kind.lo selected_real_kind.lo stat.lo symlnk.lo \
system_clock.lo time.lo transpose_generic.lo umask.lo \
unlink.lo unpack_generic.lo in_pack_generic.lo \
in_unpack_generic.lo
am__objects_37 =
am__objects_38 = _abs_c4.lo _abs_c8.lo _abs_c10.lo _abs_c16.lo \
@ -1030,6 +1031,7 @@ intrinsics/eoshift2.c \
intrinsics/erfc_scaled.c \
intrinsics/etime.c \
intrinsics/exit.c \
intrinsics/extends_type_of.c \
intrinsics/fnum.c \
intrinsics/gerror.c \
intrinsics/getcwd.c \
@ -1892,6 +1894,7 @@ distclean-compile:
@AMDEP_TRUE@@am__include@ @am__quote@./$(DEPDIR)/exponent_r16.Plo@am__quote@
@AMDEP_TRUE@@am__include@ @am__quote@./$(DEPDIR)/exponent_r4.Plo@am__quote@
@AMDEP_TRUE@@am__include@ @am__quote@./$(DEPDIR)/exponent_r8.Plo@am__quote@
@AMDEP_TRUE@@am__include@ @am__quote@./$(DEPDIR)/extends_type_of.Plo@am__quote@
@AMDEP_TRUE@@am__include@ @am__quote@./$(DEPDIR)/fbuf.Plo@am__quote@
@AMDEP_TRUE@@am__include@ @am__quote@./$(DEPDIR)/file_pos.Plo@am__quote@
@AMDEP_TRUE@@am__include@ @am__quote@./$(DEPDIR)/fmain.Plo@am__quote@
@ -5478,6 +5481,13 @@ exit.lo: intrinsics/exit.c
@AMDEP_TRUE@@am__fastdepCC_FALSE@ DEPDIR=$(DEPDIR) $(CCDEPMODE) $(depcomp) @AMDEPBACKSLASH@
@am__fastdepCC_FALSE@ $(LIBTOOL) --tag=CC $(AM_LIBTOOLFLAGS) $(LIBTOOLFLAGS) --mode=compile $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(AM_CPPFLAGS) $(CPPFLAGS) $(AM_CFLAGS) $(CFLAGS) -c -o exit.lo `test -f 'intrinsics/exit.c' || echo '$(srcdir)/'`intrinsics/exit.c
extends_type_of.lo: intrinsics/extends_type_of.c
@am__fastdepCC_TRUE@ $(LIBTOOL) --tag=CC $(AM_LIBTOOLFLAGS) $(LIBTOOLFLAGS) --mode=compile $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(AM_CPPFLAGS) $(CPPFLAGS) $(AM_CFLAGS) $(CFLAGS) -MT extends_type_of.lo -MD -MP -MF $(DEPDIR)/extends_type_of.Tpo -c -o extends_type_of.lo `test -f 'intrinsics/extends_type_of.c' || echo '$(srcdir)/'`intrinsics/extends_type_of.c
@am__fastdepCC_TRUE@ $(am__mv) $(DEPDIR)/extends_type_of.Tpo $(DEPDIR)/extends_type_of.Plo
@AMDEP_TRUE@@am__fastdepCC_FALSE@ source='intrinsics/extends_type_of.c' object='extends_type_of.lo' libtool=yes @AMDEPBACKSLASH@
@AMDEP_TRUE@@am__fastdepCC_FALSE@ DEPDIR=$(DEPDIR) $(CCDEPMODE) $(depcomp) @AMDEPBACKSLASH@
@am__fastdepCC_FALSE@ $(LIBTOOL) --tag=CC $(AM_LIBTOOLFLAGS) $(LIBTOOLFLAGS) --mode=compile $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(AM_CPPFLAGS) $(CPPFLAGS) $(AM_CFLAGS) $(CFLAGS) -c -o extends_type_of.lo `test -f 'intrinsics/extends_type_of.c' || echo '$(srcdir)/'`intrinsics/extends_type_of.c
fnum.lo: intrinsics/fnum.c
@am__fastdepCC_TRUE@ $(LIBTOOL) --tag=CC $(AM_LIBTOOLFLAGS) $(LIBTOOLFLAGS) --mode=compile $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(AM_CPPFLAGS) $(CPPFLAGS) $(AM_CFLAGS) $(CFLAGS) -MT fnum.lo -MD -MP -MF $(DEPDIR)/fnum.Tpo -c -o fnum.lo `test -f 'intrinsics/fnum.c' || echo '$(srcdir)/'`intrinsics/fnum.c
@am__fastdepCC_TRUE@ $(am__mv) $(DEPDIR)/fnum.Tpo $(DEPDIR)/fnum.Plo

View File

@ -1095,6 +1095,7 @@ GFORTRAN_1.2 {
global:
_gfortran_clz128;
_gfortran_ctz128;
_gfortran_is_extension_of;
} GFORTRAN_1.1;
F2C_1.0 {

View File

@ -0,0 +1,61 @@
/* Implementation of the EXTENDS_TYPE_OF intrinsic.
Copyright (C) 2004, 2007, 2009 Free Software Foundation, Inc.
Contributed by Janus Weil <janus@gcc.gnu.org>.
This file is part of the GNU Fortran 95 runtime library (libgfortran).
Libgfortran is free software; you can redistribute it and/or
modify it under the terms of the GNU General Public
License as published by the Free Software Foundation; either
version 3 of the License, or (at your option) any later version.
Libgfortran is distributed in the hope that it will be useful,
but WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
GNU General Public License for more details.
Under Section 7 of GPL version 3, you are granted additional
permissions described in the GCC Runtime Library Exception, version
3.1, as published by the Free Software Foundation.
You should have received a copy of the GNU General Public License and
a copy of the GCC Runtime Library Exception along with this program;
see the files COPYING3 and COPYING.RUNTIME respectively. If not, see
<http://www.gnu.org/licenses/>. */
#include "libgfortran.h"
#ifdef HAVE_STDLIB_H
#include <stdlib.h>
#endif
typedef struct vtype
{
GFC_INTEGER_4 hash;
GFC_INTEGER_4 size;
struct vtype *extends;
}
vtype;
extern GFC_LOGICAL_4 is_extension_of (struct vtype *, struct vtype *);
export_proto(is_extension_of);
/* This is a helper function for the F2003 intrinsic EXTENDS_TYPE_OF.
While EXTENDS_TYPE_OF accepts CLASS or TYPE arguments, this one here gets
passed the corresponding vtabs. Each call to EXTENDS_TYPE_OF is translated
to a call to is_extension_of. */
GFC_LOGICAL_4
is_extension_of (struct vtype *v1, struct vtype *v2)
{
while (v1)
{
if (v1->hash == v2->hash) return 1;
v1 = v1->extends;
}
return 0;
}