merge from fortran-dev branch:

gcc/fortran/

2009-11-30  Janus Weil  <janus@gcc.gnu.org>

	PR fortran/42053
	* resolve.c (resolve_select_type): Check for duplicate CLASS IS blocks.

2009-11-30  Janus Weil  <janus@gcc.gnu.org>

	PR fortran/41631
	* decl.c (gfc_match_derived_decl): Set extension level.
	* gfortran.h (symbol_attribute): Expand 'extension' bit field to 8 bit.
	* iresolve.c (gfc_resolve_extends_type_of): Return value of
	'is_extension_of' has kind=4.
	* match.c (select_type_set_tmp,gfc_match_class_is): Create temporary
	for CLASS IS blocks.
	* module.c (MOD_VERSION): Bump module version.
	(ab_attribute,attr_bits): Remove AB_EXTENSION.
	(mio_symbol_attribute): Handle expanded 'extension' field.
	* resolve.c (resolve_select_type): Implement CLASS IS blocks.
	(resolve_fl_variable_derived): Show correct type name.
	* symbol.c (gfc_build_class_symbol): Set extension level.

2009-11-30  Janus Weil  <janus@gcc.gnu.org>

	* intrinsic.h (gfc_resolve_extends_type_of): Add prototype.
	* intrinsic.c (add_functions): Use 'gfc_resolve_extends_type_of'.
	* iresolve.c (gfc_resolve_extends_type_of): New function, which
	replaces the call to EXTENDS_TYPE_OF by the library function
	'is_extension_of' and modifies the arguments.
	* trans-intrinsic.c (gfc_conv_extends_type_of): Removed.
	(gfc_conv_intrinsic_function): FOR EXTENDS_TYPE_OF, don't call
	gfc_conv_extends_type_of but gfc_conv_intrinsic_funcall.

2009-11-30  Paul Thomas  <pault@gcc.gnu.org>
	    Janus Weil  <janus@gcc.gnu.org>

	* decl.c (encapsulate_class_symbol): Replaced by
	'gfc_build_class_symbol'.
	(build_sym,build_struct): Call 'gfc_build_class_symbol'.
	(gfc_match_derived_decl): Replace vindex by hash_value.
	* dump-parse-tree.c (show_symbol): Replace vindex by hash_value.
	* gfortran.h (symbol_attribute): Add field 'vtab'.
	(gfc_symbol): Replace vindex by hash_value.
	(gfc_class_esym_list): Ditto.
	(gfc_get_derived_type,gfc_build_class_symbol,gfc_find_derived_vtab):
	New prototypes.
	* module.c (mio_symbol): Replace vindex by hash_value.
	* resolve.c (vindex_expr): Rename to 'hash_value_expr'.
	(resolve_class_compcall,resolve_class_typebound_call): Renamed
	'vindex_expr'.
	(resolve_select_type): Replace $vindex by $vptr->$hash.
	* symbol.c (gfc_add_save): Handle vtab symbols.
	(gfc_type_compatible): Rewrite.
	(gfc_build_class_symbol): New function which replaces
	'encapsulate_class_symbol'.
	(gfc_find_derived_vtab): New function to set up a vtab symbol for a
	derived type.
	* trans-decl.c (gfc_create_module_variable): Handle vtab symbols.
	* trans-expr.c (select_class_proc): Replace vindex by hash_value.
	(gfc_conv_derived_to_class): New function to construct a temporary
	CLASS variable from a derived type expression.
	(gfc_conv_procedure_call): Call 'gfc_conv_derived_to_class'.
	(gfc_conv_structure): Initialize the $extends and $size fields of
	vtab symbols.
	(gfc_trans_class_assign): Replace $vindex by $vptr. Remove the $size
	assignment.
	* trans-intrinsic.c (gfc_conv_same_type_as): Replace $vindex by
	$vptr->$hash, and replace vindex by hash_value.
	* trans-stmt.c (gfc_trans_allocate): Insert $vptr references, replace
	$vindex by $vptr. Remove the $size assignment.
	* trans-types.c (gfc_get_derived_type): Make it non-static.


gcc/testsuite/

2009-11-30  Janus Weil  <janus@gcc.gnu.org>

	PR fortran/42053
	* gfortran.dg/select_type_9.f03: New.

2009-11-30  Janus Weil  <janus@gcc.gnu.org>

	PR fortran/41631
	* gfortran.dg/extends_type_of_1.f03: Fix invalid test case.
	* gfortran.dg/module_md5_1.f90: Adjusted MD5 sum.
	* gfortran.dg/select_type_1.f03: Remove FIXMEs.
	* gfortran.dg/select_type_2.f03: Ditto.
	* gfortran.dg/select_type_8.f03: New test.

