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

1 files changed, 88 insertions, 3 deletions

diff --git a/gcc/fortran/decl.c b/gcc/fortran/decl.c
index 9b1e585..8b9b8c0 100644
--- a/gcc/fortran/decl.c
+++ b/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;