Provisonal patch for Parameterized Derived Types
Paul Richard Thomas
paul.richard.thomas@gmail.com
Wed Aug 16 19:50:00 GMT 2017
Dear All,
My silence for the last weeks has been caused by an intense period of
activity to develop a patch to implement PDTs in gfortran.
The attached patch is, as yet, incomplete and buggy. It is certainly
not ready to be committed. I am posting it now in order that it get
some exposure and testing over the next few weeks because I will be
away for ten days and will have to attend to PR34640 and some other
recent PRs on my return.
Please use the -l option with patch because I am sure that there are
some whitespace issues.
Rather than prepare a ChangeLog at this stage, I have attached some
notes on the implementation. This indicates some of the weaknesses and
problem areas.
I suggest that a good read of Mark Leair's excellent PGInsider article
on PDTS - http://www.pgroup.com/lit/articles/insider/v5n2a4.htm is a
worthwhile exercise.
I have attached a modified version of Marks' third example. Comments
have been added to show where changes have been made. Half of them are
for issues other than with the PDT implementation. Note that the
copyright notice at the top of the example must be retained.
Best regards
Paul
-------------- next part --------------
Index: gcc/fortran/decl.c
===================================================================
*** gcc/fortran/decl.c (revision 250712)
--- gcc/fortran/decl.c (working copy)
*************** gfc_symbol *gfc_new_block;
*** 94,99 ****
--- 94,108 ----
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 *********************/
*************** build_sym (const char *name, gfc_charlen
*** 1499,1504 ****
--- 1508,1518 ----
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);
*************** build_struct (const char *name, gfc_char
*** 1945,1950 ****
--- 1959,1969 ----
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;
*************** scalar:
*** 1998,2003 ****
--- 2017,2047 ----
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 %s 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;
}
*************** gfc_match_kind_spec (gfc_typespec *ts, b
*** 2564,2569 ****
--- 2608,2614 ----
m = MATCH_NO;
n = MATCH_YES;
e = NULL;
+ saved_kind_expr = NULL;
where = loc = gfc_current_locus;
*************** gfc_match_kind_spec (gfc_typespec *ts, b
*** 2580,2587 ****
--- 2625,2640 ----
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)
*************** kind_expr:
*** 2657,2662 ****
--- 2710,2717 ----
"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 != ','))
*************** match_record_decl (char *name)
*** 2980,2985 ****
--- 3035,3406 ----
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);
+ 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->name)
+ name_seen = true;
+ param = type_param_name_list->sym;
+
+ kind_expr = NULL;
+ if (!name_seen)
+ {
+ if (actual_param && actual_param->expr)
+ kind_expr = gfc_copy_expr (actual_param->expr);
+ else if (actual_param && actual_param->label
+ && actual_param->label->value == -1)
+ kind_expr = gfc_get_int_expr (gfc_default_integer_kind, NULL, 0);
+ }
+ 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->label)
+ kind_expr = gfc_copy_expr (actual_param->expr);
+ else
+ {
+ if (param->value)
+ kind_expr = gfc_copy_expr (param->value);
+ else if (!(actual_param && actual_param->label
+ && param->attr.pdt_len))
+ {
+ gfc_error ("The derived parameter '%s' at %C does not "
+ "have a default value", param->name);
+ return MATCH_ERROR;
+ }
+ else
+ kind_expr = gfc_get_int_expr (gfc_default_integer_kind, NULL, 0);
+ }
+ }
+
+ if (!kind_expr)
+ kind_expr = gfc_get_null_expr (NULL);
+
+ /* 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;
+ tail->expr = gfc_copy_expr (kind_expr);
+ /* Try simplification even for LEN expressions. */
+ gfc_simplify_expr (tail->expr, 1);
+
+ 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 (!kind_expr
+ || !gfc_simplify_expr (kind_expr, 1)
+ || !gfc_is_constant_expr (kind_expr))
+ {
+ gfc_error ("The value for the KIND parameter '%s' at %C does not "
+ "reduce to a constant expression", param->name);
+ 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;
+ }
+
+ 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);
+ }
+
+ 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 (c1->initializer)
+ c2->initializer = gfc_copy_expr (c1->initializer);
+
+ tail = tail->next;
+ }
+ 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);
+
+ 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 : 0;
+ }
+
+ /* 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.
*************** gfc_match_decl_type_spec (gfc_typespec *
*** 2998,3003 ****
--- 3419,3426 ----
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)
*************** gfc_match_decl_type_spec (gfc_typespec *
*** 3146,3152 ****
--- 3569,3581 ----
}
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_match_decl_type_spec (gfc_typespec *
*** 3161,3166 ****
--- 3590,3608 ----
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;
*************** gfc_match_decl_type_spec (gfc_typespec *
*** 3229,3241 ****
return m;
}
! m = gfc_match (" class ( %n )", name);
if (m != MATCH_YES)
return m;
ts->type = BT_CLASS;
if (!gfc_notify_std (GFC_STD_F2003, "CLASS statement at %C"))
return MATCH_ERROR;
}
/* Defer association of the derived type until the end of the
--- 3671,3697 ----
return m;
}
! 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
*************** gfc_match_decl_type_spec (gfc_typespec *
*** 3301,3306 ****
--- 3757,3774 ----
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_match_decl_type_spec (gfc_typespec *
*** 3311,3316 ****
--- 3779,3794 ----
&& !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;
*************** match_attr_spec (void)
*** 3840,3846 ****
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 */
};
/* GFC_DECL_END is the sentinel, index starts at 0. */
--- 4318,4324 ----
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_LEN, DECL_KIND, DECL_NONE, GFC_DECL_END /* Sentinel */
};
/* GFC_DECL_END is the sentinel, index starts at 0. */
*************** match_attr_spec (void)
*** 3982,3987 ****
--- 4460,4475 ----
}
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;
*************** match_attr_spec (void)
*** 4175,4180 ****
--- 4663,4674 ----
case DECL_OPTIONAL:
attr = "OPTIONAL";
break;
+ case DECL_KIND:
+ attr = "KIND";
+ break;
+ case DECL_LEN:
+ attr = "LEN";
+ break;
case DECL_PARAMETER:
attr = "PARAMETER";
break;
*************** match_attr_spec (void)
*** 4254,4259 ****
--- 4748,4801 ----
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",
*************** match_attr_spec (void)
*** 4291,4296 ****
--- 4833,4847 ----
}
}
+ 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:
*************** match_attr_spec (void)
*** 4343,4348 ****
--- 4894,4907 ----
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;
*************** gfc_match_data_decl (void)
*** 4832,4837 ****
--- 5391,5399 ----
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);
*************** ok:
*** 4946,4951 ****
--- 5508,5520 ----
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;
*************** copy_prefix (symbol_attribute *dest, loc
*** 5119,5128 ****
}
! /* Match a formal argument list. */
match
! gfc_match_formal_arglist (gfc_symbol *progname, int st_flag, int null_flag)
{
gfc_formal_arglist *head, *tail, *p, *q;
char name[GFC_MAX_SYMBOL_LEN + 1];
--- 5688,5699 ----
}
! /* 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, bool typeparam)
{
gfc_formal_arglist *head, *tail, *p, *q;
char name[GFC_MAX_SYMBOL_LEN + 1];
*************** gfc_match_formal_arglist (gfc_symbol *pr
*** 5174,5180 ****
if (m != MATCH_YES)
goto cleanup;
! if (gfc_get_symbol (name, NULL, &sym))
goto cleanup;
}
--- 5745,5754 ----
if (m != MATCH_YES)
goto cleanup;
! if (!typeparam && gfc_get_symbol (name, NULL, &sym))
! goto cleanup;
! else if (typeparam
! && gfc_get_symbol (name, progname->f2k_derived, &sym))
goto cleanup;
}
*************** gfc_match_derived_decl (void)
*** 8891,8896 ****
--- 9465,9472 ----
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;
*************** gfc_match_derived_decl (void)
*** 8918,8933 ****
if (parent[0] && !extended)
return MATCH_ERROR;
! if (gfc_match (" ::") != MATCH_YES && seen_attr)
{
gfc_error ("Expected :: in TYPE definition at %C");
return MATCH_ERROR;
}
! m = gfc_match (" %n%t", name);
if (m != MATCH_YES)
return m;
/* Make sure the name is not the name of an intrinsic type. */
if (gfc_is_intrinsic_typename (name))
{
--- 9494,9531 ----
if (parent[0] && !extended)
return MATCH_ERROR;
! 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 ", 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))
{
*************** gfc_match_derived_decl (void)
*** 9008,9016 ****
--- 9606,9626 ----
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);
*************** gfc_match_derived_decl (void)
*** 9035,9040 ****
--- 9645,9675 ----
/* 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)
Index: gcc/fortran/dump-parse-tree.c
===================================================================
*** gcc/fortran/dump-parse-tree.c (revision 250712)
--- gcc/fortran/dump-parse-tree.c (working copy)
*************** static void
*** 627,633 ****
--- 627,638 ----
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)
*************** show_attr (symbol_attribute *attr, const
*** 653,658 ****
--- 658,667 ----
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)
*************** show_components (gfc_symbol *sym)
*** 724,733 ****
--- 733,758 ----
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)
*************** show_symbol (gfc_symbol *sym)
*** 935,940 ****
--- 960,974 ----
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;
}
Index: gcc/fortran/expr.c
===================================================================
*** gcc/fortran/expr.c (revision 250712)
--- gcc/fortran/expr.c (working copy)
*************** gfc_copy_expr (gfc_expr *p)
*** 394,399 ****
--- 394,402 ----
q->ref = gfc_copy_ref (p->ref);
+ if (p->param_list)
+ q->param_list = gfc_copy_actual_arglist (p->param_list);
+
return q;
}
*************** free_expr0 (gfc_expr *e)
*** 499,504 ****
--- 502,509 ----
gfc_free_ref_list (e->ref);
+ gfc_free_actual_arglist (e->param_list);
+
memset (e, '\0', sizeof (gfc_expr));
}
*************** gfc_free_actual_arglist (gfc_actual_argl
*** 525,530 ****
--- 530,536 ----
while (a1)
{
a2 = a1->next;
+ if (a1->expr)
gfc_free_expr (a1->expr);
free (a1);
a1 = a2;
*************** gfc_is_constant_expr (gfc_expr *e)
*** 917,922 ****
--- 923,933 ----
|| 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:
*************** gfc_check_init_expr (gfc_expr *e)
*** 2531,2536 ****
--- 2542,2551 ----
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;
*************** gfc_match_init_expr (gfc_expr **result)
*** 2700,2705 ****
--- 2715,2727 ----
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)
{
*************** gfc_check_assign (gfc_expr *lvalue, gfc_
*** 3282,3287 ****
--- 3304,3317 ----
}
}
+ 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;
*************** gfc_expr_check_typed (gfc_expr* e, gfc_n
*** 4836,4841 ****
--- 4866,4894 ----
}
+ 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);
+ }
+
+
bool
gfc_ref_this_image (gfc_ref *ref)
{
Index: gcc/fortran/gfortran.h
===================================================================
*** gcc/fortran/gfortran.h (revision 250712)
--- gcc/fortran/gfortran.h (working copy)
*************** typedef struct
*** 869,874 ****
--- 869,879 ----
variable for SELECT_TYPE or ASSOCIATE. */
unsigned select_type_temporary:1, associate_var:1;
+ /* These are the attributes required for paramterized derived
+ types. */
+ unsigned pdt_kind:1, pdt_len:1, pdt_type:1, pdt_template:1,
+ pdt_array:1;
+
/* This is omp_{out,in,priv,orig} artificial variable in
!$OMP DECLARE REDUCTION. */
unsigned omp_udr_artificial_var:1;
*************** typedef struct gfc_component
*** 1052,1057 ****
--- 1057,1067 ----
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. */
*************** typedef struct gfc_symbol
*** 1506,1511 ****
--- 1516,1524 ----
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 */
*************** typedef struct gfc_expr
*** 2178,2183 ****
--- 2191,2199 ----
}
value;
+ /* Used to store PDT expression lists associated with expressions. */
+ gfc_actual_arglist *param_list;
+
}
gfc_expr;
*************** gfc_finalizer;
*** 2698,2703 ****
--- 2714,2725 ----
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_dimension (symbol_attribute
*** 2879,2884 ****
--- 2901,2908 ----
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 *);
*************** bool gfc_traverse_expr (gfc_expr *, gfc_
*** 3142,3148 ****
int);
void gfc_expr_set_symbols_referenced (gfc_expr *);
bool gfc_expr_check_typed (gfc_expr*, gfc_namespace*, bool);
!
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 *);
--- 3166,3172 ----
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_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 *);
Index: gcc/fortran/interface.c
===================================================================
*** gcc/fortran/interface.c (revision 250712)
--- gcc/fortran/interface.c (working copy)
*************** gfc_compare_derived_types (gfc_symbol *d
*** 645,651 ****
return false;
if (!(derived1->attr.sequence && derived2->attr.sequence)
! && !(derived1->attr.is_bind_c && derived2->attr.is_bind_c))
return false;
/* Protect against null components. */
--- 645,652 ----
return false;
if (!(derived1->attr.sequence && derived2->attr.sequence)
! && !(derived1->attr.is_bind_c && derived2->attr.is_bind_c)
! && !(derived1->attr.pdt_type && derived2->attr.pdt_type))
return false;
/* Protect against null components. */
Index: gcc/fortran/match.c
===================================================================
*** gcc/fortran/match.c (revision 250712)
--- gcc/fortran/match.c (working copy)
*************** bool gfc_matching_prefix = false;
*** 33,38 ****
--- 33,41 ----
/* 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 *
*************** match_derived_type_spec (gfc_typespec *t
*** 1955,1961 ****
{
char name[GFC_MAX_SYMBOL_LEN + 1];
locus old_locus;
! gfc_symbol *derived;
old_locus = gfc_current_locus;
--- 1958,1967 ----
{
char name[GFC_MAX_SYMBOL_LEN + 1];
locus old_locus;
! 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;
*************** match_derived_type_spec (gfc_typespec *t
*** 1967,1975 ****
--- 1973,2023 ----
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_match_type_spec (gfc_typespec *ts)
*** 1999,2004 ****
--- 2047,2053 ----
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_match_allocate (void)
*** 4059,4064 ****
--- 4108,4116 ----
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)
*************** alloc_opt_list:
*** 4236,4241 ****
--- 4288,4296 ----
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:
Index: gcc/fortran/match.h
===================================================================
*** gcc/fortran/match.h (revision 250712)
--- gcc/fortran/match.h (working copy)
*************** match gfc_match_decl_type_spec (gfc_type
*** 213,219 ****
match gfc_match_end (gfc_statement *);
match gfc_match_data_decl (void);
! match gfc_match_formal_arglist (gfc_symbol *, int, int);
match gfc_match_procedure (void);
match gfc_match_generic (void);
match gfc_match_function_decl (void);
--- 213,219 ----
match gfc_match_end (gfc_statement *);
match gfc_match_data_decl (void);
! 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_get_type_attr_spec (symbol_att
*** 274,280 ****
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_literal_constant (gfc_expr **, int);
/* expr.c -- FIXME: this one should be eliminated by moving the
--- 274,280 ----
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 **, bool = false);
match gfc_match_literal_constant (gfc_expr **, int);
/* expr.c -- FIXME: this one should be eliminated by moving the
Index: gcc/fortran/module.c
===================================================================
*** gcc/fortran/module.c (revision 250712)
--- gcc/fortran/module.c (working copy)
*************** enum ab_attribute
*** 1998,2004 ****
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
};
static const mstring attr_bits[] =
--- 1998,2005 ----
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_PDT_KIND, AB_PDT_LEN, AB_PDT_TYPE, AB_PDT_TEMPLATE, AB_PDT_ARRAY
};
static const mstring attr_bits[] =
*************** static const mstring attr_bits[] =
*** 2062,2067 ****
--- 2063,2073 ----
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 (NULL, -1)
};
*************** mio_symbol_attribute (symbol_attribute *
*** 2260,2265 ****
--- 2266,2281 ----
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);
mio_rparen ();
*************** mio_symbol_attribute (symbol_attribute *
*** 2453,2458 ****
--- 2469,2489 ----
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;
}
}
}
*************** mio_component (gfc_component *c, int vty
*** 2779,2784 ****
--- 2810,2818 ----
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;
*************** mio_full_f2k_derived (gfc_symbol *sym)
*** 3998,4004 ****
--- 4032,4054 ----
{
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;
+ gfc_free_namespace (ns);
+ ns = NULL;
+ }
+
mio_f2k_derived (sym->f2k_derived);
}
else
Index: gcc/fortran/primary.c
===================================================================
*** gcc/fortran/primary.c (revision 250712)
--- gcc/fortran/primary.c (working copy)
*************** match_actual_arg (gfc_expr **result)
*** 1612,1618 ****
/* Match a keyword argument. */
static match
! match_keyword_arg (gfc_actual_arglist *actual, gfc_actual_arglist *base)
{
char name[GFC_MAX_SYMBOL_LEN + 1];
gfc_actual_arglist *a;
--- 1612,1618 ----
/* Match a keyword argument. */
static match
! match_keyword_arg (gfc_actual_arglist *actual, gfc_actual_arglist *base, bool pdt)
{
char name[GFC_MAX_SYMBOL_LEN + 1];
gfc_actual_arglist *a;
*************** match_keyword_arg (gfc_actual_arglist *a
*** 1630,1641 ****
goto cleanup;
}
m = match_actual_arg (&actual->expr);
if (m != MATCH_YES)
goto cleanup;
/* Make sure this name has not appeared yet. */
!
if (name[0] != '\0')
{
for (a = base; a; a = a->next)
--- 1630,1653 ----
goto cleanup;
}
+ if (pdt && gfc_match_char ('*') == MATCH_YES)
+ {
+ actual->label = gfc_get_st_label (0);
+ goto add_name;
+ }
+
+ if (pdt && gfc_match_char (':') == MATCH_YES)
+ {
+ actual->label = gfc_get_st_label (-1);
+ goto add_name;
+ }
+
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)
*************** cleanup:
*** 1740,1746 ****
we're matching the argument list of a subroutine. */
match
! gfc_match_actual_arglist (int sub_flag, gfc_actual_arglist **argp)
{
gfc_actual_arglist *head, *tail;
int seen_keyword;
--- 1752,1758 ----
we're matching the argument list of a subroutine. */
match
! gfc_match_actual_arglist (int sub_flag, gfc_actual_arglist **argp, bool pdt)
{
gfc_actual_arglist *head, *tail;
int seen_keyword;
*************** gfc_match_actual_arglist (int sub_flag,
*** 1758,1763 ****
--- 1770,1776 ----
if (gfc_match_char (')') == MATCH_YES)
return MATCH_YES;
+
head = NULL;
matching_actual_arglist++;
*************** gfc_match_actual_arglist (int sub_flag,
*** 1772,1779 ****
tail = tail->next;
}
! if (sub_flag && gfc_match_char ('*') == MATCH_YES)
{
m = gfc_match_st_label (&label);
if (m == MATCH_NO)
gfc_error ("Expected alternate return label at %C");
--- 1785,1798 ----
tail = tail->next;
}
! if (sub_flag && !(pdt && seen_keyword)
! && gfc_match_char ('*') == MATCH_YES)
{
+ if (pdt)
+ {
+ tail->label = gfc_get_st_label (0);
+ goto next;
+ }
m = gfc_match_st_label (&label);
if (m == MATCH_NO)
gfc_error ("Expected alternate return label at %C");
*************** gfc_match_actual_arglist (int sub_flag,
*** 1788,1798 ****
goto next;
}
/* After the first keyword argument is seen, the following
arguments must also have keywords. */
if (seen_keyword)
{
! m = match_keyword_arg (tail, head);
if (m == MATCH_ERROR)
goto cleanup;
--- 1807,1824 ----
goto next;
}
+ if (pdt && !seen_keyword
+ && gfc_match_char (':') == MATCH_YES)
+ {
+ tail->label = gfc_get_st_label (-1);
+ goto next;
+ }
+
/* After the first keyword argument is seen, the following
arguments must also have keywords. */
if (seen_keyword)
{
! m = match_keyword_arg (tail, head, pdt);
if (m == MATCH_ERROR)
goto cleanup;
*************** gfc_match_actual_arglist (int sub_flag,
*** 1813,1819 ****
/* See if we have the first keyword argument. */
if (m == MATCH_NO)
{
! m = match_keyword_arg (tail, head);
if (m == MATCH_YES)
seen_keyword = 1;
if (m == MATCH_ERROR)
--- 1839,1845 ----
/* See if we have the first keyword argument. */
if (m == MATCH_NO)
{
! m = match_keyword_arg (tail, head, false);
if (m == MATCH_YES)
seen_keyword = 1;
if (m == MATCH_ERROR)
Index: gcc/fortran/resolve.c
===================================================================
*** gcc/fortran/resolve.c (revision 250712)
--- gcc/fortran/resolve.c (working copy)
*************** resolve_contained_functions (gfc_namespa
*** 1130,1135 ****
--- 1130,1225 ----
}
+
+ /* 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->label = gfc_get_st_label (0);
+ 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_symbol *derived)
+ {
+ gfc_constructor *cons;
+ gfc_component *comp, *c;
+ bool t = true;
+
+ cons = gfc_constructor_first (expr->value.constructor);
+ 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, comp->ts.u.derived);
+ if (!t)
+ return t;
+ }
+ else if (comp->ts.type == BT_DERIVED)
+ {
+ c = comp->ts.u.derived->components;
+ for (; c && cons; c = c->next, cons = gfc_constructor_next (cons))
+ {
+ if (c->ts.type == BT_DERIVED)
+ {
+ gfc_error ("Please use constructor for %s at %C",
+ c->ts.u.derived->name);
+ return false;
+ }
+ else if ((c->attr.pdt_kind || c->attr.pdt_len)
+ && comp->ts.u.derived->attr.pdt_template)
+ {
+ t = get_pdt_spec_expr (c, cons->expr);
+ 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_structure_cons (gfc_expr *expr,
*** 1154,1159 ****
--- 1244,1266 ----
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, expr->ts.u.derived);
+ if (!t)
+ return t;
+ gfc_get_pdt_instance (param_list, &expr->ts.u.derived, NULL);
+
+ 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);
*************** resolve_component (gfc_component *c, gfc
*** 13647,13652 ****
--- 13754,13760 ----
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;
Index: gcc/fortran/symbol.c
===================================================================
*** gcc/fortran/symbol.c (revision 250712)
--- gcc/fortran/symbol.c (working copy)
*************** gfc_add_optional (symbol_attribute *attr
*** 1106,1111 ****
--- 1106,1137 ----
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)
*************** free_components (gfc_component *p)
*** 2447,2452 ****
--- 2473,2482 ----
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);
*************** gfc_free_symbol (gfc_symbol *sym)
*** 2929,2934 ****
--- 2959,2967 ----
set_symbol_common_block (sym, NULL);
+ if (sym->param_list)
+ gfc_free_actual_arglist (sym->param_list);
+
free (sym);
}
*************** gfc_find_sym_tree (const char *name, gfc
*** 3091,3097 ****
--- 3124,3148 ----
}
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;
}
*************** gfc_free_namespace (gfc_namespace *ns)
*** 3887,3895 ****
if (ns == NULL)
return;
- ns->refs--;
if (ns->refs > 0)
return;
gcc_assert (ns->refs == 0);
gfc_free_statements (ns->code);
--- 3938,3949 ----
if (ns == NULL)
return;
if (ns->refs > 0)
+ {
+ ns->refs--;
return;
+ }
+
gcc_assert (ns->refs == 0);
gfc_free_statements (ns->code);
Index: gcc/fortran/trans-array.c
===================================================================
*** gcc/fortran/trans-array.c (revision 250712)
--- gcc/fortran/trans-array.c (working copy)
*************** gfc_caf_is_dealloc_only (int caf_mode)
*** 8073,8079 ****
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};
static tree
structure_alloc_comps (gfc_symbol * der_type, tree decl,
--- 8073,8082 ----
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,
! ALLOCATE_PDT_COMP, DEALLOCATE_PDT_COMP};
!
! static gfc_actual_arglist *pdt_param_list;
static tree
structure_alloc_comps (gfc_symbol * der_type, tree decl,
*************** structure_alloc_comps (gfc_symbol * der_
*** 8735,8740 ****
--- 8738,8904 ----
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);
+ if (c->param_list && c->param_list->expr
+ && c->param_list->expr->expr_type != EXPR_NULL)
+ c_expr = c->param_list->expr;
+ else
+ {
+ for (; param; param = param->next)
+ if (!strcmp (c->name, param->name))
+ c_expr = param->expr;
+ }
+ if (c_expr)
+ {
+ gfc_conv_expr_type (&tse, c_expr, TREE_TYPE (comp));
+ gfc_add_modify (&fnblock, comp, tse.expr);
+ }
+ }
+
+ /* Allocate array or parameterized string length components
+ 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 || tail->expr->expr_type == EXPR_NULL)
+ 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->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);
+ }
+
+ break;
+
default:
gcc_unreachable ();
break;
*************** gfc_copy_only_alloc_comp (gfc_symbol * d
*** 8814,8819 ****
--- 8978,9010 ----
}
+ /* 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);
+ }
+
+
/* 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. */
Index: gcc/fortran/trans-array.h
===================================================================
*** gcc/fortran/trans-array.h (revision 250712)
--- gcc/fortran/trans-array.h (working copy)
*************** tree gfc_copy_alloc_comp (gfc_symbol *,
*** 59,64 ****
--- 59,67 ----
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_alloc_allocatable_for_assignment (gfc_loopinfo*, gfc_expr*, gfc_expr*);
/* Add initialization for deferred arrays. */
Index: gcc/fortran/trans-decl.c
===================================================================
*** gcc/fortran/trans-decl.c (revision 250712)
--- gcc/fortran/trans-decl.c (working copy)
*************** gfc_get_symbol_decl (gfc_symbol * sym)
*** 1483,1488 ****
--- 1483,1496 ----
}
}
+ /* 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);
+
/* 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_trans_deferred_vars (gfc_symbol * pr
*** 4159,4164 ****
--- 4167,4173 ----
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;
*************** gfc_trans_deferred_vars (gfc_symbol * pr
*** 4269,4274 ****
--- 4278,4320 ----
if (sym->assoc)
continue;
+ if (sym->ts.type == BT_DERIVED
+ && sym->ts.u.derived
+ && sym->ts.u.derived->attr.pdt_type
+ && !(sym->attr.pointer || sym->attr.allocatable))
+ {
+ is_pdt_type = true;
+ gfc_init_block (&tmpblock);
+ 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->ts.type == BT_CLASS
+ && CLASS_DATA (sym)->ts.u.derived
+ && CLASS_DATA (sym)->ts.u.derived->attr.pdt_type
+ && !(CLASS_DATA (sym)->attr.pointer
+ || CLASS_DATA (sym)->attr.allocatable))
+ {
+ gfc_component *data = CLASS_DATA (sym);
+ is_pdt_type = true;
+ gfc_init_block (&tmpblock);
+ tmp = gfc_allocate_pdt_comp (data->ts.u.derived,
+ gfc_class_data_get (sym->backend_decl),
+ data->as ? data->as->rank : 0,
+ sym->param_list);
+ gfc_add_expr_to_block (&tmpblock, tmp);
+ tmp = gfc_deallocate_pdt_comp (data->ts.u.derived,
+ gfc_class_data_get (sym->backend_decl),
+ data->as ? data->as->rank : 0);
+ gfc_add_init_cleanup (block, gfc_finish_block (&tmpblock), tmp);
+ }
+
if (sym->attr.subref_array_pointer
&& GFC_DECL_SPAN (sym->backend_decl)
&& !TREE_STATIC (GFC_DECL_SPAN (sym->backend_decl)))
*************** gfc_trans_deferred_vars (gfc_symbol * pr
*** 4601,4607 ****
gfc_add_init_cleanup (block, gfc_finish_block (&tmpblock),
NULL_TREE);
}
! else if (!(UNLIMITED_POLY(sym)))
gcc_unreachable ();
}
--- 4647,4653 ----
gfc_add_init_cleanup (block, gfc_finish_block (&tmpblock),
NULL_TREE);
}
! else if (!(UNLIMITED_POLY(sym)) && !is_pdt_type)
gcc_unreachable ();
}
Index: gcc/fortran/trans-expr.c
===================================================================
*** gcc/fortran/trans-expr.c (revision 250712)
--- gcc/fortran/trans-expr.c (working copy)
*************** gfc_trans_subcomponent_assign (tree dest
*** 7286,7292 ****
{
if (cm->attr.allocatable && expr->expr_type == EXPR_NULL)
gfc_conv_descriptor_data_set (&block, dest, null_pointer_node);
! else if (cm->attr.allocatable)
{
tmp = gfc_trans_alloc_subarray_assign (dest, cm, expr);
gfc_add_expr_to_block (&block, tmp);
--- 7286,7292 ----
{
if (cm->attr.allocatable && expr->expr_type == EXPR_NULL)
gfc_conv_descriptor_data_set (&block, dest, null_pointer_node);
! 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);
Index: gcc/fortran/trans-stmt.c
===================================================================
*** gcc/fortran/trans-stmt.c (revision 250712)
--- gcc/fortran/trans-stmt.c (working copy)
*************** gfc_trans_allocate (gfc_code * code)
*** 6337,6342 ****
--- 6337,6361 ----
gfc_free_statements (ini);
gfc_add_expr_to_block (&block, tmp);
}
+ /* Allocate PDT components that are parameterized. */
+ else if (expr->ts.type == BT_DERIVED
+ && expr->ts.u.derived->attr.pdt_type
+ && expr->symtree->n.sym->param_list)
+ {
+ tmp = gfc_allocate_pdt_comp (expr->ts.u.derived, se.expr, expr->rank,
+ expr->param_list ? expr->param_list :
+ expr->symtree->n.sym->param_list);
+ gfc_add_expr_to_block (&block, tmp);
+ }
+ else if (expr->ts.type == BT_CLASS
+ && CLASS_DATA (expr)->ts.u.derived->attr.pdt_type
+ && expr->symtree->n.sym->param_list)
+ {
+ tmp = gfc_allocate_pdt_comp (CLASS_DATA (expr)->ts.u.derived,
+ se.expr, expr->rank,
+ expr->symtree->n.sym->param_list);
+ gfc_add_expr_to_block (&block, tmp);
+ }
else if ((init_expr = allocate_get_initializer (code, expr)))
{
/* Use class_init_assign to initialize expr. */
*************** gfc_trans_deallocate (gfc_code *code)
*** 6533,6538 ****
--- 6552,6572 ----
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)
{
Index: gcc/fortran/trans-types.c
===================================================================
*** gcc/fortran/trans-types.c (revision 250712)
--- gcc/fortran/trans-types.c (working copy)
*************** gfc_get_derived_type (gfc_symbol * deriv
*** 2437,2442 ****
--- 2437,2444 ----
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
*************** gfc_get_derived_type (gfc_symbol * deriv
*** 2648,2654 ****
required. */
if ((c->attr.dimension || c->attr.codimension) && !c->attr.proc_pointer )
{
! if (c->attr.pointer || c->attr.allocatable)
{
enum gfc_array_kind akind;
if (c->attr.pointer)
--- 2650,2656 ----
required. */
if ((c->attr.dimension || c->attr.codimension) && !c->attr.proc_pointer )
{
! if (c->attr.pointer || c->attr.allocatable || c->attr.pdt_array)
{
enum gfc_array_kind akind;
if (c->attr.pointer)
-------------- next part --------------
Notes on provisional implementation of Parameterized Derived Types in gfortran
1) Derived type definition:
___________________________
R425
derived-type-def is derived-type-stmt
[ type-param-def-stmt ]
[ private-or-sequence ] ...
[ component-part ]
[ type-bound-procedure-part ]
end-type-stmt
R426
derived-type-stmt is TYPE [ [ , type-attr-spec-list ] :: ] type-name [ ( type-param-name-list ) ]
Example in Note 4.23:
The following example uses derived-type parameters.
TYPE humongous_matrix(k, d) ! ( type-param-name-list ) = (k,d)
INTEGER, KIND :: k = kind(0.0) ! KIND parameter values known at compile time.
INTEGER(selected_int_kind(12)), LEN :: d ! LEN parameters may not be known at compile time
!-- Specify a nondefault kind for d.
REAL(k) :: element(d,d)
END TYPE
In the present version of the patch, the 'type-param-name-list' is stored as a formal_arglist in the 'formal' field of the derived type symbol, since it is not otherwise used.
The gfc_symbols associated with the formal_arglist are added to the derived type 'f2k_derived' namespace, which was one of the reasons why this namespace was introduced in the first place.
In this example, 'humongous_matrix is marked with the attribute pdt_template and the components {k,d,element} with attributes {pdt_kind,pdt_len,pdt_array}
A new gfc_component field 'kind_expr' has been added, such that kind expressions, such as that for 'element' can be stored. The array bound expressions are stored in the arrayspec as usual.
Type extension has been implemented and ensures that the extension picks up a copy of the 'type-param-name-list' of the extended type, which is concatenated with such new 'type-param-name-list' as there might be.
2) Type declaration statements:
_______________________________
R501
type-declaration-stmt is declaration-type-spec [ [ , attr-spec ] ... :: ] entity-decl -list
R403
declaration-type-spec is intrinsic-type-spec
or TYPE ( intrinsic-type-spec )
or TYPE ( derived-type-spec )
or CLASS ( derived-type-spec )
or CLASS ( * )
R453
derived-type-spec is type-name [ ( type-param-spec-list ) ]
R454 type-param-spec is [ keyword = ] type-param-value
R401
type-param-value is scalar-int-expr
or *
or :
Example in Note 5.1:
TYPE (humongous_matrix (k=8, d=1000)) :: mat
Given the similarity to actual arguments, gfc_actual_arglist has been taken over to represent the type_param_spec_list.
'param_list' fields have been added to gfc_expr, gfc_symbol and gfc_component to store all or part of the type-param-spec-list, as required.
The workhorse in the present implementation is decl.c(gfc_get_pdt_instance), which converts the pdt templates into instances of pdt types. These have the attribute pdt_type naturally enough.
'gfc_get_pdt_instance' ensures that the expressions for the KIND parameters can be simplified to constant expressions and the instance naming is Pdt//template_name//_kind.val1_kind.val2...
The instance of the example above is named 'Pdthumongous_matrix_8
Ideally, the name would have started with a non_alpha character so that it would not be possible to cause a clash with an explicitly declared entity. Unfortunately, this would interfere with the mechanism distinguishing the type from its constructor, where leading upper and lower case are used respectively. Using '@' between 'Pdt' and the template name worked until CLASS declarations were introduced, when all sorts of linker problems were caused by the naming of the functions associated with the vtables. This will have to be fixed.
It should be noted that I have thus far been rather cavalier about assumed and deferred parameters. The requisite checks will have to be added to comply with all the relevant constraints.
Also, where explicit 'type-param-value's are given to dummy arguments, no (runtime) checks have been implemented to assert that the actual argument parameter values are compliant.
I am reasonably sure that some of the calls to 'gfc_get_pdt_instance' leak memory because the type-param-spec-list is not freed.
3) Matching typespecs in other situations (eg. ALLOCATE statements)
___________________________________________________________________
This has been done in match.c(gfc_match_decl_type_spec) using 'gfc_get_pdt_instance'. Notice that this is only used in the ALLOCATE statement in the present patch. In the PGInsider article on the subject of PDTs, allocate(adj_matrix(8,c,r)::mat) appears, which is matched by this mechanism.
For reasons that I have not yet identified, allocate(adj_matrix(4,size(s,1),size(s,2))::d) causes link errors due to 'undefined size_'.
4) Runtime initialization of PDT entities
_________________________________________
This has been accomplished by extending the allocatable component workhorse trans-array.c(structure_alloc_comps) to include the calls 'gfc_allocate_pdt_comp' and 'gfc_deallocate_pdt_comp'.
Note that parameterized length CHARACTERs are not yet implemented due to lack of time.
The implementation allows recursion into extended types and PDT components.
The handling of assumed and deferred parameters is not very clean at present.
I have yet to peruse the standard to understood what should happen to use associated PDT entities.
trans_decl.c(gfc_trans_deferred_vars) handles the intialization and automatic deallocation calls. I am sure that this is leaky and not always consistent.
trans-stmt.c(gfc_trans_allocate) & (gfc_trans_deallocate) seem to work correctly and to call 'gfc_allocate_pdt_comp' as required. However, this has not been extensively tested as yet.
I have not checked fully for runtime memory leaks.
5) Other remarks
________________
I have restricted LEN parameters to be of default integer kind. I note from the standard, for example i 1) above, that this is not necessary.
I made some changes to dump-parse-tree.c because components in particular were getting very cluttered with the new fields.
interface.c(gfc_compare_derived_types) had to be modified to ensure that like 'pdt_type's were not rejected.
In module.c(mio_full_f2k_derived) the 'sym_root' of the formal namespace is hijacked and appended to the 'f2k_derived' namespace. I suspect that this is the cause of the problem in symbol.c(gfc_free_namespace), where namespaces with zero or negative 'refs' appear, which has necessitated the temporary kludge in the patch.
The new function resolve.c(get_pdt_constructor) has only one level of expansion of extended components at present. This will be extended later.
-------------- next part --------------
A non-text attachment was scrubbed...
Name: adj3.f90
Type: text/x-fortran
Size: 6159 bytes
Desc: not available
URL: <http://gcc.gnu.org/pipermail/fortran/attachments/20170816/4950138c/attachment.bin>
More information about the Fortran
mailing list