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, 84 insertions, 32 deletions

diff --git a/gcc/fortran/primary.c b/gcc/fortran/primary.c
index d25d3de..c2faa0f 100644
--- a/gcc/fortran/primary.c
+++ b/gcc/fortran/primary.c
@@ -1883,11 +1883,12 @@ gfc_match_varspec (gfc_expr *primary, int equiv_flag, bool sub_flag,
 		   bool ppc_arg)
 {
   char name[GFC_MAX_SYMBOL_LEN + 1];
-  gfc_ref *substring, *tail;
+  gfc_ref *substring, *tail, *tmp;
   gfc_component *component;
   gfc_symbol *sym = primary->symtree->n.sym;
   match m;
   bool unknown;
+  char sep;
 
   tail = NULL;
 
@@ -1972,25 +1973,31 @@ gfc_match_varspec (gfc_expr *primary, int equiv_flag, bool sub_flag,
   if (equiv_flag)
     return MATCH_YES;
 
-  if (sym->ts.type == BT_UNKNOWN && gfc_peek_ascii_char () == '%'
+  /* With DEC extensions, member separator may be '.' or '%'.  */
+  sep = gfc_peek_ascii_char ();
+  m = gfc_match_member_sep (sym);
+  if (m == MATCH_ERROR)
+    return MATCH_ERROR;
+
+  if (sym->ts.type == BT_UNKNOWN && m == MATCH_YES
       && gfc_get_default_type (sym->name, sym->ns)->type == BT_DERIVED)
     gfc_set_default_type (sym, 0, sym->ns);
 
-  if (sym->ts.type == BT_UNKNOWN && gfc_match_char ('%') == MATCH_YES)
+  if (sym->ts.type == BT_UNKNOWN && m == MATCH_YES)
     {
       gfc_error ("Symbol %qs at %C has no IMPLICIT type", sym->name);
       return MATCH_ERROR;
     }
   else if ((sym->ts.type != BT_DERIVED && sym->ts.type != BT_CLASS)
-	   && gfc_match_char ('%') == MATCH_YES)
+           && m == MATCH_YES)
     {
-      gfc_error ("Unexpected %<%%%> for nonderived-type variable %qs at %C",
-		 sym->name);
+      gfc_error ("Unexpected %<%c%> for nonderived-type variable %qs at %C",
+		 sep, sym->name);
       return MATCH_ERROR;
     }
 
   if ((sym->ts.type != BT_DERIVED && sym->ts.type != BT_CLASS)
-      || gfc_match_char ('%') != MATCH_YES)
+      || m != MATCH_YES)
     goto check_substring;
 
   sym = sym->ts.u.derived;
@@ -2061,15 +2068,24 @@ gfc_match_varspec (gfc_expr *primary, int equiv_flag, bool sub_flag,
 	  break;
 	}
 
-      component = gfc_find_component (sym, name, false, false);
+      component = gfc_find_component (sym, name, false, false, &tmp);
       if (component == NULL)
 	return MATCH_ERROR;
 
-      tail = extend_ref (primary, tail);
-      tail->type = REF_COMPONENT;
+      /* Extend the reference chain determined by gfc_find_component.  */
+      if (primary->ref == NULL)
+        primary->ref = tmp;
+      else
+        {
+          /* Set by the for loop below for the last component ref.  */
+          gcc_assert (tail != NULL);
+          tail->next = tmp;
+        }
 
-      tail->u.c.component = component;
-      tail->u.c.sym = sym;
+      /* The reference chain may be longer than one hop for union
+         subcomponents; find the new tail.  */
+      for (tail = tmp; tail->next; tail = tail->next)
+        ;
 
       primary->ts = component->ts;
 
@@ -2119,7 +2135,7 @@ gfc_match_varspec (gfc_expr *primary, int equiv_flag, bool sub_flag,
 	}
 
       if ((component->ts.type != BT_DERIVED && component->ts.type != BT_CLASS)
-	  || gfc_match_char ('%') != MATCH_YES)
+	  || gfc_match_member_sep (component->ts.u.derived) != MATCH_YES)
 	break;
 
       sym = component->ts.u.derived;