2009-11-30  Janus Weil  <janus@gcc.gnu.org>

	* gfortran.dg/extends_type_of_1.f03: New test.
	* gfortran.dg/same_type_as_1.f03: Extended.

2009-11-30  Paul Thomas  <pault@gcc.gnu.org>

	* gfortran.dg/class_4c.f03: Add dg-additional-sources.
	* gfortran.dg/class_4d.f03: Rename module. Cleanup modules.


libgfortran/

2009-11-30  Janus Weil  <janus@gcc.gnu.org>

	* gfortran.map: Add _gfortran_is_extension_of.
	* Makefile.am: Add intrinsics/extends_type_of.c.
	* Makefile.in: Regenerated.
	* intrinsics/extends_type_of.c: New file. 


git-svn-id: svn+ssh://gcc.gnu.org/svn/gcc/trunk@154840 138bc75d-0d04-0410-961f-82ee72b054a4

1 files changed, 103 insertions, 89 deletions

diff --git a/gcc/fortran/trans-expr.c b/gcc/fortran/trans-expr.c
index 77de6bd5773..acca306a2ff 100644
--- a/gcc/fortran/trans-expr.c
+++ b/gcc/fortran/trans-expr.c
@@ -1530,16 +1530,16 @@ select_class_proc (gfc_se *se, gfc_class_esym_list *elist,
   tree end_label;
   tree label;
   tree tmp;
-  tree vindex;
+  tree hash;
   stmtblock_t body;
   gfc_class_esym_list *next_elist, *tmp_elist;
   gfc_se tmpse;
 
-  /* Convert the vindex expression.  */
+  /* Convert the hash expression.  */
   gfc_init_se (&tmpse, NULL);
-  gfc_conv_expr (&tmpse, elist->vindex);
+  gfc_conv_expr (&tmpse, elist->hash_value);
   gfc_add_block_to_block (&se->pre, &tmpse.pre);
-  vindex = gfc_evaluate_now (tmpse.expr, &se->pre);
+  hash = gfc_evaluate_now (tmpse.expr, &se->pre);
   gfc_add_block_to_block (&se->post, &tmpse.post);
 
   /* Fix the function type to be that of the declared type method.  */
@@ -1566,9 +1566,9 @@ select_class_proc (gfc_se *se, gfc_class_esym_list *elist,
 	  if (elist->esym != tmp_elist->esym)
 	    continue;
 
-	  cval = build_int_cst (TREE_TYPE (vindex),
-				elist->derived->vindex);
-	  /* Build a label for the vindex value.  */
+	  cval = build_int_cst (TREE_TYPE (hash),
+				elist->derived->hash_value);
+	  /* Build a label for the hash value.  */
 	  label = gfc_build_label_decl (NULL_TREE);
 	  tmp = fold_build3 (CASE_LABEL_EXPR, void_type_node,
 			     cval, NULL_TREE, label);
@@ -1601,8 +1601,8 @@ select_class_proc (gfc_se *se, gfc_class_esym_list *elist,
 	 segfaults because it occurs too early and too often.  */
     free_elist:
       next_elist = elist->next;
-      if (elist->vindex)
-	gfc_free_expr (elist->vindex);
+      if (elist->hash_value)
+	gfc_free_expr (elist->hash_value);
       gfc_free (elist);
       elist = NULL;
     }
@@ -1613,12 +1613,12 @@ select_class_proc (gfc_se *se, gfc_class_esym_list *elist,
 		     NULL_TREE, NULL_TREE, label);
   gfc_add_expr_to_block (&body, tmp);
   tmp = gfc_trans_runtime_error (true, &expr->where,
-		"internal error: bad vindex in dynamic dispatch");
+		"internal error: bad hash value in dynamic dispatch");
   gfc_add_expr_to_block (&body, tmp);
 
   /* Write the switch expression.  */
   tmp = gfc_finish_block (&body);
-  tmp = build3_v (SWITCH_EXPR, vindex, tmp, NULL_TREE);
+  tmp = build3_v (SWITCH_EXPR, hash, tmp, NULL_TREE);
   gfc_add_expr_to_block (&se->pre, tmp);
 
   tmp = build1_v (LABEL_EXPR, end_label);
@@ -2531,6 +2531,60 @@ conv_arglist_function (gfc_se *se, gfc_expr *expr, const char *name)
 }
 
 
