diff options
Diffstat (limited to 'gcc/fortran')
42 files changed, 5853 insertions, 1274 deletions
diff --git a/gcc/fortran/ChangeLog b/gcc/fortran/ChangeLog index db74f2c..0ea9c39 100644 --- a/gcc/fortran/ChangeLog +++ b/gcc/fortran/ChangeLog @@ -1,3 +1,802 @@ +2025-07-01 Harald Anlauf <anlauf@gmx.de> + + * coarray.cc (check_add_new_component): Treat pure and elemental + intrinsic functions the same as non-intrinsic ones. + (create_caf_add_data_parameter_type): Fix front-end memleaks. + * trans-intrinsic.cc (conv_caf_func_index): Likewise. + +2025-07-01 Andre Vehreschild <vehre@gcc.gnu.org> + + PR fortran/120847 + * coarray.cc (check_add_new_comp_handle_array): Make the count + of components static to be able to create more than one. Create + an array component only for array expressions. + +2025-07-01 Andre Vehreschild <vehre@gcc.gnu.org> + + PR fortran/120843 + * resolve.cc (resolve_operator): Report inconsistent coranks + only when not referencing this_image. + (gfc_op_rank_conformable): Treat coranks as inconformable only + when a coindex other then implicit this_image is used. + +2025-06-27 Harald Anlauf <anlauf@gmx.de> + + PR fortran/120784 + * interface.cc (gfc_match_end_interface): Detect empty local_name. + +2025-06-26 Martin Jambor <mjambor@suse.cz> + + * match.cc (gfc_match_nullify): Initialize p to NULL; + +2025-06-26 Andre Vehreschild <vehre@gcc.gnu.org> + + * trans.cc (gfc_allocate_using_malloc): Prevent possible memory + leak when allocation was already done. + +2025-06-26 Andre Vehreschild <vehre@gcc.gnu.org> + + * resolve.cc (resolve_fl_derived0): Do not create the token + component when not in coarray lib mode. + * trans-types.cc: Do not access the token when not in coarray + lib mode. + +2025-06-26 Andre Vehreschild <vehre@gcc.gnu.org> + + PR fortran/120711 + * trans-array.cc (gfc_trans_array_ctor_element): Store the value + of the offset for reuse. + +2025-06-24 Tobias Burnus <tburnus@baylibre.com> + + * trans-stmt.cc (gfc_trans_call_acc_attach_detach): New. + (gfc_trans_call): Call it. + +2025-06-24 Harald Anlauf <anlauf@gmx.de> + Jerry DeLisle <jvdelisle@gcc.gnu.org> + Mikael Morin <mikael@gcc.gnu.org> + + PR fortran/120743 + * trans-expr.cc (gfc_conv_substring): Substring indices are of + type gfc_charlen_type_node. Convert to size_type_node for + pointer arithmetic only after offset adjustments have been made. + +2025-06-24 Mikael Morin <morin-mikael@orange.fr> + + * misc.cc (gfc_var_name_for_select_type_temp): New function. + * gfortran.h (gfc_var_name_for_select_type_temp): Declare it. + * resolve.cc (resolve_select_type): Pick a discriminating name + from the SELECT TYPE variable reference and use it in the name + of the temporary variable that is generated. Truncate name to + the buffer size. + * match.cc (select_type_set_tmp): Likewise. Pass the + discriminating name... + (select_intrinsic_set_tmp): ... to this function. Use the + discriminating name likewise. Augment the buffer size to match + that of select_type_set_tmp and resolve_select_type. + +2025-06-23 Tobias Burnus <tburnus@baylibre.com> + + * openmp.cc (OACC_WAIT_CLAUSES): Add if clause. + * trans-openmp.cc (gfc_trans_oacc_wait_directive): Handle it. + +2025-06-23 Harald Anlauf <anlauf@gmx.de> + + PR fortran/120784 + * interface.cc (gfc_match_end_interface): If a use-associated + symbol is renamed, use the local_name for checking. + +2025-06-19 Mikael Morin <mikael@gcc.gnu.org> + + PR fortran/120713 + * trans-array.cc (gfc_trans_deferred_array): Statically + initialize deferred length variable for SAVEd character arrays. + +2025-06-18 Harald Anlauf <anlauf@gmx.de> + + PR fortran/82480 + * check.cc (gfc_check_fstat): Extend checks to INTENT(OUT) arguments. + (gfc_check_fstat_sub): Likewise. + (gfc_check_stat): Likewise. + (gfc_check_stat_sub): Likewise. + * intrinsic.texi: Adjust documentation. + +2025-06-16 Harald Anlauf <anlauf@gmx.de> + + PR fortran/51961 + * resolve.cc (conformable_arrays): Use modified rank check when + MOLD= expression is given. + +2025-06-12 Yuao Ma <c8ef@outlook.com> + Steven G. Kargl <kargl@gcc.gnu.org> + + PR fortran/113152 + * intrinsic.texi: Document new half-revolution trigonometric + functions. Reorder doc for atand. + +2025-06-06 Tobias Burnus <tburnus@baylibre.com> + Sandra Loosemore <sloosemore@baylibre.com> + + * f95-lang.cc (ATTR_PURE_NOTHROW_LIST): Define. + * trans-expr.cc (get_builtin_fn): Handle omp_get_num_devices + and omp_get_intrinsic_device. + * gfortran.h (gfc_option_t): Add disable_omp_... for them. + * options.cc (gfc_handle_option): Handle them with + -fno-builtin-. + +2025-06-04 Andre Vehreschild <vehre@gcc.gnu.org> + + PR fortran/120483 + * trans-expr.cc (gfc_conv_substring): Use pointer arithmetic on + static allocatable char arrays. + +2025-06-03 Harald Anlauf <anlauf@gmx.de> + + PR fortran/99838 + * data.cc (gfc_assign_data_value): For a new initializer use the + location from the constructor as fallback. + +2025-05-30 Harald Anlauf <anlauf@gmx.de> + + PR fortran/102599 + PR fortran/114022 + * expr.cc (simplify_complex_array_inquiry_ref): Helper function for + simplification of inquiry references (%re/%im) of constant complex + arrays. + (find_inquiry_ref): Use it for handling %re/%im inquiry references + of complex arrays. + (scalarize_intrinsic_call): Fix frontend memleak. + * primary.cc (gfc_match_varspec): When the reference is NULL, the + previous simplification has succeeded in evaluating inquiry + references also of arrays. + +2025-05-30 Thomas Koenig <tkoenig@gcc.gnu.org> + + PR fortran/120355 + * interface.cc (compare_parameter): If the global function has a + result clause, take typespec from there for the comparison against + the dummy argument. + +2025-05-30 Julian Brown <julian@codesourcery.com> + Tobias Burnus <tburnus@baylibre.com> + + * parse.cc (tree.h, fold-const.h, tree-hash-traits.h): Add includes + (for additions to omp-general.h). + +2025-05-29 Jerry DeLisle <jvdelisle@gcc.gnu.org> + + PR fortran/120049 + * check.cc(check_c_ptr_2): Rephrase error message + for clarity. + +2025-05-28 Tobias Burnus <tburnus@baylibre.com> + + PR fortran/113152 + * simplify.cc (gfc_simplify_cospi, gfc_simplify_sinpi): Avoid using + mpfr_fmod_ui in the MPFR < 4.2.0 version. + +2025-05-28 Jerry DeLisle <jvdelisle@gcc.gnu.org> + + PR fortran/119856 + * io.cc: Set missing comma error checks to STD_STD_LEGACY. + +2025-05-28 Yuao Ma <c8ef@outlook.com> + Steven G. Kargl <kargl@gcc.gnu.org> + + PR fortran/113152 + * gfortran.h (enum gfc_isym_id): Add new enum. + * intrinsic.cc (add_functions): Register new intrinsics. Changing the call + from gfc_resolve_trigd{,2} to gfc_resolve_trig{,2}. + * intrinsic.h (gfc_simplify_acospi, gfc_simplify_asinpi, + gfc_simplify_asinpi, gfc_simplify_atanpi, gfc_simplify_atan2pi, + gfc_simplify_cospi, gfc_simplify_sinpi, gfc_simplify_tanpi): New. + (gfc_resolve_trig): Rename from gfc_resolve_trigd. + (gfc_resolve_trig2): Rename from gfc_resolve_trigd2. + * iresolve.cc (gfc_resolve_trig): Rename from gfc_resolve_trigd. + (gfc_resolve_trig2): Rename from gfc_resolve_trigd2. + * mathbuiltins.def: Add 7 new math builtins and re-align. + * simplify.cc (gfc_simplify_acos, gfc_simplify_asin, + gfc_simplify_acosd, gfc_simplify_asind): Revise error message. + (gfc_simplify_acospi, gfc_simplify_asinpi, + gfc_simplify_asinpi, gfc_simplify_atanpi, gfc_simplify_atan2pi, + gfc_simplify_cospi, gfc_simplify_sinpi, gfc_simplify_tanpi): New. + +2025-05-27 Harald Anlauf <anlauf@gmx.de> + + PR fortran/101735 + * primary.cc (gfc_match_varspec): Correct order of logic. + +2025-05-27 Jerry DeLisle <jvdelisle@gcc.gnu.org> + + PR fortran/120049 + * check.cc (gfc_check_c_associated): Use new helper functions. + Only call check_c_ptr_1 if optional c_ptr_2 tests succeed. + (check_c_ptr_1): Handle only c_ptr_1 checks. + (check_c_ptr_2): Expand checks for c_ptr_2 and handle cases + where there is no derived pointer in the gfc_expr and check + the inmod_sym_id only if it exists. + * misc.cc (gfc_typename): Handle the case for BT_VOID rather + than throw an internal error. + +2025-05-27 Harald Anlauf <anlauf@gmx.de> + + PR fortran/101735 + * expr.cc (find_inquiry_ref): If an inquiry reference applies to + a substring, use that, and calculate substring length if needed. + * primary.cc (extend_ref): Also handle attaching to end of + reference chain for appending. + (gfc_match_varspec): Discrimate between arrays of character and + substrings of them. If a substring is taken from a character + component of a derived type, get the proper typespec so that + inquiry references work correctly. + (gfc_match_rvalue): Handle corner case where we hit a seemingly + dangling '%' and missed an inquiry reference. Try another match. + +2025-05-27 David Malcolm <dmalcolm@redhat.com> + + PR other/116792 + * error.cc (gfc_diagnostic_start_span): Update for diagnostic.h + changes. + +2025-05-19 Harald Anlauf <anlauf@gmx.de> + + PR fortran/120099 + * trans-types.cc (gfc_return_by_reference): Intrinsic functions + returning complex numbers may return their result by reference + with -ff2c. + +2025-05-15 Harald Anlauf <anlauf@gmx.de> + + PR fortran/85750 + * resolve.cc (resolve_symbol): Reorder conditions when to apply + default-initializers. + +2025-05-15 Tobias Burnus <tburnus@baylibre.com> + + * trans-openmp.cc (gfc_omp_deep_mapping_do): Handle SSA_NAME if + a def_stmt is available. + +2025-05-14 Thomas Koenig <tkoenig@gcc.gnu.org> + + PR fortran/120139 + * dump-parse-tree.cc (get_c_type_name): If no constant + size of an array exists, output an asterisk. + +2025-05-14 Thomas Koenig <tkoenig@gcc.gnu.org> + + PR fortran/120107 + * dump-parse-tree.cc (write_type): Do not dump non-interoperable + types. + +2025-05-14 Tobias Burnus <tburnus@baylibre.com> + + PR fortran/120225 + * simplify.cc (gfc_simplify_cotand): Fix used argument in + mpfr_tanu call. + +2025-05-14 Tobias Burnus <tburnus@baylibre.com> + + PR fortran/120225 + * simplify.cc: Include "trigd_fe.inc" only with MPFR < 4.2.0. + (rad2deg, rad2deg): Only define if MPFR < 4.2.0. + (gfc_simplify_acosd, gfc_simplify_asind, gfc_simplify_atand, + gfc_simplify_atan2d, gfc_simplify_cosd, gfc_simplify_tand, + gfc_simplify_cotand): Use mpfr_...u functions with MPFR >= 4.2.0. + +2025-05-13 Yuao Ma <c8ef@outlook.com> + Steven G. Kargl <kargl@gcc.gnu.org> + + PR fortran/113413 + * intrinsic.cc (do_check): Minor doc polish. + (add_functions): Add atand(y, x) mapping. + * intrinsic.texi: Update atand example. + +2025-05-13 Jakub Jelinek <jakub@redhat.com> + Daniil Kochergin <daniil2472s@gmail.com> + Tobias Burnus <tburnus@baylibre.com> + + PR fortran/120191 + * trans-intrinsic.cc (strip_kind_from_actual): Remove. + (gfc_conv_intrinsic_minmaxloc): Don't call strip_kind_from_actual. + Free and clear kind_arg->expr if non-NULL. Set back_arg->name to + "%VAL" instead of a loop looking for last argument. Remove actual + variable, use array_arg instead. Free and clear dim_arg->expr if + non-NULL for BT_CHARACTER cases instead of using a loop. + +2025-05-11 Thomas Koenig <tkoenig@gcc.gnu.org> + + PR fortran/120163 + * gfortran.h: Add formal_resolved to gfc_symbol. + * resolve.cc (gfc_resolve_formal_arglist): Set it. + (resolve_function): Do not call gfc_get_formal_from_actual_arglist + if we already resolved a formal arglist. + (resolve_call): Likewise. + +2025-05-10 Harald Anlauf <anlauf@gmx.de> + + PR fortran/102891 + * dependency.cc (gfc_ref_needs_temporary_p): Within an array + reference, inquiry references of complex variables generally + need a temporary. + +2025-05-10 Jakub Jelinek <jakub@redhat.com> + + PR fortran/120193 + * trans-types.cc (gfc_init_types): For flag_unsigned use + build_distinct_type_copy or build_variant_type_copy from + gfc_character_types[index_char] if index_char > -1 instead of + gfc_character_types[index_char] or + gfc_build_unsigned_type (&gfc_unsigned_kinds[index]). + +2025-05-08 Harald Anlauf <anlauf@gmx.de> + + PR fortran/120179 + * match.cc (gfc_match_do): Do not attempt to match end-of-statement + twice. + +2025-05-07 Paul Thomas <pault@gcc.gnu.org> + and Steven G. Kargl <kargl@gcc.gnu.org> + + PR fortran/119948 + * primary.cc (match_variable): Module procedures with sym the + same as result can be treated as variables, although marked + external. + +2025-05-06 Jerry DeLisle <jvdelisle@gcc.gnu.org> + + PR fortran/120049 + * check.cc (gfc_check_c_associated): Modify checks to avoid + ICE and allow use, intrinsic :: iso_c_binding from a separate + module file. + +2025-05-06 Thomas Koenig <tkoenig@gcc.gnu.org> + + PR fortran/119928 + * interface.cc (gfc_check_dummy_characteristics): Do not issue + error if one dummy symbol has been generated from an actual + argument and the other one has OPTIONAL, INTENT, ALLOCATABLE, + POINTER, TARGET, VALUE, ASYNCHRONOUS or CONTIGUOUS. + (gfc_get_formal_from_actual_arglist): Do nothing if symbol + is a class. + +2025-05-04 Harald Anlauf <anlauf@gmx.de> + + PR fortran/119986 + * expr.cc (is_subref_array): When searching for array references, + do not terminate early so that inquiry references to complex + components work. + * primary.cc (gfc_variable_attr): A substring reference can refer + to either a scalar or array character variable. Adjust search + accordingly. + +2025-05-01 Paul Thomas <pault@gcc.gnu.org> + + PR fortran/119948 + * resolve.cc (gfc_impure_variable): The result of a module + procedure with an interface declaration is not impure even if + the current namespace is not the same as the symbol's. + +2025-04-25 Harald Anlauf <anlauf@gmx.de> + + PR fortran/102900 + * trans-decl.cc (gfc_generate_function_code): Use sym->result + when generating fake result decl for functions returning + allocatable or pointer results. + * trans-expr.cc (gfc_conv_procedure_call): When checking the + pointer status of an actual argument passed to a non-allocatable, + non-pointer dummy which is of type CLASS, do not check the + class container of the actual if it is just a procedure pointer. + (gfc_trans_pointer_assignment): Fix treatment of assignment to + NULL of a procedure pointer. + +2025-04-23 Andre Vehreschild <vehre@gcc.gnu.org> + + PR fortran/119200 + * check.cc (gfc_check_lcobound): Use locus from intrinsic_where. + (gfc_check_image_index): Same. + (gfc_check_num_images): Same. + (gfc_check_team_number): Same. + (gfc_check_this_image): Same. + (gfc_check_ucobound): Same. + +2025-04-22 Andre Vehreschild <vehre@gcc.gnu.org> + + * match.cc (match_exit_cycle): Allow to exit team block. + (gfc_match_end_team): Create end_team node also without + parameter list. + * trans-intrinsic.cc (conv_stat_and_team): Team and team_number + only need to be a single pointer. + * trans-stmt.cc (trans_associate_var): Create a mapping coarray + token for coarray associations or it is not addressed correctly. + * trans.h (enum gfc_coarray_regtype): Add mapping mode to + coarray register. + +2025-04-22 Andre Vehreschild <vehre@gcc.gnu.org> + + * check.cc (gfc_check_image_index): Check for team or + team_number correctnes. + (gfc_check_num_images): Same. + * gfortran.texi: Update documentation on num_images' API + function. + * intrinsic.cc (add_functions): Update signature of image_index + and num_images. Both can take either a team handle or number. + * intrinsic.h (gfc_check_num_images): Update signature to take + either team or team_number. + (gfc_check_image_index): Can take coarray, subscripts and team + or team number now. + (gfc_simplify_image_index): Same. + (gfc_simplify_num_images): Same. + (gfc_resolve_image_index): Same. + * intrinsic.texi: Update documentation of num_images() Fortran + function. + * iresolve.cc (gfc_resolve_image_index): Update signature. + * simplify.cc (gfc_simplify_num_images): Update signature and + remove undocumented failed argument. + (gfc_simplify_image_index): Add team or team number argument. + * trans-intrinsic.cc (conv_stat_and_team): Because being + optional teams need to be a pointer to the opaque pointer. + (conv_caf_sendget): Correct call; was two arguments short. + (trans_image_index): Support team or team_number. + (trans_num_images): Same. + (conv_intrinsic_cobound): Adapt to changed signature of + num_images in call. + * trans-stmt.cc (gfc_trans_sync): Same. + +2025-04-22 Andre Vehreschild <vehre@gcc.gnu.org> + + PR fortran/87326 + * check.cc (gfc_check_this_image): Check the three different + parameter lists possible for this_image and sort them correctly. + * gfortran.texi: Update documentation on this_image's API. + * intrinsic.cc (add_functions): Update this_image's signature. + (check_specific): Add specific check for this_image. + * intrinsic.h (gfc_check_this_image): Change to flexible + argument list. + * intrinsic.texi: Update documentation on this_image(). + * iresolve.cc (gfc_resolve_this_image): Resolve the different + arguments. + * simplify.cc (gfc_simplify_this_image): Simplify the simplify + routine. + * trans-decl.cc (gfc_build_builtin_function_decls): Update + signature of this_image. + * trans-expr.cc (gfc_caf_get_image_index): Use correct signature + of this_image. + * trans-intrinsic.cc (trans_this_image): Adapt to correct + signature. + +2025-04-22 Andre Vehreschild <vehre@gcc.gnu.org> + + PR fortran/88154 + PR fortran/88960 + PR fortran/97210 + PR fortran/103001 + * check.cc (team_type_check): Check a type for being team_type + from the iso_fortran_env module. + (gfc_check_image_status): Use team_type check. + (gfc_check_get_team): Check for level argument. + (gfc_check_team_number): Use team_type check. + * expr.cc (gfc_check_assign): Add treatment for returning + team_type in caf-single mode. + * gfortran.texi: Add/Update documentation for get_team and + team_number API functions. + * intrinsic.cc (add_functions): Update get_team signature. + * intrinsic.h (gfc_resolve_get_team): Add prototype. + * intrinsic.texi: Add/Update documentation for get_team and + team_number Fortran functions. + * iresolve.cc (gfc_resolve_get_team): Resolve return type to be + of type team_type. + * iso-fortran-env.def: Update STAT_LOCK constants. They have + nothing to do with files. Add level constants for get_team. + * libgfortran.h: Add level and unlock_stat constants. + * simplify.cc (gfc_simplify_get_team): Simply to correct return + type team_type. + * trans-decl.cc (gfc_build_builtin_function_decls): Update + get_team and image_status API prototypes to correct signatures. + * trans-intrinsic.cc (conv_intrinsic_image_status): Translate + second parameter correctly. + (conv_intrinsic_team_number): Translate optional single team + argument correctly. + (gfc_conv_intrinsic_function): Add translation of get_team. + +2025-04-22 Andre Vehreschild <vehre@gcc.gnu.org> + + PR fortran/87326 + PR fortran/87556 + PR fortran/88254 + PR fortran/103796 + * coarray.cc (split_expr_at_caf_ref): Treat polymorphic types + correctly. Ensure resolve of expression after coindex. + (create_allocated_callback): Fix parameter of allocated function + for coarrays. + (coindexed_expr_callback): Improve detection of coarrays in + allocated function. + * decl.cc (gfc_match_end): Add team block matching. + * dump-parse-tree.cc (show_code_node): Dump change team block as + such. + * frontend-passes.cc (gfc_code_walker): Recognice team block. + * gfortran.texi: Add documentation for team api functions. + * intrinsic.texi: Add documentation about team_type in + iso_fortran_env module. + * iso-fortran-env.def (team_type): Use helper to get pointer + kind. + * match.cc (gfc_match_associate): Factor out matching of + association list, because it is used in change team as well. + (check_coarray_assoc): Ensure, that the association is to a + coarray. + (match_association_list): Match a list of association either in + associate or in change team. + (gfc_match_form_team): Match form team correctly include + new_index. + (gfc_match_change_team): Match change team with association + list. + (gfc_match_end_team): Match end team including stat and errmsg. + (gfc_match_return): Prevent return from team block. + * parse.cc (decode_statement): Sort team block. + (next_statement): Same. + (check_statement_label): Same. + (accept_statement): Same. + (verify_st_order): Same. + (parse_associate): Renamed to move_associates_to_block... + (move_associates_to_block): ... to enable reuse for change team. + (parse_change_team): Parse it as block. + (parse_executable): Same. + * parse.h (enum gfc_compile_state): Add team block as compiler + state. + * resolve.cc (resolve_scalar_argument): New function to resolve + an argument to a statement as a scalar. + (resolve_form_team): Resolve its members. + (resolve_change_team): Same. + (resolve_branch): Prevent branch from jumping out of team block. + (check_team): Removed. + * trans-decl.cc (gfc_build_builtin_function_decls): Add stat and + errmsg to team API functions and update their arguments. + * trans-expr.cc (gfc_trans_subcomponent_assign): Also null the + token when moving memory or an allocated() will not detect a + free. + * trans-intrinsic.cc (gfc_conv_intrinsic_caf_is_present_remote): + Adapt to signature change no longer a pointer-pointer. + * trans-stmt.cc (gfc_trans_form_team): Translate a form team + including new_index. + (gfc_trans_change_team): Translate a change team as a block. + +2025-04-22 Andre Vehreschild <vehre@gcc.gnu.org> + + PR fortran/87939 + * check.cc (gfc_check_move_alloc): Add stat and errmsg to + move_alloc. + * dump-parse-tree.cc (show_sync_stat): New helper function. + (show_code_node): Use show_sync_stat to print stat and errmsg. + * gfortran.h (struct sync_stat): New struct to unify stat and + errmsg handling. + * intrinsic.cc (add_subroutines): Correct signature of + move_alloc. + * intrinsic.h (gfc_check_move_alloc): Correct signature of + check_move_alloc. + * match.cc (match_named_arg): Match an optional argument to a + statement. + (match_stat_errmsg): Match a stat= or errmsg= named argument. + (gfc_match_critical): Use match_stat_errmsg to match the named + arguments. + (gfc_match_sync_team): Same. + * resolve.cc (resolve_team_argument): Resolve an expr to have + type TEAM_TYPE from iso_fortran_env. + (resolve_scalar_variable_as_arg): Resolve an argument as a + scalar type. + (resolve_sync_stat): Resolve stat and errmsg expressions. + (resolve_sync_team): Resolve a sync team statement using + sync_stat helper. + (resolve_end_team): Same. + (resolve_critical): Same. + * trans-decl.cc (gfc_build_builtin_function_decls): Correct + sync_team signature. + * trans-intrinsic.cc (conv_intrinsic_move_alloc): Store stat + an errmsg optional arguments in helper struct and use helper + to translate. + * trans-stmt.cc (trans_exit): Implement DRY pattern for + generating an _exit(). + (gfc_trans_sync_stat): Translate stat and errmsg contents. + (gfc_trans_end_team): Use helper to translate stat and errmsg. + (gfc_trans_sync_team): Same. + (gfc_trans_critical): Same. + * trans-stmt.h (gfc_trans_sync_stat): New function. + * trans.cc (gfc_deallocate_with_status): Parameterize check at + runtime to allow unallocated (co-)array when freeing a + structure. + (gfc_deallocate_scalar_with_status): Same and also add errmsg. + * trans.h (gfc_deallocate_with_status): Signature changes. + (gfc_deallocate_scalar_with_status): Same. + +2025-04-19 Steven G. Kargl <kargl@gcc.gnu.org> + + PR fortran/119836 + * resolve.cc (check_pure_function): Fix checking for + an impure subprogram within a DO CONCURRENT construct. + (pure_subroutine): Ditto. + +2025-04-16 Harald Anlauf <anlauf@gmx.de> + + PR fortran/106948 + * resolve.cc (gfc_pure_function): If a function has been resolved, + but esym is not yet set, look at its attributes to see whether it + is pure or elemental. + +2025-04-15 Tobias Burnus <tburnus@baylibre.com> + + * f95-lang.cc (LANG_HOOKS_OMP_DEEP_MAPPING, + LANG_HOOKS_OMP_DEEP_MAPPING_P, LANG_HOOKS_OMP_DEEP_MAPPING_CNT): + Define. + * openmp.cc (gfc_match_omp_clause_reduction): Fix location setting. + (resolve_omp_clauses): Permit allocatable components, reject + them and polymorphic variables in PRIVATE/FIRSTPRIVATE. + * trans-decl.cc (add_clause): Set clause location. + * trans-openmp.cc (gfc_has_alloc_comps): Add ptr_ok and + shallow_alloc_only Boolean arguments. + (gfc_omp_replace_alloc_by_to_mapping): New. + (gfc_omp_private_outer_ref, gfc_walk_alloc_comps, + gfc_omp_clause_default_ctor, gfc_omp_clause_copy_ctor, + gfc_omp_clause_assign_op, gfc_omp_clause_dtor): Update call to it. + (gfc_omp_finish_clause): Minor cleanups, improve location data, + handle allocatable components. + (gfc_omp_deep_mapping_map, gfc_omp_deep_mapping_item, + gfc_omp_deep_mapping_comps, gfc_omp_gen_simple_loop, + gfc_omp_get_array_size, gfc_omp_elmental_loop, + gfc_omp_deep_map_kind_p, gfc_omp_deep_mapping_int_p, + gfc_omp_deep_mapping_p, gfc_omp_deep_mapping_do, + gfc_omp_deep_mapping_cnt, gfc_omp_deep_mapping): New. + (gfc_trans_omp_array_section): Save array descriptor in case + deep-mapping lang hook will need it. + (gfc_trans_omp_clauses): Likewise; use better clause location data. + * trans.h (gfc_omp_deep_mapping_p, gfc_omp_deep_mapping_cnt, + gfc_omp_deep_mapping): Add function prototypes. + +2025-04-13 Thomas Koenig <tkoenig@gcc.gnu.org> + + PR fortran/119669 + * interface.cc (compare_parameter): Error when mismatch between + formal argument as subroutine and function. If the dummy + argument is a known function, set its typespec. + +2025-04-12 Thomas Schwinge <tschwinge@baylibre.com> + + PR fortran/101602 + * trans-stmt.cc (gfc_trans_concurrent_locality_spec): Fix + 'static_assert'. + +2025-04-09 Harald Anlauf <anlauf@gmx.de> + + PR fortran/119656 + * interface.cc (gfc_compare_actual_formal): Fix front-end memleak + when searching for matching interfaces. + * trans-expr.cc (gfc_conv_procedure_call): If there is a formal + dummy corresponding to an absent argument, use its type, and only + fall back to inferred type otherwise. + +2025-04-09 Paul Thomas <pault@gcc.gnu.org> + and Harald Anlauf <anlauf@gcc.gnu.org> + + PR fortran/119460 + * iresolve.cc (generate_reduce_op_wrapper): Increase the size + of 'tname'. Change intent of 'a' and 'b' to intent_in. + * trans-decl.cc (add_argument_checking): Do not test artificial + formal symbols. + * trans-expr.cc (gfc_conv_procedure_call): Remove reduce_scalar + and the blocks triggered by it. + * trans-intrinsic.cc (gfc_conv_intrinsic_function): Set the + result of non-character, scalar reduce to be allocatable. + +2025-04-09 Tobias Burnus <tburnus@baylibre.com> + + PR fortran/101602 + * resolve.cc (resolve_locality_spec): Remove 'sorry, unimplemented'. + * trans-stmt.cc (struct symbol_and_tree_t): New. + (gfc_trans_concurrent_locality_spec): New. + (gfc_trans_forall_1): Call it; update to handle local and local_init. + * trans-decl.cc (gfc_start_saved_local_decls, + gfc_stop_saved_local_decls): New; moved code from ... + (gfc_process_block_locals): ... here. Call it. + * trans.h (gfc_start_saved_local_decls, + gfc_stop_saved_local_decls): Declare. + +2025-04-02 Sandra Loosemore <sloosemore@baylibre.com> + + PR middle-end/118965 + * openmp.cc (gfc_parser_omp_clause_init_modifiers): Fix some + inconsistent code indentation. Remove code for recognizing + clauses without modifiers. Diagnose prefer_type without a + following paren. Adjust error message for an unrecognized modifier. + Diagnose missing target/targetsync modifier. + (gfc_match_omp_init): Fix more inconsistent code indentation. + +2025-03-28 Harald Anlauf <anlauf@gmx.de> + + * check.cc (gfc_invalid_boz): Correct spelling of compiler flag in + hint to -fallow-invalid-boz. + +2025-03-26 Harald Anlauf <anlauf@gmx.de> + + PR fortran/118796 + * resolve.cc: Do not apply default initialization to a derived-type + function result if the resolved function is use-associated. + +2025-03-25 Thomas Koenig <tkoenig@gcc.gnu.org> + + PR fortran/119419 + * dump-parse-tree.cc (write_funptr_fcn): New function. + (write_type): Invoke it for C_FUNPTR. + (write_interop_decl): Do not dump vtabs. + +2025-03-25 Sandra Loosemore <sloosemore@baylibre.com> + Tobias Burnus <tburnus@baylibre.com> + + * trans-openmp.cc (gfc_trans_omp_declare_variant): Remove accidental + redeclaration of pref. + +2025-03-22 Jakub Jelinek <jakub@redhat.com> + + * resolve.cc (resolve_procedure_expression): Remove extraneous space + from the middle of diagnostics. + +2025-03-21 Paul-Antoine Arras <parras@baylibre.com> + Tobias Burnus <tburnus@baylibre.com> + + * trans-openmp.cc (gfc_trans_omp_clauses): Make OMP_CLAUSE_DESTROY and + OMP_CLAUSE_INIT addressable. + * types.def (BT_FN_VOID_INT_INT_PTR_PTR_PTR_INT_PTR_INT_PTR_UINT_PTR): + New. + +2025-03-21 Jerry DeLisle <jvdelisle@gcc.gnu.org> + + PR fortran/119406 + * resolve.cc (resolve_locality_spec): Add space in error + message. + +2025-03-21 Jerry DeLisle <jvdelisle@gcc.gnu.org> + + PR fortran/119403 + * interface.cc (compare_parameter): Fix typo. + +2025-03-21 Paul Thomas <pault@gcc.gnu.org> + + PR fortran/85836 + * check.cc (get_ul_from_cst_cl): New function used in + check_operation. + (check_operation): New function used in check_reduce and + check_co_reduce. + (gfc_check_co_reduce): Use it. + (gfc_check_reduce): New function. + (gfc_check_rename): Add prototype for intrinsic with 6 arguments. + * gfortran.h : Add isym id for reduce and prototype for f6. + * intrinsic.cc (do_check): Add another argument expression and use + it in the call to the six argument specific check. + (add_sym_6): New function. + (add_functions): Add the discription of the reduce intrinsic and + add it to the intrinsic list. + * intrinsic.h : Add prototypes for gfc_check_reduce and + gfc_resolve_reduce. + * iresolve.cc (generate_reduce_op_wrapper): Generate a wrapper + subroutine for the 'operation' function to enable the library + implementation to be type agnostic and use pointer arithmetic + throughout. + (gfc_resolve_reduce): New function. + * trans-expr.cc (gfc_conv_procedure_call): Add flag for scalar + reduce. Generate a return variable 'sr' for scalar reduce, pass its + address to the library function and return it as the scalar result. + * trans-intrinsic.cc (gfc_conv_intrinsic_function): Array valued + reduce is called in same way as reshape. Fall through for call to + the scalar version. + +2025-03-21 Andre Vehreschild <vehre@gcc.gnu.org> + + PR fortran/119380 + * trans-array.cc (structure_alloc_comps): Prevent freeing of + procedure pointer components. + +2025-03-21 Andre Vehreschild <vehre@gcc.gnu.org> + + PR fortran/119349 + * trans-expr.cc (gfc_conv_procedure_call): Prevent deallocation + of array temporary for polymorphic temporary argument. + 2025-03-19 Harald Anlauf <anlauf@gmx.de> PR fortran/116706 diff --git a/gcc/fortran/check.cc b/gcc/fortran/check.cc index 3545864..838d523 100644 --- a/gcc/fortran/check.cc +++ b/gcc/fortran/check.cc @@ -67,7 +67,7 @@ gfc_invalid_boz (const char *msg, locus *loc) return false; } - const char *hint = _(" [see %<-fno-allow-invalid-boz%>]"); + const char *hint = _(" [see %<-fallow-invalid-boz%>]"); size_t len = strlen (msg) + strlen (hint) + 1; char *msg2 = (char *) alloca (len); strcpy (msg2, msg); @@ -1809,6 +1809,23 @@ gfc_check_atomic_ref (gfc_expr *value, gfc_expr *atom, gfc_expr *stat) return gfc_check_atomic (atom, 1, value, 0, stat, 2); } +bool +team_type_check (gfc_expr *e, int n) +{ + if (e->ts.type != BT_DERIVED || !e->ts.u.derived + || e->ts.u.derived->from_intmod != INTMOD_ISO_FORTRAN_ENV + || e->ts.u.derived->intmod_sym_id != ISOFORTRAN_TEAM_TYPE) + { + gfc_error ("%qs argument of %qs intrinsic at %L shall be of type " + "%<team_type%> from the intrinsic module " + "%<ISO_FORTRAN_ENV%>", + gfc_current_intrinsic_arg[n]->name, gfc_current_intrinsic, + &e->where); + return false; + } + + return true; +} bool gfc_check_image_status (gfc_expr *image, gfc_expr *team) @@ -1818,14 +1835,7 @@ gfc_check_image_status (gfc_expr *image, gfc_expr *team) || !positive_check (0, image)) return false; - if (team) - { - gfc_error ("%qs argument of %qs intrinsic at %L not yet supported", - gfc_current_intrinsic_arg[1]->name, gfc_current_intrinsic, - &team->where); - return false; - } - return true; + return !team || (scalar_check (team, 0) && team_type_check (team, 0)); } @@ -1905,10 +1915,25 @@ gfc_check_get_team (gfc_expr *level) { if (level) { - gfc_error ("%qs argument of %qs intrinsic at %L not yet supported", - gfc_current_intrinsic_arg[0]->name, gfc_current_intrinsic, - &level->where); - return false; + int l; + + if (!type_check (level, 0, BT_INTEGER) || !scalar_check (level, 0)) + return false; + + /* When level is a constant, try to extract it. If not, the runtime has + to check. */ + if (gfc_extract_int (level, &l, 0)) + return true; + + if (l < GFC_CAF_INITIAL_TEAM || l > GFC_CAF_CURRENT_TEAM) + { + gfc_error ("%qs argument of %qs intrinsic at %L shall specify one of " + "the INITIAL_TEAM, PARENT_TEAM or CURRENT_TEAM constants " + "from the intrinsic module ISO_FORTRAN_ENV", + gfc_current_intrinsic_arg[0]->name, gfc_current_intrinsic, + &level->where); + return false; + } } return true; } @@ -2442,31 +2467,24 @@ gfc_check_co_broadcast (gfc_expr *a, gfc_expr *source_image, gfc_expr *stat, } -bool -gfc_check_co_reduce (gfc_expr *a, gfc_expr *op, gfc_expr *result_image, - gfc_expr *stat, gfc_expr *errmsg) +/* Helper function for character arguments in gfc_check_[co_]reduce. */ + +static unsigned long +get_ul_from_cst_cl (const gfc_charlen *cl) +{ + return cl && cl->length && cl->length->expr_type == EXPR_CONSTANT + ? mpz_get_ui (cl->length->value.integer) : 0; +}; + + +/* Checks shared between co_reduce and reduce. */ +static bool +check_operation (gfc_expr *op, gfc_expr *a, bool is_co_reduce) { symbol_attribute attr; gfc_formal_arglist *formal; gfc_symbol *sym; - if (a->ts.type == BT_CLASS) - { - gfc_error ("The A argument at %L of CO_REDUCE shall not be polymorphic", - &a->where); - return false; - } - - if (gfc_expr_attr (a).alloc_comp) - { - gfc_error ("Support for the A argument at %L with allocatable components" - " is not yet implemented", &a->where); - return false; - } - - if (!check_co_collective (a, result_image, stat, errmsg, true)) - return false; - if (!gfc_resolve_expr (op)) return false; @@ -2483,8 +2501,9 @@ gfc_check_co_reduce (gfc_expr *a, gfc_expr *op, gfc_expr *result_image, /* None of the intrinsics fulfills the criteria of taking two arguments, returning the same type and kind as the arguments and being permitted as actual argument. */ - gfc_error ("Intrinsic function %s at %L is not permitted for CO_REDUCE", - op->symtree->n.sym->name, &op->where); + gfc_error ("Intrinsic function %s at %L is not permitted for %s", + op->symtree->n.sym->name, &op->where, + is_co_reduce ? "CO_REDUCE" : "REDUCE"); return false; } @@ -2510,12 +2529,14 @@ gfc_check_co_reduce (gfc_expr *a, gfc_expr *op, gfc_expr *result_image, if (!gfc_compare_types (&a->ts, &sym->result->ts)) { - gfc_error ("The A argument at %L has type %s but the function passed as " - "OPERATION at %L returns %s", + gfc_error ("The %s argument at %L has type %s but the function passed " + "as OPERATION at %L returns %s", + is_co_reduce ? "A" : "ARRAY", &a->where, gfc_typename (a), &op->where, gfc_typename (&sym->result->ts)); return false; } + if (!gfc_compare_types (&a->ts, &formal->sym->ts) || !gfc_compare_types (&a->ts, &formal->next->sym->ts)) { @@ -2567,42 +2588,59 @@ gfc_check_co_reduce (gfc_expr *a, gfc_expr *op, gfc_expr *result_image, if (a->ts.type == BT_CHARACTER) { - gfc_charlen *cl; unsigned long actual_size, formal_size1, formal_size2, result_size; - cl = a->ts.u.cl; - actual_size = cl && cl->length && cl->length->expr_type == EXPR_CONSTANT - ? mpz_get_ui (cl->length->value.integer) : 0; - - cl = formal->sym->ts.u.cl; - formal_size1 = cl && cl->length && cl->length->expr_type == EXPR_CONSTANT - ? mpz_get_ui (cl->length->value.integer) : 0; - - cl = formal->next->sym->ts.u.cl; - formal_size2 = cl && cl->length && cl->length->expr_type == EXPR_CONSTANT - ? mpz_get_ui (cl->length->value.integer) : 0; - - cl = sym->ts.u.cl; - result_size = cl && cl->length && cl->length->expr_type == EXPR_CONSTANT - ? mpz_get_ui (cl->length->value.integer) : 0; + actual_size = get_ul_from_cst_cl (a->ts.u.cl); + formal_size1 = get_ul_from_cst_cl (formal->sym->ts.u.cl); + formal_size2 = get_ul_from_cst_cl (formal->next->sym->ts.u.cl); + result_size = get_ul_from_cst_cl (sym->ts.u.cl); if (actual_size && ((formal_size1 && actual_size != formal_size1) || (formal_size2 && actual_size != formal_size2))) { - gfc_error ("The character length of the A argument at %L and of the " - "arguments of the OPERATION at %L shall be the same", - &a->where, &op->where); + gfc_error ("The character length of the %s argument at %L and of " + "the arguments of the OPERATION at %L shall be the same", + is_co_reduce ? "A" : "ARRAY", &a->where, &op->where); return false; } + if (actual_size && result_size && actual_size != result_size) { - gfc_error ("The character length of the A argument at %L and of the " - "function result of the OPERATION at %L shall be the same", + gfc_error ("The character length of the %s argument at %L and of " + "the function result of the OPERATION at %L shall be the " + "same", is_co_reduce ? "A" : "ARRAY", &a->where, &op->where); return false; } } + return true; +} + + +bool +gfc_check_co_reduce (gfc_expr *a, gfc_expr *op, gfc_expr *result_image, + gfc_expr *stat, gfc_expr *errmsg) +{ + if (a->ts.type == BT_CLASS) + { + gfc_error ("The A argument at %L of CO_REDUCE shall not be polymorphic", + &a->where); + return false; + } + + if (gfc_expr_attr (a).alloc_comp) + { + gfc_error ("Support for the A argument at %L with allocatable components" + " is not yet implemented", &a->where); + return false; + } + + if (!check_co_collective (a, result_image, stat, errmsg, true)) + return false; + + if (!check_operation (op, a, true)) + return false; return true; } @@ -3797,7 +3835,8 @@ gfc_check_lcobound (gfc_expr *coarray, gfc_expr *dim, gfc_expr *kind) { if (flag_coarray == GFC_FCOARRAY_NONE) { - gfc_fatal_error ("Coarrays disabled at %C, use %<-fcoarray=%> to enable"); + gfc_fatal_error ("Coarrays disabled at %L, use %<-fcoarray=%> to enable", + gfc_current_intrinsic_where); return false; } @@ -4670,8 +4709,18 @@ gfc_check_merge_bits (gfc_expr *i, gfc_expr *j, gfc_expr *mask) bool -gfc_check_move_alloc (gfc_expr *from, gfc_expr *to) +gfc_check_move_alloc (gfc_expr *from, gfc_expr *to, gfc_expr *stat, + gfc_expr *errmsg) { + struct sync_stat sync_stat = {stat, errmsg}; + + if ((stat || errmsg) + && !gfc_notify_std (GFC_STD_F2008, "STAT= or ERRMSG= at %L not supported", + &to->where)) + return false; + + gfc_resolve_sync_stat (&sync_stat); + if (!variable_check (from, 0, false)) return false; if (!allocatable_check (from, 0)) @@ -5136,6 +5185,62 @@ gfc_check_real (gfc_expr *a, gfc_expr *kind) bool +gfc_check_reduce (gfc_expr *array, gfc_expr *operation, gfc_expr *dim, + gfc_expr *mask, gfc_expr *identity, gfc_expr *ordered) +{ + if (array->ts.type == BT_CLASS) + { + gfc_error ("The ARRAY argument at %L of REDUCE shall not be polymorphic", + &array->where); + return false; + } + + if (!check_operation (operation, array, false)) + return false; + + if (dim && (dim->rank || dim->ts.type != BT_INTEGER)) + { + gfc_error ("The DIM argument at %L, if present, must be an integer " + "scalar", &dim->where); + return false; + } + + if (mask && (array->rank != mask->rank || mask->ts.type != BT_LOGICAL)) + { + gfc_error ("The MASK argument at %L, if present, must be a logical " + "array with the same rank as ARRAY", &mask->where); + return false; + } + + if (mask + && !gfc_check_conformance (array, mask, + _("arguments '%s' and '%s' for intrinsic %s"), + "ARRAY", "MASK", "REDUCE")) + return false; + + if (mask && !identity) + gfc_warning (0, "MASK present at %L without IDENTITY", &mask->where); + + if (ordered && (ordered->rank || ordered->ts.type != BT_LOGICAL)) + { + gfc_error ("The ORDERED argument at %L, if present, must be a logical " + "scalar", &ordered->where); + return false; + } + + if (identity && (identity->rank + || !gfc_compare_types (&array->ts, &identity->ts))) + { + gfc_error ("The IDENTITY argument at %L, if present, must be a scalar " + "with the same type as ARRAY", &identity->where); + return false; + } + + return true; +} + + +bool gfc_check_rename (gfc_expr *path1, gfc_expr *path2) { if (!type_check (path1, 0, BT_CHARACTER)) @@ -5847,39 +5952,110 @@ gfc_check_c_sizeof (gfc_expr *arg) } -bool -gfc_check_c_associated (gfc_expr *c_ptr_1, gfc_expr *c_ptr_2) +/* Helper functions check_c_ptr_1 and check_c_ptr_2 + used in gfc_check_c_associated. */ + +static inline +bool check_c_ptr_1 (gfc_expr *c_ptr_1) { + if ((c_ptr_1->ts.type == BT_VOID) + && (c_ptr_1->expr_type == EXPR_FUNCTION)) + return true; + if (c_ptr_1->ts.type != BT_DERIVED || c_ptr_1->ts.u.derived->from_intmod != INTMOD_ISO_C_BINDING || (c_ptr_1->ts.u.derived->intmod_sym_id != ISOCBINDING_PTR && c_ptr_1->ts.u.derived->intmod_sym_id != ISOCBINDING_FUNPTR)) - { - gfc_error ("Argument C_PTR_1 at %L to C_ASSOCIATED shall have the " - "type TYPE(C_PTR) or TYPE(C_FUNPTR)", &c_ptr_1->where); - return false; - } + goto check_1_error; + + if ((c_ptr_1->ts.type == BT_DERIVED) + && (c_ptr_1->expr_type == EXPR_STRUCTURE) + && (c_ptr_1->ts.u.derived->intmod_sym_id + == ISOCBINDING_NULL_FUNPTR)) + goto check_1_error; - if (!scalar_check (c_ptr_1, 0)) + if (scalar_check (c_ptr_1, 0)) + return true; + else + /* Return since the check_1_error message may not apply here. */ return false; - if (c_ptr_2 - && (c_ptr_2->ts.type != BT_DERIVED - || c_ptr_2->ts.u.derived->from_intmod != INTMOD_ISO_C_BINDING - || (c_ptr_1->ts.u.derived->intmod_sym_id - != c_ptr_2->ts.u.derived->intmod_sym_id))) - { - gfc_error ("Argument C_PTR_2 at %L to C_ASSOCIATED shall have the " - "same type as C_PTR_1: %s instead of %s", &c_ptr_1->where, - gfc_typename (&c_ptr_1->ts), - gfc_typename (&c_ptr_2->ts)); - return false; - } +check_1_error: + + gfc_error ("Argument C_PTR_1 at %L to C_ASSOCIATED shall have the " + "type TYPE(C_PTR) or TYPE(C_FUNPTR)", &c_ptr_1->where); + return false; +} - if (c_ptr_2 && !scalar_check (c_ptr_2, 1)) +static inline +bool check_c_ptr_2 (gfc_expr *c_ptr_1, gfc_expr *c_ptr_2) +{ + switch (c_ptr_2->ts.type) + { + case BT_VOID: + if (c_ptr_2->expr_type == EXPR_FUNCTION) + { + if ((c_ptr_1->ts.type == BT_DERIVED) + && c_ptr_1->expr_type == EXPR_STRUCTURE + && (c_ptr_1->ts.u.derived->intmod_sym_id + == ISOCBINDING_FUNPTR)) + goto check_2_error; + } + break; + + case BT_DERIVED: + if ((c_ptr_2->expr_type == EXPR_STRUCTURE) + && (c_ptr_2->ts.u.derived->intmod_sym_id == ISOCBINDING_PTR) + && (c_ptr_1->ts.type == BT_VOID) + && (c_ptr_1->expr_type == EXPR_FUNCTION)) + return scalar_check (c_ptr_2, 1); + + if ((c_ptr_2->expr_type == EXPR_STRUCTURE) + && (c_ptr_1->ts.type == BT_VOID) + && (c_ptr_1->expr_type == EXPR_FUNCTION)) + goto check_2_error; + + if (c_ptr_2->ts.u.derived->from_intmod != INTMOD_ISO_C_BINDING) + goto check_2_error; + + if (c_ptr_1->ts.type == BT_DERIVED + && (c_ptr_1->ts.u.derived->intmod_sym_id + != c_ptr_2->ts.u.derived->intmod_sym_id)) + goto check_2_error; + break; + + default: + goto check_2_error; + } + + if (scalar_check (c_ptr_2, 1)) + return true; + else + /* Return since the check_2_error message may not apply here. */ return false; - return true; +check_2_error: + + gfc_error ("Argument C_PTR_2 at %L to C_ASSOCIATED shall have the " + "same type as C_PTR_1, found %s instead of %s", &c_ptr_2->where, + gfc_typename (&c_ptr_2->ts), gfc_typename (&c_ptr_1->ts)); + + return false; + } + + +bool +gfc_check_c_associated (gfc_expr *c_ptr_1, gfc_expr *c_ptr_2) +{ + if (c_ptr_2) + { + if (check_c_ptr_2 (c_ptr_1, c_ptr_2)) + return check_c_ptr_1 (c_ptr_1); + else + return false; + } + else + return check_c_ptr_1 (c_ptr_1); } @@ -6331,7 +6507,7 @@ gfc_check_fseek_sub (gfc_expr *unit, gfc_expr *offset, gfc_expr *whence, gfc_exp bool -gfc_check_fstat (gfc_expr *unit, gfc_expr *array) +gfc_check_fstat (gfc_expr *unit, gfc_expr *values) { if (!type_check (unit, 0, BT_INTEGER)) return false; @@ -6339,11 +6515,17 @@ gfc_check_fstat (gfc_expr *unit, gfc_expr *array) if (!scalar_check (unit, 0)) return false; - if (!type_check (array, 1, BT_INTEGER) + if (!type_check (values, 1, BT_INTEGER) || !kind_value_check (unit, 0, gfc_default_integer_kind)) return false; - if (!array_check (array, 1)) + if (!array_check (values, 1)) + return false; + + if (!variable_check (values, 1, false)) + return false; + + if (!array_size_check (values, 1, 13)) return false; return true; @@ -6351,19 +6533,9 @@ gfc_check_fstat (gfc_expr *unit, gfc_expr *array) bool -gfc_check_fstat_sub (gfc_expr *unit, gfc_expr *array, gfc_expr *status) +gfc_check_fstat_sub (gfc_expr *unit, gfc_expr *values, gfc_expr *status) { - if (!type_check (unit, 0, BT_INTEGER)) - return false; - - if (!scalar_check (unit, 0)) - return false; - - if (!type_check (array, 1, BT_INTEGER) - || !kind_value_check (array, 1, gfc_default_integer_kind)) - return false; - - if (!array_check (array, 1)) + if (!gfc_check_fstat (unit, values)) return false; if (status == NULL) @@ -6376,6 +6548,9 @@ gfc_check_fstat_sub (gfc_expr *unit, gfc_expr *array, gfc_expr *status) if (!scalar_check (status, 2)) return false; + if (!variable_check (status, 2, false)) + return false; + return true; } @@ -6413,18 +6588,24 @@ gfc_check_ftell_sub (gfc_expr *unit, gfc_expr *offset) bool -gfc_check_stat (gfc_expr *name, gfc_expr *array) +gfc_check_stat (gfc_expr *name, gfc_expr *values) { if (!type_check (name, 0, BT_CHARACTER)) return false; if (!kind_value_check (name, 0, gfc_default_character_kind)) return false; - if (!type_check (array, 1, BT_INTEGER) - || !kind_value_check (array, 1, gfc_default_integer_kind)) + if (!type_check (values, 1, BT_INTEGER) + || !kind_value_check (values, 1, gfc_default_integer_kind)) + return false; + + if (!array_check (values, 1)) + return false; + + if (!variable_check (values, 1, false)) return false; - if (!array_check (array, 1)) + if (!array_size_check (values, 1, 13)) return false; return true; @@ -6432,42 +6613,38 @@ gfc_check_stat (gfc_expr *name, gfc_expr *array) bool -gfc_check_stat_sub (gfc_expr *name, gfc_expr *array, gfc_expr *status) +gfc_check_stat_sub (gfc_expr *name, gfc_expr *values, gfc_expr *status) { - if (!type_check (name, 0, BT_CHARACTER)) - return false; - if (!kind_value_check (name, 0, gfc_default_character_kind)) - return false; - - if (!type_check (array, 1, BT_INTEGER) - || !kind_value_check (array, 1, gfc_default_integer_kind)) - return false; - - if (!array_check (array, 1)) + if (!gfc_check_stat (name, values)) return false; if (status == NULL) return true; if (!type_check (status, 2, BT_INTEGER) - || !kind_value_check (array, 1, gfc_default_integer_kind)) + || !kind_value_check (status, 2, gfc_default_integer_kind)) return false; if (!scalar_check (status, 2)) return false; + if (!variable_check (status, 2, false)) + return false; + return true; } bool -gfc_check_image_index (gfc_expr *coarray, gfc_expr *sub) +gfc_check_image_index (gfc_expr *coarray, gfc_expr *sub, + gfc_expr *team_or_team_number) { mpz_t nelems; if (flag_coarray == GFC_FCOARRAY_NONE) { - gfc_fatal_error ("Coarrays disabled at %C, use %<-fcoarray=%> to enable"); + gfc_fatal_error ("Coarrays disabled at %L, use %<-fcoarray=%> to enable", + gfc_current_intrinsic_where); return false; } @@ -6481,12 +6658,8 @@ gfc_check_image_index (gfc_expr *coarray, gfc_expr *sub) return false; } - if (sub->ts.type != BT_INTEGER) - { - gfc_error ("Type of %s argument of IMAGE_INDEX at %L shall be INTEGER", - gfc_current_intrinsic_arg[1]->name, &sub->where); - return false; - } + if (!type_check (sub, 1, BT_INTEGER)) + return false; if (gfc_array_size (sub, &nelems)) { @@ -6501,47 +6674,46 @@ gfc_check_image_index (gfc_expr *coarray, gfc_expr *sub) mpz_clear (nelems); } + if (team_or_team_number) + { + if (!type_check2 (team_or_team_number, 2, BT_DERIVED, BT_INTEGER) + || !scalar_check (team_or_team_number, 2)) + return false; + + /* Check team is of team_type. */ + if (team_or_team_number->ts.type == BT_DERIVED + && !team_type_check (team_or_team_number, 2)) + return false; + } + return true; } - bool -gfc_check_num_images (gfc_expr *distance, gfc_expr *failed) +gfc_check_num_images (gfc_expr *team_or_team_number) { if (flag_coarray == GFC_FCOARRAY_NONE) { - gfc_fatal_error ("Coarrays disabled at %C, use %<-fcoarray=%> to enable"); + gfc_fatal_error ("Coarrays disabled at %L, use %<-fcoarray=%> to enable", + gfc_current_intrinsic_where); return false; } - if (distance) - { - if (!type_check (distance, 0, BT_INTEGER)) - return false; - - if (!nonnegative_check ("DISTANCE", distance)) - return false; - - if (!scalar_check (distance, 0)) - return false; - - if (!gfc_notify_std (GFC_STD_F2018, "DISTANCE= argument to " - "NUM_IMAGES at %L", &distance->where)) - return false; - } + if (!team_or_team_number) + return true; - if (failed) - { - if (!type_check (failed, 1, BT_LOGICAL)) - return false; + if (!gfc_notify_std (GFC_STD_F2008, + "%<team%> or %<team_number%> argument to %qs at %L", + gfc_current_intrinsic, &team_or_team_number->where)) + return false; - if (!scalar_check (failed, 1)) - return false; + if (!type_check2 (team_or_team_number, 0, BT_DERIVED, BT_INTEGER) + || !scalar_check (team_or_team_number, 0)) + return false; - if (!gfc_notify_std (GFC_STD_F2018, "FAILED= argument to " - "NUM_IMAGES at %L", &failed->where)) - return false; - } + if (team_or_team_number->ts.type == BT_DERIVED + && !team_type_check (team_or_team_number, 0)) + return false; return true; } @@ -6552,98 +6724,126 @@ gfc_check_team_number (gfc_expr *team) { if (flag_coarray == GFC_FCOARRAY_NONE) { - gfc_fatal_error ("Coarrays disabled at %C, use %<-fcoarray=%> to enable"); + gfc_fatal_error ("Coarrays disabled at %L, use %<-fcoarray=%> to enable", + gfc_current_intrinsic_where); return false; } - if (team) - { - if (team->ts.type != BT_DERIVED - || team->ts.u.derived->from_intmod != INTMOD_ISO_FORTRAN_ENV - || team->ts.u.derived->intmod_sym_id != ISOFORTRAN_TEAM_TYPE) - { - gfc_error ("TEAM argument at %L to the intrinsic TEAM_NUMBER " - "shall be of type TEAM_TYPE", &team->where); - return false; - } - } - else - return true; - - return true; + return !team || (scalar_check (team, 0) && team_type_check (team, 0)); } bool -gfc_check_this_image (gfc_expr *coarray, gfc_expr *dim, gfc_expr *distance) +gfc_check_this_image (gfc_actual_arglist *args) { + gfc_expr *coarray, *dim, *team, *cur; + + coarray = dim = team = NULL; + if (flag_coarray == GFC_FCOARRAY_NONE) { - gfc_fatal_error ("Coarrays disabled at %C, use %<-fcoarray=%> to enable"); + gfc_fatal_error ("Coarrays disabled at %L, use %<-fcoarray=%> to enable", + gfc_current_intrinsic_where); return false; } - if (coarray == NULL && dim == NULL && distance == NULL) + /* Shortcut when no arguments are given. */ + if (!args->expr && !args->next->expr && !args->next->next->expr) return true; - if (dim != NULL && coarray == NULL) - { - gfc_error ("DIM argument without COARRAY argument not allowed for " - "THIS_IMAGE intrinsic at %L", &dim->where); - return false; - } + cur = args->expr; - if (distance && (coarray || dim)) + if (cur) { - gfc_error ("The DISTANCE argument may not be specified together with the " - "COARRAY or DIM argument in intrinsic at %L", - &distance->where); - return false; + gfc_push_suppress_errors (); + if (coarray_check (cur, 0)) + coarray = cur; + else if (scalar_check (cur, 2) && team_type_check (cur, 2)) + team = cur; + else + { + gfc_pop_suppress_errors (); + gfc_error ("First argument of %<this_image%> intrinsic at %L must be " + "a coarray " + "variable or an object of type %<team_type%> from the " + "intrinsic module " + "%<ISO_FORTRAN_ENV%>", + &cur->where); + return false; + } + gfc_pop_suppress_errors (); } - /* Assume that we have "this_image (distance)". */ - if (coarray && !gfc_is_coarray (coarray) && coarray->ts.type == BT_INTEGER) + cur = args->next->expr; + if (cur) { - if (dim) + gfc_push_suppress_errors (); + if (dim_check (cur, 1, true) && cur->corank == 0) + dim = cur; + else if (scalar_check (cur, 2) && team_type_check (cur, 2)) { - gfc_error ("Unexpected DIM argument with noncoarray argument at %L", - &coarray->where); + if (team) + { + gfc_pop_suppress_errors (); + goto team_type_error; + } + team = cur; + } + else + { + gfc_pop_suppress_errors (); + gfc_error ("Second argument of %<this_image%> intrinsic at %L must " + "be an %<INTEGER%> " + "typed scalar or an object of type %<team_type%> from the " + "intrinsic " + "module %<ISO_FORTRAN_ENV%>", + &cur->where); return false; } - distance = coarray; + gfc_pop_suppress_errors (); } - if (distance) + cur = args->next->next->expr; + if (cur) { - if (!type_check (distance, 2, BT_INTEGER)) - return false; - - if (!nonnegative_check ("DISTANCE", distance)) - return false; - - if (!scalar_check (distance, 2)) - return false; - - if (!gfc_notify_std (GFC_STD_F2018, "DISTANCE= argument to " - "THIS_IMAGE at %L", &distance->where)) + if (team_type_check (cur, 2) && scalar_check (cur, 2)) + { + if (team) + goto team_type_error; + team = cur; + } + else return false; + } - return true; + if (dim != NULL && coarray == NULL) + { + gfc_error ("%<dim%> argument without %<coarray%> argument not allowed " + "for %<this_image%> intrinsic at %L", + &dim->where); + return false; } - if (!coarray_check (coarray, 0)) + if (dim && !dim_corank_check (dim, coarray)) return false; - if (dim != NULL) - { - if (!dim_check (dim, 1, false)) - return false; - - if (!dim_corank_check (dim, coarray)) - return false; - } + if (team + && !gfc_notify_std (GFC_STD_F2018, + "%<team%> argument to %<this_image%> at %L", + &team->where)) + return false; + args->expr = coarray; + args->next->expr = dim; + args->next->next->expr = team; return true; + +team_type_error: + gfc_error ( + "At most one argument of type %<team_type%> from the intrinsic module " + "%<ISO_FORTRAN_ENV%> to %<this_image%> at %L allowed", + &cur->where); + return false; } /* Calculate the sizes for transfer, used by gfc_check_transfer and also @@ -6842,7 +7042,8 @@ gfc_check_ucobound (gfc_expr *coarray, gfc_expr *dim, gfc_expr *kind) { if (flag_coarray == GFC_FCOARRAY_NONE) { - gfc_fatal_error ("Coarrays disabled at %C, use %<-fcoarray=%> to enable"); + gfc_fatal_error ("Coarrays disabled at %L, use %<-fcoarray=%> to enable", + gfc_current_intrinsic_where); return false; } diff --git a/gcc/fortran/coarray.cc b/gcc/fortran/coarray.cc index 7058325..ef8fd4e 100644 --- a/gcc/fortran/coarray.cc +++ b/gcc/fortran/coarray.cc @@ -357,7 +357,9 @@ split_expr_at_caf_ref (gfc_expr *expr, gfc_namespace *ns, gcc_assert (expr->expr_type == EXPR_VARIABLE); caf_ts = &expr->symtree->n.sym->ts; - if (!expr->symtree->n.sym->attr.codimension) + if (!(expr->symtree->n.sym->ts.type == BT_CLASS + ? CLASS_DATA (expr->symtree->n.sym)->attr.codimension + : expr->symtree->n.sym->attr.codimension)) { /* The coarray is in some component. Find it. */ caf_ref = expr->ref; @@ -432,6 +434,9 @@ split_expr_at_caf_ref (gfc_expr *expr, gfc_namespace *ns, else if (base->ts.type == BT_CLASS) convert_coarray_class_to_derived_type (base, ns); + memset (&(*post_caf_ref_expr)->ts, 0, sizeof (gfc_typespec)); + gfc_resolve_expr (*post_caf_ref_expr); + (*post_caf_ref_expr)->corank = 0; gfc_expression_rank (*post_caf_ref_expr); if (for_send) gfc_expression_rank (expr); @@ -498,7 +503,7 @@ check_add_new_comp_handle_array (gfc_expr *e, gfc_symbol *type, gfc_symbol *add_data) { gfc_component *comp; - int cnt = -1; + static int cnt = -1; gfc_symtree *caller_image; gfc_code *pre_code = caf_accessor_prepend; bool static_array_or_scalar = true; @@ -561,7 +566,7 @@ check_add_new_comp_handle_array (gfc_expr *e, gfc_symbol *type, else { comp->initializer = gfc_copy_expr (e); - if (e_attr.dimension) + if (e_attr.dimension && e->rank) { comp->attr.dimension = 1; comp->as = get_arrayspec_from_expr (e); @@ -692,7 +697,10 @@ check_add_new_component (gfc_symbol *type, gfc_expr *e, gfc_symbol *add_data) break; case EXPR_FUNCTION: if (!e->symtree->n.sym->attr.pure - && !e->symtree->n.sym->attr.elemental) + && !e->symtree->n.sym->attr.elemental + && !(e->value.function.isym + && (e->value.function.isym->pure + || e->value.function.isym->elemental))) /* Treat non-pure/non-elemental functions. */ check_add_new_comp_handle_array (e, type, add_data); else @@ -738,7 +746,6 @@ create_caf_add_data_parameter_type (gfc_expr *expr, gfc_namespace *ns, add_data->as->lower[0] = gfc_get_constant_expr (BT_INTEGER, gfc_default_integer_kind, &expr->where); - mpz_init (add_data->as->lower[0]->value.integer); mpz_set_si (add_data->as->lower[0]->value.integer, 1); for (gfc_ref *ref = expr->ref; ref; ref = ref->next) @@ -758,6 +765,7 @@ create_caf_add_data_parameter_type (gfc_expr *expr, gfc_namespace *ns, type->declared_at = expr->where; gfc_set_sym_referenced (type); gfc_commit_symbol (type); + free (name); return type; } @@ -1130,8 +1138,8 @@ create_allocated_callback (gfc_expr *expr) // ADD_ARG (expr->symtree->name, base, BT_VOID, INTENT_IN); base = post_caf_ref_expr->symtree->n.sym; + base->attr.pointer = !base->attr.dimension; gfc_set_sym_referenced (base); - gfc_commit_symbol (base); *argptr = gfc_get_formal_arglist (); (*argptr)->sym = base; argptr = &(*argptr)->next; @@ -1420,7 +1428,8 @@ coindexed_expr_callback (gfc_expr **e, int *walk_subtrees, { case GFC_ISYM_ALLOCATED: if ((*e)->value.function.actual->expr - && gfc_is_coindexed ((*e)->value.function.actual->expr)) + && (gfc_is_coarray ((*e)->value.function.actual->expr) + || gfc_is_coindexed ((*e)->value.function.actual->expr))) { rewrite_caf_allocated (e); *walk_subtrees = 0; diff --git a/gcc/fortran/data.cc b/gcc/fortran/data.cc index 5c83f69..a438c26 100644 --- a/gcc/fortran/data.cc +++ b/gcc/fortran/data.cc @@ -593,7 +593,13 @@ gfc_assign_data_value (gfc_expr *lvalue, gfc_expr *rvalue, mpz_t index, { /* Point the container at the new expression. */ if (last_con == NULL) - symbol->value = expr; + { + symbol->value = expr; + /* For a new initializer use the location from the + constructor as fallback. */ + if (!GFC_LOCUS_IS_SET(expr->where) && con != NULL) + symbol->value->where = con->where; + } else last_con->expr = expr; } diff --git a/gcc/fortran/decl.cc b/gcc/fortran/decl.cc index feb454e..69acd2d 100644 --- a/gcc/fortran/decl.cc +++ b/gcc/fortran/decl.cc @@ -8459,6 +8459,7 @@ gfc_match_end (gfc_statement *st) { case COMP_ASSOCIATE: case COMP_BLOCK: + case COMP_CHANGE_TEAM: if (startswith (block_name, "block@")) block_name = NULL; break; @@ -8515,7 +8516,7 @@ gfc_match_end (gfc_statement *st) case COMP_SUBROUTINE: *st = ST_END_SUBROUTINE; if (!abbreviated_modproc_decl) - target = " subroutine"; + target = " subroutine"; else target = " procedure"; eos_ok = !contained_procedure (); @@ -8524,7 +8525,7 @@ gfc_match_end (gfc_statement *st) case COMP_FUNCTION: *st = ST_END_FUNCTION; if (!abbreviated_modproc_decl) - target = " function"; + target = " function"; else target = " procedure"; eos_ok = !contained_procedure (); @@ -8646,6 +8647,12 @@ gfc_match_end (gfc_statement *st) eos_ok = 0; break; + case COMP_CHANGE_TEAM: + *st = ST_END_TEAM; + target = " team"; + eos_ok = 0; + break; + default: gfc_error ("Unexpected END statement at %C"); goto cleanup; @@ -8683,14 +8690,19 @@ gfc_match_end (gfc_statement *st) else got_matching_end = true; + if (*st == ST_END_TEAM && gfc_match_end_team () == MATCH_ERROR) + /* Emit errors of stat and errmsg parsing now to finish the block and + continue analysis of compilation unit. */ + gfc_error_check (); + old_loc = gfc_current_locus; /* If we're at the end, make sure a block name wasn't required. */ if (gfc_match_eos () == MATCH_YES) { - if (*st != ST_ENDDO && *st != ST_ENDIF && *st != ST_END_SELECT && *st != ST_END_FORALL && *st != ST_END_WHERE && *st != ST_END_BLOCK - && *st != ST_END_ASSOCIATE && *st != ST_END_CRITICAL) + && *st != ST_END_ASSOCIATE && *st != ST_END_CRITICAL + && *st != ST_END_TEAM) return MATCH_YES; if (!block_name) diff --git a/gcc/fortran/dependency.cc b/gcc/fortran/dependency.cc index 57c0c49..aa8a57a 100644 --- a/gcc/fortran/dependency.cc +++ b/gcc/fortran/dependency.cc @@ -944,8 +944,12 @@ gfc_ref_needs_temporary_p (gfc_ref *ref) types), not in characters. */ return subarray_p; - case REF_COMPONENT: case REF_INQUIRY: + /* Within an array reference, inquiry references of complex + variables generally need a temporary. */ + return subarray_p; + + case REF_COMPONENT: break; } diff --git a/gcc/fortran/dump-parse-tree.cc b/gcc/fortran/dump-parse-tree.cc index 1a15757..3cd2eee 100644 --- a/gcc/fortran/dump-parse-tree.cc +++ b/gcc/fortran/dump-parse-tree.cc @@ -2607,6 +2607,20 @@ show_omp_node (int level, gfc_code *c) fprintf (dumpfile, " (%s)", c->ext.omp_clauses->critical_name); } +static void +show_sync_stat (struct sync_stat *sync_stat) +{ + if (sync_stat->stat) + { + fputs (" stat=", dumpfile); + show_expr (sync_stat->stat); + } + if (sync_stat->errmsg) + { + fputs (" errmsg=", dumpfile); + show_expr (sync_stat->errmsg); + } +} /* Show a single code node and everything underneath it if necessary. */ @@ -2755,20 +2769,27 @@ show_code_node (int level, gfc_code *c) fputs ("FAIL IMAGE ", dumpfile); break; - case EXEC_CHANGE_TEAM: - fputs ("CHANGE TEAM", dumpfile); - break; - case EXEC_END_TEAM: fputs ("END TEAM", dumpfile); + show_sync_stat (&c->ext.sync_stat); break; case EXEC_FORM_TEAM: - fputs ("FORM TEAM", dumpfile); + fputs ("FORM TEAM ", dumpfile); + show_expr (c->expr1); + show_expr (c->expr2); + if (c->expr3) + { + fputs (" NEW_INDEX", dumpfile); + show_expr (c->expr3); + } + show_sync_stat (&c->ext.sync_stat); break; case EXEC_SYNC_TEAM: - fputs ("SYNC TEAM", dumpfile); + fputs ("SYNC TEAM ", dumpfile); + show_expr (c->expr1); + show_sync_stat (&c->ext.sync_stat); break; case EXEC_SYNC_ALL: @@ -2913,6 +2934,7 @@ show_code_node (int level, gfc_code *c) fputs ("ENDIF", dumpfile); break; + case EXEC_CHANGE_TEAM: case EXEC_BLOCK: { const char *blocktype, *sname = NULL; @@ -2928,17 +2950,23 @@ show_code_node (int level, gfc_code *c) if (fcn && fcn->expr_type == EXPR_FUNCTION) sname = fcn->value.function.actual->expr->symtree->n.sym->name; } + else if (c->op == EXEC_CHANGE_TEAM) + blocktype = "CHANGE TEAM"; else if (c->ext.block.assoc) blocktype = "ASSOCIATE"; else blocktype = "BLOCK"; show_indent (); fprintf (dumpfile, "%s ", blocktype); + if (c->op == EXEC_CHANGE_TEAM) + show_expr (c->expr1); for (alist = c->ext.block.assoc; alist; alist = alist->next) { fprintf (dumpfile, " %s = ", sname ? sname : alist->name); show_expr (alist->target); } + if (c->op == EXEC_CHANGE_TEAM) + show_sync_stat (&c->ext.block.sync_stat); ++show_level; ns = c->ext.block.ns; @@ -2948,8 +2976,13 @@ show_code_node (int level, gfc_code *c) gfc_current_ns = saved_ns; show_code (show_level, ns->code); --show_level; - show_indent (); - fprintf (dumpfile, "END %s ", blocktype); + if (c->op != EXEC_CHANGE_TEAM) + { + /* A CHANGE_TEAM is terminated by a END_TEAM, which have its own + stat and errmsg. Therefore, let it print itself. */ + show_indent (); + fprintf (dumpfile, "END %s ", blocktype); + } break; } @@ -3048,7 +3081,9 @@ show_code_node (int level, gfc_code *c) break; case EXEC_CRITICAL: - fputs ("CRITICAL\n", dumpfile); + fputs ("CRITICAL", dumpfile); + show_sync_stat (&c->ext.sync_stat); + fputc ('\n', dumpfile); show_code (level + 1, c->block->next); code_indent (level, 0); fputs ("END CRITICAL", dumpfile); @@ -4038,6 +4073,7 @@ static void write_interop_decl (gfc_symbol *); static void write_proc (gfc_symbol *, bool); static void show_external_symbol (gfc_gsymbol *, void *); static void write_type (gfc_symbol *sym); +static void write_funptr_fcn (gfc_symbol *); /* Do we need to write out an #include <ISO_Fortran_binding.h> or not? */ @@ -4335,6 +4371,8 @@ get_c_type_name (gfc_typespec *ts, gfc_array_spec *as, const char **pre, mpz_clear (sz); *asterisk = false; } + else + *asterisk = true; } return ret; } @@ -4379,9 +4417,11 @@ write_type (gfc_symbol *sym) { gfc_component *c; - /* Don't dump our iso c module. */ + /* Don't dump types that are not interoperable, our very own ISO C Binding + module, or vtypes. */ - if (sym->from_intmod == INTMOD_ISO_C_BINDING || sym->attr.flavor != FL_DERIVED) + if (sym->from_intmod == INTMOD_ISO_C_BINDING || sym->attr.flavor != FL_DERIVED + || sym->attr.vtype || !sym->attr.is_bind_c) return; fprintf (dumpfile, "typedef struct %s {\n", sym->name); @@ -4495,6 +4535,18 @@ write_formal_arglist (gfc_symbol *sym, bool bind_c) } +/* Write out an interoperable function returning a function pointer. Better + handled separately. As we know nothing about the type, assume void. + Function ponters can be freely converted in C anyway. */ + +static void +write_funptr_fcn (gfc_symbol *sym) +{ + fprintf (dumpfile, "void (*%s (", sym->binding_label); + write_formal_arglist (sym, 1); + fputs (")) ();\n", dumpfile); +} + /* Write out a procedure, including its arguments. */ static void write_proc (gfc_symbol *sym, bool bind_c) @@ -4552,7 +4604,13 @@ write_interop_decl (gfc_symbol *sym) else if (sym->attr.flavor == FL_DERIVED) write_type (sym); else if (sym->attr.flavor == FL_PROCEDURE) - write_proc (sym, true); + { + if (sym->ts.type == BT_DERIVED + && sym->ts.u.derived->intmod_sym_id == ISOCBINDING_FUNPTR) + write_funptr_fcn (sym); + else + write_proc (sym, true); + } } /* This section deals with dumping the global symbol tree. */ diff --git a/gcc/fortran/error.cc b/gcc/fortran/error.cc index f89d41d..004a4b2 100644 --- a/gcc/fortran/error.cc +++ b/gcc/fortran/error.cc @@ -618,9 +618,10 @@ gfc_diagnostic_text_starter (diagnostic_text_output_format &text_output, static void gfc_diagnostic_start_span (const diagnostic_location_print_policy &loc_policy, - pretty_printer *pp, + to_text &sink, expanded_location exploc) { + pretty_printer *pp = get_printer (sink); const bool colorize = pp_show_color (pp); char *locus_prefix = gfc_diagnostic_build_locus_prefix (loc_policy, exploc, colorize); diff --git a/gcc/fortran/expr.cc b/gcc/fortran/expr.cc index 0753667..b0495b7 100644 --- a/gcc/fortran/expr.cc +++ b/gcc/fortran/expr.cc @@ -1194,6 +1194,7 @@ is_subref_array (gfc_expr * e) what follows cannot be a subreference array, unless there is a substring reference. */ if (!seen_array && ref->type == REF_COMPONENT + && ref->next == NULL && ref->u.c.component->ts.type != BT_CHARACTER && ref->u.c.component->ts.type != BT_CLASS && !gfc_bt_struct (ref->u.c.component->ts.type)) @@ -1837,6 +1838,55 @@ find_substring_ref (gfc_expr *p, gfc_expr **newp) } +/* Simplify inquiry references (%re/%im) of constant complex arrays. + Used by find_inquiry_ref. */ + +static gfc_expr * +simplify_complex_array_inquiry_ref (gfc_expr *p, inquiry_type inquiry) +{ + gfc_expr *e, *r, *result; + gfc_constructor_base base; + gfc_constructor *c; + + if ((inquiry != INQUIRY_RE && inquiry != INQUIRY_IM) + || p->expr_type != EXPR_ARRAY + || p->ts.type != BT_COMPLEX + || p->rank <= 0 + || p->value.constructor == NULL + || !gfc_is_constant_array_expr (p)) + return NULL; + + /* Simplify array sections. */ + gfc_simplify_expr (p, 0); + + result = gfc_get_array_expr (BT_REAL, p->ts.kind, &p->where); + result->rank = p->rank; + result->shape = gfc_copy_shape (p->shape, p->rank); + + base = p->value.constructor; + for (c = gfc_constructor_first (base); c; c = gfc_constructor_next (c)) + { + e = c->expr; + if (e->expr_type != EXPR_CONSTANT) + goto fail; + + r = gfc_get_constant_expr (BT_REAL, e->ts.kind, &e->where); + if (inquiry == INQUIRY_RE) + mpfr_set (r->value.real, mpc_realref (e->value.complex), GFC_RND_MODE); + else + mpfr_set (r->value.real, mpc_imagref (e->value.complex), GFC_RND_MODE); + + gfc_constructor_append_expr (&result->value.constructor, r, &e->where); + } + + return result; + +fail: + gfc_free_expr (result); + return NULL; +} + + /* Pull an inquiry result out of an expression. */ static bool @@ -1845,7 +1895,9 @@ find_inquiry_ref (gfc_expr *p, gfc_expr **newp) gfc_ref *ref; gfc_ref *inquiry = NULL; gfc_ref *inquiry_head; + gfc_ref *ref_ss = NULL; gfc_expr *tmp; + bool nofail = false; tmp = gfc_copy_expr (p); @@ -1861,6 +1913,9 @@ find_inquiry_ref (gfc_expr *p, gfc_expr **newp) { inquiry = ref->next; ref->next = NULL; + if (ref->type == REF_SUBSTRING) + ref_ss = ref; + break; } } @@ -1890,6 +1945,28 @@ find_inquiry_ref (gfc_expr *p, gfc_expr **newp) if (!gfc_notify_std (GFC_STD_F2003, "LEN part_ref at %C")) goto cleanup; + /* Inquire length of substring? */ + if (ref_ss) + { + if (ref_ss->u.ss.start->expr_type == EXPR_CONSTANT + && ref_ss->u.ss.end->expr_type == EXPR_CONSTANT) + { + HOST_WIDE_INT istart, iend, length; + istart = gfc_mpz_get_hwi (ref_ss->u.ss.start->value.integer); + iend = gfc_mpz_get_hwi (ref_ss->u.ss.end->value.integer); + + if (istart <= iend) + length = iend - istart + 1; + else + length = 0; + *newp = gfc_get_int_expr (gfc_default_integer_kind, + NULL, length); + break; + } + else + goto cleanup; + } + if (tmp->ts.u.cl->length && tmp->ts.u.cl->length->expr_type == EXPR_CONSTANT) *newp = gfc_copy_expr (tmp->ts.u.cl->length); @@ -1920,24 +1997,50 @@ find_inquiry_ref (gfc_expr *p, gfc_expr **newp) break; case INQUIRY_RE: - if (tmp->ts.type != BT_COMPLEX || tmp->expr_type != EXPR_CONSTANT) + if (tmp->ts.type != BT_COMPLEX) goto cleanup; if (!gfc_notify_std (GFC_STD_F2008, "RE part_ref at %C")) goto cleanup; + if (tmp->expr_type == EXPR_ARRAY) + { + *newp = simplify_complex_array_inquiry_ref (tmp, INQUIRY_RE); + if (*newp != NULL) + { + nofail = true; + break; + } + } + + if (tmp->expr_type != EXPR_CONSTANT) + goto cleanup; + *newp = gfc_get_constant_expr (BT_REAL, tmp->ts.kind, &tmp->where); mpfr_set ((*newp)->value.real, mpc_realref (tmp->value.complex), GFC_RND_MODE); break; case INQUIRY_IM: - if (tmp->ts.type != BT_COMPLEX || tmp->expr_type != EXPR_CONSTANT) + if (tmp->ts.type != BT_COMPLEX) goto cleanup; if (!gfc_notify_std (GFC_STD_F2008, "IM part_ref at %C")) goto cleanup; + if (tmp->expr_type == EXPR_ARRAY) + { + *newp = simplify_complex_array_inquiry_ref (tmp, INQUIRY_IM); + if (*newp != NULL) + { + nofail = true; + break; + } + } + + if (tmp->expr_type != EXPR_CONSTANT) + goto cleanup; + *newp = gfc_get_constant_expr (BT_REAL, tmp->ts.kind, &tmp->where); mpfr_set ((*newp)->value.real, mpc_imagref (tmp->value.complex), GFC_RND_MODE); @@ -1950,7 +2053,7 @@ find_inquiry_ref (gfc_expr *p, gfc_expr **newp) if (!(*newp)) goto cleanup; - else if ((*newp)->expr_type != EXPR_CONSTANT) + else if ((*newp)->expr_type != EXPR_CONSTANT && !nofail) { gfc_free_expr (*newp); goto cleanup; @@ -2522,7 +2625,7 @@ scalarize_intrinsic_call (gfc_expr *e, bool init_flag) rank[n] = a->expr->rank; else rank[n] = 1; - ctor = gfc_constructor_copy (a->expr->value.constructor); + ctor = a->expr->value.constructor; args[n] = gfc_constructor_first (ctor); } else @@ -3836,7 +3939,13 @@ gfc_check_assign (gfc_expr *lvalue, gfc_expr *rvalue, int conform, if (has_pointer && (ref == NULL || ref->next == NULL) && lvalue->symtree->n.sym->attr.data) return true; - else + /* Prevent the following error message for caf-single mode, because there + are no teams in single mode and the simplify returns a null then. */ + else if (!(flag_coarray == GFC_FCOARRAY_SINGLE + && rvalue->ts.type == BT_DERIVED + && rvalue->ts.u.derived->from_intmod == INTMOD_ISO_FORTRAN_ENV + && rvalue->ts.u.derived->intmod_sym_id + == ISOFORTRAN_TEAM_TYPE)) { gfc_error ("NULL appears on right-hand side in assignment at %L", &rvalue->where); diff --git a/gcc/fortran/f95-lang.cc b/gcc/fortran/f95-lang.cc index 124d62f..bb4ce6d 100644 --- a/gcc/fortran/f95-lang.cc +++ b/gcc/fortran/f95-lang.cc @@ -148,6 +148,9 @@ gfc_get_sarif_source_language (const char *) #undef LANG_HOOKS_OMP_CLAUSE_LINEAR_CTOR #undef LANG_HOOKS_OMP_CLAUSE_DTOR #undef LANG_HOOKS_OMP_FINISH_CLAUSE +#undef LANG_HOOKS_OMP_DEEP_MAPPING +#undef LANG_HOOKS_OMP_DEEP_MAPPING_P +#undef LANG_HOOKS_OMP_DEEP_MAPPING_CNT #undef LANG_HOOKS_OMP_ALLOCATABLE_P #undef LANG_HOOKS_OMP_SCALAR_TARGET_P #undef LANG_HOOKS_OMP_SCALAR_P @@ -188,6 +191,9 @@ gfc_get_sarif_source_language (const char *) #define LANG_HOOKS_OMP_CLAUSE_LINEAR_CTOR gfc_omp_clause_linear_ctor #define LANG_HOOKS_OMP_CLAUSE_DTOR gfc_omp_clause_dtor #define LANG_HOOKS_OMP_FINISH_CLAUSE gfc_omp_finish_clause +#define LANG_HOOKS_OMP_DEEP_MAPPING gfc_omp_deep_mapping +#define LANG_HOOKS_OMP_DEEP_MAPPING_P gfc_omp_deep_mapping_p +#define LANG_HOOKS_OMP_DEEP_MAPPING_CNT gfc_omp_deep_mapping_cnt #define LANG_HOOKS_OMP_ALLOCATABLE_P gfc_omp_allocatable_p #define LANG_HOOKS_OMP_SCALAR_P gfc_omp_scalar_p #define LANG_HOOKS_OMP_SCALAR_TARGET_P gfc_omp_scalar_target_p @@ -558,7 +564,7 @@ gfc_builtin_function (tree decl) return decl; } -/* So far we need just these 10 attribute types. */ +/* So far we need just these 12 attribute types. */ #define ATTR_NULL 0 #define ATTR_LEAF_LIST (ECF_LEAF) #define ATTR_NOTHROW_LEAF_LIST (ECF_NOTHROW | ECF_LEAF) @@ -574,6 +580,7 @@ gfc_builtin_function (tree decl) #define ATTR_COLD_NORETURN_NOTHROW_LEAF_LIST \ (ECF_COLD | ECF_NORETURN | \ ECF_NOTHROW | ECF_LEAF) +#define ATTR_PURE_NOTHROW_LIST (ECF_PURE | ECF_NOTHROW) static void gfc_define_builtin (const char *name, tree type, enum built_in_function code, diff --git a/gcc/fortran/frontend-passes.cc b/gcc/fortran/frontend-passes.cc index ef9c801..02a0a23 100644 --- a/gcc/fortran/frontend-passes.cc +++ b/gcc/fortran/frontend-passes.cc @@ -5340,6 +5340,7 @@ gfc_code_walker (gfc_code **c, walk_code_fn_t codefn, walk_expr_fn_t exprfn, { case EXEC_BLOCK: + case EXEC_CHANGE_TEAM: WALK_SUBCODE (co->ext.block.ns->code); if (co->ext.block.assoc) { diff --git a/gcc/fortran/gfortran.h b/gcc/fortran/gfortran.h index 7c6e9b6..6848bd1 100644 --- a/gcc/fortran/gfortran.h +++ b/gcc/fortran/gfortran.h @@ -647,6 +647,7 @@ enum gfc_isym_id GFC_ISYM_RANK, GFC_ISYM_REAL, GFC_ISYM_REALPART, + GFC_ISYM_REDUCE, GFC_ISYM_RENAME, GFC_ISYM_REPEAT, GFC_ISYM_RESHAPE, @@ -720,6 +721,14 @@ enum gfc_isym_id remains compatible. */ GFC_ISYM_SU_KIND, GFC_ISYM_UINT, + + GFC_ISYM_ACOSPI, + GFC_ISYM_ASINPI, + GFC_ISYM_ATANPI, + GFC_ISYM_ATAN2PI, + GFC_ISYM_COSPI, + GFC_ISYM_SINPI, + GFC_ISYM_TANPI, }; enum init_local_logical @@ -2027,6 +2036,9 @@ typedef struct gfc_symbol This is legal in Fortran, but can cause problems with autogenerated C prototypes for C23. */ unsigned ext_dummy_arglist_mismatch:1; + /* Set if the formal arglist has already been resolved, to avoid + trying to generate it again from actual arguments. */ + unsigned formal_resolved:1; /* Reference counter, used for memory management. @@ -2543,6 +2555,8 @@ typedef union struct gfc_expr *); bool (*f5)(struct gfc_expr *, struct gfc_expr *, struct gfc_expr *, struct gfc_expr *, struct gfc_expr *); + bool (*f6)(struct gfc_expr *, struct gfc_expr *, struct gfc_expr *, + struct gfc_expr *, struct gfc_expr *, struct gfc_expr *); } gfc_check_f; @@ -3159,6 +3173,11 @@ enum locality_type LOCALITY_NUM }; +struct sync_stat +{ + gfc_expr *stat, *errmsg; +}; + typedef struct gfc_code { gfc_exec_op op; @@ -3194,6 +3213,7 @@ typedef struct gfc_code gfc_omp_variant *omp_variants; bool omp_bool; int stop_code; + struct sync_stat sync_stat; struct { @@ -3204,6 +3224,7 @@ typedef struct gfc_code unsigned arr_spec_from_expr3:1; /* expr3 is not explicit */ unsigned expr3_not_explicit:1; + struct sync_stat sync_stat; } alloc; @@ -3212,6 +3233,7 @@ typedef struct gfc_code gfc_namespace *ns; gfc_association_list *assoc; gfc_case *case_list; + struct sync_stat sync_stat; } block; @@ -3280,8 +3302,10 @@ typedef struct int flag_init_logical; int flag_init_character; char flag_init_character_value; - bool disable_omp_is_initial_device; - bool disable_acc_on_device; + bool disable_omp_is_initial_device:1; + bool disable_omp_get_initial_device:1; + bool disable_omp_get_num_devices:1; + bool disable_acc_on_device:1; int fpe; int fpe_summary; @@ -3483,6 +3507,8 @@ void gfc_done_2 (void); int get_c_kind (const char *, CInteropKind_t *); +const char * gfc_var_name_for_select_type_temp (gfc_expr *); + const char *gfc_closest_fuzzy_match (const char *, char **); inline void vec_push (char **&optr, size_t &osz, const char *elt) @@ -3982,6 +4008,7 @@ bool gfc_resolve_index (gfc_expr *, int); bool gfc_resolve_dim_arg (gfc_expr *); bool gfc_resolve_substring (gfc_ref *, bool *); void gfc_resolve_substring_charlen (gfc_expr *); +void gfc_resolve_sync_stat (struct sync_stat *); gfc_expr *gfc_expr_to_initialize (gfc_expr *); bool gfc_type_is_extensible (gfc_symbol *); bool gfc_resolve_intrinsic (gfc_symbol *, locus *); diff --git a/gcc/fortran/gfortran.texi b/gcc/fortran/gfortran.texi index 9632161..841f613 100644 --- a/gcc/fortran/gfortran.texi +++ b/gcc/fortran/gfortran.texi @@ -4230,6 +4230,12 @@ future implementation of teams. It is about to change without further notice. * _gfortran_caf_co_min:: Collective minimum reduction * _gfortran_caf_co_sum:: Collective summing reduction * _gfortran_caf_co_reduce:: Generic collective reduction +* _gfortran_caf_form_team:: Team creation function +* _gfortran_caf_change_team:: Team activation function +* _gfortran_caf_end_team:: Team termination function +* _gfortran_caf_sync_team:: Synchronize all images of a given team +* _gfortran_caf_get_team:: Get the opaque handle of the specified team +* _gfortran_caf_team_number:: Get the unique id of the given team @end menu @@ -4294,21 +4300,23 @@ using the STOP and ERROR STOP statements; those use different library calls. @table @asis @item @emph{Synopsis}: -@code{int _gfortran_caf_this_image (int distance)} +@code{int _gfortran_caf_this_image (caf_team_t team)} @item @emph{Description}: -This function returns the current image number, which is a positive number. +Return the current image number in the @var{team}, or in the current team, if +no @var{team} is given. @item @emph{Arguments}: @multitable @columnfractions .15 .70 -@item @var{distance} @tab As specified for the @code{this_image} intrinsic -in TS18508. Shall be a nonnegative number. +@item @var{team} @tab intent(in), optional; The team this image's number is +requested for. If null, the image number in the current team is returned. @end multitable @item @emph{Notes}: -If the Fortran intrinsic @code{this_image} is invoked without an argument, which -is the only permitted form in Fortran 2008, GCC passes @code{0} as -first argument. +Available since Fortran 2008 without argument; Since Fortran 2018 with optional +team argument. Fortran 2008 uses 0 as argument for team, which is permissible, +because a team handle is always an opaque pointer, which as a special case can +be null here. @end table @@ -4318,25 +4326,29 @@ first argument. @table @asis @item @emph{Synopsis}: -@code{int _gfortran_caf_num_images(int distance, int failed)} +@code{int _gfortran_caf_num_images (caf_team_t team, int32_t *team_number)} @item @emph{Description}: -This function returns the number of images in the current team, if -@var{distance} is 0 or the number of images in the parent team at the specified -distance. If @var{failed} is -1, the function returns the number of all images at -the specified distance; if it is 0, the function returns the number of -nonfailed images, and if it is 1, it returns the number of failed images. +This function returns the number of images in the team given by @var{team} or +@var{team_number}, if either one is present. If both are null, then the number +of images in the current team is returned. @item @emph{Arguments}: @multitable @columnfractions .15 .70 -@item @var{distance} @tab the distance from this image to the ancestor. -Shall be positive. -@item @var{failed} @tab shall be -1, 0, or 1 +@item @var{team} @tab intent(in), optional; The team the number of images is +requested for. If null, the number of images in the current team is returned. +@item @var{team_number} @tab intent(in), optional; The team id for which the +number of teams is requested; if unset, then number of images in the current +team is returned. @end multitable @item @emph{Notes}: -This function follows TS18508. If the num_image intrinsic has no arguments, -then the compiler passes @code{distance=0} and @code{failed=-1} to the function. +When both argument are given, then it is caf-library dependent which argument +is examined first. Current implementations prioritize the @var{team} argument, +because it is easier to retrive the number of images from it. + +Fortran 2008 or later, with no arguments; Fortran 2018 or later with two +arguments. @end table @@ -4705,9 +4717,9 @@ structure. operation, i.e., zero on success and non-zero on error. When @code{NULL} and an error occurs, then an error message is printed and the program is terminated. @item @var{team} @tab intent(in) The opaque team handle as returned by -@code{FORM TEAM}. Unused at the moment. +@code{FORM TEAM}. @item @var{team_number} @tab intent(in) The number of the team this access is -to be part of. Unused at the moment. +to be part of. @end multitable @item @emph{Notes}: @@ -4806,9 +4818,9 @@ structure. operation, i.e., zero on success and non-zero on error. When @code{NULL} and an error occurs, then an error message is printed and the program is terminated. @item @var{team} @tab intent(in) The opaque team handle as returned by -@code{FORM TEAM}. Unused at the moment. +@code{FORM TEAM}. @item @var{team_number} @tab intent(in) The number of the team this access is -to be part of. Unused at the moment. +to be part of. @end multitable @item @emph{Notes}: @@ -4906,13 +4918,13 @@ the operation on the sending side, i.e., zero on success and non-zero on error. When @code{NULL} and an error occurs, then an error message is printed and the program is terminated. @item @var{dst_team} @tab intent(in) The opaque team handle as returned by -@code{FORM TEAM}. Unused at the moment. +@code{FORM TEAM}. @item @var{dst_team_number} @tab intent(in) The number of the team this access -is to be part of. Unused at the moment. +is to be part of. @item @var{src_team} @tab intent(in) The opaque team handle as returned by -@code{FORM TEAM}. Unused at the moment. +@code{FORM TEAM}. @item @var{src_team_number} @tab intent(in) The number of the team this access -is to be part of. Unused at the moment. +is to be part of. @end multitable @item @emph{Notes}: @@ -5656,6 +5668,180 @@ or an array descriptor. @end table + +@node _gfortran_caf_form_team +@subsection @code{_gfortran_caf_form_team} --- Team creation function +@cindex Coarray, _gfortran_caf_form_team + +@table @asis +@item @emph{Synopsis}: +@code{void _gfortran_caf_form_team (int team_id, caf_team_t *team, +int *new_index, int *stat, char *errmsg, size_t errmsg_len)} + +@item @emph{Description}: +Create a team. All images giving the same @var{team_id} in a call to +@code{FORM TEAM} will form a new team addressable by the opaque handle +@var{team} which is of type @code{team_type} from the intrinsic module +@ref{ISO_FORTRAN_ENV}. In the team the image gets the image index given by +@var{new_index} if present. If @var{new_index} is absent, then an +implementation specific index is assigned. + +@item @emph{Arguments}: +@multitable @columnfractions .15 .70 +@item @var{team_id} @tab intent(in) A unique id for each team to form. Images +giving the same @var{team_id} in a call to @code{FORM TEAM} belong to the same +team. +@item @var{team} @tab intent(out) The opaque pointer to the newly formed team +@item @var{new_index} @tab intent(in) If non-null gives the unique index of +this image in the newly formed team. When no @var{new_index} is given, the +caf-library is free to choose a unique index. +@item @var{stat} @tab intent(out) Stores the status STAT= and may be NULL. +@item @var{errmsg} @tab intent(out) When an error occurs, this is set to +an error message; may be NULL. +@item @var{errmsg_len} @tab intent(in) the buffer size of errmsg +@end multitable + +@item @emph{Notes}: +The id given in @var{team_id} has to be unique in all subsequent calls to +@code{FORM TEAM} on the same image. That id is the same used in +@code{TEAM_NUMBER=} of coarray indexes, which motivates the uniqueness. + +The index given in @var{new_index} needs to be unique among all members of +team to create. Failing uniqueness may lead to misbehaviour, which depends +on the caf-library's implementation. The library is free to implement +checks for this, which imposes overhead and therefore may be avoided. +@end table + + + +@node _gfortran_caf_change_team +@subsection @code{_gfortran_caf_change_team} --- Team activation function +@cindex Coarray, _gfortran_caf_change_team + +@table @asis +@item @emph{Synopsis}: +@code{void _gfortran_caf_change_team (caf_team_t team, int *stat, char *errmsg, +size_t errmsg_len)} + +@item @emph{Description}: +Actives the team given by @var{team}, which must be formed but not active +yet. This routine starts a new epoch on the coarray memory pool. All +coarrays registered from now on, will be freeed once the team is terminated. + +@item @emph{Arguments}: +@multitable @columnfractions .15 .70 +@item @var{team} @tab intent(inout) The opaque pointer to an already formed +team +@item @var{stat} @tab intent(out) Stores the status STAT= and may be NULL. +@item @var{errmsg} @tab intent(out) When an error occurs, this is set to +an error message; may be NULL. +@item @var{errmsg_len} @tab intent(in) the buffer size of errmsg +@end multitable + +@item @emph{Notes}: +When an error occurs and @var{stat} is non-null, it will be set. Nevertheless +will the Fortran program continue with the first statement in the change team +block. +@end table + + + +@node _gfortran_caf_end_team +@subsection @code{_gfortran_caf_end_team} --- Team termination function +@cindex Coarray, _gfortran_caf_end_team + +@table @asis +@item @emph{Synopsis}: +@code{void _gfortran_caf_end_team (int *stat, char *errmsg, size_t errmsg_len)} + +@item @emph{Description}: +Terminates the last team changed to. The coarray memory epoch is +terminated and all coarrays allocated since the execution of @code{CHANGE TEAM} +are freeed. + +@item @emph{Arguments}: +@multitable @columnfractions .15 .70 +@item @var{stat} @tab intent(out) Stores the status STAT= and may be NULL. +@item @var{errmsg} @tab intent(out) When an error occurs, this is set to +an error message; may be NULL. +@item @var{errmsg_len} @tab intent(in) the buffer size of errmsg +@end multitable +@end table + + + +@node _gfortran_caf_sync_team +@subsection @code{_gfortran_caf_sync_team} --- Synchronize all images of a given team +@cindex Coarray, _gfortran_caf_sync_team + +@table @asis +@item @emph{Synopsis}: +@code{void _gfortran_caf_sync_team (caf_team_t team, int *stat, char *errmsg, +size_t errmsg_len)} + +@item @emph{Description}: +Blocks execution of the image calling @code{SYNC TEAM} until all images of the +team given by @var{team} have joined the synchronisation call. + +@item @emph{Arguments}: +@multitable @columnfractions .15 .70 +@item @var{team} @tab intent(in) The opaque pointer to an active team +@item @var{stat} @tab intent(out) Stores the status STAT= and may be NULL. +@item @var{errmsg} @tab intent(out) When an error occurs, this is set to +an error message; may be NULL. +@item @var{errmsg_len} @tab intent(in) the buffer size of errmsg +@end multitable +@end table + + + +@node _gfortran_caf_get_team +@subsection @code{_gfortran_caf_get_team} --- Get the opaque handle of the specified team +@cindex Coarray, _gfortran_caf_get_team + +@table @asis +@item @emph{Synopsis}: +@code{caf_team_t _gfortran_caf_get_team (int32_t *level)} + +@item @emph{Description}: +Get the current team, when @var{level} is null, or the team specified by +@var{level} set to @code{INITIAL_TEAM}, @code{PARENT_TEAM} or +@code{CURRENT_TEAM} from the @code{ISO_FORTRAN_ENV} intrinsic module. When +being on the @code{INITIAL_TEAM} and requesting its @code{PARENT_TEAM}, then +the initial team is returned. + +@item @emph{Arguments}: +@multitable @columnfractions .15 .70 +@item @var{level} @tab intent(in) If set to one of the levels specified in +the @code{ISO_FORTRAN_ENV} module, the function returns the handle of the given +team. Values different from the allowed ones lead to a runtime error. +@end multitable +@end table + + + +@node _gfortran_caf_team_number +@subsection @code{_gfortran_caf_team_number} --- Get the unique id of the given team +@cindex Coarray, _gfortran_caf_team_number + +@table @asis +@item @emph{Synopsis}: +@code{int _gfortran_caf_team_number (caf_team_t team)} + +@item @emph{Description}: +The team id given when forming the team @ref{_gfortran_caf_form_team} of the +team specified by @var{team}, if given, or of the current team, if @var{team} +is absent. It is a runtime error to specify a non-existing team. +The team has to be formed, i.e., it is not necessary that it is changed +into to get the team number. The initial team has the team number @code{-1}. + +@item @emph{Arguments}: +@multitable @columnfractions .15 .70 +@item @var{team} @tab intent(in) The team for which the team id is desired. +@end multitable +@end table + + @c Intrinsic Procedures @c --------------------------------------------------------------------- diff --git a/gcc/fortran/interface.cc b/gcc/fortran/interface.cc index c59ed1f..f74fbf0 100644 --- a/gcc/fortran/interface.cc +++ b/gcc/fortran/interface.cc @@ -452,11 +452,20 @@ gfc_match_end_interface (void) case INTERFACE_DTIO: case INTERFACE_GENERIC: + /* If a use-associated symbol is renamed, check the local_name. */ + const char *local_name = current_interface.sym->name; + + if (current_interface.sym->attr.use_assoc + && current_interface.sym->attr.use_rename + && current_interface.sym->ns->use_stmts->rename + && (current_interface.sym->ns->use_stmts->rename->local_name[0] + != '\0')) + local_name = current_interface.sym->ns->use_stmts->rename->local_name; + if (type != current_interface.type - || strcmp (current_interface.sym->name, name) != 0) + || strcmp (local_name, name) != 0) { - gfc_error ("Expecting %<END INTERFACE %s%> at %C", - current_interface.sym->name); + gfc_error ("Expecting %<END INTERFACE %s%> at %C", local_name); m = MATCH_ERROR; } @@ -1403,77 +1412,82 @@ gfc_check_dummy_characteristics (gfc_symbol *s1, gfc_symbol *s2, } } - /* Check INTENT. */ - if (s1->attr.intent != s2->attr.intent && !s1->attr.artificial - && !s2->attr.artificial) - { - snprintf (errmsg, err_len, "INTENT mismatch in argument '%s'", - s1->name); - return false; - } + /* A lot of information is missing for artificially generated + formal arguments, let's not look into that. */ - /* Check OPTIONAL attribute. */ - if (s1->attr.optional != s2->attr.optional) + if (!s1->attr.artificial && !s2->attr.artificial) { - snprintf (errmsg, err_len, "OPTIONAL mismatch in argument '%s'", - s1->name); - return false; - } + /* Check INTENT. */ + if (s1->attr.intent != s2->attr.intent) + { + snprintf (errmsg, err_len, "INTENT mismatch in argument '%s'", + s1->name); + return false; + } - /* Check ALLOCATABLE attribute. */ - if (s1->attr.allocatable != s2->attr.allocatable) - { - snprintf (errmsg, err_len, "ALLOCATABLE mismatch in argument '%s'", - s1->name); - return false; - } + /* Check OPTIONAL attribute. */ + if (s1->attr.optional != s2->attr.optional) + { + snprintf (errmsg, err_len, "OPTIONAL mismatch in argument '%s'", + s1->name); + return false; + } - /* Check POINTER attribute. */ - if (s1->attr.pointer != s2->attr.pointer) - { - snprintf (errmsg, err_len, "POINTER mismatch in argument '%s'", - s1->name); - return false; - } + /* Check ALLOCATABLE attribute. */ + if (s1->attr.allocatable != s2->attr.allocatable) + { + snprintf (errmsg, err_len, "ALLOCATABLE mismatch in argument '%s'", + s1->name); + return false; + } - /* Check TARGET attribute. */ - if (s1->attr.target != s2->attr.target) - { - snprintf (errmsg, err_len, "TARGET mismatch in argument '%s'", - s1->name); - return false; - } + /* Check POINTER attribute. */ + if (s1->attr.pointer != s2->attr.pointer) + { + snprintf (errmsg, err_len, "POINTER mismatch in argument '%s'", + s1->name); + return false; + } - /* Check ASYNCHRONOUS attribute. */ - if (s1->attr.asynchronous != s2->attr.asynchronous) - { - snprintf (errmsg, err_len, "ASYNCHRONOUS mismatch in argument '%s'", - s1->name); - return false; - } + /* Check TARGET attribute. */ + if (s1->attr.target != s2->attr.target) + { + snprintf (errmsg, err_len, "TARGET mismatch in argument '%s'", + s1->name); + return false; + } - /* Check CONTIGUOUS attribute. */ - if (s1->attr.contiguous != s2->attr.contiguous) - { - snprintf (errmsg, err_len, "CONTIGUOUS mismatch in argument '%s'", - s1->name); - return false; - } + /* Check ASYNCHRONOUS attribute. */ + if (s1->attr.asynchronous != s2->attr.asynchronous) + { + snprintf (errmsg, err_len, "ASYNCHRONOUS mismatch in argument '%s'", + s1->name); + return false; + } - /* Check VALUE attribute. */ - if (s1->attr.value != s2->attr.value) - { - snprintf (errmsg, err_len, "VALUE mismatch in argument '%s'", - s1->name); - return false; - } + /* Check CONTIGUOUS attribute. */ + if (s1->attr.contiguous != s2->attr.contiguous) + { + snprintf (errmsg, err_len, "CONTIGUOUS mismatch in argument '%s'", + s1->name); + return false; + } - /* Check VOLATILE attribute. */ - if (s1->attr.volatile_ != s2->attr.volatile_) - { - snprintf (errmsg, err_len, "VOLATILE mismatch in argument '%s'", - s1->name); - return false; + /* Check VALUE attribute. */ + if (s1->attr.value != s2->attr.value) + { + snprintf (errmsg, err_len, "VALUE mismatch in argument '%s'", + s1->name); + return false; + } + + /* Check VOLATILE attribute. */ + if (s1->attr.volatile_ != s2->attr.volatile_) + { + snprintf (errmsg, err_len, "VOLATILE mismatch in argument '%s'", + s1->name); + return false; + } } /* Check interface of dummy procedures. */ @@ -2494,7 +2508,7 @@ compare_parameter (gfc_symbol *formal, gfc_expr *actual, { if (formal->attr.artificial) gfc_error_opt (0, "Interface mismatch in dummy procedure " - "at %L conflichts with %L: %s", &actual->where, + "at %L conflicts with %L: %s", &actual->where, &formal->declared_at, err); else gfc_error_opt (0, "Interface mismatch in dummy procedure %qs at " @@ -2534,16 +2548,40 @@ compare_parameter (gfc_symbol *formal, gfc_expr *actual, gfc_find_symbol (actual_name, gsym->ns, 0, &global_asym); if (global_asym != NULL) { - gcc_assert (formal->attr.function); - if (!gfc_compare_types (&global_asym->ts, &formal->ts)) + if (formal->attr.subroutine) { - gfc_error ("Type mismatch at %L passing global " - "function %qs declared at %L (%s/%s)", - &actual->where, actual_name, &gsym->where, - gfc_typename (&global_asym->ts), - gfc_dummy_typename (&formal->ts)); + gfc_error ("Mismatch between subroutine and " + "function at %L", &actual->where); return false; } + else if (formal->attr.function) + { + gfc_typespec ts; + + if (global_asym->result) + ts = global_asym->result->ts; + else + ts = global_asym->ts; + + if (!gfc_compare_types (&ts, + &formal->ts)) + { + gfc_error ("Type mismatch at %L passing global " + "function %qs declared at %L (%s/%s)", + &actual->where, actual_name, + &gsym->where, + gfc_typename (&global_asym->ts), + gfc_dummy_typename (&formal->ts)); + return false; + } + } + else + { + /* The global symbol is a function. Set the formal + argument acordingly. */ + formal->attr.function = 1; + formal->ts = global_asym->ts; + } } } } @@ -3382,7 +3420,11 @@ gfc_compare_actual_formal (gfc_actual_arglist **ap, gfc_formal_arglist *formal, return false; } else - a->associated_dummy = get_nonintrinsic_dummy_arg (f); + { + if (a->associated_dummy) + free (a->associated_dummy); + a->associated_dummy = get_nonintrinsic_dummy_arg (f); + } if (a->expr == NULL) { @@ -5828,6 +5870,12 @@ gfc_get_formal_from_actual_arglist (gfc_symbol *sym, char name[GFC_MAX_SYMBOL_LEN + 1]; static int var_num; + /* Do not infer the formal from actual arguments if we are dealing with + classes. */ + + if (sym->ts.type == BT_CLASS) + return; + f = &sym->formal; for (a = actual_args; a != NULL; a = a->next) { diff --git a/gcc/fortran/intrinsic.cc b/gcc/fortran/intrinsic.cc index 30f532b..9e07627 100644 --- a/gcc/fortran/intrinsic.cc +++ b/gcc/fortran/intrinsic.cc @@ -331,7 +331,7 @@ do_ts29113_check (gfc_intrinsic_sym *specific, gfc_actual_arglist *arg) static bool do_check (gfc_intrinsic_sym *specific, gfc_actual_arglist *arg) { - gfc_expr *a1, *a2, *a3, *a4, *a5; + gfc_expr *a1, *a2, *a3, *a4, *a5, *a6; if (arg == NULL) return (*specific->check.f0) (); @@ -361,6 +361,11 @@ do_check (gfc_intrinsic_sym *specific, gfc_actual_arglist *arg) if (arg == NULL) return (*specific->check.f5) (a1, a2, a3, a4, a5); + a6 = arg->expr; + arg = arg->next; + if (arg == NULL) + return (*specific->check.f6) (a1, a2, a3, a4, a5, a6); + gfc_internal_error ("do_check(): too many args"); } @@ -371,11 +376,11 @@ do_check (gfc_intrinsic_sym *specific, gfc_actual_arglist *arg) Argument list: char * name of function - int whether function is elemental - int If the function can be used as an actual argument [1] - bt return type of function - int kind of return type of function - int Fortran standard version + int whether function is elemental + int If the function can be used as an actual argument [1] + bt return type of function + int kind of return type of function + int Fortran standard version check pointer to check function simplify pointer to simplification function resolve pointer to resolution function @@ -391,7 +396,7 @@ do_check (gfc_intrinsic_sym *specific, gfc_actual_arglist *arg) [1] Whether a function can or cannot be used as an actual argument is - determined by its presence on the 13.6 list in Fortran 2003. The + determined by its presence in the 13.6 list in Fortran 2003. The following intrinsics, which are GNU extensions, are considered allowed as actual arguments: ACOSH ATANH DACOSH DASINH DATANH DCONJG DIMAG ZABS ZCOS ZEXP ZLOG ZSIN ZSQRT. */ @@ -838,6 +843,44 @@ add_sym_6fl (const char *name, gfc_isym_id id, enum klass cl, int actual_ok, } +/* Add a symbol to the function list where the function takes + 6 arguments. */ + +static void +add_sym_6 (const char *name, gfc_isym_id id, enum klass cl, int actual_ok, + bt type, int kind, int standard, + bool (*check) (gfc_expr *, gfc_expr *, gfc_expr *, + gfc_expr *, gfc_expr *, gfc_expr *), + gfc_expr *(*simplify) (gfc_expr *, gfc_expr *, gfc_expr *, + gfc_expr *, gfc_expr *, gfc_expr *), + void (*resolve) (gfc_expr *, gfc_expr *, gfc_expr *, gfc_expr *, + gfc_expr *, gfc_expr *, gfc_expr *), + const char *a1, bt type1, int kind1, int optional1, + const char *a2, bt type2, int kind2, int optional2, + const char *a3, bt type3, int kind3, int optional3, + const char *a4, bt type4, int kind4, int optional4, + const char *a5, bt type5, int kind5, int optional5, + const char *a6, bt type6, int kind6, int optional6) +{ + gfc_check_f cf; + gfc_simplify_f sf; + gfc_resolve_f rf; + + cf.f6 = check; + sf.f6 = simplify; + rf.f6 = resolve; + + add_sym (name, id, cl, actual_ok, type, kind, standard, cf, sf, rf, + a1, type1, kind1, optional1, INTENT_IN, + a2, type2, kind2, optional2, INTENT_IN, + a3, type3, kind3, optional3, INTENT_IN, + a4, type4, kind4, optional4, INTENT_IN, + a5, type5, kind5, optional5, INTENT_IN, + a6, type6, kind6, optional6, INTENT_IN, + (void *) 0); +} + + /* MINVAL, MAXVAL, PRODUCT, and SUM also get special treatment because their argument also might have to be reordered. */ @@ -1352,26 +1395,24 @@ add_functions (void) { /* Argument names. These are used as argument keywords and so need to match the documentation. Please keep this list in sorted order. */ - const char - *a = "a", *a1 = "a1", *a2 = "a2", *ar = "array", *b = "b", - *bck = "back", *bd = "boundary", *c = "c", *c_ptr_1 = "c_ptr_1", - *c_ptr_2 = "c_ptr_2", *ca = "coarray", *com = "command", - *dist = "distance", *dm = "dim", *f = "field", *failed="failed", - *fs = "fsource", *han = "handler", *i = "i", - *image = "image", *j = "j", *kind = "kind", - *l = "l", *ln = "len", *level = "level", *m = "matrix", *ma = "matrix_a", - *mb = "matrix_b", *md = "mode", *mo = "mold", *msk = "mask", - *n = "n", *ncopies= "ncopies", *nm = "name", *num = "number", - *ord = "order", *p = "p", *p1 = "path1", *p2 = "path2", - *pad = "pad", *pid = "pid", *pos = "pos", *pt = "pointer", - *r = "r", *rd = "round", - *s = "s", *set = "set", *sh = "shift", *shp = "shape", - *sig = "sig", *src = "source", *ssg = "substring", - *sta = "string_a", *stb = "string_b", *stg = "string", - *sub = "sub", *sz = "size", *tg = "target", *team = "team", *tm = "time", - *ts = "tsource", *ut = "unit", *v = "vector", *va = "vector_a", - *vb = "vector_b", *vl = "values", *val = "value", *x = "x", *y = "y", - *z = "z"; + const char *a + = "a", + *a1 = "a1", *a2 = "a2", *ar = "array", *b = "b", *bck = "back", + *bd = "boundary", *c = "c", *c_ptr_1 = "c_ptr_1", *c_ptr_2 = "c_ptr_2", + *ca = "coarray", *com = "command", *dm = "dim", *f = "field", + *fs = "fsource", *han = "handler", *i = "i", *idy = "identity", + *image = "image", *j = "j", *kind = "kind", *l = "l", *ln = "len", + *level = "level", *m = "matrix", *ma = "matrix_a", *mb = "matrix_b", + *md = "mode", *mo = "mold", *msk = "mask", *n = "n", *ncopies = "ncopies", + *nm = "name", *num = "number", *op = "operation", *ord = "order", + *odd = "ordered", *p = "p", *p1 = "path1", *p2 = "path2", *pad = "pad", + *pid = "pid", *pos = "pos", *pt = "pointer", *r = "r", *rd = "round", + *s = "s", *set = "set", *sh = "shift", *shp = "shape", *sig = "sig", + *src = "source", *ssg = "substring", *sta = "string_a", *stb = "string_b", + *stg = "string", *sub = "sub", *sz = "size", *tg = "target", *team = "team", + *team_or_team_number = "team/team_number", *tm = "time", *ts = "tsource", + *ut = "unit", *v = "vector", *va = "vector_a", *vb = "vector_b", + *vl = "values", *val = "value", *x = "x", *y = "y", *z = "z"; int di, dr, dd, dl, dc, dz, ii; @@ -2069,10 +2110,10 @@ add_functions (void) make_generic ("getpid", GFC_ISYM_GETPID, GFC_STD_GNU); - add_sym_1 ("get_team", GFC_ISYM_GET_TEAM, CLASS_TRANSFORMATIONAL, - ACTUAL_NO, BT_INTEGER, di, GFC_STD_F2018, - gfc_check_get_team, NULL, gfc_resolve_get_team, - level, BT_INTEGER, di, OPTIONAL); + add_sym_1 ("get_team", GFC_ISYM_GET_TEAM, CLASS_TRANSFORMATIONAL, ACTUAL_NO, + BT_DERIVED, di, GFC_STD_F2018, gfc_check_get_team, + gfc_simplify_get_team, gfc_resolve_get_team, level, BT_INTEGER, di, + OPTIONAL); add_sym_0 ("getuid", GFC_ISYM_GETUID, CLASS_IMPURE, ACTUAL_NO, BT_INTEGER, di, GFC_STD_GNU, NULL, NULL, gfc_resolve_getuid); @@ -2222,9 +2263,11 @@ add_functions (void) make_generic ("ierrno", GFC_ISYM_IERRNO, GFC_STD_GNU); - add_sym_2 ("image_index", GFC_ISYM_IMAGE_INDEX, CLASS_INQUIRY, ACTUAL_NO, BT_INTEGER, di, GFC_STD_F2008, - gfc_check_image_index, gfc_simplify_image_index, gfc_resolve_image_index, - ca, BT_REAL, dr, REQUIRED, sub, BT_INTEGER, ii, REQUIRED); + add_sym_3 ("image_index", GFC_ISYM_IMAGE_INDEX, CLASS_TRANSFORMATIONAL, + ACTUAL_NO, BT_INTEGER, di, GFC_STD_F2008, gfc_check_image_index, + gfc_simplify_image_index, gfc_resolve_image_index, ca, BT_REAL, dr, + REQUIRED, sub, BT_INTEGER, ii, REQUIRED, team_or_team_number, + BT_VOID, di, OPTIONAL); add_sym_2 ("image_status", GFC_ISYM_IMAGE_STATUS, CLASS_ELEMENTAL, ACTUAL_NO, BT_INTEGER, di, GFC_STD_F2018, gfc_check_image_status, @@ -2805,11 +2848,10 @@ add_functions (void) make_generic ("null", GFC_ISYM_NULL, GFC_STD_F95); - add_sym_2 ("num_images", GFC_ISYM_NUM_IMAGES, CLASS_TRANSFORMATIONAL, - ACTUAL_NO, BT_INTEGER, di, GFC_STD_F2008, - gfc_check_num_images, gfc_simplify_num_images, NULL, - dist, BT_INTEGER, di, OPTIONAL, - failed, BT_LOGICAL, dl, OPTIONAL); + add_sym_1 ("num_images", GFC_ISYM_NUM_IMAGES, CLASS_TRANSFORMATIONAL, + ACTUAL_NO, BT_INTEGER, di, GFC_STD_F2008, gfc_check_num_images, + gfc_simplify_num_images, NULL, team_or_team_number, BT_VOID, di, + OPTIONAL); add_sym_3 ("out_of_range", GFC_ISYM_OUT_OF_RANGE, CLASS_ELEMENTAL, ACTUAL_NO, BT_LOGICAL, dl, GFC_STD_F2018, @@ -2936,6 +2978,18 @@ add_functions (void) make_generic ("sngl", GFC_ISYM_SNGL, GFC_STD_F77); + add_sym_6 ("reduce", GFC_ISYM_REDUCE, CLASS_TRANSFORMATIONAL, ACTUAL_NO, + BT_REAL, dr, GFC_STD_F2018, + gfc_check_reduce, NULL, gfc_resolve_reduce, + ar, BT_REAL, dr, REQUIRED, + op, BT_REAL, dr, REQUIRED, + dm, BT_INTEGER, di, OPTIONAL, + msk, BT_LOGICAL, dl, OPTIONAL, + idy, BT_REAL, dr, OPTIONAL, + odd, BT_LOGICAL, dl, OPTIONAL); + + make_generic ("reduce", GFC_ISYM_REDUCE, GFC_STD_F2018); + add_sym_2 ("rename", GFC_ISYM_RENAME, CLASS_IMPURE, ACTUAL_NO, BT_INTEGER, di, GFC_STD_GNU, gfc_check_rename, NULL, gfc_resolve_rename, p1, BT_CHARACTER, dc, REQUIRED, p2, BT_CHARACTER, dc, REQUIRED); @@ -3283,10 +3337,11 @@ add_functions (void) gfc_check_team_number, NULL, gfc_resolve_team_number, team, BT_DERIVED, di, OPTIONAL); - add_sym_3 ("this_image", GFC_ISYM_THIS_IMAGE, CLASS_INQUIRY, ACTUAL_NO, BT_INTEGER, di, GFC_STD_F2008, - gfc_check_this_image, gfc_simplify_this_image, gfc_resolve_this_image, - ca, BT_REAL, dr, OPTIONAL, dm, BT_INTEGER, ii, OPTIONAL, - dist, BT_INTEGER, di, OPTIONAL); + add_sym_3red ("this_image", GFC_ISYM_THIS_IMAGE, CLASS_INQUIRY, ACTUAL_NO, + BT_INTEGER, di, GFC_STD_F2008, gfc_check_this_image, + gfc_simplify_this_image, gfc_resolve_this_image, ca, BT_REAL, + dr, OPTIONAL, dm, BT_INTEGER, ii, OPTIONAL, team, BT_DERIVED, + di, OPTIONAL); add_sym_0 ("time", GFC_ISYM_TIME, CLASS_IMPURE, ACTUAL_NO, BT_INTEGER, di, GFC_STD_GNU, NULL, NULL, gfc_resolve_time); @@ -3397,43 +3452,50 @@ add_functions (void) add_sym_1 ("acosd", GFC_ISYM_ACOSD, CLASS_ELEMENTAL, ACTUAL_YES, BT_REAL, dr, GFC_STD_F2023, - gfc_check_fn_r, gfc_simplify_acosd, gfc_resolve_trigd, + gfc_check_fn_r, gfc_simplify_acosd, gfc_resolve_trig, x, BT_REAL, dr, REQUIRED); make_generic ("acosd", GFC_ISYM_ACOSD, GFC_STD_F2023); add_sym_1 ("dacosd", GFC_ISYM_ACOSD, CLASS_ELEMENTAL, ACTUAL_YES, BT_REAL, dd, GFC_STD_GNU, - gfc_check_fn_d, gfc_simplify_acosd, gfc_resolve_trigd, + gfc_check_fn_d, gfc_simplify_acosd, gfc_resolve_trig, x, BT_REAL, dd, REQUIRED); add_sym_1 ("asind", GFC_ISYM_ASIND, CLASS_ELEMENTAL, ACTUAL_YES, BT_REAL, dr, GFC_STD_F2023, - gfc_check_fn_r, gfc_simplify_asind, gfc_resolve_trigd, + gfc_check_fn_r, gfc_simplify_asind, gfc_resolve_trig, x, BT_REAL, dr, REQUIRED); make_generic ("asind", GFC_ISYM_ASIND, GFC_STD_F2023); add_sym_1 ("dasind", GFC_ISYM_ASIND, CLASS_ELEMENTAL, ACTUAL_YES, BT_REAL, dd, GFC_STD_GNU, - gfc_check_fn_d, gfc_simplify_asind, gfc_resolve_trigd, + gfc_check_fn_d, gfc_simplify_asind, gfc_resolve_trig, x, BT_REAL, dd, REQUIRED); add_sym_1 ("atand", GFC_ISYM_ATAND, CLASS_ELEMENTAL, ACTUAL_YES, BT_REAL, dr, GFC_STD_F2023, - gfc_check_fn_r, gfc_simplify_atand, gfc_resolve_trigd, + gfc_check_fn_r, gfc_simplify_atand, gfc_resolve_trig, + x, BT_REAL, dr, REQUIRED); + + /* Two-argument version of atand, equivalent to atan2d. */ + add_sym_2 ("atand", GFC_ISYM_ATAN2D, CLASS_ELEMENTAL, ACTUAL_YES, + BT_REAL, dr, GFC_STD_F2023, + gfc_check_atan2, gfc_simplify_atan2d, gfc_resolve_trig2, + y, BT_REAL, dr, REQUIRED, x, BT_REAL, dr, REQUIRED); make_generic ("atand", GFC_ISYM_ATAND, GFC_STD_F2023); add_sym_1 ("datand", GFC_ISYM_ATAND, CLASS_ELEMENTAL, ACTUAL_YES, BT_REAL, dd, GFC_STD_GNU, - gfc_check_fn_d, gfc_simplify_atand, gfc_resolve_trigd, + gfc_check_fn_d, gfc_simplify_atand, gfc_resolve_trig, x, BT_REAL, dd, REQUIRED); add_sym_2 ("atan2d", GFC_ISYM_ATAN2D, CLASS_ELEMENTAL, ACTUAL_YES, BT_REAL, dr, GFC_STD_F2023, - gfc_check_atan2, gfc_simplify_atan2d, gfc_resolve_trigd2, + gfc_check_atan2, gfc_simplify_atan2d, gfc_resolve_trig2, y, BT_REAL, dr, REQUIRED, x, BT_REAL, dr, REQUIRED); @@ -3441,78 +3503,78 @@ add_functions (void) add_sym_2 ("datan2d", GFC_ISYM_ATAN2D, CLASS_ELEMENTAL, ACTUAL_YES, BT_REAL, dd, GFC_STD_GNU, - gfc_check_datan2, gfc_simplify_atan2d, gfc_resolve_trigd2, + gfc_check_datan2, gfc_simplify_atan2d, gfc_resolve_trig2, y, BT_REAL, dd, REQUIRED, x, BT_REAL, dd, REQUIRED); add_sym_1 ("cosd", GFC_ISYM_COSD, CLASS_ELEMENTAL, ACTUAL_YES, BT_REAL, dr, GFC_STD_F2023, - gfc_check_fn_r, gfc_simplify_cosd, gfc_resolve_trigd, + gfc_check_fn_r, gfc_simplify_cosd, gfc_resolve_trig, x, BT_REAL, dr, REQUIRED); make_generic ("cosd", GFC_ISYM_COSD, GFC_STD_F2023); add_sym_1 ("dcosd", GFC_ISYM_COSD, CLASS_ELEMENTAL, ACTUAL_YES, BT_REAL, dd, GFC_STD_GNU, - gfc_check_fn_d, gfc_simplify_cosd, gfc_resolve_trigd, + gfc_check_fn_d, gfc_simplify_cosd, gfc_resolve_trig, x, BT_REAL, dd, REQUIRED); add_sym_1 ("cotan", GFC_ISYM_COTAN, CLASS_ELEMENTAL, ACTUAL_YES, BT_REAL, dr, GFC_STD_GNU, - gfc_check_fn_rc2008, gfc_simplify_cotan, gfc_resolve_trigd, + gfc_check_fn_rc2008, gfc_simplify_cotan, gfc_resolve_trig, x, BT_REAL, dr, REQUIRED); add_sym_1 ("dcotan", GFC_ISYM_COTAN, CLASS_ELEMENTAL, ACTUAL_YES, BT_REAL, dd, GFC_STD_GNU, - gfc_check_fn_d, gfc_simplify_cotan, gfc_resolve_trigd, + gfc_check_fn_d, gfc_simplify_cotan, gfc_resolve_trig, x, BT_REAL, dd, REQUIRED); add_sym_1 ("ccotan", GFC_ISYM_COTAN, CLASS_ELEMENTAL, ACTUAL_YES, BT_COMPLEX, dz, GFC_STD_GNU, - NULL, gfc_simplify_cotan, gfc_resolve_trigd, + NULL, gfc_simplify_cotan, gfc_resolve_trig, x, BT_COMPLEX, dz, REQUIRED); add_sym_1 ("zcotan", GFC_ISYM_COTAN, CLASS_ELEMENTAL, ACTUAL_YES, BT_COMPLEX, dd, GFC_STD_GNU, - NULL, gfc_simplify_cotan, gfc_resolve_trigd, + NULL, gfc_simplify_cotan, gfc_resolve_trig, x, BT_COMPLEX, dd, REQUIRED); make_generic ("cotan", GFC_ISYM_COTAN, GFC_STD_GNU); add_sym_1 ("cotand", GFC_ISYM_COTAND, CLASS_ELEMENTAL, ACTUAL_YES, BT_REAL, dr, GFC_STD_GNU, - gfc_check_fn_r, gfc_simplify_cotand, gfc_resolve_trigd, + gfc_check_fn_r, gfc_simplify_cotand, gfc_resolve_trig, x, BT_REAL, dr, REQUIRED); add_sym_1 ("dcotand", GFC_ISYM_COTAND, CLASS_ELEMENTAL, ACTUAL_YES, BT_REAL, dd, GFC_STD_GNU, - gfc_check_fn_d, gfc_simplify_cotand, gfc_resolve_trigd, + gfc_check_fn_d, gfc_simplify_cotand, gfc_resolve_trig, x, BT_REAL, dd, REQUIRED); make_generic ("cotand", GFC_ISYM_COTAND, GFC_STD_GNU); add_sym_1 ("sind", GFC_ISYM_SIND, CLASS_ELEMENTAL, ACTUAL_YES, BT_REAL, dr, GFC_STD_F2023, - gfc_check_fn_r, gfc_simplify_sind, gfc_resolve_trigd, + gfc_check_fn_r, gfc_simplify_sind, gfc_resolve_trig, x, BT_REAL, dr, REQUIRED); make_generic ("sind", GFC_ISYM_SIND, GFC_STD_F2023); add_sym_1 ("dsind", GFC_ISYM_SIND, CLASS_ELEMENTAL, ACTUAL_YES, BT_REAL, dd, GFC_STD_GNU, - gfc_check_fn_d, gfc_simplify_sind, gfc_resolve_trigd, + gfc_check_fn_d, gfc_simplify_sind, gfc_resolve_trig, x, BT_REAL, dd, REQUIRED); add_sym_1 ("tand", GFC_ISYM_TAND, CLASS_ELEMENTAL, ACTUAL_YES, BT_REAL, dr, GFC_STD_F2023, - gfc_check_fn_r, gfc_simplify_tand, gfc_resolve_trigd, + gfc_check_fn_r, gfc_simplify_tand, gfc_resolve_trig, x, BT_REAL, dr, REQUIRED); make_generic ("tand", GFC_ISYM_TAND, GFC_STD_F2023); add_sym_1 ("dtand", GFC_ISYM_TAND, CLASS_ELEMENTAL, ACTUAL_YES, BT_REAL, dd, GFC_STD_GNU, - gfc_check_fn_d, gfc_simplify_tand, gfc_resolve_trigd, + gfc_check_fn_d, gfc_simplify_tand, gfc_resolve_trig, x, BT_REAL, dd, REQUIRED); /* The following function is internally used for coarray libray functions. @@ -3528,6 +3590,57 @@ add_functions (void) REQUIRED, val, BT_INTEGER, di, REQUIRED, i, BT_INTEGER, di, REQUIRED); make_from_module (); + + /* The half-cycle trigonometric functions were added by Fortran 2023. */ + + add_sym_1 ("acospi", GFC_ISYM_ACOSPI, CLASS_ELEMENTAL, ACTUAL_NO, BT_REAL, dr, + GFC_STD_F2023, gfc_check_fn_r, gfc_simplify_acospi, + gfc_resolve_trig, x, BT_REAL, dr, REQUIRED); + + make_generic ("acospi", GFC_ISYM_ACOSPI, GFC_STD_F2023); + + add_sym_1 ("asinpi", GFC_ISYM_ASINPI, CLASS_ELEMENTAL, ACTUAL_NO, BT_REAL, dr, + GFC_STD_F2023, gfc_check_fn_r, gfc_simplify_asinpi, + gfc_resolve_trig, x, BT_REAL, dr, REQUIRED); + + make_generic ("asinpi", GFC_ISYM_ASINPI, GFC_STD_F2023); + + add_sym_1 ("atanpi", GFC_ISYM_ATANPI, CLASS_ELEMENTAL, ACTUAL_NO, BT_REAL, dr, + GFC_STD_F2023, gfc_check_fn_r, gfc_simplify_atanpi, + gfc_resolve_trig, x, BT_REAL, dr, REQUIRED); + + /* Two-argument version of atanpi, equivalent to atan2pi. */ + add_sym_2 ("atanpi", GFC_ISYM_ATAN2PI, CLASS_ELEMENTAL, ACTUAL_YES, BT_REAL, + dr, GFC_STD_F2023, gfc_check_atan2, gfc_simplify_atan2pi, + gfc_resolve_trig2, y, BT_REAL, dr, REQUIRED, x, BT_REAL, dr, + REQUIRED); + + make_generic ("atanpi", GFC_ISYM_ATANPI, GFC_STD_F2023); + + add_sym_2 ("atan2pi", GFC_ISYM_ATAN2PI, CLASS_ELEMENTAL, ACTUAL_NO, BT_REAL, + dr, GFC_STD_F2023, gfc_check_atan2, gfc_simplify_atan2pi, + gfc_resolve_trig2, y, BT_REAL, dr, REQUIRED, x, BT_REAL, dr, + REQUIRED); + + make_generic ("atan2pi", GFC_ISYM_ATAN2PI, GFC_STD_F2023); + + add_sym_1 ("cospi", GFC_ISYM_COSPI, CLASS_ELEMENTAL, ACTUAL_NO, BT_REAL, dr, + GFC_STD_F2023, gfc_check_fn_r, gfc_simplify_cospi, + gfc_resolve_trig, x, BT_REAL, dr, REQUIRED); + + make_generic ("cospi", GFC_ISYM_COSPI, GFC_STD_F2023); + + add_sym_1 ("sinpi", GFC_ISYM_SINPI, CLASS_ELEMENTAL, ACTUAL_NO, BT_REAL, dr, + GFC_STD_F2023, gfc_check_fn_r, gfc_simplify_sinpi, + gfc_resolve_trig, x, BT_REAL, dr, REQUIRED); + + make_generic ("sinpi", GFC_ISYM_SINPI, GFC_STD_F2023); + + add_sym_1 ("tanpi", GFC_ISYM_TANPI, CLASS_ELEMENTAL, ACTUAL_NO, BT_REAL, dr, + GFC_STD_F2023, gfc_check_fn_r, gfc_simplify_tanpi, + gfc_resolve_trig, x, BT_REAL, dr, REQUIRED); + + make_generic ("tanpi", GFC_ISYM_TANPI, GFC_STD_F2023); } @@ -3780,11 +3893,11 @@ add_subroutines (void) st, BT_INTEGER, di, OPTIONAL, INTENT_OUT, trim_name, BT_LOGICAL, dl, OPTIONAL, INTENT_IN); - add_sym_2s ("move_alloc", GFC_ISYM_MOVE_ALLOC, CLASS_PURE, BT_UNKNOWN, 0, - GFC_STD_F2003, - gfc_check_move_alloc, NULL, NULL, - f, BT_UNKNOWN, 0, REQUIRED, INTENT_INOUT, - t, BT_UNKNOWN, 0, REQUIRED, INTENT_OUT); + add_sym_4s ("move_alloc", GFC_ISYM_MOVE_ALLOC, CLASS_PURE, BT_UNKNOWN, 0, + GFC_STD_F2003, gfc_check_move_alloc, NULL, NULL, f, BT_UNKNOWN, 0, + REQUIRED, INTENT_INOUT, t, BT_UNKNOWN, 0, REQUIRED, INTENT_OUT, + stat, BT_INTEGER, di, OPTIONAL, INTENT_OUT, errmsg, BT_CHARACTER, + dc, OPTIONAL, INTENT_INOUT); add_sym_5s ("mvbits", GFC_ISYM_MVBITS, CLASS_ELEMENTAL, BT_UNKNOWN, 0, GFC_STD_F95, gfc_check_mvbits, NULL, gfc_resolve_mvbits, @@ -4901,6 +5014,9 @@ check_specific (gfc_intrinsic_sym *specific, gfc_expr *expr, int error_flag) else if (specific->check.f3red == gfc_check_transf_bit_intrins) /* Same as for PRODUCT and SUM, but different checks. */ t = gfc_check_transf_bit_intrins (*ap); + else if (specific->check.f3red == gfc_check_this_image) + /* May need to reassign arguments. */ + t = gfc_check_this_image (*ap); else { if (specific->check.f1 == NULL) diff --git a/gcc/fortran/intrinsic.h b/gcc/fortran/intrinsic.h index 34a0248..fd54588 100644 --- a/gcc/fortran/intrinsic.h +++ b/gcc/fortran/intrinsic.h @@ -132,7 +132,7 @@ bool gfc_check_nearest (gfc_expr *, gfc_expr *); bool gfc_check_new_line (gfc_expr *); bool gfc_check_norm2 (gfc_expr *, gfc_expr *); bool gfc_check_null (gfc_expr *); -bool gfc_check_num_images (gfc_expr *, gfc_expr *); +bool gfc_check_num_images (gfc_expr *); bool gfc_check_out_of_range (gfc_expr *, gfc_expr *, gfc_expr *); bool gfc_check_pack (gfc_expr *, gfc_expr *, gfc_expr *); bool gfc_check_parity (gfc_expr *, gfc_expr *); @@ -144,6 +144,8 @@ bool gfc_check_rand (gfc_expr *); bool gfc_check_range (gfc_expr *); bool gfc_check_rank (gfc_expr *); bool gfc_check_real (gfc_expr *, gfc_expr *); +bool gfc_check_reduce (gfc_expr *, gfc_expr *, gfc_expr *, gfc_expr *, + gfc_expr *, gfc_expr *); bool gfc_check_rename (gfc_expr *, gfc_expr *); bool gfc_check_repeat (gfc_expr *, gfc_expr *); bool gfc_check_reshape (gfc_expr *, gfc_expr *, gfc_expr *, gfc_expr *); @@ -206,7 +208,8 @@ bool gfc_check_fstat_sub (gfc_expr *, gfc_expr *, gfc_expr *); bool gfc_check_gerror (gfc_expr *); bool gfc_check_getarg (gfc_expr *, gfc_expr *); bool gfc_check_getlog (gfc_expr *); -bool gfc_check_move_alloc (gfc_expr *, gfc_expr *); +bool gfc_check_move_alloc (gfc_expr *, gfc_expr *, gfc_expr *stat, + gfc_expr *errmsg); bool gfc_check_mvbits (gfc_expr *, gfc_expr *, gfc_expr *, gfc_expr *, gfc_expr *); bool gfc_check_random_init (gfc_expr *, gfc_expr *); @@ -219,7 +222,7 @@ bool gfc_check_fseek_sub (gfc_expr *, gfc_expr *, gfc_expr *, gfc_expr *); bool gfc_check_ftell_sub (gfc_expr *, gfc_expr *); bool gfc_check_getcwd_sub (gfc_expr *, gfc_expr *); bool gfc_check_hostnm_sub (gfc_expr *, gfc_expr *); -bool gfc_check_image_index (gfc_expr *, gfc_expr *); +bool gfc_check_image_index (gfc_expr *, gfc_expr *, gfc_expr *); bool gfc_check_itime_idate (gfc_expr *); bool gfc_check_kill_sub (gfc_expr *, gfc_expr *, gfc_expr *); bool gfc_check_ltime_gmtime (gfc_expr *, gfc_expr *); @@ -231,7 +234,7 @@ bool gfc_check_signal_sub (gfc_expr *, gfc_expr *, gfc_expr *); bool gfc_check_sleep_sub (gfc_expr *); bool gfc_check_stat_sub (gfc_expr *, gfc_expr *, gfc_expr *); bool gfc_check_system_sub (gfc_expr *, gfc_expr *); -bool gfc_check_this_image (gfc_expr *, gfc_expr *, gfc_expr *); +bool gfc_check_this_image (gfc_actual_arglist *); bool gfc_check_ttynam_sub (gfc_expr *, gfc_expr *); bool gfc_check_umask_sub (gfc_expr *, gfc_expr *); bool gfc_check_unlink_sub (gfc_expr *, gfc_expr *); @@ -243,6 +246,7 @@ gfc_expr *gfc_simplify_achar (gfc_expr *, gfc_expr *); gfc_expr *gfc_simplify_acos (gfc_expr *); gfc_expr *gfc_simplify_acosd (gfc_expr *); gfc_expr *gfc_simplify_acosh (gfc_expr *); +gfc_expr *gfc_simplify_acospi (gfc_expr *); gfc_expr *gfc_simplify_adjustl (gfc_expr *); gfc_expr *gfc_simplify_adjustr (gfc_expr *); gfc_expr *gfc_simplify_aimag (gfc_expr *); @@ -256,11 +260,14 @@ gfc_expr *gfc_simplify_and (gfc_expr *, gfc_expr *); gfc_expr *gfc_simplify_any (gfc_expr *, gfc_expr *); gfc_expr *gfc_simplify_asin (gfc_expr *); gfc_expr *gfc_simplify_asinh (gfc_expr *); +gfc_expr *gfc_simplify_asinpi (gfc_expr *); gfc_expr *gfc_simplify_atan (gfc_expr *); gfc_expr *gfc_simplify_atand (gfc_expr *); gfc_expr *gfc_simplify_atanh (gfc_expr *); +gfc_expr *gfc_simplify_atanpi (gfc_expr *); gfc_expr *gfc_simplify_atan2 (gfc_expr *, gfc_expr *); gfc_expr *gfc_simplify_atan2d (gfc_expr *, gfc_expr *); +gfc_expr *gfc_simplify_atan2pi (gfc_expr *, gfc_expr *); gfc_expr *gfc_simplify_bessel_j0 (gfc_expr *); gfc_expr *gfc_simplify_bessel_j1 (gfc_expr *); gfc_expr *gfc_simplify_bessel_jn (gfc_expr *, gfc_expr *); @@ -285,6 +292,7 @@ gfc_expr *gfc_simplify_conjg (gfc_expr *); gfc_expr *gfc_simplify_cos (gfc_expr *); gfc_expr *gfc_simplify_cosd (gfc_expr *); gfc_expr *gfc_simplify_cosh (gfc_expr *); +gfc_expr *gfc_simplify_cospi (gfc_expr *); gfc_expr *gfc_simplify_cotan (gfc_expr *); gfc_expr *gfc_simplify_cotand (gfc_expr *); gfc_expr *gfc_simplify_count (gfc_expr *, gfc_expr *, gfc_expr *); @@ -325,7 +333,7 @@ gfc_expr *gfc_simplify_ibits (gfc_expr *, gfc_expr *, gfc_expr *); gfc_expr *gfc_simplify_ibset (gfc_expr *, gfc_expr *); gfc_expr *gfc_simplify_ichar (gfc_expr *, gfc_expr *); gfc_expr *gfc_simplify_ieor (gfc_expr *, gfc_expr *); -gfc_expr *gfc_simplify_image_index (gfc_expr *, gfc_expr *); +gfc_expr *gfc_simplify_image_index (gfc_expr *, gfc_expr *, gfc_expr *); gfc_expr *gfc_simplify_image_status (gfc_expr *, gfc_expr *); gfc_expr *gfc_simplify_index (gfc_expr *, gfc_expr *, gfc_expr *, gfc_expr *); gfc_expr *gfc_simplify_int (gfc_expr *, gfc_expr *); @@ -380,7 +388,7 @@ gfc_expr *gfc_simplify_new_line (gfc_expr *); gfc_expr *gfc_simplify_nint (gfc_expr *, gfc_expr *); gfc_expr *gfc_simplify_norm2 (gfc_expr *, gfc_expr *); gfc_expr *gfc_simplify_null (gfc_expr *); -gfc_expr *gfc_simplify_num_images (gfc_expr *, gfc_expr *); +gfc_expr *gfc_simplify_num_images (gfc_expr *); gfc_expr *gfc_simplify_idnint (gfc_expr *); gfc_expr *gfc_simplify_not (gfc_expr *); gfc_expr *gfc_simplify_or (gfc_expr *, gfc_expr *); @@ -418,6 +426,7 @@ gfc_expr *gfc_simplify_shiftr (gfc_expr *, gfc_expr *); gfc_expr *gfc_simplify_sin (gfc_expr *); gfc_expr *gfc_simplify_sind (gfc_expr *); gfc_expr *gfc_simplify_sinh (gfc_expr *); +gfc_expr *gfc_simplify_sinpi (gfc_expr *); gfc_expr *gfc_simplify_size (gfc_expr *, gfc_expr *, gfc_expr *); gfc_expr *gfc_simplify_sizeof (gfc_expr *); gfc_expr *gfc_simplify_storage_size (gfc_expr *, gfc_expr *); @@ -429,6 +438,7 @@ gfc_expr *gfc_simplify_sum (gfc_expr *, gfc_expr *, gfc_expr *); gfc_expr *gfc_simplify_tan (gfc_expr *); gfc_expr *gfc_simplify_tand (gfc_expr *); gfc_expr *gfc_simplify_tanh (gfc_expr *); +gfc_expr *gfc_simplify_tanpi (gfc_expr *); gfc_expr *gfc_simplify_this_image (gfc_expr *, gfc_expr *, gfc_expr *); gfc_expr *gfc_simplify_tiny (gfc_expr *); gfc_expr *gfc_simplify_trailz (gfc_expr *); @@ -476,6 +486,7 @@ void gfc_resolve_bessel_n2 (gfc_expr *, gfc_expr *, gfc_expr *, gfc_expr *a); void gfc_resolve_btest (gfc_expr *, gfc_expr *, gfc_expr *); void gfc_resolve_c_loc (gfc_expr *, gfc_expr *); void gfc_resolve_c_funloc (gfc_expr *, gfc_expr *); +void gfc_resolve_get_team (gfc_expr *, gfc_expr *); void gfc_resolve_ceiling (gfc_expr *, gfc_expr *, gfc_expr *); void gfc_resolve_char (gfc_expr *, gfc_expr *, gfc_expr *); void gfc_resolve_chdir (gfc_expr *, gfc_expr *); @@ -520,7 +531,6 @@ void gfc_resolve_gamma (gfc_expr *, gfc_expr *); void gfc_resolve_getcwd (gfc_expr *, gfc_expr *); void gfc_resolve_getgid (gfc_expr *); void gfc_resolve_getpid (gfc_expr *); -void gfc_resolve_get_team (gfc_expr *, gfc_expr *); void gfc_resolve_getuid (gfc_expr *); void gfc_resolve_hostnm (gfc_expr *, gfc_expr *); void gfc_resolve_hypot (gfc_expr *, gfc_expr *, gfc_expr *); @@ -528,7 +538,7 @@ void gfc_resolve_iand (gfc_expr *, gfc_expr *, gfc_expr *); void gfc_resolve_ibclr (gfc_expr *, gfc_expr *, gfc_expr *); void gfc_resolve_ibits (gfc_expr *, gfc_expr *, gfc_expr *, gfc_expr *); void gfc_resolve_ibset (gfc_expr *, gfc_expr *, gfc_expr *); -void gfc_resolve_image_index (gfc_expr *, gfc_expr *, gfc_expr *); +void gfc_resolve_image_index (gfc_expr *, gfc_expr *, gfc_expr *, gfc_expr *); void gfc_resolve_image_status (gfc_expr *, gfc_expr *, gfc_expr *); void gfc_resolve_index_func (gfc_expr *, gfc_expr *, gfc_expr *, gfc_expr *, gfc_expr *); @@ -589,6 +599,8 @@ void gfc_resolve_parity (gfc_expr *, gfc_expr *, gfc_expr *); void gfc_resolve_product (gfc_expr *, gfc_expr *, gfc_expr *, gfc_expr *); void gfc_resolve_real (gfc_expr *, gfc_expr *, gfc_expr *); void gfc_resolve_realpart (gfc_expr *, gfc_expr *); +void gfc_resolve_reduce (gfc_expr *, gfc_expr *, gfc_expr *, gfc_expr *, + gfc_expr *, gfc_expr *, gfc_expr *); void gfc_resolve_rename (gfc_expr *, gfc_expr *, gfc_expr *); void gfc_resolve_repeat (gfc_expr *, gfc_expr *, gfc_expr *); void gfc_resolve_reshape (gfc_expr *, gfc_expr *, gfc_expr *, gfc_expr *, @@ -626,8 +638,8 @@ void gfc_resolve_time (gfc_expr *); void gfc_resolve_time8 (gfc_expr *); void gfc_resolve_transfer (gfc_expr *, gfc_expr *, gfc_expr *, gfc_expr *); void gfc_resolve_transpose (gfc_expr *, gfc_expr *); -void gfc_resolve_trigd (gfc_expr *, gfc_expr *); -void gfc_resolve_trigd2 (gfc_expr *, gfc_expr *, gfc_expr *); +void gfc_resolve_trig (gfc_expr *, gfc_expr *); +void gfc_resolve_trig2 (gfc_expr *, gfc_expr *, gfc_expr *); void gfc_resolve_trim (gfc_expr *, gfc_expr *); void gfc_resolve_ttynam (gfc_expr *, gfc_expr *); void gfc_resolve_ubound (gfc_expr *, gfc_expr *, gfc_expr *, gfc_expr *); diff --git a/gcc/fortran/intrinsic.texi b/gcc/fortran/intrinsic.texi index 8c160e5..3103da3 100644 --- a/gcc/fortran/intrinsic.texi +++ b/gcc/fortran/intrinsic.texi @@ -24,15 +24,22 @@ Some basic guidelines for editing this document: @tex \gdef\acosd{\mathop{\rm acosd}\nolimits} -\gdef\asind{\mathop{\rm asind}\nolimits} -\gdef\atand{\mathop{\rm atand}\nolimits} -\gdef\acos{\mathop{\rm acos}\nolimits} -\gdef\asin{\mathop{\rm asin}\nolimits} -\gdef\atan{\mathop{\rm atan}\nolimits} \gdef\acosh{\mathop{\rm acosh}\nolimits} +\gdef\acospi{\mathop{\rm acospi}\nolimits} +\gdef\acos{\mathop{\rm acos}\nolimits} +\gdef\asind{\mathop{\rm asind}\nolimits} \gdef\asinh{\mathop{\rm asinh}\nolimits} +\gdef\asinpi{\mathop{\rm asinpi}\nolimits} +\gdef\asin{\mathop{\rm asin}\nolimits} +\gdef\atan2pi{\mathop{\rm atan2pi}\nolimits} +\gdef\atand{\mathop{\rm atand}\nolimits} \gdef\atanh{\mathop{\rm atanh}\nolimits} +\gdef\atanpi{\mathop{\rm atanpi}\nolimits} +\gdef\atan{\mathop{\rm atan}\nolimits} \gdef\cosd{\mathop{\rm cosd}\nolimits} +\gdef\cospi{\mathop{\rm cospi}\nolimits} +\gdef\sinpi{\mathop{\rm sinpi}\nolimits} +\gdef\tanpi{\mathop{\rm tanpi}\nolimits} @end tex @@ -49,6 +56,7 @@ Some basic guidelines for editing this document: * @code{ACOS}: ACOS, Arccosine function * @code{ACOSD}: ACOSD, Arccosine function, degrees * @code{ACOSH}: ACOSH, Inverse hyperbolic cosine function +* @code{ACOSPI}: ACOSPI, Circular arc cosine function * @code{ADJUSTL}: ADJUSTL, Left adjust a string * @code{ADJUSTR}: ADJUSTR, Right adjust a string * @code{AIMAG}: AIMAG, Imaginary part of complex number @@ -62,12 +70,15 @@ Some basic guidelines for editing this document: * @code{ASIN}: ASIN, Arcsine function * @code{ASIND}: ASIND, Arcsine function, degrees * @code{ASINH}: ASINH, Inverse hyperbolic sine function +* @code{ASINPI}: ASINPI, Circular arc sine function * @code{ASSOCIATED}: ASSOCIATED, Status of a pointer or pointer/target pair * @code{ATAN}: ATAN, Arctangent function -* @code{ATAND}: ATAND, Arctangent function, degrees * @code{ATAN2}: ATAN2, Arctangent function * @code{ATAN2D}: ATAN2D, Arctangent function, degrees +* @code{ATAN2PI}: ATAN2PI, Circular arc tangent function +* @code{ATAND}: ATAND, Arctangent function, degrees * @code{ATANH}: ATANH, Inverse hyperbolic tangent function +* @code{ATANPI}: ATANPI, Circular arc tangent function * @code{ATOMIC_ADD}: ATOMIC_ADD, Atomic ADD operation * @code{ATOMIC_AND}: ATOMIC_AND, Atomic bitwise AND operation * @code{ATOMIC_CAS}: ATOMIC_CAS, Atomic compare and swap @@ -116,6 +127,7 @@ Some basic guidelines for editing this document: * @code{COS}: COS, Cosine function * @code{COSD}: COSD, Cosine function, degrees * @code{COSH}: COSH, Hyperbolic cosine function +* @code{COSPI}: COSPI, Circular cosine function * @code{COTAN}: COTAN, Cotangent function * @code{COTAND}: COTAND, Cotangent function, degrees * @code{COUNT}: COUNT, Count occurrences of TRUE in an array @@ -170,6 +182,7 @@ Some basic guidelines for editing this document: * @code{GETGID}: GETGID, Group ID function * @code{GETLOG}: GETLOG, Get login name * @code{GETPID}: GETPID, Process ID function +* @code{GET_TEAM}: GET_TEAM, Get the handle of a team * @code{GETUID}: GETUID, User ID function * @code{GMTIME}: GMTIME, Convert time to GMT info * @code{HOSTNM}: HOSTNM, Get system host name @@ -295,6 +308,7 @@ Some basic guidelines for editing this document: * @code{SIN}: SIN, Sine function * @code{SIND}: SIND, Sine function, degrees * @code{SINH}: SINH, Hyperbolic sine function +* @code{SINPI}: SINPI, Circular sine function * @code{SIZE}: SIZE, Function to determine the size of an array * @code{SIZEOF}: SIZEOF, Determine the size in bytes of an expression * @code{SLEEP}: SLEEP, Sleep for the specified number of seconds @@ -311,6 +325,8 @@ Some basic guidelines for editing this document: * @code{TAN}: TAN, Tangent function * @code{TAND}: TAND, Tangent function, degrees * @code{TANH}: TANH, Hyperbolic tangent function +* @code{TANPI}: TANPI, Circular tangent function +* @code{TEAM_NUMBER}: TEAM_NUMBER, Retrieve team id of given team * @code{THIS_IMAGE}: THIS_IMAGE, Cosubscript index of this image * @code{TIME}: TIME, Time function * @code{TIME8}: TIME8, Time function (64-bit) @@ -752,6 +768,62 @@ Inverse function: @* +@node ACOSPI +@section @code{ACOSPI} --- Circular arc cosine function +@fnindex ACOSPI +@cindex trigonometric function, cosine, inverse + +@table @asis +@item @emph{Description}: +@code{ACOSPI(X)} computes @math{ \acos(x) / \pi}, which is a measure +of an angle in half-revolutions. + +@item @emph{Standard}: +Fortran 2023 + +@item @emph{Class}: +Elemental function + +@item @emph{Syntax}: +@code{RESULT = ACOSPI(X)} + +@item @emph{Arguments}: +@multitable @columnfractions .15 .70 +@item @var{X} @tab The type shall be @code{REAL} with @math{-1 \leq x \leq 1}. +@end multitable + +@item @emph{Return value}: +The return value has the same type and kind as @var{X}. +It is expressed in half-revolutions and satisfies +@math{ 0 \leq \acospi (x) \leq 1}. + +@item @emph{Example}: +@smallexample +program test_acospi + implicit none + real, parameter :: x = 0.123, y(3) = [0.123, 0.45, 0.8] + real, parameter :: a = acospi(x), b(3) = acospi(y) + call foo(x, y) +contains + subroutine foo(u, v) + real, intent(in) :: u, v(:) + real :: f, g(size(v)) + f = acospi(u) + g = acospi(v) + if (abs(a - f) > 8 * epsilon(f)) stop 1 + if (any(abs(g - b) > 8 * epsilon(f))) stop 2 + end subroutine foo +end program test_acospi +@end smallexample + +@item @emph{See also}: +@ref{ASINPI} @* +@ref{ATAN2PI} @* +@ref{ATANPI} @* +@end table + + + @node ADJUSTL @section @code{ADJUSTL} --- Left adjust a string @fnindex ADJUSTL @@ -1467,6 +1539,62 @@ Inverse function: @* +@node ASINPI +@section @code{ASINPI} --- Circular arc sine function +@fnindex ASINPI +@cindex trigonometric function, sine, inverse + +@table @asis +@item @emph{Description}: +@code{ASINPI(X)} computes @math{ \asin(x) / \pi}, which is a measure +of an angle in half-revolutions. + +@item @emph{Standard}: +Fortran 2023 + +@item @emph{Class}: +Elemental function + +@item @emph{Syntax}: +@code{RESULT = ASINPI(X)} + +@item @emph{Arguments}: +@multitable @columnfractions .15 .70 +@item @var{X} @tab The type shall be @code{REAL} with @math{-1 \leq x \leq 1}. +@end multitable + +@item @emph{Return value}: +The return value has the same type and kind as @var{X}. +It is expressed in half-revolutions and satisfies +@math{ -0.5 \leq \asinpi (x) \leq 0.5}. + +@item @emph{Example}: +@smallexample +program test_asinpi + implicit none + real, parameter :: x = 0.123, y(3) = [0.123, 0.45, 0.8] + real, parameter :: a = asinpi(x), b(3) = asinpi(y) + call foo(x, y) +contains + subroutine foo(u, v) + real, intent(in) :: u, v(:) + real :: f, g(size(v)) + f = asinpi(u) + g = asinpi(v) + if (abs(a - f) > 8 * epsilon(f)) stop 1 + if (any(abs(g - b) > 8 * epsilon(f))) stop 2 + end subroutine foo +end program test_asinpi +@end smallexample + +@item @emph{See also}: +@ref{ACOSPI} @* +@ref{ATAN2PI} @* +@ref{ATANPI} @* +@end table + + + @node ASSOCIATED @section @code{ASSOCIATED} --- Status of a pointer or pointer/target pair @fnindex ASSOCIATED @@ -1545,7 +1673,7 @@ Fortran 90 and later @node ATAN -@section @code{ATAN} --- Arctangent function +@section @code{ATAN} --- Arctangent function @fnindex ATAN @fnindex DATAN @cindex trigonometric function, tangent, inverse @@ -1606,65 +1734,6 @@ Degrees function: @* -@node ATAND -@section @code{ATAND} --- Arctangent function, degrees -@fnindex ATAND -@fnindex DATAND -@cindex trigonometric function, tangent, inverse, degrees -@cindex tangent, inverse, degrees - -@table @asis -@item @emph{Synopsis}: -@multitable @columnfractions .80 -@item @code{RESULT = ATAND(X)} -@end multitable - -@item @emph{Description}: -@code{ATAND(X)} computes the arctangent of @var{X} in degrees (inverse of -@ref{TAND}). - -@item @emph{Class}: -Elemental function - -@item @emph{Arguments}: -@multitable @columnfractions .15 .70 -@item @var{X} @tab The type shall be @code{REAL}; -if @var{Y} is present, @var{X} shall be REAL. -@item @var{Y} @tab The type and kind type parameter shall be the same as @var{X}. -@end multitable - -@item @emph{Return value}: -The return value is of the same type and kind as @var{X}. -The result is in degrees and lies in the range -@math{-90 \leq \Re \atand(x) \leq 90}. - -@item @emph{Example}: -@smallexample -program test_atand - real(8) :: x = 2.866_8 - x = atand(x) -end program test_atand -@end smallexample - -@item @emph{Specific names}: -@multitable @columnfractions .23 .23 .20 .30 -@headitem Name @tab Argument @tab Return type @tab Standard -@item @code{ATAND(X)} @tab @code{REAL(4) X} @tab @code{REAL(4)} @tab Fortran 2023 -@item @code{DATAND(X)} @tab @code{REAL(8) X} @tab @code{REAL(8)} @tab GNU extension -@end multitable - -@item @emph{Standard}: -Fortran 2023 - -@item @emph{See also}: -Inverse function: @* -@ref{TAND} @* -Radians function: @* -@ref{ATAN} -@end table - - - @node ATAN2 @section @code{ATAN2} --- Arctangent function @fnindex ATAN2 @@ -1793,6 +1862,117 @@ Radians function: @* @ref{ATAN2} @end table + + +@node ATAN2PI +@section @code{ATAN2PI} --- Circular arc tangent function +@fnindex ATAN2PI +@cindex trigonometric function, tangent, inverse + +@table @asis +@item @emph{Description}: +@code{ATAN2PI(Y, X)} computes @math{ {\rm {atan2}}(y, x) / \pi}, +and provides a measure of an angle in half-revolutions within +the proper quadrant. + +@item @emph{Standard}: +Fortran 2023 + +@item @emph{Class}: +Elemental function + +@item @emph{Syntax}: +@code{RESULT = ATAN2PI(Y, X)} + +@item @emph{Arguments}: +@multitable @columnfractions .15 .70 +@item @var{Y} @tab The type shall be @code{REAL}. +@item @var{X} @tab The type and kind type parameter shall be the +same as @var{Y}. If @var{Y} is zero, then @var{X} shall be nonzero. +@end multitable + +@item @emph{Return value}: +The return value has the same type and kind type parameter as @var{Y} +and satisfies @math{-1 \leq {\rm {atan2}}(y, x) / \pi \leq 1}. + +@item @emph{Example}: +@smallexample +program test_atan2pi + real(kind=4) :: x = 1.e0_4, y = 0.5e0_4 + x = atan2pi(y, x) +end program test_atan2pi +@end smallexample + +@item @emph{See also}: +@ref{ACOSPI} @* +@ref{ASINPI} @* +@ref{ATANPI} @* +@end table + + + +@node ATAND +@section @code{ATAND} --- Arctangent function, degrees +@fnindex ATAND +@fnindex DATAND +@cindex trigonometric function, tangent, inverse, degrees +@cindex tangent, inverse, degrees + +@table @asis +@item @emph{Synopsis}: +@multitable @columnfractions .80 +@item @code{RESULT = ATAND(X)} +@item @code{RESULT = ATAND(Y, X)} +@end multitable + +@item @emph{Description}: +@code{ATAND(X)} computes the arctangent of @var{X} in degrees (inverse of +@ref{TAND}). + +@item @emph{Class}: +Elemental function + +@item @emph{Arguments}: +@multitable @columnfractions .15 .70 +@item @var{X} @tab The type shall be @code{REAL}. +@item @var{Y} @tab The type and kind type parameter shall be the same as @var{X}. +@end multitable + +@item @emph{Return value}: +The return value is of the same type and kind as @var{X}. +If @var{Y} is present, the result is identical to @code{ATAN2D(Y, X)}. +Otherwise, the result is in degrees and lies in the range +@math{-90 \leq \atand(x) \leq 90}. + +@item @emph{Example}: +@smallexample +program test_atand + real(8) :: x = 2.866_8 + real(4) :: x1 = 1.e0_4, y1 = 0.5e0_4 + x = atand(x) + x1 = atand(y1, x1) +end program test_atand +@end smallexample + +@item @emph{Specific names}: +@multitable @columnfractions .23 .23 .20 .30 +@headitem Name @tab Argument @tab Return type @tab Standard +@item @code{ATAND(X)} @tab @code{REAL(4) X} @tab @code{REAL(4)} @tab Fortran 2023 +@item @code{DATAND(X)} @tab @code{REAL(8) X} @tab @code{REAL(8)} @tab GNU extension +@end multitable + +@item @emph{Standard}: +Fortran 2023 + +@item @emph{See also}: +Inverse function: @* +@ref{TAND} @* +Radians function: @* +@ref{ATAN} +@end table + + + @node ATANH @section @code{ATANH} --- Inverse hyperbolic tangent function @fnindex ATANH @@ -1846,6 +2026,70 @@ Inverse function: @* +@node ATANPI +@section @code{ATANPI} --- Circular arc tangent function +@fnindex ATANPI +@cindex trigonometric function, tangent, inverse + +@table @asis +@item @emph{Description}: +@code{ATANPI(X)} computes @math{ \atan(x) / \pi}. +@code{ATANPI(Y, X)} computes @math{ {\rm atan2}(y, x) / \pi}. +These provide a measure of an angle in half-revolutions. + +@item @emph{Standard}: +Fortran 2023 + +@item @emph{Class}: +Elemental function + +@item @emph{Syntax}: +@multitable @columnfractions .80 +@item @code{RESULT = ATANPI(X)} +@item @code{RESULT = ATANPI(Y, X)} +@end multitable + +@item @emph{Arguments}: +@multitable @columnfractions .15 .70 +@item @var{Y} @tab The type shall be @code{REAL}. +@item @var{X} @tab If @var{Y} appears, @var{X} shall have the same type +and kind as @var{Y}. If @var{Y} is zero, then @var{X} shall not be zero. +If @var{Y} does not appear in a function reference, then @var{X} shall be +@code{REAL}. +@end multitable + +@item @emph{Return value}: +The return value has the same type and kind as @var{X}. +It is expressed in half-revolutions and satisfies +@math{ -0.5 \leq \atanpi (x) \leq 0.5}. + +@item @emph{Example}: +@smallexample +program test_atanpi + implicit none + real, parameter :: x = 0.123, y(3) = [0.123, 0.45, 0.8] + real, parameter :: a = atanpi(x), b(3) = atanpi(y) + call foo(x, y) +contains + subroutine foo(u, v) + real, intent(in) :: u, v(:) + real :: f, g(size(v)) + f = atanpi(u) + g = atanpi(v) + if (abs(a - f) > 8 * epsilon(f)) stop 1 + if (any(abs(g - b) > 8 * epsilon(f))) stop 2 + end subroutine foo +end program test_atanpi +@end smallexample + +@item @emph{See also}: +@ref{ACOSPI} @* +@ref{ASINPI} @* +@ref{ATAN2PI} @* +@end table + + + @node ATOMIC_ADD @section @code{ATOMIC_ADD} --- Atomic ADD operation @fnindex ATOMIC_ADD @@ -4386,6 +4630,57 @@ Inverse function: @* +@node COSPI +@section @code{COSPI} --- Circular cosine function +@fnindex COSPI +@cindex trigonometric function, cosine +@cindex cosine + +@table @asis +@item @emph{Description}: +@code{COSPI(X)} computes @math{\cos(\pi x)} without performing +an explicit multiplication by @math{\pi}. This is achieved +through argument reduction where @math{ x = n + r } with +@math{n} an integer and @math{0 \leq r \le 1}. +Due to the +properties of floating-point arithmetic, the useful range +for @var{X} is defined by +@code{ABS(X) <= REAL(2,KIND(X))**DIGITS(X)}. + +@item @emph{Standard}: +Fortran 2023 + +@item @emph{Class}: +Elemental function + +@item @emph{Syntax}: +@code{RESULT = COSPI(X)} + +@item @emph{Arguments}: +@multitable @columnfractions .15 .70 +@item @var{X} @tab The type shall be @code{REAL}. +@end multitable + +@item @emph{Return value}: +The return value is of the same type and kind as @var{X}. +The result is in half-revolutions and satisfies +@math{ -1 \leq \cospi (x) \leq 1}. + +@item @emph{Example}: +@smallexample +program test_cospi + real :: x = 0.0 + x = cospi(x) +end program test_cospi +@end smallexample + +@item @emph{See also}: +@ref{ACOSPI} @* +@ref{COS} @* +@end table + + + @node COTAN @section @code{COTAN} --- Cotangent function @fnindex COTAN @@ -6706,9 +7001,11 @@ Subroutine, function @item @emph{Arguments}: @multitable @columnfractions .15 .70 @item @var{UNIT} @tab An open I/O unit number of type @code{INTEGER}. -@item @var{VALUES} @tab The type shall be @code{INTEGER(4), DIMENSION(13)}. -@item @var{STATUS} @tab (Optional) status flag of type @code{INTEGER(4)}. Returns 0 -on success and a system specific error code otherwise. +@item @var{VALUES} @tab The type shall be @code{INTEGER, DIMENSION(13)} +of the default kind. +@item @var{STATUS} @tab (Optional) status flag of type @code{INTEGER} +of the default kind. +Returns 0 on success and a system specific error code otherwise. @end multitable @item @emph{Example}: @@ -7336,6 +7633,59 @@ GNU extension +@node GET_TEAM +@section @code{GET_TEAM} --- Get the handle of a team +@fnindex GET_TEAM +@cindex coarray, @code{GET_TEAM} +@cindex images, get a handle to a team + +@table @asis +@item @emph{Synopsis}: +@code{RESULT = GET_TEAM([LEVEL])} + +@item @emph{Description}: +Returns the handle of the current team, if @var{LEVEL} is not given. Or the +team specified by @var{LEVEL}, where @var{LEVEL} is one of the constants +@code{INITIAL_TEAM}, @code{PARENT_TEAM} or @code{CURRENT_TEAM} from the +intrinsic module @code{ISO_FORTRAN_ENV}. Calling the function with +@code{PARENT_TEAM} while being on the initial team, returns a handle to the +initial team. This ensures that always a valid team is returned, given that +team handles can neither be checked for validity nor compared with each other +or null. + +@item @emph{Class}: +Transformational function + +@item @emph{Return value}: +An opaque handle of @code{TEAM_TYPE} from the intrinsic module +@code{ISO_FORTRAN_ENV}. + +@item @emph{Example}: +@smallexample +program info + use, intrinsic :: iso_fortran_env + type(team_type) :: init, curr, par, nt + + init = get_team() + curr = get_team(current_team) ! init equals curr here + form team(1, nt) + change team(nt) + curr = get_team() ! or get_team(current_team) + par = get_team(parent_team) ! par equals init here + end team +end program info +@end smallexample + +@item @emph{Standard}: +Fortran 2018 or later + +@item @emph{See also}: +@ref{THIS_IMAGE}, @* +@ref{ISO_FORTRAN_ENV} +@end table + + + @node GETUID @section @code{GETUID} --- User ID function @fnindex GETUID @@ -9958,8 +10308,10 @@ Subroutine, function @multitable @columnfractions .15 .70 @item @var{NAME} @tab The type shall be @code{CHARACTER} of the default kind, a valid path within the file system. -@item @var{VALUES} @tab The type shall be @code{INTEGER(4), DIMENSION(13)}. -@item @var{STATUS} @tab (Optional) status flag of type @code{INTEGER(4)}. +@item @var{VALUES} @tab The type shall be @code{INTEGER, DIMENSION(13)} +of the default kind. +@item @var{STATUS} @tab (Optional) status flag of type @code{INTEGER} +of the default kind. Returns 0 on success and a system specific error code otherwise. @end multitable @@ -11372,47 +11724,48 @@ Fortran 95 and later @table @asis @item @emph{Synopsis}: -@code{RESULT = NUM_IMAGES(DISTANCE, FAILED)} +@multitable @columnfractions .80 +@item @code{RESULT = NUM_IMAGES([TEAM])} +@item @code{RESULT = NUM_IMAGES(TEAM_NUMBER)} +@end multitable @item @emph{Description}: -Returns the number of images. +Returns the number of images in the current team or the given team. @item @emph{Class}: Transformational function @item @emph{Arguments}: @multitable @columnfractions .15 .70 -@item @var{DISTANCE} @tab (optional, intent(in)) Nonnegative scalar integer -@item @var{FAILED} @tab (optional, intent(in)) Scalar logical expression +@item @var{TEAM} @tab (optional, intent(in)) If present, return the number of +images in the given team; if absent, return the number of images in the +current team. +@item @var{TEAM_NUMBER} @tab (intent(in)) The number as given in the +@code{FORM TEAM} statement. @end multitable @item @emph{Return value}: -Scalar default-kind integer. If @var{DISTANCE} is not present or has value 0, -the number of images in the current team is returned. For values smaller or -equal distance to the initial team, it returns the number of images index -on the ancestor team that has a distance of @var{DISTANCE} from the invoking -team. If @var{DISTANCE} is larger than the distance to the initial team, the -number of images of the initial team is returned. If @var{FAILED} is not present -the total number of images is returned; if it has the value @code{.TRUE.}, -the number of failed images is returned, otherwise, the number of images that -do have not the failed status. +Scalar default-kind integer. Can be called without any arguments or a team +type argument or a team_number argument. @item @emph{Example}: @smallexample +use, intrinsic :: iso_fortran_env INTEGER :: value[*] INTEGER :: i -value = THIS_IMAGE() -SYNC ALL -IF (THIS_IMAGE() == 1) THEN - DO i = 1, NUM_IMAGES() - WRITE(*,'(2(a,i0))') 'value[', i, '] is ', value[i] - END DO -END IF +type(team_type) :: t + +! When running with 4 images +print *, num_images() ! 4 + +form team (mod(this_image(), 2), t) +print *, num_images(t) ! 2 +print *, num_images(-1) ! 4 @end smallexample @item @emph{Standard}: -Fortran 2008 and later. With @var{DISTANCE} or @var{FAILED} argument, -Technical Specification (TS) 18508 or later +Fortran 2008 and later. With @var{TEAM} or @var{TEAM_NUMBER} argument, +Fortran 2018 and later. @item @emph{See also}: @ref{THIS_IMAGE}, @* @@ -13618,6 +13971,57 @@ a GNU extension +@node SINPI +@section @code{SINPI} --- Circular sine function +@fnindex SINPI +@cindex trigonometric function, sine +@cindex sine + +@table @asis +@item @emph{Description}: +@code{SINPI(X)} computes @math{\sin(\pi x)} without performing +an explicit multiplication by @math{\pi}. This is achieved +through argument reduction where @math{ |x| = n + r } with +@math{n} an integer and @math{0 \leq r \le 1}. +Due to the +properties of floating-point arithmetic, the useful range +for @var{X} is defined by +@code{ABS(X) <= REAL(2,KIND(X))**DIGITS(X)}. + +@item @emph{Standard}: +Fortran 2023 + +@item @emph{Class}: +Elemental function + +@item @emph{Syntax}: +@code{RESULT = SINPI(X)} + +@item @emph{Arguments}: +@multitable @columnfractions .15 .70 +@item @var{X} @tab The type shall be @code{REAL}. +@end multitable + +@item @emph{Return value}: +The return value is of the same type and kind as @var{X}. +The result is in half-revolutions and satisfies +@math{ -1 \leq \sinpi (x) \leq 1}. + +@item @emph{Example}: +@smallexample +program test_sinpi + real :: x = 0.0 + x = sinpi(x) +end program test_sinpi +@end smallexample + +@item @emph{See also}: +@ref{ASINPI} @* +@ref{SIN} @* +@end table + + + @node SIZE @section @code{SIZE} --- Determine the size of an array @fnindex SIZE @@ -13991,6 +14395,8 @@ The elements that are obtained and stored in the array @code{VALUES}: Not all these elements are relevant on all systems. If an element is not relevant, it is returned as 0. +If the value of an element would overflow the range of default integer, +a -1 is returned instead. This intrinsic is provided in both subroutine and function forms; however, only one form can be used in any given program unit. @@ -14002,9 +14408,11 @@ Subroutine, function @multitable @columnfractions .15 .70 @item @var{NAME} @tab The type shall be @code{CHARACTER}, of the default kind and a valid path within the file system. -@item @var{VALUES} @tab The type shall be @code{INTEGER(4), DIMENSION(13)}. -@item @var{STATUS} @tab (Optional) status flag of type @code{INTEGER(4)}. Returns 0 -on success and a system specific error code otherwise. +@item @var{VALUES} @tab The type shall be @code{INTEGER, DIMENSION(13)} +of the default kind. +@item @var{STATUS} @tab (Optional) status flag of type @code{INTEGER} +of the default kind. +Returns 0 on success and a system specific error code otherwise. @end multitable @item @emph{Example}: @@ -14467,6 +14875,103 @@ Fortran 77 and later, for a complex argument Fortran 2008 or later +@node TEAM_NUMBER +@section @code{TEAM_NUMBER} --- Retrieve team id of given team +@fnindex TEAM_NUMBER +@cindex coarray, @code{TEAM_NUMBER} +@cindex teams, index of given team + +@table @asis +@item @emph{Synopsis}: +@item @code{RESULT = TEAM_NUMBER([TEAM])} + +@item @emph{Description}: +Returns the team id for the given @var{TEAM} as assigned by @code{FORM TEAM}. +If @var{TEAM} is absent, returns the team number of the current team. + +@item @emph{Class}: +Transformational function + +@item @emph{Arguments}: +@multitable @columnfractions .15 .70 +@item @var{TEAM} @tab (optional, intent(in)) The handle of the team for which +the number, aka id, is desired. +@end multitable + +@item @emph{Return value}: +Default integer. The id as given in a call @code{FORM TEAM}. Applying +@code{TEAM_NUMBER} to the initial team will result in @code{-1} to be returned. +Returns the id of the current team, if @var{TEAM} is null. + +@item @emph{Example}: +@smallexample +use, intrinsic :: iso_fortran_env +type(team_type) :: t + +print *, team_number() ! -1 +form team (99, t) +print *, team_number(t) ! 99 +@end smallexample + +@item @emph{Standard}: +Fortran 2018 and later. + +@item @emph{See also}: +@ref{GET_TEAM}, @* +@ref{TEAM_NUMBER} +@end table + + + +@node TANPI +@section @code{TANPI} --- Circular tangent function +@fnindex TANPI +@cindex trigonometric function, tangent +@cindex tangent + +@table @asis +@item @emph{Description}: +@code{TANPI(X)} computes @math{\tan(\pi x)} without performing +an explicit multiplication by @math{\pi}. This is achieved +through argument reduction where @math{ |x| = n + r } with +@math{n} an integer and @math{0 \leq r \le 1}. +Due to the +properties of floating-point arithmetic, the useful range +for @var{X} is defined by +@code{ABS(X) <= REAL(2,KIND(X))**DIGITS(X)}. + +@item @emph{Standard}: +Fortran 2023 + +@item @emph{Class}: +Elemental function + +@item @emph{Syntax}: +@code{RESULT = TANPI(X)} + +@item @emph{Arguments}: +@multitable @columnfractions .15 .70 +@item @var{X} @tab The type shall be @code{REAL}. +@end multitable + +@item @emph{Return value}: +The return value is of the same type and kind as @var{X}. + +@item @emph{Example}: +@smallexample +program test_tanpi + real :: x = 0.0 + x = tanpi(x) +end program test_tanpi +@end smallexample + +@item @emph{See also}: +@ref{ATANPI} @* +@ref{TAN} @* +@end table + + + @node THIS_IMAGE @section @code{THIS_IMAGE} --- Function that returns the cosubscript index of this image @fnindex THIS_IMAGE @@ -14476,9 +14981,8 @@ Fortran 77 and later, for a complex argument Fortran 2008 or later @table @asis @item @emph{Synopsis}: @multitable @columnfractions .80 -@item @code{RESULT = THIS_IMAGE()} -@item @code{RESULT = THIS_IMAGE(DISTANCE)} -@item @code{RESULT = THIS_IMAGE(COARRAY [, DIM])} +@item @code{RESULT = THIS_IMAGE([TEAM])} +@item @code{RESULT = THIS_IMAGE(COARRAY [, DIM][, TEAM])} @end multitable @item @emph{Description}: @@ -14489,8 +14993,8 @@ Transformational function @item @emph{Arguments}: @multitable @columnfractions .15 .70 -@item @var{DISTANCE} @tab (optional, intent(in)) Nonnegative scalar integer -(not permitted together with @var{COARRAY}). +@item @var{TEAM} @tab (optional, intent(in)) The team for which the index of +this image is desired. The current team is used, when no team is given. @item @var{COARRAY} @tab Coarray of any type (optional; if @var{DIM} present, required). @item @var{DIM} @tab default integer scalar (optional). If present, @@ -14499,16 +15003,16 @@ present, required). @item @emph{Return value}: Default integer. If @var{COARRAY} is not present, it is scalar; if -@var{DISTANCE} is not present or has value 0, its value is the image index on -the invoking image for the current team, for values smaller or equal -distance to the initial team, it returns the image index on the ancestor team -that has a distance of @var{DISTANCE} from the invoking team. If -@var{DISTANCE} is larger than the distance to the initial team, the image -index of the initial team is returned. Otherwise when the @var{COARRAY} is +@var{TEAM} is not present, its value is the image index on the invoking image +for the current team; if @var{TEAM} is present, returns the image index of +the invoking image as given to the @code{FORM TEAM (..., NEW_INDEX=..)} call, +or a implementation specific unique number, when @code{NEW_INDEX=} was absent +from @code{FORM TEAM}. Otherwise when the @var{COARRAY} is present, if @var{DIM} is not present, a rank-1 array with corank elements is returned, containing the cosubscripts for @var{COARRAY} specifying the invoking -image. If @var{DIM} is present, a scalar is returned, with the value of -the @var{DIM} element of @code{THIS_IMAGE(COARRAY)}. +image (in the team when @var{TEAM} is present). If @var{DIM} is present, a +scalar is returned, with the value of the @var{DIM} element of +@code{THIS_IMAGE(COARRAY)}. @item @emph{Example}: @smallexample @@ -14523,13 +15027,12 @@ IF (THIS_IMAGE() == 1) THEN END IF ! Check whether the current image is the initial image -IF (THIS_IMAGE(HUGE(1)) /= THIS_IMAGE()) +IF (THIS_IMAGE(GET_TEAM(INITIAL_TEAM)) /= THIS_IMAGE()) error stop "something is rotten here" @end smallexample @item @emph{Standard}: -Fortran 2008 and later. With @var{DISTANCE} argument, -Technical Specification (TS) 18508 or later +Fortran 2008 and later. With @var{TEAM} argument, Fortran 2018 or later @item @emph{See also}: @ref{NUM_IMAGES}, @* @@ -15354,12 +15857,18 @@ parameters of the @code{CHARACTER} type. (Fortran 2008 or later.) @item @code{CHARACTER_STORAGE_SIZE}: Size in bits of the character storage unit. +@item @code{CURRENT_TEAM}: +The argument to @ref{GET_TEAM} to retrieve a handle of the current team. + @item @code{ERROR_UNIT}: Identifies the preconnected unit used for error reporting. @item @code{FILE_STORAGE_SIZE}: Size in bits of the file-storage unit. +@item @code{INTIAL_TEAM}: +Argument to @ref{GET_TEAM} to retrieve a handle of the initial team. + @item @code{INPUT_UNIT}: Identifies the preconnected unit identified by the asterisk (@code{*}) in @code{READ} statement. @@ -15397,6 +15906,9 @@ parameters of the @code{LOGICAL} type. (Fortran 2008 or later.) Identifies the preconnected unit identified by the asterisk (@code{*}) in @code{WRITE} statement. +@item @code{PARENT_TEAM}: +Argument to @ref{GET_TEAM} to retrieve a handle to the parent team. + @item @code{REAL32}, @code{REAL64}, @code{REAL128}: Kind type parameters to specify a REAL type with a storage size of 32, 64, and 128 bits. It is negative if a target platform @@ -15445,6 +15957,10 @@ Derived type with private components to be use with the @code{LOCK} and @code{UNLOCK} statement. A variable of its type has to be always declared as coarray and may not appear in a variable-definition context. (Fortran 2008 or later.) +@item @code{TEAM_TYPE}: +An opaque type for handling teams. Note that a variable of type +@code{TEAM_TYPE} is not comparable with other variables of the same or other +types nor with null. @end table The module also provides the following intrinsic procedures: diff --git a/gcc/fortran/io.cc b/gcc/fortran/io.cc index b5c9d33..7466d8f 100644 --- a/gcc/fortran/io.cc +++ b/gcc/fortran/io.cc @@ -1228,7 +1228,8 @@ between_desc: default: if (mode != MODE_FORMAT) format_locus.nextc += format_string_pos - 1; - if (!gfc_notify_std (GFC_STD_GNU, "Missing comma at %L", &format_locus)) + if (!gfc_notify_std (GFC_STD_LEGACY, + "Missing comma in FORMAT string at %L", &format_locus)) return false; /* If we do not actually return a failure, we need to unwind this before the next round. */ @@ -1290,7 +1291,8 @@ extension_optional_comma: default: if (mode != MODE_FORMAT) format_locus.nextc += format_string_pos; - if (!gfc_notify_std (GFC_STD_GNU, "Missing comma at %L", &format_locus)) + if (!gfc_notify_std (GFC_STD_LEGACY, + "Missing comma in FORMAT string at %L", &format_locus)) return false; /* If we do not actually return a failure, we need to unwind this before the next round. */ diff --git a/gcc/fortran/iresolve.cc b/gcc/fortran/iresolve.cc index 55f7e19..1001309 100644 --- a/gcc/fortran/iresolve.cc +++ b/gcc/fortran/iresolve.cc @@ -2408,6 +2408,220 @@ gfc_resolve_realpart (gfc_expr *f, gfc_expr *a) } +/* Generate a wrapper subroutine for the operation so that the library REDUCE + function can use pointer arithmetic for OPERATION and not be dependent on + knowledge of its type. */ +static gfc_symtree * +generate_reduce_op_wrapper (gfc_expr *op) +{ + gfc_symbol *operation = op->symtree->n.sym; + gfc_symbol *wrapper, *a, *b, *c; + gfc_symtree *st; + char tname[2 * GFC_MAX_SYMBOL_LEN + 2]; + char *name; + gfc_namespace *ns; + gfc_expr *e; + + /* Find the top-level namespace. */ + for (ns = gfc_current_ns; ns; ns = ns->parent) + if (!ns->parent) + break; + + sprintf (tname, "%s_%s", operation->name, + ns->proc_name ? ns->proc_name->name : "noname"); + name = xasprintf ("__reduce_wrapper_%s", tname); + + gfc_find_sym_tree (name, ns, 0, &st); + + if (st && !strcmp (name, st->name)) + { + free (name); + return st; + } + + /* Create the wrapper namespace and contain it in 'ns'. */ + gfc_namespace *sub_ns = gfc_get_namespace (ns, 0); + sub_ns->sibling = ns->contained; + ns->contained = sub_ns; + sub_ns->resolved = 1; + + /* Set up procedure symbol. */ + gfc_get_symbol (name, ns, &wrapper); + sub_ns->proc_name = wrapper; + wrapper->attr.flavor = FL_PROCEDURE; + wrapper->attr.subroutine = 1; + wrapper->attr.artificial = 1; + wrapper->attr.if_source = IFSRC_DECL; + if (ns->proc_name->attr.flavor == FL_MODULE) + wrapper->module = ns->proc_name->name; + gfc_set_sym_referenced (wrapper); + + /* Set up formal argument for the argument 'a'. */ + gfc_get_symbol ("a", sub_ns, &a); + a->ts = operation->ts; + a->attr.flavor = FL_VARIABLE; + a->attr.dummy = 1; + a->attr.artificial = 1; + a->attr.intent = INTENT_IN; + wrapper->formal = gfc_get_formal_arglist (); + wrapper->formal->sym = a; + gfc_set_sym_referenced (a); + + /* Set up formal argument for the argument 'b'. This is optional. When + present, the wrapped function is called, otherwise 'a' is assigned + to 'c'. This way, deep copies are effected in the library. */ + gfc_get_symbol ("b", sub_ns, &b); + b->ts = operation->ts; + b->attr.flavor = FL_VARIABLE; + b->attr.dummy = 1; + b->attr.optional= 1; + b->attr.artificial = 1; + b->attr.intent = INTENT_IN; + wrapper->formal->next = gfc_get_formal_arglist (); + wrapper->formal->next->sym = b; + gfc_set_sym_referenced (b); + + /* Set up formal argument for the argument 'c'. */ + gfc_get_symbol ("c", sub_ns, &c); + c->ts = operation->ts; + c->attr.flavor = FL_VARIABLE; + c->attr.dummy = 1; + c->attr.artificial = 1; + c->attr.intent = INTENT_INOUT; + wrapper->formal->next->next = gfc_get_formal_arglist (); + wrapper->formal->next->next->sym = c; + gfc_set_sym_referenced (c); + +/* The only code is: + if (present (b)) + c = operation (a, b) + else + c = a + endif + A call with 'b' missing provides a convenient way for the library to do + an intrinsic assignment instead of a call to memcpy and, where allocatable + components are present, a deep copy. + + Code for if (present (b)) */ + sub_ns->code = gfc_get_code (EXEC_IF); + gfc_code *if_block = sub_ns->code; + if_block->block = gfc_get_code (EXEC_IF); + if_block->block->expr1 = gfc_get_expr (); + e = if_block->block->expr1; + e->expr_type = EXPR_FUNCTION; + e->where = gfc_current_locus; + gfc_get_sym_tree ("present", sub_ns, &e->symtree, false); + e->symtree->n.sym->attr.flavor = FL_PROCEDURE; + e->symtree->n.sym->attr.intrinsic = 1; + e->ts.type = BT_LOGICAL; + e->ts.kind = gfc_default_logical_kind; + e->value.function.isym = gfc_intrinsic_function_by_id (GFC_ISYM_PRESENT); + e->value.function.actual = gfc_get_actual_arglist (); + e->value.function.actual->expr = gfc_lval_expr_from_sym (b); + +/* Code for c = operation (a, b) */ + if_block->block->next = gfc_get_code (EXEC_ASSIGN); + if_block->block->next->expr1 = gfc_lval_expr_from_sym (c); + if_block->block->next->expr2 = gfc_get_expr (); + e = if_block->block->next->expr2; + e->expr_type = EXPR_FUNCTION; + e->where = gfc_current_locus; + if_block->block->next->expr2->ts = operation->ts; + gfc_get_sym_tree (operation->name, ns, &e->symtree, false); + e->value.function.esym = if_block->block->next->expr2->symtree->n.sym; + e->value.function.actual = gfc_get_actual_arglist (); + e->value.function.actual->expr = gfc_lval_expr_from_sym (a); + e->value.function.actual->next = gfc_get_actual_arglist (); + e->value.function.actual->next->expr = gfc_lval_expr_from_sym (b); + + if_block->block->block = gfc_get_code (EXEC_IF); + if_block->block->block->next = gfc_get_code (EXEC_ASSIGN); + if_block->block->block->next->expr1 = gfc_lval_expr_from_sym (c); + if_block->block->block->next->expr2 = gfc_lval_expr_from_sym (a); + + /* It is unexpected to have some symbols added at resolution. Commit the + changes in order to keep a clean state. */ + gfc_commit_symbol (if_block->block->expr1->symtree->n.sym); + gfc_commit_symbol (wrapper); + gfc_commit_symbol (a); + gfc_commit_symbol (b); + gfc_commit_symbol (c); + + gfc_find_sym_tree (name, ns, 0, &st); + free (name); + + return st; +} + +void +gfc_resolve_reduce (gfc_expr *f, gfc_expr *array, + gfc_expr *operation, + gfc_expr *dim, + gfc_expr *mask, + gfc_expr *identity ATTRIBUTE_UNUSED, + gfc_expr *ordered ATTRIBUTE_UNUSED) +{ + gfc_symtree *wrapper_symtree; + gfc_typespec ts; + + gfc_resolve_expr (array); + if (array->ts.type == BT_CHARACTER && array->ref) + gfc_resolve_substring_charlen (array); + + f->ts = array->ts; + + /* Replace 'operation' with its subroutine wrapper so that pointers may be + used throughout the library function. */ + wrapper_symtree = generate_reduce_op_wrapper (operation); + gcc_assert (wrapper_symtree && wrapper_symtree->n.sym); + operation->symtree = wrapper_symtree; + operation->ts = operation->symtree->n.sym->ts; + + /* The scalar library function converts the scalar result to a dimension + zero descriptor and then returns the data after the call. */ + if (f->ts.type == BT_CHARACTER) + { + if (dim && array->rank > 1) + { + f->value.function.name = gfc_get_string (PREFIX ("reduce_c")); + f->rank = array->rank - 1; + } + else + { + f->value.function.name = gfc_get_string (PREFIX ("reduce_scalar_c")); + f->rank = 0; + } + } + else + { + if (dim && array->rank > 1) + { + f->value.function.name = gfc_get_string (PREFIX ("reduce")); + f->rank = array->rank - 1; + } + else + { + f->value.function.name = gfc_get_string (PREFIX ("reduce_scalar")); + f->rank = 0; + } + } + + if (dim) + { + ts = dim->ts; + ts.kind = 4; + gfc_convert_type_warn (dim, &ts, 1, 0); + } + + if (mask) + { + ts = mask->ts; + ts.kind = 4; + gfc_convert_type_warn (mask, &ts, 1, 0); + } +} + + void gfc_resolve_rename (gfc_expr *f, gfc_expr *p1 ATTRIBUTE_UNUSED, gfc_expr *p2 ATTRIBUTE_UNUSED) @@ -2995,17 +3209,28 @@ gfc_resolve_get_team (gfc_expr *f, gfc_expr *level ATTRIBUTE_UNUSED) { static char get_team[] = "_gfortran_caf_get_team"; f->rank = 0; - f->ts.type = BT_INTEGER; - f->ts.kind = gfc_default_integer_kind; + f->ts.type = BT_DERIVED; + gfc_find_symbol ("team_type", gfc_current_ns, 1, &f->ts.u.derived); + if (!f->ts.u.derived + || f->ts.u.derived->from_intmod != INTMOD_ISO_FORTRAN_ENV) + { + gfc_error ( + "GET_TEAM at %L needs USE of the intrinsic module ISO_FORTRAN_ENV " + "to define its result type TEAM_TYPE", + &f->where); + f->ts.type = BT_UNKNOWN; + } f->value.function.name = get_team; -} + /* No requirements to resolve for level argument now. */ +} /* Resolve image_index (...). */ void gfc_resolve_image_index (gfc_expr *f, gfc_expr *array ATTRIBUTE_UNUSED, - gfc_expr *sub ATTRIBUTE_UNUSED) + gfc_expr *sub ATTRIBUTE_UNUSED, + gfc_expr *team_or_team_number ATTRIBUTE_UNUSED) { static char image_index[] = "__image_index"; f->ts.type = BT_INTEGER; @@ -3034,31 +3259,46 @@ gfc_resolve_stopped_images (gfc_expr *f, gfc_expr *team ATTRIBUTE_UNUSED, /* Resolve team_number (team). */ void -gfc_resolve_team_number (gfc_expr *f, gfc_expr *team ATTRIBUTE_UNUSED) +gfc_resolve_team_number (gfc_expr *f, gfc_expr *team) { static char team_number[] = "_gfortran_caf_team_number"; f->rank = 0; f->ts.type = BT_INTEGER; f->ts.kind = gfc_default_integer_kind; f->value.function.name = team_number; -} + if (team) + gfc_resolve_expr (team); +} void -gfc_resolve_this_image (gfc_expr *f, gfc_expr *array, gfc_expr *dim, - gfc_expr *distance ATTRIBUTE_UNUSED) +gfc_resolve_this_image (gfc_expr *f, gfc_expr *coarray, gfc_expr *dim, + gfc_expr *team) { static char this_image[] = "__this_image"; - if (array && gfc_is_coarray (array)) - resolve_bound (f, array, dim, NULL, "__this_image", true); + if (coarray && dim) + resolve_bound (f, coarray, dim, NULL, this_image, true); + else if (coarray) + { + f->ts.type = BT_INTEGER; + f->ts.kind = gfc_default_integer_kind; + f->value.function.name = this_image; + if (f->shape && f->rank != 1) + gfc_free_shape (&f->shape, f->rank); + f->rank = 1; + f->shape = gfc_get_shape (1); + mpz_init_set_ui (f->shape[0], coarray->corank); + } else { f->ts.type = BT_INTEGER; f->ts.kind = gfc_default_integer_kind; f->value.function.name = this_image; } -} + if (team) + gfc_resolve_expr (team); +} void gfc_resolve_time (gfc_expr *f) @@ -3195,13 +3435,12 @@ gfc_resolve_trim (gfc_expr *f, gfc_expr *string) f->value.function.name = gfc_get_string ("__trim_%d", string->ts.kind); } - -/* Resolve the degree trigonometric functions. This amounts to setting +/* Resolve the trigonometric functions. This amounts to setting the function return type-spec from its argument and building a library function names of the form _gfortran_sind_r4. */ void -gfc_resolve_trigd (gfc_expr *f, gfc_expr *x) +gfc_resolve_trig (gfc_expr *f, gfc_expr *x) { f->ts = x->ts; f->value.function.name @@ -3210,9 +3449,8 @@ gfc_resolve_trigd (gfc_expr *f, gfc_expr *x) gfc_type_abi_kind (&x->ts)); } - void -gfc_resolve_trigd2 (gfc_expr *f, gfc_expr *y, gfc_expr *x) +gfc_resolve_trig2 (gfc_expr *f, gfc_expr *y, gfc_expr *x) { f->ts = y->ts; f->value.function.name diff --git a/gcc/fortran/iso-fortran-env.def b/gcc/fortran/iso-fortran-env.def index b8926f4..250a730 100644 --- a/gcc/fortran/iso-fortran-env.def +++ b/gcc/fortran/iso-fortran-env.def @@ -83,17 +83,23 @@ NAMED_INTCST (ISOFORTRANENV_REAL64, "real64", \ gfc_get_real_kind_from_width_isofortranenv (64), GFC_STD_F2008) NAMED_INTCST (ISOFORTRANENV_REAL128, "real128", \ gfc_get_real_kind_from_width_isofortranenv (128), GFC_STD_F2008) -NAMED_INTCST (ISOFORTRANENV_FILE_STAT_LOCKED, "stat_locked", \ +NAMED_INTCST (ISOFORTRANENV_STAT_LOCKED, "stat_locked", \ GFC_STAT_LOCKED, GFC_STD_F2008) -NAMED_INTCST (ISOFORTRANENV_FILE_STAT_LOCKED_OTHER_IMAGE, \ +NAMED_INTCST (ISOFORTRANENV_STAT_LOCKED_OTHER_IMAGE, \ "stat_locked_other_image", \ GFC_STAT_LOCKED_OTHER_IMAGE, GFC_STD_F2008) -NAMED_INTCST (ISOFORTRANENV_FILE_STAT_STOPPED_IMAGE, "stat_stopped_image", \ - GFC_STAT_STOPPED_IMAGE, GFC_STD_F2008) -NAMED_INTCST (ISOFORTRANENV_FILE_STAT_FAILED_IMAGE, "stat_failed_image", \ - GFC_STAT_FAILED_IMAGE, GFC_STD_F2018) -NAMED_INTCST (ISOFORTRANENV_FILE_STAT_UNLOCKED, "stat_unlocked", \ - GFC_STAT_UNLOCKED, GFC_STD_F2008) +NAMED_INTCST (ISOFORTRANENV_STAT_STOPPED_IMAGE, "stat_stopped_image", \ + GFC_STAT_STOPPED_IMAGE, GFC_STD_F2008) +NAMED_INTCST (ISOFORTRANENV_STAT_FAILED_IMAGE, "stat_failed_image", \ + GFC_STAT_FAILED_IMAGE, GFC_STD_F2018) +NAMED_INTCST (ISOFORTRANENV_STAT_UNLOCKED, "stat_unlocked", \ + GFC_STAT_UNLOCKED, GFC_STD_F2008) +NAMED_INTCST (ISOFORTRANENV_INITIAL_TEAM, "initial_team", \ + GFC_CAF_INITIAL_TEAM, GFC_STD_F2018) +NAMED_INTCST (ISOFORTRANENV_PARENT_TEAM, "parent_team", \ + GFC_CAF_PARENT_TEAM, GFC_STD_F2018) +NAMED_INTCST (ISOFORTRANENV_CURRENT_TEAM, "current_team", \ + GFC_CAF_CURRENT_TEAM, GFC_STD_F2018) /* The arguments to NAMED_KINDARRAY are: @@ -134,9 +140,7 @@ NAMED_DERIVED_TYPE (ISOFORTRAN_EVENT_TYPE, "event_type", \ : gfc_default_integer_kind, GFC_STD_F2018) NAMED_DERIVED_TYPE (ISOFORTRAN_TEAM_TYPE, "team_type", \ - flag_coarray == GFC_FCOARRAY_LIB - ? get_int_kind_from_node (ptr_type_node) - : gfc_default_integer_kind, GFC_STD_F2018) + get_int_kind_from_node (ptr_type_node), GFC_STD_F2018) NAMED_INTCST (ISOFORTRANENV_LOGICAL8, "logical8", \ gfc_get_int_kind_from_width_isofortranenv (8), GFC_STD_F2023) diff --git a/gcc/fortran/libgfortran.h b/gcc/fortran/libgfortran.h index 9565365..9de5afb 100644 --- a/gcc/fortran/libgfortran.h +++ b/gcc/fortran/libgfortran.h @@ -154,12 +154,20 @@ typedef enum GFC_STAT_LOCKED, GFC_STAT_LOCKED_OTHER_IMAGE, GFC_STAT_STOPPED_IMAGE = 6000, /* See LIBERROR_INQUIRE_INTERNAL_UNIT above. */ - GFC_STAT_FAILED_IMAGE = 6001 + GFC_STAT_FAILED_IMAGE = 6001, + GFC_STAT_UNLOCKED_FAILED_IMAGE = 6002 } libgfortran_stat_codes; typedef enum { + GFC_CAF_INITIAL_TEAM = 0, + GFC_CAF_PARENT_TEAM, + GFC_CAF_CURRENT_TEAM +} libgfortran_team_levels; + +typedef enum +{ GFC_CAF_ATOMIC_ADD = 1, GFC_CAF_ATOMIC_AND, GFC_CAF_ATOMIC_OR, diff --git a/gcc/fortran/match.cc b/gcc/fortran/match.cc index ec9e587..8355a39 100644 --- a/gcc/fortran/match.cc +++ b/gcc/fortran/match.cc @@ -1814,12 +1814,53 @@ gfc_free_iterator (gfc_iterator *iter, int flag) free (iter); } +static match +match_named_arg (const char *pat, const char *name, gfc_expr **e, + gfc_statement st_code) +{ + match m; + gfc_expr *tmp; + + m = gfc_match (pat, &tmp); + if (m == MATCH_ERROR) + { + gfc_syntax_error (st_code); + return m; + } + if (m == MATCH_YES) + { + if (*e) + { + gfc_error ("Duplicate %s attribute in %C", name); + gfc_free_expr (tmp); + return MATCH_ERROR; + } + *e = tmp; + + return MATCH_YES; + } + return MATCH_NO; +} + +static match +match_stat_errmsg (struct sync_stat *sync_stat, gfc_statement st_code) +{ + match m; + + m = match_named_arg (" stat = %v", "STAT", &sync_stat->stat, st_code); + if (m != MATCH_NO) + return m; + + m = match_named_arg (" errmsg = %v", "ERRMSG", &sync_stat->errmsg, st_code); + return m; +} /* Match a CRITICAL statement. */ match gfc_match_critical (void) { gfc_st_label *label = NULL; + match m; if (gfc_match_label () == MATCH_ERROR) return MATCH_ERROR; @@ -1830,12 +1871,29 @@ gfc_match_critical (void) if (gfc_match_st_label (&label) == MATCH_ERROR) return MATCH_ERROR; - if (gfc_match_eos () != MATCH_YES) + if (gfc_match_eos () == MATCH_YES) + goto done; + + if (gfc_match_char ('(') != MATCH_YES) + goto syntax; + + for (;;) { - gfc_syntax_error (ST_CRITICAL); - return MATCH_ERROR; + m = match_stat_errmsg (&new_st.ext.sync_stat, ST_CRITICAL); + if (m == MATCH_ERROR) + goto cleanup; + + if (gfc_match_char (',') == MATCH_YES) + continue; + + break; } + if (gfc_match (" )%t") != MATCH_YES) + goto syntax; + +done: + if (gfc_pure (NULL)) { gfc_error ("Image control statement CRITICAL at %C in PURE procedure"); @@ -1856,9 +1914,9 @@ gfc_match_critical (void) if (flag_coarray == GFC_FCOARRAY_NONE) { - gfc_fatal_error ("Coarrays disabled at %C, use %<-fcoarray=%> to " - "enable"); - return MATCH_ERROR; + gfc_fatal_error ("Coarrays disabled at %C, use %<-fcoarray=%> to " + "enable"); + return MATCH_ERROR; } if (gfc_find_state (COMP_CRITICAL)) @@ -1869,13 +1927,21 @@ gfc_match_critical (void) new_st.op = EXEC_CRITICAL; - if (label != NULL - && !gfc_reference_st_label (label, ST_LABEL_TARGET)) - return MATCH_ERROR; + if (label != NULL && !gfc_reference_st_label (label, ST_LABEL_TARGET)) + goto cleanup; return MATCH_YES; -} +syntax: + gfc_syntax_error (ST_CRITICAL); + +cleanup: + gfc_free_expr (new_st.ext.sync_stat.stat); + gfc_free_expr (new_st.ext.sync_stat.errmsg); + new_st.ext.sync_stat = {NULL, NULL}; + + return MATCH_ERROR; +} /* Match a BLOCK statement. */ @@ -1900,29 +1966,29 @@ gfc_match_block (void) return MATCH_YES; } - -/* Match an ASSOCIATE statement. */ - -match -gfc_match_associate (void) +bool +check_coarray_assoc (const char *name, gfc_association_list *assoc) { - if (gfc_match_label () == MATCH_ERROR) - return MATCH_ERROR; - - if (gfc_match (" associate") != MATCH_YES) - return MATCH_NO; - - /* Match the association list. */ - if (gfc_match_char ('(') != MATCH_YES) + if (assoc->target->expr_type == EXPR_VARIABLE + && !strcmp (assoc->target->symtree->name, name)) { - gfc_error ("Expected association list at %C"); - return MATCH_ERROR; + gfc_error ("Codimension decl name %qs in association at %L " + "must not be the same as a selector", + name, &assoc->where); + return false; } + return true; +} + +match +match_association_list (bool for_change_team = false) +{ new_st.ext.block.assoc = NULL; while (true) { - gfc_association_list* newAssoc = gfc_get_association_list (); - gfc_association_list* a; + gfc_association_list *newAssoc = gfc_get_association_list (); + gfc_association_list *a; + locus pre_name = gfc_current_locus; /* Match the next association. */ if (gfc_match (" %n ", newAssoc->name) != MATCH_YES) @@ -1932,7 +1998,7 @@ gfc_match_associate (void) } /* Required for an assumed rank target. */ - if (gfc_peek_char () == '(') + if (!for_change_team && gfc_peek_char () == '(') { newAssoc->ar = gfc_get_array_ref (); if (gfc_match_array_ref (newAssoc->ar, NULL, 0, 0) != MATCH_YES) @@ -1946,26 +2012,53 @@ gfc_match_associate (void) gfc_error_now ("The bounds remapping list at %C is an experimental " "F202y feature. Use std=f202y to enable"); + if (for_change_team && gfc_peek_char () == '[') + { + if (!newAssoc->ar) + newAssoc->ar = gfc_get_array_ref (); + if (gfc_match_array_spec (&newAssoc->ar->as, false, true) + == MATCH_ERROR) + goto assocListError; + } + /* Match the next association. */ if (gfc_match (" =>", newAssoc->name) != MATCH_YES) { - gfc_error ("Expected association at %C"); - goto assocListError; + if (for_change_team) + gfc_current_locus = pre_name; + + free (newAssoc); + return MATCH_NO; } - if (gfc_match (" %e", &newAssoc->target) != MATCH_YES) + if (!for_change_team) { - /* Have another go, allowing for procedure pointer selectors. */ - gfc_matching_procptr_assignment = 1; if (gfc_match (" %e", &newAssoc->target) != MATCH_YES) { + /* Have another go, allowing for procedure pointer selectors. */ + gfc_matching_procptr_assignment = 1; + if (gfc_match (" %e", &newAssoc->target) != MATCH_YES) + { + gfc_matching_procptr_assignment = 0; + gfc_error ("Invalid association target at %C"); + goto assocListError; + } gfc_matching_procptr_assignment = 0; - gfc_error ("Invalid association target at %C"); + } + newAssoc->where = gfc_current_locus; + } + else + { + newAssoc->where = gfc_current_locus; + /* F2018, C1116: A selector in a coarray-association shall be a named + coarray. */ + if (gfc_match (" %v", &newAssoc->target) != MATCH_YES) + { + gfc_error ("Selector in coarray association as %C shall be a " + "named coarray"); goto assocListError; } - gfc_matching_procptr_assignment = 0; } - newAssoc->where = gfc_current_locus; /* Check that the current name is not yet in the list. */ for (a = new_st.ext.block.assoc; a; a = a->next) @@ -1976,6 +2069,35 @@ gfc_match_associate (void) goto assocListError; } + if (for_change_team) + { + /* F2018, C1113: In a change-team-stmt, a coarray-name in a + codimension-decl shall not be the same as a selector, or another + coarray-name, in that statement. + The latter is already checked for above. So check only the + former. + */ + if (!check_coarray_assoc (newAssoc->name, newAssoc)) + goto assocListError; + + for (a = new_st.ext.block.assoc; a; a = a->next) + { + if (!check_coarray_assoc (newAssoc->name, a) + || !check_coarray_assoc (a->name, newAssoc)) + goto assocListError; + + /* F2018, C1115: No selector shall appear more than once in a + * given change-team-stmt. */ + if (!strcmp (newAssoc->target->symtree->name, + a->target->symtree->name)) + { + gfc_error ("Selector at %L duplicates selector at %L", + &newAssoc->target->where, &a->target->where); + goto assocListError; + } + } + } + /* The target expression must not be coindexed. */ if (gfc_is_coindexed (newAssoc->target)) { @@ -2042,8 +2164,40 @@ gfc_match_associate (void) assocListError: free (newAssoc); + return MATCH_ERROR; + } + + return MATCH_YES; +} + +/* Match an ASSOCIATE statement. */ + +match +gfc_match_associate (void) +{ + match m; + if (gfc_match_label () == MATCH_ERROR) + return MATCH_ERROR; + + if (gfc_match (" associate") != MATCH_YES) + return MATCH_NO; + + /* Match the association list. */ + if (gfc_match_char ('(') != MATCH_YES) + { + gfc_error ("Expected association list at %C"); + return MATCH_ERROR; + } + + m = match_association_list (); + if (m == MATCH_ERROR) + goto error; + else if (m == MATCH_NO) + { + gfc_error ("Expected association at %C"); goto error; } + if (gfc_match_char (')') != MATCH_YES) { /* This should never happen as we peek above. */ @@ -2738,7 +2892,7 @@ gfc_match_do (void) locus where = gfc_current_locus; if (gfc_match_eos () == MATCH_YES) - break; + goto concurr_ok; else if (gfc_match ("local ( ") == MATCH_YES) { @@ -2987,6 +3141,7 @@ gfc_match_do (void) if (gfc_match_eos () != MATCH_YES) goto concurr_cleanup; +concurr_ok: if (label != NULL && !gfc_reference_st_label (label, ST_LABEL_DO_TARGET)) goto concurr_cleanup; @@ -3171,6 +3326,7 @@ match_exit_cycle (gfc_statement st, gfc_exec_op op) case COMP_ASSOCIATE: case COMP_BLOCK: + case COMP_CHANGE_TEAM: case COMP_IF: case COMP_SELECT: case COMP_SELECT_TYPE: @@ -3848,7 +4004,9 @@ match gfc_match_form_team (void) { match m; - gfc_expr *teamid,*team; + gfc_expr *teamid, *team, *new_index; + + teamid = team = new_index = NULL; if (!gfc_notify_std (GFC_STD_F2018, "FORM TEAM statement at %C")) return MATCH_ERROR; @@ -3866,18 +4024,61 @@ gfc_match_form_team (void) if (gfc_match ("%e", &team) != MATCH_YES) goto syntax; - m = gfc_match_char (')'); + m = gfc_match_char (','); + if (m == MATCH_ERROR) + goto syntax; if (m == MATCH_NO) + { + m = gfc_match_char (')'); + if (m == MATCH_YES) + goto done; + goto syntax; + } + + for (;;) + { + m = match_stat_errmsg (&new_st.ext.sync_stat, ST_FORM_TEAM); + if (m == MATCH_ERROR) + goto cleanup; + + m = match_named_arg (" new_index = %e", "NEW_INDEX", &new_index, + ST_FORM_TEAM); + if (m == MATCH_ERROR) + goto cleanup; + + m = gfc_match_char (','); + if (m == MATCH_YES) + continue; + + break; + } + + if (m == MATCH_ERROR) + goto syntax; + + if (gfc_match (" )%t") != MATCH_YES) goto syntax; +done: + new_st.expr1 = teamid; new_st.expr2 = team; + new_st.expr3 = new_index; return MATCH_YES; syntax: gfc_syntax_error (ST_FORM_TEAM); +cleanup: + gfc_free_expr (new_index); + gfc_free_expr (new_st.ext.sync_stat.stat); + gfc_free_expr (new_st.ext.sync_stat.errmsg); + new_st.ext.sync_stat = {NULL, NULL}; + + gfc_free_expr (team); + gfc_free_expr (teamid); + return MATCH_ERROR; } @@ -3887,7 +4088,13 @@ match gfc_match_change_team (void) { match m; - gfc_expr *team; + gfc_expr *team = NULL; + + if (gfc_match_label () == MATCH_ERROR) + return MATCH_ERROR; + + if (gfc_match (" change% team") != MATCH_YES) + return MATCH_NO; if (!gfc_notify_std (GFC_STD_F2018, "CHANGE TEAM statement at %C")) return MATCH_ERROR; @@ -3895,15 +4102,41 @@ gfc_match_change_team (void) if (gfc_match_char ('(') == MATCH_NO) goto syntax; - new_st.op = EXEC_CHANGE_TEAM; - if (gfc_match ("%e", &team) != MATCH_YES) goto syntax; - m = gfc_match_char (')'); + m = gfc_match_char (','); + if (m == MATCH_ERROR) + goto syntax; if (m == MATCH_NO) + { + m = gfc_match_char (')'); + if (m == MATCH_YES) + goto done; + goto syntax; + } + + m = match_association_list (true); + if (m == MATCH_ERROR) + goto cleanup; + else if (m == MATCH_NO) + for (;;) + { + m = match_stat_errmsg (&new_st.ext.block.sync_stat, ST_CHANGE_TEAM); + if (m == MATCH_ERROR) + goto cleanup; + + if (gfc_match_char (',') == MATCH_YES) + continue; + + break; + } + + if (gfc_match (" )%t") != MATCH_YES) goto syntax; +done: + new_st.expr1 = team; return MATCH_YES; @@ -3911,20 +4144,49 @@ gfc_match_change_team (void) syntax: gfc_syntax_error (ST_CHANGE_TEAM); +cleanup: + gfc_free_expr (new_st.ext.block.sync_stat.stat); + gfc_free_expr (new_st.ext.block.sync_stat.errmsg); + new_st.ext.block.sync_stat = {NULL, NULL}; + gfc_free_association_list (new_st.ext.block.assoc); + new_st.ext.block.assoc = NULL; + gfc_free_expr (team); + return MATCH_ERROR; } -/* Match a END TEAM statement. */ +/* Match an END TEAM statement. */ match gfc_match_end_team (void) { - if (!gfc_notify_std (GFC_STD_F2018, "END TEAM statement at %C")) - return MATCH_ERROR; + if (gfc_match_eos () == MATCH_YES) + goto done; - if (gfc_match_char ('(') == MATCH_YES) + if (gfc_match_char ('(') != MATCH_YES) + { + /* There could be a team-construct-name following. Let caller decide + about error. */ + new_st.op = EXEC_END_TEAM; + return MATCH_NO; + } + + for (;;) + { + if (match_stat_errmsg (&new_st.ext.sync_stat, ST_END_TEAM) == MATCH_ERROR) + goto cleanup; + + if (gfc_match_char (',') == MATCH_YES) + continue; + + break; + } + + if (gfc_match_char (')') != MATCH_YES) goto syntax; +done: + new_st.op = EXEC_END_TEAM; return MATCH_YES; @@ -3932,6 +4194,14 @@ gfc_match_end_team (void) syntax: gfc_syntax_error (ST_END_TEAM); +cleanup: + gfc_free_expr (new_st.ext.sync_stat.stat); + gfc_free_expr (new_st.ext.sync_stat.errmsg); + new_st.ext.sync_stat = {NULL, NULL}; + + /* Try to match the closing bracket to allow error recovery. */ + gfc_match_char (')'); + return MATCH_ERROR; } @@ -3941,7 +4211,7 @@ match gfc_match_sync_team (void) { match m; - gfc_expr *team; + gfc_expr *team = NULL; if (!gfc_notify_std (GFC_STD_F2018, "SYNC TEAM statement at %C")) return MATCH_ERROR; @@ -3954,10 +4224,34 @@ gfc_match_sync_team (void) if (gfc_match ("%e", &team) != MATCH_YES) goto syntax; - m = gfc_match_char (')'); + m = gfc_match_char (','); + if (m == MATCH_ERROR) + goto syntax; if (m == MATCH_NO) + { + m = gfc_match_char (')'); + if (m == MATCH_YES) + goto done; + goto syntax; + } + + for (;;) + { + m = match_stat_errmsg (&new_st.ext.sync_stat, ST_SYNC_TEAM); + if (m == MATCH_ERROR) + goto cleanup; + + if (gfc_match_char (',') == MATCH_YES) + continue; + + break; + } + + if (gfc_match (" )%t") != MATCH_YES) goto syntax; +done: + new_st.expr1 = team; return MATCH_YES; @@ -3965,6 +4259,13 @@ gfc_match_sync_team (void) syntax: gfc_syntax_error (ST_SYNC_TEAM); +cleanup: + gfc_free_expr (new_st.ext.sync_stat.stat); + gfc_free_expr (new_st.ext.sync_stat.errmsg); + new_st.ext.sync_stat = {NULL, NULL}; + + gfc_free_expr (team); + return MATCH_ERROR; } @@ -4992,7 +5293,7 @@ match gfc_match_nullify (void) { gfc_code *tail; - gfc_expr *e, *p; + gfc_expr *e, *p = NULL; match m; tail = NULL; @@ -5261,6 +5562,15 @@ gfc_match_return (void) return MATCH_ERROR; } + if (gfc_find_state (COMP_CHANGE_TEAM)) + { + /* F2018, C1111: A RETURN statement shall not appear within a CHANGE TEAM + construct. */ + gfc_error ( + "Image control statement RETURN at %C in CHANGE TEAM-END TEAM block"); + return MATCH_ERROR; + } + if (gfc_match_eos () == MATCH_YES) goto done; @@ -6861,9 +7171,11 @@ select_type_push (gfc_symbol *sel) /* Set the temporary for the current intrinsic SELECT TYPE selector. */ static gfc_symtree * -select_intrinsic_set_tmp (gfc_typespec *ts) +select_intrinsic_set_tmp (gfc_typespec *ts, const char *var_name) { - char name[GFC_MAX_SYMBOL_LEN]; + /* Keep size in sync with the buffer size in resolve_select_type as it + determines the final name through truncation. */ + char name[GFC_MAX_SYMBOL_LEN + 12 + 1]; gfc_symtree *tmp; HOST_WIDE_INT charlen = 0; gfc_symbol *selector = select_type_stack->selector; @@ -6882,12 +7194,12 @@ select_intrinsic_set_tmp (gfc_typespec *ts) charlen = gfc_mpz_get_hwi (ts->u.cl->length->value.integer); if (ts->type != BT_CHARACTER) - sprintf (name, "__tmp_%s_%d", gfc_basic_typename (ts->type), - ts->kind); + snprintf (name, sizeof (name), "__tmp_%s_%d_%s", + gfc_basic_typename (ts->type), ts->kind, var_name); else snprintf (name, sizeof (name), - "__tmp_%s_" HOST_WIDE_INT_PRINT_DEC "_%d", - gfc_basic_typename (ts->type), charlen, ts->kind); + "__tmp_%s_" HOST_WIDE_INT_PRINT_DEC "_%d_%s", + gfc_basic_typename (ts->type), charlen, ts->kind, var_name); gfc_get_sym_tree (name, gfc_current_ns, &tmp, false); sym = tmp->n.sym; @@ -6929,7 +7241,9 @@ select_type_set_tmp (gfc_typespec *ts) return; } - tmp = select_intrinsic_set_tmp (ts); + gfc_expr *select_type_expr = gfc_state_stack->construct->expr1; + const char *var_name = gfc_var_name_for_select_type_temp (select_type_expr); + tmp = select_intrinsic_set_tmp (ts, var_name); if (tmp == NULL) { @@ -6937,9 +7251,11 @@ select_type_set_tmp (gfc_typespec *ts) return; if (ts->type == BT_CLASS) - sprintf (name, "__tmp_class_%s", ts->u.derived->name); + snprintf (name, sizeof (name), "__tmp_class_%s_%s", ts->u.derived->name, + var_name); else - sprintf (name, "__tmp_type_%s", ts->u.derived->name); + snprintf (name, sizeof (name), "__tmp_type_%s_%s", ts->u.derived->name, + var_name); gfc_get_sym_tree (name, gfc_current_ns, &tmp, false); sym = tmp->n.sym; diff --git a/gcc/fortran/mathbuiltins.def b/gcc/fortran/mathbuiltins.def index 2d475a2..bdc9058 100644 --- a/gcc/fortran/mathbuiltins.def +++ b/gcc/fortran/mathbuiltins.def @@ -23,34 +23,41 @@ along with GCC; see the file COPYING3. If not see Use DEFINE_MATH_BUILTIN_C if the complex versions of the builtin are also available. */ -DEFINE_MATH_BUILTIN_C (ACOS, "acos", 0) -DEFINE_MATH_BUILTIN_C (ACOSH, "acosh", 0) -DEFINE_MATH_BUILTIN_C (ASIN, "asin", 0) -DEFINE_MATH_BUILTIN_C (ASINH, "asinh", 0) -DEFINE_MATH_BUILTIN_C (ATAN, "atan", 0) -DEFINE_MATH_BUILTIN_C (ATANH, "atanh", 0) -DEFINE_MATH_BUILTIN (ATAN2, "atan2", 1) -DEFINE_MATH_BUILTIN_C (COS, "cos", 0) -DEFINE_MATH_BUILTIN_C (COSH, "cosh", 0) -DEFINE_MATH_BUILTIN_C (EXP, "exp", 0) -DEFINE_MATH_BUILTIN_C (LOG, "log", 0) -DEFINE_MATH_BUILTIN_C (LOG10, "log10", 0) -DEFINE_MATH_BUILTIN_C (SIN, "sin", 0) -DEFINE_MATH_BUILTIN_C (SINH, "sinh", 0) -DEFINE_MATH_BUILTIN_C (SQRT, "sqrt", 0) -DEFINE_MATH_BUILTIN_C (TAN, "tan", 0) -DEFINE_MATH_BUILTIN_C (TANH, "tanh", 0) -DEFINE_MATH_BUILTIN (J0, "j0", 0) -DEFINE_MATH_BUILTIN (J1, "j1", 0) -DEFINE_MATH_BUILTIN (JN, "jn", 5) -DEFINE_MATH_BUILTIN (Y0, "y0", 0) -DEFINE_MATH_BUILTIN (Y1, "y1", 0) -DEFINE_MATH_BUILTIN (YN, "yn", 5) -DEFINE_MATH_BUILTIN (ERF, "erf", 0) -DEFINE_MATH_BUILTIN (ERFC, "erfc", 0) -DEFINE_MATH_BUILTIN (TGAMMA,"tgamma", 0) -DEFINE_MATH_BUILTIN (LGAMMA,"lgamma", 0) -DEFINE_MATH_BUILTIN (HYPOT, "hypot", 1) +DEFINE_MATH_BUILTIN_C (ACOS, "acos", 0) +DEFINE_MATH_BUILTIN_C (ACOSH, "acosh", 0) +DEFINE_MATH_BUILTIN (ACOSPI, "acospi", 0) +DEFINE_MATH_BUILTIN_C (ASIN, "asin", 0) +DEFINE_MATH_BUILTIN_C (ASINH, "asinh", 0) +DEFINE_MATH_BUILTIN (ASINPI, "asinpi", 0) +DEFINE_MATH_BUILTIN_C (ATAN, "atan", 0) +DEFINE_MATH_BUILTIN (ATAN2, "atan2", 1) +DEFINE_MATH_BUILTIN (ATAN2PI, "atan2pi", 1) +DEFINE_MATH_BUILTIN_C (ATANH, "atanh", 0) +DEFINE_MATH_BUILTIN (ATANPI, "atanpi", 0) +DEFINE_MATH_BUILTIN_C (COS, "cos", 0) +DEFINE_MATH_BUILTIN_C (COSH, "cosh", 0) +DEFINE_MATH_BUILTIN (COSPI, "cospi", 0) +DEFINE_MATH_BUILTIN (ERF, "erf", 0) +DEFINE_MATH_BUILTIN (ERFC, "erfc", 0) +DEFINE_MATH_BUILTIN_C (EXP, "exp", 0) +DEFINE_MATH_BUILTIN (HYPOT, "hypot", 1) +DEFINE_MATH_BUILTIN (J0, "j0", 0) +DEFINE_MATH_BUILTIN (J1, "j1", 0) +DEFINE_MATH_BUILTIN (JN, "jn", 5) +DEFINE_MATH_BUILTIN (LGAMMA, "lgamma", 0) +DEFINE_MATH_BUILTIN_C (LOG, "log", 0) +DEFINE_MATH_BUILTIN_C (LOG10, "log10", 0) +DEFINE_MATH_BUILTIN_C (SIN, "sin", 0) +DEFINE_MATH_BUILTIN_C (SINH, "sinh", 0) +DEFINE_MATH_BUILTIN (SINPI, "sinpi", 0) +DEFINE_MATH_BUILTIN_C (SQRT, "sqrt", 0) +DEFINE_MATH_BUILTIN_C (TAN, "tan", 0) +DEFINE_MATH_BUILTIN_C (TANH, "tanh", 0) +DEFINE_MATH_BUILTIN (TANPI, "tanpi", 0) +DEFINE_MATH_BUILTIN (TGAMMA, "tgamma", 0) +DEFINE_MATH_BUILTIN (Y0, "y0", 0) +DEFINE_MATH_BUILTIN (Y1, "y1", 0) +DEFINE_MATH_BUILTIN (YN, "yn", 5) /* OTHER_BUILTIN (CODE, NAME, PROTOTYPE_TYPE, CONST) For floating-point builtins that do not directly correspond to a diff --git a/gcc/fortran/misc.cc b/gcc/fortran/misc.cc index 893c40f..2339306 100644 --- a/gcc/fortran/misc.cc +++ b/gcc/fortran/misc.cc @@ -214,6 +214,9 @@ gfc_typename (gfc_typespec *ts, bool for_hash) case BT_UNKNOWN: strcpy (buffer, "UNKNOWN"); break; + case BT_VOID: + strcpy (buffer, "VOID"); + break; default: gfc_internal_error ("gfc_typename(): Undefined type"); } @@ -469,3 +472,24 @@ gfc_mpz_set_hwi (mpz_t rop, const HOST_WIDE_INT op) const wide_int w = wi::shwi (op, HOST_BITS_PER_WIDE_INT); wi::to_mpz (w, rop, SIGNED); } + + +/* Extract a name suitable for use in the name of the select type temporary + variable. We pick the last component name in the data reference if there + is one, otherwise the user variable name, and return the empty string by + default. */ + +const char * +gfc_var_name_for_select_type_temp (gfc_expr *e) +{ + const char *name = ""; + if (e->symtree) + name = e->symtree->name; + for (gfc_ref *r = e->ref; r; r = r->next) + if (r->type == REF_COMPONENT + && !(strcmp (r->u.c.component->name, "_data") == 0 + || strcmp (r->u.c.component->name, "_vptr") == 0)) + name = r->u.c.component->name; + + return name; +} diff --git a/gcc/fortran/openmp.cc b/gcc/fortran/openmp.cc index 905980a..fe0a47a 100644 --- a/gcc/fortran/openmp.cc +++ b/gcc/fortran/openmp.cc @@ -1588,7 +1588,7 @@ gfc_match_omp_clause_reduction (char pc, gfc_omp_clauses *c, bool openacc, { gfc_omp_namelist *p = gfc_get_omp_namelist (), **tl; p->sym = n->sym; - p->where = p->where; + p->where = n->where; p->u.map.op = OMP_MAP_ALWAYS_TOFROM; tl = &c->lists[OMP_LIST_MAP]; @@ -2138,10 +2138,8 @@ gfc_match_omp_prefer_type (char **type_str, int *type_str_len) the 'interop' directive and the 'append_args' directive of 'declare variant'. [prefer_type(...)][,][<target|targetsync>, ...]) - If is_init_clause, there might be no modifiers but variables like 'target'; - additionally, the modifier parsing ends with a ':'. - If not is_init_clause (i.e. append_args), there must be modifiers and the - parsing ends with ')'. */ + If is_init_clause, the modifier parsing ends with a ':'. + If not is_init_clause (i.e. append_args), the parsing ends with ')'. */ static match gfc_parser_omp_clause_init_modifiers (bool &target, bool &targetsync, @@ -2153,9 +2151,10 @@ gfc_parser_omp_clause_init_modifiers (bool &target, bool &targetsync, *type_str = NULL; type_str_len = 0; match m; - locus old_loc = gfc_current_locus; - do { - if (gfc_match ("prefer_type ( ") == MATCH_YES) + + do + { + if (gfc_match ("prefer_type ( ") == MATCH_YES) { if (*type_str) { @@ -2181,12 +2180,17 @@ gfc_parser_omp_clause_init_modifiers (bool &target, bool &targetsync, } return MATCH_ERROR; } - if (gfc_match ("targetsync ") == MATCH_YES) + + if (gfc_match ("prefer_type ") == MATCH_YES) + { + gfc_error ("Expected %<(%> after %<prefer_type%> at %C"); + return MATCH_ERROR; + } + + if (gfc_match ("targetsync ") == MATCH_YES) { if (targetsync) { - /* Avoid the word 'modifier' as it could be also be no clauses and - twice a variable named 'targetsync', which is also invalid. */ gfc_error ("Duplicate %<targetsync%> at %C"); return MATCH_ERROR; } @@ -2202,13 +2206,6 @@ gfc_parser_omp_clause_init_modifiers (bool &target, bool &targetsync, } if (gfc_match (": ") == MATCH_YES) break; - gfc_char_t c = gfc_peek_char (); - if (!*type_str && (c == ')' || (gfc_current_form != FORM_FREE - && (c == '_' || ISALPHA (c))))) - { - gfc_current_locus = old_loc; - break; - } gfc_error ("Expected %<,%> or %<:%> at %C"); return MATCH_ERROR; } @@ -2231,25 +2228,21 @@ gfc_parser_omp_clause_init_modifiers (bool &target, bool &targetsync, } if (gfc_match (": ") == MATCH_YES) break; - gfc_char_t c = gfc_peek_char (); - if (!*type_str && (c == ')' || (gfc_current_form != FORM_FREE - && (c == '_' || ISALPHA (c))))) - { - gfc_current_locus = old_loc; - break; - } gfc_error ("Expected %<,%> or %<:%> at %C"); return MATCH_ERROR; } - if (*type_str) - { - gfc_error ("Expected %<target%> or %<targetsync%> at %C"); - return MATCH_ERROR; - } - gfc_current_locus = old_loc; - break; + gfc_error ("Expected %<prefer_type%>, %<target%>, or %<targetsync%> " + "at %C"); + return MATCH_ERROR; } while (true); + + if (!target && !targetsync) + { + gfc_error ("Missing required %<target%> and/or %<targetsync%> " + "modifier at %C"); + return MATCH_ERROR; + } return MATCH_YES; } @@ -2266,17 +2259,17 @@ gfc_match_omp_init (gfc_omp_namelist **list) type_str_len, true) == MATCH_ERROR) return MATCH_ERROR; - gfc_omp_namelist **head = NULL; - if (gfc_match_omp_variable_list ("", list, false, NULL, &head) != MATCH_YES) - return MATCH_ERROR; - for (gfc_omp_namelist *n = *head; n; n = n->next) - { - n->u.init.target = target; - n->u.init.targetsync = targetsync; - n->u.init.len = type_str_len; - n->u2.init_interop = type_str; - } - return MATCH_YES; + gfc_omp_namelist **head = NULL; + if (gfc_match_omp_variable_list ("", list, false, NULL, &head) != MATCH_YES) + return MATCH_ERROR; + for (gfc_omp_namelist *n = *head; n; n = n->next) + { + n->u.init.target = target; + n->u.init.targetsync = targetsync; + n->u.init.len = type_str_len; + n->u2.init_interop = type_str; + } + return MATCH_YES; } @@ -4481,7 +4474,7 @@ error: | OMP_CLAUSE_COPYOUT | OMP_CLAUSE_DELETE | OMP_CLAUSE_FINALIZE \ | OMP_CLAUSE_DETACH) #define OACC_WAIT_CLAUSES \ - omp_mask (OMP_CLAUSE_ASYNC) + omp_mask (OMP_CLAUSE_ASYNC) | OMP_CLAUSE_IF #define OACC_ROUTINE_CLAUSES \ (omp_mask (OMP_CLAUSE_GANG) | OMP_CLAUSE_WORKER | OMP_CLAUSE_VECTOR \ | OMP_CLAUSE_SEQ \ @@ -9688,22 +9681,6 @@ resolve_omp_clauses (gfc_code *code, gfc_omp_clauses *omp_clauses, && n->sym->as->type == AS_ASSUMED_SIZE) gfc_error ("Assumed size array %qs in %s clause at %L", n->sym->name, name, &n->where); - if (!openacc - && list == OMP_LIST_MAP - && n->sym->ts.type == BT_DERIVED - && n->sym->ts.u.derived->attr.alloc_comp) - gfc_error ("List item %qs with allocatable components is not " - "permitted in map clause at %L", n->sym->name, - &n->where); - if (!openacc - && (list == OMP_LIST_MAP - || list == OMP_LIST_FROM - || list == OMP_LIST_TO) - && ((n->expr && n->expr->ts.type == BT_CLASS) - || (!n->expr && n->sym->ts.type == BT_CLASS))) - gfc_warning (OPT_Wopenmp, - "Mapping polymorphic list item at %L is " - "unspecified behavior", &n->where); if (list == OMP_LIST_MAP && !openacc) switch (code->op) { @@ -10015,9 +9992,11 @@ resolve_omp_clauses (gfc_code *code, gfc_omp_clauses *omp_clauses, n->sym->name, name, &n->where); if (!openacc - && list == OMP_LIST_FIRSTPRIVATE - && ((n->expr && n->expr->ts.type == BT_CLASS) - || (!n->expr && n->sym->ts.type == BT_CLASS))) + && (list == OMP_LIST_PRIVATE + || list == OMP_LIST_FIRSTPRIVATE) + && ((n->sym->ts.type == BT_DERIVED + && n->sym->ts.u.derived->attr.alloc_comp) + || n->sym->ts.type == BT_CLASS)) switch (code->op) { case EXEC_OMP_TARGET: @@ -10032,9 +10011,19 @@ resolve_omp_clauses (gfc_code *code, gfc_omp_clauses *omp_clauses, case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD: case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_SIMD: case EXEC_OMP_TARGET_TEAMS_LOOP: - gfc_warning (OPT_Wopenmp, - "FIRSTPRIVATE with polymorphic list item at " - "%L is unspecified behavior", &n->where); + if (n->sym->ts.type == BT_DERIVED + && n->sym->ts.u.derived->attr.alloc_comp) + gfc_error ("Sorry, list item %qs at %L with allocatable" + " components is not yet supported in %s " + "clause", n->sym->name, &n->where, + list == OMP_LIST_PRIVATE ? "PRIVATE" + : "FIRSTPRIVATE"); + else + gfc_error ("Polymorphic list item %qs at %L in %s " + "clause has unspecified behavior and " + "unsupported", n->sym->name, &n->where, + list == OMP_LIST_PRIVATE ? "PRIVATE" + : "FIRSTPRIVATE"); break; default: break; diff --git a/gcc/fortran/options.cc b/gcc/fortran/options.cc index ddddc1c..d3c9066 100644 --- a/gcc/fortran/options.cc +++ b/gcc/fortran/options.cc @@ -883,6 +883,10 @@ gfc_handle_option (size_t scode, const char *arg, HOST_WIDE_INT value, return false; /* Not supported. */ if (!strcmp ("omp_is_initial_device", arg)) gfc_option.disable_omp_is_initial_device = true; + else if (!strcmp ("omp_get_initial_device", arg)) + gfc_option.disable_omp_get_initial_device = true; + else if (!strcmp ("omp_get_num_devices", arg)) + gfc_option.disable_omp_get_num_devices = true; else if (!strcmp ("acc_on_device", arg)) gfc_option.disable_acc_on_device = true; else diff --git a/gcc/fortran/parse.cc b/gcc/fortran/parse.cc index a95bb62..8d4ca39 100644 --- a/gcc/fortran/parse.cc +++ b/gcc/fortran/parse.cc @@ -27,6 +27,9 @@ along with GCC; see the file COPYING3. If not see #include "match.h" #include "parse.h" #include "tree-core.h" +#include "tree.h" +#include "fold-const.h" +#include "tree-hash-traits.h" #include "omp-general.h" /* Current statement label. Zero means no statement label. Because new_st @@ -488,6 +491,7 @@ decode_statement (void) match (NULL, gfc_match_do, ST_DO); match (NULL, gfc_match_block, ST_BLOCK); match (NULL, gfc_match_associate, ST_ASSOCIATE); + match (NULL, gfc_match_change_team, ST_CHANGE_TEAM); match (NULL, gfc_match_critical, ST_CRITICAL); match (NULL, gfc_match_select, ST_SELECT_CASE); match (NULL, gfc_match_select_type, ST_SELECT_TYPE); @@ -517,7 +521,6 @@ decode_statement (void) case 'c': match ("call", gfc_match_call, ST_CALL); - match ("change% team", gfc_match_change_team, ST_CHANGE_TEAM); match ("close", gfc_match_close, ST_CLOSE); match ("continue", gfc_match_continue, ST_CONTINUE); match ("contiguous", gfc_match_contiguous, ST_ATTR_DECL); @@ -537,7 +540,6 @@ decode_statement (void) case 'e': match ("end file", gfc_match_endfile, ST_END_FILE); - match ("end team", gfc_match_end_team, ST_END_TEAM); match ("exit", gfc_match_exit, ST_EXIT); match ("else", gfc_match_else, ST_ELSE); match ("else where", gfc_match_elsewhere, ST_ELSEWHERE); @@ -1927,8 +1929,7 @@ next_statement (void) case ST_OMP_INTEROP: \ case ST_ERROR_STOP: case ST_OMP_SCAN: case ST_SYNC_ALL: \ case ST_SYNC_IMAGES: case ST_SYNC_MEMORY: case ST_LOCK: case ST_UNLOCK: \ - case ST_FORM_TEAM: case ST_CHANGE_TEAM: \ - case ST_END_TEAM: case ST_SYNC_TEAM: \ + case ST_FORM_TEAM: case ST_SYNC_TEAM: \ case ST_EVENT_POST: case ST_EVENT_WAIT: case ST_FAIL_IMAGE: \ case ST_OACC_UPDATE: case ST_OACC_WAIT: case ST_OACC_CACHE: \ case ST_OACC_ENTER_DATA: case ST_OACC_EXIT_DATA @@ -2032,7 +2033,8 @@ next_statement (void) #define case_end case ST_END_BLOCK_DATA: case ST_END_FUNCTION: \ case ST_END_PROGRAM: case ST_END_SUBROUTINE: \ - case ST_END_BLOCK: case ST_END_ASSOCIATE + case ST_END_BLOCK: case ST_END_ASSOCIATE: \ + case ST_END_TEAM /* Push a new state onto the stack. */ @@ -2164,6 +2166,7 @@ check_statement_label (gfc_statement st) case ST_END_CRITICAL: case ST_END_BLOCK: case ST_END_ASSOCIATE: + case ST_END_TEAM: case_executable: case_exec_markers: if (st == ST_ENDDO || st == ST_CONTINUE) @@ -3199,6 +3202,8 @@ accept_statement (gfc_statement st) case ST_ENTRY: case ST_OMP_METADIRECTIVE: case ST_OMP_BEGIN_METADIRECTIVE: + case ST_CHANGE_TEAM: + case ST_END_TEAM: case_executable: case_exec_markers: add_statement (); @@ -3383,6 +3388,8 @@ verify_st_order (st_state *p, gfc_statement st, bool silent) goto order; break; + case ST_CHANGE_TEAM: + case ST_END_TEAM: case_executable: case_exec_markers: if (p->state < ORDER_EXEC) @@ -5238,30 +5245,12 @@ parse_block_construct (void) pop_state (); } - -/* Parse an ASSOCIATE construct. This is essentially a BLOCK construct - behind the scenes with compiler-generated variables. */ - static void -parse_associate (void) +move_associates_to_block () { - gfc_namespace* my_ns; - gfc_state_data s; - gfc_statement st; - gfc_association_list* a; + gfc_association_list *a; gfc_array_spec *as; - gfc_notify_std (GFC_STD_F2003, "ASSOCIATE construct at %C"); - - my_ns = gfc_build_block_ns (gfc_current_ns); - - new_st.op = EXEC_BLOCK; - new_st.ext.block.ns = my_ns; - gcc_assert (new_st.ext.block.assoc); - - /* Add all associate-names as BLOCK variables. Creating them is enough - for now, they'll get their values during trans-* phase. */ - gfc_current_ns = my_ns; for (a = new_st.ext.block.assoc; a; a = a->next) { gfc_symbol *sym, *tsym; @@ -5298,26 +5287,23 @@ parse_associate (void) /* Don’t share the character length information between associate variable and target if the length is not a compile-time constant, - as we don’t want to touch some other character length variable when - we try to initialize the associate variable’s character length - variable. - We do it here rather than later so that expressions referencing the - associate variable will automatically have the correctly setup length - information. If we did it at resolution stage the expressions would - use the original length information, and the variable a new different - one, but only the latter one would be correctly initialized at - translation stage, and the former one would need some additional setup - there. */ - if (sym->ts.type == BT_CHARACTER - && sym->ts.u.cl + as we don’t want to touch some other character length variable + when we try to initialize the associate variable’s character + length variable. We do it here rather than later so that expressions + referencing the associate variable will automatically have the + correctly setup length information. If we did it at resolution stage + the expressions would use the original length information, and the + variable a new different one, but only the latter one would be + correctly initialized at translation stage, and the former one would + need some additional setup there. */ + if (sym->ts.type == BT_CHARACTER && sym->ts.u.cl && !(sym->ts.u.cl->length && sym->ts.u.cl->length->expr_type == EXPR_CONSTANT)) sym->ts.u.cl = gfc_new_charlen (gfc_current_ns, NULL); /* If the function has been parsed, go straight to the result to obtain the expression rank. */ - if (target->expr_type == EXPR_FUNCTION - && target->symtree + if (target->expr_type == EXPR_FUNCTION && target->symtree && target->symtree->n.sym) { tsym = target->symtree->n.sym; @@ -5344,8 +5330,7 @@ parse_associate (void) by calling gfc_resolve_expr because the context is unavailable. However, the references can be resolved and the rank of the target expression set. */ - if (!sym->assoc->inferred_type - && target->ref && gfc_resolve_ref (target) + if (!sym->assoc->inferred_type && target->ref && gfc_resolve_ref (target) && target->expr_type != EXPR_ARRAY && target->expr_type != EXPR_COMPCALL) gfc_expression_rank (target); @@ -5353,13 +5338,12 @@ parse_associate (void) /* Determine whether or not function expressions with unknown type are structure constructors. If so, the function result can be converted to be a derived type. */ - if (target->expr_type == EXPR_FUNCTION - && target->ts.type == BT_UNKNOWN) + if (target->expr_type == EXPR_FUNCTION && target->ts.type == BT_UNKNOWN) { gfc_symbol *derived; /* The derived type has a leading uppercase character. */ gfc_find_symbol (gfc_dt_upper_string (target->symtree->name), - my_ns->parent, 1, &derived); + gfc_current_ns->parent, 1, &derived); if (derived && derived->attr.flavor == FL_DERIVED) { sym->ts.type = BT_DERIVED; @@ -5394,7 +5378,7 @@ parse_associate (void) attr.codimension = as->corank ? 1 : 0; sym->assoc->variable = true; } - else if (rank || corank) + else if (rank || corank) { as = gfc_get_array_spec (); as->type = AS_DEFERRED; @@ -5449,6 +5433,30 @@ parse_associate (void) } gfc_commit_symbols (); } +} + +/* Parse an ASSOCIATE construct. This is essentially a BLOCK construct + behind the scenes with compiler-generated variables. */ + +static void +parse_associate (void) +{ + gfc_namespace* my_ns; + gfc_state_data s; + gfc_statement st; + + gfc_notify_std (GFC_STD_F2003, "ASSOCIATE construct at %C"); + + my_ns = gfc_build_block_ns (gfc_current_ns); + + new_st.op = EXEC_BLOCK; + new_st.ext.block.ns = my_ns; + gcc_assert (new_st.ext.block.assoc); + + /* Add all associate-names as BLOCK variables. Creating them is enough + for now, they'll get their values during trans-* phase. */ + gfc_current_ns = my_ns; + move_associates_to_block (); accept_statement (ST_ASSOCIATE); push_state (&s, COMP_ASSOCIATE, my_ns->proc_name); @@ -5474,6 +5482,49 @@ loop: pop_state (); } +static void +parse_change_team (void) +{ + gfc_namespace *my_ns; + gfc_state_data s; + gfc_statement st; + + gfc_notify_std (GFC_STD_F2018, "CHANGE TEAM construct at %C"); + + my_ns = gfc_build_block_ns (gfc_current_ns); + + new_st.op = EXEC_CHANGE_TEAM; + new_st.ext.block.ns = my_ns; + + /* Add all associate-names as BLOCK variables. Creating them is enough + for now, they'll get their values during trans-* phase. */ + gfc_current_ns = my_ns; + if (new_st.ext.block.assoc) + move_associates_to_block (); + + accept_statement (ST_CHANGE_TEAM); + push_state (&s, COMP_CHANGE_TEAM, my_ns->proc_name); + +loop: + st = parse_executable (ST_NONE); + switch (st) + { + case ST_NONE: + unexpected_eof (); + + case_end: + accept_statement (st); + my_ns->code = gfc_state_stack->head; + break; + + default: + unexpected_statement (st); + goto loop; + } + + gfc_current_ns = gfc_current_ns->parent; + pop_state (); +} /* Parse a DO loop. Note that the ST_CYCLE and ST_EXIT statements are handled inside of parse_executable(), because they aren't really @@ -6576,6 +6627,7 @@ parse_executable (gfc_statement st) case ST_STOP: case ST_ERROR_STOP: case ST_END_SUBROUTINE: + case ST_END_TEAM: case ST_DO: case ST_FORALL: @@ -6615,6 +6667,10 @@ parse_executable (gfc_statement st) parse_associate (); break; + case ST_CHANGE_TEAM: + parse_change_team (); + break; + case ST_IF_BLOCK: parse_if_block (); break; diff --git a/gcc/fortran/parse.h b/gcc/fortran/parse.h index 722e94c..7bf0fa4 100644 --- a/gcc/fortran/parse.h +++ b/gcc/fortran/parse.h @@ -32,7 +32,7 @@ enum gfc_compile_state COMP_DO, COMP_SELECT, COMP_FORALL, COMP_WHERE, COMP_CONTAINS, COMP_ENUM, COMP_SELECT_TYPE, COMP_SELECT_RANK, COMP_OMP_STRUCTURED_BLOCK, COMP_CRITICAL, COMP_DO_CONCURRENT, COMP_OMP_STRICTLY_STRUCTURED_BLOCK, - COMP_OMP_METADIRECTIVE, COMP_OMP_BEGIN_METADIRECTIVE + COMP_OMP_METADIRECTIVE, COMP_OMP_BEGIN_METADIRECTIVE, COMP_CHANGE_TEAM }; /* Stack element for the current compilation state. These structures diff --git a/gcc/fortran/primary.cc b/gcc/fortran/primary.cc index 161d4c2..f0e1fef 100644 --- a/gcc/fortran/primary.cc +++ b/gcc/fortran/primary.cc @@ -2102,10 +2102,18 @@ extend_ref (gfc_expr *primary, gfc_ref *tail) { if (primary->ref == NULL) primary->ref = tail = gfc_get_ref (); + else if (tail == NULL) + { + /* Set tail to end of reference chain. */ + for (gfc_ref *ref = primary->ref; ref; ref = ref->next) + if (ref->next == NULL) + { + tail = ref; + break; + } + } else { - if (tail == NULL) - gfc_internal_error ("extend_ref(): Bad tail"); tail->next = gfc_get_ref (); tail = tail->next; } @@ -2302,9 +2310,22 @@ gfc_match_varspec (gfc_expr *primary, int equiv_flag, bool sub_flag, gfc_array_spec *as; bool coarray_only = sym->attr.codimension && !sym->attr.dimension && sym->ts.type == BT_CHARACTER; + gfc_ref *ref, *strarr = NULL; tail = extend_ref (primary, tail); - tail->type = REF_ARRAY; + if (sym->ts.type == BT_CHARACTER && tail->type == REF_SUBSTRING) + { + gcc_assert (sym->attr.dimension); + /* Find array reference for substrings of character arrays. */ + for (ref = primary->ref; ref && ref->next; ref = ref->next) + if (ref->type == REF_ARRAY && ref->next->type == REF_SUBSTRING) + { + strarr = ref; + break; + } + } + else + tail->type = REF_ARRAY; /* In EQUIVALENCE, we don't know yet whether we are seeing an array, character variable or array of character @@ -2317,7 +2338,8 @@ gfc_match_varspec (gfc_expr *primary, int equiv_flag, bool sub_flag, else as = sym->as; - m = gfc_match_array_ref (&tail->u.ar, as, equiv_flag, as ? as->corank : 0, + ref = strarr ? strarr : tail; + m = gfc_match_array_ref (&ref->u.ar, as, equiv_flag, as ? as->corank : 0, coarray_only); if (m != MATCH_YES) return m; @@ -2483,6 +2505,7 @@ gfc_match_varspec (gfc_expr *primary, int equiv_flag, bool sub_flag, { bool t; gfc_symtree *tbp; + gfc_typespec *ts = &primary->ts; m = gfc_match_name (name); if (m == MATCH_NO) @@ -2490,8 +2513,18 @@ gfc_match_varspec (gfc_expr *primary, int equiv_flag, bool sub_flag, if (m != MATCH_YES) return MATCH_ERROR; + /* For derived type components find typespec of ultimate component. */ + if (ts->type == BT_DERIVED && primary->ref) + { + for (gfc_ref *ref = primary->ref; ref; ref = ref->next) + { + if (ref->type == REF_COMPONENT && ref->u.c.component) + ts = &ref->u.c.component->ts; + } + } + intrinsic = false; - if (primary->ts.type != BT_CLASS && primary->ts.type != BT_DERIVED) + if (ts->type != BT_CLASS && ts->type != BT_DERIVED) { inquiry = is_inquiry_ref (name, &tmp); if (inquiry) @@ -2564,7 +2597,7 @@ gfc_match_varspec (gfc_expr *primary, int equiv_flag, bool sub_flag, return MATCH_ERROR; } else if (tmp->u.i == INQUIRY_LEN - && primary->ts.type != BT_CHARACTER) + && ts->type != BT_CHARACTER) { gfc_error ("The LEN part_ref at %C must be applied " "to a CHARACTER expression"); @@ -2659,6 +2692,11 @@ gfc_match_varspec (gfc_expr *primary, int equiv_flag, bool sub_flag, primary->ref = tmp; else { + /* Find end of reference chain if inquiry reference and tail not + set. */ + if (tail == NULL && inquiry && tmp) + tail = extend_ref (primary, tail); + /* Set by the for loop below for the last component ref. */ gcc_assert (tail != NULL); tail->next = tmp; @@ -2678,6 +2716,9 @@ gfc_match_varspec (gfc_expr *primary, int equiv_flag, bool sub_flag, if (primary->expr_type == EXPR_CONSTANT) goto check_done; + if (primary->ref == NULL) + goto check_done; + switch (tmp->u.i) { case INQUIRY_RE: @@ -2828,6 +2869,7 @@ check_substring: if (substring) primary->ts.u.cl = NULL; + gfc_gobble_whitespace (); if (gfc_peek_ascii_char () == '(') { gfc_error_now ("Unexpected array/substring ref at %C"); @@ -2893,6 +2935,7 @@ gfc_variable_attr (gfc_expr *expr, gfc_typespec *ts) gfc_symbol *sym; gfc_component *comp; bool has_inquiry_part; + bool has_substring_ref = false; if (expr->expr_type != EXPR_VARIABLE && expr->expr_type != EXPR_FUNCTION @@ -2955,7 +2998,12 @@ gfc_variable_attr (gfc_expr *expr, gfc_typespec *ts) has_inquiry_part = false; for (ref = expr->ref; ref; ref = ref->next) - if (ref->type == REF_INQUIRY) + if (ref->type == REF_SUBSTRING) + { + has_substring_ref = true; + optional = false; + } + else if (ref->type == REF_INQUIRY) { has_inquiry_part = true; optional = false; @@ -3003,9 +3051,8 @@ gfc_variable_attr (gfc_expr *expr, gfc_typespec *ts) *ts = comp->ts; /* Don't set the string length if a substring reference follows. */ - if (ts->type == BT_CHARACTER - && ref->next && ref->next->type == REF_SUBSTRING) - ts->u.cl = NULL; + if (ts->type == BT_CHARACTER && has_substring_ref) + ts->u.cl = NULL; } if (comp->ts.type == BT_CLASS) @@ -4266,6 +4313,16 @@ gfc_match_rvalue (gfc_expr **result) return MATCH_ERROR; } + /* Scan for possible inquiry references. */ + if (m == MATCH_YES + && e->expr_type == EXPR_VARIABLE + && gfc_peek_ascii_char () == '%') + { + m = gfc_match_varspec (e, 0, false, false); + if (m == MATCH_NO) + m = MATCH_YES; + } + if (m == MATCH_YES) { e->where = where; @@ -4391,7 +4448,7 @@ match_variable (gfc_expr **result, int equiv_flag, int host_flag) case FL_PROCEDURE: /* Check for a nonrecursive function result variable. */ if (sym->attr.function - && !sym->attr.external + && (!sym->attr.external || sym->abr_modproc_decl) && sym->result == sym && (gfc_is_function_return_value (sym, gfc_current_ns) || (sym->attr.entry diff --git a/gcc/fortran/resolve.cc b/gcc/fortran/resolve.cc index b9c469a..50a6fe7 100644 --- a/gcc/fortran/resolve.cc +++ b/gcc/fortran/resolve.cc @@ -533,7 +533,8 @@ gfc_resolve_formal_arglist (gfc_symbol *proc) } } } - + if (sym) + sym->formal_resolved = 1; gfc_current_ns = orig_current_ns; } @@ -1986,7 +1987,7 @@ resolve_procedure_expression (gfc_expr* expr) if (is_illegal_recursion (sym, gfc_current_ns)) { if (sym->attr.use_assoc && expr->symtree->name[0] == '@') - gfc_warning (0, "Non-RECURSIVE procedure %qs from module %qs is " + gfc_warning (0, "Non-RECURSIVE procedure %qs from module %qs is" " possibly calling itself recursively in procedure %qs. " " Declare it RECURSIVE or use %<-frecursive%>", sym->name, sym->module, gfc_current_ns->proc_name->name); @@ -3190,6 +3191,13 @@ gfc_pure_function (gfc_expr *e, const char **name) || e->value.function.isym->elemental; *name = e->value.function.isym->name; } + else if (e->symtree && e->symtree->n.sym && e->symtree->n.sym->attr.dummy) + { + /* The function has been resolved, but esym is not yet set. + This can happen with functions as dummy argument. */ + pure = e->symtree->n.sym->attr.pure; + *name = e->symtree->n.sym->name; + } else { /* Implicit functions are not pure. */ @@ -3253,14 +3261,30 @@ static bool check_pure_function (gfc_expr *e) gfc_do_concurrent_flag = 0 when the check for an impure function occurs. Check the stack to see if the source code has a nested BLOCK construct. */ + for (stack = cs_base; stack; stack = stack->prev) { - if (stack->current->op == EXEC_BLOCK) saw_block = true; + if (!saw_block && stack->current->op == EXEC_BLOCK) + { + saw_block = true; + continue; + } + if (saw_block && stack->current->op == EXEC_DO_CONCURRENT) { - gfc_error ("Reference to impure function at %L inside a " - "DO CONCURRENT", &e->where); - return false; + bool is_pure; + is_pure = (e->value.function.isym + && (e->value.function.isym->pure + || e->value.function.isym->elemental)) + || (e->value.function.esym + && (e->value.function.esym->attr.pure + || e->value.function.esym->attr.elemental)); + if (!is_pure) + { + gfc_error ("Reference to impure function at %L inside a " + "DO CONCURRENT", &e->where); + return false; + } } } @@ -3449,7 +3473,7 @@ resolve_function (gfc_expr *expr) &expr->where, &sym->formal_at); } } - else + else if (!sym->formal_resolved) { gfc_get_formal_from_actual_arglist (sym, expr->value.function.actual); sym->formal_at = expr->where; @@ -3656,16 +3680,29 @@ pure_subroutine (gfc_symbol *sym, const char *name, locus *loc) /* A BLOCK construct within a DO CONCURRENT construct leads to gfc_do_concurrent_flag = 0 when the check for an impure subroutine - occurs. Check the stack to see if the source code has a nested - BLOCK construct. */ + occurs. Walk up the stack to see if the source code has a nested + construct. */ + for (stack = cs_base; stack; stack = stack->prev) { - if (stack->current->op == EXEC_BLOCK) saw_block = true; + if (stack->current->op == EXEC_BLOCK) + { + saw_block = true; + continue; + } + if (saw_block && stack->current->op == EXEC_DO_CONCURRENT) { - gfc_error ("Subroutine call at %L in a DO CONCURRENT block " - "is not PURE", loc); - return false; + + bool is_pure = true; + is_pure = sym->attr.pure || sym->attr.elemental; + + if (!is_pure) + { + gfc_error ("Subroutine call at %L in a DO CONCURRENT block " + "is not PURE", loc); + return false; + } } } @@ -3997,7 +4034,7 @@ resolve_call (gfc_code *c) &c->loc, &csym->formal_at); } } - else + else if (!csym->formal_resolved) { gfc_get_formal_from_actual_arglist (csym, c->ext.actual); csym->formal_at = c->loc; @@ -4791,7 +4828,8 @@ resolve_operator (gfc_expr *e) if (e->shape == NULL) e->shape = gfc_copy_shape (op2->shape, op2->corank); } - else + else if ((op1->ref && !gfc_ref_this_image (op1->ref)) + || (op2->ref && !gfc_ref_this_image (op2->ref))) { gfc_error ("Inconsistent coranks for operator at %L and %L", &op1->where, &op2->where); @@ -6033,8 +6071,8 @@ gfc_op_rank_conformable (gfc_expr *op1, gfc_expr *op2) gfc_expression_rank (op2); return (op1->rank == 0 || op2->rank == 0 || op1->rank == op2->rank) - && (op1->corank == 0 || op2->corank == 0 - || op1->corank == op2->corank); + && (op1->corank == 0 || op2->corank == 0 || op1->corank == op2->corank + || (!gfc_is_coindexed (op1) && !gfc_is_coindexed (op2))); } /* Resolve a variable expression. */ @@ -8215,7 +8253,7 @@ resolve_locality_spec (gfc_code *code, gfc_namespace *ns) { if (iter->var->symtree->n.sym == sym) { - gfc_error ("Index variable %qs at %L cannot be specified in a" + gfc_error ("Index variable %qs at %L cannot be specified in a " "locality-spec", sym->name, &expr->where); continue; } @@ -8422,13 +8460,6 @@ resolve_locality_spec (gfc_code *code, gfc_namespace *ns) plist = &((*plist)->next); } } - - if (code->ext.concur.locality[LOCALITY_LOCAL] - || code->ext.concur.locality[LOCALITY_LOCAL_INIT]) - { - gfc_error ("Sorry, LOCAL and LOCAL_INIT are not yet supported for " - "%<do concurrent%> constructs at %L", &code->loc); - } } /* Resolve a list of FORALL iterators. The FORALL index-name is constrained @@ -8710,8 +8741,25 @@ static bool conformable_arrays (gfc_expr *e1, gfc_expr *e2) { gfc_ref *tail; + bool scalar; + for (tail = e2->ref; tail && tail->next; tail = tail->next); + /* If MOLD= is present and is not scalar, and the allocate-object has an + explicit-shape-spec, the ranks need not agree. This may be unintended, + so let's emit a warning if -Wsurprising is given. */ + scalar = !tail || tail->type == REF_COMPONENT; + if (e1->mold && e1->rank > 0 + && (scalar || (tail->type == REF_ARRAY && tail->u.ar.type != AR_FULL))) + { + if (scalar || (tail->u.ar.as && e1->rank != tail->u.ar.as->rank)) + gfc_warning (OPT_Wsurprising, "Allocate-object at %L has rank %d " + "but MOLD= expression at %L has rank %d", + &e2->where, scalar ? 0 : tail->u.ar.as->rank, + &e1->where, e1->rank); + return true; + } + /* First compare rank. */ if ((tail && (!tail->u.ar.as || e1->rank != tail->u.ar.as->rank)) || (!tail && e1->rank != e2->rank)) @@ -10772,6 +10820,8 @@ resolve_select_type (gfc_code *code, gfc_namespace *old_ns) ref = gfc_copy_ref (ref); } + gfc_expr *orig_expr1 = code->expr1; + /* Add EXEC_SELECT to switch on type. */ new_st = gfc_get_code (code->op); new_st->expr1 = code->expr1; @@ -10799,7 +10849,6 @@ resolve_select_type (gfc_code *code, gfc_namespace *old_ns) for (body = code->block; body; body = body->block) { gfc_symbol *vtab; - gfc_expr *e; c = body->ext.block.case_list; /* Generate an index integer expression for address of the @@ -10807,6 +10856,7 @@ resolve_select_type (gfc_code *code, gfc_namespace *old_ns) is stored in c->high and is used to resolve intrinsic cases. */ if (c->ts.type != BT_UNKNOWN) { + gfc_expr *e; if (c->ts.type == BT_DERIVED || c->ts.type == BT_CLASS) { vtab = gfc_find_derived_vtab (c->ts.u.derived); @@ -10839,11 +10889,13 @@ resolve_select_type (gfc_code *code, gfc_namespace *old_ns) when this case is actually true, so build a new ASSOCIATE that does precisely this here (instead of using the 'global' one). */ - + const char * var_name = gfc_var_name_for_select_type_temp (orig_expr1); if (c->ts.type == BT_CLASS) - sprintf (name, "__tmp_class_%s", c->ts.u.derived->name); + snprintf (name, sizeof (name), "__tmp_class_%s_%s", + c->ts.u.derived->name, var_name); else if (c->ts.type == BT_DERIVED) - sprintf (name, "__tmp_type_%s", c->ts.u.derived->name); + snprintf (name, sizeof (name), "__tmp_type_%s_%s", + c->ts.u.derived->name, var_name); else if (c->ts.type == BT_CHARACTER) { HOST_WIDE_INT charlen = 0; @@ -10851,12 +10903,13 @@ resolve_select_type (gfc_code *code, gfc_namespace *old_ns) && c->ts.u.cl->length->expr_type == EXPR_CONSTANT) charlen = gfc_mpz_get_hwi (c->ts.u.cl->length->value.integer); snprintf (name, sizeof (name), - "__tmp_%s_" HOST_WIDE_INT_PRINT_DEC "_%d", - gfc_basic_typename (c->ts.type), charlen, c->ts.kind); + "__tmp_%s_" HOST_WIDE_INT_PRINT_DEC "_%d_%s", + gfc_basic_typename (c->ts.type), charlen, c->ts.kind, + var_name); } else - sprintf (name, "__tmp_%s_%d", gfc_basic_typename (c->ts.type), - c->ts.kind); + snprintf (name, sizeof (name), "__tmp_%s_%d_%s", + gfc_basic_typename (c->ts.type), c->ts.kind, var_name); st = gfc_find_symtree (ns->sym_root, name); gcc_assert (st->n.sym->assoc); @@ -11455,6 +11508,109 @@ resolve_lock_unlock_event (gfc_code *code) } } +static void +resolve_team_argument (gfc_expr *team) +{ + gfc_resolve_expr (team); + if (team->rank != 0 || team->ts.type != BT_DERIVED + || team->ts.u.derived->from_intmod != INTMOD_ISO_FORTRAN_ENV + || team->ts.u.derived->intmod_sym_id != ISOFORTRAN_TEAM_TYPE) + { + gfc_error ("TEAM argument at %L must be a scalar expression " + "of type TEAM_TYPE from the intrinsic module ISO_FORTRAN_ENV", + &team->where); + } +} + +static void +resolve_scalar_variable_as_arg (const char *name, bt exp_type, int exp_kind, + gfc_expr *e) +{ + gfc_resolve_expr (e); + if (e + && (e->ts.type != exp_type || e->ts.kind < exp_kind || e->rank != 0 + || e->expr_type != EXPR_VARIABLE)) + gfc_error ("%s argument at %L must be a scalar %s variable of at least " + "kind %d", name, &e->where, gfc_basic_typename (exp_type), + exp_kind); +} + +void +gfc_resolve_sync_stat (struct sync_stat *sync_stat) +{ + resolve_scalar_variable_as_arg ("STAT=", BT_INTEGER, 2, sync_stat->stat); + resolve_scalar_variable_as_arg ("ERRMSG=", BT_CHARACTER, + gfc_default_character_kind, + sync_stat->errmsg); +} + +static void +resolve_scalar_argument (const char *name, bt exp_type, int exp_kind, + gfc_expr *e) +{ + gfc_resolve_expr (e); + if (e + && (e->ts.type != exp_type || e->ts.kind < exp_kind || e->rank != 0)) + gfc_error ("%s argument at %L must be a scalar %s of at least kind %d", + name, &e->where, gfc_basic_typename (exp_type), exp_kind); +} + +static void +resolve_form_team (gfc_code *code) +{ + resolve_scalar_argument ("TEAM NUMBER", BT_INTEGER, gfc_default_integer_kind, + code->expr1); + resolve_team_argument (code->expr2); + resolve_scalar_argument ("NEW_INDEX=", BT_INTEGER, gfc_default_integer_kind, + code->expr3); + gfc_resolve_sync_stat (&code->ext.sync_stat); +} + +static void resolve_block_construct (gfc_code *); + +static void +resolve_change_team (gfc_code *code) +{ + resolve_team_argument (code->expr1); + gfc_resolve_sync_stat (&code->ext.block.sync_stat); + resolve_block_construct (code); + /* Map the coarray bounds as selected. */ + for (gfc_association_list *a = code->ext.block.assoc; a; a = a->next) + if (a->ar) + { + gfc_array_spec *src = a->ar->as, *dst; + if (a->st->n.sym->ts.type == BT_CLASS) + dst = CLASS_DATA (a->st->n.sym)->as; + else + dst = a->st->n.sym->as; + dst->corank = src->corank; + dst->cotype = src->cotype; + for (int i = 0; i < src->corank; ++i) + { + dst->lower[dst->rank + i] = src->lower[i]; + dst->upper[dst->rank + i] = src->upper[i]; + src->lower[i] = src->upper[i] = nullptr; + } + gfc_free_array_spec (src); + free (a->ar); + a->ar = nullptr; + dst->resolved = false; + gfc_resolve_array_spec (dst, 0); + } +} + +static void +resolve_sync_team (gfc_code *code) +{ + resolve_team_argument (code->expr1); + gfc_resolve_sync_stat (&code->ext.sync_stat); +} + +static void +resolve_end_team (gfc_code *code) +{ + gfc_resolve_sync_stat (&code->ext.sync_stat); +} static void resolve_critical (gfc_code *code) @@ -11464,6 +11620,8 @@ resolve_critical (gfc_code *code) char name[GFC_MAX_SYMBOL_LEN]; static int serial = 0; + gfc_resolve_sync_stat (&code->ext.sync_stat); + if (flag_coarray != GFC_FCOARRAY_LIB) return; @@ -11587,8 +11745,8 @@ resolve_branch (gfc_st_label *label, gfc_code *code) if (code->here == label) { - gfc_warning (0, - "Branch at %L may result in an infinite loop", &code->loc); + gfc_warning (0, "Branch at %L may result in an infinite loop", + &code->loc); return; } @@ -11611,6 +11769,10 @@ resolve_branch (gfc_st_label *label, gfc_code *code) && bitmap_bit_p (stack->reachable_labels, label->value)) gfc_error ("GOTO statement at %L leaves DO CONCURRENT construct " "for label at %L", &code->loc, &label->where); + else if (stack->current->op == EXEC_CHANGE_TEAM + && bitmap_bit_p (stack->reachable_labels, label->value)) + gfc_error ("GOTO statement at %L leaves CHANGE TEAM construct " + "for label at %L", &code->loc, &label->where); } return; @@ -13247,23 +13409,6 @@ deferred_op_assign (gfc_code **code, gfc_namespace *ns) } -static bool -check_team (gfc_expr *team, const char *intrinsic) -{ - if (team->rank != 0 - || team->ts.type != BT_DERIVED - || team->ts.u.derived->from_intmod != INTMOD_ISO_FORTRAN_ENV - || team->ts.u.derived->intmod_sym_id != ISOFORTRAN_TEAM_TYPE) - { - gfc_error ("TEAM argument to %qs at %L must be a scalar expression " - "of type TEAM_TYPE", intrinsic, &team->where); - return false; - } - - return true; -} - - /* Given a block of code, recursively resolve everything pointed to by this code block. */ @@ -13452,22 +13597,19 @@ start: break; case EXEC_FORM_TEAM: - if (code->expr1 != NULL - && (code->expr1->ts.type != BT_INTEGER || code->expr1->rank)) - gfc_error ("TEAM NUMBER argument to FORM TEAM at %L must be " - "a scalar INTEGER", &code->expr1->where); - check_team (code->expr2, "FORM TEAM"); + resolve_form_team (code); break; case EXEC_CHANGE_TEAM: - check_team (code->expr1, "CHANGE TEAM"); + resolve_change_team (code); break; case EXEC_END_TEAM: + resolve_end_team (code); break; case EXEC_SYNC_TEAM: - check_team (code->expr1, "SYNC TEAM"); + resolve_sync_team (code); break; case EXEC_ENTRY: @@ -16700,8 +16842,8 @@ resolve_fl_derived0 (gfc_symbol *sym) return false; /* Now add the caf token field, where needed. */ - if (flag_coarray != GFC_FCOARRAY_NONE - && !sym->attr.is_class && !sym->attr.vtype) + if (flag_coarray == GFC_FCOARRAY_LIB && !sym->attr.is_class + && !sym->attr.vtype) { for (c = sym->components; c; c = c->next) if (!c->attr.dimension && !c->attr.codimension @@ -17940,15 +18082,16 @@ skip_interfaces: || (a->dummy && !a->pointer && a->intent == INTENT_OUT && sym->ns->proc_name->attr.if_source != IFSRC_IFBODY)) apply_default_init (sym); + else if (a->function && !a->pointer && !a->allocatable && !a->use_assoc + && sym->result) + /* Default initialization for function results. */ + apply_default_init (sym->result); else if (a->function && sym->result && a->access != ACCESS_PRIVATE && (sym->ts.u.derived->attr.alloc_comp || sym->ts.u.derived->attr.pointer_comp)) /* Mark the result symbol to be referenced, when it has allocatable components. */ sym->result->attr.referenced = 1; - else if (a->function && !a->pointer && !a->allocatable && sym->result) - /* Default initialization for function results. */ - apply_default_init (sym->result); } if (sym->ts.type == BT_CLASS && sym->ns == gfc_current_ns @@ -18430,6 +18573,16 @@ gfc_impure_variable (gfc_symbol *sym) if (sym->attr.use_assoc || sym->attr.in_common) return 1; + /* The namespace of a module procedure interface holds the arguments and + symbols, and so the symbol namespace can be different to that of the + procedure. */ + if (sym->ns != gfc_current_ns + && gfc_current_ns->proc_name->abr_modproc_decl + && sym->ns->proc_name->attr.function + && sym->attr.result + && !strcmp (sym->ns->proc_name->name, gfc_current_ns->proc_name->name)) + return 0; + /* Check if the symbol's ns is inside the pure procedure. */ for (ns = gfc_current_ns; ns; ns = ns->parent) { diff --git a/gcc/fortran/simplify.cc b/gcc/fortran/simplify.cc index 92ab17b..b25cd2c 100644 --- a/gcc/fortran/simplify.cc +++ b/gcc/fortran/simplify.cc @@ -885,7 +885,8 @@ gfc_simplify_acos (gfc_expr *x) if (mpfr_cmp_si (x->value.real, 1) > 0 || mpfr_cmp_si (x->value.real, -1) < 0) { - gfc_error ("Argument of ACOS at %L must be between -1 and 1", + gfc_error ("Argument of ACOS at %L must be within the closed " + "interval [-1, 1]", &x->where); return &gfc_bad_expr; } @@ -1162,7 +1163,8 @@ gfc_simplify_asin (gfc_expr *x) if (mpfr_cmp_si (x->value.real, 1) > 0 || mpfr_cmp_si (x->value.real, -1) < 0) { - gfc_error ("Argument of ASIN at %L must be between -1 and 1", + gfc_error ("Argument of ASIN at %L must be within the closed " + "interval [-1, 1]", &x->where); return &gfc_bad_expr; } @@ -1183,6 +1185,7 @@ gfc_simplify_asin (gfc_expr *x) } +#if MPFR_VERSION < MPFR_VERSION_NUM(4,2,0) /* Convert radians to degrees, i.e., x * 180 / pi. */ static void @@ -1196,6 +1199,7 @@ rad2deg (mpfr_t x) mpfr_div (x, x, tmp, GFC_RND_MODE); mpfr_clear (tmp); } +#endif /* Simplify ACOSD(X) where the returned value has units of degree. */ @@ -1211,14 +1215,19 @@ gfc_simplify_acosd (gfc_expr *x) if (mpfr_cmp_si (x->value.real, 1) > 0 || mpfr_cmp_si (x->value.real, -1) < 0) { - gfc_error ("Argument of ACOSD at %L must be between -1 and 1", - &x->where); + gfc_error ( + "Argument of ACOSD at %L must be within the closed interval [-1, 1]", + &x->where); return &gfc_bad_expr; } result = gfc_get_constant_expr (x->ts.type, x->ts.kind, &x->where); +#if MPFR_VERSION >= MPFR_VERSION_NUM(4,2,0) + mpfr_acosu (result->value.real, x->value.real, 360, GFC_RND_MODE); +#else mpfr_acos (result->value.real, x->value.real, GFC_RND_MODE); rad2deg (result->value.real); +#endif return range_check (result, "ACOSD"); } @@ -1237,14 +1246,19 @@ gfc_simplify_asind (gfc_expr *x) if (mpfr_cmp_si (x->value.real, 1) > 0 || mpfr_cmp_si (x->value.real, -1) < 0) { - gfc_error ("Argument of ASIND at %L must be between -1 and 1", - &x->where); + gfc_error ( + "Argument of ASIND at %L must be within the closed interval [-1, 1]", + &x->where); return &gfc_bad_expr; } result = gfc_get_constant_expr (x->ts.type, x->ts.kind, &x->where); +#if MPFR_VERSION >= MPFR_VERSION_NUM(4,2,0) + mpfr_asinu (result->value.real, x->value.real, 360, GFC_RND_MODE); +#else mpfr_asin (result->value.real, x->value.real, GFC_RND_MODE); rad2deg (result->value.real); +#endif return range_check (result, "ASIND"); } @@ -1261,8 +1275,12 @@ gfc_simplify_atand (gfc_expr *x) return NULL; result = gfc_get_constant_expr (x->ts.type, x->ts.kind, &x->where); +#if MPFR_VERSION >= MPFR_VERSION_NUM(4,2,0) + mpfr_atanu (result->value.real, x->value.real, 360, GFC_RND_MODE); +#else mpfr_atan (result->value.real, x->value.real, GFC_RND_MODE); rad2deg (result->value.real); +#endif return range_check (result, "ATAND"); } @@ -1369,7 +1387,7 @@ gfc_simplify_atan2 (gfc_expr *y, gfc_expr *x) if (mpfr_zero_p (y->value.real) && mpfr_zero_p (x->value.real)) { - gfc_error ("If first argument of ATAN2 at %L is zero, then the " + gfc_error ("If the first argument of ATAN2 at %L is zero, then the " "second argument must not be zero", &y->where); return &gfc_bad_expr; } @@ -1948,14 +1966,19 @@ gfc_simplify_atan2d (gfc_expr *y, gfc_expr *x) if (mpfr_zero_p (y->value.real) && mpfr_zero_p (x->value.real)) { - gfc_error ("If first argument of ATAN2D at %L is zero, then the " + gfc_error ("If the first argument of ATAN2D at %L is zero, then the " "second argument must not be zero", &y->where); return &gfc_bad_expr; } result = gfc_get_constant_expr (x->ts.type, x->ts.kind, &x->where); +#if MPFR_VERSION >= MPFR_VERSION_NUM(4,2,0) + mpfr_atan2u (result->value.real, y->value.real, x->value.real, 360, + GFC_RND_MODE); +#else mpfr_atan2 (result->value.real, y->value.real, x->value.real, GFC_RND_MODE); rad2deg (result->value.real); +#endif return range_check (result, "ATAN2D"); } @@ -1990,6 +2013,8 @@ gfc_simplify_cos (gfc_expr *x) } +#if MPFR_VERSION < MPFR_VERSION_NUM(4,2,0) +/* Used by trigd_fe.inc. */ static void deg2rad (mpfr_t x) { @@ -2001,11 +2026,13 @@ deg2rad (mpfr_t x) mpfr_mul (x, x, d2r, GFC_RND_MODE); mpfr_clear (d2r); } +#endif +#if MPFR_VERSION < MPFR_VERSION_NUM(4,2,0) /* Simplification routines for SIND, COSD, TAND. */ #include "trigd_fe.inc" - +#endif /* Simplify COSD(X) where X has the unit of degree. */ @@ -2018,8 +2045,12 @@ gfc_simplify_cosd (gfc_expr *x) return NULL; result = gfc_get_constant_expr (x->ts.type, x->ts.kind, &x->where); +#if MPFR_VERSION >= MPFR_VERSION_NUM(4,2,0) + mpfr_cosu (result->value.real, x->value.real, 360, GFC_RND_MODE); +#else mpfr_set (result->value.real, x->value.real, GFC_RND_MODE); simplify_cosd (result->value.real); +#endif return range_check (result, "COSD"); } @@ -2036,8 +2067,12 @@ gfc_simplify_sind (gfc_expr *x) return NULL; result = gfc_get_constant_expr (x->ts.type, x->ts.kind, &x->where); +#if MPFR_VERSION >= MPFR_VERSION_NUM(4,2,0) + mpfr_sinu (result->value.real, x->value.real, 360, GFC_RND_MODE); +#else mpfr_set (result->value.real, x->value.real, GFC_RND_MODE); simplify_sind (result->value.real); +#endif return range_check (result, "SIND"); } @@ -2054,8 +2089,12 @@ gfc_simplify_tand (gfc_expr *x) return NULL; result = gfc_get_constant_expr (x->ts.type, x->ts.kind, &x->where); +#if MPFR_VERSION >= MPFR_VERSION_NUM(4,2,0) + mpfr_tanu (result->value.real, x->value.real, 360, GFC_RND_MODE); +#else mpfr_set (result->value.real, x->value.real, GFC_RND_MODE); simplify_tand (result->value.real); +#endif return range_check (result, "TAND"); } @@ -2078,7 +2117,11 @@ gfc_simplify_cotand (gfc_expr *x) result = gfc_get_constant_expr (x->ts.type, x->ts.kind, &x->where); mpfr_set (result->value.real, x->value.real, GFC_RND_MODE); mpfr_add_ui (result->value.real, result->value.real, 90, GFC_RND_MODE); +#if MPFR_VERSION >= MPFR_VERSION_NUM(4,2,0) + mpfr_tanu (result->value.real, result->value.real, 360, GFC_RND_MODE); +#else simplify_tand (result->value.real); +#endif mpfr_neg (result->value.real, result->value.real, GFC_RND_MODE); return range_check (result, "COTAND"); @@ -2112,6 +2155,250 @@ gfc_simplify_cosh (gfc_expr *x) return range_check (result, "COSH"); } +gfc_expr * +gfc_simplify_acospi (gfc_expr *x) +{ + gfc_expr *result; + + if (x->expr_type != EXPR_CONSTANT) + return NULL; + + if (mpfr_cmp_si (x->value.real, 1) > 0 || mpfr_cmp_si (x->value.real, -1) < 0) + { + gfc_error ( + "Argument of ACOSPI at %L must be within the closed interval [-1, 1]", + &x->where); + return &gfc_bad_expr; + } + + result = gfc_get_constant_expr (x->ts.type, x->ts.kind, &x->where); + +#if MPFR_VERSION >= MPFR_VERSION_NUM(4, 2, 0) + mpfr_acospi (result->value.real, x->value.real, GFC_RND_MODE); +#else + mpfr_t pi, tmp; + mpfr_inits2 (2 * mpfr_get_prec (x->value.real), pi, tmp, NULL); + mpfr_const_pi (pi, GFC_RND_MODE); + mpfr_acos (tmp, x->value.real, GFC_RND_MODE); + mpfr_div (result->value.real, tmp, pi, GFC_RND_MODE); + mpfr_clears (pi, tmp, NULL); +#endif + + return result; +} + +gfc_expr * +gfc_simplify_asinpi (gfc_expr *x) +{ + gfc_expr *result; + + if (x->expr_type != EXPR_CONSTANT) + return NULL; + + if (mpfr_cmp_si (x->value.real, 1) > 0 || mpfr_cmp_si (x->value.real, -1) < 0) + { + gfc_error ( + "Argument of ASINPI at %L must be within the closed interval [-1, 1]", + &x->where); + return &gfc_bad_expr; + } + + result = gfc_get_constant_expr (x->ts.type, x->ts.kind, &x->where); + +#if MPFR_VERSION >= MPFR_VERSION_NUM(4, 2, 0) + mpfr_asinpi (result->value.real, x->value.real, GFC_RND_MODE); +#else + mpfr_t pi, tmp; + mpfr_inits2 (2 * mpfr_get_prec (x->value.real), pi, tmp, NULL); + mpfr_const_pi (pi, GFC_RND_MODE); + mpfr_asin (tmp, x->value.real, GFC_RND_MODE); + mpfr_div (result->value.real, tmp, pi, GFC_RND_MODE); + mpfr_clears (pi, tmp, NULL); +#endif + + return result; +} + +gfc_expr * +gfc_simplify_atanpi (gfc_expr *x) +{ + gfc_expr *result; + + if (x->expr_type != EXPR_CONSTANT) + return NULL; + + result = gfc_get_constant_expr (x->ts.type, x->ts.kind, &x->where); + +#if MPFR_VERSION >= MPFR_VERSION_NUM(4, 2, 0) + mpfr_atanpi (result->value.real, x->value.real, GFC_RND_MODE); +#else + mpfr_t pi, tmp; + mpfr_inits2 (2 * mpfr_get_prec (x->value.real), pi, tmp, NULL); + mpfr_const_pi (pi, GFC_RND_MODE); + mpfr_atan (tmp, x->value.real, GFC_RND_MODE); + mpfr_div (result->value.real, tmp, pi, GFC_RND_MODE); + mpfr_clears (pi, tmp, NULL); +#endif + + return range_check (result, "ATANPI"); +} + +gfc_expr * +gfc_simplify_atan2pi (gfc_expr *y, gfc_expr *x) +{ + gfc_expr *result; + + if (x->expr_type != EXPR_CONSTANT || y->expr_type != EXPR_CONSTANT) + return NULL; + + if (mpfr_zero_p (y->value.real) && mpfr_zero_p (x->value.real)) + { + gfc_error ("If the first argument of ATAN2PI at %L is zero, then the " + "second argument must not be zero", + &y->where); + return &gfc_bad_expr; + } + + result = gfc_get_constant_expr (x->ts.type, x->ts.kind, &x->where); + +#if MPFR_VERSION >= MPFR_VERSION_NUM(4, 2, 0) + mpfr_atan2pi (result->value.real, y->value.real, x->value.real, GFC_RND_MODE); +#else + mpfr_t pi, tmp; + mpfr_inits2 (2 * mpfr_get_prec (x->value.real), pi, tmp, NULL); + mpfr_const_pi (pi, GFC_RND_MODE); + mpfr_atan2 (tmp, y->value.real, x->value.real, GFC_RND_MODE); + mpfr_div (result->value.real, tmp, pi, GFC_RND_MODE); + mpfr_clears (pi, tmp, NULL); +#endif + + return range_check (result, "ATAN2PI"); +} + +gfc_expr * +gfc_simplify_cospi (gfc_expr *x) +{ + gfc_expr *result; + + if (x->expr_type != EXPR_CONSTANT) + return NULL; + + result = gfc_get_constant_expr (x->ts.type, x->ts.kind, &x->where); + +#if MPFR_VERSION >= MPFR_VERSION_NUM(4, 2, 0) + mpfr_cospi (result->value.real, x->value.real, GFC_RND_MODE); +#else + mpfr_t cs, n, r, two; + int s; + + mpfr_inits2 (2 * mpfr_get_prec (x->value.real), cs, n, r, two, NULL); + + mpfr_abs (r, x->value.real, GFC_RND_MODE); + mpfr_modf (n, r, r, GFC_RND_MODE); + + if (mpfr_cmp_d (r, 0.5) == 0) + { + mpfr_set_ui (result->value.real, 0, GFC_RND_MODE); + return result; + } + + mpfr_set_ui (two, 2, GFC_RND_MODE); + mpfr_fmod (cs, n, two, GFC_RND_MODE); + s = mpfr_cmp_ui (cs, 0) == 0 ? 1 : -1; + + mpfr_const_pi (cs, GFC_RND_MODE); + mpfr_mul (cs, cs, r, GFC_RND_MODE); + mpfr_cos (cs, cs, GFC_RND_MODE); + mpfr_mul_si (result->value.real, cs, s, GFC_RND_MODE); + + mpfr_clears (cs, n, r, two, NULL); +#endif + + return range_check (result, "COSPI"); +} + +gfc_expr * +gfc_simplify_sinpi (gfc_expr *x) +{ + gfc_expr *result; + + if (x->expr_type != EXPR_CONSTANT) + return NULL; + + result = gfc_get_constant_expr (x->ts.type, x->ts.kind, &x->where); + +#if MPFR_VERSION >= MPFR_VERSION_NUM(4, 2, 0) + mpfr_sinpi (result->value.real, x->value.real, GFC_RND_MODE); +#else + mpfr_t sn, n, r, two; + int s; + + mpfr_inits2 (2 * mpfr_get_prec (x->value.real), sn, n, r, two, NULL); + + mpfr_abs (r, x->value.real, GFC_RND_MODE); + mpfr_modf (n, r, r, GFC_RND_MODE); + + if (mpfr_cmp_d (r, 0.0) == 0) + { + mpfr_set_ui (result->value.real, 0, GFC_RND_MODE); + return result; + } + + mpfr_set_ui (two, 2, GFC_RND_MODE); + mpfr_fmod (sn, n, two, GFC_RND_MODE); + s = mpfr_cmp_si (x->value.real, 0) < 0 ? -1 : 1; + s *= mpfr_cmp_ui (sn, 0) == 0 ? 1 : -1; + + mpfr_const_pi (sn, GFC_RND_MODE); + mpfr_mul (sn, sn, r, GFC_RND_MODE); + mpfr_sin (sn, sn, GFC_RND_MODE); + mpfr_mul_si (result->value.real, sn, s, GFC_RND_MODE); + + mpfr_clears (sn, n, r, two, NULL); +#endif + + return range_check (result, "SINPI"); +} + +gfc_expr * +gfc_simplify_tanpi (gfc_expr *x) +{ + gfc_expr *result; + + if (x->expr_type != EXPR_CONSTANT) + return NULL; + + result = gfc_get_constant_expr (x->ts.type, x->ts.kind, &x->where); + +#if MPFR_VERSION >= MPFR_VERSION_NUM(4, 2, 0) + mpfr_tanpi (result->value.real, x->value.real, GFC_RND_MODE); +#else + mpfr_t tn, n, r; + int s; + + mpfr_inits2 (2 * mpfr_get_prec (x->value.real), tn, n, r, NULL); + + mpfr_abs (r, x->value.real, GFC_RND_MODE); + mpfr_modf (n, r, r, GFC_RND_MODE); + + if (mpfr_cmp_d (r, 0.0) == 0) + { + mpfr_set_ui (result->value.real, 0, GFC_RND_MODE); + return result; + } + + s = mpfr_cmp_si (x->value.real, 0) < 0 ? -1 : 1; + + mpfr_const_pi (tn, GFC_RND_MODE); + mpfr_mul (tn, tn, r, GFC_RND_MODE); + mpfr_tan (tn, tn, GFC_RND_MODE); + mpfr_mul_si (result->value.real, tn, s, GFC_RND_MODE); + + mpfr_clears (tn, n, r, NULL); +#endif + + return range_check (result, "TANPI"); +} gfc_expr * gfc_simplify_count (gfc_expr *mask, gfc_expr *dim, gfc_expr *kind) @@ -3133,8 +3420,10 @@ gfc_simplify_get_team (gfc_expr *level ATTRIBUTE_UNUSED) if (flag_coarray == GFC_FCOARRAY_SINGLE) { gfc_expr *result; - result = gfc_get_array_expr (BT_INTEGER, gfc_default_integer_kind, &gfc_current_locus); - result->rank = 0; + result = gfc_get_null_expr (&gfc_current_locus); + result->ts.type = BT_DERIVED; + gfc_find_symbol ("team_type", gfc_current_ns, 1, &result->ts.u.derived); + return result; } @@ -6727,7 +7016,7 @@ gfc_simplify_null (gfc_expr *mold) gfc_expr * -gfc_simplify_num_images (gfc_expr *distance ATTRIBUTE_UNUSED, gfc_expr *failed) +gfc_simplify_num_images (gfc_expr *team_or_team_number ATTRIBUTE_UNUSED) { gfc_expr *result; @@ -6740,16 +7029,9 @@ gfc_simplify_num_images (gfc_expr *distance ATTRIBUTE_UNUSED, gfc_expr *failed) if (flag_coarray != GFC_FCOARRAY_SINGLE) return NULL; - if (failed && failed->expr_type != EXPR_CONSTANT) - return NULL; - /* FIXME: gfc_current_locus is wrong. */ result = gfc_get_constant_expr (BT_INTEGER, gfc_default_integer_kind, &gfc_current_locus); - - if (failed && failed->value.logical != 0) - mpz_set_si (result->value.integer, 0); - else mpz_set_si (result->value.integer, 1); return result; @@ -8925,7 +9207,8 @@ gfc_simplify_trim (gfc_expr *e) gfc_expr * -gfc_simplify_image_index (gfc_expr *coarray, gfc_expr *sub) +gfc_simplify_image_index (gfc_expr *coarray, gfc_expr *sub, + gfc_expr *team_or_team_number ATTRIBUTE_UNUSED) { gfc_expr *result; gfc_ref *ref; @@ -9067,14 +9350,13 @@ gfc_simplify_image_status (gfc_expr *image, gfc_expr *team ATTRIBUTE_UNUSED) gfc_expr * gfc_simplify_this_image (gfc_expr *coarray, gfc_expr *dim, - gfc_expr *distance ATTRIBUTE_UNUSED) + gfc_expr *team ATTRIBUTE_UNUSED) { if (flag_coarray != GFC_FCOARRAY_SINGLE) return NULL; - /* If no coarray argument has been passed or when the first argument - is actually a distance argument. */ - if (coarray == NULL || !gfc_is_coarray (coarray)) + /* If no coarray argument has been passed. */ + if (coarray == NULL) { gfc_expr *result; /* FIXME: gfc_current_locus is wrong. */ diff --git a/gcc/fortran/trans-array.cc b/gcc/fortran/trans-array.cc index e9eacf2..7be2d7b 100644 --- a/gcc/fortran/trans-array.cc +++ b/gcc/fortran/trans-array.cc @@ -1991,14 +1991,17 @@ static void gfc_trans_array_ctor_element (stmtblock_t * pblock, tree desc, tree offset, gfc_se * se, gfc_expr * expr) { - tree tmp; + tree tmp, offset_eval; gfc_conv_expr (se, expr); /* Store the value. */ tmp = build_fold_indirect_ref_loc (input_location, gfc_conv_descriptor_data_get (desc)); - tmp = gfc_build_array_ref (tmp, offset, NULL); + /* The offset may change, so get its value now and use that to free memory. + */ + offset_eval = gfc_evaluate_now (offset, &se->pre); + tmp = gfc_build_array_ref (tmp, offset_eval, NULL); if (expr->expr_type == EXPR_FUNCTION && expr->ts.type == BT_DERIVED && expr->ts.u.derived->attr.alloc_comp) @@ -3150,8 +3153,7 @@ finish: the reference. */ if ((expr->ts.type == BT_DERIVED || expr->ts.type == BT_CLASS) && finalblock.head != NULL_TREE) - gfc_add_block_to_block (&loop->post, &finalblock); - + gfc_prepend_expr_to_block (&loop->post, finalblock.head); } @@ -10109,7 +10111,7 @@ structure_alloc_comps (gfc_symbol * der_type, tree decl, tree dest, else { attr = &c->attr; - if (attr->pointer) + if (attr->pointer || attr->proc_pointer) continue; } @@ -12067,8 +12069,16 @@ gfc_trans_deferred_array (gfc_symbol * sym, gfc_wrapped_block * block) && !INTEGER_CST_P (sym->ts.u.cl->backend_decl)) { if (sym->ts.deferred && !sym->ts.u.cl->length && !sym->attr.dummy) - gfc_add_modify (&init, sym->ts.u.cl->backend_decl, - build_zero_cst (TREE_TYPE (sym->ts.u.cl->backend_decl))); + { + tree len_expr = sym->ts.u.cl->backend_decl; + tree init_val = build_zero_cst (TREE_TYPE (len_expr)); + if (VAR_P (len_expr) + && sym->attr.save + && !DECL_INITIAL (len_expr)) + DECL_INITIAL (len_expr) = init_val; + else + gfc_add_modify (&init, len_expr, init_val); + } gfc_conv_string_length (sym->ts.u.cl, NULL, &init); gfc_trans_vla_type_sizes (sym, &init); diff --git a/gcc/fortran/trans-decl.cc b/gcc/fortran/trans-decl.cc index 8dd1c93..43bd7be 100644 --- a/gcc/fortran/trans-decl.cc +++ b/gcc/fortran/trans-decl.cc @@ -4043,9 +4043,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 +4201,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 ( @@ -6546,7 +6540,7 @@ add_argument_checking (stmtblock_t *block, gfc_symbol *sym) message = _("Actual string length does not match the declared one" " for dummy argument '%s' (%ld/%ld)"); } - else if (fsym->as && fsym->as->rank != 0) + else if ((fsym->as && fsym->as->rank != 0) || fsym->attr.artificial) continue; else { @@ -6920,6 +6914,7 @@ add_clause (gfc_symbol *sym, gfc_omp_map_op map_op) n = gfc_get_omp_namelist (); n->sym = sym; + n->where = sym->declared_at; n->u.map.op = map_op; if (!module_oacc_clauses) @@ -8084,13 +8079,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) @@ -8361,23 +8356,17 @@ gfc_generate_block_data (gfc_namespace * ns) rest_of_decl_compilation (decl, 1, 0); } - -/* Process the local variables of a BLOCK construct. */ - void -gfc_process_block_locals (gfc_namespace* ns) +gfc_start_saved_local_decls () { - tree decl; - + gcc_checking_assert (current_function_decl != NULL_TREE); saved_local_decls = NULL_TREE; - has_coarray_vars_or_accessors = caf_accessor_head != NULL; - - generate_local_vars (ns); - - if (flag_coarray == GFC_FCOARRAY_LIB && has_coarray_vars_or_accessors) - generate_coarray_init (ns); +} - decl = nreverse (saved_local_decls); +void +gfc_stop_saved_local_decls () +{ + tree decl = nreverse (saved_local_decls); while (decl) { tree next; @@ -8390,5 +8379,20 @@ gfc_process_block_locals (gfc_namespace* ns) saved_local_decls = NULL_TREE; } +/* Process the local variables of a BLOCK construct. */ + +void +gfc_process_block_locals (gfc_namespace* ns) +{ + gfc_start_saved_local_decls (); + has_coarray_vars_or_accessors = caf_accessor_head != NULL; + + generate_local_vars (ns); + + if (flag_coarray == GFC_FCOARRAY_LIB && has_coarray_vars_or_accessors) + generate_coarray_init (ns); + gfc_stop_saved_local_decls (); +} + #include "gt-fortran-trans-decl.h" diff --git a/gcc/fortran/trans-expr.cc b/gcc/fortran/trans-expr.cc index d965539..3e0d763 100644 --- a/gcc/fortran/trans-expr.cc +++ b/gcc/fortran/trans-expr.cc @@ -2579,10 +2579,8 @@ gfc_caf_get_image_index (stmtblock_t *block, gfc_expr *e, tree desc) gcc_assert (ref != NULL); if (ref->u.ar.dimen_type[ref->u.ar.dimen] == DIMEN_THIS_IMAGE) - { - return build_call_expr_loc (input_location, gfor_fndecl_caf_this_image, 1, - integer_zero_node); - } + return build_call_expr_loc (input_location, gfor_fndecl_caf_this_image, 1, + null_pointer_node); img_idx = build_zero_cst (gfc_array_index_type); extent = build_one_cst (gfc_array_index_type); @@ -2784,9 +2782,11 @@ gfc_conv_substring (gfc_se * se, gfc_ref * ref, int kind, start.expr = gfc_evaluate_now (start.expr, &se->pre); /* Change the start of the string. */ - if ((TREE_CODE (TREE_TYPE (se->expr)) == ARRAY_TYPE - || TREE_CODE (TREE_TYPE (se->expr)) == INTEGER_TYPE) - && TYPE_STRING_FLAG (TREE_TYPE (se->expr))) + if (((TREE_CODE (TREE_TYPE (se->expr)) == ARRAY_TYPE + || TREE_CODE (TREE_TYPE (se->expr)) == INTEGER_TYPE) + && TYPE_STRING_FLAG (TREE_TYPE (se->expr))) + || (POINTER_TYPE_P (TREE_TYPE (se->expr)) + && TREE_CODE (TREE_TYPE (TREE_TYPE (se->expr))) != ARRAY_TYPE)) tmp = se->expr; else tmp = build_fold_indirect_ref_loc (input_location, @@ -2797,6 +2797,15 @@ gfc_conv_substring (gfc_se * se, gfc_ref * ref, int kind, tmp = gfc_build_array_ref (tmp, start.expr, NULL_TREE, true); se->expr = gfc_build_addr_expr (type, tmp); } + else if (POINTER_TYPE_P (TREE_TYPE (tmp))) + { + tree diff; + diff = fold_build2 (MINUS_EXPR, gfc_charlen_type_node, start.expr, + build_one_cst (gfc_charlen_type_node)); + diff = fold_convert (size_type_node, diff); + se->expr + = fold_build2 (POINTER_PLUS_EXPR, TREE_TYPE (tmp), tmp, diff); + } } /* Length = end + 1 - start. */ @@ -4627,6 +4636,16 @@ get_builtin_fn (gfc_symbol * sym) && !strcmp (sym->name, "omp_is_initial_device")) return builtin_decl_explicit (BUILT_IN_OMP_IS_INITIAL_DEVICE); + if (!gfc_option.disable_omp_get_initial_device + && flag_openmp && sym->attr.function && sym->ts.type == BT_INTEGER + && !strcmp (sym->name, "omp_get_initial_device")) + return builtin_decl_explicit (BUILT_IN_OMP_GET_INITIAL_DEVICE); + + if (!gfc_option.disable_omp_get_num_devices + && flag_openmp && sym->attr.function && sym->ts.type == BT_INTEGER + && !strcmp (sym->name, "omp_get_num_devices")) + return builtin_decl_explicit (BUILT_IN_OMP_GET_NUM_DEVICES); + if (!gfc_option.disable_acc_on_device && flag_openacc && sym->attr.function && sym->ts.type == BT_LOGICAL && !strcmp (sym->name, "acc_on_device_h")) @@ -6925,10 +6944,18 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym, { /* Pass a NULL pointer for an absent arg. */ parmse.expr = null_pointer_node; + + /* Is it an absent character dummy? */ + bool absent_char = false; gfc_dummy_arg * const dummy_arg = arg->associated_dummy; - if (dummy_arg - && gfc_dummy_arg_get_typespec (*dummy_arg).type - == BT_CHARACTER) + + /* Fall back to inferred type only if no formal. */ + if (fsym) + absent_char = (fsym->ts.type == BT_CHARACTER); + else if (dummy_arg) + absent_char = (gfc_dummy_arg_get_typespec (*dummy_arg).type + == BT_CHARACTER); + if (absent_char) parmse.string_length = build_int_cst (gfc_charlen_type_node, 0); } @@ -6954,9 +6981,7 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym, || !CLASS_DATA (fsym)->attr.allocatable)); gfc_init_se (&parmse, NULL); parmse.expr = null_pointer_node; - if (arg->associated_dummy - && gfc_dummy_arg_get_typespec (*arg->associated_dummy).type - == BT_CHARACTER) + if (fsym->ts.type == BT_CHARACTER) parmse.string_length = build_int_cst (gfc_charlen_type_node, 0); } else if (fsym && fsym->ts.type == BT_CLASS @@ -7994,7 +8019,11 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym, gfc_add_expr_to_block (&se->post, local_tmp); } - if (!finalized && !e->must_finalize) + /* Items of array expressions passed to a polymorphic formal arguments + create their own clean up, so prevent double free. */ + if (!finalized && !e->must_finalize + && !(e->expr_type == EXPR_ARRAY && fsym + && fsym->ts.type == BT_CLASS)) { bool scalar_res_outside_loop; scalar_res_outside_loop = e->expr_type == EXPR_FUNCTION @@ -8137,7 +8166,7 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym, goto end_pointer_check; tmp = parmse.expr; - if (fsym && fsym->ts.type == BT_CLASS) + if (fsym && fsym->ts.type == BT_CLASS && !attr.proc_pointer) { if (POINTER_TYPE_P (TREE_TYPE (tmp))) tmp = build_fold_indirect_ref_loc (input_location, tmp); @@ -8401,6 +8430,7 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym, byref = (comp && (comp->attr.dimension || (comp->ts.type == BT_CHARACTER && !sym->attr.is_bind_c))) || (!comp && gfc_return_by_reference (sym)); + if (byref) { if (se->direct_byref) @@ -8585,6 +8615,7 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym, else if (ts.type == BT_CHARACTER) vec_safe_push (retargs, len); } + gfc_free_interface_mapping (&mapping); /* We need to glom RETARGS + ARGLIST + STRINGARGS + APPEND_ARGS. */ @@ -8769,10 +8800,12 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym, /* Transformational functions of derived types with allocatable components must have the result allocatable components copied when the - argument is actually given. */ + argument is actually given. This is unnecessry for REDUCE because the + wrapper for the OPERATION function takes care of this. */ arg = expr->value.function.actual; if (result && arg && expr->rank && isym && isym->transformational + && isym->id != GFC_ISYM_REDUCE && arg->expr && arg->expr->ts.type == BT_DERIVED && arg->expr->ts.u.derived->attr.alloc_comp) @@ -9822,7 +9855,12 @@ gfc_trans_subcomponent_assign (tree dest, gfc_component * cm, && !cm->attr.proc_pointer) { if (cm->attr.allocatable && expr->expr_type == EXPR_NULL) - gfc_conv_descriptor_data_set (&block, dest, null_pointer_node); + { + gfc_conv_descriptor_data_set (&block, dest, null_pointer_node); + if (cm->attr.codimension && flag_coarray == GFC_FCOARRAY_LIB) + gfc_add_modify (&block, gfc_conv_descriptor_token (dest), + null_pointer_node); + } else if (cm->attr.allocatable || cm->attr.pdt_array) { tmp = gfc_trans_alloc_subarray_assign (dest, cm, expr); @@ -10895,9 +10933,11 @@ gfc_trans_pointer_assignment (gfc_expr * expr1, gfc_expr * expr2) gfc_init_se (&lse, NULL); /* Usually testing whether this is not a proc pointer assignment. */ - non_proc_ptr_assign = !(gfc_expr_attr (expr1).proc_pointer - && expr2->expr_type == EXPR_VARIABLE - && expr2->symtree->n.sym->attr.flavor == FL_PROCEDURE); + non_proc_ptr_assign + = !(gfc_expr_attr (expr1).proc_pointer + && ((expr2->expr_type == EXPR_VARIABLE + && expr2->symtree->n.sym->attr.flavor == FL_PROCEDURE) + || expr2->expr_type == EXPR_NULL)); /* Check whether the expression is a scalar or not; we cannot use expr1->rank as it can be nonzero for proc pointers. */ diff --git a/gcc/fortran/trans-intrinsic.cc b/gcc/fortran/trans-intrinsic.cc index 373a067..f1bfd3e 100644 --- a/gcc/fortran/trans-intrinsic.cc +++ b/gcc/fortran/trans-intrinsic.cc @@ -1052,7 +1052,7 @@ conv_caf_func_index (stmtblock_t *block, gfc_namespace *ns, const char *pat, index_st->n.sym->value = gfc_get_constant_expr (BT_INTEGER, gfc_default_integer_kind, &gfc_current_locus); - mpz_init_set_si (index_st->n.sym->value->value.integer, -1); + mpz_set_si (index_st->n.sym->value->value.integer, -1); index_st->n.sym->ts.type = BT_INTEGER; index_st->n.sym->ts.kind = gfc_default_integer_kind; gfc_set_sym_referenced (index_st->n.sym); @@ -1183,8 +1183,10 @@ conv_stat_and_team (stmtblock_t *block, gfc_expr *expr, tree *stat, tree *team, { gfc_se team_se; gfc_init_se (&team_se, NULL); - gfc_conv_expr_reference (&team_se, team_e); - *team = team_se.expr; + gfc_conv_expr (&team_se, team_e); + *team + = gfc_build_addr_expr (NULL_TREE, gfc_trans_force_lval (&team_se.pre, + team_se.expr)); gfc_add_block_to_block (block, &team_se.pre); gfc_add_block_to_block (block, &team_se.post); } @@ -1196,8 +1198,11 @@ conv_stat_and_team (stmtblock_t *block, gfc_expr *expr, tree *stat, tree *team, { gfc_se team_se; gfc_init_se (&team_se, NULL); - gfc_conv_expr_reference (&team_se, team_e); - *team_no = team_se.expr; + gfc_conv_expr (&team_se, team_e); + *team_no = gfc_build_addr_expr ( + NULL_TREE, + gfc_trans_force_lval (&team_se.pre, + fold_convert (integer_type_node, team_se.expr))); gfc_add_block_to_block (block, &team_se.pre); gfc_add_block_to_block (block, &team_se.post); } @@ -1379,9 +1384,9 @@ gfc_conv_intrinsic_caf_is_present_remote (gfc_se *se, gfc_expr *e) present_fn = e->value.function.actual->next->next->expr; add_data_sym = present_fn->symtree->n.sym->formal->sym; - fn_index = conv_caf_func_index (&se->pre, gfc_current_ns, + fn_index = conv_caf_func_index (&se->pre, e->symtree->n.sym->ns, "__caf_present_on_remote_fn_index_%d", hash); - add_data_tree = conv_caf_add_call_data (&se->pre, gfc_current_ns, + add_data_tree = conv_caf_add_call_data (&se->pre, e->symtree->n.sym->ns, "__caf_present_on_remote_add_data_%d", add_data_sym, &add_data_size); ++caf_call_cnt; @@ -1790,13 +1795,13 @@ conv_caf_sendget (gfc_code *code) ++caf_call_cnt; tmp = build_call_expr_loc ( - input_location, gfor_fndecl_caf_transfer_between_remotes, 20, lhs_token, + input_location, gfor_fndecl_caf_transfer_between_remotes, 22, lhs_token, opt_lhs_desc, opt_lhs_charlen, lhs_image_index, receiver_fn_index_tree, lhs_add_data_tree, lhs_add_data_size, rhs_token, opt_rhs_desc, opt_rhs_charlen, rhs_image_index, sender_fn_index_tree, rhs_add_data_tree, rhs_add_data_size, rhs_size, transfer_rank == 0 ? boolean_true_node : boolean_false_node, lhs_stat, - lhs_team, lhs_team_no, rhs_stat, rhs_team, rhs_team_no); + rhs_stat, lhs_team, lhs_team_no, rhs_team, rhs_team_no); gfc_add_expr_to_block (&block, tmp); gfc_add_block_to_block (&block, &lhs_se.post); @@ -1818,34 +1823,31 @@ static void trans_this_image (gfc_se * se, gfc_expr *expr) { stmtblock_t loop; - tree type, desc, dim_arg, cond, tmp, m, loop_var, exit_label, min_var, - lbound, ubound, extent, ml; + tree type, desc, dim_arg, cond, tmp, m, loop_var, exit_label, min_var, lbound, + ubound, extent, ml, team; gfc_se argse; int rank, corank; - gfc_expr *distance = expr->value.function.actual->next->next->expr; - - if (expr->value.function.actual->expr - && !gfc_is_coarray (expr->value.function.actual->expr)) - distance = expr->value.function.actual->expr; /* The case -fcoarray=single is handled elsewhere. */ gcc_assert (flag_coarray != GFC_FCOARRAY_SINGLE); + /* Translate team, if present. */ + if (expr->value.function.actual->next->next->expr) + { + gfc_init_se (&argse, NULL); + gfc_conv_expr_val (&argse, expr->value.function.actual->next->next->expr); + gfc_add_block_to_block (&se->pre, &argse.pre); + gfc_add_block_to_block (&se->post, &argse.post); + team = fold_convert (pvoid_type_node, argse.expr); + } + else + team = null_pointer_node; + /* Argument-free version: THIS_IMAGE(). */ - if (distance || expr->value.function.actual->expr == NULL) + if (expr->value.function.actual->expr == NULL) { - if (distance) - { - gfc_init_se (&argse, NULL); - gfc_conv_expr_val (&argse, distance); - gfc_add_block_to_block (&se->pre, &argse.pre); - gfc_add_block_to_block (&se->post, &argse.post); - tmp = fold_convert (integer_type_node, argse.expr); - } - else - tmp = integer_zero_node; tmp = build_call_expr_loc (input_location, gfor_fndecl_caf_this_image, 1, - tmp); + team); se->expr = fold_convert (gfc_get_int_type (gfc_default_integer_kind), tmp); return; @@ -1940,8 +1942,8 @@ trans_this_image (gfc_se * se, gfc_expr *expr) */ /* this_image () - 1. */ - tmp = build_call_expr_loc (input_location, gfor_fndecl_caf_this_image, 1, - integer_zero_node); + tmp + = build_call_expr_loc (input_location, gfor_fndecl_caf_this_image, 1, team); tmp = fold_build2_loc (input_location, MINUS_EXPR, type, fold_convert (type, tmp), build_int_cst (type, 1)); if (corank == 1) @@ -2072,7 +2074,8 @@ conv_intrinsic_image_status (gfc_se *se, gfc_expr *expr) } else if (flag_coarray == GFC_FCOARRAY_LIB) tmp = build_call_expr_loc (input_location, gfor_fndecl_caf_image_status, 2, - args[0], build_int_cst (integer_type_node, -1)); + args[0], + num_args < 2 ? null_pointer_node : args[1]); else gcc_unreachable (); @@ -2092,18 +2095,7 @@ conv_intrinsic_team_number (gfc_se *se, gfc_expr *expr) if (flag_coarray == GFC_FCOARRAY_SINGLE && expr->value.function.actual->expr) - { - tree arg; - - arg = gfc_evaluate_now (args[0], &se->pre); - tmp = fold_build2_loc (input_location, EQ_EXPR, logical_type_node, - fold_convert (integer_type_node, arg), - integer_one_node); - tmp = fold_build3_loc (input_location, COND_EXPR, integer_type_node, - tmp, integer_zero_node, - build_int_cst (integer_type_node, - GFC_STAT_STOPPED_IMAGE)); - } + tmp = gfc_evaluate_now (args[0], &se->pre); else if (flag_coarray == GFC_FCOARRAY_SINGLE) { // the value -1 represents that no team has been created yet @@ -2111,10 +2103,10 @@ conv_intrinsic_team_number (gfc_se *se, gfc_expr *expr) } else if (flag_coarray == GFC_FCOARRAY_LIB && expr->value.function.actual->expr) tmp = build_call_expr_loc (input_location, gfor_fndecl_caf_team_number, 1, - args[0], build_int_cst (integer_type_node, -1)); + args[0]); else if (flag_coarray == GFC_FCOARRAY_LIB) tmp = build_call_expr_loc (input_location, gfor_fndecl_caf_team_number, 1, - integer_zero_node, build_int_cst (integer_type_node, -1)); + null_pointer_node); else gcc_unreachable (); @@ -2125,8 +2117,8 @@ conv_intrinsic_team_number (gfc_se *se, gfc_expr *expr) static void trans_image_index (gfc_se * se, gfc_expr *expr) { - tree num_images, cond, coindex, type, lbound, ubound, desc, subdesc, - tmp, invalid_bound; + tree num_images, cond, coindex, type, lbound, ubound, desc, subdesc, tmp, + invalid_bound, team = null_pointer_node, team_number = null_pointer_node; gfc_se argse, subse; int rank, corank, codim; @@ -2150,6 +2142,22 @@ trans_image_index (gfc_se * se, gfc_expr *expr) subdesc = build_fold_indirect_ref_loc (input_location, gfc_conv_descriptor_data_get (subse.expr)); + if (expr->value.function.actual->next->next->expr) + { + gfc_init_se (&argse, NULL); + gfc_conv_expr_descriptor (&argse, + expr->value.function.actual->next->next->expr); + if (expr->value.function.actual->next->next->expr->ts.type == BT_DERIVED) + team = argse.expr; + else + team_number = gfc_build_addr_expr ( + NULL_TREE, + gfc_trans_force_lval (&argse.pre, + fold_convert (integer_type_node, argse.expr))); + gfc_add_block_to_block (&se->pre, &argse.pre); + gfc_add_block_to_block (&se->post, &argse.post); + } + /* Fortran 2008 does not require that the values remain in the cobounds, thus we need explicitly check this - and return 0 if they are exceeded. */ @@ -2225,8 +2233,7 @@ trans_image_index (gfc_se * se, gfc_expr *expr) else { tmp = build_call_expr_loc (input_location, gfor_fndecl_caf_num_images, 2, - integer_zero_node, - build_int_cst (integer_type_node, -1)); + team, team_number); num_images = fold_convert (type, tmp); } @@ -2245,32 +2252,26 @@ trans_image_index (gfc_se * se, gfc_expr *expr) static void trans_num_images (gfc_se * se, gfc_expr *expr) { - tree tmp, distance, failed; + tree tmp, team = null_pointer_node, team_number = null_pointer_node; gfc_se argse; if (expr->value.function.actual->expr) { gfc_init_se (&argse, NULL); gfc_conv_expr_val (&argse, expr->value.function.actual->expr); + if (expr->value.function.actual->expr->ts.type == BT_DERIVED) + team = argse.expr; + else + team_number = gfc_build_addr_expr ( + NULL_TREE, + gfc_trans_force_lval (&se->pre, + fold_convert (integer_type_node, argse.expr))); gfc_add_block_to_block (&se->pre, &argse.pre); gfc_add_block_to_block (&se->post, &argse.post); - distance = fold_convert (integer_type_node, argse.expr); } - else - distance = integer_zero_node; - if (expr->value.function.actual->next->expr) - { - gfc_init_se (&argse, NULL); - gfc_conv_expr_val (&argse, expr->value.function.actual->next->expr); - gfc_add_block_to_block (&se->pre, &argse.pre); - gfc_add_block_to_block (&se->post, &argse.post); - failed = fold_convert (integer_type_node, argse.expr); - } - else - failed = build_int_cst (integer_type_node, -1); tmp = build_call_expr_loc (input_location, gfor_fndecl_caf_num_images, 2, - distance, failed); + team, team_number); se->expr = fold_convert (gfc_get_int_type (gfc_default_integer_kind), tmp); } @@ -2700,8 +2701,7 @@ conv_intrinsic_cobound (gfc_se * se, gfc_expr * expr) cosize = gfc_conv_descriptor_cosize (desc, arg->expr->rank, corank); tmp = build_call_expr_loc (input_location, gfor_fndecl_caf_num_images, - 2, integer_zero_node, - build_int_cst (integer_type_node, -1)); + 2, null_pointer_node, null_pointer_node); tmp = fold_build2_loc (input_location, MINUS_EXPR, gfc_array_index_type, fold_convert (gfc_array_index_type, tmp), @@ -2716,8 +2716,7 @@ conv_intrinsic_cobound (gfc_se * se, gfc_expr * expr) { /* ubound = lbound + num_images() - 1. */ tmp = build_call_expr_loc (input_location, gfor_fndecl_caf_num_images, - 2, integer_zero_node, - build_int_cst (integer_type_node, -1)); + 2, null_pointer_node, null_pointer_node); tmp = fold_build2_loc (input_location, MINUS_EXPR, gfc_array_index_type, fold_convert (gfc_array_index_type, tmp), @@ -3883,6 +3882,13 @@ gfc_conv_intrinsic_funcall (gfc_se * se, gfc_expr * expr) append_args->quick_push (null_pointer_node); } } + /* Non-character scalar reduce returns a pointer to a result of size set by + the element size of 'array'. Setting 'sym' allocatable ensures that the + result is deallocated at the appropriate time. */ + else if (expr->value.function.isym->id == GFC_ISYM_REDUCE + && expr->rank == 0 && expr->ts.type != BT_CHARACTER) + sym->attr.allocatable = 1; + gfc_conv_procedure_call (se, sym, expr->value.function.actual, expr, append_args); @@ -4709,22 +4715,6 @@ maybe_absent_optional_variable (gfc_expr *e) } -/* Remove unneeded kind= argument from actual argument list when the - result conversion is dealt with in a different place. */ - -static void -strip_kind_from_actual (gfc_actual_arglist * actual) -{ - for (gfc_actual_arglist *a = actual; a; a = a->next) - { - if (a && a->name && strcmp (a->name, "kind") == 0) - { - gfc_free_expr (a->expr); - a->expr = NULL; - } - } -} - /* Emit code for minloc or maxloc intrinsic. There are many different cases we need to handle. For performance reasons we sometimes create two loops instead of one, where the second one is much simpler. @@ -4919,7 +4909,7 @@ gfc_conv_intrinsic_minmaxloc (gfc_se * se, gfc_expr * expr, enum tree_code op) tree b_if, b_else; tree back; gfc_loopinfo loop, *ploop; - gfc_actual_arglist *actual, *array_arg, *dim_arg, *mask_arg, *kind_arg; + gfc_actual_arglist *array_arg, *dim_arg, *mask_arg, *kind_arg; gfc_actual_arglist *back_arg; gfc_ss *arrayss = nullptr; gfc_ss *maskss = nullptr; @@ -4938,8 +4928,7 @@ gfc_conv_intrinsic_minmaxloc (gfc_se * se, gfc_expr * expr, enum tree_code op) int n; bool optional_mask; - actual = expr->value.function.actual; - array_arg = actual; + array_arg = expr->value.function.actual; dim_arg = array_arg->next; mask_arg = dim_arg->next; kind_arg = mask_arg->next; @@ -4948,14 +4937,16 @@ gfc_conv_intrinsic_minmaxloc (gfc_se * se, gfc_expr * expr, enum tree_code op) bool dim_present = dim_arg->expr != nullptr; bool nested_loop = dim_present && expr->rank > 0; - /* The last argument, BACK, is passed by value. Ensure that - by setting its name to %VAL. */ - for (gfc_actual_arglist *a = actual; a; a = a->next) + /* Remove kind. */ + if (kind_arg->expr) { - if (a->next == NULL) - a->name = "%VAL"; + gfc_free_expr (kind_arg->expr); + kind_arg->expr = NULL; } + /* Pass BACK argument by value. */ + back_arg->name = "%VAL"; + if (se->ss) { if (se->ss->info->useflags) @@ -4977,25 +4968,19 @@ gfc_conv_intrinsic_minmaxloc (gfc_se * se, gfc_expr * expr, enum tree_code op) } } - arrayexpr = actual->expr; + arrayexpr = array_arg->expr; - /* Special case for character maxloc. Remove unneeded actual - arguments, then call a library function. */ + /* Special case for character maxloc. Remove unneeded "dim" actual + argument, then call a library function. */ if (arrayexpr->ts.type == BT_CHARACTER) { gcc_assert (expr->rank == 0); - gfc_actual_arglist *a = actual; - strip_kind_from_actual (a); - while (a) + if (dim_arg->expr) { - if (a->name && strcmp (a->name, "dim") == 0) - { - gfc_free_expr (a->expr); - a->expr = NULL; - } - a = a->next; + gfc_free_expr (dim_arg->expr); + dim_arg->expr = NULL; } gfc_conv_intrinsic_funcall (se, expr); return; @@ -10806,6 +10791,7 @@ gfc_conv_intrinsic_function (gfc_se * se, gfc_expr * expr) case GFC_ISYM_EOSHIFT: case GFC_ISYM_PACK: case GFC_ISYM_RESHAPE: + case GFC_ISYM_REDUCE: /* For all of those the first argument specifies the type and the third is optional. */ conv_generic_with_optional_char_arg (se, expr, 1, 3); @@ -11467,6 +11453,7 @@ gfc_conv_intrinsic_function (gfc_se * se, gfc_expr * expr) case GFC_ISYM_GETGID: case GFC_ISYM_GETPID: case GFC_ISYM_GETUID: + case GFC_ISYM_GET_TEAM: case GFC_ISYM_HOSTNM: case GFC_ISYM_IERRNO: case GFC_ISYM_IRAND: @@ -11478,6 +11465,7 @@ gfc_conv_intrinsic_function (gfc_se * se, gfc_expr * expr) case GFC_ISYM_MCLOCK: case GFC_ISYM_MCLOCK8: case GFC_ISYM_RAND: + case GFC_ISYM_REDUCE: case GFC_ISYM_RENAME: case GFC_ISYM_SECOND: case GFC_ISYM_SECNDS: @@ -11934,6 +11922,7 @@ gfc_is_intrinsic_libcall (gfc_expr * expr) case GFC_ISYM_FAILED_IMAGES: case GFC_ISYM_STOPPED_IMAGES: case GFC_ISYM_PACK: + case GFC_ISYM_REDUCE: case GFC_ISYM_RESHAPE: case GFC_ISYM_UNPACK: /* Pass absent optional parameters. */ @@ -12960,6 +12949,9 @@ gfc_conv_intrinsic_mvbits (gfc_se *se, gfc_actual_arglist *actual_args, void_type_node, to, se->expr); } +/* Comes from trans-stmt.cc, but we don't want the whole header included. */ +extern void gfc_trans_sync_stat (struct sync_stat *sync_stat, gfc_se *se, + tree *stat, tree *errmsg, tree *errmsg_len); static tree conv_intrinsic_move_alloc (gfc_code *code) @@ -12967,17 +12959,37 @@ conv_intrinsic_move_alloc (gfc_code *code) stmtblock_t block; gfc_expr *from_expr, *to_expr; gfc_se from_se, to_se; - tree tmp, to_tree, from_tree; + tree tmp, to_tree, from_tree, stat, errmsg, errmsg_len, fin_label = NULL_TREE; bool coarray, from_is_class, from_is_scalar; + gfc_actual_arglist *arg = code->ext.actual; + sync_stat tmp_sync_stat = {nullptr, nullptr}; gfc_start_block (&block); - from_expr = code->ext.actual->expr; - to_expr = code->ext.actual->next->expr; + from_expr = arg->expr; + arg = arg->next; + to_expr = arg->expr; + arg = arg->next; + + while (arg) + { + if (arg->expr) + { + if (!strcmp ("stat", arg->name)) + tmp_sync_stat.stat = arg->expr; + else if (!strcmp ("errmsg", arg->name)) + tmp_sync_stat.errmsg = arg->expr; + } + arg = arg->next; + } gfc_init_se (&from_se, NULL); gfc_init_se (&to_se, NULL); + gfc_trans_sync_stat (&tmp_sync_stat, &from_se, &stat, &errmsg, &errmsg_len); + if (stat != null_pointer_node) + fin_label = gfc_build_label_decl (NULL_TREE); + gcc_assert (from_expr->ts.type != BT_CLASS || to_expr->ts.type == BT_CLASS); coarray = from_expr->corank != 0; @@ -13020,9 +13032,10 @@ conv_intrinsic_move_alloc (gfc_code *code) /* Deallocate "to". */ if (to_expr->rank == 0) { - tmp - = gfc_deallocate_scalar_with_status (to_tree, NULL_TREE, NULL_TREE, - true, to_expr, to_expr->ts); + tmp = gfc_deallocate_scalar_with_status (to_tree, stat, fin_label, + true, to_expr, to_expr->ts, + NULL_TREE, false, true, + errmsg, errmsg_len); gfc_add_expr_to_block (&block, tmp); } @@ -13095,9 +13108,12 @@ conv_intrinsic_move_alloc (gfc_code *code) { tree cond; - tmp = gfc_deallocate_with_status (to_se.expr, NULL_TREE, NULL_TREE, - NULL_TREE, NULL_TREE, true, to_expr, - GFC_CAF_COARRAY_DEALLOCATE_ONLY); + tmp = gfc_deallocate_with_status (to_se.expr, stat, errmsg, errmsg_len, + fin_label, true, to_expr, + GFC_CAF_COARRAY_DEALLOCATE_ONLY, + NULL_TREE, NULL_TREE, + gfc_conv_descriptor_token (to_se.expr), + true); gfc_add_expr_to_block (&block, tmp); tmp = gfc_conv_descriptor_data_get (to_se.expr); @@ -13123,9 +13139,10 @@ conv_intrinsic_move_alloc (gfc_code *code) gfc_add_expr_to_block (&block, tmp); } - tmp = gfc_deallocate_with_status (to_se.expr, NULL_TREE, NULL_TREE, - NULL_TREE, NULL_TREE, true, to_expr, - GFC_CAF_COARRAY_NOCOARRAY); + tmp = gfc_deallocate_with_status (to_se.expr, stat, errmsg, errmsg_len, + fin_label, true, to_expr, + GFC_CAF_COARRAY_NOCOARRAY, NULL_TREE, + NULL_TREE, NULL_TREE, true); gfc_add_expr_to_block (&block, tmp); } @@ -13137,6 +13154,13 @@ conv_intrinsic_move_alloc (gfc_code *code) gfc_add_modify_loc (input_location, &block, tmp, fold_convert (TREE_TYPE (tmp), null_pointer_node)); + if (coarray && flag_coarray == GFC_FCOARRAY_LIB) + { + /* Copy the array descriptor data has overwritten the to-token and cleared + from.data. Now also clear the from.token. */ + gfc_add_modify (&block, gfc_conv_descriptor_token (from_se.expr), + null_pointer_node); + } if (to_expr->ts.type == BT_CHARACTER && to_expr->ts.deferred) { @@ -13147,6 +13171,8 @@ conv_intrinsic_move_alloc (gfc_code *code) gfc_add_modify_loc (input_location, &block, from_se.string_length, build_int_cst (TREE_TYPE (from_se.string_length), 0)); } + if (fin_label) + gfc_add_expr_to_block (&block, build1_v (LABEL_EXPR, fin_label)); return gfc_finish_block (&block); } diff --git a/gcc/fortran/trans-openmp.cc b/gcc/fortran/trans-openmp.cc index d1c05d0..a2e70fc 100644 --- a/gcc/fortran/trans-openmp.cc +++ b/gcc/fortran/trans-openmp.cc @@ -25,6 +25,10 @@ along with GCC; see the file COPYING3. If not see #include "options.h" #include "tree.h" #include "gfortran.h" +#include "basic-block.h" +#include "tree-ssa.h" +#include "function.h" +#include "gimple.h" #include "gimple-expr.h" #include "trans.h" #include "stringpool.h" @@ -41,6 +45,8 @@ along with GCC; see the file COPYING3. If not see #include "omp-low.h" #include "memmodel.h" /* For MEMMODEL_ enums. */ #include "dependency.h" +#include "gimple-iterator.h" /* For gsi_iterator_update. */ +#include "gimplify-me.h" /* For force_gimple_operand. */ #undef GCC_DIAG_STYLE #define GCC_DIAG_STYLE __gcc_tdiag__ @@ -375,22 +381,28 @@ gfc_omp_report_decl (tree decl) return decl; } -/* Return true if TYPE has any allocatable components. */ +/* Return true if TYPE has any allocatable components; + if ptr_ok, the decl itself is permitted to have the POINTER attribute. + if shallow_alloc_only, returns only true if any of the fields is an + allocatable; called with true by gfc_omp_replace_alloc_by_to_mapping. */ static bool -gfc_has_alloc_comps (tree type, tree decl) +gfc_has_alloc_comps (tree type, tree decl, bool ptr_ok, + bool shallow_alloc_only=false) { tree field, ftype; if (POINTER_TYPE_P (type)) { - if (GFC_DECL_GET_SCALAR_ALLOCATABLE (decl)) + if (GFC_DECL_GET_SCALAR_ALLOCATABLE (decl) + || (ptr_ok && GFC_DECL_GET_SCALAR_POINTER (decl))) type = TREE_TYPE (type); else if (GFC_DECL_GET_SCALAR_POINTER (decl)) return false; } - if (GFC_DESCRIPTOR_TYPE_P (type) + if (!ptr_ok + && GFC_DESCRIPTOR_TYPE_P (type) && (GFC_TYPE_ARRAY_AKIND (type) == GFC_ARRAY_POINTER || GFC_TYPE_ARRAY_AKIND (type) == GFC_ARRAY_POINTER_CONT)) return false; @@ -409,12 +421,51 @@ gfc_has_alloc_comps (tree type, tree decl) if (GFC_DESCRIPTOR_TYPE_P (ftype) && GFC_TYPE_ARRAY_AKIND (ftype) == GFC_ARRAY_ALLOCATABLE) return true; - if (gfc_has_alloc_comps (ftype, field)) + if (!shallow_alloc_only + && gfc_has_alloc_comps (ftype, field, false)) return true; } return false; } +/* gfc_omp_replace_alloc_by_to_mapping is used with gfc_omp_deep_mapping... to + handle the following: + + For map(alloc: dt), the array descriptors of allocatable components should + be mapped as 'to'; this could be done by (A) adding 'map(to: dt%alloc_comp)' + for each component (and avoiding to increment the reference count). + Or (B) by just mapping all of 'dt' as 'to'. + + If 'dt' contains several allocatable components and not much other data, + (A) is more efficient. If 'dt' contains a large const-size array, (A) will + copy it to the device instead of only 'alloc'ating it. + + IMPLEMENTATION CHOICE: We do (A). It avoids the ref-count issue and it is + expected that, for real-world code, derived types with allocatable + components only have few other components and either no const-size arrays. + This copying is done irrespectively whether the allocatables are allocated. + + If users wanted to save memory, they have to use 'map(alloc:dt%comp)' as + also with 'map(alloc:dt)' all components get copied. + + For the copy to the device, only allocatable arrays are relevant as their + the bounds are required; the pointer is set separately (GOMP_MAP_ATTACH) + and the only setting required for scalars. However, when later copying out + of the device, an unallocated allocatable must remain unallocated/NULL on + the host; to achieve this we also must have it set to NULL on the device + to avoid issues with uninitialized memory being copied back for the pointer + address. If we could set the pointer to NULL, gfc_has_alloc_comps's + shallow_alloc_only could be restricted to return true only for arrays. + + We only need to return true if there are allocatable-array components. */ + +static bool +gfc_omp_replace_alloc_by_to_mapping (tree type, tree decl, bool ptr_ok) +{ + return gfc_has_alloc_comps (type, decl, ptr_ok, true); +} + + /* Return true if TYPE is polymorphic but not with pointer attribute. */ static bool @@ -487,7 +538,7 @@ gfc_omp_private_outer_ref (tree decl) if (GFC_DECL_GET_SCALAR_ALLOCATABLE (decl)) return true; - if (gfc_has_alloc_comps (type, decl)) + if (gfc_has_alloc_comps (type, decl, false)) return true; return false; @@ -627,7 +678,7 @@ gfc_walk_alloc_comps (tree decl, tree dest, tree var, { tree ftype = TREE_TYPE (field); tree declf, destf = NULL_TREE; - bool has_alloc_comps = gfc_has_alloc_comps (ftype, field); + bool has_alloc_comps = gfc_has_alloc_comps (ftype, field, false); if ((!GFC_DESCRIPTOR_TYPE_P (ftype) || GFC_TYPE_ARRAY_AKIND (ftype) != GFC_ARRAY_ALLOCATABLE) && !GFC_DECL_GET_SCALAR_ALLOCATABLE (field) @@ -751,7 +802,7 @@ gfc_omp_clause_default_ctor (tree clause, tree decl, tree outer) && (!GFC_DECL_GET_SCALAR_ALLOCATABLE (OMP_CLAUSE_DECL (clause)) || !POINTER_TYPE_P (type))) { - if (gfc_has_alloc_comps (type, OMP_CLAUSE_DECL (clause))) + if (gfc_has_alloc_comps (type, OMP_CLAUSE_DECL (clause), false)) { gcc_assert (outer); gfc_start_block (&block); @@ -804,7 +855,7 @@ gfc_omp_clause_default_ctor (tree clause, tree decl, tree outer) else gfc_add_modify (&cond_block, unshare_expr (decl), fold_convert (TREE_TYPE (decl), ptr)); - if (gfc_has_alloc_comps (type, OMP_CLAUSE_DECL (clause))) + if (gfc_has_alloc_comps (type, OMP_CLAUSE_DECL (clause), false)) { tree tem = gfc_walk_alloc_comps (outer, decl, OMP_CLAUSE_DECL (clause), @@ -945,7 +996,7 @@ gfc_omp_clause_copy_ctor (tree clause, tree dest, tree src) && (!GFC_DECL_GET_SCALAR_ALLOCATABLE (OMP_CLAUSE_DECL (clause)) || !POINTER_TYPE_P (type))) { - if (gfc_has_alloc_comps (type, OMP_CLAUSE_DECL (clause))) + if (gfc_has_alloc_comps (type, OMP_CLAUSE_DECL (clause), false)) { gfc_start_block (&block); gfc_add_modify (&block, dest, src); @@ -1004,7 +1055,7 @@ gfc_omp_clause_copy_ctor (tree clause, tree dest, tree src) builtin_decl_explicit (BUILT_IN_MEMCPY), 3, ptr, srcptr, size); gfc_add_expr_to_block (&cond_block, fold_convert (void_type_node, call)); - if (gfc_has_alloc_comps (type, OMP_CLAUSE_DECL (clause))) + if (gfc_has_alloc_comps (type, OMP_CLAUSE_DECL (clause), false)) { tree tem = gfc_walk_alloc_comps (src, dest, OMP_CLAUSE_DECL (clause), @@ -1049,7 +1100,7 @@ gfc_omp_clause_assign_op (tree clause, tree dest, tree src) && (!GFC_DECL_GET_SCALAR_ALLOCATABLE (OMP_CLAUSE_DECL (clause)) || !POINTER_TYPE_P (type))) { - if (gfc_has_alloc_comps (type, OMP_CLAUSE_DECL (clause))) + if (gfc_has_alloc_comps (type, OMP_CLAUSE_DECL (clause), false)) { gfc_start_block (&block); /* First dealloc any allocatable components in DEST. */ @@ -1071,7 +1122,7 @@ gfc_omp_clause_assign_op (tree clause, tree dest, tree src) gfc_start_block (&block); - if (gfc_has_alloc_comps (type, OMP_CLAUSE_DECL (clause))) + if (gfc_has_alloc_comps (type, OMP_CLAUSE_DECL (clause), false)) { then_b = gfc_walk_alloc_comps (dest, NULL_TREE, OMP_CLAUSE_DECL (clause), WALK_ALLOC_COMPS_DTOR); @@ -1186,7 +1237,7 @@ gfc_omp_clause_assign_op (tree clause, tree dest, tree src) builtin_decl_explicit (BUILT_IN_MEMCPY), 3, ptr, srcptr, size); gfc_add_expr_to_block (&cond_block, fold_convert (void_type_node, call)); - if (gfc_has_alloc_comps (type, OMP_CLAUSE_DECL (clause))) + if (gfc_has_alloc_comps (type, OMP_CLAUSE_DECL (clause), false)) { tree tem = gfc_walk_alloc_comps (src, dest, OMP_CLAUSE_DECL (clause), @@ -1438,7 +1489,7 @@ gfc_omp_clause_dtor (tree clause, tree decl) && (!GFC_DECL_GET_SCALAR_ALLOCATABLE (OMP_CLAUSE_DECL (clause)) || !POINTER_TYPE_P (type))) { - if (gfc_has_alloc_comps (type, OMP_CLAUSE_DECL (clause))) + if (gfc_has_alloc_comps (type, OMP_CLAUSE_DECL (clause), false)) return gfc_walk_alloc_comps (decl, NULL_TREE, OMP_CLAUSE_DECL (clause), WALK_ALLOC_COMPS_DTOR); @@ -1458,7 +1509,7 @@ gfc_omp_clause_dtor (tree clause, tree decl) tem = gfc_call_free (decl); tem = gfc_omp_unshare_expr (tem); - if (gfc_has_alloc_comps (type, OMP_CLAUSE_DECL (clause))) + if (gfc_has_alloc_comps (type, OMP_CLAUSE_DECL (clause), false)) { stmtblock_t block; tree then_b; @@ -1538,6 +1589,7 @@ gfc_omp_finish_clause (tree c, gimple_seq *pre_p, bool openacc) return; tree decl = OMP_CLAUSE_DECL (c); + location_t loc = OMP_CLAUSE_LOCATION (c); /* Assumed-size arrays can't be mapped implicitly, they have to be mapped explicitly using array sections. */ @@ -1553,13 +1605,9 @@ gfc_omp_finish_clause (tree c, gimple_seq *pre_p, bool openacc) return; } - if (!openacc && GFC_CLASS_TYPE_P (TREE_TYPE (decl))) - warning_at (OMP_CLAUSE_LOCATION (c), OPT_Wopenmp, - "Implicit mapping of polymorphic variable %qD is " - "unspecified behavior", decl); - tree c2 = NULL_TREE, c3 = NULL_TREE, c4 = NULL_TREE; tree present = gfc_omp_check_optional_argument (decl, true); + tree orig_decl = NULL_TREE; if (POINTER_TYPE_P (TREE_TYPE (decl))) { if (!gfc_omp_privatize_by_reference (decl) @@ -1568,7 +1616,7 @@ gfc_omp_finish_clause (tree c, gimple_seq *pre_p, bool openacc) && !GFC_DECL_CRAY_POINTEE (decl) && !GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (TREE_TYPE (decl)))) return; - tree orig_decl = decl; + orig_decl = decl; c4 = build_omp_clause (OMP_CLAUSE_LOCATION (c), OMP_CLAUSE_MAP); OMP_CLAUSE_SET_MAP_KIND (c4, GOMP_MAP_POINTER); @@ -1579,16 +1627,16 @@ gfc_omp_finish_clause (tree c, gimple_seq *pre_p, bool openacc) && (GFC_DECL_GET_SCALAR_POINTER (orig_decl) || GFC_DECL_GET_SCALAR_ALLOCATABLE (orig_decl))) { - c2 = build_omp_clause (input_location, OMP_CLAUSE_MAP); + c2 = build_omp_clause (loc, OMP_CLAUSE_MAP); OMP_CLAUSE_SET_MAP_KIND (c2, GOMP_MAP_POINTER); - OMP_CLAUSE_DECL (c2) = decl; + OMP_CLAUSE_DECL (c2) = unshare_expr (decl); OMP_CLAUSE_SIZE (c2) = size_int (0); stmtblock_t block; gfc_start_block (&block); - tree ptr = decl; - ptr = gfc_build_cond_assign_expr (&block, present, decl, - null_pointer_node); + tree ptr = gfc_build_cond_assign_expr (&block, present, + unshare_expr (decl), + null_pointer_node); gimplify_and_add (gfc_finish_block (&block), pre_p); ptr = build_fold_indirect_ref (ptr); OMP_CLAUSE_DECL (c) = ptr; @@ -1605,10 +1653,10 @@ gfc_omp_finish_clause (tree c, gimple_seq *pre_p, bool openacc) { c3 = build_omp_clause (OMP_CLAUSE_LOCATION (c), OMP_CLAUSE_MAP); OMP_CLAUSE_SET_MAP_KIND (c3, GOMP_MAP_POINTER); - OMP_CLAUSE_DECL (c3) = unshare_expr (decl); + OMP_CLAUSE_DECL (c3) = decl; OMP_CLAUSE_SIZE (c3) = size_int (0); decl = build_fold_indirect_ref (decl); - OMP_CLAUSE_DECL (c) = decl; + OMP_CLAUSE_DECL (c) = unshare_expr (decl); } } if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (decl))) @@ -1634,7 +1682,7 @@ gfc_omp_finish_clause (tree c, gimple_seq *pre_p, bool openacc) gcc_assert (POINTER_TYPE_P (TREE_TYPE (ptr))); ptr = build_fold_indirect_ref (ptr); OMP_CLAUSE_DECL (c) = ptr; - c2 = build_omp_clause (input_location, OMP_CLAUSE_MAP); + c2 = build_omp_clause (loc, OMP_CLAUSE_MAP); OMP_CLAUSE_SET_MAP_KIND (c2, GOMP_MAP_TO_PSET); if (present) { @@ -1651,7 +1699,7 @@ gfc_omp_finish_clause (tree c, gimple_seq *pre_p, bool openacc) : GOMP_MAP_POINTER); if (present) { - ptr = gfc_conv_descriptor_data_get (decl); + ptr = gfc_conv_descriptor_data_get (unshare_expr (decl)); ptr = gfc_build_addr_expr (NULL, ptr); ptr = gfc_build_cond_assign_expr (&block, present, ptr, null_pointer_node); @@ -1664,6 +1712,17 @@ gfc_omp_finish_clause (tree c, gimple_seq *pre_p, bool openacc) tree size = create_tmp_var (gfc_array_index_type); tree elemsz = TYPE_SIZE_UNIT (gfc_get_element_type (type)); elemsz = fold_convert (gfc_array_index_type, elemsz); + + if (orig_decl == NULL_TREE) + orig_decl = decl; + if (!openacc + && gfc_has_alloc_comps (type, orig_decl, true)) + { + /* Save array descriptor for use in gfc_omp_deep_mapping{,_p,_cnt}; + force evaluate to ensure that it is not gimplified + is a decl. */ + gfc_allocate_lang_decl (size); + GFC_DECL_SAVED_DESCRIPTOR (size) = orig_decl; + } enum gfc_array_kind akind = GFC_TYPE_ARRAY_AKIND (type); if (akind == GFC_ARRAY_ALLOCATABLE || akind == GFC_ARRAY_POINTER @@ -1692,14 +1751,14 @@ gfc_omp_finish_clause (tree c, gimple_seq *pre_p, bool openacc) else_b = gfc_finish_block (&cond_block); tem = gfc_conv_descriptor_data_get (unshare_expr (decl)); tem = fold_convert (pvoid_type_node, tem); - cond = fold_build2_loc (input_location, NE_EXPR, + cond = fold_build2_loc (loc, NE_EXPR, boolean_type_node, tem, null_pointer_node); if (present) { - cond = fold_build2_loc (input_location, TRUTH_ANDIF_EXPR, + cond = fold_build2_loc (loc, TRUTH_ANDIF_EXPR, boolean_type_node, present, cond); } - gfc_add_expr_to_block (&block, build3_loc (input_location, COND_EXPR, + gfc_add_expr_to_block (&block, build3_loc (loc, COND_EXPR, void_type_node, cond, then_b, else_b)); } @@ -1739,11 +1798,30 @@ gfc_omp_finish_clause (tree c, gimple_seq *pre_p, bool openacc) tree stmt = gfc_finish_block (&block); gimplify_and_add (stmt, pre_p); } + else + { + if (OMP_CLAUSE_SIZE (c) == NULL_TREE) + OMP_CLAUSE_SIZE (c) + = DECL_P (decl) ? DECL_SIZE_UNIT (decl) + : TYPE_SIZE_UNIT (TREE_TYPE (decl)); + + tree type = TREE_TYPE (decl); + if (POINTER_TYPE_P (type) && POINTER_TYPE_P (TREE_TYPE (type))) + type = TREE_TYPE (type); + if (!openacc + && orig_decl != NULL_TREE + && gfc_has_alloc_comps (type, orig_decl, true)) + { + /* Save array descriptor for use in gfc_omp_deep_mapping{,_p,_cnt}; + force evaluate to ensure that it is not gimplified + is a decl. */ + tree size = create_tmp_var (TREE_TYPE (OMP_CLAUSE_SIZE (c))); + gfc_allocate_lang_decl (size); + GFC_DECL_SAVED_DESCRIPTOR (size) = orig_decl; + gimplify_assign (size, OMP_CLAUSE_SIZE (c), pre_p); + OMP_CLAUSE_SIZE (c) = size; + } + } tree last = c; - if (OMP_CLAUSE_SIZE (c) == NULL_TREE) - OMP_CLAUSE_SIZE (c) - = DECL_P (decl) ? DECL_SIZE_UNIT (decl) - : TYPE_SIZE_UNIT (TREE_TYPE (decl)); if (gimplify_expr (&OMP_CLAUSE_SIZE (c), pre_p, NULL, is_gimple_val, fb_rvalue) == GS_ERROR) OMP_CLAUSE_SIZE (c) = size_int (0); @@ -1767,6 +1845,735 @@ gfc_omp_finish_clause (tree c, gimple_seq *pre_p, bool openacc) } +/* map(<flag>: data [len: <size>]) + map(attach: &data [bias: <bias>]) + offset += 2; offset_data += 2 */ +static void +gfc_omp_deep_mapping_map (tree data, tree size, unsigned HOST_WIDE_INT tkind, + location_t loc, tree data_array, tree sizes_array, + tree kinds_array, tree offset_data, tree offset, + gimple_seq *seq, const gimple *ctx) +{ + tree one = build_int_cst (size_type_node, 1); + + STRIP_NOPS (data); + if (!POINTER_TYPE_P (TREE_TYPE (data))) + { + gcc_assert (TREE_CODE (data) == INDIRECT_REF); + data = TREE_OPERAND (data, 0); + } + + /* data_array[offset_data] = data; */ + tree tmp = build4 (ARRAY_REF, TREE_TYPE (TREE_TYPE (data_array)), + unshare_expr (data_array), offset_data, + NULL_TREE, NULL_TREE); + gimplify_assign (tmp, data, seq); + + /* offset_data++ */ + tmp = build2_loc (loc, PLUS_EXPR, size_type_node, offset_data, one); + gimplify_assign (offset_data, tmp, seq); + + /* data_array[offset_data] = &data; */ + tmp = build4 (ARRAY_REF, TREE_TYPE (TREE_TYPE (data_array)), + unshare_expr (data_array), + offset_data, NULL_TREE, NULL_TREE); + gimplify_assign (tmp, build_fold_addr_expr (data), seq); + + /* offset_data++ */ + tmp = build2_loc (loc, PLUS_EXPR, size_type_node, offset_data, one); + gimplify_assign (offset_data, tmp, seq); + + /* sizes_array[offset] = size */ + tmp = build2_loc (loc, MULT_EXPR, size_type_node, + TYPE_SIZE_UNIT (size_type_node), offset); + tmp = build2_loc (loc, POINTER_PLUS_EXPR, TREE_TYPE (sizes_array), + sizes_array, tmp); + gimple_seq seq2 = NULL; + tmp = force_gimple_operand (tmp, &seq2, true, NULL_TREE); + gimple_seq_add_seq (seq, seq2); + tmp = build_fold_indirect_ref_loc (loc, tmp); + gimplify_assign (tmp, size, seq); + + /* FIXME: tkind |= talign << talign_shift; */ + /* kinds_array[offset] = tkind. */ + tmp = build2_loc (loc, MULT_EXPR, size_type_node, + TYPE_SIZE_UNIT (short_unsigned_type_node), offset); + tmp = build2_loc (loc, POINTER_PLUS_EXPR, TREE_TYPE (kinds_array), + kinds_array, tmp); + seq2 = NULL; + tmp = force_gimple_operand (tmp, &seq2, true, NULL_TREE); + gimple_seq_add_seq (seq, seq2); + tmp = build_fold_indirect_ref_loc (loc, tmp); + gimplify_assign (tmp, build_int_cst (short_unsigned_type_node, tkind), seq); + + /* offset++ */ + tmp = build2_loc (loc, PLUS_EXPR, size_type_node, offset, one); + gimplify_assign (offset, tmp, seq); + + /* sizes_array[offset] = bias (= 0). */ + tmp = build2_loc (loc, MULT_EXPR, size_type_node, + TYPE_SIZE_UNIT (size_type_node), offset); + tmp = build2_loc (loc, POINTER_PLUS_EXPR, TREE_TYPE (sizes_array), + sizes_array, tmp); + seq2 = NULL; + tmp = force_gimple_operand (tmp, &seq2, true, NULL_TREE); + gimple_seq_add_seq (seq, seq2); + tmp = build_fold_indirect_ref_loc (loc, tmp); + gimplify_assign (tmp, build_zero_cst (size_type_node), seq); + + gcc_assert (gimple_code (ctx) == GIMPLE_OMP_TARGET); + tkind = (gimple_omp_target_kind (ctx) == GF_OMP_TARGET_KIND_EXIT_DATA + ? GOMP_MAP_DETACH : GOMP_MAP_ATTACH); + + /* kinds_array[offset] = tkind. */ + tmp = build2_loc (loc, MULT_EXPR, size_type_node, + TYPE_SIZE_UNIT (short_unsigned_type_node), offset); + tmp = build2_loc (loc, POINTER_PLUS_EXPR, TREE_TYPE (kinds_array), + kinds_array, tmp); + seq2 = NULL; + tmp = force_gimple_operand (tmp, &seq2, true, NULL_TREE); + gimple_seq_add_seq (seq, seq2); + tmp = build_fold_indirect_ref_loc (loc, tmp); + gimplify_assign (tmp, build_int_cst (short_unsigned_type_node, tkind), seq); + + /* offset++ */ + tmp = build2_loc (loc, PLUS_EXPR, size_type_node, offset, one); + gimplify_assign (offset, tmp, seq); +} + +static void gfc_omp_deep_mapping_item (bool, bool, bool, location_t, tree, + tree *, unsigned HOST_WIDE_INT, tree, + tree, tree, tree, tree, tree, + gimple_seq *, const gimple *, bool *); + +/* Map allocatable components. */ +static void +gfc_omp_deep_mapping_comps (bool is_cnt, location_t loc, tree decl, + tree *token, unsigned HOST_WIDE_INT tkind, + tree data_array, tree sizes_array, tree kinds_array, + tree offset_data, tree offset, tree num, + gimple_seq *seq, const gimple *ctx, + bool *poly_warned) +{ + tree type = TREE_TYPE (decl); + if (TREE_CODE (type) != RECORD_TYPE) + return; + for (tree field = TYPE_FIELDS (type); field; field = DECL_CHAIN (field)) + { + type = TREE_TYPE (field); + if (gfc_is_polymorphic_nonptr (type) + || GFC_DECL_GET_SCALAR_ALLOCATABLE (field) + || (GFC_DESCRIPTOR_TYPE_P (type) + && GFC_TYPE_ARRAY_AKIND (type) == GFC_ARRAY_ALLOCATABLE)) + { + tree tmp = fold_build3_loc (loc, COMPONENT_REF, TREE_TYPE (field), + decl, field, NULL_TREE); + gfc_omp_deep_mapping_item (is_cnt, true, true, loc, tmp, token, + tkind, data_array, sizes_array, + kinds_array, offset_data, offset, num, + seq, ctx, poly_warned); + } + else if (GFC_DECL_GET_SCALAR_POINTER (field) + || GFC_DESCRIPTOR_TYPE_P (type)) + continue; + else if (gfc_has_alloc_comps (TREE_TYPE (field), field, false)) + { + tree tmp = fold_build3_loc (loc, COMPONENT_REF, TREE_TYPE (field), + decl, field, NULL_TREE); + if (TREE_CODE (TREE_TYPE (tmp)) == ARRAY_TYPE) + gfc_omp_deep_mapping_item (is_cnt, false, false, loc, tmp, + token, tkind, data_array, sizes_array, + kinds_array, offset_data, offset, num, + seq, ctx, poly_warned); + else + gfc_omp_deep_mapping_comps (is_cnt, loc, tmp, token, tkind, + data_array, sizes_array, kinds_array, + offset_data, offset, num, seq, ctx, + poly_warned); + } + } +} + +static void +gfc_omp_gen_simple_loop (tree var, tree begin, tree end, enum tree_code cond, + tree step, location_t loc, gimple_seq *seq1, + gimple_seq *seq2) +{ + tree tmp; + + /* var = begin. */ + gimplify_assign (var, begin, seq1); + + /* Loop: for (var = begin; var <cond> end; var += step). */ + tree label_loop = create_artificial_label (loc); + tree label_cond = create_artificial_label (loc); + + gimplify_and_add (fold_build1_loc (loc, GOTO_EXPR, void_type_node, + label_cond), seq1); + gimple_seq_add_stmt (seq1, gimple_build_label (label_loop)); + + /* Everything above is seq1; place loop body here. */ + + /* End of loop body -> put into seq2. */ + tmp = fold_build2_loc (loc, PLUS_EXPR, TREE_TYPE (var), var, step); + gimplify_assign (var, tmp, seq2); + gimple_seq_add_stmt (seq2, gimple_build_label (label_cond)); + tmp = fold_build2_loc (loc, cond, boolean_type_node, var, end); + tmp = build3_v (COND_EXPR, tmp, build1_v (GOTO_EXPR, label_loop), + build_empty_stmt (loc)); + gimplify_and_add (tmp, seq2); +} + +/* Return size variable with the size of an array. */ +static tree +gfc_omp_get_array_size (location_t loc, tree desc, gimple_seq *seq) +{ + tree tmp; + gimple_seq seq1 = NULL, seq2 = NULL; + tree size = build_decl (loc, VAR_DECL, create_tmp_var_name ("size"), + size_type_node); + tree extent = build_decl (loc, VAR_DECL, create_tmp_var_name ("extent"), + gfc_array_index_type); + tree idx = build_decl (loc, VAR_DECL, create_tmp_var_name ("idx"), + signed_char_type_node); + + tree begin = build_zero_cst (signed_char_type_node); + tree end; + if (GFC_TYPE_ARRAY_AKIND (TREE_TYPE (desc)) == GFC_ARRAY_ASSUMED_SHAPE_CONT + || GFC_TYPE_ARRAY_AKIND (TREE_TYPE (desc)) == GFC_ARRAY_ASSUMED_SHAPE) + end = gfc_conv_descriptor_rank (desc); + else + end = build_int_cst (signed_char_type_node, + GFC_TYPE_ARRAY_RANK (TREE_TYPE (desc))); + tree step = build_int_cst (signed_char_type_node, 1); + + /* size = 0 + for (idx = 0; idx < rank; idx++) + extent = gfc->dim[i].ubound - gfc->dim[i].lbound + 1 + if (extent < 0) extent = 0 + size *= extent. */ + gimplify_assign (size, build_int_cst (size_type_node, 1), seq); + + gfc_omp_gen_simple_loop (idx, begin, end, LT_EXPR, step, loc, &seq1, &seq2); + gimple_seq_add_seq (seq, seq1); + + tmp = fold_build2_loc (loc, MINUS_EXPR, gfc_array_index_type, + gfc_conv_descriptor_ubound_get (desc, idx), + gfc_conv_descriptor_lbound_get (desc, idx)); + tmp = fold_build2_loc (loc, PLUS_EXPR, gfc_array_index_type, + tmp, gfc_index_one_node); + gimplify_assign (extent, tmp, seq); + tmp = fold_build2_loc (loc, LT_EXPR, boolean_type_node, + extent, gfc_index_zero_node); + tmp = build3_v (COND_EXPR, tmp, + fold_build2_loc (loc, MODIFY_EXPR, + gfc_array_index_type, + extent, gfc_index_zero_node), + build_empty_stmt (loc)); + gimplify_and_add (tmp, seq); + /* size *= extent. */ + gimplify_assign (size, fold_build2_loc (loc, MULT_EXPR, size_type_node, size, + fold_convert (size_type_node, + extent)), seq); + gimple_seq_add_seq (seq, seq2); + return size; +} + +/* Generate loop to access every array element; takes addr of first element + (decl's data comp); returns loop code in seq1 + seq2 + and the pointer to the element as return value. */ +static tree +gfc_omp_elmental_loop (location_t loc, tree decl, tree size, tree elem_len, + gimple_seq *seq1, gimple_seq *seq2) +{ + tree idx = build_decl (loc, VAR_DECL, create_tmp_var_name ("idx"), + size_type_node); + tree begin = build_zero_cst (size_type_node); + tree end = size; + tree step = build_int_cst (size_type_node, 1); + tree ptr; + + gfc_omp_gen_simple_loop (idx, begin, end, LT_EXPR, step, loc, seq1, seq2); + + tree type = TREE_TYPE (decl); + if (POINTER_TYPE_P (type)) + { + type = TREE_TYPE (type); + gcc_assert (TREE_CODE (type) == ARRAY_TYPE); + decl = fold_convert (build_pointer_type (TREE_TYPE (type)), decl); + } + else + { + gcc_assert (TREE_CODE (type) == ARRAY_TYPE); + decl = build_fold_addr_expr_loc (loc, decl); + } + decl = fold_convert (build_pointer_type (TREE_TYPE (type)), decl); + tree tmp = build2_loc (loc, MULT_EXPR, size_type_node, idx, + fold_convert (size_type_node, elem_len)); + ptr = build2_loc (loc, POINTER_PLUS_EXPR, TREE_TYPE (decl), decl, tmp); + gimple_seq seq3 = NULL; + ptr = force_gimple_operand (ptr, &seq3, true, NULL_TREE); + gimple_seq_add_seq (seq1, seq3); + + return ptr; +} + + +/* If do_copy, copy data pointer and vptr (if applicable) as well. + Otherwise, only handle allocatable components. + do_copy == false can happen only with nonpolymorphic arguments + to a copy clause. + if (is_cnt) token ... offset is ignored and num is used, otherwise + num is NULL_TREE and unused. */ + +static void +gfc_omp_deep_mapping_item (bool is_cnt, bool do_copy, bool do_alloc_check, + location_t loc, tree decl, tree *token, + unsigned HOST_WIDE_INT tkind, tree data_array, + tree sizes_array, tree kinds_array, tree offset_data, + tree offset, tree num, gimple_seq *seq, + const gimple *ctx, bool *poly_warned) +{ + tree tmp; + tree type = TREE_TYPE (decl); + if (POINTER_TYPE_P (type)) + type = TREE_TYPE (type); + tree end_label = NULL_TREE; + tree size = NULL_TREE, elem_len = NULL_TREE; + + bool poly = gfc_is_polymorphic_nonptr (type); + if (poly && is_cnt && !*poly_warned) + { + if (gfc_is_unlimited_polymorphic_nonptr (type)) + error_at (loc, + "Mapping of unlimited polymorphic list item %qD is " + "unspecified behavior and unsupported", decl); + + else + warning_at (loc, OPT_Wopenmp, + "Mapping of polymorphic list item %qD is " + "unspecified behavior", decl); + *poly_warned = true; + } + if (do_alloc_check) + { + tree then_label = create_artificial_label (loc); + end_label = create_artificial_label (loc); + tmp = decl; + if (TREE_CODE (TREE_TYPE (tmp)) == REFERENCE_TYPE + || (POINTER_TYPE_P (TREE_TYPE (tmp)) + && (POINTER_TYPE_P (TREE_TYPE (TREE_TYPE (tmp))) + || GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (TREE_TYPE (tmp)))))) + tmp = build_fold_indirect_ref_loc (loc, tmp); + if (poly) + tmp = gfc_class_data_get (tmp); + if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (tmp))) + tmp = gfc_conv_descriptor_data_get (tmp); + gimple_seq seq2 = NULL; + tmp = force_gimple_operand (tmp, &seq2, true, NULL_TREE); + gimple_seq_add_seq (seq, seq2); + + gimple_seq_add_stmt (seq, + gimple_build_cond (NE_EXPR, tmp, null_pointer_node, + then_label, end_label)); + gimple_seq_add_stmt (seq, gimple_build_label (then_label)); + } + tree class_decl = decl; + if (poly) + { + decl = gfc_class_data_get (decl); + type = TREE_TYPE (decl); + } + if (POINTER_TYPE_P (TREE_TYPE (decl))) + { + decl = build_fold_indirect_ref (decl); + type = TREE_TYPE (decl); + } + + if (is_cnt && do_copy) + { + tree tmp = fold_build2_loc (loc, PLUS_EXPR, size_type_node, + num, build_int_cst (size_type_node, 1)); + gimplify_assign (num, tmp, seq); + } + else if (do_copy) + { + /* copy data pointer */ + tree bytesize; + if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (decl))) + { + /* TODO: Optimization: Shouldn't this be an expr. const, except for + deferred-length strings. (Cf. also below). */ + elem_len = (poly ? gfc_class_vtab_size_get (class_decl) + : gfc_conv_descriptor_elem_len (decl)); + tmp = (POINTER_TYPE_P (TREE_TYPE (decl)) + ? build_fold_indirect_ref (decl) : decl); + size = gfc_omp_get_array_size (loc, tmp, seq); + bytesize = fold_build2_loc (loc, MULT_EXPR, size_type_node, + fold_convert (size_type_node, size), + fold_convert (size_type_node, elem_len)); + tmp = gfc_conv_descriptor_data_get (decl); + } + else if (poly) + { + tmp = decl; + bytesize = fold_convert (size_type_node, + gfc_class_vtab_size_get (class_decl)); + } + else + { + tmp = decl; + bytesize = TYPE_SIZE_UNIT (TREE_TYPE (decl)); + } + unsigned HOST_WIDE_INT tkind2 = tkind; + if (!is_cnt + && (tkind == GOMP_MAP_ALLOC + || (tkind == GOMP_MAP_FROM + && (gimple_omp_target_kind (ctx) + != GF_OMP_TARGET_KIND_EXIT_DATA))) + && gfc_omp_replace_alloc_by_to_mapping (TREE_TYPE (decl), decl, true)) + tkind2 = tkind == GOMP_MAP_ALLOC ? GOMP_MAP_TO : GOMP_MAP_TOFROM; + + gfc_omp_deep_mapping_map (tmp, bytesize, tkind2, loc, data_array, + sizes_array, kinds_array, offset_data, + offset, seq, ctx); + } + + tmp = decl; + if (POINTER_TYPE_P (TREE_TYPE (decl))) + while (TREE_CODE (tmp) == COMPONENT_REF || TREE_CODE (tmp) == ARRAY_REF) + tmp = TREE_OPERAND (tmp, TREE_CODE (tmp) == COMPONENT_REF ? 1 : 0); + if (poly || gfc_has_alloc_comps (type, tmp, true)) + { + gimple_seq seq2 = NULL; + if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (decl))) + { + if (elem_len == NULL_TREE) + { + elem_len = gfc_conv_descriptor_elem_len (decl); + size = fold_convert (size_type_node, + gfc_omp_get_array_size (loc, decl, seq)); + } + decl = gfc_conv_descriptor_data_get (decl); + decl = gfc_omp_elmental_loop (loc, decl, size, elem_len, seq, &seq2); + decl = build_fold_indirect_ref_loc (loc, decl); + } + else if (TREE_CODE (TREE_TYPE (tmp)) == ARRAY_TYPE) + { + type = TREE_TYPE (tmp); + /* FIXME: PR95868 - for var%str of deferred length, elem_len == 0; + len is stored as var%_str_length, but not in GFC_DECL_STRING_LEN + nor in TYPE_SIZE_UNIT as expression. */ + elem_len = TYPE_SIZE_UNIT (TREE_TYPE (type)); + size = fold_convert (size_type_node, GFC_TYPE_ARRAY_SIZE (type)); + decl = gfc_omp_elmental_loop (loc, decl, size, elem_len, seq, &seq2); + decl = build_fold_indirect_ref_loc (loc, decl); + } + else if (POINTER_TYPE_P (TREE_TYPE (decl))) + decl = build_fold_indirect_ref (decl); + + gfc_omp_deep_mapping_comps (is_cnt, loc, decl, token, tkind, + data_array, sizes_array, kinds_array, + offset_data, offset, num, seq, ctx, + poly_warned); + gimple_seq_add_seq (seq, seq2); + } + if (end_label) + gimple_seq_add_stmt (seq, gimple_build_label (end_label)); +} + + +/* Which map types to check/handle for deep mapping. */ +static bool +gfc_omp_deep_map_kind_p (tree clause) +{ + switch (OMP_CLAUSE_CODE (clause)) + { + case OMP_CLAUSE_MAP: + break; + case OMP_CLAUSE_FIRSTPRIVATE: + case OMP_CLAUSE_TO: + case OMP_CLAUSE_FROM: + return true; + default: + gcc_unreachable (); + } + + switch (OMP_CLAUSE_MAP_KIND (clause)) + { + case GOMP_MAP_TO: + case GOMP_MAP_FROM: + case GOMP_MAP_TOFROM: + case GOMP_MAP_ALWAYS_TO: + case GOMP_MAP_ALWAYS_FROM: + case GOMP_MAP_ALWAYS_TOFROM: + case GOMP_MAP_ALWAYS_PRESENT_FROM: + case GOMP_MAP_ALWAYS_PRESENT_TO: + case GOMP_MAP_ALWAYS_PRESENT_TOFROM: + case GOMP_MAP_FIRSTPRIVATE: + case GOMP_MAP_ALLOC: + return true; + case GOMP_MAP_POINTER: + case GOMP_MAP_TO_PSET: + case GOMP_MAP_FORCE_PRESENT: + case GOMP_MAP_DELETE: + case GOMP_MAP_FORCE_DEVICEPTR: + case GOMP_MAP_DEVICE_RESIDENT: + case GOMP_MAP_LINK: + case GOMP_MAP_IF_PRESENT: + case GOMP_MAP_PRESENT_ALLOC: + case GOMP_MAP_PRESENT_FROM: + case GOMP_MAP_PRESENT_TO: + case GOMP_MAP_PRESENT_TOFROM: + case GOMP_MAP_FIRSTPRIVATE_INT: + case GOMP_MAP_USE_DEVICE_PTR: + case GOMP_MAP_ZERO_LEN_ARRAY_SECTION: + case GOMP_MAP_FORCE_ALLOC: + case GOMP_MAP_FORCE_TO: + case GOMP_MAP_FORCE_FROM: + case GOMP_MAP_FORCE_TOFROM: + case GOMP_MAP_USE_DEVICE_PTR_IF_PRESENT: + case GOMP_MAP_STRUCT: + case GOMP_MAP_STRUCT_UNORD: + case GOMP_MAP_ALWAYS_POINTER: + case GOMP_MAP_POINTER_TO_ZERO_LENGTH_ARRAY_SECTION: + case GOMP_MAP_DELETE_ZERO_LEN_ARRAY_SECTION: + case GOMP_MAP_RELEASE: + case GOMP_MAP_ATTACH: + case GOMP_MAP_DETACH: + case GOMP_MAP_FORCE_DETACH: + case GOMP_MAP_ATTACH_ZERO_LENGTH_ARRAY_SECTION: + case GOMP_MAP_FIRSTPRIVATE_POINTER: + case GOMP_MAP_FIRSTPRIVATE_REFERENCE: + case GOMP_MAP_ATTACH_DETACH: + break; + default: + gcc_unreachable (); + } + return false; +} + +/* Three OpenMP deep-mapping lang hooks: gfc_omp_deep_mapping{_p,_cnt,}. */ + +/* Common check for gfc_omp_deep_mapping_p and gfc_omp_deep_mapping_do. */ + +static tree +gfc_omp_deep_mapping_int_p (const gimple *ctx, tree clause) +{ + if (is_gimple_omp_oacc (ctx) || !gfc_omp_deep_map_kind_p (clause)) + return NULL_TREE; + tree decl = OMP_CLAUSE_DECL (clause); + if (OMP_CLAUSE_SIZE (clause) != NULL_TREE + && DECL_P (OMP_CLAUSE_SIZE (clause)) + && DECL_LANG_SPECIFIC (OMP_CLAUSE_SIZE (clause)) + && GFC_DECL_SAVED_DESCRIPTOR (OMP_CLAUSE_SIZE (clause))) + /* Saved decl. */ + decl = GFC_DECL_SAVED_DESCRIPTOR (OMP_CLAUSE_SIZE (clause)); + else if (TREE_CODE (decl) == MEM_REF || TREE_CODE (decl) == INDIRECT_REF) + /* The following can happen for, e.g., class(t) :: var(..) */ + decl = TREE_OPERAND (decl, 0); + if (TREE_CODE (decl) == INDIRECT_REF) + /* The following can happen for, e.g., class(t) :: var(..) */ + decl = TREE_OPERAND (decl, 0); + if (DECL_P (decl) + && DECL_LANG_SPECIFIC (decl) + && GFC_DECL_SAVED_DESCRIPTOR (decl)) + decl = GFC_DECL_SAVED_DESCRIPTOR (decl); + /* Handle map(to: var.desc) map([to/from/tofrom:] var.desc.data) + to get proper map kind by skipping to the next item. */ + tree tmp = OMP_CLAUSE_CHAIN (clause); + if (tmp != NULL_TREE + && OMP_CLAUSE_CODE (tmp) == OMP_CLAUSE_CODE (clause) + && OMP_CLAUSE_SIZE (tmp) != NULL_TREE + && DECL_P (OMP_CLAUSE_SIZE (tmp)) + && DECL_LANG_SPECIFIC (OMP_CLAUSE_SIZE (tmp)) + && GFC_DECL_SAVED_DESCRIPTOR (OMP_CLAUSE_SIZE (tmp)) == decl) + return NULL_TREE; + if (DECL_P (decl) + && DECL_LANG_SPECIFIC (decl) + && GFC_DECL_SAVED_DESCRIPTOR (decl)) + decl = GFC_DECL_SAVED_DESCRIPTOR (decl); + tree type = TREE_TYPE (decl); + if (POINTER_TYPE_P (type)) + type = TREE_TYPE (type); + if (POINTER_TYPE_P (type)) + type = TREE_TYPE (type); + tmp = decl; + while (TREE_CODE (tmp) == COMPONENT_REF || TREE_CODE (tmp) == ARRAY_REF) + tmp = TREE_OPERAND (tmp, TREE_CODE (tmp) == COMPONENT_REF ? 1 : 0); + if (!gfc_is_polymorphic_nonptr (type) + && !gfc_has_alloc_comps (type, tmp, true)) + return NULL_TREE; + return decl; +} + +/* Return true if there is deep mapping, even if the number of mapping is known + at compile time. */ +bool +gfc_omp_deep_mapping_p (const gimple *ctx, tree clause) +{ + tree decl = gfc_omp_deep_mapping_int_p (ctx, clause); + if (decl == NULL_TREE) + return false; + return true; +} + +/* Handle gfc_omp_deep_mapping{,_cnt} */ +static tree +gfc_omp_deep_mapping_do (bool is_cnt, const gimple *ctx, tree clause, + unsigned HOST_WIDE_INT tkind, tree data, tree sizes, + tree kinds, tree offset_data, tree offset, + gimple_seq *seq) +{ + tree num = NULL_TREE; + location_t loc = OMP_CLAUSE_LOCATION (clause); + tree decl = gfc_omp_deep_mapping_int_p (ctx, clause); + bool poly_warned = false; + if (decl == NULL_TREE) + return NULL_TREE; + /* Handle: map(alloc:dt%cmp [len: ptr_size]) map(tofrom: D.0123...), + where GFC_DECL_SAVED_DESCRIPTOR(D.0123) is the same (here: dt%cmp). */ + if (OMP_CLAUSE_CODE (clause) == OMP_CLAUSE_MAP + && (OMP_CLAUSE_MAP_KIND (clause) == GOMP_MAP_ALLOC + || OMP_CLAUSE_MAP_KIND (clause) == GOMP_MAP_PRESENT_ALLOC)) + { + tree c = clause; + while ((c = OMP_CLAUSE_CHAIN (c)) != NULL_TREE) + { + if (!gfc_omp_deep_map_kind_p (c)) + continue; + tree d = gfc_omp_deep_mapping_int_p (ctx, c); + if (d != NULL_TREE && operand_equal_p (decl, d, 0)) + return NULL_TREE; + } + } + tree type = TREE_TYPE (decl); + if (POINTER_TYPE_P (type)) + type = TREE_TYPE (type); + if (POINTER_TYPE_P (type)) + type = TREE_TYPE (type); + bool poly = gfc_is_polymorphic_nonptr (type); + + if (is_cnt) + { + num = build_decl (loc, VAR_DECL, + create_tmp_var_name ("n_deepmap"), size_type_node); + tree tmp = fold_build2_loc (loc, MODIFY_EXPR, size_type_node, num, + build_int_cst (size_type_node, 0)); + gimple_add_tmp_var (num); + gimplify_and_add (tmp, seq); + } + else + gcc_assert (short_unsigned_type_node == TREE_TYPE (TREE_TYPE (kinds))); + + bool do_copy = poly; + bool do_alloc_check = false; + tree token = NULL_TREE; + tree tmp = decl; + if (poly) + { + tmp = TYPE_FIELDS (type); + type = TREE_TYPE (tmp); + } + else + while (TREE_CODE (tmp) == COMPONENT_REF || TREE_CODE (tmp) == ARRAY_REF) + tmp = TREE_OPERAND (tmp, TREE_CODE (tmp) == COMPONENT_REF ? 1 : 0); + if (TREE_CODE (tmp) == MEM_REF) + tmp = TREE_OPERAND (tmp, 0); + if (TREE_CODE (tmp) == SSA_NAME) + { + gimple *def_stmt = SSA_NAME_DEF_STMT (tmp); + if (gimple_code (def_stmt) == GIMPLE_ASSIGN) + { + tmp = gimple_assign_rhs1 (def_stmt); + if (poly) + { + tmp = TYPE_FIELDS (type); + type = TREE_TYPE (tmp); + } + else + while (TREE_CODE (tmp) == COMPONENT_REF + || TREE_CODE (tmp) == ARRAY_REF) + tmp = TREE_OPERAND (tmp, + TREE_CODE (tmp) == COMPONENT_REF ? 1 : 0); + } + } + /* If the clause argument is nonallocatable, skip is-allocate check. */ + if (GFC_DECL_GET_SCALAR_ALLOCATABLE (tmp) + || GFC_DECL_GET_SCALAR_POINTER (tmp) + || (GFC_DESCRIPTOR_TYPE_P (type) + && (GFC_TYPE_ARRAY_AKIND (type) == GFC_ARRAY_ALLOCATABLE + || GFC_TYPE_ARRAY_AKIND (type) == GFC_ARRAY_POINTER + || GFC_TYPE_ARRAY_AKIND (type) == GFC_ARRAY_POINTER_CONT))) + do_alloc_check = true; + + if (!is_cnt + && OMP_CLAUSE_CODE (clause) == OMP_CLAUSE_MAP + && (tkind == GOMP_MAP_ALLOC + || (tkind == GOMP_MAP_FROM + && (gimple_omp_target_kind (ctx) + != GF_OMP_TARGET_KIND_EXIT_DATA))) + && (poly || gfc_omp_replace_alloc_by_to_mapping (type, tmp, true))) + OMP_CLAUSE_SET_MAP_KIND (clause, tkind == GOMP_MAP_ALLOC ? GOMP_MAP_TO + : GOMP_MAP_TOFROM); + + /* TODO: For map(a(:)), we know it is present & allocated. */ + + tree present = (DECL_P (decl) ? gfc_omp_check_optional_argument (decl, true) + : NULL_TREE); + if (POINTER_TYPE_P (TREE_TYPE (decl)) + && POINTER_TYPE_P (TREE_TYPE (TREE_TYPE (decl)))) + decl = build_fold_indirect_ref (decl); + if (present) + { + tree then_label = create_artificial_label (loc); + tree end_label = create_artificial_label (loc); + gimple_seq seq2 = NULL; + tmp = force_gimple_operand (present, &seq2, true, NULL_TREE); + gimple_seq_add_seq (seq, seq2); + gimple_seq_add_stmt (seq, + gimple_build_cond_from_tree (present, + then_label, end_label)); + gimple_seq_add_stmt (seq, gimple_build_label (then_label)); + gfc_omp_deep_mapping_item (is_cnt, do_copy, do_alloc_check, loc, decl, + &token, tkind, data, sizes, kinds, + offset_data, offset, num, seq, ctx, + &poly_warned); + gimple_seq_add_stmt (seq, gimple_build_label (end_label)); + } + else + gfc_omp_deep_mapping_item (is_cnt, do_copy, do_alloc_check, loc, decl, + &token, tkind, data, sizes, kinds, offset_data, + offset, num, seq, ctx, &poly_warned); + /* Multiply by 2 as there are two mappings: data + pointer assign. */ + if (is_cnt) + gimplify_assign (num, + fold_build2_loc (loc, MULT_EXPR, + size_type_node, num, + build_int_cst (size_type_node, 2)), seq); + return num; +} + +/* Return tree with a variable which contains the count of deep-mappyings + (value depends, e.g., on allocation status) */ +tree +gfc_omp_deep_mapping_cnt (const gimple *ctx, tree clause, gimple_seq *seq) +{ + return gfc_omp_deep_mapping_do (true, ctx, clause, 0, NULL_TREE, NULL_TREE, + NULL_TREE, NULL_TREE, NULL_TREE, seq); +} + +/* Does the actual deep mapping. */ +void +gfc_omp_deep_mapping (const gimple *ctx, tree clause, + unsigned HOST_WIDE_INT tkind, tree data, + tree sizes, tree kinds, tree offset_data, tree offset, + gimple_seq *seq) +{ + (void) gfc_omp_deep_mapping_do (false, ctx, clause, tkind, data, sizes, kinds, + offset_data, offset, seq); +} + /* Return true if DECL is a scalar variable (for the purpose of implicit firstprivatization/mapping). Only if 'ptr_alloc_ok.' is true, allocatables and pointers are permitted. */ @@ -2478,6 +3285,18 @@ gfc_trans_omp_array_section (stmtblock_t *block, gfc_exec_op op, elemsz = fold_convert (gfc_array_index_type, elemsz); OMP_CLAUSE_SIZE (node) = fold_build2 (MULT_EXPR, gfc_array_index_type, OMP_CLAUSE_SIZE (node), elemsz); + if (n->expr->ts.type == BT_DERIVED + && n->expr->ts.u.derived->attr.alloc_comp) + { + /* Save array descriptor for use in gfc_omp_deep_mapping{,_p,_cnt}; + force evaluate to ensure that it is not gimplified + is a decl. */ + tree tmp = OMP_CLAUSE_SIZE (node); + tree var = gfc_create_var (TREE_TYPE (tmp), NULL); + gfc_add_modify_loc (input_location, block, var, tmp); + OMP_CLAUSE_SIZE (node) = var; + gfc_allocate_lang_decl (var); + GFC_DECL_SAVED_DESCRIPTOR (var) = se.expr; + } } gcc_assert (se.post.head == NULL_TREE); gcc_assert (POINTER_TYPE_P (TREE_TYPE (ptr))); @@ -2790,9 +3609,6 @@ gfc_trans_omp_clauses (stmtblock_t *block, gfc_omp_clauses *clauses, case OMP_LIST_USE: clause_code = OMP_CLAUSE_USE; goto add_clause; - case OMP_LIST_DESTROY: - clause_code = OMP_CLAUSE_DESTROY; - goto add_clause; case OMP_LIST_INTEROP: clause_code = OMP_CLAUSE_INTEROP; goto add_clause; @@ -2803,6 +3619,22 @@ gfc_trans_omp_clauses (stmtblock_t *block, gfc_omp_clauses *clauses, declare_simd); break; + case OMP_LIST_DESTROY: + for (; n != NULL; n = n->next) + if (n->sym->attr.referenced) + { + tree t = gfc_trans_omp_variable (n->sym, declare_simd); + if (t != error_mark_node) + { + tree node + = build_omp_clause (input_location, OMP_CLAUSE_DESTROY); + OMP_CLAUSE_DECL (node) = t; + TREE_ADDRESSABLE (OMP_CLAUSE_DECL (node)) = 1; + omp_clauses = gfc_trans_add_clause (node, omp_clauses); + } + } + break; + case OMP_LIST_INIT: { tree pref_type = NULL_TREE; @@ -2816,6 +3648,7 @@ gfc_trans_omp_clauses (stmtblock_t *block, gfc_omp_clauses *clauses, tree node = build_omp_clause (input_location, OMP_CLAUSE_INIT); OMP_CLAUSE_DECL (node) = t; + TREE_ADDRESSABLE (OMP_CLAUSE_DECL (node)) = 1; if (n->u.init.target) OMP_CLAUSE_INIT_TARGET (node) = 1; if (n->u.init.targetsync) @@ -3199,8 +4032,9 @@ gfc_trans_omp_clauses (stmtblock_t *block, gfc_omp_clauses *clauses, if (!n->sym->attr.referenced) continue; + location_t map_loc = gfc_get_location (&n->where); bool always_modifier = false; - tree node = build_omp_clause (input_location, OMP_CLAUSE_MAP); + tree node = build_omp_clause (map_loc, OMP_CLAUSE_MAP); tree node2 = NULL_TREE; tree node3 = NULL_TREE; tree node4 = NULL_TREE; @@ -3347,7 +4181,7 @@ gfc_trans_omp_clauses (stmtblock_t *block, gfc_omp_clauses *clauses, && n->u.map.op != OMP_MAP_RELEASE) { gcc_assert (n->sym->ts.u.cl->backend_decl); - node5 = build_omp_clause (input_location, OMP_CLAUSE_MAP); + node5 = build_omp_clause (map_loc, OMP_CLAUSE_MAP); OMP_CLAUSE_SET_MAP_KIND (node5, GOMP_MAP_ALWAYS_TO); OMP_CLAUSE_DECL (node5) = n->sym->ts.u.cl->backend_decl; OMP_CLAUSE_SIZE (node5) @@ -3364,7 +4198,7 @@ gfc_trans_omp_clauses (stmtblock_t *block, gfc_omp_clauses *clauses, ptr = build_fold_indirect_ref (ptr); OMP_CLAUSE_DECL (node) = ptr; OMP_CLAUSE_SIZE (node) = gfc_class_vtab_size_get (decl); - node2 = build_omp_clause (input_location, OMP_CLAUSE_MAP); + node2 = build_omp_clause (map_loc, OMP_CLAUSE_MAP); OMP_CLAUSE_SET_MAP_KIND (node2, GOMP_MAP_ATTACH_DETACH); OMP_CLAUSE_DECL (node2) = gfc_class_data_get (decl); OMP_CLAUSE_SIZE (node2) = size_int (0); @@ -3420,8 +4254,7 @@ gfc_trans_omp_clauses (stmtblock_t *block, gfc_omp_clauses *clauses, size = TYPE_SIZE_UNIT (TREE_TYPE (decl)); else size = size_int (0); - node4 = build_omp_clause (input_location, - OMP_CLAUSE_MAP); + node4 = build_omp_clause (map_loc, OMP_CLAUSE_MAP); OMP_CLAUSE_SET_MAP_KIND (node4, gmk); OMP_CLAUSE_DECL (node4) = decl; OMP_CLAUSE_SIZE (node4) = size; @@ -3445,8 +4278,7 @@ gfc_trans_omp_clauses (stmtblock_t *block, gfc_omp_clauses *clauses, size = TYPE_SIZE_UNIT (TREE_TYPE (decl)); else size = size_int (0); - node3 = build_omp_clause (input_location, - OMP_CLAUSE_MAP); + node3 = build_omp_clause (map_loc, OMP_CLAUSE_MAP); OMP_CLAUSE_SET_MAP_KIND (node3, gmk); OMP_CLAUSE_DECL (node3) = decl; OMP_CLAUSE_SIZE (node3) = size; @@ -3463,7 +4295,7 @@ gfc_trans_omp_clauses (stmtblock_t *block, gfc_omp_clauses *clauses, gcc_assert (POINTER_TYPE_P (TREE_TYPE (ptr))); ptr = build_fold_indirect_ref (ptr); OMP_CLAUSE_DECL (node) = ptr; - node2 = build_omp_clause (input_location, OMP_CLAUSE_MAP); + node2 = build_omp_clause (map_loc, OMP_CLAUSE_MAP); OMP_CLAUSE_DECL (node2) = decl; OMP_CLAUSE_SIZE (node2) = TYPE_SIZE_UNIT (type); if (n->u.map.op == OMP_MAP_DELETE) @@ -3479,8 +4311,7 @@ gfc_trans_omp_clauses (stmtblock_t *block, gfc_omp_clauses *clauses, && n->u.map.op != OMP_MAP_DELETE && n->u.map.op != OMP_MAP_RELEASE) { - node3 = build_omp_clause (input_location, - OMP_CLAUSE_MAP); + node3 = build_omp_clause (map_loc, OMP_CLAUSE_MAP); if (present) { ptr = gfc_conv_descriptor_data_get (decl); @@ -3620,10 +4451,10 @@ gfc_trans_omp_clauses (stmtblock_t *block, gfc_omp_clauses *clauses, { /* A single indirectref is handled by the middle end. */ gcc_assert (!POINTER_TYPE_P (TREE_TYPE (decl))); - decl = TREE_OPERAND (decl, 0); - decl = gfc_build_cond_assign_expr (block, present, decl, + tree tmp = TREE_OPERAND (decl, 0); + tmp = gfc_build_cond_assign_expr (block, present, tmp, null_pointer_node); - OMP_CLAUSE_DECL (node) = build_fold_indirect_ref (decl); + OMP_CLAUSE_DECL (node) = build_fold_indirect_ref (tmp); } else OMP_CLAUSE_DECL (node) = decl; @@ -3658,6 +4489,33 @@ gfc_trans_omp_clauses (stmtblock_t *block, gfc_omp_clauses *clauses, size = gfc_evaluate_now (size, block); OMP_CLAUSE_SIZE (node) = size; } + if ((TREE_CODE (decl) != PARM_DECL + || DECL_ARTIFICIAL (OMP_CLAUSE_DECL (node))) + && n->sym->ts.type == BT_DERIVED + && n->sym->ts.u.derived->attr.alloc_comp) + { + /* Save array descriptor for use in + gfc_omp_deep_mapping{,_p,_cnt}; force evaluate + to ensure that it is not gimplified + is a decl. */ + tree tmp = OMP_CLAUSE_SIZE (node); + if (tmp == NULL_TREE) + tmp = DECL_P (decl) ? DECL_SIZE_UNIT (decl) + : TYPE_SIZE_UNIT (TREE_TYPE (decl)); + tree var = gfc_create_var (TREE_TYPE (tmp), NULL); + gfc_add_modify_loc (input_location, block, var, tmp); + OMP_CLAUSE_SIZE (node) = var; + gfc_allocate_lang_decl (var); + if (TREE_CODE (decl) == INDIRECT_REF) + decl = TREE_OPERAND (decl, 0); + if (TREE_CODE (decl) == INDIRECT_REF) + decl = TREE_OPERAND (decl, 0); + if (DECL_LANG_SPECIFIC (decl) + && GFC_DECL_SAVED_DESCRIPTOR (decl)) + GFC_DECL_SAVED_DESCRIPTOR (var) + = GFC_DECL_SAVED_DESCRIPTOR (decl); + else + GFC_DECL_SAVED_DESCRIPTOR (var) = decl; + } } else if (n->expr && n->expr->expr_type == EXPR_VARIABLE @@ -3713,8 +4571,7 @@ gfc_trans_omp_clauses (stmtblock_t *block, gfc_omp_clauses *clauses, goto finalize_map_clause; } - node2 = build_omp_clause (input_location, - OMP_CLAUSE_MAP); + node2 = build_omp_clause (map_loc, OMP_CLAUSE_MAP); OMP_CLAUSE_SET_MAP_KIND (node2, GOMP_MAP_ATTACH_DETACH); OMP_CLAUSE_DECL (node2) = POINTER_TYPE_P (TREE_TYPE (se.expr)) @@ -3740,13 +4597,37 @@ gfc_trans_omp_clauses (stmtblock_t *block, gfc_omp_clauses *clauses, kind = GOMP_MAP_RELEASE; else kind = GOMP_MAP_TO; - node3 = build_omp_clause (input_location, - OMP_CLAUSE_MAP); + node3 = build_omp_clause (map_loc, OMP_CLAUSE_MAP); OMP_CLAUSE_SET_MAP_KIND (node3, kind); OMP_CLAUSE_DECL (node3) = se.string_length; OMP_CLAUSE_SIZE (node3) = TYPE_SIZE_UNIT (gfc_charlen_type_node); } + if (!openacc + && n->expr->ts.type == BT_DERIVED + && n->expr->ts.u.derived->attr.alloc_comp) + { + /* Save array descriptor for use in + gfc_omp_deep_mapping{,_p,_cnt}; force evaluate + to ensure that it is not gimplified + is a decl. */ + tree tmp = OMP_CLAUSE_SIZE (node); + if (tmp == NULL_TREE) + tmp = (DECL_P (se.expr) + ? DECL_SIZE_UNIT (se.expr) + : TYPE_SIZE_UNIT (TREE_TYPE (se.expr))); + tree var = gfc_create_var (TREE_TYPE (tmp), NULL); + gfc_add_modify_loc (input_location, block, var, tmp); + OMP_CLAUSE_SIZE (node) = var; + gfc_allocate_lang_decl (var); + if (TREE_CODE (se.expr) == INDIRECT_REF) + se.expr = TREE_OPERAND (se.expr, 0); + if (DECL_LANG_SPECIFIC (se.expr) + && GFC_DECL_SAVED_DESCRIPTOR (se.expr)) + GFC_DECL_SAVED_DESCRIPTOR (var) + = GFC_DECL_SAVED_DESCRIPTOR (se.expr); + else + GFC_DECL_SAVED_DESCRIPTOR (var) = se.expr; + } } } else if (n->expr @@ -3786,7 +4667,7 @@ gfc_trans_omp_clauses (stmtblock_t *block, gfc_omp_clauses *clauses, && (lastref->u.c.component->ts.type == BT_DERIVED || lastref->u.c.component->ts.type == BT_CLASS)) { - if (pointer || (openacc && allocatable)) + if (pointer || allocatable) { /* If it's a bare attach/detach clause, we just want to perform a single attach/detach operation, of the @@ -3866,8 +4747,7 @@ gfc_trans_omp_clauses (stmtblock_t *block, gfc_omp_clauses *clauses, OMP_CLAUSE_DECL (node) = data; OMP_CLAUSE_SIZE (node) = size; - node2 = build_omp_clause (input_location, - OMP_CLAUSE_MAP); + node2 = build_omp_clause (map_loc, OMP_CLAUSE_MAP); OMP_CLAUSE_SET_MAP_KIND (node2, GOMP_MAP_ATTACH_DETACH); OMP_CLAUSE_DECL (node2) = build_fold_addr_expr (data); @@ -3879,6 +4759,22 @@ gfc_trans_omp_clauses (stmtblock_t *block, gfc_omp_clauses *clauses, OMP_CLAUSE_SIZE (node) = TYPE_SIZE_UNIT (TREE_TYPE (inner)); } + if (!openacc + && n->expr->ts.type == BT_DERIVED + && n->expr->ts.u.derived->attr.alloc_comp) + { + /* Save array descriptor for use in + gfc_omp_deep_mapping{,_p,_cnt}; force evaluate + to ensure that it is not gimplified + is a decl. */ + tree tmp = OMP_CLAUSE_SIZE (node); + tree var = gfc_create_var (TREE_TYPE (tmp), NULL); + gfc_add_modify_loc (input_location, block, var, tmp); + OMP_CLAUSE_SIZE (node) = var; + gfc_allocate_lang_decl (var); + if (TREE_CODE (inner) == INDIRECT_REF) + inner = TREE_OPERAND (inner, 0); + GFC_DECL_SAVED_DESCRIPTOR (var) = inner; + } } else if (lastref->type == REF_ARRAY && lastref->u.ar.type == AR_FULL) @@ -3938,8 +4834,7 @@ gfc_trans_omp_clauses (stmtblock_t *block, gfc_omp_clauses *clauses, elemsz = TYPE_SIZE_UNIT (elemsz); elemsz = fold_build2 (MULT_EXPR, size_type_node, len, elemsz); - node4 = build_omp_clause (input_location, - OMP_CLAUSE_MAP); + node4 = build_omp_clause (map_loc, OMP_CLAUSE_MAP); OMP_CLAUSE_SET_MAP_KIND (node4, map_kind); OMP_CLAUSE_DECL (node4) = se.string_length; OMP_CLAUSE_SIZE (node4) @@ -3949,8 +4844,7 @@ gfc_trans_omp_clauses (stmtblock_t *block, gfc_omp_clauses *clauses, OMP_CLAUSE_SIZE (node) = fold_build2 (MULT_EXPR, gfc_array_index_type, OMP_CLAUSE_SIZE (node), elemsz); - node2 = build_omp_clause (input_location, - OMP_CLAUSE_MAP); + node2 = build_omp_clause (map_loc, OMP_CLAUSE_MAP); if (map_kind == GOMP_MAP_RELEASE || map_kind == GOMP_MAP_DELETE) { @@ -3964,6 +4858,23 @@ gfc_trans_omp_clauses (stmtblock_t *block, gfc_omp_clauses *clauses, OMP_CLAUSE_SIZE (node2) = TYPE_SIZE_UNIT (type); if (!openacc) { + if (n->expr->ts.type == BT_DERIVED + && n->expr->ts.u.derived->attr.alloc_comp) + { + /* Save array descriptor for use + in gfc_omp_deep_mapping{,_p,_cnt}; force + evaluate to ensure that it is + not gimplified + is a decl. */ + tree tmp = OMP_CLAUSE_SIZE (node); + tree var = gfc_create_var (TREE_TYPE (tmp), + NULL); + gfc_add_modify_loc (map_loc, block, + var, tmp); + OMP_CLAUSE_SIZE (node) = var; + gfc_allocate_lang_decl (var); + GFC_DECL_SAVED_DESCRIPTOR (var) = inner; + } + gfc_omp_namelist *n2 = clauses->lists[OMP_LIST_MAP]; @@ -4021,8 +4932,7 @@ gfc_trans_omp_clauses (stmtblock_t *block, gfc_omp_clauses *clauses, if (drop_mapping) continue; } - node3 = build_omp_clause (input_location, - OMP_CLAUSE_MAP); + node3 = build_omp_clause (map_loc, OMP_CLAUSE_MAP); OMP_CLAUSE_SET_MAP_KIND (node3, GOMP_MAP_ATTACH_DETACH); OMP_CLAUSE_DECL (node3) @@ -4093,7 +5003,8 @@ gfc_trans_omp_clauses (stmtblock_t *block, gfc_omp_clauses *clauses, default: gcc_unreachable (); } - tree node = build_omp_clause (input_location, clause_code); + tree node = build_omp_clause (gfc_get_location (&n->where), + clause_code); if (n->expr == NULL || (n->expr->ref->type == REF_ARRAY && n->expr->ref->u.ar.type == AR_FULL @@ -5137,6 +6048,10 @@ gfc_trans_oacc_wait_directive (gfc_code *code) args->quick_push (gfc_convert_expr_to_tree (&block, el->expr)); stmt = build_call_expr_loc_vec (loc, stmt, args); + if (clauses->if_expr) + stmt = build3_loc (input_location, COND_EXPR, void_type_node, + gfc_convert_expr_to_tree (&block, clauses->if_expr), + stmt, NULL_TREE); gfc_add_expr_to_block (&block, stmt); vec_free (args); @@ -8966,8 +9881,8 @@ gfc_trans_omp_declare_variant (gfc_namespace *ns, gfc_namespace *parent_ns) tree pref = NULL_TREE; if (n->u.init.len) { - tree pref = build_string (n->u.init.len, - n->u2.init_interop); + pref = build_string (n->u.init.len, + n->u2.init_interop); TREE_TYPE (pref) = build_array_type_nelts ( unsigned_char_type_node, n->u.init.len); diff --git a/gcc/fortran/trans-stmt.cc b/gcc/fortran/trans-stmt.cc index f16e1e3..f105401 100644 --- a/gcc/fortran/trans-stmt.cc +++ b/gcc/fortran/trans-stmt.cc @@ -19,7 +19,7 @@ You should have received a copy of the GNU General Public License along with GCC; see the file COPYING3. If not see <http://www.gnu.org/licenses/>. */ - +#define INCLUDE_VECTOR #include "config.h" #include "system.h" #include "coretypes.h" @@ -377,6 +377,57 @@ get_intrinsic_for_code (gfc_code *code) } +/* Handle the OpenACC routines acc_attach{,_async} and + acc_detach{,_finalize}{,_async} explicitly. This is required as the + the corresponding device pointee is attached to the corresponding device + pointer, but if a temporary array descriptor is created for the call, + that one is used as pointer instead of the original pointer. */ + +tree +gfc_trans_call_acc_attach_detach (gfc_code *code) +{ + stmtblock_t block; + gfc_se ptr_addr_se, async_se; + tree fn; + + fn = code->resolved_sym->backend_decl; + if (fn == NULL) + { + fn = gfc_get_symbol_decl (code->resolved_sym); + code->resolved_sym->backend_decl = fn; + } + + gfc_start_block (&block); + + gfc_init_se (&ptr_addr_se, NULL); + ptr_addr_se.descriptor_only = 1; + ptr_addr_se.want_pointer = 1; + gfc_conv_expr (&ptr_addr_se, code->ext.actual->expr); + gfc_add_block_to_block (&block, &ptr_addr_se.pre); + if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (ptr_addr_se.expr))) + ptr_addr_se.expr = gfc_conv_descriptor_data_get (ptr_addr_se.expr); + ptr_addr_se.expr = build_fold_addr_expr (ptr_addr_se.expr); + + bool async = code->ext.actual->next != NULL; + if (async) + { + gfc_init_se (&async_se, NULL); + gfc_conv_expr (&async_se, code->ext.actual->next->expr); + fn = build_call_expr_loc (gfc_get_location (&code->loc), fn, 2, + ptr_addr_se.expr, async_se.expr); + } + else + fn = build_call_expr_loc (gfc_get_location (&code->loc), + fn, 1, ptr_addr_se.expr); + gfc_add_expr_to_block (&block, fn); + gfc_add_block_to_block (&block, &ptr_addr_se.post); + if (async) + gfc_add_block_to_block (&block, &async_se.post); + + return gfc_finish_block (&block); +} + + /* Translate the CALL statement. Builds a call to an F95 subroutine. */ tree @@ -392,13 +443,32 @@ gfc_trans_call (gfc_code * code, bool dependency_check, tree tmp; bool is_intrinsic_mvbits; + gcc_assert (code->resolved_sym); + + /* Unfortunately, acc_attach* and acc_detach* need some special treatment for + attaching the the pointee to a pointer as GCC might introduce a temporary + array descriptor, whose data component is then used as to be attached to + pointer. */ + if (flag_openacc + && code->resolved_sym->attr.subroutine + && code->resolved_sym->formal + && code->resolved_sym->formal->sym->ts.type == BT_ASSUMED + && code->resolved_sym->formal->sym->attr.dimension + && code->resolved_sym->formal->sym->as->type == AS_ASSUMED_RANK + && startswith (code->resolved_sym->name, "acc_") + && (!strcmp (code->resolved_sym->name + 4, "attach") + || !strcmp (code->resolved_sym->name + 4, "attach_async") + || !strcmp (code->resolved_sym->name + 4, "detach") + || !strcmp (code->resolved_sym->name + 4, "detach_async") + || !strcmp (code->resolved_sym->name + 4, "detach_finalize") + || !strcmp (code->resolved_sym->name + 4, "detach_finalize_async"))) + return gfc_trans_call_acc_attach_detach (code); + /* A CALL starts a new block because the actual arguments may have to be evaluated first. */ gfc_init_se (&se, NULL); gfc_start_block (&se.pre); - gcc_assert (code->resolved_sym); - ss = gfc_ss_terminator; if (code->resolved_sym->attr.elemental) ss = gfc_walk_elemental_function_args (ss, code->ext.actual, @@ -721,6 +791,15 @@ gfc_trans_stop (gfc_code *code, bool error_stop) return gfc_finish_block (&se.pre); } +tree +trans_exit () +{ + const char *name = gfc_get_string (PREFIX ("exit_i%d"), 4); + gfc_symbol *exsym = gfc_get_intrinsic_sub_symbol (name); + tree tmp = gfc_get_symbol_decl (exsym); + return build_call_expr_loc (input_location, tmp, 1, integer_zero_node); +} + /* Translate the FAIL IMAGE statement. */ tree @@ -730,11 +809,49 @@ gfc_trans_fail_image (gfc_code *code ATTRIBUTE_UNUSED) return build_call_expr_loc (input_location, gfor_fndecl_caf_fail_image, 0); else + return trans_exit (); +} + +void +gfc_trans_sync_stat (struct sync_stat *sync_stat, gfc_se *se, tree *stat, + tree *errmsg, tree *errmsg_len) +{ + gfc_se argse; + + if (sync_stat->stat) { - const char *name = gfc_get_string (PREFIX ("exit_i%d"), 4); - gfc_symbol *exsym = gfc_get_intrinsic_sub_symbol (name); - tree tmp = gfc_get_symbol_decl (exsym); - return build_call_expr_loc (input_location, tmp, 1, integer_zero_node); + gfc_init_se (&argse, NULL); + gfc_conv_expr (&argse, sync_stat->stat); + gfc_add_block_to_block (&se->pre, &argse.pre); + + if (TREE_TYPE (argse.expr) != integer_type_node) + { + tree tstat = gfc_create_var (integer_type_node, "stat"); + TREE_THIS_VOLATILE (tstat) = 1; + gfc_add_modify (&se->pre, tstat, + fold_convert (integer_type_node, argse.expr)); + gfc_add_modify (&se->post, argse.expr, + fold_convert (TREE_TYPE (argse.expr), tstat)); + *stat = build_fold_addr_expr (tstat); + } + else + *stat = build_fold_addr_expr (argse.expr); + } + else + *stat = null_pointer_node; + + if (sync_stat->errmsg) + { + gfc_init_se (&argse, NULL); + gfc_conv_expr_reference (&argse, sync_stat->errmsg); + gfc_add_block_to_block (&se->pre, &argse.pre); + *errmsg = argse.expr; + *errmsg_len = fold_convert (size_type_node, argse.string_length); + } + else + { + *errmsg = null_pointer_node; + *errmsg_len = build_zero_cst (size_type_node); } } @@ -745,38 +862,42 @@ gfc_trans_form_team (gfc_code *code) { if (flag_coarray == GFC_FCOARRAY_LIB) { - gfc_se se; - gfc_se argse1, argse2; - tree team_id, team_type, tmp; + gfc_se se, argse; + tree team_id, team_type, new_index, stat, errmsg, errmsg_len, tmp; gfc_init_se (&se, NULL); - gfc_init_se (&argse1, NULL); - gfc_init_se (&argse2, NULL); - gfc_start_block (&se.pre); + gfc_init_se (&argse, NULL); + + gfc_conv_expr_val (&argse, code->expr1); + team_id = fold_convert (integer_type_node, argse.expr); + gfc_conv_expr_reference (&argse, code->expr2); + team_type = argse.expr; + + /* NEW_INDEX=. */ + if (code->expr3) + { + gfc_conv_expr_reference (&argse, code->expr3); + new_index = argse.expr; + } + else + new_index = null_pointer_node; - gfc_conv_expr_val (&argse1, code->expr1); - gfc_conv_expr_val (&argse2, code->expr2); - team_id = fold_convert (integer_type_node, argse1.expr); - team_type = gfc_build_addr_expr (ppvoid_type_node, argse2.expr); + gfc_add_block_to_block (&se.post, &argse.post); - gfc_add_block_to_block (&se.pre, &argse1.pre); - gfc_add_block_to_block (&se.pre, &argse2.pre); - tmp = build_call_expr_loc (input_location, - gfor_fndecl_caf_form_team, 3, - team_id, team_type, - integer_zero_node); + gfc_trans_sync_stat (&code->ext.sync_stat, &se, &stat, &errmsg, + &errmsg_len); + + gfc_add_block_to_block (&se.pre, &argse.pre); + + tmp = build_call_expr_loc (input_location, gfor_fndecl_caf_form_team, 6, + team_id, team_type, new_index, stat, errmsg, + errmsg_len); gfc_add_expr_to_block (&se.pre, tmp); - gfc_add_block_to_block (&se.pre, &argse1.post); - gfc_add_block_to_block (&se.pre, &argse2.post); + gfc_add_block_to_block (&se.pre, &se.post); return gfc_finish_block (&se.pre); - } + } else - { - const char *name = gfc_get_string (PREFIX ("exit_i%d"), 4); - gfc_symbol *exsym = gfc_get_intrinsic_sub_symbol (name); - tree tmp = gfc_get_symbol_decl (exsym); - return build_call_expr_loc (input_location, tmp, 1, integer_zero_node); - } + return trans_exit (); } /* Translate the CHANGE TEAM statement. */ @@ -786,47 +907,56 @@ gfc_trans_change_team (gfc_code *code) { if (flag_coarray == GFC_FCOARRAY_LIB) { - gfc_se argse; - tree team_type, tmp; + stmtblock_t block; + gfc_se se; + tree team_type, stat, errmsg, errmsg_len, tmp; - gfc_init_se (&argse, NULL); - gfc_conv_expr_val (&argse, code->expr1); - team_type = gfc_build_addr_expr (ppvoid_type_node, argse.expr); + gfc_init_se (&se, NULL); + gfc_start_block (&block); - tmp = build_call_expr_loc (input_location, - gfor_fndecl_caf_change_team, 2, team_type, - integer_zero_node); - gfc_add_expr_to_block (&argse.pre, tmp); - gfc_add_block_to_block (&argse.pre, &argse.post); - return gfc_finish_block (&argse.pre); + gfc_conv_expr_val (&se, code->expr1); + team_type = se.expr; + + gfc_trans_sync_stat (&code->ext.block.sync_stat, &se, &stat, &errmsg, + &errmsg_len); + + tmp = build_call_expr_loc (input_location, gfor_fndecl_caf_change_team, 4, + team_type, stat, errmsg, errmsg_len); + + gfc_add_expr_to_block (&se.pre, tmp); + gfc_add_block_to_block (&se.pre, &se.post); + gfc_add_block_to_block (&block, &se.pre); + gfc_add_expr_to_block (&block, gfc_trans_block_construct (code)); + return gfc_finish_block (&block); } else - { - const char *name = gfc_get_string (PREFIX ("exit_i%d"), 4); - gfc_symbol *exsym = gfc_get_intrinsic_sub_symbol (name); - tree tmp = gfc_get_symbol_decl (exsym); - return build_call_expr_loc (input_location, tmp, 1, integer_zero_node); - } + return trans_exit (); } /* Translate the END TEAM statement. */ tree -gfc_trans_end_team (gfc_code *code ATTRIBUTE_UNUSED) +gfc_trans_end_team (gfc_code *code) { if (flag_coarray == GFC_FCOARRAY_LIB) { - return build_call_expr_loc (input_location, - gfor_fndecl_caf_end_team, 1, - build_int_cst (pchar_type_node, 0)); + gfc_se se; + tree stat, errmsg, errmsg_len, tmp; + + gfc_init_se (&se, NULL); + gfc_start_block (&se.pre); + + gfc_trans_sync_stat (&code->ext.sync_stat, &se, &stat, &errmsg, + &errmsg_len); + + tmp = build_call_expr_loc (input_location, gfor_fndecl_caf_end_team, 3, + stat, errmsg, errmsg_len); + gfc_add_expr_to_block (&se.pre, tmp); + gfc_add_block_to_block (&se.pre, &se.post); + return gfc_finish_block (&se.pre); } else - { - const char *name = gfc_get_string (PREFIX ("exit_i%d"), 4); - gfc_symbol *exsym = gfc_get_intrinsic_sub_symbol (name); - tree tmp = gfc_get_symbol_decl (exsym); - return build_call_expr_loc (input_location, tmp, 1, integer_zero_node); - } + return trans_exit (); } /* Translate the SYNC TEAM statement. */ @@ -836,28 +966,25 @@ gfc_trans_sync_team (gfc_code *code) { if (flag_coarray == GFC_FCOARRAY_LIB) { - gfc_se argse; - tree team_type, tmp; + gfc_se se; + tree team_type, stat, errmsg, errmsg_len, tmp; - gfc_init_se (&argse, NULL); - gfc_conv_expr_val (&argse, code->expr1); - team_type = gfc_build_addr_expr (ppvoid_type_node, argse.expr); + gfc_init_se (&se, NULL); - tmp = build_call_expr_loc (input_location, - gfor_fndecl_caf_sync_team, 2, - team_type, - integer_zero_node); - gfc_add_expr_to_block (&argse.pre, tmp); - gfc_add_block_to_block (&argse.pre, &argse.post); - return gfc_finish_block (&argse.pre); + gfc_conv_expr_val (&se, code->expr1); + team_type = se.expr; + + gfc_trans_sync_stat (&code->ext.sync_stat, &se, &stat, &errmsg, + &errmsg_len); + + tmp = build_call_expr_loc (input_location, gfor_fndecl_caf_sync_team, 4, + team_type, stat, errmsg, errmsg_len); + gfc_add_expr_to_block (&se.pre, tmp); + gfc_add_block_to_block (&se.pre, &se.post); + return gfc_finish_block (&se.pre); } else - { - const char *name = gfc_get_string (PREFIX ("exit_i%d"), 4); - gfc_symbol *exsym = gfc_get_intrinsic_sub_symbol (name); - tree tmp = gfc_get_symbol_decl (exsym); - return build_call_expr_loc (input_location, tmp, 1, integer_zero_node); - } + return trans_exit (); } tree @@ -1280,8 +1407,7 @@ gfc_trans_sync (gfc_code *code, gfc_exec_op type) { tree cond2; tmp = build_call_expr_loc (input_location, gfor_fndecl_caf_num_images, - 2, integer_zero_node, - build_int_cst (integer_type_node, -1)); + 2, null_pointer_node, null_pointer_node); cond = fold_build2_loc (input_location, GT_EXPR, logical_type_node, images2, tmp); cond2 = fold_build2_loc (input_location, LT_EXPR, logical_type_node, @@ -1609,35 +1735,41 @@ gfc_trans_arithmetic_if (gfc_code * code) /* Translate a CRITICAL block. */ + tree gfc_trans_critical (gfc_code *code) -{ - stmtblock_t block; - tree tmp, token = NULL_TREE; + { + stmtblock_t block; + tree tmp, token = NULL_TREE; + tree stat = NULL_TREE, errmsg, errmsg_len; - gfc_start_block (&block); + gfc_start_block (&block); - if (flag_coarray == GFC_FCOARRAY_LIB) - { - tree zero_size = build_zero_cst (size_type_node); - token = gfc_get_symbol_decl (code->resolved_sym); - token = GFC_TYPE_ARRAY_CAF_TOKEN (TREE_TYPE (token)); - tmp = build_call_expr_loc (input_location, gfor_fndecl_caf_lock, 7, - token, zero_size, integer_one_node, - null_pointer_node, null_pointer_node, - null_pointer_node, zero_size); - gfc_add_expr_to_block (&block, tmp); + if (flag_coarray == GFC_FCOARRAY_LIB) + { + gfc_se se; - /* It guarantees memory consistency within the same segment */ - tmp = gfc_build_string_const (strlen ("memory")+1, "memory"), - tmp = build5_loc (input_location, ASM_EXPR, void_type_node, - gfc_build_string_const (1, ""), - NULL_TREE, NULL_TREE, - tree_cons (NULL_TREE, tmp, NULL_TREE), - NULL_TREE); - ASM_VOLATILE_P (tmp) = 1; + gfc_init_se (&se, NULL); + gfc_trans_sync_stat (&code->ext.sync_stat, &se, &stat, &errmsg, + &errmsg_len); + gfc_add_block_to_block (&block, &se.pre); - gfc_add_expr_to_block (&block, tmp); + token = gfc_get_symbol_decl (code->resolved_sym); + token = GFC_TYPE_ARRAY_CAF_TOKEN (TREE_TYPE (token)); + tmp = build_call_expr_loc (input_location, gfor_fndecl_caf_lock, 7, + token, integer_zero_node, integer_one_node, + null_pointer_node, stat, errmsg, errmsg_len); + gfc_add_expr_to_block (&block, tmp); + gfc_add_block_to_block (&block, &se.post); + + /* It guarantees memory consistency within the same segment. */ + tmp = gfc_build_string_const (strlen ("memory") + 1, "memory"), + tmp = build5_loc (input_location, ASM_EXPR, void_type_node, + gfc_build_string_const (1, ""), NULL_TREE, NULL_TREE, + tree_cons (NULL_TREE, tmp, NULL_TREE), NULL_TREE); + ASM_VOLATILE_P (tmp) = 1; + + gfc_add_expr_to_block (&block, tmp); } tmp = gfc_trans_code (code->block->next); @@ -1645,11 +1777,19 @@ gfc_trans_critical (gfc_code *code) if (flag_coarray == GFC_FCOARRAY_LIB) { - tree zero_size = build_zero_cst (size_type_node); - tmp = build_call_expr_loc (input_location, gfor_fndecl_caf_unlock, 6, - token, zero_size, integer_one_node, - null_pointer_node, null_pointer_node, - zero_size); + /* END CRITICAL does not accept STAT or ERRMSG arguments. + * If STAT= is specified for CRITICAL, pass a stat argument to + * _gfortran_caf_lock_unlock to prevent termination in the event of an + * error, but ignore any value assigned to it. + */ + tmp = build_call_expr_loc ( + input_location, gfor_fndecl_caf_unlock, 6, token, integer_zero_node, + integer_one_node, + stat != NULL_TREE + ? gfc_build_addr_expr (NULL, + gfc_create_var (integer_type_node, "stat")) + : null_pointer_node, + null_pointer_node, integer_zero_node); gfc_add_expr_to_block (&block, tmp); /* It guarantees memory consistency within the same segment */ @@ -1981,11 +2121,35 @@ trans_associate_var (gfc_symbol *sym, gfc_wrapped_block *block) GFC_DECL_PTR_ARRAY_P (sym->backend_decl) = 1; } - if (sym->attr.codimension && !sym->attr.dimension) + if (sym->attr.codimension) se.want_coarray = 1; gfc_conv_expr_descriptor (&se, e); + if (flag_coarray == GFC_FCOARRAY_LIB && sym->attr.codimension) + { + tree token = gfc_conv_descriptor_token (se.expr), + size + = sym->attr.dimension + ? fold_build2 (MULT_EXPR, gfc_array_index_type, + gfc_conv_descriptor_size (se.expr, e->rank), + gfc_conv_descriptor_span_get (se.expr)) + : gfc_conv_descriptor_span_get (se.expr); + /* Create a new token, because in the token the modified descriptor + is stored. The modified descriptor is needed for accesses on the + remote image. In the scalar case, the base address needs to be + associated correctly, which also needs a new token. + The token is freed automatically be the end team statement. */ + gfc_add_expr_to_block ( + &se.pre, + build_call_expr_loc ( + input_location, gfor_fndecl_caf_register, 7, size, + build_int_cst (integer_type_node, GFC_CAF_COARRAY_MAP_EXISTING), + gfc_build_addr_expr (pvoid_type_node, token), + gfc_build_addr_expr (NULL_TREE, se.expr), null_pointer_node, + null_pointer_node, integer_zero_node)); + } + if (sym->ts.type == BT_CHARACTER && !sym->attr.select_type_temporary && sym->ts.u.cl->backend_decl @@ -5093,6 +5257,138 @@ gfc_trans_pointer_assign_need_temp (gfc_expr * expr1, gfc_expr * expr2, } } +/* For saving the outer-variable data when doing + LOCAL and LOCAL_INIT substitution. */ +struct symbol_and_tree_t +{ + gfc_symbol *sym; + gfc_expr *value; + tree decl; + symbol_attribute attr; +}; + +/* Handle the LOCAL and LOCAL_INIT locality specifiers. This has to be + called twice, once with after_body=false - and then after the loop + body has been processed with after_body=true. + + Creates a copy of the variables that appear in the LOCAL and LOCAL_INIT + locality specifiers of 'do concurrent' - and use it in the original + gfc_symbol. The declaration is then reset by after_body=true. + + Variables in LOCAL_INIT are set in every loop iteration. */ + +void +gfc_trans_concurrent_locality_spec (bool after_body, stmtblock_t *body, + std::vector<symbol_and_tree_t> *saved_decls, + gfc_expr_list **locality_list) +{ + if (!locality_list[LOCALITY_LOCAL] && !locality_list[LOCALITY_LOCAL_INIT]) + return; + + if (after_body) + { + for (unsigned i = 0; i < saved_decls->size (); i++) + { + (*saved_decls)[i].sym->backend_decl = (*saved_decls)[i].decl; + (*saved_decls)[i].sym->attr = (*saved_decls)[i].attr; + (*saved_decls)[i].sym->value = (*saved_decls)[i].value; + } + return; + } + + gfc_expr_list *el; + int cnt = 0; + for (int i = 0; i <= 1; i++) + for (el = locality_list[i == 0 ? LOCALITY_LOCAL : LOCALITY_LOCAL_INIT]; + el; el = el->next) + { + gfc_symbol *outer_sym = el->expr->symtree->n.sym; + if (!outer_sym->backend_decl) + outer_sym->backend_decl = gfc_get_symbol_decl (outer_sym); + cnt++; + } + saved_decls->resize (cnt); + + /* The variables have to be created in the scope of the loop body. */ + if (!body->has_scope) + { + gcc_checking_assert (body->head == NULL_TREE); + gfc_start_block (body); + } + gfc_start_saved_local_decls (); + + cnt = 0; + static_assert (LOCALITY_LOCAL_INIT - LOCALITY_LOCAL == 1, "locality_type"); + for (int type = LOCALITY_LOCAL; + type <= LOCALITY_LOCAL_INIT; type++) + for (el = locality_list[type]; el; el = el->next) + { + gfc_symbol *sym = el->expr->symtree->n.sym; + (*saved_decls)[cnt].sym = sym; + (*saved_decls)[cnt].attr = sym->attr; + (*saved_decls)[cnt].value = sym->value; + (*saved_decls)[cnt].decl = sym->backend_decl; + + if (sym->attr.dimension && sym->as->type == AS_ASSUMED_SHAPE) + { + gfc_error ("Sorry, %s specifier at %L for assumed-size array %qs " + "is not yet supported", + type == LOCALITY_LOCAL ? "LOCAL" : "LOCAL_INIT", + &el->expr->where, sym->name); + continue; + } + + gfc_symbol outer_sym = *sym; + + /* Create the inner local variable. */ + sym->backend_decl = NULL; + sym->value = NULL; + sym->attr.save = SAVE_NONE; + sym->attr.value = 0; + sym->attr.dummy = 0; + sym->attr.optional = 0; + + { + /* Slightly ugly hack for adding the decl via add_decl_as_local. */ + gfc_symbol dummy_block_sym; + dummy_block_sym.attr.flavor = FL_LABEL; + gfc_symbol *saved_proc_name = sym->ns->proc_name; + sym->ns->proc_name = &dummy_block_sym; + + gfc_get_symbol_decl (sym); + DECL_SOURCE_LOCATION (sym->backend_decl) + = gfc_get_location (&el->expr->where); + + sym->ns->proc_name = saved_proc_name; + } + + symbol_attribute attr = gfc_expr_attr (el->expr); + if (type == LOCALITY_LOCAL + && !attr.pointer + && sym->ts.type == BT_DERIVED + && gfc_has_default_initializer (sym->ts.u.derived)) + /* Cf. PR fortran/ */ + gfc_error ("Sorry, LOCAL specifier at %L for %qs of derived type with" + " default initializer is not yet supported", + &el->expr->where, sym->name); + if (type == LOCALITY_LOCAL_INIT) + { + /* LOCAL_INIT: local_var = outer_var. */ + gfc_symtree st = *el->expr->symtree; + st.n.sym = &outer_sym; + gfc_expr expr = *el->expr; + expr.symtree = &st; + tree t = (attr.pointer + ? gfc_trans_pointer_assignment (el->expr, &expr) + : gfc_trans_assignment (el->expr, &expr, false, false, + false, false)); + gfc_add_expr_to_block (body, t); + } + cnt++; + } + gfc_stop_saved_local_decls (); +} + /* FORALL and WHERE statements are really nasty, especially when you nest them. All the rhs of a forall assignment must be evaluated before the @@ -5348,9 +5644,19 @@ gfc_trans_forall_1 (gfc_code * code, forall_info * nested_forall_info) gfc_init_block (&body); cycle_label = gfc_build_label_decl (NULL_TREE); code->cycle_label = cycle_label; + + /* Handle LOCAL and LOCAL_INIT. */ + std::vector<symbol_and_tree_t> saved_decls; + gfc_trans_concurrent_locality_spec (false, &body, &saved_decls, + code->ext.concur.locality); + + /* Translate the body. */ tmp = gfc_trans_code (code->block->next); gfc_add_expr_to_block (&body, tmp); + /* Reset locality variables. */ + gfc_trans_concurrent_locality_spec (true, &body, &saved_decls, + code->ext.concur.locality); if (TREE_USED (cycle_label)) { tmp = build1_v (LABEL_EXPR, cycle_label); diff --git a/gcc/fortran/trans-stmt.h b/gcc/fortran/trans-stmt.h index 67b1970..8fbcdcb 100644 --- a/gcc/fortran/trans-stmt.h +++ b/gcc/fortran/trans-stmt.h @@ -58,6 +58,7 @@ tree gfc_trans_sync (gfc_code *, gfc_exec_op); tree gfc_trans_lock_unlock (gfc_code *, gfc_exec_op); tree gfc_trans_event_post_wait (gfc_code *, gfc_exec_op); tree gfc_trans_fail_image (gfc_code *); +void gfc_trans_sync_stat (struct sync_stat *, gfc_se *, tree *, tree *, tree *); tree gfc_trans_forall (gfc_code *); tree gfc_trans_form_team (gfc_code *); tree gfc_trans_change_team (gfc_code *); diff --git a/gcc/fortran/trans-types.cc b/gcc/fortran/trans-types.cc index 3374778..1754d98 100644 --- a/gcc/fortran/trans-types.cc +++ b/gcc/fortran/trans-types.cc @@ -1140,11 +1140,6 @@ gfc_init_types (void) } gfc_character1_type_node = gfc_character_types[0]; - /* The middle end only recognizes a single unsigned type. For - compatibility of existing test cases, let's just use the - character type. The reader of tree dumps is expected to be able - to deal with this. */ - if (flag_unsigned) { for (index = 0; gfc_unsigned_kinds[index].kind != 0;++index) @@ -1159,18 +1154,26 @@ gfc_init_types (void) break; } } - if (index_char > 0) + if (index_char > -1) { - gfc_unsigned_types[index] = gfc_character_types[index_char]; + type = gfc_character_types[index_char]; + if (TYPE_STRING_FLAG (type)) + { + type = build_distinct_type_copy (type); + TYPE_CANONICAL (type) + = TYPE_CANONICAL (gfc_character_types[index_char]); + } + else + type = build_variant_type_copy (type); + TYPE_NAME (type) = NULL_TREE; + TYPE_STRING_FLAG (type) = 0; } else - { - type = gfc_build_unsigned_type (&gfc_unsigned_kinds[index]); - gfc_unsigned_types[index] = type; - snprintf (name_buf, sizeof(name_buf), "unsigned(kind=%d)", - gfc_integer_kinds[index].kind); - PUSH_TYPE (name_buf, type); - } + type = gfc_build_unsigned_type (&gfc_unsigned_kinds[index]); + gfc_unsigned_types[index] = type; + snprintf (name_buf, sizeof(name_buf), "unsigned(kind=%d)", + gfc_integer_kinds[index].kind); + PUSH_TYPE (name_buf, type); } } @@ -3184,7 +3187,7 @@ copy_derived_types: for (c = derived->components; c; c = c->next) { /* Do not add a caf_token field for class container components. */ - if ((codimen || coarray_flag) && !c->attr.dimension + if (codimen && coarray_flag && !c->attr.dimension && !c->attr.codimension && (c->attr.allocatable || c->attr.pointer) && !derived->attr.is_class) { @@ -3228,13 +3231,14 @@ gfc_return_by_reference (gfc_symbol * sym) /* Possibly return complex numbers by reference for g77 compatibility. We don't do this for calls to intrinsics (as the library uses the - -fno-f2c calling convention), nor for calls to functions which always + -fno-f2c calling convention) except for calls to specific wrappers + (_gfortran_f2c_specific_*), nor for calls to functions which always require an explicit interface, as no compatibility problems can arise there. */ if (flag_f2c && sym->ts.type == BT_COMPLEX && !sym->attr.pointer && !sym->attr.allocatable - && !sym->attr.intrinsic && !sym->attr.always_explicit) + && !sym->attr.always_explicit) return 1; return 0; diff --git a/gcc/fortran/trans.cc b/gcc/fortran/trans.cc index b03dcc1..13fd5ad 100644 --- a/gcc/fortran/trans.cc +++ b/gcc/fortran/trans.cc @@ -822,6 +822,7 @@ gfc_allocate_using_malloc (stmtblock_t * block, tree pointer, tree tmp, error_cond; stmtblock_t on_error; tree status_type = status ? TREE_TYPE (status) : NULL_TREE; + bool cond_is_true = cond == boolean_true_node; /* If successful and stat= is given, set status to 0. */ if (status != NULL_TREE) @@ -834,11 +835,13 @@ gfc_allocate_using_malloc (stmtblock_t * block, tree pointer, tmp = fold_build2_loc (input_location, MAX_EXPR, size_type_node, size, build_int_cst (size_type_node, 1)); - tmp = build_call_expr_loc (input_location, - builtin_decl_explicit (BUILT_IN_MALLOC), 1, tmp); - if (cond == boolean_true_node) + if (!cond_is_true) + tmp = build_call_expr_loc (input_location, + builtin_decl_explicit (BUILT_IN_MALLOC), 1, tmp); + else tmp = alt_alloc; - else if (cond) + + if (!cond_is_true && cond) tmp = build3_loc (input_location, COND_EXPR, TREE_TYPE (tmp), cond, alt_alloc, tmp); @@ -1795,11 +1798,11 @@ gfc_finalize_tree_expr (gfc_se *se, gfc_symbol *derived, analyzed and set by this routine, and -2 to indicate that a non-coarray is to be deallocated. */ tree -gfc_deallocate_with_status (tree pointer, tree status, tree errmsg, - tree errlen, tree label_finish, - bool can_fail, gfc_expr* expr, +gfc_deallocate_with_status (tree pointer, tree status, tree errmsg, tree errlen, + tree label_finish, bool can_fail, gfc_expr *expr, int coarray_dealloc_mode, tree class_container, - tree add_when_allocated, tree caf_token) + tree add_when_allocated, tree caf_token, + bool unalloc_ok) { stmtblock_t null, non_null; tree cond, tmp, error; @@ -1891,7 +1894,7 @@ gfc_deallocate_with_status (tree pointer, tree status, tree errmsg, tmp = fold_build2_loc (input_location, MODIFY_EXPR, status_type, fold_build1_loc (input_location, INDIRECT_REF, status_type, status), - build_int_cst (status_type, 1)); + build_int_cst (status_type, unalloc_ok ? 0 : 1)); error = fold_build3_loc (input_location, COND_EXPR, void_type_node, cond2, tmp, error); } @@ -1975,10 +1978,10 @@ gfc_deallocate_with_status (tree pointer, tree status, tree errmsg, token = gfc_build_addr_expr (NULL_TREE, token); gcc_assert (caf_dereg_type > GFC_CAF_COARRAY_ANALYZE); - tmp = build_call_expr_loc (input_location, - gfor_fndecl_caf_deregister, 5, - token, build_int_cst (integer_type_node, - caf_dereg_type), + tmp = build_call_expr_loc (input_location, gfor_fndecl_caf_deregister, 5, + token, + build_int_cst (integer_type_node, + caf_dereg_type), pstat, errmsg, errlen); gfc_add_expr_to_block (&non_null, tmp); @@ -1990,7 +1993,7 @@ gfc_deallocate_with_status (tree pointer, tree status, tree errmsg, ASM_VOLATILE_P (tmp) = 1; gfc_add_expr_to_block (&non_null, tmp); - if (status != NULL_TREE) + if (status != NULL_TREE && !integer_zerop (status)) { tree stat = build_fold_indirect_ref_loc (input_location, status); tree nullify = fold_build2_loc (input_location, MODIFY_EXPR, @@ -2024,9 +2027,10 @@ gfc_deallocate_with_status (tree pointer, tree status, tree errmsg, tree gfc_deallocate_scalar_with_status (tree pointer, tree status, tree label_finish, - bool can_fail, gfc_expr* expr, + bool can_fail, gfc_expr *expr, gfc_typespec ts, tree class_container, - bool coarray) + bool coarray, bool unalloc_ok, tree errmsg, + tree errmsg_len) { stmtblock_t null, non_null; tree cond, tmp, error; @@ -2069,7 +2073,7 @@ gfc_deallocate_scalar_with_status (tree pointer, tree status, tree label_finish, tmp = fold_build2_loc (input_location, MODIFY_EXPR, status_type, fold_build1_loc (input_location, INDIRECT_REF, status_type, status), - build_int_cst (status_type, 1)); + build_int_cst (status_type, unalloc_ok ? 0 : 1)); error = fold_build3_loc (input_location, COND_EXPR, void_type_node, cond2, tmp, error); } @@ -2134,7 +2138,8 @@ gfc_deallocate_scalar_with_status (tree pointer, tree status, tree label_finish, else { tree token; - tree pstat = null_pointer_node; + tree pstat = null_pointer_node, perrmsg = null_pointer_node, + perrlen = size_zero_node; gfc_se se; gfc_init_se (&se, NULL); @@ -2147,11 +2152,17 @@ gfc_deallocate_scalar_with_status (tree pointer, tree status, tree label_finish, pstat = status; } - tmp = build_call_expr_loc (input_location, - gfor_fndecl_caf_deregister, 5, - token, build_int_cst (integer_type_node, - caf_dereg_type), - pstat, null_pointer_node, integer_zero_node); + if (errmsg != NULL_TREE) + { + perrmsg = errmsg; + perrlen = errmsg_len; + } + + tmp = build_call_expr_loc (input_location, gfor_fndecl_caf_deregister, 5, + token, + build_int_cst (integer_type_node, + caf_dereg_type), + pstat, perrmsg, perrlen); gfc_add_expr_to_block (&non_null, tmp); /* It guarantees memory consistency within the same segment. */ diff --git a/gcc/fortran/trans.h b/gcc/fortran/trans.h index 69c3d90..461b0cd 100644 --- a/gcc/fortran/trans.h +++ b/gcc/fortran/trans.h @@ -139,10 +139,10 @@ enum gfc_coarray_regtype GFC_CAF_EVENT_STATIC, GFC_CAF_EVENT_ALLOC, GFC_CAF_COARRAY_ALLOC_REGISTER_ONLY, - GFC_CAF_COARRAY_ALLOC_ALLOCATE_ONLY + GFC_CAF_COARRAY_ALLOC_ALLOCATE_ONLY, + GFC_CAF_COARRAY_MAP_EXISTING }; - /* Describes the action to take on _caf_deregister. Keep in sync with gcc/fortran/trans.h. The negative values are not valid for the library and are used by the drivers for building the correct call. */ @@ -774,12 +774,13 @@ void gfc_allocate_using_malloc (stmtblock_t *, tree, tree, tree, tree = NULL_TREE); /* Generate code to deallocate an array. */ -tree gfc_deallocate_with_status (tree, tree, tree, tree, tree, bool, - gfc_expr *, int, tree = NULL_TREE, - tree a = NULL_TREE, tree c = NULL_TREE); -tree gfc_deallocate_scalar_with_status (tree, tree, tree, bool, gfc_expr*, +tree gfc_deallocate_with_status (tree, tree, tree, tree, tree, bool, gfc_expr *, + int, tree = NULL_TREE, tree a = NULL_TREE, + tree c = NULL_TREE, bool u = false); +tree gfc_deallocate_scalar_with_status (tree, tree, tree, bool, gfc_expr *, gfc_typespec, tree = NULL_TREE, - bool c = false); + bool c = false, bool u = false, + tree = NULL_TREE, tree = NULL_TREE); /* Generate code to call realloc(). */ tree gfc_call_realloc (stmtblock_t *, tree, tree); @@ -804,6 +805,8 @@ tree gfc_build_library_function_decl_with_spec (tree name, const char *spec, tree rettype, int nargs, ...); /* Process the local variable decls of a block construct. */ +void gfc_start_saved_local_decls (); +void gfc_stop_saved_local_decls (); void gfc_process_block_locals (gfc_namespace*); /* Output initialization/clean-up code that was deferred. */ @@ -837,6 +840,10 @@ tree gfc_omp_clause_assign_op (tree, tree, tree); tree gfc_omp_clause_linear_ctor (tree, tree, tree, tree); tree gfc_omp_clause_dtor (tree, tree); void gfc_omp_finish_clause (tree, gimple_seq *, bool); +bool gfc_omp_deep_mapping_p (const gimple *, tree); +tree gfc_omp_deep_mapping_cnt (const gimple *, tree, gimple_seq *); +void gfc_omp_deep_mapping (const gimple *, tree, unsigned HOST_WIDE_INT, tree, + tree, tree, tree, tree, gimple_seq *); bool gfc_omp_allocatable_p (tree); bool gfc_omp_scalar_p (tree, bool); bool gfc_omp_scalar_target_p (tree); diff --git a/gcc/fortran/types.def b/gcc/fortran/types.def index 6447cee..dd9b8df 100644 --- a/gcc/fortran/types.def +++ b/gcc/fortran/types.def @@ -266,6 +266,9 @@ DEF_FUNCTION_TYPE_11 (BT_FN_VOID_OMPFN_PTR_OMPCPYFN_LONG_LONG_UINT_LONG_INT_ULL_ BT_PTR_FN_VOID_PTR_PTR, BT_LONG, BT_LONG, BT_UINT, BT_LONG, BT_INT, BT_ULONGLONG, BT_ULONGLONG, BT_ULONGLONG) +DEF_FUNCTION_TYPE_11 (BT_FN_VOID_INT_INT_PTR_PTR_PTR_INT_PTR_INT_PTR_UINT_PTR, + BT_VOID, BT_INT, BT_INT, BT_PTR, BT_PTR, BT_PTR, BT_INT, + BT_PTR, BT_INT, BT_PTR, BT_UINT, BT_PTR) DEF_FUNCTION_TYPE_VAR_0 (BT_FN_VOID_VAR, BT_VOID) |