mirror/gcc
2
0
Fork 0
mirror of git://gcc.gnu.org/git/gcc.git synced 2025-03-26 09:50:40 +08:00
Code Issues Packages Projects Releases Wiki Activity

re PR fortran/60928 (gfortran issue with allocatable components and OpenMP)

Browse Source 
PR fortran/60928
	* omp-low.c (lower_rec_input_clauses) <case OMP_CLAUSE_LASTPRIVATE>:
	Set lastprivate_firstprivate even if omp_private_outer_ref
	langhook returns true.
	<case OMP_CLAUSE_REDUCTION>: When calling omp_clause_default_ctor
	langhook, call unshare_expr on new_var and call
	build_outer_var_ref to get the last argument.
gcc/c-family/
	* c-pragma.c (omp_pragmas_simd): Move PRAGMA_OMP_TASK...
	(omp_pragmas): ... back here.
gcc/fortran/
	* f95-lang.c (gfc_init_builtin_functions): Handle -fopenmp-simd
	like -fopenmp.
	* openmp.c (resolve_omp_clauses): Remove allocatable components
	diagnostics.  Add associate-name and intent(in) pointer
	diagnostics for various clauses, diagnose procedure pointers in
	reduction clause.
	* parse.c (match_word_omp_simd): New function.
	(matchs, matcho): New macros.
	(decode_omp_directive): Change match macros to either matchs
	or matcho.  Handle -fopenmp-simd.
	(next_free, next_fixed): Handle -fopenmp-simd like -fopenmp.
	* scanner.c (skip_free_comments, skip_fixed_comments, include_line):
	Likewise.
	* trans-array.c (get_full_array_size): Rename to...
	(gfc_full_array_size): ... this.  No longer static.
	(duplicate_allocatable): Adjust caller.  Add NO_MEMCPY argument
	and handle it.
	(gfc_duplicate_allocatable, gfc_copy_allocatable_data): Adjust
	duplicate_allocatable callers.
	(gfc_duplicate_allocatable_nocopy): New function.
	(structure_alloc_comps): Adjust g*_full_array_size and
	duplicate_allocatable caller.
	* trans-array.h (gfc_full_array_size,
	gfc_duplicate_allocatable_nocopy): New prototypes.
	* trans-common.c (create_common): Call gfc_finish_decl_attrs.
	* trans-decl.c (gfc_finish_decl_attrs): New function.
	(gfc_finish_var_decl, create_function_arglist,
	gfc_get_fake_result_decl): Call it.
	(gfc_allocate_lang_decl): If DECL_LANG_SPECIFIC is already allocated,
	don't allocate it again.
	(gfc_get_symbol_decl): Set GFC_DECL_ASSOCIATE_VAR_P on
	associate-names.
	* trans.h (gfc_finish_decl_attrs): New prototype.
	(struct lang_decl): Add scalar_allocatable and scalar_pointer
	bitfields.
	(GFC_DECL_SCALAR_ALLOCATABLE, GFC_DECL_SCALAR_POINTER,
	GFC_DECL_GET_SCALAR_ALLOCATABLE, GFC_DECL_GET_SCALAR_POINTER,
	GFC_DECL_ASSOCIATE_VAR_P): Define.
	(GFC_POINTER_TYPE_P): Remove.
	* trans-openmp.c (gfc_omp_privatize_by_reference): Don't check
	GFC_POINTER_TYPE_P, instead test GFC_DECL_GET_SCALAR_ALLOCATABLE,
	GFC_DECL_GET_SCALAR_POINTER or GFC_DECL_CRAY_POINTEE on decl.
	(gfc_omp_predetermined_sharing): Associate-names are predetermined.
	(enum walk_alloc_comps): New.
	(gfc_has_alloc_comps, gfc_omp_unshare_expr_r, gfc_omp_unshare_expr,
	gfc_walk_alloc_comps): New functions.
	(gfc_omp_private_outer_ref): Return true for scalar allocatables or
	decls with allocatable components.
	(gfc_omp_clause_default_ctor, gfc_omp_clause_copy_ctor,
	gfc_omp_clause_assign_op, gfc_omp_clause_dtor): Fix up handling of
	allocatables, handle also OMP_CLAUSE_REDUCTION, handle scalar
	allocatables and decls with allocatable components.
	(gfc_trans_omp_array_reduction_or_udr): Don't handle allocatable
	arrays here.
	(gfc_trans_omp_reduction_list): Call
	gfc_trans_omp_array_reduction_or_udr even for allocatable scalars.
	(gfc_trans_omp_do_simd): If -fno-openmp, just expand it as OMP_SIMD.
	(gfc_trans_omp_parallel_do_simd): Likewise.
	* trans-types.c (gfc_sym_type): Don't set GFC_POINTER_TYPE_P.
	(gfc_get_derived_type): Call gfc_finish_decl_attrs.
gcc/testsuite/
	* gfortran.dg/gomp/allocatable_components_1.f90: Remove dg-error
	directives.
	* gfortran.dg/gomp/associate1.f90: New test.
	* gfortran.dg/gomp/intentin1.f90: New test.
	* gfortran.dg/gomp/openmp-simd-1.f90: New test.
	* gfortran.dg/gomp/openmp-simd-2.f90: New test.
	* gfortran.dg/gomp/openmp-simd-3.f90: New test.
	* gfortran.dg/gomp/proc_ptr_2.f90: New test.
libgomp/
	* testsuite/libgomp.fortran/allocatable9.f90: New test.
	* testsuite/libgomp.fortran/allocatable10.f90: New test.
	* testsuite/libgomp.fortran/allocatable11.f90: New test.
	* testsuite/libgomp.fortran/allocatable12.f90: New test.
	* testsuite/libgomp.fortran/alloc-comp-1.f90: New test.
	* testsuite/libgomp.fortran/alloc-comp-2.f90: New test.
	* testsuite/libgomp.fortran/alloc-comp-3.f90: New test.
	* testsuite/libgomp.fortran/associate1.f90: New test.
	* testsuite/libgomp.fortran/associate2.f90: New test.
	* testsuite/libgomp.fortran/procptr1.f90: New test.

From-SVN: r211397
This commit is contained in:
Jakub Jelinek 2014-06-10 08:05:22 +02:00 committed by Jakub Jelinek
parent c9f2b7e90a
commit 92d28cbb59
35 changed files with 2932 additions and 291 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

10
gcc/ChangeLog
View File

@ -1,3 +1,13 @@
2014-06-10 Jakub Jelinek <jakub@redhat.com>
PR fortran/60928
* omp-low.c (lower_rec_input_clauses) <case OMP_CLAUSE_LASTPRIVATE>:
Set lastprivate_firstprivate even if omp_private_outer_ref
langhook returns true.
<case OMP_CLAUSE_REDUCTION>: When calling omp_clause_default_ctor
langhook, call unshare_expr on new_var and call
build_outer_var_ref to get the last argument.
2014-06-10 Marek Polacek <polacek@redhat.com>
PR c/60988

6
gcc/c-family/ChangeLog
View File

@ -1,3 +1,9 @@
2014-06-10 Jakub Jelinek <jakub@redhat.com>
PR fortran/60928
* c-pragma.c (omp_pragmas_simd): Move PRAGMA_OMP_TASK...
(omp_pragmas): ... back here.
2014-06-05 Marek Polacek <polacek@redhat.com>
PR c/49706

2
gcc/c-family/c-pragma.c
View File

