procyberian/gcc
1
0
Fork 0
Code Issues Pull requests Projects Releases Packages Wiki Activity Actions

array.c (resolve_array_list): Apply C4106.

Browse source 
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  Paul Thomas  <pault@gcc.gnu.org>

	* intrinsics/extends_type_of.c : Return correct results for
	null vptrs.

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.

From-SVN: r194622
This commit is contained in:
Paul Thomas 2012-12-20 00:15:00 +00:00
parent 26c08c0323
commit 8b7043164f
26 changed files with 1665 additions and 394 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

121
gcc/fortran/ChangeLog
View file

@ -1,3 +1,122 @@
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
@ -51,7 +170,7 @@
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>

17
gcc/fortran/array.c
View file

@ -557,7 +557,7 @@ gfc_match_array_spec (gfc_array_spec **asp, bool match_dim, bool match_codim)
goto cleanup;
case AS_ASSUMED_RANK:
gcc_unreachable ();
gcc_unreachable ();
}
if (gfc_match_char (')') == MATCH_YES)
@ -666,7 +666,7 @@ coarray:
goto cleanup;
case AS_ASSUMED_RANK:
gcc_unreachable ();
gcc_unreachable ();
}
if (gfc_match_char (']') == MATCH_YES)
@ -1414,7 +1414,7 @@ extract_element (gfc_expr *e)
gfc_free_expr (e);
current_expand.extract_count++;
return SUCCESS;
}
@ -1815,7 +1815,7 @@ resolve_array_list (gfc_constructor_base base)
{
gfc_symbol *iter_var;
locus iter_var_loc;
if (gfc_resolve_iterator (iter, false, true) == FAILURE)
t = FAILURE;
@ -1847,6 +1847,13 @@ resolve_array_list (gfc_constructor_base base)
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;
@ -1941,7 +1948,7 @@ got_charlen:
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. */

59
gcc/fortran/check.c
View file

@ -225,7 +225,7 @@ coarray_check (gfc_expr *e, int n)
}
return SUCCESS;
}
}
/* Make sure the expression is a logical array. */
@ -304,7 +304,7 @@ less_than_bitsize1 (const char *arg1, gfc_expr *expr1, const char *arg2,
{
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)
{
@ -355,7 +355,7 @@ less_than_bitsizekind (const char *arg, gfc_expr *expr, int k)
if (expr->expr_type != EXPR_CONSTANT)
return SUCCESS;
i = gfc_validate_kind (BT_INTEGER, k, false);
gfc_extract_int (expr, &val);
@ -510,7 +510,7 @@ variable_check (gfc_expr *e, int n, bool allow_proc)
|| (ref->u.c.component->ts.type != BT_CLASS
&& ref->u.c.component->attr.pointer)))
break;
}
}
if (!ref)
{
@ -575,7 +575,7 @@ dim_corank_check (gfc_expr *dim, gfc_expr *array)
if (dim->expr_type != EXPR_CONSTANT)
return SUCCESS;
if (array->ts.type == BT_CLASS)
return SUCCESS;
@ -668,7 +668,7 @@ identical_dimen_shape (gfc_expr *a, int ai, gfc_expr *b, int bi)
{
if (mpz_cmp (a_size, b_size) != 0)
ret = 0;
mpz_clear (b_size);
}
mpz_clear (a_size);
@ -841,7 +841,7 @@ gfc_check_allocated (gfc_expr *array)
return FAILURE;
if (allocatable_check (array, 0) == FAILURE)
return FAILURE;
return SUCCESS;
}
@ -1881,7 +1881,7 @@ gfc_check_ichar_iachar (gfc_expr *c, gfc_expr *kind)
return SUCCESS;
i = mpz_get_si (c->ts.u.cl->length->value.integer);
}
else
else
return SUCCESS;
}
else
@ -1903,7 +1903,7 @@ gfc_check_ichar_iachar (gfc_expr *c, gfc_expr *kind)
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;
}
@ -2037,7 +2037,7 @@ gfc_check_ishftc (gfc_expr *i, gfc_expr *shift, gfc_expr *size)
|| type_check (shift, 1, BT_INTEGER) == FAILURE)
return FAILURE;
if (size != NULL)
if (size != NULL)
{
int i2, i3;
@ -3081,7 +3081,7 @@ gfc_check_rank (gfc_expr *a ATTRIBUTE_UNUSED)
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;
@ -3269,7 +3269,7 @@ gfc_check_reshape (gfc_expr *source, gfc_expr *shape,
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);
@ -3287,7 +3287,7 @@ gfc_check_reshape (gfc_expr *source, gfc_expr *shape,
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;
@ -3319,7 +3319,7 @@ gfc_check_reshape (gfc_expr *source, gfc_expr *shape,
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))
@ -3346,17 +3346,17 @@ gfc_check_reshape (gfc_expr *source, gfc_expr *shape,
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",
@ -3367,14 +3367,15 @@ gfc_check_same_type_as (gfc_expr *a, gfc_expr *b)
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",
@ -3688,7 +3689,7 @@ gfc_check_spread (gfc_expr *source, gfc_expr *dim, gfc_expr *ncopies)
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))
@ -4233,7 +4234,7 @@ gfc_check_unpack (gfc_expr *vector, gfc_expr *mask, gfc_expr *field)
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;
@ -4246,7 +4247,7 @@ gfc_check_unpack (gfc_expr *vector, gfc_expr *mask, gfc_expr *field)
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);

363
gcc/fortran/class.c
View file

@ -1,5 +1,5 @@
/* 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>
@ -55,7 +55,6 @@ along with GCC; see the file COPYING3. If not see
#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
@ -237,7 +236,7 @@ gfc_add_class_array_ref (gfc_expr *e)
ref = ref->next;
ref->type = REF_ARRAY;
ref->u.ar.type = AR_FULL;
ref->u.ar.as = as;
ref->u.ar.as = as;
}
}
@ -389,7 +388,7 @@ gfc_is_class_container_ref (gfc_expr *e)
if (ref->type != REF_COMPONENT)
result = false;
else if (ref->u.c.component->ts.type == BT_CLASS)
result = true;
result = true;
else
result = false;
}
@ -403,20 +402,31 @@ gfc_is_class_container_ref (gfc_expr *e)
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);
@ -434,9 +444,14 @@ static void
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);
@ -475,10 +490,30 @@ gfc_hash_value (gfc_symbol *sym)
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];
@ -501,6 +536,7 @@ gfc_build_class_symbol (gfc_typespec *ts, symbol_attribute *attr,
gfc_symbol *fclass;
gfc_symbol *vtab;
gfc_component *c;
gfc_namespace *ns;
int rank;
gcc_assert (as);
@ -518,7 +554,7 @@ gfc_build_class_symbol (gfc_typespec *ts, symbol_attribute *attr,
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;
@ -539,17 +575,28 @@ gfc_build_class_symbol (gfc_typespec *ts, symbol_attribute *attr,
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,
@ -569,7 +616,7 @@ gfc_build_class_symbol (gfc_typespec *ts, symbol_attribute *attr,
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;
@ -591,17 +638,21 @@ gfc_build_class_symbol (gfc_typespec *ts, symbol_attribute *attr,
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;
@ -620,7 +671,7 @@ add_proc_comp (gfc_symbol *vtype, const char *name, gfc_typebound_proc *tb)
if (tb->non_overridable)
return;
c = gfc_find_component (vtype, name, true, true);
if (c == NULL)
@ -670,7 +721,7 @@ add_procs_to_declared_vtab1 (gfc_symtree *st, gfc_symbol *vtype)
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);
}
@ -1766,15 +1817,15 @@ gfc_find_derived_vtab (gfc_symbol *derived)
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];
@ -1844,7 +1895,11 @@ gfc_find_derived_vtab (gfc_symbol *derived)
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);
@ -1862,7 +1917,9 @@ gfc_find_derived_vtab (gfc_symbol *derived)
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. */
@ -1878,7 +1935,8 @@ gfc_find_derived_vtab (gfc_symbol *derived)
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
{
@ -1905,7 +1963,8 @@ gfc_find_derived_vtab (gfc_symbol *derived)
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
{
@ -1966,7 +2025,7 @@ gfc_find_derived_vtab (gfc_symbol *derived)
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;
@ -1978,7 +2037,8 @@ gfc_find_derived_vtab (gfc_symbol *derived)
}
/* 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:
@ -2055,6 +2115,233 @@ yes:
}
/* 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, &copy);
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. */
@ -2147,7 +2434,7 @@ gfc_find_typebound_intrinsic_op (gfc_symbol* derived, gfc_try* t,
/* 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. */

34
gcc/fortran/decl.c
View file

@ -2735,9 +2735,37 @@ gfc_match_decl_type_spec (gfc_typespec *ts, int implicit_flag)
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)
@ -4248,6 +4276,10 @@ gfc_match_data_decl (void)
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)

