1 files changed, 693 insertions, 7 deletions

diff --git a/gcc/fortran/decl.c b/gcc/fortran/decl.c
index b919f43..0609152 100644
--- a/gcc/fortran/decl.c
+++ b/gcc/fortran/decl.c
@@ -95,6 +95,15 @@ gfc_symbol *gfc_new_block;
 
 bool gfc_matching_function;
 
+/* If a kind expression of a component of a parameterized derived type is
+   parameterized, temporarily store the expression here.  */
+static gfc_expr *saved_kind_expr = NULL;
+
+/* Used to store the parameter list arising in a PDT declaration and
+   in the typespec of a PDT variable or component.  */
+static gfc_actual_arglist *decl_type_param_list;
+static gfc_actual_arglist *type_param_spec_list;
+
 
 /********************* DATA statement subroutines *********************/
 
@@ -1500,6 +1509,11 @@ build_sym (const char *name, gfc_charlen *cl, bool cl_deferred,
 
   sym->attr.implied_index = 0;
 
+  /* Use the parameter expressions for a parameterized derived type.  */
+  if ((sym->ts.type == BT_DERIVED || sym->ts.type == BT_CLASS)
+      && sym->ts.u.derived->attr.pdt_type && type_param_spec_list)
+    sym->param_list = gfc_copy_actual_arglist (type_param_spec_list);
+
   if (sym->ts.type == BT_CLASS)
     return gfc_build_class_symbol (&sym->ts, &sym->attr, &sym->as);
 
@@ -1946,6 +1960,11 @@ build_struct (const char *name, gfc_charlen *cl, gfc_expr **init,
   c->ts = current_ts;
   if (c->ts.type == BT_CHARACTER)
     c->ts.u.cl = cl;
+
+  if (c->ts.type != BT_CLASS && c->ts.type != BT_DERIVED
+      && c->ts.kind == 0 && saved_kind_expr != NULL)
+    c->kind_expr = gfc_copy_expr (saved_kind_expr);
+
   c->attr = current_attr;
 
   c->initializer = *init;
@@ -1999,6 +2018,31 @@ scalar:
   if (c->ts.type == BT_CLASS)
     return gfc_build_class_symbol (&c->ts, &c->attr, &c->as);
 
+  if (c->attr.pdt_kind || c->attr.pdt_len)
+    {
+      gfc_symbol *sym;
+      gfc_find_symbol (c->name, gfc_current_block ()->f2k_derived,
+		       0, &sym);
+      if (sym == NULL)
+	{
+	  gfc_error ("Type parameter %qs at %C has no corresponding entry "
+		     "in the type parameter name list at %L",
+		     c->name, &gfc_current_block ()->declared_at);
+	  return false;
+	}
+      sym->ts = c->ts;
+      sym->attr.pdt_kind = c->attr.pdt_kind;
+      sym->attr.pdt_len = c->attr.pdt_len;
+      if (c->initializer)
+	sym->value = gfc_copy_expr (c->initializer);
+      sym->attr.flavor = FL_VARIABLE;
+    }
+
+  if ((c->ts.type == BT_DERIVED || c->ts.type == BT_CLASS)
+      && c->ts.u.derived && c->ts.u.derived->attr.pdt_template
+      && decl_type_param_list)
+    c->param_list = gfc_copy_actual_arglist (decl_type_param_list);
+
   return true;
 }
 
@@ -2612,6 +2656,7 @@ gfc_match_kind_spec (gfc_typespec *ts, bool kind_expr_only)
   m = MATCH_NO;
   n = MATCH_YES;
   e = NULL;
+  saved_kind_expr = NULL;
 
   where = loc = gfc_current_locus;
 
@@ -2628,8 +2673,16 @@ gfc_match_kind_spec (gfc_typespec *ts, bool kind_expr_only)
   loc = gfc_current_locus;
 
 kind_expr:
+
   n = gfc_match_init_expr (&e);
 
+  if (gfc_derived_parameter_expr (e))
+    {
+      ts->kind = 0;
+      saved_kind_expr = gfc_copy_expr (e);
+      goto close_brackets;
+    }
+
   if (n != MATCH_YES)
     {
       if (gfc_matching_function)
@@ -2707,6 +2760,8 @@ kind_expr:
 		     "is %s", gfc_basic_typename (ts->f90_type), &where,
 		     gfc_basic_typename (ts->type));
 
+close_brackets:
+
   gfc_gobble_whitespace ();
   if ((c = gfc_next_ascii_char ()) != ')'
       && (ts->type != BT_CHARACTER || c != ','))
@@ -3030,6 +3085,423 @@ match_record_decl (char *name)
   return MATCH_ERROR;
 }
 
+
+/* This function uses the gfc_actual_arglist 'type_param_spec_list' as a source
+   of expressions to substitute into the possibly parameterized expression
+   'e'. Using a list is inefficient but should not be too bad since the
+   number of type parameters is not likely to be large.  */
+static bool
+insert_parameter_exprs (gfc_expr* e, gfc_symbol* sym ATTRIBUTE_UNUSED,
+			int* f)
+{
+  gfc_actual_arglist *param;
+  gfc_expr *copy;
+
+  if (e->expr_type != EXPR_VARIABLE)
+    return false;
+
+  gcc_assert (e->symtree);
+  if (e->symtree->n.sym->attr.pdt_kind
+      || (*f != 0 && e->symtree->n.sym->attr.pdt_len))
+    {
+      for (param = type_param_spec_list; param; param = param->next)
+	if (strcmp (e->symtree->n.sym->name, param->name) == 0)
+	  break;
+
+      if (param)
+	{
+	  copy = gfc_copy_expr (param->expr);
+	  *e = *copy;
+	  free (copy);
+	}
+    }
+
+  return false;
+}
+
+
+bool
+gfc_insert_kind_parameter_exprs (gfc_expr *e)
+{
+  return gfc_traverse_expr (e, NULL, &insert_parameter_exprs, 0);
+}
+
+
+bool
+gfc_insert_parameter_exprs (gfc_expr *e, gfc_actual_arglist *param_list)
+{
+  gfc_actual_arglist *old_param_spec_list = type_param_spec_list;
+  type_param_spec_list = param_list;
+  return gfc_traverse_expr (e, NULL, &insert_parameter_exprs, 1);
+  type_param_spec_list = NULL;
+  type_param_spec_list = old_param_spec_list;
+}
+
+/* Determines the instance of a parameterized derived type to be used by
+   matching determining the values of the kind parameters and using them
+   in the name of the instance. If the instance exists, it is used, otherwise
+   a new derived type is created.  */
+match
+gfc_get_pdt_instance (gfc_actual_arglist *param_list, gfc_symbol **sym,
+		      gfc_actual_arglist **ext_param_list)
+{
+  /* The PDT template symbol.  */
+  gfc_symbol *pdt = *sym;
+  /* The symbol for the parameter in the template f2k_namespace.  */
+  gfc_symbol *param;
+  /* The hoped for instance of the PDT.  */
+  gfc_symbol *instance;
+  /* The list of parameters appearing in the PDT declaration.  */
+  gfc_formal_arglist *type_param_name_list;
+  /* Used to store the parameter specification list during recursive calls.  */
+  gfc_actual_arglist *old_param_spec_list;
+  /* Pointers to the parameter specification being used.  */
+  gfc_actual_arglist *actual_param;
+  gfc_actual_arglist *tail = NULL;
+  /* Used to build up the name of the PDT instance. The prefix uses 4
+     characters and each KIND parameter 2 more.  Allow 8 of the latter. */
+  char name[GFC_MAX_SYMBOL_LEN + 21];
+
+  bool name_seen = (param_list == NULL);
+  bool assumed_seen = false;
+  bool deferred_seen = false;
+  bool spec_error = false;
+  int kind_value, i;
+  gfc_expr *kind_expr;
+  gfc_component *c1, *c2;
+  match m;
+
+  type_param_spec_list = NULL;
+
+  type_param_name_list = pdt->formal;
+  actual_param = param_list;
+  sprintf (name, "Pdt%s", pdt->name);
+
+  /* Run through the parameter name list and pick up the actual
+     parameter values or use the default values in the PDT declaration.  */
+  for (; type_param_name_list;
+       type_param_name_list = type_param_name_list->next)
+    {
+      if (actual_param && actual_param->spec_type != SPEC_EXPLICIT)
+	{
+	  if (actual_param->spec_type == SPEC_ASSUMED)
+	    spec_error = deferred_seen;
+	  else
+	    spec_error = assumed_seen;
+
+	  if (spec_error)
+	    {
+	      gfc_error ("The type parameter spec list at %C cannot contain "
+			 "both ASSUMED and DEFERRED parameters");
+	      gfc_free_actual_arglist (type_param_spec_list);
+	      return MATCH_ERROR;
+	    }
+	}
+
+      if (actual_param && actual_param->name)
+	name_seen = true;
+      param = type_param_name_list->sym;
+
+      kind_expr = NULL;
+      if (!name_seen)
+	{
+	  if (actual_param && actual_param->spec_type == SPEC_EXPLICIT)
+	    kind_expr = gfc_copy_expr (actual_param->expr);
+	}
+      else
+	{
+	  actual_param = param_list;
+	  for (;actual_param; actual_param = actual_param->next)
+	    if (actual_param->name
+	        && strcmp (actual_param->name, param->name) == 0)
+	      break;
+	  if (actual_param && actual_param->spec_type == SPEC_EXPLICIT)
+	    kind_expr = gfc_copy_expr (actual_param->expr);
+	  else
+	    {
+	      if (param->value)
+		kind_expr = gfc_copy_expr (param->value);
+	      else if (!(actual_param && param->attr.pdt_len))
+		{
+		  gfc_error ("The derived parameter '%qs' at %C does not "
+			     "have a default value", param->name);
+		  return MATCH_ERROR;
+		}
+	    }
+	}
+
+      /* Store the current parameter expressions in a temporary actual
+	 arglist 'list' so that they can be substituted in the corresponding
+	 expressions in the PDT instance.  */
+      if (type_param_spec_list == NULL)
+	{
+	  type_param_spec_list = gfc_get_actual_arglist ();
+	  tail = type_param_spec_list;
+	}
+      else
+	{
+	  tail->next = gfc_get_actual_arglist ();
+	  tail = tail->next;
+	}
+      tail->name = param->name;
+
+      if (kind_expr)
+	{
+	  tail->expr = gfc_copy_expr (kind_expr);
+	  /* Try simplification even for LEN expressions.  */
+	  gfc_simplify_expr (tail->expr, 1);
+	}
+
+      if (actual_param)
+	tail->spec_type = actual_param->spec_type;
+
+      if (!param->attr.pdt_kind)
+	{
+	  if (!name_seen)
+	    actual_param = actual_param->next;
+	  if (kind_expr)
+	    {
+	      gfc_free_expr (kind_expr);
+	      kind_expr = NULL;
+	    }
+	  continue;
+	}
+
+      if (actual_param
+	  && (actual_param->spec_type == SPEC_ASSUMED
+	      || actual_param->spec_type == SPEC_DEFERRED))
+	{
+	  gfc_error ("The KIND parameter '%qs' at %C cannot either be "
+		     "ASSUMED or DEFERRED", param->name);
+	  gfc_free_actual_arglist (type_param_spec_list);
+	  return MATCH_ERROR;
+	}
+
+      if (!kind_expr || !gfc_is_constant_expr (kind_expr))
+	{
+	  gfc_error ("The value for the KIND parameter '%qs' at %C does not "
+		     "reduce to a constant expression", param->name);
+	  gfc_free_actual_arglist (type_param_spec_list);
+	  return MATCH_ERROR;
+	}
+
+      gfc_extract_int (kind_expr, &kind_value);
+      sprintf (name, "%s_%d", name, kind_value);
+
+      if (!name_seen && actual_param)
+	actual_param = actual_param->next;
+      gfc_free_expr (kind_expr);
+    }
+
+  /* Now we search for the PDT instance 'name'. If it doesn't exist, we
+     build it, using 'pdt' as a template.  */
+  if (gfc_get_symbol (name, pdt->ns, &instance))
+    {
+      gfc_error ("Parameterized derived type at %C is ambiguous");
+      return MATCH_ERROR;
+    }
+
+  m = MATCH_YES;
+
+  if (instance->attr.flavor == FL_DERIVED
+      && instance->attr.pdt_type)
+    {
+      instance->refs++;
+      if (ext_param_list)
+        *ext_param_list = type_param_spec_list;
+      *sym = instance;
+      gfc_commit_symbols ();
+      return m;
+    }
+
+  /* Start building the new instance of the parameterized type.  */
+  gfc_copy_attr (&instance->attr, &pdt->attr, &pdt->declared_at);
+  instance->attr.pdt_template = 0;
+  instance->attr.pdt_type = 1;
+  instance->declared_at = gfc_current_locus;
+
+  /* Add the components, replacing the parameters in all expressions
+     with the expressions for their values in 'type_param_spec_list'.  */
+  c1 = pdt->components;
+  tail = type_param_spec_list;
+  for (; c1; c1 = c1->next)
+    {
+      gfc_add_component (instance, c1->name, &c2);
+      c2->ts = c1->ts;
+      c2->attr = c1->attr;
+
+      /* Deal with type extension by recursively calling this function
+	 to obtain the instance of the extended type.  */
+      if (gfc_current_state () != COMP_DERIVED
+	  && c1 == pdt->components
+	  && (c1->ts.type == BT_DERIVED || c1->ts.type == BT_CLASS)
+	  && c1->ts.u.derived && c1->ts.u.derived->attr.pdt_template
+	  && gfc_get_derived_super_type (*sym) == c2->ts.u.derived)
+	{
+	  gfc_formal_arglist *f;
+
+	  old_param_spec_list = type_param_spec_list;
+
+	  /* Obtain a spec list appropriate to the extended type..*/
+	  actual_param = gfc_copy_actual_arglist (type_param_spec_list);
+	  type_param_spec_list = actual_param;
+	  for (f = c1->ts.u.derived->formal; f && f->next; f = f->next)
+	    actual_param = actual_param->next;
+	  if (actual_param)
+	    {
+	      gfc_free_actual_arglist (actual_param->next);
+	      actual_param->next = NULL;
+	    }
+
+	  /* Now obtain the PDT instance for the extended type.  */
+	  c2->param_list = type_param_spec_list;
+	  m = gfc_get_pdt_instance (type_param_spec_list, &c2->ts.u.derived,
+				    NULL);
+	  type_param_spec_list = old_param_spec_list;
+
+	  c2->ts.u.derived->refs++;
+	  gfc_set_sym_referenced (c2->ts.u.derived);
+
+	  /* Set extension level.  */
+	  if (c2->ts.u.derived->attr.extension == 255)
+	    {
+	      /* Since the extension field is 8 bit wide, we can only have
+		 up to 255 extension levels.  */
+	      gfc_error ("Maximum extension level reached with type %qs at %L",
+			 c2->ts.u.derived->name,
+			 &c2->ts.u.derived->declared_at);
+	      return MATCH_ERROR;
+	    }
+	  instance->attr.extension = c2->ts.u.derived->attr.extension + 1;
+
+	  /* Advance the position in the spec list by the number of
+	     parameters in the extended type.  */
+	  tail = type_param_spec_list;
+	  for (f = c1->ts.u.derived->formal; f && f->next; f = f->next)
+	    tail = tail->next;
+
+	  continue;
+	}
+
+      /* Set the component kind using the parameterized expression.  */
+      if (c1->ts.kind == 0 && c1->kind_expr != NULL)
+	{
+	  gfc_expr *e = gfc_copy_expr (c1->kind_expr);
+	  gfc_insert_kind_parameter_exprs (e);
+	  gfc_extract_int (e, &c2->ts.kind);
+	  gfc_free_expr (e);
+	}
+
+      /* Similarly, set the string length if parameterized.  */
+      if (c1->ts.type == BT_CHARACTER
+	  && c1->ts.u.cl->length
+	  && gfc_derived_parameter_expr (c1->ts.u.cl->length))
+	{
+	  gfc_expr *e;
+	  e = gfc_copy_expr (c1->ts.u.cl->length);
+	  gfc_insert_kind_parameter_exprs (e);
+	  gfc_simplify_expr (e, 1);
+	  c2->ts.u.cl = gfc_new_charlen (gfc_current_ns, NULL);
+	  c2->ts.u.cl->length = e;
+	  c2->attr.pdt_string = 1;
+	}
+
+      /* Set up either the KIND/LEN initializer, if constant,
+	 or the parameterized expression. Use the template
+	 initializer if one is not already set in this instance.  */
+      if (c2->attr.pdt_kind || c2->attr.pdt_len)
+	{
+	  if (tail && tail->expr && gfc_is_constant_expr (tail->expr))
+	    c2->initializer = gfc_copy_expr (tail->expr);
+	  else if (tail && tail->expr)
+	    {
+	      c2->param_list = gfc_get_actual_arglist ();
+	      c2->param_list->name = tail->name;
+	      c2->param_list->expr = gfc_copy_expr (tail->expr);
+	      c2->param_list->next = NULL;
+	    }
+
+	  if (!c2->initializer && c1->initializer)
+	    c2->initializer = gfc_copy_expr (c1->initializer);
+
+	  tail = tail->next;
+	}
+
+      /* Copy the array spec.  */
+      c2->as = gfc_copy_array_spec (c1->as);
+      if (c1->ts.type == BT_CLASS)
+	CLASS_DATA (c2)->as = gfc_copy_array_spec (CLASS_DATA (c1)->as);
+
+      /* Determine if an array spec is parameterized. If so, substitute
+	 in the parameter expressions for the bounds and set the pdt_array
+	 attribute. Notice that this attribute must be unconditionally set
+	 if this is an array of parameterized character length.  */
+      if (c1->as && c1->as->type == AS_EXPLICIT)
+	{
+	  bool pdt_array = false;
+
+	  /* Are the bounds of the array parameterized?  */
+	  for (i = 0; i < c1->as->rank; i++)
+	    {
+	      if (gfc_derived_parameter_expr (c1->as->lower[i]))
+		pdt_array = true;
+	      if (gfc_derived_parameter_expr (c1->as->upper[i]))
+		pdt_array = true;
+	    }
+
+	  /* If they are, free the expressions for the bounds and
+	     replace them with the template expressions with substitute
+	     values.  */
+	  for (i = 0; pdt_array && i < c1->as->rank; i++)
+	    {
+	      gfc_expr *e;
+	      e = gfc_copy_expr (c1->as->lower[i]);
+	      gfc_insert_kind_parameter_exprs (e);
+	      gfc_simplify_expr (e, 1);
+	      gfc_free_expr (c2->as->lower[i]);
+	      c2->as->lower[i] = e;
+	      e = gfc_copy_expr (c1->as->upper[i]);
+	      gfc_insert_kind_parameter_exprs (e);
+	      gfc_simplify_expr (e, 1);
+	      gfc_free_expr (c2->as->upper[i]);
+	      c2->as->upper[i] = e;
+	    }
+	  c2->attr.pdt_array = pdt_array ? 1 : c2->attr.pdt_string;
+	}
+
+      /* Recurse into this function for PDT components.  */
+      if ((c1->ts.type == BT_DERIVED || c1->ts.type == BT_CLASS)
+	  && c1->ts.u.derived && c1->ts.u.derived->attr.pdt_template)
+	{
+	  gfc_actual_arglist *params;
+	  /* The component in the template has a list of specification
+	     expressions derived from its declaration.  */
+	  params = gfc_copy_actual_arglist (c1->param_list);
+	  actual_param = params;
+	  /* Substitute the template parameters with the expressions
+	     from the specification list.  */
+	  for (;actual_param; actual_param = actual_param->next)
+	    gfc_insert_parameter_exprs (actual_param->expr,
+					type_param_spec_list);
+
+	  /* Now obtain the PDT instance for the component.  */
+	  old_param_spec_list = type_param_spec_list;
+	  m = gfc_get_pdt_instance (params, &c2->ts.u.derived, NULL);
+	  type_param_spec_list = old_param_spec_list;
+
+	  c2->param_list = params;
+	  c2->initializer = gfc_default_initializer (&c2->ts);
+	}
+    }
+
+  gfc_commit_symbol (instance);
+  if (ext_param_list)
+    *ext_param_list = type_param_spec_list;
+  *sym = instance;
+  return m;
+}
+
+
 /* Matches a declaration-type-spec (F03:R502).  If successful, sets the ts
    structure to the matched specification.  This is necessary for FUNCTION and
    IMPLICIT statements.
@@ -3048,6 +3520,8 @@ gfc_match_decl_type_spec (gfc_typespec *ts, int implicit_flag)
   bool seen_deferred_kind, matched_type;
   const char *dt_name;
 
+  decl_type_param_list = NULL;
+
   /* A belt and braces check that the typespec is correctly being treated
      as a deferred characteristic association.  */
   seen_deferred_kind = (gfc_current_state () == COMP_FUNCTION)
