Make sure types in assignments are compatible.

2004-06-29  Steven Bosscher  <stevenb@suse.de>

	Make sure types in assignments are compatible.  Mostly mechanical.
	* trans-const.h (gfc_index_one_node): New define.
	* trans-array.c (gfc_trans_allocate_array_storage,
	gfc_trans_allocate_temp_array, gfc_trans_array_constructor_subarray,
	gfc_trans_array_constructor_value, gfc_trans_array_constructor,
	gfc_conv_array_ubound, gfc_conv_array_ref,
	gfc_trans_scalarized_loop_end, gfc_conv_section_startstride,
	gfc_conv_ss_startstride, gfc_conv_loop_setup, gfc_array_init_size,
	gfc_trans_array_bounds, gfc_trans_dummy_array_bias,
	gfc_conv_expr_descriptor, gfc_trans_deferred_array): Use the correct
	types in assignments, conversions and conditionals for expressions.
	* trans-expr.c (gfc_conv_expr_present, gfc_conv_substring,
	gfc_conv_unary_op, gfc_conv_cst_int_power, gfc_conv_string_tmp,
	gfc_conv_function_call, gfc_trans_pointer_assignment,
	gfc_trans_scalar_assign): Likewise.
	* trans-intrinsic.c (build_fixbound_expr, gfc_conv_intrinsic_bound,
	gfc_conv_intrinsic_anyall, gfc_conv_intrinsic_count,
	gfc_conv_intrinsic_minmaxloc, gfc_conv_intrinsic_btest,
	gfc_conv_intrinsic_singlebitop, gfc_conv_intrinsic_ishft,
	gfc_conv_intrinsic_ishftc, gfc_conv_intrinsic_strcmp,
	gfc_conv_allocated, gfc_conv_associated,
	gfc_conv_intrinsic_rrspacing, gfc_conv_intrinsic_trim): Likewise.
	* trans-io.c (set_string): Likewise.
	* trans-stmt.c (gfc_trans_do, gfc_trans_forall_loop,
	gfc_do_allocate, generate_loop_for_temp_to_lhs,
	generate_loop_for_rhs_to_temp, compute_inner_temp_size,
	compute_overall_iter_number, gfc_trans_assign_need_temp,
	gfc_trans_pointer_assign_need_temp, gfc_trans_forall_1,
	gfc_evaluate_where_mask, gfc_trans_where_assign,
	gfc_trans_where_2): Likewise.
	* trans-types.c (gfc_get_character_type, gfc_build_array_type,
	gfc_get_nodesc_array_type, gfc_get_array_type_bounds): Likewise.

	* trans.c (gfc_add_modify_expr): Add sanity check that types
	for the lhs and rhs are the same for scalar assignments.

From-SVN: r83877

gcc/fortran/ChangeLog

