trans-expr.c (conv_parent_component_references): New function to build missing parent references.

2008-07-29  Paul Thomas  <pault@gcc.gnu.org>

fortran/	
	* trans-expr.c (conv_parent_component_references): New function
	to build missing parent references.
	(gfc_conv_variable): Call it
	* symbol.c (gfc_add_component): Check that component name in a
	derived type extension does not appear in parent.
	(gfc_find_component): For a derived type extension, check if
	the component appears in the parent derived type by calling
	self. Separate errors for private components and private types.
	* decl.c (match_data_constant): Add extra arg to call to
	gfc_match_structure_constructor.
	(check_extended_derived_type): New function to check that a
	parent derived type exists and that it is OK for exension.
	(gfc_get_type_attr_spec): Add extra argument 'name' and return
	it if extends is specified.
	(gfc_match_derived_decl): Match derived type extension and
	build a first component of the parent derived type if OK. Add
	the f2k namespace if not present.
	* gfortran.h : Add the extension attribute.
	* module.c : Handle attribute 'extension'.
	* match.h : Modify prototypes for gfc_get_type_attr_spec and
	gfc_match_structure_constructor.
	* primary.c (build_actual_constructor): New function extracted
	from gfc_match_structure_constructor and modified to call self
	iteratively to build derived type extensions, when f2k named
	components are used.
	(gfc_match_structure_constructor): Do not throw error for too
	many components if a parent type is being handled. Use
	gfc_find_component to generate errors for non-existent or
	private components.  Iteratively call self for derived type
	extensions so that parent constructor is built.  If extension
	and components left over, throw error.
	(gfc_match_rvalue): Add extra arg to call to
	gfc_match_structure_constructor.
	* trans-array.c (gfc_conv_resolve_dependencies): If lhs and rhs
	are the same symbol, aliassing does not matter.
testsuite/
	* gfortran.dg/extends_1.f03: New test.
	* gfortran.dg/extends_2.f03: New test.
	* gfortran.dg/extends_3.f03: New test.
	* gfortran.dg/extends_4.f03: New test.
	* gfortran.dg/extends_5.f03: New test.
	* gfortran.dg/extends_6.f03: New test.
	* gfortran.dg/private_type_6.f90: Modify error message.
	* gfortran.dg/structure_constructor_7.f03: Modify error message.
	* gfortran.dg/structure_constructor_8.f03: Modify error message.

From-SVN: r138275

gcc/fortran/ChangeLog

+2008-07-29  Paul Thomas  <pault@gcc.gnu.org>
+
+	* trans-expr.c (conv_parent_component_references): New function
+	to build missing parent references.
+	(gfc_conv_variable): Call it
+	* symbol.c (gfc_add_component): Check that component name in a
+	derived type extension does not appear in parent.
+	(gfc_find_component): For a derived type extension, check if
+	the component appears in the parent derived type by calling
+	self. Separate errors for private components and private types.
+	* decl.c (match_data_constant): Add extra arg to call to
+	gfc_match_structure_constructor.
+	(check_extended_derived_type): New function to check that a
+	parent derived type exists and that it is OK for exension.
+	(gfc_get_type_attr_spec): Add extra argument 'name' and return
+	it if extends is specified.
+	(gfc_match_derived_decl): Match derived type extension and
+	build a first component of the parent derived type if OK. Add
+	the f2k namespace if not present.
+	* gfortran.h : Add the extension attribute.
+	* module.c : Handle attribute 'extension'.
+	* match.h : Modify prototypes for gfc_get_type_attr_spec and
+	gfc_match_structure_constructor.
+	* primary.c (build_actual_constructor): New function extracted
+	from gfc_match_structure_constructor and modified to call self
+	iteratively to build derived type extensions, when f2k named
+	components are used.
+	(gfc_match_structure_constructor): Do not throw error for too
+	many components if a parent type is being handled. Use
+	gfc_find_component to generate errors for non-existent or
+	private components.  Iteratively call self for derived type
+	extensions so that parent constructor is built.  If extension
+	and components left over, throw error.
+	(gfc_match_rvalue): Add extra arg to call to
+	gfc_match_structure_constructor.
+
+	* trans-array.c (gfc_conv_resolve_dependencies): If lhs and rhs
+	are the same symbol, aliassing does not matter.
+
 2008-07-29  Jan Hubicka  <jh@suse.cz>
 
 	* options.c (gfc_post_options): Do not set flag_no_inline.

