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, 216 insertions, 98 deletions

diff --git a/gcc/fortran/io.c b/gcc/fortran/io.c
index 23c1cb2..7ca000a 100644
--- a/gcc/fortran/io.c
+++ b/gcc/fortran/io.c
@@ -816,6 +816,13 @@ gfc_match_format (void)
   gfc_expr *e;
   locus start;
 
+  if (gfc_current_ns->proc_name
+	&& gfc_current_ns->proc_name->attr.flavor == FL_MODULE)
+    {
+      gfc_error ("Format statement in module main block at %C.");
+      return MATCH_ERROR;
+    }
+
   if (gfc_statement_label == NULL)
     {
       gfc_error ("Missing format label at %C");
@@ -1056,8 +1063,16 @@ resolve_tag (const io_tag * tag, gfc_expr * e)
 
       if (tag == &tag_iostat && e->ts.kind != gfc_default_integer_kind)
 	{
-	  if (gfc_notify_std (GFC_STD_F2003, "Fortran 2003: Non-default "
-			      "integer kind in IOSTAT tag at %L",
+	  if (gfc_notify_std (GFC_STD_GNU, "Fortran 95 requires default "
+			      "INTEGER in IOSTAT tag at %L",
+			      &e->where) == FAILURE)
+	    return FAILURE;
+	}
+
+      if (tag == &tag_size && e->ts.kind != gfc_default_integer_kind)
+	{
+	  if (gfc_notify_std (GFC_STD_GNU, "Fortran 95 requires default "
+			      "INTEGER in SIZE tag at %L",
 			      &e->where) == FAILURE)
 	    return FAILURE;
 	}
@@ -1728,6 +1743,8 @@ match_dt_element (io_kind k, gfc_dt * dt)
   if (m != MATCH_NO)
     return m;
   m = match_ltag (&tag_err, &dt->err);
+  if (m == MATCH_YES)
+    dt->err_where = gfc_current_locus;
   if (m != MATCH_NO)
     return m;
   m = match_etag (&tag_advance, &dt->advance);
@@ -1807,7 +1824,6 @@ gfc_resolve_dt (gfc_dt * dt)
       return FAILURE;
     }
 
-  /* Sanity checks on data transfer statements.  */
   if (e->ts.type == BT_CHARACTER)
     {
       if (gfc_has_vector_index (e))
@@ -1816,85 +1832,50 @@ gfc_resolve_dt (gfc_dt * dt)
 		     &e->where);
 	  return FAILURE;
 	}
+    }
 
-      if (dt->rec != NULL)
-	{
-	  gfc_error ("REC tag at %L is incompatible with internal file",
-		     &dt->rec->where);
-	  return FAILURE;
-	}
-
-      if (dt->namelist != NULL)
-	{
-	  gfc_error ("Internal file at %L is incompatible with namelist",
-		     &dt->io_unit->where);
-	  return FAILURE;
-	}
-
-      if (dt->advance != NULL)
-	{
-	  gfc_error ("ADVANCE tag at %L is incompatible with internal file",
-		     &dt->advance->where);
-	  return FAILURE;
-	}
+  if (e->rank && e->ts.type != BT_CHARACTER)
+    {
+      gfc_error ("External IO UNIT cannot be an array at %L", &e->where);
+      return FAILURE;
     }
 
-  if (dt->rec != NULL)
+  if (dt->err)
     {
-      if (dt->end != NULL)
+      if (gfc_reference_st_label (dt->err, ST_LABEL_TARGET) == FAILURE)
+	return FAILURE;
+      if (dt->err->defined == ST_LABEL_UNKNOWN)
 	{
-	  gfc_error ("REC tag at %L is incompatible with END tag",
-		     &dt->rec->where);
+	  gfc_error ("ERR tag label %d at %L not defined",
+		      dt->err->value, &dt->err_where);
 	  return FAILURE;
 	}
+    }
 
-      if (dt->format_label == &format_asterisk)
+  if (dt->end)
+    {
+      if (gfc_reference_st_label (dt->end, ST_LABEL_TARGET) == FAILURE)
+	return FAILURE;
+      if (dt->end->defined == ST_LABEL_UNKNOWN)
 	{
-	  gfc_error
-	    ("END tag at %L is incompatible with list directed format (*)",
-	     &dt->end_where);
+	  gfc_error ("END tag label %d at %L not defined",
+		      dt->end->value, &dt->end_where);
 	  return FAILURE;
 	}
+    }
 
-      if (dt->namelist != NULL)
+  if (dt->eor)
+    {
+      if (gfc_reference_st_label (dt->eor, ST_LABEL_TARGET) == FAILURE)
+	return FAILURE;
+      if (dt->eor->defined == ST_LABEL_UNKNOWN)
 	{
-	  gfc_error ("REC tag at %L is incompatible with namelist",
-		     &dt->rec->where);
+	  gfc_error ("EOR tag label %d at %L not defined",
+		      dt->eor->value, &dt->eor_where);
 	  return FAILURE;
 	}
     }
 
