OpenE2K
/
gcc
2
0
Fork 0
Code Issues Pull Requests Projects Releases Wiki Activity

re PR fortran/41539 ([OOP] Calling function which takes CLASS: Rank comparison does not work) 

2011-12-11  Paul Thomas  <pault@gcc.gnu.org>
	Tobias Burnus  <burnus@gcc.gnu.org>

	PR fortran/41539
	PR fortran/43214
	PR fortran/43969
	PR fortran/44568
	PR fortran/46356
	PR fortran/46990
	PR fortran/49074
	* interface.c(symbol_rank): Return the rank of the _data
	component of class objects.
	(compare_parameter): Also compare the derived type of the class
	_data component for type mismatch.  Similarly, return 1 if the
	formal and _data ranks match.
	(compare_actual_formal): Do not compare storage sizes for class
	expressions. It is an error if an actual class array, passed to
	a formal class array is not full.
	* trans-expr.c (gfc_class_data_get, gfc_class_vptr_get,
	gfc_vtable_field_get, gfc_vtable_hash_get, gfc_vtable_size_get,
	gfc_vtable_extends_get, gfc_vtable_def_init_get,
	gfc_vtable_copy_get): New functions for class API.
	(gfc_conv_derived_to_class): For an array reference in an
	elemental procedure call retain the ss to provide the
	scalarized array reference. Moved in file.
	(gfc_conv_class_to_class): New function.
        (gfc_conv_subref_array_arg): Use the type of the
	class _data component as a basetype.
	(gfc_conv_procedure_call): Ensure that class array expressions
	have both the _data reference and an array reference. Use 
	gfc_conv_class_to_class to handle class arrays for elemental
	functions in scalarized loops, class array elements and full
	class arrays. Use a call to gfc_conv_subref_array_arg in order
	that the copy-in/copy-out for passing class arrays to derived
	type arrays occurs correctly.
	(gfc_conv_expr): If it is missing, add the _data component
	between a class object or component and an array reference.
	(gfc_trans_class_array_init_assign): New function.
	(gfc_trans_class_init_assign): Call it for array expressions.
	* trans-array.c (gfc_add_loop_ss_code): Do not use a temp for
	class scalars since their size will depend on the dynamic type.
	(build_class_array_ref): New function.
	(gfc_conv_scalarized_array_ref): Call build_class_array_ref.
	(gfc_array_init_size): Add extra argument, expr3, that represents
	the SOURCE argument. If present,use this for the element size.
	(gfc_array_allocate): Also add argument expr3 and use it when
	calling gfc_array_init_size.
	(structure_alloc_comps): Enable class arrays.
	* class.c (gfc_add_component_ref): Carry over the derived type
	of the _data component.
	(gfc_add_class_array_ref): New function.
	(class_array_ref_detected): New static function.
	(gfc_is_class_array_ref): New function that calls previous.
	(gfc_is_class_scalar_expr): New function.
	(gfc_build_class_symbol): Throw not implemented error for
	assumed size class arrays.  Remove error that prevents
	CLASS arrays.
	(gfc_build_class_symbol): Prevent pointer/allocatable conflict.
	Also unset codimension.
	(gfc_find_derived_vtab): Make 'copy' elemental and set the
	intent of the arguments accordingly.: 
	* trans-array.h : Update prototype for gfc_array_allocate.
	* array.c (gfc_array_dimen_size): Return failure if class expr.
	(gfc_array_size): Likewise.
	* gfortran.h : New prototypes for gfc_add_class_array_ref,
	gfc_is_class_array_ref and gfc_is_class_scalar_expr.
	* trans-stmt.c (trans_associate_var): Exclude class targets
	from test. Move the allocation of the _vptr to an earlier time
	for class objects.
	(trans_associate_var): Assign the descriptor directly for class
	arrays.
	(gfc_trans_allocate): Add expr3 to gfc_array_allocate arguments.
	Convert array element references into sections. Do not invoke
	gfc_conv_procedure_call, use gfc_trans_call instead.
	* expr.c (gfc_get_corank): Fix for BT_CLASS.
	(gfc_is_simply_contiguous): Exclude class from test.
	* trans.c (gfc_build_array_ref): Include class array refs.
	* trans.h : Include prototypes for class API functions that are
	new in trans-expr. Define GFC_DECL_CLASS(node).
	* resolve.c (check_typebound_baseobject ): Remove error for
	non-scalar base object.
	(resolve_allocate_expr): Ensure that class _data component is
	present. If array, call gfc_expr_to_intialize.
	(resolve_select): Remove scalar error for SELECT statement as a
	temporary measure.
	(resolve_assoc_var): Update 'target' (aka 'selector') as
	needed. Ensure that the target expression has the right rank.
	(resolve_select_type): Ensure that target expressions have a
	valid locus.
	(resolve_allocate_expr, resolve_fl_derived0): Fix for BT_CLASS.
	* trans-decl.c (gfc_get_symbol_decl): Set GFC_DECL_CLASS, where
	appropriate.
	(gfc_trans_deferred_vars): Get class arrays right.
	* match.c(select_type_set_tmp): Add array spec to temporary.
	(gfc_match_select_type): Allow class arrays.
	* check.c (array_check): Ensure that class arrays have refs.
	(dim_corank_check, dim_rank_check): Retrun success if class.
	* primary.c (gfc_match_varspec): Fix for class arrays and
	co-arrays. Make sure that class _data is present.
	(gfc_match_rvalue): Handle class arrays.
	*trans-intrinsic.c (gfc_conv_intrinsic_size): Add class array
	reference.
	(gfc_conv_allocated): Add _data component to class expressions.
	(gfc_add_intrinsic_ss_code): ditto.
	* simplify.c (simplify_cobound): Fix for BT_CLASS.
	(simplify_bound): Return NULL for class arrays.
	(simplify_cobound): Obtain correct array_spec. Use cotype as
	appropriate. Use arrayspec for bounds.

2011-12-11  Paul Thomas  <pault@gcc.gnu.org>
	Tobias Burnus  <burnus@gcc.gnu.org>

	PR fortran/41539
	PR fortran/43214
	PR fortran/43969
	PR fortran/44568
	PR fortran/46356
	PR fortran/46990
	PR fortran/49074
	* gfortran.dg/class_array_1.f03: New.
	* gfortran.dg/class_array_2.f03: New.
	* gfortran.dg/class_array_3.f03: New.
	* gfortran.dg/class_array_4.f03: New.
	* gfortran.dg/class_array_5.f03: New.
	* gfortran.dg/class_array_6.f03: New.
	* gfortran.dg/class_array_7.f03: New.
	* gfortran.dg/class_array_8.f03: New.
	* gfortran.dg/coarray_poly_1.f90: New.
	* gfortran.dg/coarray_poly_2.f90: New.
	* gfortran.dg/coarray/poly_run_1.f90: New.
	* gfortran.dg/coarray/poly_run_2.f90: New.
	* gfortran.dg/class_to_type_1.f03: New.
	* gfortran.dg/type_to_class_1.f03: New.
	* gfortran.dg/typebound_assignment_3.f03: Remove the error.
	* gfortran.dg/auto_dealloc_2.f90: Occurences of __builtin_free
	now 2.
	* gfortran.dg/class_19.f03: Occurences of __builtin_free now 8.


Co-Authored-By: Tobias Burnus <burnus@gcc.gnu.org>

From-SVN: r182210
This commit is contained in:
Paul Thomas 2011-12-11 20:42:23 +00:00
parent e07e39f6e5
commit c49ea23d52
37 changed files with 1970 additions and 217 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

109
gcc/fortran/ChangeLog
View File

@ -1,3 +1,112 @@
2011-12-11 Paul Thomas <pault@gcc.gnu.org>
Tobias Burnus <burnus@gcc.gnu.org>
PR fortran/41539
PR fortran/43214
PR fortran/43969
PR fortran/44568
PR fortran/46356
PR fortran/46990
PR fortran/49074
* interface.c(symbol_rank): Return the rank of the _data
component of class objects.
(compare_parameter): Also compare the derived type of the class
_data component for type mismatch. Similarly, return 1 if the
formal and _data ranks match.
(compare_actual_formal): Do not compare storage sizes for class
expressions. It is an error if an actual class array, passed to
a formal class array is not full.
* trans-expr.c (gfc_class_data_get, gfc_class_vptr_get,
gfc_vtable_field_get, gfc_vtable_hash_get, gfc_vtable_size_get,
gfc_vtable_extends_get, gfc_vtable_def_init_get,
gfc_vtable_copy_get): New functions for class API.
(gfc_conv_derived_to_class): For an array reference in an
elemental procedure call retain the ss to provide the
scalarized array reference. Moved in file.
(gfc_conv_class_to_class): New function.
(gfc_conv_subref_array_arg): Use the type of the
class _data component as a basetype.
(gfc_conv_procedure_call): Ensure that class array expressions
have both the _data reference and an array reference. Use
gfc_conv_class_to_class to handle class arrays for elemental
functions in scalarized loops, class array elements and full
class arrays. Use a call to gfc_conv_subref_array_arg in order
that the copy-in/copy-out for passing class arrays to derived
type arrays occurs correctly.
(gfc_conv_expr): If it is missing, add the _data component
between a class object or component and an array reference.
(gfc_trans_class_array_init_assign): New function.
(gfc_trans_class_init_assign): Call it for array expressions.
* trans-array.c (gfc_add_loop_ss_code): Do not use a temp for
class scalars since their size will depend on the dynamic type.
(build_class_array_ref): New function.
(gfc_conv_scalarized_array_ref): Call build_class_array_ref.
(gfc_array_init_size): Add extra argument, expr3, that represents
the SOURCE argument. If present,use this for the element size.
(gfc_array_allocate): Also add argument expr3 and use it when
calling gfc_array_init_size.
(structure_alloc_comps): Enable class arrays.
* class.c (gfc_add_component_ref): Carry over the derived type
of the _data component.
(gfc_add_class_array_ref): New function.
(class_array_ref_detected): New static function.
(gfc_is_class_array_ref): New function that calls previous.
(gfc_is_class_scalar_expr): New function.
(gfc_build_class_symbol): Throw not implemented error for
assumed size class arrays. Remove error that prevents
CLASS arrays.
(gfc_build_class_symbol): Prevent pointer/allocatable conflict.
Also unset codimension.
(gfc_find_derived_vtab): Make 'copy' elemental and set the
intent of the arguments accordingly.:
* trans-array.h : Update prototype for gfc_array_allocate.
* array.c (gfc_array_dimen_size): Return failure if class expr.
(gfc_array_size): Likewise.
* gfortran.h : New prototypes for gfc_add_class_array_ref,
gfc_is_class_array_ref and gfc_is_class_scalar_expr.
* trans-stmt.c (trans_associate_var): Exclude class targets
from test. Move the allocation of the _vptr to an earlier time
for class objects.
(trans_associate_var): Assign the descriptor directly for class
arrays.
(gfc_trans_allocate): Add expr3 to gfc_array_allocate arguments.
Convert array element references into sections. Do not invoke
gfc_conv_procedure_call, use gfc_trans_call instead.
* expr.c (gfc_get_corank): Fix for BT_CLASS.
(gfc_is_simply_contiguous): Exclude class from test.
* trans.c (gfc_build_array_ref): Include class array refs.
* trans.h : Include prototypes for class API functions that are
new in trans-expr. Define GFC_DECL_CLASS(node).
* resolve.c (check_typebound_baseobject ): Remove error for
non-scalar base object.
(resolve_allocate_expr): Ensure that class _data component is
present. If array, call gfc_expr_to_intialize.
(resolve_select): Remove scalar error for SELECT statement as a
temporary measure.
(resolve_assoc_var): Update 'target' (aka 'selector') as
needed. Ensure that the target expression has the right rank.
(resolve_select_type): Ensure that target expressions have a
valid locus.
(resolve_allocate_expr, resolve_fl_derived0): Fix for BT_CLASS.
* trans-decl.c (gfc_get_symbol_decl): Set GFC_DECL_CLASS, where
appropriate.
(gfc_trans_deferred_vars): Get class arrays right.
* match.c(select_type_set_tmp): Add array spec to temporary.
(gfc_match_select_type): Allow class arrays.
* check.c (array_check): Ensure that class arrays have refs.
(dim_corank_check, dim_rank_check): Retrun success if class.
* primary.c (gfc_match_varspec): Fix for class arrays and
co-arrays. Make sure that class _data is present.
(gfc_match_rvalue): Handle class arrays.
*trans-intrinsic.c (gfc_conv_intrinsic_size): Add class array
reference.
(gfc_conv_allocated): Add _data component to class expressions.
(gfc_add_intrinsic_ss_code): ditto.
* simplify.c (simplify_cobound): Fix for BT_CLASS.
(simplify_bound): Return NULL for class arrays.
(simplify_cobound): Obtain correct array_spec. Use cotype as
appropriate. Use arrayspec for bounds.
2011-12-11 Thomas Koenig <tkoenig@gcc.gnu.org>
PR fortran/50690

6
gcc/fortran/array.c
View File