gcc/fortran/decl.c

@@ -367,7 +367,7 @@ match_data_constant (gfc_expr **result)
       return MATCH_ERROR;
     }
   else if (sym->attr.flavor == FL_DERIVED)
-    return gfc_match_structure_constructor (sym, result);
+    return gfc_match_structure_constructor (sym, result, false);
 
   /* Check to see if the value is an initialization array expression.  */
   if (sym->value->expr_type == EXPR_ARRAY)
@@ -6250,6 +6250,49 @@ syntax:
 }
 
 
+/* Check a derived type that is being extended.  */
+static gfc_symbol*
+check_extended_derived_type (char *name)
+{
+  gfc_symbol *extended;
+
+  if (gfc_find_symbol (name, gfc_current_ns, 1, &extended))
+    {
+      gfc_error ("Ambiguous symbol in TYPE definition at %C");
+      return NULL;
+    }
+
+  if (!extended)
+    {
+      gfc_error ("No such symbol in TYPE definition at %C");
+      return NULL;
+    }
+
+  if (extended->attr.flavor != FL_DERIVED)
+    {
+      gfc_error ("'%s' in EXTENDS expression at %C is not a "
+		 "derived type", name);
+      return NULL;
+    }
+
+  if (extended->attr.is_bind_c)
+    {
+      gfc_error ("'%s' cannot be extended at %C because it "
+		 "is BIND(C)", extended->name);
+      return NULL;
+    }
+
+  if (extended->attr.sequence)
+    {
+      gfc_error ("'%s' cannot be extended at %C because it "
+		 "is a SEQUENCE type", extended->name);
+      return NULL;
+    }
+
+  return extended;
+}
+
+
 /* Match the optional attribute specifiers for a type declaration.
    Return MATCH_ERROR if an error is encountered in one of the handled
    attributes (public, private, bind(c)), MATCH_NO if what's found is
@@ -6257,7 +6300,7 @@ syntax:
    checking on attribute conflicts needs to be done.  */
 
 match
-gfc_get_type_attr_spec (symbol_attribute *attr)
+gfc_get_type_attr_spec (symbol_attribute *attr, char *name)
 {
   /* See if the derived type is marked as private.  */
   if (gfc_match (" , private") == MATCH_YES)
@@ -6295,6 +6338,12 @@ gfc_get_type_attr_spec (symbol_attribute *attr)
 
       /* TODO: attr conflicts need to be checked, probably in symbol.c.  */
     }
+  else if (name && gfc_match(" , extends ( %n )", name) == MATCH_YES)
+    {
+      if (gfc_notify_std (GFC_STD_F2003, "Fortran 2003: derived type "
+	    "extended at %C") == FAILURE)
+	return MATCH_ERROR;
+    }
   else
     return MATCH_NO;
 