+/* Takes a derived type expression and returns the address of a temporary
+   class object of the 'declared' type.  */ 
+static void
+gfc_conv_derived_to_class (gfc_se *parmse, gfc_expr *e,
+			   gfc_typespec class_ts)
+{
+  gfc_component *cmp;
+  gfc_symbol *vtab;
+  gfc_symbol *declared = class_ts.u.derived;
+  gfc_ss *ss;
+  tree ctree;
+  tree var;
+  tree tmp;
+
+  /* The derived type needs to be converted to a temporary
+     CLASS object.  */
+  tmp = gfc_typenode_for_spec (&class_ts);
+  var = gfc_create_var (tmp, "class");
+
+  /* Set the vptr.  */
+  cmp = gfc_find_component (declared, "$vptr", true, true);
+  ctree = fold_build3 (COMPONENT_REF, TREE_TYPE (cmp->backend_decl),
+		       var, cmp->backend_decl, NULL_TREE);
+
+  /* Remember the vtab corresponds to the derived type
+    not to the class declared type.  */
+  vtab = gfc_find_derived_vtab (e->ts.u.derived);
+  gcc_assert (vtab);
+  tmp = gfc_build_addr_expr (NULL_TREE, gfc_get_symbol_decl (vtab));
+  gfc_add_modify (&parmse->pre, ctree,
+		  fold_convert (TREE_TYPE (ctree), tmp));
+
+  /* Now set the data field.  */
+  cmp = gfc_find_component (declared, "$data", true, true);
+  ctree = fold_build3 (COMPONENT_REF, TREE_TYPE (cmp->backend_decl),
+		       var, cmp->backend_decl, NULL_TREE);
+  ss = gfc_walk_expr (e);
+  if (ss == gfc_ss_terminator)
+    {
+      gfc_conv_expr_reference (parmse, e);
+      tmp = fold_convert (TREE_TYPE (ctree), parmse->expr);
+      gfc_add_modify (&parmse->pre, ctree, tmp);
+    }
+  else
+    {
+      gfc_conv_expr (parmse, e);
+      gfc_add_modify (&parmse->pre, ctree, parmse->expr);
+    }
+
+  /* Pass the address of the class object.  */
+  parmse->expr = gfc_build_addr_expr (NULL_TREE, var);
+}
+
+
 /* The following routine generates code for the intrinsic
    procedures from the ISO_C_BINDING module:
     * C_LOC           (function)
@@ -2800,53 +2854,10 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym,
       else if (fsym && fsym->ts.type == BT_CLASS
 		 && e->ts.type == BT_DERIVED)
 	{
-	  tree data;
-	  tree vindex;
-	  tree size;
-
 	  /* The derived type needs to be converted to a temporary
 	     CLASS object.  */
 	  gfc_init_se (&parmse, se);
