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

8 files changed, 590 insertions, 125 deletions

diff --git a/gcc/fortran/ChangeLog b/gcc/fortran/ChangeLog
index 8fb7318..31f1f82 100644
--- a/gcc/fortran/ChangeLog
+++ b/gcc/fortran/ChangeLog
@@ -1,3 +1,82 @@
+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-21  Erik Edelmann  <eedelman@gcc.gnu.org>
 
 	PR fortran/25423
diff --git a/gcc/fortran/gfortran.h b/gcc/fortran/gfortran.h
index 7d0c725..475b0ca 100644
--- a/gcc/fortran/gfortran.h
+++ b/gcc/fortran/gfortran.h
@@ -833,6 +833,16 @@ typedef struct gfc_symtree
 }
 gfc_symtree;
 
+/* A linked list of derived types in the namespace.  */
+typedef struct gfc_dt_list
+{
+  struct gfc_symbol *derived;
+  struct gfc_dt_list *next;
+}
+gfc_dt_list;
+
+#define gfc_get_dt_list() gfc_getmem(sizeof(gfc_dt_list))
+
 
 /* A namespace describes the contents of procedure, module or
    interface block.  */
@@ -892,6 +902,9 @@ typedef struct gfc_namespace
   /* A list of all alternate entry points to this procedure (or NULL).  */
   gfc_entry_list *entries;
 
+  /* A list of all derived types in this procedure (or NULL).  */
+  gfc_dt_list *derived_types;
+
   /* Set to 1 if namespace is a BLOCK DATA program unit.  */
   int is_block_data;
 }
@@ -1356,7 +1369,7 @@ typedef struct
   gfc_st_label *format_label;
   gfc_st_label *err, *end, *eor;
 
-  locus eor_where, end_where;
+  locus eor_where, end_where, err_where;
 }
 gfc_dt;
 
@@ -1895,6 +1908,7 @@ int gfc_is_compile_time_shape (gfc_array_spec *);
 
 /* interface.c -- FIXME: some of these should be in symbol.c */
 void gfc_free_interface (gfc_interface *);
+int gfc_compare_derived_types (gfc_symbol *, gfc_symbol *);
 int gfc_compare_types (gfc_typespec *, gfc_typespec *);
 void gfc_check_interfaces (gfc_namespace *);
 void gfc_procedure_use (gfc_symbol *, gfc_actual_arglist **, locus *);
diff --git a/gcc/fortran/interface.c b/gcc/fortran/interface.c
index 5dc6944..b58fb83 100644
--- a/gcc/fortran/interface.c
+++ b/gcc/fortran/interface.c
@@ -320,43 +320,39 @@ gfc_match_end_interface (void)
 }
 
 
-/* Compare two typespecs, recursively if necessary.  */
+/* Compare two derived types using the criteria in 4.4.2 of the standard,
+   recursing through gfc_compare_types for the components.  */
 
 int
-gfc_compare_types (gfc_typespec * ts1, gfc_typespec * ts2)
+gfc_compare_derived_types (gfc_symbol * derived1, gfc_symbol * derived2)
 {
   gfc_component *dt1, *dt2;
 
-  if (ts1->type != ts2->type)
-    return 0;
-  if (ts1->type != BT_DERIVED)
-    return (ts1->kind == ts2->kind);
-
-  /* Compare derived types.  */
-  if (ts1->derived == ts2->derived)
-    return 1;
-
   /* Special case for comparing derived types across namespaces.  If the
      true names and module names are the same and the module name is
      nonnull, then they are equal.  */
-  if (strcmp (ts1->derived->name, ts2->derived->name) == 0
-      && ((ts1->derived->module == NULL && ts2->derived->module == NULL)
-	  || (ts1->derived != NULL && ts2->derived != NULL
-	      && strcmp (ts1->derived->module, ts2->derived->module) == 0)))
+  if (strcmp (derived1->name, derived2->name) == 0
+	&& derived1 != NULL && derived2 != NULL
+	&& derived1->module != NULL && derived2->module != NULL
+	&& strcmp (derived1->module, derived2->module) == 0)
     return 1;
 
   /* Compare type via the rules of the standard.  Both types must have
      the SEQUENCE attribute to be equal.  */
 
-  if (strcmp (ts1->derived->name, ts2->derived->name))
+  if (strcmp (derived1->name, derived2->name))
     return 0;
 
-  dt1 = ts1->derived->components;
-  dt2 = ts2->derived->components;
+  if (derived1->component_access == ACCESS_PRIVATE
+	|| derived2->component_access == ACCESS_PRIVATE)
+    return 0;
 
-  if (ts1->derived->attr.sequence == 0 || ts2->derived->attr.sequence == 0)
+  if (derived1->attr.sequence == 0 || derived2->attr.sequence == 0)
     return 0;
 
+  dt1 = derived1->components;
+  dt2 = derived2->components;
+
   /* Since subtypes of SEQUENCE types must be SEQUENCE types as well, a
      simple test can speed things up.  Otherwise, lots of things have to
      match.  */
@@ -389,6 +385,24 @@ gfc_compare_types (gfc_typespec * ts1, gfc_typespec * ts2)
   return 1;
 }
 
