diff mbox series

Fortran: Mark internal symbols as artificial [PR88009,PR68800]

Message ID 20211114231748.376086cd@nbbrfq
State New
Headers show
Series Fortran: Mark internal symbols as artificial [PR88009,PR68800] | expand

Commit Message

Bernhard Reutner-Fischer Nov. 14, 2021, 10:17 p.m. UTC
Hi!

Amend fix for PR88009 to mark all these class components as artificial.

gcc/fortran/ChangeLog:

        * class.c (gfc_build_class_symbol, generate_finalization_wrapper,
        (gfc_find_derived_vtab, find_intrinsic_vtab): Use stringpool for
        names. Mark internal symbols as artificial.
        * decl.c (gfc_match_decl_type_spec, gfc_match_end): Fix
        indentation.
        (gfc_match_derived_decl): Fix indentation. Check extension level
        before incrementing refs counter.
        * parse.c (parse_derived): Fix style.
        * resolve.c (resolve_global_procedure): Likewise.
        * symbol.c (gfc_check_conflict): Do not ignore artificial symbols.
        (gfc_add_flavor): Reorder condition, cheapest first.
        (gfc_new_symbol, gfc_get_sym_tree,
        generate_isocbinding_symbol): Fix style.
        * trans-expr.c (gfc_trans_subcomponent_assign): Remove
        restriction on !artificial.
        * match.c (gfc_match_equivalence): Special-case CLASS_DATA for
        warnings.

---
gfc_match_equivalence(), too, should not bail-out early on the first
error but should diagnose all errors. I.e. not goto cleanup but set
err=true and continue in order to diagnose all constraints of a
statement. Maybe Sandra or somebody else will eventually find time to
tweak that.

I think it also plugs a very minor leak of name in gfc_find_derived_vtab
so i also tagged it [PR68800]. At least that was the initial
motiviation to look at that spot.
We were doing
-      name = xasprintf ("__vtab_%s", tname);
...
          gfc_set_sym_referenced (vtab);                                        
-         name = xasprintf ("__vtype_%s", tname);

Bootstrapped and regtested without regressions on x86_64-unknown-linux.
Ok for trunk?

From 764a41d4afc1a03e1e8a380f4f92242a5bc9bd65 Mon Sep 17 00:00:00 2001
From: Bernhard Reutner-Fischer <aldot@gcc.gnu.org>
Date: Sun, 7 Nov 2021 11:15:56 +0100
Subject: [PATCH] Fortran: Mark internal symbols as artificial
To: fortran@gcc.gnu.org

Amend fix for PR88009 to mark all these as artificial.

gcc/fortran/ChangeLog:

	* class.c (gfc_build_class_symbol, generate_finalization_wrapper,
	(gfc_find_derived_vtab, find_intrinsic_vtab): Use stringpool for
	names. Mark internal symbols as artificial.
	* decl.c (gfc_match_decl_type_spec, gfc_match_end): Fix
	indentation.
	(gfc_match_derived_decl): Fix indentation. Check extension level
	before incrementing refs counter.
	* parse.c (parse_derived): Fix style.
	* resolve.c (resolve_global_procedure): Likewise.
	* symbol.c (gfc_check_conflict): Do not ignore artificial symbols.
	(gfc_add_flavor): Reorder condition, cheapest first.
	(gfc_new_symbol, gfc_get_sym_tree,
	generate_isocbinding_symbol): Fix style.
	* trans-expr.c (gfc_trans_subcomponent_assign): Remove
	restriction on !artificial.
	* match.c (gfc_match_equivalence): Special-case CLASS_DATA for
	warnings.

---
gfc_match_equivalence(), too, should not bail-out early on the first
error but should diagnose all errors. I.e. not goto cleanup but set
err=true and continue in order to diagnose all constraints of a
statement.
---
 gcc/fortran/class.c      | 70 +++++++++++++++++++++++-----------------
 gcc/fortran/decl.c       | 49 ++++++++++++++--------------
 gcc/fortran/match.c      | 21 +++++++++---
 gcc/fortran/parse.c      |  5 ++-
 gcc/fortran/resolve.c    |  2 +-
 gcc/fortran/symbol.c     | 20 ++++--------
 gcc/fortran/trans-expr.c |  2 +-
 7 files changed, 92 insertions(+), 77 deletions(-)

diff --git a/gcc/fortran/class.c b/gcc/fortran/class.c
index 6b017667600..44fccced7b9 100644
--- a/gcc/fortran/class.c
+++ b/gcc/fortran/class.c
@@ -637,7 +637,7 @@ gfc_build_class_symbol (gfc_typespec *ts, symbol_attribute *attr,
 			gfc_array_spec **as)
 {
   char tname[GFC_MAX_SYMBOL_LEN+1];
-  char *name;
+  const char *name;
   gfc_symbol *fclass;
   gfc_symbol *vtab;
   gfc_component *c;
@@ -665,17 +665,17 @@ gfc_build_class_symbol (gfc_typespec *ts, symbol_attribute *attr,
 
   get_unique_hashed_string (tname, ts->u.derived);
   if ((*as) && attr->allocatable)
-    name = xasprintf ("__class_%s_%d_%da", tname, rank, (*as)->corank);
+    name = gfc_get_string ("__class_%s_%d_%da", tname, rank, (*as)->corank);
   else if ((*as) && attr->pointer)
-    name = xasprintf ("__class_%s_%d_%dp", tname, rank, (*as)->corank);
+    name = gfc_get_string ("__class_%s_%d_%dp", tname, rank, (*as)->corank);
   else if ((*as))
-    name = xasprintf ("__class_%s_%d_%dt", tname, rank, (*as)->corank);
+    name = gfc_get_string ("__class_%s_%d_%dt", tname, rank, (*as)->corank);
   else if (attr->pointer)
-    name = xasprintf ("__class_%s_p", tname);
+    name = gfc_get_string ("__class_%s_p", tname);
   else if (attr->allocatable)
-    name = xasprintf ("__class_%s_a", tname);
+    name = gfc_get_string ("__class_%s_a", tname);
   else
-    name = xasprintf ("__class_%s_t", tname);
+    name = gfc_get_string ("__class_%s_t", tname);
 
   if (ts->u.derived->attr.unlimited_polymorphic)
     {
@@ -695,7 +695,7 @@ gfc_build_class_symbol (gfc_typespec *ts, symbol_attribute *attr,
   if (attr->dummy && !attr->codimension && (*as)
       && !((*as)->type == AS_DEFERRED || (*as)->type == AS_ASSUMED_RANK))
     {
-      char *sname;
+      const char *sname;
       ns = gfc_current_ns;
       gfc_find_symbol (name, ns, 0, &fclass);
       /* If a local class type with this name already exists, update the
@@ -703,8 +703,7 @@ gfc_build_class_symbol (gfc_typespec *ts, symbol_attribute *attr,
       if (fclass)
 	{
 	  fclass = NULL;
-	  sname = xasprintf ("%s_%d", name, ++ctr);
-	  free (name);
+	  sname = gfc_get_string ("%s_%d", name, ++ctr);
 	  name = sname;
 	}
     }
@@ -735,6 +734,7 @@ gfc_build_class_symbol (gfc_typespec *ts, symbol_attribute *attr,
       c->ts.type = BT_DERIVED;
       c->attr.access = ACCESS_PRIVATE;
       c->ts.u.derived = ts->u.derived;
+      c->attr.artificial = 1;
       c->attr.class_pointer = attr->pointer;
       c->attr.pointer = attr->pointer || (attr->dummy && !attr->allocatable)
 			|| attr->select_type_temporary;
@@ -742,7 +742,7 @@ gfc_build_class_symbol (gfc_typespec *ts, symbol_attribute *attr,
       c->attr.dimension = attr->dimension;
       c->attr.codimension = attr->codimension;
       c->attr.abstract = fclass->attr.abstract;
-      c->as = (*as);
+      c->as = *as;
       c->initializer = NULL;
 
       /* Add component '_vptr'.  */
@@ -751,6 +751,7 @@ gfc_build_class_symbol (gfc_typespec *ts, symbol_attribute *attr,
       c->ts.type = BT_DERIVED;
       c->attr.access = ACCESS_PRIVATE;
       c->attr.pointer = 1;
+      c->attr.artificial = 1;
 
       if (ts->u.derived->attr.unlimited_polymorphic)
 	{
@@ -792,8 +793,7 @@ gfc_build_class_symbol (gfc_typespec *ts, symbol_attribute *attr,
   fclass->attr.is_class = 1;
   ts->u.derived = fclass;
   attr->allocatable = attr->pointer = attr->dimension = attr->codimension = 0;
-  (*as) = NULL;
-  free (name);
+  *as = NULL;
   return true;
 }
 
@@ -1600,7 +1600,7 @@ generate_finalization_wrapper (gfc_symbol *derived, gfc_namespace *ns,
   gfc_component *comp;
   gfc_namespace *sub_ns;
   gfc_code *last_code, *block;
-  char *name;
+  const char *name;
   bool finalizable_comp = false;
   gfc_expr *ancestor_wrapper = NULL, *rank;
   gfc_iterator *iter;
@@ -1681,7 +1681,7 @@ generate_finalization_wrapper (gfc_symbol *derived, gfc_namespace *ns,
   sub_ns->resolved = 1;
 
   /* Set up the procedure symbol.  */
-  name = xasprintf ("__final_%s", tname);
+  name = gfc_get_string ("__final_%s", tname);
   gfc_get_symbol (name, sub_ns, &final);
   sub_ns->proc_name = final;
   final->attr.flavor = FL_PROCEDURE;
@@ -2238,7 +2238,6 @@ generate_finalization_wrapper (gfc_symbol *derived, gfc_namespace *ns,
   gfc_free_expr (rank);
   vtab_final->initializer = gfc_lval_expr_from_sym (final);
   vtab_final->ts.interface = final;
-  free (name);
 }
 
 
@@ -2313,10 +2312,10 @@ gfc_find_derived_vtab (gfc_symbol *derived)
   if (ns)
     {
       char tname[GFC_MAX_SYMBOL_LEN+1];
-      char *name;
+      const char *name;
 
       get_unique_hashed_string (tname, derived);
-      name = xasprintf ("__vtab_%s", tname);
+      name = gfc_get_string ("__vtab_%s", tname);
 
       /* Look for the vtab symbol in various namespaces.  */
       if (gsym && gsym->ns)
@@ -2344,7 +2343,7 @@ gfc_find_derived_vtab (gfc_symbol *derived)
 	  vtab->attr.vtab = 1;
 	  vtab->attr.access = ACCESS_PUBLIC;
 	  gfc_set_sym_referenced (vtab);
-	  name = xasprintf ("__vtype_%s", tname);
+	  name = gfc_get_string ("__vtype_%s", tname);
 
 	  gfc_find_symbol (name, ns, 0, &vtype);
 	  if (vtype == NULL)
@@ -2372,6 +2371,7 @@ gfc_find_derived_vtab (gfc_symbol *derived)
 		goto cleanup;
 	      vtype->attr.access = ACCESS_PUBLIC;
 	      vtype->attr.vtype = 1;
+	      vtype->attr.artificial = 1;
 	      gfc_set_sym_referenced (vtype);
 
 	      /* Add component '_hash'.  */
@@ -2380,6 +2380,7 @@ gfc_find_derived_vtab (gfc_symbol *derived)
 	      c->ts.type = BT_INTEGER;
 	      c->ts.kind = 4;
 	      c->attr.access = ACCESS_PRIVATE;
+	      c->attr.artificial = 1;
 	      c->initializer = gfc_get_int_expr (gfc_default_integer_kind,
 						 NULL, derived->hash_value);
 
@@ -2389,6 +2390,7 @@ gfc_find_derived_vtab (gfc_symbol *derived)
 	      c->ts.type = BT_INTEGER;
 	      c->ts.kind = gfc_size_kind;
 	      c->attr.access = ACCESS_PRIVATE;
+	      c->attr.artificial = 1;
 	      /* Remember the derived type in ts.u.derived,
 		 so that the correct initializer can be set later on
 		 (in gfc_conv_structure).  */
@@ -2401,6 +2403,7 @@ gfc_find_derived_vtab (gfc_symbol *derived)
 		goto cleanup;
 	      c->attr.pointer = 1;
 	      c->attr.access = ACCESS_PRIVATE;
+	      c->attr.artificial = 1;
 	      if (!derived->attr.unlimited_polymorphic)
 		parent = gfc_get_derived_super_type (derived);
 	      else
@@ -2447,7 +2450,7 @@ gfc_find_derived_vtab (gfc_symbol *derived)
 	      else
 		{
 		  /* Construct default initialization variable.  */
-		  name = xasprintf ("__def_init_%s", tname);
+		  name = gfc_get_string ("__def_init_%s", tname);
 		  gfc_get_symbol (name, ns, &def_init);
 		  def_init->attr.target = 1;
 		  def_init->attr.artificial = 1;
@@ -2467,6 +2470,7 @@ gfc_find_derived_vtab (gfc_symbol *derived)
 		goto cleanup;
 	      c->attr.proc_pointer = 1;
 	      c->attr.access = ACCESS_PRIVATE;
+	      c->attr.artificial = 1;
 	      c->tb = XCNEW (gfc_typebound_proc);
 	      c->tb->ppc = 1;
 	      if (derived->attr.unlimited_polymorphic
@@ -2480,7 +2484,7 @@ gfc_find_derived_vtab (gfc_symbol *derived)
 		  ns->contained = sub_ns;
 		  sub_ns->resolved = 1;
 		  /* Set up procedure symbol.  */
-		  name = xasprintf ("__copy_%s", tname);
+		  name = gfc_get_string ("__copy_%s", tname);
 		  gfc_get_symbol (name, sub_ns, &copy);
 		  sub_ns->proc_name = copy;
 		  copy->attr.flavor = FL_PROCEDURE;
@@ -2543,6 +2547,7 @@ gfc_find_derived_vtab (gfc_symbol *derived)
 		goto cleanup;
 	      c->attr.proc_pointer = 1;
 	      c->attr.access = ACCESS_PRIVATE;
+	      c->attr.artificial = 1;
 	      c->tb = XCNEW (gfc_typebound_proc);
 	      c->tb->ppc = 1;
 	      if (derived->attr.unlimited_polymorphic
@@ -2558,7 +2563,7 @@ gfc_find_derived_vtab (gfc_symbol *derived)
 		  ns->contained = sub_ns;
 		  sub_ns->resolved = 1;
 		  /* Set up procedure symbol.  */
-		  name = xasprintf ("__deallocate_%s", tname);
+		  name = gfc_get_string ("__deallocate_%s", tname);
 		  gfc_get_symbol (name, sub_ns, &dealloc);
 		  sub_ns->proc_name = dealloc;
 		  dealloc->attr.flavor = FL_PROCEDURE;
@@ -2607,7 +2612,6 @@ have_vtype:
 	  vtab->ts.u.derived = vtype;
 	  vtab->value = gfc_default_initializer (&vtab->ts);
 	}
-      free (name);
     }
 
   found_sym = vtab;
@@ -2700,13 +2704,13 @@ find_intrinsic_vtab (gfc_typespec *ts)
   if (ns)
     {
       char tname[GFC_MAX_SYMBOL_LEN+1];
-      char *name;
+      const char *name;
 
       /* Encode all types as TYPENAME_KIND_ including especially character
 	 arrays, whose length is now consistently stored in the _len component
 	 of the class-variable.  */
       sprintf (tname, "%s_%d_", gfc_basic_typename (ts->type), ts->kind);
-      name = xasprintf ("__vtab_%s", tname);
+      name = gfc_get_string ("__vtab_%s", tname);
 
       /* Look for the vtab symbol in the top-level namespace only.  */
       gfc_find_symbol (name, ns, 0, &vtab);
@@ -2722,8 +2726,9 @@ find_intrinsic_vtab (gfc_typespec *ts)
 	  vtab->attr.save = SAVE_IMPLICIT;
 	  vtab->attr.vtab = 1;
 	  vtab->attr.access = ACCESS_PUBLIC;
+	  vtab->attr.artificial = 1;
 	  gfc_set_sym_referenced (vtab);
-	  name = xasprintf ("__vtype_%s", tname);
+	  name = gfc_get_string ("__vtype_%s", tname);
 
 	  gfc_find_symbol (name, ns, 0, &vtype);
 	  if (vtype == NULL)
@@ -2740,6 +2745,7 @@ find_intrinsic_vtab (gfc_typespec *ts)
 				   &gfc_current_locus))
 		goto cleanup;
 	      vtype->attr.access = ACCESS_PUBLIC;
+	      vtype->attr.artificial = 1;
 	      vtype->attr.vtype = 1;
 	      gfc_set_sym_referenced (vtype);
 
@@ -2749,6 +2755,7 @@ find_intrinsic_vtab (gfc_typespec *ts)
 	      c->ts.type = BT_INTEGER;
 	      c->ts.kind = 4;
 	      c->attr.access = ACCESS_PRIVATE;
+	      c->attr.artificial = 1;
 	      hash = gfc_intrinsic_hash_value (ts);
 	      c->initializer = gfc_get_int_expr (gfc_default_integer_kind,
 						 NULL, hash);
@@ -2759,6 +2766,7 @@ find_intrinsic_vtab (gfc_typespec *ts)
 	      c->ts.type = BT_INTEGER;
 	      c->ts.kind = gfc_size_kind;
 	      c->attr.access = ACCESS_PRIVATE;
+	      c->attr.artificial = 1;
 
 	      /* Build a minimal expression to make use of
 		 target-memory.c/gfc_element_size for 'size'.  Special handling
@@ -2782,6 +2790,7 @@ find_intrinsic_vtab (gfc_typespec *ts)
 		goto cleanup;
 	      c->attr.pointer = 1;
 	      c->attr.access = ACCESS_PRIVATE;
+	      c->attr.artificial = 1;
 	      c->ts.type = BT_VOID;
 	      c->initializer = gfc_get_null_expr (NULL);
 
@@ -2790,6 +2799,7 @@ find_intrinsic_vtab (gfc_typespec *ts)
 		goto cleanup;
 	      c->attr.pointer = 1;
 	      c->attr.access = ACCESS_PRIVATE;
+	      c->attr.artificial = 1;
 	      c->ts.type = BT_VOID;
 	      c->initializer = gfc_get_null_expr (NULL);
 
@@ -2798,16 +2808,17 @@ find_intrinsic_vtab (gfc_typespec *ts)
 		goto cleanup;
 	      c->attr.proc_pointer = 1;
 	      c->attr.access = ACCESS_PRIVATE;
+	      c->attr.artificial = 1;
 	      c->tb = XCNEW (gfc_typebound_proc);
 	      c->tb->ppc = 1;
 
 	      if (ts->type != BT_CHARACTER)
-		name = xasprintf ("__copy_%s", tname);
+		name = gfc_get_string ("__copy_%s", tname);
 	      else
 		{
 		  /* __copy is always the same for characters.
 		     Check to see if copy function already exists.  */
-		  name = xasprintf ("__copy_character_%d", ts->kind);
+		  name = gfc_get_string ("__copy_character_%d", ts->kind);
 		  contained = ns->contained;
 		  for (; contained; contained = contained->sibling)
 		    if (contained->proc_name
@@ -2829,6 +2840,7 @@ find_intrinsic_vtab (gfc_typespec *ts)
 	      copy->attr.flavor = FL_PROCEDURE;
 	      copy->attr.subroutine = 1;
 	      copy->attr.pure = 1;
+	      copy->attr.artificial = 1;
 	      copy->attr.if_source = IFSRC_DECL;
 	      /* This is elemental so that arrays are automatically
 		 treated correctly by the scalarizer.  */
@@ -2851,6 +2863,7 @@ find_intrinsic_vtab (gfc_typespec *ts)
 	      dst->ts.kind = ts->kind;
 	      dst->attr.flavor = FL_VARIABLE;
 	      dst->attr.dummy = 1;
+	      dst->attr.artificial = 1;
 	      dst->attr.intent = INTENT_INOUT;
 	      gfc_set_sym_referenced (dst);
 	      copy->formal->next = gfc_get_formal_arglist ();
@@ -2877,7 +2890,6 @@ find_intrinsic_vtab (gfc_typespec *ts)
 	  vtab->ts.u.derived = vtype;
 	  vtab->value = gfc_default_initializer (&vtab->ts);
 	}
-      free (name);
     }
 
   found_sym = vtab;
diff --git a/gcc/fortran/decl.c b/gcc/fortran/decl.c
index ab88ab5e9c1..04aa43af1d5 100644
--- a/gcc/fortran/decl.c
+++ b/gcc/fortran/decl.c
@@ -4458,7 +4458,7 @@ gfc_match_decl_type_spec (gfc_typespec *ts, int implicit_flag)
 	      upe->attr.zero_comp = 1;
 	      if (!gfc_add_flavor (&upe->attr, FL_DERIVED, NULL,
 				   &gfc_current_locus))
-	      return MATCH_ERROR;
+		return MATCH_ERROR;
 	    }
 	  else
 	    {
@@ -8342,7 +8342,7 @@ gfc_match_end (gfc_statement *st)
     case COMP_SUBROUTINE:
       *st = ST_END_SUBROUTINE;
       if (!abreviated_modproc_decl)
-      target = " subroutine";
+	target = " subroutine";
       else
 	target = " procedure";
       eos_ok = !contained_procedure ();
@@ -8351,7 +8351,7 @@ gfc_match_end (gfc_statement *st)
     case COMP_FUNCTION:
       *st = ST_END_FUNCTION;
       if (!abreviated_modproc_decl)
-      target = " function";
+	target = " function";
       else
 	target = " procedure";
       eos_ok = !contained_procedure ();
@@ -10473,7 +10473,7 @@ gfc_match_derived_decl (void)
   match m;
   match is_type_attr_spec = MATCH_NO;
   bool seen_attr = false;
-  gfc_interface *intr = NULL, *head;
+  gfc_interface *intr = NULL;
   bool parameterized_type = false;
   bool seen_colons = false;
 
@@ -10498,16 +10498,15 @@ gfc_match_derived_decl (void)
      been added to 'attr' but now the parent type must be found and
      checked.  */
   if (parent[0])
-    extended = check_extended_derived_type (parent);
-
-  if (parent[0] && !extended)
-    return MATCH_ERROR;
+    {
+      extended = check_extended_derived_type (parent);
+      if (extended == NULL)
+	return MATCH_ERROR;
+    }
 
   m = gfc_match (" ::");
   if (m == MATCH_YES)
-    {
-      seen_colons = true;
-    }
+    seen_colons = true;
   else if (seen_attr)
     {
       gfc_error ("Expected :: in TYPE definition at %C");
@@ -10582,7 +10581,7 @@ gfc_match_derived_decl (void)
   if (gensym->attr.dummy)
     {
       gfc_error ("Dummy argument %qs at %L cannot be a derived type at %C",
-		 name, &gensym->declared_at);
+		 gensym->name, &gensym->declared_at);
       return MATCH_ERROR;
     }
 
@@ -10599,13 +10598,12 @@ gfc_match_derived_decl (void)
     {
       /* Use upper case to save the actual derived-type symbol.  */
       gfc_get_symbol (gfc_dt_upper_string (gensym->name), NULL, &sym);
-      sym->name = gfc_get_string ("%s", gensym->name);
-      head = gensym->generic;
+      sym->name = gensym->name;
+      sym->declared_at = gfc_current_locus;
       intr = gfc_get_interface ();
       intr->sym = sym;
       intr->where = gfc_current_locus;
-      intr->sym->declared_at = gfc_current_locus;
-      intr->next = head;
+      intr->next = gensym->generic;
       gensym->generic = intr;
       gensym->attr.if_source = IFSRC_DECL;
     }
@@ -10662,15 +10660,6 @@ gfc_match_derived_decl (void)
       gfc_component *p;
       gfc_formal_arglist *f, *g, *h;
 
-      /* Add the extended derived type as the first component.  */
-      gfc_add_component (sym, parent, &p);
-      extended->refs++;
-      gfc_set_sym_referenced (extended);
-
-      p->ts.type = BT_DERIVED;
-      p->ts.u.derived = extended;
-      p->initializer = gfc_default_initializer (&p->ts);
-
       /* Set extension level.  */
       if (extended->attr.extension == 255)
 	{
@@ -10680,6 +10669,16 @@ gfc_match_derived_decl (void)
 		     extended->name, &extended->declared_at);
 	  return MATCH_ERROR;
 	}
+
+      /* Add the extended derived type as the first component.  */
+      gfc_add_component (sym, parent, &p);
+      extended->refs++;
+      gfc_set_sym_referenced (extended);
+
+      p->ts.type = BT_DERIVED;
+      p->ts.u.derived = extended;
+      p->initializer = gfc_default_initializer (&p->ts);
+
       sym->attr.extension = extended->attr.extension + 1;
 
       /* Provide the links between the extended type and its extension.  */
diff --git a/gcc/fortran/match.c b/gcc/fortran/match.c
index 2bf21434a42..94e7dce1675 100644
--- a/gcc/fortran/match.c
+++ b/gcc/fortran/match.c
@@ -5706,11 +5706,22 @@ gfc_match_equivalence (void)
 
 	  if (!gfc_add_in_equivalence (&sym->attr, sym->name, NULL))
 	    goto cleanup;
-	  if (sym->ts.type == BT_CLASS
-	      && CLASS_DATA (sym)
-	      && !gfc_add_in_equivalence (&CLASS_DATA (sym)->attr,
-					  sym->name, NULL))
-	    goto cleanup;
+	  if (sym->ts.type == BT_CLASS && CLASS_DATA (sym))
+	    {
+	      bool ret;
+	      /* The check above should have seen allocatable and some more.
+		 But gfc_build_class_symbol clears
+		 allocatable, pointer, dimension, codimension on the
+		 base symbol.  Cheat by temporarily pretending our class data
+		 has the real symbol's attribs.
+	       */
+	      CLASS_DATA (sym)->attr.artificial = 0;
+	      ret = gfc_add_in_equivalence (&CLASS_DATA (sym)->attr,
+					  sym->name, NULL);
+	      CLASS_DATA (sym)->attr.artificial = 1;
+	      if (!ret)
+		goto cleanup;
+	    }
 
 	  if (sym->attr.in_common)
 	    {
diff --git a/gcc/fortran/parse.c b/gcc/fortran/parse.c
index 12aa80ec45c..fcbff0c1dcf 100644
--- a/gcc/fortran/parse.c
+++ b/gcc/fortran/parse.c
@@ -3581,6 +3581,7 @@ parse_derived (void)
 	{
 	case ST_NONE:
 	  unexpected_eof ();
+	  break; /* never reached */
 
 	case ST_DATA_DECL:
 	case ST_PROCEDURE:
@@ -3640,9 +3641,7 @@ endType:
 			 "TYPE statement");
 
 	  if (seen_sequence)
-	    {
-	      gfc_error ("Duplicate SEQUENCE statement at %C");
-	    }
+	    gfc_error ("Duplicate SEQUENCE statement at %C");
 
 	  seen_sequence = 1;
 	  gfc_add_sequence (&gfc_current_block ()->attr,
diff --git a/gcc/fortran/resolve.c b/gcc/fortran/resolve.c
index 1f4abd08720..a9a1103e049 100644
--- a/gcc/fortran/resolve.c
+++ b/gcc/fortran/resolve.c
@@ -2588,7 +2588,7 @@ resolve_global_procedure (gfc_symbol *sym, locus *where, int sub)
   gsym = gfc_get_gsymbol (sym->binding_label ? sym->binding_label : sym->name,
 			  sym->binding_label != NULL);
 
-  if ((gsym->type != GSYM_UNKNOWN && gsym->type != type))
+  if (gsym->type != GSYM_UNKNOWN && gsym->type != type)
     gfc_global_used (gsym, where);
 
   if ((sym->attr.if_source == IFSRC_UNKNOWN
diff --git a/gcc/fortran/symbol.c b/gcc/fortran/symbol.c
index 91798f2a3a5..9df23f314df 100644
--- a/gcc/fortran/symbol.c
+++ b/gcc/fortran/symbol.c
@@ -440,9 +440,6 @@ gfc_check_conflict (symbol_attribute *attr, const char *name, locus *where)
   const char *a1, *a2;
   int standard;
 
-  if (attr->artificial)
-    return true;
-
   if (where == NULL)
     where = &gfc_current_locus;
 
@@ -901,6 +898,10 @@ gfc_check_conflict (symbol_attribute *attr, const char *name, locus *where)
   return true;
 
 conflict:
+  /* It would be wrong to complain about artificial code.  */
+  if (attr->artificial)
+    return false;
+
   if (name == NULL)
     gfc_error ("%s attribute conflicts with %s attribute at %L",
 	       a1, a2, where);
@@ -1773,7 +1774,7 @@ gfc_add_flavor (symbol_attribute *attr, sym_flavor f, const char *name,
   /* 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 (attr->flavor == f && f == FL_PROCEDURE
+  if (f == FL_PROCEDURE && attr->flavor == f
       && gfc_new_block && gfc_new_block->abr_modproc_decl)
     return true;
 
@@ -3155,7 +3156,6 @@ gfc_new_symbol (const char *name, gfc_namespace *ns)
   gfc_symbol *p;
 
   p = XCNEW (gfc_symbol);
-
   gfc_clear_ts (&p->ts);
   gfc_clear_attr (&p->attr);
   p->ns = ns;
@@ -3397,7 +3397,6 @@ gfc_get_sym_tree (const char *name, gfc_namespace *ns, gfc_symtree **result,
       p = gfc_new_symbol (name, ns);
 
       /* Add to the list of tentative symbols.  */
-      p->old_symbol = NULL;
       p->mark = 1;
       p->gfc_new = 1;
       latest_undo_chgset->syms.safe_push (p);
@@ -3405,7 +3404,6 @@ gfc_get_sym_tree (const char *name, gfc_namespace *ns, gfc_symtree **result,
       st = gfc_new_symtree (&ns->sym_root, name);
       st->n.sym = p;
       p->refs++;
-
     }
   else
     {
@@ -4835,9 +4833,7 @@ generate_isocbinding_symbol (const char *mod_name, iso_c_binding_symbol s,
 	      gfc_derived_types->dt_next = tmp_sym;
 	    }
 	  else
-	    {
-	      tmp_sym->dt_next = tmp_sym;
-	    }
+	    tmp_sym->dt_next = tmp_sym;
 	  gfc_derived_types = tmp_sym;
         }
 
@@ -5013,9 +5009,7 @@ generate_isocbinding_symbol (const char *mod_name, iso_c_binding_symbol s,
 	      gfc_derived_types->dt_next = dt_sym;
 	    }
 	  else
-	    {
-	      dt_sym->dt_next = dt_sym;
-	    }
+	    dt_sym->dt_next = dt_sym;
 	  gfc_derived_types = dt_sym;
 
 	  gfc_add_component (dt_sym, "c_address", &tmp_comp);
diff --git a/gcc/fortran/trans-expr.c b/gcc/fortran/trans-expr.c
index e7aec3845d3..56ddb6629bc 100644
--- a/gcc/fortran/trans-expr.c
+++ b/gcc/fortran/trans-expr.c
@@ -9033,7 +9033,7 @@ gfc_trans_subcomponent_assign (tree dest, gfc_component * cm, gfc_expr * expr,
 	  gfc_add_expr_to_block (&block, tmp);
 	}
     }
-  else if (!cm->attr.artificial)
+  else
     {
       /* Scalar component (excluding deferred parameters).  */
       gfc_init_se (&se, NULL);

Comments

Bernhard Reutner-Fischer Nov. 17, 2021, 8:12 a.m. UTC | #1
On Tue, 16 Nov 2021 21:46:32 +0100
Harald Anlauf via Fortran <fortran@gcc.gnu.org> wrote:

> Hi Bernhard,
> 
> I'm trying to understand your patch.  What does it really try to solve?

Compiler generated symbols should be marked artificial.
The fix for PR88009 ( f8add009ce300f24b75e9c2e2cc5dd944a020c28 ,
r9-5194 ) added artificial just to the _final component and left out all the rest.
Note that the majority of compiler generated symbols in class.c
already had artificial set properly.
The proposed patch amends the other generated symbols to be marked
artificial, too.

The other parts fix memory leaks.

> 
> PR88009 is closed and seems to have nothing to do with this.

Well it marked only _final as artificial and forgot to adjust the
others as well.
We can remove the reference to PR88009 if you prefer?

thanks!
> 
> Harald
> 
> Am 14.11.21 um 23:17 schrieb Bernhard Reutner-Fischer via Fortran:
> > Hi!
> > 
> > Amend fix for PR88009 to mark all these class components as artificial.
> > 
> > gcc/fortran/ChangeLog:
> > 
> >          * class.c (gfc_build_class_symbol, generate_finalization_wrapper,
> >          (gfc_find_derived_vtab, find_intrinsic_vtab): Use stringpool for
> >          names. Mark internal symbols as artificial.
> >          * decl.c (gfc_match_decl_type_spec, gfc_match_end): Fix
> >          indentation.
> >          (gfc_match_derived_decl): Fix indentation. Check extension level
> >          before incrementing refs counter.
> >          * parse.c (parse_derived): Fix style.
> >          * resolve.c (resolve_global_procedure): Likewise.
> >          * symbol.c (gfc_check_conflict): Do not ignore artificial symbols.
> >          (gfc_add_flavor): Reorder condition, cheapest first.
> >          (gfc_new_symbol, gfc_get_sym_tree,
> >          generate_isocbinding_symbol): Fix style.
> >          * trans-expr.c (gfc_trans_subcomponent_assign): Remove
> >          restriction on !artificial.
> >          * match.c (gfc_match_equivalence): Special-case CLASS_DATA for
> >          warnings.
> > 
> > ---
> > gfc_match_equivalence(), too, should not bail-out early on the first
> > error but should diagnose all errors. I.e. not goto cleanup but set
> > err=true and continue in order to diagnose all constraints of a
> > statement. Maybe Sandra or somebody else will eventually find time to
> > tweak that.
> > 
> > I think it also plugs a very minor leak of name in gfc_find_derived_vtab
> > so i also tagged it [PR68800]. At least that was the initial
> > motiviation to look at that spot.
> > We were doing
> > -      name = xasprintf ("__vtab_%s", tname);
> > ...
> >            gfc_set_sym_referenced (vtab);
> > -         name = xasprintf ("__vtype_%s", tname);
> > 
> > Bootstrapped and regtested without regressions on x86_64-unknown-linux.
> > Ok for trunk?
> >   
> 
>
Harald Anlauf Nov. 17, 2021, 8:32 p.m. UTC | #2
Do you have testcases/reproducers demonstrating that the patch actually
fixes the issues you're describing?

Am 17.11.21 um 09:12 schrieb Bernhard Reutner-Fischer via Gcc-patches:
> On Tue, 16 Nov 2021 21:46:32 +0100
> Harald Anlauf via Fortran <fortran@gcc.gnu.org> wrote:
> 
>> Hi Bernhard,
>>
>> I'm trying to understand your patch.  What does it really try to solve?
> 
> Compiler generated symbols should be marked artificial.
> The fix for PR88009 ( f8add009ce300f24b75e9c2e2cc5dd944a020c28 ,
> r9-5194 ) added artificial just to the _final component and left out all the rest.
> Note that the majority of compiler generated symbols in class.c
> already had artificial set properly.
> The proposed patch amends the other generated symbols to be marked
> artificial, too.
> 
> The other parts fix memory leaks.
> 
>>
>> PR88009 is closed and seems to have nothing to do with this.
> 
> Well it marked only _final as artificial and forgot to adjust the
> others as well.
> We can remove the reference to PR88009 if you prefer?
> 
> thanks!
>>
>> Harald
>>
>> Am 14.11.21 um 23:17 schrieb Bernhard Reutner-Fischer via Fortran:
>>> Hi!
>>>
>>> Amend fix for PR88009 to mark all these class components as artificial.
>>>
>>> gcc/fortran/ChangeLog:
>>>
>>>           * class.c (gfc_build_class_symbol, generate_finalization_wrapper,
>>>           (gfc_find_derived_vtab, find_intrinsic_vtab): Use stringpool for
>>>           names. Mark internal symbols as artificial.
>>>           * decl.c (gfc_match_decl_type_spec, gfc_match_end): Fix
>>>           indentation.
>>>           (gfc_match_derived_decl): Fix indentation. Check extension level
>>>           before incrementing refs counter.
>>>           * parse.c (parse_derived): Fix style.
>>>           * resolve.c (resolve_global_procedure): Likewise.
>>>           * symbol.c (gfc_check_conflict): Do not ignore artificial symbols.
>>>           (gfc_add_flavor): Reorder condition, cheapest first.
>>>           (gfc_new_symbol, gfc_get_sym_tree,
>>>           generate_isocbinding_symbol): Fix style.
>>>           * trans-expr.c (gfc_trans_subcomponent_assign): Remove
>>>           restriction on !artificial.
>>>           * match.c (gfc_match_equivalence): Special-case CLASS_DATA for
>>>           warnings.
>>>
>>> ---
>>> gfc_match_equivalence(), too, should not bail-out early on the first
>>> error but should diagnose all errors. I.e. not goto cleanup but set
>>> err=true and continue in order to diagnose all constraints of a
>>> statement. Maybe Sandra or somebody else will eventually find time to
>>> tweak that.
>>>
>>> I think it also plugs a very minor leak of name in gfc_find_derived_vtab
>>> so i also tagged it [PR68800]. At least that was the initial
>>> motiviation to look at that spot.
>>> We were doing
>>> -      name = xasprintf ("__vtab_%s", tname);
>>> ...
>>>             gfc_set_sym_referenced (vtab);
>>> -         name = xasprintf ("__vtype_%s", tname);
>>>
>>> Bootstrapped and regtested without regressions on x86_64-unknown-linux.
>>> Ok for trunk?
>>>    
>>
>>
> 
>
diff mbox series

Patch

diff --git a/gcc/fortran/match.c b/gcc/fortran/match.c
index 2bf21434a42..94e7dce1675 100644
--- a/gcc/fortran/match.c
+++ b/gcc/fortran/match.c
@@ -5706,11 +5706,22 @@  gfc_match_equivalence (void)
 
 	  if (!gfc_add_in_equivalence (&sym->attr, sym->name, NULL))
 	    goto cleanup;
-	  if (sym->ts.type == BT_CLASS
-	      && CLASS_DATA (sym)
-	      && !gfc_add_in_equivalence (&CLASS_DATA (sym)->attr,
-					  sym->name, NULL))
-	    goto cleanup;
+	  if (sym->ts.type == BT_CLASS && CLASS_DATA (sym))
+	    {
+	      bool ret;
+	      /* The check above should have seen allocatable and some more.
+		 But gfc_build_class_symbol clears
+		 allocatable, pointer, dimension, codimension on the
+		 base symbol.  Cheat by temporarily pretending our class data
+		 has the real symbol's attribs.
+	       */
+	      CLASS_DATA (sym)->attr.artificial = 0;
+	      ret = gfc_add_in_equivalence (&CLASS_DATA (sym)->attr,
+					  sym->name, NULL);
+	      CLASS_DATA (sym)->attr.artificial = 1;
+	      if (!ret)
+		goto cleanup;
+	    }
 
 	  if (sym->attr.in_common)
 	    {