re PR fortran/56226 (Add support for DEC UNION and MAP extensions)

2016-05-07  Fritz Reese  <fritzoreese@gmail.com>

	PR fortran/56226
	* module.c (dt_upper_string): Rename to gfc_dt_upper_string
	(dt_lower_string): Likewise.
	* gfortran.h: Make new gfc_dt_upper/lower_string global.
	* class.c: Use gfc_dt_upper_string.
	* decl.c: Likewise.
	* symbol.c: Likewise.
	* resolve.c (resolve_component): New function.
	(resolve_fl_derived0): Move component loop code to resolve_component.
	* parse.c (check_component): New function.
	(parse_derived): Move loop code to check_component.
	* lang.opt, invoke.texi, options.c : New option -fdec-structure.
	* libgfortran.h (bt): New basic type BT_UNION.
	* gfortran.h (gfc_option): New option -fdec-structure.
	(gfc_get_union_type, gfc_compare_union_types): New prototypes.
	(gfc_bt_struct, gfc_fl_struct, case_bt_struct, case_fl_struct): New
	macros.
	(gfc_find_component): Change prototype.
	* match.h (gfc_match_member_sep, gfc_match_map, gfc_match_union,
	gfc_match_structure_decl): New prototypes.
	* parse.h (gfc_comp_struct): New macro.
	* symbol.c (gfc_find_component): Search for components in nested unions
	* class.c (insert_component_ref, gfc_add_component_ref, add_proc_comp,
	copy_vtab_proc_comps): Update calls to gfc_find_component.
	* primary.c (gfc_convert_to_structure_constructor): Likewise.
	* symbol.c (gfc_add_component): Likewise.
	* resolve.c (resolve_typebound_function, resolve_typebound_subroutine,
	resolve_typebound_procedure, resolve_component, resolve_fl_derived):
	Likewise.
	* expr.c (get_union_init, component_init): New functions.
	* decl.c (match_clist_expr, match_record_decl, get_struct_decl,
	gfc_match_map, gfc_match_union, gfc_match_structure_decl): Likewise.
	* interface.c (compare_components, gfc_compare_union_types): Likewise.
	* match.c (gfc_match_member_sep): Likewise.
	* parse.c (check_component, parse_union, parse_struct_map): Likewise.
	* resolve.c (resolve_fl_struct): Likewise.
	* symbol.c (find_union_component): Likewise.
	* trans-types.c (gfc_get_union_type): Likewise.
	* parse.c (parse_derived): Use new functions.
	* interface.c (gfc_compare_derived_types, gfc_compare_types): Likewise.
	* expr.c (gfc_default_initializer): Likewise.
	* gfortran.texi: Support for DEC structures, unions, and maps.
	* gfortran.h (gfc_statement, sym_flavor): Likewise.
	* check.c (gfc_check_kill_sub): Likewise.
	* expr.c (gfc_copy_expr, simplify_const_ref,
	gfc_has_default_initializer): Likewise.
	* decl.c (build_sym, match_data_constant, add_init_expr_to_sym,
	match_pointer_init, build_struct, variable_decl,
	gfc_match_decl_type_spec, gfc_mach_data-decl, gfc_match_entry,
	gfc_match_end, gfc_match_derived_decl): Likewise.
	* interface.c (check_interface0, check_interface1,
	gfc_search_interface): Likewise.
	* misc.c (gfc_basic_typename, gfc_typename): Likewise.
	* module.c (add_true_name, build_tnt, bt_types, mio_typespec,
	fix_mio_expr, load_needed, mio_symbol, read_module, write_symbol,
	gfc_get_module_backend_decl): Likewise.
	* parse.h (gfc_compile_state): Likewise.
	* parse.c (decode_specification_statement, decode_statement,
	gfc_ascii_statement, verify_st_order, parse_spec): Likewise.
	* primary.c (gfc_match_varspec, gfc_match_structure_constructor,
	gfc_match_rvalue, match_variable): Likewise.
	* resolve.c (find_arglists, resolve_structure_cons,
	is_illegal_recursion, resolve_generic_f, get_declared_from_expr,
	resolve_typebound_subroutine, resolve_allocate_expr,
	nonscalar_typebound_assign, generate_component_assignments,
	resolve_fl_variable_derived, check_defined_assignments,
	resolve_component, resolve_symbol, resolve_equivalence_derived):
	Likewise.
	* symbol.c (flavors, check_conflict, gfc_add_flavor, gfc_use_derived,
	gfc_restore_last_undo_checkpoint, gfc_type_compatible,
	gfc_find_dt_in_generic): Likewise.
	* trans-decl.c (gfc_get_module_backend_decl, create_function_arglist,
	gfc_create_module_variable, check_constant_initializer): Likewise.
	* trans-expr.c (gfc_conv_component_ref, gfc_conv_initializer,
	gfc_trans_alloc_subarray_assign, gfc_trans_subcomponent_assign,
	gfc_conv_structure, gfc_trans_scalar_assign, copyable_array_p):
	Likewise.
	* trans-io.c (transfer_namelist_element, transfer_expr,
	gfc_trans_transfer): Likewise.
	* trans-stmt.c (gfc_trans_deallocate): Likewise.
	* trans-types.c (gfc_typenode_for_spec, gfc_copy_dt_decls_ifequal,
	gfc_get_derived_type): Likewise.

