Skip to content

R
riscv-gcc-1
Commit 5f23671d by Jakub Jelinek Committed by Jakub Jelinek
Options

dump-parse-tree.c (show_omp_namelist): Dump reduction id in each list item. 

gcc/fortran/
	* dump-parse-tree.c (show_omp_namelist): Dump reduction
	id in each list item.
	(show_omp_node): Only handle OMP_LIST_REDUCTION, not
	OMP_LIST_REDUCTION_FIRST .. OMP_LIST_REDUCTION_LAST.  Don't
	dump reduction id here.
	* frontend-passes.c (dummy_code_callback): Renamed to...
	(gfc_dummy_code_callback): ... this.  No longer static.
	(optimize_reduction): Use gfc_dummy_code_callback instead of
	dummy_code_callback.
	* gfortran.h (gfc_statement): Add ST_OMP_DECLARE_REDUCTION.
	(symbol_attribute): Add omp_udr_artificial_var bitfield.
	(gfc_omp_reduction_op): New enum.
	(gfc_omp_namelist): Add rop and udr fields.
	(OMP_LIST_PLUS, OMP_LIST_REDUCTION_FIRST, OMP_LIST_MULT,
	OMP_LIST_SUB, OMP_LIST_AND, OMP_LIST_OR, OMP_LIST_EQV,
	OMP_LIST_NEQV, OMP_LIST_MAX, OMP_LIST_MIN, OMP_LIST_IAND,
	OMP_LIST_IOR, OMP_LIST_IEOR, OMP_LIST_REDUCTION_LAST): Removed.
	(OMP_LIST_REDUCTION): New.
	(gfc_omp_udr): New type.
	(gfc_get_omp_udr): Define.
	(gfc_symtree): Add n.omp_udr field.
	(gfc_namespace): Add omp_udr_root field, add omp_udr_ns bitfield.
	(gfc_free_omp_udr, gfc_omp_udr_find, gfc_resolve_omp_udrs,
	gfc_dummy_code_callback): New prototypes.
	* match.h (gfc_match_omp_declare_reduction): New prototype.
	* module.c (MOD_VERSION): Increase to 13.
	(omp_declare_reduction_stmt): New array.
	(mio_omp_udr_expr, write_omp_udr, write_omp_udrs, load_omp_udrs):
	New functions.
	(read_module): Read OpenMP user defined reductions.
	(write_module): Write OpenMP user defined reductions.
	* openmp.c: Include arith.h.
	(gfc_free_omp_udr, gfc_find_omp_udr): New functions.
	(gfc_match_omp_clauses): Handle user defined reductions.
	Store reduction kind into gfc_omp_namelist instead of using
	several OMP_LIST_* entries.
	(match_udr_expr, gfc_omp_udr_predef, gfc_omp_udr_find,
	gfc_match_omp_declare_reduction): New functions.
	(resolve_omp_clauses): Adjust for reduction clauses being only
	in OMP_LIST_REDUCTION list.  Diagnose missing UDRs.
	(struct omp_udr_callback_data): New type.
	(omp_udr_callback, gfc_resolve_omp_udr, gfc_resolve_omp_udrs): New
	functions.
	* parse.c (decode_omp_directive): Handle !$omp declare reduction.
	(case_decl): Add ST_OMP_DECLARE_REDUCTION.
	(gfc_ascii_statement): Print ST_OMP_DECLARE_REDUCTION.
	* resolve.c (resolve_fl_variable): Allow len=: or len=* on
	sym->attr.omp_udr_artificial_var symbols.
	(resolve_types): Call gfc_resolve_omp_udrs.
	* symbol.c (gfc_get_uop): If gfc_current_ns->omp_udr_ns,
	use parent ns instead of gfc_current_ns.
	(gfc_get_sym_tree): Don't insert symbols into
	namespaces with omp_udr_ns set.
	(free_omp_udr_tree): New function.
	(gfc_free_namespace): Call it.
	* trans-openmp.c (struct omp_udr_find_orig_data): New type.
	(omp_udr_find_orig, gfc_trans_omp_udr_expr): New functions.
	(gfc_trans_omp_array_reduction): Renamed to...
	(gfc_trans_omp_array_reduction_or_udr): ... this.  Remove SYM
	argument, instead pass gfc_omp_namelist pointer N.  Handle
	user defined reductions.
	(gfc_trans_omp_reduction_list): Remove REDUCTION_CODE argument.
	Handle user defined reductions and reduction ops in gfc_omp_namelist.
	(gfc_trans_omp_clauses): Adjust for just a single OMP_LIST_REDUCTION
	list.
	(gfc_split_omp_clauses): Likewise.
gcc/testsuite/
	* gfortran.dg/gomp/allocatable_components_1.f90: Adjust for
	reduction clause diagnostic changes.
	* gfortran.dg/gomp/appendix-a/a.31.3.f90: Likewise.
	* gfortran.dg/gomp/reduction1.f90: Likewise.
	* gfortran.dg/gomp/reduction3.f90: Likewise.
	* gfortran.dg/gomp/udr1.f90: New test.
	* gfortran.dg/gomp/udr2.f90: New test.
	* gfortran.dg/gomp/udr3.f90: New test.
	* gfortran.dg/gomp/udr4.f90: New test.
	* gfortran.dg/gomp/udr5.f90: New test.
	* gfortran.dg/gomp/udr6.f90: New test.
	* gfortran.dg/gomp/udr7.f90: New test.
libgomp/
	* testsuite/libgomp.fortran/simd1.f90: New test.
	* testsuite/libgomp.fortran/udr1.f90: New test.
	* testsuite/libgomp.fortran/udr2.f90: New test.
	* testsuite/libgomp.fortran/udr3.f90: New test.
	* testsuite/libgomp.fortran/udr4.f90: New test.
	* testsuite/libgomp.fortran/udr5.f90: New test.
	* testsuite/libgomp.fortran/udr6.f90: New test.
	* testsuite/libgomp.fortran/udr7.f90: New test.
	* testsuite/libgomp.fortran/udr8.f90: New test.
	* testsuite/libgomp.fortran/udr9.f90: New test.
	* testsuite/libgomp.fortran/udr10.f90: New test.
	* testsuite/libgomp.fortran/udr11.f90: New test.