@@ -3196,7 +3670,13 @@ gfc_match_decl_type_spec (gfc_typespec *ts, int implicit_flag)
     }
 
   if (matched_type)
+    {
+      m = gfc_match_actual_arglist (1, &decl_type_param_list, true);
+      if (m == MATCH_ERROR)
+	return m;
+
     m = gfc_match_char (')');
+    }
 
   if (m != MATCH_YES)
     m = match_record_decl (name);
@@ -3211,6 +3691,19 @@ gfc_match_decl_type_spec (gfc_typespec *ts, int implicit_flag)
           gfc_error ("Type name %qs at %C is ambiguous", name);
           return MATCH_ERROR;
         }
+
+      if (sym && sym->attr.flavor == FL_DERIVED
+	  && sym->attr.pdt_template
+	  && gfc_current_state () != COMP_DERIVED)
+	{
+	  m = gfc_get_pdt_instance (decl_type_param_list, &sym,  NULL);
+	  if (m != MATCH_YES)
+	    return m;
+	  gcc_assert (!sym->attr.pdt_template && sym->attr.pdt_type);
+	  ts->u.derived = sym;
+	  strcpy (name, gfc_dt_lower_string (sym->name));
+	}
+
       if (sym && sym->attr.flavor == FL_STRUCT)
         {
           ts->u.derived = sym;
@@ -3279,13 +3772,27 @@ gfc_match_decl_type_spec (gfc_typespec *ts, int implicit_flag)
 	  return m;
 	}
 