2016-05-07  Fritz Reese  <fritzoreese@gmail.com>

	PR fortran/56226
	* gfortran.dg/dec_structure_1.f90: New testcase.
	* gfortran.dg/dec_structure_2.f90: Ditto.
	* gfortran.dg/dec_structure_3.f90: Ditto.
	* gfortran.dg/dec_structure_4.f90: Ditto.
	* gfortran.dg/dec_structure_5.f90: Ditto.
	* gfortran.dg/dec_structure_6.f90: Ditto.
	* gfortran.dg/dec_structure_7.f90: Ditto.
	* gfortran.dg/dec_structure_8.f90: Ditto.
	* gfortran.dg/dec_structure_9.f90: Ditto.
	* gfortran.dg/dec_structure_10.f90: Ditto.
	* gfortran.dg/dec_structure_11.f90: Ditto.
	* gfortran.dg/dec_union_1.f90: Ditto.
	* gfortran.dg/dec_union_2.f90: Ditto.
	* gfortran.dg/dec_union_3.f90: Ditto.
	* gfortran.dg/dec_union_4.f90: Ditto.
	* gfortran.dg/dec_union_5.f90: Ditto.
	* gfortran.dg/dec_union_6.f90: Ditto.
	* gfortran.dg/dec_union_7.f90: Ditto.

From-SVN: r235999

1 files changed, 34 insertions, 9 deletions

diff --git a/gcc/fortran/trans-expr.c b/gcc/fortran/trans-expr.c
index 8d039a6..8f84712 100644
--- a/gcc/fortran/trans-expr.c
+++ b/gcc/fortran/trans-expr.c
@@ -2297,6 +2297,7 @@ gfc_conv_component_ref (gfc_se * se, gfc_ref * ref)
   tree tmp;
   tree decl;
   tree field;
+  tree context;
 
   c = ref->u.c.component;
 
@@ -2307,15 +2308,20 @@ gfc_conv_component_ref (gfc_se * se, gfc_ref * ref)
   field = c->backend_decl;
   gcc_assert (field && TREE_CODE (field) == FIELD_DECL);
   decl = se->expr;
+  context = DECL_FIELD_CONTEXT (field);
 
   /* Components can correspond to fields of different containing
      types, as components are created without context, whereas
      a concrete use of a component has the type of decl as context.
      So, if the type doesn't match, we search the corresponding
      FIELD_DECL in the parent type.  To not waste too much time
-     we cache this result in norestrict_decl.  */
+     we cache this result in norestrict_decl.
+     On the other hand, if the context is a UNION or a MAP (a
+     RECORD_TYPE within a UNION_TYPE) always use the given FIELD_DECL.  */
 
