OpenE2K
/
gcc
2
0
Fork 0
Code Issues Pull Requests Projects Releases Wiki Activity

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 2006-02-14 17:38:03 +01:00 committed by Jakub Jelinek
parent 1dc5d842d4
commit 6c7a4dfdb6
177 changed files with 11250 additions and 89 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

372
gcc/fortran/ChangeLog
View File

@ -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>

20
gcc/fortran/Make-lang.in
View File

@ -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

215
gcc/fortran/dump-parse-tree.c
View File

@ -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");
}

201
gcc/fortran/f95-lang.c
View File

@ -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 ();
}

91
gcc/fortran/gfortran.h
View File

@ -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 *);

23
gcc/fortran/gfortran.texi
View File

@ -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 ---------------------------------------------------------------------

16
gcc/fortran/invoke.texi
View File

@ -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}

4
gcc/fortran/lang.opt
View File

@ -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

25
gcc/fortran/match.c
View File

@ -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;

22
gcc/fortran/match.h
View File

@ -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);

24
gcc/fortran/module.c
View File

@ -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
View File

File diff suppressed because it is too large Load Diff

9
gcc/fortran/options.c
View File

@ -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;

535
gcc/fortran/parse.c
View File

@ -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;
}

5
gcc/fortran/parse.h
View File

@ -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;

123
gcc/fortran/resolve.c
View File

@ -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);
}

209
gcc/fortran/scanner.c
View File

@ -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;
}

30
gcc/fortran/st.c
View File

@ -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");
}

28
gcc/fortran/symbol.c
View File

@ -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)

12
gcc/fortran/trans-common.c
View File

@ -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)
{

14
gcc/fortran/trans-decl.c
View File

@ -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
View File

File diff suppressed because it is too large Load Diff

3
gcc/fortran/trans-stmt.h
View File

@ -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 *);

17
gcc/fortran/trans.c
View File

@ -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");
}

13
gcc/fortran/trans.h
View File

@ -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
View 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)

6
gcc/testsuite/ChangeLog
View File

@ -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
View 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
View 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
View 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
View 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
View 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
View 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
View 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
View 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
View 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
View 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
View 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
View 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
View 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
View 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
View 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
View 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
View 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
View 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
View 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
View 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
View 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
View 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
View 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
View 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
View 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
View 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
View 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
View 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
View 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
View 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
View 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
View 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
View 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
View 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
View 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
View 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
View 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
View 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
View 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
View 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
View 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
View 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
View 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
View 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
View 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
View 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
View 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
View 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
View 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
View 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
View 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
View 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
View 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
View 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
View 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
View 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
View 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
View 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
View 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
View 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
View 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
View 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
View 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
View 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
View 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
View 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
View 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
View 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
View 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
View 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
View 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
View 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
View 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