+/* Compare two typespecs, recursively if necessary.  */
+
+int
+gfc_compare_types (gfc_typespec * ts1, gfc_typespec * ts2)
+{
+
+  if (ts1->type != ts2->type)
+    return 0;
+  if (ts1->type != BT_DERIVED)
+    return (ts1->kind == ts2->kind);
+
+  /* Compare derived types.  */
+  if (ts1->derived == ts2->derived)
+    return 1;
+
+  return gfc_compare_derived_types (ts1->derived ,ts2->derived);
+}
+
 
 /* Given two symbols that are formal arguments, compare their ranks
    and types.  Returns nonzero if they have the same rank and type,
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;
diff --git a/gcc/fortran/match.c b/gcc/fortran/match.c
index 501a091..e28127b 100644
--- a/gcc/fortran/match.c
+++ b/gcc/fortran/match.c
@@ -2503,6 +2503,14 @@ gfc_match_namelist (void)
 	  return MATCH_ERROR;
 	}
 
+      if (group_name->attr.flavor == FL_NAMELIST
+	    && group_name->attr.use_assoc
+	    && gfc_notify_std (GFC_STD_GNU, "Namelist group name '%s' "
+			       "at %C already is USE associated and can"
+			       "not be respecified.", group_name->name)
+		 == FAILURE)
+	return MATCH_ERROR;
+
       if (group_name->attr.flavor != FL_NAMELIST
 	  && gfc_add_flavor (&group_name->attr, FL_NAMELIST,
 			     group_name->name, NULL) == FAILURE)
@@ -2520,6 +2528,21 @@ gfc_match_namelist (void)
 	      && gfc_add_in_namelist (&sym->attr, sym->name, NULL) == FAILURE)
 	    goto error;
 
+	  /* Use gfc_error_check here, rather than goto error, so that this
+	     these are the only errors for the next two lines.  */
+	  if (sym->as && sym->as->type == AS_ASSUMED_SIZE)
+	    {
+	      gfc_error ("Assumed size array '%s' in namelist '%s'at "
+		         "%C is not allowed.", sym->name, group_name->name);
+	      gfc_error_check ();
+	    }
+
+	  if (sym->as && sym->as->type == AS_ASSUMED_SHAPE
+		&& gfc_notify_std (GFC_STD_GNU, "Assumed shape array '%s' in "
+				   "namelist '%s' at %C is an extension.",
+				   sym->name, group_name->name) == FAILURE)
+	    gfc_error_check ();
+
 	  nl = gfc_get_namelist ();
 	  nl->sym = sym;
 
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.  */
diff --git a/gcc/fortran/symbol.c b/gcc/fortran/symbol.c
index 20fb747..bda1c1d 100644
--- a/gcc/fortran/symbol.c
+++ b/gcc/fortran/symbol.c
@@ -2307,6 +2307,21 @@ free_sym_tree (gfc_symtree * sym_tree)
 }
 
 
