Skip to content

R
riscv-gcc-1
Commit 92d28cbb by Jakub Jelinek Committed by Jakub Jelinek
Options

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

	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
parent c9f2b7e9
Showing with 1194 additions and 108 deletions
gcc/ChangeLog
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> 2014-06-10 Marek Polacek <polacek@redhat.com>
PR c/60988 PR c/60988
......
gcc/c-family/ChangeLog
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> 2014-06-05 Marek Polacek <polacek@redhat.com>
PR c/49706 PR c/49706
......
gcc/c-family/c-pragma.c
...@@ -1185,6 +1185,7 @@ static const struct omp_pragma_def omp_pragmas[] = { ...@@ -1185,6 +1185,7 @@ static const struct omp_pragma_def omp_pragmas[] = {
{ "section", PRAGMA_OMP_SECTION }, { "section", PRAGMA_OMP_SECTION },
{ "sections", PRAGMA_OMP_SECTIONS }, { "sections", PRAGMA_OMP_SECTIONS },
{ "single", PRAGMA_OMP_SINGLE }, { "single", PRAGMA_OMP_SINGLE },
{ "task", PRAGMA_OMP_TASK },
{ "taskgroup", PRAGMA_OMP_TASKGROUP }, { "taskgroup", PRAGMA_OMP_TASKGROUP },
{ "taskwait", PRAGMA_OMP_TASKWAIT }, { "taskwait", PRAGMA_OMP_TASKWAIT },
{ "taskyield", PRAGMA_OMP_TASKYIELD }, { "taskyield", PRAGMA_OMP_TASKYIELD },
...@@ -1197,7 +1198,6 @@ static const struct omp_pragma_def omp_pragmas_simd[] = { ...@@ -1197,7 +1198,6 @@ static const struct omp_pragma_def omp_pragmas_simd[] = {
{ "parallel", PRAGMA_OMP_PARALLEL }, { "parallel", PRAGMA_OMP_PARALLEL },
{ "simd", PRAGMA_OMP_SIMD }, { "simd", PRAGMA_OMP_SIMD },
{ "target", PRAGMA_OMP_TARGET }, { "target", PRAGMA_OMP_TARGET },
{ "task", PRAGMA_OMP_TASK },
{ "teams", PRAGMA_OMP_TEAMS }, { "teams", PRAGMA_OMP_TEAMS },
}; };
......
gcc/fortran/ChangeLog
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> 2014-06-09 Paul Thomas <pault@gcc.gnu.org>
PR fortran/61406 PR fortran/61406
......
gcc/fortran/f95-lang.c
...@@ -1044,7 +1044,9 @@ gfc_init_builtin_functions (void) ...@@ -1044,7 +1044,9 @@ gfc_init_builtin_functions (void)
#include "../sync-builtins.def" #include "../sync-builtins.def"
#undef DEF_SYNC_BUILTIN #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 #undef DEF_GOMP_BUILTIN
#define DEF_GOMP_BUILTIN(code, name, type, attr) \ #define DEF_GOMP_BUILTIN(code, name, type, attr) \
......
gcc/fortran/openmp.c
...@@ -1763,9 +1763,6 @@ resolve_omp_clauses (gfc_code *code, locus *where, ...@@ -1763,9 +1763,6 @@ resolve_omp_clauses (gfc_code *code, locus *where,
if (!n->sym->attr.threadprivate) if (!n->sym->attr.threadprivate)
gfc_error ("Non-THREADPRIVATE object '%s' in COPYIN clause" gfc_error ("Non-THREADPRIVATE object '%s' in COPYIN clause"
" at %L", n->sym->name, where); " 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; break;
case OMP_LIST_COPYPRIVATE: case OMP_LIST_COPYPRIVATE:
...@@ -1774,9 +1771,9 @@ resolve_omp_clauses (gfc_code *code, locus *where, ...@@ -1774,9 +1771,9 @@ resolve_omp_clauses (gfc_code *code, locus *where,
if (n->sym->as && n->sym->as->type == AS_ASSUMED_SIZE) if (n->sym->as && n->sym->as->type == AS_ASSUMED_SIZE)
gfc_error ("Assumed size array '%s' in COPYPRIVATE clause " gfc_error ("Assumed size array '%s' in COPYPRIVATE clause "
"at %L", n->sym->name, where); "at %L", n->sym->name, where);
if (n->sym->ts.type == BT_DERIVED && n->sym->ts.u.derived->attr.alloc_comp) if (n->sym->attr.pointer && n->sym->attr.intent == INTENT_IN)
gfc_error ("COPYPRIVATE clause object '%s' at %L has ALLOCATABLE components", gfc_error ("INTENT(IN) POINTER '%s' in COPYPRIVATE clause "
n->sym->name, where); "at %L", n->sym->name, where);
} }
break; break;
case OMP_LIST_SHARED: case OMP_LIST_SHARED:
...@@ -1788,6 +1785,9 @@ resolve_omp_clauses (gfc_code *code, locus *where, ...@@ -1788,6 +1785,9 @@ resolve_omp_clauses (gfc_code *code, locus *where,
if (n->sym->attr.cray_pointee) if (n->sym->attr.cray_pointee)
gfc_error ("Cray pointee '%s' in SHARED clause at %L", gfc_error ("Cray pointee '%s' in SHARED clause at %L",
n->sym->name, where); 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; break;
case OMP_LIST_ALIGNED: case OMP_LIST_ALIGNED:
...@@ -1879,17 +1879,17 @@ resolve_omp_clauses (gfc_code *code, locus *where, ...@@ -1879,17 +1879,17 @@ resolve_omp_clauses (gfc_code *code, locus *where,
if (n->sym->attr.cray_pointee) if (n->sym->attr.cray_pointee)
gfc_error ("Cray pointee '%s' in %s clause at %L", gfc_error ("Cray pointee '%s' in %s clause at %L",
n->sym->name, name, where); 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 (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) if (n->sym->attr.pointer && list == OMP_LIST_REDUCTION)
gfc_error ("POINTER object '%s' in %s clause at %L", gfc_error ("POINTER object '%s' in %s clause at %L",
n->sym->name, name, where); 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) if (n->sym->attr.cray_pointer && list == OMP_LIST_REDUCTION)
gfc_error ("Cray pointer '%s' in %s clause at %L", gfc_error ("Cray pointer '%s' in %s clause at %L",
n->sym->name, name, where); n->sym->name, name, where);
...@@ -1901,6 +1901,19 @@ resolve_omp_clauses (gfc_code *code, locus *where, ...@@ -1901,6 +1901,19 @@ resolve_omp_clauses (gfc_code *code, locus *where,
gfc_error ("Variable '%s' in %s clause is used in " gfc_error ("Variable '%s' in %s clause is used in "
"NAMELIST statement at %L", "NAMELIST statement at %L",
n->sym->name, name, where); 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) switch (list)
{ {
case OMP_LIST_REDUCTION: case OMP_LIST_REDUCTION:
......
gcc/fortran/scanner.c
...@@ -752,7 +752,8 @@ skip_free_comments (void) ...@@ -752,7 +752,8 @@ skip_free_comments (void)
2) handle OpenMP conditional compilation, where 2) handle OpenMP conditional compilation, where
!$ should be treated as 2 spaces (for initial lines !$ should be treated as 2 spaces (for initial lines
only if followed by space). */ 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; locus old_loc = gfc_current_locus;
if (next_char () == '$') if (next_char () == '$')
...@@ -878,7 +879,7 @@ skip_fixed_comments (void) ...@@ -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))
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 () == '$') if (next_char () == '$')
{ {
...@@ -1821,7 +1822,7 @@ include_line (gfc_char_t *line) ...@@ -1821,7 +1822,7 @@ include_line (gfc_char_t *line)
c = 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) if (gfc_current_form == FORM_FREE)
{ {
......
gcc/fortran/trans-array.c
...@@ -7381,8 +7381,8 @@ gfc_trans_dealloc_allocated (tree descriptor, bool coarray, gfc_expr *expr) ...@@ -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. */ /* This helper function calculates the size in words of a full array. */
static tree tree
get_full_array_size (stmtblock_t *block, tree decl, int rank) gfc_full_array_size (stmtblock_t *block, tree decl, int rank)
{ {
tree idx; tree idx;
tree nelems; tree nelems;
...@@ -7408,7 +7408,7 @@ get_full_array_size (stmtblock_t *block, tree decl, int rank) ...@@ -7408,7 +7408,7 @@ get_full_array_size (stmtblock_t *block, tree decl, int rank)
static tree static tree
duplicate_allocatable (tree dest, tree src, tree type, int rank, 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 tmp;
tree size; tree size;
...@@ -7442,9 +7442,13 @@ duplicate_allocatable (tree dest, tree src, tree type, int rank, ...@@ -7442,9 +7442,13 @@ duplicate_allocatable (tree dest, tree src, tree type, int rank,
gfc_add_expr_to_block (&block, tmp); gfc_add_expr_to_block (&block, tmp);
} }
tmp = builtin_decl_explicit (BUILT_IN_MEMCPY); if (!no_memcpy)
tmp = build_call_expr_loc (input_location, tmp, 3, dest, src, {
fold_convert (size_type_node, size)); 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 else
{ {
...@@ -7453,7 +7457,7 @@ duplicate_allocatable (tree dest, tree src, tree type, int rank, ...@@ -7453,7 +7457,7 @@ duplicate_allocatable (tree dest, tree src, tree type, int rank,
gfc_init_block (&block); gfc_init_block (&block);
if (rank) if (rank)
nelems = get_full_array_size (&block, src, rank); nelems = gfc_full_array_size (&block, src, rank);
else else
nelems = gfc_index_one_node; nelems = gfc_index_one_node;
...@@ -7473,14 +7477,17 @@ duplicate_allocatable (tree dest, tree src, tree type, int rank, ...@@ -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, /* We know the temporary and the value will be the same length,
so can use memcpy. */ so can use memcpy. */
tmp = builtin_decl_explicit (BUILT_IN_MEMCPY); if (!no_memcpy)
tmp = build_call_expr_loc (input_location, {
tmp, 3, gfc_conv_descriptor_data_get (dest), tmp = builtin_decl_explicit (BUILT_IN_MEMCPY);
gfc_conv_descriptor_data_get (src), tmp = build_call_expr_loc (input_location, tmp, 3,
fold_convert (size_type_node, size)); 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); tmp = gfc_finish_block (&block);
/* Null the destination if the source is null; otherwise do /* Null the destination if the source is null; otherwise do
...@@ -7502,7 +7509,8 @@ duplicate_allocatable (tree dest, tree src, tree type, int rank, ...@@ -7502,7 +7509,8 @@ duplicate_allocatable (tree dest, tree src, tree type, int rank,
tree tree
gfc_duplicate_allocatable (tree dest, tree src, tree type, int rank) 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) ...@@ -7511,7 +7519,16 @@ gfc_duplicate_allocatable (tree dest, tree src, tree type, int rank)
tree tree
gfc_copy_allocatable_data (tree dest, tree src, tree type, int rank) 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, ...@@ -7571,7 +7588,7 @@ structure_alloc_comps (gfc_symbol * der_type, tree decl,
/* Use the descriptor for an allocatable array. Since this /* Use the descriptor for an allocatable array. Since this
is a full array reference, we only need the descriptor is a full array reference, we only need the descriptor
information from dimension = rank. */ 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, tmp = fold_build2_loc (input_location, MINUS_EXPR,
gfc_array_index_type, tmp, gfc_array_index_type, tmp,
gfc_index_one_node); gfc_index_one_node);
...@@ -7930,7 +7947,7 @@ structure_alloc_comps (gfc_symbol * der_type, tree decl, ...@@ -7930,7 +7947,7 @@ structure_alloc_comps (gfc_symbol * der_type, tree decl,
gfc_add_expr_to_block (&fnblock, tmp); gfc_add_expr_to_block (&fnblock, tmp);
size = size_of_string_in_bytes (c->ts.kind, len); size = size_of_string_in_bytes (c->ts.kind, len);
tmp = duplicate_allocatable (dcmp, comp, ctype, rank, tmp = duplicate_allocatable (dcmp, comp, ctype, rank,
false, size); false, false, size);
gfc_add_expr_to_block (&fnblock, tmp); gfc_add_expr_to_block (&fnblock, tmp);
} }
else if (c->attr.allocatable && !c->attr.proc_pointer else if (c->attr.allocatable && !c->attr.proc_pointer
......
gcc/fortran/trans-array.h
...@@ -44,10 +44,14 @@ void gfc_trans_g77_array (gfc_symbol *, gfc_wrapped_block *); ...@@ -44,10 +44,14 @@ void gfc_trans_g77_array (gfc_symbol *, gfc_wrapped_block *);
/* Generate code to deallocate an array, if it is allocated. */ /* Generate code to deallocate an array, if it is allocated. */
tree gfc_trans_dealloc_allocated (tree, bool, gfc_expr *); 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_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_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_nullify_alloc_comp (gfc_symbol *, tree, int);
tree gfc_deallocate_alloc_comp (gfc_symbol *, tree, int); tree gfc_deallocate_alloc_comp (gfc_symbol *, tree, int);
......
gcc/fortran/trans-common.c
...@@ -705,6 +705,7 @@ create_common (gfc_common_head *com, segment_info *head, bool saw_equiv) ...@@ -705,6 +705,7 @@ create_common (gfc_common_head *com, segment_info *head, bool saw_equiv)
TREE_ADDRESSABLE (var_decl) = 1; TREE_ADDRESSABLE (var_decl) = 1;
/* Fake variables are not visible from other translation units. */ /* Fake variables are not visible from other translation units. */
TREE_PUBLIC (var_decl) = 0; TREE_PUBLIC (var_decl) = 0;
gfc_finish_decl_attrs (var_decl, &s->sym->attr);
/* To preserve identifier names in COMMON, chain to procedure /* To preserve identifier names in COMMON, chain to procedure
scope unless at top level in a module definition. */ scope unless at top level in a module definition. */
......
gcc/fortran/trans-decl.c
...@@ -496,6 +496,29 @@ gfc_finish_decl (tree decl) ...@@ -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. */ /* Apply symbol attributes to a variable, and add it to the function scope. */
static void static void
...@@ -607,6 +630,8 @@ gfc_finish_var_decl (tree decl, gfc_symbol * sym) ...@@ -607,6 +630,8 @@ gfc_finish_var_decl (tree decl, gfc_symbol * sym)
if (sym->attr.threadprivate if (sym->attr.threadprivate
&& (TREE_STATIC (decl) || DECL_EXTERNAL (decl))) && (TREE_STATIC (decl) || DECL_EXTERNAL (decl)))
DECL_TLS_MODEL (decl) = decl_default_tls_model (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) ...@@ -615,7 +640,8 @@ gfc_finish_var_decl (tree decl, gfc_symbol * sym)
void void
gfc_allocate_lang_decl (tree decl) 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 /* Remember a symbol to generate initialization/cleanup code at function
...@@ -1517,6 +1543,9 @@ gfc_get_symbol_decl (gfc_symbol * sym) ...@@ -1517,6 +1543,9 @@ gfc_get_symbol_decl (gfc_symbol * sym)
&& !sym->attr.select_type_temporary) && !sym->attr.select_type_temporary)
DECL_BY_REFERENCE (decl) = 1; DECL_BY_REFERENCE (decl) = 1;
if (sym->attr.associate_var)
GFC_DECL_ASSOCIATE_VAR_P (decl) = 1;
if (sym->attr.vtab if (sym->attr.vtab
|| (sym->name[0] == '_' && strncmp ("__def_init", sym->name, 10) == 0)) || (sym->name[0] == '_' && strncmp ("__def_init", sym->name, 10) == 0))
TREE_READONLY (decl) = 1; TREE_READONLY (decl) = 1;
...@@ -2236,6 +2265,7 @@ create_function_arglist (gfc_symbol * sym) ...@@ -2236,6 +2265,7 @@ create_function_arglist (gfc_symbol * sym)
DECL_BY_REFERENCE (parm) = 1; DECL_BY_REFERENCE (parm) = 1;
gfc_finish_decl (parm); gfc_finish_decl (parm);
gfc_finish_decl_attrs (parm, &f->sym->attr);
f->sym->backend_decl = parm; f->sym->backend_decl = parm;
...@@ -2690,6 +2720,7 @@ gfc_get_fake_result_decl (gfc_symbol * sym, int parent_flag) ...@@ -2690,6 +2720,7 @@ gfc_get_fake_result_decl (gfc_symbol * sym, int parent_flag)
TREE_ADDRESSABLE (decl) = 1; TREE_ADDRESSABLE (decl) = 1;
layout_decl (decl, 0); layout_decl (decl, 0);
gfc_finish_decl_attrs (decl, &sym->attr);
if (parent_flag) if (parent_flag)
gfc_add_decl_to_parent_function (decl); gfc_add_decl_to_parent_function (decl);
......
gcc/fortran/trans-types.c
...@@ -2160,9 +2160,6 @@ gfc_sym_type (gfc_symbol * sym) ...@@ -2160,9 +2160,6 @@ gfc_sym_type (gfc_symbol * sym)
restricted); restricted);
byref = 0; byref = 0;
} }
if (sym->attr.cray_pointee)
GFC_POINTER_TYPE_P (type) = 1;
} }
else else
{ {
...@@ -2181,8 +2178,6 @@ gfc_sym_type (gfc_symbol * sym) ...@@ -2181,8 +2178,6 @@ gfc_sym_type (gfc_symbol * sym)
if (sym->attr.allocatable || sym->attr.pointer if (sym->attr.allocatable || sym->attr.pointer
|| gfc_is_associate_pointer (sym)) || gfc_is_associate_pointer (sym))
type = gfc_build_pointer_type (sym, type); 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. /* We currently pass all parameters by reference.
...@@ -2552,6 +2547,8 @@ gfc_get_derived_type (gfc_symbol * derived) ...@@ -2552,6 +2547,8 @@ gfc_get_derived_type (gfc_symbol * derived)
else if (derived->declared_at.lb) else if (derived->declared_at.lb)
gfc_set_decl_location (field, &derived->declared_at); gfc_set_decl_location (field, &derived->declared_at);
gfc_finish_decl_attrs (field, &c->attr);
DECL_PACKED (field) |= TYPE_PACKED (typenode); DECL_PACKED (field) |= TYPE_PACKED (typenode);
gcc_assert (field); gcc_assert (field);
......
gcc/fortran/trans.h
...@@ -547,6 +547,9 @@ void gfc_set_decl_assembler_name (tree, tree); ...@@ -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. */ /* Returns true if a variable of specified size should go on the stack. */
int gfc_can_put_var_on_stack (tree); 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. */ /* Allocate the lang-specific part of a decl node. */
void gfc_allocate_lang_decl (tree); void gfc_allocate_lang_decl (tree);
...@@ -822,6 +825,8 @@ struct GTY(()) lang_decl { ...@@ -822,6 +825,8 @@ struct GTY(()) lang_decl {
tree span; tree span;
/* For assumed-shape coarrays. */ /* For assumed-shape coarrays. */
tree token, caf_offset; tree token, caf_offset;
unsigned int scalar_allocatable : 1;
unsigned int scalar_pointer : 1;
}; };
...@@ -832,6 +837,14 @@ struct GTY(()) lang_decl { ...@@ -832,6 +837,14 @@ struct GTY(()) lang_decl {
#define GFC_DECL_CAF_OFFSET(node) DECL_LANG_SPECIFIC(node)->caf_offset #define GFC_DECL_CAF_OFFSET(node) DECL_LANG_SPECIFIC(node)->caf_offset
#define GFC_DECL_SAVED_DESCRIPTOR(node) \ #define GFC_DECL_SAVED_DESCRIPTOR(node) \
(DECL_LANG_SPECIFIC(node)->saved_descriptor) (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_PACKED_ARRAY(node) DECL_LANG_FLAG_0(node)
#define GFC_DECL_PARTIAL_PACKED_ARRAY(node) DECL_LANG_FLAG_1(node) #define GFC_DECL_PARTIAL_PACKED_ARRAY(node) DECL_LANG_FLAG_1(node)
#define GFC_DECL_ASSIGN(node) DECL_LANG_FLAG_2(node) #define GFC_DECL_ASSIGN(node) DECL_LANG_FLAG_2(node)
...@@ -839,14 +852,13 @@ struct GTY(()) lang_decl { ...@@ -839,14 +852,13 @@ struct GTY(()) lang_decl {
#define GFC_DECL_CRAY_POINTEE(node) DECL_LANG_FLAG_4(node) #define GFC_DECL_CRAY_POINTEE(node) DECL_LANG_FLAG_4(node)
#define GFC_DECL_RESULT(node) DECL_LANG_FLAG_5(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_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) #define GFC_DECL_CLASS(node) DECL_LANG_FLAG_8(node)
/* An array descriptor. */ /* An array descriptor. */
#define GFC_DESCRIPTOR_TYPE_P(node) TYPE_LANG_FLAG_1(node) #define GFC_DESCRIPTOR_TYPE_P(node) TYPE_LANG_FLAG_1(node)
/* An array without a descriptor. */ /* An array without a descriptor. */
#define GFC_ARRAY_TYPE_P(node) TYPE_LANG_FLAG_2(node) #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. */ /* Fortran CLASS type. */
#define GFC_CLASS_TYPE_P(node) TYPE_LANG_FLAG_4(node) #define GFC_CLASS_TYPE_P(node) TYPE_LANG_FLAG_4(node)
/* The GFC_TYPE_ARRAY_* members are present in both descriptor and /* The GFC_TYPE_ARRAY_* members are present in both descriptor and
......
gcc/omp-low.c
...@@ -3110,6 +3110,13 @@ lower_rec_input_clauses (tree clauses, gimple_seq *ilist, gimple_seq *dlist, ...@@ -3110,6 +3110,13 @@ lower_rec_input_clauses (tree clauses, gimple_seq *ilist, gimple_seq *dlist,
if (pass != 0) if (pass != 0)
continue; 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; break;
case OMP_CLAUSE_ALIGNED: case OMP_CLAUSE_ALIGNED:
if (pass == 0) if (pass == 0)
...@@ -3545,7 +3552,8 @@ lower_rec_input_clauses (tree clauses, gimple_seq *ilist, gimple_seq *dlist, ...@@ -3545,7 +3552,8 @@ lower_rec_input_clauses (tree clauses, gimple_seq *ilist, gimple_seq *dlist,
else if (is_reference (var) && is_simd) else if (is_reference (var) && is_simd)
handle_simd_reference (clause_loc, new_vard, ilist); handle_simd_reference (clause_loc, new_vard, ilist);
x = lang_hooks.decls.omp_clause_default_ctor 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) if (x)
gimplify_and_add (x, ilist); gimplify_and_add (x, ilist);
if (OMP_CLAUSE_REDUCTION_GIMPLE_INIT (c)) if (OMP_CLAUSE_REDUCTION_GIMPLE_INIT (c))
......
gcc/testsuite/ChangeLog
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> 2014-06-09 Marek Polacek <polacek@redhat.com>
PR c/36446 PR c/36446
......
gcc/testsuite/gfortran.dg/gomp/allocatable_components_1.f90
...@@ -14,7 +14,7 @@ CONTAINS ...@@ -14,7 +14,7 @@ CONTAINS
TYPE(t), SAVE :: a TYPE(t), SAVE :: a
!$omp threadprivate(a) !$omp threadprivate(a)
!$omp parallel copyin(a) ! { dg-error "has ALLOCATABLE components" } !$omp parallel copyin(a)
! do something ! do something
!$omp end parallel !$omp end parallel
END SUBROUTINE END SUBROUTINE
...@@ -22,7 +22,7 @@ CONTAINS ...@@ -22,7 +22,7 @@ CONTAINS
SUBROUTINE test_copyprivate() SUBROUTINE test_copyprivate()
TYPE(t) :: a TYPE(t) :: a
!$omp single ! { dg-error "has ALLOCATABLE components" } !$omp single
! do something ! do something
!$omp end single copyprivate (a) !$omp end single copyprivate (a)
END SUBROUTINE END SUBROUTINE
...@@ -30,7 +30,7 @@ CONTAINS ...@@ -30,7 +30,7 @@ CONTAINS
SUBROUTINE test_firstprivate SUBROUTINE test_firstprivate
TYPE(t) :: a TYPE(t) :: a
!$omp parallel firstprivate(a) ! { dg-error "has ALLOCATABLE components" } !$omp parallel firstprivate(a)
! do something ! do something
!$omp end parallel !$omp end parallel
END SUBROUTINE END SUBROUTINE
...@@ -39,7 +39,7 @@ CONTAINS ...@@ -39,7 +39,7 @@ CONTAINS
TYPE(t) :: a TYPE(t) :: a
INTEGER :: i INTEGER :: i
!$omp parallel do lastprivate(a) ! { dg-error "has ALLOCATABLE components" } !$omp parallel do lastprivate(a)
DO i = 1, 1 DO i = 1, 1
END DO END DO
!$omp end parallel do !$omp end parallel do
......
gcc/testsuite/gfortran.dg/gomp/associate1.f90 0 → 100644
! { 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
gcc/testsuite/gfortran.dg/gomp/intentin1.f90 0 → 100644
! { 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
gcc/testsuite/gfortran.dg/gomp/openmp-simd-1.f90 0 → 100644
! { 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" } }
gcc/testsuite/gfortran.dg/gomp/openmp-simd-2.f90 0 → 100644
! { 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" } }
gcc/testsuite/gfortran.dg/gomp/openmp-simd-3.f90 0 → 100644
! { 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" } }
gcc/testsuite/gfortran.dg/gomp/proc_ptr_2.f90 0 → 100644
! { 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
libgomp/ChangeLog
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> 2014-06-06 Jakub Jelinek <jakub@redhat.com>
* testsuite/libgomp.fortran/simd1.f90: New test. * testsuite/libgomp.fortran/simd1.f90: New test.
......
libgomp/testsuite/libgomp.fortran/allocatable10.f90 0 → 100644
! { 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
libgomp/testsuite/libgomp.fortran/allocatable11.f90 0 → 100644
! { 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
libgomp/testsuite/libgomp.fortran/allocatable12.f90 0 → 100644
! { 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
libgomp/testsuite/libgomp.fortran/allocatable9.f90 0 → 100644
! { 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
libgomp/testsuite/libgomp.fortran/associate1.f90 0 → 100644
! { 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
libgomp/testsuite/libgomp.fortran/associate2.f90 0 → 100644
! { 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
libgomp/testsuite/libgomp.fortran/procptr1.f90 0 → 100644
! { 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
Markdown is supported
0% or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment