re PR fortran/20889 (type in a structure-constructor differs from type in derived-type-def)

2005-12-22  Paul Thomas  <pault@gcc.gnu.org>

	PR fortran/20889
	*resolve.c(resolve_structure_cons): Do not attempt to convert
	the type of mismatched pointer type components, except when
	the constructor component is BT_UNKNOWN; emit error instead.

	PR fortran/25029
	PR fortran/21256
	*resolve.c(check_assumed_size_reference): New function to check for upper
	bound in assumed size array references.
	(resolve_assumed_size_actual): New function to do a very restricted scan
	of actual argument expressions of those procedures for which incomplete
	assumed size array references are not allowed.
	(resolve_function, resolve_call): Switch off assumed size checking of
	actual arguments, except for elemental procedures and array valued
	intrinsics; excepting LBOUND.
	(resolve_variable): Call check_assumed_size_reference.

	PR fortran/19362
	PR fortran/20244
	PR fortran/20864
	PR fortran/25391
	*interface.c(gfc_compare_types): Broken into two.
	(gfc_compare_derived_types): Second half of gfc_compare_types with
	corrections for a missing check that module name is non-NULL and
	a check for private components.
	*symbol.c(gfc_free_dt_list): New function.
	(gfc_free_namespace): Call gfc_free_dt_list.
	*resolve.c(resolve_symbol): Build the list of derived types in the
	symbols namespace.
	*gfortran.h: Define the structure type gfc_dt_list.  Add a new field,
	derived_types to gfc_namespace.  Provide a prototye for the new
	function gfc_compare_derived_types.
	*trans_types.c(gfc_get_derived_type): Test for the derived type being
	available in the host namespace. In this case, the host backend
	declaration is used for the structure and its components.  If an
	unbuilt, equal structure that is not use associated is found in the
	host namespace, build it there and then.  On exit,traverse the
	namespace of the derived type to see if there are equal but unbuilt.
	If so, copy the structure and its component declarations.
	(copy_dt_decls_ifequal): New functions to copy declarations to other
	equal structure types.

	PR fortran/20862
	* io.c (gfc_match_format): Make the appearance of a format statement
	in a module specification block an error.

	PR fortran/23152
	* match.c (gfc_match_namelist): Set assumed shape arrays in
	namelists as std=GFC_STD_GNU and assumed size arrays as an
	unconditional error.

	PR fortran/25069
	* match.c (gfc_match_namelist): Set the respecification of a USE
	associated namelist group as std=GFC_STD_GNU.  Permit the concatenation
	on no error.

	PR fortran/25053
	PR fortran/25063
	PR fortran/25064
	PR fortran/25066
	PR fortran/25067
	PR fortran/25068
	PR fortran/25307
	* io.c (resolve_tag): Change std on IOSTAT != default integer to
	GFC_STD_GNU and change message accordingly.  Add same error for
	SIZE.
	(match_dt_element, gfortran.h): Add field err_where to gfc_dt and
	set it when tags are being matched.
	(gfc_resolve_dt): Remove tests that can be done before resolution
	and add some of the new ones here.
	(check_io_constraints): New function that checks for most of the
	data transfer constraints. Some of these were previously done in
	match_io, from where this function is called, and some were done
	in gfc_resolve_dt.
	(match_io): Remove most of the tests of constraints and add the
	call to check_io_constraints.

2005-12-22  Paul Thomas  <pault@gcc.gnu.org>

	PR fortran/20889
	*gfortran.dg/pointer_component_type_1.f90: New test.

	PR fortran/25029
	PR fortran/21256
	*gfortran.dg/assumed_size_refs.f90: New test for the conditions that
	should give an error with assumed size array refernces and checks those
	that should not.
	*gfortran.dg/gfortran.dg/pr15140.f90: Give the assumed size array
	reference an upper bound so that it does not generate an error.

	PR fortran/19362
	PR fortran/20244
	PR fortran/20864
	PR fortran/25391
	*gfortran.dg/used_dummy_types_1.f90: New test.
	*gfortran.dg/used_dummy_types_2.f90: New test.
	*gfortran.dg/used_dummy_types_3.f90: New test.
	*gfortran.dg/used_dummy_types_4.f90: New test.
	*gfortran.dg/used_dummy_types_5.f90: New test.

	PR fortran/23152
	*gfortran.dg/namelist_use.f90: Add trap for warning on NAMELIST
	group already being USE associated.
	*gfortran.dg/assumed_shape_nml.f90: New test.
	*gfortran.dg/assumed_size_nml.f90: New test.

	PR fortran/20862
	PR fortran/25053
	PR fortran/25063
	PR fortran/25064
	PR fortran/25066
	PR fortran/25067
	PR fortran/25068
	PR fortran/25307
	* gfortran.dg/io_constraints_1.f90: New test.
	* gfortran.dg/io_constraints_1.f90: New test.
	* gfortran.dg/iostat_3.f90: Change wording of warning.
	 * gfortran.dg/g77/19981216-0.f:  the same.

