re PR fortran/50981 ([OOP] Wrong-code for scalarizing ELEMENTAL call with absent OPTIONAL argument)

2012-10-16  Tobias Burnus  <burnus@net-b.de>

        PR fortran/50981
        PR fortran/54618
        * trans.h (gfc_conv_derived_to_class, gfc_conv_class_to_class):
        Update prototype.
        * trans-stmt.c (trans_associate_var,gfc_trans_allocate): Update
        calls to those functions.
        * trans-expr.c (gfc_conv_derived_to_class,
        * gfc_conv_class_to_class,
        gfc_conv_expr_present): Handle absent polymorphic arguments.
        (class_scalar_coarray_to_class): New function.
        (gfc_conv_procedure_call): Update calls.

2012-10-16  Tobias Burnus  <burnus@net-b.de>

        PR fortran/50981
        PR fortran/54618
        * gfortran.dg/class_optional_1.f90: New.
        * gfortran.dg/class_optional_2.f90: New.

From-SVN: r192495

gcc/fortran/ChangeLog

+2012-10-16  Tobias Burnus  <burnus@net-b.de>
+
+	PR fortran/50981
+	PR fortran/54618
+	* trans.h (gfc_conv_derived_to_class, gfc_conv_class_to_class):
+	Update prototype.
+	* trans-stmt.c (trans_associate_var,gfc_trans_allocate): Update
+	calls to those functions.
+	* trans-expr.c (gfc_conv_derived_to_class, gfc_conv_class_to_class,
+	gfc_conv_expr_present): Handle absent polymorphic arguments.
+	(class_scalar_coarray_to_class): New function.
+	(gfc_conv_procedure_call): Update calls.
+
 2012-10-12  Janus Weil  <janus@gcc.gnu.org>
 
 	PR fortran/40453

gcc/fortran/trans-expr.c

@@ -231,12 +231,16 @@ class_array_data_assign (stmtblock_t *block, tree lhs_desc, tree rhs_desc,
 
 /* Takes a derived type expression and returns the address of a temporary
    class object of the 'declared' type.  If vptr is not NULL, this is
-   used for the temporary class object.  */ 
+   used for the temporary class object.
+   optional_alloc_ptr is false when the dummy is neither allocatable
+   nor a pointer; that's only relevant for the optional handling.  */
 void
 gfc_conv_derived_to_class (gfc_se *parmse, gfc_expr *e,
-			   gfc_typespec class_ts, tree vptr)
+			   gfc_typespec class_ts, tree vptr, bool optional,
+			   bool optional_alloc_ptr)
 {
   gfc_symbol *vtab;
+  tree cond_optional = NULL_TREE;
   gfc_ss *ss;
   tree ctree;
   tree var;
@@ -269,13 +273,21 @@ gfc_conv_derived_to_class (gfc_se *parmse, gfc_expr *e,
   /* Now set the data field.  */
   ctree =  gfc_class_data_get (var);
 
+  if (optional)
+    cond_optional = gfc_conv_expr_present (e->symtree->n.sym);
+
   if (parmse->ss && parmse->ss->info->useflags)
     {
       /* For an array reference in an elemental procedure call we need
 	 to retain the ss to provide the scalarized array reference.  */
       gfc_conv_expr_reference (parmse, e);
       tmp = fold_convert (TREE_TYPE (ctree), parmse->expr);
+      if (optional)
+	tmp = build3_loc (input_location, COND_EXPR, TREE_TYPE (tmp),
+			  cond_optional, tmp,
+			  fold_convert (TREE_TYPE (tmp), null_pointer_node));
       gfc_add_modify (&parmse->pre, ctree, tmp);
+
     }
   else
     {
@@ -293,28 +305,145 @@ gfc_conv_derived_to_class (gfc_se *parmse, gfc_expr *e,
 						    gfc_expr_attr (e));
 	      gfc_add_modify (&parmse->pre, gfc_conv_descriptor_dtype (ctree),
 			      gfc_get_dtype (type));
+	      if (optional)
+		parmse->expr = build3_loc (input_location, COND_EXPR,
+					   TREE_TYPE (parmse->expr),
+					   cond_optional, parmse->expr,
+					   fold_convert (TREE_TYPE (parmse->expr),
+							 null_pointer_node));
 	      gfc_conv_descriptor_data_set (&parmse->pre, ctree, parmse->expr);
 	    }
           else
 	    {
 	      tmp = fold_convert (TREE_TYPE (ctree), parmse->expr);
+	      if (optional)
+		tmp = build3_loc (input_location, COND_EXPR, TREE_TYPE (tmp),
+				  cond_optional, tmp,
+				  fold_convert (TREE_TYPE (tmp),
+						null_pointer_node));
 	      gfc_add_modify (&parmse->pre, ctree, tmp);
 	    }
 	}
       else
 	{
+	  stmtblock_t block;
+	  gfc_init_block (&block);
+
 	  parmse->ss = ss;
 	  gfc_conv_expr_descriptor (parmse, e);
 
 	  if (e->rank != class_ts.u.derived->components->as->rank)
-	    class_array_data_assign (&parmse->pre, ctree, parmse->expr, true);
+	    class_array_data_assign (&block, ctree, parmse->expr, true);
+	  else
+	    {
+	      if (gfc_expr_attr (e).codimension)
+		parmse->expr = fold_build1_loc (input_location,
+						VIEW_CONVERT_EXPR,
+						TREE_TYPE (ctree),
+						parmse->expr);
+	      gfc_add_modify (&block, ctree, parmse->expr);
+	    }
+
+	  if (optional)
+	    {
+	      tmp = gfc_finish_block (&block);
+
+	      gfc_init_block (&block);
+	      gfc_conv_descriptor_data_set (&block, ctree, null_pointer_node);
+
+	      tmp = build3_v (COND_EXPR, cond_optional, tmp,
+			      gfc_finish_block (&block));
+	      gfc_add_expr_to_block (&parmse->pre, tmp);
+	    }
 	  else
-	    gfc_add_modify (&parmse->pre, ctree, parmse->expr);
+	    gfc_add_block_to_block (&parmse->pre, &block);
 	}
     }
 
   /* Pass the address of the class object.  */
   parmse->expr = gfc_build_addr_expr (NULL_TREE, var);
+
+  if (optional && optional_alloc_ptr)
+    parmse->expr = build3_loc (input_location, COND_EXPR,
+			       TREE_TYPE (parmse->expr),
+			       cond_optional, parmse->expr,
+			       fold_convert (TREE_TYPE (parmse->expr),
+					     null_pointer_node));
+}
+
+
+/* Create a new class container, which is required as scalar coarrays
+   have an array descriptor while normal scalars haven't. Optionally,
+   NULL pointer checks are added if the argument is OPTIONAL.  */
+
+static void
+class_scalar_coarray_to_class (gfc_se *parmse, gfc_expr *e,
+			       gfc_typespec class_ts, bool optional)
+{
+  tree var, ctree, tmp;
+  stmtblock_t block;
+  gfc_ref *ref;
+  gfc_ref *class_ref;
+
+  gfc_init_block (&block);
+
+  class_ref = NULL;
+  for (ref = e->ref; ref; ref = ref->next)
+    {
+      if (ref->type == REF_COMPONENT
+	    && ref->u.c.component->ts.type == BT_CLASS)
+	class_ref = ref;
+    }
+
+  if (class_ref == NULL
+	&& e->symtree && e->symtree->n.sym->ts.type == BT_CLASS)
+    tmp = e->symtree->n.sym->backend_decl;
+  else
+    {
+      /* Remove everything after the last class reference, convert the
+	 expression and then recover its tailend once more.  */
+      gfc_se tmpse;
+      ref = class_ref->next;
+      class_ref->next = NULL;
+      gfc_init_se (&tmpse, NULL);
+      gfc_conv_expr (&tmpse, e);
+      class_ref->next = ref;
+      tmp = tmpse.expr;
+    }
+
+  var = gfc_typenode_for_spec (&class_ts);
+  var = gfc_create_var (var, "class");
+
+  ctree = gfc_class_vptr_get (var);
+  gfc_add_modify (&block, ctree,
+		  fold_convert (TREE_TYPE (ctree), gfc_class_vptr_get (tmp)));
+
+  ctree = gfc_class_data_get (var);
+  tmp = gfc_conv_descriptor_data_get (gfc_class_data_get (tmp));
+  gfc_add_modify (&block, ctree, fold_convert (TREE_TYPE (ctree), tmp));
+
+  /* Pass the address of the class object.  */
+  parmse->expr = gfc_build_addr_expr (NULL_TREE, var);
+
+  if (optional)
+    {
+      tree cond = gfc_conv_expr_present (e->symtree->n.sym);
+      tree tmp2;
+
+      tmp = gfc_finish_block (&block);
+
+      gfc_init_block (&block);
+      tmp2 = gfc_class_data_get (var);
+      gfc_add_modify (&block, tmp2, fold_convert (TREE_TYPE (tmp2),
+						  null_pointer_node));
+      tmp2 = gfc_finish_block (&block);
+
+      tmp = build3_loc (input_location, COND_EXPR, void_type_node,
+			cond, tmp, tmp2);
+      gfc_add_expr_to_block (&parmse->pre, tmp);
+    }
+  else
+    gfc_add_block_to_block (&parmse->pre, &block);
 }
 
 
