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, 27 insertions, 20 deletions

diff --git a/gcc/fortran/module.c b/gcc/fortran/module.c
index 32ee526..6d3860e 100644
--- a/gcc/fortran/module.c
+++ b/gcc/fortran/module.c
@@ -422,8 +422,8 @@ resolve_fixups (fixup_t *f, void *gp)
    to convert the symtree name of a derived-type to the symbol name or to
    the name of the associated generic function.  */
 
-static const char *
-dt_lower_string (const char *name)
+const char *
+gfc_dt_lower_string (const char *name)
 {
   if (name[0] != (char) TOLOWER ((unsigned char) name[0]))
     return gfc_get_string ("%c%s", (char) TOLOWER ((unsigned char) name[0]),
@@ -437,8 +437,8 @@ dt_lower_string (const char *name)
    symtree/symbol name of the associated generic function start with a lower-
    case character.  */
 
-static const char *
-dt_upper_string (const char *name)
+const char *
+gfc_dt_upper_string (const char *name)
 {
   if (name[0] != (char) TOUPPER ((unsigned char) name[0]))
     return gfc_get_string ("%c%s", (char) TOUPPER ((unsigned char) name[0]),
@@ -832,7 +832,7 @@ find_use_name_n (const char *name, int *inst, bool interface)
 
   /* For derived types.  */
   if (name[0] != (char) TOLOWER ((unsigned char) name[0]))
-    low_name = dt_lower_string (name);
+    low_name = gfc_dt_lower_string (name);
 
   i = 0;
   for (u = gfc_rename_list; u; u = u->next)
@@ -861,7 +861,7 @@ find_use_name_n (const char *name, int *inst, bool interface)
     {
       if (u->local_name[0] == '\0')
 	return name;
-      return dt_upper_string (u->local_name);
+      return gfc_dt_upper_string (u->local_name);
     }
 
   return (u->local_name[0] != '\0') ? u->local_name : name;
@@ -989,8 +989,8 @@ add_true_name (gfc_symbol *sym)
 
   t = XCNEW (true_name);
   t->sym = sym;
-  if (sym->attr.flavor == FL_DERIVED)
-    t->name = dt_upper_string (sym->name);
+  if (gfc_fl_struct (sym->attr.flavor))
+    t->name = gfc_dt_upper_string (sym->name);
   else
     t->name = sym->name;
 
@@ -1011,8 +1011,8 @@ build_tnt (gfc_symtree *st)
   build_tnt (st->left);
   build_tnt (st->right);
 
-  if (st->n.sym->attr.flavor == FL_DERIVED)
-    name = dt_upper_string (st->n.sym->name);
+  if (gfc_fl_struct (st->n.sym->attr.flavor))
+    name = gfc_dt_upper_string (st->n.sym->name);
   else
     name = st->n.sym->name;
 
@@ -2452,6 +2452,7 @@ static const mstring bt_types[] = {
     minit ("COMPLEX", BT_COMPLEX),
     minit ("LOGICAL", BT_LOGICAL),
     minit ("CHARACTER", BT_CHARACTER),
+    minit ("UNION", BT_UNION),
     minit ("DERIVED", BT_DERIVED),
     minit ("CLASS", BT_CLASS),
     minit ("PROCEDURE", BT_PROCEDURE),
@@ -2505,7 +2506,7 @@ mio_typespec (gfc_typespec *ts)
 
   ts->type = MIO_NAME (bt) (ts->type, bt_types);
 
-  if (ts->type != BT_DERIVED && ts->type != BT_CLASS)
+  if (!gfc_bt_struct (ts->type) && ts->type != BT_CLASS)
     mio_integer (&ts->kind);
   else
     mio_symbol_ref (&ts->u.derived);
@@ -3322,8 +3323,8 @@ fix_mio_expr (gfc_expr *e)
       if (e->symtree->n.sym && check_unique_name (e->symtree->name))
 	{
           const char *name = e->symtree->n.sym->name;
-	  if (e->symtree->n.sym->attr.flavor == FL_DERIVED)
-	    name = dt_upper_string (name);
+	  if (gfc_fl_struct (e->symtree->n.sym->attr.flavor))
+	    name = gfc_dt_upper_string (name);
 	  ns_st = gfc_find_symtree (gfc_current_ns->sym_root, name);
 	}
 
@@ -4265,7 +4266,7 @@ mio_symbol (gfc_symbol *sym)
 
   mio_integer (&(sym->intmod_sym_id));
 
-  if (sym->attr.flavor == FL_DERIVED)
+  if (gfc_fl_struct (sym->attr.flavor))
     mio_integer (&(sym->hash_value));
 
   if (sym->formal_ns
@@ -4845,7 +4846,7 @@ load_needed (pointer_info *p)
 				 1, &ns->proc_name);
 
       sym = gfc_new_symbol (p->u.rsym.true_name, ns);
-      sym->name = dt_lower_string (p->u.rsym.true_name);
+      sym->name = gfc_dt_lower_string (p->u.rsym.true_name);
       sym->module = gfc_get_string (p->u.rsym.module);
       if (p->u.rsym.binding_label)
 	sym->binding_label = IDENTIFIER_POINTER (get_identifier
@@ -4857,6 +4858,12 @@ load_needed (pointer_info *p)
   mio_symbol (sym);
   sym->attr.use_assoc = 1;
 
+  /* Unliked derived types, a STRUCTURE may share names with other symbols.
+     We greedily converted the the symbol name to lowercase before we knew its
+     type, so now we must fix it. */
+  if (sym->attr.flavor == FL_STRUCT)
+    sym->name = gfc_dt_upper_string (sym->name);
+
   /* Mark as only or rename for later diagnosis for explicitly imported
      but not used warnings; don't mark internal symbols such as __vtab,
      __def_init etc. Only mark them if they have been explicitly loaded.  */
@@ -5059,7 +5066,7 @@ read_module (void)
 	 can be used in expressions in the module.  To avoid the module loading
 	 failing, we need to associate the module's component pointer indexes
 	 with the existing symbol's component pointers.  */
-      if (sym->attr.flavor == FL_DERIVED)
+      if (gfc_fl_struct (sym->attr.flavor))
 	{
 	  gfc_component *c;
 
@@ -5213,7 +5220,7 @@ read_module (void)
 		{
 		  info->u.rsym.sym = gfc_new_symbol (info->u.rsym.true_name,
 						     gfc_current_ns);
-		  info->u.rsym.sym->name = dt_lower_string (info->u.rsym.true_name);
+		  info->u.rsym.sym->name = gfc_dt_lower_string (info->u.rsym.true_name);
 		  sym = info->u.rsym.sym;
 		  sym->module = gfc_get_string (info->u.rsym.module);
 
@@ -5557,10 +5564,10 @@ write_symbol (int n, gfc_symbol *sym)
 
   mio_integer (&n);
 
-  if (sym->attr.flavor == FL_DERIVED)
+  if (gfc_fl_struct (sym->attr.flavor))
     {
       const char *name;
-      name = dt_upper_string (sym->name);
+      name = gfc_dt_upper_string (sym->name);
       mio_pool_string (&name);
     }
   else
@@ -6568,7 +6575,7 @@ create_derived_type (const char *name, const char *modname,
   sym->attr.function = 1;
   sym->attr.generic = 1;
 
-  gfc_get_sym_tree (dt_upper_string (sym->name),
+  gfc_get_sym_tree (gfc_dt_upper_string (sym->name),
 		    gfc_current_ns, &tmp_symtree, false);
   dt_sym = tmp_symtree->n.sym;
   dt_sym->name = gfc_get_string (sym->name);