From-SVN: r108943

1 files changed, 143 insertions, 4 deletions

diff --git a/gcc/fortran/resolve.c b/gcc/fortran/resolve.c
index de2da63..5ba4c8e 100644
--- a/gcc/fortran/resolve.c
+++ b/gcc/fortran/resolve.c
@@ -588,9 +588,18 @@ resolve_structure_cons (gfc_expr * expr)
 
       /* If we don't have the right type, try to convert it.  */
 
-      if (!gfc_compare_types (&cons->expr->ts, &comp->ts)
-	  && gfc_convert_type (cons->expr, &comp->ts, 1) == FAILURE)
-	t = FAILURE;
+      if (!gfc_compare_types (&cons->expr->ts, &comp->ts))
+	{
+	  t = FAILURE;
+	  if (comp->pointer && cons->expr->ts.type != BT_UNKNOWN)
+	    gfc_error ("The element in the derived type constructor at %L, "
+		       "for pointer component '%s', is %s but should be %s",
+		       &cons->expr->where, comp->name,
+		       gfc_basic_typename (cons->expr->ts.type),
+		       gfc_basic_typename (comp->ts.type));
+	  else
+	    t = gfc_convert_type (cons->expr, &comp->ts, 1);
+	}
     }
 
   return t;
@@ -686,6 +695,68 @@ procedure_kind (gfc_symbol * sym)
   return PTYPE_UNKNOWN;
 }
 
+/* Check references to assumed size arrays.  The flag need_full_assumed_size
+   is zero when matching actual arguments.  */
+
+static int need_full_assumed_size = 1;
+
+static int
+check_assumed_size_reference (gfc_symbol * sym, gfc_expr * e)
+{
+  gfc_ref * ref;
+  int dim;
+  int last = 1;
+
+  if (!need_full_assumed_size
+	|| !(sym->as && sym->as->type == AS_ASSUMED_SIZE))
+      return 0;
+
+  for (ref = e->ref; ref; ref = ref->next)
+    if (ref->type == REF_ARRAY)
+      for (dim = 0; dim < ref->u.ar.as->rank; dim++)
+	last = (ref->u.ar.end[dim] == NULL) && (ref->u.ar.type == DIMEN_ELEMENT);
+
+  if (last)
+    {
+      gfc_error ("The upper bound in the last dimension must "
+		 "appear in the reference to the assumed size "
+		 "array '%s' at %L.", sym->name, &e->where);
+      return 1;
+    }
+  return 0;
+}
+
+
+/* Look for bad assumed size array references in argument expressions
+  of elemental and array valued intrinsic procedures.  Since this is
+  called from procedure resolution functions, it only recurses at
+  operators.  */
+static bool
+resolve_assumed_size_actual (gfc_expr *e)
+{
+  if (e == NULL)
+   return false;
+
+  switch (e->expr_type)
+    {
+    case EXPR_VARIABLE:
+      if (e->symtree
+	    && check_assumed_size_reference (e->symtree->n.sym, e))
+	return true;
+      break;
+
+    case EXPR_OP:
+      if (resolve_assumed_size_actual (e->value.op.op1)
+	    || resolve_assumed_size_actual (e->value.op.op2))
+	return true;
+      break;
+
+    default:
+      break;
+    }
+  return false;
+}
+
 
 /* Resolve an actual argument list.  Most of the time, this is just
    resolving the expressions in the list.
@@ -1083,9 +1154,16 @@ resolve_function (gfc_expr * expr)
   const char *name;
   try t;
 
+  /* Switch off assumed size checking and do this again for certain kinds
+     of procedure, once the procedure itself is resolved.  */
+  need_full_assumed_size = 0;
+
   if (resolve_actual_arglist (expr->value.function.actual) == FAILURE)
     return FAILURE;
 