+2004-06-29  Steven Bosscher  <stevenb@suse.de>
+
+	Make sure types in assignments are compatible.  Mostly mechanical.
+	* trans-const.h (gfc_index_one_node): New define.
+	* trans-array.c (gfc_trans_allocate_array_storage,
+	gfc_trans_allocate_temp_array, gfc_trans_array_constructor_subarray,
+	gfc_trans_array_constructor_value, gfc_trans_array_constructor,
+	gfc_conv_array_ubound, gfc_conv_array_ref,
+	gfc_trans_scalarized_loop_end, gfc_conv_section_startstride,
+	gfc_conv_ss_startstride, gfc_conv_loop_setup, gfc_array_init_size,
+	gfc_trans_array_bounds, gfc_trans_dummy_array_bias,
+	gfc_conv_expr_descriptor, gfc_trans_deferred_array): Use the correct
+	types in assignments, conversions and conditionals for expressions.
+	* trans-expr.c (gfc_conv_expr_present, gfc_conv_substring,
+	gfc_conv_unary_op, gfc_conv_cst_int_power, gfc_conv_string_tmp,
+	gfc_conv_function_call, gfc_trans_pointer_assignment,
+	gfc_trans_scalar_assign): Likewise.
+	* trans-intrinsic.c (build_fixbound_expr, gfc_conv_intrinsic_bound,
+	gfc_conv_intrinsic_anyall, gfc_conv_intrinsic_count,
+	gfc_conv_intrinsic_minmaxloc, gfc_conv_intrinsic_btest,
+	gfc_conv_intrinsic_singlebitop, gfc_conv_intrinsic_ishft,
+	gfc_conv_intrinsic_ishftc, gfc_conv_intrinsic_strcmp,
+	gfc_conv_allocated, gfc_conv_associated,
+	gfc_conv_intrinsic_rrspacing, gfc_conv_intrinsic_trim): Likewise.
+	* trans-io.c (set_string): Likewise.
+	* trans-stmt.c (gfc_trans_do, gfc_trans_forall_loop,
+	gfc_do_allocate, generate_loop_for_temp_to_lhs,
+	generate_loop_for_rhs_to_temp, compute_inner_temp_size,
+	compute_overall_iter_number, gfc_trans_assign_need_temp,
+	gfc_trans_pointer_assign_need_temp, gfc_trans_forall_1,
+	gfc_evaluate_where_mask, gfc_trans_where_assign,
+	gfc_trans_where_2): Likewise.
+	* trans-types.c (gfc_get_character_type, gfc_build_array_type,
+	gfc_get_nodesc_array_type, gfc_get_array_type_bounds): Likewise.
+
+	* trans.c (gfc_add_modify_expr): Add sanity check that types
+	for the lhs and rhs are the same for scalar assignments.
+
 2004-06-29  Tobias Schlueter  <tobias.schlueter@physik.uni-muenchen.de>
 
 	* dump-parse-tree.c (show_common): New function.

gcc/fortran/trans-const.h

@@ -56,4 +56,6 @@ extern GTY(()) tree gfc_strconst_wrong_return;
 
 /* Integer constants 0..GFC_MAX_DIMENSIONS.  */
 extern GTY(()) tree gfc_rank_cst[GFC_MAX_DIMENSIONS + 1];
+
 #define gfc_index_zero_node gfc_rank_cst[0]
+#define gfc_index_one_node gfc_rank_cst[1]

gcc/fortran/trans-expr.c

@@ -135,7 +135,8 @@ gfc_conv_expr_present (gfc_symbol * sym)
              || GFC_ARRAY_TYPE_P (TREE_TYPE (decl)));
       decl = GFC_DECL_SAVED_DESCRIPTOR (decl);
     }
-  return build (NE_EXPR, boolean_type_node, decl, null_pointer_node);
+  return build (NE_EXPR, boolean_type_node, decl,
+		fold_convert (TREE_TYPE (decl), null_pointer_node));
 }
 
 
@@ -174,9 +175,7 @@ gfc_conv_substring (gfc_se * se, gfc_ref * ref, int kind)
   gfc_add_block_to_block (&se->pre, &start.pre);
 
   if (integer_onep (start.expr))
-    {
     gfc_conv_string_parameter (se);
-    }
   else
     {
       /* Change the start of the string.  */
@@ -198,7 +197,9 @@ gfc_conv_substring (gfc_se * se, gfc_ref * ref, int kind)
       gfc_add_block_to_block (&se->pre, &end.pre);
     }
   tmp =
-    build (MINUS_EXPR, gfc_strlen_type_node, integer_one_node, start.expr);
+    build (MINUS_EXPR, gfc_strlen_type_node,
+	   fold_convert (gfc_strlen_type_node, integer_one_node),
+	   start.expr);
   tmp = build (PLUS_EXPR, gfc_strlen_type_node, end.expr, tmp);
   se->string_length = fold (tmp);
 }
@@ -376,7 +377,8 @@ gfc_conv_unary_op (enum tree_code code, gfc_se * se, gfc_expr * expr)
      We must convert it to a compare to 0 (e.g. EQ_EXPR (op1, 0)).
      All other unary operators have an equivalent GIMPLE unary operator  */
   if (code == TRUTH_NOT_EXPR)
