2008-07-30 Basile Starynkevitch <basile@starynkevitch.net>

	MELT branch merged with trunk r138310

	* gcc/Makefile.in: removed debugging echo in run-basilys-deps



git-svn-id: svn+ssh://gcc.gnu.org/svn/gcc/branches/melt-branch@138312 138bc75d-0d04-0410-961f-82ee72b054a4

1 files changed, 145 insertions, 105 deletions

diff --git a/gcc/fortran/primary.c b/gcc/fortran/primary.c
index 782f38e4425..dfea043d6e3 100644
--- a/gcc/fortran/primary.c
+++ b/gcc/fortran/primary.c
@@ -1984,11 +1984,103 @@ gfc_free_structure_ctor_component (gfc_structure_ctor_component *comp)
   gfc_free_expr (comp->val);
 }
 
-match
-gfc_match_structure_constructor (gfc_symbol *sym, gfc_expr **result)
+
+/* Translate the component list into the actual constructor by sorting it in
+   the order required; this also checks along the way that each and every
+   component actually has an initializer and handles default initializers
+   for components without explicit value given.  */
+static gfc_try
+build_actual_constructor (gfc_structure_ctor_component **comp_head,
+			  gfc_constructor **ctor_head, gfc_symbol *sym)
 {
-  gfc_structure_ctor_component *comp_head, *comp_tail;
   gfc_structure_ctor_component *comp_iter;
+  gfc_constructor *ctor_tail = NULL;
+  gfc_component *comp;
+
+  for (comp = sym->components; comp; comp = comp->next)
+    {
+      gfc_structure_ctor_component **next_ptr;
+      gfc_expr *value = NULL;
+
+      /* Try to find the initializer for the current component by name.  */
+      next_ptr = comp_head;
+      for (comp_iter = *comp_head; comp_iter; comp_iter = comp_iter->next)
+	{
+	  if (!strcmp (comp_iter->name, comp->name))
+	    break;
+	  next_ptr = &comp_iter->next;
+	}
+
+      /* If an extension, try building the parent derived type by building
+	 a value expression for the parent derived type and calling self.  */
+      if (!comp_iter && comp == sym->components && sym->attr.extension)
+	{
+	  value = gfc_get_expr ();
+	  value->expr_type = EXPR_STRUCTURE;
+	  value->value.constructor = NULL;
+	  value->ts = comp->ts;
+	  value->where = gfc_current_locus;
+
+	  if (build_actual_constructor (comp_head, &value->value.constructor,
+					comp->ts.derived) == FAILURE)
+	    {
+	      gfc_free_expr (value);
+	      return FAILURE;
+	    }
+	  *ctor_head = ctor_tail = gfc_get_constructor ();
+	  ctor_tail->expr = value;
+	  continue;
+	}
+
+      /* If it was not found, try the default initializer if there's any;
+	 otherwise, it's an error.  */
+      if (!comp_iter)
+	{
+	  if (comp->initializer)
+	    {
+	      if (gfc_notify_std (GFC_STD_F2003, "Fortran 2003: Structure"
+				  " constructor with missing optional arguments"
+				  " at %C") == FAILURE)
+		return FAILURE;
+	      value = gfc_copy_expr (comp->initializer);
+	    }
+	  else
+	    {
+	      gfc_error ("No initializer for component '%s' given in the"
+			 " structure constructor at %C!", comp->name);
+	      return FAILURE;
+	    }
+	}
+      else
+	value = comp_iter->val;
+
+      /* Add the value to the constructor chain built.  */
+      if (ctor_tail)
+	{
+	  ctor_tail->next = gfc_get_constructor ();
+	  ctor_tail = ctor_tail->next;
+	}
+      else
+	*ctor_head = ctor_tail = gfc_get_constructor ();
+      gcc_assert (value);
+      ctor_tail->expr = value;
+
+      /* Remove the entry from the component list.  We don't want the expression
+	 value to be free'd, so set it to NULL.  */
+      if (comp_iter)
+	{
+	  *next_ptr = comp_iter->next;
+	  comp_iter->val = NULL;
+	  gfc_free_structure_ctor_component (comp_iter);
+	}
+    }
+  return SUCCESS;
+}
+
+match
+gfc_match_structure_constructor (gfc_symbol *sym, gfc_expr **result, bool parent)
+{
+  gfc_structure_ctor_component *comp_tail, *comp_head, *comp_iter;
   gfc_constructor *ctor_head, *ctor_tail;
   gfc_component *comp; /* Is set NULL when named component is first seen */
   gfc_expr *e;
@@ -1996,10 +2088,10 @@ gfc_match_structure_constructor (gfc_symbol *sym, gfc_expr **result)
   match m;
   const char* last_name = NULL;
 
-  comp_head = comp_tail = NULL;
+  comp_tail = comp_head = NULL;
   ctor_head = ctor_tail = NULL;
 
-  if (gfc_match_char ('(') != MATCH_YES)
+  if (!parent && gfc_match_char ('(') != MATCH_YES)
     goto syntax;
 
   where = gfc_current_locus;
@@ -2047,7 +2139,7 @@ gfc_match_structure_constructor (gfc_symbol *sym, gfc_expr **result)
 		  if (last_name)
 		    gfc_error ("Component initializer without name after"
 			       " component named %s at %C!", last_name);
-		  else
+		  else if (!parent)
 		    gfc_error ("Too many components in structure constructor at"
 			       " %C!");
 		  goto cleanup;
@@ -2057,39 +2149,20 @@ gfc_match_structure_constructor (gfc_symbol *sym, gfc_expr **result)
 	      strncpy (comp_tail->name, comp->name, GFC_MAX_SYMBOL_LEN + 1);
 	    }
 