+/* Free a derived type list.  */
+
+static void
+gfc_free_dt_list (gfc_dt_list * dt)
+{
+  gfc_dt_list *n;
+
+  for (; dt; dt = n)
+    {
+      n = dt->next;
+      gfc_free (dt);
+    }
+}
+
+
 /* Free a namespace structure and everything below it.  Interface
    lists associated with intrinsic operators are not freed.  These are
    taken care of when a specific name is freed.  */
@@ -2343,6 +2358,8 @@ gfc_free_namespace (gfc_namespace * ns)
 
   gfc_free_equiv (ns->equiv);
 
+  gfc_free_dt_list (ns->derived_types);
+
   for (i = GFC_INTRINSIC_BEGIN; i != GFC_INTRINSIC_END; i++)
     gfc_free_interface (ns->operator[i]);
 
diff --git a/gcc/fortran/trans-types.c b/gcc/fortran/trans-types.c
index 6aaf81a..4e6b74e 100644
--- a/gcc/fortran/trans-types.c
+++ b/gcc/fortran/trans-types.c
@@ -1395,13 +1395,44 @@ gfc_add_field_to_struct (tree *fieldlist, tree context,
 }
 
 
-/* Build a tree node for a derived type.  */
+/* Copy the backend_decl and component backend_decls if
+   the two derived type symbols are "equal", as described
+   in 4.4.2 and resolved by gfc_compare_derived_types.  */
+
+static int
+copy_dt_decls_ifequal (gfc_symbol *from, gfc_symbol *to)
+{
+  gfc_component *to_cm;
+  gfc_component *from_cm;
+
+  if (from->backend_decl == NULL
+	|| !gfc_compare_derived_types (from, to))
+    return 0;
+
+  to->backend_decl = from->backend_decl;
+
+  to_cm = to->components;
+  from_cm = from->components;
+
+  for (; to_cm; to_cm = to_cm->next, from_cm = from_cm->next)
+    to_cm->backend_decl = from_cm->backend_decl;
+
+  return 1;
+}
+
+
+/* Build a tree node for a derived type.  If there are equal
+   derived types, with different local names, these are built
+   at the same time.  If an equal derived type has been built
+   in a parent namespace, this is used.  */
 
 static tree
 gfc_get_derived_type (gfc_symbol * derived)
 {
   tree typenode, field, field_type, fieldlist;
   gfc_component *c;
+  gfc_dt_list *dt;
+  gfc_namespace * ns;
 
   gcc_assert (derived && derived->attr.flavor == FL_DERIVED);
 
@@ -1417,6 +1448,29 @@ gfc_get_derived_type (gfc_symbol * derived)
     }
   else
     {
+      /* In a module, if an equal derived type is already available in the
+	 specification block, use its backend declaration and those of its
+	 components, rather than building anew so that potential dummy and
+	 actual arguments use the same TREE_TYPE.  Non-module structures,
+	 need to be built, if found, because the order of visits to the 
+	 namespaces is different.  */
+
+      for (ns = derived->ns->parent; ns; ns = ns->parent)
+	{
+	  for (dt = ns->derived_types; dt; dt = dt->next)
+	    {
+	      if (derived->module == NULL
+		    && dt->derived->backend_decl == NULL
+		    && gfc_compare_derived_types (dt->derived, derived))
+		gfc_get_derived_type (dt->derived);
+
+	      if (copy_dt_decls_ifequal (dt->derived, derived))
+		break;
+	    }
+	  if (derived->backend_decl)
+	    goto other_equal_dts;
+	}
+
       /* We see this derived type first time, so build the type node.  */
       typenode = make_node (RECORD_TYPE);
       TYPE_NAME (typenode) = get_identifier (derived->name);
@@ -1495,9 +1549,16 @@ gfc_get_derived_type (gfc_symbol * derived)
 
   derived->backend_decl = typenode;
 
-  return typenode;
+other_equal_dts:
+  /* Add this backend_decl to all the other, equal derived types and
+     their components in this namespace.  */
+  for (dt = derived->ns->derived_types; dt; dt = dt->next)
+    copy_dt_decls_ifequal (derived, dt->derived);
+
+  return derived->backend_decl;
 }
-
+
+
 int
 gfc_return_by_reference (gfc_symbol * sym)
 {