re PR fortran/64578 ([OOP] Seg-fault and ICE with unlimited polymorphic array pointer function)

2015-01-17  Paul Thomas  <pault@gcc.gnu.org>

	PR fortran/64578
	* trans-expr.c (gfc_trans_pointer_assignment): Make sure that
	before reinitializing rse, to add the rse.pre to block before
	creating 'ptrtemp'.
	* trans-intrinsic.c (gfc_conv_associated): Deal with the class
	data being a descriptor.

2015-01-17  Paul Thomas  <pault@gcc.gnu.org>

	PR fortran/64578
	* gfortran.dg/unlimited_polymorphic_21.f90: New test

From-SVN: r219802

gcc/fortran/ChangeLog

+2015-01-17  Paul Thomas  <pault@gcc.gnu.org>
+
+	PR fortran/64578
+	* trans-expr.c (gfc_trans_pointer_assignment): Make sure that
+	before reinitializing rse, to add the rse.pre to block before
+	creating 'ptrtemp'.
+	* trans-intrinsic.c (gfc_conv_associated): Deal with the class
+	data being a descriptor.
+
 2015-01-17  Andre Vehreschild  <vehre@gmx.de>
 
 	PR fortran/60357

gcc/fortran/trans-expr.c

@@ -7075,6 +7075,7 @@ gfc_trans_pointer_assignment (gfc_expr * expr1, gfc_expr * expr2)
 		rse.expr = gfc_class_data_get (rse.expr);
 	      else
 		{
+		  gfc_add_block_to_block (&block, &rse.pre);
 		  tmp = gfc_create_var (TREE_TYPE (rse.expr), "ptrtemp");
 		  gfc_add_modify (&lse.pre, tmp, rse.expr);
 
@@ -7146,6 +7147,7 @@ gfc_trans_pointer_assignment (gfc_expr * expr1, gfc_expr * expr2)
 	    }
 	  else
 	    {
+	      gfc_add_block_to_block (&block, &rse.pre);
 	      tmp = gfc_create_var (TREE_TYPE (rse.expr), "ptrtemp");
 	      gfc_add_modify (&lse.pre, tmp, rse.expr);
 

gcc/fortran/trans-intrinsic.c

@@ -186,7 +186,7 @@ gfc_builtin_decl_for_float_kind (enum built_in_function double_built_in,
     {
       /* For __float128, the story is a bit different, because we return
 	 a decl to a library function rather than a built-in.  */
-      gfc_intrinsic_map_t *m; 
+      gfc_intrinsic_map_t *m;
       for (m = gfc_intrinsic_map; m->double_built_in != double_built_in ; m++)
 	;
 
@@ -294,8 +294,8 @@ gfc_conv_intrinsic_conversion (gfc_se * se, gfc_expr * expr)
   nargs = gfc_intrinsic_argument_list_length (expr);
   args = XALLOCAVEC (tree, nargs);
 
-  /* Evaluate all the arguments passed. Whilst we're only interested in the 
-     first one here, there are other parts of the front-end that assume this 
+  /* Evaluate all the arguments passed. Whilst we're only interested in the
+     first one here, there are other parts of the front-end that assume this
      and will trigger an ICE if it's not the case.  */
   type = gfc_typenode_for_spec (&expr->ts);
   gcc_assert (expr->value.function.actual->expr);
@@ -540,7 +540,7 @@ gfc_conv_intrinsic_int (gfc_se * se, gfc_expr * expr, enum rounding_mode op)
   nargs = gfc_intrinsic_argument_list_length (expr);
   args = XALLOCAVEC (tree, nargs);
 
-  /* Evaluate the argument, we process all arguments even though we only 
+  /* Evaluate the argument, we process all arguments even though we only
      use the first one for code generation purposes.  */
   type = gfc_typenode_for_spec (&expr->ts);
   gcc_assert (expr->value.function.actual->expr);
@@ -1237,7 +1237,7 @@ gfc_conv_intrinsic_caf_get (gfc_se *se, gfc_expr *expr, tree lhs, tree lhs_kind,
 
 
 /* Send data to a remove coarray.  */
- 
+
 static tree
 conv_caf_send (gfc_code *code) {
   gfc_expr *lhs_expr, *rhs_expr;
@@ -1520,7 +1520,7 @@ trans_this_image (gfc_se * se, gfc_expr *expr)
 	 extent = gfc_extent(i)
 	 ml = m
 	 m  = m/extent
-	 if (i >= min_var) 
+	 if (i >= min_var)
 	   goto exit_label
 	 i++
        }
@@ -1547,10 +1547,10 @@ trans_this_image (gfc_se * se, gfc_expr *expr)
       return;
     }
 
-  m = gfc_create_var (type, NULL); 
-  ml = gfc_create_var (type, NULL); 
-  loop_var = gfc_create_var (integer_type_node, NULL); 
-  min_var = gfc_create_var (integer_type_node, NULL); 
+  m = gfc_create_var (type, NULL);
+  ml = gfc_create_var (type, NULL);
+  loop_var = gfc_create_var (integer_type_node, NULL);
+  min_var = gfc_create_var (integer_type_node, NULL);
 
   /* m = this_image () - 1.  */
   gfc_add_modify (&se->pre, m, tmp);
@@ -1584,7 +1584,7 @@ trans_this_image (gfc_se * se, gfc_expr *expr)
   extent = fold_convert (type, extent);
 
   /* m = m/extent.  */
-  gfc_add_modify (&loop, m, 
+  gfc_add_modify (&loop, m,
 		  fold_build2_loc (input_location, TRUNC_DIV_EXPR, type,
 			  m, extent));
 
@@ -1907,7 +1907,7 @@ gfc_conv_intrinsic_bound (gfc_se * se, gfc_expr * expr, int upper)
 
   ubound = gfc_conv_descriptor_ubound_get (desc, bound);
   lbound = gfc_conv_descriptor_lbound_get (desc, bound);
-  
+
   /* 13.14.53: Result value for LBOUND
 
      Case (i): For an array section or for an array expression other than a
@@ -2257,7 +2257,7 @@ gfc_conv_intrinsic_cmplx (gfc_se * se, gfc_expr * expr, int both)
 
 
 /* Remainder function MOD(A, P) = A - INT(A / P) * P
-                      MODULO(A, P) = A - FLOOR (A / P) * P  
+                      MODULO(A, P) = A - FLOOR (A / P) * P
 
    The obvious algorithms above are numerically instable for large
    arguments, hence these intrinsics are instead implemented via calls
@@ -2316,7 +2316,7 @@ gfc_conv_intrinsic_mod (gfc_se * se, gfc_expr * expr, int modulo)
 
 	 In order to calculate the result accurately, we use the fmod
 	 function as follows.
-	 
+
 	 res = fmod (arg, arg2);
 	 if (res)
 	   {
@@ -2328,7 +2328,7 @@ gfc_conv_intrinsic_mod (gfc_se * se, gfc_expr * expr, int modulo)
 
 	 => As two nested ternary exprs:
 
-	 res = res ? (((arg < 0) xor (arg2 < 0)) ? res + arg2 : res) 
+	 res = res ? (((arg < 0) xor (arg2 < 0)) ? res + arg2 : res)
 	       : copysign (0., arg2);
 
       */
@@ -2349,15 +2349,15 @@ gfc_conv_intrinsic_mod (gfc_se * se, gfc_expr * expr, int modulo)
 				  boolean_type_node, test, test2);
 	  test = gfc_evaluate_now (test, &se->pre);
 	  se->expr = fold_build3_loc (input_location, COND_EXPR, type, test,
-				      fold_build2_loc (input_location, 
+				      fold_build2_loc (input_location,
 						       PLUS_EXPR,
-						       type, tmp, args[1]), 
+						       type, tmp, args[1]),
 				      tmp);
 	}
       else
 	{
 	  tree expr1, copysign, cscall;
-	  copysign = gfc_builtin_decl_for_float_kind (BUILT_IN_COPYSIGN, 
+	  copysign = gfc_builtin_decl_for_float_kind (BUILT_IN_COPYSIGN,
 						      expr->ts.kind);
 	  test = fold_build2_loc (input_location, LT_EXPR, boolean_type_node,
 				  args[0], zero);
@@ -2366,13 +2366,13 @@ gfc_conv_intrinsic_mod (gfc_se * se, gfc_expr * expr, int modulo)
 	  test2 = fold_build2_loc (input_location, TRUTH_XOR_EXPR,
 				   boolean_type_node, test, test2);
 	  expr1 = fold_build3_loc (input_location, COND_EXPR, type, test2,
-				   fold_build2_loc (input_location, 
+				   fold_build2_loc (input_location,
 						    PLUS_EXPR,
-						    type, tmp, args[1]), 
+						    type, tmp, args[1]),
 				   tmp);
 	  test = fold_build2_loc (input_location, NE_EXPR, boolean_type_node,
 				  tmp, zero);
-	  cscall = build_call_expr_loc (input_location, copysign, 2, zero, 
+	  cscall = build_call_expr_loc (input_location, copysign, 2, zero,
 					args[1]);
 	  se->expr = fold_build3_loc (input_location, COND_EXPR, type, test,
 				      expr1, cscall);
@@ -2839,7 +2839,7 @@ gfc_conv_intrinsic_minmax (gfc_se * se, gfc_expr * expr, enum tree_code op)
     {
       tree cond, isnan;
 
-      val = args[i]; 
+      val = args[i];
 
       /* Handle absent optional arguments by ignoring the comparison.  */
       if (argexpr->expr->expr_type == EXPR_VARIABLE
@@ -2847,7 +2847,7 @@ gfc_conv_intrinsic_minmax (gfc_se * se, gfc_expr * expr, enum tree_code op)
 	  && TREE_CODE (val) == INDIRECT_REF)
 	cond = fold_build2_loc (input_location,
 				NE_EXPR, boolean_type_node,
-				TREE_OPERAND (val, 0), 
+				TREE_OPERAND (val, 0),
 			build_int_cst (TREE_TYPE (TREE_OPERAND (val, 0)), 0));
       else
       {
@@ -3387,19 +3387,19 @@ gfc_conv_intrinsic_arith (gfc_se * se, gfc_expr * expr, enum tree_code op,
       gfc_add_modify (&ifblock2, val,
 		      fold_build2_loc (input_location, RDIV_EXPR, type, scale,
 				       absX));
-      res1 = fold_build2_loc (input_location, MULT_EXPR, type, val, val); 
+      res1 = fold_build2_loc (input_location, MULT_EXPR, type, val, val);
       res1 = fold_build2_loc (input_location, MULT_EXPR, type, resvar, res1);
       res1 = fold_build2_loc (input_location, PLUS_EXPR, type, res1,
 			      gfc_build_const (type, integer_one_node));
       gfc_add_modify (&ifblock2, resvar, res1);
       gfc_add_modify (&ifblock2, scale, absX);
-      res1 = gfc_finish_block (&ifblock2); 
+      res1 = gfc_finish_block (&ifblock2);
 
       gfc_init_block (&ifblock3);
       gfc_add_modify (&ifblock3, val,
 		      fold_build2_loc (input_location, RDIV_EXPR, type, absX,
 				       scale));
-      res2 = fold_build2_loc (input_location, MULT_EXPR, type, val, val); 
+      res2 = fold_build2_loc (input_location, MULT_EXPR, type, val, val);
       res2 = fold_build2_loc (input_location, PLUS_EXPR, type, resvar, res2);
       gfc_add_modify (&ifblock3, resvar, res2);
       res2 = gfc_finish_block (&ifblock3);
@@ -3407,7 +3407,7 @@ gfc_conv_intrinsic_arith (gfc_se * se, gfc_expr * expr, enum tree_code op,
       cond = fold_build2_loc (input_location, GT_EXPR, boolean_type_node,
 			      absX, scale);
       tmp = build3_v (COND_EXPR, cond, res1, res2);
-      gfc_add_expr_to_block (&ifblock1, tmp);  
+      gfc_add_expr_to_block (&ifblock1, tmp);
       tmp = gfc_finish_block (&ifblock1);
 
       cond = fold_build2_loc (input_location, NE_EXPR, boolean_type_node,
@@ -3415,7 +3415,7 @@ gfc_conv_intrinsic_arith (gfc_se * se, gfc_expr * expr, enum tree_code op,
 			      gfc_build_const (type, integer_zero_node));
 
       tmp = build3_v (COND_EXPR, cond, tmp, build_empty_stmt (input_location));
-      gfc_add_expr_to_block (&block, tmp);  
+      gfc_add_expr_to_block (&block, tmp);
     }
   else
     {
@@ -4786,7 +4786,7 @@ gfc_conv_intrinsic_ishftc (gfc_se * se, gfc_expr * expr)
 
    For INTEGER kinds smaller than the C 'int' type, we have to subtract the
    difference in bit size between the argument of LEADZ and the C int.  */
- 
+
 static void
 gfc_conv_intrinsic_leadz (gfc_se * se, gfc_expr * expr)
 {
@@ -4848,7 +4848,7 @@ gfc_conv_intrinsic_leadz (gfc_se * se, gfc_expr * expr)
     {
       /* We end up here if the argument type is larger than 'long long'.
 	 We generate this code:
-  
+
 	    if (x & (ULL_MAX << ULL_SIZE) != 0)
 	      return clzll ((unsigned long long) (x >> ULLSIZE));
 	    else
@@ -4904,7 +4904,7 @@ gfc_conv_intrinsic_leadz (gfc_se * se, gfc_expr * expr)
    The conditional expression is necessary because the result of TRAILZ(0)
    is defined, but the result of __builtin_ctz(0) is undefined for most
    targets.  */
- 
+
 static void
 gfc_conv_intrinsic_trailz (gfc_se * se, gfc_expr *expr)
 {
@@ -4959,7 +4959,7 @@ gfc_conv_intrinsic_trailz (gfc_se * se, gfc_expr *expr)
     {
       /* We end up here if the argument type is larger than 'long long'.
 	 We generate this code:
-  
+
 	    if ((x & ULL_MAX) == 0)
 	      return ULL_SIZE + ctzll ((unsigned long long) (x >> ULLSIZE));
 	    else
@@ -5010,7 +5010,7 @@ gfc_conv_intrinsic_trailz (gfc_se * se, gfc_expr *expr)
 /* Using __builtin_popcount for POPCNT and __builtin_parity for POPPAR;
    for types larger than "long long", we call the long long built-in for
    the lower and higher bits and combine the result.  */
- 
+
 static void
 gfc_conv_intrinsic_popcnt_poppar (gfc_se * se, gfc_expr *expr, int parity)
 {
@@ -5076,7 +5076,7 @@ gfc_conv_intrinsic_popcnt_poppar (gfc_se * se, gfc_expr *expr, int parity)
       call2 = build_call_expr_loc (input_location, func, 1,
 				   fold_convert (long_long_unsigned_type_node,
 						 arg2));
-			  
+
       /* Combine the results.  */
       if (parity)
 	se->expr = fold_build2_loc (input_location, BIT_XOR_EXPR, result_type,
@@ -5411,7 +5411,7 @@ gfc_conv_intrinsic_mask (gfc_se * se, gfc_expr * expr, int left)
 {
   tree arg, allones, type, utype, res, cond, bitsize;
   int i;
- 
+
   gfc_conv_intrinsic_function_args (se, expr, &arg, 1);
   arg = gfc_evaluate_now (arg, &se->pre);
 
@@ -5743,7 +5743,7 @@ gfc_conv_intrinsic_size (gfc_se * se, gfc_expr * expr)
       gfc_add_block_to_block (&se->pre, &argse.pre);
 
       /* Unusually, for an intrinsic, size does not exclude
-	 an optional arg2, so we must test for it.  */  
+	 an optional arg2, so we must test for it.  */
       if (actual->expr->expr_type == EXPR_VARIABLE
 	    && actual->expr->symtree->n.sym->attr.dummy
 	    && actual->expr->symtree->n.sym->attr.optional)
@@ -5813,7 +5813,7 @@ size_of_string_in_bytes (int kind, tree string_length)
 {
   tree bytesize;
   int i = gfc_validate_kind (BT_CHARACTER, kind, false);
- 
+
   bytesize = build_int_cst (gfc_array_index_type,
 			    gfc_character_kinds[i].bit_size / 8);
 
@@ -5970,7 +5970,7 @@ gfc_conv_intrinsic_storage_size (gfc_se *se, gfc_expr *expr)
   tree type, result_type, tmp;
 
   arg = expr->value.function.actual->expr;
-  
+
   gfc_init_se (&argse, NULL);
   result_type = gfc_get_int_type (expr->ts.kind);
 
@@ -5986,7 +5986,7 @@ gfc_conv_intrinsic_storage_size (gfc_se *se, gfc_expr *expr)
 	}
 
       gfc_conv_expr_reference (&argse, arg);
-      type = TREE_TYPE (build_fold_indirect_ref_loc (input_location, 
+      type = TREE_TYPE (build_fold_indirect_ref_loc (input_location,
 						     argse.expr));
     }
   else
@@ -6001,12 +6001,12 @@ gfc_conv_intrinsic_storage_size (gfc_se *se, gfc_expr *expr)
 	}
       type = gfc_get_element_type (TREE_TYPE (argse.expr));
     }
-    
+
   /* Obtain the argument's word length.  */
   if (arg->ts.type == BT_CHARACTER)
     tmp = size_of_string_in_bytes (arg->ts.kind, argse.string_length);
   else
-    tmp = size_in_bytes (type); 
+    tmp = size_in_bytes (type);
   tmp = fold_convert (result_type, tmp);
 
 done:
@@ -6195,7 +6195,7 @@ gfc_conv_intrinsic_transfer (gfc_se * se, gfc_expr * expr)
 				       argse.string_length);
       else
 	tmp = fold_convert (gfc_array_index_type,
-			    size_in_bytes (source_type)); 
+			    size_in_bytes (source_type));
 
       /* Obtain the size of the array in bytes.  */
       extent = gfc_create_var (gfc_array_index_type, NULL);
@@ -6553,8 +6553,12 @@ gfc_conv_associated (gfc_se *se, gfc_expr *expr)
 	      && arg1->expr->symtree->n.sym->attr.dummy)
 	    arg1se.expr = build_fold_indirect_ref_loc (input_location,
 						       arg1se.expr);
-	  if (arg1->expr->ts.type == BT_CLASS)
+  	  if (arg1->expr->ts.type == BT_CLASS)
+	    {
 	      tmp2 = gfc_class_data_get (arg1se.expr);
+	      if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (tmp2)))
+		tmp2 = gfc_conv_descriptor_data_get (tmp2);
+	    }
 	  else
 	    tmp2 = arg1se.expr;
         }
@@ -6749,7 +6753,7 @@ gfc_conv_intrinsic_si_kind (gfc_se *se, gfc_expr *expr)
   gfc_conv_intrinsic_function_args (se, expr, &arg, 1);
 
   /* The argument to SELECTED_INT_KIND is INTEGER(4).  */
-  type = gfc_get_int_type (4); 
+  type = gfc_get_int_type (4);
   arg = gfc_build_addr_expr (NULL_TREE, fold_convert (type, arg));
 
   /* Convert it to the required type.  */
@@ -6790,7 +6794,7 @@ gfc_conv_intrinsic_sr_kind (gfc_se *se, gfc_expr *expr)
 	      gfc_convert_type (actual->expr, &ts, 2);
 	    }
 	  gfc_conv_expr_reference (&argse, actual->expr);
-	} 
+	}
 
       gfc_add_block_to_block (&se->pre, &argse.pre);
       gfc_add_block_to_block (&se->post, &argse.post);
@@ -7022,8 +7026,8 @@ gfc_conv_intrinsic_loc (gfc_se * se, gfc_expr * expr)
   else
     gfc_conv_array_parameter (se, arg_expr, true, NULL, NULL, NULL);
   se->expr = convert (gfc_get_int_type (gfc_index_integer_kind), se->expr);
-   
-  /* Create a temporary variable for loc return value.  Without this, 
+
+  /* Create a temporary variable for loc return value.  Without this,
      we get an error an ICE in gcc/expr.c(expand_expr_addr_expr_1).  */
   temp_var = gfc_create_var (gfc_get_int_type (gfc_index_integer_kind), NULL);
   gfc_add_modify (&se->pre, temp_var, se->expr);
@@ -8698,7 +8702,7 @@ conv_co_collective (gfc_code *code)
     case GFC_ISYM_CO_SUM:
       fndecl = gfor_fndecl_co_sum;
       break;
-    default: 
+    default:
       gcc_unreachable ();
     }
 
@@ -9174,7 +9178,7 @@ conv_intrinsic_atomic_cas (gfc_code *code)
 			     build_int_cst (NULL, MEMMODEL_RELAXED),
 			     build_int_cst (NULL, MEMMODEL_RELAXED));
   gfc_add_expr_to_block (&block, tmp);
-  
+
   if (stat != NULL_TREE)
     gfc_add_modify (&block, stat, build_int_cst (TREE_TYPE (stat), 0));
   gfc_add_block_to_block (&block, &post_block);

gcc/testsuite/ChangeLog

+2015-01-17  Paul Thomas  <pault@gcc.gnu.org>
+
+	PR fortran/64578
+	* gfortran.dg/unlimited_polymorphic_21.f90: New test
+
 2015-01-17  Andre Vehreschild  <vehre@gmx.de>
 
 	PR fortran/60357