@ -1185,6 +1185,7 @@ static const struct omp_pragma_def omp_pragmas[] = {
{ "section", PRAGMA_OMP_SECTION },
{ "sections", PRAGMA_OMP_SECTIONS },
{ "single", PRAGMA_OMP_SINGLE },
{ "task", PRAGMA_OMP_TASK },
{ "taskgroup", PRAGMA_OMP_TASKGROUP },
{ "taskwait", PRAGMA_OMP_TASKWAIT },
{ "taskyield", PRAGMA_OMP_TASKYIELD },
@ -1197,7 +1198,6 @@ static const struct omp_pragma_def omp_pragmas_simd[] = {
{ "parallel", PRAGMA_OMP_PARALLEL },
{ "simd", PRAGMA_OMP_SIMD },
{ "target", PRAGMA_OMP_TARGET },
{ "task", PRAGMA_OMP_TASK },
{ "teams", PRAGMA_OMP_TEAMS },
};

64
gcc/fortran/ChangeLog
View File

@ -1,3 +1,67 @@
2014-06-10 Jakub Jelinek <jakub@redhat.com>
PR fortran/60928
* f95-lang.c (gfc_init_builtin_functions): Handle -fopenmp-simd
like -fopenmp.
* openmp.c (resolve_omp_clauses): Remove allocatable components
diagnostics. Add associate-name and intent(in) pointer
diagnostics for various clauses, diagnose procedure pointers in
reduction clause.
* parse.c (match_word_omp_simd): New function.
(matchs, matcho): New macros.
(decode_omp_directive): Change match macros to either matchs
or matcho. Handle -fopenmp-simd.
(next_free, next_fixed): Handle -fopenmp-simd like -fopenmp.
* scanner.c (skip_free_comments, skip_fixed_comments, include_line):
Likewise.
* trans-array.c (get_full_array_size): Rename to...
(gfc_full_array_size): ... this. No longer static.
(duplicate_allocatable): Adjust caller. Add NO_MEMCPY argument
and handle it.
(gfc_duplicate_allocatable, gfc_copy_allocatable_data): Adjust
duplicate_allocatable callers.
(gfc_duplicate_allocatable_nocopy): New function.
(structure_alloc_comps): Adjust g*_full_array_size and
duplicate_allocatable caller.
* trans-array.h (gfc_full_array_size,
gfc_duplicate_allocatable_nocopy): New prototypes.
* trans-common.c (create_common): Call gfc_finish_decl_attrs.
* trans-decl.c (gfc_finish_decl_attrs): New function.
(gfc_finish_var_decl, create_function_arglist,
gfc_get_fake_result_decl): Call it.
(gfc_allocate_lang_decl): If DECL_LANG_SPECIFIC is already allocated,
don't allocate it again.
(gfc_get_symbol_decl): Set GFC_DECL_ASSOCIATE_VAR_P on
associate-names.
* trans.h (gfc_finish_decl_attrs): New prototype.
(struct lang_decl): Add scalar_allocatable and scalar_pointer
bitfields.
(GFC_DECL_SCALAR_ALLOCATABLE, GFC_DECL_SCALAR_POINTER,
GFC_DECL_GET_SCALAR_ALLOCATABLE, GFC_DECL_GET_SCALAR_POINTER,
GFC_DECL_ASSOCIATE_VAR_P): Define.
(GFC_POINTER_TYPE_P): Remove.
* trans-openmp.c (gfc_omp_privatize_by_reference): Don't check
GFC_POINTER_TYPE_P, instead test GFC_DECL_GET_SCALAR_ALLOCATABLE,
GFC_DECL_GET_SCALAR_POINTER or GFC_DECL_CRAY_POINTEE on decl.
(gfc_omp_predetermined_sharing): Associate-names are predetermined.
(enum walk_alloc_comps): New.
(gfc_has_alloc_comps, gfc_omp_unshare_expr_r, gfc_omp_unshare_expr,
gfc_walk_alloc_comps): New functions.
(gfc_omp_private_outer_ref): Return true for scalar allocatables or
decls with allocatable components.
(gfc_omp_clause_default_ctor, gfc_omp_clause_copy_ctor,
gfc_omp_clause_assign_op, gfc_omp_clause_dtor): Fix up handling of
allocatables, handle also OMP_CLAUSE_REDUCTION, handle scalar
allocatables and decls with allocatable components.
(gfc_trans_omp_array_reduction_or_udr): Don't handle allocatable
arrays here.
(gfc_trans_omp_reduction_list): Call
gfc_trans_omp_array_reduction_or_udr even for allocatable scalars.
(gfc_trans_omp_do_simd): If -fno-openmp, just expand it as OMP_SIMD.
(gfc_trans_omp_parallel_do_simd): Likewise.
* trans-types.c (gfc_sym_type): Don't set GFC_POINTER_TYPE_P.
(gfc_get_derived_type): Call gfc_finish_decl_attrs.
2014-06-09 Paul Thomas <pault@gcc.gnu.org>
PR fortran/61406

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

@ -1044,7 +1044,9 @@ gfc_init_builtin_functions (void)
#include "../sync-builtins.def"
#undef DEF_SYNC_BUILTIN
if (gfc_option.gfc_flag_openmp || flag_tree_parallelize_loops)
if (gfc_option.gfc_flag_openmp
|| gfc_option.gfc_flag_openmp_simd
|| flag_tree_parallelize_loops)
{
#undef DEF_GOMP_BUILTIN
#define DEF_GOMP_BUILTIN(code, name, type, attr) \

37
gcc/fortran/openmp.c
View File

@ -1763,9 +1763,6 @@ resolve_omp_clauses (gfc_code *code, locus *where,
if (!n->sym->attr.threadprivate)
gfc_error ("Non-THREADPRIVATE object '%s' in COPYIN clause"
" at %L", n->sym->name, where);
if (n->sym->ts.type == BT_DERIVED && n->sym->ts.u.derived->attr.alloc_comp)
gfc_error ("COPYIN clause object '%s' at %L has ALLOCATABLE components",
n->sym->name, where);
}
break;
case OMP_LIST_COPYPRIVATE:
@ -1774,9 +1771,9 @@ resolve_omp_clauses (gfc_code *code, locus *where,
if (n->sym->as && n->sym->as->type == AS_ASSUMED_SIZE)
gfc_error ("Assumed size array '%s' in COPYPRIVATE clause "
"at %L", n->sym->name, where);
if (n->sym->ts.type == BT_DERIVED && n->sym->ts.u.derived->attr.alloc_comp)
gfc_error ("COPYPRIVATE clause object '%s' at %L has ALLOCATABLE components",
n->sym->name, where);
if (n->sym->attr.pointer && n->sym->attr.intent == INTENT_IN)
gfc_error ("INTENT(IN) POINTER '%s' in COPYPRIVATE clause "
"at %L", n->sym->name, where);
}
break;
case OMP_LIST_SHARED:
@ -1788,6 +1785,9 @@ resolve_omp_clauses (gfc_code *code, locus *where,
if (n->sym->attr.cray_pointee)
gfc_error ("Cray pointee '%s' in SHARED clause at %L",
n->sym->name, where);
if (n->sym->attr.associate_var)
gfc_error ("ASSOCIATE name '%s' in SHARED clause at %L",
n->sym->name, where);
}
break;
case OMP_LIST_ALIGNED:
@ -1879,17 +1879,17 @@ resolve_omp_clauses (gfc_code *code, locus *where,
if (n->sym->attr.cray_pointee)
gfc_error ("Cray pointee '%s' in %s clause at %L",
n->sym->name, name, where);
if (n->sym->attr.associate_var)
gfc_error ("ASSOCIATE name '%s' in %s clause at %L",
n->sym->name, name, where);
if (list != OMP_LIST_PRIVATE)
{
if (n->sym->attr.proc_pointer && list == OMP_LIST_REDUCTION)
gfc_error ("Procedure pointer '%s' in %s clause at %L",
n->sym->name, name, where);
if (n->sym->attr.pointer && list == OMP_LIST_REDUCTION)
gfc_error ("POINTER object '%s' in %s clause at %L",
n->sym->name, name, where);
/* Variables in REDUCTION-clauses must be of intrinsic type (flagged below). */
if (list != OMP_LIST_REDUCTION
&& n->sym->ts.type == BT_DERIVED
&& n->sym->ts.u.derived->attr.alloc_comp)
gfc_error ("%s clause object '%s' has ALLOCATABLE components at %L",
name, n->sym->name, where);
if (n->sym->attr.cray_pointer && list == OMP_LIST_REDUCTION)
gfc_error ("Cray pointer '%s' in %s clause at %L",
n->sym->name, name, where);
@ -1901,6 +1901,19 @@ resolve_omp_clauses (gfc_code *code, locus *where,
gfc_error ("Variable '%s' in %s clause is used in "
"NAMELIST statement at %L",
n->sym->name, name, where);
if (n->sym->attr.pointer && n->sym->attr.intent == INTENT_IN)
switch (list)
{
case OMP_LIST_PRIVATE:
case OMP_LIST_LASTPRIVATE:
case OMP_LIST_LINEAR:
/* case OMP_LIST_REDUCTION: */
gfc_error ("INTENT(IN) POINTER '%s' in %s clause at %L",
n->sym->name, name, where);
break;
default:
break;
}
switch (list)
{
case OMP_LIST_REDUCTION:

185
gcc/fortran/parse.c
View File

@ -74,6 +74,34 @@ match_word (const char *str, match (*subr) (void), locus *old_locus)
}
/* Like match_word, but if str is matched, set a flag that it
was matched. */
static match
match_word_omp_simd (const char *str, match (*subr) (void), locus *old_locus,
bool *simd_matched)
{
match m;
if (str != NULL)
{
m = gfc_match (str);
if (m != MATCH_YES)
return m;
*simd_matched = true;
}
m = (*subr) ();
if (m != MATCH_YES)
{
gfc_current_locus = *old_locus;
reject_statement ();
}
return m;
}
/* Load symbols from all USE statements encountered in this scoping unit. */
static void
@ -103,7 +131,7 @@ use_modules (void)
if (match_word (keyword, subr, &old_locus) == MATCH_YES) \
return st; \
else \
undo_new_statement (); \
undo_new_statement (); \
} while (0);
@ -531,11 +559,34 @@ decode_statement (void)
return ST_NONE;
}
/* Like match, but set a flag simd_matched if keyword matched. */
#define matchs(keyword, subr, st) \
do { \
if (match_word_omp_simd (keyword, subr, &old_locus, \
&simd_matched) == MATCH_YES) \
return st; \
else \
undo_new_statement (); \
} while (0);
/* Like match, but don't match anything if not -fopenmp. */
#define matcho(keyword, subr, st) \
do { \
if (!gfc_option.gfc_flag_openmp) \
; \
else if (match_word (keyword, subr, &old_locus) \
== MATCH_YES) \
return st; \
else \
undo_new_statement (); \
} while (0);
static gfc_statement
decode_omp_directive (void)
{
locus old_locus;
char c;
bool simd_matched = false;
gfc_enforce_clean_symbol_state ();
@ -560,94 +611,102 @@ decode_omp_directive (void)
c = gfc_peek_ascii_char ();
/* match is for directives that should be recognized only if
-fopenmp, matchs for directives that should be recognized
if either -fopenmp or -fopenmp-simd. */
switch (c)
{
case 'a':
match ("atomic", gfc_match_omp_atomic, ST_OMP_ATOMIC);
matcho ("atomic", gfc_match_omp_atomic, ST_OMP_ATOMIC);
break;
case 'b':
match ("barrier", gfc_match_omp_barrier, ST_OMP_BARRIER);
matcho ("barrier", gfc_match_omp_barrier, ST_OMP_BARRIER);
break;
case 'c':
match ("cancellation% point", gfc_match_omp_cancellation_point,
ST_OMP_CANCELLATION_POINT);
match ("cancel", gfc_match_omp_cancel, ST_OMP_CANCEL);
match ("critical", gfc_match_omp_critical, ST_OMP_CRITICAL);
matcho ("cancellation% point", gfc_match_omp_cancellation_point,
ST_OMP_CANCELLATION_POINT);
matcho ("cancel", gfc_match_omp_cancel, ST_OMP_CANCEL);
matcho ("critical", gfc_match_omp_critical, ST_OMP_CRITICAL);
break;
case 'd':
match ("declare reduction", gfc_match_omp_declare_reduction,
ST_OMP_DECLARE_REDUCTION);
match ("declare simd", gfc_match_omp_declare_simd,
ST_OMP_DECLARE_SIMD);
match ("do simd", gfc_match_omp_do_simd, ST_OMP_DO_SIMD);
match ("do", gfc_match_omp_do, ST_OMP_DO);
matchs ("declare reduction", gfc_match_omp_declare_reduction,
ST_OMP_DECLARE_REDUCTION);
matchs ("declare simd", gfc_match_omp_declare_simd,
ST_OMP_DECLARE_SIMD);
matchs ("do simd", gfc_match_omp_do_simd, ST_OMP_DO_SIMD);
matcho ("do", gfc_match_omp_do, ST_OMP_DO);
break;
case 'e':
match ("end atomic", gfc_match_omp_eos, ST_OMP_END_ATOMIC);
match ("end critical", gfc_match_omp_critical, ST_OMP_END_CRITICAL);
match ("end do simd", gfc_match_omp_end_nowait, ST_OMP_END_DO_SIMD);
match ("end do", gfc_match_omp_end_nowait, ST_OMP_END_DO);
match ("end simd", gfc_match_omp_eos, ST_OMP_END_SIMD);
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 simd", gfc_match_omp_eos,
ST_OMP_END_PARALLEL_DO_SIMD);
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 taskgroup", gfc_match_omp_eos, ST_OMP_END_TASKGROUP);
match ("end task", gfc_match_omp_eos, ST_OMP_END_TASK);
match ("end workshare", gfc_match_omp_end_nowait,
ST_OMP_END_WORKSHARE);
matcho ("end atomic", gfc_match_omp_eos, ST_OMP_END_ATOMIC);
matcho ("end critical", gfc_match_omp_critical, ST_OMP_END_CRITICAL);
matchs ("end do simd", gfc_match_omp_end_nowait, ST_OMP_END_DO_SIMD);
matcho ("end do", gfc_match_omp_end_nowait, ST_OMP_END_DO);
matchs ("end simd", gfc_match_omp_eos, ST_OMP_END_SIMD);
matcho ("end master", gfc_match_omp_eos, ST_OMP_END_MASTER);
matcho ("end ordered", gfc_match_omp_eos, ST_OMP_END_ORDERED);
matchs ("end parallel do simd", gfc_match_omp_eos,
ST_OMP_END_PARALLEL_DO_SIMD);
matcho ("end parallel do", gfc_match_omp_eos, ST_OMP_END_PARALLEL_DO);
matcho ("end parallel sections", gfc_match_omp_eos,
ST_OMP_END_PARALLEL_SECTIONS);
matcho ("end parallel workshare", gfc_match_omp_eos,
ST_OMP_END_PARALLEL_WORKSHARE);
matcho ("end parallel", gfc_match_omp_eos, ST_OMP_END_PARALLEL);
matcho ("end sections", gfc_match_omp_end_nowait, ST_OMP_END_SECTIONS);
matcho ("end single", gfc_match_omp_end_single, ST_OMP_END_SINGLE);
matcho ("end taskgroup", gfc_match_omp_eos, ST_OMP_END_TASKGROUP);
matcho ("end task", gfc_match_omp_eos, ST_OMP_END_TASK);
matcho ("end workshare", gfc_match_omp_end_nowait,
ST_OMP_END_WORKSHARE);
break;
case 'f':
match ("flush", gfc_match_omp_flush, ST_OMP_FLUSH);
matcho ("flush", gfc_match_omp_flush, ST_OMP_FLUSH);
break;
case 'm':
match ("master", gfc_match_omp_master, ST_OMP_MASTER);
matcho ("master", gfc_match_omp_master, ST_OMP_MASTER);
break;
case 'o':
match ("ordered", gfc_match_omp_ordered, ST_OMP_ORDERED);
matcho ("ordered", gfc_match_omp_ordered, ST_OMP_ORDERED);
break;
case 'p':
match ("parallel do simd", gfc_match_omp_parallel_do_simd,
ST_OMP_PARALLEL_DO_SIMD);
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);
matchs ("parallel do simd", gfc_match_omp_parallel_do_simd,
ST_OMP_PARALLEL_DO_SIMD);
matcho ("parallel do", gfc_match_omp_parallel_do, ST_OMP_PARALLEL_DO);
matcho ("parallel sections", gfc_match_omp_parallel_sections,
ST_OMP_PARALLEL_SECTIONS);
matcho ("parallel workshare", gfc_match_omp_parallel_workshare,
ST_OMP_PARALLEL_WORKSHARE);
matcho ("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 ("simd", gfc_match_omp_simd, ST_OMP_SIMD);
match ("single", gfc_match_omp_single, ST_OMP_SINGLE);
matcho ("sections", gfc_match_omp_sections, ST_OMP_SECTIONS);
matcho ("section", gfc_match_omp_eos, ST_OMP_SECTION);
matchs ("simd", gfc_match_omp_simd, ST_OMP_SIMD);
matcho ("single", gfc_match_omp_single, ST_OMP_SINGLE);
break;
case 't':
match ("taskgroup", gfc_match_omp_taskgroup, ST_OMP_TASKGROUP);
match ("taskwait", gfc_match_omp_taskwait, ST_OMP_TASKWAIT);
match ("taskyield", gfc_match_omp_taskyield, ST_OMP_TASKYIELD);
match ("task", gfc_match_omp_task, ST_OMP_TASK);
match ("threadprivate", gfc_match_omp_threadprivate,
ST_OMP_THREADPRIVATE);
matcho ("taskgroup", gfc_match_omp_taskgroup, ST_OMP_TASKGROUP);
matcho ("taskwait", gfc_match_omp_taskwait, ST_OMP_TASKWAIT);
matcho ("taskyield", gfc_match_omp_taskyield, ST_OMP_TASKYIELD);
matcho ("task", gfc_match_omp_task, ST_OMP_TASK);
matcho ("threadprivate", gfc_match_omp_threadprivate,
ST_OMP_THREADPRIVATE);
break;
case 'w':
match ("workshare", gfc_match_omp_workshare, ST_OMP_WORKSHARE);
matcho ("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. */
stored an error message of some sort. Don't error out if
not -fopenmp and simd_matched is false, i.e. if a directive other
than one marked with match has been seen. */
if (gfc_error_check () == 0)
gfc_error_now ("Unclassifiable OpenMP directive at %C");
if (gfc_option.gfc_flag_openmp || simd_matched)
{
if (gfc_error_check () == 0)
gfc_error_now ("Unclassifiable OpenMP directive at %C");
}
reject_statement ();
@ -770,7 +829,9 @@ next_free (void)
return decode_gcc_attribute ();
}
else if (c == '$' && gfc_option.gfc_flag_openmp)
else if (c == '$'
&& (gfc_option.gfc_flag_openmp
|| gfc_option.gfc_flag_openmp_simd))
{
int i;
@ -859,7 +920,9 @@ next_fixed (void)
return decode_gcc_attribute ();
}
else if (c == '$' && gfc_option.gfc_flag_openmp)
else if (c == '$'
&& (gfc_option.gfc_flag_openmp
|| gfc_option.gfc_flag_openmp_simd))
{
for (i = 0; i < 4; i++, c = gfc_next_char_literal (NONSTRING))
gcc_assert ((char) gfc_wide_tolower (c) == "$omp"[i]);

7
gcc/fortran/scanner.c
View File

@ -752,7 +752,8 @@ skip_free_comments (void)
2) handle OpenMP conditional compilation, where
!$ should be treated as 2 spaces (for initial lines
only if followed by space). */
if (gfc_option.gfc_flag_openmp && at_bol)
if ((gfc_option.gfc_flag_openmp
|| gfc_option.gfc_flag_openmp_simd) && at_bol)
{
locus old_loc = gfc_current_locus;
if (next_char () == '$')
@ -878,7 +879,7 @@ skip_fixed_comments (void)
&& continue_line < gfc_linebuf_linenum (gfc_current_locus.lb))
continue_line = gfc_linebuf_linenum (gfc_current_locus.lb);
if (gfc_option.gfc_flag_openmp)
if (gfc_option.gfc_flag_openmp || gfc_option.gfc_flag_openmp_simd)
{
if (next_char () == '$')
{
@ -1821,7 +1822,7 @@ include_line (gfc_char_t *line)
c = line;
if (gfc_option.gfc_flag_openmp)
if (gfc_option.gfc_flag_openmp || gfc_option.gfc_flag_openmp_simd)
{
if (gfc_current_form == FORM_FREE)
{

51
gcc/fortran/trans-array.c
View File

@ -7381,8 +7381,8 @@ gfc_trans_dealloc_allocated (tree descriptor, bool coarray, gfc_expr *expr)
/* This helper function calculates the size in words of a full array. */
static tree
get_full_array_size (stmtblock_t *block, tree decl, int rank)
tree
gfc_full_array_size (stmtblock_t *block, tree decl, int rank)
{
tree idx;
tree nelems;
@ -7408,7 +7408,7 @@ get_full_array_size (stmtblock_t *block, tree decl, int rank)
static tree
duplicate_allocatable (tree dest, tree src, tree type, int rank,
bool no_malloc, tree str_sz)
bool no_malloc, bool no_memcpy, tree str_sz)
{
tree tmp;
tree size;
@ -7442,9 +7442,13 @@ duplicate_allocatable (tree dest, tree src, tree type, int rank,
gfc_add_expr_to_block (&block, tmp);
}
tmp = builtin_decl_explicit (BUILT_IN_MEMCPY);
tmp = build_call_expr_loc (input_location, tmp, 3, dest, src,
fold_convert (size_type_node, size));
if (!no_memcpy)
{
tmp = builtin_decl_explicit (BUILT_IN_MEMCPY);
tmp = build_call_expr_loc (input_location, tmp, 3, dest, src,
fold_convert (size_type_node, size));
gfc_add_expr_to_block (&block, tmp);
}
}
else
{
@ -7453,7 +7457,7 @@ duplicate_allocatable (tree dest, tree src, tree type, int rank,
gfc_init_block (&block);
if (rank)
nelems = get_full_array_size (&block, src, rank);
nelems = gfc_full_array_size (&block, src, rank);
else
nelems = gfc_index_one_node;
@ -7473,14 +7477,17 @@ duplicate_allocatable (tree dest, tree src, tree type, int rank,
/* We know the temporary and the value will be the same length,
so can use memcpy. */
tmp = builtin_decl_explicit (BUILT_IN_MEMCPY);
tmp = build_call_expr_loc (input_location,
tmp, 3, gfc_conv_descriptor_data_get (dest),
gfc_conv_descriptor_data_get (src),
fold_convert (size_type_node, size));
if (!no_memcpy)
{
tmp = builtin_decl_explicit (BUILT_IN_MEMCPY);
tmp = build_call_expr_loc (input_location, tmp, 3,
gfc_conv_descriptor_data_get (dest),
gfc_conv_descriptor_data_get (src),
fold_convert (size_type_node, size));
gfc_add_expr_to_block (&block, tmp);
}
}
gfc_add_expr_to_block (&block, tmp);
tmp = gfc_finish_block (&block);
/* Null the destination if the source is null; otherwise do
@ -7502,7 +7509,8 @@ duplicate_allocatable (tree dest, tree src, tree type, int rank,
tree
gfc_duplicate_allocatable (tree dest, tree src, tree type, int rank)
{
return duplicate_allocatable (dest, src, type, rank, false, NULL_TREE);
return duplicate_allocatable (dest, src, type, rank, false, false,
NULL_TREE);
}
@ -7511,7 +7519,16 @@ gfc_duplicate_allocatable (tree dest, tree src, tree type, int rank)
tree
gfc_copy_allocatable_data (tree dest, tree src, tree type, int rank)
{
return duplicate_allocatable (dest, src, type, rank, true, NULL_TREE);
return duplicate_allocatable (dest, src, type, rank, true, false,
NULL_TREE);
}
/* Allocate dest to the same size as src, but don't copy anything. */
tree
gfc_duplicate_allocatable_nocopy (tree dest, tree src, tree type, int rank)
{
return duplicate_allocatable (dest, src, type, rank, false, true, NULL_TREE);
}
@ -7571,7 +7588,7 @@ structure_alloc_comps (gfc_symbol * der_type, tree decl,
/* Use the descriptor for an allocatable array. Since this
is a full array reference, we only need the descriptor
information from dimension = rank. */
tmp = get_full_array_size (&fnblock, decl, rank);
tmp = gfc_full_array_size (&fnblock, decl, rank);
tmp = fold_build2_loc (input_location, MINUS_EXPR,
gfc_array_index_type, tmp,
gfc_index_one_node);
@ -7930,7 +7947,7 @@ structure_alloc_comps (gfc_symbol * der_type, tree decl,
gfc_add_expr_to_block (&fnblock, tmp);
size = size_of_string_in_bytes (c->ts.kind, len);
tmp = duplicate_allocatable (dcmp, comp, ctype, rank,
false, size);
false, false, size);
gfc_add_expr_to_block (&fnblock, tmp);
}
else if (c->attr.allocatable && !c->attr.proc_pointer

4
gcc/fortran/trans-array.h
View File

@ -44,10 +44,14 @@ void gfc_trans_g77_array (gfc_symbol *, gfc_wrapped_block *);
/* Generate code to deallocate an array, if it is allocated. */
tree gfc_trans_dealloc_allocated (tree, bool, gfc_expr *);
tree gfc_full_array_size (stmtblock_t *, tree, int);
tree gfc_duplicate_allocatable (tree dest, tree src, tree type, int rank);
tree gfc_copy_allocatable_data (tree dest, tree src, tree type, int rank);
tree gfc_duplicate_allocatable_nocopy (tree, tree, tree, int);
tree gfc_nullify_alloc_comp (gfc_symbol *, tree, int);
tree gfc_deallocate_alloc_comp (gfc_symbol *, tree, int);

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

@ -705,6 +705,7 @@ create_common (gfc_common_head *com, segment_info *head, bool saw_equiv)
TREE_ADDRESSABLE (var_decl) = 1;
/* Fake variables are not visible from other translation units. */
TREE_PUBLIC (var_decl) = 0;
gfc_finish_decl_attrs (var_decl, &s->sym->attr);
/* To preserve identifier names in COMMON, chain to procedure
scope unless at top level in a module definition. */

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

@ -496,6 +496,29 @@ gfc_finish_decl (tree decl)
}
/* Handle setting of GFC_DECL_SCALAR* on DECL. */
void
gfc_finish_decl_attrs (tree decl, symbol_attribute *attr)
{
if (!attr->dimension && !attr->codimension)
{
/* Handle scalar allocatable variables. */
if (attr->allocatable)
{
gfc_allocate_lang_decl (decl);
GFC_DECL_SCALAR_ALLOCATABLE (decl) = 1;
}
/* Handle scalar pointer variables. */
if (attr->pointer)
{
gfc_allocate_lang_decl (decl);
GFC_DECL_SCALAR_POINTER (decl) = 1;
}
}
}
/* Apply symbol attributes to a variable, and add it to the function scope. */
static void
@ -607,6 +630,8 @@ gfc_finish_var_decl (tree decl, gfc_symbol * sym)
if (sym->attr.threadprivate
&& (TREE_STATIC (decl) || DECL_EXTERNAL (decl)))
DECL_TLS_MODEL (decl) = decl_default_tls_model (decl);
gfc_finish_decl_attrs (decl, &sym->attr);
}
@ -615,7 +640,8 @@ gfc_finish_var_decl (tree decl, gfc_symbol * sym)
void
gfc_allocate_lang_decl (tree decl)
{
DECL_LANG_SPECIFIC (decl) = ggc_cleared_alloc<struct lang_decl> ();
if (DECL_LANG_SPECIFIC (decl) == NULL)
DECL_LANG_SPECIFIC (decl) = ggc_cleared_alloc<struct lang_decl> ();
}
/* Remember a symbol to generate initialization/cleanup code at function
@ -1517,6 +1543,9 @@ gfc_get_symbol_decl (gfc_symbol * sym)
&& !sym->attr.select_type_temporary)
DECL_BY_REFERENCE (decl) = 1;
if (sym->attr.associate_var)
GFC_DECL_ASSOCIATE_VAR_P (decl) = 1;
if (sym->attr.vtab
|| (sym->name[0] == '_' && strncmp ("__def_init", sym->name, 10) == 0))
TREE_READONLY (decl) = 1;
@ -2236,6 +2265,7 @@ create_function_arglist (gfc_symbol * sym)
DECL_BY_REFERENCE (parm) = 1;
gfc_finish_decl (parm);
gfc_finish_decl_attrs (parm, &f->sym->attr);
f->sym->backend_decl = parm;
@ -2690,6 +2720,7 @@ gfc_get_fake_result_decl (gfc_symbol * sym, int parent_flag)
TREE_ADDRESSABLE (decl) = 1;
layout_decl (decl, 0);
gfc_finish_decl_attrs (decl, &sym->attr);
if (parent_flag)
gfc_add_decl_to_parent_function (decl);

854
gcc/fortran/trans-openmp.c
View File

@ -55,7 +55,9 @@ gfc_omp_privatize_by_reference (const_tree decl)
/* Array POINTER/ALLOCATABLE have aggregate types, all user variables
that have POINTER_TYPE type and don't have GFC_POINTER_TYPE_P
set are supposed to be privatized by reference. */
if (GFC_POINTER_TYPE_P (type))
if (GFC_DECL_GET_SCALAR_POINTER (decl)
|| GFC_DECL_GET_SCALAR_ALLOCATABLE (decl)
|| GFC_DECL_CRAY_POINTEE (decl))
return false;
if (!DECL_ARTIFICIAL (decl)
@ -77,6 +79,19 @@ gfc_omp_privatize_by_reference (const_tree decl)
enum omp_clause_default_kind
gfc_omp_predetermined_sharing (tree decl)
{
/* Associate names preserve the association established during ASSOCIATE.
As they are implemented either as pointers to the selector or array
descriptor and shouldn't really change in the ASSOCIATE region,
this decl can be either shared or firstprivate. If it is a pointer,
use firstprivate, as it is cheaper that way, otherwise make it shared. */
if (GFC_DECL_ASSOCIATE_VAR_P (decl))
{
if (TREE_CODE (TREE_TYPE (decl)) == POINTER_TYPE)
return OMP_CLAUSE_DEFAULT_FIRSTPRIVATE;
else
return OMP_CLAUSE_DEFAULT_SHARED;
}
if (DECL_ARTIFICIAL (decl)
&& ! GFC_DECL_RESULT (decl)
&& ! (DECL_LANG_SPECIFIC (decl)
@ -135,6 +150,41 @@ gfc_omp_report_decl (tree decl)
return decl;
}
/* Return true if TYPE has any allocatable components. */
static bool
gfc_has_alloc_comps (tree type, tree decl)
{
tree field, ftype;
if (POINTER_TYPE_P (type))
{
if (GFC_DECL_GET_SCALAR_ALLOCATABLE (decl))
type = TREE_TYPE (type);
else if (GFC_DECL_GET_SCALAR_POINTER (decl))
return false;
}
while (GFC_DESCRIPTOR_TYPE_P (type) || GFC_ARRAY_TYPE_P (type))
type = gfc_get_element_type (type);
if (TREE_CODE (type) != RECORD_TYPE)
return false;
for (field = TYPE_FIELDS (type); field; field = DECL_CHAIN (field))
{
ftype = TREE_TYPE (field);
if (GFC_DECL_GET_SCALAR_ALLOCATABLE (field))
return true;
if (GFC_DESCRIPTOR_TYPE_P (ftype)
&& GFC_TYPE_ARRAY_AKIND (ftype) == GFC_ARRAY_ALLOCATABLE)
return true;
if (gfc_has_alloc_comps (ftype, field))
return true;
}
return false;
}
/* Return true if DECL in private clause needs
OMP_CLAUSE_PRIVATE_OUTER_REF on the private clause. */
bool
@ -146,68 +196,335 @@ gfc_omp_private_outer_ref (tree decl)
&& GFC_TYPE_ARRAY_AKIND (type) == GFC_ARRAY_ALLOCATABLE)
return true;
if (GFC_DECL_GET_SCALAR_ALLOCATABLE (decl))
return true;
if (gfc_omp_privatize_by_reference (decl))
type = TREE_TYPE (type);
if (gfc_has_alloc_comps (type, decl))
return true;
return false;
}
/* Callback for gfc_omp_unshare_expr. */
static tree
gfc_omp_unshare_expr_r (tree *tp, int *walk_subtrees, void *)
{
tree t = *tp;
enum tree_code code = TREE_CODE (t);
/* Stop at types, decls, constants like copy_tree_r. */
if (TREE_CODE_CLASS (code) == tcc_type
|| TREE_CODE_CLASS (code) == tcc_declaration
|| TREE_CODE_CLASS (code) == tcc_constant
|| code == BLOCK)
*walk_subtrees = 0;
else if (handled_component_p (t)
|| TREE_CODE (t) == MEM_REF)
{
*tp = unshare_expr (t);
*walk_subtrees = 0;
}
return NULL_TREE;
}
/* Unshare in expr anything that the FE which normally doesn't
care much about tree sharing (because during gimplification
everything is unshared) could cause problems with tree sharing
at omp-low.c time. */
static tree
gfc_omp_unshare_expr (tree expr)
{
walk_tree (&expr, gfc_omp_unshare_expr_r, NULL, NULL);
return expr;
}
enum walk_alloc_comps
{
WALK_ALLOC_COMPS_DTOR,
WALK_ALLOC_COMPS_DEFAULT_CTOR,
WALK_ALLOC_COMPS_COPY_CTOR
};
/* Handle allocatable components in OpenMP clauses. */
static tree
gfc_walk_alloc_comps (tree decl, tree dest, tree var,
enum walk_alloc_comps kind)
{
stmtblock_t block, tmpblock;
tree type = TREE_TYPE (decl), then_b, tem, field;
gfc_init_block (&block);
if (GFC_ARRAY_TYPE_P (type) || GFC_DESCRIPTOR_TYPE_P (type))
{
if (GFC_DESCRIPTOR_TYPE_P (type))
{
gfc_init_block (&tmpblock);
tem = gfc_full_array_size (&tmpblock, decl,
GFC_TYPE_ARRAY_RANK (type));
then_b = gfc_finish_block (&tmpblock);
gfc_add_expr_to_block (&block, gfc_omp_unshare_expr (then_b));
tem = gfc_omp_unshare_expr (tem);
tem = fold_build2_loc (input_location, MINUS_EXPR,
gfc_array_index_type, tem,
gfc_index_one_node);
}
else
{
if (!TYPE_DOMAIN (type)
|| TYPE_MAX_VALUE (TYPE_DOMAIN (type)) == NULL_TREE
|| TYPE_MIN_VALUE (TYPE_DOMAIN (type)) == error_mark_node
|| TYPE_MAX_VALUE (TYPE_DOMAIN (type)) == error_mark_node)
{
tem = fold_build2 (EXACT_DIV_EXPR, sizetype,
TYPE_SIZE_UNIT (type),
TYPE_SIZE_UNIT (TREE_TYPE (type)));
tem = size_binop (MINUS_EXPR, tem, size_one_node);
}
else
tem = array_type_nelts (type);
tem = fold_convert (gfc_array_index_type, tem);
}
tree nelems = gfc_evaluate_now (tem, &block);
tree index = gfc_create_var (gfc_array_index_type, "S");
gfc_init_block (&tmpblock);
tem = gfc_conv_array_data (decl);
tree declvar = build_fold_indirect_ref_loc (input_location, tem);
tree declvref = gfc_build_array_ref (declvar, index, NULL);
tree destvar, destvref = NULL_TREE;
if (dest)
{
tem = gfc_conv_array_data (dest);
destvar = build_fold_indirect_ref_loc (input_location, tem);
destvref = gfc_build_array_ref (destvar, index, NULL);
}
gfc_add_expr_to_block (&tmpblock,
gfc_walk_alloc_comps (declvref, destvref,
var, kind));
gfc_loopinfo loop;
gfc_init_loopinfo (&loop);
loop.dimen = 1;
loop.from[0] = gfc_index_zero_node;
loop.loopvar[0] = index;
loop.to[0] = nelems;
gfc_trans_scalarizing_loops (&loop, &tmpblock);
gfc_add_block_to_block (&block, &loop.pre);
return gfc_finish_block (&block);
}
else if (GFC_DECL_GET_SCALAR_ALLOCATABLE (var))
{
decl = build_fold_indirect_ref_loc (input_location, decl);
if (dest)
dest = build_fold_indirect_ref_loc (input_location, dest);
type = TREE_TYPE (decl);
}
gcc_assert (TREE_CODE (type) == RECORD_TYPE);
for (field = TYPE_FIELDS (type); field; field = DECL_CHAIN (field))
{
tree ftype = TREE_TYPE (field);
tree declf, destf = NULL_TREE;
bool has_alloc_comps = gfc_has_alloc_comps (ftype, field);
if ((!GFC_DESCRIPTOR_TYPE_P (ftype)
|| GFC_TYPE_ARRAY_AKIND (ftype) != GFC_ARRAY_ALLOCATABLE)
&& !GFC_DECL_GET_SCALAR_ALLOCATABLE (field)
&& !has_alloc_comps)
continue;
declf = fold_build3_loc (input_location, COMPONENT_REF, ftype,
decl, field, NULL_TREE);
if (dest)
destf = fold_build3_loc (input_location, COMPONENT_REF, ftype,
dest, field, NULL_TREE);
tem = NULL_TREE;
switch (kind)
{
case WALK_ALLOC_COMPS_DTOR:
break;
case WALK_ALLOC_COMPS_DEFAULT_CTOR:
if (GFC_DESCRIPTOR_TYPE_P (ftype)
&& GFC_TYPE_ARRAY_AKIND (ftype) == GFC_ARRAY_ALLOCATABLE)
{
gfc_add_modify (&block, unshare_expr (destf),
unshare_expr (declf));
tem = gfc_duplicate_allocatable_nocopy
(destf, declf, ftype,
GFC_TYPE_ARRAY_RANK (ftype));
}
else if (GFC_DECL_GET_SCALAR_ALLOCATABLE (field))
tem = gfc_duplicate_allocatable_nocopy (destf, declf, ftype, 0);
break;
case WALK_ALLOC_COMPS_COPY_CTOR:
if (GFC_DESCRIPTOR_TYPE_P (ftype)
&& GFC_TYPE_ARRAY_AKIND (ftype) == GFC_ARRAY_ALLOCATABLE)
tem = gfc_duplicate_allocatable (destf, declf, ftype,
GFC_TYPE_ARRAY_RANK (ftype));
else if (GFC_DECL_GET_SCALAR_ALLOCATABLE (field))
tem = gfc_duplicate_allocatable (destf, declf, ftype, 0);
break;
}
if (tem)
gfc_add_expr_to_block (&block, gfc_omp_unshare_expr (tem));
if (has_alloc_comps)
{
gfc_init_block (&tmpblock);
gfc_add_expr_to_block (&tmpblock,
gfc_walk_alloc_comps (declf, destf,
field, kind));
then_b = gfc_finish_block (&tmpblock);
if (GFC_DESCRIPTOR_TYPE_P (ftype)
&& GFC_TYPE_ARRAY_AKIND (ftype) == GFC_ARRAY_ALLOCATABLE)
tem = gfc_conv_descriptor_data_get (unshare_expr (declf));
else if (GFC_DECL_GET_SCALAR_ALLOCATABLE (field))
tem = unshare_expr (declf);
else
tem = NULL_TREE;
if (tem)
{
tem = fold_convert (pvoid_type_node, tem);
tem = fold_build2_loc (input_location, NE_EXPR,
boolean_type_node, tem,
null_pointer_node);
then_b = build3_loc (input_location, COND_EXPR, void_type_node,
tem, then_b,
build_empty_stmt (input_location));
}
gfc_add_expr_to_block (&block, then_b);
}
if (kind == WALK_ALLOC_COMPS_DTOR)
{
if (GFC_DESCRIPTOR_TYPE_P (ftype)
&& GFC_TYPE_ARRAY_AKIND (ftype) == GFC_ARRAY_ALLOCATABLE)
{
tem = gfc_trans_dealloc_allocated (unshare_expr (declf),
false, NULL);
gfc_add_expr_to_block (&block, gfc_omp_unshare_expr (tem));
}
else if (GFC_DECL_GET_SCALAR_ALLOCATABLE (field))
{
tem = gfc_call_free (unshare_expr (declf));
gfc_add_expr_to_block (&block, gfc_omp_unshare_expr (tem));
}
}
}
return gfc_finish_block (&block);
}
/* Return code to initialize DECL with its default constructor, or
NULL if there's nothing to do. */
tree
gfc_omp_clause_default_ctor (tree clause, tree decl, tree outer)
{
tree type = TREE_TYPE (decl), rank, size, esize, ptr, cond, then_b, else_b;
tree type = TREE_TYPE (decl), size, ptr, cond, then_b, else_b;
stmtblock_t block, cond_block;
if (! GFC_DESCRIPTOR_TYPE_P (type)
|| GFC_TYPE_ARRAY_AKIND (type) != GFC_ARRAY_ALLOCATABLE)
return NULL;
if (OMP_CLAUSE_CODE (clause) == OMP_CLAUSE_REDUCTION)
return NULL;
gcc_assert (outer != NULL);
gcc_assert (OMP_CLAUSE_CODE (clause) == OMP_CLAUSE_PRIVATE
|| OMP_CLAUSE_CODE (clause) == OMP_CLAUSE_LASTPRIVATE);
|| OMP_CLAUSE_CODE (clause) == OMP_CLAUSE_LASTPRIVATE
|| OMP_CLAUSE_CODE (clause) == OMP_CLAUSE_LINEAR
|| OMP_CLAUSE_CODE (clause) == OMP_CLAUSE_REDUCTION);
/* Allocatable arrays in PRIVATE clauses need to be set to
if ((! GFC_DESCRIPTOR_TYPE_P (type)
|| GFC_TYPE_ARRAY_AKIND (type) != GFC_ARRAY_ALLOCATABLE)
&& !GFC_DECL_GET_SCALAR_ALLOCATABLE (OMP_CLAUSE_DECL (clause)))
{
if (gfc_has_alloc_comps (type, OMP_CLAUSE_DECL (clause)))
{
gcc_assert (outer);
gfc_start_block (&block);
tree tem = gfc_walk_alloc_comps (outer, decl,
OMP_CLAUSE_DECL (clause),
WALK_ALLOC_COMPS_DEFAULT_CTOR);
gfc_add_expr_to_block (&block, tem);
return gfc_finish_block (&block);
}
return NULL_TREE;
}
gcc_assert (outer != NULL_TREE);
/* Allocatable arrays and scalars in PRIVATE clauses need to be set to
"not currently allocated" allocation status if outer
array is "not currently allocated", otherwise should be allocated. */
gfc_start_block (&block);
gfc_init_block (&cond_block);
gfc_add_modify (&cond_block, decl, outer);
rank = gfc_rank_cst[GFC_TYPE_ARRAY_RANK (type) - 1];
size = gfc_conv_descriptor_ubound_get (decl, rank);
size = fold_build2_loc (input_location, MINUS_EXPR, gfc_array_index_type,
size, gfc_conv_descriptor_lbound_get (decl, rank));
size = fold_build2_loc (input_location, PLUS_EXPR, gfc_array_index_type,
size, gfc_index_one_node);
if (GFC_TYPE_ARRAY_RANK (type) > 1)
size = fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type,
size, gfc_conv_descriptor_stride_get (decl, rank));
esize = fold_convert (gfc_array_index_type,
TYPE_SIZE_UNIT (gfc_get_element_type (type)));
size = fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type,
size, esize);
size = gfc_evaluate_now (fold_convert (size_type_node, size), &cond_block);
if (GFC_DESCRIPTOR_TYPE_P (type))
{
gfc_add_modify (&cond_block, decl, outer);
tree rank = gfc_rank_cst[GFC_TYPE_ARRAY_RANK (type) - 1];
size = gfc_conv_descriptor_ubound_get (decl, rank);
size = fold_build2_loc (input_location, MINUS_EXPR, gfc_array_index_type,
size,
gfc_conv_descriptor_lbound_get (decl, rank));
size = fold_build2_loc (input_location, PLUS_EXPR, gfc_array_index_type,
size, gfc_index_one_node);
if (GFC_TYPE_ARRAY_RANK (type) > 1)
size = fold_build2_loc (input_location, MULT_EXPR,
gfc_array_index_type, size,
gfc_conv_descriptor_stride_get (decl, rank));
tree esize = fold_convert (gfc_array_index_type,
TYPE_SIZE_UNIT (gfc_get_element_type (type)));
size = fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type,
size, esize);
size = unshare_expr (size);
size = gfc_evaluate_now (fold_convert (size_type_node, size),
&cond_block);
}
else
size = fold_convert (size_type_node, TYPE_SIZE_UNIT (TREE_TYPE (type)));
ptr = gfc_create_var (pvoid_type_node, NULL);
gfc_allocate_using_malloc (&cond_block, ptr, size, NULL_TREE);
gfc_conv_descriptor_data_set (&cond_block, decl, ptr);
if (GFC_DESCRIPTOR_TYPE_P (type))
gfc_conv_descriptor_data_set (&cond_block, unshare_expr (decl), ptr);
else
gfc_add_modify (&cond_block, unshare_expr (decl),
fold_convert (TREE_TYPE (decl), ptr));
if (gfc_has_alloc_comps (type, OMP_CLAUSE_DECL (clause)))
{
tree tem = gfc_walk_alloc_comps (outer, decl,
OMP_CLAUSE_DECL (clause),
WALK_ALLOC_COMPS_DEFAULT_CTOR);
gfc_add_expr_to_block (&cond_block, tem);
}
then_b = gfc_finish_block (&cond_block);
gfc_init_block (&cond_block);
gfc_conv_descriptor_data_set (&cond_block, decl, null_pointer_node);
else_b = gfc_finish_block (&cond_block);
/* Reduction clause requires allocated ALLOCATABLE. */
if (OMP_CLAUSE_CODE (clause) != OMP_CLAUSE_REDUCTION)
{
gfc_init_block (&cond_block);
if (GFC_DESCRIPTOR_TYPE_P (type))
gfc_conv_descriptor_data_set (&cond_block, unshare_expr (decl),
null_pointer_node);
else
gfc_add_modify (&cond_block, unshare_expr (decl),
build_zero_cst (TREE_TYPE (decl)));
else_b = gfc_finish_block (&cond_block);
cond = fold_build2_loc (input_location, NE_EXPR, boolean_type_node,
fold_convert (pvoid_type_node,
gfc_conv_descriptor_data_get (outer)),
null_pointer_node);
gfc_add_expr_to_block (&block, build3_loc (input_location, COND_EXPR,
void_type_node, cond, then_b, else_b));
tree tem = fold_convert (pvoid_type_node,
GFC_DESCRIPTOR_TYPE_P (type)
? gfc_conv_descriptor_data_get (outer) : outer);
tem = unshare_expr (tem);
cond = fold_build2_loc (input_location, NE_EXPR, boolean_type_node,
tem, null_pointer_node);
gfc_add_expr_to_block (&block,
build3_loc (input_location, COND_EXPR,
void_type_node, cond, then_b,
else_b));
}
else
gfc_add_expr_to_block (&block, then_b);
return gfc_finish_block (&block);
}
@ -217,15 +534,29 @@ gfc_omp_clause_default_ctor (tree clause, tree decl, tree outer)
tree
gfc_omp_clause_copy_ctor (tree clause, tree dest, tree src)
{
tree type = TREE_TYPE (dest), ptr, size, esize, rank, call;
tree type = TREE_TYPE (dest), ptr, size, call;
tree cond, then_b, else_b;
stmtblock_t block, cond_block;
if (! GFC_DESCRIPTOR_TYPE_P (type)
|| GFC_TYPE_ARRAY_AKIND (type) != GFC_ARRAY_ALLOCATABLE)
return build2_v (MODIFY_EXPR, dest, src);
gcc_assert (OMP_CLAUSE_CODE (clause) == OMP_CLAUSE_FIRSTPRIVATE
|| OMP_CLAUSE_CODE (clause) == OMP_CLAUSE_LINEAR);
gcc_assert (OMP_CLAUSE_CODE (clause) == OMP_CLAUSE_FIRSTPRIVATE);
if ((! GFC_DESCRIPTOR_TYPE_P (type)
|| GFC_TYPE_ARRAY_AKIND (type) != GFC_ARRAY_ALLOCATABLE)
&& !GFC_DECL_GET_SCALAR_ALLOCATABLE (OMP_CLAUSE_DECL (clause)))
{
if (gfc_has_alloc_comps (type, OMP_CLAUSE_DECL (clause)))
{
gfc_start_block (&block);
gfc_add_modify (&block, dest, src);
tree tem = gfc_walk_alloc_comps (src, dest, OMP_CLAUSE_DECL (clause),
WALK_ALLOC_COMPS_COPY_CTOR);
gfc_add_expr_to_block (&block, tem);
return gfc_finish_block (&block);
}
else
return build2_v (MODIFY_EXPR, dest, src);
}
/* Allocatable arrays in FIRSTPRIVATE clauses need to be allocated
and copied from SRC. */
@ -234,85 +565,257 @@ gfc_omp_clause_copy_ctor (tree clause, tree dest, tree src)
gfc_init_block (&cond_block);
gfc_add_modify (&cond_block, dest, src);
rank = gfc_rank_cst[GFC_TYPE_ARRAY_RANK (type) - 1];
size = gfc_conv_descriptor_ubound_get (dest, rank);
size = fold_build2_loc (input_location, MINUS_EXPR, gfc_array_index_type,
size, gfc_conv_descriptor_lbound_get (dest, rank));
size = fold_build2_loc (input_location, PLUS_EXPR, gfc_array_index_type,
size, gfc_index_one_node);
if (GFC_TYPE_ARRAY_RANK (type) > 1)
size = fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type,
size, gfc_conv_descriptor_stride_get (dest, rank));
esize = fold_convert (gfc_array_index_type,
TYPE_SIZE_UNIT (gfc_get_element_type (type)));
size = fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type,
size, esize);
size = gfc_evaluate_now (fold_convert (size_type_node, size), &cond_block);
if (GFC_DESCRIPTOR_TYPE_P (type))
{
tree rank = gfc_rank_cst[GFC_TYPE_ARRAY_RANK (type) - 1];
size = gfc_conv_descriptor_ubound_get (dest, rank);
size = fold_build2_loc (input_location, MINUS_EXPR, gfc_array_index_type,
size,
gfc_conv_descriptor_lbound_get (dest, rank));
size = fold_build2_loc (input_location, PLUS_EXPR, gfc_array_index_type,
size, gfc_index_one_node);
if (GFC_TYPE_ARRAY_RANK (type) > 1)
size = fold_build2_loc (input_location, MULT_EXPR,
gfc_array_index_type, size,
gfc_conv_descriptor_stride_get (dest, rank));
tree esize = fold_convert (gfc_array_index_type,
TYPE_SIZE_UNIT (gfc_get_element_type (type)));
size = fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type,
size, esize);
size = unshare_expr (size);
size = gfc_evaluate_now (fold_convert (size_type_node, size),
&cond_block);
}
else
size = fold_convert (size_type_node, TYPE_SIZE_UNIT (TREE_TYPE (type)));
ptr = gfc_create_var (pvoid_type_node, NULL);
gfc_allocate_using_malloc (&cond_block, ptr, size, NULL_TREE);
gfc_conv_descriptor_data_set (&cond_block, dest, ptr);
if (GFC_DESCRIPTOR_TYPE_P (type))
gfc_conv_descriptor_data_set (&cond_block, unshare_expr (dest), ptr);
else
gfc_add_modify (&cond_block, unshare_expr (dest),
fold_convert (TREE_TYPE (dest), ptr));
tree srcptr = GFC_DESCRIPTOR_TYPE_P (type)
? gfc_conv_descriptor_data_get (src) : src;
srcptr = unshare_expr (srcptr);
srcptr = fold_convert (pvoid_type_node, srcptr);
call = build_call_expr_loc (input_location,
builtin_decl_explicit (BUILT_IN_MEMCPY),
3, ptr,
fold_convert (pvoid_type_node,
gfc_conv_descriptor_data_get (src)),
size);
builtin_decl_explicit (BUILT_IN_MEMCPY), 3, ptr,
srcptr, size);
gfc_add_expr_to_block (&cond_block, fold_convert (void_type_node, call));
if (gfc_has_alloc_comps (type, OMP_CLAUSE_DECL (clause)))
{
tree tem = gfc_walk_alloc_comps (src, dest,
OMP_CLAUSE_DECL (clause),
WALK_ALLOC_COMPS_COPY_CTOR);
gfc_add_expr_to_block (&cond_block, tem);
}
then_b = gfc_finish_block (&cond_block);
gfc_init_block (&cond_block);
gfc_conv_descriptor_data_set (&cond_block, dest, null_pointer_node);
if (GFC_DESCRIPTOR_TYPE_P (type))
gfc_conv_descriptor_data_set (&cond_block, unshare_expr (dest),
null_pointer_node);
else
gfc_add_modify (&cond_block, unshare_expr (dest),
build_zero_cst (TREE_TYPE (dest)));
else_b = gfc_finish_block (&cond_block);
cond = fold_build2_loc (input_location, NE_EXPR, boolean_type_node,
fold_convert (pvoid_type_node,
gfc_conv_descriptor_data_get (src)),
null_pointer_node);
gfc_add_expr_to_block (&block, build3_loc (input_location, COND_EXPR,
void_type_node, cond, then_b, else_b));
unshare_expr (srcptr), null_pointer_node);
gfc_add_expr_to_block (&block,
build3_loc (input_location, COND_EXPR,
void_type_node, cond, then_b, else_b));
return gfc_finish_block (&block);
}
/* Similarly, except use an assignment operator instead. */
/* Similarly, except use an intrinsic or pointer assignment operator
instead. */
tree
gfc_omp_clause_assign_op (tree clause ATTRIBUTE_UNUSED, tree dest, tree src)
gfc_omp_clause_assign_op (tree clause, tree dest, tree src)
{
tree type = TREE_TYPE (dest), rank, size, esize, call;
stmtblock_t block;
tree type = TREE_TYPE (dest), ptr, size, call, nonalloc;
tree cond, then_b, else_b;
stmtblock_t block, cond_block, cond_block2, inner_block;
if (! GFC_DESCRIPTOR_TYPE_P (type)
|| GFC_TYPE_ARRAY_AKIND (type) != GFC_ARRAY_ALLOCATABLE)
return build2_v (MODIFY_EXPR, dest, src);
if ((! GFC_DESCRIPTOR_TYPE_P (type)
|| GFC_TYPE_ARRAY_AKIND (type) != GFC_ARRAY_ALLOCATABLE)
&& !GFC_DECL_GET_SCALAR_ALLOCATABLE (OMP_CLAUSE_DECL (clause)))
{
if (gfc_has_alloc_comps (type, OMP_CLAUSE_DECL (clause)))
{
gfc_start_block (&block);
/* First dealloc any allocatable components in DEST. */
tree tem = gfc_walk_alloc_comps (dest, NULL_TREE,
OMP_CLAUSE_DECL (clause),
WALK_ALLOC_COMPS_DTOR);
gfc_add_expr_to_block (&block, tem);
/* Then copy over toplevel data. */
gfc_add_modify (&block, dest, src);
/* Finally allocate any allocatable components and copy. */
tem = gfc_walk_alloc_comps (src, dest, OMP_CLAUSE_DECL (clause),
WALK_ALLOC_COMPS_COPY_CTOR);
gfc_add_expr_to_block (&block, tem);
return gfc_finish_block (&block);
}
else
return build2_v (MODIFY_EXPR, dest, src);
}
/* Handle copying allocatable arrays. */
gfc_start_block (&block);
rank = gfc_rank_cst[GFC_TYPE_ARRAY_RANK (type) - 1];
size = gfc_conv_descriptor_ubound_get (dest, rank);
size = fold_build2_loc (input_location, MINUS_EXPR, gfc_array_index_type,
size, gfc_conv_descriptor_lbound_get (dest, rank));
size = fold_build2_loc (input_location, PLUS_EXPR, gfc_array_index_type,
size, gfc_index_one_node);
if (GFC_TYPE_ARRAY_RANK (type) > 1)
size = fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type,
size, gfc_conv_descriptor_stride_get (dest, rank));
esize = fold_convert (gfc_array_index_type,
TYPE_SIZE_UNIT (gfc_get_element_type (type)));
size = fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type,
size, esize);
size = gfc_evaluate_now (fold_convert (size_type_node, size), &block);
if (gfc_has_alloc_comps (type, OMP_CLAUSE_DECL (clause)))
{
then_b = gfc_walk_alloc_comps (dest, NULL_TREE, OMP_CLAUSE_DECL (clause),
WALK_ALLOC_COMPS_DTOR);
tree tem = fold_convert (pvoid_type_node,
GFC_DESCRIPTOR_TYPE_P (type)
? gfc_conv_descriptor_data_get (dest) : dest);
tem = unshare_expr (tem);
cond = fold_build2_loc (input_location, NE_EXPR, boolean_type_node,
tem, null_pointer_node);
tem = build3_loc (input_location, COND_EXPR, void_type_node, cond,
then_b, build_empty_stmt (input_location));
gfc_add_expr_to_block (&block, tem);
}
gfc_init_block (&cond_block);
if (GFC_DESCRIPTOR_TYPE_P (type))
{
tree rank = gfc_rank_cst[GFC_TYPE_ARRAY_RANK (type) - 1];
size = gfc_conv_descriptor_ubound_get (src, rank);
size = fold_build2_loc (input_location, MINUS_EXPR, gfc_array_index_type,
size,
gfc_conv_descriptor_lbound_get (src, rank));
size = fold_build2_loc (input_location, PLUS_EXPR, gfc_array_index_type,
size, gfc_index_one_node);
if (GFC_TYPE_ARRAY_RANK (type) > 1)
size = fold_build2_loc (input_location, MULT_EXPR,
gfc_array_index_type, size,
gfc_conv_descriptor_stride_get (src, rank));
tree esize = fold_convert (gfc_array_index_type,
TYPE_SIZE_UNIT (gfc_get_element_type (type)));
size = fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type,
size, esize);
size = unshare_expr (size);
size = gfc_evaluate_now (fold_convert (size_type_node, size),
&cond_block);
}
else
size = fold_convert (size_type_node, TYPE_SIZE_UNIT (TREE_TYPE (type)));
ptr = gfc_create_var (pvoid_type_node, NULL);
tree destptr = GFC_DESCRIPTOR_TYPE_P (type)
? gfc_conv_descriptor_data_get (dest) : dest;
destptr = unshare_expr (destptr);
destptr = fold_convert (pvoid_type_node, destptr);
gfc_add_modify (&cond_block, ptr, destptr);
nonalloc = fold_build2_loc (input_location, EQ_EXPR, boolean_type_node,
destptr, null_pointer_node);
cond = nonalloc;
if (GFC_DESCRIPTOR_TYPE_P (type))
{
int i;
for (i = 0; i < GFC_TYPE_ARRAY_RANK (type); i++)
{
tree rank = gfc_rank_cst[i];
tree tem = gfc_conv_descriptor_ubound_get (src, rank);
tem = fold_build2_loc (input_location, MINUS_EXPR,
gfc_array_index_type, tem,
gfc_conv_descriptor_lbound_get (src, rank));
tem = fold_build2_loc (input_location, PLUS_EXPR,
gfc_array_index_type, tem,
gfc_conv_descriptor_lbound_get (dest, rank));
tem = fold_build2_loc (input_location, NE_EXPR, boolean_type_node,
tem, gfc_conv_descriptor_ubound_get (dest,
rank));
cond = fold_build2_loc (input_location, TRUTH_ORIF_EXPR,
boolean_type_node, cond, tem);
}
}
gfc_init_block (&cond_block2);
if (GFC_DESCRIPTOR_TYPE_P (type))
{
gfc_init_block (&inner_block);
gfc_allocate_using_malloc (&inner_block, ptr, size, NULL_TREE);
then_b = gfc_finish_block (&inner_block);
gfc_init_block (&inner_block);
gfc_add_modify (&inner_block, ptr,
gfc_call_realloc (&inner_block, ptr, size));
else_b = gfc_finish_block (&inner_block);
gfc_add_expr_to_block (&cond_block2,
build3_loc (input_location, COND_EXPR,
void_type_node,
unshare_expr (nonalloc),
then_b, else_b));
gfc_add_modify (&cond_block2, dest, src);
gfc_conv_descriptor_data_set (&cond_block2, unshare_expr (dest), ptr);
}
else
{
gfc_allocate_using_malloc (&cond_block2, ptr, size, NULL_TREE);
gfc_add_modify (&cond_block2, unshare_expr (dest),
fold_convert (type, ptr));
}
then_b = gfc_finish_block (&cond_block2);
else_b = build_empty_stmt (input_location);
gfc_add_expr_to_block (&cond_block,
build3_loc (input_location, COND_EXPR,
void_type_node, unshare_expr (cond),
then_b, else_b));
tree srcptr = GFC_DESCRIPTOR_TYPE_P (type)
? gfc_conv_descriptor_data_get (src) : src;
srcptr = unshare_expr (srcptr);
srcptr = fold_convert (pvoid_type_node, srcptr);
call = build_call_expr_loc (input_location,
builtin_decl_explicit (BUILT_IN_MEMCPY), 3,
fold_convert (pvoid_type_node,
gfc_conv_descriptor_data_get (dest)),
fold_convert (pvoid_type_node,
gfc_conv_descriptor_data_get (src)),
size);
gfc_add_expr_to_block (&block, fold_convert (void_type_node, call));
builtin_decl_explicit (BUILT_IN_MEMCPY), 3, ptr,
srcptr, size);
gfc_add_expr_to_block (&cond_block, fold_convert (void_type_node, call));
if (gfc_has_alloc_comps (type, OMP_CLAUSE_DECL (clause)))
{
tree tem = gfc_walk_alloc_comps (src, dest,
OMP_CLAUSE_DECL (clause),
WALK_ALLOC_COMPS_COPY_CTOR);
gfc_add_expr_to_block (&cond_block, tem);
}
then_b = gfc_finish_block (&cond_block);
if (OMP_CLAUSE_CODE (clause) == OMP_CLAUSE_COPYIN)
{
gfc_init_block (&cond_block);
if (GFC_DESCRIPTOR_TYPE_P (type))
gfc_add_expr_to_block (&cond_block,
gfc_trans_dealloc_allocated (unshare_expr (dest),
false, NULL));
else
{
destptr = gfc_evaluate_now (destptr, &cond_block);
gfc_add_expr_to_block (&cond_block, gfc_call_free (destptr));
gfc_add_modify (&cond_block, unshare_expr (dest),
build_zero_cst (TREE_TYPE (dest)));
}
else_b = gfc_finish_block (&cond_block);
cond = fold_build2_loc (input_location, NE_EXPR, boolean_type_node,
unshare_expr (srcptr), null_pointer_node);
gfc_add_expr_to_block (&block,
build3_loc (input_location, COND_EXPR,
void_type_node, cond,
then_b, else_b));
}
else
gfc_add_expr_to_block (&block, then_b);
return gfc_finish_block (&block);
}
@ -321,20 +824,52 @@ gfc_omp_clause_assign_op (tree clause ATTRIBUTE_UNUSED, tree dest, tree src)
to be done. */
tree
gfc_omp_clause_dtor (tree clause ATTRIBUTE_UNUSED, tree decl)
gfc_omp_clause_dtor (tree clause, tree decl)
{
tree type = TREE_TYPE (decl);
tree type = TREE_TYPE (decl), tem;
if (! GFC_DESCRIPTOR_TYPE_P (type)
|| GFC_TYPE_ARRAY_AKIND (type) != GFC_ARRAY_ALLOCATABLE)
return NULL;
if ((! GFC_DESCRIPTOR_TYPE_P (type)
|| GFC_TYPE_ARRAY_AKIND (type) != GFC_ARRAY_ALLOCATABLE)
&& !GFC_DECL_GET_SCALAR_ALLOCATABLE (OMP_CLAUSE_DECL (clause)))
{
if (gfc_has_alloc_comps (type, OMP_CLAUSE_DECL (clause)))
return gfc_walk_alloc_comps (decl, NULL_TREE,
OMP_CLAUSE_DECL (clause),
WALK_ALLOC_COMPS_DTOR);
return NULL_TREE;
}
if (OMP_CLAUSE_CODE (clause) == OMP_CLAUSE_REDUCTION)
return NULL;
if (GFC_DESCRIPTOR_TYPE_P (type))
/* Allocatable arrays in FIRSTPRIVATE/LASTPRIVATE etc. clauses need
to be deallocated if they were allocated. */
tem = gfc_trans_dealloc_allocated (decl, false, NULL);
else
tem = gfc_call_free (decl);
tem = gfc_omp_unshare_expr (tem);
/* Allocatable arrays in FIRSTPRIVATE/LASTPRIVATE etc. clauses need
to be deallocated if they were allocated. */
return gfc_trans_dealloc_allocated (decl, false, NULL);
if (gfc_has_alloc_comps (type, OMP_CLAUSE_DECL (clause)))
{
stmtblock_t block;
tree then_b;
gfc_init_block (&block);
gfc_add_expr_to_block (&block,
gfc_walk_alloc_comps (decl, NULL_TREE,
OMP_CLAUSE_DECL (clause),
WALK_ALLOC_COMPS_DTOR));
gfc_add_expr_to_block (&block, tem);
then_b = gfc_finish_block (&block);
tem = fold_convert (pvoid_type_node,
GFC_DESCRIPTOR_TYPE_P (type)
? gfc_conv_descriptor_data_get (decl) : decl);
tem = unshare_expr (tem);
tree cond = fold_build2_loc (input_location, NE_EXPR, boolean_type_node,
tem, null_pointer_node);
tem = build3_loc (input_location, COND_EXPR, void_type_node, cond,
then_b, build_empty_stmt (input_location));
}
return tem;
}
@ -881,47 +1416,7 @@ gfc_trans_omp_array_reduction_or_udr (tree c, gfc_omp_namelist *n, locus where)
/* Create the init statement list. */
pushlevel ();
if (sym->attr.dimension
&& GFC_DESCRIPTOR_TYPE_P (type)
&& GFC_TYPE_ARRAY_AKIND (type) == GFC_ARRAY_ALLOCATABLE)
{
/* If decl is an allocatable array, it needs to be allocated
with the same bounds as the outer var. */
tree rank, size, esize, ptr;
stmtblock_t block;
gfc_start_block (&block);
gfc_add_modify (&block, decl, outer_sym.backend_decl);
rank = gfc_rank_cst[GFC_TYPE_ARRAY_RANK (type) - 1];
size = gfc_conv_descriptor_ubound_get (decl, rank);
size = fold_build2_loc (input_location, MINUS_EXPR,
gfc_array_index_type, size,
gfc_conv_descriptor_lbound_get (decl, rank));
size = fold_build2_loc (input_location, PLUS_EXPR, gfc_array_index_type,
size, gfc_index_one_node);
if (GFC_TYPE_ARRAY_RANK (type) > 1)
size = fold_build2_loc (input_location, MULT_EXPR,
gfc_array_index_type, size,
gfc_conv_descriptor_stride_get (decl, rank));
esize = fold_convert (gfc_array_index_type,
TYPE_SIZE_UNIT (gfc_get_element_type (type)));
size = fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type,
size, esize);
size = gfc_evaluate_now (fold_convert (size_type_node, size), &block);
ptr = gfc_create_var (pvoid_type_node, NULL);
gfc_allocate_using_malloc (&block, ptr, size, NULL_TREE);
gfc_conv_descriptor_data_set (&block, decl, ptr);
if (e2)
stmt = gfc_trans_assignment (e1, e2, false, false);
else
stmt = gfc_trans_omp_udr_expr (n, true, e1, e3);
gfc_add_expr_to_block (&block, stmt);
stmt = gfc_finish_block (&block);
}
else if (e2)
if (e2)
stmt = gfc_trans_assignment (e1, e2, false, false);
else if (sym->attr.dimension)
stmt = gfc_trans_omp_udr_expr (n, true, e1, e3);
@ -936,25 +1431,7 @@ gfc_trans_omp_array_reduction_or_udr (tree c, gfc_omp_namelist *n, locus where)
/* Create the merge statement list. */
pushlevel ();
if (sym->attr.dimension
&& GFC_DESCRIPTOR_TYPE_P (type)
&& GFC_TYPE_ARRAY_AKIND (type) == GFC_ARRAY_ALLOCATABLE)
{
/* If decl is an allocatable array, it needs to be deallocated
afterwards. */
stmtblock_t block;
gfc_start_block (&block);
if (e4)
stmt = gfc_trans_assignment (e3, e4, false, true);
else
stmt = gfc_trans_omp_udr_expr (n, false, e1, e3);
gfc_add_expr_to_block (&block, stmt);
gfc_add_expr_to_block (&block, gfc_trans_dealloc_allocated (decl, false,
NULL));
stmt = gfc_finish_block (&block);
}
else if (e4)
if (e4)
stmt = gfc_trans_assignment (e3, e4, false, true);
else if (sym->attr.dimension)
stmt = gfc_trans_omp_udr_expr (n, false, e1, e3);
@ -1055,7 +1532,8 @@ gfc_trans_omp_reduction_list (gfc_omp_namelist *namelist, tree list,
gcc_unreachable ();
}
if (namelist->sym->attr.dimension
|| namelist->rop == OMP_REDUCTION_USER)
|| namelist->rop == OMP_REDUCTION_USER
|| namelist->sym->attr.allocatable)
gfc_trans_omp_array_reduction_or_udr (node, namelist, where);
list = gfc_trans_add_clause (node, list);
}
@ -2274,8 +2752,9 @@ gfc_trans_omp_do_simd (gfc_code *code, gfc_omp_clauses *clausesa,
clausesa = clausesa_buf;
gfc_split_omp_clauses (code, clausesa);
}
omp_do_clauses
= gfc_trans_omp_clauses (&block, &clausesa[GFC_OMP_SPLIT_DO], code->loc);
if (gfc_option.gfc_flag_openmp)
omp_do_clauses
= gfc_trans_omp_clauses (&block, &clausesa[GFC_OMP_SPLIT_DO], code->loc);
pblock = &block;
body = gfc_trans_omp_do (code, EXEC_OMP_SIMD, pblock,
&clausesa[GFC_OMP_SPLIT_SIMD], omp_clauses);
@ -2283,10 +2762,15 @@ gfc_trans_omp_do_simd (gfc_code *code, gfc_omp_clauses *clausesa,
body = build3_v (BIND_EXPR, NULL, body, poplevel (1, 0));
else
poplevel (0, 0);
stmt = make_node (OMP_FOR);
TREE_TYPE (stmt) = void_type_node;
OMP_FOR_BODY (stmt) = body;
OMP_FOR_CLAUSES (stmt) = omp_do_clauses;
if (gfc_option.gfc_flag_openmp)
{
stmt = make_node (OMP_FOR);
TREE_TYPE (stmt) = void_type_node;
OMP_FOR_BODY (stmt) = body;
OMP_FOR_CLAUSES (stmt) = omp_do_clauses;
}
else
stmt = body;
gfc_add_expr_to_block (&block, stmt);
return gfc_finish_block (&block);
}
@ -2332,18 +2816,22 @@ gfc_trans_omp_parallel_do_simd (gfc_code *code)
gfc_start_block (&block);
gfc_split_omp_clauses (code, clausesa);
omp_clauses
= gfc_trans_omp_clauses (&block, &clausesa[GFC_OMP_SPLIT_PARALLEL],
code->loc);
if (gfc_option.gfc_flag_openmp)
omp_clauses
= gfc_trans_omp_clauses (&block, &clausesa[GFC_OMP_SPLIT_PARALLEL],
code->loc);
pushlevel ();
stmt = gfc_trans_omp_do_simd (code, clausesa, omp_clauses);
if (TREE_CODE (stmt) != BIND_EXPR)
stmt = build3_v (BIND_EXPR, NULL, stmt, poplevel (1, 0));
else
poplevel (0, 0);
stmt = build2_loc (input_location, OMP_PARALLEL, void_type_node, stmt,
omp_clauses);
OMP_PARALLEL_COMBINED (stmt) = 1;
if (gfc_option.gfc_flag_openmp)
{
stmt = build2_loc (input_location, OMP_PARALLEL, void_type_node, stmt,
omp_clauses);
OMP_PARALLEL_COMBINED (stmt) = 1;
}
gfc_add_expr_to_block (&block, stmt);
return gfc_finish_block (&block);
}

