1 files changed, 118 insertions, 31 deletions

diff --git a/gcc/fortran/symbol.c b/gcc/fortran/symbol.c
index 0ee7decffd..ec43e635bf 100644
--- a/gcc/fortran/symbol.c
+++ b/gcc/fortran/symbol.c
@@ -1,5 +1,5 @@
 /* Maintain binary trees of symbols.
-   Copyright (C) 2000-2016 Free Software Foundation, Inc.
+   Copyright (C) 2000-2017 Free Software Foundation, Inc.
    Contributed by Andy Vaught
 
 This file is part of GCC.
@@ -87,6 +87,15 @@ const mstring save_status[] =
     minit ("IMPLICIT-SAVE", SAVE_IMPLICIT),
 };
 
+/* Set the mstrings for DTIO procedure names.  */
+const mstring dtio_procs[] =
+{
+    minit ("_dtio_formatted_read", DTIO_RF),
+    minit ("_dtio_formatted_write", DTIO_WF),
+    minit ("_dtio_unformatted_read", DTIO_RUF),
+    minit ("_dtio_unformatted_write", DTIO_WUF),
+};
+
 /* This is to make sure the backend generates setup code in the correct
    order.  */
 
@@ -373,9 +382,10 @@ check_conflict (symbol_attribute *attr, const char *name, locus *where)
     *is_bind_c = "BIND(C)", *procedure = "PROCEDURE",
     *proc_pointer = "PROCEDURE POINTER", *abstract = "ABSTRACT",
     *asynchronous = "ASYNCHRONOUS", *codimension = "CODIMENSION",
-    *contiguous = "CONTIGUOUS", *generic = "GENERIC";
+    *contiguous = "CONTIGUOUS", *generic = "GENERIC", *automatic = "AUTOMATIC";
   static const char *threadprivate = "THREADPRIVATE";
   static const char *omp_declare_target = "OMP DECLARE TARGET";
+  static const char *omp_declare_target_link = "OMP DECLARE TARGET LINK";
   static const char *oacc_declare_copyin = "OACC DECLARE COPYIN";
   static const char *oacc_declare_create = "OACC DECLARE CREATE";
   static const char *oacc_declare_deviceptr = "OACC DECLARE DEVICEPTR";
@@ -438,6 +448,7 @@ check_conflict (symbol_attribute *attr, const char *name, locus *where)
       conf (dummy, save);
       conf (in_common, save);
       conf (result, save);
+      conf (automatic, save);
 
       switch (attr->flavor)
 	{
@@ -454,7 +465,6 @@ check_conflict (symbol_attribute *attr, const char *name, locus *where)
 	    gfc_error ("Namelist group name at %L cannot have the "
 		       "SAVE attribute", where);
 	    return false; 
-	    break;
 	  case FL_PROCEDURE:
 	    /* Conflicts between SAVE and PROCEDURE will be checked at
 	       resolution stage, see "resolve_fl_procedure".  */
@@ -464,8 +474,13 @@ check_conflict (symbol_attribute *attr, const char *name, locus *where)
 	}
     }
 
-  if (attr->dummy && ((attr->function || attr->subroutine) && 
-			gfc_current_state () == COMP_CONTAINS))
+  /* The copying of procedure dummy arguments for module procedures in
+     a submodule occur whilst the current state is COMP_CONTAINS. It
+     is necessary, therefore, to let this through.  */
+  if (attr->dummy
+      && (attr->function || attr->subroutine)
+      && gfc_current_state () == COMP_CONTAINS
+      && !(gfc_new_block && gfc_new_block->abr_modproc_decl))
     gfc_error_now ("internal procedure %qs at %L conflicts with "
 		   "DUMMY argument", name, where);
 
@@ -473,12 +488,19 @@ check_conflict (symbol_attribute *attr, const char *name, locus *where)
   conf (dummy, intrinsic);
   conf (dummy, threadprivate);
   conf (dummy, omp_declare_target);
+  conf (dummy, omp_declare_target_link);
   conf (pointer, target);
   conf (pointer, intrinsic);
   conf (pointer, elemental);
   conf (pointer, codimension);
   conf (allocatable, elemental);
 
+  conf (in_common, automatic);
+  conf (in_equivalence, automatic);
+  conf (result, automatic);
+  conf (use_assoc, automatic);
+  conf (dummy, automatic);
+
   conf (target, external);
   conf (target, intrinsic);
 