@@ -6311,8 +6360,10 @@ match
 gfc_match_derived_decl (void)
 {
   char name[GFC_MAX_SYMBOL_LEN + 1];
+  char parent[GFC_MAX_SYMBOL_LEN + 1];
   symbol_attribute attr;
   gfc_symbol *sym;
+  gfc_symbol *extended;
   match m;
   match is_type_attr_spec = MATCH_NO;
   bool seen_attr = false;
@@ -6320,17 +6371,27 @@ gfc_match_derived_decl (void)
   if (gfc_current_state () == COMP_DERIVED)
     return MATCH_NO;
 
+  name[0] = '\0';
+  parent[0] = '\0';
   gfc_clear_attr (&attr);
+  extended = NULL;
 
   do
     {
-      is_type_attr_spec = gfc_get_type_attr_spec (&attr);
+      is_type_attr_spec = gfc_get_type_attr_spec (&attr, parent);
       if (is_type_attr_spec == MATCH_ERROR)
 	return MATCH_ERROR;
       if (is_type_attr_spec == MATCH_YES)
 	seen_attr = true;
     } while (is_type_attr_spec == MATCH_YES);
 
+  /* Deal with derived type extensions.  */
+  if (parent[0])
+    extended = check_extended_derived_type (parent);
+
+  if (parent[0] && !extended)
+    return MATCH_ERROR;
+
   if (gfc_match (" ::") != MATCH_YES && seen_attr)
     {
       gfc_error ("Expected :: in TYPE definition at %C");
@@ -6383,10 +6444,34 @@ gfc_match_derived_decl (void)
   if (attr.is_bind_c != 0)
     sym->attr.is_bind_c = attr.is_bind_c;
 
+
   /* Construct the f2k_derived namespace if it is not yet there.  */
   if (!sym->f2k_derived)
     sym->f2k_derived = gfc_get_namespace (NULL, 0);
 
+  
+  if (extended && !sym->components)
+    {
+      gfc_component *p;
+      gfc_symtree *st;
+
+      /* Add the extended derived type as the first component.  */
+      gfc_add_component (sym, parent, &p);
+      sym->attr.extension = 1;
+      extended->refs++;
+      gfc_set_sym_referenced (extended);
+
+      p->ts.type = BT_DERIVED;
+      p->ts.derived = extended;
+      p->initializer = gfc_default_initializer (&p->ts);
+
+      /* Provide the links between the extended type and its extension.  */
+      if (!extended->f2k_derived)
+	extended->f2k_derived = gfc_get_namespace (NULL, 0);
+      st = gfc_new_symtree (&extended->f2k_derived->sym_root, sym->name);
+      st->n.sym = sym;
+    }
+
   gfc_new_block = sym;
 
   return MATCH_YES;

gcc/fortran/gfortran.h

@@ -638,6 +638,7 @@ typedef struct
   unsigned untyped:1;           /* No implicit type could be found.  */
 
   unsigned is_bind_c:1;		/* say if is bound to C */
+  unsigned extension:1;		/* extends a derived type */
 
   /* These flags are both in the typespec and attribute.  The attribute
      list is what gets read from/written to a module file.  The typespec
@@ -1016,9 +1017,6 @@ typedef struct gfc_symbol
 
   gfc_formal_arglist *formal;
   struct gfc_namespace *formal_ns;
-
-  /* The namespace containing type-associated procedure symbols.  */
-  /* TODO: Make this union with formal?  */
   struct gfc_namespace *f2k_derived;
 
   struct gfc_expr *value;	/* Parameter/Initializer value */

gcc/fortran/match.h

@@ -182,10 +182,10 @@ gfc_try get_bind_c_idents (void);
 match gfc_match_bind_c_stmt (void);
 match gfc_match_suffix (gfc_symbol *, gfc_symbol **);
 match gfc_match_bind_c (gfc_symbol *, bool);
-match gfc_get_type_attr_spec (symbol_attribute *);
+match gfc_get_type_attr_spec (symbol_attribute *, char*);
 
 /* primary.c.  */
-match gfc_match_structure_constructor (gfc_symbol *, gfc_expr **);
+match gfc_match_structure_constructor (gfc_symbol *, gfc_expr **, bool);
 match gfc_match_variable (gfc_expr **, int);
 match gfc_match_equiv_variable (gfc_expr **);
 match gfc_match_actual_arglist (int, gfc_actual_arglist **);

gcc/fortran/module.c

@@ -1648,7 +1648,8 @@ typedef enum
   AB_ELEMENTAL, AB_PURE, AB_RECURSIVE, AB_GENERIC, AB_ALWAYS_EXPLICIT,
   AB_CRAY_POINTER, AB_CRAY_POINTEE, AB_THREADPRIVATE, AB_ALLOC_COMP,
   AB_POINTER_COMP, AB_PRIVATE_COMP, AB_VALUE, AB_VOLATILE, AB_PROTECTED,
-  AB_IS_BIND_C, AB_IS_C_INTEROP, AB_IS_ISO_C, AB_ABSTRACT, AB_ZERO_COMP
+  AB_IS_BIND_C, AB_IS_C_INTEROP, AB_IS_ISO_C, AB_ABSTRACT, AB_ZERO_COMP,
+  AB_EXTENSION
 }
 ab_attribute;
 
@@ -1688,6 +1689,7 @@ static const mstring attr_bits[] =
     minit ("ZERO_COMP", AB_ZERO_COMP),
     minit ("PROTECTED", AB_PROTECTED),
     minit ("ABSTRACT", AB_ABSTRACT),
+    minit ("EXTENSION", AB_EXTENSION),
     minit (NULL, -1)
 };
 