@@ -2127,7 +2143,7 @@ gfc_match_varspec (gfc_expr *primary, int equiv_flag, bool sub_flag,
 
 check_substring:
   unknown = false;
-  if (primary->ts.type == BT_UNKNOWN && sym->attr.flavor != FL_DERIVED)
+  if (primary->ts.type == BT_UNKNOWN && !gfc_fl_struct (sym->attr.flavor))
     {
       if (gfc_get_default_type (sym->name, sym->ns)->type == BT_CHARACTER)
        {
@@ -2548,11 +2564,11 @@ gfc_convert_to_structure_constructor (gfc_expr *e, gfc_symbol *sym, gfc_expr **c
       /* Find the current component in the structure definition and check
 	     its access is not private.  */
       if (comp)
-	this_comp = gfc_find_component (sym, comp->name, false, false);
+	this_comp = gfc_find_component (sym, comp->name, false, false, NULL);
       else
 	{
 	  this_comp = gfc_find_component (sym, (const char *)comp_tail->name,
-					  false, false);
+					  false, false, NULL);
 	  comp = NULL; /* Reset needed!  */
 	}
 
@@ -2596,7 +2612,7 @@ gfc_convert_to_structure_constructor (gfc_expr *e, gfc_symbol *sym, gfc_expr **c
           if (comp && comp == sym->components
                 && sym->attr.extension
 		&& comp_tail->val
-                && (comp_tail->val->ts.type != BT_DERIVED
+                && (!gfc_bt_struct (comp_tail->val->ts.type)
                       ||
                     comp_tail->val->ts.u.derived != this_comp->ts.u.derived))
             {
@@ -2697,7 +2713,7 @@ gfc_match_structure_constructor (gfc_symbol *sym, gfc_expr **result)
   e->symtree = symtree;
   e->expr_type = EXPR_FUNCTION;
 
-  gcc_assert (sym->attr.flavor == FL_DERIVED
+  gcc_assert (gfc_fl_struct (sym->attr.flavor)
 	      && symtree->n.sym->attr.flavor == FL_PROCEDURE);
   e->value.function.esym = sym;
   e->symtree->n.sym->attr.generic = 1;
@@ -2795,15 +2811,29 @@ gfc_match_rvalue (gfc_expr **result)
   if (m != MATCH_YES)
     return m;
 
-  if (gfc_find_state (COMP_INTERFACE)
-      && !gfc_current_ns->has_import_set)
-    i = gfc_get_sym_tree (name, NULL, &symtree, false);
-  else
-    i = gfc_get_ha_sym_tree (name, &symtree);
-
-  if (i)
+  /* Check if the symbol exists.  */
+  if (gfc_find_sym_tree (name, NULL, 1, &symtree))
     return MATCH_ERROR;
 
+  /* If the symbol doesn't exist, create it unless the name matches a FL_STRUCT
+     type. For derived types we create a generic symbol which links to the
+     derived type symbol; STRUCTUREs are simpler and must not conflict with
+     variables.  */
+  if (!symtree)
+    if (gfc_find_sym_tree (gfc_dt_upper_string (name), NULL, 1, &symtree))
+      return MATCH_ERROR;
+  if (!symtree || symtree->n.sym->attr.flavor != FL_STRUCT)
+    {
+      if (gfc_find_state (COMP_INTERFACE)
+          && !gfc_current_ns->has_import_set)
+        i = gfc_get_sym_tree (name, NULL, &symtree, false);
+      else
+        i = gfc_get_ha_sym_tree (name, &symtree);
+      if (i)
+        return MATCH_ERROR;
+    }
+
+
   sym = symtree->n.sym;
   e = NULL;
   where = gfc_current_locus;
@@ -2914,6 +2944,7 @@ gfc_match_rvalue (gfc_expr **result)
 
       break;
 
+    case FL_STRUCT:
     case FL_DERIVED:
       sym = gfc_use_derived (sym);
       if (sym == NULL)
@@ -3054,10 +3085,12 @@ gfc_match_rvalue (gfc_expr **result)
 	 via an IMPLICIT statement.  This can't wait for the
 	 resolution phase.  */
 
-      if (gfc_peek_ascii_char () == '%'
+      old_loc = gfc_current_locus;
+      if (gfc_match_member_sep (sym) == MATCH_YES
 	  && sym->ts.type == BT_UNKNOWN
 	  && gfc_get_default_type (sym->name, sym->ns)->type == BT_DERIVED)
 	gfc_set_default_type (sym, 0, sym->ns);
+      gfc_current_locus = old_loc;
 
       /* If the symbol has a (co)dimension attribute, the expression is a
 	 variable.  */
@@ -3210,13 +3243,19 @@ gfc_match_rvalue (gfc_expr **result)
       break;
 
     generic_function:
-      gfc_get_sym_tree (name, NULL, &symtree, false);	/* Can't fail */
+      /* Look for symbol first; if not found, look for STRUCTURE type symbol
+         specially. Creates a generic symbol for derived types.  */
+      gfc_find_sym_tree (name, NULL, 1, &symtree);
+      if (!symtree)
+        gfc_find_sym_tree (gfc_dt_upper_string (name), NULL, 1, &symtree);
+      if (!symtree || symtree->n.sym->attr.flavor != FL_STRUCT)
+        gfc_get_sym_tree (name, NULL, &symtree, false); /* Can't fail */
 
       e = gfc_get_expr ();
       e->symtree = symtree;
       e->expr_type = EXPR_FUNCTION;
 
-      if (sym->attr.flavor == FL_DERIVED)
+      if (gfc_fl_struct (sym->attr.flavor))
 	{
 	  e->value.function.esym = sym;
 	  e->symtree->n.sym->attr.generic = 1;
@@ -3260,10 +3299,10 @@ gfc_match_rvalue (gfc_expr **result)
 static match
 match_variable (gfc_expr **result, int equiv_flag, int host_flag)
 {
-  gfc_symbol *sym;
+  gfc_symbol *sym, *dt_sym;
   gfc_symtree *st;
   gfc_expr *expr;
-  locus where;
+  locus where, old_loc;
   match m;
 
   /* Since nothing has any business being an lvalue in a module
@@ -3294,6 +3333,17 @@ match_variable (gfc_expr **result, int equiv_flag, int host_flag)
   sym->attr.implied_index = 0;
 
   gfc_set_sym_referenced (sym);
+
+  /* STRUCTUREs may share names with variables, but derived types may not.  */
+  if (sym->attr.flavor == FL_PROCEDURE && sym->generic
+      && (dt_sym = gfc_find_dt_in_generic (sym)))
+    {
+      if (dt_sym->attr.flavor == FL_DERIVED)
+        gfc_error ("Derived type '%s' cannot be used as a variable at %C",
+                   sym->name);
+      return MATCH_ERROR;
+    }
+
   switch (sym->attr.flavor)
     {
     case FL_VARIABLE:
@@ -3379,11 +3429,13 @@ match_variable (gfc_expr **result, int equiv_flag, int host_flag)
 	implicit_ns = gfc_current_ns;
       else
 	implicit_ns = sym->ns;
-
-      if (gfc_peek_ascii_char () == '%'
+	
+      old_loc = gfc_current_locus;
+      if (gfc_match_member_sep (sym) == MATCH_YES
 	  && sym->ts.type == BT_UNKNOWN
 	  && gfc_get_default_type (sym->name, implicit_ns)->type == BT_DERIVED)
 	gfc_set_default_type (sym, 0, implicit_ns);
+      gfc_current_locus = old_loc;
     }
 
   expr = gfc_get_expr ();