mirror of
https://gcc.gnu.org/git/gcc.git
synced 2025-01-19 10:54:04 +08:00
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:
parent
8146bb5887
commit
7c1dab0d8b
@ -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
|
||||
|
@ -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;
|
||||
|
@ -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);
|
||||
}
|
||||
|
||||
|
@ -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*);
|
||||
|
@ -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);
|
||||
|
||||
|
@ -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 *);
|
||||
|
@ -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)
|
||||
{
|
||||
|
@ -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;
|
||||
|
||||
|
@ -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 ();
|
||||
}
|
||||
|
@ -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;
|
||||
}
|
||||
|
||||
|
@ -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;
|
||||
}
|
||||
|
||||
|
||||
|
@ -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);
|
||||
|
||||
|
@ -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);
|
||||
|
@ -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:
|
||||
|
@ -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));
|
||||
}
|
||||
}
|
||||
}
|
||||
|
||||
}
|
||||
|
@ -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;
|
||||
|
@ -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
|
||||
|
@ -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
|
||||
|
@ -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" } }
|
||||
|
48
gcc/testsuite/gfortran.dg/extends_type_of_1.f03
Normal file
48
gcc/testsuite/gfortran.dg/extends_type_of_1.f03
Normal 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
|
@ -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" } }
|
||||
|
@ -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
|
||||
|
@ -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" }
|
||||
|
@ -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()
|
||||
|
98
gcc/testsuite/gfortran.dg/select_type_8.f03
Normal file
98
gcc/testsuite/gfortran.dg/select_type_8.f03
Normal 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
|
20
gcc/testsuite/gfortran.dg/select_type_9.f03
Normal file
20
gcc/testsuite/gfortran.dg/select_type_9.f03
Normal 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
|
@ -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
|
||||
|
@ -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 \
|
||||
|
@ -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
|
||||
|
@ -1095,6 +1095,7 @@ GFORTRAN_1.2 {
|
||||
global:
|
||||
_gfortran_clz128;
|
||||
_gfortran_ctz128;
|
||||
_gfortran_is_extension_of;
|
||||
} GFORTRAN_1.1;
|
||||
|
||||
F2C_1.0 {
|
||||
|
61
libgfortran/intrinsics/extends_type_of.c
Normal file
61
libgfortran/intrinsics/extends_type_of.c
Normal 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;
|
||||
}
|
Loading…
Reference in New Issue
Block a user