decl.c: Add decl_type_param_list...

2017-09-09  Paul Thomas  <pault@gcc.gnu.org>

	* decl.c : Add decl_type_param_list, type_param_spec_list as
	static variables to hold PDT spec lists.
	(build_sym): Copy 'type_param_spec_list' to symbol spec_list.
	(build_struct): Copy the 'saved_kind_expr' to the component
	'kind_expr'. Check that KIND or LEN components appear in the
	decl_type_param_list. These should appear as symbols in the
	f2k_derived namespace. If the component is itself a PDT type,
	copy the decl_type_param_list to the component param_list.
	(gfc_match_kind_spec): If the KIND expression is parameterized
	set KIND to zero and store the expression in 'saved_kind_expr'.
	(insert_parameter_exprs): New function.
	(gfc_insert_kind_parameter_exprs): New function.
	(gfc_insert_parameter_exprs): New function.
	(gfc_get_pdt_instance): New function.
	(gfc_match_decl_type_spec): Match the decl_type_spec_list if it
	is present. If it is, call 'gfc_get_pdt_instance' to obtain the
	specific instance of the PDT.
	(match_attr_spec): Match KIND and LEN attributes. Check for the
	standard and for type/kind of the parameter. They are also not
	allowed outside a derived type definition.
	(gfc_match_data_decl): Null the decl_type_param_list and the
	type_param_spec_list on entry and free them on exit.
	(gfc_match_formal_arglist): If 'typeparam' is true, add the
	formal symbol to the f2k_derived namespace.
	(gfc_match_derived_decl): Register the decl_type_param_list
	if this is a PDT. If this is a type extension, gather up all
	the type parameters and put them in the right order.
	*dump-parse-tree.c (show_attr): Signal PDT templates and the
	parameter attributes.
	(show_components): Output parameter atrributes and component
	parameter list.
	(show_symbol): Show variable parameter lists.
	* expr.c (expr.c): Copy the expression parameter list.
	(gfc_is_constant_expr): Pass on symbols representing PDT
	parameters.
	(gfc_check_init_expr): Break on PDT KIND parameters and
	PDT parameter expressions.
	(gfc_check_assign): Assigning to KIND or LEN components is an
	error.
	(derived_parameter_expr): New function.
	(gfc_derived_parameter_expr): New function.
	(gfc_spec_list_type): New function.
	* gfortran.h : Add enum gfc_param_spec_type. Add the PDT attrs
	to the structure symbol_attr. Add the 'kind_expr' and
	'param_list' field to the gfc_component structure. Comment on
	the reuse of the gfc_actual_arglist structure as storage for
	type parameter spec lists. Add the new field 'spec_type' to
	this structure. Add 'param_list' fields to gfc_symbol and
	gfc_expr. Add prototypes for gfc_insert_kind_parameter_exprs,
	gfc_insert_parameter_exprs, gfc_add_kind, gfc_add_len,
	gfc_derived_parameter_expr and gfc_spec_list_type.
	* interface.c (gfc_compare_derived_types): Treat PDTs in the
	same way as sequence types.
	* match.c : Add variable 'type_param_spec_list'.
	(gfc_op2string, gfc_match_member_sep, gfc_match_label): Remove
	trailing whitespace.
	(match_derived_type_spec): Match PDTs and find specific
	instance.
	(gfc_match_type_spec): Remove more trailing whitespace.
	(gfc_match_allocate): Assumed or deferred parameters cannot
	appear here. Copy the type parameter spec list to the expr for
	the allocatable entity. Free 'type_param_spec_list'.
	(gfc_match_common, gfc_match_namelist, gfc_match_module): Still
	more trailing whitespace to remove.
	(gfc_match_type_is): Allow PDT typespecs.
	* match.h : Modify prototypes for gfc_match_formal_arglist and
	gfc_match_actual_arglist.
	* module.c (ab_attribute, mstring attr_bits): PDT attributes
	added.
	(mio_symbol_attribute): PDT attributes handled.
	(mio_component): Deal with 'kind_expr' field.
	(mio_full_f2k_derived): For PDT templates, transfer the formal
	namespace symroot to the f2k_derived namespace.
	*primary.c (match_keyword_arg, gfc_match_actual_arglist): Add
	modifications to handle PDT spec lists. These are flagged in
	both cases by new boolean arguments, whose prototype defaults
	are false.
	(gfc_match_structure_constructor, match_variable): Remove yet
	more trailing whitespace.
	* resolve.c (get_pdt_spec_expr, get_pdt_constructor): New
	functions.
	(resolve_structure_cons): If the constructor is a PDT template,
	call get_pdt_constructor to build it using the parameter lists
	and then get the specific instance of the PDT.
	(resolve_component): PDT strings need a hidden string length
	component like deferred characters.
	(resolve_symbol): Dummy PDTs cannot have deferred parameters.
	* symbol.c (gfc_add_kind, gfc_add_len): New functions.
	(free_components): Free 'kind_expr' and 'param_list' fields.
	(gfc_free_symbol): Free the 'param_list' field.
	(gfc_find_sym_tree): If the current state is a PDT template,
	look for the symtree in the f2k_derived namspaces.
	trans-array.c (structure_alloc_comps): Allocate and deallocate
	PDTs. Check dummy arguments for compliance of LEN parameters.
	Add the new functions to the preceeding enum.
	(gfc_allocate_pdt_comp, gfc_deallocate_pdt_comp and
	gfc_check_pdt_dummy): New functions calling above.
	* trans-array.h : Add prototypes for these functions.
	trans-decl.c (gfc_get_symbol_decl): Call gfc_defer_symbol_init
	as appropriate for PDT symbols.
	(gfc_trans_deferred_vars): Allocate/deallocate PDT entities as
	they come into and out of scope. Exclude pdt_types from being
	'gcc_unreachable'.
	(gfc_trans_subcomponent_assign): PDT array components must be
	handles as if they are allocatable.
	* trans-stmt.c (gfc_trans_allocate): Handle initialization of
	PDT entities.
	(gfc_trans_deallocate): Likewise.
	* trans-types.c (gfc_get_derived_type): PDT templates must not
	arrive here. PDT string components are handles as if deferred.
	Similarly, PDT arrays are treated as if allocatable. PDT
	strings are pointer types.
	* trans.c (gfc_deferred_strlen): Handle PDT strings in the same
	way as deferred characters.