@@ -1801,6 +1803,8 @@ mio_symbol_attribute (symbol_attribute *attr)
 	MIO_NAME (ab_attribute) (AB_PRIVATE_COMP, attr_bits);
       if (attr->zero_comp)
 	MIO_NAME (ab_attribute) (AB_ZERO_COMP, attr_bits);
+      if (attr->extension)
+	MIO_NAME (ab_attribute) (AB_EXTENSION, attr_bits);
 
       mio_rparen ();
 
@@ -1919,6 +1923,9 @@ mio_symbol_attribute (symbol_attribute *attr)
 	    case AB_ZERO_COMP:
 	      attr->zero_comp = 1;
 	      break;
+	    case AB_EXTENSION:
+	      attr->extension = 1;
+	      break;
 	    }
 	}
     }

gcc/fortran/symbol.c

@@ -1701,6 +1701,14 @@ gfc_add_component (gfc_symbol *sym, const char *name,
       tail = p;
     }
 
+  if (sym->attr.extension
+	&& gfc_find_component (sym->components->ts.derived, name))
+    {
+      gfc_error ("Component '%s' at %C already in the parent type "
+		 "at %L", name, &sym->components->ts.derived->declared_at);
+      return FAILURE;
+    }
+
   /* Allocate a new component.  */
   p = gfc_get_component ();
 
@@ -1830,17 +1838,36 @@ gfc_find_component (gfc_symbol *sym, const char *name)
     if (strcmp (p->name, name) == 0)
       break;
 
+  if (p == NULL
+	&& sym->attr.extension
+	&& sym->components->ts.type == BT_DERIVED)
+    {
+      p = gfc_find_component (sym->components->ts.derived, name);
+      /* Do not overwrite the error.  */
+      if (p == NULL)
+	return p;
+    }
+
   if (p == NULL)
     gfc_error ("'%s' at %C is not a member of the '%s' structure",
 	       name, sym->name);
-  else
+
+  else if (sym->attr.use_assoc)
     {
-      if (sym->attr.use_assoc && (sym->component_access == ACCESS_PRIVATE
-				  || p->access == ACCESS_PRIVATE))
+      if (p->access == ACCESS_PRIVATE)
 	{
 	  gfc_error ("Component '%s' at %C is a PRIVATE component of '%s'",
 		     name, sym->name);
-	  p = NULL;
+	  return NULL;
+	}
+	
+      /* If there were components given and all components are private, error
+	 out at this place.  */
+      if (p->access != ACCESS_PUBLIC && sym->component_access == ACCESS_PRIVATE)
+	{
+	  gfc_error ("All components of '%s' are PRIVATE in structure"
+		     " constructor at %C", sym->name);
+	  return NULL;
 	}
     }
 

gcc/fortran/trans-array.c

