diff options
author | Paul Thomas <pault@gcc.gnu.org> | 2017-09-09 11:10:42 +0000 |
---|---|---|
committer | Paul Thomas <pault@gcc.gnu.org> | 2017-09-09 11:10:42 +0000 |
commit | 5bab4c9631c478b7940e952ea57de680321d5a8e (patch) | |
tree | fe34213cb8a220dbd5072eaf2b7addbbc4709085 /gcc/fortran/decl.c | |
parent | 66c9b3f50f70b1503629b94cc2e33f7e5df64b08 (diff) | |
download | gcc-5bab4c9631c478b7940e952ea57de680321d5a8e.zip gcc-5bab4c9631c478b7940e952ea57de680321d5a8e.tar.gz gcc-5bab4c9631c478b7940e952ea57de680321d5a8e.tar.bz2 |
decl.c: Add decl_type_param_list...
2017-09-09 Paul Thomas <pault@gcc.gnu.org>
* decl.c : Add decl_type_param_list, type_param_spec_list as
static variables to hold PDT spec lists.
(build_sym): Copy 'type_param_spec_list' to symbol spec_list.
(build_struct): Copy the 'saved_kind_expr' to the component
'kind_expr'. Check that KIND or LEN components appear in the
decl_type_param_list. These should appear as symbols in the
f2k_derived namespace. If the component is itself a PDT type,
copy the decl_type_param_list to the component param_list.
(gfc_match_kind_spec): If the KIND expression is parameterized
set KIND to zero and store the expression in 'saved_kind_expr'.
(insert_parameter_exprs): New function.
(gfc_insert_kind_parameter_exprs): New function.
(gfc_insert_parameter_exprs): New function.
(gfc_get_pdt_instance): New function.
(gfc_match_decl_type_spec): Match the decl_type_spec_list if it
is present. If it is, call 'gfc_get_pdt_instance' to obtain the
specific instance of the PDT.
(match_attr_spec): Match KIND and LEN attributes. Check for the
standard and for type/kind of the parameter. They are also not
allowed outside a derived type definition.
(gfc_match_data_decl): Null the decl_type_param_list and the
type_param_spec_list on entry and free them on exit.
(gfc_match_formal_arglist): If 'typeparam' is true, add the
formal symbol to the f2k_derived namespace.
(gfc_match_derived_decl): Register the decl_type_param_list
if this is a PDT. If this is a type extension, gather up all
the type parameters and put them in the right order.
*dump-parse-tree.c (show_attr): Signal PDT templates and the
parameter attributes.
(show_components): Output parameter atrributes and component
parameter list.
(show_symbol): Show variable parameter lists.
* expr.c (expr.c): Copy the expression parameter list.
(gfc_is_constant_expr): Pass on symbols representing PDT
parameters.
(gfc_check_init_expr): Break on PDT KIND parameters and
PDT parameter expressions.
(gfc_check_assign): Assigning to KIND or LEN components is an
error.
(derived_parameter_expr): New function.
(gfc_derived_parameter_expr): New function.
(gfc_spec_list_type): New function.
* gfortran.h : Add enum gfc_param_spec_type. Add the PDT attrs
to the structure symbol_attr. Add the 'kind_expr' and
'param_list' field to the gfc_component structure. Comment on
the reuse of the gfc_actual_arglist structure as storage for
type parameter spec lists. Add the new field 'spec_type' to
this structure. Add 'param_list' fields to gfc_symbol and
gfc_expr. Add prototypes for gfc_insert_kind_parameter_exprs,
gfc_insert_parameter_exprs, gfc_add_kind, gfc_add_len,
gfc_derived_parameter_expr and gfc_spec_list_type.
* interface.c (gfc_compare_derived_types): Treat PDTs in the
same way as sequence types.
* match.c : Add variable 'type_param_spec_list'.
(gfc_op2string, gfc_match_member_sep, gfc_match_label): Remove
trailing whitespace.
(match_derived_type_spec): Match PDTs and find specific
instance.
(gfc_match_type_spec): Remove more trailing whitespace.
(gfc_match_allocate): Assumed or deferred parameters cannot
appear here. Copy the type parameter spec list to the expr for
the allocatable entity. Free 'type_param_spec_list'.
(gfc_match_common, gfc_match_namelist, gfc_match_module): Still
more trailing whitespace to remove.
(gfc_match_type_is): Allow PDT typespecs.
* match.h : Modify prototypes for gfc_match_formal_arglist and
gfc_match_actual_arglist.
* module.c (ab_attribute, mstring attr_bits): PDT attributes
added.
(mio_symbol_attribute): PDT attributes handled.
(mio_component): Deal with 'kind_expr' field.
(mio_full_f2k_derived): For PDT templates, transfer the formal
namespace symroot to the f2k_derived namespace.
*primary.c (match_keyword_arg, gfc_match_actual_arglist): Add
modifications to handle PDT spec lists. These are flagged in
both cases by new boolean arguments, whose prototype defaults
are false.
(gfc_match_structure_constructor, match_variable): Remove yet
more trailing whitespace.
* resolve.c (get_pdt_spec_expr, get_pdt_constructor): New
functions.
(resolve_structure_cons): If the constructor is a PDT template,
call get_pdt_constructor to build it using the parameter lists
and then get the specific instance of the PDT.
(resolve_component): PDT strings need a hidden string length
component like deferred characters.
(resolve_symbol): Dummy PDTs cannot have deferred parameters.
* symbol.c (gfc_add_kind, gfc_add_len): New functions.
(free_components): Free 'kind_expr' and 'param_list' fields.
(gfc_free_symbol): Free the 'param_list' field.
(gfc_find_sym_tree): If the current state is a PDT template,
look for the symtree in the f2k_derived namspaces.
trans-array.c (structure_alloc_comps): Allocate and deallocate
PDTs. Check dummy arguments for compliance of LEN parameters.
Add the new functions to the preceeding enum.
(gfc_allocate_pdt_comp, gfc_deallocate_pdt_comp and
gfc_check_pdt_dummy): New functions calling above.
* trans-array.h : Add prototypes for these functions.
trans-decl.c (gfc_get_symbol_decl): Call gfc_defer_symbol_init
as appropriate for PDT symbols.
(gfc_trans_deferred_vars): Allocate/deallocate PDT entities as
they come into and out of scope. Exclude pdt_types from being
'gcc_unreachable'.
(gfc_trans_subcomponent_assign): PDT array components must be
handles as if they are allocatable.
* trans-stmt.c (gfc_trans_allocate): Handle initialization of
PDT entities.
(gfc_trans_deallocate): Likewise.
* trans-types.c (gfc_get_derived_type): PDT templates must not
arrive here. PDT string components are handles as if deferred.
Similarly, PDT arrays are treated as if allocatable. PDT
strings are pointer types.
* trans.c (gfc_deferred_strlen): Handle PDT strings in the same
way as deferred characters.
2017-09-09 Paul Thomas <pault@gcc.gnu.org>
* gfortran.dg/pdt_1.f03 : New test.
* gfortran.dg/pdt_2.f03 : New test.
* gfortran.dg/pdt_3.f03 : New test.
* gfortran.dg/pdt_4.f03 : New test.
* gfortran.dg/pdt_5.f03 : New test.
From-SVN: r251925
Diffstat (limited to 'gcc/fortran/decl.c')
-rw-r--r-- | gcc/fortran/decl.c | 700 |
1 files changed, 693 insertions, 7 deletions
diff --git a/gcc/fortran/decl.c b/gcc/fortran/decl.c index b919f43..0609152 100644 --- a/gcc/fortran/decl.c +++ b/gcc/fortran/decl.c @@ -95,6 +95,15 @@ gfc_symbol *gfc_new_block; bool gfc_matching_function; +/* If a kind expression of a component of a parameterized derived type is + parameterized, temporarily store the expression here. */ +static gfc_expr *saved_kind_expr = NULL; + +/* Used to store the parameter list arising in a PDT declaration and + in the typespec of a PDT variable or component. */ +static gfc_actual_arglist *decl_type_param_list; +static gfc_actual_arglist *type_param_spec_list; + /********************* DATA statement subroutines *********************/ @@ -1500,6 +1509,11 @@ build_sym (const char *name, gfc_charlen *cl, bool cl_deferred, sym->attr.implied_index = 0; + /* Use the parameter expressions for a parameterized derived type. */ + if ((sym->ts.type == BT_DERIVED || sym->ts.type == BT_CLASS) + && sym->ts.u.derived->attr.pdt_type && type_param_spec_list) + sym->param_list = gfc_copy_actual_arglist (type_param_spec_list); + if (sym->ts.type == BT_CLASS) return gfc_build_class_symbol (&sym->ts, &sym->attr, &sym->as); @@ -1946,6 +1960,11 @@ build_struct (const char *name, gfc_charlen *cl, gfc_expr **init, c->ts = current_ts; if (c->ts.type == BT_CHARACTER) c->ts.u.cl = cl; + + if (c->ts.type != BT_CLASS && c->ts.type != BT_DERIVED + && c->ts.kind == 0 && saved_kind_expr != NULL) + c->kind_expr = gfc_copy_expr (saved_kind_expr); + c->attr = current_attr; c->initializer = *init; @@ -1999,6 +2018,31 @@ scalar: if (c->ts.type == BT_CLASS) return gfc_build_class_symbol (&c->ts, &c->attr, &c->as); + if (c->attr.pdt_kind || c->attr.pdt_len) + { + gfc_symbol *sym; + gfc_find_symbol (c->name, gfc_current_block ()->f2k_derived, + 0, &sym); + if (sym == NULL) + { + gfc_error ("Type parameter %qs at %C has no corresponding entry " + "in the type parameter name list at %L", + c->name, &gfc_current_block ()->declared_at); + return false; + } + sym->ts = c->ts; + sym->attr.pdt_kind = c->attr.pdt_kind; + sym->attr.pdt_len = c->attr.pdt_len; + if (c->initializer) + sym->value = gfc_copy_expr (c->initializer); + sym->attr.flavor = FL_VARIABLE; + } + + if ((c->ts.type == BT_DERIVED || c->ts.type == BT_CLASS) + && c->ts.u.derived && c->ts.u.derived->attr.pdt_template + && decl_type_param_list) + c->param_list = gfc_copy_actual_arglist (decl_type_param_list); + return true; } @@ -2612,6 +2656,7 @@ gfc_match_kind_spec (gfc_typespec *ts, bool kind_expr_only) m = MATCH_NO; n = MATCH_YES; e = NULL; + saved_kind_expr = NULL; where = loc = gfc_current_locus; @@ -2628,8 +2673,16 @@ gfc_match_kind_spec (gfc_typespec *ts, bool kind_expr_only) loc = gfc_current_locus; kind_expr: + n = gfc_match_init_expr (&e); + if (gfc_derived_parameter_expr (e)) + { + ts->kind = 0; + saved_kind_expr = gfc_copy_expr (e); + goto close_brackets; + } + if (n != MATCH_YES) { if (gfc_matching_function) @@ -2707,6 +2760,8 @@ kind_expr: "is %s", gfc_basic_typename (ts->f90_type), &where, gfc_basic_typename (ts->type)); +close_brackets: + gfc_gobble_whitespace (); if ((c = gfc_next_ascii_char ()) != ')' && (ts->type != BT_CHARACTER || c != ',')) @@ -3030,6 +3085,423 @@ match_record_decl (char *name) return MATCH_ERROR; } + +/* This function uses the gfc_actual_arglist 'type_param_spec_list' as a source + of expressions to substitute into the possibly parameterized expression + 'e'. Using a list is inefficient but should not be too bad since the + number of type parameters is not likely to be large. */ +static bool +insert_parameter_exprs (gfc_expr* e, gfc_symbol* sym ATTRIBUTE_UNUSED, + int* f) +{ + gfc_actual_arglist *param; + gfc_expr *copy; + + if (e->expr_type != EXPR_VARIABLE) + return false; + + gcc_assert (e->symtree); + if (e->symtree->n.sym->attr.pdt_kind + || (*f != 0 && e->symtree->n.sym->attr.pdt_len)) + { + for (param = type_param_spec_list; param; param = param->next) + if (strcmp (e->symtree->n.sym->name, param->name) == 0) + break; + + if (param) + { + copy = gfc_copy_expr (param->expr); + *e = *copy; + free (copy); + } + } + + return false; +} + + +bool +gfc_insert_kind_parameter_exprs (gfc_expr *e) +{ + return gfc_traverse_expr (e, NULL, &insert_parameter_exprs, 0); +} + + +bool +gfc_insert_parameter_exprs (gfc_expr *e, gfc_actual_arglist *param_list) +{ + gfc_actual_arglist *old_param_spec_list = type_param_spec_list; + type_param_spec_list = param_list; + return gfc_traverse_expr (e, NULL, &insert_parameter_exprs, 1); + type_param_spec_list = NULL; + type_param_spec_list = old_param_spec_list; +} + +/* Determines the instance of a parameterized derived type to be used by + matching determining the values of the kind parameters and using them + in the name of the instance. If the instance exists, it is used, otherwise + a new derived type is created. */ +match +gfc_get_pdt_instance (gfc_actual_arglist *param_list, gfc_symbol **sym, + gfc_actual_arglist **ext_param_list) +{ + /* The PDT template symbol. */ + gfc_symbol *pdt = *sym; + /* The symbol for the parameter in the template f2k_namespace. */ + gfc_symbol *param; + /* The hoped for instance of the PDT. */ + gfc_symbol *instance; + /* The list of parameters appearing in the PDT declaration. */ + gfc_formal_arglist *type_param_name_list; + /* Used to store the parameter specification list during recursive calls. */ + gfc_actual_arglist *old_param_spec_list; + /* Pointers to the parameter specification being used. */ + gfc_actual_arglist *actual_param; + gfc_actual_arglist *tail = NULL; + /* Used to build up the name of the PDT instance. The prefix uses 4 + characters and each KIND parameter 2 more. Allow 8 of the latter. */ + char name[GFC_MAX_SYMBOL_LEN + 21]; + + bool name_seen = (param_list == NULL); + bool assumed_seen = false; + bool deferred_seen = false; + bool spec_error = false; + int kind_value, i; + gfc_expr *kind_expr; + gfc_component *c1, *c2; + match m; + + type_param_spec_list = NULL; + + type_param_name_list = pdt->formal; + actual_param = param_list; + sprintf (name, "Pdt%s", pdt->name); + + /* Run through the parameter name list and pick up the actual + parameter values or use the default values in the PDT declaration. */ + for (; type_param_name_list; + type_param_name_list = type_param_name_list->next) + { + if (actual_param && actual_param->spec_type != SPEC_EXPLICIT) + { + if (actual_param->spec_type == SPEC_ASSUMED) + spec_error = deferred_seen; + else + spec_error = assumed_seen; + + if (spec_error) + { + gfc_error ("The type parameter spec list at %C cannot contain " + "both ASSUMED and DEFERRED parameters"); + gfc_free_actual_arglist (type_param_spec_list); + return MATCH_ERROR; + } + } + + if (actual_param && actual_param->name) + name_seen = true; + param = type_param_name_list->sym; + + kind_expr = NULL; + if (!name_seen) + { + if (actual_param && actual_param->spec_type == SPEC_EXPLICIT) + kind_expr = gfc_copy_expr (actual_param->expr); + } + else + { + actual_param = param_list; + for (;actual_param; actual_param = actual_param->next) + if (actual_param->name + && strcmp (actual_param->name, param->name) == 0) + break; + if (actual_param && actual_param->spec_type == SPEC_EXPLICIT) + kind_expr = gfc_copy_expr (actual_param->expr); + else + { + if (param->value) + kind_expr = gfc_copy_expr (param->value); + else if (!(actual_param && param->attr.pdt_len)) + { + gfc_error ("The derived parameter '%qs' at %C does not " + "have a default value", param->name); + return MATCH_ERROR; + } + } + } + + /* Store the current parameter expressions in a temporary actual + arglist 'list' so that they can be substituted in the corresponding + expressions in the PDT instance. */ + if (type_param_spec_list == NULL) + { + type_param_spec_list = gfc_get_actual_arglist (); + tail = type_param_spec_list; + } + else + { + tail->next = gfc_get_actual_arglist (); + tail = tail->next; + } + tail->name = param->name; + + if (kind_expr) + { + tail->expr = gfc_copy_expr (kind_expr); + /* Try simplification even for LEN expressions. */ + gfc_simplify_expr (tail->expr, 1); + } + + if (actual_param) + tail->spec_type = actual_param->spec_type; + + if (!param->attr.pdt_kind) + { + if (!name_seen) + actual_param = actual_param->next; + if (kind_expr) + { + gfc_free_expr (kind_expr); + kind_expr = NULL; + } + continue; + } + + if (actual_param + && (actual_param->spec_type == SPEC_ASSUMED + || actual_param->spec_type == SPEC_DEFERRED)) + { + gfc_error ("The KIND parameter '%qs' at %C cannot either be " + "ASSUMED or DEFERRED", param->name); + gfc_free_actual_arglist (type_param_spec_list); + return MATCH_ERROR; + } + + if (!kind_expr || !gfc_is_constant_expr (kind_expr)) + { + gfc_error ("The value for the KIND parameter '%qs' at %C does not " + "reduce to a constant expression", param->name); + gfc_free_actual_arglist (type_param_spec_list); + return MATCH_ERROR; + } + + gfc_extract_int (kind_expr, &kind_value); + sprintf (name, "%s_%d", name, kind_value); + + if (!name_seen && actual_param) + actual_param = actual_param->next; + gfc_free_expr (kind_expr); + } + + /* Now we search for the PDT instance 'name'. If it doesn't exist, we + build it, using 'pdt' as a template. */ + if (gfc_get_symbol (name, pdt->ns, &instance)) + { + gfc_error ("Parameterized derived type at %C is ambiguous"); + return MATCH_ERROR; + } + + m = MATCH_YES; + + if (instance->attr.flavor == FL_DERIVED + && instance->attr.pdt_type) + { + instance->refs++; + if (ext_param_list) + *ext_param_list = type_param_spec_list; + *sym = instance; + gfc_commit_symbols (); + return m; + } + + /* Start building the new instance of the parameterized type. */ + gfc_copy_attr (&instance->attr, &pdt->attr, &pdt->declared_at); + instance->attr.pdt_template = 0; + instance->attr.pdt_type = 1; + instance->declared_at = gfc_current_locus; + + /* Add the components, replacing the parameters in all expressions + with the expressions for their values in 'type_param_spec_list'. */ + c1 = pdt->components; + tail = type_param_spec_list; + for (; c1; c1 = c1->next) + { + gfc_add_component (instance, c1->name, &c2); + c2->ts = c1->ts; + c2->attr = c1->attr; + + /* Deal with type extension by recursively calling this function + to obtain the instance of the extended type. */ + if (gfc_current_state () != COMP_DERIVED + && c1 == pdt->components + && (c1->ts.type == BT_DERIVED || c1->ts.type == BT_CLASS) + && c1->ts.u.derived && c1->ts.u.derived->attr.pdt_template + && gfc_get_derived_super_type (*sym) == c2->ts.u.derived) + { + gfc_formal_arglist *f; + + old_param_spec_list = type_param_spec_list; + + /* Obtain a spec list appropriate to the extended type..*/ + actual_param = gfc_copy_actual_arglist (type_param_spec_list); + type_param_spec_list = actual_param; + for (f = c1->ts.u.derived->formal; f && f->next; f = f->next) + actual_param = actual_param->next; + if (actual_param) + { + gfc_free_actual_arglist (actual_param->next); + actual_param->next = NULL; + } + + /* Now obtain the PDT instance for the extended type. */ + c2->param_list = type_param_spec_list; + m = gfc_get_pdt_instance (type_param_spec_list, &c2->ts.u.derived, + NULL); + type_param_spec_list = old_param_spec_list; + + c2->ts.u.derived->refs++; + gfc_set_sym_referenced (c2->ts.u.derived); + + /* Set extension level. */ + if (c2->ts.u.derived->attr.extension == 255) + { + /* Since the extension field is 8 bit wide, we can only have + up to 255 extension levels. */ + gfc_error ("Maximum extension level reached with type %qs at %L", + c2->ts.u.derived->name, + &c2->ts.u.derived->declared_at); + return MATCH_ERROR; + } + instance->attr.extension = c2->ts.u.derived->attr.extension + 1; + + /* Advance the position in the spec list by the number of + parameters in the extended type. */ + tail = type_param_spec_list; + for (f = c1->ts.u.derived->formal; f && f->next; f = f->next) + tail = tail->next; + + continue; + } + + /* Set the component kind using the parameterized expression. */ + if (c1->ts.kind == 0 && c1->kind_expr != NULL) + { + gfc_expr *e = gfc_copy_expr (c1->kind_expr); + gfc_insert_kind_parameter_exprs (e); + gfc_extract_int (e, &c2->ts.kind); + gfc_free_expr (e); + } + + /* Similarly, set the string length if parameterized. */ + if (c1->ts.type == BT_CHARACTER + && c1->ts.u.cl->length + && gfc_derived_parameter_expr (c1->ts.u.cl->length)) + { + gfc_expr *e; + e = gfc_copy_expr (c1->ts.u.cl->length); + gfc_insert_kind_parameter_exprs (e); + gfc_simplify_expr (e, 1); + c2->ts.u.cl = gfc_new_charlen (gfc_current_ns, NULL); + c2->ts.u.cl->length = e; + c2->attr.pdt_string = 1; + } + + /* Set up either the KIND/LEN initializer, if constant, + or the parameterized expression. Use the template + initializer if one is not already set in this instance. */ + if (c2->attr.pdt_kind || c2->attr.pdt_len) + { + if (tail && tail->expr && gfc_is_constant_expr (tail->expr)) + c2->initializer = gfc_copy_expr (tail->expr); + else if (tail && tail->expr) + { + c2->param_list = gfc_get_actual_arglist (); + c2->param_list->name = tail->name; + c2->param_list->expr = gfc_copy_expr (tail->expr); + c2->param_list->next = NULL; + } + + if (!c2->initializer && c1->initializer) + c2->initializer = gfc_copy_expr (c1->initializer); + + tail = tail->next; + } + + /* Copy the array spec. */ + c2->as = gfc_copy_array_spec (c1->as); + if (c1->ts.type == BT_CLASS) + CLASS_DATA (c2)->as = gfc_copy_array_spec (CLASS_DATA (c1)->as); + + /* Determine if an array spec is parameterized. If so, substitute + in the parameter expressions for the bounds and set the pdt_array + attribute. Notice that this attribute must be unconditionally set + if this is an array of parameterized character length. */ + if (c1->as && c1->as->type == AS_EXPLICIT) + { + bool pdt_array = false; + + /* Are the bounds of the array parameterized? */ + for (i = 0; i < c1->as->rank; i++) + { + if (gfc_derived_parameter_expr (c1->as->lower[i])) + pdt_array = true; + if (gfc_derived_parameter_expr (c1->as->upper[i])) + pdt_array = true; + } + + /* If they are, free the expressions for the bounds and + replace them with the template expressions with substitute + values. */ + for (i = 0; pdt_array && i < c1->as->rank; i++) + { + gfc_expr *e; + e = gfc_copy_expr (c1->as->lower[i]); + gfc_insert_kind_parameter_exprs (e); + gfc_simplify_expr (e, 1); + gfc_free_expr (c2->as->lower[i]); + c2->as->lower[i] = e; + e = gfc_copy_expr (c1->as->upper[i]); + gfc_insert_kind_parameter_exprs (e); + gfc_simplify_expr (e, 1); + gfc_free_expr (c2->as->upper[i]); + c2->as->upper[i] = e; + } + c2->attr.pdt_array = pdt_array ? 1 : c2->attr.pdt_string; + } + + /* Recurse into this function for PDT components. */ + if ((c1->ts.type == BT_DERIVED || c1->ts.type == BT_CLASS) + && c1->ts.u.derived && c1->ts.u.derived->attr.pdt_template) + { + gfc_actual_arglist *params; + /* The component in the template has a list of specification + expressions derived from its declaration. */ + params = gfc_copy_actual_arglist (c1->param_list); + actual_param = params; + /* Substitute the template parameters with the expressions + from the specification list. */ + for (;actual_param; actual_param = actual_param->next) + gfc_insert_parameter_exprs (actual_param->expr, + type_param_spec_list); + + /* Now obtain the PDT instance for the component. */ + old_param_spec_list = type_param_spec_list; + m = gfc_get_pdt_instance (params, &c2->ts.u.derived, NULL); + type_param_spec_list = old_param_spec_list; + + c2->param_list = params; + c2->initializer = gfc_default_initializer (&c2->ts); + } + } + + gfc_commit_symbol (instance); + if (ext_param_list) + *ext_param_list = type_param_spec_list; + *sym = instance; + return m; +} + + /* Matches a declaration-type-spec (F03:R502). If successful, sets the ts structure to the matched specification. This is necessary for FUNCTION and IMPLICIT statements. @@ -3048,6 +3520,8 @@ gfc_match_decl_type_spec (gfc_typespec *ts, int implicit_flag) bool seen_deferred_kind, matched_type; const char *dt_name; + decl_type_param_list = NULL; + /* A belt and braces check that the typespec is correctly being treated as a deferred characteristic association. */ seen_deferred_kind = (gfc_current_state () == COMP_FUNCTION) @@ -3196,7 +3670,13 @@ gfc_match_decl_type_spec (gfc_typespec *ts, int implicit_flag) } if (matched_type) + { + m = gfc_match_actual_arglist (1, &decl_type_param_list, true); + if (m == MATCH_ERROR) + return m; + m = gfc_match_char (')'); + } if (m != MATCH_YES) m = match_record_decl (name); @@ -3211,6 +3691,19 @@ gfc_match_decl_type_spec (gfc_typespec *ts, int implicit_flag) gfc_error ("Type name %qs at %C is ambiguous", name); return MATCH_ERROR; } + + if (sym && sym->attr.flavor == FL_DERIVED + && sym->attr.pdt_template + && gfc_current_state () != COMP_DERIVED) + { + m = gfc_get_pdt_instance (decl_type_param_list, &sym, NULL); + if (m != MATCH_YES) + return m; + gcc_assert (!sym->attr.pdt_template && sym->attr.pdt_type); + ts->u.derived = sym; + strcpy (name, gfc_dt_lower_string (sym->name)); + } + if (sym && sym->attr.flavor == FL_STRUCT) { ts->u.derived = sym; @@ -3279,13 +3772,27 @@ gfc_match_decl_type_spec (gfc_typespec *ts, int implicit_flag) return m; } - m = gfc_match (" class ( %n )", name); + m = gfc_match (" class ("); + + if (m == MATCH_YES) + m = gfc_match ("%n", name); + else + return m; + if (m != MATCH_YES) return m; ts->type = BT_CLASS; if (!gfc_notify_std (GFC_STD_F2003, "CLASS statement at %C")) return MATCH_ERROR; + + m = gfc_match_actual_arglist (1, &decl_type_param_list, true); + if (m == MATCH_ERROR) + return m; + + m = gfc_match_char (')'); + if (m != MATCH_YES) + return m; } /* Defer association of the derived type until the end of the @@ -3351,6 +3858,18 @@ gfc_match_decl_type_spec (gfc_typespec *ts, int implicit_flag) return MATCH_ERROR; } + if (sym && sym->attr.flavor == FL_DERIVED + && sym->attr.pdt_template + && gfc_current_state () != COMP_DERIVED) + { + m = gfc_get_pdt_instance (decl_type_param_list, &sym, NULL); + if (m != MATCH_YES) + return m; + gcc_assert (!sym->attr.pdt_template && sym->attr.pdt_type); + ts->u.derived = sym; + strcpy (name, gfc_dt_lower_string (sym->name)); + } + gfc_save_symbol_data (sym); gfc_set_sym_referenced (sym); if (!sym->attr.generic @@ -3361,6 +3880,16 @@ gfc_match_decl_type_spec (gfc_typespec *ts, int implicit_flag) && !gfc_add_function (&sym->attr, sym->name, NULL)) return MATCH_ERROR; + if (dt_sym && dt_sym->attr.flavor == FL_DERIVED + && dt_sym->attr.pdt_template + && gfc_current_state () != COMP_DERIVED) + { + m = gfc_get_pdt_instance (decl_type_param_list, &dt_sym, NULL); + if (m != MATCH_YES) + return m; + gcc_assert (!dt_sym->attr.pdt_template && dt_sym->attr.pdt_type); + } + if (!dt_sym) { gfc_interface *intr, *head; @@ -3890,7 +4419,7 @@ match_attr_spec (void) DECL_STATIC, DECL_AUTOMATIC, DECL_PUBLIC, DECL_SAVE, DECL_TARGET, DECL_VALUE, DECL_VOLATILE, DECL_IS_BIND_C, DECL_CODIMENSION, DECL_ASYNCHRONOUS, DECL_CONTIGUOUS, - DECL_NONE, GFC_DECL_END /* Sentinel */ + DECL_LEN, DECL_KIND, DECL_NONE, GFC_DECL_END /* Sentinel */ }; /* GFC_DECL_END is the sentinel, index starts at 0. */ @@ -4033,6 +4562,16 @@ match_attr_spec (void) } break; + case 'k': + if (match_string_p ("kind")) + d = DECL_KIND; + break; + + case 'l': + if (match_string_p ("len")) + d = DECL_LEN; + break; + case 'o': if (match_string_p ("optional")) d = DECL_OPTIONAL; @@ -4226,6 +4765,12 @@ match_attr_spec (void) case DECL_OPTIONAL: attr = "OPTIONAL"; break; + case DECL_KIND: + attr = "KIND"; + break; + case DECL_LEN: + attr = "LEN"; + break; case DECL_PARAMETER: attr = "PARAMETER"; break; @@ -4307,6 +4852,54 @@ match_attr_spec (void) goto cleanup; } } + else if (d == DECL_KIND) + { + if (!gfc_notify_std (GFC_STD_F2003, "KIND " + "attribute at %C in a TYPE definition")) + { + m = MATCH_ERROR; + goto cleanup; + } + if (current_ts.type != BT_INTEGER) + { + gfc_error ("Component with KIND attribute at %C must be " + "INTEGER"); + m = MATCH_ERROR; + goto cleanup; + } + if (current_ts.kind != gfc_default_integer_kind) + { + gfc_error ("Component with KIND attribute at %C must be " + "default integer kind (%d)", + gfc_default_integer_kind); + m = MATCH_ERROR; + goto cleanup; + } + } + else if (d == DECL_LEN) + { + if (!gfc_notify_std (GFC_STD_F2003, "LEN " + "attribute at %C in a TYPE definition")) + { + m = MATCH_ERROR; + goto cleanup; + } + if (current_ts.type != BT_INTEGER) + { + gfc_error ("Component with LEN attribute at %C must be " + "INTEGER"); + m = MATCH_ERROR; + goto cleanup; + } + if (current_ts.kind != gfc_default_integer_kind) + { + gfc_error ("Component with LEN attribute at %C must be " + "default integer kind (%d)", + gfc_default_integer_kind); + m = MATCH_ERROR; + goto cleanup; + } + } else { gfc_error ("Attribute at %L is not allowed in a TYPE definition", @@ -4344,6 +4937,15 @@ match_attr_spec (void) } } + if (gfc_current_state () != COMP_DERIVED + && (d == DECL_KIND || d == DECL_LEN)) + { + gfc_error ("Attribute at %L is not allowed outside a TYPE " + "definition", &seen_at[d]); + m = MATCH_ERROR; + goto cleanup; + } + switch (d) { case DECL_ALLOCATABLE: @@ -4396,6 +4998,14 @@ match_attr_spec (void) t = gfc_add_optional (¤t_attr, &seen_at[d]); break; + case DECL_KIND: + t = gfc_add_kind (¤t_attr, &seen_at[d]); + break; + + case DECL_LEN: + t = gfc_add_len (¤t_attr, &seen_at[d]); + break; + case DECL_PARAMETER: t = gfc_add_flavor (¤t_attr, FL_PARAMETER, NULL, &seen_at[d]); break; @@ -4886,6 +5496,9 @@ gfc_match_data_decl (void) match m; int elem; + type_param_spec_list = NULL; + decl_type_param_list = NULL; + num_idents_on_line = 0; m = gfc_match_decl_type_spec (¤t_ts, 0); @@ -5000,6 +5613,13 @@ ok: gfc_free_data_all (gfc_current_ns); cleanup: + if (saved_kind_expr) + gfc_free_expr (saved_kind_expr); + if (type_param_spec_list) + gfc_free_actual_arglist (type_param_spec_list); + if (decl_type_param_list) + gfc_free_actual_arglist (decl_type_param_list); + saved_kind_expr = NULL; gfc_free_array_spec (current_as); current_as = NULL; return m; @@ -5173,10 +5793,12 @@ copy_prefix (symbol_attribute *dest, locus *where) } -/* Match a formal argument list. */ +/* Match a formal argument list or, if typeparam is true, a + type_param_name_list. */ match -gfc_match_formal_arglist (gfc_symbol *progname, int st_flag, int null_flag) +gfc_match_formal_arglist (gfc_symbol *progname, int st_flag, + int null_flag, bool typeparam) { gfc_formal_arglist *head, *tail, *p, *q; char name[GFC_MAX_SYMBOL_LEN + 1]; @@ -5228,7 +5850,10 @@ gfc_match_formal_arglist (gfc_symbol *progname, int st_flag, int null_flag) if (m != MATCH_YES) goto cleanup; - if (gfc_get_symbol (name, NULL, &sym)) + if (!typeparam && gfc_get_symbol (name, NULL, &sym)) + goto cleanup; + else if (typeparam + && gfc_get_symbol (name, progname->f2k_derived, &sym)) goto cleanup; } @@ -8945,6 +9570,8 @@ gfc_match_derived_decl (void) match is_type_attr_spec = MATCH_NO; bool seen_attr = false; gfc_interface *intr = NULL, *head; + bool parameterized_type = false; + bool seen_colons = false; if (gfc_comp_struct (gfc_current_state ())) return MATCH_NO; @@ -8972,16 +9599,38 @@ gfc_match_derived_decl (void) if (parent[0] && !extended) return MATCH_ERROR; - if (gfc_match (" ::") != MATCH_YES && seen_attr) + m = gfc_match (" ::"); + if (m == MATCH_YES) + { + seen_colons = true; + } + else if (seen_attr) { gfc_error ("Expected :: in TYPE definition at %C"); return MATCH_ERROR; } - m = gfc_match (" %n%t", name); + m = gfc_match (" %n ", name); if (m != MATCH_YES) return m; + /* Make sure that we don't identify TYPE IS (...) as a parameterized + derived type named 'is'. + TODO Expand the check, when 'name' = "is" by matching " (tname) " + and checking if this is a(n intrinsic) typename. his picks up + misplaced TYPE IS statements such as in select_type_1.f03. */ + if (gfc_peek_ascii_char () == '(') + { + if (gfc_current_state () == COMP_SELECT_TYPE + || (!seen_colons && !strcmp (name, "is"))) + return MATCH_NO; + parameterized_type = true; + } + + m = gfc_match_eos (); + if (m != MATCH_YES && !parameterized_type) + return m; + /* Make sure the name is not the name of an intrinsic type. */ if (gfc_is_intrinsic_typename (name)) { @@ -9062,9 +9711,21 @@ gfc_match_derived_decl (void) if (!sym->f2k_derived) sym->f2k_derived = gfc_get_namespace (NULL, 0); + if (parameterized_type) + { + m = gfc_match_formal_arglist (sym, 0, 0, true); + if (m != MATCH_YES) + return m; + m = gfc_match_eos (); + if (m != MATCH_YES) + return m; + sym->attr.pdt_template = 1; + } + if (extended && !sym->components) { gfc_component *p; + gfc_formal_arglist *f, *g, *h; /* Add the extended derived type as the first component. */ gfc_add_component (sym, parent, &p); @@ -9089,6 +9750,31 @@ gfc_match_derived_decl (void) /* Provide the links between the extended type and its extension. */ if (!extended->f2k_derived) extended->f2k_derived = gfc_get_namespace (NULL, 0); + + /* Copy the extended type-param-name-list from the extended type, + append those of the extension and add the whole lot to the + extension. */ + if (extended->attr.pdt_template) + { + g = h = NULL; + sym->attr.pdt_template = 1; + for (f = extended->formal; f; f = f->next) + { + if (f == extended->formal) + { + g = gfc_get_formal_arglist (); + h = g; + } + else + { + g->next = gfc_get_formal_arglist (); + g = g->next; + } + g->sym = f->sym; + } + g->next = sym->formal; + sym->formal = h; + } } if (!sym->hash_value) |