-      m = gfc_match (" class ( %n )", name);
+      m = gfc_match (" class (");
+
+      if (m == MATCH_YES)
+	m = gfc_match ("%n", name);
+      else
+	return m;
+
       if (m != MATCH_YES)
 	return m;
       ts->type = BT_CLASS;
 
       if (!gfc_notify_std (GFC_STD_F2003, "CLASS statement at %C"))
 	return MATCH_ERROR;
+
+      m = gfc_match_actual_arglist (1, &decl_type_param_list, true);
+      if (m == MATCH_ERROR)
+	return m;
+
+      m = gfc_match_char (')');
+      if (m != MATCH_YES)
+	return m;
     }
 
   /* Defer association of the derived type until the end of the
@@ -3351,6 +3858,18 @@ gfc_match_decl_type_spec (gfc_typespec *ts, int implicit_flag)
       return MATCH_ERROR;
     }
 
+  if (sym && sym->attr.flavor == FL_DERIVED
+      && sym->attr.pdt_template
+      && gfc_current_state () != COMP_DERIVED)
+	{
+	  m = gfc_get_pdt_instance (decl_type_param_list, &sym, NULL);
+	  if (m != MATCH_YES)
+	    return m;
+	  gcc_assert (!sym->attr.pdt_template && sym->attr.pdt_type);
+	  ts->u.derived = sym;
+	  strcpy (name, gfc_dt_lower_string (sym->name));
+	}
+
   gfc_save_symbol_data (sym);
   gfc_set_sym_referenced (sym);
   if (!sym->attr.generic
@@ -3361,6 +3880,16 @@ gfc_match_decl_type_spec (gfc_typespec *ts, int implicit_flag)
       && !gfc_add_function (&sym->attr, sym->name, NULL))
     return MATCH_ERROR;
 
+  if (dt_sym && dt_sym->attr.flavor == FL_DERIVED
+      && dt_sym->attr.pdt_template
+      && gfc_current_state () != COMP_DERIVED)
+    {
+      m = gfc_get_pdt_instance (decl_type_param_list, &dt_sym, NULL);
+      if (m != MATCH_YES)
+	return m;
+      gcc_assert (!dt_sym->attr.pdt_template && dt_sym->attr.pdt_type);
+    }
+
   if (!dt_sym)
     {
       gfc_interface *intr, *head;
@@ -3890,7 +4419,7 @@ match_attr_spec (void)
     DECL_STATIC, DECL_AUTOMATIC,
     DECL_PUBLIC, DECL_SAVE, DECL_TARGET, DECL_VALUE, DECL_VOLATILE,
     DECL_IS_BIND_C, DECL_CODIMENSION, DECL_ASYNCHRONOUS, DECL_CONTIGUOUS,
-    DECL_NONE, GFC_DECL_END /* Sentinel */
+    DECL_LEN, DECL_KIND, DECL_NONE, GFC_DECL_END /* Sentinel */
   };
 
 /* GFC_DECL_END is the sentinel, index starts at 0.  */
