git
/
gcc
mirror of git://gcc.gnu.org/git/gcc.git
1
0
Fork 0
Code Issues Packages Projects Releases Wiki Activity

array.c (resolve_array_list): Apply C4106. 

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> 2012-12-19 Tobias Burnus <burnus@net-b.de>
PR fortran/55733 PR fortran/55733
@ -51,7 +170,7 @@
PR fortran/55593 PR fortran/55593
* frontend-passes.c (doloop_code): Use resolved_sym * frontend-passes.c (doloop_code): Use resolved_sym
instead of n.sym->formal for formal argument list 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> 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; goto cleanup;
case AS_ASSUMED_RANK: case AS_ASSUMED_RANK:
gcc_unreachable (); gcc_unreachable ();
} }
if (gfc_match_char (')') == MATCH_YES) if (gfc_match_char (')') == MATCH_YES)
@ -666,7 +666,7 @@ coarray:
goto cleanup; goto cleanup;
case AS_ASSUMED_RANK: case AS_ASSUMED_RANK:
gcc_unreachable (); gcc_unreachable ();
} }
if (gfc_match_char (']') == MATCH_YES) if (gfc_match_char (']') == MATCH_YES)
@ -1414,7 +1414,7 @@ extract_element (gfc_expr *e)
gfc_free_expr (e); gfc_free_expr (e);
current_expand.extract_count++; current_expand.extract_count++;
return SUCCESS; return SUCCESS;
} }
@ -1815,7 +1815,7 @@ resolve_array_list (gfc_constructor_base base)
{ {
gfc_symbol *iter_var; gfc_symbol *iter_var;
locus iter_var_loc; locus iter_var_loc;
if (gfc_resolve_iterator (iter, false, true) == FAILURE) if (gfc_resolve_iterator (iter, false, true) == FAILURE)
t = FAILURE; t = FAILURE;
@ -1847,6 +1847,13 @@ resolve_array_list (gfc_constructor_base base)
if (gfc_resolve_expr (c->expr) == FAILURE) if (gfc_resolve_expr (c->expr) == FAILURE)
t = 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; return t;
@ -1941,7 +1948,7 @@ got_charlen:
expr->ts.u.cl->length = gfc_get_int_expr (gfc_default_integer_kind, expr->ts.u.cl->length = gfc_get_int_expr (gfc_default_integer_kind,
NULL, found_length); NULL, found_length);
} }
else else
{ {
/* We've got a character length specified. It should be an integer, /* We've got a character length specified. It should be an integer,
otherwise an error is signalled elsewhere. */ 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; return SUCCESS;
} }
/* Make sure the expression is a logical array. */ /* 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); gfc_extract_int (expr2, &i2);
i3 = gfc_validate_kind (BT_INTEGER, expr1->ts.kind, false); i3 = gfc_validate_kind (BT_INTEGER, expr1->ts.kind, false);
/* For ISHFT[C], check that |shift| <= bit_size(i). */ /* For ISHFT[C], check that |shift| <= bit_size(i). */
if (arg2 == NULL) if (arg2 == NULL)
{ {
@ -355,7 +355,7 @@ less_than_bitsizekind (const char *arg, gfc_expr *expr, int k)
if (expr->expr_type != EXPR_CONSTANT) if (expr->expr_type != EXPR_CONSTANT)
return SUCCESS; return SUCCESS;
i = gfc_validate_kind (BT_INTEGER, k, false); i = gfc_validate_kind (BT_INTEGER, k, false);
gfc_extract_int (expr, &val); 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->ts.type != BT_CLASS
&& ref->u.c.component->attr.pointer))) && ref->u.c.component->attr.pointer)))
break; break;
} }
if (!ref) if (!ref)
{ {
@ -575,7 +575,7 @@ dim_corank_check (gfc_expr *dim, gfc_expr *array)
if (dim->expr_type != EXPR_CONSTANT) if (dim->expr_type != EXPR_CONSTANT)
return SUCCESS; return SUCCESS;
if (array->ts.type == BT_CLASS) if (array->ts.type == BT_CLASS)
return SUCCESS; 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) if (mpz_cmp (a_size, b_size) != 0)
ret = 0; ret = 0;
mpz_clear (b_size); mpz_clear (b_size);
} }
mpz_clear (a_size); mpz_clear (a_size);
@ -841,7 +841,7 @@ gfc_check_allocated (gfc_expr *array)
return FAILURE; return FAILURE;
if (allocatable_check (array, 0) == FAILURE) if (allocatable_check (array, 0) == FAILURE)
return FAILURE; return FAILURE;
return SUCCESS; return SUCCESS;
} }
@ -1881,7 +1881,7 @@ gfc_check_ichar_iachar (gfc_expr *c, gfc_expr *kind)
return SUCCESS; return SUCCESS;
i = mpz_get_si (c->ts.u.cl->length->value.integer); i = mpz_get_si (c->ts.u.cl->length->value.integer);
} }
else else
return SUCCESS; return SUCCESS;
} }
else else
@ -1903,7 +1903,7 @@ gfc_check_ichar_iachar (gfc_expr *c, gfc_expr *kind)
if (i != 1) 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); gfc_current_intrinsic, &c->where);
return FAILURE; 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) || type_check (shift, 1, BT_INTEGER) == FAILURE)
return FAILURE; return FAILURE;
if (size != NULL) if (size != NULL)
{ {
int i2, i3; int i2, i3;
@ -3081,7 +3081,7 @@ gfc_check_rank (gfc_expr *a ATTRIBUTE_UNUSED)
bool is_variable = true; bool is_variable = true;
/* Functions returning pointers are regarded as variable, cf. F2008, R602. */ /* 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 is_variable = a->value.function.esym
? a->value.function.esym->result->attr.pointer ? a->value.function.esym->result->attr.pointer
: a->symtree->n.sym->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) if (order_size != shape_size)
{ {
gfc_error ("'%s' argument of '%s' intrinsic at %L " 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_arg[3]->name,
gfc_current_intrinsic, &order->where, gfc_current_intrinsic, &order->where,
order_size, shape_size); order_size, shape_size);
@ -3287,7 +3287,7 @@ gfc_check_reshape (gfc_expr *source, gfc_expr *shape,
if (dim < 1 || dim > order_size) if (dim < 1 || dim > order_size)
{ {
gfc_error ("'%s' argument of '%s' intrinsic at %L " 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_arg[3]->name,
gfc_current_intrinsic, &e->where, dim); gfc_current_intrinsic, &e->where, dim);
return FAILURE; return FAILURE;
@ -3319,7 +3319,7 @@ gfc_check_reshape (gfc_expr *source, gfc_expr *shape,
gfc_constructor *c; gfc_constructor *c;
bool test; bool test;
mpz_init_set_ui (size, 1); mpz_init_set_ui (size, 1);
for (c = gfc_constructor_first (shape->value.constructor); for (c = gfc_constructor_first (shape->value.constructor);
c; c = gfc_constructor_next (c)) c; c = gfc_constructor_next (c))
@ -3346,17 +3346,17 @@ gfc_check_reshape (gfc_expr *source, gfc_expr *shape,
gfc_try gfc_try
gfc_check_same_type_as (gfc_expr *a, gfc_expr *b) gfc_check_same_type_as (gfc_expr *a, gfc_expr *b)
{ {
if (a->ts.type != BT_DERIVED && a->ts.type != BT_CLASS) if (a->ts.type != BT_DERIVED && a->ts.type != BT_CLASS)
{ {
gfc_error ("'%s' argument of '%s' intrinsic at %L " gfc_error ("'%s' argument of '%s' intrinsic at %L "
"must be of a derived type", "cannot be of type %s",
gfc_current_intrinsic_arg[0]->name, gfc_current_intrinsic, gfc_current_intrinsic_arg[0]->name,
&a->where); gfc_current_intrinsic,
return FAILURE; &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 " gfc_error ("'%s' argument of '%s' intrinsic at %L "
"must be of an extensible type", "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) if (b->ts.type != BT_DERIVED && b->ts.type != BT_CLASS)
{ {
gfc_error ("'%s' argument of '%s' intrinsic at %L " gfc_error ("'%s' argument of '%s' intrinsic at %L "
"must be of a derived type", "cannot be of type %s",
gfc_current_intrinsic_arg[1]->name, gfc_current_intrinsic, gfc_current_intrinsic_arg[0]->name,
&b->where); gfc_current_intrinsic,
&b->where, gfc_typename (&b->ts));
return FAILURE; 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 " gfc_error ("'%s' argument of '%s' intrinsic at %L "
"must be of an extensible type", "must be of an extensible type",
@ -3688,7 +3689,7 @@ gfc_check_spread (gfc_expr *source, gfc_expr *dim, gfc_expr *ncopies)
return FAILURE; return FAILURE;
/* dim_rank_check() does not apply here. */ /* dim_rank_check() does not apply here. */
if (dim if (dim
&& dim->expr_type == EXPR_CONSTANT && dim->expr_type == EXPR_CONSTANT
&& (mpz_cmp_ui (dim->value.integer, 1) < 0 && (mpz_cmp_ui (dim->value.integer, 1) < 0
|| mpz_cmp_ui (dim->value.integer, source->rank + 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) if (mask->rank != field->rank && field->rank != 0)
{ {
gfc_error ("'%s' argument of '%s' intrinsic at %L must have " 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, gfc_current_intrinsic_arg[2]->name, gfc_current_intrinsic,
&field->where, gfc_current_intrinsic_arg[1]->name); &field->where, gfc_current_intrinsic_arg[1]->name);
return FAILURE; 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)) if (! identical_dimen_shape (mask, i, field, i))
{ {
gfc_error ("'%s' and '%s' arguments of '%s' intrinsic at %L " 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[2]->name,
gfc_current_intrinsic_arg[1]->name, gfc_current_intrinsic, gfc_current_intrinsic_arg[1]->name, gfc_current_intrinsic,
&field->where); &field->where);

363
gcc/fortran/class.c
View File

@ -1,5 +1,5 @@
/* Implementation of Fortran 2003 Polymorphism. /* Implementation of Fortran 2003 Polymorphism.
Copyright (C) 2009, 2010 Copyright (C) 2009, 2010, 2011, 2012
Free Software Foundation, Inc. Free Software Foundation, Inc.
Contributed by Paul Richard Thomas <pault@gcc.gnu.org> Contributed by Paul Richard Thomas <pault@gcc.gnu.org>
and Janus Weil <janus@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 "gfortran.h"
#include "constructor.h" #include "constructor.h"
/* Inserts a derived type component reference in a data reference chain. /* 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 TS: base type of the ref chain so far, in which we will pick the component
REF: the address of the GFC_REF pointer to update REF: 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 = ref->next;
ref->type = REF_ARRAY; ref->type = REF_ARRAY;
ref->u.ar.type = AR_FULL; 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) if (ref->type != REF_COMPONENT)
result = false; result = false;
else if (ref->u.c.component->ts.type == BT_CLASS) else if (ref->u.c.component->ts.type == BT_CLASS)
result = true; result = true;
else else
result = false; result = false;
} }
@ -403,20 +402,31 @@ gfc_is_class_container_ref (gfc_expr *e)
the _vptr component to the declared type. */ the _vptr component to the declared type. */
gfc_expr * gfc_expr *
gfc_class_null_initializer (gfc_typespec *ts) gfc_class_null_initializer (gfc_typespec *ts, gfc_expr *init_expr)
{ {
gfc_expr *init; gfc_expr *init;
gfc_component *comp; 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, init = gfc_get_structure_constructor_expr (ts->type, ts->kind,
&ts->u.derived->declared_at); &ts->u.derived->declared_at);
init->ts = *ts; init->ts = *ts;
for (comp = ts->u.derived->components; comp; comp = comp->next) for (comp = ts->u.derived->components; comp; comp = comp->next)
{ {
gfc_constructor *ctor = gfc_constructor_get(); gfc_constructor *ctor = gfc_constructor_get();
if (strcmp (comp->name, "_vptr") == 0) if (strcmp (comp->name, "_vptr") == 0 && vtab)
ctor->expr = gfc_lval_expr_from_sym (gfc_find_derived_vtab (ts->u.derived)); ctor->expr = gfc_lval_expr_from_sym (vtab);
else else
ctor->expr = gfc_get_null_expr (NULL); ctor->expr = gfc_get_null_expr (NULL);
gfc_constructor_append (&init->value.constructor, ctor); gfc_constructor_append (&init->value.constructor, ctor);
@ -434,9 +444,14 @@ static void
get_unique_type_string (char *string, gfc_symbol *derived) get_unique_type_string (char *string, gfc_symbol *derived)
{ {
char dt_name[GFC_MAX_SYMBOL_LEN+1]; 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); sprintf (dt_name, "%s", derived->name);
dt_name[0] = TOUPPER (dt_name[0]); 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); sprintf (string, "%s_%s", derived->module, dt_name);
else if (derived->ns->proc_name) else if (derived->ns->proc_name)
sprintf (string, "%s_%s", derived->ns->proc_name->name, dt_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; unsigned int hash = 0;
char c[2*(GFC_MAX_SYMBOL_LEN+1)]; char c[2*(GFC_MAX_SYMBOL_LEN+1)];
int i, len; int i, len;
get_unique_type_string (&c[0], sym); get_unique_type_string (&c[0], sym);
len = strlen (c); 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++) for (i = 0; i < len; i++)
hash = (hash << 6) + (hash << 16) - hash + c[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 *fclass;
gfc_symbol *vtab; gfc_symbol *vtab;
gfc_component *c; gfc_component *c;
gfc_namespace *ns;
int rank; int rank;
gcc_assert (as); 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->class_ok = attr->dummy || attr->pointer || attr->allocatable
|| attr->select_type_temporary; || attr->select_type_temporary;
if (!attr->class_ok) if (!attr->class_ok)
/* We can not build the class container yet. */ /* We can not build the class container yet. */
return SUCCESS; return SUCCESS;
@ -539,17 +575,28 @@ gfc_build_class_symbol (gfc_typespec *ts, symbol_attribute *attr,
else else
sprintf (name, "__class_%s", tname); 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) if (fclass == NULL)
{ {
gfc_symtree *st; gfc_symtree *st;
/* If not there, create a new symbol. */ /* If not there, create a new symbol. */
fclass = gfc_new_symbol (name, ts->u.derived->ns); fclass = gfc_new_symbol (name, ns);
st = gfc_new_symtree (&ts->u.derived->ns->sym_root, name); st = gfc_new_symtree (&ns->sym_root, name);
st->n.sym = fclass; st->n.sym = fclass;
gfc_set_sym_referenced (fclass); gfc_set_sym_referenced (fclass);
fclass->refs++; fclass->refs++;
fclass->ts.type = BT_UNKNOWN; fclass->ts.type = BT_UNKNOWN;
if (!ts->u.derived->attr.unlimited_polymorphic)
fclass->attr.abstract = ts->u.derived->attr.abstract; fclass->attr.abstract = ts->u.derived->attr.abstract;
fclass->f2k_derived = gfc_get_namespace (NULL, 0); fclass->f2k_derived = gfc_get_namespace (NULL, 0);
if (gfc_add_flavor (&fclass->attr, FL_DERIVED, 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.allocatable = attr->allocatable;
c->attr.dimension = attr->dimension; c->attr.dimension = attr->dimension;
c->attr.codimension = attr->codimension; c->attr.codimension = attr->codimension;
c->attr.abstract = ts->u.derived->attr.abstract; c->attr.abstract = fclass->attr.abstract;
c->as = (*as); c->as = (*as);
c->initializer = NULL; c->initializer = NULL;
@ -591,17 +638,21 @@ gfc_build_class_symbol (gfc_typespec *ts, symbol_attribute *attr,
c->attr.pointer = 1; c->attr.pointer = 1;
} }
/* Since the extension field is 8 bit wide, we can only have if (!ts->u.derived->attr.unlimited_polymorphic)
up to 255 extension levels. */
if (ts->u.derived->attr.extension == 255)
{ {
gfc_error ("Maximum extension level reached with type '%s' at %L", /* Since the extension field is 8 bit wide, we can only have
ts->u.derived->name, &ts->u.derived->declared_at); up to 255 extension levels. */
return FAILURE; 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; fclass->attr.is_class = 1;
ts->u.derived = fclass; ts->u.derived = fclass;
attr->allocatable = attr->pointer = attr->dimension = attr->codimension = 0; 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) if (tb->non_overridable)
return; return;
c = gfc_find_component (vtype, name, true, true); c = gfc_find_component (vtype, name, true, true);
if (c == NULL) if (c == NULL)
@ -670,7 +721,7 @@ add_procs_to_declared_vtab1 (gfc_symtree *st, gfc_symbol *vtype)
if (st->right) if (st->right)
add_procs_to_declared_vtab1 (st->right, vtype); 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) && !st->n.tb->is_generic && st->n.tb->u.specific)
add_proc_comp (vtype, st->name, st->n.tb); 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 *vtab = NULL, *vtype = NULL, *found_sym = NULL, *def_init = NULL;
gfc_symbol *copy = NULL, *src = NULL, *dst = 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) for (ns = gfc_current_ns; ns; ns = ns->parent)
if (!ns->parent) if (!ns->parent)
break; break;
/* If the type is a class container, use the underlying derived type. */ /* 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); derived = gfc_get_derived_super_type (derived);
if (ns) if (ns)
{ {
char name[GFC_MAX_SYMBOL_LEN+1], tname[GFC_MAX_SYMBOL_LEN+1]; 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; goto cleanup;
c->attr.pointer = 1; c->attr.pointer = 1;
c->attr.access = ACCESS_PRIVATE; 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) if (parent)
{ {
parent_vtab = gfc_find_derived_vtab (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); 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. /* At this point an error must have occurred.
Prevent further errors on the vtype components. */ Prevent further errors on the vtype components. */
@ -1878,7 +1935,8 @@ gfc_find_derived_vtab (gfc_symbol *derived)
c->attr.access = ACCESS_PRIVATE; c->attr.access = ACCESS_PRIVATE;
c->ts.type = BT_DERIVED; c->ts.type = BT_DERIVED;
c->ts.u.derived = 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); c->initializer = gfc_get_null_expr (NULL);
else else
{ {
@ -1905,7 +1963,8 @@ gfc_find_derived_vtab (gfc_symbol *derived)
c->attr.access = ACCESS_PRIVATE; c->attr.access = ACCESS_PRIVATE;
c->tb = XCNEW (gfc_typebound_proc); c->tb = XCNEW (gfc_typebound_proc);
c->tb->ppc = 1; c->tb->ppc = 1;
if (derived->attr.abstract) if (derived->attr.unlimited_polymorphic
|| derived->attr.abstract)
c->initializer = gfc_get_null_expr (NULL); c->initializer = gfc_get_null_expr (NULL);
else else
{ {
@ -1966,7 +2025,7 @@ gfc_find_derived_vtab (gfc_symbol *derived)
Note: The actual wrapper function can only be generated Note: The actual wrapper function can only be generated
at resolution time. */ at resolution time. */
/* FIXME: Enable ABI-breaking "_final" generation. */ /* FIXME: Enable ABI-breaking "_final" generation. */
if (0) if (0)
{ {
if (gfc_add_component (vtype, "_final", &c) == FAILURE) if (gfc_add_component (vtype, "_final", &c) == FAILURE)
goto cleanup; goto cleanup;
@ -1978,7 +2037,8 @@ gfc_find_derived_vtab (gfc_symbol *derived)
} }
/* Add procedure pointers for type-bound procedures. */ /* 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: 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 /* General worker function to find either a type-bound procedure or a
type-bound user operator. */ 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. */ /* Try to find it in the current type's namespace. */
if (derived->f2k_derived) if (derived->f2k_derived)
res = derived->f2k_derived->tb_op[op]; res = derived->f2k_derived->tb_op[op];
else else
res = NULL; res = NULL;
/* Check access. */ /* 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; return MATCH_ERROR;
else if (m == MATCH_YES) 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; 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); m = gfc_match (" class ( %n )", name);
if (m != MATCH_YES) if (m != MATCH_YES)
@ -4248,6 +4276,10 @@ gfc_match_data_decl (void)
goto cleanup; 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) if ((current_ts.type == BT_DERIVED || current_ts.type == BT_CLASS)
&& current_ts.u.derived->components == NULL && current_ts.u.derived->components == NULL
&& !current_ts.u.derived->attr.zero_comp) && !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; mpz_t *new_shape, *s;
int i, n; int i, n;
if (shape == NULL if (shape == NULL
|| rank <= 1 || rank <= 1
|| dim == NULL || dim == NULL
|| dim->expr_type != EXPR_CONSTANT || dim->expr_type != EXPR_CONSTANT
|| dim->ts.type != BT_INTEGER) || dim->ts.type != BT_INTEGER)
return NULL; return NULL;
@ -1389,7 +1389,7 @@ find_array_section (gfc_expr *expr, gfc_ref *ref)
gcc_assert (begin->rank == 1); gcc_assert (begin->rank == 1);
/* Zero-sized arrays have no shape and no elements, stop early. */ /* Zero-sized arrays have no shape and no elements, stop early. */
if (!begin->shape) if (!begin->shape)
{ {
mpz_init_set_ui (nelts, 0); mpz_init_set_ui (nelts, 0);
break; 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 /* An element reference reduces the rank of the expression; don't
add anything to the shape array. */ 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); mpz_set (expr->shape[shape_i++], tmp_mpz);
} }
@ -1520,7 +1520,7 @@ find_array_section (gfc_expr *expr, gfc_ref *ref)
} }
else 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 if (mpz_cmp_ui (stride[d], 0) > 0
? mpz_cmp (ctr[d], end[d]) > 0 ? mpz_cmp (ctr[d], end[d]) > 0
@ -1952,7 +1952,7 @@ scalarize_intrinsic_call (gfc_expr *e)
gfc_constructor *ci, *new_ctor; gfc_constructor *ci, *new_ctor;
gfc_expr *expr, *old; gfc_expr *expr, *old;
int n, i, rank[5], array_arg; int n, i, rank[5], array_arg;
/* Find which, if any, arguments are arrays. Assume that the old /* Find which, if any, arguments are arrays. Assume that the old
expression carries the type information and that the first arg expression carries the type information and that the first arg
that is an array expression carries all the shape information.*/ 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: case INTRINSIC_LE_OS:
if ((*check_function) (op2) == FAILURE) if ((*check_function) (op2) == FAILURE)
return FAILURE; return FAILURE;
if (!(et0 (op1) == BT_CHARACTER && et0 (op2) == BT_CHARACTER) if (!(et0 (op1) == BT_CHARACTER && et0 (op2) == BT_CHARACTER)
&& !(numeric_type (et0 (op1)) && numeric_type (et0 (op2)))) && !(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; 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; ? inquiry_func_f2003 : inquiry_func_f95;
for (i = 0; functions[i]; i++) for (i = 0; functions[i]; i++)
@ -2360,7 +2360,7 @@ check_transformational (gfc_expr *e)
name = e->symtree->n.sym->name; 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; ? trans_func_f2003 : trans_func_f95;
/* NULL() is dealt with below. */ /* 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.subroutine)
|| gfc_current_ns->parent->proc_name->attr.is_main_program)) || 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) if (!gfc_current_ns->proc_name->attr.function)
bad_proc = true; 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 (rvalue->expr_type == EXPR_NULL)
{ {
if (has_pointer && (ref == NULL || ref->next == NULL) if (has_pointer && (ref == NULL || ref->next == NULL)
&& lvalue->symtree->n.sym->attr.data) && lvalue->symtree->n.sym->attr.data)
return SUCCESS; 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(). */ /* 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->expr_type == EXPR_FUNCTION
&& rvalue->symtree->n.sym->attr.pointer) && rvalue->symtree->n.sym->attr.pointer)
gfc_warning ("POINTER valued function appears on right-hand side of " 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); mpfr_init (rv);
gfc_set_model_kind (rvalue->ts.kind); gfc_set_model_kind (rvalue->ts.kind);
mpfr_init (diff); mpfr_init (diff);
mpfr_set (rv, rvalue->value.real, GFC_RND_MODE); mpfr_set (rv, rvalue->value.real, GFC_RND_MODE);
mpfr_sub (diff, rv, rvalue->value.real, GFC_RND_MODE); mpfr_sub (diff, rv, rvalue->value.real, GFC_RND_MODE);
if (!mpfr_zero_p (diff)) if (!mpfr_zero_p (diff))
gfc_warning ("Change of value in conversion from " gfc_warning ("Change of value in conversion from "
" %s to %s at %L", gfc_typename (&rvalue->ts), " %s to %s at %L", gfc_typename (&rvalue->ts),
gfc_typename (&lvalue->ts), &rvalue->where); gfc_typename (&lvalue->ts), &rvalue->where);
mpfr_clear (rv); mpfr_clear (rv);
mpfr_clear (diff); 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)) if (!gfc_compare_types (&lvalue->ts, &rvalue->ts))
{ {
gfc_error ("Different types in pointer assignment at %L; attempted " /* Check for F03:C717. */
"assignment of %s to %s", &lvalue->where, if (UNLIMITED_POLY (rvalue)
gfc_typename (&rvalue->ts), gfc_typename (&lvalue->ts)); && !(UNLIMITED_POLY (lvalue)
|| (lvalue->ts.type == BT_DERIVED
&& (lvalue->ts.u.derived->attr.is_bind_c
|| lvalue->ts.u.derived->attr.sequence))))
gfc_error ("Data-pointer-object &L must be unlimited "
"polymorphic, a sequence derived type or of a "
"type with the BIND attribute assignment at %L "
"to be compatible with an unlimited polymorphic "
"target", &lvalue->where);
else
gfc_error ("Different types in pointer assignment at %L; "
"attempted assignment of %s to %s", &lvalue->where,
gfc_typename (&rvalue->ts),
gfc_typename (&lvalue->ts));
return FAILURE; return FAILURE;
} }
@ -3569,9 +3582,11 @@ gfc_check_pointer_assign (gfc_expr *lvalue, gfc_expr *rvalue)
return FAILURE; return FAILURE;
} }
if (lvalue->ts.type == BT_CLASS && rvalue->ts.type == BT_DERIVED)
/* Make sure the vtab is present. */ /* 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); 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. */ /* Check rank remapping. */
if (rank_remap) 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)) if (is_implicit_pure && gfc_impure_variable (rvalue->symtree->n.sym))
gfc_current_ns->proc_name->attr.implicit_pure = 0; gfc_current_ns->proc_name->attr.implicit_pure = 0;
if (gfc_has_vector_index (rvalue)) if (gfc_has_vector_index (rvalue))
{ {
@ -3747,7 +3762,7 @@ gfc_check_assign_symbol (gfc_symbol *sym, gfc_expr *rvalue)
if (r == FAILURE) if (r == FAILURE)
return r; return r;
if (sym->attr.pointer && rvalue->expr_type != EXPR_NULL) if (sym->attr.pointer && rvalue->expr_type != EXPR_NULL)
{ {
/* F08:C461. Additional checks for pointer initialization. */ /* F08:C461. Additional checks for pointer initialization. */
@ -3772,7 +3787,7 @@ gfc_check_assign_symbol (gfc_symbol *sym, gfc_expr *rvalue)
return FAILURE; return FAILURE;
} }
} }
if (sym->attr.proc_pointer && rvalue->expr_type != EXPR_NULL) if (sym->attr.proc_pointer && rvalue->expr_type != EXPR_NULL)
{ {
/* F08:C1220. Additional checks for procedure pointer initialization. */ /* 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 static bool
replace_symbol (gfc_expr *expr, gfc_symbol *sym, int *i ATTRIBUTE_UNUSED) 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 || (expr->expr_type == EXPR_FUNCTION
&& !gfc_is_intrinsic (expr->symtree->n.sym, 0, expr->where))) && !gfc_is_intrinsic (expr->symtree->n.sym, 0, expr->where)))
&& expr->symtree->n.sym->ns == sym->ts.interface->formal_ns && 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; gfc_component *comp;
comp = (gfc_component *)sym; comp = (gfc_component *)sym;
if ((expr->expr_type == EXPR_VARIABLE if ((expr->expr_type == EXPR_VARIABLE
|| (expr->expr_type == EXPR_FUNCTION || (expr->expr_type == EXPR_FUNCTION
&& !gfc_is_intrinsic (expr->symtree->n.sym, 0, expr->where))) && !gfc_is_intrinsic (expr->symtree->n.sym, 0, expr->where)))
&& expr->symtree->n.sym->ns == comp->ts.interface->formal_ns) && 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) if (e->ts.type == BT_CLASS && e->ts.u.derived->components)
corank = e->ts.u.derived->components->as corank = e->ts.u.derived->components->as
? e->ts.u.derived->components->as->corank : 0; ? e->ts.u.derived->components->as->corank : 0;
else else
corank = e->symtree->n.sym->as ? e->symtree->n.sym->as->corank : 0; corank = e->symtree->n.sym->as ? e->symtree->n.sym->as->corank : 0;
for (ref = e->ref; ref; ref = ref->next) for (ref = e->ref; ref; ref = ref->next)
@ -4478,7 +4493,7 @@ gfc_has_ultimate_pointer (gfc_expr *e)
for (ref = e->ref; ref; ref = ref->next) for (ref = e->ref; ref; ref = ref->next)
if (ref->type == REF_COMPONENT) if (ref->type == REF_COMPONENT)
last = ref; last = ref;
if (last && last->u.c.component->ts.type == BT_CLASS) if (last && last->u.c.component->ts.type == BT_CLASS)
return CLASS_DATA (last->u.c.component)->attr.pointer_comp; return CLASS_DATA (last->u.c.component)->attr.pointer_comp;
else if (last && last->u.c.component->ts.type == BT_DERIVED) 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)) ar->as->upper[i]->value.integer) != 0))
colon = false; colon = false;
} }
return true; return true;
} }
@ -4618,7 +4633,7 @@ gfc_build_intrinsic_call (const char* name, locus where, unsigned numarg, ...)
isym = gfc_find_function (name); isym = gfc_find_function (name);
gcc_assert (isym); gcc_assert (isym);
result = gfc_get_expr (); result = gfc_get_expr ();
result->expr_type = EXPR_FUNCTION; result->expr_type = EXPR_FUNCTION;
result->ts = isym->ts; result->ts = isym->ts;
@ -4669,6 +4684,7 @@ gfc_check_vardef_context (gfc_expr* e, bool pointer, bool alloc_obj,
bool is_pointer; bool is_pointer;
bool check_intentin; bool check_intentin;
bool ptr_component; bool ptr_component;
bool unlimited;
symbol_attribute attr; symbol_attribute attr;
gfc_ref* ref; 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; 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); attr = gfc_expr_attr (e);
if (!pointer && e->expr_type == EXPR_FUNCTION && attr.pointer) 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 /* Find out whether the expr is a pointer; this also means following
component references to the last one. */ component references to the last one. */
is_pointer = (attr.pointer || attr.proc_pointer); is_pointer = (attr.pointer || attr.proc_pointer);
if (pointer && !is_pointer) if (pointer && !is_pointer && !unlimited)
{ {
if (context) if (context)
gfc_error ("Non-POINTER in pointer association context (%s)" 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, components or private components, procedure pointer components,
possibly nested. zero_comp is true if the derived type has no possibly nested. zero_comp is true if the derived type has no
component at all. defined_assign_comp is true if the derived 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, unsigned alloc_comp:1, pointer_comp:1, proc_pointer_comp:1,
private_comp:1, zero_comp:1, coarray_comp:1, lock_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. */ /* This is a temporary selector for SELECT TYPE. */
unsigned select_type_temporary:1; unsigned select_type_temporary:1;
@ -1271,7 +1273,6 @@ typedef struct gfc_symbol
} }
gfc_symbol; gfc_symbol;
/* This structure is used to keep track of symbols in common blocks. */ /* This structure is used to keep track of symbols in common blocks. */
typedef struct gfc_common_head 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_array_ref (gfc_expr *, bool *);
bool gfc_is_class_scalar_expr (gfc_expr *); bool gfc_is_class_scalar_expr (gfc_expr *);
bool gfc_is_class_container_ref (gfc_expr *e); 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 *); unsigned int gfc_hash_value (gfc_symbol *);
gfc_try gfc_build_class_symbol (gfc_typespec *, symbol_attribute *, gfc_try gfc_build_class_symbol (gfc_typespec *, symbol_attribute *,
gfc_array_spec **, bool); gfc_array_spec **, bool);
gfc_symbol *gfc_find_derived_vtab (gfc_symbol *); 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*, gfc_symtree* gfc_find_typebound_proc (gfc_symbol*, gfc_try*,
const char*, bool, locus*); const char*, bool, locus*);
gfc_symtree* gfc_find_typebound_user_op (gfc_symbol*, gfc_try*, 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 **); bool gfc_is_finalizable (gfc_symbol *, gfc_expr **);
#define CLASS_DATA(sym) sym->ts.u.derived->components #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 */ /* 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)) if (gfc_get_symbol (name, NULL, &sym))
return MATCH_ERROR; return MATCH_ERROR;
if (!sym->attr.generic if (!sym->attr.generic
&& gfc_add_generic (&sym->attr, sym->name, NULL) == FAILURE) && gfc_add_generic (&sym->attr, sym->name, NULL) == FAILURE)
return MATCH_ERROR; return MATCH_ERROR;
@ -351,7 +351,7 @@ gfc_match_end_interface (void)
gfc_error ("Expecting 'END INTERFACE OPERATOR (%s)' at %C, " gfc_error ("Expecting 'END INTERFACE OPERATOR (%s)' at %C, "
"but got %s", s1, s2); "but got %s", s1, s2);
} }
} }
break; 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) if (dt1->attr.dimension && gfc_compare_array_spec (dt1->as, dt2->as) == 0)
return 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! */ endless recursive loop! */
if (!(dt1->ts.type == BT_DERIVED && derived1 == dt1->ts.u.derived) if (!(dt1->ts.type == BT_DERIVED && derived1 == dt1->ts.u.derived)
&& !(dt2->ts.type == BT_DERIVED && derived2 == dt2->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. */ that is for the formal arg, but oh well. */
if (ts1->type == BT_VOID || ts2->type == BT_VOID) if (ts1->type == BT_VOID || ts2->type == BT_VOID)
return 1; 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 if (ts1->type != ts2->type
&& ((ts1->type != BT_DERIVED && ts1->type != BT_CLASS) && ((ts1->type != BT_DERIVED && ts1->type != BT_CLASS)
|| (ts2->type != BT_DERIVED && ts2->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 0; /* Ranks differ. */
return gfc_compare_types (&s1->ts, &s2->ts) 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; return SUCCESS;
} }
@ -1403,6 +1413,9 @@ gfc_compare_interfaces (gfc_symbol *s1, gfc_symbol *s2, const char *name2,
return 0; return 0;
} }
if (UNLIMITED_POLY (f1->sym))
goto next;
if (strict_flag) if (strict_flag)
{ {
/* Check all characteristics. */ /* Check all characteristics. */
@ -1418,7 +1431,7 @@ gfc_compare_interfaces (gfc_symbol *s1, gfc_symbol *s2, const char *name2,
f1->sym->name); f1->sym->name);
return 0; return 0;
} }
next:
f1 = f1->next; f1 = f1->next;
f2 = f2->next; f2 = f2->next;
} }
@ -1712,7 +1725,7 @@ gfc_check_interfaces (gfc_namespace *ns)
for (ns2 = ns; ns2; ns2 = ns2->parent) for (ns2 = ns; ns2; ns2 = ns2->parent)
{ {
gfc_intrinsic_op other_op; gfc_intrinsic_op other_op;
if (check_interface1 (ns->op[i], ns2->op[i], 0, if (check_interface1 (ns->op[i], ns2->op[i], 0,
interface_name, true)) interface_name, true))
goto done; goto done;
@ -1814,7 +1827,7 @@ argument_rank_mismatch (const char *name, locus *where,
"(rank-%d and scalar)", name, where, rank1); "(rank-%d and scalar)", name, where, rank1);
} }
else else
{ {
gfc_error ("Rank mismatch in argument '%s' at %L " gfc_error ("Rank mismatch in argument '%s' at %L "
"(rank-%d and rank-%d)", name, where, rank1, rank2); "(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 && formal->ts.type != BT_ASSUMED
&& !gfc_compare_types (&formal->ts, &actual->ts) && !gfc_compare_types (&formal->ts, &actual->ts)
&& !(formal->ts.type == BT_DERIVED && actual->ts.type == BT_CLASS && !(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))) CLASS_DATA (actual)->ts.u.derived)))
{ {
if (where) 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 (formal->attr.codimension && !gfc_is_coarray (actual))
{ {
if (where) if (where)
@ -2078,7 +2108,7 @@ compare_parameter (gfc_symbol *formal, gfc_expr *actual,
is_pointer = ref->u.c.component->attr.pointer; is_pointer = ref->u.c.component->attr.pointer;
else if (ref->type == REF_ARRAY && ref->u.ar.type == AR_ELEMENT else if (ref->type == REF_ARRAY && ref->u.ar.type == AR_ELEMENT
&& ref->u.ar.dimen > 0 && ref->u.ar.dimen > 0
&& (!ref->next && (!ref->next
|| (ref->next->type == REF_SUBSTRING && !ref->next->next))) || (ref->next->type == REF_SUBSTRING && !ref->next->next)))
break; break;
} }
@ -2156,7 +2186,7 @@ get_sym_storage_size (gfc_symbol *sym)
return 0; return 0;
} }
else else
strlen = 1; strlen = 1;
if (symbol_rank (sym) == 0) if (symbol_rank (sym) == 0)
return strlen; return strlen;
@ -2194,7 +2224,7 @@ get_expr_storage_size (gfc_expr *e)
if (e == NULL) if (e == NULL)
return 0; return 0;
if (e->ts.type == BT_CHARACTER) if (e->ts.type == BT_CHARACTER)
{ {
if (e->ts.u.cl && e->ts.u.cl->length 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; 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 if (a->expr->expr_type == EXPR_NULL
&& ((f->sym->ts.type != BT_CLASS && !f->sym->attr.pointer && ((f->sym->ts.type != BT_CLASS && !f->sym->attr.pointer
&& (f->sym->attr.allocatable || !f->sym->attr.optional && (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; return 0;
} }
if (!compare_parameter (f->sym, a->expr, ranks_must_agree, if (!compare_parameter (f->sym, a->expr, ranks_must_agree,
is_elemental, where)) is_elemental, where))
return 0; 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); "pointer dummy '%s'", &a->expr->where,f->sym->name);
return 0; return 0;
} }
/* Fortran 2008, C1242. */ /* Fortran 2008, C1242. */
if (f->sym->attr.pointer && gfc_is_coindexed (a->expr)) 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; has_null_arg = true;
null_expr_loc = a->expr->where; null_expr_loc = a->expr->where;
break; break;
} }
for (; intr; intr = intr->next) 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 /* 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) if (intr->sym->attr.elemental)
{ {
elem_sym = intr->sym; elem_sym = intr->sym;
@ -3613,7 +3650,7 @@ gfc_extend_expr (gfc_expr *e)
tbo = matching_typebound_op (&tb_base, actual, i, NULL, &gname); tbo = matching_typebound_op (&tb_base, actual, i, NULL, &gname);
break; break;
} }
/* If there is a matching typebound-operator, replace the expression with /* If there is a matching typebound-operator, replace the expression with
a call to it and succeed. */ a call to it and succeed. */
if (tbo) if (tbo)
@ -3703,7 +3740,7 @@ gfc_extend_assign (gfc_code *c, gfc_namespace *ns)
/* See if we find a matching type-bound assignment. */ /* See if we find a matching type-bound assignment. */
tbo = matching_typebound_op (&tb_base, actual, tbo = matching_typebound_op (&tb_base, actual,
INTRINSIC_ASSIGN, NULL, &gname); INTRINSIC_ASSIGN, NULL, &gname);
/* If there is one, replace the expression with a call to it and /* If there is one, replace the expression with a call to it and
succeed. */ succeed. */
if (tbo) if (tbo)
@ -4028,7 +4065,7 @@ gfc_check_typebound_override (gfc_symtree* proc, gfc_symtree* old)
" FUNCTION", proc->name, &where); " FUNCTION", proc->name, &where);
return FAILURE; return FAILURE;
} }
if (check_result_characteristics (proc_target, old_target, if (check_result_characteristics (proc_target, old_target,
err, sizeof(err)) == FAILURE) 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; size_t i = 0;
gfc_char_t c; gfc_char_t c;
char* buf; char* buf;
size_t cursz = 16; size_t cursz = 16;
old_loc = gfc_current_locus; old_loc = gfc_current_locus;
gfc_gobble_whitespace (); gfc_gobble_whitespace ();
@ -605,7 +605,7 @@ gfc_match_name_C (const char **buffer)
gfc_current_locus = old_loc; gfc_current_locus = old_loc;
return MATCH_YES; return MATCH_YES;
} }
if (!ISALPHA (c) && c != '_') if (!ISALPHA (c) && c != '_')
{ {
gfc_error ("Invalid C name in NAME= specifier at %C"); gfc_error ("Invalid C name in NAME= specifier at %C");
@ -625,9 +625,9 @@ gfc_match_name_C (const char **buffer)
cursz *= 2; cursz *= 2;
buf = XRESIZEVEC (char, buf, cursz); buf = XRESIZEVEC (char, buf, cursz);
} }
old_loc = gfc_current_locus; old_loc = gfc_current_locus;
/* Get next char; param means we're in a string. */ /* Get next char; param means we're in a string. */
c = gfc_next_char_literal (INSTRING_WARN); c = gfc_next_char_literal (INSTRING_WARN);
} while (ISALNUM (c) || c == '_'); } while (ISALNUM (c) || c == '_');
@ -650,7 +650,7 @@ gfc_match_name_C (const char **buffer)
return MATCH_ERROR; return MATCH_ERROR;
} }
} }
/* If we stopped because we had an invalid character for a C name, report /* If we stopped because we had an invalid character for a C name, report
that to the user by returning MATCH_NO. */ that to the user by returning MATCH_NO. */
if (c != '"' && c != '\'') 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, /* Match an intrinsic operator. Returns an INTRINSIC enum. While matching,
we always find INTRINSIC_PLUS before INTRINSIC_UPLUS. We work around this we always find INTRINSIC_PLUS before INTRINSIC_UPLUS. We work around this
in matchexp.c. */ in matchexp.c. */
match match
@ -1441,7 +1441,7 @@ gfc_match_if (gfc_statement *if_type)
old_loc2 = gfc_current_locus; old_loc2 = gfc_current_locus;
gfc_current_locus = old_loc; gfc_current_locus = old_loc;
if (gfc_match_parens () == MATCH_ERROR) if (gfc_match_parens () == MATCH_ERROR)
return MATCH_ERROR; return MATCH_ERROR;
@ -1473,7 +1473,7 @@ gfc_match_if (gfc_statement *if_type)
gfc_free_expr (expr); gfc_free_expr (expr);
return MATCH_ERROR; return MATCH_ERROR;
} }
if (gfc_notify_std (GFC_STD_F95_OBS, "Arithmetic IF " if (gfc_notify_std (GFC_STD_F95_OBS, "Arithmetic IF "
"statement at %C") == FAILURE) "statement at %C") == FAILURE)
return MATCH_ERROR; return MATCH_ERROR;
@ -1579,7 +1579,7 @@ gfc_match_if (gfc_statement *if_type)
match ("write", gfc_match_write, ST_WRITE) match ("write", gfc_match_write, ST_WRITE)
/* The gfc_match_assignment() above may have returned a MATCH_NO /* 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. */ special case here. */
m = gfc_match_assignment (); m = gfc_match_assignment ();
if (m == MATCH_NO) if (m == MATCH_NO)
@ -1907,7 +1907,7 @@ static match
match_derived_type_spec (gfc_typespec *ts) match_derived_type_spec (gfc_typespec *ts)
{ {
char name[GFC_MAX_SYMBOL_LEN + 1]; char name[GFC_MAX_SYMBOL_LEN + 1];
locus old_locus; locus old_locus;
gfc_symbol *derived; gfc_symbol *derived;
old_locus = gfc_current_locus; old_locus = gfc_current_locus;
@ -1930,7 +1930,7 @@ match_derived_type_spec (gfc_typespec *ts)
return MATCH_YES; return MATCH_YES;
} }
gfc_current_locus = old_locus; gfc_current_locus = old_locus;
return MATCH_NO; return MATCH_NO;
} }
@ -2194,7 +2194,7 @@ cleanup:
return MATCH_ERROR; 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. */ IF statement. */
static match static match
@ -2373,7 +2373,7 @@ gfc_match_do (void)
return MATCH_NO; return MATCH_NO;
/* Check for balanced parens. */ /* Check for balanced parens. */
if (gfc_match_parens () == MATCH_ERROR) if (gfc_match_parens () == MATCH_ERROR)
return 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) " do-construct-name at %C") == FAILURE)
return MATCH_ERROR; return MATCH_ERROR;
break; break;
default: default:
gfc_error ("%s statement at %C is not applicable to construct '%s'", gfc_error ("%s statement at %C is not applicable to construct '%s'",
gfc_ascii_statement (st), sym->name); gfc_ascii_statement (st), sym->name);
@ -3265,7 +3265,7 @@ gfc_match_goto (void)
return MATCH_YES; return MATCH_YES;
} }
/* The assigned GO TO statement. */ /* The assigned GO TO statement. */
if (gfc_match_variable (&expr, 0) == MATCH_YES) if (gfc_match_variable (&expr, 0) == MATCH_YES)
{ {
@ -3432,6 +3432,7 @@ gfc_match_allocate (void)
match m; match m;
locus old_locus, deferred_locus; locus old_locus, deferred_locus;
bool saw_stat, saw_errmsg, saw_source, saw_mold, saw_deferred, b1, b2, b3; bool saw_stat, saw_errmsg, saw_source, saw_mold, saw_deferred, b1, b2, b3;
bool saw_unlimited = false;
head = tail = NULL; head = tail = NULL;
stat = errmsg = source = mold = tmp = NULL; stat = errmsg = source = mold = tmp = NULL;
@ -3573,7 +3574,7 @@ gfc_match_allocate (void)
} }
/* Enforce F03:C627. */ /* 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 " gfc_error ("Kind type parameter for entity at %L differs from "
"the kind type parameter of the typespec", "the kind type parameter of the typespec",
@ -3585,6 +3586,8 @@ gfc_match_allocate (void)
if (tail->expr->ts.type == BT_DERIVED) if (tail->expr->ts.type == BT_DERIVED)
tail->expr->ts.u.derived = gfc_use_derived (tail->expr->ts.u.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) if (gfc_peek_ascii_char () == '(' && !sym->attr.dimension)
{ {
gfc_error ("Shape specification for allocatable scalar at %C"); 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); gfc_error ("Redundant MOLD tag found at %L ", &tmp->where);
goto cleanup; goto cleanup;
} }
/* Check F08:C637. */ /* Check F08:C637. */
if (ts.type != BT_UNKNOWN) if (ts.type != BT_UNKNOWN)
{ {
@ -3739,7 +3742,20 @@ alloc_opt_list:
&deferred_locus); &deferred_locus);
goto cleanup; 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.op = EXEC_ALLOCATE;
new_st.expr1 = stat; new_st.expr1 = stat;
new_st.expr2 = errmsg; 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. */ matched and var found to be a derived-type variable. */
static match static match
@ -4081,7 +4097,7 @@ match_typebound_call (gfc_symtree* varst)
base->symtree = varst; base->symtree = varst;
base->where = gfc_current_locus; base->where = gfc_current_locus;
gfc_set_sym_referenced (varst->n.sym); gfc_set_sym_referenced (varst->n.sym);
m = gfc_match_varspec (base, 0, true, true); m = gfc_match_varspec (base, 0, true, true);
if (m == MATCH_NO) if (m == MATCH_NO)
gfc_error ("Expected component reference at %C"); gfc_error ("Expected component reference at %C");
@ -4258,7 +4274,7 @@ cleanup:
/* Given a name, return a pointer to the common head structure, /* Given a name, return a pointer to the common head structure,
creating it if it does not exist. If FROM_MODULE is nonzero, we 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. in the using namespace.
TODO: Add to global symbol tree. */ TODO: Add to global symbol tree. */
@ -4403,7 +4419,7 @@ gfc_match_common (void)
/* Store a ref to the common block for error checking. */ /* Store a ref to the common block for error checking. */
sym->common_block = t; sym->common_block = t;
sym->common_block->refs++; sym->common_block->refs++;
/* See if we know the current common block is bind(c), and if /* 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 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 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, sym->name, &(sym->declared_at), t->name,
t->name); t->name);
} }
if (sym->attr.is_bind_c == 1) if (sym->attr.is_bind_c == 1)
gfc_error_now ("Variable '%s' in common block " gfc_error_now ("Variable '%s' in common block "
"'%s' at %C can not be bind(c) since " "'%s' at %C can not be bind(c) since "
"it is not global", sym->name, t->name); "it is not global", sym->name, t->name);
} }
if (sym->attr.in_common) if (sym->attr.in_common)
{ {
gfc_error ("Symbol '%s' at %C is already in a COMMON block", 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 /* Check that a statement function is not recursive. This is done by looking
for the statement function symbol(sym) by looking recursively through its 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 12.5.4 requires that any variable of function that is implicitly typed
shall have that type confirmed by any subsequent type declaration. The shall have that type confirmed by any subsequent type declaration. The
implicit typing is conveniently done here. */ 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 . */ /* Set up a temporary for the current TYPE IS / CLASS IS branch . */
static void static void
select_type_set_tmp (gfc_typespec *ts) select_type_set_tmp (gfc_typespec *ts)
{ {
char name[GFC_MAX_SYMBOL_LEN]; char name[GFC_MAX_SYMBOL_LEN];
gfc_symtree *tmp; gfc_symtree *tmp = NULL;
if (!ts) if (!ts)
{ {
select_type_stack->tmp = NULL; select_type_stack->tmp = NULL;
return; return;
} }
if (!gfc_type_is_extensible (ts->u.derived))
return;
if (ts->type == BT_CLASS) tmp = select_intrinsic_set_tmp (ts);
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 if (tmp == NULL)
&& select_type_stack->selector->attr.class_ok)
{ {
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; = CLASS_DATA (select_type_stack->selector)->attr.class_pointer;
/* Copy across the array spec to the selector. */ /* Copy across the array spec to the selector. */
if ((CLASS_DATA (select_type_stack->selector)->attr.dimension if (CLASS_DATA (select_type_stack->selector)->attr.dimension
|| CLASS_DATA (select_type_stack->selector)->attr.codimension)) || CLASS_DATA (select_type_stack->selector)->attr.codimension)
{ {
tmp->n.sym->attr.dimension tmp->n.sym->attr.dimension
= CLASS_DATA (select_type_stack->selector)->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; = 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_copy_array_spec (CLASS_DATA (select_type_stack->selector)->as);
} }
} }
gfc_set_sym_referenced (tmp->n.sym); gfc_set_sym_referenced (tmp->n.sym);
@ -5257,6 +5326,7 @@ select_type_set_tmp (gfc_typespec *ts)
if (ts->type == BT_CLASS) if (ts->type == BT_CLASS)
gfc_build_class_symbol (&tmp->n.sym->ts, &tmp->n.sym->attr, gfc_build_class_symbol (&tmp->n.sym->ts, &tmp->n.sym->attr,
&tmp->n.sym->as, false); &tmp->n.sym->as, false);
}
/* Add an association for it, so the rest of the parser knows it is /* Add an association for it, so the rest of the parser knows it is
an associate-name. The target will be set during resolution. */ 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; select_type_stack->tmp = tmp;
} }
/* Match a SELECT TYPE statement. */ /* Match a SELECT TYPE statement. */
match match
@ -5356,7 +5426,7 @@ gfc_match_select_type (void)
select_type_push (expr1->symtree->n.sym); select_type_push (expr1->symtree->n.sym);
return MATCH_YES; return MATCH_YES;
cleanup: cleanup:
parent_ns = gfc_current_ns->parent; parent_ns = gfc_current_ns->parent;
gfc_free_namespace (gfc_current_ns); gfc_free_namespace (gfc_current_ns);
@ -5457,9 +5527,7 @@ gfc_match_type_is (void)
c = gfc_get_case (); c = gfc_get_case ();
c->where = gfc_current_locus; c->where = gfc_current_locus;
/* TODO: Once unlimited polymorphism is implemented, we will need to call if (match_type_spec (&c->ts) == MATCH_ERROR)
match_type_spec here. */
if (match_derived_type_spec (&c->ts) == MATCH_ERROR)
goto cleanup; goto cleanup;
if (gfc_match_char (')') != MATCH_YES) if (gfc_match_char (')') != MATCH_YES)
@ -5474,6 +5542,16 @@ gfc_match_type_is (void)
new_st.op = EXEC_SELECT_TYPE; new_st.op = EXEC_SELECT_TYPE;
new_st.ext.block.case_list = c; 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. */ /* Create temporary variable. */
select_type_set_tmp (&c->ts); select_type_set_tmp (&c->ts);
@ -5546,7 +5624,7 @@ gfc_match_class_is (void)
new_st.op = EXEC_SELECT_TYPE; new_st.op = EXEC_SELECT_TYPE;
new_st.ext.block.case_list = c; new_st.ext.block.case_list = c;
/* Create temporary variable. */ /* Create temporary variable. */
select_type_set_tmp (&c->ts); select_type_set_tmp (&c->ts);
@ -5564,7 +5642,7 @@ cleanup:
/********************* WHERE subroutines ********************/ /********************* 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 static match

10
gcc/fortran/misc.c
View File

@ -1,5 +1,6 @@
/* Miscellaneous stuff that doesn't fit anywhere else. /* 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. Free Software Foundation, Inc.
Contributed by Andy Vaught Contributed by Andy Vaught
@ -158,8 +159,11 @@ gfc_typename (gfc_typespec *ts)
sprintf (buffer, "TYPE(%s)", ts->u.derived->name); sprintf (buffer, "TYPE(%s)", ts->u.derived->name);
break; break;
case BT_CLASS: case BT_CLASS:
sprintf (buffer, "CLASS(%s)", ts = &ts->u.derived->components->ts;
ts->u.derived->components->ts.u.derived->name); if (ts->u.derived->attr.unlimited_polymorphic)
sprintf (buffer, "CLASS(*)");
else
sprintf (buffer, "CLASS(%s)", ts->u.derived->name);
break; break;
case BT_ASSUMED: case BT_ASSUMED:
sprintf (buffer, "TYPE(*)"); 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_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_IS_CLASS, AB_PROCEDURE, AB_PROC_POINTER, AB_ASYNCHRONOUS, AB_CODIMENSION,
AB_COARRAY_COMP, AB_VTYPE, AB_VTAB, AB_CONTIGUOUS, AB_CLASS_POINTER, 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; ab_attribute;
@ -1898,6 +1898,7 @@ static const mstring attr_bits[] =
minit ("VTAB", AB_VTAB), minit ("VTAB", AB_VTAB),
minit ("CLASS_POINTER", AB_CLASS_POINTER), minit ("CLASS_POINTER", AB_CLASS_POINTER),
minit ("IMPLICIT_PURE", AB_IMPLICIT_PURE), minit ("IMPLICIT_PURE", AB_IMPLICIT_PURE),
minit ("UNLIMITED_POLY", AB_UNLIMITED_POLY),
minit (NULL, -1) minit (NULL, -1)
}; };
@ -2036,6 +2037,8 @@ mio_symbol_attribute (symbol_attribute *attr)
MIO_NAME (ab_attribute) (AB_PURE, attr_bits); MIO_NAME (ab_attribute) (AB_PURE, attr_bits);
if (attr->implicit_pure) if (attr->implicit_pure)
MIO_NAME (ab_attribute) (AB_IMPLICIT_PURE, attr_bits); 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) if (attr->recursive)
MIO_NAME (ab_attribute) (AB_RECURSIVE, attr_bits); MIO_NAME (ab_attribute) (AB_RECURSIVE, attr_bits);
if (attr->always_explicit) if (attr->always_explicit)
@ -2177,6 +2180,9 @@ mio_symbol_attribute (symbol_attribute *attr)
case AB_IMPLICIT_PURE: case AB_IMPLICIT_PURE:
attr->implicit_pure = 1; attr->implicit_pure = 1;
break; break;
case AB_UNLIMITED_POLY:
attr->unlimited_polymorphic = 1;
break;
case AB_RECURSIVE: case AB_RECURSIVE:
attr->recursive = 1; attr->recursive = 1;
break; break;

107
gcc/fortran/resolve.c
View File

@ -929,6 +929,10 @@ resolve_common_vars (gfc_symbol *sym, bool named_common)
&csym->declared_at); &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) if (csym->ts.type != BT_DERIVED)
continue; continue;
@ -6898,6 +6902,7 @@ resolve_deallocate_expr (gfc_expr *e)
gfc_ref *ref; gfc_ref *ref;
gfc_symbol *sym; gfc_symbol *sym;
gfc_component *c; gfc_component *c;
bool unlimited;
if (gfc_resolve_expr (e) == FAILURE) if (gfc_resolve_expr (e) == FAILURE)
return FAILURE; return FAILURE;
@ -6906,6 +6911,7 @@ resolve_deallocate_expr (gfc_expr *e)
goto bad; goto bad;
sym = e->symtree->n.sym; sym = e->symtree->n.sym;
unlimited = UNLIMITED_POLY(sym);
if (sym->ts.type == BT_CLASS) if (sym->ts.type == BT_CLASS)
{ {
@ -6950,7 +6956,7 @@ resolve_deallocate_expr (gfc_expr *e)
attr = gfc_expr_attr (e); attr = gfc_expr_attr (e);
if (allocatable == 0 && attr.pointer == 0) if (allocatable == 0 && attr.pointer == 0 && !unlimited)
{ {
bad: bad:
gfc_error ("Allocate-object at %L must be ALLOCATABLE or a POINTER", 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 i, pointer, allocatable, dimension, is_abstract;
int codimension; int codimension;
bool coindexed; bool coindexed;
bool unlimited;
symbol_attribute attr; symbol_attribute attr;
gfc_ref *ref, *ref2; gfc_ref *ref, *ref2;
gfc_expr *e2; gfc_expr *e2;
@ -7149,6 +7156,9 @@ resolve_allocate_expr (gfc_expr *e, gfc_code *code)
/* Check whether ultimate component is abstract and CLASS. */ /* Check whether ultimate component is abstract and CLASS. */
is_abstract = 0; is_abstract = 0;
/* Is the allocate-object unlimited polymorphic? */
unlimited = UNLIMITED_POLY(e);
if (e->expr_type != EXPR_VARIABLE) if (e->expr_type != EXPR_VARIABLE)
{ {
allocatable = 0; allocatable = 0;
@ -7235,7 +7245,7 @@ resolve_allocate_expr (gfc_expr *e, gfc_code *code)
} }
/* Check for F08:C628. */ /* 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", gfc_error ("Allocate-object at %L must be ALLOCATABLE or a POINTER",
&e->where); &e->where);
@ -7254,12 +7264,12 @@ resolve_allocate_expr (gfc_expr *e, gfc_code *code)
} }
/* Check F03:C632 and restriction following Note 6.18. */ /* 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) && conformable_arrays (code->expr3, e) == FAILURE)
goto failure; goto failure;
/* Check F03:C633. */ /* 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 " gfc_error ("The allocate-object at %L and the source-expr at %L "
"shall have the same kind type parameter", "shall have the same kind type parameter",
@ -7362,7 +7372,7 @@ resolve_allocate_expr (gfc_expr *e, gfc_code *code)
code->expr3 = rhs; 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 /* Make sure the vtab symbol is present when
the module variables are generated. */ the module variables are generated. */
@ -7371,7 +7381,29 @@ resolve_allocate_expr (gfc_expr *e, gfc_code *code)
ts = code->expr3->ts; ts = code->expr3->ts;
else if (code->ext.alloc.ts.type == BT_DERIVED) else if (code->ext.alloc.ts.type == BT_DERIVED)
ts = code->ext.alloc.ts; ts = code->ext.alloc.ts;
gfc_find_derived_vtab (ts.u.derived); 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) if (dimension)
e = gfc_expr_to_initialize (e); e = gfc_expr_to_initialize (e);
} }
@ -8206,7 +8238,9 @@ resolve_select (gfc_code *code)
bool bool
gfc_type_is_extensible (gfc_symbol *sym) 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]; char name[GFC_MAX_SYMBOL_LEN];
gfc_namespace *ns; gfc_namespace *ns;
int error = 0; int error = 0;
int charlen = 0;
ns = code->ext.block.ns; ns = code->ext.block.ns;
gfc_resolve (ns); gfc_resolve (ns);
@ -8344,6 +8379,7 @@ resolve_select_type (gfc_code *code, gfc_namespace *old_ns)
/* Check F03:C815. */ /* Check F03:C815. */
if ((c->ts.type == BT_DERIVED || c->ts.type == BT_CLASS) 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_type_is_extensible (c->ts.u.derived))
{ {
gfc_error ("Derived type '%s' at %L must be extensible", 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. */ /* Check F03:C816. */
if ((c->ts.type == BT_DERIVED || c->ts.type == BT_CLASS) 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_type_is_extension_of (selector_type, c->ts.u.derived))
{ {
gfc_error ("Derived type '%s' at %L must be an extension of '%s'", 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; 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. */ /* Intercept the DEFAULT case. */
if (c->ts.type == BT_UNKNOWN) 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; ns->code->next = new_st;
code = new_st; code = new_st;
code->op = EXEC_SELECT; code->op = EXEC_SELECT;
gfc_add_vptr_component (code->expr1); gfc_add_vptr_component (code->expr1);
gfc_add_hash_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) if (c->ts.type == BT_DERIVED)
c->low = c->high = gfc_get_int_expr (gfc_default_integer_kind, NULL, c->low = c->high = gfc_get_int_expr (gfc_default_integer_kind, NULL,
c->ts.u.derived->hash_value); 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) else if (c->ts.type == BT_UNKNOWN)
continue; continue;
@ -8442,13 +8499,25 @@ resolve_select_type (gfc_code *code, gfc_namespace *old_ns)
if (c->ts.type == BT_CLASS) if (c->ts.type == BT_CLASS)
sprintf (name, "__tmp_class_%s", c->ts.u.derived->name); 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); 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); st = gfc_find_symtree (ns->sym_root, name);
gcc_assert (st->n.sym->assoc); gcc_assert (st->n.sym->assoc);
st->n.sym->assoc->target = gfc_get_variable_expr (code->expr1->symtree); st->n.sym->assoc->target = gfc_get_variable_expr (code->expr1->symtree);
st->n.sym->assoc->target->where = code->expr1->where; 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); gfc_add_data_component (st->n.sym->assoc->target);
new_st = gfc_get_code (); new_st = gfc_get_code ();
@ -11029,6 +11098,8 @@ resolve_fl_var_and_proc (gfc_symbol *sym, int mp_flag)
{ {
/* F03:C502. */ /* F03:C502. */
if (sym->attr.class_ok if (sym->attr.class_ok
&& !sym->attr.select_type_temporary
&& !UNLIMITED_POLY(sym)
&& !gfc_type_is_extensible (CLASS_DATA (sym)->ts.u.derived)) && !gfc_type_is_extensible (CLASS_DATA (sym)->ts.u.derived))
{ {
gfc_error ("Type '%s' of CLASS variable '%s' at %L is not extensible", 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. */ dummy arguments. */
e = sym->ts.u.cl->length; e = sym->ts.u.cl->length;
if (e == NULL && !sym->attr.dummy && !sym->attr.result 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 " gfc_error ("Entity with assumed character length at %L must be a "
"dummy argument or a PARAMETER", &sym->declared_at); "dummy argument or a PARAMETER", &sym->declared_at);
@ -12412,6 +12483,9 @@ resolve_fl_derived0 (gfc_symbol *sym)
gfc_symbol* super_type; gfc_symbol* super_type;
gfc_component *c; gfc_component *c;
if (sym->attr.unlimited_polymorphic)
return SUCCESS;
super_type = gfc_get_derived_super_type (sym); super_type = gfc_get_derived_super_type (sym);
/* F2008, C432. */ /* F2008, C432. */
@ -12764,7 +12838,8 @@ resolve_fl_derived0 (gfc_symbol *sym)
if (c->ts.type == BT_CLASS && c->attr.class_ok if (c->ts.type == BT_CLASS && c->attr.class_ok
&& CLASS_DATA (c)->attr.class_pointer && CLASS_DATA (c)->attr.class_pointer
&& CLASS_DATA (c)->ts.u.derived->components == NULL && 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 " gfc_error ("The pointer component '%s' of '%s' at %L is a type "
"that has not been declared", c->name, sym->name, "that has not been declared", c->name, sym->name,
@ -12833,6 +12908,9 @@ resolve_fl_derived (gfc_symbol *sym)
{ {
gfc_symbol *gen_dt = NULL; gfc_symbol *gen_dt = NULL;
if (sym->attr.unlimited_polymorphic)
return SUCCESS;
if (!sym->attr.is_class) if (!sym->attr.is_class)
gfc_find_symbol (sym->name, sym->ns, 0, &gen_dt); gfc_find_symbol (sym->name, sym->ns, 0, &gen_dt);
if (gen_dt && gen_dt->generic && gen_dt->generic->next 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. */ /* Fix up incomplete CLASS symbols. */
gfc_component *data = gfc_find_component (sym, "_data", true, true); gfc_component *data = gfc_find_component (sym, "_data", true, true);
gfc_component *vptr = gfc_find_component (sym, "_vptr", 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); gfc_symbol *vtab = gfc_find_derived_vtab (data->ts.u.derived);
gcc_assert (vtab); gcc_assert (vtab);
@ -13074,6 +13156,9 @@ resolve_symbol (gfc_symbol *sym)
if (sym->attr.artificial) if (sym->attr.artificial)
return; return;
if (sym->attr.unlimited_polymorphic)
return;
if (sym->attr.flavor == FL_UNKNOWN if (sym->attr.flavor == FL_UNKNOWN
|| (sym->attr.flavor == FL_PROCEDURE && !sym->attr.intrinsic || (sym->attr.flavor == FL_PROCEDURE && !sym->attr.intrinsic
&& !sym->attr.generic && !sym->attr.external && !sym->attr.generic && !sym->attr.external

72
gcc/fortran/simplify.c
View File

@ -1,6 +1,6 @@
/* Simplify intrinsic functions at compile-time. /* Simplify intrinsic functions at compile-time.
Copyright (C) 2000, 2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009, Copyright (C) 2000, 2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008,
2010, 2011 Free Software Foundation, Inc. 2009, 2010, 2011, 2012 Free Software Foundation, Inc.
Contributed by Andy Vaught & Katherine Holcomb Contributed by Andy Vaught & Katherine Holcomb
This file is part of GCC. This file is part of GCC.
@ -82,7 +82,7 @@ range_check (gfc_expr *result, const char *name)
{ {
case ARITH_OK: case ARITH_OK:
return result; return result;
case ARITH_OVERFLOW: case ARITH_OVERFLOW:
gfc_error ("Result of %s overflows its kind at %L", name, gfc_error ("Result of %s overflows its kind at %L", name,
&result->where); &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. */ depending on DIM. */
static gfc_expr * 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 :: array(n, m) = ...
REAL, PARAMETER :: s(n) = PROD(array, DIM=1) 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 * static gfc_expr *
simplify_transformation_to_array (gfc_expr *result, gfc_expr *array, gfc_expr *dim, 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); mpfr_clear (last1);
return result; return result;
} }
/* Get second recursion anchor. */ /* Get second recursion anchor. */
mpfr_init (last2); mpfr_init (last2);
@ -1335,7 +1335,7 @@ gfc_simplify_bessel_n2 (gfc_expr *order1, gfc_expr *order2, gfc_expr *x,
} }
if (jn) if (jn)
gfc_constructor_insert_expr (&result->value.constructor, e, &x->where, -2); gfc_constructor_insert_expr (&result->value.constructor, e, &x->where, -2);
else else
gfc_constructor_append_expr (&result->value.constructor, e, &x->where); gfc_constructor_append_expr (&result->value.constructor, e, &x->where);
if (n1 + 1 == n2) 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_init (x2rev);
mpfr_ui_div (x2rev, 2, x->value.real, GFC_RND_MODE); mpfr_ui_div (x2rev, 2, x->value.real, GFC_RND_MODE);
for (i = 2; i <= n2-n1; i++) for (i = 2; i <= n2-n1; i++)
{ {
e = gfc_get_constant_expr (x->ts.type, x->ts.kind, &x->where); 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: case BT_COMPLEX:
mpc_cosh (result->value.complex, x->value.complex, GFC_MPC_RND_MODE); mpc_cosh (result->value.complex, x->value.complex, GFC_MPC_RND_MODE);
break; break;
default: default:
gcc_unreachable (); 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, return gfc_get_logical_expr (gfc_default_logical_kind, &a->where,
gfc_type_is_extension_of (mold->ts.u.derived, gfc_type_is_extension_of (mold->ts.u.derived,
a->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. */ /* Return .false. if the dynamic type can never be the same. */
if ((a->ts.type == BT_CLASS && mold->ts.type == BT_CLASS if ((a->ts.type == BT_CLASS && mold->ts.type == BT_CLASS
&& !gfc_type_is_extension_of && !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 back, len, lensub;
int i, j, k, count, index = 0, start; 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)) || ( b != NULL && b->expr_type != EXPR_CONSTANT))
return NULL; return NULL;
@ -2685,7 +2689,7 @@ gfc_simplify_index (gfc_expr *x, gfc_expr *y, gfc_expr *b, gfc_expr *kind)
else else
back = 0; 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) if (k == -1)
return &gfc_bad_expr; return &gfc_bad_expr;
@ -3229,7 +3233,7 @@ simplify_bound_dim (gfc_expr *array, gfc_expr *kind, int d, int upper,
int k; int k;
k = get_kind (BT_INTEGER, kind, upper ? "UBOUND" : "LBOUND", k = get_kind (BT_INTEGER, kind, upper ? "UBOUND" : "LBOUND",
gfc_default_integer_kind); gfc_default_integer_kind);
if (k == -1) if (k == -1)
return &gfc_bad_expr; 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->expr_type = EXPR_ARRAY;
e->ts.type = BT_INTEGER; e->ts.type = BT_INTEGER;
k = get_kind (BT_INTEGER, kind, upper ? "UCOBOUND" : "LCOBOUND", k = get_kind (BT_INTEGER, kind, upper ? "UCOBOUND" : "LCOBOUND",
gfc_default_integer_kind); gfc_default_integer_kind);
if (k == -1) if (k == -1)
{ {
gfc_free_expr (e); gfc_free_expr (e);
@ -3912,7 +3916,7 @@ gfc_simplify_maskr (gfc_expr *i, gfc_expr *kind_arg)
if (i->expr_type != EXPR_CONSTANT) if (i->expr_type != EXPR_CONSTANT)
return NULL; return NULL;
kind = get_kind (BT_INTEGER, kind_arg, "MASKR", gfc_default_integer_kind); kind = get_kind (BT_INTEGER, kind_arg, "MASKR", gfc_default_integer_kind);
if (kind == -1) if (kind == -1)
return &gfc_bad_expr; return &gfc_bad_expr;
@ -3944,7 +3948,7 @@ gfc_simplify_maskl (gfc_expr *i, gfc_expr *kind_arg)
if (i->expr_type != EXPR_CONSTANT) if (i->expr_type != EXPR_CONSTANT)
return NULL; return NULL;
kind = get_kind (BT_INTEGER, kind_arg, "MASKL", gfc_default_integer_kind); kind = get_kind (BT_INTEGER, kind_arg, "MASKL", gfc_default_integer_kind);
if (kind == -1) if (kind == -1)
return &gfc_bad_expr; return &gfc_bad_expr;
@ -4066,7 +4070,7 @@ min_max_choose (gfc_expr *arg, gfc_expr *extremum, int sign)
#undef LENGTH #undef LENGTH
#undef STRING #undef STRING
break; break;
default: default:
gfc_internal_error ("simplify_min_max(): Bad type in arglist"); gfc_internal_error ("simplify_min_max(): Bad type in arglist");
} }
@ -4119,14 +4123,14 @@ simplify_min_max (gfc_expr *expr, int sign)
return NULL; return NULL;
/* Convert to the correct type and kind. */ /* 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, return gfc_convert_constant (expr->value.function.actual->expr,
expr->ts.type, expr->ts.kind); 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, return gfc_convert_constant (expr->value.function.actual->expr,
specific->ts.type, specific->ts.kind); specific->ts.type, specific->ts.kind);
return gfc_copy_expr (expr->value.function.actual->expr); return gfc_copy_expr (expr->value.function.actual->expr);
} }
@ -4176,14 +4180,14 @@ simplify_minval_maxval (gfc_expr *expr, int sign)
return NULL; return NULL;
/* Convert to the correct type and kind. */ /* 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, return gfc_convert_constant (extremum->expr,
expr->ts.type, expr->ts.kind); expr->ts.type, expr->ts.kind);
if (specific->ts.type != BT_UNKNOWN) if (specific->ts.type != BT_UNKNOWN)
return gfc_convert_constant (extremum->expr, return gfc_convert_constant (extremum->expr,
specific->ts.type, specific->ts.kind); specific->ts.type, specific->ts.kind);
return gfc_copy_expr (extremum->expr); return gfc_copy_expr (extremum->expr);
} }
@ -4261,7 +4265,7 @@ gfc_simplify_mod (gfc_expr *a, gfc_expr *p)
} }
gfc_set_model_kind (kind); 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); GFC_RND_MODE);
break; break;
@ -4310,7 +4314,7 @@ gfc_simplify_modulo (gfc_expr *a, gfc_expr *p)
} }
gfc_set_model_kind (kind); 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); GFC_RND_MODE);
if (mpfr_cmp_ui (result->value.real, 0) != 0) 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); GFC_RND_MODE);
} }
else else
mpfr_copysign (result->value.real, result->value.real, mpfr_copysign (result->value.real, result->value.real,
p->value.real, GFC_RND_MODE); p->value.real, GFC_RND_MODE);
break; break;
@ -4621,7 +4625,7 @@ gfc_simplify_pack (gfc_expr *array, gfc_expr *mask, gfc_expr *vector)
} }
else if (mask->expr_type == EXPR_ARRAY) 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 equals .TRUE.. */
mask_ctor = gfc_constructor_first (mask->value.constructor); mask_ctor = gfc_constructor_first (mask->value.constructor);
while (mask_ctor) while (mask_ctor)
@ -4921,8 +4925,8 @@ gfc_simplify_repeat (gfc_expr *e, gfc_expr *n)
if (e->expr_type != EXPR_CONSTANT) if (e->expr_type != EXPR_CONSTANT)
return NULL; return NULL;
if (len || if (len ||
(e->ts.u.cl->length && (e->ts.u.cl->length &&
mpz_sgn (e->ts.u.cl->length->value.integer)) != 0) mpz_sgn (e->ts.u.cl->length->value.integer)) != 0)
{ {
const char *res = gfc_extract_int (n, &ncop); 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 /* 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 possibility of subnormal numbers. Fortran 2003 states the result is
b**max(e - p, emin - 1). */ b**max(e - p, emin - 1). */
@ -6025,11 +6029,11 @@ gfc_simplify_transfer (gfc_expr *source, gfc_expr *mold, gfc_expr *size)
: mold; : mold;
/* Set result character length, if needed. Note that this needs to be /* 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. */ gfc_target_interpret_expr. */
if (result->ts.type == BT_CHARACTER && gfc_is_constant_expr (mold_element)) if (result->ts.type == BT_CHARACTER && gfc_is_constant_expr (mold_element))
result->value.character.length = mold_element->value.character.length; result->value.character.length = mold_element->value.character.length;
/* Set the number of elements in the result, and determine its size. */ /* Set the number of elements in the result, and determine its size. */
if (mold->expr_type == EXPR_ARRAY || mold->rank || 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, gfc_expr *e = gfc_constructor_lookup_expr (matrix->value.constructor,
col * matrix_rows + row); col * matrix_rows + row);
gfc_constructor_insert_expr (&result->value.constructor, gfc_constructor_insert_expr (&result->value.constructor,
gfc_copy_expr (e), &matrix->where, gfc_copy_expr (e), &matrix->where,
row * matrix_cols + col); row * matrix_cols + col);
} }

8
gcc/fortran/symbol.c
View File

@ -1955,6 +1955,9 @@ gfc_use_derived (gfc_symbol *sym)
if (!sym) if (!sym)
return NULL; return NULL;
if (sym->attr.unlimited_polymorphic)
return sym;
if (sym->attr.generic) if (sym->attr.generic)
sym = gfc_find_dt_in_generic (sym); 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_derived1 = (ts1->type == BT_DERIVED);
bool is_derived2 = (ts2->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) if (!is_derived1 && !is_derived2 && !is_class1 && !is_class2)
return (ts1->type == ts2->type); 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)). */ binding label (mainly those that are bind(c)). */
if (sym->attr.is_bind_c == 1 && sym->binding_label) if (sym->attr.is_bind_c == 1 && sym->binding_label)
return get_identifier (sym->binding_label); return get_identifier (sym->binding_label);
if (sym->module == NULL) if (sym->module == NULL)
return gfc_sym_identifier (sym); return gfc_sym_identifier (sym);
else else
@ -433,14 +433,14 @@ gfc_finish_cray_pointee (tree decl, gfc_symbol *sym)
tree value; tree value;
/* Parameters need to be dereferenced. */ /* 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 = build_fold_indirect_ref_loc (input_location,
ptr_decl); ptr_decl);
/* Check to see if we're dealing with a variable-sized array. */ /* Check to see if we're dealing with a variable-sized array. */
if (sym->attr.dimension 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 /* These decls will be dereferenced later, so we don't dereference
them here. */ them here. */
value = convert (TREE_TYPE (decl), ptr_decl); value = convert (TREE_TYPE (decl), ptr_decl);
@ -483,7 +483,7 @@ gfc_finish_decl (tree decl)
/* We should know the storage size. */ /* We should know the storage size. */
gcc_assert (DECL_SIZE (decl) != NULL_TREE gcc_assert (DECL_SIZE (decl) != NULL_TREE
|| (TREE_STATIC (decl) || (TREE_STATIC (decl)
? (!DECL_INITIAL (decl) || !DECL_CONTEXT (decl)) ? (!DECL_INITIAL (decl) || !DECL_CONTEXT (decl))
: DECL_EXTERNAL (decl))); : DECL_EXTERNAL (decl)));
@ -550,7 +550,7 @@ gfc_finish_var_decl (tree decl, gfc_symbol * sym)
TREE_PUBLIC(decl) = 1; TREE_PUBLIC(decl) = 1;
DECL_COMMON(decl) = 1; DECL_COMMON(decl) = 1;
} }
/* If a variable is USE associated, it's always external. */ /* If a variable is USE associated, it's always external. */
if (sym->attr.use_assoc) if (sym->attr.use_assoc)
{ {
@ -592,7 +592,7 @@ gfc_finish_var_decl (tree decl, gfc_symbol * sym)
TREE_SIDE_EFFECTS (decl) = 1; TREE_SIDE_EFFECTS (decl) = 1;
new_type = build_qualified_type (TREE_TYPE (decl), TYPE_QUAL_VOLATILE); new_type = build_qualified_type (TREE_TYPE (decl), TYPE_QUAL_VOLATILE);
TREE_TYPE (decl) = new_type; TREE_TYPE (decl) = new_type;
} }
/* Keep variables larger than max-stack-var-size off stack. */ /* Keep variables larger than max-stack-var-size off stack. */
if (!sym->ns->proc_name->attr.recursive 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? */ /* Do we know the element size? */
known_size = sym->ts.type != BT_CHARACTER known_size = sym->ts.type != BT_CHARACTER
|| INTEGER_CST_P (sym->ts.u.cl->backend_decl); || INTEGER_CST_P (sym->ts.u.cl->backend_decl);
if (known_size && !GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (type))) if (known_size && !GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (type)))
{ {
/* For descriptorless arrays with known element size the actual /* 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) if (sym->attr.use_assoc)
DECL_IGNORED_P (decl) = 1; DECL_IGNORED_P (decl) = 1;
} }
if ((sym->ns->proc_name if ((sym->ns->proc_name
&& sym->ns->proc_name->backend_decl == current_function_decl) && sym->ns->proc_name->backend_decl == current_function_decl)
|| sym->attr.contained) || sym->attr.contained)
@ -1984,7 +1984,7 @@ create_function_arglist (gfc_symbol * sym)
type = TREE_VALUE (typelist); type = TREE_VALUE (typelist);
parm = build_decl (input_location, parm = build_decl (input_location,
PARM_DECL, get_identifier ("__entry"), type); PARM_DECL, get_identifier ("__entry"), type);
DECL_CONTEXT (parm) = fndecl; DECL_CONTEXT (parm) = fndecl;
DECL_ARG_TYPE (parm) = type; DECL_ARG_TYPE (parm) = type;
TREE_READONLY (parm) = 1; TREE_READONLY (parm) = 1;
@ -2106,7 +2106,7 @@ create_function_arglist (gfc_symbol * sym)
gfc_finish_decl (length); gfc_finish_decl (length);
/* Remember the passed value. */ /* 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 /* This can happen if the same type is used for multiple
arguments. We need to copy cl as otherwise 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); gcc_assert (GFC_TYPE_ARRAY_CAF_TOKEN (caf_type) == NULL_TREE);
GFC_TYPE_ARRAY_CAF_TOKEN (caf_type) = token; GFC_TYPE_ARRAY_CAF_TOKEN (caf_type) = token;
} }
DECL_CONTEXT (token) = fndecl; DECL_CONTEXT (token) = fndecl;
DECL_ARTIFICIAL (token) = 1; DECL_ARTIFICIAL (token) = 1;
DECL_ARG_TYPE (token) = TREE_VALUE (typelist); 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; vec<tree, va_gc> *string_args = NULL;
thunk_sym = el->sym; thunk_sym = el->sym;
build_function_decl (thunk_sym, global); build_function_decl (thunk_sym, global);
create_function_arglist (thunk_sym); 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, tmp = fold_build3_loc (input_location, COMPONENT_REF,
TREE_TYPE (field), union_decl, field, TREE_TYPE (field), union_decl, field,
NULL_TREE); 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)), TREE_TYPE (DECL_RESULT (current_function_decl)),
DECL_RESULT (current_function_decl), tmp); DECL_RESULT (current_function_decl), tmp);
tmp = build1_v (RETURN_EXPR, tmp); tmp = build1_v (RETURN_EXPR, tmp);
@ -2985,7 +2985,7 @@ gfc_build_intrinsic_function_decls (void)
gfc_int4_type_node); gfc_int4_type_node);
TREE_READONLY (gfor_fndecl_math_ishftc4) = 1; TREE_READONLY (gfor_fndecl_math_ishftc4) = 1;
TREE_NOTHROW (gfor_fndecl_math_ishftc4) = 1; TREE_NOTHROW (gfor_fndecl_math_ishftc4) = 1;
gfor_fndecl_math_ishftc8 = gfc_build_library_function_decl ( gfor_fndecl_math_ishftc8 = gfc_build_library_function_decl (
get_identifier (PREFIX("ishftc8")), get_identifier (PREFIX("ishftc8")),
gfc_int8_type_node, 3, gfc_int8_type_node, gfc_int4_type_node, 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); void_type_node, -2, pchar_type_node, pchar_type_node);
/* The runtime_error_at function does not return. */ /* The runtime_error_at function does not return. */
TREE_THIS_VOLATILE (gfor_fndecl_runtime_error_at) = 1; TREE_THIS_VOLATILE (gfor_fndecl_runtime_error_at) = 1;
gfor_fndecl_runtime_warning_at = gfc_build_library_function_decl_with_spec ( gfor_fndecl_runtime_warning_at = gfc_build_library_function_decl_with_spec (
get_identifier (PREFIX("runtime_warning_at")), ".RR", get_identifier (PREFIX("runtime_warning_at")), ".RR",
void_type_node, -2, pchar_type_node, pchar_type_node); 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) if (sym->ts.type == BT_CLASS)
{ {
/* Initialize _vptr to declared type. */ /* Initialize _vptr to declared type. */
gfc_symbol *vtab = gfc_find_derived_vtab (sym->ts.u.derived); gfc_symbol *vtab;
tree rhs; tree rhs;
gfc_save_backend_locus (&loc); 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; se.want_pointer = 1;
gfc_conv_expr (&se, e); gfc_conv_expr (&se, e);
gfc_free_expr (e); gfc_free_expr (e);
rhs = gfc_build_addr_expr (TREE_TYPE (se.expr), if (UNLIMITED_POLY (sym))
gfc_get_symbol_decl (vtab)); 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_add_modify (&init, se.expr, rhs);
gfc_restore_backend_locus (&loc); 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), gfc_add_init_cleanup (block, gfc_finish_block (&tmpblock),
NULL_TREE); NULL_TREE);
} }
else else if (!(UNLIMITED_POLY(sym)))
gcc_unreachable (); gcc_unreachable ();
} }
@ -4347,7 +4353,7 @@ generate_coarray_sym_init (gfc_symbol *sym)
tree tmp, size, decl, token; tree tmp, size, decl, token;
if (sym->attr.dummy || sym->attr.allocatable || !sym->attr.codimension 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; return;
decl = sym->backend_decl; 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))); 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, size = fold_build2_loc (input_location, MAX_EXPR, size_type_node,
fold_convert (size_type_node, size), fold_convert (size_type_node, size),
build_int_cst (size_type_node, 1)); build_int_cst (size_type_node, 1));
@ -4382,7 +4388,7 @@ generate_coarray_sym_init (gfc_symbol *sym)
token, null_pointer_node, /* token, stat. */ token, null_pointer_node, /* token, stat. */
null_pointer_node, /* errgmsg, errmsg_len. */ null_pointer_node, /* errgmsg, errmsg_len. */
build_int_cst (integer_type_node, 0)); build_int_cst (integer_type_node, 0));
gfc_add_modify (&caf_init_block, decl, fold_convert (TREE_TYPE (decl), tmp)); 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) if (gfc_option.warn_unused_dummy_argument)
gfc_warning ("Unused dummy argument '%s' at %L", sym->name, gfc_warning ("Unused dummy argument '%s' at %L", sym->name,
&sym->declared_at); &sym->declared_at);
} }
/* Silence bogus "unused parameter" warnings from the /* Silence bogus "unused parameter" warnings from the
@ -5151,9 +5157,9 @@ create_main_function (tree fndecl)
/* Coarray: Call _gfortran_caf_finalize(void). */ /* Coarray: Call _gfortran_caf_finalize(void). */
if (gfc_option.coarray == GFC_FCOARRAY_LIB) if (gfc_option.coarray == GFC_FCOARRAY_LIB)
{ {
/* Per F2008, 8.5.1 END of the main program implies a /* 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 = builtin_decl_explicit (BUILT_IN_SYNC_SYNCHRONIZE);
tmp = build_call_expr_loc (input_location, tmp, 0); tmp = build_call_expr_loc (input_location, tmp, 0);
gfc_add_expr_to_block (&body, tmp); 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 static tree
conv_scalar_to_descriptor (gfc_se *se, tree scalar, symbol_attribute attr) 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); type = get_scalar_to_descriptor_type (scalar, attr);
desc = gfc_create_var (type, "desc"); 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 /* Takes a scalarized class array expression and returns the
address of a temporary scalar class object of the 'declared' address of a temporary scalar class object of the 'declared'
type. type.
OOP-TODO: This could be improved by adding code that branched on 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 dynamic type being the same as the declared type. In this case
the original class expression can be passed directly. 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; tmp = NULL_TREE;
if (class_ref == NULL 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; tmp = e->symtree->n.sym->backend_decl;
else else
{ {
@ -813,6 +872,8 @@ gfc_trans_class_init_assign (gfc_code *code)
gfc_conv_expr (&src, rhs); gfc_conv_expr (&src, rhs);
gfc_conv_expr (&memsz, sz); gfc_conv_expr (&memsz, sz);
gfc_add_block_to_block (&block, &src.pre); 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); 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); gfc_add_expr_to_block (&block, tmp);
return gfc_finish_block (&block); 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); lhs = gfc_copy_expr (expr1);
gfc_add_vptr_component (lhs); 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) if (expr2->ts.type == BT_DERIVED)
vtab = gfc_find_derived_vtab (expr2->ts.u.derived); vtab = gfc_find_derived_vtab (expr2->ts.u.derived);
else if (expr2->expr_type == EXPR_NULL) else if (expr2->expr_type == EXPR_NULL)
vtab = gfc_find_derived_vtab (expr1->ts.u.derived); vtab = gfc_find_derived_vtab (expr1->ts.u.derived);
else
vtab = gfc_find_intrinsic_vtab (&expr2->ts);
gcc_assert (vtab); gcc_assert (vtab);
rhs = gfc_get_expr (); 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); gfc_find_sym_tree (vtab->name, vtab->ns, 1, &st);
rhs->symtree = st; rhs->symtree = st;
rhs->ts = vtab->ts; rhs->ts = vtab->ts;
assign_vptr:
tmp = gfc_trans_pointer_assignment (lhs, rhs); tmp = gfc_trans_pointer_assignment (lhs, rhs);
gfc_add_expr_to_block (&block, tmp); gfc_add_expr_to_block (&block, tmp);
gfc_free_expr (lhs); gfc_free_expr (lhs);
gfc_free_expr (rhs); 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) else if (CLASS_DATA (expr2)->attr.dimension)
{ {
/* Insert an additional assignment which sets the '_vptr' field. */ /* 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 = gfc_get_int_type (kind);
tmp = fold_convert (tmp, build_fold_indirect_ref_loc (input_location, tmp = fold_convert (tmp, build_fold_indirect_ref_loc (input_location,
se->expr)); se->expr));
/* Test for a NULL value. */ /* Test for a NULL value. */
tmp = build3_loc (input_location, COND_EXPR, TREE_TYPE (tmp), present, tmp = build3_loc (input_location, COND_EXPR, TREE_TYPE (tmp), present,
tmp, fold_convert (TREE_TYPE (tmp), integer_one_node)); tmp, fold_convert (TREE_TYPE (tmp), integer_one_node));
@ -1147,9 +1225,9 @@ gfc_get_expr_charlen (gfc_expr *e)
gfc_ref *r; gfc_ref *r;
tree length; tree length;
gcc_assert (e->expr_type == EXPR_VARIABLE gcc_assert (e->expr_type == EXPR_VARIABLE
&& e->ts.type == BT_CHARACTER); && e->ts.type == BT_CHARACTER);
length = NULL; /* To silence compiler warning. */ length = NULL; /* To silence compiler warning. */
if (is_subref_array (e) && e->ts.u.cl->length) 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: case EXPR_OP:
flatten_array_ctors_without_strlen (e->value.op.op1); 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.op2);
break; break;
case EXPR_COMPCALL: 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); se_expr = gfc_get_fake_result_decl (sym, parent_flag);
/* Similarly for alternate entry points. */ /* Similarly for alternate entry points. */
else if (alternate_entry else if (alternate_entry
&& (sym->ns->proc_name->backend_decl == current_function_decl && (sym->ns->proc_name->backend_decl == current_function_decl
|| parent_flag)) || parent_flag))
{ {
@ -1640,7 +1718,7 @@ gfc_conv_variable (gfc_se * se, gfc_expr * expr)
/* Dereference the expression, where needed. Since characters /* 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. */ separately. */
if (sym->ts.type == BT_CHARACTER) 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 = build_fold_indirect_ref_loc (input_location,
se->expr); se->expr);
/* Dereference non-character pointer variables. /* Dereference non-character pointer variables.
These must be dummies, results, or scalars. */ These must be dummies, results, or scalars. */
if ((sym->attr.pointer || sym->attr.allocatable if ((sym->attr.pointer || sym->attr.allocatable
|| gfc_is_associate_pointer (sym) || 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 */ 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". */ method". */
#define POWI_WINDOW_SIZE 3 #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. */ values are put in tmpvar. The function returns tmpvar[1] ** n. */
static tree static tree
gfc_conv_powi (gfc_se * se, unsigned HOST_WIDE_INT n, tree * tmpvar) 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 /* There's no ABS for HOST_WIDE_INT, so here we go. It also takes care
of the asymmetric range of the integer type. */ of the asymmetric range of the integer type. */
n = (unsigned HOST_WIDE_INT) (m < 0 ? -m : m); n = (unsigned HOST_WIDE_INT) (m < 0 ? -m : m);
type = TREE_TYPE (lhs); type = TREE_TYPE (lhs);
sgn = tree_int_cst_sgn (rhs); sgn = tree_int_cst_sgn (rhs);
@ -2006,7 +2084,7 @@ gfc_conv_power_op (gfc_se * se, gfc_expr * expr)
case 4: case 4:
ikind = 0; ikind = 0;
break; break;
case 8: case 8:
ikind = 1; ikind = 1;
break; break;
@ -2034,7 +2112,7 @@ gfc_conv_power_op (gfc_se * se, gfc_expr * expr)
case 4: case 4:
kind = 0; kind = 0;
break; break;
case 8: case 8:
kind = 1; kind = 1;
break; break;
@ -2050,7 +2128,7 @@ gfc_conv_power_op (gfc_se * se, gfc_expr * expr)
default: default:
gcc_unreachable (); gcc_unreachable ();
} }
switch (expr->value.op.op1->ts.type) switch (expr->value.op.op1->ts.type)
{ {
case BT_INTEGER: case BT_INTEGER:
@ -2068,7 +2146,7 @@ gfc_conv_power_op (gfc_se * se, gfc_expr * expr)
case 0: case 0:
fndecl = builtin_decl_explicit (BUILT_IN_POWIF); fndecl = builtin_decl_explicit (BUILT_IN_POWIF);
break; break;
case 1: case 1:
fndecl = builtin_decl_explicit (BUILT_IN_POWI); fndecl = builtin_decl_explicit (BUILT_IN_POWI);
break; break;
@ -2078,7 +2156,7 @@ gfc_conv_power_op (gfc_se * se, gfc_expr * expr)
break; break;
case 3: 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. */ actually the C long double type. */
if (!gfc_real16_is_float128) if (!gfc_real16_is_float128)
fndecl = builtin_decl_explicit (BUILT_IN_POWIL); 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. */ library function. */
if (!fndecl) if (!fndecl)
fndecl = gfor_fndecl_math_powi[kind][ikind].real; 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]); (int)(*expr)->value.character.string[0]);
if ((*expr)->ts.kind != gfc_c_int_kind) 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. */ conversion fails, then the 2 causes an ICE. */
ts.type = BT_INTEGER; ts.type = BT_INTEGER;
ts.kind = gfc_c_int_kind; 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) else if (!sym->attr.dimension || sym->attr.pointer || sym->attr.allocatable)
value = build_fold_indirect_ref_loc (input_location, value = build_fold_indirect_ref_loc (input_location,
se->expr); 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) else if (sym->ts.type == BT_CHARACTER && !new_sym->ts.u.cl->length)
value = build_fold_indirect_ref_loc (input_location, value = build_fold_indirect_ref_loc (input_location,
se->expr); se->expr);
@ -3347,7 +3425,7 @@ gfc_conv_subref_array_arg (gfc_se * parmse, gfc_expr * expr, int g77,
rss = gfc_walk_expr (expr); rss = gfc_walk_expr (expr);
gcc_assert (rss != gfc_ss_terminator); gcc_assert (rss != gfc_ss_terminator);
/* Initialize the scalarizer. */ /* Initialize the scalarizer. */
gfc_init_loopinfo (&loop); gfc_init_loopinfo (&loop);
gfc_add_ss_to_loop (&loop, rss); 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); tmp = gfc_trans_scalar_assign (&lse, &rse, expr->ts, false, false, true);
gfc_add_expr_to_block (&body, tmp); gfc_add_expr_to_block (&body, tmp);
/* Generate the copying loops. */ /* Generate the copying loops. */
gfc_trans_scalarizing_loops (&loop2, &body); 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) if (formal_ptr)
{ {
size = gfc_index_one_node; size = gfc_index_one_node;
offset = gfc_index_zero_node; offset = gfc_index_zero_node;
for (n = 0; n < dimen; n++) for (n = 0; n < dimen; n++)
{ {
tmp = gfc_conv_descriptor_ubound_get (parmse->expr, 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->attr.pointer || fsym->attr.allocatable)
&& fsym->as->type != AS_ASSUMED_SHAPE; && fsym->as->type != AS_ASSUMED_SHAPE;
f = f || !sym->attr.always_explicit; f = f || !sym->attr.always_explicit;
gfc_conv_array_parameter (se, arg->expr, f, NULL, NULL, NULL); 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.f90_type = sym->ts.u.derived->ts.f90_type;
arg->expr->ts.kind = sym->ts.u.derived->ts.kind; arg->expr->ts.kind = sym->ts.u.derived->ts.kind;
gfc_conv_expr_reference (se, arg->expr); gfc_conv_expr_reference (se, arg->expr);
return 1; return 1;
} }
else if (sym->intmod_sym_id == ISOCBINDING_F_POINTER 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, gfc_array_index_type, stride,
fold_convert (gfc_array_index_type, fold_convert (gfc_array_index_type,
shapese.expr))); shapese.expr)));
/* Finish scalarization loop. */ /* Finish scalarization loop. */
gfc_trans_scalarizing_loops (&loop, &body); gfc_trans_scalarizing_loops (&loop, &body);
gfc_add_block_to_block (&block, &loop.pre); gfc_add_block_to_block (&block, &loop.pre);
gfc_add_block_to_block (&block, &loop.post); gfc_add_block_to_block (&block, &loop.post);
gfc_add_block_to_block (&block, &fptrse.post); gfc_add_block_to_block (&block, &fptrse.post);
gfc_cleanup_loop (&loop); gfc_cleanup_loop (&loop);
gfc_add_modify (&block, offset, gfc_add_modify (&block, offset,
fold_build1_loc (input_location, NEGATE_EXPR, fold_build1_loc (input_location, NEGATE_EXPR,
gfc_array_index_type, offset)); gfc_array_index_type, offset));
gfc_conv_descriptor_offset_set (&block, desc, 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 eq_expr;
tree not_null_expr; tree not_null_expr;
/* Given two arguments so build the arg2se from second arg. */ /* Given two arguments so build the arg2se from second arg. */
gfc_init_se (&arg2se, NULL); gfc_init_se (&arg2se, NULL);
gfc_conv_expr (&arg2se, arg->next->expr); gfc_conv_expr (&arg2se, arg->next->expr);
@ -3820,7 +3898,7 @@ conv_isocbinding_procedure (gfc_se * se, gfc_symbol * sym,
return 1; return 1;
} }
/* Nothing was done. */ /* Nothing was done. */
return 0; 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.class_pointer
|| CLASS_DATA (fsym)->attr.allocatable); || 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) else if (se->ss && se->ss->info->useflags)
{ {
gfc_ss *ss; gfc_ss *ss;
@ -4051,7 +4136,7 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym,
= fold_build3_loc (input_location, COND_EXPR, = fold_build3_loc (input_location, COND_EXPR,
TREE_TYPE (parmse.expr), TREE_TYPE (parmse.expr),
gfc_unlikely (tmp), gfc_unlikely (tmp),
fold_convert (TREE_TYPE (parmse.expr), fold_convert (TREE_TYPE (parmse.expr),
null_pointer_node), null_pointer_node),
parmse.expr); 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.class_pointer
|| CLASS_DATA (fsym)->attr.allocatable); || 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. */ allocated on entry, it must be deallocated. */
if (fsym && fsym->attr.intent == INTENT_OUT if (fsym && fsym->attr.intent == INTENT_OUT
&& (fsym->attr.allocatable && (fsym->attr.allocatable
@ -4205,7 +4290,7 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym,
gfc_init_block (&block); gfc_init_block (&block);
ptr = parmse.expr; ptr = parmse.expr;
if (e->ts.type == BT_CLASS) 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, tmp = gfc_deallocate_with_status (ptr, NULL_TREE,
NULL_TREE, 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 /* If the argument is a function call that may not create
a temporary for the result, we have to check that we 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. */ argument and another one. */
if (gfc_get_noncopying_intrinsic_argument (e) != NULL) if (gfc_get_noncopying_intrinsic_argument (e) != NULL)
{ {
@ -4387,7 +4472,7 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym,
else else
gfc_conv_array_parameter (&parmse, e, f, fsym, sym->name, NULL); 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. */ allocated on entry, it must be deallocated. */
if (fsym && fsym->attr.allocatable if (fsym && fsym->attr.allocatable
&& fsym->attr.intent == INTENT_OUT) && 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)); tmp, build_empty_stmt (input_location));
gfc_add_expr_to_block (&se->pre, tmp); gfc_add_expr_to_block (&se->pre, tmp);
} }
} }
} }
/* The case with fsym->attr.optional is that of a user subroutine /* 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->rank != 0 && sym->attr.elemental)
|| e->representation.length || e->ts.type == BT_CHARACTER || e->representation.length || e->ts.type == BT_CHARACTER
|| (e->rank != 0 || (e->rank != 0
&& (fsym == NULL && (fsym == NULL
|| (fsym-> as || (fsym-> as
&& (fsym->as->type == AS_ASSUMED_SHAPE && (fsym->as->type == AS_ASSUMED_SHAPE
|| fsym->as->type == AS_ASSUMED_RANK || 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), fold_convert (TREE_TYPE (tmp),
null_pointer_node)); null_pointer_node));
} }
gfc_trans_runtime_check (true, false, cond, &se->pre, &e->where, gfc_trans_runtime_check (true, false, cond, &se->pre, &e->where,
msg); msg);
free (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 /* Character strings are passed as two parameters, a length and a
pointer - except for Bind(c) which only passes the pointer. */ pointer - except for Bind(c) which only passes the pointer.
if (parmse.string_length != NULL_TREE && !sym->attr.is_bind_c) 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); vec_safe_push (stringargs, parmse.string_length);
/* For descriptorless coarrays and assumed-shape coarray dummies, we /* 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); && GFC_TYPE_ARRAY_CAF_TOKEN (caf_type) != NULL_TREE);
tmp = GFC_TYPE_ARRAY_CAF_TOKEN (caf_type); tmp = GFC_TYPE_ARRAY_CAF_TOKEN (caf_type);
} }
vec_safe_push (stringargs, tmp); vec_safe_push (stringargs, tmp);
if (GFC_DESCRIPTOR_TYPE_P (caf_type) 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_conv_expr (&parmse, ts.u.cl->length);
gfc_add_block_to_block (&se->pre, &parmse.pre); gfc_add_block_to_block (&se->pre, &parmse.pre);
gfc_add_block_to_block (&se->post, &parmse.post); gfc_add_block_to_block (&se->post, &parmse.post);
tmp = fold_convert (gfc_charlen_type_node, parmse.expr); tmp = fold_convert (gfc_charlen_type_node, parmse.expr);
tmp = fold_build2_loc (input_location, MAX_EXPR, tmp = fold_build2_loc (input_location, MAX_EXPR,
gfc_charlen_type_node, tmp, 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. /* 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. */ initialized. EXPR may be null. */
tree tree
@ -5521,7 +5619,7 @@ gfc_conv_initializer (gfc_expr * expr, gfc_typespec * ts, tree type,
gcc_assert (TREE_CODE (se.expr) != CONSTRUCTOR); gcc_assert (TREE_CODE (se.expr) != CONSTRUCTOR);
return se.expr; return se.expr;
} }
if (array && !procptr) if (array && !procptr)
{ {
tree ctor; tree ctor;
@ -5557,7 +5655,7 @@ gfc_conv_initializer (gfc_expr * expr, gfc_typespec * ts, tree type,
case BT_CLASS: case BT_CLASS:
gfc_init_se (&se, NULL); gfc_init_se (&se, NULL);
if (ts->type == BT_CLASS && expr->expr_type == EXPR_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 else
gfc_conv_structure (&se, expr, 1); gfc_conv_structure (&se, expr, 1);
gcc_assert (TREE_CODE (se.expr) == CONSTRUCTOR); gcc_assert (TREE_CODE (se.expr) == CONSTRUCTOR);
@ -5579,7 +5677,7 @@ gfc_conv_initializer (gfc_expr * expr, gfc_typespec * ts, tree type,
} }
} }
} }
static tree static tree
gfc_trans_subarray_assign (tree dest, gfc_component * cm, gfc_expr * expr) 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); cm->as->lower[n]->value.integer);
mpz_add_ui (lss_array->shape[n], lss_array->shape[n], 1); mpz_add_ui (lss_array->shape[n], lss_array->shape[n], 1);
} }
/* Associate the SS with the loop. */ /* Associate the SS with the loop. */
gfc_add_ss_to_loop (&loop, lss); gfc_add_ss_to_loop (&loop, lss);
gfc_add_ss_to_loop (&loop, rss); 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_start_block (&block);
gfc_init_se (&se, NULL); gfc_init_se (&se, NULL);
/* Get the descriptor for the expressions. */ /* Get the descriptor for the expressions. */
se.want_pointer = 0; se.want_pointer = 0;
gfc_conv_expr_descriptor (&se, expr); gfc_conv_expr_descriptor (&se, expr);
gfc_add_block_to_block (&block, &se.pre); 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. */ /* NULL initialization for CLASS components. */
tmp = gfc_trans_structure_assign (dest, 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); gfc_add_expr_to_block (&block, tmp);
} }
else if (cm->attr.dimension && !cm->attr.proc_pointer) 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)); fold_convert (TREE_TYPE (lse.expr), se.expr));
return gfc_finish_block (&block); return gfc_finish_block (&block);
} }
for (c = gfc_constructor_first (expr->value.constructor); for (c = gfc_constructor_first (expr->value.constructor);
c; c = gfc_constructor_next (c), cm = cm->next) 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)) if (!c->expr || (cm->attr.allocatable && cm->attr.flavor != FL_PROCEDURE))
continue; continue;
if (strcmp (cm->name, "_size") == 0) if (cm->initializer && cm->initializer->expr_type != EXPR_NULL
{ && strcmp (cm->name, "_extends") == 0
val = TYPE_SIZE_UNIT (gfc_get_derived_type (cm->ts.u.derived)); && cm->initializer->symtree)
CONSTRUCTOR_APPEND_ELT (v, cm->backend_decl, val);
}
else if (cm->initializer && cm->initializer->expr_type != EXPR_NULL
&& strcmp (cm->name, "_extends") == 0)
{ {
tree vtab; tree vtab;
gfc_symbol *vtabs; 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)); vtab = gfc_build_addr_expr (NULL_TREE, gfc_get_symbol_decl (vtabs));
CONSTRUCTOR_APPEND_ELT (v, cm->backend_decl, vtab); 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 else
{ {
val = gfc_conv_initializer (c->expr, &cm->ts, 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); se->expr = build_constructor (type, v);
if (init) if (init)
TREE_CONSTANT (se->expr) = 1; TREE_CONSTANT (se->expr) = 1;
} }
@ -6309,7 +6408,7 @@ gfc_trans_pointer_assignment (gfc_expr * expr1, gfc_expr * expr2)
scalar = ss == gfc_ss_terminator; scalar = ss == gfc_ss_terminator;
if (!scalar) if (!scalar)
gfc_free_ss_chain (ss); gfc_free_ss_chain (ss);
if (scalar) if (scalar)
{ {
/* Scalar pointers. */ /* Scalar pointers. */
@ -6794,7 +6893,7 @@ arrayfunc_assign_needs_temporary (gfc_expr * expr1, gfc_expr * expr2)
/* Functions returning pointers or allocatables need temporaries. */ /* Functions returning pointers or allocatables need temporaries. */
c = expr2->value.function.esym c = expr2->value.function.esym
? (expr2->value.function.esym->attr.pointer ? (expr2->value.function.esym->attr.pointer
|| expr2->value.function.esym->attr.allocatable) || expr2->value.function.esym->attr.allocatable)
: (expr2->symtree->n.sym->attr.pointer : (expr2->symtree->n.sym->attr.pointer
|| expr2->symtree->n.sym->attr.allocatable); || 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 correctly take care of the reallocation internally. For intrinsic
calls, the array data is freed and the library takes care of allocation. 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 TODO: Add logic of trans-array.c: gfc_alloc_allocatable_for_assignment
to the library. */ to the library. */
if (gfc_option.flag_realloc_lhs if (gfc_option.flag_realloc_lhs
&& gfc_is_reallocatable_lhs (expr1) && gfc_is_reallocatable_lhs (expr1)
&& !gfc_expr_attr (expr1).codimension && !gfc_expr_attr (expr1).codimension
@ -7417,7 +7516,7 @@ alloc_scalar_allocatable_for_assignment (stmtblock_t *block,
gfc_init_se (&lse, NULL); gfc_init_se (&lse, NULL);
lse.want_pointer = 1; lse.want_pointer = 1;
gfc_conv_expr (&lse, expr1); gfc_conv_expr (&lse, expr1);
jump_label1 = gfc_build_label_decl (NULL_TREE); jump_label1 = gfc_build_label_decl (NULL_TREE);
jump_label2 = 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_expr *a, *b;
gfc_se se1, se2; gfc_se se1, se2;
tree tmp; tree tmp;
tree conda = NULL_TREE, condb = NULL_TREE;
gfc_init_se (&se1, NULL); gfc_init_se (&se1, NULL);
gfc_init_se (&se2, 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; a = expr->value.function.actual->expr;
b = expr->value.function.actual->next->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) if (a->ts.type == BT_CLASS)
{ {
gfc_add_vptr_component (a); 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 (&se1, a);
gfc_conv_expr (&se2, b); gfc_conv_expr (&se2, b);
tmp = fold_build2_loc (input_location, EQ_EXPR, boolean_type_node, tmp = fold_build2_loc (input_location, EQ_EXPR,
se1.expr, fold_convert (TREE_TYPE (se1.expr), se2.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); 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) if (e == NULL)
continue; 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) for (ss = loopse->ss; ss && ss != gfc_ss_terminator; ss = ss->next)
if (ss->info->expr == e) if (ss->info->expr == e)
break; break;
@ -449,9 +449,9 @@ gfc_trans_call (gfc_code * code, bool dependency_check,
gfc_add_ss_to_loop (&loop, ss); gfc_add_ss_to_loop (&loop, ss);
gfc_conv_ss_startstride (&loop); gfc_conv_ss_startstride (&loop);
/* TODO: gfc_conv_loop_setup generates a temporary for vector /* TODO: gfc_conv_loop_setup generates a temporary for vector
subscripts. This could be prevented in the elemental case subscripts. This could be prevented in the elemental case
as temporaries are handled separatedly as temporaries are handled separatedly
(below in gfc_conv_elemental_dependencies). */ (below in gfc_conv_elemental_dependencies). */
gfc_conv_loop_setup (&loop, &code->expr1->where); gfc_conv_loop_setup (&loop, &code->expr1->where);
gfc_mark_ss_chain_used (ss, 1); 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 ? (gfc_option.coarray == GFC_FCOARRAY_LIB
? gfor_fndecl_caf_error_stop ? gfor_fndecl_caf_error_stop
: gfor_fndecl_error_stop_numeric) : 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)); fold_convert (gfc_int4_type_node, se.expr));
} }
else 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 /* Short cut: For single images without STAT= or LOCK_ACQUIRED
return early. (ERRMSG= is always untouched for -fcoarray=single.) */ return early. (ERRMSG= is always untouched for -fcoarray=single.) */
if (!code->expr2 && !code->expr4 && gfc_option.coarray != GFC_FCOARRAY_LIB) if (!code->expr2 && !code->expr4 && gfc_option.coarray != GFC_FCOARRAY_LIB)
return NULL_TREE; return NULL_TREE;
gfc_init_se (&se, NULL); gfc_init_se (&se, NULL);
gfc_start_block (&se.pre); 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.) */ return early. (ERRMSG= is always untouched for -fcoarray=single.) */
if (!code->expr2 && !(gfc_option.rtcheck & GFC_RTCHECK_BOUNDS) if (!code->expr2 && !(gfc_option.rtcheck & GFC_RTCHECK_BOUNDS)
&& gfc_option.coarray != GFC_FCOARRAY_LIB) && gfc_option.coarray != GFC_FCOARRAY_LIB)
return NULL_TREE; return NULL_TREE;
gfc_init_se (&se, NULL); gfc_init_se (&se, NULL);
gfc_start_block (&se.pre); 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) if (TREE_TYPE (stat) == integer_type_node)
stat = gfc_build_addr_expr (NULL, stat); stat = gfc_build_addr_expr (NULL, stat);
tmp = build_call_expr_loc (input_location, gfor_fndecl_caf_sync_all, tmp = build_call_expr_loc (input_location, gfor_fndecl_caf_sync_all,
3, stat, errmsg, errmsglen); 3, stat, errmsg, errmsglen);
gfc_add_expr_to_block (&se.pre, tmp); 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), 3, gfc_build_addr_expr (NULL, tmp_stat),
errmsg, errmsglen); errmsg, errmsglen);
gfc_add_expr_to_block (&se.pre, tmp); 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)); 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) if (TREE_TYPE (stat) == integer_type_node)
stat = gfc_build_addr_expr (NULL, stat); 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), 5, fold_convert (integer_type_node, len),
images, stat, errmsg, errmsglen); images, stat, errmsg, errmsglen);
gfc_add_expr_to_block (&se.pre, tmp); 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"); 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), 5, fold_convert (integer_type_node, len),
images, gfc_build_addr_expr (NULL, tmp_stat), images, gfc_build_addr_expr (NULL, tmp_stat),
errmsg, errmsglen); errmsg, errmsglen);
gfc_add_expr_to_block (&se.pre, tmp); 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)); 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; 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, stmt = fold_build3_loc (loc, COND_EXPR, void_type_node, if_se.expr, stmt,
elsestmt); elsestmt);
gfc_add_expr_to_block (&if_se.pre, stmt); gfc_add_expr_to_block (&if_se.pre, stmt);
/* Finish off this statement. */ /* Finish off this statement. */
@ -1141,6 +1141,7 @@ trans_associate_var (gfc_symbol *sym, gfc_wrapped_block *block)
gfc_expr *e; gfc_expr *e;
tree tmp; tree tmp;
bool class_target; bool class_target;
bool unlimited;
tree desc; tree desc;
tree offset; tree offset;
tree dim; 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_scalar_expr (e)
|| gfc_is_class_array_ref (e, NULL)); || gfc_is_class_array_ref (e, NULL));
unlimited = UNLIMITED_POLY (e);
/* Do a `pointer assignment' with updated descriptor (or assign descriptor /* Do a `pointer assignment' with updated descriptor (or assign descriptor
to array temporary) for arrays with either unknown shape or if associating to array temporary) for arrays with either unknown shape or if associating
to a variable. */ to a variable. */
@ -1194,9 +1197,10 @@ trans_associate_var (gfc_symbol *sym, gfc_wrapped_block *block)
gfc_finish_block (&se.post)); gfc_finish_block (&se.post));
} }
/* Derived type temporaries, arising from TYPE IS, just need the /* Temporaries, arising from TYPE IS, just need the descriptor of class
descriptor of class arrays to be assigned directly. */ arrays to be assigned directly. */
else if (class_target && sym->ts.type == BT_DERIVED && sym->attr.dimension) else if (class_target && sym->attr.dimension
&& (sym->ts.type == BT_DERIVED || unlimited))
{ {
gfc_se se; 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))); gcc_assert (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (sym->backend_decl)));
gfc_add_modify (&se.pre, sym->backend_decl, se.expr); 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_add_init_cleanup (block, gfc_finish_block( &se.pre),
gfc_finish_block (&se.post)); 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. */ /* For a class array we need a descriptor for the selector. */
gfc_conv_expr_descriptor (&se, e); 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); gfc_conv_class_to_class (&se, e, sym->ts, false, true, false, false);
se.expr = build_fold_indirect_ref_loc (input_location, se.expr); 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. */ /* This is bound to be a class array element. */
gfc_conv_expr_reference (&se, e); 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); tmp = gfc_get_vptr_from_expr (se.expr);
/* Obtain a temporary class container for the result. */ /* Obtain a temporary class container for the result. */
gfc_conv_derived_to_class (&se, e, sym->ts, tmp, false, false); 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 = TREE_TYPE (sym->backend_decl);
tmp = gfc_build_addr_expr (tmp, se.expr); tmp = gfc_build_addr_expr (tmp, se.expr);
gfc_add_modify (&se.pre, sym->backend_decl, tmp); gfc_add_modify (&se.pre, sym->backend_decl, tmp);
gfc_add_init_cleanup (block, gfc_finish_block( &se.pre), gfc_add_init_cleanup (block, gfc_finish_block( &se.pre),
gfc_finish_block (&se.post)); 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); tmp = gfc_trans_assignment (lhs, e, false, true);
gfc_add_init_cleanup (block, tmp, NULL_TREE); 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); gfc_trans_deferred_vars (sym, &block);
for (ass = code->ext.block.assoc; ass; ass = ass->next) for (ass = code->ext.block.assoc; ass; ass = ass->next)
trans_associate_var (ass->st->n.sym, &block); trans_associate_var (ass->st->n.sym, &block);
return gfc_finish_wrapped_block (&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 cycle_label;
tree exit_label; tree exit_label;
location_t loc; location_t loc;
type = TREE_TYPE (dovar); type = TREE_TYPE (dovar);
loc = code->ext.iterator->start->where.lb->location; 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. */ /* Initialize the DO variable: dovar = from. */
gfc_add_modify_loc (loc, pblock, dovar, gfc_add_modify_loc (loc, pblock, dovar,
fold_convert (TREE_TYPE(dovar), from)); fold_convert (TREE_TYPE(dovar), from));
/* Save value for do-tinkering checking. */ /* Save value for do-tinkering checking. */
if (gfc_option.rtcheck & GFC_RTCHECK_DO) 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, tmp = fold_build2_loc (loc, LT_EXPR, boolean_type_node, step,
build_int_cst (TREE_TYPE (step), 0)); build_int_cst (TREE_TYPE (step), 0));
step_sign = fold_build3_loc (loc, COND_EXPR, type, tmp, step_sign = fold_build3_loc (loc, COND_EXPR, type, tmp,
build_int_cst (type, -1), build_int_cst (type, -1),
build_int_cst (type, 1)); build_int_cst (type, 1));
tmp = fold_build2_loc (loc, LT_EXPR, boolean_type_node, to, from); 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)) if (INTEGER_CST_P (inner_size))
{ {
while (forall_tmp while (forall_tmp
&& !forall_tmp->mask && !forall_tmp->mask
&& INTEGER_CST_P (forall_tmp->size)) && INTEGER_CST_P (forall_tmp->size))
{ {
inner_size = fold_build2_loc (input_location, MULT_EXPR, 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++) for (n = 0; n < nvar; n++)
{ {
/* size = (end + step - start) / step. */ /* 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]); step[n], start[n]);
tmp = fold_build2_loc (input_location, PLUS_EXPR, TREE_TYPE (end[n]), tmp = fold_build2_loc (input_location, PLUS_EXPR, TREE_TYPE (end[n]),
end[n], tmp); end[n], tmp);
@ -4108,7 +4138,7 @@ gfc_trans_where_assign (gfc_expr *expr1, gfc_expr *expr2,
stmtblock_t body; stmtblock_t body;
tree index, maskexpr; tree index, maskexpr;
/* A defined assignment. */ /* A defined assignment. */
if (cnext && cnext->resolved_sym) if (cnext && cnext->resolved_sym)
return gfc_trans_call (cnext, true, mask, count1, invert); 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, if (!gfc_array_allocate (&se, expr, stat, errmsg, errlen, label_finish,
memsz, &nelems, code->expr3)) 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. */ /* A scalar or derived type. */
/* Determine allocate size. */ /* Determine allocate size. */
if (al->expr->ts.type == BT_CLASS if (al->expr->ts.type == BT_CLASS
&& !unlimited_char
&& code->expr3 && code->expr3
&& memsz == NULL_TREE) && memsz == NULL_TREE)
{ {
@ -4913,8 +4952,8 @@ gfc_trans_allocate (gfc_code * code)
else else
memsz = TYPE_SIZE_UNIT (gfc_typenode_for_spec (&code->expr3->ts)); memsz = TYPE_SIZE_UNIT (gfc_typenode_for_spec (&code->expr3->ts));
} }
else if (al->expr->ts.type == BT_CHARACTER else if (((al->expr->ts.type == BT_CHARACTER && al->expr->ts.deferred)
&& al->expr->ts.deferred && code->expr3) || unlimited_char) && code->expr3)
{ {
if (!code->expr3->ts.u.cl->backend_decl) if (!code->expr3->ts.u.cl->backend_decl)
{ {
@ -4968,13 +5007,17 @@ gfc_trans_allocate (gfc_code * code)
memsz)); memsz));
/* Convert to size in bytes, using the character KIND. */ /* 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 = TREE_TYPE (gfc_typenode_for_spec (&al->expr->ts));
tmp = TYPE_SIZE_UNIT (tmp); tmp = TYPE_SIZE_UNIT (tmp);
memsz = fold_build2_loc (input_location, MULT_EXPR, memsz = fold_build2_loc (input_location, MULT_EXPR,
TREE_TYPE (tmp), tmp, TREE_TYPE (tmp), tmp,
fold_convert (TREE_TYPE (tmp), memsz)); 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); gcc_assert (code->ext.alloc.ts.u.cl && code->ext.alloc.ts.u.cl->length);
gfc_init_se (&se_sz, NULL); gfc_init_se (&se_sz, NULL);
@ -5026,7 +5069,7 @@ gfc_trans_allocate (gfc_code * code)
} }
else if (al->expr->ts.type == BT_CLASS) 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 memory because we cannot know if dynamic types have allocatable
components or not. */ components or not. */
tmp = build_call_expr_loc (input_location, tmp = build_call_expr_loc (input_location,
@ -5050,8 +5093,8 @@ gfc_trans_allocate (gfc_code * code)
build_empty_stmt (input_location)); build_empty_stmt (input_location));
gfc_add_expr_to_block (&block, tmp); 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); e = gfc_copy_expr (al->expr);
if (e->ts.type == BT_CLASS) if (e->ts.type == BT_CLASS)
{ {
@ -5090,16 +5133,19 @@ gfc_trans_allocate (gfc_code * code)
ts = &code->expr3->ts; ts = &code->expr3->ts;
else if (e->ts.type == BT_DERIVED) else if (e->ts.type == BT_DERIVED)
ts = &e->ts; 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; ts = &code->ext.alloc.ts;
else if (e->ts.type == BT_CLASS) else if (e->ts.type == BT_CLASS)
ts = &CLASS_DATA (e)->ts; ts = &CLASS_DATA (e)->ts;
else else
ts = &e->ts; 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); vtab = gfc_find_derived_vtab (ts->u.derived);
else
vtab = gfc_find_intrinsic_vtab (ts);
gcc_assert (vtab); gcc_assert (vtab);
gfc_init_se (&lse, NULL); gfc_init_se (&lse, NULL);
lse.want_pointer = 1; lse.want_pointer = 1;
@ -5184,9 +5230,12 @@ gfc_trans_allocate (gfc_code * code)
ppc = gfc_copy_expr (rhs); ppc = gfc_copy_expr (rhs);
gfc_add_vptr_component (ppc); gfc_add_vptr_component (ppc);
} }
else else if (rhs->ts.type == BT_DERIVED)
ppc = gfc_lval_expr_from_sym ppc = gfc_lval_expr_from_sym
(gfc_find_derived_vtab (rhs->ts.u.derived)); (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"); gfc_add_component_ref (ppc, "_copy");
ppc_code = gfc_get_code (); 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. */ /* Translate a DEALLOCATE statement. */
tree tree
@ -5376,6 +5449,8 @@ gfc_trans_deallocate (gfc_code *code)
tmp = gfc_array_deallocate (se.expr, pstat, errmsg, errlen, tmp = gfc_array_deallocate (se.expr, pstat, errmsg, errlen,
label_finish, expr); label_finish, expr);
gfc_add_expr_to_block (&se.pre, tmp); gfc_add_expr_to_block (&se.pre, tmp);
if (UNLIMITED_POLY (al->expr))
reset_vptr (&se.pre, al->expr);
} }
else else
{ {
@ -5388,19 +5463,9 @@ gfc_trans_deallocate (gfc_code *code)
se.expr, se.expr,
build_int_cst (TREE_TYPE (se.expr), 0)); build_int_cst (TREE_TYPE (se.expr), 0));
gfc_add_expr_to_block (&se.pre, tmp); gfc_add_expr_to_block (&se.pre, tmp);
if (al->expr->ts.type == BT_CLASS) if (al->expr->ts.type == BT_CLASS)
{ reset_vptr (&se.pre, al->expr);
/* 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);
}
} }
if (code->expr1) 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 canonical = NULL_TREE;
tree *chain = NULL; tree *chain = NULL;
bool got_canonical = false; bool got_canonical = false;
bool unlimited_entity = false;
gfc_component *c; gfc_component *c;
gfc_dt_list *dt; gfc_dt_list *dt;
gfc_namespace *ns; gfc_namespace *ns;
if (derived->attr.unlimited_polymorphic)
return ptr_type_node;
if (derived && derived->attr.flavor == FL_PROCEDURE if (derived && derived->attr.flavor == FL_PROCEDURE
&& derived->attr.generic) && derived->attr.generic)
derived = gfc_find_dt_in_generic (derived); 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. */ /* See if it's one of the iso_c_binding derived types. */
if (derived->attr.is_iso_c == 1) if (derived->attr.is_iso_c == 1)
{ {
@ -2431,6 +2433,12 @@ gfc_get_derived_type (gfc_symbol * derived)
derived->backend_decl = typenode; 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 /* Go through the derived type components, building them as
necessary. The reason for doing this now is that it is necessary. The reason for doing this now is that it is
possible to recurse back to this derived type through a possible to recurse back to this derived type through a
@ -2511,14 +2519,16 @@ gfc_get_derived_type (gfc_symbol * derived)
!c->attr.target); !c->attr.target);
} }
else if ((c->attr.pointer || c->attr.allocatable) 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); field_type = build_pointer_type (field_type);
if (c->attr.pointer) if (c->attr.pointer)
field_type = gfc_nonrestricted_type (field_type); field_type = gfc_nonrestricted_type (field_type);
/* vtype fields can point to different types to the base 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), field_type = build_pointer_type_for_mode (TREE_TYPE (field_type),
ptr_mode, true); ptr_mode, true);

40
gcc/fortran/trans.c
View File

@ -1,6 +1,6 @@
/* Code translation -- generate GCC trees from gfc_code. /* Code translation -- generate GCC trees from gfc_code.
Copyright (C) 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009, 2010, 2012 Copyright (C) 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009, 2010,
Free Software Foundation, Inc. 2012 Free Software Foundation, Inc.
Contributed by Paul Brook Contributed by Paul Brook
This file is part of GCC. This file is part of GCC.
@ -87,7 +87,7 @@ tree
gfc_create_var_np (tree type, const char *prefix) gfc_create_var_np (tree type, const char *prefix)
{ {
tree t; tree t;
t = create_tmp_var_raw (type, prefix); t = create_tmp_var_raw (type, prefix);
/* No warnings for anonymous variables. */ /* 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: A MODIFY_EXPR is an assignment:
LHS <- RHS. */ 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, arg = gfc_build_addr_expr (pchar_type_node,
gfc_build_localized_cstring_const (message)); gfc_build_localized_cstring_const (message));
free (message); free (message);
asprintf (&message, "%s", _(msgid)); asprintf (&message, "%s", _(msgid));
arg2 = gfc_build_addr_expr (pchar_type_node, arg2 = gfc_build_addr_expr (pchar_type_node,
gfc_build_localized_cstring_const (message)); gfc_build_localized_cstring_const (message));
@ -440,7 +440,7 @@ trans_runtime_error_vararg (bool error, locus* where, const char* msgid,
argarray[1] = arg2; argarray[1] = arg2;
for (i = 0; i < nargs; i++) for (i = 0; i < nargs; i++)
argarray[2 + i] = va_arg (ap, tree); argarray[2 + i] = va_arg (ap, tree);
/* Build the function call to runtime_(warning,error)_at; because of the /* 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, variable number of arguments, we can't use build_call_expr_loc dinput_location,
irectly. */ irectly. */
@ -591,14 +591,14 @@ gfc_call_malloc (stmtblock_t * block, tree type, tree size)
/* Allocate memory, using an optional status argument. /* Allocate memory, using an optional status argument.
This function follows the following pseudo-code: This function follows the following pseudo-code:
void * void *
allocate (size_t size, integer_type stat) allocate (size_t size, integer_type stat)
{ {
void *newmem; void *newmem;
if (stat requested) if (stat requested)
stat = 0; stat = 0;
@ -661,7 +661,7 @@ gfc_allocate_using_malloc (stmtblock_t * block, tree pointer,
/* Allocate memory, using an optional status argument. /* Allocate memory, using an optional status argument.
This function follows the following pseudo-code: This function follows the following pseudo-code:
void * 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 /* Generate code for an ALLOCATE statement when the argument is an
allocatable variable. If the variable is currently allocated, it is an allocatable variable. If the variable is currently allocated, it is an
error to allocate it again. error to allocate it again.
This function follows the following pseudo-code: This function follows the following pseudo-code:
void * void *
allocate_allocatable (void *mem, size_t size, integer_type stat) 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"); runtime_error ("Attempting to allocate already allocated variable");
} }
} }
expr must be set to the original expression being allocated for its locus 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. */ and variable name in case a runtime error has to be printed. */
void void
@ -866,7 +866,7 @@ gfc_call_free (tree var)
even when no status variable is passed to us (this is used for even when no status variable is passed to us (this is used for
unconditional deallocation generated by the front-end at end of unconditional deallocation generated by the front-end at end of
each procedure). each procedure).
If a runtime-message is possible, `expr' must point to the original If a runtime-message is possible, `expr' must point to the original
expression being deallocated for its locus and variable name. 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. */ /* When POINTER is not NULL, we free it. */
gfc_start_block (&non_null); gfc_start_block (&non_null);
/* Free allocatable components. */ /* Free allocatable components. */
if (ts.type == BT_DERIVED && ts.u.derived->attr.alloc_comp) 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); tmp, 0);
gfc_add_expr_to_block (&non_null, tmp); gfc_add_expr_to_block (&non_null, tmp);
} }
tmp = build_call_expr_loc (input_location, tmp = build_call_expr_loc (input_location,
builtin_decl_explicit (BUILT_IN_FREE), 1, builtin_decl_explicit (BUILT_IN_FREE), 1,
fold_convert (pvoid_type_node, pointer)); fold_convert (pvoid_type_node, pointer));
@ -1320,6 +1320,12 @@ trans_code (gfc_code * code, tree cond)
case EXEC_POINTER_ASSIGN: case EXEC_POINTER_ASSIGN:
if (code->expr1->ts.type == BT_CLASS) if (code->expr1->ts.type == BT_CLASS)
res = gfc_trans_class_assign (code->expr1, code->expr2, code->op); 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 else
res = gfc_trans_pointer_assign (code); res = gfc_trans_pointer_assign (code);
break; break;
@ -1544,7 +1550,7 @@ trans_code (gfc_code * code, tree cond)
{ {
if (TREE_CODE (res) != STATEMENT_LIST) if (TREE_CODE (res) != STATEMENT_LIST)
SET_EXPR_LOCATION (res, input_location); SET_EXPR_LOCATION (res, input_location);
/* Add the new statement to the block. */ /* Add the new statement to the block. */
gfc_add_expr_to_block (&block, res); gfc_add_expr_to_block (&block, res);
} }
@ -1686,7 +1692,7 @@ gfc_finish_wrapped_block (gfc_wrapped_block* block)
if (block->cleanup) if (block->cleanup)
result = build2_loc (input_location, TRY_FINALLY_EXPR, void_type_node, result = build2_loc (input_location, TRY_FINALLY_EXPR, void_type_node,
result, block->cleanup); result, block->cleanup);
/* Clear the block. */ /* Clear the block. */
block->init = NULL_TREE; block->init = NULL_TREE;
block->code = 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> 2012-12-19 Kyrylo Tkachov <kyrylo.tkachov@arm.com>
* gcc.target/arm/vmaxnmdf.c: New test. * 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> 2012-12-03 Janus Weil <janus@gcc.gnu.org>
PR fortran/55548 PR fortran/55548

8
libgfortran/intrinsics/extends_type_of.c
View File

@ -49,6 +49,14 @@ export_proto(is_extension_of);
GFC_LOGICAL_4 GFC_LOGICAL_4
is_extension_of (struct vtype *v1, struct vtype *v2) 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) while (v1)
{ {
if (v1->hash == v2->hash) return 1; if (v1->hash == v2->hash) return 1;