2017-09-09  Paul Thomas  <pault@gcc.gnu.org>

	* gfortran.dg/pdt_1.f03 : New test.
	* gfortran.dg/pdt_2.f03 : New test.
	* gfortran.dg/pdt_3.f03 : New test.
	* gfortran.dg/pdt_4.f03 : New test.
	* gfortran.dg/pdt_5.f03 : New test.

From-SVN: r251925

1 files changed, 297 insertions, 1 deletions

diff --git a/gcc/fortran/trans-array.c b/gcc/fortran/trans-array.c
index 9efb531..2b06903 100644
--- a/gcc/fortran/trans-array.c
+++ b/gcc/fortran/trans-array.c
@@ -8073,7 +8073,10 @@ gfc_caf_is_dealloc_only (int caf_mode)
    function for the functions named in this enum.  */
 
 enum {DEALLOCATE_ALLOC_COMP = 1, NULLIFY_ALLOC_COMP,
-      COPY_ALLOC_COMP, COPY_ONLY_ALLOC_COMP, REASSIGN_CAF_COMP};
+      COPY_ALLOC_COMP, COPY_ONLY_ALLOC_COMP, REASSIGN_CAF_COMP,
+      ALLOCATE_PDT_COMP, DEALLOCATE_PDT_COMP, CHECK_PDT_DUMMY};
+
+static gfc_actual_arglist *pdt_param_list;
 
 static tree
 structure_alloc_comps (gfc_symbol * der_type, tree decl,
@@ -8735,6 +8738,255 @@ structure_alloc_comps (gfc_symbol * der_type, tree decl,
 
 	  break;
 
+	case ALLOCATE_PDT_COMP:
+
+	  comp = fold_build3_loc (input_location, COMPONENT_REF, ctype,
+				  decl, cdecl, NULL_TREE);
+
+	  /* Set the PDT KIND and LEN fields.  */
+	  if (c->attr.pdt_kind || c->attr.pdt_len)
+	    {
+	      gfc_se tse;
+	      gfc_expr *c_expr = NULL;
+	      gfc_actual_arglist *param = pdt_param_list;
+	      gfc_init_se (&tse, NULL);
+	      for (; param; param = param->next)
+		if (!strcmp (c->name, param->name))
+		  c_expr = param->expr;
+
+	      if (!c_expr)
+		c_expr = c->initializer;
+
+	      if (c_expr)
+		{
+		  gfc_conv_expr_type (&tse, c_expr, TREE_TYPE (comp));
+		  gfc_add_modify (&fnblock, comp, tse.expr);
+		}
+	    }
+
+	  if (c->attr.pdt_string)
+	    {
+	      gfc_se tse;
+	      gfc_init_se (&tse, NULL);
+	      tree strlen;
+	      /* Convert the parameterized string length to its value. The
+		 string length is stored in a hidden field in the same way as
+		 deferred string lengths.  */
+	      gfc_insert_parameter_exprs (c->ts.u.cl->length, pdt_param_list);
+	      if (gfc_deferred_strlen (c, &strlen) && strlen != NULL_TREE)
+		{
+		  gfc_conv_expr_type (&tse, c->ts.u.cl->length,
+				      TREE_TYPE (strlen));
+		  strlen = fold_build3_loc (input_location, COMPONENT_REF,
+					    TREE_TYPE (strlen),
+					    decl, strlen, NULL_TREE);
+		  gfc_add_modify (&fnblock, strlen, tse.expr);
+		  c->ts.u.cl->backend_decl = strlen;
+		}
+	      /* Scalar parameterizied strings can be allocated now.  */
+	      if (!c->as)
+		{
+		  tmp = fold_convert (gfc_array_index_type, strlen);
+		  tmp = size_of_string_in_bytes (c->ts.kind, tmp);
+		  tmp = gfc_evaluate_now (tmp, &fnblock);
+		  tmp = gfc_call_malloc (&fnblock, TREE_TYPE (comp), tmp);
+		  gfc_add_modify (&fnblock, comp, tmp);
+		}
+	    }
+
+	  /* Allocate paramterized arrays of parameterized derived types.  */
+	  if (!(c->attr.pdt_array && c->as && c->as->type == AS_EXPLICIT)
+	      && !((c->ts.type == BT_DERIVED || c->ts.type == BT_CLASS)
+		   && (c->ts.u.derived && c->ts.u.derived->attr.pdt_type)))
+	    continue;
+
+	  if (c->ts.type == BT_CLASS)
+	    comp = gfc_class_data_get (comp);
+
+	  if (c->attr.pdt_array)
+	    {
+	      gfc_se tse;
+	      int i;
+	      tree size = gfc_index_one_node;
+	      tree offset = gfc_index_zero_node;
+	      tree lower, upper;
+	      gfc_expr *e;
+
+	      /* This chunk takes the expressions for 'lower' and 'upper'
+		 in the arrayspec and substitutes in the expressions for
+		 the parameters from 'pdt_param_list'. The descriptor
+		 fields can then be filled from the values so obtained.  */
+	      gcc_assert (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (comp)));
+	      for (i = 0; i < c->as->rank; i++)
+		{
+		  gfc_init_se (&tse, NULL);
+		  e = gfc_copy_expr (c->as->lower[i]);
+		  gfc_insert_parameter_exprs (e, pdt_param_list);
+		  gfc_conv_expr_type (&tse, e, gfc_array_index_type);
+		  gfc_free_expr (e);
+		  lower = tse.expr;
+		  gfc_conv_descriptor_lbound_set (&fnblock, comp,
+						  gfc_rank_cst[i],
+						  lower);
+		  e = gfc_copy_expr (c->as->upper[i]);
+		  gfc_insert_parameter_exprs (e, pdt_param_list);
+		  gfc_conv_expr_type (&tse, e, gfc_array_index_type);
+		  gfc_free_expr (e);
+		  upper = tse.expr;
+		  gfc_conv_descriptor_ubound_set (&fnblock, comp,
+						  gfc_rank_cst[i],
+						  upper);
+		  gfc_conv_descriptor_stride_set (&fnblock, comp,
+						  gfc_rank_cst[i],
+						  size);
+		  size = gfc_evaluate_now (size, &fnblock);
+		  offset = fold_build2_loc (input_location,
+					    MINUS_EXPR,
+					    gfc_array_index_type,
+					    offset, size);
+		  offset = gfc_evaluate_now (offset, &fnblock);
+		  tmp = fold_build2_loc (input_location, MINUS_EXPR,
+					 gfc_array_index_type,
+					 upper, lower);
+		  tmp = fold_build2_loc (input_location, PLUS_EXPR,
+					 gfc_array_index_type,
+					 tmp, gfc_index_one_node);
+		  size = fold_build2_loc (input_location, MULT_EXPR,
+					  gfc_array_index_type, size, tmp);
+		}
+	      gfc_conv_descriptor_offset_set (&fnblock, comp, offset);
+	      if (c->ts.type == BT_CLASS)
+		{
+		  tmp = gfc_get_vptr_from_expr (comp);
+		  if (POINTER_TYPE_P (TREE_TYPE (tmp)))
+		    tmp = build_fold_indirect_ref_loc (input_location, tmp);
+		  tmp = gfc_vptr_size_get (tmp);
+		}
+	      else
+		tmp = TYPE_SIZE_UNIT (gfc_get_element_type (ctype));
+	      tmp = fold_convert (gfc_array_index_type, tmp);
+	      size = fold_build2_loc (input_location, MULT_EXPR,
+				      gfc_array_index_type, size, tmp);
+	      size = gfc_evaluate_now (size, &fnblock);
+	      tmp = gfc_call_malloc (&fnblock, NULL, size);
+	      gfc_conv_descriptor_data_set (&fnblock, comp, tmp);
+	      tmp = gfc_conv_descriptor_dtype (comp);
+	      gfc_add_modify (&fnblock, tmp, gfc_get_dtype (ctype));
+	    }
+
+	  /* Recurse in to PDT components.  */
+	  if ((c->ts.type == BT_DERIVED || c->ts.type == BT_CLASS)
+	      && c->ts.u.derived && c->ts.u.derived->attr.pdt_type)
+	    {
+	      bool is_deferred = false;
+	      gfc_actual_arglist *tail = c->param_list;
+
+	      for (; tail; tail = tail->next)
+		if (!tail->expr)
+		  is_deferred = true;
+
+	      tail = is_deferred ? pdt_param_list : c->param_list;
+	      tmp = gfc_allocate_pdt_comp (c->ts.u.derived, comp,
+					   c->as ? c->as->rank : 0,
+					   tail);
+	      gfc_add_expr_to_block (&fnblock, tmp);
+	    }
+
+	  break;
+
+	case DEALLOCATE_PDT_COMP:
+	  /* Deallocate array or parameterized string length components
+	     of parameterized derived types.  */
+	  if (!(c->attr.pdt_array && c->as && c->as->type == AS_EXPLICIT)
+	      && !c->attr.pdt_string
+	      && !((c->ts.type == BT_DERIVED || c->ts.type == BT_CLASS)
+		   && (c->ts.u.derived && c->ts.u.derived->attr.pdt_type)))
+	    continue;
+
+	  comp = fold_build3_loc (input_location, COMPONENT_REF, ctype,
+				  decl, cdecl, NULL_TREE);
+	  if (c->ts.type == BT_CLASS)
+	    comp = gfc_class_data_get (comp);
+
+	  /* Recurse in to PDT components.  */
+	  if ((c->ts.type == BT_DERIVED || c->ts.type == BT_CLASS)
+	      && c->ts.u.derived && c->ts.u.derived->attr.pdt_type)
+	    {
+	      tmp = gfc_deallocate_pdt_comp (c->ts.u.derived, comp,
+					     c->as ? c->as->rank : 0);
+	      gfc_add_expr_to_block (&fnblock, tmp);
+	    }
+
+	  if (c->attr.pdt_array)
+	    {
+	      tmp = gfc_conv_descriptor_data_get (comp);
+	      tmp = gfc_call_free (tmp);
+	      gfc_add_expr_to_block (&fnblock, tmp);
+	      gfc_conv_descriptor_data_set (&fnblock, comp, null_pointer_node);
+	    }
+	  else if (c->attr.pdt_string)
+	    {
+	      tmp = gfc_call_free (comp);
+	      gfc_add_expr_to_block (&fnblock, tmp);
+	      tmp = fold_convert (TREE_TYPE (comp), null_pointer_node);
+	      gfc_add_modify (&fnblock, comp, tmp);
+	    }
+
+	  break;
+
+	case CHECK_PDT_DUMMY:
+
+	  comp = fold_build3_loc (input_location, COMPONENT_REF, ctype,
+				  decl, cdecl, NULL_TREE);
+	  if (c->ts.type == BT_CLASS)
+	    comp = gfc_class_data_get (comp);
+
+	  /* Recurse in to PDT components.  */
+	  if ((c->ts.type == BT_DERIVED || c->ts.type == BT_CLASS)
+	      && c->ts.u.derived && c->ts.u.derived->attr.pdt_type)
+	    {
+	      tmp = gfc_check_pdt_dummy (c->ts.u.derived, comp,
+					 c->as ? c->as->rank : 0,
+					 pdt_param_list);
+	      gfc_add_expr_to_block (&fnblock, tmp);
+	    }
+
+	  if (!c->attr.pdt_len)
+	    continue;
+	  else
+	    {
+	      gfc_se tse;
+	      gfc_expr *c_expr = NULL;
+	      gfc_actual_arglist *param = pdt_param_list;
+
+	      gfc_init_se (&tse, NULL);
+	      for (; param; param = param->next)
+		if (!strcmp (c->name, param->name))
+		  c_expr = param->expr;
+
+	      if (c_expr)
+		{
+		  tree error, cond, cname;
+		  gfc_conv_expr_type (&tse, c_expr, TREE_TYPE (comp));
+		  cond = fold_build2_loc (input_location, NE_EXPR,
+					  boolean_type_node,
+					  comp, tse.expr);
+		  cname = gfc_build_cstring_const (c->name);
+		  cname = gfc_build_addr_expr (pchar_type_node, cname);
+		  error = gfc_trans_runtime_error (true, NULL,
+						   "The value of the PDT LEN "
+						   "parameter '%s' does not "
+						   "agree with that in the "
+						   "dummy declaration",
+						   cname);
+		  tmp = fold_build3_loc (input_location, COND_EXPR,
+					 void_type_node, cond, error,
+					 build_empty_stmt (input_location));
+		  gfc_add_expr_to_block (&fnblock, tmp);
+		}
+	    }
+	  break;
+
 	default:
 	  gcc_unreachable ();
 	  break;
@@ -8814,6 +9066,50 @@ gfc_copy_only_alloc_comp (gfc_symbol * der_type, tree decl, tree dest, int rank)
 }
 
 