@@ -517,14 +539,18 @@ check_conflict (symbol_attribute *attr, const char *name, locus *where)
   conf (in_equivalence, allocatable);
   conf (in_equivalence, threadprivate);
   conf (in_equivalence, omp_declare_target);
+  conf (in_equivalence, omp_declare_target_link);
   conf (in_equivalence, oacc_declare_create);
   conf (in_equivalence, oacc_declare_copyin);
   conf (in_equivalence, oacc_declare_deviceptr);
   conf (in_equivalence, oacc_declare_device_resident);
+  conf (in_equivalence, is_bind_c);
 
   conf (dummy, result);
   conf (entry, result);
   conf (generic, result);
+  conf (generic, omp_declare_target);
+  conf (generic, omp_declare_target_link);
 
   conf (function, subroutine);
 
@@ -570,6 +596,7 @@ check_conflict (symbol_attribute *attr, const char *name, locus *where)
   conf (cray_pointee, in_equivalence);
   conf (cray_pointee, threadprivate);
   conf (cray_pointee, omp_declare_target);
+  conf (cray_pointee, omp_declare_target_link);
   conf (cray_pointee, oacc_declare_create);
   conf (cray_pointee, oacc_declare_copyin);
   conf (cray_pointee, oacc_declare_deviceptr);
@@ -626,8 +653,11 @@ check_conflict (symbol_attribute *attr, const char *name, locus *where)
   conf (procedure, entry)
 
   conf (proc_pointer, abstract)
+  conf (proc_pointer, omp_declare_target)
+  conf (proc_pointer, omp_declare_target_link)
 
   conf (entry, omp_declare_target)
+  conf (entry, omp_declare_target_link)
   conf (entry, oacc_declare_create)
   conf (entry, oacc_declare_copyin)
   conf (entry, oacc_declare_deviceptr)
@@ -669,6 +699,7 @@ check_conflict (symbol_attribute *attr, const char *name, locus *where)
       conf2 (subroutine);
       conf2 (threadprivate);
       conf2 (omp_declare_target);
+      conf2 (omp_declare_target_link);
       conf2 (oacc_declare_create);
       conf2 (oacc_declare_copyin);
       conf2 (oacc_declare_deviceptr);
@@ -719,6 +750,8 @@ check_conflict (symbol_attribute *attr, const char *name, locus *where)
       if (!attr->proc_pointer)
 	conf2 (in_common);
 
