public inbox for fortran@gcc.gnu.org
 help / color / mirror / Atom feed
* RE: Fwd: DEC Extension Patches: Structure, Union, and Map
@ 2016-03-01 21:12 Fritz Reese
  0 siblings, 0 replies; 16+ messages in thread
From: Fritz Reese @ 2016-03-01 21:12 UTC (permalink / raw)
  To: gcc-patches, fortran

[-- Attachment #1: Type: text/plain, Size: 210 bytes --]

Please see the original message:
https://gcc.gnu.org/ml/fortran/2016-03/msg00002.html

I have to send the patches separately, as together they are blocked by
the spam filter. This is part 1:



---
Fritz Reese

[-- Attachment #2: 0001-2014-10-16-Fritz-Reese-fritzoreese-gmail.com.patch --]
[-- Type: text/x-patch, Size: 8521 bytes --]

From 00eaf54e4cc4bb63bfbcb1ffab97cb9b593f2c6d Mon Sep 17 00:00:00 2001
From: Fritz O. Reese <fritzoreese@gmail.com>
Date: Thu, 16 Oct 2014 15:35:54 -0400
Subject: [PATCH 1/4] 2014-10-16  Fritz Reese  <fritzoreese@gmail.com>

    * gcc/fortran/module.c (dt_upper_string): Rename to gfc_dt_upper_string
    (dt_lower_string): Likewise.
    * gcc/fortran/gfortran.h: Make new gfc_dt_upper/lower_string global.
    * gcc/fortran/class.c: Use gfc_dt_upper_string.
    * gcc/fortran/decl.c: Likewise.
    * gcc/fortran/symbol.c: Likewise.
---
 gcc/fortran/class.c    |    3 +--
 gcc/fortran/decl.c     |   12 +++---------
 gcc/fortran/gfortran.h |    2 ++
 gcc/fortran/module.c   |   26 +++++++++++++-------------
 gcc/fortran/symbol.c   |   11 +++--------
 5 files changed, 22 insertions(+), 32 deletions(-)

diff --git a/gcc/fortran/class.c b/gcc/fortran/class.c
index 6a7339f..b3e1b45 100644
--- a/gcc/fortran/class.c
+++ b/gcc/fortran/class.c
@@ -477,8 +477,7 @@ get_unique_type_string (char *string, gfc_symbol *derived)
   if (derived->attr.unlimited_polymorphic)
     strcpy (dt_name, "STAR");
   else
-    strcpy (dt_name, derived->name);
-  dt_name[0] = TOUPPER (dt_name[0]);
+    strcpy (dt_name, gfc_dt_upper_string (derived->name));
   if (derived->attr.unlimited_polymorphic)
     sprintf (string, "_%s", dt_name);
   else if (derived->module)
diff --git a/gcc/fortran/decl.c b/gcc/fortran/decl.c
index d3ddda2..2b92623 100644
--- a/gcc/fortran/decl.c
+++ b/gcc/fortran/decl.c
@@ -2964,9 +2964,7 @@ gfc_match_decl_type_spec (gfc_typespec *ts, int implicit_flag)
      stored in a symtree with the first letter of the name capitalized; the
      symtree with the all lower-case name contains the associated
      generic function.  */
-  dt_name = gfc_get_string ("%c%s",
-			    (char) TOUPPER ((unsigned char) name[0]),
-			    (const char*)&name[1]);
+  dt_name = gfc_dt_upper_string (name);
   sym = NULL;
   dt_sym = NULL;
   if (ts->kind != -1)
@@ -3480,9 +3478,7 @@ gfc_match_import (void)
 		 letter of the name capitalized; the symtree with the all
 		 lower-case name contains the associated generic function.  */
 	      st = gfc_new_symtree (&gfc_current_ns->sym_root,
-			gfc_get_string ("%c%s",
-				(char) TOUPPER ((unsigned char) name[0]),
-				&name[1]));
+                                    gfc_dt_upper_string (name));
 	      st->n.sym = sym;
 	      sym->refs++;
 	      sym->attr.imported = 1;
@@ -8099,9 +8095,7 @@ gfc_match_derived_decl (void)
   if (!sym)
     {
       /* Use upper case to save the actual derived-type symbol.  */
-      gfc_get_symbol (gfc_get_string ("%c%s",
-			(char) TOUPPER ((unsigned char) gensym->name[0]),
-			&gensym->name[1]), NULL, &sym);
+      gfc_get_symbol (gfc_dt_upper_string (gensym->name), NULL, &sym);
       sym->name = gfc_get_string (gensym->name);
       head = gensym->generic;
       intr = gfc_get_interface ();
diff --git a/gcc/fortran/gfortran.h b/gcc/fortran/gfortran.h
index 33fffd8..2e6ea4b 100644
--- a/gcc/fortran/gfortran.h
+++ b/gcc/fortran/gfortran.h
@@ -3174,6 +3174,8 @@ void gfc_module_done_2 (void);
 void gfc_dump_module (const char *, int);
 bool gfc_check_symbol_access (gfc_symbol *);
 void gfc_free_use_stmts (gfc_use_list *);
+const char *gfc_dt_lower_string (const char *);
+const char *gfc_dt_upper_string (const char *);
 
 /* primary.c */
 symbol_attribute gfc_variable_attr (gfc_expr *, gfc_typespec *);
diff --git a/gcc/fortran/module.c b/gcc/fortran/module.c
index 32ee526..152574c 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;
@@ -990,7 +990,7 @@ 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);
+    t->name = gfc_dt_upper_string (sym->name);
   else
     t->name = sym->name;
 
@@ -1012,7 +1012,7 @@ build_tnt (gfc_symtree *st)
   build_tnt (st->right);
 
   if (st->n.sym->attr.flavor == FL_DERIVED)
-    name = dt_upper_string (st->n.sym->name);
+    name = gfc_dt_upper_string (st->n.sym->name);
   else
     name = st->n.sym->name;
 
@@ -3323,7 +3323,7 @@ fix_mio_expr (gfc_expr *e)
 	{
           const char *name = e->symtree->n.sym->name;
 	  if (e->symtree->n.sym->attr.flavor == FL_DERIVED)
-	    name = dt_upper_string (name);
+	    name = gfc_dt_upper_string (name);
 	  ns_st = gfc_find_symtree (gfc_current_ns->sym_root, name);
 	}
 
@@ -4845,7 +4845,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
@@ -5213,7 +5213,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);
 
@@ -5560,7 +5560,7 @@ write_symbol (int n, gfc_symbol *sym)
   if (sym->attr.flavor == FL_DERIVED)
     {
       const char *name;
-      name = dt_upper_string (sym->name);
+      name = gfc_dt_upper_string (sym->name);
       mio_pool_string (&name);
     }
   else
@@ -6568,7 +6568,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);
diff --git a/gcc/fortran/symbol.c b/gcc/fortran/symbol.c
index 8efd12c..f6819a6 100644
--- a/gcc/fortran/symbol.c
+++ b/gcc/fortran/symbol.c
@@ -3339,10 +3339,8 @@ gfc_restore_last_undo_checkpoint (void)
 	     letter capitalized; the all lower-case version to the
 	     derived type contains its associated generic function.  */
 	  if (p->attr.flavor == FL_DERIVED)
-	    gfc_delete_symtree (&p->ns->sym_root, gfc_get_string ("%c%s",
-                        (char) TOUPPER ((unsigned char) p->name[0]),
-                        &p->name[1]));
-	  else
+	    gfc_delete_symtree (&p->ns->sym_root,gfc_dt_upper_string (p->name));
+          else
 	    gfc_delete_symtree (&p->ns->sym_root, p->name);
 
 	  gfc_release_symbol (p);