@@ -4033,6 +4562,16 @@ match_attr_spec (void)
 		}
 	      break;
 
+	    case 'k':
+	      if (match_string_p ("kind"))
+		d = DECL_KIND;
+	      break;
+
+	    case 'l':
+	      if (match_string_p ("len"))
+		d = DECL_LEN;
+	      break;
+
 	    case 'o':
 	      if (match_string_p ("optional"))
 		d = DECL_OPTIONAL;
@@ -4226,6 +4765,12 @@ match_attr_spec (void)
 	  case DECL_OPTIONAL:
 	    attr = "OPTIONAL";
 	    break;
+	  case DECL_KIND:
+	    attr = "KIND";
+	    break;
+	  case DECL_LEN:
+	    attr = "LEN";
+	    break;
 	  case DECL_PARAMETER:
 	    attr = "PARAMETER";
 	    break;
@@ -4307,6 +4852,54 @@ match_attr_spec (void)
 		  goto cleanup;
 		}
 	    }
+	  else if (d == DECL_KIND)
+	    {
+	      if (!gfc_notify_std (GFC_STD_F2003, "KIND "
+				   "attribute at %C in a TYPE definition"))
+		{
+		  m = MATCH_ERROR;
+		  goto cleanup;
+		}
+	      if (current_ts.type != BT_INTEGER)
+		{
+		  gfc_error ("Component with KIND attribute at %C must be "
+			     "INTEGER");
+		  m = MATCH_ERROR;
+		  goto cleanup;
+		}
+	      if (current_ts.kind != gfc_default_integer_kind)
+		{
+		  gfc_error ("Component with KIND attribute at %C must be "
+			     "default integer kind (%d)",
+			      gfc_default_integer_kind);
+		  m = MATCH_ERROR;
+		  goto cleanup;
+		}
+	    }
+	  else if (d == DECL_LEN)
+	    {
+	      if (!gfc_notify_std (GFC_STD_F2003, "LEN "
+				   "attribute at %C in a TYPE definition"))
+		{
+		  m = MATCH_ERROR;
+		  goto cleanup;
+		}
+	      if (current_ts.type != BT_INTEGER)
+		{
+		  gfc_error ("Component with LEN attribute at %C must be "
+			     "INTEGER");
+		  m = MATCH_ERROR;
+		  goto cleanup;
+		}
+	      if (current_ts.kind != gfc_default_integer_kind)
+		{
+		  gfc_error ("Component with LEN attribute at %C must be "
+			     "default integer kind (%d)",
+			      gfc_default_integer_kind);
+		  m = MATCH_ERROR;
+		  goto cleanup;
+		}
+	    }
 	  else
 	    {
 	      gfc_error ("Attribute at %L is not allowed in a TYPE definition",
@@ -4344,6 +4937,15 @@ match_attr_spec (void)
 	    }
 	}
 