+  /* Resume assumed_size checking. */
+  need_full_assumed_size = 1;
+
 /* See if function is already resolved.  */
 
   if (expr->value.function.name != NULL)
@@ -1129,7 +1207,6 @@ resolve_function (gfc_expr * expr)
 	  || (expr->value.function.isym != NULL
 	      && expr->value.function.isym->elemental)))
     {
-
       /* The rank of an elemental is the rank of its array argument(s).  */
 
       for (arg = expr->value.function.actual; arg; arg = arg->next)
@@ -1140,6 +1217,31 @@ resolve_function (gfc_expr * expr)
 	      break;
 	    }
 	}
+
+      /* Being elemental, the last upper bound of an assumed size array
+	 argument must be present.  */
+      for (arg = expr->value.function.actual; arg; arg = arg->next)
+	{
+	  if (arg->expr != NULL
+		&& arg->expr->rank > 0
+		&& resolve_assumed_size_actual (arg->expr))
+	    return FAILURE;
+	}
+    }
+
+  else if (expr->value.function.actual != NULL
+      && expr->value.function.isym != NULL
+      && strcmp (expr->value.function.isym->name, "lbound"))
+    {
+      /* Array instrinsics must also have the last upper bound of an
+	 asumed size array argument.  */
+      for (arg = expr->value.function.actual; arg; arg = arg->next)
+	{
+	  if (arg->expr != NULL
+		&& arg->expr->rank > 0
+		&& resolve_assumed_size_actual (arg->expr))
+	    return FAILURE;
+	}
     }
 
   if (!pure_function (expr, &name))
@@ -1381,9 +1483,17 @@ resolve_call (gfc_code * c)
 {
   try t;
 
+  /* Switch off assumed size checking and do this again for certain kinds
+     of procedure, once the procedure itself is resolved.  */
+  need_full_assumed_size = 0;
+
   if (resolve_actual_arglist (c->ext.actual) == FAILURE)
     return FAILURE;
 
+  /* Resume assumed_size checking. */
+  need_full_assumed_size = 1;
+
+
   t = SUCCESS;
   if (c->resolved_sym == NULL)
     switch (procedure_kind (c->symtree->n.sym))
@@ -1404,6 +1514,21 @@ resolve_call (gfc_code * c)
 	gfc_internal_error ("resolve_subroutine(): bad function type");
       }
 
+  if (c->ext.actual != NULL
+      && c->symtree->n.sym->attr.elemental)
+    {
+      gfc_actual_arglist * a;
+      /* Being elemental, the last upper bound of an assumed size array
+	 argument must be present.  */
+      for (a = c->ext.actual; a; a = a->next)
+	{
+	  if (a->expr != NULL
+		&& a->expr->rank > 0
+		&& resolve_assumed_size_actual (a->expr))
+	    return FAILURE;
+	}
+    }
+
   if (t == SUCCESS)
     find_noncopying_intrinsics (c->resolved_sym, c->ext.actual);
   return t;
@@ -2330,6 +2455,9 @@ resolve_variable (gfc_expr * e)
       e->ts = sym->ts;
     }
 
+  if (check_assumed_size_reference (sym, e))
+    return FAILURE;
+
   return SUCCESS;
 }
 
@@ -4580,6 +4708,17 @@ resolve_symbol (gfc_symbol * sym)
 	}
       break;
 
+    case FL_DERIVED:
+      /* Add derived type to the derived type list.  */
+      {
+	gfc_dt_list * dt_list;
+	dt_list = gfc_get_dt_list ();
+	dt_list->next = sym->ns->derived_types;
+	dt_list->derived = sym;
+	sym->ns->derived_types = dt_list;
+      }
+      break;
+
     default:
 
       /* An external symbol falls through to here if it is not referenced.  */