Patchwork [Fortran] Add parsing support for assumed-rank array

login
register
mail settings
Submitter Tobias Burnus
Date July 19, 2012, 8:21 p.m.
Message ID <50086C3E.8080608@net-b.de>
Download mbox | patch
Permalink /patch/172057/
State New
Headers show

Comments

Tobias Burnus - July 19, 2012, 8:21 p.m.
Mikael Morin wrote:
> The four of them are not directly related to the assumed rank stuff, and
> thus deserve a separate commit.
> As you said:
>> >* Unrelated bug fixes, found when writing the test cases and thus
> included:
> I assume they don't need testcases of their own, so that they are
> approved as is.
>

Thanks for the review. I have committed them – after regtesting – as 
Rev. 189669 (interface.c) and Rev. 189678 (resolve.c, interface.c).

I will now have a look at the other review comments and your patch.

Thanks for walking through the big patch.

  * * *

Patches with pending review:

* Allowed assumed-shape with bind(C) [TS29113]: 
http://gcc.gnu.org/ml/fortran/2012-07/msg00086.html
* C_F_POINTER changes for the fortran-dev branch: 
http://gcc.gnu.org/ml/fortran/2012-07/msg00045.html

Tobias

Patch

Index: trans-expr.c
===================================================================
--- trans-expr.c	(Revision 189675)
+++ trans-expr.c	(Arbeitskopie)
@@ -3620,10 +3620,15 @@  gfc_conv_procedure_call (gfc_se * se, gfc_symbol *
 		parmse.string_length = build_int_cst (gfc_charlen_type_node, 0);
 	    }
 	}
-      else if (arg->expr->expr_type == EXPR_NULL && fsym && !fsym->attr.pointer)
+      else if (arg->expr->expr_type == EXPR_NULL
+	       && fsym && !fsym->attr.pointer
+	       && (fsym->ts.type != BT_CLASS
+		   || !CLASS_DATA (fsym)->attr.class_pointer))
 	{
 	  /* Pass a NULL pointer to denote an absent arg.  */
-	  gcc_assert (fsym->attr.optional && !fsym->attr.allocatable);
+	  gcc_assert (fsym->attr.optional && !fsym->attr.allocatable
+		      && (fsym->ts.type != BT_CLASS
+			  || !CLASS_DATA (fsym)->attr.allocatable));
 	  gfc_init_se (&parmse, NULL);
 	  parmse.expr = null_pointer_node;
 	  if (arg->missing_arg_type == BT_CHARACTER)
Index: ChangeLog
===================================================================
--- ChangeLog	(Revision 189675)
+++ ChangeLog	(Arbeitskopie)
@@ -1,5 +1,12 @@ 
 2012-07-19  Tobias Burnus  <burnus@net-b.de>
 
+	* trans-expr.c (gfc_conv_procedure_call): Fix handling
+	of polymorphic arguments.
+	* resolve.c (resolve_formal_arglist): Ditto, mark polymorphic
+	assumed-shape arrays as such.
+
+2012-07-19  Tobias Burnus  <burnus@net-b.de>
+
 	* interface.c (compare_parameter, compare_actual_formal): Fix
 	handling of polymorphic arguments.
 
Index: resolve.c
===================================================================
--- resolve.c	(Revision 189675)
+++ resolve.c	(Arbeitskopie)
@@ -251,6 +251,7 @@  resolve_formal_arglist (gfc_symbol *proc)
   for (f = proc->formal; f; f = f->next)
     {
       sym = f->sym;
+      gfc_array_spec *as;
 
       if (sym == NULL)
 	{
@@ -284,23 +285,33 @@  resolve_formal_arglist (gfc_symbol *proc)
 	    gfc_set_default_type (sym, 1, sym->ns);
 	}
 
-      gfc_resolve_array_spec (sym->as, 0);
+      as = sym->ts.type == BT_CLASS && sym->attr.class_ok
+	   ? CLASS_DATA (sym)->as : sym->as;
 
+      gfc_resolve_array_spec (as, 0);
+
       /* We can't tell if an array with dimension (:) is assumed or deferred
 	 shape until we know if it has the pointer or allocatable attributes.
       */
-      if (sym->as && sym->as->rank > 0 && sym->as->type == AS_DEFERRED
-	  && !(sym->attr.pointer || sym->attr.allocatable)
+      if (as && as->rank > 0 && as->type == AS_DEFERRED
+	  && ((sym->ts.type != BT_CLASS
+	       && !(sym->attr.pointer || sym->attr.allocatable))
+              || (sym->ts.type == BT_CLASS
+		  && !(CLASS_DATA (sym)->attr.class_pointer
+		       || CLASS_DATA (sym)->attr.allocatable)))
 	  && sym->attr.flavor != FL_PROCEDURE)
 	{
-	  sym->as->type = AS_ASSUMED_SHAPE;
-	  for (i = 0; i < sym->as->rank; i++)
-	    sym->as->lower[i] = gfc_get_int_expr (gfc_default_integer_kind,
-						  NULL, 1);
+	  as->type = AS_ASSUMED_SHAPE;
+	  for (i = 0; i < as->rank; i++)
+	    as->lower[i] = gfc_get_int_expr (gfc_default_integer_kind, NULL, 1);
 	}
 
-      if ((sym->as && sym->as->rank > 0 && sym->as->type == AS_ASSUMED_SHAPE)
+      if ((as && as->rank > 0 && as->type == AS_ASSUMED_SHAPE)
 	  || sym->attr.pointer || sym->attr.allocatable || sym->attr.target
+	  || (sym->ts.type == BT_CLASS && sym->attr.class_ok
+	      && (CLASS_DATA (sym)->attr.class_pointer
+		  || CLASS_DATA (sym)->attr.allocatable
+		  || CLASS_DATA (sym)->attr.target))
 	  || sym->attr.optional)
 	{
 	  proc->attr.always_explicit = 1;