7
gcc/fortran/trans-types.c
View File

@ -2160,9 +2160,6 @@ gfc_sym_type (gfc_symbol * sym)
restricted);
byref = 0;
}
if (sym->attr.cray_pointee)
GFC_POINTER_TYPE_P (type) = 1;
}
else
{
@ -2181,8 +2178,6 @@ gfc_sym_type (gfc_symbol * sym)
if (sym->attr.allocatable || sym->attr.pointer
|| gfc_is_associate_pointer (sym))
type = gfc_build_pointer_type (sym, type);
if (sym->attr.pointer || sym->attr.cray_pointee)
GFC_POINTER_TYPE_P (type) = 1;
}
/* We currently pass all parameters by reference.
@ -2552,6 +2547,8 @@ gfc_get_derived_type (gfc_symbol * derived)
else if (derived->declared_at.lb)
gfc_set_decl_location (field, &derived->declared_at);
gfc_finish_decl_attrs (field, &c->attr);
DECL_PACKED (field) |= TYPE_PACKED (typenode);
gcc_assert (field);

16
gcc/fortran/trans.h
View File

@ -547,6 +547,9 @@ void gfc_set_decl_assembler_name (tree, tree);
/* Returns true if a variable of specified size should go on the stack. */
int gfc_can_put_var_on_stack (tree);
/* Set GFC_DECL_SCALAR_* on decl from sym if needed. */
void gfc_finish_decl_attrs (tree, symbol_attribute *);
/* Allocate the lang-specific part of a decl node. */
void gfc_allocate_lang_decl (tree);
@ -822,6 +825,8 @@ struct GTY(()) lang_decl {
tree span;
/* For assumed-shape coarrays. */
tree token, caf_offset;
unsigned int scalar_allocatable : 1;
unsigned int scalar_pointer : 1;
};
@ -832,6 +837,14 @@ struct GTY(()) lang_decl {
#define GFC_DECL_CAF_OFFSET(node) DECL_LANG_SPECIFIC(node)->caf_offset
#define GFC_DECL_SAVED_DESCRIPTOR(node) \
(DECL_LANG_SPECIFIC(node)->saved_descriptor)
#define GFC_DECL_SCALAR_ALLOCATABLE(node) \
(DECL_LANG_SPECIFIC (node)->scalar_allocatable)
#define GFC_DECL_SCALAR_POINTER(node) \
(DECL_LANG_SPECIFIC (node)->scalar_pointer)
#define GFC_DECL_GET_SCALAR_ALLOCATABLE(node) \
(DECL_LANG_SPECIFIC (node) ? GFC_DECL_SCALAR_ALLOCATABLE (node) : 0)
#define GFC_DECL_GET_SCALAR_POINTER(node) \
(DECL_LANG_SPECIFIC (node) ? GFC_DECL_SCALAR_POINTER (node) : 0)
#define GFC_DECL_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)
@ -839,14 +852,13 @@ struct GTY(()) lang_decl {
#define GFC_DECL_CRAY_POINTEE(node) DECL_LANG_FLAG_4(node)
#define GFC_DECL_RESULT(node) DECL_LANG_FLAG_5(node)
#define GFC_DECL_SUBREF_ARRAY_P(node) DECL_LANG_FLAG_6(node)
#define GFC_DECL_ASSOCIATE_VAR_P(node) DECL_LANG_FLAG_7(node)
#define GFC_DECL_CLASS(node) DECL_LANG_FLAG_8(node)
/* An array descriptor. */
#define GFC_DESCRIPTOR_TYPE_P(node) TYPE_LANG_FLAG_1(node)
/* An array without a descriptor. */
#define GFC_ARRAY_TYPE_P(node) TYPE_LANG_FLAG_2(node)
/* Fortran POINTER type. */
#define GFC_POINTER_TYPE_P(node) TYPE_LANG_FLAG_3(node)
/* Fortran CLASS type. */
#define GFC_CLASS_TYPE_P(node) TYPE_LANG_FLAG_4(node)
/* The GFC_TYPE_ARRAY_* members are present in both descriptor and

10
gcc/omp-low.c
View File

@ -3110,6 +3110,13 @@ lower_rec_input_clauses (tree clauses, gimple_seq *ilist, gimple_seq *dlist,
if (pass != 0)
continue;
}
/* Even without corresponding firstprivate, if
decl is Fortran allocatable, it needs outer var
reference. */
else if (pass == 0
&& lang_hooks.decls.omp_private_outer_ref
(OMP_CLAUSE_DECL (c)))
lastprivate_firstprivate = true;
break;
case OMP_CLAUSE_ALIGNED:
if (pass == 0)
@ -3545,7 +3552,8 @@ lower_rec_input_clauses (tree clauses, gimple_seq *ilist, gimple_seq *dlist,
else if (is_reference (var) && is_simd)
handle_simd_reference (clause_loc, new_vard, ilist);
x = lang_hooks.decls.omp_clause_default_ctor
(c, new_var, unshare_expr (x));
(c, unshare_expr (new_var),
build_outer_var_ref (var, ctx));
if (x)
gimplify_and_add (x, ilist);
if (OMP_CLAUSE_REDUCTION_GIMPLE_INIT (c))

12
gcc/testsuite/ChangeLog
View File

@ -1,3 +1,15 @@
2014-06-10 Jakub Jelinek <jakub@redhat.com>
PR fortran/60928
* gfortran.dg/gomp/allocatable_components_1.f90: Remove dg-error
directives.
* gfortran.dg/gomp/associate1.f90: New test.
* gfortran.dg/gomp/intentin1.f90: New test.
* gfortran.dg/gomp/openmp-simd-1.f90: New test.
* gfortran.dg/gomp/openmp-simd-2.f90: New test.
* gfortran.dg/gomp/openmp-simd-3.f90: New test.
* gfortran.dg/gomp/proc_ptr_2.f90: New test.
2014-06-09 Marek Polacek <polacek@redhat.com>
PR c/36446

8
gcc/testsuite/gfortran.dg/gomp/allocatable_components_1.f90
View File

@ -14,7 +14,7 @@ CONTAINS
TYPE(t), SAVE :: a
!$omp threadprivate(a)
!$omp parallel copyin(a) ! { dg-error "has ALLOCATABLE components" }
!$omp parallel copyin(a)
! do something
!$omp end parallel
END SUBROUTINE
@ -22,7 +22,7 @@ CONTAINS
SUBROUTINE test_copyprivate()
TYPE(t) :: a
!$omp single ! { dg-error "has ALLOCATABLE components" }
!$omp single
! do something
!$omp end single copyprivate (a)
END SUBROUTINE
@ -30,7 +30,7 @@ CONTAINS
SUBROUTINE test_firstprivate
TYPE(t) :: a
!$omp parallel firstprivate(a) ! { dg-error "has ALLOCATABLE components" }
!$omp parallel firstprivate(a)
! do something
!$omp end parallel
END SUBROUTINE
@ -39,7 +39,7 @@ CONTAINS
TYPE(t) :: a
INTEGER :: i
!$omp parallel do lastprivate(a) ! { dg-error "has ALLOCATABLE components" }
!$omp parallel do lastprivate(a)
DO i = 1, 1
END DO
!$omp end parallel do

83
gcc/testsuite/gfortran.dg/gomp/associate1.f90 Normal file
View File

@ -0,0 +1,83 @@
! { dg-do compile }
program associate1
type dl
integer :: i
end type
type dt
integer :: i
real :: a(3, 3)
type(dl) :: c(3, 3)
end type
integer :: v, i, j
real :: a(3, 3)
type(dt) :: b(3)
i = 1
j = 2
associate(k => v, l => a(i, j), m => a(i, :))
associate(n => b(j)%c(:, :)%i, o => a, p => b)
!$omp parallel shared (l) ! { dg-error "ASSOCIATE name" }
!$omp end parallel
!$omp parallel firstprivate (m) ! { dg-error "ASSOCIATE name" }
!$omp end parallel
!$omp parallel reduction (+: k) ! { dg-error "ASSOCIATE name" }
!$omp end parallel
!$omp parallel do firstprivate (k) ! { dg-error "ASSOCIATE name" }
do i = 1, 10
end do
!$omp parallel do lastprivate (n) ! { dg-error "ASSOCIATE name" }
do i = 1, 10
end do
!$omp parallel do private (o) ! { dg-error "ASSOCIATE name" }
do i = 1, 10
end do
!$omp parallel do shared (p) ! { dg-error "ASSOCIATE name" }
do i = 1, 10
end do
!$omp task private (k) ! { dg-error "ASSOCIATE name" }
!$omp end task
!$omp task shared (l) ! { dg-error "ASSOCIATE name" }
!$omp end task
!$omp task firstprivate (m) ! { dg-error "ASSOCIATE name" }
!$omp end task
!$omp do private (l) ! { dg-error "ASSOCIATE name" }
do i = 1, 10
end do
!$omp do reduction (*: k) ! { dg-error "ASSOCIATE name" }
do i = 1, 10
end do
!$omp sections private(o) ! { dg-error "ASSOCIATE name" }
!$omp section
!$omp section
!$omp end sections
!$omp parallel sections firstprivate(p) ! { dg-error "ASSOCIATE name" }
!$omp section
!$omp section
!$omp endparallelsections
!$omp parallelsections lastprivate(m) ! { dg-error "ASSOCIATE name" }
!$omp section
!$omp section
!$omp endparallelsections
!$omp sections reduction(+:k) ! { dg-error "ASSOCIATE name" }
!$omp section
!$omp section
!$omp end sections
!$omp simd private (l) ! { dg-error "ASSOCIATE name" }
do i = 1, 10
end do
k = 1
!$omp simd lastprivate (m) ! { dg-error "ASSOCIATE name" }
do i = 1, 10
end do
k = 1
!$omp simd reduction (+: k) ! { dg-error "ASSOCIATE name" }
do i = 1, 10
end do
k = 1
!$omp simd linear (k : 2) ! { dg-error "ASSOCIATE name" }
do i = 1, 10
k = k + 2
end do
end associate
end associate
end program

16
gcc/testsuite/gfortran.dg/gomp/intentin1.f90 Normal file
View File

@ -0,0 +1,16 @@
! { dg-do compile }
subroutine foo (x)
integer, pointer, intent (in) :: x
integer :: i
!$omp parallel private (x) ! { dg-error "INTENT.IN. POINTER" }
!$omp end parallel
!$omp parallel do lastprivate (x) ! { dg-error "INTENT.IN. POINTER" }
do i = 1, 10
end do
!$omp simd linear (x) ! { dg-error "INTENT.IN. POINTER" }
do i = 1, 10
end do
!$omp single ! { dg-error "INTENT.IN. POINTER" }
!$omp end single copyprivate (x)
end

137
gcc/testsuite/gfortran.dg/gomp/openmp-simd-1.f90 Normal file
View File

@ -0,0 +1,137 @@
! { dg-do compile }
! { dg-options "-fno-openmp -fopenmp-simd -fdump-tree-original -O2" }
!$omp declare reduction (foo:integer:omp_out = omp_out + omp_in)
interface
integer function foo (x, y)
integer, value :: x, y
!$omp declare simd (foo) linear (y : 2)
end function foo
end interface
integer :: i, a(64), b, c
integer, save :: d
!$omp threadprivate (d)
d = 5
a = 6
!$omp simd
do i = 1, 64
a(i) = foo (a(i), 2 * i)
end do
b = 0
c = 0
!$omp simd reduction (+:b) reduction (foo:c)
do i = 1, 64
b = b + a(i)
c = c + a(i) * 2
end do
print *, b
b = 0
!$omp parallel
!$omp do simd schedule(static, 4) safelen (8) reduction (+:b)
do i = 1, 64
a(i) = a(i) + 1
b = b + 1
end do
!$omp end parallel
print *, b
b = 0
!$omp parallel do simd schedule(static, 4) safelen (8) &
!$omp num_threads (4) if (.true.) reduction (+:b)
do i = 1, 64
a(i) = a(i) + 1
b = b + 1
end do
print *, b
b = 0
!$omp parallel
!$omp do simd schedule(static, 4) safelen (8) reduction (+:b)
do i = 1, 64
a(i) = a(i) + 1
b = b + 1
end do
!$omp enddosimd
!$omp end parallel
print *, b
b = 0
!$omp parallel do simd schedule(static, 4) safelen (8) &
!$omp num_threads (4) if (.true.) reduction (+:b)
do i = 1, 64
a(i) = a(i) + 1
b = b + 1
end do
!$omp end parallel do simd
!$omp atomic seq_cst
b = b + 1
!$omp end atomic
!$omp barrier
!$omp parallel private (i)
!$omp cancellation point parallel
!$omp critical (bar)
b = b + 1
!$omp end critical (bar)
!$omp flush(b)
!$omp single
b = b + 1
!$omp end single
!$omp do ordered
do i = 1, 10
!$omp atomic
b = b + 1
!$omp end atomic
!$omp ordered
print *, b
!$omp end ordered
end do
!$omp end do
!$omp master
b = b + 1
!$omp end master
!$omp cancel parallel
!$omp end parallel
!$omp parallel do schedule(runtime) num_threads(8)
do i = 1, 10
print *, b
end do
!$omp end parallel do
!$omp sections
!$omp section
b = b + 1
!$omp section
c = c + 1
!$omp end sections
print *, b
!$omp parallel sections firstprivate (b) if (.true.)
!$omp section
b = b + 1
!$omp section
c = c + 1
!$omp endparallelsections
!$omp workshare
b = 24
!$omp end workshare
!$omp parallel workshare num_threads (2)
b = b + 1
c = c + 1
!$omp end parallel workshare
print *, b
!$omp parallel
!$omp single
!$omp taskgroup
!$omp task firstprivate (b)
b = b + 1
!$omp taskyield
!$omp end task
!$omp task firstprivate (b)
b = b + 1
!$omp end task
!$omp taskwait
!$omp end taskgroup
!$omp end single
!$omp end parallel
print *, a, c
end
! { dg-final { scan-tree-dump-times "pragma omp simd" 6 "original" } }
! { dg-final { scan-tree-dump-times "pragma omp" 6 "original" } }
! { dg-final { scan-tree-dump-times "__builtin_GOMP" 0 "original" } }
! { dg-final { cleanup-tree-dump "original" } }

28
gcc/testsuite/gfortran.dg/gomp/openmp-simd-2.f90 Normal file
View File

@ -0,0 +1,28 @@
! { dg-do compile }
! { dg-options "-fopenmp -fopenmp-simd -fdump-tree-original -O2" }
include 'openmp-simd-1.f90'
! { dg-final { scan-tree-dump-times "pragma omp simd" 6 "original" } }
! { dg-final { scan-tree-dump-times "pragma omp" 39 "original" } }
! { dg-final { scan-tree-dump-times "pragma omp for" 6 "original" } }
! { dg-final { scan-tree-dump-times "pragma omp parallel" 9 "original" } }
! { dg-final { scan-tree-dump-times "pragma omp taskgroup" 1 "original" } }
! Includes the above taskgroup
! { dg-final { scan-tree-dump-times "pragma omp task" 3 "original" } }
! { dg-final { scan-tree-dump-times "pragma omp critical" 1 "original" } }
! { dg-final { scan-tree-dump-times "pragma omp atomic" 2 "original" } }
! { dg-final { scan-tree-dump-times "pragma omp sections" 2 "original" } }
! Includes the above sections
! { dg-final { scan-tree-dump-times "pragma omp section" 6 "original" } }
! { dg-final { scan-tree-dump-times "pragma omp single" 4 "original" } }
! { dg-final { scan-tree-dump-times "pragma omp ordered" 1 "original" } }
! { dg-final { scan-tree-dump-times "pragma omp master" 1 "original" } }
! { dg-final { scan-tree-dump-times "__builtin_GOMP" 5 "original" } }
! { dg-final { scan-tree-dump-times "__builtin_GOMP_barrier" 1 "original" } }
! { dg-final { scan-tree-dump-times "__builtin_GOMP_cancellation_point" 1 "original" } }
! Includes the above cancellation point
! { dg-final { scan-tree-dump-times "__builtin_GOMP_cancel" 2 "original" } }
! { dg-final { scan-tree-dump-times "__builtin_GOMP_taskyield" 1 "original" } }
! { dg-final { scan-tree-dump-times "__builtin_GOMP_taskwait" 1 "original" } }
! { dg-final { cleanup-tree-dump "original" } }

28
gcc/testsuite/gfortran.dg/gomp/openmp-simd-3.f90 Normal file
View File

@ -0,0 +1,28 @@
! { dg-do compile }
! { dg-options "-fopenmp -fno-openmp-simd -fdump-tree-original -O2" }
include 'openmp-simd-1.f90'
! { dg-final { scan-tree-dump-times "pragma omp simd" 6 "original" } }
! { dg-final { scan-tree-dump-times "pragma omp" 39 "original" } }
! { dg-final { scan-tree-dump-times "pragma omp for" 6 "original" } }
! { dg-final { scan-tree-dump-times "pragma omp parallel" 9 "original" } }
! { dg-final { scan-tree-dump-times "pragma omp taskgroup" 1 "original" } }
! Includes the above taskgroup
! { dg-final { scan-tree-dump-times "pragma omp task" 3 "original" } }
! { dg-final { scan-tree-dump-times "pragma omp critical" 1 "original" } }
! { dg-final { scan-tree-dump-times "pragma omp atomic" 2 "original" } }
! { dg-final { scan-tree-dump-times "pragma omp sections" 2 "original" } }
! Includes the above sections
! { dg-final { scan-tree-dump-times "pragma omp section" 6 "original" } }
! { dg-final { scan-tree-dump-times "pragma omp single" 4 "original" } }
! { dg-final { scan-tree-dump-times "pragma omp ordered" 1 "original" } }
! { dg-final { scan-tree-dump-times "pragma omp master" 1 "original" } }
! { dg-final { scan-tree-dump-times "__builtin_GOMP" 5 "original" } }
! { dg-final { scan-tree-dump-times "__builtin_GOMP_barrier" 1 "original" } }
! { dg-final { scan-tree-dump-times "__builtin_GOMP_cancellation_point" 1 "original" } }
! Includes the above cancellation point
! { dg-final { scan-tree-dump-times "__builtin_GOMP_cancel" 2 "original" } }
! { dg-final { scan-tree-dump-times "__builtin_GOMP_taskyield" 1 "original" } }
! { dg-final { scan-tree-dump-times "__builtin_GOMP_taskwait" 1 "original" } }
! { dg-final { cleanup-tree-dump "original" } }

14
gcc/testsuite/gfortran.dg/gomp/proc_ptr_2.f90 Normal file
View File

@ -0,0 +1,14 @@
! { dg-do compile }
procedure(foo), pointer :: ptr
integer :: i
ptr => foo
!$omp do reduction (+ : ptr) ! { dg-error "Procedure pointer|not found" }
do i = 1, 10
end do
!$omp simd linear (ptr) ! { dg-error "must be INTEGER" }
do i = 1, 10
end do
contains
subroutine foo
end subroutine
end

14
libgomp/ChangeLog
View File

@ -1,3 +1,17 @@
2014-06-10 Jakub Jelinek <jakub@redhat.com>
PR fortran/60928
* testsuite/libgomp.fortran/allocatable9.f90: New test.
* testsuite/libgomp.fortran/allocatable10.f90: New test.
* testsuite/libgomp.fortran/allocatable11.f90: New test.
* testsuite/libgomp.fortran/allocatable12.f90: New test.
* testsuite/libgomp.fortran/alloc-comp-1.f90: New test.
* testsuite/libgomp.fortran/alloc-comp-2.f90: New test.
* testsuite/libgomp.fortran/alloc-comp-3.f90: New test.
* testsuite/libgomp.fortran/associate1.f90: New test.
* testsuite/libgomp.fortran/associate2.f90: New test.
* testsuite/libgomp.fortran/procptr1.f90: New test.
2014-06-06 Jakub Jelinek <jakub@redhat.com>
* testsuite/libgomp.fortran/simd1.f90: New test.

328
libgomp/testsuite/libgomp.fortran/alloc-comp-1.f90 Normal file
View File

@ -0,0 +1,328 @@
! { dg-do run }
! Don't cycle by default through all options, just test -O0 and -O2,
! as this is quite large test.
! { dg-skip-if "" { ! run_expensive_tests } { "*" } { "-O0" "-O2" } }
module m
type dl
integer :: a, b
integer, allocatable :: c(:,:)
integer :: d, e
integer, allocatable :: f
end type
type dt
integer :: g
type (dl), allocatable :: h(:)
integer :: i
type (dl) :: j(2, 2)
type (dl), allocatable :: k
end type
contains
subroutine ver_dl (obj, val, c, cl1, cu1, cl2, cu2, f)
type (dl), intent (in) :: obj
integer, intent (in) :: val, cl1, cu1, cl2, cu2
logical, intent (in) :: c, f
if ((c .neqv. allocated (obj%c)) .or. (f .neqv. allocated (obj%f))) call abort
if (c) then
if (lbound (obj%c, 1) /= cl1 .or. ubound (obj%c, 1) /= cu1) call abort
if (lbound (obj%c, 2) /= cl2 .or. ubound (obj%c, 2) /= cu2) call abort
end if
if (val /= 0) then
if (obj%a /= val .or. obj%b /= val) call abort
if (obj%d /= val .or. obj%e /= val) call abort
if (c) then
if (any (obj%c /= val)) call abort
end if
if (f) then
if (obj%f /= val) call abort
end if
end if
end subroutine ver_dl
subroutine ver_dt (obj, val, h, hl, hu, k, c, cl1, cu1, cl2, cu2, f)
type (dt), intent (in) :: obj
integer, intent (in) :: val, hl, hu, cl1, cu1, cl2, cu2
logical, intent (in) :: h, k, c, f
integer :: i, j
if ((h .neqv. allocated (obj%h)) .or. (k .neqv. allocated (obj%k))) call abort
if (h) then
if (lbound (obj%h, 1) /= hl .or. ubound (obj%h, 1) /= hu) call abort
do i = hl, hu
call ver_dl (obj%h(i), val, c, cl1, cu1, cl2, cu2, f)
end do
end if
do i = 1, 2
do j = 1, 2
call ver_dl (obj%j(i, j), val, c, cl1, cu1, cl2, cu2, f)
end do
end do
if (k) call ver_dl (obj%k, val, c, cl1, cu1, cl2, cu2, f)
if (val /= 0) then
if (obj%g /= val .or. obj%i /= val) call abort
end if
end subroutine ver_dt
subroutine alloc_dl (obj, val, c, cl1, cu1, cl2, cu2, f)
type (dl), intent (inout) :: obj
integer, intent (in) :: val, cl1, cu1, cl2, cu2
logical, intent (in) :: c, f
if (val /= 0) then
obj%a = val
obj%b = val
obj%d = val
obj%e = val
end if
if (allocated (obj%c)) deallocate (obj%c)
if (c) then
allocate (obj%c(cl1:cu1, cl2:cu2))
if (val /= 0) obj%c = val
end if
if (f) then
if (.not.allocated (obj%f)) allocate (obj%f)
if (val /= 0) obj%f = val
else
if (allocated (obj%f)) deallocate (obj%f)
end if
end subroutine alloc_dl
subroutine alloc_dt (obj, val, h, hl, hu, k, c, cl1, cu1, cl2, cu2, f)
type (dt), intent (inout) :: obj
integer, intent (in) :: val, hl, hu, cl1, cu1, cl2, cu2
logical, intent (in) :: h, k, c, f
integer :: i, j
if (val /= 0) then
obj%g = val
obj%i = val
end if
if (allocated (obj%h)) deallocate (obj%h)
if (h) then
allocate (obj%h(hl:hu))
do i = hl, hu
call alloc_dl (obj%h(i), val, c, cl1, cu1, cl2, cu2, f)
end do
end if
do i = 1, 2
do j = 1, 2
call alloc_dl (obj%j(i, j), val, c, cl1, cu1, cl2, cu2, f)
end do
end do
if (k) then
if (.not.allocated (obj%k)) allocate (obj%k)
call alloc_dl (obj%k, val, c, cl1, cu1, cl2, cu2, f)
else
if (allocated (obj%k)) deallocate (obj%k)
end if
end subroutine alloc_dt
end module m
use m
type (dt) :: y
call foo (y)
contains
subroutine foo (y)
use m
type (dt) :: x, y, z(-3:-3,2:3)
logical, parameter :: F = .false.
logical, parameter :: T = .true.
logical :: l
call ver_dt (x, 0, F, 0, 0, F, F, 0, 0, 0, 0, F)
call ver_dt (y, 0, F, 0, 0, F, F, 0, 0, 0, 0, F)
call ver_dt (z(-3,2), 0, F, 0, 0, F, F, 0, 0, 0, 0, F)
call ver_dt (z(-3,3), 0, F, 0, 0, F, F, 0, 0, 0, 0, F)
!$omp parallel private (x, y, z)
call ver_dt (x, 0, F, 0, 0, F, F, 0, 0, 0, 0, F)
call alloc_dt (x, 4, T, -3, -1, T, T, -1, -1, 2, 3, T)
call ver_dt (x, 4, T, -3, -1, T, T, -1, -1, 2, 3, T)
call ver_dt (y, 0, F, 0, 0, F, F, 0, 0, 0, 0, F)
call alloc_dt (y, 14, T, 3, 4, F, T, 1, 1, 2, 4, T)
call ver_dt (y, 14, T, 3, 4, F, T, 1, 1, 2, 4, T)
call ver_dt (z(-3,2), 0, F, 0, 0, F, F, 0, 0, 0, 0, F)
call alloc_dt (z(-3,2), 4, T, -3, -1, T, T, -1, -1, 2, 3, T)
call ver_dt (z(-3,2), 4, T, -3, -1, T, T, -1, -1, 2, 3, T)
call ver_dt (z(-3,3), 0, F, 0, 0, F, F, 0, 0, 0, 0, F)
call alloc_dt (z(-3,3), 14, T, 3, 4, F, T, 1, 1, 2, 4, T)
call ver_dt (z(-3,3), 14, T, 3, 4, F, T, 1, 1, 2, 4, T)
!$omp end parallel
call ver_dt (x, 0, F, 0, 0, F, F, 0, 0, 0, 0, F)
call alloc_dt (x, 4, T, -3, -1, T, T, -1, -1, 2, 3, T)
call ver_dt (y, 0, F, 0, 0, F, F, 0, 0, 0, 0, F)
call alloc_dt (y, 14, T, 3, 4, F, T, 1, 1, 2, 4, T)
call ver_dt (z(-3,2), 0, F, 0, 0, F, F, 0, 0, 0, 0, F)
call alloc_dt (z(-3,2), 4, T, -3, -1, T, T, -1, -1, 2, 3, T)
call ver_dt (z(-3,3), 0, F, 0, 0, F, F, 0, 0, 0, 0, F)
call alloc_dt (z(-3,3), 14, T, 3, 4, F, T, 1, 1, 2, 4, T)
!$omp parallel private (x, y, z)
call ver_dt (x, 0, T, -3, -1, T, T, -1, -1, 2, 3, T)
call ver_dt (y, 0, T, 3, 4, F, T, 1, 1, 2, 4, T)
deallocate (x%h, x%k)
deallocate (y%h)
allocate (y%k)
call ver_dt (z(-3,2), 0, T, -3, -1, T, T, -1, -1, 2, 3, T)
call ver_dt (z(-3,3), 0, T, 3, 4, F, T, 1, 1, 2, 4, T)
deallocate (z(-3,2)%h, z(-3,2)%k)
deallocate (z(-3,3)%h)
allocate (z(-3,3)%k)
!$omp end parallel
call alloc_dt (x, 5, T, 1, 2, F, T, 2, 3, -2, -2, F)
call alloc_dt (y, 15, F, 0, 0, T, T, 2, 2, 2, 2, T)
call alloc_dt (z(-3,2), 5, T, 1, 2, F, T, 2, 3, -2, -2, F)
call alloc_dt (z(-3,3), 15, F, 0, 0, T, T, 2, 2, 2, 2, T)
!$omp parallel firstprivate (x, y, z)
call ver_dt (x, 5, T, 1, 2, F, T, 2, 3, -2, -2, F)
call alloc_dt (x, 4, T, -3, -1, T, T, -1, -1, 2, 3, T)
call ver_dt (x, 4, T, -3, -1, T, T, -1, -1, 2, 3, T)
call ver_dt (y, 15, F, 0, 0, T, T, 2, 2, 2, 2, T)
call alloc_dt (y, 4, T, 3, 4, T, T, 1, 1, 2, 4, T)
call ver_dt (y, 4, T, 3, 4, T, T, 1, 1, 2, 4, T)
call ver_dt (z(-3,2), 5, T, 1, 2, F, T, 2, 3, -2, -2, F)
call alloc_dt (z(-3,2), 4, T, -3, -1, T, T, -1, -1, 2, 3, T)
call ver_dt (z(-3,2), 4, T, -3, -1, T, T, -1, -1, 2, 3, T)
call ver_dt (z(-3,3), 15, F, 0, 0, T, T, 2, 2, 2, 2, T)
call alloc_dt (z(-3,3), 4, T, 3, 4, T, T, 1, 1, 2, 4, T)
call ver_dt (z(-3,3), 4, T, 3, 4, T, T, 1, 1, 2, 4, T)
!$omp end parallel
call ver_dt (x, 5, T, 1, 2, F, T, 2, 3, -2, -2, F)
call alloc_dt (x, 4, F, 0, 0, F, F, 0, 0, 0, 0, F)
call ver_dt (y, 15, F, 0, 0, T, T, 2, 2, 2, 2, T)
call alloc_dt (y, 16, F, 0, 0, F, F, 0, 0, 0, 0, F)
call ver_dt (z(-3,2), 5, T, 1, 2, F, T, 2, 3, -2, -2, F)
call alloc_dt (z(-3,2), 4, F, 0, 0, F, F, 0, 0, 0, 0, F)
call ver_dt (z(-3,3), 15, F, 0, 0, T, T, 2, 2, 2, 2, T)
call alloc_dt (z(-3,3), 16, F, 0, 0, F, F, 0, 0, 0, 0, F)
!$omp parallel firstprivate (x, y, z)
call ver_dt (x, 4, F, 0, 0, F, F, 0, 0, 0, 0, F)
call alloc_dt (x, 4, T, -3, -1, T, T, -1, -1, 2, 3, T)
call ver_dt (x, 4, T, -3, -1, T, T, -1, -1, 2, 3, T)
call ver_dt (y, 16, F, 0, 0, F, F, 0, 0, 0, 0, F)
call alloc_dt (y, 17, T, 1, 2, F, T, 2, 2, 3, 3, F)
call ver_dt (y, 17, T, 1, 2, F, T, 2, 2, 3, 3, F)
call ver_dt (z(-3,2), 4, F, 0, 0, F, F, 0, 0, 0, 0, F)
call alloc_dt (z(-3,2), 4, T, -3, -1, T, T, -1, -1, 2, 3, T)
call ver_dt (z(-3,2), 4, T, -3, -1, T, T, -1, -1, 2, 3, T)
call ver_dt (z(-3,3), 16, F, 0, 0, F, F, 0, 0, 0, 0, F)
call alloc_dt (z(-3,3), 17, T, 1, 2, F, T, 2, 2, 3, 3, F)
call ver_dt (z(-3,3), 17, T, 1, 2, F, T, 2, 2, 3, 3, F)
!$omp end parallel
call ver_dt (x, 4, F, 0, 0, F, F, 0, 0, 0, 0, F)
call ver_dt (y, 16, F, 0, 0, F, F, 0, 0, 0, 0, F)
call alloc_dt (y, 18, T, 0, 1, T, T, 0, 1, 0, 1, T)
call ver_dt (z(-3,2), 4, F, 0, 0, F, F, 0, 0, 0, 0, F)
call ver_dt (z(-3,3), 16, F, 0, 0, F, F, 0, 0, 0, 0, F)
call alloc_dt (z(-3,3), 18, T, 0, 1, T, T, 0, 1, 0, 1, T)
l = F
!$omp parallel sections lastprivate (x, y, z) firstprivate (l)
!$omp section
if (l) then
call ver_dt (x, 9, T, 1, 1, F, F, 0, 0, 0, 0, T)
call ver_dt (y, 21, F, 0, 0, T, T, 1, 2, 3, 4, T)
call ver_dt (z(-3,2), 9, T, 1, 1, F, F, 0, 0, 0, 0, T)
call ver_dt (z(-3,3), 21, F, 0, 0, T, T, 1, 2, 3, 4, T)
else
call ver_dt (x, 0, F, 0, 0, F, F, 0, 0, 0, 0, F)
call ver_dt (y, 0, T, 0, 1, T, T, 0, 1, 0, 1, T)
call ver_dt (z(-3,2), 0, F, 0, 0, F, F, 0, 0, 0, 0, F)
call ver_dt (z(-3,3), 0, T, 0, 1, T, T, 0, 1, 0, 1, T)
end if
l = T
call alloc_dt (x, 7, T, 1, 1, T, T, 1, 2, 3, 3, T)
call ver_dt (x, 7, T, 1, 1, T, T, 1, 2, 3, 3, T)
call alloc_dt (y, 20, T, 0, 0, F, T, 2, 2, 3, 4, F)
call ver_dt (y, 20, T, 0, 0, F, T, 2, 2, 3, 4, F)
call alloc_dt (z(-3,2), 7, T, 1, 1, T, T, 1, 2, 3, 3, T)
call ver_dt (z(-3,2), 7, T, 1, 1, T, T, 1, 2, 3, 3, T)
call alloc_dt (z(-3,3), 20, T, 0, 0, F, T, 2, 2, 3, 4, F)
call ver_dt (z(-3,3), 20, T, 0, 0, F, T, 2, 2, 3, 4, F)
!$omp section
if (l) then
call ver_dt (x, 7, T, 1, 1, T, T, 1, 2, 3, 3, T)
call ver_dt (y, 20, T, 0, 0, F, T, 2, 2, 3, 4, F)
call ver_dt (z(-3,2), 7, T, 1, 1, T, T, 1, 2, 3, 3, T)
call ver_dt (z(-3,3), 20, T, 0, 0, F, T, 2, 2, 3, 4, F)
else
call ver_dt (x, 0, F, 0, 0, F, F, 0, 0, 0, 0, F)
call ver_dt (y, 0, T, 0, 1, T, T, 0, 1, 0, 1, T)
call ver_dt (z(-3,2), 0, F, 0, 0, F, F, 0, 0, 0, 0, F)
call ver_dt (z(-3,3), 0, T, 0, 1, T, T, 0, 1, 0, 1, T)
end if
l = T
call alloc_dt (x, 9, T, 1, 1, F, F, 0, 0, 0, 0, T)
call ver_dt (x, 9, T, 1, 1, F, F, 0, 0, 0, 0, T)
call alloc_dt (y, 21, F, 0, 0, T, T, 1, 2, 3, 4, T)
call ver_dt (y, 21, F, 0, 0, T, T, 1, 2, 3, 4, T)
call alloc_dt (z(-3,2), 9, T, 1, 1, F, F, 0, 0, 0, 0, T)
call ver_dt (z(-3,2), 9, T, 1, 1, F, F, 0, 0, 0, 0, T)
call alloc_dt (z(-3,3), 21, F, 0, 0, T, T, 1, 2, 3, 4, T)
call ver_dt (z(-3,3), 21, F, 0, 0, T, T, 1, 2, 3, 4, T)
!$omp section
!$omp end parallel sections
call ver_dt (x, 9, T, 1, 1, F, F, 0, 0, 0, 0, T)
call ver_dt (y, 21, F, 0, 0, T, T, 1, 2, 3, 4, T)
call ver_dt (z(-3,2), 9, T, 1, 1, F, F, 0, 0, 0, 0, T)
call ver_dt (z(-3,3), 21, F, 0, 0, T, T, 1, 2, 3, 4, T)
!$omp parallel sections lastprivate (x, y, z) firstprivate (l)
!$omp section
if (l) then
call ver_dt (x, 5, F, 0, 0, T, T, -1, -1, -1, -1, T)
call ver_dt (y, 23, T, 0, 1, T, T, 2, 2, 2, 2, F)
call ver_dt (z(-3,2), 5, F, 0, 0, T, T, -1, -1, -1, -1, T)
call ver_dt (z(-3,3), 23, T, 0, 1, T, T, 2, 2, 2, 2, F)
else
call ver_dt (x, 0, T, 1, 1, F, F, 0, 0, 0, 0, T)
call ver_dt (y, 0, F, 0, 0, T, T, 1, 2, 3, 4, T)
call ver_dt (z(-3,2), 0, T, 1, 1, F, F, 0, 0, 0, 0, T)
call ver_dt (z(-3,3), 0, F, 0, 0, T, T, 1, 2, 3, 4, T)
end if
l = T
call alloc_dt (x, 3, F, 0, 0, T, T, 0, 1, 0, 1, F)
call ver_dt (x, 3, F, 0, 0, T, T, 0, 1, 0, 1, F)
call alloc_dt (y, 22, T, 5, 5, F, T, 2, 3, 2, 2, T)
call ver_dt (y, 22, T, 5, 5, F, T, 2, 3, 2, 2, T)
call alloc_dt (z(-3,2), 3, F, 0, 0, T, T, 0, 1, 0, 1, F)
call ver_dt (z(-3,2), 3, F, 0, 0, T, T, 0, 1, 0, 1, F)
call alloc_dt (z(-3,3), 22, T, 5, 5, F, T, 2, 3, 2, 2, T)
call ver_dt (z(-3,3), 22, T, 5, 5, F, T, 2, 3, 2, 2, T)
!$omp section
if (l) then
call ver_dt (x, 3, F, 0, 0, T, T, 0, 1, 0, 1, F)
call ver_dt (y, 22, T, 5, 5, F, T, 2, 3, 2, 2, T)
call ver_dt (z(-3,2), 3, F, 0, 0, T, T, 0, 1, 0, 1, F)
call ver_dt (z(-3,3), 22, T, 5, 5, F, T, 2, 3, 2, 2, T)
else
call ver_dt (x, 0, T, 1, 1, F, F, 0, 0, 0, 0, T)
call ver_dt (y, 0, F, 0, 0, T, T, 1, 2, 3, 4, T)
call ver_dt (z(-3,2), 0, T, 1, 1, F, F, 0, 0, 0, 0, T)
call ver_dt (z(-3,3), 0, F, 0, 0, T, T, 1, 2, 3, 4, T)
end if
l = T
call alloc_dt (x, 5, F, 0, 0, T, T, -1, -1, -1, -1, T)
call ver_dt (x, 5, F, 0, 0, T, T, -1, -1, -1, -1, T)
call alloc_dt (y, 23, T, 0, 1, T, T, 2, 2, 2, 2, F)
call ver_dt (y, 23, T, 0, 1, T, T, 2, 2, 2, 2, F)
call alloc_dt (z(-3,2), 5, F, 0, 0, T, T, -1, -1, -1, -1, T)
call ver_dt (z(-3,2), 5, F, 0, 0, T, T, -1, -1, -1, -1, T)
call alloc_dt (z(-3,3), 23, T, 0, 1, T, T, 2, 2, 2, 2, F)
call ver_dt (z(-3,3), 23, T, 0, 1, T, T, 2, 2, 2, 2, F)
!$omp section
!$omp end parallel sections
call ver_dt (x, 5, F, 0, 0, T, T, -1, -1, -1, -1, T)
call ver_dt (y, 23, T, 0, 1, T, T, 2, 2, 2, 2, F)
call ver_dt (z(-3,2), 5, F, 0, 0, T, T, -1, -1, -1, -1, T)
call ver_dt (z(-3,3), 23, T, 0, 1, T, T, 2, 2, 2, 2, F)
!$omp parallel private (x, y, z)
call ver_dt (x, 0, F, 0, 0, T, T, -1, -1, -1, -1, T)
call ver_dt (y, 0, T, 0, 1, T, T, 2, 2, 2, 2, F)
call ver_dt (z(-3,2), 0, F, 0, 0, T, T, -1, -1, -1, -1, T)
call ver_dt (z(-3,3), 0, T, 0, 1, T, T, 2, 2, 2, 2, F)
!$omp single
call alloc_dt (x, 3, F, 0, 0, T, T, 0, 1, 0, 1, F)
call alloc_dt (y, 22, T, 5, 5, F, T, 2, 3, 2, 2, T)
call alloc_dt (z(-3,2), 3, F, 0, 0, T, T, 0, 1, 0, 1, F)
call alloc_dt (z(-3,3), 22, T, 5, 5, F, T, 2, 3, 2, 2, T)
!$omp end single copyprivate (x, y, z)
call ver_dt (x, 3, F, 0, 0, T, T, 0, 1, 0, 1, F)
call ver_dt (y, 22, T, 5, 5, F, T, 2, 3, 2, 2, T)
call ver_dt (z(-3,2), 3, F, 0, 0, T, T, 0, 1, 0, 1, F)
call ver_dt (z(-3,3), 22, T, 5, 5, F, T, 2, 3, 2, 2, T)
!$omp end parallel
call ver_dt (x, 5, F, 0, 0, T, T, -1, -1, -1, -1, T)
call ver_dt (y, 23, T, 0, 1, T, T, 2, 2, 2, 2, F)
call ver_dt (z(-3,2), 5, F, 0, 0, T, T, -1, -1, -1, -1, T)
call ver_dt (z(-3,3), 23, T, 0, 1, T, T, 2, 2, 2, 2, F)
end subroutine foo
end

367
libgomp/testsuite/libgomp.fortran/alloc-comp-2.f90 Normal file
View File

@ -0,0 +1,367 @@
! { dg-do run }
! Don't cycle by default through all options, just test -O0 and -O2,
! as this is quite large test.
! { dg-skip-if "" { ! run_expensive_tests } { "*" } { "-O0" "-O2" } }
module m
type dl
integer :: a, b
integer, allocatable :: c(:,:)
integer :: d, e
integer, allocatable :: f
end type
type dt
integer :: g
type (dl), allocatable :: h(:)
integer :: i
type (dl) :: j(2, 2)
type (dl), allocatable :: k
end type
contains
subroutine ver_dl (obj, val, c, cl1, cu1, cl2, cu2, f)
type (dl), intent (in) :: obj
integer, intent (in) :: val, cl1, cu1, cl2, cu2
logical, intent (in) :: c, f
if ((c .neqv. allocated (obj%c)) .or. (f .neqv. allocated (obj%f))) call abort
if (c) then
if (lbound (obj%c, 1) /= cl1 .or. ubound (obj%c, 1) /= cu1) call abort
if (lbound (obj%c, 2) /= cl2 .or. ubound (obj%c, 2) /= cu2) call abort
end if
if (val /= 0) then
if (obj%a /= val .or. obj%b /= val) call abort
if (obj%d /= val .or. obj%e /= val) call abort
if (c) then
if (any (obj%c /= val)) call abort
end if
if (f) then
if (obj%f /= val) call abort
end if
end if
end subroutine ver_dl
subroutine ver_dt (obj, val, h, hl, hu, k, c, cl1, cu1, cl2, cu2, f)
type (dt), intent (in) :: obj
integer, intent (in) :: val, hl, hu, cl1, cu1, cl2, cu2
logical, intent (in) :: h, k, c, f
integer :: i, j
if ((h .neqv. allocated (obj%h)) .or. (k .neqv. allocated (obj%k))) call abort
if (h) then
if (lbound (obj%h, 1) /= hl .or. ubound (obj%h, 1) /= hu) call abort
do i = hl, hu
call ver_dl (obj%h(i), val, c, cl1, cu1, cl2, cu2, f)
end do
end if
do i = 1, 2
do j = 1, 2
call ver_dl (obj%j(i, j), val, c, cl1, cu1, cl2, cu2, f)
end do
end do
if (k) call ver_dl (obj%k, val, c, cl1, cu1, cl2, cu2, f)
if (val /= 0) then
if (obj%g /= val .or. obj%i /= val) call abort
end if
end subroutine ver_dt
subroutine alloc_dl (obj, val, c, cl1, cu1, cl2, cu2, f)
type (dl), intent (inout) :: obj
integer, intent (in) :: val, cl1, cu1, cl2, cu2
logical, intent (in) :: c, f
if (val /= 0) then
obj%a = val
obj%b = val
obj%d = val
obj%e = val
end if
if (allocated (obj%c)) deallocate (obj%c)
if (c) then
allocate (obj%c(cl1:cu1, cl2:cu2))
if (val /= 0) obj%c = val
end if
if (f) then
if (.not.allocated (obj%f)) allocate (obj%f)
if (val /= 0) obj%f = val
else
if (allocated (obj%f)) deallocate (obj%f)
end if
end subroutine alloc_dl
subroutine alloc_dt (obj, val, h, hl, hu, k, c, cl1, cu1, cl2, cu2, f)
type (dt), intent (inout) :: obj
integer, intent (in) :: val, hl, hu, cl1, cu1, cl2, cu2
logical, intent (in) :: h, k, c, f
integer :: i, j
if (val /= 0) then
obj%g = val
obj%i = val
end if
if (allocated (obj%h)) deallocate (obj%h)
if (h) then
allocate (obj%h(hl:hu))
do i = hl, hu
call alloc_dl (obj%h(i), val, c, cl1, cu1, cl2, cu2, f)
end do
end if
do i = 1, 2
do j = 1, 2
call alloc_dl (obj%j(i, j), val, c, cl1, cu1, cl2, cu2, f)
end do
end do
if (k) then
if (.not.allocated (obj%k)) allocate (obj%k)
call alloc_dl (obj%k, val, c, cl1, cu1, cl2, cu2, f)
else
if (allocated (obj%k)) deallocate (obj%k)
end if
end subroutine alloc_dt
end module m
use m
type (dt), allocatable :: y
call foo (y)
contains
subroutine foo (y)
use m
type (dt), allocatable :: x, y, z(:,:)
logical, parameter :: F = .false.
logical, parameter :: T = .true.
logical :: l
!$omp parallel private (x, y, z)
if (allocated (x) .or. allocated (y) .or. allocated (z)) call abort
!$omp end parallel
!$omp parallel firstprivate (x, y, z)
if (allocated (x) .or. allocated (y) .or. allocated (z)) call abort
!$omp end parallel
l = F
!$omp parallel sections lastprivate (x, y, z) firstprivate (l)
!$omp section
if (.not. l) then
if (allocated (x) .or. allocated (y) .or. allocated (z)) call abort
end if
!$omp section
if (.not. l) then
if (allocated (x) .or. allocated (y) .or. allocated (z)) call abort
end if
allocate (x, y, z(-3:-3,2:3))
call alloc_dt (x, 5, F, 0, 0, T, T, -1, -1, -1, -1, T)
call ver_dt (x, 5, F, 0, 0, T, T, -1, -1, -1, -1, T)
call alloc_dt (y, 23, T, 0, 1, T, T, 2, 2, 2, 2, F)
call ver_dt (y, 23, T, 0, 1, T, T, 2, 2, 2, 2, F)
call alloc_dt (z(-3,2), 5, F, 0, 0, T, T, -1, -1, -1, -1, T)
call ver_dt (z(-3,2), 5, F, 0, 0, T, T, -1, -1, -1, -1, T)
call alloc_dt (z(-3,3), 23, T, 0, 1, T, T, 2, 2, 2, 2, F)
call ver_dt (z(-3,3), 23, T, 0, 1, T, T, 2, 2, 2, 2, F)
!$omp section
!$omp end parallel sections
if (.not.allocated (x) .or. .not.allocated (y)) call abort
if (.not.allocated (z)) call abort
if (lbound (z, 1) /= -3 .or. ubound (z, 1) /= -3) call abort
if (lbound (z, 2) /= 2 .or. ubound (z, 2) /= 3) call abort
call ver_dt (x, 5, F, 0, 0, T, T, -1, -1, -1, -1, T)
call ver_dt (y, 23, T, 0, 1, T, T, 2, 2, 2, 2, F)
call ver_dt (z(-3,2), 5, F, 0, 0, T, T, -1, -1, -1, -1, T)
call ver_dt (z(-3,3), 23, T, 0, 1, T, T, 2, 2, 2, 2, F)
call alloc_dt (x, 0, F, 0, 0, F, F, 0, 0, 0, 0, F)
call ver_dt (x, 0, F, 0, 0, F, F, 0, 0, 0, 0, F)
call alloc_dt (y, 0, F, 0, 0, F, F, 0, 0, 0, 0, F)
call ver_dt (y, 0, F, 0, 0, F, F, 0, 0, 0, 0, F)
call alloc_dt (z(-3,2), 0, F, 0, 0, F, F, 0, 0, 0, 0, F)
call ver_dt (z(-3,2), 0, F, 0, 0, F, F, 0, 0, 0, 0, F)
call alloc_dt (z(-3,3), 0, F, 0, 0, F, F, 0, 0, 0, 0, F)
call ver_dt (z(-3,3), 0, F, 0, 0, F, F, 0, 0, 0, 0, F)
!$omp parallel private (x, y, z)
call ver_dt (x, 0, F, 0, 0, F, F, 0, 0, 0, 0, F)
call alloc_dt (x, 4, T, -3, -1, T, T, -1, -1, 2, 3, T)
call ver_dt (x, 4, T, -3, -1, T, T, -1, -1, 2, 3, T)
call ver_dt (y, 0, F, 0, 0, F, F, 0, 0, 0, 0, F)
call alloc_dt (y, 14, T, 3, 4, F, T, 1, 1, 2, 4, T)
call ver_dt (y, 14, T, 3, 4, F, T, 1, 1, 2, 4, T)
call ver_dt (z(-3,2), 0, F, 0, 0, F, F, 0, 0, 0, 0, F)
call alloc_dt (z(-3,2), 4, T, -3, -1, T, T, -1, -1, 2, 3, T)
call ver_dt (z(-3,2), 4, T, -3, -1, T, T, -1, -1, 2, 3, T)
call ver_dt (z(-3,3), 0, F, 0, 0, F, F, 0, 0, 0, 0, F)
call alloc_dt (z(-3,3), 14, T, 3, 4, F, T, 1, 1, 2, 4, T)
call ver_dt (z(-3,3), 14, T, 3, 4, F, T, 1, 1, 2, 4, T)
!$omp end parallel
call ver_dt (x, 0, F, 0, 0, F, F, 0, 0, 0, 0, F)
call alloc_dt (x, 4, T, -3, -1, T, T, -1, -1, 2, 3, T)
call ver_dt (y, 0, F, 0, 0, F, F, 0, 0, 0, 0, F)
call alloc_dt (y, 14, T, 3, 4, F, T, 1, 1, 2, 4, T)
call ver_dt (z(-3,2), 0, F, 0, 0, F, F, 0, 0, 0, 0, F)
call alloc_dt (z(-3,2), 4, T, -3, -1, T, T, -1, -1, 2, 3, T)
call ver_dt (z(-3,3), 0, F, 0, 0, F, F, 0, 0, 0, 0, F)
call alloc_dt (z(-3,3), 14, T, 3, 4, F, T, 1, 1, 2, 4, T)
!$omp parallel private (x, y, z)
call ver_dt (x, 0, T, -3, -1, T, T, -1, -1, 2, 3, T)
call ver_dt (y, 0, T, 3, 4, F, T, 1, 1, 2, 4, T)
deallocate (x%h, x%k)
deallocate (y%h)
allocate (y%k)
call ver_dt (z(-3,2), 0, T, -3, -1, T, T, -1, -1, 2, 3, T)
call ver_dt (z(-3,3), 0, T, 3, 4, F, T, 1, 1, 2, 4, T)
deallocate (z(-3,2)%h, z(-3,2)%k)
deallocate (z(-3,3)%h)
allocate (z(-3,3)%k)
!$omp end parallel
call alloc_dt (x, 5, T, 1, 2, F, T, 2, 3, -2, -2, F)
call alloc_dt (y, 15, F, 0, 0, T, T, 2, 2, 2, 2, T)
call alloc_dt (z(-3,2), 5, T, 1, 2, F, T, 2, 3, -2, -2, F)
call alloc_dt (z(-3,3), 15, F, 0, 0, T, T, 2, 2, 2, 2, T)
!$omp parallel firstprivate (x, y, z)
call ver_dt (x, 5, T, 1, 2, F, T, 2, 3, -2, -2, F)
call alloc_dt (x, 4, T, -3, -1, T, T, -1, -1, 2, 3, T)
call ver_dt (x, 4, T, -3, -1, T, T, -1, -1, 2, 3, T)
call ver_dt (y, 15, F, 0, 0, T, T, 2, 2, 2, 2, T)
call alloc_dt (y, 4, T, 3, 4, T, T, 1, 1, 2, 4, T)
call ver_dt (y, 4, T, 3, 4, T, T, 1, 1, 2, 4, T)
call ver_dt (z(-3,2), 5, T, 1, 2, F, T, 2, 3, -2, -2, F)
call alloc_dt (z(-3,2), 4, T, -3, -1, T, T, -1, -1, 2, 3, T)
call ver_dt (z(-3,2), 4, T, -3, -1, T, T, -1, -1, 2, 3, T)
call ver_dt (z(-3,3), 15, F, 0, 0, T, T, 2, 2, 2, 2, T)
call alloc_dt (z(-3,3), 4, T, 3, 4, T, T, 1, 1, 2, 4, T)
call ver_dt (z(-3,3), 4, T, 3, 4, T, T, 1, 1, 2, 4, T)
!$omp end parallel
call ver_dt (x, 5, T, 1, 2, F, T, 2, 3, -2, -2, F)
call alloc_dt (x, 4, F, 0, 0, F, F, 0, 0, 0, 0, F)
call ver_dt (y, 15, F, 0, 0, T, T, 2, 2, 2, 2, T)
call alloc_dt (y, 16, F, 0, 0, F, F, 0, 0, 0, 0, F)
call ver_dt (z(-3,2), 5, T, 1, 2, F, T, 2, 3, -2, -2, F)
call alloc_dt (z(-3,2), 4, F, 0, 0, F, F, 0, 0, 0, 0, F)
call ver_dt (z(-3,3), 15, F, 0, 0, T, T, 2, 2, 2, 2, T)
call alloc_dt (z(-3,3), 16, F, 0, 0, F, F, 0, 0, 0, 0, F)
!$omp parallel firstprivate (x, y, z)
call ver_dt (x, 4, F, 0, 0, F, F, 0, 0, 0, 0, F)
call alloc_dt (x, 4, T, -3, -1, T, T, -1, -1, 2, 3, T)
call ver_dt (x, 4, T, -3, -1, T, T, -1, -1, 2, 3, T)
call ver_dt (y, 16, F, 0, 0, F, F, 0, 0, 0, 0, F)
call alloc_dt (y, 17, T, 1, 2, F, T, 2, 2, 3, 3, F)
call ver_dt (y, 17, T, 1, 2, F, T, 2, 2, 3, 3, F)
call ver_dt (z(-3,2), 4, F, 0, 0, F, F, 0, 0, 0, 0, F)
call alloc_dt (z(-3,2), 4, T, -3, -1, T, T, -1, -1, 2, 3, T)
call ver_dt (z(-3,2), 4, T, -3, -1, T, T, -1, -1, 2, 3, T)
call ver_dt (z(-3,3), 16, F, 0, 0, F, F, 0, 0, 0, 0, F)
call alloc_dt (z(-3,3), 17, T, 1, 2, F, T, 2, 2, 3, 3, F)
call ver_dt (z(-3,3), 17, T, 1, 2, F, T, 2, 2, 3, 3, F)
!$omp end parallel
call ver_dt (x, 4, F, 0, 0, F, F, 0, 0, 0, 0, F)
call ver_dt (y, 16, F, 0, 0, F, F, 0, 0, 0, 0, F)
call alloc_dt (y, 18, T, 0, 1, T, T, 0, 1, 0, 1, T)
call ver_dt (z(-3,2), 4, F, 0, 0, F, F, 0, 0, 0, 0, F)
call ver_dt (z(-3,3), 16, F, 0, 0, F, F, 0, 0, 0, 0, F)
call alloc_dt (z(-3,3), 18, T, 0, 1, T, T, 0, 1, 0, 1, T)
l = F
!$omp parallel sections lastprivate (x, y, z) firstprivate (l)
!$omp section
if (l) then
call ver_dt (x, 9, T, 1, 1, F, F, 0, 0, 0, 0, T)
call ver_dt (y, 21, F, 0, 0, T, T, 1, 2, 3, 4, T)
call ver_dt (z(-3,2), 9, T, 1, 1, F, F, 0, 0, 0, 0, T)
call ver_dt (z(-3,3), 21, F, 0, 0, T, T, 1, 2, 3, 4, T)
else
call ver_dt (x, 0, F, 0, 0, F, F, 0, 0, 0, 0, F)
call ver_dt (y, 0, T, 0, 1, T, T, 0, 1, 0, 1, T)
call ver_dt (z(-3,2), 0, F, 0, 0, F, F, 0, 0, 0, 0, F)
call ver_dt (z(-3,3), 0, T, 0, 1, T, T, 0, 1, 0, 1, T)
end if
l = T
call alloc_dt (x, 7, T, 1, 1, T, T, 1, 2, 3, 3, T)
call ver_dt (x, 7, T, 1, 1, T, T, 1, 2, 3, 3, T)
call alloc_dt (y, 20, T, 0, 0, F, T, 2, 2, 3, 4, F)
call ver_dt (y, 20, T, 0, 0, F, T, 2, 2, 3, 4, F)
call alloc_dt (z(-3,2), 7, T, 1, 1, T, T, 1, 2, 3, 3, T)
call ver_dt (z(-3,2), 7, T, 1, 1, T, T, 1, 2, 3, 3, T)
call alloc_dt (z(-3,3), 20, T, 0, 0, F, T, 2, 2, 3, 4, F)
call ver_dt (z(-3,3), 20, T, 0, 0, F, T, 2, 2, 3, 4, F)
!$omp section
if (l) then
call ver_dt (x, 7, T, 1, 1, T, T, 1, 2, 3, 3, T)
call ver_dt (y, 20, T, 0, 0, F, T, 2, 2, 3, 4, F)
call ver_dt (z(-3,2), 7, T, 1, 1, T, T, 1, 2, 3, 3, T)
call ver_dt (z(-3,3), 20, T, 0, 0, F, T, 2, 2, 3, 4, F)
else
call ver_dt (x, 0, F, 0, 0, F, F, 0, 0, 0, 0, F)
call ver_dt (y, 0, T, 0, 1, T, T, 0, 1, 0, 1, T)
call ver_dt (z(-3,2), 0, F, 0, 0, F, F, 0, 0, 0, 0, F)
call ver_dt (z(-3,3), 0, T, 0, 1, T, T, 0, 1, 0, 1, T)
end if
l = T
call alloc_dt (x, 9, T, 1, 1, F, F, 0, 0, 0, 0, T)
call ver_dt (x, 9, T, 1, 1, F, F, 0, 0, 0, 0, T)
call alloc_dt (y, 21, F, 0, 0, T, T, 1, 2, 3, 4, T)
call ver_dt (y, 21, F, 0, 0, T, T, 1, 2, 3, 4, T)
call alloc_dt (z(-3,2), 9, T, 1, 1, F, F, 0, 0, 0, 0, T)
call ver_dt (z(-3,2), 9, T, 1, 1, F, F, 0, 0, 0, 0, T)
call alloc_dt (z(-3,3), 21, F, 0, 0, T, T, 1, 2, 3, 4, T)
call ver_dt (z(-3,3), 21, F, 0, 0, T, T, 1, 2, 3, 4, T)
!$omp section
!$omp end parallel sections
call ver_dt (x, 9, T, 1, 1, F, F, 0, 0, 0, 0, T)
call ver_dt (y, 21, F, 0, 0, T, T, 1, 2, 3, 4, T)
call ver_dt (z(-3,2), 9, T, 1, 1, F, F, 0, 0, 0, 0, T)
call ver_dt (z(-3,3), 21, F, 0, 0, T, T, 1, 2, 3, 4, T)
!$omp parallel sections lastprivate (x, y, z) firstprivate (l)
!$omp section
if (l) then
call ver_dt (x, 5, F, 0, 0, T, T, -1, -1, -1, -1, T)
call ver_dt (y, 23, T, 0, 1, T, T, 2, 2, 2, 2, F)
call ver_dt (z(-3,2), 5, F, 0, 0, T, T, -1, -1, -1, -1, T)
call ver_dt (z(-3,3), 23, T, 0, 1, T, T, 2, 2, 2, 2, F)
else
call ver_dt (x, 0, T, 1, 1, F, F, 0, 0, 0, 0, T)
call ver_dt (y, 0, F, 0, 0, T, T, 1, 2, 3, 4, T)
call ver_dt (z(-3,2), 0, T, 1, 1, F, F, 0, 0, 0, 0, T)
call ver_dt (z(-3,3), 0, F, 0, 0, T, T, 1, 2, 3, 4, T)
end if
l = T
call alloc_dt (x, 3, F, 0, 0, T, T, 0, 1, 0, 1, F)
call ver_dt (x, 3, F, 0, 0, T, T, 0, 1, 0, 1, F)
call alloc_dt (y, 22, T, 5, 5, F, T, 2, 3, 2, 2, T)
call ver_dt (y, 22, T, 5, 5, F, T, 2, 3, 2, 2, T)
call alloc_dt (z(-3,2), 3, F, 0, 0, T, T, 0, 1, 0, 1, F)
call ver_dt (z(-3,2), 3, F, 0, 0, T, T, 0, 1, 0, 1, F)
call alloc_dt (z(-3,3), 22, T, 5, 5, F, T, 2, 3, 2, 2, T)
call ver_dt (z(-3,3), 22, T, 5, 5, F, T, 2, 3, 2, 2, T)
!$omp section
if (l) then
call ver_dt (x, 3, F, 0, 0, T, T, 0, 1, 0, 1, F)
call ver_dt (y, 22, T, 5, 5, F, T, 2, 3, 2, 2, T)
call ver_dt (z(-3,2), 3, F, 0, 0, T, T, 0, 1, 0, 1, F)
call ver_dt (z(-3,3), 22, T, 5, 5, F, T, 2, 3, 2, 2, T)
else
call ver_dt (x, 0, T, 1, 1, F, F, 0, 0, 0, 0, T)
call ver_dt (y, 0, F, 0, 0, T, T, 1, 2, 3, 4, T)
call ver_dt (z(-3,2), 0, T, 1, 1, F, F, 0, 0, 0, 0, T)
call ver_dt (z(-3,3), 0, F, 0, 0, T, T, 1, 2, 3, 4, T)
end if
l = T
call alloc_dt (x, 5, F, 0, 0, T, T, -1, -1, -1, -1, T)
call ver_dt (x, 5, F, 0, 0, T, T, -1, -1, -1, -1, T)
call alloc_dt (y, 23, T, 0, 1, T, T, 2, 2, 2, 2, F)
call ver_dt (y, 23, T, 0, 1, T, T, 2, 2, 2, 2, F)
call alloc_dt (z(-3,2), 5, F, 0, 0, T, T, -1, -1, -1, -1, T)
call ver_dt (z(-3,2), 5, F, 0, 0, T, T, -1, -1, -1, -1, T)
call alloc_dt (z(-3,3), 23, T, 0, 1, T, T, 2, 2, 2, 2, F)
call ver_dt (z(-3,3), 23, T, 0, 1, T, T, 2, 2, 2, 2, F)
!$omp section
!$omp end parallel sections
call ver_dt (x, 5, F, 0, 0, T, T, -1, -1, -1, -1, T)
call ver_dt (y, 23, T, 0, 1, T, T, 2, 2, 2, 2, F)
call ver_dt (z(-3,2), 5, F, 0, 0, T, T, -1, -1, -1, -1, T)
call ver_dt (z(-3,3), 23, T, 0, 1, T, T, 2, 2, 2, 2, F)
!$omp parallel private (x, y, z)
call ver_dt (x, 0, F, 0, 0, T, T, -1, -1, -1, -1, T)
call ver_dt (y, 0, T, 0, 1, T, T, 2, 2, 2, 2, F)
call ver_dt (z(-3,2), 0, F, 0, 0, T, T, -1, -1, -1, -1, T)
call ver_dt (z(-3,3), 0, T, 0, 1, T, T, 2, 2, 2, 2, F)
!$omp single
call alloc_dt (x, 3, F, 0, 0, T, T, 0, 1, 0, 1, F)
call alloc_dt (y, 22, T, 5, 5, F, T, 2, 3, 2, 2, T)
call alloc_dt (z(-3,2), 3, F, 0, 0, T, T, 0, 1, 0, 1, F)
call alloc_dt (z(-3,3), 22, T, 5, 5, F, T, 2, 3, 2, 2, T)
!$omp end single copyprivate (x, y, z)
call ver_dt (x, 3, F, 0, 0, T, T, 0, 1, 0, 1, F)
call ver_dt (y, 22, T, 5, 5, F, T, 2, 3, 2, 2, T)
call ver_dt (z(-3,2), 3, F, 0, 0, T, T, 0, 1, 0, 1, F)
call ver_dt (z(-3,3), 22, T, 5, 5, F, T, 2, 3, 2, 2, T)
!$omp end parallel
call ver_dt (x, 5, F, 0, 0, T, T, -1, -1, -1, -1, T)
call ver_dt (y, 23, T, 0, 1, T, T, 2, 2, 2, 2, F)
call ver_dt (z(-3,2), 5, F, 0, 0, T, T, -1, -1, -1, -1, T)
call ver_dt (z(-3,3), 23, T, 0, 1, T, T, 2, 2, 2, 2, F)
end subroutine foo
end

372
libgomp/testsuite/libgomp.fortran/alloc-comp-3.f90 Normal file
View File

@ -0,0 +1,372 @@
! { dg-do run }
! Don't cycle by default through all options, just test -O0 and -O2,
! as this is quite large test.
! { dg-skip-if "" { ! run_expensive_tests } { "*" } { "-O0" "-O2" } }
module m
type dl
integer :: a, b
integer, allocatable :: c(:,:)
integer :: d, e
integer, allocatable :: f
end type
type dt
integer :: g
type (dl), allocatable :: h(:)
integer :: i
type (dl) :: j(2, 2)
type (dl), allocatable :: k
end type
contains
subroutine ver_dl (obj, val, c, cl1, cu1, cl2, cu2, f)
type (dl), intent (in) :: obj
integer, intent (in) :: val, cl1, cu1, cl2, cu2
logical, intent (in) :: c, f
if ((c .neqv. allocated (obj%c)) .or. (f .neqv. allocated (obj%f))) call abort
if (c) then
if (lbound (obj%c, 1) /= cl1 .or. ubound (obj%c, 1) /= cu1) call abort
if (lbound (obj%c, 2) /= cl2 .or. ubound (obj%c, 2) /= cu2) call abort
end if
if (val /= 0) then
if (obj%a /= val .or. obj%b /= val) call abort
if (obj%d /= val .or. obj%e /= val) call abort
if (c) then
if (any (obj%c /= val)) call abort
end if
if (f) then
if (obj%f /= val) call abort
end if
end if
end subroutine ver_dl
subroutine ver_dt (obj, val, h, hl, hu, k, c, cl1, cu1, cl2, cu2, f)
type (dt), intent (in) :: obj
integer, intent (in) :: val, hl, hu, cl1, cu1, cl2, cu2
logical, intent (in) :: h, k, c, f
integer :: i, j
if ((h .neqv. allocated (obj%h)) .or. (k .neqv. allocated (obj%k))) call abort
if (h) then
if (lbound (obj%h, 1) /= hl .or. ubound (obj%h, 1) /= hu) call abort
do i = hl, hu
call ver_dl (obj%h(i), val, c, cl1, cu1, cl2, cu2, f)
end do
end if
do i = 1, 2
do j = 1, 2
call ver_dl (obj%j(i, j), val, c, cl1, cu1, cl2, cu2, f)
end do
end do
if (k) call ver_dl (obj%k, val, c, cl1, cu1, cl2, cu2, f)
if (val /= 0) then
if (obj%g /= val .or. obj%i /= val) call abort
end if
end subroutine ver_dt
subroutine alloc_dl (obj, val, c, cl1, cu1, cl2, cu2, f)
type (dl), intent (inout) :: obj
integer, intent (in) :: val, cl1, cu1, cl2, cu2
logical, intent (in) :: c, f
if (val /= 0) then
obj%a = val
obj%b = val
obj%d = val
obj%e = val
end if
if (allocated (obj%c)) deallocate (obj%c)
if (c) then
allocate (obj%c(cl1:cu1, cl2:cu2))
if (val /= 0) obj%c = val
end if
if (f) then
if (.not.allocated (obj%f)) allocate (obj%f)
if (val /= 0) obj%f = val
else
if (allocated (obj%f)) deallocate (obj%f)
end if
end subroutine alloc_dl
subroutine alloc_dt (obj, val, h, hl, hu, k, c, cl1, cu1, cl2, cu2, f)
type (dt), intent (inout) :: obj
integer, intent (in) :: val, hl, hu, cl1, cu1, cl2, cu2
logical, intent (in) :: h, k, c, f
integer :: i, j
if (val /= 0) then
obj%g = val
obj%i = val
end if
if (allocated (obj%h)) deallocate (obj%h)
if (h) then
allocate (obj%h(hl:hu))
do i = hl, hu
call alloc_dl (obj%h(i), val, c, cl1, cu1, cl2, cu2, f)
end do
end if
do i = 1, 2
do j = 1, 2
call alloc_dl (obj%j(i, j), val, c, cl1, cu1, cl2, cu2, f)
end do
end do
if (k) then
if (.not.allocated (obj%k)) allocate (obj%k)
call alloc_dl (obj%k, val, c, cl1, cu1, cl2, cu2, f)
else
if (allocated (obj%k)) deallocate (obj%k)
end if
end subroutine alloc_dt
end module m
use m
type (dt), allocatable :: z(:,:)
type (dt) :: y(2:3)
call foo (y, z, 4)
contains
subroutine foo (y, z, n)
use m
integer :: n
type (dt) :: x(2:n), y(3:)
type (dt), allocatable :: z(:,:)
logical, parameter :: F = .false.
logical, parameter :: T = .true.
logical :: l
if (lbound (x, 1) /= 2 .or. ubound (x, 1) /= 4) call abort
if (lbound (y, 1) /= 3 .or. ubound (y, 1) /= 4) call abort
call ver_dt (x(2), 0, F, 0, 0, F, F, 0, 0, 0, 0, F)
call ver_dt (x(n), 0, F, 0, 0, F, F, 0, 0, 0, 0, F)
call ver_dt (y(3), 0, F, 0, 0, F, F, 0, 0, 0, 0, F)
call ver_dt (y(4), 0, F, 0, 0, F, F, 0, 0, 0, 0, F)
!$omp parallel private (z)
if (allocated (z)) call abort
!$omp end parallel
!$omp parallel firstprivate (z)
if (allocated (z)) call abort
!$omp end parallel
l = F
!$omp parallel sections lastprivate (z) firstprivate (l)
!$omp section
if (.not. l) then
if (allocated (z)) call abort
end if
!$omp section
if (.not. l) then
if (allocated (z)) call abort
end if
allocate (z(-3:-3,2:3))
call alloc_dt (z(-3,2), 5, F, 0, 0, T, T, -1, -1, -1, -1, T)
call ver_dt (z(-3,2), 5, F, 0, 0, T, T, -1, -1, -1, -1, T)
call alloc_dt (z(-3,3), 23, T, 0, 1, T, T, 2, 2, 2, 2, F)
call ver_dt (z(-3,3), 23, T, 0, 1, T, T, 2, 2, 2, 2, F)
!$omp section
!$omp end parallel sections
if (.not.allocated (z)) call abort
if (lbound (z, 1) /= -3 .or. ubound (z, 1) /= -3) call abort
if (lbound (z, 2) /= 2 .or. ubound (z, 2) /= 3) call abort
call ver_dt (z(-3,2), 5, F, 0, 0, T, T, -1, -1, -1, -1, T)
call ver_dt (z(-3,3), 23, T, 0, 1, T, T, 2, 2, 2, 2, F)
call ver_dt (x(n - 1), 0, F, 0, 0, F, F, 0, 0, 0, 0, F)
call ver_dt (y(4), 0, F, 0, 0, F, F, 0, 0, 0, 0, F)
call alloc_dt (z(-3,2), 0, F, 0, 0, F, F, 0, 0, 0, 0, F)
call ver_dt (z(-3,2), 0, F, 0, 0, F, F, 0, 0, 0, 0, F)
call alloc_dt (z(-3,3), 0, F, 0, 0, F, F, 0, 0, 0, 0, F)
call ver_dt (z(-3,3), 0, F, 0, 0, F, F, 0, 0, 0, 0, F)
!$omp parallel private (x, y, z)
call ver_dt (x(n - 1), 0, F, 0, 0, F, F, 0, 0, 0, 0, F)
call alloc_dt (x(n - 1), 4, T, -3, -1, T, T, -1, -1, 2, 3, T)
call ver_dt (x(n - 1), 4, T, -3, -1, T, T, -1, -1, 2, 3, T)
call ver_dt (y(4), 0, F, 0, 0, F, F, 0, 0, 0, 0, F)
call alloc_dt (y(4), 14, T, 3, 4, F, T, 1, 1, 2, 4, T)
call ver_dt (y(4), 14, T, 3, 4, F, T, 1, 1, 2, 4, T)
call ver_dt (z(-3,2), 0, F, 0, 0, F, F, 0, 0, 0, 0, F)
call alloc_dt (z(-3,2), 4, T, -3, -1, T, T, -1, -1, 2, 3, T)
call ver_dt (z(-3,2), 4, T, -3, -1, T, T, -1, -1, 2, 3, T)
call ver_dt (z(-3,3), 0, F, 0, 0, F, F, 0, 0, 0, 0, F)
call alloc_dt (z(-3,3), 14, T, 3, 4, F, T, 1, 1, 2, 4, T)
call ver_dt (z(-3,3), 14, T, 3, 4, F, T, 1, 1, 2, 4, T)
!$omp end parallel
call ver_dt (x(n - 1), 0, F, 0, 0, F, F, 0, 0, 0, 0, F)
call alloc_dt (x(n - 1), 4, T, -3, -1, T, T, -1, -1, 2, 3, T)
call ver_dt (y(4), 0, F, 0, 0, F, F, 0, 0, 0, 0, F)
call alloc_dt (y(4), 14, T, 3, 4, F, T, 1, 1, 2, 4, T)
call ver_dt (z(-3,2), 0, F, 0, 0, F, F, 0, 0, 0, 0, F)
call alloc_dt (z(-3,2), 4, T, -3, -1, T, T, -1, -1, 2, 3, T)
call ver_dt (z(-3,3), 0, F, 0, 0, F, F, 0, 0, 0, 0, F)
call alloc_dt (z(-3,3), 14, T, 3, 4, F, T, 1, 1, 2, 4, T)
!$omp parallel private (x, y, z)
call ver_dt (x(n - 1), 0, T, -3, -1, T, T, -1, -1, 2, 3, T)
call ver_dt (y(4), 0, T, 3, 4, F, T, 1, 1, 2, 4, T)
deallocate (x(n - 1)%h, x(n - 1)%k)
deallocate (y(4)%h)
allocate (y(4)%k)
call ver_dt (z(-3,2), 0, T, -3, -1, T, T, -1, -1, 2, 3, T)
call ver_dt (z(-3,3), 0, T, 3, 4, F, T, 1, 1, 2, 4, T)
deallocate (z(-3,2)%h, z(-3,2)%k)
deallocate (z(-3,3)%h)
allocate (z(-3,3)%k)
!$omp end parallel
call alloc_dt (x(n - 1), 5, T, 1, 2, F, T, 2, 3, -2, -2, F)
call alloc_dt (y(4), 15, F, 0, 0, T, T, 2, 2, 2, 2, T)
call alloc_dt (z(-3,2), 5, T, 1, 2, F, T, 2, 3, -2, -2, F)
call alloc_dt (z(-3,3), 15, F, 0, 0, T, T, 2, 2, 2, 2, T)
!$omp parallel firstprivate (x, y, z)
if (lbound (x, 1) /= 2 .or. ubound (x, 1) /= 4) call abort
if (lbound (y, 1) /= 3 .or. ubound (y, 1) /= 4) call abort
call ver_dt (x(n - 1), 5, T, 1, 2, F, T, 2, 3, -2, -2, F)
call alloc_dt (x(n - 1), 4, T, -3, -1, T, T, -1, -1, 2, 3, T)
call ver_dt (x(n - 1), 4, T, -3, -1, T, T, -1, -1, 2, 3, T)
call ver_dt (y(4), 15, F, 0, 0, T, T, 2, 2, 2, 2, T)
call alloc_dt (y(4), 4, T, 3, 4, T, T, 1, 1, 2, 4, T)
call ver_dt (y(4), 4, T, 3, 4, T, T, 1, 1, 2, 4, T)
call ver_dt (z(-3,2), 5, T, 1, 2, F, T, 2, 3, -2, -2, F)
call alloc_dt (z(-3,2), 4, T, -3, -1, T, T, -1, -1, 2, 3, T)
call ver_dt (z(-3,2), 4, T, -3, -1, T, T, -1, -1, 2, 3, T)
call ver_dt (z(-3,3), 15, F, 0, 0, T, T, 2, 2, 2, 2, T)
call alloc_dt (z(-3,3), 4, T, 3, 4, T, T, 1, 1, 2, 4, T)
call ver_dt (z(-3,3), 4, T, 3, 4, T, T, 1, 1, 2, 4, T)
!$omp end parallel
call ver_dt (x(n - 1), 5, T, 1, 2, F, T, 2, 3, -2, -2, F)
call alloc_dt (x(n - 1), 4, F, 0, 0, F, F, 0, 0, 0, 0, F)
call ver_dt (y(4), 15, F, 0, 0, T, T, 2, 2, 2, 2, T)
call alloc_dt (y(4), 16, F, 0, 0, F, F, 0, 0, 0, 0, F)
call ver_dt (z(-3,2), 5, T, 1, 2, F, T, 2, 3, -2, -2, F)
call alloc_dt (z(-3,2), 4, F, 0, 0, F, F, 0, 0, 0, 0, F)
call ver_dt (z(-3,3), 15, F, 0, 0, T, T, 2, 2, 2, 2, T)
call alloc_dt (z(-3,3), 16, F, 0, 0, F, F, 0, 0, 0, 0, F)
!$omp parallel firstprivate (x, y, z)
call ver_dt (x(n - 1), 4, F, 0, 0, F, F, 0, 0, 0, 0, F)
call alloc_dt (x(n - 1), 4, T, -3, -1, T, T, -1, -1, 2, 3, T)
call ver_dt (x(n - 1), 4, T, -3, -1, T, T, -1, -1, 2, 3, T)
call ver_dt (y(4), 16, F, 0, 0, F, F, 0, 0, 0, 0, F)
call alloc_dt (y(4), 17, T, 1, 2, F, T, 2, 2, 3, 3, F)
call ver_dt (y(4), 17, T, 1, 2, F, T, 2, 2, 3, 3, F)
call ver_dt (z(-3,2), 4, F, 0, 0, F, F, 0, 0, 0, 0, F)
call alloc_dt (z(-3,2), 4, T, -3, -1, T, T, -1, -1, 2, 3, T)
call ver_dt (z(-3,2), 4, T, -3, -1, T, T, -1, -1, 2, 3, T)
call ver_dt (z(-3,3), 16, F, 0, 0, F, F, 0, 0, 0, 0, F)
call alloc_dt (z(-3,3), 17, T, 1, 2, F, T, 2, 2, 3, 3, F)
call ver_dt (z(-3,3), 17, T, 1, 2, F, T, 2, 2, 3, 3, F)
!$omp end parallel
call ver_dt (x(n - 1), 4, F, 0, 0, F, F, 0, 0, 0, 0, F)
call ver_dt (y(4), 16, F, 0, 0, F, F, 0, 0, 0, 0, F)
call alloc_dt (y(4), 18, T, 0, 1, T, T, 0, 1, 0, 1, T)
call ver_dt (z(-3,2), 4, F, 0, 0, F, F, 0, 0, 0, 0, F)
call ver_dt (z(-3,3), 16, F, 0, 0, F, F, 0, 0, 0, 0, F)
call alloc_dt (z(-3,3), 18, T, 0, 1, T, T, 0, 1, 0, 1, T)
l = F
!$omp parallel sections lastprivate (x, y, z) firstprivate (l)
!$omp section
if (l) then
call ver_dt (x(n - 1), 9, T, 1, 1, F, F, 0, 0, 0, 0, T)
call ver_dt (y(4), 21, F, 0, 0, T, T, 1, 2, 3, 4, T)
call ver_dt (z(-3,2), 9, T, 1, 1, F, F, 0, 0, 0, 0, T)
call ver_dt (z(-3,3), 21, F, 0, 0, T, T, 1, 2, 3, 4, T)
else
call ver_dt (x(n - 1), 0, F, 0, 0, F, F, 0, 0, 0, 0, F)
call ver_dt (y(4), 0, T, 0, 1, T, T, 0, 1, 0, 1, T)
call ver_dt (z(-3,2), 0, F, 0, 0, F, F, 0, 0, 0, 0, F)
call ver_dt (z(-3,3), 0, T, 0, 1, T, T, 0, 1, 0, 1, T)
end if
l = T
call alloc_dt (x(n - 1), 7, T, 1, 1, T, T, 1, 2, 3, 3, T)
call ver_dt (x(n - 1), 7, T, 1, 1, T, T, 1, 2, 3, 3, T)
call alloc_dt (y(4), 20, T, 0, 0, F, T, 2, 2, 3, 4, F)
call ver_dt (y(4), 20, T, 0, 0, F, T, 2, 2, 3, 4, F)
call alloc_dt (z(-3,2), 7, T, 1, 1, T, T, 1, 2, 3, 3, T)
call ver_dt (z(-3,2), 7, T, 1, 1, T, T, 1, 2, 3, 3, T)
call alloc_dt (z(-3,3), 20, T, 0, 0, F, T, 2, 2, 3, 4, F)
call ver_dt (z(-3,3), 20, T, 0, 0, F, T, 2, 2, 3, 4, F)
!$omp section
if (l) then
call ver_dt (x(n - 1), 7, T, 1, 1, T, T, 1, 2, 3, 3, T)
call ver_dt (y(4), 20, T, 0, 0, F, T, 2, 2, 3, 4, F)
call ver_dt (z(-3,2), 7, T, 1, 1, T, T, 1, 2, 3, 3, T)
call ver_dt (z(-3,3), 20, T, 0, 0, F, T, 2, 2, 3, 4, F)
else
call ver_dt (x(n - 1), 0, F, 0, 0, F, F, 0, 0, 0, 0, F)
call ver_dt (y(4), 0, T, 0, 1, T, T, 0, 1, 0, 1, T)
call ver_dt (z(-3,2), 0, F, 0, 0, F, F, 0, 0, 0, 0, F)
call ver_dt (z(-3,3), 0, T, 0, 1, T, T, 0, 1, 0, 1, T)
end if
l = T
call alloc_dt (x(n - 1), 9, T, 1, 1, F, F, 0, 0, 0, 0, T)
call ver_dt (x(n - 1), 9, T, 1, 1, F, F, 0, 0, 0, 0, T)
call alloc_dt (y(4), 21, F, 0, 0, T, T, 1, 2, 3, 4, T)
call ver_dt (y(4), 21, F, 0, 0, T, T, 1, 2, 3, 4, T)
call alloc_dt (z(-3,2), 9, T, 1, 1, F, F, 0, 0, 0, 0, T)
call ver_dt (z(-3,2), 9, T, 1, 1, F, F, 0, 0, 0, 0, T)
call alloc_dt (z(-3,3), 21, F, 0, 0, T, T, 1, 2, 3, 4, T)
call ver_dt (z(-3,3), 21, F, 0, 0, T, T, 1, 2, 3, 4, T)
!$omp section
!$omp end parallel sections
call ver_dt (x(n - 1), 9, T, 1, 1, F, F, 0, 0, 0, 0, T)
call ver_dt (y(4), 21, F, 0, 0, T, T, 1, 2, 3, 4, T)
call ver_dt (z(-3,2), 9, T, 1, 1, F, F, 0, 0, 0, 0, T)
call ver_dt (z(-3,3), 21, F, 0, 0, T, T, 1, 2, 3, 4, T)
!$omp parallel sections lastprivate (x, y, z) firstprivate (l)
!$omp section
if (l) then
call ver_dt (x(n - 1), 5, F, 0, 0, T, T, -1, -1, -1, -1, T)
call ver_dt (y(4), 23, T, 0, 1, T, T, 2, 2, 2, 2, F)
call ver_dt (z(-3,2), 5, F, 0, 0, T, T, -1, -1, -1, -1, T)
call ver_dt (z(-3,3), 23, T, 0, 1, T, T, 2, 2, 2, 2, F)
else
call ver_dt (x(n - 1), 0, T, 1, 1, F, F, 0, 0, 0, 0, T)
call ver_dt (y(4), 0, F, 0, 0, T, T, 1, 2, 3, 4, T)
call ver_dt (z(-3,2), 0, T, 1, 1, F, F, 0, 0, 0, 0, T)
call ver_dt (z(-3,3), 0, F, 0, 0, T, T, 1, 2, 3, 4, T)
end if
l = T
call alloc_dt (x(n - 1), 3, F, 0, 0, T, T, 0, 1, 0, 1, F)
call ver_dt (x(n - 1), 3, F, 0, 0, T, T, 0, 1, 0, 1, F)
call alloc_dt (y(4), 22, T, 5, 5, F, T, 2, 3, 2, 2, T)
call ver_dt (y(4), 22, T, 5, 5, F, T, 2, 3, 2, 2, T)
call alloc_dt (z(-3,2), 3, F, 0, 0, T, T, 0, 1, 0, 1, F)
call ver_dt (z(-3,2), 3, F, 0, 0, T, T, 0, 1, 0, 1, F)
call alloc_dt (z(-3,3), 22, T, 5, 5, F, T, 2, 3, 2, 2, T)
call ver_dt (z(-3,3), 22, T, 5, 5, F, T, 2, 3, 2, 2, T)
!$omp section
if (l) then
call ver_dt (x(n - 1), 3, F, 0, 0, T, T, 0, 1, 0, 1, F)
call ver_dt (y(4), 22, T, 5, 5, F, T, 2, 3, 2, 2, T)
call ver_dt (z(-3,2), 3, F, 0, 0, T, T, 0, 1, 0, 1, F)
call ver_dt (z(-3,3), 22, T, 5, 5, F, T, 2, 3, 2, 2, T)
else
call ver_dt (x(n - 1), 0, T, 1, 1, F, F, 0, 0, 0, 0, T)
call ver_dt (y(4), 0, F, 0, 0, T, T, 1, 2, 3, 4, T)
call ver_dt (z(-3,2), 0, T, 1, 1, F, F, 0, 0, 0, 0, T)
call ver_dt (z(-3,3), 0, F, 0, 0, T, T, 1, 2, 3, 4, T)
end if
l = T
call alloc_dt (x(n - 1), 5, F, 0, 0, T, T, -1, -1, -1, -1, T)
call ver_dt (x(n - 1), 5, F, 0, 0, T, T, -1, -1, -1, -1, T)
call alloc_dt (y(4), 23, T, 0, 1, T, T, 2, 2, 2, 2, F)
call ver_dt (y(4), 23, T, 0, 1, T, T, 2, 2, 2, 2, F)
call alloc_dt (z(-3,2), 5, F, 0, 0, T, T, -1, -1, -1, -1, T)
call ver_dt (z(-3,2), 5, F, 0, 0, T, T, -1, -1, -1, -1, T)
call alloc_dt (z(-3,3), 23, T, 0, 1, T, T, 2, 2, 2, 2, F)
call ver_dt (z(-3,3), 23, T, 0, 1, T, T, 2, 2, 2, 2, F)
!$omp section
!$omp end parallel sections
call ver_dt (x(n - 1), 5, F, 0, 0, T, T, -1, -1, -1, -1, T)
call ver_dt (y(4), 23, T, 0, 1, T, T, 2, 2, 2, 2, F)
call ver_dt (z(-3,2), 5, F, 0, 0, T, T, -1, -1, -1, -1, T)
call ver_dt (z(-3,3), 23, T, 0, 1, T, T, 2, 2, 2, 2, F)
!$omp parallel private (x, y, z)
call ver_dt (x(n - 1), 0, F, 0, 0, T, T, -1, -1, -1, -1, T)
call ver_dt (y(4), 0, T, 0, 1, T, T, 2, 2, 2, 2, F)
call ver_dt (z(-3,2), 0, F, 0, 0, T, T, -1, -1, -1, -1, T)
call ver_dt (z(-3,3), 0, T, 0, 1, T, T, 2, 2, 2, 2, F)
!$omp single
call alloc_dt (x(n - 1), 3, F, 0, 0, T, T, 0, 1, 0, 1, F)
call alloc_dt (y(4), 22, T, 5, 5, F, T, 2, 3, 2, 2, T)
call alloc_dt (z(-3,2), 3, F, 0, 0, T, T, 0, 1, 0, 1, F)
call alloc_dt (z(-3,3), 22, T, 5, 5, F, T, 2, 3, 2, 2, T)
!$omp end single copyprivate (x, y, z)
call ver_dt (x(n - 1), 3, F, 0, 0, T, T, 0, 1, 0, 1, F)
call ver_dt (y(4), 22, T, 5, 5, F, T, 2, 3, 2, 2, T)
call ver_dt (z(-3,2), 3, F, 0, 0, T, T, 0, 1, 0, 1, F)
call ver_dt (z(-3,3), 22, T, 5, 5, F, T, 2, 3, 2, 2, T)
!$omp end parallel
call ver_dt (x(n - 1), 5, F, 0, 0, T, T, -1, -1, -1, -1, T)
call ver_dt (y(4), 23, T, 0, 1, T, T, 2, 2, 2, 2, F)
call ver_dt (z(-3,2), 5, F, 0, 0, T, T, -1, -1, -1, -1, T)
call ver_dt (z(-3,3), 23, T, 0, 1, T, T, 2, 2, 2, 2, F)
call ver_dt (x(2), 0, F, 0, 0, F, F, 0, 0, 0, 0, F)
call ver_dt (x(n), 0, F, 0, 0, F, F, 0, 0, 0, 0, F)
call ver_dt (y(3), 0, F, 0, 0, F, F, 0, 0, 0, 0, F)
end subroutine foo
end

112
libgomp/testsuite/libgomp.fortran/allocatable10.f90 Normal file
View File

@ -0,0 +1,112 @@
! { dg-do run }
integer, allocatable :: a, b(:), c(:,:)
integer :: i
!$omp declare reduction (foo : integer : omp_out = omp_out + omp_in) &
!$omp & initializer (omp_priv = 0)
if (allocated (a) .or. allocated (b) .or. allocated (c)) call abort
allocate (a, b(6:9), c(3, 8:9))
a = 0
b = 0
c = 0
if (.not.allocated (a)) call abort
if (.not.allocated (b) .or. size (b) /= 4) call abort
if (lbound (b, 1) /= 6 .or. ubound (b, 1) /= 9) call abort
if (.not.allocated (c) .or. size (c) /= 6) call abort
if (size (c, 1) /= 3 .or. size (c, 2) /= 2) call abort
if (lbound (c, 1) /= 1 .or. ubound (c, 1) /= 3) call abort
if (lbound (c, 2) /= 8 .or. ubound (c, 2) /= 9) call abort
!$omp parallel do reduction (+:a, b, c)
do i = 1, 10
if (.not.allocated (a)) call abort
if (.not.allocated (b) .or. size (b) /= 4) call abort
if (lbound (b, 1) /= 6 .or. ubound (b, 1) /= 9) call abort
if (.not.allocated (c) .or. size (c) /= 6) call abort
if (size (c, 1) /= 3 .or. size (c, 2) /= 2) call abort
if (lbound (c, 1) /= 1 .or. ubound (c, 1) /= 3) call abort
if (lbound (c, 2) /= 8 .or. ubound (c, 2) /= 9) call abort
a = a + i
b = b + 2 * i
c = c + 3 * i
end do
if (.not.allocated (a)) call abort
if (.not.allocated (b) .or. size (b) /= 4) call abort
if (lbound (b, 1) /= 6 .or. ubound (b, 1) /= 9) call abort
if (.not.allocated (c) .or. size (c) /= 6) call abort
if (size (c, 1) /= 3 .or. size (c, 2) /= 2) call abort
if (lbound (c, 1) /= 1 .or. ubound (c, 1) /= 3) call abort
if (lbound (c, 2) /= 8 .or. ubound (c, 2) /= 9) call abort
if (a /= 55 .or. any (b /= 110) .or. any (c /= 165)) call abort
a = 0
b = 0
c = 0
!$omp parallel do reduction (foo : a, b, c)
do i = 1, 10
if (.not.allocated (a)) call abort
if (.not.allocated (b) .or. size (b) /= 4) call abort
if (lbound (b, 1) /= 6 .or. ubound (b, 1) /= 9) call abort
if (.not.allocated (c) .or. size (c) /= 6) call abort
if (size (c, 1) /= 3 .or. size (c, 2) /= 2) call abort
if (lbound (c, 1) /= 1 .or. ubound (c, 1) /= 3) call abort
if (lbound (c, 2) /= 8 .or. ubound (c, 2) /= 9) call abort
a = a + i
b = b + 2 * i
c = c + 3 * i
end do
if (.not.allocated (a)) call abort
if (.not.allocated (b) .or. size (b) /= 4) call abort
if (lbound (b, 1) /= 6 .or. ubound (b, 1) /= 9) call abort
if (.not.allocated (c) .or. size (c) /= 6) call abort
if (size (c, 1) /= 3 .or. size (c, 2) /= 2) call abort
if (lbound (c, 1) /= 1 .or. ubound (c, 1) /= 3) call abort
if (lbound (c, 2) /= 8 .or. ubound (c, 2) /= 9) call abort
if (a /= 55 .or. any (b /= 110) .or. any (c /= 165)) call abort
a = 0
b = 0
c = 0
!$omp simd reduction (+:a, b, c)
do i = 1, 10
if (.not.allocated (a)) call abort
if (.not.allocated (b) .or. size (b) /= 4) call abort
if (lbound (b, 1) /= 6 .or. ubound (b, 1) /= 9) call abort
if (.not.allocated (c) .or. size (c) /= 6) call abort
if (size (c, 1) /= 3 .or. size (c, 2) /= 2) call abort
if (lbound (c, 1) /= 1 .or. ubound (c, 1) /= 3) call abort
if (lbound (c, 2) /= 8 .or. ubound (c, 2) /= 9) call abort
a = a + i
b = b + 2 * i
c = c + 3 * i
end do
if (.not.allocated (a)) call abort
if (.not.allocated (b) .or. size (b) /= 4) call abort
if (lbound (b, 1) /= 6 .or. ubound (b, 1) /= 9) call abort
if (.not.allocated (c) .or. size (c) /= 6) call abort
if (size (c, 1) /= 3 .or. size (c, 2) /= 2) call abort
if (lbound (c, 1) /= 1 .or. ubound (c, 1) /= 3) call abort
if (lbound (c, 2) /= 8 .or. ubound (c, 2) /= 9) call abort
if (a /= 55 .or. any (b /= 110) .or. any (c /= 165)) call abort
a = 0
b = 0
c = 0
!$omp simd reduction (foo : a, b, c)
do i = 1, 10
if (.not.allocated (a)) call abort
if (.not.allocated (b) .or. size (b) /= 4) call abort
if (lbound (b, 1) /= 6 .or. ubound (b, 1) /= 9) call abort
if (.not.allocated (c) .or. size (c) /= 6) call abort
if (size (c, 1) /= 3 .or. size (c, 2) /= 2) call abort
if (lbound (c, 1) /= 1 .or. ubound (c, 1) /= 3) call abort
if (lbound (c, 2) /= 8 .or. ubound (c, 2) /= 9) call abort
a = a + i
b = b + 2 * i
c = c + 3 * i
end do
if (.not.allocated (a)) call abort
if (.not.allocated (b) .or. size (b) /= 4) call abort
if (lbound (b, 1) /= 6 .or. ubound (b, 1) /= 9) call abort
if (.not.allocated (c) .or. size (c) /= 6) call abort
if (size (c, 1) /= 3 .or. size (c, 2) /= 2) call abort
if (lbound (c, 1) /= 1 .or. ubound (c, 1) /= 3) call abort
if (lbound (c, 2) /= 8 .or. ubound (c, 2) /= 9) call abort
if (a /= 55 .or. any (b /= 110) .or. any (c /= 165)) call abort
end

72
libgomp/testsuite/libgomp.fortran/allocatable11.f90 Normal file
View File

@ -0,0 +1,72 @@
! { dg-do run }
! { dg-require-effective-target tls_runtime }
use omp_lib
integer, allocatable, save :: a, b(:), c(:,:)
integer :: p
!$omp threadprivate (a, b, c)
if (allocated (a) .or. allocated (b) .or. allocated (c)) call abort
call omp_set_dynamic (.false.)
call omp_set_num_threads (4)
!$omp parallel num_threads (4)
if (allocated (a) .or. allocated (b) .or. allocated (c)) call abort
!$omp end parallel
allocate (a, b(6:9), c(3, 8:9))
a = 4
b = 5
c = 6
if (.not.allocated (a)) call abort
if (.not.allocated (b) .or. size (b) /= 4) call abort
if (lbound (b, 1) /= 6 .or. ubound (b, 1) /= 9) call abort
if (.not.allocated (c) .or. size (c) /= 6) call abort
if (size (c, 1) /= 3 .or. size (c, 2) /= 2) call abort
if (lbound (c, 1) /= 1 .or. ubound (c, 1) /= 3) call abort
if (lbound (c, 2) /= 8 .or. ubound (c, 2) /= 9) call abort
!$omp parallel num_threads (4) copyin (a, b, c) private (p)
p = omp_get_thread_num ()
if (.not.allocated (a)) call abort
if (.not.allocated (b) .or. size (b) /= 4) call abort
if (lbound (b, 1) /= 6 .or. ubound (b, 1) /= 9) call abort
if (.not.allocated (c) .or. size (c) /= 6) call abort
if (size (c, 1) /= 3 .or. size (c, 2) /= 2) call abort
if (lbound (c, 1) /= 1 .or. ubound (c, 1) /= 3) call abort
if (lbound (c, 2) /= 8 .or. ubound (c, 2) /= 9) call abort
if (a /= 4 .or. any (b /= 5) .or. any (c /= 6)) call abort
deallocate (a, b, c)
if (allocated (a) .or. allocated (b) .or. allocated (c)) call abort
allocate (a, b(p:9), c(3, p:7))
a = p
b = p
c = p
if (.not.allocated (a)) call abort
if (.not.allocated (b) .or. size (b) /= (10 - p)) call abort
if (lbound (b, 1) /= p .or. ubound (b, 1) /= 9) call abort
if (.not.allocated (c) .or. size (c) /= (3 * (8 - p))) call abort
if (size (c, 1) /= 3 .or. size (c, 2) /= (8 - p)) call abort
if (lbound (c, 1) /= 1 .or. ubound (c, 1) /= 3) call abort
if (lbound (c, 2) /= p .or. ubound (c, 2) /= 7) call abort
if (a /= p .or. any (b /= p) .or. any (c /= p)) call abort
!$omp end parallel
!$omp parallel num_threads (4) copyin (a, b, c)
if (.not.allocated (a)) call abort
if (.not.allocated (b) .or. size (b) /= 10) call abort
if (lbound (b, 1) /= 0 .or. ubound (b, 1) /= 9) call abort
if (.not.allocated (c) .or. size (c) /= 24) call abort
if (size (c, 1) /= 3 .or. size (c, 2) /= 8) call abort
if (lbound (c, 1) /= 1 .or. ubound (c, 1) /= 3) call abort
if (lbound (c, 2) /= 0 .or. ubound (c, 2) /= 7) call abort
if (a /= 0 .or. any (b /= 0) .or. any (c /= 0)) call abort
!$omp end parallel
deallocate (a, b, c)
if (allocated (a) .or. allocated (b) .or. allocated (c)) call abort
!$omp parallel num_threads (4) copyin (a, b, c)
if (allocated (a) .or. allocated (b) .or. allocated (c)) call abort
!$omp end parallel
end

74
libgomp/testsuite/libgomp.fortran/allocatable12.f90 Normal file
View File

@ -0,0 +1,74 @@
! { dg-do run }
integer, allocatable :: a, b(:), c(:,:)
logical :: l
if (allocated (a) .or. allocated (b) .or. allocated (c)) call abort
!$omp parallel private (a, b, c, l)
l = .false.
if (allocated (a) .or. allocated (b) .or. allocated (c)) call abort
!$omp single
allocate (a, b(6:9), c(3, 8:9))
a = 4
b = 5
c = 6
!$omp end single copyprivate (a, b, c)
if (.not.allocated (a)) call abort
if (.not.allocated (b) .or. size (b) /= 4) call abort
if (lbound (b, 1) /= 6 .or. ubound (b, 1) /= 9) call abort
if (.not.allocated (c) .or. size (c) /= 6) call abort
if (size (c, 1) /= 3 .or. size (c, 2) /= 2) call abort
if (lbound (c, 1) /= 1 .or. ubound (c, 1) /= 3) call abort
if (lbound (c, 2) /= 8 .or. ubound (c, 2) /= 9) call abort
if (a /= 4 .or. any (b /= 5) .or. any (c /= 6)) call abort
!$omp single
deallocate (a, b, c)
if (allocated (a) .or. allocated (b) .or. allocated (c)) call abort
allocate (a, b(0:4), c(3, 2:7))
a = 1
b = 2
c = 3
!$omp end single copyprivate (a, b, c)
if (.not.allocated (a)) call abort
if (.not.allocated (b) .or. size (b) /= 5) call abort
if (lbound (b, 1) /= 0 .or. ubound (b, 1) /= 4) call abort
if (.not.allocated (c) .or. size (c) /= 18) call abort
if (size (c, 1) /= 3 .or. size (c, 2) /= 6) call abort
if (lbound (c, 1) /= 1 .or. ubound (c, 1) /= 3) call abort
if (lbound (c, 2) /= 2 .or. ubound (c, 2) /= 7) call abort
if (a /= 1 .or. any (b /= 2) .or. any (c /= 3)) call abort
!$omp single
l = .true.
deallocate (a, b, c)
if (allocated (a) .or. allocated (b) .or. allocated (c)) call abort
allocate (a, b(2:6), c(3:5, 3:8))
a = 7
b = 8
c = 9
!$omp end single copyprivate (a, b, c)
if (.not.allocated (a)) call abort
if (.not.allocated (b) .or. size (b) /= 5) call abort
if (l) then
if (lbound (b, 1) /= 2 .or. ubound (b, 1) /= 6) call abort
else
if (lbound (b, 1) /= 0 .or. ubound (b, 1) /= 4) call abort
end if
if (.not.allocated (c) .or. size (c) /= 18) call abort
if (size (c, 1) /= 3 .or. size (c, 2) /= 6) call abort
if (l) then
if (lbound (c, 1) /= 3 .or. ubound (c, 1) /= 5) call abort
if (lbound (c, 2) /= 3 .or. ubound (c, 2) /= 8) call abort
else
if (lbound (c, 1) /= 1 .or. ubound (c, 1) /= 3) call abort
if (lbound (c, 2) /= 2 .or. ubound (c, 2) /= 7) call abort
end if
if (a /= 7 .or. any (b /= 8) .or. any (c /= 9)) call abort
!$omp end parallel
end

156
libgomp/testsuite/libgomp.fortran/allocatable9.f90 Normal file
View File

@ -0,0 +1,156 @@
! { dg-do run }
integer, allocatable :: a, b(:), c(:,:)
logical :: l
if (allocated (a) .or. allocated (b) .or. allocated (c)) call abort
!$omp parallel private (a, b, c)
if (allocated (a) .or. allocated (b) .or. allocated (c)) call abort
allocate (a, b(-7:-1), c(2:3, 3:5))
if (.not.allocated (a)) call abort
if (.not.allocated (b) .or. size (b) /= 7) call abort
if (lbound (b, 1) /= -7 .or. ubound (b, 1) /= -1) call abort
if (.not.allocated (c) .or. size (c) /= 6) call abort
if (size (c, 1) /= 2 .or. size (c, 2) /= 3) call abort
if (lbound (c, 1) /= 2 .or. ubound (c, 1) /= 3) call abort
if (lbound (c, 2) /= 3 .or. ubound (c, 2) /= 5) call abort
a = 4
b = 3
c = 2
!$omp end parallel
if (allocated (a) .or. allocated (b) .or. allocated (c)) call abort
!$omp parallel firstprivate (a, b, c)
if (allocated (a) .or. allocated (b) .or. allocated (c)) call abort
allocate (a, b(-7:-1), c(2:3, 3:5))
if (.not.allocated (a)) call abort
if (.not.allocated (b) .or. size (b) /= 7) call abort
if (lbound (b, 1) /= -7 .or. ubound (b, 1) /= -1) call abort
if (.not.allocated (c) .or. size (c) /= 6) call abort
if (size (c, 1) /= 2 .or. size (c, 2) /= 3) call abort
if (lbound (c, 1) /= 2 .or. ubound (c, 1) /= 3) call abort
if (lbound (c, 2) /= 3 .or. ubound (c, 2) /= 5) call abort
a = 4
b = 3
c = 2
!$omp end parallel
if (allocated (a) .or. allocated (b) .or. allocated (c)) call abort
allocate (a, b(6:9), c(3, 8:9))
a = 2
b = 4
c = 5
if (.not.allocated (a)) call abort
if (.not.allocated (b) .or. size (b) /= 4) call abort
if (lbound (b, 1) /= 6 .or. ubound (b, 1) /= 9) call abort
if (.not.allocated (c) .or. size (c) /= 6) call abort
if (size (c, 1) /= 3 .or. size (c, 2) /= 2) call abort
if (lbound (c, 1) /= 1 .or. ubound (c, 1) /= 3) call abort
if (lbound (c, 2) /= 8 .or. ubound (c, 2) /= 9) call abort
!$omp parallel firstprivate (a, b, c)
if (.not.allocated (a)) call abort
if (.not.allocated (b) .or. size (b) /= 4) call abort
if (lbound (b, 1) /= 6 .or. ubound (b, 1) /= 9) call abort
if (.not.allocated (c) .or. size (c) /= 6) call abort
if (size (c, 1) /= 3 .or. size (c, 2) /= 2) call abort
if (lbound (c, 1) /= 1 .or. ubound (c, 1) /= 3) call abort
if (lbound (c, 2) /= 8 .or. ubound (c, 2) /= 9) call abort
if (a /= 2 .or. any (b .ne. 4) .or. any (c .ne. 5)) call abort
deallocate (a)
if (allocated (a)) call abort
allocate (a)
a = 8
b = (/ 1, 2, 3 /)
c = reshape ((/ 1, 2, 3, 4, 5, 6, 7, 8 /), (/ 2, 4 /))
if (.not.allocated (a)) call abort
if (.not.allocated (b) .or. size (b) /= 3) call abort
if (lbound (b, 1) /= 1 .or. ubound (b, 1) /= 3) call abort
if (.not.allocated (c) .or. size (c) /= 8) call abort
if (size (c, 1) /= 2 .or. size (c, 2) /= 4) call abort
if (lbound (c, 1) /= 1 .or. ubound (c, 1) /= 2) call abort
if (lbound (c, 2) /= 1 .or. ubound (c, 2) /= 4) call abort
if (a /= 8 .or. b(2) /= 2 .or. c(1, 2) /= 3) call abort
!$omp end parallel
if (.not.allocated (a)) call abort
if (.not.allocated (b) .or. size (b) /= 4) call abort
if (lbound (b, 1) /= 6 .or. ubound (b, 1) /= 9) call abort
if (.not.allocated (c) .or. size (c) /= 6) call abort
if (size (c, 1) /= 3 .or. size (c, 2) /= 2) call abort
if (lbound (c, 1) /= 1 .or. ubound (c, 1) /= 3) call abort
if (lbound (c, 2) /= 8 .or. ubound (c, 2) /= 9) call abort
if (a /= 2 .or. any (b .ne. 4) .or. any (c .ne. 5)) call abort
l = .false.
!$omp parallel sections lastprivate (a, b, c) firstprivate (l)
!$omp section
if (.not.allocated (a)) call abort
if (l) then
if (.not.allocated (b) .or. size (b) /= 6) call abort
if (lbound (b, 1) /= 1 .or. ubound (b, 1) /= 6) call abort
if (.not.allocated (c) .or. size (c) /= 8) call abort
if (size (c, 1) /= 4 .or. size (c, 2) /= 2) call abort
if (lbound (c, 1) /= 1 .or. ubound (c, 1) /= 4) call abort
if (lbound (c, 2) /= 1 .or. ubound (c, 2) /= 2) call abort
if (a /= 12 .or. b(2) /= 8 .or. c(1, 2) /= 5) call abort
else
if (.not.allocated (b) .or. size (b) /= 4) call abort
if (lbound (b, 1) /= 6 .or. ubound (b, 1) /= 9) call abort
if (.not.allocated (c) .or. size (c) /= 6) call abort
if (size (c, 1) /= 3 .or. size (c, 2) /= 2) call abort
if (lbound (c, 1) /= 1 .or. ubound (c, 1) /= 3) call abort
if (lbound (c, 2) /= 8 .or. ubound (c, 2) /= 9) call abort
end if
l = .true.
deallocate (a)
if (allocated (a)) call abort
allocate (a)
a = 8
b = (/ 1, 2, 3 /)
c = reshape ((/ 1, 2, 3, 4, 5, 6, 7, 8 /), (/ 2, 4 /))
if (.not.allocated (a)) call abort
if (.not.allocated (b) .or. size (b) /= 3) call abort
if (lbound (b, 1) /= 1 .or. ubound (b, 1) /= 3) call abort
if (.not.allocated (c) .or. size (c) /= 8) call abort
if (size (c, 1) /= 2 .or. size (c, 2) /= 4) call abort
if (lbound (c, 1) /= 1 .or. ubound (c, 1) /= 2) call abort
if (lbound (c, 2) /= 1 .or. ubound (c, 2) /= 4) call abort
if (a /= 8 .or. b(2) /= 2 .or. c(1, 2) /= 3) call abort
!$omp section
if (.not.allocated (a)) call abort
if (l) then
if (.not.allocated (b) .or. size (b) /= 3) call abort
if (lbound (b, 1) /= 1 .or. ubound (b, 1) /= 3) call abort
if (.not.allocated (c) .or. size (c) /= 8) call abort
if (size (c, 1) /= 2 .or. size (c, 2) /= 4) call abort
if (lbound (c, 1) /= 1 .or. ubound (c, 1) /= 2) call abort
if (lbound (c, 2) /= 1 .or. ubound (c, 2) /= 4) call abort
if (a /= 8 .or. b(2) /= 2 .or. c(1, 2) /= 3) call abort
else
if (.not.allocated (b) .or. size (b) /= 4) call abort
if (lbound (b, 1) /= 6 .or. ubound (b, 1) /= 9) call abort
if (.not.allocated (c) .or. size (c) /= 6) call abort
if (size (c, 1) /= 3 .or. size (c, 2) /= 2) call abort
if (lbound (c, 1) /= 1 .or. ubound (c, 1) /= 3) call abort
if (lbound (c, 2) /= 8 .or. ubound (c, 2) /= 9) call abort
end if
l = .true.
deallocate (a)
if (allocated (a)) call abort
allocate (a)
a = 12
b = (/ 9, 8, 7, 6, 5, 4 /)
c = reshape ((/ 1, 2, 3, 4, 5, 6, 7, 8 /), (/ 4, 2 /))
if (.not.allocated (a)) call abort
if (.not.allocated (b) .or. size (b) /= 6) call abort
if (lbound (b, 1) /= 1 .or. ubound (b, 1) /= 6) call abort
if (.not.allocated (c) .or. size (c) /= 8) call abort
if (size (c, 1) /= 4 .or. size (c, 2) /= 2) call abort
if (lbound (c, 1) /= 1 .or. ubound (c, 1) /= 4) call abort
if (lbound (c, 2) /= 1 .or. ubound (c, 2) /= 2) call abort
if (a /= 12 .or. b(2) /= 8 .or. c(1, 2) /= 5) call abort
!$omp end parallel sections
if (.not.allocated (a)) call abort
if (.not.allocated (b) .or. size (b) /= 6) call abort
if (lbound (b, 1) /= 1 .or. ubound (b, 1) /= 6) call abort
if (.not.allocated (c) .or. size (c) /= 8) call abort
if (size (c, 1) /= 4 .or. size (c, 2) /= 2) call abort
if (lbound (c, 1) /= 1 .or. ubound (c, 1) /= 4) call abort
if (lbound (c, 2) /= 1 .or. ubound (c, 2) /= 2) call abort
if (a /= 12 .or. b(2) /= 8 .or. c(1, 2) /= 5) call abort
end

23
libgomp/testsuite/libgomp.fortran/associate1.f90 Normal file
View File

@ -0,0 +1,23 @@
! { dg-do run }
program associate1
integer :: v, i, j
real :: a(3, 3)
v = 15
a = 4.5
a(2,1) = 3.5
i = 2
j = 1
associate(u => v, b => a(i, j))
!$omp parallel private(v, a) default(none)
v = -1
a = 2.5
if (v /= -1 .or. u /= 15) call abort
if (a(2,1) /= 2.5 .or. b /= 3.5) call abort
associate(u => v, b => a(2, 1))
if (u /= -1 .or. b /= 2.5) call abort
end associate
if (u /= 15 .or. b /= 3.5) call abort
!$omp end parallel
end associate
end program

46
libgomp/testsuite/libgomp.fortran/associate2.f90 Normal file
View File

@ -0,0 +1,46 @@
! { dg-do run }
program associate2
type dl
integer :: i
end type
type dt
integer :: i
real :: a(3, 3)
type(dl) :: c(3, 3)
end type
integer :: v(4), i, j, k, l
type (dt) :: a(3, 3)
v = 15
forall (k = 1:3, l = 1:3) a(k, l)%a(:,:) = 4.5
a(2,1)%a(1,2) = 3.5
i = 2
j = 1
associate(u => v, b => a(i, j)%a)
!$omp parallel private(v, a) default(none)
v = -1
forall (k = 1:3, l = 1:3) a(k, l)%a(:,:) = 2.5
if (v(3) /= -1 .or. u(3) /= 15) call abort
if (a(2,1)%a(1,2) /= 2.5 .or. b(1,2) /= 3.5) call abort
associate(u => v, b => a(2, 1)%a)
if (u(3) /= -1 .or. b(1,2) /= 2.5) call abort
end associate
if (u(3) /= 15 .or. b(1,2) /= 3.5) call abort
!$omp end parallel
end associate
forall (k = 1:3, l = 1:3) a(k, l)%c(:,:)%i = 7
a(1,2)%c(2,1)%i = 9
i = 1
j = 2
associate(d => a(i, j)%c(2,:)%i)
!$omp parallel private(a) default(none)
forall (k = 1:3, l = 1:3) a(k, l)%c(:,:)%i = 15
if (a(1,2)%c(2,1)%i /= 15 .or. d(1) /= 9) call abort
if (a(1,2)%c(2,2)%i /= 15 .or. d(2) /= 7) call abort
associate(d => a(2,1)%c(2,:)%i)
if (d(1) /= 15 .or. d(2) /= 15) call abort
end associate
if (d(1) /= 9 .or. d(2) /= 7) call abort
!$omp end parallel
end associate
end program

42
libgomp/testsuite/libgomp.fortran/procptr1.f90 Normal file
View File

@ -0,0 +1,42 @@
! { dg-do run }
interface
integer function foo ()
end function
integer function bar ()
end function
integer function baz ()
end function
end interface
procedure(foo), pointer :: ptr
integer :: i
ptr => foo
!$omp parallel shared (ptr)
if (ptr () /= 1) call abort
!$omp end parallel
ptr => bar
!$omp parallel firstprivate (ptr)
if (ptr () /= 2) call abort
!$omp end parallel
!$omp parallel sections lastprivate (ptr)
!$omp section
ptr => foo
if (ptr () /= 1) call abort
!$omp section
ptr => bar
if (ptr () /= 2) call abort
!$omp section
ptr => baz
if (ptr () /= 3) call abort
!$omp end parallel sections
if (ptr () /= 3) call abort
if (.not.associated (ptr, baz)) call abort
end
integer function foo ()
foo = 1
end function
integer function bar ()
bar = 2
end function
integer function baz ()
baz = 3
end function