From-SVN: r211303
parent d969f3c1
Showing with 1768 additions and 117 deletions
gcc/fortran/ChangeLog
2014-06-06 Jakub Jelinek <jakub@redhat.com>
* dump-parse-tree.c (show_omp_namelist): Dump reduction
id in each list item.
(show_omp_node): Only handle OMP_LIST_REDUCTION, not
OMP_LIST_REDUCTION_FIRST .. OMP_LIST_REDUCTION_LAST. Don't
dump reduction id here.
* frontend-passes.c (dummy_code_callback): Renamed to...
(gfc_dummy_code_callback): ... this. No longer static.
(optimize_reduction): Use gfc_dummy_code_callback instead of
dummy_code_callback.
* gfortran.h (gfc_statement): Add ST_OMP_DECLARE_REDUCTION.
(symbol_attribute): Add omp_udr_artificial_var bitfield.
(gfc_omp_reduction_op): New enum.
(gfc_omp_namelist): Add rop and udr fields.
(OMP_LIST_PLUS, OMP_LIST_REDUCTION_FIRST, OMP_LIST_MULT,
OMP_LIST_SUB, OMP_LIST_AND, OMP_LIST_OR, OMP_LIST_EQV,
OMP_LIST_NEQV, OMP_LIST_MAX, OMP_LIST_MIN, OMP_LIST_IAND,
OMP_LIST_IOR, OMP_LIST_IEOR, OMP_LIST_REDUCTION_LAST): Removed.
(OMP_LIST_REDUCTION): New.
(gfc_omp_udr): New type.
(gfc_get_omp_udr): Define.
(gfc_symtree): Add n.omp_udr field.
(gfc_namespace): Add omp_udr_root field, add omp_udr_ns bitfield.
(gfc_free_omp_udr, gfc_omp_udr_find, gfc_resolve_omp_udrs,
gfc_dummy_code_callback): New prototypes.
* match.h (gfc_match_omp_declare_reduction): New prototype.
* module.c (MOD_VERSION): Increase to 13.
(omp_declare_reduction_stmt): New array.
(mio_omp_udr_expr, write_omp_udr, write_omp_udrs, load_omp_udrs):
New functions.
(read_module): Read OpenMP user defined reductions.
(write_module): Write OpenMP user defined reductions.
* openmp.c: Include arith.h.
(gfc_free_omp_udr, gfc_find_omp_udr): New functions.
(gfc_match_omp_clauses): Handle user defined reductions.
Store reduction kind into gfc_omp_namelist instead of using
several OMP_LIST_* entries.
(match_udr_expr, gfc_omp_udr_predef, gfc_omp_udr_find,
gfc_match_omp_declare_reduction): New functions.
(resolve_omp_clauses): Adjust for reduction clauses being only
in OMP_LIST_REDUCTION list. Diagnose missing UDRs.
(struct omp_udr_callback_data): New type.
(omp_udr_callback, gfc_resolve_omp_udr, gfc_resolve_omp_udrs): New
functions.
* parse.c (decode_omp_directive): Handle !$omp declare reduction.
(case_decl): Add ST_OMP_DECLARE_REDUCTION.
(gfc_ascii_statement): Print ST_OMP_DECLARE_REDUCTION.
* resolve.c (resolve_fl_variable): Allow len=: or len=* on
sym->attr.omp_udr_artificial_var symbols.
(resolve_types): Call gfc_resolve_omp_udrs.
* symbol.c (gfc_get_uop): If gfc_current_ns->omp_udr_ns,
use parent ns instead of gfc_current_ns.
(gfc_get_sym_tree): Don't insert symbols into
namespaces with omp_udr_ns set.
(free_omp_udr_tree): New function.
(gfc_free_namespace): Call it.
* trans-openmp.c (struct omp_udr_find_orig_data): New type.
(omp_udr_find_orig, gfc_trans_omp_udr_expr): New functions.
(gfc_trans_omp_array_reduction): Renamed to...
(gfc_trans_omp_array_reduction_or_udr): ... this. Remove SYM
argument, instead pass gfc_omp_namelist pointer N. Handle
user defined reductions.
(gfc_trans_omp_reduction_list): Remove REDUCTION_CODE argument.
Handle user defined reductions and reduction ops in gfc_omp_namelist.
(gfc_trans_omp_clauses): Adjust for just a single OMP_LIST_REDUCTION
list.
(gfc_split_omp_clauses): Likewise.
2014-06-05 Richard Biener <rguenther@suse.de>
PR fortran/61418
......
gcc/fortran/dump-parse-tree.c
......@@ -1020,6 +1020,28 @@ show_omp_namelist (gfc_omp_namelist *n)
{
for (; n; n = n->next)
{
switch (n->rop)
{
case OMP_REDUCTION_PLUS:
case OMP_REDUCTION_TIMES:
case OMP_REDUCTION_MINUS:
case OMP_REDUCTION_AND:
case OMP_REDUCTION_OR:
case OMP_REDUCTION_EQV:
case OMP_REDUCTION_NEQV:
fprintf (dumpfile, "%s:", gfc_op2string ((gfc_intrinsic_op) n->rop));
break;
case OMP_REDUCTION_MAX: fputs ("max:", dumpfile); break;
case OMP_REDUCTION_MIN: fputs ("min:", dumpfile); break;
case OMP_REDUCTION_IAND: fputs ("iand:", dumpfile); break;
case OMP_REDUCTION_IOR: fputs ("ior:", dumpfile); break;
case OMP_REDUCTION_IEOR: fputs ("ieor:", dumpfile); break;
case OMP_REDUCTION_USER:
if (n->udr)
fprintf (dumpfile, "%s:", n->udr->name);
break;
default: break;
}
fprintf (dumpfile, "%s", n->sym->name);
if (n->expr)
{
......@@ -1193,51 +1215,28 @@ show_omp_node (int level, gfc_code *c)
&& list_type != OMP_LIST_COPYPRIVATE)
{
const char *type = NULL;
if (list_type >= OMP_LIST_REDUCTION_FIRST)
{
switch (list_type)
{
case OMP_LIST_PLUS: type = "+"; break;
case OMP_LIST_MULT: type = "*"; break;
case OMP_LIST_SUB: type = "-"; break;
case OMP_LIST_AND: type = ".AND."; break;
case OMP_LIST_OR: type = ".OR."; break;
case OMP_LIST_EQV: type = ".EQV."; break;
case OMP_LIST_NEQV: type = ".NEQV."; break;
case OMP_LIST_MAX: type = "MAX"; break;
case OMP_LIST_MIN: type = "MIN"; break;
case OMP_LIST_IAND: type = "IAND"; break;
case OMP_LIST_IOR: type = "IOR"; break;
case OMP_LIST_IEOR: type = "IEOR"; break;
default:
gcc_unreachable ();
}
fprintf (dumpfile, " REDUCTION(%s:", type);
}
else
switch (list_type)
{
switch (list_type)
{
case OMP_LIST_PRIVATE: type = "PRIVATE"; break;
case OMP_LIST_FIRSTPRIVATE: type = "FIRSTPRIVATE"; break;
case OMP_LIST_LASTPRIVATE: type = "LASTPRIVATE"; break;
case OMP_LIST_SHARED: type = "SHARED"; break;
case OMP_LIST_COPYIN: type = "COPYIN"; break;
case OMP_LIST_UNIFORM: type = "UNIFORM"; break;
case OMP_LIST_ALIGNED: type = "ALIGNED"; break;
case OMP_LIST_LINEAR: type = "LINEAR"; break;
case OMP_LIST_DEPEND_IN:
fprintf (dumpfile, " DEPEND(IN:");
break;
case OMP_LIST_DEPEND_OUT:
fprintf (dumpfile, " DEPEND(OUT:");
break;
default:
gcc_unreachable ();
}
if (type)
fprintf (dumpfile, " %s(", type);
case OMP_LIST_PRIVATE: type = "PRIVATE"; break;
case OMP_LIST_FIRSTPRIVATE: type = "FIRSTPRIVATE"; break;
case OMP_LIST_LASTPRIVATE: type = "LASTPRIVATE"; break;
case OMP_LIST_SHARED: type = "SHARED"; break;
case OMP_LIST_COPYIN: type = "COPYIN"; break;
case OMP_LIST_UNIFORM: type = "UNIFORM"; break;
case OMP_LIST_ALIGNED: type = "ALIGNED"; break;
case OMP_LIST_LINEAR: type = "LINEAR"; break;
case OMP_LIST_REDUCTION: type = "REDUCTION"; break;
case OMP_LIST_DEPEND_IN:
fprintf (dumpfile, " DEPEND(IN:");
break;
case OMP_LIST_DEPEND_OUT:
fprintf (dumpfile, " DEPEND(OUT:");
break;
default:
gcc_unreachable ();
}
if (type)
fprintf (dumpfile, " %s(", type);
show_omp_namelist (omp_clauses->lists[list_type]);
fputc (')', dumpfile);
}
......
gcc/fortran/frontend-passes.c
......@@ -676,10 +676,10 @@ dummy_expr_callback (gfc_expr **e ATTRIBUTE_UNUSED, int *walk_subtrees,
/* Dummy function for code callback, for use when we really
don't want to do anything. */
static int
dummy_code_callback (gfc_code **e ATTRIBUTE_UNUSED,
int *walk_subtrees ATTRIBUTE_UNUSED,
void *data ATTRIBUTE_UNUSED)
int
gfc_dummy_code_callback (gfc_code **e ATTRIBUTE_UNUSED,
int *walk_subtrees ATTRIBUTE_UNUSED,
void *data ATTRIBUTE_UNUSED)
{
return 0;
}
......@@ -844,7 +844,8 @@ static void
optimize_reduction (gfc_namespace *ns)
{
current_ns = ns;
gfc_code_walker (&ns->code, dummy_code_callback, callback_reduction, NULL);
gfc_code_walker (&ns->code, gfc_dummy_code_callback,
callback_reduction, NULL);
/* BLOCKs are handled in the expression walker below. */
for (ns = ns->contained; ns; ns = ns->sibling)
......
gcc/fortran/gfortran.h
......@@ -214,9 +214,9 @@ typedef enum
ST_OMP_TASKWAIT, ST_OMP_TASKYIELD, ST_OMP_CANCEL, ST_OMP_CANCELLATION_POINT,
ST_OMP_TASKGROUP, ST_OMP_END_TASKGROUP, ST_OMP_SIMD, ST_OMP_END_SIMD,
ST_OMP_DO_SIMD, ST_OMP_END_DO_SIMD, ST_OMP_PARALLEL_DO_SIMD,
ST_OMP_END_PARALLEL_DO_SIMD, ST_OMP_DECLARE_SIMD, ST_PROCEDURE, ST_GENERIC,
ST_CRITICAL, ST_END_CRITICAL, ST_GET_FCN_CHARACTERISTICS, ST_LOCK,
ST_UNLOCK, ST_NONE
ST_OMP_END_PARALLEL_DO_SIMD, ST_OMP_DECLARE_SIMD, ST_OMP_DECLARE_REDUCTION,
ST_PROCEDURE, ST_GENERIC, ST_CRITICAL, ST_END_CRITICAL,
ST_GET_FCN_CHARACTERISTICS, ST_LOCK, ST_UNLOCK, ST_NONE
}
gfc_statement;
......@@ -817,6 +817,10 @@ typedef struct
variable for SELECT_TYPE or ASSOCIATE. */
unsigned select_type_temporary:1, associate_var:1;
/* This is omp_{out,in,priv,orig} artificial variable in
!$OMP DECLARE REDUCTION. */
unsigned omp_udr_artificial_var:1;
/* Attributes set by compiler extensions (!GCC$ ATTRIBUTES). */
unsigned ext_attr:EXT_ATTR_NUM;
......@@ -1037,6 +1041,25 @@ gfc_namelist;
#define gfc_get_namelist() XCNEW (gfc_namelist)
typedef enum
{
OMP_REDUCTION_NONE = -1,
OMP_REDUCTION_PLUS = INTRINSIC_PLUS,
OMP_REDUCTION_MINUS = INTRINSIC_MINUS,
OMP_REDUCTION_TIMES = INTRINSIC_TIMES,
OMP_REDUCTION_AND = INTRINSIC_AND,
OMP_REDUCTION_OR = INTRINSIC_OR,
OMP_REDUCTION_EQV = INTRINSIC_EQV,
OMP_REDUCTION_NEQV = INTRINSIC_NEQV,
OMP_REDUCTION_MAX = GFC_INTRINSIC_END,
OMP_REDUCTION_MIN,
OMP_REDUCTION_IAND,
OMP_REDUCTION_IOR,
OMP_REDUCTION_IEOR,
OMP_REDUCTION_USER
}
gfc_omp_reduction_op;
/* For use in OpenMP clauses in case we need extra information
(aligned clause alignment, linear clause step, etc.). */
......@@ -1044,6 +1067,8 @@ typedef struct gfc_omp_namelist
{
struct gfc_symbol *sym;
struct gfc_expr *expr;
gfc_omp_reduction_op rop;
struct gfc_omp_udr *udr;
struct gfc_omp_namelist *next;
}
gfc_omp_namelist;
......@@ -1063,20 +1088,7 @@ enum
OMP_LIST_LINEAR,
OMP_LIST_DEPEND_IN,
OMP_LIST_DEPEND_OUT,
OMP_LIST_PLUS,
OMP_LIST_REDUCTION_FIRST = OMP_LIST_PLUS,
OMP_LIST_MULT,
OMP_LIST_SUB,
OMP_LIST_AND,
OMP_LIST_OR,
OMP_LIST_EQV,
OMP_LIST_NEQV,
OMP_LIST_MAX,
OMP_LIST_MIN,
OMP_LIST_IAND,
OMP_LIST_IOR,
OMP_LIST_IEOR,
OMP_LIST_REDUCTION_LAST = OMP_LIST_IEOR,
OMP_LIST_REDUCTION,
OMP_LIST_NUM
};
......@@ -1155,6 +1167,25 @@ typedef struct gfc_omp_declare_simd
gfc_omp_declare_simd;
#define gfc_get_omp_declare_simd() XCNEW (gfc_omp_declare_simd)
typedef struct gfc_omp_udr
{
struct gfc_omp_udr *next;
locus where; /* Where the !$omp declare reduction construct occurred. */
const char *name;
gfc_typespec ts;
gfc_omp_reduction_op rop;
struct gfc_symbol *omp_out;
struct gfc_symbol *omp_in;
struct gfc_namespace *combiner_ns;
struct gfc_symbol *omp_priv;
struct gfc_symbol *omp_orig;
struct gfc_namespace *initializer_ns;
}
gfc_omp_udr;
#define gfc_get_omp_udr() XCNEW (gfc_omp_udr)
/* The gfc_st_label structure is a BBT attached to a namespace that
records the usage of statement labels within that space. */
......@@ -1432,6 +1463,7 @@ typedef struct gfc_symtree
gfc_user_op *uop;
gfc_common_head *common;
gfc_typebound_proc *tb;
gfc_omp_udr *omp_udr;
}
n;
}
......@@ -1462,6 +1494,8 @@ typedef struct gfc_namespace
gfc_symtree *uop_root;
/* Tree containing all the common blocks. */
gfc_symtree *common_root;
/* Tree containing all the OpenMP user defined reductions. */
gfc_symtree *omp_udr_root;
/* Tree containing type-bound procedures. */
gfc_symtree *tb_sym_root;
......@@ -1547,6 +1581,9 @@ typedef struct gfc_namespace
/* Set to 1 if symbols in this namespace should be 'construct entities',
i.e. for BLOCK local variables. */
unsigned construct_entities:1;
/* Set to 1 for !$OMP DECLARE REDUCTION namespaces. */
unsigned omp_udr_ns:1;
}
gfc_namespace;
......@@ -2814,11 +2851,14 @@ struct gfc_omp_saved_state { void *ptrs[2]; int ints[1]; };
void gfc_free_omp_clauses (gfc_omp_clauses *);
void gfc_free_omp_declare_simd (gfc_omp_declare_simd *);
void gfc_free_omp_declare_simd_list (gfc_omp_declare_simd *);
void gfc_free_omp_udr (gfc_omp_udr *);
gfc_omp_udr *gfc_omp_udr_find (gfc_symtree *, gfc_typespec *);
void gfc_resolve_omp_directive (gfc_code *, gfc_namespace *);
void gfc_resolve_do_iterator (gfc_code *, gfc_symbol *);
void gfc_resolve_omp_parallel_blocks (gfc_code *, gfc_namespace *);
void gfc_resolve_omp_do_blocks (gfc_code *, gfc_namespace *);
void gfc_resolve_omp_declare_simd (gfc_namespace *);
void gfc_resolve_omp_udrs (gfc_symtree *);
void gfc_omp_save_and_clear_state (struct gfc_omp_saved_state *);
void gfc_omp_restore_state (struct gfc_omp_saved_state *);
......@@ -3094,6 +3134,7 @@ void gfc_run_passes (gfc_namespace *);
typedef int (*walk_code_fn_t) (gfc_code **, int *, void *);
typedef int (*walk_expr_fn_t) (gfc_expr **, int *, void *);
int gfc_dummy_code_callback (gfc_code **, int *, void *);
int gfc_expr_walker (gfc_expr **, walk_expr_fn_t, void *);
int gfc_code_walker (gfc_code **, walk_code_fn_t, walk_expr_fn_t, void *);
......
gcc/fortran/match.h
......@@ -129,6 +129,7 @@ match gfc_match_omp_barrier (void);
match gfc_match_omp_cancel (void);
match gfc_match_omp_cancellation_point (void);
match gfc_match_omp_critical (void);
match gfc_match_omp_declare_reduction (void);
match gfc_match_omp_declare_simd (void);
match gfc_match_omp_do (void);
match gfc_match_omp_do_simd (void);
......
gcc/fortran/parse.c
......@@ -575,6 +575,8 @@ decode_omp_directive (void)
match ("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);
......@@ -1050,7 +1052,7 @@ next_statement (void)
#define case_decl case ST_ATTR_DECL: case ST_COMMON: case ST_DATA_DECL: \
case ST_EQUIVALENCE: case ST_NAMELIST: case ST_STATEMENT_FUNCTION: \
case ST_TYPE: case ST_INTERFACE: case ST_OMP_THREADPRIVATE: \
case ST_PROCEDURE: case ST_OMP_DECLARE_SIMD
case ST_PROCEDURE: case ST_OMP_DECLARE_SIMD: case ST_OMP_DECLARE_REDUCTION
/* Block end statements. Errors associated with interchanging these
are detected in gfc_match_end(). */
......@@ -1550,6 +1552,9 @@ gfc_ascii_statement (gfc_statement st)
case ST_OMP_CRITICAL:
p = "!$OMP CRITICAL";
break;
case ST_OMP_DECLARE_REDUCTION:
p = "!$OMP DECLARE REDUCTION";
break;
case ST_OMP_DECLARE_SIMD:
p = "!$OMP DECLARE SIMD";
break;
......
gcc/fortran/resolve.c
......@@ -10866,7 +10866,10 @@ resolve_fl_variable (gfc_symbol *sym, int mp_flag)
}
/* Constraints on deferred type parameter. */
if (sym->ts.deferred && !(sym->attr.pointer || sym->attr.allocatable))
if (sym->ts.deferred
&& !(sym->attr.pointer
|| sym->attr.allocatable
|| sym->attr.omp_udr_artificial_var))
{
gfc_error ("Entity '%s' at %L has a deferred type parameter and "
"requires either the pointer or allocatable attribute",
......@@ -10881,7 +10884,8 @@ resolve_fl_variable (gfc_symbol *sym, int mp_flag)
dummy arguments. */
e = sym->ts.u.cl->length;
if (e == NULL && !sym->attr.dummy && !sym->attr.result
&& !sym->ts.deferred && !sym->attr.select_type_temporary)
&& !sym->ts.deferred && !sym->attr.select_type_temporary
&& !sym->attr.omp_udr_artificial_var)
{
gfc_error ("Entity with assumed character length at %L must be a "
"dummy argument or a PARAMETER", &sym->declared_at);
......@@ -14696,6 +14700,8 @@ resolve_types (gfc_namespace *ns)
gfc_resolve_omp_declare_simd (ns);
gfc_resolve_omp_udrs (ns->omp_udr_root);
gfc_current_ns = old_ns;
}
......
gcc/fortran/symbol.c
......@@ -2450,17 +2450,20 @@ gfc_get_uop (const char *name)
{
gfc_user_op *uop;
gfc_symtree *st;
gfc_namespace *ns = gfc_current_ns;
st = gfc_find_symtree (gfc_current_ns->uop_root, name);
if (ns->omp_udr_ns)
ns = ns->parent;
st = gfc_find_symtree (ns->uop_root, name);
if (st != NULL)
return st->n.uop;
st = gfc_new_symtree (&gfc_current_ns->uop_root, name);
st = gfc_new_symtree (&ns->uop_root, name);
uop = st->n.uop = XCNEW (gfc_user_op);
uop->name = gfc_get_string (name);
uop->access = ACCESS_UNKNOWN;
uop->ns = gfc_current_ns;
uop->ns = ns;
return uop;
}
......@@ -2771,6 +2774,12 @@ gfc_get_sym_tree (const char *name, gfc_namespace *ns, gfc_symtree **result,
/* Try to find the symbol in ns. */
st = gfc_find_symtree (ns->sym_root, name);
if (st == NULL && ns->omp_udr_ns)
{
ns = ns->parent;
st = gfc_find_symtree (ns->sym_root, name);
}
if (st == NULL)
{
/* If not there, create a new symbol. */
......@@ -3269,6 +3278,23 @@ free_common_tree (gfc_symtree * common_tree)
}
/* Recursive function that deletes an entire tree and all the common
head structures it points to. */
static void
free_omp_udr_tree (gfc_symtree * omp_udr_tree)
{
if (omp_udr_tree == NULL)
return;
free_omp_udr_tree (omp_udr_tree->left);
free_omp_udr_tree (omp_udr_tree->right);
gfc_free_omp_udr (omp_udr_tree->n.omp_udr);
free (omp_udr_tree);
}
/* Recursive function that deletes an entire tree and all the user
operator nodes that it contains. */
......@@ -3465,6 +3491,7 @@ gfc_free_namespace (gfc_namespace *ns)
free_sym_tree (ns->sym_root);
free_uop_tree (ns->uop_root);
free_common_tree (ns->common_root);
free_omp_udr_tree (ns->omp_udr_root);
free_tb_tree (ns->tb_sym_root);
free_tb_tree (ns->tb_uop_root);
gfc_free_finalizer_list (ns->finalizers);
......
gcc/testsuite/ChangeLog
2014-06-06 Jakub Jelinek <jakub@redhat.com>
* gfortran.dg/gomp/allocatable_components_1.f90: Adjust for
reduction clause diagnostic changes.
* gfortran.dg/gomp/appendix-a/a.31.3.f90: Likewise.
* gfortran.dg/gomp/reduction1.f90: Likewise.
* gfortran.dg/gomp/reduction3.f90: Likewise.
* gfortran.dg/gomp/udr1.f90: New test.
* gfortran.dg/gomp/udr2.f90: New test.
* gfortran.dg/gomp/udr3.f90: New test.
* gfortran.dg/gomp/udr4.f90: New test.
* gfortran.dg/gomp/udr5.f90: New test.
* gfortran.dg/gomp/udr6.f90: New test.
* gfortran.dg/gomp/udr7.f90: New test.
2014-06-06 Christian Bruel <christian.bruel@st.com>
PR tree-optimization/43934
......
gcc/testsuite/gfortran.dg/gomp/allocatable_components_1.f90
......@@ -49,7 +49,7 @@ CONTAINS
TYPE(t) :: a(10)
INTEGER :: i
!$omp parallel do reduction(+: a) ! { dg-error "must be of numeric type" }
!$omp parallel do reduction(+: a) ! { dg-error "OMP DECLARE REDUCTION\[^\n\r\]*not found for type" }
DO i = 1, SIZE(a)
END DO
!$omp end parallel do
......
gcc/testsuite/gfortran.dg/gomp/appendix-a/a.31.3.f90
......@@ -5,7 +5,7 @@
!$OMP PARALLEL DO REDUCTION(MAX: M) ! MAX is no longer the
! intrinsic so this
! is non-conforming
! { dg-error "is not INTRINSIC procedure name" "" { target *-*-* } 5 } */
! { dg-error "OMP DECLARE REDUCTION max not found" "" { target *-*-* } 5 } */
DO I = 1, 100
CALL SUB(M,I)
END DO
......
gcc/testsuite/gfortran.dg/gomp/reduction1.f90
......@@ -60,73 +60,73 @@ common /blk/ i1
!$omp end parallel
!$omp parallel reduction (*:ia1) ! { dg-error "Assumed size" }
!$omp end parallel
!$omp parallel reduction (+:l1) ! { dg-error "must be of numeric type, got LOGICAL" }
!$omp parallel reduction (+:l1) ! { dg-error "OMP DECLARE REDUCTION\[^\n\r\]*not found for type" }
!$omp end parallel
!$omp parallel reduction (*:la1) ! { dg-error "must be of numeric type, got LOGICAL" }
!$omp parallel reduction (*:la1) ! { dg-error "OMP DECLARE REDUCTION\[^\n\r\]*not found for type" }
!$omp end parallel
!$omp parallel reduction (-:a1) ! { dg-error "must be of numeric type, got CHARACTER" }
!$omp parallel reduction (-:a1) ! { dg-error "OMP DECLARE REDUCTION\[^\n\r\]*not found for type" }
!$omp end parallel
!$omp parallel reduction (+:t1) ! { dg-error "must be of numeric type, got TYPE" }
!$omp parallel reduction (+:t1) ! { dg-error "OMP DECLARE REDUCTION\[^\n\r\]*not found for type" }
!$omp end parallel
!$omp parallel reduction (*:ta1) ! { dg-error "must be of numeric type, got TYPE" }
!$omp parallel reduction (*:ta1) ! { dg-error "OMP DECLARE REDUCTION\[^\n\r\]*not found for type" }
!$omp end parallel
!$omp parallel reduction (.and.:i3) ! { dg-error "must be LOGICAL" }
!$omp parallel reduction (.and.:i3) ! { dg-error "OMP DECLARE REDUCTION\[^\n\r\]*not found for type" }
!$omp end parallel
!$omp parallel reduction (.or.:ia2) ! { dg-error "must be LOGICAL" }
!$omp parallel reduction (.or.:ia2) ! { dg-error "OMP DECLARE REDUCTION\[^\n\r\]*not found for type" }
!$omp end parallel
!$omp parallel reduction (.eqv.:r1) ! { dg-error "must be LOGICAL" }
!$omp parallel reduction (.eqv.:r1) ! { dg-error "OMP DECLARE REDUCTION\[^\n\r\]*not found for type" }
!$omp end parallel
!$omp parallel reduction (.neqv.:ra1) ! { dg-error "must be LOGICAL" }
!$omp parallel reduction (.neqv.:ra1) ! { dg-error "OMP DECLARE REDUCTION\[^\n\r\]*not found for type" }
!$omp end parallel
!$omp parallel reduction (.and.:d1) ! { dg-error "must be LOGICAL" }
!$omp parallel reduction (.and.:d1) ! { dg-error "OMP DECLARE REDUCTION\[^\n\r\]*not found for type" }
!$omp end parallel
!$omp parallel reduction (.or.:da1) ! { dg-error "must be LOGICAL" }
!$omp parallel reduction (.or.:da1) ! { dg-error "OMP DECLARE REDUCTION\[^\n\r\]*not found for type" }
!$omp end parallel
!$omp parallel reduction (.eqv.:c1) ! { dg-error "must be LOGICAL" }
!$omp parallel reduction (.eqv.:c1) ! { dg-error "OMP DECLARE REDUCTION\[^\n\r\]*not found for type" }
!$omp end parallel
!$omp parallel reduction (.neqv.:ca1) ! { dg-error "must be LOGICAL" }
!$omp parallel reduction (.neqv.:ca1) ! { dg-error "OMP DECLARE REDUCTION\[^\n\r\]*not found for type" }
!$omp end parallel
!$omp parallel reduction (.and.:a1) ! { dg-error "must be LOGICAL" }
!$omp parallel reduction (.and.:a1) ! { dg-error "OMP DECLARE REDUCTION\[^\n\r\]*not found for type" }
!$omp end parallel
!$omp parallel reduction (.or.:t1) ! { dg-error "must be LOGICAL" }
!$omp parallel reduction (.or.:t1) ! { dg-error "OMP DECLARE REDUCTION\[^\n\r\]*not found for type" }
!$omp end parallel
!$omp parallel reduction (.eqv.:ta1) ! { dg-error "must be LOGICAL" }
!$omp parallel reduction (.eqv.:ta1) ! { dg-error "OMP DECLARE REDUCTION\[^\n\r\]*not found for type" }
!$omp end parallel
!$omp parallel reduction (min:c1) ! { dg-error "must be INTEGER or REAL" }
!$omp parallel reduction (min:c1) ! { dg-error "OMP DECLARE REDUCTION\[^\n\r\]*not found for type" }
!$omp end parallel
!$omp parallel reduction (max:ca1) ! { dg-error "must be INTEGER or REAL" }
!$omp parallel reduction (max:ca1) ! { dg-error "OMP DECLARE REDUCTION\[^\n\r\]*not found for type" }
!$omp end parallel
!$omp parallel reduction (max:l1) ! { dg-error "must be INTEGER or REAL" }
!$omp parallel reduction (max:l1) ! { dg-error "OMP DECLARE REDUCTION\[^\n\r\]*not found for type" }
!$omp end parallel
!$omp parallel reduction (min:la1) ! { dg-error "must be INTEGER or REAL" }
!$omp parallel reduction (min:la1) ! { dg-error "OMP DECLARE REDUCTION\[^\n\r\]*not found for type" }
!$omp end parallel
!$omp parallel reduction (max:a1) ! { dg-error "must be INTEGER or REAL" }
!$omp parallel reduction (max:a1) ! { dg-error "OMP DECLARE REDUCTION\[^\n\r\]*not found for type" }
!$omp end parallel
!$omp parallel reduction (min:t1) ! { dg-error "must be INTEGER or REAL" }
!$omp parallel reduction (min:t1) ! { dg-error "OMP DECLARE REDUCTION\[^\n\r\]*not found for type" }
!$omp end parallel
!$omp parallel reduction (max:ta1) ! { dg-error "must be INTEGER or REAL" }
!$omp parallel reduction (max:ta1) ! { dg-error "OMP DECLARE REDUCTION\[^\n\r\]*not found for type" }
!$omp end parallel
!$omp parallel reduction (iand:r1) ! { dg-error "must be INTEGER" }
!$omp parallel reduction (iand:r1) ! { dg-error "OMP DECLARE REDUCTION\[^\n\r\]*not found for type" }
!$omp end parallel
!$omp parallel reduction (ior:ra1) ! { dg-error "must be INTEGER" }
!$omp parallel reduction (ior:ra1) ! { dg-error "OMP DECLARE REDUCTION\[^\n\r\]*not found for type" }
!$omp end parallel
!$omp parallel reduction (ieor:d1) ! { dg-error "must be INTEGER" }
!$omp parallel reduction (ieor:d1) ! { dg-error "OMP DECLARE REDUCTION\[^\n\r\]*not found for type" }
!$omp end parallel
!$omp parallel reduction (ior:da1) ! { dg-error "must be INTEGER" }
!$omp parallel reduction (ior:da1) ! { dg-error "OMP DECLARE REDUCTION\[^\n\r\]*not found for type" }
!$omp end parallel
!$omp parallel reduction (iand:c1) ! { dg-error "must be INTEGER" }
!$omp parallel reduction (iand:c1) ! { dg-error "OMP DECLARE REDUCTION\[^\n\r\]*not found for type" }
!$omp end parallel
!$omp parallel reduction (ior:ca1) ! { dg-error "must be INTEGER" }
!$omp parallel reduction (ior:ca1) ! { dg-error "OMP DECLARE REDUCTION\[^\n\r\]*not found for type" }
!$omp end parallel
!$omp parallel reduction (ieor:l1) ! { dg-error "must be INTEGER" }
!$omp parallel reduction (ieor:l1) ! { dg-error "OMP DECLARE REDUCTION\[^\n\r\]*not found for type" }
!$omp end parallel
!$omp parallel reduction (iand:la1) ! { dg-error "must be INTEGER" }
!$omp parallel reduction (iand:la1) ! { dg-error "OMP DECLARE REDUCTION\[^\n\r\]*not found for type" }
!$omp end parallel
!$omp parallel reduction (ior:a1) ! { dg-error "must be INTEGER" }
!$omp parallel reduction (ior:a1) ! { dg-error "OMP DECLARE REDUCTION\[^\n\r\]*not found for type" }
!$omp end parallel
!$omp parallel reduction (ieor:t1) ! { dg-error "must be INTEGER" }
!$omp parallel reduction (ieor:t1) ! { dg-error "OMP DECLARE REDUCTION\[^\n\r\]*not found for type" }
!$omp end parallel
!$omp parallel reduction (iand:ta1) ! { dg-error "must be INTEGER" }
!$omp parallel reduction (iand:ta1) ! { dg-error "OMP DECLARE REDUCTION\[^\n\r\]*not found for type" }
!$omp end parallel
end subroutine
gcc/testsuite/gfortran.dg/gomp/reduction3.f90
......@@ -16,7 +16,7 @@ subroutine f1
integer :: i, ior
ior = 6
i = 6
!$omp parallel reduction (ior:i) ! { dg-error "is not INTRINSIC procedure name" }
!$omp parallel reduction (ior:i) ! { dg-error "OMP DECLARE REDUCTION\[^\n\r\]*not found" }
!$omp end parallel
end subroutine f1
subroutine f2
......@@ -27,7 +27,7 @@ subroutine f2
end function
end interface
i = 6
!$omp parallel reduction (ior:i) ! { dg-error "is not INTRINSIC procedure name" }
!$omp parallel reduction (ior:i) ! { dg-error "OMP DECLARE REDUCTION\[^\n\r\]*not found" }
i = ior (i, 3)
!$omp end parallel
end subroutine f2
......@@ -50,7 +50,7 @@ subroutine f5
use mreduction3
integer :: i
i = 6
!$omp parallel reduction (ior:i) ! { dg-error "is not INTRINSIC procedure name" }
!$omp parallel reduction (ior:i) ! { dg-error "OMP DECLARE REDUCTION\[^\n\r\]*not found" }
i = ior (i, 7)
!$omp end parallel
end subroutine f5
......@@ -58,7 +58,7 @@ subroutine f6
use mreduction3
integer :: i
i = 6
!$omp parallel reduction (iand:i) ! { dg-error "is not INTRINSIC procedure name" }
!$omp parallel reduction (iand:i) ! { dg-error "OMP DECLARE REDUCTION\[^\n\r\]*not found" }
i = iand (i, 18)
!$omp end parallel
end subroutine f6
gcc/testsuite/gfortran.dg/gomp/udr1.f90 0 → 100644
! { dg-do compile }
subroutine f1
!$omp declare reduction (.le.:integer:omp_out = omp_out + omp_in) ! { dg-error "Invalid operator for" }
end subroutine f1
subroutine f2
!$omp declare reduction (bar:real(kind=4):omp_out = omp_out + omp_in)
real(kind=4) :: r
integer :: i
r = 0.0
!$omp parallel do reduction (bar:r)
do i = 1, 10
r = r + i
end do
!$omp parallel do reduction (foo:r) ! { dg-error "foo not found" }
do i = 1, 10
r = r + i
end do
!$omp parallel do reduction (.gt.:r) ! { dg-error "cannot be used as a defined operator" }
do i = 1, 10
r = r + i
end do
end subroutine f2
subroutine f3
!$omp declare reduction (foo:blah:omp_out=omp_out + omp_in) ! { dg-error "Unclassifiable OpenMP directive" }
end subroutine f3
subroutine f4
!$omp declare reduction (foo:integer:a => null()) ! { dg-error "Invalid character in name" }
!$omp declare reduction (foo:integer:omp_out = omp_in + omp_out) &
!$omp & initializer(a => null()) ! { dg-error "Invalid character in name" }
end subroutine f4
subroutine f5
integer :: a, b
!$omp declare reduction (foo:integer:a = b + 1) ! { dg-error "Variable other than OMP_OUT or OMP_IN used in combiner" }
!$omp declare reduction (bar:integer:omp_out = omp_out * omp_in) &
!$omp & initializer(b = a + 1) ! { dg-error "Variable other than OMP_PRIV or OMP_ORIG used in INITIALIZER clause" }
end subroutine f5
subroutine f6
!$omp declare reduction (foo:integer:omp_out=omp_out+omp_in) &
!$omp & initializer(omp_orig=omp_priv)
end subroutine f6
gcc/testsuite/gfortran.dg/gomp/udr2.f90 0 → 100644
! { dg-do compile }
subroutine f6
!$omp declare reduction (foo:real:omp_out (omp_in)) ! { dg-error "Unclassifiable OpenMP directive" }
!$omp declare reduction (bar:real:omp_out = omp_in * omp_out) & ! { dg-error "Unclassifiable OpenMP directive" }
!$omp & initializer (omp_priv (omp_orig))
end subroutine f6
subroutine f7
integer :: a
!$omp declare reduction (foo:integer:a (omp_out, omp_in)) ! { dg-error "Unclassifiable OpenMP directive" }
!$omp declare reduction (bar:real:omp_out = omp_out.or.omp_in) ! { dg-error "Operands of logical operator" }
!$omp declare reduction (baz:real:omp_out = omp_out + omp_in)
!$omp & initializer (a (omp_priv, omp_orig)) ! { dg-error "Unclassifiable OpenMP directive" }
end subroutine f7
subroutine f8
interface
subroutine f8a (x)
integer :: x
end subroutine f8a
end interface
!$omp declare reduction (baz:integer:omp_out = omp_out + omp_in) &
!$omp & initializer (f8a (omp_orig)) ! { dg-error "One of actual subroutine arguments in INITIALIZER clause" }
!$omp declare reduction (foo:integer:f8a) ! { dg-error "is not a variable" }
!$omp declare reduction (bar:integer:omp_out = omp_out - omp_in) &
!$omp & initializer (f8a) ! { dg-error "is not a variable" }
end subroutine f8
subroutine f9
type dt ! { dg-error "which is not consistent with the CALL" }
integer :: x = 0
integer :: y = 0
end type dt
!$omp declare reduction (foo:integer:dt (omp_out, omp_in)) ! { dg-error "which is not consistent with the CALL" }
!$omp declare reduction (bar:integer:omp_out = omp_out + omp_in) &
!$omp & initializer (dt (omp_priv, omp_orig)) ! { dg-error "which is not consistent with the CALL" }
end subroutine f9
subroutine f10
integer :: a, b
!$omp declare reduction(foo:character(len=64) &
!$omp & :omp_out(a:b) = omp_in(a:b)) ! { dg-error "Variable other than OMP_OUT or OMP_IN used in combiner" }
!$omp declare reduction(bar:character(len=16) &
!$omp & :omp_out = trim(omp_out) // omp_in) &
!$omp & initializer (omp_priv(a:b) = ' ') ! { dg-error "Variable other than OMP_PRIV or OMP_ORIG used in INITIALIZER clause" }
end subroutine f10
gcc/testsuite/gfortran.dg/gomp/udr3.f90 0 → 100644
! { dg-do compile }
subroutine f1
type dt
logical :: l = .false.
end type
type dt2
logical :: l = .false.
end type
!$omp declare reduction (foo:integer(kind = 4) & ! { dg-error "Previous !.OMP DECLARE REDUCTION" }
!$omp & :omp_out = omp_out + omp_in)
!$omp declare reduction (foo:integer(kind = 4) : & ! { dg-error "Redefinition of !.OMP DECLARE REDUCTION" }
!$omp & omp_out = omp_out + omp_in)
!$omp declare reduction (bar:integer, &
!$omp & real:omp_out = omp_out + omp_in)
!$omp declare reduction (baz:integer,real,integer & ! { dg-error "Redefinition of !.OMP DECLARE REDUCTION|Previous" }
!$omp & : omp_out = omp_out + omp_in)
!$omp declare reduction (id1:dt,dt2:omp_out%l=omp_out%l &
!$omp & .or.omp_in%l)
!$omp declare reduction (id2:dt,dt:omp_out%l=omp_out%l & ! { dg-error "Redefinition of !.OMP DECLARE REDUCTION|Previous" }
!$omp & .or.omp_in%l)
!$omp declare reduction (id3:dt2,dt:omp_out%l=omp_out%l & ! { dg-error "Previous !.OMP DECLARE REDUCTION" }
!$omp & .or.omp_in%l)
!$omp declare reduction (id3:dt2:omp_out%l=omp_out%l & ! { dg-error "Redefinition of !.OMP DECLARE REDUCTION" }
!$omp & .or.omp_in%l)
end subroutine f1
subroutine f2
interface
subroutine f2a (x, y, z)
character (len = *) :: x, y
logical :: z
end subroutine
end interface
interface f2b
subroutine f2b (x, y, z)
character (len = *, kind = 1) :: x, y
logical :: z
end subroutine
subroutine f2c (x, y, z)
character (kind = 4, len = *) :: x, y
logical :: z
end subroutine
end interface
!$omp declare reduction (foo:character(len=*): &
!$omp & f2a (omp_out, omp_in, .false.)) &
!$omp & initializer (f2a (omp_priv, omp_orig, .true.))
!$omp declare reduction (bar:character(len=:): &
!$omp & f2a (omp_out, omp_in, .false.)) &
!$omp & initializer (f2a (omp_priv, omp_orig, .true.))
!$omp declare reduction (baz:character(len=4): &
!$omp & f2a (omp_out, omp_in, .false.)) &
!$omp & initializer (f2a (omp_priv, omp_orig, .true.))
!$omp declare reduction (baz:character(len=5): &
!$omp & f2a (omp_out, omp_in, .false.)) &
!$omp & initializer (f2a (omp_priv, omp_orig, .true.))
!$omp declare reduction (baz:character(len=6): &
!$omp & f2a (omp_out, omp_in, .false.)) &
!$omp & initializer (f2a (omp_priv, omp_orig, .true.))
!$omp declare reduction (id:character(len=*): & ! { dg-error "Previous !.OMP DECLARE REDUCTION" }
!$omp & f2a (omp_out, omp_in, .false.)) &
!$omp & initializer (f2a (omp_priv, omp_orig, .true.))
!$omp declare reduction (id: & ! { dg-error "Redefinition of !.OMP DECLARE REDUCTION" }
!$omp & character(len=:) : f2a (omp_out, omp_in, .false.)) &
!$omp & initializer (f2a (omp_priv, omp_orig, .true.))
!$omp declare reduction & ! { dg-error "Redefinition of !.OMP DECLARE REDUCTION|Previous" }
!$omp (id2:character(len=*), character(len=:): &
!$omp f2a (omp_out, omp_in, .false.)) &
!$omp & initializer (f2a (omp_priv, omp_orig, .true.))
!$omp declare reduction (id3:character(len=*, kind = 1), character(kind=4, len=:): &
!$omp f2b (omp_out, omp_in, .false.)) &
!$omp & initializer (f2b (omp_priv, omp_orig, .true.))
!$omp declare reduction (id4:character(kind=4, len=4), character(kind =1, len=4): &
!$omp f2b (omp_out, omp_in, .false.)) &
!$omp & initializer (f2b (omp_priv, omp_orig, .true.))
end subroutine f2
gcc/testsuite/gfortran.dg/gomp/udr4.f90 0 → 100644
! { dg-do compile }
subroutine f3
!$omp declare reduction ! { dg-error "Unclassifiable OpenMP directive" }
!$omp declare reduction foo ! { dg-error "Unclassifiable OpenMP directive" }
!$omp declare reduction (foo) ! { dg-error "Unclassifiable OpenMP directive" }
!$omp declare reduction (foo:integer) ! { dg-error "Unclassifiable OpenMP directive" }
!$omp declare reduction (foo:integer:omp_out=omp_out+omp_in) &
!$omp & initializer(omp_priv=0) initializer(omp_priv=0) ! { dg-error "Unclassifiable statement" }
end subroutine f3
subroutine f4
implicit integer (o)
implicit real (b)
!$omp declare reduction (foo:integer:omp_priv(omp_out,omp_in)) ! { dg-error "Implicitly declared subroutine omp_priv" }
!$omp declare reduction (foo:real:bar(omp_out,omp_in)) ! { dg-error "Implicitly declared subroutine bar used" }
!$omp declare reduction (bar:integer:omp_out=omp_out+omp_in) &
!$omp & initializer(omp_out (omp_priv)) ! { dg-error "Implicitly declared subroutine omp_out used" }
!$omp declare reduction (bar:real:omp_out=omp_out+omp_in) &
!$omp & initializer(bar (omp_priv, omp_orig)) ! { dg-error "Implicitly declared subroutine bar used" }
!$omp declare reduction (id1:integer:omp_out=omp_orig(omp_out,omp_in)) ! { dg-error "Implicitly declared function omp_orig used" }
!$omp declare reduction (id1:real:omp_out=foo(omp_out,omp_in)) ! { dg-error "Implicitly declared function foo used" }
!$omp declare reduction (id2:integer:omp_out=omp_out+omp_in) &
!$omp & initializer(omp_priv = omp_in (omp_orig)) ! { dg-error "Implicitly declared function omp_in used" }
!$omp declare reduction (id2:real:omp_out=omp_out+omp_in) &
!$omp & initializer(omp_priv = baz (omp_orig)) ! { dg-error "Implicitly declared function baz used" }
end subroutine f4
subroutine f5
interface
subroutine f5a (x, *, y)
double precision :: x, y
end subroutine f5a
end interface
!$omp declare reduction (foo:double precision: & ! { dg-error "Subroutine call with alternate returns in combiner" }
!$omp & f5a (omp_out, *10, omp_in))
!$omp declare reduction (bar:double precision: &
!$omp omp_out = omp_in + omp_out) &
!$omp & initializer (f5a (omp_priv, *20, omp_orig)) ! { dg-error "Subroutine call with alternate returns in INITIALIZER clause" }
10 continue
20 continue
! { dg-error "Label\[^\n\r]* is never defined" "" { target *-*-* } 0 }
! { dg-prune-output "<During initialization>" }
end subroutine f5
subroutine f6
integer :: a
!$omp declare reduction(foo:character(len=a*2) & ! { dg-error "cannot appear in the expression|not constant" }
!$omp & :omp_out=trim(omp_out)//omp_in) &
!$omp & initializer(omp_priv=' ')
end subroutine f6
subroutine f7
type dt1
integer :: a = 1
integer :: b
end type
type dt2
integer :: a = 2
integer :: b = 3
end type
type dt3
integer :: a
integer :: b
end type dt3
!$omp declare reduction(foo:dt1,dt2:omp_out%a=omp_out%a+omp_in%a)
!$omp declare reduction(foo:dt3:omp_out%a=omp_out%a+omp_in%a) ! { dg-error "Missing INITIALIZER clause for !.OMP DECLARE REDUCTION of derived type without default initializer" }
end subroutine f7
gcc/testsuite/gfortran.dg/gomp/udr5.f90 0 → 100644
! { dg-do compile }
module udr5m1
type dt
real :: r
end type dt
end module udr5m1
module udr5m2
use udr5m1
interface operator(+)
module procedure addm2
end interface
!$omp declare reduction(+:dt:omp_out=omp_out+omp_in) &
!$omp & initializer(omp_priv=dt(0.0))
!$omp declare reduction(.myadd.:dt:omp_out=omp_out.myadd.omp_in) &
!$omp & initializer(omp_priv=dt(0.0))
interface operator(.myadd.)
module procedure addm2
end interface
contains
type(dt) function addm2 (x, y)
type(dt), intent (in):: x, y
addm2%r = x%r + y%r
end function
end module udr5m2
module udr5m3
use udr5m1
interface operator(.myadd.)
module procedure addm3
end interface
!$omp declare reduction(+:dt:omp_out=omp_out+omp_in) &
!$omp & initializer(omp_priv=dt(0.0))
!$omp declare reduction(.myadd.:dt:omp_out=omp_out.myadd.omp_in) &
!$omp & initializer(omp_priv=dt(0.0))
interface operator(+)
module procedure addm3
end interface
contains
type(dt) function addm3 (x, y)
type(dt), intent (in):: x, y
addm3%r = x%r + y%r
end function
end module udr5m3
subroutine f1
use udr5m2
type(dt) :: d, e
integer :: i
d=dt(0.0)
e = dt (0.0)
!$omp parallel do reduction (+ : d) reduction ( .myadd. : e)
do i=1,100
d=d+dt(i)
e=e+dt(i)
end do
end subroutine f1
subroutine f2
use udr5m3 ! { dg-error "Previous !.OMP DECLARE REDUCTION|Ambiguous interfaces" }
use udr5m2 ! { dg-error "Ambiguous !.OMP DECLARE REDUCTION" }
end subroutine f2
gcc/testsuite/gfortran.dg/gomp/udr6.f90 0 → 100644
! { dg-do compile }
! { dg-options "-fmax-errors=1000 -fopenmp -ffree-line-length-160" }
module udr6
type dt
integer :: i
end type
end module udr6
subroutine f1
use udr6, only : dt
!$omp declare reduction (+:integer:omp_out = omp_out + omp_in) ! { dg-error "Redefinition of predefined" }
!$omp declare reduction (+:real(kind=4):omp_out = omp_out + omp_in) ! { dg-error "Redefinition of predefined" }
!$omp declare reduction (+:double precision:omp_out = omp_out + omp_in) ! { dg-error "Redefinition of predefined" }
!$omp declare reduction (+:integer(kind=8),integer(kind=1) & ! { dg-error "Redefinition of predefined" }
!$omp & :omp_out = omp_out + omp_in)
!$omp declare reduction (+:complex:omp_out = omp_out + omp_in) ! { dg-error "Redefinition of predefined" }
!$omp declare reduction (+:complex(kind=16):omp_out = omp_out + omp_in) ! { dg-error "Redefinition of predefined" }
interface operator(+)
function addf1 (x, y)
use udr6, only : dt
type(dt), intent (in) :: x, y
type(dt) :: addf1
end function
end interface
end subroutine f1
subroutine f2
use udr6, only : dt
interface operator(-)
function subf2 (x, y)
use udr6, only : dt
type(dt), intent (in) :: x, y
type(dt) :: subf2
end function
end interface
!$omp declare reduction (-:integer:omp_out = omp_out + omp_in) ! { dg-error "Redefinition of predefined" }
!$omp declare reduction (-:real(kind=4):omp_out = omp_out + omp_in) ! { dg-error "Redefinition of predefined" }
!$omp declare reduction (-:double precision:omp_out = omp_out + omp_in) ! { dg-error "Redefinition of predefined" }
!$omp declare reduction (-:integer(kind=8),integer(kind=1) & ! { dg-error "Redefinition of predefined" }
!$omp & :omp_out = omp_out + omp_in)
!$omp declare reduction (-:complex:omp_out = omp_out + omp_in) ! { dg-error "Redefinition of predefined" }
!$omp declare reduction (-:complex(kind=16):omp_out = omp_out + omp_in) ! { dg-error "Redefinition of predefined" }
end subroutine f2
subroutine f3
use udr6, only : dt
interface operator(*)
function mulf3 (x, y)
use udr6, only : dt
type(dt), intent (in) :: x, y
type(dt) :: mulf3
end function
end interface
!$omp declare reduction (*:integer:omp_out = omp_out * omp_in) ! { dg-error "Redefinition of predefined" }
!$omp declare reduction (*:real(kind=4):omp_out = omp_out * omp_in) ! { dg-error "Redefinition of predefined" }
!$omp declare reduction (*:double precision:omp_out = omp_out * omp_in) ! { dg-error "Redefinition of predefined" }
!$omp declare reduction (*:integer(kind=8),integer(kind=1) & ! { dg-error "Redefinition of predefined" }
!$omp & :omp_out = omp_out * omp_in)
!$omp declare reduction (*:complex:omp_out = omp_out * omp_in) ! { dg-error "Redefinition of predefined" }
!$omp declare reduction (*:complex(kind=16):omp_out = omp_out * omp_in) ! { dg-error "Redefinition of predefined" }
end subroutine f3
subroutine f4
use udr6, only : dt
interface operator(.and.)
function andf4 (x, y)
use udr6, only : dt
type(dt), intent (in) :: x, y
type(dt) :: andf4
end function
end interface
!$omp declare reduction (.neqv.:logical:omp_out = omp_out .or. omp_in) ! { dg-error "Redefinition of predefined" }
interface operator(.or.)
function orf4 (x, y)
use udr6, only : dt
type(dt), intent (in) :: x, y
type(dt) :: orf4
end function
end interface
!$omp declare reduction (.eqv.:logical:omp_out = omp_out .or. omp_in) ! { dg-error "Redefinition of predefined" }
interface operator(.eqv.)
function eqvf4 (x, y)
use udr6, only : dt
type(dt), intent (in) :: x, y
type(dt) :: eqvf4
end function
end interface
!$omp declare reduction (.or.:logical:omp_out = omp_out .or. omp_in) ! { dg-error "Redefinition of predefined" }
interface operator(.neqv.)
function neqvf4 (x, y)
use udr6, only : dt
type(dt), intent (in) :: x, y
type(dt) :: neqvf4
end function
end interface
!$omp declare reduction (.and.:logical:omp_out = omp_out .and. omp_in) ! { dg-error "Redefinition of predefined" }
end subroutine f4
subroutine f5
use udr6, only : dt
interface operator(.and.)
function andf5 (x, y)
use udr6, only : dt
type(dt), intent (in) :: x, y
type(dt) :: andf5
end function
end interface
!$omp declare reduction (.neqv.:logical(kind =4):omp_out = omp_out .neqv. omp_in) ! { dg-error "Redefinition of predefined" }
interface operator(.or.)
function orf5 (x, y)
use udr6, only : dt
type(dt), intent (in) :: x, y
type(dt) :: orf5
end function
end interface
!$omp declare reduction (.eqv.:logical(kind= 4):omp_out = omp_out .eqv. omp_in) ! { dg-error "Redefinition of predefined" }
interface operator(.eqv.)
function eqvf5 (x, y)
use udr6, only : dt
type(dt), intent (in) :: x, y
type(dt) :: eqvf5
end function
end interface
!$omp declare reduction (.or.:logical(kind=4):omp_out = omp_out .or. omp_in) ! { dg-error "Redefinition of predefined" }
interface operator(.neqv.)
function neqvf5 (x, y)
use udr6, only : dt
type(dt), intent (in) :: x, y
type(dt) :: neqvf5
end function
end interface
!$omp declare reduction (.and.:logical(kind = 4):omp_out = omp_out .and. omp_in) ! { dg-error "Redefinition of predefined" }
end subroutine f5
subroutine f6
!$omp declare reduction (min:integer:omp_out = min (omp_out, omp_in)) ! { dg-error "Redefinition of predefined" }
!$omp declare reduction (max:integer:omp_out = max (omp_out, omp_in)) ! { dg-error "Redefinition of predefined" }
!$omp declare reduction (iand:integer:omp_out = iand (omp_out, omp_in)) ! { dg-error "Redefinition of predefined" }
!$omp declare reduction (ior:integer:omp_out = ior (omp_out, omp_in)) ! { dg-error "Redefinition of predefined" }
!$omp declare reduction (ieor:integer:omp_out = ieor (omp_out, omp_in)) ! { dg-error "Redefinition of predefined" }
!$omp declare reduction (min:real:omp_out = min (omp_out, omp_in)) ! { dg-error "Redefinition of predefined" }
!$omp declare reduction (max:real:omp_out = max (omp_out, omp_in)) ! { dg-error "Redefinition of predefined" }
!$omp declare reduction (min:double precision:omp_out = min (omp_out, omp_in)) ! { dg-error "Redefinition of predefined" }
!$omp declare reduction (max:double precision:omp_out = max (omp_out, omp_in)) ! { dg-error "Redefinition of predefined" }
end subroutine f6
subroutine f7
!$omp declare reduction (min:integer(kind=2):omp_out = min (omp_out, omp_in)) ! { dg-error "Redefinition of predefined" }
!$omp declare reduction (max:integer(kind=4):omp_out = max (omp_out, omp_in)) ! { dg-error "Redefinition of predefined" }
!$omp declare reduction (iand:integer(kind=1):omp_out = iand (omp_out, omp_in)) ! { dg-error "Redefinition of predefined" }
!$omp declare reduction (ior:integer(kind=8):omp_out = ior (omp_out, omp_in)) ! { dg-error "Redefinition of predefined" }
!$omp declare reduction (ieor:integer(kind=4):omp_out = ieor (omp_out, omp_in)) ! { dg-error "Redefinition of predefined" }
!$omp declare reduction (min:real(kind=4):omp_out = min (omp_out, omp_in)) ! { dg-error "Redefinition of predefined" }
!$omp declare reduction (max:real(kind=4):omp_out = max (omp_out, omp_in)) ! { dg-error "Redefinition of predefined" }
!$omp declare reduction (min:double precision:omp_out = min (omp_out, omp_in)) ! { dg-error "Redefinition of predefined" }
!$omp declare reduction (max:double precision:omp_out = max (omp_out, omp_in)) ! { dg-error "Redefinition of predefined" }
end subroutine f7
subroutine f8
integer :: min
!$omp declare reduction (min:integer:omp_out = omp_out + omp_in)
!$omp declare reduction (min:real:omp_out = omp_out + omp_in)
!$omp declare reduction (min:double precision:omp_out = omp_out + omp_in)
end subroutine f8
subroutine f9
integer :: max
!$omp declare reduction (max:integer:omp_out = omp_out + omp_in)
!$omp declare reduction (max:real:omp_out = omp_out + omp_in)
!$omp declare reduction (max:double precision:omp_out = omp_out + omp_in)
end subroutine f9
subroutine f10
integer :: iand
!$omp declare reduction (iand:integer:omp_out = omp_out + omp_in)
!$omp declare reduction (iand:real:omp_out = omp_out + omp_in)
end subroutine f10
subroutine f11
integer :: ior
!$omp declare reduction (ior:integer:omp_out = omp_out + omp_in)
!$omp declare reduction (ior:real:omp_out = omp_out + omp_in)
end subroutine f11
subroutine f12
integer :: ieor
!$omp declare reduction (ieor:integer:omp_out = omp_out + omp_in)
!$omp declare reduction (ieor:real:omp_out = omp_out + omp_in)
end subroutine f12
subroutine f13
!$omp declare reduction (min:integer:omp_out = omp_out + omp_in)
!$omp declare reduction (min:real:omp_out = omp_out + omp_in)
!$omp declare reduction (min:double precision:omp_out = omp_out + omp_in)
integer :: min
end subroutine f13
subroutine f14
!$omp declare reduction (max:integer:omp_out = omp_out + omp_in)
!$omp declare reduction (max:real:omp_out = omp_out + omp_in)
!$omp declare reduction (max:double precision:omp_out = omp_out + omp_in)
integer :: max
end subroutine f14
subroutine f15
!$omp declare reduction (iand:integer:omp_out = omp_out + omp_in)
!$omp declare reduction (iand:real:omp_out = omp_out + omp_in)
integer :: iand
end subroutine f15
subroutine f16
!$omp declare reduction (ior:integer:omp_out = omp_out + omp_in)
!$omp declare reduction (ior:real:omp_out = omp_out + omp_in)
integer :: ior
end subroutine f16
subroutine f17
!$omp declare reduction (ieor:integer:omp_out = omp_out + omp_in)
!$omp declare reduction (ieor:real:omp_out = omp_out + omp_in)
integer :: ieor
end subroutine f17
gcc/testsuite/gfortran.dg/gomp/udr7.f90 0 → 100644
! { dg-do compile }
module udr7m1
type dt
real :: r
end type dt
end module udr7m1
module udr7m2
use udr7m1
interface operator(+)
module procedure addm2
end interface
!$omp declare reduction(+:dt:omp_out=omp_out+omp_in) &
!$omp & initializer(omp_priv=dt(0.0))
!$omp declare reduction(.myadd.:dt:omp_out=omp_out.myadd.omp_in) &
!$omp & initializer(omp_priv=dt(0.0))
interface operator(.myadd.)
module procedure addm2
end interface
private
public :: operator(+), operator(.myadd.), dt
contains
type(dt) function addm2 (x, y)
type(dt), intent (in):: x, y
addm2%r = x%r + y%r
end function
end module udr7m2
module udr7m3
use udr7m1
private
public :: operator(.myadd.), operator(+), dt
interface operator(.myadd.)
module procedure addm3
end interface
!$omp declare reduction(+:dt:omp_out=omp_out+omp_in) &
!$omp & initializer(omp_priv=dt(0.0))
!$omp declare reduction(.myadd.:dt:omp_out=omp_out.myadd.omp_in) &
!$omp & initializer(omp_priv=dt(0.0))
interface operator(+)
module procedure addm3
end interface
contains
type(dt) function addm3 (x, y)
type(dt), intent (in):: x, y
addm3%r = x%r + y%r
end function
end module udr7m3
module udr7m4
use udr7m1
private
interface operator(.myadd.)
module procedure addm4
end interface
!$omp declare reduction(+:dt:omp_out=omp_out+omp_in) &
!$omp & initializer(omp_priv=dt(0.0))
!$omp declare reduction(.myadd.:dt:omp_out=omp_out.myadd.omp_in) &
!$omp & initializer(omp_priv=dt(0.0))
interface operator(+)
module procedure addm4
end interface
contains
type(dt) function addm4 (x, y)
type(dt), intent (in):: x, y
addm4%r = x%r + y%r
end function
end module udr7m4
subroutine f1
use udr7m2
type(dt) :: d, e
integer :: i
d=dt(0.0)
e = dt (0.0)
!$omp parallel do reduction (+ : d) reduction ( .myadd. : e)
do i=1,100
d=d+dt(i)
e=e+dt(i)
end do
end subroutine f1
subroutine f2
use udr7m3 ! { dg-error "Previous !.OMP DECLARE REDUCTION|Ambiguous interfaces" }
use udr7m2 ! { dg-error "Ambiguous !.OMP DECLARE REDUCTION" }
end subroutine f2
subroutine f3
use udr7m4
use udr7m2
end subroutine f3
subroutine f4
use udr7m3
use udr7m4
end subroutine f4
libgomp/ChangeLog
2014-06-06 Jakub Jelinek <jakub@redhat.com>
* testsuite/libgomp.fortran/simd1.f90: New test.
* testsuite/libgomp.fortran/udr1.f90: New test.
* testsuite/libgomp.fortran/udr2.f90: New test.
* testsuite/libgomp.fortran/udr3.f90: New test.
* testsuite/libgomp.fortran/udr4.f90: New test.
* testsuite/libgomp.fortran/udr5.f90: New test.
* testsuite/libgomp.fortran/udr6.f90: New test.
* testsuite/libgomp.fortran/udr7.f90: New test.
* testsuite/libgomp.fortran/udr8.f90: New test.
* testsuite/libgomp.fortran/udr9.f90: New test.
* testsuite/libgomp.fortran/udr10.f90: New test.
* testsuite/libgomp.fortran/udr11.f90: New test.
2014-05-27 Uros Bizjak <ubizjak@gmail.com>
* testsuite/libgomp.fortran/declare-simd-1.f90: Require
......
libgomp/testsuite/libgomp.fortran/simd1.f90
......@@ -2,22 +2,34 @@
! { dg-additional-options "-msse2" { target sse2_runtime } }
! { dg-additional-options "-mavx" { target avx_runtime } }
integer :: i, j, k, l, r, a(30)
type dt
integer :: x = 0
end type
type (dt) :: t
integer :: i, j, k, l, r, s, a(30)
integer, target :: q(30)
integer, pointer :: p(:)
!$omp declare reduction (foo : integer : &
!$omp & omp_out = omp_out + omp_in) initializer (omp_priv = 0)
!$omp declare reduction (+ : dt : omp_out%x = omp_out%x &
!$omp & + omp_in%x)
a(:) = 1
q(:) = 1
p => q
r = 0
j = 10
k = 20
!$omp simd safelen (8) reduction(+:r) linear(j, k : 2) &
!$omp& private (l) aligned(p : 4)
s = 0
!$omp simd safelen (8) reduction(+:r, t) linear(j, k : 2) &
!$omp& private (l) aligned(p : 4) reduction(foo:s)
do i = 1, 30
l = j + k + a(i) + p(i)
r = r + l
j = j + 2
k = k + 2
s = s + l
t%x = t%x + l
end do
if (r.ne.2700.or.j.ne.70.or.k.ne.80) call abort
if (r.ne.2700.or.j.ne.70.or.k.ne.80.or.s.ne.2700) call abort
if (t%x.ne.2700) call abort
end
libgomp/testsuite/libgomp.fortran/udr1.f90 0 → 100644
! { dg-do run }
module udr1
type dt
integer :: x = 7
integer :: y = 9
end type
end module udr1
use udr1, only : dt
!$omp declare reduction (foo : integer : omp_out = omp_out + omp_in)
integer :: i, j
!$omp declare reduction (bar : integer : &
!$omp & omp_out = omp_out + iand (omp_in, -4)) initializer (omp_priv = 3)
type (dt) :: d
!$omp declare reduction (+ : dt : omp_out%x = omp_out%x &
!$omp & + iand (omp_in%x, -8))
!$omp declare reduction (foo : dt : omp_out%x = iand (omp_in%x, -8) &
!$omp & + omp_out%x) initializer (omp_priv = dt (5, 21))
interface operator (+)
function notdefined(x, y)
use udr1, only : dt
type(dt), intent (in) :: x, y
type(dt) :: notdefined
end function
end interface
j = 0
!$omp parallel do reduction (foo : j)
do i = 1, 100
j = j + i
end do
if (j .ne. 5050) call abort
j = 3
!$omp parallel do reduction (bar : j)
do i = 1, 100
j = j + 4 * i
end do
if (j .ne. (5050 * 4 + 3)) call abort
!$omp parallel do reduction (+ : d)
do i = 1, 100
if (d%y .ne. 9) call abort
d%x = d%x + 8 * i
end do
if (d%x .ne. (5050 * 8 + 7) .or. d%y .ne. 9) call abort
d = dt (5, 21)
!$omp parallel do reduction (foo : d)
do i = 1, 100
if (d%y .ne. 21) call abort
d%x = d%x + 8 * i
end do
if (d%x .ne. (5050 * 8 + 5) .or. d%y .ne. 21) call abort
end
libgomp/testsuite/libgomp.fortran/udr10.f90 0 → 100644
! { dg-do run }
module udr10m
type dt
integer :: x = 0
end type
!$omp declare reduction(.add.:dt:omp_out=omp_out.add.omp_in)
!$omp declare reduction(+:dt:omp_out=omp_out+omp_in)
interface operator(+)
module procedure addme
end interface
interface operator(.add.)
module procedure addme
end interface
contains
type(dt) function addme (x, y)
type (dt), intent (in) :: x, y
addme%x = x%x + y%x
end function addme
end module udr10m
program udr10
use udr10m, only : operator(.localadd.) => operator(.add.), &
& operator(+), dl => dt
type(dl) :: j, k
integer :: i
!$omp parallel do reduction(+:j) reduction(.localadd.:k)
do i = 1, 100
j = j .localadd. dl(i)
k = k + dl(i * 2)
end do
if (j%x /= 5050 .or. k%x /= 10100) call abort
end
libgomp/testsuite/libgomp.fortran/udr11.f90 0 → 100644
! { dg-do run }
module udr11
type dt
integer :: x = 0
end type
end module udr11
use udr11, only : dt
!$omp declare reduction(+:dt:omp_out%x=omp_out%x+omp_in%x)
!$omp declare reduction(-:dt:omp_out%x=omp_out%x+omp_in%x)
!$omp declare reduction(*:dt:omp_out%x=omp_out%x+omp_in%x)
!$omp declare reduction(.and.:dt:omp_out%x=omp_out%x+omp_in%x)
!$omp declare reduction(.or.:dt:omp_out%x=omp_out%x+3*omp_in%x)
!$omp declare reduction(.eqv.:dt:omp_out%x=omp_out%x+omp_in%x)
!$omp declare reduction(.neqv.:dt:omp_out%x=omp_out%x+omp_in%x)
!$omp declare reduction(min:dt:omp_out%x=omp_out%x+omp_in%x)
!$omp declare reduction(max:dt:omp_out%x=omp_out%x+omp_in%x)
!$omp declare reduction(iand:dt:omp_out%x=omp_out%x+omp_in%x)
!$omp declare reduction(ior:dt:omp_out%x=omp_out%x+omp_in%x)
!$omp declare reduction(ieor:dt:omp_out%x=omp_out%x+omp_in%x)
interface operator(.and.)
function addme1 (x, y)
use udr11, only : dt
type (dt), intent (in) :: x, y
type(dt) :: addme1
end function addme1
end interface
interface operator(.or.)
function addme2 (x, y)
use udr11, only : dt
type (dt), intent (in) :: x, y
type(dt) :: addme2
end function addme2
end interface
interface operator(.eqv.)
function addme3 (x, y)
use udr11, only : dt
type (dt), intent (in) :: x, y
type(dt) :: addme3
end function addme3
end interface
interface operator(.neqv.)
function addme4 (x, y)
use udr11, only : dt
type (dt), intent (in) :: x, y
type(dt) :: addme4
end function addme4
end interface
interface operator(+)
function addme5 (x, y)
use udr11, only : dt
type (dt), intent (in) :: x, y
type(dt) :: addme5
end function addme5
end interface
interface operator(-)
function addme6 (x, y)
use udr11, only : dt
type (dt), intent (in) :: x, y
type(dt) :: addme6
end function addme6
end interface
interface operator(*)
function addme7 (x, y)
use udr11, only : dt
type (dt), intent (in) :: x, y
type(dt) :: addme7
end function addme7
end interface
type(dt) :: j, k, l, m, n, o, p, q, r, s, t, u
integer :: i
!$omp parallel do reduction(.and.:j) reduction(.or.:k) &
!$omp & reduction(.eqv.:l) reduction(.neqv.:m) &
!$omp & reduction(min:n) reduction(max:o) &
!$omp & reduction(iand:p) reduction(ior:q) reduction (ieor:r) &
!$omp & reduction(+:s) reduction(-:t) reduction(*:u)
do i = 1, 100
j%x = j%x + i
k%x = k%x + 2 * i
l%x = l%x + 3 * i
m%x = m%x + i
n%x = n%x + 2 * i
o%x = o%x + 3 * i
p%x = p%x + i
q%x = q%x + 2 * i
r%x = r%x + 3 * i
s%x = s%x + i
t%x = t%x + 2 * i
u%x = u%x + 3 * i
end do
if (j%x /= 5050 .or. k%x /= 30300 .or. l%x /= 15150) call abort
if (m%x /= 5050 .or. n%x /= 10100 .or. o%x /= 15150) call abort
if (p%x /= 5050 .or. q%x /= 10100 .or. r%x /= 15150) call abort
if (s%x /= 5050 .or. t%x /= 10100 .or. u%x /= 15150) call abort
end
libgomp/testsuite/libgomp.fortran/udr2.f90 0 → 100644
! { dg-do run }
module udr2
type dt
integer :: x = 7
integer :: y = 9
end type
end module udr2
use udr2, only : dt
!$omp declare reduction (foo : integer : omp_out = omp_out + omp_in)
integer :: i, j(2:4,3:5)
!$omp declare reduction (bar : integer : &
!$omp & omp_out = omp_out + iand (omp_in, -4)) initializer (omp_priv = 3)
interface operator (+)
function notdefined(x, y)
use udr2, only : dt
type(dt), intent (in) :: x, y
type(dt) :: notdefined
end function
end interface
type (dt) :: d(2:4,3:5)
!$omp declare reduction (+ : dt : omp_out%x = omp_out%x &
!$omp & + iand (omp_in%x, -8))
!$omp declare reduction (foo : dt : omp_out%x = iand (omp_in%x, -8) &
!$omp & + omp_out%x) initializer (omp_priv = dt (5, 21))
j = 0
!$omp parallel do reduction (foo : j)
do i = 1, 100
j = j + i
end do
if (any(j .ne. 5050)) call abort
j = 3
!$omp parallel do reduction (bar : j)
do i = 1, 100
j = j + 4 * i
end do
if (any(j .ne. (5050 * 4 + 3))) call abort
!$omp parallel do reduction (+ : d)
do i = 1, 100
if (any(d%y .ne. 9)) call abort
d%x = d%x + 8 * i
end do
if (any(d%x .ne. (5050 * 8 + 7)) .or. any(d%y .ne. 9)) call abort
d = dt (5, 21)
!$omp parallel do reduction (foo : d)
do i = 1, 100
if (any(d%y .ne. 21)) call abort
d%x = d%x + 8 * i
end do
if (any(d%x .ne. (5050 * 8 + 5)) .or. any(d%y .ne. 21)) call abort
end
libgomp/testsuite/libgomp.fortran/udr3.f90 0 → 100644
! { dg-do run }
!$omp declare reduction (foo : character(kind=1, len=*) &
!$omp & : omp_out = trim(omp_out) // omp_in) initializer (omp_priv = '')
!$omp declare reduction (bar : character(kind=1, len=:) &
!$omp & : omp_out = trim(omp_in) // omp_out) initializer (omp_priv = '')
!$omp declare reduction (baz : character(kind=1, len=1) &
!$omp & : omp_out = char (ichar (omp_out) + ichar (omp_in) &
!$omp & - ichar ('0'))) initializer (omp_priv = '0')
!$omp declare reduction (baz : character(kind=1, len=2) &
!$omp & : omp_out = char (ichar (omp_out(1:1)) + ichar (omp_in(1:1)) &
!$omp & - ichar ('0')) // char (ichar (omp_out(2:2)) + &
!$omp & ichar (omp_in(2:2)) - ichar ('0'))) initializer (omp_priv = '00')
character(kind=1, len=64) :: c, d
character(kind = 1, len=1) :: e
character(kind = 1, len=1+1) :: f
integer :: i
c = ''
d = ''
e = '0'
f = '00'
!$omp parallel do reduction (foo : c) reduction (bar : d) &
!$omp & reduction (baz : e, f)
do i = 1, 64
c = trim(c) // char (ichar ('0') + i)
d = char (ichar ('0') + i) // d
e = char (ichar (e) + mod (i, 3))
f = char (ichar (f(1:1)) + mod (i, 2)) &
& // char (ichar (f(2:2)) + mod (i, 3))
end do
do i = 1, 64
if (index (c, char (ichar ('0') + i)) .eq. 0) call abort
if (index (d, char (ichar ('0') + i)) .eq. 0) call abort
end do
if (e.ne.char (ichar ('0') + 64)) call abort
if (f(1:1).ne.char (ichar ('0') + 32)) call abort
if (f(2:2).ne.char (ichar ('0') + 64)) call abort
end
libgomp/testsuite/libgomp.fortran/udr4.f90 0 → 100644
! { dg-do run }
!$omp declare reduction (foo : character(kind=1, len=*) &
!$omp & : omp_out = trim(omp_out) // omp_in) initializer (omp_priv = '')
!$omp declare reduction (bar : character(kind=1, len=:) &
!$omp & : omp_out = trim(omp_in) // omp_out) initializer (omp_priv = '')
!$omp declare reduction (baz : character(kind=1, len=1) &
!$omp & : omp_out = char (ichar (omp_out) + ichar (omp_in) &
!$omp & - ichar ('0'))) initializer (omp_priv = '0')
!$omp declare reduction (baz : character(kind=1, len=2) &
!$omp & : omp_out = char (ichar (omp_out(1:1)) + ichar (omp_in(1:1)) &
!$omp & - ichar ('0')) // char (ichar (omp_out(2:2)) + &
!$omp & ichar (omp_in(2:2)) - ichar ('0'))) initializer (omp_priv = '00')
character(kind=1, len=64) :: c(-3:-2,1:1,7:8), d(2:3,-7:-5)
character(kind = 1, len=1) :: e(2:4)
character(kind = 1, len=1+1) :: f(8:10,9:10)
integer :: i, j, k
c = ''
d = ''
e = '0'
f = '00'
!$omp parallel do reduction (foo : c) reduction (bar : d) &
!$omp & reduction (baz : e, f) private (j, k)
do i = 1, 64
forall (j = -3:-2, k = 7:8) &
c(j,1,k) = trim(c(j,1,k)) // char (ichar ('0') + i)
d = char (ichar ('0') + i) // d
e = char (ichar (e) + mod (i, 3))
f = char (ichar (f(:,:)(1:1)) + mod (i, 2)) &
& // char (ichar (f(:,:)(2:2)) + mod (i, 3))
end do
do i = 1, 64
if (any (index (c, char (ichar ('0') + i)) .eq. 0)) call abort
if (any (index (d, char (ichar ('0') + i)) .eq. 0)) call abort
end do
if (any (e.ne.char (ichar ('0') + 64))) call abort
if (any (f(:,:)(1:1).ne.char (ichar ('0') + 32))) call abort
if (any (f(:,:)(2:2).ne.char (ichar ('0') + 64))) call abort
end
libgomp/testsuite/libgomp.fortran/udr5.f90 0 → 100644
! { dg-do run }
module m
interface operator(.add.)
module procedure do_add
end interface
type dt
real :: r = 0.0
end type
contains
function do_add(x, y)
type (dt), intent (in) :: x, y
type (dt) :: do_add
do_add%r = x%r + y%r
end function
subroutine dp_add(x, y)
double precision :: x, y
x = x + y
end subroutine
subroutine dp_init(x)
double precision :: x
x = 0.0
end subroutine
end module
program udr5
use m, only : operator(.add.), dt, dp_add, dp_init
type(dt) :: xdt, one
real :: r
integer (kind = 4) :: i4
integer (kind = 8) :: i8
real (kind = 4) :: r4
double precision :: dp
!$omp declare reduction(.add.:dt:omp_out=omp_out.add.omp_in)
!$omp declare reduction(foo:integer(4),integer(kind=8),real (kind = 4) &
!$omp & :omp_out = omp_out + omp_in) initializer (omp_priv = 0)
!$omp declare reduction(foo:double precision:dp_add (omp_out, omp_in)) &
!$omp & initializer (dp_init (omp_priv))
one%r = 1.0
r = 0.0
i4 = 0
i8 = 0
r4 = 0.0
call dp_init (dp)
!$omp parallel reduction(.add.: xdt) reduction(+: r) &
!$omp & reduction(foo: i4, i8, r4, dp)
xdt = xdt.add.one
r = r + 1.0
i4 = i4 + 1
i8 = i8 + 1
r4 = r4 + 1.0
call dp_add (dp, 1.0d0)
!$omp end parallel
if (xdt%r .ne. r) call abort
if (i4.ne.r.or.i8.ne.r.or.r4.ne.r.or.dp.ne.r) call abort
end program udr5
libgomp/testsuite/libgomp.fortran/udr6.f90 0 → 100644
! { dg-do run }
module m
interface operator(.add.)
module procedure do_add
end interface
type dt
real :: r = 0.0
end type
contains
function do_add(x, y)
type (dt), intent (in) :: x, y
type (dt) :: do_add
do_add%r = x%r + y%r
end function
subroutine dp_add(x, y)
double precision :: x, y
x = x + y
end subroutine
subroutine dp_init(x)
double precision :: x
x = 0.0
end subroutine
end module
program udr6
use m, only : operator(.add.), dt, dp_add, dp_init
type(dt), allocatable :: xdt(:)
type(dt) :: one
real :: r
integer (kind = 4), allocatable, dimension(:) :: i4
integer (kind = 8), allocatable, dimension(:,:) :: i8
integer :: i
real (kind = 4), allocatable :: r4(:,:)
double precision, allocatable :: dp(:)
!$omp declare reduction(.add.:dt:omp_out=omp_out.add.omp_in)
!$omp declare reduction(foo:integer(4),integer(kind=8),real (kind = 4) &
!$omp & :omp_out = omp_out + omp_in) initializer (omp_priv = 0)
!$omp declare reduction(foo:double precision:dp_add (omp_out, omp_in)) &
!$omp & initializer (dp_init (omp_priv))
one%r = 1.0
allocate (xdt(4), i4 (3), i8(-5:-2,2:3), r4(2:5,1:1), dp(7))
r = 0.0
i4 = 0
i8 = 0
r4 = 0.0
do i = 1, 7
call dp_init (dp(i))
end do
!$omp parallel reduction(.add.: xdt) reduction(+: r) &
!$omp & reduction(foo: i4, i8, r4, dp) private(i)
do i = 1, 4
xdt(i) = xdt(i).add.one
end do
r = r + 1.0
i4 = i4 + 1
i8 = i8 + 1
r4 = r4 + 1.0
do i = 1, 7
call dp_add (dp(i), 1.0d0)
end do
!$omp end parallel
if (any (xdt%r .ne. r)) call abort
if (any (i4.ne.r).or.any(i8.ne.r)) call abort
if (any(r4.ne.r).or.any(dp.ne.r)) call abort
deallocate (xdt, i4, i8, r4, dp)
end program udr6
libgomp/testsuite/libgomp.fortran/udr7.f90 0 → 100644
! { dg-do run }
program udr7
implicit none
interface
subroutine omp_priv (x, y, z)
real, intent (in) :: x
real, intent (inout) :: y
real, intent (in) :: z(:)
end subroutine omp_priv
real function omp_orig (x)
real, intent (in) :: x
end function omp_orig
end interface
!$omp declare reduction (omp_priv : real : &
!$omp & omp_priv (omp_orig (omp_in), omp_out, (/ 1.0, 2.0, 3.0 /))) &
!$omp & initializer (omp_out (omp_priv, omp_in (omp_orig)))
real :: x (2:4, 1:1, -2:0)
integer :: i
x = 0
!$omp parallel do reduction (omp_priv : x)
do i = 1, 64
x = x + i
end do
if (any (x /= 2080.0)) call abort
contains
subroutine omp_out (x, y)
real, intent (out) :: x
real, intent (in) :: y
if (y /= 4.0) call abort
x = 0.0
end subroutine omp_out
real function omp_in (x)
real, intent (in) :: x
omp_in = x + 4.0
end function omp_in
end program udr7
subroutine omp_priv (x, y, z)
real, intent (in) :: x
real, intent (inout) :: y
real, intent (in) :: z(:)
if (any (z .ne. (/ 1.0, 2.0, 3.0 /))) call abort
y = y + (x - 4.0)
end subroutine omp_priv
real function omp_orig (x)
real, intent (in) :: x
omp_orig = x + 4.0
end function omp_orig
libgomp/testsuite/libgomp.fortran/udr8.f90 0 → 100644
! { dg-do run }
module udr8m1
integer, parameter :: a = 6
integer :: b
!$omp declare reduction (foo : integer : omp_out = omp_out + omp_in)
!$omp declare reduction (.add. : integer : &
!$omp & omp_out = omp_out .add. iand (omp_in, -4)) &
!$omp & initializer (omp_priv = 3)
interface operator (.add.)
module procedure f1
end interface
contains
integer function f1 (x, y)
integer, intent (in) :: x, y
f1 = x + y
end function f1
end module udr8m1
module udr8m2
use udr8m1
type dt
integer :: x
end type
!$omp declare reduction (+ : dt : omp_out = omp_out + omp_in) &
!$omp & initializer (omp_priv = dt (0))
interface operator (+)
module procedure f2
end interface
contains
type(dt) function f2 (x, y)
type(dt), intent (in) :: x, y
f2%x = x%x + y%x
end function f2
end module udr8m2
use udr8m2
integer :: i, j
type(dt) :: d
j = 3
d%x = 0
!$omp parallel do reduction (.add.: j) reduction (+ : d)
do i = 1, 100
j = j.add.iand (i, -4)
d = d + dt(i)
end do
if (d%x /= 5050 .or. j /= 4903) call abort
end
libgomp/testsuite/libgomp.fortran/udr9.f90 0 → 100644
! { dg-do run }
module udr9m1
integer, parameter :: a = 6
integer :: b
!$omp declare reduction (foo : integer : combiner1 (omp_out, omp_in)) &
!$omp & initializer (initializer1 (omp_priv, omp_orig))
!$omp declare reduction (.add. : integer : &
!$omp & combiner1 (omp_out, omp_in)) &
!$omp & initializer (initializer1 (omp_priv, omp_orig))
interface operator (.add.)
module procedure f1
end interface
contains
integer function f1 (x, y)
integer, intent (in) :: x, y
f1 = x + y
end function f1
elemental subroutine combiner1 (x, y)
integer, intent (inout) :: x
integer, intent (in) :: y
x = x + iand (y, -4)
end subroutine
subroutine initializer1 (x, y)
integer :: x, y
if (y .ne. 3) call abort
x = y
end subroutine
end module udr9m1
module udr9m2
use udr9m1
type dt
integer :: x
end type
!$omp declare reduction (+ : dt : combiner2 (omp_in, omp_out)) &
!$omp & initializer (initializer2 (omp_priv))
interface operator (+)
module procedure f2
end interface
contains
type(dt) function f2 (x, y)
type(dt), intent (in) :: x, y
f2%x = x%x + y%x
end function f2
subroutine combiner2 (x, y)
type(dt) :: x, y
y = y + x
end subroutine combiner2
subroutine initializer2 (x)
type(dt), intent(out) :: x
x%x = 0
end subroutine initializer2
end module udr9m2
use udr9m2
integer :: i, j
type(dt) :: d
j = 3
d%x = 0
!$omp parallel do reduction (.add.: j) reduction (+ : d)
do i = 1, 100
j = j.add.iand (i, -4)
d = d + dt(i)
end do
if (d%x /= 5050 .or. j /= 4903) call abort
end
Markdown is supported
0% or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment