diff options
| author | Ian Lance Taylor <iant@golang.org> | 2021-09-13 10:37:49 -0700 |
|---|---|---|
| committer | Ian Lance Taylor <iant@golang.org> | 2021-09-13 10:37:49 -0700 |
| commit | e252b51ccde010cbd2a146485d8045103cd99533 (patch) | |
| tree | e060f101cdc32bf5e520de8e5275db9d4236b74c /gcc/fortran | |
| parent | f10c7c4596dda99d2ee872c995ae4aeda65adbdf (diff) | |
| parent | 104c05c5284b7822d770ee51a7d91946c7e56d50 (diff) | |
| download | gcc-e252b51ccde010cbd2a146485d8045103cd99533.zip gcc-e252b51ccde010cbd2a146485d8045103cd99533.tar.gz gcc-e252b51ccde010cbd2a146485d8045103cd99533.tar.bz2 | |
Merge from trunk revision 104c05c5284b7822d770ee51a7d91946c7e56d50.
Diffstat (limited to 'gcc/fortran')
44 files changed, 5499 insertions, 1123 deletions
diff --git a/gcc/fortran/ChangeLog b/gcc/fortran/ChangeLog index 8cc9403..991f3cf 100644 --- a/gcc/fortran/ChangeLog +++ b/gcc/fortran/ChangeLog @@ -1,3 +1,964 @@ +2021-09-09 Harald Anlauf <anlauf@gmx.de> + + PR fortran/98490 + * trans-expr.c (gfc_conv_substring): Do not generate substring + bounds check for implied do loop index variable before it actually + becomes defined. + +2021-09-08 liuhongt <hongtao.liu@intel.com> + + * options.c (gfc_post_options): Issue an error for + -fexcess-precision=16. + +2021-09-07 Harald Anlauf <anlauf@gmx.de> + + PR fortran/101327 + * expr.c (find_array_element): When bounds cannot be determined as + constant, return error instead of aborting. + +2021-09-07 Marcel Vollweiler <marcel@codesourcery.com> + + * openmp.c (gfc_match_omp_flush): Parse 'seq_cst' clause on 'flush' + directive. + * trans-openmp.c (gfc_trans_omp_flush): Handle OMP_MEMORDER_SEQ_CST. + +2021-09-03 Tobias Burnus <tobias@codesourcery.com> + + * decl.c (gfc_verify_c_interop_param): Reject pointer with + CONTIGUOUS attributes as dummy arg. Reject character len > 1 + when passed as byte stream. + +2021-09-01 Harald Anlauf <anlauf@gmx.de> + + PR fortran/56985 + * resolve.c (resolve_common_vars): Fix grammar and improve wording + of error message rejecting an unlimited polymorphic in COMMON. + +2021-08-31 Harald Anlauf <anlauf@gmx.de> + + PR fortran/100950 + * simplify.c (substring_has_constant_len): Minimize checks for + substring expressions being allowed. + +2021-08-31 Marcel Vollweiler <marcel@codesourcery.com> + + * gfortran.h: Add variable for 'ancestor' in struct gfc_omp_clauses. + * openmp.c (gfc_match_omp_clauses): Parse device-modifiers 'device_num' + and 'ancestor' in 'target device' clauses. + * trans-openmp.c (gfc_trans_omp_clauses): Set OMP_CLAUSE_DEVICE_ANCESTOR. + +2021-08-30 Harald Anlauf <anlauf@gmx.de> + + PR fortran/102113 + * match.c (gfc_match_goto): Allow for whitespace in parsing list + of labels. + +2021-08-30 Harald Anlauf <anlauf@gmx.de> + + PR fortran/101349 + * resolve.c (resolve_allocate_expr): An unlimited polymorphic + argument to ALLOCATE must be ALLOCATABLE or a POINTER. Fix the + corresponding check. + +2021-08-28 Harald Anlauf <anlauf@gmx.de> + + PR fortran/87737 + * resolve.c (resolve_entries): For functions of type CHARACTER + tighten the checks for matching characteristics. + +2021-08-25 Lewis Hyatt <lhyatt@gmail.com> + + PR other/93067 + * cpp.c (gfc_cpp_post_options): Call new function + diagnostic_initialize_input_context(). + +2021-08-24 Harald Anlauf <anlauf@gmx.de> + + PR fortran/98411 + * trans-decl.c (gfc_finish_var_decl): Adjust check to handle + implicit SAVE as well as variables in the main program. Improve + warning message text. + +2021-08-23 Tobias Burnus <tobias@codesourcery.com> + + * openmp.c (gfc_match_dupl_check, gfc_match_dupl_memorder, + gfc_match_dupl_atomic): New. + (gfc_match_omp_clauses): Use them; remove duplicate + 'release'/'relaxed' clause matching; improve error dignostic + for 'default'. + +2021-08-23 Tobias Burnus <tobias@codesourcery.com> + + * dump-parse-tree.c (show_omp_clauses): Handle 'strict' modifier + on grainsize/num_tasks + * gfortran.h (gfc_omp_clauses): Add grainsize_strict + and num_tasks_strict. + * trans-openmp.c (gfc_trans_omp_clauses, gfc_split_omp_clauses): + Handle 'strict' modifier on grainsize/num_tasks. + * openmp.c (gfc_match_omp_clauses): Likewise. + +2021-08-20 Tobias Burnus <tobias@codesourcery.com> + + * error.c + (error_uinteger): Take 'long long unsigned' instead + of 'long unsigned' as argumpent. + (error_integer): Take 'long long' instead of 'long'. + (error_hwuint, error_hwint): New. + (error_print): Update to handle 'll' and 'w' + length modifiers. + * simplify.c (substring_has_constant_len): Use '%wd' + in gfc_error. + +2021-08-20 Harald Anlauf <anlauf@gmx.de> + + PR fortran/100950 + * simplify.c (substring_has_constant_len): Fix format string of + gfc_error, pass HOST_WIDE_INT bounds values via char buffer. + +2021-08-20 Tobias Burnus <tobias@codesourcery.com> + + * dump-parse-tree.c (show_omp_clauses): Handle 'at', 'severity' + and 'message' clauses. + (show_omp_node, show_code_node): Handle EXEC_OMP_ERROR. + * gfortran.h (gfc_statement): Add ST_OMP_ERROR. + (gfc_omp_severity_type, gfc_omp_at_type): New. + (gfc_omp_clauses): Add 'at', 'severity' and 'message' clause; + use more bitfields + ENUM_BITFIELD. + (gfc_exec_op): Add EXEC_OMP_ERROR. + * match.h (gfc_match_omp_error): New. + * openmp.c (enum omp_mask1): Add OMP_CLAUSE_(AT,SEVERITY,MESSAGE). + (gfc_match_omp_clauses): Handle new clauses. + (OMP_ERROR_CLAUSES, gfc_match_omp_error): New. + (resolve_omp_clauses): Resolve new clauses. + (omp_code_to_statement, gfc_resolve_omp_directive): Handle + EXEC_OMP_ERROR. + * parse.c (decode_omp_directive, next_statement, + gfc_ascii_statement): Handle 'omp error'. + * resolve.c (gfc_resolve_blocks): Likewise. + * st.c (gfc_free_statement): Likewise. + * trans-openmp.c (gfc_trans_omp_error): Likewise. + (gfc_trans_omp_directive): Likewise. + * trans.c (trans_code): Likewise. + +2021-08-20 Jakub Jelinek <jakub@redhat.com> + + * types.def (BT_FN_VOID_CONST_PTR_SIZE): New DEF_FUNCTION_TYPE_2. + * f95-lang.c (ATTR_COLD_NORETURN_NOTHROW_LEAF_LIST): Define. + +2021-08-19 Harald Anlauf <anlauf@gmx.de> + + PR fortran/100950 + * simplify.c (substring_has_constant_len): New. + (gfc_simplify_len): Handle case of substrings with constant + bounds. + +2021-08-18 Tobias Burnus <tobias@codesourcery.com> + + * match.h (gfc_match_omp_nothing): New. + * openmp.c (gfc_match_omp_nothing): New. + * parse.c (decode_omp_directive): Match 'nothing' directive. + +2021-08-17 Tobias Burnus <tobias@codesourcery.com> + + * dump-parse-tree.c (show_omp_node, show_code_node): Handle + EXEC_OMP_SCOPE. + * gfortran.h (enum gfc_statement): Add ST_OMP_(END_)SCOPE. + (enum gfc_exec_op): Add EXEC_OMP_SCOPE. + * match.h (gfc_match_omp_scope): New. + * openmp.c (OMP_SCOPE_CLAUSES): Define + (gfc_match_omp_scope): New. + (gfc_match_omp_cancellation_point, gfc_match_omp_end_nowait): + Improve error diagnostic. + (omp_code_to_statement): Handle ST_OMP_SCOPE. + (gfc_resolve_omp_directive): Handle EXEC_OMP_SCOPE. + * parse.c (decode_omp_directive, next_statement, + gfc_ascii_statement, parse_omp_structured_block, + parse_executable): Handle OpenMP's scope construct. + * resolve.c (gfc_resolve_blocks): Likewise + * st.c (gfc_free_statement): Likewise + * trans-openmp.c (gfc_trans_omp_scope): New. + (gfc_trans_omp_directive): Call it. + * trans.c (trans_code): handle EXEC_OMP_SCOPE. + +2021-08-16 Tobias Burnus <tobias@codesourcery.com> + + * dump-parse-tree.c (show_omp_clauses): Handle 'filter' clause. + (show_omp_node, show_code_node): Handle (combined) omp masked construct. + * frontend-passes.c (gfc_code_walker): Likewise. + * gfortran.h (enum gfc_statement): Add ST_OMP_*_MASKED*. + (enum gfc_exec_op): Add EXEC_OMP_*_MASKED*. + * match.h (gfc_match_omp_masked, gfc_match_omp_masked_taskloop, + gfc_match_omp_masked_taskloop_simd, gfc_match_omp_parallel_masked, + gfc_match_omp_parallel_masked_taskloop, + gfc_match_omp_parallel_masked_taskloop_simd): New prototypes. + * openmp.c (enum omp_mask1): Add OMP_CLAUSE_FILTER. + (gfc_match_omp_clauses): Match it. + (OMP_MASKED_CLAUSES, gfc_match_omp_parallel_masked, + gfc_match_omp_parallel_masked_taskloop, + gfc_match_omp_parallel_masked_taskloop_simd, + gfc_match_omp_masked, gfc_match_omp_masked_taskloop, + gfc_match_omp_masked_taskloop_simd): New. + (resolve_omp_clauses): Resolve filter clause. + (gfc_resolve_omp_parallel_blocks, resolve_omp_do, + omp_code_to_statement, gfc_resolve_omp_directive): Handle + omp masked constructs. + * parse.c (decode_omp_directive, case_exec_markers, + gfc_ascii_statement, parse_omp_do, parse_omp_structured_block, + parse_executable): Likewise. + * resolve.c (gfc_resolve_blocks, gfc_resolve_code): Likewise. + * st.c (gfc_free_statement): Likewise. + * trans-openmp.c (gfc_trans_omp_clauses): Handle filter clause. + (GFC_OMP_SPLIT_MASKED, GFC_OMP_MASK_MASKED): New enum values. + (gfc_trans_omp_masked): New. + (gfc_split_omp_clauses): Handle combined masked directives. + (gfc_trans_omp_master_taskloop): Rename to ... + (gfc_trans_omp_master_masked_taskloop): ... this; handle also + combined masked directives. + (gfc_trans_omp_parallel_master): Rename to ... + (gfc_trans_omp_parallel_master_masked): ... this; handle + combined masked directives. + (gfc_trans_omp_directive): Handle EXEC_OMP_*_MASKED*. + * trans.c (trans_code): Likewise. + +2021-08-15 Harald Anlauf <anlauf@gmx.de> + + PR fortran/99351 + * match.c (sync_statement): Replace %v code by %e in gfc_match to + allow for function references as STAT and ERRMSG arguments. + * resolve.c (resolve_sync): Adjust checks of STAT= and ERRMSG= to + being definable arguments. Function references with a data + pointer result are accepted. + * trans-stmt.c (gfc_trans_sync): Adjust assertion. + +2021-08-12 Tobias Burnus <tobias@codesourcery.com> + + * gfortran.h (gfc_omp_proc_bind_kind): Add OMP_PROC_BIND_PRIMARY. + * dump-parse-tree.c (show_omp_clauses): Add TODO comment to + change 'master' to 'primary' in proc_bind for OpenMP 5.1. + * intrinsic.texi (OMP_LIB): Mention OpenMP 5.1; add + omp_proc_bind_primary. + * openmp.c (gfc_match_omp_clauses): Accept + 'primary' as alias for 'master'. + * trans-openmp.c (gfc_trans_omp_clauses): Handle + OMP_PROC_BIND_PRIMARY. + +2021-08-11 Sandra Loosemore <sandra@codesourcery.com> + + * iso-c-binding.def (c_float128, c_float128_complex): Check + float128_type_node instead of gfc_float128_type_node. + * trans-types.c (gfc_init_kinds, gfc_build_real_type): + Update comments re supported 128-bit floating-point types. + +2021-08-11 Richard Biener <rguenther@suse.de> + + * trans-common.c (create_common): Set TREE_THIS_VOLATILE on the + COMPONENT_REF if the field is volatile. + +2021-08-07 Harald Anlauf <anlauf@gmx.de> + + PR fortran/68568 + * primary.c (gfc_expr_attr): Variable attribute can only be + inquired when symtree is non-NULL. + +2021-07-28 Harald Anlauf <anlauf@gmx.de> + + PR fortran/101564 + * expr.c (gfc_check_vardef_context): Add check for KIND and LEN + parameter inquiries. + * match.c (gfc_match): Fix comment for %v code. + (gfc_match_allocate, gfc_match_deallocate): Replace use of %v code + by %e in gfc_match to allow for function references as STAT and + ERRMSG arguments. + * resolve.c (resolve_allocate_deallocate): Avoid NULL pointer + dereferences and shortcut for bad STAT and ERRMSG argument to + (DE)ALLOCATE. Remove bogus parts of checks for STAT and ERRMSG. + +2021-07-26 José Rui Faustino de Sousa <jrfsousa@gmail.com> + Tobias Burnus <tobias@codesourcery.com> + + PR fortran/93308 + PR fortran/93963 + PR fortran/94327 + PR fortran/94331 + PR fortran/97046 + * trans-decl.c (convert_CFI_desc): Only copy out the descriptor + if necessary. + * trans-expr.c (gfc_conv_gfc_desc_to_cfi_desc): Updated attribute + handling which reflect a previous intermediate version of the + standard. Only copy out the descriptor if necessary. + +2021-07-23 Harald Anlauf <anlauf@gmx.de> + + PR fortran/101536 + * check.c (array_check): Adjust check for the case of CLASS + arrays. + +2021-07-21 Thomas Schwinge <thomas@codesourcery.com> + Joseph Myers <joseph@codesourcery.com> + Cesar Philippidis <cesar@codesourcery.com> + + * dump-parse-tree.c (show_attr): Update. + * gfortran.h (symbol_attribute): Add 'oacc_routine_nohost' member. + (gfc_omp_clauses): Add 'nohost' member. + * module.c (ab_attribute): Add 'AB_OACC_ROUTINE_NOHOST'. + (attr_bits, mio_symbol_attribute): Update. + * openmp.c (omp_mask2): Add 'OMP_CLAUSE_NOHOST'. + (gfc_match_omp_clauses): Handle 'OMP_CLAUSE_NOHOST'. + (OACC_ROUTINE_CLAUSES): Add 'OMP_CLAUSE_NOHOST'. + (gfc_match_oacc_routine): Update. + * trans-decl.c (add_attributes_to_decl): Update. + * trans-openmp.c (gfc_trans_omp_clauses): Likewise. + +2021-07-21 Harald Anlauf <anlauf@gmx.de> + + PR fortran/101514 + * target-memory.c (gfc_interpret_derived): Size of array component + of derived type can only be computed here for explicit shape. + * trans-types.c (gfc_get_nodesc_array_type): Do not dereference + NULL pointers. + +2021-07-21 Tobias Burnus <tobias@codesourcery.com> + + * decl.c (gfc_verify_c_interop_param): Update for F2008 + F2018 + changes; reject unsupported bits with 'Error: Sorry,'. + * trans-expr.c (gfc_conv_procedure_call): Fix condition to + For using CFI descriptor with characters. + +2021-07-18 Harald Anlauf <anlauf@gmx.de> + + PR fortran/101084 + * io.c (resolve_tag_format): Extend FORMAT check to unknown type. + +2021-07-14 Harald Anlauf <anlauf@gmx.de> + + PR fortran/100949 + * trans-expr.c (gfc_trans_class_init_assign): Call + gfc_conv_expr_present only for dummy variables. + +2021-07-06 Thomas Koenig <tkoenig@gcc.gnu.org> + + PR fortran/100227 + * frontend-passes.c (traverse_io_block): Adjust test for + when a variable is eligible for the transformation to + array slice. + +2021-06-28 Martin Sebor <msebor@redhat.com> + + * trans-array.c (trans_array_constructor): Replace direct uses + of TREE_NO_WARNING with warning_suppressed_p, and suppress_warning. + * trans-decl.c (gfc_build_qualified_array): Same. + (gfc_build_dummy_array_decl): Same. + (generate_local_decl): Same. + (gfc_generate_function_code): Same. + * trans-openmp.c (gfc_omp_clause_default_ctor): Same. + (gfc_omp_clause_copy_ctor): Same. + * trans-types.c (get_dtype_type_node): Same. + (gfc_get_desc_dim_type): Same. + (gfc_get_array_descriptor_base): Same. + (gfc_get_caf_vector_type): Same. + (gfc_get_caf_reference_type): Same. + * trans.c (gfc_create_var_np): Same. + +2021-06-23 Tobias Burnus <tobias@codesourcery.com> + + * dump-parse-tree.c (show_omp_clauses): Fix enum type used + for dumping gfc_omp_defaultmap_category. + +2021-06-23 Andre Vehreschild <vehre@gcc.gnu.org> + + PR fortran/100337 + * trans-intrinsic.c (conv_co_collective): Check stat for null ptr + before dereferrencing. + +2021-06-18 Harald Anlauf <anlauf@gmx.de> + + PR fortran/100283 + PR fortran/101123 + * trans-intrinsic.c (gfc_conv_intrinsic_minmax): Unconditionally + convert result of min/max to result type. + +2021-06-16 Harald Anlauf <anlauf@gmx.de> + + PR fortran/95501 + PR fortran/95502 + * expr.c (gfc_check_pointer_assign): Avoid NULL pointer + dereference. + * match.c (gfc_match_pointer_assignment): Likewise. + * parse.c (gfc_check_do_variable): Avoid comparison with NULL + symtree. + +2021-06-16 Harald Anlauf <anlauf@gmx.de> + + Revert: + 2021-06-16 Harald Anlauf <anlauf@gmx.de> + + PR fortran/95501 + PR fortran/95502 + * expr.c (gfc_check_pointer_assign): Avoid NULL pointer + dereference. + * match.c (gfc_match_pointer_assignment): Likewise. + * parse.c (gfc_check_do_variable): Avoid comparison with NULL + symtree. + +2021-06-16 Harald Anlauf <anlauf@gmx.de> + + PR fortran/95501 + PR fortran/95502 + * expr.c (gfc_check_pointer_assign): Avoid NULL pointer + dereference. + * match.c (gfc_match_pointer_assignment): Likewise. + * parse.c (gfc_check_do_variable): Avoid comparison with NULL + symtree. + +2021-06-15 Tobias Burnus <tobias@codesourcery.com> + + PR fortran/92568 + * dump-parse-tree.c (show_omp_clauses): Update for defaultmap. + * f95-lang.c (LANG_HOOKS_OMP_ALLOCATABLE_P, + LANG_HOOKS_OMP_SCALAR_TARGET_P): New. + * gfortran.h (enum gfc_omp_defaultmap, + enum gfc_omp_defaultmap_category): New. + * openmp.c (gfc_match_omp_clauses): Update defaultmap matching. + * trans-decl.c (gfc_finish_decl_attrs): Set GFC_DECL_SCALAR_TARGET. + * trans-openmp.c (gfc_omp_allocatable_p, gfc_omp_scalar_target_p): New. + (gfc_omp_scalar_p): Take 'ptr_alloc_ok' argument. + (gfc_trans_omp_clauses, gfc_split_omp_clauses): Update for + defaultmap changes. + * trans.h (gfc_omp_scalar_p): Update prototype. + (gfc_omp_allocatable_p, gfc_omp_scalar_target_p): New. + (struct lang_decl): Add scalar_target. + (GFC_DECL_SCALAR_TARGET, GFC_DECL_GET_SCALAR_TARGET): New. + +2021-06-14 Tobias Burnus <tobias@codesourcery.com> + + * resolve.c (resolve_variable): Remove *XCNEW used to + nullify nullified memory. + +2021-06-09 Martin Liska <mliska@suse.cz> + + * intrinsic.texi: Add missing @headitem to tables with a header. + +2021-06-09 Jakub Jelinek <jakub@redhat.com> + + PR fortran/100965 + * trans-openmp.c (gfc_omp_finish_clause): Gimplify OMP_CLAUSE_SIZE. + +2021-06-08 Tobias Burnus <tobias@codesourcery.com> + + PR middle-end/99928 + * trans-openmp.c (gfc_add_clause_implicitly): New. + (gfc_split_omp_clauses): Use it. + (gfc_free_split_omp_clauses): New. + (gfc_trans_omp_do_simd, gfc_trans_omp_parallel_do, + gfc_trans_omp_parallel_do_simd, gfc_trans_omp_distribute, + gfc_trans_omp_teams, gfc_trans_omp_target, gfc_trans_omp_taskloop, + gfc_trans_omp_master_taskloop, gfc_trans_omp_parallel_master): Use it. + +2021-06-08 Martin Liska <mliska@suse.cz> + + * intrinsic.texi: Fix typo. + * trans-expr.c (gfc_trans_pointer_assignment): Likewise. + +2021-06-05 José Rui Faustino de Sousa <jrfsousa@gmail.com> + + PR fortran/100120 + PR fortran/100816 + PR fortran/100818 + PR fortran/100819 + PR fortran/100821 + * trans-array.c (gfc_get_array_span): rework the way character + array "span" was calculated. + (gfc_conv_expr_descriptor): improve handling of character sections + and unlimited polymorphic objects. + * trans-expr.c (gfc_get_character_len): new function to calculate + character string length. + (gfc_get_character_len_in_bytes): new function to calculate + character string length in bytes. + (gfc_conv_scalar_to_descriptor): add call to set the "span". + (gfc_trans_pointer_assignment): set "_len" and antecipate the + initialization of the deferred character length hidden argument. + * trans-intrinsic.c (gfc_conv_associated): set "force_no_tmp" to + avoid the creation of a temporary. + * trans-types.c (gfc_get_dtype_rank_type): rework type detection + so that unlimited polymorphic objects get proper type infomation, + also important for bind(c). + (gfc_get_dtype): add argument to pass the rank if necessary. + (gfc_get_array_type_bounds): cosmetic change to have character + arrays called character instead of unknown. + * trans-types.h (gfc_get_dtype): modify prototype. + * trans.c (get_array_span): rework the way character array "span" + was calculated. + * trans.h (gfc_get_character_len): new prototype. + (gfc_get_character_len_in_bytes): new prototype. + Add "unlimited_polymorphic" flag to "gfc_se" type to signal when + expression carries an unlimited polymorphic object. + +2021-06-04 Harald Anlauf <anlauf@gmx.de> + + PR fortran/99839 + * frontend-passes.c (inline_matmul_assign): Do not inline matmul + if the assignment to the resulting array if it is not of canonical + type (real/integer/complex/logical). + +2021-06-04 Tobias Burnus <tobias@codesourcery.com> + + * dump-parse-tree.c (show_code_node): Handle + EXEC_OMP_(TARGET_)(,PARALLEL_,TEAMS_)LOOP. + +2021-06-04 Tobias Burnus <tobias@codesourcery.com> + + * scanner.c (skip_fixed_omp_sentinel): Set openacc_flag if + this is not an (OpenMP) continuation line. + (skip_fixed_oacc_sentinel): Likewise for openmp_flag and OpenACC. + (gfc_next_char_literal): gfc_error_now to force error for mixed OMP/ACC + continuation once per location and return '\n'. + +2021-06-04 Tobias Burnus <tobias@codesourcery.com> + + PR middle-end/99928 + * openmp.c (gfc_match_omp_clauses): Fix typo in error message. + +2021-06-04 Tobias Burnus <tobias@codesourcery.com> + + PR middle-end/99928 + * dump-parse-tree.c (show_omp_clauses): Handle bind clause. + (show_omp_node): Handle loop directive. + * frontend-passes.c (gfc_code_walker): Likewise. + * gfortran.h (enum gfc_statement): Add + ST_OMP_(END_)(TARGET_)(|PARALLEL_|TEAMS_)LOOP. + (enum gfc_omp_bind_type): New. + (gfc_omp_clauses): Use it. + (enum gfc_exec_op): Add EXEC_OMP_(TARGET_)(|PARALLEL_|TEAMS_)LOOP. + * match.h (gfc_match_omp_loop, gfc_match_omp_parallel_loop, + gfc_match_omp_target_parallel_loop, gfc_match_omp_target_teams_loop, + gfc_match_omp_teams_loop): New. + * openmp.c (enum omp_mask1): Add OMP_CLAUSE_BIND. + (gfc_match_omp_clauses): Handle it. + (OMP_LOOP_CLAUSES, gfc_match_omp_loop, gfc_match_omp_teams_loop, + gfc_match_omp_target_teams_loop, gfc_match_omp_parallel_loop, + gfc_match_omp_target_parallel_loop): New. + (resolve_omp_clauses, resolve_omp_do, omp_code_to_statement, + gfc_resolve_omp_directive): Handle omp loop. + * parse.c (decode_omp_directive case_exec_markers, gfc_ascii_statement, + parse_omp_do, parse_executable): Likewise. + (parse_omp_structured_block): Remove ST_ which use parse_omp_do. + * resolve.c (gfc_resolve_blocks): Add omp loop. + * st.c (gfc_free_statement): Likewise. + * trans-openmp.c (gfc_trans_omp_clauses): Handle bind clause. + (gfc_trans_omp_do, gfc_trans_omp_parallel_do, gfc_trans_omp_distribute, + gfc_trans_omp_teams, gfc_trans_omp_target, gfc_trans_omp_directive): + Handle loop directive. + (gfc_split_omp_clauses): Likewise; fix firstprivate/lastprivate + and (in_)reduction for taskloop. + * trans.c (trans_code): Handle omp loop directive. + +2021-06-01 Tobias Burnus <tobias@codesourcery.com> + + PR middle-end/99928 + * dump-parse-tree.c (show_omp_node, show_code_node): Handle + (parallel) master taskloop (simd). + * frontend-passes.c (gfc_code_walker): Set in_omp_workshare + to false for parallel master taskloop (simd). + * gfortran.h (enum gfc_statement): + Add ST_OMP_(END_)(PARALLEL_)MASTER_TASKLOOP(_SIMD). + (enum gfc_exec_op): EXEC_OMP_(PARALLEL_)MASTER_TASKLOOP(_SIMD). + * match.h (gfc_match_omp_master_taskloop, + gfc_match_omp_master_taskloop_simd, + gfc_match_omp_parallel_master_taskloop, + gfc_match_omp_parallel_master_taskloop_simd): New prototype. + * openmp.c (gfc_match_omp_parallel_master_taskloop, + gfc_match_omp_parallel_master_taskloop_simd, + gfc_match_omp_master_taskloop, + gfc_match_omp_master_taskloop_simd): New. + (gfc_match_omp_taskloop_simd): Permit 'reduction' clause. + (resolve_omp_clauses): Handle new combined directives; remove + inscan-reduction check to reduce multiple errors; add + task-reduction error for 'taskloop simd'. + (gfc_resolve_omp_parallel_blocks, + resolve_omp_do, omp_code_to_statement, + gfc_resolve_omp_directive): Handle new combined constructs. + * parse.c (decode_omp_directive, next_statement, + gfc_ascii_statement, parse_omp_do, parse_omp_structured_block, + parse_executable): Likewise. + * resolve.c (gfc_resolve_blocks, gfc_resolve_code): Likewise. + * st.c (gfc_free_statement): Likewise. + * trans.c (trans_code): Likewise. + * trans-openmp.c (gfc_split_omp_clauses, + gfc_trans_omp_directive): Likewise. + (gfc_trans_omp_parallel_master): Move after gfc_trans_omp_master_taskloop; + handle parallel master taskloop (simd) as well. + (gfc_trans_omp_taskloop): Take gfc_exec_op as arg. + (gfc_trans_omp_master_taskloop): New. + +2021-05-30 Gerald Pfeifer <gerald@pfeifer.com> + + * gfortran.texi (BOZ literal constants): Fix typo. + +2021-05-28 Tobias Burnus <tobias@codesourcery.com> + + * dump-parse-tree.c (show_iterator): New. + (show_omp_namelist): Handle iterators. + (show_omp_clauses): Handle affinity. + * gfortran.h (gfc_free_omp_namelist): New union with 'udr' and new 'ns'. + * match.c (gfc_free_omp_namelist): Add are to choose union element. + * openmp.c (gfc_free_omp_clauses, gfc_match_omp_detach, + gfc_match_omp_clause_reduction, gfc_match_omp_flush): Update + call to gfc_free_omp_namelist. + (gfc_match_omp_variable_list): Likewise; permit preceeding whitespace. + (enum omp_mask1): Add OMP_CLAUSE_AFFINITY. + (gfc_match_iterator): New. + (gfc_match_omp_clauses): Use it; update call to gfc_free_omp_namelist. + (OMP_TASK_CLAUSES): Add OMP_CLAUSE_AFFINITY. + (gfc_match_omp_taskwait): Match depend clause. + (resolve_omp_clauses): Handle affinity; update for udr/union change. + (gfc_resolve_omp_directive): Resolve clauses of taskwait. + * st.c (gfc_free_statement): Update gfc_free_omp_namelist call. + * trans-openmp.c (gfc_trans_omp_array_reduction_or_udr): Likewise + (handle_iterator): New. + (gfc_trans_omp_clauses): Handle iterators for depend/affinity clause. + (gfc_trans_omp_taskwait): Handle depend clause. + (gfc_trans_omp_directive): Update call. + +2021-05-27 Harald Anlauf <anlauf@gmx.de> + + PR fortran/100602 + * trans-intrinsic.c (gfc_conv_intrinsic_size): Use CLASS data + attributes for CLASS arrays for generation of runtime error. + +2021-05-27 Harald Anlauf <anlauf@gmx.de> + + PR fortran/100656 + * trans-array.c (gfc_conv_ss_startstride): Do not call check for + presence of a dummy argument when a symbol actually refers to a + non-dummy. + +2021-05-25 Tobias Burnus <tobias@codesourcery.com> + Johannes Nendwich <a08727063@unet.univie.ac.at> + + * intrinsic.texi (GERROR, GETARGS, GETLOG, NORM2, PARITY, RANDOM_INIT, + RANDOM_NUMBER): Fix typos and copy'n'paste errors. + +2021-05-24 Tobias Burnus <tobias@codesourcery.com> + + PR fortran/86470 + * trans-expr.c (gfc_copy_class_to_class): Add unshare_expr. + * trans-openmp.c (gfc_is_polymorphic_nonptr, + gfc_is_unlimited_polymorphic_nonptr): New. + (gfc_omp_clause_copy_ctor, gfc_omp_clause_dtor): Handle + polymorphic scalars. + +2021-05-23 Harald Anlauf <anlauf@gmx.de> + + PR fortran/100551 + * trans-expr.c (gfc_conv_procedure_call): Adjust check for + implicit conversion of actual argument to an unlimited polymorphic + procedure argument. + +2021-05-23 Tobias Burnus <tobias@codesourcery.com> + + * intrinsic.texi (ATOMIC_ADD, ATOMIC_FETCH_ADD): Use the + proper variable name in the description. + +2021-05-22 Andre Vehreschild <vehre@gcc.gnu.org> + Steve Kargl <kargl@gcc.gnu.org> + + PR fortran/98301 + * trans-decl.c (gfc_build_builtin_function_decls): Move decl. + * trans-intrinsic.c (conv_intrinsic_random_init): Use bool for + lib-call of caf_random_init instead of logical (4-byte). + * trans.h: Add tree var for random_init. + +2021-05-20 Marcel Vollweiler <marcel@codesourcery.com> + + * openmp.c (gfc_match_omp_clauses): Support map-type-modifier 'close'. + +2021-05-18 Tobias Burnus <tobias@codesourcery.com> + + PR fortran/100642 + * openmp.c (omp_code_to_statement): Add missing EXEC_OMP_DEPOBJ. + +2021-05-17 Harald Anlauf <anlauf@gmx.de> + + PR fortran/98411 + * trans-decl.c (gfc_finish_var_decl): Add check for explicit SAVE + attribute. + +2021-05-17 Tobias Burnus <tobias@codesourcery.com> + + PR fortran/100633 + * resolve.c (gfc_resolve_code): Reject nonintrinsic assignments in + OMP WORKSHARE. + +2021-05-14 Tobias Burnus <tobias@codesourcery.com> + + * dump-parse-tree.c (show_omp_node, show_code_node): Handle + EXEC_OMP_PARALLEL_MASTER. + * frontend-passes.c (gfc_code_walker): Likewise. + * gfortran.h (enum gfc_statement): Add ST_OMP_PARALLEL_MASTER and + ST_OMP_END_PARALLEL_MASTER. + (enum gfc_exec_op): Add EXEC_OMP_PARALLEL_MASTER.. + * match.h (gfc_match_omp_parallel_master): Handle it. + * openmp.c (gfc_match_omp_parallel_master, resolve_omp_clauses, + omp_code_to_statement, gfc_resolve_omp_directive): Likewise. + * parse.c (decode_omp_directive, case_exec_markers, + gfc_ascii_statement, parse_omp_structured_block, + parse_executable): Likewise. + * resolve.c (gfc_resolve_blocks, gfc_resolve_code): Likewise. + * st.c (gfc_free_statement): Likewise. + * trans-openmp.c (gfc_trans_omp_parallel_master, + gfc_trans_omp_workshare, gfc_trans_omp_directive): Likewise. + * trans.c (trans_code): Likewise. + +2021-05-14 Tobias Burnus <tobias@codesourcery.com> + + * resolve.c (resolve_symbol): Handle implicit SAVE of main-program + for vars in 'omp threadprivate' and 'omp declare target'. + +2021-05-10 Martin Liska <mliska@suse.cz> + + * decl.c (variable_decl): Use startswith + function instead of strncmp. + (gfc_match_end): Likewise. + * gfortran.h (gfc_str_startswith): Likewise. + * module.c (load_omp_udrs): Likewise. + (read_module): Likewise. + * options.c (gfc_handle_runtime_check_option): Likewise. + * primary.c (match_arg_list_function): Likewise. + * trans-decl.c (gfc_get_symbol_decl): Likewise. + * trans-expr.c (gfc_conv_procedure_call): Likewise. + * trans-intrinsic.c (gfc_conv_ieee_arithmetic_function): Likewise. + +2021-05-06 Paul Thomas <pault@gcc.gnu.org> + + PR fortran/46991 + PR fortran/99819 + * class.c (gfc_build_class_symbol): Remove the error that + disables assumed size class arrays. Class array types that are + not deferred shape or assumed rank are given a unique name and + placed in the procedure namespace. + * trans-array.c (gfc_trans_g77_array): Obtain the data pointer + for class arrays. + (gfc_trans_dummy_array_bias): Suppress the runtime error for + extent violations in explicit shape class arrays because it + always fails. + * trans-expr.c (gfc_conv_procedure_call): Handle assumed size + class actual arguments passed to non-descriptor formal args by + using the data pointer, stored as the symbol's backend decl. + +2021-05-05 Harald Anlauf <anlauf@gmx.de> + + PR fortran/100274 + * interface.c (gfc_compare_actual_formal): Continue checks after + emitting warning for argument length mismatch. + * trans-expr.c (gfc_conv_procedure_call): Check for NULL pointer + dereference. + +2021-05-04 Tobias Burnus <tobias@codesourcery.com> + + PR testsuite/100397 + * trans-openmp.c (gfc_trans_omp_depobj): Fix pasto in enum values. + +2021-04-28 Tobias Burnus <tobias@codesourcery.com> + + * openmp.c (gfc_match_omp_variable_list): Gobble whitespace before + checking whether a '%' or parenthesis-open follows as next character. + +2021-04-28 José Rui Faustino de Sousa <jrfsousa@gmail.com> + + PR fortran/82376 + * trans-expr.c (gfc_conv_procedure_call): Evaluate function result + and then pass a pointer. + +2021-04-26 Thomas Schwinge <thomas@codesourcery.com> + Nathan Sidwell <nathan@codesourcery.com> + Tom de Vries <vries@codesourcery.com> + Julian Brown <julian@codesourcery.com> + Kwok Cheung Yeung <kcy@codesourcery.com> + + * lang.opt (Wopenacc-parallelism): New. + +2021-04-24 Harald Anlauf <anlauf@gmx.de> + + PR fortran/100154 + * check.c (variable_check): Allow function reference having a data + pointer result. + (arg_strlen_is_zero): New function. + (gfc_check_fgetputc_sub): Add static check of character and status + arguments. + (gfc_check_fgetput_sub): Likewise. + * intrinsic.c (add_subroutines): Fix argument name for the + character argument to intrinsic subroutines fget[c], fput[c]. + +2021-04-24 Harald Anlauf <anlauf@gmx.de> + + PR fortran/100218 + * expr.c (gfc_check_vardef_context): Extend check to allow pointer + from a function reference. + +2021-04-22 Martin Liska <mliska@suse.cz> + + PR testsuite/100159 + PR testsuite/100192 + * frontend-passes.c (optimize_expr): Fix typos and missing comments. + +2021-04-22 Michael Meissner <meissner@linux.ibm.com> + + PR fortran/96983 + * trans-intrinsic.c (build_round_expr): If int type is larger than + long long, do the round and convert to the integer type. Do not + try to find a floating point type the exact size of the integer + type. + +2021-04-21 Tobias Burnus <tobias@codesourcery.com> + + * dump-parse-tree.c (show_omp_namelist): Handle depobj + mutexinoutset + in the depend clause. + (show_omp_clauses, show_omp_node, show_code_node): Handle depobj. + * gfortran.h (enum gfc_statement): Add ST_OMP_DEPOBJ. + (enum gfc_omp_depend_op): Add OMP_DEPEND_UNSET, + OMP_DEPEND_MUTEXINOUTSET and OMP_DEPEND_DEPOBJ. + (gfc_omp_clauses): Add destroy, depobj_update and depobj. + (enum gfc_exec_op): Add EXEC_OMP_DEPOBJ + * match.h (gfc_match_omp_depobj): Match 'omp depobj'. + * openmp.c (gfc_match_omp_clauses): Add depobj + mutexinoutset + to depend clause. + (gfc_match_omp_depobj, resolve_omp_clauses, gfc_resolve_omp_directive): + Handle 'omp depobj'. + * parse.c (decode_omp_directive, next_statement, gfc_ascii_statement): + Likewise. + * resolve.c (gfc_resolve_code): Likewise. + * st.c (gfc_free_statement): Likewise. + * trans-openmp.c (gfc_trans_omp_clauses): Handle depobj + mutexinoutset + in the depend clause. + (gfc_trans_omp_depobj, gfc_trans_omp_directive): Handle EXEC_OMP_DEPOBJ. + * trans.c (trans_code): Likewise. + +2021-04-20 Paul Thomas <pault@gcc.gnu.org> + + PR fortran/100110 + * trans-decl.c (gfc_get_symbol_decl): Replace test for host + association with a check that the current and symbol namespaces + are the same. + +2021-04-19 Thomas Schwinge <thomas@codesourcery.com> + + * lang.opt (fopenacc-kernels=): Remove. + +2021-04-16 José Rui Faustino de Sousa <jrfsousa@gmail.com> + + PR fortran/100094 + * trans-array.c (gfc_trans_deferred_array): Add code to initialize + pointers and allocatables with correct TKR parameters. + +2021-04-16 José Rui Faustino de Sousa <jrfsousa@gmail.com> + + PR fortran/100018 + * resolve.c: Add association check before de-referencing pointer. + +2021-04-16 Harald Anlauf <anlauf@gmx.de> + Paul Thomas <pault@gcc.gnu.org> + + PR fortran/63797 + * module.c (write_symtree): Do not write interface of intrinsic + procedure to module file for F2003 and newer. + +2021-04-15 Paul Thomas <pault@gcc.gnu.org> + + PR fortran/99307 + * symbol.c: Remove trailing white space. + * trans-array.c (gfc_trans_create_temp_array): Create a class + temporary for class expressions and assign the new descriptor + to the data field. + (build_class_array_ref): If the class expr can be extracted, + then use that for 'decl'. Class function results are reliably + handled this way. Call gfc_find_and_cut_at_last_class_ref to + eliminate largely redundant code. Remove dead code and recast + the rest of the code to extract 'decl' for remaining cases. + Call gfc_build_spanned_array_ref. + (gfc_alloc_allocatable_for_assignment): Use class descriptor + element length for 'elemsize1'. Eliminate repeat set of dtype + for class expressions. + * trans-expr.c (gfc_find_and_cut_at_last_class_ref): Include + additional code from build_class_array_ref, and use optional + gfc_typespec pointer argument. + (gfc_trans_scalar_assign): Make use of pre and post blocks for + all class expressions. + * trans.c (get_array_span): For unlimited polymorphic exprs + multiply the span by the value of the _len field. + (gfc_build_spanned_array_ref): New function. + (gfc_build_array_ref): Call gfc_build_spanned_array_ref and + eliminate repeated code. + * trans.h: Add arg to gfc_find_and_cut_at_last_class_ref and + add prototype for gfc_build_spanned_array_ref. + +2021-04-14 Martin Liska <mliska@suse.cz> + + * intrinsic.texi: The table has first column empty and it makes + trouble when processing makeinfo --xml output. + +2021-04-09 Tobias Burnus <tobias@codesourcery.com> + + PR fortran/99817 + * trans-types.c (gfc_get_function_type): Also generate hidden + coarray argument for character arguments. + +2021-04-03 Paul Thomas <pault@gcc.gnu.org> + + PR fortran/99818 + * interface.c (compare_parameter): The codimension attribute is + applied to the _data field of class formal arguments. + +2021-04-01 Harald Anlauf <anlauf@gmx.de> + + PR fortran/99840 + * simplify.c (gfc_simplify_transpose): Properly initialize + resulting shape. + +2021-03-28 Paul Thomas <pault@gcc.gnu.org> + + PR fortran/99602 + * trans-expr.c (gfc_conv_procedure_call): Use the _data attrs + for class expressions and detect proc pointer evaluations by + the non-null actual argument list. + +2021-03-27 Steve Kargl <kargl@gcc.gnu.org> + + * misc.c (gfc_typename): Fix off-by-one in buffer sizes. + +2021-03-26 Tobias Burnus <tobias@codesourcery.com> + + PR fortran/99651 + * intrinsic.c (gfc_intrinsic_func_interface): Set + attr.proc = PROC_INTRINSIC if FL_PROCEDURE. + +2021-03-24 Tobias Burnus <tobias@codesourcery.com> + + PR fortran/99369 + * resolve.c (resolve_operator): Make 'msg' buffer larger + and use snprintf. + +2021-03-23 Tobias Burnus <tobias@codesourcery.com> + + PR fortran/93660 + * trans-decl.c (build_function_decl): Add comment; + increment hidden_typelist for caf_token/caf_offset. + * trans-types.c (gfc_get_function_type): Add comment; + add missing caf_token/caf_offset args. + +2021-03-22 Tobias Burnus <tobias@codesourcery.com> + + PR fortran/99688 + * match.c (select_type_set_tmp, gfc_match_select_type, + gfc_match_select_rank): Fix 'name' buffersize to avoid out of bounds. + * resolve.c (resolve_select_type): Likewise. + +2021-03-19 Thomas Koenig <tkoenig@gcc.gnu.org> + + * frontend-passes.c (inline_limit_check): Add rank_a + argument. If a is rank 1, set the second dimension to 1. + (inline_matmul_assign): Pass rank_a argument to inline_limit_check. + (call_external_blas): Likewise. + 2021-03-15 Thomas Koenig <tkoenig@gcc.gnu.org> PR fortran/99345 diff --git a/gcc/fortran/check.c b/gcc/fortran/check.c index 82db8e4..851af1b 100644 --- a/gcc/fortran/check.c +++ b/gcc/fortran/check.c @@ -731,12 +731,11 @@ logical_array_check (gfc_expr *array, int n) static bool array_check (gfc_expr *e, int n) { - if (e->ts.type == BT_CLASS && gfc_expr_attr (e).class_ok + if (e->rank != 0 && e->ts.type == BT_CLASS && gfc_expr_attr (e).class_ok && CLASS_DATA (e)->attr.dimension && CLASS_DATA (e)->as->rank) { gfc_add_class_array_ref (e); - return true; } if (e->rank != 0 && e->ts.type != BT_PROCEDURE) @@ -1055,6 +1054,13 @@ variable_check (gfc_expr *e, int n, bool allow_proc) return true; } + /* F2018:R902: function reference having a data pointer result. */ + if (e->expr_type == EXPR_FUNCTION + && e->symtree->n.sym->attr.flavor == FL_PROCEDURE + && e->symtree->n.sym->attr.function + && e->symtree->n.sym->attr.pointer) + return true; + gfc_error ("%qs argument of %qs intrinsic at %L must be a variable", gfc_current_intrinsic_arg[n]->name, gfc_current_intrinsic, &e->where); @@ -5690,6 +5696,19 @@ gfc_check_spread (gfc_expr *source, gfc_expr *dim, gfc_expr *ncopies) functions). */ bool +arg_strlen_is_zero (gfc_expr *c, int n) +{ + if (gfc_var_strlen (c) == 0) + { + gfc_error ("%qs argument of %qs intrinsic at %L must have " + "length at least 1", gfc_current_intrinsic_arg[n]->name, + gfc_current_intrinsic, &c->where); + return true; + } + return false; +} + +bool gfc_check_fgetputc_sub (gfc_expr *unit, gfc_expr *c, gfc_expr *status) { if (!type_check (unit, 0, BT_INTEGER)) @@ -5702,13 +5721,19 @@ gfc_check_fgetputc_sub (gfc_expr *unit, gfc_expr *c, gfc_expr *status) return false; if (!kind_value_check (c, 1, gfc_default_character_kind)) return false; + if (strcmp (gfc_current_intrinsic, "fgetc") == 0 + && !variable_check (c, 1, false)) + return false; + if (arg_strlen_is_zero (c, 1)) + return false; if (status == NULL) return true; if (!type_check (status, 2, BT_INTEGER) || !kind_value_check (status, 2, gfc_default_integer_kind) - || !scalar_check (status, 2)) + || !scalar_check (status, 2) + || !variable_check (status, 2, false)) return false; return true; @@ -5729,13 +5754,19 @@ gfc_check_fgetput_sub (gfc_expr *c, gfc_expr *status) return false; if (!kind_value_check (c, 0, gfc_default_character_kind)) return false; + if (strcmp (gfc_current_intrinsic, "fget") == 0 + && !variable_check (c, 0, false)) + return false; + if (arg_strlen_is_zero (c, 0)) + return false; if (status == NULL) return true; if (!type_check (status, 1, BT_INTEGER) || !kind_value_check (status, 1, gfc_default_integer_kind) - || !scalar_check (status, 1)) + || !scalar_check (status, 1) + || !variable_check (status, 1, false)) return false; return true; diff --git a/gcc/fortran/class.c b/gcc/fortran/class.c index 8935321..93118ad 100644 --- a/gcc/fortran/class.c +++ b/gcc/fortran/class.c @@ -630,6 +630,7 @@ gfc_get_len_component (gfc_expr *e, int k) component '_vptr' which determines the dynamic type. When this CLASS entity is unlimited polymorphic, then also add a component '_len' to store the length of string when that is stored in it. */ +static int ctr = 0; bool gfc_build_class_symbol (gfc_typespec *ts, symbol_attribute *attr, @@ -645,13 +646,6 @@ gfc_build_class_symbol (gfc_typespec *ts, symbol_attribute *attr, gcc_assert (as); - if (*as && (*as)->type == AS_ASSUMED_SIZE) - { - gfc_error ("Assumed size polymorphic objects or components, such " - "as that at %C, have not yet been implemented"); - return false; - } - if (attr->class_ok) /* Class container has already been built. */ return true; @@ -693,7 +687,30 @@ gfc_build_class_symbol (gfc_typespec *ts, symbol_attribute *attr, else ns = ts->u.derived->ns; - gfc_find_symbol (name, ns, 0, &fclass); + /* Although this might seem to be counterintuitive, we can build separate + class types with different array specs because the TKR interface checks + work on the declared type. All array type other than deferred shape or + assumed rank are added to the function namespace to ensure that they + are properly distinguished. */ + if (attr->dummy && !attr->codimension && (*as) + && !((*as)->type == AS_DEFERRED || (*as)->type == AS_ASSUMED_RANK)) + { + char *sname; + ns = gfc_current_ns; + gfc_find_symbol (name, ns, 0, &fclass); + /* If a local class type with this name already exists, update the + name with an index. */ + if (fclass) + { + fclass = NULL; + sname = xasprintf ("%s_%d", name, ++ctr); + free (name); + name = sname; + } + } + else + gfc_find_symbol (name, ns, 0, &fclass); + if (fclass == NULL) { gfc_symtree *st; diff --git a/gcc/fortran/cpp.c b/gcc/fortran/cpp.c index 419cd6a..83c4517 100644 --- a/gcc/fortran/cpp.c +++ b/gcc/fortran/cpp.c @@ -493,6 +493,12 @@ gfc_cpp_post_options (void) cpp_post_options (cpp_in); + + /* Let diagnostics infrastructure know how to convert input files the same + way libcpp will do it, namely, with no charset conversion but with + skipping of a UTF-8 BOM if present. */ + diagnostic_initialize_input_context (global_dc, nullptr, true); + gfc_cpp_register_include_paths (); } diff --git a/gcc/fortran/decl.c b/gcc/fortran/decl.c index 947e4f8..f2e8896 100644 --- a/gcc/fortran/decl.c +++ b/gcc/fortran/decl.c @@ -1551,21 +1551,109 @@ gfc_verify_c_interop_param (gfc_symbol *sym) sym->ns->proc_name->name); } + /* Per F2018, 18.3.6 (5), pointer + contiguous is not permitted. */ + if (sym->attr.pointer && sym->attr.contiguous) + gfc_error ("Dummy argument %qs at %L may not be a pointer with " + "CONTIGUOUS attribute as procedure %qs is BIND(C)", + sym->name, &sym->declared_at, sym->ns->proc_name->name); + /* Character strings are only C interoperable if they have a - length of 1. */ - if (sym->ts.type == BT_CHARACTER && !sym->attr.dimension) + length of 1. However, as an argument they are also iteroperable + when passed as descriptor (which requires len=: or len=*). */ + if (sym->ts.type == BT_CHARACTER) { gfc_charlen *cl = sym->ts.u.cl; - if (!cl || !cl->length || cl->length->expr_type != EXPR_CONSTANT - || mpz_cmp_si (cl->length->value.integer, 1) != 0) + + if (sym->attr.allocatable || sym->attr.pointer) { - gfc_error ("Character argument %qs at %L " - "must be length 1 because " - "procedure %qs is BIND(C)", - sym->name, &sym->declared_at, - sym->ns->proc_name->name); + /* F2018, 18.3.6 (6). */ + if (!sym->ts.deferred) + { + if (sym->attr.allocatable) + gfc_error ("Allocatable character dummy argument %qs " + "at %L must have deferred length as " + "procedure %qs is BIND(C)", sym->name, + &sym->declared_at, sym->ns->proc_name->name); + else + gfc_error ("Pointer character dummy argument %qs at %L " + "must have deferred length as procedure %qs " + "is BIND(C)", sym->name, &sym->declared_at, + sym->ns->proc_name->name); + retval = false; + } + else if (!gfc_notify_std (GFC_STD_F2018, + "Deferred-length character dummy " + "argument %qs at %L of procedure " + "%qs with BIND(C) attribute", + sym->name, &sym->declared_at, + sym->ns->proc_name->name)) + retval = false; + else if (!sym->attr.dimension) + { + /* FIXME: Use CFI array descriptor for scalars. */ + gfc_error ("Sorry, deferred-length scalar character dummy " + "argument %qs at %L of procedure %qs with " + "BIND(C) not yet supported", sym->name, + &sym->declared_at, sym->ns->proc_name->name); + retval = false; + } + } + else if (sym->attr.value + && (!cl || !cl->length + || cl->length->expr_type != EXPR_CONSTANT + || mpz_cmp_si (cl->length->value.integer, 1) != 0)) + { + gfc_error ("Character dummy argument %qs at %L must be " + "of length 1 as it has the VALUE attribute", + sym->name, &sym->declared_at); retval = false; } + else if (!cl || !cl->length) + { + /* Assumed length; F2018, 18.3.6 (5)(2). + Uses the CFI array descriptor - also for scalars and + explicit-size/assumed-size arrays. */ + if (!gfc_notify_std (GFC_STD_F2018, + "Assumed-length character dummy argument " + "%qs at %L of procedure %qs with BIND(C) " + "attribute", sym->name, &sym->declared_at, + sym->ns->proc_name->name)) + retval = false; + else if (!sym->attr.dimension + || sym->as->type == AS_ASSUMED_SIZE + || sym->as->type == AS_EXPLICIT) + { + /* FIXME: Valid - should use the CFI array descriptor, but + not yet handled for scalars and assumed-/explicit-size + arrays. */ + gfc_error ("Sorry, character dummy argument %qs at %L " + "with assumed length is not yet supported for " + "procedure %qs with BIND(C) attribute", + sym->name, &sym->declared_at, + sym->ns->proc_name->name); + retval = false; + } + } + else if (cl->length->expr_type != EXPR_CONSTANT + || mpz_cmp_si (cl->length->value.integer, 1) != 0) + { + /* F2018, 18.3.6, (5), item 4. */ + if (!sym->attr.dimension + || sym->as->type == AS_ASSUMED_SIZE + || sym->as->type == AS_EXPLICIT) + { + gfc_error ("Character dummy argument %qs at %L must be " + "of constant length of one or assumed length, " + "unless it has assumed shape or assumed rank, " + "as procedure %qs has the BIND(C) attribute", + sym->name, &sym->declared_at, + sym->ns->proc_name->name); + retval = false; + } + /* else: valid only since F2018 - and an assumed-shape/rank + array; however, gfc_notify_std is already called when + those array types are used. Thus, silently accept F200x. */ + } } /* We have to make sure that any param to a bind(c) routine does @@ -2081,6 +2169,24 @@ add_init_expr_to_sym (const char *name, gfc_expr **initp, locus *var_locus) sym->as->type = AS_EXPLICIT; } + /* Ensure that explicit bounds are simplified. */ + if (sym->attr.flavor == FL_PARAMETER && sym->attr.dimension + && sym->as->type == AS_EXPLICIT) + { + for (int dim = 0; dim < sym->as->rank; ++dim) + { + gfc_expr *e; + + e = sym->as->lower[dim]; + if (e->expr_type != EXPR_CONSTANT) + gfc_reduce_init_expr (e); + + e = sym->as->upper[dim]; + if (e->expr_type != EXPR_CONSTANT) + gfc_reduce_init_expr (e); + } + } + /* Need to check if the expression we initialized this to was one of the iso_c_binding named constants. If so, and we're a parameter (constant), let it be iso_c. @@ -2721,7 +2827,7 @@ variable_decl (int elem) } /* %FILL components may not have initializers. */ - if (gfc_str_startswith (name, "%FILL") && gfc_match_eos () != MATCH_YES) + if (startswith (name, "%FILL") && gfc_match_eos () != MATCH_YES) { gfc_error ("%qs entity cannot have an initializer at %C", "%FILL"); m = MATCH_ERROR; @@ -8221,7 +8327,7 @@ gfc_match_end (gfc_statement *st) { case COMP_ASSOCIATE: case COMP_BLOCK: - if (gfc_str_startswith (block_name, "block@")) + if (startswith (block_name, "block@")) block_name = NULL; break; diff --git a/gcc/fortran/dump-parse-tree.c b/gcc/fortran/dump-parse-tree.c index 059d842..a1df47c 100644 --- a/gcc/fortran/dump-parse-tree.c +++ b/gcc/fortran/dump-parse-tree.c @@ -926,6 +926,8 @@ show_attr (symbol_attribute *attr, const char * module) fputs (" ALWAYS-EXPLICIT", dumpfile); if (attr->is_main_program) fputs (" IS-MAIN-PROGRAM", dumpfile); + if (attr->oacc_routine_nohost) + fputs (" OACC-ROUTINE-NOHOST", dumpfile); /* FIXME: Still missing are oacc_routine_lop and ext_attr. */ fputc (')', dumpfile); @@ -1298,10 +1300,55 @@ show_code (int level, gfc_code *c) } static void +show_iterator (gfc_namespace *ns) +{ + for (gfc_symbol *sym = ns->proc_name; sym; sym = sym->tlink) + { + gfc_constructor *c; + if (sym != ns->proc_name) + fputc (',', dumpfile); + fputs (sym->name, dumpfile); + fputc ('=', dumpfile); + c = gfc_constructor_first (sym->value->value.constructor); + show_expr (c->expr); + fputc (':', dumpfile); + c = gfc_constructor_next (c); + show_expr (c->expr); + c = gfc_constructor_next (c); + if (c) + { + fputc (':', dumpfile); + show_expr (c->expr); + } + } +} + +static void show_omp_namelist (int list_type, gfc_omp_namelist *n) { + gfc_namespace *ns_iter = NULL, *ns_curr = gfc_current_ns; + gfc_omp_namelist *n2 = n; for (; n; n = n->next) { + gfc_current_ns = ns_curr; + if (list_type == OMP_LIST_AFFINITY || list_type == OMP_LIST_DEPEND) + { + gfc_current_ns = n->u2.ns ? n->u2.ns : ns_curr; + if (n->u2.ns != ns_iter) + { + if (n != n2) + fputs (list_type == OMP_LIST_AFFINITY + ? ") AFFINITY(" : ") DEPEND(", dumpfile); + if (n->u2.ns) + { + fputs ("ITERATOR(", dumpfile); + show_iterator (n->u2.ns); + fputc (')', dumpfile); + fputc (list_type == OMP_LIST_AFFINITY ? ':' : ',', dumpfile); + } + } + ns_iter = n->u2.ns; + } if (list_type == OMP_LIST_REDUCTION) switch (n->u.reduction_op) { @@ -1321,8 +1368,8 @@ show_omp_namelist (int list_type, gfc_omp_namelist *n) case OMP_REDUCTION_IOR: fputs ("ior:", dumpfile); break; case OMP_REDUCTION_IEOR: fputs ("ieor:", dumpfile); break; case OMP_REDUCTION_USER: - if (n->udr) - fprintf (dumpfile, "%s:", n->udr->udr->name); + if (n->u2.udr) + fprintf (dumpfile, "%s:", n->u2.udr->udr->name); break; default: break; } @@ -1332,6 +1379,10 @@ show_omp_namelist (int list_type, gfc_omp_namelist *n) case OMP_DEPEND_IN: fputs ("in:", dumpfile); break; case OMP_DEPEND_OUT: fputs ("out:", dumpfile); break; case OMP_DEPEND_INOUT: fputs ("inout:", dumpfile); break; + case OMP_DEPEND_DEPOBJ: fputs ("depobj:", dumpfile); break; + case OMP_DEPEND_MUTEXINOUTSET: + fputs ("mutexinoutset:", dumpfile); + break; case OMP_DEPEND_SINK_FIRST: fputs ("sink:", dumpfile); while (1) @@ -1383,6 +1434,7 @@ show_omp_namelist (int list_type, gfc_omp_namelist *n) if (n->next) fputc (',', dumpfile); } + gfc_current_ns = ns_curr; } @@ -1606,6 +1658,7 @@ show_omp_clauses (gfc_omp_clauses *omp_clauses) case OMP_LIST_SHARED: type = "SHARED"; break; case OMP_LIST_COPYIN: type = "COPYIN"; break; case OMP_LIST_UNIFORM: type = "UNIFORM"; break; + case OMP_LIST_AFFINITY: type = "AFFINITY"; break; case OMP_LIST_ALIGNED: type = "ALIGNED"; break; case OMP_LIST_LINEAR: type = "LINEAR"; break; case OMP_LIST_DEPEND: type = "DEPEND"; break; @@ -1659,6 +1712,7 @@ show_omp_clauses (gfc_omp_clauses *omp_clauses) const char *type; switch (omp_clauses->proc_bind) { + case OMP_PROC_BIND_PRIMARY: type = "PRIMARY"; break; case OMP_PROC_BIND_MASTER: type = "MASTER"; break; case OMP_PROC_BIND_SPREAD: type = "SPREAD"; break; case OMP_PROC_BIND_CLOSE: type = "CLOSE"; break; @@ -1667,6 +1721,19 @@ show_omp_clauses (gfc_omp_clauses *omp_clauses) } fprintf (dumpfile, " PROC_BIND(%s)", type); } + if (omp_clauses->bind != OMP_BIND_UNSET) + { + const char *type; + switch (omp_clauses->bind) + { + case OMP_BIND_TEAMS: type = "TEAMS"; break; + case OMP_BIND_PARALLEL: type = "PARALLEL"; break; + case OMP_BIND_THREAD: type = "THREAD"; break; + default: + gcc_unreachable (); + } + fprintf (dumpfile, " BIND(%s)", type); + } if (omp_clauses->num_teams) { fputs (" NUM_TEAMS(", dumpfile); @@ -1687,7 +1754,7 @@ show_omp_clauses (gfc_omp_clauses *omp_clauses) } if (omp_clauses->dist_sched_kind != OMP_SCHED_NONE) { - fprintf (dumpfile, " DIST_SCHEDULE (STATIC"); + fputs (" DIST_SCHEDULE (STATIC", dumpfile); if (omp_clauses->dist_chunk_size) { fputc (',', dumpfile); @@ -1695,8 +1762,40 @@ show_omp_clauses (gfc_omp_clauses *omp_clauses) } fputc (')', dumpfile); } - if (omp_clauses->defaultmap) - fputs (" DEFALTMAP (TOFROM: SCALAR)", dumpfile); + for (int i = 0; i < OMP_DEFAULTMAP_CAT_NUM; i++) + { + const char *dfltmap; + if (omp_clauses->defaultmap[i] == OMP_DEFAULTMAP_UNSET) + continue; + fputs (" DEFAULTMAP (", dumpfile); + switch (omp_clauses->defaultmap[i]) + { + case OMP_DEFAULTMAP_ALLOC: dfltmap = "ALLOC"; break; + case OMP_DEFAULTMAP_TO: dfltmap = "TO"; break; + case OMP_DEFAULTMAP_FROM: dfltmap = "FROM"; break; + case OMP_DEFAULTMAP_TOFROM: dfltmap = "TOFROM"; break; + case OMP_DEFAULTMAP_FIRSTPRIVATE: dfltmap = "FIRSTPRIVATE"; break; + case OMP_DEFAULTMAP_NONE: dfltmap = "NONE"; break; + case OMP_DEFAULTMAP_DEFAULT: dfltmap = "DEFAULT"; break; + case OMP_DEFAULTMAP_PRESENT: dfltmap = "PRESENT"; break; + default: gcc_unreachable (); + } + fputs (dfltmap, dumpfile); + if (i != OMP_DEFAULTMAP_CAT_UNCATEGORIZED) + { + fputc (':', dumpfile); + switch ((enum gfc_omp_defaultmap_category) i) + { + case OMP_DEFAULTMAP_CAT_SCALAR: dfltmap = "SCALAR"; break; + case OMP_DEFAULTMAP_CAT_AGGREGATE: dfltmap = "AGGREGATE"; break; + case OMP_DEFAULTMAP_CAT_ALLOCATABLE: dfltmap = "ALLOCATABLE"; break; + case OMP_DEFAULTMAP_CAT_POINTER: dfltmap = "POINTER"; break; + default: gcc_unreachable (); + } + fputs (dfltmap, dumpfile); + } + fputc (')', dumpfile); + } if (omp_clauses->nogroup) fputs (" NOGROUP", dumpfile); if (omp_clauses->simd) @@ -1706,9 +1805,17 @@ show_omp_clauses (gfc_omp_clauses *omp_clauses) if (omp_clauses->grainsize) { fputs (" GRAINSIZE(", dumpfile); + if (omp_clauses->grainsize_strict) + fputs ("strict: ", dumpfile); show_expr (omp_clauses->grainsize); fputc (')', dumpfile); } + if (omp_clauses->filter) + { + fputs (" FILTER(", dumpfile); + show_expr (omp_clauses->filter); + fputc (')', dumpfile); + } if (omp_clauses->hint) { fputs (" HINT(", dumpfile); @@ -1718,6 +1825,8 @@ show_omp_clauses (gfc_omp_clauses *omp_clauses) if (omp_clauses->num_tasks) { fputs (" NUM_TASKS(", dumpfile); + if (omp_clauses->num_tasks_strict) + fputs ("strict: ", dumpfile); show_expr (omp_clauses->num_tasks); fputc (')', dumpfile); } @@ -1754,10 +1863,27 @@ show_omp_clauses (gfc_omp_clauses *omp_clauses) show_expr (omp_clauses->if_exprs[i]); fputc (')', dumpfile); } + if (omp_clauses->destroy) + fputs (" DESTROY", dumpfile); if (omp_clauses->depend_source) fputs (" DEPEND(source)", dumpfile); if (omp_clauses->capture) fputs (" CAPTURE", dumpfile); + if (omp_clauses->depobj_update != OMP_DEPEND_UNSET) + { + const char *deptype; + fputs (" UPDATE(", dumpfile); + switch (omp_clauses->depobj_update) + { + case OMP_DEPEND_IN: deptype = "IN"; break; + case OMP_DEPEND_OUT: deptype = "OUT"; break; + case OMP_DEPEND_INOUT: deptype = "INOUT"; break; + case OMP_DEPEND_MUTEXINOUTSET: deptype = "MUTEXINOUTSET"; break; + default: gcc_unreachable (); + } + fputs (deptype, dumpfile); + fputc (')', dumpfile); + } if (omp_clauses->atomic_op != GFC_OMP_ATOMIC_UNSET) { const char *atomic_op; @@ -1786,6 +1912,26 @@ show_omp_clauses (gfc_omp_clauses *omp_clauses) fputc (' ', dumpfile); fputs (memorder, dumpfile); } + if (omp_clauses->at != OMP_AT_UNSET) + { + if (omp_clauses->at != OMP_AT_COMPILATION) + fputs (" AT (COMPILATION)", dumpfile); + else + fputs (" AT (EXECUTION)", dumpfile); + } + if (omp_clauses->severity != OMP_SEVERITY_UNSET) + { + if (omp_clauses->severity != OMP_SEVERITY_FATAL) + fputs (" SEVERITY (FATAL)", dumpfile); + else + fputs (" SEVERITY (WARNING)", dumpfile); + } + if (omp_clauses->message) + { + fputs (" ERROR (", dumpfile); + show_expr (omp_clauses->message); + fputc (')', dumpfile); + } } /* Show a single OpenMP or OpenACC directive node and everything underneath it @@ -1828,15 +1974,35 @@ show_omp_node (int level, gfc_code *c) case EXEC_OMP_DISTRIBUTE_SIMD: name = "DISTRIBUTE SIMD"; break; case EXEC_OMP_DO: name = "DO"; break; case EXEC_OMP_DO_SIMD: name = "DO SIMD"; break; + case EXEC_OMP_ERROR: name = "ERROR"; break; case EXEC_OMP_FLUSH: name = "FLUSH"; break; + case EXEC_OMP_LOOP: name = "LOOP"; break; + case EXEC_OMP_MASKED: name = "MASKED"; break; + case EXEC_OMP_MASKED_TASKLOOP: name = "MASKED TASKLOOP"; break; + case EXEC_OMP_MASKED_TASKLOOP_SIMD: name = "MASKED TASKLOOP SIMD"; break; case EXEC_OMP_MASTER: name = "MASTER"; break; + case EXEC_OMP_MASTER_TASKLOOP: name = "MASTER TASKLOOP"; break; + case EXEC_OMP_MASTER_TASKLOOP_SIMD: name = "MASTER TASKLOOP SIMD"; break; case EXEC_OMP_ORDERED: name = "ORDERED"; break; + case EXEC_OMP_DEPOBJ: name = "DEPOBJ"; break; case EXEC_OMP_PARALLEL: name = "PARALLEL"; break; case EXEC_OMP_PARALLEL_DO: name = "PARALLEL DO"; break; case EXEC_OMP_PARALLEL_DO_SIMD: name = "PARALLEL DO SIMD"; break; + case EXEC_OMP_PARALLEL_LOOP: name = "PARALLEL LOOP"; break; + case EXEC_OMP_PARALLEL_MASTER: name = "PARALLEL MASTER"; break; + case EXEC_OMP_PARALLEL_MASKED: name = "PARALLEL MASK"; break; + case EXEC_OMP_PARALLEL_MASKED_TASKLOOP: + name = "PARALLEL MASK TASKLOOP"; break; + case EXEC_OMP_PARALLEL_MASKED_TASKLOOP_SIMD: + name = "PARALLEL MASK TASKLOOP SIMD"; break; + case EXEC_OMP_PARALLEL_MASTER_TASKLOOP: + name = "PARALLEL MASTER TASKLOOP"; break; + case EXEC_OMP_PARALLEL_MASTER_TASKLOOP_SIMD: + name = "PARALLEL MASTER TASKLOOP SIMD"; break; case EXEC_OMP_PARALLEL_SECTIONS: name = "PARALLEL SECTIONS"; break; case EXEC_OMP_PARALLEL_WORKSHARE: name = "PARALLEL WORKSHARE"; break; case EXEC_OMP_SCAN: name = "SCAN"; break; + case EXEC_OMP_SCOPE: name = "SCOPE"; break; case EXEC_OMP_SECTIONS: name = "SECTIONS"; break; case EXEC_OMP_SIMD: name = "SIMD"; break; case EXEC_OMP_SINGLE: name = "SINGLE"; break; @@ -1848,6 +2014,7 @@ show_omp_node (int level, gfc_code *c) case EXEC_OMP_TARGET_PARALLEL_DO: name = "TARGET PARALLEL DO"; break; case EXEC_OMP_TARGET_PARALLEL_DO_SIMD: name = "TARGET_PARALLEL_DO_SIMD"; break; + case EXEC_OMP_TARGET_PARALLEL_LOOP: name = "TARGET PARALLEL LOOP"; break; case EXEC_OMP_TARGET_SIMD: name = "TARGET SIMD"; break; case EXEC_OMP_TARGET_TEAMS: name = "TARGET TEAMS"; break; case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE: @@ -1858,6 +2025,7 @@ show_omp_node (int level, gfc_code *c) name = "TARGET TEAMS DISTRIBUTE PARALLEL DO SIMD"; break; case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_SIMD: name = "TARGET TEAMS DISTRIBUTE SIMD"; break; + case EXEC_OMP_TARGET_TEAMS_LOOP: name = "TARGET TEAMS LOOP"; break; case EXEC_OMP_TARGET_UPDATE: name = "TARGET UPDATE"; break; case EXEC_OMP_TASK: name = "TASK"; break; case EXEC_OMP_TASKGROUP: name = "TASKGROUP"; break; @@ -1872,6 +2040,7 @@ show_omp_node (int level, gfc_code *c) case EXEC_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD: name = "TEAMS DISTRIBUTE PARALLEL DO SIMD"; break; case EXEC_OMP_TEAMS_DISTRIBUTE_SIMD: name = "TEAMS DISTRIBUTE SIMD"; break; + case EXEC_OMP_TEAMS_LOOP: name = "TEAMS LOOP"; break; case EXEC_OMP_WORKSHARE: name = "WORKSHARE"; break; default: gcc_unreachable (); @@ -1901,13 +2070,24 @@ show_omp_node (int level, gfc_code *c) case EXEC_OMP_DISTRIBUTE_SIMD: case EXEC_OMP_DO: case EXEC_OMP_DO_SIMD: + case EXEC_OMP_ERROR: + case EXEC_OMP_LOOP: case EXEC_OMP_ORDERED: + case EXEC_OMP_MASKED: case EXEC_OMP_PARALLEL: case EXEC_OMP_PARALLEL_DO: case EXEC_OMP_PARALLEL_DO_SIMD: + case EXEC_OMP_PARALLEL_LOOP: + case EXEC_OMP_PARALLEL_MASKED: + case EXEC_OMP_PARALLEL_MASKED_TASKLOOP: + case EXEC_OMP_PARALLEL_MASKED_TASKLOOP_SIMD: + case EXEC_OMP_PARALLEL_MASTER: + case EXEC_OMP_PARALLEL_MASTER_TASKLOOP: + case EXEC_OMP_PARALLEL_MASTER_TASKLOOP_SIMD: case EXEC_OMP_PARALLEL_SECTIONS: case EXEC_OMP_PARALLEL_WORKSHARE: case EXEC_OMP_SCAN: + case EXEC_OMP_SCOPE: case EXEC_OMP_SECTIONS: case EXEC_OMP_SIMD: case EXEC_OMP_SINGLE: @@ -1918,12 +2098,14 @@ show_omp_node (int level, gfc_code *c) case EXEC_OMP_TARGET_PARALLEL: case EXEC_OMP_TARGET_PARALLEL_DO: case EXEC_OMP_TARGET_PARALLEL_DO_SIMD: + case EXEC_OMP_TARGET_PARALLEL_LOOP: case EXEC_OMP_TARGET_SIMD: case EXEC_OMP_TARGET_TEAMS: case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE: case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO: case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD: case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_SIMD: + case EXEC_OMP_TARGET_TEAMS_LOOP: case EXEC_OMP_TARGET_UPDATE: case EXEC_OMP_TASK: case EXEC_OMP_TASKLOOP: @@ -1933,6 +2115,7 @@ show_omp_node (int level, gfc_code *c) case EXEC_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO: case EXEC_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD: case EXEC_OMP_TEAMS_DISTRIBUTE_SIMD: + case EXEC_OMP_TEAMS_LOOP: case EXEC_OMP_WORKSHARE: omp_clauses = c->ext.omp_clauses; break; @@ -1941,6 +2124,15 @@ show_omp_node (int level, gfc_code *c) if (omp_clauses) fprintf (dumpfile, " (%s)", c->ext.omp_clauses->critical_name); break; + case EXEC_OMP_DEPOBJ: + omp_clauses = c->ext.omp_clauses; + if (omp_clauses) + { + fputc ('(', dumpfile); + show_expr (c->ext.omp_clauses->depobj); + fputc (')', dumpfile); + } + break; case EXEC_OMP_FLUSH: if (c->ext.omp_namelist) { @@ -1969,6 +2161,7 @@ show_omp_node (int level, gfc_code *c) || c->op == EXEC_OACC_ENTER_DATA || c->op == EXEC_OACC_EXIT_DATA || c->op == EXEC_OMP_TARGET_UPDATE || c->op == EXEC_OMP_TARGET_ENTER_DATA || c->op == EXEC_OMP_TARGET_EXIT_DATA || c->op == EXEC_OMP_SCAN + || c->op == EXEC_OMP_DEPOBJ || c->op == EXEC_OMP_ERROR || (c->op == EXEC_OMP_ORDERED && c->block == NULL)) return; if (c->op == EXEC_OMP_SECTIONS || c->op == EXEC_OMP_PARALLEL_SECTIONS) @@ -3094,21 +3287,37 @@ show_code_node (int level, gfc_code *c) case EXEC_OMP_CANCELLATION_POINT: case EXEC_OMP_BARRIER: case EXEC_OMP_CRITICAL: + case EXEC_OMP_DEPOBJ: case EXEC_OMP_DISTRIBUTE: case EXEC_OMP_DISTRIBUTE_PARALLEL_DO: case EXEC_OMP_DISTRIBUTE_PARALLEL_DO_SIMD: case EXEC_OMP_DISTRIBUTE_SIMD: case EXEC_OMP_DO: case EXEC_OMP_DO_SIMD: + case EXEC_OMP_ERROR: case EXEC_OMP_FLUSH: + case EXEC_OMP_LOOP: + case EXEC_OMP_MASKED: + case EXEC_OMP_MASKED_TASKLOOP: + case EXEC_OMP_MASKED_TASKLOOP_SIMD: case EXEC_OMP_MASTER: + case EXEC_OMP_MASTER_TASKLOOP: + case EXEC_OMP_MASTER_TASKLOOP_SIMD: case EXEC_OMP_ORDERED: case EXEC_OMP_PARALLEL: case EXEC_OMP_PARALLEL_DO: case EXEC_OMP_PARALLEL_DO_SIMD: + case EXEC_OMP_PARALLEL_LOOP: + case EXEC_OMP_PARALLEL_MASKED: + case EXEC_OMP_PARALLEL_MASKED_TASKLOOP: + case EXEC_OMP_PARALLEL_MASKED_TASKLOOP_SIMD: + case EXEC_OMP_PARALLEL_MASTER: + case EXEC_OMP_PARALLEL_MASTER_TASKLOOP: + case EXEC_OMP_PARALLEL_MASTER_TASKLOOP_SIMD: case EXEC_OMP_PARALLEL_SECTIONS: case EXEC_OMP_PARALLEL_WORKSHARE: case EXEC_OMP_SCAN: + case EXEC_OMP_SCOPE: case EXEC_OMP_SECTIONS: case EXEC_OMP_SIMD: case EXEC_OMP_SINGLE: @@ -3119,12 +3328,14 @@ show_code_node (int level, gfc_code *c) case EXEC_OMP_TARGET_PARALLEL: case EXEC_OMP_TARGET_PARALLEL_DO: case EXEC_OMP_TARGET_PARALLEL_DO_SIMD: + case EXEC_OMP_TARGET_PARALLEL_LOOP: case EXEC_OMP_TARGET_SIMD: case EXEC_OMP_TARGET_TEAMS: case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE: case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO: case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD: case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_SIMD: + case EXEC_OMP_TARGET_TEAMS_LOOP: case EXEC_OMP_TARGET_UPDATE: case EXEC_OMP_TASK: case EXEC_OMP_TASKGROUP: @@ -3137,6 +3348,7 @@ show_code_node (int level, gfc_code *c) case EXEC_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO: case EXEC_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD: case EXEC_OMP_TEAMS_DISTRIBUTE_SIMD: + case EXEC_OMP_TEAMS_LOOP: case EXEC_OMP_WORKSHARE: show_omp_node (level, c); break; diff --git a/gcc/fortran/error.c b/gcc/fortran/error.c index 529d97f..5e6e873 100644 --- a/gcc/fortran/error.c +++ b/gcc/fortran/error.c @@ -136,7 +136,7 @@ error_string (const char *p) #define IBUF_LEN 60 static void -error_uinteger (unsigned long int i) +error_uinteger (unsigned long long int i) { char *p, int_buf[IBUF_LEN]; @@ -156,13 +156,50 @@ error_uinteger (unsigned long int i) } static void -error_integer (long int i) +error_integer (long long int i) { - unsigned long int u; + unsigned long long int u; if (i < 0) { - u = (unsigned long int) -i; + u = (unsigned long long int) -i; + error_char ('-'); + } + else + u = i; + + error_uinteger (u); +} + + +static void +error_hwuint (unsigned HOST_WIDE_INT i) +{ + char *p, int_buf[IBUF_LEN]; + + p = int_buf + IBUF_LEN - 1; + *p-- = '\0'; + + if (i == 0) + *p-- = '0'; + + while (i > 0) + { + *p-- = i % 10 + '0'; + i = i / 10; + } + + error_string (p + 1); +} + +static void +error_hwint (HOST_WIDE_INT i) +{ + unsigned HOST_WIDE_INT u; + + if (i < 0) + { + u = (unsigned HOST_WIDE_INT) -i; error_char ('-'); } else @@ -482,8 +519,8 @@ static void ATTRIBUTE_GCC_GFC(2,0) error_print (const char *type, const char *format0, va_list argp) { enum { TYPE_CURRENTLOC, TYPE_LOCUS, TYPE_INTEGER, TYPE_UINTEGER, - TYPE_LONGINT, TYPE_ULONGINT, TYPE_CHAR, TYPE_STRING, - NOTYPE }; + TYPE_LONGINT, TYPE_ULONGINT, TYPE_LLONGINT, TYPE_ULLONGINT, + TYPE_HWINT, TYPE_HWUINT, TYPE_CHAR, TYPE_STRING, NOTYPE }; struct { int type; @@ -494,6 +531,10 @@ error_print (const char *type, const char *format0, va_list argp) unsigned int uintval; long int longintval; unsigned long int ulongintval; + long long int llongintval; + unsigned long long int ullongintval; + HOST_WIDE_INT hwintval; + unsigned HOST_WIDE_INT hwuintval; char charval; const char * stringval; } u; @@ -577,7 +618,17 @@ error_print (const char *type, const char *format0, va_list argp) case 'l': c = *format++; - if (c == 'u') + if (c == 'l') + { + c = *format++; + if (c == 'u') + arg[pos].type = TYPE_ULLONGINT; + else if (c == 'i' || c == 'd') + arg[pos].type = TYPE_LLONGINT; + else + gcc_unreachable (); + } + else if (c == 'u') arg[pos].type = TYPE_ULONGINT; else if (c == 'i' || c == 'd') arg[pos].type = TYPE_LONGINT; @@ -585,6 +636,16 @@ error_print (const char *type, const char *format0, va_list argp) gcc_unreachable (); break; + case 'w': + c = *format++; + if (c == 'u') + arg[pos].type = TYPE_HWUINT; + else if (c == 'i' || c == 'd') + arg[pos].type = TYPE_HWINT; + else + gcc_unreachable (); + break; + case 'c': arg[pos].type = TYPE_CHAR; break; @@ -649,6 +710,22 @@ error_print (const char *type, const char *format0, va_list argp) arg[pos].u.ulongintval = va_arg (argp, unsigned long int); break; + case TYPE_LLONGINT: + arg[pos].u.llongintval = va_arg (argp, long long int); + break; + + case TYPE_ULLONGINT: + arg[pos].u.ullongintval = va_arg (argp, unsigned long long int); + break; + + case TYPE_HWINT: + arg[pos].u.hwintval = va_arg (argp, HOST_WIDE_INT); + break; + + case TYPE_HWUINT: + arg[pos].u.hwuintval = va_arg (argp, unsigned HOST_WIDE_INT); + break; + case TYPE_CHAR: arg[pos].u.charval = (char) va_arg (argp, int); break; @@ -725,12 +802,27 @@ error_print (const char *type, const char *format0, va_list argp) case 'l': format++; + if (*format == 'l') + { + format++; + if (*format == 'u') + error_uinteger (spec[n++].u.ullongintval); + else + error_integer (spec[n++].u.llongintval); + } if (*format == 'u') error_uinteger (spec[n++].u.ulongintval); else error_integer (spec[n++].u.longintval); break; + case 'w': + format++; + if (*format == 'u') + error_hwuint (spec[n++].u.hwintval); + else + error_hwint (spec[n++].u.hwuintval); + break; } } diff --git a/gcc/fortran/expr.c b/gcc/fortran/expr.c index 92a6700..604e63e 100644 --- a/gcc/fortran/expr.c +++ b/gcc/fortran/expr.c @@ -1337,7 +1337,9 @@ find_array_element (gfc_constructor_base base, gfc_array_ref *ar, for (i = 0; i < ar->dimen; i++) { if (!gfc_reduce_init_expr (ar->as->lower[i]) - || !gfc_reduce_init_expr (ar->as->upper[i])) + || !gfc_reduce_init_expr (ar->as->upper[i]) + || ar->as->upper[i]->expr_type != EXPR_CONSTANT + || ar->as->lower[i]->expr_type != EXPR_CONSTANT) { t = false; cons = NULL; @@ -1351,9 +1353,6 @@ find_array_element (gfc_constructor_base base, gfc_array_ref *ar, goto depart; } - gcc_assert (ar->as->upper[i]->expr_type == EXPR_CONSTANT - && ar->as->lower[i]->expr_type == EXPR_CONSTANT); - /* Check the bounds. */ if ((ar->as->upper[i] && mpz_cmp (e->value.integer, @@ -1725,8 +1724,8 @@ find_substring_ref (gfc_expr *p, gfc_expr **newp) *newp = gfc_copy_expr (p); free ((*newp)->value.character.string); - end = (gfc_charlen_t) mpz_get_ui (p->ref->u.ss.end->value.integer); - start = (gfc_charlen_t) mpz_get_ui (p->ref->u.ss.start->value.integer); + end = (gfc_charlen_t) mpz_get_si (p->ref->u.ss.end->value.integer); + start = (gfc_charlen_t) mpz_get_si (p->ref->u.ss.start->value.integer); if (end >= start) length = end - start + 1; else @@ -3815,6 +3814,9 @@ gfc_check_pointer_assign (gfc_expr *lvalue, gfc_expr *rvalue, int proc_pointer; bool same_rank; + if (!lvalue->symtree) + return false; + lhs_attr = gfc_expr_attr (lvalue); if (lvalue->ts.type == BT_UNKNOWN && !lhs_attr.proc_pointer) { @@ -6121,7 +6123,9 @@ gfc_check_vardef_context (gfc_expr* e, bool pointer, bool alloc_obj, } if (!pointer && sym->attr.flavor != FL_VARIABLE && !(sym->attr.flavor == FL_PROCEDURE && sym == sym->result) - && !(sym->attr.flavor == FL_PROCEDURE && sym->attr.proc_pointer)) + && !(sym->attr.flavor == FL_PROCEDURE && sym->attr.proc_pointer) + && !(sym->attr.flavor == FL_PROCEDURE + && sym->attr.function && sym->attr.pointer)) { if (context) gfc_error ("%qs in variable definition context (%s) at %L is not" @@ -6194,6 +6198,16 @@ gfc_check_vardef_context (gfc_expr* e, bool pointer, bool alloc_obj, if (!pointer) check_intentin = false; } + if (ref->type == REF_INQUIRY + && (ref->u.i == INQUIRY_KIND || ref->u.i == INQUIRY_LEN)) + { + if (context) + gfc_error ("%qs parameter inquiry for %qs in " + "variable definition context (%s) at %L", + ref->u.i == INQUIRY_KIND ? "KIND" : "LEN", + sym->name, context, &e->where); + return false; + } } if (check_intentin diff --git a/gcc/fortran/f95-lang.c b/gcc/fortran/f95-lang.c index a346457..026228d 100644 --- a/gcc/fortran/f95-lang.c +++ b/gcc/fortran/f95-lang.c @@ -126,6 +126,8 @@ static const struct attribute_spec gfc_attribute_table[] = #undef LANG_HOOKS_OMP_CLAUSE_LINEAR_CTOR #undef LANG_HOOKS_OMP_CLAUSE_DTOR #undef LANG_HOOKS_OMP_FINISH_CLAUSE +#undef LANG_HOOKS_OMP_ALLOCATABLE_P +#undef LANG_HOOKS_OMP_SCALAR_TARGET_P #undef LANG_HOOKS_OMP_SCALAR_P #undef LANG_HOOKS_OMP_DISREGARD_VALUE_EXPR #undef LANG_HOOKS_OMP_PRIVATE_DEBUG_CLAUSE @@ -162,7 +164,9 @@ static const struct attribute_spec gfc_attribute_table[] = #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_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 #define LANG_HOOKS_OMP_DISREGARD_VALUE_EXPR gfc_omp_disregard_value_expr #define LANG_HOOKS_OMP_PRIVATE_DEBUG_CLAUSE gfc_omp_private_debug_clause #define LANG_HOOKS_OMP_PRIVATE_OUTER_REF gfc_omp_private_outer_ref @@ -531,7 +535,7 @@ gfc_builtin_function (tree decl) return decl; } -/* So far we need just these 8 attribute types. */ +/* So far we need just these 10 attribute types. */ #define ATTR_NULL 0 #define ATTR_LEAF_LIST (ECF_LEAF) #define ATTR_NOTHROW_LEAF_LIST (ECF_NOTHROW | ECF_LEAF) @@ -542,6 +546,9 @@ gfc_builtin_function (tree decl) #define ATTR_CONST_NOTHROW_LIST (ECF_NOTHROW | ECF_CONST) #define ATTR_ALLOC_WARN_UNUSED_RESULT_SIZE_2_NOTHROW_LIST \ (ECF_NOTHROW) +#define ATTR_COLD_NORETURN_NOTHROW_LEAF_LIST \ + (ECF_COLD | ECF_NORETURN | \ + ECF_NOTHROW | ECF_LEAF) static void gfc_define_builtin (const char *name, tree type, enum built_in_function code, diff --git a/gcc/fortran/frontend-passes.c b/gcc/fortran/frontend-passes.c index cfc4747..145bff5 100644 --- a/gcc/fortran/frontend-passes.c +++ b/gcc/fortran/frontend-passes.c @@ -373,7 +373,7 @@ optimize_expr (gfc_expr **e, int *walk_subtrees ATTRIBUTE_UNUSED, return 0; } -/* Auxiliary function to handle the arguments to reduction intrnisics. If the +/* Auxiliary function to handle the arguments to reduction intrinsics. If the function is a scalar, just copy it; otherwise returns the new element, the old one can be freed. */ @@ -1299,8 +1299,8 @@ traverse_io_block (gfc_code *code, bool *has_reached, gfc_code *prev) std::swap (start->value.op.op1, start->value.op.op2); gcc_fallthrough (); case INTRINSIC_MINUS: - if ((start->value.op.op1->expr_type!= EXPR_VARIABLE - && start->value.op.op2->expr_type != EXPR_CONSTANT) + if (start->value.op.op1->expr_type!= EXPR_VARIABLE + || start->value.op.op2->expr_type != EXPR_CONSTANT || start->value.op.op1->ref) return false; if (!stack_top || !stack_top->iter @@ -3307,7 +3307,7 @@ get_operand (gfc_intrinsic_op op, gfc_expr *e1, gfc_expr *e2) removed by DCE. Only called for rank-two matrices A and B. */ static gfc_code * -inline_limit_check (gfc_expr *a, gfc_expr *b, int limit) +inline_limit_check (gfc_expr *a, gfc_expr *b, int limit, int rank_a) { gfc_expr *inline_limit; gfc_code *if_1, *if_2, *else_2; @@ -3315,16 +3315,28 @@ inline_limit_check (gfc_expr *a, gfc_expr *b, int limit) gfc_typespec ts; gfc_expr *cond; + gcc_assert (rank_a == 1 || rank_a == 2); + /* Calculation is done in real to avoid integer overflow. */ inline_limit = gfc_get_constant_expr (BT_REAL, gfc_default_real_kind, &a->where); mpfr_set_si (inline_limit->value.real, limit, GFC_RND_MODE); - mpfr_pow_ui (inline_limit->value.real, inline_limit->value.real, 3, + + /* Set the limit according to the rank. */ + mpfr_pow_ui (inline_limit->value.real, inline_limit->value.real, rank_a + 1, GFC_RND_MODE); a1 = get_array_inq_function (GFC_ISYM_SIZE, a, 1); - a2 = get_array_inq_function (GFC_ISYM_SIZE, a, 2); + + /* For a_rank = 1, must use one as the size of a along the second + dimension as to avoid too much code duplication. */ + + if (rank_a == 2) + a2 = get_array_inq_function (GFC_ISYM_SIZE, a, 2); + else + a2 = gfc_get_int_expr (gfc_index_integer_kind, &a->where, 1); + b2 = get_array_inq_function (GFC_ISYM_SIZE, b, 2); gfc_clear_ts (&ts); @@ -4181,6 +4193,19 @@ inline_matmul_assign (gfc_code **c, int *walk_subtrees, if (m_case == none) return 0; + /* We only handle assignment to numeric or logical variables. */ + switch(expr1->ts.type) + { + case BT_INTEGER: + case BT_LOGICAL: + case BT_REAL: + case BT_COMPLEX: + break; + + default: + return 0; + } + ns = insert_block (); /* Assign the type of the zero expression for initializing the resulting @@ -4243,11 +4268,13 @@ inline_matmul_assign (gfc_code **c, int *walk_subtrees, /* Take care of the inline flag. If the limit check evaluates to a constant, dead code elimination will eliminate the unneeded branch. */ - if (flag_inline_matmul_limit > 0 && matrix_a->rank == 2 + if (flag_inline_matmul_limit > 0 + && (matrix_a->rank == 1 || matrix_a->rank == 2) && matrix_b->rank == 2) { if_limit = inline_limit_check (matrix_a, matrix_b, - flag_inline_matmul_limit); + flag_inline_matmul_limit, + matrix_a->rank); /* Insert the original statement into the else branch. */ if_limit->block->block->next = co; @@ -4757,7 +4784,7 @@ call_external_blas (gfc_code **c, int *walk_subtrees ATTRIBUTE_UNUSED, return 0; /* Generate the if statement and hang it into the tree. */ - if_limit = inline_limit_check (matrix_a, matrix_b, flag_blas_matmul_limit); + if_limit = inline_limit_check (matrix_a, matrix_b, flag_blas_matmul_limit, 2); co_next = co->next; (*current_code) = if_limit; co->next = NULL; @@ -5528,6 +5555,13 @@ gfc_code_walker (gfc_code **c, walk_code_fn_t codefn, walk_expr_fn_t exprfn, case EXEC_OMP_PARALLEL: case EXEC_OMP_PARALLEL_DO: case EXEC_OMP_PARALLEL_DO_SIMD: + case EXEC_OMP_PARALLEL_LOOP: + case EXEC_OMP_PARALLEL_MASKED: + case EXEC_OMP_PARALLEL_MASKED_TASKLOOP: + case EXEC_OMP_PARALLEL_MASKED_TASKLOOP_SIMD: + case EXEC_OMP_PARALLEL_MASTER: + case EXEC_OMP_PARALLEL_MASTER_TASKLOOP: + case EXEC_OMP_PARALLEL_MASTER_TASKLOOP_SIMD: case EXEC_OMP_PARALLEL_SECTIONS: in_omp_workshare = false; @@ -5550,6 +5584,7 @@ gfc_code_walker (gfc_code **c, walk_code_fn_t codefn, walk_expr_fn_t exprfn, case EXEC_OMP_DISTRIBUTE_SIMD: case EXEC_OMP_DO: case EXEC_OMP_DO_SIMD: + case EXEC_OMP_LOOP: case EXEC_OMP_ORDERED: case EXEC_OMP_SECTIONS: case EXEC_OMP_SINGLE: @@ -5564,12 +5599,14 @@ gfc_code_walker (gfc_code **c, walk_code_fn_t codefn, walk_expr_fn_t exprfn, case EXEC_OMP_TARGET_PARALLEL: case EXEC_OMP_TARGET_PARALLEL_DO: case EXEC_OMP_TARGET_PARALLEL_DO_SIMD: + case EXEC_OMP_TARGET_PARALLEL_LOOP: case EXEC_OMP_TARGET_SIMD: case EXEC_OMP_TARGET_TEAMS: case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE: case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO: case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD: case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_SIMD: + case EXEC_OMP_TARGET_TEAMS_LOOP: case EXEC_OMP_TARGET_UPDATE: case EXEC_OMP_TASK: case EXEC_OMP_TEAMS: @@ -5577,6 +5614,7 @@ gfc_code_walker (gfc_code **c, walk_code_fn_t codefn, walk_expr_fn_t exprfn, case EXEC_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO: case EXEC_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD: case EXEC_OMP_TEAMS_DISTRIBUTE_SIMD: + case EXEC_OMP_TEAMS_LOOP: /* Come to this label only from the EXEC_OMP_PARALLEL_* cases above. */ diff --git a/gcc/fortran/gfortran.h b/gcc/fortran/gfortran.h index 7935aca..fdf556e 100644 --- a/gcc/fortran/gfortran.h +++ b/gcc/fortran/gfortran.h @@ -261,12 +261,28 @@ enum gfc_statement ST_OMP_TARGET_PARALLEL_DO_SIMD, ST_OMP_END_TARGET_PARALLEL_DO_SIMD, ST_OMP_TARGET_ENTER_DATA, ST_OMP_TARGET_EXIT_DATA, ST_OMP_TARGET_SIMD, ST_OMP_END_TARGET_SIMD, - ST_OMP_TASKLOOP, ST_OMP_END_TASKLOOP, ST_OMP_SCAN, + ST_OMP_TASKLOOP, ST_OMP_END_TASKLOOP, ST_OMP_SCAN, ST_OMP_DEPOBJ, ST_OMP_TASKLOOP_SIMD, ST_OMP_END_TASKLOOP_SIMD, ST_OMP_ORDERED_DEPEND, ST_OMP_REQUIRES, ST_PROCEDURE, ST_GENERIC, ST_CRITICAL, ST_END_CRITICAL, ST_GET_FCN_CHARACTERISTICS, ST_LOCK, ST_UNLOCK, ST_EVENT_POST, ST_EVENT_WAIT, ST_FAIL_IMAGE, ST_FORM_TEAM, ST_CHANGE_TEAM, - ST_END_TEAM, ST_SYNC_TEAM, ST_NONE + ST_END_TEAM, ST_SYNC_TEAM, ST_OMP_PARALLEL_MASTER, + ST_OMP_END_PARALLEL_MASTER, ST_OMP_PARALLEL_MASTER_TASKLOOP, + ST_OMP_END_PARALLEL_MASTER_TASKLOOP, ST_OMP_PARALLEL_MASTER_TASKLOOP_SIMD, + ST_OMP_END_PARALLEL_MASTER_TASKLOOP_SIMD, ST_OMP_MASTER_TASKLOOP, + ST_OMP_END_MASTER_TASKLOOP, ST_OMP_MASTER_TASKLOOP_SIMD, + ST_OMP_END_MASTER_TASKLOOP_SIMD, ST_OMP_LOOP, ST_OMP_END_LOOP, + ST_OMP_PARALLEL_LOOP, ST_OMP_END_PARALLEL_LOOP, ST_OMP_TEAMS_LOOP, + ST_OMP_END_TEAMS_LOOP, ST_OMP_TARGET_PARALLEL_LOOP, + ST_OMP_END_TARGET_PARALLEL_LOOP, ST_OMP_TARGET_TEAMS_LOOP, + ST_OMP_END_TARGET_TEAMS_LOOP, ST_OMP_MASKED, ST_OMP_END_MASKED, + ST_OMP_PARALLEL_MASKED, ST_OMP_END_PARALLEL_MASKED, + ST_OMP_PARALLEL_MASKED_TASKLOOP, ST_OMP_END_PARALLEL_MASKED_TASKLOOP, + ST_OMP_PARALLEL_MASKED_TASKLOOP_SIMD, + ST_OMP_END_PARALLEL_MASKED_TASKLOOP_SIMD, ST_OMP_MASKED_TASKLOOP, + ST_OMP_END_MASKED_TASKLOOP, ST_OMP_MASKED_TASKLOOP_SIMD, + ST_OMP_END_MASKED_TASKLOOP_SIMD, ST_OMP_SCOPE, ST_OMP_END_SCOPE, + ST_OMP_ERROR, ST_NONE }; /* Types of interfaces that we can have. Assignment interfaces are @@ -761,6 +777,20 @@ enum gfc_omp_device_type OMP_DEVICE_TYPE_ANY }; +enum gfc_omp_severity_type +{ + OMP_SEVERITY_UNSET, + OMP_SEVERITY_WARNING, + OMP_SEVERITY_FATAL +}; + +enum gfc_omp_at_type +{ + OMP_AT_UNSET, + OMP_AT_COMPILATION, + OMP_AT_EXECUTION +}; + /* Structure and list of supported extension attributes. */ typedef enum { @@ -938,6 +968,7 @@ typedef struct /* OpenACC 'routine' directive's level of parallelism. */ ENUM_BITFIELD (oacc_routine_lop) oacc_routine_lop:3; + unsigned oacc_routine_nohost:1; /* Attributes set by compiler extensions (!GCC$ ATTRIBUTES). */ unsigned ext_attr:EXT_ATTR_NUM; @@ -1198,9 +1229,12 @@ enum gfc_omp_reduction_op enum gfc_omp_depend_op { + OMP_DEPEND_UNSET, OMP_DEPEND_IN, OMP_DEPEND_OUT, OMP_DEPEND_INOUT, + OMP_DEPEND_MUTEXINOUTSET, + OMP_DEPEND_DEPOBJ, OMP_DEPEND_SINK_FIRST, OMP_DEPEND_SINK }; @@ -1229,6 +1263,29 @@ enum gfc_omp_map_op OMP_MAP_ALWAYS_TOFROM }; +enum gfc_omp_defaultmap +{ + OMP_DEFAULTMAP_UNSET, + OMP_DEFAULTMAP_ALLOC, + OMP_DEFAULTMAP_TO, + OMP_DEFAULTMAP_FROM, + OMP_DEFAULTMAP_TOFROM, + OMP_DEFAULTMAP_FIRSTPRIVATE, + OMP_DEFAULTMAP_NONE, + OMP_DEFAULTMAP_DEFAULT, + OMP_DEFAULTMAP_PRESENT +}; + +enum gfc_omp_defaultmap_category +{ + OMP_DEFAULTMAP_CAT_UNCATEGORIZED, + OMP_DEFAULTMAP_CAT_SCALAR, + OMP_DEFAULTMAP_CAT_AGGREGATE, + OMP_DEFAULTMAP_CAT_ALLOCATABLE, + OMP_DEFAULTMAP_CAT_POINTER, + OMP_DEFAULTMAP_CAT_NUM +}; + enum gfc_omp_linear_op { OMP_LINEAR_DEFAULT, @@ -1253,7 +1310,11 @@ typedef struct gfc_omp_namelist struct gfc_common_head *common; bool lastprivate_conditional; } u; - struct gfc_omp_namelist_udr *udr; + union + { + struct gfc_omp_namelist_udr *udr; + gfc_namespace *ns; + } u2; struct gfc_omp_namelist *next; locus where; } @@ -1271,6 +1332,7 @@ enum OMP_LIST_SHARED, OMP_LIST_COPYIN, OMP_LIST_UNIFORM, + OMP_LIST_AFFINITY, OMP_LIST_ALIGNED, OMP_LIST_LINEAR, OMP_LIST_DEPEND, @@ -1321,6 +1383,7 @@ enum gfc_omp_default_sharing enum gfc_omp_proc_bind_kind { OMP_PROC_BIND_UNKNOWN, + OMP_PROC_BIND_PRIMARY, OMP_PROC_BIND_MASTER, OMP_PROC_BIND_SPREAD, OMP_PROC_BIND_CLOSE @@ -1388,39 +1451,57 @@ enum gfc_omp_memorder OMP_MEMORDER_RELAXED }; +enum gfc_omp_bind_type +{ + OMP_BIND_UNSET, + OMP_BIND_TEAMS, + OMP_BIND_PARALLEL, + OMP_BIND_THREAD +}; + typedef struct gfc_omp_clauses { + gfc_omp_namelist *lists[OMP_LIST_NUM]; struct gfc_expr *if_expr; struct gfc_expr *final_expr; struct gfc_expr *num_threads; - gfc_omp_namelist *lists[OMP_LIST_NUM]; - enum gfc_omp_sched_kind sched_kind; - enum gfc_omp_device_type device_type; struct gfc_expr *chunk_size; - enum gfc_omp_default_sharing default_sharing; - int collapse, orderedc; - bool nowait, ordered, untied, mergeable; - bool inbranch, notinbranch, defaultmap, nogroup; - bool sched_simd, sched_monotonic, sched_nonmonotonic; - bool simd, threads, depend_source, order_concurrent, capture; - enum gfc_omp_atomic_op atomic_op; - enum gfc_omp_memorder memorder; - enum gfc_omp_cancel_kind cancel; - enum gfc_omp_proc_bind_kind proc_bind; struct gfc_expr *safelen_expr; struct gfc_expr *simdlen_expr; struct gfc_expr *num_teams; struct gfc_expr *device; struct gfc_expr *thread_limit; struct gfc_expr *grainsize; + struct gfc_expr *filter; struct gfc_expr *hint; struct gfc_expr *num_tasks; struct gfc_expr *priority; struct gfc_expr *detach; + struct gfc_expr *depobj; struct gfc_expr *if_exprs[OMP_IF_LAST]; - enum gfc_omp_sched_kind dist_sched_kind; struct gfc_expr *dist_chunk_size; + struct gfc_expr *message; const char *critical_name; + bool ancestor; + enum gfc_omp_default_sharing default_sharing; + enum gfc_omp_atomic_op atomic_op; + enum gfc_omp_defaultmap defaultmap[OMP_DEFAULTMAP_CAT_NUM]; + int collapse, orderedc; + unsigned nowait:1, ordered:1, untied:1, mergeable:1; + unsigned inbranch:1, notinbranch:1, nogroup:1; + unsigned sched_simd:1, sched_monotonic:1, sched_nonmonotonic:1; + unsigned simd:1, threads:1, depend_source:1, destroy:1, order_concurrent:1; + unsigned capture:1, grainsize_strict:1, num_tasks_strict:1; + ENUM_BITFIELD (gfc_omp_sched_kind) sched_kind:3; + ENUM_BITFIELD (gfc_omp_device_type) device_type:2; + ENUM_BITFIELD (gfc_omp_memorder) memorder:3; + ENUM_BITFIELD (gfc_omp_cancel_kind) cancel:3; + ENUM_BITFIELD (gfc_omp_proc_bind_kind) proc_bind:3; + ENUM_BITFIELD (gfc_omp_depend_op) depobj_update:3; + ENUM_BITFIELD (gfc_omp_bind_type) bind:2; + ENUM_BITFIELD (gfc_omp_at_type) at:2; + ENUM_BITFIELD (gfc_omp_severity_type) severity:2; + ENUM_BITFIELD (gfc_omp_sched_kind) dist_sched_kind:3; /* OpenACC. */ struct gfc_expr *async_expr; @@ -1436,8 +1517,8 @@ typedef struct gfc_omp_clauses unsigned async:1, gang:1, worker:1, vector:1, seq:1, independent:1; unsigned par_auto:1, gang_static:1; unsigned if_present:1, finalize:1; + unsigned nohost:1; locus loc; - } gfc_omp_clauses; @@ -2700,7 +2781,15 @@ enum gfc_exec_op EXEC_OMP_TARGET_ENTER_DATA, EXEC_OMP_TARGET_EXIT_DATA, EXEC_OMP_TARGET_PARALLEL, EXEC_OMP_TARGET_PARALLEL_DO, EXEC_OMP_TARGET_PARALLEL_DO_SIMD, EXEC_OMP_TARGET_SIMD, - EXEC_OMP_TASKLOOP, EXEC_OMP_TASKLOOP_SIMD, EXEC_OMP_SCAN + EXEC_OMP_TASKLOOP, EXEC_OMP_TASKLOOP_SIMD, EXEC_OMP_SCAN, EXEC_OMP_DEPOBJ, + EXEC_OMP_PARALLEL_MASTER, EXEC_OMP_PARALLEL_MASTER_TASKLOOP, + EXEC_OMP_PARALLEL_MASTER_TASKLOOP_SIMD, EXEC_OMP_MASTER_TASKLOOP, + EXEC_OMP_MASTER_TASKLOOP_SIMD, EXEC_OMP_LOOP, EXEC_OMP_PARALLEL_LOOP, + EXEC_OMP_TEAMS_LOOP, EXEC_OMP_TARGET_PARALLEL_LOOP, + EXEC_OMP_TARGET_TEAMS_LOOP, EXEC_OMP_MASKED, EXEC_OMP_PARALLEL_MASKED, + EXEC_OMP_PARALLEL_MASKED_TASKLOOP, EXEC_OMP_PARALLEL_MASKED_TASKLOOP_SIMD, + EXEC_OMP_MASKED_TASKLOOP, EXEC_OMP_MASKED_TASKLOOP_SIMD, EXEC_OMP_SCOPE, + EXEC_OMP_ERROR }; typedef struct gfc_code @@ -3315,7 +3404,7 @@ void gfc_free_iterator (gfc_iterator *, int); void gfc_free_forall_iterator (gfc_forall_iterator *); void gfc_free_alloc_list (gfc_alloc *); void gfc_free_namelist (gfc_namelist *); -void gfc_free_omp_namelist (gfc_omp_namelist *); +void gfc_free_omp_namelist (gfc_omp_namelist *, bool); void gfc_free_equiv (gfc_equiv *); void gfc_free_equiv_until (gfc_equiv *, gfc_equiv *); void gfc_free_data (gfc_data *); @@ -3514,10 +3603,6 @@ bool gfc_is_compile_time_shape (gfc_array_spec *); bool gfc_ref_dimen_size (gfc_array_ref *, int dimen, mpz_t *, mpz_t *); - -#define gfc_str_startswith(str, pref) \ - (strncmp ((str), (pref), strlen (pref)) == 0) - /* interface.c -- FIXME: some of these should be in symbol.c */ void gfc_free_interface (gfc_interface *); bool gfc_compare_derived_types (gfc_symbol *, gfc_symbol *); diff --git a/gcc/fortran/gfortran.texi b/gcc/fortran/gfortran.texi index 60bf257..a54153b 100644 --- a/gcc/fortran/gfortran.texi +++ b/gcc/fortran/gfortran.texi @@ -1842,7 +1842,7 @@ type, then the real-literal-constant will be interpreted as a Besides decimal constants, Fortran also supports binary (@code{b}), octal (@code{o}) and hexadecimal (@code{z}) integer constants. The -syntax is: @samp{prefix quote digits quote}, were the prefix is +syntax is: @samp{prefix quote digits quote}, where the prefix is either @code{b}, @code{o} or @code{z}, quote is either @code{'} or @code{"} and the digits are @code{0} or @code{1} for binary, between @code{0} and @code{7} for octal, and between @code{0} and diff --git a/gcc/fortran/interface.c b/gcc/fortran/interface.c index f7ca52e..9e3e8aa 100644 --- a/gcc/fortran/interface.c +++ b/gcc/fortran/interface.c @@ -2327,6 +2327,7 @@ compare_parameter (gfc_symbol *formal, gfc_expr *actual, bool rank_check, is_pointer; char err[200]; gfc_component *ppc; + bool codimension = false; /* If the formal arg has type BT_VOID, it's to one of the iso_c_binding procs c_f_pointer or c_f_procpointer, and we need to accept most @@ -2490,7 +2491,12 @@ compare_parameter (gfc_symbol *formal, gfc_expr *actual, return false; } - if (formal->attr.codimension && !gfc_is_coarray (actual)) + if (formal->ts.type == BT_CLASS && formal->attr.class_ok) + codimension = CLASS_DATA (formal)->attr.codimension; + else + codimension = formal->attr.codimension; + + if (codimension && !gfc_is_coarray (actual)) { if (where) gfc_error ("Actual argument to %qs at %L must be a coarray", @@ -2498,7 +2504,7 @@ compare_parameter (gfc_symbol *formal, gfc_expr *actual, return false; } - if (formal->attr.codimension && formal->attr.allocatable) + if (codimension && formal->attr.allocatable) { gfc_ref *last = NULL; @@ -2520,7 +2526,7 @@ compare_parameter (gfc_symbol *formal, gfc_expr *actual, } } - if (formal->attr.codimension) + if (codimension) { /* F2008, 12.5.2.8 + Corrig 2 (IR F08/0048). */ /* F2018, 12.5.2.8. */ @@ -2586,7 +2592,7 @@ compare_parameter (gfc_symbol *formal, gfc_expr *actual, return false; } - if (formal->attr.allocatable && !formal->attr.codimension + if (formal->attr.allocatable && !codimension && actual_attr.codimension) { if (formal->attr.intent == INTENT_OUT) @@ -3249,10 +3255,13 @@ gfc_compare_actual_formal (gfc_actual_arglist **ap, gfc_formal_arglist *formal, && f->sym->attr.flavor != FL_PROCEDURE) { if (a->expr->ts.type == BT_CHARACTER && !f->sym->as && where) - gfc_warning (0, "Character length of actual argument shorter " - "than of dummy argument %qs (%lu/%lu) at %L", - f->sym->name, actual_size, formal_size, - &a->expr->where); + { + gfc_warning (0, "Character length of actual argument shorter " + "than of dummy argument %qs (%lu/%lu) at %L", + f->sym->name, actual_size, formal_size, + &a->expr->where); + goto skip_size_check; + } else if (where) { /* Emit a warning for -std=legacy and an error otherwise. */ diff --git a/gcc/fortran/intrinsic.c b/gcc/fortran/intrinsic.c index e68eff8..219f04f 100644 --- a/gcc/fortran/intrinsic.c +++ b/gcc/fortran/intrinsic.c @@ -3460,7 +3460,7 @@ add_subroutines (void) /* Argument names. These are used as argument keywords and so need to match the documentation. Please keep this list in sorted order. */ static const char - *a = "a", *c = "count", *cm = "count_max", *com = "command", + *a = "a", *c_ = "c", *c = "count", *cm = "count_max", *com = "command", *cr = "count_rate", *dt = "date", *errmsg = "errmsg", *f = "from", *fp = "frompos", *gt = "get", *h = "harvest", *han = "handler", *length = "length", *ln = "len", *md = "mode", *msk = "mask", @@ -3840,12 +3840,12 @@ add_subroutines (void) add_sym_3s ("fgetc", GFC_ISYM_FGETC, CLASS_IMPURE, BT_UNKNOWN, 0, GFC_STD_GNU, gfc_check_fgetputc_sub, NULL, gfc_resolve_fgetc_sub, ut, BT_INTEGER, di, REQUIRED, INTENT_IN, - c, BT_CHARACTER, dc, REQUIRED, INTENT_OUT, + c_, BT_CHARACTER, dc, REQUIRED, INTENT_OUT, st, BT_INTEGER, di, OPTIONAL, INTENT_OUT); add_sym_2s ("fget", GFC_ISYM_FGET, CLASS_IMPURE, BT_UNKNOWN, 0, GFC_STD_GNU, gfc_check_fgetput_sub, NULL, gfc_resolve_fget_sub, - c, BT_CHARACTER, dc, REQUIRED, INTENT_OUT, + c_, BT_CHARACTER, dc, REQUIRED, INTENT_OUT, st, BT_INTEGER, di, OPTIONAL, INTENT_OUT); add_sym_1s ("flush", GFC_ISYM_FLUSH, CLASS_IMPURE, BT_UNKNOWN, 0, GFC_STD_GNU, @@ -3855,12 +3855,12 @@ add_subroutines (void) add_sym_3s ("fputc", GFC_ISYM_FPUTC, CLASS_IMPURE, BT_UNKNOWN, 0, GFC_STD_GNU, gfc_check_fgetputc_sub, NULL, gfc_resolve_fputc_sub, ut, BT_INTEGER, di, REQUIRED, INTENT_IN, - c, BT_CHARACTER, dc, REQUIRED, INTENT_IN, + c_, BT_CHARACTER, dc, REQUIRED, INTENT_IN, st, BT_INTEGER, di, OPTIONAL, INTENT_OUT); add_sym_2s ("fput", GFC_ISYM_FPUT, CLASS_IMPURE, BT_UNKNOWN, 0, GFC_STD_GNU, gfc_check_fgetput_sub, NULL, gfc_resolve_fput_sub, - c, BT_CHARACTER, dc, REQUIRED, INTENT_IN, + c_, BT_CHARACTER, dc, REQUIRED, INTENT_IN, st, BT_INTEGER, di, OPTIONAL, INTENT_OUT); add_sym_1s ("free", GFC_ISYM_FREE, CLASS_IMPURE, BT_UNKNOWN, 0, GFC_STD_GNU, @@ -5071,6 +5071,11 @@ got_specific: sym->attr.intrinsic = 1; sym->attr.flavor = FL_PROCEDURE; } + if (sym->attr.flavor == FL_PROCEDURE) + { + sym->attr.function = 1; + sym->attr.proc = PROC_INTRINSIC; + } if (!sym->module) gfc_intrinsic_symbol (sym); diff --git a/gcc/fortran/intrinsic.texi b/gcc/fortran/intrinsic.texi index 73baa34..1aacd33 100644 --- a/gcc/fortran/intrinsic.texi +++ b/gcc/fortran/intrinsic.texi @@ -462,7 +462,7 @@ end program test_abs @item @emph{Specific names}: @multitable @columnfractions .20 .20 .20 .25 -@item Name @tab Argument @tab Return type @tab Standard +@headitem Name @tab Argument @tab Return type @tab Standard @item @code{ABS(A)} @tab @code{REAL(4) A} @tab @code{REAL(4)} @tab Fortran 77 and later @item @code{CABS(A)} @tab @code{COMPLEX(4) A} @tab @code{REAL(4)} @tab Fortran 77 and later @item @code{DABS(A)} @tab @code{REAL(8) A} @tab @code{REAL(8)} @tab Fortran 77 and later @@ -502,7 +502,7 @@ Inquiry function @item @emph{Arguments}: @multitable @columnfractions .15 .70 @item @var{NAME} @tab Scalar @code{CHARACTER} of default kind with the -file name. Tailing blank are ignored unless the character @code{achar(0)} +file name. Trailing blank are ignored unless the character @code{achar(0)} is present, then all characters up to and excluding @code{achar(0)} are used as file name. @item @var{MODE} @tab Scalar @code{CHARACTER} of default kind with the @@ -627,7 +627,7 @@ end program test_acos @item @emph{Specific names}: @multitable @columnfractions .20 .20 .20 .25 -@item Name @tab Argument @tab Return type @tab Standard +@headitem Name @tab Argument @tab Return type @tab Standard @item @code{ACOS(X)} @tab @code{REAL(4) X} @tab @code{REAL(4)} @tab Fortran 77 and later @item @code{DACOS(X)} @tab @code{REAL(8) X} @tab @code{REAL(8)} @tab Fortran 77 and later @end multitable @@ -686,7 +686,7 @@ end program test_acosd @item @emph{Specific names}: @multitable @columnfractions .20 .20 .20 .25 -@item Name @tab Argument @tab Return type @tab Standard +@headitem Name @tab Argument @tab Return type @tab Standard @item @code{ACOSD(X)} @tab @code{REAL(4) X} @tab @code{REAL(4)} @tab GNU extension @item @code{DACOSD(X)} @tab @code{REAL(8) X} @tab @code{REAL(8)} @tab GNU extension @end multitable @@ -742,7 +742,7 @@ END PROGRAM @item @emph{Specific names}: @multitable @columnfractions .20 .20 .20 .25 -@item Name @tab Argument @tab Return type @tab Standard +@headitem Name @tab Argument @tab Return type @tab Standard @item @code{DACOSH(X)} @tab @code{REAL(8) X} @tab @code{REAL(8)} @tab GNU extension @end multitable @@ -891,7 +891,7 @@ end program test_aimag @item @emph{Specific names}: @multitable @columnfractions .20 .20 .20 .25 -@item Name @tab Argument @tab Return type @tab Standard +@headitem Name @tab Argument @tab Return type @tab Standard @item @code{AIMAG(Z)} @tab @code{COMPLEX Z} @tab @code{REAL} @tab Fortran 77 and later @item @code{DIMAG(Z)} @tab @code{COMPLEX(8) Z} @tab @code{REAL(8)} @tab GNU extension @item @code{IMAG(Z)} @tab @code{COMPLEX Z} @tab @code{REAL} @tab GNU extension @@ -951,7 +951,7 @@ end program test_aint @item @emph{Specific names}: @multitable @columnfractions .20 .20 .20 .25 -@item Name @tab Argument @tab Return type @tab Standard +@headitem Name @tab Argument @tab Return type @tab Standard @item @code{AINT(A)} @tab @code{REAL(4) A} @tab @code{REAL(4)} @tab Fortran 77 and later @item @code{DINT(A)} @tab @code{REAL(8) A} @tab @code{REAL(8)} @tab Fortran 77 and later @end multitable @@ -1231,7 +1231,7 @@ end program test_anint @item @emph{Specific names}: @multitable @columnfractions .20 .20 .20 .25 -@item Name @tab Argument @tab Return type @tab Standard +@headitem Name @tab Argument @tab Return type @tab Standard @item @code{ANINT(A)} @tab @code{REAL(4) A} @tab @code{REAL(4)} @tab Fortran 77 and later @item @code{DNINT(A)} @tab @code{REAL(8) A} @tab @code{REAL(8)} @tab Fortran 77 and later @end multitable @@ -1347,7 +1347,7 @@ end program test_asin @item @emph{Specific names}: @multitable @columnfractions .20 .20 .20 .25 -@item Name @tab Argument @tab Return type @tab Standard +@headitem Name @tab Argument @tab Return type @tab Standard @item @code{ASIN(X)} @tab @code{REAL(4) X} @tab @code{REAL(4)} @tab Fortran 77 and later @item @code{DASIN(X)} @tab @code{REAL(8) X} @tab @code{REAL(8)} @tab Fortran 77 and later @end multitable @@ -1406,7 +1406,7 @@ end program test_asind @item @emph{Specific names}: @multitable @columnfractions .20 .20 .20 .25 -@item Name @tab Argument @tab Return type @tab Standard +@headitem Name @tab Argument @tab Return type @tab Standard @item @code{ASIND(X)} @tab @code{REAL(4) X} @tab @code{REAL(4)} @tab GNU extension @item @code{DASIND(X)} @tab @code{REAL(8) X} @tab @code{REAL(8)} @tab GNU extension @end multitable @@ -1462,7 +1462,7 @@ END PROGRAM @item @emph{Specific names}: @multitable @columnfractions .20 .20 .20 .25 -@item Name @tab Argument @tab Return type @tab Standard +@headitem Name @tab Argument @tab Return type @tab Standard @item @code{DASINH(X)} @tab @code{REAL(8) X} @tab @code{REAL(8)} @tab GNU extension. @end multitable @@ -1598,7 +1598,7 @@ end program test_atan @item @emph{Specific names}: @multitable @columnfractions .20 .20 .20 .25 -@item Name @tab Argument @tab Return type @tab Standard +@headitem Name @tab Argument @tab Return type @tab Standard @item @code{ATAN(X)} @tab @code{REAL(4) X} @tab @code{REAL(4)} @tab Fortran 77 and later @item @code{DATAN(X)} @tab @code{REAL(8) X} @tab @code{REAL(8)} @tab Fortran 77 and later @end multitable @@ -1663,7 +1663,7 @@ end program test_atand @item @emph{Specific names}: @multitable @columnfractions .20 .20 .20 .25 -@item Name @tab Argument @tab Return type @tab Standard +@headitem Name @tab Argument @tab Return type @tab Standard @item @code{ATAND(X)} @tab @code{REAL(4) X} @tab @code{REAL(4)} @tab GNU extension @item @code{DATAND(X)} @tab @code{REAL(8) X} @tab @code{REAL(8)} @tab GNU extension @end multitable @@ -1728,7 +1728,7 @@ end program test_atan2 @item @emph{Specific names}: @multitable @columnfractions .20 .20 .20 .25 -@item Name @tab Argument @tab Return type @tab Standard +@headitem Name @tab Argument @tab Return type @tab Standard @item @code{ATAN2(X, Y)} @tab @code{REAL(4) X, Y} @tab @code{REAL(4)} @tab Fortran 77 and later @item @code{DATAN2(X, Y)} @tab @code{REAL(8) X, Y} @tab @code{REAL(8)} @tab Fortran 77 and later @end multitable @@ -1796,7 +1796,7 @@ end program test_atan2d @item @emph{Specific names}: @multitable @columnfractions .20 .20 .20 .25 -@item Name @tab Argument @tab Return type @tab Standard +@headitem Name @tab Argument @tab Return type @tab Standard @item @code{ATAN2D(X, Y)} @tab @code{REAL(4) X, Y} @tab @code{REAL(4)} @tab GNU extension @item @code{DATAN2D(X, Y)} @tab @code{REAL(8) X, Y} @tab @code{REAL(8)} @tab GNU extension @end multitable @@ -1852,7 +1852,7 @@ END PROGRAM @item @emph{Specific names}: @multitable @columnfractions .20 .20 .20 .25 -@item Name @tab Argument @tab Return type @tab Standard +@headitem Name @tab Argument @tab Return type @tab Standard @item @code{DATANH(X)} @tab @code{REAL(8) X} @tab @code{REAL(8)} @tab GNU extension @end multitable @@ -1870,7 +1870,7 @@ Inverse function: @gol @table @asis @item @emph{Description}: -@code{ATOMIC_ADD(ATOM, VALUE)} atomically adds the value of @var{VAR} to the +@code{ATOMIC_ADD(ATOM, VALUE)} atomically adds the value of @var{VALUE} to the variable @var{ATOM}. When @var{STAT} is present and the invocation was successful, it is assigned the value 0. If it is present and the invocation has failed, it is assigned a positive value; in particular, for a coindexed @@ -2090,7 +2090,7 @@ end program atomic @table @asis @item @emph{Description}: @code{ATOMIC_FETCH_ADD(ATOM, VALUE, OLD)} atomically stores the value of -@var{ATOM} in @var{OLD} and adds the value of @var{VAR} to the +@var{ATOM} in @var{OLD} and adds the value of @var{VALUE} to the variable @var{ATOM}. When @var{STAT} is present and the invocation was successful, it is assigned the value 0. If it is present and the invocation has failed, it is assigned a positive value; in particular, for a coindexed @@ -2541,7 +2541,7 @@ end program test_besj0 @item @emph{Specific names}: @multitable @columnfractions .20 .20 .20 .25 -@item Name @tab Argument @tab Return type @tab Standard +@headitem Name @tab Argument @tab Return type @tab Standard @item @code{DBESJ0(X)} @tab @code{REAL(8) X} @tab @code{REAL(8)} @tab GNU extension @end multitable @end table @@ -2590,7 +2590,7 @@ end program test_besj1 @item @emph{Specific names}: @multitable @columnfractions .20 .20 .20 .25 -@item Name @tab Argument @tab Return type @tab Standard +@headitem Name @tab Argument @tab Return type @tab Standard @item @code{DBESJ1(X)} @tab @code{REAL(8) X} @tab @code{REAL(8)} @tab GNU extension @end multitable @end table @@ -2655,7 +2655,7 @@ end program test_besjn @item @emph{Specific names}: @multitable @columnfractions .20 .20 .20 .25 -@item Name @tab Argument @tab Return type @tab Standard +@headitem Name @tab Argument @tab Return type @tab Standard @item @code{DBESJN(N, X)} @tab @code{INTEGER N} @tab @code{REAL(8)} @tab GNU extension @item @tab @code{REAL(8) X} @tab @tab @end multitable @@ -2703,7 +2703,7 @@ end program test_besy0 @item @emph{Specific names}: @multitable @columnfractions .20 .20 .20 .25 -@item Name @tab Argument @tab Return type @tab Standard +@headitem Name @tab Argument @tab Return type @tab Standard @item @code{DBESY0(X)}@tab @code{REAL(8) X} @tab @code{REAL(8)} @tab GNU extension @end multitable @end table @@ -2750,7 +2750,7 @@ end program test_besy1 @item @emph{Specific names}: @multitable @columnfractions .20 .20 .20 .25 -@item Name @tab Argument @tab Return type @tab Standard +@headitem Name @tab Argument @tab Return type @tab Standard @item @code{DBESY1(X)}@tab @code{REAL(8) X} @tab @code{REAL(8)} @tab GNU extension @end multitable @end table @@ -2815,7 +2815,7 @@ end program test_besyn @item @emph{Specific names}: @multitable @columnfractions .20 .20 .20 .25 -@item Name @tab Argument @tab Return type @tab Standard +@headitem Name @tab Argument @tab Return type @tab Standard @item @code{DBESYN(N,X)} @tab @code{INTEGER N} @tab @code{REAL(8)} @tab GNU extension @item @tab @code{REAL(8) X} @tab @tab @end multitable @@ -3058,7 +3058,7 @@ end program test_btest @item @emph{Specific names}: @multitable @columnfractions .20 .20 .20 .25 -@item Name @tab Argument @tab Return type @tab Standard +@headitem Name @tab Argument @tab Return type @tab Standard @item @code{BTEST(I,POS)} @tab @code{INTEGER I,POS} @tab @code{LOGICAL} @tab Fortran 95 and later @item @code{BBTEST(I,POS)} @tab @code{INTEGER(1) I,POS} @tab @code{LOGICAL(1)} @tab GNU extension @item @code{BITEST(I,POS)} @tab @code{INTEGER(2) I,POS} @tab @code{LOGICAL(2)} @tab GNU extension @@ -3475,7 +3475,7 @@ end program test_char @item @emph{Specific names}: @multitable @columnfractions .18 .18 .24 .25 -@item Name @tab Argument @tab Return type @tab Standard +@headitem Name @tab Argument @tab Return type @tab Standard @item @code{CHAR(I)} @tab @code{INTEGER I} @tab @code{CHARACTER(LEN=1)} @tab Fortran 77 and later @end multitable @@ -4204,7 +4204,7 @@ end program test_conjg @item @emph{Specific names}: @multitable @columnfractions .20 .20 .20 .25 -@item Name @tab Argument @tab Return type @tab Standard +@headitem Name @tab Argument @tab Return type @tab Standard @item @code{DCONJG(Z)} @tab @code{COMPLEX(8) Z} @tab @code{COMPLEX(8)} @tab GNU extension @end multitable @end table @@ -4255,7 +4255,7 @@ end program test_cos @item @emph{Specific names}: @multitable @columnfractions .20 .20 .20 .25 -@item Name @tab Argument @tab Return type @tab Standard +@headitem Name @tab Argument @tab Return type @tab Standard @item @code{COS(X)} @tab @code{REAL(4) X} @tab @code{REAL(4)} @tab Fortran 77 and later @item @code{DCOS(X)} @tab @code{REAL(8) X} @tab @code{REAL(8)} @tab Fortran 77 and later @item @code{CCOS(X)} @tab @code{COMPLEX(4) X} @tab @code{COMPLEX(4)} @tab Fortran 77 and later @@ -4319,7 +4319,7 @@ end program test_cosd @item @emph{Specific names}: @multitable @columnfractions .20 .20 .20 .25 -@item Name @tab Argument @tab Return type @tab Standard +@headitem Name @tab Argument @tab Return type @tab Standard @item @code{COSD(X)} @tab @code{REAL(4) X} @tab @code{REAL(4)} @tab GNU extension @item @code{DCOSD(X)} @tab @code{REAL(8) X} @tab @code{REAL(8)} @tab GNU extension @item @code{CCOSD(X)} @tab @code{COMPLEX(4) X} @tab @code{COMPLEX(4)} @tab GNU extension @@ -4378,7 +4378,7 @@ end program test_cosh @item @emph{Specific names}: @multitable @columnfractions .20 .20 .20 .25 -@item Name @tab Argument @tab Return type @tab Standard +@headitem Name @tab Argument @tab Return type @tab Standard @item @code{COSH(X)} @tab @code{REAL(4) X} @tab @code{REAL(4)} @tab Fortran 77 and later @item @code{DCOSH(X)} @tab @code{REAL(8) X} @tab @code{REAL(8)} @tab Fortran 77 and later @end multitable @@ -4432,7 +4432,7 @@ end program test_cotan @item @emph{Specific names}: @multitable @columnfractions .20 .20 .20 .25 -@item Name @tab Argument @tab Return type @tab Standard +@headitem Name @tab Argument @tab Return type @tab Standard @item @code{COTAN(X)} @tab @code{REAL(4) X} @tab @code{REAL(4)} @tab GNU extension @item @code{DCOTAN(X)} @tab @code{REAL(8) X} @tab @code{REAL(8)} @tab GNU extension @end multitable @@ -4488,7 +4488,7 @@ end program test_cotand @item @emph{Specific names}: @multitable @columnfractions .20 .20 .20 .25 -@item Name @tab Argument @tab Return type @tab Standard +@headitem Name @tab Argument @tab Return type @tab Standard @item @code{COTAND(X)} @tab @code{REAL(4) X} @tab @code{REAL(4)} @tab GNU extension @item @code{DCOTAND(X)} @tab @code{REAL(8) X} @tab @code{REAL(8)} @tab GNU extension @end multitable @@ -4764,15 +4764,15 @@ Unavailable time and date parameters return blanks. @var{VALUES} is @code{INTENT(OUT)} and provides the following: -@multitable @columnfractions .15 .30 .40 -@item @tab @code{VALUE(1)}: @tab The year -@item @tab @code{VALUE(2)}: @tab The month -@item @tab @code{VALUE(3)}: @tab The day of the month -@item @tab @code{VALUE(4)}: @tab Time difference with UTC in minutes -@item @tab @code{VALUE(5)}: @tab The hour of the day -@item @tab @code{VALUE(6)}: @tab The minutes of the hour -@item @tab @code{VALUE(7)}: @tab The seconds of the minute -@item @tab @code{VALUE(8)}: @tab The milliseconds of the second +@multitable @columnfractions .15 .70 +@item @code{VALUE(1)}: @tab The year +@item @code{VALUE(2)}: @tab The month +@item @code{VALUE(3)}: @tab The day of the month +@item @code{VALUE(4)}: @tab Time difference with UTC in minutes +@item @code{VALUE(5)}: @tab The hour of the day +@item @code{VALUE(6)}: @tab The minutes of the hour +@item @code{VALUE(7)}: @tab The seconds of the minute +@item @code{VALUE(8)}: @tab The milliseconds of the second @end multitable @item @emph{Standard}: @@ -5003,7 +5003,7 @@ end program test_dim @item @emph{Specific names}: @multitable @columnfractions .20 .20 .20 .25 -@item Name @tab Argument @tab Return type @tab Standard +@headitem Name @tab Argument @tab Return type @tab Standard @item @code{DIM(X,Y)} @tab @code{REAL(4) X, Y} @tab @code{REAL(4)} @tab Fortran 77 and later @item @code{IDIM(X,Y)} @tab @code{INTEGER(4) X, Y} @tab @code{INTEGER(4)} @tab Fortran 77 and later @item @code{DDIM(X,Y)} @tab @code{REAL(8) X, Y} @tab @code{REAL(8)} @tab Fortran 77 and later @@ -5106,7 +5106,7 @@ end program test_dprod @item @emph{Specific names}: @multitable @columnfractions .20 .20 .20 .25 -@item Name @tab Argument @tab Return type @tab Standard +@headitem Name @tab Argument @tab Return type @tab Standard @item @code{DPROD(X,Y)} @tab @code{REAL(4) X, Y} @tab @code{REAL(8)} @tab Fortran 77 and later @end multitable @@ -5278,10 +5278,10 @@ only one form can be used in any given program unit. @var{VALUES} and @var{TIME} are @code{INTENT(OUT)} and provide the following: -@multitable @columnfractions .15 .30 .40 -@item @tab @code{VALUES(1)}: @tab User time in seconds. -@item @tab @code{VALUES(2)}: @tab System time in seconds. -@item @tab @code{TIME}: @tab Run time since start in seconds. +@multitable @columnfractions .15 .70 +@item @code{VALUES(1)}: @tab User time in seconds. +@item @code{VALUES(2)}: @tab System time in seconds. +@item @code{TIME}: @tab Run time since start in seconds. @end multitable @item @emph{Standard}: @@ -5475,7 +5475,7 @@ end program test_erf @item @emph{Specific names}: @multitable @columnfractions .20 .20 .20 .25 -@item Name @tab Argument @tab Return type @tab Standard +@headitem Name @tab Argument @tab Return type @tab Standard @item @code{DERF(X)} @tab @code{REAL(8) X} @tab @code{REAL(8)} @tab GNU extension @end multitable @end table @@ -5519,7 +5519,7 @@ end program test_erfc @item @emph{Specific names}: @multitable @columnfractions .20 .20 .20 .25 -@item Name @tab Argument @tab Return type @tab Standard +@headitem Name @tab Argument @tab Return type @tab Standard @item @code{DERFC(X)} @tab @code{REAL(8) X} @tab @code{REAL(8)} @tab GNU extension @end multitable @end table @@ -5587,10 +5587,10 @@ only one form can be used in any given program unit. @var{VALUES} and @var{TIME} are @code{INTENT(OUT)} and provide the following: -@multitable @columnfractions .15 .30 .60 -@item @tab @code{VALUES(1)}: @tab User time in seconds. -@item @tab @code{VALUES(2)}: @tab System time in seconds. -@item @tab @code{TIME}: @tab Run time since start in seconds. +@multitable @columnfractions .15 .70 +@item @code{VALUES(1)}: @tab User time in seconds. +@item @code{VALUES(2)}: @tab System time in seconds. +@item @code{TIME}: @tab Run time since start in seconds. @end multitable @item @emph{Standard}: @@ -5863,7 +5863,7 @@ end program test_exp @item @emph{Specific names}: @multitable @columnfractions .20 .20 .20 .25 -@item Name @tab Argument @tab Return type @tab Standard +@headitem Name @tab Argument @tab Return type @tab Standard @item @code{EXP(X)} @tab @code{REAL(4) X} @tab @code{REAL(4)} @tab Fortran 77 and later @item @code{DEXP(X)} @tab @code{REAL(8) X} @tab @code{REAL(8)} @tab Fortran 77 and later @item @code{CEXP(X)} @tab @code{COMPLEX(4) X} @tab @code{COMPLEX(4)} @tab Fortran 77 and later @@ -6803,7 +6803,7 @@ end program test_gamma @item @emph{Specific names}: @multitable @columnfractions .20 .20 .20 .25 -@item Name @tab Argument @tab Return type @tab Standard +@headitem Name @tab Argument @tab Return type @tab Standard @item @code{DGAMMA(X)} @tab @code{REAL(8) X} @tab @code{REAL(8)} @tab GNU extension @end multitable @@ -6835,7 +6835,7 @@ Subroutine @item @emph{Arguments}: @multitable @columnfractions .15 .70 -@item @var{RESULT} @tab Shall of type @code{CHARACTER} and of default +@item @var{RESULT} @tab Shall be of type @code{CHARACTER} and of default kind. @end multitable @item @emph{Example}: @@ -6885,7 +6885,6 @@ Subroutine the default integer kind; @math{@var{POS} \geq 0} @item @var{VALUE} @tab Shall be of type @code{CHARACTER} and of default kind. -@item @var{VALUE} @tab Shall be of type @code{CHARACTER}. @end multitable @item @emph{Return value}: @@ -7259,7 +7258,7 @@ Subroutine @end multitable @item @emph{Return value}: -Stores the current user name in @var{LOGIN}. (On systems where POSIX +Stores the current user name in @var{C}. (On systems where POSIX functions @code{geteuid} and @code{getpwuid} are not available, and the @code{getlogin} function is not implemented either, this will return a blank string.) @@ -7693,7 +7692,7 @@ END PROGRAM @item @emph{Specific names}: @multitable @columnfractions .20 .20 .20 .25 -@item Name @tab Argument @tab Return type @tab Standard +@headitem Name @tab Argument @tab Return type @tab Standard @item @code{IAND(A)} @tab @code{INTEGER A} @tab @code{INTEGER} @tab Fortran 90 and later @item @code{BIAND(A)} @tab @code{INTEGER(1) A} @tab @code{INTEGER(1)} @tab GNU extension @item @code{IIAND(A)} @tab @code{INTEGER(2) A} @tab @code{INTEGER(2)} @tab GNU extension @@ -7856,7 +7855,7 @@ The return value is of type @code{INTEGER} and of the same kind as @item @emph{Specific names}: @multitable @columnfractions .20 .20 .20 .25 -@item Name @tab Argument @tab Return type @tab Standard +@headitem Name @tab Argument @tab Return type @tab Standard @item @code{IBCLR(A)} @tab @code{INTEGER A} @tab @code{INTEGER} @tab Fortran 90 and later @item @code{BBCLR(A)} @tab @code{INTEGER(1) A} @tab @code{INTEGER(1)} @tab GNU extension @item @code{IIBCLR(A)} @tab @code{INTEGER(2) A} @tab @code{INTEGER(2)} @tab GNU extension @@ -7915,7 +7914,7 @@ The return value is of type @code{INTEGER} and of the same kind as @item @emph{Specific names}: @multitable @columnfractions .20 .20 .20 .25 -@item Name @tab Argument @tab Return type @tab Standard +@headitem Name @tab Argument @tab Return type @tab Standard @item @code{IBITS(A)} @tab @code{INTEGER A} @tab @code{INTEGER} @tab Fortran 90 and later @item @code{BBITS(A)} @tab @code{INTEGER(1) A} @tab @code{INTEGER(1)} @tab GNU extension @item @code{IIBITS(A)} @tab @code{INTEGER(2) A} @tab @code{INTEGER(2)} @tab GNU extension @@ -7969,7 +7968,7 @@ The return value is of type @code{INTEGER} and of the same kind as @item @emph{Specific names}: @multitable @columnfractions .20 .20 .20 .25 -@item Name @tab Argument @tab Return type @tab Standard +@headitem Name @tab Argument @tab Return type @tab Standard @item @code{IBSET(A)} @tab @code{INTEGER A} @tab @code{INTEGER} @tab Fortran 90 and later @item @code{BBSET(A)} @tab @code{INTEGER(1) A} @tab @code{INTEGER(1)} @tab GNU extension @item @code{IIBSET(A)} @tab @code{INTEGER(2) A} @tab @code{INTEGER(2)} @tab GNU extension @@ -8030,7 +8029,7 @@ end program test_ichar @item @emph{Specific names}: @multitable @columnfractions .20 .20 .20 .25 -@item Name @tab Argument @tab Return type @tab Standard +@headitem Name @tab Argument @tab Return type @tab Standard @item @code{ICHAR(C)} @tab @code{CHARACTER C} @tab @code{INTEGER(4)} @tab Fortran 77 and later @end multitable @@ -8157,7 +8156,7 @@ type parameter of the other argument as-if a call to @ref{INT} occurred. @item @emph{Specific names}: @multitable @columnfractions .20 .20 .20 .25 -@item Name @tab Argument @tab Return type @tab Standard +@headitem Name @tab Argument @tab Return type @tab Standard @item @code{IEOR(A)} @tab @code{INTEGER A} @tab @code{INTEGER} @tab Fortran 90 and later @item @code{BIEOR(A)} @tab @code{INTEGER(1) A} @tab @code{INTEGER(1)} @tab GNU extension @item @code{IIEOR(A)} @tab @code{INTEGER(2) A} @tab @code{INTEGER(2)} @tab GNU extension @@ -8294,7 +8293,7 @@ The return value is of type @code{INTEGER} and of kind @var{KIND}. If @item @emph{Specific names}: @multitable @columnfractions .20 .20 .20 .25 -@item Name @tab Argument @tab Return type @tab Standard +@headitem Name @tab Argument @tab Return type @tab Standard @item @code{INDEX(STRING, SUBSTRING)} @tab @code{CHARACTER} @tab @code{INTEGER(4)} @tab Fortran 77 and later @end multitable @@ -8361,7 +8360,7 @@ end program @item @emph{Specific names}: @multitable @columnfractions .20 .20 .20 .25 -@item Name @tab Argument @tab Return type @tab Standard +@headitem Name @tab Argument @tab Return type @tab Standard @item @code{INT(A)} @tab @code{REAL(4) A} @tab @code{INTEGER} @tab Fortran 77 and later @item @code{IFIX(A)} @tab @code{REAL(4) A} @tab @code{INTEGER} @tab Fortran 77 and later @item @code{IDINT(A)} @tab @code{REAL(8) A} @tab @code{INTEGER} @tab Fortran 77 and later @@ -8487,7 +8486,7 @@ type parameter of the other argument as-if a call to @ref{INT} occurred. @item @emph{Specific names}: @multitable @columnfractions .20 .20 .20 .25 -@item Name @tab Argument @tab Return type @tab Standard +@headitem Name @tab Argument @tab Return type @tab Standard @item @code{IOR(A)} @tab @code{INTEGER A} @tab @code{INTEGER} @tab Fortran 90 and later @item @code{BIOR(A)} @tab @code{INTEGER(1) A} @tab @code{INTEGER(1)} @tab GNU extension @item @code{IIOR(A)} @tab @code{INTEGER(2) A} @tab @code{INTEGER(2)} @tab GNU extension @@ -8841,7 +8840,7 @@ The return value is of type @code{INTEGER} and of the same kind as @item @emph{Specific names}: @multitable @columnfractions .20 .20 .20 .25 -@item Name @tab Argument @tab Return type @tab Standard +@headitem Name @tab Argument @tab Return type @tab Standard @item @code{ISHFT(A)} @tab @code{INTEGER A} @tab @code{INTEGER} @tab Fortran 90 and later @item @code{BSHFT(A)} @tab @code{INTEGER(1) A} @tab @code{INTEGER(1)} @tab GNU extension @item @code{IISHFT(A)} @tab @code{INTEGER(2) A} @tab @code{INTEGER(2)} @tab GNU extension @@ -8899,7 +8898,7 @@ The return value is of type @code{INTEGER} and of the same kind as @item @emph{Specific names}: @multitable @columnfractions .20 .20 .20 .25 -@item Name @tab Argument @tab Return type @tab Standard +@headitem Name @tab Argument @tab Return type @tab Standard @item @code{ISHFTC(A)} @tab @code{INTEGER A} @tab @code{INTEGER} @tab Fortran 90 and later @item @code{BSHFTC(A)} @tab @code{INTEGER(1) A} @tab @code{INTEGER(1)} @tab GNU extension @item @code{IISHFTC(A)} @tab @code{INTEGER(2) A} @tab @code{INTEGER(2)} @tab GNU extension @@ -9260,7 +9259,7 @@ The return value is of type @code{INTEGER} and of kind @var{KIND}. If @item @emph{Specific names}: @multitable @columnfractions .20 .20 .20 .25 -@item Name @tab Argument @tab Return type @tab Standard +@headitem Name @tab Argument @tab Return type @tab Standard @item @code{LEN(STRING)} @tab @code{CHARACTER} @tab @code{INTEGER} @tab Fortran 77 and later @end multitable @@ -9353,7 +9352,7 @@ otherwise, based on the ASCII ordering. @item @emph{Specific names}: @multitable @columnfractions .20 .20 .20 .25 -@item Name @tab Argument @tab Return type @tab Standard +@headitem Name @tab Argument @tab Return type @tab Standard @item @code{LGE(STRING_A, STRING_B)} @tab @code{CHARACTER} @tab @code{LOGICAL} @tab Fortran 77 and later @end multitable @@ -9407,7 +9406,7 @@ otherwise, based on the ASCII ordering. @item @emph{Specific names}: @multitable @columnfractions .20 .20 .20 .25 -@item Name @tab Argument @tab Return type @tab Standard +@headitem Name @tab Argument @tab Return type @tab Standard @item @code{LGT(STRING_A, STRING_B)} @tab @code{CHARACTER} @tab @code{LOGICAL} @tab Fortran 77 and later @end multitable @@ -9505,7 +9504,7 @@ otherwise, based on the ASCII ordering. @item @emph{Specific names}: @multitable @columnfractions .20 .20 .20 .25 -@item Name @tab Argument @tab Return type @tab Standard +@headitem Name @tab Argument @tab Return type @tab Standard @item @code{LLE(STRING_A, STRING_B)} @tab @code{CHARACTER} @tab @code{LOGICAL} @tab Fortran 77 and later @end multitable @@ -9559,7 +9558,7 @@ otherwise, based on the ASCII ordering. @item @emph{Specific names}: @multitable @columnfractions .20 .20 .20 .25 -@item Name @tab Argument @tab Return type @tab Standard +@headitem Name @tab Argument @tab Return type @tab Standard @item @code{LLT(STRING_A, STRING_B)} @tab @code{CHARACTER} @tab @code{LOGICAL} @tab Fortran 77 and later @end multitable @@ -9698,7 +9697,7 @@ end program test_log @item @emph{Specific names}: @multitable @columnfractions .20 .20 .20 .25 -@item Name @tab Argument @tab Return type @tab Standard +@headitem Name @tab Argument @tab Return type @tab Standard @item @code{ALOG(X)} @tab @code{REAL(4) X} @tab @code{REAL(4)} @tab Fortran 77 or later @item @code{DLOG(X)} @tab @code{REAL(8) X} @tab @code{REAL(8)} @tab Fortran 77 or later @item @code{CLOG(X)} @tab @code{COMPLEX(4) X} @tab @code{COMPLEX(4)} @tab Fortran 77 or later @@ -9750,7 +9749,7 @@ end program test_log10 @item @emph{Specific names}: @multitable @columnfractions .20 .20 .20 .25 -@item Name @tab Argument @tab Return type @tab Standard +@headitem Name @tab Argument @tab Return type @tab Standard @item @code{ALOG10(X)} @tab @code{REAL(4) X} @tab @code{REAL(4)} @tab Fortran 77 and later @item @code{DLOG10(X)} @tab @code{REAL(8) X} @tab @code{REAL(8)} @tab Fortran 77 and later @end multitable @@ -9799,7 +9798,7 @@ end program test_log_gamma @item @emph{Specific names}: @multitable @columnfractions .20 .20 .20 .25 -@item Name @tab Argument @tab Return type @tab Standard +@headitem Name @tab Argument @tab Return type @tab Standard @item @code{LGAMMA(X)} @tab @code{REAL(4) X} @tab @code{REAL(4)} @tab GNU extension @item @code{ALGAMA(X)} @tab @code{REAL(4) X} @tab @code{REAL(4)} @tab GNU extension @item @code{DLGAMA(X)} @tab @code{REAL(8) X} @tab @code{REAL(8)} @tab GNU extension @@ -10258,7 +10257,7 @@ and has the same type and kind as the first argument. @item @emph{Specific names}: @multitable @columnfractions .20 .20 .20 .25 -@item Name @tab Argument @tab Return type @tab Standard +@headitem Name @tab Argument @tab Return type @tab Standard @item @code{MAX0(A1)} @tab @code{INTEGER(4) A1} @tab @code{INTEGER(4)} @tab Fortran 77 and later @item @code{AMAX0(A1)} @tab @code{INTEGER(4) A1} @tab @code{REAL(MAX(X))} @tab Fortran 77 and later @item @code{MAX1(A1)} @tab @code{REAL A1} @tab @code{INT(MAX(X))} @tab Fortran 77 and later @@ -10633,7 +10632,7 @@ and has the same type and kind as the first argument. @item @emph{Specific names}: @multitable @columnfractions .20 .20 .20 .25 -@item Name @tab Argument @tab Return type @tab Standard +@headitem Name @tab Argument @tab Return type @tab Standard @item @code{MIN0(A1)} @tab @code{INTEGER(4) A1} @tab @code{INTEGER(4)} @tab Fortran 77 and later @item @code{AMIN0(A1)} @tab @code{INTEGER(4) A1} @tab @code{REAL(4)} @tab Fortran 77 and later @item @code{MIN1(A1)} @tab @code{REAL A1} @tab @code{INTEGER(4)} @tab Fortran 77 and later @@ -10866,7 +10865,7 @@ end program test_mod @item @emph{Specific names}: @multitable @columnfractions .20 .20 .20 .25 -@item Name @tab Arguments @tab Return type @tab Standard +@headitem Name @tab Arguments @tab Return type @tab Standard @item @code{MOD(A,P)} @tab @code{INTEGER A,P} @tab @code{INTEGER} @tab Fortran 77 and later @item @code{AMOD(A,P)} @tab @code{REAL(4) A,P} @tab @code{REAL(4)} @tab Fortran 77 and later @item @code{DMOD(A,P)} @tab @code{REAL(8) A,P} @tab @code{REAL(8)} @tab Fortran 77 and later @@ -11031,7 +11030,7 @@ same kind as @var{FROM}. @item @emph{Specific names}: @multitable @columnfractions .20 .20 .20 .25 -@item Name @tab Argument @tab Return type @tab Standard +@headitem Name @tab Argument @tab Return type @tab Standard @item @code{MVBITS(A)} @tab @code{INTEGER A} @tab @code{INTEGER} @tab Fortran 90 and later @item @code{BMVBITS(A)} @tab @code{INTEGER(1) A} @tab @code{INTEGER(1)} @tab GNU extension @item @code{IMVBITS(A)} @tab @code{INTEGER(2) A} @tab @code{INTEGER(2)} @tab GNU extension @@ -11181,7 +11180,7 @@ end program test_nint @item @emph{Specific names}: @multitable @columnfractions .20 .20 .20 .25 -@item Name @tab Argument @tab Return Type @tab Standard +@headitem Name @tab Argument @tab Return Type @tab Standard @item @code{NINT(A)} @tab @code{REAL(4) A} @tab @code{INTEGER} @tab Fortran 77 and later @item @code{IDNINT(A)} @tab @code{REAL(8) A} @tab @code{INTEGER} @tab Fortran 77 and later @end multitable @@ -11202,7 +11201,7 @@ end program test_nint @table @asis @item @emph{Description}: -Calculates the Euclidean vector norm (@math{L_2} norm) of +Calculates the Euclidean vector norm (@math{L_2} norm) of @var{ARRAY} along dimension @var{DIM}. @item @emph{Standard}: @@ -11279,7 +11278,7 @@ argument. @item @emph{Specific names}: @multitable @columnfractions .20 .20 .20 .25 -@item Name @tab Argument @tab Return type @tab Standard +@headitem Name @tab Argument @tab Return type @tab Standard @item @code{NOT(A)} @tab @code{INTEGER A} @tab @code{INTEGER} @tab Fortran 95 and later @item @code{BNOT(A)} @tab @code{INTEGER(1) A} @tab @code{INTEGER(1)} @tab GNU extension @item @code{INOT(A)} @tab @code{INTEGER(2) A} @tab @code{INTEGER(2)} @tab GNU extension @@ -11555,7 +11554,7 @@ Transformational function @item @emph{Arguments}: @multitable @columnfractions .15 .70 -@item @var{LOGICAL} @tab Shall be an array of type @code{LOGICAL} +@item @var{MASK} @tab Shall be an array of type @code{LOGICAL} @item @var{DIM} @tab (Optional) shall be a scalar of type @code{INTEGER} with a value in the range from 1 to n, where n equals the rank of @var{MASK}. @@ -12005,7 +12004,7 @@ is set to a processor-dependent value. @code{LOGICAL} type, and it is @code{INTENT(IN)}. If it is @code{.true.}, the seed is set to a processor-dependent value that is distinct from th seed set by a call to @code{RANDOM_INIT} in another image. If it is -@code{.false.}, the seed is set value that does depend which image called +@code{.false.}, the seed is set to a value that does depend which image called @code{RANDOM_INIT}. @end multitable @@ -12057,7 +12056,7 @@ Fortran 90 and later Subroutine @item @emph{Syntax}: -@code{RANDOM_NUMBER(HARVEST)} +@code{CALL RANDOM_NUMBER(HARVEST)} @item @emph{Arguments}: @multitable @columnfractions .15 .70 @@ -12295,7 +12294,7 @@ end program test_real @item @emph{Specific names}: @multitable @columnfractions .20 .20 .20 .25 -@item Name @tab Argument @tab Return type @tab Standard +@headitem Name @tab Argument @tab Return type @tab Standard @item @code{FLOAT(A)} @tab @code{INTEGER(4)} @tab @code{REAL(4)} @tab GNU extension @item @code{DFLOAT(A)} @tab @code{INTEGER(4)} @tab @code{REAL(8)} @tab GNU extension @item @code{FLOATI(A)} @tab @code{INTEGER(2)} @tab @code{REAL(4)} @tab GNU extension @@ -13199,7 +13198,7 @@ end program test_sign @item @emph{Specific names}: @multitable @columnfractions .20 .20 .20 .25 -@item Name @tab Arguments @tab Return type @tab Standard +@headitem Name @tab Arguments @tab Return type @tab Standard @item @code{SIGN(A,B)} @tab @code{REAL(4) A, B} @tab @code{REAL(4)} @tab Fortran 77 and later @item @code{ISIGN(A,B)} @tab @code{INTEGER(4) A, B} @tab @code{INTEGER(4)} @tab Fortran 77 and later @item @code{DSIGN(A,B)} @tab @code{REAL(8) A, B} @tab @code{REAL(8)} @tab Fortran 77 and later @@ -13308,7 +13307,7 @@ end program test_sin @item @emph{Specific names}: @multitable @columnfractions .20 .20 .20 .25 -@item Name @tab Argument @tab Return type @tab Standard +@headitem Name @tab Argument @tab Return type @tab Standard @item @code{SIN(X)} @tab @code{REAL(4) X} @tab @code{REAL(4)} @tab Fortran 77 and later @item @code{DSIN(X)} @tab @code{REAL(8) X} @tab @code{REAL(8)} @tab Fortran 77 and later @item @code{CSIN(X)} @tab @code{COMPLEX(4) X} @tab @code{COMPLEX(4)} @tab Fortran 77 and later @@ -13370,7 +13369,7 @@ end program test_sind @item @emph{Specific names}: @multitable @columnfractions .20 .20 .20 .25 -@item Name @tab Argument @tab Return type @tab Standard +@headitem Name @tab Argument @tab Return type @tab Standard @item @code{SIND(X)} @tab @code{REAL(4) X} @tab @code{REAL(4)} @tab GNU extension @item @code{DSIND(X)} @tab @code{REAL(8) X} @tab @code{REAL(8)} @tab GNU extension @item @code{CSIND(X)} @tab @code{COMPLEX(4) X} @tab @code{COMPLEX(4)} @tab GNU extension @@ -13427,7 +13426,7 @@ end program test_sinh @item @emph{Specific names}: @multitable @columnfractions .20 .20 .20 .25 -@item Name @tab Argument @tab Return type @tab Standard +@headitem Name @tab Argument @tab Return type @tab Standard @item @code{DSINH(X)} @tab @code{REAL(8) X} @tab @code{REAL(8)} @tab Fortran 90 and later @end multitable @@ -13712,7 +13711,7 @@ end program test_sqrt @item @emph{Specific names}: @multitable @columnfractions .20 .20 .20 .25 -@item Name @tab Argument @tab Return type @tab Standard +@headitem Name @tab Argument @tab Return type @tab Standard @item @code{SQRT(X)} @tab @code{REAL(4) X} @tab @code{REAL(4)} @tab Fortran 77 and later @item @code{DSQRT(X)} @tab @code{REAL(8) X} @tab @code{REAL(8)} @tab Fortran 77 and later @item @code{CSQRT(X)} @tab @code{COMPLEX(4) X} @tab @code{COMPLEX(4)} @tab Fortran 77 and later @@ -14163,7 +14162,7 @@ end program test_tan @item @emph{Specific names}: @multitable @columnfractions .20 .20 .20 .25 -@item Name @tab Argument @tab Return type @tab Standard +@headitem Name @tab Argument @tab Return type @tab Standard @item @code{TAN(X)} @tab @code{REAL(4) X} @tab @code{REAL(4)} @tab Fortran 77 and later @item @code{DTAN(X)} @tab @code{REAL(8) X} @tab @code{REAL(8)} @tab Fortran 77 and later @end multitable @@ -14218,7 +14217,7 @@ end program test_tand @item @emph{Specific names}: @multitable @columnfractions .20 .20 .20 .25 -@item Name @tab Argument @tab Return type @tab Standard +@headitem Name @tab Argument @tab Return type @tab Standard @item @code{TAND(X)} @tab @code{REAL(4) X} @tab @code{REAL(4)} @tab GNU extension @item @code{DTAND(X)} @tab @code{REAL(8) X} @tab @code{REAL(8)} @tab GNU extension @end multitable @@ -14274,7 +14273,7 @@ end program test_tanh @item @emph{Specific names}: @multitable @columnfractions .20 .20 .20 .25 -@item Name @tab Argument @tab Return type @tab Standard +@headitem Name @tab Argument @tab Return type @tab Standard @item @code{TANH(X)} @tab @code{REAL(4) X} @tab @code{REAL(4)} @tab Fortran 77 and later @item @code{DTANH(X)} @tab @code{REAL(8) X} @tab @code{REAL(8)} @tab Fortran 77 and later @end multitable @@ -15198,7 +15197,7 @@ Furthermore, if @code{__float128} is supported in C, the named constants @code{C_FLOAT128, C_FLOAT128_COMPLEX} are defined. @multitable @columnfractions .15 .35 .35 .35 -@item Fortran Type @tab Named constant @tab C type @tab Extension +@headitem Fortran Type @tab Named constant @tab C type @tab Extension @item @code{INTEGER}@tab @code{C_INT} @tab @code{int} @item @code{INTEGER}@tab @code{C_SHORT} @tab @code{short int} @item @code{INTEGER}@tab @code{C_LONG} @tab @code{long int} @@ -15239,7 +15238,7 @@ Additionally, the following parameters of type @code{CHARACTER(KIND=C_CHAR)} are defined. @multitable @columnfractions .20 .45 .15 -@item Name @tab C definition @tab Value +@headitem Name @tab C definition @tab Value @item @code{C_NULL_CHAR} @tab null character @tab @code{'\0'} @item @code{C_ALERT} @tab alert @tab @code{'\a'} @item @code{C_BACKSPACE} @tab backspace @tab @code{'\b'} @@ -15253,7 +15252,7 @@ are defined. Moreover, the following two named constants are defined: @multitable @columnfractions .20 .80 -@item Name @tab Type +@headitem Name @tab Type @item @code{C_NULL_PTR} @tab @code{C_PTR} @item @code{C_NULL_FUNPTR} @tab @code{C_FUNPTR} @end multitable @@ -15294,8 +15293,9 @@ with the following options: @code{-fno-unsafe-math-optimizations @section OpenMP Modules @code{OMP_LIB} and @code{OMP_LIB_KINDS} @table @asis @item @emph{Standard}: -OpenMP Application Program Interface v4.5 and -OpenMP Application Program Interface v5.0 (partially supported). +OpenMP Application Program Interface v4.5, +OpenMP Application Program Interface v5.0 (partially supported) and +OpenMP Application Program Interface v5.1 (partially supported). @end table The OpenMP Fortran runtime library routines are provided both in @@ -15358,6 +15358,7 @@ kind @code{omp_proc_bind_kind}: @table @asis @item @code{omp_proc_bind_false} @item @code{omp_proc_bind_true} +@item @code{omp_proc_bind_primary} @item @code{omp_proc_bind_master} @item @code{omp_proc_bind_close} @item @code{omp_proc_bind_spread} diff --git a/gcc/fortran/io.c b/gcc/fortran/io.c index 40cd76e..fc97df7 100644 --- a/gcc/fortran/io.c +++ b/gcc/fortran/io.c @@ -1763,7 +1763,7 @@ resolve_tag_format (gfc_expr *e) if (e->ts.type != BT_CHARACTER) { if (e->ts.type == BT_DERIVED || e->ts.type == BT_CLASS - || e->ts.type == BT_VOID) + || e->ts.type == BT_VOID || e->ts.type == BT_UNKNOWN) { gfc_error ("Non-character non-Hollerith in FORMAT tag at %L", &e->where); diff --git a/gcc/fortran/iso-c-binding.def b/gcc/fortran/iso-c-binding.def index 8bf69ef..e65c750 100644 --- a/gcc/fortran/iso-c-binding.def +++ b/gcc/fortran/iso-c-binding.def @@ -114,9 +114,14 @@ NAMED_REALCST (ISOCBINDING_DOUBLE, "c_double", \ get_real_kind_from_node (double_type_node), GFC_STD_F2003) NAMED_REALCST (ISOCBINDING_LONG_DOUBLE, "c_long_double", \ get_real_kind_from_node (long_double_type_node), GFC_STD_F2003) + +/* GNU Extension. Note that the equivalence here is specifically to + the IEEE 128-bit type __float128; if that does not map onto a type + otherwise supported by the Fortran front end, get_real_kind_from_node + will reject it as unsupported. */ NAMED_REALCST (ISOCBINDING_FLOAT128, "c_float128", \ - gfc_float128_type_node == NULL_TREE \ - ? -4 : get_real_kind_from_node (gfc_float128_type_node), \ + (float128_type_node == NULL_TREE \ + ? -4 : get_real_kind_from_node (float128_type_node)), \ GFC_STD_GNU) NAMED_CMPXCST (ISOCBINDING_FLOAT_COMPLEX, "c_float_complex", \ get_real_kind_from_node (float_type_node), GFC_STD_F2003) @@ -124,9 +129,11 @@ NAMED_CMPXCST (ISOCBINDING_DOUBLE_COMPLEX, "c_double_complex", \ get_real_kind_from_node (double_type_node), GFC_STD_F2003) NAMED_CMPXCST (ISOCBINDING_LONG_DOUBLE_COMPLEX, "c_long_double_complex", \ get_real_kind_from_node (long_double_type_node), GFC_STD_F2003) + +/* GNU Extension. Similar issues to c_float128 above. */ NAMED_CMPXCST (ISOCBINDING_FLOAT128_COMPLEX, "c_float128_complex", \ - gfc_float128_type_node == NULL_TREE \ - ? -4 : get_real_kind_from_node (gfc_float128_type_node), \ + (float128_type_node == NULL_TREE \ + ? -4 : get_real_kind_from_node (float128_type_node)), \ GFC_STD_GNU) NAMED_LOGCST (ISOCBINDING_BOOL, "c_bool", \ diff --git a/gcc/fortran/lang.opt b/gcc/fortran/lang.opt index 2b1977c..6db01c7 100644 --- a/gcc/fortran/lang.opt +++ b/gcc/fortran/lang.opt @@ -285,6 +285,10 @@ Wuse-without-only Fortran Var(warn_use_without_only) Warning Warn about USE statements that have no ONLY qualifier. +Wopenacc-parallelism +Fortran +; Documented in C + Wopenmp-simd Fortran ; Documented in C @@ -691,10 +695,6 @@ fopenacc-dim= Fortran LTO Joined Var(flag_openacc_dims) ; Documented in C -fopenacc-kernels= -Fortran RejectNegative Joined Enum(openacc_kernels) Var(flag_openacc_kernels) Init(OPENACC_KERNELS_PARLOOPS) -; Documented in C - fopenmp Fortran LTO ; Documented in C diff --git a/gcc/fortran/match.c b/gcc/fortran/match.c index 4d5890f..53a575e 100644 --- a/gcc/fortran/match.c +++ b/gcc/fortran/match.c @@ -1109,7 +1109,8 @@ gfc_match_char (char c) %t Matches end of statement. %o Matches an intrinsic operator, returned as an INTRINSIC enum. %l Matches a statement label - %v Matches a variable expression (an lvalue) + %v Matches a variable expression (an lvalue, except function references + having a data pointer result) % Matches a required space (in free form) and optional spaces. */ match @@ -1409,7 +1410,7 @@ gfc_match_pointer_assignment (void) gfc_matching_procptr_assignment = 0; m = gfc_match (" %v =>", &lvalue); - if (m != MATCH_YES) + if (m != MATCH_YES || !lvalue->symtree) { m = MATCH_NO; goto cleanup; @@ -3854,7 +3855,7 @@ sync_statement (gfc_statement st) for (;;) { - m = gfc_match (" stat = %v", &tmp); + m = gfc_match (" stat = %e", &tmp); if (m == MATCH_ERROR) goto syntax; if (m == MATCH_YES) @@ -3874,7 +3875,7 @@ sync_statement (gfc_statement st) break; } - m = gfc_match (" errmsg = %v", &tmp); + m = gfc_match (" errmsg = %e", &tmp); if (m == MATCH_ERROR) goto syntax; if (m == MATCH_YES) @@ -4078,7 +4079,7 @@ gfc_match_goto (void) } while (gfc_match_char (',') == MATCH_YES); - if (gfc_match (")%t") != MATCH_YES) + if (gfc_match (" )%t") != MATCH_YES) goto syntax; if (head == NULL) @@ -4405,7 +4406,7 @@ gfc_match_allocate (void) alloc_opt_list: - m = gfc_match (" stat = %v", &tmp); + m = gfc_match (" stat = %e", &tmp); if (m == MATCH_ERROR) goto cleanup; if (m == MATCH_YES) @@ -4434,7 +4435,7 @@ alloc_opt_list: goto alloc_opt_list; } - m = gfc_match (" errmsg = %v", &tmp); + m = gfc_match (" errmsg = %e", &tmp); if (m == MATCH_ERROR) goto cleanup; if (m == MATCH_YES) @@ -4777,7 +4778,7 @@ gfc_match_deallocate (void) dealloc_opt_list: - m = gfc_match (" stat = %v", &tmp); + m = gfc_match (" stat = %e", &tmp); if (m == MATCH_ERROR) goto cleanup; if (m == MATCH_YES) @@ -4799,7 +4800,7 @@ dealloc_opt_list: goto dealloc_opt_list; } - m = gfc_match (" errmsg = %v", &tmp); + m = gfc_match (" errmsg = %e", &tmp); if (m == MATCH_ERROR) goto cleanup; if (m == MATCH_YES) @@ -5470,20 +5471,22 @@ gfc_free_namelist (gfc_namelist *name) /* Free an OpenMP namelist structure. */ void -gfc_free_omp_namelist (gfc_omp_namelist *name) +gfc_free_omp_namelist (gfc_omp_namelist *name, bool free_ns) { gfc_omp_namelist *n; for (; name; name = n) { gfc_free_expr (name->expr); - if (name->udr) + if (free_ns) + gfc_free_namespace (name->u2.ns); + else if (name->u2.udr) { - if (name->udr->combiner) - gfc_free_statement (name->udr->combiner); - if (name->udr->initializer) - gfc_free_statement (name->udr->initializer); - free (name->udr); + if (name->u2.udr->combiner) + gfc_free_statement (name->u2.udr->combiner); + if (name->u2.udr->initializer) + gfc_free_statement (name->u2.udr->initializer); + free (name->u2.udr); } n = name->next; free (name); @@ -6330,7 +6333,7 @@ select_intrinsic_set_tmp (gfc_typespec *ts) static void select_type_set_tmp (gfc_typespec *ts) { - char name[GFC_MAX_SYMBOL_LEN]; + char name[GFC_MAX_SYMBOL_LEN + 12 + 1]; gfc_symtree *tmp = NULL; gfc_symbol *selector = select_type_stack->selector; gfc_symbol *sym; @@ -6409,7 +6412,7 @@ gfc_match_select_type (void) { gfc_expr *expr1, *expr2 = NULL; match m; - char name[GFC_MAX_SYMBOL_LEN]; + char name[GFC_MAX_SYMBOL_LEN + 1]; bool class_array; gfc_symbol *sym; gfc_namespace *ns = gfc_current_ns; @@ -6634,7 +6637,7 @@ gfc_match_select_rank (void) { gfc_expr *expr1, *expr2 = NULL; match m; - char name[GFC_MAX_SYMBOL_LEN]; + char name[GFC_MAX_SYMBOL_LEN + 1]; gfc_symbol *sym, *sym2; gfc_namespace *ns = gfc_current_ns; gfc_array_spec *as = NULL; diff --git a/gcc/fortran/match.h b/gcc/fortran/match.h index 20a530f..92fd127 100644 --- a/gcc/fortran/match.h +++ b/gcc/fortran/match.h @@ -160,22 +160,39 @@ match gfc_match_omp_critical (void); match gfc_match_omp_declare_reduction (void); match gfc_match_omp_declare_simd (void); match gfc_match_omp_declare_target (void); +match gfc_match_omp_depobj (void); match gfc_match_omp_distribute (void); match gfc_match_omp_distribute_parallel_do (void); match gfc_match_omp_distribute_parallel_do_simd (void); match gfc_match_omp_distribute_simd (void); match gfc_match_omp_do (void); match gfc_match_omp_do_simd (void); +match gfc_match_omp_loop (void); +match gfc_match_omp_error (void); match gfc_match_omp_flush (void); +match gfc_match_omp_masked (void); +match gfc_match_omp_masked_taskloop (void); +match gfc_match_omp_masked_taskloop_simd (void); match gfc_match_omp_master (void); +match gfc_match_omp_master_taskloop (void); +match gfc_match_omp_master_taskloop_simd (void); +match gfc_match_omp_nothing (void); match gfc_match_omp_ordered (void); match gfc_match_omp_ordered_depend (void); match gfc_match_omp_parallel (void); match gfc_match_omp_parallel_do (void); match gfc_match_omp_parallel_do_simd (void); +match gfc_match_omp_parallel_loop (void); +match gfc_match_omp_parallel_masked (void); +match gfc_match_omp_parallel_masked_taskloop (void); +match gfc_match_omp_parallel_masked_taskloop_simd (void); +match gfc_match_omp_parallel_master (void); +match gfc_match_omp_parallel_master_taskloop (void); +match gfc_match_omp_parallel_master_taskloop_simd (void); match gfc_match_omp_parallel_sections (void); match gfc_match_omp_parallel_workshare (void); match gfc_match_omp_requires (void); +match gfc_match_omp_scope (void); match gfc_match_omp_scan (void); match gfc_match_omp_sections (void); match gfc_match_omp_simd (void); @@ -187,12 +204,14 @@ match gfc_match_omp_target_exit_data (void); match gfc_match_omp_target_parallel (void); match gfc_match_omp_target_parallel_do (void); match gfc_match_omp_target_parallel_do_simd (void); +match gfc_match_omp_target_parallel_loop (void); match gfc_match_omp_target_simd (void); match gfc_match_omp_target_teams (void); match gfc_match_omp_target_teams_distribute (void); match gfc_match_omp_target_teams_distribute_parallel_do (void); match gfc_match_omp_target_teams_distribute_parallel_do_simd (void); match gfc_match_omp_target_teams_distribute_simd (void); +match gfc_match_omp_target_teams_loop (void); match gfc_match_omp_target_update (void); match gfc_match_omp_task (void); match gfc_match_omp_taskgroup (void); @@ -205,6 +224,7 @@ match gfc_match_omp_teams_distribute (void); match gfc_match_omp_teams_distribute_parallel_do (void); match gfc_match_omp_teams_distribute_parallel_do_simd (void); match gfc_match_omp_teams_distribute_simd (void); +match gfc_match_omp_teams_loop (void); match gfc_match_omp_threadprivate (void); match gfc_match_omp_workshare (void); match gfc_match_omp_end_critical (void); diff --git a/gcc/fortran/misc.c b/gcc/fortran/misc.c index 8a96243..3d449ae1 100644 --- a/gcc/fortran/misc.c +++ b/gcc/fortran/misc.c @@ -124,8 +124,10 @@ gfc_basic_typename (bt type) const char * gfc_typename (gfc_typespec *ts, bool for_hash) { - static char buffer1[GFC_MAX_SYMBOL_LEN + 7]; /* 7 for "TYPE()" + '\0'. */ - static char buffer2[GFC_MAX_SYMBOL_LEN + 7]; + /* Need to add sufficient padding for "TYPE()" + '\0', "UNION()" + '\0', + or "CLASS()" + '\0'. */ + static char buffer1[GFC_MAX_SYMBOL_LEN + 8]; + static char buffer2[GFC_MAX_SYMBOL_LEN + 8]; static int flag = 0; char *buffer; gfc_typespec *ts1; diff --git a/gcc/fortran/module.c b/gcc/fortran/module.c index 4db0a3a..1804066 100644 --- a/gcc/fortran/module.c +++ b/gcc/fortran/module.c @@ -2088,6 +2088,7 @@ enum ab_attribute AB_PDT_TEMPLATE, AB_PDT_ARRAY, AB_PDT_STRING, AB_OACC_ROUTINE_LOP_GANG, AB_OACC_ROUTINE_LOP_WORKER, AB_OACC_ROUTINE_LOP_VECTOR, AB_OACC_ROUTINE_LOP_SEQ, + AB_OACC_ROUTINE_NOHOST, AB_OMP_REQ_REVERSE_OFFLOAD, AB_OMP_REQ_UNIFIED_ADDRESS, AB_OMP_REQ_UNIFIED_SHARED_MEMORY, AB_OMP_REQ_DYNAMIC_ALLOCATORS, AB_OMP_REQ_MEM_ORDER_SEQ_CST, AB_OMP_REQ_MEM_ORDER_ACQ_REL, @@ -2166,6 +2167,7 @@ static const mstring attr_bits[] = minit ("OACC_ROUTINE_LOP_WORKER", AB_OACC_ROUTINE_LOP_WORKER), minit ("OACC_ROUTINE_LOP_VECTOR", AB_OACC_ROUTINE_LOP_VECTOR), minit ("OACC_ROUTINE_LOP_SEQ", AB_OACC_ROUTINE_LOP_SEQ), + minit ("OACC_ROUTINE_NOHOST", AB_OACC_ROUTINE_NOHOST), minit ("OMP_REQ_REVERSE_OFFLOAD", AB_OMP_REQ_REVERSE_OFFLOAD), minit ("OMP_REQ_UNIFIED_ADDRESS", AB_OMP_REQ_UNIFIED_ADDRESS), minit ("OMP_REQ_UNIFIED_SHARED_MEMORY", AB_OMP_REQ_UNIFIED_SHARED_MEMORY), @@ -2420,6 +2422,8 @@ mio_symbol_attribute (symbol_attribute *attr) default: gcc_unreachable (); } + if (attr->oacc_routine_nohost) + MIO_NAME (ab_attribute) (AB_OACC_ROUTINE_NOHOST, attr_bits); if (attr->flavor == FL_MODULE && gfc_current_ns->omp_requires) { @@ -2682,6 +2686,9 @@ mio_symbol_attribute (symbol_attribute *attr) verify_OACC_ROUTINE_LOP_NONE (attr->oacc_routine_lop); attr->oacc_routine_lop = OACC_ROUTINE_LOP_SEQ; break; + case AB_OACC_ROUTINE_NOHOST: + attr->oacc_routine_nohost = 1; + break; case AB_OMP_REQ_REVERSE_OFFLOAD: gfc_omp_requires_add_clause (OMP_REQ_REVERSE_OFFLOAD, "reverse_offload", @@ -5029,7 +5036,7 @@ load_omp_udrs (void) mio_pool_string (&name); gfc_clear_ts (&ts); mio_typespec (&ts); - if (gfc_str_startswith (name, "operator ")) + if (startswith (name, "operator ")) { const char *p = name + sizeof ("operator ") - 1; if (strcmp (p, "+") == 0) @@ -5477,8 +5484,8 @@ read_module (void) /* Exception: Always import vtabs & vtypes. */ if (p == NULL && name[0] == '_' - && (gfc_str_startswith (name, "__vtab_") - || gfc_str_startswith (name, "__vtype_"))) + && (startswith (name, "__vtab_") + || startswith (name, "__vtype_"))) p = name; /* Skip symtree nodes not in an ONLY clause, unless there @@ -5563,8 +5570,8 @@ read_module (void) sym->attr.use_rename = 1; if (name[0] != '_' - || (!gfc_str_startswith (name, "__vtab_") - && !gfc_str_startswith (name, "__vtype_"))) + || (!startswith (name, "__vtab_") + && !startswith (name, "__vtype_"))) sym->attr.use_only = only_flag; /* Store the symtree pointing to this symbol. */ @@ -6218,6 +6225,17 @@ write_symtree (gfc_symtree *st) if (check_unique_name (st->name)) return; + /* From F2003 onwards, intrinsic procedures are no longer subject to + the restriction, "that an elemental intrinsic function here be of + type integer or character and each argument must be an initialization + expr of type integer or character" is lifted so that intrinsic + procedures can be over-ridden. This requires that the intrinsic + symbol not appear in the module file, thereby preventing ambiguity + when USEd. */ + if (strcmp (sym->module, "(intrinsic)") == 0 + && (gfc_option.allow_std & GFC_STD_F2003)) + return; + p = find_pointer (sym); if (p == NULL) gfc_internal_error ("write_symtree(): Symbol not written"); diff --git a/gcc/fortran/openmp.c b/gcc/fortran/openmp.c index 1f1920c..a64b7f5 100644 --- a/gcc/fortran/openmp.c +++ b/gcc/fortran/openmp.c @@ -25,8 +25,10 @@ along with GCC; see the file COPYING3. If not see #include "arith.h" #include "match.h" #include "parse.h" +#include "constructor.h" #include "diagnostic.h" #include "gomp-constants.h" +#include "target-memory.h" /* For gfc_encode_character. */ /* Match an end of OpenMP directive. End of OpenMP directive is optional whitespace, followed by '\n' or comment '!'. */ @@ -103,7 +105,8 @@ gfc_free_omp_clauses (gfc_omp_clauses *c) gfc_free_expr (c->num_workers_expr); gfc_free_expr (c->vector_length_expr); for (i = 0; i < OMP_LIST_NUM; i++) - gfc_free_omp_namelist (c->lists[i]); + gfc_free_omp_namelist (c->lists[i], + i == OMP_LIST_AFFINITY || i == OMP_LIST_DEPEND); gfc_free_expr_list (c->wait_list); gfc_free_expr_list (c->tile_list); free (CONST_CAST (char *, c->critical_name)); @@ -261,6 +264,7 @@ gfc_match_omp_variable_list (const char *str, gfc_omp_namelist **list, case MATCH_YES: gfc_expr *expr; expr = NULL; + gfc_gobble_whitespace (); if ((allow_sections && gfc_peek_ascii_char () == '(') || (allow_derived && gfc_peek_ascii_char () == '%')) { @@ -354,7 +358,7 @@ syntax: gfc_error ("Syntax error in OpenMP variable list at %C"); cleanup: - gfc_free_omp_namelist (head); + gfc_free_omp_namelist (head, false); gfc_current_locus = old_loc; return MATCH_ERROR; } @@ -444,7 +448,7 @@ syntax: gfc_error ("Syntax error in OpenMP variable list at %C"); cleanup: - gfc_free_omp_namelist (head); + gfc_free_omp_namelist (head, false); gfc_current_locus = old_loc; return MATCH_ERROR; } @@ -551,7 +555,7 @@ syntax: gfc_error ("Syntax error in OpenMP DEPEND SINK list at %C"); cleanup: - gfc_free_omp_namelist (head); + gfc_free_omp_namelist (head, false); gfc_current_locus = old_loc; return MATCH_ERROR; } @@ -842,6 +846,12 @@ enum omp_mask1 OMP_CLAUSE_CAPTURE, /* OpenMP 5.0. */ OMP_CLAUSE_MEMORDER, /* OpenMP 5.0. */ OMP_CLAUSE_DETACH, /* OpenMP 5.0. */ + OMP_CLAUSE_AFFINITY, /* OpenMP 5.0. */ + OMP_CLAUSE_BIND, /* OpenMP 5.0. */ + OMP_CLAUSE_FILTER, /* OpenMP 5.1. */ + OMP_CLAUSE_AT, /* OpenMP 5.1. */ + OMP_CLAUSE_MESSAGE, /* OpenMP 5.1. */ + OMP_CLAUSE_SEVERITY, /* OpenMP 5.1. */ OMP_CLAUSE_NOWAIT, /* This must come last. */ OMP_MASK1_LAST @@ -875,6 +885,7 @@ enum omp_mask2 OMP_CLAUSE_IF_PRESENT, OMP_CLAUSE_FINALIZE, OMP_CLAUSE_ATTACH, + OMP_CLAUSE_NOHOST, /* This must come last. */ OMP_MASK2_LAST }; @@ -995,6 +1006,132 @@ gfc_match_omp_map_clause (gfc_omp_namelist **list, gfc_omp_map_op map_op, return false; } +static match +gfc_match_iterator (gfc_namespace **ns, bool permit_var) +{ + locus old_loc = gfc_current_locus; + + if (gfc_match ("iterator ( ") != MATCH_YES) + return MATCH_NO; + + gfc_typespec ts; + gfc_symbol *last = NULL; + gfc_expr *begin, *end, *step; + *ns = gfc_build_block_ns (gfc_current_ns); + char name[GFC_MAX_SYMBOL_LEN + 1]; + while (true) + { + locus prev_loc = gfc_current_locus; + if (gfc_match_type_spec (&ts) == MATCH_YES + && gfc_match (" :: ") == MATCH_YES) + { + if (ts.type != BT_INTEGER) + { + gfc_error ("Expected INTEGER type at %L", &prev_loc); + return MATCH_ERROR; + } + permit_var = false; + } + else + { + ts.type = BT_INTEGER; + ts.kind = gfc_default_integer_kind; + gfc_current_locus = prev_loc; + } + prev_loc = gfc_current_locus; + if (gfc_match_name (name) != MATCH_YES) + { + gfc_error ("Expected identifier at %C"); + goto failed; + } + if (gfc_find_symtree ((*ns)->sym_root, name)) + { + gfc_error ("Same identifier %qs specified again at %C", name); + goto failed; + } + + gfc_symbol *sym = gfc_new_symbol (name, *ns); + if (last) + last->tlink = sym; + else + (*ns)->proc_name = sym; + last = sym; + sym->declared_at = prev_loc; + sym->ts = ts; + sym->attr.flavor = FL_VARIABLE; + sym->attr.artificial = 1; + sym->attr.referenced = 1; + sym->refs++; + gfc_symtree *st = gfc_new_symtree (&(*ns)->sym_root, name); + st->n.sym = sym; + + prev_loc = gfc_current_locus; + if (gfc_match (" = ") != MATCH_YES) + goto failed; + permit_var = false; + begin = end = step = NULL; + if (gfc_match ("%e : ", &begin) != MATCH_YES + || gfc_match ("%e ", &end) != MATCH_YES) + { + gfc_error ("Expected range-specification at %C"); + gfc_free_expr (begin); + gfc_free_expr (end); + return MATCH_ERROR; + } + if (':' == gfc_peek_ascii_char ()) + { + step = gfc_get_expr (); + if (gfc_match (": %e ", &step) != MATCH_YES) + { + gfc_free_expr (begin); + gfc_free_expr (end); + gfc_free_expr (step); + goto failed; + } + } + + gfc_expr *e = gfc_get_expr (); + e->where = prev_loc; + e->expr_type = EXPR_ARRAY; + e->ts = ts; + e->rank = 1; + e->shape = gfc_get_shape (1); + mpz_init_set_ui (e->shape[0], step ? 3 : 2); + gfc_constructor_append_expr (&e->value.constructor, begin, &begin->where); + gfc_constructor_append_expr (&e->value.constructor, end, &end->where); + if (step) + gfc_constructor_append_expr (&e->value.constructor, step, &step->where); + sym->value = e; + + if (gfc_match (") ") == MATCH_YES) + break; + if (gfc_match (", ") != MATCH_YES) + goto failed; + } + return MATCH_YES; + +failed: + gfc_namespace *prev_ns = NULL; + for (gfc_namespace *it = gfc_current_ns->contained; it; it = it->sibling) + { + if (it == *ns) + { + if (prev_ns) + prev_ns->sibling = it->sibling; + else + gfc_current_ns->contained = it->sibling; + gfc_free_namespace (it); + break; + } + prev_ns = it; + } + *ns = NULL; + if (!permit_var) + return MATCH_ERROR; + gfc_current_locus = old_loc; + return MATCH_NO; +} + /* reduction ( reduction-modifier, reduction-operator : variable-list ) in_reduction ( reduction-operator : variable-list ) task_reduction ( reduction-operator : variable-list ) */ @@ -1137,7 +1274,7 @@ gfc_match_omp_clause_reduction (char pc, gfc_omp_clauses *c, bool openacc, *head = NULL; gfc_error_now ("!$OMP DECLARE REDUCTION %s not found at %L", buffer, &old_loc); - gfc_free_omp_namelist (n); + gfc_free_omp_namelist (n, false); } else for (n = *head; n; n = n->next) @@ -1145,13 +1282,71 @@ gfc_match_omp_clause_reduction (char pc, gfc_omp_clauses *c, bool openacc, n->u.reduction_op = rop; if (udr) { - n->udr = gfc_get_omp_namelist_udr (); - n->udr->udr = udr; + n->u2.udr = gfc_get_omp_namelist_udr (); + n->u2.udr->udr = udr; } } return MATCH_YES; } + +/* Match with duplicate check. Matches 'name'. If expr != NULL, it + then matches '(expr)', otherwise, if open_parens is true, + it matches a ' ( ' after 'name'. + dupl_message requires '%qs %L' - and is used by + gfc_match_dupl_memorder and gfc_match_dupl_atomic. */ + +static match +gfc_match_dupl_check (bool not_dupl, const char *name, bool open_parens = false, + gfc_expr **expr = NULL, const char *dupl_msg = NULL) +{ + match m; + locus old_loc = gfc_current_locus; + if ((m = gfc_match (name)) != MATCH_YES) + return m; + if (!not_dupl) + { + if (dupl_msg) + gfc_error (dupl_msg, name, &old_loc); + else + gfc_error ("Duplicated %qs clause at %L", name, &old_loc); + return MATCH_ERROR; + } + if (open_parens || expr) + { + if (gfc_match (" ( ") != MATCH_YES) + { + gfc_error ("Expected %<(%> after %qs at %C", name); + return MATCH_ERROR; + } + if (expr) + { + if (gfc_match ("%e )", expr) != MATCH_YES) + { + gfc_error ("Invalid expression after %<%s(%> at %C", name); + return MATCH_ERROR; + } + } + } + return MATCH_YES; +} + +static match +gfc_match_dupl_memorder (bool not_dupl, const char *name) +{ + return gfc_match_dupl_check (not_dupl, name, false, NULL, + "Duplicated memory-order clause: unexpected %s " + "clause at %L"); +} + +static match +gfc_match_dupl_atomic (bool not_dupl, const char *name) +{ + return gfc_match_dupl_check (not_dupl, name, false, NULL, + "Duplicated atomic clause: unexpected %s " + "clause at %L"); +} + /* Match OpenMP and OpenACC directive clauses. MASK is a bitmask of clauses that are allowed for a particular directive. */ @@ -1160,6 +1355,7 @@ gfc_match_omp_clauses (gfc_omp_clauses **cp, const omp_mask mask, bool first = true, bool needs_space = true, bool openacc = false) { + bool error = false; gfc_omp_clauses *c = gfc_get_omp_clauses (); locus old_loc; /* Determine whether we're dealing with an OpenACC directive that permits @@ -1185,6 +1381,7 @@ gfc_match_omp_clauses (gfc_omp_clauses **cp, const omp_mask mask, gfc_omp_namelist **head; old_loc = gfc_current_locus; char pc = gfc_peek_ascii_char (); + match m; switch (pc) { case 'a': @@ -1201,7 +1398,7 @@ gfc_match_omp_clauses (gfc_omp_clauses **cp, const omp_mask mask, if (end_colon && gfc_match (" %e )", &alignment) != MATCH_YES) { - gfc_free_omp_namelist (*head); + gfc_free_omp_namelist (*head, false); gfc_current_locus = old_loc; *head = NULL; break; @@ -1214,27 +1411,82 @@ gfc_match_omp_clauses (gfc_omp_clauses **cp, const omp_mask mask, continue; } if ((mask & OMP_CLAUSE_MEMORDER) - && c->memorder == OMP_MEMORDER_UNSET - && gfc_match ("acq_rel") == MATCH_YES) + && (m = gfc_match_dupl_memorder ((c->memorder + == OMP_MEMORDER_UNSET), + "acq_rel")) != MATCH_NO) { + if (m == MATCH_ERROR) + goto error; c->memorder = OMP_MEMORDER_ACQ_REL; needs_space = true; continue; } if ((mask & OMP_CLAUSE_MEMORDER) - && c->memorder == OMP_MEMORDER_UNSET - && gfc_match ("acquire") == MATCH_YES) + && (m = gfc_match_dupl_memorder ((c->memorder + == OMP_MEMORDER_UNSET), + "acquire")) != MATCH_NO) { + if (m == MATCH_ERROR) + goto error; c->memorder = OMP_MEMORDER_ACQUIRE; needs_space = true; continue; } + if ((mask & OMP_CLAUSE_AFFINITY) + && gfc_match ("affinity ( ") == MATCH_YES) + { + gfc_namespace *ns_iter = NULL, *ns_curr = gfc_current_ns; + m = gfc_match_iterator (&ns_iter, true); + if (m == MATCH_ERROR) + break; + if (m == MATCH_YES && gfc_match (" : ") != MATCH_YES) + { + gfc_error ("Expected %<:%> at %C"); + break; + } + if (ns_iter) + gfc_current_ns = ns_iter; + head = NULL; + m = gfc_match_omp_variable_list ("", &c->lists[OMP_LIST_AFFINITY], + false, NULL, &head, true); + gfc_current_ns = ns_curr; + if (m == MATCH_ERROR) + break; + if (ns_iter) + { + for (gfc_omp_namelist *n = *head; n; n = n->next) + { + n->u2.ns = ns_iter; + ns_iter->refs++; + } + } + continue; + } + if ((mask & OMP_CLAUSE_AT) + && (m = gfc_match_dupl_check (c->at == OMP_AT_UNSET, "at", true)) + != MATCH_NO) + { + if (m == MATCH_ERROR) + goto error; + if (gfc_match ("compilation )") == MATCH_YES) + c->at = OMP_AT_COMPILATION; + else if (gfc_match ("execution )") == MATCH_YES) + c->at = OMP_AT_EXECUTION; + else + { + gfc_error ("Expected COMPILATION or EXECUTION in AT clause " + "at %C"); + goto error; + } + continue; + } if ((mask & OMP_CLAUSE_ASYNC) - && !c->async - && gfc_match ("async") == MATCH_YES) + && (m = gfc_match_dupl_check (!c->async, "async")) != MATCH_NO) { + if (m == MATCH_ERROR) + goto error; c->async = true; - match m = gfc_match (" ( %e )", &c->async_expr); + m = gfc_match (" ( %e )", &c->async_expr); if (m == MATCH_ERROR) { gfc_current_locus = old_loc; @@ -1252,9 +1504,11 @@ gfc_match_omp_clauses (gfc_omp_clauses **cp, const omp_mask mask, continue; } if ((mask & OMP_CLAUSE_AUTO) - && !c->par_auto - && gfc_match ("auto") == MATCH_YES) + && (m = gfc_match_dupl_check (!c->par_auto, "auto")) + != MATCH_NO) { + if (m == MATCH_ERROR) + goto error; c->par_auto = true; needs_space = true; continue; @@ -1266,36 +1520,60 @@ gfc_match_omp_clauses (gfc_omp_clauses **cp, const omp_mask mask, allow_derived)) continue; break; + case 'b': + if ((mask & OMP_CLAUSE_BIND) + && (m = gfc_match_dupl_check (c->bind == OMP_BIND_UNSET, "bind", + true)) != MATCH_NO) + { + if (m == MATCH_ERROR) + goto error; + if (gfc_match ("teams )") == MATCH_YES) + c->bind = OMP_BIND_TEAMS; + else if (gfc_match ("parallel )") == MATCH_YES) + c->bind = OMP_BIND_PARALLEL; + else if (gfc_match ("thread )") == MATCH_YES) + c->bind = OMP_BIND_THREAD; + else + { + gfc_error ("Expected TEAMS, PARALLEL or THREAD as binding in " + "BIND at %C"); + break; + } + continue; + } + break; case 'c': if ((mask & OMP_CLAUSE_CAPTURE) - && !c->capture - && gfc_match ("capture") == MATCH_YES) + && (m = gfc_match_dupl_check (!c->capture, "capture")) + != MATCH_NO) { + if (m == MATCH_ERROR) + goto error; c->capture = true; needs_space = true; continue; } - if ((mask & OMP_CLAUSE_COLLAPSE) - && !c->collapse) + if (mask & OMP_CLAUSE_COLLAPSE) { gfc_expr *cexpr = NULL; - match m = gfc_match ("collapse ( %e )", &cexpr); - - if (m == MATCH_YES) - { - int collapse; - if (gfc_extract_int (cexpr, &collapse, -1)) + if ((m = gfc_match_dupl_check (!c->collapse, "collapse", true, + &cexpr)) != MATCH_NO) + { + int collapse; + if (m == MATCH_ERROR) + goto error; + if (gfc_extract_int (cexpr, &collapse, -1)) + collapse = 1; + else if (collapse <= 0) + { + gfc_error_now ("COLLAPSE clause argument not constant " + "positive integer at %C"); collapse = 1; - else if (collapse <= 0) - { - gfc_error_now ("COLLAPSE clause argument not" - " constant positive integer at %C"); - collapse = 1; - } - c->collapse = collapse; - gfc_free_expr (cexpr); - continue; - } + } + gfc_free_expr (cexpr); + c->collapse = collapse; + continue; + } } if ((mask & OMP_CLAUSE_COPY) && gfc_match ("copy ( ") == MATCH_YES @@ -1335,33 +1613,125 @@ gfc_match_omp_clauses (gfc_omp_clauses **cp, const omp_mask mask, continue; break; case 'd': + if ((mask & OMP_CLAUSE_DEFAULTMAP) + && gfc_match ("defaultmap ( ") == MATCH_YES) + { + enum gfc_omp_defaultmap behavior; + gfc_omp_defaultmap_category category + = OMP_DEFAULTMAP_CAT_UNCATEGORIZED; + if (gfc_match ("alloc ") == MATCH_YES) + behavior = OMP_DEFAULTMAP_ALLOC; + else if (gfc_match ("tofrom ") == MATCH_YES) + behavior = OMP_DEFAULTMAP_TOFROM; + else if (gfc_match ("to ") == MATCH_YES) + behavior = OMP_DEFAULTMAP_TO; + else if (gfc_match ("from ") == MATCH_YES) + behavior = OMP_DEFAULTMAP_FROM; + else if (gfc_match ("firstprivate ") == MATCH_YES) + behavior = OMP_DEFAULTMAP_FIRSTPRIVATE; + else if (gfc_match ("none ") == MATCH_YES) + behavior = OMP_DEFAULTMAP_NONE; + else if (gfc_match ("default ") == MATCH_YES) + behavior = OMP_DEFAULTMAP_DEFAULT; + else + { + gfc_error ("Expected ALLOC, TO, FROM, TOFROM, FIRSTPRIVATE, " + "NONE or DEFAULT at %C"); + break; + } + if (')' == gfc_peek_ascii_char ()) + ; + else if (gfc_match (": ") != MATCH_YES) + break; + else + { + if (gfc_match ("scalar ") == MATCH_YES) + category = OMP_DEFAULTMAP_CAT_SCALAR; + else if (gfc_match ("aggregate ") == MATCH_YES) + category = OMP_DEFAULTMAP_CAT_AGGREGATE; + else if (gfc_match ("allocatable ") == MATCH_YES) + category = OMP_DEFAULTMAP_CAT_ALLOCATABLE; + else if (gfc_match ("pointer ") == MATCH_YES) + category = OMP_DEFAULTMAP_CAT_POINTER; + else + { + gfc_error ("Expected SCALAR, AGGREGATE, ALLOCATABLE or " + "POINTER at %C"); + break; + } + } + for (int i = 0; i < OMP_DEFAULTMAP_CAT_NUM; ++i) + { + if (i != category + && category != OMP_DEFAULTMAP_CAT_UNCATEGORIZED) + continue; + if (c->defaultmap[i] != OMP_DEFAULTMAP_UNSET) + { + const char *pcategory = NULL; + switch (i) + { + case OMP_DEFAULTMAP_CAT_UNCATEGORIZED: break; + case OMP_DEFAULTMAP_CAT_SCALAR: pcategory = "SCALAR"; break; + case OMP_DEFAULTMAP_CAT_AGGREGATE: + pcategory = "AGGREGATE"; + break; + case OMP_DEFAULTMAP_CAT_ALLOCATABLE: + pcategory = "ALLOCATABLE"; + break; + case OMP_DEFAULTMAP_CAT_POINTER: + pcategory = "POINTER"; + break; + default: gcc_unreachable (); + } + if (i == OMP_DEFAULTMAP_CAT_UNCATEGORIZED) + gfc_error ("DEFAULTMAP at %C but prior DEFAULTMAP with " + "unspecified category"); + else + gfc_error ("DEFAULTMAP at %C but prior DEFAULTMAP for " + "category %s", pcategory); + goto error; + } + } + c->defaultmap[category] = behavior; + if (gfc_match (")") != MATCH_YES) + break; + continue; + } if ((mask & OMP_CLAUSE_DEFAULT) - && c->default_sharing == OMP_DEFAULT_UNKNOWN) + && (m = gfc_match_dupl_check (c->default_sharing + == OMP_DEFAULT_UNKNOWN, "default", + true)) != MATCH_NO) { - if (gfc_match ("default ( none )") == MATCH_YES) + if (m == MATCH_ERROR) + goto error; + if (gfc_match ("none") == MATCH_YES) c->default_sharing = OMP_DEFAULT_NONE; else if (openacc) { - if (gfc_match ("default ( present )") == MATCH_YES) + if (gfc_match ("present") == MATCH_YES) c->default_sharing = OMP_DEFAULT_PRESENT; } else { - if (gfc_match ("default ( firstprivate )") == MATCH_YES) + if (gfc_match ("firstprivate") == MATCH_YES) c->default_sharing = OMP_DEFAULT_FIRSTPRIVATE; - else if (gfc_match ("default ( private )") == MATCH_YES) + else if (gfc_match ("private") == MATCH_YES) c->default_sharing = OMP_DEFAULT_PRIVATE; - else if (gfc_match ("default ( shared )") == MATCH_YES) + else if (gfc_match ("shared") == MATCH_YES) c->default_sharing = OMP_DEFAULT_SHARED; } - if (c->default_sharing != OMP_DEFAULT_UNKNOWN) - continue; - } - if ((mask & OMP_CLAUSE_DEFAULTMAP) - && !c->defaultmap - && gfc_match ("defaultmap ( tofrom : scalar )") == MATCH_YES) - { - c->defaultmap = true; + if (c->default_sharing == OMP_DEFAULT_UNKNOWN) + { + if (openacc) + gfc_error ("Expected NONE or PRESENT in DEFAULT clause " + "at %C"); + else + gfc_error ("Expected NONE, FIRSTPRIVATE, PRIVATE or SHARED " + "in DEFAULT clause at %C"); + goto error; + } + if (gfc_match (" )") != MATCH_YES) + goto error; continue; } if ((mask & OMP_CLAUSE_DELETE) @@ -1373,7 +1743,13 @@ gfc_match_omp_clauses (gfc_omp_clauses **cp, const omp_mask mask, if ((mask & OMP_CLAUSE_DEPEND) && gfc_match ("depend ( ") == MATCH_YES) { - match m = MATCH_YES; + gfc_namespace *ns_iter = NULL, *ns_curr = gfc_current_ns; + match m_it = gfc_match_iterator (&ns_iter, false); + if (m_it == MATCH_ERROR) + break; + if (m_it == MATCH_YES && gfc_match (" , ") != MATCH_YES) + break; + m = MATCH_YES; gfc_omp_depend_op depend_op = OMP_DEPEND_OUT; if (gfc_match ("inout") == MATCH_YES) depend_op = OMP_DEPEND_INOUT; @@ -1381,14 +1757,31 @@ gfc_match_omp_clauses (gfc_omp_clauses **cp, const omp_mask mask, depend_op = OMP_DEPEND_IN; else if (gfc_match ("out") == MATCH_YES) depend_op = OMP_DEPEND_OUT; + else if (gfc_match ("mutexinoutset") == MATCH_YES) + depend_op = OMP_DEPEND_MUTEXINOUTSET; + else if (gfc_match ("depobj") == MATCH_YES) + depend_op = OMP_DEPEND_DEPOBJ; else if (!c->depend_source && gfc_match ("source )") == MATCH_YES) { + if (m_it == MATCH_YES) + { + gfc_error ("ITERATOR may not be combined with SOURCE " + "at %C"); + gfc_free_omp_clauses (c); + return MATCH_ERROR; + } c->depend_source = true; continue; } else if (gfc_match ("sink : ") == MATCH_YES) { + if (m_it == MATCH_YES) + { + gfc_error ("ITERATOR may not be combined with SINK " + "at %C"); + break; + } if (gfc_match_omp_depend_sink (&c->lists[OMP_LIST_DEPEND]) == MATCH_YES) continue; @@ -1397,19 +1790,26 @@ gfc_match_omp_clauses (gfc_omp_clauses **cp, const omp_mask mask, else m = MATCH_NO; head = NULL; - if (m == MATCH_YES - && gfc_match_omp_variable_list (" : ", - &c->lists[OMP_LIST_DEPEND], - false, NULL, &head, - true) == MATCH_YES) + if (ns_iter) + gfc_current_ns = ns_iter; + if (m == MATCH_YES) + m = gfc_match_omp_variable_list (" : ", + &c->lists[OMP_LIST_DEPEND], + false, NULL, &head, true); + gfc_current_ns = ns_curr; + if (m == MATCH_YES) { gfc_omp_namelist *n; for (n = *head; n; n = n->next) - n->u.depend_op = depend_op; + { + n->u.depend_op = depend_op; + n->u2.ns = ns_iter; + if (ns_iter) + ns_iter->refs++; + } continue; } - else - gfc_current_locus = old_loc; + break; } if ((mask & OMP_CLAUSE_DETACH) && !openacc @@ -1425,9 +1825,56 @@ gfc_match_omp_clauses (gfc_omp_clauses **cp, const omp_mask mask, continue; if ((mask & OMP_CLAUSE_DEVICE) && !openacc - && c->device == NULL - && gfc_match ("device ( %e )", &c->device) == MATCH_YES) - continue; + && ((m = gfc_match_dupl_check (!c->device, "device", true)) + != MATCH_NO)) + { + if (m == MATCH_ERROR) + goto error; + c->ancestor = false; + if (gfc_match ("device_num : ") == MATCH_YES) + { + if (gfc_match ("%e )", &c->device) != MATCH_YES) + { + gfc_error ("Expected integer expression at %C"); + break; + } + } + else if (gfc_match ("ancestor : ") == MATCH_YES) + { + c->ancestor = true; + if (!(gfc_current_ns->omp_requires & OMP_REQ_REVERSE_OFFLOAD)) + { + gfc_error ("%<ancestor%> device modifier not " + "preceded by %<requires%> directive " + "with %<reverse_offload%> clause at %C"); + break; + } + locus old_loc2 = gfc_current_locus; + if (gfc_match ("%e )", &c->device) == MATCH_YES) + { + int device = 0; + if (!gfc_extract_int (c->device, &device) && device != 1) + { + gfc_current_locus = old_loc2; + gfc_error ("the %<device%> clause expression must " + "evaluate to %<1%> at %C"); + break; + } + } + else + { + gfc_error ("Expected integer expression at %C"); + break; + } + } + else if (gfc_match ("%e )", &c->device) != MATCH_YES) + { + gfc_error ("Expected integer expression or a single device-" + "modifier %<device_num%> or %<ancestor%> at %C"); + break; + } + continue; + } if ((mask & OMP_CLAUSE_DEVICE) && openacc && gfc_match ("device ( ") == MATCH_YES @@ -1468,7 +1915,7 @@ gfc_match_omp_clauses (gfc_omp_clauses **cp, const omp_mask mask, && c->dist_sched_kind == OMP_SCHED_NONE && gfc_match ("dist_schedule ( static") == MATCH_YES) { - match m = MATCH_NO; + m = MATCH_NO; c->dist_sched_kind = OMP_SCHED_STATIC; m = gfc_match (" , %e )", &c->dist_chunk_size); if (m != MATCH_YES) @@ -1483,14 +1930,28 @@ gfc_match_omp_clauses (gfc_omp_clauses **cp, const omp_mask mask, } break; case 'f': + if ((mask & OMP_CLAUSE_FILTER) + && (m = gfc_match_dupl_check (!c->filter, "filter", true, + &c->filter)) != MATCH_NO) + { + if (m == MATCH_ERROR) + goto error; + continue; + } if ((mask & OMP_CLAUSE_FINAL) - && c->final_expr == NULL - && gfc_match ("final ( %e )", &c->final_expr) == MATCH_YES) - continue; + && (m = gfc_match_dupl_check (!c->final_expr, "final", true, + &c->final_expr)) != MATCH_NO) + { + if (m == MATCH_ERROR) + goto error; + continue; + } if ((mask & OMP_CLAUSE_FINALIZE) - && !c->finalize - && gfc_match ("finalize") == MATCH_YES) + && (m = gfc_match_dupl_check (!c->finalize, "finalize")) + != MATCH_NO) { + if (m == MATCH_ERROR) + goto error; c->finalize = true; needs_space = true; continue; @@ -1508,11 +1969,12 @@ gfc_match_omp_clauses (gfc_omp_clauses **cp, const omp_mask mask, break; case 'g': if ((mask & OMP_CLAUSE_GANG) - && !c->gang - && gfc_match ("gang") == MATCH_YES) + && (m = gfc_match_dupl_check (!c->gang, "gang")) != MATCH_NO) { + if (m == MATCH_ERROR) + goto error; c->gang = true; - match m = match_oacc_clause_gwv (c, GOMP_DIM_GANG); + m = match_oacc_clause_gwv (c, GOMP_DIM_GANG); if (m == MATCH_ERROR) { gfc_current_locus = old_loc; @@ -1523,15 +1985,27 @@ gfc_match_omp_clauses (gfc_omp_clauses **cp, const omp_mask mask, continue; } if ((mask & OMP_CLAUSE_GRAINSIZE) - && c->grainsize == NULL - && gfc_match ("grainsize ( %e )", &c->grainsize) == MATCH_YES) - continue; + && (m = gfc_match_dupl_check (!c->grainsize, "grainsize", true)) + != MATCH_NO) + { + if (m == MATCH_ERROR) + goto error; + if (gfc_match ("strict : ") == MATCH_YES) + c->grainsize_strict = true; + if (gfc_match (" %e )", &c->grainsize) != MATCH_YES) + goto error; + continue; + } break; case 'h': if ((mask & OMP_CLAUSE_HINT) - && c->hint == NULL - && gfc_match ("hint ( %e )", &c->hint) == MATCH_YES) - continue; + && (m = gfc_match_dupl_check (!c->hint, "hint", true, &c->hint)) + != MATCH_NO) + { + if (m == MATCH_ERROR) + goto error; + continue; + } if ((mask & OMP_CLAUSE_HOST_SELF) && gfc_match ("host ( ") == MATCH_YES && gfc_match_omp_map_clause (&c->lists[OMP_LIST_MAP], @@ -1540,24 +2014,36 @@ gfc_match_omp_clauses (gfc_omp_clauses **cp, const omp_mask mask, continue; break; case 'i': + if ((mask & OMP_CLAUSE_IF_PRESENT) + && (m = gfc_match_dupl_check (!c->if_present, "if_present")) + != MATCH_NO) + { + if (m == MATCH_ERROR) + goto error; + c->if_present = true; + needs_space = true; + continue; + } if ((mask & OMP_CLAUSE_IF) - && c->if_expr == NULL - && gfc_match ("if ( ") == MATCH_YES) + && (m = gfc_match_dupl_check (!c->if_expr, "if", true)) + != MATCH_NO) { + if (m == MATCH_ERROR) + goto error; if (!openacc) { /* This should match the enum gfc_omp_if_kind order. */ static const char *ifs[OMP_IF_LAST] = { - " cancel : %e )", - " parallel : %e )", - " simd : %e )", - " task : %e )", - " taskloop : %e )", - " target : %e )", - " target data : %e )", - " target update : %e )", - " target enter data : %e )", - " target exit data : %e )" }; + "cancel : %e )", + "parallel : %e )", + "simd : %e )", + "task : %e )", + "taskloop : %e )", + "target : %e )", + "target data : %e )", + "target update : %e )", + "target enter data : %e )", + "target exit data : %e )" }; int i; for (i = 0; i < OMP_IF_LAST; i++) if (c->if_exprs[i] == NULL @@ -1566,34 +2052,29 @@ gfc_match_omp_clauses (gfc_omp_clauses **cp, const omp_mask mask, if (i < OMP_IF_LAST) continue; } - if (gfc_match ("%e )", &c->if_expr) == MATCH_YES) + if (gfc_match (" %e )", &c->if_expr) == MATCH_YES) continue; - gfc_current_locus = old_loc; - } - if ((mask & OMP_CLAUSE_IF_PRESENT) - && !c->if_present - && gfc_match ("if_present") == MATCH_YES) - { - c->if_present = true; - needs_space = true; - continue; + goto error; } if ((mask & OMP_CLAUSE_IN_REDUCTION) && gfc_match_omp_clause_reduction (pc, c, openacc, allow_derived) == MATCH_YES) continue; if ((mask & OMP_CLAUSE_INBRANCH) - && !c->inbranch - && !c->notinbranch - && gfc_match ("inbranch") == MATCH_YES) + && (m = gfc_match_dupl_check (!c->inbranch && !c->notinbranch, + "inbranch")) != MATCH_NO) { + if (m == MATCH_ERROR) + goto error; c->inbranch = needs_space = true; continue; } if ((mask & OMP_CLAUSE_INDEPENDENT) - && !c->independent - && gfc_match ("independent") == MATCH_YES) + && (m = gfc_match_dupl_check (!c->independent, "independent")) + != MATCH_NO) { + if (m == MATCH_ERROR) + goto error; c->independent = true; needs_space = true; continue; @@ -1661,7 +2142,7 @@ gfc_match_omp_clauses (gfc_omp_clauses **cp, const omp_mask mask, end_colon = true; else if (gfc_match (" )") != MATCH_YES) { - gfc_free_omp_namelist (*head); + gfc_free_omp_namelist (*head, false); gfc_current_locus = old_loc; *head = NULL; break; @@ -1669,7 +2150,7 @@ gfc_match_omp_clauses (gfc_omp_clauses **cp, const omp_mask mask, } if (end_colon && gfc_match (" %e )", &step) != MATCH_YES) { - gfc_free_omp_namelist (*head); + gfc_free_omp_namelist (*head, false); gfc_current_locus = old_loc; *head = NULL; break; @@ -1705,27 +2186,62 @@ gfc_match_omp_clauses (gfc_omp_clauses **cp, const omp_mask mask, && gfc_match ("map ( ") == MATCH_YES) { locus old_loc2 = gfc_current_locus; - bool always = false; + int always_modifier = 0; + int close_modifier = 0; + locus second_always_locus = old_loc2; + locus second_close_locus = old_loc2; + + for (;;) + { + locus current_locus = gfc_current_locus; + if (gfc_match ("always ") == MATCH_YES) + { + if (always_modifier++ == 1) + second_always_locus = current_locus; + } + else if (gfc_match ("close ") == MATCH_YES) + { + if (close_modifier++ == 1) + second_close_locus = current_locus; + } + else + break; + gfc_match (", "); + } + gfc_omp_map_op map_op = OMP_MAP_TOFROM; - if (gfc_match ("always , ") == MATCH_YES) - always = true; if (gfc_match ("alloc : ") == MATCH_YES) map_op = OMP_MAP_ALLOC; else if (gfc_match ("tofrom : ") == MATCH_YES) - map_op = always ? OMP_MAP_ALWAYS_TOFROM : OMP_MAP_TOFROM; + map_op = always_modifier ? OMP_MAP_ALWAYS_TOFROM : OMP_MAP_TOFROM; else if (gfc_match ("to : ") == MATCH_YES) - map_op = always ? OMP_MAP_ALWAYS_TO : OMP_MAP_TO; + map_op = always_modifier ? OMP_MAP_ALWAYS_TO : OMP_MAP_TO; else if (gfc_match ("from : ") == MATCH_YES) - map_op = always ? OMP_MAP_ALWAYS_FROM : OMP_MAP_FROM; + map_op = always_modifier ? OMP_MAP_ALWAYS_FROM : OMP_MAP_FROM; else if (gfc_match ("release : ") == MATCH_YES) map_op = OMP_MAP_RELEASE; else if (gfc_match ("delete : ") == MATCH_YES) map_op = OMP_MAP_DELETE; - else if (always) + else { gfc_current_locus = old_loc2; - always = false; + always_modifier = 0; + close_modifier = 0; + } + + if (always_modifier > 1) + { + gfc_error ("too many %<always%> modifiers at %L", + &second_always_locus); + break; + } + if (close_modifier > 1) + { + gfc_error ("too many %<close%> modifiers at %L", + &second_close_locus); + break; } + head = NULL; if (gfc_match_omp_variable_list ("", &c->lists[OMP_LIST_MAP], false, NULL, &head, @@ -1736,15 +2252,26 @@ gfc_match_omp_clauses (gfc_omp_clauses **cp, const omp_mask mask, n->u.map_op = map_op; continue; } - else - gfc_current_locus = old_loc; + gfc_current_locus = old_loc; + break; } - if ((mask & OMP_CLAUSE_MERGEABLE) && !c->mergeable - && gfc_match ("mergeable") == MATCH_YES) + if ((mask & OMP_CLAUSE_MERGEABLE) + && (m = gfc_match_dupl_check (!c->mergeable, "mergeable")) + != MATCH_NO) { + if (m == MATCH_ERROR) + goto error; c->mergeable = needs_space = true; continue; } + if ((mask & OMP_CLAUSE_MESSAGE) + && (m = gfc_match_dupl_check (!c->message, "message", true, + &c->message)) != MATCH_NO) + { + if (m == MATCH_ERROR) + goto error; + continue; + } break; case 'n': if ((mask & OMP_CLAUSE_NO_CREATE) @@ -1754,55 +2281,91 @@ gfc_match_omp_clauses (gfc_omp_clauses **cp, const omp_mask mask, allow_derived)) continue; if ((mask & OMP_CLAUSE_NOGROUP) - && !c->nogroup - && gfc_match ("nogroup") == MATCH_YES) + && (m = gfc_match_dupl_check (!c->nogroup, "nogroup")) + != MATCH_NO) { + if (m == MATCH_ERROR) + goto error; c->nogroup = needs_space = true; continue; } + if ((mask & OMP_CLAUSE_NOHOST) + && (m = gfc_match_dupl_check (!c->nohost, "nohost")) != MATCH_NO) + { + if (m == MATCH_ERROR) + goto error; + c->nohost = needs_space = true; + continue; + } if ((mask & OMP_CLAUSE_NOTEMPORAL) && gfc_match_omp_variable_list ("nontemporal (", &c->lists[OMP_LIST_NONTEMPORAL], true) == MATCH_YES) continue; if ((mask & OMP_CLAUSE_NOTINBRANCH) - && !c->notinbranch - && !c->inbranch - && gfc_match ("notinbranch") == MATCH_YES) + && (m = gfc_match_dupl_check (!c->notinbranch && !c->inbranch, + "notinbranch")) != MATCH_NO) { + if (m == MATCH_ERROR) + goto error; c->notinbranch = needs_space = true; continue; } if ((mask & OMP_CLAUSE_NOWAIT) - && !c->nowait - && gfc_match ("nowait") == MATCH_YES) + && (m = gfc_match_dupl_check (!c->nowait, "nowait")) != MATCH_NO) { + if (m == MATCH_ERROR) + goto error; c->nowait = needs_space = true; continue; } if ((mask & OMP_CLAUSE_NUM_GANGS) - && c->num_gangs_expr == NULL - && gfc_match ("num_gangs ( %e )", - &c->num_gangs_expr) == MATCH_YES) - continue; + && (m = gfc_match_dupl_check (!c->num_gangs_expr, "num_gangs", + true)) != MATCH_NO) + { + if (m == MATCH_ERROR) + goto error; + if (gfc_match (" %e )", &c->num_gangs_expr) != MATCH_YES) + goto error; + continue; + } if ((mask & OMP_CLAUSE_NUM_TASKS) - && c->num_tasks == NULL - && gfc_match ("num_tasks ( %e )", &c->num_tasks) == MATCH_YES) - continue; + && (m = gfc_match_dupl_check (!c->num_tasks, "num_tasks", true)) + != MATCH_NO) + { + if (m == MATCH_ERROR) + goto error; + if (gfc_match ("strict : ") == MATCH_YES) + c->num_tasks_strict = true; + if (gfc_match (" %e )", &c->num_tasks) != MATCH_YES) + goto error; + continue; + } if ((mask & OMP_CLAUSE_NUM_TEAMS) - && c->num_teams == NULL - && gfc_match ("num_teams ( %e )", &c->num_teams) == MATCH_YES) - continue; + && (m = gfc_match_dupl_check (!c->num_teams, "num_teams", true, + &c->num_teams)) != MATCH_NO) + { + if (m == MATCH_ERROR) + goto error; + continue; + } if ((mask & OMP_CLAUSE_NUM_THREADS) - && c->num_threads == NULL - && (gfc_match ("num_threads ( %e )", &c->num_threads) - == MATCH_YES)) - continue; + && (m = gfc_match_dupl_check (!c->num_threads, "num_threads", true, + &c->num_threads)) != MATCH_NO) + { + if (m == MATCH_ERROR) + goto error; + continue; + } if ((mask & OMP_CLAUSE_NUM_WORKERS) - && c->num_workers_expr == NULL - && gfc_match ("num_workers ( %e )", - &c->num_workers_expr) == MATCH_YES) - continue; + && (m = gfc_match_dupl_check (!c->num_workers_expr, "num_workers", + true, &c->num_workers_expr)) + != MATCH_NO) + { + if (m == MATCH_ERROR) + goto error; + continue; + } break; case 'o': if ((mask & OMP_CLAUSE_ORDER) @@ -1813,11 +2376,13 @@ gfc_match_omp_clauses (gfc_omp_clauses **cp, const omp_mask mask, continue; } if ((mask & OMP_CLAUSE_ORDERED) - && !c->ordered - && gfc_match ("ordered") == MATCH_YES) + && (m = gfc_match_dupl_check (!c->ordered, "ordered")) + != MATCH_NO) { + if (m == MATCH_ERROR) + goto error; gfc_expr *cexpr = NULL; - match m = gfc_match (" ( %e )", &cexpr); + m = gfc_match (" ( %e )", &cexpr); c->ordered = true; if (m == MATCH_YES) @@ -1889,32 +2454,46 @@ gfc_match_omp_clauses (gfc_omp_clauses **cp, const omp_mask mask, OMP_MAP_ALLOC, true, allow_derived)) continue; if ((mask & OMP_CLAUSE_PRIORITY) - && c->priority == NULL - && gfc_match ("priority ( %e )", &c->priority) == MATCH_YES) - continue; + && (m = gfc_match_dupl_check (!c->priority, "priority", true, + &c->priority)) != MATCH_NO) + { + if (m == MATCH_ERROR) + goto error; + continue; + } if ((mask & OMP_CLAUSE_PRIVATE) && gfc_match_omp_variable_list ("private (", &c->lists[OMP_LIST_PRIVATE], true) == MATCH_YES) continue; if ((mask & OMP_CLAUSE_PROC_BIND) - && c->proc_bind == OMP_PROC_BIND_UNKNOWN) + && (m = gfc_match_dupl_check ((c->proc_bind + == OMP_PROC_BIND_UNKNOWN), + "proc_bind", true)) != MATCH_NO) { - if (gfc_match ("proc_bind ( master )") == MATCH_YES) + if (m == MATCH_ERROR) + goto error; + if (gfc_match ("primary )") == MATCH_YES) + c->proc_bind = OMP_PROC_BIND_PRIMARY; + else if (gfc_match ("master )") == MATCH_YES) c->proc_bind = OMP_PROC_BIND_MASTER; - else if (gfc_match ("proc_bind ( spread )") == MATCH_YES) + else if (gfc_match ("spread )") == MATCH_YES) c->proc_bind = OMP_PROC_BIND_SPREAD; - else if (gfc_match ("proc_bind ( close )") == MATCH_YES) + else if (gfc_match ("close )") == MATCH_YES) c->proc_bind = OMP_PROC_BIND_CLOSE; - if (c->proc_bind != OMP_PROC_BIND_UNKNOWN) - continue; + else + goto error; + continue; } break; case 'r': if ((mask & OMP_CLAUSE_ATOMIC) - && c->atomic_op == GFC_OMP_ATOMIC_UNSET - && gfc_match ("read") == MATCH_YES) + && (m = gfc_match_dupl_atomic ((c->atomic_op + == GFC_OMP_ATOMIC_UNSET), + "read")) != MATCH_NO) { + if (m == MATCH_ERROR) + goto error; c->atomic_op = GFC_OMP_ATOMIC_READ; needs_space = true; continue; @@ -1924,33 +2503,23 @@ gfc_match_omp_clauses (gfc_omp_clauses **cp, const omp_mask mask, allow_derived) == MATCH_YES) continue; if ((mask & OMP_CLAUSE_MEMORDER) - && c->memorder == OMP_MEMORDER_UNSET - && gfc_match ("relaxed") == MATCH_YES) - { - c->memorder = OMP_MEMORDER_RELAXED; - needs_space = true; - continue; - } - if ((mask & OMP_CLAUSE_MEMORDER) - && c->memorder == OMP_MEMORDER_UNSET - && gfc_match ("release") == MATCH_YES) - { - c->memorder = OMP_MEMORDER_RELEASE; - needs_space = true; - continue; - } - if ((mask & OMP_CLAUSE_MEMORDER) - && c->memorder == OMP_MEMORDER_UNSET - && gfc_match ("relaxed") == MATCH_YES) + && (m = gfc_match_dupl_memorder ((c->memorder + == OMP_MEMORDER_UNSET), + "relaxed")) != MATCH_NO) { + if (m == MATCH_ERROR) + goto error; c->memorder = OMP_MEMORDER_RELAXED; needs_space = true; continue; } if ((mask & OMP_CLAUSE_MEMORDER) - && c->memorder == OMP_MEMORDER_UNSET - && gfc_match ("release") == MATCH_YES) + && (m = gfc_match_dupl_memorder ((c->memorder + == OMP_MEMORDER_UNSET), + "release")) != MATCH_NO) { + if (m == MATCH_ERROR) + goto error; c->memorder = OMP_MEMORDER_RELEASE; needs_space = true; continue; @@ -1958,13 +2527,20 @@ gfc_match_omp_clauses (gfc_omp_clauses **cp, const omp_mask mask, break; case 's': if ((mask & OMP_CLAUSE_SAFELEN) - && c->safelen_expr == NULL - && gfc_match ("safelen ( %e )", &c->safelen_expr) == MATCH_YES) - continue; + && (m = gfc_match_dupl_check (!c->safelen_expr, "safelen", + true, &c->safelen_expr)) + != MATCH_NO) + { + if (m == MATCH_ERROR) + goto error; + continue; + } if ((mask & OMP_CLAUSE_SCHEDULE) - && c->sched_kind == OMP_SCHED_NONE - && gfc_match ("schedule ( ") == MATCH_YES) + && (m = gfc_match_dupl_check (c->sched_kind == OMP_SCHED_NONE, + "schedule", true)) != MATCH_NO) { + if (m == MATCH_ERROR) + goto error; int nmodifiers = 0; locus old_loc2 = gfc_current_locus; do @@ -2011,7 +2587,7 @@ gfc_match_omp_clauses (gfc_omp_clauses **cp, const omp_mask mask, c->sched_kind = OMP_SCHED_AUTO; if (c->sched_kind != OMP_SCHED_NONE) { - match m = MATCH_NO; + m = MATCH_NO; if (c->sched_kind != OMP_SCHED_RUNTIME && c->sched_kind != OMP_SCHED_AUTO) m = gfc_match (" , %e )", &c->chunk_size); @@ -2032,17 +2608,21 @@ gfc_match_omp_clauses (gfc_omp_clauses **cp, const omp_mask mask, allow_derived)) continue; if ((mask & OMP_CLAUSE_SEQ) - && !c->seq - && gfc_match ("seq") == MATCH_YES) + && (m = gfc_match_dupl_check (!c->seq, "seq")) != MATCH_NO) { + if (m == MATCH_ERROR) + goto error; c->seq = true; needs_space = true; continue; } if ((mask & OMP_CLAUSE_MEMORDER) - && c->memorder == OMP_MEMORDER_UNSET - && gfc_match ("seq_cst") == MATCH_YES) + && (m = gfc_match_dupl_memorder ((c->memorder + == OMP_MEMORDER_UNSET), + "seq_cst")) != MATCH_NO) { + if (m == MATCH_ERROR) + goto error; c->memorder = OMP_MEMORDER_SEQ_CST; needs_space = true; continue; @@ -2053,16 +2633,39 @@ gfc_match_omp_clauses (gfc_omp_clauses **cp, const omp_mask mask, true) == MATCH_YES) continue; if ((mask & OMP_CLAUSE_SIMDLEN) - && c->simdlen_expr == NULL - && gfc_match ("simdlen ( %e )", &c->simdlen_expr) == MATCH_YES) - continue; + && (m = gfc_match_dupl_check (!c->simdlen_expr, "simdlen", true, + &c->simdlen_expr)) != MATCH_NO) + { + if (m == MATCH_ERROR) + goto error; + continue; + } if ((mask & OMP_CLAUSE_SIMD) - && !c->simd - && gfc_match ("simd") == MATCH_YES) + && (m = gfc_match_dupl_check (!c->simd, "simd")) != MATCH_NO) { + if (m == MATCH_ERROR) + goto error; c->simd = needs_space = true; continue; } + if ((mask & OMP_CLAUSE_SEVERITY) + && (m = gfc_match_dupl_check (!c->severity, "severity", true)) + != MATCH_NO) + { + if (m == MATCH_ERROR) + goto error; + if (gfc_match ("fatal )") == MATCH_YES) + c->severity = OMP_SEVERITY_FATAL; + else if (gfc_match ("warning )") == MATCH_YES) + c->severity = OMP_SEVERITY_WARNING; + else + { + gfc_error ("Expected FATAL or WARNING in SEVERITY clause " + "at %C"); + goto error; + } + continue; + } break; case 't': if ((mask & OMP_CLAUSE_TASK_REDUCTION) @@ -2070,14 +2673,20 @@ gfc_match_omp_clauses (gfc_omp_clauses **cp, const omp_mask mask, allow_derived) == MATCH_YES) continue; if ((mask & OMP_CLAUSE_THREAD_LIMIT) - && c->thread_limit == NULL - && gfc_match ("thread_limit ( %e )", - &c->thread_limit) == MATCH_YES) - continue; + && (m = gfc_match_dupl_check (!c->thread_limit, "thread_limit", + true, &c->thread_limit)) + != MATCH_NO) + { + if (m == MATCH_ERROR) + goto error; + continue; + } if ((mask & OMP_CLAUSE_THREADS) - && !c->threads - && gfc_match ("threads") == MATCH_YES) + && (m = gfc_match_dupl_check (!c->threads, "threads")) + != MATCH_NO) { + if (m == MATCH_ERROR) + goto error; c->threads = needs_space = true; continue; } @@ -2105,16 +2714,20 @@ gfc_match_omp_clauses (gfc_omp_clauses **cp, const omp_mask mask, false) == MATCH_YES) continue; if ((mask & OMP_CLAUSE_UNTIED) - && !c->untied - && gfc_match ("untied") == MATCH_YES) + && (m = gfc_match_dupl_check (!c->untied, "untied")) != MATCH_NO) { + if (m == MATCH_ERROR) + goto error; c->untied = needs_space = true; continue; } if ((mask & OMP_CLAUSE_ATOMIC) - && c->atomic_op == GFC_OMP_ATOMIC_UNSET - && gfc_match ("update") == MATCH_YES) + && (m = gfc_match_dupl_atomic ((c->atomic_op + == GFC_OMP_ATOMIC_UNSET), + "update")) != MATCH_NO) { + if (m == MATCH_ERROR) + goto error; c->atomic_op = GFC_OMP_ATOMIC_UPDATE; needs_space = true; continue; @@ -2139,21 +2752,24 @@ gfc_match_omp_clauses (gfc_omp_clauses **cp, const omp_mask mask, /* VECTOR_LENGTH must be matched before VECTOR, because the latter doesn't unconditionally match '('. */ if ((mask & OMP_CLAUSE_VECTOR_LENGTH) - && c->vector_length_expr == NULL - && (gfc_match ("vector_length ( %e )", &c->vector_length_expr) - == MATCH_YES)) - continue; + && (m = gfc_match_dupl_check (!c->vector_length_expr, + "vector_length", true, + &c->vector_length_expr)) + != MATCH_NO) + { + if (m == MATCH_ERROR) + goto error; + continue; + } if ((mask & OMP_CLAUSE_VECTOR) - && !c->vector - && gfc_match ("vector") == MATCH_YES) + && (m = gfc_match_dupl_check (!c->vector, "vector")) != MATCH_NO) { + if (m == MATCH_ERROR) + goto error; c->vector = true; - match m = match_oacc_clause_gwv (c, GOMP_DIM_VECTOR); + m = match_oacc_clause_gwv (c, GOMP_DIM_VECTOR); if (m == MATCH_ERROR) - { - gfc_current_locus = old_loc; - break; - } + goto error; if (m == MATCH_NO) needs_space = true; continue; @@ -2163,12 +2779,9 @@ gfc_match_omp_clauses (gfc_omp_clauses **cp, const omp_mask mask, if ((mask & OMP_CLAUSE_WAIT) && gfc_match ("wait") == MATCH_YES) { - match m = match_oacc_expr_list (" (", &c->wait_list, false); + m = match_oacc_expr_list (" (", &c->wait_list, false); if (m == MATCH_ERROR) - { - gfc_current_locus = old_loc; - break; - } + goto error; else if (m == MATCH_NO) { gfc_expr *expr @@ -2186,24 +2799,25 @@ gfc_match_omp_clauses (gfc_omp_clauses **cp, const omp_mask mask, continue; } if ((mask & OMP_CLAUSE_WORKER) - && !c->worker - && gfc_match ("worker") == MATCH_YES) + && (m = gfc_match_dupl_check (!c->worker, "worker")) != MATCH_NO) { + if (m == MATCH_ERROR) + goto error; c->worker = true; - match m = match_oacc_clause_gwv (c, GOMP_DIM_WORKER); + m = match_oacc_clause_gwv (c, GOMP_DIM_WORKER); if (m == MATCH_ERROR) - { - gfc_current_locus = old_loc; - break; - } + goto error; else if (m == MATCH_NO) needs_space = true; continue; } if ((mask & OMP_CLAUSE_ATOMIC) - && c->atomic_op == GFC_OMP_ATOMIC_UNSET - && gfc_match ("write") == MATCH_YES) + && (m = gfc_match_dupl_atomic ((c->atomic_op + == GFC_OMP_ATOMIC_UNSET), + "write")) != MATCH_NO) { + if (m == MATCH_ERROR) + goto error; c->atomic_op = GFC_OMP_ATOMIC_WRITE; needs_space = true; continue; @@ -2213,7 +2827,8 @@ gfc_match_omp_clauses (gfc_omp_clauses **cp, const omp_mask mask, break; } - if (gfc_match_omp_eos () != MATCH_YES) +end: + if (error || gfc_match_omp_eos () != MATCH_YES) { if (!gfc_error_flag_test ()) gfc_error ("Failed to match clause at %C"); @@ -2223,6 +2838,10 @@ gfc_match_omp_clauses (gfc_omp_clauses **cp, const omp_mask mask, *cp = c; return MATCH_YES; + +error: + error = true; + goto end; } @@ -2283,7 +2902,8 @@ gfc_match_omp_clauses (gfc_omp_clauses **cp, const omp_mask mask, omp_mask (OMP_CLAUSE_ASYNC) #define OACC_ROUTINE_CLAUSES \ (omp_mask (OMP_CLAUSE_GANG) | OMP_CLAUSE_WORKER | OMP_CLAUSE_VECTOR \ - | OMP_CLAUSE_SEQ) + | OMP_CLAUSE_SEQ \ + | OMP_CLAUSE_NOHOST) static match @@ -2612,6 +3232,7 @@ gfc_match_oacc_routine (void) gfc_omp_clauses *c = NULL; gfc_oacc_routine_name *n = NULL; oacc_routine_lop lop = OACC_ROUTINE_LOP_NONE; + bool nohost; old_loc = gfc_current_locus; @@ -2688,6 +3309,7 @@ gfc_match_oacc_routine (void) gfc_error ("Multiple loop axes specified for routine at %C"); goto cleanup; } + nohost = c ? c->nohost : false; if (isym != NULL) { @@ -2700,6 +3322,13 @@ gfc_match_oacc_routine (void) " clause"); goto cleanup; } + /* ..., and no 'nohost' clause. */ + if (nohost) + { + gfc_error ("Intrinsic symbol specified in !$ACC ROUTINE ( NAME )" + " at %C marked with incompatible NOHOST clause"); + goto cleanup; + } } else if (sym != NULL) { @@ -2713,7 +3342,9 @@ gfc_match_oacc_routine (void) if (n_p->sym == sym) { add = false; - if (lop != gfc_oacc_routine_lop (n_p->clauses)) + bool nohost_p = n_p->clauses ? n_p->clauses->nohost : false; + if (lop != gfc_oacc_routine_lop (n_p->clauses) + || nohost != nohost_p) { gfc_error ("!$ACC ROUTINE already applied at %C"); goto cleanup; @@ -2723,6 +3354,7 @@ gfc_match_oacc_routine (void) if (add) { sym->attr.oacc_routine_lop = lop; + sym->attr.oacc_routine_nohost = nohost; n = gfc_get_oacc_routine_name (); n->sym = sym; @@ -2737,8 +3369,10 @@ gfc_match_oacc_routine (void) /* For a repeated OpenACC 'routine' directive, diagnose if it doesn't match the first one. */ oacc_routine_lop lop_p = gfc_current_ns->proc_name->attr.oacc_routine_lop; + bool nohost_p = gfc_current_ns->proc_name->attr.oacc_routine_nohost; if (lop_p != OACC_ROUTINE_LOP_NONE - && lop != lop_p) + && (lop != lop_p + || nohost != nohost_p)) { gfc_error ("!$ACC ROUTINE already applied at %C"); goto cleanup; @@ -2749,6 +3383,7 @@ gfc_match_oacc_routine (void) &old_loc)) goto cleanup; gfc_current_ns->proc_name->attr.oacc_routine_lop = lop; + gfc_current_ns->proc_name->attr.oacc_routine_nohost = nohost; } else /* Something has gone wrong, possibly a syntax error. */ @@ -2791,6 +3426,11 @@ cleanup: | OMP_CLAUSE_LASTPRIVATE | OMP_CLAUSE_REDUCTION \ | OMP_CLAUSE_SCHEDULE | OMP_CLAUSE_ORDERED | OMP_CLAUSE_COLLAPSE \ | OMP_CLAUSE_LINEAR | OMP_CLAUSE_ORDER) +#define OMP_LOOP_CLAUSES \ + (omp_mask (OMP_CLAUSE_BIND) | OMP_CLAUSE_COLLAPSE | OMP_CLAUSE_ORDER \ + | OMP_CLAUSE_PRIVATE | OMP_CLAUSE_LASTPRIVATE | OMP_CLAUSE_REDUCTION) +#define OMP_SCOPE_CLAUSES \ + (omp_mask (OMP_CLAUSE_PRIVATE) | OMP_CLAUSE_REDUCTION) #define OMP_SECTIONS_CLAUSES \ (omp_mask (OMP_CLAUSE_PRIVATE) | OMP_CLAUSE_FIRSTPRIVATE \ | OMP_CLAUSE_LASTPRIVATE | OMP_CLAUSE_REDUCTION) @@ -2804,7 +3444,7 @@ cleanup: | OMP_CLAUSE_SHARED | OMP_CLAUSE_IF | OMP_CLAUSE_DEFAULT \ | OMP_CLAUSE_UNTIED | OMP_CLAUSE_FINAL | OMP_CLAUSE_MERGEABLE \ | OMP_CLAUSE_DEPEND | OMP_CLAUSE_PRIORITY | OMP_CLAUSE_IN_REDUCTION \ - | OMP_CLAUSE_DETACH) + | OMP_CLAUSE_DETACH | OMP_CLAUSE_AFFINITY) #define OMP_TASKLOOP_CLAUSES \ (omp_mask (OMP_CLAUSE_PRIVATE) | OMP_CLAUSE_FIRSTPRIVATE \ | OMP_CLAUSE_LASTPRIVATE | OMP_CLAUSE_SHARED | OMP_CLAUSE_IF \ @@ -2845,6 +3485,11 @@ cleanup: #define OMP_ATOMIC_CLAUSES \ (omp_mask (OMP_CLAUSE_ATOMIC) | OMP_CLAUSE_CAPTURE | OMP_CLAUSE_HINT \ | OMP_CLAUSE_MEMORDER) +#define OMP_MASKED_CLAUSES \ + (omp_mask (OMP_CLAUSE_FILTER)) +#define OMP_ERROR_CLAUSES \ + (omp_mask (OMP_CLAUSE_AT) | OMP_CLAUSE_MESSAGE | OMP_CLAUSE_SEVERITY) + static match @@ -2898,6 +3543,86 @@ gfc_match_omp_end_critical (void) return MATCH_YES; } +/* depobj(depobj) depend(dep-type:loc)|destroy|update(dep-type) + dep-type = in/out/inout/mutexinoutset/depobj/source/sink + depend: !source, !sink + update: !source, !sink, !depobj + locator = exactly one list item .*/ +match +gfc_match_omp_depobj (void) +{ + gfc_omp_clauses *c = NULL; + gfc_expr *depobj; + + if (gfc_match (" ( %v ) ", &depobj) != MATCH_YES) + { + gfc_error ("Expected %<( depobj )%> at %C"); + return MATCH_ERROR; + } + if (gfc_match ("update ( ") == MATCH_YES) + { + c = gfc_get_omp_clauses (); + if (gfc_match ("inout )") == MATCH_YES) + c->depobj_update = OMP_DEPEND_INOUT; + else if (gfc_match ("in )") == MATCH_YES) + c->depobj_update = OMP_DEPEND_IN; + else if (gfc_match ("out )") == MATCH_YES) + c->depobj_update = OMP_DEPEND_OUT; + else if (gfc_match ("mutexinoutset )") == MATCH_YES) + c->depobj_update = OMP_DEPEND_MUTEXINOUTSET; + else + { + gfc_error ("Expected IN, OUT, INOUT, MUTEXINOUTSET followed by " + "%<)%> at %C"); + goto error; + } + } + else if (gfc_match ("destroy") == MATCH_YES) + { + c = gfc_get_omp_clauses (); + c->destroy = true; + } + else if (gfc_match_omp_clauses (&c, omp_mask (OMP_CLAUSE_DEPEND), true, false) + != MATCH_YES) + goto error; + + if (c->depobj_update == OMP_DEPEND_UNSET && !c->destroy) + { + if (!c->depend_source && !c->lists[OMP_LIST_DEPEND]) + { + gfc_error ("Expected DEPEND, UPDATE, or DESTROY clause at %C"); + goto error; + } + if (c->depend_source + || c->lists[OMP_LIST_DEPEND]->u.depend_op == OMP_DEPEND_SINK_FIRST + || c->lists[OMP_LIST_DEPEND]->u.depend_op == OMP_DEPEND_SINK + || c->lists[OMP_LIST_DEPEND]->u.depend_op == OMP_DEPEND_DEPOBJ) + { + gfc_error ("DEPEND clause at %L of OMP DEPOBJ construct shall not " + "have dependence-type SOURCE, SINK or DEPOBJ", + c->lists[OMP_LIST_DEPEND] + ? &c->lists[OMP_LIST_DEPEND]->where : &gfc_current_locus); + goto error; + } + if (c->lists[OMP_LIST_DEPEND]->next) + { + gfc_error ("DEPEND clause at %L of OMP DEPOBJ construct shall have " + "only a single locator", + &c->lists[OMP_LIST_DEPEND]->next->where); + goto error; + } + } + + c->depobj = depobj; + new_st.op = EXEC_OMP_DEPOBJ; + new_st.ext.omp_clauses = c; + return MATCH_YES; + +error: + gfc_free_expr (depobj); + gfc_free_omp_clauses (c); + return MATCH_ERROR; +} match gfc_match_omp_distribute (void) @@ -2950,6 +3675,105 @@ gfc_match_omp_do_simd (void) match +gfc_match_omp_loop (void) +{ + return match_omp (EXEC_OMP_LOOP, OMP_LOOP_CLAUSES); +} + + +match +gfc_match_omp_teams_loop (void) +{ + return match_omp (EXEC_OMP_TEAMS_LOOP, OMP_TEAMS_CLAUSES | OMP_LOOP_CLAUSES); +} + + +match +gfc_match_omp_target_teams_loop (void) +{ + return match_omp (EXEC_OMP_TARGET_TEAMS_LOOP, + OMP_TARGET_CLAUSES | OMP_TEAMS_CLAUSES | OMP_LOOP_CLAUSES); +} + + +match +gfc_match_omp_parallel_loop (void) +{ + return match_omp (EXEC_OMP_PARALLEL_LOOP, + OMP_PARALLEL_CLAUSES | OMP_LOOP_CLAUSES); +} + + +match +gfc_match_omp_target_parallel_loop (void) +{ + return match_omp (EXEC_OMP_TARGET_PARALLEL_LOOP, + (OMP_TARGET_CLAUSES | OMP_PARALLEL_CLAUSES + | OMP_LOOP_CLAUSES)); +} + + +match +gfc_match_omp_error (void) +{ + locus loc = gfc_current_locus; + match m = match_omp (EXEC_OMP_ERROR, OMP_ERROR_CLAUSES); + if (m != MATCH_YES) + return m; + + gfc_omp_clauses *c = new_st.ext.omp_clauses; + if (c->severity == OMP_SEVERITY_UNSET) + c->severity = OMP_SEVERITY_FATAL; + if (new_st.ext.omp_clauses->at == OMP_AT_EXECUTION) + return MATCH_YES; + if (c->message + && (!gfc_resolve_expr (c->message) + || c->message->ts.type != BT_CHARACTER + || c->message->ts.kind != gfc_default_character_kind + || c->message->rank != 0)) + { + gfc_error ("MESSAGE clause at %L requires a scalar default-kind " + "CHARACTER expression", + &new_st.ext.omp_clauses->message->where); + return MATCH_ERROR; + } + if (c->message && !gfc_is_constant_expr (c->message)) + { + gfc_error ("Constant character expression required in MESSAGE clause " + "at %L", &new_st.ext.omp_clauses->message->where); + return MATCH_ERROR; + } + if (c->message) + { + const char *msg = G_("$OMP ERROR encountered at %L: %s"); + gcc_assert (c->message->expr_type == EXPR_CONSTANT); + gfc_charlen_t slen = c->message->value.character.length; + int i = gfc_validate_kind (BT_CHARACTER, gfc_default_character_kind, + false); + size_t size = slen * gfc_character_kinds[i].bit_size / 8; + unsigned char *s = XCNEWVAR (unsigned char, size + 1); + gfc_encode_character (gfc_default_character_kind, slen, + c->message->value.character.string, + (unsigned char *) s, size); + s[size] = '\0'; + if (c->severity == OMP_SEVERITY_WARNING) + gfc_warning_now (0, msg, &loc, s); + else + gfc_error_now (msg, &loc, s); + free (s); + } + else + { + const char *msg = G_("$OMP ERROR encountered at %L"); + if (c->severity == OMP_SEVERITY_WARNING) + gfc_warning_now (0, msg, &loc); + else + gfc_error_now (msg, &loc); + } + return MATCH_YES; +} + +match gfc_match_omp_flush (void) { gfc_omp_namelist *list = NULL; @@ -2958,7 +3782,9 @@ gfc_match_omp_flush (void) enum gfc_omp_memorder mo = OMP_MEMORDER_UNSET; if (gfc_match_omp_eos () == MATCH_NO && gfc_peek_ascii_char () != '(') { - if (gfc_match ("acq_rel") == MATCH_YES) + if (gfc_match ("seq_cst") == MATCH_YES) + mo = OMP_MEMORDER_SEQ_CST; + else if (gfc_match ("acq_rel") == MATCH_YES) mo = OMP_MEMORDER_ACQ_REL; else if (gfc_match ("release") == MATCH_YES) mo = OMP_MEMORDER_RELEASE; @@ -2966,7 +3792,7 @@ gfc_match_omp_flush (void) mo = OMP_MEMORDER_ACQUIRE; else { - gfc_error ("Expected AQC_REL, RELEASE, or ACQUIRE at %C"); + gfc_error ("Expected SEQ_CST, AQC_REL, RELEASE, or ACQUIRE at %C"); return MATCH_ERROR; } c = gfc_get_omp_clauses (); @@ -2977,14 +3803,14 @@ gfc_match_omp_flush (void) { gfc_error ("List specified together with memory order clause in FLUSH " "directive at %C"); - gfc_free_omp_namelist (list); + gfc_free_omp_namelist (list, false); gfc_free_omp_clauses (c); return MATCH_ERROR; } if (gfc_match_omp_eos () != MATCH_YES) { gfc_error ("Unexpected junk after $OMP FLUSH statement at %C"); - gfc_free_omp_namelist (list); + gfc_free_omp_namelist (list, false); gfc_free_omp_clauses (c); return MATCH_ERROR; } @@ -3685,6 +4511,54 @@ gfc_match_omp_parallel_do_simd (void) match +gfc_match_omp_parallel_masked (void) +{ + return match_omp (EXEC_OMP_PARALLEL_MASKED, + OMP_PARALLEL_CLAUSES | OMP_MASKED_CLAUSES); +} + +match +gfc_match_omp_parallel_masked_taskloop (void) +{ + return match_omp (EXEC_OMP_PARALLEL_MASKED_TASKLOOP, + (OMP_PARALLEL_CLAUSES | OMP_MASKED_CLAUSES + | OMP_TASKLOOP_CLAUSES) + & ~(omp_mask (OMP_CLAUSE_IN_REDUCTION))); +} + +match +gfc_match_omp_parallel_masked_taskloop_simd (void) +{ + return match_omp (EXEC_OMP_PARALLEL_MASKED_TASKLOOP_SIMD, + (OMP_PARALLEL_CLAUSES | OMP_MASKED_CLAUSES + | OMP_TASKLOOP_CLAUSES | OMP_SIMD_CLAUSES) + & ~(omp_mask (OMP_CLAUSE_IN_REDUCTION))); +} + +match +gfc_match_omp_parallel_master (void) +{ + return match_omp (EXEC_OMP_PARALLEL_MASTER, OMP_PARALLEL_CLAUSES); +} + +match +gfc_match_omp_parallel_master_taskloop (void) +{ + return match_omp (EXEC_OMP_PARALLEL_MASTER_TASKLOOP, + (OMP_PARALLEL_CLAUSES | OMP_TASKLOOP_CLAUSES) + & ~(omp_mask (OMP_CLAUSE_IN_REDUCTION))); +} + +match +gfc_match_omp_parallel_master_taskloop_simd (void) +{ + return match_omp (EXEC_OMP_PARALLEL_MASTER_TASKLOOP_SIMD, + (OMP_PARALLEL_CLAUSES | OMP_TASKLOOP_CLAUSES + | OMP_SIMD_CLAUSES) + & ~(omp_mask (OMP_CLAUSE_IN_REDUCTION))); +} + +match gfc_match_omp_parallel_sections (void) { return match_omp (EXEC_OMP_PARALLEL_SECTIONS, @@ -3960,6 +4834,13 @@ gfc_match_omp_scan (void) match +gfc_match_omp_scope (void) +{ + return match_omp (EXEC_OMP_SCOPE, OMP_SCOPE_CLAUSES); +} + + +match gfc_match_omp_sections (void) { return match_omp (EXEC_OMP_SECTIONS, OMP_SECTIONS_CLAUSES); @@ -4117,22 +4998,20 @@ match gfc_match_omp_taskloop_simd (void) { return match_omp (EXEC_OMP_TASKLOOP_SIMD, - (OMP_TASKLOOP_CLAUSES | OMP_SIMD_CLAUSES) - & ~(omp_mask (OMP_CLAUSE_REDUCTION))); + OMP_TASKLOOP_CLAUSES | OMP_SIMD_CLAUSES); } match gfc_match_omp_taskwait (void) { - if (gfc_match_omp_eos () != MATCH_YES) + if (gfc_match_omp_eos () == MATCH_YES) { - gfc_error ("Unexpected junk after TASKWAIT clause at %C"); - return MATCH_ERROR; + new_st.op = EXEC_OMP_TASKWAIT; + new_st.ext.omp_clauses = NULL; + return MATCH_YES; } - new_st.op = EXEC_OMP_TASKWAIT; - new_st.ext.omp_clauses = NULL; - return MATCH_YES; + return match_omp (EXEC_OMP_TASKWAIT, omp_mask (OMP_CLAUSE_DEPEND)); } @@ -4210,6 +5089,27 @@ gfc_match_omp_workshare (void) match +gfc_match_omp_masked (void) +{ + return match_omp (EXEC_OMP_MASKED, OMP_MASKED_CLAUSES); +} + +match +gfc_match_omp_masked_taskloop (void) +{ + return match_omp (EXEC_OMP_MASKED_TASKLOOP, + OMP_MASKED_CLAUSES | OMP_TASKLOOP_CLAUSES); +} + +match +gfc_match_omp_masked_taskloop_simd (void) +{ + return match_omp (EXEC_OMP_MASKED_TASKLOOP_SIMD, + (OMP_MASKED_CLAUSES | OMP_TASKLOOP_CLAUSES + | OMP_SIMD_CLAUSES)); +} + +match gfc_match_omp_master (void) { if (gfc_match_omp_eos () != MATCH_YES) @@ -4222,6 +5122,18 @@ gfc_match_omp_master (void) return MATCH_YES; } +match +gfc_match_omp_master_taskloop (void) +{ + return match_omp (EXEC_OMP_MASTER_TASKLOOP, OMP_TASKLOOP_CLAUSES); +} + +match +gfc_match_omp_master_taskloop_simd (void) +{ + return match_omp (EXEC_OMP_MASTER_TASKLOOP_SIMD, + OMP_TASKLOOP_CLAUSES | OMP_SIMD_CLAUSES); +} match gfc_match_omp_ordered (void) @@ -4229,6 +5141,17 @@ gfc_match_omp_ordered (void) return match_omp (EXEC_OMP_ORDERED, OMP_ORDERED_CLAUSES); } +match +gfc_match_omp_nothing (void) +{ + if (gfc_match_omp_eos () != MATCH_YES) + { + gfc_error ("Unexpected junk after $OMP NOTHING statement at %C"); + return MATCH_ERROR; + } + /* Will use ST_NONE; therefore, no EXEC_OMP_ is needed. */ + return MATCH_YES; +} match gfc_match_omp_ordered_depend (void) @@ -4416,7 +5339,11 @@ gfc_match_omp_cancellation_point (void) gfc_omp_clauses *c; enum gfc_omp_cancel_kind kind = gfc_match_omp_cancel_kind (); if (kind == OMP_CANCEL_UNKNOWN) - return MATCH_ERROR; + { + gfc_error ("Expected construct-type PARALLEL, SECTIONS, DO or TASKGROUP " + "in $OMP CANCELLATION POINT statement at %C"); + return MATCH_ERROR; + } if (gfc_match_omp_eos () != MATCH_YES) { gfc_error ("Unexpected junk after $OMP CANCELLATION POINT statement " @@ -4439,7 +5366,10 @@ gfc_match_omp_end_nowait (void) nowait = true; if (gfc_match_omp_eos () != MATCH_YES) { - gfc_error ("Unexpected junk after NOWAIT clause at %C"); + if (nowait) + gfc_error ("Unexpected junk after NOWAIT clause at %C"); + else + gfc_error ("Unexpected junk at %C"); return MATCH_ERROR; } new_st.op = EXEC_OMP_END_NOWAIT; @@ -4698,7 +5628,7 @@ resolve_omp_clauses (gfc_code *code, gfc_omp_clauses *omp_clauses, gfc_omp_linear_op linear_op = OMP_LINEAR_DEFAULT; static const char *clause_names[] = { "PRIVATE", "FIRSTPRIVATE", "LASTPRIVATE", "COPYPRIVATE", "SHARED", - "COPYIN", "UNIFORM", "ALIGNED", "LINEAR", "DEPEND", "MAP", + "COPYIN", "UNIFORM", "AFFINITY", "ALIGNED", "LINEAR", "DEPEND", "MAP", "TO", "FROM", "INCLUSIVE", "EXCLUSIVE", "REDUCTION", "REDUCTION" /*inscan*/, "REDUCTION" /*task*/, "IN_REDUCTION", "TASK_REDUCTION", @@ -4748,6 +5678,8 @@ resolve_omp_clauses (gfc_code *code, gfc_omp_clauses *omp_clauses, case EXEC_OMP_PARALLEL: case EXEC_OMP_PARALLEL_DO: + case EXEC_OMP_PARALLEL_MASKED: + case EXEC_OMP_PARALLEL_MASTER: case EXEC_OMP_PARALLEL_SECTIONS: case EXEC_OMP_PARALLEL_WORKSHARE: case EXEC_OMP_DISTRIBUTE_PARALLEL_DO: @@ -4761,6 +5693,18 @@ resolve_omp_clauses (gfc_code *code, gfc_omp_clauses *omp_clauses, ok = ifc == OMP_IF_PARALLEL || ifc == OMP_IF_SIMD; break; + case EXEC_OMP_PARALLEL_MASKED_TASKLOOP: + case EXEC_OMP_PARALLEL_MASTER_TASKLOOP: + ok = ifc == OMP_IF_PARALLEL || ifc == OMP_IF_TASKLOOP; + break; + + case EXEC_OMP_PARALLEL_MASKED_TASKLOOP_SIMD: + case EXEC_OMP_PARALLEL_MASTER_TASKLOOP_SIMD: + ok = (ifc == OMP_IF_PARALLEL + || ifc == OMP_IF_TASKLOOP + || ifc == OMP_IF_SIMD); + break; + case EXEC_OMP_SIMD: case EXEC_OMP_DO_SIMD: case EXEC_OMP_DISTRIBUTE_SIMD: @@ -4773,10 +5717,14 @@ resolve_omp_clauses (gfc_code *code, gfc_omp_clauses *omp_clauses, break; case EXEC_OMP_TASKLOOP: + case EXEC_OMP_MASKED_TASKLOOP: + case EXEC_OMP_MASTER_TASKLOOP: ok = ifc == OMP_IF_TASKLOOP; break; case EXEC_OMP_TASKLOOP_SIMD: + case EXEC_OMP_MASKED_TASKLOOP_SIMD: + case EXEC_OMP_MASTER_TASKLOOP_SIMD: ok = ifc == OMP_IF_TASKLOOP || ifc == OMP_IF_SIMD; break; @@ -4877,6 +5825,14 @@ resolve_omp_clauses (gfc_code *code, gfc_omp_clauses *omp_clauses, "clause at %L", &code->loc); } + if (omp_clauses->depobj + && (!gfc_resolve_expr (omp_clauses->depobj) + || omp_clauses->depobj->ts.type != BT_INTEGER + || omp_clauses->depobj->ts.kind != 2 * gfc_index_integer_kind + || omp_clauses->depobj->rank != 0)) + gfc_error ("DEPOBJ in DEPOBJ construct at %L shall be a scalar integer " + "of OMP_DEPEND_KIND kind", &omp_clauses->depobj->where); + /* Check that no symbol appears on multiple clauses, except that a symbol can appear on both firstprivate and lastprivate. */ for (list = 0; list < OMP_LIST_NUM; list++) @@ -5137,6 +6093,7 @@ resolve_omp_clauses (gfc_code *code, gfc_omp_clauses *omp_clauses, } } break; + case OMP_LIST_AFFINITY: case OMP_LIST_DEPEND: case OMP_LIST_MAP: case OMP_LIST_TO: @@ -5144,6 +6101,40 @@ resolve_omp_clauses (gfc_code *code, gfc_omp_clauses *omp_clauses, case OMP_LIST_CACHE: for (; n != NULL; n = n->next) { + if ((list == OMP_LIST_DEPEND || list == OMP_LIST_AFFINITY) + && n->u2.ns && !n->u2.ns->resolved) + { + n->u2.ns->resolved = 1; + for (gfc_symbol *sym = n->u2.ns->proc_name; sym; + sym = sym->tlink) + { + gfc_constructor *c; + c = gfc_constructor_first (sym->value->value.constructor); + if (!gfc_resolve_expr (c->expr) + || c->expr->ts.type != BT_INTEGER + || c->expr->rank != 0) + gfc_error ("Scalar integer expression for range begin" + " expected at %L", &c->expr->where); + c = gfc_constructor_next (c); + if (!gfc_resolve_expr (c->expr) + || c->expr->ts.type != BT_INTEGER + || c->expr->rank != 0) + gfc_error ("Scalar integer expression for range end " + "expected at %L", &c->expr->where); + c = gfc_constructor_next (c); + if (c && (!gfc_resolve_expr (c->expr) + || c->expr->ts.type != BT_INTEGER + || c->expr->rank != 0)) + gfc_error ("Scalar integer expression for range step " + "expected at %L", &c->expr->where); + else if (c + && c->expr->expr_type == EXPR_CONSTANT + && mpz_cmp_si (c->expr->value.integer, 0) == 0) + gfc_error ("Nonzero range step expected at %L", + &c->expr->where); + } + } + if (list == OMP_LIST_DEPEND) { if (n->u.depend_op == OMP_DEPEND_SINK_FIRST @@ -5173,6 +6164,26 @@ resolve_omp_clauses (gfc_code *code, gfc_omp_clauses *omp_clauses, gfc_error ("Only SOURCE or SINK dependence types " "are allowed on ORDERED directive at %L", &n->where); + else if (n->u.depend_op == OMP_DEPEND_DEPOBJ + && !n->expr + && (n->sym->ts.type != BT_INTEGER + || n->sym->ts.kind + != 2 * gfc_index_integer_kind + || n->sym->attr.dimension)) + gfc_error ("Locator %qs at %L in DEPEND clause of depobj " + "type shall be a scalar integer of " + "OMP_DEPEND_KIND kind", n->sym->name, + &n->where); + else if (n->u.depend_op == OMP_DEPEND_DEPOBJ + && n->expr + && (!gfc_resolve_expr (n->expr) + || n->expr->ts.type != BT_INTEGER + || n->expr->ts.kind + != 2 * gfc_index_integer_kind + || n->expr->rank != 0)) + gfc_error ("Locator at %L in DEPEND clause of depobj " + "type shall be a scalar integer of " + "OMP_DEPEND_KIND kind", &n->expr->where); } gfc_ref *lastref = NULL, *lastslice = NULL; bool resolved = false; @@ -5265,7 +6276,8 @@ resolve_omp_clauses (gfc_code *code, gfc_omp_clauses *omp_clauses, n->sym->name, name, &n->where); break; } - else if (list == OMP_LIST_DEPEND + else if ((list == OMP_LIST_DEPEND + || list == OMP_LIST_AFFINITY) && ar->start[i] && ar->start[i]->expr_type == EXPR_CONSTANT && ar->end[i] @@ -5273,9 +6285,11 @@ resolve_omp_clauses (gfc_code *code, gfc_omp_clauses *omp_clauses, && mpz_cmp (ar->start[i]->value.integer, ar->end[i]->value.integer) > 0) { - gfc_error ("%qs in DEPEND clause at %L is a " + gfc_error ("%qs in %s clause at %L is a " "zero size array section", - n->sym->name, &n->where); + n->sym->name, + list == OMP_LIST_DEPEND + ? "DEPEND" : "AFFINITY", &n->where); break; } } @@ -5470,11 +6484,25 @@ resolve_omp_clauses (gfc_code *code, gfc_omp_clauses *omp_clauses, n->sym->name, name, &n->where); switch (list) { - case OMP_LIST_REDUCTION_INSCAN: case OMP_LIST_REDUCTION_TASK: - if (code && (code->op == EXEC_OMP_TASKLOOP - || code->op == EXEC_OMP_TEAMS - || code->op == EXEC_OMP_TEAMS_DISTRIBUTE)) + if (code + && (code->op == EXEC_OMP_LOOP + || code->op == EXEC_OMP_TASKLOOP + || code->op == EXEC_OMP_TASKLOOP_SIMD + || code->op == EXEC_OMP_MASKED_TASKLOOP + || code->op == EXEC_OMP_MASKED_TASKLOOP_SIMD + || code->op == EXEC_OMP_MASTER_TASKLOOP + || code->op == EXEC_OMP_MASTER_TASKLOOP_SIMD + || code->op == EXEC_OMP_PARALLEL_LOOP + || code->op == EXEC_OMP_PARALLEL_MASKED_TASKLOOP + || code->op == EXEC_OMP_PARALLEL_MASKED_TASKLOOP_SIMD + || code->op == EXEC_OMP_PARALLEL_MASTER_TASKLOOP + || code->op == EXEC_OMP_PARALLEL_MASTER_TASKLOOP_SIMD + || code->op == EXEC_OMP_TARGET_PARALLEL_LOOP + || code->op == EXEC_OMP_TARGET_TEAMS_LOOP + || code->op == EXEC_OMP_TEAMS + || code->op == EXEC_OMP_TEAMS_DISTRIBUTE + || code->op == EXEC_OMP_TEAMS_LOOP)) { gfc_error ("Only DEFAULT permitted as reduction-" "modifier in REDUCTION clause at %L", @@ -5485,6 +6513,7 @@ resolve_omp_clauses (gfc_code *code, gfc_omp_clauses *omp_clauses, case OMP_LIST_REDUCTION: case OMP_LIST_IN_REDUCTION: case OMP_LIST_TASK_REDUCTION: + case OMP_LIST_REDUCTION_INSCAN: switch (n->u.reduction_op) { case OMP_REDUCTION_PLUS: @@ -5519,23 +6548,23 @@ resolve_omp_clauses (gfc_code *code, gfc_omp_clauses *omp_clauses, break; } if (!bad) - n->udr = NULL; + n->u2.udr = NULL; else { const char *udr_name = NULL; - if (n->udr) + if (n->u2.udr) { - udr_name = n->udr->udr->name; - n->udr->udr + udr_name = n->u2.udr->udr->name; + n->u2.udr->udr = gfc_find_omp_udr (NULL, udr_name, &n->sym->ts); - if (n->udr->udr == NULL) + if (n->u2.udr->udr == NULL) { - free (n->udr); - n->udr = NULL; + free (n->u2.udr); + n->u2.udr = NULL; } } - if (n->udr == NULL) + if (n->u2.udr == NULL) { if (udr_name == NULL) switch (n->u.reduction_op) @@ -5574,14 +6603,14 @@ resolve_omp_clauses (gfc_code *code, gfc_omp_clauses *omp_clauses, } else { - gfc_omp_udr *udr = n->udr->udr; + gfc_omp_udr *udr = n->u2.udr->udr; n->u.reduction_op = OMP_REDUCTION_USER; - n->udr->combiner + n->u2.udr->combiner = resolve_omp_udr_clause (n, udr->combiner_ns, udr->omp_out, udr->omp_in); if (udr->initializer_ns) - n->udr->initializer + n->u2.udr->initializer = resolve_omp_udr_clause (n, udr->initializer_ns, udr->omp_priv, @@ -5726,6 +6755,8 @@ resolve_omp_clauses (gfc_code *code, gfc_omp_clauses *omp_clauses, resolve_positive_int_expr (omp_clauses->num_teams, "NUM_TEAMS"); if (omp_clauses->device) resolve_nonnegative_int_expr (omp_clauses->device, "DEVICE"); + if (omp_clauses->filter) + resolve_nonnegative_int_expr (omp_clauses->filter, "FILTER"); if (omp_clauses->hint) { resolve_scalar_int_expr (omp_clauses->hint, "HINT"); @@ -5776,6 +6807,15 @@ resolve_omp_clauses (gfc_code *code, gfc_omp_clauses *omp_clauses, if (omp_clauses->depend_source && code->op != EXEC_OMP_ORDERED) gfc_error ("SOURCE dependence type only allowed " "on ORDERED directive at %L", &code->loc); + if (omp_clauses->message) + { + gfc_expr *expr = omp_clauses->message; + if (!gfc_resolve_expr (expr) + || expr->ts.kind != gfc_default_character_kind + || expr->ts.type != BT_CHARACTER || expr->rank != 0) + gfc_error ("MESSAGE clause at %L requires a scalar default-kind " + "CHARACTER expression", &expr->where); + } if (!openacc && code && omp_clauses->lists[OMP_LIST_MAP] == NULL @@ -6388,6 +7428,14 @@ gfc_resolve_omp_parallel_blocks (gfc_code *code, gfc_namespace *ns) case EXEC_OMP_DISTRIBUTE_PARALLEL_DO_SIMD: case EXEC_OMP_PARALLEL_DO: case EXEC_OMP_PARALLEL_DO_SIMD: + case EXEC_OMP_PARALLEL_MASKED_TASKLOOP: + case EXEC_OMP_PARALLEL_MASKED_TASKLOOP_SIMD: + case EXEC_OMP_PARALLEL_MASTER_TASKLOOP: + case EXEC_OMP_PARALLEL_MASTER_TASKLOOP_SIMD: + case EXEC_OMP_MASKED_TASKLOOP: + case EXEC_OMP_MASKED_TASKLOOP_SIMD: + case EXEC_OMP_MASTER_TASKLOOP: + case EXEC_OMP_MASTER_TASKLOOP_SIMD: case EXEC_OMP_TARGET_PARALLEL_DO: case EXEC_OMP_TARGET_PARALLEL_DO_SIMD: case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE: @@ -6526,17 +7574,46 @@ resolve_omp_do (gfc_code *code) break; case EXEC_OMP_DO: name = "!$OMP DO"; break; case EXEC_OMP_DO_SIMD: name = "!$OMP DO SIMD"; is_simd = true; break; + case EXEC_OMP_LOOP: name = "!$OMP LOOP"; break; case EXEC_OMP_PARALLEL_DO: name = "!$OMP PARALLEL DO"; break; case EXEC_OMP_PARALLEL_DO_SIMD: name = "!$OMP PARALLEL DO SIMD"; is_simd = true; break; + case EXEC_OMP_PARALLEL_LOOP: name = "!$OMP PARALLEL LOOP"; break; + case EXEC_OMP_PARALLEL_MASKED_TASKLOOP: + name = "!$OMP PARALLEL MASKED TASKLOOP"; + break; + case EXEC_OMP_PARALLEL_MASKED_TASKLOOP_SIMD: + name = "!$OMP PARALLEL MASKED TASKLOOP SIMD"; + is_simd = true; + break; + case EXEC_OMP_PARALLEL_MASTER_TASKLOOP: + name = "!$OMP PARALLEL MASTER TASKLOOP"; + break; + case EXEC_OMP_PARALLEL_MASTER_TASKLOOP_SIMD: + name = "!$OMP PARALLEL MASTER TASKLOOP SIMD"; + is_simd = true; + break; + case EXEC_OMP_MASKED_TASKLOOP: name = "!$OMP MASKED TASKLOOP"; break; + case EXEC_OMP_MASKED_TASKLOOP_SIMD: + name = "!$OMP MASKED TASKLOOP SIMD"; + is_simd = true; + break; + case EXEC_OMP_MASTER_TASKLOOP: name = "!$OMP MASTER TASKLOOP"; break; + case EXEC_OMP_MASTER_TASKLOOP_SIMD: + name = "!$OMP MASTER TASKLOOP SIMD"; + is_simd = true; + break; case EXEC_OMP_SIMD: name = "!$OMP SIMD"; is_simd = true; break; case EXEC_OMP_TARGET_PARALLEL_DO: name = "!$OMP TARGET PARALLEL DO"; break; case EXEC_OMP_TARGET_PARALLEL_DO_SIMD: name = "!$OMP TARGET PARALLEL DO SIMD"; is_simd = true; break; + case EXEC_OMP_TARGET_PARALLEL_LOOP: + name = "!$OMP TARGET PARALLEL LOOP"; + break; case EXEC_OMP_TARGET_SIMD: name = "!$OMP TARGET SIMD"; is_simd = true; @@ -6555,6 +7632,7 @@ resolve_omp_do (gfc_code *code) name = "!$OMP TARGET TEAMS DISTRIBUTE SIMD"; is_simd = true; break; + case EXEC_OMP_TARGET_TEAMS_LOOP: name = "!$OMP TARGET TEAMS LOOP"; break; case EXEC_OMP_TASKLOOP: name = "!$OMP TASKLOOP"; break; case EXEC_OMP_TASKLOOP_SIMD: name = "!$OMP TASKLOOP SIMD"; @@ -6572,6 +7650,7 @@ resolve_omp_do (gfc_code *code) name = "!$OMP TEAMS DISTRIBUTE SIMD"; is_simd = true; break; + case EXEC_OMP_TEAMS_LOOP: name = "!$OMP TEAMS LOOP"; break; default: gcc_unreachable (); } @@ -6683,6 +7762,18 @@ omp_code_to_statement (gfc_code *code) { case EXEC_OMP_PARALLEL: return ST_OMP_PARALLEL; + case EXEC_OMP_PARALLEL_MASKED: + return ST_OMP_PARALLEL_MASKED; + case EXEC_OMP_PARALLEL_MASKED_TASKLOOP: + return ST_OMP_PARALLEL_MASKED_TASKLOOP; + case EXEC_OMP_PARALLEL_MASKED_TASKLOOP_SIMD: + return ST_OMP_PARALLEL_MASKED_TASKLOOP_SIMD; + case EXEC_OMP_PARALLEL_MASTER: + return ST_OMP_PARALLEL_MASTER; + case EXEC_OMP_PARALLEL_MASTER_TASKLOOP: + return ST_OMP_PARALLEL_MASTER_TASKLOOP; + case EXEC_OMP_PARALLEL_MASTER_TASKLOOP_SIMD: + return ST_OMP_PARALLEL_MASTER_TASKLOOP_SIMD; case EXEC_OMP_PARALLEL_SECTIONS: return ST_OMP_PARALLEL_SECTIONS; case EXEC_OMP_SECTIONS: @@ -6691,8 +7782,18 @@ omp_code_to_statement (gfc_code *code) return ST_OMP_ORDERED; case EXEC_OMP_CRITICAL: return ST_OMP_CRITICAL; + case EXEC_OMP_MASKED: + return ST_OMP_MASKED; + case EXEC_OMP_MASKED_TASKLOOP: + return ST_OMP_MASKED_TASKLOOP; + case EXEC_OMP_MASKED_TASKLOOP_SIMD: + return ST_OMP_MASKED_TASKLOOP_SIMD; case EXEC_OMP_MASTER: return ST_OMP_MASTER; + case EXEC_OMP_MASTER_TASKLOOP: + return ST_OMP_MASTER_TASKLOOP; + case EXEC_OMP_MASTER_TASKLOOP_SIMD: + return ST_OMP_MASTER_TASKLOOP_SIMD; case EXEC_OMP_SINGLE: return ST_OMP_SINGLE; case EXEC_OMP_TASK: @@ -6703,6 +7804,8 @@ omp_code_to_statement (gfc_code *code) return ST_OMP_PARALLEL_WORKSHARE; case EXEC_OMP_DO: return ST_OMP_DO; + case EXEC_OMP_LOOP: + return ST_OMP_LOOP; case EXEC_OMP_ATOMIC: return ST_OMP_ATOMIC; case EXEC_OMP_BARRIER: @@ -6711,6 +7814,8 @@ omp_code_to_statement (gfc_code *code) return ST_OMP_CANCEL; case EXEC_OMP_CANCELLATION_POINT: return ST_OMP_CANCELLATION_POINT; + case EXEC_OMP_ERROR: + return ST_OMP_ERROR; case EXEC_OMP_FLUSH: return ST_OMP_FLUSH; case EXEC_OMP_DISTRIBUTE: @@ -6725,6 +7830,8 @@ omp_code_to_statement (gfc_code *code) return ST_OMP_DO_SIMD; case EXEC_OMP_SCAN: return ST_OMP_SCAN; + case EXEC_OMP_SCOPE: + return ST_OMP_SCOPE; case EXEC_OMP_SIMD: return ST_OMP_SIMD; case EXEC_OMP_TARGET: @@ -6741,6 +7848,8 @@ omp_code_to_statement (gfc_code *code) return ST_OMP_TARGET_PARALLEL_DO; case EXEC_OMP_TARGET_PARALLEL_DO_SIMD: return ST_OMP_TARGET_PARALLEL_DO_SIMD; + case EXEC_OMP_TARGET_PARALLEL_LOOP: + return ST_OMP_TARGET_PARALLEL_LOOP; case EXEC_OMP_TARGET_SIMD: return ST_OMP_TARGET_SIMD; case EXEC_OMP_TARGET_TEAMS: @@ -6753,6 +7862,8 @@ omp_code_to_statement (gfc_code *code) return ST_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD; case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_SIMD: return ST_OMP_TARGET_TEAMS_DISTRIBUTE_SIMD; + case EXEC_OMP_TARGET_TEAMS_LOOP: + return ST_OMP_TARGET_TEAMS_LOOP; case EXEC_OMP_TARGET_UPDATE: return ST_OMP_TARGET_UPDATE; case EXEC_OMP_TASKGROUP: @@ -6775,11 +7886,16 @@ omp_code_to_statement (gfc_code *code) return ST_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD; case EXEC_OMP_TEAMS_DISTRIBUTE_SIMD: return ST_OMP_TEAMS_DISTRIBUTE_SIMD; + case EXEC_OMP_TEAMS_LOOP: + return ST_OMP_TEAMS_LOOP; case EXEC_OMP_PARALLEL_DO: return ST_OMP_PARALLEL_DO; case EXEC_OMP_PARALLEL_DO_SIMD: return ST_OMP_PARALLEL_DO_SIMD; - + case EXEC_OMP_PARALLEL_LOOP: + return ST_OMP_PARALLEL_LOOP; + case EXEC_OMP_DEPOBJ: + return ST_OMP_DEPOBJ; default: gcc_unreachable (); } @@ -7178,28 +8294,46 @@ gfc_resolve_omp_directive (gfc_code *code, gfc_namespace *ns) case EXEC_OMP_DISTRIBUTE_SIMD: case EXEC_OMP_DO: case EXEC_OMP_DO_SIMD: + case EXEC_OMP_LOOP: case EXEC_OMP_PARALLEL_DO: case EXEC_OMP_PARALLEL_DO_SIMD: + case EXEC_OMP_PARALLEL_LOOP: + case EXEC_OMP_PARALLEL_MASKED_TASKLOOP: + case EXEC_OMP_PARALLEL_MASKED_TASKLOOP_SIMD: + case EXEC_OMP_PARALLEL_MASTER_TASKLOOP: + case EXEC_OMP_PARALLEL_MASTER_TASKLOOP_SIMD: + case EXEC_OMP_MASKED_TASKLOOP: + case EXEC_OMP_MASKED_TASKLOOP_SIMD: + case EXEC_OMP_MASTER_TASKLOOP: + case EXEC_OMP_MASTER_TASKLOOP_SIMD: case EXEC_OMP_SIMD: case EXEC_OMP_TARGET_PARALLEL_DO: case EXEC_OMP_TARGET_PARALLEL_DO_SIMD: + case EXEC_OMP_TARGET_PARALLEL_LOOP: case EXEC_OMP_TARGET_SIMD: case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE: case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO: case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD: case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_SIMD: + case EXEC_OMP_TARGET_TEAMS_LOOP: case EXEC_OMP_TASKLOOP: case EXEC_OMP_TASKLOOP_SIMD: case EXEC_OMP_TEAMS_DISTRIBUTE: case EXEC_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO: case EXEC_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD: case EXEC_OMP_TEAMS_DISTRIBUTE_SIMD: + case EXEC_OMP_TEAMS_LOOP: resolve_omp_do (code); break; case EXEC_OMP_CANCEL: + case EXEC_OMP_ERROR: + case EXEC_OMP_MASKED: case EXEC_OMP_PARALLEL_WORKSHARE: case EXEC_OMP_PARALLEL: + case EXEC_OMP_PARALLEL_MASKED: + case EXEC_OMP_PARALLEL_MASTER: case EXEC_OMP_PARALLEL_SECTIONS: + case EXEC_OMP_SCOPE: case EXEC_OMP_SECTIONS: case EXEC_OMP_SINGLE: case EXEC_OMP_TARGET: @@ -7209,8 +8343,10 @@ gfc_resolve_omp_directive (gfc_code *code, gfc_namespace *ns) case EXEC_OMP_TARGET_PARALLEL: case EXEC_OMP_TARGET_TEAMS: case EXEC_OMP_TASK: + case EXEC_OMP_TASKWAIT: case EXEC_OMP_TEAMS: case EXEC_OMP_WORKSHARE: + case EXEC_OMP_DEPOBJ: if (code->ext.omp_clauses) resolve_omp_clauses (code, code->ext.omp_clauses, NULL); break; diff --git a/gcc/fortran/options.c b/gcc/fortran/options.c index 3a0b98b..847e20e 100644 --- a/gcc/fortran/options.c +++ b/gcc/fortran/options.c @@ -267,6 +267,9 @@ gfc_post_options (const char **pfilename) support. */ if (flag_excess_precision == EXCESS_PRECISION_STANDARD) sorry ("%<-fexcess-precision=standard%> for Fortran"); + else if (flag_excess_precision == EXCESS_PRECISION_FLOAT16) + sorry ("%<-fexcess-precision=16%> for Fortran"); + flag_excess_precision = EXCESS_PRECISION_FAST; /* Fortran allows associative math - but we cannot reassociate if @@ -615,7 +618,7 @@ gfc_handle_runtime_check_option (const char *arg) result = 1; break; } - else if (optname[n] && pos > 3 && gfc_str_startswith (arg, "no-") + else if (optname[n] && pos > 3 && startswith (arg, "no-") && strncmp (optname[n], arg+3, pos-3) == 0) { gfc_option.rtcheck &= ~optmask[n]; diff --git a/gcc/fortran/parse.c b/gcc/fortran/parse.c index 1549f8e..d37a0b5 100644 --- a/gcc/fortran/parse.c +++ b/gcc/fortran/parse.c @@ -895,6 +895,7 @@ decode_omp_directive (void) case 'd': matchds ("declare reduction", gfc_match_omp_declare_reduction, ST_OMP_DECLARE_REDUCTION); + matcho ("depobj", gfc_match_omp_depobj, ST_OMP_DEPOBJ); matchs ("distribute parallel do simd", gfc_match_omp_distribute_parallel_do_simd, ST_OMP_DISTRIBUTE_PARALLEL_DO_SIMD); @@ -907,6 +908,7 @@ decode_omp_directive (void) matcho ("do", gfc_match_omp_do, ST_OMP_DO); break; case 'e': + matcho ("error", gfc_match_omp_error, ST_OMP_ERROR); matcho ("end atomic", gfc_match_omp_eos_error, ST_OMP_END_ATOMIC); matcho ("end critical", gfc_match_omp_end_critical, ST_OMP_END_CRITICAL); matchs ("end distribute parallel do simd", gfc_match_omp_eos_error, @@ -919,16 +921,38 @@ decode_omp_directive (void) matchs ("end do simd", gfc_match_omp_end_nowait, ST_OMP_END_DO_SIMD); matcho ("end do", gfc_match_omp_end_nowait, ST_OMP_END_DO); matchs ("end simd", gfc_match_omp_eos_error, ST_OMP_END_SIMD); + matcho ("end masked taskloop simd", gfc_match_omp_eos_error, + ST_OMP_END_MASKED_TASKLOOP_SIMD); + matcho ("end masked taskloop", gfc_match_omp_eos_error, + ST_OMP_END_MASKED_TASKLOOP); + matcho ("end masked", gfc_match_omp_eos_error, ST_OMP_END_MASKED); + matcho ("end master taskloop simd", gfc_match_omp_eos_error, + ST_OMP_END_MASTER_TASKLOOP_SIMD); + matcho ("end master taskloop", gfc_match_omp_eos_error, + ST_OMP_END_MASTER_TASKLOOP); matcho ("end master", gfc_match_omp_eos_error, ST_OMP_END_MASTER); matchs ("end ordered", gfc_match_omp_eos_error, ST_OMP_END_ORDERED); matchs ("end parallel do simd", gfc_match_omp_eos_error, ST_OMP_END_PARALLEL_DO_SIMD); matcho ("end parallel do", gfc_match_omp_eos_error, ST_OMP_END_PARALLEL_DO); + matcho ("end parallel masked taskloop simd", gfc_match_omp_eos_error, + ST_OMP_END_PARALLEL_MASKED_TASKLOOP_SIMD); + matcho ("end parallel masked taskloop", gfc_match_omp_eos_error, + ST_OMP_END_PARALLEL_MASKED_TASKLOOP); + matcho ("end parallel masked", gfc_match_omp_eos_error, + ST_OMP_END_PARALLEL_MASKED); + matcho ("end parallel master taskloop simd", gfc_match_omp_eos_error, + ST_OMP_END_PARALLEL_MASTER_TASKLOOP_SIMD); + matcho ("end parallel master taskloop", gfc_match_omp_eos_error, + ST_OMP_END_PARALLEL_MASTER_TASKLOOP); + matcho ("end parallel master", gfc_match_omp_eos_error, + ST_OMP_END_PARALLEL_MASTER); matcho ("end parallel sections", gfc_match_omp_eos_error, ST_OMP_END_PARALLEL_SECTIONS); matcho ("end parallel workshare", gfc_match_omp_eos_error, ST_OMP_END_PARALLEL_WORKSHARE); matcho ("end parallel", gfc_match_omp_eos_error, ST_OMP_END_PARALLEL); + matcho ("end scope", gfc_match_omp_end_nowait, ST_OMP_END_SCOPE); matcho ("end sections", gfc_match_omp_end_nowait, ST_OMP_END_SECTIONS); matcho ("end single", gfc_match_omp_end_single, ST_OMP_END_SINGLE); matcho ("end target data", gfc_match_omp_eos_error, ST_OMP_END_TARGET_DATA); @@ -971,8 +995,23 @@ decode_omp_directive (void) matcho ("flush", gfc_match_omp_flush, ST_OMP_FLUSH); break; case 'm': + matcho ("masked taskloop simd", gfc_match_omp_masked_taskloop_simd, + ST_OMP_MASKED_TASKLOOP_SIMD); + matcho ("masked taskloop", gfc_match_omp_masked_taskloop, + ST_OMP_MASKED_TASKLOOP); + matcho ("masked", gfc_match_omp_masked, ST_OMP_MASKED); + matcho ("master taskloop simd", gfc_match_omp_master_taskloop_simd, + ST_OMP_MASTER_TASKLOOP_SIMD); + matcho ("master taskloop", gfc_match_omp_master_taskloop, + ST_OMP_MASTER_TASKLOOP); matcho ("master", gfc_match_omp_master, ST_OMP_MASTER); break; + case 'n': + matcho ("nothing", gfc_match_omp_nothing, ST_NONE); + break; + case 'l': + matcho ("loop", gfc_match_omp_loop, ST_OMP_LOOP); + break; case 'o': if (gfc_match ("ordered depend (") == MATCH_YES) { @@ -989,6 +1028,24 @@ decode_omp_directive (void) matchs ("parallel do simd", gfc_match_omp_parallel_do_simd, ST_OMP_PARALLEL_DO_SIMD); matcho ("parallel do", gfc_match_omp_parallel_do, ST_OMP_PARALLEL_DO); + matcho ("parallel loop", gfc_match_omp_parallel_loop, + ST_OMP_PARALLEL_LOOP); + matcho ("parallel masked taskloop simd", + gfc_match_omp_parallel_masked_taskloop_simd, + ST_OMP_PARALLEL_MASKED_TASKLOOP_SIMD); + matcho ("parallel masked taskloop", + gfc_match_omp_parallel_masked_taskloop, + ST_OMP_PARALLEL_MASKED_TASKLOOP); + matcho ("parallel masked", gfc_match_omp_parallel_masked, + ST_OMP_PARALLEL_MASKED); + matcho ("parallel master taskloop simd", + gfc_match_omp_parallel_master_taskloop_simd, + ST_OMP_PARALLEL_MASTER_TASKLOOP_SIMD); + matcho ("parallel master taskloop", + gfc_match_omp_parallel_master_taskloop, + ST_OMP_PARALLEL_MASTER_TASKLOOP); + matcho ("parallel master", gfc_match_omp_parallel_master, + ST_OMP_PARALLEL_MASTER); matcho ("parallel sections", gfc_match_omp_parallel_sections, ST_OMP_PARALLEL_SECTIONS); matcho ("parallel workshare", gfc_match_omp_parallel_workshare, @@ -1000,6 +1057,7 @@ decode_omp_directive (void) break; case 's': matcho ("scan", gfc_match_omp_scan, ST_OMP_SCAN); + matcho ("scope", gfc_match_omp_scope, ST_OMP_SCOPE); matcho ("sections", gfc_match_omp_sections, ST_OMP_SECTIONS); matcho ("section", gfc_match_omp_eos_error, ST_OMP_SECTION); matcho ("single", gfc_match_omp_single, ST_OMP_SINGLE); @@ -1014,6 +1072,8 @@ decode_omp_directive (void) ST_OMP_TARGET_PARALLEL_DO_SIMD); matcho ("target parallel do", gfc_match_omp_target_parallel_do, ST_OMP_TARGET_PARALLEL_DO); + matcho ("target parallel loop", gfc_match_omp_target_parallel_loop, + ST_OMP_TARGET_PARALLEL_LOOP); matcho ("target parallel", gfc_match_omp_target_parallel, ST_OMP_TARGET_PARALLEL); matchs ("target simd", gfc_match_omp_target_simd, ST_OMP_TARGET_SIMD); @@ -1028,6 +1088,8 @@ decode_omp_directive (void) ST_OMP_TARGET_TEAMS_DISTRIBUTE_SIMD); matcho ("target teams distribute", gfc_match_omp_target_teams_distribute, ST_OMP_TARGET_TEAMS_DISTRIBUTE); + matcho ("target teams loop", gfc_match_omp_target_teams_loop, + ST_OMP_TARGET_TEAMS_LOOP); matcho ("target teams", gfc_match_omp_target_teams, ST_OMP_TARGET_TEAMS); matcho ("target update", gfc_match_omp_target_update, ST_OMP_TARGET_UPDATE); @@ -1049,6 +1111,7 @@ decode_omp_directive (void) ST_OMP_TEAMS_DISTRIBUTE_SIMD); matcho ("teams distribute", gfc_match_omp_teams_distribute, ST_OMP_TEAMS_DISTRIBUTE); + matcho ("teams loop", gfc_match_omp_teams_loop, ST_OMP_TEAMS_LOOP); matcho ("teams", gfc_match_omp_teams, ST_OMP_TEAMS); matchdo ("threadprivate", gfc_match_omp_threadprivate, ST_OMP_THREADPRIVATE); @@ -1102,9 +1165,11 @@ decode_omp_directive (void) case ST_OMP_TARGET_TEAMS_DISTRIBUTE_SIMD: case ST_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO: case ST_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD: + case ST_OMP_TARGET_TEAMS_LOOP: case ST_OMP_TARGET_PARALLEL: case ST_OMP_TARGET_PARALLEL_DO: case ST_OMP_TARGET_PARALLEL_DO_SIMD: + case ST_OMP_TARGET_PARALLEL_LOOP: case ST_OMP_TARGET_SIMD: case ST_OMP_TARGET_UPDATE: { @@ -1119,6 +1184,9 @@ decode_omp_directive (void) prog_unit->omp_target_seen = true; break; } + case ST_OMP_ERROR: + if (new_st.ext.omp_clauses->at != OMP_AT_EXECUTION) + return ST_NONE; default: break; } @@ -1588,9 +1656,9 @@ next_statement (void) case ST_ASSIGNMENT: case ST_ARITHMETIC_IF: case ST_WHERE: case ST_FORALL: \ case ST_LABEL_ASSIGNMENT: case ST_FLUSH: case ST_OMP_FLUSH: \ case ST_OMP_BARRIER: case ST_OMP_TASKWAIT: case ST_OMP_TASKYIELD: \ - case ST_OMP_CANCEL: case ST_OMP_CANCELLATION_POINT: \ + case ST_OMP_CANCEL: case ST_OMP_CANCELLATION_POINT: case ST_OMP_DEPOBJ: \ case ST_OMP_TARGET_UPDATE: case ST_OMP_TARGET_ENTER_DATA: \ - case ST_OMP_TARGET_EXIT_DATA: case ST_OMP_ORDERED_DEPEND: \ + case ST_OMP_TARGET_EXIT_DATA: case ST_OMP_ORDERED_DEPEND: case ST_OMP_ERROR: \ 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: \ @@ -1604,9 +1672,16 @@ next_statement (void) #define case_exec_markers case ST_DO: case ST_FORALL_BLOCK: \ case ST_IF_BLOCK: case ST_BLOCK: case ST_ASSOCIATE: \ case ST_WHERE_BLOCK: case ST_SELECT_CASE: case ST_SELECT_TYPE: \ - case ST_SELECT_RANK: case ST_OMP_PARALLEL: \ + case ST_SELECT_RANK: case ST_OMP_PARALLEL: case ST_OMP_PARALLEL_MASKED: \ + case ST_OMP_PARALLEL_MASKED_TASKLOOP: \ + case ST_OMP_PARALLEL_MASKED_TASKLOOP_SIMD: case ST_OMP_PARALLEL_MASTER: \ + case ST_OMP_PARALLEL_MASTER_TASKLOOP: \ + case ST_OMP_PARALLEL_MASTER_TASKLOOP_SIMD: \ case ST_OMP_PARALLEL_SECTIONS: case ST_OMP_SECTIONS: case ST_OMP_ORDERED: \ - case ST_OMP_CRITICAL: case ST_OMP_MASTER: case ST_OMP_SINGLE: \ + case ST_OMP_CRITICAL: case ST_OMP_MASKED: case ST_OMP_MASKED_TASKLOOP: \ + case ST_OMP_MASKED_TASKLOOP_SIMD: \ + case ST_OMP_MASTER: case ST_OMP_MASTER_TASKLOOP: \ + case ST_OMP_MASTER_TASKLOOP_SIMD: case ST_OMP_SCOPE: case ST_OMP_SINGLE: \ case ST_OMP_DO: case ST_OMP_PARALLEL_DO: case ST_OMP_ATOMIC: \ case ST_OMP_WORKSHARE: case ST_OMP_PARALLEL_WORKSHARE: \ case ST_OMP_TASK: case ST_OMP_TASKGROUP: case ST_OMP_SIMD: \ @@ -1624,6 +1699,8 @@ next_statement (void) case ST_OMP_DISTRIBUTE_PARALLEL_DO_SIMD: case ST_OMP_TARGET_PARALLEL: \ case ST_OMP_TARGET_PARALLEL_DO: case ST_OMP_TARGET_PARALLEL_DO_SIMD: \ case ST_OMP_TARGET_SIMD: case ST_OMP_TASKLOOP: case ST_OMP_TASKLOOP_SIMD: \ + case ST_OMP_LOOP: case ST_OMP_PARALLEL_LOOP: case ST_OMP_TEAMS_LOOP: \ + case ST_OMP_TARGET_PARALLEL_LOOP: case ST_OMP_TARGET_TEAMS_LOOP: \ case ST_CRITICAL: \ case ST_OACC_PARALLEL_LOOP: case ST_OACC_PARALLEL: case ST_OACC_KERNELS: \ case ST_OACC_DATA: case ST_OACC_HOST_DATA: case ST_OACC_LOOP: \ @@ -1643,7 +1720,6 @@ next_statement (void) case ST_OMP_DECLARE_TARGET: case ST_OMP_DECLARE_REDUCTION: \ case ST_OMP_REQUIRES: case ST_OACC_ROUTINE: case ST_OACC_DECLARE - /* Block end statements. Errors associated with interchanging these are detected in gfc_match_end(). */ @@ -2285,6 +2361,9 @@ gfc_ascii_statement (gfc_statement st) case ST_OMP_DECLARE_TARGET: p = "!$OMP DECLARE TARGET"; break; + case ST_OMP_DEPOBJ: + p = "!$OMP DEPOBJ"; + break; case ST_OMP_DISTRIBUTE: p = "!$OMP DISTRIBUTE"; break; @@ -2330,9 +2409,27 @@ gfc_ascii_statement (gfc_statement st) case ST_OMP_END_SIMD: p = "!$OMP END SIMD"; break; + case ST_OMP_END_LOOP: + p = "!$OMP END LOOP"; + break; + case ST_OMP_END_MASKED: + p = "!$OMP END MASKED"; + break; + case ST_OMP_END_MASKED_TASKLOOP: + p = "!$OMP END MASKED TASKLOOP"; + break; + case ST_OMP_END_MASKED_TASKLOOP_SIMD: + p = "!$OMP END MASKED TASKLOOP SIMD"; + break; case ST_OMP_END_MASTER: p = "!$OMP END MASTER"; break; + case ST_OMP_END_MASTER_TASKLOOP: + p = "!$OMP END MASTER TASKLOOP"; + break; + case ST_OMP_END_MASTER_TASKLOOP_SIMD: + p = "!$OMP END MASTER TASKLOOP SIMD"; + break; case ST_OMP_END_ORDERED: p = "!$OMP END ORDERED"; break; @@ -2345,6 +2442,27 @@ gfc_ascii_statement (gfc_statement st) case ST_OMP_END_PARALLEL_DO_SIMD: p = "!$OMP END PARALLEL DO SIMD"; break; + case ST_OMP_END_PARALLEL_LOOP: + p = "!$OMP END PARALLEL LOOP"; + break; + case ST_OMP_END_PARALLEL_MASKED: + p = "!$OMP END PARALLEL MASKED"; + break; + case ST_OMP_END_PARALLEL_MASKED_TASKLOOP: + p = "!$OMP END PARALLEL MASKED TASKLOOP"; + break; + case ST_OMP_END_PARALLEL_MASKED_TASKLOOP_SIMD: + p = "!$OMP END PARALLEL MASKED TASKLOOP SIMD"; + break; + case ST_OMP_END_PARALLEL_MASTER: + p = "!$OMP END PARALLEL MASTER"; + break; + case ST_OMP_END_PARALLEL_MASTER_TASKLOOP: + p = "!$OMP END PARALLEL MASTER TASKLOOP"; + break; + case ST_OMP_END_PARALLEL_MASTER_TASKLOOP_SIMD: + p = "!$OMP END PARALLEL MASTER TASKLOOP SIMD"; + break; case ST_OMP_END_PARALLEL_SECTIONS: p = "!$OMP END PARALLEL SECTIONS"; break; @@ -2375,6 +2493,9 @@ gfc_ascii_statement (gfc_statement st) case ST_OMP_END_TARGET_PARALLEL_DO_SIMD: p = "!$OMP END TARGET PARALLEL DO SIMD"; break; + case ST_OMP_END_TARGET_PARALLEL_LOOP: + p = "!$OMP END TARGET PARALLEL LOOP"; + break; case ST_OMP_END_TARGET_SIMD: p = "!$OMP END TARGET SIMD"; break; @@ -2393,6 +2514,9 @@ gfc_ascii_statement (gfc_statement st) case ST_OMP_END_TARGET_TEAMS_DISTRIBUTE_SIMD: p = "!$OMP END TARGET TEAMS DISTRIBUTE SIMD"; break; + case ST_OMP_END_TARGET_TEAMS_LOOP: + p = "!$OMP END TARGET TEAMS LOOP"; + break; case ST_OMP_END_TASKGROUP: p = "!$OMP END TASKGROUP"; break; @@ -2417,15 +2541,39 @@ gfc_ascii_statement (gfc_statement st) case ST_OMP_END_TEAMS_DISTRIBUTE_SIMD: p = "!$OMP END TEAMS DISTRIBUTE SIMD"; break; + case ST_OMP_END_TEAMS_LOOP: + p = "!$OMP END TEAMS LOP"; + break; case ST_OMP_END_WORKSHARE: p = "!$OMP END WORKSHARE"; break; + case ST_OMP_ERROR: + p = "!$OMP ERROR"; + break; case ST_OMP_FLUSH: p = "!$OMP FLUSH"; break; + case ST_OMP_LOOP: + p = "!$OMP LOOP"; + break; + case ST_OMP_MASKED: + p = "!$OMP MASKED"; + break; + case ST_OMP_MASKED_TASKLOOP: + p = "!$OMP MASKED TASKLOOP"; + break; + case ST_OMP_MASKED_TASKLOOP_SIMD: + p = "!$OMP MASKED TASKLOOP SIMD"; + break; case ST_OMP_MASTER: p = "!$OMP MASTER"; break; + case ST_OMP_MASTER_TASKLOOP: + p = "!$OMP MASTER TASKLOOP"; + break; + case ST_OMP_MASTER_TASKLOOP_SIMD: + p = "!$OMP MASTER TASKLOOP SIMD"; + break; case ST_OMP_ORDERED: case ST_OMP_ORDERED_DEPEND: p = "!$OMP ORDERED"; @@ -2436,9 +2584,30 @@ gfc_ascii_statement (gfc_statement st) case ST_OMP_PARALLEL_DO: p = "!$OMP PARALLEL DO"; break; + case ST_OMP_PARALLEL_LOOP: + p = "!$OMP PARALLEL LOOP"; + break; case ST_OMP_PARALLEL_DO_SIMD: p = "!$OMP PARALLEL DO SIMD"; break; + case ST_OMP_PARALLEL_MASKED: + p = "!$OMP PARALLEL MASKED"; + break; + case ST_OMP_PARALLEL_MASKED_TASKLOOP: + p = "!$OMP PARALLEL MASKED TASKLOOP"; + break; + case ST_OMP_PARALLEL_MASKED_TASKLOOP_SIMD: + p = "!$OMP PARALLEL MASKED TASKLOOP SIMD"; + break; + case ST_OMP_PARALLEL_MASTER: + p = "!$OMP PARALLEL MASTER"; + break; + case ST_OMP_PARALLEL_MASTER_TASKLOOP: + p = "!$OMP PARALLEL MASTER TASKLOOP"; + break; + case ST_OMP_PARALLEL_MASTER_TASKLOOP_SIMD: + p = "!$OMP PARALLEL MASTER TASKLOOP SIMD"; + break; case ST_OMP_PARALLEL_SECTIONS: p = "!$OMP PARALLEL SECTIONS"; break; @@ -2451,6 +2620,9 @@ gfc_ascii_statement (gfc_statement st) case ST_OMP_SCAN: p = "!$OMP SCAN"; break; + case ST_OMP_SCOPE: + p = "!$OMP SCOPE"; + break; case ST_OMP_SECTIONS: p = "!$OMP SECTIONS"; break; @@ -2484,6 +2656,9 @@ gfc_ascii_statement (gfc_statement st) case ST_OMP_TARGET_PARALLEL_DO_SIMD: p = "!$OMP TARGET PARALLEL DO SIMD"; break; + case ST_OMP_TARGET_PARALLEL_LOOP: + p = "!$OMP TARGET PARALLEL LOOP"; + break; case ST_OMP_TARGET_SIMD: p = "!$OMP TARGET SIMD"; break; @@ -2502,6 +2677,9 @@ gfc_ascii_statement (gfc_statement st) case ST_OMP_TARGET_TEAMS_DISTRIBUTE_SIMD: p = "!$OMP TARGET TEAMS DISTRIBUTE SIMD"; break; + case ST_OMP_TARGET_TEAMS_LOOP: + p = "!$OMP TARGET TEAMS LOOP"; + break; case ST_OMP_TARGET_UPDATE: p = "!$OMP TARGET UPDATE"; break; @@ -2538,6 +2716,9 @@ gfc_ascii_statement (gfc_statement st) case ST_OMP_TEAMS_DISTRIBUTE_SIMD: p = "!$OMP TEAMS DISTRIBUTE SIMD"; break; + case ST_OMP_TEAMS_LOOP: + p = "!$OMP TEAMS LOOP"; + break; case ST_OMP_THREADPRIVATE: p = "!$OMP THREADPRIVATE"; break; @@ -4485,6 +4666,9 @@ gfc_check_do_variable (gfc_symtree *st) { gfc_state_data *s; + if (!st) + return 0; + for (s=gfc_state_stack; s; s = s->previous) if (s->do_variable == st) { @@ -4985,10 +5169,14 @@ parse_omp_do (gfc_statement omp_st) break; case ST_OMP_DO: omp_end_st = ST_OMP_END_DO; break; case ST_OMP_DO_SIMD: omp_end_st = ST_OMP_END_DO_SIMD; break; + case ST_OMP_LOOP: omp_end_st = ST_OMP_END_LOOP; break; case ST_OMP_PARALLEL_DO: omp_end_st = ST_OMP_END_PARALLEL_DO; break; case ST_OMP_PARALLEL_DO_SIMD: omp_end_st = ST_OMP_END_PARALLEL_DO_SIMD; break; + case ST_OMP_PARALLEL_LOOP: + omp_end_st = ST_OMP_END_PARALLEL_LOOP; + break; case ST_OMP_SIMD: omp_end_st = ST_OMP_END_SIMD; break; case ST_OMP_TARGET_PARALLEL_DO: omp_end_st = ST_OMP_END_TARGET_PARALLEL_DO; @@ -4996,6 +5184,9 @@ parse_omp_do (gfc_statement omp_st) case ST_OMP_TARGET_PARALLEL_DO_SIMD: omp_end_st = ST_OMP_END_TARGET_PARALLEL_DO_SIMD; break; + case ST_OMP_TARGET_PARALLEL_LOOP: + omp_end_st = ST_OMP_END_TARGET_PARALLEL_LOOP; + break; case ST_OMP_TARGET_SIMD: omp_end_st = ST_OMP_END_TARGET_SIMD; break; case ST_OMP_TARGET_TEAMS_DISTRIBUTE: omp_end_st = ST_OMP_END_TARGET_TEAMS_DISTRIBUTE; @@ -5009,8 +5200,31 @@ parse_omp_do (gfc_statement omp_st) case ST_OMP_TARGET_TEAMS_DISTRIBUTE_SIMD: omp_end_st = ST_OMP_END_TARGET_TEAMS_DISTRIBUTE_SIMD; break; + case ST_OMP_TARGET_TEAMS_LOOP: + omp_end_st = ST_OMP_END_TARGET_TEAMS_LOOP; + break; case ST_OMP_TASKLOOP: omp_end_st = ST_OMP_END_TASKLOOP; break; case ST_OMP_TASKLOOP_SIMD: omp_end_st = ST_OMP_END_TASKLOOP_SIMD; break; + case ST_OMP_MASKED_TASKLOOP: omp_end_st = ST_OMP_END_MASKED_TASKLOOP; break; + case ST_OMP_MASKED_TASKLOOP_SIMD: + omp_end_st = ST_OMP_END_MASKED_TASKLOOP_SIMD; + break; + case ST_OMP_MASTER_TASKLOOP: omp_end_st = ST_OMP_END_MASTER_TASKLOOP; break; + case ST_OMP_MASTER_TASKLOOP_SIMD: + omp_end_st = ST_OMP_END_MASTER_TASKLOOP_SIMD; + break; + case ST_OMP_PARALLEL_MASKED_TASKLOOP: + omp_end_st = ST_OMP_END_PARALLEL_MASKED_TASKLOOP; + break; + case ST_OMP_PARALLEL_MASKED_TASKLOOP_SIMD: + omp_end_st = ST_OMP_END_PARALLEL_MASKED_TASKLOOP_SIMD; + break; + case ST_OMP_PARALLEL_MASTER_TASKLOOP: + omp_end_st = ST_OMP_END_PARALLEL_MASTER_TASKLOOP; + break; + case ST_OMP_PARALLEL_MASTER_TASKLOOP_SIMD: + omp_end_st = ST_OMP_END_PARALLEL_MASTER_TASKLOOP_SIMD; + break; case ST_OMP_TEAMS_DISTRIBUTE: omp_end_st = ST_OMP_END_TEAMS_DISTRIBUTE; break; @@ -5023,6 +5237,9 @@ parse_omp_do (gfc_statement omp_st) case ST_OMP_TEAMS_DISTRIBUTE_SIMD: omp_end_st = ST_OMP_END_TEAMS_DISTRIBUTE_SIMD; break; + case ST_OMP_TEAMS_LOOP: + omp_end_st = ST_OMP_END_TEAMS_LOOP; + break; default: gcc_unreachable (); } if (st == omp_end_st) @@ -5251,9 +5468,18 @@ parse_omp_structured_block (gfc_statement omp_st, bool workshare_stmts_only) case ST_OMP_PARALLEL: omp_end_st = ST_OMP_END_PARALLEL; break; + case ST_OMP_PARALLEL_MASKED: + omp_end_st = ST_OMP_END_PARALLEL_MASKED; + break; + case ST_OMP_PARALLEL_MASTER: + omp_end_st = ST_OMP_END_PARALLEL_MASTER; + break; case ST_OMP_PARALLEL_SECTIONS: omp_end_st = ST_OMP_END_PARALLEL_SECTIONS; break; + case ST_OMP_SCOPE: + omp_end_st = ST_OMP_END_SCOPE; + break; case ST_OMP_SECTIONS: omp_end_st = ST_OMP_END_SECTIONS; break; @@ -5263,6 +5489,9 @@ parse_omp_structured_block (gfc_statement omp_st, bool workshare_stmts_only) case ST_OMP_CRITICAL: omp_end_st = ST_OMP_END_CRITICAL; break; + case ST_OMP_MASKED: + omp_end_st = ST_OMP_END_MASKED; + break; case ST_OMP_MASTER: omp_end_st = ST_OMP_END_MASTER; break; @@ -5281,18 +5510,6 @@ parse_omp_structured_block (gfc_statement omp_st, bool workshare_stmts_only) case ST_OMP_TARGET_TEAMS: omp_end_st = ST_OMP_END_TARGET_TEAMS; break; - case ST_OMP_TARGET_TEAMS_DISTRIBUTE: - omp_end_st = ST_OMP_END_TARGET_TEAMS_DISTRIBUTE; - break; - case ST_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO: - omp_end_st = ST_OMP_END_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO; - break; - case ST_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD: - omp_end_st = ST_OMP_END_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD; - break; - case ST_OMP_TARGET_TEAMS_DISTRIBUTE_SIMD: - omp_end_st = ST_OMP_END_TARGET_TEAMS_DISTRIBUTE_SIMD; - break; case ST_OMP_TASK: omp_end_st = ST_OMP_END_TASK; break; @@ -5305,27 +5522,9 @@ parse_omp_structured_block (gfc_statement omp_st, bool workshare_stmts_only) case ST_OMP_TEAMS_DISTRIBUTE: omp_end_st = ST_OMP_END_TEAMS_DISTRIBUTE; break; - case ST_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO: - omp_end_st = ST_OMP_END_TEAMS_DISTRIBUTE_PARALLEL_DO; - break; - case ST_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD: - omp_end_st = ST_OMP_END_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD; - break; - case ST_OMP_TEAMS_DISTRIBUTE_SIMD: - omp_end_st = ST_OMP_END_TEAMS_DISTRIBUTE_SIMD; - break; case ST_OMP_DISTRIBUTE: omp_end_st = ST_OMP_END_DISTRIBUTE; break; - case ST_OMP_DISTRIBUTE_PARALLEL_DO: - omp_end_st = ST_OMP_END_DISTRIBUTE_PARALLEL_DO; - break; - case ST_OMP_DISTRIBUTE_PARALLEL_DO_SIMD: - omp_end_st = ST_OMP_END_DISTRIBUTE_PARALLEL_DO_SIMD; - break; - case ST_OMP_DISTRIBUTE_SIMD: - omp_end_st = ST_OMP_END_DISTRIBUTE_SIMD; - break; case ST_OMP_WORKSHARE: omp_end_st = ST_OMP_END_WORKSHARE; break; @@ -5375,6 +5574,8 @@ parse_omp_structured_block (gfc_statement omp_st, bool workshare_stmts_only) break; case ST_OMP_PARALLEL: + case ST_OMP_PARALLEL_MASKED: + case ST_OMP_PARALLEL_MASTER: case ST_OMP_PARALLEL_SECTIONS: parse_omp_structured_block (st, false); break; @@ -5576,11 +5777,15 @@ parse_executable (gfc_statement st) break; case ST_OMP_PARALLEL: + case ST_OMP_PARALLEL_MASKED: + case ST_OMP_PARALLEL_MASTER: case ST_OMP_PARALLEL_SECTIONS: - case ST_OMP_SECTIONS: case ST_OMP_ORDERED: case ST_OMP_CRITICAL: + case ST_OMP_MASKED: case ST_OMP_MASTER: + case ST_OMP_SCOPE: + case ST_OMP_SECTIONS: case ST_OMP_SINGLE: case ST_OMP_TARGET: case ST_OMP_TARGET_DATA: @@ -5603,22 +5808,35 @@ parse_executable (gfc_statement st) case ST_OMP_DISTRIBUTE_SIMD: case ST_OMP_DO: case ST_OMP_DO_SIMD: + case ST_OMP_LOOP: case ST_OMP_PARALLEL_DO: case ST_OMP_PARALLEL_DO_SIMD: + case ST_OMP_PARALLEL_LOOP: + case ST_OMP_PARALLEL_MASKED_TASKLOOP: + case ST_OMP_PARALLEL_MASKED_TASKLOOP_SIMD: + case ST_OMP_PARALLEL_MASTER_TASKLOOP: + case ST_OMP_PARALLEL_MASTER_TASKLOOP_SIMD: + case ST_OMP_MASKED_TASKLOOP: + case ST_OMP_MASKED_TASKLOOP_SIMD: + case ST_OMP_MASTER_TASKLOOP: + case ST_OMP_MASTER_TASKLOOP_SIMD: case ST_OMP_SIMD: case ST_OMP_TARGET_PARALLEL_DO: case ST_OMP_TARGET_PARALLEL_DO_SIMD: + case ST_OMP_TARGET_PARALLEL_LOOP: case ST_OMP_TARGET_SIMD: case ST_OMP_TARGET_TEAMS_DISTRIBUTE: case ST_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO: case ST_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD: case ST_OMP_TARGET_TEAMS_DISTRIBUTE_SIMD: + case ST_OMP_TARGET_TEAMS_LOOP: case ST_OMP_TASKLOOP: case ST_OMP_TASKLOOP_SIMD: case ST_OMP_TEAMS_DISTRIBUTE: case ST_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO: case ST_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD: case ST_OMP_TEAMS_DISTRIBUTE_SIMD: + case ST_OMP_TEAMS_LOOP: st = parse_omp_do (st); if (st == ST_IMPLIED_ENDDO) return st; diff --git a/gcc/fortran/primary.c b/gcc/fortran/primary.c index a6df885..56a78d6 100644 --- a/gcc/fortran/primary.c +++ b/gcc/fortran/primary.c @@ -1786,21 +1786,21 @@ match_arg_list_function (gfc_actual_arglist *result) switch (name[0]) { case 'l': - if (gfc_str_startswith (name, "loc")) + if (startswith (name, "loc")) { result->name = "%LOC"; break; } /* FALLTHRU */ case 'r': - if (gfc_str_startswith (name, "ref")) + if (startswith (name, "ref")) { result->name = "%REF"; break; } /* FALLTHRU */ case 'v': - if (gfc_str_startswith (name, "val")) + if (startswith (name, "val")) { result->name = "%VAL"; break; @@ -2779,7 +2779,7 @@ gfc_expr_attr (gfc_expr *e) && e->value.function.isym->transformational && e->ts.type == BT_CLASS) attr = CLASS_DATA (e)->attr; - else + else if (e->symtree) attr = gfc_variable_attr (e, NULL); /* TODO: NULL() returns pointers. May have to take care of this diff --git a/gcc/fortran/resolve.c b/gcc/fortran/resolve.c index 32015c2..8e5ed1c 100644 --- a/gcc/fortran/resolve.c +++ b/gcc/fortran/resolve.c @@ -804,6 +804,15 @@ resolve_entries (gfc_namespace *ns) the same string length, i.e. both len=*, or both len=4. Having both len=<variable> is also possible, but difficult to check at compile time. */ + else if (ts->type == BT_CHARACTER + && (el->sym->result->attr.allocatable + != ns->entries->sym->result->attr.allocatable)) + { + gfc_error ("Function %s at %L has entry %s with mismatched " + "characteristics", ns->entries->sym->name, + &ns->entries->sym->declared_at, el->sym->name); + return; + } else if (ts->type == BT_CHARACTER && ts->u.cl && fts->u.cl && (((ts->u.cl->length && !fts->u.cl->length) ||(!ts->u.cl->length && fts->u.cl->length)) @@ -970,7 +979,7 @@ resolve_common_vars (gfc_common_head *common_block, bool named_common) } if (UNLIMITED_POLY (csym)) - gfc_error_now ("%qs in cannot appear in COMMON at %L " + gfc_error_now ("%qs at %L cannot appear in COMMON " "[F2008:C5100]", csym->name, &csym->declared_at); if (csym->ts.type != BT_DERIVED) @@ -3994,7 +4003,8 @@ static bool resolve_operator (gfc_expr *e) { gfc_expr *op1, *op2; - char msg[200]; + /* One error uses 3 names; additional space for wording (also via gettext). */ + char msg[3*GFC_MAX_SYMBOL_LEN + 1 + 50]; bool dual_locus_error; bool t = true; @@ -4047,7 +4057,8 @@ resolve_operator (gfc_expr *e) if ((op1 && op1->expr_type == EXPR_NULL) || (op2 && op2->expr_type == EXPR_NULL)) { - sprintf (msg, _("Invalid context for NULL() pointer at %%L")); + snprintf (msg, sizeof (msg), + _("Invalid context for NULL() pointer at %%L")); goto bad_op; } @@ -4063,8 +4074,9 @@ resolve_operator (gfc_expr *e) break; } - sprintf (msg, _("Operand of unary numeric operator %%<%s%%> at %%L is %s"), - gfc_op2string (e->value.op.op), gfc_typename (e)); + snprintf (msg, sizeof (msg), + _("Operand of unary numeric operator %%<%s%%> at %%L is %s"), + gfc_op2string (e->value.op.op), gfc_typename (e)); goto bad_op; case INTRINSIC_PLUS: @@ -4079,14 +4091,14 @@ resolve_operator (gfc_expr *e) } if (op1->ts.type == BT_DERIVED || op2->ts.type == BT_DERIVED) - sprintf (msg, - _("Unexpected derived-type entities in binary intrinsic " - "numeric operator %%<%s%%> at %%L"), + snprintf (msg, sizeof (msg), + _("Unexpected derived-type entities in binary intrinsic " + "numeric operator %%<%s%%> at %%L"), gfc_op2string (e->value.op.op)); else - sprintf (msg, - _("Operands of binary numeric operator %%<%s%%> at %%L are %s/%s"), - gfc_op2string (e->value.op.op), gfc_typename (op1), + snprintf (msg, sizeof(msg), + _("Operands of binary numeric operator %%<%s%%> at %%L are %s/%s"), + gfc_op2string (e->value.op.op), gfc_typename (op1), gfc_typename (op2)); goto bad_op; @@ -4099,9 +4111,9 @@ resolve_operator (gfc_expr *e) break; } - sprintf (msg, - _("Operands of string concatenation operator at %%L are %s/%s"), - gfc_typename (op1), gfc_typename (op2)); + snprintf (msg, sizeof (msg), + _("Operands of string concatenation operator at %%L are %s/%s"), + gfc_typename (op1), gfc_typename (op2)); goto bad_op; case INTRINSIC_AND: @@ -4142,9 +4154,10 @@ resolve_operator (gfc_expr *e) goto simplify_op; } - sprintf (msg, _("Operands of logical operator %%<%s%%> at %%L are %s/%s"), - gfc_op2string (e->value.op.op), gfc_typename (op1), - gfc_typename (op2)); + snprintf (msg, sizeof (msg), + _("Operands of logical operator %%<%s%%> at %%L are %s/%s"), + gfc_op2string (e->value.op.op), gfc_typename (op1), + gfc_typename (op2)); goto bad_op; @@ -4165,8 +4178,8 @@ resolve_operator (gfc_expr *e) break; } - sprintf (msg, _("Operand of .not. operator at %%L is %s"), - gfc_typename (op1)); + snprintf (msg, sizeof (msg), _("Operand of .not. operator at %%L is %s"), + gfc_typename (op1)); goto bad_op; case INTRINSIC_GT: @@ -4276,16 +4289,16 @@ resolve_operator (gfc_expr *e) } if (op1->ts.type == BT_LOGICAL && op2->ts.type == BT_LOGICAL) - sprintf (msg, - _("Logicals at %%L must be compared with %s instead of %s"), - (e->value.op.op == INTRINSIC_EQ - || e->value.op.op == INTRINSIC_EQ_OS) - ? ".eqv." : ".neqv.", gfc_op2string (e->value.op.op)); + snprintf (msg, sizeof (msg), + _("Logicals at %%L must be compared with %s instead of %s"), + (e->value.op.op == INTRINSIC_EQ + || e->value.op.op == INTRINSIC_EQ_OS) + ? ".eqv." : ".neqv.", gfc_op2string (e->value.op.op)); else - sprintf (msg, - _("Operands of comparison operator %%<%s%%> at %%L are %s/%s"), - gfc_op2string (e->value.op.op), gfc_typename (op1), - gfc_typename (op2)); + snprintf (msg, sizeof (msg), + _("Operands of comparison operator %%<%s%%> at %%L are %s/%s"), + gfc_op2string (e->value.op.op), gfc_typename (op1), + gfc_typename (op2)); goto bad_op; @@ -4296,19 +4309,23 @@ resolve_operator (gfc_expr *e) const char *guessed; guessed = lookup_uop_fuzzy (name, e->value.op.uop->ns->uop_root); if (guessed) - sprintf (msg, _("Unknown operator %%<%s%%> at %%L; did you mean '%s'?"), - name, guessed); + snprintf (msg, sizeof (msg), + _("Unknown operator %%<%s%%> at %%L; did you mean '%s'?"), + name, guessed); else - sprintf (msg, _("Unknown operator %%<%s%%> at %%L"), name); + snprintf (msg, sizeof (msg), _("Unknown operator %%<%s%%> at %%L"), + name); } else if (op2 == NULL) - sprintf (msg, _("Operand of user operator %%<%s%%> at %%L is %s"), - e->value.op.uop->name, gfc_typename (op1)); + snprintf (msg, sizeof (msg), + _("Operand of user operator %%<%s%%> at %%L is %s"), + e->value.op.uop->name, gfc_typename (op1)); else { - sprintf (msg, _("Operands of user operator %%<%s%%> at %%L are %s/%s"), - e->value.op.uop->name, gfc_typename (op1), - gfc_typename (op2)); + snprintf (msg, sizeof (msg), + _("Operands of user operator %%<%s%%> at %%L are %s/%s"), + e->value.op.uop->name, gfc_typename (op1), + gfc_typename (op2)); e->value.op.uop->op->sym->attr.referenced = 1; } @@ -4391,8 +4408,8 @@ resolve_operator (gfc_expr *e) /* Try user-defined operators, and otherwise throw an error. */ dual_locus_error = true; - sprintf (msg, - _("Inconsistent ranks for operator at %%L and %%L")); + snprintf (msg, sizeof (msg), + _("Inconsistent ranks for operator at %%L and %%L")); goto bad_op; } } @@ -5701,7 +5718,6 @@ resolve_variable (gfc_expr *e) part_ref. */ gfc_ref *ref = gfc_get_ref (); ref->type = REF_ARRAY; - ref->u.ar = *gfc_get_array_ref(); ref->u.ar.type = AR_FULL; if (sym->as) { @@ -7813,8 +7829,9 @@ resolve_allocate_expr (gfc_expr *e, gfc_code *code, bool *array_alloc_wo_spec) } } - /* Check for F08:C628. */ - if (allocatable == 0 && pointer == 0 && !unlimited) + /* Check for F08:C628 (F2018:C932). Each allocate-object shall be a data + pointer or an allocatable variable. */ + if (allocatable == 0 && pointer == 0) { gfc_error ("Allocate-object at %L must be ALLOCATABLE or a POINTER", &e->where); @@ -8148,16 +8165,21 @@ resolve_allocate_deallocate (gfc_code *code, const char *fcn) /* Check the stat variable. */ if (stat) { - gfc_check_vardef_context (stat, false, false, false, - _("STAT variable")); + if (!gfc_check_vardef_context (stat, false, false, false, + _("STAT variable"))) + goto done_stat; - if ((stat->ts.type != BT_INTEGER - && !(stat->ref && (stat->ref->type == REF_ARRAY - || stat->ref->type == REF_COMPONENT))) + if (stat->ts.type != BT_INTEGER || stat->rank > 0) gfc_error ("Stat-variable at %L must be a scalar INTEGER " "variable", &stat->where); + if (stat->expr_type == EXPR_CONSTANT || stat->symtree == NULL) + goto done_stat; + + /* F2018:9.7.4: The stat-variable shall not be allocated or deallocated + * within the ALLOCATE or DEALLOCATE statement in which it appears ... + */ for (p = code->ext.alloc.list; p; p = p->next) if (p->expr->symtree->n.sym->name == stat->symtree->n.sym->name) { @@ -8185,6 +8207,8 @@ resolve_allocate_deallocate (gfc_code *code, const char *fcn) } } +done_stat: + /* Check the errmsg variable. */ if (errmsg) { @@ -8192,22 +8216,26 @@ resolve_allocate_deallocate (gfc_code *code, const char *fcn) gfc_warning (0, "ERRMSG at %L is useless without a STAT tag", &errmsg->where); - gfc_check_vardef_context (errmsg, false, false, false, - _("ERRMSG variable")); + if (!gfc_check_vardef_context (errmsg, false, false, false, + _("ERRMSG variable"))) + goto done_errmsg; /* F18:R928 alloc-opt is ERRMSG = errmsg-variable F18:R930 errmsg-variable is scalar-default-char-variable F18:R906 default-char-variable is variable F18:C906 default-char-variable shall be default character. */ - if ((errmsg->ts.type != BT_CHARACTER - && !(errmsg->ref - && (errmsg->ref->type == REF_ARRAY - || errmsg->ref->type == REF_COMPONENT))) + if (errmsg->ts.type != BT_CHARACTER || errmsg->rank > 0 || errmsg->ts.kind != gfc_default_character_kind) gfc_error ("ERRMSG variable at %L shall be a scalar default CHARACTER " "variable", &errmsg->where); + if (errmsg->expr_type == EXPR_CONSTANT || errmsg->symtree == NULL) + goto done_errmsg; + + /* F2018:9.7.5: The errmsg-variable shall not be allocated or deallocated + * within the ALLOCATE or DEALLOCATE statement in which it appears ... + */ for (p = code->ext.alloc.list; p; p = p->next) if (p->expr->symtree->n.sym->name == errmsg->symtree->n.sym->name) { @@ -8235,6 +8263,8 @@ resolve_allocate_deallocate (gfc_code *code, const char *fcn) } } +done_errmsg: + /* Check that an allocate-object appears only once in the statement. */ for (p = code->ext.alloc.list; p; p = p->next) @@ -9246,7 +9276,7 @@ resolve_select_type (gfc_code *code, gfc_namespace *old_ns) gfc_code *class_is = NULL, *default_case = NULL; gfc_case *c; gfc_symtree *st; - char name[GFC_MAX_SYMBOL_LEN]; + char name[GFC_MAX_SYMBOL_LEN + 12 + 1]; gfc_namespace *ns; int error = 0; int rank = 0; @@ -10216,19 +10246,27 @@ resolve_sync (gfc_code *code) /* Check STAT. */ gfc_resolve_expr (code->expr2); - if (code->expr2 - && (code->expr2->ts.type != BT_INTEGER || code->expr2->rank != 0 - || code->expr2->expr_type != EXPR_VARIABLE)) - gfc_error ("STAT= argument at %L must be a scalar INTEGER variable", - &code->expr2->where); + if (code->expr2) + { + if (code->expr2->ts.type != BT_INTEGER || code->expr2->rank != 0) + gfc_error ("STAT= argument at %L must be a scalar INTEGER variable", + &code->expr2->where); + else + gfc_check_vardef_context (code->expr2, false, false, false, + _("STAT variable")); + } /* Check ERRMSG. */ gfc_resolve_expr (code->expr3); - if (code->expr3 - && (code->expr3->ts.type != BT_CHARACTER || code->expr3->rank != 0 - || code->expr3->expr_type != EXPR_VARIABLE)) - gfc_error ("ERRMSG= argument at %L must be a scalar CHARACTER variable", - &code->expr3->where); + if (code->expr3) + { + if (code->expr3->ts.type != BT_CHARACTER || code->expr3->rank != 0) + gfc_error ("ERRMSG= argument at %L must be a scalar CHARACTER variable", + &code->expr3->where); + else + gfc_check_vardef_context (code->expr3, false, false, false, + _("ERRMSG variable")); + } } @@ -10789,15 +10827,30 @@ gfc_resolve_blocks (gfc_code *b, gfc_namespace *ns) case EXEC_OMP_DISTRIBUTE_SIMD: case EXEC_OMP_DO: case EXEC_OMP_DO_SIMD: + case EXEC_OMP_ERROR: + case EXEC_OMP_LOOP: + case EXEC_OMP_MASKED: + case EXEC_OMP_MASKED_TASKLOOP: + case EXEC_OMP_MASKED_TASKLOOP_SIMD: case EXEC_OMP_MASTER: + case EXEC_OMP_MASTER_TASKLOOP: + case EXEC_OMP_MASTER_TASKLOOP_SIMD: case EXEC_OMP_ORDERED: case EXEC_OMP_PARALLEL: case EXEC_OMP_PARALLEL_DO: case EXEC_OMP_PARALLEL_DO_SIMD: + case EXEC_OMP_PARALLEL_LOOP: + case EXEC_OMP_PARALLEL_MASKED: + case EXEC_OMP_PARALLEL_MASKED_TASKLOOP: + case EXEC_OMP_PARALLEL_MASKED_TASKLOOP_SIMD: + case EXEC_OMP_PARALLEL_MASTER: + case EXEC_OMP_PARALLEL_MASTER_TASKLOOP: + case EXEC_OMP_PARALLEL_MASTER_TASKLOOP_SIMD: case EXEC_OMP_PARALLEL_SECTIONS: case EXEC_OMP_PARALLEL_WORKSHARE: case EXEC_OMP_SECTIONS: case EXEC_OMP_SIMD: + case EXEC_OMP_SCOPE: case EXEC_OMP_SINGLE: case EXEC_OMP_TARGET: case EXEC_OMP_TARGET_DATA: @@ -10806,12 +10859,14 @@ gfc_resolve_blocks (gfc_code *b, gfc_namespace *ns) case EXEC_OMP_TARGET_PARALLEL: case EXEC_OMP_TARGET_PARALLEL_DO: case EXEC_OMP_TARGET_PARALLEL_DO_SIMD: + case EXEC_OMP_TARGET_PARALLEL_LOOP: case EXEC_OMP_TARGET_SIMD: case EXEC_OMP_TARGET_TEAMS: case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE: case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO: case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD: case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_SIMD: + case EXEC_OMP_TARGET_TEAMS_LOOP: case EXEC_OMP_TARGET_UPDATE: case EXEC_OMP_TASK: case EXEC_OMP_TASKGROUP: @@ -10823,6 +10878,7 @@ gfc_resolve_blocks (gfc_code *b, gfc_namespace *ns) case EXEC_OMP_TEAMS_DISTRIBUTE: case EXEC_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO: case EXEC_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD: + case EXEC_OMP_TEAMS_LOOP: case EXEC_OMP_TEAMS_DISTRIBUTE_SIMD: case EXEC_OMP_WORKSHARE: break; @@ -11755,6 +11811,12 @@ gfc_resolve_code (gfc_code *code, gfc_namespace *ns) case EXEC_OMP_PARALLEL: case EXEC_OMP_PARALLEL_DO: case EXEC_OMP_PARALLEL_DO_SIMD: + case EXEC_OMP_PARALLEL_MASKED: + case EXEC_OMP_PARALLEL_MASKED_TASKLOOP: + case EXEC_OMP_PARALLEL_MASKED_TASKLOOP_SIMD: + case EXEC_OMP_PARALLEL_MASTER: + case EXEC_OMP_PARALLEL_MASTER_TASKLOOP: + case EXEC_OMP_PARALLEL_MASTER_TASKLOOP_SIMD: case EXEC_OMP_PARALLEL_SECTIONS: case EXEC_OMP_TARGET_PARALLEL: case EXEC_OMP_TARGET_PARALLEL_DO: @@ -11930,6 +11992,12 @@ start: if (resolve_ordinary_assign (code, ns)) { + if (omp_workshare_flag) + { + gfc_error ("Expected intrinsic assignment in OMP WORKSHARE " + "at %L", &code->loc); + break; + } if (code->op == EXEC_COMPCALL) goto compcall; else @@ -11991,6 +12059,7 @@ start: /* Assigning a class object always is a regular assign. */ if (code->expr2->ts.type == BT_CLASS && code->expr1->ts.type == BT_CLASS + && CLASS_DATA (code->expr2) && !CLASS_DATA (code->expr2)->attr.dimension && !(gfc_expr_attr (code->expr1).proc_pointer && code->expr2->expr_type == EXPR_VARIABLE @@ -12189,15 +12258,24 @@ start: case EXEC_OMP_CANCELLATION_POINT: case EXEC_OMP_CRITICAL: case EXEC_OMP_FLUSH: + case EXEC_OMP_DEPOBJ: case EXEC_OMP_DISTRIBUTE: case EXEC_OMP_DISTRIBUTE_PARALLEL_DO: case EXEC_OMP_DISTRIBUTE_PARALLEL_DO_SIMD: case EXEC_OMP_DISTRIBUTE_SIMD: case EXEC_OMP_DO: case EXEC_OMP_DO_SIMD: + case EXEC_OMP_ERROR: + case EXEC_OMP_LOOP: case EXEC_OMP_MASTER: + case EXEC_OMP_MASTER_TASKLOOP: + case EXEC_OMP_MASTER_TASKLOOP_SIMD: + case EXEC_OMP_MASKED: + case EXEC_OMP_MASKED_TASKLOOP: + case EXEC_OMP_MASKED_TASKLOOP_SIMD: case EXEC_OMP_ORDERED: case EXEC_OMP_SCAN: + case EXEC_OMP_SCOPE: case EXEC_OMP_SECTIONS: case EXEC_OMP_SIMD: case EXEC_OMP_SINGLE: @@ -12208,12 +12286,14 @@ start: case EXEC_OMP_TARGET_PARALLEL: case EXEC_OMP_TARGET_PARALLEL_DO: case EXEC_OMP_TARGET_PARALLEL_DO_SIMD: + case EXEC_OMP_TARGET_PARALLEL_LOOP: case EXEC_OMP_TARGET_SIMD: case EXEC_OMP_TARGET_TEAMS: case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE: case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO: case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD: case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_SIMD: + case EXEC_OMP_TARGET_TEAMS_LOOP: case EXEC_OMP_TARGET_UPDATE: case EXEC_OMP_TASK: case EXEC_OMP_TASKGROUP: @@ -12226,6 +12306,7 @@ start: case EXEC_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO: case EXEC_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD: case EXEC_OMP_TEAMS_DISTRIBUTE_SIMD: + case EXEC_OMP_TEAMS_LOOP: case EXEC_OMP_WORKSHARE: gfc_resolve_omp_directive (code, ns); break; @@ -12233,6 +12314,13 @@ start: case EXEC_OMP_PARALLEL: case EXEC_OMP_PARALLEL_DO: case EXEC_OMP_PARALLEL_DO_SIMD: + case EXEC_OMP_PARALLEL_LOOP: + case EXEC_OMP_PARALLEL_MASKED: + case EXEC_OMP_PARALLEL_MASKED_TASKLOOP: + case EXEC_OMP_PARALLEL_MASKED_TASKLOOP_SIMD: + case EXEC_OMP_PARALLEL_MASTER: + case EXEC_OMP_PARALLEL_MASTER_TASKLOOP: + case EXEC_OMP_PARALLEL_MASTER_TASKLOOP_SIMD: case EXEC_OMP_PARALLEL_SECTIONS: case EXEC_OMP_PARALLEL_WORKSHARE: omp_workshare_save = omp_workshare_flag; @@ -16029,7 +16117,8 @@ resolve_symbol (gfc_symbol *sym) && !(sym->ns->save_all && !sym->attr.automatic) && sym->module == NULL && (sym->ns->proc_name == NULL - || sym->ns->proc_name->attr.flavor != FL_MODULE)) + || (sym->ns->proc_name->attr.flavor != FL_MODULE + && !sym->ns->proc_name->attr.is_main_program))) gfc_error ("Threadprivate at %L isn't SAVEd", &sym->declared_at); /* Check omp declare target restrictions. */ @@ -16040,7 +16129,8 @@ resolve_symbol (gfc_symbol *sym) && (!sym->attr.in_common && sym->module == NULL && (sym->ns->proc_name == NULL - || sym->ns->proc_name->attr.flavor != FL_MODULE))) + || (sym->ns->proc_name->attr.flavor != FL_MODULE + && !sym->ns->proc_name->attr.is_main_program)))) gfc_error ("!$OMP DECLARE TARGET variable %qs at %L isn't SAVEd", sym->name, &sym->declared_at); diff --git a/gcc/fortran/scanner.c b/gcc/fortran/scanner.c index 74c5461..39db099 100644 --- a/gcc/fortran/scanner.c +++ b/gcc/fortran/scanner.c @@ -942,6 +942,8 @@ skip_fixed_omp_sentinel (locus *start) && (continue_flag || c == ' ' || c == '\t' || c == '0')) { + if (c == ' ' || c == '\t' || c == '0') + openacc_flag = 0; do c = next_char (); while (gfc_is_whitespace (c)); @@ -971,6 +973,8 @@ skip_fixed_oacc_sentinel (locus *start) && (continue_flag || c == ' ' || c == '\t' || c == '0')) { + if (c == ' ' || c == '\t' || c == '0') + openmp_flag = 0; do c = next_char (); while (gfc_is_whitespace (c)); @@ -1205,6 +1209,7 @@ gfc_skip_comments (void) gfc_char_t gfc_next_char_literal (gfc_instring in_string) { + static locus omp_acc_err_loc = {}; locus old_loc; int i, prev_openmp_flag, prev_openacc_flag; gfc_char_t c; @@ -1403,14 +1408,16 @@ restart: { if (gfc_wide_tolower (c) != (unsigned char) "!$acc"[i]) is_openmp = 1; - if (i == 4) - old_loc = gfc_current_locus; } - gfc_error (is_openmp - ? G_("Wrong OpenACC continuation at %C: " - "expected !$ACC, got !$OMP") - : G_("Wrong OpenMP continuation at %C: " - "expected !$OMP, got !$ACC")); + if (omp_acc_err_loc.nextc != gfc_current_locus.nextc + || omp_acc_err_loc.lb != gfc_current_locus.lb) + gfc_error_now (is_openmp + ? G_("Wrong OpenACC continuation at %C: " + "expected !$ACC, got !$OMP") + : G_("Wrong OpenMP continuation at %C: " + "expected !$OMP, got !$ACC")); + omp_acc_err_loc = gfc_current_locus; + goto not_continuation; } if (c != '&') @@ -1511,11 +1518,15 @@ restart: if (gfc_wide_tolower (c) != (unsigned char) "*$acc"[i]) is_openmp = 1; } - gfc_error (is_openmp - ? G_("Wrong OpenACC continuation at %C: " - "expected !$ACC, got !$OMP") - : G_("Wrong OpenMP continuation at %C: " - "expected !$OMP, got !$ACC")); + if (omp_acc_err_loc.nextc != gfc_current_locus.nextc + || omp_acc_err_loc.lb != gfc_current_locus.lb) + gfc_error_now (is_openmp + ? G_("Wrong OpenACC continuation at %C: " + "expected !$ACC, got !$OMP") + : G_("Wrong OpenMP continuation at %C: " + "expected !$OMP, got !$ACC")); + omp_acc_err_loc = gfc_current_locus; + goto not_continuation; } else if (!openmp_flag && !openacc_flag) for (i = 0; i < 5; i++) diff --git a/gcc/fortran/simplify.c b/gcc/fortran/simplify.c index 388aca7..b46cbfa 100644 --- a/gcc/fortran/simplify.c +++ b/gcc/fortran/simplify.c @@ -4512,6 +4512,49 @@ gfc_simplify_leadz (gfc_expr *e) } +/* Check for constant length of a substring. */ + +static bool +substring_has_constant_len (gfc_expr *e) +{ + gfc_ref *ref; + HOST_WIDE_INT istart, iend, length; + bool equal_length = false; + + if (e->ts.type != BT_CHARACTER) + return false; + + for (ref = e->ref; ref; ref = ref->next) + if (ref->type != REF_COMPONENT && ref->type != REF_ARRAY) + break; + + if (!ref + || ref->type != REF_SUBSTRING + || !ref->u.ss.start + || ref->u.ss.start->expr_type != EXPR_CONSTANT + || !ref->u.ss.end + || ref->u.ss.end->expr_type != EXPR_CONSTANT) + return false; + + /* Basic checks on substring starting and ending indices. */ + if (!gfc_resolve_substring (ref, &equal_length)) + return false; + + istart = gfc_mpz_get_hwi (ref->u.ss.start->value.integer); + iend = gfc_mpz_get_hwi (ref->u.ss.end->value.integer); + + if (istart <= iend) + length = iend - istart + 1; + else + length = 0; + + /* Fix substring length. */ + e->value.character.length = length; + + return true; +} + + gfc_expr * gfc_simplify_len (gfc_expr *e, gfc_expr *kind) { @@ -4521,7 +4564,8 @@ gfc_simplify_len (gfc_expr *e, gfc_expr *kind) if (k == -1) return &gfc_bad_expr; - if (e->expr_type == EXPR_CONSTANT) + if (e->expr_type == EXPR_CONSTANT + || substring_has_constant_len (e)) { result = gfc_get_constant_expr (BT_INTEGER, k, &e->where); mpz_set_si (result->value.integer, e->value.character.length); @@ -8123,8 +8167,8 @@ gfc_simplify_transpose (gfc_expr *matrix) &matrix->where); result->rank = 2; result->shape = gfc_get_shape (result->rank); - mpz_set (result->shape[0], matrix->shape[1]); - mpz_set (result->shape[1], matrix->shape[0]); + mpz_init_set (result->shape[0], matrix->shape[1]); + mpz_init_set (result->shape[1], matrix->shape[0]); if (matrix->ts.type == BT_CHARACTER) result->ts.u.cl = matrix->ts.u.cl; diff --git a/gcc/fortran/st.c b/gcc/fortran/st.c index 13b3880..6bf730c 100644 --- a/gcc/fortran/st.c +++ b/gcc/fortran/st.c @@ -218,20 +218,36 @@ gfc_free_statement (gfc_code *p) case EXEC_OMP_CANCEL: case EXEC_OMP_CANCELLATION_POINT: case EXEC_OMP_CRITICAL: + case EXEC_OMP_DEPOBJ: case EXEC_OMP_DISTRIBUTE: case EXEC_OMP_DISTRIBUTE_PARALLEL_DO: case EXEC_OMP_DISTRIBUTE_PARALLEL_DO_SIMD: case EXEC_OMP_DISTRIBUTE_SIMD: case EXEC_OMP_DO: case EXEC_OMP_DO_SIMD: + case EXEC_OMP_ERROR: + case EXEC_OMP_LOOP: case EXEC_OMP_END_SINGLE: + case EXEC_OMP_MASKED_TASKLOOP: + case EXEC_OMP_MASKED_TASKLOOP_SIMD: + case EXEC_OMP_MASTER_TASKLOOP: + case EXEC_OMP_MASTER_TASKLOOP_SIMD: case EXEC_OMP_ORDERED: + case EXEC_OMP_MASKED: case EXEC_OMP_PARALLEL: case EXEC_OMP_PARALLEL_DO: case EXEC_OMP_PARALLEL_DO_SIMD: + case EXEC_OMP_PARALLEL_LOOP: + case EXEC_OMP_PARALLEL_MASKED: + case EXEC_OMP_PARALLEL_MASKED_TASKLOOP: + case EXEC_OMP_PARALLEL_MASKED_TASKLOOP_SIMD: + case EXEC_OMP_PARALLEL_MASTER: + case EXEC_OMP_PARALLEL_MASTER_TASKLOOP: + case EXEC_OMP_PARALLEL_MASTER_TASKLOOP_SIMD: case EXEC_OMP_PARALLEL_SECTIONS: case EXEC_OMP_PARALLEL_WORKSHARE: case EXEC_OMP_SCAN: + case EXEC_OMP_SCOPE: case EXEC_OMP_SECTIONS: case EXEC_OMP_SIMD: case EXEC_OMP_SINGLE: @@ -242,12 +258,14 @@ gfc_free_statement (gfc_code *p) case EXEC_OMP_TARGET_PARALLEL: case EXEC_OMP_TARGET_PARALLEL_DO: case EXEC_OMP_TARGET_PARALLEL_DO_SIMD: + case EXEC_OMP_TARGET_PARALLEL_LOOP: case EXEC_OMP_TARGET_SIMD: case EXEC_OMP_TARGET_TEAMS: case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE: case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO: case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD: case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_SIMD: + case EXEC_OMP_TARGET_TEAMS_LOOP: case EXEC_OMP_TARGET_UPDATE: case EXEC_OMP_TASK: case EXEC_OMP_TASKLOOP: @@ -257,6 +275,7 @@ gfc_free_statement (gfc_code *p) case EXEC_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO: case EXEC_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD: case EXEC_OMP_TEAMS_DISTRIBUTE_SIMD: + case EXEC_OMP_TEAMS_LOOP: case EXEC_OMP_WORKSHARE: gfc_free_omp_clauses (p->ext.omp_clauses); break; @@ -266,7 +285,7 @@ gfc_free_statement (gfc_code *p) break; case EXEC_OMP_FLUSH: - gfc_free_omp_namelist (p->ext.omp_namelist); + gfc_free_omp_namelist (p->ext.omp_namelist, false); break; case EXEC_OMP_BARRIER: diff --git a/gcc/fortran/symbol.c b/gcc/fortran/symbol.c index e982374..6d61bf4 100644 --- a/gcc/fortran/symbol.c +++ b/gcc/fortran/symbol.c @@ -4391,7 +4391,7 @@ get_iso_c_binding_dt (int sym_id) if (dt_list->from_intmod != INTMOD_NONE && dt_list->intmod_sym_id == sym_id) return dt_list; - + dt_list = dt_list->dt_next; } } diff --git a/gcc/fortran/target-memory.c b/gcc/fortran/target-memory.c index cfa8402..7b21a9e 100644 --- a/gcc/fortran/target-memory.c +++ b/gcc/fortran/target-memory.c @@ -534,6 +534,9 @@ gfc_interpret_derived (unsigned char *buffer, size_t buffer_size, gfc_expr *resu { int n; + if (cmp->as->type != AS_EXPLICIT) + return 0; + e->expr_type = EXPR_ARRAY; e->rank = cmp->as->rank; diff --git a/gcc/fortran/trans-array.c b/gcc/fortran/trans-array.c index be5eb89..0d013de 100644 --- a/gcc/fortran/trans-array.c +++ b/gcc/fortran/trans-array.c @@ -860,16 +860,25 @@ gfc_get_array_span (tree desc, gfc_expr *expr) size of the array. Attempt to deal with unbounded character types if possible. Otherwise, return NULL_TREE. */ tmp = gfc_get_element_type (TREE_TYPE (desc)); - if (tmp && TREE_CODE (tmp) == ARRAY_TYPE - && (TYPE_MAX_VALUE (TYPE_DOMAIN (tmp)) == NULL_TREE - || integer_zerop (TYPE_MAX_VALUE (TYPE_DOMAIN (tmp))))) - { - if (expr->expr_type == EXPR_VARIABLE - && expr->ts.type == BT_CHARACTER) - tmp = fold_convert (gfc_array_index_type, - gfc_get_expr_charlen (expr)); - else - tmp = NULL_TREE; + if (tmp && TREE_CODE (tmp) == ARRAY_TYPE && TYPE_STRING_FLAG (tmp)) + { + gcc_assert (expr->ts.type == BT_CHARACTER); + + tmp = gfc_get_character_len_in_bytes (tmp); + + if (tmp == NULL_TREE || integer_zerop (tmp)) + { + tree bs; + + tmp = gfc_get_expr_charlen (expr); + tmp = fold_convert (gfc_array_index_type, tmp); + bs = build_int_cst (gfc_array_index_type, expr->ts.kind); + tmp = fold_build2_loc (input_location, MULT_EXPR, + gfc_array_index_type, tmp, bs); + } + + tmp = (tmp && !integer_zerop (tmp)) + ? (fold_convert (gfc_array_index_type, tmp)) : (NULL_TREE); } else tmp = fold_convert (gfc_array_index_type, @@ -1403,9 +1412,6 @@ gfc_trans_create_temp_array (stmtblock_t * pre, stmtblock_t * post, gfc_ss * ss, desc = gfc_create_var (type, "atmp"); GFC_DECL_PACKED_ARRAY (desc) = 1; - info->descriptor = desc; - size = gfc_index_one_node; - /* Emit a DECL_EXPR for the variable sized array type in GFC_TYPE_ARRAY_DATAPTR_TYPE so the gimplification of its type sizes works correctly. */ @@ -1416,9 +1422,40 @@ gfc_trans_create_temp_array (stmtblock_t * pre, stmtblock_t * post, gfc_ss * ss, gfc_add_expr_to_block (pre, build1 (DECL_EXPR, arraytype, TYPE_NAME (arraytype))); - /* Fill in the array dtype. */ - tmp = gfc_conv_descriptor_dtype (desc); - gfc_add_modify (pre, tmp, gfc_get_dtype (TREE_TYPE (desc))); + if (class_expr != NULL_TREE) + { + tree class_data; + tree dtype; + + /* Create a class temporary. */ + tmp = gfc_create_var (TREE_TYPE (class_expr), "ctmp"); + gfc_add_modify (pre, tmp, class_expr); + + /* Assign the new descriptor to the _data field. This allows the + vptr _copy to be used for scalarized assignment since the class + temporary can be found from the descriptor. */ + class_data = gfc_class_data_get (tmp); + tmp = fold_build1_loc (input_location, VIEW_CONVERT_EXPR, + TREE_TYPE (desc), desc); + gfc_add_modify (pre, class_data, tmp); + + /* Take the dtype from the class expression. */ + dtype = gfc_conv_descriptor_dtype (gfc_class_data_get (class_expr)); + tmp = gfc_conv_descriptor_dtype (class_data); + gfc_add_modify (pre, tmp, dtype); + + /* Point desc to the class _data field. */ + desc = class_data; + } + else + { + /* Fill in the array dtype. */ + tmp = gfc_conv_descriptor_dtype (desc); + gfc_add_modify (pre, tmp, gfc_get_dtype (TREE_TYPE (desc))); + } + + info->descriptor = desc; + size = gfc_index_one_node; /* Fill in the bounds and stride. This is a packed array, so: @@ -2727,7 +2764,7 @@ trans_array_constructor (gfc_ss * ss, locus * where) desc = ss_info->data.array.descriptor; offset = gfc_index_zero_node; offsetvar = gfc_create_var_np (gfc_array_index_type, "offset"); - TREE_NO_WARNING (offsetvar) = 1; + suppress_warning (offsetvar); TREE_USED (offsetvar) = 0; gfc_trans_array_constructor_value (&outer_loop->pre, type, desc, c, &offset, &offsetvar, dynamic); @@ -3424,134 +3461,73 @@ conv_array_index_offset (gfc_se * se, gfc_ss * ss, int dim, int i, static bool build_class_array_ref (gfc_se *se, tree base, tree index) { - tree type; tree size; - tree offset; tree decl = NULL_TREE; tree tmp; gfc_expr *expr = se->ss->info->expr; - gfc_ref *ref; - gfc_ref *class_ref = NULL; + gfc_expr *class_expr; gfc_typespec *ts; + gfc_symbol *sym; + + tmp = !VAR_P (base) ? gfc_get_class_from_expr (base) : NULL_TREE; - if (se->expr && DECL_P (se->expr) && DECL_LANG_SPECIFIC (se->expr) - && GFC_DECL_SAVED_DESCRIPTOR (se->expr) - && GFC_CLASS_TYPE_P (TREE_TYPE (GFC_DECL_SAVED_DESCRIPTOR (se->expr)))) - decl = se->expr; + if (tmp != NULL_TREE) + decl = tmp; else { - if (expr == NULL + /* The base expression does not contain a class component, either + because it is a temporary array or array descriptor. Class + array functions are correctly resolved above. */ + if (!expr || (expr->ts.type != BT_CLASS - && !gfc_is_class_array_function (expr) && !gfc_is_class_array_ref (expr, NULL))) return false; - if (expr->symtree && expr->symtree->n.sym->ts.type == BT_CLASS) - ts = &expr->symtree->n.sym->ts; - else - ts = NULL; - - for (ref = expr->ref; ref; ref = ref->next) - { - if (ref->type == REF_COMPONENT - && ref->u.c.component->ts.type == BT_CLASS - && ref->next && ref->next->type == REF_COMPONENT - && strcmp (ref->next->u.c.component->name, "_data") == 0 - && ref->next->next - && ref->next->next->type == REF_ARRAY - && ref->next->next->u.ar.type != AR_ELEMENT) - { - ts = &ref->u.c.component->ts; - class_ref = ref; - break; - } - } + /* Obtain the expression for the class entity or component that is + followed by an array reference, which is not an element, so that + the span of the array can be obtained. */ + class_expr = gfc_find_and_cut_at_last_class_ref (expr, false, &ts); - if (ts == NULL) + if (!ts) return false; - } - if (class_ref == NULL && expr && expr->symtree->n.sym->attr.function - && expr->symtree->n.sym == expr->symtree->n.sym->result - && expr->symtree->n.sym->backend_decl == current_function_decl) - { - decl = gfc_get_fake_result_decl (expr->symtree->n.sym, 0); - } - else if (expr && gfc_is_class_array_function (expr)) - { - size = NULL_TREE; - decl = NULL_TREE; - for (tmp = base; tmp; tmp = TREE_OPERAND (tmp, 0)) - { - tree type; - type = TREE_TYPE (tmp); - while (type) - { - if (GFC_CLASS_TYPE_P (type)) - decl = tmp; - if (type != TYPE_CANONICAL (type)) - type = TYPE_CANONICAL (type); - else - type = NULL_TREE; - } - if (VAR_P (tmp)) - break; + sym = (!class_expr && expr) ? expr->symtree->n.sym : NULL; + if (sym && sym->attr.function + && sym == sym->result + && sym->backend_decl == current_function_decl) + /* The temporary is the data field of the class data component + of the current function. */ + decl = gfc_get_fake_result_decl (sym, 0); + else if (sym) + { + if (decl == NULL_TREE) + decl = expr->symtree->n.sym->backend_decl; + /* For class arrays the tree containing the class is stored in + GFC_DECL_SAVED_DESCRIPTOR of the sym's backend_decl. + For all others it's sym's backend_decl directly. */ + if (DECL_LANG_SPECIFIC (decl) && GFC_DECL_SAVED_DESCRIPTOR (decl)) + decl = GFC_DECL_SAVED_DESCRIPTOR (decl); } + else + decl = gfc_get_class_from_gfc_expr (class_expr); - if (decl == NULL_TREE) - return false; + if (POINTER_TYPE_P (TREE_TYPE (decl))) + decl = build_fold_indirect_ref_loc (input_location, decl); - se->class_vptr = gfc_evaluate_now (gfc_class_vptr_get (decl), &se->pre); - } - else if (class_ref == NULL) - { - if (decl == NULL_TREE) - decl = expr->symtree->n.sym->backend_decl; - /* For class arrays the tree containing the class is stored in - GFC_DECL_SAVED_DESCRIPTOR of the sym's backend_decl. - For all others it's sym's backend_decl directly. */ - if (DECL_LANG_SPECIFIC (decl) && GFC_DECL_SAVED_DESCRIPTOR (decl)) - decl = GFC_DECL_SAVED_DESCRIPTOR (decl); - } - else - { - /* Remove everything after the last class reference, convert the - expression and then recover its tailend once more. */ - gfc_se tmpse; - ref = class_ref->next; - class_ref->next = NULL; - gfc_init_se (&tmpse, NULL); - gfc_conv_expr (&tmpse, expr); - gfc_add_block_to_block (&se->pre, &tmpse.pre); - decl = tmpse.expr; - class_ref->next = ref; + if (!GFC_CLASS_TYPE_P (TREE_TYPE (decl))) + return false; } - if (POINTER_TYPE_P (TREE_TYPE (decl))) - decl = build_fold_indirect_ref_loc (input_location, decl); - - if (!GFC_CLASS_TYPE_P (TREE_TYPE (decl))) - return false; + se->class_vptr = gfc_evaluate_now (gfc_class_vptr_get (decl), &se->pre); size = gfc_class_vtab_size_get (decl); - /* For unlimited polymorphic entities then _len component needs to be multiplied with the size. */ size = gfc_resize_class_size_with_len (&se->pre, decl, size); - size = fold_convert (TREE_TYPE (index), size); - /* Build the address of the element. */ - type = TREE_TYPE (TREE_TYPE (base)); - offset = fold_build2_loc (input_location, MULT_EXPR, - gfc_array_index_type, - index, size); - tmp = gfc_build_addr_expr (pvoid_type_node, base); - tmp = fold_build_pointer_plus_loc (input_location, tmp, offset); - tmp = fold_convert (build_pointer_type (type), tmp); - /* Return the element in the se expression. */ - se->expr = build_fold_indirect_ref_loc (input_location, tmp); + se->expr = gfc_build_spanned_array_ref (base, index, size); return true; } @@ -4751,8 +4727,9 @@ done: /* For optional arguments, only check bounds if the argument is present. */ - if (expr->symtree->n.sym->attr.optional - || expr->symtree->n.sym->attr.not_always_present) + if ((expr->symtree->n.sym->attr.optional + || expr->symtree->n.sym->attr.not_always_present) + && expr->symtree->n.sym->attr.dummy) tmp = build3_v (COND_EXPR, gfc_conv_expr_present (expr->symtree->n.sym), tmp, build_empty_stmt (input_location)); @@ -6557,7 +6534,14 @@ gfc_trans_g77_array (gfc_symbol * sym, gfc_wrapped_block * block) /* Set the pointer itself if we aren't using the parameter directly. */ if (TREE_CODE (parm) != PARM_DECL) { - tmp = convert (TREE_TYPE (parm), GFC_DECL_SAVED_DESCRIPTOR (parm)); + tmp = GFC_DECL_SAVED_DESCRIPTOR (parm); + if (sym->ts.type == BT_CLASS) + { + tmp = build_fold_indirect_ref_loc (input_location, tmp); + tmp = gfc_class_data_get (tmp); + tmp = gfc_conv_descriptor_data_get (tmp); + } + tmp = convert (TREE_TYPE (parm), tmp); gfc_add_modify (&init, parm, tmp); } stmt = gfc_finish_block (&init); @@ -6659,7 +6643,8 @@ gfc_trans_dummy_array_bias (gfc_symbol * sym, tree tmpdesc, && VAR_P (sym->ts.u.cl->backend_decl)) gfc_conv_string_length (sym->ts.u.cl, NULL, &init); - checkparm = (as->type == AS_EXPLICIT + /* TODO: Fix the exclusion of class arrays from extent checking. */ + checkparm = (as->type == AS_EXPLICIT && !is_classarray && (gfc_option.rtcheck & GFC_RTCHECK_BOUNDS)); no_repack = !(GFC_DECL_PACKED_ARRAY (tmpdesc) @@ -7352,6 +7337,9 @@ gfc_conv_expr_descriptor (gfc_se *se, gfc_expr *expr) expr = expr->value.function.actual->expr; } + if (!se->direct_byref) + se->unlimited_polymorphic = UNLIMITED_POLY (expr); + /* Special case things we know we can pass easily. */ switch (expr->expr_type) { @@ -7375,9 +7363,11 @@ gfc_conv_expr_descriptor (gfc_se *se, gfc_expr *expr) && TREE_CODE (desc) == COMPONENT_REF) deferred_array_component = true; - subref_array_target = se->direct_byref && is_subref_array (expr); - need_tmp = gfc_ref_needs_temporary_p (expr->ref) - && !subref_array_target; + subref_array_target = (is_subref_array (expr) + && (se->direct_byref + || expr->ts.type == BT_CHARACTER)); + need_tmp = (gfc_ref_needs_temporary_p (expr->ref) + && !subref_array_target); if (se->force_tmp) need_tmp = 1; @@ -7414,9 +7404,8 @@ gfc_conv_expr_descriptor (gfc_se *se, gfc_expr *expr) subref_array_target, expr); /* ....and set the span field. */ - tmp = gfc_get_array_span (desc, expr); - if (tmp != NULL_TREE && !integer_zerop (tmp)) - gfc_conv_descriptor_span_set (&se->pre, se->expr, tmp); + tmp = gfc_conv_descriptor_span_get (desc); + gfc_conv_descriptor_span_set (&se->pre, se->expr, tmp); } else if (se->want_pointer) { @@ -7631,6 +7620,7 @@ gfc_conv_expr_descriptor (gfc_se *se, gfc_expr *expr) int dim, ndim, codim; tree parm; tree parmtype; + tree dtype; tree stride; tree from; tree to; @@ -7713,7 +7703,7 @@ gfc_conv_expr_descriptor (gfc_se *se, gfc_expr *expr) else { /* Otherwise make a new one. */ - if (expr->ts.type == BT_CHARACTER && expr->ts.deferred) + if (expr->ts.type == BT_CHARACTER) parmtype = gfc_typenode_for_spec (&expr->ts); else parmtype = gfc_get_element_type (TREE_TYPE (desc)); @@ -7747,11 +7737,8 @@ gfc_conv_expr_descriptor (gfc_se *se, gfc_expr *expr) } /* Set the span field. */ - if (expr->ts.type == BT_CHARACTER && ss_info->string_length) - tmp = ss_info->string_length; - else - tmp = gfc_get_array_span (desc, expr); - if (tmp != NULL_TREE) + tmp = gfc_get_array_span (desc, expr); + if (tmp) gfc_conv_descriptor_span_set (&loop.pre, parm, tmp); /* The following can be somewhat confusing. We have two @@ -7765,7 +7752,11 @@ gfc_conv_expr_descriptor (gfc_se *se, gfc_expr *expr) /* Set the dtype. */ tmp = gfc_conv_descriptor_dtype (parm); - gfc_add_modify (&loop.pre, tmp, gfc_get_dtype (parmtype)); + if (se->unlimited_polymorphic) + dtype = gfc_get_dtype (TREE_TYPE (desc), &loop.dimen); + else + dtype = gfc_get_dtype (parmtype); + gfc_add_modify (&loop.pre, tmp, dtype); /* The 1st element in the section. */ base = gfc_index_zero_node; @@ -10280,23 +10271,10 @@ gfc_alloc_allocatable_for_assignment (gfc_loopinfo *loop, } else if (expr1->ts.type == BT_CLASS) { - tmp = expr1->rank ? gfc_get_class_from_expr (desc) : NULL_TREE; - if (tmp == NULL_TREE) - tmp = gfc_get_class_from_gfc_expr (expr1); - - if (tmp != NULL_TREE) - { - tmp2 = gfc_class_vptr_get (tmp); - cond = fold_build2_loc (input_location, NE_EXPR, - logical_type_node, tmp2, - build_int_cst (TREE_TYPE (tmp2), 0)); - elemsize1 = gfc_class_vtab_size_get (tmp); - elemsize1 = fold_build3_loc (input_location, COND_EXPR, - gfc_array_index_type, cond, - elemsize1, gfc_index_zero_node); - } - else - elemsize1 = TYPE_SIZE_UNIT (gfc_typenode_for_spec (&CLASS_DATA (expr1)->ts)); + /* Unfortunately, the lhs vptr is set too early in many cases. + Play it safe by using the descriptor element length. */ + tmp = gfc_conv_descriptor_elem_len (desc); + elemsize1 = fold_convert (gfc_array_index_type, tmp); } else elemsize1 = NULL_TREE; @@ -10770,11 +10748,11 @@ gfc_alloc_allocatable_for_assignment (gfc_loopinfo *loop, /* We already set the dtype in the case of deferred character - length arrays and unlimited polymorphic arrays. */ + length arrays and class lvalues. */ if (!(GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (desc)) && ((expr1->ts.type == BT_CHARACTER && expr1->ts.deferred) || coarray)) - && !UNLIMITED_POLY (expr1)) + && expr1->ts.type != BT_CLASS) { tmp = gfc_conv_descriptor_dtype (desc); gfc_add_modify (&alloc_block, tmp, gfc_get_dtype (TREE_TYPE (desc))); @@ -10920,6 +10898,20 @@ gfc_trans_deferred_array (gfc_symbol * sym, gfc_wrapped_block * block) } } + /* Set initial TKR for pointers and allocatables */ + if (GFC_DESCRIPTOR_TYPE_P (type) + && (sym->attr.pointer || sym->attr.allocatable)) + { + tree etype; + + gcc_assert (sym->as && sym->as->rank>=0); + tmp = gfc_conv_descriptor_dtype (descriptor); + etype = gfc_get_element_type (type); + tmp = fold_build2_loc (input_location, MODIFY_EXPR, + TREE_TYPE (tmp), tmp, + gfc_get_dtype_rank_type (sym->as->rank, etype)); + gfc_add_expr_to_block (&init, tmp); + } gfc_restore_backend_locus (&loc); gfc_init_block (&cleanup); diff --git a/gcc/fortran/trans-common.c b/gcc/fortran/trans-common.c index a11cf4c..7bcf18d 100644 --- a/gcc/fortran/trans-common.c +++ b/gcc/fortran/trans-common.c @@ -759,10 +759,11 @@ create_common (gfc_common_head *com, segment_info *head, bool saw_equiv) else gfc_add_decl_to_function (var_decl); - SET_DECL_VALUE_EXPR (var_decl, - fold_build3_loc (input_location, COMPONENT_REF, - TREE_TYPE (s->field), - decl, s->field, NULL_TREE)); + tree comp = build3_loc (input_location, COMPONENT_REF, + TREE_TYPE (s->field), decl, s->field, NULL_TREE); + if (TREE_THIS_VOLATILE (s->field)) + TREE_THIS_VOLATILE (comp) = 1; + SET_DECL_VALUE_EXPR (var_decl, comp); DECL_HAS_VALUE_EXPR_P (var_decl) = 1; GFC_DECL_COMMON_OR_EQUIV (var_decl) = 1; diff --git a/gcc/fortran/trans-decl.c b/gcc/fortran/trans-decl.c index 6a4ed9b..bed61e2 100644 --- a/gcc/fortran/trans-decl.c +++ b/gcc/fortran/trans-decl.c @@ -170,6 +170,7 @@ tree gfor_fndecl_co_min; tree gfor_fndecl_co_reduce; tree gfor_fndecl_co_sum; tree gfor_fndecl_caf_is_present; +tree gfor_fndecl_caf_random_init; /* Math functions. Many other math functions are handled in @@ -233,7 +234,7 @@ tree gfor_fndecl_cgemm; tree gfor_fndecl_zgemm; /* RANDOM_INIT function. */ -tree gfor_fndecl_random_init; +tree gfor_fndecl_random_init; /* libgfortran, 1 image only. */ static void gfc_add_decl_to_parent_function (tree decl) @@ -604,6 +605,11 @@ gfc_finish_decl_attrs (tree decl, symbol_attribute *attr) gfc_allocate_lang_decl (decl); GFC_DECL_SCALAR_POINTER (decl) = 1; } + if (attr->target) + { + gfc_allocate_lang_decl (decl); + GFC_DECL_SCALAR_TARGET (decl) = 1; + } } } @@ -737,7 +743,10 @@ gfc_finish_var_decl (tree decl, gfc_symbol * sym) /* Keep variables larger than max-stack-var-size off stack. */ if (!(sym->ns->proc_name && sym->ns->proc_name->attr.recursive) + && !(sym->ns->proc_name && sym->ns->proc_name->attr.is_main_program) && !sym->attr.automatic + && sym->attr.save != SAVE_EXPLICIT + && sym->attr.save != SAVE_IMPLICIT && INTEGER_CST_P (DECL_SIZE_UNIT (decl)) && !gfc_can_put_var_on_stack (DECL_SIZE_UNIT (decl)) /* Put variable length auto array pointers always into stack. */ @@ -750,13 +759,17 @@ gfc_finish_var_decl (tree decl, gfc_symbol * sym) { if (flag_max_stack_var_size > 0) gfc_warning (OPT_Wsurprising, - "Array %qs at %L is larger than limit set by" - " %<-fmax-stack-var-size=%>, moved from stack to static" - " storage. This makes the procedure unsafe when called" - " recursively, or concurrently from multiple threads." - " Consider using %<-frecursive%>, or increase the" - " %<-fmax-stack-var-size=%> limit, or change the code to" - " use an ALLOCATABLE array.", + "Array %qs at %L is larger than limit set by " + "%<-fmax-stack-var-size=%>, moved from stack to static " + "storage. This makes the procedure unsafe when called " + "recursively, or concurrently from multiple threads. " + "Consider increasing the %<-fmax-stack-var-size=%> " + "limit (or use %<-frecursive%>, which implies " + "unlimited %<-fmax-stack-var-size%>) - or change the " + "code to use an ALLOCATABLE array. If the variable is " + "never accessed concurrently, this warning can be " + "ignored, and the variable could also be declared with " + "the SAVE attribute.", sym->name, &sym->declared_at); TREE_STATIC (decl) = 1; @@ -1038,7 +1051,7 @@ gfc_build_qualified_array (tree decl, gfc_symbol * sym) if (GFC_TYPE_ARRAY_LBOUND (type, dim) == NULL_TREE) { GFC_TYPE_ARRAY_LBOUND (type, dim) = create_index_var ("lbound", nest); - TREE_NO_WARNING (GFC_TYPE_ARRAY_LBOUND (type, dim)) = 1; + suppress_warning (GFC_TYPE_ARRAY_LBOUND (type, dim)); } /* Don't try to use the unknown bound for assumed shape arrays. */ if (GFC_TYPE_ARRAY_UBOUND (type, dim) == NULL_TREE @@ -1046,13 +1059,13 @@ gfc_build_qualified_array (tree decl, gfc_symbol * sym) || dim < GFC_TYPE_ARRAY_RANK (type) - 1)) { GFC_TYPE_ARRAY_UBOUND (type, dim) = create_index_var ("ubound", nest); - TREE_NO_WARNING (GFC_TYPE_ARRAY_UBOUND (type, dim)) = 1; + suppress_warning (GFC_TYPE_ARRAY_UBOUND (type, dim)); } if (GFC_TYPE_ARRAY_STRIDE (type, dim) == NULL_TREE) { GFC_TYPE_ARRAY_STRIDE (type, dim) = create_index_var ("stride", nest); - TREE_NO_WARNING (GFC_TYPE_ARRAY_STRIDE (type, dim)) = 1; + suppress_warning (GFC_TYPE_ARRAY_STRIDE (type, dim)); } } for (dim = GFC_TYPE_ARRAY_RANK (type); @@ -1061,21 +1074,21 @@ gfc_build_qualified_array (tree decl, gfc_symbol * sym) if (GFC_TYPE_ARRAY_LBOUND (type, dim) == NULL_TREE) { GFC_TYPE_ARRAY_LBOUND (type, dim) = create_index_var ("lbound", nest); - TREE_NO_WARNING (GFC_TYPE_ARRAY_LBOUND (type, dim)) = 1; + suppress_warning (GFC_TYPE_ARRAY_LBOUND (type, dim)); } /* Don't try to use the unknown ubound for the last coarray dimension. */ if (GFC_TYPE_ARRAY_UBOUND (type, dim) == NULL_TREE && dim < GFC_TYPE_ARRAY_RANK (type) + GFC_TYPE_ARRAY_CORANK (type) - 1) { GFC_TYPE_ARRAY_UBOUND (type, dim) = create_index_var ("ubound", nest); - TREE_NO_WARNING (GFC_TYPE_ARRAY_UBOUND (type, dim)) = 1; + suppress_warning (GFC_TYPE_ARRAY_UBOUND (type, dim)); } } if (GFC_TYPE_ARRAY_OFFSET (type) == NULL_TREE) { GFC_TYPE_ARRAY_OFFSET (type) = gfc_create_var_np (gfc_array_index_type, "offset"); - TREE_NO_WARNING (GFC_TYPE_ARRAY_OFFSET (type)) = 1; + suppress_warning (GFC_TYPE_ARRAY_OFFSET (type)); if (nest) gfc_add_decl_to_parent_function (GFC_TYPE_ARRAY_OFFSET (type)); @@ -1087,7 +1100,7 @@ gfc_build_qualified_array (tree decl, gfc_symbol * sym) && as->type != AS_ASSUMED_SIZE) { GFC_TYPE_ARRAY_SIZE (type) = create_index_var ("size", nest); - TREE_NO_WARNING (GFC_TYPE_ARRAY_SIZE (type)) = 1; + suppress_warning (GFC_TYPE_ARRAY_SIZE (type)); } if (POINTER_TYPE_P (type)) @@ -1292,7 +1305,7 @@ gfc_build_dummy_array_decl (gfc_symbol * sym, tree dummy) /* Avoid uninitialized warnings for optional dummy arguments. */ if (sym->attr.optional) - TREE_NO_WARNING (decl) = 1; + suppress_warning (decl); /* We should never get deferred shape arrays here. We used to because of frontend bugs. */ @@ -1466,6 +1479,14 @@ add_attributes_to_decl (symbol_attribute sym_attr, tree list) tree dims = oacc_build_routine_dims (clauses); list = oacc_replace_fn_attrib_attr (list, dims); } + + if (sym_attr.oacc_routine_nohost) + { + tree c = build_omp_clause (UNKNOWN_LOCATION, OMP_CLAUSE_NOHOST); + OMP_CLAUSE_CHAIN (c) = clauses; + clauses = c; + } + if (sym_attr.omp_device_type != OMP_DEVICE_TYPE_UNSET) { tree c = build_omp_clause (UNKNOWN_LOCATION, OMP_CLAUSE_DEVICE_TYPE); @@ -1548,7 +1569,8 @@ gfc_get_symbol_decl (gfc_symbol * sym) declaration of the entity and memory allocated/deallocated. */ if ((sym->ts.type == BT_DERIVED || sym->ts.type == BT_CLASS) && sym->param_list != NULL - && !(sym->attr.host_assoc || sym->attr.use_assoc || sym->attr.dummy)) + && gfc_current_ns == sym->ns + && !(sym->attr.use_assoc || sym->attr.dummy)) gfc_defer_symbol_init (sym); /* Dummy PDT 'len' parameters should be checked when they are explicit. */ @@ -1940,7 +1962,7 @@ gfc_get_symbol_decl (gfc_symbol * sym) Marking this as artificial means that OpenMP will treat this as predetermined shared. */ - bool def_init = gfc_str_startswith (sym->name, "__def_init"); + bool def_init = startswith (sym->name, "__def_init"); if (sym->attr.vtab || def_init) { @@ -2488,7 +2510,9 @@ build_function_decl (gfc_symbol * sym, bool global) } -/* Create the DECL_ARGUMENTS for a procedure. */ +/* Create the DECL_ARGUMENTS for a procedure. + NOTE: The arguments added here must match the argument type created by + gfc_get_function_type (). */ static void create_function_arglist (gfc_symbol * sym) @@ -2807,6 +2831,7 @@ create_function_arglist (gfc_symbol * sym) DECL_ARG_TYPE (token) = TREE_VALUE (typelist); TREE_READONLY (token) = 1; hidden_arglist = chainon (hidden_arglist, token); + hidden_typelist = TREE_CHAIN (hidden_typelist); gfc_finish_decl (token); offset = build_decl (input_location, PARM_DECL, @@ -2832,6 +2857,7 @@ create_function_arglist (gfc_symbol * sym) DECL_ARG_TYPE (offset) = TREE_VALUE (typelist); TREE_READONLY (offset) = 1; hidden_arglist = chainon (hidden_arglist, offset); + hidden_typelist = TREE_CHAIN (hidden_typelist); gfc_finish_decl (offset); } @@ -3510,6 +3536,8 @@ gfc_build_intrinsic_function_decls (void) void_type_node, 3, gfc_logical4_type_node, gfc_logical4_type_node, gfc_int4_type_node); + // gfor_fndecl_caf_rand_init is defined in the lib-coarray section below. + gfor_fndecl_sc_kind = gfc_build_library_function_decl_with_spec ( get_identifier (PREFIX("selected_char_kind")), ". . R ", gfc_int4_type_node, 2, gfc_charlen_type_node, pchar_type_node); @@ -4075,6 +4103,10 @@ gfc_build_builtin_function_decls (void) get_identifier (PREFIX("caf_is_present")), ". r . r ", integer_type_node, 3, pvoid_type_node, integer_type_node, pvoid_type_node); + + gfor_fndecl_caf_random_init = gfc_build_library_function_decl ( + get_identifier (PREFIX("caf_random_init")), + void_type_node, 2, logical_type_node, logical_type_node); } gfc_build_intrinsic_function_decls (); @@ -4513,22 +4545,28 @@ convert_CFI_desc (gfc_wrapped_block * block, gfc_symbol *sym) gfc_add_expr_to_block (&outer_block, incoming); incoming = gfc_finish_block (&outer_block); - /* Convert the gfc descriptor back to the CFI type before going out of scope, if the CFI type was present at entry. */ - gfc_init_block (&outer_block); - gfc_init_block (&tmpblock); - - tmp = gfc_build_addr_expr (ppvoid_type_node, CFI_desc_ptr); - outgoing = build_call_expr_loc (input_location, - gfor_fndecl_gfc_to_cfi, 2, tmp, gfc_desc_ptr); - gfc_add_expr_to_block (&tmpblock, outgoing); + outgoing = NULL_TREE; + if ((sym->attr.pointer || sym->attr.allocatable) + && !sym->attr.value + && sym->attr.intent != INTENT_IN) + { + gfc_init_block (&outer_block); + gfc_init_block (&tmpblock); - outgoing = build3_v (COND_EXPR, present, - gfc_finish_block (&tmpblock), - build_empty_stmt (input_location)); - gfc_add_expr_to_block (&outer_block, outgoing); - outgoing = gfc_finish_block (&outer_block); + tmp = gfc_build_addr_expr (ppvoid_type_node, CFI_desc_ptr); + outgoing = build_call_expr_loc (input_location, + gfor_fndecl_gfc_to_cfi, 2, + tmp, gfc_desc_ptr); + gfc_add_expr_to_block (&tmpblock, outgoing); + + outgoing = build3_v (COND_EXPR, present, + gfc_finish_block (&tmpblock), + build_empty_stmt (input_location)); + gfc_add_expr_to_block (&outer_block, outgoing); + outgoing = gfc_finish_block (&outer_block); + } /* Add the lot to the procedure init and finally blocks. */ gfc_add_init_cleanup (block, incoming, outgoing); @@ -5968,7 +6006,7 @@ generate_local_decl (gfc_symbol * sym) "does not have a default initializer", sym->name, &sym->declared_at); if (sym->backend_decl != NULL_TREE) - TREE_NO_WARNING(sym->backend_decl) = 1; + suppress_warning (sym->backend_decl); } else if (warn_unused_dummy_argument) { @@ -5978,7 +6016,7 @@ generate_local_decl (gfc_symbol * sym) &sym->declared_at); if (sym->backend_decl != NULL_TREE) - TREE_NO_WARNING(sym->backend_decl) = 1; + suppress_warning (sym->backend_decl); } } @@ -5994,7 +6032,7 @@ generate_local_decl (gfc_symbol * sym) "explicitly imported at %L", sym->name, &sym->declared_at); if (sym->backend_decl != NULL_TREE) - TREE_NO_WARNING(sym->backend_decl) = 1; + suppress_warning (sym->backend_decl); } else if (!sym->attr.use_assoc) { @@ -6012,7 +6050,7 @@ generate_local_decl (gfc_symbol * sym) "Unused variable %qs declared at %L", sym->name, &sym->declared_at); if (sym->backend_decl != NULL_TREE) - TREE_NO_WARNING(sym->backend_decl) = 1; + suppress_warning (sym->backend_decl); } } @@ -6127,7 +6165,7 @@ generate_local_decl (gfc_symbol * sym) /* Silence bogus "unused parameter" warnings from the middle end. */ if (sym->backend_decl != NULL_TREE) - TREE_NO_WARNING (sym->backend_decl) = 1; + suppress_warning (sym->backend_decl); } } @@ -6958,7 +6996,7 @@ gfc_generate_function_code (gfc_namespace * ns) "Return value of function %qs at %L not set", sym->name, &sym->declared_at); if (warn_return_type > 0) - TREE_NO_WARNING(sym->backend_decl) = 1; + suppress_warning (sym->backend_decl); } if (result != NULL_TREE) gfc_add_expr_to_block (&body, gfc_generate_return ()); diff --git a/gcc/fortran/trans-expr.c b/gcc/fortran/trans-expr.c index bffe080..18d6651 100644 --- a/gcc/fortran/trans-expr.c +++ b/gcc/fortran/trans-expr.c @@ -42,6 +42,45 @@ along with GCC; see the file COPYING3. If not see #include "dependency.h" #include "gimplify.h" + +/* Calculate the number of characters in a string. */ + +tree +gfc_get_character_len (tree type) +{ + tree len; + + gcc_assert (type && TREE_CODE (type) == ARRAY_TYPE + && TYPE_STRING_FLAG (type)); + + len = TYPE_MAX_VALUE (TYPE_DOMAIN (type)); + len = (len) ? (len) : (integer_zero_node); + return fold_convert (gfc_charlen_type_node, len); +} + + + +/* Calculate the number of bytes in a string. */ + +tree +gfc_get_character_len_in_bytes (tree type) +{ + tree tmp, len; + + gcc_assert (type && TREE_CODE (type) == ARRAY_TYPE + && TYPE_STRING_FLAG (type)); + + tmp = TYPE_SIZE_UNIT (TREE_TYPE (type)); + tmp = (tmp && !integer_zerop (tmp)) + ? (fold_convert (gfc_charlen_type_node, tmp)) : (NULL_TREE); + len = gfc_get_character_len (type); + if (tmp && len && !integer_zerop (len)) + len = fold_build2_loc (input_location, MULT_EXPR, + gfc_charlen_type_node, len, tmp); + return len; +} + + /* Convert a scalar to an array descriptor. To be used for assumed-rank arrays. */ @@ -87,6 +126,8 @@ gfc_conv_scalar_to_descriptor (gfc_se *se, tree scalar, symbol_attribute attr) gfc_add_modify (&se->pre, gfc_conv_descriptor_dtype (desc), gfc_get_dtype_rank_type (0, etype)); gfc_conv_descriptor_data_set (&se->pre, desc, scalar); + gfc_conv_descriptor_span_set (&se->pre, desc, + gfc_conv_descriptor_elem_len (desc)); /* Copy pointer address back - but only if it could have changed and if the actual argument is a pointer and not, e.g., NULL(). */ @@ -380,15 +421,20 @@ gfc_vptr_size_get (tree vptr) #undef VTABLE_FINAL_FIELD -/* Search for the last _class ref in the chain of references of this - expression and cut the chain there. Albeit this routine is similiar - to class.c::gfc_add_component_ref (), is there a significant - difference: gfc_add_component_ref () concentrates on an array ref to - be the last ref in the chain. This routine is oblivious to the kind - of refs following. */ +/* IF ts is null (default), search for the last _class ref in the chain + of references of the expression and cut the chain there. Although + this routine is similiar to class.c:gfc_add_component_ref (), there + is a significant difference: gfc_add_component_ref () concentrates + on an array ref that is the last ref in the chain and is oblivious + to the kind of refs following. + ELSE IF ts is non-null the cut is at the class entity or component + that is followed by an array reference, which is not an element. + These calls come from trans-array.c:build_class_array_ref, which + handles scalarized class array references.*/ gfc_expr * -gfc_find_and_cut_at_last_class_ref (gfc_expr *e, bool is_mold) +gfc_find_and_cut_at_last_class_ref (gfc_expr *e, bool is_mold, + gfc_typespec **ts) { gfc_expr *base_expr; gfc_ref *ref, *class_ref, *tail = NULL, *array_ref; @@ -396,27 +442,59 @@ gfc_find_and_cut_at_last_class_ref (gfc_expr *e, bool is_mold) /* Find the last class reference. */ class_ref = NULL; array_ref = NULL; - for (ref = e->ref; ref; ref = ref->next) + + if (ts) { - if (ref->type == REF_ARRAY && ref->u.ar.type != AR_ELEMENT) - array_ref = ref; + if (e->symtree + && e->symtree->n.sym->ts.type == BT_CLASS) + *ts = &e->symtree->n.sym->ts; + else + *ts = NULL; + } - if (ref->type == REF_COMPONENT - && ref->u.c.component->ts.type == BT_CLASS) + for (ref = e->ref; ref; ref = ref->next) + { + if (ts) { - /* Component to the right of a part reference with nonzero rank - must not have the ALLOCATABLE attribute. If attempts are - made to reference such a component reference, an error results - followed by an ICE. */ - if (array_ref && CLASS_DATA (ref->u.c.component)->attr.allocatable) - return NULL; - class_ref = ref; + if (ref->type == REF_COMPONENT + && ref->u.c.component->ts.type == BT_CLASS + && ref->next && ref->next->type == REF_COMPONENT + && !strcmp (ref->next->u.c.component->name, "_data") + && ref->next->next + && ref->next->next->type == REF_ARRAY + && ref->next->next->u.ar.type != AR_ELEMENT) + { + *ts = &ref->u.c.component->ts; + class_ref = ref; + break; + } + + if (ref->next == NULL) + break; } + else + { + if (ref->type == REF_ARRAY && ref->u.ar.type != AR_ELEMENT) + array_ref = ref; - if (ref->next == NULL) - break; + if (ref->type == REF_COMPONENT + && ref->u.c.component->ts.type == BT_CLASS) + { + /* Component to the right of a part reference with nonzero + rank must not have the ALLOCATABLE attribute. If attempts + are made to reference such a component reference, an error + results followed by an ICE. */ + if (array_ref + && CLASS_DATA (ref->u.c.component)->attr.allocatable) + return NULL; + class_ref = ref; + } + } } + if (ts && *ts == NULL) + return NULL; + /* Remove and store all subsequent references after the CLASS reference. */ if (class_ref) @@ -1524,7 +1602,7 @@ gfc_copy_class_to_class (tree from, tree to, tree nelems, bool unlimited) { vec_safe_push (args, from_len); vec_safe_push (args, to_len); - extcopy = build_call_vec (fcn_type, fcn, args); + extcopy = build_call_vec (fcn_type, unshare_expr (fcn), args); tmp = fold_build2_loc (input_location, GT_EXPR, logical_type_node, from_len, build_zero_cst (TREE_TYPE (from_len))); @@ -1663,8 +1741,9 @@ gfc_trans_class_init_assign (gfc_code *code) } } - if (code->expr1->symtree->n.sym->attr.optional - || code->expr1->symtree->n.sym->ns->proc_name->attr.entry_master) + if (code->expr1->symtree->n.sym->attr.dummy + && (code->expr1->symtree->n.sym->attr.optional + || code->expr1->symtree->n.sym->ns->proc_name->attr.entry_master)) { tree present = gfc_conv_expr_present (code->expr1->symtree->n.sym); tmp = build3_loc (input_location, COND_EXPR, TREE_TYPE (tmp), @@ -2551,7 +2630,9 @@ gfc_conv_substring (gfc_se * se, gfc_ref * ref, int kind, if (!CONSTANT_CLASS_P (tmp) && !DECL_P (tmp)) end.expr = gfc_evaluate_now (end.expr, &se->pre); - if (gfc_option.rtcheck & GFC_RTCHECK_BOUNDS) + if ((gfc_option.rtcheck & GFC_RTCHECK_BOUNDS) + && (ref->u.ss.start->symtree + && !ref->u.ss.start->symtree->n.sym->attr.implied_index)) { tree nonempty = fold_build2_loc (input_location, LE_EXPR, logical_type_node, start.expr, @@ -5423,13 +5504,12 @@ gfc_conv_gfc_desc_to_cfi_desc (gfc_se *parmse, gfc_expr *e, gfc_symbol *fsym) attribute = 1; } - /* If the formal argument is assumed shape and neither a pointer nor - allocatable, it is unconditionally CFI_attribute_other. */ - if (fsym->as->type == AS_ASSUMED_SHAPE - && !fsym->attr.pointer && !fsym->attr.allocatable) - cfi_attribute = 2; + if (fsym->attr.pointer) + cfi_attribute = 0; + else if (fsym->attr.allocatable) + cfi_attribute = 1; else - cfi_attribute = attribute; + cfi_attribute = 2; if (e->rank != 0) { @@ -5537,10 +5617,15 @@ gfc_conv_gfc_desc_to_cfi_desc (gfc_se *parmse, gfc_expr *e, gfc_symbol *fsym) gfc_prepend_expr_to_block (&parmse->post, tmp); /* Transfer values back to gfc descriptor. */ - tmp = gfc_build_addr_expr (NULL_TREE, parmse->expr); - tmp = build_call_expr_loc (input_location, - gfor_fndecl_cfi_to_gfc, 2, gfc_desc_ptr, tmp); - gfc_prepend_expr_to_block (&parmse->post, tmp); + if (cfi_attribute != 2 /* CFI_attribute_other. */ + && !fsym->attr.value + && fsym->attr.intent != INTENT_IN) + { + tmp = gfc_build_addr_expr (NULL_TREE, parmse->expr); + tmp = build_call_expr_loc (input_location, + gfor_fndecl_cfi_to_gfc, 2, gfc_desc_ptr, tmp); + gfc_prepend_expr_to_block (&parmse->post, tmp); + } /* Deal with an optional dummy being passed to an optional formal arg by finishing the pre and post blocks and making their execution @@ -5678,18 +5763,16 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym, arg = arg->next, formal = formal ? formal->next : NULL, ++argc) { bool finalized = false; - bool non_unity_length_string = false; + bool assumed_length_string = false; tree derived_array = NULL_TREE; e = arg->expr; fsym = formal ? formal->sym : NULL; parm_kind = MISSING; - if (fsym && fsym->ts.type == BT_CHARACTER && fsym->ts.u.cl - && (!fsym->ts.u.cl->length - || fsym->ts.u.cl->length->expr_type != EXPR_CONSTANT - || mpz_cmp_si (fsym->ts.u.cl->length->value.integer, 1) != 0)) - non_unity_length_string = true; + if (fsym && fsym->ts.type == BT_CHARACTER + && (!fsym->ts.u.cl || !fsym->ts.u.cl->length)) + assumed_length_string = true; /* If the procedure requires an explicit interface, the actual argument is passed according to the corresponding formal @@ -5789,7 +5872,9 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym, &derived_array); } else if (UNLIMITED_POLY (fsym) && e->ts.type != BT_CLASS - && gfc_expr_attr (e).flavor != FL_PROCEDURE) + && e->ts.type != BT_PROCEDURE + && (gfc_expr_attr (e).flavor != FL_PROCEDURE + || gfc_expr_attr (e).proc != PROC_UNKNOWN)) { /* The intrinsic type needs to be converted to a temporary CLASS object for the unlimited polymorphic formal. */ @@ -5921,8 +6006,8 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym, else if (sym->attr.is_bind_c && e && (is_CFI_desc (fsym, NULL) - || non_unity_length_string)) - /* Implement F2018, C.12.6.1: paragraph (2). */ + || assumed_length_string)) + /* Implement F2018, 18.3.6, list item (5), bullet point 2. */ gfc_conv_gfc_desc_to_cfi_desc (&parmse, e, fsym); else if (fsym && fsym->attr.value) @@ -5977,11 +6062,8 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym, || (!e->value.function.esym && e->symtree->n.sym->attr.pointer)) && fsym && fsym->attr.target) - { - gfc_conv_expr (&parmse, e); - parmse.expr = gfc_build_addr_expr (NULL_TREE, parmse.expr); - } - + /* Make sure the function only gets called once. */ + gfc_conv_expr_reference (&parmse, e, false); else if (e->expr_type == EXPR_FUNCTION && e->symtree->n.sym->result && e->symtree->n.sym->result != e->symtree->n.sym @@ -6091,6 +6173,7 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym, bool add_clobber; add_clobber = fsym && fsym->attr.intent == INTENT_OUT && !fsym->attr.allocatable && !fsym->attr.pointer + && e->symtree && e->symtree->n.sym && !e->symtree->n.sym->attr.dimension && !e->symtree->n.sym->attr.pointer && !e->symtree->n.sym->attr.allocatable @@ -6368,8 +6451,8 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym, } if (sym->attr.is_bind_c && e - && (is_CFI_desc (fsym, NULL) || non_unity_length_string)) - /* Implement F2018, C.12.6.1: paragraph (2). */ + && (is_CFI_desc (fsym, NULL) || assumed_length_string)) + /* Implement F2018, 18.3.6, list item (5), bullet point 2. */ gfc_conv_gfc_desc_to_cfi_desc (&parmse, e, fsym); else if (e->expr_type == EXPR_VARIABLE @@ -6383,6 +6466,15 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym, fsym ? fsym->attr.intent : INTENT_INOUT, fsym && fsym->attr.pointer); + else if (e->ts.type == BT_CLASS && CLASS_DATA (e)->as + && CLASS_DATA (e)->as->type == AS_ASSUMED_SIZE + && nodesc_arg && fsym->ts.type == BT_DERIVED) + /* An assumed size class actual argument being passed to + a 'no descriptor' formal argument just requires the + data pointer to be passed. For class dummy arguments + this is stored in the symbol backend decl.. */ + parmse.expr = e->symtree->n.sym->backend_decl; + else if (gfc_is_class_array_ref (e, NULL) && fsym && fsym->ts.type == BT_DERIVED) /* The actual argument is a component reference to an @@ -6663,6 +6755,18 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym, char *msg; tree cond; tree tmp; + symbol_attribute fsym_attr; + + if (fsym) + { + if (fsym->ts.type == BT_CLASS) + { + fsym_attr = CLASS_DATA (fsym)->attr; + fsym_attr.pointer = fsym_attr.class_pointer; + } + else + fsym_attr = fsym->attr; + } if (e->expr_type == EXPR_VARIABLE || e->expr_type == EXPR_FUNCTION) attr = gfc_expr_attr (e); @@ -6685,17 +6789,17 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym, tree present, null_ptr, type; if (attr.allocatable - && (fsym == NULL || !fsym->attr.allocatable)) + && (fsym == NULL || !fsym_attr.allocatable)) msg = xasprintf ("Allocatable actual argument '%s' is not " "allocated or not present", e->symtree->n.sym->name); else if (attr.pointer - && (fsym == NULL || !fsym->attr.pointer)) + && (fsym == NULL || !fsym_attr.pointer)) msg = xasprintf ("Pointer actual argument '%s' is not " "associated or not present", e->symtree->n.sym->name); - else if (attr.proc_pointer - && (fsym == NULL || !fsym->attr.proc_pointer)) + else if (attr.proc_pointer && !e->value.function.actual + && (fsym == NULL || !fsym_attr.proc_pointer)) msg = xasprintf ("Proc-pointer actual argument '%s' is not " "associated or not present", e->symtree->n.sym->name); @@ -6719,15 +6823,15 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym, else { if (attr.allocatable - && (fsym == NULL || !fsym->attr.allocatable)) + && (fsym == NULL || !fsym_attr.allocatable)) msg = xasprintf ("Allocatable actual argument '%s' is not " "allocated", e->symtree->n.sym->name); else if (attr.pointer - && (fsym == NULL || !fsym->attr.pointer)) + && (fsym == NULL || !fsym_attr.pointer)) msg = xasprintf ("Pointer actual argument '%s' is not " "associated", e->symtree->n.sym->name); - else if (attr.proc_pointer - && (fsym == NULL || !fsym->attr.proc_pointer)) + else if (attr.proc_pointer && !e->value.function.actual + && (fsym == NULL || !fsym_attr.proc_pointer)) msg = xasprintf ("Proc-pointer actual argument '%s' is not " "associated", e->symtree->n.sym->name); else @@ -6791,7 +6895,7 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym, /* When calling __copy for character expressions to unlimited polymorphic entities, the dst argument needs a string length. */ if (sym->name[0] == '_' && e && e->ts.type == BT_CHARACTER - && gfc_str_startswith (sym->name, "__vtab_CHARACTER") + && startswith (sym->name, "__vtab_CHARACTER") && arg->next && arg->next->expr && (arg->next->expr->ts.type == BT_DERIVED || arg->next->expr->ts.type == BT_CLASS) @@ -9414,7 +9518,7 @@ gfc_trans_pointer_assignment (gfc_expr * expr1, gfc_expr * expr2) { gfc_add_data_component (expr2); /* The following is required as gfc_add_data_component doesn't - update ts.type if there is a tailing REF_ARRAY. */ + update ts.type if there is a trailing REF_ARRAY. */ expr2->ts.type = BT_DERIVED; } @@ -9572,11 +9676,12 @@ gfc_trans_pointer_assignment (gfc_expr * expr1, gfc_expr * expr2) lse.direct_byref = 1; gfc_conv_expr_descriptor (&lse, expr2); strlen_rhs = lse.string_length; + gfc_init_se (&rse, NULL); if (expr1->ts.type == BT_CLASS) { rse.expr = NULL_TREE; - rse.string_length = NULL_TREE; + rse.string_length = strlen_rhs; trans_class_vptr_len_assignment (&block, expr1, expr2, &rse, NULL, NULL); } @@ -9636,6 +9741,19 @@ gfc_trans_pointer_assignment (gfc_expr * expr1, gfc_expr * expr2) gfc_add_modify (&lse.pre, desc, tmp); } + if (expr1->ts.type == BT_CHARACTER + && expr1->symtree->n.sym->ts.deferred + && expr1->symtree->n.sym->ts.u.cl->backend_decl + && VAR_P (expr1->symtree->n.sym->ts.u.cl->backend_decl)) + { + tmp = expr1->symtree->n.sym->ts.u.cl->backend_decl; + if (expr2->expr_type != EXPR_NULL) + gfc_add_modify (&block, tmp, + fold_convert (TREE_TYPE (tmp), strlen_rhs)); + else + gfc_add_modify (&block, tmp, build_zero_cst (TREE_TYPE (tmp))); + } + gfc_add_block_to_block (&block, &lse.pre); if (rank_remap) gfc_add_block_to_block (&block, &rse.pre); @@ -9798,19 +9916,6 @@ gfc_trans_pointer_assignment (gfc_expr * expr1, gfc_expr * expr2) msg, rsize, lsize); } - if (expr1->ts.type == BT_CHARACTER - && expr1->symtree->n.sym->ts.deferred - && expr1->symtree->n.sym->ts.u.cl->backend_decl - && VAR_P (expr1->symtree->n.sym->ts.u.cl->backend_decl)) - { - tmp = expr1->symtree->n.sym->ts.u.cl->backend_decl; - if (expr2->expr_type != EXPR_NULL) - gfc_add_modify (&block, tmp, - fold_convert (TREE_TYPE (tmp), strlen_rhs)); - else - gfc_add_modify (&block, tmp, build_zero_cst (TREE_TYPE (tmp))); - } - /* Check string lengths if applicable. The check is only really added to the output code if -fbounds-check is enabled. */ if (expr1->ts.type == BT_CHARACTER && expr2->expr_type != EXPR_NULL) @@ -9993,17 +10098,20 @@ gfc_trans_scalar_assign (gfc_se * lse, gfc_se * rse, gfc_typespec ts, gfc_add_modify (&block, lse->expr, tmp); } /* If possible use the rhs vptr copy with trans_scalar_class_assign.... */ - else if (ts.type == BT_CLASS - && !trans_scalar_class_assign (&block, lse, rse)) + else if (ts.type == BT_CLASS) { gfc_add_block_to_block (&block, &lse->pre); gfc_add_block_to_block (&block, &rse->pre); - /* ...otherwise assignment suffices. Note the use of VIEW_CONVERT_EXPR - for the lhs which ensures that class data rhs cast as a string assigns - correctly. */ - tmp = fold_build1_loc (input_location, VIEW_CONVERT_EXPR, - TREE_TYPE (rse->expr), lse->expr); - gfc_add_modify (&block, tmp, rse->expr); + + if (!trans_scalar_class_assign (&block, lse, rse)) + { + /* ...otherwise assignment suffices. Note the use of VIEW_CONVERT_EXPR + for the lhs which ensures that class data rhs cast as a string assigns + correctly. */ + tmp = fold_build1_loc (input_location, VIEW_CONVERT_EXPR, + TREE_TYPE (rse->expr), lse->expr); + gfc_add_modify (&block, tmp, rse->expr); + } } else if (ts.type != BT_CLASS) { diff --git a/gcc/fortran/trans-intrinsic.c b/gcc/fortran/trans-intrinsic.c index 5e53d11..46670ba 100644 --- a/gcc/fortran/trans-intrinsic.c +++ b/gcc/fortran/trans-intrinsic.c @@ -386,30 +386,20 @@ build_round_expr (tree arg, tree restype) argprec = TYPE_PRECISION (argtype); resprec = TYPE_PRECISION (restype); - /* Depending on the type of the result, choose the int intrinsic - (iround, available only as a builtin, therefore cannot use it for - __float128), long int intrinsic (lround family) or long long - intrinsic (llround). We might also need to convert the result - afterwards. */ + /* Depending on the type of the result, choose the int intrinsic (iround, + available only as a builtin, therefore cannot use it for __float128), long + int intrinsic (lround family) or long long intrinsic (llround). If we + don't have an appropriate function that converts directly to the integer + type (such as kind == 16), just use ROUND, and then convert the result to + an integer. We might also need to convert the result afterwards. */ if (resprec <= INT_TYPE_SIZE && argprec <= LONG_DOUBLE_TYPE_SIZE) fn = builtin_decl_for_precision (BUILT_IN_IROUND, argprec); else if (resprec <= LONG_TYPE_SIZE) fn = builtin_decl_for_precision (BUILT_IN_LROUND, argprec); else if (resprec <= LONG_LONG_TYPE_SIZE) fn = builtin_decl_for_precision (BUILT_IN_LLROUND, argprec); - else if (resprec >= argprec && resprec == 128) - { - /* Search for a real kind suitable as temporary for conversion. */ - int kind = -1; - for (int i = 0; kind < 0 && gfc_real_kinds[i].kind != 0; i++) - if (gfc_real_kinds[i].mode_precision >= resprec) - kind = gfc_real_kinds[i].kind; - if (kind < 0) - gfc_internal_error ("Could not find real kind with at least %d bits", - resprec); - arg = fold_convert (gfc_get_real_type (kind), arg); - fn = gfc_builtin_decl_for_float_kind (BUILT_IN_ROUND, kind); - } + else if (resprec >= argprec) + fn = builtin_decl_for_precision (BUILT_IN_ROUND, argprec); else gcc_unreachable (); @@ -3837,38 +3827,43 @@ conv_intrinsic_random_init (gfc_code *code) { stmtblock_t block; gfc_se se; - tree arg1, arg2, arg3, tmp; - tree logical4_type_node = gfc_get_logical_type (4); + tree arg1, arg2, tmp; + /* On none coarray == lib compiles use LOGICAL(4) else regular LOGICAL. */ + tree used_bool_type_node = flag_coarray == GFC_FCOARRAY_LIB + ? logical_type_node + : gfc_get_logical_type (4); /* Make the function call. */ gfc_init_block (&block); gfc_init_se (&se, NULL); - /* Convert REPEATABLE to a LOGICAL(4) entity. */ + /* Convert REPEATABLE to the desired LOGICAL entity. */ gfc_conv_expr (&se, code->ext.actual->expr); gfc_add_block_to_block (&block, &se.pre); - arg1 = fold_convert (logical4_type_node, gfc_evaluate_now (se.expr, &block)); + arg1 = fold_convert (used_bool_type_node, gfc_evaluate_now (se.expr, &block)); gfc_add_block_to_block (&block, &se.post); - /* Convert IMAGE_DISTINCT to a LOGICAL(4) entity. */ + /* Convert IMAGE_DISTINCT to the desired LOGICAL entity. */ gfc_conv_expr (&se, code->ext.actual->next->expr); gfc_add_block_to_block (&block, &se.pre); - arg2 = fold_convert (logical4_type_node, gfc_evaluate_now (se.expr, &block)); + arg2 = fold_convert (used_bool_type_node, gfc_evaluate_now (se.expr, &block)); gfc_add_block_to_block (&block, &se.post); - /* Create the hidden argument. For non-coarray codes and -fcoarray=single, - simply set this to 0. For -fcoarray=lib, generate a call to - THIS_IMAGE() without arguments. */ - arg3 = build_int_cst (gfc_get_int_type (4), 0); if (flag_coarray == GFC_FCOARRAY_LIB) { - arg3 = build_call_expr_loc (input_location, gfor_fndecl_caf_this_image, - 1, arg3); - se.expr = fold_convert (gfc_get_int_type (4), arg3); + tmp = build_call_expr_loc (input_location, gfor_fndecl_caf_random_init, + 2, arg1, arg2); + } + else + { + /* The ABI for libgfortran needs to be maintained, so a hidden + argument must be include if code is compiled with -fcoarray=single + or without the option. Set to 0. */ + tree arg3 = build_int_cst (gfc_get_int_type (4), 0); + tmp = build_call_expr_loc (input_location, gfor_fndecl_random_init, + 3, arg1, arg2, arg3); } - tmp = build_call_expr_loc (input_location, gfor_fndecl_random_init, 3, - arg1, arg2, arg3); gfc_add_expr_to_block (&block, tmp); return gfc_finish_block (&block); @@ -4152,10 +4147,7 @@ gfc_conv_intrinsic_minmax (gfc_se * se, gfc_expr * expr, enum tree_code op) build_empty_stmt (input_location)); gfc_add_expr_to_block (&se->pre, tmp); } - if (TREE_CODE (type) == INTEGER_TYPE) - se->expr = fold_build1_loc (input_location, FIX_TRUNC_EXPR, type, mvar); - else - se->expr = convert (type, mvar); + se->expr = convert (type, mvar); } @@ -8009,7 +8001,14 @@ gfc_conv_intrinsic_size (gfc_se * se, gfc_expr * expr) tree temp; tree cond; - attr = sym ? sym->attr : gfc_expr_attr (e); + if (e->symtree->n.sym && IS_CLASS_ARRAY (e->symtree->n.sym)) + { + attr = CLASS_DATA (e->symtree->n.sym)->attr; + attr.pointer = attr.class_pointer; + } + else + attr = gfc_expr_attr (e); + if (attr.allocatable) msg = xasprintf ("Allocatable argument '%s' is not allocated", e->symtree->n.sym->name); @@ -9078,6 +9077,7 @@ gfc_conv_associated (gfc_se *se, gfc_expr *expr) gfc_add_block_to_block (&se->post, &arg1se.post); arg2se.want_pointer = 1; + arg2se.force_no_tmp = 1; gfc_conv_expr_descriptor (&arg2se, arg2->expr); gfc_add_block_to_block (&se->pre, &arg2se.pre); gfc_add_block_to_block (&se->post, &arg2se.post); @@ -10072,27 +10072,27 @@ gfc_conv_ieee_arithmetic_function (gfc_se * se, gfc_expr * expr) { const char *name = expr->value.function.name; - if (gfc_str_startswith (name, "_gfortran_ieee_is_nan")) + if (startswith (name, "_gfortran_ieee_is_nan")) conv_intrinsic_ieee_builtin (se, expr, BUILT_IN_ISNAN, 1); - else if (gfc_str_startswith (name, "_gfortran_ieee_is_finite")) + else if (startswith (name, "_gfortran_ieee_is_finite")) conv_intrinsic_ieee_builtin (se, expr, BUILT_IN_ISFINITE, 1); - else if (gfc_str_startswith (name, "_gfortran_ieee_unordered")) + else if (startswith (name, "_gfortran_ieee_unordered")) conv_intrinsic_ieee_builtin (se, expr, BUILT_IN_ISUNORDERED, 2); - else if (gfc_str_startswith (name, "_gfortran_ieee_is_normal")) + else if (startswith (name, "_gfortran_ieee_is_normal")) conv_intrinsic_ieee_is_normal (se, expr); - else if (gfc_str_startswith (name, "_gfortran_ieee_is_negative")) + else if (startswith (name, "_gfortran_ieee_is_negative")) conv_intrinsic_ieee_is_negative (se, expr); - else if (gfc_str_startswith (name, "_gfortran_ieee_copy_sign")) + else if (startswith (name, "_gfortran_ieee_copy_sign")) conv_intrinsic_ieee_copy_sign (se, expr); - else if (gfc_str_startswith (name, "_gfortran_ieee_scalb")) + else if (startswith (name, "_gfortran_ieee_scalb")) conv_intrinsic_ieee_scalb (se, expr); - else if (gfc_str_startswith (name, "_gfortran_ieee_next_after")) + else if (startswith (name, "_gfortran_ieee_next_after")) conv_intrinsic_ieee_next_after (se, expr); - else if (gfc_str_startswith (name, "_gfortran_ieee_rem")) + else if (startswith (name, "_gfortran_ieee_rem")) conv_intrinsic_ieee_rem (se, expr); - else if (gfc_str_startswith (name, "_gfortran_ieee_logb")) + else if (startswith (name, "_gfortran_ieee_logb")) conv_intrinsic_ieee_logb_rint (se, expr, BUILT_IN_LOGB); - else if (gfc_str_startswith (name, "_gfortran_ieee_rint")) + else if (startswith (name, "_gfortran_ieee_rint")) conv_intrinsic_ieee_logb_rint (se, expr, BUILT_IN_RINT); else /* It is not among the functions we translate directly. We return @@ -11242,8 +11242,28 @@ conv_co_collective (gfc_code *code) if (flag_coarray == GFC_FCOARRAY_SINGLE) { if (stat != NULL_TREE) - gfc_add_modify (&block, stat, - fold_convert (TREE_TYPE (stat), integer_zero_node)); + { + /* For optional stats, check the pointer is valid before zero'ing. */ + if (gfc_expr_attr (stat_expr).optional) + { + tree tmp; + stmtblock_t ass_block; + gfc_start_block (&ass_block); + gfc_add_modify (&ass_block, stat, + fold_convert (TREE_TYPE (stat), + integer_zero_node)); + tmp = fold_build2 (NE_EXPR, logical_type_node, + gfc_build_addr_expr (NULL_TREE, stat), + null_pointer_node); + tmp = fold_build3 (COND_EXPR, void_type_node, tmp, + gfc_finish_block (&ass_block), + build_empty_stmt (input_location)); + gfc_add_expr_to_block (&block, tmp); + } + else + gfc_add_modify (&block, stat, + fold_convert (TREE_TYPE (stat), integer_zero_node)); + } return gfc_finish_block (&block); } diff --git a/gcc/fortran/trans-openmp.c b/gcc/fortran/trans-openmp.c index 349df1c..e55e0c8 100644 --- a/gcc/fortran/trans-openmp.c +++ b/gcc/fortran/trans-openmp.c @@ -35,6 +35,7 @@ along with GCC; see the file COPYING3. If not see #include "trans-array.h" #include "trans-const.h" #include "arith.h" +#include "constructor.h" #include "gomp-constants.h" #include "omp-general.h" #include "omp-low.h" @@ -360,6 +361,61 @@ gfc_has_alloc_comps (tree type, tree decl) return false; } +/* Return true if TYPE is polymorphic but not with pointer attribute. */ + +static bool +gfc_is_polymorphic_nonptr (tree type) +{ + if (POINTER_TYPE_P (type)) + type = TREE_TYPE (type); + return GFC_CLASS_TYPE_P (type); +} + +/* Return true if TYPE is unlimited polymorphic but not with pointer attribute; + unlimited means also intrinsic types are handled and _len is used. */ + +static bool +gfc_is_unlimited_polymorphic_nonptr (tree type) +{ + if (POINTER_TYPE_P (type)) + type = TREE_TYPE (type); + if (!GFC_CLASS_TYPE_P (type)) + return false; + + tree field = TYPE_FIELDS (type); /* _data */ + gcc_assert (field); + field = DECL_CHAIN (field); /* _vptr */ + gcc_assert (field); + field = DECL_CHAIN (field); + if (!field) + return false; + gcc_assert (strcmp ("_len", IDENTIFIER_POINTER (DECL_NAME (field))) == 0); + return true; +} + +/* Return true if the DECL is for an allocatable array or scalar. */ + +bool +gfc_omp_allocatable_p (tree decl) +{ + if (!DECL_P (decl)) + return false; + + if (GFC_DECL_GET_SCALAR_ALLOCATABLE (decl)) + return true; + + tree type = TREE_TYPE (decl); + if (gfc_omp_privatize_by_reference (decl)) + type = TREE_TYPE (type); + + if (GFC_DESCRIPTOR_TYPE_P (type) + && GFC_TYPE_ARRAY_AKIND (type) == GFC_ARRAY_ALLOCATABLE) + return true; + + return false; +} + + /* Return true if DECL in private clause needs OMP_CLAUSE_PRIVATE_OUTER_REF on the private clause. */ bool @@ -729,7 +785,7 @@ gfc_omp_clause_default_ctor (tree clause, tree decl, tree outer) else_b)); /* Avoid -W*uninitialized warnings. */ if (DECL_P (decl)) - TREE_NO_WARNING (decl) = 1; + suppress_warning (decl, OPT_Wuninitialized); } else gfc_add_expr_to_block (&block, then_b); @@ -743,12 +799,88 @@ tree gfc_omp_clause_copy_ctor (tree clause, tree dest, tree src) { tree type = TREE_TYPE (dest), ptr, size, call; + tree decl_type = TREE_TYPE (OMP_CLAUSE_DECL (clause)); tree cond, then_b, else_b; stmtblock_t block, cond_block; gcc_assert (OMP_CLAUSE_CODE (clause) == OMP_CLAUSE_FIRSTPRIVATE || OMP_CLAUSE_CODE (clause) == OMP_CLAUSE_LINEAR); + if (DECL_ARTIFICIAL (OMP_CLAUSE_DECL (clause)) + && DECL_LANG_SPECIFIC (OMP_CLAUSE_DECL (clause)) + && GFC_DECL_SAVED_DESCRIPTOR (OMP_CLAUSE_DECL (clause))) + decl_type + = TREE_TYPE (GFC_DECL_SAVED_DESCRIPTOR (OMP_CLAUSE_DECL (clause))); + + if (gfc_is_polymorphic_nonptr (decl_type)) + { + if (POINTER_TYPE_P (decl_type)) + decl_type = TREE_TYPE (decl_type); + decl_type = TREE_TYPE (TYPE_FIELDS (decl_type)); + if (GFC_DESCRIPTOR_TYPE_P (decl_type) || GFC_ARRAY_TYPE_P (decl_type)) + fatal_error (input_location, + "Sorry, polymorphic arrays not yet supported for " + "firstprivate"); + tree src_len; + tree nelems = build_int_cst (size_type_node, 1); /* Scalar. */ + tree src_data = gfc_class_data_get (unshare_expr (src)); + tree dest_data = gfc_class_data_get (unshare_expr (dest)); + bool unlimited = gfc_is_unlimited_polymorphic_nonptr (type); + + gfc_start_block (&block); + gfc_add_modify (&block, gfc_class_vptr_get (dest), + gfc_class_vptr_get (src)); + gfc_init_block (&cond_block); + + if (unlimited) + { + src_len = gfc_class_len_get (src); + gfc_add_modify (&cond_block, gfc_class_len_get (unshare_expr (dest)), src_len); + } + + /* Use: size = class._vtab._size * (class._len > 0 ? class._len : 1). */ + size = fold_convert (size_type_node, gfc_class_vtab_size_get (src)); + if (unlimited) + { + cond = fold_build2_loc (input_location, GT_EXPR, boolean_type_node, + unshare_expr (src_len), + build_zero_cst (TREE_TYPE (src_len))); + cond = build3_loc (input_location, COND_EXPR, size_type_node, cond, + fold_convert (size_type_node, + unshare_expr (src_len)), + build_int_cst (size_type_node, 1)); + size = fold_build2_loc (input_location, MULT_EXPR, size_type_node, + size, cond); + } + + /* Malloc memory + call class->_vpt->_copy. */ + call = builtin_decl_explicit (BUILT_IN_MALLOC); + call = build_call_expr_loc (input_location, call, 1, size); + gfc_add_modify (&cond_block, dest_data, + fold_convert (TREE_TYPE (dest_data), call)); + gfc_add_expr_to_block (&cond_block, + gfc_copy_class_to_class (src, dest, nelems, + unlimited)); + + gcc_assert (TREE_CODE (dest_data) == COMPONENT_REF); + if (!GFC_DECL_GET_SCALAR_ALLOCATABLE (TREE_OPERAND (dest_data, 1))) + { + gfc_add_block_to_block (&block, &cond_block); + } + else + { + /* Create: if (class._data != 0) <cond_block> else class._data = NULL; */ + cond = fold_build2_loc (input_location, NE_EXPR, boolean_type_node, + src_data, null_pointer_node); + gfc_add_expr_to_block (&block, build3_loc (input_location, COND_EXPR, + void_type_node, cond, + gfc_finish_block (&cond_block), + fold_build2_loc (input_location, MODIFY_EXPR, void_type_node, + unshare_expr (dest_data), null_pointer_node))); + } + return gfc_finish_block (&block); + } + if ((! GFC_DESCRIPTOR_TYPE_P (type) || GFC_TYPE_ARRAY_AKIND (type) != GFC_ARRAY_ALLOCATABLE) && (!GFC_DECL_GET_SCALAR_ALLOCATABLE (OMP_CLAUSE_DECL (clause)) @@ -773,7 +905,7 @@ gfc_omp_clause_copy_ctor (tree clause, tree dest, tree src) gfc_init_block (&cond_block); - gfc_add_modify (&cond_block, dest, src); + gfc_add_modify (&cond_block, dest, fold_convert (TREE_TYPE (dest), src)); if (GFC_DESCRIPTOR_TYPE_P (type)) { tree rank = gfc_rank_cst[GFC_TYPE_ARRAY_RANK (type) - 1]; @@ -838,7 +970,7 @@ gfc_omp_clause_copy_ctor (tree clause, tree dest, tree src) void_type_node, cond, then_b, else_b)); /* Avoid -W*uninitialized warnings. */ if (DECL_P (dest)) - TREE_NO_WARNING (dest) = 1; + suppress_warning (dest, OPT_Wuninitialized); return gfc_finish_block (&block); } @@ -1185,6 +1317,57 @@ tree gfc_omp_clause_dtor (tree clause, tree decl) { tree type = TREE_TYPE (decl), tem; + tree decl_type = TREE_TYPE (OMP_CLAUSE_DECL (clause)); + + if (DECL_ARTIFICIAL (OMP_CLAUSE_DECL (clause)) + && DECL_LANG_SPECIFIC (OMP_CLAUSE_DECL (clause)) + && GFC_DECL_SAVED_DESCRIPTOR (OMP_CLAUSE_DECL (clause))) + decl_type + = TREE_TYPE (GFC_DECL_SAVED_DESCRIPTOR (OMP_CLAUSE_DECL (clause))); + if (gfc_is_polymorphic_nonptr (decl_type)) + { + if (POINTER_TYPE_P (decl_type)) + decl_type = TREE_TYPE (decl_type); + decl_type = TREE_TYPE (TYPE_FIELDS (decl_type)); + if (GFC_DESCRIPTOR_TYPE_P (decl_type) || GFC_ARRAY_TYPE_P (decl_type)) + fatal_error (input_location, + "Sorry, polymorphic arrays not yet supported for " + "firstprivate"); + stmtblock_t block, cond_block; + gfc_start_block (&block); + gfc_init_block (&cond_block); + tree final = gfc_class_vtab_final_get (decl); + tree size = fold_convert (size_type_node, gfc_class_vtab_size_get (decl)); + gfc_se se; + gfc_init_se (&se, NULL); + symbol_attribute attr = {}; + tree data = gfc_class_data_get (decl); + tree desc = gfc_conv_scalar_to_descriptor (&se, data, attr); + + /* Call class->_vpt->_finalize + free. */ + tree call = build_fold_indirect_ref (final); + call = build_call_expr_loc (input_location, call, 3, + gfc_build_addr_expr (NULL, desc), + size, boolean_false_node); + gfc_add_block_to_block (&cond_block, &se.pre); + gfc_add_expr_to_block (&cond_block, fold_convert (void_type_node, call)); + gfc_add_block_to_block (&cond_block, &se.post); + /* Create: if (_vtab && _final) <cond_block> */ + tree cond = fold_build2_loc (input_location, NE_EXPR, boolean_type_node, + gfc_class_vptr_get (decl), + null_pointer_node); + tree cond2 = fold_build2_loc (input_location, NE_EXPR, boolean_type_node, + final, null_pointer_node); + cond = fold_build2_loc (input_location, TRUTH_ANDIF_EXPR, + boolean_type_node, cond, cond2); + gfc_add_expr_to_block (&block, build3_loc (input_location, COND_EXPR, + void_type_node, cond, + gfc_finish_block (&cond_block), NULL_TREE)); + call = builtin_decl_explicit (BUILT_IN_FREE); + call = build_call_expr_loc (input_location, call, 1, data); + gfc_add_expr_to_block (&block, fold_convert (void_type_node, call)); + return gfc_finish_block (&block); + } if ((! GFC_DESCRIPTOR_TYPE_P (type) || GFC_TYPE_ARRAY_AKIND (type) != GFC_ARRAY_ALLOCATABLE) @@ -1478,6 +1661,9 @@ gfc_omp_finish_clause (tree c, gimple_seq *pre_p, bool openacc) 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); if (c2) { OMP_CLAUSE_CHAIN (c2) = OMP_CLAUSE_CHAIN (last); @@ -1499,10 +1685,11 @@ gfc_omp_finish_clause (tree c, gimple_seq *pre_p, bool openacc) /* Return true if DECL is a scalar variable (for the purpose of - implicit firstprivatization). */ + implicit firstprivatization/mapping). Only if 'ptr_alloc_ok.' + is true, allocatables and pointers are permitted. */ bool -gfc_omp_scalar_p (tree decl) +gfc_omp_scalar_p (tree decl, bool ptr_alloc_ok) { tree type = TREE_TYPE (decl); if (TREE_CODE (type) == REFERENCE_TYPE) @@ -1511,7 +1698,11 @@ gfc_omp_scalar_p (tree decl) { if (GFC_DECL_GET_SCALAR_ALLOCATABLE (decl) || GFC_DECL_GET_SCALAR_POINTER (decl)) - type = TREE_TYPE (type); + { + if (!ptr_alloc_ok) + return false; + type = TREE_TYPE (type); + } if (GFC_ARRAY_TYPE_P (type) || GFC_CLASS_TYPE_P (type)) return false; @@ -1527,6 +1718,17 @@ gfc_omp_scalar_p (tree decl) } +/* Return true if DECL is a scalar with target attribute but does not have the + allocatable (or pointer) attribute (for the purpose of implicit mapping). */ + +bool +gfc_omp_scalar_target_p (tree decl) +{ + return (DECL_P (decl) && GFC_DECL_GET_SCALAR_TARGET (decl) + && gfc_omp_scalar_p (decl, false)); +} + + /* Return true if DECL's DECL_VALUE_EXPR (if any) should be disregarded in OpenMP construct, because it is going to be remapped during OpenMP lowering. SHARED is true if DECL @@ -1750,7 +1952,7 @@ gfc_trans_omp_array_reduction_or_udr (tree c, gfc_omp_namelist *n, locus where) locus old_loc = gfc_current_locus; const char *iname; bool t; - gfc_omp_udr *udr = n->udr ? n->udr->udr : NULL; + gfc_omp_udr *udr = n->u2.udr ? n->u2.udr->udr : NULL; decl = OMP_CLAUSE_DECL (c); gfc_current_locus = where; @@ -1869,9 +2071,9 @@ gfc_trans_omp_array_reduction_or_udr (tree c, gfc_omp_namelist *n, locus where) t = gfc_resolve_expr (e2); gcc_assert (t); } - else if (n->udr->initializer->op == EXEC_ASSIGN) + else if (n->u2.udr->initializer->op == EXEC_ASSIGN) { - e2 = gfc_copy_expr (n->udr->initializer->expr2); + e2 = gfc_copy_expr (n->u2.udr->initializer->expr2); t = gfc_resolve_expr (e2); gcc_assert (t); } @@ -1880,7 +2082,7 @@ gfc_trans_omp_array_reduction_or_udr (tree c, gfc_omp_namelist *n, locus where) struct omp_udr_find_orig_data cd; cd.omp_udr = udr; cd.omp_orig_seen = false; - gfc_code_walker (&n->udr->initializer, + gfc_code_walker (&n->u2.udr->initializer, gfc_dummy_code_callback, omp_udr_find_orig, &cd); if (cd.omp_orig_seen) OMP_CLAUSE_REDUCTION_OMP_ORIG_REF (c) = 1; @@ -1930,11 +2132,11 @@ gfc_trans_omp_array_reduction_or_udr (tree c, gfc_omp_namelist *n, locus where) iname = "ieor"; break; case ERROR_MARK: - if (n->udr->combiner->op == EXEC_ASSIGN) + if (n->u2.udr->combiner->op == EXEC_ASSIGN) { gfc_free_expr (e3); - e3 = gfc_copy_expr (n->udr->combiner->expr1); - e4 = gfc_copy_expr (n->udr->combiner->expr2); + e3 = gfc_copy_expr (n->u2.udr->combiner->expr1); + e4 = gfc_copy_expr (n->u2.udr->combiner->expr2); t = gfc_resolve_expr (e3); gcc_assert (t); t = gfc_resolve_expr (e4); @@ -1984,7 +2186,7 @@ gfc_trans_omp_array_reduction_or_udr (tree c, gfc_omp_namelist *n, locus where) if (e2) stmt = gfc_trans_assignment (e1, e2, false, false); else - stmt = gfc_trans_call (n->udr->initializer, false, + stmt = gfc_trans_call (n->u2.udr->initializer, false, NULL_TREE, NULL_TREE, false); if (TREE_CODE (stmt) != BIND_EXPR) stmt = build3_v (BIND_EXPR, NULL, stmt, poplevel (1, 0)); @@ -1997,7 +2199,7 @@ gfc_trans_omp_array_reduction_or_udr (tree c, gfc_omp_namelist *n, locus where) if (e4) stmt = gfc_trans_assignment (e3, e4, false, true); else - stmt = gfc_trans_call (n->udr->combiner, false, + stmt = gfc_trans_call (n->u2.udr->combiner, false, NULL_TREE, NULL_TREE, false); if (TREE_CODE (stmt) != BIND_EXPR) stmt = build3_v (BIND_EXPR, NULL, stmt, poplevel (1, 0)); @@ -2273,13 +2475,76 @@ gfc_trans_omp_array_section (stmtblock_t *block, gfc_omp_namelist *n, } static tree +handle_iterator (gfc_namespace *ns, stmtblock_t *iter_block, tree block) +{ + tree list = NULL_TREE; + for (gfc_symbol *sym = ns->proc_name; sym; sym = sym->tlink) + { + gfc_constructor *c; + gfc_se se; + + tree last = make_tree_vec (6); + tree iter_var = gfc_get_symbol_decl (sym); + tree type = TREE_TYPE (iter_var); + TREE_VEC_ELT (last, 0) = iter_var; + DECL_CHAIN (iter_var) = BLOCK_VARS (block); + BLOCK_VARS (block) = iter_var; + + /* begin */ + c = gfc_constructor_first (sym->value->value.constructor); + gfc_init_se (&se, NULL); + gfc_conv_expr (&se, c->expr); + gfc_add_block_to_block (iter_block, &se.pre); + gfc_add_block_to_block (iter_block, &se.post); + TREE_VEC_ELT (last, 1) = fold_convert (type, + gfc_evaluate_now (se.expr, + iter_block)); + /* end */ + c = gfc_constructor_next (c); + gfc_init_se (&se, NULL); + gfc_conv_expr (&se, c->expr); + gfc_add_block_to_block (iter_block, &se.pre); + gfc_add_block_to_block (iter_block, &se.post); + TREE_VEC_ELT (last, 2) = fold_convert (type, + gfc_evaluate_now (se.expr, + iter_block)); + /* step */ + c = gfc_constructor_next (c); + tree step; + if (c) + { + gfc_init_se (&se, NULL); + gfc_conv_expr (&se, c->expr); + gfc_add_block_to_block (iter_block, &se.pre); + gfc_add_block_to_block (iter_block, &se.post); + gfc_conv_expr (&se, c->expr); + step = fold_convert (type, + gfc_evaluate_now (se.expr, + iter_block)); + } + else + step = build_int_cst (type, 1); + TREE_VEC_ELT (last, 3) = step; + /* orig_step */ + TREE_VEC_ELT (last, 4) = save_expr (step); + TREE_CHAIN (last) = list; + list = last; + } + return list; +} + +static tree gfc_trans_omp_clauses (stmtblock_t *block, gfc_omp_clauses *clauses, locus where, bool declare_simd = false, bool openacc = false) { - tree omp_clauses = NULL_TREE, chunk_size, c; + tree omp_clauses = NULL_TREE, prev_clauses, chunk_size, c; + tree iterator = NULL_TREE; + tree tree_block = NULL_TREE; + stmtblock_t iter_block; int list, ifc; enum omp_clause_code clause_code; + gfc_omp_namelist *prev = NULL; gfc_se se; if (clauses == NULL) @@ -2482,10 +2747,38 @@ gfc_trans_omp_clauses (stmtblock_t *block, gfc_omp_clauses *clauses, } } break; + case OMP_LIST_AFFINITY: case OMP_LIST_DEPEND: + iterator = NULL_TREE; + prev = NULL; + prev_clauses = omp_clauses; for (; n != NULL; n = n->next) { - if (n->u.depend_op == OMP_DEPEND_SINK_FIRST) + if (iterator && prev->u2.ns != n->u2.ns) + { + BLOCK_SUBBLOCKS (tree_block) = gfc_finish_block (&iter_block); + TREE_VEC_ELT (iterator, 5) = tree_block; + for (tree c = omp_clauses; c != prev_clauses; + c = OMP_CLAUSE_CHAIN (c)) + OMP_CLAUSE_DECL (c) = build_tree_list (iterator, + OMP_CLAUSE_DECL (c)); + prev_clauses = omp_clauses; + iterator = NULL_TREE; + } + if (n->u2.ns && (!prev || prev->u2.ns != n->u2.ns)) + { + gfc_init_block (&iter_block); + tree_block = make_node (BLOCK); + TREE_USED (tree_block) = 1; + BLOCK_VARS (tree_block) = NULL_TREE; + iterator = handle_iterator (n->u2.ns, block, + tree_block); + } + if (!iterator) + gfc_init_block (&iter_block); + prev = n; + if (list == OMP_LIST_DEPEND + && n->u.depend_op == OMP_DEPEND_SINK_FIRST) { tree vec = NULL_TREE; unsigned int i; @@ -2539,12 +2832,18 @@ gfc_trans_omp_clauses (stmtblock_t *block, gfc_omp_clauses *clauses, if (!n->sym->attr.referenced) continue; - tree node = build_omp_clause (input_location, OMP_CLAUSE_DEPEND); + tree node = build_omp_clause (input_location, + list == OMP_LIST_DEPEND + ? OMP_CLAUSE_DEPEND + : OMP_CLAUSE_AFFINITY); if (n->expr == NULL || n->expr->ref->u.ar.type == AR_FULL) { tree decl = gfc_trans_omp_variable (n->sym, false); if (gfc_omp_privatize_by_reference (decl)) decl = build_fold_indirect_ref (decl); + if (n->u.depend_op == OMP_DEPEND_DEPOBJ + && POINTER_TYPE_P (TREE_TYPE (decl))) + decl = build_fold_indirect_ref (decl); if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (decl))) { decl = gfc_conv_descriptor_data_get (decl); @@ -2570,28 +2869,47 @@ gfc_trans_omp_clauses (stmtblock_t *block, gfc_omp_clauses *clauses, gfc_conv_expr_descriptor (&se, n->expr); ptr = gfc_conv_array_data (se.expr); } - gfc_add_block_to_block (block, &se.pre); - gfc_add_block_to_block (block, &se.post); + gfc_add_block_to_block (&iter_block, &se.pre); + gfc_add_block_to_block (&iter_block, &se.post); ptr = fold_convert (build_pointer_type (char_type_node), ptr); OMP_CLAUSE_DECL (node) = build_fold_indirect_ref (ptr); } - switch (n->u.depend_op) - { - case OMP_DEPEND_IN: - OMP_CLAUSE_DEPEND_KIND (node) = OMP_CLAUSE_DEPEND_IN; - break; - case OMP_DEPEND_OUT: - OMP_CLAUSE_DEPEND_KIND (node) = OMP_CLAUSE_DEPEND_OUT; - break; - case OMP_DEPEND_INOUT: - OMP_CLAUSE_DEPEND_KIND (node) = OMP_CLAUSE_DEPEND_INOUT; - break; - default: - gcc_unreachable (); - } + if (list == OMP_LIST_DEPEND) + switch (n->u.depend_op) + { + case OMP_DEPEND_IN: + OMP_CLAUSE_DEPEND_KIND (node) = OMP_CLAUSE_DEPEND_IN; + break; + case OMP_DEPEND_OUT: + OMP_CLAUSE_DEPEND_KIND (node) = OMP_CLAUSE_DEPEND_OUT; + break; + case OMP_DEPEND_INOUT: + OMP_CLAUSE_DEPEND_KIND (node) = OMP_CLAUSE_DEPEND_INOUT; + break; + case OMP_DEPEND_MUTEXINOUTSET: + OMP_CLAUSE_DEPEND_KIND (node) + = OMP_CLAUSE_DEPEND_MUTEXINOUTSET; + break; + case OMP_DEPEND_DEPOBJ: + OMP_CLAUSE_DEPEND_KIND (node) = OMP_CLAUSE_DEPEND_DEPOBJ; + break; + default: + gcc_unreachable (); + } + if (!iterator) + gfc_add_block_to_block (block, &iter_block); omp_clauses = gfc_trans_add_clause (node, omp_clauses); } + if (iterator) + { + BLOCK_SUBBLOCKS (tree_block) = gfc_finish_block (&iter_block); + TREE_VEC_ELT (iterator, 5) = tree_block; + for (tree c = omp_clauses; c != prev_clauses; + c = OMP_CLAUSE_CHAIN (c)) + OMP_CLAUSE_DECL (c) = build_tree_list (iterator, + OMP_CLAUSE_DECL (c)); + } break; case OMP_LIST_MAP: for (; n != NULL; n = n->next) @@ -3547,6 +3865,9 @@ gfc_trans_omp_clauses (stmtblock_t *block, gfc_omp_clauses *clauses, c = build_omp_clause (gfc_get_location (&where), OMP_CLAUSE_PROC_BIND); switch (clauses->proc_bind) { + case OMP_PROC_BIND_PRIMARY: + OMP_CLAUSE_PROC_BIND_KIND (c) = OMP_CLAUSE_PROC_BIND_PRIMARY; + break; case OMP_PROC_BIND_MASTER: OMP_CLAUSE_PROC_BIND_KIND (c) = OMP_CLAUSE_PROC_BIND_MASTER; break; @@ -3629,6 +3950,10 @@ gfc_trans_omp_clauses (stmtblock_t *block, gfc_omp_clauses *clauses, c = build_omp_clause (gfc_get_location (&where), OMP_CLAUSE_DEVICE); OMP_CLAUSE_DEVICE_ID (c) = device; + + if (clauses->ancestor) + OMP_CLAUSE_DEVICE_ANCESTOR (c) = 1; + omp_clauses = gfc_trans_add_clause (c, omp_clauses); } @@ -3677,6 +4002,8 @@ gfc_trans_omp_clauses (stmtblock_t *block, gfc_omp_clauses *clauses, c = build_omp_clause (gfc_get_location (&where), OMP_CLAUSE_GRAINSIZE); OMP_CLAUSE_GRAINSIZE_EXPR (c) = grainsize; + if (clauses->grainsize_strict) + OMP_CLAUSE_GRAINSIZE_STRICT (c) = 1; omp_clauses = gfc_trans_add_clause (c, omp_clauses); } @@ -3692,6 +4019,8 @@ gfc_trans_omp_clauses (stmtblock_t *block, gfc_omp_clauses *clauses, c = build_omp_clause (gfc_get_location (&where), OMP_CLAUSE_NUM_TASKS); OMP_CLAUSE_NUM_TASKS_EXPR (c) = num_tasks; + if (clauses->num_tasks_strict) + OMP_CLAUSE_NUM_TASKS_STRICT (c) = 1; omp_clauses = gfc_trans_add_clause (c, omp_clauses); } @@ -3726,6 +4055,21 @@ gfc_trans_omp_clauses (stmtblock_t *block, gfc_omp_clauses *clauses, omp_clauses = gfc_trans_add_clause (c, omp_clauses); } + if (clauses->filter) + { + tree filter; + + gfc_init_se (&se, NULL); + gfc_conv_expr (&se, clauses->filter); + gfc_add_block_to_block (block, &se.pre); + filter = gfc_evaluate_now (se.expr, block); + gfc_add_block_to_block (block, &se.post); + + c = build_omp_clause (gfc_get_location (&where), OMP_CLAUSE_FILTER); + OMP_CLAUSE_FILTER_EXPR (c) = filter; + omp_clauses = gfc_trans_add_clause (c, omp_clauses); + } + if (clauses->hint) { tree hint; @@ -3756,13 +4100,55 @@ gfc_trans_omp_clauses (stmtblock_t *block, gfc_omp_clauses *clauses, c = build_omp_clause (gfc_get_location (&where), OMP_CLAUSE_NOGROUP); omp_clauses = gfc_trans_add_clause (c, omp_clauses); } - if (clauses->defaultmap) + + for (int i = 0; i < OMP_DEFAULTMAP_CAT_NUM; i++) { + if (clauses->defaultmap[i] == OMP_DEFAULTMAP_UNSET) + continue; + enum omp_clause_defaultmap_kind behavior, category; + switch ((gfc_omp_defaultmap_category) i) + { + case OMP_DEFAULTMAP_CAT_UNCATEGORIZED: + category = OMP_CLAUSE_DEFAULTMAP_CATEGORY_UNSPECIFIED; + break; + case OMP_DEFAULTMAP_CAT_SCALAR: + category = OMP_CLAUSE_DEFAULTMAP_CATEGORY_SCALAR; + break; + case OMP_DEFAULTMAP_CAT_AGGREGATE: + category = OMP_CLAUSE_DEFAULTMAP_CATEGORY_AGGREGATE; + break; + case OMP_DEFAULTMAP_CAT_ALLOCATABLE: + category = OMP_CLAUSE_DEFAULTMAP_CATEGORY_ALLOCATABLE; + break; + case OMP_DEFAULTMAP_CAT_POINTER: + category = OMP_CLAUSE_DEFAULTMAP_CATEGORY_POINTER; + break; + default: gcc_unreachable (); + } + switch (clauses->defaultmap[i]) + { + case OMP_DEFAULTMAP_ALLOC: + behavior = OMP_CLAUSE_DEFAULTMAP_ALLOC; + break; + case OMP_DEFAULTMAP_TO: behavior = OMP_CLAUSE_DEFAULTMAP_TO; break; + case OMP_DEFAULTMAP_FROM: behavior = OMP_CLAUSE_DEFAULTMAP_FROM; break; + case OMP_DEFAULTMAP_TOFROM: + behavior = OMP_CLAUSE_DEFAULTMAP_TOFROM; + break; + case OMP_DEFAULTMAP_FIRSTPRIVATE: + behavior = OMP_CLAUSE_DEFAULTMAP_FIRSTPRIVATE; + break; + case OMP_DEFAULTMAP_NONE: behavior = OMP_CLAUSE_DEFAULTMAP_NONE; break; + case OMP_DEFAULTMAP_DEFAULT: + behavior = OMP_CLAUSE_DEFAULTMAP_DEFAULT; + break; + default: gcc_unreachable (); + } c = build_omp_clause (gfc_get_location (&where), OMP_CLAUSE_DEFAULTMAP); - OMP_CLAUSE_DEFAULTMAP_SET_KIND (c, OMP_CLAUSE_DEFAULTMAP_TOFROM, - OMP_CLAUSE_DEFAULTMAP_CATEGORY_SCALAR); + OMP_CLAUSE_DEFAULTMAP_SET_KIND (c, behavior, category); omp_clauses = gfc_trans_add_clause (c, omp_clauses); } + if (clauses->depend_source) { c = build_omp_clause (gfc_get_location (&where), OMP_CLAUSE_DEPEND); @@ -3918,6 +4304,27 @@ gfc_trans_omp_clauses (stmtblock_t *block, gfc_omp_clauses *clauses, OMP_CLAUSE_GANG_STATIC_EXPR (c) = arg; } } + if (clauses->bind != OMP_BIND_UNSET) + { + c = build_omp_clause (gfc_get_location (&where), OMP_CLAUSE_BIND); + omp_clauses = gfc_trans_add_clause (c, omp_clauses); + switch (clauses->bind) + { + case OMP_BIND_TEAMS: + OMP_CLAUSE_BIND_KIND (c) = OMP_CLAUSE_BIND_TEAMS; + break; + case OMP_BIND_PARALLEL: + OMP_CLAUSE_BIND_KIND (c) = OMP_CLAUSE_BIND_PARALLEL; + break; + case OMP_BIND_THREAD: + OMP_CLAUSE_BIND_KIND (c) = OMP_CLAUSE_BIND_THREAD; + break; + default: + gcc_unreachable (); + } + } + /* OpenACC 'nohost' clauses cannot appear here. */ + gcc_checking_assert (!clauses->nohost); return nreverse (omp_clauses); } @@ -4806,6 +5213,7 @@ gfc_trans_omp_do (gfc_code *code, gfc_exec_op op, stmtblock_t *pblock, case EXEC_OMP_SIMD: stmt = make_node (OMP_SIMD); break; case EXEC_OMP_DO: stmt = make_node (OMP_FOR); break; case EXEC_OMP_DISTRIBUTE: stmt = make_node (OMP_DISTRIBUTE); break; + case EXEC_OMP_LOOP: stmt = make_node (OMP_LOOP); break; case EXEC_OMP_TASKLOOP: stmt = make_node (OMP_TASKLOOP); break; case EXEC_OACC_LOOP: stmt = make_node (OACC_LOOP); break; default: gcc_unreachable (); @@ -4913,11 +5321,100 @@ gfc_trans_oacc_combined_directive (gfc_code *code) } static tree +gfc_trans_omp_depobj (gfc_code *code) +{ + stmtblock_t block; + gfc_se se; + gfc_init_se (&se, NULL); + gfc_init_block (&block); + gfc_conv_expr (&se, code->ext.omp_clauses->depobj); + gcc_assert (se.pre.head == NULL && se.post.head == NULL); + tree depobj = se.expr; + location_t loc = EXPR_LOCATION (depobj); + if (!POINTER_TYPE_P (TREE_TYPE (depobj))) + depobj = gfc_build_addr_expr (NULL, depobj); + depobj = fold_convert (build_pointer_type_for_mode (ptr_type_node, + TYPE_MODE (ptr_type_node), + true), depobj); + gfc_omp_namelist *n = code->ext.omp_clauses->lists[OMP_LIST_DEPEND]; + if (n) + { + tree var; + if (n->expr) + var = gfc_convert_expr_to_tree (&block, n->expr); + else + var = gfc_get_symbol_decl (n->sym); + if (!POINTER_TYPE_P (TREE_TYPE (var))) + var = gfc_build_addr_expr (NULL, var); + depobj = save_expr (depobj); + tree r = build_fold_indirect_ref_loc (loc, depobj); + gfc_add_expr_to_block (&block, + build2 (MODIFY_EXPR, void_type_node, r, var)); + } + + /* Only one may be set. */ + gcc_assert (((int)(n != NULL) + (int)(code->ext.omp_clauses->destroy) + + (int)(code->ext.omp_clauses->depobj_update != OMP_DEPEND_UNSET)) + == 1); + int k = -1; /* omp_clauses->destroy */ + if (!code->ext.omp_clauses->destroy) + switch (code->ext.omp_clauses->depobj_update != OMP_DEPEND_UNSET + ? code->ext.omp_clauses->depobj_update : n->u.depend_op) + { + case OMP_DEPEND_IN: k = GOMP_DEPEND_IN; break; + case OMP_DEPEND_OUT: k = GOMP_DEPEND_OUT; break; + case OMP_DEPEND_INOUT: k = GOMP_DEPEND_INOUT; break; + case OMP_DEPEND_MUTEXINOUTSET: k = GOMP_DEPEND_MUTEXINOUTSET; break; + default: gcc_unreachable (); + } + tree t = build_int_cst (ptr_type_node, k); + depobj = build2_loc (loc, POINTER_PLUS_EXPR, TREE_TYPE (depobj), depobj, + TYPE_SIZE_UNIT (ptr_type_node)); + depobj = build_fold_indirect_ref_loc (loc, depobj); + gfc_add_expr_to_block (&block, build2 (MODIFY_EXPR, void_type_node, depobj, t)); + + return gfc_finish_block (&block); +} + +static tree +gfc_trans_omp_error (gfc_code *code) +{ + stmtblock_t block; + gfc_se se; + tree len, message; + bool fatal = code->ext.omp_clauses->severity == OMP_SEVERITY_FATAL; + tree fndecl = builtin_decl_explicit (fatal ? BUILT_IN_GOMP_ERROR + : BUILT_IN_GOMP_WARNING); + gfc_start_block (&block); + gfc_init_se (&se, NULL ); + if (!code->ext.omp_clauses->message) + { + message = null_pointer_node; + len = build_int_cst (size_type_node, 0); + } + else + { + gfc_conv_expr (&se, code->ext.omp_clauses->message); + message = se.expr; + if (!POINTER_TYPE_P (TREE_TYPE (message))) + /* To ensure an ARRAY_TYPE is not passed as such. */ + message = gfc_build_addr_expr (NULL, message); + len = se.string_length; + } + gfc_add_block_to_block (&block, &se.pre); + gfc_add_expr_to_block (&block, build_call_expr_loc (input_location, fndecl, + 2, message, len)); + gfc_add_block_to_block (&block, &se.post); + return gfc_finish_block (&block); +} + +static tree gfc_trans_omp_flush (gfc_code *code) { tree call; if (!code->ext.omp_clauses - || code->ext.omp_clauses->memorder == OMP_MEMORDER_UNSET) + || code->ext.omp_clauses->memorder == OMP_MEMORDER_UNSET + || code->ext.omp_clauses->memorder == OMP_MEMORDER_SEQ_CST) { call = builtin_decl_explicit (BUILT_IN_SYNC_SYNCHRONIZE); call = build_call_expr_loc (input_location, call, 0); @@ -4949,6 +5446,26 @@ gfc_trans_omp_master (gfc_code *code) } static tree +gfc_trans_omp_masked (gfc_code *code, gfc_omp_clauses *clauses) +{ + stmtblock_t block; + tree body = gfc_trans_code (code->block->next); + if (IS_EMPTY_STMT (body)) + return body; + if (!clauses) + clauses = code->ext.omp_clauses; + gfc_start_block (&block); + tree omp_clauses = gfc_trans_omp_clauses (&block, clauses, code->loc); + tree stmt = make_node (OMP_MASKED); + TREE_TYPE (stmt) = void_type_node; + OMP_MASKED_BODY (stmt) = body; + OMP_MASKED_CLAUSES (stmt) = omp_clauses; + gfc_add_expr_to_block (&block, stmt); + return gfc_finish_block (&block); +} + + +static tree gfc_trans_omp_ordered (gfc_code *code) { if (!flag_openmp) @@ -4991,6 +5508,7 @@ enum GFC_OMP_SPLIT_TEAMS, GFC_OMP_SPLIT_TARGET, GFC_OMP_SPLIT_TASKLOOP, + GFC_OMP_SPLIT_MASKED, GFC_OMP_SPLIT_NUM }; @@ -5002,14 +5520,157 @@ enum GFC_OMP_MASK_DISTRIBUTE = (1 << GFC_OMP_SPLIT_DISTRIBUTE), GFC_OMP_MASK_TEAMS = (1 << GFC_OMP_SPLIT_TEAMS), GFC_OMP_MASK_TARGET = (1 << GFC_OMP_SPLIT_TARGET), - GFC_OMP_MASK_TASKLOOP = (1 << GFC_OMP_SPLIT_TASKLOOP) + GFC_OMP_MASK_TASKLOOP = (1 << GFC_OMP_SPLIT_TASKLOOP), + GFC_OMP_MASK_MASKED = (1 << GFC_OMP_SPLIT_MASKED) }; +/* If a var is in lastprivate/firstprivate/reduction but not in a + data mapping/sharing clause, add it to 'map(tofrom:' if is_target + and to 'shared' otherwise. */ +static void +gfc_add_clause_implicitly (gfc_omp_clauses *clauses_out, + gfc_omp_clauses *clauses_in, + bool is_target, bool is_parallel_do) +{ + int clauselist_to_add = is_target ? OMP_LIST_MAP : OMP_LIST_SHARED; + gfc_omp_namelist *tail = NULL; + for (int i = 0; i < 5; ++i) + { + gfc_omp_namelist *n; + switch (i) + { + case 0: n = clauses_in->lists[OMP_LIST_FIRSTPRIVATE]; break; + case 1: n = clauses_in->lists[OMP_LIST_LASTPRIVATE]; break; + case 2: n = clauses_in->lists[OMP_LIST_REDUCTION]; break; + case 3: n = clauses_in->lists[OMP_LIST_REDUCTION_INSCAN]; break; + case 4: n = clauses_in->lists[OMP_LIST_REDUCTION_TASK]; break; + default: gcc_unreachable (); + } + for (; n != NULL; n = n->next) + { + gfc_omp_namelist *n2, **n_firstp = NULL, **n_lastp = NULL; + for (int j = 0; j < 6; ++j) + { + gfc_omp_namelist **n2ref = NULL, *prev2 = NULL; + switch (j) + { + case 0: + n2ref = &clauses_out->lists[clauselist_to_add]; + break; + case 1: + n2ref = &clauses_out->lists[OMP_LIST_FIRSTPRIVATE]; + break; + case 2: + if (is_target) + n2ref = &clauses_in->lists[OMP_LIST_LASTPRIVATE]; + else + n2ref = &clauses_out->lists[OMP_LIST_LASTPRIVATE]; + break; + case 3: n2ref = &clauses_out->lists[OMP_LIST_REDUCTION]; break; + case 4: + n2ref = &clauses_out->lists[OMP_LIST_REDUCTION_INSCAN]; + break; + case 5: + n2ref = &clauses_out->lists[OMP_LIST_REDUCTION_TASK]; + break; + default: gcc_unreachable (); + } + for (n2 = *n2ref; n2 != NULL; prev2 = n2, n2 = n2->next) + if (n2->sym == n->sym) + break; + if (n2) + { + if (j == 0 /* clauselist_to_add */) + break; /* Already present. */ + if (j == 1 /* OMP_LIST_FIRSTPRIVATE */) + { + n_firstp = prev2 ? &prev2->next : n2ref; + continue; + } + if (j == 2 /* OMP_LIST_LASTPRIVATE */) + { + n_lastp = prev2 ? &prev2->next : n2ref; + continue; + } + break; + } + } + if (n_firstp && n_lastp) + { + /* For parallel do, GCC puts firstprivatee/lastprivate + on the parallel. */ + if (is_parallel_do) + continue; + *n_firstp = (*n_firstp)->next; + if (!is_target) + *n_lastp = (*n_lastp)->next; + } + else if (is_target && n_lastp) + ; + else if (n2 || n_firstp || n_lastp) + continue; + if (clauses_out->lists[clauselist_to_add] + && (clauses_out->lists[clauselist_to_add] + == clauses_in->lists[clauselist_to_add])) + { + gfc_omp_namelist *p = NULL; + for (n2 = clauses_in->lists[clauselist_to_add]; n2; n2 = n2->next) + { + if (p) + { + p->next = gfc_get_omp_namelist (); + p = p->next; + } + else + { + p = gfc_get_omp_namelist (); + clauses_out->lists[clauselist_to_add] = p; + } + *p = *n2; + } + } + if (!tail) + { + tail = clauses_out->lists[clauselist_to_add]; + for (; tail && tail->next; tail = tail->next) + ; + } + n2 = gfc_get_omp_namelist (); + n2->where = n->where; + n2->sym = n->sym; + if (is_target) + n2->u.map_op = OMP_MAP_TOFROM; + if (tail) + { + tail->next = n2; + tail = n2; + } + else + clauses_out->lists[clauselist_to_add] = n2; + } + } +} + +static void +gfc_free_split_omp_clauses (gfc_code *code, gfc_omp_clauses *clausesa) +{ + for (int i = 0; i < GFC_OMP_SPLIT_NUM; ++i) + for (int j = 0; j < OMP_LIST_NUM; ++j) + if (clausesa[i].lists[j] && clausesa[i].lists[j] != code->ext.omp_clauses->lists[j]) + for (gfc_omp_namelist *n = clausesa[i].lists[j]; n;) + { + gfc_omp_namelist *p = n; + n = n->next; + free (p); + } +} + static void gfc_split_omp_clauses (gfc_code *code, gfc_omp_clauses clausesa[GFC_OMP_SPLIT_NUM]) { int mask = 0, innermost = 0; + bool is_loop = false; memset (clausesa, 0, GFC_OMP_SPLIT_NUM * sizeof (gfc_omp_clauses)); switch (code->op) { @@ -5030,6 +5691,7 @@ gfc_split_omp_clauses (gfc_code *code, innermost = GFC_OMP_SPLIT_SIMD; break; case EXEC_OMP_DO: + case EXEC_OMP_LOOP: innermost = GFC_OMP_SPLIT_DO; break; case EXEC_OMP_DO_SIMD: @@ -5040,6 +5702,7 @@ gfc_split_omp_clauses (gfc_code *code, innermost = GFC_OMP_SPLIT_PARALLEL; break; case EXEC_OMP_PARALLEL_DO: + case EXEC_OMP_PARALLEL_LOOP: mask = GFC_OMP_MASK_PARALLEL | GFC_OMP_MASK_DO; innermost = GFC_OMP_SPLIT_DO; break; @@ -5047,6 +5710,28 @@ gfc_split_omp_clauses (gfc_code *code, mask = GFC_OMP_MASK_PARALLEL | GFC_OMP_MASK_DO | GFC_OMP_MASK_SIMD; innermost = GFC_OMP_SPLIT_SIMD; break; + case EXEC_OMP_PARALLEL_MASKED: + mask = GFC_OMP_MASK_PARALLEL | GFC_OMP_MASK_MASKED; + innermost = GFC_OMP_SPLIT_MASKED; + break; + case EXEC_OMP_PARALLEL_MASKED_TASKLOOP: + mask = (GFC_OMP_MASK_PARALLEL | GFC_OMP_MASK_MASKED + | GFC_OMP_MASK_TASKLOOP | GFC_OMP_MASK_SIMD); + innermost = GFC_OMP_SPLIT_TASKLOOP; + break; + case EXEC_OMP_PARALLEL_MASTER_TASKLOOP: + mask = GFC_OMP_MASK_PARALLEL | GFC_OMP_MASK_TASKLOOP | GFC_OMP_MASK_SIMD; + innermost = GFC_OMP_SPLIT_TASKLOOP; + break; + case EXEC_OMP_PARALLEL_MASKED_TASKLOOP_SIMD: + mask = (GFC_OMP_MASK_PARALLEL | GFC_OMP_MASK_MASKED + | GFC_OMP_MASK_TASKLOOP | GFC_OMP_MASK_SIMD); + innermost = GFC_OMP_SPLIT_SIMD; + break; + case EXEC_OMP_PARALLEL_MASTER_TASKLOOP_SIMD: + mask = GFC_OMP_MASK_PARALLEL | GFC_OMP_MASK_TASKLOOP | GFC_OMP_MASK_SIMD; + innermost = GFC_OMP_SPLIT_SIMD; + break; case EXEC_OMP_SIMD: innermost = GFC_OMP_SPLIT_SIMD; break; @@ -5058,6 +5743,7 @@ gfc_split_omp_clauses (gfc_code *code, innermost = GFC_OMP_SPLIT_PARALLEL; break; case EXEC_OMP_TARGET_PARALLEL_DO: + case EXEC_OMP_TARGET_PARALLEL_LOOP: mask = GFC_OMP_MASK_TARGET | GFC_OMP_MASK_PARALLEL | GFC_OMP_MASK_DO; innermost = GFC_OMP_SPLIT_DO; break; @@ -5094,9 +5780,23 @@ gfc_split_omp_clauses (gfc_code *code, | GFC_OMP_MASK_DISTRIBUTE | GFC_OMP_MASK_SIMD; innermost = GFC_OMP_SPLIT_SIMD; break; + case EXEC_OMP_TARGET_TEAMS_LOOP: + mask = GFC_OMP_MASK_TARGET | GFC_OMP_MASK_TEAMS | GFC_OMP_MASK_DO; + innermost = GFC_OMP_SPLIT_DO; + break; + case EXEC_OMP_MASKED_TASKLOOP: + mask = GFC_OMP_SPLIT_MASKED | GFC_OMP_SPLIT_TASKLOOP; + innermost = GFC_OMP_SPLIT_TASKLOOP; + break; + case EXEC_OMP_MASTER_TASKLOOP: case EXEC_OMP_TASKLOOP: innermost = GFC_OMP_SPLIT_TASKLOOP; break; + case EXEC_OMP_MASKED_TASKLOOP_SIMD: + mask = GFC_OMP_MASK_MASKED | GFC_OMP_MASK_TASKLOOP | GFC_OMP_MASK_SIMD; + innermost = GFC_OMP_SPLIT_SIMD; + break; + case EXEC_OMP_MASTER_TASKLOOP_SIMD: case EXEC_OMP_TASKLOOP_SIMD: mask = GFC_OMP_MASK_TASKLOOP | GFC_OMP_MASK_SIMD; innermost = GFC_OMP_SPLIT_SIMD; @@ -5122,6 +5822,10 @@ gfc_split_omp_clauses (gfc_code *code, mask = GFC_OMP_MASK_TEAMS | GFC_OMP_MASK_DISTRIBUTE | GFC_OMP_MASK_SIMD; innermost = GFC_OMP_SPLIT_SIMD; break; + case EXEC_OMP_TEAMS_LOOP: + mask = GFC_OMP_MASK_TEAMS | GFC_OMP_MASK_DO; + innermost = GFC_OMP_SPLIT_DO; + break; default: gcc_unreachable (); } @@ -5130,6 +5834,18 @@ gfc_split_omp_clauses (gfc_code *code, clausesa[innermost] = *code->ext.omp_clauses; return; } + /* Loops are similar to DO but still a bit different. */ + switch (code->op) + { + case EXEC_OMP_LOOP: + case EXEC_OMP_PARALLEL_LOOP: + case EXEC_OMP_TEAMS_LOOP: + case EXEC_OMP_TARGET_PARALLEL_LOOP: + case EXEC_OMP_TARGET_TEAMS_LOOP: + is_loop = true; + default: + break; + } if (code->ext.omp_clauses != NULL) { if (mask & GFC_OMP_MASK_TARGET) @@ -5141,8 +5857,9 @@ gfc_split_omp_clauses (gfc_code *code, = code->ext.omp_clauses->lists[OMP_LIST_IS_DEVICE_PTR]; clausesa[GFC_OMP_SPLIT_TARGET].device = code->ext.omp_clauses->device; - clausesa[GFC_OMP_SPLIT_TARGET].defaultmap - = code->ext.omp_clauses->defaultmap; + for (int i = 0; i < OMP_DEFAULTMAP_CAT_NUM; i++) + clausesa[GFC_OMP_SPLIT_TARGET].defaultmap[i] + = code->ext.omp_clauses->defaultmap[i]; clausesa[GFC_OMP_SPLIT_TARGET].if_exprs[OMP_IF_TARGET] = code->ext.omp_clauses->if_exprs[OMP_IF_TARGET]; /* And this is copied to all. */ @@ -5197,7 +5914,9 @@ gfc_split_omp_clauses (gfc_code *code, clausesa[GFC_OMP_SPLIT_PARALLEL].if_expr = code->ext.omp_clauses->if_expr; } - if (mask & GFC_OMP_MASK_DO) + if (mask & GFC_OMP_MASK_MASKED) + clausesa[GFC_OMP_SPLIT_MASKED].filter = code->ext.omp_clauses->filter; + if ((mask & GFC_OMP_MASK_DO) && !is_loop) { /* First the clauses that are unique to some constructs. */ clausesa[GFC_OMP_SPLIT_DO].ordered @@ -5217,6 +5936,11 @@ gfc_split_omp_clauses (gfc_code *code, = code->ext.omp_clauses->chunk_size; clausesa[GFC_OMP_SPLIT_DO].nowait = code->ext.omp_clauses->nowait; + } + if (mask & GFC_OMP_MASK_DO) + { + clausesa[GFC_OMP_SPLIT_DO].bind + = code->ext.omp_clauses->bind; /* Duplicate collapse. */ clausesa[GFC_OMP_SPLIT_DO].collapse = code->ext.omp_clauses->collapse; @@ -5249,8 +5973,12 @@ gfc_split_omp_clauses (gfc_code *code, = code->ext.omp_clauses->nogroup; clausesa[GFC_OMP_SPLIT_TASKLOOP].grainsize = code->ext.omp_clauses->grainsize; + clausesa[GFC_OMP_SPLIT_TASKLOOP].grainsize_strict + = code->ext.omp_clauses->grainsize_strict; clausesa[GFC_OMP_SPLIT_TASKLOOP].num_tasks = code->ext.omp_clauses->num_tasks; + clausesa[GFC_OMP_SPLIT_TASKLOOP].num_tasks_strict + = code->ext.omp_clauses->num_tasks_strict; clausesa[GFC_OMP_SPLIT_TASKLOOP].priority = code->ext.omp_clauses->priority; clausesa[GFC_OMP_SPLIT_TASKLOOP].final_expr @@ -5274,16 +6002,18 @@ gfc_split_omp_clauses (gfc_code *code, clausesa[GFC_OMP_SPLIT_TASKLOOP].collapse = code->ext.omp_clauses->collapse; } - /* Private clause is supported on all constructs, - it is enough to put it on the innermost one. For + /* Private clause is supported on all constructs but master/masked, + it is enough to put it on the innermost one except for master/masked. For !$ omp parallel do put it on parallel though, as that's what we did for OpenMP 3.1. */ - clausesa[innermost == GFC_OMP_SPLIT_DO + clausesa[((innermost == GFC_OMP_SPLIT_DO && !is_loop) + || code->op == EXEC_OMP_PARALLEL_MASTER + || code->op == EXEC_OMP_PARALLEL_MASKED) ? (int) GFC_OMP_SPLIT_PARALLEL : innermost].lists[OMP_LIST_PRIVATE] = code->ext.omp_clauses->lists[OMP_LIST_PRIVATE]; /* Firstprivate clause is supported on all constructs but - simd. Put it on the outermost of those and duplicate + simd and masked/master. Put it on the outermost of those and duplicate on parallel and teams. */ if (mask & GFC_OMP_MASK_TARGET) clausesa[GFC_OMP_SPLIT_TARGET].lists[OMP_LIST_FIRSTPRIVATE] @@ -5294,19 +6024,27 @@ gfc_split_omp_clauses (gfc_code *code, else if (mask & GFC_OMP_MASK_DISTRIBUTE) clausesa[GFC_OMP_SPLIT_DISTRIBUTE].lists[OMP_LIST_FIRSTPRIVATE] = code->ext.omp_clauses->lists[OMP_LIST_FIRSTPRIVATE]; - if (mask & GFC_OMP_MASK_PARALLEL) + if (mask & GFC_OMP_MASK_TASKLOOP) + clausesa[GFC_OMP_SPLIT_TASKLOOP].lists[OMP_LIST_FIRSTPRIVATE] + = code->ext.omp_clauses->lists[OMP_LIST_FIRSTPRIVATE]; + if ((mask & GFC_OMP_MASK_PARALLEL) + && !(mask & GFC_OMP_MASK_TASKLOOP)) clausesa[GFC_OMP_SPLIT_PARALLEL].lists[OMP_LIST_FIRSTPRIVATE] = code->ext.omp_clauses->lists[OMP_LIST_FIRSTPRIVATE]; - else if (mask & GFC_OMP_MASK_DO) + else if ((mask & GFC_OMP_MASK_DO) && !is_loop) clausesa[GFC_OMP_SPLIT_DO].lists[OMP_LIST_FIRSTPRIVATE] = code->ext.omp_clauses->lists[OMP_LIST_FIRSTPRIVATE]; - /* Lastprivate is allowed on distribute, do and simd. + /* Lastprivate is allowed on distribute, do, simd, taskloop and loop. In parallel do{, simd} we actually want to put it on parallel rather than do. */ if (mask & GFC_OMP_MASK_DISTRIBUTE) clausesa[GFC_OMP_SPLIT_DISTRIBUTE].lists[OMP_LIST_LASTPRIVATE] = code->ext.omp_clauses->lists[OMP_LIST_LASTPRIVATE]; - if (mask & GFC_OMP_MASK_PARALLEL) + if (mask & GFC_OMP_MASK_TASKLOOP) + clausesa[GFC_OMP_SPLIT_TASKLOOP].lists[OMP_LIST_LASTPRIVATE] + = code->ext.omp_clauses->lists[OMP_LIST_LASTPRIVATE]; + if ((mask & GFC_OMP_MASK_PARALLEL) && !is_loop + && !(mask & GFC_OMP_MASK_TASKLOOP)) clausesa[GFC_OMP_SPLIT_PARALLEL].lists[OMP_LIST_LASTPRIVATE] = code->ext.omp_clauses->lists[OMP_LIST_LASTPRIVATE]; else if (mask & GFC_OMP_MASK_DO) @@ -5315,17 +6053,26 @@ gfc_split_omp_clauses (gfc_code *code, if (mask & GFC_OMP_MASK_SIMD) clausesa[GFC_OMP_SPLIT_SIMD].lists[OMP_LIST_LASTPRIVATE] = code->ext.omp_clauses->lists[OMP_LIST_LASTPRIVATE]; - /* Reduction is allowed on simd, do, parallel and teams. - Duplicate it on all of them, but omit on do if - parallel is present; additionally, inscan applies to do/simd only. */ + /* Reduction is allowed on simd, do, parallel, teams, taskloop, and loop. + Duplicate it on all of them, but + - omit on do if parallel is present; + - omit on task and parallel if loop is present; + additionally, inscan applies to do/simd only. */ for (int i = OMP_LIST_REDUCTION; i <= OMP_LIST_REDUCTION_TASK; i++) { - if (mask & GFC_OMP_MASK_TEAMS + if (mask & GFC_OMP_MASK_TASKLOOP && i != OMP_LIST_REDUCTION_INSCAN) + clausesa[GFC_OMP_SPLIT_TASKLOOP].lists[i] + = code->ext.omp_clauses->lists[i]; + if (mask & GFC_OMP_MASK_TEAMS + && i != OMP_LIST_REDUCTION_INSCAN + && !is_loop) clausesa[GFC_OMP_SPLIT_TEAMS].lists[i] = code->ext.omp_clauses->lists[i]; if (mask & GFC_OMP_MASK_PARALLEL - && i != OMP_LIST_REDUCTION_INSCAN) + && i != OMP_LIST_REDUCTION_INSCAN + && !(mask & GFC_OMP_MASK_TASKLOOP) + && !is_loop) clausesa[GFC_OMP_SPLIT_PARALLEL].lists[i] = code->ext.omp_clauses->lists[i]; else if (mask & GFC_OMP_MASK_DO) @@ -5346,8 +6093,21 @@ gfc_split_omp_clauses (gfc_code *code, clausesa[innermost].lists[OMP_LIST_LINEAR] = code->ext.omp_clauses->lists[OMP_LIST_LINEAR]; } - if ((mask & (GFC_OMP_MASK_PARALLEL | GFC_OMP_MASK_DO)) - == (GFC_OMP_MASK_PARALLEL | GFC_OMP_MASK_DO)) + /* Propagate firstprivate/lastprivate/reduction vars to + shared (parallel, teams) and map-tofrom (target). */ + if (mask & GFC_OMP_MASK_TARGET) + gfc_add_clause_implicitly (&clausesa[GFC_OMP_SPLIT_TARGET], + code->ext.omp_clauses, true, false); + if ((mask & GFC_OMP_MASK_PARALLEL) && innermost != GFC_OMP_MASK_PARALLEL) + gfc_add_clause_implicitly (&clausesa[GFC_OMP_SPLIT_PARALLEL], + code->ext.omp_clauses, false, + mask & GFC_OMP_MASK_DO); + if (mask & GFC_OMP_MASK_TEAMS && innermost != GFC_OMP_MASK_TEAMS) + gfc_add_clause_implicitly (&clausesa[GFC_OMP_SPLIT_TEAMS], + code->ext.omp_clauses, false, false); + if (((mask & (GFC_OMP_MASK_PARALLEL | GFC_OMP_MASK_DO)) + == (GFC_OMP_MASK_PARALLEL | GFC_OMP_MASK_DO)) + && !is_loop) clausesa[GFC_OMP_SPLIT_DO].nowait = true; } @@ -5358,6 +6118,7 @@ gfc_trans_omp_do_simd (gfc_code *code, stmtblock_t *pblock, stmtblock_t block; gfc_omp_clauses clausesa_buf[GFC_OMP_SPLIT_NUM]; tree stmt, body, omp_do_clauses = NULL_TREE; + bool free_clausesa = false; if (pblock == NULL) gfc_start_block (&block); @@ -5368,6 +6129,7 @@ gfc_trans_omp_do_simd (gfc_code *code, stmtblock_t *pblock, { clausesa = clausesa_buf; gfc_split_omp_clauses (code, clausesa); + free_clausesa = true; } if (flag_openmp) omp_do_clauses @@ -5393,16 +6155,19 @@ gfc_trans_omp_do_simd (gfc_code *code, stmtblock_t *pblock, else stmt = body; gfc_add_expr_to_block (&block, stmt); + if (free_clausesa) + gfc_free_split_omp_clauses (code, clausesa); return gfc_finish_block (&block); } static tree -gfc_trans_omp_parallel_do (gfc_code *code, stmtblock_t *pblock, +gfc_trans_omp_parallel_do (gfc_code *code, bool is_loop, stmtblock_t *pblock, gfc_omp_clauses *clausesa) { stmtblock_t block, *new_pblock = pblock; gfc_omp_clauses clausesa_buf[GFC_OMP_SPLIT_NUM]; tree stmt, omp_clauses = NULL_TREE; + bool free_clausesa = false; if (pblock == NULL) gfc_start_block (&block); @@ -5413,6 +6178,7 @@ gfc_trans_omp_parallel_do (gfc_code *code, stmtblock_t *pblock, { clausesa = clausesa_buf; gfc_split_omp_clauses (code, clausesa); + free_clausesa = true; } omp_clauses = gfc_trans_omp_clauses (&block, &clausesa[GFC_OMP_SPLIT_PARALLEL], @@ -5425,8 +6191,9 @@ gfc_trans_omp_parallel_do (gfc_code *code, stmtblock_t *pblock, else pushlevel (); } - stmt = gfc_trans_omp_do (code, EXEC_OMP_DO, new_pblock, - &clausesa[GFC_OMP_SPLIT_DO], omp_clauses); + stmt = gfc_trans_omp_do (code, is_loop ? EXEC_OMP_LOOP : EXEC_OMP_DO, + new_pblock, &clausesa[GFC_OMP_SPLIT_DO], + omp_clauses); if (pblock == NULL) { if (TREE_CODE (stmt) != BIND_EXPR) @@ -5440,6 +6207,8 @@ gfc_trans_omp_parallel_do (gfc_code *code, stmtblock_t *pblock, void_type_node, stmt, omp_clauses); OMP_PARALLEL_COMBINED (stmt) = 1; gfc_add_expr_to_block (&block, stmt); + if (free_clausesa) + gfc_free_split_omp_clauses (code, clausesa); return gfc_finish_block (&block); } @@ -5450,6 +6219,7 @@ gfc_trans_omp_parallel_do_simd (gfc_code *code, stmtblock_t *pblock, stmtblock_t block; gfc_omp_clauses clausesa_buf[GFC_OMP_SPLIT_NUM]; tree stmt, omp_clauses = NULL_TREE; + bool free_clausesa = false; if (pblock == NULL) gfc_start_block (&block); @@ -5460,6 +6230,7 @@ gfc_trans_omp_parallel_do_simd (gfc_code *code, stmtblock_t *pblock, { clausesa = clausesa_buf; gfc_split_omp_clauses (code, clausesa); + free_clausesa = true; } if (flag_openmp) omp_clauses @@ -5484,6 +6255,8 @@ gfc_trans_omp_parallel_do_simd (gfc_code *code, stmtblock_t *pblock, OMP_PARALLEL_COMBINED (stmt) = 1; } gfc_add_expr_to_block (&block, stmt); + if (free_clausesa) + gfc_free_split_omp_clauses (code, clausesa); return gfc_finish_block (&block); } @@ -5537,6 +6310,24 @@ gfc_trans_omp_parallel_workshare (gfc_code *code) } static tree +gfc_trans_omp_scope (gfc_code *code) +{ + stmtblock_t block; + tree body = gfc_trans_code (code->block->next); + if (IS_EMPTY_STMT (body)) + return body; + gfc_start_block (&block); + tree omp_clauses = gfc_trans_omp_clauses (&block, code->ext.omp_clauses, + code->loc); + tree stmt = make_node (OMP_SCOPE); + TREE_TYPE (stmt) = void_type_node; + OMP_SCOPE_BODY (stmt) = body; + OMP_SCOPE_CLAUSES (stmt) = omp_clauses; + gfc_add_expr_to_block (&block, stmt); + return gfc_finish_block (&block); +} + +static tree gfc_trans_omp_sections (gfc_code *code, gfc_omp_clauses *clauses) { stmtblock_t block, body; @@ -5609,10 +6400,23 @@ gfc_trans_omp_taskgroup (gfc_code *code) } static tree -gfc_trans_omp_taskwait (void) +gfc_trans_omp_taskwait (gfc_code *code) { - tree decl = builtin_decl_explicit (BUILT_IN_GOMP_TASKWAIT); - return build_call_expr_loc (input_location, decl, 0); + if (!code->ext.omp_clauses) + { + tree decl = builtin_decl_explicit (BUILT_IN_GOMP_TASKWAIT); + return build_call_expr_loc (input_location, decl, 0); + } + stmtblock_t block; + gfc_start_block (&block); + tree stmt = make_node (OMP_TASK); + TREE_TYPE (stmt) = void_type_node; + OMP_TASK_BODY (stmt) = NULL_TREE; + OMP_TASK_CLAUSES (stmt) = gfc_trans_omp_clauses (&block, + code->ext.omp_clauses, + code->loc); + gfc_add_expr_to_block (&block, stmt); + return gfc_finish_block (&block); } static tree @@ -5628,12 +6432,14 @@ gfc_trans_omp_distribute (gfc_code *code, gfc_omp_clauses *clausesa) stmtblock_t block; gfc_omp_clauses clausesa_buf[GFC_OMP_SPLIT_NUM]; tree stmt, omp_clauses = NULL_TREE; + bool free_clausesa = false; gfc_start_block (&block); if (clausesa == NULL) { clausesa = clausesa_buf; gfc_split_omp_clauses (code, clausesa); + free_clausesa = true; } if (flag_openmp) omp_clauses @@ -5650,7 +6456,7 @@ gfc_trans_omp_distribute (gfc_code *code, gfc_omp_clauses *clausesa) case EXEC_OMP_DISTRIBUTE_PARALLEL_DO: case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO: case EXEC_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO: - stmt = gfc_trans_omp_parallel_do (code, &block, clausesa); + stmt = gfc_trans_omp_parallel_do (code, false, &block, clausesa); if (TREE_CODE (stmt) != BIND_EXPR) stmt = build3_v (BIND_EXPR, NULL, stmt, poplevel (1, 0)); else @@ -5687,6 +6493,8 @@ gfc_trans_omp_distribute (gfc_code *code, gfc_omp_clauses *clausesa) stmt = distribute; } gfc_add_expr_to_block (&block, stmt); + if (free_clausesa) + gfc_free_split_omp_clauses (code, clausesa); return gfc_finish_block (&block); } @@ -5697,13 +6505,14 @@ gfc_trans_omp_teams (gfc_code *code, gfc_omp_clauses *clausesa, stmtblock_t block; gfc_omp_clauses clausesa_buf[GFC_OMP_SPLIT_NUM]; tree stmt; - bool combined = true; + bool combined = true, free_clausesa = false; gfc_start_block (&block); if (clausesa == NULL) { clausesa = clausesa_buf; gfc_split_omp_clauses (code, clausesa); + free_clausesa = true; } if (flag_openmp) { @@ -5727,6 +6536,12 @@ gfc_trans_omp_teams (gfc_code *code, gfc_omp_clauses *clausesa, &clausesa[GFC_OMP_SPLIT_DISTRIBUTE], NULL); break; + case EXEC_OMP_TARGET_TEAMS_LOOP: + case EXEC_OMP_TEAMS_LOOP: + stmt = gfc_trans_omp_do (code, EXEC_OMP_LOOP, NULL, + &clausesa[GFC_OMP_SPLIT_DO], + NULL); + break; default: stmt = gfc_trans_omp_distribute (code, clausesa); break; @@ -5740,6 +6555,8 @@ gfc_trans_omp_teams (gfc_code *code, gfc_omp_clauses *clausesa, OMP_TEAMS_COMBINED (stmt) = 1; } gfc_add_expr_to_block (&block, stmt); + if (free_clausesa) + gfc_free_split_omp_clauses (code, clausesa); return gfc_finish_block (&block); } @@ -5784,7 +6601,11 @@ gfc_trans_omp_target (gfc_code *code) } break; case EXEC_OMP_TARGET_PARALLEL_DO: - stmt = gfc_trans_omp_parallel_do (code, &block, clausesa); + case EXEC_OMP_TARGET_PARALLEL_LOOP: + stmt = gfc_trans_omp_parallel_do (code, + (code->op + == EXEC_OMP_TARGET_PARALLEL_LOOP), + &block, clausesa); if (TREE_CODE (stmt) != BIND_EXPR) stmt = build3_v (BIND_EXPR, NULL, stmt, poplevel (1, 0)); else @@ -5845,11 +6666,12 @@ gfc_trans_omp_target (gfc_code *code) cfun->has_omp_target = true; } gfc_add_expr_to_block (&block, stmt); + gfc_free_split_omp_clauses (code, clausesa); return gfc_finish_block (&block); } static tree -gfc_trans_omp_taskloop (gfc_code *code) +gfc_trans_omp_taskloop (gfc_code *code, gfc_exec_op op) { stmtblock_t block; gfc_omp_clauses clausesa[GFC_OMP_SPLIT_NUM]; @@ -5861,7 +6683,7 @@ gfc_trans_omp_taskloop (gfc_code *code) omp_clauses = gfc_trans_omp_clauses (&block, &clausesa[GFC_OMP_SPLIT_TASKLOOP], code->loc); - switch (code->op) + switch (op) { case EXEC_OMP_TASKLOOP: /* This is handled in gfc_trans_omp_do. */ @@ -5887,6 +6709,128 @@ gfc_trans_omp_taskloop (gfc_code *code) stmt = taskloop; } gfc_add_expr_to_block (&block, stmt); + gfc_free_split_omp_clauses (code, clausesa); + return gfc_finish_block (&block); +} + +static tree +gfc_trans_omp_master_masked_taskloop (gfc_code *code, gfc_exec_op op) +{ + gfc_omp_clauses clausesa[GFC_OMP_SPLIT_NUM]; + stmtblock_t block; + tree stmt; + + if (op != EXEC_OMP_MASTER_TASKLOOP_SIMD + && code->op != EXEC_OMP_MASTER_TASKLOOP) + gfc_split_omp_clauses (code, clausesa); + + pushlevel (); + if (op == EXEC_OMP_MASKED_TASKLOOP_SIMD + || op == EXEC_OMP_MASTER_TASKLOOP_SIMD) + stmt = gfc_trans_omp_taskloop (code, EXEC_OMP_TASKLOOP_SIMD); + else + { + gcc_assert (op == EXEC_OMP_MASKED_TASKLOOP + || op == EXEC_OMP_MASTER_TASKLOOP); + stmt = gfc_trans_omp_do (code, EXEC_OMP_TASKLOOP, NULL, + code->op != EXEC_OMP_MASTER_TASKLOOP + ? &clausesa[GFC_OMP_SPLIT_TASKLOOP] + : code->ext.omp_clauses, NULL); + } + if (TREE_CODE (stmt) != BIND_EXPR) + stmt = build3_v (BIND_EXPR, NULL, stmt, poplevel (1, 0)); + else + poplevel (0, 0); + gfc_start_block (&block); + if (op == EXEC_OMP_MASKED_TASKLOOP || op == EXEC_OMP_MASKED_TASKLOOP_SIMD) + { + tree clauses = gfc_trans_omp_clauses (&block, + &clausesa[GFC_OMP_SPLIT_MASKED], + code->loc); + tree msk = make_node (OMP_MASKED); + TREE_TYPE (msk) = void_type_node; + OMP_MASKED_BODY (msk) = stmt; + OMP_MASKED_CLAUSES (msk) = clauses; + OMP_MASKED_COMBINED (msk) = 1; + gfc_add_expr_to_block (&block, msk); + } + else + { + gcc_assert (op == EXEC_OMP_MASTER_TASKLOOP + || op == EXEC_OMP_MASTER_TASKLOOP_SIMD); + stmt = build1_v (OMP_MASTER, stmt); + gfc_add_expr_to_block (&block, stmt); + } + if (op != EXEC_OMP_MASTER_TASKLOOP_SIMD + && code->op != EXEC_OMP_MASTER_TASKLOOP) + gfc_free_split_omp_clauses (code, clausesa); + return gfc_finish_block (&block); +} + +static tree +gfc_trans_omp_parallel_master_masked (gfc_code *code) +{ + stmtblock_t block; + tree stmt, omp_clauses; + gfc_omp_clauses clausesa[GFC_OMP_SPLIT_NUM]; + bool parallel_combined = false; + + if (code->op != EXEC_OMP_PARALLEL_MASTER) + gfc_split_omp_clauses (code, clausesa); + + gfc_start_block (&block); + omp_clauses = gfc_trans_omp_clauses (&block, + code->op == EXEC_OMP_PARALLEL_MASTER + ? code->ext.omp_clauses + : &clausesa[GFC_OMP_SPLIT_PARALLEL], + code->loc); + pushlevel (); + if (code->op == EXEC_OMP_PARALLEL_MASTER) + stmt = gfc_trans_omp_master (code); + else if (code->op == EXEC_OMP_PARALLEL_MASKED) + stmt = gfc_trans_omp_masked (code, &clausesa[GFC_OMP_SPLIT_MASKED]); + else + { + gfc_exec_op op; + switch (code->op) + { + case EXEC_OMP_PARALLEL_MASKED_TASKLOOP: + op = EXEC_OMP_MASKED_TASKLOOP; + break; + case EXEC_OMP_PARALLEL_MASKED_TASKLOOP_SIMD: + op = EXEC_OMP_MASKED_TASKLOOP_SIMD; + break; + case EXEC_OMP_PARALLEL_MASTER_TASKLOOP: + op = EXEC_OMP_MASTER_TASKLOOP; + break; + case EXEC_OMP_PARALLEL_MASTER_TASKLOOP_SIMD: + op = EXEC_OMP_MASTER_TASKLOOP_SIMD; + break; + default: + gcc_unreachable (); + } + stmt = gfc_trans_omp_master_masked_taskloop (code, op); + parallel_combined = true; + } + if (TREE_CODE (stmt) != BIND_EXPR) + stmt = build3_v (BIND_EXPR, NULL, stmt, poplevel (1, 0)); + else + poplevel (0, 0); + stmt = build2_loc (gfc_get_location (&code->loc), OMP_PARALLEL, + void_type_node, stmt, omp_clauses); + /* masked does have just filter clause, but during gimplification + isn't represented by a gimplification omp context, so for + !$omp parallel masked don't set OMP_PARALLEL_COMBINED, + so that + !$omp parallel masked + !$omp taskloop simd lastprivate (x) + isn't confused with + !$omp parallel masked taskloop simd lastprivate (x) */ + if (parallel_combined) + OMP_PARALLEL_COMBINED (stmt) = 1; + gfc_add_expr_to_block (&block, stmt); + if (code->op != EXEC_OMP_PARALLEL_MASTER) + gfc_free_split_omp_clauses (code, clausesa); return gfc_finish_block (&block); } @@ -6026,6 +6970,7 @@ gfc_trans_omp_workshare (gfc_code *code, gfc_omp_clauses *clauses) case EXEC_OMP_PARALLEL: case EXEC_OMP_PARALLEL_DO: + case EXEC_OMP_PARALLEL_MASTER: case EXEC_OMP_PARALLEL_SECTIONS: case EXEC_OMP_PARALLEL_WORKSHARE: case EXEC_OMP_CRITICAL: @@ -6181,8 +7126,11 @@ gfc_trans_omp_directive (gfc_code *code) return gfc_trans_omp_cancellation_point (code); case EXEC_OMP_CRITICAL: return gfc_trans_omp_critical (code); + case EXEC_OMP_DEPOBJ: + return gfc_trans_omp_depobj (code); case EXEC_OMP_DISTRIBUTE: case EXEC_OMP_DO: + case EXEC_OMP_LOOP: case EXEC_OMP_SIMD: case EXEC_OMP_TASKLOOP: return gfc_trans_omp_do (code, code->op, NULL, code->ext.omp_clauses, @@ -6193,22 +7141,42 @@ gfc_trans_omp_directive (gfc_code *code) return gfc_trans_omp_distribute (code, NULL); case EXEC_OMP_DO_SIMD: return gfc_trans_omp_do_simd (code, NULL, NULL, NULL_TREE); + case EXEC_OMP_ERROR: + return gfc_trans_omp_error (code); case EXEC_OMP_FLUSH: return gfc_trans_omp_flush (code); + case EXEC_OMP_MASKED: + return gfc_trans_omp_masked (code, NULL); case EXEC_OMP_MASTER: return gfc_trans_omp_master (code); + case EXEC_OMP_MASKED_TASKLOOP: + case EXEC_OMP_MASKED_TASKLOOP_SIMD: + case EXEC_OMP_MASTER_TASKLOOP: + case EXEC_OMP_MASTER_TASKLOOP_SIMD: + return gfc_trans_omp_master_masked_taskloop (code, code->op); case EXEC_OMP_ORDERED: return gfc_trans_omp_ordered (code); case EXEC_OMP_PARALLEL: return gfc_trans_omp_parallel (code); case EXEC_OMP_PARALLEL_DO: - return gfc_trans_omp_parallel_do (code, NULL, NULL); + return gfc_trans_omp_parallel_do (code, false, NULL, NULL); + case EXEC_OMP_PARALLEL_LOOP: + return gfc_trans_omp_parallel_do (code, true, NULL, NULL); case EXEC_OMP_PARALLEL_DO_SIMD: return gfc_trans_omp_parallel_do_simd (code, NULL, NULL); + case EXEC_OMP_PARALLEL_MASKED: + case EXEC_OMP_PARALLEL_MASKED_TASKLOOP: + case EXEC_OMP_PARALLEL_MASKED_TASKLOOP_SIMD: + case EXEC_OMP_PARALLEL_MASTER: + case EXEC_OMP_PARALLEL_MASTER_TASKLOOP: + case EXEC_OMP_PARALLEL_MASTER_TASKLOOP_SIMD: + return gfc_trans_omp_parallel_master_masked (code); case EXEC_OMP_PARALLEL_SECTIONS: return gfc_trans_omp_parallel_sections (code); case EXEC_OMP_PARALLEL_WORKSHARE: return gfc_trans_omp_parallel_workshare (code); + case EXEC_OMP_SCOPE: + return gfc_trans_omp_scope (code); case EXEC_OMP_SECTIONS: return gfc_trans_omp_sections (code, code->ext.omp_clauses); case EXEC_OMP_SINGLE: @@ -6217,12 +7185,14 @@ gfc_trans_omp_directive (gfc_code *code) case EXEC_OMP_TARGET_PARALLEL: case EXEC_OMP_TARGET_PARALLEL_DO: case EXEC_OMP_TARGET_PARALLEL_DO_SIMD: + case EXEC_OMP_TARGET_PARALLEL_LOOP: case EXEC_OMP_TARGET_SIMD: case EXEC_OMP_TARGET_TEAMS: case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE: case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO: case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD: case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_SIMD: + case EXEC_OMP_TARGET_TEAMS_LOOP: return gfc_trans_omp_target (code); case EXEC_OMP_TARGET_DATA: return gfc_trans_omp_target_data (code); @@ -6237,9 +7207,9 @@ gfc_trans_omp_directive (gfc_code *code) case EXEC_OMP_TASKGROUP: return gfc_trans_omp_taskgroup (code); case EXEC_OMP_TASKLOOP_SIMD: - return gfc_trans_omp_taskloop (code); + return gfc_trans_omp_taskloop (code, code->op); case EXEC_OMP_TASKWAIT: - return gfc_trans_omp_taskwait (); + return gfc_trans_omp_taskwait (code); case EXEC_OMP_TASKYIELD: return gfc_trans_omp_taskyield (); case EXEC_OMP_TEAMS: @@ -6247,6 +7217,7 @@ gfc_trans_omp_directive (gfc_code *code) case EXEC_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO: case EXEC_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD: case EXEC_OMP_TEAMS_DISTRIBUTE_SIMD: + case EXEC_OMP_TEAMS_LOOP: return gfc_trans_omp_teams (code, NULL, NULL_TREE); case EXEC_OMP_WORKSHARE: return gfc_trans_omp_workshare (code, code->ext.omp_clauses); diff --git a/gcc/fortran/trans-stmt.c b/gcc/fortran/trans-stmt.c index 7cbdef7..11df186 100644 --- a/gcc/fortran/trans-stmt.c +++ b/gcc/fortran/trans-stmt.c @@ -1226,7 +1226,8 @@ gfc_trans_sync (gfc_code *code, gfc_exec_op type) if (code->expr2) { - gcc_assert (code->expr2->expr_type == EXPR_VARIABLE); + gcc_assert (code->expr2->expr_type == EXPR_VARIABLE + || code->expr2->expr_type == EXPR_FUNCTION); gfc_init_se (&argse, NULL); gfc_conv_expr_val (&argse, code->expr2); stat = argse.expr; @@ -1236,7 +1237,8 @@ gfc_trans_sync (gfc_code *code, gfc_exec_op type) if (code->expr3 && flag_coarray == GFC_FCOARRAY_LIB) { - gcc_assert (code->expr3->expr_type == EXPR_VARIABLE); + gcc_assert (code->expr3->expr_type == EXPR_VARIABLE + || code->expr3->expr_type == EXPR_FUNCTION); gfc_init_se (&argse, NULL); argse.want_pointer = 1; gfc_conv_expr (&argse, code->expr3); diff --git a/gcc/fortran/trans-types.c b/gcc/fortran/trans-types.c index ccdc468..1c78a90 100644 --- a/gcc/fortran/trans-types.c +++ b/gcc/fortran/trans-types.c @@ -150,23 +150,23 @@ tree get_dtype_type_node (void) field = gfc_add_field_to_struct_1 (dtype_node, get_identifier ("elem_len"), size_type_node, &dtype_chain); - TREE_NO_WARNING (field) = 1; + suppress_warning (field); field = gfc_add_field_to_struct_1 (dtype_node, get_identifier ("version"), integer_type_node, &dtype_chain); - TREE_NO_WARNING (field) = 1; + suppress_warning (field); field = gfc_add_field_to_struct_1 (dtype_node, get_identifier ("rank"), signed_char_type_node, &dtype_chain); - TREE_NO_WARNING (field) = 1; + suppress_warning (field); field = gfc_add_field_to_struct_1 (dtype_node, get_identifier ("type"), signed_char_type_node, &dtype_chain); - TREE_NO_WARNING (field) = 1; + suppress_warning (field); field = gfc_add_field_to_struct_1 (dtype_node, get_identifier ("attribute"), short_integer_type_node, &dtype_chain); - TREE_NO_WARNING (field) = 1; + suppress_warning (field); gfc_finish_type (dtype_node); TYPE_DECL_SUPPRESS_DEBUG (TYPE_STUB_DECL (dtype_node)) = 1; dtype_type_node = dtype_node; @@ -446,7 +446,7 @@ gfc_init_kinds (void) if (!targetm.scalar_mode_supported_p (mode)) continue; - /* Only let float, double, long double and __float128 go through. + /* Only let float, double, long double and TFmode go through. Runtime support for others is not provided, so they would be useless. */ if (!targetm.libgcc_floating_mode_supported_p (mode)) @@ -471,7 +471,14 @@ gfc_init_kinds (void) We round up so as to handle IA-64 __floatreg (RFmode), which is an 82 bit type. Not to be confused with __float80 (XFmode), which is an 80 bit type also supported by IA-64. So XFmode should come out - to be kind=10, and RFmode should come out to be kind=11. Egads. */ + to be kind=10, and RFmode should come out to be kind=11. Egads. + + TODO: The kind calculation has to be modified to support all + three 128-bit floating-point modes on PowerPC as IFmode, KFmode, + and TFmode since the following line would all map to kind=16. + However, currently only float, double, long double, and TFmode + reach this code. + */ kind = (GET_MODE_PRECISION (mode) + 7) / 8; @@ -851,6 +858,7 @@ gfc_build_real_type (gfc_real_info *info) info->c_long_double = 1; if (mode_precision != LONG_DOUBLE_TYPE_SIZE && mode_precision == 128) { + /* TODO: see PR101835. */ info->c_float128 = 1; gfc_real16_is_float128 = true; } @@ -1453,17 +1461,17 @@ gfc_get_desc_dim_type (void) decl = gfc_add_field_to_struct_1 (type, get_identifier ("stride"), gfc_array_index_type, &chain); - TREE_NO_WARNING (decl) = 1; + suppress_warning (decl); decl = gfc_add_field_to_struct_1 (type, get_identifier ("lbound"), gfc_array_index_type, &chain); - TREE_NO_WARNING (decl) = 1; + suppress_warning (decl); decl = gfc_add_field_to_struct_1 (type, get_identifier ("ubound"), gfc_array_index_type, &chain); - TREE_NO_WARNING (decl) = 1; + suppress_warning (decl); /* Finish off the type. */ gfc_finish_type (type); @@ -1482,6 +1490,7 @@ gfc_get_desc_dim_type (void) tree gfc_get_dtype_rank_type (int rank, tree etype) { + tree ptype; tree size; int n; tree tmp; @@ -1489,12 +1498,24 @@ gfc_get_dtype_rank_type (int rank, tree etype) tree field; vec<constructor_elt, va_gc> *v = NULL; - size = TYPE_SIZE_UNIT (etype); + ptype = etype; + while (TREE_CODE (etype) == POINTER_TYPE + || TREE_CODE (etype) == ARRAY_TYPE) + { + ptype = etype; + etype = TREE_TYPE (etype); + } + + gcc_assert (etype); switch (TREE_CODE (etype)) { case INTEGER_TYPE: - n = BT_INTEGER; + if (TREE_CODE (ptype) == ARRAY_TYPE + && TYPE_STRING_FLAG (ptype)) + n = BT_CHARACTER; + else + n = BT_INTEGER; break; case BOOLEAN_TYPE: @@ -1516,27 +1537,36 @@ gfc_get_dtype_rank_type (int rank, tree etype) n = BT_DERIVED; break; - /* We will never have arrays of arrays. */ - case ARRAY_TYPE: - n = BT_CHARACTER; - if (size == NULL_TREE) - size = TYPE_SIZE_UNIT (TREE_TYPE (etype)); + case FUNCTION_TYPE: + case VOID_TYPE: + n = BT_VOID; break; - case POINTER_TYPE: - n = BT_ASSUMED; - if (TREE_CODE (TREE_TYPE (etype)) != VOID_TYPE) - size = TYPE_SIZE_UNIT (TREE_TYPE (etype)); - else - size = build_int_cst (size_type_node, 0); - break; - default: /* TODO: Don't do dtype for temporary descriptorless arrays. */ /* We can encounter strange array types for temporary arrays. */ - return gfc_index_zero_node; + gcc_unreachable (); + } + + switch (n) + { + case BT_CHARACTER: + gcc_assert (TREE_CODE (ptype) == ARRAY_TYPE); + size = gfc_get_character_len_in_bytes (ptype); + break; + case BT_VOID: + gcc_assert (TREE_CODE (ptype) == POINTER_TYPE); + size = size_in_bytes (ptype); + break; + default: + size = size_in_bytes (etype); + break; } + + gcc_assert (size); + STRIP_NOPS (size); + size = fold_convert (size_type_node, size); tmp = get_dtype_type_node (); field = gfc_advance_chain (TYPE_FIELDS (tmp), GFC_DTYPE_ELEM_LEN); @@ -1560,17 +1590,17 @@ gfc_get_dtype_rank_type (int rank, tree etype) tree -gfc_get_dtype (tree type) +gfc_get_dtype (tree type, int * rank) { tree dtype; tree etype; - int rank; + int irnk; gcc_assert (GFC_DESCRIPTOR_TYPE_P (type) || GFC_ARRAY_TYPE_P (type)); - rank = GFC_TYPE_ARRAY_RANK (type); + irnk = (rank) ? (*rank) : (GFC_TYPE_ARRAY_RANK (type)); etype = gfc_get_element_type (type); - dtype = gfc_get_dtype_rank_type (rank, etype); + dtype = gfc_get_dtype_rank_type (irnk, etype); GFC_TYPE_ARRAY_DTYPE (type) = dtype; return dtype; @@ -1622,7 +1652,7 @@ gfc_get_nodesc_array_type (tree etype, gfc_array_spec * as, gfc_packed packed, GFC_TYPE_ARRAY_STRIDE (type, n) = tmp; expr = as->lower[n]; - if (expr->expr_type == EXPR_CONSTANT) + if (expr && expr->expr_type == EXPR_CONSTANT) { tmp = gfc_conv_mpz_to_tree (expr->value.integer, gfc_index_integer_kind); @@ -1672,7 +1702,7 @@ gfc_get_nodesc_array_type (tree etype, gfc_array_spec * as, gfc_packed packed, for (n = as->rank; n < as->rank + as->corank; n++) { expr = as->lower[n]; - if (expr->expr_type == EXPR_CONSTANT) + if (expr && expr->expr_type == EXPR_CONSTANT) tmp = gfc_conv_mpz_to_tree (expr->value.integer, gfc_index_integer_kind); else @@ -1831,19 +1861,19 @@ gfc_get_array_descriptor_base (int dimen, int codimen, bool restricted) decl = gfc_add_field_to_struct_1 (fat_type, get_identifier ("offset"), gfc_array_index_type, &chain); - TREE_NO_WARNING (decl) = 1; + suppress_warning (decl); /* Add the dtype component. */ decl = gfc_add_field_to_struct_1 (fat_type, get_identifier ("dtype"), get_dtype_type_node (), &chain); - TREE_NO_WARNING (decl) = 1; + suppress_warning (decl); /* Add the span component. */ decl = gfc_add_field_to_struct_1 (fat_type, get_identifier ("span"), gfc_array_index_type, &chain); - TREE_NO_WARNING (decl) = 1; + suppress_warning (decl); /* Build the array type for the stride and bound components. */ if (dimen + codimen > 0) @@ -1856,7 +1886,7 @@ gfc_get_array_descriptor_base (int dimen, int codimen, bool restricted) decl = gfc_add_field_to_struct_1 (fat_type, get_identifier ("dim"), arraytype, &chain); - TREE_NO_WARNING (decl) = 1; + suppress_warning (decl); } if (flag_coarray == GFC_FCOARRAY_LIB) @@ -1864,7 +1894,7 @@ gfc_get_array_descriptor_base (int dimen, int codimen, bool restricted) decl = gfc_add_field_to_struct_1 (fat_type, get_identifier ("token"), prvoid_type_node, &chain); - TREE_NO_WARNING (decl) = 1; + suppress_warning (decl); } /* Finish off the type. */ @@ -1912,7 +1942,11 @@ gfc_get_array_type_bounds (tree etype, int dimen, int codimen, tree * lbound, TYPE_TYPELESS_STORAGE (fat_type) = 1; gcc_checking_assert (!get_alias_set (base_type) && !get_alias_set (fat_type)); - tmp = TYPE_NAME (etype); + tmp = etype; + if (TREE_CODE (tmp) == ARRAY_TYPE + && TYPE_STRING_FLAG (tmp)) + tmp = TREE_TYPE (etype); + tmp = TYPE_NAME (tmp); if (tmp && TREE_CODE (tmp) == TYPE_DECL) tmp = DECL_NAME (tmp); if (tmp) @@ -2856,7 +2890,7 @@ copy_derived_types: token = gfc_find_component (derived, caf_name, true, true, NULL); gcc_assert (token); c->caf_token = token->backend_decl; - TREE_NO_WARNING (c->caf_token) = 1; + suppress_warning (c->caf_token); } } @@ -3011,6 +3045,10 @@ create_fn_spec (gfc_symbol *sym, tree fntype) return build_type_attribute_variant (fntype, tmp); } + +/* NOTE: The returned function type must match the argument list created by + create_function_arglist. */ + tree gfc_get_function_type (gfc_symbol * sym, gfc_actual_arglist *actual_args, const char *fnspec) @@ -3119,10 +3157,11 @@ gfc_get_function_type (gfc_symbol * sym, gfc_actual_arglist *actual_args, } } - /* Add hidden string length parameters. */ + /* Add hidden arguments. */ for (f = gfc_sym_get_dummy_args (sym); f; f = f->next) { arg = f->sym; + /* Add hidden string length parameters. */ if (arg && arg->ts.type == BT_CHARACTER && !sym->attr.is_bind_c) { if (!arg->ts.deferred) @@ -3145,6 +3184,20 @@ gfc_get_function_type (gfc_symbol * sym, gfc_actual_arglist *actual_args, && arg->ts.type != BT_CLASS && !gfc_bt_struct (arg->ts.type)) vec_safe_push (typelist, boolean_type_node); + /* Coarrays which are descriptorless or assumed-shape pass with + -fcoarray=lib the token and the offset as hidden arguments. */ + if (arg + && flag_coarray == GFC_FCOARRAY_LIB + && ((arg->ts.type != BT_CLASS + && arg->attr.codimension + && !arg->attr.allocatable) + || (arg->ts.type == BT_CLASS + && CLASS_DATA (arg)->attr.codimension + && !CLASS_DATA (arg)->attr.allocatable))) + { + vec_safe_push (typelist, pvoid_type_node); /* caf_token. */ + vec_safe_push (typelist, gfc_array_index_type); /* caf_offset. */ + } } if (!vec_safe_is_empty (typelist) @@ -3502,11 +3555,11 @@ gfc_get_caf_vector_type (int dim) tmp = gfc_add_field_to_struct_1 (vect_struct_type, get_identifier ("vector"), pvoid_type_node, &chain); - TREE_NO_WARNING (tmp) = 1; + suppress_warning (tmp); tmp = gfc_add_field_to_struct_1 (vect_struct_type, get_identifier ("kind"), integer_type_node, &chain); - TREE_NO_WARNING (tmp) = 1; + suppress_warning (tmp); gfc_finish_type (vect_struct_type); chain = 0; @@ -3514,34 +3567,34 @@ gfc_get_caf_vector_type (int dim) tmp = gfc_add_field_to_struct_1 (triplet_struct_type, get_identifier ("lower_bound"), gfc_array_index_type, &chain); - TREE_NO_WARNING (tmp) = 1; + suppress_warning (tmp); tmp = gfc_add_field_to_struct_1 (triplet_struct_type, get_identifier ("upper_bound"), gfc_array_index_type, &chain); - TREE_NO_WARNING (tmp) = 1; + suppress_warning (tmp); tmp = gfc_add_field_to_struct_1 (triplet_struct_type, get_identifier ("stride"), gfc_array_index_type, &chain); - TREE_NO_WARNING (tmp) = 1; + suppress_warning (tmp); gfc_finish_type (triplet_struct_type); chain = 0; union_type = make_node (UNION_TYPE); tmp = gfc_add_field_to_struct_1 (union_type, get_identifier ("v"), vect_struct_type, &chain); - TREE_NO_WARNING (tmp) = 1; + suppress_warning (tmp); tmp = gfc_add_field_to_struct_1 (union_type, get_identifier ("triplet"), triplet_struct_type, &chain); - TREE_NO_WARNING (tmp) = 1; + suppress_warning (tmp); gfc_finish_type (union_type); chain = 0; vec_type = make_node (RECORD_TYPE); tmp = gfc_add_field_to_struct_1 (vec_type, get_identifier ("nvec"), size_type_node, &chain); - TREE_NO_WARNING (tmp) = 1; + suppress_warning (tmp); tmp = gfc_add_field_to_struct_1 (vec_type, get_identifier ("u"), union_type, &chain); - TREE_NO_WARNING (tmp) = 1; + suppress_warning (tmp); gfc_finish_type (vec_type); TYPE_NAME (vec_type) = get_identifier ("caf_vector_t"); } @@ -3568,11 +3621,11 @@ gfc_get_caf_reference_type () tmp = gfc_add_field_to_struct_1 (c_struct_type, get_identifier ("offset"), gfc_array_index_type, &chain); - TREE_NO_WARNING (tmp) = 1; + suppress_warning (tmp); tmp = gfc_add_field_to_struct_1 (c_struct_type, get_identifier ("caf_token_offset"), gfc_array_index_type, &chain); - TREE_NO_WARNING (tmp) = 1; + suppress_warning (tmp); gfc_finish_type (c_struct_type); chain = 0; @@ -3580,15 +3633,15 @@ gfc_get_caf_reference_type () tmp = gfc_add_field_to_struct_1 (s_struct_type, get_identifier ("start"), gfc_array_index_type, &chain); - TREE_NO_WARNING (tmp) = 1; + suppress_warning (tmp); tmp = gfc_add_field_to_struct_1 (s_struct_type, get_identifier ("end"), gfc_array_index_type, &chain); - TREE_NO_WARNING (tmp) = 1; + suppress_warning (tmp); tmp = gfc_add_field_to_struct_1 (s_struct_type, get_identifier ("stride"), gfc_array_index_type, &chain); - TREE_NO_WARNING (tmp) = 1; + suppress_warning (tmp); gfc_finish_type (s_struct_type); chain = 0; @@ -3596,25 +3649,25 @@ gfc_get_caf_reference_type () tmp = gfc_add_field_to_struct_1 (v_struct_type, get_identifier ("vector"), pvoid_type_node, &chain); - TREE_NO_WARNING (tmp) = 1; + suppress_warning (tmp); tmp = gfc_add_field_to_struct_1 (v_struct_type, get_identifier ("nvec"), size_type_node, &chain); - TREE_NO_WARNING (tmp) = 1; + suppress_warning (tmp); tmp = gfc_add_field_to_struct_1 (v_struct_type, get_identifier ("kind"), integer_type_node, &chain); - TREE_NO_WARNING (tmp) = 1; + suppress_warning (tmp); gfc_finish_type (v_struct_type); chain = 0; union_type = make_node (UNION_TYPE); tmp = gfc_add_field_to_struct_1 (union_type, get_identifier ("s"), s_struct_type, &chain); - TREE_NO_WARNING (tmp) = 1; + suppress_warning (tmp); tmp = gfc_add_field_to_struct_1 (union_type, get_identifier ("v"), v_struct_type, &chain); - TREE_NO_WARNING (tmp) = 1; + suppress_warning (tmp); gfc_finish_type (union_type); tmp = build_range_type (gfc_array_index_type, gfc_index_zero_node, @@ -3629,40 +3682,40 @@ gfc_get_caf_reference_type () gfc_index_zero_node, gfc_rank_cst[GFC_MAX_DIMENSIONS - 1])), &chain); - TREE_NO_WARNING (tmp) = 1; + suppress_warning (tmp); tmp = gfc_add_field_to_struct_1 (a_struct_type, get_identifier ("static_array_type"), integer_type_node, &chain); - TREE_NO_WARNING (tmp) = 1; + suppress_warning (tmp); tmp = gfc_add_field_to_struct_1 (a_struct_type, get_identifier ("dim"), dim_union_type, &chain); - TREE_NO_WARNING (tmp) = 1; + suppress_warning (tmp); gfc_finish_type (a_struct_type); chain = 0; u_union_type = make_node (UNION_TYPE); tmp = gfc_add_field_to_struct_1 (u_union_type, get_identifier ("c"), c_struct_type, &chain); - TREE_NO_WARNING (tmp) = 1; + suppress_warning (tmp); tmp = gfc_add_field_to_struct_1 (u_union_type, get_identifier ("a"), a_struct_type, &chain); - TREE_NO_WARNING (tmp) = 1; + suppress_warning (tmp); gfc_finish_type (u_union_type); chain = 0; reference_type = make_node (RECORD_TYPE); tmp = gfc_add_field_to_struct_1 (reference_type, get_identifier ("next"), build_pointer_type (reference_type), &chain); - TREE_NO_WARNING (tmp) = 1; + suppress_warning (tmp); tmp = gfc_add_field_to_struct_1 (reference_type, get_identifier ("type"), integer_type_node, &chain); - TREE_NO_WARNING (tmp) = 1; + suppress_warning (tmp); tmp = gfc_add_field_to_struct_1 (reference_type, get_identifier ("item_size"), size_type_node, &chain); - TREE_NO_WARNING (tmp) = 1; + suppress_warning (tmp); tmp = gfc_add_field_to_struct_1 (reference_type, get_identifier ("u"), u_union_type, &chain); - TREE_NO_WARNING (tmp) = 1; + suppress_warning (tmp); gfc_finish_type (reference_type); TYPE_NAME (reference_type) = get_identifier ("caf_reference_t"); diff --git a/gcc/fortran/trans-types.h b/gcc/fortran/trans-types.h index ff01226..3b45ce2 100644 --- a/gcc/fortran/trans-types.h +++ b/gcc/fortran/trans-types.h @@ -114,7 +114,7 @@ int gfc_is_nodesc_array (gfc_symbol *); /* Return the DTYPE for an array. */ tree gfc_get_dtype_rank_type (int, tree); -tree gfc_get_dtype (tree); +tree gfc_get_dtype (tree, int *rank = NULL); tree gfc_get_ppc_type (gfc_component *); tree gfc_get_caf_vector_type (int dim); diff --git a/gcc/fortran/trans.c b/gcc/fortran/trans.c index ab53fc5..eb5682a 100644 --- a/gcc/fortran/trans.c +++ b/gcc/fortran/trans.c @@ -129,7 +129,7 @@ gfc_create_var_np (tree type, const char *prefix) /* No warnings for anonymous variables. */ if (prefix == NULL) - TREE_NO_WARNING (t) = 1; + suppress_warning (t); return t; } @@ -371,30 +371,16 @@ get_array_span (tree type, tree decl) return gfc_conv_descriptor_span_get (decl); /* Return the span for deferred character length array references. */ - if (type && TREE_CODE (type) == ARRAY_TYPE - && TYPE_MAX_VALUE (TYPE_DOMAIN (type)) != NULL_TREE - && (VAR_P (TYPE_MAX_VALUE (TYPE_DOMAIN (type))) - || TREE_CODE (TYPE_MAX_VALUE (TYPE_DOMAIN (type))) == INDIRECT_REF) - && (TREE_CODE (TYPE_MAX_VALUE (TYPE_DOMAIN (type))) == INDIRECT_REF - || TREE_CODE (decl) == FUNCTION_DECL - || DECL_CONTEXT (TYPE_MAX_VALUE (TYPE_DOMAIN (type))) - == DECL_CONTEXT (decl))) - { - span = fold_convert (gfc_array_index_type, - TYPE_MAX_VALUE (TYPE_DOMAIN (type))); - span = fold_build2 (MULT_EXPR, gfc_array_index_type, - fold_convert (gfc_array_index_type, - TYPE_SIZE_UNIT (TREE_TYPE (type))), - span); - } - else if (type && TREE_CODE (type) == ARRAY_TYPE - && TYPE_MAX_VALUE (TYPE_DOMAIN (type)) != NULL_TREE - && integer_zerop (TYPE_MAX_VALUE (TYPE_DOMAIN (type)))) + if (type && TREE_CODE (type) == ARRAY_TYPE && TYPE_STRING_FLAG (type)) { + if (TREE_CODE (decl) == PARM_DECL) + decl = build_fold_indirect_ref_loc (input_location, decl); if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (decl))) span = gfc_conv_descriptor_span_get (decl); else - span = NULL_TREE; + span = gfc_get_character_len_in_bytes (type); + span = (span && !integer_zerop (span)) + ? (fold_convert (gfc_array_index_type, span)) : (NULL_TREE); } /* Likewise for class array or pointer array references. */ else if (TREE_CODE (decl) == FIELD_DECL @@ -422,6 +408,9 @@ get_array_span (tree type, tree decl) return NULL_TREE; } span = gfc_class_vtab_size_get (decl); + /* For unlimited polymorphic entities then _len component needs + to be multiplied with the size. */ + span = gfc_resize_class_size_with_len (NULL, decl, span); } else if (GFC_DECL_PTR_ARRAY_P (decl)) { @@ -439,13 +428,31 @@ get_array_span (tree type, tree decl) } +tree +gfc_build_spanned_array_ref (tree base, tree offset, tree span) +{ + tree type; + tree tmp; + type = TREE_TYPE (TREE_TYPE (base)); + offset = fold_build2_loc (input_location, MULT_EXPR, + gfc_array_index_type, + offset, span); + tmp = gfc_build_addr_expr (pvoid_type_node, base); + tmp = fold_build_pointer_plus_loc (input_location, tmp, offset); + tmp = fold_convert (build_pointer_type (type), tmp); + if ((TREE_CODE (type) != INTEGER_TYPE && TREE_CODE (type) != ARRAY_TYPE) + || !TYPE_STRING_FLAG (type)) + tmp = build_fold_indirect_ref_loc (input_location, tmp); + return tmp; +} + + /* Build an ARRAY_REF with its natural type. */ tree gfc_build_array_ref (tree base, tree offset, tree decl, tree vptr) { tree type = TREE_TYPE (base); - tree tmp; tree span = NULL_TREE; if (GFC_ARRAY_TYPE_P (type) && GFC_TYPE_ARRAY_RANK (type) == 0) @@ -488,18 +495,7 @@ gfc_build_array_ref (tree base, tree offset, tree decl, tree vptr) /* If a non-null span has been generated reference the element with pointer arithmetic. */ if (span != NULL_TREE) - { - offset = fold_build2_loc (input_location, MULT_EXPR, - gfc_array_index_type, - offset, span); - tmp = gfc_build_addr_expr (pvoid_type_node, base); - tmp = fold_build_pointer_plus_loc (input_location, tmp, offset); - tmp = fold_convert (build_pointer_type (type), tmp); - if ((TREE_CODE (type) != INTEGER_TYPE && TREE_CODE (type) != ARRAY_TYPE) - || !TYPE_STRING_FLAG (type)) - tmp = build_fold_indirect_ref_loc (input_location, tmp); - return tmp; - } + return gfc_build_spanned_array_ref (base, offset, span); /* Otherwise use a straightforward array reference. */ else return build4_loc (input_location, ARRAY_REF, type, base, offset, @@ -2151,20 +2147,36 @@ trans_code (gfc_code * code, tree cond) case EXEC_OMP_CANCEL: case EXEC_OMP_CANCELLATION_POINT: case EXEC_OMP_CRITICAL: + case EXEC_OMP_DEPOBJ: case EXEC_OMP_DISTRIBUTE: case EXEC_OMP_DISTRIBUTE_PARALLEL_DO: case EXEC_OMP_DISTRIBUTE_PARALLEL_DO_SIMD: case EXEC_OMP_DISTRIBUTE_SIMD: case EXEC_OMP_DO: case EXEC_OMP_DO_SIMD: + case EXEC_OMP_LOOP: + case EXEC_OMP_ERROR: case EXEC_OMP_FLUSH: + case EXEC_OMP_MASKED: + case EXEC_OMP_MASKED_TASKLOOP: + case EXEC_OMP_MASKED_TASKLOOP_SIMD: case EXEC_OMP_MASTER: + case EXEC_OMP_MASTER_TASKLOOP: + case EXEC_OMP_MASTER_TASKLOOP_SIMD: case EXEC_OMP_ORDERED: case EXEC_OMP_PARALLEL: case EXEC_OMP_PARALLEL_DO: case EXEC_OMP_PARALLEL_DO_SIMD: + case EXEC_OMP_PARALLEL_LOOP: + case EXEC_OMP_PARALLEL_MASKED: + case EXEC_OMP_PARALLEL_MASKED_TASKLOOP: + case EXEC_OMP_PARALLEL_MASKED_TASKLOOP_SIMD: + case EXEC_OMP_PARALLEL_MASTER: + case EXEC_OMP_PARALLEL_MASTER_TASKLOOP: + case EXEC_OMP_PARALLEL_MASTER_TASKLOOP_SIMD: case EXEC_OMP_PARALLEL_SECTIONS: case EXEC_OMP_PARALLEL_WORKSHARE: + case EXEC_OMP_SCOPE: case EXEC_OMP_SECTIONS: case EXEC_OMP_SIMD: case EXEC_OMP_SINGLE: @@ -2175,12 +2187,14 @@ trans_code (gfc_code * code, tree cond) case EXEC_OMP_TARGET_PARALLEL: case EXEC_OMP_TARGET_PARALLEL_DO: case EXEC_OMP_TARGET_PARALLEL_DO_SIMD: + case EXEC_OMP_TARGET_PARALLEL_LOOP: case EXEC_OMP_TARGET_SIMD: case EXEC_OMP_TARGET_TEAMS: case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE: case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO: case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD: case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_SIMD: + case EXEC_OMP_TARGET_TEAMS_LOOP: case EXEC_OMP_TARGET_UPDATE: case EXEC_OMP_TASK: case EXEC_OMP_TASKGROUP: @@ -2193,6 +2207,7 @@ trans_code (gfc_code * code, tree cond) case EXEC_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO: case EXEC_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD: case EXEC_OMP_TEAMS_DISTRIBUTE_SIMD: + case EXEC_OMP_TEAMS_LOOP: case EXEC_OMP_WORKSHARE: res = gfc_trans_omp_directive (code); break; diff --git a/gcc/fortran/trans.h b/gcc/fortran/trans.h index 44cbfb6..78578cf 100644 --- a/gcc/fortran/trans.h +++ b/gcc/fortran/trans.h @@ -53,6 +53,9 @@ typedef struct gfc_se here. */ tree class_vptr; + /* Whether expr is a reference to an unlimited polymorphic object. */ + unsigned unlimited_polymorphic:1; + /* If set gfc_conv_variable will return an expression for the array descriptor. When set, want_pointer should also be set. If not set scalarizing variables will be substituted. */ @@ -424,7 +427,8 @@ tree gfc_class_vptr_get (tree); tree gfc_class_len_get (tree); tree gfc_class_len_or_zero_get (tree); tree gfc_resize_class_size_with_len (stmtblock_t *, tree, tree); -gfc_expr * gfc_find_and_cut_at_last_class_ref (gfc_expr *, bool is_mold = false); +gfc_expr * gfc_find_and_cut_at_last_class_ref (gfc_expr *, bool is_mold = false, + gfc_typespec **ts = NULL); /* Get an accessor to the class' vtab's * field, when a class handle is available. */ tree gfc_class_vtab_hash_get (tree); @@ -505,6 +509,8 @@ void gfc_conv_expr_type (gfc_se * se, gfc_expr *, tree); /* trans-expr.c */ +tree gfc_get_character_len (tree); +tree gfc_get_character_len_in_bytes (tree); tree gfc_conv_scalar_to_descriptor (gfc_se *, tree, symbol_attribute); tree gfc_get_ultimate_alloc_ptr_comps_caf_token (gfc_se *, gfc_expr *); void gfc_conv_scalar_char_value (gfc_symbol *sym, gfc_se *se, gfc_expr **expr); @@ -622,6 +628,9 @@ tree gfc_build_addr_expr (tree, tree); /* Build an ARRAY_REF. */ tree gfc_build_array_ref (tree, tree, tree, tree vptr = NULL_TREE); +/* Build an array ref using pointer arithmetic. */ +tree gfc_build_spanned_array_ref (tree base, tree offset, tree span); + /* Creates a label. Decl is artificial if label_id == NULL_TREE. */ tree gfc_build_label_decl (tree); @@ -814,7 +823,9 @@ 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_scalar_p (tree); +bool gfc_omp_allocatable_p (tree); +bool gfc_omp_scalar_p (tree, bool); +bool gfc_omp_scalar_target_p (tree); bool gfc_omp_disregard_value_expr (tree, bool); bool gfc_omp_private_debug_clause (tree, bool); bool gfc_omp_private_outer_ref (tree); @@ -965,6 +976,7 @@ extern GTY(()) tree gfor_fndecl_ieee_procedure_exit; /* RANDOM_INIT. */ extern GTY(()) tree gfor_fndecl_random_init; +extern GTY(()) tree gfor_fndecl_caf_random_init; /* True if node is an integer constant. */ #define INTEGER_CST_P(node) (TREE_CODE(node) == INTEGER_CST) @@ -1020,6 +1032,7 @@ struct GTY(()) lang_decl { tree token, caf_offset; unsigned int scalar_allocatable : 1; unsigned int scalar_pointer : 1; + unsigned int scalar_target : 1; unsigned int optional_arg : 1; }; @@ -1034,12 +1047,16 @@ struct GTY(()) lang_decl { (DECL_LANG_SPECIFIC (node)->scalar_allocatable) #define GFC_DECL_SCALAR_POINTER(node) \ (DECL_LANG_SPECIFIC (node)->scalar_pointer) +#define GFC_DECL_SCALAR_TARGET(node) \ + (DECL_LANG_SPECIFIC (node)->scalar_target) #define GFC_DECL_OPTIONAL_ARGUMENT(node) \ (DECL_LANG_SPECIFIC (node)->optional_arg) #define GFC_DECL_GET_SCALAR_ALLOCATABLE(node) \ (DECL_LANG_SPECIFIC (node) ? GFC_DECL_SCALAR_ALLOCATABLE (node) : 0) #define GFC_DECL_GET_SCALAR_POINTER(node) \ (DECL_LANG_SPECIFIC (node) ? GFC_DECL_SCALAR_POINTER (node) : 0) +#define GFC_DECL_GET_SCALAR_TARGET(node) \ + (DECL_LANG_SPECIFIC (node) ? GFC_DECL_SCALAR_TARGET (node) : 0) #define GFC_DECL_PACKED_ARRAY(node) DECL_LANG_FLAG_0(node) #define GFC_DECL_PARTIAL_PACKED_ARRAY(node) DECL_LANG_FLAG_1(node) #define GFC_DECL_ASSIGN(node) DECL_LANG_FLAG_2(node) diff --git a/gcc/fortran/types.def b/gcc/fortran/types.def index 8626ed0..85b85ed 100644 --- a/gcc/fortran/types.def +++ b/gcc/fortran/types.def @@ -120,6 +120,7 @@ DEF_FUNCTION_TYPE_2 (BT_FN_BOOL_INT_BOOL, BT_BOOL, BT_INT, BT_BOOL) DEF_FUNCTION_TYPE_2 (BT_FN_VOID_UINT_UINT, BT_VOID, BT_UINT, BT_UINT) DEF_FUNCTION_TYPE_2 (BT_FN_VOID_PTR_PTRMODE, BT_VOID, BT_PTR, BT_PTRMODE) +DEF_FUNCTION_TYPE_2 (BT_FN_VOID_CONST_PTR_SIZE, BT_VOID, BT_CONST_PTR, BT_SIZE) DEF_POINTER_TYPE (BT_PTR_FN_VOID_PTR_PTR, BT_FN_VOID_PTR_PTR) |