+      conf2 (omp_declare_target_link);
+
       switch (attr->proc)
 	{
 	case PROC_ST_FUNCTION:
@@ -755,6 +788,7 @@ check_conflict (symbol_attribute *attr, const char *name, locus *where)
       conf2 (threadprivate);
       conf2 (result);
       conf2 (omp_declare_target);
+      conf2 (omp_declare_target_link);
       conf2 (oacc_declare_create);
       conf2 (oacc_declare_copyin);
       conf2 (oacc_declare_deviceptr);
@@ -933,6 +967,21 @@ gfc_add_allocatable (symbol_attribute *attr, locus *where)
 
 
 bool
+gfc_add_automatic (symbol_attribute *attr, const char *name, locus *where)
+{
+  if (check_used (attr, name, where))
+    return false;
+
+  if (attr->automatic && !gfc_notify_std (GFC_STD_LEGACY,
+	"Duplicate AUTOMATIC attribute specified at %L", where))
+    return false;
+
+  attr->automatic = 1;
+  return check_conflict (attr, name, where);
+}
+
+
+bool
 gfc_add_codimension (symbol_attribute *attr, const char *name, locus *where)
 {
 
@@ -1270,6 +1319,22 @@ gfc_add_omp_declare_target (symbol_attribute *attr, const char *name,
 
 
 bool
+gfc_add_omp_declare_target_link (symbol_attribute *attr, const char *name,
+				 locus *where)
+{
+
+  if (check_used (attr, name, where))
+    return false;
+
+  if (attr->omp_declare_target_link)
+    return true;
+
+  attr->omp_declare_target_link = 1;
+  return check_conflict (attr, name, where);
+}
+
+
+bool
 gfc_add_oacc_declare_create (symbol_attribute *attr, const char *name,
 			     locus *where)
 {
@@ -1587,6 +1652,13 @@ gfc_add_flavor (symbol_attribute *attr, sym_flavor f, const char *name,
   if (attr->flavor == f && f == FL_VARIABLE)
     return true;
 
+  /* Copying a procedure dummy argument for a module procedure in a
+     submodule results in the flavor being copied and would result in
+     an error without this.  */
+  if (gfc_new_block && gfc_new_block->abr_modproc_decl
+      && attr->flavor == f && f == FL_PROCEDURE)
+    return true;
+
   if (attr->flavor != FL_UNKNOWN)
     {
       if (where == NULL)
@@ -1880,6 +1952,8 @@ gfc_copy_attr (symbol_attribute *dest, symbol_attribute *src, locus *where)
   if (src->allocatable && !gfc_add_allocatable (dest, where))
     goto fail;
 
+  if (src->automatic && !gfc_add_automatic (dest, NULL, where))
+    goto fail;
   if (src->dimension && !gfc_add_dimension (dest, NULL, where))
     goto fail;
   if (src->codimension && !gfc_add_codimension (dest, NULL, where))
@@ -1906,6 +1980,9 @@ gfc_copy_attr (symbol_attribute *dest, symbol_attribute *src, locus *where)
   if (src->omp_declare_target
       && !gfc_add_omp_declare_target (dest, NULL, where))
     goto fail;
+  if (src->omp_declare_target_link
+      && !gfc_add_omp_declare_target_link (dest, NULL, where))
+    goto fail;
   if (src->oacc_declare_create
       && !gfc_add_oacc_declare_create (dest, NULL, where))
     goto fail;
@@ -2085,7 +2162,7 @@ gfc_add_component (gfc_symbol *sym, const char *name,
   else
     tail->next = p;
 
-  p->name = gfc_get_string (name);
+  p->name = gfc_get_string ("%s", name);
   p->loc = gfc_current_locus;
   p->ts.type = BT_UNKNOWN;
 
@@ -2692,7 +2769,7 @@ gfc_new_symtree (gfc_symtree **root, const char *name)
   gfc_symtree *st;
 
   st = XCNEW (gfc_symtree);
-  st->name = gfc_get_string (name);
+  st->name = gfc_get_string ("%s", name);
 
   gfc_insert_bbt (root, st, compare_symtree);
   return st;
@@ -2705,10 +2782,20 @@ void
 gfc_delete_symtree (gfc_symtree **root, const char *name)
 {
   gfc_symtree st, *st0;
+  const char *p;
+
+  /* Submodules are marked as mod.submod.  When freeing a submodule
+     symbol, the symtree only has "submod", so adjust that here.  */
 
-  st0 = gfc_find_symtree (*root, name);
+  p = strrchr(name, '.');
+  if (p)
+    p++;
+  else
+    p = name;
+
+  st0 = gfc_find_symtree (*root, p);
 
-  st.name = gfc_get_string (name);
+  st.name = gfc_get_string ("%s", p);
   gfc_delete_bbt (root, &st, compare_symtree);
 
   free (st0);
@@ -2770,7 +2857,7 @@ gfc_get_uop (const char *name)
   st = gfc_new_symtree (&ns->uop_root, name);
 
   uop = st->n.uop = XCNEW (gfc_user_op);
-  uop->name = gfc_get_string (name);
+  uop->name = gfc_get_string ("%s", name);
   uop->access = ACCESS_UNKNOWN;
   uop->ns = ns;
 
@@ -2891,7 +2978,7 @@ gfc_new_symbol (const char *name, gfc_namespace *ns)
   if (strlen (name) > GFC_MAX_SYMBOL_LEN)
     gfc_internal_error ("new_symbol(): Symbol name too long");
 
-  p->name = gfc_get_string (name);
+  p->name = gfc_get_string ("%s", name);
 
   /* Make sure flags for symbol being C bound are clear initially.  */
   p->attr.is_bind_c = 0;
@@ -2901,6 +2988,7 @@ gfc_new_symbol (const char *name, gfc_namespace *ns)
   p->common_block = NULL;
   p->f2k_derived = NULL;
   p->assoc = NULL;
+  p->fn_result_spec = 0;
   
   return p;
 }
@@ -2930,7 +3018,11 @@ select_type_insert_tmp (gfc_symtree **st)
   gfc_select_type_stack *stack = select_type_stack;
   for (; stack; stack = stack->prev)
     if ((*st)->n.sym == stack->selector && stack->tmp)
-      *st = stack->tmp;
+      {
+        *st = stack->tmp;
+        select_type_insert_tmp (st);
+        return;
+      }
 }
 
 
@@ -3726,31 +3818,22 @@ gfc_charlen*
 gfc_new_charlen (gfc_namespace *ns, gfc_charlen *old_cl)
 {
   gfc_charlen *cl;
+
   cl = gfc_get_charlen ();
 
   /* Copy old_cl.  */
   if (old_cl)
     {
-      /* Put into namespace, but don't allow reject_statement
-	 to free it if old_cl is given.  */
-      gfc_charlen **prev = &ns->cl_list;
-      cl->next = ns->old_cl_list;
-      while (*prev != ns->old_cl_list)
-	prev = &(*prev)->next;
-      *prev = cl;
-      ns->old_cl_list = cl;
       cl->length = gfc_copy_expr (old_cl->length);
       cl->length_from_typespec = old_cl->length_from_typespec;
       cl->backend_decl = old_cl->backend_decl;
       cl->passed_length = old_cl->passed_length;
       cl->resolved = old_cl->resolved;
     }
-  else
-    {
-      /* Put into namespace.  */
-      cl->next = ns->cl_list;
-      ns->cl_list = cl;
-    }
+
+  /* Put into namespace.  */
+  cl->next = ns->cl_list;
+  ns->cl_list = cl;
 
   return cl;
 }
@@ -3987,6 +4070,10 @@ gfc_is_var_automatic (gfc_symbol *sym)
       && sym->ts.u.cl
       && !gfc_is_constant_expr (sym->ts.u.cl->length))
     return true;
+  /* Variables with explicit AUTOMATIC attribute.  */
+  if (sym->attr.automatic)
+      return true;
+
   return false;
 }
 
@@ -4082,7 +4169,7 @@ gfc_get_gsymbol (const char *name)
 
   s = XCNEW (gfc_gsymbol);
   s->type = GSYM_UNKNOWN;
-  s->name = gfc_get_string (name);
+  s->name = gfc_get_string ("%s", name);
 
   gfc_insert_bbt (&gfc_gsym_root, s, gsym_compare);
 
@@ -4545,7 +4632,7 @@ generate_isocbinding_symbol (const char *mod_name, iso_c_binding_symbol s,
     }
 
   /* Say what module this symbol belongs to.  */
-  tmp_sym->module = gfc_get_string (mod_name);
+  tmp_sym->module = gfc_get_string ("%s", mod_name);
   tmp_sym->from_intmod = INTMOD_ISO_C_BINDING;
   tmp_sym->intmod_sym_id = s;
   tmp_sym->attr.is_iso_c = 1;
@@ -4642,7 +4729,7 @@ generate_isocbinding_symbol (const char *mod_name, iso_c_binding_symbol s,
 	      gfc_get_sym_tree (hidden_name, gfc_current_ns, &tmp_symtree, false);
 	      dt_sym = tmp_symtree->n.sym;
 	      dt_sym->name = gfc_get_string (s == ISOCBINDING_PTR
-					    ? "c_ptr" : "c_funptr");
+					     ? "c_ptr" : "c_funptr");
 
 	      /* Generate an artificial generic function.  */
 	      head = tmp_sym->generic;
@@ -4662,7 +4749,7 @@ generate_isocbinding_symbol (const char *mod_name, iso_c_binding_symbol s,
 	    }
 
 	  /* Say what module this symbol belongs to.  */
-	  dt_sym->module = gfc_get_string (mod_name);
+	  dt_sym->module = gfc_get_string ("%s", mod_name);
 	  dt_sym->from_intmod = INTMOD_ISO_C_BINDING;
 	  dt_sym->intmod_sym_id = s;
           dt_sym->attr.use_assoc = 1;
@@ -4861,7 +4948,7 @@ gfc_type_compatible (gfc_typespec *ts1, gfc_typespec *ts2)
       && !is_union1 && !is_union2)
     return (ts1->type == ts2->type);
 
-  if ((is_derived1 && is_derived2) || (is_union1 && is_union1))
+  if ((is_derived1 && is_derived2) || (is_union1 && is_union2))
     return gfc_compare_derived_types (ts1->u.derived, ts2->u.derived);
 
   if (is_derived1 && is_class2)