-	  type = gfc_typenode_for_spec (&fsym->ts);
-	  var = gfc_create_var (type, "class");
-
-	  /* Get the components.  */
-	  tmp = fsym->ts.u.derived->components->backend_decl;
-	  data = fold_build3 (COMPONENT_REF, TREE_TYPE (tmp),
-			      var, tmp, NULL_TREE);
-	  tmp = fsym->ts.u.derived->components->next->backend_decl;
-	  vindex = fold_build3 (COMPONENT_REF, TREE_TYPE (tmp),
-				var, tmp, NULL_TREE);
-	  tmp = fsym->ts.u.derived->components->next->next->backend_decl;
-	  size = fold_build3 (COMPONENT_REF, TREE_TYPE (tmp),
-			      var, tmp, NULL_TREE);
-
-	  /* Set the vindex.  */
-	  tmp = build_int_cst (TREE_TYPE (vindex), e->ts.u.derived->vindex);
-	  gfc_add_modify (&parmse.pre, vindex, tmp);
-
-	  /* Set the size.  */
-	  tmp = TYPE_SIZE_UNIT (gfc_typenode_for_spec (&e->ts));
-	  gfc_add_modify (&parmse.pre, size,
-			  fold_convert (TREE_TYPE (size), tmp));
-
-	  /* Now set the data field.  */
-	  argss = gfc_walk_expr (e);
-	  if (argss == gfc_ss_terminator)
-            {
-	      gfc_conv_expr_reference (&parmse, e);
-	      tmp = fold_convert (TREE_TYPE (data),
-				  parmse.expr);
-	      gfc_add_modify (&parmse.pre, data, tmp);
-	    }
-	  else
-	    {
-	      gfc_conv_expr (&parmse, e);
-	      gfc_add_modify (&parmse.pre, data, parmse.expr);
-	    }
-
-	  /* Pass the address of the class object.  */
-	  parmse.expr = gfc_build_addr_expr (NULL_TREE, var);
+	  gfc_conv_derived_to_class (&parmse, e, fsym->ts);
 	}
       else if (se->ss && se->ss->useflags)
 	{
@@ -4240,14 +4251,27 @@ gfc_conv_structure (gfc_se * se, gfc_expr * expr, int init)
 
       if (cm->ts.type == BT_CLASS)
 	{
+	  gfc_component *data;
+	  data = gfc_find_component (cm->ts.u.derived, "$data", true, true);
 	  val = gfc_conv_initializer (c->expr, &cm->ts,
-	      TREE_TYPE (cm->ts.u.derived->components->backend_decl),
-	      cm->ts.u.derived->components->attr.dimension,
-	      cm->ts.u.derived->components->attr.pointer);
+				      TREE_TYPE (data->backend_decl),
+				      data->attr.dimension,
+				      data->attr.pointer);
 
-	  /* Append it to the constructor list.  */
-	  CONSTRUCTOR_APPEND_ELT (v, cm->ts.u.derived->components->backend_decl,
-				  val);
+	  CONSTRUCTOR_APPEND_ELT (v, data->backend_decl, val);
+	}
+      else if (strcmp (cm->name, "$size") == 0)
+	{
+	  val = TYPE_SIZE_UNIT (gfc_get_derived_type (cm->ts.u.derived));
+	  CONSTRUCTOR_APPEND_ELT (v, cm->backend_decl, val);
+	}
+      else if (cm->initializer && cm->initializer->expr_type != EXPR_NULL
+	       && strcmp (cm->name, "$extends") == 0)
+	{
+	  gfc_symbol *vtabs;
+	  vtabs = cm->initializer->symtree->n.sym;
+	  val = gfc_build_addr_expr (NULL_TREE, gfc_get_symbol_decl (vtabs));
+	  CONSTRUCTOR_APPEND_ELT (v, cm->backend_decl, val);
 	}
       else
 	{
@@ -5366,47 +5390,37 @@ gfc_trans_class_assign (gfc_code *code)
 {
   stmtblock_t block;
   tree tmp;
+  gfc_expr *lhs;
+  gfc_expr *rhs;
 
   gfc_start_block (&block);
 
   if (code->expr2->ts.type != BT_CLASS)
     {
-      /* Insert an additional assignment which sets the '$vindex' field.  */
-      gfc_expr *lhs,*rhs;
+      /* Insert an additional assignment which sets the '$vptr' field.  */
       lhs = gfc_copy_expr (code->expr1);
-      gfc_add_component_ref (lhs, "$vindex");
-      if (code->expr2->ts.type == BT_DERIVED)
-	/* vindex is constant, determined at compile time.  */
-	rhs = gfc_int_expr (code->expr2->ts.u.derived->vindex);
-      else if (code->expr2->expr_type == EXPR_NULL)
-	rhs = gfc_int_expr (0);
-      else
-	gcc_unreachable ();
-      tmp = gfc_trans_assignment (lhs, rhs, false);
-      gfc_add_expr_to_block (&block, tmp);
-
-      /* Insert another assignment which sets the '$size' field.  */
-      lhs = gfc_copy_expr (code->expr1);
-      gfc_add_component_ref (lhs, "$size");
+      gfc_add_component_ref (lhs, "$vptr");
       if (code->expr2->ts.type == BT_DERIVED)
 	{
-	  /* Size is fixed at compile time.  */
-	  gfc_se lse;
-	  gfc_init_se (&lse, NULL);
-	  gfc_conv_expr (&lse, lhs);
-	  tmp = TYPE_SIZE_UNIT (gfc_typenode_for_spec (&code->expr2->ts));
-	  gfc_add_modify (&block, lse.expr,
-			  fold_convert (TREE_TYPE (lse.expr), tmp));
+	  gfc_symbol *vtab;
+	  gfc_symtree *st;
+	  vtab = gfc_find_derived_vtab (code->expr2->ts.u.derived);
+	  gcc_assert (vtab);
+
+	  rhs = gfc_get_expr ();
+	  rhs->expr_type = EXPR_VARIABLE;
+	  gfc_find_sym_tree (vtab->name, NULL, 1, &st);
+	  rhs->symtree = st;
+	  rhs->ts = vtab->ts;
 	}
       else if (code->expr2->expr_type == EXPR_NULL)
-	{
-	  rhs = gfc_int_expr (0);
-	  tmp = gfc_trans_assignment (lhs, rhs, false);
-	  gfc_add_expr_to_block (&block, tmp);
-	}
+	rhs = gfc_int_expr (0);
       else
 	gcc_unreachable ();
 
+      tmp = gfc_trans_pointer_assignment (lhs, rhs);
+      gfc_add_expr_to_block (&block, tmp);
+
       gfc_free_expr (lhs);
       gfc_free_expr (rhs);
     }