+      if (gfc_current_state () != COMP_DERIVED
+	  && (d == DECL_KIND || d == DECL_LEN))
+	{
+	  gfc_error ("Attribute at %L is not allowed outside a TYPE "
+		     "definition", &seen_at[d]);
+	  m = MATCH_ERROR;
+	  goto cleanup;
+	}
+
       switch (d)
 	{
 	case DECL_ALLOCATABLE:
@@ -4396,6 +4998,14 @@ match_attr_spec (void)
 	  t = gfc_add_optional (&current_attr, &seen_at[d]);
 	  break;
 
+	case DECL_KIND:
+	  t = gfc_add_kind (&current_attr, &seen_at[d]);
+	  break;
+
+	case DECL_LEN:
+	  t = gfc_add_len (&current_attr, &seen_at[d]);
+	  break;
+
 	case DECL_PARAMETER:
 	  t = gfc_add_flavor (&current_attr, FL_PARAMETER, NULL, &seen_at[d]);
 	  break;
@@ -4886,6 +5496,9 @@ gfc_match_data_decl (void)
   match m;
   int elem;
 
+  type_param_spec_list = NULL;
+  decl_type_param_list = NULL;
+
   num_idents_on_line = 0;
 
   m = gfc_match_decl_type_spec (&current_ts, 0);
@@ -5000,6 +5613,13 @@ ok:
   gfc_free_data_all (gfc_current_ns);
 
 cleanup:
+  if (saved_kind_expr)
+    gfc_free_expr (saved_kind_expr);
+  if (type_param_spec_list)
+    gfc_free_actual_arglist (type_param_spec_list);
+  if (decl_type_param_list)
+    gfc_free_actual_arglist (decl_type_param_list);
+  saved_kind_expr = NULL;
   gfc_free_array_spec (current_as);
   current_as = NULL;
   return m;
@@ -5173,10 +5793,12 @@ copy_prefix (symbol_attribute *dest, locus *where)
 }
 
 