-    se->expr = build (EQ_EXPR, type, operand.expr, integer_zero_node);
+    se->expr = build (EQ_EXPR, type, operand.expr,
+		      convert (type, integer_zero_node));
   else
     se->expr = build1 (code, type, operand.expr);
 
@@ -502,24 +504,27 @@ gfc_conv_cst_int_power (gfc_se * se, tree lhs, tree rhs)
   if ((sgn == -1) && (TREE_CODE (type) == INTEGER_TYPE))
     {
       tmp = build (EQ_EXPR, boolean_type_node, lhs,
-			integer_minus_one_node);
+		   fold_convert (TREE_TYPE (lhs), integer_minus_one_node));
       cond = build (EQ_EXPR, boolean_type_node, lhs,
-			integer_one_node);
+		    convert (TREE_TYPE (lhs), integer_one_node));
 
       /* If rhs is an even,
 	 result = (lhs == 1 || lhs == -1) ? 1 : 0.  */
       if ((n & 1) == 0)
         {
 	  tmp = build (TRUTH_OR_EXPR, boolean_type_node, tmp, cond);
-	  se->expr = build (COND_EXPR, type, tmp, integer_one_node, 
-			integer_zero_node);
+	  se->expr = build (COND_EXPR, type, tmp,
+			    convert (type, integer_one_node),
+			    convert (type, integer_zero_node));
 	  return 1;
 	}
       /* If rhs is an odd,
 	 result = (lhs == 1) ? 1 : (lhs == -1) ? -1 : 0.  */
-      tmp = build (COND_EXPR, type, tmp, integer_minus_one_node,
-			integer_zero_node);
-      se->expr = build (COND_EXPR, type, cond, integer_one_node,
+      tmp = build (COND_EXPR, type, tmp,
+		   convert (type, integer_minus_one_node),
+		   convert (type, integer_zero_node));
+      se->expr = build (COND_EXPR, type, cond,
+			convert (type, integer_one_node),
 			tmp);
       return 1;
     }
@@ -675,11 +680,16 @@ gfc_conv_string_tmp (gfc_se * se, tree type, tree len)
   tree tmp;
   tree args;
 
+  if (TREE_TYPE (len) != gfc_strlen_type_node)
+    abort ();
+
   if (gfc_can_put_var_on_stack (len))
     {
       /* Create a temporary variable to hold the result.  */
-      tmp = fold (build (MINUS_EXPR, TREE_TYPE (len), len, integer_one_node));
-      tmp = build_range_type (gfc_array_index_type, integer_zero_node, tmp);
+      tmp = fold (build (MINUS_EXPR, gfc_strlen_type_node, len,
+			 convert (gfc_strlen_type_node,
+				  integer_one_node)));
+      tmp = build_range_type (gfc_array_index_type, gfc_index_zero_node, tmp);
       tmp = build_array_type (gfc_character1_type_node, tmp);
       var = gfc_create_var (tmp, "str");
       var = gfc_build_addr_expr (type, var);
@@ -1030,7 +1040,8 @@ gfc_conv_function_call (gfc_se * se, gfc_symbol * sym,
 	  /* Zero the first stride to indicate a temporary.  */
 	  tmp =
 	    gfc_conv_descriptor_stride (info->descriptor, gfc_rank_cst[0]);
-	  gfc_add_modify_expr (&se->pre, tmp, integer_zero_node);
+	  gfc_add_modify_expr (&se->pre, tmp,
+			       convert (TREE_TYPE (tmp), integer_zero_node));
 	  /* Pass the temporary as the first argument.  */
 	  tmp = info->descriptor;
 	  tmp = gfc_build_addr_expr (NULL, tmp);
@@ -1080,8 +1091,10 @@ gfc_conv_function_call (gfc_se * se, gfc_symbol * sym,
 	      parmse.expr = null_pointer_node;
               if (arg->missing_arg_type == BT_CHARACTER)
                 {
-                  stringargs = gfc_chainon_list (stringargs,
-                      convert (gfc_strlen_type_node, integer_zero_node));
+                  stringargs =
+		    gfc_chainon_list (stringargs,
+				      convert (gfc_strlen_type_node,
+					       integer_zero_node));
                 }
 	    }
 	}
@@ -1589,7 +1602,6 @@ gfc_trans_pointer_assignment (gfc_expr * expr1, gfc_expr * expr2)
   gfc_ss *lss;
   gfc_ss *rss;
   stmtblock_t block;
-  tree tmp;
 
   gfc_start_block (&block);
 
@@ -1607,7 +1619,8 @@ gfc_trans_pointer_assignment (gfc_expr * expr1, gfc_expr * expr2)
       gfc_conv_expr (&rse, expr2);
       gfc_add_block_to_block (&block, &lse.pre);
       gfc_add_block_to_block (&block, &rse.pre);
-      gfc_add_modify_expr (&block, lse.expr, rse.expr);
+      gfc_add_modify_expr (&block, lse.expr,
+			   fold_convert (TREE_TYPE (lse.expr), rse.expr));
       gfc_add_block_to_block (&block, &rse.post);
       gfc_add_block_to_block (&block, &lse.post);
     }
