procyberian/gcc
1
0
Fork 0
Code Issues Pull requests Projects Releases Packages Wiki Activity Actions

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

Browse source 
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
This commit is contained in:
Jakub Jelinek 2014-06-06 09:24:38 +02:00 • committed by Jakub Jelinek
parent d969f3c163
commit 5f23671d3f
36 changed files with 2849 additions and 298 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

69
gcc/fortran/ChangeLog
View file

@ -1,3 +1,72 @@
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

85
gcc/fortran/dump-parse-tree.c
View file

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

11
gcc/fortran/frontend-passes.c
View file

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

75
gcc/fortran/gfortran.h
View file

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

1
gcc/fortran/match.h
View file

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

297
gcc/fortran/module.c
View file

@ -82,7 +82,7 @@ along with GCC; see the file COPYING3. If not see
/* Don't put any single quote (') in MOD_VERSION, if you want it to be
recognized. */
#define MOD_VERSION "12"
#define MOD_VERSION "13"
/* Structure that describes a position within a module file. */
@ -3896,6 +3896,98 @@ mio_omp_declare_simd (gfc_namespace *ns, gfc_omp_declare_simd **odsp)
}
static const mstring omp_declare_reduction_stmt[] =
{
minit ("ASSIGN", 0),
minit ("CALL", 1),
minit (NULL, -1)
};
static void
mio_omp_udr_expr (gfc_omp_udr *udr, gfc_symbol **sym1, gfc_symbol **sym2,
gfc_namespace *ns, bool is_initializer)
{
if (iomode == IO_OUTPUT)
{
if ((*sym1)->module == NULL)
{
(*sym1)->module = module_name;
(*sym2)->module = module_name;
}
mio_symbol_ref (sym1);
mio_symbol_ref (sym2);
if (ns->code->op == EXEC_ASSIGN)
{
mio_name (0, omp_declare_reduction_stmt);
mio_expr (&ns->code->expr1);
mio_expr (&ns->code->expr2);
}
else
{
int flag;
mio_name (1, omp_declare_reduction_stmt);
mio_symtree_ref (&ns->code->symtree);
mio_actual_arglist (&ns->code->ext.actual);
flag = ns->code->resolved_isym != NULL;
mio_integer (&flag);
if (flag)
write_atom (ATOM_STRING, ns->code->resolved_isym->name);
else
mio_symbol_ref (&ns->code->resolved_sym);
}
}
else
{
pointer_info *p1 = mio_symbol_ref (sym1);
pointer_info *p2 = mio_symbol_ref (sym2);
gfc_symbol *sym;
gcc_assert (p1->u.rsym.ns == p2->u.rsym.ns);
gcc_assert (p1->u.rsym.sym == NULL);
/* Add hidden symbols to the symtree. */
pointer_info *q = get_integer (p1->u.rsym.ns);
q->u.pointer = (void *) ns;
sym = gfc_new_symbol (is_initializer ? "omp_priv" : "omp_out", ns);
sym->ts = udr->ts;
sym->module = gfc_get_string (p1->u.rsym.module);
associate_integer_pointer (p1, sym);
sym->attr.omp_udr_artificial_var = 1;
gcc_assert (p2->u.rsym.sym == NULL);
sym = gfc_new_symbol (is_initializer ? "omp_orig" : "omp_in", ns);
sym->ts = udr->ts;
sym->module = gfc_get_string (p2->u.rsym.module);
associate_integer_pointer (p2, sym);
sym->attr.omp_udr_artificial_var = 1;
if (mio_name (0, omp_declare_reduction_stmt) == 0)
{
ns->code = gfc_get_code (EXEC_ASSIGN);
mio_expr (&ns->code->expr1);
mio_expr (&ns->code->expr2);
}
else
{
int flag;
ns->code = gfc_get_code (EXEC_CALL);
mio_symtree_ref (&ns->code->symtree);
mio_actual_arglist (&ns->code->ext.actual);
mio_integer (&flag);
if (flag)
{
require_atom (ATOM_STRING);
ns->code->resolved_isym = gfc_find_subroutine (atom_string);
free (atom_string);
}
else
mio_symbol_ref (&ns->code->resolved_sym);
}
ns->code->loc = gfc_current_locus;
ns->omp_udr_ns = 1;
}
}
/* Unlike most other routines, the address of the symbol node is already
fixed on input and the name/module has already been filled in.
If you update the symbol format here, don't forget to update read_module
@ -4453,6 +4545,119 @@ load_derived_extensions (void)
}
/* This function loads OpenMP user defined reductions. */
static void
load_omp_udrs (void)
{
mio_lparen ();
while (peek_atom () != ATOM_RPAREN)
{
const char *name, *newname;
char *altname;
gfc_typespec ts;
gfc_symtree *st;
gfc_omp_reduction_op rop = OMP_REDUCTION_USER;
mio_lparen ();
mio_pool_string (&name);
mio_typespec (&ts);
if (strncmp (name, "operator ", sizeof ("operator ") - 1) == 0)
{
const char *p = name + sizeof ("operator ") - 1;
if (strcmp (p, "+") == 0)
rop = OMP_REDUCTION_PLUS;
else if (strcmp (p, "*") == 0)
rop = OMP_REDUCTION_TIMES;
else if (strcmp (p, "-") == 0)
rop = OMP_REDUCTION_MINUS;
else if (strcmp (p, ".and.") == 0)
rop = OMP_REDUCTION_AND;
else if (strcmp (p, ".or.") == 0)
rop = OMP_REDUCTION_OR;
else if (strcmp (p, ".eqv.") == 0)
rop = OMP_REDUCTION_EQV;
else if (strcmp (p, ".neqv.") == 0)
rop = OMP_REDUCTION_NEQV;
}
altname = NULL;
if (rop == OMP_REDUCTION_USER && name[0] == '.')
{
size_t len = strlen (name + 1);
altname = XALLOCAVEC (char, len);
gcc_assert (name[len] == '.');
memcpy (altname, name + 1, len - 1);
altname[len - 1] = '\0';
}
newname = name;
if (rop == OMP_REDUCTION_USER)
newname = find_use_name (altname ? altname : name, !!altname);
else if (only_flag && find_use_operator ((gfc_intrinsic_op) rop) == NULL)
newname = NULL;
if (newname == NULL)
{
skip_list (1);
continue;
}
if (altname && newname != altname)
{
size_t len = strlen (newname);
altname = XALLOCAVEC (char, len + 3);
altname[0] = '.';
memcpy (altname + 1, newname, len);
altname[len + 1] = '.';
altname[len + 2] = '\0';
name = gfc_get_string (altname);
}
st = gfc_find_symtree (gfc_current_ns->omp_udr_root, name);
gfc_omp_udr *udr = gfc_omp_udr_find (st, &ts);
if (udr)
{
require_atom (ATOM_INTEGER);
pointer_info *p = get_integer (atom_int);
if (strcmp (p->u.rsym.module, udr->omp_out->module))
{
gfc_error ("Ambiguous !$OMP DECLARE REDUCTION from "
"module %s at %L",
p->u.rsym.module, &gfc_current_locus);
gfc_error ("Previous !$OMP DECLARE REDUCTION from module "
"%s at %L",
udr->omp_out->module, &udr->where);
}
skip_list (1);
continue;
}
udr = gfc_get_omp_udr ();
udr->name = name;
udr->rop = rop;
udr->ts = ts;
udr->where = gfc_current_locus;
udr->combiner_ns = gfc_get_namespace (gfc_current_ns, 1);
udr->combiner_ns->proc_name = gfc_current_ns->proc_name;
mio_omp_udr_expr (udr, &udr->omp_out, &udr->omp_in, udr->combiner_ns,
false);
if (peek_atom () != ATOM_RPAREN)
{
udr->initializer_ns = gfc_get_namespace (gfc_current_ns, 1);
udr->initializer_ns->proc_name = gfc_current_ns->proc_name;
mio_omp_udr_expr (udr, &udr->omp_priv, &udr->omp_orig,
udr->initializer_ns, true);
}
if (st)
{
udr->next = st->n.omp_udr;
st->n.omp_udr = udr;
}
else
{
st = gfc_new_symtree (&gfc_current_ns->omp_udr_root, name);
st->n.omp_udr = udr;
}
mio_rparen ();
}
mio_rparen ();
}
/* Recursive function to traverse the pointer_info tree and load a
needed symbol. We return nonzero if we load a symbol and stop the
traversal, because the act of loading can alter the tree. */
@ -4640,7 +4845,7 @@ check_for_ambiguous (gfc_symbol *st_sym, pointer_info *info)
static void
read_module (void)
{
module_locus operator_interfaces, user_operators, extensions;
module_locus operator_interfaces, user_operators, extensions, omp_udrs;
const char *p;
char name[GFC_MAX_SYMBOL_LEN + 1];
int i;
@ -4664,6 +4869,10 @@ read_module (void)
get_module_locus (&extensions);
skip_list ();
/* Skip OpenMP UDRs. */
get_module_locus (&omp_udrs);
skip_list ();
mio_lparen ();
/* Create the fixup nodes for all the symbols. */
@ -4929,6 +5138,10 @@ read_module (void)
load_commons ();
load_equiv ();
/* Load OpenMP user defined reductions. */
set_module_locus (&omp_udrs);
load_omp_udrs ();
/* At this point, we read those symbols that are needed but haven't
been loaded yet. If one symbol requires another, the other gets
marked as NEEDED if its previous state was UNUSED. */
@ -5307,6 +5520,80 @@ write_symbol0 (gfc_symtree *st)
}
static void
write_omp_udr (gfc_omp_udr *udr)
{
switch (udr->rop)
{
case OMP_REDUCTION_USER:
/* Non-operators can't be used outside of the module. */
if (udr->name[0] != '.')
return;
else
{
gfc_symtree *st;
size_t len = strlen (udr->name + 1);
char *name = XALLOCAVEC (char, len);
memcpy (name, udr->name, len - 1);
name[len - 1] = '\0';
st = gfc_find_symtree (gfc_current_ns->uop_root, name);
/* If corresponding user operator is private, don't write
the UDR. */
if (st != NULL)
{
gfc_user_op *uop = st->n.uop;
if (!check_access (uop->access, uop->ns->default_access))
return;
}
}
break;
case OMP_REDUCTION_PLUS:
case OMP_REDUCTION_MINUS:
case OMP_REDUCTION_TIMES:
case OMP_REDUCTION_AND:
case OMP_REDUCTION_OR:
case OMP_REDUCTION_EQV:
case OMP_REDUCTION_NEQV:
/* If corresponding operator is private, don't write the UDR. */
if (!check_access (gfc_current_ns->operator_access[udr->rop],
gfc_current_ns->default_access))
return;
break;
default:
break;
}
if (udr->ts.type == BT_DERIVED || udr->ts.type == BT_CLASS)
{
/* If derived type is private, don't write the UDR. */
if (!gfc_check_symbol_access (udr->ts.u.derived))
return;
}
mio_lparen ();
mio_pool_string (&udr->name);
mio_typespec (&udr->ts);
mio_omp_udr_expr (udr, &udr->omp_out, &udr->omp_in, udr->combiner_ns, false);
if (udr->initializer_ns)
mio_omp_udr_expr (udr, &udr->omp_priv, &udr->omp_orig,
udr->initializer_ns, true);
mio_rparen ();
}
static void
write_omp_udrs (gfc_symtree *st)
{
if (st == NULL)
return;
write_omp_udrs (st->left);
gfc_omp_udr *udr;
for (udr = st->n.omp_udr; udr; udr = udr->next)
write_omp_udr (udr);
write_omp_udrs (st->right);
}
/* Type for the temporary tree used when writing secondary symbols. */
struct sorted_pointer_info
@ -5555,6 +5842,12 @@ write_module (void)
write_char ('\n');
write_char ('\n');
mio_lparen ();
write_omp_udrs (gfc_current_ns->omp_udr_root);
mio_rparen ();
write_char ('\n');
write_char ('\n');
/* Write symbol information. First we traverse all symbols in the
primary namespace, writing those that need to be written.
Sometimes writing one symbol will cause another to need to be

842
gcc/fortran/openmp.c
View file

@ -23,6 +23,7 @@ along with GCC; see the file COPYING3. If not see
#include "coretypes.h"
#include "flags.h"
#include "gfortran.h"
#include "arith.h"
#include "match.h"
#include "parse.h"
#include "pointer-set.h"
@ -99,6 +100,66 @@ gfc_free_omp_declare_simd_list (gfc_omp_declare_simd *list)
}
}
/* Free an !$omp declare reduction. */
void
gfc_free_omp_udr (gfc_omp_udr *omp_udr)
{
if (omp_udr)
{
gfc_free_omp_udr (omp_udr->next);
gfc_free_namespace (omp_udr->combiner_ns);
if (omp_udr->initializer_ns)
gfc_free_namespace (omp_udr->initializer_ns);
free (omp_udr);
}
}
static gfc_omp_udr *
gfc_find_omp_udr (gfc_namespace *ns, const char *name, gfc_typespec *ts)
{
gfc_symtree *st;
if (ns == NULL)
ns = gfc_current_ns;
do
{
gfc_omp_udr *omp_udr;
st = gfc_find_symtree (ns->omp_udr_root, name);
if (st != NULL)
for (omp_udr = st->n.omp_udr; omp_udr; omp_udr = omp_udr->next)
if (ts == NULL)
return omp_udr;
else if (gfc_compare_types (&omp_udr->ts, ts))
{
if (ts->type == BT_CHARACTER)
{
if (omp_udr->ts.u.cl->length == NULL)
return omp_udr;
if (ts->u.cl->length == NULL)
continue;
if (gfc_compare_expr (omp_udr->ts.u.cl->length,
ts->u.cl->length,
INTRINSIC_EQ) != 0)
continue;
}
return omp_udr;
}
/* Don't escape an interface block. */
if (ns && !ns->has_import_set
&& ns->proc_name && ns->proc_name->attr.if_source == IFSRC_IFBODY)
break;
ns = ns->parent;
}
while (ns != NULL);
return NULL;
}
/* Match a variable/common block list and construct a namelist from it. */
@ -313,22 +374,30 @@ gfc_match_omp_clauses (gfc_omp_clauses **cp, int mask, bool first = true,
if ((mask & OMP_CLAUSE_REDUCTION)
&& gfc_match ("reduction ( ") == MATCH_YES)
{
int reduction = OMP_LIST_NUM;
char buffer[GFC_MAX_SYMBOL_LEN + 1];
gfc_omp_reduction_op rop = OMP_REDUCTION_NONE;
char buffer[GFC_MAX_SYMBOL_LEN + 3];
if (gfc_match_char ('+') == MATCH_YES)
reduction = OMP_LIST_PLUS;
rop = OMP_REDUCTION_PLUS;
else if (gfc_match_char ('*') == MATCH_YES)
reduction = OMP_LIST_MULT;
rop = OMP_REDUCTION_TIMES;
else if (gfc_match_char ('-') == MATCH_YES)
reduction = OMP_LIST_SUB;
rop = OMP_REDUCTION_MINUS;
else if (gfc_match (".and.") == MATCH_YES)
reduction = OMP_LIST_AND;
rop = OMP_REDUCTION_AND;
else if (gfc_match (".or.") == MATCH_YES)
reduction = OMP_LIST_OR;
rop = OMP_REDUCTION_OR;
else if (gfc_match (".eqv.") == MATCH_YES)
reduction = OMP_LIST_EQV;
rop = OMP_REDUCTION_EQV;
else if (gfc_match (".neqv.") == MATCH_YES)
reduction = OMP_LIST_NEQV;
rop = OMP_REDUCTION_NEQV;
if (rop != OMP_REDUCTION_NONE)
snprintf (buffer, sizeof buffer,
"operator %s", gfc_op2string ((gfc_intrinsic_op) rop));
else if (gfc_match_defined_op_name (buffer + 1, 1) == MATCH_YES)
{
buffer[0] = '.';
strcat (buffer, ".");
}
else if (gfc_match_name (buffer) == MATCH_YES)
{
gfc_symbol *sym;
@ -356,40 +425,60 @@ gfc_match_omp_clauses (gfc_omp_clauses **cp, int mask, bool first = true,
|| sym->attr.if_source != IFSRC_UNKNOWN
|| sym == sym->ns->proc_name)
{
gfc_error_now ("%s is not INTRINSIC procedure name "
"at %C", buffer);
sym = NULL;
n = NULL;
}
else
n = sym->name;
}
if (strcmp (n, "max") == 0)
reduction = OMP_LIST_MAX;
if (n == NULL)
rop = OMP_REDUCTION_NONE;
else if (strcmp (n, "max") == 0)
rop = OMP_REDUCTION_MAX;
else if (strcmp (n, "min") == 0)
reduction = OMP_LIST_MIN;
rop = OMP_REDUCTION_MIN;
else if (strcmp (n, "iand") == 0)
reduction = OMP_LIST_IAND;
rop = OMP_REDUCTION_IAND;
else if (strcmp (n, "ior") == 0)
reduction = OMP_LIST_IOR;
rop = OMP_REDUCTION_IOR;
else if (strcmp (n, "ieor") == 0)
reduction = OMP_LIST_IEOR;
if (reduction != OMP_LIST_NUM
rop = OMP_REDUCTION_IEOR;
if (rop != OMP_REDUCTION_NONE
&& sym != NULL
&& ! sym->attr.intrinsic
&& ! sym->attr.use_assoc
&& ((sym->attr.flavor == FL_UNKNOWN
&& !gfc_add_flavor (&sym->attr, FL_PROCEDURE, sym->name, NULL))
&& !gfc_add_flavor (&sym->attr, FL_PROCEDURE,
sym->name, NULL))
|| !gfc_add_intrinsic (&sym->attr, NULL)))
{
gfc_free_omp_clauses (c);
return MATCH_ERROR;
}
rop = OMP_REDUCTION_NONE;
}
gfc_omp_udr *udr = gfc_find_omp_udr (gfc_current_ns, buffer, NULL);
gfc_omp_namelist **head = NULL;
if (rop == OMP_REDUCTION_NONE && udr)
rop = OMP_REDUCTION_USER;
if (gfc_match_omp_variable_list (" :",
&c->lists[OMP_LIST_REDUCTION],
false, NULL, &head) == MATCH_YES)
{
gfc_omp_namelist *n;
if (rop == OMP_REDUCTION_NONE)
{
n = *head;
*head = NULL;
gfc_error_now ("!$OMP DECLARE REDUCTION %s not found "
"at %L", buffer, &old_loc);
gfc_free_omp_namelist (n);
}
else
for (n = *head; n; n = n->next)
{
n->rop = rop;
n->udr = udr;
}
continue;
}
if (reduction != OMP_LIST_NUM
&& gfc_match_omp_variable_list (" :", &c->lists[reduction],
false)
== MATCH_YES)
continue;
else
gfc_current_locus = old_loc;
}
@ -777,6 +866,382 @@ gfc_match_omp_declare_simd (void)
}
static bool
match_udr_expr (gfc_symtree *omp_sym1, gfc_symtree *omp_sym2)
{
match m;
locus old_loc = gfc_current_locus;
char sname[GFC_MAX_SYMBOL_LEN + 1];
gfc_symbol *sym;
gfc_namespace *ns = gfc_current_ns;
gfc_expr *lvalue = NULL, *rvalue = NULL;
gfc_symtree *st;
gfc_actual_arglist *arglist;
m = gfc_match (" %v =", &lvalue);
if (m != MATCH_YES)
gfc_current_locus = old_loc;
else
{
m = gfc_match (" %e )", &rvalue);
if (m == MATCH_YES)
{
ns->code = gfc_get_code (EXEC_ASSIGN);
ns->code->expr1 = lvalue;
ns->code->expr2 = rvalue;
ns->code->loc = old_loc;
return true;
}
gfc_current_locus = old_loc;
gfc_free_expr (lvalue);
}
m = gfc_match (" %n", sname);
if (m != MATCH_YES)
return false;
if (strcmp (sname, omp_sym1->name) == 0
|| strcmp (sname, omp_sym2->name) == 0)
return false;
gfc_current_ns = ns->parent;
if (gfc_get_ha_sym_tree (sname, &st))
return false;
sym = st->n.sym;
if (sym->attr.flavor != FL_PROCEDURE
&& sym->attr.flavor != FL_UNKNOWN)
return false;
if (!sym->attr.generic
&& !sym->attr.subroutine
&& !sym->attr.function)
{
if (!(sym->attr.external && !sym->attr.referenced))
{
/* ...create a symbol in this scope... */
if (sym->ns != gfc_current_ns
&& gfc_get_sym_tree (sname, NULL, &st, false) == 1)
return false;
if (sym != st->n.sym)
sym = st->n.sym;
}
/* ...and then to try to make the symbol into a subroutine. */
if (!gfc_add_subroutine (&sym->attr, sym->name, NULL))
return false;
}
gfc_set_sym_referenced (sym);
gfc_gobble_whitespace ();
if (gfc_peek_ascii_char () != '(')
return false;
gfc_current_ns = ns;
m = gfc_match_actual_arglist (1, &arglist);
if (m != MATCH_YES)
return false;
if (gfc_match_char (')') != MATCH_YES)
return false;
ns->code = gfc_get_code (EXEC_CALL);
ns->code->symtree = st;
ns->code->ext.actual = arglist;
ns->code->loc = old_loc;
return true;
}
static bool
gfc_omp_udr_predef (gfc_omp_reduction_op rop, const char *name,
gfc_typespec *ts, const char **n)
{
if (!gfc_numeric_ts (ts) && ts->type != BT_LOGICAL)
return false;
switch (rop)
{
case OMP_REDUCTION_PLUS:
case OMP_REDUCTION_MINUS:
case OMP_REDUCTION_TIMES:
return ts->type != BT_LOGICAL;
case OMP_REDUCTION_AND:
case OMP_REDUCTION_OR:
case OMP_REDUCTION_EQV:
case OMP_REDUCTION_NEQV:
return ts->type == BT_LOGICAL;
case OMP_REDUCTION_USER:
if (name[0] != '.' && (ts->type == BT_INTEGER || ts->type == BT_REAL))
{
gfc_symbol *sym;
gfc_find_symbol (name, NULL, 1, &sym);
if (sym != NULL)
{
if (sym->attr.intrinsic)
*n = sym->name;
else if ((sym->attr.flavor != FL_UNKNOWN
&& sym->attr.flavor != FL_PROCEDURE)
|| sym->attr.external
|| sym->attr.generic
|| sym->attr.entry
|| sym->attr.result
|| sym->attr.dummy
|| sym->attr.subroutine
|| sym->attr.pointer
|| sym->attr.target
|| sym->attr.cray_pointer
|| sym->attr.cray_pointee
|| (sym->attr.proc != PROC_UNKNOWN
&& sym->attr.proc != PROC_INTRINSIC)
|| sym->attr.if_source != IFSRC_UNKNOWN
|| sym == sym->ns->proc_name)
*n = NULL;
else
*n = sym->name;
}
else
*n = name;
if (*n
&& (strcmp (*n, "max") == 0 || strcmp (*n, "min") == 0))
return true;
else if (*n
&& ts->type == BT_INTEGER
&& (strcmp (*n, "iand") == 0
|| strcmp (*n, "ior") == 0
|| strcmp (*n, "ieor") == 0))
return true;
}
break;
default:
break;
}
return false;
}
gfc_omp_udr *
gfc_omp_udr_find (gfc_symtree *st, gfc_typespec *ts)
{
gfc_omp_udr *omp_udr;
if (st == NULL)
return NULL;
for (omp_udr = st->n.omp_udr; omp_udr; omp_udr = omp_udr->next)
if (omp_udr->ts.type == ts->type
|| ((omp_udr->ts.type == BT_DERIVED || omp_udr->ts.type == BT_CLASS)
&& (ts->type == BT_DERIVED && ts->type == BT_CLASS)))
{
if (omp_udr->ts.type == BT_DERIVED || omp_udr->ts.type == BT_CLASS)
{
if (strcmp (omp_udr->ts.u.derived->name, ts->u.derived->name) == 0)
return omp_udr;
}
else if (omp_udr->ts.kind == ts->kind)
{
if (omp_udr->ts.type == BT_CHARACTER)
{
if (omp_udr->ts.u.cl->length == NULL
|| ts->u.cl->length == NULL)
return omp_udr;
if (omp_udr->ts.u.cl->length->expr_type != EXPR_CONSTANT)
return omp_udr;
if (ts->u.cl->length->expr_type != EXPR_CONSTANT)
return omp_udr;
if (omp_udr->ts.u.cl->length->ts.type != BT_INTEGER)
return omp_udr;
if (ts->u.cl->length->ts.type != BT_INTEGER)
return omp_udr;
if (gfc_compare_expr (omp_udr->ts.u.cl->length,
ts->u.cl->length, INTRINSIC_EQ) != 0)
continue;
}
return omp_udr;
}
}
return NULL;
}
match
gfc_match_omp_declare_reduction (void)
{
match m;
gfc_intrinsic_op op;
char name[GFC_MAX_SYMBOL_LEN + 3];
auto_vec<gfc_typespec, 5> tss;
gfc_typespec ts;
unsigned int i;
gfc_symtree *st;
locus where = gfc_current_locus;
locus end_loc = gfc_current_locus;
bool end_loc_set = false;
gfc_omp_reduction_op rop = OMP_REDUCTION_NONE;
if (gfc_match_char ('(') != MATCH_YES)
return MATCH_ERROR;
m = gfc_match (" %o : ", &op);
if (m == MATCH_ERROR)
return MATCH_ERROR;
if (m == MATCH_YES)
{
snprintf (name, sizeof name, "operator %s", gfc_op2string (op));
rop = (gfc_omp_reduction_op) op;
}
else
{
m = gfc_match_defined_op_name (name + 1, 1);
if (m == MATCH_ERROR)
return MATCH_ERROR;
if (m == MATCH_YES)
{
name[0] = '.';
strcat (name, ".");
if (gfc_match (" : ") != MATCH_YES)
return MATCH_ERROR;
}
else
{
if (gfc_match (" %n : ", name) != MATCH_YES)
return MATCH_ERROR;
}
rop = OMP_REDUCTION_USER;
}
m = gfc_match_type_spec (&ts);
if (m != MATCH_YES)
return MATCH_ERROR;
tss.safe_push (ts);
while (gfc_match_char (',') == MATCH_YES)
{
m = gfc_match_type_spec (&ts);
if (m != MATCH_YES)
return MATCH_ERROR;
tss.safe_push (ts);
}
if (gfc_match_char (':') != MATCH_YES)
return MATCH_ERROR;
st = gfc_find_symtree (gfc_current_ns->omp_udr_root, name);
for (i = 0; i < tss.length (); i++)
{
gfc_symtree *omp_out, *omp_in;
gfc_symtree *omp_priv = NULL, *omp_orig = NULL;
gfc_namespace *combiner_ns, *initializer_ns = NULL;
gfc_omp_udr *prev_udr, *omp_udr;
const char *predef_name = NULL;
omp_udr = gfc_get_omp_udr ();
omp_udr->name = gfc_get_string (name);
omp_udr->rop = rop;
omp_udr->ts = tss[i];
omp_udr->where = where;
gfc_current_ns = combiner_ns = gfc_get_namespace (gfc_current_ns, 1);
combiner_ns->proc_name = combiner_ns->parent->proc_name;
gfc_get_sym_tree ("omp_out", combiner_ns, &omp_out, false);
gfc_get_sym_tree ("omp_in", combiner_ns, &omp_in, false);
combiner_ns->omp_udr_ns = 1;
omp_out->n.sym->ts = tss[i];
omp_in->n.sym->ts = tss[i];
omp_out->n.sym->attr.omp_udr_artificial_var = 1;
omp_in->n.sym->attr.omp_udr_artificial_var = 1;
gfc_commit_symbols ();
omp_udr->combiner_ns = combiner_ns;
omp_udr->omp_out = omp_out->n.sym;
omp_udr->omp_in = omp_in->n.sym;
locus old_loc = gfc_current_locus;
if (!match_udr_expr (omp_out, omp_in))
{
syntax:
gfc_current_locus = old_loc;
gfc_current_ns = combiner_ns->parent;
gfc_free_omp_udr (omp_udr);
return MATCH_ERROR;
}
if (gfc_match (" initializer ( ") == MATCH_YES)
{
gfc_current_ns = combiner_ns->parent;
initializer_ns = gfc_get_namespace (gfc_current_ns, 1);
gfc_current_ns = initializer_ns;
initializer_ns->proc_name = initializer_ns->parent->proc_name;
gfc_get_sym_tree ("omp_priv", initializer_ns, &omp_priv, false);
gfc_get_sym_tree ("omp_orig", initializer_ns, &omp_orig, false);
initializer_ns->omp_udr_ns = 1;
omp_priv->n.sym->ts = tss[i];
omp_orig->n.sym->ts = tss[i];
omp_priv->n.sym->attr.omp_udr_artificial_var = 1;
omp_orig->n.sym->attr.omp_udr_artificial_var = 1;
gfc_commit_symbols ();
omp_udr->initializer_ns = initializer_ns;
omp_udr->omp_priv = omp_priv->n.sym;
omp_udr->omp_orig = omp_orig->n.sym;
if (!match_udr_expr (omp_priv, omp_orig))
goto syntax;
}
gfc_current_ns = combiner_ns->parent;
if (!end_loc_set)
{
end_loc_set = true;
end_loc = gfc_current_locus;
}
gfc_current_locus = old_loc;
prev_udr = gfc_omp_udr_find (st, &tss[i]);
if (gfc_omp_udr_predef (rop, name, &tss[i], &predef_name)
/* Don't error on !$omp declare reduction (min : integer : ...)
just yet, there could be integer :: min afterwards,
making it valid. When the UDR is resolved, we'll get
to it again. */
&& (rop != OMP_REDUCTION_USER || name[0] == '.'))
{
if (predef_name)
gfc_error_now ("Redefinition of predefined %s "
"!$OMP DECLARE REDUCTION at %L",
predef_name, &where);
else
gfc_error_now ("Redefinition of predefined "
"!$OMP DECLARE REDUCTION at %L", &where);
}
else if (prev_udr)
{
gfc_error_now ("Redefinition of !$OMP DECLARE REDUCTION at %L",
&where);
gfc_error_now ("Previous !$OMP DECLARE REDUCTION at %L",
&prev_udr->where);
}
else if (st)
{
omp_udr->next = st->n.omp_udr;
st->n.omp_udr = omp_udr;
}
else
{
st = gfc_new_symtree (&gfc_current_ns->omp_udr_root, name);
st->n.omp_udr = omp_udr;
}
}
if (end_loc_set)
{
gfc_current_locus = end_loc;
return MATCH_YES;
}
gfc_clear_error ();
return MATCH_ERROR;
}
match
gfc_match_omp_threadprivate (void)
{
@ -1285,10 +1750,8 @@ resolve_omp_clauses (gfc_code *code, locus *where,
{
const char *name;
if (list < OMP_LIST_REDUCTION_FIRST)
if (list < OMP_LIST_NUM)
name = clause_names[list];
else if (list <= OMP_LIST_REDUCTION_LAST)
name = clause_names[OMP_LIST_REDUCTION_FIRST];
else
gcc_unreachable ();
@ -1409,6 +1872,7 @@ resolve_omp_clauses (gfc_code *code, locus *where,
default:
for (; n != NULL; n = n->next)
{
bool bad = false;
if (n->sym->attr.threadprivate)
gfc_error ("THREADPRIVATE object '%s' in %s clause at %L",
n->sym->name, name, where);
@ -1417,74 +1881,113 @@ resolve_omp_clauses (gfc_code *code, locus *where,
n->sym->name, name, where);
if (list != OMP_LIST_PRIVATE)
{
if (n->sym->attr.pointer
&& list >= OMP_LIST_REDUCTION_FIRST
&& list <= OMP_LIST_REDUCTION_LAST)
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_FIRST || list > OMP_LIST_REDUCTION_LAST)
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_FIRST
&& list <= OMP_LIST_REDUCTION_LAST)
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);
}
if (n->sym->as && n->sym->as->type == AS_ASSUMED_SIZE)
gfc_error ("Assumed size array '%s' in %s clause at %L",
n->sym->name, name, where);
if (n->sym->attr.in_namelist
&& (list < OMP_LIST_REDUCTION_FIRST
|| list > OMP_LIST_REDUCTION_LAST))
if (n->sym->attr.in_namelist && list != OMP_LIST_REDUCTION)
gfc_error ("Variable '%s' in %s clause is used in "
"NAMELIST statement at %L",
n->sym->name, name, where);
switch (list)
{
case OMP_LIST_PLUS:
case OMP_LIST_MULT:
case OMP_LIST_SUB:
if (!gfc_numeric_ts (&n->sym->ts))
gfc_error ("%c REDUCTION variable '%s' at %L must be of numeric type, got %s",
list == OMP_LIST_PLUS ? '+'
: list == OMP_LIST_MULT ? '*' : '-',
n->sym->name, where,
gfc_typename (&n->sym->ts));
break;
case OMP_LIST_AND:
case OMP_LIST_OR:
case OMP_LIST_EQV:
case OMP_LIST_NEQV:
if (n->sym->ts.type != BT_LOGICAL)
gfc_error ("%s REDUCTION variable '%s' must be LOGICAL "
"at %L",
list == OMP_LIST_AND ? ".AND."
: list == OMP_LIST_OR ? ".OR."
: list == OMP_LIST_EQV ? ".EQV." : ".NEQV.",
n->sym->name, where);
break;
case OMP_LIST_MAX:
case OMP_LIST_MIN:
if (n->sym->ts.type != BT_INTEGER
&& n->sym->ts.type != BT_REAL)
gfc_error ("%s REDUCTION variable '%s' must be "
"INTEGER or REAL at %L",
list == OMP_LIST_MAX ? "MAX" : "MIN",
n->sym->name, where);
break;
case OMP_LIST_IAND:
case OMP_LIST_IOR:
case OMP_LIST_IEOR:
if (n->sym->ts.type != BT_INTEGER)
gfc_error ("%s REDUCTION variable '%s' must be INTEGER "
"at %L",
list == OMP_LIST_IAND ? "IAND"
: list == OMP_LIST_MULT ? "IOR" : "IEOR",
n->sym->name, where);
case OMP_LIST_REDUCTION:
switch (n->rop)
{
case OMP_REDUCTION_PLUS:
case OMP_REDUCTION_TIMES:
case OMP_REDUCTION_MINUS:
if (!gfc_numeric_ts (&n->sym->ts))
bad = true;
break;
case OMP_REDUCTION_AND:
case OMP_REDUCTION_OR:
case OMP_REDUCTION_EQV:
case OMP_REDUCTION_NEQV:
if (n->sym->ts.type != BT_LOGICAL)
bad = true;
break;
case OMP_REDUCTION_MAX:
case OMP_REDUCTION_MIN:
if (n->sym->ts.type != BT_INTEGER
&& n->sym->ts.type != BT_REAL)
bad = true;
break;
case OMP_REDUCTION_IAND:
case OMP_REDUCTION_IOR:
case OMP_REDUCTION_IEOR:
if (n->sym->ts.type != BT_INTEGER)
bad = true;
break;
case OMP_REDUCTION_USER:
bad = true;
break;
default:
break;
}
if (!bad)
n->udr = NULL;
else
{
const char *udr_name = NULL;
if (n->udr)
{
udr_name = n->udr->name;
n->udr = gfc_find_omp_udr (NULL, udr_name,
&n->sym->ts);
}
if (n->udr == NULL)
{
if (udr_name == NULL)
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:
udr_name = gfc_op2string ((gfc_intrinsic_op)
n->rop);
break;
case OMP_REDUCTION_MAX:
udr_name = "max";
break;
case OMP_REDUCTION_MIN:
udr_name = "min";
break;
case OMP_REDUCTION_IAND:
udr_name = "iand";
break;
case OMP_REDUCTION_IOR:
udr_name = "ior";
break;
case OMP_REDUCTION_IEOR:
udr_name = "ieor";
break;
default:
gcc_unreachable ();
}
gfc_error ("!$OMP DECLARE REDUCTION %s not found "
"for type %s at %L", udr_name,
gfc_typename (&n->sym->ts), where);
}
else
n->rop = OMP_REDUCTION_USER;
}
break;
case OMP_LIST_LINEAR:
if (n->sym->ts.type != BT_INTEGER)
@ -2312,3 +2815,180 @@ gfc_resolve_omp_declare_simd (gfc_namespace *ns)
resolve_omp_clauses (NULL, &ods->where, ods->clauses, ns);
}
}
struct omp_udr_callback_data
{
gfc_omp_udr *omp_udr;
bool is_initializer;
};
static int
omp_udr_callback (gfc_expr **e, int *walk_subtrees ATTRIBUTE_UNUSED,
void *data)
{
struct omp_udr_callback_data *cd = (struct omp_udr_callback_data *) data;
if ((*e)->expr_type == EXPR_VARIABLE)
{
if (cd->is_initializer)
{
if ((*e)->symtree->n.sym != cd->omp_udr->omp_priv
&& (*e)->symtree->n.sym != cd->omp_udr->omp_orig)
gfc_error ("Variable other than OMP_PRIV or OMP_ORIG used in "
"INITIALIZER clause of !$OMP DECLARE REDUCTION at %L",
&(*e)->where);
}
else
{
if ((*e)->symtree->n.sym != cd->omp_udr->omp_out
&& (*e)->symtree->n.sym != cd->omp_udr->omp_in)
gfc_error ("Variable other than OMP_OUT or OMP_IN used in "
"combiner of !$OMP DECLARE REDUCTION at %L",
&(*e)->where);
}
}
else if ((*e)->expr_type == EXPR_FUNCTION
&& (*e)->value.function.isym == NULL)
{
gfc_symbol *sym = (*e)->symtree->n.sym;
if (!sym->attr.intrinsic
&& sym->attr.if_source == IFSRC_UNKNOWN)
gfc_error ("Implicitly declared function %s used in "
"!$OMP DECLARE REDUCTION at %L ", sym->name, &(*e)->where);
}
return 0;
}
/* Resolve !$omp declare reduction constructs. */
static void
gfc_resolve_omp_udr (gfc_omp_udr *omp_udr)
{
gfc_actual_arglist *a;
const char *predef_name = NULL;
gfc_resolve (omp_udr->combiner_ns);
if (omp_udr->initializer_ns)
gfc_resolve (omp_udr->initializer_ns);
switch (omp_udr->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:
case OMP_REDUCTION_MAX:
case OMP_REDUCTION_USER:
break;
default:
gfc_error ("Invalid operator for !$OMP DECLARE REDUCTION %s at %L",
omp_udr->name, &omp_udr->where);
return;
}
if (gfc_omp_udr_predef (omp_udr->rop, omp_udr->name,
&omp_udr->ts, &predef_name))
{
if (predef_name)
gfc_error_now ("Redefinition of predefined %s "
"!$OMP DECLARE REDUCTION at %L",
predef_name, &omp_udr->where);
else
gfc_error_now ("Redefinition of predefined "
"!$OMP DECLARE REDUCTION at %L", &omp_udr->where);
return;
}
if (omp_udr->ts.type == BT_CHARACTER
&& omp_udr->ts.u.cl->length
&& omp_udr->ts.u.cl->length->expr_type != EXPR_CONSTANT)
{
gfc_error ("CHARACTER length in !$OMP DECLARE REDUCTION %s not "
"constant at %L", omp_udr->name, &omp_udr->where);
return;
}
struct omp_udr_callback_data cd;
cd.omp_udr = omp_udr;
cd.is_initializer = false;
gfc_code_walker (&omp_udr->combiner_ns->code, gfc_dummy_code_callback,
omp_udr_callback, &cd);
if (omp_udr->combiner_ns->code->op == EXEC_CALL)
{
for (a = omp_udr->combiner_ns->code->ext.actual; a; a = a->next)
if (a->expr == NULL)
break;
if (a)
gfc_error ("Subroutine call with alternate returns in combiner "
"of !$OMP DECLARE REDUCTION at %L",
&omp_udr->combiner_ns->code->loc);
if (omp_udr->combiner_ns->code->resolved_isym == NULL)
{
gfc_symbol *sym = omp_udr->combiner_ns->code->resolved_sym;
if (sym
&& !sym->attr.intrinsic
&& sym->attr.if_source == IFSRC_UNKNOWN)
gfc_error ("Implicitly declared subroutine %s used in "
"!$OMP DECLARE REDUCTION at %L ", sym->name,
&omp_udr->combiner_ns->code->loc);
}
}
if (omp_udr->initializer_ns)
{
cd.is_initializer = true;
gfc_code_walker (&omp_udr->initializer_ns->code, gfc_dummy_code_callback,
omp_udr_callback, &cd);
if (omp_udr->initializer_ns->code->op == EXEC_CALL)
{
for (a = omp_udr->initializer_ns->code->ext.actual; a; a = a->next)
if (a->expr == NULL)
break;
if (a)
gfc_error ("Subroutine call with alternate returns in "
"INITIALIZER clause of !$OMP DECLARE REDUCTION "
"at %L", &omp_udr->initializer_ns->code->loc);
for (a = omp_udr->initializer_ns->code->ext.actual; a; a = a->next)
if (a->expr
&& a->expr->expr_type == EXPR_VARIABLE
&& a->expr->symtree->n.sym == omp_udr->omp_priv
&& a->expr->ref == NULL)
break;
if (a == NULL)
gfc_error ("One of actual subroutine arguments in INITIALIZER "
"clause of !$OMP DECLARE REDUCTION must be OMP_PRIV "
"at %L", &omp_udr->initializer_ns->code->loc);
if (omp_udr->initializer_ns->code->resolved_isym == NULL)
{
gfc_symbol *sym = omp_udr->initializer_ns->code->resolved_sym;
if (sym
&& !sym->attr.intrinsic
&& sym->attr.if_source == IFSRC_UNKNOWN)
gfc_error ("Implicitly declared subroutine %s used in "
"!$OMP DECLARE REDUCTION at %L ", sym->name,
&omp_udr->initializer_ns->code->loc);
}
}
}
else if (omp_udr->ts.type == BT_DERIVED
&& !gfc_has_default_initializer (omp_udr->ts.u.derived))
{
gfc_error ("Missing INITIALIZER clause for !$OMP DECLARE REDUCTION "
"of derived type without default initializer at %L",
&omp_udr->where);
return;
}
}
void
gfc_resolve_omp_udrs (gfc_symtree *st)
{
gfc_omp_udr *omp_udr;
if (st == NULL)
return;
gfc_resolve_omp_udrs (st->left);
gfc_resolve_omp_udrs (st->right);
for (omp_udr = st->n.omp_udr; omp_udr; omp_udr = omp_udr->next)
gfc_resolve_omp_udr (omp_udr);
}