@@ -323,19 +452,29 @@ gfc_conv_derived_to_class (gfc_se *parmse, gfc_expr *e,
    type.  
    OOP-TODO: This could be improved by adding code that branched on
    the dynamic type being the same as the declared type. In this case
-   the original class expression can be passed directly.  */ 
+   the original class expression can be passed directly.
+   optional_alloc_ptr is false when the dummy is neither allocatable
+   nor a pointer; that's relevant for the optional handling.
+   Set copyback to true if class container's _data and _vtab pointers
+   might get modified.  */
+
 void
-gfc_conv_class_to_class (gfc_se *parmse, gfc_expr *e,
-			 gfc_typespec class_ts, bool elemental)
+gfc_conv_class_to_class (gfc_se *parmse, gfc_expr *e, gfc_typespec class_ts,
+			 bool elemental, bool copyback, bool optional,
+		         bool optional_alloc_ptr)
 {
   tree ctree;
   tree var;
   tree tmp;
   tree vptr;
+  tree cond = NULL_TREE;
   gfc_ref *ref;
   gfc_ref *class_ref;
+  stmtblock_t block;
   bool full_array = false;
 
+  gfc_init_block (&block);
+
   class_ref = NULL;
   for (ref = e->ref; ref; ref = ref->next)
     {
@@ -353,7 +492,11 @@ gfc_conv_class_to_class (gfc_se *parmse, gfc_expr *e,
     return;
 
   /* Test for FULL_ARRAY.  */
-  gfc_is_class_array_ref (e, &full_array);
+  if (e->rank == 0 && gfc_expr_attr (e).codimension
+      && gfc_expr_attr (e).dimension)
+    full_array = true;
+  else
+    gfc_is_class_array_ref (e, &full_array);
 
   /* The derived type needs to be converted to a temporary
      CLASS object.  */
@@ -369,22 +512,30 @@ gfc_conv_class_to_class (gfc_se *parmse, gfc_expr *e,
 	{
 	  tree type = get_scalar_to_descriptor_type (parmse->expr,
 						     gfc_expr_attr (e));
-	  gfc_add_modify (&parmse->pre, gfc_conv_descriptor_dtype (ctree),
+	  gfc_add_modify (&block, gfc_conv_descriptor_dtype (ctree),
 			  gfc_get_dtype (type));
-	  gfc_conv_descriptor_data_set (&parmse->pre, ctree,
-					gfc_class_data_get (parmse->expr));
 
+	  tmp = gfc_class_data_get (parmse->expr);
+	  if (!POINTER_TYPE_P (TREE_TYPE (tmp)))
+	    tmp = gfc_build_addr_expr (NULL_TREE, tmp);
+
+	  gfc_conv_descriptor_data_set (&block, ctree, tmp);
 	}
       else
-	class_array_data_assign (&parmse->pre, ctree, parmse->expr, false);
+	class_array_data_assign (&block, ctree, parmse->expr, false);
     }
   else
-    gfc_add_modify (&parmse->pre, ctree, parmse->expr);
+    {
+      if (CLASS_DATA (e)->attr.codimension)
+	parmse->expr = fold_build1_loc (input_location, VIEW_CONVERT_EXPR,
+					TREE_TYPE (ctree), parmse->expr);
+      gfc_add_modify (&block, ctree, parmse->expr);
+    }
 
   /* Return the data component, except in the case of scalarized array
      references, where nullification of the cannot occur and so there
      is no need.  */
-  if (!elemental && full_array)
+  if (!elemental && full_array && copyback)
     {
       if (class_ts.u.derived->components->as
 	  && e->rank != class_ts.u.derived->components->as->rank)
@@ -429,17 +580,51 @@ gfc_conv_class_to_class (gfc_se *parmse, gfc_expr *e,
     tmp = build_fold_indirect_ref_loc (input_location, tmp);
 
   vptr = gfc_class_vptr_get (tmp);
-  gfc_add_modify (&parmse->pre, ctree,
+  gfc_add_modify (&block, ctree,
 		  fold_convert (TREE_TYPE (ctree), vptr));
 
   /* Return the vptr component, except in the case of scalarized array
      references, where the dynamic type cannot change.  */
-  if (!elemental && full_array)
+  if (!elemental && full_array && copyback)
     gfc_add_modify (&parmse->post, vptr,
 		    fold_convert (TREE_TYPE (vptr), ctree));
 
+  gcc_assert (!optional || (optional && !copyback));
+  if (optional)
+    {
+      tree tmp2;
+
+      cond = gfc_conv_expr_present (e->symtree->n.sym);
+      tmp = gfc_finish_block (&block);
+
+      if (optional_alloc_ptr)
+	tmp2 = build_empty_stmt (input_location);
+      else
+	{
+	  gfc_init_block (&block);
+
+	  tmp2 = gfc_conv_descriptor_data_get (gfc_class_data_get (var));
+	  gfc_add_modify (&block, tmp2, fold_convert (TREE_TYPE (tmp2),
+						      null_pointer_node));
+	  tmp2 = gfc_finish_block (&block);
+	}
+
+      tmp = build3_loc (input_location, COND_EXPR, void_type_node,
+			cond, tmp, tmp2);
+      gfc_add_expr_to_block (&parmse->pre, tmp);
+    }
+  else
+    gfc_add_block_to_block (&parmse->pre, &block);
+
   /* Pass the address of the class object.  */
   parmse->expr = gfc_build_addr_expr (NULL_TREE, var);
+
+  if (optional && optional_alloc_ptr)
+    parmse->expr = build3_loc (input_location, COND_EXPR,
+			       TREE_TYPE (parmse->expr),
+			       cond, parmse->expr,
+			       fold_convert (TREE_TYPE (parmse->expr),
+					     null_pointer_node));
 }
 
 
@@ -857,19 +1042,43 @@ gfc_conv_expr_present (gfc_symbol * sym)
 
   /* Fortran 2008 allows to pass null pointers and non-associated pointers
      as actual argument to denote absent dummies. For array descriptors,
-     we thus also need to check the array descriptor.  */
-  if (!sym->attr.pointer && !sym->attr.allocatable
-      && sym->as && (sym->as->type == AS_ASSUMED_SHAPE
-		     || sym->as->type == AS_ASSUMED_RANK)
-      && (gfc_option.allow_std & GFC_STD_F2008) != 0)
+     we thus also need to check the array descriptor.  For BT_CLASS, it
+     can also occur for scalars and F2003 due to type->class wrapping and
+     class->class wrapping.  Note futher that BT_CLASS always uses an
+     array descriptor for arrays, also for explicit-shape/assumed-size.  */
+
+  if (!sym->attr.allocatable
+      && ((sym->ts.type != BT_CLASS && !sym->attr.pointer)
+	  || (sym->ts.type == BT_CLASS
+	      && !CLASS_DATA (sym)->attr.allocatable
+	      && !CLASS_DATA (sym)->attr.class_pointer))
+      && ((gfc_option.allow_std & GFC_STD_F2008) != 0
+	  || sym->ts.type == BT_CLASS))
     {
       tree tmp;
-      tmp = build_fold_indirect_ref_loc (input_location, decl);
-      tmp = gfc_conv_array_data (tmp);
-      tmp = fold_build2_loc (input_location, NE_EXPR, boolean_type_node, tmp,
-			     fold_convert (TREE_TYPE (tmp), null_pointer_node));
-      cond = fold_build2_loc (input_location, TRUTH_ANDIF_EXPR,
-			      boolean_type_node, cond, tmp);
+
+      if ((sym->as && (sym->as->type == AS_ASSUMED_SHAPE
+		       || sym->as->type == AS_ASSUMED_RANK
+		       || sym->attr.codimension))
+	  || (sym->ts.type == BT_CLASS && CLASS_DATA (sym)->as))
+	{
+	  tmp = build_fold_indirect_ref_loc (input_location, decl);
+	  if (sym->ts.type == BT_CLASS)
+	    tmp = gfc_class_data_get (tmp);
+	  tmp = gfc_conv_array_data (tmp);
+	}
+      else if (sym->ts.type == BT_CLASS)
+	tmp = gfc_class_data_get (decl);
+      else
+	tmp = NULL_TREE;
+
+      if (tmp != NULL_TREE)
+	{
+	  tmp = fold_build2_loc (input_location, NE_EXPR, boolean_type_node, tmp,
+				 fold_convert (TREE_TYPE (tmp), null_pointer_node));
+	  cond = fold_build2_loc (input_location, TRUTH_ANDIF_EXPR,
+				  boolean_type_node, cond, tmp);
+	}
     }
 
   return cond;
@@ -3714,7 +3923,8 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym,
       if (e && e->expr_type == EXPR_VARIABLE
 	    && !e->ref
 	    && e->ts.type == BT_CLASS
-	    && CLASS_DATA (e)->attr.dimension)
+	    && (CLASS_DATA (e)->attr.codimension
+		|| CLASS_DATA (e)->attr.dimension))
 	{
 	  gfc_typespec temp_ts = e->ts;
 	  gfc_add_class_array_ref (e);
@@ -3763,7 +3973,12 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym,
 	  /* The derived type needs to be converted to a temporary
 	     CLASS object.  */
 	  gfc_init_se (&parmse, se);
-	  gfc_conv_derived_to_class (&parmse, e, fsym->ts, NULL);
+	  gfc_conv_derived_to_class (&parmse, e, fsym->ts, NULL,
+				     fsym->attr.optional
+				     && e->expr_type == EXPR_VARIABLE
+				     && e->symtree->n.sym->attr.optional,
+				     CLASS_DATA (fsym)->attr.class_pointer
+				     || CLASS_DATA (fsym)->attr.allocatable);
 	}
       else if (se->ss && se->ss->info->useflags)
 	{
@@ -3789,7 +4004,20 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym,
 
 	  if (fsym && fsym->ts.type == BT_DERIVED
 	      && gfc_is_class_container_ref (e))
-	    parmse.expr = gfc_class_data_get (parmse.expr);
+	    {
+	      parmse.expr = gfc_class_data_get (parmse.expr);
+
+	      if (fsym->attr.optional && e->expr_type == EXPR_VARIABLE
+		  && e->symtree->n.sym->attr.optional)
+		{
+		  tree cond = gfc_conv_expr_present (e->symtree->n.sym);
+		  parmse.expr = build3_loc (input_location, COND_EXPR,
+					TREE_TYPE (parmse.expr),
+					cond, parmse.expr,
+					fold_convert (TREE_TYPE (parmse.expr),
+						      null_pointer_node));
+		}
+	    }
 
 	  /* If we are passing an absent array as optional dummy to an
 	     elemental procedure, make sure that we pass NULL when the data
@@ -3817,13 +4045,23 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym,
 	  /* The scalarizer does not repackage the reference to a class
 	     array - instead it returns a pointer to the data element.  */
 	  if (fsym && fsym->ts.type == BT_CLASS && e->ts.type == BT_CLASS)
-	    gfc_conv_class_to_class (&parmse, e, fsym->ts, true);
+	    gfc_conv_class_to_class (&parmse, e, fsym->ts, true,
+				     fsym->attr.intent != INTENT_IN
+				     && (CLASS_DATA (fsym)->attr.class_pointer
+					 || CLASS_DATA (fsym)->attr.allocatable),
+				     fsym->attr.optional
+				     && e->expr_type == EXPR_VARIABLE
+				     && e->symtree->n.sym->attr.optional,
+				     CLASS_DATA (fsym)->attr.class_pointer
+				     || CLASS_DATA (fsym)->attr.allocatable);
 	}
       else
 	{
 	  bool scalar;
 	  gfc_ss *argss;
 
+	  gfc_init_se (&parmse, NULL);
+
 	  /* Check whether the expression is a scalar or not; we cannot use
 	     e->rank as it can be nonzero for functions arguments.  */
 	  argss = gfc_walk_expr (e);
@@ -3831,9 +4069,19 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym,
 	  if (!scalar)
 	    gfc_free_ss_chain (argss);
 
+	  /* Special handling for passing scalar polymorphic coarrays;
+	     otherwise one passes "class->_data.data" instead of "&class".  */
+	  if (e->rank == 0 && e->ts.type == BT_CLASS
+	      && fsym && fsym->ts.type == BT_CLASS
+	      && CLASS_DATA (fsym)->attr.codimension
+	      && !CLASS_DATA (fsym)->attr.dimension)
+	    {
+	      gfc_add_class_array_ref (e);
+              parmse.want_coarray = 1;
+	      scalar = false;
+	    }
+
 	  /* A scalar or transformational function.  */
-	  gfc_init_se (&parmse, NULL);
-          
 	  if (scalar)
 	    {
 	      if (e->expr_type == EXPR_VARIABLE
@@ -3888,7 +4136,23 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym,
 		}
 	      else
 		{
-		  gfc_conv_expr_reference (&parmse, e);
+		  if (e->ts.type == BT_CLASS && fsym
+		      && fsym->ts.type == BT_CLASS
+		      && (!CLASS_DATA (fsym)->as
+			  || CLASS_DATA (fsym)->as->type != AS_ASSUMED_RANK)
+		      && CLASS_DATA (e)->attr.codimension)
+		    {
+		      gcc_assert (!CLASS_DATA (fsym)->attr.codimension);
+		      gcc_assert (!CLASS_DATA (fsym)->as);
+		      gfc_add_class_array_ref (e);
+		      parmse.want_coarray = 1;
+		      gfc_conv_expr_reference (&parmse, e);
+		      class_scalar_coarray_to_class (&parmse, e, fsym->ts,
+				     fsym->attr.optional
+				     && e->expr_type == EXPR_VARIABLE);
+		    }
+		  else
+		    gfc_conv_expr_reference (&parmse, e);
 
 		  /* Catch base objects that are not variables.  */
 		  if (e->ts.type == BT_CLASS
@@ -3904,7 +4168,15 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym,
 			&& ((CLASS_DATA (fsym)->as
 			     && CLASS_DATA (fsym)->as->type == AS_ASSUMED_RANK)
 			    || CLASS_DATA (e)->attr.dimension))
-		    gfc_conv_class_to_class (&parmse, e, fsym->ts, false);
+		    gfc_conv_class_to_class (&parmse, e, fsym->ts, false,
+				     fsym->attr.intent != INTENT_IN
+				     && (CLASS_DATA (fsym)->attr.class_pointer
+					 || CLASS_DATA (fsym)->attr.allocatable),
+				     fsym->attr.optional
+				     && e->expr_type == EXPR_VARIABLE
+				     && e->symtree->n.sym->attr.optional,
+				     CLASS_DATA (fsym)->attr.class_pointer
+				     || CLASS_DATA (fsym)->attr.allocatable);
 
 		  if (fsym && (fsym->ts.type == BT_DERIVED
 			       || fsym->ts.type == BT_ASSUMED)
@@ -4005,14 +4277,22 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym,
 	    }
 	  else if (e->ts.type == BT_CLASS
 		    && fsym && fsym->ts.type == BT_CLASS
-		    && CLASS_DATA (fsym)->attr.dimension)
+		    && (CLASS_DATA (fsym)->attr.dimension
+			|| CLASS_DATA (fsym)->attr.codimension))
 	    {
 	      /* Pass a class array.  */
-	      gfc_init_se (&parmse, se);
 	      gfc_conv_expr_descriptor (&parmse, e);
 	      /* The conversion does not repackage the reference to a class
 	         array - _data descriptor.  */
-	      gfc_conv_class_to_class (&parmse, e, fsym->ts, false);
+	      gfc_conv_class_to_class (&parmse, e, fsym->ts, false,
+				     fsym->attr.intent != INTENT_IN
+				     && (CLASS_DATA (fsym)->attr.class_pointer
+					 || CLASS_DATA (fsym)->attr.allocatable),
+				     fsym->attr.optional
+				     && e->expr_type == EXPR_VARIABLE
+				     && e->symtree->n.sym->attr.optional,
+				     CLASS_DATA (fsym)->attr.class_pointer
+				     || CLASS_DATA (fsym)->attr.allocatable);
 	    }
 	  else
 	    {

gcc/fortran/trans-stmt.c

@@ -1228,7 +1228,7 @@ trans_associate_var (gfc_symbol *sym, gfc_wrapped_block *block)
 	  gfc_conv_expr_descriptor (&se, e);
 
 	  /* Obtain a temporary class container for the result.  */ 
-	  gfc_conv_class_to_class (&se, e, sym->ts, false);
+	  gfc_conv_class_to_class (&se, e, sym->ts, false, true, false, false);
 	  se.expr = build_fold_indirect_ref_loc (input_location, se.expr);
 
 	  /* Set the offset.  */
@@ -1255,7 +1255,7 @@ trans_associate_var (gfc_symbol *sym, gfc_wrapped_block *block)
 	  /* Get the _vptr component of the class object.  */ 
 	  tmp = gfc_get_vptr_from_expr (se.expr);
 	  /* Obtain a temporary class container for the result.  */
-	  gfc_conv_derived_to_class (&se, e, sym->ts, tmp);
+	  gfc_conv_derived_to_class (&se, e, sym->ts, tmp, false, false);
 	  se.expr = build_fold_indirect_ref_loc (input_location, se.expr);
 	}
       else
@@ -4874,7 +4874,7 @@ gfc_trans_allocate (gfc_code * code)
 	  gfc_init_se (&se_sz, NULL);
 	  gfc_conv_expr_reference (&se_sz, code->expr3);
 	  gfc_conv_class_to_class (&se_sz, code->expr3,
-				   code->expr3->ts, false);
+				   code->expr3->ts, false, true, false, false);
 	  gfc_add_block_to_block (&se.pre, &se_sz.pre);
 	  gfc_add_block_to_block (&se.post, &se_sz.post);
 	  classexpr = build_fold_indirect_ref_loc (input_location,

gcc/fortran/trans.h

@@ -351,8 +351,10 @@ tree gfc_vtable_copy_get (tree);
 tree gfc_get_vptr_from_expr (tree);
 tree gfc_get_class_array_ref (tree, tree);
 tree gfc_copy_class_to_class (tree, tree, tree);
-void gfc_conv_derived_to_class (gfc_se *, gfc_expr *, gfc_typespec, tree);
-void gfc_conv_class_to_class (gfc_se *, gfc_expr *, gfc_typespec, bool);
+void gfc_conv_derived_to_class (gfc_se *, gfc_expr *, gfc_typespec, tree, bool,
+				bool);
+void gfc_conv_class_to_class (gfc_se *, gfc_expr *, gfc_typespec, bool, bool,
+			      bool, bool);
 
 /* Initialize an init/cleanup block.  */
 void gfc_start_wrapped_block (gfc_wrapped_block* block, tree code);

gcc/testsuite/ChangeLog

+2012-10-16  Tobias Burnus  <burnus@net-b.de>
+
+	PR fortran/50981
+	PR fortran/54618
+	* gfortran.dg/class_optional_1.f90: New.
+	* gfortran.dg/class_optional_2.f90: New.
+
 2012-10-16  Jakub Jelinek  <jakub@redhat.com>
 
 	PR debug/54796

gcc/testsuite/gfortran.dg/class_optional_1.f90

+! { dg-do run }
+! { dg-options "-fcoarray=single" }
+!
+! PR fortran/50981
+! PR fortran/54618
+!
+
+  implicit none
+  type t
+   integer, allocatable :: i
+  end type t
+  type, extends (t):: t2
+   integer, allocatable :: j
+  end type t2
+
+  class(t), allocatable :: xa, xa2(:), xac[:], xa2c(:)[:]
+  class(t), pointer :: xp, xp2(:)
+
+  xp => null()
+  xp2 => null()
+
+  call suba(alloc=.false., prsnt=.false.)
+  call suba(xa, alloc=.false., prsnt=.true.)
+  if (.not. allocated (xa)) call abort ()
+  if (.not. allocated (xa%i)) call abort ()
+  if (xa%i /= 5) call abort ()
+  xa%i = -3
+  call suba(xa, alloc=.true., prsnt=.true.)
+  if (allocated (xa)) call abort ()
+
+  call suba2(alloc=.false., prsnt=.false.)
+  call suba2(xa2, alloc=.false., prsnt=.true.)
+  if (.not. allocated (xa2)) call abort ()
+  if (size (xa2) /= 1) call abort ()
+  if (.not. allocated (xa2(1)%i)) call abort ()
+  if (xa2(1)%i /= 5) call abort ()
+  xa2(1)%i = -3
+  call suba2(xa2, alloc=.true., prsnt=.true.)
+  if (allocated (xa2)) call abort ()
+
+  call subp(alloc=.false., prsnt=.false.)
+  call subp(xp, alloc=.false., prsnt=.true.)
+  if (.not. associated (xp)) call abort ()
+  if (.not. allocated (xp%i)) call abort ()
+  if (xp%i /= 5) call abort ()
+  xp%i = -3
+  call subp(xp, alloc=.true., prsnt=.true.)
+  if (associated (xp)) call abort ()
+
+  call subp2(alloc=.false., prsnt=.false.)
+  call subp2(xp2, alloc=.false., prsnt=.true.)
+  if (.not. associated (xp2)) call abort ()
+  if (size (xp2) /= 1) call abort ()
+  if (.not. allocated (xp2(1)%i)) call abort ()
+  if (xp2(1)%i /= 5) call abort ()
+  xp2(1)%i = -3
+  call subp2(xp2, alloc=.true., prsnt=.true.)
+  if (associated (xp2)) call abort ()
+
+  call subac(alloc=.false., prsnt=.false.)
+  call subac(xac, alloc=.false., prsnt=.true.)
+  if (.not. allocated (xac)) call abort ()
+  if (.not. allocated (xac%i)) call abort ()
+  if (xac%i /= 5) call abort ()
+  xac%i = -3
+  call subac(xac, alloc=.true., prsnt=.true.)
+  if (allocated (xac)) call abort ()
+
+  call suba2c(alloc=.false., prsnt=.false.)
+  call suba2c(xa2c, alloc=.false., prsnt=.true.)
+  if (.not. allocated (xa2c)) call abort ()
+  if (size (xa2c) /= 1) call abort ()
+  if (.not. allocated (xa2c(1)%i)) call abort ()
+  if (xa2c(1)%i /= 5) call abort ()
+  xa2c(1)%i = -3
+  call suba2c(xa2c, alloc=.true., prsnt=.true.)
+  if (allocated (xa2c)) call abort ()
+
+contains
+ subroutine suba2c(x, prsnt, alloc)
+   class(t), optional, allocatable :: x(:)[:]
+   logical prsnt, alloc
+   if (present (x) .neqv. prsnt) call abort ()
+   if (prsnt) then
+     if (alloc .neqv. allocated(x)) call abort ()
+     if (.not. allocated (x)) then
+       allocate (x(1)[*])
+       x(1)%i = 5
+     else
+       if (x(1)%i /= -3) call abort()
+       deallocate (x)
+     end if
+   end if
+ end subroutine suba2c
+
+ subroutine subac(x, prsnt, alloc)
+   class(t), optional, allocatable :: x[:]
+   logical prsnt, alloc
+   if (present (x) .neqv. prsnt) call abort ()
+   if (present (x)) then
+     if (alloc .neqv. allocated(x)) call abort ()
+     if (.not. allocated (x)) then
+       allocate (x[*])
+       x%i = 5
+     else
+       if (x%i /= -3) call abort()
+       deallocate (x)
+     end if
+   end if
+ end subroutine subac
+
+ subroutine suba2(x, prsnt, alloc)
+   class(t), optional, allocatable :: x(:)
+   logical prsnt, alloc
+   if (present (x) .neqv. prsnt) call abort ()
+   if (prsnt) then
+     if (alloc .neqv. allocated(x)) call abort ()
+     if (.not. allocated (x)) then
+       allocate (x(1))
+       x(1)%i = 5
+     else
+       if (x(1)%i /= -3) call abort()
+       deallocate (x)
+     end if
+   end if
+ end subroutine suba2
+
+ subroutine suba(x, prsnt, alloc)
+   class(t), optional, allocatable :: x
+   logical prsnt, alloc
+   if (present (x) .neqv. prsnt) call abort ()
+   if (present (x)) then
+     if (alloc .neqv. allocated(x)) call abort ()
+     if (.not. allocated (x)) then
+       allocate (x)
+       x%i = 5
+     else
+       if (x%i /= -3) call abort()
+       deallocate (x)
+     end if
+   end if
+ end subroutine suba
+
+ subroutine subp2(x, prsnt, alloc)
+   class(t), optional, pointer :: x(:)
+   logical prsnt, alloc
+   if (present (x) .neqv. prsnt) call abort ()
+   if (present (x)) then
+     if (alloc .neqv. associated(x)) call abort ()
+     if (.not. associated (x)) then
+       allocate (x(1))
+       x(1)%i = 5
+     else
+       if (x(1)%i /= -3) call abort()
+       deallocate (x)
+     end if
+   end if
+ end subroutine subp2
+
+ subroutine subp(x, prsnt, alloc)
+   class(t), optional, pointer :: x
+   logical prsnt, alloc
+   if (present (x) .neqv. prsnt) call abort ()
+   if (present (x)) then
+     if (alloc .neqv. associated(x)) call abort ()
+     if (.not. associated (x)) then
+       allocate (x)
+       x%i = 5
+     else
+       if (x%i /= -3) call abort()
+       deallocate (x)
+     end if
+   end if
+ end subroutine subp
+end

gcc/testsuite/gfortran.dg/class_optional_2.f90

+! { dg-do run }
+! { dg-options "-fcoarray=single" }
+!
+! PR fortran/50981
+! PR fortran/54618
+!
+
+  implicit none
+  type t
+   integer, allocatable :: i
+  end type t
+  type, extends (t):: t2
+   integer, allocatable :: j
+  end type t2
+
+  call s1a1()
+  call s1a()
+  call s1ac1()
+  call s1ac()
+  call s2()
+  call s2p(psnt=.false.)
+  call s2caf()
+  call s2elem()
+  call s2elem_t()
+  call s2elem_t2()
+  call s2t()
+  call s2tp(psnt=.false.)
+  call s2t2()
+  call s2t2p(psnt=.false.)
+
+  call a1a1()
+  call a1a()
+  call a1ac1()
+  call a1ac()
+  call a2()
+  call a2p(psnt=.false.)
+  call a2caf()
+
+  call a3a1()
+  call a3a()
+  call a3ac1()
+  call a3ac()
+  call a4()
+  call a4p(psnt=.false.)
+  call a4caf()
+
+  call ar1a1()
+  call ar1a()
+  call ar1ac1()
+  call ar1ac()
+  call ar()
+  call art()
+  call arp(psnt=.false.)
+  call artp(psnt=.false.)
+
+contains
+
+ subroutine s1a1(z, z2, z3, z4, z5)
+   type(t), optional :: z, z4[*]
+   type(t), pointer, optional :: z2
+   type(t), allocatable, optional :: z3, z5[:]
+   type(t), allocatable :: x
+   type(t), pointer :: y
+   y => null()
+   call s2(x)
+   call s2(y)
+   call s2(z)
+   call s2(z2)
+   call s2(z3)
+   call s2(z4)
+   call s2(z5)
+   call s2p(y,psnt=.true.)
+   call s2p(z2,psnt=.false.)
+   call s2elem(x)
+   call s2elem(y)
+   call s2elem(z)
+   call s2elem(z2)
+   call s2elem(z3)
+   call s2elem(z4)
+   call s2elem(z5)
+   call s2elem_t(x)
+   call s2elem_t(y)
+   call s2elem_t(z)
+!   call s2elem_t(z2) ! FIXME: Segfault
+!   call s2elem_t(z3) ! FIXME: Segfault
+!   call s2elem_t(z4) ! FIXME: Segfault
+!   call s2elem_t(z5) ! FIXME: Segfault
+   call s2caf(z4)
+   call s2caf(z5)
+   call ar(x)
+   call ar(y)
+   call ar(z)
+   call ar(z2)
+   call ar(z3)
+   call ar(z4)
+   call ar(z5)
+   call arp(y,psnt=.true.)
+   call arp(z2,psnt=.false.)
+   call s2t(x)
+   call s2t(y)
+   call s2t(z)
+!  call s2t(z2) ! FIXME: Segfault
+!   call s2t(z3) ! FIXME: Segfault
+!   call s2t(z4) ! FIXME: Segfault
+!   call s2t(z5) ! FIXME: Segfault
+   call s2tp(y,psnt=.true.)
+   call s2tp(z2,psnt=.false.)
+ end subroutine s1a1
+ subroutine s1a(z, z2, z3, z4, z5)
+   type(t2), optional :: z, z4[*]
+   type(t2), optional, pointer :: z2
+   type(t2), optional, allocatable :: z3, z5[:]
+   type(t2), allocatable :: x
+   type(t2), pointer :: y
+   y => null()
+   call s2(x)
+   call s2(y)
+   call s2(z)
+   call s2(z2)
+   call s2(z3)
+   call s2(z4)
+   call s2(z5)
+   call s2p(y,psnt=.true.)
+   call s2p(z2,psnt=.false.)
+   call s2elem(x)
+   call s2elem(y)
+   call s2elem(z)
+   call s2elem(z2)
+   call s2elem(z3)
+   call s2elem(z4)
+   call s2elem(z5)
+   call s2elem_t2(x)
+   call s2elem_t2(y)
+   call s2elem_t2(z)
+!   call s2elem_t2(z2) ! FIXME: Segfault
+!   call s2elem_t2(z3) ! FIXME: Segfault
+!   call s2elem_t2(z4) ! FIXME: Segfault
+!   call s2elem_t2(z5) ! FIXME: Segfault
+   call s2caf(z4)
+   call s2caf(z5)
+   call ar(x)
+   call ar(y)
+   call ar(z)
+   call ar(z2)
+   call ar(z3)
+   call ar(z4)
+   call ar(z5)
+   call arp(y,psnt=.true.)
+   call arp(z2,psnt=.false.)
+   call s2t2(x)
+   call s2t2(y)
+   call s2t2(z)
+!   call s2t2(z2) ! FIXME: Segfault
+!   call s2t2(z3) ! FIXME: Segfault
+   call s2t2(z4)
+!   call s2t2(z5) ! FIXME: Segfault
+   call s2t2p(y,psnt=.true.)
+   call s2t2p(z2,psnt=.false.)
+ end subroutine s1a
+ subroutine s1ac1(z, z2, z3, z4, z5)
+   class(t), optional :: z, z4[*]
+   class(t), optional, pointer :: z2
+   class(t), optional, allocatable :: z3, z5[:]
+   class(t), allocatable :: x
+   class(t), pointer :: y
+   y => null()
+   call s2(x)
+   call s2(y)
+   call s2(z)
+   call s2(z2)
+   call s2(z3)
+   call s2(z4)
+   call s2(z5)
+   call s2p(y,psnt=.true.)
+   call s2p(z2,psnt=.false.)
+   call s2elem(x)
+   call s2elem(y)
+   call s2elem(z)
+   call s2elem(z2)
+   call s2elem(z3)
+   call s2elem(z4)
+   call s2elem(z5)
+   call s2elem_t(x)
+   call s2elem_t(y)
+!   call s2elem_t(z) ! FIXME: Segfault
+!   call s2elem_t(z2) ! FIXME: Segfault
+!   call s2elem_t(z3) ! FIXME: Segfault
+!   call s2elem_t(z4) ! FIXME: Segfault
+!   call s2elem_t(z5) ! FIXME: Segfault
+   call s2caf(z4)
+   call s2caf(z5)
+   call ar(x)
+   call ar(y)
+   call ar(z)
+   call ar(z2)
+   call ar(z3)
+   call ar(z4)
+   call ar(z5)
+   call arp(y,psnt=.true.)
+   call arp(z2,psnt=.false.)
+   call s2t(x)
+   call s2t(y)
+!   call s2t(z) ! FIXME: Segfault
+!   call s2t(z2) ! FIXME: Segfault
+!   call s2t(z3) ! FIXME: Segfault
+!   call s2t(z4) ! FIXME: Segfault
+!   call s2t(z5) ! FIXME: Segfault
+   call s2tp(y,psnt=.true.)
+   call s2tp(z2,psnt=.false.)
+ end subroutine s1ac1
+ subroutine s1ac(z, z2, z3, z4, z5)
+   class(t2), optional :: z, z4[*]
+   class(t2), optional, pointer :: z2
+   class(t2), optional, allocatable :: z3, z5[:]
+   class(t2), allocatable :: x
+   class(t2), pointer :: y
+   y => null()
+   call s2(x)
+   call s2(y)
+   call s2(z)
+   call s2(z2)
+   call s2(z3)
+   call s2(z4)
+   call s2(z5)
+   call s2p(y,psnt=.true.)
+   call s2p(z2,psnt=.false.)
+   call s2elem(x)
+   call s2elem(y)
+   call s2elem(z)
+   call s2elem(z2)
+   call s2elem(z3)
+   call s2elem(z4)
+   call s2elem(z5)
+   call s2elem_t2(x)
+!   call s2elem_t2(y) ! FIXME: Segfault
+!   call s2elem_t2(z) ! FIXME: Segfault
+!   call s2elem_t2(z2) ! FIXME: Segfault
+!   call s2elem_t2(z3) ! FIXME: Segfault
+!   call s2elem_t2(z4) ! FIXME: Segfault
+!   call s2elem_t2(z5) ! FIXME: Segfault
+   call s2caf(z4)
+   call s2caf(z5)
+   call ar(x)
+   call ar(y)
+   call ar(z)
+   call ar(z2)
+   call ar(z3)
+   call ar(z4)
+   call ar(z5)
+   call arp(y,psnt=.true.)
+   call arp(z2,psnt=.false.)
+   call s2t2(x)
+   call s2t2(y)
+!   call s2t2(z) ! FIXME: Segfault
+!   call s2t2(z2) ! FIXME: Segfault
+!   call s2t2(z3) ! FIXME: Segfault
+!   call s2t2(z4) ! FIXME: Segfault
+!   call s2t2(z5) ! FIXME: Segfault
+   call s2t2p(y,psnt=.true.)
+   call s2t2p(z2,psnt=.false.)
+ end subroutine s1ac
+
+ subroutine s2(x)
+   class(t), intent(in), optional :: x
+   if (present (x)) call abort ()
+   !print *, present(x)
+ end subroutine s2
+ subroutine s2p(x,psnt)
+   class(t), intent(in), pointer, optional :: x
+   logical psnt
+   if (present (x).neqv. psnt) call abort ()
+   !print *, present(x)
+ end subroutine s2p
+ subroutine s2caf(x)
+   class(t), intent(in), optional :: x[*]
+   if (present (x)) call abort ()
+   !print *, present(x)
+ end subroutine s2caf
+ subroutine s2t(x)
+   type(t), intent(in), optional :: x
+   if (present (x)) call abort ()
+   !print *, present(x)
+ end subroutine s2t
+ subroutine s2t2(x)
+   type(t2), intent(in), optional :: x
+   if (present (x)) call abort ()
+   !print *, present(x)
+ end subroutine s2t2
+ subroutine s2tp(x, psnt)
+   type(t), pointer, intent(in), optional :: x
+   logical psnt
+   if (present (x).neqv. psnt) call abort ()
+   !print *, present(x)
+ end subroutine s2tp
+ subroutine s2t2p(x, psnt)
+   type(t2), pointer, intent(in), optional :: x
+   logical psnt
+   if (present (x).neqv. psnt) call abort ()
+   !print *, present(x)
+ end subroutine s2t2p
+ impure elemental subroutine s2elem(x)
+   class(t), intent(in), optional :: x
+   if (present (x)) call abort ()
+   !print *, present(x)
+ end subroutine s2elem
+ impure elemental subroutine s2elem_t(x)
+   type(t), intent(in), optional :: x
+   if (present (x)) call abort ()
+   !print *, present(x)
+ end subroutine s2elem_t
+ impure elemental subroutine s2elem_t2(x)
+   type(t2), intent(in), optional :: x
+   if (present (x)) call abort ()
+   !print *, present(x)
+ end subroutine s2elem_t2
+
+
+ subroutine a1a1(z, z2, z3, z4, z5)
+   type(t), optional :: z(:), z4(:)[*]
+   type(t), optional, pointer :: z2(:)
+   type(t), optional, allocatable :: z3(:), z5(:)[:]
+   type(t), allocatable :: x(:)
+   type(t), pointer :: y(:)
+   y => null()
+   call a2(x)
+   call a2(y)
+   call a2(z)
+   call a2(z2)
+   call a2(z3)
+   call a2(z4)
+   call a2(z5)
+   call a2p(y,psnt=.true.)
+   call a2p(z2,psnt=.false.)
+   call a2caf(z4)
+   call a2caf(z5)
+   call ar(x)
+   call ar(y)
+   call ar(z)
+   call ar(z2)
+   call ar(z3)
+   call ar(z4)
+   call ar(z5)
+   call arp(y,psnt=.true.)
+   call arp(z2,psnt=.false.)
+!   call s2elem(x) ! FIXME: Segfault
+!   call s2elem(y) ! FIXME: Segfault
+!   call s2elem(z) ! FIXME: Segfault
+!   call s2elem(z2) ! FIXME: Segfault
+!   call s2elem(z3) ! FIXME: Segfault
+!   call s2elem(z4) ! FIXME: Segfault
+!   call s2elem(z5) ! FIXME: Segfault
+!   call s2elem_t(x) ! FIXME: Conditional jump or move depends on uninitialised value
+!   call s2elem_t(y) ! FIXME: Conditional jump or move depends on uninitialised value
+!   call s2elem_t(z) ! FIXME: Conditional jump or move depends on uninitialised value
+!   call s2elem_t(z2) ! FIXME: Segfault
+!   call s2elem_t(z3) ! FIXME: Segfault
+!   call s2elem_t(z4) ! FIXME: Segfault
+!   call s2elem_t(z5) ! FIXME: Segfault
+ end subroutine a1a1
+ subroutine a1a(z, z2, z3, z4, z5)
+   type(t2), optional :: z(:), z4(:)[*]
+   type(t2), optional, pointer :: z2(:)
+   type(t2), optional, allocatable :: z3(:), z5(:)[:]
+   type(t2), allocatable :: x(:)
+   type(t2), pointer :: y(:)
+   y => null()
+   call a2(x)
+   call a2(y)
+   call a2(z)
+   call a2(z2)
+   call a2(z3)
+   call a2(z4)
+   call a2(z5)
+   call a2p(y,psnt=.true.)
+   call a2p(z2,psnt=.false.)
+   call a2caf(z4)
+   call a2caf(z5)
+   call ar(x)
+   call ar(y)
+   call ar(z)
+   call ar(z2)
+   call ar(z3)
+   call ar(z4)
+   call ar(z5)
+   call arp(y,psnt=.true.)
+   call arp(z2,psnt=.false.)
+!   call s2elem(x) ! FIXME: Segfault
+!   call s2elem(y) ! FIXME: Segfault
+!   call s2elem(z) ! FIXME: Segfault
+!   call s2elem(z2) ! FIXME: Segfault
+!   call s2elem(z3) ! FIXME: Segfault
+!   call s2elem(z4) ! FIXME: Segfault
+!   call s2elem(z5) ! FIXME: Segfault
+!   call s2elem_t2(x) ! FIXME: Conditional jump or move depends on uninitialised value
+!   call s2elem_t2(y) ! FIXME: Conditional jump or move depends on uninitialised value
+!   call s2elem_t2(z) ! FIXME: Conditional jump or move depends on uninitialised value
+!   call s2elem_t2(z2) ! FIXME: Segfault
+!   call s2elem_t2(z3) ! FIXME: Segfault
+!   call s2elem_t2(z4) ! FIXME: Segfault
+!   call s2elem_t2(z5) ! FIXME: Segfault
+ end subroutine a1a
+ subroutine a1ac1(z, z2, z3, z4, z5)
+   class(t), optional :: z(:), z4(:)[*]
+   class(t), optional, pointer :: z2(:)
+   class(t), optional, allocatable :: z3(:), z5(:)[:]
+   class(t), allocatable :: x(:)
+   class(t), pointer :: y(:)
+   y => null()
+   call a2(x)
+   call a2(y)
+   call a2(z)
+   call a2(z2)
+   call a2(z3)
+   call a2(z4)
+   call a2(z5)
+   call a2p(y,psnt=.true.)
+   call a2p(z2,psnt=.false.)
+   call a2caf(z4)
+   call a2caf(z5)
+   call ar(x)
+   call ar(y)
+   call ar(z)
+   call ar(z2)
+   call ar(z3)
+   call ar(z4)
+   call ar(z5)
+   call arp(y,psnt=.true.)
+   call arp(z2,psnt=.false.)
+!   call s2elem(x) ! FIXME: Segfault
+!   call s2elem(y) ! FIXME: Segfault
+!   call s2elem(z) ! FIXME: Segfault
+!   call s2elem(z2) ! FIXME: Segfault
+!   call s2elem(z3) ! FIXME: Segfault
+!   call s2elem(z4) ! FIXME: Segfault
+!   call s2elem(z5) ! FIXME: Segfault
+!   call s2elem_t(x) ! FIXME: Segfault
+!   call s2elem_t(y) ! FIXME: Segfault
+!   call s2elem_t(z) ! FIXME: Segfault
+!   call s2elem_t(z2) ! FIXME: Segfault
+!   call s2elem_t(z3) ! FIXME: Segfault
+!   call s2elem_t(z4) ! FIXME: Segfault
+!   call s2elem_t(z5) ! FIXME: Segfault
+ end subroutine a1ac1
+ subroutine a1ac(z, z2, z3, z4, z5)
+   class(t2), optional :: z(:), z4(:)[*]
+   class(t2), optional, pointer :: z2(:)
+   class(t2), optional, allocatable :: z3(:), z5(:)[:]
+   class(t2), allocatable :: x(:)
+   class(t2), pointer :: y(:)
+   y => null()
+   call a2(x)
+   call a2(y)
+   call a2(z)
+   call a2(z2)
+   call a2(z3)
+   call a2(z4)
+   call a2(z5)
+   call a2p(y,psnt=.true.)
+   call a2p(z2,psnt=.false.)
+   call a2caf(z4)
+   call a2caf(z5)
+   call ar(x)
+   call ar(y)
+   call ar(z)
+   call ar(z2)
+   call ar(z3)
+   call ar(z4)
+   call ar(z5)
+   call arp(y,psnt=.true.)
+   call arp(z2,psnt=.false.)
+!   call s2elem(x) ! FIXME: Segfault
+!   call s2elem(y) ! FIXME: Segfault
+!   call s2elem(z) ! FIXME: Segfault
+!   call s2elem(z2) ! FIXME: Segfault
+!   call s2elem(z3) ! FIXME: Segfault
+!   call s2elem(z4) ! FIXME: Segfault
+!   call s2elem(z5) ! FIXME: Segfault
+!   call s2elem_t2(x) ! FIXME: Segfault
+!   call s2elem_t2(y) ! FIXME: Segfault
+!   call s2elem_t2(z) ! FIXME: Segfault
+!   call s2elem_t2(z2) ! FIXME: Segfault
+!   call s2elem_t2(z3) ! FIXME: Segfault
+!   call s2elem_t2(z4) ! FIXME: Segfault
+!   call s2elem_t2(z5) ! FIXME: Segfault
+ end subroutine a1ac
+
+ subroutine a2(x)
+   class(t), intent(in), optional :: x(:)
+   if (present (x)) call abort ()
+   ! print *, present(x)
+ end subroutine a2
+ subroutine a2p(x, psnt)
+   class(t), pointer, intent(in), optional :: x(:)
+   logical psnt
+   if (present (x).neqv. psnt) call abort ()
+   ! print *, present(x)
+ end subroutine a2p
+ subroutine a2caf(x)
+   class(t), intent(in), optional :: x(:)[*]
+   if (present (x)) call abort ()
+   ! print *, present(x)
+ end subroutine a2caf
+
+
+ subroutine a3a1(z, z2, z3, z4, z5)
+   type(t), optional :: z(4), z4(4)[*]
+   type(t), optional, pointer :: z2(:)
+   type(t), optional, allocatable :: z3(:), z5(:)[:]
+   type(t), allocatable :: x(:)
+   type(t), pointer :: y(:)
+   y => null()
+   call a4(x)
+   call a4(y)
+   call a4(z)
+   call a4(z2)
+   call a4(z3)
+   call a4(z4)
+   call a4(z5)
+   call a4p(y,psnt=.true.)
+   call a4p(z2,psnt=.false.)
+   call a4t(x)
+   call a4t(y)
+   call a4t(z)
+!   call a4t(z2) ! FIXME: Segfault
+!   call a4t(z3) ! FIXME: Segfault
+!   call a4t(z4) ! FIXME: Segfault
+!   call a4t(z5) ! FIXME: Segfault
+   call a4tp(y,psnt=.true.)
+   call a4tp(z2,psnt=.false.)
+   call a4caf(z4)
+   call a4caf(z5)
+   call ar(x)
+   call ar(y)
+   call ar(z)
+   call ar(z2)
+   call ar(z3)
+   call ar(z4)
+   call ar(z5)
+   call arp(y,psnt=.true.)
+   call arp(z2,psnt=.false.)
+!   call s2elem(x) ! FIXME: Segfault
+!   call s2elem(y) ! FIXME: Segfault
+!   call s2elem(z) ! FIXME: Segfault
+!   call s2elem(z2) ! FIXME: Segfault
+!   call s2elem(z3) ! FIXME: Segfault
+!   call s2elem(z4) ! FIXME: Segfault
+!   call s2elem(z5) ! FIXME: Segfault
+!   call s2elem_t(x) ! FIXME: Conditional jump or move depends on uninitialised value
+!   call s2elem_t(y) ! FIXME: Conditional jump or move depends on uninitialised value
+!   call s2elem_t(z) ! FIXME: Conditional jump or move depends on uninitialised value
+!   call s2elem_t(z2) ! FIXME: Segfault
+!   call s2elem_t(z3) ! FIXME: Segfault
+!   call s2elem_t(z4) ! FIXME: Segfault
+!   call s2elem_t(z5) ! FIXME: Segfault
+ end subroutine a3a1
+ subroutine a3a(z, z2, z3)
+   type(t2), optional :: z(4)
+   type(t2), optional, pointer :: z2(:)
+   type(t2), optional, allocatable :: z3(:)
+   type(t2), allocatable :: x(:)
+   type(t2), pointer :: y(:)
+   y => null()
+   call a4(x)
+   call a4(y)
+   call a4(z)
+   call a4(z2)
+   call a4(z3)
+   call a4p(y,psnt=.true.)
+   call a4p(z2,psnt=.false.)
+   call a4t2(x)
+   call a4t2(y)
+   call a4t2(z)
+!   call a4t2(z2) ! FIXME: Segfault
+!   call a4t2(z3) ! FIXME: Segfault
+   call a4t2p(y,psnt=.true.)
+   call a4t2p(z2,psnt=.false.)
+   call ar(x)
+   call ar(y)
+   call ar(z)
+   call ar(z2)
+   call ar(z3)
+   call arp(y,psnt=.true.)
+   call arp(z2,psnt=.false.)
+!   call s2elem(x) ! FIXME: Segfault
+!   call s2elem(y) ! FIXME: Segfault
+!   call s2elem(z) ! FIXME: Segfault
+!   call s2elem(z2) ! FIXME: Segfault
+!   call s2elem(z3) ! FIXME: Segfault
+!   call s2elem(z4) ! FIXME: Segfault
+!   call s2elem(z5) ! FIXME: Segfault
+!   call s2elem_t2(x) ! FIXME: Conditional jump or move depends on uninitialised value
+!   call s2elem_t2(y) ! FIXME: Conditional jump or move depends on uninitialised value
+!   call s2elem_t2(z) ! FIXME: Conditional jump or move depends on uninitialised value
+!   call s2elem_t2(z2) ! FIXME: Segfault
+!   call s2elem_t2(z3) ! FIXME: Segfault
+!   call s2elem_t2(z4) ! FIXME: Segfault
+!   call s2elem_t2(z5) ! FIXME: Segfault
+ end subroutine a3a
+ subroutine a3ac1(z, z2, z3, z4, z5)
+   class(t), optional :: z(4), z4(4)[*]
+   class(t), optional, pointer :: z2(:)
+   class(t), optional, allocatable :: z3(:), z5(:)[:]
+   class(t), allocatable :: x(:)
+   class(t), pointer :: y(:)
+   y => null()
+   call a4(x)
+   call a4(y)
+   call a4(z)
+   call a4(z2)
+   call a4(z3)
+   call a4(z4)
+   call a4(z5)
+   call a4p(y,psnt=.true.)
+   call a4p(z2,psnt=.false.)
+!   call a4t(x) ! FIXME: Segfault
+!   call a4t(y) ! FIXME: Segfault
+!   call a4t(z) ! FIXME: Segfault
+!   call a4t(z2) ! FIXME: Segfault
+!   call a4t(z3) ! FIXME: Segfault
+!   call a4t(z4) ! FIXME: Segfault
+!   call a4t(z5) ! FIXME: Segfault
+!   call a4tp(y,psnt=.true.) ! FIXME: Segfault
+!   call a4tp(z2,psnt=.false.) ! FIXME: Segfault
+   call a4caf(z4)
+   call a4caf(z5)
+   call ar(x)
+   call ar(y)
+   call ar(z)
+   call ar(z2)
+   call ar(z3)
+   call ar(z4)
+   call ar(z5)
+   call arp(y,psnt=.true.)
+   call arp(z2,psnt=.false.)
+!   call s2elem(x) ! FIXME: Conditional jump or move depends on uninitialised value
+!   call s2elem(y) ! FIXME: Conditional jump or move depends on uninitialised value
+!   call s2elem(z) ! FIXME: Segfault
+!   call s2elem(z2) ! FIXME: Segfault
+!   call s2elem(z3) ! FIXME: Segfault
+!   call s2elem(z4) ! FIXME: Segfault
+!   call s2elem(z5) ! FIXME: Segfault
+!   call s2elem_t(x) ! FIXME: Conditional jump or move depends on uninitialised value
+!   call s2elem_t(y) ! FIXME: Conditional jump or move depends on uninitialised value
+!   call s2elem_t(z) ! FIXME: Segfault
+!   call s2elem_t(z2) ! FIXME: Segfault
+!   call s2elem_t(z3) ! FIXME: Segfault
+!   call s2elem_t(z4) ! FIXME: Segfault
+!   call s2elem_t(z5) ! FIXME: Segfault
+ end subroutine a3ac1
+ subroutine a3ac(z, z2, z3, z4, z5)
+   class(t2), optional :: z(4), z4(4)[*]
+   class(t2), optional, pointer :: z2(:)
+   class(t2), optional, allocatable :: z3(:), z5(:)[:]
+   class(t2), allocatable :: x(:)
+   class(t2), pointer :: y(:)
+   y => null()
+   call a4(x)
+   call a4(y)
+   call a4(z)
+   call a4(z2)
+   call a4(z3)
+   call a4(z4)
+   call a4(z5)
+   call a4p(y,psnt=.true.)
+   call a4p(z2,psnt=.false.)
+!   call a4t2(x) ! FIXME: Segfault
+!   call a4t2(y) ! FIXME: Segfault
+!   call a4t2(z) ! FIXME: Segfault
+!   call a4t2(z2) ! FIXME: Segfault
+!   call a4t2(z3) ! FIXME: Segfault
+!   call a4t2(z4) ! FIXME: Segfault
+!   call a4t2(z5) ! FIXME: Segfault
+!   call a4t2p(y,psnt=.true.) ! FIXME: Segfault
+!   call a4t2p(z2,psnt=.false.) ! FIXME: Segfault
+   call a4caf(z4)
+   call a4caf(z5)
+   call ar(x)
+   call ar(y)
+   call ar(z)
+   call ar(z2)
+   call ar(z3)
+   call ar(z4)
+   call ar(z5)
+   call arp(y,psnt=.true.) 
+   call arp(z2,psnt=.false.)
+ end subroutine a3ac
+
+ subroutine a4(x)
+   class(t), intent(in), optional :: x(4)
+   if (present (x)) call abort ()
+   !print *, present(x)
+ end subroutine a4
+ subroutine a4p(x, psnt)
+   class(t), pointer, intent(in), optional :: x(:)
+   logical psnt
+   if (present (x).neqv. psnt) call abort ()
+   !print *, present(x)
+ end subroutine a4p
+ subroutine a4caf(x)
+   class(t), intent(in), optional :: x(4)[*]
+   if (present (x)) call abort ()
+   !print *, present(x)
+ end subroutine a4caf
+ subroutine a4t(x)
+   type(t), intent(in), optional :: x(4)
+   if (present (x)) call abort ()
+   !print *, present(x)
+ end subroutine a4t
+ subroutine a4t2(x)
+   type(t2), intent(in), optional :: x(4)
+   if (present (x)) call abort ()
+   !print *, present(x)
+ end subroutine a4t2
+ subroutine a4tp(x, psnt)
+   type(t), pointer, intent(in), optional :: x(:)
+   logical psnt
+   if (present (x).neqv. psnt) call abort ()
+   !print *, present(x)
+ end subroutine a4tp
+ subroutine a4t2p(x, psnt)
+   type(t2), pointer, intent(in), optional :: x(:)
+   logical psnt
+   if (present (x).neqv. psnt) call abort ()
+   !print *, present(x)
+ end subroutine a4t2p
+
+
+ subroutine ar(x)
+   class(t), intent(in), optional :: x(..)
+   if (present (x)) call abort ()
+   !print *, present(x)
+ end subroutine ar
+
+ subroutine art(x)
+   type(t), intent(in), optional :: x(..)
+   if (present (x)) call abort ()
+   !print *, present(x)
+ end subroutine art
+
+ subroutine arp(x, psnt)
+   class(t), pointer, intent(in), optional :: x(..)
+   logical psnt
+   if (present (x).neqv. psnt) call abort ()
+   !print *, present(x)
+ end subroutine arp
+
+ subroutine artp(x, psnt)
+   type(t), intent(in), pointer, optional :: x(..)
+   logical psnt
+   if (present (x).neqv. psnt) call abort ()
+   !print *, present(x)
+ end subroutine artp
+
+
+
+ subroutine ar1a1(z, z2, z3)
+   type(t), optional :: z(..)
+   type(t), pointer, optional :: z2(..)
+   type(t), allocatable, optional :: z3(..)
+   call ar(z)
+   call ar(z2)
+   call ar(z3)
+   call art(z)
+   call art(z2)
+   call art(z3)
+   call arp(z2, .false.)
+   call artp(z2, .false.)
+ end subroutine ar1a1
+ subroutine ar1a(z, z2, z3)
+   type(t2), optional :: z(..)
+   type(t2), optional, pointer :: z2(..)
+   type(t2), optional, allocatable :: z3(..)
+   call ar(z)
+   call ar(z2)
+   call ar(z3)
+   call arp(z2, .false.)
+ end subroutine ar1a
+ subroutine ar1ac1(z, z2, z3)
+   class(t), optional :: z(..)
+   class(t), optional, pointer :: z2(..)
+   class(t), optional, allocatable :: z3(..)
+   call ar(z)
+   call ar(z2)
+   call ar(z3)
+!   call art(z) ! FIXME: ICE - This requires packing support for assumed-rank
+!   call art(z2)! FIXME: ICE - This requires packing support for assumed-rank
+!   call art(z3)! FIXME: ICE - This requires packing support for assumed-rank
+   call arp(z2, .false.)
+!   call artp(z2, .false.) ! FIXME: ICE
+ end subroutine ar1ac1
+ subroutine ar1ac(z, z2, z3)
+   class(t2), optional :: z(..)
+   class(t2), optional, pointer :: z2(..)
+   class(t2), optional, allocatable :: z3(..)
+   call ar(z)
+   call ar(z2)
+   call ar(z3)
+   call arp(z2, .false.)
+ end subroutine ar1ac
+end