@@ -1618,9 +1631,8 @@ gfc_trans_pointer_assignment (gfc_expr * expr1, gfc_expr * expr2)
       if (expr2->expr_type == EXPR_NULL)
         {
           lse.expr = gfc_conv_descriptor_data (lse.expr);
-          rse.expr = null_pointer_node;
-          tmp = build_v (MODIFY_EXPR, lse.expr, rse.expr);
-          gfc_add_expr_to_block (&block, tmp);
+          rse.expr = fold_convert (TREE_TYPE (lse.expr), null_pointer_node);
+          gfc_add_modify_expr (&block, lse.expr, rse.expr);
         }
       else
         {
@@ -1690,7 +1702,8 @@ gfc_trans_scalar_assign (gfc_se * lse, gfc_se * rse, bt type)
       gfc_add_block_to_block (&block, &lse->pre);
       gfc_add_block_to_block (&block, &rse->pre);
 
-      gfc_add_modify_expr (&block, lse->expr, rse->expr);
+      gfc_add_modify_expr (&block, lse->expr,
+			   fold_convert (TREE_TYPE (lse->expr), rse->expr));
     }
 
   gfc_add_block_to_block (&block, &lse->post);

gcc/fortran/trans-intrinsic.c

@@ -228,7 +228,8 @@ build_fixbound_expr (stmtblock_t * pblock, tree arg, tree type, int up)
   tmp = convert (argtype, intval);
   cond = build (up ? GE_EXPR : LE_EXPR, boolean_type_node, tmp, arg);
 
-  tmp = build (up ? PLUS_EXPR : MINUS_EXPR, type, intval, integer_one_node);
+  tmp = build (up ? PLUS_EXPR : MINUS_EXPR, type, intval,
+	       convert (type, integer_one_node));
   tmp = build (COND_EXPR, type, cond, intval, tmp);
   return tmp;
 }
@@ -651,7 +652,7 @@ gfc_conv_intrinsic_bound (gfc_se * se, gfc_expr * expr, int upper)
       bound = argse.expr;
       /* Convert from one based to zero based.  */
       bound = fold (build (MINUS_EXPR, gfc_array_index_type, bound,
-                    integer_one_node));
+			   gfc_index_one_node));
     }
 
   /* TODO: don't re-evaluate the descriptor on each iteration.  */
@@ -677,7 +678,7 @@ gfc_conv_intrinsic_bound (gfc_se * se, gfc_expr * expr, int upper)
         {
           bound = gfc_evaluate_now (bound, &se->pre);
           cond = fold (build (LT_EXPR, boolean_type_node, bound,
-                              integer_zero_node));
+                              convert (TREE_TYPE (bound), integer_zero_node)));
           tmp = gfc_rank_cst[GFC_TYPE_ARRAY_RANK (TREE_TYPE (desc))];
           tmp = fold (build (GE_EXPR, boolean_type_node, bound, tmp));
           cond = fold(build (TRUTH_ORIF_EXPR, boolean_type_node, cond, tmp));