-	  /* Find the current component in the structure definition; this is
-	     needed to get its access attribute in the private check below.  */
+	  /* Find the current component in the structure definition and check its
+	     access is not private.  */
 	  if (comp)
-	    this_comp = comp;
+	    this_comp = gfc_find_component (sym, comp->name);
 	  else
 	    {
-	      for (comp = sym->components; comp; comp = comp->next)
-		if (!strcmp (comp->name, comp_tail->name))
-		  {
-		    this_comp = comp;
-		    break;
-		  }
+	      this_comp = gfc_find_component (sym, (const char *)comp_tail->name);
 	      comp = NULL; /* Reset needed!  */
-
-	      /* Here we can check if a component name is given which does not
-		 correspond to any component of the defined structure.  */
-	      if (!this_comp)
-		{
-		  gfc_error ("Component '%s' in structure constructor at %C"
-			     " does not correspond to any component in the"
-			     " constructed structure!", comp_tail->name);
-		  goto cleanup;
-		}
 	    }
-	  gcc_assert (this_comp);
 
-	  /* Check the current component's access status.  */
-	  if (sym->attr.use_assoc && this_comp->access == ACCESS_PRIVATE)
-	    {
-	      gfc_error ("Component '%s' is PRIVATE in structure constructor"
-			 " at %C!", comp_tail->name);
-	      goto cleanup;
-	    }
+	  /* Here we can check if a component name is given which does not
+	     correspond to any component of the defined structure.  */
+	  if (!this_comp)
+	    goto cleanup;
 
 	  /* Check if this component is already given a value.  */
 	  for (comp_iter = comp_head; comp_iter != comp_tail; 
@@ -2111,89 +2184,56 @@ gfc_match_structure_constructor (gfc_symbol *sym, gfc_expr **result)
 	  if (m == MATCH_ERROR)
 	    goto cleanup;
 
-	  if (comp)
-	    comp = comp->next;
-	}
-      while (gfc_match_char (',') == MATCH_YES);
+	  /* If not explicitly a parent constructor, gather up the components
+	     and build one.  */
+	  if (comp && comp == sym->components
+		&& sym->attr.extension
+		&& (comp_tail->val->ts.type != BT_DERIVED
+		      ||
+		    comp_tail->val->ts.derived != this_comp->ts.derived))
+	    {
+	      gfc_current_locus = where;
+	      gfc_free_expr (comp_tail->val);
 
-      if (gfc_match_char (')') != MATCH_YES)
-	goto syntax;
-	
-      /* If there were components given and all components are private, error
-	 out at this place.  */
-      if (sym->attr.use_assoc && sym->component_access == ACCESS_PRIVATE)
-	{
-	  gfc_error ("All components of '%s' are PRIVATE in structure"
-		     " constructor at %C", sym->name);
-	  goto cleanup;
-	}
-    }
+	      m = gfc_match_structure_constructor (comp->ts.derived, 
+						   &comp_tail->val, true);
+	      if (m == MATCH_NO)
+		goto syntax;
+	      if (m == MATCH_ERROR)
+		goto cleanup;
+	    }
 