-  if (dt->advance != NULL && dt->format_label == &format_asterisk)
-    {
-      gfc_error ("ADVANCE tag at %L is incompatible with list directed "
-		 "format (*)", &dt->advance->where);
-      return FAILURE;
-    }
-
-  if (dt->eor != 0 && dt->advance == NULL)
-    {
-      gfc_error ("EOR tag at %L requires an ADVANCE tag", &dt->eor_where);
-      return FAILURE;
-    }
-
-  if (dt->size != NULL && dt->advance == NULL)
-    {
-      gfc_error ("SIZE tag at %L requires an ADVANCE tag", &dt->size->where);
-      return FAILURE;
-    }
-
-  /* TODO: Make sure the ADVANCE tag is 'yes' or 'no' if it is a string
-     constant.  */
-
-  if (gfc_reference_st_label (dt->err, ST_LABEL_TARGET) == FAILURE)
-    return FAILURE;
-
-  if (gfc_reference_st_label (dt->end, ST_LABEL_TARGET) == FAILURE)
-    return FAILURE;
-
-  if (gfc_reference_st_label (dt->eor, ST_LABEL_TARGET) == FAILURE)
-    return FAILURE;
-
   /* Check the format label actually exists.  */
   if (dt->format_label && dt->format_label != &format_asterisk
       && dt->format_label->defined == ST_LABEL_UNKNOWN)
@@ -2181,6 +2162,165 @@ terminate_io (gfc_code * io_code)
 }
 
 
+/* Check the constraints for a data transfer statement.  The majority of the
+   constraints appearing in 9.4 of the standard appear here.  Some are handled
+   in resolve_tag and others in gfc_resolve_dt.  */
+
+static match
+check_io_constraints (io_kind k, gfc_dt *dt, gfc_code * io_code, locus * spec_end)
+{
+#define io_constraint(condition,msg,arg)\
+if (condition) \
+  {\
+    gfc_error(msg,arg);\
+    m = MATCH_ERROR;\
+  }
+
+  match m;
+  gfc_expr * expr;
+  gfc_symbol * sym = NULL;
+
+  m = MATCH_YES;
+
+  expr = dt->io_unit;
+  if (expr && expr->expr_type == EXPR_VARIABLE
+	&& expr->ts.type == BT_CHARACTER)
+    {
+      sym = expr->symtree->n.sym;
+
+      io_constraint (k == M_WRITE && sym->attr.intent == INTENT_IN,
+		     "Internal file at %L must not be INTENT(IN)",
+		     &expr->where);
+
+      io_constraint (gfc_has_vector_index (dt->io_unit),
+		     "Internal file incompatible with vector subscript at %L",
+		     &expr->where);
+
+      io_constraint (dt->rec != NULL,
+		     "REC tag at %L is incompatible with internal file",
+		     &dt->rec->where);
+
+      io_constraint (dt->namelist != NULL,
+		     "Internal file at %L is incompatible with namelist",
+		     &expr->where);
+
+      io_constraint (dt->advance != NULL,
+		     "ADVANCE tag at %L is incompatible with internal file",
+		     &dt->advance->where);
+    }
+
+  if (expr && expr->ts.type != BT_CHARACTER)
+    {
+
+      io_constraint (gfc_pure (NULL)
+		       && (k == M_READ || k == M_WRITE),
+		     "IO UNIT in %s statement at %C must be "
+		     "an internal file in a PURE procedure",
+		     io_kind_name (k));
+    }
+
+
+  if (k != M_READ)
+    {
+      io_constraint (dt->end,
+		     "END tag not allowed with output at %L",
+		     &dt->end_where);
+
+      io_constraint (dt->eor,
+		     "EOR tag not allowed with output at %L",
+		     &dt->eor_where);
+
+      io_constraint (k != M_READ && dt->size,
+		     "SIZE=specifier not allowed with output at %L",
+		     &dt->size->where);
+    }
+  else
+    {
+      io_constraint (dt->size && dt->advance == NULL,
+		     "SIZE tag at %L requires an ADVANCE tag",
+		     &dt->size->where);
+
+      io_constraint (dt->eor && dt->advance == NULL,
+		     "EOR tag at %L requires an ADVANCE tag",
+		     &dt->eor_where);
+    }
+
+
+
+  if (dt->namelist)
+    {
+      io_constraint (io_code && dt->namelist,
+		     "NAMELIST cannot be followed by IO-list at %L",
+		     &io_code->loc);
+
+      io_constraint (dt->format_expr,
+		     "IO spec-list cannot contain both NAMELIST group name "
+		     "and format specification at %L.",
+		     &dt->format_expr->where);
+
+      io_constraint (dt->format_label,
+		     "IO spec-list cannot contain both NAMELIST group name "
+		     "and format label at %L", spec_end);
+
+      io_constraint (dt->rec,
+		     "NAMELIST IO is not allowed with a REC=specifier "
+		     "at %L.", &dt->rec->where);
+
+      io_constraint (dt->advance,
+		     "NAMELIST IO is not allowed with a ADVANCE=specifier "
+		     "at %L.", &dt->advance->where);
+    }
+
+  if (dt->rec)
+    {
+      io_constraint (dt->end,
+		     "An END tag is not allowed with a "
+		     "REC=specifier at %L.", &dt->end_where);
+
+
+      io_constraint (dt->format_label == &format_asterisk,
+		     "FMT=* is not allowed with a REC=specifier "
+		     "at %L.", spec_end);
+    }
+
+  if (dt->advance)
+    {
+      const char * advance;
+      int not_yes, not_no;
+      expr = dt->advance;
+      advance = expr->value.character.string;
+
+      io_constraint (dt->format_label == &format_asterisk,
+		     "List directed format(*) is not allowed with a "
+		     "ADVANCE=specifier at %L.", &expr->where);
+
+      not_no = strncasecmp (advance, "no", 2) != 0;
+      not_yes = strncasecmp (advance, "yes", 2) != 0;
+
+      io_constraint (expr->expr_type == EXPR_CONSTANT
+		       && not_no && not_yes,
+		     "ADVANCE=specifier at %L must have value = "
+		     "YES or NO.", &expr->where);
+
+      io_constraint (dt->size && expr->expr_type == EXPR_CONSTANT
+		       && not_no && k == M_READ,
+		     "SIZE tag at %L requires an ADVANCE = 'NO'",
+		     &dt->size->where);
+
+      io_constraint (dt->eor && expr->expr_type == EXPR_CONSTANT 
+		       && not_no && k == M_READ,
+		     "EOR tag at %L requires an ADVANCE = 'NO'",
+		     &dt->eor_where);      
+    }
+
+  expr = dt->format_expr;
+  if (expr != NULL && expr->expr_type == EXPR_CONSTANT)
+    check_format_string (expr);
+
+  return m;
+}
+#undef io_constraint
+
 /* Match a READ, WRITE or PRINT statement.  */
 
 static match