-  if (DECL_FIELD_CONTEXT (field) != TREE_TYPE (decl))
+  if (context != TREE_TYPE (decl) 
+      && !(   TREE_CODE (TREE_TYPE (field)) == UNION_TYPE /* Field is union */
+           || TREE_CODE (context) == UNION_TYPE))         /* Field is map */
     {
       tree f2 = c->norestrict_decl;
       if (!f2 || DECL_FIELD_CONTEXT (f2) != TREE_TYPE (decl))
@@ -6715,7 +6721,7 @@ gfc_conv_initializer (gfc_expr * expr, gfc_typespec * ts, tree type,
     {
       switch (ts->type)
 	{
-	case BT_DERIVED:
+	case_bt_struct:
 	case BT_CLASS:
 	  gfc_init_se (&se, NULL);
 	  if (ts->type == BT_CLASS && expr->expr_type == EXPR_NULL)
@@ -6860,7 +6866,7 @@ gfc_trans_alloc_subarray_assign (tree dest, gfc_component * cm,
   gfc_add_modify (&block, dest, se.expr);
 
   /* Deal with arrays of derived types with allocatable components.  */
-  if (cm->ts.type == BT_DERIVED
+  if (gfc_bt_struct (cm->ts.type)
 	&& cm->ts.u.derived->attr.alloc_comp)
     tmp = gfc_copy_alloc_comp (cm->ts.u.derived,
 			       se.expr, dest,
@@ -7033,7 +7039,7 @@ alloc_scalar_allocatable_for_subcomponent_assignment (stmtblock_t *block,
       /* Ensure that cm->ts.u.cl->backend_decl is a componentref to _%s_length
 	 component.  */
       sprintf (name, "_%s_length", cm->name);
-      strlen = gfc_find_component (sym, name, true, true);
+      strlen = gfc_find_component (sym, name, true, true, NULL);
       lhs_cl_size = fold_build3_loc (input_location, COMPONENT_REF,
 				     gfc_charlen_type_node,
 				     TREE_OPERAND (comp, 0),
@@ -7245,7 +7251,7 @@ gfc_trans_subcomponent_assign (tree dest, gfc_component * cm, gfc_expr * expr,
 			fold_convert (TREE_TYPE (tmp), se.expr));
       gfc_add_block_to_block (&block, &se.post);
     }
-  else if (expr->ts.type == BT_DERIVED && expr->ts.f90_type != BT_VOID)
+  else if (gfc_bt_struct (expr->ts.type) && expr->ts.f90_type != BT_VOID)
     {
       if (expr->expr_type != EXPR_STRUCTURE)
 	{
@@ -7416,6 +7422,24 @@ gfc_conv_structure (gfc_se * se, gfc_expr * expr, int init)
       return;
     }
 
+  /* Though unions appear to have multiple map components, they must only
+     have a single initializer since each map overlaps. TODO: squash map
+     constructors?  */
+  if (expr->ts.type == BT_UNION)
+    {
+      c = gfc_constructor_first (expr->value.constructor);
+      cm = c->n.component;
+      val = gfc_conv_initializer (c->expr, &expr->ts,
+                                  TREE_TYPE (cm->backend_decl),
+                                  cm->attr.dimension, cm->attr.pointer,
+                                  cm->attr.proc_pointer);
+      val = unshare_expr_without_location (val);
+
+      /* Append it to the constructor list.  */
+      CONSTRUCTOR_APPEND_ELT (v, cm->backend_decl, val);
+      goto finish;
+    }
+
   cm = expr->ts.u.derived->components;
 
   for (c = gfc_constructor_first (expr->value.constructor);
@@ -7462,6 +7486,7 @@ gfc_conv_structure (gfc_se * se, gfc_expr * expr, int init)
 	  CONSTRUCTOR_APPEND_ELT (v, cm->backend_decl, val);
 	}
     }
+finish:
   se->expr = build_constructor (type, v);
   if (init)
     TREE_CONSTANT (se->expr) = 1;
@@ -8246,7 +8271,7 @@ gfc_trans_scalar_assign (gfc_se * lse, gfc_se * rse, gfc_typespec ts,
       gfc_trans_string_copy (&block, llen, lse->expr, ts.kind, rlen,
 			     rse->expr, ts.kind);
     }
-  else if (ts.type == BT_DERIVED && ts.u.derived->attr.alloc_comp)
+  else if (gfc_bt_struct (ts.type) && ts.u.derived->attr.alloc_comp)
     {
       tree tmp_var = NULL_TREE;
       cond = NULL_TREE;
@@ -8299,7 +8324,7 @@ gfc_trans_scalar_assign (gfc_se * lse, gfc_se * rse, gfc_typespec ts,
 	  gfc_add_expr_to_block (&block, tmp);
 	}
     }
-  else if (ts.type == BT_DERIVED || ts.type == BT_CLASS)
+  else if (gfc_bt_struct (ts.type) || ts.type == BT_CLASS)
     {
       gfc_add_block_to_block (&block, &lse->pre);
       gfc_add_block_to_block (&block, &rse->pre);
@@ -9503,7 +9528,7 @@ copyable_array_p (gfc_expr * expr)
     case BT_CHARACTER:
       return false;
 
-    case BT_DERIVED:
+    case_bt_struct:
       return !expr->ts.u.derived->attr.alloc_comp;
 
     default: