mirror of
git://gcc.gnu.org/git/gcc.git
synced 2025-04-05 10:50:51 +08:00
re PR fortran/25162 (Issue with OpenMP COPYIN and gfortran)
gcc/fortran/
2006-02-14 Jakub Jelinek <jakub@redhat.com>
Richard Henderson <rth@redhat.com>
Diego Novillo <dnovillo@redhat.com>
* 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.
gcc/testsuite/
2006-02-14 Jakub Jelinek <jakub@redhat.com>
Diego Novillo <dnovillo@redhat.com>
Uros Bizjak <uros@kss-loka.si>
* gfortran.dg/gomp: New directory.
libgomp/
2006-02-14 Jakub Jelinek <jakub@redhat.com>
* testsuite/libgomp.fortran/vla7.f90: Add -w to options.
Remove tests for returning assumed character length arrays.
Co-Authored-By: Diego Novillo <dnovillo@redhat.com>
Co-Authored-By: Richard Henderson <rth@redhat.com>
Co-Authored-By: Uros Bizjak <uros@kss-loka.si>
From-SVN: r110984
This commit is contained in:
Jakub Jelinek
Jakub Jelinek
parent
1dc5d842d4
commit
6c7a4dfdb6
@ -1,3 +1,375 @@
|
||||
2006-02-14 Jakub Jelinek <jakub@redhat.com>
|
||||
Richard Henderson <rth@redhat.com>
|
||||
Diego Novillo <dnovillo@redhat.com>
|
||||
|
||||
* 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 <pinskia@physics.uc.edu>
|
||||
Jakub Jelinek <jakub@redhat.com>
|
||||
|
||||
|
||||
@ -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 <paul@nowt.org
|
||||
# and Steven Bosscher <s.bosscher@student.tudelft.nl>
|
||||
|
||||
@ -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
|
||||
|
||||
|
||||
@ -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");
|
||||
}
|
||||
|
||||
@ -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 ();
|
||||
}
|
||||
|
||||
@ -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 *);
|
||||
|
||||
@ -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 ---------------------------------------------------------------------
|
||||
|
||||
@ -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}
|
||||
|
||||
@ -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
|
||||
|
||||
@ -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;
|
||||
|
||||
|
||||
@ -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);
|
||||
|
||||
@ -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();
|
||||
}
|
||||
|
||||
1325
gcc/fortran/openmp.c
Normal file
1325
gcc/fortran/openmp.c
Normal file
File diff suppressed because it is too large
Load Diff
@ -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;
|
||||
|
||||
@ -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;
|
||||
}
|
||||
|
||||
|
||||
|
||||
@ -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;
|
||||
|
||||
|
||||
@ -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);
|
||||
}
|
||||
|
||||
|
||||
|
||||
@ -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;
|
||||
}
|
||||
|
||||
|
||||
@ -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");
|
||||
}
|
||||
|
||||
@ -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)
|
||||
|
||||
@ -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 <canqun@nudt.edu.cn>
|
||||
|
||||
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)
|
||||
{
|
||||
|
||||
@ -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);
|
||||
|
||||
|
||||
1203
gcc/fortran/trans-openmp.c
Normal file
1203
gcc/fortran/trans-openmp.c
Normal file
File diff suppressed because it is too large
Load Diff
@ -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 *);
|
||||
|
||||
@ -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");
|
||||
}
|
||||
|
||||
@ -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
|
||||
|
||||
132
gcc/fortran/types.def
Normal file
132
gcc/fortran/types.def
Normal file
@ -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)
|
||||
@ -1,3 +1,9 @@
|
||||
2006-02-14 Jakub Jelinek <jakub@redhat.com>
|
||||
Diego Novillo <dnovillo@redhat.com>
|
||||
Uros Bizjak <uros@kss-loka.si>
|
||||
|
||||
* gfortran.dg/gomp: New directory.
|
||||
|
||||
2006-02-14 Richard Guenther <rguenther@suse.de>
|
||||
|
||||
PR tree-optimization/26258
|
||||
|
||||
10
gcc/testsuite/gfortran.dg/gomp/appendix-a/a.1.1.f90
Normal file
10
gcc/testsuite/gfortran.dg/gomp/appendix-a/a.1.1.f90
Normal file
@ -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
|
||||
12
gcc/testsuite/gfortran.dg/gomp/appendix-a/a.11.1.f90
Normal file
12
gcc/testsuite/gfortran.dg/gomp/appendix-a/a.11.1.f90
Normal file
@ -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
|
||||
16
gcc/testsuite/gfortran.dg/gomp/appendix-a/a.11.2.f90
Normal file
16
gcc/testsuite/gfortran.dg/gomp/appendix-a/a.11.2.f90
Normal file
@ -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
|
||||
15
gcc/testsuite/gfortran.dg/gomp/appendix-a/a.11.3.f90
Normal file
15
gcc/testsuite/gfortran.dg/gomp/appendix-a/a.11.3.f90
Normal file
@ -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
|
||||
16
gcc/testsuite/gfortran.dg/gomp/appendix-a/a.11.4.f90
Normal file
16
gcc/testsuite/gfortran.dg/gomp/appendix-a/a.11.4.f90
Normal file
@ -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
|
||||
14
gcc/testsuite/gfortran.dg/gomp/appendix-a/a.11.5.f90
Normal file
14
gcc/testsuite/gfortran.dg/gomp/appendix-a/a.11.5.f90
Normal file
@ -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
|
||||
|
||||
14
gcc/testsuite/gfortran.dg/gomp/appendix-a/a.11.6.f90
Normal file
14
gcc/testsuite/gfortran.dg/gomp/appendix-a/a.11.6.f90
Normal file
@ -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
|
||||
11
gcc/testsuite/gfortran.dg/gomp/appendix-a/a.11.7.f90
Normal file
11
gcc/testsuite/gfortran.dg/gomp/appendix-a/a.11.7.f90
Normal file
@ -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
|
||||
32
gcc/testsuite/gfortran.dg/gomp/appendix-a/a.12.1.f90
Normal file
32
gcc/testsuite/gfortran.dg/gomp/appendix-a/a.12.1.f90
Normal file
@ -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
|
||||
16
gcc/testsuite/gfortran.dg/gomp/appendix-a/a.13.1.f90
Normal file
16
gcc/testsuite/gfortran.dg/gomp/appendix-a/a.13.1.f90
Normal file
@ -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
|
||||
|
||||
15
gcc/testsuite/gfortran.dg/gomp/appendix-a/a.14.1.f90
Normal file
15
gcc/testsuite/gfortran.dg/gomp/appendix-a/a.14.1.f90
Normal file
@ -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
|
||||
14
gcc/testsuite/gfortran.dg/gomp/appendix-a/a.17.1.f90
Normal file
14
gcc/testsuite/gfortran.dg/gomp/appendix-a/a.17.1.f90
Normal file
@ -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
|
||||
19
gcc/testsuite/gfortran.dg/gomp/appendix-a/a.17.2.f90
Normal file
19
gcc/testsuite/gfortran.dg/gomp/appendix-a/a.17.2.f90
Normal file
@ -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
|
||||
|
||||
18
gcc/testsuite/gfortran.dg/gomp/appendix-a/a.17.3.f90
Normal file
18
gcc/testsuite/gfortran.dg/gomp/appendix-a/a.17.3.f90
Normal file
@ -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
|
||||
20
gcc/testsuite/gfortran.dg/gomp/appendix-a/a.21.2.f90
Normal file
20
gcc/testsuite/gfortran.dg/gomp/appendix-a/a.21.2.f90
Normal file
@ -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
|
||||
18
gcc/testsuite/gfortran.dg/gomp/appendix-a/a.21.3.f90
Normal file
18
gcc/testsuite/gfortran.dg/gomp/appendix-a/a.21.3.f90
Normal file
@ -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
|
||||
10
gcc/testsuite/gfortran.dg/gomp/appendix-a/a.22.1.f90
Normal file
10
gcc/testsuite/gfortran.dg/gomp/appendix-a/a.22.1.f90
Normal file
@ -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
|
||||
11
gcc/testsuite/gfortran.dg/gomp/appendix-a/a.22.4.f90
Normal file
11
gcc/testsuite/gfortran.dg/gomp/appendix-a/a.22.4.f90
Normal file
@ -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
|
||||
13
gcc/testsuite/gfortran.dg/gomp/appendix-a/a.22.5.f90
Normal file
13
gcc/testsuite/gfortran.dg/gomp/appendix-a/a.22.5.f90
Normal file
@ -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
|
||||
14
gcc/testsuite/gfortran.dg/gomp/appendix-a/a.22.6.f90
Normal file
14
gcc/testsuite/gfortran.dg/gomp/appendix-a/a.22.6.f90
Normal file
@ -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
|
||||
11
gcc/testsuite/gfortran.dg/gomp/appendix-a/a.23.1.f90
Normal file
11
gcc/testsuite/gfortran.dg/gomp/appendix-a/a.23.1.f90
Normal file
@ -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
|
||||
19
gcc/testsuite/gfortran.dg/gomp/appendix-a/a.23.2.f90
Normal file
19
gcc/testsuite/gfortran.dg/gomp/appendix-a/a.23.2.f90
Normal file
@ -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
|
||||
11
gcc/testsuite/gfortran.dg/gomp/appendix-a/a.23.3.f90
Normal file
11
gcc/testsuite/gfortran.dg/gomp/appendix-a/a.23.3.f90
Normal file
@ -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
|
||||
9
gcc/testsuite/gfortran.dg/gomp/appendix-a/a.23.4.f90
Normal file
9
gcc/testsuite/gfortran.dg/gomp/appendix-a/a.23.4.f90
Normal file
@ -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
|
||||
12
gcc/testsuite/gfortran.dg/gomp/appendix-a/a.23.5.f90
Normal file
12
gcc/testsuite/gfortran.dg/gomp/appendix-a/a.23.5.f90
Normal file
@ -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
|
||||
31
gcc/testsuite/gfortran.dg/gomp/appendix-a/a.24.1.f90
Normal file
31
gcc/testsuite/gfortran.dg/gomp/appendix-a/a.24.1.f90
Normal file
@ -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
|
||||
19
gcc/testsuite/gfortran.dg/gomp/appendix-a/a.25.1.f90
Normal file
19
gcc/testsuite/gfortran.dg/gomp/appendix-a/a.25.1.f90
Normal file
@ -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
|
||||
22
gcc/testsuite/gfortran.dg/gomp/appendix-a/a.26.2.f90
Normal file
22
gcc/testsuite/gfortran.dg/gomp/appendix-a/a.26.2.f90
Normal file
@ -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
|
||||
12
gcc/testsuite/gfortran.dg/gomp/appendix-a/a.27.1.f90
Normal file
12
gcc/testsuite/gfortran.dg/gomp/appendix-a/a.27.1.f90
Normal file
@ -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
|
||||
14
gcc/testsuite/gfortran.dg/gomp/appendix-a/a.30.1.f90
Normal file
14
gcc/testsuite/gfortran.dg/gomp/appendix-a/a.30.1.f90
Normal file
@ -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
|
||||
15
gcc/testsuite/gfortran.dg/gomp/appendix-a/a.31.1.f90
Normal file
15
gcc/testsuite/gfortran.dg/gomp/appendix-a/a.31.1.f90
Normal file
@ -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
|
||||
20
gcc/testsuite/gfortran.dg/gomp/appendix-a/a.31.2.f90
Normal file
20
gcc/testsuite/gfortran.dg/gomp/appendix-a/a.31.2.f90
Normal file
@ -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
|
||||
15
gcc/testsuite/gfortran.dg/gomp/appendix-a/a.31.3.f90
Normal file
15
gcc/testsuite/gfortran.dg/gomp/appendix-a/a.31.3.f90
Normal file
@ -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
|
||||
24
gcc/testsuite/gfortran.dg/gomp/appendix-a/a.32.1.f90
Normal file
24
gcc/testsuite/gfortran.dg/gomp/appendix-a/a.32.1.f90
Normal file
@ -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
|
||||
11
gcc/testsuite/gfortran.dg/gomp/appendix-a/a.33.1.f90
Normal file
11
gcc/testsuite/gfortran.dg/gomp/appendix-a/a.33.1.f90
Normal file
@ -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
|
||||
17
gcc/testsuite/gfortran.dg/gomp/appendix-a/a.33.2.f90
Normal file
17
gcc/testsuite/gfortran.dg/gomp/appendix-a/a.33.2.f90
Normal file
@ -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
|
||||
19
gcc/testsuite/gfortran.dg/gomp/appendix-a/a.33.4.f90
Normal file
19
gcc/testsuite/gfortran.dg/gomp/appendix-a/a.33.4.f90
Normal file
@ -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
|
||||
|
||||
19
gcc/testsuite/gfortran.dg/gomp/appendix-a/a.34.1.f90
Normal file
19
gcc/testsuite/gfortran.dg/gomp/appendix-a/a.34.1.f90
Normal file
@ -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
|
||||
22
gcc/testsuite/gfortran.dg/gomp/appendix-a/a.34.2.f90
Normal file
22
gcc/testsuite/gfortran.dg/gomp/appendix-a/a.34.2.f90
Normal file
@ -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
|
||||
18
gcc/testsuite/gfortran.dg/gomp/appendix-a/a.35.1.f90
Normal file
18
gcc/testsuite/gfortran.dg/gomp/appendix-a/a.35.1.f90
Normal file
@ -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
|
||||
20
gcc/testsuite/gfortran.dg/gomp/appendix-a/a.35.2.f90
Normal file
20
gcc/testsuite/gfortran.dg/gomp/appendix-a/a.35.2.f90
Normal file
@ -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
|
||||
14
gcc/testsuite/gfortran.dg/gomp/appendix-a/a.35.3.f90
Normal file
14
gcc/testsuite/gfortran.dg/gomp/appendix-a/a.35.3.f90
Normal file
@ -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
|
||||
15
gcc/testsuite/gfortran.dg/gomp/appendix-a/a.35.4.f90
Normal file
15
gcc/testsuite/gfortran.dg/gomp/appendix-a/a.35.4.f90
Normal file
@ -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
|
||||
13
gcc/testsuite/gfortran.dg/gomp/appendix-a/a.35.5.f90
Normal file
13
gcc/testsuite/gfortran.dg/gomp/appendix-a/a.35.5.f90
Normal file
@ -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
|
||||
14
gcc/testsuite/gfortran.dg/gomp/appendix-a/a.35.6.f90
Normal file
14
gcc/testsuite/gfortran.dg/gomp/appendix-a/a.35.6.f90
Normal file
@ -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
|
||||
|
||||
23
gcc/testsuite/gfortran.dg/gomp/appendix-a/a.36.1.f90
Normal file
23
gcc/testsuite/gfortran.dg/gomp/appendix-a/a.36.1.f90
Normal file
@ -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
|
||||
15
gcc/testsuite/gfortran.dg/gomp/appendix-a/a.37.1.f90
Normal file
15
gcc/testsuite/gfortran.dg/gomp/appendix-a/a.37.1.f90
Normal file
@ -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
|
||||
13
gcc/testsuite/gfortran.dg/gomp/appendix-a/a.37.2.f90
Normal file
13
gcc/testsuite/gfortran.dg/gomp/appendix-a/a.37.2.f90
Normal file
@ -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
|
||||
24
gcc/testsuite/gfortran.dg/gomp/appendix-a/a.6.1.f90
Normal file
24
gcc/testsuite/gfortran.dg/gomp/appendix-a/a.6.1.f90
Normal file
@ -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
|
||||
15
gcc/testsuite/gfortran.dg/gomp/appendix-a/a.6.2.f90
Normal file
15
gcc/testsuite/gfortran.dg/gomp/appendix-a/a.6.2.f90
Normal file
@ -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
|
||||
12
gcc/testsuite/gfortran.dg/gomp/appendix-a/a.7.1.f90
Normal file
12
gcc/testsuite/gfortran.dg/gomp/appendix-a/a.7.1.f90
Normal file
@ -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
|
||||
22
gcc/testsuite/gfortran.dg/gomp/appendix-a/a.7.2.f90
Normal file
22
gcc/testsuite/gfortran.dg/gomp/appendix-a/a.7.2.f90
Normal file
@ -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
|
||||
18
gcc/testsuite/gfortran.dg/gomp/appendix-a/a.8.1.f90
Normal file
18
gcc/testsuite/gfortran.dg/gomp/appendix-a/a.8.1.f90
Normal file
@ -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
|
||||
11
gcc/testsuite/gfortran.dg/gomp/appendix-a/a.9.1.f90
Normal file
11
gcc/testsuite/gfortran.dg/gomp/appendix-a/a.9.1.f90
Normal file
@ -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
|
||||
10
gcc/testsuite/gfortran.dg/gomp/block-1.f90
Normal file
10
gcc/testsuite/gfortran.dg/gomp/block-1.f90
Normal file
@ -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
|
||||
51
gcc/testsuite/gfortran.dg/gomp/crayptr1.f90
Normal file
51
gcc/testsuite/gfortran.dg/gomp/crayptr1.f90
Normal file
@ -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
|
||||
17
gcc/testsuite/gfortran.dg/gomp/crayptr2.f90
Normal file
17
gcc/testsuite/gfortran.dg/gomp/crayptr2.f90
Normal file
@ -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
|
||||
22
gcc/testsuite/gfortran.dg/gomp/crayptr3.f90
Normal file
22
gcc/testsuite/gfortran.dg/gomp/crayptr3.f90
Normal file
@ -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
|
||||
24
gcc/testsuite/gfortran.dg/gomp/crayptr4.f90
Normal file
24
gcc/testsuite/gfortran.dg/gomp/crayptr4.f90
Normal file
@ -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
|
||||
26
gcc/testsuite/gfortran.dg/gomp/do-1.f90
Normal file
26
gcc/testsuite/gfortran.dg/gomp/do-1.f90
Normal file
@ -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" } }
|
||||
22
gcc/testsuite/gfortran.dg/gomp/fixed-1.f
Normal file
22
gcc/testsuite/gfortran.dg/gomp/fixed-1.f
Normal file
@ -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
|
||||
8
gcc/testsuite/gfortran.dg/gomp/free-1.f90
Normal file
8
gcc/testsuite/gfortran.dg/gomp/free-1.f90
Normal file
@ -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
|
||||
14
gcc/testsuite/gfortran.dg/gomp/gomp.exp
Normal file
14
gcc/testsuite/gfortran.dg/gomp/gomp.exp
Normal file
@ -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
|
||||
38
gcc/testsuite/gfortran.dg/gomp/omp_atomic1.f90
Normal file
38
gcc/testsuite/gfortran.dg/gomp/omp_atomic1.f90
Normal file
@ -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
|
||||
25
gcc/testsuite/gfortran.dg/gomp/omp_clauses1.f90
Normal file
25
gcc/testsuite/gfortran.dg/gomp/omp_clauses1.f90
Normal file
@ -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
|
||||
57
gcc/testsuite/gfortran.dg/gomp/omp_do1.f90
Normal file
57
gcc/testsuite/gfortran.dg/gomp/omp_do1.f90
Normal file
@ -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 }
|
||||
17
gcc/testsuite/gfortran.dg/gomp/omp_threadprivate1.f90
Normal file
17
gcc/testsuite/gfortran.dg/gomp/omp_threadprivate1.f90
Normal file
@ -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
|
||||
6
gcc/testsuite/gfortran.dg/gomp/omp_threadprivate2.f90
Normal file
6
gcc/testsuite/gfortran.dg/gomp/omp_threadprivate2.f90
Normal file
@ -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
|
||||
131
gcc/testsuite/gfortran.dg/gomp/reduction1.f90
Normal file
131
gcc/testsuite/gfortran.dg/gomp/reduction1.f90
Normal file
@ -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
|
||||
33
gcc/testsuite/gfortran.dg/gomp/reduction2.f90
Normal file
33
gcc/testsuite/gfortran.dg/gomp/reduction2.f90
Normal file
@ -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
|
||||
69
gcc/testsuite/gfortran.dg/gomp/reduction3.f90
Normal file
69
gcc/testsuite/gfortran.dg/gomp/reduction3.f90
Normal file
@ -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
|
||||
28
gcc/testsuite/gfortran.dg/gomp/sharing-1.f90
Normal file
28
gcc/testsuite/gfortran.dg/gomp/sharing-1.f90
Normal file
@ -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
|
||||
84
gcc/testsuite/gfortran.dg/gomp/sharing-2.f90
Normal file
84
gcc/testsuite/gfortran.dg/gomp/sharing-2.f90
Normal file
@ -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
|
||||
Some files were not shown because too many files have changed in this diff Show More
Loading…
x
Reference in New Issue
Block a user