+/* Recursively traverse an object of paramterized derived type, generating
+   code to allocate parameterized components.  */
+
+tree
+gfc_allocate_pdt_comp (gfc_symbol * der_type, tree decl, int rank,
+		       gfc_actual_arglist *param_list)
+{
+  tree res;
+  gfc_actual_arglist *old_param_list = pdt_param_list;
+  pdt_param_list = param_list;
+  res = structure_alloc_comps (der_type, decl, NULL_TREE, rank,
+			       ALLOCATE_PDT_COMP, 0);
+  pdt_param_list = old_param_list;
+  return res;
+}
+
+/* Recursively traverse an object of paramterized derived type, generating
+   code to deallocate parameterized components.  */
+
+tree
+gfc_deallocate_pdt_comp (gfc_symbol * der_type, tree decl, int rank)
+{
+  return structure_alloc_comps (der_type, decl, NULL_TREE, rank,
+				DEALLOCATE_PDT_COMP, 0);
+}
+
+
+/* Recursively traverse a dummy of paramterized derived type to check the
+   values of LEN parameters.  */
+
+tree
+gfc_check_pdt_dummy (gfc_symbol * der_type, tree decl, int rank,
+		     gfc_actual_arglist *param_list)
+{
+  tree res;
+  gfc_actual_arglist *old_param_list = pdt_param_list;
+  pdt_param_list = param_list;
+  res = structure_alloc_comps (der_type, decl, NULL_TREE, rank,
+			       CHECK_PDT_DUMMY, 0);
+  pdt_param_list = old_param_list;
+  return res;
+}
+
+
 /* Returns the value of LBOUND for an expression.  This could be broken out
    from gfc_conv_intrinsic_bound but this seemed to be simpler.  This is
    called by gfc_alloc_allocatable_for_assignment.  */