76
gcc/fortran/expr.c
View file

@ -729,10 +729,10 @@ gfc_copy_shape_excluding (mpz_t *shape, int rank, gfc_expr *dim)
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;
@ -1389,7 +1389,7 @@ find_array_section (gfc_expr *expr, gfc_ref *ref)
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;
@ -1473,7 +1473,7 @@ find_array_section (gfc_expr *expr, gfc_ref *ref)
/* 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);
}
@ -1520,7 +1520,7 @@ find_array_section (gfc_expr *expr, gfc_ref *ref)
}
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
@ -1952,7 +1952,7 @@ scalarize_intrinsic_call (gfc_expr *e)
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.*/
@ -2105,7 +2105,7 @@ check_intrinsic_op (gfc_expr *e, gfc_try (*check_function) (gfc_expr *))
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))))
{
@ -2271,7 +2271,7 @@ check_inquiry (gfc_expr *e, int not_restricted)
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++)
@ -2360,7 +2360,7 @@ check_transformational (gfc_expr *e)
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. */
@ -3097,7 +3097,7 @@ gfc_check_assign (gfc_expr *lvalue, gfc_expr *rvalue, int conform)
|| 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;
@ -3137,7 +3137,7 @@ gfc_check_assign (gfc_expr *lvalue, gfc_expr *rvalue, int conform)
}
if (rvalue->expr_type == EXPR_NULL)
{
{
if (has_pointer && (ref == NULL || ref->next == NULL)
&& lvalue->symtree->n.sym->attr.data)
return SUCCESS;
@ -3150,7 +3150,7 @@ gfc_check_assign (gfc_expr *lvalue, gfc_expr *rvalue, int conform)
}
/* 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 "
@ -3222,15 +3222,15 @@ gfc_check_assign (gfc_expr *lvalue, gfc_expr *rvalue, int conform)
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);
}
@ -3550,9 +3550,22 @@ gfc_check_pointer_assign (gfc_expr *lvalue, gfc_expr *rvalue)
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;
}
@ -3569,9 +3582,11 @@ gfc_check_pointer_assign (gfc_expr *lvalue, gfc_expr *rvalue)
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)
@ -3647,7 +3662,7 @@ gfc_check_pointer_assign (gfc_expr *lvalue, gfc_expr *rvalue)
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))
{
@ -3747,7 +3762,7 @@ gfc_check_assign_symbol (gfc_symbol *sym, gfc_expr *rvalue)
if (r == FAILURE)
return r;
if (sym->attr.pointer && rvalue->expr_type != EXPR_NULL)
{
/* F08:C461. Additional checks for pointer initialization. */
@ -3772,7 +3787,7 @@ gfc_check_assign_symbol (gfc_symbol *sym, gfc_expr *rvalue)
return FAILURE;
}
}
if (sym->attr.proc_pointer && rvalue->expr_type != EXPR_NULL)
{
/* F08:C1220. Additional checks for procedure pointer initialization. */
@ -4251,7 +4266,7 @@ gfc_expr_check_typed (gfc_expr* e, gfc_namespace* ns, bool strict)
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
@ -4285,7 +4300,7 @@ replace_comp (gfc_expr *expr, gfc_symbol *sym, int *i ATTRIBUTE_UNUSED)
{
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)
@ -4421,7 +4436,7 @@ gfc_get_corank (gfc_expr *e)
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)
@ -4478,7 +4493,7 @@ gfc_has_ultimate_pointer (gfc_expr *e)
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)
@ -4598,7 +4613,7 @@ gfc_is_simply_contiguous (gfc_expr *expr, bool strict)
ar->as->upper[i]->value.integer) != 0))
colon = false;
}
return true;
}
@ -4618,7 +4633,7 @@ gfc_build_intrinsic_call (const char* name, locus where, unsigned numarg, ...)
isym = gfc_find_function (name);
gcc_assert (isym);
result = gfc_get_expr ();
result->expr_type = EXPR_FUNCTION;
result->ts = isym->ts;
@ -4669,6 +4684,7 @@ gfc_check_vardef_context (gfc_expr* e, bool pointer, bool alloc_obj,
bool is_pointer;
bool check_intentin;
bool ptr_component;
bool unlimited;
symbol_attribute attr;
gfc_ref* ref;
@ -4683,6 +4699,8 @@ gfc_check_vardef_context (gfc_expr* e, bool pointer, bool alloc_obj,
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)
{
@ -4722,7 +4740,7 @@ gfc_check_vardef_context (gfc_expr* e, bool pointer, bool alloc_obj,
/* 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)"

15
gcc/fortran/gfortran.h
View file

@ -796,10 +796,12 @@ typedef struct
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;
@ -1271,7 +1273,6 @@ typedef struct gfc_symbol
}
gfc_symbol;
/* This structure is used to keep track of symbols in common blocks. */
typedef struct gfc_common_head
{
@ -2964,11 +2965,12 @@ void gfc_add_class_array_ref (gfc_expr *);
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*,
@ -2980,6 +2982,11 @@ gfc_symtree* gfc_get_tbp_symtree (gfc_symtree**, const char*);
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 */

77
gcc/fortran/interface.c
View file

@ -214,7 +214,7 @@ gfc_match_interface (void)
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;
@ -351,7 +351,7 @@ gfc_match_end_interface (void)
gfc_error ("Expecting 'END INTERFACE OPERATOR (%s)' at %C, "
"but got %s", s1, s2);
}
}
break;
@ -446,7 +446,7 @@ gfc_compare_derived_types (gfc_symbol *derived1, gfc_symbol *derived2)
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)
@ -485,7 +485,17 @@ gfc_compare_types (gfc_typespec *ts1, gfc_typespec *ts2)
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)))
@ -523,7 +533,7 @@ compare_type_rank (gfc_symbol *s1, gfc_symbol *s2)
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;
}
@ -1157,7 +1167,7 @@ check_dummy_characteristics (gfc_symbol *s1, gfc_symbol *s2,
}
}
}
return SUCCESS;
}
@ -1403,6 +1413,9 @@ gfc_compare_interfaces (gfc_symbol *s1, gfc_symbol *s2, const char *name2,
return 0;
}
if (UNLIMITED_POLY (f1->sym))
goto next;
if (strict_flag)
{
/* Check all characteristics. */
@ -1418,7 +1431,7 @@ gfc_compare_interfaces (gfc_symbol *s1, gfc_symbol *s2, const char *name2,
f1->sym->name);
return 0;
}
next:
f1 = f1->next;
f2 = f2->next;
}
@ -1712,7 +1725,7 @@ gfc_check_interfaces (gfc_namespace *ns)
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;
@ -1814,7 +1827,7 @@ argument_rank_mismatch (const char *name, locus *where,
"(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);
}
@ -1900,7 +1913,7 @@ compare_parameter (gfc_symbol *formal, gfc_expr *actual,
&& 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)
@ -1933,6 +1946,23 @@ compare_parameter (gfc_symbol *formal, gfc_expr *actual,
}
}
/* 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)
@ -2078,7 +2108,7 @@ compare_parameter (gfc_symbol *formal, gfc_expr *actual,
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;
}
@ -2156,7 +2186,7 @@ get_sym_storage_size (gfc_symbol *sym)
return 0;
}
else
strlen = 1;
strlen = 1;
if (symbol_rank (sym) == 0)
return strlen;
@ -2194,7 +2224,7 @@ get_expr_storage_size (gfc_expr *e)
if (e == NULL)
return 0;
if (e->ts.type == BT_CHARACTER)
{
if (e->ts.u.cl && e->ts.u.cl->length
@ -2455,6 +2485,13 @@ compare_actual_formal (gfc_actual_arglist **ap, gfc_formal_arglist *formal,
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
@ -2478,7 +2515,7 @@ compare_actual_formal (gfc_actual_arglist **ap, gfc_formal_arglist *formal,
return 0;
}
if (!compare_parameter (f->sym, a->expr, ranks_must_agree,
is_elemental, where))
return 0;
@ -2628,7 +2665,7 @@ compare_actual_formal (gfc_actual_arglist **ap, gfc_formal_arglist *formal,
"pointer dummy '%s'", &a->expr->where,f->sym->name);
return 0;
}
/* Fortran 2008, C1242. */
if (f->sym->attr.pointer && gfc_is_coindexed (a->expr))
@ -3283,7 +3320,7 @@ gfc_search_interface (gfc_interface *intr, int sub_flag,
has_null_arg = true;
null_expr_loc = a->expr->where;
break;
}
}
for (; intr; intr = intr->next)
{
@ -3310,7 +3347,7 @@ gfc_search_interface (gfc_interface *intr, int sub_flag,
}
/* 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;
@ -3613,7 +3650,7 @@ gfc_extend_expr (gfc_expr *e)
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)
@ -3703,7 +3740,7 @@ gfc_extend_assign (gfc_code *c, gfc_namespace *ns)
/* 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)
@ -4028,7 +4065,7 @@ gfc_check_typebound_override (gfc_symtree* proc, gfc_symtree* old)
" FUNCTION", proc->name, &where);
return FAILURE;
}
if (check_result_characteristics (proc_target, old_target,
err, sizeof(err)) == FAILURE)
{

186
gcc/fortran/match.c
View file

@ -588,7 +588,7 @@ gfc_match_name_C (const char **buffer)
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 ();
@ -605,7 +605,7 @@ gfc_match_name_C (const char **buffer)
gfc_current_locus = old_loc;
return MATCH_YES;
}
if (!ISALPHA (c) && c != '_')
{
gfc_error ("Invalid C name in NAME= specifier at %C");
@ -625,9 +625,9 @@ gfc_match_name_C (const char **buffer)
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 == '_');
@ -650,7 +650,7 @@ gfc_match_name_C (const char **buffer)
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 != '\'')
@ -708,8 +708,8 @@ gfc_match_symbol (gfc_symbol **matched_symbol, int host_assoc)
}
/* 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
@ -1441,7 +1441,7 @@ gfc_match_if (gfc_statement *if_type)
old_loc2 = gfc_current_locus;
gfc_current_locus = old_loc;
if (gfc_match_parens () == MATCH_ERROR)
return MATCH_ERROR;
@ -1473,7 +1473,7 @@ gfc_match_if (gfc_statement *if_type)
gfc_free_expr (expr);
return MATCH_ERROR;
}
if (gfc_notify_std (GFC_STD_F95_OBS, "Arithmetic IF "
"statement at %C") == FAILURE)
return MATCH_ERROR;
@ -1579,7 +1579,7 @@ gfc_match_if (gfc_statement *if_type)
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)
@ -1907,7 +1907,7 @@ static match
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;
@ -1930,7 +1930,7 @@ match_derived_type_spec (gfc_typespec *ts)
return MATCH_YES;
}
gfc_current_locus = old_locus;
gfc_current_locus = old_locus;
return MATCH_NO;
}
@ -2194,7 +2194,7 @@ cleanup:
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
@ -2373,7 +2373,7 @@ gfc_match_do (void)
return MATCH_NO;
/* Check for balanced parens. */
if (gfc_match_parens () == MATCH_ERROR)
return MATCH_ERROR;
@ -2585,7 +2585,7 @@ match_exit_cycle (gfc_statement st, gfc_exec_op op)
" 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);
@ -3265,7 +3265,7 @@ gfc_match_goto (void)
return MATCH_YES;
}
/* The assigned GO TO statement. */
/* The assigned GO TO statement. */
if (gfc_match_variable (&expr, 0) == MATCH_YES)
{
@ -3432,6 +3432,7 @@ gfc_match_allocate (void)
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;
@ -3573,7 +3574,7 @@ gfc_match_allocate (void)
}
/* 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",
@ -3585,6 +3586,8 @@ gfc_match_allocate (void)
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");
@ -3696,7 +3699,7 @@ alloc_opt_list:
gfc_error ("Redundant MOLD tag found at %L ", &tmp->where);
goto cleanup;
}
/* Check F08:C637. */
if (ts.type != BT_UNKNOWN)
{
@ -3739,7 +3742,20 @@ alloc_opt_list:
&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;
@ -4067,7 +4083,7 @@ done:
}
/* 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
@ -4081,7 +4097,7 @@ match_typebound_call (gfc_symtree* varst)
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");
@ -4258,7 +4274,7 @@ cleanup:
/* 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. */
@ -4403,7 +4419,7 @@ gfc_match_common (void)
/* 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
@ -4423,13 +4439,13 @@ gfc_match_common (void)
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",
@ -4872,7 +4888,7 @@ cleanup:
/* 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. */
@ -5207,47 +5223,100 @@ select_type_push (gfc_symbol *sel)
}
/* 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
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);
if (select_type_stack->selector->ts.type == BT_CLASS
&& select_type_stack->selector->attr.class_ok)
{
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
/* 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);
@ -5257,6 +5326,7 @@ select_type_set_tmp (gfc_typespec *ts)
if (ts->type == BT_CLASS)
gfc_build_class_symbol (&tmp->n.sym->ts, &tmp->n.sym->attr,
&tmp->n.sym->as, 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. */
@ -5267,7 +5337,7 @@ select_type_set_tmp (gfc_typespec *ts)
select_type_stack->tmp = tmp;
}
/* Match a SELECT TYPE statement. */
match
@ -5356,7 +5426,7 @@ gfc_match_select_type (void)
select_type_push (expr1->symtree->n.sym);
return MATCH_YES;
cleanup:
parent_ns = gfc_current_ns->parent;
gfc_free_namespace (gfc_current_ns);
@ -5457,9 +5527,7 @@ gfc_match_type_is (void)
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)
@ -5474,6 +5542,16 @@ gfc_match_type_is (void)
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);
@ -5546,7 +5624,7 @@ gfc_match_class_is (void)
new_st.op = EXEC_SELECT_TYPE;
new_st.ext.block.case_list = c;
/* Create temporary variable. */
select_type_set_tmp (&c->ts);
@ -5564,7 +5642,7 @@ cleanup:
/********************* 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

10
gcc/fortran/misc.c
View file

@ -1,5 +1,6 @@
/* 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
@ -158,8 +159,11 @@ gfc_typename (gfc_typespec *ts)
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(*)");

8
gcc/fortran/module.c
View file

@ -1844,7 +1844,7 @@ typedef enum
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;
@ -1898,6 +1898,7 @@ static const mstring attr_bits[] =
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)
};
@ -2036,6 +2037,8 @@ mio_symbol_attribute (symbol_attribute *attr)
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)
@ -2177,6 +2180,9 @@ mio_symbol_attribute (symbol_attribute *attr)
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;

107
gcc/fortran/resolve.c
View file

@ -929,6 +929,10 @@ resolve_common_vars (gfc_symbol *sym, bool named_common)
&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;
@ -6898,6 +6902,7 @@ resolve_deallocate_expr (gfc_expr *e)
gfc_ref *ref;
gfc_symbol *sym;
gfc_component *c;
bool unlimited;
if (gfc_resolve_expr (e) == FAILURE)
return FAILURE;
@ -6906,6 +6911,7 @@ resolve_deallocate_expr (gfc_expr *e)
goto bad;
sym = e->symtree->n.sym;
unlimited = UNLIMITED_POLY(sym);
if (sym->ts.type == BT_CLASS)
{
@ -6950,7 +6956,7 @@ resolve_deallocate_expr (gfc_expr *e)
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",
@ -7118,6 +7124,7 @@ resolve_allocate_expr (gfc_expr *e, gfc_code *code)
int i, pointer, allocatable, dimension, is_abstract;
int codimension;
bool coindexed;
bool unlimited;
symbol_attribute attr;
gfc_ref *ref, *ref2;
gfc_expr *e2;
@ -7149,6 +7156,9 @@ resolve_allocate_expr (gfc_expr *e, gfc_code *code)
/* 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;
@ -7235,7 +7245,7 @@ resolve_allocate_expr (gfc_expr *e, gfc_code *code)
}
/* 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);
@ -7254,12 +7264,12 @@ resolve_allocate_expr (gfc_expr *e, gfc_code *code)
}
/* 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",
@ -7362,7 +7372,7 @@ resolve_allocate_expr (gfc_expr *e, gfc_code *code)
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. */
@ -7371,7 +7381,29 @@ resolve_allocate_expr (gfc_expr *e, gfc_code *code)
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);
}
@ -8206,7 +8238,9 @@ resolve_select (gfc_code *code)
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));
}
@ -8312,6 +8346,7 @@ resolve_select_type (gfc_code *code, gfc_namespace *old_ns)
char name[GFC_MAX_SYMBOL_LEN];
gfc_namespace *ns;
int error = 0;
int charlen = 0;
ns = code->ext.block.ns;
gfc_resolve (ns);
@ -8344,6 +8379,7 @@ resolve_select_type (gfc_code *code, gfc_namespace *old_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",
@ -8354,6 +8390,7 @@ resolve_select_type (gfc_code *code, gfc_namespace *old_ns)
/* 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'",
@ -8362,6 +8399,15 @@ resolve_select_type (gfc_code *code, gfc_namespace *old_ns)
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)
{
@ -8420,6 +8466,7 @@ resolve_select_type (gfc_code *code, gfc_namespace *old_ns)
ns->code->next = new_st;
code = new_st;
code->op = EXEC_SELECT;
gfc_add_vptr_component (code->expr1);
gfc_add_hash_component (code->expr1);
@ -8431,6 +8478,16 @@ resolve_select_type (gfc_code *code, gfc_namespace *old_ns)
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;
@ -8442,13 +8499,25 @@ resolve_select_type (gfc_code *code, gfc_namespace *old_ns)
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 ();
@ -11029,6 +11098,8 @@ resolve_fl_var_and_proc (gfc_symbol *sym, int mp_flag)
{
/* 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",
@ -11167,7 +11238,7 @@ resolve_fl_variable (gfc_symbol *sym, int mp_flag)
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);
@ -12412,6 +12483,9 @@ resolve_fl_derived0 (gfc_symbol *sym)
gfc_symbol* super_type;
gfc_component *c;
if (sym->attr.unlimited_polymorphic)
return SUCCESS;
super_type = gfc_get_derived_super_type (sym);
/* F2008, C432. */
@ -12764,7 +12838,8 @@ resolve_fl_derived0 (gfc_symbol *sym)
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,
@ -12833,6 +12908,9 @@ resolve_fl_derived (gfc_symbol *sym)
{
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
@ -12859,7 +12937,11 @@ resolve_fl_derived (gfc_symbol *sym)
/* 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);
@ -13074,6 +13156,9 @@ resolve_symbol (gfc_symbol *sym)
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

72
gcc/fortran/simplify.c
View file

@ -1,6 +1,6 @@
/* 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.
@ -82,7 +82,7 @@ range_check (gfc_expr *result, const char *name)
{
case ARITH_OK:
return result;
case ARITH_OVERFLOW:
gfc_error ("Result of %s overflows its kind at %L", name,
&result->where);
@ -380,7 +380,7 @@ compute_dot_product (gfc_expr *matrix_a, int stride_a, int offset_a,
}
/* Build a result expression for transformational intrinsics,
/* Build a result expression for transformational intrinsics,
depending on DIM. */
static gfc_expr *
@ -491,7 +491,7 @@ simplify_transformation_to_scalar (gfc_expr *result, gfc_expr *array, 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,
@ -1314,7 +1314,7 @@ gfc_simplify_bessel_n2 (gfc_expr *order1, gfc_expr *order2, gfc_expr *x,
mpfr_clear (last1);
return result;
}
/* Get second recursion anchor. */
mpfr_init (last2);
@ -1335,7 +1335,7 @@ gfc_simplify_bessel_n2 (gfc_expr *order1, gfc_expr *order2, gfc_expr *x,
}
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)
@ -1349,7 +1349,7 @@ gfc_simplify_bessel_n2 (gfc_expr *order1, gfc_expr *order2, gfc_expr *x,
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);
@ -1743,7 +1743,7 @@ gfc_simplify_cosh (gfc_expr *x)
case BT_COMPLEX:
mpc_cosh (result->value.complex, x->value.complex, GFC_MPC_RND_MODE);
break;
default:
gcc_unreachable ();
}
@ -2251,6 +2251,10 @@ gfc_simplify_extends_type_of (gfc_expr *a, gfc_expr *mold)
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
@ -2676,7 +2680,7 @@ gfc_simplify_index (gfc_expr *x, gfc_expr *y, gfc_expr *b, gfc_expr *kind)
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;
@ -2685,7 +2689,7 @@ gfc_simplify_index (gfc_expr *x, gfc_expr *y, gfc_expr *b, gfc_expr *kind)
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;
@ -3229,7 +3233,7 @@ simplify_bound_dim (gfc_expr *array, gfc_expr *kind, int d, int upper,
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;
@ -3558,7 +3562,7 @@ simplify_cobound (gfc_expr *array, gfc_expr *dim, gfc_expr *kind, int upper)
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);
@ -3912,7 +3916,7 @@ gfc_simplify_maskr (gfc_expr *i, gfc_expr *kind_arg)
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;
@ -3944,7 +3948,7 @@ gfc_simplify_maskl (gfc_expr *i, gfc_expr *kind_arg)
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;
@ -4066,7 +4070,7 @@ min_max_choose (gfc_expr *arg, gfc_expr *extremum, int sign)
#undef LENGTH
#undef STRING
break;
default:
gfc_internal_error ("simplify_min_max(): Bad type in arglist");
}
@ -4119,14 +4123,14 @@ simplify_min_max (gfc_expr *expr, int sign)
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);
}
@ -4176,14 +4180,14 @@ simplify_minval_maxval (gfc_expr *expr, int sign)
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);
}
@ -4261,7 +4265,7 @@ gfc_simplify_mod (gfc_expr *a, gfc_expr *p)
}
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;
@ -4310,7 +4314,7 @@ gfc_simplify_modulo (gfc_expr *a, gfc_expr *p)
}
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)
{
@ -4319,7 +4323,7 @@ gfc_simplify_modulo (gfc_expr *a, gfc_expr *p)
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;
@ -4621,7 +4625,7 @@ gfc_simplify_pack (gfc_expr *array, gfc_expr *mask, gfc_expr *vector)
}
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)
@ -4921,8 +4925,8 @@ gfc_simplify_repeat (gfc_expr *e, gfc_expr *n)
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);
@ -5740,7 +5744,7 @@ gfc_simplify_spacing (gfc_expr *x)
}
/* 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). */
@ -6025,11 +6029,11 @@ gfc_simplify_transfer (gfc_expr *source, gfc_expr *mold, gfc_expr *size)
: 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)
@ -6087,7 +6091,7 @@ gfc_simplify_transpose (gfc_expr *matrix)
{
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);
}