@ -2112,6 +2112,9 @@ gfc_array_dimen_size (gfc_expr *array, int dimen, mpz_t *result)
gfc_ref *ref;
int i;
if (array->ts.type == BT_CLASS)
return FAILURE;
if (dimen < 0 || array == NULL || dimen > array->rank - 1)
gfc_internal_error ("gfc_array_dimen_size(): Bad dimension");
@ -2190,6 +2193,9 @@ gfc_array_size (gfc_expr *array, mpz_t *result)
int i;
gfc_try t;
if (array->ts.type == BT_CLASS)
return FAILURE;
switch (array->expr_type)
{
case EXPR_ARRAY:

14
gcc/fortran/check.c
View File

@ -240,6 +240,14 @@ logical_array_check (gfc_expr *array, int n)
static gfc_try
array_check (gfc_expr *e, int n)
{
if (e->ts.type == BT_CLASS
&& CLASS_DATA (e)->attr.dimension
&& CLASS_DATA (e)->as->rank)
{
gfc_add_class_array_ref (e);
return SUCCESS;
}
if (e->rank != 0)
return SUCCESS;
@ -554,6 +562,9 @@ dim_corank_check (gfc_expr *dim, gfc_expr *array)
if (dim->expr_type != EXPR_CONSTANT)
return SUCCESS;
if (array->ts.type == BT_CLASS)
return SUCCESS;
corank = gfc_get_corank (array);
@ -587,6 +598,9 @@ dim_rank_check (gfc_expr *dim, gfc_expr *array, int allow_assumed)
if (dim->expr_type != EXPR_CONSTANT)
return SUCCESS;
if (array->ts.type == BT_CLASS)
return SUCCESS;
if (array->expr_type == EXPR_FUNCTION && array->value.function.isym
&& array->value.function.isym->id == GFC_ISYM_SPREAD)
rank = array->rank + 1;

184
gcc/fortran/class.c
View File

@ -64,7 +64,14 @@ gfc_add_component_ref (gfc_expr *e, const char *name)
while (*tail != NULL)
{
if ((*tail)->type == REF_COMPONENT)
derived = (*tail)->u.c.component->ts.u.derived;
{
if (strcmp ((*tail)->u.c.component->name, "_data") == 0
&& (*tail)->next
&& (*tail)->next->type == REF_ARRAY
&& (*tail)->next->next == NULL)
return;
derived = (*tail)->u.c.component->ts.u.derived;
}
if ((*tail)->type == REF_ARRAY && (*tail)->next == NULL)
break;
tail = &((*tail)->next);
@ -82,6 +89,155 @@ gfc_add_component_ref (gfc_expr *e, const char *name)
}
/* This is used to add both the _data component reference and an array
reference to class expressions. Used in translation of intrinsic
array inquiry functions. */
void
gfc_add_class_array_ref (gfc_expr *e)
{
int rank = CLASS_DATA (e)->as->rank;
gfc_array_spec *as = CLASS_DATA (e)->as;
gfc_ref *ref = NULL;
gfc_add_component_ref (e, "_data");
e->rank = rank;
for (ref = e->ref; ref; ref = ref->next)
if (!ref->next)
break;
if (ref->type != REF_ARRAY)
{
ref->next = gfc_get_ref ();
ref = ref->next;
ref->type = REF_ARRAY;
ref->u.ar.type = AR_FULL;
ref->u.ar.as = as;
}
}
/* Unfortunately, class array expressions can appear in various conditions;
with and without both _data component and an arrayspec. This function
deals with that variability. The previous reference to 'ref' is to a
class array. */
static bool
class_array_ref_detected (gfc_ref *ref, bool *full_array)
{
bool no_data = false;
bool with_data = false;
/* An array reference with no _data component. */
if (ref && ref->type == REF_ARRAY
&& !ref->next
&& ref->u.ar.type != AR_ELEMENT)
{
if (full_array)
*full_array = ref->u.ar.type == AR_FULL;
no_data = true;
}
/* Cover cases where _data appears, with or without an array ref. */
if (ref && ref->type == REF_COMPONENT
&& strcmp (ref->u.c.component->name, "_data") == 0)
{
if (!ref->next)
{
with_data = true;
if (full_array)
*full_array = true;
}
else if (ref->next && ref->next->type == REF_ARRAY
&& !ref->next->next
&& ref->type == REF_COMPONENT
&& ref->next->type == REF_ARRAY
&& ref->next->u.ar.type != AR_ELEMENT)
{
with_data = true;
if (full_array)
*full_array = ref->next->u.ar.type == AR_FULL;
}
}
return no_data || with_data;
}
/* Returns true if the expression contains a reference to a class
array. Notice that class array elements return false. */
bool
gfc_is_class_array_ref (gfc_expr *e, bool *full_array)
{
gfc_ref *ref;
if (!e->rank)
return false;
if (full_array)
*full_array= false;
/* Is this a class array object? ie. Is the symbol of type class? */
if (e->symtree
&& e->symtree->n.sym->ts.type == BT_CLASS
&& CLASS_DATA (e->symtree->n.sym)
&& CLASS_DATA (e->symtree->n.sym)->attr.dimension
&& class_array_ref_detected (e->ref, full_array))
return true;
/* Or is this a class array component reference? */
for (ref = e->ref; ref; ref = ref->next)
{
if (ref->type == REF_COMPONENT
&& ref->u.c.component->ts.type == BT_CLASS
&& CLASS_DATA (ref->u.c.component)->attr.dimension
&& class_array_ref_detected (ref->next, full_array))
return true;
}
return false;
}
/* Returns true if the expression is a reference to a class
scalar. This function is necessary because such expressions
can be dressed with a reference to the _data component and so
have a type other than BT_CLASS. */
bool
gfc_is_class_scalar_expr (gfc_expr *e)
{
gfc_ref *ref;
if (e->rank)
return false;
/* Is this a class object? */
if (e->symtree
&& e->symtree->n.sym->ts.type == BT_CLASS
&& CLASS_DATA (e->symtree->n.sym)
&& !CLASS_DATA (e->symtree->n.sym)->attr.dimension
&& (e->ref == NULL
|| (strcmp (e->ref->u.c.component->name, "_data") == 0
&& e->ref->next == NULL)))
return true;
/* Or is the final reference BT_CLASS or _data? */
for (ref = e->ref; ref; ref = ref->next)
{
if (ref->type == REF_COMPONENT
&& ref->u.c.component->ts.type == BT_CLASS
&& CLASS_DATA (ref->u.c.component)
&& !CLASS_DATA (ref->u.c.component)->attr.dimension
&& (ref->next == NULL
|| (strcmp (ref->next->u.c.component->name, "_data") == 0
&& ref->next->next == NULL)))
return true;
}
return false;
}
/* Build a NULL initializer for CLASS pointers,
initializing the _data component to NULL and
the _vptr component to the declared type. */
@ -183,7 +339,14 @@ gfc_build_class_symbol (gfc_typespec *ts, symbol_attribute *attr,
gfc_symbol *fclass;
gfc_symbol *vtab;
gfc_component *c;
if (as && *as && (*as)->type == AS_ASSUMED_SIZE)
{
gfc_error ("Assumed size polymorphic objects or components, such "
"as that at %C, have not yet been implemented");
return FAILURE;
}
if (attr->class_ok)
/* Class container has already been built. */
return SUCCESS;
@ -195,12 +358,6 @@ gfc_build_class_symbol (gfc_typespec *ts, symbol_attribute *attr,
/* We can not build the class container yet. */
return SUCCESS;
if (*as)
{
gfc_fatal_error ("Polymorphic array at %C not yet supported");
return FAILURE;
}
/* Determine the name of the encapsulating type. */
get_unique_hashed_string (tname, ts->u.derived);
if ((*as) && (*as)->rank && attr->allocatable)
@ -277,8 +434,8 @@ gfc_build_class_symbol (gfc_typespec *ts, symbol_attribute *attr,
fclass->attr.extension = ts->u.derived->attr.extension + 1;
fclass->attr.is_class = 1;
ts->u.derived = fclass;
attr->allocatable = attr->pointer = attr->dimension = 0;
(*as) = NULL; /* XXX */
attr->allocatable = attr->pointer = attr->dimension = attr->codimension = 0;
(*as) = NULL;
return SUCCESS;
}
@ -402,7 +559,7 @@ gfc_find_derived_vtab (gfc_symbol *derived)
gfc_namespace *ns;
gfc_symbol *vtab = NULL, *vtype = NULL, *found_sym = NULL, *def_init = NULL;
gfc_symbol *copy = NULL, *src = NULL, *dst = NULL;
/* Find the top-level namespace (MODULE or PROGRAM). */
for (ns = gfc_current_ns; ns; ns = ns->parent)
if (!ns->parent)
@ -556,6 +713,9 @@ gfc_find_derived_vtab (gfc_symbol *derived)
copy->attr.flavor = FL_PROCEDURE;
copy->attr.subroutine = 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);
@ -565,6 +725,7 @@ gfc_find_derived_vtab (gfc_symbol *derived)
src->ts.u.derived = derived;
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;
@ -573,6 +734,7 @@ gfc_find_derived_vtab (gfc_symbol *derived)
dst->ts.u.derived = derived;
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;

21
gcc/fortran/expr.c
View File

@ -4309,7 +4309,11 @@ gfc_get_corank (gfc_expr *e)
if (!gfc_is_coarray (e))
return 0;
corank = e->symtree->n.sym->as ? e->symtree->n.sym->as->corank : 0;
if (e->ts.type == BT_CLASS && e->ts.u.derived->components)
corank = e->ts.u.derived->components->as
? e->ts.u.derived->components->as->corank : 0;
else
corank = e->symtree->n.sym->as ? e->symtree->n.sym->as->corank : 0;
for (ref = e->ref; ref; ref = ref->next)
{
@ -4394,6 +4398,7 @@ gfc_is_simply_contiguous (gfc_expr *expr, bool strict)
int i;
gfc_array_ref *ar = NULL;
gfc_ref *ref, *part_ref = NULL;
gfc_symbol *sym;
if (expr->expr_type == EXPR_FUNCTION)
return expr->value.function.esym
@ -4417,11 +4422,15 @@ gfc_is_simply_contiguous (gfc_expr *expr, bool strict)
ar = &ref->u.ar;
}
if ((part_ref && !part_ref->u.c.component->attr.contiguous
&& part_ref->u.c.component->attr.pointer)
|| (!part_ref && !expr->symtree->n.sym->attr.contiguous
&& (expr->symtree->n.sym->attr.pointer
|| expr->symtree->n.sym->as->type == AS_ASSUMED_SHAPE)))
sym = expr->symtree->n.sym;
if (expr->ts.type != BT_CLASS
&& ((part_ref
&& !part_ref->u.c.component->attr.contiguous
&& part_ref->u.c.component->attr.pointer)
|| (!part_ref
&& !sym->attr.contiguous
&& (sym->attr.pointer
|| sym->as->type == AS_ASSUMED_SHAPE))))
return false;
if (!ar || ar->type == AR_FULL)

3
gcc/fortran/gfortran.h
View File

@ -2911,11 +2911,14 @@ gfc_try gfc_calculate_transfer_sizes (gfc_expr*, gfc_expr*, gfc_expr*,
/* class.c */
void gfc_add_component_ref (gfc_expr *, const char *);
void gfc_add_class_array_ref (gfc_expr *);
#define gfc_add_data_component(e) gfc_add_component_ref(e,"_data")
#define gfc_add_vptr_component(e) gfc_add_component_ref(e,"_vptr")
#define gfc_add_hash_component(e) gfc_add_component_ref(e,"_hash")
#define gfc_add_size_component(e) gfc_add_component_ref(e,"_size")
#define gfc_add_def_init_component(e) gfc_add_component_ref(e,"_def_init")
bool gfc_is_class_array_ref (gfc_expr *, bool *);
bool gfc_is_class_scalar_expr (gfc_expr *);
gfc_expr *gfc_class_null_initializer (gfc_typespec *);
unsigned int gfc_hash_value (gfc_symbol *);
gfc_try gfc_build_class_symbol (gfc_typespec *, symbol_attribute *,

36
gcc/fortran/interface.c
View File

@ -1541,6 +1541,9 @@ done:
static int
symbol_rank (gfc_symbol *sym)
{
if (sym->ts.type == BT_CLASS && CLASS_DATA (sym)->as)
return CLASS_DATA (sym)->as->rank;
return (sym->as == NULL) ? 0 : sym->as->rank;
}
@ -1691,7 +1694,10 @@ compare_parameter (gfc_symbol *formal, gfc_expr *actual,
if ((actual->expr_type != EXPR_NULL || actual->ts.type != BT_UNKNOWN)
&& actual->ts.type != BT_HOLLERITH
&& !gfc_compare_types (&formal->ts, &actual->ts))
&& !gfc_compare_types (&formal->ts, &actual->ts)
&& !(formal->ts.type == BT_DERIVED && actual->ts.type == BT_CLASS
&& gfc_compare_derived_types (formal->ts.u.derived,
CLASS_DATA (actual)->ts.u.derived)))
{
if (where)
gfc_error ("Type mismatch in argument '%s' at %L; passed %s to %s",
@ -1820,6 +1826,10 @@ compare_parameter (gfc_symbol *formal, gfc_expr *actual,
if (symbol_rank (formal) == actual->rank)
return 1;
if (actual->ts.type == BT_CLASS && CLASS_DATA (actual)->as
&& CLASS_DATA (actual)->as->rank == symbol_rank (formal))
return 1;
rank_check = where != NULL && !is_elemental && formal->as
&& (formal->as->type == AS_ASSUMED_SHAPE
|| formal->as->type == AS_DEFERRED)
@ -1829,7 +1839,11 @@ compare_parameter (gfc_symbol *formal, gfc_expr *actual,
if (rank_check || ranks_must_agree
|| (formal->attr.pointer && actual->expr_type != EXPR_NULL)
|| (actual->rank != 0 && !(is_elemental || formal->attr.dimension))
|| (actual->rank == 0 && formal->as->type == AS_ASSUMED_SHAPE
|| (actual->rank == 0
&& ((formal->ts.type == BT_CLASS
&& CLASS_DATA (formal)->as->type == AS_ASSUMED_SHAPE)
|| (formal->ts.type != BT_CLASS
&& formal->as->type == AS_ASSUMED_SHAPE))
&& actual->expr_type != EXPR_NULL)
|| (actual->rank == 0 && formal->attr.dimension
&& gfc_is_coindexed (actual)))
@ -2158,6 +2172,7 @@ compare_actual_formal (gfc_actual_arglist **ap, gfc_formal_arglist *formal,
gfc_formal_arglist *f;
int i, n, na;
unsigned long actual_size, formal_size;
bool full_array = false;
actual = *ap;
@ -2297,6 +2312,9 @@ compare_actual_formal (gfc_actual_arglist **ap, gfc_formal_arglist *formal,
return 0;
}
if (f->sym->ts.type == BT_CLASS)
goto skip_size_check;
actual_size = get_expr_storage_size (a->expr);
formal_size = get_sym_storage_size (f->sym);
if (actual_size != 0 && actual_size < formal_size
@ -2316,6 +2334,8 @@ compare_actual_formal (gfc_actual_arglist **ap, gfc_formal_arglist *formal,
return 0;
}
skip_size_check:
/* Satisfy 12.4.1.3 by ensuring that a procedure pointer actual argument
is provided for a procedure pointer formal argument. */
if (f->sym->attr.proc_pointer
@ -2428,6 +2448,18 @@ compare_actual_formal (gfc_actual_arglist **ap, gfc_formal_arglist *formal,
return 0;
}
if (f->sym->ts.type == BT_CLASS
&& CLASS_DATA (f->sym)->attr.allocatable
&& gfc_is_class_array_ref (a->expr, &full_array)
&& !full_array)
{
if (where)
gfc_error ("Actual CLASS array argument for '%s' must be a full "
"array at %L", f->sym->name, &a->expr->where);
return 0;
}
if (a->expr->expr_type != EXPR_NULL
&& compare_allocatable (f->sym, a->expr) == 0)
{

40
gcc/fortran/match.c
View File

@ -5151,6 +5151,27 @@ select_type_set_tmp (gfc_typespec *ts)
sprintf (name, "__tmp_type_%s", ts->u.derived->name);
gfc_get_sym_tree (name, gfc_current_ns, &tmp, false);
gfc_add_type (tmp->n.sym, ts, NULL);
/* Copy across the array spec to the selector, taking care as to
whether or not it is a class object or not. */
if (select_type_stack->selector->ts.type == BT_CLASS &&
CLASS_DATA (select_type_stack->selector)->attr.dimension)
{
if (ts->type == BT_CLASS)
{
CLASS_DATA (tmp->n.sym)->attr.dimension = 1;
CLASS_DATA (tmp->n.sym)->as = gfc_get_array_spec ();
CLASS_DATA (tmp->n.sym)->as
= CLASS_DATA (select_type_stack->selector)->as;
}
else
{
tmp->n.sym->attr.dimension = 1;
tmp->n.sym->as = gfc_get_array_spec ();
tmp->n.sym->as = 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;
@ -5176,6 +5197,7 @@ gfc_match_select_type (void)
gfc_expr *expr1, *expr2 = NULL;
match m;
char name[GFC_MAX_SYMBOL_LEN];
bool class_array;
m = gfc_match_label ();
if (m == MATCH_ERROR)
@ -5216,8 +5238,24 @@ gfc_match_select_type (void)
if (m != MATCH_YES)
goto cleanup;
/* This ghastly expression seems to be needed to distinguish a CLASS
array, which can have a reference, from other expressions that
have references, such as derived type components, and are not
allowed by the standard.
TODO; see is it is sufficent to exclude component and substring
references. */
class_array = expr1->expr_type == EXPR_VARIABLE
&& expr1->ts.type != BT_UNKNOWN
&& CLASS_DATA (expr1)
&& (strcmp (CLASS_DATA (expr1)->name, "_data") == 0)
&& CLASS_DATA (expr1)->attr.dimension
&& expr1->ref
&& expr1->ref->type == REF_ARRAY
&& expr1->ref->next == NULL;
/* Check for F03:C811. */
if (!expr2 && (expr1->expr_type != EXPR_VARIABLE || expr1->ref != NULL))
if (!expr2 && (expr1->expr_type != EXPR_VARIABLE
|| (!class_array && expr1->ref != NULL)))
{
gfc_error ("Selector in SELECT TYPE at %C is not a named variable; "
"use associate-name=>");

26
gcc/fortran/primary.c
View File

@ -1789,13 +1789,17 @@ gfc_match_varspec (gfc_expr *primary, int equiv_flag, bool sub_flag,
if (gfc_peek_ascii_char () == '[')
{
if (sym->attr.dimension)
if ((sym->ts.type != BT_CLASS && sym->attr.dimension)
|| (sym->ts.type == BT_CLASS && CLASS_DATA (sym)
&& CLASS_DATA (sym)->attr.dimension))
{
gfc_error ("Array section designator, e.g. '(:)', is required "
"besides the coarray designator '[...]' at %C");
return MATCH_ERROR;
}
if (!sym->attr.codimension)
if ((sym->ts.type != BT_CLASS && !sym->attr.codimension)
|| (sym->ts.type == BT_CLASS && CLASS_DATA (sym)
&& !CLASS_DATA (sym)->attr.codimension))
{
gfc_error ("Coarray designator at %C but '%s' is not a coarray",
sym->name);
@ -1827,7 +1831,7 @@ gfc_match_varspec (gfc_expr *primary, int equiv_flag, bool sub_flag,
m = gfc_match_array_ref (&tail->u.ar, equiv_flag ? NULL : sym->as,
equiv_flag,
sym->ts.type == BT_CLASS
sym->ts.type == BT_CLASS && CLASS_DATA (sym)
? (CLASS_DATA (sym)->as
? CLASS_DATA (sym)->as->corank : 0)
: (sym->as ? sym->as->corank : 0));
@ -2909,6 +2913,22 @@ gfc_match_rvalue (gfc_expr **result)
break;
}
if (sym->ts.type == BT_CLASS && CLASS_DATA (sym)->attr.dimension)
{
if (gfc_add_flavor (&sym->attr, FL_VARIABLE,
sym->name, NULL) == FAILURE)
{
m = MATCH_ERROR;
break;
}
e = gfc_get_expr ();
e->symtree = symtree;
e->expr_type = EXPR_VARIABLE;
m = gfc_match_varspec (e, 0, false, true);
break;
}
/* Name is not an array, so we peek to see if a '(' implies a
function call or a substring reference. Otherwise the
variable is just a scalar. */

46
gcc/fortran/resolve.c
View File

@ -5584,14 +5584,6 @@ check_typebound_baseobject (gfc_expr* e)
goto cleanup;
}
/* FIXME: Remove once PR 43214 is fixed (TBP with non-scalar PASS). */
if (base->rank > 0)
{
gfc_error ("Non-scalar base object at %L currently not implemented",
&e->where);
goto cleanup;
}
return_value = SUCCESS;
cleanup:
@ -6765,7 +6757,7 @@ resolve_allocate_expr (gfc_expr *e, gfc_code *code)
}
else
{
if (sym->ts.type == BT_CLASS)
if (sym->ts.type == BT_CLASS && CLASS_DATA (sym))
{
allocatable = CLASS_DATA (sym)->attr.allocatable;
pointer = CLASS_DATA (sym)->attr.class_pointer;
@ -6911,7 +6903,16 @@ resolve_allocate_expr (gfc_expr *e, gfc_code *code)
if (t == FAILURE)
goto failure;
if (!code->expr3)
if (e->ts.type == BT_CLASS && CLASS_DATA (e)->attr.dimension
&& !code->expr3 && code->ext.alloc.ts.type == BT_DERIVED)
{
/* For class arrays, the initialization with SOURCE is done
using _copy and trans_call. It is convenient to exploit that
when the allocated type is different from the declared type but
no SOURCE exists by setting expr3. */
code->expr3 = gfc_default_initializer (&code->ext.alloc.ts);
}
else if (!code->expr3)
{
/* Set up default initializer if needed. */
gfc_typespec ts;
@ -6955,6 +6956,8 @@ resolve_allocate_expr (gfc_expr *e, gfc_code *code)
else if (code->ext.alloc.ts.type == BT_DERIVED)
ts = code->ext.alloc.ts;
gfc_find_derived_vtab (ts.u.derived);
if (dimension)
e = gfc_expr_to_initialize (e);
}
if (dimension == 0 && codimension == 0)
@ -7531,16 +7534,6 @@ resolve_select (gfc_code *code)
return;
}
if (case_expr->rank != 0)
{
gfc_error ("Argument of SELECT statement at %L must be a scalar "
"expression", &case_expr->where);
/* Punt. */
return;
}
/* Raise a warning if an INTEGER case value exceeds the range of
the case-expr. Later, all expressions will be promoted to the
largest kind of all case-labels. */
@ -7825,6 +7818,9 @@ resolve_assoc_var (gfc_symbol* sym, bool resolve_target)
sym->attr.volatile_ = tsym->attr.volatile_;
sym->attr.target = (tsym->attr.target || tsym->attr.pointer);
if (sym->ts.type == BT_DERIVED && target->symtree->n.sym->ts.type == BT_CLASS)
target->rank = sym->as ? sym->as->rank : 0;
}
/* Get type if this was not already set. Note that it can be
@ -7839,7 +7835,10 @@ resolve_assoc_var (gfc_symbol* sym, bool resolve_target)
&& !gfc_has_vector_subscript (target));
/* Finally resolve if this is an array or not. */
if (sym->attr.dimension && target->rank == 0)
if (sym->attr.dimension
&& (target->ts.type == BT_CLASS
? !CLASS_DATA (target)->attr.dimension
: target->rank == 0))
{
gfc_error ("Associate-name '%s' at %L is used as array",
sym->name, &sym->declared_at);
@ -7955,6 +7954,7 @@ resolve_select_type (gfc_code *code, gfc_namespace *old_ns)
assoc = gfc_get_association_list ();
assoc->st = code->expr1->symtree;
assoc->target = gfc_copy_expr (code->expr2);
assoc->target->where = code->expr2->where;
/* assoc->variable will be set by resolve_assoc_var. */
code->ext.block.assoc = assoc;
@ -8006,6 +8006,7 @@ resolve_select_type (gfc_code *code, gfc_namespace *old_ns)
st = gfc_find_symtree (ns->sym_root, name);
gcc_assert (st->n.sym->assoc);
st->n.sym->assoc->target = gfc_get_variable_expr (code->expr1->symtree);
st->n.sym->assoc->target->where = code->expr1->where;
if (c->ts.type == BT_DERIVED)
gfc_add_data_component (st->n.sym->assoc->target);
@ -11432,7 +11433,8 @@ resolve_fl_derived0 (gfc_symbol *sym)
for (c = sym->components; c != NULL; c = c->next)
{
/* F2008, C442. */
if (c->attr.codimension /* FIXME: c->as check due to PR 43412. */
if ((!sym->attr.is_class || c != sym->components)
&& c->attr.codimension
&& (!c->attr.allocatable || (c->as && c->as->type != AS_DEFERRED)))
{
gfc_error ("Coarray component '%s' at %L must be allocatable with "

16
gcc/fortran/simplify.c
View File

@ -3326,6 +3326,9 @@ simplify_bound (gfc_expr *array, gfc_expr *dim, gfc_expr *kind, int upper)
gfc_array_spec *as;
int d;
if (array->ts.type == BT_CLASS)
return NULL;
if (array->expr_type != EXPR_VARIABLE)
{
as = NULL;
@ -3462,7 +3465,9 @@ simplify_cobound (gfc_expr *array, gfc_expr *dim, gfc_expr *kind, int upper)
return NULL;
/* Follow any component references. */
as = array->symtree->n.sym->as;
as = (array->ts.type == BT_CLASS && array->ts.u.derived->components)
? array->ts.u.derived->components->as
: array->symtree->n.sym->as;
for (ref = array->ref; ref; ref = ref->next)
{
switch (ref->type)
@ -3506,11 +3511,12 @@ simplify_cobound (gfc_expr *array, gfc_expr *dim, gfc_expr *kind, int upper)
}
}
gcc_unreachable ();
if (!as)
gcc_unreachable ();
done:
if (as->type == AS_DEFERRED || as->type == AS_ASSUMED_SHAPE)
if (as->cotype == AS_DEFERRED || as->cotype == AS_ASSUMED_SHAPE)
return NULL;
if (dim == NULL)
@ -3523,7 +3529,7 @@ simplify_cobound (gfc_expr *array, gfc_expr *dim, gfc_expr *kind, int upper)
/* Simplify the cobounds for each dimension. */
for (d = 0; d < as->corank; d++)
{
bounds[d] = simplify_bound_dim (array, kind, d + 1 + array->rank,
bounds[d] = simplify_bound_dim (array, kind, d + 1 + as->rank,
upper, as, ref, true);
if (bounds[d] == NULL || bounds[d] == &gfc_bad_expr)
{
@ -3575,7 +3581,7 @@ simplify_cobound (gfc_expr *array, gfc_expr *dim, gfc_expr *kind, int upper)
return &gfc_bad_expr;
}
return simplify_bound_dim (array, kind, d+array->rank, upper, as, ref, true);
return simplify_bound_dim (array, kind, d+as->rank, upper, as, ref, true);
}
}

165
gcc/fortran/trans-array.c
View File

@ -2428,9 +2428,18 @@ gfc_add_loop_ss_code (gfc_loopinfo * loop, gfc_ss * ss, bool subscript,
gfc_conv_expr (&se, expr);
gfc_add_block_to_block (&outer_loop->pre, &se.pre);
gfc_add_block_to_block (&outer_loop->post, &se.post);
if (gfc_is_class_scalar_expr (expr))
/* This is necessary because the dynamic type will always be
large than the declared type. In consequence, assigning
the value to a temporary could segfault.
OOP-TODO: see if this is generally correct or is the value
has to be written to an allocated temporary, whose address
is passed via ss_info. */
ss_info->data.scalar.value = se.expr;
else
ss_info->data.scalar.value = gfc_evaluate_now (se.expr,
&outer_loop->pre);
ss_info->data.scalar.value = gfc_evaluate_now (se.expr,
&outer_loop->pre);
ss_info->string_length = se.string_length;
break;
@ -2879,6 +2888,82 @@ conv_array_index_offset (gfc_se * se, gfc_ss * ss, int dim, int i,
}
/* Build a scalarized array reference using the vptr 'size'. */
static bool
build_class_array_ref (gfc_se *se, tree base, tree index)
{
tree type;
tree size;
tree offset;
tree decl;
tree tmp;
gfc_expr *expr = se->ss->info->expr;
gfc_ref *ref;
gfc_ref *class_ref;
gfc_typespec *ts;
if (expr == NULL || expr->ts.type != BT_CLASS)
return false;
if (expr->symtree && expr->symtree->n.sym->ts.type == BT_CLASS)
ts = &expr->symtree->n.sym->ts;
else
ts = NULL;
class_ref = NULL;
for (ref = expr->ref; ref; ref = ref->next)
{
if (ref->type == REF_COMPONENT
&& ref->u.c.component->ts.type == BT_CLASS
&& ref->next && ref->next->type == REF_COMPONENT
&& strcmp (ref->next->u.c.component->name, "_data") == 0
&& ref->next->next
&& ref->next->next->type == REF_ARRAY
&& ref->next->next->u.ar.type != AR_ELEMENT)
{
ts = &ref->u.c.component->ts;
class_ref = ref;
break;
}
}
if (ts == NULL)
return false;
if (class_ref == NULL)
decl = expr->symtree->n.sym->backend_decl;
else
{
/* Remove everything after the last class reference, convert the
expression and then recover its tailend once more. */
gfc_se tmpse;
ref = class_ref->next;
class_ref->next = NULL;
gfc_init_se (&tmpse, NULL);
gfc_conv_expr (&tmpse, expr);
decl = tmpse.expr;
class_ref->next = ref;
}
size = gfc_vtable_size_get (decl);
/* Build the address of the element. */
type = TREE_TYPE (TREE_TYPE (base));
size = fold_convert (TREE_TYPE (index), size);
offset = fold_build2_loc (input_location, MULT_EXPR,
gfc_array_index_type,
index, size);
tmp = gfc_build_addr_expr (pvoid_type_node, base);
tmp = fold_build_pointer_plus_loc (input_location, tmp, offset);
tmp = fold_convert (build_pointer_type (type), tmp);
/* Return the element in the se expression. */
se->expr = build_fold_indirect_ref_loc (input_location, tmp);
return true;
}
/* Build a scalarized reference to an array. */
static void
@ -2911,6 +2996,12 @@ gfc_conv_scalarized_array_ref (gfc_se * se, gfc_array_ref * ar)
decl = expr->symtree->n.sym->backend_decl;
tmp = build_fold_indirect_ref_loc (input_location, info->data);
/* Use the vptr 'size' field to access a class the element of a class
array. */
if (build_class_array_ref (se, tmp, index))
return;
se->expr = gfc_build_array_ref (tmp, index, decl);
}
@ -4592,7 +4683,8 @@ gfc_conv_descriptor_cosize (tree desc, int rank, int corank)
static tree
gfc_array_init_size (tree descriptor, int rank, int corank, tree * poffset,
gfc_expr ** lower, gfc_expr ** upper, stmtblock_t * pblock,
stmtblock_t * descriptor_block, tree * overflow)
stmtblock_t * descriptor_block, tree * overflow,
gfc_expr *expr3)
{
tree type;
tree tmp;
@ -4747,8 +4839,30 @@ gfc_array_init_size (tree descriptor, int rank, int corank, tree * poffset,
}
/* The stride is the number of elements in the array, so multiply by the
size of an element to get the total size. */
tmp = TYPE_SIZE_UNIT (gfc_get_element_type (type));
size of an element to get the total size. Obviously, if there ia a
SOURCE expression (expr3) we must use its element size. */
if (expr3 != NULL)
{
if (expr3->ts.type == BT_CLASS)
{
gfc_se se_sz;
gfc_expr *sz = gfc_copy_expr (expr3);
gfc_add_vptr_component (sz);
gfc_add_size_component (sz);
gfc_init_se (&se_sz, NULL);
gfc_conv_expr (&se_sz, sz);
gfc_free_expr (sz);
tmp = se_sz.expr;
}
else
{
tmp = gfc_typenode_for_spec (&expr3->ts);
tmp = TYPE_SIZE_UNIT (tmp);
}
}
else
tmp = TYPE_SIZE_UNIT (gfc_get_element_type (type));
/* Convert to size_t. */
element_size = fold_convert (size_type_node, tmp);
@ -4813,7 +4927,7 @@ gfc_array_init_size (tree descriptor, int rank, int corank, tree * poffset,
bool
gfc_array_allocate (gfc_se * se, gfc_expr * expr, tree status, tree errmsg,
tree errlen)
tree errlen, gfc_expr *expr3)
{
tree tmp;
tree pointer;
@ -4897,7 +5011,8 @@ gfc_array_allocate (gfc_se * se, gfc_expr * expr, tree status, tree errmsg,
gfc_init_block (&set_descriptor_block);
size = gfc_array_init_size (se->expr, ref->u.ar.as->rank,
ref->u.ar.as->corank, &offset, lower, upper,
&se->pre, &set_descriptor_block, &overflow);
&se->pre, &set_descriptor_block, &overflow,
expr3);
if (dimension)
{
@ -4972,7 +5087,7 @@ gfc_array_allocate (gfc_se * se, gfc_expr * expr, tree status, tree errmsg,
else
gfc_add_expr_to_block (&se->pre, set_descriptor);
if ((expr->ts.type == BT_DERIVED || expr->ts.type == BT_CLASS)
if ((expr->ts.type == BT_DERIVED)
&& expr->ts.u.derived->attr.alloc_comp)
{
tmp = gfc_nullify_alloc_comp (expr->ts.u.derived, se->expr,
@ -7240,7 +7355,7 @@ structure_alloc_comps (gfc_symbol * der_type, tree decl,
}
else if (c->ts.type == BT_CLASS && CLASS_DATA (c)->attr.allocatable)
{
/* Allocatable scalar CLASS components. */
/* Allocatable CLASS components. */
comp = fold_build3_loc (input_location, COMPONENT_REF, ctype,
decl, cdecl, NULL_TREE);
@ -7249,13 +7364,18 @@ structure_alloc_comps (gfc_symbol * der_type, tree decl,
comp = fold_build3_loc (input_location, COMPONENT_REF,
TREE_TYPE (tmp), comp, tmp, NULL_TREE);
tmp = gfc_deallocate_scalar_with_status (comp, NULL, true, NULL,
CLASS_DATA (c)->ts);
gfc_add_expr_to_block (&fnblock, tmp);
if (GFC_DESCRIPTOR_TYPE_P(TREE_TYPE (comp)))
tmp = gfc_trans_dealloc_allocated (comp);
else
{
tmp = gfc_deallocate_scalar_with_status (comp, NULL, true, NULL,
CLASS_DATA (c)->ts);
gfc_add_expr_to_block (&fnblock, tmp);
tmp = fold_build2_loc (input_location, MODIFY_EXPR,
void_type_node, comp,
build_int_cst (TREE_TYPE (comp), 0));
tmp = fold_build2_loc (input_location, MODIFY_EXPR,
void_type_node, comp,
build_int_cst (TREE_TYPE (comp), 0));
}
gfc_add_expr_to_block (&fnblock, tmp);
}
break;
@ -7282,17 +7402,22 @@ structure_alloc_comps (gfc_symbol * der_type, tree decl,
}
else if (c->ts.type == BT_CLASS && CLASS_DATA (c)->attr.allocatable)
{
/* Allocatable scalar CLASS components. */
/* Allocatable CLASS components. */
comp = fold_build3_loc (input_location, COMPONENT_REF, ctype,
decl, cdecl, NULL_TREE);
/* Add reference to '_data' component. */
tmp = CLASS_DATA (c)->backend_decl;
comp = fold_build3_loc (input_location, COMPONENT_REF,
TREE_TYPE (tmp), comp, tmp, NULL_TREE);
tmp = fold_build2_loc (input_location, MODIFY_EXPR,
void_type_node, comp,
build_int_cst (TREE_TYPE (comp), 0));
gfc_add_expr_to_block (&fnblock, tmp);
if (GFC_DESCRIPTOR_TYPE_P(TREE_TYPE (comp)))
gfc_conv_descriptor_data_set (&fnblock, comp, null_pointer_node);
else
{
tmp = fold_build2_loc (input_location, MODIFY_EXPR,
void_type_node, comp,
build_int_cst (TREE_TYPE (comp), 0));
gfc_add_expr_to_block (&fnblock, tmp);
}
}
else if (cmp_has_alloc_comps)
{

4
gcc/fortran/trans-array.h
View File

@ -22,9 +22,9 @@ along with GCC; see the file COPYING3. If not see
/* Generate code to free an array. */
tree gfc_array_deallocate (tree, tree, gfc_expr*);
/* Generate code to initialize an allocate an array. Statements are added to
/* Generate code to initialize and allocate an array. Statements are added to
se, which should contain an expression for the array descriptor. */
bool gfc_array_allocate (gfc_se *, gfc_expr *, tree, tree, tree);
bool gfc_array_allocate (gfc_se *, gfc_expr *, tree, tree, tree, gfc_expr *);
/* Allow the bounds of a loop to be set from a callee's array spec. */
void gfc_set_loop_bounds_from_array_spec (gfc_interface_mapping *,

42
gcc/fortran/trans-decl.c
View File

@ -1293,7 +1293,12 @@ gfc_get_symbol_decl (gfc_symbol * sym)
&& DECL_CONTEXT (sym->backend_decl) != current_function_decl)
gfc_nonlocal_dummy_array_decl (sym);
return sym->backend_decl;
if (sym->ts.type == BT_CLASS && sym->backend_decl)
GFC_DECL_CLASS(sym->backend_decl) = 1;
if (sym->ts.type == BT_CLASS && sym->backend_decl)
GFC_DECL_CLASS(sym->backend_decl) = 1;
return sym->backend_decl;
}
if (sym->backend_decl)
@ -1314,7 +1319,11 @@ gfc_get_symbol_decl (gfc_symbol * sym)
&& !intrinsic_array_parameter
&& sym->module
&& gfc_get_module_backend_decl (sym))
return sym->backend_decl;
{
if (sym->ts.type == BT_CLASS && sym->backend_decl)
GFC_DECL_CLASS(sym->backend_decl) = 1;
return sym->backend_decl;
}
if (sym->attr.flavor == FL_PROCEDURE)
{
@ -1431,6 +1440,9 @@ gfc_get_symbol_decl (gfc_symbol * sym)
GFC_TYPE_ARRAY_SPAN (TREE_TYPE (decl)) = span;
}
if (sym->ts.type == BT_CLASS)
GFC_DECL_CLASS(decl) = 1;
sym->backend_decl = decl;
if (sym->attr.assign)
@ -3655,6 +3667,10 @@ gfc_trans_deferred_vars (gfc_symbol * proc_sym, gfc_wrapped_block * block)
if (sym_has_alloc_comp && !seen_trans_deferred_array)
gfc_trans_deferred_array (sym, block);
}
else if ((!sym->attr.dummy || sym->ts.deferred)
&& (sym->ts.type == BT_CLASS
&& CLASS_DATA (sym)->attr.pointer))
break;
else if ((!sym->attr.dummy || sym->ts.deferred)
&& (sym->attr.allocatable
|| (sym->ts.type == BT_CLASS
@ -3669,8 +3685,26 @@ gfc_trans_deferred_vars (gfc_symbol * proc_sym, gfc_wrapped_block * block)
gfc_add_data_component (e);
gfc_init_se (&se, NULL);
se.want_pointer = 1;
gfc_conv_expr (&se, e);
if (sym->ts.type != BT_CLASS
|| sym->ts.u.derived->attr.dimension
|| sym->ts.u.derived->attr.codimension)
{
se.want_pointer = 1;
gfc_conv_expr (&se, e);
}
else if (sym->ts.type == BT_CLASS
&& !CLASS_DATA (sym)->attr.dimension
&& !CLASS_DATA (sym)->attr.codimension)
{
se.want_pointer = 1;
gfc_conv_expr (&se, e);
}
else
{
gfc_conv_expr (&se, e);
se.expr = gfc_conv_descriptor_data_addr (se.expr);
se.expr = build_fold_indirect_ref_loc (input_location, se.expr);
}
gfc_free_expr (e);
gfc_save_backend_locus (&loc);

456
gcc/fortran/trans-expr.c
View File

@ -41,6 +41,270 @@ along with GCC; see the file COPYING3. If not see
#include "trans-stmt.h"
#include "dependency.h"
/* This is the seed for an eventual trans-class.c
The following parameters should not be used directly since they might
in future implementations. Use the corresponding APIs. */
#define CLASS_DATA_FIELD 0
#define CLASS_VPTR_FIELD 1
#define VTABLE_HASH_FIELD 0
#define VTABLE_SIZE_FIELD 1
#define VTABLE_EXTENDS_FIELD 2
#define VTABLE_DEF_INIT_FIELD 3
#define VTABLE_COPY_FIELD 4
tree
gfc_class_data_get (tree decl)
{
tree data;
if (POINTER_TYPE_P (TREE_TYPE (decl)))
decl = build_fold_indirect_ref_loc (input_location, decl);
data = gfc_advance_chain (TYPE_FIELDS (TREE_TYPE (decl)),
CLASS_DATA_FIELD);
return fold_build3_loc (input_location, COMPONENT_REF,
TREE_TYPE (data), decl, data,
NULL_TREE);
}
tree
gfc_class_vptr_get (tree decl)
{
tree vptr;
if (POINTER_TYPE_P (TREE_TYPE (decl)))
decl = build_fold_indirect_ref_loc (input_location, decl);
vptr = gfc_advance_chain (TYPE_FIELDS (TREE_TYPE (decl)),
CLASS_VPTR_FIELD);
return fold_build3_loc (input_location, COMPONENT_REF,
TREE_TYPE (vptr), decl, vptr,
NULL_TREE);
}
static tree
gfc_vtable_field_get (tree decl, int field)
{
tree size;
tree vptr;
vptr = gfc_class_vptr_get (decl);
vptr = build_fold_indirect_ref_loc (input_location, vptr);
size = gfc_advance_chain (TYPE_FIELDS (TREE_TYPE (vptr)),
field);
size = fold_build3_loc (input_location, COMPONENT_REF,
TREE_TYPE (size), vptr, size,
NULL_TREE);
/* Always return size as an array index type. */
if (field == VTABLE_SIZE_FIELD)
size = fold_convert (gfc_array_index_type, size);
gcc_assert (size);
return size;
}
tree
gfc_vtable_hash_get (tree decl)
{
return gfc_vtable_field_get (decl, VTABLE_HASH_FIELD);
}
tree
gfc_vtable_size_get (tree decl)
{
return gfc_vtable_field_get (decl, VTABLE_SIZE_FIELD);
}
tree
gfc_vtable_extends_get (tree decl)
{
return gfc_vtable_field_get (decl, VTABLE_EXTENDS_FIELD);
}
tree
gfc_vtable_def_init_get (tree decl)
{
return gfc_vtable_field_get (decl, VTABLE_DEF_INIT_FIELD);
}
tree
gfc_vtable_copy_get (tree decl)
{
return gfc_vtable_field_get (decl, VTABLE_COPY_FIELD);
}
#undef CLASS_DATA_FIELD
#undef CLASS_VPTR_FIELD
#undef VTABLE_HASH_FIELD
#undef VTABLE_SIZE_FIELD
#undef VTABLE_EXTENDS_FIELD
#undef VTABLE_DEF_INIT_FIELD
#undef VTABLE_COPY_FIELD
/* Takes a derived type expression and returns the address of a temporary
class object of the 'declared' type. */
static void
gfc_conv_derived_to_class (gfc_se *parmse, gfc_expr *e,
gfc_typespec class_ts)
{
gfc_symbol *vtab;
gfc_ss *ss;
tree ctree;
tree var;
tree tmp;
/* The derived type needs to be converted to a temporary
CLASS object. */
tmp = gfc_typenode_for_spec (&class_ts);
var = gfc_create_var (tmp, "class");
/* Set the vptr. */
ctree = gfc_class_vptr_get (var);
/* Remember the vtab corresponds to the derived type
not to the class declared type. */
vtab = gfc_find_derived_vtab (e->ts.u.derived);
gcc_assert (vtab);
tmp = gfc_build_addr_expr (NULL_TREE, gfc_get_symbol_decl (vtab));
gfc_add_modify (&parmse->pre, ctree,
fold_convert (TREE_TYPE (ctree), tmp));
/* Now set the data field. */
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, ss);
gfc_add_modify (&parmse->pre, ctree, parmse->expr);
}
}
/* Pass the address of the class object. */
parmse->expr = gfc_build_addr_expr (NULL_TREE, var);
}
/* Takes a scalarized class array expression and returns the
address of a temporary scalar class object of the 'declared'
type.
OOP-TODO: This could be improved by adding code that branched on
the dynamic type being the same as the declared type. In this case
the original class expression can be passed directly. */
static void
gfc_conv_class_to_class (gfc_se *parmse, gfc_expr *e,
gfc_typespec class_ts, bool elemental)
{
tree ctree;
tree var;
tree tmp;
tree vptr;
gfc_ref *ref;
gfc_ref *class_ref;
bool full_array = false;
class_ref = NULL;
for (ref = e->ref; ref; ref = ref->next)
{
if (ref->type == REF_COMPONENT
&& ref->u.c.component->ts.type == BT_CLASS)
class_ref = ref;
if (ref->next == NULL)
break;
}
if (ref == NULL || class_ref == ref)
return;
/* Test for FULL_ARRAY. */
gfc_is_class_array_ref (e, &full_array);
/* The derived type needs to be converted to a temporary
CLASS object. */
tmp = gfc_typenode_for_spec (&class_ts);
var = gfc_create_var (tmp, "class");
/* Set the data. */
ctree = gfc_class_data_get (var);
gfc_add_modify (&parmse->pre, ctree, parmse->expr);
/* Return the data component, except in the case of scalarized array
references, where nullification of the cannot occur and so there
is no need. */
if (!elemental && full_array)
gfc_add_modify (&parmse->post, parmse->expr, ctree);
/* Set the vptr. */
ctree = gfc_class_vptr_get (var);
/* The vptr is the second field of the actual argument.
First we have to find the corresponding class reference. */
tmp = NULL_TREE;
if (class_ref == NULL
&& e->symtree && e->symtree->n.sym->ts.type == BT_CLASS)
tmp = e->symtree->n.sym->backend_decl;
else
{
/* Remove everything after the last class reference, convert the
expression and then recover its tailend once more. */
gfc_se tmpse;
ref = class_ref->next;
class_ref->next = NULL;
gfc_init_se (&tmpse, NULL);
gfc_conv_expr (&tmpse, e);
class_ref->next = ref;
tmp = tmpse.expr;
}
gcc_assert (tmp != NULL_TREE);
/* Dereference if needs be. */
if (TREE_CODE (TREE_TYPE (tmp)) == REFERENCE_TYPE)
tmp = build_fold_indirect_ref_loc (input_location, tmp);
vptr = gfc_class_vptr_get (tmp);
gfc_add_modify (&parmse->pre, ctree,
fold_convert (TREE_TYPE (ctree), vptr));
/* Return the vptr component, except in the case of scalarized array
references, where the dynamic type cannot change. */
if (!elemental && full_array)
gfc_add_modify (&parmse->post, vptr,
fold_convert (TREE_TYPE (vptr), ctree));
/* Pass the address of the class object. */
parmse->expr = gfc_build_addr_expr (NULL_TREE, var);
}
/* End of prototype trans-class.c */
static tree gfc_trans_structure_assign (tree dest, gfc_expr * expr);
static void gfc_apply_interface_mapping_to_expr (gfc_interface_mapping *,
gfc_expr *);
@ -799,6 +1063,7 @@ gfc_conv_variable (gfc_se * se, gfc_expr * expr)
conv_parent_component_references (se, ref);
gfc_conv_component_ref (se, ref);
break;
case REF_SUBSTRING:
@ -2409,6 +2674,9 @@ gfc_conv_subref_array_arg (gfc_se * parmse, gfc_expr * expr, int g77,
|| GFC_DESCRIPTOR_TYPE_P (base_type))
base_type = gfc_get_element_type (base_type);
if (expr->ts.type == BT_CLASS)
base_type = gfc_typenode_for_spec (&CLASS_DATA (expr)->ts);
loop.temp_ss = gfc_get_temp_ss (base_type, ((expr->ts.type == BT_CHARACTER)
? expr->ts.u.cl->backend_decl
: NULL),
@ -2645,64 +2913,6 @@ conv_arglist_function (gfc_se *se, gfc_expr *expr, const char *name)
}
/* Takes a derived type expression and returns the address of a temporary
class object of the 'declared' type. */
static void
gfc_conv_derived_to_class (gfc_se *parmse, gfc_expr *e,
gfc_typespec class_ts)
{
gfc_component *cmp;
gfc_symbol *vtab;
gfc_symbol *declared = class_ts.u.derived;
gfc_ss *ss;
tree ctree;
tree var;
tree tmp;
/* The derived type needs to be converted to a temporary
CLASS object. */
tmp = gfc_typenode_for_spec (&class_ts);
var = gfc_create_var (tmp, "class");
/* Set the vptr. */
cmp = gfc_find_component (declared, "_vptr", true, true);
ctree = fold_build3_loc (input_location, COMPONENT_REF,
TREE_TYPE (cmp->backend_decl),
var, cmp->backend_decl, NULL_TREE);
/* Remember the vtab corresponds to the derived type
not to the class declared type. */
vtab = gfc_find_derived_vtab (e->ts.u.derived);
gcc_assert (vtab);
tmp = gfc_build_addr_expr (NULL_TREE, gfc_get_symbol_decl (vtab));
gfc_add_modify (&parmse->pre, ctree,
fold_convert (TREE_TYPE (ctree), tmp));
/* Now set the data field. */
cmp = gfc_find_component (declared, "_data", true, true);
ctree = fold_build3_loc (input_location, COMPONENT_REF,
TREE_TYPE (cmp->backend_decl),
var, cmp->backend_decl, NULL_TREE);
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 (parmse, e);
gfc_add_modify (&parmse->pre, ctree, parmse->expr);
}
/* Pass the address of the class object. */
parmse->expr = gfc_build_addr_expr (NULL_TREE, var);
}
/* The following routine generates code for the intrinsic
procedures from the ISO_C_BINDING module:
* C_LOC (function)
@ -2954,6 +3164,19 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym,
fsym = formal ? formal->sym : NULL;
parm_kind = MISSING;
/* Class array expressions are sometimes coming completely unadorned
with either arrayspec or _data component. Correct that here.
OOP-TODO: Move this to the frontend. */
if (e && e->expr_type == EXPR_VARIABLE
&& !e->ref
&& e->ts.type == BT_CLASS
&& CLASS_DATA (e)->attr.dimension)
{
gfc_typespec temp_ts = e->ts;
gfc_add_class_array_ref (e);
e->ts = temp_ts;
}
if (e == NULL)
{
if (se->ignore_optional)
@ -3010,6 +3233,11 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym,
}
else
gfc_conv_expr_reference (&parmse, e);
/* The scalarizer does not repackage the reference to a class
array - instead it returns a pointer to the data element. */
if (fsym && fsym->ts.type == BT_CLASS && e->ts.type == BT_CLASS)
gfc_conv_class_to_class (&parmse, e, fsym->ts, true);
}
else
{
@ -3073,6 +3301,13 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym,
{
gfc_conv_expr_reference (&parmse, e);
/* A class array element needs converting back to be a
class object, if the formal argument is a class object. */
if (fsym && fsym->ts.type == BT_CLASS
&& e->ts.type == BT_CLASS
&& CLASS_DATA (e)->attr.dimension)
gfc_conv_class_to_class (&parmse, e, fsym->ts, false);
/* If an ALLOCATABLE dummy argument has INTENT(OUT) and is
allocated on entry, it must be deallocated. */
if (fsym && fsym->attr.allocatable
@ -3124,6 +3359,17 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym,
}
}
}
else if (e->ts.type == BT_CLASS
&& fsym && fsym->ts.type == BT_CLASS
&& CLASS_DATA (fsym)->attr.dimension)
{
/* Pass a class array. */
gfc_init_se (&parmse, se);
gfc_conv_expr_descriptor (&parmse, e, argss);
/* The conversion does not repackage the reference to a class
array - _data descriptor. */
gfc_conv_class_to_class (&parmse, e, fsym->ts, false);
}
else
{
/* If the procedure requires an explicit interface, the actual
@ -3188,6 +3434,18 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym,
gfc_conv_subref_array_arg (&parmse, e, f,
fsym ? fsym->attr.intent : INTENT_INOUT,
fsym && fsym->attr.pointer);
else if (gfc_is_class_array_ref (e, NULL)
&& fsym && fsym->ts.type == BT_DERIVED)
/* The actual argument is a component reference to an
array of derived types. In this case, the argument
is converted to a temporary, which is passed and then
written back after the procedure call.
OOP-TODO: Insert code so that if the dynamic type is
the same as the declared type, copy-in/copy-out does
not occur. */
gfc_conv_subref_array_arg (&parmse, e, f,
fsym ? fsym->attr.intent : INTENT_INOUT,
fsym && fsym->attr.pointer);
else
gfc_conv_array_parameter (&parmse, e, argss, f, fsym,
sym->name, NULL);
@ -4895,7 +5153,12 @@ gfc_conv_expr (gfc_se * se, gfc_expr * expr)
expr->ts.kind = expr->ts.u.derived->ts.kind;
}
}
/* TODO: make this work for general class array expressions. */
if (expr->ts.type == BT_CLASS
&& expr->ref && expr->ref->type == REF_ARRAY)
gfc_add_component_ref (expr, "_data");
switch (expr->expr_type)
{
case EXPR_OP:
@ -6469,6 +6732,36 @@ gfc_trans_assign (gfc_code * code)
}
static tree
gfc_trans_class_array_init_assign (gfc_expr *rhs, gfc_expr *lhs, gfc_expr *obj)
{
gfc_actual_arglist *actual;
gfc_expr *ppc;
gfc_code *ppc_code;
tree res;
actual = gfc_get_actual_arglist ();
actual->expr = gfc_copy_expr (rhs);
actual->next = gfc_get_actual_arglist ();
actual->next->expr = gfc_copy_expr (lhs);
ppc = gfc_copy_expr (obj);
gfc_add_vptr_component (ppc);
gfc_add_component_ref (ppc, "_copy");
ppc_code = gfc_get_code ();
ppc_code->resolved_sym = ppc->symtree->n.sym;
/* Although '_copy' is set to be elemental in class.c, it is
not staying that way. Find out why, sometime.... */
ppc_code->resolved_sym->attr.elemental = 1;
ppc_code->ext.actual = actual;
ppc_code->expr1 = ppc;
ppc_code->op = EXEC_CALL;
/* Since '_copy' is elemental, the scalarizer will take care
of arrays in gfc_trans_call. */
res = gfc_trans_call (ppc_code, false, NULL, NULL, false);
gfc_free_statements (ppc_code);
return res;
}
/* Special case for initializing a polymorphic dummy with INTENT(OUT).
A MEMCPY is needed to copy the full data from the default initializer
of the dynamic type. */
@ -6495,18 +6788,24 @@ gfc_trans_class_init_assign (gfc_code *code)
gfc_get_derived_type (rhs->ts.u.derived);
gfc_add_def_init_component (rhs);
sz = gfc_copy_expr (code->expr1);
gfc_add_vptr_component (sz);
gfc_add_size_component (sz);
if (code->expr1->ts.type == BT_CLASS
&& CLASS_DATA (code->expr1)->attr.dimension)
tmp = gfc_trans_class_array_init_assign (rhs, lhs, code->expr1);
else
{
sz = gfc_copy_expr (code->expr1);
gfc_add_vptr_component (sz);
gfc_add_size_component (sz);
gfc_init_se (&dst, NULL);
gfc_init_se (&src, NULL);
gfc_init_se (&memsz, NULL);
gfc_conv_expr (&dst, lhs);
gfc_conv_expr (&src, rhs);
gfc_conv_expr (&memsz, sz);
gfc_add_block_to_block (&block, &src.pre);
tmp = gfc_build_memcpy_call (dst.expr, src.expr, memsz.expr);
gfc_init_se (&dst, NULL);
gfc_init_se (&src, NULL);
gfc_init_se (&memsz, NULL);
gfc_conv_expr (&dst, lhs);
gfc_conv_expr (&src, rhs);
gfc_conv_expr (&memsz, sz);
gfc_add_block_to_block (&block, &src.pre);
tmp = gfc_build_memcpy_call (dst.expr, src.expr, memsz.expr);
}
gfc_add_expr_to_block (&block, tmp);
return gfc_finish_block (&block);
@ -6550,12 +6849,27 @@ gfc_trans_class_assign (gfc_expr *expr1, gfc_expr *expr2, gfc_exec_op op)
tmp = gfc_trans_pointer_assignment (lhs, rhs);
gfc_add_expr_to_block (&block, tmp);
gfc_free_expr (lhs);
gfc_free_expr (rhs);
}
else if (CLASS_DATA (expr2)->attr.dimension)
{
/* Insert an additional assignment which sets the '_vptr' field. */
lhs = gfc_copy_expr (expr1);
gfc_add_vptr_component (lhs);
rhs = gfc_copy_expr (expr2);
gfc_add_vptr_component (rhs);
tmp = gfc_trans_pointer_assignment (lhs, rhs);
gfc_add_expr_to_block (&block, tmp);
gfc_free_expr (lhs);
gfc_free_expr (rhs);
}
/* Do the actual CLASS assignment. */
if (expr2->ts.type == BT_CLASS)
if (expr2->ts.type == BT_CLASS && !CLASS_DATA (expr2)->attr.dimension)
op = EXEC_ASSIGN;
else
gfc_add_data_component (expr1);

20
gcc/fortran/trans-intrinsic.c
View File

@ -5028,6 +5028,9 @@ gfc_conv_intrinsic_size (gfc_se * se, gfc_expr * expr)
gfc_init_se (&argse, NULL);
actual = expr->value.function.actual;
if (actual->expr->ts.type == BT_CLASS)
gfc_add_class_array_ref (actual->expr);
ss = gfc_walk_expr (actual->expr);
gcc_assert (ss != gfc_ss_terminator);
argse.want_pointer = 1;
@ -5667,14 +5670,24 @@ gfc_conv_allocated (gfc_se *se, gfc_expr *expr)
gfc_init_se (&arg1se, NULL);
arg1 = expr->value.function.actual;
if (arg1->expr->ts.type == BT_CLASS)
{
/* Make sure that class array expressions have both a _data
component reference and an array reference.... */
if (CLASS_DATA (arg1->expr)->attr.dimension)
gfc_add_class_array_ref (arg1->expr);
/* .... whilst scalars only need the _data component. */
else
gfc_add_data_component (arg1->expr);
}
ss1 = gfc_walk_expr (arg1->expr);
if (ss1 == gfc_ss_terminator)
{
/* Allocatable scalar. */
arg1se.want_pointer = 1;
if (arg1->expr->ts.type == BT_CLASS)
gfc_add_data_component (arg1->expr);
gfc_conv_expr (&arg1se, arg1->expr);
tmp = arg1se.expr;
}
@ -6998,6 +7011,9 @@ gfc_add_intrinsic_ss_code (gfc_loopinfo * loop ATTRIBUTE_UNUSED, gfc_ss * ss)
static gfc_ss *
gfc_walk_intrinsic_bound (gfc_ss * ss, gfc_expr * expr)
{
if (expr->value.function.actual->expr->ts.type == BT_CLASS)
gfc_add_class_array_ref (expr->value.function.actual->expr);
/* The two argument version returns a scalar. */
if (expr->value.function.actual->next->expr)
return ss;

198
gcc/fortran/trans-stmt.c
View File

@ -1093,14 +1093,19 @@ trans_associate_var (gfc_symbol *sym, gfc_wrapped_block *block)
{
gfc_expr *e;
tree tmp;
bool class_target;
gcc_assert (sym->assoc);
e = sym->assoc->target;
class_target = (e->expr_type == EXPR_VARIABLE)
&& (gfc_is_class_scalar_expr (e)
|| gfc_is_class_array_ref (e, NULL));
/* Do a `pointer assignment' with updated descriptor (or assign descriptor
to array temporary) for arrays with either unknown shape or if associating
to a variable. */
if (sym->attr.dimension
if (sym->attr.dimension && !class_target
&& (sym->as->type == AS_DEFERRED || sym->assoc->variable))
{
gfc_se se;
@ -1140,6 +1145,23 @@ trans_associate_var (gfc_symbol *sym, gfc_wrapped_block *block)
gfc_finish_block (&se.post));
}
/* CLASS arrays just need the descriptor to be directly assigned. */
else if (class_target && sym->attr.dimension)
{
gfc_se se;
gfc_init_se (&se, NULL);
gfc_conv_expr (&se, e);
gcc_assert (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (se.expr)));
gcc_assert (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (sym->backend_decl)));
gfc_add_modify (&se.pre, sym->backend_decl, se.expr);
gfc_add_init_cleanup (block, gfc_finish_block( &se.pre),
gfc_finish_block (&se.post));
}
/* Do a scalar pointer assignment; this is for scalar variable targets. */
else if (gfc_is_associate_pointer (sym))
{
@ -4677,6 +4699,7 @@ tree
gfc_trans_allocate (gfc_code * code)
{
gfc_alloc *al;
gfc_expr *e;
gfc_expr *expr;
gfc_se se;
tree tmp;
@ -4748,7 +4771,7 @@ gfc_trans_allocate (gfc_code * code)
se.descriptor_only = 1;
gfc_conv_expr (&se, expr);
if (!gfc_array_allocate (&se, expr, stat, errmsg, errlen))
if (!gfc_array_allocate (&se, expr, stat, errmsg, errlen, code->expr3))
{
/* A scalar or derived type. */
@ -4878,6 +4901,16 @@ gfc_trans_allocate (gfc_code * code)
tmp = gfc_nullify_alloc_comp (expr->ts.u.derived, tmp, 0);
gfc_add_expr_to_block (&se.pre, tmp);
}
else if (al->expr->ts.type == BT_CLASS && code->expr3)
{
/* With class objects, it is best to play safe and null the
memory because we cannot know if dynamic types have allocatable
components or not. */
tmp = build_call_expr_loc (input_location,
builtin_decl_explicit (BUILT_IN_MEMSET),
3, se.expr, integer_zero_node, memsz);
gfc_add_expr_to_block (&se.pre, tmp);
}
}
gfc_add_block_to_block (&block, &se.pre);
@ -4901,6 +4934,60 @@ gfc_trans_allocate (gfc_code * code)
gfc_add_expr_to_block (&block, tmp);
}
/* We need the vptr of CLASS objects to be initialized. */
e = gfc_copy_expr (al->expr);
if (e->ts.type == BT_CLASS)
{
gfc_expr *lhs,*rhs;
gfc_se lse;
lhs = gfc_expr_to_initialize (e);
gfc_add_vptr_component (lhs);
rhs = NULL;
if (code->expr3 && code->expr3->ts.type == BT_CLASS)
{
/* Polymorphic SOURCE: VPTR must be determined at run time. */
rhs = gfc_copy_expr (code->expr3);
gfc_add_vptr_component (rhs);
tmp = gfc_trans_pointer_assignment (lhs, rhs);
gfc_add_expr_to_block (&block, tmp);
gfc_free_expr (rhs);
rhs = gfc_expr_to_initialize (e);
}
else
{
/* VPTR is fixed at compile time. */
gfc_symbol *vtab;
gfc_typespec *ts;
if (code->expr3)
ts = &code->expr3->ts;
else if (e->ts.type == BT_DERIVED)
ts = &e->ts;
else if (code->ext.alloc.ts.type == BT_DERIVED)
ts = &code->ext.alloc.ts;
else if (e->ts.type == BT_CLASS)
ts = &CLASS_DATA (e)->ts;
else
ts = &e->ts;
if (ts->type == BT_DERIVED)
{
vtab = gfc_find_derived_vtab (ts->u.derived);
gcc_assert (vtab);
gfc_init_se (&lse, NULL);
lse.want_pointer = 1;
gfc_conv_expr (&lse, lhs);
tmp = gfc_build_addr_expr (NULL_TREE,
gfc_get_symbol_decl (vtab));
gfc_add_modify (&block, lse.expr,
fold_convert (TREE_TYPE (lse.expr), tmp));
}
}
gfc_free_expr (lhs);
}
gfc_free_expr (e);
if (code->expr3 && !code->expr3->mold)
{
/* Initialization via SOURCE block
@ -4908,10 +4995,11 @@ gfc_trans_allocate (gfc_code * code)
gfc_expr *rhs = gfc_copy_expr (code->expr3);
if (al->expr->ts.type == BT_CLASS)
{
gfc_se call;
gfc_actual_arglist *actual;
gfc_expr *ppc;
gfc_init_se (&call, NULL);
gfc_code *ppc_code;
gfc_ref *dataref;
/* Do a polymorphic deep copy. */
actual = gfc_get_actual_arglist ();
actual->expr = gfc_copy_expr (rhs);
@ -4919,20 +5007,58 @@ gfc_trans_allocate (gfc_code * code)
gfc_add_data_component (actual->expr);
actual->next = gfc_get_actual_arglist ();
actual->next->expr = gfc_copy_expr (al->expr);
actual->next->expr->ts.type = BT_CLASS;
gfc_add_data_component (actual->next->expr);
dataref = actual->next->expr->ref;
if (dataref->u.c.component->as)
{
int dim;
gfc_expr *temp;
gfc_ref *ref = dataref->next;
ref->u.ar.type = AR_SECTION;
/* We have to set up the array reference to give ranges
in all dimensions and ensure that the end and stride
are set so that the copy can be scalarized. */
dim = 0;
for (; dim < dataref->u.c.component->as->rank; dim++)
{
ref->u.ar.dimen_type[dim] = DIMEN_RANGE;
if (ref->u.ar.end[dim] == NULL)
{
ref->u.ar.end[dim] = ref->u.ar.start[dim];
temp = gfc_get_int_expr (gfc_default_integer_kind,
&al->expr->where, 1);
ref->u.ar.start[dim] = temp;
}
temp = gfc_subtract (gfc_copy_expr (ref->u.ar.end[dim]),
gfc_copy_expr (ref->u.ar.start[dim]));
temp = gfc_add (gfc_get_int_expr (gfc_default_integer_kind,
&al->expr->where, 1),
temp);
}
}
if (rhs->ts.type == BT_CLASS)
{
ppc = gfc_copy_expr (rhs);
gfc_add_vptr_component (ppc);
}
else
ppc = gfc_lval_expr_from_sym (gfc_find_derived_vtab (rhs->ts.u.derived));
ppc = gfc_lval_expr_from_sym
(gfc_find_derived_vtab (rhs->ts.u.derived));
gfc_add_component_ref (ppc, "_copy");
gfc_conv_procedure_call (&call, ppc->symtree->n.sym, actual,
ppc, NULL);
gfc_add_expr_to_block (&call.pre, call.expr);
gfc_add_block_to_block (&call.pre, &call.post);
tmp = gfc_finish_block (&call.pre);
ppc_code = gfc_get_code ();
ppc_code->resolved_sym = ppc->symtree->n.sym;
/* Although '_copy' is set to be elemental in class.c, it is
not staying that way. Find out why, sometime.... */
ppc_code->resolved_sym->attr.elemental = 1;
ppc_code->ext.actual = actual;
ppc_code->expr1 = ppc;
ppc_code->op = EXEC_CALL;
/* Since '_copy' is elemental, the scalarizer will take care
of arrays in gfc_trans_call. */
tmp = gfc_trans_call (ppc_code, true, NULL, NULL, false);
gfc_free_statements (ppc_code);
}
else if (expr3 != NULL_TREE)
{
@ -4972,59 +5098,7 @@ gfc_trans_allocate (gfc_code * code)
gfc_free_expr (rhs);
}
/* Allocation of CLASS entities. */
gfc_free_expr (expr);
expr = al->expr;
if (expr->ts.type == BT_CLASS)
{
gfc_expr *lhs,*rhs;
gfc_se lse;
/* Initialize VPTR for CLASS objects. */
lhs = gfc_expr_to_initialize (expr);
gfc_add_vptr_component (lhs);
rhs = NULL;
if (code->expr3 && code->expr3->ts.type == BT_CLASS)
{
/* Polymorphic SOURCE: VPTR must be determined at run time. */
rhs = gfc_copy_expr (code->expr3);
gfc_add_vptr_component (rhs);
tmp = gfc_trans_pointer_assignment (lhs, rhs);
gfc_add_expr_to_block (&block, tmp);
gfc_free_expr (rhs);
}
else
{
/* VPTR is fixed at compile time. */
gfc_symbol *vtab;
gfc_typespec *ts;
if (code->expr3)
ts = &code->expr3->ts;
else if (expr->ts.type == BT_DERIVED)
ts = &expr->ts;
else if (code->ext.alloc.ts.type == BT_DERIVED)
ts = &code->ext.alloc.ts;
else if (expr->ts.type == BT_CLASS)
ts = &CLASS_DATA (expr)->ts;
else
ts = &expr->ts;
if (ts->type == BT_DERIVED)
{
vtab = gfc_find_derived_vtab (ts->u.derived);
gcc_assert (vtab);
gfc_init_se (&lse, NULL);
lse.want_pointer = 1;
gfc_conv_expr (&lse, lhs);
tmp = gfc_build_addr_expr (NULL_TREE,
gfc_get_symbol_decl (vtab));
gfc_add_modify (&block, lse.expr,
fold_convert (TREE_TYPE (lse.expr), tmp));
}
}
gfc_free_expr (lhs);
}
}
/* STAT (ERRMSG only makes sense with STAT). */

28
gcc/fortran/trans.c
View File

@ -315,6 +315,7 @@ gfc_build_array_ref (tree base, tree offset, tree decl)
{
tree type = TREE_TYPE (base);
tree tmp;
tree span;
if (GFC_ARRAY_TYPE_P (type) && GFC_TYPE_ARRAY_RANK (type) == 0)
{
@ -345,12 +346,33 @@ gfc_build_array_ref (tree base, tree offset, tree decl)
if (decl && (TREE_CODE (decl) == FIELD_DECL
|| TREE_CODE (decl) == VAR_DECL
|| TREE_CODE (decl) == PARM_DECL)
&& GFC_DECL_SUBREF_ARRAY_P (decl)
&& !integer_zerop (GFC_DECL_SPAN(decl)))
&& ((GFC_DECL_SUBREF_ARRAY_P (decl)
&& !integer_zerop (GFC_DECL_SPAN(decl)))
|| GFC_DECL_CLASS (decl)))
{
if (GFC_DECL_CLASS (decl))
{
/* Allow for dummy arguments and other good things. */
if (POINTER_TYPE_P (TREE_TYPE (decl)))
decl = build_fold_indirect_ref_loc (input_location, decl);
/* Check if '_data' is an array descriptor. If it is not,
the array must be one of the components of the class object,
so return a normal array reference. */
if (!GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (gfc_class_data_get (decl))))
return build4_loc (input_location, ARRAY_REF, type, base,
offset, NULL_TREE, NULL_TREE);
span = gfc_vtable_size_get (decl);
}
else if (GFC_DECL_SUBREF_ARRAY_P (decl))
span = GFC_DECL_SPAN(decl);
else
gcc_unreachable ();
offset = fold_build2_loc (input_location, MULT_EXPR,
gfc_array_index_type,
offset, GFC_DECL_SPAN(decl));
offset, span);
tmp = gfc_build_addr_expr (pvoid_type_node, base);
tmp = fold_build_pointer_plus_loc (input_location, tmp, offset);
tmp = fold_convert (build_pointer_type (type), tmp);

9
gcc/fortran/trans.h
View File

@ -333,6 +333,14 @@ typedef struct
}
gfc_wrapped_block;
/* Class API functions. */
tree gfc_class_data_get (tree);
tree gfc_class_vptr_get (tree);
tree gfc_vtable_hash_get (tree);
tree gfc_vtable_size_get (tree);
tree gfc_vtable_extends_get (tree);
tree gfc_vtable_def_init_get (tree);
tree gfc_vtable_copy_get (tree);
/* Initialize an init/cleanup block. */
void gfc_start_wrapped_block (gfc_wrapped_block* block, tree code);
@ -803,6 +811,7 @@ struct GTY((variable_size)) lang_decl {
#define GFC_DECL_RESULT(node) DECL_LANG_FLAG_5(node)
#define GFC_DECL_SUBREF_ARRAY_P(node) DECL_LANG_FLAG_6(node)
#define GFC_DECL_PUSH_TOPLEVEL(node) DECL_LANG_FLAG_7(node)
#define GFC_DECL_CLASS(node) DECL_LANG_FLAG_8(node)
/* An array descriptor. */
#define GFC_DESCRIPTOR_TYPE_P(node) TYPE_LANG_FLAG_1(node)

29
gcc/testsuite/ChangeLog
View File

@ -1,3 +1,32 @@
2011-12-11 Paul Thomas <pault@gcc.gnu.org>
Tobias Burnus <burnus@gcc.gnu.org>
PR fortran/41539
PR fortran/43214
PR fortran/43969
PR fortran/44568
PR fortran/46356
PR fortran/46990
PR fortran/49074
* gfortran.dg/class_array_1.f03: New.
* gfortran.dg/class_array_2.f03: New.
* gfortran.dg/class_array_3.f03: New.
* gfortran.dg/class_array_4.f03: New.
* gfortran.dg/class_array_5.f03: New.
* gfortran.dg/class_array_6.f03: New.
* gfortran.dg/class_array_7.f03: New.
* gfortran.dg/class_array_8.f03: New.
* gfortran.dg/coarray_poly_1.f90: New.
* gfortran.dg/coarray_poly_2.f90: New.
* gfortran.dg/coarray/poly_run_1.f90: New.
* gfortran.dg/coarray/poly_run_2.f90: New.
* gfortran.dg/class_to_type_1.f03: New.
* gfortran.dg/type_to_class_1.f03: New.
* gfortran.dg/typebound_assignment_3.f03: Remove the error.
* gfortran.dg/auto_dealloc_2.f90: Occurences of __builtin_free
now 2.
* gfortran.dg/class_19.f03: Occurences of __builtin_free now 8.
2011-12-11 Thomas Koenig <tkoenig@gcc.gnu.org>
PR fortran/50690

2
gcc/testsuite/gfortran.dg/auto_dealloc_2.f90
View File

@ -25,5 +25,5 @@ contains
end program
! { dg-final { scan-tree-dump-times "__builtin_free" 2 "original" } }
! { dg-final { scan-tree-dump-times "__builtin_free" 3 "original" } }
! { dg-final { cleanup-tree-dump "original" } }

2
gcc/testsuite/gfortran.dg/class_19.f03
View File

@ -39,7 +39,7 @@ program main
end program main
! { dg-final { scan-tree-dump-times "__builtin_free" 8 "original" } }
! { dg-final { scan-tree-dump-times "__builtin_free" 11 "original" } }
! { dg-final { cleanup-tree-dump "original" } }
! { dg-final { cleanup-modules "foo_mod" } }

76
gcc/testsuite/gfortran.dg/class_array_1.f03 Normal file
View File

@ -0,0 +1,76 @@
! { dg-do run }
!
! Test functionality of allocatable class arrays:
! ALLOCATE with source, ALLOCATED, DEALLOCATE, passing as arguments for
! ELEMENTAL and non-ELEMENTAL procedures, SELECT TYPE and LOWER/UPPER.
!
type :: type1
integer :: i
end type
type, extends(type1) :: type2
real :: r
end type
class(type1), allocatable, dimension (:) :: x
allocate(x(2), source = type2(42,42.0))
call display(x, [1], [2], t2 = [type2(42,42.0),type2(42,42.0)])
call display(x, [1], [2], t2 = [type2(111,99.0),type2(111,99.0)])
if (allocated (x)) deallocate (x)
allocate(x(1:4), source = [(type2(i,42.0 + float (i)), i = 1, 4)])
call display(x, [1], [4], t2 = [(type2(i,42.0 + float (i)), i = 1, 4)])
call display(x, [1], [4], t2 = [(type2(111,99.0), i = 1, 4)])
if (any (disp (x) .ne. [99.0,99.0,99.0,99.0])) call abort
if (allocated (x)) deallocate (x)
allocate(x(1:4), source = type1(42))
call display(x, [1], [4], t1 = [(type1(42), i = 1, 4)])
call display(x, [1], [4], t1 = [type1(42),type1(99),type1(42),type1(42)])
if (any (disp (x) .ne. [0.0,0.0,0.0,0.0])) call abort
contains
subroutine display(x, lower, upper, t1, t2)
class(type1), allocatable, dimension (:) :: x
integer, dimension (:) :: lower, upper
type(type1), optional, dimension(:) :: t1
type(type2), optional, dimension(:) :: t2
select type (x)
type is (type1)
if (present (t1)) then
if (any (x%i .ne. t1%i)) call abort
else
call abort
end if
x(2)%i = 99
type is (type2)
if (present (t2)) then
if (any (x%i .ne. t2%i)) call abort
if (any (x%r .ne. t2%r)) call abort
else
call abort
end if
x%i = 111
x%r = 99.0
end select
call bounds (x, lower, upper)
end subroutine
subroutine bounds (x, lower, upper)
class(type1), allocatable, dimension (:) :: x
integer, dimension (:) :: lower, upper
if (any (lower .ne. lbound (x))) call abort
if (any (upper .ne. ubound (x))) call abort
end subroutine
elemental function disp(y) result(ans)
class(type1), intent(in) :: y
real :: ans
select type (y)
type is (type1)
ans = 0.0
type is (type2)
ans = y%r
end select
end function
end

78
gcc/testsuite/gfortran.dg/class_array_2.f03 Normal file
View File

@ -0,0 +1,78 @@
! { dg-do run }
!
! Test functionality of pointer class arrays:
! ALLOCATE with source, ASSOCIATED, DEALLOCATE, passing as arguments for
! ELEMENTAL and non-ELEMENTAL procedures, SELECT TYPE and LOWER/UPPER.
!
type :: type1
integer :: i
end type
type, extends(type1) :: type2
real :: r
end type
class(type1), pointer, dimension (:) :: x
allocate(x(2), source = type2(42,42.0))
call display(x, [1], [2], t2 = [type2(42,42.0),type2(42,42.0)])
call display(x, [1], [2], t2 = [type2(111,99.0),type2(111,99.0)])
if (associated (x)) deallocate (x)
allocate(x(1:4), source = [(type2(i,42.0 + float (i)), i = 1, 4)])
call display(x, [1], [4], t2 = [(type2(i,42.0 + float (i)), i = 1, 4)])
call display(x, [1], [4], t2 = [(type2(111,99.0), i = 1, 4)])
if (any (disp (x) .ne. [99.0,99.0,99.0,99.0])) call abort
if (associated (x)) deallocate (x)
allocate(x(1:4), source = type1(42))
call display(x, [1], [4], t1 = [(type1(42), i = 1, 4)])
call display(x, [1], [4], t1 = [type1(42),type1(99),type1(42),type1(42)])
if (any (disp (x) .ne. [0.0,0.0,0.0,0.0])) call abort
if (associated (x)) deallocate (x)
contains
subroutine display(x, lower, upper, t1, t2)
class(type1), pointer, dimension (:) :: x
integer, dimension (:) :: lower, upper
type(type1), optional, dimension(:) :: t1
type(type2), optional, dimension(:) :: t2
select type (x)
type is (type1)
if (present (t1)) then
if (any (x%i .ne. t1%i)) call abort
else
call abort
end if
x(2)%i = 99
type is (type2)
if (present (t2)) then
if (any (x%i .ne. t2%i)) call abort
if (any (x%r .ne. t2%r)) call abort
else
call abort
end if
x%i = 111
x%r = 99.0
end select
call bounds (x, lower, upper)
end subroutine
subroutine bounds (x, lower, upper)
class(type1), pointer, dimension (:) :: x
integer, dimension (:) :: lower, upper
if (any (lower .ne. lbound (x))) call abort
if (any (upper .ne. ubound (x))) call abort
end subroutine
elemental function disp(y) result(ans)
class(type1), intent(in) :: y
real :: ans
select type (y)
type is (type1)
ans = 0.0
type is (type2)
ans = y%r
end select
end function
end

143
gcc/testsuite/gfortran.dg/class_array_3.f03 Normal file
View File

@ -0,0 +1,143 @@
! { dg-do run }
!
! class based quick sort program - starting point comment #0 of pr41539
!
! Note assignment with vector index reference fails because temporary
! allocation does not occur - also false dependency detected. Nullification
! of temp descriptor data causes a segfault.
!
module m_qsort
implicit none
type, abstract :: sort_t
contains
procedure(disp), deferred :: disp
procedure(lt_cmp), deferred :: lt_cmp
procedure(assign), deferred :: assign
generic :: operator(<) => lt_cmp
generic :: assignment(=) => assign
end type sort_t
interface
elemental integer function disp(a)
import
class(sort_t), intent(in) :: a
end function disp
end interface
interface
impure elemental logical function lt_cmp(a,b)
import
class(sort_t), intent(in) :: a, b
end function lt_cmp
end interface
interface
elemental subroutine assign(a,b)
import
class(sort_t), intent(out) :: a
class(sort_t), intent(in) :: b
end subroutine assign
end interface
contains
subroutine qsort(a)
class(sort_t), intent(inout),allocatable :: a(:)
class(sort_t), allocatable :: tmp (:)
integer, allocatable :: index_array (:)
integer :: i
allocate (tmp(size (a, 1)), source = a)
index_array = [(i, i = 1, size (a, 1))]
call internal_qsort (tmp, index_array) ! Do not move class elements around until end
do i = 1, size (a, 1) ! Since they can be of arbitrary size.
a(i) = tmp(index_array(i)) ! Vector index array would be neater
end do
! a = tmp(index_array) ! Like this - TODO: fixme
end subroutine qsort
recursive subroutine internal_qsort (x, iarray)
class(sort_t), intent(inout),allocatable :: x(:)
class(sort_t), allocatable :: ptr
integer, allocatable :: iarray(:), above(:), below(:), itmp(:)
integer :: pivot, nelem, i, iptr
if (.not.allocated (iarray)) return
nelem = size (iarray, 1)
if (nelem .le. 1) return
pivot = nelem / 2
allocate (ptr, source = x(iarray(pivot))) ! Pointer to the pivot element
do i = 1, nelem
iptr = iarray(i) ! Index for i'th element
if (ptr%lt_cmp (x(iptr))) then ! Compare pivot with i'th element
itmp = [iptr]
above = concat (itmp, above) ! Invert order to prevent infinite loops
else
itmp = [iptr]
below = concat (itmp, below) ! -ditto-
end if
end do
call internal_qsort (x, above) ! Recursive sort of 'above' and 'below'
call internal_qsort (x, below)
iarray = concat (below, above) ! Concatenate the result
end subroutine internal_qsort
function concat (ia, ib) result (ic)
integer, allocatable, dimension(:) :: ia, ib, ic
if (allocated (ia) .and. allocated (ib)) then
ic = [ia, ib]
else if (allocated (ia)) then
ic = ia
else if (allocated (ib)) then
ic = ib
end if
end function concat
end module m_qsort
module test
use m_qsort
implicit none
type, extends(sort_t) :: sort_int_t
integer :: i
contains
procedure :: disp => disp_int
procedure :: lt_cmp => lt_cmp_int
procedure :: assign => assign_int
end type
contains
elemental integer function disp_int(a)
class(sort_int_t), intent(in) :: a
disp_int = a%i
end function disp_int
elemental subroutine assign_int (a, b)
class(sort_int_t), intent(out) :: a
class(sort_t), intent(in) :: b ! TODO: gfortran does not throw 'class(sort_int_t)'
select type (b)
class is (sort_int_t)
a%i = b%i
class default
a%i = -1
end select
end subroutine assign_int
impure elemental logical function lt_cmp_int(a,b) result(cmp)
class(sort_int_t), intent(in) :: a
class(sort_t), intent(in) :: b
select type(b)
type is(sort_int_t)
if (a%i < b%i) then
cmp = .true.
else
cmp = .false.
end if
class default
ERROR STOP "Don't compare apples with oranges"
end select
end function lt_cmp_int
end module test
program main
use test
class(sort_t), allocatable :: A(:)
integer :: i, m(5)= [7 , 4, 5, 2, 3]
allocate (A(5), source = [(sort_int_t(m(i)), i=1,5)])
! print *, "Before qsort: ", (A(i)%disp(), i = 1, size(a,1))
call qsort(A)
! print *, "After qsort: ", (A(i)%disp(), i = 1, size(a,1))
if (any ([(A(i)%disp(), i = 1, size(a,1))] .ne. [2,3,4,5,7])) call abort
end program main
! { dg-final { cleanup-modules "m_qsort test" } }

26
gcc/testsuite/gfortran.dg/class_array_4.f03 Normal file
View File

@ -0,0 +1,26 @@
! { dg-do run }
! PR43214 - implementation of class arrays
!
! Contributed by Tobias Burnus <burnus@gcc.gnu.org>
!
module m
type t
real :: r = 99
contains
procedure, pass :: foo => foo
end type t
contains
elemental subroutine foo(x, i)
class(t),intent(in) :: x
integer,intent(inout) :: i
i = x%r + i
end subroutine foo
end module m
use m
type(t) :: x(3)
integer :: n(3) = [0,100,200]
call x(:)%foo(n)
if (any(n .ne. [99,199,299])) call abort
end
! { dg-final { cleanup-modules "m" } }

25
gcc/testsuite/gfortran.dg/class_array_5.f03 Normal file
View File

@ -0,0 +1,25 @@
! { dg-do compile }
! PR44568 - class array impelementation.
!
! Contributed by Hans-Werner Boschmann
!
module ice6
type::a_type
contains
procedure::do_something
end type a_type
contains
subroutine do_something(this)
class(a_type),intent(in)::this
end subroutine do_something
subroutine do_something_else()
class(a_type),dimension(:),allocatable::values
call values(1)%do_something()
end subroutine do_something_else
end module ice6
! { dg-final { cleanup-modules "ice6" } }

33
gcc/testsuite/gfortran.dg/class_array_6.f03 Normal file
View File

@ -0,0 +1,33 @@
! { dg-do compile }
! PR46356 - class arrays
!
! Contributed by Ian Harvey
!
MODULE procedure_intent_nonsense
IMPLICIT NONE
PRIVATE
TYPE, PUBLIC :: Parent
INTEGER :: comp
END TYPE Parent
TYPE :: ParentVector
INTEGER :: a
! CLASS(Parent), ALLOCATABLE :: a
END TYPE ParentVector
CONTAINS
SUBROUTINE vector_operation(pvec)
CLASS(ParentVector), INTENT(INOUT) :: pvec(:)
INTEGER :: i
!---
DO i = 1, SIZE(pvec)
CALL item_operation(pvec(i))
END DO
! PRINT *, pvec(1)%a%comp
END SUBROUTINE vector_operation
SUBROUTINE item_operation(pvec)
CLASS(ParentVector), INTENT(INOUT) :: pvec
!TYPE(ParentVector), INTENT(INOUT) :: pvec
END SUBROUTINE item_operation
END MODULE procedure_intent_nonsense
! { dg-final { cleanup-modules "procedure_intent_nonsense" } }

59
gcc/testsuite/gfortran.dg/class_array_7.f03 Normal file
View File

@ -0,0 +1,59 @@
! { dg-do run }
! PR46990 - class array implementation
!
! Contributed by Wolfgang Kilian on comp.lang.fortran - see comment #7 of PR
!
module realloc
implicit none
type :: base_type
integer :: i
contains
procedure :: assign
generic :: assignment(=) => assign ! define generic assignment
end type base_type
type, extends(base_type) :: extended_type
integer :: j
end type extended_type
contains
elemental subroutine assign (a, b)
class(base_type), intent(out) :: a
type(base_type), intent(in) :: b
a%i = b%i
end subroutine assign
subroutine reallocate (a)
class(base_type), dimension(:), allocatable, intent(inout) :: a
class(base_type), dimension(:), allocatable :: tmp
allocate (tmp (2 * size (a))) ! how to alloc b with same type as a ?
if (trim (print_type ("tmp", tmp)) .ne. "tmp is base_type") call abort
tmp(:size(a)) = a ! polymorphic l.h.s.
call move_alloc (from=tmp, to=a)
end subroutine reallocate
character(20) function print_type (name, a)
character(*), intent(in) :: name
class(base_type), dimension(:), intent(in) :: a
select type (a)
type is (base_type); print_type = NAME // " is base_type"
type is (extended_type); print_type = NAME // " is extended_type"
end select
end function
end module realloc
program main
use realloc
implicit none
class(base_type), dimension(:), allocatable :: a
allocate (extended_type :: a(10))
if (trim (print_type ("a", a)) .ne. "a is extended_type") call abort
call reallocate (a)
if (trim (print_type ("a", a)) .ne. "a is base_type") call abort
end program main
! { dg-final { cleanup-modules "realloc" } }

18
gcc/testsuite/gfortran.dg/class_array_8.f03 Normal file
View File

@ -0,0 +1,18 @@
! { dg-do run }
! PR43969 - class array implementation
!
! Contributed by Janus Weil <janus@gcc.gnu.org>
!
implicit none
type indx_map
end type
type desc_type
class(indx_map), allocatable :: indxmap(:)
end type
type(desc_type) :: desc
if (allocated(desc%indxmap)) call abort()
end

97
gcc/testsuite/gfortran.dg/class_to_type_1.f03 Normal file
View File

@ -0,0 +1,97 @@
! { dg-do run }
!
! Passing CLASS to TYPE
!
implicit none
type t
integer :: A
real, allocatable :: B(:)
end type t
type, extends(t) :: t2
complex :: z = cmplx(3.3, 4.4)
end type t2
integer :: i
class(t), allocatable :: x(:)
allocate(t2 :: x(10))
select type(x)
type is(t2)
if (size (x) /= 10) call abort ()
x = [(t2(a=-i, B=[1*i,2*i,3*i,4*i]), i = 1, 10)]
do i = 1, 10
if (x(i)%a /= -i .or. size (x(i)%b) /= 4 &
.or. any (x(i)%b /= [1*i,2*i,3*i,4*i])) then
call abort()
end if
if (x(i)%z /= cmplx(3.3, 4.4)) call abort()
end do
class default
call abort()
end select
call base(x)
call baseExplicit(x, size(x))
call class(x)
call classExplicit(x, size(x))
contains
subroutine base(y)
type(t) :: y(:)
if (size (y) /= 10) call abort ()
do i = 1, 10
if (y(i)%a /= -i .or. size (y(i)%b) /= 4 &
.or. any (y(i)%b /= [1*i,2*i,3*i,4*i])) then
call abort()
end if
end do
end subroutine base
subroutine baseExplicit(v, n)
integer, intent(in) :: n
type(t) :: v(n)
if (size (v) /= 10) call abort ()
do i = 1, 10
if (v(i)%a /= -i .or. size (v(i)%b) /= 4 &
.or. any (v(i)%b /= [1*i,2*i,3*i,4*i])) then
call abort()
end if
end do
end subroutine baseExplicit
subroutine class(z)
class(t), intent(in) :: z(:)
select type(z)
type is(t2)
if (size (z) /= 10) call abort ()
do i = 1, 10
if (z(i)%a /= -i .or. size (z(i)%b) /= 4 &
.or. any (z(i)%b /= [1*i,2*i,3*i,4*i])) then
call abort()
end if
if (z(i)%z /= cmplx(3.3, 4.4)) call abort()
end do
class default
call abort()
end select
call base(z)
call baseExplicit(z, size(z))
end subroutine class
subroutine classExplicit(u, n)
integer, intent(in) :: n
class(t), intent(in) :: u(n)
select type(u)
type is(t2)
if (size (u) /= 10) call abort ()
do i = 1, 10
if (u(i)%a /= -i .or. size (u(i)%b) /= 4 &
.or. any (u(i)%b /= [1*i,2*i,3*i,4*i])) then
call abort()
end if
if (u(i)%z /= cmplx(3.3, 4.4)) call abort()
end do
class default
call abort()
end select
call base(u)
call baseExplicit(u, n)
end subroutine classExplicit
end

43
gcc/testsuite/gfortran.dg/coarray/poly_run_1.f90 Normal file
View File

@ -0,0 +1,43 @@
! { dg-do run }
!
! Test for polymorphic coarrays
!
type t
end type t
class(t), allocatable :: A(:)[:,:]
allocate (A(2)[1:4,-5:*])
if (any (lcobound(A) /= [1, -5])) call abort ()
if (num_images() == 1) then
if (any (ucobound(A) /= [4, -5])) call abort ()
else
if (ucobound(A,dim=1) /= 4) call abort ()
end if
if (allocated(A)) i = 5
call s(A)
!call t(A) ! FIXME
contains
subroutine s(x)
class(t),allocatable :: x(:)[:,:]
if (any (lcobound(x) /= [1, -5])) call abort ()
if (num_images() == 1) then
if (any (ucobound(x) /= [4, -5])) call abort ()
! FIXME: Tree-walking issue?
! else
! if (ucobound(x,dim=1) /= 4) call abort ()
end if
end subroutine s
! FIXME
!subroutine st(x)
! class(t),allocatable :: x(:)[:,:]
! if (any (lcobound(x) /= [1, 2])) call abort ()
! if (num_images() == 1) then
! if (any (ucobound(x) /= [4, 2])) call abort ()
! else
! if (ucobound(x,dim=1) /= 4) call abort ()
! end if
!end subroutine st
end

40
gcc/testsuite/gfortran.dg/coarray/poly_run_2.f90 Normal file
View File

@ -0,0 +1,40 @@
! { dg-do run }
!
! Test for polymorphic coarrays
!
type t
end type t
class(t), allocatable :: A[:,:]
allocate (A[1:4,-5:*])
if (allocated(A)) stop
if (any (lcobound(A) /= [1, -5])) call abort ()
if (num_images() == 1) then
if (any (ucobound(A) /= [4, -5])) call abort ()
! FIXME: Tree walk issue
!else
! if (ucobound(A,dim=1) /= 4) call abort ()
end if
if (allocated(A)) i = 5
call s(A)
call st(A)
contains
subroutine s(x)
class(t) :: x[4,2:*]
if (any (lcobound(x) /= [1, 2])) call abort ()
if (num_images() == 1) then
if (any (ucobound(x) /= [4, 2])) call abort ()
else
if (ucobound(x,dim=1) /= 4) call abort ()
end if
end subroutine s
subroutine st(x)
class(t) :: x[:,:]
if (any (lcobound(x) /= [1, -5])) call abort ()
if (num_images() == 1) then
if (any (ucobound(x) /= [4, -5])) call abort ()
else
if (ucobound(x,dim=1) /= 4) call abort ()
end if
end subroutine st
end

13
gcc/testsuite/gfortran.dg/coarray_poly_1.f90 Normal file
View File

@ -0,0 +1,13 @@
! { dg-do compile }
! { dg-options "-fcoarray=single" }
!
! Test for polymorphic coarrays
!
subroutine s2()
type t
end type t
class(t) :: A(:)[4,2:*] ! { dg-error "is not ALLOCATABLE, SAVE nor a dummy argument" }
print *, ucobound(a)
allocate(a) ! { dg-error "must be ALLOCATABLE or a POINTER" }
end

13
gcc/testsuite/gfortran.dg/coarray_poly_2.f90 Normal file
View File

@ -0,0 +1,13 @@
! { dg-do compile }
! { dg-options "-fcoarray=single" }
!
type t
end type t
type(t) :: a[*]
call test(a) ! { dg-error "Rank mismatch in argument 'x' at .1. .rank-1 and scalar." }
contains
subroutine test(x)
class(t) :: x(:)[*]
print *, ucobound(x)
end
end

65
gcc/testsuite/gfortran.dg/type_to_class_1.f03 Normal file
View File

@ -0,0 +1,65 @@
! { dg-do run }
!
! Passing TYPE to CLASS
!
implicit none
type t
integer :: A
real, allocatable :: B(:)
end type t
type(t), allocatable :: x(:)
type(t) :: y(10)
integer :: i
allocate(x(10))
if (size (x) /= 10) call abort ()
x = [(t(a=-i, B=[1*i,2*i,3*i,4*i]), i = 1, 10)]
do i = 1, 10
if (x(i)%a /= -i .or. size (x(i)%b) /= 4 &
.or. any (x(i)%b /= [1*i,2*i,3*i,4*i])) then
call abort()
end if
end do
y = x ! TODO: Segfaults in runtime without 'y' being set
call class(x)
call classExplicit(x, size(x))
call class(y)
call classExplicit(y, size(y))
contains
subroutine class(z)
class(t), intent(in) :: z(:)
select type(z)
type is(t)
if (size (z) /= 10) call abort ()
do i = 1, 10
if (z(i)%a /= -i .or. size (z(i)%b) /= 4 &
.or. any (z(i)%b /= [1*i,2*i,3*i,4*i])) then
call abort()
end if
end do
class default
call abort()
end select
end subroutine class
subroutine classExplicit(u, n)
integer, intent(in) :: n
class(t), intent(in) :: u(n)
select type(u)
type is(t)
if (size (u) /= 10) call abort ()
do i = 1, 10
if (u(i)%a /= -i .or. size (u(i)%b) /= 4 &
.or. any (u(i)%b /= [1*i,2*i,3*i,4*i])) then
call abort()
end if
end do
class default
call abort()
end select
end subroutine classExplicit
end

2
gcc/testsuite/gfortran.dg/typebound_assignment_3.f03
View File

@ -24,7 +24,7 @@ end module
use foo
type (bar) :: foobar(2)
foobar = bar() ! { dg-error "currently not implemented" }
foobar = bar() ! There was a not-implemented error here
end
! { dg-final { cleanup-modules "foo" } }