+2012-12-19 Paul Thomas <pault@gcc.gnu.org>
+
+ * array.c (resolve_array_list): Apply C4106.
+ * check.c (gfc_check_same_type_as): Exclude polymorphic
+ entities from check for extensible types. Improved error
+ for disallowed argument types to name the offending type.
+ * class.c : Update copyright date.
+ (gfc_class_null_initializer): Add argument for initialization
+ expression and deal with unlimited polymorphic typespecs.
+ (get_unique_type_string): Give unlimited polymorphic
+ entities a type string.
+ (gfc_intrinsic_hash_value): New function.
+ (gfc_build_class_symbol): Incorporate unlimited polymorphic
+ entities.
+ (gfc_find_derived_vtab): Deal with unlimited polymorphic
+ entities.
+ (gfc_find_intrinsic_vtab): New function.
+ * decl.c (gfc_match_decl_type_spec): Match typespec for
+ unlimited polymorphic type.
+ (gfc_match_data_decl): Skip to 'ok' if unlimited polymorphic.
+ expr.c (gfc_check_pointer_assign): Apply C717. If unlimited
+ polymorphic lvalue, find rvalue vtable for all typespecs,
+ except unlimited polymorphic expressions.
+ (gfc_check_vardef_context): Handle unlimited polymorphic
+ entities.
+ * gfortran.h : Add unlimited polymorphic attribute. Add
+ second arg to gfc_class_null_initializer primitive and
+ primitive for gfc_find_intrinsic_vtab. Add UNLIMITED_POLY
+ to detect unlimited polymorphic expressions.
+ * interface.c (gfc_compare_types): If expr1 is unlimited
+ polymorphic, always return 1. If expr2 is unlimited polymorphic
+ enforce C717.
+ (gfc_compare_interfaces): Skip past conditions that do not
+ apply for unlimited polymorphic entities.
+ (compare_parameter): Make sure that an unlimited polymorphic,
+ allocatable or pointer, formal argument is matched by an
+ unlimited polymorphic actual argument.
+ (compare_actual_formal): Ensure that an intrinsic vtable exists
+ to match an unlimited polymorphic formal argument.
+ * match.c (gfc_match_allocate): Type kind parameter does not
+ need to match an unlimited polymorphic allocate-object.
+ (alloc_opt_list): An unlimited polymorphic allocate-object
+ requires a typespec or a SOURCE tag.
+ (select_intrinsic_set_tmp): New function.
+ (select_type_set_tmp): Call new function. If it returns NULL,
+ build a derived type or class temporary instead.
+ (gfc_match_type_is): Remove restriction to derived types only.
+ Bind(C) or sequence derived types not permitted.
+ * misc (gfc_typename): Printed CLASS(*) for unlimited
+ polymorphism.
+ * module.c : Add AB_UNLIMITED_POLY to pass unlimited
+ polymorphic attribute to and from modules.
+ * resolve.c (resolve_common_vars): Unlimited polymorphic
+ entities cannot appear in common blocks.
+ (resolve_deallocate_expr): Deallocate unlimited polymorphic
+ enities.
+ (resolve_allocate_expr): Likewise for allocation. Make sure
+ vtable exists.
+ (gfc_type_is_extensible): Unlimited polymorphic entities are
+ not extensible.
+ (resolve_select_type): Handle unlimited polymorphic selectors.
+ Ensure that length type parameters are assumed and that names
+ for intrinsic types are generated.
+ (resolve_fl_var_and_proc): Exclude select type temporaries
+ from test of extensibility of type.
+ (resolve_fl_variable): Likewise for test that assumed character
+ length must be a dummy or a parameter.
+ (resolve_fl_derived0): Return SUCCESS unconditionally for
+ unlimited polymorphic entities. Also, allow unlimited
+ polymorphic components.
+ (resolve_fl_derived): Return SUCCESS unconditionally for
+ unlimited polymorphic entities.
+ (resolve_symbol): Return early with unlimited polymorphic
+ entities.
+ * simplifiy.c : Update copyright year.
+ (gfc_simplify_extends_type_of): No simplification possible
+ for unlimited polymorphic arguments.
+ * symbol.c (gfc_use_derived): Nothing to do for unlimited
+ polymorphic "derived type".
+ (gfc_type_compatible): Return unity if ts1 is unlimited
+ polymorphic.
+ * trans-decl.c (create_function_arglist) Formal arguments
+ without a character length should be treated in the same way
+ as passed lengths.
+ (gfc_trans_deferred_vars): Nullify the vptr of unlimited
+ polymorphic pointers. Avoid unlimited polymorphic entities
+ triggering gcc_unreachable.
+ * trans-expr.c (gfc_conv_intrinsic_to_class): New function.
+ (gfc_trans_class_init_assign): Make indirect reference of
+ src.expr.
+ (gfc_trans_class_assign): Expression NULL of unknown type
+ should set NULL vptr on lhs. Treat C717 cases where lhs is
+ a derived type and the rhs is unlimited polymorphic.
+ (gfc_conv_procedure_call): Handle the conversion of a non-class
+ actual argument to match an unlimited polymorphic formal
+ argument. Suppress the passing of a character string length
+ in this case. Make sure that calls to the character __copy
+ function have two character string length arguments.
+ (gfc_conv_initializer): Pass the initialization expression to
+ gfc_class_null_initializer.
+ (gfc_trans_subcomponent_assign): Ditto.
+ (gfc_conv_structure): Move handling of _size component.
+ trans-intrinsic.c: (gfc_conv_same_type_as): Handle conditions
+ where unlimited polymorphic arguments have null vptr.
+ * trans-stmt.c (trans_associate_var): Correctly treat array
+ temporaries associated with unlimited polymorphic selectors.
+ Recover the overwritten dtype for the descriptor. Use the _size
+ field of the vptr for character string lengths.
+ (gfc_trans_allocate): Cope with unlimited polymorphic allocate
+ objects; especially with character source tags.
+ (reset_vptr): New function.
+ (gfc_trans_deallocate): Call it.
+ * trans-types.c (gfc_get_derived_type): Detect unlimited
+ polymorphic types and deal with cases where the derived type of
+ components is null.
+ * trans.c : Update copyright year.
+ (trans_code): Call gfc_trans_class_assign for C717 cases where
+ the lhs is not unlimited polymorphic.
+
2012-12-19 Tobias Burnus <burnus@net-b.de>
PR fortran/55733
PR fortran/55593
* frontend-passes.c (doloop_code): Use resolved_sym
instead of n.sym->formal for formal argument list
- to get the correct version for all generic subroutines.
+ to get the correct version for all generic subroutines.
2012-12-05 Tobias Burnus <burnus@net-b.de>
goto cleanup;
case AS_ASSUMED_RANK:
- gcc_unreachable ();
+ gcc_unreachable ();
}
if (gfc_match_char (')') == MATCH_YES)
goto cleanup;
case AS_ASSUMED_RANK:
- gcc_unreachable ();
+ gcc_unreachable ();
}
if (gfc_match_char (']') == MATCH_YES)
gfc_free_expr (e);
current_expand.extract_count++;
-
+
return SUCCESS;
}
{
gfc_symbol *iter_var;
locus iter_var_loc;
-
+
if (gfc_resolve_iterator (iter, false, true) == FAILURE)
t = FAILURE;
if (gfc_resolve_expr (c->expr) == FAILURE)
t = FAILURE;
+
+ if (UNLIMITED_POLY (c->expr))
+ {
+ gfc_error ("Array constructor value at %L shall not be unlimited "
+ "polymorphic [F2008: C4106]", &c->expr->where);
+ t = FAILURE;
+ }
}
return t;
expr->ts.u.cl->length = gfc_get_int_expr (gfc_default_integer_kind,
NULL, found_length);
}
- else
+ else
{
/* We've got a character length specified. It should be an integer,
otherwise an error is signalled elsewhere. */
}
return SUCCESS;
-}
+}
/* Make sure the expression is a logical array. */
{
gfc_extract_int (expr2, &i2);
i3 = gfc_validate_kind (BT_INTEGER, expr1->ts.kind, false);
-
+
/* For ISHFT[C], check that |shift| <= bit_size(i). */
if (arg2 == NULL)
{
if (expr->expr_type != EXPR_CONSTANT)
return SUCCESS;
-
+
i = gfc_validate_kind (BT_INTEGER, k, false);
gfc_extract_int (expr, &val);
|| (ref->u.c.component->ts.type != BT_CLASS
&& ref->u.c.component->attr.pointer)))
break;
- }
+ }
if (!ref)
{
if (dim->expr_type != EXPR_CONSTANT)
return SUCCESS;
-
+
if (array->ts.type == BT_CLASS)
return SUCCESS;
{
if (mpz_cmp (a_size, b_size) != 0)
ret = 0;
-
+
mpz_clear (b_size);
}
mpz_clear (a_size);
return FAILURE;
if (allocatable_check (array, 0) == FAILURE)
return FAILURE;
-
+
return SUCCESS;
}
return SUCCESS;
i = mpz_get_si (c->ts.u.cl->length->value.integer);
}
- else
+ else
return SUCCESS;
}
else
if (i != 1)
{
- gfc_error ("Argument of %s at %L must be of length one",
+ gfc_error ("Argument of %s at %L must be of length one",
gfc_current_intrinsic, &c->where);
return FAILURE;
}
|| type_check (shift, 1, BT_INTEGER) == FAILURE)
return FAILURE;
- if (size != NULL)
+ if (size != NULL)
{
int i2, i3;
bool is_variable = true;
/* Functions returning pointers are regarded as variable, cf. F2008, R602. */
- if (a->expr_type == EXPR_FUNCTION)
+ if (a->expr_type == EXPR_FUNCTION)
is_variable = a->value.function.esym
? a->value.function.esym->result->attr.pointer
: a->symtree->n.sym->result->attr.pointer;
if (order_size != shape_size)
{
gfc_error ("'%s' argument of '%s' intrinsic at %L "
- "has wrong number of elements (%d/%d)",
+ "has wrong number of elements (%d/%d)",
gfc_current_intrinsic_arg[3]->name,
gfc_current_intrinsic, &order->where,
order_size, shape_size);
if (dim < 1 || dim > order_size)
{
gfc_error ("'%s' argument of '%s' intrinsic at %L "
- "has out-of-range dimension (%d)",
+ "has out-of-range dimension (%d)",
gfc_current_intrinsic_arg[3]->name,
gfc_current_intrinsic, &e->where, dim);
return FAILURE;
gfc_constructor *c;
bool test;
-
+
mpz_init_set_ui (size, 1);
for (c = gfc_constructor_first (shape->value.constructor);
c; c = gfc_constructor_next (c))
gfc_try
gfc_check_same_type_as (gfc_expr *a, gfc_expr *b)
{
-
if (a->ts.type != BT_DERIVED && a->ts.type != BT_CLASS)
{
- gfc_error ("'%s' argument of '%s' intrinsic at %L "
- "must be of a derived type",
- gfc_current_intrinsic_arg[0]->name, gfc_current_intrinsic,
- &a->where);
- return FAILURE;
+ gfc_error ("'%s' argument of '%s' intrinsic at %L "
+ "cannot be of type %s",
+ gfc_current_intrinsic_arg[0]->name,
+ gfc_current_intrinsic,
+ &a->where, gfc_typename (&a->ts));
+ return FAILURE;
}
- if (!gfc_type_is_extensible (a->ts.u.derived))
+ if (!(gfc_type_is_extensible (a->ts.u.derived) || UNLIMITED_POLY (a)))
{
gfc_error ("'%s' argument of '%s' intrinsic at %L "
"must be of an extensible type",
if (b->ts.type != BT_DERIVED && b->ts.type != BT_CLASS)
{
- gfc_error ("'%s' argument of '%s' intrinsic at %L "
- "must be of a derived type",
- gfc_current_intrinsic_arg[1]->name, gfc_current_intrinsic,
- &b->where);
+ gfc_error ("'%s' argument of '%s' intrinsic at %L "
+ "cannot be of type %s",
+ gfc_current_intrinsic_arg[0]->name,
+ gfc_current_intrinsic,
+ &b->where, gfc_typename (&b->ts));
return FAILURE;
}
- if (!gfc_type_is_extensible (b->ts.u.derived))
+ if (!(gfc_type_is_extensible (b->ts.u.derived) || UNLIMITED_POLY (b)))
{
gfc_error ("'%s' argument of '%s' intrinsic at %L "
"must be of an extensible type",
return FAILURE;
/* dim_rank_check() does not apply here. */
- if (dim
+ if (dim
&& dim->expr_type == EXPR_CONSTANT
&& (mpz_cmp_ui (dim->value.integer, 1) < 0
|| mpz_cmp_ui (dim->value.integer, source->rank + 1) > 0))
if (mask->rank != field->rank && field->rank != 0)
{
gfc_error ("'%s' argument of '%s' intrinsic at %L must have "
- "the same rank as '%s' or be a scalar",
+ "the same rank as '%s' or be a scalar",
gfc_current_intrinsic_arg[2]->name, gfc_current_intrinsic,
&field->where, gfc_current_intrinsic_arg[1]->name);
return FAILURE;
if (! identical_dimen_shape (mask, i, field, i))
{
gfc_error ("'%s' and '%s' arguments of '%s' intrinsic at %L "
- "must have identical shape.",
+ "must have identical shape.",
gfc_current_intrinsic_arg[2]->name,
gfc_current_intrinsic_arg[1]->name, gfc_current_intrinsic,
&field->where);
/* Implementation of Fortran 2003 Polymorphism.
- Copyright (C) 2009, 2010
+ Copyright (C) 2009, 2010, 2011, 2012
Free Software Foundation, Inc.
Contributed by Paul Richard Thomas <pault@gcc.gnu.org>
and Janus Weil <janus@gcc.gnu.org>
#include "gfortran.h"
#include "constructor.h"
-
/* Inserts a derived type component reference in a data reference chain.
TS: base type of the ref chain so far, in which we will pick the component
REF: the address of the GFC_REF pointer to update
ref = ref->next;
ref->type = REF_ARRAY;
ref->u.ar.type = AR_FULL;
- ref->u.ar.as = as;
+ ref->u.ar.as = as;
}
}
if (ref->type != REF_COMPONENT)
result = false;
else if (ref->u.c.component->ts.type == BT_CLASS)
- result = true;
+ result = true;
else
result = false;
}
the _vptr component to the declared type. */
gfc_expr *
-gfc_class_null_initializer (gfc_typespec *ts)
+gfc_class_null_initializer (gfc_typespec *ts, gfc_expr *init_expr)
{
gfc_expr *init;
gfc_component *comp;
-
+ gfc_symbol *vtab = NULL;
+ bool is_unlimited_polymorphic;
+
+ is_unlimited_polymorphic = ts->u.derived
+ && ts->u.derived->components->ts.u.derived
+ && ts->u.derived->components->ts.u.derived->attr.unlimited_polymorphic;
+
+ if (is_unlimited_polymorphic && init_expr)
+ vtab = gfc_find_intrinsic_vtab (&(init_expr->ts));
+ else
+ vtab = gfc_find_derived_vtab (ts->u.derived);
+
init = gfc_get_structure_constructor_expr (ts->type, ts->kind,
&ts->u.derived->declared_at);
init->ts = *ts;
-
+
for (comp = ts->u.derived->components; comp; comp = comp->next)
{
gfc_constructor *ctor = gfc_constructor_get();
- if (strcmp (comp->name, "_vptr") == 0)
- ctor->expr = gfc_lval_expr_from_sym (gfc_find_derived_vtab (ts->u.derived));
+ if (strcmp (comp->name, "_vptr") == 0 && vtab)
+ ctor->expr = gfc_lval_expr_from_sym (vtab);
else
ctor->expr = gfc_get_null_expr (NULL);
gfc_constructor_append (&init->value.constructor, ctor);
get_unique_type_string (char *string, gfc_symbol *derived)
{
char dt_name[GFC_MAX_SYMBOL_LEN+1];
+ if (derived->attr.unlimited_polymorphic)
+ sprintf (dt_name, "%s", "$tar");
+ else
sprintf (dt_name, "%s", derived->name);
dt_name[0] = TOUPPER (dt_name[0]);
- if (derived->module)
+ if (derived->attr.unlimited_polymorphic)
+ sprintf (string, "_%s", dt_name);
+ else if (derived->module)
sprintf (string, "%s_%s", derived->module, dt_name);
else if (derived->ns->proc_name)
sprintf (string, "%s_%s", derived->ns->proc_name->name, dt_name);
unsigned int hash = 0;
char c[2*(GFC_MAX_SYMBOL_LEN+1)];
int i, len;
-
+
get_unique_type_string (&c[0], sym);
len = strlen (c);
-
+
+ for (i = 0; i < len; i++)
+ hash = (hash << 6) + (hash << 16) - hash + c[i];
+
+ /* Return the hash but take the modulus for the sake of module read,
+ even though this slightly increases the chance of collision. */
+ return (hash % 100000000);
+}
+
+
+/* Assign a hash value for an intrinsic type. The algorithm is that of SDBM. */
+
+unsigned int
+gfc_intrinsic_hash_value (gfc_typespec *ts)
+{
+ unsigned int hash = 0;
+ const char *c = gfc_typename (ts);
+ int i, len;
+
+ len = strlen (c);
+
for (i = 0; i < len; i++)
hash = (hash << 6) + (hash << 16) - hash + c[i];
gfc_symbol *fclass;
gfc_symbol *vtab;
gfc_component *c;
+ gfc_namespace *ns;
int rank;
gcc_assert (as);
attr->class_ok = attr->dummy || attr->pointer || attr->allocatable
|| attr->select_type_temporary;
-
+
if (!attr->class_ok)
/* We can not build the class container yet. */
return SUCCESS;
else
sprintf (name, "__class_%s", tname);
- gfc_find_symbol (name, ts->u.derived->ns, 0, &fclass);
+ if (ts->u.derived->attr.unlimited_polymorphic)
+ {
+ /* Find the top-level namespace. */
+ for (ns = gfc_current_ns; ns; ns = ns->parent)
+ if (!ns->parent)
+ break;
+ }
+ else
+ ns = ts->u.derived->ns;
+
+ gfc_find_symbol (name, 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);
+ fclass = gfc_new_symbol (name, ns);
+ st = gfc_new_symtree (&ns->sym_root, name);
st->n.sym = fclass;
gfc_set_sym_referenced (fclass);
fclass->refs++;
fclass->ts.type = BT_UNKNOWN;
+ if (!ts->u.derived->attr.unlimited_polymorphic)
fclass->attr.abstract = ts->u.derived->attr.abstract;
fclass->f2k_derived = gfc_get_namespace (NULL, 0);
if (gfc_add_flavor (&fclass->attr, FL_DERIVED,
c->attr.allocatable = attr->allocatable;
c->attr.dimension = attr->dimension;
c->attr.codimension = attr->codimension;
- c->attr.abstract = ts->u.derived->attr.abstract;
+ c->attr.abstract = fclass->attr.abstract;
c->as = (*as);
c->initializer = NULL;
c->attr.pointer = 1;
}
- /* Since the extension field is 8 bit wide, we can only have
- up to 255 extension levels. */
- if (ts->u.derived->attr.extension == 255)
+ if (!ts->u.derived->attr.unlimited_polymorphic)
{
- gfc_error ("Maximum extension level reached with type '%s' at %L",
- ts->u.derived->name, &ts->u.derived->declared_at);
- return FAILURE;
+ /* 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.alloc_comp = ts->u.derived->attr.alloc_comp;
}
-
- fclass->attr.extension = ts->u.derived->attr.extension + 1;
- fclass->attr.alloc_comp = ts->u.derived->attr.alloc_comp;
+
fclass->attr.is_class = 1;
ts->u.derived = fclass;
attr->allocatable = attr->pointer = attr->dimension = attr->codimension = 0;
if (tb->non_overridable)
return;
-
+
c = gfc_find_component (vtype, name, true, true);
if (c == NULL)
if (st->right)
add_procs_to_declared_vtab1 (st->right, vtype);
- if (st->n.tb && !st->n.tb->error
+ if (st->n.tb && !st->n.tb->error
&& !st->n.tb->is_generic && st->n.tb->u.specific)
add_proc_comp (vtype, st->name, st->n.tb);
}
gfc_symbol *vtab = NULL, *vtype = NULL, *found_sym = NULL, *def_init = NULL;
gfc_symbol *copy = NULL, *src = NULL, *dst = NULL;
- /* Find the top-level namespace (MODULE or PROGRAM). */
+ /* Find the top-level namespace. */
for (ns = gfc_current_ns; ns; ns = ns->parent)
if (!ns->parent)
break;
/* If the type is a class container, use the underlying derived type. */
- if (derived->attr.is_class)
+ if (!derived->attr.unlimited_polymorphic && derived->attr.is_class)
derived = gfc_get_derived_super_type (derived);
-
+
if (ns)
{
char name[GFC_MAX_SYMBOL_LEN+1], tname[GFC_MAX_SYMBOL_LEN+1];
goto cleanup;
c->attr.pointer = 1;
c->attr.access = ACCESS_PRIVATE;
- parent = gfc_get_derived_super_type (derived);
+ if (!derived->attr.unlimited_polymorphic)
+ parent = gfc_get_derived_super_type (derived);
+ else
+ parent = NULL;
+
if (parent)
{
parent_vtab = gfc_find_derived_vtab (parent);
c->initializer = gfc_get_null_expr (NULL);
}
- if (derived->components == NULL && !derived->attr.zero_comp)
+ if (!derived->attr.unlimited_polymorphic
+ && derived->components == NULL
+ && !derived->attr.zero_comp)
{
/* At this point an error must have occurred.
Prevent further errors on the vtype components. */
c->attr.access = ACCESS_PRIVATE;
c->ts.type = BT_DERIVED;
c->ts.u.derived = derived;
- if (derived->attr.abstract)
+ if (derived->attr.unlimited_polymorphic
+ || derived->attr.abstract)
c->initializer = gfc_get_null_expr (NULL);
else
{
c->attr.access = ACCESS_PRIVATE;
c->tb = XCNEW (gfc_typebound_proc);
c->tb->ppc = 1;
- if (derived->attr.abstract)
+ if (derived->attr.unlimited_polymorphic
+ || derived->attr.abstract)
c->initializer = gfc_get_null_expr (NULL);
else
{
Note: The actual wrapper function can only be generated
at resolution time. */
/* FIXME: Enable ABI-breaking "_final" generation. */
- if (0)
+ if (0)
{
if (gfc_add_component (vtype, "_final", &c) == FAILURE)
goto cleanup;
}
/* Add procedure pointers for type-bound procedures. */
- add_procs_to_declared_vtab (derived, vtype);
+ if (!derived->attr.unlimited_polymorphic)
+ add_procs_to_declared_vtab (derived, vtype);
}
have_vtype:
}
+/* Find (or generate) the symbol for an intrinsic type's vtab. This is
+ need to support unlimited polymorphism. */
+
+gfc_symbol *
+gfc_find_intrinsic_vtab (gfc_typespec *ts)
+{
+ gfc_namespace *ns;
+ gfc_symbol *vtab = NULL, *vtype = NULL, *found_sym = NULL, *def_init = NULL;
+ gfc_symbol *copy = NULL, *src = NULL, *dst = NULL;
+ int charlen = 0;
+
+ if (ts->type == BT_CHARACTER && ts->deferred)
+ {
+ gfc_error ("TODO: Deferred character length variable at %C cannot "
+ "yet be associated with unlimited polymorphic entities");
+ return NULL;
+ }
+
+ if (ts->type == BT_UNKNOWN)
+ return NULL;
+
+ /* Sometimes the typespec is passed from a single call. */
+ if (ts->type == BT_DERIVED)
+ return gfc_find_derived_vtab (ts->u.derived);
+
+ /* Find the top-level namespace. */
+ for (ns = gfc_current_ns; ns; ns = ns->parent)
+ if (!ns->parent)
+ break;
+
+ if (ts->type == BT_CHARACTER && ts->u.cl && ts->u.cl->length
+ && ts->u.cl->length->expr_type == EXPR_CONSTANT)
+ charlen = mpz_get_si (ts->u.cl->length->value.integer);
+
+ if (ns)
+ {
+ char name[GFC_MAX_SYMBOL_LEN+1], tname[GFC_MAX_SYMBOL_LEN+1];
+
+ if (ts->type == BT_CHARACTER)
+ sprintf (tname, "%s_%d_%d", gfc_basic_typename (ts->type),
+ charlen, ts->kind);
+ else
+ sprintf (tname, "%s_%d_", gfc_basic_typename (ts->type), ts->kind);
+
+ sprintf (name, "__vtab_%s", tname);
+
+ /* Look for the vtab symbol in various namespaces. */
+ gfc_find_symbol (name, gfc_current_ns, 0, &vtab);
+ if (vtab == NULL)
+ gfc_find_symbol (name, ns, 0, &vtab);
+
+ if (vtab == NULL)
+ {
+ gfc_get_symbol (name, ns, &vtab);
+ vtab->ts.type = BT_DERIVED;
+ if (gfc_add_flavor (&vtab->attr, FL_VARIABLE, NULL,
+ &gfc_current_locus) == FAILURE)
+ goto cleanup;
+ vtab->attr.target = 1;
+ vtab->attr.save = SAVE_IMPLICIT;
+ vtab->attr.vtab = 1;
+ vtab->attr.access = ACCESS_PUBLIC;
+ gfc_set_sym_referenced (vtab);
+ sprintf (name, "__vtype_%s", tname);
+
+ gfc_find_symbol (name, ns, 0, &vtype);
+ if (vtype == NULL)
+ {
+ gfc_component *c;
+ int hash;
+ gfc_namespace *sub_ns;
+ gfc_namespace *contained;
+
+ gfc_get_symbol (name, ns, &vtype);
+ if (gfc_add_flavor (&vtype->attr, FL_DERIVED,
+ NULL, &gfc_current_locus) == FAILURE)
+ goto cleanup;
+ vtype->attr.access = ACCESS_PUBLIC;
+ vtype->attr.vtype = 1;
+ gfc_set_sym_referenced (vtype);
+
+ /* Add component '_hash'. */
+ if (gfc_add_component (vtype, "_hash", &c) == FAILURE)
+ goto cleanup;
+ c->ts.type = BT_INTEGER;
+ c->ts.kind = 4;
+ c->attr.access = ACCESS_PRIVATE;
+ hash = gfc_intrinsic_hash_value (ts);
+ c->initializer = gfc_get_int_expr (gfc_default_integer_kind,
+ NULL, hash);
+
+ /* Add component '_size'. */
+ if (gfc_add_component (vtype, "_size", &c) == FAILURE)
+ goto cleanup;
+ c->ts.type = BT_INTEGER;
+ c->ts.kind = 4;
+ c->attr.access = ACCESS_PRIVATE;
+ if (ts->type == BT_CHARACTER)
+ c->initializer = gfc_get_int_expr (gfc_default_integer_kind,
+ NULL, charlen*ts->kind);
+ else
+ c->initializer = gfc_get_int_expr (gfc_default_integer_kind,
+ NULL, ts->kind);
+
+ /* Add component _extends. */
+ if (gfc_add_component (vtype, "_extends", &c) == FAILURE)
+ goto cleanup;
+ c->attr.pointer = 1;
+ c->attr.access = ACCESS_PRIVATE;
+ /* Avoid segfaults because due to character length. */
+ c->ts.type = ts->type == BT_CHARACTER ? BT_VOID : ts->type;
+ c->ts.kind = ts->kind;
+ c->initializer = gfc_get_null_expr (NULL);
+
+ /* Add component _def_init. */
+ if (gfc_add_component (vtype, "_def_init", &c) == FAILURE)
+ goto cleanup;
+ c->attr.pointer = 1;
+ c->attr.access = ACCESS_PRIVATE;
+ /* Avoid segfaults due to missing character length. */
+ c->ts.type = ts->type == BT_CHARACTER ? BT_VOID : ts->type;
+ c->ts.kind = ts->kind;
+ c->initializer = gfc_get_null_expr (NULL);
+
+ /* Add component _copy. */
+ if (gfc_add_component (vtype, "_copy", &c) == FAILURE)
+ goto cleanup;
+ c->attr.proc_pointer = 1;
+ c->attr.access = ACCESS_PRIVATE;
+ c->tb = XCNEW (gfc_typebound_proc);
+ c->tb->ppc = 1;
+
+ /* Check to see if copy function already exists. Note
+ that this is only used for characters of different
+ lengths. */
+ contained = ns->contained;
+ for (; contained; contained = contained->sibling)
+ if (contained->proc_name
+ && strcmp (name, contained->proc_name->name) == 0)
+ {
+ copy = contained->proc_name;
+ goto got_char_copy;
+ }
+
+ /* Set up namespace. */
+ sub_ns = gfc_get_namespace (ns, 0);
+ sub_ns->sibling = ns->contained;
+ ns->contained = sub_ns;
+ sub_ns->resolved = 1;
+ /* Set up procedure symbol. */
+ if (ts->type != BT_CHARACTER)
+ sprintf (name, "__copy_%s", tname);
+ else
+ /* __copy is always the same for characters. */
+ sprintf (name, "__copy_character_%d", ts->kind);
+ gfc_get_symbol (name, sub_ns, ©);
+ sub_ns->proc_name = copy;
+ copy->attr.flavor = FL_PROCEDURE;
+ copy->attr.subroutine = 1;
+ copy->attr.pure = 1;
+ copy->attr.if_source = IFSRC_DECL;
+ /* This is elemental so that arrays are automatically
+ treated correctly by the scalarizer. */
+ copy->attr.elemental = 1;
+ if (ns->proc_name->attr.flavor == FL_MODULE)
+ copy->module = ns->proc_name->name;
+ gfc_set_sym_referenced (copy);
+ /* Set up formal arguments. */
+ gfc_get_symbol ("src", sub_ns, &src);
+ src->ts.type = ts->type;
+ src->ts.kind = ts->kind;
+ src->attr.flavor = FL_VARIABLE;
+ src->attr.dummy = 1;
+ src->attr.intent = INTENT_IN;
+ gfc_set_sym_referenced (src);
+ copy->formal = gfc_get_formal_arglist ();
+ copy->formal->sym = src;
+ gfc_get_symbol ("dst", sub_ns, &dst);
+ dst->ts.type = ts->type;
+ dst->ts.kind = ts->kind;
+ dst->attr.flavor = FL_VARIABLE;
+ dst->attr.dummy = 1;
+ dst->attr.intent = INTENT_OUT;
+ gfc_set_sym_referenced (dst);
+ copy->formal->next = gfc_get_formal_arglist ();
+ copy->formal->next->sym = dst;
+ /* Set up code. */
+ sub_ns->code = gfc_get_code ();
+ sub_ns->code->op = EXEC_INIT_ASSIGN;
+ sub_ns->code->expr1 = gfc_lval_expr_from_sym (dst);
+ sub_ns->code->expr2 = gfc_lval_expr_from_sym (src);
+ got_char_copy:
+ /* Set initializer. */
+ c->initializer = gfc_lval_expr_from_sym (copy);
+ c->ts.interface = copy;
+ }
+ vtab->ts.u.derived = vtype;
+ vtab->value = gfc_default_initializer (&vtab->ts);
+ }
+ }
+
+ found_sym = vtab;
+
+cleanup:
+ /* It is unexpected to have some symbols added at resolution or code
+ generation time. We commit the changes in order to keep a clean state. */
+ if (found_sym)
+ {
+ gfc_commit_symbol (vtab);
+ if (vtype)
+ gfc_commit_symbol (vtype);
+ if (def_init)
+ gfc_commit_symbol (def_init);
+ if (copy)
+ gfc_commit_symbol (copy);
+ if (src)
+ gfc_commit_symbol (src);
+ if (dst)
+ gfc_commit_symbol (dst);
+ }
+ else
+ gfc_undo_symbols ();
+
+ return found_sym;
+}
+
+
/* General worker function to find either a type-bound procedure or a
type-bound user operator. */
/* Try to find it in the current type's namespace. */
if (derived->f2k_derived)
res = derived->f2k_derived->tb_op[op];
- else
+ else
res = NULL;
/* Check access. */
return MATCH_ERROR;
else if (m == MATCH_YES)
{
- gfc_fatal_error ("Unlimited polymorphism at %C not yet supported");
+ gfc_symbol *upe;
+ gfc_symtree *st;
+ ts->type = BT_CLASS;
+ gfc_find_symbol ("$tar", gfc_current_ns, 1, &upe);
+ if (upe == NULL)
+ {
+ upe = gfc_new_symbol ("$tar", gfc_current_ns);
+ st = gfc_new_symtree (&gfc_current_ns->sym_root, "$tar");
+ st->n.sym = upe;
+ gfc_set_sym_referenced (upe);
+ upe->refs++;
+ upe->ts.type = BT_VOID;
+ upe->attr.unlimited_polymorphic = 1;
+ /* This is essential to force the construction of
+ unlimited polymorphic component class containers. */
+ upe->attr.zero_comp = 1;
+ if (gfc_add_flavor (&upe->attr, FL_DERIVED,
+ NULL, &gfc_current_locus) == FAILURE)
return MATCH_ERROR;
}
+ else
+ {
+ st = gfc_find_symtree (gfc_current_ns->sym_root, "$tar");
+ if (st == NULL)
+ st = gfc_new_symtree (&gfc_current_ns->sym_root, "$tar");
+ st->n.sym = upe;
+ upe->refs++;
+ }
+ ts->u.derived = upe;
+ return m;
+ }
m = gfc_match (" class ( %n )", name);
if (m != MATCH_YES)
goto cleanup;
}
+ if (current_ts.type == BT_CLASS
+ && current_ts.u.derived->attr.unlimited_polymorphic)
+ goto ok;
+
if ((current_ts.type == BT_DERIVED || current_ts.type == BT_CLASS)
&& current_ts.u.derived->components == NULL
&& !current_ts.u.derived->attr.zero_comp)
mpz_t *new_shape, *s;
int i, n;
- if (shape == NULL
+ if (shape == NULL
|| rank <= 1
|| dim == NULL
- || dim->expr_type != EXPR_CONSTANT
+ || dim->expr_type != EXPR_CONSTANT
|| dim->ts.type != BT_INTEGER)
return NULL;
gcc_assert (begin->rank == 1);
/* Zero-sized arrays have no shape and no elements, stop early. */
- if (!begin->shape)
+ if (!begin->shape)
{
mpz_init_set_ui (nelts, 0);
break;
/* An element reference reduces the rank of the expression; don't
add anything to the shape array. */
- if (ref->u.ar.dimen_type[d] != DIMEN_ELEMENT)
+ if (ref->u.ar.dimen_type[d] != DIMEN_ELEMENT)
mpz_set (expr->shape[shape_i++], tmp_mpz);
}
}
else
{
- mpz_add (ctr[d], ctr[d], stride[d]);
+ mpz_add (ctr[d], ctr[d], stride[d]);
if (mpz_cmp_ui (stride[d], 0) > 0
? mpz_cmp (ctr[d], end[d]) > 0
gfc_constructor *ci, *new_ctor;
gfc_expr *expr, *old;
int n, i, rank[5], array_arg;
-
+
/* Find which, if any, arguments are arrays. Assume that the old
expression carries the type information and that the first arg
that is an array expression carries all the shape information.*/
case INTRINSIC_LE_OS:
if ((*check_function) (op2) == FAILURE)
return FAILURE;
-
+
if (!(et0 (op1) == BT_CHARACTER && et0 (op2) == BT_CHARACTER)
&& !(numeric_type (et0 (op1)) && numeric_type (et0 (op2))))
{
name = e->symtree->n.sym->name;
- functions = (gfc_option.warn_std & GFC_STD_F2003)
+ functions = (gfc_option.warn_std & GFC_STD_F2003)
? inquiry_func_f2003 : inquiry_func_f95;
for (i = 0; functions[i]; i++)
name = e->symtree->n.sym->name;
- functions = (gfc_option.allow_std & GFC_STD_F2003)
+ functions = (gfc_option.allow_std & GFC_STD_F2003)
? trans_func_f2003 : trans_func_f95;
/* NULL() is dealt with below. */
|| gfc_current_ns->parent->proc_name->attr.subroutine)
|| gfc_current_ns->parent->proc_name->attr.is_main_program))
{
- /* ... that is not a function... */
+ /* ... that is not a function... */
if (!gfc_current_ns->proc_name->attr.function)
bad_proc = true;
}
if (rvalue->expr_type == EXPR_NULL)
- {
+ {
if (has_pointer && (ref == NULL || ref->next == NULL)
&& lvalue->symtree->n.sym->attr.data)
return SUCCESS;
}
/* This is possibly a typo: x = f() instead of x => f(). */
- if (gfc_option.warn_surprising
+ if (gfc_option.warn_surprising
&& rvalue->expr_type == EXPR_FUNCTION
&& rvalue->symtree->n.sym->attr.pointer)
gfc_warning ("POINTER valued function appears on right-hand side of "
mpfr_init (rv);
gfc_set_model_kind (rvalue->ts.kind);
mpfr_init (diff);
-
+
mpfr_set (rv, rvalue->value.real, GFC_RND_MODE);
mpfr_sub (diff, rv, rvalue->value.real, GFC_RND_MODE);
-
+
if (!mpfr_zero_p (diff))
gfc_warning ("Change of value in conversion from "
" %s to %s at %L", gfc_typename (&rvalue->ts),
gfc_typename (&lvalue->ts), &rvalue->where);
-
+
mpfr_clear (rv);
mpfr_clear (diff);
}
if (!gfc_compare_types (&lvalue->ts, &rvalue->ts))
{
- gfc_error ("Different types in pointer assignment at %L; attempted "
- "assignment of %s to %s", &lvalue->where,
- gfc_typename (&rvalue->ts), gfc_typename (&lvalue->ts));
+ /* Check for F03:C717. */
+ if (UNLIMITED_POLY (rvalue)
+ && !(UNLIMITED_POLY (lvalue)
+ || (lvalue->ts.type == BT_DERIVED
+ && (lvalue->ts.u.derived->attr.is_bind_c
+ || lvalue->ts.u.derived->attr.sequence))))
+ gfc_error ("Data-pointer-object &L must be unlimited "
+ "polymorphic, a sequence derived type or of a "
+ "type with the BIND attribute assignment at %L "
+ "to be compatible with an unlimited polymorphic "
+ "target", &lvalue->where);
+ else
+ gfc_error ("Different types in pointer assignment at %L; "
+ "attempted assignment of %s to %s", &lvalue->where,
+ gfc_typename (&rvalue->ts),
+ gfc_typename (&lvalue->ts));
return FAILURE;
}
return FAILURE;
}
- if (lvalue->ts.type == BT_CLASS && rvalue->ts.type == BT_DERIVED)
/* Make sure the vtab is present. */
+ if (lvalue->ts.type == BT_CLASS && rvalue->ts.type == BT_DERIVED)
gfc_find_derived_vtab (rvalue->ts.u.derived);
+ else if (UNLIMITED_POLY (lvalue) && !UNLIMITED_POLY (rvalue))
+ gfc_find_intrinsic_vtab (&rvalue->ts);
/* Check rank remapping. */
if (rank_remap)
if (is_implicit_pure && gfc_impure_variable (rvalue->symtree->n.sym))
gfc_current_ns->proc_name->attr.implicit_pure = 0;
-
+
if (gfc_has_vector_index (rvalue))
{
if (r == FAILURE)
return r;
-
+
if (sym->attr.pointer && rvalue->expr_type != EXPR_NULL)
{
/* F08:C461. Additional checks for pointer initialization. */
return FAILURE;
}
}
-
+
if (sym->attr.proc_pointer && rvalue->expr_type != EXPR_NULL)
{
/* F08:C1220. Additional checks for procedure pointer initialization. */
static bool
replace_symbol (gfc_expr *expr, gfc_symbol *sym, int *i ATTRIBUTE_UNUSED)
{
- if ((expr->expr_type == EXPR_VARIABLE
+ if ((expr->expr_type == EXPR_VARIABLE
|| (expr->expr_type == EXPR_FUNCTION
&& !gfc_is_intrinsic (expr->symtree->n.sym, 0, expr->where)))
&& expr->symtree->n.sym->ns == sym->ts.interface->formal_ns
{
gfc_component *comp;
comp = (gfc_component *)sym;
- if ((expr->expr_type == EXPR_VARIABLE
+ if ((expr->expr_type == EXPR_VARIABLE
|| (expr->expr_type == EXPR_FUNCTION
&& !gfc_is_intrinsic (expr->symtree->n.sym, 0, expr->where)))
&& expr->symtree->n.sym->ns == comp->ts.interface->formal_ns)
if (e->ts.type == BT_CLASS && e->ts.u.derived->components)
corank = e->ts.u.derived->components->as
? e->ts.u.derived->components->as->corank : 0;
- else
+ else
corank = e->symtree->n.sym->as ? e->symtree->n.sym->as->corank : 0;
for (ref = e->ref; ref; ref = ref->next)
for (ref = e->ref; ref; ref = ref->next)
if (ref->type == REF_COMPONENT)
last = ref;
-
+
if (last && last->u.c.component->ts.type == BT_CLASS)
return CLASS_DATA (last->u.c.component)->attr.pointer_comp;
else if (last && last->u.c.component->ts.type == BT_DERIVED)
ar->as->upper[i]->value.integer) != 0))
colon = false;
}
-
+
return true;
}
isym = gfc_find_function (name);
gcc_assert (isym);
-
+
result = gfc_get_expr ();
result->expr_type = EXPR_FUNCTION;
result->ts = isym->ts;
bool is_pointer;
bool check_intentin;
bool ptr_component;
+ bool unlimited;
symbol_attribute attr;
gfc_ref* ref;
sym = e->value.function.esym ? e->value.function.esym : e->symtree->n.sym;
}
+ unlimited = e->ts.type == BT_CLASS && UNLIMITED_POLY (sym);
+
attr = gfc_expr_attr (e);
if (!pointer && e->expr_type == EXPR_FUNCTION && attr.pointer)
{
/* Find out whether the expr is a pointer; this also means following
component references to the last one. */
is_pointer = (attr.pointer || attr.proc_pointer);
- if (pointer && !is_pointer)
+ if (pointer && !is_pointer && !unlimited)
{
if (context)
gfc_error ("Non-POINTER in pointer association context (%s)"
components or private components, procedure pointer components,
possibly nested. zero_comp is true if the derived type has no
component at all. defined_assign_comp is true if the derived
- type or a (sub-)component has a typebound defined assignment. */
+ type or a (sub-)component has a typebound defined assignment.
+ unlimited_polymorphic flags the type of the container for these
+ entities. */
unsigned alloc_comp:1, pointer_comp:1, proc_pointer_comp:1,
private_comp:1, zero_comp:1, coarray_comp:1, lock_comp:1,
- defined_assign_comp:1;
+ defined_assign_comp:1, unlimited_polymorphic:1;
/* This is a temporary selector for SELECT TYPE. */
unsigned select_type_temporary:1;
}
gfc_symbol;
-
/* This structure is used to keep track of symbols in common blocks. */
typedef struct gfc_common_head
{
bool gfc_is_class_array_ref (gfc_expr *, bool *);
bool gfc_is_class_scalar_expr (gfc_expr *);
bool gfc_is_class_container_ref (gfc_expr *e);
-gfc_expr *gfc_class_null_initializer (gfc_typespec *);
+gfc_expr *gfc_class_null_initializer (gfc_typespec *, gfc_expr *);
unsigned int gfc_hash_value (gfc_symbol *);
gfc_try gfc_build_class_symbol (gfc_typespec *, symbol_attribute *,
gfc_array_spec **, bool);
gfc_symbol *gfc_find_derived_vtab (gfc_symbol *);
+gfc_symbol *gfc_find_intrinsic_vtab (gfc_typespec *);
gfc_symtree* gfc_find_typebound_proc (gfc_symbol*, gfc_try*,
const char*, bool, locus*);
gfc_symtree* gfc_find_typebound_user_op (gfc_symbol*, gfc_try*,
bool gfc_is_finalizable (gfc_symbol *, gfc_expr **);
#define CLASS_DATA(sym) sym->ts.u.derived->components
+#define UNLIMITED_POLY(sym) \
+ (sym != NULL && sym->ts.type == BT_CLASS \
+ && CLASS_DATA (sym) \
+ && CLASS_DATA (sym)->ts.u.derived \
+ && CLASS_DATA (sym)->ts.u.derived->attr.unlimited_polymorphic)
/* frontend-passes.c */
if (gfc_get_symbol (name, NULL, &sym))
return MATCH_ERROR;
- if (!sym->attr.generic
+ if (!sym->attr.generic
&& gfc_add_generic (&sym->attr, sym->name, NULL) == FAILURE)
return MATCH_ERROR;
gfc_error ("Expecting 'END INTERFACE OPERATOR (%s)' at %C, "
"but got %s", s1, s2);
}
-
+
}
break;
if (dt1->attr.dimension && gfc_compare_array_spec (dt1->as, dt2->as) == 0)
return 0;
- /* Make sure that link lists do not put this function into an
+ /* Make sure that link lists do not put this function into an
endless recursive loop! */
if (!(dt1->ts.type == BT_DERIVED && derived1 == dt1->ts.u.derived)
&& !(dt2->ts.type == BT_DERIVED && derived2 == dt2->ts.u.derived)
that is for the formal arg, but oh well. */
if (ts1->type == BT_VOID || ts2->type == BT_VOID)
return 1;
-
+
+ if (ts1->type == BT_CLASS
+ && ts1->u.derived->components->ts.u.derived->attr.unlimited_polymorphic)
+ return 1;
+
+ /* F2003: C717 */
+ if (ts2->type == BT_CLASS && ts1->type == BT_DERIVED
+ && ts2->u.derived->components->ts.u.derived->attr.unlimited_polymorphic
+ && (ts1->u.derived->attr.sequence || ts1->u.derived->attr.is_bind_c))
+ return 1;
+
if (ts1->type != ts2->type
&& ((ts1->type != BT_DERIVED && ts1->type != BT_CLASS)
|| (ts2->type != BT_DERIVED && ts2->type != BT_CLASS)))
return 0; /* Ranks differ. */
return gfc_compare_types (&s1->ts, &s2->ts)
- || s1->ts.type == BT_ASSUMED || s2->ts.type == BT_ASSUMED;
+ || s1->ts.type == BT_ASSUMED || s2->ts.type == BT_ASSUMED;
}
}
}
}
-
+
return SUCCESS;
}
return 0;
}
+ if (UNLIMITED_POLY (f1->sym))
+ goto next;
+
if (strict_flag)
{
/* Check all characteristics. */
f1->sym->name);
return 0;
}
-
+next:
f1 = f1->next;
f2 = f2->next;
}
for (ns2 = ns; ns2; ns2 = ns2->parent)
{
gfc_intrinsic_op other_op;
-
+
if (check_interface1 (ns->op[i], ns2->op[i], 0,
interface_name, true))
goto done;
"(rank-%d and scalar)", name, where, rank1);
}
else
- {
+ {
gfc_error ("Rank mismatch in argument '%s' at %L "
"(rank-%d and rank-%d)", name, where, rank1, rank2);
}
&& formal->ts.type != BT_ASSUMED
&& !gfc_compare_types (&formal->ts, &actual->ts)
&& !(formal->ts.type == BT_DERIVED && actual->ts.type == BT_CLASS
- && gfc_compare_derived_types (formal->ts.u.derived,
+ && gfc_compare_derived_types (formal->ts.u.derived,
CLASS_DATA (actual)->ts.u.derived)))
{
if (where)
}
}
+ /* F08: 12.5.2.5 Allocatable and pointer dummy variables. However, this
+ is necessary also for F03, so retain error for both.
+ NOTE: Other type/kind errors pre-empt this error. Since they are F03
+ compatible, no attempt has been made to channel to this one. */
+ if (UNLIMITED_POLY (formal) && !UNLIMITED_POLY (actual)
+ && (CLASS_DATA (formal)->attr.allocatable
+ ||CLASS_DATA (formal)->attr.class_pointer))
+ {
+ if (where)
+ gfc_error ("Actual argument to '%s' at %L must be unlimited "
+ "polymorphic since the formal argument is a "
+ "pointer or allocatable unlimited polymorphic "
+ "entity [F2008: 12.5.2.5]", formal->name,
+ &actual->where);
+ return 0;
+ }
+
if (formal->attr.codimension && !gfc_is_coarray (actual))
{
if (where)
is_pointer = ref->u.c.component->attr.pointer;
else if (ref->type == REF_ARRAY && ref->u.ar.type == AR_ELEMENT
&& ref->u.ar.dimen > 0
- && (!ref->next
+ && (!ref->next
|| (ref->next->type == REF_SUBSTRING && !ref->next->next)))
break;
}
return 0;
}
else
- strlen = 1;
+ strlen = 1;
if (symbol_rank (sym) == 0)
return strlen;
if (e == NULL)
return 0;
-
+
if (e->ts.type == BT_CHARACTER)
{
if (e->ts.u.cl && e->ts.u.cl->length
return 0;
}
+ /* Make sure that intrinsic vtables exist for calls to unlimited
+ polymorphic formal arguments. */
+ if (UNLIMITED_POLY(f->sym)
+ && a->expr->ts.type != BT_DERIVED
+ && a->expr->ts.type != BT_CLASS)
+ gfc_find_intrinsic_vtab (&a->expr->ts);
+
if (a->expr->expr_type == EXPR_NULL
&& ((f->sym->ts.type != BT_CLASS && !f->sym->attr.pointer
&& (f->sym->attr.allocatable || !f->sym->attr.optional
return 0;
}
-
+
if (!compare_parameter (f->sym, a->expr, ranks_must_agree,
is_elemental, where))
return 0;
"pointer dummy '%s'", &a->expr->where,f->sym->name);
return 0;
}
-
+
/* Fortran 2008, C1242. */
if (f->sym->attr.pointer && gfc_is_coindexed (a->expr))
has_null_arg = true;
null_expr_loc = a->expr->where;
break;
- }
+ }
for (; intr; intr = intr->next)
{
}
/* Satisfy 12.4.4.1 such that an elemental match has lower
- weight than a non-elemental match. */
+ weight than a non-elemental match. */
if (intr->sym->attr.elemental)
{
elem_sym = intr->sym;
tbo = matching_typebound_op (&tb_base, actual, i, NULL, &gname);
break;
}
-
+
/* If there is a matching typebound-operator, replace the expression with
a call to it and succeed. */
if (tbo)
/* See if we find a matching type-bound assignment. */
tbo = matching_typebound_op (&tb_base, actual,
INTRINSIC_ASSIGN, NULL, &gname);
-
+
/* If there is one, replace the expression with a call to it and
succeed. */
if (tbo)
" FUNCTION", proc->name, &where);
return FAILURE;
}
-
+
if (check_result_characteristics (proc_target, old_target,
err, sizeof(err)) == FAILURE)
{
size_t i = 0;
gfc_char_t c;
char* buf;
- size_t cursz = 16;
+ size_t cursz = 16;
old_loc = gfc_current_locus;
gfc_gobble_whitespace ();
gfc_current_locus = old_loc;
return MATCH_YES;
}
-
+
if (!ISALPHA (c) && c != '_')
{
gfc_error ("Invalid C name in NAME= specifier at %C");
cursz *= 2;
buf = XRESIZEVEC (char, buf, cursz);
}
-
+
old_loc = gfc_current_locus;
-
+
/* Get next char; param means we're in a string. */
c = gfc_next_char_literal (INSTRING_WARN);
} while (ISALNUM (c) || c == '_');
return MATCH_ERROR;
}
}
-
+
/* If we stopped because we had an invalid character for a C name, report
that to the user by returning MATCH_NO. */
if (c != '"' && c != '\'')
}
-/* Match an intrinsic operator. Returns an INTRINSIC enum. While matching,
- we always find INTRINSIC_PLUS before INTRINSIC_UPLUS. We work around this
+/* Match an intrinsic operator. Returns an INTRINSIC enum. While matching,
+ we always find INTRINSIC_PLUS before INTRINSIC_UPLUS. We work around this
in matchexp.c. */
match
old_loc2 = gfc_current_locus;
gfc_current_locus = old_loc;
-
+
if (gfc_match_parens () == MATCH_ERROR)
return MATCH_ERROR;
gfc_free_expr (expr);
return MATCH_ERROR;
}
-
+
if (gfc_notify_std (GFC_STD_F95_OBS, "Arithmetic IF "
"statement at %C") == FAILURE)
return MATCH_ERROR;
match ("write", gfc_match_write, ST_WRITE)
/* The gfc_match_assignment() above may have returned a MATCH_NO
- where the assignment was to a named constant. Check that
+ where the assignment was to a named constant. Check that
special case here. */
m = gfc_match_assignment ();
if (m == MATCH_NO)
match_derived_type_spec (gfc_typespec *ts)
{
char name[GFC_MAX_SYMBOL_LEN + 1];
- locus old_locus;
+ locus old_locus;
gfc_symbol *derived;
old_locus = gfc_current_locus;
return MATCH_YES;
}
- gfc_current_locus = old_locus;
+ gfc_current_locus = old_locus;
return MATCH_NO;
}
return MATCH_ERROR;
}
-/* Match the rest of a simple FORALL statement that follows an
+/* Match the rest of a simple FORALL statement that follows an
IF statement. */
static match
return MATCH_NO;
/* Check for balanced parens. */
-
+
if (gfc_match_parens () == MATCH_ERROR)
return MATCH_ERROR;
" do-construct-name at %C") == FAILURE)
return MATCH_ERROR;
break;
-
+
default:
gfc_error ("%s statement at %C is not applicable to construct '%s'",
gfc_ascii_statement (st), sym->name);
return MATCH_YES;
}
- /* The assigned GO TO statement. */
+ /* The assigned GO TO statement. */
if (gfc_match_variable (&expr, 0) == MATCH_YES)
{
match m;
locus old_locus, deferred_locus;
bool saw_stat, saw_errmsg, saw_source, saw_mold, saw_deferred, b1, b2, b3;
+ bool saw_unlimited = false;
head = tail = NULL;
stat = errmsg = source = mold = tmp = NULL;
}
/* Enforce F03:C627. */
- if (ts.kind != tail->expr->ts.kind)
+ if (ts.kind != tail->expr->ts.kind && !UNLIMITED_POLY (tail->expr))
{
gfc_error ("Kind type parameter for entity at %L differs from "
"the kind type parameter of the typespec",
if (tail->expr->ts.type == BT_DERIVED)
tail->expr->ts.u.derived = gfc_use_derived (tail->expr->ts.u.derived);
+ saw_unlimited = saw_unlimited | UNLIMITED_POLY (tail->expr);
+
if (gfc_peek_ascii_char () == '(' && !sym->attr.dimension)
{
gfc_error ("Shape specification for allocatable scalar at %C");
gfc_error ("Redundant MOLD tag found at %L ", &tmp->where);
goto cleanup;
}
-
+
/* Check F08:C637. */
if (ts.type != BT_UNKNOWN)
{
&deferred_locus);
goto cleanup;
}
-
+
+ /* Check F03:C625, */
+ if (saw_unlimited && ts.type == BT_UNKNOWN && !source && !mold)
+ {
+ for (tail = head; tail; tail = tail->next)
+ {
+ if (UNLIMITED_POLY (tail->expr))
+ gfc_error ("Unlimited polymorphic allocate-object at %L "
+ "requires either a type-spec or SOURCE tag "
+ "or a MOLD tag", &tail->expr->where);
+ }
+ goto cleanup;
+ }
+
new_st.op = EXEC_ALLOCATE;
new_st.expr1 = stat;
new_st.expr2 = errmsg;
}
-/* Match the call of a type-bound procedure, if CALL%var has already been
+/* Match the call of a type-bound procedure, if CALL%var has already been
matched and var found to be a derived-type variable. */
static match
base->symtree = varst;
base->where = gfc_current_locus;
gfc_set_sym_referenced (varst->n.sym);
-
+
m = gfc_match_varspec (base, 0, true, true);
if (m == MATCH_NO)
gfc_error ("Expected component reference at %C");
/* Given a name, return a pointer to the common head structure,
creating it if it does not exist. If FROM_MODULE is nonzero, we
- mangle the name so that it doesn't interfere with commons defined
+ mangle the name so that it doesn't interfere with commons defined
in the using namespace.
TODO: Add to global symbol tree. */
/* Store a ref to the common block for error checking. */
sym->common_block = t;
sym->common_block->refs++;
-
+
/* See if we know the current common block is bind(c), and if
so, then see if we can check if the symbol is (which it'll
need to be). This can happen if the bind(c) attr stmt was
sym->name, &(sym->declared_at), t->name,
t->name);
}
-
+
if (sym->attr.is_bind_c == 1)
gfc_error_now ("Variable '%s' in common block "
"'%s' at %C can not be bind(c) since "
"it is not global", sym->name, t->name);
}
-
+
if (sym->attr.in_common)
{
gfc_error ("Symbol '%s' at %C is already in a COMMON block",
/* Check that a statement function is not recursive. This is done by looking
for the statement function symbol(sym) by looking recursively through its
- expression(e). If a reference to sym is found, true is returned.
+ expression(e). If a reference to sym is found, true is returned.
12.5.4 requires that any variable of function that is implicitly typed
shall have that type confirmed by any subsequent type declaration. The
implicit typing is conveniently done here. */
}
+/* Set the temporary for the current intrinsic SELECT TYPE selector. */
+
+static gfc_symtree *
+select_intrinsic_set_tmp (gfc_typespec *ts)
+{
+ char name[GFC_MAX_SYMBOL_LEN];
+ gfc_symtree *tmp;
+ int charlen = 0;
+
+ if (ts->type == BT_CLASS || ts->type == BT_DERIVED)
+ return NULL;
+
+ if (select_type_stack->selector->ts.type == BT_CLASS
+ && !select_type_stack->selector->attr.class_ok)
+ return NULL;
+
+ if (ts->type == BT_CHARACTER && ts->u.cl && ts->u.cl->length
+ && ts->u.cl->length->expr_type == EXPR_CONSTANT)
+ charlen = mpz_get_si (ts->u.cl->length->value.integer);
+
+ if (ts->type != BT_CHARACTER)
+ sprintf (name, "__tmp_%s_%d", gfc_basic_typename (ts->type),
+ ts->kind);
+ else
+ sprintf (name, "__tmp_%s_%d_%d", gfc_basic_typename (ts->type),
+ charlen, ts->kind);
+
+ gfc_get_sym_tree (name, gfc_current_ns, &tmp, false);
+ gfc_add_type (tmp->n.sym, ts, NULL);
+
+ /* Copy across the array spec to the selector. */
+ if (select_type_stack->selector->ts.type == BT_CLASS
+ && (CLASS_DATA (select_type_stack->selector)->attr.dimension
+ || CLASS_DATA (select_type_stack->selector)->attr.codimension))
+ {
+ tmp->n.sym->attr.pointer = 1;
+ tmp->n.sym->attr.dimension
+ = CLASS_DATA (select_type_stack->selector)->attr.dimension;
+ tmp->n.sym->attr.codimension
+ = CLASS_DATA (select_type_stack->selector)->attr.codimension;
+ tmp->n.sym->as
+ = gfc_copy_array_spec (CLASS_DATA (select_type_stack->selector)->as);
+ }
+
+ gfc_set_sym_referenced (tmp->n.sym);
+ gfc_add_flavor (&tmp->n.sym->attr, FL_VARIABLE, name, NULL);
+ tmp->n.sym->attr.select_type_temporary = 1;
+
+ return tmp;
+}
+
+
/* Set up a temporary for the current TYPE IS / CLASS IS branch . */
static void
select_type_set_tmp (gfc_typespec *ts)
{
char name[GFC_MAX_SYMBOL_LEN];
- gfc_symtree *tmp;
+ gfc_symtree *tmp = NULL;
if (!ts)
{
select_type_stack->tmp = NULL;
return;
}
-
- if (!gfc_type_is_extensible (ts->u.derived))
- return;
- 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);
+ tmp = select_intrinsic_set_tmp (ts);
- if (select_type_stack->selector->ts.type == BT_CLASS
- && select_type_stack->selector->attr.class_ok)
+ if (tmp == NULL)
{
- tmp->n.sym->attr.pointer
- = CLASS_DATA (select_type_stack->selector)->attr.class_pointer;
+ 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);
- /* Copy across the array spec to the selector. */
- if ((CLASS_DATA (select_type_stack->selector)->attr.dimension
- || CLASS_DATA (select_type_stack->selector)->attr.codimension))
+ if (select_type_stack->selector->ts.type == BT_CLASS
+ && select_type_stack->selector->attr.class_ok)
{
- tmp->n.sym->attr.dimension
+ tmp->n.sym->attr.pointer
+ = CLASS_DATA (select_type_stack->selector)->attr.class_pointer;
+
+ /* Copy across the array spec to the selector. */
+ if (CLASS_DATA (select_type_stack->selector)->attr.dimension
+ || CLASS_DATA (select_type_stack->selector)->attr.codimension)
+ {
+ tmp->n.sym->attr.dimension
= CLASS_DATA (select_type_stack->selector)->attr.dimension;
- tmp->n.sym->attr.codimension
+ tmp->n.sym->attr.codimension
= CLASS_DATA (select_type_stack->selector)->attr.codimension;
- tmp->n.sym->as
+ tmp->n.sym->as
= gfc_copy_array_spec (CLASS_DATA (select_type_stack->selector)->as);
- }
+ }
}
gfc_set_sym_referenced (tmp->n.sym);
if (ts->type == BT_CLASS)
gfc_build_class_symbol (&tmp->n.sym->ts, &tmp->n.sym->attr,
&tmp->n.sym->as, false);
+ }
/* Add an association for it, so the rest of the parser knows it is
an associate-name. The target will be set during resolution. */
select_type_stack->tmp = tmp;
}
-
+
/* Match a SELECT TYPE statement. */
match
select_type_push (expr1->symtree->n.sym);
return MATCH_YES;
-
+
cleanup:
parent_ns = gfc_current_ns->parent;
gfc_free_namespace (gfc_current_ns);
c = gfc_get_case ();
c->where = gfc_current_locus;
- /* TODO: Once unlimited polymorphism is implemented, we will need to call
- match_type_spec here. */
- if (match_derived_type_spec (&c->ts) == MATCH_ERROR)
+ if (match_type_spec (&c->ts) == MATCH_ERROR)
goto cleanup;
if (gfc_match_char (')') != MATCH_YES)
new_st.op = EXEC_SELECT_TYPE;
new_st.ext.block.case_list = c;
+ if (c->ts.type == BT_DERIVED && c->ts.u.derived
+ && (c->ts.u.derived->attr.sequence
+ || c->ts.u.derived->attr.is_bind_c))
+ {
+ gfc_error ("The type-spec shall not specify a sequence derived "
+ "type or a type with the BIND attribute in SELECT "
+ "TYPE at %C [F2003:C815]");
+ return MATCH_ERROR;
+ }
+
/* Create temporary variable. */
select_type_set_tmp (&c->ts);
new_st.op = EXEC_SELECT_TYPE;
new_st.ext.block.case_list = c;
-
+
/* Create temporary variable. */
select_type_set_tmp (&c->ts);
/********************* WHERE subroutines ********************/
-/* Match the rest of a simple WHERE statement that follows an IF statement.
+/* Match the rest of a simple WHERE statement that follows an IF statement.
*/
static match
/* Miscellaneous stuff that doesn't fit anywhere else.
- Copyright (C) 2000, 2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2010, 2011
+ Copyright (C) 2000, 2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008,
+ 2010, 2011, 2012
Free Software Foundation, Inc.
Contributed by Andy Vaught
sprintf (buffer, "TYPE(%s)", ts->u.derived->name);
break;
case BT_CLASS:
- sprintf (buffer, "CLASS(%s)",
- ts->u.derived->components->ts.u.derived->name);
+ ts = &ts->u.derived->components->ts;
+ if (ts->u.derived->attr.unlimited_polymorphic)
+ sprintf (buffer, "CLASS(*)");
+ else
+ sprintf (buffer, "CLASS(%s)", ts->u.derived->name);
break;
case BT_ASSUMED:
sprintf (buffer, "TYPE(*)");
AB_IS_BIND_C, AB_IS_C_INTEROP, AB_IS_ISO_C, AB_ABSTRACT, AB_ZERO_COMP,
AB_IS_CLASS, AB_PROCEDURE, AB_PROC_POINTER, AB_ASYNCHRONOUS, AB_CODIMENSION,
AB_COARRAY_COMP, AB_VTYPE, AB_VTAB, AB_CONTIGUOUS, AB_CLASS_POINTER,
- AB_IMPLICIT_PURE, AB_ARTIFICIAL
+ AB_IMPLICIT_PURE, AB_ARTIFICIAL, AB_UNLIMITED_POLY
}
ab_attribute;
minit ("VTAB", AB_VTAB),
minit ("CLASS_POINTER", AB_CLASS_POINTER),
minit ("IMPLICIT_PURE", AB_IMPLICIT_PURE),
+ minit ("UNLIMITED_POLY", AB_UNLIMITED_POLY),
minit (NULL, -1)
};
MIO_NAME (ab_attribute) (AB_PURE, attr_bits);
if (attr->implicit_pure)
MIO_NAME (ab_attribute) (AB_IMPLICIT_PURE, attr_bits);
+ if (attr->unlimited_polymorphic)
+ MIO_NAME (ab_attribute) (AB_UNLIMITED_POLY, attr_bits);
if (attr->recursive)
MIO_NAME (ab_attribute) (AB_RECURSIVE, attr_bits);
if (attr->always_explicit)
case AB_IMPLICIT_PURE:
attr->implicit_pure = 1;
break;
+ case AB_UNLIMITED_POLY:
+ attr->unlimited_polymorphic = 1;
+ break;
case AB_RECURSIVE:
attr->recursive = 1;
break;
&csym->declared_at);
}
+ if (UNLIMITED_POLY (csym))
+ gfc_error_now ("'%s' in cannot appear in COMMON at %L "
+ "[F2008:C5100]", csym->name, &csym->declared_at);
+
if (csym->ts.type != BT_DERIVED)
continue;
gfc_ref *ref;
gfc_symbol *sym;
gfc_component *c;
+ bool unlimited;
if (gfc_resolve_expr (e) == FAILURE)
return FAILURE;
goto bad;
sym = e->symtree->n.sym;
+ unlimited = UNLIMITED_POLY(sym);
if (sym->ts.type == BT_CLASS)
{
attr = gfc_expr_attr (e);
- if (allocatable == 0 && attr.pointer == 0)
+ if (allocatable == 0 && attr.pointer == 0 && !unlimited)
{
bad:
gfc_error ("Allocate-object at %L must be ALLOCATABLE or a POINTER",
int i, pointer, allocatable, dimension, is_abstract;
int codimension;
bool coindexed;
+ bool unlimited;
symbol_attribute attr;
gfc_ref *ref, *ref2;
gfc_expr *e2;
/* Check whether ultimate component is abstract and CLASS. */
is_abstract = 0;
+ /* Is the allocate-object unlimited polymorphic? */
+ unlimited = UNLIMITED_POLY(e);
+
if (e->expr_type != EXPR_VARIABLE)
{
allocatable = 0;
}
/* Check for F08:C628. */
- if (allocatable == 0 && pointer == 0)
+ if (allocatable == 0 && pointer == 0 && !unlimited)
{
gfc_error ("Allocate-object at %L must be ALLOCATABLE or a POINTER",
&e->where);
}
/* Check F03:C632 and restriction following Note 6.18. */
- if (code->expr3->rank > 0
+ if (code->expr3->rank > 0 && !unlimited
&& conformable_arrays (code->expr3, e) == FAILURE)
goto failure;
/* Check F03:C633. */
- if (code->expr3->ts.kind != e->ts.kind)
+ if (code->expr3->ts.kind != e->ts.kind && !unlimited)
{
gfc_error ("The allocate-object at %L and the source-expr at %L "
"shall have the same kind type parameter",
code->expr3 = rhs;
}
- if (e->ts.type == BT_CLASS)
+ if (e->ts.type == BT_CLASS && !unlimited && !UNLIMITED_POLY (code->expr3))
{
/* Make sure the vtab symbol is present when
the module variables are generated. */
ts = code->expr3->ts;
else if (code->ext.alloc.ts.type == BT_DERIVED)
ts = code->ext.alloc.ts;
+
gfc_find_derived_vtab (ts.u.derived);
+
+ if (dimension)
+ e = gfc_expr_to_initialize (e);
+ }
+ else if (unlimited && !UNLIMITED_POLY (code->expr3))
+ {
+ /* Again, make sure the vtab symbol is present when
+ the module variables are generated. */
+ gfc_typespec *ts = NULL;
+ if (code->expr3)
+ ts = &code->expr3->ts;
+ else
+ ts = &code->ext.alloc.ts;
+
+ gcc_assert (ts);
+
+ if (ts->type == BT_CLASS || ts->type == BT_DERIVED)
+ gfc_find_derived_vtab (ts->u.derived);
+ else
+ gfc_find_intrinsic_vtab (ts);
+
if (dimension)
e = gfc_expr_to_initialize (e);
}
bool
gfc_type_is_extensible (gfc_symbol *sym)
{
- return !(sym->attr.is_bind_c || sym->attr.sequence);
+ return !(sym->attr.is_bind_c || sym->attr.sequence
+ || (sym->attr.is_class
+ && sym->components->ts.u.derived->attr.unlimited_polymorphic));
}
char name[GFC_MAX_SYMBOL_LEN];
gfc_namespace *ns;
int error = 0;
+ int charlen = 0;
ns = code->ext.block.ns;
gfc_resolve (ns);
/* Check F03:C815. */
if ((c->ts.type == BT_DERIVED || c->ts.type == BT_CLASS)
+ && !selector_type->attr.unlimited_polymorphic
&& !gfc_type_is_extensible (c->ts.u.derived))
{
gfc_error ("Derived type '%s' at %L must be extensible",
/* Check F03:C816. */
if ((c->ts.type == BT_DERIVED || c->ts.type == BT_CLASS)
+ && !selector_type->attr.unlimited_polymorphic
&& !gfc_type_is_extension_of (selector_type, c->ts.u.derived))
{
gfc_error ("Derived type '%s' at %L must be an extension of '%s'",
continue;
}
+ /* Check F03:C814. */
+ if (c->ts.type == BT_CHARACTER && c->ts.u.cl->length != NULL)
+ {
+ gfc_error ("The type-spec at %L shall specify that each length "
+ "type parameter is assumed", &c->where);
+ error++;
+ continue;
+ }
+
/* Intercept the DEFAULT case. */
if (c->ts.type == BT_UNKNOWN)
{
ns->code->next = new_st;
code = new_st;
code->op = EXEC_SELECT;
+
gfc_add_vptr_component (code->expr1);
gfc_add_hash_component (code->expr1);
if (c->ts.type == BT_DERIVED)
c->low = c->high = gfc_get_int_expr (gfc_default_integer_kind, NULL,
c->ts.u.derived->hash_value);
+ else if (c->ts.type != BT_CLASS && c->ts.type != BT_UNKNOWN)
+ {
+ gfc_symbol *ivtab;
+ gfc_expr *e;
+
+ ivtab = gfc_find_intrinsic_vtab (&c->ts);
+ gcc_assert (ivtab);
+ e = CLASS_DATA (ivtab)->initializer;
+ c->low = c->high = gfc_copy_expr (e);
+ }
else if (c->ts.type == BT_UNKNOWN)
continue;
if (c->ts.type == BT_CLASS)
sprintf (name, "__tmp_class_%s", c->ts.u.derived->name);
- else
+ else if (c->ts.type == BT_DERIVED)
sprintf (name, "__tmp_type_%s", c->ts.u.derived->name);
+ else if (c->ts.type == BT_CHARACTER)
+ {
+ if (c->ts.u.cl && c->ts.u.cl->length
+ && c->ts.u.cl->length->expr_type == EXPR_CONSTANT)
+ charlen = mpz_get_si (c->ts.u.cl->length->value.integer);
+ sprintf (name, "__tmp_%s_%d_%d", gfc_basic_typename (c->ts.type),
+ charlen, c->ts.kind);
+ }
+ else
+ sprintf (name, "__tmp_%s_%d", gfc_basic_typename (c->ts.type),
+ c->ts.kind);
+
st = gfc_find_symtree (ns->sym_root, name);
gcc_assert (st->n.sym->assoc);
st->n.sym->assoc->target = gfc_get_variable_expr (code->expr1->symtree);
st->n.sym->assoc->target->where = code->expr1->where;
- if (c->ts.type == BT_DERIVED)
+ if (c->ts.type != BT_CLASS && c->ts.type != BT_UNKNOWN)
gfc_add_data_component (st->n.sym->assoc->target);
new_st = gfc_get_code ();
{
/* F03:C502. */
if (sym->attr.class_ok
+ && !sym->attr.select_type_temporary
+ && !UNLIMITED_POLY(sym)
&& !gfc_type_is_extensible (CLASS_DATA (sym)->ts.u.derived))
{
gfc_error ("Type '%s' of CLASS variable '%s' at %L is not extensible",
dummy arguments. */
e = sym->ts.u.cl->length;
if (e == NULL && !sym->attr.dummy && !sym->attr.result
- && !sym->ts.deferred)
+ && !sym->ts.deferred && !sym->attr.select_type_temporary)
{
gfc_error ("Entity with assumed character length at %L must be a "
"dummy argument or a PARAMETER", &sym->declared_at);
gfc_symbol* super_type;
gfc_component *c;
+ if (sym->attr.unlimited_polymorphic)
+ return SUCCESS;
+
super_type = gfc_get_derived_super_type (sym);
/* F2008, C432. */
if (c->ts.type == BT_CLASS && c->attr.class_ok
&& CLASS_DATA (c)->attr.class_pointer
&& CLASS_DATA (c)->ts.u.derived->components == NULL
- && !CLASS_DATA (c)->ts.u.derived->attr.zero_comp)
+ && !CLASS_DATA (c)->ts.u.derived->attr.zero_comp
+ && !UNLIMITED_POLY (c))
{
gfc_error ("The pointer component '%s' of '%s' at %L is a type "
"that has not been declared", c->name, sym->name,
{
gfc_symbol *gen_dt = NULL;
+ if (sym->attr.unlimited_polymorphic)
+ return SUCCESS;
+
if (!sym->attr.is_class)
gfc_find_symbol (sym->name, sym->ns, 0, &gen_dt);
if (gen_dt && gen_dt->generic && gen_dt->generic->next
/* Fix up incomplete CLASS symbols. */
gfc_component *data = gfc_find_component (sym, "_data", true, true);
gfc_component *vptr = gfc_find_component (sym, "_vptr", true, true);
- if (vptr->ts.u.derived == NULL)
+
+ /* Nothing more to do for unlimited polymorphic entities. */
+ if (data->ts.u.derived->attr.unlimited_polymorphic)
+ return SUCCESS;
+ else if (vptr->ts.u.derived == NULL)
{
gfc_symbol *vtab = gfc_find_derived_vtab (data->ts.u.derived);
gcc_assert (vtab);
if (sym->attr.artificial)
return;
+ if (sym->attr.unlimited_polymorphic)
+ return;
+
if (sym->attr.flavor == FL_UNKNOWN
|| (sym->attr.flavor == FL_PROCEDURE && !sym->attr.intrinsic
&& !sym->attr.generic && !sym->attr.external
/* Simplify intrinsic functions at compile-time.
- Copyright (C) 2000, 2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009,
- 2010, 2011 Free Software Foundation, Inc.
+ Copyright (C) 2000, 2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008,
+ 2009, 2010, 2011, 2012 Free Software Foundation, Inc.
Contributed by Andy Vaught & Katherine Holcomb
This file is part of GCC.
{
case ARITH_OK:
return result;
-
+
case ARITH_OVERFLOW:
gfc_error ("Result of %s overflows its kind at %L", name,
&result->where);
}
-/* Build a result expression for transformational intrinsics,
+/* Build a result expression for transformational intrinsics,
depending on DIM. */
static gfc_expr *
REAL, PARAMETER :: array(n, m) = ...
REAL, PARAMETER :: s(n) = PROD(array, DIM=1)
- where OP == gfc_multiply(). The result might be post processed using post_op. */
+ where OP == gfc_multiply(). The result might be post processed using post_op. */
static gfc_expr *
simplify_transformation_to_array (gfc_expr *result, gfc_expr *array, gfc_expr *dim,
mpfr_clear (last1);
return result;
}
-
+
/* Get second recursion anchor. */
mpfr_init (last2);
}
if (jn)
gfc_constructor_insert_expr (&result->value.constructor, e, &x->where, -2);
- else
+ else
gfc_constructor_append_expr (&result->value.constructor, e, &x->where);
if (n1 + 1 == n2)
mpfr_init (x2rev);
mpfr_ui_div (x2rev, 2, x->value.real, GFC_RND_MODE);
-
+
for (i = 2; i <= n2-n1; i++)
{
e = gfc_get_constant_expr (x->ts.type, x->ts.kind, &x->where);
case BT_COMPLEX:
mpc_cosh (result->value.complex, x->value.complex, GFC_MPC_RND_MODE);
break;
-
+
default:
gcc_unreachable ();
}
return gfc_get_logical_expr (gfc_default_logical_kind, &a->where,
gfc_type_is_extension_of (mold->ts.u.derived,
a->ts.u.derived));
+
+ if (UNLIMITED_POLY (a) || UNLIMITED_POLY (mold))
+ return NULL;
+
/* Return .false. if the dynamic type can never be the same. */
if ((a->ts.type == BT_CLASS && mold->ts.type == BT_CLASS
&& !gfc_type_is_extension_of
int back, len, lensub;
int i, j, k, count, index = 0, start;
- if (x->expr_type != EXPR_CONSTANT || y->expr_type != EXPR_CONSTANT
+ if (x->expr_type != EXPR_CONSTANT || y->expr_type != EXPR_CONSTANT
|| ( b != NULL && b->expr_type != EXPR_CONSTANT))
return NULL;
else
back = 0;
- k = get_kind (BT_INTEGER, kind, "INDEX", gfc_default_integer_kind);
+ k = get_kind (BT_INTEGER, kind, "INDEX", gfc_default_integer_kind);
if (k == -1)
return &gfc_bad_expr;
int k;
k = get_kind (BT_INTEGER, kind, upper ? "UBOUND" : "LBOUND",
- gfc_default_integer_kind);
+ gfc_default_integer_kind);
if (k == -1)
return &gfc_bad_expr;
e->expr_type = EXPR_ARRAY;
e->ts.type = BT_INTEGER;
k = get_kind (BT_INTEGER, kind, upper ? "UCOBOUND" : "LCOBOUND",
- gfc_default_integer_kind);
+ gfc_default_integer_kind);
if (k == -1)
{
gfc_free_expr (e);
if (i->expr_type != EXPR_CONSTANT)
return NULL;
-
+
kind = get_kind (BT_INTEGER, kind_arg, "MASKR", gfc_default_integer_kind);
if (kind == -1)
return &gfc_bad_expr;
if (i->expr_type != EXPR_CONSTANT)
return NULL;
-
+
kind = get_kind (BT_INTEGER, kind_arg, "MASKL", gfc_default_integer_kind);
if (kind == -1)
return &gfc_bad_expr;
#undef LENGTH
#undef STRING
break;
-
+
default:
gfc_internal_error ("simplify_min_max(): Bad type in arglist");
}
return NULL;
/* Convert to the correct type and kind. */
- if (expr->ts.type != BT_UNKNOWN)
+ if (expr->ts.type != BT_UNKNOWN)
return gfc_convert_constant (expr->value.function.actual->expr,
expr->ts.type, expr->ts.kind);
- if (specific->ts.type != BT_UNKNOWN)
+ if (specific->ts.type != BT_UNKNOWN)
return gfc_convert_constant (expr->value.function.actual->expr,
- specific->ts.type, specific->ts.kind);
-
+ specific->ts.type, specific->ts.kind);
+
return gfc_copy_expr (expr->value.function.actual->expr);
}
return NULL;
/* Convert to the correct type and kind. */
- if (expr->ts.type != BT_UNKNOWN)
+ if (expr->ts.type != BT_UNKNOWN)
return gfc_convert_constant (extremum->expr,
expr->ts.type, expr->ts.kind);
- if (specific->ts.type != BT_UNKNOWN)
+ if (specific->ts.type != BT_UNKNOWN)
return gfc_convert_constant (extremum->expr,
- specific->ts.type, specific->ts.kind);
-
+ specific->ts.type, specific->ts.kind);
+
return gfc_copy_expr (extremum->expr);
}
}
gfc_set_model_kind (kind);
- mpfr_fmod (result->value.real, a->value.real, p->value.real,
+ mpfr_fmod (result->value.real, a->value.real, p->value.real,
GFC_RND_MODE);
break;
}
gfc_set_model_kind (kind);
- mpfr_fmod (result->value.real, a->value.real, p->value.real,
+ mpfr_fmod (result->value.real, a->value.real, p->value.real,
GFC_RND_MODE);
if (mpfr_cmp_ui (result->value.real, 0) != 0)
{
GFC_RND_MODE);
}
else
- mpfr_copysign (result->value.real, result->value.real,
+ mpfr_copysign (result->value.real, result->value.real,
p->value.real, GFC_RND_MODE);
break;
}
else if (mask->expr_type == EXPR_ARRAY)
{
- /* Copy only those elements of ARRAY to RESULT whose
+ /* Copy only those elements of ARRAY to RESULT whose
MASK equals .TRUE.. */
mask_ctor = gfc_constructor_first (mask->value.constructor);
while (mask_ctor)
if (e->expr_type != EXPR_CONSTANT)
return NULL;
- if (len ||
- (e->ts.u.cl->length &&
+ if (len ||
+ (e->ts.u.cl->length &&
mpz_sgn (e->ts.u.cl->length->value.integer)) != 0)
{
const char *res = gfc_extract_int (n, &ncop);
}
/* In the Fortran 95 standard, the result is b**(e - p) where b, e, and p
- are the radix, exponent of x, and precision. This excludes the
+ are the radix, exponent of x, and precision. This excludes the
possibility of subnormal numbers. Fortran 2003 states the result is
b**max(e - p, emin - 1). */
: mold;
/* Set result character length, if needed. Note that this needs to be
- set even for array expressions, in order to pass this information into
+ set even for array expressions, in order to pass this information into
gfc_target_interpret_expr. */
if (result->ts.type == BT_CHARACTER && gfc_is_constant_expr (mold_element))
result->value.character.length = mold_element->value.character.length;
-
+
/* Set the number of elements in the result, and determine its size. */
if (mold->expr_type == EXPR_ARRAY || mold->rank || size)
{
gfc_expr *e = gfc_constructor_lookup_expr (matrix->value.constructor,
col * matrix_rows + row);
- gfc_constructor_insert_expr (&result->value.constructor,
+ gfc_constructor_insert_expr (&result->value.constructor,
gfc_copy_expr (e), &matrix->where,
row * matrix_cols + col);
}
if (!sym)
return NULL;
+ if (sym->attr.unlimited_polymorphic)
+ return sym;
+
if (sym->attr.generic)
sym = gfc_find_dt_in_generic (sym);
bool is_derived1 = (ts1->type == BT_DERIVED);
bool is_derived2 = (ts2->type == BT_DERIVED);
+ if (is_class1
+ && ts1->u.derived->components
+ && ts1->u.derived->components->ts.u.derived->attr.unlimited_polymorphic)
+ return 1;
+
if (!is_derived1 && !is_derived2 && !is_class1 && !is_class2)
return (ts1->type == ts2->type);
binding label (mainly those that are bind(c)). */
if (sym->attr.is_bind_c == 1 && sym->binding_label)
return get_identifier (sym->binding_label);
-
+
if (sym->module == NULL)
return gfc_sym_identifier (sym);
else
tree value;
/* Parameters need to be dereferenced. */
- if (sym->cp_pointer->attr.dummy)
+ if (sym->cp_pointer->attr.dummy)
ptr_decl = build_fold_indirect_ref_loc (input_location,
ptr_decl);
/* Check to see if we're dealing with a variable-sized array. */
if (sym->attr.dimension
- && TREE_CODE (TREE_TYPE (decl)) == POINTER_TYPE)
- {
+ && TREE_CODE (TREE_TYPE (decl)) == POINTER_TYPE)
+ {
/* These decls will be dereferenced later, so we don't dereference
them here. */
value = convert (TREE_TYPE (decl), ptr_decl);
/* We should know the storage size. */
gcc_assert (DECL_SIZE (decl) != NULL_TREE
- || (TREE_STATIC (decl)
+ || (TREE_STATIC (decl)
? (!DECL_INITIAL (decl) || !DECL_CONTEXT (decl))
: DECL_EXTERNAL (decl)));
TREE_PUBLIC(decl) = 1;
DECL_COMMON(decl) = 1;
}
-
+
/* If a variable is USE associated, it's always external. */
if (sym->attr.use_assoc)
{
TREE_SIDE_EFFECTS (decl) = 1;
new_type = build_qualified_type (TREE_TYPE (decl), TYPE_QUAL_VOLATILE);
TREE_TYPE (decl) = new_type;
- }
+ }
/* Keep variables larger than max-stack-var-size off stack. */
if (!sym->ns->proc_name->attr.recursive
/* Do we know the element size? */
known_size = sym->ts.type != BT_CHARACTER
|| INTEGER_CST_P (sym->ts.u.cl->backend_decl);
-
+
if (known_size && !GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (type)))
{
/* For descriptorless arrays with known element size the actual
if (sym->attr.use_assoc)
DECL_IGNORED_P (decl) = 1;
}
-
+
if ((sym->ns->proc_name
&& sym->ns->proc_name->backend_decl == current_function_decl)
|| sym->attr.contained)
type = TREE_VALUE (typelist);
parm = build_decl (input_location,
PARM_DECL, get_identifier ("__entry"), type);
-
+
DECL_CONTEXT (parm) = fndecl;
DECL_ARG_TYPE (parm) = type;
TREE_READONLY (parm) = 1;
gfc_finish_decl (length);
/* Remember the passed value. */
- if (f->sym->ts.u.cl->passed_length != NULL)
+ if (!f->sym->ts.u.cl || f->sym->ts.u.cl->passed_length)
{
/* This can happen if the same type is used for multiple
arguments. We need to copy cl as otherwise
gcc_assert (GFC_TYPE_ARRAY_CAF_TOKEN (caf_type) == NULL_TREE);
GFC_TYPE_ARRAY_CAF_TOKEN (caf_type) = token;
}
-
+
DECL_CONTEXT (token) = fndecl;
DECL_ARTIFICIAL (token) = 1;
DECL_ARG_TYPE (token) = TREE_VALUE (typelist);
vec<tree, va_gc> *string_args = NULL;
thunk_sym = el->sym;
-
+
build_function_decl (thunk_sym, global);
create_function_arglist (thunk_sym);
tmp = fold_build3_loc (input_location, COMPONENT_REF,
TREE_TYPE (field), union_decl, field,
NULL_TREE);
- tmp = fold_build2_loc (input_location, MODIFY_EXPR,
+ tmp = fold_build2_loc (input_location, MODIFY_EXPR,
TREE_TYPE (DECL_RESULT (current_function_decl)),
DECL_RESULT (current_function_decl), tmp);
tmp = build1_v (RETURN_EXPR, tmp);
gfc_int4_type_node);
TREE_READONLY (gfor_fndecl_math_ishftc4) = 1;
TREE_NOTHROW (gfor_fndecl_math_ishftc4) = 1;
-
+
gfor_fndecl_math_ishftc8 = gfc_build_library_function_decl (
get_identifier (PREFIX("ishftc8")),
gfc_int8_type_node, 3, gfc_int8_type_node, gfc_int4_type_node,
void_type_node, -2, pchar_type_node, pchar_type_node);
/* The runtime_error_at function does not return. */
TREE_THIS_VOLATILE (gfor_fndecl_runtime_error_at) = 1;
-
+
gfor_fndecl_runtime_warning_at = gfc_build_library_function_decl_with_spec (
get_identifier (PREFIX("runtime_warning_at")), ".RR",
void_type_node, -2, pchar_type_node, pchar_type_node);
if (sym->ts.type == BT_CLASS)
{
/* Initialize _vptr to declared type. */
- gfc_symbol *vtab = gfc_find_derived_vtab (sym->ts.u.derived);
+ gfc_symbol *vtab;
tree rhs;
gfc_save_backend_locus (&loc);
se.want_pointer = 1;
gfc_conv_expr (&se, e);
gfc_free_expr (e);
- rhs = gfc_build_addr_expr (TREE_TYPE (se.expr),
- gfc_get_symbol_decl (vtab));
+ if (UNLIMITED_POLY (sym))
+ rhs = build_int_cst (TREE_TYPE (se.expr), 0);
+ else
+ {
+ vtab = gfc_find_derived_vtab (sym->ts.u.derived);
+ rhs = gfc_build_addr_expr (TREE_TYPE (se.expr),
+ gfc_get_symbol_decl (vtab));
+ }
gfc_add_modify (&init, se.expr, rhs);
gfc_restore_backend_locus (&loc);
}
gfc_add_init_cleanup (block, gfc_finish_block (&tmpblock),
NULL_TREE);
}
- else
+ else if (!(UNLIMITED_POLY(sym)))
gcc_unreachable ();
}
tree tmp, size, decl, token;
if (sym->attr.dummy || sym->attr.allocatable || !sym->attr.codimension
- || sym->attr.use_assoc || !sym->attr.referenced)
+ || sym->attr.use_assoc || !sym->attr.referenced)
return;
decl = sym->backend_decl;
size = TYPE_SIZE_UNIT (gfc_get_element_type (TREE_TYPE (decl)));
- /* Ensure that we do not have size=0 for zero-sized arrays. */
+ /* Ensure that we do not have size=0 for zero-sized arrays. */
size = fold_build2_loc (input_location, MAX_EXPR, size_type_node,
fold_convert (size_type_node, size),
build_int_cst (size_type_node, 1));
token, null_pointer_node, /* token, stat. */
null_pointer_node, /* errgmsg, errmsg_len. */
build_int_cst (integer_type_node, 0));
-
+
gfc_add_modify (&caf_init_block, decl, fold_convert (TREE_TYPE (decl), tmp));
{
if (gfc_option.warn_unused_dummy_argument)
gfc_warning ("Unused dummy argument '%s' at %L", sym->name,
- &sym->declared_at);
+ &sym->declared_at);
}
/* Silence bogus "unused parameter" warnings from the
/* Coarray: Call _gfortran_caf_finalize(void). */
if (gfc_option.coarray == GFC_FCOARRAY_LIB)
- {
+ {
/* Per F2008, 8.5.1 END of the main program implies a
- SYNC MEMORY. */
+ SYNC MEMORY. */
tmp = builtin_decl_explicit (BUILT_IN_SYNC_SYNCHRONIZE);
tmp = build_call_expr_loc (input_location, tmp, 0);
gfc_add_expr_to_block (&body, tmp);
static tree
conv_scalar_to_descriptor (gfc_se *se, tree scalar, symbol_attribute attr)
{
- tree desc, type;
+ tree desc, type;
type = get_scalar_to_descriptor_type (scalar, attr);
desc = gfc_create_var (type, "desc");
}
+/* Takes an intrinsic type expression and returns the address of a temporary
+ class object of the 'declared' type. */
+void
+gfc_conv_intrinsic_to_class (gfc_se *parmse, gfc_expr *e,
+ gfc_typespec class_ts)
+{
+ gfc_symbol *vtab;
+ gfc_ss *ss;
+ tree ctree;
+ tree var;
+ tree tmp;
+
+ /* The intrinsic 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. */
+ ctree = gfc_class_vptr_get (var);
+
+ vtab = gfc_find_intrinsic_vtab (&e->ts);
+ 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. */
+ ctree = gfc_class_data_get (var);
+ if (parmse->ss && parmse->ss->info->useflags)
+ {
+ /* For an array reference in an elemental procedure call we need
+ to retain the ss to provide the scalarized array reference. */
+ gfc_conv_expr_reference (parmse, e);
+ tmp = fold_convert (TREE_TYPE (ctree), parmse->expr);
+ gfc_add_modify (&parmse->pre, ctree, tmp);
+ }
+ else
+ {
+ ss = gfc_walk_expr (e);
+ if (ss == gfc_ss_terminator)
+ {
+ parmse->ss = NULL;
+ gfc_conv_expr_reference (parmse, e);
+ tmp = fold_convert (TREE_TYPE (ctree), parmse->expr);
+ gfc_add_modify (&parmse->pre, ctree, tmp);
+ }
+ else
+ {
+ parmse->ss = ss;
+ gfc_conv_expr_descriptor (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);
+}
+
+
/* Takes a scalarized class array expression and returns the
address of a temporary scalar class object of the 'declared'
- type.
+ type.
OOP-TODO: This could be improved by adding code that branched on
the dynamic type being the same as the declared type. In this case
the original class expression can be passed directly.
tmp = NULL_TREE;
if (class_ref == NULL
- && e->symtree && e->symtree->n.sym->ts.type == BT_CLASS)
+ && e->symtree && e->symtree->n.sym->ts.type == BT_CLASS)
tmp = e->symtree->n.sym->backend_decl;
else
{
gfc_conv_expr (&src, rhs);
gfc_conv_expr (&memsz, sz);
gfc_add_block_to_block (&block, &src.pre);
+ src.expr = gfc_build_addr_expr (NULL_TREE, src.expr);
+
tmp = gfc_build_memcpy_call (dst.expr, src.expr, memsz.expr);
}
}
gfc_add_expr_to_block (&block, tmp);
-
+
return gfc_finish_block (&block);
}
lhs = gfc_copy_expr (expr1);
gfc_add_vptr_component (lhs);
+ if (UNLIMITED_POLY (expr1)
+ && expr2->expr_type == EXPR_NULL && expr2->ts.type == BT_UNKNOWN)
+ {
+ rhs = gfc_get_null_expr (&expr2->where);
+ goto assign_vptr;
+ }
+
if (expr2->ts.type == BT_DERIVED)
vtab = gfc_find_derived_vtab (expr2->ts.u.derived);
else if (expr2->expr_type == EXPR_NULL)
vtab = gfc_find_derived_vtab (expr1->ts.u.derived);
+ else
+ vtab = gfc_find_intrinsic_vtab (&expr2->ts);
gcc_assert (vtab);
rhs = gfc_get_expr ();
gfc_find_sym_tree (vtab->name, vtab->ns, 1, &st);
rhs->symtree = st;
rhs->ts = vtab->ts;
-
+assign_vptr:
tmp = gfc_trans_pointer_assignment (lhs, rhs);
gfc_add_expr_to_block (&block, tmp);
gfc_free_expr (lhs);
gfc_free_expr (rhs);
}
+ else if (expr1->ts.type == BT_DERIVED && UNLIMITED_POLY (expr2))
+ {
+ /* F2003:C717 only sequence and bind-C types can come here. */
+ gcc_assert (expr1->ts.u.derived->attr.sequence
+ || expr1->ts.u.derived->attr.is_bind_c);
+ gfc_add_data_component (expr2);
+ goto assign;
+ }
else if (CLASS_DATA (expr2)->attr.dimension)
{
/* Insert an additional assignment which sets the '_vptr' field. */
tmp = gfc_get_int_type (kind);
tmp = fold_convert (tmp, build_fold_indirect_ref_loc (input_location,
se->expr));
-
+
/* Test for a NULL value. */
tmp = build3_loc (input_location, COND_EXPR, TREE_TYPE (tmp), present,
tmp, fold_convert (TREE_TYPE (tmp), integer_one_node));
gfc_ref *r;
tree length;
- gcc_assert (e->expr_type == EXPR_VARIABLE
+ gcc_assert (e->expr_type == EXPR_VARIABLE
&& e->ts.type == BT_CHARACTER);
-
+
length = NULL; /* To silence compiler warning. */
if (is_subref_array (e) && e->ts.u.cl->length)
{
case EXPR_OP:
- flatten_array_ctors_without_strlen (e->value.op.op1);
- flatten_array_ctors_without_strlen (e->value.op.op2);
+ flatten_array_ctors_without_strlen (e->value.op.op1);
+ flatten_array_ctors_without_strlen (e->value.op.op2);
break;
case EXPR_COMPCALL:
se_expr = gfc_get_fake_result_decl (sym, parent_flag);
/* Similarly for alternate entry points. */
- else if (alternate_entry
+ else if (alternate_entry
&& (sym->ns->proc_name->backend_decl == current_function_decl
|| parent_flag))
{
/* Dereference the expression, where needed. Since characters
- are entirely different from other types, they are treated
+ are entirely different from other types, they are treated
separately. */
if (sym->ts.type == BT_CHARACTER)
{
se->expr = build_fold_indirect_ref_loc (input_location,
se->expr);
- /* Dereference non-character pointer variables.
+ /* Dereference non-character pointer variables.
These must be dummies, results, or scalars. */
if ((sym->attr.pointer || sym->attr.allocatable
|| gfc_is_associate_pointer (sym)
124, 166, 125, 214, 126, 138, 127, 153, /* 248 - 255 */
};
-/* If n is larger than lookup table's max index, we use the "window
+/* If n is larger than lookup table's max index, we use the "window
method". */
#define POWI_WINDOW_SIZE 3
-/* Recursive function to expand the power operator. The temporary
+/* Recursive function to expand the power operator. The temporary
values are put in tmpvar. The function returns tmpvar[1] ** n. */
static tree
gfc_conv_powi (gfc_se * se, unsigned HOST_WIDE_INT n, tree * tmpvar)
/* There's no ABS for HOST_WIDE_INT, so here we go. It also takes care
of the asymmetric range of the integer type. */
n = (unsigned HOST_WIDE_INT) (m < 0 ? -m : m);
-
+
type = TREE_TYPE (lhs);
sgn = tree_int_cst_sgn (rhs);
case 4:
ikind = 0;
break;
-
+
case 8:
ikind = 1;
break;
case 4:
kind = 0;
break;
-
+
case 8:
kind = 1;
break;
default:
gcc_unreachable ();
}
-
+
switch (expr->value.op.op1->ts.type)
{
case BT_INTEGER:
case 0:
fndecl = builtin_decl_explicit (BUILT_IN_POWIF);
break;
-
+
case 1:
fndecl = builtin_decl_explicit (BUILT_IN_POWI);
break;
break;
case 3:
- /* Use the __builtin_powil() only if real(kind=16) is
+ /* Use the __builtin_powil() only if real(kind=16) is
actually the C long double type. */
if (!gfc_real16_is_float128)
fndecl = builtin_decl_explicit (BUILT_IN_POWIL);
}
}
- /* If we don't have a good builtin for this, go for the
+ /* If we don't have a good builtin for this, go for the
library function. */
if (!fndecl)
fndecl = gfor_fndecl_math_powi[kind][ikind].real;
(int)(*expr)->value.character.string[0]);
if ((*expr)->ts.kind != gfc_c_int_kind)
{
- /* The expr needs to be compatible with a C int. If the
+ /* The expr needs to be compatible with a C int. If the
conversion fails, then the 2 causes an ICE. */
ts.type = BT_INTEGER;
ts.kind = gfc_c_int_kind;
else if (!sym->attr.dimension || sym->attr.pointer || sym->attr.allocatable)
value = build_fold_indirect_ref_loc (input_location,
se->expr);
-
- /* For character(*), use the actual argument's descriptor. */
+
+ /* For character(*), use the actual argument's descriptor. */
else if (sym->ts.type == BT_CHARACTER && !new_sym->ts.u.cl->length)
value = build_fold_indirect_ref_loc (input_location,
se->expr);
rss = gfc_walk_expr (expr);
gcc_assert (rss != gfc_ss_terminator);
-
+
/* Initialize the scalarizer. */
gfc_init_loopinfo (&loop);
gfc_add_ss_to_loop (&loop, rss);
tmp = gfc_trans_scalar_assign (&lse, &rse, expr->ts, false, false, true);
gfc_add_expr_to_block (&body, tmp);
-
+
/* Generate the copying loops. */
gfc_trans_scalarizing_loops (&loop2, &body);
if (formal_ptr)
{
size = gfc_index_one_node;
- offset = gfc_index_zero_node;
+ offset = gfc_index_zero_node;
for (n = 0; n < dimen; n++)
{
tmp = gfc_conv_descriptor_ubound_get (parmse->expr,
&& !(fsym->attr.pointer || fsym->attr.allocatable)
&& fsym->as->type != AS_ASSUMED_SHAPE;
f = f || !sym->attr.always_explicit;
-
+
gfc_conv_array_parameter (se, arg->expr, f, NULL, NULL, NULL);
}
arg->expr->ts.f90_type = sym->ts.u.derived->ts.f90_type;
arg->expr->ts.kind = sym->ts.u.derived->ts.kind;
gfc_conv_expr_reference (se, arg->expr);
-
+
return 1;
}
else if (sym->intmod_sym_id == ISOCBINDING_F_POINTER
gfc_array_index_type, stride,
fold_convert (gfc_array_index_type,
shapese.expr)));
- /* Finish scalarization loop. */
+ /* Finish scalarization loop. */
gfc_trans_scalarizing_loops (&loop, &body);
gfc_add_block_to_block (&block, &loop.pre);
gfc_add_block_to_block (&block, &loop.post);
gfc_add_block_to_block (&block, &fptrse.post);
gfc_cleanup_loop (&loop);
- gfc_add_modify (&block, offset,
+ gfc_add_modify (&block, offset,
fold_build1_loc (input_location, NEGATE_EXPR,
gfc_array_index_type, offset));
gfc_conv_descriptor_offset_set (&block, desc, offset);
{
tree eq_expr;
tree not_null_expr;
-
+
/* Given two arguments so build the arg2se from second arg. */
gfc_init_se (&arg2se, NULL);
gfc_conv_expr (&arg2se, arg->next->expr);
return 1;
}
-
+
/* Nothing was done. */
return 0;
}
CLASS_DATA (fsym)->attr.class_pointer
|| CLASS_DATA (fsym)->attr.allocatable);
}
+ else if (UNLIMITED_POLY (fsym) && e->ts.type != BT_CLASS)
+ {
+ /* The intrinsic type needs to be converted to a temporary
+ CLASS object for the unlimited polymorphic formal. */
+ gfc_init_se (&parmse, se);
+ gfc_conv_intrinsic_to_class (&parmse, e, fsym->ts);
+ }
else if (se->ss && se->ss->info->useflags)
{
gfc_ss *ss;
= fold_build3_loc (input_location, COND_EXPR,
TREE_TYPE (parmse.expr),
gfc_unlikely (tmp),
- fold_convert (TREE_TYPE (parmse.expr),
+ fold_convert (TREE_TYPE (parmse.expr),
null_pointer_node),
parmse.expr);
}
CLASS_DATA (fsym)->attr.class_pointer
|| CLASS_DATA (fsym)->attr.allocatable);
- /* If an ALLOCATABLE dummy argument has INTENT(OUT) and is
+ /* If an ALLOCATABLE dummy argument has INTENT(OUT) and is
allocated on entry, it must be deallocated. */
if (fsym && fsym->attr.intent == INTENT_OUT
&& (fsym->attr.allocatable
gfc_init_block (&block);
ptr = parmse.expr;
if (e->ts.type == BT_CLASS)
- ptr = gfc_class_data_get (ptr);
+ ptr = gfc_class_data_get (ptr);
tmp = gfc_deallocate_with_status (ptr, NULL_TREE,
NULL_TREE, NULL_TREE,
/* If the argument is a function call that may not create
a temporary for the result, we have to check that we
- can do it, i.e. that there is no alias between this
+ can do it, i.e. that there is no alias between this
argument and another one. */
if (gfc_get_noncopying_intrinsic_argument (e) != NULL)
{
else
gfc_conv_array_parameter (&parmse, e, f, fsym, sym->name, NULL);
- /* If an ALLOCATABLE dummy argument has INTENT(OUT) and is
+ /* If an ALLOCATABLE dummy argument has INTENT(OUT) and is
allocated on entry, it must be deallocated. */
if (fsym && fsym->attr.allocatable
&& fsym->attr.intent == INTENT_OUT)
tmp, build_empty_stmt (input_location));
gfc_add_expr_to_block (&se->pre, tmp);
}
- }
+ }
}
/* The case with fsym->attr.optional is that of a user subroutine
&& ((e->rank != 0 && sym->attr.elemental)
|| e->representation.length || e->ts.type == BT_CHARACTER
|| (e->rank != 0
- && (fsym == NULL
+ && (fsym == NULL
|| (fsym-> as
&& (fsym->as->type == AS_ASSUMED_SHAPE
|| fsym->as->type == AS_ASSUMED_RANK
fold_convert (TREE_TYPE (tmp),
null_pointer_node));
}
-
+
gfc_trans_runtime_check (true, false, cond, &se->pre, &e->where,
msg);
free (msg);
}
/* Character strings are passed as two parameters, a length and a
- pointer - except for Bind(c) which only passes the pointer. */
- if (parmse.string_length != NULL_TREE && !sym->attr.is_bind_c)
+ pointer - except for Bind(c) which only passes the pointer.
+ An unlimited polymorphic formal argument likewise does not
+ need the length. */
+ if (parmse.string_length != NULL_TREE
+ && !sym->attr.is_bind_c
+ && !(fsym && UNLIMITED_POLY (fsym)))
+ vec_safe_push (stringargs, parmse.string_length);
+
+ /* When calling __copy for character expressions to unlimited
+ polymorphic entities, the dst argument needs a string length. */
+ if (sym->name[0] == '_' && e && e->ts.type == BT_CHARACTER
+ && strncmp (sym->name, "__vtab_CHARACTER", 16) == 0
+ && arg->next && arg->next->expr
+ && arg->next->expr->ts.type == BT_DERIVED
+ && arg->next->expr->ts.u.derived->attr.unlimited_polymorphic)
vec_safe_push (stringargs, parmse.string_length);
/* For descriptorless coarrays and assumed-shape coarray dummies, we
&& GFC_TYPE_ARRAY_CAF_TOKEN (caf_type) != NULL_TREE);
tmp = GFC_TYPE_ARRAY_CAF_TOKEN (caf_type);
}
-
+
vec_safe_push (stringargs, tmp);
if (GFC_DESCRIPTOR_TYPE_P (caf_type)
gfc_conv_expr (&parmse, ts.u.cl->length);
gfc_add_block_to_block (&se->pre, &parmse.pre);
gfc_add_block_to_block (&se->post, &parmse.post);
-
+
tmp = fold_convert (gfc_charlen_type_node, parmse.expr);
tmp = fold_build2_loc (input_location, MAX_EXPR,
gfc_charlen_type_node, tmp,
/* Build a static initializer. EXPR is the expression for the initial value.
- The other parameters describe the variable of the component being
+ The other parameters describe the variable of the component being
initialized. EXPR may be null. */
tree
gcc_assert (TREE_CODE (se.expr) != CONSTRUCTOR);
return se.expr;
}
-
+
if (array && !procptr)
{
tree ctor;
case BT_CLASS:
gfc_init_se (&se, NULL);
if (ts->type == BT_CLASS && expr->expr_type == EXPR_NULL)
- gfc_conv_structure (&se, gfc_class_null_initializer(ts), 1);
+ gfc_conv_structure (&se, gfc_class_null_initializer(ts, expr), 1);
else
gfc_conv_structure (&se, expr, 1);
gcc_assert (TREE_CODE (se.expr) == CONSTRUCTOR);
}
}
}
-
+
static tree
gfc_trans_subarray_assign (tree dest, gfc_component * cm, gfc_expr * expr)
{
cm->as->lower[n]->value.integer);
mpz_add_ui (lss_array->shape[n], lss_array->shape[n], 1);
}
-
+
/* Associate the SS with the loop. */
gfc_add_ss_to_loop (&loop, lss);
gfc_add_ss_to_loop (&loop, rss);
gfc_start_block (&block);
gfc_init_se (&se, NULL);
- /* Get the descriptor for the expressions. */
+ /* Get the descriptor for the expressions. */
se.want_pointer = 0;
gfc_conv_expr_descriptor (&se, expr);
gfc_add_block_to_block (&block, &se.pre);
{
/* NULL initialization for CLASS components. */
tmp = gfc_trans_structure_assign (dest,
- gfc_class_null_initializer (&cm->ts));
+ gfc_class_null_initializer (&cm->ts, expr));
gfc_add_expr_to_block (&block, tmp);
}
else if (cm->attr.dimension && !cm->attr.proc_pointer)
fold_convert (TREE_TYPE (lse.expr), se.expr));
return gfc_finish_block (&block);
- }
+ }
for (c = gfc_constructor_first (expr->value.constructor);
c; c = gfc_constructor_next (c), cm = cm->next)
if (!c->expr || (cm->attr.allocatable && cm->attr.flavor != FL_PROCEDURE))
continue;
- 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)
+ if (cm->initializer && cm->initializer->expr_type != EXPR_NULL
+ && strcmp (cm->name, "_extends") == 0
+ && cm->initializer->symtree)
{
tree vtab;
gfc_symbol *vtabs;
vtab = gfc_build_addr_expr (NULL_TREE, gfc_get_symbol_decl (vtabs));
CONSTRUCTOR_APPEND_ELT (v, cm->backend_decl, vtab);
}
+ else if (cm->ts.u.derived && 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
{
val = gfc_conv_initializer (c->expr, &cm->ts,
}
}
se->expr = build_constructor (type, v);
- if (init)
+ if (init)
TREE_CONSTANT (se->expr) = 1;
}
scalar = ss == gfc_ss_terminator;
if (!scalar)
gfc_free_ss_chain (ss);
-
+
if (scalar)
{
/* Scalar pointers. */
/* Functions returning pointers or allocatables need temporaries. */
c = expr2->value.function.esym
- ? (expr2->value.function.esym->attr.pointer
+ ? (expr2->value.function.esym->attr.pointer
|| expr2->value.function.esym->attr.allocatable)
: (expr2->symtree->n.sym->attr.pointer
|| expr2->symtree->n.sym->attr.allocatable);
correctly take care of the reallocation internally. For intrinsic
calls, the array data is freed and the library takes care of allocation.
TODO: Add logic of trans-array.c: gfc_alloc_allocatable_for_assignment
- to the library. */
+ to the library. */
if (gfc_option.flag_realloc_lhs
&& gfc_is_reallocatable_lhs (expr1)
&& !gfc_expr_attr (expr1).codimension
gfc_init_se (&lse, NULL);
lse.want_pointer = 1;
gfc_conv_expr (&lse, expr1);
-
+
jump_label1 = gfc_build_label_decl (NULL_TREE);
jump_label2 = gfc_build_label_decl (NULL_TREE);
gfc_expr *a, *b;
gfc_se se1, se2;
tree tmp;
+ tree conda = NULL_TREE, condb = NULL_TREE;
gfc_init_se (&se1, NULL);
gfc_init_se (&se2, NULL);
a = expr->value.function.actual->expr;
b = expr->value.function.actual->next->expr;
+ if (UNLIMITED_POLY (a))
+ {
+ tmp = gfc_class_vptr_get (a->symtree->n.sym->backend_decl);
+ conda = fold_build2_loc (input_location, NE_EXPR, boolean_type_node,
+ tmp, build_int_cst (TREE_TYPE (tmp), 0));
+ }
+
+ if (UNLIMITED_POLY (b))
+ {
+ tmp = gfc_class_vptr_get (b->symtree->n.sym->backend_decl);
+ condb = fold_build2_loc (input_location, NE_EXPR, boolean_type_node,
+ tmp, build_int_cst (TREE_TYPE (tmp), 0));
+ }
+
if (a->ts.type == BT_CLASS)
{
gfc_add_vptr_component (a);
gfc_conv_expr (&se1, a);
gfc_conv_expr (&se2, b);
- tmp = fold_build2_loc (input_location, EQ_EXPR, boolean_type_node,
- se1.expr, fold_convert (TREE_TYPE (se1.expr), se2.expr));
+ tmp = fold_build2_loc (input_location, EQ_EXPR,
+ boolean_type_node, se1.expr,
+ fold_convert (TREE_TYPE (se1.expr), se2.expr));
+
+ if (conda)
+ tmp = fold_build2_loc (input_location, TRUTH_ANDIF_EXPR,
+ boolean_type_node, conda, tmp);
+
+ if (condb)
+ tmp = fold_build2_loc (input_location, TRUTH_ANDIF_EXPR,
+ boolean_type_node, condb, tmp);
+
se->expr = convert (gfc_typenode_for_spec (&expr->ts), tmp);
}
if (e == NULL)
continue;
- /* Obtain the info structure for the current argument. */
+ /* Obtain the info structure for the current argument. */
for (ss = loopse->ss; ss && ss != gfc_ss_terminator; ss = ss->next)
if (ss->info->expr == e)
break;
gfc_add_ss_to_loop (&loop, ss);
gfc_conv_ss_startstride (&loop);
- /* TODO: gfc_conv_loop_setup generates a temporary for vector
- subscripts. This could be prevented in the elemental case
- as temporaries are handled separatedly
+ /* TODO: gfc_conv_loop_setup generates a temporary for vector
+ subscripts. This could be prevented in the elemental case
+ as temporaries are handled separatedly
(below in gfc_conv_elemental_dependencies). */
gfc_conv_loop_setup (&loop, &code->expr1->where);
gfc_mark_ss_chain_used (ss, 1);
? (gfc_option.coarray == GFC_FCOARRAY_LIB
? gfor_fndecl_caf_error_stop
: gfor_fndecl_error_stop_numeric)
- : gfor_fndecl_stop_numeric_f08, 1,
+ : gfor_fndecl_stop_numeric_f08, 1,
fold_convert (gfc_int4_type_node, se.expr));
}
else
/* Short cut: For single images without STAT= or LOCK_ACQUIRED
return early. (ERRMSG= is always untouched for -fcoarray=single.) */
if (!code->expr2 && !code->expr4 && gfc_option.coarray != GFC_FCOARRAY_LIB)
- return NULL_TREE;
+ return NULL_TREE;
gfc_init_se (&se, NULL);
gfc_start_block (&se.pre);
return early. (ERRMSG= is always untouched for -fcoarray=single.) */
if (!code->expr2 && !(gfc_option.rtcheck & GFC_RTCHECK_BOUNDS)
&& gfc_option.coarray != GFC_FCOARRAY_LIB)
- return NULL_TREE;
+ return NULL_TREE;
gfc_init_se (&se, NULL);
gfc_start_block (&se.pre);
{
if (TREE_TYPE (stat) == integer_type_node)
stat = gfc_build_addr_expr (NULL, stat);
-
+
tmp = build_call_expr_loc (input_location, gfor_fndecl_caf_sync_all,
3, stat, errmsg, errmsglen);
gfc_add_expr_to_block (&se.pre, tmp);
3, gfc_build_addr_expr (NULL, tmp_stat),
errmsg, errmsglen);
gfc_add_expr_to_block (&se.pre, tmp);
-
+
gfc_add_modify (&se.pre, stat,
fold_convert (TREE_TYPE (stat), tmp_stat));
}
if (TREE_TYPE (stat) == integer_type_node)
stat = gfc_build_addr_expr (NULL, stat);
- tmp = build_call_expr_loc (input_location, gfor_fndecl_caf_sync_images,
+ tmp = build_call_expr_loc (input_location, gfor_fndecl_caf_sync_images,
5, fold_convert (integer_type_node, len),
images, stat, errmsg, errmsglen);
gfc_add_expr_to_block (&se.pre, tmp);
{
tree tmp_stat = gfc_create_var (integer_type_node, "stat");
- tmp = build_call_expr_loc (input_location, gfor_fndecl_caf_sync_images,
+ tmp = build_call_expr_loc (input_location, gfor_fndecl_caf_sync_images,
5, fold_convert (integer_type_node, len),
images, gfc_build_addr_expr (NULL, tmp_stat),
errmsg, errmsglen);
gfc_add_expr_to_block (&se.pre, tmp);
- gfc_add_modify (&se.pre, stat,
+ gfc_add_modify (&se.pre, stat,
fold_convert (TREE_TYPE (stat), tmp_stat));
}
}
loc = code->expr1->where.lb ? code->expr1->where.lb->location : input_location;
stmt = fold_build3_loc (loc, COND_EXPR, void_type_node, if_se.expr, stmt,
elsestmt);
-
+
gfc_add_expr_to_block (&if_se.pre, stmt);
/* Finish off this statement. */
gfc_expr *e;
tree tmp;
bool class_target;
+ bool unlimited;
tree desc;
tree offset;
tree dim;
&& (gfc_is_class_scalar_expr (e)
|| gfc_is_class_array_ref (e, NULL));
+ unlimited = UNLIMITED_POLY (e);
+
/* Do a `pointer assignment' with updated descriptor (or assign descriptor
to array temporary) for arrays with either unknown shape or if associating
to a variable. */
gfc_finish_block (&se.post));
}
- /* Derived type temporaries, arising from TYPE IS, just need the
- descriptor of class arrays to be assigned directly. */
- else if (class_target && sym->ts.type == BT_DERIVED && sym->attr.dimension)
+ /* Temporaries, arising from TYPE IS, just need the descriptor of class
+ arrays to be assigned directly. */
+ else if (class_target && sym->attr.dimension
+ && (sym->ts.type == BT_DERIVED || unlimited))
{
gfc_se se;
gcc_assert (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (sym->backend_decl)));
gfc_add_modify (&se.pre, sym->backend_decl, se.expr);
-
+
+ if (unlimited)
+ {
+ /* Recover the dtype, which has been overwritten by the
+ assignment from an unlimited polymorphic object. */
+ tmp = gfc_conv_descriptor_dtype (sym->backend_decl);
+ gfc_add_modify (&se.pre, tmp,
+ gfc_get_dtype (TREE_TYPE (sym->backend_decl)));
+ }
+
gfc_add_init_cleanup (block, gfc_finish_block( &se.pre),
gfc_finish_block (&se.post));
}
/* For a class array we need a descriptor for the selector. */
gfc_conv_expr_descriptor (&se, e);
- /* Obtain a temporary class container for the result. */
+ /* Obtain a temporary class container for the result. */
gfc_conv_class_to_class (&se, e, sym->ts, false, true, false, false);
se.expr = build_fold_indirect_ref_loc (input_location, se.expr);
{
/* This is bound to be a class array element. */
gfc_conv_expr_reference (&se, e);
- /* Get the _vptr component of the class object. */
+ /* Get the _vptr component of the class object. */
tmp = gfc_get_vptr_from_expr (se.expr);
/* Obtain a temporary class container for the result. */
gfc_conv_derived_to_class (&se, e, sym->ts, tmp, false, false);
tmp = TREE_TYPE (sym->backend_decl);
tmp = gfc_build_addr_expr (tmp, se.expr);
gfc_add_modify (&se.pre, sym->backend_decl, tmp);
-
+
gfc_add_init_cleanup (block, gfc_finish_block( &se.pre),
gfc_finish_block (&se.post));
}
tmp = gfc_trans_assignment (lhs, e, false, true);
gfc_add_init_cleanup (block, tmp, NULL_TREE);
}
+
+ /* Set the stringlength from the vtable size. */
+ if (sym->ts.type == BT_CHARACTER && sym->attr.select_type_temporary)
+ {
+ tree charlen;
+ gfc_se se;
+ gfc_init_se (&se, NULL);
+ gcc_assert (UNLIMITED_POLY (e->symtree->n.sym));
+ tmp = gfc_get_symbol_decl (e->symtree->n.sym);
+ tmp = gfc_vtable_size_get (tmp);
+ gfc_get_symbol_decl (sym);
+ charlen = sym->ts.u.cl->backend_decl;
+ gfc_add_modify (&se.pre, charlen,
+ fold_convert (TREE_TYPE (charlen), tmp));
+ gfc_add_init_cleanup (block, gfc_finish_block( &se.pre),
+ gfc_finish_block (&se.post));
+ }
}
gfc_trans_deferred_vars (sym, &block);
for (ass = code->ext.block.assoc; ass; ass = ass->next)
trans_associate_var (ass->st->n.sym, &block);
-
+
return gfc_finish_wrapped_block (&block);
}
tree cycle_label;
tree exit_label;
location_t loc;
-
+
type = TREE_TYPE (dovar);
loc = code->ext.iterator->start->where.lb->location;
/* Initialize the DO variable: dovar = from. */
gfc_add_modify_loc (loc, pblock, dovar,
fold_convert (TREE_TYPE(dovar), from));
-
+
/* Save value for do-tinkering checking. */
if (gfc_option.rtcheck & GFC_RTCHECK_DO)
{
tmp = fold_build2_loc (loc, LT_EXPR, boolean_type_node, step,
build_int_cst (TREE_TYPE (step), 0));
- step_sign = fold_build3_loc (loc, COND_EXPR, type, tmp,
- build_int_cst (type, -1),
+ step_sign = fold_build3_loc (loc, COND_EXPR, type, tmp,
+ build_int_cst (type, -1),
build_int_cst (type, 1));
tmp = fold_build2_loc (loc, LT_EXPR, boolean_type_node, to, from);
if (INTEGER_CST_P (inner_size))
{
while (forall_tmp
- && !forall_tmp->mask
+ && !forall_tmp->mask
&& INTEGER_CST_P (forall_tmp->size))
{
inner_size = fold_build2_loc (input_location, MULT_EXPR,
for (n = 0; n < nvar; n++)
{
/* size = (end + step - start) / step. */
- tmp = fold_build2_loc (input_location, MINUS_EXPR, TREE_TYPE (start[n]),
+ tmp = fold_build2_loc (input_location, MINUS_EXPR, TREE_TYPE (start[n]),
step[n], start[n]);
tmp = fold_build2_loc (input_location, PLUS_EXPR, TREE_TYPE (end[n]),
end[n], tmp);
stmtblock_t body;
tree index, maskexpr;
- /* A defined assignment. */
+ /* A defined assignment. */
if (cnext && cnext->resolved_sym)
return gfc_trans_call (cnext, true, mask, count1, invert);
if (!gfc_array_allocate (&se, expr, stat, errmsg, errlen, label_finish,
memsz, &nelems, code->expr3))
{
+ bool unlimited_char;
+
+ unlimited_char = UNLIMITED_POLY (al->expr)
+ && ((code->expr3 && code->expr3->ts.type == BT_CHARACTER)
+ || (code->ext.alloc.ts.type == BT_CHARACTER
+ && code->ext.alloc.ts.u.cl
+ && code->ext.alloc.ts.u.cl->length));
+
/* A scalar or derived type. */
/* Determine allocate size. */
if (al->expr->ts.type == BT_CLASS
+ && !unlimited_char
&& code->expr3
&& memsz == NULL_TREE)
{
else
memsz = TYPE_SIZE_UNIT (gfc_typenode_for_spec (&code->expr3->ts));
}
- else if (al->expr->ts.type == BT_CHARACTER
- && al->expr->ts.deferred && code->expr3)
+ else if (((al->expr->ts.type == BT_CHARACTER && al->expr->ts.deferred)
+ || unlimited_char) && code->expr3)
{
if (!code->expr3->ts.u.cl->backend_decl)
{
memsz));
/* Convert to size in bytes, using the character KIND. */
+ if (unlimited_char)
+ tmp = TREE_TYPE (gfc_typenode_for_spec (&code->expr3->ts));
+ else
tmp = TREE_TYPE (gfc_typenode_for_spec (&al->expr->ts));
tmp = TYPE_SIZE_UNIT (tmp);
memsz = fold_build2_loc (input_location, MULT_EXPR,
TREE_TYPE (tmp), tmp,
fold_convert (TREE_TYPE (tmp), memsz));
}
- else if (al->expr->ts.type == BT_CHARACTER && al->expr->ts.deferred)
+ else if ((al->expr->ts.type == BT_CHARACTER && al->expr->ts.deferred)
+ || unlimited_char)
{
gcc_assert (code->ext.alloc.ts.u.cl && code->ext.alloc.ts.u.cl->length);
gfc_init_se (&se_sz, NULL);
}
else if (al->expr->ts.type == BT_CLASS)
{
- /* With class objects, it is best to play safe and null the
+ /* With class objects, it is best to play safe and null the
memory because we cannot know if dynamic types have allocatable
components or not. */
tmp = build_call_expr_loc (input_location,
build_empty_stmt (input_location));
gfc_add_expr_to_block (&block, tmp);
}
-
- /* We need the vptr of CLASS objects to be initialized. */
+
+ /* We need the vptr of CLASS objects to be initialized. */
e = gfc_copy_expr (al->expr);
if (e->ts.type == BT_CLASS)
{
ts = &code->expr3->ts;
else if (e->ts.type == BT_DERIVED)
ts = &e->ts;
- else if (code->ext.alloc.ts.type == BT_DERIVED)
+ else if (code->ext.alloc.ts.type == BT_DERIVED || UNLIMITED_POLY (al->expr))
ts = &code->ext.alloc.ts;
else if (e->ts.type == BT_CLASS)
ts = &CLASS_DATA (e)->ts;
else
ts = &e->ts;
- if (ts->type == BT_DERIVED)
+ if (ts->type == BT_DERIVED || UNLIMITED_POLY (e))
{
+ if (ts->type == BT_DERIVED)
vtab = gfc_find_derived_vtab (ts->u.derived);
+ else
+ vtab = gfc_find_intrinsic_vtab (ts);
gcc_assert (vtab);
gfc_init_se (&lse, NULL);
lse.want_pointer = 1;
ppc = gfc_copy_expr (rhs);
gfc_add_vptr_component (ppc);
}
- else
+ else if (rhs->ts.type == BT_DERIVED)
ppc = gfc_lval_expr_from_sym
(gfc_find_derived_vtab (rhs->ts.u.derived));
+ else
+ ppc = gfc_lval_expr_from_sym
+ (gfc_find_intrinsic_vtab (&rhs->ts));
gfc_add_component_ref (ppc, "_copy");
ppc_code = gfc_get_code ();
}
+/* Reset the vptr after deallocation. */
+
+static void
+reset_vptr (stmtblock_t *block, gfc_expr *e)
+{
+ gfc_expr *rhs, *lhs = gfc_copy_expr (e);
+ gfc_symbol *vtab;
+ tree tmp;
+
+ if (UNLIMITED_POLY (e))
+ rhs = gfc_get_null_expr (NULL);
+ else
+ {
+ vtab = gfc_find_derived_vtab (e->ts.u.derived);
+ rhs = gfc_lval_expr_from_sym (vtab);
+ }
+ gfc_add_vptr_component (lhs);
+ tmp = gfc_trans_pointer_assignment (lhs, rhs);
+ gfc_add_expr_to_block (block, tmp);
+ gfc_free_expr (lhs);
+ gfc_free_expr (rhs);
+}
+
+
/* Translate a DEALLOCATE statement. */
tree
tmp = gfc_array_deallocate (se.expr, pstat, errmsg, errlen,
label_finish, expr);
gfc_add_expr_to_block (&se.pre, tmp);
+ if (UNLIMITED_POLY (al->expr))
+ reset_vptr (&se.pre, al->expr);
}
else
{
se.expr,
build_int_cst (TREE_TYPE (se.expr), 0));
gfc_add_expr_to_block (&se.pre, tmp);
-
+
if (al->expr->ts.type == BT_CLASS)
- {
- /* Reset _vptr component to declared type. */
- gfc_expr *rhs, *lhs = gfc_copy_expr (al->expr);
- gfc_symbol *vtab = gfc_find_derived_vtab (al->expr->ts.u.derived);
- gfc_add_vptr_component (lhs);
- rhs = gfc_lval_expr_from_sym (vtab);
- tmp = gfc_trans_pointer_assignment (lhs, rhs);
- gfc_add_expr_to_block (&se.pre, tmp);
- gfc_free_expr (lhs);
- gfc_free_expr (rhs);
- }
+ reset_vptr (&se.pre, al->expr);
}
if (code->expr1)
tree canonical = NULL_TREE;
tree *chain = NULL;
bool got_canonical = false;
+ bool unlimited_entity = false;
gfc_component *c;
gfc_dt_list *dt;
gfc_namespace *ns;
+ if (derived->attr.unlimited_polymorphic)
+ return ptr_type_node;
+
if (derived && derived->attr.flavor == FL_PROCEDURE
&& derived->attr.generic)
derived = gfc_find_dt_in_generic (derived);
- gcc_assert (derived && derived->attr.flavor == FL_DERIVED);
-
/* See if it's one of the iso_c_binding derived types. */
if (derived->attr.is_iso_c == 1)
{
derived->backend_decl = typenode;
}
+ if (derived->components
+ && derived->components->ts.type == BT_DERIVED
+ && strcmp (derived->components->name, "_data") == 0
+ && derived->components->ts.u.derived->attr.unlimited_polymorphic)
+ unlimited_entity = true;
+
/* Go through the derived type components, building them as
necessary. The reason for doing this now is that it is
possible to recurse back to this derived type through a
!c->attr.target);
}
else if ((c->attr.pointer || c->attr.allocatable)
- && !c->attr.proc_pointer)
+ && !c->attr.proc_pointer
+ && !(unlimited_entity && c == derived->components))
field_type = build_pointer_type (field_type);
if (c->attr.pointer)
field_type = gfc_nonrestricted_type (field_type);
/* vtype fields can point to different types to the base type. */
- if (c->ts.type == BT_DERIVED && c->ts.u.derived->attr.vtype)
+ if (c->ts.type == BT_DERIVED
+ && c->ts.u.derived && c->ts.u.derived->attr.vtype)
field_type = build_pointer_type_for_mode (TREE_TYPE (field_type),
ptr_mode, true);
/* Code translation -- generate GCC trees from gfc_code.
- Copyright (C) 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009, 2010, 2012
- Free Software Foundation, Inc.
+ Copyright (C) 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009, 2010,
+ 2012 Free Software Foundation, Inc.
Contributed by Paul Brook
This file is part of GCC.
gfc_create_var_np (tree type, const char *prefix)
{
tree t;
-
+
t = create_tmp_var_raw (type, prefix);
/* No warnings for anonymous variables. */
}
-/* Build a MODIFY_EXPR node and add it to a given statement block PBLOCK.
+/* Build a MODIFY_EXPR node and add it to a given statement block PBLOCK.
A MODIFY_EXPR is an assignment:
LHS <- RHS. */
arg = gfc_build_addr_expr (pchar_type_node,
gfc_build_localized_cstring_const (message));
free (message);
-
+
asprintf (&message, "%s", _(msgid));
arg2 = gfc_build_addr_expr (pchar_type_node,
gfc_build_localized_cstring_const (message));
argarray[1] = arg2;
for (i = 0; i < nargs; i++)
argarray[2 + i] = va_arg (ap, tree);
-
+
/* Build the function call to runtime_(warning,error)_at; because of the
variable number of arguments, we can't use build_call_expr_loc dinput_location,
irectly. */
/* Allocate memory, using an optional status argument.
-
+
This function follows the following pseudo-code:
void *
allocate (size_t size, integer_type stat)
{
void *newmem;
-
+
if (stat requested)
stat = 0;
/* Allocate memory, using an optional status argument.
-
+
This function follows the following pseudo-code:
void *
/* Generate code for an ALLOCATE statement when the argument is an
allocatable variable. If the variable is currently allocated, it is an
error to allocate it again.
-
+
This function follows the following pseudo-code:
-
+
void *
allocate_allocatable (void *mem, size_t size, integer_type stat)
{
runtime_error ("Attempting to allocate already allocated variable");
}
}
-
+
expr must be set to the original expression being allocated for its locus
and variable name in case a runtime error has to be printed. */
void
even when no status variable is passed to us (this is used for
unconditional deallocation generated by the front-end at end of
each procedure).
-
+
If a runtime-message is possible, `expr' must point to the original
expression being deallocated for its locus and variable name.
/* When POINTER is not NULL, we free it. */
gfc_start_block (&non_null);
-
+
/* Free allocatable components. */
if (ts.type == BT_DERIVED && ts.u.derived->attr.alloc_comp)
{
tmp, 0);
gfc_add_expr_to_block (&non_null, tmp);
}
-
+
tmp = build_call_expr_loc (input_location,
builtin_decl_explicit (BUILT_IN_FREE), 1,
fold_convert (pvoid_type_node, pointer));
case EXEC_POINTER_ASSIGN:
if (code->expr1->ts.type == BT_CLASS)
res = gfc_trans_class_assign (code->expr1, code->expr2, code->op);
+ else if (UNLIMITED_POLY (code->expr2)
+ && code->expr1->ts.type == BT_DERIVED
+ && (code->expr1->ts.u.derived->attr.sequence
+ || code->expr1->ts.u.derived->attr.is_bind_c))
+ /* F2003: C717 */
+ res = gfc_trans_class_assign (code->expr1, code->expr2, code->op);
else
res = gfc_trans_pointer_assign (code);
break;
{
if (TREE_CODE (res) != STATEMENT_LIST)
SET_EXPR_LOCATION (res, input_location);
-
+
/* Add the new statement to the block. */
gfc_add_expr_to_block (&block, res);
}
if (block->cleanup)
result = build2_loc (input_location, TRY_FINALLY_EXPR, void_type_node,
result, block->cleanup);
-
+
/* Clear the block. */
block->init = NULL_TREE;
block->code = NULL_TREE;
+2012-12-19 Paul Thomas <pault@gcc.gnu.org>
+
+ * gfortran.dg/unlimited_polymorphic_1.f03: New test.
+ * gfortran.dg/unlimited_polymorphic_2.f03: New test.
+ * gfortran.dg/unlimited_polymorphic_3.f03: New test.
+ * gfortran.dg/same_type_as.f03: Correct for improved message.
+
2012-12-19 Kyrylo Tkachov <kyrylo.tkachov@arm.com>
* gcc.target/arm/vmaxnmdf.c: New test.
--- /dev/null
+! { dg-do run }\r
+!\r
+! Basic tests of functionality of unlimited polymorphism\r
+!\r
+! Contributed by Paul Thomas <pault@gcc.gnu.org>\r
+!\r
+MODULE m\r
+ TYPE :: a\r
+ integer :: i\r
+ END TYPE\r
+\r
+contains\r
+ subroutine bar (arg, res)\r
+ class(*) :: arg\r
+ character(100) :: res\r
+ select type (w => arg)\r
+ type is (a)\r
+ write (res, '(a, I4)') "type(a)", w%i\r
+ type is (integer)\r
+ write (res, '(a, I4)') "integer", w\r
+ type is (real(4))\r
+ write (res, '(a, F4.1)') "real4", w\r
+ type is (real(8))\r
+ write (res, '(a, F4.1)') "real8", w\r
+ type is (character(*, kind = 4))\r
+ call abort\r
+ type is (character(*))\r
+ write (res, '(a, I2, a, a)') "char(", LEN(w), ")", trim(w)\r
+ end select\r
+ end subroutine\r
+\r
+ subroutine foo (arg, res)\r
+ class(*) :: arg (:)\r
+ character(100) :: res\r
+ select type (w => arg)\r
+ type is (a)\r
+ write (res,'(a, 10I4)') "type(a) array", w%i\r
+ type is (integer)\r
+ write (res,'(a, 10I4)') "integer array", w\r
+ type is (real)\r
+ write (res,'(a, 10F4.1)') "real array", w\r
+ type is (character(*))\r
+ write (res, '(a5, I2, a, I2, a1, 2(a))') &\r
+ "char(",len(w),",", size(w,1),") array ", w\r
+ end select\r
+ end subroutine\r
+END MODULE\r
+\r
+\r
+ USE m\r
+ TYPE(a), target :: obj1 = a(99)\r
+ TYPE(a), target :: obj2(3) = a(999)\r
+ integer, target :: obj3 = 999\r
+ real(4), target :: obj4(4) = [(real(i), i = 1, 4)]\r
+ integer, target :: obj5(3) = [(i*99, i = 1, 3)]\r
+ class(*), pointer :: u1\r
+ class(*), pointer :: u2(:)\r
+ class(*), allocatable :: u3\r
+ class(*), allocatable :: u4(:)\r
+ type(a), pointer :: aptr(:)\r
+ character(8) :: sun = "sunshine"\r
+ character(100) :: res\r
+\r
+ ! NULL without MOLD used to cause segfault\r
+ u2 => NULL()\r
+ u2 => NULL(aptr)\r
+\r
+! Test pointing to derived types.\r
+ u1 => obj1\r
+ if (SAME_TYPE_AS (obj1, u1) .neqv. .TRUE.) call abort\r
+ u2 => obj2\r
+ call bar (u1, res)\r
+ if (trim (res) .ne. "type(a) 99") call abort\r
+\r
+ call foo (u2, res)\r
+ if (trim (res) .ne. "type(a) array 999 999 999") call abort\r
+\r
+ if (SAME_TYPE_AS (obj1, u1) .neqv. .TRUE.) call abort\r
+\r
+! Check allocate with an array SOURCE.\r
+ allocate (u2(5), source = [(a(i), i = 1,5)])\r
+ if (SAME_TYPE_AS (u1, a(2)) .neqv. .TRUE.) call abort\r
+ call foo (u2, res)\r
+ if (trim (res) .ne. "type(a) array 1 2 3 4 5") call abort\r
+\r
+ deallocate (u2)\r
+\r
+! Point to intrinsic targets.\r
+ u1 => obj3\r
+ call bar (u1, res)\r
+ if (trim (res) .ne. "integer 999") call abort\r
+\r
+ u2 => obj4\r
+ call foo (u2, res)\r
+ if (trim (res) .ne. "real array 1.0 2.0 3.0 4.0") call abort\r
+\r
+ u2 => obj5\r
+ call foo (u2, res)\r
+ if (trim (res) .ne. "integer array 99 198 297") call abort\r
+\r
+! Test allocate with source.\r
+ allocate (u1, source = sun)\r
+ call bar (u1, res)\r
+ if (trim (res) .ne. "char( 8)sunshine") call abort\r
+ deallocate (u1)\r
+\r
+ allocate (u2(3), source = [7,8,9])\r
+ call foo (u2, res)\r
+ if (trim (res) .ne. "integer array 7 8 9") call abort\r
+\r
+ deallocate (u2)\r
+\r
+ if (EXTENDS_TYPE_OF (obj1, u2) .neqv. .TRUE.) call abort\r
+ if (EXTENDS_TYPE_OF (u2, obj1) .neqv. .FALSE.) call abort\r
+\r
+ allocate (u2(3), source = [5.0,6.0,7.0])\r
+ call foo (u2, res)\r
+ if (trim (res) .ne. "real array 5.0 6.0 7.0") call abort\r
+\r
+ if (EXTENDS_TYPE_OF (obj1, u2) .neqv. .FALSE.) call abort\r
+ if (EXTENDS_TYPE_OF (u2, obj1) .neqv. .FALSE.) call abort\r
+ deallocate (u2)\r
+\r
+! Check allocate with a MOLD tag.\r
+ allocate (u2(3), mold = 8.0)\r
+ call foo (u2, res)\r
+ if (res(1:10) .ne. "real array") call abort\r
+ deallocate (u2)\r
+\r
+! Test passing an intrinsic type to a CLASS(*) formal.\r
+ call bar(1, res)\r
+ if (trim (res) .ne. "integer 1") call abort\r
+\r
+ call bar(2.0, res)\r
+ if (trim (res) .ne. "real4 2.0") call abort\r
+\r
+ call bar(2d0, res)\r
+ if (trim (res) .ne. "real8 2.0") call abort\r
+\r
+ call bar(a(3), res)\r
+ if (trim (res) .ne. "type(a) 3") call abort\r
+\r
+ call bar(sun, res)\r
+ if (trim (res) .ne. "char( 8)sunshine") call abort\r
+\r
+ call bar (obj3, res)\r
+ if (trim (res) .ne. "integer 999") call abort\r
+\r
+ call foo([4,5], res)\r
+ if (trim (res) .ne. "integer array 4 5") call abort\r
+\r
+ call foo([6.0,7.0], res)\r
+ if (trim (res) .ne. "real array 6.0 7.0") call abort\r
+\r
+ call foo([a(8),a(9)], res)\r
+ if (trim (res) .ne. "type(a) array 8 9") call abort\r
+\r
+ call foo([sun, " & rain"], res)\r
+ if (trim (res) .ne. "char( 8, 2)sunshine & rain") call abort\r
+\r
+ call foo([sun//" never happens", " & rain always happens"], res)\r
+ if (trim (res) .ne. "char(22, 2)sunshine never happens & rain always happens") call abort\r
+\r
+ call foo (obj4, res)\r
+ if (trim (res) .ne. "real array 1.0 2.0 3.0 4.0") call abort\r
+\r
+ call foo (obj5, res)\r
+ if (trim (res) .ne. "integer array 99 198 297") call abort\r
+\r
+! Allocatable entities\r
+ if (EXTENDS_TYPE_OF (obj1, u3) .neqv. .TRUE.) call abort\r
+ if (EXTENDS_TYPE_OF (u3, obj1) .neqv. .FALSE.) call abort\r
+ if (EXTENDS_TYPE_OF (obj1, u4) .neqv. .TRUE.) call abort\r
+ if (EXTENDS_TYPE_OF (u4, obj1) .neqv. .FALSE.) call abort\r
+\r
+ allocate (u3, source = 2.4)\r
+ call bar (u3, res)\r
+ if (trim (res) .ne. "real4 2.4") call abort\r
+\r
+ allocate (u4(2), source = [a(88), a(99)])\r
+ call foo (u4, res)\r
+ if (trim (res) .ne. "type(a) array 88 99") call abort\r
+\r
+ if (EXTENDS_TYPE_OF (obj1, u3) .neqv. .FALSE.) call abort\r
+ if (EXTENDS_TYPE_OF (u3, obj1) .neqv. .FALSE.) call abort\r
+\r
+ deallocate (u3)\r
+ if (EXTENDS_TYPE_OF (obj1, u3) .neqv. .TRUE.) call abort\r
+ if (EXTENDS_TYPE_OF (u3, obj1) .neqv. .FALSE.) call abort\r
+\r
+ if (EXTENDS_TYPE_OF (obj1, u4) .neqv. .TRUE.) call abort\r
+ if (EXTENDS_TYPE_OF (u4, obj1) .neqv. .TRUE.) call abort\r
+ deallocate (u4)\r
+ if (EXTENDS_TYPE_OF (obj1, u4) .neqv. .TRUE.) call abort\r
+ if (EXTENDS_TYPE_OF (u4, obj1) .neqv. .FALSE.) call abort\r
+\r
+\r
+! Check assumed rank calls\r
+ call foobar (u3, 0)\r
+ call foobar (u4, 1)\r
+contains\r
+\r
+ subroutine foobar (arg, ranki)\r
+ class(*) :: arg (..)\r
+ integer :: ranki\r
+ integer i\r
+ i = rank (arg)\r
+ if (i .ne. ranki) call abort\r
+ end subroutine\r
+\r
+END\r
--- /dev/null
+! { dg-do compile }\r
+!\r
+! Test the most important constraints unlimited polymorphic entities\r
+!\r
+! Contributed by Paul Thomas <pault@gcc.gnu.org>\r
+! and Tobias Burnus <burnus@gcc.gnu.org>\r
+!\r
+ CHARACTER(:), allocatable, target :: chr ! { dg-error "TODO: Deferred character length variable" }\r
+! F2008: C5100\r
+ integer :: i(2)\r
+ logical :: flag\r
+ class(*), pointer :: u1, u2(:) ! { dg-error "cannot appear in COMMON" }\r
+ common u1\r
+ u1 => chr\r
+! F2003: C625\r
+ allocate (u1) ! { dg-error "requires either a type-spec or SOURCE tag" }\r
+ allocate (u1, mold = 1.0) ! { dg-error "requires either a type-spec or SOURCE tag" }\r
+ allocate (real :: u1)\r
+ Allocate (u1, source = 1.0)\r
+\r
+! F2008: C4106\r
+ u2 = [u1] ! { dg-error "shall not be unlimited polymorphic" }\r
+\r
+ i = u2 ! { dg-error "Can\\'t convert CLASS\\(\\*\\)" }\r
+\r
+! Repeats same_type_as_1.f03 for unlimited polymorphic u2\r
+ flag = same_type_as (i, u2) ! { dg-error "cannot be of type INTEGER" }\r
+ flag = extends_type_of (i, u2) ! { dg-error "cannot be of type INTEGER" }\r
+\r
+contains\r
+\r
+! C717 (R735) If data-target is unlimited polymorphic,\r
+! data-pointer-object shall be unlimited polymorphic, of a sequence\r
+! derived type, or of a type with the BIND attribute.\r
+!\r
+ subroutine bar\r
+\r
+ type sq\r
+ sequence\r
+ integer :: i\r
+ end type sq\r
+\r
+ type(sq), target :: x\r
+ class(*), pointer :: y\r
+ integer, pointer :: tgt\r
+\r
+ x%i = 42\r
+ y => x\r
+ call foo (y)\r
+\r
+ y => tgt ! This is OK, of course.\r
+ tgt => y ! { dg-error "must be unlimited polymorphic" }\r
+\r
+ select type (y) ! This is the correct way to accomplish the previous\r
+ type is (integer)\r
+ tgt => y\r
+ end select\r
+\r
+ end subroutine bar\r
+\r
+\r
+ subroutine foo(tgt)\r
+ class(*), pointer, intent(in) :: tgt\r
+ type t\r
+ sequence\r
+ integer :: k\r
+ end type t\r
+\r
+ type(t), pointer :: ptr\r
+\r
+ ptr => tgt ! C717 allows this.\r
+\r
+ select type (tgt)\r
+! F03:C815 or F08:C839\r
+ type is (t) ! { dg-error "shall not specify a sequence derived type" }\r
+ ptr => tgt ! { dg-error "Expected TYPE IS" }\r
+ end select\r
+\r
+ print *, ptr%k\r
+ end subroutine foo\r
+END\r
--- /dev/null
+! { dg-do run }
+!
+! Check that pointer assignments allowed by F2003:C717
+! work and check null initialization of CLASS(*) pointers.
+!
+! Contributed by Tobias Burnus <burnus@gcc.gnu.org>
+!
+program main
+ interface
+ subroutine foo(z)
+ class(*), pointer, intent(in) :: z
+ end subroutine foo
+ end interface
+ type sq
+ sequence
+ integer :: i
+ end type sq
+ type(sq), target :: x
+ class(*), pointer :: y, z
+ x%i = 42
+ y => x
+ z => y ! unlimited => unlimited allowed
+ call foo (z)
+ call bar
+contains
+ subroutine bar
+ type t
+ end type t
+ type(t), pointer :: x
+ class(*), pointer :: ptr1 => null() ! pointer initialization
+ class(*), pointer :: ptr2 => null(x) ! pointer initialization
+ if (same_type_as (ptr1, x) .neqv. .FALSE.) call abort
+ if (same_type_as (ptr2, x) .neqv. .TRUE.) call abort
+ end subroutine bar
+
+end program main
+
+
+subroutine foo(tgt)
+ use iso_c_binding
+ class(*), pointer, intent(in) :: tgt
+ type, bind(c) :: s
+ integer (c_int) :: k
+ end type s
+ type t
+ sequence
+ integer :: k
+ end type t
+ type(s), pointer :: ptr1
+ type(t), pointer :: ptr2
+ ptr1 => tgt ! bind(c) => unlimited allowed
+ if (ptr1%k .ne. 42) call abort
+ ptr2 => tgt ! sequence type => unlimited allowed
+ if (ptr2%k .ne. 42) call abort
+end subroutine foo
+2012-12-19 Paul Thomas <pault@gcc.gnu.org>
+
+ * intrinsics/extends_type_of.c : Return correct results for
+ null vptrs.
+
2012-12-03 Janus Weil <janus@gcc.gnu.org>
PR fortran/55548
GFC_LOGICAL_4
is_extension_of (struct vtype *v1, struct vtype *v2)
{
+ /* Assume that only unlimited polymorphic entities will pass NULL v1 or v2
+ if they are unallocated or disassociated. */
+
+ if (!v2)
+ return 1;
+ if (!v1)
+ return 0;
+
while (v1)
{
if (v1->hash == v2->hash) return 1;
projects / thirdparty / gcc.git / commitdiff