@@ -1172,7 +1173,9 @@ gfc_conv_intrinsic_anyall (gfc_se * se, gfc_expr * expr, int op)
   gfc_conv_expr_val (&arrayse, actual->expr);
 
   gfc_add_block_to_block (&body, &arrayse.pre);
-  tmp = build (op, boolean_type_node, arrayse.expr, integer_zero_node);
+  tmp = build (op, boolean_type_node, arrayse.expr,
+	       fold_convert (TREE_TYPE (arrayse.expr),
+			     integer_zero_node));
   tmp = build_v (COND_EXPR, tmp, found, build_empty_stmt ());
   gfc_add_expr_to_block (&body, tmp);
   gfc_add_block_to_block (&body, &arrayse.post);
@@ -1214,7 +1217,7 @@ gfc_conv_intrinsic_count (gfc_se * se, gfc_expr * expr)
   type = gfc_typenode_for_spec (&expr->ts);
   /* Initialize the result.  */
   resvar = gfc_create_var (type, "count");
-  gfc_add_modify_expr (&se->pre, resvar, integer_zero_node);
+  gfc_add_modify_expr (&se->pre, resvar, convert (type, integer_zero_node));
 
   /* Walk the arguments.  */
   arrayss = gfc_walk_expr (actual->expr);
@@ -1232,7 +1235,8 @@ gfc_conv_intrinsic_count (gfc_se * se, gfc_expr * expr)
   /* Generate the loop body.  */
   gfc_start_scalarized_body (&loop, &body);
 
-  tmp = build (PLUS_EXPR, TREE_TYPE (resvar), resvar, integer_one_node);
+  tmp = build (PLUS_EXPR, TREE_TYPE (resvar), resvar,
+	       convert (TREE_TYPE (resvar), integer_one_node));
   tmp = build_v (MODIFY_EXPR, resvar, tmp);
 
   gfc_init_se (&arrayse, NULL);
@@ -1453,7 +1457,7 @@ gfc_conv_intrinsic_minmaxloc (gfc_se * se, gfc_expr * expr, int op)
      array, in case all elements are equal to the limit.
      ie. pos = (ubound >= lbound) ? lbound, lbound - 1;  */
   tmp = fold (build (MINUS_EXPR, gfc_array_index_type,
-	             loop.from[0], integer_one_node));
+	             loop.from[0], gfc_index_one_node));
   cond = fold (build (GE_EXPR, boolean_type_node,
 		      loop.to[0], loop.from[0]));
   tmp = fold (build (COND_EXPR, gfc_array_index_type, cond,
@@ -1522,7 +1526,7 @@ gfc_conv_intrinsic_minmaxloc (gfc_se * se, gfc_expr * expr, int op)
 
   /* Return a value in the range 1..SIZE(array).  */
   tmp = fold (build (MINUS_EXPR, gfc_array_index_type, loop.from[0],
-		     integer_one_node));
+		     gfc_index_one_node));
   tmp = fold (build (MINUS_EXPR, gfc_array_index_type, pos, tmp));
   /* And convert to the required type.  */
   se->expr = convert (type, tmp);
@@ -1670,9 +1674,10 @@ gfc_conv_intrinsic_btest (gfc_se * se, gfc_expr * expr)
   arg = TREE_VALUE (arg);
   type = TREE_TYPE (arg);
 
-  tmp = build (LSHIFT_EXPR, type, integer_one_node, arg2);
+  tmp = build (LSHIFT_EXPR, type, convert (type, integer_one_node), arg2);
   tmp = build (BIT_AND_EXPR, type, arg, tmp);
-  tmp = fold (build (NE_EXPR, boolean_type_node, tmp, integer_zero_node));
+  tmp = fold (build (NE_EXPR, boolean_type_node, tmp,
+		     convert (type, integer_zero_node)));
   type = gfc_typenode_for_spec (&expr->ts);
   se->expr = convert (type, tmp);
 }
