[Patch, fortran-dev] SAME_TYPE_AS etc

[Janus Weil <janus at gcc dot gnu dot org>]

Hi all,

here goes another patch for the fortran-dev branch. It contains an
implementation for the SAME_TYPE_AS intrinsic, fixes some stuff
related to initialization and makes sure that *every* derived type in
a module gets a unique vindex (which was not the case before).
However, these vindices are not unique yet when used across modules
(that will come later). I also added two test cases for SAME_TYPE_AS.

I will probably commit this tomorrow or on Monday. Until then,
feedback is welcome (as always).

Cheers,
Janus

Index: gcc/fortran/intrinsic.c
===================================================================
--- gcc/fortran/intrinsic.c	(Revision 152201)
+++ gcc/fortran/intrinsic.c	(Arbeitskopie)
@@ -2307,6 +2307,12 @@ add_functions (void)
 
   make_generic ("rrspacing", GFC_ISYM_RRSPACING, GFC_STD_F95);
 
+  add_sym_2 ("same_type_as", GFC_ISYM_SAME_TYPE_AS, CLASS_INQUIRY, ACTUAL_NO,
+	     BT_LOGICAL, dl, GFC_STD_F2003,
+	     gfc_check_same_type_as, NULL, NULL,
+	     a, BT_UNKNOWN, 0, REQUIRED,
+	     b, BT_UNKNOWN, 0, REQUIRED);
+
   add_sym_2 ("scale", GFC_ISYM_SCALE, CLASS_ELEMENTAL, ACTUAL_NO, BT_REAL, dr, GFC_STD_F95,
 	     gfc_check_scale, gfc_simplify_scale, gfc_resolve_scale,
 	     x, BT_REAL, dr, REQUIRED, i, BT_INTEGER, di, REQUIRED);
Index: gcc/fortran/trans-expr.c
===================================================================
--- gcc/fortran/trans-expr.c	(Revision 152201)
+++ gcc/fortran/trans-expr.c	(Arbeitskopie)
@@ -3820,6 +3820,13 @@ gfc_trans_subcomponent_assign (tree dest, gfc_comp
 	  gfc_add_block_to_block (&block, &se.post);
 	}
     }
+  else if (cm->ts.type == BT_CLASS && expr->expr_type == EXPR_NULL)
+    {
+      /* NULL initialization for CLASS components.  */
+      tmp = gfc_trans_structure_assign (dest,
+					gfc_default_initializer (&cm->ts));
+      gfc_add_expr_to_block (&block, tmp);
+    }
   else if (cm->attr.dimension)
     {
       if (cm->attr.allocatable && expr->expr_type == EXPR_NULL)
@@ -4015,12 +4022,26 @@ gfc_conv_structure (gfc_se * se, gfc_expr * expr,
       if (!c->expr || cm->attr.allocatable)
         continue;
 
-      val = gfc_conv_initializer (c->expr, &cm->ts,
-	  TREE_TYPE (cm->backend_decl), cm->attr.dimension,
-	  cm->attr.pointer || cm->attr.proc_pointer);
+      if (cm->ts.type == BT_CLASS)
+	{
+	  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);
 
-      /* Append it to the constructor list.  */
-      CONSTRUCTOR_APPEND_ELT (v, cm->backend_decl, val);
+	  /* Append it to the constructor list.  */
+	  CONSTRUCTOR_APPEND_ELT (v, cm->ts.u.derived->components->backend_decl,
+				  val);
+	}
+      else
+	{
+	  val = gfc_conv_initializer (c->expr, &cm->ts,
+	      TREE_TYPE (cm->backend_decl), cm->attr.dimension,
+	      cm->attr.pointer || cm->attr.proc_pointer);
+
+	  /* Append it to the constructor list.  */
+	  CONSTRUCTOR_APPEND_ELT (v, cm->backend_decl, val);
+	}
     }
   se->expr = build_constructor (type, v);
   if (init) 
Index: gcc/fortran/decl.c
===================================================================
--- gcc/fortran/decl.c	(Revision 152201)
+++ gcc/fortran/decl.c	(Arbeitskopie)
@@ -1077,6 +1077,8 @@ encapsulate_class_symbol (gfc_typespec *ts, symbol
       c->attr.allocatable = attr->allocatable;
       c->attr.dimension = attr->dimension;
       c->as = (*as);
+      c->initializer = gfc_get_expr ();
+      c->initializer->expr_type = EXPR_NULL;
 
       /* Add component '$vindex'.  */
       if (gfc_add_component (fclass, "$vindex", &c) == FAILURE)
@@ -1084,6 +1086,7 @@ encapsulate_class_symbol (gfc_typespec *ts, symbol
       c->ts.type = BT_INTEGER;
       c->ts.kind = 4;
       c->attr.access = ACCESS_PRIVATE;
+      c->initializer = gfc_int_expr (0);
     }
 
   fclass->attr.extension = 1;
@@ -1322,6 +1325,7 @@ add_init_expr_to_sym (const char *name, gfc_expr *
       /* Check if the assignment can happen. This has to be put off
 	 until later for a derived type variable.  */
       if (sym->ts.type != BT_DERIVED && init->ts.type != BT_DERIVED
+	  && sym->ts.type != BT_CLASS && init->ts.type != BT_CLASS
 	  && gfc_check_assign_symbol (sym, init) == FAILURE)
 	return FAILURE;
 
@@ -6738,6 +6742,10 @@ gfc_get_type_attr_spec (symbol_attribute *attr, ch
 }
 
 
+/* Counter for assigning a unique vindex number to each derived type.  */
+static int vindex_counter = 0;
+
+
 /* Match the beginning of a derived type declaration.  If a type name
    was the result of a function, then it is possible to have a symbol
    already to be known as a derived type yet have no components.  */
@@ -6840,7 +6848,6 @@ gfc_match_derived_decl (void)
     {
       gfc_component *p;
       gfc_symtree *st;
-      gfc_symbol *declared_type;
 
       /* Add the extended derived type as the first component.  */
       gfc_add_component (sym, parent, &p);
@@ -6857,16 +6864,12 @@ gfc_match_derived_decl (void)
 	extended->f2k_derived = gfc_get_namespace (NULL, 0);
       st = gfc_new_symtree (&extended->f2k_derived->sym_root, sym->name);
       st->n.sym = sym;
-
-      /* Increment the VINDEX of the top-level declared type and set
-	 the VINDEX for this one.  This is done so that the size of
-	 the VTABLE entries for the top-level derived type is VINDEX.  */
-      declared_type = gfc_get_ultimate_derived_super_type (sym);
-      if (declared_type->vindex == 0)
-	declared_type->vindex++; 
-      sym->vindex = declared_type->vindex++;
     }
 
+  if (!sym->vindex)
+    /* Set the vindex for this type and increment the counter.  */
+    sym->vindex = ++vindex_counter;
+
   /* Take over the ABSTRACT attribute.  */
   sym->attr.abstract = attr.abstract;
 
Index: gcc/fortran/intrinsic.h
===================================================================
--- gcc/fortran/intrinsic.h	(Revision 152201)
+++ gcc/fortran/intrinsic.h	(Arbeitskopie)
@@ -119,6 +119,7 @@ gfc_try gfc_check_real (gfc_expr *, gfc_expr *);
 gfc_try gfc_check_rename (gfc_expr *, gfc_expr *);
 gfc_try gfc_check_repeat (gfc_expr *, gfc_expr *);
 gfc_try gfc_check_reshape (gfc_expr *, gfc_expr *, gfc_expr *, gfc_expr *);
+gfc_try gfc_check_same_type_as (gfc_expr *, gfc_expr *);
 gfc_try gfc_check_scale (gfc_expr *, gfc_expr *);
 gfc_try gfc_check_scan (gfc_expr *, gfc_expr *, gfc_expr *, gfc_expr *);
 gfc_try gfc_check_second_sub (gfc_expr *);
Index: gcc/fortran/gfortran.h
===================================================================
--- gcc/fortran/gfortran.h	(Revision 152201)
+++ gcc/fortran/gfortran.h	(Arbeitskopie)
@@ -475,6 +475,7 @@ enum gfc_isym_id
   GFC_ISYM_RESHAPE,
   GFC_ISYM_RRSPACING,
   GFC_ISYM_RSHIFT,
+  GFC_ISYM_SAME_TYPE_AS,
   GFC_ISYM_SC_KIND,
   GFC_ISYM_SCALE,
   GFC_ISYM_SCAN,
@@ -2626,6 +2627,7 @@ int gfc_is_formal_arg (void);
 void gfc_resolve_substring_charlen (gfc_expr *);
 match gfc_iso_c_sub_interface(gfc_code *, gfc_symbol *);
 gfc_expr *gfc_expr_to_initialize (gfc_expr *);
+bool gfc_type_is_extensible (gfc_symbol *sym);
 
 
 /* array.c */
Index: gcc/fortran/expr.c
===================================================================
--- gcc/fortran/expr.c	(Revision 152201)
+++ gcc/fortran/expr.c	(Arbeitskopie)
@@ -3368,7 +3368,8 @@ gfc_check_assign_symbol (gfc_symbol *sym, gfc_expr
 
   if (sym->attr.pointer || sym->attr.proc_pointer
       || (sym->ts.type == BT_CLASS 
-	  && sym->ts.u.derived->components->attr.pointer))
+	  && sym->ts.u.derived->components->attr.pointer
+	  && rvalue->expr_type == EXPR_NULL))
     r = gfc_check_pointer_assign (&lvalue, rvalue);
   else
     r = gfc_check_assign (&lvalue, rvalue, 1);
Index: gcc/fortran/resolve.c
===================================================================
--- gcc/fortran/resolve.c	(Revision 152201)
+++ gcc/fortran/resolve.c	(Arbeitskopie)
@@ -879,7 +879,10 @@ resolve_structure_cons (gfc_expr *expr)
 
       if (cons->expr->expr_type == EXPR_NULL
 	  && !(comp->attr.pointer || comp->attr.allocatable
-	       || comp->attr.proc_pointer))
+	       || comp->attr.proc_pointer
+	       || (comp->ts.type == BT_CLASS
+		   && (comp->ts.u.derived->components->attr.pointer
+		       || comp->ts.u.derived->components->attr.allocatable))))
 	{
 	  t = FAILURE;
 	  gfc_error ("The NULL in the derived type constructor at %L is "
@@ -6404,8 +6407,8 @@ resolve_select (gfc_code *code)
 
 /* Check if a derived type is extensible.  */
 
-static bool
-type_is_extensible (gfc_symbol *sym)
+bool
+gfc_type_is_extensible (gfc_symbol *sym)
 {
   return !(sym->attr.is_bind_c || sym->attr.sequence);
 }
@@ -6434,7 +6437,7 @@ resolve_select_type (gfc_code *code)
 
       /* Check F03:C815.  */
       if ((c->ts.type == BT_DERIVED || c->ts.type == BT_CLASS)
-	  && !type_is_extensible (c->ts.u.derived))
+	  && !gfc_type_is_extensible (c->ts.u.derived))
 	{
 	  gfc_error ("Derived type '%s' at %L must be extensible",
 		     c->ts.u.derived->name, &c->where);
@@ -7267,17 +7270,16 @@ resolve_class_assign (gfc_code *code)
   assign_code->expr1 = gfc_copy_expr (code->expr1);
   gfc_add_component_ref (assign_code->expr1, "$vindex");
   if (code->expr2->ts.type == BT_DERIVED)
-    {
-      /* vindex is constant, determined at compile time.  */
-      int vindex = code->expr2->ts.u.derived->vindex;
-      assign_code->expr2 = gfc_int_expr (vindex);
-    }
+    /* vindex is constant, determined at compile time.  */
+    assign_code->expr2 = gfc_int_expr (code->expr2->ts.u.derived->vindex);
   else if (code->expr2->ts.type == BT_CLASS)
     {
       /* vindex must be determined at run time.  */
       assign_code->expr2 = gfc_copy_expr (code->expr2);
       gfc_add_component_ref (assign_code->expr2, "$vindex");
     }
+  else if (code->expr2->expr_type == EXPR_NULL)
+    assign_code->expr2 = gfc_int_expr (0);
   else
     gcc_unreachable ();
 
@@ -8279,7 +8281,7 @@ resolve_fl_variable_derived (gfc_symbol *sym, int
   if (sym->ts.type == BT_CLASS)
     {
       /* C502.  */
-      if (!type_is_extensible (sym->ts.u.derived->components->ts.u.derived))
+      if (!gfc_type_is_extensible (sym->ts.u.derived->components->ts.u.derived))
 	{
 	  gfc_error ("Type '%s' of CLASS variable '%s' at %L is not extensible",
 		     sym->ts.u.derived->name, sym->name, &sym->declared_at);
@@ -9665,7 +9667,7 @@ resolve_fl_derived (gfc_symbol *sym)
     return FAILURE;
 
   /* An ABSTRACT type must be extensible.  */
-  if (sym->attr.abstract && !type_is_extensible (sym))
+  if (sym->attr.abstract && !gfc_type_is_extensible (sym))
     {
       gfc_error ("Non-extensible derived-type '%s' at %L must not be ABSTRACT",
 		 sym->name, &sym->declared_at);
@@ -9841,7 +9843,7 @@ resolve_fl_derived (gfc_symbol *sym)
 	      return FAILURE;
 	    }
 
-	  if (type_is_extensible (sym) && me_arg->ts.type != BT_CLASS)
+	  if (gfc_type_is_extensible (sym) && me_arg->ts.type != BT_CLASS)
 	    gfc_error ("Non-polymorphic passed-object dummy argument of '%s'"
 		       " at %L", c->name, &c->loc);
 
Index: gcc/fortran/check.c
===================================================================
--- gcc/fortran/check.c	(Revision 152201)
+++ gcc/fortran/check.c	(Arbeitskopie)
@@ -2641,6 +2641,46 @@ gfc_check_reshape (gfc_expr *source, gfc_expr *sha
 
 
 gfc_try
+gfc_check_same_type_as (gfc_expr *a, gfc_expr *b)
+{
+
+  if (a->ts.type != BT_DERIVED && a->ts.type != BT_CLASS)
+    {
+      gfc_error ("'%s' argument of '%s' intrinsic at %L "
+		 "must be of a derived type", gfc_current_intrinsic_arg[0],
+		 gfc_current_intrinsic, &a->where);
+      return FAILURE;
+    }
+
+  if (!gfc_type_is_extensible (a->ts.u.derived))
+    {
+      gfc_error ("'%s' argument of '%s' intrinsic at %L "
+		 "must be of an extensible type", gfc_current_intrinsic_arg[0],
+		 gfc_current_intrinsic, &a->where);
+      return FAILURE;
+    }
+
+  if (b->ts.type != BT_DERIVED && b->ts.type != BT_CLASS)
+    {
+      gfc_error ("'%s' argument of '%s' intrinsic at %L "
+		 "must be of a derived type", gfc_current_intrinsic_arg[1],
+		 gfc_current_intrinsic, &b->where);
+      return FAILURE;
+    }
+
+  if (!gfc_type_is_extensible (b->ts.u.derived))
+    {
+      gfc_error ("'%s' argument of '%s' intrinsic at %L "
+		 "must be of an extensible type", gfc_current_intrinsic_arg[1],
+		 gfc_current_intrinsic, &b->where);
+      return FAILURE;
+    }
+
+  return SUCCESS;
+}
+
+
+gfc_try
 gfc_check_scale (gfc_expr *x, gfc_expr *i)
 {
   if (type_check (x, 0, BT_REAL) == FAILURE)
Index: gcc/fortran/primary.c
===================================================================
--- gcc/fortran/primary.c	(Revision 152201)
+++ gcc/fortran/primary.c	(Arbeitskopie)
@@ -2074,7 +2074,16 @@ gfc_expr_attr (gfc_expr *e)
       gfc_clear_attr (&attr);
 
       if (e->value.function.esym != NULL)
-	attr = e->value.function.esym->result->attr;
+	{
+	  gfc_symbol *sym = e->value.function.esym->result;
+	  attr = sym->attr;
+	  if (sym->ts.type == BT_CLASS)
+	    {
+	      attr.dimension = sym->ts.u.derived->components->attr.dimension;
+	      attr.pointer = sym->ts.u.derived->components->attr.pointer;
+	      attr.allocatable = sym->ts.u.derived->components->attr.allocatable;
+	    }
+	}
       else
 	attr = gfc_variable_attr (e, NULL);
 
Index: gcc/fortran/trans-intrinsic.c
===================================================================
--- gcc/fortran/trans-intrinsic.c	(Revision 152201)
+++ gcc/fortran/trans-intrinsic.c	(Arbeitskopie)
@@ -4700,6 +4700,41 @@ gfc_conv_associated (gfc_se *se, gfc_expr *expr)
 }
 
 
+/* Generate code for the SAME_TYPE_AS intrinsic.
+   Generate inline code that directly checks the vindices.  */
+
+static void
+gfc_conv_same_type_as (gfc_se *se, gfc_expr *expr)
+{
+  gfc_expr *a, *b;
+  gfc_se se1, se2;
+  tree tmp;
+
+  gfc_init_se (&se1, NULL);
+  gfc_init_se (&se2, NULL);
+
+  a = expr->value.function.actual->expr;
+  b = expr->value.function.actual->next->expr;
+
+  if (a->ts.type == BT_CLASS)
+    gfc_add_component_ref (a, "$vindex");
+  else if (a->ts.type == BT_DERIVED)
+    a = gfc_int_expr (a->ts.u.derived->vindex);
+
+  if (b->ts.type == BT_CLASS)
+    gfc_add_component_ref (b, "$vindex");
+  else if (b->ts.type == BT_DERIVED)
+    b = gfc_int_expr (b->ts.u.derived->vindex);
+
+  gfc_conv_expr (&se1, a);
+  gfc_conv_expr (&se2, b);
+
+  tmp = fold_build2 (EQ_EXPR, boolean_type_node,
+		     se1.expr, fold_convert (TREE_TYPE (se1.expr), se2.expr));
+  se->expr = convert (gfc_typenode_for_spec (&expr->ts), tmp);
+}
+
+
 /* Generate code for SELECTED_CHAR_KIND (NAME) intrinsic function.  */
 
 static void
@@ -5108,6 +5143,10 @@ gfc_conv_intrinsic_function (gfc_se * se, gfc_expr
       gfc_conv_associated(se, expr);
       break;
 
+    case GFC_ISYM_SAME_TYPE_AS:
+      gfc_conv_same_type_as (se, expr);
+      break;
+
     case GFC_ISYM_ABS:
       gfc_conv_intrinsic_abs (se, expr);
       break;

Attachment: same_type_as_1.f90
Description: Binary data

Attachment: same_type_as_2.f90
Description: Binary data