RE: Fwd: DEC Extension Patches: Structure, Union, and Map

[Fritz Reese]

Please see the original thread
https://gcc.gnu.org/ml/fortran/2016-03/msg2.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


0004-2016-03-01-Fritz-Reese-fritzoreese-gmail.com.patch.gz
Description: GNU Zip compressed data

RE: Fwd: DEC Extension Patches: Structure, Union, and Map

[Fritz Reese]

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

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


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

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, >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, >loc);
+
+  if (lock_type && allocatable && !coarray)
+gfc_error 

RE: Fwd: DEC Extension Patches: Structure, Union, and Map

[Fritz Reese]

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

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

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

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, >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,
-		 >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, >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, >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, >declared_at);
+  gfc_error ("Component %qs at %L has the CONTIGUOUS attribute but "
+ "is not an array pointer", c->name, >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, >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, >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;
+
+  

RE: Fwd: DEC Extension Patches: Structure, Union, and Map

[Fritz Reese]

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

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



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

* 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*)[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 (_current_ns->sym_root,
-			gfc_get_string ("%c%s",
-(char) TOUPPER ((unsigned char) name[0]),
-[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]),
-			>name[1]), NULL, );
+  gfc_get_symbol (gfc_dt_upper_string (gensym->name), NULL, );
   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