@@ -1720,7 +1725,8 @@ gfc_conv_intrinsic_singlebitop (gfc_se * se, gfc_expr * expr, int set)
   arg = TREE_VALUE (arg);
   type = TREE_TYPE (arg);
 
-  tmp = fold (build (LSHIFT_EXPR, type, integer_one_node, arg2));
+  tmp = fold (build (LSHIFT_EXPR, type,
+		     convert (type, integer_one_node), arg2));
   if (set)
     op = BIT_IOR_EXPR;
   else
@@ -1783,11 +1789,13 @@ gfc_conv_intrinsic_ishft (gfc_se * se, gfc_expr * expr)
   tmp = build1 (NEGATE_EXPR, TREE_TYPE (arg2), arg2);
   rshift = build (RSHIFT_EXPR, type, arg, tmp);
 
-  tmp = build (GT_EXPR, boolean_type_node, arg2, integer_zero_node);
+  tmp = build (GT_EXPR, boolean_type_node, arg2,
+	       convert (TREE_TYPE (arg2), integer_zero_node));
   rshift = build (COND_EXPR, type, tmp, lshift, rshift);
 
   /* Do nothing if shift == 0.  */
-  tmp = build (EQ_EXPR, boolean_type_node, arg2, integer_zero_node);
+  tmp = build (EQ_EXPR, boolean_type_node, arg2,
+	       convert (TREE_TYPE (arg2), integer_zero_node));
   se->expr = build (COND_EXPR, type, tmp, arg, rshift);
 }
 
@@ -1843,11 +1851,13 @@ gfc_conv_intrinsic_ishftc (gfc_se * se, gfc_expr * expr)
   tmp = build1 (NEGATE_EXPR, TREE_TYPE (arg2), arg2);
   rrot = build (RROTATE_EXPR, type, arg, tmp);
 
-  tmp = build (GT_EXPR, boolean_type_node, arg2, integer_zero_node);
+  tmp = build (GT_EXPR, boolean_type_node, arg2,
+	       convert (TREE_TYPE (arg2), integer_zero_node));
   rrot = build (COND_EXPR, type, tmp, lrot, rrot);
 
   /* Do nothing if shift == 0.  */
-  tmp = build (EQ_EXPR, boolean_type_node, arg2, integer_zero_node);
+  tmp = build (EQ_EXPR, boolean_type_node, arg2,
+	       convert (TREE_TYPE (arg2), integer_zero_node));
   se->expr = build (COND_EXPR, type, tmp, arg, rrot);
 }
 
@@ -2040,7 +2050,8 @@ gfc_conv_intrinsic_strcmp (gfc_se * se, gfc_expr * expr, int op)
   se->expr = gfc_build_function_call (gfor_fndecl_compare_string, args);
 
   type = gfc_typenode_for_spec (&expr->ts);
-  se->expr = build (op, type, se->expr, integer_zero_node);
+  se->expr = build (op, type, se->expr,
+		    convert (TREE_TYPE (se->expr), integer_zero_node));
 }
 
 /* Generate a call to the adjustl/adjustr library function.  */
@@ -2130,7 +2141,8 @@ gfc_conv_allocated (gfc_se *se, gfc_expr *expr)
   gfc_conv_expr_descriptor (&arg1se, arg1->expr, ss1);
 
   tmp = gfc_conv_descriptor_data (arg1se.expr);
-  tmp = build (NE_EXPR, boolean_type_node, tmp, null_pointer_node);
+  tmp = build (NE_EXPR, boolean_type_node, tmp,
+	       fold_convert (TREE_TYPE (tmp), null_pointer_node));
   se->expr = convert (gfc_typenode_for_spec (&expr->ts), tmp);
 }
 
@@ -2176,7 +2188,8 @@ gfc_conv_associated (gfc_se *se, gfc_expr *expr)
           gfc_conv_expr_lhs (&arg1se, arg1->expr);
           tmp2 = gfc_conv_descriptor_data (arg1se.expr);
         }
