aboutsummaryrefslogtreecommitdiff
path: root/gcc/fortran/trans-decl.cc
diff options
context:
space:
mode:
Diffstat (limited to 'gcc/fortran/trans-decl.cc')
-rw-r--r--gcc/fortran/trans-decl.cc143
1 files changed, 75 insertions, 68 deletions
diff --git a/gcc/fortran/trans-decl.cc b/gcc/fortran/trans-decl.cc
index ddc4960..b077cee 100644
--- a/gcc/fortran/trans-decl.cc
+++ b/gcc/fortran/trans-decl.cc
@@ -197,6 +197,7 @@ tree gfor_fndecl_string_scan;
tree gfor_fndecl_string_verify;
tree gfor_fndecl_string_trim;
tree gfor_fndecl_string_minmax;
+tree gfor_fndecl_string_split;
tree gfor_fndecl_adjustl;
tree gfor_fndecl_adjustr;
tree gfor_fndecl_select_string;
@@ -208,6 +209,7 @@ tree gfor_fndecl_string_scan_char4;
tree gfor_fndecl_string_verify_char4;
tree gfor_fndecl_string_trim_char4;
tree gfor_fndecl_string_minmax_char4;
+tree gfor_fndecl_string_split_char4;
tree gfor_fndecl_adjustl_char4;
tree gfor_fndecl_adjustr_char4;
tree gfor_fndecl_select_string_char4;
@@ -821,11 +823,6 @@ gfc_finish_var_decl (tree decl, gfc_symbol * sym)
}
}
- /* Handle threadprivate variables. */
- if (sym->attr.threadprivate
- && (TREE_STATIC (decl) || DECL_EXTERNAL (decl)))
- set_decl_tls_model (decl, decl_default_tls_model (decl));
-
if (sym->attr.omp_allocate && TREE_STATIC (decl))
{
struct gfc_omp_namelist *n;
@@ -844,6 +841,11 @@ gfc_finish_var_decl (tree decl, gfc_symbol * sym)
if (sym->attr.ext_attr & (1 << EXT_ATTR_WEAK))
declare_weak (decl);
+ /* Handle threadprivate variables. */
+ if (sym->attr.threadprivate
+ && (TREE_STATIC (decl) || DECL_EXTERNAL (decl)))
+ set_decl_tls_model (decl, decl_default_tls_model (decl));
+
gfc_finish_decl_attrs (decl, &sym->attr);
}
@@ -2216,13 +2218,13 @@ get_proc_pointer_decl (gfc_symbol *sym)
false, true);
}
+ add_attributes_to_decl (&decl, sym);
+
/* Handle threadprivate procedure pointers. */
if (sym->attr.threadprivate
&& (TREE_STATIC (decl) || DECL_EXTERNAL (decl)))
set_decl_tls_model (decl, decl_default_tls_model (decl));
- add_attributes_to_decl (&decl, sym);
-
return decl;
}
@@ -3569,6 +3571,12 @@ gfc_build_intrinsic_function_decls (void)
build_pointer_type (pchar1_type_node), integer_type_node,
integer_type_node);
+ gfor_fndecl_string_split = gfc_build_library_function_decl_with_spec (
+ get_identifier (PREFIX ("string_split")), ". . R . R . . ",
+ gfc_charlen_type_node, 6, gfc_charlen_type_node, pchar1_type_node,
+ gfc_charlen_type_node, pchar1_type_node, gfc_charlen_type_node,
+ gfc_logical4_type_node);
+
gfor_fndecl_adjustl = gfc_build_library_function_decl_with_spec (
get_identifier (PREFIX("adjustl")), ". W . R ",
void_type_node, 3, pchar1_type_node, gfc_charlen_type_node,
@@ -3641,6 +3649,12 @@ gfc_build_intrinsic_function_decls (void)
build_pointer_type (pchar4_type_node), integer_type_node,
integer_type_node);
+ gfor_fndecl_string_split_char4 = gfc_build_library_function_decl_with_spec (
+ get_identifier (PREFIX ("string_split_char4")), ". . R . R . . ",
+ gfc_charlen_type_node, 6, gfc_charlen_type_node, pchar4_type_node,
+ gfc_charlen_type_node, pchar4_type_node, gfc_charlen_type_node,
+ gfc_logical4_type_node);
+
gfor_fndecl_adjustl_char4 = gfc_build_library_function_decl_with_spec (
get_identifier (PREFIX("adjustl_char4")), ". W . R ",
void_type_node, 3, pchar4_type_node, gfc_charlen_type_node,
@@ -4043,9 +4057,9 @@ gfc_build_builtin_function_decls (void)
gfor_fndecl_caf_finalize = gfc_build_library_function_decl (
get_identifier (PREFIX("caf_finalize")), void_type_node, 0);
- gfor_fndecl_caf_this_image = gfc_build_library_function_decl (
- get_identifier (PREFIX("caf_this_image")), integer_type_node,
- 1, integer_type_node);
+ gfor_fndecl_caf_this_image = gfc_build_library_function_decl_with_spec (
+ get_identifier (PREFIX ("caf_this_image")), ". r ", integer_type_node,
+ 1, pvoid_type_node);
gfor_fndecl_caf_num_images = gfc_build_library_function_decl (
get_identifier (PREFIX("caf_num_images")), integer_type_node,
@@ -4201,42 +4215,36 @@ gfc_build_builtin_function_decls (void)
void_type_node, 3, pvoid_type_node, ppvoid_type_node,
integer_type_node);
- gfor_fndecl_caf_form_team
- = gfc_build_library_function_decl_with_spec (
- get_identifier (PREFIX("caf_form_team")), ". . W . ",
- void_type_node, 3, integer_type_node, ppvoid_type_node,
- integer_type_node);
+ gfor_fndecl_caf_form_team = gfc_build_library_function_decl_with_spec (
+ get_identifier (PREFIX ("caf_form_team")), ". r w r w w w ",
+ void_type_node, 6, integer_type_node, ppvoid_type_node, pint_type,
+ pint_type, pchar_type_node, size_type_node);
- gfor_fndecl_caf_change_team
- = gfc_build_library_function_decl_with_spec (
- get_identifier (PREFIX("caf_change_team")), ". w . ",
- void_type_node, 2, ppvoid_type_node,
- integer_type_node);
+ gfor_fndecl_caf_change_team = gfc_build_library_function_decl_with_spec (
+ get_identifier (PREFIX ("caf_change_team")), ". r w w w ",
+ void_type_node, 4, pvoid_type_node, pint_type, pchar_type_node,
+ size_type_node);
- gfor_fndecl_caf_end_team
- = gfc_build_library_function_decl (
- get_identifier (PREFIX("caf_end_team")), void_type_node, 0);
+ gfor_fndecl_caf_end_team = gfc_build_library_function_decl_with_spec (
+ get_identifier (PREFIX ("caf_end_team")), ". w w w ", void_type_node, 3,
+ pint_type, pchar_type_node, size_type_node);
- gfor_fndecl_caf_get_team
- = gfc_build_library_function_decl (
- get_identifier (PREFIX("caf_get_team")),
- void_type_node, 1, integer_type_node);
+ gfor_fndecl_caf_get_team = gfc_build_library_function_decl_with_spec (
+ get_identifier (PREFIX ("caf_get_team")), ". r ", pvoid_type_node, 1,
+ pint_type);
- gfor_fndecl_caf_sync_team
- = gfc_build_library_function_decl_with_spec (
- get_identifier (PREFIX("caf_sync_team")), ". r . ",
- void_type_node, 2, ppvoid_type_node,
- integer_type_node);
+ gfor_fndecl_caf_sync_team = gfc_build_library_function_decl_with_spec (
+ get_identifier (PREFIX ("caf_sync_team")), ". r w w w ", void_type_node,
+ 4, pvoid_type_node, pint_type, pchar_type_node, size_type_node);
gfor_fndecl_caf_team_number
= gfc_build_library_function_decl_with_spec (
get_identifier (PREFIX("caf_team_number")), ". r ",
integer_type_node, 1, integer_type_node);
- gfor_fndecl_caf_image_status
- = gfc_build_library_function_decl_with_spec (
- get_identifier (PREFIX("caf_image_status")), ". . r ",
- integer_type_node, 2, integer_type_node, ppvoid_type_node);
+ gfor_fndecl_caf_image_status = gfc_build_library_function_decl_with_spec (
+ get_identifier (PREFIX ("caf_image_status")), ". r r ",
+ integer_type_node, 2, integer_type_node, ppvoid_type_node);
gfor_fndecl_caf_stopped_images
= gfc_build_library_function_decl_with_spec (
@@ -4779,14 +4787,14 @@ gfc_trans_deferred_vars (gfc_symbol * proc_sym, gfc_wrapped_block * block)
/* Nullify explicit return class arrays on entry. */
tree type;
tmp = get_proc_result (proc_sym);
- if (tmp && GFC_CLASS_TYPE_P (TREE_TYPE (tmp)))
- {
- gfc_start_block (&init);
- tmp = gfc_class_data_get (tmp);
- type = TREE_TYPE (gfc_conv_descriptor_data_get (tmp));
- gfc_conv_descriptor_data_set (&init, tmp, build_int_cst (type, 0));
- gfc_add_init_cleanup (block, gfc_finish_block (&init), NULL_TREE);
- }
+ if (tmp && GFC_CLASS_TYPE_P (TREE_TYPE (tmp)))
+ {
+ gfc_start_block (&init);
+ tmp = gfc_class_data_get (tmp);
+ type = TREE_TYPE (gfc_conv_descriptor_data_get (tmp));
+ gfc_conv_descriptor_data_set (&init, tmp, build_int_cst (type, 0));
+ gfc_add_init_cleanup (block, gfc_finish_block (&init), NULL_TREE);
+ }
}
@@ -4928,20 +4936,6 @@ gfc_trans_deferred_vars (gfc_symbol * proc_sym, gfc_wrapped_block * block)
}
}
- if (sym->attr.pointer && sym->attr.dimension
- && sym->attr.save == SAVE_NONE
- && !sym->attr.use_assoc
- && !sym->attr.host_assoc
- && !sym->attr.dummy
- && GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (sym->backend_decl)))
- {
- gfc_init_block (&tmpblock);
- gfc_conv_descriptor_span_set (&tmpblock, sym->backend_decl,
- build_int_cst (gfc_array_index_type, 0));
- gfc_add_init_cleanup (block, gfc_finish_block (&tmpblock),
- NULL_TREE);
- }
-
if (sym->ts.type == BT_CLASS
&& (sym->attr.save || flag_max_stack_var_size == 0)
&& CLASS_DATA (sym)->attr.allocatable)
@@ -5140,18 +5134,31 @@ gfc_trans_deferred_vars (gfc_symbol * proc_sym, gfc_wrapped_block * block)
se.descriptor_only = 1;
gfc_conv_expr (&se, e);
descriptor = se.expr;
- se.expr = gfc_conv_descriptor_data_addr (se.expr);
- se.expr = build_fold_indirect_ref_loc (input_location, se.expr);
+ se.expr = gfc_conv_descriptor_data_get (se.expr);
}
gfc_free_expr (e);
if (!sym->attr.dummy || sym->attr.intent == INTENT_OUT)
{
/* Nullify when entering the scope. */
- tmp = fold_build2_loc (input_location, MODIFY_EXPR,
- TREE_TYPE (se.expr), se.expr,
- fold_convert (TREE_TYPE (se.expr),
- null_pointer_node));
+ if (sym->ts.type == BT_CLASS
+ && (CLASS_DATA (sym)->attr.dimension
+ || CLASS_DATA (sym)->attr.codimension))
+ {
+ stmtblock_t nullify;
+ gfc_init_block (&nullify);
+ gfc_conv_descriptor_data_set (&nullify, descriptor,
+ null_pointer_node);
+ tmp = gfc_finish_block (&nullify);
+ }
+ else
+ {
+ tree typed_null = fold_convert (TREE_TYPE (se.expr),
+ null_pointer_node);
+ tmp = fold_build2_loc (input_location, MODIFY_EXPR,
+ TREE_TYPE (se.expr), se.expr,
+ typed_null);
+ }
if (sym->attr.optional)
{
tree present = gfc_conv_expr_present (sym);
@@ -5332,7 +5339,7 @@ gfc_trans_deferred_vars (gfc_symbol * proc_sym, gfc_wrapped_block * block)
continue;
/* 'omp allocate( {purpose: allocator, value: align},
{purpose: init-stmtlist, value: cleanup-stmtlist},
- {purpose: size-var, value: last-size-expr}}
+ {purpose: size-var, value: last-size-expr} )
where init-stmt/cleanup-stmt is the STATEMENT list to find the
try-final block; last-size-expr is to find the location after
which to add the code and 'size-var' is for the proper size, cf.
@@ -8085,13 +8092,13 @@ gfc_generate_function_code (gfc_namespace * ns)
|| sym->result->ts.u.derived->attr.alloc_comp
|| sym->result->ts.u.derived->attr.pointer_comp))
|| (sym->result->ts.type == BT_CLASS
- && (CLASS_DATA (sym)->attr.allocatable
- || CLASS_DATA (sym)->attr.class_pointer
+ && (CLASS_DATA (sym->result)->attr.allocatable
+ || CLASS_DATA (sym->result)->attr.class_pointer
|| CLASS_DATA (sym->result)->attr.alloc_comp
|| CLASS_DATA (sym->result)->attr.pointer_comp))))
{
artificial_result_decl = true;
- result = gfc_get_fake_result_decl (sym, 0);
+ result = gfc_get_fake_result_decl (sym->result, 0);
}
if (result != NULL_TREE && sym->attr.function && !sym->attr.pointer)
generated by cgit v1.1 at 2025-08-23 01:48:07 +0000