diff --git a/gcc/fortran/ChangeLog b/gcc/fortran/ChangeLog index d4a2720c6bf..7a36057a8f2 100644 --- a/gcc/fortran/ChangeLog +++ b/gcc/fortran/ChangeLog @@ -1,3 +1,375 @@ +2006-02-14 Jakub Jelinek + Richard Henderson + Diego Novillo + + * invoke.texi: Document -fopenmp. + * gfortran.texi (Extensions): Document OpenMP. + + Backport from gomp-20050608-branch + * trans-openmp.c: Call build_omp_clause instead of + make_node when creating OMP_CLAUSE_* trees. + (gfc_trans_omp_reduction_list): Remove argument 'code'. + Adjust all callers. + + * trans.h (build4_v): Define. + * trans-openmp.c: Call build4_v to create OMP_PARALLEL nodes. + Call build3_v to create OMP_SECTIONS nodes. + + PR fortran/25162 + * openmp.c (gfc_match_omp_variable_list): Call gfc_set_sym_referenced + on all symbols added to the variable list. + + * openmp.c (gfc_match_omp_clauses): Fix check for non-INTRINSIC + procedure symbol in REDUCTION. + + * trans-openmp.c (gfc_trans_omp_array_reduction): Use gfc_add + for MINUS_EXPR OMP_CLAUSE_REDUCTION_CODE. + + * trans-openmp.c (gfc_trans_omp_do): Add PBLOCK argument. If PBLOCK + is non-NULL, evaluate INIT/COND/INCR and chunk size expressions in + that statement block. + (gfc_trans_omp_parallel_do): Pass non-NULL PBLOCK to gfc_trans_omp_do + for non-ordered non-static combined loops. + (gfc_trans_omp_directive): Pass NULL PBLOCK to gfc_trans_omp_do. + + * openmp.c: Include target.h and toplev.h. + (gfc_match_omp_threadprivate): Emit diagnostic if target does + not support TLS. + * Make-lang.in (fortran/openmp.o): Add dependencies on + target.h and toplev.h. + + * trans-decl.c (gfc_get_fake_result_decl): Set GFC_DECL_RESULT. + * trans-openmp.c (gfc_omp_privatize_by_reference): Make + DECL_ARTIFICIAL vars predetermined shared except GFC_DECL_RESULT. + (gfc_omp_disregard_value_expr): Handle GFC_DECL_RESULT. + (gfc_trans_omp_variable): New function. + (gfc_trans_omp_variable_list, gfc_trans_omp_reduction_list): Use it. + * trans.h (GFC_DECL_RESULT): Define. + + * trans-openmp.c (gfc_omp_firstprivatize_type_sizes): New function. + * f95-lang.c (LANG_HOOKS_OMP_FIRSTPRIVATIZE_TYPE_SIZES): Define. + * trans.h (gfc_omp_firstprivatize_type_sizes): New prototype. + + * trans-openmp.c (gfc_omp_privatize_by_reference): Return + true if a pointer has GFC_DECL_SAVED_DESCRIPTOR set. + (gfc_trans_omp_array_reduction, gfc_trans_omp_reduction_list): New + functions. + (gfc_trans_omp_clauses): Add WHERE argument. Call + gfc_trans_omp_reduction_list rather than gfc_trans_omp_variable_list + for reductions. + (gfc_trans_omp_do, gfc_trans_omp_parallel, gfc_trans_omp_parallel_do, + gfc_trans_omp_parallel_sections, gfc_trans_omp_parallel_workshare, + gfc_trans_omp_sections, gfc_trans_omp_single): Adjust + gfc_trans_omp_clauses callers. + + * openmp.c (omp_current_do_code): New var. + (gfc_resolve_omp_do_blocks): New function. + (gfc_resolve_omp_parallel_blocks): Call it. + (gfc_resolve_do_iterator): Add CODE argument. Don't propagate + predetermination if argument is !$omp do or !$omp parallel do + iteration variable. + * resolve.c (resolve_code): Call gfc_resolve_omp_do_blocks + for EXEC_OMP_DO. Adjust gfc_resolve_do_iterator caller. + * fortran.h (gfc_resolve_omp_do_blocks): New prototype. + (gfc_resolve_do_iterator): Add CODE argument. + + * trans.h (gfc_omp_predetermined_sharing, + gfc_omp_disregard_value_expr, gfc_omp_private_debug_clause): New + prototypes. + (GFC_DECL_COMMON_OR_EQUIV, GFC_DECL_CRAY_POINTEE): Define. + * trans-openmp.c (gfc_omp_predetermined_sharing, + gfc_omp_disregard_value_expr, gfc_omp_private_debug_clause): New + functions. + * trans-common.c (build_equiv_decl, build_common_decl, + create_common): Set GFC_DECL_COMMON_OR_EQUIV flag on the decls. + * trans-decl.c (gfc_finish_cray_pointee): Set GFC_DECL_CRAY_POINTEE + on the decl. + * f95-lang.c (LANG_HOOKS_OMP_PREDETERMINED_SHARING, + LANG_HOOKS_OMP_DISREGARD_VALUE_EXPR, + LANG_HOOKS_OMP_PRIVATE_DEBUG_CLAUSE): Define. + + * openmp.c (resolve_omp_clauses): Remove extraneous comma. + + * symbol.c (check_conflict): Add conflict between cray_pointee and + threadprivate. + * openmp.c (gfc_match_omp_threadprivate): Fail if + gfc_add_threadprivate returned FAILURE. + (resolve_omp_clauses): Diagnose Cray pointees in SHARED, + {,FIRST,LAST}PRIVATE and REDUCTION clauses and Cray pointers in + {FIRST,LAST}PRIVATE and REDUCTION clauses. + + * resolve.c (omp_workshare_flag): New variable. + (resolve_function): Diagnose use of non-ELEMENTAL user defined + function in WORKSHARE construct. + (resolve_code): Cleanup forall_save use. Make sure omp_workshare_flag + is set to correct value in different contexts. + + * openmp.c (resolve_omp_clauses): Replace %s with '%s' when printing + variable name. + (resolve_omp_atomic): Likewise. + + PR fortran/24493 + * scanner.c (skip_free_comments): Set at_bol at the beginning of the + loop, not before it. + (skip_fixed_comments): Handle ! comments in the middle of line here + as well. + (gfc_skip_comments): Use skip_fixed_comments for FIXED_FORM even if + not at BOL. + (gfc_next_char_literal): Fix expected canonicalized *$omp string. + + * trans-openmp.c (gfc_trans_omp_do): Use make_node and explicit + initialization to build OMP_FOR instead of build. + + * trans-decl.c (gfc_gimplify_function): Invoke + diagnose_omp_structured_block_errors. + + * trans-openmp.c (gfc_trans_omp_master): Use OMP_MASTER. + (gfc_trans_omp_ordered): Use OMP_ORDERED. + + * gfortran.h (gfc_resolve_do_iterator, gfc_resolve_blocks, + gfc_resolve_omp_parallel_blocks): New prototypes. + * resolve.c (resolve_blocks): Renamed to... + (gfc_resolve_blocks): ... this. Remove static. + (gfc_resolve_forall): Adjust caller. + (resolve_code): Only call gfc_resolve_blocks if code->block != 0 + and not for EXEC_OMP_PARALLEL* directives. Call + gfc_resolve_omp_parallel_blocks for EXEC_OMP_PARALLEL* directives. + Call gfc_resolve_do_iterator if resolved successfully EXEC_DO + iterator. + * openmp.c: Include pointer-set.h. + (omp_current_ctx): New variable. + (gfc_resolve_omp_parallel_blocks, gfc_resolve_do_iterator): New + functions. + * Make-lang.in (fortran/openmp.o): Depend on pointer-set.h. + + * openmp.c (gfc_match_omp_clauses): For max/min/iand/ior/ieor, + look up symbol if it exists, use its name instead and, if it is not + INTRINSIC, issue diagnostics. + + * parse.c (parse_omp_do): Handle implied end do properly. + (parse_executable): If parse_omp_do returned ST_IMPLIED_ENDDO, + return it instead of continuing. + + * trans-openmp.c (gfc_trans_omp_critical): Update for changed + operand numbering. + (gfc_trans_omp_do, gfc_trans_omp_parallel, gfc_trans_omp_parallel_do, + gfc_trans_omp_parallel_sections, gfc_trans_omp_parallel_workshare, + gfc_trans_omp_sections, gfc_trans_omp_single): Likewise. + + * trans.h (gfc_omp_privatize_by_reference): New prototype. + * f95-lang.c (LANG_HOOKS_OMP_PRIVATIZE_BY_REFERENCE): Redefine + to gfc_omp_privatize_by_reference. + * trans-openmp.c (gfc_omp_privatize_by_reference): New function. + + * trans-stmt.h (gfc_trans_omp_directive): Add comment. + + * openmp.c (gfc_match_omp_variable_list): Add ALLOW_COMMON argument. + Disallow COMMON matching if it is set. + (gfc_match_omp_clauses, gfc_match_omp_flush): Adjust all callers. + (resolve_omp_clauses): Show locus in error messages. Check that + variable types in reduction clauses are appropriate for reduction + operators. + + * resolve.c (resolve_symbol): Don't error if a threadprivate module + variable isn't SAVEd. + + * trans-openmp.c (gfc_trans_omp_do): Put count into BLOCK, not BODY. + Fix typo in condition. Fix DOVAR initialization. + + * openmp.c (gfc_match_omp_clauses): Match min/iand/ior/ieor + rather than .min. etc. + + * trans-openmpc.c (omp_not_yet): Remove. + (gfc_trans_omp_parallel_do): Keep listprivate clause on parallel. + Force creation of BIND_EXPR around the workshare construct. + (gfc_trans_omp_parallel_sections): Likewise. + (gfc_trans_omp_parallel_workshare): Likewise. + + * types.def (BT_I16, BT_FN_I16_VPTR_I16, + BT_FN_BOOL_VPTR_I16_I16, BT_FN_I16_VPTR_I16_I16): Add. + + * trans-openmp.c (gfc_trans_omp_clauses): Create OMP_CLAUSE_DEFAULT. + (gfc_trans_omp_code): New function. + (gfc_trans_omp_do): Use it, remove omp_not_yet uses. + (gfc_trans_omp_parallel, gfc_trans_omp_single): Likewise. + (gfc_trans_omp_sections): Likewise. Only treat empty last section + specially if lastprivate clause is present. + * f95-lang.c (gfc_init_builtin_functions): Create BUILT_IN_TRAP + builtin. + + * trans-openmp.c (gfc_trans_omp_variable_list): Update for + OMP_CLAUSE_DECL name change. + (gfc_trans_omp_do): Likewise. + + * trans-openmp.c (gfc_trans_omp_clauses): Create OMP_CLAUSE_REDUCTION + clauses. + (gfc_trans_omp_atomic): Build OMP_ATOMIC instead of expanding + sync builtins directly. + (gfc_trans_omp_single): Build OMP_SINGLE statement. + + * trans-openmp.c (gfc_trans_add_clause): New. + (gfc_trans_omp_variable_list): Take a tree code and build the clause + node here. Link it to the head of a list. + (gfc_trans_omp_clauses): Update to match. + (gfc_trans_omp_do): Use gfc_trans_add_clause. + + * trans-openmp.c (gfc_trans_omp_clauses): Change second argument to + gfc_omp_clauses *. Use gfc_evaluate_now instead of creating + temporaries by hand. + (gfc_trans_omp_atomic, gfc_trans_omp_critical): Use buildN_v macros. + (gfc_trans_omp_do): New function. + (gfc_trans_omp_master): Dont' check for gfc_trans_code returning NULL. + (gfc_trans_omp_parallel): Adjust gfc_trans_omp_clauses caller. + Use buildN_v macros. + (gfc_trans_omp_parallel_do, gfc_trans_omp_parallel_sections, + gfc_trans_omp_parallel_workshare, gfc_trans_omp_sections, + gfc_trans_omp_single, gfc_trans_omp_workshare): New functions. + (gfc_trans_omp_directive): Use them. + * parse.c (parse_omp_do): Allow new_st.op == EXEC_NOP. + * openmp.c (resolve_omp_clauses): Check for list items present + in multiple clauses. + (resolve_omp_do): Check that iteration variable is not THREADPRIVATE + and is not present in any clause variable lists other than PRIVATE + or LASTPRIVATE. + + * gfortran.h (symbol_attribute): Add threadprivate bit. + (gfc_common_head): Add threadprivate member, change use_assoc + and saved into char to save space. + (gfc_add_threadprivate): New prototype. + * symbol.c (check_conflict): Handle threadprivate. + (gfc_add_threadprivate): New function. + (gfc_copy_attr): Copy threadprivate. + * trans-openmp.c (gfc_trans_omp_clauses): Avoid creating a temporary + if IF or NUM_THREADS is constant. Create OMP_CLAUSE_SCHEDULE and + OMP_CLAUSE_ORDERED. + * resolve.c (resolve_symbol): Complain if a THREADPRIVATE symbol + outside a module and not in COMMON has is not SAVEd. + (resolve_equivalence): Ensure THREADPRIVATE objects don't get + EQUIVALENCEd. + * trans-common.c: Include target.h and rtl.h. + (build_common_decl): Set DECL_TLS_MODEL if THREADPRIVATE. + * trans-decl.c: Include rtl.h. + (gfc_finish_var_decl): Set DECL_TLS_MODEL if THREADPRIVATE. + * dump-parse-tree.c (gfc_show_attr): Handle THREADPRIVATE. + * Make-lang.in (fortran/trans-decl.o): Depend on $(RTL_H). + (fortran/trans-common.o): Depend on $(RTL_H) and $(TARGET_H). + * openmp.c (gfc_match_omp_variable_list): Ensure COMMON block + is from current namespace. + (gfc_match_omp_threadprivate): Rewrite. + (resolve_omp_clauses): Check some clause restrictions. + * module.c (ab_attribute): Add AB_THREADPRIVATE. + (attr_bits): Add THREADPRIVATE. + (mio_symbol_attribute, mio_symbol_attribute): Handle threadprivate. + (load_commons, write_common, write_blank_common): Adjust for type + change of saved, store/load threadprivate bit from the integer + as well. + + * types.def (BT_FN_UINT_UINT): New. + (BT_FN_VOID_UINT_UINT): Remove. + + * trans-openmp.c (gfc_trans_omp_clauses, gfc_trans_omp_barrier, + gfc_trans_omp_critical, gfc_trans_omp_flush, gfc_trans_omp_master, + gfc_trans_omp_ordered, gfc_trans_omp_parallel): New functions. + (gfc_trans_omp_directive): Use them. + + * openmp.c (expr_references_sym): Add SE argument, don't look + into SE tree. + (is_conversion): New function. + (resolve_omp_atomic): Adjust expr_references_sym callers. Handle + promoted expressions. + * trans-openmp.c (gfc_trans_omp_atomic): New function. + (gfc_trans_omp_directive): Call it. + + * f95-lang.c (builtin_type_for_size): New function. + (gfc_init_builtin_functions): Initialize synchronization and + OpenMP builtins. + * types.def: New file. + * Make-lang.in (f95-lang.o): Depend on $(BUILTINS_DEF) and + fortran/types.def. + + * trans-openmp.c: Rename GOMP_* tree codes into OMP_*. + + * dump-parse-tree.c (show_symtree): Don't crash if ns->proc_name + is NULL. + + * dump-parse-tree.c (gfc_show_namelist, gfc_show_omp_node): New + functions. + (gfc_show_code_node): Call gfc_show_omp_node for EXEC_OMP_* nodes. + + * parse.c (parse_omp_do): Call pop_state before next_statement. + * openmp.c (expr_references_sym, resolve_omp_atomic, resolve_omp_do): + New functions. + (gfc_resolve_omp_directive): Call them. + * match.c (match_exit_cycle): Issue error if EXIT or CYCLE statement + leaves an OpenMP structured block or if EXIT terminates !$omp do + loop. + + * Make-lang.in (F95_PARSER_OBJS): Add fortran/openmp.o. + (F95_OBJS): Add fortran/trans-openmp.o. + (fortran/trans-openmp.o): Depend on $(GFORTRAN_TRANS_DEPS). + * lang.opt: Add -fopenmp option. + * options.c (gfc_init_options): Initialize it. + (gfc_handle_option): Handle it. + * gfortran.h (ST_OMP_ATOMIC, ST_OMP_BARRIER, ST_OMP_CRITICAL, + ST_OMP_END_CRITICAL, ST_OMP_END_DO, ST_OMP_END_MASTER, + ST_OMP_END_ORDERED, ST_OMP_END_PARALLEL, ST_OMP_END_PARALLEL_DO, + ST_OMP_END_PARALLEL_SECTIONS, ST_OMP_END_PARALLEL_WORKSHARE, + ST_OMP_END_SECTIONS, ST_OMP_END_SINGLE, ST_OMP_END_WORKSHARE, + ST_OMP_DO, ST_OMP_FLUSH, ST_OMP_MASTER, ST_OMP_ORDERED, + ST_OMP_PARALLEL, ST_OMP_PARALLEL_DO, ST_OMP_PARALLEL_SECTIONS, + ST_OMP_PARALLEL_WORKSHARE, ST_OMP_SECTIONS, ST_OMP_SECTION, + ST_OMP_SINGLE, ST_OMP_THREADPRIVATE, ST_OMP_WORKSHARE): New + statement codes. + (OMP_LIST_PRIVATE, OMP_LIST_FIRSTPRIVATE, OMP_LIST_LASTPRIVATE, + OMP_LIST_COPYPRIVATE, OMP_LIST_SHARED, OMP_LIST_COPYIN, + OMP_LIST_PLUS, OMP_LIST_REDUCTION_FIRST, OMP_LIST_MULT, + OMP_LIST_SUB, OMP_LIST_AND, OMP_LIST_OR, OMP_LIST_EQV, + OMP_LIST_NEQV, OMP_LIST_MAX, OMP_LIST_MIN, OMP_LIST_IAND, + OMP_LIST_IOR, OMP_LIST_IEOR, OMP_LIST_REDUCTION_LAST, OMP_LIST_NUM): + New OpenMP variable list types. + (gfc_omp_clauses): New typedef. + (gfc_get_omp_clauses): Define. + (EXEC_OMP_CRITICAL, EXEC_OMP_DO, EXEC_OMP_FLUSH, EXEC_OMP_MASTER, + EXEC_OMP_ORDERED, EXEC_OMP_PARALLEL, EXEC_OMP_PARALLEL_DO, + EXEC_OMP_PARALLEL_SECTIONS, EXEC_OMP_PARALLEL_WORKSHARE, + EXEC_OMP_SECTIONS, EXEC_OMP_SINGLE, EXEC_OMP_WORKSHARE, + EXEC_OMP_ATOMIC, EXEC_OMP_BARRIER, EXEC_OMP_END_NOWAIT, + EXEC_OMP_END_SINGLE): New OpenMP gfc_exec_op codes. + (struct gfc_code): Add omp_clauses, omp_name, omp_namelist + and omp_bool fields to ext union. + (flag_openmp): Declare. + (gfc_free_omp_clauses, gfc_resolve_omp_directive): New prototypes. + * scanner.c (openmp_flag, openmp_locus): New variables. + (skip_free_comments, skip_fixed_comments, gfc_next_char_literal): + Handle OpenMP directive lines and conditional compilation magic + comments. + * parse.h (COMP_OMP_STRUCTURED_BLOCK): New compile state. + * parse.c (decode_omp_directive, parse_omp_do, parse_omp_atomic, + parse_omp_structured_block): New functions. + (next_free, next_fixed): Parse OpenMP directives. + (case_executable, case_exec_markers, case_decl): Add ST_OMP_* + codes. + (gfc_ascii_statement): Handle ST_OMP_* codes. + (parse_executable): Rearrange the loop slightly, so that + parse_omp_do can return next_statement. + * match.h (gfc_match_omp_eos, gfc_match_omp_atomic, + gfc_match_omp_barrier, gfc_match_omp_critical, gfc_match_omp_do, + gfc_match_omp_flush, gfc_match_omp_master, gfc_match_omp_ordered, + gfc_match_omp_parallel, gfc_match_omp_parallel_do, + gfc_match_omp_parallel_sections, gfc_match_omp_parallel_workshare, + gfc_match_omp_sections, gfc_match_omp_single, + gfc_match_omp_threadprivate, gfc_match_omp_workshare, + gfc_match_omp_end_nowait, gfc_match_omp_end_single): New prototypes. + * resolve.c (resolve_blocks): Ignore EXEC_OMP_* block directives. + (resolve_code): Call gfc_resolve_omp_directive on EXEC_OMP_* + directives. + * trans.c (gfc_trans_code): Call gfc_trans_omp_directive for + EXEC_OMP_* directives. + * st.c (gfc_free_statement): Handle EXEC_OMP_* statement freeing. + * trans-stmt.h (gfc_trans_omp_directive): New prototype. + * openmp.c: New file. + * trans-openmp.c: New file. + 2006-02-13 Andrew Pinski Jakub Jelinek diff --git a/gcc/fortran/Make-lang.in b/gcc/fortran/Make-lang.in index c7fa78f0303..74af449756c 100644 --- a/gcc/fortran/Make-lang.in +++ b/gcc/fortran/Make-lang.in @@ -1,6 +1,6 @@ # -*- makefile -*- # Top level makefile fragment for GNU gfortran, the GNU Fortran 95 compiler. -# Copyright (C) 2002, 2003, 2004, 2005 Free Software Foundation, Inc. +# Copyright (C) 2002, 2003, 2004, 2005, 2006 Free Software Foundation, Inc. # Contributed by Paul Brook @@ -65,15 +65,16 @@ F95_PARSER_OBJS = fortran/arith.o fortran/array.o fortran/bbt.o \ fortran/error.o fortran/expr.o fortran/interface.o \ fortran/intrinsic.o fortran/io.o fortran/iresolve.o \ fortran/match.o fortran/matchexp.o fortran/misc.o fortran/module.o \ - fortran/options.o fortran/parse.o fortran/primary.o fortran/resolve.o \ - fortran/scanner.o fortran/simplify.o fortran/st.o fortran/symbol.o + fortran/openmp.o fortran/options.o fortran/parse.o fortran/primary.o \ + fortran/resolve.o fortran/scanner.o fortran/simplify.o fortran/st.o \ + fortran/symbol.o F95_OBJS = $(F95_PARSER_OBJS) \ fortran/convert.o fortran/dependency.o fortran/f95-lang.o \ fortran/trans.o fortran/trans-array.o fortran/trans-common.o \ fortran/trans-const.o fortran/trans-decl.o fortran/trans-expr.o \ - fortran/trans-intrinsic.o fortran/trans-io.o fortran/trans-stmt.o \ - fortran/trans-types.o + fortran/trans-intrinsic.o fortran/trans-io.o fortran/trans-openmp.o \ + fortran/trans-stmt.o fortran/trans-types.o # GFORTRAN uses GMP for its internal arithmetics. F95_LIBS = $(GMPLIBS) $(LIBS) @@ -261,6 +262,7 @@ $(F95_PARSER_OBJS): fortran/gfortran.h fortran/intrinsic.h fortran/match.h \ $(CONFIG_H) $(SYSTEM_H) $(TM_H) $(TM_P_H) coretypes.h \ $(RTL_H) $(TREE_H) $(TREE_DUMP_H) $(GGC_H) $(EXPR_H) \ flags.h output.h diagnostic.h errors.h function.h +fortran/openmp.o: pointer-set.h $(TARGET_H) toplev.h GFORTRAN_TRANS_DEPS = fortran/gfortran.h fortran/intrinsic.h fortran/trans-array.h \ fortran/trans-const.h fortran/trans-const.h fortran/trans.h \ @@ -268,24 +270,26 @@ GFORTRAN_TRANS_DEPS = fortran/gfortran.h fortran/intrinsic.h fortran/trans-array $(CONFIG_H) $(SYSTEM_H) $(TREE_H) $(TM_H) coretypes.h $(GGC_H) fortran/f95-lang.o: $(GFORTRAN_TRANS_DEPS) fortran/mathbuiltins.def \ - gt-fortran-f95-lang.h gtype-fortran.h cgraph.h $(TARGET_H) + gt-fortran-f95-lang.h gtype-fortran.h cgraph.h $(TARGET_H) \ + $(BUILTINS_DEF) fortran/types.def fortran/scanner.o: toplev.h fortran/convert.o: $(GFORTRAN_TRANS_DEPS) fortran/trans.o: $(GFORTRAN_TRANS_DEPS) fortran/trans-decl.o: $(GFORTRAN_TRANS_DEPS) gt-fortran-trans-decl.h \ - cgraph.h $(TARGET_H) function.h $(FLAGS_H) tree-gimple.h \ + cgraph.h $(TARGET_H) function.h $(FLAGS_H) $(RTL_H) tree-gimple.h \ tree-dump.h fortran/trans-types.o: $(GFORTRAN_TRANS_DEPS) gt-fortran-trans-types.h \ real.h toplev.h $(TARGET_H) fortran/trans-const.o: $(GFORTRAN_TRANS_DEPS) fortran/trans-expr.o: $(GFORTRAN_TRANS_DEPS) fortran/dependency.h fortran/trans-stmt.o: $(GFORTRAN_TRANS_DEPS) fortran/dependency.h +fortran/trans-openmp.o: $(GFORTRAN_TRANS_DEPS) fortran/trans-io.o: $(GFORTRAN_TRANS_DEPS) gt-fortran-trans-io.h \ fortran/ioparm.def fortran/trans-array.o: $(GFORTRAN_TRANS_DEPS) fortran/trans-intrinsic.o: $(GFORTRAN_TRANS_DEPS) fortran/mathbuiltins.def \ gt-fortran-trans-intrinsic.h fortran/dependency.o: $(GFORTRAN_TRANS_DEPS) fortran/dependency.h -fortran/trans-common.o: $(GFORTRAN_TRANS_DEPS) +fortran/trans-common.o: $(GFORTRAN_TRANS_DEPS) $(TARGET_H) $(RTL_H) fortran/resolve.o: fortran/dependency.h diff --git a/gcc/fortran/dump-parse-tree.c b/gcc/fortran/dump-parse-tree.c index 644729c2f17..06322d42771 100644 --- a/gcc/fortran/dump-parse-tree.c +++ b/gcc/fortran/dump-parse-tree.c @@ -547,6 +547,8 @@ gfc_show_attr (symbol_attribute * attr) gfc_status (" POINTER"); if (attr->save) gfc_status (" SAVE"); + if (attr->threadprivate) + gfc_status (" THREADPRIVATE"); if (attr->target) gfc_status (" TARGET"); if (attr->dummy) @@ -786,6 +788,202 @@ gfc_show_code (int level, gfc_code * c) gfc_show_code_node (level, c); } +static void +gfc_show_namelist (gfc_namelist *n) +{ + for (; n->next; n = n->next) + gfc_status ("%s,", n->sym->name); + gfc_status ("%s", n->sym->name); +} + +/* Show a single OpenMP directive node and everything underneath it + if necessary. */ + +static void +gfc_show_omp_node (int level, gfc_code * c) +{ + gfc_omp_clauses *omp_clauses = NULL; + const char *name = NULL; + + switch (c->op) + { + case EXEC_OMP_ATOMIC: name = "ATOMIC"; break; + case EXEC_OMP_BARRIER: name = "BARRIER"; break; + case EXEC_OMP_CRITICAL: name = "CRITICAL"; break; + case EXEC_OMP_FLUSH: name = "FLUSH"; break; + case EXEC_OMP_DO: name = "DO"; break; + case EXEC_OMP_MASTER: name = "MASTER"; break; + case EXEC_OMP_ORDERED: name = "ORDERED"; break; + case EXEC_OMP_PARALLEL: name = "PARALLEL"; break; + case EXEC_OMP_PARALLEL_DO: name = "PARALLEL DO"; break; + case EXEC_OMP_PARALLEL_SECTIONS: name = "PARALLEL SECTIONS"; break; + case EXEC_OMP_PARALLEL_WORKSHARE: name = "PARALLEL WORKSHARE"; break; + case EXEC_OMP_SECTIONS: name = "SECTIONS"; break; + case EXEC_OMP_SINGLE: name = "SINGLE"; break; + case EXEC_OMP_WORKSHARE: name = "WORKSHARE"; break; + default: + gcc_unreachable (); + } + gfc_status ("!$OMP %s", name); + switch (c->op) + { + case EXEC_OMP_DO: + case EXEC_OMP_PARALLEL: + case EXEC_OMP_PARALLEL_DO: + case EXEC_OMP_PARALLEL_SECTIONS: + case EXEC_OMP_SECTIONS: + case EXEC_OMP_SINGLE: + case EXEC_OMP_WORKSHARE: + case EXEC_OMP_PARALLEL_WORKSHARE: + omp_clauses = c->ext.omp_clauses; + break; + case EXEC_OMP_CRITICAL: + if (c->ext.omp_name) + gfc_status (" (%s)", c->ext.omp_name); + break; + case EXEC_OMP_FLUSH: + if (c->ext.omp_namelist) + { + gfc_status (" ("); + gfc_show_namelist (c->ext.omp_namelist); + gfc_status_char (')'); + } + return; + case EXEC_OMP_BARRIER: + return; + default: + break; + } + if (omp_clauses) + { + int list_type; + + if (omp_clauses->if_expr) + { + gfc_status (" IF("); + gfc_show_expr (omp_clauses->if_expr); + gfc_status_char (')'); + } + if (omp_clauses->num_threads) + { + gfc_status (" NUM_THREADS("); + gfc_show_expr (omp_clauses->num_threads); + gfc_status_char (')'); + } + if (omp_clauses->sched_kind != OMP_SCHED_NONE) + { + const char *type; + switch (omp_clauses->sched_kind) + { + case OMP_SCHED_STATIC: type = "STATIC"; break; + case OMP_SCHED_DYNAMIC: type = "DYNAMIC"; break; + case OMP_SCHED_GUIDED: type = "GUIDED"; break; + case OMP_SCHED_RUNTIME: type = "RUNTIME"; break; + default: + gcc_unreachable (); + } + gfc_status (" SCHEDULE (%s", type); + if (omp_clauses->chunk_size) + { + gfc_status_char (','); + gfc_show_expr (omp_clauses->chunk_size); + } + gfc_status_char (')'); + } + if (omp_clauses->default_sharing != OMP_DEFAULT_UNKNOWN) + { + const char *type; + switch (omp_clauses->default_sharing) + { + case OMP_DEFAULT_NONE: type = "NONE"; break; + case OMP_DEFAULT_PRIVATE: type = "PRIVATE"; break; + case OMP_DEFAULT_SHARED: type = "SHARED"; break; + case OMP_SCHED_RUNTIME: type = "RUNTIME"; break; + default: + gcc_unreachable (); + } + gfc_status (" DEFAULT(%s)", type); + } + if (omp_clauses->ordered) + gfc_status (" ORDERED"); + for (list_type = 0; list_type < OMP_LIST_NUM; list_type++) + if (omp_clauses->lists[list_type] != NULL + && list_type != OMP_LIST_COPYPRIVATE) + { + const char *type; + if (list_type >= OMP_LIST_REDUCTION_FIRST) + { + switch (list_type) + { + case OMP_LIST_PLUS: type = "+"; break; + case OMP_LIST_MULT: type = "*"; break; + case OMP_LIST_SUB: type = "-"; break; + case OMP_LIST_AND: type = ".AND."; break; + case OMP_LIST_OR: type = ".OR."; break; + case OMP_LIST_EQV: type = ".EQV."; break; + case OMP_LIST_NEQV: type = ".NEQV."; break; + case OMP_LIST_MAX: type = "MAX"; break; + case OMP_LIST_MIN: type = "MIN"; break; + case OMP_LIST_IAND: type = "IAND"; break; + case OMP_LIST_IOR: type = "IOR"; break; + case OMP_LIST_IEOR: type = "IEOR"; break; + default: + gcc_unreachable (); + } + gfc_status (" REDUCTION(%s:", type); + } + else + { + switch (list_type) + { + case OMP_LIST_PRIVATE: type = "PRIVATE"; break; + case OMP_LIST_FIRSTPRIVATE: type = "FIRSTPRIVATE"; break; + case OMP_LIST_LASTPRIVATE: type = "LASTPRIVATE"; break; + case OMP_LIST_SHARED: type = "SHARED"; break; + case OMP_LIST_COPYIN: type = "COPYIN"; break; + default: + gcc_unreachable (); + } + gfc_status (" %s(", type); + } + gfc_show_namelist (omp_clauses->lists[list_type]); + gfc_status_char (')'); + } + } + gfc_status_char ('\n'); + if (c->op == EXEC_OMP_SECTIONS || c->op == EXEC_OMP_PARALLEL_SECTIONS) + { + gfc_code *d = c->block; + while (d != NULL) + { + gfc_show_code (level + 1, d->next); + if (d->block == NULL) + break; + code_indent (level, 0); + gfc_status ("!$OMP SECTION\n"); + d = d->block; + } + } + else + gfc_show_code (level + 1, c->block->next); + if (c->op == EXEC_OMP_ATOMIC) + return; + code_indent (level, 0); + gfc_status ("!$OMP END %s", name); + if (omp_clauses != NULL) + { + if (omp_clauses->lists[OMP_LIST_COPYPRIVATE]) + { + gfc_status (" COPYPRIVATE("); + gfc_show_namelist (omp_clauses->lists[OMP_LIST_COPYPRIVATE]); + gfc_status_char (')'); + } + else if (omp_clauses->nowait) + gfc_status (" NOWAIT"); + } + else if (c->op == EXEC_OMP_CRITICAL && c->ext.omp_name) + gfc_status (" (%s)", c->ext.omp_name); +} /* Show a single code node and everything underneath it if necessary. */ @@ -1448,6 +1646,23 @@ gfc_show_code_node (int level, gfc_code * c) gfc_status (" EOR=%d", dt->eor->value); break; + case EXEC_OMP_ATOMIC: + case EXEC_OMP_BARRIER: + case EXEC_OMP_CRITICAL: + case EXEC_OMP_FLUSH: + case EXEC_OMP_DO: + case EXEC_OMP_MASTER: + case EXEC_OMP_ORDERED: + case EXEC_OMP_PARALLEL: + case EXEC_OMP_PARALLEL_DO: + case EXEC_OMP_PARALLEL_SECTIONS: + case EXEC_OMP_PARALLEL_WORKSHARE: + case EXEC_OMP_SECTIONS: + case EXEC_OMP_SINGLE: + case EXEC_OMP_WORKSHARE: + gfc_show_omp_node (level, c); + break; + default: gfc_internal_error ("gfc_show_code_node(): Bad statement code"); } diff --git a/gcc/fortran/f95-lang.c b/gcc/fortran/f95-lang.c index a5d11615646..6722117dd1b 100644 --- a/gcc/fortran/f95-lang.c +++ b/gcc/fortran/f95-lang.c @@ -1,6 +1,6 @@ /* gfortran backend interface - Copyright (C) 2000, 2001, 2002, 2003, 2004, 2005 Free Software Foundation, - Inc. + Copyright (C) 2000, 2001, 2002, 2003, 2004, 2005, 2006 + Free Software Foundation, Inc. Contributed by Paul Brook. This file is part of GCC. @@ -116,6 +116,11 @@ static void gfc_expand_function (tree); #undef LANG_HOOKS_SIGNED_OR_UNSIGNED_TYPE #undef LANG_HOOKS_CALLGRAPH_EXPAND_FUNCTION #undef LANG_HOOKS_CLEAR_BINDING_STACK +#undef LANG_HOOKS_OMP_PRIVATIZE_BY_REFERENCE +#undef LANG_HOOKS_OMP_PREDETERMINED_SHARING +#undef LANG_HOOKS_OMP_DISREGARD_VALUE_EXPR +#undef LANG_HOOKS_OMP_PRIVATE_DEBUG_CLAUSE +#undef LANG_HOOKS_OMP_FIRSTPRIVATIZE_TYPE_SIZES /* Define lang hooks. */ #define LANG_HOOKS_NAME "GNU F95" @@ -134,6 +139,12 @@ static void gfc_expand_function (tree); #define LANG_HOOKS_SIGNED_OR_UNSIGNED_TYPE gfc_signed_or_unsigned_type #define LANG_HOOKS_CALLGRAPH_EXPAND_FUNCTION gfc_expand_function #define LANG_HOOKS_CLEAR_BINDING_STACK gfc_clear_binding_stack +#define LANG_HOOKS_OMP_PRIVATIZE_BY_REFERENCE gfc_omp_privatize_by_reference +#define LANG_HOOKS_OMP_PREDETERMINED_SHARING gfc_omp_predetermined_sharing +#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_FIRSTPRIVATIZE_TYPE_SIZES \ + gfc_omp_firstprivatize_type_sizes const struct lang_hooks lang_hooks = LANG_HOOKS_INITIALIZER; @@ -784,12 +795,53 @@ build_builtin_fntypes (tree * fntype, tree type) fntype[2] = build_function_type (type, tmp); } +static tree +builtin_type_for_size (int size, bool unsignedp) +{ + tree type = lang_hooks.types.type_for_size (size, unsignedp); + return type ? type : error_mark_node; +} /* Initialization of builtin function nodes. */ static void gfc_init_builtin_functions (void) { + enum builtin_type + { +#define DEF_PRIMITIVE_TYPE(NAME, VALUE) NAME, +#define DEF_FUNCTION_TYPE_0(NAME, RETURN) NAME, +#define DEF_FUNCTION_TYPE_1(NAME, RETURN, ARG1) NAME, +#define DEF_FUNCTION_TYPE_2(NAME, RETURN, ARG1, ARG2) NAME, +#define DEF_FUNCTION_TYPE_3(NAME, RETURN, ARG1, ARG2, ARG3) NAME, +#define DEF_FUNCTION_TYPE_4(NAME, RETURN, ARG1, ARG2, ARG3, ARG4) NAME, +#define DEF_FUNCTION_TYPE_5(NAME, RETURN, ARG1, ARG2, ARG3, ARG4, ARG5) NAME, +#define DEF_FUNCTION_TYPE_6(NAME, RETURN, ARG1, ARG2, ARG3, ARG4, ARG5, ARG6) NAME, +#define DEF_FUNCTION_TYPE_7(NAME, RETURN, ARG1, ARG2, ARG3, ARG4, ARG5, ARG6, ARG7) NAME, +#define DEF_FUNCTION_TYPE_VAR_0(NAME, RETURN) NAME, +#define DEF_POINTER_TYPE(NAME, TYPE) NAME, +#include "types.def" +#undef DEF_PRIMITIVE_TYPE +#undef DEF_FUNCTION_TYPE_0 +#undef DEF_FUNCTION_TYPE_1 +#undef DEF_FUNCTION_TYPE_2 +#undef DEF_FUNCTION_TYPE_3 +#undef DEF_FUNCTION_TYPE_4 +#undef DEF_FUNCTION_TYPE_5 +#undef DEF_FUNCTION_TYPE_6 +#undef DEF_FUNCTION_TYPE_7 +#undef DEF_FUNCTION_TYPE_VAR_0 +#undef DEF_POINTER_TYPE + BT_LAST + }; + typedef enum builtin_type builtin_type; + enum + { + /* So far we need just these 2 attribute types. */ + ATTR_NOTHROW_LIST, + ATTR_CONST_NOTHROW_LIST + }; + tree mfunc_float[3]; tree mfunc_double[3]; tree mfunc_longdouble[3]; @@ -801,6 +853,7 @@ gfc_init_builtin_functions (void) tree func_clongdouble_longdouble; tree ftype; tree tmp; + tree builtin_types[(int) BT_LAST + 1]; build_builtin_fntypes (mfunc_float, float_type_node); build_builtin_fntypes (mfunc_double, double_type_node); @@ -882,6 +935,150 @@ gfc_init_builtin_functions (void) gfc_define_builtin ("__builtin_expect", ftype, BUILT_IN_EXPECT, "__builtin_expect", true); +#define DEF_PRIMITIVE_TYPE(ENUM, VALUE) \ + builtin_types[(int) ENUM] = VALUE; +#define DEF_FUNCTION_TYPE_0(ENUM, RETURN) \ + builtin_types[(int) ENUM] \ + = build_function_type (builtin_types[(int) RETURN], \ + void_list_node); +#define DEF_FUNCTION_TYPE_1(ENUM, RETURN, ARG1) \ + builtin_types[(int) ENUM] \ + = build_function_type (builtin_types[(int) RETURN], \ + tree_cons (NULL_TREE, \ + builtin_types[(int) ARG1], \ + void_list_node)); +#define DEF_FUNCTION_TYPE_2(ENUM, RETURN, ARG1, ARG2) \ + builtin_types[(int) ENUM] \ + = build_function_type \ + (builtin_types[(int) RETURN], \ + tree_cons (NULL_TREE, \ + builtin_types[(int) ARG1], \ + tree_cons (NULL_TREE, \ + builtin_types[(int) ARG2], \ + void_list_node))); +#define DEF_FUNCTION_TYPE_3(ENUM, RETURN, ARG1, ARG2, ARG3) \ + builtin_types[(int) ENUM] \ + = build_function_type \ + (builtin_types[(int) RETURN], \ + tree_cons (NULL_TREE, \ + builtin_types[(int) ARG1], \ + tree_cons (NULL_TREE, \ + builtin_types[(int) ARG2], \ + tree_cons (NULL_TREE, \ + builtin_types[(int) ARG3], \ + void_list_node)))); +#define DEF_FUNCTION_TYPE_4(ENUM, RETURN, ARG1, ARG2, ARG3, ARG4) \ + builtin_types[(int) ENUM] \ + = build_function_type \ + (builtin_types[(int) RETURN], \ + tree_cons (NULL_TREE, \ + builtin_types[(int) ARG1], \ + tree_cons (NULL_TREE, \ + builtin_types[(int) ARG2], \ + tree_cons \ + (NULL_TREE, \ + builtin_types[(int) ARG3], \ + tree_cons (NULL_TREE, \ + builtin_types[(int) ARG4], \ + void_list_node))))); +#define DEF_FUNCTION_TYPE_5(ENUM, RETURN, ARG1, ARG2, ARG3, ARG4, ARG5) \ + builtin_types[(int) ENUM] \ + = build_function_type \ + (builtin_types[(int) RETURN], \ + tree_cons (NULL_TREE, \ + builtin_types[(int) ARG1], \ + tree_cons (NULL_TREE, \ + builtin_types[(int) ARG2], \ + tree_cons \ + (NULL_TREE, \ + builtin_types[(int) ARG3], \ + tree_cons (NULL_TREE, \ + builtin_types[(int) ARG4], \ + tree_cons (NULL_TREE, \ + builtin_types[(int) ARG5],\ + void_list_node)))))); +#define DEF_FUNCTION_TYPE_6(ENUM, RETURN, ARG1, ARG2, ARG3, ARG4, ARG5, \ + ARG6) \ + builtin_types[(int) ENUM] \ + = build_function_type \ + (builtin_types[(int) RETURN], \ + tree_cons (NULL_TREE, \ + builtin_types[(int) ARG1], \ + tree_cons (NULL_TREE, \ + builtin_types[(int) ARG2], \ + tree_cons \ + (NULL_TREE, \ + builtin_types[(int) ARG3], \ + tree_cons \ + (NULL_TREE, \ + builtin_types[(int) ARG4], \ + tree_cons (NULL_TREE, \ + builtin_types[(int) ARG5], \ + tree_cons (NULL_TREE, \ + builtin_types[(int) ARG6],\ + void_list_node))))))); +#define DEF_FUNCTION_TYPE_7(ENUM, RETURN, ARG1, ARG2, ARG3, ARG4, ARG5, \ + ARG6, ARG7) \ + builtin_types[(int) ENUM] \ + = build_function_type \ + (builtin_types[(int) RETURN], \ + tree_cons (NULL_TREE, \ + builtin_types[(int) ARG1], \ + tree_cons (NULL_TREE, \ + builtin_types[(int) ARG2], \ + tree_cons \ + (NULL_TREE, \ + builtin_types[(int) ARG3], \ + tree_cons \ + (NULL_TREE, \ + builtin_types[(int) ARG4], \ + tree_cons (NULL_TREE, \ + builtin_types[(int) ARG5], \ + tree_cons (NULL_TREE, \ + builtin_types[(int) ARG6],\ + tree_cons (NULL_TREE, \ + builtin_types[(int) ARG6], \ + void_list_node)))))))); +#define DEF_FUNCTION_TYPE_VAR_0(ENUM, RETURN) \ + builtin_types[(int) ENUM] \ + = build_function_type (builtin_types[(int) RETURN], NULL_TREE); +#define DEF_POINTER_TYPE(ENUM, TYPE) \ + builtin_types[(int) ENUM] \ + = build_pointer_type (builtin_types[(int) TYPE]); +#include "types.def" +#undef DEF_PRIMITIVE_TYPE +#undef DEF_FUNCTION_TYPE_1 +#undef DEF_FUNCTION_TYPE_2 +#undef DEF_FUNCTION_TYPE_3 +#undef DEF_FUNCTION_TYPE_4 +#undef DEF_FUNCTION_TYPE_5 +#undef DEF_FUNCTION_TYPE_6 +#undef DEF_FUNCTION_TYPE_VAR_0 +#undef DEF_POINTER_TYPE + builtin_types[(int) BT_LAST] = NULL_TREE; + + /* Initialize synchronization builtins. */ +#undef DEF_SYNC_BUILTIN +#define DEF_SYNC_BUILTIN(code, name, type, attr) \ + gfc_define_builtin (name, builtin_types[type], code, name, \ + attr == ATTR_CONST_NOTHROW_LIST); +#include "../sync-builtins.def" +#undef DEF_SYNC_BUILTIN + + if (gfc_option.flag_openmp) + { +#undef DEF_GOMP_BUILTIN +#define DEF_GOMP_BUILTIN(code, name, type, attr) \ + gfc_define_builtin ("__builtin_" name, builtin_types[type], \ + code, name, attr == ATTR_CONST_NOTHROW_LIST); +#include "../omp-builtins.def" +#undef DEF_GOMP_BUILTIN + } + + gfc_define_builtin ("__builtin_trap", builtin_types[BT_FN_VOID], + BUILT_IN_TRAP, NULL, false); + TREE_THIS_VOLATILE (built_in_decls[BUILT_IN_TRAP]) = 1; + build_common_builtin_nodes (); targetm.init_builtins (); } diff --git a/gcc/fortran/gfortran.h b/gcc/fortran/gfortran.h index 46141b6184a..16f0a127051 100644 --- a/gcc/fortran/gfortran.h +++ b/gcc/fortran/gfortran.h @@ -220,7 +220,16 @@ typedef enum ST_STOP, ST_SUBROUTINE, ST_TYPE, ST_USE, ST_WHERE_BLOCK, ST_WHERE, ST_WRITE, ST_ASSIGNMENT, ST_POINTER_ASSIGNMENT, ST_SELECT_CASE, ST_SEQUENCE, ST_SIMPLE_IF, ST_STATEMENT_FUNCTION, ST_DERIVED_DECL, ST_LABEL_ASSIGNMENT, - ST_ENUM, ST_ENUMERATOR, ST_END_ENUM, ST_NONE + ST_ENUM, ST_ENUMERATOR, ST_END_ENUM, + ST_OMP_ATOMIC, ST_OMP_BARRIER, ST_OMP_CRITICAL, ST_OMP_END_CRITICAL, + ST_OMP_END_DO, ST_OMP_END_MASTER, ST_OMP_END_ORDERED, ST_OMP_END_PARALLEL, + ST_OMP_END_PARALLEL_DO, ST_OMP_END_PARALLEL_SECTIONS, + ST_OMP_END_PARALLEL_WORKSHARE, ST_OMP_END_SECTIONS, ST_OMP_END_SINGLE, + ST_OMP_END_WORKSHARE, ST_OMP_DO, ST_OMP_FLUSH, ST_OMP_MASTER, ST_OMP_ORDERED, + ST_OMP_PARALLEL, ST_OMP_PARALLEL_DO, ST_OMP_PARALLEL_SECTIONS, + ST_OMP_PARALLEL_WORKSHARE, ST_OMP_SECTIONS, ST_OMP_SECTION, ST_OMP_SINGLE, + ST_OMP_THREADPRIVATE, ST_OMP_WORKSHARE, + ST_NONE } gfc_statement; @@ -451,7 +460,7 @@ typedef struct /* Variable attributes. */ unsigned allocatable:1, dimension:1, external:1, intrinsic:1, optional:1, pointer:1, save:1, target:1, - dummy:1, result:1, assign:1; + dummy:1, result:1, assign:1, threadprivate:1; unsigned data:1, /* Symbol is named in a DATA statement. */ use_assoc:1; /* Symbol has been use-associated. */ @@ -678,6 +687,60 @@ gfc_namelist; #define gfc_get_namelist() gfc_getmem(sizeof(gfc_namelist)) +enum +{ + OMP_LIST_PRIVATE, + OMP_LIST_FIRSTPRIVATE, + OMP_LIST_LASTPRIVATE, + OMP_LIST_COPYPRIVATE, + OMP_LIST_SHARED, + OMP_LIST_COPYIN, + OMP_LIST_PLUS, + OMP_LIST_REDUCTION_FIRST = OMP_LIST_PLUS, + OMP_LIST_MULT, + OMP_LIST_SUB, + OMP_LIST_AND, + OMP_LIST_OR, + OMP_LIST_EQV, + OMP_LIST_NEQV, + OMP_LIST_MAX, + OMP_LIST_MIN, + OMP_LIST_IAND, + OMP_LIST_IOR, + OMP_LIST_IEOR, + OMP_LIST_REDUCTION_LAST = OMP_LIST_IEOR, + OMP_LIST_NUM +}; + +/* Because a symbol can belong to multiple namelists, they must be + linked externally to the symbol itself. */ +typedef struct gfc_omp_clauses +{ + struct gfc_expr *if_expr; + struct gfc_expr *num_threads; + gfc_namelist *lists[OMP_LIST_NUM]; + enum + { + OMP_SCHED_NONE, + OMP_SCHED_STATIC, + OMP_SCHED_DYNAMIC, + OMP_SCHED_GUIDED, + OMP_SCHED_RUNTIME + } sched_kind; + struct gfc_expr *chunk_size; + enum + { + OMP_DEFAULT_UNKNOWN, + OMP_DEFAULT_NONE, + OMP_DEFAULT_PRIVATE, + OMP_DEFAULT_SHARED + } default_sharing; + bool nowait, ordered; +} +gfc_omp_clauses; + +#define gfc_get_omp_clauses() gfc_getmem(sizeof(gfc_omp_clauses)) + /* The gfc_st_label structure is a doubly linked list attached to a namespace that records the usage of statement labels within that @@ -794,7 +857,7 @@ gfc_symbol; typedef struct gfc_common_head { locus where; - int use_assoc, saved; + char use_assoc, saved, threadprivate; char name[GFC_MAX_SYMBOL_LEN + 1]; struct gfc_symbol *head; } @@ -1402,7 +1465,13 @@ typedef enum EXEC_ALLOCATE, EXEC_DEALLOCATE, EXEC_OPEN, EXEC_CLOSE, EXEC_READ, EXEC_WRITE, EXEC_IOLENGTH, EXEC_TRANSFER, EXEC_DT_END, - EXEC_BACKSPACE, EXEC_ENDFILE, EXEC_INQUIRE, EXEC_REWIND, EXEC_FLUSH + EXEC_BACKSPACE, EXEC_ENDFILE, EXEC_INQUIRE, EXEC_REWIND, EXEC_FLUSH, + EXEC_OMP_CRITICAL, EXEC_OMP_DO, EXEC_OMP_FLUSH, EXEC_OMP_MASTER, + EXEC_OMP_ORDERED, EXEC_OMP_PARALLEL, EXEC_OMP_PARALLEL_DO, + EXEC_OMP_PARALLEL_SECTIONS, EXEC_OMP_PARALLEL_WORKSHARE, + EXEC_OMP_SECTIONS, EXEC_OMP_SINGLE, EXEC_OMP_WORKSHARE, + EXEC_OMP_ATOMIC, EXEC_OMP_BARRIER, EXEC_OMP_END_NOWAIT, + EXEC_OMP_END_SINGLE } gfc_exec_op; @@ -1436,6 +1505,10 @@ typedef struct gfc_code struct gfc_code *whichloop; int stop_code; gfc_entry_list *entry; + gfc_omp_clauses *omp_clauses; + const char *omp_name; + gfc_namelist *omp_namelist; + bool omp_bool; } ext; /* Points to additional structures required by statement */ @@ -1528,6 +1601,7 @@ typedef struct int flag_backslash; int flag_cray_pointer; int flag_d_lines; + int flag_openmp; int q_kind; @@ -1722,6 +1796,7 @@ try gfc_add_cray_pointee (symbol_attribute *, locus *); try gfc_mod_pointee_as (gfc_array_spec *as); try gfc_add_result (symbol_attribute *, const char *, locus *); try gfc_add_save (symbol_attribute *, const char *, locus *); +try gfc_add_threadprivate (symbol_attribute *, const char *, locus *); try gfc_add_saved_common (symbol_attribute *, locus *); try gfc_add_target (symbol_attribute *, locus *); try gfc_add_dummy (symbol_attribute *, const char *, locus *); @@ -1832,6 +1907,13 @@ void gfc_free_equiv (gfc_equiv *); void gfc_free_data (gfc_data *); void gfc_free_case_list (gfc_case *); +/* openmp.c */ +void gfc_free_omp_clauses (gfc_omp_clauses *); +void gfc_resolve_omp_directive (gfc_code *, gfc_namespace *); +void gfc_resolve_do_iterator (gfc_code *, gfc_symbol *); +void gfc_resolve_omp_parallel_blocks (gfc_code *, gfc_namespace *); +void gfc_resolve_omp_do_blocks (gfc_code *, gfc_namespace *); + /* expr.c */ void gfc_free_actual_arglist (gfc_actual_arglist *); gfc_actual_arglist *gfc_copy_actual_arglist (gfc_actual_arglist *); @@ -1880,6 +1962,7 @@ void gfc_free_statements (gfc_code *); /* resolve.c */ try gfc_resolve_expr (gfc_expr *); void gfc_resolve (gfc_namespace *); +void gfc_resolve_blocks (gfc_code *, gfc_namespace *); int gfc_impure_variable (gfc_symbol *); int gfc_pure (gfc_symbol *); int gfc_elemental (gfc_symbol *); diff --git a/gcc/fortran/gfortran.texi b/gcc/fortran/gfortran.texi index 65a2542de6e..908e05aec76 100644 --- a/gcc/fortran/gfortran.texi +++ b/gcc/fortran/gfortran.texi @@ -1,7 +1,7 @@ \input texinfo @c -*-texinfo-*- @c %**start of header @setfilename gfortran.info -@set copyrights-gfortran 1999-2005 +@set copyrights-gfortran 1999-2006 @include gcc-common.texi @@ -492,10 +492,6 @@ Allow setting the default unit number. Option to initialize otherwise uninitialized integer and floating point variables. -@item -Support for OpenMP directives. This also requires support from the runtime -library and the rest of the compiler. - @item Support for Fortran 200x. This includes several new features including floating point exceptions, extended use of allocatable arrays, C @@ -658,6 +654,7 @@ of extensions, and @option{-std=legacy} allows both without warning. * Hollerith constants support:: * Cray pointers:: * CONVERT specifier:: +* OpenMP:: @end menu @node Old-style kind specifications @@ -1049,6 +1046,22 @@ carries a significant speed overhead. If speed in this area matters to you, it is best if you use this only for data that needs to be portable. +@node OpenMP +@section OpenMP +@cindex OpenMP + +gfortran attempts to be OpenMP Application Program Interface v2.5 +compatible when invoked with the @code{-fopenmp} option. gfortran +then generates parallellized code according to the OpenMP directives +used in the source. The OpenMP Fortran runtime library +routines are provided both in a form of Fortran 90 module named +@code{omp_lib} and in a form of a Fortran @code{include} file named +@code{omp_lib.h}. + +For details refer to the actual +@uref{http://www.openmp.org/drupal/mp-documents/spec25.pdf, +OpenMP Application Program Interface v2.5} specification. + @c --------------------------------------------------------------------- @include intrinsic.texi @c --------------------------------------------------------------------- diff --git a/gcc/fortran/invoke.texi b/gcc/fortran/invoke.texi index 8d7a1d52f11..c031cd41a2d 100644 --- a/gcc/fortran/invoke.texi +++ b/gcc/fortran/invoke.texi @@ -1,11 +1,11 @@ -@c Copyright (C) 2004, 2005 +@c Copyright (C) 2004, 2005, 2006 @c Free Software Foundation, Inc. @c This is part of the GFORTRAN manual. @c For copying conditions, see the file gfortran.texi. @ignore @c man begin COPYRIGHT -Copyright @copyright{} 2004, 2005 +Copyright @copyright{} 2004, 2005, 2006 Free Software Foundation, Inc. Permission is granted to copy, distribute and/or modify this document @@ -122,7 +122,7 @@ by type. Explanations are in the following sections. -ffixed-line-length-@var{n} -ffixed-line-length-none @gol -ffree-line-length-@var{n} -ffree-line-length-none @gol -fdefault-double-8 -fdefault-integer-8 -fdefault-real-8 @gol --fcray-pointer } +-fcray-pointer -fopenmp } @item Warning Options @xref{Warning Options,,Options to Request or Suppress Warnings}. @@ -291,6 +291,16 @@ Specify that no implicit typing is allowed, unless overridden by explicit @item -fcray-pointer Enables the Cray pointer extension, which provides a C-like pointer. +@cindex -fopenmp +@cindex options, -fopenmp +@item -fopenmp +Enables handling of OpenMP @code{!$omp} directives in free form +and @code{c$omp}, @code{*$omp} and @code{!$omp} directives in fixed form, +enables @code{!$} conditional compilation sentinels in free form +and @code{c$}, @code{*$} and @code{!$} sentinels in fixed form +and when linking arranges for the OpenMP runtime library to be linked +in. + @cindex -std=@var{std} option @cindex option, -std=@var{std} @item -std=@var{std} diff --git a/gcc/fortran/lang.opt b/gcc/fortran/lang.opt index 5ce2934f590..17522040272 100644 --- a/gcc/fortran/lang.opt +++ b/gcc/fortran/lang.opt @@ -117,6 +117,10 @@ ffree-form Fortran RejectNegative Assume that the source file is free form +fopenmp +Fortran +Enable OpenMP + funderscoring Fortran Append underscores to externally visible names diff --git a/gcc/fortran/match.c b/gcc/fortran/match.c index a78cd028ea4..a2b9c41d549 100644 --- a/gcc/fortran/match.c +++ b/gcc/fortran/match.c @@ -1341,7 +1341,7 @@ cleanup: static match match_exit_cycle (gfc_statement st, gfc_exec_op op) { - gfc_state_data *p; + gfc_state_data *p, *o; gfc_symbol *sym; match m; @@ -1368,9 +1368,11 @@ match_exit_cycle (gfc_statement st, gfc_exec_op op) /* Find the loop mentioned specified by the label (or lack of a label). */ - for (p = gfc_state_stack; p; p = p->previous) + for (o = NULL, p = gfc_state_stack; p; p = p->previous) if (p->state == COMP_DO && (sym == NULL || sym == p->sym)) break; + else if (o == NULL && p->state == COMP_OMP_STRUCTURED_BLOCK) + o = p; if (p == NULL) { @@ -1384,6 +1386,25 @@ match_exit_cycle (gfc_statement st, gfc_exec_op op) return MATCH_ERROR; } + if (o != NULL) + { + gfc_error ("%s statement at %C leaving OpenMP structured block", + gfc_ascii_statement (st)); + return MATCH_ERROR; + } + else if (st == ST_EXIT + && p->previous != NULL + && p->previous->state == COMP_OMP_STRUCTURED_BLOCK + && (p->previous->head->op == EXEC_OMP_DO + || p->previous->head->op == EXEC_OMP_PARALLEL_DO)) + { + gcc_assert (p->previous->head->next != NULL); + gcc_assert (p->previous->head->next->op == EXEC_DO + || p->previous->head->next->op == EXEC_DO_WHILE); + gfc_error ("EXIT statement at %C terminating !$OMP DO loop"); + return MATCH_ERROR; + } + /* Save the first statement in the loop - needed by the backend. */ new_st.ext.whichloop = p->head; diff --git a/gcc/fortran/match.h b/gcc/fortran/match.h index 1c5115e0b45..19340cee0f1 100644 --- a/gcc/fortran/match.h +++ b/gcc/fortran/match.h @@ -90,6 +90,28 @@ match gfc_match_forall (gfc_statement *); gfc_common_head *gfc_get_common (const char *, int); +/* openmp.c */ + +/* OpenMP directive matchers */ +match gfc_match_omp_eos (void); +match gfc_match_omp_atomic (void); +match gfc_match_omp_barrier (void); +match gfc_match_omp_critical (void); +match gfc_match_omp_do (void); +match gfc_match_omp_flush (void); +match gfc_match_omp_master (void); +match gfc_match_omp_ordered (void); +match gfc_match_omp_parallel (void); +match gfc_match_omp_parallel_do (void); +match gfc_match_omp_parallel_sections (void); +match gfc_match_omp_parallel_workshare (void); +match gfc_match_omp_sections (void); +match gfc_match_omp_single (void); +match gfc_match_omp_threadprivate (void); +match gfc_match_omp_workshare (void); +match gfc_match_omp_end_nowait (void); +match gfc_match_omp_end_single (void); + /* decl.c */ match gfc_match_data (void); diff --git a/gcc/fortran/module.c b/gcc/fortran/module.c index c32fe0bbd03..3c45e57cff1 100644 --- a/gcc/fortran/module.c +++ b/gcc/fortran/module.c @@ -1432,7 +1432,7 @@ typedef enum AB_DATA, AB_IN_NAMELIST, AB_IN_COMMON, AB_FUNCTION, AB_SUBROUTINE, AB_SEQUENCE, AB_ELEMENTAL, AB_PURE, AB_RECURSIVE, AB_GENERIC, AB_ALWAYS_EXPLICIT, AB_CRAY_POINTER, - AB_CRAY_POINTEE + AB_CRAY_POINTEE, AB_THREADPRIVATE } ab_attribute; @@ -1446,6 +1446,7 @@ static const mstring attr_bits[] = minit ("POINTER", AB_POINTER), minit ("SAVE", AB_SAVE), minit ("TARGET", AB_TARGET), + minit ("THREADPRIVATE", AB_THREADPRIVATE), minit ("DUMMY", AB_DUMMY), minit ("RESULT", AB_RESULT), minit ("DATA", AB_DATA), @@ -1515,6 +1516,8 @@ mio_symbol_attribute (symbol_attribute * attr) MIO_NAME(ab_attribute) (AB_SAVE, attr_bits); if (attr->target) MIO_NAME(ab_attribute) (AB_TARGET, attr_bits); + if (attr->threadprivate) + MIO_NAME(ab_attribute) (AB_THREADPRIVATE, attr_bits); if (attr->dummy) MIO_NAME(ab_attribute) (AB_DUMMY, attr_bits); if (attr->result) @@ -1590,6 +1593,9 @@ mio_symbol_attribute (symbol_attribute * attr) case AB_TARGET: attr->target = 1; break; + case AB_THREADPRIVATE: + attr->threadprivate = 1; + break; case AB_DUMMY: attr->dummy = 1; break; @@ -2982,13 +2988,18 @@ load_commons(void) while (peek_atom () != ATOM_RPAREN) { + int flags; mio_lparen (); mio_internal_string (name); p = gfc_get_common (name, 1); mio_symbol_ref (&p->head); - mio_integer (&p->saved); + mio_integer (&flags); + if (flags & 1) + p->saved = 1; + if (flags & 2) + p->threadprivate = 1; p->use_assoc = 1; mio_rparen(); @@ -3385,6 +3396,7 @@ write_common (gfc_symtree *st) { gfc_common_head *p; const char * name; + int flags; if (st == NULL) return; @@ -3401,7 +3413,9 @@ write_common (gfc_symtree *st) p = st->n.common; mio_symbol_ref(&p->head); - mio_integer(&p->saved); + flags = p->saved ? 1 : 0; + if (p->threadprivate) flags |= 2; + mio_integer(&flags); mio_rparen(); } @@ -3412,6 +3426,7 @@ static void write_blank_common (void) { const char * name = BLANK_COMMON_NAME; + int saved; if (gfc_current_ns->blank_common.head == NULL) return; @@ -3421,7 +3436,8 @@ write_blank_common (void) mio_pool_string(&name); mio_symbol_ref(&gfc_current_ns->blank_common.head); - mio_integer(&gfc_current_ns->blank_common.saved); + saved = gfc_current_ns->blank_common.saved; + mio_integer(&saved); mio_rparen(); } diff --git a/gcc/fortran/openmp.c b/gcc/fortran/openmp.c new file mode 100644 index 00000000000..312d5a1e49a --- /dev/null +++ b/gcc/fortran/openmp.c @@ -0,0 +1,1325 @@ +/* OpenMP directive matching and resolving. + Copyright (C) 2005, 2006 Free Software Foundation, Inc. + Contributed by Jakub Jelinek + +This file is part of GCC. + +GCC is free software; you can redistribute it and/or modify it under +the terms of the GNU General Public License as published by the Free +Software Foundation; either version 2, or (at your option) any later +version. + +GCC is distributed in the hope that it will be useful, but WITHOUT ANY +WARRANTY; without even the implied warranty of MERCHANTABILITY or +FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License +for more details. + +You should have received a copy of the GNU General Public License +along with GCC; see the file COPYING. If not, write to the Free +Software Foundation, 51 Franklin Street, Fifth Floor, Boston, MA +02110-1301, USA. */ + + +#include "config.h" +#include "system.h" +#include "flags.h" +#include "gfortran.h" +#include "match.h" +#include "parse.h" +#include "pointer-set.h" +#include "target.h" +#include "toplev.h" + +/* Match an end of OpenMP directive. End of OpenMP directive is optional + whitespace, followed by '\n' or comment '!'. */ + +match +gfc_match_omp_eos (void) +{ + locus old_loc; + int c; + + old_loc = gfc_current_locus; + gfc_gobble_whitespace (); + + c = gfc_next_char (); + switch (c) + { + case '!': + do + c = gfc_next_char (); + while (c != '\n'); + /* Fall through */ + + case '\n': + return MATCH_YES; + } + + gfc_current_locus = old_loc; + return MATCH_NO; +} + +/* Free an omp_clauses structure. */ + +void +gfc_free_omp_clauses (gfc_omp_clauses *c) +{ + int i; + if (c == NULL) + return; + + gfc_free_expr (c->if_expr); + gfc_free_expr (c->num_threads); + gfc_free_expr (c->chunk_size); + for (i = 0; i < OMP_LIST_NUM; i++) + gfc_free_namelist (c->lists[i]); + gfc_free (c); +} + +/* Match a variable/common block list and construct a namelist from it. */ + +static match +gfc_match_omp_variable_list (const char *str, gfc_namelist **list, + bool allow_common) +{ + gfc_namelist *head, *tail, *p; + locus old_loc; + char n[GFC_MAX_SYMBOL_LEN+1]; + gfc_symbol *sym; + match m; + gfc_symtree *st; + + head = tail = NULL; + + old_loc = gfc_current_locus; + + m = gfc_match (str); + if (m != MATCH_YES) + return m; + + for (;;) + { + m = gfc_match_symbol (&sym, 1); + switch (m) + { + case MATCH_YES: + gfc_set_sym_referenced (sym); + p = gfc_get_namelist (); + if (head == NULL) + head = tail = p; + else + { + tail->next = p; + tail = tail->next; + } + tail->sym = sym; + goto next_item; + case MATCH_NO: + break; + case MATCH_ERROR: + goto cleanup; + } + + if (!allow_common) + goto syntax; + + m = gfc_match (" / %n /", n); + if (m == MATCH_ERROR) + goto cleanup; + if (m == MATCH_NO) + goto syntax; + + st = gfc_find_symtree (gfc_current_ns->common_root, n); + if (st == NULL) + { + gfc_error ("COMMON block /%s/ not found at %C", n); + goto cleanup; + } + for (sym = st->n.common->head; sym; sym = sym->common_next) + { + gfc_set_sym_referenced (sym); + p = gfc_get_namelist (); + if (head == NULL) + head = tail = p; + else + { + tail->next = p; + tail = tail->next; + } + tail->sym = sym; + } + + next_item: + if (gfc_match_char (')') == MATCH_YES) + break; + if (gfc_match_char (',') != MATCH_YES) + goto syntax; + } + + while (*list) + list = &(*list)->next; + + *list = head; + return MATCH_YES; + +syntax: + gfc_error ("Syntax error in OpenMP variable list at %C"); + +cleanup: + gfc_free_namelist (head); + gfc_current_locus = old_loc; + return MATCH_ERROR; +} + +#define OMP_CLAUSE_PRIVATE (1 << 0) +#define OMP_CLAUSE_FIRSTPRIVATE (1 << 1) +#define OMP_CLAUSE_LASTPRIVATE (1 << 2) +#define OMP_CLAUSE_COPYPRIVATE (1 << 3) +#define OMP_CLAUSE_SHARED (1 << 4) +#define OMP_CLAUSE_COPYIN (1 << 5) +#define OMP_CLAUSE_REDUCTION (1 << 6) +#define OMP_CLAUSE_IF (1 << 7) +#define OMP_CLAUSE_NUM_THREADS (1 << 8) +#define OMP_CLAUSE_SCHEDULE (1 << 9) +#define OMP_CLAUSE_DEFAULT (1 << 10) +#define OMP_CLAUSE_ORDERED (1 << 11) + +/* Match OpenMP directive clauses. MASK is a bitmask of + clauses that are allowed for a particular directive. */ + +static match +gfc_match_omp_clauses (gfc_omp_clauses **cp, int mask) +{ + gfc_omp_clauses *c = gfc_get_omp_clauses (); + locus old_loc; + bool needs_space = true, first = true; + + *cp = NULL; + while (1) + { + if ((first || gfc_match_char (',') != MATCH_YES) + && (needs_space && gfc_match_space () != MATCH_YES)) + break; + needs_space = false; + first = false; + gfc_gobble_whitespace (); + if ((mask & OMP_CLAUSE_IF) && c->if_expr == NULL + && gfc_match ("if ( %e )", &c->if_expr) == MATCH_YES) + continue; + if ((mask & OMP_CLAUSE_NUM_THREADS) && c->num_threads == NULL + && gfc_match ("num_threads ( %e )", &c->num_threads) == MATCH_YES) + 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_FIRSTPRIVATE) + && gfc_match_omp_variable_list ("firstprivate (", + &c->lists[OMP_LIST_FIRSTPRIVATE], + true) + == MATCH_YES) + continue; + if ((mask & OMP_CLAUSE_LASTPRIVATE) + && gfc_match_omp_variable_list ("lastprivate (", + &c->lists[OMP_LIST_LASTPRIVATE], + true) + == MATCH_YES) + continue; + if ((mask & OMP_CLAUSE_COPYPRIVATE) + && gfc_match_omp_variable_list ("copyprivate (", + &c->lists[OMP_LIST_COPYPRIVATE], + true) + == MATCH_YES) + continue; + if ((mask & OMP_CLAUSE_SHARED) + && gfc_match_omp_variable_list ("shared (", + &c->lists[OMP_LIST_SHARED], true) + == MATCH_YES) + continue; + if ((mask & OMP_CLAUSE_COPYIN) + && gfc_match_omp_variable_list ("copyin (", + &c->lists[OMP_LIST_COPYIN], true) + == MATCH_YES) + continue; + old_loc = gfc_current_locus; + if ((mask & OMP_CLAUSE_REDUCTION) + && gfc_match ("reduction ( ") == MATCH_YES) + { + int reduction = OMP_LIST_NUM; + char buffer[GFC_MAX_SYMBOL_LEN + 1]; + if (gfc_match_char ('+') == MATCH_YES) + reduction = OMP_LIST_PLUS; + else if (gfc_match_char ('*') == MATCH_YES) + reduction = OMP_LIST_MULT; + else if (gfc_match_char ('-') == MATCH_YES) + reduction = OMP_LIST_SUB; + else if (gfc_match (".and.") == MATCH_YES) + reduction = OMP_LIST_AND; + else if (gfc_match (".or.") == MATCH_YES) + reduction = OMP_LIST_OR; + else if (gfc_match (".eqv.") == MATCH_YES) + reduction = OMP_LIST_EQV; + else if (gfc_match (".neqv.") == MATCH_YES) + reduction = OMP_LIST_NEQV; + else if (gfc_match_name (buffer) == MATCH_YES) + { + gfc_symbol *sym; + const char *n = buffer; + + gfc_find_symbol (buffer, NULL, 1, &sym); + if (sym != NULL) + { + if (sym->attr.intrinsic) + n = sym->name; + else if ((sym->attr.flavor != FL_UNKNOWN + && sym->attr.flavor != FL_PROCEDURE) + || sym->attr.external + || sym->attr.generic + || sym->attr.entry + || sym->attr.result + || sym->attr.dummy + || sym->attr.subroutine + || sym->attr.pointer + || sym->attr.target + || sym->attr.cray_pointer + || sym->attr.cray_pointee + || (sym->attr.proc != PROC_UNKNOWN + && sym->attr.proc != PROC_INTRINSIC) + || sym->attr.if_source != IFSRC_UNKNOWN + || sym == sym->ns->proc_name) + { + gfc_error_now ("%s is not INTRINSIC procedure name " + "at %C", buffer); + sym = NULL; + } + else + n = sym->name; + } + if (strcmp (n, "max") == 0) + reduction = OMP_LIST_MAX; + else if (strcmp (n, "min") == 0) + reduction = OMP_LIST_MIN; + else if (strcmp (n, "iand") == 0) + reduction = OMP_LIST_IAND; + else if (strcmp (n, "ior") == 0) + reduction = OMP_LIST_IOR; + else if (strcmp (n, "ieor") == 0) + reduction = OMP_LIST_IEOR; + if (reduction != OMP_LIST_NUM + && sym != NULL + && ! sym->attr.intrinsic + && ! sym->attr.use_assoc + && ((sym->attr.flavor == FL_UNKNOWN + && gfc_add_flavor (&sym->attr, FL_PROCEDURE, + sym->name, NULL) == FAILURE) + || gfc_add_intrinsic (&sym->attr, NULL) == FAILURE)) + { + gfc_free_omp_clauses (c); + return MATCH_ERROR; + } + } + if (reduction != OMP_LIST_NUM + && gfc_match_omp_variable_list (" :", &c->lists[reduction], + false) + == MATCH_YES) + continue; + else + gfc_current_locus = old_loc; + } + if ((mask & OMP_CLAUSE_DEFAULT) + && c->default_sharing == OMP_DEFAULT_UNKNOWN) + { + if (gfc_match ("default ( shared )") == MATCH_YES) + c->default_sharing = OMP_DEFAULT_SHARED; + else if (gfc_match ("default ( private )") == MATCH_YES) + c->default_sharing = OMP_DEFAULT_PRIVATE; + else if (gfc_match ("default ( none )") == MATCH_YES) + c->default_sharing = OMP_DEFAULT_NONE; + if (c->default_sharing != OMP_DEFAULT_UNKNOWN) + continue; + } + old_loc = gfc_current_locus; + if ((mask & OMP_CLAUSE_SCHEDULE) + && c->sched_kind == OMP_SCHED_NONE + && gfc_match ("schedule ( ") == MATCH_YES) + { + if (gfc_match ("static") == MATCH_YES) + c->sched_kind = OMP_SCHED_STATIC; + else if (gfc_match ("dynamic") == MATCH_YES) + c->sched_kind = OMP_SCHED_DYNAMIC; + else if (gfc_match ("guided") == MATCH_YES) + c->sched_kind = OMP_SCHED_GUIDED; + else if (gfc_match ("runtime") == MATCH_YES) + c->sched_kind = OMP_SCHED_RUNTIME; + if (c->sched_kind != OMP_SCHED_NONE) + { + match m = MATCH_NO; + if (c->sched_kind != OMP_SCHED_RUNTIME) + m = gfc_match (" , %e )", &c->chunk_size); + if (m != MATCH_YES) + m = gfc_match_char (')'); + if (m != MATCH_YES) + c->sched_kind = OMP_SCHED_NONE; + } + if (c->sched_kind != OMP_SCHED_NONE) + continue; + else + gfc_current_locus = old_loc; + } + if ((mask & OMP_CLAUSE_ORDERED) && !c->ordered + && gfc_match ("ordered") == MATCH_YES) + { + c->ordered = needs_space = true; + continue; + } + + break; + } + + if (gfc_match_omp_eos () != MATCH_YES) + { + gfc_free_omp_clauses (c); + return MATCH_ERROR; + } + + *cp = c; + return MATCH_YES; +} + +#define OMP_PARALLEL_CLAUSES \ + (OMP_CLAUSE_PRIVATE | OMP_CLAUSE_FIRSTPRIVATE | OMP_CLAUSE_SHARED \ + | OMP_CLAUSE_COPYIN | OMP_CLAUSE_REDUCTION | OMP_CLAUSE_IF \ + | OMP_CLAUSE_NUM_THREADS | OMP_CLAUSE_DEFAULT) +#define OMP_DO_CLAUSES \ + (OMP_CLAUSE_PRIVATE | OMP_CLAUSE_FIRSTPRIVATE \ + | OMP_CLAUSE_LASTPRIVATE | OMP_CLAUSE_REDUCTION \ + | OMP_CLAUSE_SCHEDULE | OMP_CLAUSE_ORDERED) +#define OMP_SECTIONS_CLAUSES \ + (OMP_CLAUSE_PRIVATE | OMP_CLAUSE_FIRSTPRIVATE \ + | OMP_CLAUSE_LASTPRIVATE | OMP_CLAUSE_REDUCTION) + +match +gfc_match_omp_parallel (void) +{ + gfc_omp_clauses *c; + if (gfc_match_omp_clauses (&c, OMP_PARALLEL_CLAUSES) != MATCH_YES) + return MATCH_ERROR; + new_st.op = EXEC_OMP_PARALLEL; + new_st.ext.omp_clauses = c; + return MATCH_YES; +} + +match +gfc_match_omp_critical (void) +{ + char n[GFC_MAX_SYMBOL_LEN+1]; + + if (gfc_match (" ( %n )", n) != MATCH_YES) + n[0] = '\0'; + if (gfc_match_omp_eos () != MATCH_YES) + return MATCH_ERROR; + new_st.op = EXEC_OMP_CRITICAL; + new_st.ext.omp_name = n[0] ? xstrdup (n) : NULL; + return MATCH_YES; +} + +match +gfc_match_omp_do (void) +{ + gfc_omp_clauses *c; + if (gfc_match_omp_clauses (&c, OMP_DO_CLAUSES) != MATCH_YES) + return MATCH_ERROR; + new_st.op = EXEC_OMP_DO; + new_st.ext.omp_clauses = c; + return MATCH_YES; +} + +match +gfc_match_omp_flush (void) +{ + gfc_namelist *list = NULL; + gfc_match_omp_variable_list (" (", &list, true); + if (gfc_match_omp_eos () != MATCH_YES) + { + gfc_free_namelist (list); + return MATCH_ERROR; + } + new_st.op = EXEC_OMP_FLUSH; + new_st.ext.omp_namelist = list; + return MATCH_YES; +} + +match +gfc_match_omp_threadprivate (void) +{ + locus old_loc; + char n[GFC_MAX_SYMBOL_LEN+1]; + gfc_symbol *sym; + match m; + gfc_symtree *st; + + old_loc = gfc_current_locus; + + m = gfc_match (" ("); + if (m != MATCH_YES) + return m; + + if (!targetm.have_tls) + { + sorry ("threadprivate variables not supported in this target"); + goto cleanup; + } + + for (;;) + { + m = gfc_match_symbol (&sym, 0); + switch (m) + { + case MATCH_YES: + if (sym->attr.in_common) + gfc_error_now ("Threadprivate variable at %C is an element of" + " a COMMON block"); + else if (gfc_add_threadprivate (&sym->attr, sym->name, + &sym->declared_at) == FAILURE) + goto cleanup; + goto next_item; + case MATCH_NO: + break; + case MATCH_ERROR: + goto cleanup; + } + + m = gfc_match (" / %n /", n); + if (m == MATCH_ERROR) + goto cleanup; + if (m == MATCH_NO || n[0] == '\0') + goto syntax; + + st = gfc_find_symtree (gfc_current_ns->common_root, n); + if (st == NULL) + { + gfc_error ("COMMON block /%s/ not found at %C", n); + goto cleanup; + } + st->n.common->threadprivate = 1; + for (sym = st->n.common->head; sym; sym = sym->common_next) + if (gfc_add_threadprivate (&sym->attr, sym->name, + &sym->declared_at) == FAILURE) + goto cleanup; + + next_item: + if (gfc_match_char (')') == MATCH_YES) + break; + if (gfc_match_char (',') != MATCH_YES) + goto syntax; + } + + return MATCH_YES; + +syntax: + gfc_error ("Syntax error in !$OMP THREADPRIVATE list at %C"); + +cleanup: + gfc_current_locus = old_loc; + return MATCH_ERROR; +} + +match +gfc_match_omp_parallel_do (void) +{ + gfc_omp_clauses *c; + if (gfc_match_omp_clauses (&c, OMP_PARALLEL_CLAUSES | OMP_DO_CLAUSES) + != MATCH_YES) + return MATCH_ERROR; + new_st.op = EXEC_OMP_PARALLEL_DO; + new_st.ext.omp_clauses = c; + return MATCH_YES; +} + +match +gfc_match_omp_parallel_sections (void) +{ + gfc_omp_clauses *c; + if (gfc_match_omp_clauses (&c, OMP_PARALLEL_CLAUSES | OMP_SECTIONS_CLAUSES) + != MATCH_YES) + return MATCH_ERROR; + new_st.op = EXEC_OMP_PARALLEL_SECTIONS; + new_st.ext.omp_clauses = c; + return MATCH_YES; +} + +match +gfc_match_omp_parallel_workshare (void) +{ + gfc_omp_clauses *c; + if (gfc_match_omp_clauses (&c, OMP_PARALLEL_CLAUSES) != MATCH_YES) + return MATCH_ERROR; + new_st.op = EXEC_OMP_PARALLEL_WORKSHARE; + new_st.ext.omp_clauses = c; + return MATCH_YES; +} + +match +gfc_match_omp_sections (void) +{ + gfc_omp_clauses *c; + if (gfc_match_omp_clauses (&c, OMP_SECTIONS_CLAUSES) != MATCH_YES) + return MATCH_ERROR; + new_st.op = EXEC_OMP_SECTIONS; + new_st.ext.omp_clauses = c; + return MATCH_YES; +} + +match +gfc_match_omp_single (void) +{ + gfc_omp_clauses *c; + if (gfc_match_omp_clauses (&c, OMP_CLAUSE_PRIVATE | OMP_CLAUSE_FIRSTPRIVATE) + != MATCH_YES) + return MATCH_ERROR; + new_st.op = EXEC_OMP_SINGLE; + new_st.ext.omp_clauses = c; + return MATCH_YES; +} + +match +gfc_match_omp_workshare (void) +{ + if (gfc_match_omp_eos () != MATCH_YES) + return MATCH_ERROR; + new_st.op = EXEC_OMP_WORKSHARE; + new_st.ext.omp_clauses = gfc_get_omp_clauses (); + return MATCH_YES; +} + +match +gfc_match_omp_master (void) +{ + if (gfc_match_omp_eos () != MATCH_YES) + return MATCH_ERROR; + new_st.op = EXEC_OMP_MASTER; + new_st.ext.omp_clauses = NULL; + return MATCH_YES; +} + +match +gfc_match_omp_ordered (void) +{ + if (gfc_match_omp_eos () != MATCH_YES) + return MATCH_ERROR; + new_st.op = EXEC_OMP_ORDERED; + new_st.ext.omp_clauses = NULL; + return MATCH_YES; +} + +match +gfc_match_omp_atomic (void) +{ + if (gfc_match_omp_eos () != MATCH_YES) + return MATCH_ERROR; + new_st.op = EXEC_OMP_ATOMIC; + new_st.ext.omp_clauses = NULL; + return MATCH_YES; +} + +match +gfc_match_omp_barrier (void) +{ + if (gfc_match_omp_eos () != MATCH_YES) + return MATCH_ERROR; + new_st.op = EXEC_OMP_BARRIER; + new_st.ext.omp_clauses = NULL; + return MATCH_YES; +} + +match +gfc_match_omp_end_nowait (void) +{ + bool nowait = false; + if (gfc_match ("% nowait") == MATCH_YES) + nowait = true; + if (gfc_match_omp_eos () != MATCH_YES) + return MATCH_ERROR; + new_st.op = EXEC_OMP_END_NOWAIT; + new_st.ext.omp_bool = nowait; + return MATCH_YES; +} + +match +gfc_match_omp_end_single (void) +{ + gfc_omp_clauses *c; + if (gfc_match ("% nowait") == MATCH_YES) + { + new_st.op = EXEC_OMP_END_NOWAIT; + new_st.ext.omp_bool = true; + return MATCH_YES; + } + if (gfc_match_omp_clauses (&c, OMP_CLAUSE_COPYPRIVATE) != MATCH_YES) + return MATCH_ERROR; + new_st.op = EXEC_OMP_END_SINGLE; + new_st.ext.omp_clauses = c; + return MATCH_YES; +} + +/* OpenMP directive resolving routines. */ + +static void +resolve_omp_clauses (gfc_code *code) +{ + gfc_omp_clauses *omp_clauses = code->ext.omp_clauses; + gfc_namelist *n; + int list; + static const char *clause_names[] + = { "PRIVATE", "FIRSTPRIVATE", "LASTPRIVATE", "COPYPRIVATE", "SHARED", + "COPYIN", "REDUCTION" }; + + if (omp_clauses == NULL) + return; + + if (omp_clauses->if_expr) + { + gfc_expr *expr = omp_clauses->if_expr; + if (gfc_resolve_expr (expr) == FAILURE + || expr->ts.type != BT_LOGICAL || expr->rank != 0) + gfc_error ("IF clause at %L requires a scalar LOGICAL expression", + &expr->where); + } + if (omp_clauses->num_threads) + { + gfc_expr *expr = omp_clauses->num_threads; + if (gfc_resolve_expr (expr) == FAILURE + || expr->ts.type != BT_INTEGER || expr->rank != 0) + gfc_error ("NUM_THREADS clause at %L requires a scalar" + " INTEGER expression", &expr->where); + } + if (omp_clauses->chunk_size) + { + gfc_expr *expr = omp_clauses->chunk_size; + if (gfc_resolve_expr (expr) == FAILURE + || expr->ts.type != BT_INTEGER || expr->rank != 0) + gfc_error ("SCHEDULE clause's chunk_size at %L requires" + " a scalar INTEGER expression", &expr->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++) + for (n = omp_clauses->lists[list]; n; n = n->next) + n->sym->mark = 0; + + for (list = 0; list < OMP_LIST_NUM; list++) + if (list != OMP_LIST_FIRSTPRIVATE && list != OMP_LIST_LASTPRIVATE) + for (n = omp_clauses->lists[list]; n; n = n->next) + if (n->sym->mark) + gfc_error ("Symbol '%s' present on multiple clauses at %L", + n->sym->name, &code->loc); + else + n->sym->mark = 1; + + gcc_assert (OMP_LIST_LASTPRIVATE == OMP_LIST_FIRSTPRIVATE + 1); + for (list = OMP_LIST_FIRSTPRIVATE; list <= OMP_LIST_LASTPRIVATE; list++) + for (n = omp_clauses->lists[list]; n; n = n->next) + if (n->sym->mark) + { + gfc_error ("Symbol '%s' present on multiple clauses at %L", + n->sym->name, &code->loc); + n->sym->mark = 0; + } + + for (n = omp_clauses->lists[OMP_LIST_FIRSTPRIVATE]; n; n = n->next) + if (n->sym->mark) + gfc_error ("Symbol '%s' present on multiple clauses at %L", + n->sym->name, &code->loc); + else + n->sym->mark = 1; + + for (n = omp_clauses->lists[OMP_LIST_LASTPRIVATE]; n; n = n->next) + n->sym->mark = 0; + + for (n = omp_clauses->lists[OMP_LIST_LASTPRIVATE]; n; n = n->next) + if (n->sym->mark) + gfc_error ("Symbol '%s' present on multiple clauses at %L", + n->sym->name, &code->loc); + else + n->sym->mark = 1; + + for (list = 0; list < OMP_LIST_NUM; list++) + if ((n = omp_clauses->lists[list]) != NULL) + { + const char *name; + + if (list < OMP_LIST_REDUCTION_FIRST) + name = clause_names[list]; + else if (list <= OMP_LIST_REDUCTION_LAST) + name = clause_names[OMP_LIST_REDUCTION_FIRST]; + else + gcc_unreachable (); + + switch (list) + { + case OMP_LIST_COPYIN: + for (; n != NULL; n = n->next) + { + if (!n->sym->attr.threadprivate) + gfc_error ("Non-THREADPRIVATE object '%s' in COPYIN clause" + " at %L", n->sym->name, &code->loc); + if (n->sym->attr.allocatable) + gfc_error ("COPYIN clause object '%s' is ALLOCATABLE at %L", + n->sym->name, &code->loc); + } + break; + case OMP_LIST_COPYPRIVATE: + for (; n != NULL; n = n->next) + { + if (n->sym->as && n->sym->as->type == AS_ASSUMED_SIZE) + gfc_error ("Assumed size array '%s' in COPYPRIVATE clause" + " at %L", n->sym->name, &code->loc); + if (n->sym->attr.allocatable) + gfc_error ("COPYPRIVATE clause object '%s' is ALLOCATABLE" + " at %L", n->sym->name, &code->loc); + } + break; + case OMP_LIST_SHARED: + for (; n != NULL; n = n->next) + { + if (n->sym->attr.threadprivate) + gfc_error ("THREADPRIVATE object '%s' in SHARED clause at" + " %L", n->sym->name, &code->loc); + if (n->sym->attr.cray_pointee) + gfc_error ("Cray pointee '%s' in SHARED clause at %L", + n->sym->name, &code->loc); + } + break; + default: + for (; n != NULL; n = n->next) + { + if (n->sym->attr.threadprivate) + gfc_error ("THREADPRIVATE object '%s' in %s clause at %L", + n->sym->name, name, &code->loc); + if (n->sym->attr.cray_pointee) + gfc_error ("Cray pointee '%s' in %s clause at %L", + n->sym->name, name, &code->loc); + if (list != OMP_LIST_PRIVATE) + { + if (n->sym->attr.pointer) + gfc_error ("POINTER object '%s' in %s clause at %L", + n->sym->name, name, &code->loc); + if (n->sym->attr.allocatable) + gfc_error ("%s clause object '%s' is ALLOCATABLE at %L", + name, n->sym->name, &code->loc); + if (n->sym->attr.cray_pointer) + gfc_error ("Cray pointer '%s' in %s clause at %L", + n->sym->name, name, &code->loc); + } + if (n->sym->as && n->sym->as->type == AS_ASSUMED_SIZE) + gfc_error ("Assumed size array '%s' in %s clause at %L", + n->sym->name, name, &code->loc); + if (n->sym->attr.in_namelist + && (list < OMP_LIST_REDUCTION_FIRST + || list > OMP_LIST_REDUCTION_LAST)) + gfc_error ("Variable '%s' in %s clause is used in" + " NAMELIST statement at %L", + n->sym->name, name, &code->loc); + switch (list) + { + case OMP_LIST_PLUS: + case OMP_LIST_MULT: + case OMP_LIST_SUB: + if (!gfc_numeric_ts (&n->sym->ts)) + gfc_error ("%c REDUCTION variable '%s' is %s at %L", + list == OMP_LIST_PLUS ? '+' + : list == OMP_LIST_MULT ? '*' : '-', + n->sym->name, gfc_typename (&n->sym->ts), + &code->loc); + break; + case OMP_LIST_AND: + case OMP_LIST_OR: + case OMP_LIST_EQV: + case OMP_LIST_NEQV: + if (n->sym->ts.type != BT_LOGICAL) + gfc_error ("%s REDUCTION variable '%s' must be LOGICAL" + " at %L", + list == OMP_LIST_AND ? ".AND." + : list == OMP_LIST_OR ? ".OR." + : list == OMP_LIST_EQV ? ".EQV." : ".NEQV.", + n->sym->name, &code->loc); + break; + case OMP_LIST_MAX: + case OMP_LIST_MIN: + if (n->sym->ts.type != BT_INTEGER + && n->sym->ts.type != BT_REAL) + gfc_error ("%s REDUCTION variable '%s' must be" + " INTEGER or REAL at %L", + list == OMP_LIST_MAX ? "MAX" : "MIN", + n->sym->name, &code->loc); + break; + case OMP_LIST_IAND: + case OMP_LIST_IOR: + case OMP_LIST_IEOR: + if (n->sym->ts.type != BT_INTEGER) + gfc_error ("%s REDUCTION variable '%s' must be INTEGER" + " at %L", + list == OMP_LIST_IAND ? "IAND" + : list == OMP_LIST_MULT ? "IOR" : "IEOR", + n->sym->name, &code->loc); + break; + default: + break; + } + } + break; + } + } +} + +/* Return true if SYM is ever referenced in EXPR except in the SE node. */ + +static bool +expr_references_sym (gfc_expr *e, gfc_symbol *s, gfc_expr *se) +{ + gfc_actual_arglist *arg; + if (e == NULL || e == se) + return false; + switch (e->expr_type) + { + case EXPR_CONSTANT: + case EXPR_NULL: + case EXPR_VARIABLE: + case EXPR_STRUCTURE: + case EXPR_ARRAY: + if (e->symtree != NULL + && e->symtree->n.sym == s) + return true; + return false; + case EXPR_SUBSTRING: + if (e->ref != NULL + && (expr_references_sym (e->ref->u.ss.start, s, se) + || expr_references_sym (e->ref->u.ss.end, s, se))) + return true; + return false; + case EXPR_OP: + if (expr_references_sym (e->value.op.op2, s, se)) + return true; + return expr_references_sym (e->value.op.op1, s, se); + case EXPR_FUNCTION: + for (arg = e->value.function.actual; arg; arg = arg->next) + if (expr_references_sym (arg->expr, s, se)) + return true; + return false; + default: + gcc_unreachable (); + } +} + +/* If EXPR is a conversion function that widens the type + if WIDENING is true or narrows the type if WIDENING is false, + return the inner expression, otherwise return NULL. */ + +static gfc_expr * +is_conversion (gfc_expr *expr, bool widening) +{ + gfc_typespec *ts1, *ts2; + + if (expr->expr_type != EXPR_FUNCTION + || expr->value.function.isym == NULL + || expr->value.function.esym != NULL + || expr->value.function.isym->generic_id != GFC_ISYM_CONVERSION) + return NULL; + + if (widening) + { + ts1 = &expr->ts; + ts2 = &expr->value.function.actual->expr->ts; + } + else + { + ts1 = &expr->value.function.actual->expr->ts; + ts2 = &expr->ts; + } + + if (ts1->type > ts2->type + || (ts1->type == ts2->type && ts1->kind > ts2->kind)) + return expr->value.function.actual->expr; + + return NULL; +} + +static void +resolve_omp_atomic (gfc_code *code) +{ + gfc_symbol *var; + gfc_expr *expr2; + + code = code->block->next; + gcc_assert (code->op == EXEC_ASSIGN); + gcc_assert (code->next == NULL); + + if (code->expr->expr_type != EXPR_VARIABLE + || code->expr->symtree == NULL + || code->expr->rank != 0 + || (code->expr->ts.type != BT_INTEGER + && code->expr->ts.type != BT_REAL + && code->expr->ts.type != BT_COMPLEX + && code->expr->ts.type != BT_LOGICAL)) + { + gfc_error ("!$OMP ATOMIC statement must set a scalar variable of" + " intrinsic type at %L", &code->loc); + return; + } + + var = code->expr->symtree->n.sym; + expr2 = is_conversion (code->expr2, false); + if (expr2 == NULL) + expr2 = code->expr2; + + if (expr2->expr_type == EXPR_OP) + { + gfc_expr *v = NULL, *e, *c; + gfc_intrinsic_op op = expr2->value.op.operator; + gfc_intrinsic_op alt_op = INTRINSIC_NONE; + + switch (op) + { + case INTRINSIC_PLUS: + alt_op = INTRINSIC_MINUS; + break; + case INTRINSIC_TIMES: + alt_op = INTRINSIC_DIVIDE; + break; + case INTRINSIC_MINUS: + alt_op = INTRINSIC_PLUS; + break; + case INTRINSIC_DIVIDE: + alt_op = INTRINSIC_TIMES; + break; + case INTRINSIC_AND: + case INTRINSIC_OR: + break; + case INTRINSIC_EQV: + alt_op = INTRINSIC_NEQV; + break; + case INTRINSIC_NEQV: + alt_op = INTRINSIC_EQV; + break; + default: + gfc_error ("!$OMP ATOMIC assignment operator must be" + " +, *, -, /, .AND., .OR., .EQV. or .NEQV. at %L", + &expr2->where); + return; + } + + /* Check for var = var op expr resp. var = expr op var where + expr doesn't reference var and var op expr is mathematically + equivalent to var op (expr) resp. expr op var equivalent to + (expr) op var. We rely here on the fact that the matcher + for x op1 y op2 z where op1 and op2 have equal precedence + returns (x op1 y) op2 z. */ + e = expr2->value.op.op2; + if (e->expr_type == EXPR_VARIABLE + && e->symtree != NULL + && e->symtree->n.sym == var) + v = e; + else if ((c = is_conversion (e, true)) != NULL + && c->expr_type == EXPR_VARIABLE + && c->symtree != NULL + && c->symtree->n.sym == var) + v = c; + else + { + gfc_expr **p = NULL, **q; + for (q = &expr2->value.op.op1; (e = *q) != NULL; ) + if (e->expr_type == EXPR_VARIABLE + && e->symtree != NULL + && e->symtree->n.sym == var) + { + v = e; + break; + } + else if ((c = is_conversion (e, true)) != NULL) + q = &e->value.function.actual->expr; + else if (e->expr_type != EXPR_OP + || (e->value.op.operator != op + && e->value.op.operator != alt_op) + || e->rank != 0) + break; + else + { + p = q; + q = &e->value.op.op1; + } + + if (v == NULL) + { + gfc_error ("!$OMP ATOMIC assignment must be var = var op expr" + " or var = expr op var at %L", &expr2->where); + return; + } + + if (p != NULL) + { + e = *p; + switch (e->value.op.operator) + { + case INTRINSIC_MINUS: + case INTRINSIC_DIVIDE: + case INTRINSIC_EQV: + case INTRINSIC_NEQV: + gfc_error ("!$OMP ATOMIC var = var op expr not" + " mathematically equivalent to var = var op" + " (expr) at %L", &expr2->where); + break; + default: + break; + } + + /* Canonicalize into var = var op (expr). */ + *p = e->value.op.op2; + e->value.op.op2 = expr2; + e->ts = expr2->ts; + if (code->expr2 == expr2) + code->expr2 = expr2 = e; + else + code->expr2->value.function.actual->expr = expr2 = e; + + if (!gfc_compare_types (&expr2->value.op.op1->ts, &expr2->ts)) + { + for (p = &expr2->value.op.op1; *p != v; + p = &(*p)->value.function.actual->expr) + ; + *p = NULL; + gfc_free_expr (expr2->value.op.op1); + expr2->value.op.op1 = v; + gfc_convert_type (v, &expr2->ts, 2); + } + } + } + + if (e->rank != 0 || expr_references_sym (code->expr2, var, v)) + { + gfc_error ("expr in !$OMP ATOMIC assignment var = var op expr" + " must be scalar and cannot reference var at %L", + &expr2->where); + return; + } + } + else if (expr2->expr_type == EXPR_FUNCTION + && expr2->value.function.isym != NULL + && expr2->value.function.esym == NULL + && expr2->value.function.actual != NULL + && expr2->value.function.actual->next != NULL) + { + gfc_actual_arglist *arg, *var_arg; + + switch (expr2->value.function.isym->generic_id) + { + case GFC_ISYM_MIN: + case GFC_ISYM_MAX: + break; + case GFC_ISYM_IAND: + case GFC_ISYM_IOR: + case GFC_ISYM_IEOR: + if (expr2->value.function.actual->next->next != NULL) + { + gfc_error ("!$OMP ATOMIC assignment intrinsic IAND, IOR" + "or IEOR must have two arguments at %L", + &expr2->where); + return; + } + break; + default: + gfc_error ("!$OMP ATOMIC assignment intrinsic must be" + " MIN, MAX, IAND, IOR or IEOR at %L", + &expr2->where); + return; + } + + var_arg = NULL; + for (arg = expr2->value.function.actual; arg; arg = arg->next) + { + if ((arg == expr2->value.function.actual + || (var_arg == NULL && arg->next == NULL)) + && arg->expr->expr_type == EXPR_VARIABLE + && arg->expr->symtree != NULL + && arg->expr->symtree->n.sym == var) + var_arg = arg; + else if (expr_references_sym (arg->expr, var, NULL)) + gfc_error ("!$OMP ATOMIC intrinsic arguments except one must not" + " reference '%s' at %L", var->name, &arg->expr->where); + if (arg->expr->rank != 0) + gfc_error ("!$OMP ATOMIC intrinsic arguments must be scalar" + " at %L", &arg->expr->where); + } + + if (var_arg == NULL) + { + gfc_error ("First or last !$OMP ATOMIC intrinsic argument must" + " be '%s' at %L", var->name, &expr2->where); + return; + } + + if (var_arg != expr2->value.function.actual) + { + /* Canonicalize, so that var comes first. */ + gcc_assert (var_arg->next == NULL); + for (arg = expr2->value.function.actual; + arg->next != var_arg; arg = arg->next) + ; + var_arg->next = expr2->value.function.actual; + expr2->value.function.actual = var_arg; + arg->next = NULL; + } + } + else + gfc_error ("!$OMP ATOMIC assignment must have an operator or intrinsic" + " on right hand side at %L", &expr2->where); +} + +struct omp_context +{ + gfc_code *code; + struct pointer_set_t *sharing_clauses; + struct pointer_set_t *private_iterators; + struct omp_context *previous; +} *omp_current_ctx; +gfc_code *omp_current_do_code; + +void +gfc_resolve_omp_do_blocks (gfc_code *code, gfc_namespace *ns) +{ + if (code->block->next && code->block->next->op == EXEC_DO) + omp_current_do_code = code->block->next; + gfc_resolve_blocks (code->block, ns); +} + +void +gfc_resolve_omp_parallel_blocks (gfc_code *code, gfc_namespace *ns) +{ + struct omp_context ctx; + gfc_omp_clauses *omp_clauses = code->ext.omp_clauses; + gfc_namelist *n; + int list; + + ctx.code = code; + ctx.sharing_clauses = pointer_set_create (); + ctx.private_iterators = pointer_set_create (); + ctx.previous = omp_current_ctx; + omp_current_ctx = &ctx; + + for (list = 0; list < OMP_LIST_NUM; list++) + for (n = omp_clauses->lists[list]; n; n = n->next) + pointer_set_insert (ctx.sharing_clauses, n->sym); + + if (code->op == EXEC_OMP_PARALLEL_DO) + gfc_resolve_omp_do_blocks (code, ns); + else + gfc_resolve_blocks (code->block, ns); + + omp_current_ctx = ctx.previous; + pointer_set_destroy (ctx.sharing_clauses); + pointer_set_destroy (ctx.private_iterators); +} + +/* Note a DO iterator variable. This is special in !$omp parallel + construct, where they are predetermined private. */ + +void +gfc_resolve_do_iterator (gfc_code *code, gfc_symbol *sym) +{ + struct omp_context *ctx; + + if (sym->attr.threadprivate) + return; + + /* !$omp do and !$omp parallel do iteration variable is predetermined + private just in the !$omp do resp. !$omp parallel do construct, + with no implications for the outer parallel constructs. */ + if (code == omp_current_do_code) + return; + + for (ctx = omp_current_ctx; ctx; ctx = ctx->previous) + { + if (pointer_set_contains (ctx->sharing_clauses, sym)) + continue; + + if (! pointer_set_insert (ctx->private_iterators, sym)) + { + gfc_omp_clauses *omp_clauses = ctx->code->ext.omp_clauses; + gfc_namelist *p; + + p = gfc_get_namelist (); + p->sym = sym; + p->next = omp_clauses->lists[OMP_LIST_PRIVATE]; + omp_clauses->lists[OMP_LIST_PRIVATE] = p; + } + } +} + +static void +resolve_omp_do (gfc_code *code) +{ + gfc_code *do_code; + int list; + gfc_namelist *n; + gfc_symbol *dovar; + + if (code->ext.omp_clauses) + resolve_omp_clauses (code); + + do_code = code->block->next; + if (do_code->op == EXEC_DO_WHILE) + gfc_error ("!$OMP DO cannot be a DO WHILE or DO without loop control at %L", + &do_code->loc); + else + { + gcc_assert (do_code->op == EXEC_DO); + if (do_code->ext.iterator->var->ts.type != BT_INTEGER) + gfc_error ("!$OMP DO iteration variable must be of type integer at %L", + &do_code->loc); + dovar = do_code->ext.iterator->var->symtree->n.sym; + if (dovar->attr.threadprivate) + gfc_error ("!$OMP DO iteration variable must not be THREADPRIVATE at %L", + &do_code->loc); + if (code->ext.omp_clauses) + for (list = 0; list < OMP_LIST_NUM; list++) + if (list != OMP_LIST_PRIVATE && list != OMP_LIST_LASTPRIVATE) + for (n = code->ext.omp_clauses->lists[list]; n; n = n->next) + if (dovar == n->sym) + { + gfc_error ("!$OMP DO iteration variable present on clause" + " other than PRIVATE or LASTPRIVATE at %L", + &do_code->loc); + break; + } + } +} + +/* Resolve OpenMP directive clauses and check various requirements + of each directive. */ + +void +gfc_resolve_omp_directive (gfc_code *code, gfc_namespace *ns ATTRIBUTE_UNUSED) +{ + switch (code->op) + { + case EXEC_OMP_DO: + case EXEC_OMP_PARALLEL_DO: + resolve_omp_do (code); + break; + case EXEC_OMP_WORKSHARE: + case EXEC_OMP_PARALLEL_WORKSHARE: + case EXEC_OMP_PARALLEL: + case EXEC_OMP_PARALLEL_SECTIONS: + case EXEC_OMP_SECTIONS: + case EXEC_OMP_SINGLE: + if (code->ext.omp_clauses) + resolve_omp_clauses (code); + break; + case EXEC_OMP_ATOMIC: + resolve_omp_atomic (code); + break; + default: + break; + } +} diff --git a/gcc/fortran/options.c b/gcc/fortran/options.c index 0b2f7b36f21..bf1da85b8ba 100644 --- a/gcc/fortran/options.c +++ b/gcc/fortran/options.c @@ -1,6 +1,6 @@ /* Parse and display command line options. - Copyright (C) 2000, 2001, 2002, 2003, 2004, 2005 Free Software Foundation, - Inc. + Copyright (C) 2000, 2001, 2002, 2003, 2004, 2005, 2006 + Free Software Foundation, Inc. Contributed by Andy Vaught This file is part of GCC. @@ -77,6 +77,7 @@ gfc_init_options (unsigned int argc ATTRIBUTE_UNUSED, gfc_option.flag_backslash = 1; gfc_option.flag_cray_pointer = 0; gfc_option.flag_d_lines = -1; + gfc_option.flag_openmp = 0; gfc_option.q_kind = gfc_default_double_kind; @@ -456,6 +457,10 @@ gfc_handle_option (size_t scode, const char *arg, int value) gfc_option.source_form = FORM_FREE; break; + case OPT_fopenmp: + gfc_option.flag_openmp = value; + break; + case OPT_ffree_line_length_none: gfc_option.free_line_length = 0; break; diff --git a/gcc/fortran/parse.c b/gcc/fortran/parse.c index 4fb690baa0a..832848237e9 100644 --- a/gcc/fortran/parse.c +++ b/gcc/fortran/parse.c @@ -300,6 +300,107 @@ decode_statement (void) return ST_NONE; } +static gfc_statement +decode_omp_directive (void) +{ + locus old_locus; + int c; + +#ifdef GFC_DEBUG + gfc_symbol_state (); +#endif + + gfc_clear_error (); /* Clear any pending errors. */ + gfc_clear_warning (); /* Clear any pending warnings. */ + + if (gfc_pure (NULL)) + { + gfc_error_now ("OpenMP directives at %C may not appear in PURE or ELEMENTAL procedures"); + gfc_error_recovery (); + return ST_NONE; + } + + old_locus = gfc_current_locus; + + /* General OpenMP directive matching: Instead of testing every possible + statement, we eliminate most possibilities by peeking at the + first character. */ + + c = gfc_peek_char (); + + switch (c) + { + case 'a': + match ("atomic", gfc_match_omp_atomic, ST_OMP_ATOMIC); + break; + case 'b': + match ("barrier", gfc_match_omp_barrier, ST_OMP_BARRIER); + break; + case 'c': + match ("critical", gfc_match_omp_critical, ST_OMP_CRITICAL); + break; + case 'd': + match ("do", gfc_match_omp_do, ST_OMP_DO); + break; + case 'e': + match ("end critical", gfc_match_omp_critical, ST_OMP_END_CRITICAL); + match ("end do", gfc_match_omp_end_nowait, ST_OMP_END_DO); + match ("end master", gfc_match_omp_eos, ST_OMP_END_MASTER); + match ("end ordered", gfc_match_omp_eos, ST_OMP_END_ORDERED); + match ("end parallel do", gfc_match_omp_eos, ST_OMP_END_PARALLEL_DO); + match ("end parallel sections", gfc_match_omp_eos, + ST_OMP_END_PARALLEL_SECTIONS); + match ("end parallel workshare", gfc_match_omp_eos, + ST_OMP_END_PARALLEL_WORKSHARE); + match ("end parallel", gfc_match_omp_eos, ST_OMP_END_PARALLEL); + match ("end sections", gfc_match_omp_end_nowait, ST_OMP_END_SECTIONS); + match ("end single", gfc_match_omp_end_single, ST_OMP_END_SINGLE); + match ("end workshare", gfc_match_omp_end_nowait, + ST_OMP_END_WORKSHARE); + break; + case 'f': + match ("flush", gfc_match_omp_flush, ST_OMP_FLUSH); + break; + case 'm': + match ("master", gfc_match_omp_master, ST_OMP_MASTER); + break; + case 'o': + match ("ordered", gfc_match_omp_ordered, ST_OMP_ORDERED); + break; + case 'p': + match ("parallel do", gfc_match_omp_parallel_do, ST_OMP_PARALLEL_DO); + match ("parallel sections", gfc_match_omp_parallel_sections, + ST_OMP_PARALLEL_SECTIONS); + match ("parallel workshare", gfc_match_omp_parallel_workshare, + ST_OMP_PARALLEL_WORKSHARE); + match ("parallel", gfc_match_omp_parallel, ST_OMP_PARALLEL); + break; + case 's': + match ("sections", gfc_match_omp_sections, ST_OMP_SECTIONS); + match ("section", gfc_match_omp_eos, ST_OMP_SECTION); + match ("single", gfc_match_omp_single, ST_OMP_SINGLE); + break; + case 't': + match ("threadprivate", gfc_match_omp_threadprivate, + ST_OMP_THREADPRIVATE); + case 'w': + match ("workshare", gfc_match_omp_workshare, ST_OMP_WORKSHARE); + break; + } + + /* All else has failed, so give up. See if any of the matchers has + stored an error message of some sort. */ + + if (gfc_error_check () == 0) + gfc_error_now ("Unclassifiable OpenMP directive at %C"); + + reject_statement (); + + gfc_error_recovery (); + + return ST_NONE; +} + #undef match @@ -355,6 +456,22 @@ next_free (void) } } } + else if (c == '!') + { + /* Comments have already been skipped by the time we get here, + except for OpenMP directives. */ + if (gfc_option.flag_openmp) + { + int i; + + c = gfc_next_char (); + for (i = 0; i < 5; i++, c = gfc_next_char ()) + gcc_assert (c == "!$omp"[i]); + + gcc_assert (c == ' '); + return decode_omp_directive (); + } + } return decode_statement (); } @@ -405,7 +522,26 @@ next_fixed (void) digit_flag = 1; break; - /* Comments have already been skipped by the time we get + /* Comments have already been skipped by the time we get + here, except for OpenMP directives. */ + case '*': + if (gfc_option.flag_openmp) + { + for (i = 0; i < 5; i++, c = gfc_next_char_literal (0)) + gcc_assert (TOLOWER (c) == "*$omp"[i]); + + if (c != ' ' && c != '0') + { + gfc_buffer_error (0); + gfc_error ("Bad continuation line at %C"); + return ST_NONE; + } + + return decode_omp_directive (); + } + /* FALLTHROUGH */ + + /* Comments have already been skipped by the time we get here so don't bother checking for them. */ default: @@ -534,18 +670,23 @@ next_statement (void) case ST_PAUSE: case ST_STOP: case ST_WRITE: case ST_ASSIGNMENT: \ case ST_POINTER_ASSIGNMENT: case ST_EXIT: case ST_CYCLE: \ case ST_ARITHMETIC_IF: case ST_WHERE: case ST_FORALL: \ - case ST_LABEL_ASSIGNMENT: case ST_FLUSH + case ST_LABEL_ASSIGNMENT: case ST_FLUSH: case ST_OMP_FLUSH: \ + case ST_OMP_BARRIER /* Statements that mark other executable statements. */ #define case_exec_markers case ST_DO: case ST_FORALL_BLOCK: case ST_IF_BLOCK: \ - case ST_WHERE_BLOCK: case ST_SELECT_CASE + case ST_WHERE_BLOCK: case ST_SELECT_CASE: case ST_OMP_PARALLEL: \ + 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_DO: case ST_OMP_PARALLEL_DO: case ST_OMP_ATOMIC: \ + case ST_OMP_WORKSHARE: case ST_OMP_PARALLEL_WORKSHARE /* Declaration statements */ #define case_decl case ST_ATTR_DECL: case ST_COMMON: case ST_DATA_DECL: \ case ST_EQUIVALENCE: case ST_NAMELIST: case ST_STATEMENT_FUNCTION: \ - case ST_TYPE: case ST_INTERFACE + case ST_TYPE: case ST_INTERFACE: case ST_OMP_THREADPRIVATE /* Block end statements. Errors associated with interchanging these are detected in gfc_match_end(). */ @@ -963,6 +1104,87 @@ gfc_ascii_statement (gfc_statement st) case ST_END_ENUM: p = "END ENUM"; break; + case ST_OMP_ATOMIC: + p = "!$OMP ATOMIC"; + break; + case ST_OMP_BARRIER: + p = "!$OMP BARRIER"; + break; + case ST_OMP_CRITICAL: + p = "!$OMP CRITICAL"; + break; + case ST_OMP_DO: + p = "!$OMP DO"; + break; + case ST_OMP_END_CRITICAL: + p = "!$OMP END CRITICAL"; + break; + case ST_OMP_END_DO: + p = "!$OMP END DO"; + break; + case ST_OMP_END_MASTER: + p = "!$OMP END MASTER"; + break; + case ST_OMP_END_ORDERED: + p = "!$OMP END ORDERED"; + break; + case ST_OMP_END_PARALLEL: + p = "!$OMP END PARALLEL"; + break; + case ST_OMP_END_PARALLEL_DO: + p = "!$OMP END PARALLEL DO"; + break; + case ST_OMP_END_PARALLEL_SECTIONS: + p = "!$OMP END PARALLEL SECTIONS"; + break; + case ST_OMP_END_PARALLEL_WORKSHARE: + p = "!$OMP END PARALLEL WORKSHARE"; + break; + case ST_OMP_END_SECTIONS: + p = "!$OMP END SECTIONS"; + break; + case ST_OMP_END_SINGLE: + p = "!$OMP END SINGLE"; + break; + case ST_OMP_END_WORKSHARE: + p = "!$OMP END WORKSHARE"; + break; + case ST_OMP_FLUSH: + p = "!$OMP FLUSH"; + break; + case ST_OMP_MASTER: + p = "!$OMP MASTER"; + break; + case ST_OMP_ORDERED: + p = "!$OMP ORDERED"; + break; + case ST_OMP_PARALLEL: + p = "!$OMP PARALLEL"; + break; + case ST_OMP_PARALLEL_DO: + p = "!$OMP PARALLEL DO"; + break; + case ST_OMP_PARALLEL_SECTIONS: + p = "!$OMP PARALLEL SECTIONS"; + break; + case ST_OMP_PARALLEL_WORKSHARE: + p = "!$OMP PARALLEL WORKSHARE"; + break; + case ST_OMP_SECTIONS: + p = "!$OMP SECTIONS"; + break; + case ST_OMP_SECTION: + p = "!$OMP SECTION"; + break; + case ST_OMP_SINGLE: + p = "!$OMP SINGLE"; + break; + case ST_OMP_THREADPRIVATE: + p = "!$OMP THREADPRIVATE"; + break; + case ST_OMP_WORKSHARE: + p = "!$OMP WORKSHARE"; + break; default: gfc_internal_error ("gfc_ascii_statement(): Bad statement code"); } @@ -2070,6 +2292,266 @@ loop: } +/* Parse the statements of OpenMP do/parallel do. */ + +static gfc_statement +parse_omp_do (gfc_statement omp_st) +{ + gfc_statement st; + gfc_code *cp, *np; + gfc_state_data s; + + accept_statement (omp_st); + + cp = gfc_state_stack->tail; + push_state (&s, COMP_OMP_STRUCTURED_BLOCK, NULL); + np = new_level (cp); + np->op = cp->op; + np->block = NULL; + + for (;;) + { + st = next_statement (); + if (st == ST_NONE) + unexpected_eof (); + else if (st == ST_DO) + break; + else + unexpected_statement (st); + } + + parse_do_block (); + if (gfc_statement_label != NULL + && gfc_state_stack->previous != NULL + && gfc_state_stack->previous->state == COMP_DO + && gfc_state_stack->previous->ext.end_do_label == gfc_statement_label) + { + /* In + DO 100 I=1,10 + !$OMP DO + DO J=1,10 + ... + 100 CONTINUE + there should be no !$OMP END DO. */ + pop_state (); + return ST_IMPLIED_ENDDO; + } + + check_do_closure (); + pop_state (); + + st = next_statement (); + if (st == (omp_st == ST_OMP_DO ? ST_OMP_END_DO : ST_OMP_END_PARALLEL_DO)) + { + if (new_st.op == EXEC_OMP_END_NOWAIT) + cp->ext.omp_clauses->nowait |= new_st.ext.omp_bool; + else + gcc_assert (new_st.op == EXEC_NOP); + gfc_clear_new_st (); + st = next_statement (); + } + return st; +} + + +/* Parse the statements of OpenMP atomic directive. */ + +static void +parse_omp_atomic (void) +{ + gfc_statement st; + gfc_code *cp, *np; + gfc_state_data s; + + accept_statement (ST_OMP_ATOMIC); + + cp = gfc_state_stack->tail; + push_state (&s, COMP_OMP_STRUCTURED_BLOCK, NULL); + np = new_level (cp); + np->op = cp->op; + np->block = NULL; + + for (;;) + { + st = next_statement (); + if (st == ST_NONE) + unexpected_eof (); + else if (st == ST_ASSIGNMENT) + break; + else + unexpected_statement (st); + } + + accept_statement (st); + + pop_state (); +} + + +/* Parse the statements of an OpenMP structured block. */ + +static void +parse_omp_structured_block (gfc_statement omp_st, bool workshare_stmts_only) +{ + gfc_statement st, omp_end_st; + gfc_code *cp, *np; + gfc_state_data s; + + accept_statement (omp_st); + + cp = gfc_state_stack->tail; + push_state (&s, COMP_OMP_STRUCTURED_BLOCK, NULL); + np = new_level (cp); + np->op = cp->op; + np->block = NULL; + + switch (omp_st) + { + case ST_OMP_PARALLEL: + omp_end_st = ST_OMP_END_PARALLEL; + break; + case ST_OMP_PARALLEL_SECTIONS: + omp_end_st = ST_OMP_END_PARALLEL_SECTIONS; + break; + case ST_OMP_SECTIONS: + omp_end_st = ST_OMP_END_SECTIONS; + break; + case ST_OMP_ORDERED: + omp_end_st = ST_OMP_END_ORDERED; + break; + case ST_OMP_CRITICAL: + omp_end_st = ST_OMP_END_CRITICAL; + break; + case ST_OMP_MASTER: + omp_end_st = ST_OMP_END_MASTER; + break; + case ST_OMP_SINGLE: + omp_end_st = ST_OMP_END_SINGLE; + break; + case ST_OMP_WORKSHARE: + omp_end_st = ST_OMP_END_WORKSHARE; + break; + case ST_OMP_PARALLEL_WORKSHARE: + omp_end_st = ST_OMP_END_PARALLEL_WORKSHARE; + break; + default: + gcc_unreachable (); + } + + do + { + if (workshare_stmts_only) + { + /* Inside of !$omp workshare, only + scalar assignments + array assignments + where statements and constructs + forall statements and constructs + !$omp atomic + !$omp critical + !$omp parallel + are allowed. For !$omp critical these + restrictions apply recursively. */ + bool cycle = true; + + st = next_statement (); + for (;;) + { + switch (st) + { + case ST_NONE: + unexpected_eof (); + + case ST_ASSIGNMENT: + case ST_WHERE: + case ST_FORALL: + accept_statement (st); + break; + + case ST_WHERE_BLOCK: + parse_where_block (); + break; + + case ST_FORALL_BLOCK: + parse_forall_block (); + break; + + case ST_OMP_PARALLEL: + case ST_OMP_PARALLEL_SECTIONS: + parse_omp_structured_block (st, false); + break; + + case ST_OMP_PARALLEL_WORKSHARE: + case ST_OMP_CRITICAL: + parse_omp_structured_block (st, true); + break; + + case ST_OMP_PARALLEL_DO: + st = parse_omp_do (st); + continue; + + case ST_OMP_ATOMIC: + parse_omp_atomic (); + break; + + default: + cycle = false; + break; + } + + if (!cycle) + break; + + st = next_statement (); + } + } + else + st = parse_executable (ST_NONE); + if (st == ST_NONE) + unexpected_eof (); + else if (st == ST_OMP_SECTION + && (omp_st == ST_OMP_SECTIONS + || omp_st == ST_OMP_PARALLEL_SECTIONS)) + { + np = new_level (np); + np->op = cp->op; + np->block = NULL; + } + else if (st != omp_end_st) + unexpected_statement (st); + } + while (st != omp_end_st); + + switch (new_st.op) + { + case EXEC_OMP_END_NOWAIT: + cp->ext.omp_clauses->nowait |= new_st.ext.omp_bool; + break; + case EXEC_OMP_CRITICAL: + if (((cp->ext.omp_name == NULL) ^ (new_st.ext.omp_name == NULL)) + || (new_st.ext.omp_name != NULL + && strcmp (cp->ext.omp_name, new_st.ext.omp_name) != 0)) + gfc_error ("Name after !$omp critical and !$omp end critical does" + " not match at %C"); + gfc_free ((char *) new_st.ext.omp_name); + break; + case EXEC_OMP_END_SINGLE: + cp->ext.omp_clauses->lists[OMP_LIST_COPYPRIVATE] + = new_st.ext.omp_clauses->lists[OMP_LIST_COPYPRIVATE]; + new_st.ext.omp_clauses->lists[OMP_LIST_COPYPRIVATE] = NULL; + gfc_free_omp_clauses (new_st.ext.omp_clauses); + break; + case EXEC_NOP: + break; + default: + gcc_unreachable (); + } + + gfc_clear_new_st (); + pop_state (); +} + + /* Accept a series of executable statements. We return the first statement that doesn't fit to the caller. Any block statements are passed on to the correct handler, which usually passes the buck @@ -2083,9 +2565,8 @@ parse_executable (gfc_statement st) if (st == ST_NONE) st = next_statement (); - for (;; st = next_statement ()) + for (;;) { - close_flag = check_do_closure (); if (close_flag) switch (st) @@ -2125,38 +2606,62 @@ parse_executable (gfc_statement st) accept_statement (st); if (close_flag == 1) return ST_IMPLIED_ENDDO; - continue; + break; case ST_IF_BLOCK: parse_if_block (); - continue; + break; case ST_SELECT_CASE: parse_select_block (); - continue; + break; case ST_DO: parse_do_block (); if (check_do_closure () == 1) return ST_IMPLIED_ENDDO; - continue; + break; case ST_WHERE_BLOCK: parse_where_block (); - continue; + break; case ST_FORALL_BLOCK: parse_forall_block (); + break; + + case ST_OMP_PARALLEL: + 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: + parse_omp_structured_block (st, false); + break; + + case ST_OMP_WORKSHARE: + case ST_OMP_PARALLEL_WORKSHARE: + parse_omp_structured_block (st, true); + break; + + case ST_OMP_DO: + case ST_OMP_PARALLEL_DO: + st = parse_omp_do (st); + if (st == ST_IMPLIED_ENDDO) + return st; continue; - default: + case ST_OMP_ATOMIC: + parse_omp_atomic (); break; + + default: + return st; } - break; + st = next_statement (); } - - return st; } diff --git a/gcc/fortran/parse.h b/gcc/fortran/parse.h index 193e1150674..f3b12e17b0a 100644 --- a/gcc/fortran/parse.h +++ b/gcc/fortran/parse.h @@ -1,5 +1,5 @@ /* Parser header - Copyright (C) 2003 Free Software Foundation, Inc. + Copyright (C) 2003, 2005, 2006 Free Software Foundation, Inc. Contributed by Steven Bosscher This file is part of GCC. @@ -30,7 +30,8 @@ typedef enum { COMP_NONE, COMP_PROGRAM, COMP_MODULE, COMP_SUBROUTINE, COMP_FUNCTION, COMP_BLOCK_DATA, COMP_INTERFACE, COMP_DERIVED, COMP_IF, COMP_DO, - COMP_SELECT, COMP_FORALL, COMP_WHERE, COMP_CONTAINS, COMP_ENUM + COMP_SELECT, COMP_FORALL, COMP_WHERE, COMP_CONTAINS, COMP_ENUM, + COMP_OMP_STRUCTURED_BLOCK } gfc_compile_state; diff --git a/gcc/fortran/resolve.c b/gcc/fortran/resolve.c index 84d5c7b3eef..61983d153a0 100644 --- a/gcc/fortran/resolve.c +++ b/gcc/fortran/resolve.c @@ -48,10 +48,14 @@ code_stack; static code_stack *cs_base = NULL; -/* Nonzero if we're inside a FORALL block */ +/* Nonzero if we're inside a FORALL block. */ static int forall_flag; +/* Nonzero if we're inside a OpenMP WORKSHARE or PARALLEL WORKSHARE block. */ + +static int omp_workshare_flag; + /* Nonzero if we are processing a formal arglist. The corresponding function resets the flag each time that it is read. */ static int formal_arg_flag = 0; @@ -1314,6 +1318,15 @@ resolve_function (gfc_expr * expr) return FAILURE; } } + if (omp_workshare_flag + && expr->value.function.esym + && ! gfc_elemental (expr->value.function.esym)) + { + gfc_error ("User defined non-ELEMENTAL function '%s' at %L not allowed" + " in WORKSHARE construct", expr->value.function.esym->name, + &expr->where); + t = FAILURE; + } else if (expr->value.function.actual != NULL && expr->value.function.isym != NULL @@ -4036,7 +4049,7 @@ gfc_resolve_forall_body (gfc_code *code, int nvar, gfc_expr **var_expr) gfc_resolve_assign_in_forall (c, nvar, var_expr); break; - /* Because the resolve_blocks() will handle the nested FORALL, + /* Because the gfc_resolve_blocks() will handle the nested FORALL, there is no need to handle it here. */ case EXEC_FORALL: break; @@ -4055,8 +4068,6 @@ gfc_resolve_forall_body (gfc_code *code, int nvar, gfc_expr **var_expr) /* Given a FORALL construct, first resolve the FORALL iterator, then call gfc_resolve_forall_body to resolve the FORALL body. */ -static void resolve_blocks (gfc_code *, gfc_namespace *); - static void gfc_resolve_forall (gfc_code *code, gfc_namespace *ns, int forall_save) { @@ -4122,7 +4133,7 @@ gfc_resolve_forall (gfc_code *code, gfc_namespace *ns, int forall_save) gfc_resolve_forall_body (code, nvar, var_expr); /* May call gfc_resolve_forall to resolve the inner FORALL loop. */ - resolve_blocks (code->block, ns); + gfc_resolve_blocks (code->block, ns); /* Free VAR_EXPR after the whole FORALL construct resolved. */ for (i = 0; i < total_var; i++) @@ -4139,8 +4150,8 @@ gfc_resolve_forall (gfc_code *code, gfc_namespace *ns, int forall_save) static void resolve_code (gfc_code *, gfc_namespace *); -static void -resolve_blocks (gfc_code * b, gfc_namespace * ns) +void +gfc_resolve_blocks (gfc_code * b, gfc_namespace * ns) { try t; @@ -4183,6 +4194,20 @@ resolve_blocks (gfc_code * b, gfc_namespace * ns) case EXEC_IOLENGTH: break; + case EXEC_OMP_ATOMIC: + case EXEC_OMP_CRITICAL: + case EXEC_OMP_DO: + case EXEC_OMP_MASTER: + case EXEC_OMP_ORDERED: + case EXEC_OMP_PARALLEL: + case EXEC_OMP_PARALLEL_DO: + case EXEC_OMP_PARALLEL_SECTIONS: + case EXEC_OMP_PARALLEL_WORKSHARE: + case EXEC_OMP_SECTIONS: + case EXEC_OMP_SINGLE: + case EXEC_OMP_WORKSHARE: + break; + default: gfc_internal_error ("resolve_block(): Bad block type"); } @@ -4198,7 +4223,7 @@ resolve_blocks (gfc_code * b, gfc_namespace * ns) static void resolve_code (gfc_code * code, gfc_namespace * ns) { - int forall_save = 0; + int omp_workshare_save; code_stack frame; gfc_alloc *a; try t; @@ -4213,15 +4238,44 @@ resolve_code (gfc_code * code, gfc_namespace * ns) if (code->op == EXEC_FORALL) { - forall_save = forall_flag; - forall_flag = 1; - gfc_resolve_forall (code, ns, forall_save); - } - else - resolve_blocks (code->block, ns); + int forall_save = forall_flag; - if (code->op == EXEC_FORALL) - forall_flag = forall_save; + forall_flag = 1; + gfc_resolve_forall (code, ns, forall_save); + forall_flag = forall_save; + } + else if (code->block) + { + omp_workshare_save = -1; + switch (code->op) + { + case EXEC_OMP_PARALLEL_WORKSHARE: + omp_workshare_save = omp_workshare_flag; + omp_workshare_flag = 1; + gfc_resolve_omp_parallel_blocks (code, ns); + break; + case EXEC_OMP_PARALLEL: + case EXEC_OMP_PARALLEL_DO: + case EXEC_OMP_PARALLEL_SECTIONS: + omp_workshare_save = omp_workshare_flag; + omp_workshare_flag = 0; + gfc_resolve_omp_parallel_blocks (code, ns); + break; + case EXEC_OMP_DO: + gfc_resolve_omp_do_blocks (code, ns); + break; + case EXEC_OMP_WORKSHARE: + omp_workshare_save = omp_workshare_flag; + omp_workshare_flag = 1; + /* FALLTHROUGH */ + default: + gfc_resolve_blocks (code->block, ns); + break; + } + + if (omp_workshare_save != -1) + omp_workshare_flag = omp_workshare_save; + } t = gfc_resolve_expr (code->expr); if (gfc_resolve_expr (code->expr2) == FAILURE) @@ -4358,7 +4412,11 @@ resolve_code (gfc_code * code, gfc_namespace * ns) case EXEC_DO: if (code->ext.iterator != NULL) - gfc_resolve_iterator (code->ext.iterator, true); + { + gfc_iterator *iter = code->ext.iterator; + if (gfc_resolve_iterator (iter, true) != FAILURE) + gfc_resolve_do_iterator (code, iter->var->symtree->n.sym); + } break; case EXEC_DO_WHILE: @@ -4456,6 +4514,29 @@ resolve_code (gfc_code * code, gfc_namespace * ns) &code->expr->where); break; + case EXEC_OMP_ATOMIC: + case EXEC_OMP_BARRIER: + case EXEC_OMP_CRITICAL: + case EXEC_OMP_FLUSH: + case EXEC_OMP_DO: + case EXEC_OMP_MASTER: + case EXEC_OMP_ORDERED: + case EXEC_OMP_SECTIONS: + case EXEC_OMP_SINGLE: + case EXEC_OMP_WORKSHARE: + gfc_resolve_omp_directive (code, ns); + break; + + case EXEC_OMP_PARALLEL: + case EXEC_OMP_PARALLEL_DO: + case EXEC_OMP_PARALLEL_SECTIONS: + case EXEC_OMP_PARALLEL_WORKSHARE: + omp_workshare_save = omp_workshare_flag; + omp_workshare_flag = 0; + gfc_resolve_omp_directive (code, ns); + omp_workshare_flag = omp_workshare_save; + break; + default: gfc_internal_error ("resolve_code(): Bad statement code"); } @@ -5133,6 +5214,14 @@ resolve_symbol (gfc_symbol * sym) gfc_resolve (sym->formal_ns); formal_ns_flag = formal_ns_save; } + + /* Check threadprivate restrictions. */ + if (sym->attr.threadprivate && !sym->attr.save + && (!sym->attr.in_common + && sym->module == NULL + && (sym->ns->proc_name == NULL + || sym->ns->proc_name->attr.flavor != FL_MODULE))) + gfc_error ("Threadprivate at %L isn't SAVEd", &sym->declared_at); } diff --git a/gcc/fortran/scanner.c b/gcc/fortran/scanner.c index 690d6d78766..2aadc1cc68e 100644 --- a/gcc/fortran/scanner.c +++ b/gcc/fortran/scanner.c @@ -1,5 +1,5 @@ /* Character scanner. - Copyright (C) 2000, 2001, 2002, 2003, 2004, 2005 + Copyright (C) 2000, 2001, 2002, 2003, 2004, 2005, 2006 Free Software Foundation, Inc. Contributed by Andy Vaught @@ -60,7 +60,8 @@ static gfc_directorylist *include_dirs; static gfc_file *file_head, *current_file; -static int continue_flag, end_flag; +static int continue_flag, end_flag, openmp_flag; +static locus openmp_locus; gfc_source_form gfc_current_form; static gfc_linebuf *line_head, *line_tail; @@ -328,17 +329,17 @@ skip_free_comments (void) { locus start; char c; + int at_bol; for (;;) { + at_bol = gfc_at_bol (); start = gfc_current_locus; if (gfc_at_eof ()) break; do - { - c = next_char (); - } + c = next_char (); while (gfc_is_whitespace (c)); if (c == '\n') @@ -349,6 +350,46 @@ skip_free_comments (void) if (c == '!') { + /* If -fopenmp, we need to handle here 2 things: + 1) don't treat !$omp as comments, but directives + 2) handle OpenMP conditional compilation, where + !$ should be treated as 2 spaces (for initial lines + only if followed by space). */ + if (gfc_option.flag_openmp && at_bol) + { + locus old_loc = gfc_current_locus; + if (next_char () == '$') + { + c = next_char (); + if (c == 'o' || c == 'O') + { + if (((c = next_char ()) == 'm' || c == 'M') + && ((c = next_char ()) == 'p' || c == 'P') + && ((c = next_char ()) == ' ' || continue_flag)) + { + while (gfc_is_whitespace (c)) + c = next_char (); + if (c != '\n' && c != '!') + { + openmp_flag = 1; + openmp_locus = old_loc; + gfc_current_locus = start; + return; + } + } + gfc_current_locus = old_loc; + next_char (); + c = next_char (); + } + if (continue_flag || c == ' ') + { + gfc_current_locus = old_loc; + next_char (); + return; + } + } + gfc_current_locus = old_loc; + } skip_comment_line (); continue; } @@ -356,6 +397,8 @@ skip_free_comments (void) break; } + if (openmp_flag && at_bol) + openmp_flag = 0; gfc_current_locus = start; } @@ -372,6 +415,28 @@ skip_fixed_comments (void) int col; char c; + if (! gfc_at_bol ()) + { + start = gfc_current_locus; + if (! gfc_at_eof ()) + { + do + c = next_char (); + while (gfc_is_whitespace (c)); + + if (c == '\n') + gfc_advance_line (); + else if (c == '!') + skip_comment_line (); + } + + if (! gfc_at_bol ()) + { + gfc_current_locus = start; + return; + } + } + for (;;) { start = gfc_current_locus; @@ -387,6 +452,66 @@ skip_fixed_comments (void) if (c == '!' || c == 'c' || c == 'C' || c == '*') { + /* If -fopenmp, we need to handle here 2 things: + 1) don't treat !$omp|c$omp|*$omp as comments, but directives + 2) handle OpenMP conditional compilation, where + !$|c$|*$ should be treated as 2 spaces if the characters + in columns 3 to 6 are valid fixed form label columns + characters. */ + if (gfc_option.flag_openmp) + { + if (next_char () == '$') + { + c = next_char (); + if (c == 'o' || c == 'O') + { + if (((c = next_char ()) == 'm' || c == 'M') + && ((c = next_char ()) == 'p' || c == 'P')) + { + c = next_char (); + if (c != '\n' + && ((openmp_flag && continue_flag) + || c == ' ' || c == '0')) + { + c = next_char (); + while (gfc_is_whitespace (c)) + c = next_char (); + if (c != '\n' && c != '!') + { + /* Canonicalize to *$omp. */ + *start.nextc = '*'; + openmp_flag = 1; + gfc_current_locus = start; + return; + } + } + } + } + else + { + int digit_seen = 0; + + for (col = 3; col < 6; col++, c = next_char ()) + if (c == ' ') + continue; + else if (c < '0' || c > '9') + break; + else + digit_seen = 1; + + if (col == 6 && c != '\n' + && ((continue_flag && !digit_seen) + || c == ' ' || c == '0')) + { + gfc_current_locus = start; + start.nextc[0] = ' '; + start.nextc[1] = ' '; + continue; + } + } + } + gfc_current_locus = start; + } skip_comment_line (); continue; } @@ -425,18 +550,17 @@ skip_fixed_comments (void) break; } + openmp_flag = 0; gfc_current_locus = start; } -/* Skips the current line if it is a comment. Assumes that we are at - the start of the current line. */ +/* Skips the current line if it is a comment. */ void gfc_skip_comments (void) { - - if (!gfc_at_bol () || gfc_current_form == FORM_FREE) + if (gfc_current_form == FORM_FREE) skip_free_comments (); else skip_fixed_comments (); @@ -454,7 +578,7 @@ int gfc_next_char_literal (int in_string) { locus old_loc; - int i, c; + int i, c, prev_openmp_flag; continue_flag = 0; @@ -465,9 +589,13 @@ restart: if (gfc_current_form == FORM_FREE) { - if (!in_string && c == '!') { + if (openmp_flag + && memcmp (&gfc_current_locus, &openmp_locus, + sizeof (gfc_current_locus)) == 0) + goto done; + /* This line can't be continued */ do { @@ -485,7 +613,7 @@ restart: goto done; /* If the next nonblank character is a ! or \n, we've got a - continuation line. */ + continuation line. */ old_loc = gfc_current_locus; c = next_char (); @@ -493,7 +621,7 @@ restart: c = next_char (); /* Character constants to be continued cannot have commentary - after the '&'. */ + after the '&'. */ if (in_string && c != '\n') { @@ -509,6 +637,7 @@ restart: goto done; } + prev_openmp_flag = openmp_flag; continue_flag = 1; if (c == '!') skip_comment_line (); @@ -516,13 +645,21 @@ restart: gfc_advance_line (); /* We've got a continuation line and need to find where it continues. - First eat any comment lines. */ + First eat any comment lines. */ gfc_skip_comments (); + if (prev_openmp_flag != openmp_flag) + { + gfc_current_locus = old_loc; + openmp_flag = prev_openmp_flag; + c = '&'; + goto done; + } + /* Now that we have a non-comment line, probe ahead for the - first non-whitespace character. If it is another '&', then - reading starts at the next character, otherwise we must back - up to where the whitespace started and resume from there. */ + first non-whitespace character. If it is another '&', then + reading starts at the next character, otherwise we must back + up to where the whitespace started and resume from there. */ old_loc = gfc_current_locus; @@ -530,9 +667,20 @@ restart: while (gfc_is_whitespace (c)) c = next_char (); + if (openmp_flag) + { + for (i = 0; i < 5; i++, c = next_char ()) + { + gcc_assert (TOLOWER (c) == "!$omp"[i]); + if (i == 4) + old_loc = gfc_current_locus; + } + while (gfc_is_whitespace (c)) + c = next_char (); + } + if (c != '&') gfc_current_locus = old_loc; - } else { @@ -553,6 +701,7 @@ restart: if (c != '\n') goto done; + prev_openmp_flag = openmp_flag; continue_flag = 1; old_loc = gfc_current_locus; @@ -560,15 +709,29 @@ restart: gfc_skip_comments (); /* See if this line is a continuation line. */ - for (i = 0; i < 5; i++) + if (openmp_flag != prev_openmp_flag) { - c = next_char (); - if (c != ' ') - goto not_continuation; + openmp_flag = prev_openmp_flag; + goto not_continuation; } + if (!openmp_flag) + for (i = 0; i < 5; i++) + { + c = next_char (); + if (c != ' ') + goto not_continuation; + } + else + for (i = 0; i < 5; i++) + { + c = next_char (); + if (TOLOWER (c) != "*$omp"[i]) + goto not_continuation; + } + c = next_char (); - if (c == '0' || c == ' ') + if (c == '0' || c == ' ' || c == '\n') goto not_continuation; } diff --git a/gcc/fortran/st.c b/gcc/fortran/st.c index dc0a01e01a3..e7461a70c5d 100644 --- a/gcc/fortran/st.c +++ b/gcc/fortran/st.c @@ -1,5 +1,6 @@ /* Build executable statement trees. - Copyright (C) 2000, 2001, 2002, 2004, 2005 Free Software Foundation, Inc. + Copyright (C) 2000, 2001, 2002, 2004, 2005, 2006 + Free Software Foundation, Inc. Contributed by Andy Vaught This file is part of GCC. @@ -161,6 +162,33 @@ gfc_free_statement (gfc_code * p) gfc_free_forall_iterator (p->ext.forall_iterator); break; + case EXEC_OMP_DO: + case EXEC_OMP_END_SINGLE: + case EXEC_OMP_PARALLEL: + case EXEC_OMP_PARALLEL_DO: + case EXEC_OMP_PARALLEL_SECTIONS: + case EXEC_OMP_SECTIONS: + case EXEC_OMP_SINGLE: + case EXEC_OMP_WORKSHARE: + case EXEC_OMP_PARALLEL_WORKSHARE: + gfc_free_omp_clauses (p->ext.omp_clauses); + break; + + case EXEC_OMP_CRITICAL: + gfc_free ((char *) p->ext.omp_name); + break; + + case EXEC_OMP_FLUSH: + gfc_free_namelist (p->ext.omp_namelist); + break; + + case EXEC_OMP_ATOMIC: + case EXEC_OMP_BARRIER: + case EXEC_OMP_MASTER: + case EXEC_OMP_ORDERED: + case EXEC_OMP_END_NOWAIT: + break; + default: gfc_internal_error ("gfc_free_statement(): Bad statement"); } diff --git a/gcc/fortran/symbol.c b/gcc/fortran/symbol.c index 111c6926473..7fc7ef1b6f8 100644 --- a/gcc/fortran/symbol.c +++ b/gcc/fortran/symbol.c @@ -265,6 +265,7 @@ check_conflict (symbol_attribute * attr, const char * name, locus * where) *dimension = "DIMENSION", *in_equivalence = "EQUIVALENCE", *use_assoc = "USE ASSOCIATED", *cray_pointer = "CRAY POINTER", *cray_pointee = "CRAY POINTEE", *data = "DATA"; + static const char *threadprivate = "THREADPRIVATE"; const char *a1, *a2; @@ -308,6 +309,7 @@ check_conflict (symbol_attribute * attr, const char * name, locus * where) } conf (dummy, save); + conf (dummy, threadprivate); conf (pointer, target); conf (pointer, external); conf (pointer, intrinsic); @@ -347,6 +349,7 @@ check_conflict (symbol_attribute * attr, const char * name, locus * where) conf (in_equivalence, result); conf (in_equivalence, entry); conf (in_equivalence, allocatable); + conf (in_equivalence, threadprivate); conf (in_namelist, pointer); conf (in_namelist, allocatable); @@ -381,6 +384,7 @@ check_conflict (symbol_attribute * attr, const char * name, locus * where) conf (cray_pointee, entry); conf (cray_pointee, in_common); conf (cray_pointee, in_equivalence); + conf (cray_pointee, threadprivate); conf (data, dummy); conf (data, function); @@ -417,6 +421,7 @@ check_conflict (symbol_attribute * attr, const char * name, locus * where) conf2 (optional); conf2 (function); conf2 (subroutine); + conf2 (threadprivate); break; case FL_VARIABLE: @@ -435,6 +440,7 @@ check_conflict (symbol_attribute * attr, const char * name, locus * where) conf2(result); conf2(in_namelist); conf2(function); + conf2(threadprivate); } switch (attr->proc) @@ -452,6 +458,7 @@ check_conflict (symbol_attribute * attr, const char * name, locus * where) conf2 (result); conf2 (in_common); conf2 (save); + conf2 (threadprivate); break; default: @@ -472,6 +479,7 @@ check_conflict (symbol_attribute * attr, const char * name, locus * where) conf2 (entry); conf2 (function); conf2 (subroutine); + conf2 (threadprivate); if (attr->intent != INTENT_UNKNOWN) { @@ -493,6 +501,7 @@ check_conflict (symbol_attribute * attr, const char * name, locus * where) conf2 (dummy); conf2 (in_common); conf2 (save); + conf2 (threadprivate); break; default: @@ -781,6 +790,23 @@ gfc_add_save (symbol_attribute * attr, const char *name, locus * where) } +try +gfc_add_threadprivate (symbol_attribute * attr, const char *name, locus * where) +{ + if (check_used (attr, name, where)) + return FAILURE; + + if (attr->threadprivate) + { + duplicate_attr ("THREADPRIVATE", where); + return FAILURE; + } + + attr->threadprivate = 1; + return check_conflict (attr, name, where); +} + + try gfc_add_target (symbol_attribute * attr, locus * where) { @@ -1191,6 +1217,8 @@ gfc_copy_attr (symbol_attribute * dest, symbol_attribute * src, locus * where) goto fail; if (src->save && gfc_add_save (dest, NULL, where) == FAILURE) goto fail; + if (src->threadprivate && gfc_add_threadprivate (dest, NULL, where) == FAILURE) + goto fail; if (src->target && gfc_add_target (dest, where) == FAILURE) goto fail; if (src->dummy && gfc_add_dummy (dest, NULL, where) == FAILURE) diff --git a/gcc/fortran/trans-common.c b/gcc/fortran/trans-common.c index ebd7f52627e..c8f92bd329b 100644 --- a/gcc/fortran/trans-common.c +++ b/gcc/fortran/trans-common.c @@ -1,5 +1,6 @@ /* Common block and equivalence list handling - Copyright (C) 2000, 2003, 2004, 2005 Free Software Foundation, Inc. + Copyright (C) 2000, 2003, 2004, 2005, 2006 + Free Software Foundation, Inc. Contributed by Canqun Yang This file is part of GCC. @@ -96,6 +97,7 @@ Software Foundation, 51 Franklin Street, Fifth Floor, Boston, MA #include "config.h" #include "system.h" #include "coretypes.h" +#include "target.h" #include "tree.h" #include "toplev.h" #include "tm.h" @@ -103,6 +105,7 @@ Software Foundation, 51 Franklin Street, Fifth Floor, Boston, MA #include "trans.h" #include "trans-types.h" #include "trans-const.h" +#include "rtl.h" /* Holds a single variable in an equivalence set. */ @@ -278,6 +281,7 @@ build_equiv_decl (tree union_type, bool is_init, bool is_saved) { decl = gfc_create_var (union_type, "equiv"); TREE_STATIC (decl) = 1; + GFC_DECL_COMMON_OR_EQUIV (decl) = 1; return decl; } @@ -292,6 +296,7 @@ build_equiv_decl (tree union_type, bool is_init, bool is_saved) TREE_ADDRESSABLE (decl) = 1; TREE_USED (decl) = 1; + GFC_DECL_COMMON_OR_EQUIV (decl) = 1; /* The source location has been lost, and doesn't really matter. We need to set it to something though. */ @@ -349,9 +354,13 @@ build_common_decl (gfc_common_head *com, tree union_type, bool is_init) TREE_STATIC (decl) = 1; DECL_ALIGN (decl) = BIGGEST_ALIGNMENT; DECL_USER_ALIGN (decl) = 0; + GFC_DECL_COMMON_OR_EQUIV (decl) = 1; gfc_set_decl_location (decl, &com->where); + if (com->threadprivate && targetm.have_tls) + DECL_TLS_MODEL (decl) = decl_default_tls_model (decl); + /* Place the back end declaration for this common block in GLOBAL_BINDING_LEVEL. */ common_sym->backend_decl = pushdecl_top_level (decl); @@ -493,6 +502,7 @@ create_common (gfc_common_head *com, segment_info * head, bool saw_equiv) build3 (COMPONENT_REF, TREE_TYPE (s->field), decl, s->field, NULL_TREE)); DECL_HAS_VALUE_EXPR_P (var_decl) = 1; + GFC_DECL_COMMON_OR_EQUIV (var_decl) = 1; if (s->sym->attr.assign) { diff --git a/gcc/fortran/trans-decl.c b/gcc/fortran/trans-decl.c index 3d43c66fa70..1def170e64f 100644 --- a/gcc/fortran/trans-decl.c +++ b/gcc/fortran/trans-decl.c @@ -40,6 +40,7 @@ Software Foundation, 51 Franklin Street, Fifth Floor, Boston, MA #include "trans-types.h" #include "trans-array.h" #include "trans-const.h" +#include "rtl.h" /* Only for gfc_trans_code. Shouldn't need to include this. */ #include "trans-stmt.h" @@ -389,6 +390,7 @@ gfc_finish_cray_pointee (tree decl, gfc_symbol *sym) SET_DECL_VALUE_EXPR (decl, value); DECL_HAS_VALUE_EXPR_P (decl) = 1; + GFC_DECL_CRAY_POINTEE (decl) = 1; /* This is a fake variable just for debugging purposes. */ TREE_ASM_WRITTEN (decl) = 1; } @@ -508,6 +510,11 @@ gfc_finish_var_decl (tree decl, gfc_symbol * sym) && INTEGER_CST_P (DECL_SIZE_UNIT (decl)) && !gfc_can_put_var_on_stack (DECL_SIZE_UNIT (decl))) TREE_STATIC (decl) = 1; + + /* Handle threadprivate variables. */ + if (sym->attr.threadprivate && targetm.have_tls + && (TREE_STATIC (decl) || DECL_EXTERNAL (decl))) + DECL_TLS_MODEL (decl) = decl_default_tls_model (decl); } @@ -1473,6 +1480,11 @@ gfc_gimplify_function (tree fndecl) gimplify_function_tree (fndecl); dump_function (TDI_generic, fndecl); + /* Generate errors for structured block violations. */ + /* ??? Could be done as part of resolve_labels. */ + if (flag_openmp) + diagnose_omp_structured_block_errors (fndecl); + /* Convert all nested functions to GIMPLE now. We do things in this order so that items like VLA sizes are expanded properly in the context of the correct function. */ @@ -1755,6 +1767,7 @@ gfc_get_fake_result_decl (gfc_symbol * sym) NULL_TREE); } var = gfc_create_var (TREE_TYPE (decl), sym->name); + GFC_DECL_RESULT (var) = 1; SET_DECL_VALUE_EXPR (var, decl); DECL_HAS_VALUE_EXPR_P (var) = 1; TREE_CHAIN (current_fake_result_decl) @@ -1806,6 +1819,7 @@ gfc_get_fake_result_decl (gfc_symbol * sym) DECL_EXTERNAL (decl) = 0; TREE_PUBLIC (decl) = 0; TREE_USED (decl) = 1; + GFC_DECL_RESULT (decl) = 1; layout_decl (decl, 0); diff --git a/gcc/fortran/trans-openmp.c b/gcc/fortran/trans-openmp.c new file mode 100644 index 00000000000..44be1b752de --- /dev/null +++ b/gcc/fortran/trans-openmp.c @@ -0,0 +1,1203 @@ +/* OpenMP directive translation -- generate GCC trees from gfc_code. + Copyright (C) 2005, 2006 Free Software Foundation, Inc. + Contributed by Jakub Jelinek + +This file is part of GCC. + +GCC is free software; you can redistribute it and/or modify it under +the terms of the GNU General Public License as published by the Free +Software Foundation; either version 2, or (at your option) any later +version. + +GCC is distributed in the hope that it will be useful, but WITHOUT ANY +WARRANTY; without even the implied warranty of MERCHANTABILITY or +FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License +for more details. + +You should have received a copy of the GNU General Public License +along with GCC; see the file COPYING. If not, write to the Free +Software Foundation, 51 Franklin Street, Fifth Floor, Boston, MA +02110-1301, USA. */ + + +#include "config.h" +#include "system.h" +#include "coretypes.h" +#include "tree.h" +#include "tree-gimple.h" +#include "ggc.h" +#include "toplev.h" +#include "real.h" +#include "gfortran.h" +#include "trans.h" +#include "trans-stmt.h" +#include "trans-types.h" +#include "trans-array.h" +#include "trans-const.h" +#include "arith.h" + + +/* True if OpenMP should privatize what this DECL points to rather + than the DECL itself. */ + +bool +gfc_omp_privatize_by_reference (tree decl) +{ + tree type = TREE_TYPE (decl); + + if (TREE_CODE (type) == REFERENCE_TYPE) + return true; + + if (TREE_CODE (type) == POINTER_TYPE) + { + /* POINTER/ALLOCATABLE have aggregate types, all user variables + that have POINTER_TYPE type are supposed to be privatized + by reference. */ + if (!DECL_ARTIFICIAL (decl)) + return true; + + /* Some arrays are expanded as DECL_ARTIFICIAL pointers + by the frontend. */ + if (DECL_LANG_SPECIFIC (decl) + && GFC_DECL_SAVED_DESCRIPTOR (decl)) + return true; + } + + return false; +} + +/* True if OpenMP sharing attribute of DECL is predetermined. */ + +enum omp_clause_default_kind +gfc_omp_predetermined_sharing (tree decl) +{ + if (DECL_ARTIFICIAL (decl) && ! GFC_DECL_RESULT (decl)) + return OMP_CLAUSE_DEFAULT_SHARED; + + /* Cray pointees shouldn't be listed in any clauses and should be + gimplified to dereference of the corresponding Cray pointer. + Make them all private, so that they are emitted in the debug + information. */ + if (GFC_DECL_CRAY_POINTEE (decl)) + return OMP_CLAUSE_DEFAULT_PRIVATE; + + /* COMMON and EQUIVALENCE decls are shared. They + are only referenced through DECL_VALUE_EXPR of the variables + contained in them. If those are privatized, they will not be + gimplified to the COMMON or EQUIVALENCE decls. */ + if (GFC_DECL_COMMON_OR_EQUIV (decl) && ! DECL_HAS_VALUE_EXPR_P (decl)) + return OMP_CLAUSE_DEFAULT_SHARED; + + if (GFC_DECL_RESULT (decl) && ! DECL_HAS_VALUE_EXPR_P (decl)) + return OMP_CLAUSE_DEFAULT_SHARED; + + return OMP_CLAUSE_DEFAULT_UNSPECIFIED; +} + +/* 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 + is going to be shared, false if it is going to be privatized. */ + +bool +gfc_omp_disregard_value_expr (tree decl, bool shared) +{ + if (GFC_DECL_COMMON_OR_EQUIV (decl) + && DECL_HAS_VALUE_EXPR_P (decl)) + { + tree value = DECL_VALUE_EXPR (decl); + + if (TREE_CODE (value) == COMPONENT_REF + && TREE_CODE (TREE_OPERAND (value, 0)) == VAR_DECL + && GFC_DECL_COMMON_OR_EQUIV (TREE_OPERAND (value, 0))) + { + /* If variable in COMMON or EQUIVALENCE is privatized, return + true, as just that variable is supposed to be privatized, + not the whole COMMON or whole EQUIVALENCE. + For shared variables in COMMON or EQUIVALENCE, let them be + gimplified to DECL_VALUE_EXPR, so that for multiple shared vars + from the same COMMON or EQUIVALENCE just one sharing of the + whole COMMON or EQUIVALENCE is enough. */ + return ! shared; + } + } + + if (GFC_DECL_RESULT (decl) && DECL_HAS_VALUE_EXPR_P (decl)) + return ! shared; + + return false; +} + +/* Return true if DECL that is shared iff SHARED is true should + be put into OMP_CLAUSE_PRIVATE with OMP_CLAUSE_PRIVATE_DEBUG + flag set. */ + +bool +gfc_omp_private_debug_clause (tree decl, bool shared) +{ + if (GFC_DECL_CRAY_POINTEE (decl)) + return true; + + if (GFC_DECL_COMMON_OR_EQUIV (decl) + && DECL_HAS_VALUE_EXPR_P (decl)) + { + tree value = DECL_VALUE_EXPR (decl); + + if (TREE_CODE (value) == COMPONENT_REF + && TREE_CODE (TREE_OPERAND (value, 0)) == VAR_DECL + && GFC_DECL_COMMON_OR_EQUIV (TREE_OPERAND (value, 0))) + return shared; + } + + return false; +} + +/* Register language specific type size variables as potentially OpenMP + firstprivate variables. */ + +void +gfc_omp_firstprivatize_type_sizes (struct gimplify_omp_ctx *ctx, tree type) +{ + if (GFC_ARRAY_TYPE_P (type) || GFC_DESCRIPTOR_TYPE_P (type)) + { + int r; + + gcc_assert (TYPE_LANG_SPECIFIC (type) != NULL); + for (r = 0; r < GFC_TYPE_ARRAY_RANK (type); r++) + { + omp_firstprivatize_variable (ctx, GFC_TYPE_ARRAY_LBOUND (type, r)); + omp_firstprivatize_variable (ctx, GFC_TYPE_ARRAY_UBOUND (type, r)); + omp_firstprivatize_variable (ctx, GFC_TYPE_ARRAY_STRIDE (type, r)); + } + omp_firstprivatize_variable (ctx, GFC_TYPE_ARRAY_SIZE (type)); + omp_firstprivatize_variable (ctx, GFC_TYPE_ARRAY_OFFSET (type)); + } +} + + +static inline tree +gfc_trans_add_clause (tree node, tree tail) +{ + OMP_CLAUSE_CHAIN (node) = tail; + return node; +} + +static tree +gfc_trans_omp_variable (gfc_symbol *sym) +{ + tree t = gfc_get_symbol_decl (sym); + + /* Special case for assigning the return value of a function. + Self recursive functions must have an explicit return value. */ + if (t == current_function_decl && sym->attr.function + && (sym->result == sym)) + t = gfc_get_fake_result_decl (sym); + + /* Similarly for alternate entry points. */ + else if (sym->attr.function && sym->attr.entry + && (sym->result == sym) + && sym->ns->proc_name->backend_decl == current_function_decl) + { + gfc_entry_list *el = NULL; + + for (el = sym->ns->entries; el; el = el->next) + if (sym == el->sym) + { + t = gfc_get_fake_result_decl (sym); + break; + } + } + + else if (sym->attr.result + && sym->ns->proc_name->backend_decl == current_function_decl + && sym->ns->proc_name->attr.entry_master + && !gfc_return_by_reference (sym->ns->proc_name)) + t = gfc_get_fake_result_decl (sym); + + return t; +} + +static tree +gfc_trans_omp_variable_list (enum omp_clause_code code, gfc_namelist *namelist, + tree list) +{ + for (; namelist != NULL; namelist = namelist->next) + if (namelist->sym->attr.referenced) + { + tree t = gfc_trans_omp_variable (namelist->sym); + if (t != error_mark_node) + { + tree node = build_omp_clause (code); + OMP_CLAUSE_DECL (node) = t; + list = gfc_trans_add_clause (node, list); + } + } + return list; +} + +static void +gfc_trans_omp_array_reduction (tree c, gfc_symbol *sym, locus where) +{ + gfc_symtree *root1 = NULL, *root2 = NULL, *root3 = NULL, *root4 = NULL; + gfc_symtree *symtree1, *symtree2, *symtree3, *symtree4 = NULL; + gfc_symbol init_val_sym, outer_sym, intrinsic_sym; + gfc_expr *e1, *e2, *e3, *e4; + gfc_ref *ref; + tree decl, backend_decl; + locus old_loc = gfc_current_locus; + const char *iname; + try t; + + decl = OMP_CLAUSE_DECL (c); + gfc_current_locus = where; + + /* Create a fake symbol for init value. */ + memset (&init_val_sym, 0, sizeof (init_val_sym)); + init_val_sym.ns = sym->ns; + init_val_sym.name = sym->name; + init_val_sym.ts = sym->ts; + init_val_sym.attr.referenced = 1; + init_val_sym.declared_at = where; + backend_decl = omp_reduction_init (c, gfc_sym_type (&init_val_sym)); + init_val_sym.backend_decl = backend_decl; + + /* Create a fake symbol for the outer array reference. */ + outer_sym = *sym; + outer_sym.as = gfc_copy_array_spec (sym->as); + outer_sym.attr.dummy = 0; + outer_sym.attr.result = 0; + outer_sym.backend_decl = create_tmp_var_raw (TREE_TYPE (decl), NULL); + + /* Create fake symtrees for it. */ + symtree1 = gfc_new_symtree (&root1, sym->name); + symtree1->n.sym = sym; + gcc_assert (symtree1 == root1); + + symtree2 = gfc_new_symtree (&root2, sym->name); + symtree2->n.sym = &init_val_sym; + gcc_assert (symtree2 == root2); + + symtree3 = gfc_new_symtree (&root3, sym->name); + symtree3->n.sym = &outer_sym; + gcc_assert (symtree3 == root3); + + /* Create expressions. */ + e1 = gfc_get_expr (); + e1->expr_type = EXPR_VARIABLE; + e1->where = where; + e1->symtree = symtree1; + e1->ts = sym->ts; + e1->ref = ref = gfc_get_ref (); + ref->u.ar.where = where; + ref->u.ar.as = sym->as; + ref->u.ar.type = AR_FULL; + ref->u.ar.dimen = 0; + t = gfc_resolve_expr (e1); + gcc_assert (t == SUCCESS); + + e2 = gfc_get_expr (); + e2->expr_type = EXPR_VARIABLE; + e2->where = where; + e2->symtree = symtree2; + e2->ts = sym->ts; + t = gfc_resolve_expr (e2); + gcc_assert (t == SUCCESS); + + e3 = gfc_copy_expr (e1); + e3->symtree = symtree3; + t = gfc_resolve_expr (e3); + gcc_assert (t == SUCCESS); + + iname = NULL; + switch (OMP_CLAUSE_REDUCTION_CODE (c)) + { + case PLUS_EXPR: + case MINUS_EXPR: + e4 = gfc_add (e3, e1); + break; + case MULT_EXPR: + e4 = gfc_multiply (e3, e1); + break; + case TRUTH_ANDIF_EXPR: + e4 = gfc_and (e3, e1); + break; + case TRUTH_ORIF_EXPR: + e4 = gfc_or (e3, e1); + break; + case EQ_EXPR: + e4 = gfc_eqv (e3, e1); + break; + case NE_EXPR: + e4 = gfc_neqv (e3, e1); + break; + case MIN_EXPR: + iname = "min"; + break; + case MAX_EXPR: + iname = "max"; + break; + case BIT_AND_EXPR: + iname = "iand"; + break; + case BIT_IOR_EXPR: + iname = "ior"; + break; + case BIT_XOR_EXPR: + iname = "ieor"; + break; + default: + gcc_unreachable (); + } + if (iname != NULL) + { + memset (&intrinsic_sym, 0, sizeof (intrinsic_sym)); + intrinsic_sym.ns = sym->ns; + intrinsic_sym.name = iname; + intrinsic_sym.ts = sym->ts; + intrinsic_sym.attr.referenced = 1; + intrinsic_sym.attr.intrinsic = 1; + intrinsic_sym.attr.function = 1; + intrinsic_sym.result = &intrinsic_sym; + intrinsic_sym.declared_at = where; + + symtree4 = gfc_new_symtree (&root4, iname); + symtree4->n.sym = &intrinsic_sym; + gcc_assert (symtree4 == root4); + + e4 = gfc_get_expr (); + e4->expr_type = EXPR_FUNCTION; + e4->where = where; + e4->symtree = symtree4; + e4->value.function.isym = gfc_find_function (iname); + e4->value.function.actual = gfc_get_actual_arglist (); + e4->value.function.actual->expr = e3; + e4->value.function.actual->next = gfc_get_actual_arglist (); + e4->value.function.actual->next->expr = e1; + } + /* e1 and e3 have been stored as arguments of e4, avoid sharing. */ + e1 = gfc_copy_expr (e1); + e3 = gfc_copy_expr (e3); + t = gfc_resolve_expr (e4); + gcc_assert (t == SUCCESS); + + /* Create the init statement list. */ + OMP_CLAUSE_REDUCTION_INIT (c) = gfc_trans_assignment (e1, e2); + + /* Create the merge statement list. */ + OMP_CLAUSE_REDUCTION_MERGE (c) = gfc_trans_assignment (e3, e4); + + /* And stick the placeholder VAR_DECL into the clause as well. */ + OMP_CLAUSE_REDUCTION_PLACEHOLDER (c) = outer_sym.backend_decl; + + gfc_current_locus = old_loc; + + gfc_free_expr (e1); + gfc_free_expr (e2); + gfc_free_expr (e3); + gfc_free_expr (e4); + gfc_free (symtree1); + gfc_free (symtree2); + gfc_free (symtree3); + if (symtree4) + gfc_free (symtree4); + gfc_free_array_spec (outer_sym.as); +} + +static tree +gfc_trans_omp_reduction_list (gfc_namelist *namelist, tree list, + enum tree_code reduction_code, locus where) +{ + for (; namelist != NULL; namelist = namelist->next) + if (namelist->sym->attr.referenced) + { + tree t = gfc_trans_omp_variable (namelist->sym); + if (t != error_mark_node) + { + tree node = build_omp_clause (OMP_CLAUSE_REDUCTION); + OMP_CLAUSE_DECL (node) = t; + OMP_CLAUSE_REDUCTION_CODE (node) = reduction_code; + if (namelist->sym->attr.dimension) + gfc_trans_omp_array_reduction (node, namelist->sym, where); + list = gfc_trans_add_clause (node, list); + } + } + return list; +} + +static tree +gfc_trans_omp_clauses (stmtblock_t *block, gfc_omp_clauses *clauses, + locus where) +{ + tree omp_clauses = NULL_TREE, chunk_size, c, old_clauses; + int list; + enum omp_clause_code clause_code; + gfc_se se; + + if (clauses == NULL) + return NULL_TREE; + + for (list = 0; list < OMP_LIST_NUM; list++) + { + gfc_namelist *n = clauses->lists[list]; + + if (n == NULL) + continue; + if (list >= OMP_LIST_REDUCTION_FIRST + && list <= OMP_LIST_REDUCTION_LAST) + { + enum tree_code reduction_code; + switch (list) + { + case OMP_LIST_PLUS: + reduction_code = PLUS_EXPR; + break; + case OMP_LIST_MULT: + reduction_code = MULT_EXPR; + break; + case OMP_LIST_SUB: + reduction_code = MINUS_EXPR; + break; + case OMP_LIST_AND: + reduction_code = TRUTH_ANDIF_EXPR; + break; + case OMP_LIST_OR: + reduction_code = TRUTH_ORIF_EXPR; + break; + case OMP_LIST_EQV: + reduction_code = EQ_EXPR; + break; + case OMP_LIST_NEQV: + reduction_code = NE_EXPR; + break; + case OMP_LIST_MAX: + reduction_code = MAX_EXPR; + break; + case OMP_LIST_MIN: + reduction_code = MIN_EXPR; + break; + case OMP_LIST_IAND: + reduction_code = BIT_AND_EXPR; + break; + case OMP_LIST_IOR: + reduction_code = BIT_IOR_EXPR; + break; + case OMP_LIST_IEOR: + reduction_code = BIT_XOR_EXPR; + break; + default: + gcc_unreachable (); + } + old_clauses = omp_clauses; + omp_clauses + = gfc_trans_omp_reduction_list (n, omp_clauses, reduction_code, + where); + continue; + } + switch (list) + { + case OMP_LIST_PRIVATE: + clause_code = OMP_CLAUSE_PRIVATE; + goto add_clause; + case OMP_LIST_SHARED: + clause_code = OMP_CLAUSE_SHARED; + goto add_clause; + case OMP_LIST_FIRSTPRIVATE: + clause_code = OMP_CLAUSE_FIRSTPRIVATE; + goto add_clause; + case OMP_LIST_LASTPRIVATE: + clause_code = OMP_CLAUSE_LASTPRIVATE; + goto add_clause; + case OMP_LIST_COPYIN: + clause_code = OMP_CLAUSE_COPYIN; + goto add_clause; + case OMP_LIST_COPYPRIVATE: + clause_code = OMP_CLAUSE_COPYPRIVATE; + /* FALLTHROUGH */ + add_clause: + omp_clauses + = gfc_trans_omp_variable_list (clause_code, n, omp_clauses); + break; + default: + break; + } + } + + if (clauses->if_expr) + { + tree if_var; + + gfc_init_se (&se, NULL); + gfc_conv_expr (&se, clauses->if_expr); + gfc_add_block_to_block (block, &se.pre); + if_var = gfc_evaluate_now (se.expr, block); + gfc_add_block_to_block (block, &se.post); + + c = build_omp_clause (OMP_CLAUSE_IF); + OMP_CLAUSE_IF_EXPR (c) = if_var; + omp_clauses = gfc_trans_add_clause (c, omp_clauses); + } + + if (clauses->num_threads) + { + tree num_threads; + + gfc_init_se (&se, NULL); + gfc_conv_expr (&se, clauses->num_threads); + gfc_add_block_to_block (block, &se.pre); + num_threads = gfc_evaluate_now (se.expr, block); + gfc_add_block_to_block (block, &se.post); + + c = build_omp_clause (OMP_CLAUSE_NUM_THREADS); + OMP_CLAUSE_NUM_THREADS_EXPR (c) = num_threads; + omp_clauses = gfc_trans_add_clause (c, omp_clauses); + } + + chunk_size = NULL_TREE; + if (clauses->chunk_size) + { + gfc_init_se (&se, NULL); + gfc_conv_expr (&se, clauses->chunk_size); + gfc_add_block_to_block (block, &se.pre); + chunk_size = gfc_evaluate_now (se.expr, block); + gfc_add_block_to_block (block, &se.post); + } + + if (clauses->sched_kind != OMP_SCHED_NONE) + { + c = build_omp_clause (OMP_CLAUSE_SCHEDULE); + OMP_CLAUSE_SCHEDULE_CHUNK_EXPR (c) = chunk_size; + switch (clauses->sched_kind) + { + case OMP_SCHED_STATIC: + OMP_CLAUSE_SCHEDULE_KIND (c) = OMP_CLAUSE_SCHEDULE_STATIC; + break; + case OMP_SCHED_DYNAMIC: + OMP_CLAUSE_SCHEDULE_KIND (c) = OMP_CLAUSE_SCHEDULE_DYNAMIC; + break; + case OMP_SCHED_GUIDED: + OMP_CLAUSE_SCHEDULE_KIND (c) = OMP_CLAUSE_SCHEDULE_GUIDED; + break; + case OMP_SCHED_RUNTIME: + OMP_CLAUSE_SCHEDULE_KIND (c) = OMP_CLAUSE_SCHEDULE_RUNTIME; + break; + default: + gcc_unreachable (); + } + omp_clauses = gfc_trans_add_clause (c, omp_clauses); + } + + if (clauses->default_sharing != OMP_DEFAULT_UNKNOWN) + { + c = build_omp_clause (OMP_CLAUSE_DEFAULT); + switch (clauses->default_sharing) + { + case OMP_DEFAULT_NONE: + OMP_CLAUSE_DEFAULT_KIND (c) = OMP_CLAUSE_DEFAULT_NONE; + break; + case OMP_DEFAULT_SHARED: + OMP_CLAUSE_DEFAULT_KIND (c) = OMP_CLAUSE_DEFAULT_SHARED; + break; + case OMP_DEFAULT_PRIVATE: + OMP_CLAUSE_DEFAULT_KIND (c) = OMP_CLAUSE_DEFAULT_PRIVATE; + break; + default: + gcc_unreachable (); + } + omp_clauses = gfc_trans_add_clause (c, omp_clauses); + } + + if (clauses->nowait) + { + c = build_omp_clause (OMP_CLAUSE_NOWAIT); + omp_clauses = gfc_trans_add_clause (c, omp_clauses); + } + + if (clauses->ordered) + { + c = build_omp_clause (OMP_CLAUSE_ORDERED); + omp_clauses = gfc_trans_add_clause (c, omp_clauses); + } + + return omp_clauses; +} + +/* Like gfc_trans_code, but force creation of a BIND_EXPR around it. */ + +static tree +gfc_trans_omp_code (gfc_code *code, bool force_empty) +{ + tree stmt; + + pushlevel (0); + stmt = gfc_trans_code (code); + if (TREE_CODE (stmt) != BIND_EXPR) + { + if (!IS_EMPTY_STMT (stmt) || force_empty) + { + tree block = poplevel (1, 0, 0); + stmt = build3_v (BIND_EXPR, NULL, stmt, block); + } + else + poplevel (0, 0, 0); + } + else + poplevel (0, 0, 0); + return stmt; +} + + +static tree gfc_trans_omp_sections (gfc_code *, gfc_omp_clauses *); +static tree gfc_trans_omp_workshare (gfc_code *, gfc_omp_clauses *); + +static tree +gfc_trans_omp_atomic (gfc_code *code) +{ + gfc_se lse; + gfc_se rse; + gfc_expr *expr2, *e; + gfc_symbol *var; + stmtblock_t block; + tree lhsaddr, type, rhs, x; + enum tree_code op = ERROR_MARK; + bool var_on_left = false; + + code = code->block->next; + gcc_assert (code->op == EXEC_ASSIGN); + gcc_assert (code->next == NULL); + var = code->expr->symtree->n.sym; + + gfc_init_se (&lse, NULL); + gfc_init_se (&rse, NULL); + gfc_start_block (&block); + + gfc_conv_expr (&lse, code->expr); + gfc_add_block_to_block (&block, &lse.pre); + type = TREE_TYPE (lse.expr); + lhsaddr = gfc_build_addr_expr (NULL, lse.expr); + + expr2 = code->expr2; + if (expr2->expr_type == EXPR_FUNCTION + && expr2->value.function.isym->generic_id == GFC_ISYM_CONVERSION) + expr2 = expr2->value.function.actual->expr; + + if (expr2->expr_type == EXPR_OP) + { + gfc_expr *e; + switch (expr2->value.op.operator) + { + case INTRINSIC_PLUS: + op = PLUS_EXPR; + break; + case INTRINSIC_TIMES: + op = MULT_EXPR; + break; + case INTRINSIC_MINUS: + op = MINUS_EXPR; + break; + case INTRINSIC_DIVIDE: + if (expr2->ts.type == BT_INTEGER) + op = TRUNC_DIV_EXPR; + else + op = RDIV_EXPR; + break; + case INTRINSIC_AND: + op = TRUTH_ANDIF_EXPR; + break; + case INTRINSIC_OR: + op = TRUTH_ORIF_EXPR; + break; + case INTRINSIC_EQV: + op = EQ_EXPR; + break; + case INTRINSIC_NEQV: + op = NE_EXPR; + break; + default: + gcc_unreachable (); + } + e = expr2->value.op.op1; + if (e->expr_type == EXPR_FUNCTION + && e->value.function.isym->generic_id == GFC_ISYM_CONVERSION) + e = e->value.function.actual->expr; + if (e->expr_type == EXPR_VARIABLE + && e->symtree != NULL + && e->symtree->n.sym == var) + { + expr2 = expr2->value.op.op2; + var_on_left = true; + } + else + { + e = expr2->value.op.op2; + if (e->expr_type == EXPR_FUNCTION + && e->value.function.isym->generic_id == GFC_ISYM_CONVERSION) + e = e->value.function.actual->expr; + gcc_assert (e->expr_type == EXPR_VARIABLE + && e->symtree != NULL + && e->symtree->n.sym == var); + expr2 = expr2->value.op.op1; + var_on_left = false; + } + gfc_conv_expr (&rse, expr2); + gfc_add_block_to_block (&block, &rse.pre); + } + else + { + gcc_assert (expr2->expr_type == EXPR_FUNCTION); + switch (expr2->value.function.isym->generic_id) + { + case GFC_ISYM_MIN: + op = MIN_EXPR; + break; + case GFC_ISYM_MAX: + op = MAX_EXPR; + break; + case GFC_ISYM_IAND: + op = BIT_AND_EXPR; + break; + case GFC_ISYM_IOR: + op = BIT_IOR_EXPR; + break; + case GFC_ISYM_IEOR: + op = BIT_XOR_EXPR; + break; + default: + gcc_unreachable (); + } + e = expr2->value.function.actual->expr; + gcc_assert (e->expr_type == EXPR_VARIABLE + && e->symtree != NULL + && e->symtree->n.sym == var); + + gfc_conv_expr (&rse, expr2->value.function.actual->next->expr); + gfc_add_block_to_block (&block, &rse.pre); + if (expr2->value.function.actual->next->next != NULL) + { + tree accum = gfc_create_var (TREE_TYPE (rse.expr), NULL); + gfc_actual_arglist *arg; + + gfc_add_modify_expr (&block, accum, rse.expr); + for (arg = expr2->value.function.actual->next->next; arg; + arg = arg->next) + { + gfc_init_block (&rse.pre); + gfc_conv_expr (&rse, arg->expr); + gfc_add_block_to_block (&block, &rse.pre); + x = fold_build2 (op, TREE_TYPE (accum), accum, rse.expr); + gfc_add_modify_expr (&block, accum, x); + } + + rse.expr = accum; + } + + expr2 = expr2->value.function.actual->next->expr; + } + + lhsaddr = save_expr (lhsaddr); + rhs = gfc_evaluate_now (rse.expr, &block); + x = convert (TREE_TYPE (rhs), build_fold_indirect_ref (lhsaddr)); + + if (var_on_left) + x = fold_build2 (op, TREE_TYPE (rhs), x, rhs); + else + x = fold_build2 (op, TREE_TYPE (rhs), rhs, x); + + if (TREE_CODE (TREE_TYPE (rhs)) == COMPLEX_TYPE + && TREE_CODE (type) != COMPLEX_TYPE) + x = build1 (REALPART_EXPR, TREE_TYPE (TREE_TYPE (rhs)), x); + + x = build2_v (OMP_ATOMIC, lhsaddr, convert (type, x)); + gfc_add_expr_to_block (&block, x); + + gfc_add_block_to_block (&block, &lse.pre); + gfc_add_block_to_block (&block, &rse.pre); + + return gfc_finish_block (&block); +} + +static tree +gfc_trans_omp_barrier (void) +{ + tree decl = built_in_decls [BUILT_IN_GOMP_BARRIER]; + return build_function_call_expr (decl, NULL); +} + +static tree +gfc_trans_omp_critical (gfc_code *code) +{ + tree name = NULL_TREE, stmt; + if (code->ext.omp_name != NULL) + name = get_identifier (code->ext.omp_name); + stmt = gfc_trans_code (code->block->next); + return build2_v (OMP_CRITICAL, stmt, name); +} + +static tree +gfc_trans_omp_do (gfc_code *code, stmtblock_t *pblock, + gfc_omp_clauses *clauses) +{ + gfc_se se; + tree dovar, stmt, from, to, step, type, init, cond, incr; + tree count = NULL_TREE, cycle_label, tmp, omp_clauses; + stmtblock_t block; + stmtblock_t body; + int simple = 0; + bool dovar_found = false; + + code = code->block->next; + gcc_assert (code->op == EXEC_DO); + + if (pblock == NULL) + { + gfc_start_block (&block); + pblock = █ + } + + omp_clauses = gfc_trans_omp_clauses (pblock, clauses, code->loc); + if (clauses) + { + gfc_namelist *n; + for (n = clauses->lists[OMP_LIST_LASTPRIVATE]; n != NULL; n = n->next) + if (code->ext.iterator->var->symtree->n.sym == n->sym) + break; + if (n == NULL) + for (n = clauses->lists[OMP_LIST_PRIVATE]; n != NULL; n = n->next) + if (code->ext.iterator->var->symtree->n.sym == n->sym) + break; + if (n != NULL) + dovar_found = true; + } + + /* Evaluate all the expressions in the iterator. */ + gfc_init_se (&se, NULL); + gfc_conv_expr_lhs (&se, code->ext.iterator->var); + gfc_add_block_to_block (pblock, &se.pre); + dovar = se.expr; + type = TREE_TYPE (dovar); + gcc_assert (TREE_CODE (type) == INTEGER_TYPE); + + gfc_init_se (&se, NULL); + gfc_conv_expr_val (&se, code->ext.iterator->start); + gfc_add_block_to_block (pblock, &se.pre); + from = gfc_evaluate_now (se.expr, pblock); + + gfc_init_se (&se, NULL); + gfc_conv_expr_val (&se, code->ext.iterator->end); + gfc_add_block_to_block (pblock, &se.pre); + to = gfc_evaluate_now (se.expr, pblock); + + gfc_init_se (&se, NULL); + gfc_conv_expr_val (&se, code->ext.iterator->step); + gfc_add_block_to_block (pblock, &se.pre); + step = gfc_evaluate_now (se.expr, pblock); + + /* Special case simple loops. */ + if (integer_onep (step)) + simple = 1; + else if (tree_int_cst_equal (step, integer_minus_one_node)) + simple = -1; + + /* Loop body. */ + if (simple) + { + init = build2_v (MODIFY_EXPR, dovar, from); + cond = build2 (simple > 0 ? LE_EXPR : GE_EXPR, boolean_type_node, + dovar, to); + incr = fold_build2 (PLUS_EXPR, type, dovar, step); + incr = fold_build2 (MODIFY_EXPR, type, dovar, incr); + if (pblock != &block) + { + pushlevel (0); + gfc_start_block (&block); + } + gfc_start_block (&body); + } + else + { + /* STEP is not 1 or -1. Use: + for (count = 0; count < (to + step - from) / step; count++) + { + dovar = from + count * step; + body; + cycle_label:; + } */ + tmp = fold_build2 (MINUS_EXPR, type, step, from); + tmp = fold_build2 (PLUS_EXPR, type, to, tmp); + tmp = fold_build2 (TRUNC_DIV_EXPR, type, tmp, step); + tmp = gfc_evaluate_now (tmp, pblock); + count = gfc_create_var (type, "count"); + init = build2_v (MODIFY_EXPR, count, build_int_cst (type, 0)); + cond = build2 (LT_EXPR, boolean_type_node, count, tmp); + incr = fold_build2 (PLUS_EXPR, type, count, build_int_cst (type, 1)); + incr = fold_build2 (MODIFY_EXPR, type, count, incr); + + if (pblock != &block) + { + pushlevel (0); + gfc_start_block (&block); + } + gfc_start_block (&body); + + /* Initialize DOVAR. */ + tmp = fold_build2 (MULT_EXPR, type, count, step); + tmp = build2 (PLUS_EXPR, type, from, tmp); + gfc_add_modify_expr (&body, dovar, tmp); + } + + if (!dovar_found) + { + tmp = build_omp_clause (OMP_CLAUSE_PRIVATE); + OMP_CLAUSE_DECL (tmp) = dovar; + omp_clauses = gfc_trans_add_clause (tmp, omp_clauses); + } + if (!simple) + { + tmp = build_omp_clause (OMP_CLAUSE_PRIVATE); + OMP_CLAUSE_DECL (tmp) = count; + omp_clauses = gfc_trans_add_clause (tmp, omp_clauses); + } + + /* Cycle statement is implemented with a goto. Exit statement must not be + present for this loop. */ + cycle_label = gfc_build_label_decl (NULL_TREE); + + /* Put these labels where they can be found later. We put the + labels in a TREE_LIST node (because TREE_CHAIN is already + used). cycle_label goes in TREE_PURPOSE (backend_decl), exit + label in TREE_VALUE (backend_decl). */ + + code->block->backend_decl = tree_cons (cycle_label, NULL, NULL); + + /* Main loop body. */ + tmp = gfc_trans_omp_code (code->block->next, true); + gfc_add_expr_to_block (&body, tmp); + + /* Label for cycle statements (if needed). */ + if (TREE_USED (cycle_label)) + { + tmp = build1_v (LABEL_EXPR, cycle_label); + gfc_add_expr_to_block (&body, tmp); + } + + /* End of loop body. */ + stmt = make_node (OMP_FOR); + + TREE_TYPE (stmt) = void_type_node; + OMP_FOR_BODY (stmt) = gfc_finish_block (&body); + OMP_FOR_CLAUSES (stmt) = omp_clauses; + OMP_FOR_INIT (stmt) = init; + OMP_FOR_COND (stmt) = cond; + OMP_FOR_INCR (stmt) = incr; + gfc_add_expr_to_block (&block, stmt); + + return gfc_finish_block (&block); +} + +static tree +gfc_trans_omp_flush (void) +{ + tree decl = built_in_decls [BUILT_IN_SYNCHRONIZE]; + return build_function_call_expr (decl, NULL); +} + +static tree +gfc_trans_omp_master (gfc_code *code) +{ + tree stmt = gfc_trans_code (code->block->next); + if (IS_EMPTY_STMT (stmt)) + return stmt; + return build1_v (OMP_MASTER, stmt); +} + +static tree +gfc_trans_omp_ordered (gfc_code *code) +{ + return build1_v (OMP_ORDERED, gfc_trans_code (code->block->next)); +} + +static tree +gfc_trans_omp_parallel (gfc_code *code) +{ + stmtblock_t block; + tree stmt, omp_clauses; + + gfc_start_block (&block); + omp_clauses = gfc_trans_omp_clauses (&block, code->ext.omp_clauses, + code->loc); + stmt = gfc_trans_omp_code (code->block->next, true); + stmt = build4_v (OMP_PARALLEL, stmt, omp_clauses, NULL, NULL); + gfc_add_expr_to_block (&block, stmt); + return gfc_finish_block (&block); +} + +static tree +gfc_trans_omp_parallel_do (gfc_code *code) +{ + stmtblock_t block, *pblock = NULL; + gfc_omp_clauses parallel_clauses, do_clauses; + tree stmt, omp_clauses = NULL_TREE; + + gfc_start_block (&block); + + memset (&do_clauses, 0, sizeof (do_clauses)); + if (code->ext.omp_clauses != NULL) + { + memcpy (¶llel_clauses, code->ext.omp_clauses, + sizeof (parallel_clauses)); + do_clauses.sched_kind = parallel_clauses.sched_kind; + do_clauses.chunk_size = parallel_clauses.chunk_size; + do_clauses.ordered = parallel_clauses.ordered; + parallel_clauses.sched_kind = OMP_SCHED_NONE; + parallel_clauses.chunk_size = NULL; + parallel_clauses.ordered = false; + omp_clauses = gfc_trans_omp_clauses (&block, ¶llel_clauses, + code->loc); + } + do_clauses.nowait = true; + if (!do_clauses.ordered && do_clauses.sched_kind != OMP_SCHED_STATIC) + pblock = █ + else + pushlevel (0); + stmt = gfc_trans_omp_do (code, pblock, &do_clauses); + if (TREE_CODE (stmt) != BIND_EXPR) + stmt = build3_v (BIND_EXPR, NULL, stmt, poplevel (1, 0, 0)); + else + poplevel (0, 0, 0); + stmt = build4_v (OMP_PARALLEL, stmt, omp_clauses, NULL, NULL); + gfc_add_expr_to_block (&block, stmt); + return gfc_finish_block (&block); +} + +static tree +gfc_trans_omp_parallel_sections (gfc_code *code) +{ + stmtblock_t block; + gfc_omp_clauses section_clauses; + tree stmt, omp_clauses; + + memset (§ion_clauses, 0, sizeof (section_clauses)); + section_clauses.nowait = true; + + gfc_start_block (&block); + omp_clauses = gfc_trans_omp_clauses (&block, code->ext.omp_clauses, + code->loc); + pushlevel (0); + stmt = gfc_trans_omp_sections (code, §ion_clauses); + if (TREE_CODE (stmt) != BIND_EXPR) + stmt = build3_v (BIND_EXPR, NULL, stmt, poplevel (1, 0, 0)); + else + poplevel (0, 0, 0); + stmt = build4_v (OMP_PARALLEL, stmt, omp_clauses, NULL, NULL); + gfc_add_expr_to_block (&block, stmt); + return gfc_finish_block (&block); +} + +static tree +gfc_trans_omp_parallel_workshare (gfc_code *code) +{ + stmtblock_t block; + gfc_omp_clauses workshare_clauses; + tree stmt, omp_clauses; + + memset (&workshare_clauses, 0, sizeof (workshare_clauses)); + workshare_clauses.nowait = true; + + gfc_start_block (&block); + omp_clauses = gfc_trans_omp_clauses (&block, code->ext.omp_clauses, + code->loc); + pushlevel (0); + stmt = gfc_trans_omp_workshare (code, &workshare_clauses); + if (TREE_CODE (stmt) != BIND_EXPR) + stmt = build3_v (BIND_EXPR, NULL, stmt, poplevel (1, 0, 0)); + else + poplevel (0, 0, 0); + stmt = build4_v (OMP_PARALLEL, stmt, omp_clauses, NULL, NULL); + 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; + tree omp_clauses, stmt; + bool has_lastprivate = clauses->lists[OMP_LIST_LASTPRIVATE] != NULL; + + gfc_start_block (&block); + + omp_clauses = gfc_trans_omp_clauses (&block, clauses, code->loc); + + gfc_init_block (&body); + for (code = code->block; code; code = code->block) + { + /* Last section is special because of lastprivate, so even if it + is empty, chain it in. */ + stmt = gfc_trans_omp_code (code->next, + has_lastprivate && code->block == NULL); + if (! IS_EMPTY_STMT (stmt)) + { + stmt = build1_v (OMP_SECTION, stmt); + gfc_add_expr_to_block (&body, stmt); + } + } + stmt = gfc_finish_block (&body); + + stmt = build3_v (OMP_SECTIONS, stmt, omp_clauses, NULL); + gfc_add_expr_to_block (&block, stmt); + + return gfc_finish_block (&block); +} + +static tree +gfc_trans_omp_single (gfc_code *code, gfc_omp_clauses *clauses) +{ + tree omp_clauses = gfc_trans_omp_clauses (NULL, clauses, code->loc); + tree stmt = gfc_trans_omp_code (code->block->next, true); + stmt = build2_v (OMP_SINGLE, stmt, omp_clauses); + return stmt; +} + +static tree +gfc_trans_omp_workshare (gfc_code *code, gfc_omp_clauses *clauses) +{ + /* XXX */ + return gfc_trans_omp_single (code, clauses); +} + +tree +gfc_trans_omp_directive (gfc_code *code) +{ + switch (code->op) + { + case EXEC_OMP_ATOMIC: + return gfc_trans_omp_atomic (code); + case EXEC_OMP_BARRIER: + return gfc_trans_omp_barrier (); + case EXEC_OMP_CRITICAL: + return gfc_trans_omp_critical (code); + case EXEC_OMP_DO: + return gfc_trans_omp_do (code, NULL, code->ext.omp_clauses); + case EXEC_OMP_FLUSH: + return gfc_trans_omp_flush (); + case EXEC_OMP_MASTER: + return gfc_trans_omp_master (code); + 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); + 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_SECTIONS: + return gfc_trans_omp_sections (code, code->ext.omp_clauses); + case EXEC_OMP_SINGLE: + return gfc_trans_omp_single (code, code->ext.omp_clauses); + case EXEC_OMP_WORKSHARE: + return gfc_trans_omp_workshare (code, code->ext.omp_clauses); + default: + gcc_unreachable (); + } +} diff --git a/gcc/fortran/trans-stmt.h b/gcc/fortran/trans-stmt.h index f33d7ac32e9..a71c8bfbede 100644 --- a/gcc/fortran/trans-stmt.h +++ b/gcc/fortran/trans-stmt.h @@ -51,6 +51,9 @@ tree gfc_trans_allocate (gfc_code *); tree gfc_trans_deallocate (gfc_code *); tree gfc_trans_deallocate_array (tree); +/* trans-openmp.c */ +tree gfc_trans_omp_directive (gfc_code *); + /* trans-io.c */ tree gfc_trans_open (gfc_code *); tree gfc_trans_close (gfc_code *); diff --git a/gcc/fortran/trans.c b/gcc/fortran/trans.c index dff50659244..a586932c9d6 100644 --- a/gcc/fortran/trans.c +++ b/gcc/fortran/trans.c @@ -583,6 +583,23 @@ gfc_trans_code (gfc_code * code) res = gfc_trans_dt_end (code); break; + case EXEC_OMP_ATOMIC: + case EXEC_OMP_BARRIER: + case EXEC_OMP_CRITICAL: + case EXEC_OMP_DO: + case EXEC_OMP_FLUSH: + case EXEC_OMP_MASTER: + case EXEC_OMP_ORDERED: + case EXEC_OMP_PARALLEL: + case EXEC_OMP_PARALLEL_DO: + case EXEC_OMP_PARALLEL_SECTIONS: + case EXEC_OMP_PARALLEL_WORKSHARE: + case EXEC_OMP_SECTIONS: + case EXEC_OMP_SINGLE: + case EXEC_OMP_WORKSHARE: + res = gfc_trans_omp_directive (code); + break; + default: internal_error ("gfc_trans_code(): Bad statement code"); } diff --git a/gcc/fortran/trans.h b/gcc/fortran/trans.h index c7c2301a3a0..82f74e049fa 100644 --- a/gcc/fortran/trans.h +++ b/gcc/fortran/trans.h @@ -439,6 +439,14 @@ tree gfc_truthvalue_conversion (tree); tree builtin_function (const char *, tree, int, enum built_in_class, const char *, tree); +/* In trans-openmp.c */ +bool gfc_omp_privatize_by_reference (tree); +enum omp_clause_default_kind gfc_omp_predetermined_sharing (tree); +bool gfc_omp_disregard_value_expr (tree, bool); +bool gfc_omp_private_debug_clause (tree, bool); +struct gimplify_omp_ctx; +void gfc_omp_firstprivatize_type_sizes (struct gimplify_omp_ctx *, tree); + /* Runtime library function decls. */ extern GTY(()) tree gfor_fndecl_internal_malloc; extern GTY(()) tree gfor_fndecl_internal_malloc64; @@ -548,6 +556,9 @@ struct lang_decl GTY(()) #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) +#define GFC_DECL_COMMON_OR_EQUIV(node) DECL_LANG_FLAG_3(node) +#define GFC_DECL_CRAY_POINTEE(node) DECL_LANG_FLAG_4(node) +#define GFC_DECL_RESULT(node) DECL_LANG_FLAG_5(node) /* An array descriptor. */ #define GFC_DESCRIPTOR_TYPE_P(node) TYPE_LANG_FLAG_1(node) @@ -580,6 +591,8 @@ struct lang_decl GTY(()) arg1, arg2) #define build3_v(code, arg1, arg2, arg3) build3(code, void_type_node, \ arg1, arg2, arg3) +#define build4_v(code, arg1, arg2, arg3, arg4) build4(code, void_type_node, \ + arg1, arg2, arg3, arg4) /* This group of functions allows a caller to evaluate an expression from the callee's interface. It establishes a mapping between the interface's diff --git a/gcc/fortran/types.def b/gcc/fortran/types.def new file mode 100644 index 00000000000..5a3e5d72221 --- /dev/null +++ b/gcc/fortran/types.def @@ -0,0 +1,132 @@ +/* Copyright (C) 2001, 2002, 2003, 2004, 2005, 2006 + Free Software Foundation, Inc. + +This file is part of GCC. + +GCC is free software; you can redistribute it and/or modify it under +the terms of the GNU General Public License as published by the Free +Software Foundation; either version 2, or (at your option) any later +version. + +GCC is distributed in the hope that it will be useful, but WITHOUT ANY +WARRANTY; without even the implied warranty of MERCHANTABILITY or +FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License +for more details. + +You should have received a copy of the GNU General Public License +along with GCC; see the file COPYING. If not, write to the Free +Software Foundation, 51 Franklin Street, Fifth Floor, Boston, MA +02110-1301, USA. */ + +/* This header contains a subset of ../builtin-types.def needed for + Fortran frontend builtins. + + Before including this header, you must define the following macros: + + DEF_PRIMITIVE_TYPE (ENUM, TYPE) + + The ENUM is an identifier indicating which type is being defined. + TYPE is an expression for a `tree' that represents the type. + + DEF_FUNCTION_TYPE_0 (ENUM, RETURN) + DEF_FUNCTION_TYPE_1 (ENUM, RETURN, ARG1) + DEF_FUNCTION_TYPE_2 (ENUM, RETURN, ARG1, ARG2) + DEF_FUNCTION_TYPE_3 (ENUM, RETURN, ARG1, ARG2, ARG3) + DEF_FUNCTION_TYPE_4 (ENUM, RETURN, ARG1, ARG2, ARG3, ARG4) + DEF_FUNCTION_TYPE_5 (ENUM, RETURN, ARG1, ARG2, ARG3, ARG4, ARG5) + DEF_FUNCTION_TYPE_6 (ENUM, RETURN, ARG1, ARG2, ARG3, ARG4, ARG5, ARG6) + DEF_FUNCTION_TYPE_7 (ENUM, RETURN, ARG1, ARG2, ARG3, ARG4, ARG5, ARG6, ARG7) + + These macros describe function types. ENUM is as above. The + RETURN type is one of the enumerals already defined. ARG1, ARG2, + and ARG3 give the types of the arguments, similarly. + + DEF_FUNCTION_TYPE_VAR_0 (ENUM, RETURN) + + Similar, but for function types that take variable arguments. + + DEF_POINTER_TYPE (ENUM, TYPE) + + This macro describes a pointer type. ENUM is as above; TYPE is + the type pointed to. */ + +DEF_PRIMITIVE_TYPE (BT_VOID, void_type_node) +DEF_PRIMITIVE_TYPE (BT_BOOL, boolean_type_node) +DEF_PRIMITIVE_TYPE (BT_INT, integer_type_node) +DEF_PRIMITIVE_TYPE (BT_UINT, unsigned_type_node) +DEF_PRIMITIVE_TYPE (BT_LONG, long_integer_type_node) + +DEF_PRIMITIVE_TYPE (BT_I1, builtin_type_for_size (BITS_PER_UNIT*1, 1)) +DEF_PRIMITIVE_TYPE (BT_I2, builtin_type_for_size (BITS_PER_UNIT*2, 1)) +DEF_PRIMITIVE_TYPE (BT_I4, builtin_type_for_size (BITS_PER_UNIT*4, 1)) +DEF_PRIMITIVE_TYPE (BT_I8, builtin_type_for_size (BITS_PER_UNIT*8, 1)) +DEF_PRIMITIVE_TYPE (BT_I16, builtin_type_for_size (BITS_PER_UNIT*16, 1)) + +DEF_PRIMITIVE_TYPE (BT_PTR, ptr_type_node) +DEF_PRIMITIVE_TYPE (BT_CONST_PTR, const_ptr_type_node) +DEF_PRIMITIVE_TYPE (BT_VOLATILE_PTR, + build_pointer_type + (build_qualified_type (void_type_node, + TYPE_QUAL_VOLATILE))) + +DEF_POINTER_TYPE (BT_PTR_LONG, BT_LONG) +DEF_POINTER_TYPE (BT_PTR_PTR, BT_PTR) +DEF_FUNCTION_TYPE_0 (BT_FN_BOOL, BT_BOOL) +DEF_FUNCTION_TYPE_0 (BT_FN_PTR, BT_PTR) +DEF_FUNCTION_TYPE_0 (BT_FN_INT, BT_INT) +DEF_FUNCTION_TYPE_0 (BT_FN_UINT, BT_UINT) +DEF_FUNCTION_TYPE_0 (BT_FN_VOID, BT_VOID) + +DEF_FUNCTION_TYPE_1 (BT_FN_VOID_PTR, BT_VOID, BT_PTR) +DEF_FUNCTION_TYPE_1 (BT_FN_VOID_PTRPTR, BT_VOID, BT_PTR_PTR) +DEF_FUNCTION_TYPE_1 (BT_FN_VOID_VPTR, BT_VOID, BT_VOLATILE_PTR) +DEF_FUNCTION_TYPE_1 (BT_FN_UINT_UINT, BT_UINT, BT_UINT) + +DEF_POINTER_TYPE (BT_PTR_FN_VOID_PTR, BT_FN_VOID_PTR) + +DEF_FUNCTION_TYPE_2 (BT_FN_BOOL_LONGPTR_LONGPTR, + BT_BOOL, BT_PTR_LONG, BT_PTR_LONG) +DEF_FUNCTION_TYPE_2 (BT_FN_I1_VPTR_I1, BT_I1, BT_VOLATILE_PTR, BT_I1) +DEF_FUNCTION_TYPE_2 (BT_FN_I2_VPTR_I2, BT_I2, BT_VOLATILE_PTR, BT_I2) +DEF_FUNCTION_TYPE_2 (BT_FN_I4_VPTR_I4, BT_I4, BT_VOLATILE_PTR, BT_I4) +DEF_FUNCTION_TYPE_2 (BT_FN_I8_VPTR_I8, BT_I8, BT_VOLATILE_PTR, BT_I8) +DEF_FUNCTION_TYPE_2 (BT_FN_I16_VPTR_I16, BT_I16, BT_VOLATILE_PTR, BT_I16) + +DEF_FUNCTION_TYPE_3 (BT_FN_BOOL_VPTR_I1_I1, BT_BOOL, BT_VOLATILE_PTR, + BT_I1, BT_I1) +DEF_FUNCTION_TYPE_3 (BT_FN_BOOL_VPTR_I2_I2, BT_BOOL, BT_VOLATILE_PTR, + BT_I2, BT_I2) +DEF_FUNCTION_TYPE_3 (BT_FN_BOOL_VPTR_I4_I4, BT_BOOL, BT_VOLATILE_PTR, + BT_I4, BT_I4) +DEF_FUNCTION_TYPE_3 (BT_FN_BOOL_VPTR_I8_I8, BT_BOOL, BT_VOLATILE_PTR, + BT_I8, BT_I8) +DEF_FUNCTION_TYPE_3 (BT_FN_BOOL_VPTR_I16_I16, BT_BOOL, BT_VOLATILE_PTR, + BT_I16, BT_I16) +DEF_FUNCTION_TYPE_3 (BT_FN_I1_VPTR_I1_I1, BT_I1, BT_VOLATILE_PTR, BT_I1, BT_I1) +DEF_FUNCTION_TYPE_3 (BT_FN_I2_VPTR_I2_I2, BT_I2, BT_VOLATILE_PTR, BT_I2, BT_I2) +DEF_FUNCTION_TYPE_3 (BT_FN_I4_VPTR_I4_I4, BT_I4, BT_VOLATILE_PTR, BT_I4, BT_I4) +DEF_FUNCTION_TYPE_3 (BT_FN_I8_VPTR_I8_I8, BT_I8, BT_VOLATILE_PTR, BT_I8, BT_I8) +DEF_FUNCTION_TYPE_3 (BT_FN_I16_VPTR_I16_I16, BT_I16, BT_VOLATILE_PTR, + BT_I16, BT_I16) +DEF_FUNCTION_TYPE_3 (BT_FN_VOID_OMPFN_PTR_UINT, BT_VOID, BT_PTR_FN_VOID_PTR, + BT_PTR, BT_UINT) + +DEF_FUNCTION_TYPE_4 (BT_FN_VOID_OMPFN_PTR_UINT_UINT, + BT_VOID, BT_PTR_FN_VOID_PTR, BT_PTR, BT_UINT, BT_UINT) + +DEF_FUNCTION_TYPE_5 (BT_FN_BOOL_LONG_LONG_LONG_LONGPTR_LONGPTR, + BT_BOOL, BT_LONG, BT_LONG, BT_LONG, + BT_PTR_LONG, BT_PTR_LONG) + +DEF_FUNCTION_TYPE_6 (BT_FN_BOOL_LONG_LONG_LONG_LONG_LONGPTR_LONGPTR, + BT_BOOL, BT_LONG, BT_LONG, BT_LONG, BT_LONG, + BT_PTR_LONG, BT_PTR_LONG) +DEF_FUNCTION_TYPE_6 (BT_FN_VOID_OMPFN_PTR_UINT_LONG_LONG_LONG, + BT_VOID, BT_PTR_FN_VOID_PTR, BT_PTR, BT_UINT, + BT_LONG, BT_LONG, BT_LONG) + +DEF_FUNCTION_TYPE_7 (BT_FN_VOID_OMPFN_PTR_UINT_LONG_LONG_LONG_LONG, + BT_VOID, BT_PTR_FN_VOID_PTR, BT_PTR, BT_UINT, + BT_LONG, BT_LONG, BT_LONG, BT_LONG) + +DEF_FUNCTION_TYPE_VAR_0 (BT_FN_VOID_VAR, BT_VOID) diff --git a/gcc/testsuite/ChangeLog b/gcc/testsuite/ChangeLog index daac3ab2eea..d12f8741c62 100644 --- a/gcc/testsuite/ChangeLog +++ b/gcc/testsuite/ChangeLog @@ -1,3 +1,9 @@ +2006-02-14 Jakub Jelinek + Diego Novillo + Uros Bizjak + + * gfortran.dg/gomp: New directory. + 2006-02-14 Richard Guenther PR tree-optimization/26258 diff --git a/gcc/testsuite/gfortran.dg/gomp/appendix-a/a.1.1.f90 b/gcc/testsuite/gfortran.dg/gomp/appendix-a/a.1.1.f90 new file mode 100644 index 00000000000..fd83131b5e9 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/gomp/appendix-a/a.1.1.f90 @@ -0,0 +1,10 @@ +! { dg-do compile } + SUBROUTINE A1(N, A, B) + INTEGER I, N + REAL B(N), A(N) +!$OMP PARALLEL DO !I is private by default + DO I=2,N + B(I) = (A(I) + A(I-1)) / 2.0 + ENDDO +!$OMP END PARALLEL DO + END SUBROUTINE A1 diff --git a/gcc/testsuite/gfortran.dg/gomp/appendix-a/a.11.1.f90 b/gcc/testsuite/gfortran.dg/gomp/appendix-a/a.11.1.f90 new file mode 100644 index 00000000000..eb8455e19bb --- /dev/null +++ b/gcc/testsuite/gfortran.dg/gomp/appendix-a/a.11.1.f90 @@ -0,0 +1,12 @@ +! { dg-do compile } + SUBROUTINE A11_1(AA, BB, CC, DD, EE, FF, N) + INTEGER N + REAL AA(N,N), BB(N,N), CC(N,N), DD(N,N), EE(N,N), FF(N,N) +!$OMP PARALLEL +!$OMP WORKSHARE + AA = BB + CC = DD + EE = FF +!$OMP END WORKSHARE +!$OMP END PARALLEL + END SUBROUTINE A11_1 diff --git a/gcc/testsuite/gfortran.dg/gomp/appendix-a/a.11.2.f90 b/gcc/testsuite/gfortran.dg/gomp/appendix-a/a.11.2.f90 new file mode 100644 index 00000000000..11fdc1caa47 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/gomp/appendix-a/a.11.2.f90 @@ -0,0 +1,16 @@ +! { do-do compile } + + SUBROUTINE A11_2(AA, BB, CC, DD, EE, FF, N) + INTEGER N + REAL AA(N,N), BB(N,N), CC(N,N) + REAL DD(N,N), EE(N,N), FF(N,N) +!$OMP PARALLEL +!$OMP WORKSHARE + AA = BB + CC = DD +!$OMP END WORKSHARE NOWAIT +!$OMP WORKSHARE + EE = FF +!$OMP END WORKSHARE +!$OMP END PARALLEL + END SUBROUTINE A11_2 diff --git a/gcc/testsuite/gfortran.dg/gomp/appendix-a/a.11.3.f90 b/gcc/testsuite/gfortran.dg/gomp/appendix-a/a.11.3.f90 new file mode 100644 index 00000000000..b87232f9c66 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/gomp/appendix-a/a.11.3.f90 @@ -0,0 +1,15 @@ +! { dg-do compile } + SUBROUTINE A11_3(AA, BB, CC, DD, N) + INTEGER N + REAL AA(N,N), BB(N,N), CC(N,N), DD(N,N) + REAL R + R=0 +!$OMP PARALLEL +!$OMP WORKSHARE + AA = BB +!$OMP ATOMIC + R = R + SUM(AA) + CC = DD +!$OMP END WORKSHARE +!$OMP END PARALLEL + END SUBROUTINE A11_3 diff --git a/gcc/testsuite/gfortran.dg/gomp/appendix-a/a.11.4.f90 b/gcc/testsuite/gfortran.dg/gomp/appendix-a/a.11.4.f90 new file mode 100644 index 00000000000..ae95c1f98e2 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/gomp/appendix-a/a.11.4.f90 @@ -0,0 +1,16 @@ +! { dg-do compile } + + SUBROUTINE A11_4(AA, BB, CC, DD, EE, FF, GG, HH, N) + INTEGER N + REAL AA(N,N), BB(N,N), CC(N,N) + REAL DD(N,N), EE(N,N), FF(N,N) + REAL GG(N,N), HH(N,N) +!$OMP PARALLEL +!$OMP WORKSHARE + AA = BB + CC = DD + WHERE (EE .ne. 0) FF = 1 / EE + GG = HH +!$OMP END WORKSHARE +!$OMP END PARALLEL + END SUBROUTINE A11_4 diff --git a/gcc/testsuite/gfortran.dg/gomp/appendix-a/a.11.5.f90 b/gcc/testsuite/gfortran.dg/gomp/appendix-a/a.11.5.f90 new file mode 100644 index 00000000000..6b8e4fa3deb --- /dev/null +++ b/gcc/testsuite/gfortran.dg/gomp/appendix-a/a.11.5.f90 @@ -0,0 +1,14 @@ +! { dg-do compile } + SUBROUTINE A11_5(AA, BB, CC, DD, N) + INTEGER N + REAL AA(N,N), BB(N,N), CC(N,N), DD(N,N) + INTEGER SHR +!$OMP PARALLEL SHARED(SHR) +!$OMP WORKSHARE + AA = BB + SHR = 1 + CC = DD * SHR +!$OMP END WORKSHARE +!$OMP END PARALLEL + END SUBROUTINE A11_5 + diff --git a/gcc/testsuite/gfortran.dg/gomp/appendix-a/a.11.6.f90 b/gcc/testsuite/gfortran.dg/gomp/appendix-a/a.11.6.f90 new file mode 100644 index 00000000000..fa31bcffcd3 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/gomp/appendix-a/a.11.6.f90 @@ -0,0 +1,14 @@ +! { dg-do compile } + + SUBROUTINE A11_6_WRONG(AA, BB, CC, DD, N) + INTEGER N + REAL AA(N,N), BB(N,N), CC(N,N), DD(N,N) + INTEGER PRI +!$OMP PARALLEL PRIVATE(PRI) +!$OMP WORKSHARE + AA = BB + PRI = 1 + CC = DD * PRI +!$OMP END WORKSHARE +!$OMP END PARALLEL + END SUBROUTINE A11_6_WRONG diff --git a/gcc/testsuite/gfortran.dg/gomp/appendix-a/a.11.7.f90 b/gcc/testsuite/gfortran.dg/gomp/appendix-a/a.11.7.f90 new file mode 100644 index 00000000000..86b8c7bc5b5 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/gomp/appendix-a/a.11.7.f90 @@ -0,0 +1,11 @@ +! { dg-do compile } + SUBROUTINE A11_7(AA, BB, CC, N) + INTEGER N + REAL AA(N), BB(N), CC(N) +!$OMP PARALLEL +!$OMP WORKSHARE + AA(1:50) = BB(11:60) + CC(11:20) = AA(1:10) +!$OMP END WORKSHARE +!$OMP END PARALLEL + END SUBROUTINE A11_7 diff --git a/gcc/testsuite/gfortran.dg/gomp/appendix-a/a.12.1.f90 b/gcc/testsuite/gfortran.dg/gomp/appendix-a/a.12.1.f90 new file mode 100644 index 00000000000..38389e4f4a6 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/gomp/appendix-a/a.12.1.f90 @@ -0,0 +1,32 @@ +! { dg-do compile } + SUBROUTINE A12( X, XOLD, N, TOL ) + REAL X(*), XOLD(*), TOL + INTEGER N + INTEGER C, I, TOOBIG + REAL ERROR, Y, AVERAGE + EXTERNAL AVERAGE + C=0 + TOOBIG = 1 +!$OMP PARALLEL + DO WHILE( TOOBIG > 0 ) +!$OMP DO PRIVATE(I) + DO I = 2, N-1 + XOLD(I) = X(I) + ENDDO +!$OMP SINGLE + TOOBIG = 0 +!$OMP END SINGLE +!$OMP DO PRIVATE(I,Y,ERROR), REDUCTION(+:TOOBIG) + DO I = 2, N-1 + Y = X(I) + X(I) = AVERAGE( XOLD(I-1), X(I), XOLD(I+1) ) + ERROR = Y-X(I) + IF( ERROR > TOL .OR. ERROR < -TOL ) TOOBIG = TOOBIG+1 + ENDDO +!$OMP MASTER + C=C+1 + PRINT *, "Iteration ", C, " TOOBIG=", TOOBIG +!$OMP END MASTER + ENDDO +!$OMP END PARALLEL + END SUBROUTINE A12 diff --git a/gcc/testsuite/gfortran.dg/gomp/appendix-a/a.13.1.f90 b/gcc/testsuite/gfortran.dg/gomp/appendix-a/a.13.1.f90 new file mode 100644 index 00000000000..57f5b8912fc --- /dev/null +++ b/gcc/testsuite/gfortran.dg/gomp/appendix-a/a.13.1.f90 @@ -0,0 +1,16 @@ +! { dg-do compile } + SUBROUTINE A13(X, Y) + REAL X(*), Y(*) + INTEGER IX_NEXT, IY_NEXT +!$OMP PARALLEL SHARED(X, Y) PRIVATE(IX_NEXT, IY_NEXT) +!$OMP CRITICAL(XAXIS) + CALL DEQUEUE(IX_NEXT, X) +!$OMP END CRITICAL(XAXIS) + CALL WORK(IX_NEXT, X) +!$OMP CRITICAL(YAXIS) + CALL DEQUEUE(IY_NEXT,Y) +!$OMP END CRITICAL(YAXIS) + CALL WORK(IY_NEXT, Y) +!$OMP END PARALLEL + END SUBROUTINE A13 + diff --git a/gcc/testsuite/gfortran.dg/gomp/appendix-a/a.14.1.f90 b/gcc/testsuite/gfortran.dg/gomp/appendix-a/a.14.1.f90 new file mode 100644 index 00000000000..6db107afa4a --- /dev/null +++ b/gcc/testsuite/gfortran.dg/gomp/appendix-a/a.14.1.f90 @@ -0,0 +1,15 @@ +! { dg-do compile } + SUBROUTINE A14() + INTEGER I + I=1 +!$OMP PARALLEL SECTIONS +!$OMP SECTION +!$OMP CRITICAL (NAME) +!$OMP PARALLEL +!$OMP SINGLE + I=I+1 +!$OMP END SINGLE +!$OMP END PARALLEL +!$OMP END CRITICAL (NAME) +!$OMP END PARALLEL SECTIONS + END SUBROUTINE A14 diff --git a/gcc/testsuite/gfortran.dg/gomp/appendix-a/a.17.1.f90 b/gcc/testsuite/gfortran.dg/gomp/appendix-a/a.17.1.f90 new file mode 100644 index 00000000000..8fd600176ca --- /dev/null +++ b/gcc/testsuite/gfortran.dg/gomp/appendix-a/a.17.1.f90 @@ -0,0 +1,14 @@ +! { dg-do compile } + SUBROUTINE A17_1_WRONG() + INTEGER:: I + REAL:: R + EQUIVALENCE(I,R) +!$OMP PARALLEL +!$OMP ATOMIC + I=I+1 +!$OMP ATOMIC + R = R + 1.0 +! incorrect because I and R reference the same location +! but have different types +!$OMP END PARALLEL + END SUBROUTINE A17_1_WRONG diff --git a/gcc/testsuite/gfortran.dg/gomp/appendix-a/a.17.2.f90 b/gcc/testsuite/gfortran.dg/gomp/appendix-a/a.17.2.f90 new file mode 100644 index 00000000000..a19db8c0dc9 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/gomp/appendix-a/a.17.2.f90 @@ -0,0 +1,19 @@ +! { dg-do compile } + + SUBROUTINE SUB() + COMMON /BLK/ R + REAL R +!$OMP ATOMIC + R = R + 1.0 + END SUBROUTINE SUB + + SUBROUTINE A17_2_WRONG() + COMMON /BLK/ I + INTEGER I +!$OMP PARALLEL +!$OMP ATOMIC + I=I+1 + CALL SUB() +!$OMP END PARALLEL + END SUBROUTINE A17_2_WRONG + diff --git a/gcc/testsuite/gfortran.dg/gomp/appendix-a/a.17.3.f90 b/gcc/testsuite/gfortran.dg/gomp/appendix-a/a.17.3.f90 new file mode 100644 index 00000000000..4f4f55c0943 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/gomp/appendix-a/a.17.3.f90 @@ -0,0 +1,18 @@ +! { dg-do compile } + SUBROUTINE A17_3_WRONG + INTEGER:: I + REAL:: R + EQUIVALENCE(I,R) +!$OMP PARALLEL +!$OMP ATOMIC + I=I+1 +! incorrect because I and R reference the same location +! but have different types +!$OMP END PARALLEL +!$OMP PARALLEL +!$OMP ATOMIC + R = R + 1.0 +! incorrect because I and R reference the same location +! but have different types +!$OMP END PARALLEL + END SUBROUTINE A17_3_WRONG diff --git a/gcc/testsuite/gfortran.dg/gomp/appendix-a/a.21.2.f90 b/gcc/testsuite/gfortran.dg/gomp/appendix-a/a.21.2.f90 new file mode 100644 index 00000000000..87359a152a6 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/gomp/appendix-a/a.21.2.f90 @@ -0,0 +1,20 @@ +! { dg-do compile } + + SUBROUTINE WORK(I) + INTEGER I + END SUBROUTINE WORK + SUBROUTINE A21_WRONG(N) + INTEGER N + INTEGER I +!$OMP DO ORDERED + DO I = 1, N +! incorrect because an iteration may not execute more than one +! ordered region +!$OMP ORDERED + CALL WORK(I) +!$OMP END ORDERED +!$OMP ORDERED + CALL WORK(I+1) +!$OMP END ORDERED + END DO + END SUBROUTINE A21_WRONG diff --git a/gcc/testsuite/gfortran.dg/gomp/appendix-a/a.21.3.f90 b/gcc/testsuite/gfortran.dg/gomp/appendix-a/a.21.3.f90 new file mode 100644 index 00000000000..97ca8f45812 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/gomp/appendix-a/a.21.3.f90 @@ -0,0 +1,18 @@ +! { dg-do compile } + + SUBROUTINE A21_GOOD(N) + INTEGER N +!$OMP DO ORDERED + DO I = 1,N + IF (I <= 10) THEN +!$OMP ORDERED + CALL WORK(I) +!$OMP END ORDERED + ENDIF + IF (I > 10) THEN +!$OMP ORDERED + CALL WORK(I+1) +!$OMP END ORDERED + ENDIF + ENDDO + END SUBROUTINE A21_GOOD diff --git a/gcc/testsuite/gfortran.dg/gomp/appendix-a/a.22.1.f90 b/gcc/testsuite/gfortran.dg/gomp/appendix-a/a.22.1.f90 new file mode 100644 index 00000000000..cc94b140384 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/gomp/appendix-a/a.22.1.f90 @@ -0,0 +1,10 @@ +! { dg-do compile } +! { dg-require-effective-target tls } + + INTEGER FUNCTION INCREMENT_COUNTER() + COMMON/A22_COMMON/COUNTER +!$OMP THREADPRIVATE(/A22_COMMON/) + COUNTER = COUNTER +1 + INCREMENT_COUNTER = COUNTER + RETURN + END FUNCTION INCREMENT_COUNTER diff --git a/gcc/testsuite/gfortran.dg/gomp/appendix-a/a.22.4.f90 b/gcc/testsuite/gfortran.dg/gomp/appendix-a/a.22.4.f90 new file mode 100644 index 00000000000..f769fc18f3e --- /dev/null +++ b/gcc/testsuite/gfortran.dg/gomp/appendix-a/a.22.4.f90 @@ -0,0 +1,11 @@ +! { dg-do compile } +! { dg-require-effective-target tls } + + MODULE A22_MODULE + COMMON /T/ A + END MODULE A22_MODULE + SUBROUTINE A22_4_WRONG() + USE A22_MODULE +!$OMP THREADPRIVATE(/T/) ! { dg-error "COMMON block" } + !non-conforming because /T/ not declared in A22_4_WRONG + END SUBROUTINE A22_4_WRONG diff --git a/gcc/testsuite/gfortran.dg/gomp/appendix-a/a.22.5.f90 b/gcc/testsuite/gfortran.dg/gomp/appendix-a/a.22.5.f90 new file mode 100644 index 00000000000..6531d826c57 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/gomp/appendix-a/a.22.5.f90 @@ -0,0 +1,13 @@ +! { dg-do compile } +! { dg-require-effective-target tls } + + SUBROUTINE A22_5_WRONG() + COMMON /T/ A +!$OMP THREADPRIVATE(/T/) + CONTAINS + SUBROUTINE A22_5S_WRONG() +!$OMP PARALLEL COPYIN(/T/) ! { dg-error "COMMON block" } + !non-conforming because /T/ not declared in A22_5S_WRONG +!$OMP END PARALLEL ! { dg-error "Unexpected" } + END SUBROUTINE A22_5S_WRONG + END SUBROUTINE A22_5_WRONG diff --git a/gcc/testsuite/gfortran.dg/gomp/appendix-a/a.22.6.f90 b/gcc/testsuite/gfortran.dg/gomp/appendix-a/a.22.6.f90 new file mode 100644 index 00000000000..0a2e6a6836f --- /dev/null +++ b/gcc/testsuite/gfortran.dg/gomp/appendix-a/a.22.6.f90 @@ -0,0 +1,14 @@ +! { dg-do compile } +! { dg-require-effective-target tls } + + SUBROUTINE A22_6_GOOD() + COMMON /T/ A +!$OMP THREADPRIVATE(/T/) + CONTAINS + SUBROUTINE A22_6S_GOOD() + COMMON /T/ A +!$OMP THREADPRIVATE(/T/) +!$OMP PARALLEL COPYIN(/T/) +!$OMP END PARALLEL + END SUBROUTINE A22_6S_GOOD + END SUBROUTINE A22_6_GOOD diff --git a/gcc/testsuite/gfortran.dg/gomp/appendix-a/a.23.1.f90 b/gcc/testsuite/gfortran.dg/gomp/appendix-a/a.23.1.f90 new file mode 100644 index 00000000000..6eab6872985 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/gomp/appendix-a/a.23.1.f90 @@ -0,0 +1,11 @@ +! { dg-do compile } + SUBROUTINE A23_1_GOOD() + COMMON /C/ X,Y + REAL X, Y +!$OMP PARALLEL PRIVATE (/C/) + ! do work here +!$OMP END PARALLEL +!$OMP PARALLEL SHARED (X,Y) + ! do work here +!$OMP END PARALLEL + END SUBROUTINE A23_1_GOOD diff --git a/gcc/testsuite/gfortran.dg/gomp/appendix-a/a.23.2.f90 b/gcc/testsuite/gfortran.dg/gomp/appendix-a/a.23.2.f90 new file mode 100644 index 00000000000..ecfdbe5a2a0 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/gomp/appendix-a/a.23.2.f90 @@ -0,0 +1,19 @@ +! { dg-do compile } + SUBROUTINE A23_2_GOOD() + COMMON /C/ X,Y + REAL X, Y + INTEGER I +!$OMP PARALLEL +!$OMP DO PRIVATE(/C/) + DO I=1,1000 + ! do work here + ENDDO +!$OMP END DO +! +!$OMP DO PRIVATE(X) + DO I=1,1000 + ! do work here + ENDDO +!$OMP END DO +!$OMP END PARALLEL + END SUBROUTINE A23_2_GOOD diff --git a/gcc/testsuite/gfortran.dg/gomp/appendix-a/a.23.3.f90 b/gcc/testsuite/gfortran.dg/gomp/appendix-a/a.23.3.f90 new file mode 100644 index 00000000000..abd80410284 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/gomp/appendix-a/a.23.3.f90 @@ -0,0 +1,11 @@ +! { dg-do compile } + + SUBROUTINE A23_3_GOOD() + COMMON /C/ X,Y +!$OMP PARALLEL PRIVATE (/C/) + ! do work here +!$OMP END PARALLEL +!$OMP PARALLEL SHARED (/C/) + ! do work here +!$OMP END PARALLEL + END SUBROUTINE A23_3_GOOD diff --git a/gcc/testsuite/gfortran.dg/gomp/appendix-a/a.23.4.f90 b/gcc/testsuite/gfortran.dg/gomp/appendix-a/a.23.4.f90 new file mode 100644 index 00000000000..8c6e2281d17 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/gomp/appendix-a/a.23.4.f90 @@ -0,0 +1,9 @@ +! { dg-do compile } + + SUBROUTINE A23_4_WRONG() + COMMON /C/ X,Y +! Incorrect because X is a constituent element of C +!$OMP PARALLEL PRIVATE(/C/), SHARED(X) ! { dg-error "Symbol 'x' present" } + ! do work here +!$OMP END PARALLEL + END SUBROUTINE A23_4_WRONG diff --git a/gcc/testsuite/gfortran.dg/gomp/appendix-a/a.23.5.f90 b/gcc/testsuite/gfortran.dg/gomp/appendix-a/a.23.5.f90 new file mode 100644 index 00000000000..732c15f2385 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/gomp/appendix-a/a.23.5.f90 @@ -0,0 +1,12 @@ +! { dg-do compile } + + SUBROUTINE A23_5_WRONG() + COMMON /C/ X,Y +! Incorrect: common block C cannot be declared both +! shared and private +!$OMP PARALLEL PRIVATE (/C/), SHARED(/C/) + ! { dg-error "Symbol 'y' present" "" { target *-*-* } 7 } + ! { dg-error "Symbol 'x' present" "" { target *-*-* } 7 } + ! do work here +!$OMP END PARALLEL + END SUBROUTINE A23_5_WRONG diff --git a/gcc/testsuite/gfortran.dg/gomp/appendix-a/a.24.1.f90 b/gcc/testsuite/gfortran.dg/gomp/appendix-a/a.24.1.f90 new file mode 100644 index 00000000000..e5b95450d28 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/gomp/appendix-a/a.24.1.f90 @@ -0,0 +1,31 @@ +! { dg-do compile } +! { dg-require-effective-target tls } + + SUBROUTINE A24(A) + INTEGER A + INTEGER X, Y, Z(1000) + INTEGER OMP_GET_NUM_THREADS + COMMON/BLOCKX/X + COMMON/BLOCKY/Y + COMMON/BLOCKZ/Z +!$OMP THREADPRIVATE(/BLOCKX/) + INTEGER I, J + i=1 +!$OMP PARALLEL DEFAULT(NONE) PRIVATE(A) SHARED(Z) PRIVATE(J) + J = OMP_GET_NUM_THREADS(); + ! O.K. - J is listed in PRIVATE clause + A = Z(J) ! O.K. - A is listed in PRIVATE clause + ! - Z is listed in SHARED clause + X=1 ! O.K. - X is THREADPRIVATE + Z(I) = Y ! Error - cannot reference I or Y here +! { dg-error "'i' not specified" "" { target *-*-* } 20 } */ +! { dg-error "enclosing parallel" "" { target *-*-* } 14 } */ +! { dg-error "'y' not specified" "" { target *-*-* } 20 } */ +!$OMP DO firstprivate(y) + DO I = 1,10 + Z(I) = Y ! O.K. - I is the loop iteration variable + ! Y is listed in FIRSTPRIVATE clause + END DO + Z(I) = Y ! Error - cannot reference I or Y here +!$OMP END PARALLEL + END SUBROUTINE A24 diff --git a/gcc/testsuite/gfortran.dg/gomp/appendix-a/a.25.1.f90 b/gcc/testsuite/gfortran.dg/gomp/appendix-a/a.25.1.f90 new file mode 100644 index 00000000000..66bfba80ed1 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/gomp/appendix-a/a.25.1.f90 @@ -0,0 +1,19 @@ +! { dg-do compile } + + SUBROUTINE A25 + INTEGER OMP_GET_THREAD_NUM + REAL A(20) + INTEGER MYTHREAD + !$OMP PARALLEL SHARED(A) PRIVATE(MYTHREAD) + MYTHREAD = OMP_GET_THREAD_NUM() + IF (MYTHREAD .EQ. 0) THEN + CALL SUB(A(1:10)) ! compiler may introduce writes to A(6:10) + ELSE + A(6:10) = 12 + ENDIF + !$OMP END PARALLEL + END SUBROUTINE A25 + SUBROUTINE SUB(X) + REAL X(*) + X(1:5) = 4 + END SUBROUTINE SUB diff --git a/gcc/testsuite/gfortran.dg/gomp/appendix-a/a.26.2.f90 b/gcc/testsuite/gfortran.dg/gomp/appendix-a/a.26.2.f90 new file mode 100644 index 00000000000..97c14d945d1 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/gomp/appendix-a/a.26.2.f90 @@ -0,0 +1,22 @@ +! { dg-do compile } + + MODULE A26_2 + REAL A + CONTAINS + SUBROUTINE G(K) + REAL K + A = K ! This is A in module A26_2, not the private + ! A in F + END SUBROUTINE G + SUBROUTINE F(N) + INTEGER N + REAL A + INTEGER I +!$OMP PARALLEL DO PRIVATE(A) + DO I = 1,N + A=I + CALL G(A*2) + ENDDO +!$OMP END PARALLEL DO + END SUBROUTINE F + END MODULE A26_2 diff --git a/gcc/testsuite/gfortran.dg/gomp/appendix-a/a.27.1.f90 b/gcc/testsuite/gfortran.dg/gomp/appendix-a/a.27.1.f90 new file mode 100644 index 00000000000..f564bd380c2 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/gomp/appendix-a/a.27.1.f90 @@ -0,0 +1,12 @@ +! { dg-do compile } + + SUBROUTINE A27() + INTEGER I, A +!$OMP PARALLEL PRIVATE(A) +!$OMP PARALLEL DO PRIVATE(A) + DO I = 1, 10 + ! do work here + END DO +!$OMP END PARALLEL DO +!$OMP END PARALLEL + END SUBROUTINE A27 diff --git a/gcc/testsuite/gfortran.dg/gomp/appendix-a/a.30.1.f90 b/gcc/testsuite/gfortran.dg/gomp/appendix-a/a.30.1.f90 new file mode 100644 index 00000000000..e62cbf81bbc --- /dev/null +++ b/gcc/testsuite/gfortran.dg/gomp/appendix-a/a.30.1.f90 @@ -0,0 +1,14 @@ +! { dg-do compile } + + SUBROUTINE A30(N, A, B) + INTEGER N + REAL A(*), B(*) + INTEGER I +!$OMP PARALLEL +!$OMP DO LASTPRIVATE(I) + DO I=1,N-1 + A(I) = B(I) + B(I+1) + ENDDO +!$OMP END PARALLEL + A(I) = B(I) ! I has the value of N here + END SUBROUTINE A30 diff --git a/gcc/testsuite/gfortran.dg/gomp/appendix-a/a.31.1.f90 b/gcc/testsuite/gfortran.dg/gomp/appendix-a/a.31.1.f90 new file mode 100644 index 00000000000..294926bfdca --- /dev/null +++ b/gcc/testsuite/gfortran.dg/gomp/appendix-a/a.31.1.f90 @@ -0,0 +1,15 @@ +! { dg-do compile } + + SUBROUTINE A31_1(A, B, X, Y, N) + INTEGER N + REAL X(*), Y(*), A, B +!$OMP PARALLEL DO PRIVATE(I) SHARED(X, N) REDUCTION(+:A) +!$OMP& REDUCTION(MIN:B) + DO I=1,N + A = A + X(I) + B = MIN(B, Y(I)) +! Note that some reductions can be expressed in +! other forms. For example, the MIN could be expressed as +! IF (B > Y(I)) B = Y(I) + END DO + END SUBROUTINE A31_1 diff --git a/gcc/testsuite/gfortran.dg/gomp/appendix-a/a.31.2.f90 b/gcc/testsuite/gfortran.dg/gomp/appendix-a/a.31.2.f90 new file mode 100644 index 00000000000..f78188c7c28 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/gomp/appendix-a/a.31.2.f90 @@ -0,0 +1,20 @@ +! { dg-do compile } + + SUBROUTINE A31_2 (A, B, X, Y, N) + INTEGER N + REAL X(*), Y(*), A, B, A_P, B_P +!$OMP PARALLEL SHARED(X, Y, N, A, B) PRIVATE(A_P, B_P) + A_P = 0.0 + B_P = HUGE(B_P) +!$OMP DO PRIVATE(I) + DO I=1,N + A_P = A_P + X(I) + B_P = MIN(B_P, Y(I)) + ENDDO +!$OMP END DO +!$OMP CRITICAL + A = A + A_P + B = MIN(B, B_P) +!$OMP END CRITICAL +!$OMP END PARALLEL + END SUBROUTINE A31_2 diff --git a/gcc/testsuite/gfortran.dg/gomp/appendix-a/a.31.3.f90 b/gcc/testsuite/gfortran.dg/gomp/appendix-a/a.31.3.f90 new file mode 100644 index 00000000000..f67c91c215b --- /dev/null +++ b/gcc/testsuite/gfortran.dg/gomp/appendix-a/a.31.3.f90 @@ -0,0 +1,15 @@ +! { dg-do compile } + PROGRAM A31_3_WRONG + MAX = HUGE(0) + M=0 + !$OMP PARALLEL DO REDUCTION(MAX: M) ! MAX is no longer the + ! intrinsic so this + ! is non-conforming +! { dg-error "is not INTRINSIC procedure name" "" { target *-*-* } 5 } */ + DO I = 1, 100 + CALL SUB(M,I) + END DO + END PROGRAM A31_3_WRONG + SUBROUTINE SUB(M,I) + M = MAX(M,I) + END SUBROUTINE SUB diff --git a/gcc/testsuite/gfortran.dg/gomp/appendix-a/a.32.1.f90 b/gcc/testsuite/gfortran.dg/gomp/appendix-a/a.32.1.f90 new file mode 100644 index 00000000000..8e0b5e093c5 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/gomp/appendix-a/a.32.1.f90 @@ -0,0 +1,24 @@ +! { dg-do compile } +! { dg-require-effective-target tls } + + MODULE M + REAL, POINTER, SAVE :: WORK(:) + INTEGER :: SIZE + REAL :: TOL +!$OMP THREADPRIVATE(WORK,SIZE,TOL) + END MODULE M + SUBROUTINE A32( T, N ) + USE M + REAL :: T + INTEGER :: N + TOL = T + SIZE = N +!$OMP PARALLEL COPYIN(TOL,SIZE) + CALL BUILD +!$OMP END PARALLEL + END SUBROUTINE A32 + SUBROUTINE BUILD + USE M + ALLOCATE(WORK(SIZE)) + WORK = TOL + END SUBROUTINE BUILD diff --git a/gcc/testsuite/gfortran.dg/gomp/appendix-a/a.33.1.f90 b/gcc/testsuite/gfortran.dg/gomp/appendix-a/a.33.1.f90 new file mode 100644 index 00000000000..05145b1715f --- /dev/null +++ b/gcc/testsuite/gfortran.dg/gomp/appendix-a/a.33.1.f90 @@ -0,0 +1,11 @@ +! { dg-do compile } +! { dg-require-effective-target tls } + + SUBROUTINE INIT(A,B) + REAL A, B + COMMON /XY/ X,Y +!$OMP THREADPRIVATE (/XY/) +!$OMP SINGLE + READ (11) A,B,X,Y +!$OMP END SINGLE COPYPRIVATE (A,B,/XY/) + END SUBROUTINE INIT diff --git a/gcc/testsuite/gfortran.dg/gomp/appendix-a/a.33.2.f90 b/gcc/testsuite/gfortran.dg/gomp/appendix-a/a.33.2.f90 new file mode 100644 index 00000000000..ced23c856b4 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/gomp/appendix-a/a.33.2.f90 @@ -0,0 +1,17 @@ +! { dg-do compile } + + REAL FUNCTION READ_NEXT() + REAL, POINTER :: TMP +!$OMP SINGLE + ALLOCATE (TMP) +!$OMP END SINGLE COPYPRIVATE (TMP) ! copies the pointer only +!$OMP MASTER + READ (11) TMP +!$OMP END MASTER +!$OMP BARRIER + READ_NEXT = TMP +!$OMP BARRIER +!$OMP SINGLE + DEALLOCATE (TMP) +!$OMP END SINGLE NOWAIT + END FUNCTION READ_NEXT diff --git a/gcc/testsuite/gfortran.dg/gomp/appendix-a/a.33.4.f90 b/gcc/testsuite/gfortran.dg/gomp/appendix-a/a.33.4.f90 new file mode 100644 index 00000000000..9685b5939c8 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/gomp/appendix-a/a.33.4.f90 @@ -0,0 +1,19 @@ +! { dg-do compile } + SUBROUTINE S(N) + INTEGER N + REAL, DIMENSION(:), ALLOCATABLE :: A + REAL, DIMENSION(:), POINTER :: B + ALLOCATE (A(N)) +!$OMP SINGLE ! { dg-error "COPYPRIVATE clause object 'a'" } + ALLOCATE (B(N)) + READ (11) A,B +!$OMP END SINGLE COPYPRIVATE(A,B) + ! Variable A designates a private object + ! which has the same value in each thread + ! Variable B designates a shared object +!$OMP BARRIER +!$OMP SINGLE + DEALLOCATE (B) +!$OMP END SINGLE NOWAIT + END SUBROUTINE S + diff --git a/gcc/testsuite/gfortran.dg/gomp/appendix-a/a.34.1.f90 b/gcc/testsuite/gfortran.dg/gomp/appendix-a/a.34.1.f90 new file mode 100644 index 00000000000..29ea952cb36 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/gomp/appendix-a/a.34.1.f90 @@ -0,0 +1,19 @@ +! { dg-do compile } + SUBROUTINE WORK(I, J) + INTEGER I, J + END SUBROUTINE WORK + SUBROUTINE GOOD_NESTING(N) + INTEGER N + INTEGER I +!$OMP PARALLEL DEFAULT(SHARED) +!$OMP DO + DO I = 1, N +!$OMP PARALLEL SHARED(I,N) +!$OMP DO + DO J = 1, N + CALL WORK(I,J) + END DO +!$OMP END PARALLEL + END DO +!$OMP END PARALLEL + END SUBROUTINE GOOD_NESTING diff --git a/gcc/testsuite/gfortran.dg/gomp/appendix-a/a.34.2.f90 b/gcc/testsuite/gfortran.dg/gomp/appendix-a/a.34.2.f90 new file mode 100644 index 00000000000..980a623726a --- /dev/null +++ b/gcc/testsuite/gfortran.dg/gomp/appendix-a/a.34.2.f90 @@ -0,0 +1,22 @@ +! { dg-do compile } + SUBROUTINE WORK(I, J) + INTEGER I, J + END SUBROUTINE WORK + SUBROUTINE WORK1(I, N) + INTEGER J +!$OMP PARALLEL DEFAULT(SHARED) +!$OMP DO + DO J = 1, N + CALL WORK(I,J) + END DO +!$OMP END PARALLEL + END SUBROUTINE WORK1 + SUBROUTINE GOOD_NESTING2(N) + INTEGER N +!$OMP PARALLEL DEFAULT(SHARED) +!$OMP DO + DO I = 1, N + CALL WORK1(I, N) + END DO +!$OMP END PARALLEL + END SUBROUTINE GOOD_NESTING2 diff --git a/gcc/testsuite/gfortran.dg/gomp/appendix-a/a.35.1.f90 b/gcc/testsuite/gfortran.dg/gomp/appendix-a/a.35.1.f90 new file mode 100644 index 00000000000..7325e34005e --- /dev/null +++ b/gcc/testsuite/gfortran.dg/gomp/appendix-a/a.35.1.f90 @@ -0,0 +1,18 @@ +! { dg-do compile } + + SUBROUTINE WORK(I, J) + INTEGER I, J + END SUBROUTINE WORK + SUBROUTINE WRONG1(N) + INTEGER N + INTEGER I,J +!$OMP PARALLEL DEFAULT(SHARED) +!$OMP DO + DO I = 1, N +!$OMP DO ! incorrect nesting of loop regions + DO J = 1, N + CALL WORK(I,J) + END DO + END DO +!$OMP END PARALLEL + END SUBROUTINE WRONG1 diff --git a/gcc/testsuite/gfortran.dg/gomp/appendix-a/a.35.2.f90 b/gcc/testsuite/gfortran.dg/gomp/appendix-a/a.35.2.f90 new file mode 100644 index 00000000000..5fad2c05f7a --- /dev/null +++ b/gcc/testsuite/gfortran.dg/gomp/appendix-a/a.35.2.f90 @@ -0,0 +1,20 @@ +! { dg-do compile } + + SUBROUTINE WORK1(I,N) + INTEGER I, N + INTEGER J +!$OMP DO ! incorrect nesting of loop regions + DO J = 1, N + CALL WORK(I,J) + END DO + END SUBROUTINE WORK1 + SUBROUTINE WRONG2(N) + INTEGER N + INTEGER I +!$OMP PARALLEL DEFAULT(SHARED) +!$OMP DO + DO I = 1, N + CALL WORK1(I,N) + END DO +!$OMP END PARALLEL + END SUBROUTINE WRONG2 diff --git a/gcc/testsuite/gfortran.dg/gomp/appendix-a/a.35.3.f90 b/gcc/testsuite/gfortran.dg/gomp/appendix-a/a.35.3.f90 new file mode 100644 index 00000000000..63a558f72ab --- /dev/null +++ b/gcc/testsuite/gfortran.dg/gomp/appendix-a/a.35.3.f90 @@ -0,0 +1,14 @@ +! { dg-do compile } + + SUBROUTINE WRONG3(N) + INTEGER N + INTEGER I +!$OMP PARALLEL DEFAULT(SHARED) +!$OMP DO + DO I = 1, N +!$OMP SINGLE ! incorrect nesting of regions + CALL WORK(I, 1) +!$OMP END SINGLE + END DO +!$OMP END PARALLEL + END SUBROUTINE WRONG3 diff --git a/gcc/testsuite/gfortran.dg/gomp/appendix-a/a.35.4.f90 b/gcc/testsuite/gfortran.dg/gomp/appendix-a/a.35.4.f90 new file mode 100644 index 00000000000..e44952263f1 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/gomp/appendix-a/a.35.4.f90 @@ -0,0 +1,15 @@ +! { dg-do compile } + + SUBROUTINE WRONG4(N) + INTEGER N + INTEGER I +!$OMP PARALLEL DEFAULT(SHARED) +!$OMP DO + DO I = 1, N + CALL WORK(I, 1) +! incorrect nesting of barrier region in a loop region +!$OMP BARRIER + CALL WORK(I, 2) + END DO +!$OMP END PARALLEL + END SUBROUTINE WRONG4 diff --git a/gcc/testsuite/gfortran.dg/gomp/appendix-a/a.35.5.f90 b/gcc/testsuite/gfortran.dg/gomp/appendix-a/a.35.5.f90 new file mode 100644 index 00000000000..083c0b3b723 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/gomp/appendix-a/a.35.5.f90 @@ -0,0 +1,13 @@ +! { dg-do compile } + + SUBROUTINE WRONG5(N) + INTEGER N +!$OMP PARALLEL DEFAULT(SHARED) +!$OMP CRITICAL + CALL WORK(N,1) +! incorrect nesting of barrier region in a critical region +!$OMP BARRIER + CALL WORK(N,2) +!$OMP END CRITICAL +!$OMP END PARALLEL + END SUBROUTINE WRONG5 diff --git a/gcc/testsuite/gfortran.dg/gomp/appendix-a/a.35.6.f90 b/gcc/testsuite/gfortran.dg/gomp/appendix-a/a.35.6.f90 new file mode 100644 index 00000000000..0488537dd10 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/gomp/appendix-a/a.35.6.f90 @@ -0,0 +1,14 @@ +! { dg-do compile } + + SUBROUTINE WRONG6(N) + INTEGER N +!$OMP PARALLEL DEFAULT(SHARED) +!$OMP SINGLE + CALL WORK(N,1) +! incorrect nesting of barrier region in a single region +!$OMP BARRIER + CALL WORK(N,2) +!$OMP END SINGLE +!$OMP END PARALLEL + END SUBROUTINE WRONG6 + diff --git a/gcc/testsuite/gfortran.dg/gomp/appendix-a/a.36.1.f90 b/gcc/testsuite/gfortran.dg/gomp/appendix-a/a.36.1.f90 new file mode 100644 index 00000000000..be68188ec98 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/gomp/appendix-a/a.36.1.f90 @@ -0,0 +1,23 @@ +! { dg-do compile } + + SUBROUTINE DO_BY_16(X, IAM, IPOINTS) + REAL X(*) + INTEGER IAM, IPOINTS + END SUBROUTINE DO_BY_16 + SUBROUTINE SUBA36(X, NPOINTS) + INTEGER NPOINTS + REAL X(NPOINTS) + INTEGER IAM, IPOINTS + EXTERNAL OMP_SET_DYNAMIC, OMP_SET_NUM_THREADS + INTEGER OMP_GET_NUM_THREADS, OMP_GET_THREAD_NUM + CALL OMP_SET_DYNAMIC(.FALSE.) + CALL OMP_SET_NUM_THREADS(16) +!$OMP PARALLEL SHARED(X,NPOINTS) PRIVATE(IAM, IPOINTS) + IF (OMP_GET_NUM_THREADS() .NE. 16) THEN + STOP + ENDIF + IAM = OMP_GET_THREAD_NUM() + IPOINTS = NPOINTS/16 + CALL DO_BY_16(X,IAM,IPOINTS) +!$OMP END PARALLEL + END SUBROUTINE SUBA36 diff --git a/gcc/testsuite/gfortran.dg/gomp/appendix-a/a.37.1.f90 b/gcc/testsuite/gfortran.dg/gomp/appendix-a/a.37.1.f90 new file mode 100644 index 00000000000..473c1fec826 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/gomp/appendix-a/a.37.1.f90 @@ -0,0 +1,15 @@ +! { dg-do compile } + SUBROUTINE WORK(I) + INTEGER I + I=I+1 + END SUBROUTINE WORK + SUBROUTINE INCORRECT() + INTEGER OMP_GET_NUM_THREADS + INTEGER I, NP + NP = OMP_GET_NUM_THREADS() !misplaced: will return 1 +!$OMP PARALLEL DO SCHEDULE(STATIC) + DO I = 0, NP-1 + CALL WORK(I) + ENDDO +!$OMP END PARALLEL DO + END SUBROUTINE INCORRECT diff --git a/gcc/testsuite/gfortran.dg/gomp/appendix-a/a.37.2.f90 b/gcc/testsuite/gfortran.dg/gomp/appendix-a/a.37.2.f90 new file mode 100644 index 00000000000..c5fbcbbd0b3 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/gomp/appendix-a/a.37.2.f90 @@ -0,0 +1,13 @@ +! { dg-do compile } + SUBROUTINE WORK(I) + INTEGER I + I=I+1 + END SUBROUTINE WORK + SUBROUTINE CORRECT() + INTEGER OMP_GET_THREAD_NUM + INTEGER I +!$OMP PARALLEL PRIVATE(I) + I = OMP_GET_THREAD_NUM() + CALL WORK(I) +!$OMP END PARALLEL + END SUBROUTINE CORRECT diff --git a/gcc/testsuite/gfortran.dg/gomp/appendix-a/a.6.1.f90 b/gcc/testsuite/gfortran.dg/gomp/appendix-a/a.6.1.f90 new file mode 100644 index 00000000000..f1c6c659617 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/gomp/appendix-a/a.6.1.f90 @@ -0,0 +1,24 @@ +! { dg-do compile } + + SUBROUTINE WORK(I, J) + INTEGER I,J + END SUBROUTINE WORK + SUBROUTINE A6_GOOD() + INTEGER I, J + REAL A(1000) + DO 100 I = 1,10 +!$OMP DO + DO 100 J = 1,10 + CALL WORK(I,J) + 100 CONTINUE ! !$OMP ENDDO implied here +!$OMP DO + DO 200 J = 1,10 +200 A(I) = I + 1 +!$OMP ENDDO +!$OMP DO + DO 300 I = 1,10 + DO 300 J = 1,10 + CALL WORK(I,J) +300 CONTINUE +!$OMP ENDDO + END SUBROUTINE A6_GOOD diff --git a/gcc/testsuite/gfortran.dg/gomp/appendix-a/a.6.2.f90 b/gcc/testsuite/gfortran.dg/gomp/appendix-a/a.6.2.f90 new file mode 100644 index 00000000000..e1388089962 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/gomp/appendix-a/a.6.2.f90 @@ -0,0 +1,15 @@ +! { dg-do compile } + + SUBROUTINE WORK(I, J) + INTEGER I,J + END SUBROUTINE WORK + + SUBROUTINE A6_WRONG + INTEGER I, J + DO 100 I = 1,10 +!$OMP DO + DO 100 J = 1,10 + CALL WORK(I,J) + 100 CONTINUE +!$OMP ENDDO ! { dg-error "Unexpected ..OMP END DO statement" } + END SUBROUTINE A6_WRONG diff --git a/gcc/testsuite/gfortran.dg/gomp/appendix-a/a.7.1.f90 b/gcc/testsuite/gfortran.dg/gomp/appendix-a/a.7.1.f90 new file mode 100644 index 00000000000..9f3b08d2e51 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/gomp/appendix-a/a.7.1.f90 @@ -0,0 +1,12 @@ +! { dg-do compile } +SUBROUTINE A7_1(A,N) +INTEGER OMP_GET_THREAD_NUM +REAL A(*) +INTEGER I, MYOFFSET, N +!$OMP PARALLEL PRIVATE(MYOFFSET) + MYOFFSET = OMP_GET_THREAD_NUM()*N + DO I = 1, N + A(MYOFFSET+I) = FLOAT(I) + ENDDO +!$OMP END PARALLEL +END SUBROUTINE A7_1 diff --git a/gcc/testsuite/gfortran.dg/gomp/appendix-a/a.7.2.f90 b/gcc/testsuite/gfortran.dg/gomp/appendix-a/a.7.2.f90 new file mode 100644 index 00000000000..23f2318764c --- /dev/null +++ b/gcc/testsuite/gfortran.dg/gomp/appendix-a/a.7.2.f90 @@ -0,0 +1,22 @@ +! { dg-do compile } + +SUBROUTINE A7_2(A,B,N,I1,I2) +REAL A(*), B(*) +INTEGER I1, I2, N +!$OMP PARALLEL SHARED(A,B,I1,I2) +!$OMP SECTIONS +!$OMP SECTION + DO I1 = I1, N + IF (A(I1).NE.0.0) EXIT + ENDDO +!$OMP SECTION + DO I2 = I2, N + IF (B(I2).NE.0.0) EXIT + ENDDO +!$OMP END SECTIONS +!$OMP SINGLE + IF (I1.LE.N) PRINT *, "ITEMS IN A UP TO ", I1, " ARE ALL ZERO." + IF (I2.LE.N) PRINT *, "ITEMS IN B UP TO ", I2, " ARE ALL ZERO." +!$OMP END SINGLE +!$OMP END PARALLEL +END SUBROUTINE A7_2 diff --git a/gcc/testsuite/gfortran.dg/gomp/appendix-a/a.8.1.f90 b/gcc/testsuite/gfortran.dg/gomp/appendix-a/a.8.1.f90 new file mode 100644 index 00000000000..f499e7f8979 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/gomp/appendix-a/a.8.1.f90 @@ -0,0 +1,18 @@ +! { dg-do compile } + SUBROUTINE A8(N, M, A, B, Y, Z) + INTEGER N, M + REAL A(*), B(*), Y(*), Z(*) + INTEGER I +!$OMP PARALLEL +!$OMP DO + DO I=2,N + B(I) = (A(I) + A(I-1)) / 2.0 + ENDDO +!$OMP END DO NOWAIT +!$OMP DO + DO I=1,M + Y(I) = SQRT(Z(I)) + ENDDO +!$OMP END DO NOWAIT +!$OMP END PARALLEL + END SUBROUTINE A8 diff --git a/gcc/testsuite/gfortran.dg/gomp/appendix-a/a.9.1.f90 b/gcc/testsuite/gfortran.dg/gomp/appendix-a/a.9.1.f90 new file mode 100644 index 00000000000..fc7b67de53e --- /dev/null +++ b/gcc/testsuite/gfortran.dg/gomp/appendix-a/a.9.1.f90 @@ -0,0 +1,11 @@ +! { dg-do compile } + SUBROUTINE A9() +!$OMP PARALLEL SECTIONS +!$OMP SECTION + CALL XAXIS() +!$OMP SECTION + CALL YAXIS() +!$OMP SECTION + CALL ZAXIS() +!$OMP END PARALLEL SECTIONS + END SUBROUTINE A9 diff --git a/gcc/testsuite/gfortran.dg/gomp/block-1.f90 b/gcc/testsuite/gfortran.dg/gomp/block-1.f90 new file mode 100644 index 00000000000..f03602ab2f4 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/gomp/block-1.f90 @@ -0,0 +1,10 @@ +! { dg-do compile } + +!$omp parallel +!$omp critical + goto 10 ! { dg-error "invalid exit" } +!$omp end critical + 10 x = 1 +!$omp end parallel + + end diff --git a/gcc/testsuite/gfortran.dg/gomp/crayptr1.f90 b/gcc/testsuite/gfortran.dg/gomp/crayptr1.f90 new file mode 100644 index 00000000000..fca5606e032 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/gomp/crayptr1.f90 @@ -0,0 +1,51 @@ +! { dg-do compile } +! { dg-options "-fopenmp -fcray-pointer" } + + integer :: a, b, c, d, i + pointer (ip1, a) + pointer (ip2, b) + pointer (ip3, c) + pointer (ip4, d) + +!$omp parallel shared (a) ! { dg-error "Cray pointee 'a' in SHARED clause" } +!$omp end parallel + +!$omp parallel private (b) ! { dg-error "Cray pointee 'b' in PRIVATE clause" } +!$omp end parallel + +!$omp parallel firstprivate (c) ! { dg-error "Cray pointee 'c' in FIRSTPRIVATE clause" } +!$omp end parallel + +!$omp parallel do lastprivate (d) ! { dg-error "Cray pointee 'd' in LASTPRIVATE clause" } + do i = 1, 10 + if (i .eq. 10) d = 1 + end do +!$omp end parallel do + +!$omp parallel reduction (+: a) ! { dg-error "Cray pointee 'a' in REDUCTION clause" } +!$omp end parallel + + ip1 = loc (i) +!$omp parallel shared (ip1) + a = 2 +!$omp end parallel + +!$omp parallel private (ip2, i) + ip2 = loc (i) + b = 1 +!$omp end parallel + + ip3 = loc (i) +!$omp parallel firstprivate (ip3) ! { dg-error "Cray pointer 'ip3' in FIRSTPRIVATE clause" } +!$omp end parallel + +!$omp parallel do lastprivate (ip4) ! { dg-error "Cray pointer 'ip4' in LASTPRIVATE clause" } + do i = 1, 10 + if (i .eq. 10) ip4 = loc (i) + end do +!$omp end parallel do + +!$omp parallel reduction (+: ip1) ! { dg-error "Cray pointer 'ip1' in REDUCTION clause" } +!$omp end parallel + +end diff --git a/gcc/testsuite/gfortran.dg/gomp/crayptr2.f90 b/gcc/testsuite/gfortran.dg/gomp/crayptr2.f90 new file mode 100644 index 00000000000..476d7b9e771 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/gomp/crayptr2.f90 @@ -0,0 +1,17 @@ +! { dg-do compile } +! { dg-options "-fopenmp -fcray-pointer" } +! { dg-require-effective-target tls } + +module crayptr2 + integer :: e ! { dg-error "CRAY POINTEE attribute conflicts with THREADPRIVATE" } + pointer (ip5, e) + +! The standard is not very clear about this. +! Certainly, Cray pointees can't be SAVEd, nor they can be +! in COMMON, so the only way to make threadprivate Cray pointees would +! be if they are module variables. But threadprivate pointees don't +! make any sense anyway. + +!$omp threadprivate (e) + +end module crayptr2 diff --git a/gcc/testsuite/gfortran.dg/gomp/crayptr3.f90 b/gcc/testsuite/gfortran.dg/gomp/crayptr3.f90 new file mode 100644 index 00000000000..be8f5a0f4a7 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/gomp/crayptr3.f90 @@ -0,0 +1,22 @@ +! { dg-do compile } +! { dg-options "-fopenmp -fcray-pointer" } + + integer :: a, b + pointer (ip, a) + + b = 2 + ip = loc (b) +!$omp parallel default (none) shared (ip) + a = 1 +!$omp end parallel + +!$omp parallel default (none) private (ip, b) + b = 3 + ip = loc (b) + a = 1 +!$omp end parallel + +!$omp parallel default (none) ! { dg-error "enclosing parallel" } + a = 1 ! { dg-error "'ip' not specified in enclosing parallel" } +!$omp end parallel +end diff --git a/gcc/testsuite/gfortran.dg/gomp/crayptr4.f90 b/gcc/testsuite/gfortran.dg/gomp/crayptr4.f90 new file mode 100644 index 00000000000..d7da0bd8cc9 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/gomp/crayptr4.f90 @@ -0,0 +1,24 @@ +! { dg-do compile } +! { dg-options "-fopenmp -fcray-pointer" } + +subroutine foo (n) + integer :: a, b (38), n + pointer (ip, a (n + 1)) + + b = 2 + n = 36 + ip = loc (b) +!$omp parallel default (none) shared (ip) +!$omp parallel default (none) shared (ip) + a = 1 +!$omp end parallel +!$omp end parallel + +!$omp parallel default (none) +!$omp parallel default (none) private (ip, b) + b = 3 + ip = loc (b) + a = 1 +!$omp end parallel +!$omp end parallel +end diff --git a/gcc/testsuite/gfortran.dg/gomp/do-1.f90 b/gcc/testsuite/gfortran.dg/gomp/do-1.f90 new file mode 100644 index 00000000000..a9c9cf11df6 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/gomp/do-1.f90 @@ -0,0 +1,26 @@ +! { dg-do compile } +! { dg-options "-O -fopenmp -fdump-tree-omplower" } + +subroutine foo (i, j, k, s, a) + integer :: i, j, k, s, a(100), l +!$omp parallel do schedule (dynamic, s * 2) + do 100, l = j, k +100 a(l) = i +!$omp parallel do schedule (dynamic, s * 2) + do 101, l = j, k, 3 +101 a(l) = i + 1 +end subroutine foo + +subroutine bar (i, j, k, s, a) + integer :: i, j, k, s, a(100), l +!$omp parallel do schedule (guided, s * 2) + do 100, l = j, k +100 a(l) = i +!$omp parallel do schedule (guided, s * 2) + do 101, l = j, k, 3 +101 a(l) = i + 1 +end subroutine bar + +! { dg-final { scan-tree-dump-times "GOMP_parallel_loop_dynamic_start" 2 "omplower" { xfail *-*-* } } } +! { dg-final { scan-tree-dump-times "GOMP_parallel_loop_guided_start" 2 "omplower" { xfail *-*-* } } } +! { dg-final { cleanup-tree-dump "omplower" } } diff --git a/gcc/testsuite/gfortran.dg/gomp/fixed-1.f b/gcc/testsuite/gfortran.dg/gomp/fixed-1.f new file mode 100644 index 00000000000..d61f2ba638d --- /dev/null +++ b/gcc/testsuite/gfortran.dg/gomp/fixed-1.f @@ -0,0 +1,22 @@ +C PR fortran/24493 +C { dg-do compile } +C { dg-require-effective-target tls } + INTEGER I, J, K, L, M +C$OMP THREADPRIVATE(I) +C SOME COMMENT + SAVE I ! ANOTHER COMMENT +C$OMP THREADPRIVATE +C$OMP+(J) ! OMP DIRECTIVE COMMENT +* NORMAL COMMENT +c$OMP THREAD! COMMENT +C$OMP&PRIVATE! COMMENT +*$OMP+ (K) +C$OMP THREADPRIVATE (L ! COMMENT +*$OMP& , M) + SAVE J, K, L, M + I = 1 + J = 2 + K = 3 + L = 4 + M = 5 + END diff --git a/gcc/testsuite/gfortran.dg/gomp/free-1.f90 b/gcc/testsuite/gfortran.dg/gomp/free-1.f90 new file mode 100644 index 00000000000..f6f9de4441b --- /dev/null +++ b/gcc/testsuite/gfortran.dg/gomp/free-1.f90 @@ -0,0 +1,8 @@ +! { dg-require-effective-target tls } + +subroutine foo +integer, save :: i ! Some comment +!$omp threadpri& + !$omp&vate (i) +i = 1 +end subroutine diff --git a/gcc/testsuite/gfortran.dg/gomp/gomp.exp b/gcc/testsuite/gfortran.dg/gomp/gomp.exp new file mode 100644 index 00000000000..0cafd924d79 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/gomp/gomp.exp @@ -0,0 +1,14 @@ +# GCC testsuite that uses the `dg.exp' driver. + +# Load support procs. +load_lib gfortran-dg.exp + +# Initialize `dg'. +dg-init + +# Main loop. +gfortran-dg-runtest [lsort \ + [find $srcdir/$subdir *.\[fF\]{,90,95} ] ] " -fopenmp" + +# All done. +dg-finish diff --git a/gcc/testsuite/gfortran.dg/gomp/omp_atomic1.f90 b/gcc/testsuite/gfortran.dg/gomp/omp_atomic1.f90 new file mode 100644 index 00000000000..247f8ae50ab --- /dev/null +++ b/gcc/testsuite/gfortran.dg/gomp/omp_atomic1.f90 @@ -0,0 +1,38 @@ +! { dg-do compile } +subroutine test_atomic + integer (kind = 4) :: a + integer :: b + real :: c, f + double precision :: d + integer, dimension (10) :: e + a = 1 + b = 2 + c = 3 + d = 4 + e = 5 + f = 6 +!$omp atomic + a = a + 4 +!$omp atomic + b = 4 - b +!$omp atomic + c = c * 2 +!$omp atomic + d = 2 / d +!$omp atomic + e = 1 ! { dg-error "must set a scalar variable" } +!$omp atomic + a = a ** 8 ! { dg-error "assignment operator must be" } +!$omp atomic + b = b + 3 + b ! { dg-error "cannot reference" } +!$omp atomic + c = c - f + 1 ! { dg-error "not mathematically equivalent to" } +!$omp atomic + a = ishft (a, 1) ! { dg-error "assignment intrinsic must be" } +!$omp atomic + c = min (c, 2.1, c) ! { dg-error "intrinsic arguments except one" } +!$omp atomic + a = max (b, e(1)) ! { dg-error "intrinsic argument must be 'a'" } +!$omp atomic + d = 12 ! { dg-error "assignment must have an operator" } +end subroutine test_atomic diff --git a/gcc/testsuite/gfortran.dg/gomp/omp_clauses1.f90 b/gcc/testsuite/gfortran.dg/gomp/omp_clauses1.f90 new file mode 100644 index 00000000000..8851101b92c --- /dev/null +++ b/gcc/testsuite/gfortran.dg/gomp/omp_clauses1.f90 @@ -0,0 +1,25 @@ +! { dg-do compile } + subroutine test1 + integer :: i, j, k, l + common /b/ j, k +!$omp parallel shared (i) private (/b/) +!$omp end parallel +!$omp parallel do shared (/b/), firstprivate (i), lastprivate (i) + do l = 1, 10 + end do +!$omp end parallel do +!$omp parallel shared (j) private (/b/) ! { dg-error "'j' present on multiple clauses" } +!$omp end parallel +!$omp parallel shared (j, j) private (i) ! { dg-error "'j' present on multiple clauses" } +!$omp end parallel +!$omp parallel firstprivate (i, j, i) ! { dg-error "'i' present on multiple clauses" } +!$omp end parallel +!$omp parallel shared (i) private (/b/, /b/) ! { dg-error "'\[jk\]' present on multiple clauses" } +!$omp end parallel +!$omp parallel shared (i) reduction (+ : i, j) ! { dg-error "'i' present on multiple clauses" } +!$omp end parallel +!$omp parallel do shared (/b/), firstprivate (/b/), lastprivate (i) ! { dg-error "'\[jk\]' present on multiple clauses" } + do l = 1, 10 + end do +!$omp end parallel do + end subroutine test1 diff --git a/gcc/testsuite/gfortran.dg/gomp/omp_do1.f90 b/gcc/testsuite/gfortran.dg/gomp/omp_do1.f90 new file mode 100644 index 00000000000..3dfd43d43e3 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/gomp/omp_do1.f90 @@ -0,0 +1,57 @@ +! { dg-do compile } +! { dg-options "-fopenmp -std=gnu" } +subroutine foo + integer :: i, j + integer, dimension (30) :: a + double precision :: d + i = 0 +!$omp do private (i) + do 100 ! { dg-error "cannot be a DO WHILE or DO without loop control" } + if (i .gt. 0) exit ! { dg-error "EXIT statement" } +100 i = i + 1 + i = 0 +!$omp do private (i) + do ! { dg-error "cannot be a DO WHILE or DO without loop control" } + if (i .gt. 0) exit ! { dg-error "EXIT statement" } + i = i + 1 + end do + i = 0 +!$omp do private (i) + do 200 while (i .lt. 4) ! { dg-error "cannot be a DO WHILE or DO without loop control" } +200 i = i + 1 +!$omp do private (i) + do while (i .lt. 8) ! { dg-error "cannot be a DO WHILE or DO without loop control" } + i = i + 1 + end do +!$omp do + do 300 d = 1, 30, 6 ! { dg-warning "Obsolete: REAL DO loop iterator" } + i = d +300 a(i) = 1 +!$omp do + do d = 1, 30, 5 ! { dg-warning "Obsolete: REAL DO loop iterator" } + i = d + a(i) = 2 + end do +!$omp do + do i = 1, 30 + if (i .eq. 16) exit ! { dg-error "EXIT statement" } + end do +!$omp do +outer: do i = 1, 30 + do j = 5, 10 + if (i .eq. 6 .and. j .eq. 7) exit outer ! { dg-error "EXIT statement" } + end do + end do outer +last: do i = 1, 30 +!$omp parallel + if (i .eq. 21) exit last ! { dg-error "leaving OpenMP structured block" } +!$omp end parallel + end do last +!$omp parallel do shared (i) + do i = 1, 30, 2 ! { dg-error "iteration variable present on clause" } + a(i) = 5 + end do +!$omp end parallel do +end subroutine +! { dg-error "iteration variable must be of type integer" "" { target *-*-* } 27 } +! { dg-error "iteration variable must be of type integer" "" { target *-*-* } 31 } diff --git a/gcc/testsuite/gfortran.dg/gomp/omp_threadprivate1.f90 b/gcc/testsuite/gfortran.dg/gomp/omp_threadprivate1.f90 new file mode 100644 index 00000000000..55aad067082 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/gomp/omp_threadprivate1.f90 @@ -0,0 +1,17 @@ +! { dg-require-effective-target tls } + module omp_threadprivate1 + common /T/ a + end module omp_threadprivate1 + subroutine bad1 + use omp_threadprivate1 +!$omp threadprivate (/T/) ! { dg-error "not found" } + end subroutine bad1 + subroutine bad2 + common /S/ b +!$omp threadprivate (/S/) + contains + subroutine bad3 +!$omp parallel copyin (/T/) ! { dg-error "not found" } +!$omp end parallel ! { dg-error "" } + end subroutine bad3 + end subroutine bad2 diff --git a/gcc/testsuite/gfortran.dg/gomp/omp_threadprivate2.f90 b/gcc/testsuite/gfortran.dg/gomp/omp_threadprivate2.f90 new file mode 100644 index 00000000000..cd1ab5cd60a --- /dev/null +++ b/gcc/testsuite/gfortran.dg/gomp/omp_threadprivate2.f90 @@ -0,0 +1,6 @@ +! { dg-do compile } +! { dg-require-effective-target tls } + subroutine bad1 + double precision :: d ! { dg-error "isn't SAVEd" } +!$omp threadprivate (d) + end subroutine bad1 diff --git a/gcc/testsuite/gfortran.dg/gomp/reduction1.f90 b/gcc/testsuite/gfortran.dg/gomp/reduction1.f90 new file mode 100644 index 00000000000..b69714d4b91 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/gomp/reduction1.f90 @@ -0,0 +1,131 @@ +! { dg-do compile } +! { dg-require-effective-target tls } + +subroutine foo (ia1) +integer :: i1, i2, i3 +integer, dimension (*) :: ia1 +integer, dimension (10) :: ia2 +real :: r1 +real, dimension (5) :: ra1 +double precision :: d1 +double precision, dimension (4) :: da1 +complex :: c1 +complex, dimension (7) :: ca1 +logical :: l1 +logical, dimension (3) :: la1 +character (5) :: a1 +type t + integer :: i +end type +type(t) :: t1 +type(t), dimension (2) :: ta1 +real, pointer :: p1 => NULL() +integer, allocatable :: aa1 (:,:) +save i2 +!$omp threadprivate (i2) +common /blk/ i1 + +!$omp parallel reduction (+:i3, ia2, r1, ra1, d1, da1, c1, ca1) +!$omp end parallel +!$omp parallel reduction (*:i3, ia2, r1, ra1, d1, da1, c1, ca1) +!$omp end parallel +!$omp parallel reduction (-:i3, ia2, r1, ra1, d1, da1, c1, ca1) +!$omp end parallel +!$omp parallel reduction (.and.:l1, la1) +!$omp end parallel +!$omp parallel reduction (.or.:l1, la1) +!$omp end parallel +!$omp parallel reduction (.eqv.:l1, la1) +!$omp end parallel +!$omp parallel reduction (.neqv.:l1, la1) +!$omp end parallel +!$omp parallel reduction (min:i3, ia2, r1, ra1, d1, da1) +!$omp end parallel +!$omp parallel reduction (max:i3, ia2, r1, ra1, d1, da1) +!$omp end parallel +!$omp parallel reduction (iand:i3, ia2) +!$omp end parallel +!$omp parallel reduction (ior:i3, ia2) +!$omp end parallel +!$omp parallel reduction (ieor:i3, ia2) +!$omp end parallel +!$omp parallel reduction (+:/blk/) ! { dg-error "Syntax error" } +!$omp end parallel ! { dg-error "Unexpected" } +!$omp parallel reduction (+:i2) ! { dg-error "THREADPRIVATE object" } +!$omp end parallel +!$omp parallel reduction (*:p1) ! { dg-error "POINTER object" } +!$omp end parallel +!$omp parallel reduction (-:aa1) ! { dg-error "is ALLOCATABLE" } +!$omp end parallel +!$omp parallel reduction (*:ia1) ! { dg-error "Assumed size" } +!$omp end parallel +!$omp parallel reduction (+:l1) ! { dg-error "is LOGICAL" } +!$omp end parallel +!$omp parallel reduction (*:la1) ! { dg-error "is LOGICAL" } +!$omp end parallel +!$omp parallel reduction (-:a1) ! { dg-error "is CHARACTER" } +!$omp end parallel +!$omp parallel reduction (+:t1) ! { dg-error "is TYPE" } +!$omp end parallel +!$omp parallel reduction (*:ta1) ! { dg-error "is TYPE" } +!$omp end parallel +!$omp parallel reduction (.and.:i3) ! { dg-error "must be LOGICAL" } +!$omp end parallel +!$omp parallel reduction (.or.:ia2) ! { dg-error "must be LOGICAL" } +!$omp end parallel +!$omp parallel reduction (.eqv.:r1) ! { dg-error "must be LOGICAL" } +!$omp end parallel +!$omp parallel reduction (.neqv.:ra1) ! { dg-error "must be LOGICAL" } +!$omp end parallel +!$omp parallel reduction (.and.:d1) ! { dg-error "must be LOGICAL" } +!$omp end parallel +!$omp parallel reduction (.or.:da1) ! { dg-error "must be LOGICAL" } +!$omp end parallel +!$omp parallel reduction (.eqv.:c1) ! { dg-error "must be LOGICAL" } +!$omp end parallel +!$omp parallel reduction (.neqv.:ca1) ! { dg-error "must be LOGICAL" } +!$omp end parallel +!$omp parallel reduction (.and.:a1) ! { dg-error "must be LOGICAL" } +!$omp end parallel +!$omp parallel reduction (.or.:t1) ! { dg-error "must be LOGICAL" } +!$omp end parallel +!$omp parallel reduction (.eqv.:ta1) ! { dg-error "must be LOGICAL" } +!$omp end parallel +!$omp parallel reduction (min:c1) ! { dg-error "must be INTEGER or REAL" } +!$omp end parallel +!$omp parallel reduction (max:ca1) ! { dg-error "must be INTEGER or REAL" } +!$omp end parallel +!$omp parallel reduction (max:l1) ! { dg-error "must be INTEGER or REAL" } +!$omp end parallel +!$omp parallel reduction (min:la1) ! { dg-error "must be INTEGER or REAL" } +!$omp end parallel +!$omp parallel reduction (max:a1) ! { dg-error "must be INTEGER or REAL" } +!$omp end parallel +!$omp parallel reduction (min:t1) ! { dg-error "must be INTEGER or REAL" } +!$omp end parallel +!$omp parallel reduction (max:ta1) ! { dg-error "must be INTEGER or REAL" } +!$omp end parallel +!$omp parallel reduction (iand:r1) ! { dg-error "must be INTEGER" } +!$omp end parallel +!$omp parallel reduction (ior:ra1) ! { dg-error "must be INTEGER" } +!$omp end parallel +!$omp parallel reduction (ieor:d1) ! { dg-error "must be INTEGER" } +!$omp end parallel +!$omp parallel reduction (ior:da1) ! { dg-error "must be INTEGER" } +!$omp end parallel +!$omp parallel reduction (iand:c1) ! { dg-error "must be INTEGER" } +!$omp end parallel +!$omp parallel reduction (ior:ca1) ! { dg-error "must be INTEGER" } +!$omp end parallel +!$omp parallel reduction (ieor:l1) ! { dg-error "must be INTEGER" } +!$omp end parallel +!$omp parallel reduction (iand:la1) ! { dg-error "must be INTEGER" } +!$omp end parallel +!$omp parallel reduction (ior:a1) ! { dg-error "must be INTEGER" } +!$omp end parallel +!$omp parallel reduction (ieor:t1) ! { dg-error "must be INTEGER" } +!$omp end parallel +!$omp parallel reduction (iand:ta1) ! { dg-error "must be INTEGER" } +!$omp end parallel + +end subroutine diff --git a/gcc/testsuite/gfortran.dg/gomp/reduction2.f90 b/gcc/testsuite/gfortran.dg/gomp/reduction2.f90 new file mode 100644 index 00000000000..f855d0e7fa7 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/gomp/reduction2.f90 @@ -0,0 +1,33 @@ +! { dg-do compile } + +subroutine f1 + integer :: i + i = 0 +!$omp parallel reduction (ior:i) + i = ior (i, 3) +!$omp end parallel +!$omp parallel reduction (ior:i) + i = ior (i, 16) +!$omp end parallel +end subroutine f1 +subroutine f2 + integer :: i + i = ior (2, 4) +!$omp parallel reduction (ior:i) + i = ior (i, 3) +!$omp end parallel +end subroutine f2 +subroutine f3 + integer :: i + i = 6 +!$omp parallel reduction (ior:i) + i = ior (i, 3) +!$omp end parallel +end subroutine f3 +subroutine f4 + integer :: i, ior + i = 6 +!$omp parallel reduction (ior:i) + i = ior (i, 3) +!$omp end parallel +end subroutine f4 diff --git a/gcc/testsuite/gfortran.dg/gomp/reduction3.f90 b/gcc/testsuite/gfortran.dg/gomp/reduction3.f90 new file mode 100644 index 00000000000..1bb0e21c387 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/gomp/reduction3.f90 @@ -0,0 +1,69 @@ +! { dg-do compile } + +module mreduction3 + interface + function ior (a, b) + integer :: ior, a, b + end function + end interface +contains + function iand (a, b) + integer :: iand, a, b + iand = a + b + end function +end module mreduction3 +subroutine f1 + integer :: i, ior + ior = 6 + i = 6 +!$omp parallel reduction (ior:i) ! { dg-error "is not INTRINSIC procedure name" } +!$omp end parallel +end subroutine f1 +subroutine f2 + integer :: i + interface + function ior (a, b) + integer :: ior, a, b + end function + end interface + i = 6 +!$omp parallel reduction (ior:i) ! { dg-error "is not INTRINSIC procedure name" } + i = ior (i, 3) +!$omp end parallel +end subroutine f2 +subroutine f3 + integer :: i + interface + function ior (a, b) + integer :: ior, a, b + end function + end interface + intrinsic ior + i = 6 +!$omp parallel reduction (ior:i) + i = ior (i, 3) +!$omp end parallel +end subroutine f3 +subroutine f4 + integer :: i, ior + i = 6 +!$omp parallel reduction (ior:i) + ior = 4 ! { dg-error "Expected VARIABLE" } +!$omp end parallel +end subroutine f4 +subroutine f5 + use mreduction3 + integer :: i + i = 6 +!$omp parallel reduction (ior:i) ! { dg-error "is not INTRINSIC procedure name" } + i = ior (i, 7) +!$omp end parallel +end subroutine f5 +subroutine f6 + use mreduction3 + integer :: i + i = 6 +!$omp parallel reduction (iand:i) ! { dg-error "is not INTRINSIC procedure name" } + i = iand (i, 18) +!$omp end parallel +end subroutine f6 diff --git a/gcc/testsuite/gfortran.dg/gomp/sharing-1.f90 b/gcc/testsuite/gfortran.dg/gomp/sharing-1.f90 new file mode 100644 index 00000000000..7a107ffe7cb --- /dev/null +++ b/gcc/testsuite/gfortran.dg/gomp/sharing-1.f90 @@ -0,0 +1,28 @@ +! { dg-do compile } +! { dg-require-effective-target tls } + + integer :: thrpriv, thr, i, j, s, g1, g2, m + integer, dimension (6) :: p + common /thrblk/ thr + common /gblk/ g1 + save thrpriv, g2 +!$omp threadprivate (/thrblk/, thrpriv) + s = 1 +!$omp parallel do default (none) & +!$omp & private (p) shared (s) ! { dg-error "enclosing parallel" } + do i = 1, 64 + call foo (thrpriv) ! Predetermined - threadprivate + call foo (thr) ! Predetermined - threadprivate + call foo (i) ! Predetermined - omp do iteration var + do j = 1, 64 ! Predetermined - sequential loop + call foo (j) ! iteration variable + end do + call bar ((/ (k * 4, k = 1, 8) /)) ! Predetermined - implied do + forall (l = 1 : i) &! Predetermined - forall indice + p(l) = 6 ! Explicitly determined - private + call foo (s) ! Explicitly determined - shared + call foo (g1) ! { dg-error "not specified in" } + call foo (g2) ! { dg-error "not specified in" } + call foo (m) ! { dg-error "not specified in" } + end do +end diff --git a/gcc/testsuite/gfortran.dg/gomp/sharing-2.f90 b/gcc/testsuite/gfortran.dg/gomp/sharing-2.f90 new file mode 100644 index 00000000000..aede06c9c0f --- /dev/null +++ b/gcc/testsuite/gfortran.dg/gomp/sharing-2.f90 @@ -0,0 +1,84 @@ + integer :: i, j, k, l + integer, dimension (10, 10) :: a +!$omp parallel do default (none) shared (a) + do i = 1, 10 + j = 4 + do j = 1, 10 + a(i, j) = i + j + end do + j = 8 + end do +!$omp end parallel do +!$omp parallel default (none) shared (a) ! { dg-error "enclosing parallel" } + i = 1 + j = 1 + k = 1 + l = 1 ! { dg-error "not specified in" } + do i = 1, 10 + a(i, 1) = 1 + end do +!$omp critical + do j = 1, 10 + a(1, j) = j + end do +!$omp end critical +!$omp single + do k = 1, 10 + a(k, k) = k + end do +!$omp end single +!$omp end parallel +!$omp parallel default (none) shared (a) + i = 1 + j = 1 + k = 1 +!$omp parallel default (none) shared (a) + i = 1 + j = 1 + k = 1 + do i = 1, 10 + a(i, 1) = 1 + end do +!$omp critical + do j = 1, 10 + a(1, j) = j + end do +!$omp end critical +!$omp single + do k = 1, 10 + a(k, k) = k + end do +!$omp end single +!$omp end parallel + i = 1 + j = 1 + k = 1 +!$omp end parallel +!$omp parallel default (none) shared (a) ! { dg-error "enclosing parallel" } + i = 1 ! { dg-error "not specified in" } +!$omp do + do i = 1, 10 + a(i, 1) = i + 1 + end do +!$omp end parallel +!$omp parallel default (none) shared (a) ! { dg-error "enclosing parallel" } + i = 1 ! { dg-error "not specified in" } +!$omp parallel do default (none) shared (a) + do i = 1, 10 + a(i, 1) = i + 1 + end do +!$omp end parallel +!$omp parallel default (none) shared (a) + i = 1 +!$omp parallel default (none) shared (a, i) + i = 2 +!$omp parallel default (none) shared (a) + do i = 1, 10 + a(i, 1) = i + end do +!$omp end parallel + i = 3 +!$omp end parallel + i = 4 +!$omp end parallel +end diff --git a/gcc/testsuite/gfortran.dg/gomp/workshare1.f90 b/gcc/testsuite/gfortran.dg/gomp/workshare1.f90 new file mode 100644 index 00000000000..ffbb1db8211 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/gomp/workshare1.f90 @@ -0,0 +1,42 @@ +! { dg-do compile } + +interface + subroutine foo + end subroutine + function bar () + integer :: bar + end function bar + elemental function baz () + integer :: baz + end function baz +end interface + + integer :: i, j + real :: a, b (10), c + a = 0.5 + b = 0.25 +!$omp parallel workshare + a = sin (a) + b = sin (b) + forall (i = 1:10) b(i) = cos (b(i)) - 0.5 + j = baz () +!$omp parallel if (bar () .gt. 2) & +!$omp & num_threads (bar () + 1) + i = bar () +!$omp end parallel +!$omp parallel do schedule (static, bar () + 4) + do j = 1, 10 + i = bar () + end do +!$omp end parallel do +!$omp end parallel workshare +!$omp parallel workshare + call foo ! { dg-error "CALL statement" } + i = bar () ! { dg-error "non-ELEMENTAL" } +!$omp critical + i = bar () ! { dg-error "non-ELEMENTAL" } +!$omp end critical +!$omp atomic + j = j + bar () ! { dg-error "non-ELEMENTAL" } +!$omp end parallel workshare +end diff --git a/libgomp/ChangeLog b/libgomp/ChangeLog index 260d9680dc0..fd21de23a52 100644 --- a/libgomp/ChangeLog +++ b/libgomp/ChangeLog @@ -1,3 +1,8 @@ +2006-02-13 Jakub Jelinek + + * testsuite/libgomp.fortran/vla7.f90: Add -w to options. + Remove tests for returning assumed character length arrays. + 2006-02-12 Roger Sayle John David Anglin diff --git a/libgomp/testsuite/libgomp.fortran/appendix-a/a.15.1.f90 b/libgomp/testsuite/libgomp.fortran/appendix-a/a.15.1.f90 new file mode 100644 index 00000000000..3d95451eaff --- /dev/null +++ b/libgomp/testsuite/libgomp.fortran/appendix-a/a.15.1.f90 @@ -0,0 +1,31 @@ +! { dg-do compile } + SUBROUTINE WORK(N) + INTEGER N + END SUBROUTINE WORK + SUBROUTINE SUB3(N) + INTEGER N + CALL WORK(N) +!$OMP BARRIER + CALL WORK(N) + END SUBROUTINE SUB3 + SUBROUTINE SUB2(K) + INTEGER K +!$OMP PARALLEL SHARED(K) + CALL SUB3(K) +!$OMP END PARALLEL + END SUBROUTINE SUB2 + SUBROUTINE SUB1(N) + INTEGER N + INTEGER I +!$OMP PARALLEL PRIVATE(I) SHARED(N) +!$OMP DO + DO I = 1, N + CALL SUB2(I) + END DO +!$OMP END PARALLEL + END SUBROUTINE SUB1 + PROGRAM A15 + CALL SUB1(2) + CALL SUB2(2) + CALL SUB3(2) + END PROGRAM A15 diff --git a/libgomp/testsuite/libgomp.fortran/appendix-a/a.16.1.f90 b/libgomp/testsuite/libgomp.fortran/appendix-a/a.16.1.f90 new file mode 100644 index 00000000000..014d4fd5ac4 --- /dev/null +++ b/libgomp/testsuite/libgomp.fortran/appendix-a/a.16.1.f90 @@ -0,0 +1,41 @@ +! { dg-do run } + REAL FUNCTION WORK1(I) + INTEGER I + WORK1 = 1.0 * I + RETURN + END FUNCTION WORK1 + + REAL FUNCTION WORK2(I) + INTEGER I + WORK2 = 2.0 * I + RETURN + END FUNCTION WORK2 + + SUBROUTINE SUBA16(X, Y, INDEX, N) + REAL X(*), Y(*) + INTEGER INDEX(*), N + INTEGER I +!$OMP PARALLEL DO SHARED(X, Y, INDEX, N) + DO I=1,N +!$OMP ATOMIC + X(INDEX(I)) = X(INDEX(I)) + WORK1(I) + Y(I) = Y(I) + WORK2(I) + ENDDO + END SUBROUTINE SUBA16 + + PROGRAM A16 + REAL X(1000), Y(10000) + INTEGER INDEX(10000) + INTEGER I + DO I=1,10000 + INDEX(I) = MOD(I, 1000) + 1 + Y(I) = 0.0 + ENDDO + DO I = 1,1000 + X(I) = 0.0 + ENDDO + CALL SUBA16(X, Y, INDEX, 10000) + DO I = 1,10 + PRINT *, "X(", I, ") = ", X(I), ", Y(", I, ") = ", Y(I) + ENDDO + END PROGRAM A16 diff --git a/libgomp/testsuite/libgomp.fortran/appendix-a/a.18.1.f90 b/libgomp/testsuite/libgomp.fortran/appendix-a/a.18.1.f90 new file mode 100644 index 00000000000..3321485efc3 --- /dev/null +++ b/libgomp/testsuite/libgomp.fortran/appendix-a/a.18.1.f90 @@ -0,0 +1,59 @@ +! { dg-do run } +! { dg-options "-ffixed-form" } + REAL FUNCTION FN1(I) + INTEGER I + FN1 = I * 2.0 + RETURN + END FUNCTION FN1 + + REAL FUNCTION FN2(A, B) + REAL A, B + FN2 = A + B + RETURN + END FUNCTION FN2 + + PROGRAM A18 + INCLUDE "omp_lib.h" ! or USE OMP_LIB + INTEGER ISYNC(256) + REAL WORK(256) + REAL RESULT(256) + INTEGER IAM, NEIGHBOR +!$OMP PARALLEL PRIVATE(IAM, NEIGHBOR) SHARED(WORK, ISYNC) NUM_THREADS(4) + IAM = OMP_GET_THREAD_NUM() + 1 + ISYNC(IAM) = 0 +!$OMP BARRIER +! Do computation into my portion of work array + WORK(IAM) = FN1(IAM) +! Announce that I am done with my work. +! The first flush ensures that my work is made visible before +! synch. The second flush ensures that synch is made visible. +!$OMP FLUSH(WORK,ISYNC) + ISYNC(IAM) = 1 +!$OMP FLUSH(ISYNC) + +! Wait until neighbor is done. The first flush ensures that +! synch is read from memory, rather than from the temporary +! view of memory. The second flush ensures that work is read +! from memory, and is done so after the while loop exits. + IF (IAM .EQ. 1) THEN + NEIGHBOR = OMP_GET_NUM_THREADS() + ELSE + NEIGHBOR = IAM - 1 + ENDIF + DO WHILE (ISYNC(NEIGHBOR) .EQ. 0) +!$OMP FLUSH(ISYNC) + END DO +!$OMP FLUSH(WORK, ISYNC) + RESULT(IAM) = FN2(WORK(NEIGHBOR), WORK(IAM)) +!$OMP END PARALLEL + DO I=1,4 + IF (I .EQ. 1) THEN + NEIGHBOR = 4 + ELSE + NEIGHBOR = I - 1 + ENDIF + IF (RESULT(I) .NE. I * 2 + NEIGHBOR * 2) THEN + CALL ABORT + ENDIF + ENDDO + END PROGRAM A18 diff --git a/libgomp/testsuite/libgomp.fortran/appendix-a/a.19.1.f90 b/libgomp/testsuite/libgomp.fortran/appendix-a/a.19.1.f90 new file mode 100644 index 00000000000..1fe1c424726 --- /dev/null +++ b/libgomp/testsuite/libgomp.fortran/appendix-a/a.19.1.f90 @@ -0,0 +1,60 @@ +! { dg-do run } + SUBROUTINE F1(Q) + COMMON /DATA/ P, X + INTEGER, TARGET :: X + INTEGER, POINTER :: P + INTEGER Q + Q=1 +!$OMP FLUSH + ! X, P and Q are flushed + ! because they are shared and accessible + END SUBROUTINE F1 + SUBROUTINE F2(Q) + COMMON /DATA/ P, X + INTEGER, TARGET :: X + INTEGER, POINTER :: P + INTEGER Q +!$OMP BARRIER + Q=2 +!$OMP BARRIER + ! a barrier implies a flush + ! X, P and Q are flushed + ! because they are shared and accessible + END SUBROUTINE F2 + + INTEGER FUNCTION G(N) + COMMON /DATA/ P, X + INTEGER, TARGET :: X + INTEGER, POINTER :: P + INTEGER N + INTEGER I, J, SUM + I=1 + SUM = 0 + P=1 +!$OMP PARALLEL REDUCTION(+: SUM) NUM_THREADS(2) + CALL F1(J) + ! I, N and SUM were not flushed + ! because they were not accessible in F1 + ! J was flushed because it was accessible + SUM = SUM + J + CALL F2(J) + ! I, N, and SUM were not flushed + ! because they were not accessible in f2 + ! J was flushed because it was accessible + SUM = SUM + I + J + P + N +!$OMP END PARALLEL + G = SUM + END FUNCTION G + + PROGRAM A19 + COMMON /DATA/ P, X + INTEGER, TARGET :: X + INTEGER, POINTER :: P + INTEGER RESULT, G + P => X + RESULT = G(10) + PRINT *, RESULT + IF (RESULT .NE. 30) THEN + CALL ABORT + ENDIF + END PROGRAM A19 diff --git a/libgomp/testsuite/libgomp.fortran/appendix-a/a.2.1.f90 b/libgomp/testsuite/libgomp.fortran/appendix-a/a.2.1.f90 new file mode 100644 index 00000000000..2b09f5b1fd5 --- /dev/null +++ b/libgomp/testsuite/libgomp.fortran/appendix-a/a.2.1.f90 @@ -0,0 +1,22 @@ +! { dg-do run } +PROGRAM A2 + INCLUDE "omp_lib.h" ! or USE OMP_LIB + INTEGER X + X=2 +!$OMP PARALLEL NUM_THREADS(2) SHARED(X) + IF (OMP_GET_THREAD_NUM() .EQ. 0) THEN + X=5 + ELSE + ! PRINT 1: The following read of x has a race + PRINT *,"1: THREAD# ", OMP_GET_THREAD_NUM(), "X = ", X + ENDIF +!$OMP BARRIER + IF (OMP_GET_THREAD_NUM() .EQ. 0) THEN + ! PRINT 2 + PRINT *,"2: THREAD# ", OMP_GET_THREAD_NUM(), "X = ", X + ELSE + ! PRINT 3 + PRINT *,"3: THREAD# ", OMP_GET_THREAD_NUM(), "X = ", X + ENDIF +!$OMP END PARALLEL +END PROGRAM A2 diff --git a/libgomp/testsuite/libgomp.fortran/appendix-a/a.21.1.f90 b/libgomp/testsuite/libgomp.fortran/appendix-a/a.21.1.f90 new file mode 100644 index 00000000000..c22fa116927 --- /dev/null +++ b/libgomp/testsuite/libgomp.fortran/appendix-a/a.21.1.f90 @@ -0,0 +1,19 @@ +! { dg-do compile } + SUBROUTINE WORK(K) + INTEGER k +!$OMP ORDERED + WRITE(*,*) K +!$OMP END ORDERED + END SUBROUTINE WORK + SUBROUTINE SUBA21(LB, UB, STRIDE) + INTEGER LB, UB, STRIDE + INTEGER I +!$OMP PARALLEL DO ORDERED SCHEDULE(DYNAMIC) + DO I=LB,UB,STRIDE + CALL WORK(I) + END DO +!$OMP END PARALLEL DO + END SUBROUTINE SUBA21 + PROGRAM A21 + CALL SUBA21(1,100,5) + END PROGRAM A21 diff --git a/libgomp/testsuite/libgomp.fortran/appendix-a/a.22.7.f90 b/libgomp/testsuite/libgomp.fortran/appendix-a/a.22.7.f90 new file mode 100644 index 00000000000..fff4e6d4997 --- /dev/null +++ b/libgomp/testsuite/libgomp.fortran/appendix-a/a.22.7.f90 @@ -0,0 +1,33 @@ +! { dg-do run } +! { dg-require-effective-target tls_runtime } + + PROGRAM A22_7_GOOD + INTEGER, ALLOCATABLE, SAVE :: A(:) + INTEGER, POINTER, SAVE :: PTR + INTEGER, SAVE :: I + INTEGER, TARGET :: TARG + LOGICAL :: FIRSTIN = .TRUE. +!$OMP THREADPRIVATE(A, I, PTR) + ALLOCATE (A(3)) + A = (/1,2,3/) + PTR => TARG + I=5 +!$OMP PARALLEL COPYIN(I, PTR) +!$OMP CRITICAL + IF (FIRSTIN) THEN + TARG = 4 ! Update target of ptr + I = I + 10 + IF (ALLOCATED(A)) A = A + 10 + FIRSTIN = .FALSE. + END IF + IF (ALLOCATED(A)) THEN + PRINT *, "a = ", A + ELSE + PRINT *, "A is not allocated" + END IF + PRINT *, "ptr = ", PTR + PRINT *, "i = ", I + PRINT * +!$OMP END CRITICAL +!$OMP END PARALLEL + END PROGRAM A22_7_GOOD diff --git a/libgomp/testsuite/libgomp.fortran/appendix-a/a.22.8.f90 b/libgomp/testsuite/libgomp.fortran/appendix-a/a.22.8.f90 new file mode 100644 index 00000000000..cf6d90ee828 --- /dev/null +++ b/libgomp/testsuite/libgomp.fortran/appendix-a/a.22.8.f90 @@ -0,0 +1,25 @@ +! { dg-do run } +! { dg-require-effective-target tls_runtime } + MODULE A22_MODULE8 + REAL, POINTER :: WORK(:) + SAVE WORK +!$OMP THREADPRIVATE(WORK) + END MODULE A22_MODULE8 + SUBROUTINE SUB1(N) + USE A22_MODULE8 +!$OMP PARALLEL PRIVATE(THE_SUM) + ALLOCATE(WORK(N)) + CALL SUB2(THE_SUM) + WRITE(*,*)THE_SUM +!$OMP END PARALLEL + END SUBROUTINE SUB1 + SUBROUTINE SUB2(THE_SUM) + USE A22_MODULE8 + WORK(:) = 10 + THE_SUM=SUM(WORK) + END SUBROUTINE SUB2 + PROGRAM A22_8_GOOD + N = 10 + CALL SUB1(N) + END PROGRAM A22_8_GOOD + diff --git a/libgomp/testsuite/libgomp.fortran/appendix-a/a.26.1.f90 b/libgomp/testsuite/libgomp.fortran/appendix-a/a.26.1.f90 new file mode 100644 index 00000000000..e9ebf87af73 --- /dev/null +++ b/libgomp/testsuite/libgomp.fortran/appendix-a/a.26.1.f90 @@ -0,0 +1,11 @@ +! { dg-do run } + PROGRAM A26 + INTEGER I, J + I=1 + J=2 +!$OMP PARALLEL PRIVATE(I) FIRSTPRIVATE(J) + I=3 + J=J+2 +!$OMP END PARALLEL + PRINT *, I, J ! I and J are undefined + END PROGRAM A26 diff --git a/libgomp/testsuite/libgomp.fortran/appendix-a/a.28.1.f90 b/libgomp/testsuite/libgomp.fortran/appendix-a/a.28.1.f90 new file mode 100644 index 00000000000..c271333a86d --- /dev/null +++ b/libgomp/testsuite/libgomp.fortran/appendix-a/a.28.1.f90 @@ -0,0 +1,14 @@ +! { dg-do run } + + SUBROUTINE SUB() + COMMON /BLOCK/ X + PRINT *,X ! X is undefined + END SUBROUTINE SUB + PROGRAM A28_1 + COMMON /BLOCK/ X + X = 1.0 +!$OMP PARALLEL PRIVATE (X) + X = 2.0 + CALL SUB() +!$OMP END PARALLEL + END PROGRAM A28_1 diff --git a/libgomp/testsuite/libgomp.fortran/appendix-a/a.28.2.f90 b/libgomp/testsuite/libgomp.fortran/appendix-a/a.28.2.f90 new file mode 100644 index 00000000000..1145e541026 --- /dev/null +++ b/libgomp/testsuite/libgomp.fortran/appendix-a/a.28.2.f90 @@ -0,0 +1,16 @@ +! { dg-do run } + + PROGRAM A28_2 + COMMON /BLOCK2/ X + X = 1.0 +!$OMP PARALLEL PRIVATE (X) + X = 2.0 + CALL SUB() +!$OMP END PARALLEL + CONTAINS + SUBROUTINE SUB() + COMMON /BLOCK2/ Y + PRINT *,X ! X is undefined + PRINT *,Y ! Y is undefined + END SUBROUTINE SUB + END PROGRAM A28_2 diff --git a/libgomp/testsuite/libgomp.fortran/appendix-a/a.28.3.f90 b/libgomp/testsuite/libgomp.fortran/appendix-a/a.28.3.f90 new file mode 100644 index 00000000000..a337f3bc7d5 --- /dev/null +++ b/libgomp/testsuite/libgomp.fortran/appendix-a/a.28.3.f90 @@ -0,0 +1,11 @@ +! { dg-do run } + + PROGRAM A28_3 + EQUIVALENCE (X,Y) + X = 1.0 +!$OMP PARALLEL PRIVATE(X) + PRINT *,Y ! Y is undefined + Y = 10 + PRINT *,X ! X is undefined +!$OMP END PARALLEL + END PROGRAM A28_3 diff --git a/libgomp/testsuite/libgomp.fortran/appendix-a/a.28.4.f90 b/libgomp/testsuite/libgomp.fortran/appendix-a/a.28.4.f90 new file mode 100644 index 00000000000..c5a5cd74cf5 --- /dev/null +++ b/libgomp/testsuite/libgomp.fortran/appendix-a/a.28.4.f90 @@ -0,0 +1,24 @@ +! { dg-do run } + + PROGRAM A28_4 + INTEGER I, J + INTEGER A(100), B(100) + EQUIVALENCE (A(51), B(1)) +!$OMP PARALLEL DO DEFAULT(PRIVATE) PRIVATE(I,J) LASTPRIVATE(A) + DO I=1,100 + DO J=1,100 + B(J) = J - 1 + ENDDO + DO J=1,100 + A(J) = J ! B becomes undefined at this point + ENDDO + DO J=1,50 + B(J) = B(J) + 1 ! B is undefined + ! A becomes undefined at this point + ENDDO + ENDDO +!$OMP END PARALLEL DO ! The LASTPRIVATE write for A has + ! undefined results + PRINT *, B ! B is undefined since the LASTPRIVATE + ! write of A was not defined + END PROGRAM A28_4 diff --git a/libgomp/testsuite/libgomp.fortran/appendix-a/a.28.5.f90 b/libgomp/testsuite/libgomp.fortran/appendix-a/a.28.5.f90 new file mode 100644 index 00000000000..e3775822f10 --- /dev/null +++ b/libgomp/testsuite/libgomp.fortran/appendix-a/a.28.5.f90 @@ -0,0 +1,29 @@ +! { dg-do compile } + + SUBROUTINE SUB1(X) + DIMENSION X(10) + ! This use of X does not conform to the + ! specification. It would be legal Fortran 90, + ! but the OpenMP private directive allows the + ! compiler to break the sequence association that + ! A had with the rest of the common block. + FORALL (I = 1:10) X(I) = I + END SUBROUTINE SUB1 + PROGRAM A28_5 + COMMON /BLOCK5/ A + DIMENSION B(10) + EQUIVALENCE (A,B(1)) + ! the common block has to be at least 10 words + A=0 +!$OMP PARALLEL PRIVATE(/BLOCK5/) + ! Without the private clause, + ! we would be passing a member of a sequence + ! that is at least ten elements long. + ! With the private clause, A may no longer be + ! sequence-associated. + CALL SUB1(A) +!$OMP MASTER + PRINT *, A +!$OMP END MASTER +!$OMP END PARALLEL + END PROGRAM A28_5 diff --git a/libgomp/testsuite/libgomp.fortran/appendix-a/a.3.1.f90 b/libgomp/testsuite/libgomp.fortran/appendix-a/a.3.1.f90 new file mode 100644 index 00000000000..0a175727279 --- /dev/null +++ b/libgomp/testsuite/libgomp.fortran/appendix-a/a.3.1.f90 @@ -0,0 +1,6 @@ +! { dg-do run } +! { dg-options "-ffixed-form" } + PROGRAM A3 +!234567890 +!$ PRINT *, "Compiled by an OpenMP-compliant implementation." + END PROGRAM A3 diff --git a/libgomp/testsuite/libgomp.fortran/appendix-a/a.31.4.f90 b/libgomp/testsuite/libgomp.fortran/appendix-a/a.31.4.f90 new file mode 100644 index 00000000000..69882c1e6b9 --- /dev/null +++ b/libgomp/testsuite/libgomp.fortran/appendix-a/a.31.4.f90 @@ -0,0 +1,12 @@ +! { dg-do run } + MODULE M + INTRINSIC MAX + END MODULE M + PROGRAM A31_4 + USE M, REN => MAX + N=0 +!$OMP PARALLEL DO REDUCTION(REN: N) ! still does MAX + DO I = 1, 100 + N = MAX(N,I) + END DO + END PROGRAM A31_4 diff --git a/libgomp/testsuite/libgomp.fortran/appendix-a/a.31.5.f90 b/libgomp/testsuite/libgomp.fortran/appendix-a/a.31.5.f90 new file mode 100644 index 00000000000..91a97cd829d --- /dev/null +++ b/libgomp/testsuite/libgomp.fortran/appendix-a/a.31.5.f90 @@ -0,0 +1,14 @@ +! { dg-do run } + MODULE MOD + INTRINSIC MAX, MIN + END MODULE MOD + PROGRAM A31_5 + USE MOD, MIN=>MAX, MAX=>MIN + REAL :: R + R = -HUGE(0.0) + !$OMP PARALLEL DO REDUCTION(MIN: R) ! still does MAX + DO I = 1, 1000 + R = MIN(R, SIN(REAL(I))) + END DO + PRINT *, R + END PROGRAM A31_5 diff --git a/libgomp/testsuite/libgomp.fortran/appendix-a/a.33.3.f90 b/libgomp/testsuite/libgomp.fortran/appendix-a/a.33.3.f90 new file mode 100644 index 00000000000..adc493fcf0a --- /dev/null +++ b/libgomp/testsuite/libgomp.fortran/appendix-a/a.33.3.f90 @@ -0,0 +1,10 @@ +! { dg-do compile } + + FUNCTION NEW_LOCK() + USE OMP_LIB ! or INCLUDE "omp_lib.h" + INTEGER(OMP_LOCK_KIND), POINTER :: NEW_LOCK +!$OMP SINGLE + ALLOCATE(NEW_LOCK) + CALL OMP_INIT_LOCK(NEW_LOCK) +!$OMP END SINGLE COPYPRIVATE(NEW_LOCK) + END FUNCTION NEW_LOCK diff --git a/libgomp/testsuite/libgomp.fortran/appendix-a/a.38.1.f90 b/libgomp/testsuite/libgomp.fortran/appendix-a/a.38.1.f90 new file mode 100644 index 00000000000..55541303cea --- /dev/null +++ b/libgomp/testsuite/libgomp.fortran/appendix-a/a.38.1.f90 @@ -0,0 +1,12 @@ +! { dg-do compile } + + FUNCTION NEW_LOCKS() + USE OMP_LIB ! or INCLUDE "omp_lib.h" + INTEGER(OMP_LOCK_KIND), DIMENSION(1000) :: NEW_LOCKS + INTEGER I +!$OMP PARALLEL DO PRIVATE(I) + DO I=1,1000 + CALL OMP_INIT_LOCK(NEW_LOCKS(I)) + END DO +!$OMP END PARALLEL DO + END FUNCTION NEW_LOCKS diff --git a/libgomp/testsuite/libgomp.fortran/appendix-a/a.39.1.f90 b/libgomp/testsuite/libgomp.fortran/appendix-a/a.39.1.f90 new file mode 100644 index 00000000000..540d17f5b02 --- /dev/null +++ b/libgomp/testsuite/libgomp.fortran/appendix-a/a.39.1.f90 @@ -0,0 +1,26 @@ +! { dg-do run } + + SUBROUTINE SKIP(ID) + END SUBROUTINE SKIP + SUBROUTINE WORK(ID) + END SUBROUTINE WORK + PROGRAM A39 + INCLUDE "omp_lib.h" ! or USE OMP_LIB + INTEGER(OMP_LOCK_KIND) LCK + INTEGER ID + CALL OMP_INIT_LOCK(LCK) +!$OMP PARALLEL SHARED(LCK) PRIVATE(ID) + ID = OMP_GET_THREAD_NUM() + CALL OMP_SET_LOCK(LCK) + PRINT *, "My thread id is ", ID + CALL OMP_UNSET_LOCK(LCK) + DO WHILE (.NOT. OMP_TEST_LOCK(LCK)) + CALL SKIP(ID) ! We do not yet have the lock + ! so we must do something else + END DO + CALL WORK(ID) ! We now have the lock + ! and can do the work + CALL OMP_UNSET_LOCK( LCK ) +!$OMP END PARALLEL + CALL OMP_DESTROY_LOCK( LCK ) + END PROGRAM A39 diff --git a/libgomp/testsuite/libgomp.fortran/appendix-a/a.4.1.f90 b/libgomp/testsuite/libgomp.fortran/appendix-a/a.4.1.f90 new file mode 100644 index 00000000000..3c2a74a4fdd --- /dev/null +++ b/libgomp/testsuite/libgomp.fortran/appendix-a/a.4.1.f90 @@ -0,0 +1,29 @@ +! { dg-do run } + SUBROUTINE SUBDOMAIN(X, ISTART, IPOINTS) + INTEGER ISTART, IPOINTS + REAL X(*) + INTEGER I + DO 100 I=1,IPOINTS + X(ISTART+I) = 123.456 + 100 CONTINUE + END SUBROUTINE SUBDOMAIN + SUBROUTINE SUB(X, NPOINTS) + INCLUDE "omp_lib.h" ! or USE OMP_LIB + REAL X(*) + INTEGER NPOINTS + INTEGER IAM, NT, IPOINTS, ISTART +!$OMP PARALLEL DEFAULT(PRIVATE) SHARED(X,NPOINTS) + IAM = OMP_GET_THREAD_NUM() + NT = OMP_GET_NUM_THREADS() + IPOINTS = NPOINTS/NT + ISTART = IAM * IPOINTS + IF (IAM .EQ. NT-1) THEN + IPOINTS = NPOINTS - ISTART + ENDIF + CALL SUBDOMAIN(X,ISTART,IPOINTS) +!$OMP END PARALLEL + END SUBROUTINE SUB + PROGRAM A4 + REAL ARRAY(10000) + CALL SUB(ARRAY, 10000) + END PROGRAM A4 diff --git a/libgomp/testsuite/libgomp.fortran/appendix-a/a.40.1.f90 b/libgomp/testsuite/libgomp.fortran/appendix-a/a.40.1.f90 new file mode 100644 index 00000000000..38fbca3fced --- /dev/null +++ b/libgomp/testsuite/libgomp.fortran/appendix-a/a.40.1.f90 @@ -0,0 +1,52 @@ +! { dg-do compile } +! { dg-options "-ffixed-form" } + MODULE DATA + USE OMP_LIB, ONLY: OMP_NEST_LOCK_KIND + TYPE LOCKED_PAIR + INTEGER A + INTEGER B + INTEGER (OMP_NEST_LOCK_KIND) LCK + END TYPE + END MODULE DATA + SUBROUTINE INCR_A(P, A) + ! called only from INCR_PAIR, no need to lock + USE DATA + TYPE(LOCKED_PAIR) :: P + INTEGER A + P%A = P%A + A + END SUBROUTINE INCR_A + SUBROUTINE INCR_B(P, B) + ! called from both INCR_PAIR and elsewhere, + ! so we need a nestable lock + USE OMP_LIB ! or INCLUDE "omp_lib.h" + USE DATA + TYPE(LOCKED_PAIR) :: P + INTEGER B + CALL OMP_SET_NEST_LOCK(P%LCK) + P%B = P%B + B + CALL OMP_UNSET_NEST_LOCK(P%LCK) + END SUBROUTINE INCR_B + SUBROUTINE INCR_PAIR(P, A, B) + USE OMP_LIB ! or INCLUDE "omp_lib.h" + USE DATA + TYPE(LOCKED_PAIR) :: P + INTEGER A + INTEGER B + CALL OMP_SET_NEST_LOCK(P%LCK) + CALL INCR_A(P, A) + CALL INCR_B(P, B) + CALL OMP_UNSET_NEST_LOCK(P%LCK) + END SUBROUTINE INCR_PAIR + SUBROUTINE A40(P) + USE OMP_LIB ! or INCLUDE "omp_lib.h" + USE DATA + TYPE(LOCKED_PAIR) :: P + INTEGER WORK1, WORK2, WORK3 + EXTERNAL WORK1, WORK2, WORK3 +!$OMP PARALLEL SECTIONS +!$OMP SECTION + CALL INCR_PAIR(P, WORK1(), WORK2()) +!$OMP SECTION + CALL INCR_B(P, WORK3()) +!$OMP END PARALLEL SECTIONS + END SUBROUTINE A40 diff --git a/libgomp/testsuite/libgomp.fortran/appendix-a/a.5.1.f90 b/libgomp/testsuite/libgomp.fortran/appendix-a/a.5.1.f90 new file mode 100644 index 00000000000..13e451e506a --- /dev/null +++ b/libgomp/testsuite/libgomp.fortran/appendix-a/a.5.1.f90 @@ -0,0 +1,8 @@ +! { dg-do run } + PROGRAM A5 + INCLUDE "omp_lib.h" ! or USE OMP_LIB + CALL OMP_SET_DYNAMIC(.TRUE.) +!$OMP PARALLEL NUM_THREADS(10) + ! do work here +!$OMP END PARALLEL + END PROGRAM A5 diff --git a/libgomp/testsuite/libgomp.fortran/appendix-a/a10.1.f90 b/libgomp/testsuite/libgomp.fortran/appendix-a/a10.1.f90 new file mode 100644 index 00000000000..c1564bf4b3f --- /dev/null +++ b/libgomp/testsuite/libgomp.fortran/appendix-a/a10.1.f90 @@ -0,0 +1,20 @@ +! { dg-do run } + SUBROUTINE WORK1() + END SUBROUTINE WORK1 + SUBROUTINE WORK2() + END SUBROUTINE WORK2 + PROGRAM A10 +!$OMP PARALLEL +!$OMP SINGLE + print *, "Beginning work1." +!$OMP END SINGLE + CALL WORK1() +!$OMP SINGLE + print *, "Finishing work1." +!$OMP END SINGLE +!$OMP SINGLE + print *, "Finished work1 and beginning work2." +!$OMP END SINGLE NOWAIT + CALL WORK2() +!$OMP END PARALLEL + END PROGRAM A10 diff --git a/libgomp/testsuite/libgomp.fortran/character1.f90 b/libgomp/testsuite/libgomp.fortran/character1.f90 new file mode 100644 index 00000000000..f75ae27e8f9 --- /dev/null +++ b/libgomp/testsuite/libgomp.fortran/character1.f90 @@ -0,0 +1,72 @@ +! { dg-do run } +!$ use omp_lib + + character (len = 8) :: h, i + character (len = 4) :: j, k + h = '01234567' + i = 'ABCDEFGH' + j = 'IJKL' + k = 'MN' + call test (h, j) +contains + subroutine test (p, q) + character (len = 8) :: p + character (len = 4) :: q, r + character (len = 16) :: f + character (len = 32) :: g + integer, dimension (18) :: s + logical :: l + integer :: m + f = 'test16' + g = 'abcdefghijklmnopqrstuvwxyz' + r = '' + l = .false. + s = -6 +!$omp parallel firstprivate (f, p, s) private (r, m) reduction (.or.:l) & +!$omp & num_threads (4) + m = omp_get_thread_num () + if (any (s .ne. -6)) l = .true. + l = l .or. f .ne. 'test16' .or. p .ne. '01234567' + l = l .or. g .ne. 'abcdefghijklmnopqrstuvwxyz' + l = l .or. i .ne. 'ABCDEFGH' .or. q .ne. 'IJKL' + l = l .or. k .ne. 'MN' +!$omp barrier + if (m .eq. 0) then + f = 'ffffffff0' + g = 'xyz' + i = '123' + k = '9876' + p = '_abc' + q = '_def' + r = '1_23' + else if (m .eq. 1) then + f = '__' + p = 'xxx' + r = '7575' + else if (m .eq. 2) then + f = 'ZZ' + p = 'm2' + r = 'M2' + else if (m .eq. 3) then + f = 'YY' + p = 'm3' + r = 'M3' + end if + s = m +!$omp barrier + l = l .or. g .ne. 'xyz' .or. i .ne. '123' .or. k .ne. '9876' + l = l .or. q .ne. '_def' + if (any (s .ne. m)) l = .true. + if (m .eq. 0) then + l = l .or. f .ne. 'ffffffff0' .or. p .ne. '_abc' .or. r .ne. '1_23' + else if (m .eq. 1) then + l = l .or. f .ne. '__' .or. p .ne. 'xxx' .or. r .ne. '7575' + else if (m .eq. 2) then + l = l .or. f .ne. 'ZZ' .or. p .ne. 'm2' .or. r .ne. 'M2' + else if (m .eq. 3) then + l = l .or. f .ne. 'YY' .or. p .ne. 'm3' .or. r .ne. 'M3' + end if +!$omp end parallel + if (l) call abort + end subroutine test +end diff --git a/libgomp/testsuite/libgomp.fortran/character2.f90 b/libgomp/testsuite/libgomp.fortran/character2.f90 new file mode 100644 index 00000000000..d59032b57a0 --- /dev/null +++ b/libgomp/testsuite/libgomp.fortran/character2.f90 @@ -0,0 +1,61 @@ +! { dg-do run } +!$ use omp_lib + + character (len = 8) :: h + character (len = 9) :: i + h = '01234567' + i = 'ABCDEFGHI' + call test (h, i, 9) +contains + subroutine test (p, q, n) + character (len = *) :: p + character (len = n) :: q + character (len = n) :: r + character (len = n) :: t + character (len = n) :: u + integer, dimension (n + 4) :: s + logical :: l + integer :: m + r = '' + if (n .gt. 8) r = 'jklmnopqr' + do m = 1, n + 4 + s(m) = m + end do + u = 'abc' + l = .false. +!$omp parallel firstprivate (p, q, r) private (t, m) reduction (.or.:l) & +!$omp & num_threads (2) + do m = 1, 13 + if (s(m) .ne. m) l = .true. + end do + m = omp_get_thread_num () + l = l .or. p .ne. '01234567' .or. q .ne. 'ABCDEFGHI' + l = l .or. r .ne. 'jklmnopqr' .or. u .ne. 'abc' +!$omp barrier + if (m .eq. 0) then + p = 'A' + q = 'B' + r = 'C' + t = '123' + u = '987654321' + else if (m .eq. 1) then + p = 'D' + q = 'E' + r = 'F' + t = '456' + s = m + end if +!$omp barrier + l = l .or. u .ne. '987654321' + if (any (s .ne. 1)) l = .true. + if (m .eq. 0) then + l = l .or. p .ne. 'A' .or. q .ne. 'B' .or. r .ne. 'C' + l = l .or. t .ne. '123' + else + l = l .or. p .ne. 'D' .or. q .ne. 'E' .or. r .ne. 'F' + l = l .or. t .ne. '456' + end if +!$omp end parallel + if (l) call abort + end subroutine test +end diff --git a/libgomp/testsuite/libgomp.fortran/crayptr1.f90 b/libgomp/testsuite/libgomp.fortran/crayptr1.f90 new file mode 100644 index 00000000000..57c59f71f9f --- /dev/null +++ b/libgomp/testsuite/libgomp.fortran/crayptr1.f90 @@ -0,0 +1,46 @@ +! { dg-do run } +! { dg-options "-fopenmp -fcray-pointer" } + + use omp_lib + integer :: a, b, c, p + logical :: l + pointer (ip, p) + a = 1 + b = 2 + c = 3 + l = .false. + ip = loc (a) + +!$omp parallel num_threads (2) reduction (.or.:l) + l = p .ne. 1 +!$omp barrier +!$omp master + ip = loc (b) +!$omp end master +!$omp barrier + l = l .or. p .ne. 2 +!$omp barrier + if (omp_get_thread_num () .eq. 1 .or. omp_get_num_threads () .lt. 2) & + ip = loc (c) +!$omp barrier + l = l .or. p .ne. 3 +!$omp end parallel + + if (l) call abort + + l = .false. +!$omp parallel num_threads (2) reduction (.or.:l) default (private) + ip = loc (a) + a = 3 * omp_get_thread_num () + 4 + b = a + 1 + c = a + 2 + l = p .ne. 3 * omp_get_thread_num () + 4 + ip = loc (c) + l = l .or. p .ne. 3 * omp_get_thread_num () + 6 + ip = loc (b) + l = l .or. p .ne. 3 * omp_get_thread_num () + 5 +!$omp end parallel + + if (l) call abort + +end diff --git a/libgomp/testsuite/libgomp.fortran/do1.f90 b/libgomp/testsuite/libgomp.fortran/do1.f90 new file mode 100644 index 00000000000..2a48c7345fc --- /dev/null +++ b/libgomp/testsuite/libgomp.fortran/do1.f90 @@ -0,0 +1,179 @@ +! { dg-do run } + + integer, dimension (128) :: a, b + integer :: i + a = -1 + b = -1 + do i = 1, 128 + if (i .ge. 8 .and. i .le. 15) then + b(i) = 1 * 256 + i + else if (i .ge. 19 .and. i .le. 23) then + b(i) = 2 * 256 + i + else if (i .ge. 28 .and. i .le. 38) then + if (iand (i, 1) .eq. 0) b(i) = 3 * 256 + i + else if (i .ge. 59 .and. i .le. 79) then + if (iand (i - 59, 3) .eq. 0) b(i) = 4 * 256 + i + else if (i .ge. 101 .and. i .le. 125) then + if (mod (i - 101, 12) .eq. 0) b(i) = 5 * 256 + i + end if + end do + +!$omp parallel num_threads (4) + +!$omp do + do i = 8, 15 + a(i) = 1 * 256 + i + end do + +!$omp do + do i = 23, 19, -1 + a(i) = 2 * 256 + i + end do + +!$omp do + do i = 28, 39, 2 + a(i) = 3 * 256 + i + end do + +!$omp do + do i = 79, 59, -4 + a(i) = 4 * 256 + i + end do + +!$omp do + do i = 125, 90, -12 + a(i) = 5 * 256 + i + end do + +!$omp end parallel + + if (any (a .ne. b)) call abort + a = -1 + +!$omp parallel num_threads (4) + +!$omp do schedule (static) + do i = 8, 15 + a(i) = 1 * 256 + i + end do + +!$omp do schedule (static, 1) + do i = 23, 19, -1 + a(i) = 2 * 256 + i + end do + +!$omp do schedule (static, 3) + do i = 28, 39, 2 + a(i) = 3 * 256 + i + end do + +!$omp do schedule (static, 6) + do i = 79, 59, -4 + a(i) = 4 * 256 + i + end do + +!$omp do schedule (static, 2) + do i = 125, 90, -12 + a(i) = 5 * 256 + i + end do + +!$omp end parallel + + if (any (a .ne. b)) call abort + a = -1 + +!$omp parallel num_threads (4) + +!$omp do schedule (dynamic) + do i = 8, 15 + a(i) = 1 * 256 + i + end do + +!$omp do schedule (dynamic, 4) + do i = 23, 19, -1 + a(i) = 2 * 256 + i + end do + +!$omp do schedule (dynamic, 1) + do i = 28, 39, 2 + a(i) = 3 * 256 + i + end do + +!$omp do schedule (dynamic, 2) + do i = 79, 59, -4 + a(i) = 4 * 256 + i + end do + +!$omp do schedule (dynamic, 3) + do i = 125, 90, -12 + a(i) = 5 * 256 + i + end do + +!$omp end parallel + + if (any (a .ne. b)) call abort + a = -1 + +!$omp parallel num_threads (4) + +!$omp do schedule (guided) + do i = 8, 15 + a(i) = 1 * 256 + i + end do + +!$omp do schedule (guided, 4) + do i = 23, 19, -1 + a(i) = 2 * 256 + i + end do + +!$omp do schedule (guided, 1) + do i = 28, 39, 2 + a(i) = 3 * 256 + i + end do + +!$omp do schedule (guided, 2) + do i = 79, 59, -4 + a(i) = 4 * 256 + i + end do + +!$omp do schedule (guided, 3) + do i = 125, 90, -12 + a(i) = 5 * 256 + i + end do + +!$omp end parallel + + if (any (a .ne. b)) call abort + a = -1 + +!$omp parallel num_threads (4) + +!$omp do schedule (runtime) + do i = 8, 15 + a(i) = 1 * 256 + i + end do + +!$omp do schedule (runtime) + do i = 23, 19, -1 + a(i) = 2 * 256 + i + end do + +!$omp do schedule (runtime) + do i = 28, 39, 2 + a(i) = 3 * 256 + i + end do + +!$omp do schedule (runtime) + do i = 79, 59, -4 + a(i) = 4 * 256 + i + end do + +!$omp do schedule (runtime) + do i = 125, 90, -12 + a(i) = 5 * 256 + i + end do + +!$omp end parallel + + if (any (a .ne. b)) call abort +end diff --git a/libgomp/testsuite/libgomp.fortran/do2.f90 b/libgomp/testsuite/libgomp.fortran/do2.f90 new file mode 100644 index 00000000000..b90ccddd80b --- /dev/null +++ b/libgomp/testsuite/libgomp.fortran/do2.f90 @@ -0,0 +1,366 @@ +! { dg-do run } + + integer, dimension (128) :: a, b + integer :: i, j + logical :: k + a = -1 + b = -1 + do i = 1, 128 + if (i .ge. 8 .and. i .le. 15) then + b(i) = 1 * 256 + i + else if (i .ge. 19 .and. i .le. 23) then + b(i) = 2 * 256 + i + else if (i .ge. 28 .and. i .le. 38) then + if (iand (i, 1) .eq. 0) b(i) = 3 * 256 + i + else if (i .ge. 59 .and. i .le. 79) then + if (iand (i - 59, 3) .eq. 0) b(i) = 4 * 256 + i + else if (i .ge. 101 .and. i .le. 125) then + if (mod (i - 101, 12) .eq. 0) b(i) = 5 * 256 + i + end if + end do + + k = .false. + j = 8 +!$omp parallel num_threads (4) + +!$omp do ordered + do i = 8, 15 + a(i) = 1 * 256 + i +!$omp ordered + if (i .ne. j) k = .true. + j = j + 1 +!$omp end ordered + end do + +!$omp single + j = 23 +!$omp end single + +!$omp do ordered + do i = 23, 19, -1 + a(i) = 2 * 256 + i +!$omp ordered + if (i .ne. j) k = .true. + j = j - 1 +!$omp end ordered + end do + +!$omp single + j = 28 +!$omp end single + +!$omp do ordered + do i = 28, 39, 2 + a(i) = 3 * 256 + i +!$omp ordered + if (i .ne. j) k = .true. + j = j + 2 +!$omp end ordered + end do + +!$omp single + j = 79 +!$omp end single + +!$omp do ordered + do i = 79, 59, -4 + a(i) = 4 * 256 + i +!$omp ordered + if (i .ne. j) k = .true. + j = j - 4 +!$omp end ordered + end do + +!$omp single + j = 125 +!$omp end single + +!$omp do ordered + do i = 125, 90, -12 + a(i) = 5 * 256 + i +!$omp ordered + if (i .ne. j) k = .true. + j = j - 12 +!$omp end ordered + end do + +!$omp end parallel + + if (any (a .ne. b) .or. k) call abort + a = -1 + k = .false. + j = 8 +!$omp parallel num_threads (4) + +!$omp do ordered schedule (static) + do i = 8, 15 + a(i) = 1 * 256 + i +!$omp ordered + if (i .ne. j) k = .true. + j = j + 1 +!$omp end ordered + end do + +!$omp single + j = 23 +!$omp end single + +!$omp do ordered schedule (static, 1) + do i = 23, 19, -1 + a(i) = 2 * 256 + i +!$omp ordered + if (i .ne. j) k = .true. + j = j - 1 +!$omp end ordered + end do + +!$omp single + j = 28 +!$omp end single + +!$omp do ordered schedule (static, 3) + do i = 28, 39, 2 + a(i) = 3 * 256 + i +!$omp ordered + if (i .ne. j) k = .true. + j = j + 2 +!$omp end ordered + end do + +!$omp single + j = 79 +!$omp end single + +!$omp do ordered schedule (static, 6) + do i = 79, 59, -4 + a(i) = 4 * 256 + i +!$omp ordered + if (i .ne. j) k = .true. + j = j - 4 +!$omp end ordered + end do + +!$omp single + j = 125 +!$omp end single + +!$omp do ordered schedule (static, 2) + do i = 125, 90, -12 + a(i) = 5 * 256 + i +!$omp ordered + if (i .ne. j) k = .true. + j = j - 12 +!$omp end ordered + end do + +!$omp end parallel + + if (any (a .ne. b) .or. k) call abort + a = -1 + k = .false. + j = 8 +!$omp parallel num_threads (4) + +!$omp do ordered schedule (dynamic) + do i = 8, 15 + a(i) = 1 * 256 + i +!$omp ordered + if (i .ne. j) k = .true. + j = j + 1 +!$omp end ordered + end do + +!$omp single + j = 23 +!$omp end single + +!$omp do ordered schedule (dynamic, 4) + do i = 23, 19, -1 + a(i) = 2 * 256 + i +!$omp ordered + if (i .ne. j) k = .true. + j = j - 1 +!$omp end ordered + end do + +!$omp single + j = 28 +!$omp end single + +!$omp do ordered schedule (dynamic, 1) + do i = 28, 39, 2 + a(i) = 3 * 256 + i +!$omp ordered + if (i .ne. j) k = .true. + j = j + 2 +!$omp end ordered + end do + +!$omp single + j = 79 +!$omp end single + +!$omp do ordered schedule (dynamic, 2) + do i = 79, 59, -4 + a(i) = 4 * 256 + i +!$omp ordered + if (i .ne. j) k = .true. + j = j - 4 +!$omp end ordered + end do + +!$omp single + j = 125 +!$omp end single + +!$omp do ordered schedule (dynamic, 3) + do i = 125, 90, -12 + a(i) = 5 * 256 + i +!$omp ordered + if (i .ne. j) k = .true. + j = j - 12 +!$omp end ordered + end do + +!$omp end parallel + + if (any (a .ne. b) .or. k) call abort + a = -1 + k = .false. + j = 8 +!$omp parallel num_threads (4) + +!$omp do ordered schedule (guided) + do i = 8, 15 + a(i) = 1 * 256 + i +!$omp ordered + if (i .ne. j) k = .true. + j = j + 1 +!$omp end ordered + end do + +!$omp single + j = 23 +!$omp end single + +!$omp do ordered schedule (guided, 4) + do i = 23, 19, -1 + a(i) = 2 * 256 + i +!$omp ordered + if (i .ne. j) k = .true. + j = j - 1 +!$omp end ordered + end do + +!$omp single + j = 28 +!$omp end single + +!$omp do ordered schedule (guided, 1) + do i = 28, 39, 2 + a(i) = 3 * 256 + i +!$omp ordered + if (i .ne. j) k = .true. + j = j + 2 +!$omp end ordered + end do + +!$omp single + j = 79 +!$omp end single + +!$omp do ordered schedule (guided, 2) + do i = 79, 59, -4 + a(i) = 4 * 256 + i +!$omp ordered + if (i .ne. j) k = .true. + j = j - 4 +!$omp end ordered + end do + +!$omp single + j = 125 +!$omp end single + +!$omp do ordered schedule (guided, 3) + do i = 125, 90, -12 + a(i) = 5 * 256 + i +!$omp ordered + if (i .ne. j) k = .true. + j = j - 12 +!$omp end ordered + end do + +!$omp end parallel + + if (any (a .ne. b) .or. k) call abort + a = -1 + k = .false. + j = 8 +!$omp parallel num_threads (4) + +!$omp do ordered schedule (runtime) + do i = 8, 15 + a(i) = 1 * 256 + i +!$omp ordered + if (i .ne. j) k = .true. + j = j + 1 +!$omp end ordered + end do + +!$omp single + j = 23 +!$omp end single + +!$omp do ordered schedule (runtime) + do i = 23, 19, -1 + a(i) = 2 * 256 + i +!$omp ordered + if (i .ne. j) k = .true. + j = j - 1 +!$omp end ordered + end do + +!$omp single + j = 28 +!$omp end single + +!$omp do ordered schedule (runtime) + do i = 28, 39, 2 + a(i) = 3 * 256 + i +!$omp ordered + if (i .ne. j) k = .true. + j = j + 2 +!$omp end ordered + end do + +!$omp single + j = 79 +!$omp end single + +!$omp do ordered schedule (runtime) + do i = 79, 59, -4 + a(i) = 4 * 256 + i +!$omp ordered + if (i .ne. j) k = .true. + j = j - 4 +!$omp end ordered + end do + +!$omp single + j = 125 +!$omp end single + +!$omp do ordered schedule (runtime) + do i = 125, 90, -12 + a(i) = 5 * 256 + i +!$omp ordered + if (i .ne. j) k = .true. + j = j - 12 +!$omp end ordered + end do + +!$omp end parallel + + if (any (a .ne. b) .or. k) call abort +end diff --git a/libgomp/testsuite/libgomp.fortran/fortran.exp b/libgomp/testsuite/libgomp.fortran/fortran.exp new file mode 100644 index 00000000000..e7ee746c282 --- /dev/null +++ b/libgomp/testsuite/libgomp.fortran/fortran.exp @@ -0,0 +1,20 @@ +set lang_library_path "../libgfortran/.libs" +set lang_test_file "${lang_library_path}/libgfortranbegin.a" +set lang_link_flags "-lgfortranbegin -lgfortran" + +load_lib libgomp-dg.exp + +# Initialize dg. +dg-init + +if [file exists "${blddir}/${lang_test_file}"] { + + # Gather a list of all tests. + set tests [lsort [find $srcdir/$subdir *.\[fF\]{,90,95}]] + + # Main loop. + gfortran-dg-runtest $tests "" +} + +# All done. +dg-finish diff --git a/libgomp/testsuite/libgomp.fortran/jacobi.f b/libgomp/testsuite/libgomp.fortran/jacobi.f new file mode 100644 index 00000000000..b27e20f2766 --- /dev/null +++ b/libgomp/testsuite/libgomp.fortran/jacobi.f @@ -0,0 +1,261 @@ +* { dg-do run } + + program main +************************************************************ +* program to solve a finite difference +* discretization of Helmholtz equation : +* (d2/dx2)u + (d2/dy2)u - alpha u = f +* using Jacobi iterative method. +* +* Modified: Sanjiv Shah, Kuck and Associates, Inc. (KAI), 1998 +* Author: Joseph Robicheaux, Kuck and Associates, Inc. (KAI), 1998 +* +* Directives are used in this code to achieve paralleism. +* All do loops are parallized with default 'static' scheduling. +* +* Input : n - grid dimension in x direction +* m - grid dimension in y direction +* alpha - Helmholtz constant (always greater than 0.0) +* tol - error tolerance for iterative solver +* relax - Successice over relaxation parameter +* mits - Maximum iterations for iterative solver +* +* On output +* : u(n,m) - Dependent variable (solutions) +* : f(n,m) - Right hand side function +************************************************************* + implicit none + + integer n,m,mits,mtemp + include "omp_lib.h" + double precision tol,relax,alpha + + common /idat/ n,m,mits,mtemp + common /fdat/tol,alpha,relax +* +* Read info +* + write(*,*) "Input n,m - grid dimension in x,y direction " + n = 64 + m = 64 +* read(5,*) n,m + write(*,*) n, m + write(*,*) "Input alpha - Helmholts constant " + alpha = 0.5 +* read(5,*) alpha + write(*,*) alpha + write(*,*) "Input relax - Successive over-relaxation parameter" + relax = 0.9 +* read(5,*) relax + write(*,*) relax + write(*,*) "Input tol - error tolerance for iterative solver" + tol = 1.0E-12 +* read(5,*) tol + write(*,*) tol + write(*,*) "Input mits - Maximum iterations for solver" + mits = 100 +* read(5,*) mits + write(*,*) mits + + call omp_set_num_threads (2) + +* +* Calls a driver routine +* + call driver () + + stop + end + + subroutine driver ( ) +************************************************************* +* Subroutine driver () +* This is where the arrays are allocated and initialzed. +* +* Working varaibles/arrays +* dx - grid spacing in x direction +* dy - grid spacing in y direction +************************************************************* + implicit none + + integer n,m,mits,mtemp + double precision tol,relax,alpha + + common /idat/ n,m,mits,mtemp + common /fdat/tol,alpha,relax + + double precision u(n,m),f(n,m),dx,dy + +* Initialize data + + call initialize (n,m,alpha,dx,dy,u,f) + +* Solve Helmholtz equation + + call jacobi (n,m,dx,dy,alpha,relax,u,f,tol,mits) + +* Check error between exact solution + + call error_check (n,m,alpha,dx,dy,u,f) + + return + end + + subroutine initialize (n,m,alpha,dx,dy,u,f) +****************************************************** +* Initializes data +* Assumes exact solution is u(x,y) = (1-x^2)*(1-y^2) +* +****************************************************** + implicit none + + integer n,m + double precision u(n,m),f(n,m),dx,dy,alpha + + integer i,j, xx,yy + double precision PI + parameter (PI=3.1415926) + + dx = 2.0 / (n-1) + dy = 2.0 / (m-1) + +* Initilize initial condition and RHS + +!$omp parallel do private(xx,yy) + do j = 1,m + do i = 1,n + xx = -1.0 + dx * dble(i-1) ! -1 < x < 1 + yy = -1.0 + dy * dble(j-1) ! -1 < y < 1 + u(i,j) = 0.0 + f(i,j) = -alpha *(1.0-xx*xx)*(1.0-yy*yy) + & - 2.0*(1.0-xx*xx)-2.0*(1.0-yy*yy) + enddo + enddo +!$omp end parallel do + + return + end + + subroutine jacobi (n,m,dx,dy,alpha,omega,u,f,tol,maxit) +****************************************************************** +* Subroutine HelmholtzJ +* Solves poisson equation on rectangular grid assuming : +* (1) Uniform discretization in each direction, and +* (2) Dirichlect boundary conditions +* +* Jacobi method is used in this routine +* +* Input : n,m Number of grid points in the X/Y directions +* dx,dy Grid spacing in the X/Y directions +* alpha Helmholtz eqn. coefficient +* omega Relaxation factor +* f(n,m) Right hand side function +* u(n,m) Dependent variable/Solution +* tol Tolerance for iterative solver +* maxit Maximum number of iterations +* +* Output : u(n,m) - Solution +***************************************************************** + implicit none + integer n,m,maxit + double precision dx,dy,f(n,m),u(n,m),alpha, tol,omega +* +* Local variables +* + integer i,j,k,k_local + double precision error,resid,rsum,ax,ay,b + double precision error_local, uold(n,m) + + real ta,tb,tc,td,te,ta1,ta2,tb1,tb2,tc1,tc2,td1,td2 + real te1,te2 + real second + external second +* +* Initialize coefficients + ax = 1.0/(dx*dx) ! X-direction coef + ay = 1.0/(dy*dy) ! Y-direction coef + b = -2.0/(dx*dx)-2.0/(dy*dy) - alpha ! Central coeff + + error = 10.0 * tol + k = 1 + + do while (k.le.maxit .and. error.gt. tol) + + error = 0.0 + +* Copy new solution into old +!$omp parallel + +!$omp do + do j=1,m + do i=1,n + uold(i,j) = u(i,j) + enddo + enddo + +* Compute stencil, residual, & update + +!$omp do private(resid) reduction(+:error) + do j = 2,m-1 + do i = 2,n-1 +* Evaluate residual + resid = (ax*(uold(i-1,j) + uold(i+1,j)) + & + ay*(uold(i,j-1) + uold(i,j+1)) + & + b * uold(i,j) - f(i,j))/b +* Update solution + u(i,j) = uold(i,j) - omega * resid +* Accumulate residual error + error = error + resid*resid + end do + enddo +!$omp enddo nowait + +!$omp end parallel + +* Error check + + k = k + 1 + + error = sqrt(error)/dble(n*m) +* + enddo ! End iteration loop +* + print *, 'Total Number of Iterations ', k + print *, 'Residual ', error + + return + end + + subroutine error_check (n,m,alpha,dx,dy,u,f) + implicit none +************************************************************ +* Checks error between numerical and exact solution +* +************************************************************ + + integer n,m + double precision u(n,m),f(n,m),dx,dy,alpha + + integer i,j + double precision xx,yy,temp,error + + dx = 2.0 / (n-1) + dy = 2.0 / (m-1) + error = 0.0 + +!$omp parallel do private(xx,yy,temp) reduction(+:error) + do j = 1,m + do i = 1,n + xx = -1.0d0 + dx * dble(i-1) + yy = -1.0d0 + dy * dble(j-1) + temp = u(i,j) - (1.0-xx*xx)*(1.0-yy*yy) + error = error + temp*temp + enddo + enddo + + error = sqrt(error)/dble(n*m) + + print *, 'Solution Error : ',error + + return + end diff --git a/libgomp/testsuite/libgomp.fortran/lib1.f90 b/libgomp/testsuite/libgomp.fortran/lib1.f90 new file mode 100644 index 00000000000..8840018674a --- /dev/null +++ b/libgomp/testsuite/libgomp.fortran/lib1.f90 @@ -0,0 +1,76 @@ +! { dg-do run } + + use omp_lib + + double precision :: d, e + logical :: l + integer (kind = omp_lock_kind) :: lck + integer (kind = omp_nest_lock_kind) :: nlck + + d = omp_get_wtime () + + call omp_init_lock (lck) + call omp_set_lock (lck) + if (omp_test_lock (lck)) call abort + call omp_unset_lock (lck) + if (.not. omp_test_lock (lck)) call abort + if (omp_test_lock (lck)) call abort + call omp_unset_lock (lck) + call omp_destroy_lock (lck) + + call omp_init_nest_lock (nlck) + if (omp_test_nest_lock (nlck) .ne. 1) call abort + call omp_set_nest_lock (nlck) + if (omp_test_nest_lock (nlck) .ne. 3) call abort + call omp_unset_nest_lock (nlck) + call omp_unset_nest_lock (nlck) + if (omp_test_nest_lock (nlck) .ne. 2) call abort + call omp_unset_nest_lock (nlck) + call omp_unset_nest_lock (nlck) + call omp_destroy_nest_lock (nlck) + + call omp_set_dynamic (.true.) + if (.not. omp_get_dynamic ()) call abort + call omp_set_dynamic (.false.) + if (omp_get_dynamic ()) call abort + + call omp_set_nested (.true.) + if (.not. omp_get_nested ()) call abort + call omp_set_nested (.false.) + if (omp_get_nested ()) call abort + + call omp_set_num_threads (5) + if (omp_get_num_threads () .ne. 1) call abort + if (omp_get_max_threads () .ne. 5) call abort + if (omp_get_thread_num () .ne. 0) call abort + call omp_set_num_threads (3) + if (omp_get_num_threads () .ne. 1) call abort + if (omp_get_max_threads () .ne. 3) call abort + if (omp_get_thread_num () .ne. 0) call abort + l = .false. +!$omp parallel reduction (.or.:l) + l = omp_get_num_threads () .ne. 3 + l = l .or. (omp_get_thread_num () .lt. 0) + l = l .or. (omp_get_thread_num () .ge. 3) +!$omp master + l = l .or. (omp_get_thread_num () .ne. 0) +!$omp end master +!$omp end parallel + if (l) call abort + + if (omp_get_num_procs () .le. 0) call abort + if (omp_in_parallel ()) call abort +!$omp parallel reduction (.or.:l) + l = .not. omp_in_parallel () +!$omp end parallel +!$omp parallel reduction (.or.:l) if (.true.) + l = .not. omp_in_parallel () +!$omp end parallel + + e = omp_get_wtime () + if (d .gt. e) call abort + d = omp_get_wtick () + ! Negative precision is definitely wrong, + ! bigger than 1s clock resolution is also strange + if (d .le. 0 .or. d .gt. 1.) call abort +end diff --git a/libgomp/testsuite/libgomp.fortran/lib2.f b/libgomp/testsuite/libgomp.fortran/lib2.f new file mode 100644 index 00000000000..75510827043 --- /dev/null +++ b/libgomp/testsuite/libgomp.fortran/lib2.f @@ -0,0 +1,76 @@ +C { dg-do run } + + USE OMP_LIB + + DOUBLE PRECISION :: D, E + LOGICAL :: L + INTEGER (KIND = OMP_LOCK_KIND) :: LCK + INTEGER (KIND = OMP_NEST_LOCK_KIND) :: NLCK + + D = OMP_GET_WTIME () + + CALL OMP_INIT_LOCK (LCK) + CALL OMP_SET_LOCK (LCK) + IF (OMP_TEST_LOCK (LCK)) CALL ABORT + CALL OMP_UNSET_LOCK (LCK) + IF (.NOT. OMP_TEST_LOCK (LCK)) CALL ABORT + IF (OMP_TEST_LOCK (LCK)) CALL ABORT + CALL OMP_UNSET_LOCK (LCK) + CALL OMP_DESTROY_LOCK (LCK) + + CALL OMP_INIT_NEST_LOCK (NLCK) + IF (OMP_TEST_NEST_LOCK (NLCK) .NE. 1) CALL ABORT + CALL OMP_SET_NEST_LOCK (NLCK) + IF (OMP_TEST_NEST_LOCK (NLCK) .NE. 3) CALL ABORT + CALL OMP_UNSET_NEST_LOCK (NLCK) + CALL OMP_UNSET_NEST_LOCK (NLCK) + IF (OMP_TEST_NEST_LOCK (NLCK) .NE. 2) CALL ABORT + CALL OMP_UNSET_NEST_LOCK (NLCK) + CALL OMP_UNSET_NEST_LOCK (NLCK) + CALL OMP_DESTROY_NEST_LOCK (NLCK) + + CALL OMP_SET_DYNAMIC (.TRUE.) + IF (.NOT. OMP_GET_DYNAMIC ()) CALL ABORT + CALL OMP_SET_DYNAMIC (.FALSE.) + IF (OMP_GET_DYNAMIC ()) CALL ABORT + + CALL OMP_SET_NESTED (.TRUE.) + IF (.NOT. OMP_GET_NESTED ()) CALL ABORT + CALL OMP_SET_NESTED (.FALSE.) + IF (OMP_GET_NESTED ()) CALL ABORT + + CALL OMP_SET_NUM_THREADS (5) + IF (OMP_GET_NUM_THREADS () .NE. 1) CALL ABORT + IF (OMP_GET_MAX_THREADS () .NE. 5) CALL ABORT + IF (OMP_GET_THREAD_NUM () .NE. 0) CALL ABORT + CALL OMP_SET_NUM_THREADS (3) + IF (OMP_GET_NUM_THREADS () .NE. 1) CALL ABORT + IF (OMP_GET_MAX_THREADS () .NE. 3) CALL ABORT + IF (OMP_GET_THREAD_NUM () .NE. 0) CALL ABORT + L = .FALSE. +C$OMP PARALLEL REDUCTION (.OR.:L) + L = OMP_GET_NUM_THREADS () .NE. 3 + L = L .OR. (OMP_GET_THREAD_NUM () .LT. 0) + L = L .OR. (OMP_GET_THREAD_NUM () .GE. 3) +C$OMP MASTER + L = L .OR. (OMP_GET_THREAD_NUM () .NE. 0) +C$OMP END MASTER +C$OMP END PARALLEL + IF (L) CALL ABORT + + IF (OMP_GET_NUM_PROCS () .LE. 0) CALL ABORT + IF (OMP_IN_PARALLEL ()) CALL ABORT +C$OMP PARALLEL REDUCTION (.OR.:L) + L = .NOT. OMP_IN_PARALLEL () +C$OMP END PARALLEL +C$OMP PARALLEL REDUCTION (.OR.:L) IF (.TRUE.) + L = .NOT. OMP_IN_PARALLEL () +C$OMP END PARALLEL + + E = OMP_GET_WTIME () + IF (D .GT. E) CALL ABORT + D = OMP_GET_WTICK () +C Negative precision is definitely wrong, +C bigger than 1s clock resolution is also strange + IF (D .LE. 0 .OR. D .GT. 1.) CALL ABORT + END diff --git a/libgomp/testsuite/libgomp.fortran/lib3.f b/libgomp/testsuite/libgomp.fortran/lib3.f new file mode 100644 index 00000000000..fa7b227c0ef --- /dev/null +++ b/libgomp/testsuite/libgomp.fortran/lib3.f @@ -0,0 +1,76 @@ +C { dg-do run } + + INCLUDE "omp_lib.h" + + DOUBLE PRECISION :: D, E + LOGICAL :: L + INTEGER (KIND = OMP_LOCK_KIND) :: LCK + INTEGER (KIND = OMP_NEST_LOCK_KIND) :: NLCK + + D = OMP_GET_WTIME () + + CALL OMP_INIT_LOCK (LCK) + CALL OMP_SET_LOCK (LCK) + IF (OMP_TEST_LOCK (LCK)) CALL ABORT + CALL OMP_UNSET_LOCK (LCK) + IF (.NOT. OMP_TEST_LOCK (LCK)) CALL ABORT + IF (OMP_TEST_LOCK (LCK)) CALL ABORT + CALL OMP_UNSET_LOCK (LCK) + CALL OMP_DESTROY_LOCK (LCK) + + CALL OMP_INIT_NEST_LOCK (NLCK) + IF (OMP_TEST_NEST_LOCK (NLCK) .NE. 1) CALL ABORT + CALL OMP_SET_NEST_LOCK (NLCK) + IF (OMP_TEST_NEST_LOCK (NLCK) .NE. 3) CALL ABORT + CALL OMP_UNSET_NEST_LOCK (NLCK) + CALL OMP_UNSET_NEST_LOCK (NLCK) + IF (OMP_TEST_NEST_LOCK (NLCK) .NE. 2) CALL ABORT + CALL OMP_UNSET_NEST_LOCK (NLCK) + CALL OMP_UNSET_NEST_LOCK (NLCK) + CALL OMP_DESTROY_NEST_LOCK (NLCK) + + CALL OMP_SET_DYNAMIC (.TRUE.) + IF (.NOT. OMP_GET_DYNAMIC ()) CALL ABORT + CALL OMP_SET_DYNAMIC (.FALSE.) + IF (OMP_GET_DYNAMIC ()) CALL ABORT + + CALL OMP_SET_NESTED (.TRUE.) + IF (.NOT. OMP_GET_NESTED ()) CALL ABORT + CALL OMP_SET_NESTED (.FALSE.) + IF (OMP_GET_NESTED ()) CALL ABORT + + CALL OMP_SET_NUM_THREADS (5) + IF (OMP_GET_NUM_THREADS () .NE. 1) CALL ABORT + IF (OMP_GET_MAX_THREADS () .NE. 5) CALL ABORT + IF (OMP_GET_THREAD_NUM () .NE. 0) CALL ABORT + CALL OMP_SET_NUM_THREADS (3) + IF (OMP_GET_NUM_THREADS () .NE. 1) CALL ABORT + IF (OMP_GET_MAX_THREADS () .NE. 3) CALL ABORT + IF (OMP_GET_THREAD_NUM () .NE. 0) CALL ABORT + L = .FALSE. +C$OMP PARALLEL REDUCTION (.OR.:L) + L = OMP_GET_NUM_THREADS () .NE. 3 + L = L .OR. (OMP_GET_THREAD_NUM () .LT. 0) + L = L .OR. (OMP_GET_THREAD_NUM () .GE. 3) +C$OMP MASTER + L = L .OR. (OMP_GET_THREAD_NUM () .NE. 0) +C$OMP END MASTER +C$OMP END PARALLEL + IF (L) CALL ABORT + + IF (OMP_GET_NUM_PROCS () .LE. 0) CALL ABORT + IF (OMP_IN_PARALLEL ()) CALL ABORT +C$OMP PARALLEL REDUCTION (.OR.:L) + L = .NOT. OMP_IN_PARALLEL () +C$OMP END PARALLEL +C$OMP PARALLEL REDUCTION (.OR.:L) IF (.TRUE.) + L = .NOT. OMP_IN_PARALLEL () +C$OMP END PARALLEL + + E = OMP_GET_WTIME () + IF (D .GT. E) CALL ABORT + D = OMP_GET_WTICK () +C Negative precision is definitely wrong, +C bigger than 1s clock resolution is also strange + IF (D .LE. 0 .OR. D .GT. 1.) CALL ABORT + END diff --git a/libgomp/testsuite/libgomp.fortran/nestedfn1.f90 b/libgomp/testsuite/libgomp.fortran/nestedfn1.f90 new file mode 100644 index 00000000000..67dadd6dfc1 --- /dev/null +++ b/libgomp/testsuite/libgomp.fortran/nestedfn1.f90 @@ -0,0 +1,43 @@ +! { dg-do run } + + integer :: a, b, c + a = 1 + b = 2 + c = 3 + call foo + if (a .ne. 7) call abort +contains + subroutine foo + use omp_lib + logical :: l + l = .false. +!$omp parallel shared (a) private (b) firstprivate (c) & +!$omp num_threads (2) reduction (.or.:l) + if (a .ne. 1 .or. c .ne. 3) l = .true. +!$omp barrier + if (omp_get_thread_num () .eq. 0) then + a = 4 + b = 5 + c = 6 + end if +!$omp barrier + if (omp_get_thread_num () .eq. 1) then + if (a .ne. 4 .or. c .ne. 3) l = .true. + a = 7 + b = 8 + c = 9 + else if (omp_get_num_threads () .eq. 1) then + a = 7 + end if +!$omp barrier + if (omp_get_thread_num () .eq. 0) then + if (a .ne. 7 .or. b .ne. 5 .or. c .ne. 6) l = .true. + end if +!$omp barrier + if (omp_get_thread_num () .eq. 1) then + if (a .ne. 7 .or. b .ne. 8 .or. c .ne. 9) l = .true. + end if +!$omp end parallel + if (l) call abort + end subroutine foo +end diff --git a/libgomp/testsuite/libgomp.fortran/nestedfn2.f90 b/libgomp/testsuite/libgomp.fortran/nestedfn2.f90 new file mode 100644 index 00000000000..dfb12ae6622 --- /dev/null +++ b/libgomp/testsuite/libgomp.fortran/nestedfn2.f90 @@ -0,0 +1,34 @@ +! { dg-do run } + + integer :: i + common /c/ i + i = -1 +!$omp parallel shared (i) num_threads (4) + call test1 +!$omp end parallel +end +subroutine test1 + integer :: vari + call test2 + call test3 +contains + subroutine test2 + use omp_lib + integer :: i + common /c/ i +!$omp single + i = omp_get_thread_num () + call test4 +!$omp end single copyprivate (vari) + end subroutine test2 + subroutine test3 + integer :: i + common /c/ i + if (i .lt. 0 .or. i .ge. 4) call abort + if (i + 10 .ne. vari) call abort + end subroutine test3 + subroutine test4 + use omp_lib + vari = omp_get_thread_num () + 10 + end subroutine test4 +end subroutine test1 diff --git a/libgomp/testsuite/libgomp.fortran/omp_atomic1.f90 b/libgomp/testsuite/libgomp.fortran/omp_atomic1.f90 new file mode 100644 index 00000000000..f9ce94b9ad7 --- /dev/null +++ b/libgomp/testsuite/libgomp.fortran/omp_atomic1.f90 @@ -0,0 +1,39 @@ +! { dg-do run } + integer (kind = 4) :: a + integer (kind = 2) :: b + real :: c, f + double precision :: d + integer, dimension (10) :: e + a = 1 + b = 2 + c = 3 + d = 4 + e = 5 + f = 6 +!$omp atomic + a = a + 4 +!$omp atomic + b = 4 - b +!$omp atomic + c = c * 2 +!$omp atomic + d = 2 / d + if (a .ne. 5 .or. b .ne. 2 .or. c .ne. 6 .or. d .ne. 0.5) call abort + d = 1.2 +!$omp atomic + a = a + c + d +!$omp atomic + b = b - (a + c + d) + if (a .ne. 12 .or. b .ne. -17) call abort +!$omp atomic + a = c + d + a +!$omp atomic + b = a + c + d - b + if (a .ne. 19 .or. b .ne. 43) call abort +!$omp atomic + b = (a + c + d) - b + a = 32 +!$omp atomic + a = a / 3.4 + if (a .ne. 9 .or. b .ne. -16) call abort +end diff --git a/libgomp/testsuite/libgomp.fortran/omp_atomic2.f90 b/libgomp/testsuite/libgomp.fortran/omp_atomic2.f90 new file mode 100644 index 00000000000..1dea2c8ebd8 --- /dev/null +++ b/libgomp/testsuite/libgomp.fortran/omp_atomic2.f90 @@ -0,0 +1,54 @@ +! { dg-do run } + real, dimension (20) :: r + integer, dimension (20) :: d + integer :: i, j, k, n + integer (kind = 2) :: a, b, c + + do 10 i = 1, 20 + r(i) = i +10 d(i) = 21 - i + + n = 20 + call foo (r, d, n) + + if (n .ne. 22) call abort + if (any (r .ne. 33)) call abort + + i = 1 + j = 18 + k = 23 +!$omp atomic + i = min (i, j, k, n) + if (i .ne. 1) call abort +!$omp atomic + i = max (j, n, k, i) + if (i .ne. 23) call abort + + a = 1 + b = 18 + c = 23 +!$omp atomic + a = min (a, b, c) + if (a .ne. 1) call abort +!$omp atomic + a = max (a, b, c) + if (a .ne. 23) call abort + +contains + function bar (i) + real bar + integer i + bar = 12.0 + i + end function bar + + subroutine foo (x, y, n) + integer i, y (*), n + real x (*) + do i = 1, n +!$omp atomic + x(y(i)) = x(y(i)) + bar (i) + end do +!$omp atomic + n = n + 2 + end subroutine foo +end diff --git a/libgomp/testsuite/libgomp.fortran/omp_cond1.f b/libgomp/testsuite/libgomp.fortran/omp_cond1.f new file mode 100644 index 00000000000..b557d908003 --- /dev/null +++ b/libgomp/testsuite/libgomp.fortran/omp_cond1.f @@ -0,0 +1,22 @@ +C Test conditional compilation in fixed form if -fopenmp +! { dg-options "-fopenmp" } + 10 foo = 2 + &56 + if (foo.ne.256) call abort + bar = 26 +!$2 0 ba +c$ +r = 42 + !$ bar = 62 +!$ bar = bar + 1 + if (bar.ne.43) call abort + baz = bar +*$ 0baz = 5 +C$ +12! Comment +c$ !4 +!$ +!Another comment +*$ &2 +!$ X baz = 0 ! Not valid OpenMP conditional compilation lines +! $ baz = 1 +c$ 10&baz = 2 + if (baz.ne.51242) call abort + end diff --git a/libgomp/testsuite/libgomp.fortran/omp_cond2.f b/libgomp/testsuite/libgomp.fortran/omp_cond2.f new file mode 100644 index 00000000000..6df891c6c67 --- /dev/null +++ b/libgomp/testsuite/libgomp.fortran/omp_cond2.f @@ -0,0 +1,22 @@ +c Test conditional compilation in fixed form if -fno-openmp +! { dg-options "-fno-openmp" } + 10 foo = 2 + &56 + if (foo.ne.256) call abort + bar = 26 +!$2 0 ba +c$ +r = 42 + !$ bar = 62 +!$ bar = bar + 1 + if (bar.ne.26) call abort + baz = bar +*$ 0baz = 5 +C$ +12! Comment +c$ !4 +!$ +!Another comment +*$ &2 +!$ X baz = 0 ! Not valid OpenMP conditional compilation lines +! $ baz = 1 +c$ 10&baz = 2 + if (baz.ne.26) call abort + end diff --git a/libgomp/testsuite/libgomp.fortran/omp_cond3.F90 b/libgomp/testsuite/libgomp.fortran/omp_cond3.F90 new file mode 100644 index 00000000000..6c4e36e2293 --- /dev/null +++ b/libgomp/testsuite/libgomp.fortran/omp_cond3.F90 @@ -0,0 +1,24 @@ +! Test conditional compilation in free form if -fopenmp +! { dg-options "-fopenmp" } + 10 foo = 2& + &56 + if (foo.ne.256) call abort + bar = 26 + !$ 20 ba& +!$ &r = 4& + !$2 + !$bar = 62 + !$ bar = bar + 2 +#ifdef _OPENMP +bar = bar - 1 +#endif + if (bar.ne.43) call abort + baz = bar +!$ 30 baz = 5& ! Comment +!$12 & + !$ + 2 +!$X baz = 0 ! Not valid OpenMP conditional compilation lines +! $ baz = 1 +baz = baz + 1 !$ baz = 2 + if (baz.ne.515) call abort + end diff --git a/libgomp/testsuite/libgomp.fortran/omp_cond4.F90 b/libgomp/testsuite/libgomp.fortran/omp_cond4.F90 new file mode 100644 index 00000000000..aa4c5cb76d6 --- /dev/null +++ b/libgomp/testsuite/libgomp.fortran/omp_cond4.F90 @@ -0,0 +1,24 @@ +! Test conditional compilation in free form if -fno-openmp +! { dg-options "-fno-openmp" } + 10 foo = 2& + &56 + if (foo.ne.256) call abort + bar = 26 + !$ 20 ba& +!$ &r = 4& + !$2 + !$bar = 62 + !$ bar = bar + 2 +#ifdef _OPENMP +bar = bar - 1 +#endif + if (bar.ne.26) call abort + baz = bar +!$ 30 baz = 5& ! Comment +!$12 & + !$ + 2 +!$X baz = 0 ! Not valid OpenMP conditional compilation lines +! $ baz = 1 +baz = baz + 1 !$ baz = 2 + if (baz.ne.27) call abort + end diff --git a/libgomp/testsuite/libgomp.fortran/omp_hello.f b/libgomp/testsuite/libgomp.fortran/omp_hello.f new file mode 100644 index 00000000000..ba445312625 --- /dev/null +++ b/libgomp/testsuite/libgomp.fortran/omp_hello.f @@ -0,0 +1,36 @@ +C****************************************************************************** +C FILE: omp_hello.f +C DESCRIPTION: +C OpenMP Example - Hello World - Fortran Version +C In this simple example, the master thread forks a parallel region. +C All threads in the team obtain their unique thread number and print it. +C The master thread only prints the total number of threads. Two OpenMP +C library routines are used to obtain the number of threads and each +C thread's number. +C AUTHOR: Blaise Barney 5/99 +C LAST REVISED: +C****************************************************************************** + + PROGRAM HELLO + + INTEGER NTHREADS, TID, OMP_GET_NUM_THREADS, + + OMP_GET_THREAD_NUM + +C Fork a team of threads giving them their own copies of variables +!$OMP PARALLEL PRIVATE(NTHREADS, TID) + + +C Obtain thread number + TID = OMP_GET_THREAD_NUM() + PRINT *, 'Hello World from thread = ', TID + +C Only master thread does this + IF (TID .EQ. 0) THEN + NTHREADS = OMP_GET_NUM_THREADS() + PRINT *, 'Number of threads = ', NTHREADS + END IF + +C All threads join master thread and disband +!$OMP END PARALLEL + + END diff --git a/libgomp/testsuite/libgomp.fortran/omp_orphan.f b/libgomp/testsuite/libgomp.fortran/omp_orphan.f new file mode 100644 index 00000000000..7653c78d2e4 --- /dev/null +++ b/libgomp/testsuite/libgomp.fortran/omp_orphan.f @@ -0,0 +1,44 @@ +C****************************************************************************** +C FILE: omp_orphan.f +C DESCRIPTION: +C OpenMP Example - Parallel region with an orphaned directive - Fortran +C Version +C This example demonstrates a dot product being performed by an orphaned +C loop reduction construct. Scoping of the reduction variable is critical. +C AUTHOR: Blaise Barney 5/99 +C LAST REVISED: +C****************************************************************************** + + PROGRAM ORPHAN + COMMON /DOTDATA/ A, B, SUM + INTEGER I, VECLEN + PARAMETER (VECLEN = 100) + REAL*8 A(VECLEN), B(VECLEN), SUM + + DO I=1, VECLEN + A(I) = 1.0 * I + B(I) = A(I) + ENDDO + SUM = 0.0 +!$OMP PARALLEL + CALL DOTPROD +!$OMP END PARALLEL + WRITE(*,*) "Sum = ", SUM + END + + + + SUBROUTINE DOTPROD + COMMON /DOTDATA/ A, B, SUM + INTEGER I, TID, OMP_GET_THREAD_NUM, VECLEN + PARAMETER (VECLEN = 100) + REAL*8 A(VECLEN), B(VECLEN), SUM + + TID = OMP_GET_THREAD_NUM() +!$OMP DO REDUCTION(+:SUM) + DO I=1, VECLEN + SUM = SUM + (A(I)*B(I)) + PRINT *, ' TID= ',TID,'I= ',I + ENDDO + RETURN + END diff --git a/libgomp/testsuite/libgomp.fortran/omp_parse1.f90 b/libgomp/testsuite/libgomp.fortran/omp_parse1.f90 new file mode 100644 index 00000000000..9cd8cc2ba13 --- /dev/null +++ b/libgomp/testsuite/libgomp.fortran/omp_parse1.f90 @@ -0,0 +1,185 @@ +! { dg-do run } +use omp_lib + call test_parallel + call test_do + call test_sections + call test_single + +contains + subroutine test_parallel + integer :: a, b, c, e, f, g, i, j + integer, dimension (20) :: d + logical :: h + a = 6 + b = 8 + c = 11 + d(:) = -1 + e = 13 + f = 24 + g = 27 + h = .false. + i = 1 + j = 16 +!$omp para& +!$omp&llel & +!$omp if (a .eq. 6) private (b, c) shared (d) private (e) & + !$omp firstprivate(f) num_threads (a - 1) first& +!$ompprivate(g)default (shared) reduction (.or. : h) & +!$omp reduction(*:i) + if (i .ne. 1) h = .true. + i = 2 + if (f .ne. 24) h = .true. + if (g .ne. 27) h = .true. + e = 7 + b = omp_get_thread_num () + if (b .eq. 0) j = 24 + f = b + g = f + c = omp_get_num_threads () + if (c .gt. a - 1 .or. c .le. 0) h = .true. + if (b .ge. c) h = .true. + d(b + 1) = c + if (f .ne. g .or. f .ne. b) h = .true. +!$omp endparallel + if (h) call abort + if (a .ne. 6) call abort + if (j .ne. 24) call abort + if (d(1) .eq. -1) call abort + e = 1 + do g = 1, d(1) + if (d(g) .ne. d(1)) call abort + e = e * 2 + end do + if (e .ne. i) call abort + end subroutine test_parallel + + subroutine test_do_orphan + integer :: k, l +!$omp parallel do private (l) + do 600 k = 1, 16, 2 +600 l = k + end subroutine test_do_orphan + + subroutine test_do + integer :: i, j, k, l, n + integer, dimension (64) :: d + logical :: m + + j = 16 + d(:) = -1 + m = .true. + n = 24 +!$omp parallel num_threads (4) shared (i, k, d) private (l) & +!$omp&reduction (.and. : m) + if (omp_get_thread_num () .eq. 0) then + k = omp_get_num_threads () + end if + call test_do_orphan +!$omp do schedule (static) firstprivate (n) + do 200 i = 1, j + if (i .eq. 1 .and. n .ne. 24) call abort + n = i +200 d(n) = omp_get_thread_num () +!$omp enddo nowait + +!$omp do lastprivate (i) schedule (static, 5) + do 201 i = j + 1, 2 * j +201 d(i) = omp_get_thread_num () + 1024 + ! Implied omp end do here + + if (i .ne. 33) m = .false. + +!$omp do private (j) schedule (dynamic) + do i = 33, 48 + d(i) = omp_get_thread_num () + 2048 + end do +!$omp end do nowait + +!$omp do schedule (runtime) + do i = 49, 4 * j + d(i) = omp_get_thread_num () + 4096 + end do + ! Implied omp end do here +!$omp end parallel + if (.not. m) call abort + + j = 0 + do i = 1, 64 + if (d(i) .lt. j .or. d(i) .ge. j + k) call abort + if (i .eq. 16) j = 1024 + if (i .eq. 32) j = 2048 + if (i .eq. 48) j = 4096 + end do + end subroutine test_do + + subroutine test_sections + integer :: i, j, k, l, m, n + i = 9 + j = 10 + k = 11 + l = 0 + m = 0 + n = 30 + call omp_set_dynamic (.false.) + call omp_set_num_threads (4) +!$omp parallel num_threads (4) +!$omp sections private (i) firstprivate (j, k) lastprivate (j) & +!$omp& reduction (+ : l, m) +!$omp section + i = 24 + if (j .ne. 10 .or. k .ne. 11 .or. m .ne. 0) l = 1 + m = m + 4 +!$omp section + i = 25 + if (j .ne. 10 .or. k .ne. 11) l = 1 + m = m + 6 +!$omp section + i = 26 + if (j .ne. 10 .or. k .ne. 11) l = 1 + m = m + 8 +!$omp section + i = 27 + if (j .ne. 10 .or. k .ne. 11) l = 1 + m = m + 10 + j = 271 +!$omp end sections nowait +!$omp sections lastprivate (n) +!$omp section + n = 6 +!$omp section + n = 7 +!$omp endsections +!$omp end parallel + if (j .ne. 271 .or. l .ne. 0) call abort + if (m .ne. 4 + 6 + 8 + 10) call abort + if (n .ne. 7) call abort + end subroutine test_sections + + subroutine test_single + integer :: i, j, k, l + logical :: m + i = 200 + j = 300 + k = 400 + l = 500 + m = .false. +!$omp parallel num_threads (4), private (i, j), reduction (.or. : m) + i = omp_get_thread_num () + j = omp_get_thread_num () +!$omp single private (k) + k = 64 +!$omp end single nowait +!$omp single private (k) firstprivate (l) + if (i .ne. omp_get_thread_num () .or. i .ne. j) then + j = -1 + else + j = -2 + end if + if (l .ne. 500) j = -1 + l = 265 +!$omp end single copyprivate (j) + if (i .ne. omp_get_thread_num () .or. j .ne. -2) m = .true. +!$omp endparallel + if (m) call abort + end subroutine test_single +end diff --git a/libgomp/testsuite/libgomp.fortran/omp_parse2.f90 b/libgomp/testsuite/libgomp.fortran/omp_parse2.f90 new file mode 100644 index 00000000000..da54a987275 --- /dev/null +++ b/libgomp/testsuite/libgomp.fortran/omp_parse2.f90 @@ -0,0 +1,102 @@ +! { dg-do run } +use omp_lib + call test_master + call test_critical + call test_barrier + call test_atomic + +contains + subroutine test_master + logical :: i, j + i = .false. + j = .false. +!$omp parallel num_threads (4) +!$omp master + i = .true. + j = omp_get_thread_num () .eq. 0 +!$omp endmaster +!$omp end parallel + if (.not. (i .or. j)) call abort + end subroutine test_master + + subroutine test_critical_1 (i, j) + integer :: i, j +!$omp critical(critical_foo) + i = i + 1 +!$omp end critical (critical_foo) +!$omp critical + j = j + 1 +!$omp end critical + end subroutine test_critical_1 + + subroutine test_critical + integer :: i, j, n + n = -1 + i = 0 + j = 0 +!$omp parallel num_threads (4) + if (omp_get_thread_num () .eq. 0) n = omp_get_num_threads () + call test_critical_1 (i, j) + call test_critical_1 (i, j) +!$omp critical + j = j + 1 +!$omp end critical +!$omp critical (critical_foo) + i = i + 1 +!$omp endcritical (critical_foo) +!$omp end parallel + if (n .lt. 1 .or. i .ne. n * 3 .or. j .ne. n * 3) call abort + end subroutine test_critical + + subroutine test_barrier + integer :: i + logical :: j + i = 23 + j = .false. +!$omp parallel num_threads (4) + if (omp_get_thread_num () .eq. 0) i = 5 +!$omp flush (i) +!$omp barrier + if (i .ne. 5) then +!$omp atomic + j = j .or. .true. + end if +!$omp end parallel + if (i .ne. 5 .or. j) call abort + end subroutine test_barrier + + subroutine test_atomic + integer :: a, b, c, d, e, f, g + a = 0 + b = 1 + c = 0 + d = 1024 + e = 1024 + f = -1 + g = -1 +!$omp parallel num_threads (8) +!$omp atomic + a = a + 2 + 4 +!$omp atomic + b = 3 * b +!$omp atomic + c = 8 - c +!$omp atomic + d = d / 2 +!$omp atomic + e = min (e, omp_get_thread_num ()) +!$omp atomic + f = max (omp_get_thread_num (), f) + if (omp_get_thread_num () .eq. 0) g = omp_get_num_threads () +!$omp end parallel + if (g .le. 0 .or. g .gt. 8) call abort + if (a .ne. 6 * g .or. b .ne. 3 ** g) call abort + if (iand (g, 1) .eq. 1) then + if (c .ne. 8) call abort + else if (c .ne. 0) then + call abort + end if + if (d .ne. 1024 / (2 ** g)) call abort + if (e .ne. 0 .or. f .ne. g - 1) call abort + end subroutine test_atomic +end diff --git a/libgomp/testsuite/libgomp.fortran/omp_parse3.f90 b/libgomp/testsuite/libgomp.fortran/omp_parse3.f90 new file mode 100644 index 00000000000..98c94b93b79 --- /dev/null +++ b/libgomp/testsuite/libgomp.fortran/omp_parse3.f90 @@ -0,0 +1,95 @@ +! { dg-do run } +! { dg-require-effective-target tls_runtime } +use omp_lib + common /tlsblock/ x, y + integer :: x, y, z + save z +!$omp threadprivate (/tlsblock/, z) + + call test_flush + call test_ordered + call test_threadprivate + +contains + subroutine test_flush + integer :: i, j + i = 0 + j = 0 +!$omp parallel num_threads (4) + if (omp_get_thread_num () .eq. 0) i = omp_get_num_threads () + if (omp_get_thread_num () .eq. 0) j = j + 1 +!$omp flush (i, j) +!$omp barrier + if (omp_get_thread_num () .eq. 1) j = j + 2 +!$omp flush +!$omp barrier + if (omp_get_thread_num () .eq. 2) j = j + 3 +!$omp flush (i) +!$omp flush (j) +!$omp barrier + if (omp_get_thread_num () .eq. 3) j = j + 4 +!$omp end parallel + end subroutine test_flush + + subroutine test_ordered + integer :: i, j + integer, dimension (100) :: d + d(:) = -1 +!$omp parallel do ordered schedule (dynamic) num_threads (4) + do i = 1, 100, 5 +!$omp ordered + d(i) = i +!$omp end ordered + end do + j = 1 + do 100 i = 1, 100 + if (i .eq. j) then + if (d(i) .ne. i) call abort + j = i + 5 + else + if (d(i) .ne. -1) call abort + end if +100 d(i) = -1 + end subroutine test_ordered + + subroutine test_threadprivate + common /tlsblock/ x, y +!$omp threadprivate (/tlsblock/) + integer :: i, j + logical :: m, n + call omp_set_num_threads (4) + call omp_set_dynamic (.false.) + i = -1 + x = 6 + y = 7 + z = 8 + n = .false. + m = .false. +!$omp parallel copyin (/tlsblock/, z) reduction (.or.:m) & +!$omp& num_threads (4) + if (omp_get_thread_num () .eq. 0) i = omp_get_num_threads () + if (x .ne. 6 .or. y .ne. 7 .or. z .ne. 8) call abort + x = omp_get_thread_num () + y = omp_get_thread_num () + 1024 + z = omp_get_thread_num () + 4096 +!$omp end parallel + if (x .ne. 0 .or. y .ne. 1024 .or. z .ne. 4096) call abort +!$omp parallel num_threads (4), private (j) reduction (.or.:n) + if (omp_get_num_threads () .eq. i) then + j = omp_get_thread_num () + if (x .ne. j .or. y .ne. j + 1024 .or. z .ne. j + 4096) & +& call abort + end if +!$omp end parallel + m = m .or. n + n = .false. +!$omp parallel num_threads (4), copyin (z) reduction (.or. : n) + if (z .ne. 4096) n = .true. + if (omp_get_num_threads () .eq. i) then + j = omp_get_thread_num () + if (x .ne. j .or. y .ne. j + 1024) call abort + end if +!$omp end parallel + if (m .or. n) call abort + end subroutine test_threadprivate +end diff --git a/libgomp/testsuite/libgomp.fortran/omp_parse4.f90 b/libgomp/testsuite/libgomp.fortran/omp_parse4.f90 new file mode 100644 index 00000000000..ba35bcb2ad4 --- /dev/null +++ b/libgomp/testsuite/libgomp.fortran/omp_parse4.f90 @@ -0,0 +1,72 @@ +! { dg-do run } +!$ use omp_lib + call test_workshare + +contains + subroutine test_workshare + integer :: i, j, k, l, m + double precision, dimension (64) :: d, e + integer, dimension (10) :: f, g + integer, dimension (16, 16) :: a, b, c + integer, dimension (16) :: n + d(:) = 1 + e = 7 + f = 10 + l = 256 + m = 512 + g(1:3) = -1 + g(4:6) = 0 + g(7:8) = 5 + g(9:10) = 10 + forall (i = 1:16, j = 1:16) a (i, j) = i * 16 + j + forall (j = 1:16) n (j) = j +!$omp parallel num_threads (4) private (j, k) +!$omp barrier +!$omp workshare + i = 6 + e(:) = d(:) + where (g .lt. 0) + f = 100 + elsewhere (g .eq. 0) + f = 200 + f + elsewhere + where (g .gt. 6) f = f + sum (g) + f = 300 + f + end where + where (f .gt. 210) g = 0 +!$omp end workshare nowait +!$omp workshare + forall (j = 1:16, k = 1:16) b (k, j) = a (j, k) + forall (k = 1:16) c (k, 1:16) = a (1:16, k) + forall (j = 2:16, n (17 - j) / 4 * 4 .ne. n (17 - j)) + n (j) = n (j - 1) * n (j) + end forall +!$omp endworkshare +!$omp workshare +!$omp atomic + i = i + 8 + 6 +!$omp critical +!$omp critical (critical_foox) + l = 128 +!$omp end critical (critical_foox) +!$omp endcritical +!$omp parallel num_threads (2) +!$ if (omp_get_thread_num () .eq. 0) m = omp_get_num_threads () +!$omp atomic + l = 1 + l +!$omp end parallel +!$omp end workshare +!$omp end parallel + + if (any (f .ne. (/100, 100, 100, 210, 210, 210, 310, 310, 337, 337/))) & +& call abort + if (any (g .ne. (/-1, -1, -1, 0, 0, 0, 0, 0, 0, 0/))) call abort + if (i .ne. 20) call abort +!$ if (l .ne. 128 + m) call abort + if (any (d .ne. 1 .or. e .ne. 1)) call abort + if (any (b .ne. transpose (a))) call abort + if (any (c .ne. b)) call abort + if (any (n .ne. (/1, 2, 6, 12, 5, 30, 42, 56, 9, 90, & +& 110, 132, 13, 182, 210, 240/))) call abort + end subroutine test_workshare +end diff --git a/libgomp/testsuite/libgomp.fortran/omp_reduction.f b/libgomp/testsuite/libgomp.fortran/omp_reduction.f new file mode 100644 index 00000000000..0560bd8963d --- /dev/null +++ b/libgomp/testsuite/libgomp.fortran/omp_reduction.f @@ -0,0 +1,33 @@ +C****************************************************************************** +C FILE: omp_reduction.f +C DESCRIPTION: +C OpenMP Example - Combined Parallel Loop Reduction - Fortran Version +C This example demonstrates a sum reduction within a combined parallel loop +C construct. Notice that default data element scoping is assumed - there +C are no clauses specifying shared or private variables. OpenMP will +C automatically make loop index variables private within team threads, and +C global variables shared. +C AUTHOR: Blaise Barney 5/99 +C LAST REVISED: +C****************************************************************************** + + PROGRAM REDUCTION + + INTEGER I, N + REAL A(100), B(100), SUM + +! Some initializations + N = 100 + DO I = 1, N + A(I) = I *1.0 + B(I) = A(I) + ENDDO + SUM = 0.0 + +!$OMP PARALLEL DO REDUCTION(+:SUM) + DO I = 1, N + SUM = SUM + (A(I) * B(I)) + ENDDO + + PRINT *, ' Sum = ', SUM + END diff --git a/libgomp/testsuite/libgomp.fortran/omp_workshare1.f b/libgomp/testsuite/libgomp.fortran/omp_workshare1.f new file mode 100644 index 00000000000..8aef69406de --- /dev/null +++ b/libgomp/testsuite/libgomp.fortran/omp_workshare1.f @@ -0,0 +1,48 @@ +C****************************************************************************** +C FILE: omp_workshare1.f +C DESCRIPTION: +C OpenMP Example - Loop Work-sharing - Fortran Version +C In this example, the iterations of a loop are scheduled dynamically +C across the team of threads. A thread will perform CHUNK iterations +C at a time before being scheduled for the next CHUNK of work. +C AUTHOR: Blaise Barney 5/99 +C LAST REVISED: 01/09/04 +C****************************************************************************** + + PROGRAM WORKSHARE1 + + INTEGER NTHREADS, TID, OMP_GET_NUM_THREADS, + + OMP_GET_THREAD_NUM, N, CHUNKSIZE, CHUNK, I + PARAMETER (N=100) + PARAMETER (CHUNKSIZE=10) + REAL A(N), B(N), C(N) + +! Some initializations + DO I = 1, N + A(I) = I * 1.0 + B(I) = A(I) + ENDDO + CHUNK = CHUNKSIZE + +!$OMP PARALLEL SHARED(A,B,C,NTHREADS,CHUNK) PRIVATE(I,TID) + + TID = OMP_GET_THREAD_NUM() + IF (TID .EQ. 0) THEN + NTHREADS = OMP_GET_NUM_THREADS() + PRINT *, 'Number of threads =', NTHREADS + END IF + PRINT *, 'Thread',TID,' starting...' + +!$OMP DO SCHEDULE(DYNAMIC,CHUNK) + DO I = 1, N + C(I) = A(I) + B(I) + WRITE(*,100) TID,I,C(I) + 100 FORMAT(' Thread',I2,': C(',I3,')=',F8.2) + ENDDO +!$OMP END DO NOWAIT + + PRINT *, 'Thread',TID,' done.' + +!$OMP END PARALLEL + + END diff --git a/libgomp/testsuite/libgomp.fortran/omp_workshare2.f b/libgomp/testsuite/libgomp.fortran/omp_workshare2.f new file mode 100644 index 00000000000..9e61da91e9b --- /dev/null +++ b/libgomp/testsuite/libgomp.fortran/omp_workshare2.f @@ -0,0 +1,56 @@ +C****************************************************************************** +C FILE: omp_workshare2.f +C DESCRIPTION: +C OpenMP Example - Sections Work-sharing - Fortran Version +C In this example, the OpenMP SECTION directive is used to assign +C different array operations to threads that execute a SECTION. Each +C thread receives its own copy of the result array to work with. +C AUTHOR: Blaise Barney 5/99 +C LAST REVISED: 01/09/04 +C****************************************************************************** + + PROGRAM WORKSHARE2 + + INTEGER N, I, NTHREADS, TID, OMP_GET_NUM_THREADS, + + OMP_GET_THREAD_NUM + PARAMETER (N=50) + REAL A(N), B(N), C(N) + +! Some initializations + DO I = 1, N + A(I) = I * 1.0 + B(I) = A(I) + ENDDO + +!$OMP PARALLEL SHARED(A,B,NTHREADS), PRIVATE(C,I,TID) + TID = OMP_GET_THREAD_NUM() + IF (TID .EQ. 0) THEN + NTHREADS = OMP_GET_NUM_THREADS() + PRINT *, 'Number of threads =', NTHREADS + END IF + PRINT *, 'Thread',TID,' starting...' + +!$OMP SECTIONS + +!$OMP SECTION + PRINT *, 'Thread',TID,' doing section 1' + DO I = 1, N + C(I) = A(I) + B(I) + WRITE(*,100) TID,I,C(I) + 100 FORMAT(' Thread',I2,': C(',I2,')=',F8.2) + ENDDO + +!$OMP SECTION + PRINT *, 'Thread',TID,' doing section 2' + DO I = 1+N/2, N + C(I) = A(I) * B(I) + WRITE(*,100) TID,I,C(I) + ENDDO + +!$OMP END SECTIONS NOWAIT + + PRINT *, 'Thread',TID,' done.' + +!$OMP END PARALLEL + + END diff --git a/libgomp/testsuite/libgomp.fortran/pr25162.f b/libgomp/testsuite/libgomp.fortran/pr25162.f new file mode 100644 index 00000000000..a868ea4c9b2 --- /dev/null +++ b/libgomp/testsuite/libgomp.fortran/pr25162.f @@ -0,0 +1,40 @@ +C PR fortran/25162 +C { dg-do run } +C { dg-require-effective-target tls_runtime } + PROGRAM PR25162 + CALL TEST1 + CALL TEST2 + END + SUBROUTINE TEST1 + DOUBLE PRECISION BPRIM + COMMON /TESTCOM/ BPRIM(100) +C$OMP THREADPRIVATE(/TESTCOM/) + INTEGER I + DO I = 1, 100 + BPRIM( I ) = DBLE( I ) + END DO + RETURN + END + SUBROUTINE TEST2 + DOUBLE PRECISION BPRIM + COMMON /TESTCOM/ BPRIM(100) +C$OMP THREADPRIVATE(/TESTCOM/) + INTEGER I, IDUM(50) + DO I = 1, 50 + IDUM(I) = I + END DO +C$OMP PARALLEL COPYIN(/TESTCOM/) NUM_THREADS(4) + CALL TEST3 +C$OMP END PARALLEL + RETURN + END + SUBROUTINE TEST3 + DOUBLE PRECISION BPRIM + COMMON /TESTCOM/ BPRIM(100) +C$OMP THREADPRIVATE(/TESTCOM/) + INTEGER K + DO K = 1, 10 + IF (K.NE.BPRIM(K)) CALL ABORT + END DO + RETURN + END diff --git a/libgomp/testsuite/libgomp.fortran/pr25219.f90 b/libgomp/testsuite/libgomp.fortran/pr25219.f90 new file mode 100644 index 00000000000..7fe1a53aa1c --- /dev/null +++ b/libgomp/testsuite/libgomp.fortran/pr25219.f90 @@ -0,0 +1,15 @@ +! PR fortran/25219 + + implicit none + save + integer :: i, k + k = 3 +!$omp parallel +!$omp do lastprivate (k) + do i = 1, 100 + k = i + end do +!$omp end do +!$omp end parallel + if (k .ne. 100) call abort +end diff --git a/libgomp/testsuite/libgomp.fortran/reduction1.f90 b/libgomp/testsuite/libgomp.fortran/reduction1.f90 new file mode 100644 index 00000000000..d6ceb081443 --- /dev/null +++ b/libgomp/testsuite/libgomp.fortran/reduction1.f90 @@ -0,0 +1,181 @@ +! { dg-do run } +!$ use omp_lib + + integer :: i, ia (6), n, cnt + real :: r, ra (4) + double precision :: d, da (5) + complex :: c, ca (3) + logical :: v + + i = 1 + ia = 2 + r = 3 + ra = 4 + d = 5.5 + da = 6.5 + c = cmplx (7.5, 1.5) + ca = cmplx (8.5, -3.0) + v = .false. + cnt = -1 + +!$omp parallel num_threads (3) private (n) reduction (.or.:v) & +!$omp & reduction (+:i, ia, r, ra, d, da, c, ca) +!$ if (i .ne. 0 .or. any (ia .ne. 0)) v = .true. +!$ if (r .ne. 0 .or. any (ra .ne. 0)) v = .true. +!$ if (d .ne. 0 .or. any (da .ne. 0)) v = .true. +!$ if (c .ne. cmplx (0) .or. any (ca .ne. cmplx (0))) v = .true. + n = omp_get_thread_num () + if (n .eq. 0) then + cnt = omp_get_num_threads () + i = 4 + ia(3:5) = -2 + r = 5 + ra(1:2) = 6.5 + d = -2.5 + da(2:4) = 8.5 + c = cmplx (2.5, -3.5) + ca(1) = cmplx (4.5, 5) + else if (n .eq. 1) then + i = 2 + ia(4:6) = 5 + r = 1 + ra(2:4) = -1.5 + d = 8.5 + da(1:3) = 2.5 + c = cmplx (0.5, -3) + ca(2:3) = cmplx (-1, 6) + else + i = 1 + ia = 1 + r = -1 + ra = -1 + d = 1 + da = -1 + c = 1 + ca = cmplx (-1, 0) + end if +!$omp end parallel + if (v) call abort + if (cnt .eq. 3) then + if (i .ne. 8 .or. any (ia .ne. (/3, 3, 1, 6, 6, 8/))) call abort + if (r .ne. 8 .or. any (ra .ne. (/9.5, 8.0, 1.5, 1.5/))) call abort + if (d .ne. 12.5 .or. any (da .ne. (/8.0, 16.5, 16.5, 14.0, 5.5/))) call abort + if (c .ne. cmplx (11.5, -5)) call abort + if (ca(1) .ne. cmplx (12, 2)) call abort + if (ca(2) .ne. cmplx (6.5, 3) .or. ca(2) .ne. ca(3)) call abort + end if + + i = 1 + ia = 2 + r = 3 + ra = 4 + d = 5.5 + da = 6.5 + c = cmplx (7.5, 1.5) + ca = cmplx (8.5, -3.0) + v = .false. + cnt = -1 + +!$omp parallel num_threads (3) private (n) reduction (.or.:v) & +!$omp & reduction (-:i, ia, r, ra, d, da, c, ca) +!$ if (i .ne. 0 .or. any (ia .ne. 0)) v = .true. +!$ if (r .ne. 0 .or. any (ra .ne. 0)) v = .true. +!$ if (d .ne. 0 .or. any (da .ne. 0)) v = .true. +!$ if (c .ne. cmplx (0) .or. any (ca .ne. cmplx (0))) v = .true. + n = omp_get_thread_num () + if (n .eq. 0) then + cnt = omp_get_num_threads () + i = 4 + ia(3:5) = -2 + r = 5 + ra(1:2) = 6.5 + d = -2.5 + da(2:4) = 8.5 + c = cmplx (2.5, -3.5) + ca(1) = cmplx (4.5, 5) + else if (n .eq. 1) then + i = 2 + ia(4:6) = 5 + r = 1 + ra(2:4) = -1.5 + d = 8.5 + da(1:3) = 2.5 + c = cmplx (0.5, -3) + ca(2:3) = cmplx (-1, 6) + else + i = 1 + ia = 1 + r = -1 + ra = -1 + d = 1 + da = -1 + c = 1 + ca = cmplx (-1, 0) + end if +!$omp end parallel + if (v) call abort + if (cnt .eq. 3) then + if (i .ne. 8 .or. any (ia .ne. (/3, 3, 1, 6, 6, 8/))) call abort + if (r .ne. 8 .or. any (ra .ne. (/9.5, 8.0, 1.5, 1.5/))) call abort + if (d .ne. 12.5 .or. any (da .ne. (/8.0, 16.5, 16.5, 14.0, 5.5/))) call abort + if (c .ne. cmplx (11.5, -5)) call abort + if (ca(1) .ne. cmplx (12, 2)) call abort + if (ca(2) .ne. cmplx (6.5, 3) .or. ca(2) .ne. ca(3)) call abort + end if + + i = 1 + ia = 2 + r = 4 + ra = 8 + d = 16 + da = 32 + c = 2 + ca = cmplx (0, 2) + v = .false. + cnt = -1 + +!$omp parallel num_threads (3) private (n) reduction (.or.:v) & +!$omp & reduction (*:i, ia, r, ra, d, da, c, ca) +!$ if (i .ne. 1 .or. any (ia .ne. 1)) v = .true. +!$ if (r .ne. 1 .or. any (ra .ne. 1)) v = .true. +!$ if (d .ne. 1 .or. any (da .ne. 1)) v = .true. +!$ if (c .ne. cmplx (1) .or. any (ca .ne. cmplx (1))) v = .true. + n = omp_get_thread_num () + if (n .eq. 0) then + cnt = omp_get_num_threads () + i = 3 + ia(3:5) = 2 + r = 0.5 + ra(1:2) = 2 + d = -1 + da(2:4) = -2 + c = 2.5 + ca(1) = cmplx (-5, 0) + else if (n .eq. 1) then + i = 2 + ia(4:6) = -2 + r = 8 + ra(2:4) = -0.5 + da(1:3) = -1 + c = -3 + ca(2:3) = cmplx (0, -1) + else + ia = 2 + r = 0.5 + ra = 0.25 + d = 2.5 + da = -1 + c = cmplx (0, -1) + ca = cmplx (-1, 0) + end if +!$omp end parallel + if (v) call abort + if (cnt .eq. 3) then + if (i .ne. 6 .or. any (ia .ne. (/4, 4, 8, -16, -16, -8/))) call abort + if (r .ne. 8 .or. any (ra .ne. (/4., -2., -1., -1./))) call abort + if (d .ne. -40 .or. any (da .ne. (/32., -64., -64., 64., -32./))) call abort + if (c .ne. cmplx (0, 15)) call abort + if (ca(1) .ne. cmplx (0, 10)) call abort + if (ca(2) .ne. cmplx (-2, 0) .or. ca(2) .ne. ca(3)) call abort + end if +end diff --git a/libgomp/testsuite/libgomp.fortran/reduction2.f90 b/libgomp/testsuite/libgomp.fortran/reduction2.f90 new file mode 100644 index 00000000000..9bdeb77de85 --- /dev/null +++ b/libgomp/testsuite/libgomp.fortran/reduction2.f90 @@ -0,0 +1,73 @@ +! { dg-do run } +!$ use omp_lib + + logical :: l, la (4), m, ma (4), v + integer :: n, cnt + + l = .true. + la = (/.true., .false., .true., .true./) + m = .false. + ma = (/.false., .false., .false., .true./) + v = .false. + cnt = -1 + +!$omp parallel num_threads (3) private (n) reduction (.or.:v) & +!$omp & reduction (.and.:l, la) reduction (.or.:m, ma) +!$ if (.not. l .or. any (.not. la)) v = .true. +!$ if (m .or. any (ma)) v = .true. + n = omp_get_thread_num () + if (n .eq. 0) then + cnt = omp_get_num_threads () + l = .false. + la(3) = .false. + ma(2) = .true. + else if (n .eq. 1) then + l = .false. + la(4) = .false. + ma(1) = .true. + else + la(3) = .false. + m = .true. + ma(1) = .true. + end if +!$omp end parallel + if (v) call abort + if (cnt .eq. 3) then + if (l .or. any (la .neqv. (/.true., .false., .false., .false./))) call abort + if (.not. m .or. any (ma .neqv. (/.true., .true., .false., .true./))) call abort + end if + + l = .true. + la = (/.true., .false., .true., .true./) + m = .false. + ma = (/.false., .false., .false., .true./) + v = .false. + cnt = -1 + +!$omp parallel num_threads (3) private (n) reduction (.or.:v) & +!$omp & reduction (.eqv.:l, la) reduction (.neqv.:m, ma) +!$ if (.not. l .or. any (.not. la)) v = .true. +!$ if (m .or. any (ma)) v = .true. + n = omp_get_thread_num () + if (n .eq. 0) then + cnt = omp_get_num_threads () + l = .false. + la(3) = .false. + ma(2) = .true. + else if (n .eq. 1) then + l = .false. + la(4) = .false. + ma(1) = .true. + else + la(3) = .false. + m = .true. + ma(1) = .true. + end if +!$omp end parallel + if (v) call abort + if (cnt .eq. 3) then + if (.not. l .or. any (la .neqv. (/.true., .false., .true., .false./))) call abort + if (.not. m .or. any (ma .neqv. (/.false., .true., .false., .true./))) call abort + end if + +end diff --git a/libgomp/testsuite/libgomp.fortran/reduction3.f90 b/libgomp/testsuite/libgomp.fortran/reduction3.f90 new file mode 100644 index 00000000000..a0786eca008 --- /dev/null +++ b/libgomp/testsuite/libgomp.fortran/reduction3.f90 @@ -0,0 +1,103 @@ +! { dg-do run } +!$ use omp_lib + + integer (kind = 4) :: i, ia (6), n, cnt + real :: r, ra (4) + double precision :: d, da (5) + logical :: v + + i = 1 + ia = 2 + r = 3 + ra = 4 + d = 5.5 + da = 6.5 + v = .false. + cnt = -1 + +!$omp parallel num_threads (3) private (n) reduction (.or.:v) & +!$omp & reduction (max:i, ia, r, ra, d, da) +!$ if (i .ne. -2147483648 .or. any (ia .ne. -2147483648)) v = .true. +!$ if (r .ge. -1.0d38 .or. any (ra .ge. -1.0d38)) v = .true. +!$ if (d .ge. -1.0d300 .or. any (da .ge. -1.0d300)) v = .true. + n = omp_get_thread_num () + if (n .eq. 0) then + cnt = omp_get_num_threads () + i = 4 + ia(3:5) = -2 + ia(1) = 7 + r = 5 + ra(1:2) = 6.5 + d = -2.5 + da(2:4) = 8.5 + else if (n .eq. 1) then + i = 2 + ia(4:6) = 5 + r = 1 + ra(2:4) = -1.5 + d = 8.5 + da(1:3) = 2.5 + else + i = 1 + ia = 1 + r = -1 + ra = -1 + d = 1 + da = -1 + end if +!$omp end parallel + if (v) call abort + if (cnt .eq. 3) then + if (i .ne. 4 .or. any (ia .ne. (/7, 2, 2, 5, 5, 5/))) call abort + if (r .ne. 5 .or. any (ra .ne. (/6.5, 6.5, 4., 4./))) call abort + if (d .ne. 8.5 .or. any (da .ne. (/6.5, 8.5, 8.5, 8.5, 6.5/))) call abort + end if + + i = 1 + ia = 2 + r = 3 + ra = 4 + d = 5.5 + da = 6.5 + v = .false. + cnt = -1 + +!$omp parallel num_threads (3) private (n) reduction (.or.:v) & +!$omp & reduction (min:i, ia, r, ra, d, da) +!$ if (i .ne. 2147483647 .or. any (ia .ne. 2147483647)) v = .true. +!$ if (r .le. 1.0d38 .or. any (ra .le. 1.0d38)) v = .true. +!$ if (d .le. 1.0d300 .or. any (da .le. 1.0d300)) v = .true. + n = omp_get_thread_num () + if (n .eq. 0) then + cnt = omp_get_num_threads () + i = 4 + ia(3:5) = -2 + ia(1) = 7 + r = 5 + ra(1:2) = 6.5 + d = -2.5 + da(2:4) = 8.5 + else if (n .eq. 1) then + i = 2 + ia(4:6) = 5 + r = 1 + ra(2:4) = -1.5 + d = 8.5 + da(1:3) = 2.5 + else + i = 1 + ia = 1 + r = -1 + ra = 7 + ra(3) = -8.5 + d = 1 + da(1:4) = 6 + end if +!$omp end parallel + if (v) call abort + if (cnt .eq. 3) then + if (i .ne. 1 .or. any (ia .ne. (/1, 1, -2, -2, -2, 1/))) call abort + if (r .ne. -1 .or. any (ra .ne. (/4., -1.5, -8.5, -1.5/))) call abort + if (d .ne. -2.5 .or. any (da .ne. (/2.5, 2.5, 2.5, 6., 6.5/))) call abort + end if +end diff --git a/libgomp/testsuite/libgomp.fortran/reduction4.f90 b/libgomp/testsuite/libgomp.fortran/reduction4.f90 new file mode 100644 index 00000000000..5a5e852bea7 --- /dev/null +++ b/libgomp/testsuite/libgomp.fortran/reduction4.f90 @@ -0,0 +1,56 @@ +! { dg-do run } +!$ use omp_lib + + integer (kind = 4) :: i, ia (6), j, ja (6), k, ka (6), ta (6), n, cnt, x + logical :: v + + i = Z'ffff0f' + ia = Z'f0ff0f' + j = Z'0f0000' + ja = Z'0f5a00' + k = Z'055aa0' + ka = Z'05a5a5' + v = .false. + cnt = -1 + x = Z'ffffffff' + +!$omp parallel num_threads (3) private (n) reduction (.or.:v) & +!$omp & reduction (iand:i, ia) reduction (ior:j, ja) reduction (ieor:k, ka) +!$ if (i .ne. x .or. any (ia .ne. x)) v = .true. +!$ if (j .ne. 0 .or. any (ja .ne. 0)) v = .true. +!$ if (k .ne. 0 .or. any (ka .ne. 0)) v = .true. + n = omp_get_thread_num () + if (n .eq. 0) then + cnt = omp_get_num_threads () + i = Z'ff7fff' + ia(3:5) = Z'fffff1' + j = Z'078000' + ja(1:3) = 1 + k = Z'78' + ka(3:6) = Z'f0f' + else if (n .eq. 1) then + i = Z'ffff77' + ia(2:5) = Z'ffafff' + j = Z'007800' + ja(2:5) = 8 + k = Z'57' + ka(3:4) = Z'f0108' + else + i = Z'777fff' + ia(1:2) = Z'fffff3' + j = Z'000780' + ja(5:6) = Z'f00' + k = Z'1000' + ka(6:6) = Z'777' + end if +!$omp end parallel + if (v) call abort + if (cnt .eq. 3) then + ta = (/Z'f0ff03', Z'f0af03', Z'f0af01', Z'f0af01', Z'f0af01', Z'f0ff0f'/) + if (i .ne. Z'777f07' .or. any (ia .ne. ta)) call abort + ta = (/Z'f5a01', Z'f5a09', Z'f5a09', Z'f5a08', Z'f5f08', Z'f5f00'/) + if (j .ne. Z'fff80' .or. any (ja .ne. ta)) call abort + ta = (/Z'5a5a5', Z'5a5a5', Z'aaba2', Z'aaba2', Z'5aaaa', Z'5addd'/) + if (k .ne. Z'54a8f' .or. any (ka .ne. ta)) call abort + end if +end diff --git a/libgomp/testsuite/libgomp.fortran/reduction5.f90 b/libgomp/testsuite/libgomp.fortran/reduction5.f90 new file mode 100644 index 00000000000..bfdd43a93fa --- /dev/null +++ b/libgomp/testsuite/libgomp.fortran/reduction5.f90 @@ -0,0 +1,41 @@ +! { dg-do run } + +module reduction5 + intrinsic ior, min, max +end module reduction5 + + call test1 + call test2 +contains + subroutine test1 + use reduction5, bitwise_or => ior + integer :: n + n = Z'f' +!$omp parallel sections num_threads (3) reduction (bitwise_or: n) + n = ior (n, Z'20') +!$omp section + n = bitwise_or (Z'410', n) +!$omp section + n = bitwise_or (n, Z'2000') +!$omp end parallel sections + if (n .ne. Z'243f') call abort + end subroutine + subroutine test2 + use reduction5, min => max, max => min + integer :: m, n + m = 8 + n = 4 +!$omp parallel sections num_threads (3) reduction (min: n) & +!$omp & reduction (max: m) + if (m .gt. 13) m = 13 + if (n .lt. 11) n = 11 +!$omp section + if (m .gt. 5) m = 5 + if (n .lt. 15) n = 15 +!$omp section + if (m .gt. 3) m = 3 + if (n .lt. -1) n = -1 +!$omp end parallel sections + if (m .ne. 3 .or. n .ne. 15) call abort + end subroutine test2 +end diff --git a/libgomp/testsuite/libgomp.fortran/reduction6.f90 b/libgomp/testsuite/libgomp.fortran/reduction6.f90 new file mode 100644 index 00000000000..9f3ec6ca893 --- /dev/null +++ b/libgomp/testsuite/libgomp.fortran/reduction6.f90 @@ -0,0 +1,32 @@ +! { dg-do run } + + integer, dimension (6, 6) :: a + character (36) :: c + integer nthreads + a = 9 + nthreads = -1 + call foo (a (2:4, 3:5), nthreads) + if (nthreads .eq. 3) then + write (c, '(36i1)') a + if (c .ne. '999999999999966699966699966699999999') call abort + end if +contains + subroutine foo (b, nthreads) + use omp_lib + integer, dimension (3:, 5:) :: b + integer :: err, nthreads + b = 0 + err = 0 +!$omp parallel num_threads (3) reduction (+:b) + if (any (b .ne. 0)) then +!$omp atomic + err = err + 1 + end if +!$omp master + nthreads = omp_get_num_threads () +!$omp end master + b = 2 +!$omp end parallel + if (err .gt. 0) call abort + end subroutine foo +end diff --git a/libgomp/testsuite/libgomp.fortran/reference1.f90 b/libgomp/testsuite/libgomp.fortran/reference1.f90 new file mode 100644 index 00000000000..b959e2716b8 --- /dev/null +++ b/libgomp/testsuite/libgomp.fortran/reference1.f90 @@ -0,0 +1,34 @@ +! { dg-do run } +!$ use omp_lib + + integer :: i, j, k + double precision :: d + i = 6 + j = 19 + k = 0 + d = 24.5 + call test (i, j, k, d) + if (i .ne. 38) call abort + if (iand (k, 255) .ne. 0) call abort + if (iand (k, 65280) .eq. 0) then + if (k .ne. 65536 * 4) call abort + end if +contains + subroutine test (i, j, k, d) + integer :: i, j, k + double precision :: d + +!$omp parallel firstprivate (d) private (j) num_threads (4) reduction (+:k) + if (i .ne. 6 .or. d .ne. 24.5 .or. k .ne. 0) k = k + 1 + if (omp_get_num_threads () .ne. 4) k = k + 256 + d = d / 2 + j = 8 + k = k + 65536 +!$omp barrier + if (d .ne. 12.25 .or. j .ne. 8) k = k + 1 +!$omp single + i = i + 32 +!$omp end single nowait +!$omp end parallel + end subroutine test +end diff --git a/libgomp/testsuite/libgomp.fortran/reference2.f90 b/libgomp/testsuite/libgomp.fortran/reference2.f90 new file mode 100644 index 00000000000..1232b6926cb --- /dev/null +++ b/libgomp/testsuite/libgomp.fortran/reference2.f90 @@ -0,0 +1,21 @@ +! { dg-do run } + real, dimension (5) :: b + b = 5 + call foo (b) +contains + subroutine foo (a) + real, dimension (5) :: a + logical :: l + l = .false. +!$omp parallel private (a) reduction (.or.:l) + a = 15 + l = bar (a) +!$omp end parallel + if (l) call abort + end subroutine + function bar (a) + real, dimension (5) :: a + logical :: bar + bar = any (a .ne. 15) + end function +end diff --git a/libgomp/testsuite/libgomp.fortran/retval1.f90 b/libgomp/testsuite/libgomp.fortran/retval1.f90 new file mode 100644 index 00000000000..8bb07f8fce6 --- /dev/null +++ b/libgomp/testsuite/libgomp.fortran/retval1.f90 @@ -0,0 +1,120 @@ +! { dg-do run } + +function f1 () + use omp_lib + real :: f1 + logical :: l + f1 = 6.5 + l = .false. +!$omp parallel firstprivate (f1) num_threads (2) reduction (.or.:l) + l = f1 .ne. 6.5 + if (omp_get_thread_num () .eq. 0) f1 = 8.5 + if (omp_get_thread_num () .eq. 1) f1 = 14.5 +!$omp barrier + l = l .or. (omp_get_thread_num () .eq. 0 .and. f1 .ne. 8.5) + l = l .or. (omp_get_thread_num () .eq. 1 .and. f1 .ne. 14.5) +!$omp end parallel + if (l) call abort + f1 = -2.5 +end function f1 +function f2 () + use omp_lib + real :: f2, e2 + logical :: l +entry e2 () + f2 = 6.5 + l = .false. +!$omp parallel firstprivate (e2) num_threads (2) reduction (.or.:l) + l = e2 .ne. 6.5 + if (omp_get_thread_num () .eq. 0) e2 = 8.5 + if (omp_get_thread_num () .eq. 1) e2 = 14.5 +!$omp barrier + l = l .or. (omp_get_thread_num () .eq. 0 .and. e2 .ne. 8.5) + l = l .or. (omp_get_thread_num () .eq. 1 .and. e2 .ne. 14.5) +!$omp end parallel + if (l) call abort + e2 = 7.5 +end function f2 +function f3 () + use omp_lib + real :: f3, e3 + logical :: l +entry e3 () + f3 = 6.5 + l = .false. +!$omp parallel firstprivate (f3, e3) num_threads (2) reduction (.or.:l) + l = e3 .ne. 6.5 + l = l .or. f3 .ne. 6.5 + if (omp_get_thread_num () .eq. 0) e3 = 8.5 + if (omp_get_thread_num () .eq. 1) e3 = 14.5 + f3 = e3 - 4.5 +!$omp barrier + l = l .or. (omp_get_thread_num () .eq. 0 .and. e3 .ne. 8.5) + l = l .or. (omp_get_thread_num () .eq. 1 .and. e3 .ne. 14.5) + l = l .or. f3 .ne. e3 - 4.5 +!$omp end parallel + if (l) call abort + e3 = 0.5 +end function f3 +function f4 () result (r4) + use omp_lib + real :: r4, s4 + logical :: l +entry e4 () result (s4) + r4 = 6.5 + l = .false. +!$omp parallel firstprivate (r4, s4) num_threads (2) reduction (.or.:l) + l = s4 .ne. 6.5 + l = l .or. r4 .ne. 6.5 + if (omp_get_thread_num () .eq. 0) s4 = 8.5 + if (omp_get_thread_num () .eq. 1) s4 = 14.5 + r4 = s4 - 4.5 +!$omp barrier + l = l .or. (omp_get_thread_num () .eq. 0 .and. s4 .ne. 8.5) + l = l .or. (omp_get_thread_num () .eq. 1 .and. s4 .ne. 14.5) + l = l .or. r4 .ne. s4 - 4.5 +!$omp end parallel + if (l) call abort + s4 = -0.5 +end function f4 +function f5 (is_f5) + use omp_lib + real :: f5 + integer :: e5 + logical :: l, is_f5 +entry e5 (is_f5) + if (is_f5) then + f5 = 6.5 + else + e5 = 8 + end if + l = .false. +!$omp parallel firstprivate (f5, e5) shared (is_f5) num_threads (2) & +!$omp reduction (.or.:l) + l = .not. is_f5 .and. e5 .ne. 8 + l = l .or. (is_f5 .and. f5 .ne. 6.5) + if (omp_get_thread_num () .eq. 0) e5 = 8 + if (omp_get_thread_num () .eq. 1) e5 = 14 + f5 = e5 - 4.5 +!$omp barrier + l = l .or. (omp_get_thread_num () .eq. 0 .and. e5 .ne. 8) + l = l .or. (omp_get_thread_num () .eq. 1 .and. e5 .ne. 14) + l = l .or. f5 .ne. e5 - 4.5 +!$omp end parallel + if (l) call abort + if (is_f5) f5 = -2.5 + if (.not. is_f5) e5 = 8 +end function f5 + + real :: f1, f2, e2, f3, e3, f4, e4, f5 + integer :: e5 + if (f1 () .ne. -2.5) call abort + if (f2 () .ne. 7.5) call abort + if (e2 () .ne. 7.5) call abort + if (f3 () .ne. 0.5) call abort + if (e3 () .ne. 0.5) call abort + if (f4 () .ne. -0.5) call abort + if (e4 () .ne. -0.5) call abort + if (f5 (.true.) .ne. -2.5) call abort + if (e5 (.false.) .ne. 8) call abort +end diff --git a/libgomp/testsuite/libgomp.fortran/sharing1.f90 b/libgomp/testsuite/libgomp.fortran/sharing1.f90 new file mode 100644 index 00000000000..063e7db8357 --- /dev/null +++ b/libgomp/testsuite/libgomp.fortran/sharing1.f90 @@ -0,0 +1,29 @@ +! { dg-do run } + + use omp_lib + integer :: i, j, k + logical :: l + common /b/ i, j + i = 4 + j = 8 + l = .false. +!$omp parallel private (k) firstprivate (i) shared (j) num_threads (2) & +!$omp& reduction (.or.:l) + if (i .ne. 4 .or. j .ne. 8) l = .true. +!$omp barrier + k = omp_get_thread_num () + if (k .eq. 0) then + i = 14 + j = 15 + end if +!$omp barrier + if (k .eq. 1) then + if (i .ne. 4 .or. j .ne. 15) l = .true. + i = 24 + j = 25 + end if +!$omp barrier + if (j .ne. 25 .or. i .ne. (k * 10 + 14)) l = .true. +!$omp end parallel + if (l .or. j .ne. 25) call abort +end diff --git a/libgomp/testsuite/libgomp.fortran/sharing2.f90 b/libgomp/testsuite/libgomp.fortran/sharing2.f90 new file mode 100644 index 00000000000..266dd46fadb --- /dev/null +++ b/libgomp/testsuite/libgomp.fortran/sharing2.f90 @@ -0,0 +1,32 @@ +! { dg-do run } + + use omp_lib + integer :: i, j, k, m, n + logical :: l + equivalence (i, m) + equivalence (j, n) + i = 4 + j = 8 + l = .false. +!$omp parallel private (k) firstprivate (i) shared (j) num_threads (2) & +!$omp& reduction (.or.:l) + l = l .or. i .ne. 4 + l = l .or. j .ne. 8 +!$omp barrier + k = omp_get_thread_num () + if (k .eq. 0) then + i = 14 + j = 15 + end if +!$omp barrier + if (k .eq. 1) then + if (i .ne. 4 .or. j .ne. 15) l = .true. + i = 24 + j = 25 + end if +!$omp barrier + if (j .ne. 25 .or. i .ne. (k * 10 + 14)) l = .true. +!$omp end parallel + if (l) call abort + if (j .ne. 25) call abort +end diff --git a/libgomp/testsuite/libgomp.fortran/threadprivate1.f90 b/libgomp/testsuite/libgomp.fortran/threadprivate1.f90 new file mode 100644 index 00000000000..99a20185509 --- /dev/null +++ b/libgomp/testsuite/libgomp.fortran/threadprivate1.f90 @@ -0,0 +1,19 @@ +! { dg-do run } +! { dg-require-effective-target tls_runtime } + +module threadprivate1 + double precision :: d +!$omp threadprivate (d) +end module threadprivate1 + +!$ use omp_lib + use threadprivate1 + logical :: l + l = .false. +!$omp parallel num_threads (4) reduction (.or.:l) + d = omp_get_thread_num () + 6.5 +!$omp barrier + if (d .ne. omp_get_thread_num () + 6.5) l = .true. +!$omp end parallel + if (l) call abort () +end diff --git a/libgomp/testsuite/libgomp.fortran/threadprivate2.f90 b/libgomp/testsuite/libgomp.fortran/threadprivate2.f90 new file mode 100644 index 00000000000..f3a4af0fc13 --- /dev/null +++ b/libgomp/testsuite/libgomp.fortran/threadprivate2.f90 @@ -0,0 +1,94 @@ +! { dg-do run } +! { dg-require-effective-target tls_runtime } + +module threadprivate2 + integer, dimension(:,:), allocatable :: foo +!$omp threadprivate (foo) +end module threadprivate2 + + use omp_lib + use threadprivate2 + + integer, dimension(:), pointer :: bar1 + integer, dimension(2), target :: bar2 + common /thrc/ bar1, bar2 +!$omp threadprivate (/thrc/) + + integer, dimension(:), pointer, save :: bar3 => NULL() +!$omp threadprivate (bar3) + + logical :: l + type tt + integer :: a + integer :: b = 32 + end type tt + type (tt), save :: baz +!$omp threadprivate (baz) + + l = .false. + call omp_set_dynamic (.false.) + call omp_set_num_threads (4) + +!$omp parallel num_threads (4) reduction (.or.:l) + l = allocated (foo) + allocate (foo (6 + omp_get_thread_num (), 3)) + l = l.or..not.allocated (foo) + l = l.or.size (foo).ne.(18 + 3 * omp_get_thread_num ()) + foo = omp_get_thread_num () + 1 + + bar2 = omp_get_thread_num () + l = l.or.associated (bar3) + bar1 => bar2 + l = l.or..not.associated (bar1) + l = l.or..not.associated (bar1, bar2) + l = l.or.any (bar1.ne.omp_get_thread_num ()) + nullify (bar1) + l = l.or.associated (bar1) + allocate (bar3 (4)) + l = l.or..not.associated (bar3) + bar3 = omp_get_thread_num () - 2 + + l = l.or.(baz%b.ne.32) + baz%a = omp_get_thread_num () * 2 + baz%b = omp_get_thread_num () * 2 + 1 +!$omp end parallel + + if (l) call abort + if (.not.allocated (foo)) call abort + if (size (foo).ne.18) call abort + if (any (foo.ne.1)) call abort + + if (associated (bar1)) call abort + if (.not.associated (bar3)) call abort + if (any (bar3 .ne. -2)) call abort + deallocate (bar3) + if (associated (bar3)) call abort + +!$omp parallel num_threads (4) reduction (.or.:l) + l = l.or..not.allocated (foo) + l = l.or.size (foo).ne.(18 + 3 * omp_get_thread_num ()) + l = l.or.any (foo.ne.(omp_get_thread_num () + 1)) + if (omp_get_thread_num () .ne. 0) then + deallocate (foo) + l = l.or.allocated (foo) + end if + + l = l.or.associated (bar1) + if (omp_get_thread_num () .ne. 0) then + l = l.or..not.associated (bar3) + l = l.or.any (bar3 .ne. omp_get_thread_num () - 2) + deallocate (bar3) + end if + l = l.or.associated (bar3) + + l = l.or.(baz%a.ne.(omp_get_thread_num () * 2)) + l = l.or.(baz%b.ne.(omp_get_thread_num () * 2 + 1)) +!$omp end parallel + + if (l) call abort + if (.not.allocated (foo)) call abort + if (size (foo).ne.18) call abort + if (any (foo.ne.1)) call abort + deallocate (foo) + if (allocated (foo)) call abort +end diff --git a/libgomp/testsuite/libgomp.fortran/threadprivate3.f90 b/libgomp/testsuite/libgomp.fortran/threadprivate3.f90 new file mode 100644 index 00000000000..d20a6520a8a --- /dev/null +++ b/libgomp/testsuite/libgomp.fortran/threadprivate3.f90 @@ -0,0 +1,106 @@ +! { dg-do run } +! { dg-require-effective-target tls_runtime } + +module threadprivate3 + integer, dimension(:,:), pointer :: foo => NULL() +!$omp threadprivate (foo) +end module threadprivate3 + + use omp_lib + use threadprivate3 + + integer, dimension(:), pointer :: bar1 + integer, dimension(2), target :: bar2, var + common /thrc/ bar1, bar2 +!$omp threadprivate (/thrc/) + + integer, dimension(:), pointer, save :: bar3 => NULL() +!$omp threadprivate (bar3) + + logical :: l + type tt + integer :: a + integer :: b = 32 + end type tt + type (tt), save :: baz +!$omp threadprivate (baz) + + l = .false. + call omp_set_dynamic (.false.) + call omp_set_num_threads (4) + var = 6 + +!$omp parallel num_threads (4) reduction (.or.:l) + bar2 = omp_get_thread_num () + l = associated (bar3) + bar1 => bar2 + l = l.or..not.associated (bar1) + l = l.or..not.associated (bar1, bar2) + l = l.or.any (bar1.ne.omp_get_thread_num ()) + nullify (bar1) + l = l.or.associated (bar1) + allocate (bar3 (4)) + l = l.or..not.associated (bar3) + bar3 = omp_get_thread_num () - 2 + if (omp_get_thread_num () .ne. 0) then + deallocate (bar3) + if (associated (bar3)) call abort + else + bar1 => var + end if + bar2 = omp_get_thread_num () * 6 + 130 + + l = l.or.(baz%b.ne.32) + baz%a = omp_get_thread_num () * 2 + baz%b = omp_get_thread_num () * 2 + 1 +!$omp end parallel + + if (l) call abort + if (.not.associated (bar1)) call abort + if (any (bar1.ne.6)) call abort + if (.not.associated (bar3)) call abort + if (any (bar3 .ne. -2)) call abort + deallocate (bar3) + if (associated (bar3)) call abort + + allocate (bar3 (10)) + bar3 = 17 + +!$omp parallel copyin (bar1, bar2, bar3, baz) num_threads (4) & +!$omp& reduction (.or.:l) + l = l.or..not.associated (bar1) + l = l.or.any (bar1.ne.6) + l = l.or.any (bar2.ne.130) + l = l.or..not.associated (bar3) + l = l.or.size (bar3).ne.10 + l = l.or.any (bar3.ne.17) + allocate (bar1 (4)) + bar1 = omp_get_thread_num () + bar2 = omp_get_thread_num () + 8 + + l = l.or.(baz%a.ne.0) + l = l.or.(baz%b.ne.1) + baz%a = omp_get_thread_num () * 3 + 4 + baz%b = omp_get_thread_num () * 3 + 5 + +!$omp barrier + if (omp_get_thread_num () .eq. 0) then + deallocate (bar3) + end if + bar3 => bar2 +!$omp barrier + + l = l.or..not.associated (bar1) + l = l.or..not.associated (bar3) + l = l.or.any (bar1.ne.omp_get_thread_num ()) + l = l.or.size (bar1).ne.4 + l = l.or.any (bar2.ne.omp_get_thread_num () + 8) + l = l.or.any (bar3.ne.omp_get_thread_num () + 8) + l = l.or.size (bar3).ne.2 + + l = l.or.(baz%a .ne. omp_get_thread_num () * 3 + 4) + l = l.or.(baz%b .ne. omp_get_thread_num () * 3 + 5) +!$omp end parallel + + if (l) call abort +end diff --git a/libgomp/testsuite/libgomp.fortran/vla1.f90 b/libgomp/testsuite/libgomp.fortran/vla1.f90 new file mode 100644 index 00000000000..c22165ee0a1 --- /dev/null +++ b/libgomp/testsuite/libgomp.fortran/vla1.f90 @@ -0,0 +1,185 @@ +! { dg-do run } + + call test +contains + subroutine check (x, y, l) + integer :: x, y + logical :: l + l = l .or. x .ne. y + end subroutine check + + subroutine foo (c, d, e, f, g, h, i, j, k, n) + use omp_lib + integer :: n + character (len = *) :: c + character (len = n) :: d + integer, dimension (2, 3:5, n) :: e + integer, dimension (2, 3:n, n) :: f + character (len = *), dimension (5, 3:n) :: g + character (len = n), dimension (5, 3:n) :: h + real, dimension (:, :, :) :: i + double precision, dimension (3:, 5:, 7:) :: j + integer, dimension (:, :, :) :: k + logical :: l + integer :: p, q, r + character (len = n) :: s + integer, dimension (2, 3:5, n) :: t + integer, dimension (2, 3:n, n) :: u + character (len = n), dimension (5, 3:n) :: v + character (len = 2 * n + 24) :: w + integer :: x + character (len = 1) :: y + s = 'PQRSTUV' + forall (p = 1:2, q = 3:5, r = 1:7) t(p, q, r) = -10 + p - q + 2 * r + forall (p = 1:2, q = 3:7, r = 1:7) u(p, q, r) = 30 - p + q - 2 * r + forall (p = 1:5, q = 3:7, p + q .le. 8) v(p, q) = '_+|/Oo_' + forall (p = 1:5, q = 3:7, p + q .gt. 8) v(p, q) = '///|||!' + l = .false. +!$omp parallel default (none) firstprivate (c, d, e, f, g, h, i, j, k) & +!$omp & firstprivate (s, t, u, v) reduction (.or.:l) num_threads (6) & +!$omp private (p, q, r, w, x, y) + l = l .or. c .ne. 'abcdefghijkl' + l = l .or. d .ne. 'ABCDEFG' + l = l .or. s .ne. 'PQRSTUV' + do 100, p = 1, 2 + do 100, q = 3, 7 + do 100, r = 1, 7 + if (q .lt. 6) l = l .or. e(p, q, r) .ne. 5 + p + q + 2 * r + l = l .or. f(p, q, r) .ne. 25 + p + q + 2 * r + if (r .lt. 6 .and. q + r .le. 8) l = l .or. g(r, q) .ne. '0123456789AB' + if (r .lt. 6 .and. q + r .gt. 8) l = l .or. g(r, q) .ne. '9876543210ZY' + if (r .lt. 6 .and. q + r .le. 8) l = l .or. h(r, q) .ne. '0123456' + if (r .lt. 6 .and. q + r .gt. 8) l = l .or. h(r, q) .ne. '9876543' + if (q .lt. 6) l = l .or. t(p, q, r) .ne. -10 + p - q + 2 * r + l = l .or. u(p, q, r) .ne. 30 - p + q - 2 * r + if (r .lt. 6 .and. q + r .le. 8) l = l .or. v(r, q) .ne. '_+|/Oo_' + if (r .lt. 6 .and. q + r .gt. 8) l = l .or. v(r, q) .ne. '///|||!' +100 continue + do 101, p = 3, 5 + do 101, q = 2, 6 + do 101, r = 1, 7 + l = l .or. i(p - 2, q - 1, r) .ne. 7.5 * p * q * r + l = l .or. j(p, q + 3, r + 6) .ne. 9.5 * p * q * r +101 continue + do 102, p = 1, 5 + do 102, q = 4, 6 + l = l .or. k(p, 1, q - 3) .ne. 19 + p + 7 + 3 * q +102 continue + x = omp_get_thread_num () + w = '' + if (x .eq. 0) w = 'thread0thr_number_0THREAD0THR_NUMBER_0' + if (x .eq. 1) w = 'thread1thr_number_1THREAD1THR_NUMBER_1' + if (x .eq. 2) w = 'thread2thr_number_2THREAD2THR_NUMBER_2' + if (x .eq. 3) w = 'thread3thr_number_3THREAD3THR_NUMBER_3' + if (x .eq. 4) w = 'thread4thr_number_4THREAD4THR_NUMBER_4' + if (x .eq. 5) w = 'thread5thr_number_5THREAD5THR_NUMBER_5' + c = w(8:19) + d = w(1:7) + forall (p = 1:2, q = 3:5, r = 1:7) e(p, q, r) = 5 * x + p + q + 2 * r + forall (p = 1:2, q = 3:7, r = 1:7) f(p, q, r) = 25 * x + p + q + 2 * r + forall (p = 1:5, q = 3:7, p + q .le. 8) g(p, q) = w(8:19) + forall (p = 1:5, q = 3:7, p + q .gt. 8) g(p, q) = w(27:38) + forall (p = 1:5, q = 3:7, p + q .le. 8) h(p, q) = w(1:7) + forall (p = 1:5, q = 3:7, p + q .gt. 8) h(p, q) = w(20:26) + forall (p = 3:5, q = 2:6, r = 1:7) i(p - 2, q - 1, r) = (7.5 + x) * p * q * r + forall (p = 3:5, q = 2:6, r = 1:7) j(p, q + 3, r + 6) = (9.5 + x) * p * q * r + forall (p = 1:5, q = 7:7, r = 4:6) k(p, q - 6, r - 3) = 19 + x + p + q + 3 * r + s = w(20:26) + forall (p = 1:2, q = 3:5, r = 1:7) t(p, q, r) = -10 + x + p - q + 2 * r + forall (p = 1:2, q = 3:7, r = 1:7) u(p, q, r) = 30 - x - p + q - 2 * r + forall (p = 1:5, q = 3:7, p + q .le. 8) v(p, q) = w(1:7) + forall (p = 1:5, q = 3:7, p + q .gt. 8) v(p, q) = w(20:26) +!$omp barrier + y = '' + if (x .eq. 0) y = '0' + if (x .eq. 1) y = '1' + if (x .eq. 2) y = '2' + if (x .eq. 3) y = '3' + if (x .eq. 4) y = '4' + if (x .eq. 5) y = '5' + l = l .or. w(7:7) .ne. y + l = l .or. w(19:19) .ne. y + l = l .or. w(26:26) .ne. y + l = l .or. w(38:38) .ne. y + l = l .or. c .ne. w(8:19) + l = l .or. d .ne. w(1:7) + l = l .or. s .ne. w(20:26) + do 103, p = 1, 2 + do 103, q = 3, 7 + do 103, r = 1, 7 + if (q .lt. 6) l = l .or. e(p, q, r) .ne. 5 * x + p + q + 2 * r + l = l .or. f(p, q, r) .ne. 25 * x + p + q + 2 * r + if (r .lt. 6 .and. q + r .le. 8) l = l .or. g(r, q) .ne. w(8:19) + if (r .lt. 6 .and. q + r .gt. 8) l = l .or. g(r, q) .ne. w(27:38) + if (r .lt. 6 .and. q + r .le. 8) l = l .or. h(r, q) .ne. w(1:7) + if (r .lt. 6 .and. q + r .gt. 8) l = l .or. h(r, q) .ne. w(20:26) + if (q .lt. 6) l = l .or. t(p, q, r) .ne. -10 + x + p - q + 2 * r + l = l .or. u(p, q, r) .ne. 30 - x - p + q - 2 * r + if (r .lt. 6 .and. q + r .le. 8) l = l .or. v(r, q) .ne. w(1:7) + if (r .lt. 6 .and. q + r .gt. 8) l = l .or. v(r, q) .ne. w(20:26) +103 continue + do 104, p = 3, 5 + do 104, q = 2, 6 + do 104, r = 1, 7 + l = l .or. i(p - 2, q - 1, r) .ne. (7.5 + x) * p * q * r + l = l .or. j(p, q + 3, r + 6) .ne. (9.5 + x) * p * q * r +104 continue + do 105, p = 1, 5 + do 105, q = 4, 6 + l = l .or. k(p, 1, q - 3) .ne. 19 + x + p + 7 + 3 * q +105 continue + call check (size (e, 1), 2, l) + call check (size (e, 2), 3, l) + call check (size (e, 3), 7, l) + call check (size (e), 42, l) + call check (size (f, 1), 2, l) + call check (size (f, 2), 5, l) + call check (size (f, 3), 7, l) + call check (size (f), 70, l) + call check (size (g, 1), 5, l) + call check (size (g, 2), 5, l) + call check (size (g), 25, l) + call check (size (h, 1), 5, l) + call check (size (h, 2), 5, l) + call check (size (h), 25, l) + call check (size (i, 1), 3, l) + call check (size (i, 2), 5, l) + call check (size (i, 3), 7, l) + call check (size (i), 105, l) + call check (size (j, 1), 4, l) + call check (size (j, 2), 5, l) + call check (size (j, 3), 7, l) + call check (size (j), 140, l) + call check (size (k, 1), 5, l) + call check (size (k, 2), 1, l) + call check (size (k, 3), 3, l) + call check (size (k), 15, l) +!$omp end parallel + if (l) call abort + end subroutine foo + + subroutine test + character (len = 12) :: c + character (len = 7) :: d + integer, dimension (2, 3:5, 7) :: e + integer, dimension (2, 3:7, 7) :: f + character (len = 12), dimension (5, 3:7) :: g + character (len = 7), dimension (5, 3:7) :: h + real, dimension (3:5, 2:6, 1:7) :: i + double precision, dimension (3:6, 2:6, 1:7) :: j + integer, dimension (1:5, 7:7, 4:6) :: k + integer :: p, q, r + c = 'abcdefghijkl' + d = 'ABCDEFG' + forall (p = 1:2, q = 3:5, r = 1:7) e(p, q, r) = 5 + p + q + 2 * r + forall (p = 1:2, q = 3:7, r = 1:7) f(p, q, r) = 25 + p + q + 2 * r + forall (p = 1:5, q = 3:7, p + q .le. 8) g(p, q) = '0123456789AB' + forall (p = 1:5, q = 3:7, p + q .gt. 8) g(p, q) = '9876543210ZY' + forall (p = 1:5, q = 3:7, p + q .le. 8) h(p, q) = '0123456' + forall (p = 1:5, q = 3:7, p + q .gt. 8) h(p, q) = '9876543' + forall (p = 3:5, q = 2:6, r = 1:7) i(p, q, r) = 7.5 * p * q * r + forall (p = 3:6, q = 2:6, r = 1:7) j(p, q, r) = 9.5 * p * q * r + forall (p = 1:5, q = 7:7, r = 4:6) k(p, q, r) = 19 + p + q + 3 * r + call foo (c, d, e, f, g, h, i, j, k, 7) + end subroutine test +end diff --git a/libgomp/testsuite/libgomp.fortran/vla2.f90 b/libgomp/testsuite/libgomp.fortran/vla2.f90 new file mode 100644 index 00000000000..a9510fd385a --- /dev/null +++ b/libgomp/testsuite/libgomp.fortran/vla2.f90 @@ -0,0 +1,142 @@ +! { dg-do run } + + call test +contains + subroutine check (x, y, l) + integer :: x, y + logical :: l + l = l .or. x .ne. y + end subroutine check + + subroutine foo (c, d, e, f, g, h, i, j, k, n) + use omp_lib + integer :: n + character (len = *) :: c + character (len = n) :: d + integer, dimension (2, 3:5, n) :: e + integer, dimension (2, 3:n, n) :: f + character (len = *), dimension (5, 3:n) :: g + character (len = n), dimension (5, 3:n) :: h + real, dimension (:, :, :) :: i + double precision, dimension (3:, 5:, 7:) :: j + integer, dimension (:, :, :) :: k + logical :: l + integer :: p, q, r + character (len = n) :: s + integer, dimension (2, 3:5, n) :: t + integer, dimension (2, 3:n, n) :: u + character (len = n), dimension (5, 3:n) :: v + character (len = 2 * n + 24) :: w + integer :: x + character (len = 1) :: y + l = .false. +!$omp parallel default (none) private (c, d, e, f, g, h, i, j, k) & +!$omp & private (s, t, u, v) reduction (.or.:l) num_threads (6) & +!$omp private (p, q, r, w, x, y) + x = omp_get_thread_num () + w = '' + if (x .eq. 0) w = 'thread0thr_number_0THREAD0THR_NUMBER_0' + if (x .eq. 1) w = 'thread1thr_number_1THREAD1THR_NUMBER_1' + if (x .eq. 2) w = 'thread2thr_number_2THREAD2THR_NUMBER_2' + if (x .eq. 3) w = 'thread3thr_number_3THREAD3THR_NUMBER_3' + if (x .eq. 4) w = 'thread4thr_number_4THREAD4THR_NUMBER_4' + if (x .eq. 5) w = 'thread5thr_number_5THREAD5THR_NUMBER_5' + c = w(8:19) + d = w(1:7) + forall (p = 1:2, q = 3:5, r = 1:7) e(p, q, r) = 5 * x + p + q + 2 * r + forall (p = 1:2, q = 3:7, r = 1:7) f(p, q, r) = 25 * x + p + q + 2 * r + forall (p = 1:5, q = 3:7, p + q .le. 8) g(p, q) = w(8:19) + forall (p = 1:5, q = 3:7, p + q .gt. 8) g(p, q) = w(27:38) + forall (p = 1:5, q = 3:7, p + q .le. 8) h(p, q) = w(1:7) + forall (p = 1:5, q = 3:7, p + q .gt. 8) h(p, q) = w(20:26) + forall (p = 3:5, q = 2:6, r = 1:7) i(p - 2, q - 1, r) = (7.5 + x) * p * q * r + forall (p = 3:5, q = 2:6, r = 1:7) j(p, q + 3, r + 6) = (9.5 + x) * p * q * r + forall (p = 1:5, q = 7:7, r = 4:6) k(p, q - 6, r - 3) = 19 + x + p + q + 3 * r + s = w(20:26) + forall (p = 1:2, q = 3:5, r = 1:7) t(p, q, r) = -10 + x + p - q + 2 * r + forall (p = 1:2, q = 3:7, r = 1:7) u(p, q, r) = 30 - x - p + q - 2 * r + forall (p = 1:5, q = 3:7, p + q .le. 8) v(p, q) = w(1:7) + forall (p = 1:5, q = 3:7, p + q .gt. 8) v(p, q) = w(20:26) +!$omp barrier + y = '' + if (x .eq. 0) y = '0' + if (x .eq. 1) y = '1' + if (x .eq. 2) y = '2' + if (x .eq. 3) y = '3' + if (x .eq. 4) y = '4' + if (x .eq. 5) y = '5' + l = l .or. w(7:7) .ne. y + l = l .or. w(19:19) .ne. y + l = l .or. w(26:26) .ne. y + l = l .or. w(38:38) .ne. y + l = l .or. c .ne. w(8:19) + l = l .or. d .ne. w(1:7) + l = l .or. s .ne. w(20:26) + do 103, p = 1, 2 + do 103, q = 3, 7 + do 103, r = 1, 7 + if (q .lt. 6) l = l .or. e(p, q, r) .ne. 5 * x + p + q + 2 * r + l = l .or. f(p, q, r) .ne. 25 * x + p + q + 2 * r + if (r .lt. 6 .and. q + r .le. 8) l = l .or. g(r, q) .ne. w(8:19) + if (r .lt. 6 .and. q + r .gt. 8) l = l .or. g(r, q) .ne. w(27:38) + if (r .lt. 6 .and. q + r .le. 8) l = l .or. h(r, q) .ne. w(1:7) + if (r .lt. 6 .and. q + r .gt. 8) l = l .or. h(r, q) .ne. w(20:26) + if (q .lt. 6) l = l .or. t(p, q, r) .ne. -10 + x + p - q + 2 * r + l = l .or. u(p, q, r) .ne. 30 - x - p + q - 2 * r + if (r .lt. 6 .and. q + r .le. 8) l = l .or. v(r, q) .ne. w(1:7) + if (r .lt. 6 .and. q + r .gt. 8) l = l .or. v(r, q) .ne. w(20:26) +103 continue + do 104, p = 3, 5 + do 104, q = 2, 6 + do 104, r = 1, 7 + l = l .or. i(p - 2, q - 1, r) .ne. (7.5 + x) * p * q * r + l = l .or. j(p, q + 3, r + 6) .ne. (9.5 + x) * p * q * r +104 continue + do 105, p = 1, 5 + do 105, q = 4, 6 + l = l .or. k(p, 1, q - 3) .ne. 19 + x + p + 7 + 3 * q +105 continue + call check (size (e, 1), 2, l) + call check (size (e, 2), 3, l) + call check (size (e, 3), 7, l) + call check (size (e), 42, l) + call check (size (f, 1), 2, l) + call check (size (f, 2), 5, l) + call check (size (f, 3), 7, l) + call check (size (f), 70, l) + call check (size (g, 1), 5, l) + call check (size (g, 2), 5, l) + call check (size (g), 25, l) + call check (size (h, 1), 5, l) + call check (size (h, 2), 5, l) + call check (size (h), 25, l) + call check (size (i, 1), 3, l) + call check (size (i, 2), 5, l) + call check (size (i, 3), 7, l) + call check (size (i), 105, l) + call check (size (j, 1), 4, l) + call check (size (j, 2), 5, l) + call check (size (j, 3), 7, l) + call check (size (j), 140, l) + call check (size (k, 1), 5, l) + call check (size (k, 2), 1, l) + call check (size (k, 3), 3, l) + call check (size (k), 15, l) +!$omp end parallel + if (l) call abort + end subroutine foo + + subroutine test + character (len = 12) :: c + character (len = 7) :: d + integer, dimension (2, 3:5, 7) :: e + integer, dimension (2, 3:7, 7) :: f + character (len = 12), dimension (5, 3:7) :: g + character (len = 7), dimension (5, 3:7) :: h + real, dimension (3:5, 2:6, 1:7) :: i + double precision, dimension (3:6, 2:6, 1:7) :: j + integer, dimension (1:5, 7:7, 4:6) :: k + integer :: p, q, r + call foo (c, d, e, f, g, h, i, j, k, 7) + end subroutine test +end diff --git a/libgomp/testsuite/libgomp.fortran/vla3.f90 b/libgomp/testsuite/libgomp.fortran/vla3.f90 new file mode 100644 index 00000000000..bfafc4f7d05 --- /dev/null +++ b/libgomp/testsuite/libgomp.fortran/vla3.f90 @@ -0,0 +1,191 @@ +! { dg-do run } + + call test +contains + subroutine check (x, y, l) + integer :: x, y + logical :: l + l = l .or. x .ne. y + end subroutine check + + subroutine foo (c, d, e, f, g, h, i, j, k, n) + use omp_lib + integer :: n + character (len = *) :: c + character (len = n) :: d + integer, dimension (2, 3:5, n) :: e + integer, dimension (2, 3:n, n) :: f + character (len = *), dimension (5, 3:n) :: g + character (len = n), dimension (5, 3:n) :: h + real, dimension (:, :, :) :: i + double precision, dimension (3:, 5:, 7:) :: j + integer, dimension (:, :, :) :: k + logical :: l + integer :: p, q, r + character (len = n) :: s + integer, dimension (2, 3:5, n) :: t + integer, dimension (2, 3:n, n) :: u + character (len = n), dimension (5, 3:n) :: v + character (len = 2 * n + 24) :: w + integer :: x, z + character (len = 1) :: y + s = 'PQRSTUV' + forall (p = 1:2, q = 3:5, r = 1:7) t(p, q, r) = -10 + p - q + 2 * r + forall (p = 1:2, q = 3:7, r = 1:7) u(p, q, r) = 30 - p + q - 2 * r + forall (p = 1:5, q = 3:7, p + q .le. 8) v(p, q) = '_+|/Oo_' + forall (p = 1:5, q = 3:7, p + q .gt. 8) v(p, q) = '///|||!' + l = .false. +!$omp parallel default (none) shared (c, d, e, f, g, h, i, j, k) & +!$omp & shared (s, t, u, v) reduction (.or.:l) num_threads (6) & +!$omp private (p, q, r, w, x, y) + l = l .or. c .ne. 'abcdefghijkl' + l = l .or. d .ne. 'ABCDEFG' + l = l .or. s .ne. 'PQRSTUV' + do 100, p = 1, 2 + do 100, q = 3, 7 + do 100, r = 1, 7 + if (q .lt. 6) l = l .or. e(p, q, r) .ne. 5 + p + q + 2 * r + l = l .or. f(p, q, r) .ne. 25 + p + q + 2 * r + if (r .lt. 6 .and. q + r .le. 8) l = l .or. g(r, q) .ne. '0123456789AB' + if (r .lt. 6 .and. q + r .gt. 8) l = l .or. g(r, q) .ne. '9876543210ZY' + if (r .lt. 6 .and. q + r .le. 8) l = l .or. h(r, q) .ne. '0123456' + if (r .lt. 6 .and. q + r .gt. 8) l = l .or. h(r, q) .ne. '9876543' + if (q .lt. 6) l = l .or. t(p, q, r) .ne. -10 + p - q + 2 * r + l = l .or. u(p, q, r) .ne. 30 - p + q - 2 * r + if (r .lt. 6 .and. q + r .le. 8) l = l .or. v(r, q) .ne. '_+|/Oo_' + if (r .lt. 6 .and. q + r .gt. 8) l = l .or. v(r, q) .ne. '///|||!' +100 continue + do 101, p = 3, 5 + do 101, q = 2, 6 + do 101, r = 1, 7 + l = l .or. i(p - 2, q - 1, r) .ne. 7.5 * p * q * r + l = l .or. j(p, q + 3, r + 6) .ne. 9.5 * p * q * r +101 continue + do 102, p = 1, 5 + do 102, q = 4, 6 + l = l .or. k(p, 1, q - 3) .ne. 19 + p + 7 + 3 * q +102 continue + do 110 z = 0, omp_get_num_threads () - 1 +!$omp barrier + x = omp_get_thread_num () + w = '' + if (z .eq. 0) w = 'thread0thr_number_0THREAD0THR_NUMBER_0' + if (z .eq. 1) w = 'thread1thr_number_1THREAD1THR_NUMBER_1' + if (z .eq. 2) w = 'thread2thr_number_2THREAD2THR_NUMBER_2' + if (z .eq. 3) w = 'thread3thr_number_3THREAD3THR_NUMBER_3' + if (z .eq. 4) w = 'thread4thr_number_4THREAD4THR_NUMBER_4' + if (z .eq. 5) w = 'thread5thr_number_5THREAD5THR_NUMBER_5' + if (x .eq. z) then + c = w(8:19) + d = w(1:7) + forall (p = 1:2, q = 3:5, r = 1:7) e(p, q, r) = 5 * x + p + q + 2 * r + forall (p = 1:2, q = 3:7, r = 1:7) f(p, q, r) = 25 * x + p + q + 2 * r + forall (p = 1:5, q = 3:7, p + q .le. 8) g(p, q) = w(8:19) + forall (p = 1:5, q = 3:7, p + q .gt. 8) g(p, q) = w(27:38) + forall (p = 1:5, q = 3:7, p + q .le. 8) h(p, q) = w(1:7) + forall (p = 1:5, q = 3:7, p + q .gt. 8) h(p, q) = w(20:26) + forall (p = 3:5, q = 2:6, r = 1:7) i(p - 2, q - 1, r) = (7.5 + x) * p * q * r + forall (p = 3:5, q = 2:6, r = 1:7) j(p, q + 3, r + 6) = (9.5 + x) * p * q * r + forall (p = 1:5, q = 7:7, r = 4:6) k(p, q - 6, r - 3) = 19 + x + p + q + 3 * r + s = w(20:26) + forall (p = 1:2, q = 3:5, r = 1:7) t(p, q, r) = -10 + x + p - q + 2 * r + forall (p = 1:2, q = 3:7, r = 1:7) u(p, q, r) = 30 - x - p + q - 2 * r + forall (p = 1:5, q = 3:7, p + q .le. 8) v(p, q) = w(1:7) + forall (p = 1:5, q = 3:7, p + q .gt. 8) v(p, q) = w(20:26) + end if +!$omp barrier + x = z + y = '' + if (x .eq. 0) y = '0' + if (x .eq. 1) y = '1' + if (x .eq. 2) y = '2' + if (x .eq. 3) y = '3' + if (x .eq. 4) y = '4' + if (x .eq. 5) y = '5' + l = l .or. w(7:7) .ne. y + l = l .or. w(19:19) .ne. y + l = l .or. w(26:26) .ne. y + l = l .or. w(38:38) .ne. y + l = l .or. c .ne. w(8:19) + l = l .or. d .ne. w(1:7) + l = l .or. s .ne. w(20:26) + do 103, p = 1, 2 + do 103, q = 3, 7 + do 103, r = 1, 7 + if (q .lt. 6) l = l .or. e(p, q, r) .ne. 5 * x + p + q + 2 * r + l = l .or. f(p, q, r) .ne. 25 * x + p + q + 2 * r + if (r .lt. 6 .and. q + r .le. 8) l = l .or. g(r, q) .ne. w(8:19) + if (r .lt. 6 .and. q + r .gt. 8) l = l .or. g(r, q) .ne. w(27:38) + if (r .lt. 6 .and. q + r .le. 8) l = l .or. h(r, q) .ne. w(1:7) + if (r .lt. 6 .and. q + r .gt. 8) l = l .or. h(r, q) .ne. w(20:26) + if (q .lt. 6) l = l .or. t(p, q, r) .ne. -10 + x + p - q + 2 * r + l = l .or. u(p, q, r) .ne. 30 - x - p + q - 2 * r + if (r .lt. 6 .and. q + r .le. 8) l = l .or. v(r, q) .ne. w(1:7) + if (r .lt. 6 .and. q + r .gt. 8) l = l .or. v(r, q) .ne. w(20:26) +103 continue + do 104, p = 3, 5 + do 104, q = 2, 6 + do 104, r = 1, 7 + l = l .or. i(p - 2, q - 1, r) .ne. (7.5 + x) * p * q * r + l = l .or. j(p, q + 3, r + 6) .ne. (9.5 + x) * p * q * r +104 continue + do 105, p = 1, 5 + do 105, q = 4, 6 + l = l .or. k(p, 1, q - 3) .ne. 19 + x + p + 7 + 3 * q +105 continue +110 continue + call check (size (e, 1), 2, l) + call check (size (e, 2), 3, l) + call check (size (e, 3), 7, l) + call check (size (e), 42, l) + call check (size (f, 1), 2, l) + call check (size (f, 2), 5, l) + call check (size (f, 3), 7, l) + call check (size (f), 70, l) + call check (size (g, 1), 5, l) + call check (size (g, 2), 5, l) + call check (size (g), 25, l) + call check (size (h, 1), 5, l) + call check (size (h, 2), 5, l) + call check (size (h), 25, l) + call check (size (i, 1), 3, l) + call check (size (i, 2), 5, l) + call check (size (i, 3), 7, l) + call check (size (i), 105, l) + call check (size (j, 1), 4, l) + call check (size (j, 2), 5, l) + call check (size (j, 3), 7, l) + call check (size (j), 140, l) + call check (size (k, 1), 5, l) + call check (size (k, 2), 1, l) + call check (size (k, 3), 3, l) + call check (size (k), 15, l) +!$omp end parallel + if (l) call abort + end subroutine foo + + subroutine test + character (len = 12) :: c + character (len = 7) :: d + integer, dimension (2, 3:5, 7) :: e + integer, dimension (2, 3:7, 7) :: f + character (len = 12), dimension (5, 3:7) :: g + character (len = 7), dimension (5, 3:7) :: h + real, dimension (3:5, 2:6, 1:7) :: i + double precision, dimension (3:6, 2:6, 1:7) :: j + integer, dimension (1:5, 7:7, 4:6) :: k + integer :: p, q, r + c = 'abcdefghijkl' + d = 'ABCDEFG' + forall (p = 1:2, q = 3:5, r = 1:7) e(p, q, r) = 5 + p + q + 2 * r + forall (p = 1:2, q = 3:7, r = 1:7) f(p, q, r) = 25 + p + q + 2 * r + forall (p = 1:5, q = 3:7, p + q .le. 8) g(p, q) = '0123456789AB' + forall (p = 1:5, q = 3:7, p + q .gt. 8) g(p, q) = '9876543210ZY' + forall (p = 1:5, q = 3:7, p + q .le. 8) h(p, q) = '0123456' + forall (p = 1:5, q = 3:7, p + q .gt. 8) h(p, q) = '9876543' + forall (p = 3:5, q = 2:6, r = 1:7) i(p, q, r) = 7.5 * p * q * r + forall (p = 3:6, q = 2:6, r = 1:7) j(p, q, r) = 9.5 * p * q * r + forall (p = 1:5, q = 7:7, r = 4:6) k(p, q, r) = 19 + p + q + 3 * r + call foo (c, d, e, f, g, h, i, j, k, 7) + end subroutine test +end diff --git a/libgomp/testsuite/libgomp.fortran/vla4.f90 b/libgomp/testsuite/libgomp.fortran/vla4.f90 new file mode 100644 index 00000000000..58caabc6248 --- /dev/null +++ b/libgomp/testsuite/libgomp.fortran/vla4.f90 @@ -0,0 +1,228 @@ +! { dg-do run } + + call test +contains + subroutine check (x, y, l) + integer :: x, y + logical :: l + l = l .or. x .ne. y + end subroutine check + + subroutine foo (c, d, e, f, g, h, i, j, k, n) + use omp_lib + integer :: n + character (len = *) :: c + character (len = n) :: d + integer, dimension (2, 3:5, n) :: e + integer, dimension (2, 3:n, n) :: f + character (len = *), dimension (5, 3:n) :: g + character (len = n), dimension (5, 3:n) :: h + real, dimension (:, :, :) :: i + double precision, dimension (3:, 5:, 7:) :: j + integer, dimension (:, :, :) :: k + logical :: l + integer :: p, q, r + character (len = n) :: s + integer, dimension (2, 3:5, n) :: t + integer, dimension (2, 3:n, n) :: u + character (len = n), dimension (5, 3:n) :: v + character (len = 2 * n + 24) :: w + integer :: x, z, z2 + character (len = 1) :: y + s = 'PQRSTUV' + forall (p = 1:2, q = 3:5, r = 1:7) t(p, q, r) = -10 + p - q + 2 * r + forall (p = 1:2, q = 3:7, r = 1:7) u(p, q, r) = 30 - p + q - 2 * r + forall (p = 1:5, q = 3:7, p + q .le. 8) v(p, q) = '_+|/Oo_' + forall (p = 1:5, q = 3:7, p + q .gt. 8) v(p, q) = '///|||!' + l = .false. + call omp_set_dynamic (.false.) + call omp_set_num_threads (6) +!$omp parallel do default (none) firstprivate (c, d, e, f, g, h, i, j, k) & +!$omp & firstprivate (s, t, u, v) reduction (.or.:l) num_threads (6) & +!$omp private (p, q, r, w, x, y) schedule (static) shared (z2) & +!$omp lastprivate (c, d, e, f, g, h, i, j, k, s, t, u, v) + do 110 z = 0, omp_get_num_threads () - 1 + if (omp_get_thread_num () .eq. 0) z2 = omp_get_num_threads () + l = l .or. c .ne. 'abcdefghijkl' + l = l .or. d .ne. 'ABCDEFG' + l = l .or. s .ne. 'PQRSTUV' + do 100, p = 1, 2 + do 100, q = 3, 7 + do 100, r = 1, 7 + if (q .lt. 6) l = l .or. e(p, q, r) .ne. 5 + p + q + 2 * r + l = l .or. f(p, q, r) .ne. 25 + p + q + 2 * r + if (r .lt. 6 .and. q + r .le. 8) l = l .or. g(r, q) .ne. '0123456789AB' + if (r .lt. 6 .and. q + r .gt. 8) l = l .or. g(r, q) .ne. '9876543210ZY' + if (r .lt. 6 .and. q + r .le. 8) l = l .or. h(r, q) .ne. '0123456' + if (r .lt. 6 .and. q + r .gt. 8) l = l .or. h(r, q) .ne. '9876543' + if (q .lt. 6) l = l .or. t(p, q, r) .ne. -10 + p - q + 2 * r + l = l .or. u(p, q, r) .ne. 30 - p + q - 2 * r + if (r .lt. 6 .and. q + r .le. 8) l = l .or. v(r, q) .ne. '_+|/Oo_' + if (r .lt. 6 .and. q + r .gt. 8) l = l .or. v(r, q) .ne. '///|||!' +100 continue + do 101, p = 3, 5 + do 101, q = 2, 6 + do 101, r = 1, 7 + l = l .or. i(p - 2, q - 1, r) .ne. 7.5 * p * q * r + l = l .or. j(p, q + 3, r + 6) .ne. 9.5 * p * q * r +101 continue + do 102, p = 1, 5 + do 102, q = 4, 6 + l = l .or. k(p, 1, q - 3) .ne. 19 + p + 7 + 3 * q +102 continue + x = omp_get_thread_num () + w = '' + if (x .eq. 0) w = 'thread0thr_number_0THREAD0THR_NUMBER_0' + if (x .eq. 1) w = 'thread1thr_number_1THREAD1THR_NUMBER_1' + if (x .eq. 2) w = 'thread2thr_number_2THREAD2THR_NUMBER_2' + if (x .eq. 3) w = 'thread3thr_number_3THREAD3THR_NUMBER_3' + if (x .eq. 4) w = 'thread4thr_number_4THREAD4THR_NUMBER_4' + if (x .eq. 5) w = 'thread5thr_number_5THREAD5THR_NUMBER_5' + c = w(8:19) + d = w(1:7) + forall (p = 1:2, q = 3:5, r = 1:7) e(p, q, r) = 5 * x + p + q + 2 * r + forall (p = 1:2, q = 3:7, r = 1:7) f(p, q, r) = 25 * x + p + q + 2 * r + forall (p = 1:5, q = 3:7, p + q .le. 8) g(p, q) = w(8:19) + forall (p = 1:5, q = 3:7, p + q .gt. 8) g(p, q) = w(27:38) + forall (p = 1:5, q = 3:7, p + q .le. 8) h(p, q) = w(1:7) + forall (p = 1:5, q = 3:7, p + q .gt. 8) h(p, q) = w(20:26) + forall (p = 3:5, q = 2:6, r = 1:7) i(p - 2, q - 1, r) = (7.5 + x) * p * q * r + forall (p = 3:5, q = 2:6, r = 1:7) j(p, q + 3, r + 6) = (9.5 + x) * p * q * r + forall (p = 1:5, q = 7:7, r = 4:6) k(p, q - 6, r - 3) = 19 + x + p + q + 3 * r + s = w(20:26) + forall (p = 1:2, q = 3:5, r = 1:7) t(p, q, r) = -10 + x + p - q + 2 * r + forall (p = 1:2, q = 3:7, r = 1:7) u(p, q, r) = 30 - x - p + q - 2 * r + forall (p = 1:5, q = 3:7, p + q .le. 8) v(p, q) = w(1:7) + forall (p = 1:5, q = 3:7, p + q .gt. 8) v(p, q) = w(20:26) +!$omp barrier + y = '' + if (x .eq. 0) y = '0' + if (x .eq. 1) y = '1' + if (x .eq. 2) y = '2' + if (x .eq. 3) y = '3' + if (x .eq. 4) y = '4' + if (x .eq. 5) y = '5' + l = l .or. w(7:7) .ne. y + l = l .or. w(19:19) .ne. y + l = l .or. w(26:26) .ne. y + l = l .or. w(38:38) .ne. y + l = l .or. c .ne. w(8:19) + l = l .or. d .ne. w(1:7) + l = l .or. s .ne. w(20:26) + do 103, p = 1, 2 + do 103, q = 3, 7 + do 103, r = 1, 7 + if (q .lt. 6) l = l .or. e(p, q, r) .ne. 5 * x + p + q + 2 * r + l = l .or. f(p, q, r) .ne. 25 * x + p + q + 2 * r + if (r .lt. 6 .and. q + r .le. 8) l = l .or. g(r, q) .ne. w(8:19) + if (r .lt. 6 .and. q + r .gt. 8) l = l .or. g(r, q) .ne. w(27:38) + if (r .lt. 6 .and. q + r .le. 8) l = l .or. h(r, q) .ne. w(1:7) + if (r .lt. 6 .and. q + r .gt. 8) l = l .or. h(r, q) .ne. w(20:26) + if (q .lt. 6) l = l .or. t(p, q, r) .ne. -10 + x + p - q + 2 * r + l = l .or. u(p, q, r) .ne. 30 - x - p + q - 2 * r + if (r .lt. 6 .and. q + r .le. 8) l = l .or. v(r, q) .ne. w(1:7) + if (r .lt. 6 .and. q + r .gt. 8) l = l .or. v(r, q) .ne. w(20:26) +103 continue + do 104, p = 3, 5 + do 104, q = 2, 6 + do 104, r = 1, 7 + l = l .or. i(p - 2, q - 1, r) .ne. (7.5 + x) * p * q * r + l = l .or. j(p, q + 3, r + 6) .ne. (9.5 + x) * p * q * r +104 continue + do 105, p = 1, 5 + do 105, q = 4, 6 + l = l .or. k(p, 1, q - 3) .ne. 19 + x + p + 7 + 3 * q +105 continue + call check (size (e, 1), 2, l) + call check (size (e, 2), 3, l) + call check (size (e, 3), 7, l) + call check (size (e), 42, l) + call check (size (f, 1), 2, l) + call check (size (f, 2), 5, l) + call check (size (f, 3), 7, l) + call check (size (f), 70, l) + call check (size (g, 1), 5, l) + call check (size (g, 2), 5, l) + call check (size (g), 25, l) + call check (size (h, 1), 5, l) + call check (size (h, 2), 5, l) + call check (size (h), 25, l) + call check (size (i, 1), 3, l) + call check (size (i, 2), 5, l) + call check (size (i, 3), 7, l) + call check (size (i), 105, l) + call check (size (j, 1), 4, l) + call check (size (j, 2), 5, l) + call check (size (j, 3), 7, l) + call check (size (j), 140, l) + call check (size (k, 1), 5, l) + call check (size (k, 2), 1, l) + call check (size (k, 3), 3, l) + call check (size (k), 15, l) +110 continue +!$omp end parallel do + if (l) call abort + if (z2 == 6) then + x = 5 + w = 'thread5thr_number_5THREAD5THR_NUMBER_5' + y = '5' + l = l .or. w(7:7) .ne. y + l = l .or. w(19:19) .ne. y + l = l .or. w(26:26) .ne. y + l = l .or. w(38:38) .ne. y + l = l .or. c .ne. w(8:19) + l = l .or. d .ne. w(1:7) + l = l .or. s .ne. w(20:26) + do 113, p = 1, 2 + do 113, q = 3, 7 + do 113, r = 1, 7 + if (q .lt. 6) l = l .or. e(p, q, r) .ne. 5 * x + p + q + 2 * r + l = l .or. f(p, q, r) .ne. 25 * x + p + q + 2 * r + if (r .lt. 6 .and. q + r .le. 8) l = l .or. g(r, q) .ne. w(8:19) + if (r .lt. 6 .and. q + r .gt. 8) l = l .or. g(r, q) .ne. w(27:38) + if (r .lt. 6 .and. q + r .le. 8) l = l .or. h(r, q) .ne. w(1:7) + if (r .lt. 6 .and. q + r .gt. 8) l = l .or. h(r, q) .ne. w(20:26) + if (q .lt. 6) l = l .or. t(p, q, r) .ne. -10 + x + p - q + 2 * r + l = l .or. u(p, q, r) .ne. 30 - x - p + q - 2 * r + if (r .lt. 6 .and. q + r .le. 8) l = l .or. v(r, q) .ne. w(1:7) + if (r .lt. 6 .and. q + r .gt. 8) l = l .or. v(r, q) .ne. w(20:26) +113 continue + do 114, p = 3, 5 + do 114, q = 2, 6 + do 114, r = 1, 7 + l = l .or. i(p - 2, q - 1, r) .ne. (7.5 + x) * p * q * r + l = l .or. j(p, q + 3, r + 6) .ne. (9.5 + x) * p * q * r +114 continue + do 115, p = 1, 5 + do 115, q = 4, 6 + l = l .or. k(p, 1, q - 3) .ne. 19 + x + p + 7 + 3 * q +115 continue + if (l) call abort + end if + end subroutine foo + + subroutine test + character (len = 12) :: c + character (len = 7) :: d + integer, dimension (2, 3:5, 7) :: e + integer, dimension (2, 3:7, 7) :: f + character (len = 12), dimension (5, 3:7) :: g + character (len = 7), dimension (5, 3:7) :: h + real, dimension (3:5, 2:6, 1:7) :: i + double precision, dimension (3:6, 2:6, 1:7) :: j + integer, dimension (1:5, 7:7, 4:6) :: k + integer :: p, q, r + c = 'abcdefghijkl' + d = 'ABCDEFG' + forall (p = 1:2, q = 3:5, r = 1:7) e(p, q, r) = 5 + p + q + 2 * r + forall (p = 1:2, q = 3:7, r = 1:7) f(p, q, r) = 25 + p + q + 2 * r + forall (p = 1:5, q = 3:7, p + q .le. 8) g(p, q) = '0123456789AB' + forall (p = 1:5, q = 3:7, p + q .gt. 8) g(p, q) = '9876543210ZY' + forall (p = 1:5, q = 3:7, p + q .le. 8) h(p, q) = '0123456' + forall (p = 1:5, q = 3:7, p + q .gt. 8) h(p, q) = '9876543' + forall (p = 3:5, q = 2:6, r = 1:7) i(p, q, r) = 7.5 * p * q * r + forall (p = 3:6, q = 2:6, r = 1:7) j(p, q, r) = 9.5 * p * q * r + forall (p = 1:5, q = 7:7, r = 4:6) k(p, q, r) = 19 + p + q + 3 * r + call foo (c, d, e, f, g, h, i, j, k, 7) + end subroutine test +end diff --git a/libgomp/testsuite/libgomp.fortran/vla5.f90 b/libgomp/testsuite/libgomp.fortran/vla5.f90 new file mode 100644 index 00000000000..5c889f9923a --- /dev/null +++ b/libgomp/testsuite/libgomp.fortran/vla5.f90 @@ -0,0 +1,200 @@ +! { dg-do run } + + call test +contains + subroutine check (x, y, l) + integer :: x, y + logical :: l + l = l .or. x .ne. y + end subroutine check + + subroutine foo (c, d, e, f, g, h, i, j, k, n) + use omp_lib + integer :: n + character (len = *) :: c + character (len = n) :: d + integer, dimension (2, 3:5, n) :: e + integer, dimension (2, 3:n, n) :: f + character (len = *), dimension (5, 3:n) :: g + character (len = n), dimension (5, 3:n) :: h + real, dimension (:, :, :) :: i + double precision, dimension (3:, 5:, 7:) :: j + integer, dimension (:, :, :) :: k + logical :: l + integer :: p, q, r + character (len = n) :: s + integer, dimension (2, 3:5, n) :: t + integer, dimension (2, 3:n, n) :: u + character (len = n), dimension (5, 3:n) :: v + character (len = 2 * n + 24) :: w + integer :: x, z, z2 + character (len = 1) :: y + s = 'PQRSTUV' + forall (p = 1:2, q = 3:5, r = 1:7) t(p, q, r) = -10 + p - q + 2 * r + forall (p = 1:2, q = 3:7, r = 1:7) u(p, q, r) = 30 - p + q - 2 * r + forall (p = 1:5, q = 3:7, p + q .le. 8) v(p, q) = '_+|/Oo_' + forall (p = 1:5, q = 3:7, p + q .gt. 8) v(p, q) = '///|||!' + l = .false. + call omp_set_dynamic (.false.) + call omp_set_num_threads (6) +!$omp parallel do default (none) lastprivate (c, d, e, f, g, h, i, j, k) & +!$omp & lastprivate (s, t, u, v) reduction (.or.:l) num_threads (6) & +!$omp private (p, q, r, w, x, y) schedule (static) shared (z2) + do 110 z = 0, omp_get_num_threads () - 1 + if (omp_get_thread_num () .eq. 0) z2 = omp_get_num_threads () + x = omp_get_thread_num () + w = '' + if (x .eq. 0) w = 'thread0thr_number_0THREAD0THR_NUMBER_0' + if (x .eq. 1) w = 'thread1thr_number_1THREAD1THR_NUMBER_1' + if (x .eq. 2) w = 'thread2thr_number_2THREAD2THR_NUMBER_2' + if (x .eq. 3) w = 'thread3thr_number_3THREAD3THR_NUMBER_3' + if (x .eq. 4) w = 'thread4thr_number_4THREAD4THR_NUMBER_4' + if (x .eq. 5) w = 'thread5thr_number_5THREAD5THR_NUMBER_5' + c = w(8:19) + d = w(1:7) + forall (p = 1:2, q = 3:5, r = 1:7) e(p, q, r) = 5 * x + p + q + 2 * r + forall (p = 1:2, q = 3:7, r = 1:7) f(p, q, r) = 25 * x + p + q + 2 * r + forall (p = 1:5, q = 3:7, p + q .le. 8) g(p, q) = w(8:19) + forall (p = 1:5, q = 3:7, p + q .gt. 8) g(p, q) = w(27:38) + forall (p = 1:5, q = 3:7, p + q .le. 8) h(p, q) = w(1:7) + forall (p = 1:5, q = 3:7, p + q .gt. 8) h(p, q) = w(20:26) + forall (p = 3:5, q = 2:6, r = 1:7) i(p - 2, q - 1, r) = (7.5 + x) * p * q * r + forall (p = 3:5, q = 2:6, r = 1:7) j(p, q + 3, r + 6) = (9.5 + x) * p * q * r + forall (p = 1:5, q = 7:7, r = 4:6) k(p, q - 6, r - 3) = 19 + x + p + q + 3 * r + s = w(20:26) + forall (p = 1:2, q = 3:5, r = 1:7) t(p, q, r) = -10 + x + p - q + 2 * r + forall (p = 1:2, q = 3:7, r = 1:7) u(p, q, r) = 30 - x - p + q - 2 * r + forall (p = 1:5, q = 3:7, p + q .le. 8) v(p, q) = w(1:7) + forall (p = 1:5, q = 3:7, p + q .gt. 8) v(p, q) = w(20:26) +!$omp barrier + y = '' + if (x .eq. 0) y = '0' + if (x .eq. 1) y = '1' + if (x .eq. 2) y = '2' + if (x .eq. 3) y = '3' + if (x .eq. 4) y = '4' + if (x .eq. 5) y = '5' + l = l .or. w(7:7) .ne. y + l = l .or. w(19:19) .ne. y + l = l .or. w(26:26) .ne. y + l = l .or. w(38:38) .ne. y + l = l .or. c .ne. w(8:19) + l = l .or. d .ne. w(1:7) + l = l .or. s .ne. w(20:26) + do 103, p = 1, 2 + do 103, q = 3, 7 + do 103, r = 1, 7 + if (q .lt. 6) l = l .or. e(p, q, r) .ne. 5 * x + p + q + 2 * r + l = l .or. f(p, q, r) .ne. 25 * x + p + q + 2 * r + if (r .lt. 6 .and. q + r .le. 8) l = l .or. g(r, q) .ne. w(8:19) + if (r .lt. 6 .and. q + r .gt. 8) l = l .or. g(r, q) .ne. w(27:38) + if (r .lt. 6 .and. q + r .le. 8) l = l .or. h(r, q) .ne. w(1:7) + if (r .lt. 6 .and. q + r .gt. 8) l = l .or. h(r, q) .ne. w(20:26) + if (q .lt. 6) l = l .or. t(p, q, r) .ne. -10 + x + p - q + 2 * r + l = l .or. u(p, q, r) .ne. 30 - x - p + q - 2 * r + if (r .lt. 6 .and. q + r .le. 8) l = l .or. v(r, q) .ne. w(1:7) + if (r .lt. 6 .and. q + r .gt. 8) l = l .or. v(r, q) .ne. w(20:26) +103 continue + do 104, p = 3, 5 + do 104, q = 2, 6 + do 104, r = 1, 7 + l = l .or. i(p - 2, q - 1, r) .ne. (7.5 + x) * p * q * r + l = l .or. j(p, q + 3, r + 6) .ne. (9.5 + x) * p * q * r +104 continue + do 105, p = 1, 5 + do 105, q = 4, 6 + l = l .or. k(p, 1, q - 3) .ne. 19 + x + p + 7 + 3 * q +105 continue + call check (size (e, 1), 2, l) + call check (size (e, 2), 3, l) + call check (size (e, 3), 7, l) + call check (size (e), 42, l) + call check (size (f, 1), 2, l) + call check (size (f, 2), 5, l) + call check (size (f, 3), 7, l) + call check (size (f), 70, l) + call check (size (g, 1), 5, l) + call check (size (g, 2), 5, l) + call check (size (g), 25, l) + call check (size (h, 1), 5, l) + call check (size (h, 2), 5, l) + call check (size (h), 25, l) + call check (size (i, 1), 3, l) + call check (size (i, 2), 5, l) + call check (size (i, 3), 7, l) + call check (size (i), 105, l) + call check (size (j, 1), 4, l) + call check (size (j, 2), 5, l) + call check (size (j, 3), 7, l) + call check (size (j), 140, l) + call check (size (k, 1), 5, l) + call check (size (k, 2), 1, l) + call check (size (k, 3), 3, l) + call check (size (k), 15, l) +110 continue +!$omp end parallel do + if (l) call abort + if (z2 == 6) then + x = 5 + w = 'thread5thr_number_5THREAD5THR_NUMBER_5' + y = '5' + l = l .or. w(7:7) .ne. y + l = l .or. w(19:19) .ne. y + l = l .or. w(26:26) .ne. y + l = l .or. w(38:38) .ne. y + l = l .or. c .ne. w(8:19) + l = l .or. d .ne. w(1:7) + l = l .or. s .ne. w(20:26) + do 113, p = 1, 2 + do 113, q = 3, 7 + do 113, r = 1, 7 + if (q .lt. 6) l = l .or. e(p, q, r) .ne. 5 * x + p + q + 2 * r + l = l .or. f(p, q, r) .ne. 25 * x + p + q + 2 * r + if (r .lt. 6 .and. q + r .le. 8) l = l .or. g(r, q) .ne. w(8:19) + if (r .lt. 6 .and. q + r .gt. 8) l = l .or. g(r, q) .ne. w(27:38) + if (r .lt. 6 .and. q + r .le. 8) l = l .or. h(r, q) .ne. w(1:7) + if (r .lt. 6 .and. q + r .gt. 8) l = l .or. h(r, q) .ne. w(20:26) + if (q .lt. 6) l = l .or. t(p, q, r) .ne. -10 + x + p - q + 2 * r + l = l .or. u(p, q, r) .ne. 30 - x - p + q - 2 * r + if (r .lt. 6 .and. q + r .le. 8) l = l .or. v(r, q) .ne. w(1:7) + if (r .lt. 6 .and. q + r .gt. 8) l = l .or. v(r, q) .ne. w(20:26) +113 continue + do 114, p = 3, 5 + do 114, q = 2, 6 + do 114, r = 1, 7 + l = l .or. i(p - 2, q - 1, r) .ne. (7.5 + x) * p * q * r + l = l .or. j(p, q + 3, r + 6) .ne. (9.5 + x) * p * q * r +114 continue + do 115, p = 1, 5 + do 115, q = 4, 6 + l = l .or. k(p, 1, q - 3) .ne. 19 + x + p + 7 + 3 * q +115 continue + if (l) call abort + end if + end subroutine foo + + subroutine test + character (len = 12) :: c + character (len = 7) :: d + integer, dimension (2, 3:5, 7) :: e + integer, dimension (2, 3:7, 7) :: f + character (len = 12), dimension (5, 3:7) :: g + character (len = 7), dimension (5, 3:7) :: h + real, dimension (3:5, 2:6, 1:7) :: i + double precision, dimension (3:6, 2:6, 1:7) :: j + integer, dimension (1:5, 7:7, 4:6) :: k + integer :: p, q, r + c = 'abcdefghijkl' + d = 'ABCDEFG' + forall (p = 1:2, q = 3:5, r = 1:7) e(p, q, r) = 5 + p + q + 2 * r + forall (p = 1:2, q = 3:7, r = 1:7) f(p, q, r) = 25 + p + q + 2 * r + forall (p = 1:5, q = 3:7, p + q .le. 8) g(p, q) = '0123456789AB' + forall (p = 1:5, q = 3:7, p + q .gt. 8) g(p, q) = '9876543210ZY' + forall (p = 1:5, q = 3:7, p + q .le. 8) h(p, q) = '0123456' + forall (p = 1:5, q = 3:7, p + q .gt. 8) h(p, q) = '9876543' + forall (p = 3:5, q = 2:6, r = 1:7) i(p, q, r) = 7.5 * p * q * r + forall (p = 3:6, q = 2:6, r = 1:7) j(p, q, r) = 9.5 * p * q * r + forall (p = 1:5, q = 7:7, r = 4:6) k(p, q, r) = 19 + p + q + 3 * r + call foo (c, d, e, f, g, h, i, j, k, 7) + end subroutine test +end diff --git a/libgomp/testsuite/libgomp.fortran/vla6.f90 b/libgomp/testsuite/libgomp.fortran/vla6.f90 new file mode 100644 index 00000000000..bb9c4916d40 --- /dev/null +++ b/libgomp/testsuite/libgomp.fortran/vla6.f90 @@ -0,0 +1,191 @@ +! { dg-do run } + + call test +contains + subroutine check (x, y, l) + integer :: x, y + logical :: l + l = l .or. x .ne. y + end subroutine check + + subroutine foo (c, d, e, f, g, h, i, j, k, n) + use omp_lib + integer :: n + character (len = *) :: c + character (len = n) :: d + integer, dimension (2, 3:5, n) :: e + integer, dimension (2, 3:n, n) :: f + character (len = *), dimension (5, 3:n) :: g + character (len = n), dimension (5, 3:n) :: h + real, dimension (:, :, :) :: i + double precision, dimension (3:, 5:, 7:) :: j + integer, dimension (:, :, :) :: k + logical :: l + integer :: p, q, r + character (len = n) :: s + integer, dimension (2, 3:5, n) :: t + integer, dimension (2, 3:n, n) :: u + character (len = n), dimension (5, 3:n) :: v + character (len = 2 * n + 24) :: w + integer :: x, z + character (len = 1) :: y + l = .false. +!$omp parallel default (none) private (c, d, e, f, g, h, i, j, k) & +!$omp & private (s, t, u, v) reduction (.or.:l) num_threads (6) & +!$omp private (p, q, r, w, x, y) shared (z) + x = omp_get_thread_num () + w = '' + if (x .eq. 0) w = 'thread0thr_number_0THREAD0THR_NUMBER_0' + if (x .eq. 1) w = 'thread1thr_number_1THREAD1THR_NUMBER_1' + if (x .eq. 2) w = 'thread2thr_number_2THREAD2THR_NUMBER_2' + if (x .eq. 3) w = 'thread3thr_number_3THREAD3THR_NUMBER_3' + if (x .eq. 4) w = 'thread4thr_number_4THREAD4THR_NUMBER_4' + if (x .eq. 5) w = 'thread5thr_number_5THREAD5THR_NUMBER_5' + c = w(8:19) + d = w(1:7) + forall (p = 1:2, q = 3:5, r = 1:7) e(p, q, r) = 5 * x + p + q + 2 * r + forall (p = 1:2, q = 3:7, r = 1:7) f(p, q, r) = 25 * x + p + q + 2 * r + forall (p = 1:5, q = 3:7, p + q .le. 8) g(p, q) = w(8:19) + forall (p = 1:5, q = 3:7, p + q .gt. 8) g(p, q) = w(27:38) + forall (p = 1:5, q = 3:7, p + q .le. 8) h(p, q) = w(1:7) + forall (p = 1:5, q = 3:7, p + q .gt. 8) h(p, q) = w(20:26) + forall (p = 3:5, q = 2:6, r = 1:7) i(p - 2, q - 1, r) = (7.5 + x) * p * q * r + forall (p = 3:5, q = 2:6, r = 1:7) j(p, q + 3, r + 6) = (9.5 + x) * p * q * r + forall (p = 1:5, q = 7:7, r = 4:6) k(p, q - 6, r - 3) = 19 + x + p + q + 3 * r + s = w(20:26) + forall (p = 1:2, q = 3:5, r = 1:7) t(p, q, r) = -10 + x + p - q + 2 * r + forall (p = 1:2, q = 3:7, r = 1:7) u(p, q, r) = 30 - x - p + q - 2 * r + forall (p = 1:5, q = 3:7, p + q .le. 8) v(p, q) = w(1:7) + forall (p = 1:5, q = 3:7, p + q .gt. 8) v(p, q) = w(20:26) +!$omp barrier + y = '' + if (x .eq. 0) y = '0' + if (x .eq. 1) y = '1' + if (x .eq. 2) y = '2' + if (x .eq. 3) y = '3' + if (x .eq. 4) y = '4' + if (x .eq. 5) y = '5' + l = l .or. w(7:7) .ne. y + l = l .or. w(19:19) .ne. y + l = l .or. w(26:26) .ne. y + l = l .or. w(38:38) .ne. y + l = l .or. c .ne. w(8:19) + l = l .or. d .ne. w(1:7) + l = l .or. s .ne. w(20:26) + do 103, p = 1, 2 + do 103, q = 3, 7 + do 103, r = 1, 7 + if (q .lt. 6) l = l .or. e(p, q, r) .ne. 5 * x + p + q + 2 * r + l = l .or. f(p, q, r) .ne. 25 * x + p + q + 2 * r + if (r .lt. 6 .and. q + r .le. 8) l = l .or. g(r, q) .ne. w(8:19) + if (r .lt. 6 .and. q + r .gt. 8) l = l .or. g(r, q) .ne. w(27:38) + if (r .lt. 6 .and. q + r .le. 8) l = l .or. h(r, q) .ne. w(1:7) + if (r .lt. 6 .and. q + r .gt. 8) l = l .or. h(r, q) .ne. w(20:26) + if (q .lt. 6) l = l .or. t(p, q, r) .ne. -10 + x + p - q + 2 * r + l = l .or. u(p, q, r) .ne. 30 - x - p + q - 2 * r + if (r .lt. 6 .and. q + r .le. 8) l = l .or. v(r, q) .ne. w(1:7) + if (r .lt. 6 .and. q + r .gt. 8) l = l .or. v(r, q) .ne. w(20:26) +103 continue + do 104, p = 3, 5 + do 104, q = 2, 6 + do 104, r = 1, 7 + l = l .or. i(p - 2, q - 1, r) .ne. (7.5 + x) * p * q * r + l = l .or. j(p, q + 3, r + 6) .ne. (9.5 + x) * p * q * r +104 continue + do 105, p = 1, 5 + do 105, q = 4, 6 + l = l .or. k(p, 1, q - 3) .ne. 19 + x + p + 7 + 3 * q +105 continue + call check (size (e, 1), 2, l) + call check (size (e, 2), 3, l) + call check (size (e, 3), 7, l) + call check (size (e), 42, l) + call check (size (f, 1), 2, l) + call check (size (f, 2), 5, l) + call check (size (f, 3), 7, l) + call check (size (f), 70, l) + call check (size (g, 1), 5, l) + call check (size (g, 2), 5, l) + call check (size (g), 25, l) + call check (size (h, 1), 5, l) + call check (size (h, 2), 5, l) + call check (size (h), 25, l) + call check (size (i, 1), 3, l) + call check (size (i, 2), 5, l) + call check (size (i, 3), 7, l) + call check (size (i), 105, l) + call check (size (j, 1), 4, l) + call check (size (j, 2), 5, l) + call check (size (j, 3), 7, l) + call check (size (j), 140, l) + call check (size (k, 1), 5, l) + call check (size (k, 2), 1, l) + call check (size (k, 3), 3, l) + call check (size (k), 15, l) +!$omp single + z = omp_get_thread_num () +!$omp end single copyprivate (c, d, e, f, g, h, i, j, k, s, t, u, v) + w = '' + x = z + if (x .eq. 0) w = 'thread0thr_number_0THREAD0THR_NUMBER_0' + if (x .eq. 1) w = 'thread1thr_number_1THREAD1THR_NUMBER_1' + if (x .eq. 2) w = 'thread2thr_number_2THREAD2THR_NUMBER_2' + if (x .eq. 3) w = 'thread3thr_number_3THREAD3THR_NUMBER_3' + if (x .eq. 4) w = 'thread4thr_number_4THREAD4THR_NUMBER_4' + if (x .eq. 5) w = 'thread5thr_number_5THREAD5THR_NUMBER_5' + y = '' + if (x .eq. 0) y = '0' + if (x .eq. 1) y = '1' + if (x .eq. 2) y = '2' + if (x .eq. 3) y = '3' + if (x .eq. 4) y = '4' + if (x .eq. 5) y = '5' + l = l .or. w(7:7) .ne. y + l = l .or. w(19:19) .ne. y + l = l .or. w(26:26) .ne. y + l = l .or. w(38:38) .ne. y + l = l .or. c .ne. w(8:19) + l = l .or. d .ne. w(1:7) + l = l .or. s .ne. w(20:26) + do 113, p = 1, 2 + do 113, q = 3, 7 + do 113, r = 1, 7 + if (q .lt. 6) l = l .or. e(p, q, r) .ne. 5 * x + p + q + 2 * r + l = l .or. f(p, q, r) .ne. 25 * x + p + q + 2 * r + if (r .lt. 6 .and. q + r .le. 8) l = l .or. g(r, q) .ne. w(8:19) + if (r .lt. 6 .and. q + r .gt. 8) l = l .or. g(r, q) .ne. w(27:38) + if (r .lt. 6 .and. q + r .le. 8) l = l .or. h(r, q) .ne. w(1:7) + if (r .lt. 6 .and. q + r .gt. 8) l = l .or. h(r, q) .ne. w(20:26) + if (q .lt. 6) l = l .or. t(p, q, r) .ne. -10 + x + p - q + 2 * r + l = l .or. u(p, q, r) .ne. 30 - x - p + q - 2 * r + if (r .lt. 6 .and. q + r .le. 8) l = l .or. v(r, q) .ne. w(1:7) + if (r .lt. 6 .and. q + r .gt. 8) l = l .or. v(r, q) .ne. w(20:26) +113 continue + do 114, p = 3, 5 + do 114, q = 2, 6 + do 114, r = 1, 7 + l = l .or. i(p - 2, q - 1, r) .ne. (7.5 + x) * p * q * r + l = l .or. j(p, q + 3, r + 6) .ne. (9.5 + x) * p * q * r +114 continue + do 115, p = 1, 5 + do 115, q = 4, 6 + l = l .or. k(p, 1, q - 3) .ne. 19 + x + p + 7 + 3 * q +115 continue +!$omp end parallel + if (l) call abort + end subroutine foo + + subroutine test + character (len = 12) :: c + character (len = 7) :: d + integer, dimension (2, 3:5, 7) :: e + integer, dimension (2, 3:7, 7) :: f + character (len = 12), dimension (5, 3:7) :: g + character (len = 7), dimension (5, 3:7) :: h + real, dimension (3:5, 2:6, 1:7) :: i + double precision, dimension (3:6, 2:6, 1:7) :: j + integer, dimension (1:5, 7:7, 4:6) :: k + integer :: p, q, r + call foo (c, d, e, f, g, h, i, j, k, 7) + end subroutine test +end diff --git a/libgomp/testsuite/libgomp.fortran/vla7.f90 b/libgomp/testsuite/libgomp.fortran/vla7.f90 new file mode 100644 index 00000000000..29a6696443a --- /dev/null +++ b/libgomp/testsuite/libgomp.fortran/vla7.f90 @@ -0,0 +1,143 @@ +! { dg-do run } +! { dg-options "-w" } + + character (6) :: c, f2 + character (6) :: d(2) + c = f1 (6) + if (c .ne. 'opqrst') call abort + c = f2 (6) + if (c .ne. '_/!!/_') call abort + d = f3 (6) + if (d(1) .ne. 'opqrst' .or. d(2) .ne. 'a') call abort + d = f4 (6) + if (d(1) .ne. 'Opqrst' .or. d(2) .ne. 'A') call abort +contains + function f1 (n) + use omp_lib + character (n) :: f1 + logical :: l + f1 = 'abcdef' + l = .false. +!$omp parallel firstprivate (f1) reduction (.or.:l) num_threads (2) + l = f1 .ne. 'abcdef' + if (omp_get_thread_num () .eq. 0) f1 = 'ijklmn' + if (omp_get_thread_num () .eq. 1) f1 = 'IJKLMN' +!$omp barrier + l = l .or. (omp_get_thread_num () .eq. 0 .and. f1 .ne. 'ijklmn') + l = l .or. (omp_get_thread_num () .eq. 1 .and. f1 .ne. 'IJKLMN') +!$omp end parallel + f1 = 'zZzz_z' +!$omp parallel shared (f1) reduction (.or.:l) num_threads (2) + l = l .or. f1 .ne. 'zZzz_z' +!$omp barrier +!$omp master + f1 = 'abc' +!$omp end master +!$omp barrier + l = l .or. f1 .ne. 'abc' +!$omp barrier + if (omp_get_thread_num () .eq. 1) f1 = 'def' +!$omp barrier + l = l .or. f1 .ne. 'def' +!$omp end parallel + if (l) call abort + f1 = 'opqrst' + end function f1 + function f3 (n) + use omp_lib + character (n), dimension (2) :: f3 + logical :: l + f3 = 'abcdef' + l = .false. +!$omp parallel firstprivate (f3) reduction (.or.:l) num_threads (2) + l = any (f3 .ne. 'abcdef') + if (omp_get_thread_num () .eq. 0) f3 = 'ijklmn' + if (omp_get_thread_num () .eq. 1) f3 = 'IJKLMN' +!$omp barrier + l = l .or. (omp_get_thread_num () .eq. 0 .and. any (f3 .ne. 'ijklmn')) + l = l .or. (omp_get_thread_num () .eq. 1 .and. any (f3 .ne. 'IJKLMN')) +!$omp end parallel + f3 = 'zZzz_z' +!$omp parallel shared (f3) reduction (.or.:l) num_threads (2) + l = l .or. any (f3 .ne. 'zZzz_z') +!$omp barrier +!$omp master + f3 = 'abc' +!$omp end master +!$omp barrier + l = l .or. any (f3 .ne. 'abc') +!$omp barrier + if (omp_get_thread_num () .eq. 1) f3 = 'def' +!$omp barrier + l = l .or. any (f3 .ne. 'def') +!$omp end parallel + if (l) call abort + f3(1) = 'opqrst' + f3(2) = 'a' + end function f3 + function f4 (n) + use omp_lib + character (n), dimension (n - 4) :: f4 + logical :: l + f4 = 'abcdef' + l = .false. +!$omp parallel firstprivate (f4) reduction (.or.:l) num_threads (2) + l = any (f4 .ne. 'abcdef') + if (omp_get_thread_num () .eq. 0) f4 = 'ijklmn' + if (omp_get_thread_num () .eq. 1) f4 = 'IJKLMN' +!$omp barrier + l = l .or. (omp_get_thread_num () .eq. 0 .and. any (f4 .ne. 'ijklmn')) + l = l .or. (omp_get_thread_num () .eq. 1 .and. any (f4 .ne. 'IJKLMN')) + l = l .or. size (f4) .ne. 2 +!$omp end parallel + f4 = 'zZzz_z' +!$omp parallel shared (f4) reduction (.or.:l) num_threads (2) + l = l .or. any (f4 .ne. 'zZzz_z') +!$omp barrier +!$omp master + f4 = 'abc' +!$omp end master +!$omp barrier + l = l .or. any (f4 .ne. 'abc') +!$omp barrier + if (omp_get_thread_num () .eq. 1) f4 = 'def' +!$omp barrier + l = l .or. any (f4 .ne. 'def') + l = l .or. size (f4) .ne. 2 +!$omp end parallel + if (l) call abort + f4(1) = 'Opqrst' + f4(2) = 'A' + end function f4 +end +function f2 (n) + use omp_lib + character (*) :: f2 + logical :: l + f2 = 'abcdef' + l = .false. +!$omp parallel firstprivate (f2) reduction (.or.:l) num_threads (2) + l = f2 .ne. 'abcdef' + if (omp_get_thread_num () .eq. 0) f2 = 'ijklmn' + if (omp_get_thread_num () .eq. 1) f2 = 'IJKLMN' +!$omp barrier + l = l .or. (omp_get_thread_num () .eq. 0 .and. f2 .ne. 'ijklmn') + l = l .or. (omp_get_thread_num () .eq. 1 .and. f2 .ne. 'IJKLMN') +!$omp end parallel + f2 = 'zZzz_z' +!$omp parallel shared (f2) reduction (.or.:l) num_threads (2) + l = l .or. f2 .ne. 'zZzz_z' +!$omp barrier +!$omp master + f2 = 'abc' +!$omp end master +!$omp barrier + l = l .or. f2 .ne. 'abc' +!$omp barrier + if (omp_get_thread_num () .eq. 1) f2 = 'def' +!$omp barrier + l = l .or. f2 .ne. 'def' +!$omp end parallel + if (l) call abort + f2 = '_/!!/_' +end function f2 diff --git a/libgomp/testsuite/libgomp.fortran/workshare1.f90 b/libgomp/testsuite/libgomp.fortran/workshare1.f90 new file mode 100644 index 00000000000..a0e6ff919e5 --- /dev/null +++ b/libgomp/testsuite/libgomp.fortran/workshare1.f90 @@ -0,0 +1,30 @@ +function foo () + integer :: foo + logical :: foo_seen + common /foo_seen/ foo_seen + foo_seen = .true. + foo = 3 +end +function bar () + integer :: bar + logical :: bar_seen + common /bar_seen/ bar_seen + bar_seen = .true. + bar = 3 +end + integer :: a (10), b (10), foo, bar + logical :: foo_seen, bar_seen + common /foo_seen/ foo_seen + common /bar_seen/ bar_seen + + foo_seen = .false. + bar_seen = .false. +!$omp parallel workshare if (foo () .gt. 2) num_threads (bar () + 1) + a = 10 + b = 20 + a(1:5) = max (a(1:5), b(1:5)) +!$omp end parallel workshare + if (any (a(1:5) .ne. 20)) call abort + if (any (a(6:10) .ne. 10)) call abort + if (.not. foo_seen .or. .not. bar_seen) call abort +end