-      tmp = build (NE_EXPR, boolean_type_node, tmp2, null_pointer_node);
+      tmp = build (NE_EXPR, boolean_type_node, tmp2,
+		   fold_convert (TREE_TYPE (tmp2), null_pointer_node));
       se->expr = tmp;
     }
   else
@@ -2450,7 +2463,8 @@ gfc_conv_intrinsic_rrspacing (gfc_se * se, gfc_expr * expr)
 
    cond2 = build (EQ_EXPR, boolean_type_node, rcs.frac, zero);
    cond = build (TRUTH_ANDIF_EXPR, boolean_type_node, cond, cond2);
-   tmp = build (COND_EXPR, masktype, cond, integer_zero_node, tmp);
+   tmp = build (COND_EXPR, masktype, cond,
+		convert (masktype, integer_zero_node), tmp);
 
    tmp = build1 (VIEW_CONVERT_EXPR, rcs.type, tmp);
    se->expr = tmp;
@@ -2527,7 +2541,8 @@ gfc_conv_intrinsic_trim (gfc_se * se, gfc_expr * expr)
   gfc_add_expr_to_block (&se->pre, tmp);
 
   /* Free the temporary afterwards, if necessary.  */
-  cond = build (GT_EXPR, boolean_type_node, len, integer_zero_node);
+  cond = build (GT_EXPR, boolean_type_node, len,
+		convert (TREE_TYPE (len), integer_zero_node));
   arglist = gfc_chainon_list (NULL_TREE, var);
   tmp = gfc_build_function_call (gfor_fndecl_internal_free, arglist);
   tmp = build_v (COND_EXPR, cond, tmp, build_empty_stmt ());

gcc/fortran/trans-io.c