@@ -3257,14 +3257,16 @@ gfc_conv_resolve_dependencies (gfc_loopinfo * loop, gfc_ss * dest,
       if (ss->type != GFC_SS_SECTION)
 	continue;
 
-      if (gfc_could_be_alias (dest, ss)
-	    || gfc_are_equivalenced_arrays (dest->expr, ss->expr))
+      if (dest->expr->symtree->n.sym != ss->expr->symtree->n.sym)
 	{
-	  nDepend = 1;
-	  break;
+	  if (gfc_could_be_alias (dest, ss)
+		|| gfc_are_equivalenced_arrays (dest->expr, ss->expr))
+	    {
+	      nDepend = 1;
+	      break;
+	    }
 	}
-
-      if (dest->expr->symtree->n.sym == ss->expr->symtree->n.sym)
+      else
 	{
 	  lref = dest->expr->ref;
 	  rref = ss->expr->ref;

gcc/fortran/trans-expr.c

 /* Expression translation
-   Copyright (C) 2002, 2003, 2004, 2005, 2006, 2007, 2008 Free Software
-   Foundation, Inc.
+   Copyright (C) 2002, 2003, 2004, 2005, 2006, 2007, 2008
+   Free Software Foundation, Inc.
    Contributed by Paul Brook <paul@nowt.org>
    and Steven Bosscher <s.bosscher@student.tudelft.nl>
 
@@ -395,6 +395,40 @@ gfc_conv_component_ref (gfc_se * se, gfc_ref * ref)
 }
 
 
+/* This function deals with component references to components of the
+   parent type for derived type extensons.  */
+static void
+conv_parent_component_references (gfc_se * se, gfc_ref * ref)
+{
+  gfc_component *c;
+  gfc_component *cmp;
+  gfc_symbol *dt;
+  gfc_ref parent;
+
+  dt = ref->u.c.sym;
+  c = ref->u.c.component;
+
+  /* Build a gfc_ref to recursively call gfc_conv_component_ref.  */
+  parent.type = REF_COMPONENT;
+  parent.next = NULL;
+  parent.u.c.sym = dt;
+  parent.u.c.component = dt->components;
+
+  if (dt->attr.extension && dt->components)
+    {
+      /* Return if the component is not in the parent type.  */
+      for (cmp = dt->components->next; cmp; cmp = cmp->next)
+	if (strcmp (c->name, cmp->name) == 0)
+	  return;
+	
+      /* Otherwise build the reference and call self.  */
+      gfc_conv_component_ref (se, &parent);
+      parent.u.c.sym = dt->components->ts.derived;
+      parent.u.c.component = c;
+      conv_parent_component_references (se, &parent);
+    }
+}
+
 /* Return the contents of a variable. Also handles reference/pointer
    variables (all Fortran pointer references are implicit).  */
 
@@ -561,6 +595,9 @@ gfc_conv_variable (gfc_se * se, gfc_expr * expr)
 	  break;
 
 	case REF_COMPONENT:
+	  if (ref->u.c.sym->attr.extension)
+	    conv_parent_component_references (se, ref);
+
 	  gfc_conv_component_ref (se, ref);
 	  break;
 

gcc/fortran/trans-io.c

 /* IO Code translation/library interface
-   Copyright (C) 2002, 2003, 2004, 2005, 2006, 2007, 2008 Free Software
-   Foundation, Inc.
+   Copyright (C) 2002, 2003, 2004, 2005, 2006, 2007, 2008
+   Free Software Foundation, Inc.
    Contributed by Paul Brook
 
 This file is part of GCC.

gcc/testsuite/ChangeLog

+2008-07-29  Paul Thomas  <pault@gcc.gnu.org>
+
+	* gfortran.dg/extends_1.f03: New test.
+	* gfortran.dg/extends_2.f03: New test.
+	* gfortran.dg/extends_3.f03: New test.
+	* gfortran.dg/extends_4.f03: New test.
+	* gfortran.dg/extends_5.f03: New test.
+	* gfortran.dg/extends_6.f03: New test.
+	* gfortran.dg/private_type_6.f90: Modify error message.
+	* gfortran.dg/structure_constructor_7.f03: Modify error message.
+	* gfortran.dg/structure_constructor_8.f03: Modify error message.
+
 2008-07-29  Richard Guenther  <rguenther@suse.de>
 
 	PR tree-optimization/36945

gcc/testsuite/gfortran.dg/extends_1.f03

+! { dg-do run }
+! A basic functional test of derived type extension.
+!
+! Contributed by Paul Thomas  <pault@gcc.gnu.org>
+!
+module persons
+  type :: person
+    character(24) :: name = ""
+    integer :: ss = 1
+  end type person
+end module persons
+
+module person_education
+  use persons
+  type, extends(person) :: education
+    integer ::  attainment = 0
+    character(24) :: institution = ""
+  end type education
+end module person_education
+
+  use person_education
+  type, extends(education) :: service
+    integer :: personnel_number = 0
+    character(24) :: department = ""
+  end type service
+  
+  type, extends(service) :: person_record
+    type (person_record), pointer :: supervisor => NULL ()
+  end type person_record
+  
+  type(person_record), pointer :: recruit, supervisor
+  
+! Check that references by ultimate component work
+
+  allocate (supervisor)
+  supervisor%name = "Joe Honcho"
+  supervisor%ss = 123455
+  supervisor%attainment = 100
+  supervisor%institution = "Celestial University"
+  supervisor%personnel_number = 1
+  supervisor%department = "Directorate"
+
+  recruit => entry ("John Smith", 123456, 1, "Bog Hill High School", &
+                    99, "Records", supervisor)
+
+  if (trim (recruit%name) /= "John Smith") call abort
+  if (recruit%name /= recruit%service%name) call abort
+  if (recruit%supervisor%ss /= 123455) call abort
+  if (recruit%supervisor%ss /= supervisor%person%ss) call abort
+
+  deallocate (supervisor)
+  deallocate (recruit)
+contains
+  function entry (name, ss, attainment, institution, &
+                  personnel_number, department, supervisor) result (new_person)
+    integer :: ss, attainment, personnel_number
+    character (*) :: name, institution, department
+    type (person_record), pointer :: supervisor, new_person
+
+    allocate (new_person)
+
+! Check mixtures of references
+    new_person%person%name = name
+    new_person%service%education%person%ss = ss
+    new_person%service%attainment = attainment
+    new_person%education%institution = institution
+    new_person%personnel_number = personnel_number
+    new_person%service%department = department
+    new_person%supervisor => supervisor
+  end function
+end
+
+! { dg-final { cleanup-modules "persons person_education" } }

gcc/testsuite/gfortran.dg/extends_2.f03

+! { dg-do run }
+! A test of f95 style constructors with derived type extension.
+!
+! Contributed by Paul Thomas  <pault@gcc.gnu.org>
+!
+module persons
+  type :: person
+    character(24) :: name = ""
+    integer :: ss = 1
+  end type person
+end module persons
+
+module person_education
+  use persons
+  type, extends(person) :: education
+    integer ::  attainment = 0
+    character(24) :: institution = ""
+  end type education
+end module person_education
+
+  use person_education
+  type, extends(education) :: service
+    integer :: personnel_number = 0
+    character(24) :: department = ""
+  end type service
+
+  type, extends(service) :: person_record
+    type (person_record), pointer :: supervisor => NULL ()
+  end type person_record
+
+  type(person_record), pointer :: recruit, supervisor
+
+! Check that simple constructor works
+  allocate (supervisor)
+  supervisor%service = service ("Joe Honcho", 123455, 100, &
+                                "Celestial University", 1, &
+                                "Directorate")
+
+  recruit => entry ("John Smith", 123456, 1, "Bog Hill High School", &
+                    99, "Records", supervisor)
+
+  if (trim (recruit%name) /= "John Smith") call abort
+  if (recruit%name /= recruit%service%name) call abort
+  if (recruit%supervisor%ss /= 123455) call abort
+  if (recruit%supervisor%ss /= supervisor%person%ss) call abort
+
+  deallocate (supervisor)
+  deallocate (recruit)
+contains
+  function entry (name, ss, attainment, institution, &
+                  personnel_number, department, supervisor) result (new_person)
+    integer :: ss, attainment, personnel_number
+    character (*) :: name, institution, department
+    type (person_record), pointer :: supervisor, new_person
+
+    allocate (new_person)
+
+! Check nested constructors
+    new_person = person_record (education (person (name, ss), &
+                                attainment, institution), &
+                                personnel_number, department, &
+                                supervisor)
+  end function
+end
+
+! { dg-final { cleanup-modules "persons person_education" } }

gcc/testsuite/gfortran.dg/extends_3.f03

+! { dg-do run }
+! A test of f2k style constructors with derived type extension.
+!
+! Contributed by Paul Thomas  <pault@gcc.gnu.org>
+!
+module persons
+  type :: person
+    character(24) :: name = ""
+    integer :: ss = 1
+  end type person
+end module persons
+
+module person_education
+  use persons
+  type, extends(person) :: education
+    integer ::  attainment = 0
+    character(24) :: institution = ""
+  end type education
+end module person_education
+
+  use person_education
+  type, extends(education) :: service
+    integer :: personnel_number = 0
+    character(24) :: department = ""
+  end type service
+
+  type, extends(service) :: person_record
+    type (person_record), pointer :: supervisor => NULL ()
+  end type person_record
+
+  type(person_record), pointer :: recruit, supervisor
+  
+! Check that F2K constructor with missing entries works
+  allocate (supervisor)
+  supervisor%service = service (NAME = "Joe Honcho", SS= 123455)
+
+  recruit => entry ("John Smith", 123456, 1, "Bog Hill High School", &
+                    99, "Records", supervisor)
+
+  if (supervisor%ss /= 123455) call abort
+  if (trim (supervisor%name) /= "Joe Honcho") call abort
+  if (trim (supervisor%institution) /= "") call abort
+  if (supervisor%attainment /= 0) call abort
+
+  if (trim (recruit%name) /= "John Smith") call abort
+  if (recruit%name /= recruit%service%name) call abort
+  if (recruit%supervisor%ss /= 123455) call abort
+  if (recruit%supervisor%ss /= supervisor%person%ss) call abort
+
+  deallocate (supervisor)
+  deallocate (recruit)
+contains
+  function entry (name, ss, attainment, institution, &
+                  personnel_number, department, supervisor) result (new_person)
+    integer :: ss, attainment, personnel_number
+    character (*) :: name, institution, department
+    type (person_record), pointer :: supervisor, new_person
+
+    allocate (new_person)
+
+! Check F2K constructor with order shuffled a bit
+    new_person = person_record (NAME = name, SS =ss, &
+                                DEPARTMENT = department, &
+                                INSTITUTION = institution, &
+                                PERSONNEL_NUMBER = personnel_number, &
+                                ATTAINMENT = attainment, &
+                                SUPERVISOR = supervisor)
+  end function
+end
+
+! { dg-final { cleanup-modules "persons person_education" } }

gcc/testsuite/gfortran.dg/extends_4.f03

+! { dg-do run }
+! Check that derived type extension is compatible with renaming
+! the parent type and that allocatable components are OK.  At
+! the same time, private type and components are checked.
+!
+! Contributed by Paul Thomas  <pault@gcc.gnu.org>
+!
+module mymod
+  type :: a
+    real, allocatable :: x(:)
+    integer, private :: ia = 0
+  end type a
+  type :: b
+    private
+    real, allocatable :: x(:)
+    integer :: i
+  end type b
+contains
+  function set_b () result (res)
+    type(b) :: res
+    allocate (res%x(2))
+    res%x = [10.0, 20.0]
+    res%i = 1
+  end function
+  subroutine check_b (arg)
+    type(b) :: arg
+    if (any (arg%x /= [10.0, 20.0])) call abort
+    if (arg%i /= 1) call abort
+  end subroutine
+end module mymod
+
+  use mymod, e => a
+  type, extends(e) :: f
+    integer :: if
+  end type f
+  type, extends(b) :: d
+    integer :: id
+  end type d
+
+  type(f) :: p
+  type(d) :: q
+
+  p = f (x = [1.0, 2.0], if = 3)
+  if (any (p%e%x /= [1.0, 2.0])) call abort
+
+  q%b = set_b ()
+  call check_b (q%b)
+  q = d (b = set_b (), id = 99)
+  call check_b (q%b)
+end
+
+! { dg-final { cleanup-modules "persons person_education" } }

gcc/testsuite/gfortran.dg/extends_5.f03

+! { dg-do compile }
+! Some errors for derived type extension.
+!
+! Contributed by Paul Thomas  <pault@gcc.gnu.org>
+!
+module m
+  use iso_c_binding
+  type :: date
+    sequence
+    integer :: yr, mon
+    integer,public :: day
+  end type
+  type, bind(c) :: dt
+    integer(c_int) :: yr, mon
+    integer(c_int) :: day
+  end type
+end module m
+
+  use m
+  type, extends(date) :: datetime ! { dg-error "because it is a SEQUENCE type" }
+  end type ! { dg-error "Expecting END PROGRAM" }
+
+  type, extends(dt) :: dt_type ! { dg-error "because it is BIND" }
+  end type ! { dg-error "Expecting END PROGRAM" }
+end
+
+! { dg-final { cleanup-modules "m" } }

gcc/testsuite/gfortran.dg/extends_6.f03

+! { dg-do compile }
+! Some errors pointed out in the development of the patch.
+!
+! Contributed by Tobias Burnus  <burnus@net-b.de>
+!
+module m
+  type :: date
+    private
+    integer :: yr, mon
+    integer,public :: day
+  end type
+  type :: dt
+    integer :: yr, mon
+    integer :: day
+  end type
+end module m
+
+  use m
+  type, extends(date) :: datetime
+    integer :: hr, min, sec
+  end type
+  type(datetime) :: o_dt
+
+  type :: one
+    integer :: i
+  end type one
+
+  type, extends(one) :: two
+    real :: r
+  end type two
+
+  o_dt%day = 5  ! VALID but failed in first version of EXTENDS patch
+  o_dt%yr  = 5  ! { dg-error "All components of 'date' are PRIVATE" }
+
+  t = two(one = one(4), i = 5, r=4.4) ! { dg-error "has already been set" }
+
+  call foo
+contains
+  subroutine foo
+    use m, date_type => dt
+    type, extends(date_type) :: dt_type
+    end type
+    type (dt_type) :: foo_dt
+    foo_dt%date_type%day = 1
+    foo_dt%dt%day = 1 ! { dg-error "not a member" }
+  end subroutine
+end
+
+! { dg-final { cleanup-modules "m" } }

gcc/testsuite/gfortran.dg/private_type_6.f90

@@ -19,7 +19,7 @@ program foo_test
   TYPE(footype) :: foo
   TYPE(bartype) :: foo2
   foo  = footype(1) ! { dg-error "All components of 'footype' are PRIVATE" }
-  foo2 = bartype(1,2) ! { dg-error "'dummy2' is PRIVATE" }
+  foo2 = bartype(1,2) ! { dg-error "is a PRIVATE component" }
   foo2%dummy2 = 5 ! { dg-error "is a PRIVATE component" }
 end program foo_test
 ! { dg-final { cleanup-modules "foomod" } }

gcc/testsuite/gfortran.dg/structure_constructor_7.f03

@@ -13,6 +13,6 @@ PROGRAM test
   TYPE(basics_t) :: basics
 
   basics = basics_t (42, 1.5, 1000) ! { dg-error "Too many components" }
-  basics = basics_t (42, xxx = 1000) ! { dg-error "Component 'xxx'" }
+  basics = basics_t (42, xxx = 1000) ! { dg-error "is not a member" }
 
 END PROGRAM test

gcc/testsuite/gfortran.dg/structure_constructor_8.f03

@@ -47,8 +47,8 @@ PROGRAM test
   struct2 = allpriv_t ()
 
   ! These should fail
-  struct1 = haspriv_t (1, 2) ! { dg-error "'b' is PRIVATE" }
-  struct1 = haspriv_t (b = 2, a = 1) ! { dg-error "'b' is PRIVATE" }
+  struct1 = haspriv_t (1, 2) ! { dg-error "is a PRIVATE component" }
+  struct1 = haspriv_t (b = 2, a = 1) ! { dg-error "is a PRIVATE component" }
 
   ! This should fail as all components are private
   struct2 = allpriv_t (5) ! { dg-error "of 'allpriv_t' are PRIVATE" }