fix PR 86484 and PR 84543

[gcc.git] / gcc / fortran / trans-stmt.c

diff --git a/gcc/fortran/trans-stmt.c b/gcc/fortran/trans-stmt.c
index e9e8456554997a28002bcb134b7a217590b7c4fe..795d3cc0a13c2033a3ca2e2a5e5eb971179d568d 100644 (file)
--- a/gcc/fortran/trans-stmt.c
+++ b/gcc/fortran/trans-stmt.c
@@ -578,7 +578,7 @@ gfc_trans_return (gfc_code * code)
 tree
 gfc_trans_pause (gfc_code * code)
 {
-  tree gfc_int4_type_node = gfc_get_int_type (4);
+  tree gfc_int8_type_node = gfc_get_int_type (8);
   gfc_se se;
   tree tmp;
 
@@ -589,7 +589,7 @@ gfc_trans_pause (gfc_code * code)
 
   if (code->expr1 == NULL)
     {
-      tmp = build_int_cst (gfc_int4_type_node, 0);
+      tmp = build_int_cst (size_type_node, 0);
       tmp = build_call_expr_loc (input_location,
                                 gfor_fndecl_pause_string, 2,
                                 build_int_cst (pchar_type_node, 0), tmp);
@@ -599,14 +599,15 @@ gfc_trans_pause (gfc_code * code)
       gfc_conv_expr (&se, code->expr1);
       tmp = build_call_expr_loc (input_location,
                                 gfor_fndecl_pause_numeric, 1,
-                                fold_convert (gfc_int4_type_node, se.expr));
+                                fold_convert (gfc_int8_type_node, se.expr));
     }
   else
     {
       gfc_conv_expr_reference (&se, code->expr1);
       tmp = build_call_expr_loc (input_location,
                             gfor_fndecl_pause_string, 2,
-                            se.expr, se.string_length);
+                                se.expr, fold_convert (size_type_node,
+                                                       se.string_length));
     }
 
   gfc_add_expr_to_block (&se.pre, tmp);
@@ -641,7 +642,8 @@ gfc_trans_stop (gfc_code *code, bool error_stop)
                                 : (flag_coarray == GFC_FCOARRAY_LIB
                                    ? gfor_fndecl_caf_stop_str
                                    : gfor_fndecl_stop_string),
-                                2, build_int_cst (pchar_type_node, 0), tmp);
+                                3, build_int_cst (pchar_type_node, 0), tmp,
+                                boolean_false_node);
     }
   else if (code->expr1->ts.type == BT_INTEGER)
     {
@@ -653,8 +655,9 @@ gfc_trans_stop (gfc_code *code, bool error_stop)
                                    : gfor_fndecl_error_stop_numeric)
                                 : (flag_coarray == GFC_FCOARRAY_LIB
                                    ? gfor_fndecl_caf_stop_numeric
-                                   : gfor_fndecl_stop_numeric), 1,
-                                fold_convert (integer_type_node, se.expr));
+                                   : gfor_fndecl_stop_numeric), 2,
+                                fold_convert (integer_type_node, se.expr),
+                                boolean_false_node);
     }
   else
     {
@@ -667,8 +670,9 @@ gfc_trans_stop (gfc_code *code, bool error_stop)
                                 : (flag_coarray == GFC_FCOARRAY_LIB
                                    ? gfor_fndecl_caf_stop_str
                                    : gfor_fndecl_stop_string),
-                                2, se.expr, fold_convert (size_type_node,
-                                                          se.string_length));
+                                3, se.expr, fold_convert (size_type_node,
+                                                          se.string_length),
+                                boolean_false_node);
     }
 
   gfc_add_expr_to_block (&se.pre, tmp);
@@ -1731,11 +1735,8 @@ trans_associate_var (gfc_symbol *sym, gfc_wrapped_block *block)
       if (sym->attr.subref_array_pointer)
        {
          gcc_assert (e->expr_type == EXPR_VARIABLE);
-         tmp = e->symtree->n.sym->ts.type == BT_CLASS
-             ? gfc_class_data_get (e->symtree->n.sym->backend_decl)
-             : e->symtree->n.sym->backend_decl;
-         tmp = gfc_get_element_type (TREE_TYPE (tmp));
-         tmp = fold_convert (gfc_array_index_type, size_in_bytes (tmp));
+         tmp = gfc_get_array_span (se.expr, e);
+
          gfc_conv_descriptor_span_set (&se.pre, desc, tmp);
        }
 
