diff options
| author | pault <pault@138bc75d-0d04-0410-961f-82ee72b054a4> | 2012-12-20 00:15:00 +0000 |
|---|---|---|
| committer | pault <pault@138bc75d-0d04-0410-961f-82ee72b054a4> | 2012-12-20 00:15:00 +0000 |
| commit | a90fe8299d2e635e53ab006c934154289d06ffa1 (patch) | |
| tree | 2e697d5cae930814fb839a61cea3e7b4e8d95338 | |
| parent | 873f242d97571e98acad8ea1912f81682bd7a448 (diff) | |
| download | ppe42-gcc-a90fe8299d2e635e53ab006c934154289d06ffa1.tar.gz ppe42-gcc-a90fe8299d2e635e53ab006c934154289d06ffa1.zip | |
2012-12-19 Paul Thomas <pault@gcc.gnu.org>
* array.c (resolve_array_list): Apply C4106.
* check.c (gfc_check_same_type_as): Exclude polymorphic
entities from check for extensible types. Improved error
for disallowed argument types to name the offending type.
* class.c : Update copyright date.
(gfc_class_null_initializer): Add argument for initialization
expression and deal with unlimited polymorphic typespecs.
(get_unique_type_string): Give unlimited polymorphic
entities a type string.
(gfc_intrinsic_hash_value): New function.
(gfc_build_class_symbol): Incorporate unlimited polymorphic
entities.
(gfc_find_derived_vtab): Deal with unlimited polymorphic
entities.
(gfc_find_intrinsic_vtab): New function.
* decl.c (gfc_match_decl_type_spec): Match typespec for
unlimited polymorphic type.
(gfc_match_data_decl): Skip to 'ok' if unlimited polymorphic.
expr.c (gfc_check_pointer_assign): Apply C717. If unlimited
polymorphic lvalue, find rvalue vtable for all typespecs,
except unlimited polymorphic expressions.
(gfc_check_vardef_context): Handle unlimited polymorphic
entities.
* gfortran.h : Add unlimited polymorphic attribute. Add
second arg to gfc_class_null_initializer primitive and
primitive for gfc_find_intrinsic_vtab. Add UNLIMITED_POLY
to detect unlimited polymorphic expressions.
* interface.c (gfc_compare_types): If expr1 is unlimited
polymorphic, always return 1. If expr2 is unlimited polymorphic
enforce C717.
(gfc_compare_interfaces): Skip past conditions that do not
apply for unlimited polymorphic entities.
(compare_parameter): Make sure that an unlimited polymorphic,
allocatable or pointer, formal argument is matched by an
unlimited polymorphic actual argument.
(compare_actual_formal): Ensure that an intrinsic vtable exists
to match an unlimited polymorphic formal argument.
* match.c (gfc_match_allocate): Type kind parameter does not
need to match an unlimited polymorphic allocate-object.
(alloc_opt_list): An unlimited polymorphic allocate-object
requires a typespec or a SOURCE tag.
(select_intrinsic_set_tmp): New function.
(select_type_set_tmp): Call new function. If it returns NULL,
build a derived type or class temporary instead.
(gfc_match_type_is): Remove restriction to derived types only.
Bind(C) or sequence derived types not permitted.
* misc (gfc_typename): Printed CLASS(*) for unlimited
polymorphism.
* module.c : Add AB_UNLIMITED_POLY to pass unlimited
polymorphic attribute to and from modules.
* resolve.c (resolve_common_vars): Unlimited polymorphic
entities cannot appear in common blocks.
(resolve_deallocate_expr): Deallocate unlimited polymorphic
enities.
(resolve_allocate_expr): Likewise for allocation. Make sure
vtable exists.
(gfc_type_is_extensible): Unlimited polymorphic entities are
not extensible.
(resolve_select_type): Handle unlimited polymorphic selectors.
Ensure that length type parameters are assumed and that names
for intrinsic types are generated.
(resolve_fl_var_and_proc): Exclude select type temporaries
from test of extensibility of type.
(resolve_fl_variable): Likewise for test that assumed character
length must be a dummy or a parameter.
(resolve_fl_derived0): Return SUCCESS unconditionally for
unlimited polymorphic entities. Also, allow unlimited
polymorphic components.
(resolve_fl_derived): Return SUCCESS unconditionally for
unlimited polymorphic entities.
(resolve_symbol): Return early with unlimited polymorphic
entities.
* simplifiy.c : Update copyright year.
(gfc_simplify_extends_type_of): No simplification possible
for unlimited polymorphic arguments.
* symbol.c (gfc_use_derived): Nothing to do for unlimited
polymorphic "derived type".
(gfc_type_compatible): Return unity if ts1 is unlimited
polymorphic.
* trans-decl.c (create_function_arglist) Formal arguments
without a character length should be treated in the same way
as passed lengths.
(gfc_trans_deferred_vars): Nullify the vptr of unlimited
polymorphic pointers. Avoid unlimited polymorphic entities
triggering gcc_unreachable.
* trans-expr.c (gfc_conv_intrinsic_to_class): New function.
(gfc_trans_class_init_assign): Make indirect reference of
src.expr.
(gfc_trans_class_assign): Expression NULL of unknown type
should set NULL vptr on lhs. Treat C717 cases where lhs is
a derived type and the rhs is unlimited polymorphic.
(gfc_conv_procedure_call): Handle the conversion of a non-class
actual argument to match an unlimited polymorphic formal
argument. Suppress the passing of a character string length
in this case. Make sure that calls to the character __copy
function have two character string length arguments.
(gfc_conv_initializer): Pass the initialization expression to
gfc_class_null_initializer.
(gfc_trans_subcomponent_assign): Ditto.
(gfc_conv_structure): Move handling of _size component.
trans-intrinsic.c: (gfc_conv_same_type_as): Handle conditions
where unlimited polymorphic arguments have null vptr.
* trans-stmt.c (trans_associate_var): Correctly treat array
temporaries associated with unlimited polymorphic selectors.
Recover the overwritten dtype for the descriptor. Use the _size
field of the vptr for character string lengths.
(gfc_trans_allocate): Cope with unlimited polymorphic allocate
objects; especially with character source tags.
(reset_vptr): New function.
(gfc_trans_deallocate): Call it.
* trans-types.c (gfc_get_derived_type): Detect unlimited
polymorphic types and deal with cases where the derived type of
components is null.
* trans.c : Update copyright year.
(trans_code): Call gfc_trans_class_assign for C717 cases where
the lhs is not unlimited polymorphic.
2012-12-19 Paul Thomas <pault@gcc.gnu.org>
* intrinsics/extends_type_of.c : Return correct results for
null vptrs.
2012-12-19 Paul Thomas <pault@gcc.gnu.org>
* gfortran.dg/unlimited_polymorphic_1.f03: New test.
* gfortran.dg/unlimited_polymorphic_2.f03: New test.
* gfortran.dg/unlimited_polymorphic_3.f03: New test.
* gfortran.dg/same_type_as.f03: Correct for improved message.
git-svn-id: svn+ssh://gcc.gnu.org/svn/gcc/trunk@194622 138bc75d-0d04-0410-961f-82ee72b054a4
26 files changed, 1665 insertions, 394 deletions
diff --git a/gcc/fortran/ChangeLog b/gcc/fortran/ChangeLog index 6a24ef7214c..ab271a4272a 100644 --- a/gcc/fortran/ChangeLog +++ b/gcc/fortran/ChangeLog @@ -1,3 +1,122 @@ +2012-12-19 Paul Thomas <pault@gcc.gnu.org> + + * array.c (resolve_array_list): Apply C4106. + * check.c (gfc_check_same_type_as): Exclude polymorphic + entities from check for extensible types. Improved error + for disallowed argument types to name the offending type. + * class.c : Update copyright date. + (gfc_class_null_initializer): Add argument for initialization + expression and deal with unlimited polymorphic typespecs. + (get_unique_type_string): Give unlimited polymorphic + entities a type string. + (gfc_intrinsic_hash_value): New function. + (gfc_build_class_symbol): Incorporate unlimited polymorphic + entities. + (gfc_find_derived_vtab): Deal with unlimited polymorphic + entities. + (gfc_find_intrinsic_vtab): New function. + * decl.c (gfc_match_decl_type_spec): Match typespec for + unlimited polymorphic type. + (gfc_match_data_decl): Skip to 'ok' if unlimited polymorphic. + expr.c (gfc_check_pointer_assign): Apply C717. If unlimited + polymorphic lvalue, find rvalue vtable for all typespecs, + except unlimited polymorphic expressions. + (gfc_check_vardef_context): Handle unlimited polymorphic + entities. + * gfortran.h : Add unlimited polymorphic attribute. Add + second arg to gfc_class_null_initializer primitive and + primitive for gfc_find_intrinsic_vtab. Add UNLIMITED_POLY + to detect unlimited polymorphic expressions. + * interface.c (gfc_compare_types): If expr1 is unlimited + polymorphic, always return 1. If expr2 is unlimited polymorphic + enforce C717. + (gfc_compare_interfaces): Skip past conditions that do not + apply for unlimited polymorphic entities. + (compare_parameter): Make sure that an unlimited polymorphic, + allocatable or pointer, formal argument is matched by an + unlimited polymorphic actual argument. + (compare_actual_formal): Ensure that an intrinsic vtable exists + to match an unlimited polymorphic formal argument. + * match.c (gfc_match_allocate): Type kind parameter does not + need to match an unlimited polymorphic allocate-object. + (alloc_opt_list): An unlimited polymorphic allocate-object + requires a typespec or a SOURCE tag. + (select_intrinsic_set_tmp): New function. + (select_type_set_tmp): Call new function. If it returns NULL, + build a derived type or class temporary instead. + (gfc_match_type_is): Remove restriction to derived types only. + Bind(C) or sequence derived types not permitted. + * misc (gfc_typename): Printed CLASS(*) for unlimited + polymorphism. + * module.c : Add AB_UNLIMITED_POLY to pass unlimited + polymorphic attribute to and from modules. + * resolve.c (resolve_common_vars): Unlimited polymorphic + entities cannot appear in common blocks. + (resolve_deallocate_expr): Deallocate unlimited polymorphic + enities. + (resolve_allocate_expr): Likewise for allocation. Make sure + vtable exists. + (gfc_type_is_extensible): Unlimited polymorphic entities are + not extensible. + (resolve_select_type): Handle unlimited polymorphic selectors. + Ensure that length type parameters are assumed and that names + for intrinsic types are generated. + (resolve_fl_var_and_proc): Exclude select type temporaries + from test of extensibility of type. + (resolve_fl_variable): Likewise for test that assumed character + length must be a dummy or a parameter. + (resolve_fl_derived0): Return SUCCESS unconditionally for + unlimited polymorphic entities. Also, allow unlimited + polymorphic components. + (resolve_fl_derived): Return SUCCESS unconditionally for + unlimited polymorphic entities. + (resolve_symbol): Return early with unlimited polymorphic + entities. + * simplifiy.c : Update copyright year. + (gfc_simplify_extends_type_of): No simplification possible + for unlimited polymorphic arguments. + * symbol.c (gfc_use_derived): Nothing to do for unlimited + polymorphic "derived type". + (gfc_type_compatible): Return unity if ts1 is unlimited + polymorphic. + * trans-decl.c (create_function_arglist) Formal arguments + without a character length should be treated in the same way + as passed lengths. + (gfc_trans_deferred_vars): Nullify the vptr of unlimited + polymorphic pointers. Avoid unlimited polymorphic entities + triggering gcc_unreachable. + * trans-expr.c (gfc_conv_intrinsic_to_class): New function. + (gfc_trans_class_init_assign): Make indirect reference of + src.expr. + (gfc_trans_class_assign): Expression NULL of unknown type + should set NULL vptr on lhs. Treat C717 cases where lhs is + a derived type and the rhs is unlimited polymorphic. + (gfc_conv_procedure_call): Handle the conversion of a non-class + actual argument to match an unlimited polymorphic formal + argument. Suppress the passing of a character string length + in this case. Make sure that calls to the character __copy + function have two character string length arguments. + (gfc_conv_initializer): Pass the initialization expression to + gfc_class_null_initializer. + (gfc_trans_subcomponent_assign): Ditto. + (gfc_conv_structure): Move handling of _size component. + trans-intrinsic.c: (gfc_conv_same_type_as): Handle conditions + where unlimited polymorphic arguments have null vptr. + * trans-stmt.c (trans_associate_var): Correctly treat array + temporaries associated with unlimited polymorphic selectors. + Recover the overwritten dtype for the descriptor. Use the _size + field of the vptr for character string lengths. + (gfc_trans_allocate): Cope with unlimited polymorphic allocate + objects; especially with character source tags. + (reset_vptr): New function. + (gfc_trans_deallocate): Call it. + * trans-types.c (gfc_get_derived_type): Detect unlimited + polymorphic types and deal with cases where the derived type of + components is null. + * trans.c : Update copyright year. + (trans_code): Call gfc_trans_class_assign for C717 cases where + the lhs is not unlimited polymorphic. + 2012-12-19 Tobias Burnus <burnus@net-b.de> PR fortran/55733 @@ -51,7 +170,7 @@ PR fortran/55593 * frontend-passes.c (doloop_code): Use resolved_sym instead of n.sym->formal for formal argument list - to get the correct version for all generic subroutines. + to get the correct version for all generic subroutines. 2012-12-05 Tobias Burnus <burnus@net-b.de> diff --git a/gcc/fortran/array.c b/gcc/fortran/array.c index 349151755c0..bc20bb9871d 100644 --- a/gcc/fortran/array.c +++ b/gcc/fortran/array.c @@ -557,7 +557,7 @@ gfc_match_array_spec (gfc_array_spec **asp, bool match_dim, bool match_codim) goto cleanup; case AS_ASSUMED_RANK: - gcc_unreachable (); + gcc_unreachable (); } if (gfc_match_char (')') == MATCH_YES) @@ -666,7 +666,7 @@ coarray: goto cleanup; case AS_ASSUMED_RANK: - gcc_unreachable (); + gcc_unreachable (); } if (gfc_match_char (']') == MATCH_YES) @@ -1414,7 +1414,7 @@ extract_element (gfc_expr *e) gfc_free_expr (e); current_expand.extract_count++; - + return SUCCESS; } @@ -1815,7 +1815,7 @@ resolve_array_list (gfc_constructor_base base) { gfc_symbol *iter_var; locus iter_var_loc; - + if (gfc_resolve_iterator (iter, false, true) == FAILURE) t = FAILURE; @@ -1847,6 +1847,13 @@ resolve_array_list (gfc_constructor_base base) if (gfc_resolve_expr (c->expr) == FAILURE) t = FAILURE; + + if (UNLIMITED_POLY (c->expr)) + { + gfc_error ("Array constructor value at %L shall not be unlimited " + "polymorphic [F2008: C4106]", &c->expr->where); + t = FAILURE; + } } return t; @@ -1941,7 +1948,7 @@ got_charlen: expr->ts.u.cl->length = gfc_get_int_expr (gfc_default_integer_kind, NULL, found_length); } - else + else { /* We've got a character length specified. It should be an integer, otherwise an error is signalled elsewhere. */ diff --git a/gcc/fortran/check.c b/gcc/fortran/check.c index a4902385070..793ad75d701 100644 --- a/gcc/fortran/check.c +++ b/gcc/fortran/check.c @@ -225,7 +225,7 @@ coarray_check (gfc_expr *e, int n) } return SUCCESS; -} +} /* Make sure the expression is a logical array. */ @@ -304,7 +304,7 @@ less_than_bitsize1 (const char *arg1, gfc_expr *expr1, const char *arg2, { gfc_extract_int (expr2, &i2); i3 = gfc_validate_kind (BT_INTEGER, expr1->ts.kind, false); - + /* For ISHFT[C], check that |shift| <= bit_size(i). */ if (arg2 == NULL) { @@ -355,7 +355,7 @@ less_than_bitsizekind (const char *arg, gfc_expr *expr, int k) if (expr->expr_type != EXPR_CONSTANT) return SUCCESS; - + i = gfc_validate_kind (BT_INTEGER, k, false); gfc_extract_int (expr, &val); @@ -510,7 +510,7 @@ variable_check (gfc_expr *e, int n, bool allow_proc) || (ref->u.c.component->ts.type != BT_CLASS && ref->u.c.component->attr.pointer))) break; - } + } if (!ref) { @@ -575,7 +575,7 @@ dim_corank_check (gfc_expr *dim, gfc_expr *array) if (dim->expr_type != EXPR_CONSTANT) return SUCCESS; - + if (array->ts.type == BT_CLASS) return SUCCESS; @@ -668,7 +668,7 @@ identical_dimen_shape (gfc_expr *a, int ai, gfc_expr *b, int bi) { if (mpz_cmp (a_size, b_size) != 0) ret = 0; - + mpz_clear (b_size); } mpz_clear (a_size); @@ -841,7 +841,7 @@ gfc_check_allocated (gfc_expr *array) return FAILURE; if (allocatable_check (array, 0) == FAILURE) return FAILURE; - + return SUCCESS; } @@ -1881,7 +1881,7 @@ gfc_check_ichar_iachar (gfc_expr *c, gfc_expr *kind) return SUCCESS; i = mpz_get_si (c->ts.u.cl->length->value.integer); } - else + else return SUCCESS; } else @@ -1903,7 +1903,7 @@ gfc_check_ichar_iachar (gfc_expr *c, gfc_expr *kind) if (i != 1) { - gfc_error ("Argument of %s at %L must be of length one", + gfc_error ("Argument of %s at %L must be of length one", gfc_current_intrinsic, &c->where); return FAILURE; } @@ -2037,7 +2037,7 @@ gfc_check_ishftc (gfc_expr *i, gfc_expr *shift, gfc_expr *size) || type_check (shift, 1, BT_INTEGER) == FAILURE) return FAILURE; - if (size != NULL) + if (size != NULL) { int i2, i3; @@ -3081,7 +3081,7 @@ gfc_check_rank (gfc_expr *a ATTRIBUTE_UNUSED) bool is_variable = true; /* Functions returning pointers are regarded as variable, cf. F2008, R602. */ - if (a->expr_type == EXPR_FUNCTION) + if (a->expr_type == EXPR_FUNCTION) is_variable = a->value.function.esym ? a->value.function.esym->result->attr.pointer : a->symtree->n.sym->result->attr.pointer; @@ -3269,7 +3269,7 @@ gfc_check_reshape (gfc_expr *source, gfc_expr *shape, if (order_size != shape_size) { gfc_error ("'%s' argument of '%s' intrinsic at %L " - "has wrong number of elements (%d/%d)", + "has wrong number of elements (%d/%d)", gfc_current_intrinsic_arg[3]->name, gfc_current_intrinsic, &order->where, order_size, shape_size); @@ -3287,7 +3287,7 @@ gfc_check_reshape (gfc_expr *source, gfc_expr *shape, if (dim < 1 || dim > order_size) { gfc_error ("'%s' argument of '%s' intrinsic at %L " - "has out-of-range dimension (%d)", + "has out-of-range dimension (%d)", gfc_current_intrinsic_arg[3]->name, gfc_current_intrinsic, &e->where, dim); return FAILURE; @@ -3319,7 +3319,7 @@ gfc_check_reshape (gfc_expr *source, gfc_expr *shape, gfc_constructor *c; bool test; - + mpz_init_set_ui (size, 1); for (c = gfc_constructor_first (shape->value.constructor); c; c = gfc_constructor_next (c)) @@ -3346,17 +3346,17 @@ gfc_check_reshape (gfc_expr *source, gfc_expr *shape, gfc_try gfc_check_same_type_as (gfc_expr *a, gfc_expr *b) { - if (a->ts.type != BT_DERIVED && a->ts.type != BT_CLASS) { - gfc_error ("'%s' argument of '%s' intrinsic at %L " - "must be of a derived type", - gfc_current_intrinsic_arg[0]->name, gfc_current_intrinsic, - &a->where); - return FAILURE; + gfc_error ("'%s' argument of '%s' intrinsic at %L " + "cannot be of type %s", + gfc_current_intrinsic_arg[0]->name, + gfc_current_intrinsic, + &a->where, gfc_typename (&a->ts)); + return FAILURE; } - if (!gfc_type_is_extensible (a->ts.u.derived)) + if (!(gfc_type_is_extensible (a->ts.u.derived) || UNLIMITED_POLY (a))) { gfc_error ("'%s' argument of '%s' intrinsic at %L " "must be of an extensible type", @@ -3367,14 +3367,15 @@ gfc_check_same_type_as (gfc_expr *a, gfc_expr *b) if (b->ts.type != BT_DERIVED && b->ts.type != BT_CLASS) { - gfc_error ("'%s' argument of '%s' intrinsic at %L " - "must be of a derived type", - gfc_current_intrinsic_arg[1]->name, gfc_current_intrinsic, - &b->where); + gfc_error ("'%s' argument of '%s' intrinsic at %L " + "cannot be of type %s", + gfc_current_intrinsic_arg[0]->name, + gfc_current_intrinsic, + &b->where, gfc_typename (&b->ts)); return FAILURE; } - if (!gfc_type_is_extensible (b->ts.u.derived)) + if (!(gfc_type_is_extensible (b->ts.u.derived) || UNLIMITED_POLY (b))) { gfc_error ("'%s' argument of '%s' intrinsic at %L " "must be of an extensible type", @@ -3688,7 +3689,7 @@ gfc_check_spread (gfc_expr *source, gfc_expr *dim, gfc_expr *ncopies) return FAILURE; /* dim_rank_check() does not apply here. */ - if (dim + if (dim && dim->expr_type == EXPR_CONSTANT && (mpz_cmp_ui (dim->value.integer, 1) < 0 || mpz_cmp_ui (dim->value.integer, source->rank + 1) > 0)) @@ -4233,7 +4234,7 @@ gfc_check_unpack (gfc_expr *vector, gfc_expr *mask, gfc_expr *field) if (mask->rank != field->rank && field->rank != 0) { gfc_error ("'%s' argument of '%s' intrinsic at %L must have " - "the same rank as '%s' or be a scalar", + "the same rank as '%s' or be a scalar", gfc_current_intrinsic_arg[2]->name, gfc_current_intrinsic, &field->where, gfc_current_intrinsic_arg[1]->name); return FAILURE; @@ -4246,7 +4247,7 @@ gfc_check_unpack (gfc_expr *vector, gfc_expr *mask, gfc_expr *field) if (! identical_dimen_shape (mask, i, field, i)) { gfc_error ("'%s' and '%s' arguments of '%s' intrinsic at %L " - "must have identical shape.", + "must have identical shape.", gfc_current_intrinsic_arg[2]->name, gfc_current_intrinsic_arg[1]->name, gfc_current_intrinsic, &field->where); diff --git a/gcc/fortran/class.c b/gcc/fortran/class.c index 8a8a54aa9ba..61d65e7a30b 100644 --- a/gcc/fortran/class.c +++ b/gcc/fortran/class.c @@ -1,5 +1,5 @@ /* Implementation of Fortran 2003 Polymorphism. - Copyright (C) 2009, 2010 + Copyright (C) 2009, 2010, 2011, 2012 Free Software Foundation, Inc. Contributed by Paul Richard Thomas <pault@gcc.gnu.org> and Janus Weil <janus@gcc.gnu.org> @@ -55,7 +55,6 @@ along with GCC; see the file COPYING3. If not see #include "gfortran.h" #include "constructor.h" - /* Inserts a derived type component reference in a data reference chain. TS: base type of the ref chain so far, in which we will pick the component REF: the address of the GFC_REF pointer to update @@ -237,7 +236,7 @@ gfc_add_class_array_ref (gfc_expr *e) ref = ref->next; ref->type = REF_ARRAY; ref->u.ar.type = AR_FULL; - ref->u.ar.as = as; + ref->u.ar.as = as; } } @@ -389,7 +388,7 @@ gfc_is_class_container_ref (gfc_expr *e) if (ref->type != REF_COMPONENT) result = false; else if (ref->u.c.component->ts.type == BT_CLASS) - result = true; + result = true; else result = false; } @@ -403,20 +402,31 @@ gfc_is_class_container_ref (gfc_expr *e) the _vptr component to the declared type. */ gfc_expr * -gfc_class_null_initializer (gfc_typespec *ts) +gfc_class_null_initializer (gfc_typespec *ts, gfc_expr *init_expr) { gfc_expr *init; gfc_component *comp; - + gfc_symbol *vtab = NULL; + bool is_unlimited_polymorphic; + + is_unlimited_polymorphic = ts->u.derived + && ts->u.derived->components->ts.u.derived + && ts->u.derived->components->ts.u.derived->attr.unlimited_polymorphic; + + if (is_unlimited_polymorphic && init_expr) + vtab = gfc_find_intrinsic_vtab (&(init_expr->ts)); + else + vtab = gfc_find_derived_vtab (ts->u.derived); + init = gfc_get_structure_constructor_expr (ts->type, ts->kind, &ts->u.derived->declared_at); init->ts = *ts; - + for (comp = ts->u.derived->components; comp; comp = comp->next) { gfc_constructor *ctor = gfc_constructor_get(); - if (strcmp (comp->name, "_vptr") == 0) - ctor->expr = gfc_lval_expr_from_sym (gfc_find_derived_vtab (ts->u.derived)); + if (strcmp (comp->name, "_vptr") == 0 && vtab) + ctor->expr = gfc_lval_expr_from_sym (vtab); else ctor->expr = gfc_get_null_expr (NULL); gfc_constructor_append (&init->value.constructor, ctor); @@ -434,9 +444,14 @@ static void get_unique_type_string (char *string, gfc_symbol *derived) { char dt_name[GFC_MAX_SYMBOL_LEN+1]; + if (derived->attr.unlimited_polymorphic) + sprintf (dt_name, "%s", "$tar"); + else sprintf (dt_name, "%s", derived->name); dt_name[0] = TOUPPER (dt_name[0]); - if (derived->module) + if (derived->attr.unlimited_polymorphic) + sprintf (string, "_%s", dt_name); + else if (derived->module) sprintf (string, "%s_%s", derived->module, dt_name); else if (derived->ns->proc_name) sprintf (string, "%s_%s", derived->ns->proc_name->name, dt_name); @@ -475,10 +490,30 @@ gfc_hash_value (gfc_symbol *sym) unsigned int hash = 0; char c[2*(GFC_MAX_SYMBOL_LEN+1)]; int i, len; - + get_unique_type_string (&c[0], sym); len = strlen (c); - + + for (i = 0; i < len; i++) + hash = (hash << 6) + (hash << 16) - hash + c[i]; + + /* Return the hash but take the modulus for the sake of module read, + even though this slightly increases the chance of collision. */ + return (hash % 100000000); +} + + +/* Assign a hash value for an intrinsic type. The algorithm is that of SDBM. */ + +unsigned int +gfc_intrinsic_hash_value (gfc_typespec *ts) +{ + unsigned int hash = 0; + const char *c = gfc_typename (ts); + int i, len; + + len = strlen (c); + for (i = 0; i < len; i++) hash = (hash << 6) + (hash << 16) - hash + c[i]; @@ -501,6 +536,7 @@ gfc_build_class_symbol (gfc_typespec *ts, symbol_attribute *attr, gfc_symbol *fclass; gfc_symbol *vtab; gfc_component *c; + gfc_namespace *ns; int rank; gcc_assert (as); @@ -518,7 +554,7 @@ gfc_build_class_symbol (gfc_typespec *ts, symbol_attribute *attr, attr->class_ok = attr->dummy || attr->pointer || attr->allocatable || attr->select_type_temporary; - + if (!attr->class_ok) /* We can not build the class container yet. */ return SUCCESS; @@ -539,17 +575,28 @@ gfc_build_class_symbol (gfc_typespec *ts, symbol_attribute *attr, else sprintf (name, "__class_%s", tname); - gfc_find_symbol (name, ts->u.derived->ns, 0, &fclass); + if (ts->u.derived->attr.unlimited_polymorphic) + { + /* Find the top-level namespace. */ + for (ns = gfc_current_ns; ns; ns = ns->parent) + if (!ns->parent) + break; + } + else + ns = ts->u.derived->ns; + + gfc_find_symbol (name, ns, 0, &fclass); if (fclass == NULL) { gfc_symtree *st; /* If not there, create a new symbol. */ - fclass = gfc_new_symbol (name, ts->u.derived->ns); - st = gfc_new_symtree (&ts->u.derived->ns->sym_root, name); + fclass = gfc_new_symbol (name, ns); + st = gfc_new_symtree (&ns->sym_root, name); st->n.sym = fclass; gfc_set_sym_referenced (fclass); fclass->refs++; fclass->ts.type = BT_UNKNOWN; + if (!ts->u.derived->attr.unlimited_polymorphic) fclass->attr.abstract = ts->u.derived->attr.abstract; fclass->f2k_derived = gfc_get_namespace (NULL, 0); if (gfc_add_flavor (&fclass->attr, FL_DERIVED, @@ -569,7 +616,7 @@ gfc_build_class_symbol (gfc_typespec *ts, symbol_attribute *attr, c->attr.allocatable = attr->allocatable; c->attr.dimension = attr->dimension; c->attr.codimension = attr->codimension; - c->attr.abstract = ts->u.derived->attr.abstract; + c->attr.abstract = fclass->attr.abstract; c->as = (*as); c->initializer = NULL; @@ -591,17 +638,21 @@ gfc_build_class_symbol (gfc_typespec *ts, symbol_attribute *attr, c->attr.pointer = 1; } - /* Since the extension field is 8 bit wide, we can only have - up to 255 extension levels. */ - if (ts->u.derived->attr.extension == 255) + if (!ts->u.derived->attr.unlimited_polymorphic) { - gfc_error ("Maximum extension level reached with type '%s' at %L", - ts->u.derived->name, &ts->u.derived->declared_at); - return FAILURE; + /* Since the extension field is 8 bit wide, we can only have + up to 255 extension levels. */ + if (ts->u.derived->attr.extension == 255) + { + gfc_error ("Maximum extension level reached with type '%s' at %L", + ts->u.derived->name, &ts->u.derived->declared_at); + return FAILURE; + } + + fclass->attr.extension = ts->u.derived->attr.extension + 1; + fclass->attr.alloc_comp = ts->u.derived->attr.alloc_comp; } - - fclass->attr.extension = ts->u.derived->attr.extension + 1; - fclass->attr.alloc_comp = ts->u.derived->attr.alloc_comp; + fclass->attr.is_class = 1; ts->u.derived = fclass; attr->allocatable = attr->pointer = attr->dimension = attr->codimension = 0; @@ -620,7 +671,7 @@ add_proc_comp (gfc_symbol *vtype, const char *name, gfc_typebound_proc *tb) if (tb->non_overridable) return; - + c = gfc_find_component (vtype, name, true, true); if (c == NULL) @@ -670,7 +721,7 @@ add_procs_to_declared_vtab1 (gfc_symtree *st, gfc_symbol *vtype) if (st->right) add_procs_to_declared_vtab1 (st->right, vtype); - if (st->n.tb && !st->n.tb->error + if (st->n.tb && !st->n.tb->error && !st->n.tb->is_generic && st->n.tb->u.specific) add_proc_comp (vtype, st->name, st->n.tb); } @@ -1766,15 +1817,15 @@ gfc_find_derived_vtab (gfc_symbol *derived) gfc_symbol *vtab = NULL, *vtype = NULL, *found_sym = NULL, *def_init = NULL; gfc_symbol *copy = NULL, *src = NULL, *dst = NULL; - /* Find the top-level namespace (MODULE or PROGRAM). */ + /* Find the top-level namespace. */ for (ns = gfc_current_ns; ns; ns = ns->parent) if (!ns->parent) break; /* If the type is a class container, use the underlying derived type. */ - if (derived->attr.is_class) + if (!derived->attr.unlimited_polymorphic && derived->attr.is_class) derived = gfc_get_derived_super_type (derived); - + if (ns) { char name[GFC_MAX_SYMBOL_LEN+1], tname[GFC_MAX_SYMBOL_LEN+1]; @@ -1844,7 +1895,11 @@ gfc_find_derived_vtab (gfc_symbol *derived) goto cleanup; c->attr.pointer = 1; c->attr.access = ACCESS_PRIVATE; - parent = gfc_get_derived_super_type (derived); + if (!derived->attr.unlimited_polymorphic) + parent = gfc_get_derived_super_type (derived); + else + parent = NULL; + if (parent) { parent_vtab = gfc_find_derived_vtab (parent); @@ -1862,7 +1917,9 @@ gfc_find_derived_vtab (gfc_symbol *derived) c->initializer = gfc_get_null_expr (NULL); } - if (derived->components == NULL && !derived->attr.zero_comp) + if (!derived->attr.unlimited_polymorphic + && derived->components == NULL + && !derived->attr.zero_comp) { /* At this point an error must have occurred. Prevent further errors on the vtype components. */ @@ -1878,7 +1935,8 @@ gfc_find_derived_vtab (gfc_symbol *derived) c->attr.access = ACCESS_PRIVATE; c->ts.type = BT_DERIVED; c->ts.u.derived = derived; - if (derived->attr.abstract) + if (derived->attr.unlimited_polymorphic + || derived->attr.abstract) c->initializer = gfc_get_null_expr (NULL); else { @@ -1905,7 +1963,8 @@ gfc_find_derived_vtab (gfc_symbol *derived) c->attr.access = ACCESS_PRIVATE; c->tb = XCNEW (gfc_typebound_proc); c->tb->ppc = 1; - if (derived->attr.abstract) + if (derived->attr.unlimited_polymorphic + || derived->attr.abstract) c->initializer = gfc_get_null_expr (NULL); else { @@ -1966,7 +2025,7 @@ gfc_find_derived_vtab (gfc_symbol *derived) Note: The actual wrapper function can only be generated at resolution time. */ /* FIXME: Enable ABI-breaking "_final" generation. */ - if (0) + if (0) { if (gfc_add_component (vtype, "_final", &c) == FAILURE) goto cleanup; @@ -1978,7 +2037,8 @@ gfc_find_derived_vtab (gfc_symbol *derived) } /* Add procedure pointers for type-bound procedures. */ - add_procs_to_declared_vtab (derived, vtype); + if (!derived->attr.unlimited_polymorphic) + add_procs_to_declared_vtab (derived, vtype); } have_vtype: @@ -2055,6 +2115,233 @@ yes: } +/* Find (or generate) the symbol for an intrinsic type's vtab. This is + need to support unlimited polymorphism. */ + +gfc_symbol * +gfc_find_intrinsic_vtab (gfc_typespec *ts) +{ + gfc_namespace *ns; + gfc_symbol *vtab = NULL, *vtype = NULL, *found_sym = NULL, *def_init = NULL; + gfc_symbol *copy = NULL, *src = NULL, *dst = NULL; + int charlen = 0; + + if (ts->type == BT_CHARACTER && ts->deferred) + { + gfc_error ("TODO: Deferred character length variable at %C cannot " + "yet be associated with unlimited polymorphic entities"); + return NULL; + } + + if (ts->type == BT_UNKNOWN) + return NULL; + + /* Sometimes the typespec is passed from a single call. */ + if (ts->type == BT_DERIVED) + return gfc_find_derived_vtab (ts->u.derived); + + /* Find the top-level namespace. */ + for (ns = gfc_current_ns; ns; ns = ns->parent) + if (!ns->parent) + break; + + if (ts->type == BT_CHARACTER && ts->u.cl && ts->u.cl->length + && ts->u.cl->length->expr_type == EXPR_CONSTANT) + charlen = mpz_get_si (ts->u.cl->length->value.integer); + + if (ns) + { + char name[GFC_MAX_SYMBOL_LEN+1], tname[GFC_MAX_SYMBOL_LEN+1]; + + if (ts->type == BT_CHARACTER) + sprintf (tname, "%s_%d_%d", gfc_basic_typename (ts->type), + charlen, ts->kind); + else + sprintf (tname, "%s_%d_", gfc_basic_typename (ts->type), ts->kind); + + sprintf (name, "__vtab_%s", tname); + + /* Look for the vtab symbol in various namespaces. */ + gfc_find_symbol (name, gfc_current_ns, 0, &vtab); + if (vtab == NULL) + gfc_find_symbol (name, ns, 0, &vtab); + + if (vtab == NULL) + { + gfc_get_symbol (name, ns, &vtab); + vtab->ts.type = BT_DERIVED; + if (gfc_add_flavor (&vtab->attr, FL_VARIABLE, NULL, + &gfc_current_locus) == FAILURE) + goto cleanup; + vtab->attr.target = 1; + vtab->attr.save = SAVE_IMPLICIT; + vtab->attr.vtab = 1; + vtab->attr.access = ACCESS_PUBLIC; + gfc_set_sym_referenced (vtab); + sprintf (name, "__vtype_%s", tname); + + gfc_find_symbol (name, ns, 0, &vtype); + if (vtype == NULL) + { + gfc_component *c; + int hash; + gfc_namespace *sub_ns; + gfc_namespace *contained; + + gfc_get_symbol (name, ns, &vtype); + if (gfc_add_flavor (&vtype->attr, FL_DERIVED, + NULL, &gfc_current_locus) == FAILURE) + goto cleanup; + vtype->attr.access = ACCESS_PUBLIC; + vtype->attr.vtype = 1; + gfc_set_sym_referenced (vtype); + + /* Add component '_hash'. */ + if (gfc_add_component (vtype, "_hash", &c) == FAILURE) + goto cleanup; + c->ts.type = BT_INTEGER; + c->ts.kind = 4; + c->attr.access = ACCESS_PRIVATE; + hash = gfc_intrinsic_hash_value (ts); + c->initializer = gfc_get_int_expr (gfc_default_integer_kind, + NULL, hash); + + /* Add component '_size'. */ + if (gfc_add_component (vtype, "_size", &c) == FAILURE) + goto cleanup; + c->ts.type = BT_INTEGER; + c->ts.kind = 4; + c->attr.access = ACCESS_PRIVATE; + if (ts->type == BT_CHARACTER) + c->initializer = gfc_get_int_expr (gfc_default_integer_kind, + NULL, charlen*ts->kind); + else + c->initializer = gfc_get_int_expr (gfc_default_integer_kind, + NULL, ts->kind); + + /* Add component _extends. */ + if (gfc_add_component (vtype, "_extends", &c) == FAILURE) + goto cleanup; + c->attr.pointer = 1; + c->attr.access = ACCESS_PRIVATE; + /* Avoid segfaults because due to character length. */ + c->ts.type = ts->type == BT_CHARACTER ? BT_VOID : ts->type; + c->ts.kind = ts->kind; + c->initializer = gfc_get_null_expr (NULL); + + /* Add component _def_init. */ + if (gfc_add_component (vtype, "_def_init", &c) == FAILURE) + goto cleanup; + c->attr.pointer = 1; + c->attr.access = ACCESS_PRIVATE; + /* Avoid segfaults due to missing character length. */ + c->ts.type = ts->type == BT_CHARACTER ? BT_VOID : ts->type; + c->ts.kind = ts->kind; + c->initializer = gfc_get_null_expr (NULL); + + /* Add component _copy. */ + if (gfc_add_component (vtype, "_copy", &c) == FAILURE) + goto cleanup; + c->attr.proc_pointer = 1; + c->attr.access = ACCESS_PRIVATE; + c->tb = XCNEW (gfc_typebound_proc); + c->tb->ppc = 1; + + /* Check to see if copy function already exists. Note + that this is only used for characters of different + lengths. */ + contained = ns->contained; + for (; contained; contained = contained->sibling) + if (contained->proc_name + && strcmp (name, contained->proc_name->name) == 0) + { + copy = contained->proc_name; + goto got_char_copy; + } + + /* Set up namespace. */ + sub_ns = gfc_get_namespace (ns, 0); + sub_ns->sibling = ns->contained; + ns->contained = sub_ns; + sub_ns->resolved = 1; + /* Set up procedure symbol. */ + if (ts->type != BT_CHARACTER) + sprintf (name, "__copy_%s", tname); + else + /* __copy is always the same for characters. */ + sprintf (name, "__copy_character_%d", ts->kind); + gfc_get_symbol (name, sub_ns, ©); + sub_ns->proc_name = copy; + copy->attr.flavor = FL_PROCEDURE; + copy->attr.subroutine = 1; + copy->attr.pure = 1; + copy->attr.if_source = IFSRC_DECL; + /* This is elemental so that arrays are automatically + treated correctly by the scalarizer. */ + copy->attr.elemental = 1; + if (ns->proc_name->attr.flavor == FL_MODULE) + copy->module = ns->proc_name->name; + gfc_set_sym_referenced (copy); + /* Set up formal arguments. */ + gfc_get_symbol ("src", sub_ns, &src); + src->ts.type = ts->type; + src->ts.kind = ts->kind; + src->attr.flavor = FL_VARIABLE; + src->attr.dummy = 1; + src->attr.intent = INTENT_IN; + gfc_set_sym_referenced (src); + copy->formal = gfc_get_formal_arglist (); + copy->formal->sym = src; + gfc_get_symbol ("dst", sub_ns, &dst); + dst->ts.type = ts->type; + dst->ts.kind = ts->kind; + dst->attr.flavor = FL_VARIABLE; + dst->attr.dummy = 1; + dst->attr.intent = INTENT_OUT; + gfc_set_sym_referenced (dst); + copy->formal->next = gfc_get_formal_arglist (); + copy->formal->next->sym = dst; + /* Set up code. */ + sub_ns->code = gfc_get_code (); + sub_ns->code->op = EXEC_INIT_ASSIGN; + sub_ns->code->expr1 = gfc_lval_expr_from_sym (dst); + sub_ns->code->expr2 = gfc_lval_expr_from_sym (src); + got_char_copy: + /* Set initializer. */ + c->initializer = gfc_lval_expr_from_sym (copy); + c->ts.interface = copy; + } + vtab->ts.u.derived = vtype; + vtab->value = gfc_default_initializer (&vtab->ts); + } + } + + found_sym = vtab; + +cleanup: + /* It is unexpected to have some symbols added at resolution or code + generation time. We commit the changes in order to keep a clean state. */ + if (found_sym) + { + gfc_commit_symbol (vtab); + if (vtype) + gfc_commit_symbol (vtype); + if (def_init) + gfc_commit_symbol (def_init); + if (copy) + gfc_commit_symbol (copy); + if (src) + gfc_commit_symbol (src); + if (dst) + gfc_commit_symbol (dst); + } + else + gfc_undo_symbols (); + + return found_sym; +} + + /* General worker function to find either a type-bound procedure or a type-bound user operator. */ @@ -2147,7 +2434,7 @@ gfc_find_typebound_intrinsic_op (gfc_symbol* derived, gfc_try* t, /* Try to find it in the current type's namespace. */ if (derived->f2k_derived) res = derived->f2k_derived->tb_op[op]; - else + else res = NULL; /* Check access. */ diff --git a/gcc/fortran/decl.c b/gcc/fortran/decl.c index 77ca9930afc..5ed838856a9 100644 --- a/gcc/fortran/decl.c +++ b/gcc/fortran/decl.c @@ -2735,9 +2735,37 @@ gfc_match_decl_type_spec (gfc_typespec *ts, int implicit_flag) return MATCH_ERROR; else if (m == MATCH_YES) { - gfc_fatal_error ("Unlimited polymorphism at %C not yet supported"); + gfc_symbol *upe; + gfc_symtree *st; + ts->type = BT_CLASS; + gfc_find_symbol ("$tar", gfc_current_ns, 1, &upe); + if (upe == NULL) + { + upe = gfc_new_symbol ("$tar", gfc_current_ns); + st = gfc_new_symtree (&gfc_current_ns->sym_root, "$tar"); + st->n.sym = upe; + gfc_set_sym_referenced (upe); + upe->refs++; + upe->ts.type = BT_VOID; + upe->attr.unlimited_polymorphic = 1; + /* This is essential to force the construction of + unlimited polymorphic component class containers. */ + upe->attr.zero_comp = 1; + if (gfc_add_flavor (&upe->attr, FL_DERIVED, + NULL, &gfc_current_locus) == FAILURE) return MATCH_ERROR; } + else + { + st = gfc_find_symtree (gfc_current_ns->sym_root, "$tar"); + if (st == NULL) + st = gfc_new_symtree (&gfc_current_ns->sym_root, "$tar"); + st->n.sym = upe; + upe->refs++; + } + ts->u.derived = upe; + return m; + } m = gfc_match (" class ( %n )", name); if (m != MATCH_YES) @@ -4248,6 +4276,10 @@ gfc_match_data_decl (void) goto cleanup; } + if (current_ts.type == BT_CLASS + && current_ts.u.derived->attr.unlimited_polymorphic) + goto ok; + if ((current_ts.type == BT_DERIVED || current_ts.type == BT_CLASS) && current_ts.u.derived->components == NULL && !current_ts.u.derived->attr.zero_comp) diff --git a/gcc/fortran/expr.c b/gcc/fortran/expr.c index b535e8adf5d..5c9ce11c4ee 100644 --- a/gcc/fortran/expr.c +++ b/gcc/fortran/expr.c @@ -729,10 +729,10 @@ gfc_copy_shape_excluding (mpz_t *shape, int rank, gfc_expr *dim) mpz_t *new_shape, *s; int i, n; - if (shape == NULL + if (shape == NULL || rank <= 1 || dim == NULL - || dim->expr_type != EXPR_CONSTANT + || dim->expr_type != EXPR_CONSTANT || dim->ts.type != BT_INTEGER) return NULL; @@ -1389,7 +1389,7 @@ find_array_section (gfc_expr *expr, gfc_ref *ref) gcc_assert (begin->rank == 1); /* Zero-sized arrays have no shape and no elements, stop early. */ - if (!begin->shape) + if (!begin->shape) { mpz_init_set_ui (nelts, 0); break; @@ -1473,7 +1473,7 @@ find_array_section (gfc_expr *expr, gfc_ref *ref) /* An element reference reduces the rank of the expression; don't add anything to the shape array. */ - if (ref->u.ar.dimen_type[d] != DIMEN_ELEMENT) + if (ref->u.ar.dimen_type[d] != DIMEN_ELEMENT) mpz_set (expr->shape[shape_i++], tmp_mpz); } @@ -1520,7 +1520,7 @@ find_array_section (gfc_expr *expr, gfc_ref *ref) } else { - mpz_add (ctr[d], ctr[d], stride[d]); + mpz_add (ctr[d], ctr[d], stride[d]); if (mpz_cmp_ui (stride[d], 0) > 0 ? mpz_cmp (ctr[d], end[d]) > 0 @@ -1952,7 +1952,7 @@ scalarize_intrinsic_call (gfc_expr *e) gfc_constructor *ci, *new_ctor; gfc_expr *expr, *old; int n, i, rank[5], array_arg; - + /* Find which, if any, arguments are arrays. Assume that the old expression carries the type information and that the first arg that is an array expression carries all the shape information.*/ @@ -2105,7 +2105,7 @@ check_intrinsic_op (gfc_expr *e, gfc_try (*check_function) (gfc_expr *)) case INTRINSIC_LE_OS: if ((*check_function) (op2) == FAILURE) return FAILURE; - + if (!(et0 (op1) == BT_CHARACTER && et0 (op2) == BT_CHARACTER) && !(numeric_type (et0 (op1)) && numeric_type (et0 (op2)))) { @@ -2271,7 +2271,7 @@ check_inquiry (gfc_expr *e, int not_restricted) name = e->symtree->n.sym->name; - functions = (gfc_option.warn_std & GFC_STD_F2003) + functions = (gfc_option.warn_std & GFC_STD_F2003) ? inquiry_func_f2003 : inquiry_func_f95; for (i = 0; functions[i]; i++) @@ -2360,7 +2360,7 @@ check_transformational (gfc_expr *e) name = e->symtree->n.sym->name; - functions = (gfc_option.allow_std & GFC_STD_F2003) + functions = (gfc_option.allow_std & GFC_STD_F2003) ? trans_func_f2003 : trans_func_f95; /* NULL() is dealt with below. */ @@ -3097,7 +3097,7 @@ gfc_check_assign (gfc_expr *lvalue, gfc_expr *rvalue, int conform) || gfc_current_ns->parent->proc_name->attr.subroutine) || gfc_current_ns->parent->proc_name->attr.is_main_program)) { - /* ... that is not a function... */ + /* ... that is not a function... */ if (!gfc_current_ns->proc_name->attr.function) bad_proc = true; @@ -3137,7 +3137,7 @@ gfc_check_assign (gfc_expr *lvalue, gfc_expr *rvalue, int conform) } if (rvalue->expr_type == EXPR_NULL) - { + { if (has_pointer && (ref == NULL || ref->next == NULL) && lvalue->symtree->n.sym->attr.data) return SUCCESS; @@ -3150,7 +3150,7 @@ gfc_check_assign (gfc_expr *lvalue, gfc_expr *rvalue, int conform) } /* This is possibly a typo: x = f() instead of x => f(). */ - if (gfc_option.warn_surprising + if (gfc_option.warn_surprising && rvalue->expr_type == EXPR_FUNCTION && rvalue->symtree->n.sym->attr.pointer) gfc_warning ("POINTER valued function appears on right-hand side of " @@ -3222,15 +3222,15 @@ gfc_check_assign (gfc_expr *lvalue, gfc_expr *rvalue, int conform) mpfr_init (rv); gfc_set_model_kind (rvalue->ts.kind); mpfr_init (diff); - + mpfr_set (rv, rvalue->value.real, GFC_RND_MODE); mpfr_sub (diff, rv, rvalue->value.real, GFC_RND_MODE); - + if (!mpfr_zero_p (diff)) gfc_warning ("Change of value in conversion from " " %s to %s at %L", gfc_typename (&rvalue->ts), gfc_typename (&lvalue->ts), &rvalue->where); - + mpfr_clear (rv); mpfr_clear (diff); } @@ -3550,9 +3550,22 @@ gfc_check_pointer_assign (gfc_expr *lvalue, gfc_expr *rvalue) if (!gfc_compare_types (&lvalue->ts, &rvalue->ts)) { - gfc_error ("Different types in pointer assignment at %L; attempted " - "assignment of %s to %s", &lvalue->where, - gfc_typename (&rvalue->ts), gfc_typename (&lvalue->ts)); + /* Check for F03:C717. */ + if (UNLIMITED_POLY (rvalue) + && !(UNLIMITED_POLY (lvalue) + || (lvalue->ts.type == BT_DERIVED + && (lvalue->ts.u.derived->attr.is_bind_c + || lvalue->ts.u.derived->attr.sequence)))) + gfc_error ("Data-pointer-object &L must be unlimited " + "polymorphic, a sequence derived type or of a " + "type with the BIND attribute assignment at %L " + "to be compatible with an unlimited polymorphic " + "target", &lvalue->where); + else + gfc_error ("Different types in pointer assignment at %L; " + "attempted assignment of %s to %s", &lvalue->where, + gfc_typename (&rvalue->ts), + gfc_typename (&lvalue->ts)); return FAILURE; } @@ -3569,9 +3582,11 @@ gfc_check_pointer_assign (gfc_expr *lvalue, gfc_expr *rvalue) return FAILURE; } - if (lvalue->ts.type == BT_CLASS && rvalue->ts.type == BT_DERIVED) /* Make sure the vtab is present. */ + if (lvalue->ts.type == BT_CLASS && rvalue->ts.type == BT_DERIVED) gfc_find_derived_vtab (rvalue->ts.u.derived); + else if (UNLIMITED_POLY (lvalue) && !UNLIMITED_POLY (rvalue)) + gfc_find_intrinsic_vtab (&rvalue->ts); /* Check rank remapping. */ if (rank_remap) @@ -3647,7 +3662,7 @@ gfc_check_pointer_assign (gfc_expr *lvalue, gfc_expr *rvalue) if (is_implicit_pure && gfc_impure_variable (rvalue->symtree->n.sym)) gfc_current_ns->proc_name->attr.implicit_pure = 0; - + if (gfc_has_vector_index (rvalue)) { @@ -3747,7 +3762,7 @@ gfc_check_assign_symbol (gfc_symbol *sym, gfc_expr *rvalue) if (r == FAILURE) return r; - + if (sym->attr.pointer && rvalue->expr_type != EXPR_NULL) { /* F08:C461. Additional checks for pointer initialization. */ @@ -3772,7 +3787,7 @@ gfc_check_assign_symbol (gfc_symbol *sym, gfc_expr *rvalue) return FAILURE; } } - + if (sym->attr.proc_pointer && rvalue->expr_type != EXPR_NULL) { /* F08:C1220. Additional checks for procedure pointer initialization. */ @@ -4251,7 +4266,7 @@ gfc_expr_check_typed (gfc_expr* e, gfc_namespace* ns, bool strict) static bool replace_symbol (gfc_expr *expr, gfc_symbol *sym, int *i ATTRIBUTE_UNUSED) { - if ((expr->expr_type == EXPR_VARIABLE + if ((expr->expr_type == EXPR_VARIABLE || (expr->expr_type == EXPR_FUNCTION && !gfc_is_intrinsic (expr->symtree->n.sym, 0, expr->where))) && expr->symtree->n.sym->ns == sym->ts.interface->formal_ns @@ -4285,7 +4300,7 @@ replace_comp (gfc_expr *expr, gfc_symbol *sym, int *i ATTRIBUTE_UNUSED) { gfc_component *comp; comp = (gfc_component *)sym; - if ((expr->expr_type == EXPR_VARIABLE + if ((expr->expr_type == EXPR_VARIABLE || (expr->expr_type == EXPR_FUNCTION && !gfc_is_intrinsic (expr->symtree->n.sym, 0, expr->where))) && expr->symtree->n.sym->ns == comp->ts.interface->formal_ns) @@ -4421,7 +4436,7 @@ gfc_get_corank (gfc_expr *e) if (e->ts.type == BT_CLASS && e->ts.u.derived->components) corank = e->ts.u.derived->components->as ? e->ts.u.derived->components->as->corank : 0; - else + else corank = e->symtree->n.sym->as ? e->symtree->n.sym->as->corank : 0; for (ref = e->ref; ref; ref = ref->next) @@ -4478,7 +4493,7 @@ gfc_has_ultimate_pointer (gfc_expr *e) for (ref = e->ref; ref; ref = ref->next) if (ref->type == REF_COMPONENT) last = ref; - + if (last && last->u.c.component->ts.type == BT_CLASS) return CLASS_DATA (last->u.c.component)->attr.pointer_comp; else if (last && last->u.c.component->ts.type == BT_DERIVED) @@ -4598,7 +4613,7 @@ gfc_is_simply_contiguous (gfc_expr *expr, bool strict) ar->as->upper[i]->value.integer) != 0)) colon = false; } - + return true; } @@ -4618,7 +4633,7 @@ gfc_build_intrinsic_call (const char* name, locus where, unsigned numarg, ...) isym = gfc_find_function (name); gcc_assert (isym); - + result = gfc_get_expr (); result->expr_type = EXPR_FUNCTION; result->ts = isym->ts; @@ -4669,6 +4684,7 @@ gfc_check_vardef_context (gfc_expr* e, bool pointer, bool alloc_obj, bool is_pointer; bool check_intentin; bool ptr_component; + bool unlimited; symbol_attribute attr; gfc_ref* ref; @@ -4683,6 +4699,8 @@ gfc_check_vardef_context (gfc_expr* e, bool pointer, bool alloc_obj, sym = e->value.function.esym ? e->value.function.esym : e->symtree->n.sym; } + unlimited = e->ts.type == BT_CLASS && UNLIMITED_POLY (sym); + attr = gfc_expr_attr (e); if (!pointer && e->expr_type == EXPR_FUNCTION && attr.pointer) { @@ -4722,7 +4740,7 @@ gfc_check_vardef_context (gfc_expr* e, bool pointer, bool alloc_obj, /* Find out whether the expr is a pointer; this also means following component references to the last one. */ is_pointer = (attr.pointer || attr.proc_pointer); - if (pointer && !is_pointer) + if (pointer && !is_pointer && !unlimited) { if (context) gfc_error ("Non-POINTER in pointer association context (%s)" diff --git a/gcc/fortran/gfortran.h b/gcc/fortran/gfortran.h index 74162e777e4..5eda83989da 100644 --- a/gcc/fortran/gfortran.h +++ b/gcc/fortran/gfortran.h @@ -796,10 +796,12 @@ typedef struct components or private components, procedure pointer components, possibly nested. zero_comp is true if the derived type has no component at all. defined_assign_comp is true if the derived - type or a (sub-)component has a typebound defined assignment. */ + type or a (sub-)component has a typebound defined assignment. + unlimited_polymorphic flags the type of the container for these + entities. */ unsigned alloc_comp:1, pointer_comp:1, proc_pointer_comp:1, private_comp:1, zero_comp:1, coarray_comp:1, lock_comp:1, - defined_assign_comp:1; + defined_assign_comp:1, unlimited_polymorphic:1; /* This is a temporary selector for SELECT TYPE. */ unsigned select_type_temporary:1; @@ -1271,7 +1273,6 @@ typedef struct gfc_symbol } gfc_symbol; - /* This structure is used to keep track of symbols in common blocks. */ typedef struct gfc_common_head { @@ -2964,11 +2965,12 @@ void gfc_add_class_array_ref (gfc_expr *); bool gfc_is_class_array_ref (gfc_expr *, bool *); bool gfc_is_class_scalar_expr (gfc_expr *); bool gfc_is_class_container_ref (gfc_expr *e); -gfc_expr *gfc_class_null_initializer (gfc_typespec *); +gfc_expr *gfc_class_null_initializer (gfc_typespec *, gfc_expr *); unsigned int gfc_hash_value (gfc_symbol *); gfc_try gfc_build_class_symbol (gfc_typespec *, symbol_attribute *, gfc_array_spec **, bool); gfc_symbol *gfc_find_derived_vtab (gfc_symbol *); +gfc_symbol *gfc_find_intrinsic_vtab (gfc_typespec *); gfc_symtree* gfc_find_typebound_proc (gfc_symbol*, gfc_try*, const char*, bool, locus*); gfc_symtree* gfc_find_typebound_user_op (gfc_symbol*, gfc_try*, @@ -2980,6 +2982,11 @@ gfc_symtree* gfc_get_tbp_symtree (gfc_symtree**, const char*); bool gfc_is_finalizable (gfc_symbol *, gfc_expr **); #define CLASS_DATA(sym) sym->ts.u.derived->components +#define UNLIMITED_POLY(sym) \ + (sym != NULL && sym->ts.type == BT_CLASS \ + && CLASS_DATA (sym) \ + && CLASS_DATA (sym)->ts.u.derived \ + && CLASS_DATA (sym)->ts.u.derived->attr.unlimited_polymorphic) /* frontend-passes.c */ diff --git a/gcc/fortran/interface.c b/gcc/fortran/interface.c index d90fc73e8dd..908db747c04 100644 --- a/gcc/fortran/interface.c +++ b/gcc/fortran/interface.c @@ -214,7 +214,7 @@ gfc_match_interface (void) if (gfc_get_symbol (name, NULL, &sym)) return MATCH_ERROR; - if (!sym->attr.generic + if (!sym->attr.generic && gfc_add_generic (&sym->attr, sym->name, NULL) == FAILURE) return MATCH_ERROR; @@ -351,7 +351,7 @@ gfc_match_end_interface (void) gfc_error ("Expecting 'END INTERFACE OPERATOR (%s)' at %C, " "but got %s", s1, s2); } - + } break; @@ -446,7 +446,7 @@ gfc_compare_derived_types (gfc_symbol *derived1, gfc_symbol *derived2) if (dt1->attr.dimension && gfc_compare_array_spec (dt1->as, dt2->as) == 0) return 0; - /* Make sure that link lists do not put this function into an + /* Make sure that link lists do not put this function into an endless recursive loop! */ if (!(dt1->ts.type == BT_DERIVED && derived1 == dt1->ts.u.derived) && !(dt2->ts.type == BT_DERIVED && derived2 == dt2->ts.u.derived) @@ -485,7 +485,17 @@ gfc_compare_types (gfc_typespec *ts1, gfc_typespec *ts2) that is for the formal arg, but oh well. */ if (ts1->type == BT_VOID || ts2->type == BT_VOID) return 1; - + + if (ts1->type == BT_CLASS + && ts1->u.derived->components->ts.u.derived->attr.unlimited_polymorphic) + return 1; + + /* F2003: C717 */ + if (ts2->type == BT_CLASS && ts1->type == BT_DERIVED + && ts2->u.derived->components->ts.u.derived->attr.unlimited_polymorphic + && (ts1->u.derived->attr.sequence || ts1->u.derived->attr.is_bind_c)) + return 1; + if (ts1->type != ts2->type && ((ts1->type != BT_DERIVED && ts1->type != BT_CLASS) || (ts2->type != BT_DERIVED && ts2->type != BT_CLASS))) @@ -523,7 +533,7 @@ compare_type_rank (gfc_symbol *s1, gfc_symbol *s2) return 0; /* Ranks differ. */ return gfc_compare_types (&s1->ts, &s2->ts) - || s1->ts.type == BT_ASSUMED || s2->ts.type == BT_ASSUMED; + || s1->ts.type == BT_ASSUMED || s2->ts.type == BT_ASSUMED; } @@ -1157,7 +1167,7 @@ check_dummy_characteristics (gfc_symbol *s1, gfc_symbol *s2, } } } - + return SUCCESS; } @@ -1403,6 +1413,9 @@ gfc_compare_interfaces (gfc_symbol *s1, gfc_symbol *s2, const char *name2, return 0; } + if (UNLIMITED_POLY (f1->sym)) + goto next; + if (strict_flag) { /* Check all characteristics. */ @@ -1418,7 +1431,7 @@ gfc_compare_interfaces (gfc_symbol *s1, gfc_symbol *s2, const char *name2, f1->sym->name); return 0; } - +next: f1 = f1->next; f2 = f2->next; } @@ -1712,7 +1725,7 @@ gfc_check_interfaces (gfc_namespace *ns) for (ns2 = ns; ns2; ns2 = ns2->parent) { gfc_intrinsic_op other_op; - + if (check_interface1 (ns->op[i], ns2->op[i], 0, interface_name, true)) goto done; @@ -1814,7 +1827,7 @@ argument_rank_mismatch (const char *name, locus *where, "(rank-%d and scalar)", name, where, rank1); } else - { + { gfc_error ("Rank mismatch in argument '%s' at %L " "(rank-%d and rank-%d)", name, where, rank1, rank2); } @@ -1900,7 +1913,7 @@ compare_parameter (gfc_symbol *formal, gfc_expr *actual, && formal->ts.type != BT_ASSUMED && !gfc_compare_types (&formal->ts, &actual->ts) && !(formal->ts.type == BT_DERIVED && actual->ts.type == BT_CLASS - && gfc_compare_derived_types (formal->ts.u.derived, + && gfc_compare_derived_types (formal->ts.u.derived, CLASS_DATA (actual)->ts.u.derived))) { if (where) @@ -1933,6 +1946,23 @@ compare_parameter (gfc_symbol *formal, gfc_expr *actual, } } + /* F08: 12.5.2.5 Allocatable and pointer dummy variables. However, this + is necessary also for F03, so retain error for both. + NOTE: Other type/kind errors pre-empt this error. Since they are F03 + compatible, no attempt has been made to channel to this one. */ + if (UNLIMITED_POLY (formal) && !UNLIMITED_POLY (actual) + && (CLASS_DATA (formal)->attr.allocatable + ||CLASS_DATA (formal)->attr.class_pointer)) + { + if (where) + gfc_error ("Actual argument to '%s' at %L must be unlimited " + "polymorphic since the formal argument is a " + "pointer or allocatable unlimited polymorphic " + "entity [F2008: 12.5.2.5]", formal->name, + &actual->where); + return 0; + } + if (formal->attr.codimension && !gfc_is_coarray (actual)) { if (where) @@ -2078,7 +2108,7 @@ compare_parameter (gfc_symbol *formal, gfc_expr *actual, is_pointer = ref->u.c.component->attr.pointer; else if (ref->type == REF_ARRAY && ref->u.ar.type == AR_ELEMENT && ref->u.ar.dimen > 0 - && (!ref->next + && (!ref->next || (ref->next->type == REF_SUBSTRING && !ref->next->next))) break; } @@ -2156,7 +2186,7 @@ get_sym_storage_size (gfc_symbol *sym) return 0; } else - strlen = 1; + strlen = 1; if (symbol_rank (sym) == 0) return strlen; @@ -2194,7 +2224,7 @@ get_expr_storage_size (gfc_expr *e) if (e == NULL) return 0; - + if (e->ts.type == BT_CHARACTER) { if (e->ts.u.cl && e->ts.u.cl->length @@ -2455,6 +2485,13 @@ compare_actual_formal (gfc_actual_arglist **ap, gfc_formal_arglist *formal, return 0; } + /* Make sure that intrinsic vtables exist for calls to unlimited + polymorphic formal arguments. */ + if (UNLIMITED_POLY(f->sym) + && a->expr->ts.type != BT_DERIVED + && a->expr->ts.type != BT_CLASS) + gfc_find_intrinsic_vtab (&a->expr->ts); + if (a->expr->expr_type == EXPR_NULL && ((f->sym->ts.type != BT_CLASS && !f->sym->attr.pointer && (f->sym->attr.allocatable || !f->sym->attr.optional @@ -2478,7 +2515,7 @@ compare_actual_formal (gfc_actual_arglist **ap, gfc_formal_arglist *formal, return 0; } - + if (!compare_parameter (f->sym, a->expr, ranks_must_agree, is_elemental, where)) return 0; @@ -2628,7 +2665,7 @@ compare_actual_formal (gfc_actual_arglist **ap, gfc_formal_arglist *formal, "pointer dummy '%s'", &a->expr->where,f->sym->name); return 0; } - + /* Fortran 2008, C1242. */ if (f->sym->attr.pointer && gfc_is_coindexed (a->expr)) @@ -3283,7 +3320,7 @@ gfc_search_interface (gfc_interface *intr, int sub_flag, has_null_arg = true; null_expr_loc = a->expr->where; break; - } + } for (; intr; intr = intr->next) { @@ -3310,7 +3347,7 @@ gfc_search_interface (gfc_interface *intr, int sub_flag, } /* Satisfy 12.4.4.1 such that an elemental match has lower - weight than a non-elemental match. */ + weight than a non-elemental match. */ if (intr->sym->attr.elemental) { elem_sym = intr->sym; @@ -3613,7 +3650,7 @@ gfc_extend_expr (gfc_expr *e) tbo = matching_typebound_op (&tb_base, actual, i, NULL, &gname); break; } - + /* If there is a matching typebound-operator, replace the expression with a call to it and succeed. */ if (tbo) @@ -3703,7 +3740,7 @@ gfc_extend_assign (gfc_code *c, gfc_namespace *ns) /* See if we find a matching type-bound assignment. */ tbo = matching_typebound_op (&tb_base, actual, INTRINSIC_ASSIGN, NULL, &gname); - + /* If there is one, replace the expression with a call to it and succeed. */ if (tbo) @@ -4028,7 +4065,7 @@ gfc_check_typebound_override (gfc_symtree* proc, gfc_symtree* old) " FUNCTION", proc->name, &where); return FAILURE; } - + if (check_result_characteristics (proc_target, old_target, err, sizeof(err)) == FAILURE) { diff --git a/gcc/fortran/match.c b/gcc/fortran/match.c index 39da62faedf..6322fae6fda 100644 --- a/gcc/fortran/match.c +++ b/gcc/fortran/match.c @@ -588,7 +588,7 @@ gfc_match_name_C (const char **buffer) size_t i = 0; gfc_char_t c; char* buf; - size_t cursz = 16; + size_t cursz = 16; old_loc = gfc_current_locus; gfc_gobble_whitespace (); @@ -605,7 +605,7 @@ gfc_match_name_C (const char **buffer) gfc_current_locus = old_loc; return MATCH_YES; } - + if (!ISALPHA (c) && c != '_') { gfc_error ("Invalid C name in NAME= specifier at %C"); @@ -625,9 +625,9 @@ gfc_match_name_C (const char **buffer) cursz *= 2; buf = XRESIZEVEC (char, buf, cursz); } - + old_loc = gfc_current_locus; - + /* Get next char; param means we're in a string. */ c = gfc_next_char_literal (INSTRING_WARN); } while (ISALNUM (c) || c == '_'); @@ -650,7 +650,7 @@ gfc_match_name_C (const char **buffer) return MATCH_ERROR; } } - + /* If we stopped because we had an invalid character for a C name, report that to the user by returning MATCH_NO. */ if (c != '"' && c != '\'') @@ -708,8 +708,8 @@ gfc_match_symbol (gfc_symbol **matched_symbol, int host_assoc) } -/* Match an intrinsic operator. Returns an INTRINSIC enum. While matching, - we always find INTRINSIC_PLUS before INTRINSIC_UPLUS. We work around this +/* Match an intrinsic operator. Returns an INTRINSIC enum. While matching, + we always find INTRINSIC_PLUS before INTRINSIC_UPLUS. We work around this in matchexp.c. */ match @@ -1441,7 +1441,7 @@ gfc_match_if (gfc_statement *if_type) old_loc2 = gfc_current_locus; gfc_current_locus = old_loc; - + if (gfc_match_parens () == MATCH_ERROR) return MATCH_ERROR; @@ -1473,7 +1473,7 @@ gfc_match_if (gfc_statement *if_type) gfc_free_expr (expr); return MATCH_ERROR; } - + if (gfc_notify_std (GFC_STD_F95_OBS, "Arithmetic IF " "statement at %C") == FAILURE) return MATCH_ERROR; @@ -1579,7 +1579,7 @@ gfc_match_if (gfc_statement *if_type) match ("write", gfc_match_write, ST_WRITE) /* The gfc_match_assignment() above may have returned a MATCH_NO - where the assignment was to a named constant. Check that + where the assignment was to a named constant. Check that special case here. */ m = gfc_match_assignment (); if (m == MATCH_NO) @@ -1907,7 +1907,7 @@ static match match_derived_type_spec (gfc_typespec *ts) { char name[GFC_MAX_SYMBOL_LEN + 1]; - locus old_locus; + locus old_locus; gfc_symbol *derived; old_locus = gfc_current_locus; @@ -1930,7 +1930,7 @@ match_derived_type_spec (gfc_typespec *ts) return MATCH_YES; } - gfc_current_locus = old_locus; + gfc_current_locus = old_locus; return MATCH_NO; } @@ -2194,7 +2194,7 @@ cleanup: return MATCH_ERROR; } -/* Match the rest of a simple FORALL statement that follows an +/* Match the rest of a simple FORALL statement that follows an IF statement. */ static match @@ -2373,7 +2373,7 @@ gfc_match_do (void) return MATCH_NO; /* Check for balanced parens. */ - + if (gfc_match_parens () == MATCH_ERROR) return MATCH_ERROR; @@ -2585,7 +2585,7 @@ match_exit_cycle (gfc_statement st, gfc_exec_op op) " do-construct-name at %C") == FAILURE) return MATCH_ERROR; break; - + default: gfc_error ("%s statement at %C is not applicable to construct '%s'", gfc_ascii_statement (st), sym->name); @@ -3265,7 +3265,7 @@ gfc_match_goto (void) return MATCH_YES; } - /* The assigned GO TO statement. */ + /* The assigned GO TO statement. */ if (gfc_match_variable (&expr, 0) == MATCH_YES) { @@ -3432,6 +3432,7 @@ gfc_match_allocate (void) match m; locus old_locus, deferred_locus; bool saw_stat, saw_errmsg, saw_source, saw_mold, saw_deferred, b1, b2, b3; + bool saw_unlimited = false; head = tail = NULL; stat = errmsg = source = mold = tmp = NULL; @@ -3573,7 +3574,7 @@ gfc_match_allocate (void) } /* Enforce F03:C627. */ - if (ts.kind != tail->expr->ts.kind) + if (ts.kind != tail->expr->ts.kind && !UNLIMITED_POLY (tail->expr)) { gfc_error ("Kind type parameter for entity at %L differs from " "the kind type parameter of the typespec", @@ -3585,6 +3586,8 @@ gfc_match_allocate (void) if (tail->expr->ts.type == BT_DERIVED) tail->expr->ts.u.derived = gfc_use_derived (tail->expr->ts.u.derived); + saw_unlimited = saw_unlimited | UNLIMITED_POLY (tail->expr); + if (gfc_peek_ascii_char () == '(' && !sym->attr.dimension) { gfc_error ("Shape specification for allocatable scalar at %C"); @@ -3696,7 +3699,7 @@ alloc_opt_list: gfc_error ("Redundant MOLD tag found at %L ", &tmp->where); goto cleanup; } - + /* Check F08:C637. */ if (ts.type != BT_UNKNOWN) { @@ -3739,7 +3742,20 @@ alloc_opt_list: &deferred_locus); goto cleanup; } - + + /* Check F03:C625, */ + if (saw_unlimited && ts.type == BT_UNKNOWN && !source && !mold) + { + for (tail = head; tail; tail = tail->next) + { + if (UNLIMITED_POLY (tail->expr)) + gfc_error ("Unlimited polymorphic allocate-object at %L " + "requires either a type-spec or SOURCE tag " + "or a MOLD tag", &tail->expr->where); + } + goto cleanup; + } + new_st.op = EXEC_ALLOCATE; new_st.expr1 = stat; new_st.expr2 = errmsg; @@ -4067,7 +4083,7 @@ done: } -/* Match the call of a type-bound procedure, if CALL%var has already been +/* Match the call of a type-bound procedure, if CALL%var has already been matched and var found to be a derived-type variable. */ static match @@ -4081,7 +4097,7 @@ match_typebound_call (gfc_symtree* varst) base->symtree = varst; base->where = gfc_current_locus; gfc_set_sym_referenced (varst->n.sym); - + m = gfc_match_varspec (base, 0, true, true); if (m == MATCH_NO) gfc_error ("Expected component reference at %C"); @@ -4258,7 +4274,7 @@ cleanup: /* Given a name, return a pointer to the common head structure, creating it if it does not exist. If FROM_MODULE is nonzero, we - mangle the name so that it doesn't interfere with commons defined + mangle the name so that it doesn't interfere with commons defined in the using namespace. TODO: Add to global symbol tree. */ @@ -4403,7 +4419,7 @@ gfc_match_common (void) /* Store a ref to the common block for error checking. */ sym->common_block = t; sym->common_block->refs++; - + /* See if we know the current common block is bind(c), and if so, then see if we can check if the symbol is (which it'll need to be). This can happen if the bind(c) attr stmt was @@ -4423,13 +4439,13 @@ gfc_match_common (void) sym->name, &(sym->declared_at), t->name, t->name); } - + if (sym->attr.is_bind_c == 1) gfc_error_now ("Variable '%s' in common block " "'%s' at %C can not be bind(c) since " "it is not global", sym->name, t->name); } - + if (sym->attr.in_common) { gfc_error ("Symbol '%s' at %C is already in a COMMON block", @@ -4872,7 +4888,7 @@ cleanup: /* Check that a statement function is not recursive. This is done by looking for the statement function symbol(sym) by looking recursively through its - expression(e). If a reference to sym is found, true is returned. + expression(e). If a reference to sym is found, true is returned. 12.5.4 requires that any variable of function that is implicitly typed shall have that type confirmed by any subsequent type declaration. The implicit typing is conveniently done here. */ @@ -5207,47 +5223,100 @@ select_type_push (gfc_symbol *sel) } +/* Set the temporary for the current intrinsic SELECT TYPE selector. */ + +static gfc_symtree * +select_intrinsic_set_tmp (gfc_typespec *ts) +{ + char name[GFC_MAX_SYMBOL_LEN]; + gfc_symtree *tmp; + int charlen = 0; + + if (ts->type == BT_CLASS || ts->type == BT_DERIVED) + return NULL; + + if (select_type_stack->selector->ts.type == BT_CLASS + && !select_type_stack->selector->attr.class_ok) + return NULL; + + if (ts->type == BT_CHARACTER && ts->u.cl && ts->u.cl->length + && ts->u.cl->length->expr_type == EXPR_CONSTANT) + charlen = mpz_get_si (ts->u.cl->length->value.integer); + + if (ts->type != BT_CHARACTER) + sprintf (name, "__tmp_%s_%d", gfc_basic_typename (ts->type), + ts->kind); + else + sprintf (name, "__tmp_%s_%d_%d", gfc_basic_typename (ts->type), + charlen, ts->kind); + + gfc_get_sym_tree (name, gfc_current_ns, &tmp, false); + gfc_add_type (tmp->n.sym, ts, NULL); + + /* Copy across the array spec to the selector. */ + if (select_type_stack->selector->ts.type == BT_CLASS + && (CLASS_DATA (select_type_stack->selector)->attr.dimension + || CLASS_DATA (select_type_stack->selector)->attr.codimension)) + { + tmp->n.sym->attr.pointer = 1; + tmp->n.sym->attr.dimension + = CLASS_DATA (select_type_stack->selector)->attr.dimension; + tmp->n.sym->attr.codimension + = CLASS_DATA (select_type_stack->selector)->attr.codimension; + tmp->n.sym->as + = gfc_copy_array_spec (CLASS_DATA (select_type_stack->selector)->as); + } + + gfc_set_sym_referenced (tmp->n.sym); + gfc_add_flavor (&tmp->n.sym->attr, FL_VARIABLE, name, NULL); + tmp->n.sym->attr.select_type_temporary = 1; + + return tmp; +} + + /* Set up a temporary for the current TYPE IS / CLASS IS branch . */ static void select_type_set_tmp (gfc_typespec *ts) { char name[GFC_MAX_SYMBOL_LEN]; - gfc_symtree *tmp; + gfc_symtree *tmp = NULL; if (!ts) { select_type_stack->tmp = NULL; return; } - - if (!gfc_type_is_extensible (ts->u.derived)) - return; - if (ts->type == BT_CLASS) - sprintf (name, "__tmp_class_%s", ts->u.derived->name); - else - sprintf (name, "__tmp_type_%s", ts->u.derived->name); - gfc_get_sym_tree (name, gfc_current_ns, &tmp, false); - gfc_add_type (tmp->n.sym, ts, NULL); + tmp = select_intrinsic_set_tmp (ts); - if (select_type_stack->selector->ts.type == BT_CLASS - && select_type_stack->selector->attr.class_ok) + if (tmp == NULL) { - tmp->n.sym->attr.pointer - = CLASS_DATA (select_type_stack->selector)->attr.class_pointer; + if (ts->type == BT_CLASS) + sprintf (name, "__tmp_class_%s", ts->u.derived->name); + else + sprintf (name, "__tmp_type_%s", ts->u.derived->name); + gfc_get_sym_tree (name, gfc_current_ns, &tmp, false); + gfc_add_type (tmp->n.sym, ts, NULL); - /* Copy across the array spec to the selector. */ - if ((CLASS_DATA (select_type_stack->selector)->attr.dimension - || CLASS_DATA (select_type_stack->selector)->attr.codimension)) + if (select_type_stack->selector->ts.type == BT_CLASS + && select_type_stack->selector->attr.class_ok) { - tmp->n.sym->attr.dimension + tmp->n.sym->attr.pointer + = CLASS_DATA (select_type_stack->selector)->attr.class_pointer; + + /* Copy across the array spec to the selector. */ + if (CLASS_DATA (select_type_stack->selector)->attr.dimension + || CLASS_DATA (select_type_stack->selector)->attr.codimension) + { + tmp->n.sym->attr.dimension = CLASS_DATA (select_type_stack->selector)->attr.dimension; - tmp->n.sym->attr.codimension + tmp->n.sym->attr.codimension = CLASS_DATA (select_type_stack->selector)->attr.codimension; - tmp->n.sym->as + tmp->n.sym->as = gfc_copy_array_spec (CLASS_DATA (select_type_stack->selector)->as); - } + } } gfc_set_sym_referenced (tmp->n.sym); @@ -5257,6 +5326,7 @@ select_type_set_tmp (gfc_typespec *ts) if (ts->type == BT_CLASS) gfc_build_class_symbol (&tmp->n.sym->ts, &tmp->n.sym->attr, &tmp->n.sym->as, false); + } /* Add an association for it, so the rest of the parser knows it is an associate-name. The target will be set during resolution. */ @@ -5267,7 +5337,7 @@ select_type_set_tmp (gfc_typespec *ts) select_type_stack->tmp = tmp; } - + /* Match a SELECT TYPE statement. */ match @@ -5356,7 +5426,7 @@ gfc_match_select_type (void) select_type_push (expr1->symtree->n.sym); return MATCH_YES; - + cleanup: parent_ns = gfc_current_ns->parent; gfc_free_namespace (gfc_current_ns); @@ -5457,9 +5527,7 @@ gfc_match_type_is (void) c = gfc_get_case (); c->where = gfc_current_locus; - /* TODO: Once unlimited polymorphism is implemented, we will need to call - match_type_spec here. */ - if (match_derived_type_spec (&c->ts) == MATCH_ERROR) + if (match_type_spec (&c->ts) == MATCH_ERROR) goto cleanup; if (gfc_match_char (')') != MATCH_YES) @@ -5474,6 +5542,16 @@ gfc_match_type_is (void) new_st.op = EXEC_SELECT_TYPE; new_st.ext.block.case_list = c; + if (c->ts.type == BT_DERIVED && c->ts.u.derived + && (c->ts.u.derived->attr.sequence + || c->ts.u.derived->attr.is_bind_c)) + { + gfc_error ("The type-spec shall not specify a sequence derived " + "type or a type with the BIND attribute in SELECT " + "TYPE at %C [F2003:C815]"); + return MATCH_ERROR; + } + /* Create temporary variable. */ select_type_set_tmp (&c->ts); @@ -5546,7 +5624,7 @@ gfc_match_class_is (void) new_st.op = EXEC_SELECT_TYPE; new_st.ext.block.case_list = c; - + /* Create temporary variable. */ select_type_set_tmp (&c->ts); @@ -5564,7 +5642,7 @@ cleanup: /********************* WHERE subroutines ********************/ -/* Match the rest of a simple WHERE statement that follows an IF statement. +/* Match the rest of a simple WHERE statement that follows an IF statement. */ static match diff --git a/gcc/fortran/misc.c b/gcc/fortran/misc.c index 60c3cf1ddd3..8aa6df53569 100644 --- a/gcc/fortran/misc.c +++ b/gcc/fortran/misc.c @@ -1,5 +1,6 @@ /* Miscellaneous stuff that doesn't fit anywhere else. - Copyright (C) 2000, 2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2010, 2011 + Copyright (C) 2000, 2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008, + 2010, 2011, 2012 Free Software Foundation, Inc. Contributed by Andy Vaught @@ -158,8 +159,11 @@ gfc_typename (gfc_typespec *ts) sprintf (buffer, "TYPE(%s)", ts->u.derived->name); break; case BT_CLASS: - sprintf (buffer, "CLASS(%s)", - ts->u.derived->components->ts.u.derived->name); + ts = &ts->u.derived->components->ts; + if (ts->u.derived->attr.unlimited_polymorphic) + sprintf (buffer, "CLASS(*)"); + else + sprintf (buffer, "CLASS(%s)", ts->u.derived->name); break; case BT_ASSUMED: sprintf (buffer, "TYPE(*)"); diff --git a/gcc/fortran/module.c b/gcc/fortran/module.c index cde57390c37..168f933936a 100644 --- a/gcc/fortran/module.c +++ b/gcc/fortran/module.c @@ -1844,7 +1844,7 @@ typedef enum AB_IS_BIND_C, AB_IS_C_INTEROP, AB_IS_ISO_C, AB_ABSTRACT, AB_ZERO_COMP, AB_IS_CLASS, AB_PROCEDURE, AB_PROC_POINTER, AB_ASYNCHRONOUS, AB_CODIMENSION, AB_COARRAY_COMP, AB_VTYPE, AB_VTAB, AB_CONTIGUOUS, AB_CLASS_POINTER, - AB_IMPLICIT_PURE, AB_ARTIFICIAL + AB_IMPLICIT_PURE, AB_ARTIFICIAL, AB_UNLIMITED_POLY } ab_attribute; @@ -1898,6 +1898,7 @@ static const mstring attr_bits[] = minit ("VTAB", AB_VTAB), minit ("CLASS_POINTER", AB_CLASS_POINTER), minit ("IMPLICIT_PURE", AB_IMPLICIT_PURE), + minit ("UNLIMITED_POLY", AB_UNLIMITED_POLY), minit (NULL, -1) }; @@ -2036,6 +2037,8 @@ mio_symbol_attribute (symbol_attribute *attr) MIO_NAME (ab_attribute) (AB_PURE, attr_bits); if (attr->implicit_pure) MIO_NAME (ab_attribute) (AB_IMPLICIT_PURE, attr_bits); + if (attr->unlimited_polymorphic) + MIO_NAME (ab_attribute) (AB_UNLIMITED_POLY, attr_bits); if (attr->recursive) MIO_NAME (ab_attribute) (AB_RECURSIVE, attr_bits); if (attr->always_explicit) @@ -2177,6 +2180,9 @@ mio_symbol_attribute (symbol_attribute *attr) case AB_IMPLICIT_PURE: attr->implicit_pure = 1; break; + case AB_UNLIMITED_POLY: + attr->unlimited_polymorphic = 1; + break; case AB_RECURSIVE: attr->recursive = 1; break; diff --git a/gcc/fortran/resolve.c b/gcc/fortran/resolve.c index d4d5eb9b52d..6208a819c13 100644 --- a/gcc/fortran/resolve.c +++ b/gcc/fortran/resolve.c @@ -929,6 +929,10 @@ resolve_common_vars (gfc_symbol *sym, bool named_common) &csym->declared_at); } + if (UNLIMITED_POLY (csym)) + gfc_error_now ("'%s' in cannot appear in COMMON at %L " + "[F2008:C5100]", csym->name, &csym->declared_at); + if (csym->ts.type != BT_DERIVED) continue; @@ -6898,6 +6902,7 @@ resolve_deallocate_expr (gfc_expr *e) gfc_ref *ref; gfc_symbol *sym; gfc_component *c; + bool unlimited; if (gfc_resolve_expr (e) == FAILURE) return FAILURE; @@ -6906,6 +6911,7 @@ resolve_deallocate_expr (gfc_expr *e) goto bad; sym = e->symtree->n.sym; + unlimited = UNLIMITED_POLY(sym); if (sym->ts.type == BT_CLASS) { @@ -6950,7 +6956,7 @@ resolve_deallocate_expr (gfc_expr *e) attr = gfc_expr_attr (e); - if (allocatable == 0 && attr.pointer == 0) + if (allocatable == 0 && attr.pointer == 0 && !unlimited) { bad: gfc_error ("Allocate-object at %L must be ALLOCATABLE or a POINTER", @@ -7118,6 +7124,7 @@ resolve_allocate_expr (gfc_expr *e, gfc_code *code) int i, pointer, allocatable, dimension, is_abstract; int codimension; bool coindexed; + bool unlimited; symbol_attribute attr; gfc_ref *ref, *ref2; gfc_expr *e2; @@ -7149,6 +7156,9 @@ resolve_allocate_expr (gfc_expr *e, gfc_code *code) /* Check whether ultimate component is abstract and CLASS. */ is_abstract = 0; + /* Is the allocate-object unlimited polymorphic? */ + unlimited = UNLIMITED_POLY(e); + if (e->expr_type != EXPR_VARIABLE) { allocatable = 0; @@ -7235,7 +7245,7 @@ resolve_allocate_expr (gfc_expr *e, gfc_code *code) } /* Check for F08:C628. */ - if (allocatable == 0 && pointer == 0) + if (allocatable == 0 && pointer == 0 && !unlimited) { gfc_error ("Allocate-object at %L must be ALLOCATABLE or a POINTER", &e->where); @@ -7254,12 +7264,12 @@ resolve_allocate_expr (gfc_expr *e, gfc_code *code) } /* Check F03:C632 and restriction following Note 6.18. */ - if (code->expr3->rank > 0 + if (code->expr3->rank > 0 && !unlimited && conformable_arrays (code->expr3, e) == FAILURE) goto failure; /* Check F03:C633. */ - if (code->expr3->ts.kind != e->ts.kind) + if (code->expr3->ts.kind != e->ts.kind && !unlimited) { gfc_error ("The allocate-object at %L and the source-expr at %L " "shall have the same kind type parameter", @@ -7362,7 +7372,7 @@ resolve_allocate_expr (gfc_expr *e, gfc_code *code) code->expr3 = rhs; } - if (e->ts.type == BT_CLASS) + if (e->ts.type == BT_CLASS && !unlimited && !UNLIMITED_POLY (code->expr3)) { /* Make sure the vtab symbol is present when the module variables are generated. */ @@ -7371,7 +7381,29 @@ resolve_allocate_expr (gfc_expr *e, gfc_code *code) ts = code->expr3->ts; else if (code->ext.alloc.ts.type == BT_DERIVED) ts = code->ext.alloc.ts; + gfc_find_derived_vtab (ts.u.derived); + + if (dimension) + e = gfc_expr_to_initialize (e); + } + else if (unlimited && !UNLIMITED_POLY (code->expr3)) + { + /* Again, make sure the vtab symbol is present when + the module variables are generated. */ + gfc_typespec *ts = NULL; + if (code->expr3) + ts = &code->expr3->ts; + else + ts = &code->ext.alloc.ts; + + gcc_assert (ts); + + if (ts->type == BT_CLASS || ts->type == BT_DERIVED) + gfc_find_derived_vtab (ts->u.derived); + else + gfc_find_intrinsic_vtab (ts); + if (dimension) e = gfc_expr_to_initialize (e); } @@ -8206,7 +8238,9 @@ resolve_select (gfc_code *code) bool gfc_type_is_extensible (gfc_symbol *sym) { - return !(sym->attr.is_bind_c || sym->attr.sequence); + return !(sym->attr.is_bind_c || sym->attr.sequence + || (sym->attr.is_class + && sym->components->ts.u.derived->attr.unlimited_polymorphic)); } @@ -8312,6 +8346,7 @@ resolve_select_type (gfc_code *code, gfc_namespace *old_ns) char name[GFC_MAX_SYMBOL_LEN]; gfc_namespace *ns; int error = 0; + int charlen = 0; ns = code->ext.block.ns; gfc_resolve (ns); @@ -8344,6 +8379,7 @@ resolve_select_type (gfc_code *code, gfc_namespace *old_ns) /* Check F03:C815. */ if ((c->ts.type == BT_DERIVED || c->ts.type == BT_CLASS) + && !selector_type->attr.unlimited_polymorphic && !gfc_type_is_extensible (c->ts.u.derived)) { gfc_error ("Derived type '%s' at %L must be extensible", @@ -8354,6 +8390,7 @@ resolve_select_type (gfc_code *code, gfc_namespace *old_ns) /* Check F03:C816. */ if ((c->ts.type == BT_DERIVED || c->ts.type == BT_CLASS) + && !selector_type->attr.unlimited_polymorphic && !gfc_type_is_extension_of (selector_type, c->ts.u.derived)) { gfc_error ("Derived type '%s' at %L must be an extension of '%s'", @@ -8362,6 +8399,15 @@ resolve_select_type (gfc_code *code, gfc_namespace *old_ns) continue; } + /* Check F03:C814. */ + if (c->ts.type == BT_CHARACTER && c->ts.u.cl->length != NULL) + { + gfc_error ("The type-spec at %L shall specify that each length " + "type parameter is assumed", &c->where); + error++; + continue; + } + /* Intercept the DEFAULT case. */ if (c->ts.type == BT_UNKNOWN) { @@ -8420,6 +8466,7 @@ resolve_select_type (gfc_code *code, gfc_namespace *old_ns) ns->code->next = new_st; code = new_st; code->op = EXEC_SELECT; + gfc_add_vptr_component (code->expr1); gfc_add_hash_component (code->expr1); @@ -8431,6 +8478,16 @@ resolve_select_type (gfc_code *code, gfc_namespace *old_ns) if (c->ts.type == BT_DERIVED) c->low = c->high = gfc_get_int_expr (gfc_default_integer_kind, NULL, c->ts.u.derived->hash_value); + else if (c->ts.type != BT_CLASS && c->ts.type != BT_UNKNOWN) + { + gfc_symbol *ivtab; + gfc_expr *e; + + ivtab = gfc_find_intrinsic_vtab (&c->ts); + gcc_assert (ivtab); + e = CLASS_DATA (ivtab)->initializer; + c->low = c->high = gfc_copy_expr (e); + } else if (c->ts.type == BT_UNKNOWN) continue; @@ -8442,13 +8499,25 @@ resolve_select_type (gfc_code *code, gfc_namespace *old_ns) if (c->ts.type == BT_CLASS) sprintf (name, "__tmp_class_%s", c->ts.u.derived->name); - else + else if (c->ts.type == BT_DERIVED) sprintf (name, "__tmp_type_%s", c->ts.u.derived->name); + else if (c->ts.type == BT_CHARACTER) + { + if (c->ts.u.cl && c->ts.u.cl->length + && c->ts.u.cl->length->expr_type == EXPR_CONSTANT) + charlen = mpz_get_si (c->ts.u.cl->length->value.integer); + sprintf (name, "__tmp_%s_%d_%d", gfc_basic_typename (c->ts.type), + charlen, c->ts.kind); + } + else + sprintf (name, "__tmp_%s_%d", gfc_basic_typename (c->ts.type), + c->ts.kind); + st = gfc_find_symtree (ns->sym_root, name); gcc_assert (st->n.sym->assoc); st->n.sym->assoc->target = gfc_get_variable_expr (code->expr1->symtree); st->n.sym->assoc->target->where = code->expr1->where; - if (c->ts.type == BT_DERIVED) + if (c->ts.type != BT_CLASS && c->ts.type != BT_UNKNOWN) gfc_add_data_component (st->n.sym->assoc->target); new_st = gfc_get_code (); @@ -11029,6 +11098,8 @@ resolve_fl_var_and_proc (gfc_symbol *sym, int mp_flag) { /* F03:C502. */ if (sym->attr.class_ok + && !sym->attr.select_type_temporary + && !UNLIMITED_POLY(sym) && !gfc_type_is_extensible (CLASS_DATA (sym)->ts.u.derived)) { gfc_error ("Type '%s' of CLASS variable '%s' at %L is not extensible", @@ -11167,7 +11238,7 @@ resolve_fl_variable (gfc_symbol *sym, int mp_flag) dummy arguments. */ e = sym->ts.u.cl->length; if (e == NULL && !sym->attr.dummy && !sym->attr.result - && !sym->ts.deferred) + && !sym->ts.deferred && !sym->attr.select_type_temporary) { gfc_error ("Entity with assumed character length at %L must be a " "dummy argument or a PARAMETER", &sym->declared_at); @@ -12412,6 +12483,9 @@ resolve_fl_derived0 (gfc_symbol *sym) gfc_symbol* super_type; gfc_component *c; + if (sym->attr.unlimited_polymorphic) + return SUCCESS; + super_type = gfc_get_derived_super_type (sym); /* F2008, C432. */ @@ -12764,7 +12838,8 @@ resolve_fl_derived0 (gfc_symbol *sym) if (c->ts.type == BT_CLASS && c->attr.class_ok && CLASS_DATA (c)->attr.class_pointer && CLASS_DATA (c)->ts.u.derived->components == NULL - && !CLASS_DATA (c)->ts.u.derived->attr.zero_comp) + && !CLASS_DATA (c)->ts.u.derived->attr.zero_comp + && !UNLIMITED_POLY (c)) { gfc_error ("The pointer component '%s' of '%s' at %L is a type " "that has not been declared", c->name, sym->name, @@ -12833,6 +12908,9 @@ resolve_fl_derived (gfc_symbol *sym) { gfc_symbol *gen_dt = NULL; + if (sym->attr.unlimited_polymorphic) + return SUCCESS; + if (!sym->attr.is_class) gfc_find_symbol (sym->name, sym->ns, 0, &gen_dt); if (gen_dt && gen_dt->generic && gen_dt->generic->next @@ -12859,7 +12937,11 @@ resolve_fl_derived (gfc_symbol *sym) /* Fix up incomplete CLASS symbols. */ gfc_component *data = gfc_find_component (sym, "_data", true, true); gfc_component *vptr = gfc_find_component (sym, "_vptr", true, true); - if (vptr->ts.u.derived == NULL) + + /* Nothing more to do for unlimited polymorphic entities. */ + if (data->ts.u.derived->attr.unlimited_polymorphic) + return SUCCESS; + else if (vptr->ts.u.derived == NULL) { gfc_symbol *vtab = gfc_find_derived_vtab (data->ts.u.derived); gcc_assert (vtab); @@ -13074,6 +13156,9 @@ resolve_symbol (gfc_symbol *sym) if (sym->attr.artificial) return; + if (sym->attr.unlimited_polymorphic) + return; + if (sym->attr.flavor == FL_UNKNOWN || (sym->attr.flavor == FL_PROCEDURE && !sym->attr.intrinsic && !sym->attr.generic && !sym->attr.external diff --git a/gcc/fortran/simplify.c b/gcc/fortran/simplify.c index 2f96e900bf1..eb3e8c3cfbb 100644 --- a/gcc/fortran/simplify.c +++ b/gcc/fortran/simplify.c @@ -1,6 +1,6 @@ /* Simplify intrinsic functions at compile-time. - Copyright (C) 2000, 2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009, - 2010, 2011 Free Software Foundation, Inc. + Copyright (C) 2000, 2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008, + 2009, 2010, 2011, 2012 Free Software Foundation, Inc. Contributed by Andy Vaught & Katherine Holcomb This file is part of GCC. @@ -82,7 +82,7 @@ range_check (gfc_expr *result, const char *name) { case ARITH_OK: return result; - + case ARITH_OVERFLOW: gfc_error ("Result of %s overflows its kind at %L", name, &result->where); @@ -380,7 +380,7 @@ compute_dot_product (gfc_expr *matrix_a, int stride_a, int offset_a, } -/* Build a result expression for transformational intrinsics, +/* Build a result expression for transformational intrinsics, depending on DIM. */ static gfc_expr * @@ -491,7 +491,7 @@ simplify_transformation_to_scalar (gfc_expr *result, gfc_expr *array, gfc_expr * REAL, PARAMETER :: array(n, m) = ... REAL, PARAMETER :: s(n) = PROD(array, DIM=1) - where OP == gfc_multiply(). The result might be post processed using post_op. */ + where OP == gfc_multiply(). The result might be post processed using post_op. */ static gfc_expr * simplify_transformation_to_array (gfc_expr *result, gfc_expr *array, gfc_expr *dim, @@ -1314,7 +1314,7 @@ gfc_simplify_bessel_n2 (gfc_expr *order1, gfc_expr *order2, gfc_expr *x, mpfr_clear (last1); return result; } - + /* Get second recursion anchor. */ mpfr_init (last2); @@ -1335,7 +1335,7 @@ gfc_simplify_bessel_n2 (gfc_expr *order1, gfc_expr *order2, gfc_expr *x, } if (jn) gfc_constructor_insert_expr (&result->value.constructor, e, &x->where, -2); - else + else gfc_constructor_append_expr (&result->value.constructor, e, &x->where); if (n1 + 1 == n2) @@ -1349,7 +1349,7 @@ gfc_simplify_bessel_n2 (gfc_expr *order1, gfc_expr *order2, gfc_expr *x, mpfr_init (x2rev); mpfr_ui_div (x2rev, 2, x->value.real, GFC_RND_MODE); - + for (i = 2; i <= n2-n1; i++) { e = gfc_get_constant_expr (x->ts.type, x->ts.kind, &x->where); @@ -1743,7 +1743,7 @@ gfc_simplify_cosh (gfc_expr *x) case BT_COMPLEX: mpc_cosh (result->value.complex, x->value.complex, GFC_MPC_RND_MODE); break; - + default: gcc_unreachable (); } @@ -2251,6 +2251,10 @@ gfc_simplify_extends_type_of (gfc_expr *a, gfc_expr *mold) return gfc_get_logical_expr (gfc_default_logical_kind, &a->where, gfc_type_is_extension_of (mold->ts.u.derived, a->ts.u.derived)); + + if (UNLIMITED_POLY (a) || UNLIMITED_POLY (mold)) + return NULL; + /* Return .false. if the dynamic type can never be the same. */ if ((a->ts.type == BT_CLASS && mold->ts.type == BT_CLASS && !gfc_type_is_extension_of @@ -2676,7 +2680,7 @@ gfc_simplify_index (gfc_expr *x, gfc_expr *y, gfc_expr *b, gfc_expr *kind) int back, len, lensub; int i, j, k, count, index = 0, start; - if (x->expr_type != EXPR_CONSTANT || y->expr_type != EXPR_CONSTANT + if (x->expr_type != EXPR_CONSTANT || y->expr_type != EXPR_CONSTANT || ( b != NULL && b->expr_type != EXPR_CONSTANT)) return NULL; @@ -2685,7 +2689,7 @@ gfc_simplify_index (gfc_expr *x, gfc_expr *y, gfc_expr *b, gfc_expr *kind) else back = 0; - k = get_kind (BT_INTEGER, kind, "INDEX", gfc_default_integer_kind); + k = get_kind (BT_INTEGER, kind, "INDEX", gfc_default_integer_kind); if (k == -1) return &gfc_bad_expr; @@ -3229,7 +3233,7 @@ simplify_bound_dim (gfc_expr *array, gfc_expr *kind, int d, int upper, int k; k = get_kind (BT_INTEGER, kind, upper ? "UBOUND" : "LBOUND", - gfc_default_integer_kind); + gfc_default_integer_kind); if (k == -1) return &gfc_bad_expr; @@ -3558,7 +3562,7 @@ simplify_cobound (gfc_expr *array, gfc_expr *dim, gfc_expr *kind, int upper) e->expr_type = EXPR_ARRAY; e->ts.type = BT_INTEGER; k = get_kind (BT_INTEGER, kind, upper ? "UCOBOUND" : "LCOBOUND", - gfc_default_integer_kind); + gfc_default_integer_kind); if (k == -1) { gfc_free_expr (e); @@ -3912,7 +3916,7 @@ gfc_simplify_maskr (gfc_expr *i, gfc_expr *kind_arg) if (i->expr_type != EXPR_CONSTANT) return NULL; - + kind = get_kind (BT_INTEGER, kind_arg, "MASKR", gfc_default_integer_kind); if (kind == -1) return &gfc_bad_expr; @@ -3944,7 +3948,7 @@ gfc_simplify_maskl (gfc_expr *i, gfc_expr *kind_arg) if (i->expr_type != EXPR_CONSTANT) return NULL; - + kind = get_kind (BT_INTEGER, kind_arg, "MASKL", gfc_default_integer_kind); if (kind == -1) return &gfc_bad_expr; @@ -4066,7 +4070,7 @@ min_max_choose (gfc_expr *arg, gfc_expr *extremum, int sign) #undef LENGTH #undef STRING break; - + default: gfc_internal_error ("simplify_min_max(): Bad type in arglist"); } @@ -4119,14 +4123,14 @@ simplify_min_max (gfc_expr *expr, int sign) return NULL; /* Convert to the correct type and kind. */ - if (expr->ts.type != BT_UNKNOWN) + if (expr->ts.type != BT_UNKNOWN) return gfc_convert_constant (expr->value.function.actual->expr, expr->ts.type, expr->ts.kind); - if (specific->ts.type != BT_UNKNOWN) + if (specific->ts.type != BT_UNKNOWN) return gfc_convert_constant (expr->value.function.actual->expr, - specific->ts.type, specific->ts.kind); - + specific->ts.type, specific->ts.kind); + return gfc_copy_expr (expr->value.function.actual->expr); } @@ -4176,14 +4180,14 @@ simplify_minval_maxval (gfc_expr *expr, int sign) return NULL; /* Convert to the correct type and kind. */ - if (expr->ts.type != BT_UNKNOWN) + if (expr->ts.type != BT_UNKNOWN) return gfc_convert_constant (extremum->expr, expr->ts.type, expr->ts.kind); - if (specific->ts.type != BT_UNKNOWN) + if (specific->ts.type != BT_UNKNOWN) return gfc_convert_constant (extremum->expr, - specific->ts.type, specific->ts.kind); - + specific->ts.type, specific->ts.kind); + return gfc_copy_expr (extremum->expr); } @@ -4261,7 +4265,7 @@ gfc_simplify_mod (gfc_expr *a, gfc_expr *p) } gfc_set_model_kind (kind); - mpfr_fmod (result->value.real, a->value.real, p->value.real, + mpfr_fmod (result->value.real, a->value.real, p->value.real, GFC_RND_MODE); break; @@ -4310,7 +4314,7 @@ gfc_simplify_modulo (gfc_expr *a, gfc_expr *p) } gfc_set_model_kind (kind); - mpfr_fmod (result->value.real, a->value.real, p->value.real, + mpfr_fmod (result->value.real, a->value.real, p->value.real, GFC_RND_MODE); if (mpfr_cmp_ui (result->value.real, 0) != 0) { @@ -4319,7 +4323,7 @@ gfc_simplify_modulo (gfc_expr *a, gfc_expr *p) GFC_RND_MODE); } else - mpfr_copysign (result->value.real, result->value.real, + mpfr_copysign (result->value.real, result->value.real, p->value.real, GFC_RND_MODE); break; @@ -4621,7 +4625,7 @@ gfc_simplify_pack (gfc_expr *array, gfc_expr *mask, gfc_expr *vector) } else if (mask->expr_type == EXPR_ARRAY) { - /* Copy only those elements of ARRAY to RESULT whose + /* Copy only those elements of ARRAY to RESULT whose MASK equals .TRUE.. */ mask_ctor = gfc_constructor_first (mask->value.constructor); while (mask_ctor) @@ -4921,8 +4925,8 @@ gfc_simplify_repeat (gfc_expr *e, gfc_expr *n) if (e->expr_type != EXPR_CONSTANT) return NULL; - if (len || - (e->ts.u.cl->length && + if (len || + (e->ts.u.cl->length && mpz_sgn (e->ts.u.cl->length->value.integer)) != 0) { const char *res = gfc_extract_int (n, &ncop); @@ -5740,7 +5744,7 @@ gfc_simplify_spacing (gfc_expr *x) } /* In the Fortran 95 standard, the result is b**(e - p) where b, e, and p - are the radix, exponent of x, and precision. This excludes the + are the radix, exponent of x, and precision. This excludes the possibility of subnormal numbers. Fortran 2003 states the result is b**max(e - p, emin - 1). */ @@ -6025,11 +6029,11 @@ gfc_simplify_transfer (gfc_expr *source, gfc_expr *mold, gfc_expr *size) : mold; /* Set result character length, if needed. Note that this needs to be - set even for array expressions, in order to pass this information into + set even for array expressions, in order to pass this information into gfc_target_interpret_expr. */ if (result->ts.type == BT_CHARACTER && gfc_is_constant_expr (mold_element)) result->value.character.length = mold_element->value.character.length; - + /* Set the number of elements in the result, and determine its size. */ if (mold->expr_type == EXPR_ARRAY || mold->rank || size) @@ -6087,7 +6091,7 @@ gfc_simplify_transpose (gfc_expr *matrix) { gfc_expr *e = gfc_constructor_lookup_expr (matrix->value.constructor, col * matrix_rows + row); - gfc_constructor_insert_expr (&result->value.constructor, + gfc_constructor_insert_expr (&result->value.constructor, gfc_copy_expr (e), &matrix->where, row * matrix_cols + col); } diff --git a/gcc/fortran/symbol.c b/gcc/fortran/symbol.c index c914e65cac2..dbd51329350 100644 --- a/gcc/fortran/symbol.c +++ b/gcc/fortran/symbol.c @@ -1955,6 +1955,9 @@ gfc_use_derived (gfc_symbol *sym) if (!sym) return NULL; + if (sym->attr.unlimited_polymorphic) + return sym; + if (sym->attr.generic) sym = gfc_find_dt_in_generic (sym); @@ -4905,6 +4908,11 @@ gfc_type_compatible (gfc_typespec *ts1, gfc_typespec *ts2) bool is_derived1 = (ts1->type == BT_DERIVED); bool is_derived2 = (ts2->type == BT_DERIVED); + if (is_class1 + && ts1->u.derived->components + && ts1->u.derived->components->ts.u.derived->attr.unlimited_polymorphic) + return 1; + if (!is_derived1 && !is_derived2 && !is_class1 && !is_class2) return (ts1->type == ts2->type); diff --git a/gcc/fortran/trans-decl.c b/gcc/fortran/trans-decl.c index 588f55a02df..88f9c562996 100644 --- a/gcc/fortran/trans-decl.c +++ b/gcc/fortran/trans-decl.c @@ -327,7 +327,7 @@ gfc_sym_mangled_identifier (gfc_symbol * sym) binding label (mainly those that are bind(c)). */ if (sym->attr.is_bind_c == 1 && sym->binding_label) return get_identifier (sym->binding_label); - + if (sym->module == NULL) return gfc_sym_identifier (sym); else @@ -433,14 +433,14 @@ gfc_finish_cray_pointee (tree decl, gfc_symbol *sym) tree value; /* Parameters need to be dereferenced. */ - if (sym->cp_pointer->attr.dummy) + if (sym->cp_pointer->attr.dummy) ptr_decl = build_fold_indirect_ref_loc (input_location, ptr_decl); /* Check to see if we're dealing with a variable-sized array. */ if (sym->attr.dimension - && TREE_CODE (TREE_TYPE (decl)) == POINTER_TYPE) - { + && TREE_CODE (TREE_TYPE (decl)) == POINTER_TYPE) + { /* These decls will be dereferenced later, so we don't dereference them here. */ value = convert (TREE_TYPE (decl), ptr_decl); @@ -483,7 +483,7 @@ gfc_finish_decl (tree decl) /* We should know the storage size. */ gcc_assert (DECL_SIZE (decl) != NULL_TREE - || (TREE_STATIC (decl) + || (TREE_STATIC (decl) ? (!DECL_INITIAL (decl) || !DECL_CONTEXT (decl)) : DECL_EXTERNAL (decl))); @@ -550,7 +550,7 @@ gfc_finish_var_decl (tree decl, gfc_symbol * sym) TREE_PUBLIC(decl) = 1; DECL_COMMON(decl) = 1; } - + /* If a variable is USE associated, it's always external. */ if (sym->attr.use_assoc) { @@ -592,7 +592,7 @@ gfc_finish_var_decl (tree decl, gfc_symbol * sym) TREE_SIDE_EFFECTS (decl) = 1; new_type = build_qualified_type (TREE_TYPE (decl), TYPE_QUAL_VOLATILE); TREE_TYPE (decl) = new_type; - } + } /* Keep variables larger than max-stack-var-size off stack. */ if (!sym->ns->proc_name->attr.recursive @@ -948,7 +948,7 @@ gfc_build_dummy_array_decl (gfc_symbol * sym, tree dummy) /* Do we know the element size? */ known_size = sym->ts.type != BT_CHARACTER || INTEGER_CST_P (sym->ts.u.cl->backend_decl); - + if (known_size && !GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (type))) { /* For descriptorless arrays with known element size the actual @@ -1558,7 +1558,7 @@ get_proc_pointer_decl (gfc_symbol *sym) if (sym->attr.use_assoc) DECL_IGNORED_P (decl) = 1; } - + if ((sym->ns->proc_name && sym->ns->proc_name->backend_decl == current_function_decl) || sym->attr.contained) @@ -1984,7 +1984,7 @@ create_function_arglist (gfc_symbol * sym) type = TREE_VALUE (typelist); parm = build_decl (input_location, PARM_DECL, get_identifier ("__entry"), type); - + DECL_CONTEXT (parm) = fndecl; DECL_ARG_TYPE (parm) = type; TREE_READONLY (parm) = 1; @@ -2106,7 +2106,7 @@ create_function_arglist (gfc_symbol * sym) gfc_finish_decl (length); /* Remember the passed value. */ - if (f->sym->ts.u.cl->passed_length != NULL) + if (!f->sym->ts.u.cl || f->sym->ts.u.cl->passed_length) { /* This can happen if the same type is used for multiple arguments. We need to copy cl as otherwise @@ -2215,7 +2215,7 @@ create_function_arglist (gfc_symbol * sym) gcc_assert (GFC_TYPE_ARRAY_CAF_TOKEN (caf_type) == NULL_TREE); GFC_TYPE_ARRAY_CAF_TOKEN (caf_type) = token; } - + DECL_CONTEXT (token) = fndecl; DECL_ARTIFICIAL (token) = 1; DECL_ARG_TYPE (token) = TREE_VALUE (typelist); @@ -2314,7 +2314,7 @@ build_entry_thunks (gfc_namespace * ns, bool global) vec<tree, va_gc> *string_args = NULL; thunk_sym = el->sym; - + build_function_decl (thunk_sym, global); create_function_arglist (thunk_sym); @@ -2411,7 +2411,7 @@ build_entry_thunks (gfc_namespace * ns, bool global) tmp = fold_build3_loc (input_location, COMPONENT_REF, TREE_TYPE (field), union_decl, field, NULL_TREE); - tmp = fold_build2_loc (input_location, MODIFY_EXPR, + tmp = fold_build2_loc (input_location, MODIFY_EXPR, TREE_TYPE (DECL_RESULT (current_function_decl)), DECL_RESULT (current_function_decl), tmp); tmp = build1_v (RETURN_EXPR, tmp); @@ -2985,7 +2985,7 @@ gfc_build_intrinsic_function_decls (void) gfc_int4_type_node); TREE_READONLY (gfor_fndecl_math_ishftc4) = 1; TREE_NOTHROW (gfor_fndecl_math_ishftc4) = 1; - + gfor_fndecl_math_ishftc8 = gfc_build_library_function_decl ( get_identifier (PREFIX("ishftc8")), gfc_int8_type_node, 3, gfc_int8_type_node, gfc_int4_type_node, @@ -3121,7 +3121,7 @@ gfc_build_builtin_function_decls (void) void_type_node, -2, pchar_type_node, pchar_type_node); /* The runtime_error_at function does not return. */ TREE_THIS_VOLATILE (gfor_fndecl_runtime_error_at) = 1; - + gfor_fndecl_runtime_warning_at = gfc_build_library_function_decl_with_spec ( get_identifier (PREFIX("runtime_warning_at")), ".RR", void_type_node, -2, pchar_type_node, pchar_type_node); @@ -3816,7 +3816,7 @@ gfc_trans_deferred_vars (gfc_symbol * proc_sym, gfc_wrapped_block * block) if (sym->ts.type == BT_CLASS) { /* Initialize _vptr to declared type. */ - gfc_symbol *vtab = gfc_find_derived_vtab (sym->ts.u.derived); + gfc_symbol *vtab; tree rhs; gfc_save_backend_locus (&loc); @@ -3827,8 +3827,14 @@ gfc_trans_deferred_vars (gfc_symbol * proc_sym, gfc_wrapped_block * block) se.want_pointer = 1; gfc_conv_expr (&se, e); gfc_free_expr (e); - rhs = gfc_build_addr_expr (TREE_TYPE (se.expr), - gfc_get_symbol_decl (vtab)); + if (UNLIMITED_POLY (sym)) + rhs = build_int_cst (TREE_TYPE (se.expr), 0); + else + { + vtab = gfc_find_derived_vtab (sym->ts.u.derived); + rhs = gfc_build_addr_expr (TREE_TYPE (se.expr), + gfc_get_symbol_decl (vtab)); + } gfc_add_modify (&init, se.expr, rhs); gfc_restore_backend_locus (&loc); } @@ -3894,7 +3900,7 @@ gfc_trans_deferred_vars (gfc_symbol * proc_sym, gfc_wrapped_block * block) gfc_add_init_cleanup (block, gfc_finish_block (&tmpblock), NULL_TREE); } - else + else if (!(UNLIMITED_POLY(sym))) gcc_unreachable (); } @@ -4347,7 +4353,7 @@ generate_coarray_sym_init (gfc_symbol *sym) tree tmp, size, decl, token; if (sym->attr.dummy || sym->attr.allocatable || !sym->attr.codimension - || sym->attr.use_assoc || !sym->attr.referenced) + || sym->attr.use_assoc || !sym->attr.referenced) return; decl = sym->backend_decl; @@ -4360,7 +4366,7 @@ generate_coarray_sym_init (gfc_symbol *sym) size = TYPE_SIZE_UNIT (gfc_get_element_type (TREE_TYPE (decl))); - /* Ensure that we do not have size=0 for zero-sized arrays. */ + /* Ensure that we do not have size=0 for zero-sized arrays. */ size = fold_build2_loc (input_location, MAX_EXPR, size_type_node, fold_convert (size_type_node, size), build_int_cst (size_type_node, 1)); @@ -4382,7 +4388,7 @@ generate_coarray_sym_init (gfc_symbol *sym) token, null_pointer_node, /* token, stat. */ null_pointer_node, /* errgmsg, errmsg_len. */ build_int_cst (integer_type_node, 0)); - + gfc_add_modify (&caf_init_block, decl, fold_convert (TREE_TYPE (decl), tmp)); @@ -4724,7 +4730,7 @@ generate_local_decl (gfc_symbol * sym) { if (gfc_option.warn_unused_dummy_argument) gfc_warning ("Unused dummy argument '%s' at %L", sym->name, - &sym->declared_at); + &sym->declared_at); } /* Silence bogus "unused parameter" warnings from the @@ -5151,9 +5157,9 @@ create_main_function (tree fndecl) /* Coarray: Call _gfortran_caf_finalize(void). */ if (gfc_option.coarray == GFC_FCOARRAY_LIB) - { + { /* Per F2008, 8.5.1 END of the main program implies a - SYNC MEMORY. */ + SYNC MEMORY. */ tmp = builtin_decl_explicit (BUILT_IN_SYNC_SYNCHRONIZE); tmp = build_call_expr_loc (input_location, tmp, 0); gfc_add_expr_to_block (&body, tmp); diff --git a/gcc/fortran/trans-expr.c b/gcc/fortran/trans-expr.c index 42f6e0cdea5..ad266845ae7 100644 --- a/gcc/fortran/trans-expr.c +++ b/gcc/fortran/trans-expr.c @@ -64,7 +64,7 @@ get_scalar_to_descriptor_type (tree scalar, symbol_attribute attr) static tree conv_scalar_to_descriptor (gfc_se *se, tree scalar, symbol_attribute attr) { - tree desc, type; + tree desc, type; type = get_scalar_to_descriptor_type (scalar, attr); desc = gfc_create_var (type, "desc"); @@ -456,9 +456,68 @@ class_scalar_coarray_to_class (gfc_se *parmse, gfc_expr *e, } +/* Takes an intrinsic type expression and returns the address of a temporary + class object of the 'declared' type. */ +void +gfc_conv_intrinsic_to_class (gfc_se *parmse, gfc_expr *e, + gfc_typespec class_ts) +{ + gfc_symbol *vtab; + gfc_ss *ss; + tree ctree; + tree var; + tree tmp; + + /* The intrinsic type needs to be converted to a temporary + CLASS object. */ + tmp = gfc_typenode_for_spec (&class_ts); + var = gfc_create_var (tmp, "class"); + + /* Set the vptr. */ + ctree = gfc_class_vptr_get (var); + + vtab = gfc_find_intrinsic_vtab (&e->ts); + gcc_assert (vtab); + tmp = gfc_build_addr_expr (NULL_TREE, gfc_get_symbol_decl (vtab)); + gfc_add_modify (&parmse->pre, ctree, + fold_convert (TREE_TYPE (ctree), tmp)); + + /* Now set the data field. */ + ctree = gfc_class_data_get (var); + if (parmse->ss && parmse->ss->info->useflags) + { + /* For an array reference in an elemental procedure call we need + to retain the ss to provide the scalarized array reference. */ + gfc_conv_expr_reference (parmse, e); + tmp = fold_convert (TREE_TYPE (ctree), parmse->expr); + gfc_add_modify (&parmse->pre, ctree, tmp); + } + else + { + ss = gfc_walk_expr (e); + if (ss == gfc_ss_terminator) + { + parmse->ss = NULL; + gfc_conv_expr_reference (parmse, e); + tmp = fold_convert (TREE_TYPE (ctree), parmse->expr); + gfc_add_modify (&parmse->pre, ctree, tmp); + } + else + { + parmse->ss = ss; + gfc_conv_expr_descriptor (parmse, e); + gfc_add_modify (&parmse->pre, ctree, parmse->expr); + } + } + + /* Pass the address of the class object. */ + parmse->expr = gfc_build_addr_expr (NULL_TREE, var); +} + + /* Takes a scalarized class array expression and returns the address of a temporary scalar class object of the 'declared' - type. + type. OOP-TODO: This could be improved by adding code that branched on the dynamic type being the same as the declared type. In this case the original class expression can be passed directly. @@ -567,7 +626,7 @@ gfc_conv_class_to_class (gfc_se *parmse, gfc_expr *e, gfc_typespec class_ts, tmp = NULL_TREE; if (class_ref == NULL - && e->symtree && e->symtree->n.sym->ts.type == BT_CLASS) + && e->symtree && e->symtree->n.sym->ts.type == BT_CLASS) tmp = e->symtree->n.sym->backend_decl; else { @@ -813,6 +872,8 @@ gfc_trans_class_init_assign (gfc_code *code) gfc_conv_expr (&src, rhs); gfc_conv_expr (&memsz, sz); gfc_add_block_to_block (&block, &src.pre); + src.expr = gfc_build_addr_expr (NULL_TREE, src.expr); + tmp = gfc_build_memcpy_call (dst.expr, src.expr, memsz.expr); } @@ -826,7 +887,7 @@ gfc_trans_class_init_assign (gfc_code *code) } gfc_add_expr_to_block (&block, tmp); - + return gfc_finish_block (&block); } @@ -867,10 +928,19 @@ gfc_trans_class_assign (gfc_expr *expr1, gfc_expr *expr2, gfc_exec_op op) lhs = gfc_copy_expr (expr1); gfc_add_vptr_component (lhs); + if (UNLIMITED_POLY (expr1) + && expr2->expr_type == EXPR_NULL && expr2->ts.type == BT_UNKNOWN) + { + rhs = gfc_get_null_expr (&expr2->where); + goto assign_vptr; + } + if (expr2->ts.type == BT_DERIVED) vtab = gfc_find_derived_vtab (expr2->ts.u.derived); else if (expr2->expr_type == EXPR_NULL) vtab = gfc_find_derived_vtab (expr1->ts.u.derived); + else + vtab = gfc_find_intrinsic_vtab (&expr2->ts); gcc_assert (vtab); rhs = gfc_get_expr (); @@ -878,13 +948,21 @@ gfc_trans_class_assign (gfc_expr *expr1, gfc_expr *expr2, gfc_exec_op op) gfc_find_sym_tree (vtab->name, vtab->ns, 1, &st); rhs->symtree = st; rhs->ts = vtab->ts; - +assign_vptr: tmp = gfc_trans_pointer_assignment (lhs, rhs); gfc_add_expr_to_block (&block, tmp); gfc_free_expr (lhs); gfc_free_expr (rhs); } + else if (expr1->ts.type == BT_DERIVED && UNLIMITED_POLY (expr2)) + { + /* F2003:C717 only sequence and bind-C types can come here. */ + gcc_assert (expr1->ts.u.derived->attr.sequence + || expr1->ts.u.derived->attr.is_bind_c); + gfc_add_data_component (expr2); + goto assign; + } else if (CLASS_DATA (expr2)->attr.dimension) { /* Insert an additional assignment which sets the '_vptr' field. */ @@ -1110,7 +1188,7 @@ gfc_conv_missing_dummy (gfc_se * se, gfc_expr * arg, gfc_typespec ts, int kind) tmp = gfc_get_int_type (kind); tmp = fold_convert (tmp, build_fold_indirect_ref_loc (input_location, se->expr)); - + /* Test for a NULL value. */ tmp = build3_loc (input_location, COND_EXPR, TREE_TYPE (tmp), present, tmp, fold_convert (TREE_TYPE (tmp), integer_one_node)); @@ -1147,9 +1225,9 @@ gfc_get_expr_charlen (gfc_expr *e) gfc_ref *r; tree length; - gcc_assert (e->expr_type == EXPR_VARIABLE + gcc_assert (e->expr_type == EXPR_VARIABLE && e->ts.type == BT_CHARACTER); - + length = NULL; /* To silence compiler warning. */ if (is_subref_array (e) && e->ts.u.cl->length) @@ -1238,8 +1316,8 @@ flatten_array_ctors_without_strlen (gfc_expr* e) { case EXPR_OP: - flatten_array_ctors_without_strlen (e->value.op.op1); - flatten_array_ctors_without_strlen (e->value.op.op2); + flatten_array_ctors_without_strlen (e->value.op.op1); + flatten_array_ctors_without_strlen (e->value.op.op2); break; case EXPR_COMPCALL: @@ -1604,7 +1682,7 @@ gfc_conv_variable (gfc_se * se, gfc_expr * expr) se_expr = gfc_get_fake_result_decl (sym, parent_flag); /* Similarly for alternate entry points. */ - else if (alternate_entry + else if (alternate_entry && (sym->ns->proc_name->backend_decl == current_function_decl || parent_flag)) { @@ -1640,7 +1718,7 @@ gfc_conv_variable (gfc_se * se, gfc_expr * expr) /* Dereference the expression, where needed. Since characters - are entirely different from other types, they are treated + are entirely different from other types, they are treated separately. */ if (sym->ts.type == BT_CHARACTER) { @@ -1670,7 +1748,7 @@ gfc_conv_variable (gfc_se * se, gfc_expr * expr) se->expr = build_fold_indirect_ref_loc (input_location, se->expr); - /* Dereference non-character pointer variables. + /* Dereference non-character pointer variables. These must be dummies, results, or scalars. */ if ((sym->attr.pointer || sym->attr.allocatable || gfc_is_associate_pointer (sym) @@ -1828,11 +1906,11 @@ static const unsigned char powi_table[POWI_TABLE_SIZE] = 124, 166, 125, 214, 126, 138, 127, 153, /* 248 - 255 */ }; -/* If n is larger than lookup table's max index, we use the "window +/* If n is larger than lookup table's max index, we use the "window method". */ #define POWI_WINDOW_SIZE 3 -/* Recursive function to expand the power operator. The temporary +/* Recursive function to expand the power operator. The temporary values are put in tmpvar. The function returns tmpvar[1] ** n. */ static tree gfc_conv_powi (gfc_se * se, unsigned HOST_WIDE_INT n, tree * tmpvar) @@ -1895,7 +1973,7 @@ gfc_conv_cst_int_power (gfc_se * se, tree lhs, tree rhs) /* There's no ABS for HOST_WIDE_INT, so here we go. It also takes care of the asymmetric range of the integer type. */ n = (unsigned HOST_WIDE_INT) (m < 0 ? -m : m); - + type = TREE_TYPE (lhs); sgn = tree_int_cst_sgn (rhs); @@ -2006,7 +2084,7 @@ gfc_conv_power_op (gfc_se * se, gfc_expr * expr) case 4: ikind = 0; break; - + case 8: ikind = 1; break; @@ -2034,7 +2112,7 @@ gfc_conv_power_op (gfc_se * se, gfc_expr * expr) case 4: kind = 0; break; - + case 8: kind = 1; break; @@ -2050,7 +2128,7 @@ gfc_conv_power_op (gfc_se * se, gfc_expr * expr) default: gcc_unreachable (); } - + switch (expr->value.op.op1->ts.type) { case BT_INTEGER: @@ -2068,7 +2146,7 @@ gfc_conv_power_op (gfc_se * se, gfc_expr * expr) case 0: fndecl = builtin_decl_explicit (BUILT_IN_POWIF); break; - + case 1: fndecl = builtin_decl_explicit (BUILT_IN_POWI); break; @@ -2078,7 +2156,7 @@ gfc_conv_power_op (gfc_se * se, gfc_expr * expr) break; case 3: - /* Use the __builtin_powil() only if real(kind=16) is + /* Use the __builtin_powil() only if real(kind=16) is actually the C long double type. */ if (!gfc_real16_is_float128) fndecl = builtin_decl_explicit (BUILT_IN_POWIL); @@ -2089,7 +2167,7 @@ gfc_conv_power_op (gfc_se * se, gfc_expr * expr) } } - /* If we don't have a good builtin for this, go for the + /* If we don't have a good builtin for this, go for the library function. */ if (!fndecl) fndecl = gfor_fndecl_math_powi[kind][ikind].real; @@ -2497,7 +2575,7 @@ gfc_conv_scalar_char_value (gfc_symbol *sym, gfc_se *se, gfc_expr **expr) (int)(*expr)->value.character.string[0]); if ((*expr)->ts.kind != gfc_c_int_kind) { - /* The expr needs to be compatible with a C int. If the + /* The expr needs to be compatible with a C int. If the conversion fails, then the 2 causes an ICE. */ ts.type = BT_INTEGER; ts.kind = gfc_c_int_kind; @@ -2937,8 +3015,8 @@ gfc_add_interface_mapping (gfc_interface_mapping * mapping, else if (!sym->attr.dimension || sym->attr.pointer || sym->attr.allocatable) value = build_fold_indirect_ref_loc (input_location, se->expr); - - /* For character(*), use the actual argument's descriptor. */ + + /* For character(*), use the actual argument's descriptor. */ else if (sym->ts.type == BT_CHARACTER && !new_sym->ts.u.cl->length) value = build_fold_indirect_ref_loc (input_location, se->expr); @@ -3347,7 +3425,7 @@ gfc_conv_subref_array_arg (gfc_se * parmse, gfc_expr * expr, int g77, rss = gfc_walk_expr (expr); gcc_assert (rss != gfc_ss_terminator); - + /* Initialize the scalarizer. */ gfc_init_loopinfo (&loop); gfc_add_ss_to_loop (&loop, rss); @@ -3507,7 +3585,7 @@ gfc_conv_subref_array_arg (gfc_se * parmse, gfc_expr * expr, int g77, tmp = gfc_trans_scalar_assign (&lse, &rse, expr->ts, false, false, true); gfc_add_expr_to_block (&body, tmp); - + /* Generate the copying loops. */ gfc_trans_scalarizing_loops (&loop2, &body); @@ -3534,7 +3612,7 @@ gfc_conv_subref_array_arg (gfc_se * parmse, gfc_expr * expr, int g77, if (formal_ptr) { size = gfc_index_one_node; - offset = gfc_index_zero_node; + offset = gfc_index_zero_node; for (n = 0; n < dimen; n++) { tmp = gfc_conv_descriptor_ubound_get (parmse->expr, @@ -3635,7 +3713,7 @@ conv_isocbinding_procedure (gfc_se * se, gfc_symbol * sym, && !(fsym->attr.pointer || fsym->attr.allocatable) && fsym->as->type != AS_ASSUMED_SHAPE; f = f || !sym->attr.always_explicit; - + gfc_conv_array_parameter (se, arg->expr, f, NULL, NULL, NULL); } @@ -3654,7 +3732,7 @@ conv_isocbinding_procedure (gfc_se * se, gfc_symbol * sym, arg->expr->ts.f90_type = sym->ts.u.derived->ts.f90_type; arg->expr->ts.kind = sym->ts.u.derived->ts.kind; gfc_conv_expr_reference (se, arg->expr); - + return 1; } else if (sym->intmod_sym_id == ISOCBINDING_F_POINTER @@ -3756,14 +3834,14 @@ conv_isocbinding_procedure (gfc_se * se, gfc_symbol * sym, gfc_array_index_type, stride, fold_convert (gfc_array_index_type, shapese.expr))); - /* Finish scalarization loop. */ + /* Finish scalarization loop. */ gfc_trans_scalarizing_loops (&loop, &body); gfc_add_block_to_block (&block, &loop.pre); gfc_add_block_to_block (&block, &loop.post); gfc_add_block_to_block (&block, &fptrse.post); gfc_cleanup_loop (&loop); - gfc_add_modify (&block, offset, + gfc_add_modify (&block, offset, fold_build1_loc (input_location, NEGATE_EXPR, gfc_array_index_type, offset)); gfc_conv_descriptor_offset_set (&block, desc, offset); @@ -3796,7 +3874,7 @@ conv_isocbinding_procedure (gfc_se * se, gfc_symbol * sym, { tree eq_expr; tree not_null_expr; - + /* Given two arguments so build the arg2se from second arg. */ gfc_init_se (&arg2se, NULL); gfc_conv_expr (&arg2se, arg->next->expr); @@ -3820,7 +3898,7 @@ conv_isocbinding_procedure (gfc_se * se, gfc_symbol * sym, return 1; } - + /* Nothing was done. */ return 0; } @@ -3994,6 +4072,13 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym, CLASS_DATA (fsym)->attr.class_pointer || CLASS_DATA (fsym)->attr.allocatable); } + else if (UNLIMITED_POLY (fsym) && e->ts.type != BT_CLASS) + { + /* The intrinsic type needs to be converted to a temporary + CLASS object for the unlimited polymorphic formal. */ + gfc_init_se (&parmse, se); + gfc_conv_intrinsic_to_class (&parmse, e, fsym->ts); + } else if (se->ss && se->ss->info->useflags) { gfc_ss *ss; @@ -4051,7 +4136,7 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym, = fold_build3_loc (input_location, COND_EXPR, TREE_TYPE (parmse.expr), gfc_unlikely (tmp), - fold_convert (TREE_TYPE (parmse.expr), + fold_convert (TREE_TYPE (parmse.expr), null_pointer_node), parmse.expr); } @@ -4192,7 +4277,7 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym, CLASS_DATA (fsym)->attr.class_pointer || CLASS_DATA (fsym)->attr.allocatable); - /* If an ALLOCATABLE dummy argument has INTENT(OUT) and is + /* If an ALLOCATABLE dummy argument has INTENT(OUT) and is allocated on entry, it must be deallocated. */ if (fsym && fsym->attr.intent == INTENT_OUT && (fsym->attr.allocatable @@ -4205,7 +4290,7 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym, gfc_init_block (&block); ptr = parmse.expr; if (e->ts.type == BT_CLASS) - ptr = gfc_class_data_get (ptr); + ptr = gfc_class_data_get (ptr); tmp = gfc_deallocate_with_status (ptr, NULL_TREE, NULL_TREE, NULL_TREE, @@ -4327,7 +4412,7 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym, /* If the argument is a function call that may not create a temporary for the result, we have to check that we - can do it, i.e. that there is no alias between this + can do it, i.e. that there is no alias between this argument and another one. */ if (gfc_get_noncopying_intrinsic_argument (e) != NULL) { @@ -4387,7 +4472,7 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym, else gfc_conv_array_parameter (&parmse, e, f, fsym, sym->name, NULL); - /* If an ALLOCATABLE dummy argument has INTENT(OUT) and is + /* If an ALLOCATABLE dummy argument has INTENT(OUT) and is allocated on entry, it must be deallocated. */ if (fsym && fsym->attr.allocatable && fsym->attr.intent == INTENT_OUT) @@ -4404,7 +4489,7 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym, tmp, build_empty_stmt (input_location)); gfc_add_expr_to_block (&se->pre, tmp); } - } + } } /* The case with fsym->attr.optional is that of a user subroutine @@ -4430,7 +4515,7 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym, && ((e->rank != 0 && sym->attr.elemental) || e->representation.length || e->ts.type == BT_CHARACTER || (e->rank != 0 - && (fsym == NULL + && (fsym == NULL || (fsym-> as && (fsym->as->type == AS_ASSUMED_SHAPE || fsym->as->type == AS_ASSUMED_RANK @@ -4600,7 +4685,7 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym, fold_convert (TREE_TYPE (tmp), null_pointer_node)); } - + gfc_trans_runtime_check (true, false, cond, &se->pre, &e->where, msg); free (msg); @@ -4618,8 +4703,21 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym, } /* Character strings are passed as two parameters, a length and a - pointer - except for Bind(c) which only passes the pointer. */ - if (parmse.string_length != NULL_TREE && !sym->attr.is_bind_c) + pointer - except for Bind(c) which only passes the pointer. + An unlimited polymorphic formal argument likewise does not + need the length. */ + if (parmse.string_length != NULL_TREE + && !sym->attr.is_bind_c + && !(fsym && UNLIMITED_POLY (fsym))) + vec_safe_push (stringargs, parmse.string_length); + + /* When calling __copy for character expressions to unlimited + polymorphic entities, the dst argument needs a string length. */ + if (sym->name[0] == '_' && e && e->ts.type == BT_CHARACTER + && strncmp (sym->name, "__vtab_CHARACTER", 16) == 0 + && arg->next && arg->next->expr + && arg->next->expr->ts.type == BT_DERIVED + && arg->next->expr->ts.u.derived->attr.unlimited_polymorphic) vec_safe_push (stringargs, parmse.string_length); /* For descriptorless coarrays and assumed-shape coarray dummies, we @@ -4656,7 +4754,7 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym, && GFC_TYPE_ARRAY_CAF_TOKEN (caf_type) != NULL_TREE); tmp = GFC_TYPE_ARRAY_CAF_TOKEN (caf_type); } - + vec_safe_push (stringargs, tmp); if (GFC_DESCRIPTOR_TYPE_P (caf_type) @@ -4752,7 +4850,7 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym, gfc_conv_expr (&parmse, ts.u.cl->length); gfc_add_block_to_block (&se->pre, &parmse.pre); gfc_add_block_to_block (&se->post, &parmse.post); - + tmp = fold_convert (gfc_charlen_type_node, parmse.expr); tmp = fold_build2_loc (input_location, MAX_EXPR, gfc_charlen_type_node, tmp, @@ -5490,7 +5588,7 @@ gfc_conv_array_constructor_expr (gfc_se * se, gfc_expr * expr) /* Build a static initializer. EXPR is the expression for the initial value. - The other parameters describe the variable of the component being + The other parameters describe the variable of the component being initialized. EXPR may be null. */ tree @@ -5521,7 +5619,7 @@ gfc_conv_initializer (gfc_expr * expr, gfc_typespec * ts, tree type, gcc_assert (TREE_CODE (se.expr) != CONSTRUCTOR); return se.expr; } - + if (array && !procptr) { tree ctor; @@ -5557,7 +5655,7 @@ gfc_conv_initializer (gfc_expr * expr, gfc_typespec * ts, tree type, case BT_CLASS: gfc_init_se (&se, NULL); if (ts->type == BT_CLASS && expr->expr_type == EXPR_NULL) - gfc_conv_structure (&se, gfc_class_null_initializer(ts), 1); + gfc_conv_structure (&se, gfc_class_null_initializer(ts, expr), 1); else gfc_conv_structure (&se, expr, 1); gcc_assert (TREE_CODE (se.expr) == CONSTRUCTOR); @@ -5579,7 +5677,7 @@ gfc_conv_initializer (gfc_expr * expr, gfc_typespec * ts, tree type, } } } - + static tree gfc_trans_subarray_assign (tree dest, gfc_component * cm, gfc_expr * expr) { @@ -5626,7 +5724,7 @@ gfc_trans_subarray_assign (tree dest, gfc_component * cm, gfc_expr * expr) cm->as->lower[n]->value.integer); mpz_add_ui (lss_array->shape[n], lss_array->shape[n], 1); } - + /* Associate the SS with the loop. */ gfc_add_ss_to_loop (&loop, lss); gfc_add_ss_to_loop (&loop, rss); @@ -5691,7 +5789,7 @@ gfc_trans_alloc_subarray_assign (tree dest, gfc_component * cm, gfc_start_block (&block); gfc_init_se (&se, NULL); - /* Get the descriptor for the expressions. */ + /* Get the descriptor for the expressions. */ se.want_pointer = 0; gfc_conv_expr_descriptor (&se, expr); gfc_add_block_to_block (&block, &se.pre); @@ -5867,7 +5965,7 @@ gfc_trans_subcomponent_assign (tree dest, gfc_component * cm, gfc_expr * expr) { /* NULL initialization for CLASS components. */ tmp = gfc_trans_structure_assign (dest, - gfc_class_null_initializer (&cm->ts)); + gfc_class_null_initializer (&cm->ts, expr)); gfc_add_expr_to_block (&block, tmp); } else if (cm->attr.dimension && !cm->attr.proc_pointer) @@ -5948,7 +6046,7 @@ gfc_trans_structure_assign (tree dest, gfc_expr * expr) fold_convert (TREE_TYPE (lse.expr), se.expr)); return gfc_finish_block (&block); - } + } for (c = gfc_constructor_first (expr->value.constructor); c; c = gfc_constructor_next (c), cm = cm->next) @@ -6004,13 +6102,9 @@ gfc_conv_structure (gfc_se * se, gfc_expr * expr, int init) if (!c->expr || (cm->attr.allocatable && cm->attr.flavor != FL_PROCEDURE)) continue; - if (strcmp (cm->name, "_size") == 0) - { - val = TYPE_SIZE_UNIT (gfc_get_derived_type (cm->ts.u.derived)); - CONSTRUCTOR_APPEND_ELT (v, cm->backend_decl, val); - } - else if (cm->initializer && cm->initializer->expr_type != EXPR_NULL - && strcmp (cm->name, "_extends") == 0) + if (cm->initializer && cm->initializer->expr_type != EXPR_NULL + && strcmp (cm->name, "_extends") == 0 + && cm->initializer->symtree) { tree vtab; gfc_symbol *vtabs; @@ -6018,6 +6112,11 @@ gfc_conv_structure (gfc_se * se, gfc_expr * expr, int init) vtab = gfc_build_addr_expr (NULL_TREE, gfc_get_symbol_decl (vtabs)); CONSTRUCTOR_APPEND_ELT (v, cm->backend_decl, vtab); } + else if (cm->ts.u.derived && strcmp (cm->name, "_size") == 0) + { + val = TYPE_SIZE_UNIT (gfc_get_derived_type (cm->ts.u.derived)); + CONSTRUCTOR_APPEND_ELT (v, cm->backend_decl, val); + } else { val = gfc_conv_initializer (c->expr, &cm->ts, @@ -6030,7 +6129,7 @@ gfc_conv_structure (gfc_se * se, gfc_expr * expr, int init) } } se->expr = build_constructor (type, v); - if (init) + if (init) TREE_CONSTANT (se->expr) = 1; } @@ -6309,7 +6408,7 @@ gfc_trans_pointer_assignment (gfc_expr * expr1, gfc_expr * expr2) scalar = ss == gfc_ss_terminator; if (!scalar) gfc_free_ss_chain (ss); - + if (scalar) { /* Scalar pointers. */ @@ -6794,7 +6893,7 @@ arrayfunc_assign_needs_temporary (gfc_expr * expr1, gfc_expr * expr2) /* Functions returning pointers or allocatables need temporaries. */ c = expr2->value.function.esym - ? (expr2->value.function.esym->attr.pointer + ? (expr2->value.function.esym->attr.pointer || expr2->value.function.esym->attr.allocatable) : (expr2->symtree->n.sym->attr.pointer || expr2->symtree->n.sym->attr.allocatable); @@ -7085,7 +7184,7 @@ gfc_trans_arrayfunc_assign (gfc_expr * expr1, gfc_expr * expr2) correctly take care of the reallocation internally. For intrinsic calls, the array data is freed and the library takes care of allocation. TODO: Add logic of trans-array.c: gfc_alloc_allocatable_for_assignment - to the library. */ + to the library. */ if (gfc_option.flag_realloc_lhs && gfc_is_reallocatable_lhs (expr1) && !gfc_expr_attr (expr1).codimension @@ -7417,7 +7516,7 @@ alloc_scalar_allocatable_for_assignment (stmtblock_t *block, gfc_init_se (&lse, NULL); lse.want_pointer = 1; gfc_conv_expr (&lse, expr1); - + jump_label1 = gfc_build_label_decl (NULL_TREE); jump_label2 = gfc_build_label_decl (NULL_TREE); diff --git a/gcc/fortran/trans-intrinsic.c b/gcc/fortran/trans-intrinsic.c index 4f74c3ff29a..52f24c1d82f 100644 --- a/gcc/fortran/trans-intrinsic.c +++ b/gcc/fortran/trans-intrinsic.c @@ -5911,6 +5911,7 @@ gfc_conv_same_type_as (gfc_se *se, gfc_expr *expr) gfc_expr *a, *b; gfc_se se1, se2; tree tmp; + tree conda = NULL_TREE, condb = NULL_TREE; gfc_init_se (&se1, NULL); gfc_init_se (&se2, NULL); @@ -5918,6 +5919,20 @@ gfc_conv_same_type_as (gfc_se *se, gfc_expr *expr) a = expr->value.function.actual->expr; b = expr->value.function.actual->next->expr; + if (UNLIMITED_POLY (a)) + { + tmp = gfc_class_vptr_get (a->symtree->n.sym->backend_decl); + conda = fold_build2_loc (input_location, NE_EXPR, boolean_type_node, + tmp, build_int_cst (TREE_TYPE (tmp), 0)); + } + + if (UNLIMITED_POLY (b)) + { + tmp = gfc_class_vptr_get (b->symtree->n.sym->backend_decl); + condb = fold_build2_loc (input_location, NE_EXPR, boolean_type_node, + tmp, build_int_cst (TREE_TYPE (tmp), 0)); + } + if (a->ts.type == BT_CLASS) { gfc_add_vptr_component (a); @@ -5939,8 +5954,18 @@ gfc_conv_same_type_as (gfc_se *se, gfc_expr *expr) gfc_conv_expr (&se1, a); gfc_conv_expr (&se2, b); - tmp = fold_build2_loc (input_location, EQ_EXPR, boolean_type_node, - se1.expr, fold_convert (TREE_TYPE (se1.expr), se2.expr)); + tmp = fold_build2_loc (input_location, EQ_EXPR, + boolean_type_node, se1.expr, + fold_convert (TREE_TYPE (se1.expr), se2.expr)); + + if (conda) + tmp = fold_build2_loc (input_location, TRUTH_ANDIF_EXPR, + boolean_type_node, conda, tmp); + + if (condb) + tmp = fold_build2_loc (input_location, TRUTH_ANDIF_EXPR, + boolean_type_node, condb, tmp); + se->expr = convert (gfc_typenode_for_spec (&expr->ts), tmp); } diff --git a/gcc/fortran/trans-stmt.c b/gcc/fortran/trans-stmt.c index 6fe8b778e65..e41a0c7b173 100644 --- a/gcc/fortran/trans-stmt.c +++ b/gcc/fortran/trans-stmt.c @@ -247,7 +247,7 @@ gfc_conv_elemental_dependencies (gfc_se * se, gfc_se * loopse, if (e == NULL) continue; - /* Obtain the info structure for the current argument. */ + /* Obtain the info structure for the current argument. */ for (ss = loopse->ss; ss && ss != gfc_ss_terminator; ss = ss->next) if (ss->info->expr == e) break; @@ -449,9 +449,9 @@ gfc_trans_call (gfc_code * code, bool dependency_check, gfc_add_ss_to_loop (&loop, ss); gfc_conv_ss_startstride (&loop); - /* TODO: gfc_conv_loop_setup generates a temporary for vector - subscripts. This could be prevented in the elemental case - as temporaries are handled separatedly + /* TODO: gfc_conv_loop_setup generates a temporary for vector + subscripts. This could be prevented in the elemental case + as temporaries are handled separatedly (below in gfc_conv_elemental_dependencies). */ gfc_conv_loop_setup (&loop, &code->expr1->where); gfc_mark_ss_chain_used (ss, 1); @@ -657,7 +657,7 @@ gfc_trans_stop (gfc_code *code, bool error_stop) ? (gfc_option.coarray == GFC_FCOARRAY_LIB ? gfor_fndecl_caf_error_stop : gfor_fndecl_error_stop_numeric) - : gfor_fndecl_stop_numeric_f08, 1, + : gfor_fndecl_stop_numeric_f08, 1, fold_convert (gfc_int4_type_node, se.expr)); } else @@ -689,7 +689,7 @@ gfc_trans_lock_unlock (gfc_code *code, gfc_exec_op type ATTRIBUTE_UNUSED) /* Short cut: For single images without STAT= or LOCK_ACQUIRED return early. (ERRMSG= is always untouched for -fcoarray=single.) */ if (!code->expr2 && !code->expr4 && gfc_option.coarray != GFC_FCOARRAY_LIB) - return NULL_TREE; + return NULL_TREE; gfc_init_se (&se, NULL); gfc_start_block (&se.pre); @@ -734,7 +734,7 @@ gfc_trans_sync (gfc_code *code, gfc_exec_op type) return early. (ERRMSG= is always untouched for -fcoarray=single.) */ if (!code->expr2 && !(gfc_option.rtcheck & GFC_RTCHECK_BOUNDS) && gfc_option.coarray != GFC_FCOARRAY_LIB) - return NULL_TREE; + return NULL_TREE; gfc_init_se (&se, NULL); gfc_start_block (&se.pre); @@ -824,7 +824,7 @@ gfc_trans_sync (gfc_code *code, gfc_exec_op type) { if (TREE_TYPE (stat) == integer_type_node) stat = gfc_build_addr_expr (NULL, stat); - + tmp = build_call_expr_loc (input_location, gfor_fndecl_caf_sync_all, 3, stat, errmsg, errmsglen); gfc_add_expr_to_block (&se.pre, tmp); @@ -837,7 +837,7 @@ gfc_trans_sync (gfc_code *code, gfc_exec_op type) 3, gfc_build_addr_expr (NULL, tmp_stat), errmsg, errmsglen); gfc_add_expr_to_block (&se.pre, tmp); - + gfc_add_modify (&se.pre, stat, fold_convert (TREE_TYPE (stat), tmp_stat)); } @@ -890,7 +890,7 @@ gfc_trans_sync (gfc_code *code, gfc_exec_op type) if (TREE_TYPE (stat) == integer_type_node) stat = gfc_build_addr_expr (NULL, stat); - tmp = build_call_expr_loc (input_location, gfor_fndecl_caf_sync_images, + tmp = build_call_expr_loc (input_location, gfor_fndecl_caf_sync_images, 5, fold_convert (integer_type_node, len), images, stat, errmsg, errmsglen); gfc_add_expr_to_block (&se.pre, tmp); @@ -899,13 +899,13 @@ gfc_trans_sync (gfc_code *code, gfc_exec_op type) { tree tmp_stat = gfc_create_var (integer_type_node, "stat"); - tmp = build_call_expr_loc (input_location, gfor_fndecl_caf_sync_images, + tmp = build_call_expr_loc (input_location, gfor_fndecl_caf_sync_images, 5, fold_convert (integer_type_node, len), images, gfc_build_addr_expr (NULL, tmp_stat), errmsg, errmsglen); gfc_add_expr_to_block (&se.pre, tmp); - gfc_add_modify (&se.pre, stat, + gfc_add_modify (&se.pre, stat, fold_convert (TREE_TYPE (stat), tmp_stat)); } } @@ -995,7 +995,7 @@ gfc_trans_if_1 (gfc_code * code) loc = code->expr1->where.lb ? code->expr1->where.lb->location : input_location; stmt = fold_build3_loc (loc, COND_EXPR, void_type_node, if_se.expr, stmt, elsestmt); - + gfc_add_expr_to_block (&if_se.pre, stmt); /* Finish off this statement. */ @@ -1141,6 +1141,7 @@ trans_associate_var (gfc_symbol *sym, gfc_wrapped_block *block) gfc_expr *e; tree tmp; bool class_target; + bool unlimited; tree desc; tree offset; tree dim; @@ -1153,6 +1154,8 @@ trans_associate_var (gfc_symbol *sym, gfc_wrapped_block *block) && (gfc_is_class_scalar_expr (e) || gfc_is_class_array_ref (e, NULL)); + unlimited = UNLIMITED_POLY (e); + /* Do a `pointer assignment' with updated descriptor (or assign descriptor to array temporary) for arrays with either unknown shape or if associating to a variable. */ @@ -1194,9 +1197,10 @@ trans_associate_var (gfc_symbol *sym, gfc_wrapped_block *block) gfc_finish_block (&se.post)); } - /* Derived type temporaries, arising from TYPE IS, just need the - descriptor of class arrays to be assigned directly. */ - else if (class_target && sym->ts.type == BT_DERIVED && sym->attr.dimension) + /* Temporaries, arising from TYPE IS, just need the descriptor of class + arrays to be assigned directly. */ + else if (class_target && sym->attr.dimension + && (sym->ts.type == BT_DERIVED || unlimited)) { gfc_se se; @@ -1208,7 +1212,16 @@ trans_associate_var (gfc_symbol *sym, gfc_wrapped_block *block) gcc_assert (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (sym->backend_decl))); gfc_add_modify (&se.pre, sym->backend_decl, se.expr); - + + if (unlimited) + { + /* Recover the dtype, which has been overwritten by the + assignment from an unlimited polymorphic object. */ + tmp = gfc_conv_descriptor_dtype (sym->backend_decl); + gfc_add_modify (&se.pre, tmp, + gfc_get_dtype (TREE_TYPE (sym->backend_decl))); + } + gfc_add_init_cleanup (block, gfc_finish_block( &se.pre), gfc_finish_block (&se.post)); } @@ -1229,7 +1242,7 @@ trans_associate_var (gfc_symbol *sym, gfc_wrapped_block *block) /* For a class array we need a descriptor for the selector. */ gfc_conv_expr_descriptor (&se, e); - /* Obtain a temporary class container for the result. */ + /* Obtain a temporary class container for the result. */ gfc_conv_class_to_class (&se, e, sym->ts, false, true, false, false); se.expr = build_fold_indirect_ref_loc (input_location, se.expr); @@ -1254,7 +1267,7 @@ trans_associate_var (gfc_symbol *sym, gfc_wrapped_block *block) { /* This is bound to be a class array element. */ gfc_conv_expr_reference (&se, e); - /* Get the _vptr component of the class object. */ + /* Get the _vptr component of the class object. */ tmp = gfc_get_vptr_from_expr (se.expr); /* Obtain a temporary class container for the result. */ gfc_conv_derived_to_class (&se, e, sym->ts, tmp, false, false); @@ -1266,7 +1279,7 @@ trans_associate_var (gfc_symbol *sym, gfc_wrapped_block *block) tmp = TREE_TYPE (sym->backend_decl); tmp = gfc_build_addr_expr (tmp, se.expr); gfc_add_modify (&se.pre, sym->backend_decl, tmp); - + gfc_add_init_cleanup (block, gfc_finish_block( &se.pre), gfc_finish_block (&se.post)); } @@ -1281,6 +1294,23 @@ trans_associate_var (gfc_symbol *sym, gfc_wrapped_block *block) tmp = gfc_trans_assignment (lhs, e, false, true); gfc_add_init_cleanup (block, tmp, NULL_TREE); } + + /* Set the stringlength from the vtable size. */ + if (sym->ts.type == BT_CHARACTER && sym->attr.select_type_temporary) + { + tree charlen; + gfc_se se; + gfc_init_se (&se, NULL); + gcc_assert (UNLIMITED_POLY (e->symtree->n.sym)); + tmp = gfc_get_symbol_decl (e->symtree->n.sym); + tmp = gfc_vtable_size_get (tmp); + gfc_get_symbol_decl (sym); + charlen = sym->ts.u.cl->backend_decl; + gfc_add_modify (&se.pre, charlen, + fold_convert (TREE_TYPE (charlen), tmp)); + gfc_add_init_cleanup (block, gfc_finish_block( &se.pre), + gfc_finish_block (&se.post)); + } } @@ -1319,7 +1349,7 @@ gfc_trans_block_construct (gfc_code* code) gfc_trans_deferred_vars (sym, &block); for (ass = code->ext.block.assoc; ass; ass = ass->next) trans_associate_var (ass->st->n.sym, &block); - + return gfc_finish_wrapped_block (&block); } @@ -1366,7 +1396,7 @@ gfc_trans_simple_do (gfc_code * code, stmtblock_t *pblock, tree dovar, tree cycle_label; tree exit_label; location_t loc; - + type = TREE_TYPE (dovar); loc = code->ext.iterator->start->where.lb->location; @@ -1374,7 +1404,7 @@ gfc_trans_simple_do (gfc_code * code, stmtblock_t *pblock, tree dovar, /* Initialize the DO variable: dovar = from. */ gfc_add_modify_loc (loc, pblock, dovar, fold_convert (TREE_TYPE(dovar), from)); - + /* Save value for do-tinkering checking. */ if (gfc_option.rtcheck & GFC_RTCHECK_DO) { @@ -1612,8 +1642,8 @@ gfc_trans_do (gfc_code * code, tree exit_cond) tmp = fold_build2_loc (loc, LT_EXPR, boolean_type_node, step, build_int_cst (TREE_TYPE (step), 0)); - step_sign = fold_build3_loc (loc, COND_EXPR, type, tmp, - build_int_cst (type, -1), + step_sign = fold_build3_loc (loc, COND_EXPR, type, tmp, + build_int_cst (type, -1), build_int_cst (type, 1)); tmp = fold_build2_loc (loc, LT_EXPR, boolean_type_node, to, from); @@ -3183,7 +3213,7 @@ compute_overall_iter_number (forall_info *nested_forall_info, tree inner_size, if (INTEGER_CST_P (inner_size)) { while (forall_tmp - && !forall_tmp->mask + && !forall_tmp->mask && INTEGER_CST_P (forall_tmp->size)) { inner_size = fold_build2_loc (input_location, MULT_EXPR, @@ -3707,7 +3737,7 @@ gfc_trans_forall_1 (gfc_code * code, forall_info * nested_forall_info) for (n = 0; n < nvar; n++) { /* size = (end + step - start) / step. */ - tmp = fold_build2_loc (input_location, MINUS_EXPR, TREE_TYPE (start[n]), + tmp = fold_build2_loc (input_location, MINUS_EXPR, TREE_TYPE (start[n]), step[n], start[n]); tmp = fold_build2_loc (input_location, PLUS_EXPR, TREE_TYPE (end[n]), end[n], tmp); @@ -4108,7 +4138,7 @@ gfc_trans_where_assign (gfc_expr *expr1, gfc_expr *expr2, stmtblock_t body; tree index, maskexpr; - /* A defined assignment. */ + /* A defined assignment. */ if (cnext && cnext->resolved_sym) return gfc_trans_call (cnext, true, mask, count1, invert); @@ -4893,10 +4923,19 @@ gfc_trans_allocate (gfc_code * code) if (!gfc_array_allocate (&se, expr, stat, errmsg, errlen, label_finish, memsz, &nelems, code->expr3)) { + bool unlimited_char; + + unlimited_char = UNLIMITED_POLY (al->expr) + && ((code->expr3 && code->expr3->ts.type == BT_CHARACTER) + || (code->ext.alloc.ts.type == BT_CHARACTER + && code->ext.alloc.ts.u.cl + && code->ext.alloc.ts.u.cl->length)); + /* A scalar or derived type. */ /* Determine allocate size. */ if (al->expr->ts.type == BT_CLASS + && !unlimited_char && code->expr3 && memsz == NULL_TREE) { @@ -4913,8 +4952,8 @@ gfc_trans_allocate (gfc_code * code) else memsz = TYPE_SIZE_UNIT (gfc_typenode_for_spec (&code->expr3->ts)); } - else if (al->expr->ts.type == BT_CHARACTER - && al->expr->ts.deferred && code->expr3) + else if (((al->expr->ts.type == BT_CHARACTER && al->expr->ts.deferred) + || unlimited_char) && code->expr3) { if (!code->expr3->ts.u.cl->backend_decl) { @@ -4968,13 +5007,17 @@ gfc_trans_allocate (gfc_code * code) memsz)); /* Convert to size in bytes, using the character KIND. */ + if (unlimited_char) + tmp = TREE_TYPE (gfc_typenode_for_spec (&code->expr3->ts)); + else tmp = TREE_TYPE (gfc_typenode_for_spec (&al->expr->ts)); tmp = TYPE_SIZE_UNIT (tmp); memsz = fold_build2_loc (input_location, MULT_EXPR, TREE_TYPE (tmp), tmp, fold_convert (TREE_TYPE (tmp), memsz)); } - else if (al->expr->ts.type == BT_CHARACTER && al->expr->ts.deferred) + else if ((al->expr->ts.type == BT_CHARACTER && al->expr->ts.deferred) + || unlimited_char) { gcc_assert (code->ext.alloc.ts.u.cl && code->ext.alloc.ts.u.cl->length); gfc_init_se (&se_sz, NULL); @@ -5026,7 +5069,7 @@ gfc_trans_allocate (gfc_code * code) } else if (al->expr->ts.type == BT_CLASS) { - /* With class objects, it is best to play safe and null the + /* With class objects, it is best to play safe and null the memory because we cannot know if dynamic types have allocatable components or not. */ tmp = build_call_expr_loc (input_location, @@ -5050,8 +5093,8 @@ gfc_trans_allocate (gfc_code * code) build_empty_stmt (input_location)); gfc_add_expr_to_block (&block, tmp); } - - /* We need the vptr of CLASS objects to be initialized. */ + + /* We need the vptr of CLASS objects to be initialized. */ e = gfc_copy_expr (al->expr); if (e->ts.type == BT_CLASS) { @@ -5090,16 +5133,19 @@ gfc_trans_allocate (gfc_code * code) ts = &code->expr3->ts; else if (e->ts.type == BT_DERIVED) ts = &e->ts; - else if (code->ext.alloc.ts.type == BT_DERIVED) + else if (code->ext.alloc.ts.type == BT_DERIVED || UNLIMITED_POLY (al->expr)) ts = &code->ext.alloc.ts; else if (e->ts.type == BT_CLASS) ts = &CLASS_DATA (e)->ts; else ts = &e->ts; - if (ts->type == BT_DERIVED) + if (ts->type == BT_DERIVED || UNLIMITED_POLY (e)) { + if (ts->type == BT_DERIVED) vtab = gfc_find_derived_vtab (ts->u.derived); + else + vtab = gfc_find_intrinsic_vtab (ts); gcc_assert (vtab); gfc_init_se (&lse, NULL); lse.want_pointer = 1; @@ -5184,9 +5230,12 @@ gfc_trans_allocate (gfc_code * code) ppc = gfc_copy_expr (rhs); gfc_add_vptr_component (ppc); } - else + else if (rhs->ts.type == BT_DERIVED) ppc = gfc_lval_expr_from_sym (gfc_find_derived_vtab (rhs->ts.u.derived)); + else + ppc = gfc_lval_expr_from_sym + (gfc_find_intrinsic_vtab (&rhs->ts)); gfc_add_component_ref (ppc, "_copy"); ppc_code = gfc_get_code (); @@ -5296,6 +5345,30 @@ gfc_trans_allocate (gfc_code * code) } +/* Reset the vptr after deallocation. */ + +static void +reset_vptr (stmtblock_t *block, gfc_expr *e) +{ + gfc_expr *rhs, *lhs = gfc_copy_expr (e); + gfc_symbol *vtab; + tree tmp; + + if (UNLIMITED_POLY (e)) + rhs = gfc_get_null_expr (NULL); + else + { + vtab = gfc_find_derived_vtab (e->ts.u.derived); + rhs = gfc_lval_expr_from_sym (vtab); + } + gfc_add_vptr_component (lhs); + tmp = gfc_trans_pointer_assignment (lhs, rhs); + gfc_add_expr_to_block (block, tmp); + gfc_free_expr (lhs); + gfc_free_expr (rhs); +} + + /* Translate a DEALLOCATE statement. */ tree @@ -5376,6 +5449,8 @@ gfc_trans_deallocate (gfc_code *code) tmp = gfc_array_deallocate (se.expr, pstat, errmsg, errlen, label_finish, expr); gfc_add_expr_to_block (&se.pre, tmp); + if (UNLIMITED_POLY (al->expr)) + reset_vptr (&se.pre, al->expr); } else { @@ -5388,19 +5463,9 @@ gfc_trans_deallocate (gfc_code *code) se.expr, build_int_cst (TREE_TYPE (se.expr), 0)); gfc_add_expr_to_block (&se.pre, tmp); - + if (al->expr->ts.type == BT_CLASS) - { - /* Reset _vptr component to declared type. */ - gfc_expr *rhs, *lhs = gfc_copy_expr (al->expr); - gfc_symbol *vtab = gfc_find_derived_vtab (al->expr->ts.u.derived); - gfc_add_vptr_component (lhs); - rhs = gfc_lval_expr_from_sym (vtab); - tmp = gfc_trans_pointer_assignment (lhs, rhs); - gfc_add_expr_to_block (&se.pre, tmp); - gfc_free_expr (lhs); - gfc_free_expr (rhs); - } + reset_vptr (&se.pre, al->expr); } if (code->expr1) diff --git a/gcc/fortran/trans-types.c b/gcc/fortran/trans-types.c index 35a39c57859..8394bf93576 100644 --- a/gcc/fortran/trans-types.c +++ b/gcc/fortran/trans-types.c @@ -2338,16 +2338,18 @@ gfc_get_derived_type (gfc_symbol * derived) tree canonical = NULL_TREE; tree *chain = NULL; bool got_canonical = false; + bool unlimited_entity = false; gfc_component *c; gfc_dt_list *dt; gfc_namespace *ns; + if (derived->attr.unlimited_polymorphic) + return ptr_type_node; + if (derived && derived->attr.flavor == FL_PROCEDURE && derived->attr.generic) derived = gfc_find_dt_in_generic (derived); - gcc_assert (derived && derived->attr.flavor == FL_DERIVED); - /* See if it's one of the iso_c_binding derived types. */ if (derived->attr.is_iso_c == 1) { @@ -2431,6 +2433,12 @@ gfc_get_derived_type (gfc_symbol * derived) derived->backend_decl = typenode; } + if (derived->components + && derived->components->ts.type == BT_DERIVED + && strcmp (derived->components->name, "_data") == 0 + && derived->components->ts.u.derived->attr.unlimited_polymorphic) + unlimited_entity = true; + /* Go through the derived type components, building them as necessary. The reason for doing this now is that it is possible to recurse back to this derived type through a @@ -2511,14 +2519,16 @@ gfc_get_derived_type (gfc_symbol * derived) !c->attr.target); } else if ((c->attr.pointer || c->attr.allocatable) - && !c->attr.proc_pointer) + && !c->attr.proc_pointer + && !(unlimited_entity && c == derived->components)) field_type = build_pointer_type (field_type); if (c->attr.pointer) field_type = gfc_nonrestricted_type (field_type); /* vtype fields can point to different types to the base type. */ - if (c->ts.type == BT_DERIVED && c->ts.u.derived->attr.vtype) + if (c->ts.type == BT_DERIVED + && c->ts.u.derived && c->ts.u.derived->attr.vtype) field_type = build_pointer_type_for_mode (TREE_TYPE (field_type), ptr_mode, true); diff --git a/gcc/fortran/trans.c b/gcc/fortran/trans.c index 6365213b8f0..70f06fffe99 100644 --- a/gcc/fortran/trans.c +++ b/gcc/fortran/trans.c @@ -1,6 +1,6 @@ /* Code translation -- generate GCC trees from gfc_code. - Copyright (C) 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009, 2010, 2012 - Free Software Foundation, Inc. + Copyright (C) 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009, 2010, + 2012 Free Software Foundation, Inc. Contributed by Paul Brook This file is part of GCC. @@ -87,7 +87,7 @@ tree gfc_create_var_np (tree type, const char *prefix) { tree t; - + t = create_tmp_var_raw (type, prefix); /* No warnings for anonymous variables. */ @@ -139,7 +139,7 @@ gfc_evaluate_now (tree expr, stmtblock_t * pblock) } -/* Build a MODIFY_EXPR node and add it to a given statement block PBLOCK. +/* Build a MODIFY_EXPR node and add it to a given statement block PBLOCK. A MODIFY_EXPR is an assignment: LHS <- RHS. */ @@ -428,7 +428,7 @@ trans_runtime_error_vararg (bool error, locus* where, const char* msgid, arg = gfc_build_addr_expr (pchar_type_node, gfc_build_localized_cstring_const (message)); free (message); - + asprintf (&message, "%s", _(msgid)); arg2 = gfc_build_addr_expr (pchar_type_node, gfc_build_localized_cstring_const (message)); @@ -440,7 +440,7 @@ trans_runtime_error_vararg (bool error, locus* where, const char* msgid, argarray[1] = arg2; for (i = 0; i < nargs; i++) argarray[2 + i] = va_arg (ap, tree); - + /* Build the function call to runtime_(warning,error)_at; because of the variable number of arguments, we can't use build_call_expr_loc dinput_location, irectly. */ @@ -591,14 +591,14 @@ gfc_call_malloc (stmtblock_t * block, tree type, tree size) /* Allocate memory, using an optional status argument. - + This function follows the following pseudo-code: void * allocate (size_t size, integer_type stat) { void *newmem; - + if (stat requested) stat = 0; @@ -661,7 +661,7 @@ gfc_allocate_using_malloc (stmtblock_t * block, tree pointer, /* Allocate memory, using an optional status argument. - + This function follows the following pseudo-code: void * @@ -717,9 +717,9 @@ gfc_allocate_using_lib (stmtblock_t * block, tree pointer, tree size, /* Generate code for an ALLOCATE statement when the argument is an allocatable variable. If the variable is currently allocated, it is an error to allocate it again. - + This function follows the following pseudo-code: - + void * allocate_allocatable (void *mem, size_t size, integer_type stat) { @@ -733,7 +733,7 @@ gfc_allocate_using_lib (stmtblock_t * block, tree pointer, tree size, runtime_error ("Attempting to allocate already allocated variable"); } } - + expr must be set to the original expression being allocated for its locus and variable name in case a runtime error has to be printed. */ void @@ -866,7 +866,7 @@ gfc_call_free (tree var) even when no status variable is passed to us (this is used for unconditional deallocation generated by the front-end at end of each procedure). - + If a runtime-message is possible, `expr' must point to the original expression being deallocated for its locus and variable name. @@ -1075,7 +1075,7 @@ gfc_deallocate_scalar_with_status (tree pointer, tree status, bool can_fail, /* When POINTER is not NULL, we free it. */ gfc_start_block (&non_null); - + /* Free allocatable components. */ if (ts.type == BT_DERIVED && ts.u.derived->attr.alloc_comp) { @@ -1091,7 +1091,7 @@ gfc_deallocate_scalar_with_status (tree pointer, tree status, bool can_fail, tmp, 0); gfc_add_expr_to_block (&non_null, tmp); } - + tmp = build_call_expr_loc (input_location, builtin_decl_explicit (BUILT_IN_FREE), 1, fold_convert (pvoid_type_node, pointer)); @@ -1320,6 +1320,12 @@ trans_code (gfc_code * code, tree cond) case EXEC_POINTER_ASSIGN: if (code->expr1->ts.type == BT_CLASS) res = gfc_trans_class_assign (code->expr1, code->expr2, code->op); + else if (UNLIMITED_POLY (code->expr2) + && code->expr1->ts.type == BT_DERIVED + && (code->expr1->ts.u.derived->attr.sequence + || code->expr1->ts.u.derived->attr.is_bind_c)) + /* F2003: C717 */ + res = gfc_trans_class_assign (code->expr1, code->expr2, code->op); else res = gfc_trans_pointer_assign (code); break; @@ -1544,7 +1550,7 @@ trans_code (gfc_code * code, tree cond) { if (TREE_CODE (res) != STATEMENT_LIST) SET_EXPR_LOCATION (res, input_location); - + /* Add the new statement to the block. */ gfc_add_expr_to_block (&block, res); } @@ -1686,7 +1692,7 @@ gfc_finish_wrapped_block (gfc_wrapped_block* block) if (block->cleanup) result = build2_loc (input_location, TRY_FINALLY_EXPR, void_type_node, result, block->cleanup); - + /* Clear the block. */ block->init = NULL_TREE; block->code = NULL_TREE; diff --git a/gcc/testsuite/ChangeLog b/gcc/testsuite/ChangeLog index 8e1e53ccb6d..ce4f2870f07 100644 --- a/gcc/testsuite/ChangeLog +++ b/gcc/testsuite/ChangeLog @@ -1,3 +1,10 @@ +2012-12-19 Paul Thomas <pault@gcc.gnu.org> + + * gfortran.dg/unlimited_polymorphic_1.f03: New test. + * gfortran.dg/unlimited_polymorphic_2.f03: New test. + * gfortran.dg/unlimited_polymorphic_3.f03: New test. + * gfortran.dg/same_type_as.f03: Correct for improved message. + 2012-12-19 Kyrylo Tkachov <kyrylo.tkachov@arm.com> * gcc.target/arm/vmaxnmdf.c: New test. diff --git a/gcc/testsuite/gfortran.dg/unlimited_polymorphic_1.f03 b/gcc/testsuite/gfortran.dg/unlimited_polymorphic_1.f03 new file mode 100644 index 00000000000..3ff1e551ee5 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/unlimited_polymorphic_1.f03 @@ -0,0 +1,211 @@ +! { dg-do run }
+!
+! Basic tests of functionality of unlimited polymorphism
+!
+! Contributed by Paul Thomas <pault@gcc.gnu.org>
+!
+MODULE m
+ TYPE :: a
+ integer :: i
+ END TYPE
+
+contains
+ subroutine bar (arg, res)
+ class(*) :: arg
+ character(100) :: res
+ select type (w => arg)
+ type is (a)
+ write (res, '(a, I4)') "type(a)", w%i
+ type is (integer)
+ write (res, '(a, I4)') "integer", w
+ type is (real(4))
+ write (res, '(a, F4.1)') "real4", w
+ type is (real(8))
+ write (res, '(a, F4.1)') "real8", w
+ type is (character(*, kind = 4))
+ call abort
+ type is (character(*))
+ write (res, '(a, I2, a, a)') "char(", LEN(w), ")", trim(w)
+ end select
+ end subroutine
+
+ subroutine foo (arg, res)
+ class(*) :: arg (:)
+ character(100) :: res
+ select type (w => arg)
+ type is (a)
+ write (res,'(a, 10I4)') "type(a) array", w%i
+ type is (integer)
+ write (res,'(a, 10I4)') "integer array", w
+ type is (real)
+ write (res,'(a, 10F4.1)') "real array", w
+ type is (character(*))
+ write (res, '(a5, I2, a, I2, a1, 2(a))') &
+ "char(",len(w),",", size(w,1),") array ", w
+ end select
+ end subroutine
+END MODULE
+
+
+ USE m
+ TYPE(a), target :: obj1 = a(99)
+ TYPE(a), target :: obj2(3) = a(999)
+ integer, target :: obj3 = 999
+ real(4), target :: obj4(4) = [(real(i), i = 1, 4)]
+ integer, target :: obj5(3) = [(i*99, i = 1, 3)]
+ class(*), pointer :: u1
+ class(*), pointer :: u2(:)
+ class(*), allocatable :: u3
+ class(*), allocatable :: u4(:)
+ type(a), pointer :: aptr(:)
+ character(8) :: sun = "sunshine"
+ character(100) :: res
+
+ ! NULL without MOLD used to cause segfault
+ u2 => NULL()
+ u2 => NULL(aptr)
+
+! Test pointing to derived types.
+ u1 => obj1
+ if (SAME_TYPE_AS (obj1, u1) .neqv. .TRUE.) call abort
+ u2 => obj2
+ call bar (u1, res)
+ if (trim (res) .ne. "type(a) 99") call abort
+
+ call foo (u2, res)
+ if (trim (res) .ne. "type(a) array 999 999 999") call abort
+
+ if (SAME_TYPE_AS (obj1, u1) .neqv. .TRUE.) call abort
+
+! Check allocate with an array SOURCE.
+ allocate (u2(5), source = [(a(i), i = 1,5)])
+ if (SAME_TYPE_AS (u1, a(2)) .neqv. .TRUE.) call abort
+ call foo (u2, res)
+ if (trim (res) .ne. "type(a) array 1 2 3 4 5") call abort
+
+ deallocate (u2)
+
+! Point to intrinsic targets.
+ u1 => obj3
+ call bar (u1, res)
+ if (trim (res) .ne. "integer 999") call abort
+
+ u2 => obj4
+ call foo (u2, res)
+ if (trim (res) .ne. "real array 1.0 2.0 3.0 4.0") call abort
+
+ u2 => obj5
+ call foo (u2, res)
+ if (trim (res) .ne. "integer array 99 198 297") call abort
+
+! Test allocate with source.
+ allocate (u1, source = sun)
+ call bar (u1, res)
+ if (trim (res) .ne. "char( 8)sunshine") call abort
+ deallocate (u1)
+
+ allocate (u2(3), source = [7,8,9])
+ call foo (u2, res)
+ if (trim (res) .ne. "integer array 7 8 9") call abort
+
+ deallocate (u2)
+
+ if (EXTENDS_TYPE_OF (obj1, u2) .neqv. .TRUE.) call abort
+ if (EXTENDS_TYPE_OF (u2, obj1) .neqv. .FALSE.) call abort
+
+ allocate (u2(3), source = [5.0,6.0,7.0])
+ call foo (u2, res)
+ if (trim (res) .ne. "real array 5.0 6.0 7.0") call abort
+
+ if (EXTENDS_TYPE_OF (obj1, u2) .neqv. .FALSE.) call abort
+ if (EXTENDS_TYPE_OF (u2, obj1) .neqv. .FALSE.) call abort
+ deallocate (u2)
+
+! Check allocate with a MOLD tag.
+ allocate (u2(3), mold = 8.0)
+ call foo (u2, res)
+ if (res(1:10) .ne. "real array") call abort
+ deallocate (u2)
+
+! Test passing an intrinsic type to a CLASS(*) formal.
+ call bar(1, res)
+ if (trim (res) .ne. "integer 1") call abort
+
+ call bar(2.0, res)
+ if (trim (res) .ne. "real4 2.0") call abort
+
+ call bar(2d0, res)
+ if (trim (res) .ne. "real8 2.0") call abort
+
+ call bar(a(3), res)
+ if (trim (res) .ne. "type(a) 3") call abort
+
+ call bar(sun, res)
+ if (trim (res) .ne. "char( 8)sunshine") call abort
+
+ call bar (obj3, res)
+ if (trim (res) .ne. "integer 999") call abort
+
+ call foo([4,5], res)
+ if (trim (res) .ne. "integer array 4 5") call abort
+
+ call foo([6.0,7.0], res)
+ if (trim (res) .ne. "real array 6.0 7.0") call abort
+
+ call foo([a(8),a(9)], res)
+ if (trim (res) .ne. "type(a) array 8 9") call abort
+
+ call foo([sun, " & rain"], res)
+ if (trim (res) .ne. "char( 8, 2)sunshine & rain") call abort
+
+ call foo([sun//" never happens", " & rain always happens"], res)
+ if (trim (res) .ne. "char(22, 2)sunshine never happens & rain always happens") call abort
+
+ call foo (obj4, res)
+ if (trim (res) .ne. "real array 1.0 2.0 3.0 4.0") call abort
+
+ call foo (obj5, res)
+ if (trim (res) .ne. "integer array 99 198 297") call abort
+
+! Allocatable entities
+ if (EXTENDS_TYPE_OF (obj1, u3) .neqv. .TRUE.) call abort
+ if (EXTENDS_TYPE_OF (u3, obj1) .neqv. .FALSE.) call abort
+ if (EXTENDS_TYPE_OF (obj1, u4) .neqv. .TRUE.) call abort
+ if (EXTENDS_TYPE_OF (u4, obj1) .neqv. .FALSE.) call abort
+
+ allocate (u3, source = 2.4)
+ call bar (u3, res)
+ if (trim (res) .ne. "real4 2.4") call abort
+
+ allocate (u4(2), source = [a(88), a(99)])
+ call foo (u4, res)
+ if (trim (res) .ne. "type(a) array 88 99") call abort
+
+ if (EXTENDS_TYPE_OF (obj1, u3) .neqv. .FALSE.) call abort
+ if (EXTENDS_TYPE_OF (u3, obj1) .neqv. .FALSE.) call abort
+
+ deallocate (u3)
+ if (EXTENDS_TYPE_OF (obj1, u3) .neqv. .TRUE.) call abort
+ if (EXTENDS_TYPE_OF (u3, obj1) .neqv. .FALSE.) call abort
+
+ if (EXTENDS_TYPE_OF (obj1, u4) .neqv. .TRUE.) call abort
+ if (EXTENDS_TYPE_OF (u4, obj1) .neqv. .TRUE.) call abort
+ deallocate (u4)
+ if (EXTENDS_TYPE_OF (obj1, u4) .neqv. .TRUE.) call abort
+ if (EXTENDS_TYPE_OF (u4, obj1) .neqv. .FALSE.) call abort
+
+
+! Check assumed rank calls
+ call foobar (u3, 0)
+ call foobar (u4, 1)
+contains
+
+ subroutine foobar (arg, ranki)
+ class(*) :: arg (..)
+ integer :: ranki
+ integer i
+ i = rank (arg)
+ if (i .ne. ranki) call abort
+ end subroutine
+
+END
diff --git a/gcc/testsuite/gfortran.dg/unlimited_polymorphic_2.f03 b/gcc/testsuite/gfortran.dg/unlimited_polymorphic_2.f03 new file mode 100644 index 00000000000..7c05c845616 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/unlimited_polymorphic_2.f03 @@ -0,0 +1,81 @@ +! { dg-do compile }
+!
+! Test the most important constraints unlimited polymorphic entities
+!
+! Contributed by Paul Thomas <pault@gcc.gnu.org>
+! and Tobias Burnus <burnus@gcc.gnu.org>
+!
+ CHARACTER(:), allocatable, target :: chr ! { dg-error "TODO: Deferred character length variable" }
+! F2008: C5100
+ integer :: i(2)
+ logical :: flag
+ class(*), pointer :: u1, u2(:) ! { dg-error "cannot appear in COMMON" }
+ common u1
+ u1 => chr
+! F2003: C625
+ allocate (u1) ! { dg-error "requires either a type-spec or SOURCE tag" }
+ allocate (u1, mold = 1.0) ! { dg-error "requires either a type-spec or SOURCE tag" }
+ allocate (real :: u1)
+ Allocate (u1, source = 1.0)
+
+! F2008: C4106
+ u2 = [u1] ! { dg-error "shall not be unlimited polymorphic" }
+
+ i = u2 ! { dg-error "Can\\'t convert CLASS\\(\\*\\)" }
+
+! Repeats same_type_as_1.f03 for unlimited polymorphic u2
+ flag = same_type_as (i, u2) ! { dg-error "cannot be of type INTEGER" }
+ flag = extends_type_of (i, u2) ! { dg-error "cannot be of type INTEGER" }
+
+contains
+
+! C717 (R735) If data-target is unlimited polymorphic,
+! data-pointer-object shall be unlimited polymorphic, of a sequence
+! derived type, or of a type with the BIND attribute.
+!
+ subroutine bar
+
+ type sq
+ sequence
+ integer :: i
+ end type sq
+
+ type(sq), target :: x
+ class(*), pointer :: y
+ integer, pointer :: tgt
+
+ x%i = 42
+ y => x
+ call foo (y)
+
+ y => tgt ! This is OK, of course.
+ tgt => y ! { dg-error "must be unlimited polymorphic" }
+
+ select type (y) ! This is the correct way to accomplish the previous
+ type is (integer)
+ tgt => y
+ end select
+
+ end subroutine bar
+
+
+ subroutine foo(tgt)
+ class(*), pointer, intent(in) :: tgt
+ type t
+ sequence
+ integer :: k
+ end type t
+
+ type(t), pointer :: ptr
+
+ ptr => tgt ! C717 allows this.
+
+ select type (tgt)
+! F03:C815 or F08:C839
+ type is (t) ! { dg-error "shall not specify a sequence derived type" }
+ ptr => tgt ! { dg-error "Expected TYPE IS" }
+ end select
+
+ print *, ptr%k
+ end subroutine foo
+END
diff --git a/gcc/testsuite/gfortran.dg/unlimited_polymorphic_3.f03 b/gcc/testsuite/gfortran.dg/unlimited_polymorphic_3.f03 new file mode 100644 index 00000000000..5ed98974d7c --- /dev/null +++ b/gcc/testsuite/gfortran.dg/unlimited_polymorphic_3.f03 @@ -0,0 +1,55 @@ +! { dg-do run } +! +! Check that pointer assignments allowed by F2003:C717 +! work and check null initialization of CLASS(*) pointers. +! +! Contributed by Tobias Burnus <burnus@gcc.gnu.org> +! +program main + interface + subroutine foo(z) + class(*), pointer, intent(in) :: z + end subroutine foo + end interface + type sq + sequence + integer :: i + end type sq + type(sq), target :: x + class(*), pointer :: y, z + x%i = 42 + y => x + z => y ! unlimited => unlimited allowed + call foo (z) + call bar +contains + subroutine bar + type t + end type t + type(t), pointer :: x + class(*), pointer :: ptr1 => null() ! pointer initialization + class(*), pointer :: ptr2 => null(x) ! pointer initialization + if (same_type_as (ptr1, x) .neqv. .FALSE.) call abort + if (same_type_as (ptr2, x) .neqv. .TRUE.) call abort + end subroutine bar + +end program main + + +subroutine foo(tgt) + use iso_c_binding + class(*), pointer, intent(in) :: tgt + type, bind(c) :: s + integer (c_int) :: k + end type s + type t + sequence + integer :: k + end type t + type(s), pointer :: ptr1 + type(t), pointer :: ptr2 + ptr1 => tgt ! bind(c) => unlimited allowed + if (ptr1%k .ne. 42) call abort + ptr2 => tgt ! sequence type => unlimited allowed + if (ptr2%k .ne. 42) call abort +end subroutine foo diff --git a/libgfortran/ChangeLog b/libgfortran/ChangeLog index ecaa6e3ec48..bea7c72970c 100644 --- a/libgfortran/ChangeLog +++ b/libgfortran/ChangeLog @@ -1,3 +1,8 @@ +2012-12-19 Paul Thomas <pault@gcc.gnu.org> + + * intrinsics/extends_type_of.c : Return correct results for + null vptrs. + 2012-12-03 Janus Weil <janus@gcc.gnu.org> PR fortran/55548 diff --git a/libgfortran/intrinsics/extends_type_of.c b/libgfortran/intrinsics/extends_type_of.c index 223423428d5..8f8b5a9f7d1 100644 --- a/libgfortran/intrinsics/extends_type_of.c +++ b/libgfortran/intrinsics/extends_type_of.c @@ -49,6 +49,14 @@ export_proto(is_extension_of); GFC_LOGICAL_4 is_extension_of (struct vtype *v1, struct vtype *v2) { + /* Assume that only unlimited polymorphic entities will pass NULL v1 or v2 + if they are unallocated or disassociated. */ + + if (!v2) + return 1; + if (!v1) + return 0; + while (v1) { if (v1->hash == v2->hash) return 1; |