8
gcc/fortran/symbol.c
View file

@ -1955,6 +1955,9 @@ gfc_use_derived (gfc_symbol *sym)
if (!sym)
return NULL;
if (sym->attr.unlimited_polymorphic)
return sym;
if (sym->attr.generic)
sym = gfc_find_dt_in_generic (sym);
@ -4905,6 +4908,11 @@ gfc_type_compatible (gfc_typespec *ts1, gfc_typespec *ts2)
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);

58
gcc/fortran/trans-decl.c
View file

@ -327,7 +327,7 @@ gfc_sym_mangled_identifier (gfc_symbol * sym)
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
@ -433,14 +433,14 @@ gfc_finish_cray_pointee (tree decl, gfc_symbol *sym)
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);
@ -483,7 +483,7 @@ gfc_finish_decl (tree 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)));
@ -550,7 +550,7 @@ gfc_finish_var_decl (tree decl, gfc_symbol * sym)
TREE_PUBLIC(decl) = 1;
DECL_COMMON(decl) = 1;
}
/* If a variable is USE associated, it's always external. */
if (sym->attr.use_assoc)
{
@ -592,7 +592,7 @@ gfc_finish_var_decl (tree decl, gfc_symbol * sym)
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
@ -948,7 +948,7 @@ gfc_build_dummy_array_decl (gfc_symbol * sym, tree dummy)
/* 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
@ -1558,7 +1558,7 @@ get_proc_pointer_decl (gfc_symbol *sym)
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)
@ -1984,7 +1984,7 @@ create_function_arglist (gfc_symbol * sym)
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;
@ -2106,7 +2106,7 @@ create_function_arglist (gfc_symbol * sym)
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
@ -2215,7 +2215,7 @@ create_function_arglist (gfc_symbol * sym)
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);
@ -2314,7 +2314,7 @@ build_entry_thunks (gfc_namespace * ns, bool global)
vec<tree, va_gc> *string_args = NULL;
thunk_sym = el->sym;
build_function_decl (thunk_sym, global);
create_function_arglist (thunk_sym);
@ -2411,7 +2411,7 @@ build_entry_thunks (gfc_namespace * ns, bool global)
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);
@ -2985,7 +2985,7 @@ gfc_build_intrinsic_function_decls (void)
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,
@ -3121,7 +3121,7 @@ gfc_build_builtin_function_decls (void)
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);
@ -3816,7 +3816,7 @@ gfc_trans_deferred_vars (gfc_symbol * proc_sym, gfc_wrapped_block * block)
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);
@ -3827,8 +3827,14 @@ gfc_trans_deferred_vars (gfc_symbol * proc_sym, gfc_wrapped_block * block)
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);
}
@ -3894,7 +3900,7 @@ gfc_trans_deferred_vars (gfc_symbol * proc_sym, gfc_wrapped_block * block)
gfc_add_init_cleanup (block, gfc_finish_block (&tmpblock),
NULL_TREE);
}
else
else if (!(UNLIMITED_POLY(sym)))
gcc_unreachable ();
}
@ -4347,7 +4353,7 @@ generate_coarray_sym_init (gfc_symbol *sym)
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;
@ -4360,7 +4366,7 @@ generate_coarray_sym_init (gfc_symbol *sym)
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));
@ -4382,7 +4388,7 @@ generate_coarray_sym_init (gfc_symbol *sym)
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));
@ -4724,7 +4730,7 @@ generate_local_decl (gfc_symbol * sym)
{
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
@ -5151,9 +5157,9 @@ create_main_function (tree fndecl)
/* 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);

231
gcc/fortran/trans-expr.c
View file

@ -64,7 +64,7 @@ get_scalar_to_descriptor_type (tree scalar, symbol_attribute attr)
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");
@ -456,9 +456,68 @@ class_scalar_coarray_to_class (gfc_se *parmse, gfc_expr *e,
}
/* 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.
@ -567,7 +626,7 @@ gfc_conv_class_to_class (gfc_se *parmse, gfc_expr *e, gfc_typespec class_ts,
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
{
@ -813,6 +872,8 @@ gfc_trans_class_init_assign (gfc_code *code)
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);
}
@ -826,7 +887,7 @@ gfc_trans_class_init_assign (gfc_code *code)
}
gfc_add_expr_to_block (&block, tmp);
return gfc_finish_block (&block);
}
@ -867,10 +928,19 @@ gfc_trans_class_assign (gfc_expr *expr1, gfc_expr *expr2, gfc_exec_op op)
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 ();
@ -878,13 +948,21 @@ gfc_trans_class_assign (gfc_expr *expr1, gfc_expr *expr2, gfc_exec_op op)
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. */
@ -1110,7 +1188,7 @@ gfc_conv_missing_dummy (gfc_se * se, gfc_expr * arg, gfc_typespec ts, int kind)
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));
@ -1147,9 +1225,9 @@ gfc_get_expr_charlen (gfc_expr *e)
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)
@ -1238,8 +1316,8 @@ flatten_array_ctors_without_strlen (gfc_expr* e)
{
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:
@ -1604,7 +1682,7 @@ gfc_conv_variable (gfc_se * se, gfc_expr * expr)
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))
{
@ -1640,7 +1718,7 @@ gfc_conv_variable (gfc_se * se, gfc_expr * expr)
/* 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)
{
@ -1670,7 +1748,7 @@ gfc_conv_variable (gfc_se * se, gfc_expr * expr)
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)
@ -1828,11 +1906,11 @@ static const unsigned char powi_table[POWI_TABLE_SIZE] =
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)
@ -1895,7 +1973,7 @@ gfc_conv_cst_int_power (gfc_se * se, tree lhs, tree rhs)
/* 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);
@ -2006,7 +2084,7 @@ gfc_conv_power_op (gfc_se * se, gfc_expr * expr)
case 4:
ikind = 0;
break;
case 8:
ikind = 1;
break;
@ -2034,7 +2112,7 @@ gfc_conv_power_op (gfc_se * se, gfc_expr * expr)
case 4:
kind = 0;
break;
case 8:
kind = 1;
break;
@ -2050,7 +2128,7 @@ gfc_conv_power_op (gfc_se * se, gfc_expr * expr)
default:
gcc_unreachable ();
}
switch (expr->value.op.op1->ts.type)
{
case BT_INTEGER:
@ -2068,7 +2146,7 @@ gfc_conv_power_op (gfc_se * se, gfc_expr * expr)
case 0:
fndecl = builtin_decl_explicit (BUILT_IN_POWIF);
break;
case 1:
fndecl = builtin_decl_explicit (BUILT_IN_POWI);
break;
@ -2078,7 +2156,7 @@ gfc_conv_power_op (gfc_se * se, gfc_expr * expr)
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);
@ -2089,7 +2167,7 @@ gfc_conv_power_op (gfc_se * se, gfc_expr * expr)
}
}
/* 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;
@ -2497,7 +2575,7 @@ gfc_conv_scalar_char_value (gfc_symbol *sym, gfc_se *se, gfc_expr **expr)
(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;
@ -2937,8 +3015,8 @@ gfc_add_interface_mapping (gfc_interface_mapping * mapping,
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);
@ -3347,7 +3425,7 @@ gfc_conv_subref_array_arg (gfc_se * parmse, gfc_expr * expr, int g77,
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);
@ -3507,7 +3585,7 @@ gfc_conv_subref_array_arg (gfc_se * parmse, gfc_expr * expr, int g77,
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);
@ -3534,7 +3612,7 @@ gfc_conv_subref_array_arg (gfc_se * parmse, gfc_expr * expr, int g77,
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,
@ -3635,7 +3713,7 @@ conv_isocbinding_procedure (gfc_se * se, gfc_symbol * sym,
&& !(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);
}
@ -3654,7 +3732,7 @@ conv_isocbinding_procedure (gfc_se * se, gfc_symbol * sym,
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
@ -3756,14 +3834,14 @@ conv_isocbinding_procedure (gfc_se * se, gfc_symbol * sym,
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);
@ -3796,7 +3874,7 @@ conv_isocbinding_procedure (gfc_se * se, gfc_symbol * sym,
{
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);
@ -3820,7 +3898,7 @@ conv_isocbinding_procedure (gfc_se * se, gfc_symbol * sym,
return 1;
}
/* Nothing was done. */
return 0;
}
@ -3994,6 +4072,13 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym,
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;
@ -4051,7 +4136,7 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym,
= 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);
}
@ -4192,7 +4277,7 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym,
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
@ -4205,7 +4290,7 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym,
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,
@ -4327,7 +4412,7 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym,
/* 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)
{
@ -4387,7 +4472,7 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym,
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)
@ -4404,7 +4489,7 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym,
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
@ -4430,7 +4515,7 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym,
&& ((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
@ -4600,7 +4685,7 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym,
fold_convert (TREE_TYPE (tmp),
null_pointer_node));
}
gfc_trans_runtime_check (true, false, cond, &se->pre, &e->where,
msg);
free (msg);
@ -4618,8 +4703,21 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym,
}
/* 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
@ -4656,7 +4754,7 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym,
&& 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)
@ -4752,7 +4850,7 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym,
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,
@ -5490,7 +5588,7 @@ gfc_conv_array_constructor_expr (gfc_se * se, gfc_expr * expr)
/* 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
@ -5521,7 +5619,7 @@ gfc_conv_initializer (gfc_expr * expr, gfc_typespec * ts, tree type,
gcc_assert (TREE_CODE (se.expr) != CONSTRUCTOR);
return se.expr;
}
if (array && !procptr)
{
tree ctor;
@ -5557,7 +5655,7 @@ gfc_conv_initializer (gfc_expr * expr, gfc_typespec * ts, tree type,
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);
@ -5579,7 +5677,7 @@ gfc_conv_initializer (gfc_expr * expr, gfc_typespec * ts, tree type,
}
}
}
static tree
gfc_trans_subarray_assign (tree dest, gfc_component * cm, gfc_expr * expr)
{
@ -5626,7 +5724,7 @@ 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);
@ -5691,7 +5789,7 @@ gfc_trans_alloc_subarray_assign (tree dest, gfc_component * cm,
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);
@ -5867,7 +5965,7 @@ gfc_trans_subcomponent_assign (tree dest, gfc_component * cm, gfc_expr * expr)
{
/* 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)
@ -5948,7 +6046,7 @@ gfc_trans_structure_assign (tree dest, gfc_expr * expr)
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)
@ -6004,13 +6102,9 @@ gfc_conv_structure (gfc_se * se, gfc_expr * expr, int init)
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;
@ -6018,6 +6112,11 @@ gfc_conv_structure (gfc_se * se, gfc_expr * expr, int init)
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,
@ -6030,7 +6129,7 @@ gfc_conv_structure (gfc_se * se, gfc_expr * expr, int init)
}
}
se->expr = build_constructor (type, v);
if (init)
if (init)
TREE_CONSTANT (se->expr) = 1;
}
@ -6309,7 +6408,7 @@ gfc_trans_pointer_assignment (gfc_expr * expr1, gfc_expr * expr2)
scalar = ss == gfc_ss_terminator;
if (!scalar)
gfc_free_ss_chain (ss);
if (scalar)
{
/* Scalar pointers. */
@ -6794,7 +6893,7 @@ arrayfunc_assign_needs_temporary (gfc_expr * expr1, gfc_expr * expr2)
/* 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);
@ -7085,7 +7184,7 @@ gfc_trans_arrayfunc_assign (gfc_expr * expr1, gfc_expr * expr2)
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
@ -7417,7 +7516,7 @@ alloc_scalar_allocatable_for_assignment (stmtblock_t *block,
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);

29
gcc/fortran/trans-intrinsic.c
View file

@ -5911,6 +5911,7 @@ gfc_conv_same_type_as (gfc_se *se, gfc_expr *expr)
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);
@ -5918,6 +5919,20 @@ gfc_conv_same_type_as (gfc_se *se, gfc_expr *expr)
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);
@ -5939,8 +5954,18 @@ gfc_conv_same_type_as (gfc_se *se, gfc_expr *expr)
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);
}

163
gcc/fortran/trans-stmt.c
View file

@ -247,7 +247,7 @@ gfc_conv_elemental_dependencies (gfc_se * se, gfc_se * loopse,
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;
@ -449,9 +449,9 @@ gfc_trans_call (gfc_code * code, bool dependency_check,
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);
@ -657,7 +657,7 @@ gfc_trans_stop (gfc_code *code, bool error_stop)
? (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
@ -689,7 +689,7 @@ gfc_trans_lock_unlock (gfc_code *code, gfc_exec_op type ATTRIBUTE_UNUSED)
/* 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);
@ -734,7 +734,7 @@ gfc_trans_sync (gfc_code *code, gfc_exec_op type)
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);
@ -824,7 +824,7 @@ gfc_trans_sync (gfc_code *code, gfc_exec_op type)
{
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);
@ -837,7 +837,7 @@ gfc_trans_sync (gfc_code *code, gfc_exec_op type)
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));
}
@ -890,7 +890,7 @@ gfc_trans_sync (gfc_code *code, gfc_exec_op type)
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);
@ -899,13 +899,13 @@ gfc_trans_sync (gfc_code *code, gfc_exec_op type)
{
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));
}
}
@ -995,7 +995,7 @@ gfc_trans_if_1 (gfc_code * code)
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. */
@ -1141,6 +1141,7 @@ trans_associate_var (gfc_symbol *sym, gfc_wrapped_block *block)
gfc_expr *e;
tree tmp;
bool class_target;
bool unlimited;
tree desc;
tree offset;
tree dim;
@ -1153,6 +1154,8 @@ trans_associate_var (gfc_symbol *sym, gfc_wrapped_block *block)
&& (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. */
@ -1194,9 +1197,10 @@ trans_associate_var (gfc_symbol *sym, gfc_wrapped_block *block)
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;
@ -1208,7 +1212,16 @@ trans_associate_var (gfc_symbol *sym, gfc_wrapped_block *block)
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));
}
@ -1229,7 +1242,7 @@ trans_associate_var (gfc_symbol *sym, gfc_wrapped_block *block)
/* 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);
@ -1254,7 +1267,7 @@ trans_associate_var (gfc_symbol *sym, gfc_wrapped_block *block)
{
/* 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);
@ -1266,7 +1279,7 @@ trans_associate_var (gfc_symbol *sym, gfc_wrapped_block *block)
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));
}
@ -1281,6 +1294,23 @@ trans_associate_var (gfc_symbol *sym, gfc_wrapped_block *block)
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));
}
}
@ -1319,7 +1349,7 @@ gfc_trans_block_construct (gfc_code* code)
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);
}
@ -1366,7 +1396,7 @@ gfc_trans_simple_do (gfc_code * code, stmtblock_t *pblock, tree dovar,
tree cycle_label;
tree exit_label;
location_t loc;
type = TREE_TYPE (dovar);
loc = code->ext.iterator->start->where.lb->location;
@ -1374,7 +1404,7 @@ gfc_trans_simple_do (gfc_code * code, stmtblock_t *pblock, tree dovar,
/* 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)
{
@ -1612,8 +1642,8 @@ gfc_trans_do (gfc_code * code, tree exit_cond)
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);
@ -3183,7 +3213,7 @@ compute_overall_iter_number (forall_info *nested_forall_info, tree inner_size,
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,
@ -3707,7 +3737,7 @@ gfc_trans_forall_1 (gfc_code * code, forall_info * nested_forall_info)
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);
@ -4108,7 +4138,7 @@ gfc_trans_where_assign (gfc_expr *expr1, gfc_expr *expr2,
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);
@ -4893,10 +4923,19 @@ gfc_trans_allocate (gfc_code * code)
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)
{
@ -4913,8 +4952,8 @@ gfc_trans_allocate (gfc_code * code)
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)
{
@ -4968,13 +5007,17 @@ gfc_trans_allocate (gfc_code * code)
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);
@ -5026,7 +5069,7 @@ gfc_trans_allocate (gfc_code * code)
}
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,
@ -5050,8 +5093,8 @@ gfc_trans_allocate (gfc_code * code)
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)
{
@ -5090,16 +5133,19 @@ gfc_trans_allocate (gfc_code * code)
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;
@ -5184,9 +5230,12 @@ gfc_trans_allocate (gfc_code * code)
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 ();
@ -5296,6 +5345,30 @@ gfc_trans_allocate (gfc_code * 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
@ -5376,6 +5449,8 @@ gfc_trans_deallocate (gfc_code *code)
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
{
@ -5388,19 +5463,9 @@ gfc_trans_deallocate (gfc_code *code)
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)

18
gcc/fortran/trans-types.c
View file

@ -2338,16 +2338,18 @@ gfc_get_derived_type (gfc_symbol * derived)
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)
{
@ -2431,6 +2433,12 @@ gfc_get_derived_type (gfc_symbol * derived)
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
@ -2511,14 +2519,16 @@ gfc_get_derived_type (gfc_symbol * derived)
!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);

40
gcc/fortran/trans.c
View file

@ -1,6 +1,6 @@
/* 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.
@ -87,7 +87,7 @@ tree
gfc_create_var_np (tree type, const char *prefix)
{
tree t;
t = create_tmp_var_raw (type, prefix);
/* No warnings for anonymous variables. */
@ -139,7 +139,7 @@ gfc_evaluate_now (tree expr, stmtblock_t * pblock)
}
/* 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. */
@ -428,7 +428,7 @@ trans_runtime_error_vararg (bool error, locus* where, const char* msgid,
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));
@ -440,7 +440,7 @@ trans_runtime_error_vararg (bool error, locus* where, const char* msgid,
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. */
@ -591,14 +591,14 @@ gfc_call_malloc (stmtblock_t * block, tree type, tree size)
/* 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;
@ -661,7 +661,7 @@ gfc_allocate_using_malloc (stmtblock_t * block, tree pointer,
/* Allocate memory, using an optional status argument.
This function follows the following pseudo-code:
void *
@ -717,9 +717,9 @@ gfc_allocate_using_lib (stmtblock_t * block, tree pointer, tree size,
/* 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)
{
@ -733,7 +733,7 @@ gfc_allocate_using_lib (stmtblock_t * block, tree pointer, tree size,
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
@ -866,7 +866,7 @@ gfc_call_free (tree var)
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.
@ -1075,7 +1075,7 @@ gfc_deallocate_scalar_with_status (tree pointer, tree status, bool can_fail,
/* 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)
{
@ -1091,7 +1091,7 @@ gfc_deallocate_scalar_with_status (tree pointer, tree status, bool can_fail,
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));
@ -1320,6 +1320,12 @@ trans_code (gfc_code * code, tree cond)
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;
@ -1544,7 +1550,7 @@ trans_code (gfc_code * code, tree cond)
{
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);
}
@ -1686,7 +1692,7 @@ gfc_finish_wrapped_block (gfc_wrapped_block* block)
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;

7
gcc/testsuite/ChangeLog
View file

@ -1,3 +1,10 @@
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.

211
gcc/testsuite/gfortran.dg/unlimited_polymorphic_1.f03 Normal file
View file

@ -0,0 +1,211 @@
! { dg-do run }
!
! Basic tests of functionality of unlimited polymorphism
!
! Contributed by Paul Thomas <pault@gcc.gnu.org>
!
MODULE m
TYPE :: a
integer :: i
END TYPE
contains
subroutine bar (arg, res)
class(*) :: arg
character(100) :: res
select type (w => arg)
type is (a)
write (res, '(a, I4)') "type(a)", w%i
type is (integer)
write (res, '(a, I4)') "integer", w
type is (real(4))
write (res, '(a, F4.1)') "real4", w
type is (real(8))
write (res, '(a, F4.1)') "real8", w
type is (character(*, kind = 4))
call abort
type is (character(*))
write (res, '(a, I2, a, a)') "char(", LEN(w), ")", trim(w)
end select
end subroutine
subroutine foo (arg, res)
class(*) :: arg (:)
character(100) :: res
select type (w => arg)
type is (a)
write (res,'(a, 10I4)') "type(a) array", w%i
type is (integer)
write (res,'(a, 10I4)') "integer array", w
type is (real)
write (res,'(a, 10F4.1)') "real array", w
type is (character(*))
write (res, '(a5, I2, a, I2, a1, 2(a))') &
"char(",len(w),",", size(w,1),") array ", w
end select
end subroutine
END MODULE
USE m
TYPE(a), target :: obj1 = a(99)
TYPE(a), target :: obj2(3) = a(999)
integer, target :: obj3 = 999
real(4), target :: obj4(4) = [(real(i), i = 1, 4)]
integer, target :: obj5(3) = [(i*99, i = 1, 3)]
class(*), pointer :: u1
class(*), pointer :: u2(:)
class(*), allocatable :: u3
class(*), allocatable :: u4(:)
type(a), pointer :: aptr(:)
character(8) :: sun = "sunshine"
character(100) :: res
! NULL without MOLD used to cause segfault
u2 => NULL()
u2 => NULL(aptr)
! Test pointing to derived types.
u1 => obj1
if (SAME_TYPE_AS (obj1, u1) .neqv. .TRUE.) call abort
u2 => obj2
call bar (u1, res)
if (trim (res) .ne. "type(a) 99") call abort
call foo (u2, res)
if (trim (res) .ne. "type(a) array 999 999 999") call abort
if (SAME_TYPE_AS (obj1, u1) .neqv. .TRUE.) call abort
! Check allocate with an array SOURCE.
allocate (u2(5), source = [(a(i), i = 1,5)])
if (SAME_TYPE_AS (u1, a(2)) .neqv. .TRUE.) call abort
call foo (u2, res)
if (trim (res) .ne. "type(a) array 1 2 3 4 5") call abort
deallocate (u2)
! Point to intrinsic targets.
u1 => obj3
call bar (u1, res)
if (trim (res) .ne. "integer 999") call abort
u2 => obj4
call foo (u2, res)
if (trim (res) .ne. "real array 1.0 2.0 3.0 4.0") call abort
u2 => obj5
call foo (u2, res)
if (trim (res) .ne. "integer array 99 198 297") call abort
! Test allocate with source.
allocate (u1, source = sun)
call bar (u1, res)
if (trim (res) .ne. "char( 8)sunshine") call abort
deallocate (u1)
allocate (u2(3), source = [7,8,9])
call foo (u2, res)
if (trim (res) .ne. "integer array 7 8 9") call abort
deallocate (u2)
if (EXTENDS_TYPE_OF (obj1, u2) .neqv. .TRUE.) call abort
if (EXTENDS_TYPE_OF (u2, obj1) .neqv. .FALSE.) call abort
allocate (u2(3), source = [5.0,6.0,7.0])
call foo (u2, res)
if (trim (res) .ne. "real array 5.0 6.0 7.0") call abort
if (EXTENDS_TYPE_OF (obj1, u2) .neqv. .FALSE.) call abort
if (EXTENDS_TYPE_OF (u2, obj1) .neqv. .FALSE.) call abort
deallocate (u2)
! Check allocate with a MOLD tag.
allocate (u2(3), mold = 8.0)
call foo (u2, res)
if (res(1:10) .ne. "real array") call abort
deallocate (u2)
! Test passing an intrinsic type to a CLASS(*) formal.
call bar(1, res)
if (trim (res) .ne. "integer 1") call abort
call bar(2.0, res)
if (trim (res) .ne. "real4 2.0") call abort
call bar(2d0, res)
if (trim (res) .ne. "real8 2.0") call abort
call bar(a(3), res)
if (trim (res) .ne. "type(a) 3") call abort
call bar(sun, res)
if (trim (res) .ne. "char( 8)sunshine") call abort
call bar (obj3, res)
if (trim (res) .ne. "integer 999") call abort
call foo([4,5], res)
if (trim (res) .ne. "integer array 4 5") call abort
call foo([6.0,7.0], res)
if (trim (res) .ne. "real array 6.0 7.0") call abort
call foo([a(8),a(9)], res)
if (trim (res) .ne. "type(a) array 8 9") call abort
call foo([sun, " & rain"], res)
if (trim (res) .ne. "char( 8, 2)sunshine & rain") call abort
call foo([sun//" never happens", " & rain always happens"], res)
if (trim (res) .ne. "char(22, 2)sunshine never happens & rain always happens") call abort
call foo (obj4, res)
if (trim (res) .ne. "real array 1.0 2.0 3.0 4.0") call abort
call foo (obj5, res)
if (trim (res) .ne. "integer array 99 198 297") call abort
! Allocatable entities
if (EXTENDS_TYPE_OF (obj1, u3) .neqv. .TRUE.) call abort
if (EXTENDS_TYPE_OF (u3, obj1) .neqv. .FALSE.) call abort
if (EXTENDS_TYPE_OF (obj1, u4) .neqv. .TRUE.) call abort
if (EXTENDS_TYPE_OF (u4, obj1) .neqv. .FALSE.) call abort
allocate (u3, source = 2.4)
call bar (u3, res)
if (trim (res) .ne. "real4 2.4") call abort
allocate (u4(2), source = [a(88), a(99)])
call foo (u4, res)
if (trim (res) .ne. "type(a) array 88 99") call abort
if (EXTENDS_TYPE_OF (obj1, u3) .neqv. .FALSE.) call abort
if (EXTENDS_TYPE_OF (u3, obj1) .neqv. .FALSE.) call abort
deallocate (u3)
if (EXTENDS_TYPE_OF (obj1, u3) .neqv. .TRUE.) call abort
if (EXTENDS_TYPE_OF (u3, obj1) .neqv. .FALSE.) call abort
if (EXTENDS_TYPE_OF (obj1, u4) .neqv. .TRUE.) call abort
if (EXTENDS_TYPE_OF (u4, obj1) .neqv. .TRUE.) call abort
deallocate (u4)
if (EXTENDS_TYPE_OF (obj1, u4) .neqv. .TRUE.) call abort
if (EXTENDS_TYPE_OF (u4, obj1) .neqv. .FALSE.) call abort
! Check assumed rank calls
call foobar (u3, 0)
call foobar (u4, 1)
contains
subroutine foobar (arg, ranki)
class(*) :: arg (..)
integer :: ranki
integer i
i = rank (arg)
if (i .ne. ranki) call abort
end subroutine
END

81
gcc/testsuite/gfortran.dg/unlimited_polymorphic_2.f03 Normal file
View file

@ -0,0 +1,81 @@
! { dg-do compile }
!
! Test the most important constraints unlimited polymorphic entities
!
! Contributed by Paul Thomas <pault@gcc.gnu.org>
! and Tobias Burnus <burnus@gcc.gnu.org>
!
CHARACTER(:), allocatable, target :: chr ! { dg-error "TODO: Deferred character length variable" }
! F2008: C5100
integer :: i(2)
logical :: flag
class(*), pointer :: u1, u2(:) ! { dg-error "cannot appear in COMMON" }
common u1
u1 => chr
! F2003: C625
allocate (u1) ! { dg-error "requires either a type-spec or SOURCE tag" }
allocate (u1, mold = 1.0) ! { dg-error "requires either a type-spec or SOURCE tag" }
allocate (real :: u1)
Allocate (u1, source = 1.0)
! F2008: C4106
u2 = [u1] ! { dg-error "shall not be unlimited polymorphic" }
i = u2 ! { dg-error "Can\\'t convert CLASS\\(\\*\\)" }
! Repeats same_type_as_1.f03 for unlimited polymorphic u2
flag = same_type_as (i, u2) ! { dg-error "cannot be of type INTEGER" }
flag = extends_type_of (i, u2) ! { dg-error "cannot be of type INTEGER" }
contains
! C717 (R735) If data-target is unlimited polymorphic,
! data-pointer-object shall be unlimited polymorphic, of a sequence
! derived type, or of a type with the BIND attribute.
!
subroutine bar
type sq
sequence
integer :: i
end type sq
type(sq), target :: x
class(*), pointer :: y
integer, pointer :: tgt
x%i = 42
y => x
call foo (y)
y => tgt ! This is OK, of course.
tgt => y ! { dg-error "must be unlimited polymorphic" }
select type (y) ! This is the correct way to accomplish the previous
type is (integer)
tgt => y
end select
end subroutine bar
subroutine foo(tgt)
class(*), pointer, intent(in) :: tgt
type t
sequence
integer :: k
end type t
type(t), pointer :: ptr
ptr => tgt ! C717 allows this.
select type (tgt)
! F03:C815 or F08:C839
type is (t) ! { dg-error "shall not specify a sequence derived type" }
ptr => tgt ! { dg-error "Expected TYPE IS" }
end select
print *, ptr%k
end subroutine foo
END

55
gcc/testsuite/gfortran.dg/unlimited_polymorphic_3.f03 Normal file
View file

@ -0,0 +1,55 @@
! { 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

5
libgfortran/ChangeLog
View file

@ -1,3 +1,8 @@
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

8
libgfortran/intrinsics/extends_type_of.c
View file

@ -49,6 +49,14 @@ export_proto(is_extension_of);
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;