@@ -4526,10 +4524,7 @@ generate_isocbinding_symbol (const char *mod_name, iso_c_binding_symbol s,
 	      const char *hidden_name;
 	      gfc_interface *intr, *head;
 
-	      hidden_name = gfc_get_string ("%c%s",
-					    (char) TOUPPER ((unsigned char)
-							      tmp_sym->name[0]),
-					    &tmp_sym->name[1]);
+	      hidden_name = gfc_dt_upper_string (tmp_sym->name);
 	      tmp_symtree = gfc_find_symtree (gfc_current_ns->sym_root,
 					      hidden_name);
 	      gcc_assert (tmp_symtree == NULL);
-- 
1.7.1


^ permalink raw reply	[flat|nested] 16+ messages in thread
* RE: Fwd: DEC Extension Patches: Structure, Union, and Map
@ 2016-03-01 21:17 Fritz Reese
  0 siblings, 0 replies; 16+ messages in thread
From: Fritz Reese @ 2016-03-01 21:17 UTC (permalink / raw)
  To: gcc-patches, fortran

[-- Attachment #1: Type: text/plain, Size: 213 bytes --]

Please see the original thread
https://gcc.gnu.org/ml/fortran/2016-03/msg00002.html.

I have to send the patches separately, as together they cause me to be
blocked for spamming. This is patch 2:

---
Fritz Reese

[-- Attachment #2: 0002-2014-11-10-Fritz-Reese-fritzoreese-gmail.com.patch --]
[-- Type: text/x-patch, Size: 28922 bytes --]

From 2f7077c45fdcf2d05554d9d2e22fc5261bd95661 Mon Sep 17 00:00:00 2001
From: Fritz O. Reese <fritzoreese@gmail.com>
Date: Mon, 10 Nov 2014 13:34:06 -0500
Subject: [PATCH 2/4] 2014-11-10  Fritz Reese  <fritzoreese@gmail.com>

gcc/fortran/
	* resolve.c (resolve_component): New function.
	(resolve_fl_derived0): Move component loop code to resolve_component.
---
 gcc/fortran/resolve.c |  742 ++++++++++++++++++++++++-------------------------
 1 files changed, 365 insertions(+), 377 deletions(-)

diff --git a/gcc/fortran/resolve.c b/gcc/fortran/resolve.c
index 556c846..1c3b814 100644
--- a/gcc/fortran/resolve.c
+++ b/gcc/fortran/resolve.c
@@ -12899,438 +12899,426 @@ check_defined_assignments (gfc_symbol *derived)
 }
 
 
-/* Resolve the components of a derived type. This does not have to wait until
-   resolution stage, but can be done as soon as the dt declaration has been
-   parsed.  */
+/* Resolve a single component of a derived type.  */
 
 static bool
-resolve_fl_derived0 (gfc_symbol *sym)
+resolve_component (gfc_component *c, gfc_symbol *sym)
 {
-  gfc_symbol* super_type;
-  gfc_component *c;
+  gfc_symbol *super_type;
 
-  if (sym->attr.unlimited_polymorphic)
+  if (c->attr.artificial)
     return true;
 
-  super_type = gfc_get_derived_super_type (sym);
+  /* F2008, C442.  */
+  if ((!sym->attr.is_class || c != sym->components)
+      && c->attr.codimension
+      && (!c->attr.allocatable || (c->as && c->as->type != AS_DEFERRED)))
+    {
+      gfc_error ("Coarray component %qs at %L must be allocatable with "
+                 "deferred shape", c->name, &c->loc);
+      return false;
+    }
 
-  /* F2008, C432.  */
-  if (super_type && sym->attr.coarray_comp && !super_type->attr.coarray_comp)
+  /* F2008, C443.  */
+  if (c->attr.codimension && c->ts.type == BT_DERIVED
+      && c->ts.u.derived->ts.is_iso_c)
     {
-      gfc_error ("As extending type %qs at %L has a coarray component, "
-		 "parent type %qs shall also have one", sym->name,
-		 &sym->declared_at, super_type->name);
+      gfc_error ("Component %qs at %L of TYPE(C_PTR) or TYPE(C_FUNPTR) "
+                 "shall not be a coarray", c->name, &c->loc);
       return false;
     }
 
-  /* Ensure the extended type gets resolved before we do.  */
-  if (super_type && !resolve_fl_derived0 (super_type))
-    return false;
+  /* F2008, C444.  */
+  if (c->ts.type == BT_DERIVED && c->ts.u.derived->attr.coarray_comp
+      && (c->attr.codimension || c->attr.pointer || c->attr.dimension
+          || c->attr.allocatable))
+    {
+      gfc_error ("Component %qs at %L with coarray component "
+                 "shall be a nonpointer, nonallocatable scalar",
+                 c->name, &c->loc);
+      return false;
+    }
 
-  /* An ABSTRACT type must be extensible.  */
-  if (sym->attr.abstract && !gfc_type_is_extensible (sym))
+  /* F2008, C448.  */
+  if (c->attr.contiguous && (!c->attr.dimension || !c->attr.pointer))
     {
-      gfc_error ("Non-extensible derived-type %qs at %L must not be ABSTRACT",
-		 sym->name, &sym->declared_at);
+      gfc_error ("Component %qs at %L has the CONTIGUOUS attribute but "
+                 "is not an array pointer", c->name, &c->loc);
       return false;
     }
 
-  c = (sym->attr.is_class) ? sym->components->ts.u.derived->components
-			   : sym->components;
+  if (c->attr.proc_pointer && c->ts.interface)
+    {
+      gfc_symbol *ifc = c->ts.interface;
 
-  bool success = true;
+      if (!sym->attr.vtype
+          && !check_proc_interface (ifc, &c->loc))
+        return false;
 
-  for ( ; c != NULL; c = c->next)
+      if (ifc->attr.if_source || ifc->attr.intrinsic)
+        {
+          /* Resolve interface and copy attributes.  */
+          if (ifc->formal && !ifc->formal_ns)
+            resolve_symbol (ifc);
+          if (ifc->attr.intrinsic)
+            gfc_resolve_intrinsic (ifc, &ifc->declared_at);
+
+          if (ifc->result)
+            {
+              c->ts = ifc->result->ts;
+              c->attr.allocatable = ifc->result->attr.allocatable;
+              c->attr.pointer = ifc->result->attr.pointer;
+              c->attr.dimension = ifc->result->attr.dimension;
+              c->as = gfc_copy_array_spec (ifc->result->as);
+              c->attr.class_ok = ifc->result->attr.class_ok;
+            }
+          else
+            {
+              c->ts = ifc->ts;
+              c->attr.allocatable = ifc->attr.allocatable;
+              c->attr.pointer = ifc->attr.pointer;
+              c->attr.dimension = ifc->attr.dimension;
+              c->as = gfc_copy_array_spec (ifc->as);
+              c->attr.class_ok = ifc->attr.class_ok;
+            }
+          c->ts.interface = ifc;
+          c->attr.function = ifc->attr.function;
+          c->attr.subroutine = ifc->attr.subroutine;
+
+          c->attr.pure = ifc->attr.pure;
+          c->attr.elemental = ifc->attr.elemental;
+          c->attr.recursive = ifc->attr.recursive;
+          c->attr.always_explicit = ifc->attr.always_explicit;
+          c->attr.ext_attr |= ifc->attr.ext_attr;
+          /* Copy char length.  */
+          if (ifc->ts.type == BT_CHARACTER && ifc->ts.u.cl)
+            {
+              gfc_charlen *cl = gfc_new_charlen (sym->ns, ifc->ts.u.cl);
+              if (cl->length && !cl->resolved
+                  && !gfc_resolve_expr (cl->length))
+                return false;
+              c->ts.u.cl = cl;
+            }
+        }
+    }
+  else if (c->attr.proc_pointer && c->ts.type == BT_UNKNOWN)
     {
-      if (c->attr.artificial)
-	continue;
+      /* Since PPCs are not implicitly typed, a PPC without an explicit
+         interface must be a subroutine.  */
+      gfc_add_subroutine (&c->attr, c->name, &c->loc);
+    }
 
-      /* F2008, C442.  */
-      if ((!sym->attr.is_class || c != sym->components)
-	  && c->attr.codimension
-	  && (!c->attr.allocatable || (c->as && c->as->type != AS_DEFERRED)))
-	{
-	  gfc_error ("Coarray component %qs at %L must be allocatable with "
-		     "deferred shape", c->name, &c->loc);
-	  success = false;
-	  continue;
-	}
+  /* Procedure pointer components: Check PASS arg.  */
+  if (c->attr.proc_pointer && !c->tb->nopass && c->tb->pass_arg_num == 0
+      && !sym->attr.vtype)
+    {
+      gfc_symbol* me_arg;
 
-      /* F2008, C443.  */
-      if (c->attr.codimension && c->ts.type == BT_DERIVED
-	  && c->ts.u.derived->ts.is_iso_c)
-	{
-	  gfc_error ("Component %qs at %L of TYPE(C_PTR) or TYPE(C_FUNPTR) "
-		     "shall not be a coarray", c->name, &c->loc);
-	  success = false;
-	  continue;
-	}
+      if (c->tb->pass_arg)
+        {
+          gfc_formal_arglist* i;
 
-      /* F2008, C444.  */
-      if (c->ts.type == BT_DERIVED && c->ts.u.derived->attr.coarray_comp
-	  && (c->attr.codimension || c->attr.pointer || c->attr.dimension
-	      || c->attr.allocatable))
-	{
-	  gfc_error ("Component %qs at %L with coarray component "
-		     "shall be a nonpointer, nonallocatable scalar",
-		     c->name, &c->loc);
-	  success = false;
-	  continue;
-	}
+          /* If an explicit passing argument name is given, walk the arg-list
+            and look for it.  */
 
-      /* F2008, C448.  */
-      if (c->attr.contiguous && (!c->attr.dimension || !c->attr.pointer))
-	{
-	  gfc_error ("Component %qs at %L has the CONTIGUOUS attribute but "
-		     "is not an array pointer", c->name, &c->loc);
-	  success = false;
-	  continue;
-	}
+          me_arg = NULL;
+          c->tb->pass_arg_num = 1;
+          for (i = c->ts.interface->formal; i; i = i->next)
+            {
+              if (!strcmp (i->sym->name, c->tb->pass_arg))
+                {
+                  me_arg = i->sym;
+                  break;
+                }
+              c->tb->pass_arg_num++;
+            }
 
-      if (c->attr.proc_pointer && c->ts.interface)
-	{
-	  gfc_symbol *ifc = c->ts.interface;
+          if (!me_arg)
+            {
+              gfc_error ("Procedure pointer component %qs with PASS(%s) "
+                         "at %L has no argument %qs", c->name,
+                         c->tb->pass_arg, &c->loc, c->tb->pass_arg);
+              c->tb->error = 1;
+              return false;
+            }
+        }
+      else
+        {
+          /* Otherwise, take the first one; there should in fact be at least
+            one.  */
+          c->tb->pass_arg_num = 1;
+          if (!c->ts.interface->formal)
+            {
+              gfc_error ("Procedure pointer component %qs with PASS at %L "
+                         "must have at least one argument",
+                         c->name, &c->loc);
+              c->tb->error = 1;
+              return false;
+            }
+          me_arg = c->ts.interface->formal->sym;
+        }
 
-	  if (!sym->attr.vtype && !check_proc_interface (ifc, &c->loc))
-	    {
-	      c->tb->error = 1;
-	      success = false;
-	      continue;
-	    }
+      /* Now check that the argument-type matches.  */
+      gcc_assert (me_arg);
+      if ((me_arg->ts.type != BT_DERIVED && me_arg->ts.type != BT_CLASS)
+          || (me_arg->ts.type == BT_DERIVED && me_arg->ts.u.derived != sym)
+          || (me_arg->ts.type == BT_CLASS
+              && CLASS_DATA (me_arg)->ts.u.derived != sym))
+        {
+          gfc_error ("Argument %qs of %qs with PASS(%s) at %L must be of"
+                     " the derived type %qs", me_arg->name, c->name,
+                     me_arg->name, &c->loc, sym->name);
+          c->tb->error = 1;
+          return false;
+        }
 
-	  if (ifc->attr.if_source || ifc->attr.intrinsic)
-	    {
-	      /* Resolve interface and copy attributes.  */
-	      if (ifc->formal && !ifc->formal_ns)
-		resolve_symbol (ifc);
-	      if (ifc->attr.intrinsic)
-		gfc_resolve_intrinsic (ifc, &ifc->declared_at);
+      /* Check for C453.  */
+      if (me_arg->attr.dimension)
+        {
+          gfc_error ("Argument %qs of %qs with PASS(%s) at %L "
+                     "must be scalar", me_arg->name, c->name, me_arg->name,
+                     &c->loc);
+          c->tb->error = 1;
+          return false;
+        }
 
-	      if (ifc->result)
-		{
-		  c->ts = ifc->result->ts;
-		  c->attr.allocatable = ifc->result->attr.allocatable;
-		  c->attr.pointer = ifc->result->attr.pointer;
-		  c->attr.dimension = ifc->result->attr.dimension;
-		  c->as = gfc_copy_array_spec (ifc->result->as);
-		  c->attr.class_ok = ifc->result->attr.class_ok;
-		}
-	      else
-		{
-		  c->ts = ifc->ts;
-		  c->attr.allocatable = ifc->attr.allocatable;
-		  c->attr.pointer = ifc->attr.pointer;
-		  c->attr.dimension = ifc->attr.dimension;
-		  c->as = gfc_copy_array_spec (ifc->as);
-		  c->attr.class_ok = ifc->attr.class_ok;
-		}
-	      c->ts.interface = ifc;
-	      c->attr.function = ifc->attr.function;
-	      c->attr.subroutine = ifc->attr.subroutine;
-
-	      c->attr.pure = ifc->attr.pure;
-	      c->attr.elemental = ifc->attr.elemental;
-	      c->attr.recursive = ifc->attr.recursive;
-	      c->attr.always_explicit = ifc->attr.always_explicit;
-	      c->attr.ext_attr |= ifc->attr.ext_attr;
-	      /* Copy char length.  */
-	      if (ifc->ts.type == BT_CHARACTER && ifc->ts.u.cl)
-		{
-		  gfc_charlen *cl = gfc_new_charlen (sym->ns, ifc->ts.u.cl);
-		  if (cl->length && !cl->resolved
-		      && !gfc_resolve_expr (cl->length))
-		    {
-		      c->tb->error = 1;
-		      success = false;
-		      continue;
-		    }
-		  c->ts.u.cl = cl;
-		}
-	    }
-	}
-      else if (c->attr.proc_pointer && c->ts.type == BT_UNKNOWN)
-	{
-	  /* Since PPCs are not implicitly typed, a PPC without an explicit
-	     interface must be a subroutine.  */
-	  gfc_add_subroutine (&c->attr, c->name, &c->loc);
-	}
+      if (me_arg->attr.pointer)
+        {
+          gfc_error ("Argument %qs of %qs with PASS(%s) at %L "
+                     "may not have the POINTER attribute", me_arg->name,
+                     c->name, me_arg->name, &c->loc);
+          c->tb->error = 1;
+          return false;
+        }
 
-      /* Procedure pointer components: Check PASS arg.  */
-      if (c->attr.proc_pointer && !c->tb->nopass && c->tb->pass_arg_num == 0
-	  && !sym->attr.vtype)
-	{
-	  gfc_symbol* me_arg;
+      if (me_arg->attr.allocatable)
+        {
+          gfc_error ("Argument %qs of %qs with PASS(%s) at %L "
+                     "may not be ALLOCATABLE", me_arg->name, c->name,
+                     me_arg->name, &c->loc);
+          c->tb->error = 1;
+          return false;
+        }
 
-	  if (c->tb->pass_arg)
-	    {
-	      gfc_formal_arglist* i;
+      if (gfc_type_is_extensible (sym) && me_arg->ts.type != BT_CLASS)
+        gfc_error ("Non-polymorphic passed-object dummy argument of %qs"
+                   " at %L", c->name, &c->loc);
 
-	      /* If an explicit passing argument name is given, walk the arg-list
-		and look for it.  */
+    }
 
-	      me_arg = NULL;
-	      c->tb->pass_arg_num = 1;
-	      for (i = c->ts.interface->formal; i; i = i->next)
-		{
-		  if (!strcmp (i->sym->name, c->tb->pass_arg))
-		    {
-		      me_arg = i->sym;
-		      break;
-		    }
-		  c->tb->pass_arg_num++;
-		}
+  /* Check type-spec if this is not the parent-type component.  */
+  if (((sym->attr.is_class
+        && (!sym->components->ts.u.derived->attr.extension
+            || c != sym->components->ts.u.derived->components))
+       || (!sym->attr.is_class
+           && (!sym->attr.extension || c != sym->components)))
+      && !sym->attr.vtype
+      && !resolve_typespec_used (&c->ts, &c->loc, c->name))
+    return false;
 
-	      if (!me_arg)
-		{
-		  gfc_error ("Procedure pointer component %qs with PASS(%s) "
-			     "at %L has no argument %qs", c->name,
-			     c->tb->pass_arg, &c->loc, c->tb->pass_arg);
-		  c->tb->error = 1;
-		  success = false;
-		  continue;
-		}
-	    }
-	  else
-	    {
-	      /* Otherwise, take the first one; there should in fact be at least
-		one.  */
-	      c->tb->pass_arg_num = 1;
-	      if (!c->ts.interface->formal)
-		{
-		  gfc_error ("Procedure pointer component %qs with PASS at %L "
-			     "must have at least one argument",
-			     c->name, &c->loc);
-		  c->tb->error = 1;
-		  success = false;
-		  continue;
-		}
-	      me_arg = c->ts.interface->formal->sym;
-	    }
+  super_type = gfc_get_derived_super_type (sym);
 
-	  /* Now check that the argument-type matches.  */
-	  gcc_assert (me_arg);
-	  if ((me_arg->ts.type != BT_DERIVED && me_arg->ts.type != BT_CLASS)
-	      || (me_arg->ts.type == BT_DERIVED && me_arg->ts.u.derived != sym)
-	      || (me_arg->ts.type == BT_CLASS
-		  && CLASS_DATA (me_arg)->ts.u.derived != sym))
-	    {
-	      gfc_error ("Argument %qs of %qs with PASS(%s) at %L must be of"
-			 " the derived type %qs", me_arg->name, c->name,
-			 me_arg->name, &c->loc, sym->name);
-	      c->tb->error = 1;
-	      success = false;
-	      continue;
-	    }
+  /* If this type is an extension, set the accessibility of the parent
+     component.  */
+  if (super_type
+      && ((sym->attr.is_class
+           && c == sym->components->ts.u.derived->components)
+          || (!sym->attr.is_class && c == sym->components))
+      && strcmp (super_type->name, c->name) == 0)
+    c->attr.access = super_type->attr.access;
+
+  /* If this type is an extension, see if this component has the same name
+     as an inherited type-bound procedure.  */
+  if (super_type && !sym->attr.is_class
+      && gfc_find_typebound_proc (super_type, NULL, c->name, true, NULL))
+    {
+      gfc_error ("Component %qs of %qs at %L has the same name as an"
+                 " inherited type-bound procedure",
+                 c->name, sym->name, &c->loc);
+      return false;
+    }
 
-	  /* Check for C453.  */
-	  if (me_arg->attr.dimension)
-	    {
-	      gfc_error ("Argument %qs of %qs with PASS(%s) at %L "
-			 "must be scalar", me_arg->name, c->name, me_arg->name,
-			 &c->loc);
-	      c->tb->error = 1;
-	      success = false;
-	      continue;
-	    }
+  if (c->ts.type == BT_CHARACTER && !c->attr.proc_pointer
+        && !c->ts.deferred)
+    {
+     if (c->ts.u.cl->length == NULL
+         || (!resolve_charlen(c->ts.u.cl))
+         || !gfc_is_constant_expr (c->ts.u.cl->length))
+       {
+         gfc_error ("Character length of component %qs needs to "
+                    "be a constant specification expression at %L",
+                    c->name,
+                    c->ts.u.cl->length ? &c->ts.u.cl->length->where : &c->loc);
+         return false;
+       }
+    }
 
-	  if (me_arg->attr.pointer)
-	    {
-	      gfc_error ("Argument %qs of %qs with PASS(%s) at %L "
-			 "may not have the POINTER attribute", me_arg->name,
-			 c->name, me_arg->name, &c->loc);
-	      c->tb->error = 1;
-	      success = false;
-	      continue;
-	    }
+  if (c->ts.type == BT_CHARACTER && c->ts.deferred
+      && !c->attr.pointer && !c->attr.allocatable)
+    {
+      gfc_error ("Character component %qs of %qs at %L with deferred "
+                 "length must be a POINTER or ALLOCATABLE",
+                 c->name, sym->name, &c->loc);
+      return false;
+    }
 
-	  if (me_arg->attr.allocatable)
-	    {
-	      gfc_error ("Argument %qs of %qs with PASS(%s) at %L "
-			 "may not be ALLOCATABLE", me_arg->name, c->name,
-			 me_arg->name, &c->loc);
-	      c->tb->error = 1;
-	      success = false;
-	      continue;
-	    }
+  /* Add the hidden deferred length field.  */
+  if (c->ts.type == BT_CHARACTER && c->ts.deferred && !c->attr.function
+      && !sym->attr.is_class)
+    {
+      char name[GFC_MAX_SYMBOL_LEN+9];
+      gfc_component *strlen;
+      sprintf (name, "_%s_length", c->name);
+      strlen = gfc_find_component (sym, name, true, true);
+      if (strlen == NULL)
+        {
+          if (!gfc_add_component (sym, name, &strlen))
+            return false;
+          strlen->ts.type = BT_INTEGER;
+          strlen->ts.kind = gfc_charlen_int_kind;
+          strlen->attr.access = ACCESS_PRIVATE;
+          strlen->attr.artificial = 1;
+        }
+    }
 
-	  if (gfc_type_is_extensible (sym) && me_arg->ts.type != BT_CLASS)
-	    {
-	      gfc_error ("Non-polymorphic passed-object dummy argument of %qs"
-			 " at %L", c->name, &c->loc);
-	      success = false;
-	      continue;
-	    }
+  if (c->ts.type == BT_DERIVED
+      && sym->component_access != ACCESS_PRIVATE
+      && gfc_check_symbol_access (sym)
+      && !is_sym_host_assoc (c->ts.u.derived, sym->ns)
+      && !c->ts.u.derived->attr.use_assoc
+      && !gfc_check_symbol_access (c->ts.u.derived)
+      && !gfc_notify_std (GFC_STD_F2003, "the component %qs is a "
+                          "PRIVATE type and cannot be a component of "
+                          "%qs, which is PUBLIC at %L", c->name,
+                          sym->name, &sym->declared_at))
+    return false;
 
-	}
+  if ((sym->attr.sequence || sym->attr.is_bind_c) && c->ts.type == BT_CLASS)
+    {
+      gfc_error ("Polymorphic component %s at %L in SEQUENCE or BIND(C) "
+                 "type %s", c->name, &c->loc, sym->name);
+      return false;
+    }
 
-      /* Check type-spec if this is not the parent-type component.  */
-      if (((sym->attr.is_class
-	    && (!sym->components->ts.u.derived->attr.extension
-		|| c != sym->components->ts.u.derived->components))
-	   || (!sym->attr.is_class
-	       && (!sym->attr.extension || c != sym->components)))
-	  && !sym->attr.vtype
-	  && !resolve_typespec_used (&c->ts, &c->loc, c->name))
-	return false;
+  if (sym->attr.sequence)
+    {
+      if (c->ts.type == BT_DERIVED && c->ts.u.derived->attr.sequence == 0)
+        {
+          gfc_error ("Component %s of SEQUENCE type declared at %L does "
+                     "not have the SEQUENCE attribute",
+                     c->ts.u.derived->name, &sym->declared_at);
+          return false;
+        }
+    }
 
-      /* If this type is an extension, set the accessibility of the parent
-	 component.  */
-      if (super_type
-	  && ((sym->attr.is_class
-	       && c == sym->components->ts.u.derived->components)
-	      || (!sym->attr.is_class && c == sym->components))
-	  && strcmp (super_type->name, c->name) == 0)
-	c->attr.access = super_type->attr.access;
-
-      /* If this type is an extension, see if this component has the same name
-	 as an inherited type-bound procedure.  */
-      if (super_type && !sym->attr.is_class
-	  && gfc_find_typebound_proc (super_type, NULL, c->name, true, NULL))
-	{
-	  gfc_error ("Component %qs of %qs at %L has the same name as an"
-		     " inherited type-bound procedure",
-		     c->name, sym->name, &c->loc);
-	  return false;
-	}
+  if (c->ts.type == BT_DERIVED && c->ts.u.derived->attr.generic)
+    c->ts.u.derived = gfc_find_dt_in_generic (c->ts.u.derived);
+  else if (c->ts.type == BT_CLASS && c->attr.class_ok
+           && CLASS_DATA (c)->ts.u.derived->attr.generic)
+    CLASS_DATA (c)->ts.u.derived
+                    = gfc_find_dt_in_generic (CLASS_DATA (c)->ts.u.derived);
 
-      if (c->ts.type == BT_CHARACTER && !c->attr.proc_pointer
-	    && !c->ts.deferred)
-	{
-	 if (c->ts.u.cl->length == NULL
-	     || (!resolve_charlen(c->ts.u.cl))
-	     || !gfc_is_constant_expr (c->ts.u.cl->length))
-	   {
-	     gfc_error ("Character length of component %qs needs to "
-			"be a constant specification expression at %L",
-			c->name,
-			c->ts.u.cl->length ? &c->ts.u.cl->length->where : &c->loc);
-	     return false;
-	   }
-	}
+  if (!sym->attr.is_class && c->ts.type == BT_DERIVED && !sym->attr.vtype
+      && c->attr.pointer && c->ts.u.derived->components == NULL
+      && !c->ts.u.derived->attr.zero_comp)
+    {
+      gfc_error ("The pointer component %qs of %qs at %L is a type "
+                 "that has not been declared", c->name, sym->name,
+                 &c->loc);
+      return false;
+    }
 
-      if (c->ts.type == BT_CHARACTER && c->ts.deferred
-	  && !c->attr.pointer && !c->attr.allocatable)
-	{
-	  gfc_error ("Character component %qs of %qs at %L with deferred "
-		     "length must be a POINTER or ALLOCATABLE",
-		     c->name, sym->name, &c->loc);
-	  return false;
-	}
+  if (c->ts.type == BT_CLASS && c->attr.class_ok
+      && CLASS_DATA (c)->attr.class_pointer
+      && CLASS_DATA (c)->ts.u.derived->components == NULL
+      && !CLASS_DATA (c)->ts.u.derived->attr.zero_comp
+      && !UNLIMITED_POLY (c))
+    {
+      gfc_error ("The pointer component %qs of %qs at %L is a type "
+                 "that has not been declared", c->name, sym->name,
+                 &c->loc);
+      return false;
+    }
 
-      /* Add the hidden deferred length field.  */
-      if (c->ts.type == BT_CHARACTER && c->ts.deferred && !c->attr.function
-	  && !sym->attr.is_class)
-	{
-	  char name[GFC_MAX_SYMBOL_LEN+9];
-	  gfc_component *strlen;
-	  sprintf (name, "_%s_length", c->name);
-	  strlen = gfc_find_component (sym, name, true, true);
-	  if (strlen == NULL)
-	    {
-	      if (!gfc_add_component (sym, name, &strlen))
-		return false;
-	      strlen->ts.type = BT_INTEGER;
-	      strlen->ts.kind = gfc_charlen_int_kind;
-	      strlen->attr.access = ACCESS_PRIVATE;
-	      strlen->attr.artificial = 1;
-	    }
-	}
+  /* C437.  */
+  if (c->ts.type == BT_CLASS && c->attr.flavor != FL_PROCEDURE
+      && (!c->attr.class_ok
+          || !(CLASS_DATA (c)->attr.class_pointer
+               || CLASS_DATA (c)->attr.allocatable)))
+    {
+      gfc_error ("Component %qs with CLASS at %L must be allocatable "
+                 "or pointer", c->name, &c->loc);
+      /* Prevent a recurrence of the error.  */
+      c->ts.type = BT_UNKNOWN;
+      return false;
+    }
 
-      if (c->ts.type == BT_DERIVED
-	  && sym->component_access != ACCESS_PRIVATE
-	  && gfc_check_symbol_access (sym)
-	  && !is_sym_host_assoc (c->ts.u.derived, sym->ns)
-	  && !c->ts.u.derived->attr.use_assoc
-	  && !gfc_check_symbol_access (c->ts.u.derived)
-	  && !gfc_notify_std (GFC_STD_F2003, "the component %qs is a "
-			      "PRIVATE type and cannot be a component of "
-			      "%qs, which is PUBLIC at %L", c->name,
-			      sym->name, &sym->declared_at))
-	return false;
+  /* Ensure that all the derived type components are put on the
+     derived type list; even in formal namespaces, where derived type
+     pointer components might not have been declared.  */
+  if (c->ts.type == BT_DERIVED
+        && c->ts.u.derived
+        && c->ts.u.derived->components
+        && c->attr.pointer
+        && sym != c->ts.u.derived)
+    add_dt_to_dt_list (c->ts.u.derived);
 
-      if ((sym->attr.sequence || sym->attr.is_bind_c) && c->ts.type == BT_CLASS)
-	{
-	  gfc_error ("Polymorphic component %s at %L in SEQUENCE or BIND(C) "
-		     "type %s", c->name, &c->loc, sym->name);
-	  return false;
-	}
+  if (!gfc_resolve_array_spec (c->as,
+                               !(c->attr.pointer || c->attr.proc_pointer
+                                 || c->attr.allocatable)))
+    return false;
 
-      if (sym->attr.sequence)
-	{
-	  if (c->ts.type == BT_DERIVED && c->ts.u.derived->attr.sequence == 0)
-	    {
-	      gfc_error ("Component %s of SEQUENCE type declared at %L does "
-			 "not have the SEQUENCE attribute",
-			 c->ts.u.derived->name, &sym->declared_at);
-	      return false;
-	    }
-	}
+  if (c->initializer && !sym->attr.vtype
+      && !gfc_check_assign_symbol (sym, c, c->initializer))
+    return false;
 
-      if (c->ts.type == BT_DERIVED && c->ts.u.derived->attr.generic)
-	c->ts.u.derived = gfc_find_dt_in_generic (c->ts.u.derived);
-      else if (c->ts.type == BT_CLASS && c->attr.class_ok
-	       && CLASS_DATA (c)->ts.u.derived->attr.generic)
-	CLASS_DATA (c)->ts.u.derived
-			= gfc_find_dt_in_generic (CLASS_DATA (c)->ts.u.derived);
+  return true;
+}
 
-      if (!sym->attr.is_class && c->ts.type == BT_DERIVED && !sym->attr.vtype
-	  && c->attr.pointer && c->ts.u.derived->components == NULL
-	  && !c->ts.u.derived->attr.zero_comp)
-	{
-	  gfc_error ("The pointer component %qs of %qs at %L is a type "
-		     "that has not been declared", c->name, sym->name,
-		     &c->loc);
-	  return false;
-	}
 
-      if (c->ts.type == BT_CLASS && c->attr.class_ok
-	  && CLASS_DATA (c)->attr.class_pointer
-	  && CLASS_DATA (c)->ts.u.derived->components == NULL
-	  && !CLASS_DATA (c)->ts.u.derived->attr.zero_comp
-	  && !UNLIMITED_POLY (c))
-	{
-	  gfc_error ("The pointer component %qs of %qs at %L is a type "
-		     "that has not been declared", c->name, sym->name,
-		     &c->loc);
-	  return false;
-	}
+/* Resolve the components of a derived type. This does not have to wait until
+   resolution stage, but can be done as soon as the dt declaration has been
+   parsed.  */
 
-      /* C437.  */
-      if (c->ts.type == BT_CLASS && c->attr.flavor != FL_PROCEDURE
-	  && (!c->attr.class_ok
-	      || !(CLASS_DATA (c)->attr.class_pointer
-		   || CLASS_DATA (c)->attr.allocatable)))
-	{
-	  gfc_error ("Component %qs with CLASS at %L must be allocatable "
-		     "or pointer", c->name, &c->loc);
-	  /* Prevent a recurrence of the error.  */
-	  c->ts.type = BT_UNKNOWN;
-	  return false;
-	}
+static bool
+resolve_fl_derived0 (gfc_symbol *sym)
+{
+  gfc_symbol* super_type;
+  gfc_component *c;
 
-      /* Ensure that all the derived type components are put on the
-	 derived type list; even in formal namespaces, where derived type
-	 pointer components might not have been declared.  */
-      if (c->ts.type == BT_DERIVED
-	    && c->ts.u.derived
-	    && c->ts.u.derived->components
-	    && c->attr.pointer
-	    && sym != c->ts.u.derived)
-	add_dt_to_dt_list (c->ts.u.derived);
-
-      if (!gfc_resolve_array_spec (c->as,
-				   !(c->attr.pointer || c->attr.proc_pointer
-				     || c->attr.allocatable)))
-	return false;
+  if (sym->attr.unlimited_polymorphic)
+    return true;
 
-      if (c->initializer && !sym->attr.vtype
-	  && !gfc_check_assign_symbol (sym, c, c->initializer))
-	return false;
+  super_type = gfc_get_derived_super_type (sym);
+
+  /* F2008, C432.  */
+  if (super_type && sym->attr.coarray_comp && !super_type->attr.coarray_comp)
+    {
+      gfc_error ("As extending type %qs at %L has a coarray component, "
+		 "parent type %qs shall also have one", sym->name,
+		 &sym->declared_at, super_type->name);
+      return false;
     }
 
-  if (!success)
+  /* Ensure the extended type gets resolved before we do.  */
+  if (super_type && !resolve_fl_derived0 (super_type))
     return false;
 
+  /* An ABSTRACT type must be extensible.  */
+  if (sym->attr.abstract && !gfc_type_is_extensible (sym))
+    {
+      gfc_error ("Non-extensible derived-type %qs at %L must not be ABSTRACT",
+		 sym->name, &sym->declared_at);
+      return false;
+    }
+
+  c = (sym->attr.is_class) ? sym->components->ts.u.derived->components
+			   : sym->components;
+
+  for ( ; c != NULL; c = c->next)
+    if (!resolve_component (c, sym))
+      return false;
+
   check_defined_assignments (sym);
 
   if (!sym->attr.defined_assign_comp && super_type)
-- 
1.7.1


^ permalink raw reply	[flat|nested] 16+ messages in thread
* RE: Fwd: DEC Extension Patches: Structure, Union, and Map
@ 2016-03-01 21:18 Fritz Reese
  0 siblings, 0 replies; 16+ messages in thread
From: Fritz Reese @ 2016-03-01 21:18 UTC (permalink / raw)
  To: gcc-patches, fortran

[-- Attachment #1: Type: text/plain, Size: 214 bytes --]

Please see the original thread
https://gcc.gnu.org/ml/fortran/2016-03/msg00002.html.

I have to send the patches separately, as together they cause me to be
blocked for spamming. This is patch 3:


---
Fritz Reese

[-- Attachment #2: 0003-2014-11-13-Fritz-Reese-fritzoreese-gmail.com.patch --]
[-- Type: text/x-patch, Size: 15598 bytes --]

From 93e96b8a9e62c0413e6d9d33c01fa7825ecd9ee4 Mon Sep 17 00:00:00 2001
From: Fritz O. Reese <fritzoreese@gmail.com>
Date: Thu, 13 Nov 2014 14:41:04 -0500
Subject: [PATCH 3/4] 2014-11-13  Fritz Reese  <fritzoreese@gmail.com>

gcc/fortran/
	* parse.c (check_component): New function.
        (parse_derived): Move loop code to check_component.
---
 gcc/fortran/parse.c |  343 +++++++++++++++++++++++++++------------------------
 1 files changed, 179 insertions(+), 164 deletions(-)

diff --git a/gcc/fortran/parse.c b/gcc/fortran/parse.c
index 7bce47f..1374c13 100644
--- a/gcc/fortran/parse.c
+++ b/gcc/fortran/parse.c
@@ -2646,6 +2646,184 @@ error:
 }
 
 
+/* Set attributes for the parent symbol based on the attributes of a component
+   and raise errors if conflicting attributes are found for the component.  */
+
+static void
+check_component (gfc_symbol *sym, gfc_component *c, gfc_component **lockp,
+    gfc_component **eventp)
+{
+  bool coarray, lock_type, event_type, allocatable, pointer;
+  coarray = lock_type = event_type = allocatable = pointer = false;
+  gfc_component *lock_comp, *event_comp;
+
+  lock_comp = *lockp;
+  event_comp = *eventp;
+
+  /* Look for allocatable components.  */
+  if (c->attr.allocatable
+      || (c->ts.type == BT_CLASS && c->attr.class_ok
+          && CLASS_DATA (c)->attr.allocatable)
+      || (c->ts.type == BT_DERIVED && !c->attr.pointer
+          && c->ts.u.derived->attr.alloc_comp))
+    {
+      allocatable = true;
+      sym->attr.alloc_comp = 1;
+    }
+
+  /* Look for pointer components.  */
+  if (c->attr.pointer
+      || (c->ts.type == BT_CLASS && c->attr.class_ok
+          && CLASS_DATA (c)->attr.class_pointer)
+      || (c->ts.type == BT_DERIVED && c->ts.u.derived->attr.pointer_comp))
+    {
+      pointer = true;
+      sym->attr.pointer_comp = 1;
+    }
+
+  /* Look for procedure pointer components.  */
+  if (c->attr.proc_pointer
+      || (c->ts.type == BT_DERIVED
+          && c->ts.u.derived->attr.proc_pointer_comp))
+    sym->attr.proc_pointer_comp = 1;
+
+  /* Looking for coarray components.  */
+  if (c->attr.codimension
+      || (c->ts.type == BT_CLASS && c->attr.class_ok
+          && CLASS_DATA (c)->attr.codimension))
+    {
+      coarray = true;
+      sym->attr.coarray_comp = 1;
+    }
+ 
+  if (c->ts.type == BT_DERIVED && c->ts.u.derived->attr.coarray_comp
+      && !c->attr.pointer)
+    {
+      coarray = true;
+      sym->attr.coarray_comp = 1;
+    }
+
+  /* Looking for lock_type components.  */
+  if ((c->ts.type == BT_DERIVED
+          && c->ts.u.derived->from_intmod == INTMOD_ISO_FORTRAN_ENV
+          && c->ts.u.derived->intmod_sym_id == ISOFORTRAN_LOCK_TYPE)
+      || (c->ts.type == BT_CLASS && c->attr.class_ok
+          && CLASS_DATA (c)->ts.u.derived->from_intmod
+             == INTMOD_ISO_FORTRAN_ENV
+          && CLASS_DATA (c)->ts.u.derived->intmod_sym_id
+             == ISOFORTRAN_LOCK_TYPE)
+      || (c->ts.type == BT_DERIVED && c->ts.u.derived->attr.lock_comp
+          && !allocatable && !pointer))
+    {
+      lock_type = 1;
+      lock_comp = c;
+      sym->attr.lock_comp = 1;
+    }
+
+    /* Looking for event_type components.  */
+    if ((c->ts.type == BT_DERIVED
+            && c->ts.u.derived->from_intmod == INTMOD_ISO_FORTRAN_ENV
+            && c->ts.u.derived->intmod_sym_id == ISOFORTRAN_EVENT_TYPE)
+        || (c->ts.type == BT_CLASS && c->attr.class_ok
+            && CLASS_DATA (c)->ts.u.derived->from_intmod
+               == INTMOD_ISO_FORTRAN_ENV
+            && CLASS_DATA (c)->ts.u.derived->intmod_sym_id
+               == ISOFORTRAN_EVENT_TYPE)
+        || (c->ts.type == BT_DERIVED && c->ts.u.derived->attr.event_comp
+            && !allocatable && !pointer))
+      {
+        event_type = 1;
+        event_comp = c;
+        sym->attr.event_comp = 1;
+      }
+
+  /* Check for F2008, C1302 - and recall that pointers may not be coarrays
+     (5.3.14) and that subobjects of coarray are coarray themselves (2.4.7),
+     unless there are nondirect [allocatable or pointer] components
+     involved (cf. 1.3.33.1 and 1.3.33.3).  */
+
+  if (pointer && !coarray && lock_type)
+    gfc_error ("Component %s at %L of type LOCK_TYPE must have a "
+               "codimension or be a subcomponent of a coarray, "
+               "which is not possible as the component has the "
+               "pointer attribute", c->name, &c->loc);
+  else if (pointer && !coarray && c->ts.type == BT_DERIVED
+           && c->ts.u.derived->attr.lock_comp)
+    gfc_error ("Pointer component %s at %L has a noncoarray subcomponent "
+               "of type LOCK_TYPE, which must have a codimension or be a "
+               "subcomponent of a coarray", c->name, &c->loc);
+
+  if (lock_type && allocatable && !coarray)
+    gfc_error ("Allocatable component %s at %L of type LOCK_TYPE must have "
+               "a codimension", c->name, &c->loc);
+  else if (lock_type && allocatable && c->ts.type == BT_DERIVED
+           && c->ts.u.derived->attr.lock_comp)
+    gfc_error ("Allocatable component %s at %L must have a codimension as "
+               "it has a noncoarray subcomponent of type LOCK_TYPE",
+               c->name, &c->loc);
+
+  if (sym->attr.coarray_comp && !coarray && lock_type)
+    gfc_error ("Noncoarray component %s at %L of type LOCK_TYPE or with "
+               "subcomponent of type LOCK_TYPE must have a codimension or "
+               "be a subcomponent of a coarray. (Variables of type %s may "
+               "not have a codimension as already a coarray "
+               "subcomponent exists)", c->name, &c->loc, sym->name);
+
+  if (sym->attr.lock_comp && coarray && !lock_type)
+    gfc_error ("Noncoarray component %s at %L of type LOCK_TYPE or with "
+               "subcomponent of type LOCK_TYPE must have a codimension or "
+               "be a subcomponent of a coarray. (Variables of type %s may "
+               "not have a codimension as %s at %L has a codimension or a "
+               "coarray subcomponent)", lock_comp->name, &lock_comp->loc,
+               sym->name, c->name, &c->loc);
+
+  /* Similarly for EVENT TYPE.  */
+
+  if (pointer && !coarray && event_type)
+    gfc_error ("Component %s at %L of type EVENT_TYPE must have a "
+               "codimension or be a subcomponent of a coarray, "
+               "which is not possible as the component has the "
+               "pointer attribute", c->name, &c->loc);
+  else if (pointer && !coarray && c->ts.type == BT_DERIVED
+           && c->ts.u.derived->attr.event_comp)
+    gfc_error ("Pointer component %s at %L has a noncoarray subcomponent "
+               "of type EVENT_TYPE, which must have a codimension or be a "
+               "subcomponent of a coarray", c->name, &c->loc);
+
+  if (event_type && allocatable && !coarray)
+    gfc_error ("Allocatable component %s at %L of type EVENT_TYPE must have "
+               "a codimension", c->name, &c->loc);
+  else if (event_type && allocatable && c->ts.type == BT_DERIVED
+           && c->ts.u.derived->attr.event_comp)
+    gfc_error ("Allocatable component %s at %L must have a codimension as "
+               "it has a noncoarray subcomponent of type EVENT_TYPE",
+               c->name, &c->loc);
+
+  if (sym->attr.coarray_comp && !coarray && event_type)
+    gfc_error ("Noncoarray component %s at %L of type EVENT_TYPE or with "
+               "subcomponent of type EVENT_TYPE must have a codimension or "
+               "be a subcomponent of a coarray. (Variables of type %s may "
+               "not have a codimension as already a coarray "
+               "subcomponent exists)", c->name, &c->loc, sym->name);
+
+  if (sym->attr.event_comp && coarray && !event_type)
+    gfc_error ("Noncoarray component %s at %L of type EVENT_TYPE or with "
+               "subcomponent of type EVENT_TYPE must have a codimension or "
+               "be a subcomponent of a coarray. (Variables of type %s may "
+               "not have a codimension as %s at %L has a codimension or a "
+               "coarray subcomponent)", event_comp->name, &event_comp->loc,
+               sym->name, c->name, &c->loc);
+
+  /* Look for private components.  */
+  if (sym->component_access == ACCESS_PRIVATE
+      || c->attr.access == ACCESS_PRIVATE
+      || (c->ts.type == BT_DERIVED && c->ts.u.derived->attr.private_comp))
+    sym->attr.private_comp = 1;
+
+  *lockp = lock_comp;
+  *eventp = event_comp;
+}
+
 /* Parse a derived type.  */
 
 static void
@@ -2762,170 +2940,7 @@ endType:
    */
   sym = gfc_current_block ();
   for (c = sym->components; c; c = c->next)
-    {
-      bool coarray, lock_type, event_type, allocatable, pointer;
-      coarray = lock_type = event_type = allocatable = pointer = false;
-
-      /* Look for allocatable components.  */
-      if (c->attr.allocatable
-	  || (c->ts.type == BT_CLASS && c->attr.class_ok
-	      && CLASS_DATA (c)->attr.allocatable)
-	  || (c->ts.type == BT_DERIVED && !c->attr.pointer
-	      && c->ts.u.derived->attr.alloc_comp))
-	{
-	  allocatable = true;
-	  sym->attr.alloc_comp = 1;
-	}
-
-      /* Look for pointer components.  */
-      if (c->attr.pointer
-	  || (c->ts.type == BT_CLASS && c->attr.class_ok
-	      && CLASS_DATA (c)->attr.class_pointer)
-	  || (c->ts.type == BT_DERIVED && c->ts.u.derived->attr.pointer_comp))
-	{
-	  pointer = true;
-	  sym->attr.pointer_comp = 1;
-	}
-
-      /* Look for procedure pointer components.  */
-      if (c->attr.proc_pointer
-	  || (c->ts.type == BT_DERIVED
-	      && c->ts.u.derived->attr.proc_pointer_comp))
-	sym->attr.proc_pointer_comp = 1;
-
-      /* Looking for coarray components.  */
-      if (c->attr.codimension
-	  || (c->ts.type == BT_CLASS && c->attr.class_ok
-	      && CLASS_DATA (c)->attr.codimension))
-	{
-	  coarray = true;
-	  sym->attr.coarray_comp = 1;
-	}
-
-      if (c->ts.type == BT_DERIVED && c->ts.u.derived->attr.coarray_comp
-	  && !c->attr.pointer)
-	{
-	  coarray = true;
-	  sym->attr.coarray_comp = 1;
-	}
-
-      /* Looking for lock_type components.  */
-      if ((c->ts.type == BT_DERIVED
-	      && c->ts.u.derived->from_intmod == INTMOD_ISO_FORTRAN_ENV
-	      && c->ts.u.derived->intmod_sym_id == ISOFORTRAN_LOCK_TYPE)
-	  || (c->ts.type == BT_CLASS && c->attr.class_ok
-	      && CLASS_DATA (c)->ts.u.derived->from_intmod
-		 == INTMOD_ISO_FORTRAN_ENV
-	      && CLASS_DATA (c)->ts.u.derived->intmod_sym_id
-		 == ISOFORTRAN_LOCK_TYPE)
-	  || (c->ts.type == BT_DERIVED && c->ts.u.derived->attr.lock_comp
-	      && !allocatable && !pointer))
-	{
-	  lock_type = 1;
-	  lock_comp = c;
-	  sym->attr.lock_comp = 1;
-	}
-
-      /* Looking for event_type components.  */
-      if ((c->ts.type == BT_DERIVED
-	      && c->ts.u.derived->from_intmod == INTMOD_ISO_FORTRAN_ENV
-	      && c->ts.u.derived->intmod_sym_id == ISOFORTRAN_EVENT_TYPE)
-	  || (c->ts.type == BT_CLASS && c->attr.class_ok
-	      && CLASS_DATA (c)->ts.u.derived->from_intmod
-		 == INTMOD_ISO_FORTRAN_ENV
-	      && CLASS_DATA (c)->ts.u.derived->intmod_sym_id
-		 == ISOFORTRAN_EVENT_TYPE)
-	  || (c->ts.type == BT_DERIVED && c->ts.u.derived->attr.event_comp
-	      && !allocatable && !pointer))
-	{
-	  event_type = 1;
-	  event_comp = c;
-	  sym->attr.event_comp = 1;
-	}
-
-      /* Check for F2008, C1302 - and recall that pointers may not be coarrays
-	 (5.3.14) and that subobjects of coarray are coarray themselves (2.4.7),
-	 unless there are nondirect [allocatable or pointer] components
-	 involved (cf. 1.3.33.1 and 1.3.33.3).  */
-
-      if (pointer && !coarray && lock_type)
-	gfc_error ("Component %s at %L of type LOCK_TYPE must have a "
-		   "codimension or be a subcomponent of a coarray, "
-		   "which is not possible as the component has the "
-		   "pointer attribute", c->name, &c->loc);
-      else if (pointer && !coarray && c->ts.type == BT_DERIVED
-	       && c->ts.u.derived->attr.lock_comp)
-	gfc_error ("Pointer component %s at %L has a noncoarray subcomponent "
-		   "of type LOCK_TYPE, which must have a codimension or be a "
-		   "subcomponent of a coarray", c->name, &c->loc);
-
-      if (lock_type && allocatable && !coarray)
-	gfc_error ("Allocatable component %s at %L of type LOCK_TYPE must have "
-		   "a codimension", c->name, &c->loc);
-      else if (lock_type && allocatable && c->ts.type == BT_DERIVED
-	       && c->ts.u.derived->attr.lock_comp)
-	gfc_error ("Allocatable component %s at %L must have a codimension as "
-		   "it has a noncoarray subcomponent of type LOCK_TYPE",
-		   c->name, &c->loc);
-
-      if (sym->attr.coarray_comp && !coarray && lock_type)
-	gfc_error ("Noncoarray component %s at %L of type LOCK_TYPE or with "
-		   "subcomponent of type LOCK_TYPE must have a codimension or "
-		   "be a subcomponent of a coarray. (Variables of type %s may "
-		   "not have a codimension as already a coarray "
-		   "subcomponent exists)", c->name, &c->loc, sym->name);
-
-      if (sym->attr.lock_comp && coarray && !lock_type)
-	gfc_error ("Noncoarray component %s at %L of type LOCK_TYPE or with "
-		   "subcomponent of type LOCK_TYPE must have a codimension or "
-		   "be a subcomponent of a coarray. (Variables of type %s may "
-		   "not have a codimension as %s at %L has a codimension or a "
-		   "coarray subcomponent)", lock_comp->name, &lock_comp->loc,
-		   sym->name, c->name, &c->loc);
-
-      /* Similarly for EVENT TYPE.  */
-
-      if (pointer && !coarray && event_type)
-	gfc_error ("Component %s at %L of type EVENT_TYPE must have a "
-		   "codimension or be a subcomponent of a coarray, "
-		   "which is not possible as the component has the "
-		   "pointer attribute", c->name, &c->loc);
-      else if (pointer && !coarray && c->ts.type == BT_DERIVED
-	       && c->ts.u.derived->attr.event_comp)
-	gfc_error ("Pointer component %s at %L has a noncoarray subcomponent "
-		   "of type EVENT_TYPE, which must have a codimension or be a "
-		   "subcomponent of a coarray", c->name, &c->loc);
-
-      if (event_type && allocatable && !coarray)
-	gfc_error ("Allocatable component %s at %L of type EVENT_TYPE must have "
-		   "a codimension", c->name, &c->loc);
-      else if (event_type && allocatable && c->ts.type == BT_DERIVED
-	       && c->ts.u.derived->attr.event_comp)
-	gfc_error ("Allocatable component %s at %L must have a codimension as "
-		   "it has a noncoarray subcomponent of type EVENT_TYPE",
-		   c->name, &c->loc);
-
-      if (sym->attr.coarray_comp && !coarray && event_type)
-	gfc_error ("Noncoarray component %s at %L of type EVENT_TYPE or with "
-		   "subcomponent of type EVENT_TYPE must have a codimension or "
-		   "be a subcomponent of a coarray. (Variables of type %s may "
-		   "not have a codimension as already a coarray "
-		   "subcomponent exists)", c->name, &c->loc, sym->name);
-
-      if (sym->attr.event_comp && coarray && !event_type)
-	gfc_error ("Noncoarray component %s at %L of type EVENT_TYPE or with "
-		   "subcomponent of type EVENT_TYPE must have a codimension or "
-		   "be a subcomponent of a coarray. (Variables of type %s may "
-		   "not have a codimension as %s at %L has a codimension or a "
-		   "coarray subcomponent)", event_comp->name, &event_comp->loc,
-		   sym->name, c->name, &c->loc);
-
-      /* Look for private components.  */
-      if (sym->component_access == ACCESS_PRIVATE
-	  || c->attr.access == ACCESS_PRIVATE
-	  || (c->ts.type == BT_DERIVED && c->ts.u.derived->attr.private_comp))
-	sym->attr.private_comp = 1;
-    }
+    check_component (sym, c, &lock_comp, &event_comp);
 
   if (!seen_component)
     sym->attr.zero_comp = 1;
-- 
1.7.1


^ permalink raw reply	[flat|nested] 16+ messages in thread
* RE: Fwd: DEC Extension Patches: Structure, Union, and Map
@ 2016-03-01 21:25 Fritz Reese
  0 siblings, 0 replies; 16+ messages in thread
From: Fritz Reese @ 2016-03-01 21:25 UTC (permalink / raw)
  To: gcc-patches, fortran

[-- Attachment #1: Type: text/plain, Size: 286 bytes --]

Please see the original thread
https://gcc.gnu.org/ml/fortran/2016-03/msg00002.html.

I have to send the patches separately, as together they cause me to be
blocked for spamming. This is the big one, patch 4. It is compressed
with gzip since it is 150KB uncompressed.


---
Fritz Reese

[-- Attachment #2: 0004-2016-03-01-Fritz-Reese-fritzoreese-gmail.com.patch.gz --]
[-- Type: application/x-gzip, Size: 40164 bytes --]

^ permalink raw reply	[flat|nested] 16+ messages in thread
* Re: Fwd: DEC Extension Patches: Structure, Union, and Map
@ 2016-05-10 22:34 Dominique d'Humières
  2016-05-13  0:15 ` Fritz Reese
  0 siblings, 1 reply; 16+ messages in thread
From: Dominique d'Humières @ 2016-05-10 22:34 UTC (permalink / raw)
  To: Steve Kargl; +Cc: fritzoreese, fortran

> Please keep an eye out for people reporting problems.
It caused pr71047.

> I'll commit the patch to the 6-branch next weekend as I am traveling
> for the next week.
Could you please wait for a fix?

TIA

Dominique

^ permalink raw reply	[flat|nested] 16+ messages in thread
end of thread, other threads:[~2016-05-14 20:01 UTC | newest]

Thread overview: 16+ messages (download: mbox.gz / follow: Atom feed)
-- links below jump to the message on this page --
     [not found] <CAE4aFAn4fv4G3qgYrJr-476dgAYjTeG=LEtzbzYZ_dz8WVme4A@mail.gmail.com>
     [not found] ` <CAE4aFAnVnTufXz6aVsjnvv_WBEkETWgDtRFJNxwnuZa39iiqfQ@mail.gmail.com>
     [not found]   ` <CAE4aFAmvOxARXxx2Z=kPxnXGmAfdZed0HAt_D9UVEm6OrHX50w@mail.gmail.com>
2016-03-01 21:07     ` Fwd: DEC Extension Patches: Structure, Union, and Map Fritz Reese
2016-03-02  0:25       ` Steve Kargl
2016-03-02  6:52         ` Paul Richard Thomas
2016-03-06 12:17           ` Paul Richard Thomas
2016-03-08  8:49             ` Paul Richard Thomas
2016-03-03 14:31       ` Jim MacArthur
2016-05-07 23:22       ` Steve Kargl
2016-05-10 17:37         ` Jerry DeLisle
2016-05-11  7:00           ` Paul Richard Thomas
2016-03-01 21:12 Fritz Reese
2016-03-01 21:17 Fritz Reese
2016-03-01 21:18 Fritz Reese
2016-03-01 21:25 Fritz Reese
2016-05-10 22:34 Dominique d'Humières
2016-05-13  0:15 ` Fritz Reese
2016-05-14 20:01   ` Steve Kargl

This is a public inbox, see mirroring instructions
for how to clone and mirror all data and code used for this inbox;
as well as URLs for read-only IMAP folder(s) and NNTP newsgroup(s).