+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
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");
int i;
gfc_try t;
+ if (array->ts.type == BT_CLASS)
+ return FAILURE;
+
switch (array->expr_type)
{
case EXPR_ARRAY:
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;
if (dim->expr_type != EXPR_CONSTANT)
return SUCCESS;
+
+ if (array->ts.type == BT_CLASS)
+ return SUCCESS;
corank = gfc_get_corank (array);
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;
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);
}
+/* 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. */
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;
/* 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)
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;
}
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)
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);
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;
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;
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)
{
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
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)
/* 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 *,
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;
}
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",
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)
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)))
gfc_formal_arglist *f;
int i, n, na;
unsigned long actual_size, formal_size;
+ bool full_array = false;
actual = *ap;
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
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
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)
{
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;
gfc_expr *expr1, *expr2 = NULL;
match m;
char name[GFC_MAX_SYMBOL_LEN];
+ bool class_array;
m = gfc_match_label ();
if (m == MATCH_ERROR)
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=>");
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);
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));
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. */
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:
}
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;
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;
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)
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. */
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
&& !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);
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;
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);
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 "
gfc_array_spec *as;
int d;
+ if (array->ts.type == BT_CLASS)
+ return NULL;
+
if (array->expr_type != EXPR_VARIABLE)
{
as = NULL;
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)
}
}
- 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)
/* 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)
{
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);
}
}
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;
}
+/* 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
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);
}
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;
}
/* 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);
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;
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)
{
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,
}
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);
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;
}
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)
{
/* 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 *,
&& 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)
&& !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)
{
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)
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
&& CLASS_DATA (sym)->attr.allocatable)))
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);
#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 *);
conv_parent_component_references (se, ref);
gfc_conv_component_ref (se, ref);
+
break;
case REF_SUBSTRING:
|| 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),
}
-/* 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)
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)
}
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
{
{
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
}
}
}
+ 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
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);
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:
}
+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. */
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);
-
- 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);
+ 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_add_expr_to_block (&block, tmp);
return gfc_finish_block (&block);
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);
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;
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;
}
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;
{
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;
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))
{
gfc_trans_allocate (gfc_code * code)
{
gfc_alloc *al;
+ gfc_expr *e;
gfc_expr *expr;
gfc_se se;
tree tmp;
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. */
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);
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
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);
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)
{
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). */
{
tree type = TREE_TYPE (base);
tree tmp;
+ tree span;
if (GFC_ARRAY_TYPE_P (type) && GFC_TYPE_ARRAY_RANK (type) == 0)
{
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);
}
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);
#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)
+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
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" } }
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" } }
--- /dev/null
+! { 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
+
--- /dev/null
+! { 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
+
--- /dev/null
+! { 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" } }
--- /dev/null
+! { 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" } }
--- /dev/null
+! { 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" } }
--- /dev/null
+! { 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" } }
--- /dev/null
+! { 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" } }
--- /dev/null
+! { 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
--- /dev/null
+! { 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
+
--- /dev/null
+! { 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
+
--- /dev/null
+! { 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
+
--- /dev/null
+! { 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
+
--- /dev/null
+! { 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
--- /dev/null
+! { 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
+
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" } }
OSDN Git Service