@@ -2189,12 +2329,13 @@ match_io (io_kind k)
   char name[GFC_MAX_SYMBOL_LEN + 1];
   gfc_code *io_code;
   gfc_symbol *sym;
-  gfc_expr *expr;
   int comma_flag, c;
   locus where;
+  locus spec_end;
   gfc_dt *dt;
   match m;
 
+  where = gfc_current_locus;
   comma_flag = 0;
   current_dt = dt = gfc_getmem (sizeof (gfc_dt));
   if (gfc_match_char ('(') == MATCH_NO)
@@ -2217,12 +2358,6 @@ match_io (io_kind k)
 		      m = MATCH_ERROR;
 		      goto cleanup;
 		    }
-		  if (gfc_match_eos () == MATCH_NO)
-		    {
-		      gfc_error ("Namelist followed by I/O list at %C");
-		      m = MATCH_ERROR;
-		      goto cleanup;
-		    }
 
 		  dt->io_unit = default_unit (k);
 		  dt->namelist = sym;
@@ -2321,6 +2456,10 @@ loop:
     }
 
 get_io_list:
+
+  /* Used in check_io_constraints, where no locus is available.  */
+  spec_end = gfc_current_locus;
+
   /* Optional leading comma (non-standard).  */
   if (!comma_flag
       && gfc_match_char (',') == MATCH_YES
@@ -2346,33 +2485,12 @@ get_io_list:
 	goto syntax;
     }
 
-  /* A full IO statement has been matched.  */
-  if (dt->io_unit->expr_type == EXPR_VARIABLE
-      && k == M_WRITE
-      && dt->io_unit->ts.type == BT_CHARACTER
-      && dt->io_unit->symtree->n.sym->attr.intent == INTENT_IN)
-    {
-      gfc_error ("Internal file '%s' at %L is INTENT(IN)",
-		 dt->io_unit->symtree->n.sym->name, &dt->io_unit->where);
-      m = MATCH_ERROR;
-      goto cleanup;
-    }
-
-  expr = dt->format_expr;
+  /* A full IO statement has been matched.  Check the constraints.  spec_end is
+     supplied for cases where no locus is supplied.  */
+  m = check_io_constraints (k, dt, io_code, &spec_end);
 
-  if (expr != NULL && expr->expr_type == EXPR_CONSTANT)
-    check_format_string (expr);
-
-  if (gfc_pure (NULL)
-      && (k == M_READ || k == M_WRITE)
-      && dt->io_unit->ts.type != BT_CHARACTER)
-    {
-      gfc_error
-	("io-unit in %s statement at %C must be an internal file in a "
-	 "PURE procedure", io_kind_name (k));
-      m = MATCH_ERROR;
-      goto cleanup;
-    }
+  if (m == MATCH_ERROR)
+    goto cleanup;
 
   new_st.op = (k == M_READ) ? EXEC_READ : EXEC_WRITE;
   new_st.ext.dt = dt;