-/* Match a formal argument list.  */
+/* Match a formal argument list or, if typeparam is true, a
+   type_param_name_list.  */
 
 match
-gfc_match_formal_arglist (gfc_symbol *progname, int st_flag, int null_flag)
+gfc_match_formal_arglist (gfc_symbol *progname, int st_flag,
+			  int null_flag, bool typeparam)
 {
   gfc_formal_arglist *head, *tail, *p, *q;
   char name[GFC_MAX_SYMBOL_LEN + 1];
@@ -5228,7 +5850,10 @@ gfc_match_formal_arglist (gfc_symbol *progname, int st_flag, int null_flag)
 	  if (m != MATCH_YES)
 	    goto cleanup;
 
-	  if (gfc_get_symbol (name, NULL, &sym))
+	  if (!typeparam && gfc_get_symbol (name, NULL, &sym))
+	    goto cleanup;
+	  else if (typeparam
+		   && gfc_get_symbol (name, progname->f2k_derived, &sym))
 	    goto cleanup;
 	}
 
@@ -8945,6 +9570,8 @@ gfc_match_derived_decl (void)
   match is_type_attr_spec = MATCH_NO;
   bool seen_attr = false;
   gfc_interface *intr = NULL, *head;
+  bool parameterized_type = false;
+  bool seen_colons = false;
 
   if (gfc_comp_struct (gfc_current_state ()))
     return MATCH_NO;