-  /* Translate the component list into the actual constructor by sorting it in
-     the order required; this also checks along the way that each and every
-     component actually has an initializer and handles default initializers
-     for components without explicit value given.  */
-  for (comp = sym->components; comp; comp = comp->next)
-    {
-      gfc_structure_ctor_component **next_ptr;
-      gfc_expr *value = NULL;
+ 	  if (comp)
+	    comp = comp->next;
 
-      /* Try to find the initializer for the current component by name.  */
-      next_ptr = &comp_head;
-      for (comp_iter = comp_head; comp_iter; comp_iter = comp_iter->next)
-	{
-	  if (!strcmp (comp_iter->name, comp->name))
+	  if (parent && !comp)
 	    break;
-	  next_ptr = &comp_iter->next;
-	}
-
-      /* If it was not found, try the default initializer if there's any;
-	 otherwise, it's an error.  */
-      if (!comp_iter)
-	{
-	  if (comp->initializer)
-	    {
-	      if (gfc_notify_std (GFC_STD_F2003, "Fortran 2003: Structure"
-				  " constructor with missing optional arguments"
-				  " at %C") == FAILURE)
-		goto cleanup;
-	      value = gfc_copy_expr (comp->initializer);
-	    }
-	  else
-	    {
-	      gfc_error ("No initializer for component '%s' given in the"
-			 " structure constructor at %C!", comp->name);
-	      goto cleanup;
-	    }
 	}
-      else
-	value = comp_iter->val;
 
-      /* Add the value to the constructor chain built.  */
-      if (ctor_tail)
-	{
-	  ctor_tail->next = gfc_get_constructor ();
-	  ctor_tail = ctor_tail->next;
-	}
-      else
-	ctor_head = ctor_tail = gfc_get_constructor ();
-      gcc_assert (value);
-      ctor_tail->expr = value;
+      while (gfc_match_char (',') == MATCH_YES);
 
-      /* Remove the entry from the component list.  We don't want the expression
-	 value to be free'd, so set it to NULL.  */
-      if (comp_iter)
-	{
-	  *next_ptr = comp_iter->next;
-	  comp_iter->val = NULL;
-	  gfc_free_structure_ctor_component (comp_iter);
-	}
+      if (!parent && gfc_match_char (')') != MATCH_YES)
+	goto syntax;
     }
 
+  if (build_actual_constructor (&comp_head, &ctor_head, sym) == FAILURE)
+    goto cleanup;
+
   /* No component should be left, as this should have caused an error in the
      loop constructing the component-list (name that does not correspond to any
      component in the structure definition).  */
-  gcc_assert (!comp_head);
+  if (comp_head && sym->attr.extension)
+    {
+      for (comp_iter = comp_head; comp_iter; comp_iter = comp_iter->next)
+	{
+	  gfc_error ("component '%s' at %L has already been set by a "
+		     "parent derived type constructor", comp_iter->name,
+		     &comp_iter->where);
+	}
+      goto cleanup;
+    }
+  else
+    gcc_assert (!comp_head);
 
   e = gfc_get_expr ();
 
@@ -2396,7 +2436,7 @@ gfc_match_rvalue (gfc_expr **result)
       if (sym == NULL)
 	m = MATCH_ERROR;
       else
-	m = gfc_match_structure_constructor (sym, &e);
+	m = gfc_match_structure_constructor (sym, &e, false);
       break;
 
     /* If we're here, then the name is known to be the name of a