@@ -410,7 +410,8 @@ set_string (stmtblock_t * block, stmtblock_t * postblock, tree var,
       msg =
         gfc_build_string_const (37, "Assigned label is not a format label");
       tmp = GFC_DECL_STRING_LEN (se.expr);
-      tmp = build (LE_EXPR, boolean_type_node, tmp, integer_minus_one_node);
+      tmp = build (LE_EXPR, boolean_type_node,
+		   tmp, convert (TREE_TYPE (tmp), integer_minus_one_node));
       gfc_trans_runtime_check (tmp, msg, &se.pre);
       gfc_add_modify_expr (&se.pre, io, GFC_DECL_ASSIGN_ADDR (se.expr));
       gfc_add_modify_expr (&se.pre, len, GFC_DECL_STRING_LEN (se.expr));
@@ -418,7 +419,7 @@ set_string (stmtblock_t * block, stmtblock_t * postblock, tree var,
   else
     {
       gfc_conv_string_parameter (&se);
-      gfc_add_modify_expr (&se.pre, io, se.expr);
+      gfc_add_modify_expr (&se.pre, io, fold_convert (TREE_TYPE (io), se.expr));
       gfc_add_modify_expr (&se.pre, len, se.string_length);
     }
 
@@ -432,10 +433,10 @@ set_string (stmtblock_t * block, stmtblock_t * postblock, tree var,
 static void
 set_flag (stmtblock_t *block, tree var)
 {
-  tree tmp;
+  tree tmp, type = TREE_TYPE (var);
 
-  tmp = build (COMPONENT_REF, TREE_TYPE(var), ioparm_var, var, NULL_TREE);
-  gfc_add_modify_expr (block, tmp, integer_one_node);
+  tmp = build (COMPONENT_REF, type, ioparm_var, var, NULL_TREE);
+  gfc_add_modify_expr (block, tmp, convert (type, integer_one_node));
 }
 
 

gcc/fortran/trans-types.c

@@ -290,7 +290,7 @@ gfc_get_character_type (int kind, gfc_charlen * cl)
 
   len = (cl == 0) ? NULL_TREE : cl->backend_decl;
 
-  bounds = build_range_type (gfc_array_index_type, integer_one_node, len);
+  bounds = build_range_type (gfc_array_index_type, gfc_index_one_node, len);
   type = build_array_type (base, bounds);
   TYPE_STRING_FLAG (type) = 1;
 
@@ -493,7 +493,7 @@ gfc_build_array_type (tree type, gfc_array_spec * as)
     {
       /* Create expressions for the known bounds of the array.  */
       if (as->type == AS_ASSUMED_SHAPE && as->lower[n] == NULL)
-        lbound[n] = integer_one_node;
+        lbound[n] = gfc_index_one_node;
       else
         lbound[n] = gfc_conv_array_bound (as->lower[n]);
       ubound[n] = gfc_conv_array_bound (as->upper[n]);
@@ -727,7 +727,7 @@ gfc_get_nodesc_array_type (tree etype, gfc_array_spec * as, int packed)
 
   GFC_TYPE_ARRAY_DTYPE (type) = gfc_get_dtype (etype, as->rank);
   GFC_TYPE_ARRAY_RANK (type) = as->rank;
-  range = build_range_type (gfc_array_index_type, integer_zero_node,
+  range = build_range_type (gfc_array_index_type, gfc_index_zero_node,
 			    NULL_TREE);
   /* TODO: use main type if it is unbounded.  */
   GFC_TYPE_ARRAY_DATAPTR_TYPE (type) =
@@ -741,7 +741,7 @@ gfc_get_nodesc_array_type (tree etype, gfc_array_spec * as, int packed)
   else
     range = NULL_TREE;
 
-  range = build_range_type (gfc_array_index_type, integer_zero_node, range);
+  range = build_range_type (gfc_array_index_type, gfc_index_zero_node, range);
   TYPE_DOMAIN (type) = range;
 
   build_pointer_type (etype);
@@ -806,7 +806,7 @@ gfc_get_array_type_bounds (tree etype, int dimen, tree * lbound,
 
   /* Build an array descriptor record type.  */
   if (packed != 0)
-    stride = integer_one_node;
+    stride = gfc_index_one_node;
   else
     stride = NULL_TREE;
 
@@ -840,7 +840,7 @@ gfc_get_array_type_bounds (tree etype, int dimen, tree * lbound,
 	{
 	  tmp = fold (build (MINUS_EXPR, gfc_array_index_type, upper, lower));
 	  tmp = fold (build (PLUS_EXPR, gfc_array_index_type, tmp,
-			     integer_one_node));
+			     gfc_index_one_node));
 	  stride =
 	    fold (build (MULT_EXPR, gfc_array_index_type, tmp, stride));
 	  /* Check the folding worked.  */
@@ -858,7 +858,7 @@ gfc_get_array_type_bounds (tree etype, int dimen, tree * lbound,
   arraytype =
     build_array_type (etype,
 		      build_range_type (gfc_array_index_type,
-					integer_zero_node, NULL_TREE));
+					gfc_index_zero_node, NULL_TREE));
   arraytype = build_pointer_type (arraytype);
   GFC_TYPE_ARRAY_DATAPTR_TYPE (fat_type) = arraytype;
 
@@ -885,7 +885,7 @@ gfc_get_array_type_bounds (tree etype, int dimen, tree * lbound,
   arraytype =
     build_array_type (gfc_get_desc_dim_type (),
 		      build_range_type (gfc_array_index_type,
-					integer_zero_node,
+					gfc_index_zero_node,
 					gfc_rank_cst[dimen - 1]));
 
   decl = build_decl (FIELD_DECL, get_identifier ("dim"), arraytype);

gcc/fortran/trans.c

@@ -146,6 +146,16 @@ gfc_add_modify_expr (stmtblock_t * pblock, tree lhs, tree rhs)
 {
   tree tmp;
 
+#ifdef ENABLE_CHECKING
+  /* Make sure that the types of the rhs and the lhs are the same
+     for scalar assignments.  We should probably have something
+     similar for aggregates, but right now removing that check just
+     breaks everything.  */
+  if (TREE_TYPE (rhs) != TREE_TYPE (lhs)
+      && !AGGREGATE_TYPE_P (TREE_TYPE (lhs)))
+    abort ();
+#endif
+
   tmp = fold (build_v (MODIFY_EXPR, lhs, rhs));
   gfc_add_expr_to_block (pblock, tmp);
 }