@@ -8972,16 +9599,38 @@ gfc_match_derived_decl (void)
   if (parent[0] && !extended)
     return MATCH_ERROR;
 
-  if (gfc_match (" ::") != MATCH_YES && seen_attr)
+  m = gfc_match (" ::");
+  if (m == MATCH_YES)
+    {
+      seen_colons = true;
+    }
+  else if (seen_attr)
     {
       gfc_error ("Expected :: in TYPE definition at %C");
       return MATCH_ERROR;
     }
 
-  m = gfc_match (" %n%t", name);
+  m = gfc_match (" %n ", name);
   if (m != MATCH_YES)
     return m;
 
+  /* Make sure that we don't identify TYPE IS (...) as a parameterized
+     derived type named 'is'.
+     TODO Expand the check, when 'name' = "is" by matching " (tname) "
+     and checking if this is a(n intrinsic) typename. his picks up
+     misplaced TYPE IS statements such as in select_type_1.f03.  */
+  if (gfc_peek_ascii_char () == '(')
+    {
+      if (gfc_current_state () == COMP_SELECT_TYPE
+	  || (!seen_colons && !strcmp (name, "is")))
+	return MATCH_NO;
+      parameterized_type = true;
+    }
+
+  m = gfc_match_eos ();
+  if (m != MATCH_YES && !parameterized_type)
+    return m;
+
   /* Make sure the name is not the name of an intrinsic type.  */
   if (gfc_is_intrinsic_typename (name))
     {
@@ -9062,9 +9711,21 @@ gfc_match_derived_decl (void)
   if (!sym->f2k_derived)
     sym->f2k_derived = gfc_get_namespace (NULL, 0);
 
+  if (parameterized_type)
+    {
+      m = gfc_match_formal_arglist (sym, 0, 0, true);
+      if (m != MATCH_YES)
+	return m;
+      m = gfc_match_eos ();
+      if (m != MATCH_YES)
+	return m;
+      sym->attr.pdt_template = 1;
+    }
+
   if (extended && !sym->components)
     {
       gfc_component *p;
+      gfc_formal_arglist *f, *g, *h;
 
       /* Add the extended derived type as the first component.  */
       gfc_add_component (sym, parent, &p);
@@ -9089,6 +9750,31 @@ gfc_match_derived_decl (void)
       /* Provide the links between the extended type and its extension.  */
       if (!extended->f2k_derived)
 	extended->f2k_derived = gfc_get_namespace (NULL, 0);
+
+      /* Copy the extended type-param-name-list from the extended type,
+	 append those of the extension and add the whole lot to the
+	 extension.  */
+      if (extended->attr.pdt_template)
+	{
+	  g = h = NULL;
+	  sym->attr.pdt_template = 1;
+	  for (f = extended->formal; f; f = f->next)
+	    {
+	      if (f == extended->formal)
+		{
+		  g = gfc_get_formal_arglist ();
+		  h = g;
+		}
+	      else
+		{
+		  g->next = gfc_get_formal_arglist ();
+		  g = g->next;
+		}
+	      g->sym = f->sym;
+	    }
+	  g->next = sym->formal;
+	  sym->formal = h;
+	}
     }
 
   if (!sym->hash_value)