This is the mail archive of the
gcc-patches@gcc.gnu.org
mailing list for the GCC project.
[PATCH] Misc Fortran OpenMP 4.0 changes (PR fortran/60928)
- From: Jakub Jelinek <jakub at redhat dot com>
- To: gcc-patches at gcc dot gnu dot org, fortran at gcc dot gnu dot org
- Date: Mon, 9 Jun 2014 18:22:30 +0200
- Subject: [PATCH] Misc Fortran OpenMP 4.0 changes (PR fortran/60928)
- Authentication-results: sourceware.org; auth=none
- Reply-to: Jakub Jelinek <jakub at redhat dot com>
Hi!
This patch deals with various smaller things:
1) -fopenmp-simd fortran support
2) ALLOCATABLE handling fixes (e.g. copyin can't assume in OpenMP 4.0
that what it copies to has the same bounds and allocation status)
3) support for scalar ALLOCATABLE in various clauses
4) support for allocatable components
5) support for ASSOCIATE names (predetermined in OpenMP 4.0)
6) diagnostics of procedure pointers in reduction, and intent(in)
pointers in various clauses that don't allow them in OpenMP 4.0
Bootstrapped/regtested on x86_64-linux and i686-linux. Does this look
ok to Fortran maintainers?
2014-06-09 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.
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.
--- gcc/omp-low.c.jj 2014-06-09 11:01:15.412933417 +0200
+++ gcc/omp-low.c 2014-06-09 12:13:12.952753759 +0200
@@ -3110,6 +3110,13 @@ lower_rec_input_clauses (tree clauses, g
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, g
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))
--- gcc/c-family/c-pragma.c.jj 2014-06-09 11:00:58.257020135 +0200
+++ gcc/c-family/c-pragma.c 2014-06-09 12:13:12.952753759 +0200
@@ -1185,6 +1185,7 @@ static const struct omp_pragma_def omp_p
{ "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_p
{ "parallel", PRAGMA_OMP_PARALLEL },
{ "simd", PRAGMA_OMP_SIMD },
{ "target", PRAGMA_OMP_TARGET },
- { "task", PRAGMA_OMP_TASK },
{ "teams", PRAGMA_OMP_TEAMS },
};
--- gcc/fortran/f95-lang.c.jj 2014-06-09 11:00:58.592018439 +0200
+++ gcc/fortran/f95-lang.c 2014-06-09 12:13:12.920754724 +0200
@@ -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) \
--- gcc/fortran/openmp.c.jj 2014-06-09 11:00:58.520018804 +0200
+++ gcc/fortran/openmp.c 2014-06-09 12:13:12.911755172 +0200
@@ -1763,9 +1763,6 @@ resolve_omp_clauses (gfc_code *code, loc
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, loc
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, loc
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, loc
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, loc
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:
--- gcc/fortran/parse.c.jj 2014-06-09 11:00:58.556018623 +0200
+++ gcc/fortran/parse.c 2014-06-09 12:13:12.913755085 +0200
@@ -74,6 +74,34 @@ match_word (const char *str, match (*sub
}
+/* 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]);
--- gcc/fortran/scanner.c.jj 2014-06-09 11:00:58.637018229 +0200
+++ gcc/fortran/scanner.c 2014-06-09 12:13:12.920754724 +0200
@@ -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)
{
--- gcc/fortran/trans-array.c.jj 2014-06-09 11:00:58.505018880 +0200
+++ gcc/fortran/trans-array.c 2014-06-09 12:13:12.916754985 +0200
@@ -7381,8 +7381,8 @@ gfc_trans_dealloc_allocated (tree descri
/* 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,
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 s
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 s
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 s
/* 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 s
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, tr
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_
/* 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_
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
--- gcc/fortran/trans-array.h.jj 2014-06-09 11:00:58.514018834 +0200
+++ gcc/fortran/trans-array.h 2014-06-09 12:13:12.912755128 +0200
@@ -44,10 +44,14 @@ void gfc_trans_g77_array (gfc_symbol *,
/* 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);
--- gcc/fortran/trans-common.c.jj 2014-06-09 11:00:58.320019806 +0200
+++ gcc/fortran/trans-common.c 2014-06-09 12:13:12.919754787 +0200
@@ -705,6 +705,7 @@ create_common (gfc_common_head *com, seg
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. */
--- gcc/fortran/trans-decl.c.jj 2014-06-09 11:00:58.439019214 +0200
+++ gcc/fortran/trans-decl.c 2014-06-09 12:13:12.914755043 +0200
@@ -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_symb
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_symb
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 * sy
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 * s
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);
--- gcc/fortran/trans.h.jj 2014-06-09 11:00:58.476019024 +0200
+++ gcc/fortran/trans.h 2014-06-09 12:13:12.915755003 +0200
@@ -547,6 +547,9 @@ void gfc_set_decl_assembler_name (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
--- gcc/fortran/trans-openmp.c.jj 2014-06-09 11:00:58.376019520 +0200
+++ gcc/fortran/trans-openmp.c 2014-06-09 12:13:12.918754853 +0200
@@ -55,7 +55,9 @@ gfc_omp_privatize_by_reference (const_tr
/* 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_tr
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;
+ gcc_assert (OMP_CLAUSE_CODE (clause) == OMP_CLAUSE_PRIVATE
+ || OMP_CLAUSE_CODE (clause) == OMP_CLAUSE_LASTPRIVATE
+ || OMP_CLAUSE_CODE (clause) == OMP_CLAUSE_LINEAR
+ || OMP_CLAUSE_CODE (clause) == OMP_CLAUSE_REDUCTION);
- if (OMP_CLAUSE_CODE (clause) == OMP_CLAUSE_REDUCTION)
- 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)))
+ {
+ 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);
- gcc_assert (OMP_CLAUSE_CODE (clause) == OMP_CLAUSE_PRIVATE
- || OMP_CLAUSE_CODE (clause) == OMP_CLAUSE_LASTPRIVATE);
+ gcc_assert (outer != NULL_TREE);
- /* Allocatable arrays in PRIVATE clauses need to be set to
+ /* 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);
-
- 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));
+ /* 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);
+
+ 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
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, t
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 AT
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)
+ && !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 (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);
- 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;
-
- /* 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 (tr
/* 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 (tr
/* 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_na
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, g
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 = █
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, g
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
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);
}
--- gcc/fortran/trans-types.c.jj 2014-06-09 11:00:58.679018020 +0200
+++ gcc/fortran/trans-types.c 2014-06-09 12:13:12.919754787 +0200
@@ -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 +2546,8 @@ gfc_get_derived_type (gfc_symbol * deriv
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);
--- gcc/testsuite/gfortran.dg/gomp/allocatable_components_1.f90.jj 2014-06-09 11:00:57.874022088 +0200
+++ gcc/testsuite/gfortran.dg/gomp/allocatable_components_1.f90 2014-06-09 12:13:12.940753898 +0200
@@ -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
--- gcc/testsuite/gfortran.dg/gomp/associate1.f90.jj 2014-06-09 12:13:12.940753898 +0200
+++ gcc/testsuite/gfortran.dg/gomp/associate1.f90 2014-06-09 12:13:12.940753898 +0200
@@ -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
--- gcc/testsuite/gfortran.dg/gomp/intentin1.f90.jj 2014-06-09 12:13:12.939753927 +0200
+++ gcc/testsuite/gfortran.dg/gomp/intentin1.f90 2014-06-09 12:13:12.939753927 +0200
@@ -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
--- gcc/testsuite/gfortran.dg/gomp/openmp-simd-1.f90.jj 2014-06-09 12:13:12.940753898 +0200
+++ gcc/testsuite/gfortran.dg/gomp/openmp-simd-1.f90 2014-06-09 12:13:12.940753898 +0200
@@ -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" } }
--- gcc/testsuite/gfortran.dg/gomp/openmp-simd-2.f90.jj 2014-06-09 12:13:12.940753898 +0200
+++ gcc/testsuite/gfortran.dg/gomp/openmp-simd-2.f90 2014-06-09 12:13:12.940753898 +0200
@@ -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" } }
--- gcc/testsuite/gfortran.dg/gomp/openmp-simd-3.f90.jj 2014-06-09 12:13:12.940753898 +0200
+++ gcc/testsuite/gfortran.dg/gomp/openmp-simd-3.f90 2014-06-09 12:13:12.940753898 +0200
@@ -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" } }
--- gcc/testsuite/gfortran.dg/gomp/proc_ptr_2.f90.jj 2014-06-09 12:13:12.940753898 +0200
+++ gcc/testsuite/gfortran.dg/gomp/proc_ptr_2.f90 2014-06-09 12:13:12.940753898 +0200
@@ -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
--- libgomp/testsuite/libgomp.fortran/allocatable9.f90.jj 2014-06-09 12:13:12.954753749 +0200
+++ libgomp/testsuite/libgomp.fortran/allocatable9.f90 2014-06-09 12:13:12.954753749 +0200
@@ -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
--- libgomp/testsuite/libgomp.fortran/allocatable10.f90.jj 2014-06-09 12:13:12.954753749 +0200
+++ libgomp/testsuite/libgomp.fortran/allocatable10.f90 2014-06-09 12:13:12.954753749 +0200
@@ -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
--- libgomp/testsuite/libgomp.fortran/allocatable11.f90.jj 2014-06-09 12:13:12.954753749 +0200
+++ libgomp/testsuite/libgomp.fortran/allocatable11.f90 2014-06-09 12:13:12.954753749 +0200
@@ -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
--- libgomp/testsuite/libgomp.fortran/allocatable12.f90.jj 2014-06-09 12:13:12.953753755 +0200
+++ libgomp/testsuite/libgomp.fortran/allocatable12.f90 2014-06-09 12:13:12.953753755 +0200
@@ -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
--- libgomp/testsuite/libgomp.fortran/alloc-comp-1.f90.jj 2014-06-09 12:13:12.954753749 +0200
+++ libgomp/testsuite/libgomp.fortran/alloc-comp-1.f90 2014-06-09 13:28:57.130658789 +0200
@@ -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
--- libgomp/testsuite/libgomp.fortran/alloc-comp-2.f90.jj 2014-06-09 12:13:12.953753755 +0200
+++ libgomp/testsuite/libgomp.fortran/alloc-comp-2.f90 2014-06-09 13:29:04.516619437 +0200
@@ -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
--- libgomp/testsuite/libgomp.fortran/alloc-comp-3.f90.jj 2014-06-09 12:54:00.290856627 +0200
+++ libgomp/testsuite/libgomp.fortran/alloc-comp-3.f90 2014-06-09 13:29:12.712580363 +0200
@@ -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
--- libgomp/testsuite/libgomp.fortran/associate1.f90.jj 2014-06-09 12:13:12.953753755 +0200
+++ libgomp/testsuite/libgomp.fortran/associate1.f90 2014-06-09 12:13:12.953753755 +0200
@@ -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
--- libgomp/testsuite/libgomp.fortran/associate2.f90.jj 2014-06-09 12:13:12.954753749 +0200
+++ libgomp/testsuite/libgomp.fortran/associate2.f90 2014-06-09 12:13:12.954753749 +0200
@@ -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
--- libgomp/testsuite/libgomp.fortran/procptr1.f90.jj 2014-06-09 12:13:12.952753759 +0200
+++ libgomp/testsuite/libgomp.fortran/procptr1.f90 2014-06-09 12:13:12.952753759 +0200
@@ -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
Jakub