+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-01 Jakub Jelinek <jakub@redhat.com>
PR c/81887
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 *********************/
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);
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;
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;
}
m = MATCH_NO;
n = MATCH_YES;
e = NULL;
+ saved_kind_expr = NULL;
where = loc = gfc_current_locus;
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)
"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 != ','))
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.
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)
}
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);
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;
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
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
&& !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;
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. */
}
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;
case DECL_OPTIONAL:
attr = "OPTIONAL";
break;
+ case DECL_KIND:
+ attr = "KIND";
+ break;
+ case DECL_LEN:
+ attr = "LEN";
+ break;
case DECL_PARAMETER:
attr = "PARAMETER";
break;
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",
}
}
+ 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:
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;
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);
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;
}
-/* 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];
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;
}
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;
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))
{
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);
/* 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)
show_attr (symbol_attribute *attr, const char * module)
{
if (attr->flavor != FL_UNKNOWN)
+ {
+ if (attr->flavor == FL_DERIVED && attr->pdt_template)
+ fputs (" (PDT template", dumpfile);
+ else
fprintf (dumpfile, "(%s ", gfc_code2string (flavors, attr->flavor));
+ }
if (attr->access != ACCESS_UNKNOWN)
fprintf (dumpfile, "%s ", gfc_code2string (access_types, attr->access));
if (attr->proc != PROC_UNKNOWN)
fputs (" INTRINSIC", dumpfile);
if (attr->optional)
fputs (" OPTIONAL", dumpfile);
+ if (attr->pdt_kind)
+ fputs (" KIND", dumpfile);
+ if (attr->pdt_len)
+ fputs (" LEN", dumpfile);
if (attr->pointer)
fputs (" POINTER", dumpfile);
if (attr->is_protected)
for (c = sym->components; c; c = c->next)
{
+ show_indent ();
fprintf (dumpfile, "(%s ", c->name);
show_typespec (&c->ts);
+ if (c->kind_expr)
+ {
+ fputs (" kind_expr: ", dumpfile);
+ show_expr (c->kind_expr);
+ }
+ if (c->param_list)
+ {
+ fputs ("PDT parameters", dumpfile);
+ show_actual_arglist (c->param_list);
+ }
+
if (c->attr.allocatable)
fputs (" ALLOCATABLE", dumpfile);
+ if (c->attr.pdt_kind)
+ fputs (" KIND", dumpfile);
+ if (c->attr.pdt_len)
+ fputs (" LEN", dumpfile);
if (c->attr.pointer)
fputs (" POINTER", dumpfile);
if (c->attr.proc_pointer)
fputs ("Formal namespace", dumpfile);
show_namespace (sym->formal_ns);
}
+
+ if (sym->attr.flavor == FL_VARIABLE
+ && sym->param_list)
+ {
+ show_indent ();
+ fputs ("PDT parameters", dumpfile);
+ show_actual_arglist (sym->param_list);
+
+ }
--show_level;
}
q->ref = gfc_copy_ref (p->ref);
+ if (p->param_list)
+ q->param_list = gfc_copy_actual_arglist (p->param_list);
+
return q;
}
gfc_free_ref_list (e->ref);
+ gfc_free_actual_arglist (e->param_list);
+
memset (e, '\0', sizeof (gfc_expr));
}
while (a1)
{
a2 = a1->next;
+ if (a1->expr)
gfc_free_expr (a1->expr);
free (a1);
a1 = a2;
|| gfc_is_constant_expr (e->value.op.op2)));
case EXPR_VARIABLE:
+ /* The only context in which this can occur is in a parameterized
+ derived type declaration, so returning true is OK. */
+ if (e->symtree->n.sym->attr.pdt_len
+ || e->symtree->n.sym->attr.pdt_kind)
+ return true;
return false;
case EXPR_FUNCTION:
case EXPR_VARIABLE:
t = true;
+ /* This occurs when parsing pdt templates. */
+ if (e->symtree->n.sym->attr.pdt_kind)
+ break;
+
if (gfc_check_iter_variable (e))
break;
return m;
}
+ if (gfc_derived_parameter_expr (expr))
+ {
+ *result = expr;
+ gfc_init_expr_flag = false;
+ return m;
+ }
+
t = gfc_reduce_init_expr (expr);
if (!t)
{
}
}
+ if (gfc_expr_attr (lvalue).pdt_kind || gfc_expr_attr (lvalue).pdt_len)
+ {
+ gfc_error ("The assignment to a KIND or LEN component of a "
+ "parameterized type at %L is not allowed",
+ &lvalue->where);
+ return false;
+ }
+
if (gfc_compare_types (&lvalue->ts, &rvalue->ts))
return true;
}
+/* This function returns true if it contains any references to PDT KIND
+ or LEN parameters. */
+
+static bool
+derived_parameter_expr (gfc_expr* e, gfc_symbol* sym ATTRIBUTE_UNUSED,
+ int* f ATTRIBUTE_UNUSED)
+{
+ if (e->expr_type != EXPR_VARIABLE)
+ return false;
+
+ gcc_assert (e->symtree);
+ if (e->symtree->n.sym->attr.pdt_kind
+ || e->symtree->n.sym->attr.pdt_len)
+ return true;
+
+ return false;
+}
+
+
+bool
+gfc_derived_parameter_expr (gfc_expr *e)
+{
+ return gfc_traverse_expr (e, NULL, &derived_parameter_expr, 0);
+}
+
+
+/* This function returns the overall type of a type parameter spec list.
+ If all the specs are explicit, SPEC_EXPLICIT is returned. If any of the
+ parameters are assumed/deferred then SPEC_ASSUMED/DEFERRED is returned
+ unless derived is not NULL. In this latter case, all the LEN parameters
+ must be either assumed or deferred for the return argument to be set to
+ anything other than SPEC_EXPLICIT. */
+
+gfc_param_spec_type
+gfc_spec_list_type (gfc_actual_arglist *param_list, gfc_symbol *derived)
+{
+ gfc_param_spec_type res = SPEC_EXPLICIT;
+ gfc_component *c;
+ bool seen_assumed = false;
+ bool seen_deferred = false;
+
+ if (derived == NULL)
+ {
+ for (; param_list; param_list = param_list->next)
+ if (param_list->spec_type == SPEC_ASSUMED
+ || param_list->spec_type == SPEC_DEFERRED)
+ return param_list->spec_type;
+ }
+ else
+ {
+ for (; param_list; param_list = param_list->next)
+ {
+ c = gfc_find_component (derived, param_list->name,
+ true, true, NULL);
+ gcc_assert (c != NULL);
+ if (c->attr.pdt_kind)
+ continue;
+ else if (param_list->spec_type == SPEC_EXPLICIT)
+ return SPEC_EXPLICIT;
+ seen_assumed = param_list->spec_type == SPEC_ASSUMED;
+ seen_deferred = param_list->spec_type == SPEC_DEFERRED;
+ if (seen_assumed && seen_deferred)
+ return SPEC_EXPLICIT;
+ }
+ res = seen_assumed ? SPEC_ASSUMED : SPEC_DEFERRED;
+ }
+ return res;
+}
+
+
bool
gfc_ref_this_image (gfc_ref *ref)
{
GFC_INHIBIT_REVERSE
};
+enum gfc_param_spec_type
+{
+ SPEC_EXPLICIT,
+ SPEC_ASSUMED,
+ SPEC_DEFERRED
+};
+
/************************* Structures *****************************/
/* Used for keeping things in balanced binary trees. */
variable for SELECT_TYPE or ASSOCIATE. */
unsigned select_type_temporary:1, associate_var:1;
+ /* These are the attributes required for parameterized derived
+ types. */
+ unsigned pdt_kind:1, pdt_len:1, pdt_type:1, pdt_template:1,
+ pdt_array:1, pdt_string:1;
+
/* This is omp_{out,in,priv,orig} artificial variable in
!$OMP DECLARE REDUCTION. */
unsigned omp_udr_artificial_var:1;
tree norestrict_decl;
locus loc;
struct gfc_expr *initializer;
+ /* Used in parameterized derived type declarations to store parameterized
+ kind expressions. */
+ struct gfc_expr *kind_expr;
+ struct gfc_actual_arglist *param_list;
+
struct gfc_component *next;
/* Needed for procedure pointer components. */
#define gfc_get_formal_arglist() XCNEW (gfc_formal_arglist)
-/* The gfc_actual_arglist structure is for actual arguments. */
+/* The gfc_actual_arglist structure is for actual arguments and
+ for type parameter specification lists. */
typedef struct gfc_actual_arglist
{
const char *name;
argument has to be added to a function call. */
bt missing_arg_type;
+ gfc_param_spec_type spec_type;
+
struct gfc_expr *expr;
struct gfc_actual_arglist *next;
}
struct gfc_namespace *formal_ns;
struct gfc_namespace *f2k_derived;
+ /* List of PDT parameter expressions */
+ struct gfc_actual_arglist *param_list;
+
struct gfc_expr *value; /* Parameter/Initializer value */
gfc_array_spec *as;
struct gfc_symbol *result; /* function result symbol */
}
value;
+ /* Used to store PDT expression lists associated with expressions. */
+ gfc_actual_arglist *param_list;
+
}
gfc_expr;
bool gfc_in_match_data (void);
match gfc_match_char_spec (gfc_typespec *);
+/* Handling Parameterized Derived Types */
+bool gfc_insert_kind_parameter_exprs (gfc_expr *);
+bool gfc_insert_parameter_exprs (gfc_expr *, gfc_actual_arglist *);
+match gfc_get_pdt_instance (gfc_actual_arglist *, gfc_symbol **,
+ gfc_actual_arglist **);
+
/* scanner.c */
void gfc_scanner_done_1 (void);
void gfc_scanner_init_1 (void);
bool gfc_add_external (symbol_attribute *, locus *);
bool gfc_add_intrinsic (symbol_attribute *, locus *);
bool gfc_add_optional (symbol_attribute *, locus *);
+bool gfc_add_kind (symbol_attribute *, locus *);
+bool gfc_add_len (symbol_attribute *, locus *);
bool gfc_add_pointer (symbol_attribute *, locus *);
bool gfc_add_cray_pointer (symbol_attribute *, locus *);
bool gfc_add_cray_pointee (symbol_attribute *, locus *);
int);
void gfc_expr_set_symbols_referenced (gfc_expr *);
bool gfc_expr_check_typed (gfc_expr*, gfc_namespace*, bool);
-
+bool gfc_derived_parameter_expr (gfc_expr *);
+gfc_param_spec_type gfc_spec_list_type (gfc_actual_arglist *, gfc_symbol *);
gfc_component * gfc_get_proc_ptr_comp (gfc_expr *);
bool gfc_is_proc_ptr_comp (gfc_expr *);
bool gfc_is_alloc_class_scalar_function (gfc_expr *);
return false;
if (!(derived1->attr.sequence && derived2->attr.sequence)
- && !(derived1->attr.is_bind_c && derived2->attr.is_bind_c))
+ && !(derived1->attr.is_bind_c && derived2->attr.is_bind_c)
+ && !(derived1->attr.pdt_type && derived2->attr.pdt_type))
return false;
/* Protect against null components. */
/* Stack of SELECT TYPE statements. */
gfc_select_type_stack *select_type_stack = NULL;
+/* List of type parameter expressions. */
+gfc_actual_arglist *type_param_spec_list;
+
/* For debugging and diagnostic purposes. Return the textual representation
of the intrinsic operator OP. */
const char *
(1) If any user defined operator ".y." exists, this is always y(x,z)
(even if ".y." is the wrong type and/or x has a member y).
(2) Otherwise if x has a member y, and y is itself a derived type,
- this is (x->y)->z, even if an intrinsic operator exists which
- can handle (x,z).
- (3) If x has no member y or (x->y) is not a derived type but ".y."
+ this is (x->y)->z, even if an intrinsic operator exists which
+ can handle (x,z).
+ (3) If x has no member y or (x->y) is not a derived type but ".y."
is an intrinsic operator (such as ".eq."), this is y(x,z).
(4) Lastly if there is no operator ".y." and x has no member "y", it is an
- error.
+ error.
It is worth noting that the logic here does not support mixed use of member
accessors within a single string. That is, even if x has component y and y
has component z, the following are all syntax errors:
tsym = NULL;
/* We may be given either a derived type variable or the derived type
- declaration itself (which actually contains the components);
+ declaration itself (which actually contains the components);
we need the latter to search for components. */
if (gfc_fl_struct (sym->attr.flavor))
tsym = sym;
if (gfc_find_uop (name, sym->ns) != NULL)
goto no;
- /* Match accesses to existing derived-type components for
+ /* Match accesses to existing derived-type components for
derived-type vars: "x.y.z" = (x->y)->z */
c = gfc_find_component(tsym, name, false, true, NULL);
if (c && (gfc_bt_struct (c->ts.type) || c->ts.type == BT_CLASS))
if (gfc_match_intrinsic_op (&iop) != MATCH_YES)
{
/* If ".y." is not an intrinsic operator but y was a valid non-
- structure component, match and leave the trailing dot to be
+ structure component, match and leave the trailing dot to be
dealt with later. */
if (c)
goto yes;
return MATCH_ERROR;
}
- if (!gfc_add_flavor (&gfc_new_block->attr, FL_LABEL,
+ if (!gfc_add_flavor (&gfc_new_block->attr, FL_LABEL,
gfc_new_block->name, NULL))
return MATCH_ERROR;
{
char name[GFC_MAX_SYMBOL_LEN + 1];
locus old_locus;
- gfc_symbol *derived;
+ gfc_symbol *derived, *der_type;
+ match m = MATCH_YES;
+ gfc_actual_arglist *decl_type_param_list = NULL;
+ bool is_pdt_template = false;
old_locus = gfc_current_locus;
gfc_find_symbol (name, NULL, 1, &derived);
+ /* Match the PDT spec list, if there. */
+ if (derived && derived->attr.flavor == FL_PROCEDURE)
+ {
+ gfc_find_symbol (gfc_dt_upper_string (name), NULL, 1, &der_type);
+ is_pdt_template = der_type
+ && der_type->attr.flavor == FL_DERIVED
+ && der_type->attr.pdt_template;
+ }
+
+ if (is_pdt_template)
+ m = gfc_match_actual_arglist (1, &decl_type_param_list, true);
+
+ if (m == MATCH_ERROR)
+ {
+ gfc_free_actual_arglist (decl_type_param_list);
+ return m;
+ }
+
if (derived && derived->attr.flavor == FL_PROCEDURE && derived->attr.generic)
derived = gfc_find_dt_in_generic (derived);
+ /* If this is a PDT, find the specific instance. */
+ if (m == MATCH_YES && is_pdt_template)
+ {
+ gfc_namespace *old_ns;
+
+ old_ns = gfc_current_ns;
+ while (gfc_current_ns && gfc_current_ns->parent)
+ gfc_current_ns = gfc_current_ns->parent;
+
+ if (type_param_spec_list)
+ gfc_free_actual_arglist (type_param_spec_list);
+ m = gfc_get_pdt_instance (decl_type_param_list, &der_type,
+ &type_param_spec_list);
+ gfc_free_actual_arglist (decl_type_param_list);
+
+ if (m != MATCH_YES)
+ return m;
+ derived = der_type;
+ gcc_assert (!derived->attr.pdt_template && derived->attr.pdt_type);
+ gfc_set_sym_referenced (derived);
+
+ gfc_current_ns = old_ns;
+ }
+
if (derived && derived->attr.flavor == FL_DERIVED)
{
ts->type = BT_DERIVED;
gfc_clear_ts (ts);
gfc_gobble_whitespace ();
old_locus = gfc_current_locus;
+ type_param_spec_list = NULL;
if (match_derived_type_spec (ts) == MATCH_YES)
{
| GFC_STD_F2008_OBS);
/* Set f03 for -std=f2003. */
- f03 = gfc_option.allow_std == (GFC_STD_F95_OBS | GFC_STD_F95 | GFC_STD_F77
+ f03 = gfc_option.allow_std == (GFC_STD_F95_OBS | GFC_STD_F95 | GFC_STD_F77
| GFC_STD_F2008_OBS | GFC_STD_F2003);
/* Look for a blank between STOP and the stop-code for F2008 or later. */
{
if (gfc_match (" :: ") == MATCH_YES)
{
- if (!gfc_notify_std (GFC_STD_F2003, "typespec in ALLOCATE at %L",
+ if (!gfc_notify_std (GFC_STD_F2003, "typespec in ALLOCATE at %L",
&old_locus))
goto cleanup;
if (ts.type == BT_CHARACTER)
ts.u.cl->length_from_typespec = true;
+
+ /* TODO understand why this error does not appear but, instead,
+ the derived type is caught as a variable in primary.c. */
+ if (gfc_spec_list_type (type_param_spec_list, NULL) != SPEC_EXPLICIT)
+ {
+ gfc_error ("The type parameter spec list in the type-spec at "
+ "%L cannot contain ASSUMED or DEFERRED parameters",
+ &old_locus);
+ goto cleanup;
+ }
}
else
{
if (tail->expr->ts.type == BT_DERIVED)
tail->expr->ts.u.derived = gfc_use_derived (tail->expr->ts.u.derived);
+ if (type_param_spec_list)
+ tail->expr->param_list = gfc_copy_actual_arglist (type_param_spec_list);
+
saw_unlimited = saw_unlimited | UNLIMITED_POLY (tail->expr);
if (gfc_peek_ascii_char () == '(' && !sym->attr.dimension)
if (head->next
&& !gfc_notify_std (GFC_STD_F2008, "SOURCE tag at %L"
- " with more than a single allocate object",
+ " with more than a single allocate object",
&tmp->where))
goto cleanup;
new_st.ext.alloc.list = head;
new_st.ext.alloc.ts = ts;
+ if (type_param_spec_list)
+ gfc_free_actual_arglist (type_param_spec_list);
+
return MATCH_YES;
syntax:
gfc_free_expr (mold);
if (tmp && tmp->expr_type) gfc_free_expr (tmp);
gfc_free_alloc_list (head);
+ if (type_param_spec_list)
+ gfc_free_actual_arglist (type_param_spec_list);
return MATCH_ERROR;
}
|| sym->attr.data) && gfc_current_state () != COMP_BLOCK_DATA)
{
if (!gfc_notify_std (GFC_STD_GNU, "Initialized symbol %qs at "
- "%C can only be COMMON in BLOCK DATA",
+ "%C can only be COMMON in BLOCK DATA",
sym->name))
goto cleanup;
}
return MATCH_ERROR;
if (group_name->attr.flavor != FL_NAMELIST
- && !gfc_add_flavor (&group_name->attr, FL_NAMELIST,
+ && !gfc_add_flavor (&group_name->attr, FL_NAMELIST,
group_name->name, NULL))
return MATCH_ERROR;
if (m != MATCH_YES)
return m;
- if (!gfc_add_flavor (&gfc_new_block->attr, FL_MODULE,
+ if (!gfc_add_flavor (&gfc_new_block->attr, FL_MODULE,
gfc_new_block->name, NULL))
return MATCH_ERROR;
return MATCH_ERROR;
}
+ if (c->ts.type == BT_DERIVED
+ && c->ts.u.derived && c->ts.u.derived->attr.pdt_type
+ && gfc_spec_list_type (type_param_spec_list, c->ts.u.derived)
+ != SPEC_ASSUMED)
+ {
+ gfc_error ("All the LEN type parameters in the TYPE IS statement "
+ "at %C must be ASSUMED");
+ return MATCH_ERROR;
+ }
+
/* Create temporary variable. */
select_type_set_tmp (&c->ts);
return MATCH_YES;
syntax:
- gfc_error ("Syntax error in TYPE IS specification at %C");
+ gfc_error ("Ssyntax error in TYPE IS specification at %C");
cleanup:
if (c != NULL)
match gfc_match_end (gfc_statement *);
match gfc_match_data_decl (void);
-match gfc_match_formal_arglist (gfc_symbol *, int, int);
+match gfc_match_formal_arglist (gfc_symbol *, int, int, bool = false);
match gfc_match_procedure (void);
match gfc_match_generic (void);
match gfc_match_function_decl (void);
match gfc_match_structure_constructor (gfc_symbol *, gfc_expr **);
match gfc_match_variable (gfc_expr **, int);
match gfc_match_equiv_variable (gfc_expr **);
-match gfc_match_actual_arglist (int, gfc_actual_arglist **);
+match gfc_match_actual_arglist (int, gfc_actual_arglist **, bool = false);
match gfc_match_literal_constant (gfc_expr **, int);
/* expr.c -- FIXME: this one should be eliminated by moving the
AB_ARRAY_OUTER_DEPENDENCY, AB_MODULE_PROCEDURE, AB_OACC_DECLARE_CREATE,
AB_OACC_DECLARE_COPYIN, AB_OACC_DECLARE_DEVICEPTR,
AB_OACC_DECLARE_DEVICE_RESIDENT, AB_OACC_DECLARE_LINK,
- AB_OMP_DECLARE_TARGET_LINK
+ AB_OMP_DECLARE_TARGET_LINK, AB_PDT_KIND, AB_PDT_LEN, AB_PDT_TYPE,
+ AB_PDT_TEMPLATE, AB_PDT_ARRAY, AB_PDT_STRING
};
static const mstring attr_bits[] =
minit ("OACC_DECLARE_DEVICE_RESIDENT", AB_OACC_DECLARE_DEVICE_RESIDENT),
minit ("OACC_DECLARE_LINK", AB_OACC_DECLARE_LINK),
minit ("OMP_DECLARE_TARGET_LINK", AB_OMP_DECLARE_TARGET_LINK),
+ minit ("PDT_KIND", AB_PDT_KIND),
+ minit ("PDT_LEN", AB_PDT_LEN),
+ minit ("PDT_TYPE", AB_PDT_TYPE),
+ minit ("PDT_TEMPLATE", AB_PDT_TEMPLATE),
+ minit ("PDT_ARRAY", AB_PDT_ARRAY),
+ minit ("PDT_STRING", AB_PDT_STRING),
minit (NULL, -1)
};
MIO_NAME (ab_attribute) (AB_OACC_DECLARE_LINK, attr_bits);
if (attr->omp_declare_target_link)
MIO_NAME (ab_attribute) (AB_OMP_DECLARE_TARGET_LINK, attr_bits);
+ if (attr->pdt_kind)
+ MIO_NAME (ab_attribute) (AB_PDT_KIND, attr_bits);
+ if (attr->pdt_len)
+ MIO_NAME (ab_attribute) (AB_PDT_LEN, attr_bits);
+ if (attr->pdt_type)
+ MIO_NAME (ab_attribute) (AB_PDT_TYPE, attr_bits);
+ if (attr->pdt_template)
+ MIO_NAME (ab_attribute) (AB_PDT_TEMPLATE, attr_bits);
+ if (attr->pdt_array)
+ MIO_NAME (ab_attribute) (AB_PDT_ARRAY, attr_bits);
+ if (attr->pdt_string)
+ MIO_NAME (ab_attribute) (AB_PDT_STRING, attr_bits);
mio_rparen ();
case AB_OACC_DECLARE_LINK:
attr->oacc_declare_link = 1;
break;
+ case AB_PDT_KIND:
+ attr->pdt_kind = 1;
+ break;
+ case AB_PDT_LEN:
+ attr->pdt_len = 1;
+ break;
+ case AB_PDT_TYPE:
+ attr->pdt_type = 1;
+ break;
+ case AB_PDT_TEMPLATE:
+ attr->pdt_template = 1;
+ break;
+ case AB_PDT_ARRAY:
+ attr->pdt_array = 1;
+ break;
+ case AB_PDT_STRING:
+ attr->pdt_string = 1;
+ break;
}
}
}
mio_typespec (&c->ts);
mio_array_spec (&c->as);
+ /* PDT templates store the expression for the kind of a component here. */
+ mio_expr (&c->kind_expr);
+
mio_symbol_attribute (&c->attr);
if (c->ts.type == BT_CLASS)
c->attr.class_ok = 1;
{
if (peek_atom () != ATOM_RPAREN)
{
+ gfc_namespace *ns;
+
sym->f2k_derived = gfc_get_namespace (NULL, 0);
+
+ /* PDT templates make use of the mechanisms for formal args
+ and so the parameter symbols are stored in the formal
+ namespace. Transfer the sym_root to f2k_derived and then
+ free the formal namespace since it is uneeded. */
+ if (sym->attr.pdt_template && sym->formal && sym->formal->sym)
+ {
+ ns = sym->formal->sym->ns;
+ sym->f2k_derived->sym_root = ns->sym_root;
+ ns->sym_root = NULL;
+ ns->refs++;
+ gfc_free_namespace (ns);
+ ns = NULL;
+ }
+
mio_f2k_derived (sym->f2k_derived);
}
else
}
-/* Match a keyword argument. */
+/* Match a keyword argument or type parameter spec list.. */
static match
-match_keyword_arg (gfc_actual_arglist *actual, gfc_actual_arglist *base)
+match_keyword_arg (gfc_actual_arglist *actual, gfc_actual_arglist *base, bool pdt)
{
char name[GFC_MAX_SYMBOL_LEN + 1];
gfc_actual_arglist *a;
goto cleanup;
}
+ if (pdt)
+ {
+ if (gfc_match_char ('*') == MATCH_YES)
+ {
+ actual->spec_type = SPEC_ASSUMED;
+ goto add_name;
+ }
+ else if (gfc_match_char (':') == MATCH_YES)
+ {
+ actual->spec_type = SPEC_DEFERRED;
+ goto add_name;
+ }
+ else
+ actual->spec_type = SPEC_EXPLICIT;
+ }
+
m = match_actual_arg (&actual->expr);
if (m != MATCH_YES)
goto cleanup;
/* Make sure this name has not appeared yet. */
-
+add_name:
if (name[0] != '\0')
{
for (a = base; a; a = a->next)
list is assumed to allow keyword arguments because we don't know if
the symbol associated with the procedure has an implicit interface
or not. We make sure keywords are unique. If sub_flag is set,
- we're matching the argument list of a subroutine. */
+ we're matching the argument list of a subroutine.
+
+ NOTE: An alternative use for this function is to match type parameter
+ spec lists, which are so similar to actual argument lists that the
+ machinery can be reused. This use is flagged by the optional argument
+ 'pdt'. */
match
-gfc_match_actual_arglist (int sub_flag, gfc_actual_arglist **argp)
+gfc_match_actual_arglist (int sub_flag, gfc_actual_arglist **argp, bool pdt)
{
gfc_actual_arglist *head, *tail;
int seen_keyword;
if (gfc_match_char (')') == MATCH_YES)
return MATCH_YES;
+
head = NULL;
matching_actual_arglist++;
tail = tail->next;
}
- if (sub_flag && gfc_match_char ('*') == MATCH_YES)
+ if (sub_flag && !pdt && gfc_match_char ('*') == MATCH_YES)
{
+ if (pdt)
+ {
+ tail->spec_type = SPEC_ASSUMED;
+ goto next;
+ }
m = gfc_match_st_label (&label);
if (m == MATCH_NO)
gfc_error ("Expected alternate return label at %C");
goto next;
}
+ if (pdt && !seen_keyword)
+ {
+ if (gfc_match_char (':') == MATCH_YES)
+ {
+ tail->spec_type = SPEC_DEFERRED;
+ goto next;
+ }
+ else if (gfc_match_char ('*') == MATCH_YES)
+ {
+ tail->spec_type = SPEC_ASSUMED;
+ goto next;
+ }
+ else
+ tail->spec_type = SPEC_EXPLICIT;
+ }
+
/* After the first keyword argument is seen, the following
arguments must also have keywords. */
if (seen_keyword)
{
- m = match_keyword_arg (tail, head);
+ m = match_keyword_arg (tail, head, pdt);
if (m == MATCH_ERROR)
goto cleanup;
/* See if we have the first keyword argument. */
if (m == MATCH_NO)
{
- m = match_keyword_arg (tail, head);
+ m = match_keyword_arg (tail, head, false);
if (m == MATCH_YES)
seen_keyword = 1;
if (m == MATCH_ERROR)
expression here. */
if (gfc_in_match_data ())
gfc_reduce_init_expr (e);
-
+
*result = e;
return MATCH_YES;
}
implicit_ns = gfc_current_ns;
else
implicit_ns = sym->ns;
-
+
old_loc = gfc_current_locus;
if (gfc_match_member_sep (sym) == MATCH_YES
&& sym->ts.type == BT_UNKNOWN
}
+
+/* A Parameterized Derived Type constructor must contain values for
+ the PDT KIND parameters or they must have a default initializer.
+ Go through the constructor picking out the KIND expressions,
+ storing them in 'param_list' and then call gfc_get_pdt_instance
+ to obtain the PDT instance. */
+
+static gfc_actual_arglist *param_list, *param_tail, *param;
+
+static bool
+get_pdt_spec_expr (gfc_component *c, gfc_expr *expr)
+{
+ param = gfc_get_actual_arglist ();
+ if (!param_list)
+ param_list = param_tail = param;
+ else
+ {
+ param_tail->next = param;
+ param_tail = param_tail->next;
+ }
+
+ param_tail->name = c->name;
+ if (expr)
+ param_tail->expr = gfc_copy_expr (expr);
+ else if (c->initializer)
+ param_tail->expr = gfc_copy_expr (c->initializer);
+ else
+ {
+ param_tail->spec_type = SPEC_ASSUMED;
+ if (c->attr.pdt_kind)
+ {
+ gfc_error ("The KIND parameter in the PDT constructor "
+ "at %C has no value");
+ return false;
+ }
+ }
+
+ return true;
+}
+
+static bool
+get_pdt_constructor (gfc_expr *expr, gfc_constructor **constr,
+ gfc_symbol *derived)
+{
+ gfc_constructor *cons;
+ gfc_component *comp;
+ bool t = true;
+
+ if (expr && expr->expr_type == EXPR_STRUCTURE)
+ cons = gfc_constructor_first (expr->value.constructor);
+ else if (constr)
+ cons = *constr;
+ gcc_assert (cons);
+
+ comp = derived->components;
+
+ for (; comp && cons; comp = comp->next, cons = gfc_constructor_next (cons))
+ {
+ if (cons->expr->expr_type == EXPR_STRUCTURE
+ && comp->ts.type == BT_DERIVED)
+ {
+ t = get_pdt_constructor (cons->expr, NULL, comp->ts.u.derived);
+ if (!t)
+ return t;
+ }
+ else if (comp->ts.type == BT_DERIVED)
+ {
+ t = get_pdt_constructor (NULL, &cons, comp->ts.u.derived);
+ if (!t)
+ return t;
+ }
+ else if ((comp->attr.pdt_kind || comp->attr.pdt_len)
+ && derived->attr.pdt_template)
+ {
+ t = get_pdt_spec_expr (comp, cons->expr);
+ if (!t)
+ return t;
+ }
+ }
+ return t;
+}
+
+
static bool resolve_fl_derived0 (gfc_symbol *sym);
static bool resolve_fl_struct (gfc_symbol *sym);
resolve_fl_derived0 (expr->ts.u.derived);
else
resolve_fl_struct (expr->ts.u.derived);
+
+ /* If this is a Parameterized Derived Type template, find the
+ instance corresponding to the PDT kind parameters. */
+ if (expr->ts.u.derived->attr.pdt_template)
+ {
+ param_list = NULL;
+ t = get_pdt_constructor (expr, NULL, expr->ts.u.derived);
+ if (!t)
+ return t;
+ gfc_get_pdt_instance (param_list, &expr->ts.u.derived, NULL);
+
+ expr->param_list = gfc_copy_actual_arglist (param_list);
+
+ if (param_list)
+ gfc_free_actual_arglist (param_list);
+
+ if (!expr->ts.u.derived->attr.pdt_type)
+ return false;
+ }
}
cons = gfc_constructor_first (expr->value.constructor);
}
/* Add the hidden deferred length field. */
- if (c->ts.type == BT_CHARACTER && c->ts.deferred && !c->attr.function
+ if (c->ts.type == BT_CHARACTER
+ && (c->ts.deferred || c->attr.pdt_string)
+ && !c->attr.function
&& !sym->attr.is_class)
{
char name[GFC_MAX_SYMBOL_LEN+9];
return false;
if (c->initializer && !sym->attr.vtype
+ && !c->attr.pdt_kind && !c->attr.pdt_len
&& !gfc_check_assign_symbol (sym, c, c->initializer))
return false;
return;
}
+ if (sym->attr.dummy && sym->ts.type == BT_DERIVED
+ && sym->ts.u.derived->attr.pdt_type
+ && gfc_spec_list_type (sym->param_list, NULL) == SPEC_DEFERRED)
+ {
+ gfc_error ("%qs at %L cannot have DEFERRED type parameters because "
+ "it is a dummy argument", sym->name, &sym->declared_at);
+ return;
+ }
+
if (sym->attr.value && sym->ts.type == BT_CHARACTER)
{
gfc_charlen *cl = sym->ts.u.cl;
return check_conflict (attr, NULL, where);
}
+bool
+gfc_add_kind (symbol_attribute *attr, locus *where)
+{
+ if (attr->pdt_kind)
+ {
+ duplicate_attr ("KIND", where);
+ return false;
+ }
+
+ attr->pdt_kind = 1;
+ return check_conflict (attr, NULL, where);
+}
+
+bool
+gfc_add_len (symbol_attribute *attr, locus *where)
+{
+ if (attr->pdt_len)
+ {
+ duplicate_attr ("LEN", where);
+ return false;
+ }
+
+ attr->pdt_len = 1;
+ return check_conflict (attr, NULL, where);
+}
+
bool
gfc_add_pointer (symbol_attribute *attr, locus *where)
gfc_free_array_spec (p->as);
gfc_free_expr (p->initializer);
+ if (p->kind_expr)
+ gfc_free_expr (p->kind_expr);
+ if (p->param_list)
+ gfc_free_actual_arglist (p->param_list);
free (p->tb);
free (p);
set_symbol_common_block (sym, NULL);
+ if (sym->param_list)
+ gfc_free_actual_arglist (sym->param_list);
+
free (sym);
}
}
while (ns != NULL);
+ if (gfc_current_state() == COMP_DERIVED
+ && gfc_current_block ()->attr.pdt_template)
+ {
+ gfc_symbol *der = gfc_current_block ();
+ for (; der; der = gfc_get_derived_super_type (der))
+ {
+ if (der->f2k_derived && der->f2k_derived->sym_root)
+ {
+ st = gfc_find_symtree (der->f2k_derived->sym_root, name);
+ if (st)
+ break;
+ }
+ }
+ *result = st;
+ return 0;
+ }
+
*result = NULL;
+
return 0;
}
ns->refs--;
if (ns->refs > 0)
return;
+
gcc_assert (ns->refs == 0);
gfc_free_statements (ns->code);
function for the functions named in this enum. */
enum {DEALLOCATE_ALLOC_COMP = 1, NULLIFY_ALLOC_COMP,
- COPY_ALLOC_COMP, COPY_ONLY_ALLOC_COMP, REASSIGN_CAF_COMP};
+ COPY_ALLOC_COMP, COPY_ONLY_ALLOC_COMP, REASSIGN_CAF_COMP,
+ ALLOCATE_PDT_COMP, DEALLOCATE_PDT_COMP, CHECK_PDT_DUMMY};
+
+static gfc_actual_arglist *pdt_param_list;
static tree
structure_alloc_comps (gfc_symbol * der_type, tree decl,
break;
+ case ALLOCATE_PDT_COMP:
+
+ comp = fold_build3_loc (input_location, COMPONENT_REF, ctype,
+ decl, cdecl, NULL_TREE);
+
+ /* Set the PDT KIND and LEN fields. */
+ if (c->attr.pdt_kind || c->attr.pdt_len)
+ {
+ gfc_se tse;
+ gfc_expr *c_expr = NULL;
+ gfc_actual_arglist *param = pdt_param_list;
+ gfc_init_se (&tse, NULL);
+ for (; param; param = param->next)
+ if (!strcmp (c->name, param->name))
+ c_expr = param->expr;
+
+ if (!c_expr)
+ c_expr = c->initializer;
+
+ if (c_expr)
+ {
+ gfc_conv_expr_type (&tse, c_expr, TREE_TYPE (comp));
+ gfc_add_modify (&fnblock, comp, tse.expr);
+ }
+ }
+
+ if (c->attr.pdt_string)
+ {
+ gfc_se tse;
+ gfc_init_se (&tse, NULL);
+ tree strlen;
+ /* Convert the parameterized string length to its value. The
+ string length is stored in a hidden field in the same way as
+ deferred string lengths. */
+ gfc_insert_parameter_exprs (c->ts.u.cl->length, pdt_param_list);
+ if (gfc_deferred_strlen (c, &strlen) && strlen != NULL_TREE)
+ {
+ gfc_conv_expr_type (&tse, c->ts.u.cl->length,
+ TREE_TYPE (strlen));
+ strlen = fold_build3_loc (input_location, COMPONENT_REF,
+ TREE_TYPE (strlen),
+ decl, strlen, NULL_TREE);
+ gfc_add_modify (&fnblock, strlen, tse.expr);
+ c->ts.u.cl->backend_decl = strlen;
+ }
+ /* Scalar parameterizied strings can be allocated now. */
+ if (!c->as)
+ {
+ tmp = fold_convert (gfc_array_index_type, strlen);
+ tmp = size_of_string_in_bytes (c->ts.kind, tmp);
+ tmp = gfc_evaluate_now (tmp, &fnblock);
+ tmp = gfc_call_malloc (&fnblock, TREE_TYPE (comp), tmp);
+ gfc_add_modify (&fnblock, comp, tmp);
+ }
+ }
+
+ /* Allocate paramterized arrays of parameterized derived types. */
+ if (!(c->attr.pdt_array && c->as && c->as->type == AS_EXPLICIT)
+ && !((c->ts.type == BT_DERIVED || c->ts.type == BT_CLASS)
+ && (c->ts.u.derived && c->ts.u.derived->attr.pdt_type)))
+ continue;
+
+ if (c->ts.type == BT_CLASS)
+ comp = gfc_class_data_get (comp);
+
+ if (c->attr.pdt_array)
+ {
+ gfc_se tse;
+ int i;
+ tree size = gfc_index_one_node;
+ tree offset = gfc_index_zero_node;
+ tree lower, upper;
+ gfc_expr *e;
+
+ /* This chunk takes the expressions for 'lower' and 'upper'
+ in the arrayspec and substitutes in the expressions for
+ the parameters from 'pdt_param_list'. The descriptor
+ fields can then be filled from the values so obtained. */
+ gcc_assert (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (comp)));
+ for (i = 0; i < c->as->rank; i++)
+ {
+ gfc_init_se (&tse, NULL);
+ e = gfc_copy_expr (c->as->lower[i]);
+ gfc_insert_parameter_exprs (e, pdt_param_list);
+ gfc_conv_expr_type (&tse, e, gfc_array_index_type);
+ gfc_free_expr (e);
+ lower = tse.expr;
+ gfc_conv_descriptor_lbound_set (&fnblock, comp,
+ gfc_rank_cst[i],
+ lower);
+ e = gfc_copy_expr (c->as->upper[i]);
+ gfc_insert_parameter_exprs (e, pdt_param_list);
+ gfc_conv_expr_type (&tse, e, gfc_array_index_type);
+ gfc_free_expr (e);
+ upper = tse.expr;
+ gfc_conv_descriptor_ubound_set (&fnblock, comp,
+ gfc_rank_cst[i],
+ upper);
+ gfc_conv_descriptor_stride_set (&fnblock, comp,
+ gfc_rank_cst[i],
+ size);
+ size = gfc_evaluate_now (size, &fnblock);
+ offset = fold_build2_loc (input_location,
+ MINUS_EXPR,
+ gfc_array_index_type,
+ offset, size);
+ offset = gfc_evaluate_now (offset, &fnblock);
+ tmp = fold_build2_loc (input_location, MINUS_EXPR,
+ gfc_array_index_type,
+ upper, lower);
+ tmp = fold_build2_loc (input_location, PLUS_EXPR,
+ gfc_array_index_type,
+ tmp, gfc_index_one_node);
+ size = fold_build2_loc (input_location, MULT_EXPR,
+ gfc_array_index_type, size, tmp);
+ }
+ gfc_conv_descriptor_offset_set (&fnblock, comp, offset);
+ if (c->ts.type == BT_CLASS)
+ {
+ tmp = gfc_get_vptr_from_expr (comp);
+ if (POINTER_TYPE_P (TREE_TYPE (tmp)))
+ tmp = build_fold_indirect_ref_loc (input_location, tmp);
+ tmp = gfc_vptr_size_get (tmp);
+ }
+ else
+ tmp = TYPE_SIZE_UNIT (gfc_get_element_type (ctype));
+ tmp = fold_convert (gfc_array_index_type, tmp);
+ size = fold_build2_loc (input_location, MULT_EXPR,
+ gfc_array_index_type, size, tmp);
+ size = gfc_evaluate_now (size, &fnblock);
+ tmp = gfc_call_malloc (&fnblock, NULL, size);
+ gfc_conv_descriptor_data_set (&fnblock, comp, tmp);
+ tmp = gfc_conv_descriptor_dtype (comp);
+ gfc_add_modify (&fnblock, tmp, gfc_get_dtype (ctype));
+ }
+
+ /* Recurse in to PDT components. */
+ if ((c->ts.type == BT_DERIVED || c->ts.type == BT_CLASS)
+ && c->ts.u.derived && c->ts.u.derived->attr.pdt_type)
+ {
+ bool is_deferred = false;
+ gfc_actual_arglist *tail = c->param_list;
+
+ for (; tail; tail = tail->next)
+ if (!tail->expr)
+ is_deferred = true;
+
+ tail = is_deferred ? pdt_param_list : c->param_list;
+ tmp = gfc_allocate_pdt_comp (c->ts.u.derived, comp,
+ c->as ? c->as->rank : 0,
+ tail);
+ gfc_add_expr_to_block (&fnblock, tmp);
+ }
+
+ break;
+
+ case DEALLOCATE_PDT_COMP:
+ /* Deallocate array or parameterized string length components
+ of parameterized derived types. */
+ if (!(c->attr.pdt_array && c->as && c->as->type == AS_EXPLICIT)
+ && !c->attr.pdt_string
+ && !((c->ts.type == BT_DERIVED || c->ts.type == BT_CLASS)
+ && (c->ts.u.derived && c->ts.u.derived->attr.pdt_type)))
+ continue;
+
+ comp = fold_build3_loc (input_location, COMPONENT_REF, ctype,
+ decl, cdecl, NULL_TREE);
+ if (c->ts.type == BT_CLASS)
+ comp = gfc_class_data_get (comp);
+
+ /* Recurse in to PDT components. */
+ if ((c->ts.type == BT_DERIVED || c->ts.type == BT_CLASS)
+ && c->ts.u.derived && c->ts.u.derived->attr.pdt_type)
+ {
+ tmp = gfc_deallocate_pdt_comp (c->ts.u.derived, comp,
+ c->as ? c->as->rank : 0);
+ gfc_add_expr_to_block (&fnblock, tmp);
+ }
+
+ if (c->attr.pdt_array)
+ {
+ tmp = gfc_conv_descriptor_data_get (comp);
+ tmp = gfc_call_free (tmp);
+ gfc_add_expr_to_block (&fnblock, tmp);
+ gfc_conv_descriptor_data_set (&fnblock, comp, null_pointer_node);
+ }
+ else if (c->attr.pdt_string)
+ {
+ tmp = gfc_call_free (comp);
+ gfc_add_expr_to_block (&fnblock, tmp);
+ tmp = fold_convert (TREE_TYPE (comp), null_pointer_node);
+ gfc_add_modify (&fnblock, comp, tmp);
+ }
+
+ break;
+
+ case CHECK_PDT_DUMMY:
+
+ comp = fold_build3_loc (input_location, COMPONENT_REF, ctype,
+ decl, cdecl, NULL_TREE);
+ if (c->ts.type == BT_CLASS)
+ comp = gfc_class_data_get (comp);
+
+ /* Recurse in to PDT components. */
+ if ((c->ts.type == BT_DERIVED || c->ts.type == BT_CLASS)
+ && c->ts.u.derived && c->ts.u.derived->attr.pdt_type)
+ {
+ tmp = gfc_check_pdt_dummy (c->ts.u.derived, comp,
+ c->as ? c->as->rank : 0,
+ pdt_param_list);
+ gfc_add_expr_to_block (&fnblock, tmp);
+ }
+
+ if (!c->attr.pdt_len)
+ continue;
+ else
+ {
+ gfc_se tse;
+ gfc_expr *c_expr = NULL;
+ gfc_actual_arglist *param = pdt_param_list;
+
+ gfc_init_se (&tse, NULL);
+ for (; param; param = param->next)
+ if (!strcmp (c->name, param->name))
+ c_expr = param->expr;
+
+ if (c_expr)
+ {
+ tree error, cond, cname;
+ gfc_conv_expr_type (&tse, c_expr, TREE_TYPE (comp));
+ cond = fold_build2_loc (input_location, NE_EXPR,
+ boolean_type_node,
+ comp, tse.expr);
+ cname = gfc_build_cstring_const (c->name);
+ cname = gfc_build_addr_expr (pchar_type_node, cname);
+ error = gfc_trans_runtime_error (true, NULL,
+ "The value of the PDT LEN "
+ "parameter '%s' does not "
+ "agree with that in the "
+ "dummy declaration",
+ cname);
+ tmp = fold_build3_loc (input_location, COND_EXPR,
+ void_type_node, cond, error,
+ build_empty_stmt (input_location));
+ gfc_add_expr_to_block (&fnblock, tmp);
+ }
+ }
+ break;
+
default:
gcc_unreachable ();
break;
}
+/* Recursively traverse an object of paramterized derived type, generating
+ code to allocate parameterized components. */
+
+tree
+gfc_allocate_pdt_comp (gfc_symbol * der_type, tree decl, int rank,
+ gfc_actual_arglist *param_list)
+{
+ tree res;
+ gfc_actual_arglist *old_param_list = pdt_param_list;
+ pdt_param_list = param_list;
+ res = structure_alloc_comps (der_type, decl, NULL_TREE, rank,
+ ALLOCATE_PDT_COMP, 0);
+ pdt_param_list = old_param_list;
+ return res;
+}
+
+/* Recursively traverse an object of paramterized derived type, generating
+ code to deallocate parameterized components. */
+
+tree
+gfc_deallocate_pdt_comp (gfc_symbol * der_type, tree decl, int rank)
+{
+ return structure_alloc_comps (der_type, decl, NULL_TREE, rank,
+ DEALLOCATE_PDT_COMP, 0);
+}
+
+
+/* Recursively traverse a dummy of paramterized derived type to check the
+ values of LEN parameters. */
+
+tree
+gfc_check_pdt_dummy (gfc_symbol * der_type, tree decl, int rank,
+ gfc_actual_arglist *param_list)
+{
+ tree res;
+ gfc_actual_arglist *old_param_list = pdt_param_list;
+ pdt_param_list = param_list;
+ res = structure_alloc_comps (der_type, decl, NULL_TREE, rank,
+ CHECK_PDT_DUMMY, 0);
+ pdt_param_list = old_param_list;
+ return res;
+}
+
+
/* Returns the value of LBOUND for an expression. This could be broken out
from gfc_conv_intrinsic_bound but this seemed to be simpler. This is
called by gfc_alloc_allocatable_for_assignment. */
tree gfc_copy_only_alloc_comp (gfc_symbol *, tree, tree, int);
+tree gfc_allocate_pdt_comp (gfc_symbol *, tree, int, gfc_actual_arglist *);
+tree gfc_deallocate_pdt_comp (gfc_symbol *, tree, int);
+tree gfc_check_pdt_dummy (gfc_symbol *, tree, int, gfc_actual_arglist *);
+
tree gfc_alloc_allocatable_for_assignment (gfc_loopinfo*, gfc_expr*, gfc_expr*);
/* Add initialization for deferred arrays. */
}
}
+ /* PDT parameterized array components and string_lengths must have the
+ 'len' parameters substituted for the expressions appearing in the
+ declaration of the entity and memory allocated/deallocated. */
+ if ((sym->ts.type == BT_DERIVED || sym->ts.type == BT_CLASS)
+ && sym->param_list != NULL
+ && !(sym->attr.host_assoc || sym->attr.use_assoc || sym->attr.dummy))
+ gfc_defer_symbol_init (sym);
+
+ /* Dummy PDT 'len' parameters should be checked when they are explicit. */
+ if ((sym->ts.type == BT_DERIVED || sym->ts.type == BT_CLASS)
+ && (gfc_option.rtcheck & GFC_RTCHECK_BOUNDS)
+ && sym->param_list != NULL
+ && sym->attr.dummy)
+ gfc_defer_symbol_init (sym);
+
/* All deferred character length procedures need to retain the backend
decl, which is a pointer to the character length in the caller's
namespace and to declare a local character length. */
gfc_formal_arglist *f;
stmtblock_t tmpblock;
bool seen_trans_deferred_array = false;
+ bool is_pdt_type = false;
tree tmp = NULL;
gfc_expr *e;
gfc_se se;
if (sym->assoc)
continue;
+ if (sym->ts.type == BT_DERIVED
+ && sym->ts.u.derived
+ && sym->ts.u.derived->attr.pdt_type)
+ {
+ is_pdt_type = true;
+ gfc_init_block (&tmpblock);
+ if (!(sym->attr.dummy
+ || sym->attr.pointer
+ || sym->attr.allocatable))
+ {
+ tmp = gfc_allocate_pdt_comp (sym->ts.u.derived,
+ sym->backend_decl,
+ sym->as ? sym->as->rank : 0,
+ sym->param_list);
+ gfc_add_expr_to_block (&tmpblock, tmp);
+ tmp = gfc_deallocate_pdt_comp (sym->ts.u.derived,
+ sym->backend_decl,
+ sym->as ? sym->as->rank : 0);
+ gfc_add_init_cleanup (block, gfc_finish_block (&tmpblock), tmp);
+ }
+ else if (sym->attr.dummy)
+ {
+ tmp = gfc_check_pdt_dummy (sym->ts.u.derived,
+ sym->backend_decl,
+ sym->as ? sym->as->rank : 0,
+ sym->param_list);
+ gfc_add_expr_to_block (&tmpblock, tmp);
+ gfc_add_init_cleanup (block, gfc_finish_block (&tmpblock), NULL);
+ }
+ }
+ else if (sym->ts.type == BT_CLASS
+ && CLASS_DATA (sym)->ts.u.derived
+ && CLASS_DATA (sym)->ts.u.derived->attr.pdt_type)
+ {
+ gfc_component *data = CLASS_DATA (sym);
+ is_pdt_type = true;
+ gfc_init_block (&tmpblock);
+ if (!(sym->attr.dummy
+ || CLASS_DATA (sym)->attr.pointer
+ || CLASS_DATA (sym)->attr.allocatable))
+ {
+ tmp = gfc_class_data_get (sym->backend_decl);
+ tmp = gfc_allocate_pdt_comp (data->ts.u.derived, tmp,
+ data->as ? data->as->rank : 0,
+ sym->param_list);
+ gfc_add_expr_to_block (&tmpblock, tmp);
+ tmp = gfc_class_data_get (sym->backend_decl);
+ tmp = gfc_deallocate_pdt_comp (data->ts.u.derived, tmp,
+ data->as ? data->as->rank : 0);
+ gfc_add_init_cleanup (block, gfc_finish_block (&tmpblock), tmp);
+ }
+ else if (sym->attr.dummy)
+ {
+ tmp = gfc_class_data_get (sym->backend_decl);
+ tmp = gfc_check_pdt_dummy (data->ts.u.derived, tmp,
+ data->as ? data->as->rank : 0,
+ sym->param_list);
+ gfc_add_expr_to_block (&tmpblock, tmp);
+ gfc_add_init_cleanup (block, gfc_finish_block (&tmpblock), NULL);
+ }
+ }
+
if (sym->attr.subref_array_pointer
&& GFC_DECL_SPAN (sym->backend_decl)
&& !TREE_STATIC (GFC_DECL_SPAN (sym->backend_decl)))
gfc_add_init_cleanup (block, gfc_finish_block (&tmpblock),
NULL_TREE);
}
- else if (!(UNLIMITED_POLY(sym)))
+ else if (!(UNLIMITED_POLY(sym)) && !is_pdt_type)
gcc_unreachable ();
}
{
if (cm->attr.allocatable && expr->expr_type == EXPR_NULL)
gfc_conv_descriptor_data_set (&block, dest, null_pointer_node);
- else if (cm->attr.allocatable)
+ else if (cm->attr.allocatable || cm->attr.pdt_array)
{
tmp = gfc_trans_alloc_subarray_assign (dest, cm, expr);
gfc_add_expr_to_block (&block, tmp);
bool needs_caf_sync, caf_refs_comp;
gfc_symtree *newsym = NULL;
symbol_attribute caf_attr;
+ gfc_actual_arglist *param_list;
if (!code->ext.alloc.list)
return NULL_TREE;
gfc_free_expr (rhs);
gfc_add_expr_to_block (&block, tmp);
}
+ /* Set KIND and LEN PDT components and allocate those that are
+ parameterized. */
+ else if (expr->ts.type == BT_DERIVED
+ && expr->ts.u.derived->attr.pdt_type)
+ {
+ if (code->expr3 && code->expr3->param_list)
+ param_list = code->expr3->param_list;
+ else if (expr->param_list)
+ param_list = expr->param_list;
+ else
+ param_list = expr->symtree->n.sym->param_list;
+ tmp = gfc_allocate_pdt_comp (expr->ts.u.derived, se.expr,
+ expr->rank, param_list);
+ gfc_add_expr_to_block (&block, tmp);
+ }
+ /* Ditto for CLASS expressions. */
+ else if (expr->ts.type == BT_CLASS
+ && CLASS_DATA (expr)->ts.u.derived->attr.pdt_type)
+ {
+ if (code->expr3 && code->expr3->param_list)
+ param_list = code->expr3->param_list;
+ else if (expr->param_list)
+ param_list = expr->param_list;
+ else
+ param_list = expr->symtree->n.sym->param_list;
+ tmp = gfc_allocate_pdt_comp (CLASS_DATA (expr)->ts.u.derived,
+ se.expr, expr->rank, param_list);
+ gfc_add_expr_to_block (&block, tmp);
+ }
else if (code->expr3 && code->expr3->mold
&& code->expr3->ts.type == BT_CLASS)
{
se.descriptor_only = 1;
gfc_conv_expr (&se, expr);
+ /* Deallocate PDT components that are parameterized. */
+ tmp = NULL;
+ if (expr->ts.type == BT_DERIVED
+ && expr->ts.u.derived->attr.pdt_type
+ && expr->symtree->n.sym->param_list)
+ tmp = gfc_deallocate_pdt_comp (expr->ts.u.derived, se.expr, expr->rank);
+ else if (expr->ts.type == BT_CLASS
+ && CLASS_DATA (expr)->ts.u.derived->attr.pdt_type
+ && expr->symtree->n.sym->param_list)
+ tmp = gfc_deallocate_pdt_comp (CLASS_DATA (expr)->ts.u.derived,
+ se.expr, expr->rank);
+
+ if (tmp)
+ gfc_add_expr_to_block (&block, tmp);
+
if (flag_coarray == GFC_FCOARRAY_LIB
|| flag_coarray == GFC_FCOARRAY_SINGLE)
{
gfc_namespace *ns;
tree tmp;
+ gcc_assert (!derived->attr.pdt_template);
+
if (derived->attr.unlimited_polymorphic
|| (flag_coarray == GFC_FCOARRAY_LIB
&& derived->from_intmod == INTMOD_ISO_FORTRAN_ENV
field_type = c->ts.u.derived->backend_decl;
else
{
- if (c->ts.type == BT_CHARACTER && !c->ts.deferred)
+ if (c->ts.type == BT_CHARACTER
+ && !c->ts.deferred && !c->attr.pdt_string)
{
/* Evaluate the string length. */
gfc_conv_const_charlen (c->ts.u.cl);
required. */
if ((c->attr.dimension || c->attr.codimension) && !c->attr.proc_pointer )
{
- if (c->attr.pointer || c->attr.allocatable)
+ if (c->attr.pointer || c->attr.allocatable || c->attr.pdt_array)
{
enum gfc_array_kind akind;
if (c->attr.pointer)
PACKED_STATIC,
!c->attr.target);
}
- else if ((c->attr.pointer || c->attr.allocatable)
+ else if ((c->attr.pointer || c->attr.allocatable || c->attr.pdt_string)
&& !c->attr.proc_pointer
&& !(unlimited_entity && c == derived->components))
field_type = build_pointer_type (field_type);
{
char name[GFC_MAX_SYMBOL_LEN+9];
gfc_component *strlen;
- if (!(c->ts.type == BT_CHARACTER && c->ts.deferred))
+ if (!(c->ts.type == BT_CHARACTER
+ && (c->ts.deferred || c->attr.pdt_string)))
return false;
sprintf (name, "_%s_length", c->name);
for (strlen = c; strlen; strlen = strlen->next)
+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.
+
2017-09-08 Eric Botcazou <ebotcazou@adacore.com>
* gcc.dg/pr81988.c: New test.
--- /dev/null
+! { dg-do run }
+! { dg-options "-fcheck=all" }
+!
+! Basic check of Parameterized Derived Types.
+!
+! -fcheck=all is used here to ensure that when the parameter
+! 'b' of the dummy in 'foo' is assumed, there is no error.
+! Likewise in 'bar' and 'foobar', when 'b' has the correct
+! explicit value.
+!
+ implicit none
+ integer, parameter :: ftype = kind(0.0e0)
+ integer :: pdt_len = 4
+ integer :: i
+ type :: mytype (a,b)
+ integer, kind :: a = kind(0.0d0)
+ integer, LEN :: b
+ integer :: i
+ real(kind = a) :: d(b, b)
+ character (len = b*b) :: chr
+ end type
+
+ type(mytype(b=4)) :: z(2)
+ type(mytype(ftype, pdt_len)) :: z2
+
+ z(1)%i = 1
+ z(2)%i = 2
+ z(1)%d = reshape ([(real(i), i = 1, 16)],[4,4])
+ z(2)%d = 10*z(1)%d
+ z(1)%chr = "hello pdt"
+ z(2)%chr = "goodbye pdt"
+
+ z2%d = z(1)%d * 10 - 1
+ z2%chr = "scalar pdt"
+
+ call foo (z)
+ call bar (z)
+ call foobar (z2)
+contains
+ elemental subroutine foo (arg)
+ type(mytype(8,*)), intent(in) :: arg
+ if (arg%i .eq. 1) then
+ if (trim (arg%chr) .ne. "hello pdt") error stop
+ if (int (sum (arg%d)) .ne. 136) error stop
+ else if (arg%i .eq. 2 ) then
+ if (trim (arg%chr) .ne. "goodbye pdt") error stop
+ if (int (sum (arg%d)) .ne. 1360) error stop
+ else
+ error stop
+ end if
+ end subroutine
+ subroutine bar (arg)
+ type(mytype(b=4)) :: arg(:)
+ if (int (sum (arg(1)%d)) .ne. 136) call abort
+ if (trim (arg(2)%chr) .ne. "goodbye pdt") call abort
+ end subroutine
+ subroutine foobar (arg)
+ type(mytype(ftype, pdt_len)) :: arg
+ if (int (sum (arg%d)) .ne. 1344) call abort
+ if (trim (arg%chr) .ne. "scalar pdt") call abort
+ end subroutine
+end
--- /dev/null
+! { dg-do run }
+! { dg-options "-fcheck=all" }
+! { dg-shouldfail "value of the PDT LEN parameter" }
+!
+! Reduced version of pdt_1.f03 to check that an incorrect
+! value for the parameter 'b' in the dummy is picked up.
+!
+ implicit none
+ integer, parameter :: ftype = kind(0.0e0)
+ integer :: pdt_len = 4
+ integer :: i
+ type :: mytype (a,b)
+ integer, kind :: a = kind(0.0d0)
+ integer, LEN :: b
+ integer :: i
+ real(kind = a) :: d(b, b)
+ character (len = b*b) :: chr
+ end type
+
+ type(mytype(ftype, pdt_len)) :: z2
+ call foobar (z2)
+contains
+ subroutine foobar (arg)
+ type(mytype(ftype, 8)) :: arg
+ print *, arg%i
+ end subroutine
+end
--- /dev/null
+! { dg-do run }
+!
+! Check PDT type extension and simple OOP.
+!
+module vars
+ integer :: d_dim = 4
+ integer :: mat_dim = 256
+ integer, parameter :: ftype = kind(0.0d0)
+end module
+
+ use vars
+ implicit none
+ integer :: i
+ type :: mytype (a,b)
+ integer, kind :: a = kind(0.0e0)
+ integer, LEN :: b = 4
+ integer :: i
+ real(kind = a) :: d(b, b)
+ end type
+
+ type, extends(mytype) :: thytype(h)
+ integer, kind :: h
+ integer(kind = h) :: j
+ end type
+
+ type x (q, r, s)
+ integer, kind :: q
+ integer, kind :: r
+ integer, LEN :: s
+ integer(kind = q) :: idx_mat(2,2) ! check these do not get treated as pdt_arrays.
+ type (mytype (b=s)) :: mat1
+ type (mytype (b=s*2)) :: mat2
+ end type x
+
+ real, allocatable :: matrix (:,:)
+ type(thytype(ftype, 4, 4)) :: w
+ type(x(8,4,mat_dim)) :: q
+ class(mytype(ftype, :)), allocatable :: cz
+
+ w%d = reshape ([(real(i), i = 1, d_dim*d_dim)],[d_dim,d_dim])
+
+! Make sure that the type extension is ordering the parameters correctly.
+ if (w%a .ne. ftype) call abort
+ if (w%b .ne. 4) call abort
+ if (w%h .ne. 4) call abort
+ if (size (w%d) .ne. 16) call abort
+ if (int (w%d(2,4)) .ne. 14) call abort
+ if (kind (w%j) .ne. w%h) call abort
+
+! As a side issue, ensure PDT components are OK
+ if (q%mat1%b .ne. q%s) call abort
+ if (q%mat2%b .ne. q%s*2) call abort
+ if (size (q%mat1%d) .ne. mat_dim**2) call abort
+ if (size (q%mat2%d) .ne. 4*mat_dim**2) call abort
+
+! Now check some basic OOP with PDTs
+ matrix = w%d
+
+! TODO - for some reason, using w%d directly in the source causes a seg fault.
+ allocate (cz, source = mytype(ftype, d_dim, 0, matrix))
+ select type (cz)
+ type is (mytype(ftype, *))
+ if (int (sum (cz%d)) .ne. 136) call abort
+ type is (thytype(ftype, *, 8))
+ call abort
+ end select
+ deallocate (cz)
+
+ allocate (thytype(ftype, d_dim*2, 8) :: cz)
+ cz%d = reshape ([(i*10, i = 1, cz%b**2)], [cz%b,cz%b])
+ select type (cz)
+ type is (mytype(ftype, *))
+ call abort
+ type is (thytype(ftype, *, 8))
+ if (int (sum (cz%d)) .ne. 20800) call abort
+ end select
+
+ deallocate (cz)
+end
--- /dev/null
+! { dg-do compile }
+!
+! Test bad PDT coding: Based on pdt_3.f03
+!
+module vars
+ integer :: d_dim = 4
+ integer :: mat_dim = 256
+ integer, parameter :: ftype = kind(0.0d0)
+end module
+
+ use vars
+ implicit none
+ integer :: i
+ integer, kind :: bad_kind ! { dg-error "not allowed outside a TYPE definition" }
+ integer, len :: bad_len ! { dg-error "not allowed outside a TYPE definition" }
+
+ type :: bad_pdt (a,b, c, d)
+ real, kind :: a ! { dg-error "must be INTEGER" }
+ INTEGER(8), kind :: b ! { dg-error "be default integer kind" }
+ real, LEN :: c ! { dg-error "must be INTEGER" }
+ INTEGER(8), LEN :: d ! { dg-error "be default integer kind" }
+ end type
+
+ type :: mytype (a,b)
+ integer, kind :: a = kind(0.0e0)
+ integer, LEN :: b = 4
+ integer :: i
+ real(kind = a) :: d(b, b)
+ end type
+
+ type, extends(mytype) :: thytype(h)
+ integer, kind :: h
+ integer(kind = h) :: j
+ end type
+
+ type x (q, r, s)
+ integer, kind :: q
+ integer, kind :: r
+ integer, LEN :: s
+ integer(kind = q) :: idx_mat(2,2)
+ type (mytype (b=s)) :: mat1
+ type (mytype (b=s*2)) :: mat2
+ end type x
+
+ real, allocatable :: matrix (:,:)
+
+! Bad KIND parameters
+ type(thytype(d_dim, 4, 4)) :: wbad ! { dg-error "does not reduce to a constant" }
+ type(thytype(*, 4, 4)) :: worse ! { dg-error "cannot either be ASSUMED or DEFERRED" }
+ type(thytype(:, 4, 4)) :: w_ugh ! { dg-error "cannot either be ASSUMED or DEFERRED" }
+
+ type(thytype(ftype, b=4, h=4)) :: w
+ type(x(8,4,mat_dim)) :: q
+ class(mytype(ftype, :)), allocatable :: cz
+
+ w%a = 1 ! { dg-error "assignment to a KIND or LEN component" }
+ w%b = 2 ! { dg-error "assignment to a KIND or LEN component" }
+ w%h = 3 ! { dg-error "assignment to a KIND or LEN component" }
+
+ w%d = reshape ([(real(i), i = 1, d_dim*d_dim)],[d_dim,d_dim])
+
+ matrix = w%d
+
+ allocate (cz, source = mytype(*, d_dim, 0, matrix)) ! { dg-error "Syntax error" }
+ allocate (cz, source = mytype(ftype, :, 0, matrix)) ! { dg-error "Syntax error" }
+ select type (cz)
+ type is (mytype(ftype, d_dim)) ! { dg-error "must be ASSUMED" }
+ if (int (sum (cz%d)) .ne. 136) call abort ! { dg-error "Expected TYPE IS" }
+ type is (thytype(ftype, *, 8))
+ call abort
+ end select
+ deallocate (cz)
+
+ allocate (thytype(ftype, d_dim*2, 8) :: cz)
+ cz%d = reshape ([(i*10, i = 1, cz%b**2)], [cz%b,cz%b])
+ select type (cz)
+ type is (mytype(4, *)) ! { dg-error "must be an extension" }
+ call abort
+ type is (thytype(ftype, *, 8))
+ if (int (sum (cz%d)) .ne. 20800) call abort
+ end select
+ deallocate (cz)
+contains
+ subroutine foo(arg) ! { dg-error "has no IMPLICIT type" }
+ type (mytype(4, *)) :: arg ! { dg-error "is being used before it is defined" }
+ end subroutine
+ subroutine bar(arg) ! { dg-error "cannot have DEFERRED type parameters" }
+ type (thytype(8, :, 4) :: arg
+ end subroutine
+end
--- /dev/null
+! { dg-do run }
+!
+! Third, complete example from the PGInsider article:
+! "Object-Oriented Programming in Fortran 2003 Part 3: Parameterized Derived Types"
+! by Mark Leair
+!
+! Copyright (c) 2013, NVIDIA CORPORATION. All rights reserved.
+!
+! NVIDIA CORPORATION and its licensors retain all intellectual property
+! and proprietary rights in and to this software, related documentation
+! and any modifications thereto. Any use, reproduction, disclosure or
+! distribution of this software and related documentation without an express
+! license agreement from NVIDIA CORPORATION is strictly prohibited.
+!
+
+! THIS CODE AND INFORMATION ARE PROVIDED "AS IS" WITHOUT
+! WARRANTY OF ANY KIND, EITHER EXPRESSED OR IMPLIED, INCLUDING BUT
+! NOT LIMITED TO THE IMPLIED WARRANTIES OF MERCHANTABILITY AND/OR
+! FITNESS FOR A PARTICULAR PURPOSE.
+!
+! Note that modification had to be made all of which are commented.
+!
+module matrix
+
+type :: base_matrix(k,c,r)
+ private
+ integer, kind :: k = 4
+ integer, len :: c = 1
+ integer, len :: r = 1
+end type base_matrix
+
+type, extends(base_matrix) :: adj_matrix
+ private
+ class(*), pointer :: m(:,:) => null()
+end type adj_matrix
+
+interface getKind
+ module procedure getKind4
+ module procedure getKind8
+end interface getKind
+
+interface getColumns
+ module procedure getNumCols4
+ module procedure getNumCols8
+end interface getColumns
+
+interface getRows
+ module procedure getNumRows4
+ module procedure getNumRows8
+end interface getRows
+
+interface adj_matrix
+ module procedure construct_4 ! kind=4 constructor
+ module procedure construct_8 ! kind=8 constructor
+end interface adj_matrix
+
+interface assignment(=)
+ module procedure m2m4 ! assign kind=4 matrix
+ module procedure a2m4 ! assign kind=4 array
+ module procedure m2m8 ! assign kind=8 matrix
+ module procedure a2m8 ! assign kind=8 array
+ module procedure m2a4 ! assign kind=4 matrix to array
+ module procedure m2a8 ! assign kind=8 matrix to array
+end interface assignment(=)
+
+
+contains
+
+ function getKind4(this) result(rslt)
+ class(adj_matrix(4,*,*)) :: this
+ integer :: rslt
+ rslt = this%k
+ end function getKind4
+
+ function getKind8(this) result(rslt)
+ class(adj_matrix(8,*,*)) :: this
+ integer :: rslt
+ rslt = this%k
+ end function getKind8
+
+ function getNumCols4(this) result(rslt)
+ class(adj_matrix(4,*,*)) :: this
+ integer :: rslt
+ rslt = this%c
+ end function getNumCols4
+
+ function getNumCols8(this) result(rslt)
+ class(adj_matrix(8,*,*)) :: this
+ integer :: rslt
+ rslt = this%c
+ end function getNumCols8
+
+ function getNumRows4(this) result(rslt)
+ class(adj_matrix(4,*,*)) :: this
+ integer :: rslt
+ rslt = this%r
+ end function getNumRows4
+
+ function getNumRows8(this) result(rslt)
+ class(adj_matrix(8,*,*)) :: this
+ integer :: rslt
+ rslt = this%r
+ end function getNumRows8
+
+
+ function construct_4(k,c,r) result(mat)
+ integer(4) :: k
+ integer :: c
+ integer :: r
+ class(adj_matrix(4,:,:)),allocatable :: mat
+
+ allocate(adj_matrix(4,c,r)::mat)
+
+ end function construct_4
+
+ function construct_8(k,c,r) result(mat)
+ integer(8) :: k
+ integer :: c
+ integer :: r
+ class(adj_matrix(8,:,:)),allocatable :: mat
+
+ allocate(adj_matrix(8,c,r)::mat)
+
+ end function construct_8
+
+ subroutine a2m4(d,s)
+ class(adj_matrix(4,:,:)),allocatable :: d
+ class(*),dimension(:,:) :: s
+
+ if (allocated(d)) deallocate(d)
+! allocate(adj_matrix(4,size(s,1),size(s,2))::d) ! generates assembler error
+ allocate(d, mold = adj_matrix(4,size(s,1),size(s,2)))
+ allocate(d%m(size(s,1),size(s,2)),source=s)
+ end subroutine a2m4
+
+ subroutine a2m8(d,s)
+ class(adj_matrix(8,:,:)),allocatable :: d
+ class(*),dimension(:,:) :: s
+
+ if (allocated(d)) deallocate(d)
+! allocate(adj_matrix(8,size(s,1),size(s,2))::d) ! generates assembler error
+ allocate(d, mold = adj_matrix(8_8,size(s,1),size(s,2))) ! Needs 8_8 to match arg1 of 'construct_8'
+ allocate(d%m(size(s,1),size(s,2)),source=s)
+ end subroutine a2m8
+
+subroutine m2a8(a,this)
+class(adj_matrix(8,*,*)), intent(in) :: this ! Intents required for
+real(8),allocatable, intent(out) :: a(:,:) ! defined assignment
+ select type (array => this%m) ! Added SELECT TYPE because...
+ type is (real(8))
+ if (allocated(a)) deallocate(a)
+ allocate(a,source=array)
+ end select
+! allocate(a(size(this%m,1),size(this%m,2)),source=this%m) ! ...CLASS(*) source does not work in gfortran
+ end subroutine m2a8
+
+ subroutine m2a4(a,this)
+ class(adj_matrix(4,*,*)), intent(in) :: this ! Intents required for
+ real(4),allocatable, intent(out) :: a(:,:) ! defined assignment
+ select type (array => this%m) ! Added SELECT TYPE because...
+ type is (real(4))
+ if (allocated(a)) deallocate(a)
+ allocate(a,source=array)
+ end select
+! allocate(a(size(this%m,1),size(this%m,2)),source=this%m) ! ...CLASS(*) source does not work in gfortran
+ end subroutine m2a4
+
+ subroutine m2m4(d,s)
+ CLASS(adj_matrix(4,:,:)),allocatable, intent(OUT) :: d ! Intents required for
+ CLASS(adj_matrix(4,*,*)), intent(in) :: s ! defined assignment
+
+ if (allocated(d)) deallocate(d)
+ allocate(d,source=s)
+ end subroutine m2m4
+
+ subroutine m2m8(d,s)
+ CLASS(adj_matrix(8,:,:)),allocatable, intent(OUT) :: d ! Intents required for
+ CLASS(adj_matrix(8,*,*)), intent(in) :: s ! defined assignment
+
+ if (allocated(d)) deallocate(d)
+ allocate(d,source=s)
+ end subroutine m2m8
+
+
+end module matrix
+
+
+program adj3
+
+ use matrix
+ implicit none
+ integer(8) :: i
+
+ class(adj_matrix(8,:,:)),allocatable :: adj ! Was TYPE: Fails in
+ real(8) :: a(2,3) ! defined assignment
+ real(8),allocatable :: b(:,:)
+
+ class(adj_matrix(4,:,:)),allocatable :: adj_4 ! Ditto and ....
+ real(4) :: a_4(3,2) ! ... these declarations were
+ real(4),allocatable :: b_4(:,:) ! added to check KIND=4
+
+! Check constructor of PDT and instrinsic assignment
+ adj = adj_matrix(INT(8,8),2,4)
+ if (adj%k .ne. 8) call abort
+ if (adj%c .ne. 2) call abort
+ if (adj%r .ne. 4) call abort
+ a = reshape ([(i, i = 1, 6)], [2,3])
+ adj = a
+ b = adj
+ if (any (b .ne. a)) call abort
+
+! Check allocation with MOLD of PDT. Note that only KIND parameters set.
+ allocate (adj_4, mold = adj_matrix(4,3,2)) ! Added check of KIND = 4
+ if (adj_4%k .ne. 4) call abort
+ a_4 = reshape (a, [3,2])
+ adj_4 = a_4
+ b_4 = adj_4
+ if (any (b_4 .ne. a_4)) call abort
+
+end program adj3
+
+
+
projects / gcc.git / commitdiff