7
gcc/fortran/parse.c
View file

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

10
gcc/fortran/resolve.c
View file

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

33
gcc/fortran/symbol.c
View file

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

420
gcc/fortran/trans-openmp.c
View file

@ -525,12 +525,104 @@ gfc_trans_omp_variable_list (enum omp_clause_code code,
return list;
}
static void
gfc_trans_omp_array_reduction (tree c, gfc_symbol *sym, locus where)
struct omp_udr_find_orig_data
{
gfc_omp_udr *omp_udr;
bool omp_orig_seen;
};
static int
omp_udr_find_orig (gfc_expr **e, int *walk_subtrees ATTRIBUTE_UNUSED,
void *data)
{
struct omp_udr_find_orig_data *cd = (struct omp_udr_find_orig_data *) data;
if ((*e)->expr_type == EXPR_VARIABLE
&& (*e)->symtree->n.sym == cd->omp_udr->omp_orig)
cd->omp_orig_seen = true;
return 0;
}
static tree
gfc_trans_omp_udr_expr (gfc_omp_namelist *n, bool is_initializer,
gfc_expr *syme, gfc_expr *outere)
{
gfc_se symse, outerse;
gfc_ss *symss, *outerss;
gfc_loopinfo loop;
stmtblock_t block, body;
tree tem;
int i;
gfc_namespace *ns = (is_initializer
? n->udr->initializer_ns : n->udr->combiner_ns);
syme = gfc_copy_expr (syme);
outere = gfc_copy_expr (outere);
gfc_init_se (&symse, NULL);
gfc_init_se (&outerse, NULL);
gfc_start_block (&block);
gfc_init_loopinfo (&loop);
symss = gfc_walk_expr (syme);
outerss = gfc_walk_expr (outere);
gfc_add_ss_to_loop (&loop, symss);
gfc_add_ss_to_loop (&loop, outerss);
gfc_conv_ss_startstride (&loop);
/* Enable loop reversal. */
for (i = 0; i < GFC_MAX_DIMENSIONS; i++)
loop.reverse[i] = GFC_ENABLE_REVERSE;
gfc_conv_loop_setup (&loop, &ns->code->loc);
gfc_copy_loopinfo_to_se (&symse, &loop);
gfc_copy_loopinfo_to_se (&outerse, &loop);
symse.ss = symss;
outerse.ss = outerss;
gfc_mark_ss_chain_used (symss, 1);
gfc_mark_ss_chain_used (outerss, 1);
gfc_start_scalarized_body (&loop, &body);
gfc_conv_expr (&symse, syme);
gfc_conv_expr (&outerse, outere);
if (is_initializer)
{
n->udr->omp_priv->backend_decl = symse.expr;
n->udr->omp_orig->backend_decl = outerse.expr;
}
else
{
n->udr->omp_out->backend_decl = outerse.expr;
n->udr->omp_in->backend_decl = symse.expr;
}
if (ns->code->op == EXEC_ASSIGN)
tem = gfc_trans_assignment (ns->code->expr1, ns->code->expr2,
false, false);
else
tem = gfc_trans_call (ns->code, false, NULL_TREE, NULL_TREE, false);
gfc_add_expr_to_block (&body, tem);
gcc_assert (symse.ss == gfc_ss_terminator
&& outerse.ss == gfc_ss_terminator);
/* Generate the copying loops. */
gfc_trans_scalarizing_loops (&loop, &body);
/* Wrap the whole thing up. */
gfc_add_block_to_block (&block, &loop.pre);
gfc_add_block_to_block (&block, &loop.post);
gfc_cleanup_loop (&loop);
gfc_free_expr (syme);
gfc_free_expr (outere);
return gfc_finish_block (&block);
}
static void
gfc_trans_omp_array_reduction_or_udr (tree c, gfc_omp_namelist *n, locus where)
{
gfc_symbol *sym = n->sym;
gfc_symtree *root1 = NULL, *root2 = NULL, *root3 = NULL, *root4 = NULL;
gfc_symtree *symtree1, *symtree2, *symtree3, *symtree4 = NULL;
gfc_symbol init_val_sym, outer_sym, intrinsic_sym;
gfc_symbol omp_var_copy[4];
gfc_expr *e1, *e2, *e3, *e4;
gfc_ref *ref;
tree decl, backend_decl, stmt, type, outer_decl;
@ -559,12 +651,29 @@ gfc_trans_omp_array_reduction (tree c, gfc_symbol *sym, locus where)
init_val_sym.attr.referenced = 1;
init_val_sym.declared_at = where;
init_val_sym.attr.flavor = FL_VARIABLE;
backend_decl = omp_reduction_init (c, gfc_sym_type (&init_val_sym));
if (OMP_CLAUSE_REDUCTION_CODE (c) != ERROR_MARK)
backend_decl = omp_reduction_init (c, gfc_sym_type (&init_val_sym));
else if (n->udr->initializer_ns)
backend_decl = NULL;
else
switch (sym->ts.type)
{
case BT_LOGICAL:
case BT_INTEGER:
case BT_REAL:
case BT_COMPLEX:
backend_decl = build_zero_cst (gfc_sym_type (&init_val_sym));
break;
default:
backend_decl = NULL_TREE;
break;
}
init_val_sym.backend_decl = backend_decl;
/* Create a fake symbol for the outer array reference. */
outer_sym = *sym;
outer_sym.as = gfc_copy_array_spec (sym->as);
if (sym->as)
outer_sym.as = gfc_copy_array_spec (sym->as);
outer_sym.attr.dummy = 0;
outer_sym.attr.result = 0;
outer_sym.attr.flavor = FL_VARIABLE;
@ -585,28 +694,94 @@ gfc_trans_omp_array_reduction (tree c, gfc_symbol *sym, locus where)
symtree3->n.sym = &outer_sym;
gcc_assert (symtree3 == root3);
memset (omp_var_copy, 0, sizeof omp_var_copy);
if (n->udr)
{
omp_var_copy[0] = *n->udr->omp_out;
omp_var_copy[1] = *n->udr->omp_in;
if (sym->attr.dimension)
{
n->udr->omp_out->ts = sym->ts;
n->udr->omp_in->ts = sym->ts;
}
else
{
*n->udr->omp_out = outer_sym;
*n->udr->omp_in = *sym;
}
if (n->udr->initializer_ns)
{
omp_var_copy[2] = *n->udr->omp_priv;
omp_var_copy[3] = *n->udr->omp_orig;
if (sym->attr.dimension)
{
n->udr->omp_priv->ts = sym->ts;
n->udr->omp_orig->ts = sym->ts;
}
else
{
*n->udr->omp_priv = *sym;
*n->udr->omp_orig = outer_sym;
}
}
}
/* Create expressions. */
e1 = gfc_get_expr ();
e1->expr_type = EXPR_VARIABLE;
e1->where = where;
e1->symtree = symtree1;
e1->ts = sym->ts;
e1->ref = ref = gfc_get_ref ();
ref->type = REF_ARRAY;
ref->u.ar.where = where;
ref->u.ar.as = sym->as;
ref->u.ar.type = AR_FULL;
ref->u.ar.dimen = 0;
if (sym->attr.dimension)
{
e1->ref = ref = gfc_get_ref ();
ref->type = REF_ARRAY;
ref->u.ar.where = where;
ref->u.ar.as = sym->as;
ref->u.ar.type = AR_FULL;
ref->u.ar.dimen = 0;
}
t = gfc_resolve_expr (e1);
gcc_assert (t);
e2 = gfc_get_expr ();
e2->expr_type = EXPR_VARIABLE;
e2->where = where;
e2->symtree = symtree2;
e2->ts = sym->ts;
t = gfc_resolve_expr (e2);
gcc_assert (t);
e2 = NULL;
if (backend_decl != NULL_TREE)
{
e2 = gfc_get_expr ();
e2->expr_type = EXPR_VARIABLE;
e2->where = where;
e2->symtree = symtree2;
e2->ts = sym->ts;
t = gfc_resolve_expr (e2);
gcc_assert (t);
}
else if (n->udr->initializer_ns == NULL)
{
gcc_assert (sym->ts.type == BT_DERIVED);
e2 = gfc_default_initializer (&sym->ts);
gcc_assert (e2);
t = gfc_resolve_expr (e2);
gcc_assert (t);
}
else if (n->udr->initializer_ns->code->op == EXEC_ASSIGN)
{
if (!sym->attr.dimension)
{
e2 = gfc_copy_expr (n->udr->initializer_ns->code->expr2);
t = gfc_resolve_expr (e2);
gcc_assert (t);
}
}
if (n->udr && n->udr->initializer_ns)
{
struct omp_udr_find_orig_data cd;
cd.omp_udr = n->udr;
cd.omp_orig_seen = false;
gfc_code_walker (&n->udr->initializer_ns->code,
gfc_dummy_code_callback, omp_udr_find_orig, &cd);
if (cd.omp_orig_seen)
OMP_CLAUSE_REDUCTION_OMP_ORIG_REF (c) = 1;
}
e3 = gfc_copy_expr (e1);
e3->symtree = symtree3;
@ -614,6 +789,7 @@ gfc_trans_omp_array_reduction (tree c, gfc_symbol *sym, locus where)
gcc_assert (t);
iname = NULL;
e4 = NULL;
switch (OMP_CLAUSE_REDUCTION_CODE (c))
{
case PLUS_EXPR:
@ -650,6 +826,21 @@ gfc_trans_omp_array_reduction (tree c, gfc_symbol *sym, locus where)
case BIT_XOR_EXPR:
iname = "ieor";
break;
case ERROR_MARK:
if (n->udr->combiner_ns->code->op == EXEC_ASSIGN)
{
if (!sym->attr.dimension)
{
gfc_free_expr (e3);
e3 = gfc_copy_expr (n->udr->combiner_ns->code->expr1);
e4 = gfc_copy_expr (n->udr->combiner_ns->code->expr2);
t = gfc_resolve_expr (e3);
gcc_assert (t);
t = gfc_resolve_expr (e4);
gcc_assert (t);
}
}
break;
default:
gcc_unreachable ();
}
@ -679,15 +870,19 @@ gfc_trans_omp_array_reduction (tree c, gfc_symbol *sym, locus where)
e4->value.function.actual->next = gfc_get_actual_arglist ();
e4->value.function.actual->next->expr = e1;
}
/* e1 and e3 have been stored as arguments of e4, avoid sharing. */
e1 = gfc_copy_expr (e1);
e3 = gfc_copy_expr (e3);
t = gfc_resolve_expr (e4);
gcc_assert (t);
if (OMP_CLAUSE_REDUCTION_CODE (c) != ERROR_MARK)
{
/* e1 and e3 have been stored as arguments of e4, avoid sharing. */
e1 = gfc_copy_expr (e1);
e3 = gfc_copy_expr (e3);
t = gfc_resolve_expr (e4);
gcc_assert (t);
}
/* Create the init statement list. */
pushlevel ();
if (GFC_DESCRIPTOR_TYPE_P (type)
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
@ -719,12 +914,20 @@ gfc_trans_omp_array_reduction (tree c, gfc_symbol *sym, locus where)
gfc_allocate_using_malloc (&block, ptr, size, NULL_TREE);
gfc_conv_descriptor_data_set (&block, decl, ptr);
gfc_add_expr_to_block (&block, gfc_trans_assignment (e1, e2, false,
false));
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
else 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);
else
stmt = gfc_trans_call (n->udr->initializer_ns->code, false,
NULL_TREE, NULL_TREE, false);
if (TREE_CODE (stmt) != BIND_EXPR)
stmt = build3_v (BIND_EXPR, NULL, stmt, poplevel (1, 0));
else
@ -733,7 +936,8 @@ gfc_trans_omp_array_reduction (tree c, gfc_symbol *sym, locus where)
/* Create the merge statement list. */
pushlevel ();
if (GFC_DESCRIPTOR_TYPE_P (type)
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
@ -741,14 +945,22 @@ gfc_trans_omp_array_reduction (tree c, gfc_symbol *sym, locus where)
stmtblock_t block;
gfc_start_block (&block);
gfc_add_expr_to_block (&block, gfc_trans_assignment (e3, e4, false,
true));
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
else 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);
else
stmt = gfc_trans_call (n->udr->combiner_ns->code, false,
NULL_TREE, NULL_TREE, false);
if (TREE_CODE (stmt) != BIND_EXPR)
stmt = build3_v (BIND_EXPR, NULL, stmt, poplevel (1, 0));
else
@ -761,19 +973,33 @@ gfc_trans_omp_array_reduction (tree c, gfc_symbol *sym, locus where)
gfc_current_locus = old_loc;
gfc_free_expr (e1);
gfc_free_expr (e2);
if (e2)
gfc_free_expr (e2);
gfc_free_expr (e3);
gfc_free_expr (e4);
if (e4)
gfc_free_expr (e4);
free (symtree1);
free (symtree2);
free (symtree3);
free (symtree4);
gfc_free_array_spec (outer_sym.as);
if (outer_sym.as)
gfc_free_array_spec (outer_sym.as);
if (n->udr)
{
*n->udr->omp_out = omp_var_copy[0];
*n->udr->omp_in = omp_var_copy[1];
if (n->udr->initializer_ns)
{
*n->udr->omp_priv = omp_var_copy[2];
*n->udr->omp_orig = omp_var_copy[3];
}
}
}
static tree
gfc_trans_omp_reduction_list (gfc_omp_namelist *namelist, tree list,
enum tree_code reduction_code, locus where)
locus where)
{
for (; namelist != NULL; namelist = namelist->next)
if (namelist->sym->attr.referenced)
@ -784,9 +1010,53 @@ gfc_trans_omp_reduction_list (gfc_omp_namelist *namelist, tree list,
tree node = build_omp_clause (where.lb->location,
OMP_CLAUSE_REDUCTION);
OMP_CLAUSE_DECL (node) = t;
OMP_CLAUSE_REDUCTION_CODE (node) = reduction_code;
if (namelist->sym->attr.dimension)
gfc_trans_omp_array_reduction (node, namelist->sym, where);
switch (namelist->rop)
{
case OMP_REDUCTION_PLUS:
OMP_CLAUSE_REDUCTION_CODE (node) = PLUS_EXPR;
break;
case OMP_REDUCTION_MINUS:
OMP_CLAUSE_REDUCTION_CODE (node) = MINUS_EXPR;
break;
case OMP_REDUCTION_TIMES:
OMP_CLAUSE_REDUCTION_CODE (node) = MULT_EXPR;
break;
case OMP_REDUCTION_AND:
OMP_CLAUSE_REDUCTION_CODE (node) = TRUTH_ANDIF_EXPR;
break;
case OMP_REDUCTION_OR:
OMP_CLAUSE_REDUCTION_CODE (node) = TRUTH_ORIF_EXPR;
break;
case OMP_REDUCTION_EQV:
OMP_CLAUSE_REDUCTION_CODE (node) = EQ_EXPR;
break;
case OMP_REDUCTION_NEQV:
OMP_CLAUSE_REDUCTION_CODE (node) = NE_EXPR;
break;
case OMP_REDUCTION_MAX:
OMP_CLAUSE_REDUCTION_CODE (node) = MAX_EXPR;
break;
case OMP_REDUCTION_MIN:
OMP_CLAUSE_REDUCTION_CODE (node) = MIN_EXPR;
break;
case OMP_REDUCTION_IAND:
OMP_CLAUSE_REDUCTION_CODE (node) = BIT_AND_EXPR;
break;
case OMP_REDUCTION_IOR:
OMP_CLAUSE_REDUCTION_CODE (node) = BIT_IOR_EXPR;
break;
case OMP_REDUCTION_IEOR:
OMP_CLAUSE_REDUCTION_CODE (node) = BIT_XOR_EXPR;
break;
case OMP_REDUCTION_USER:
OMP_CLAUSE_REDUCTION_CODE (node) = ERROR_MARK;
break;
default:
gcc_unreachable ();
}
if (namelist->sym->attr.dimension
|| namelist->rop == OMP_REDUCTION_USER)
gfc_trans_omp_array_reduction_or_udr (node, namelist, where);
list = gfc_trans_add_clause (node, list);
}
}
@ -811,58 +1081,11 @@ gfc_trans_omp_clauses (stmtblock_t *block, gfc_omp_clauses *clauses,
if (n == NULL)
continue;
if (list >= OMP_LIST_REDUCTION_FIRST
&& list <= OMP_LIST_REDUCTION_LAST)
{
enum tree_code reduction_code;
switch (list)
{
case OMP_LIST_PLUS:
reduction_code = PLUS_EXPR;
break;
case OMP_LIST_MULT:
reduction_code = MULT_EXPR;
break;
case OMP_LIST_SUB:
reduction_code = MINUS_EXPR;
break;
case OMP_LIST_AND:
reduction_code = TRUTH_ANDIF_EXPR;
break;
case OMP_LIST_OR:
reduction_code = TRUTH_ORIF_EXPR;
break;
case OMP_LIST_EQV:
reduction_code = EQ_EXPR;
break;
case OMP_LIST_NEQV:
reduction_code = NE_EXPR;
break;
case OMP_LIST_MAX:
reduction_code = MAX_EXPR;
break;
case OMP_LIST_MIN:
reduction_code = MIN_EXPR;
break;
case OMP_LIST_IAND:
reduction_code = BIT_AND_EXPR;
break;
case OMP_LIST_IOR:
reduction_code = BIT_IOR_EXPR;
break;
case OMP_LIST_IEOR:
reduction_code = BIT_XOR_EXPR;
break;
default:
gcc_unreachable ();
}
omp_clauses
= gfc_trans_omp_reduction_list (n, omp_clauses, reduction_code,
where);
continue;
}
switch (list)
{
case OMP_LIST_REDUCTION:
omp_clauses = gfc_trans_omp_reduction_list (n, omp_clauses, where);
break;
case OMP_LIST_PRIVATE:
clause_code = OMP_CLAUSE_PRIVATE;
goto add_clause;
@ -1923,7 +2146,7 @@ static void
gfc_split_omp_clauses (gfc_code *code,
gfc_omp_clauses clausesa[GFC_OMP_SPLIT_NUM])
{
int mask = 0, innermost = 0, i;
int mask = 0, innermost = 0;
memset (clausesa, 0, GFC_OMP_SPLIT_NUM * sizeof (gfc_omp_clauses));
switch (code->op)
{
@ -2021,18 +2244,15 @@ gfc_split_omp_clauses (gfc_code *code,
/* Reduction is allowed on simd, do, parallel and teams.
Duplicate it on all of them, but omit on do if
parallel is present. */
for (i = OMP_LIST_REDUCTION_FIRST; i <= OMP_LIST_REDUCTION_LAST; i++)
{
if (mask & GFC_OMP_MASK_PARALLEL)
clausesa[GFC_OMP_SPLIT_PARALLEL].lists[i]
= code->ext.omp_clauses->lists[i];
else if (mask & GFC_OMP_MASK_DO)
clausesa[GFC_OMP_SPLIT_DO].lists[i]
= code->ext.omp_clauses->lists[i];
if (mask & GFC_OMP_MASK_SIMD)
clausesa[GFC_OMP_SPLIT_SIMD].lists[i]
= code->ext.omp_clauses->lists[i];
}
if (mask & GFC_OMP_MASK_PARALLEL)
clausesa[GFC_OMP_SPLIT_PARALLEL].lists[OMP_LIST_REDUCTION]
= code->ext.omp_clauses->lists[OMP_LIST_REDUCTION];
else if (mask & GFC_OMP_MASK_DO)
clausesa[GFC_OMP_SPLIT_DO].lists[OMP_LIST_REDUCTION]
= code->ext.omp_clauses->lists[OMP_LIST_REDUCTION];
if (mask & GFC_OMP_MASK_SIMD)
clausesa[GFC_OMP_SPLIT_SIMD].lists[OMP_LIST_REDUCTION]
= code->ext.omp_clauses->lists[OMP_LIST_REDUCTION];
}
if ((mask & (GFC_OMP_MASK_PARALLEL | GFC_OMP_MASK_DO))
== (GFC_OMP_MASK_PARALLEL | GFC_OMP_MASK_DO))

15
gcc/testsuite/ChangeLog
View file

@ -1,3 +1,18 @@
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

2
gcc/testsuite/gfortran.dg/gomp/allocatable_components_1.f90
View file

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

2
gcc/testsuite/gfortran.dg/gomp/appendix-a/a.31.3.f90
View file

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

68
gcc/testsuite/gfortran.dg/gomp/reduction1.f90
View file

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

8
gcc/testsuite/gfortran.dg/gomp/reduction3.f90
View file

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

41
gcc/testsuite/gfortran.dg/gomp/udr1.f90 Normal file
View file

@ -0,0 +1,41 @@
! { 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

43
gcc/testsuite/gfortran.dg/gomp/udr2.f90 Normal file
View file

@ -0,0 +1,43 @@
! { 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

75
gcc/testsuite/gfortran.dg/gomp/udr3.f90 Normal file
View file

@ -0,0 +1,75 @@
! { 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

64
gcc/testsuite/gfortran.dg/gomp/udr4.f90 Normal file
View file

@ -0,0 +1,64 @@
! { 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

59
gcc/testsuite/gfortran.dg/gomp/udr5.f90 Normal file
View file

@ -0,0 +1,59 @@
! { 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

205
gcc/testsuite/gfortran.dg/gomp/udr6.f90 Normal file
View file

@ -0,0 +1,205 @@
! { 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

90
gcc/testsuite/gfortran.dg/gomp/udr7.f90 Normal file
View file

@ -0,0 +1,90 @@
! { 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

15
libgomp/ChangeLog
View file

@ -1,3 +1,18 @@
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

20
libgomp/testsuite/libgomp.fortran/simd1.f90
View file

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

51
libgomp/testsuite/libgomp.fortran/udr1.f90 Normal file
View file

@ -0,0 +1,51 @@
! { 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

32
libgomp/testsuite/libgomp.fortran/udr10.f90 Normal file
View file

@ -0,0 +1,32 @@
! { 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

95
libgomp/testsuite/libgomp.fortran/udr11.f90 Normal file
View file

@ -0,0 +1,95 @@
! { 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

51
libgomp/testsuite/libgomp.fortran/udr2.f90 Normal file
View file

@ -0,0 +1,51 @@
! { 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

38
libgomp/testsuite/libgomp.fortran/udr3.f90 Normal file
View file

@ -0,0 +1,38 @@
! { 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

39
libgomp/testsuite/libgomp.fortran/udr4.f90 Normal file
View file

@ -0,0 +1,39 @@
! { 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

57
libgomp/testsuite/libgomp.fortran/udr5.f90 Normal file
View file

@ -0,0 +1,57 @@
! { 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

68
libgomp/testsuite/libgomp.fortran/udr6.f90 Normal file
View file

@ -0,0 +1,68 @@
! { 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

48
libgomp/testsuite/libgomp.fortran/udr7.f90 Normal file
View file

@ -0,0 +1,48 @@
! { 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

46
libgomp/testsuite/libgomp.fortran/udr8.f90 Normal file
View file

@ -0,0 +1,46 @@
! { 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

65
libgomp/testsuite/libgomp.fortran/udr9.f90 Normal file
View file

@ -0,0 +1,65 @@
! { 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