@@ -1903,7 +1904,8 @@ trans_associate_var (gfc_symbol *sym, gfc_wrapped_block *block)
 
       attr = gfc_expr_attr (e);
       if (sym->ts.type == BT_CHARACTER && e->ts.type == BT_CHARACTER
-         && (attr.allocatable || attr.pointer || attr.dummy))
+         && (attr.allocatable || attr.pointer || attr.dummy)
+         && POINTER_TYPE_P (TREE_TYPE (se.expr)))
        {
          /* These are pointer types already.  */
          tmp = fold_convert (TREE_TYPE (sym->backend_decl), se.expr);
@@ -3637,10 +3639,13 @@ gfc_trans_forall_loop (forall_info *forall_tmp, tree body,
       /* The exit condition.  */
       cond = fold_build2_loc (input_location, LE_EXPR, logical_type_node,
                              count, build_int_cst (TREE_TYPE (count), 0));
+
+      /* PR 83064 means that we cannot use annot_expr_parallel_kind until
+       the autoparallelizer can hande this.  */
       if (forall_tmp->do_concurrent)
        cond = build3 (ANNOTATE_EXPR, TREE_TYPE (cond), cond,
                       build_int_cst (integer_type_node,
-                                     annot_expr_parallel_kind),
+                                     annot_expr_ivdep_kind),
                       integer_zero_node);
 
       tmp = build1_v (GOTO_EXPR, exit_label);
@@ -5778,6 +5783,7 @@ gfc_trans_allocate (gfc_code * code)
   enum { E3_UNSET = 0, E3_SOURCE, E3_MOLD, E3_DESC } e3_is;
   stmtblock_t block;
   stmtblock_t post;
+  stmtblock_t final_block;
   tree nelems;
   bool upoly_expr, tmp_expr3_len_flag = false, al_len_needs_set, is_coarray;
   bool needs_caf_sync, caf_refs_comp;
@@ -5796,6 +5802,7 @@ gfc_trans_allocate (gfc_code * code)
 
   gfc_init_block (&block);
   gfc_init_block (&post);
+  gfc_init_block (&final_block);
 
   /* STAT= (and maybe ERRMSG=) is present.  */
   if (code->expr1)
@@ -5837,6 +5844,11 @@ gfc_trans_allocate (gfc_code * code)
 
       is_coarray = gfc_is_coarray (code->expr3);
 
+      if (code->expr3->expr_type == EXPR_FUNCTION && !code->expr3->mold
+         && (gfc_is_class_array_function (code->expr3)
+             || gfc_is_alloc_class_scalar_function (code->expr3)))
+       code->expr3->must_finalize = 1;
+
       /* Figure whether we need the vtab from expr3.  */
       for (al = code->ext.alloc.list; !vtab_needed && al != NULL;
           al = al->next)
@@ -5909,7 +5921,10 @@ gfc_trans_allocate (gfc_code * code)
          temp_obj_created = temp_var_needed = !VAR_P (se.expr);
        }
       gfc_add_block_to_block (&block, &se.pre);
-      gfc_add_block_to_block (&post, &se.post);
+      if (code->expr3->must_finalize)
+       gfc_add_block_to_block (&final_block, &se.post);
+      else
+       gfc_add_block_to_block (&post, &se.post);
 
       /* Special case when string in expr3 is zero.  */
       if (code->expr3->ts.type == BT_CHARACTER
@@ -6738,6 +6753,8 @@ gfc_trans_allocate (gfc_code * code)
 
   gfc_add_block_to_block (&block, &se.post);
   gfc_add_block_to_block (&block, &post);
+  if (code->expr3 && code->expr3->must_finalize)
+    gfc_add_block_to_block (&block, &final_block);
 
   return gfc_finish_block (&block);
 }