This is the mail archive of the
gcc-patches@gcc.gnu.org
mailing list for the GCC project.
Re: [PATCH] Add support for OpenMP fortran user defined reductions
- From: Paul Richard Thomas <paul dot richard dot thomas at gmail dot com>
- To: Jakub Jelinek <jakub at redhat dot com>
- Cc: gcc-patches at gcc dot gnu dot org, fortran at gcc dot gnu dot org
- Date: Mon, 2 Jun 2014 21:11:20 +0200
- Subject: Re: [PATCH] Add support for OpenMP fortran user defined reductions
- Authentication-results: sourceware.org; auth=none
- References: <20140602143544 dot GL10386 at tucnak dot redhat dot com>
Dear Jakub,
First I should say many thanks for this support for gfortran. This is
the one area for which we have professional support and I for one am
truly grateful.
I have scanned through the patch and can see nothing to object to. So
I would say that this is good for trunk, especially at this stage of
the cycle.
Many thanks
Paul
On 2 June 2014 16:35, Jakub Jelinek <jakub@redhat.com> wrote:
> Hi!
>
> This patch adds UDR support to Fortran FE. Tested on x86_64-linux,
> does this look ok?
>
> 2014-06-02 Jakub Jelinek <jakub@redhat.com>
>
> 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.
>
> --- gcc/fortran/dump-parse-tree.c.jj 2014-05-30 20:33:49.394060821 +0200
> +++ gcc/fortran/dump-parse-tree.c 2014-06-02 10:36:19.655285301 +0200
> @@ -1020,6 +1020,28 @@ show_omp_namelist (gfc_omp_namelist *n)
> {
> for (; n; n = n->next)
> {
> + switch (n->rop)
> + {
> + case OMP_REDUCTION_PLUS:
> + case OMP_REDUCTION_TIMES:
> + case OMP_REDUCTION_MINUS:
> + case OMP_REDUCTION_AND:
> + case OMP_REDUCTION_OR:
> + case OMP_REDUCTION_EQV:
> + case OMP_REDUCTION_NEQV:
> + fprintf (dumpfile, "%s:", gfc_op2string ((gfc_intrinsic_op) n->rop));
> + break;
> + case OMP_REDUCTION_MAX: fputs ("max:", dumpfile); break;
> + case OMP_REDUCTION_MIN: fputs ("min:", dumpfile); break;
> + case OMP_REDUCTION_IAND: fputs ("iand:", dumpfile); break;
> + case OMP_REDUCTION_IOR: fputs ("ior:", dumpfile); break;
> + case OMP_REDUCTION_IEOR: fputs ("ieor:", dumpfile); break;
> + case OMP_REDUCTION_USER:
> + if (n->udr)
> + fprintf (dumpfile, "%s:", n->udr->name);
> + break;
> + default: break;
> + }
> fprintf (dumpfile, "%s", n->sym->name);
> if (n->expr)
> {
> @@ -1193,51 +1215,28 @@ show_omp_node (int level, gfc_code *c)
> && list_type != OMP_LIST_COPYPRIVATE)
> {
> const char *type = NULL;
> - if (list_type >= OMP_LIST_REDUCTION_FIRST)
> - {
> - switch (list_type)
> - {
> - case OMP_LIST_PLUS: type = "+"; break;
> - case OMP_LIST_MULT: type = "*"; break;
> - case OMP_LIST_SUB: type = "-"; break;
> - case OMP_LIST_AND: type = ".AND."; break;
> - case OMP_LIST_OR: type = ".OR."; break;
> - case OMP_LIST_EQV: type = ".EQV."; break;
> - case OMP_LIST_NEQV: type = ".NEQV."; break;
> - case OMP_LIST_MAX: type = "MAX"; break;
> - case OMP_LIST_MIN: type = "MIN"; break;
> - case OMP_LIST_IAND: type = "IAND"; break;
> - case OMP_LIST_IOR: type = "IOR"; break;
> - case OMP_LIST_IEOR: type = "IEOR"; break;
> - default:
> - gcc_unreachable ();
> - }
> - fprintf (dumpfile, " REDUCTION(%s:", type);
> - }
> - else
> + switch (list_type)
> {
> - switch (list_type)
> - {
> - case OMP_LIST_PRIVATE: type = "PRIVATE"; break;
> - case OMP_LIST_FIRSTPRIVATE: type = "FIRSTPRIVATE"; break;
> - case OMP_LIST_LASTPRIVATE: type = "LASTPRIVATE"; break;
> - case OMP_LIST_SHARED: type = "SHARED"; break;
> - case OMP_LIST_COPYIN: type = "COPYIN"; break;
> - case OMP_LIST_UNIFORM: type = "UNIFORM"; break;
> - case OMP_LIST_ALIGNED: type = "ALIGNED"; break;
> - case OMP_LIST_LINEAR: type = "LINEAR"; break;
> - case OMP_LIST_DEPEND_IN:
> - fprintf (dumpfile, " DEPEND(IN:");
> - break;
> - case OMP_LIST_DEPEND_OUT:
> - fprintf (dumpfile, " DEPEND(OUT:");
> - break;
> - default:
> - gcc_unreachable ();
> - }
> - if (type)
> - fprintf (dumpfile, " %s(", type);
> + case OMP_LIST_PRIVATE: type = "PRIVATE"; break;
> + case OMP_LIST_FIRSTPRIVATE: type = "FIRSTPRIVATE"; break;
> + case OMP_LIST_LASTPRIVATE: type = "LASTPRIVATE"; break;
> + case OMP_LIST_SHARED: type = "SHARED"; break;
> + case OMP_LIST_COPYIN: type = "COPYIN"; break;
> + case OMP_LIST_UNIFORM: type = "UNIFORM"; break;
> + case OMP_LIST_ALIGNED: type = "ALIGNED"; break;
> + case OMP_LIST_LINEAR: type = "LINEAR"; break;
> + case OMP_LIST_REDUCTION: type = "REDUCTION"; break;
> + case OMP_LIST_DEPEND_IN:
> + fprintf (dumpfile, " DEPEND(IN:");
> + break;
> + case OMP_LIST_DEPEND_OUT:
> + fprintf (dumpfile, " DEPEND(OUT:");
> + break;
> + default:
> + gcc_unreachable ();
> }
> + if (type)
> + fprintf (dumpfile, " %s(", type);
> show_omp_namelist (omp_clauses->lists[list_type]);
> fputc (')', dumpfile);
> }
> --- gcc/fortran/frontend-passes.c.jj 2014-05-30 20:33:49.442060576 +0200
> +++ gcc/fortran/frontend-passes.c 2014-06-02 10:36:19.676285158 +0200
> @@ -676,10 +676,10 @@ dummy_expr_callback (gfc_expr **e ATTRIB
>
> /* Dummy function for code callback, for use when we really
> don't want to do anything. */
> -static int
> -dummy_code_callback (gfc_code **e ATTRIBUTE_UNUSED,
> - int *walk_subtrees ATTRIBUTE_UNUSED,
> - void *data ATTRIBUTE_UNUSED)
> +int
> +gfc_dummy_code_callback (gfc_code **e ATTRIBUTE_UNUSED,
> + int *walk_subtrees ATTRIBUTE_UNUSED,
> + void *data ATTRIBUTE_UNUSED)
> {
> return 0;
> }
> @@ -844,7 +844,8 @@ static void
> optimize_reduction (gfc_namespace *ns)
> {
> current_ns = ns;
> - gfc_code_walker (&ns->code, dummy_code_callback, callback_reduction, NULL);
> + gfc_code_walker (&ns->code, gfc_dummy_code_callback,
> + callback_reduction, NULL);
>
> /* BLOCKs are handled in the expression walker below. */
> for (ns = ns->contained; ns; ns = ns->sibling)
> --- gcc/fortran/gfortran.h.jj 2014-05-30 20:33:49.420060689 +0200
> +++ gcc/fortran/gfortran.h 2014-06-02 10:36:19.695285060 +0200
> @@ -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[
> void gfc_free_omp_clauses (gfc_omp_clauses *);
> void gfc_free_omp_declare_simd (gfc_omp_declare_simd *);
> void gfc_free_omp_declare_simd_list (gfc_omp_declare_simd *);
> +void gfc_free_omp_udr (gfc_omp_udr *);
> +gfc_omp_udr *gfc_omp_udr_find (gfc_symtree *, gfc_typespec *);
> void gfc_resolve_omp_directive (gfc_code *, gfc_namespace *);
> void gfc_resolve_do_iterator (gfc_code *, gfc_symbol *);
> void gfc_resolve_omp_parallel_blocks (gfc_code *, gfc_namespace *);
> void gfc_resolve_omp_do_blocks (gfc_code *, gfc_namespace *);
> void gfc_resolve_omp_declare_simd (gfc_namespace *);
> +void gfc_resolve_omp_udrs (gfc_symtree *);
> void gfc_omp_save_and_clear_state (struct gfc_omp_saved_state *);
> void gfc_omp_restore_state (struct gfc_omp_saved_state *);
>
> @@ -3094,6 +3134,7 @@ void gfc_run_passes (gfc_namespace *);
> typedef int (*walk_code_fn_t) (gfc_code **, int *, void *);
> typedef int (*walk_expr_fn_t) (gfc_expr **, int *, void *);
>
> +int gfc_dummy_code_callback (gfc_code **, int *, void *);
> int gfc_expr_walker (gfc_expr **, walk_expr_fn_t, void *);
> int gfc_code_walker (gfc_code **, walk_code_fn_t, walk_expr_fn_t, void *);
>
> --- gcc/fortran/match.h.jj 2014-05-30 20:33:49.462060474 +0200
> +++ gcc/fortran/match.h 2014-06-02 10:36:19.706285003 +0200
> @@ -129,6 +129,7 @@ match gfc_match_omp_barrier (void);
> match gfc_match_omp_cancel (void);
> match gfc_match_omp_cancellation_point (void);
> match gfc_match_omp_critical (void);
> +match gfc_match_omp_declare_reduction (void);
> match gfc_match_omp_declare_simd (void);
> match gfc_match_omp_do (void);
> match gfc_match_omp_do_simd (void);
> --- gcc/fortran/module.c.jj 2014-05-30 20:33:49.429060643 +0200
> +++ gcc/fortran/module.c 2014-06-02 16:23:21.569941713 +0200
> @@ -82,7 +82,7 @@ along with GCC; see the file COPYING3.
>
> /* 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,
> }
>
>
> +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,
> 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
> @@ -5554,6 +5841,12 @@ write_module (void)
> mio_rparen ();
> 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.
> --- gcc/fortran/openmp.c.jj 2014-05-30 20:33:49.481060376 +0200
> +++ gcc/fortran/openmp.c 2014-06-02 15:33:11.781117656 +0200
> @@ -23,6 +23,7 @@ along with GCC; see the file COPYING3.
> #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_
> }
> }
>
> +/* 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 *
> 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 *
> || 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)))
> + 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)
> {
> - gfc_free_omp_clauses (c);
> - return MATCH_ERROR;
> + 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, loc
> {
> 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, loc
> 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, loc
> 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_namesp
> 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);
> +}
> --- gcc/fortran/parse.c.jj 2014-05-30 20:33:49.472060423 +0200
> +++ gcc/fortran/parse.c 2014-06-02 10:36:19.744284805 +0200
> @@ -575,6 +575,8 @@ decode_omp_directive (void)
> match ("critical", gfc_match_omp_critical, ST_OMP_CRITICAL);
> break;
> case 'd':
> + match ("declare reduction", gfc_match_omp_declare_reduction,
> + ST_OMP_DECLARE_REDUCTION);
> match ("declare simd", gfc_match_omp_declare_simd,
> ST_OMP_DECLARE_SIMD);
> match ("do simd", gfc_match_omp_do_simd, ST_OMP_DO_SIMD);
> @@ -1050,7 +1052,7 @@ next_statement (void)
> #define case_decl case ST_ATTR_DECL: case ST_COMMON: case ST_DATA_DECL: \
> case ST_EQUIVALENCE: case ST_NAMELIST: case ST_STATEMENT_FUNCTION: \
> case ST_TYPE: case ST_INTERFACE: case ST_OMP_THREADPRIVATE: \
> - case ST_PROCEDURE: case ST_OMP_DECLARE_SIMD
> + case ST_PROCEDURE: case ST_OMP_DECLARE_SIMD: case ST_OMP_DECLARE_REDUCTION
>
> /* Block end statements. Errors associated with interchanging these
> are detected in gfc_match_end(). */
> @@ -1550,6 +1552,9 @@ gfc_ascii_statement (gfc_statement st)
> case ST_OMP_CRITICAL:
> p = "!$OMP CRITICAL";
> break;
> + case ST_OMP_DECLARE_REDUCTION:
> + p = "!$OMP DECLARE REDUCTION";
> + break;
> case ST_OMP_DECLARE_SIMD:
> p = "!$OMP DECLARE SIMD";
> break;
> --- gcc/fortran/resolve.c.jj 2014-05-30 20:33:49.458060495 +0200
> +++ gcc/fortran/resolve.c 2014-06-02 10:36:19.764284702 +0200
> @@ -10866,7 +10866,10 @@ resolve_fl_variable (gfc_symbol *sym, in
> }
>
> /* 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, in
> dummy arguments. */
> e = sym->ts.u.cl->length;
> if (e == NULL && !sym->attr.dummy && !sym->attr.result
> - && !sym->ts.deferred && !sym->attr.select_type_temporary)
> + && !sym->ts.deferred && !sym->attr.select_type_temporary
> + && !sym->attr.omp_udr_artificial_var)
> {
> gfc_error ("Entity with assumed character length at %L must be a "
> "dummy argument or a PARAMETER", &sym->declared_at);
> @@ -14696,6 +14700,8 @@ resolve_types (gfc_namespace *ns)
>
> gfc_resolve_omp_declare_simd (ns);
>
> + gfc_resolve_omp_udrs (ns->omp_udr_root);
> +
> gfc_current_ns = old_ns;
> }
>
> --- gcc/fortran/symbol.c.jj 2014-05-30 20:33:49.491060325 +0200
> +++ gcc/fortran/symbol.c 2014-06-02 10:36:19.774284650 +0200
> @@ -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_
> /* 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_t
> }
>
>
> +/* Recursive function that deletes an entire tree and all the common
> + head structures it points to. */
> +
> +static void
> +free_omp_udr_tree (gfc_symtree * omp_udr_tree)
> +{
> + if (omp_udr_tree == NULL)
> + return;
> +
> + free_omp_udr_tree (omp_udr_tree->left);
> + free_omp_udr_tree (omp_udr_tree->right);
> +
> + gfc_free_omp_udr (omp_udr_tree->n.omp_udr);
> + free (omp_udr_tree);
> +}
> +
> +
> /* Recursive function that deletes an entire tree and all the user
> operator nodes that it contains. */
>
> @@ -3465,6 +3491,7 @@ gfc_free_namespace (gfc_namespace *ns)
> free_sym_tree (ns->sym_root);
> free_uop_tree (ns->uop_root);
> free_common_tree (ns->common_root);
> + free_omp_udr_tree (ns->omp_udr_root);
> free_tb_tree (ns->tb_sym_root);
> free_tb_tree (ns->tb_uop_root);
> gfc_free_finalizer_list (ns->finalizers);
> --- gcc/fortran/trans-openmp.c.jj 2014-05-30 20:33:49.416060708 +0200
> +++ gcc/fortran/trans-openmp.c 2014-06-02 10:36:19.786284587 +0200
> @@ -525,12 +525,104 @@ gfc_trans_omp_variable_list (enum omp_cl
> return list;
> }
>
> +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 (tree c, gfc_symbol *sym, locus where)
> +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, g
> 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, g
> 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, g
> 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, g
> 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, g
> 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, g
> 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, g
>
> /* 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, g
> 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, g
> 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_na
> 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 *bloc
>
> 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))
> --- gcc/testsuite/gfortran.dg/gomp/allocatable_components_1.f90.jj 2014-05-30 20:33:49.692059296 +0200
> +++ gcc/testsuite/gfortran.dg/gomp/allocatable_components_1.f90 2014-06-02 10:36:19.823284396 +0200
> @@ -49,7 +49,7 @@ CONTAINS
> TYPE(t) :: a(10)
> INTEGER :: i
>
> - !$omp parallel do reduction(+: a) ! { dg-error "must be of numeric type" }
> + !$omp parallel do reduction(+: a) ! { dg-error "OMP DECLARE REDUCTION\[^\n\r\]*not found for type" }
> DO i = 1, SIZE(a)
> END DO
> !$omp end parallel do
> --- gcc/testsuite/gfortran.dg/gomp/appendix-a/a.31.3.f90.jj 2014-05-30 20:33:49.685059331 +0200
> +++ gcc/testsuite/gfortran.dg/gomp/appendix-a/a.31.3.f90 2014-06-02 10:36:19.827284374 +0200
> @@ -5,7 +5,7 @@
> !$OMP PARALLEL DO REDUCTION(MAX: M) ! MAX is no longer the
> ! intrinsic so this
> ! is non-conforming
> -! { dg-error "is not INTRINSIC procedure name" "" { target *-*-* } 5 } */
> +! { dg-error "OMP DECLARE REDUCTION max not found" "" { target *-*-* } 5 } */
> DO I = 1, 100
> CALL SUB(M,I)
> END DO
> --- gcc/testsuite/gfortran.dg/gomp/reduction1.f90.jj 2014-05-30 20:33:49.692059296 +0200
> +++ gcc/testsuite/gfortran.dg/gomp/reduction1.f90 2014-06-02 10:36:19.827284374 +0200
> @@ -60,73 +60,73 @@ common /blk/ i1
> !$omp end parallel
> !$omp parallel reduction (*:ia1) ! { dg-error "Assumed size" }
> !$omp end parallel
> -!$omp parallel reduction (+:l1) ! { dg-error "must be of numeric type, got LOGICAL" }
> +!$omp parallel reduction (+:l1) ! { dg-error "OMP DECLARE REDUCTION\[^\n\r\]*not found for type" }
> !$omp end parallel
> -!$omp parallel reduction (*:la1) ! { dg-error "must be of numeric type, got LOGICAL" }
> +!$omp parallel reduction (*:la1) ! { dg-error "OMP DECLARE REDUCTION\[^\n\r\]*not found for type" }
> !$omp end parallel
> -!$omp parallel reduction (-:a1) ! { dg-error "must be of numeric type, got CHARACTER" }
> +!$omp parallel reduction (-:a1) ! { dg-error "OMP DECLARE REDUCTION\[^\n\r\]*not found for type" }
> !$omp end parallel
> -!$omp parallel reduction (+:t1) ! { dg-error "must be of numeric type, got TYPE" }
> +!$omp parallel reduction (+:t1) ! { dg-error "OMP DECLARE REDUCTION\[^\n\r\]*not found for type" }
> !$omp end parallel
> -!$omp parallel reduction (*:ta1) ! { dg-error "must be of numeric type, got TYPE" }
> +!$omp parallel reduction (*:ta1) ! { dg-error "OMP DECLARE REDUCTION\[^\n\r\]*not found for type" }
> !$omp end parallel
> -!$omp parallel reduction (.and.:i3) ! { dg-error "must be LOGICAL" }
> +!$omp parallel reduction (.and.:i3) ! { dg-error "OMP DECLARE REDUCTION\[^\n\r\]*not found for type" }
> !$omp end parallel
> -!$omp parallel reduction (.or.:ia2) ! { dg-error "must be LOGICAL" }
> +!$omp parallel reduction (.or.:ia2) ! { dg-error "OMP DECLARE REDUCTION\[^\n\r\]*not found for type" }
> !$omp end parallel
> -!$omp parallel reduction (.eqv.:r1) ! { dg-error "must be LOGICAL" }
> +!$omp parallel reduction (.eqv.:r1) ! { dg-error "OMP DECLARE REDUCTION\[^\n\r\]*not found for type" }
> !$omp end parallel
> -!$omp parallel reduction (.neqv.:ra1) ! { dg-error "must be LOGICAL" }
> +!$omp parallel reduction (.neqv.:ra1) ! { dg-error "OMP DECLARE REDUCTION\[^\n\r\]*not found for type" }
> !$omp end parallel
> -!$omp parallel reduction (.and.:d1) ! { dg-error "must be LOGICAL" }
> +!$omp parallel reduction (.and.:d1) ! { dg-error "OMP DECLARE REDUCTION\[^\n\r\]*not found for type" }
> !$omp end parallel
> -!$omp parallel reduction (.or.:da1) ! { dg-error "must be LOGICAL" }
> +!$omp parallel reduction (.or.:da1) ! { dg-error "OMP DECLARE REDUCTION\[^\n\r\]*not found for type" }
> !$omp end parallel
> -!$omp parallel reduction (.eqv.:c1) ! { dg-error "must be LOGICAL" }
> +!$omp parallel reduction (.eqv.:c1) ! { dg-error "OMP DECLARE REDUCTION\[^\n\r\]*not found for type" }
> !$omp end parallel
> -!$omp parallel reduction (.neqv.:ca1) ! { dg-error "must be LOGICAL" }
> +!$omp parallel reduction (.neqv.:ca1) ! { dg-error "OMP DECLARE REDUCTION\[^\n\r\]*not found for type" }
> !$omp end parallel
> -!$omp parallel reduction (.and.:a1) ! { dg-error "must be LOGICAL" }
> +!$omp parallel reduction (.and.:a1) ! { dg-error "OMP DECLARE REDUCTION\[^\n\r\]*not found for type" }
> !$omp end parallel
> -!$omp parallel reduction (.or.:t1) ! { dg-error "must be LOGICAL" }
> +!$omp parallel reduction (.or.:t1) ! { dg-error "OMP DECLARE REDUCTION\[^\n\r\]*not found for type" }
> !$omp end parallel
> -!$omp parallel reduction (.eqv.:ta1) ! { dg-error "must be LOGICAL" }
> +!$omp parallel reduction (.eqv.:ta1) ! { dg-error "OMP DECLARE REDUCTION\[^\n\r\]*not found for type" }
> !$omp end parallel
> -!$omp parallel reduction (min:c1) ! { dg-error "must be INTEGER or REAL" }
> +!$omp parallel reduction (min:c1) ! { dg-error "OMP DECLARE REDUCTION\[^\n\r\]*not found for type" }
> !$omp end parallel
> -!$omp parallel reduction (max:ca1) ! { dg-error "must be INTEGER or REAL" }
> +!$omp parallel reduction (max:ca1) ! { dg-error "OMP DECLARE REDUCTION\[^\n\r\]*not found for type" }
> !$omp end parallel
> -!$omp parallel reduction (max:l1) ! { dg-error "must be INTEGER or REAL" }
> +!$omp parallel reduction (max:l1) ! { dg-error "OMP DECLARE REDUCTION\[^\n\r\]*not found for type" }
> !$omp end parallel
> -!$omp parallel reduction (min:la1) ! { dg-error "must be INTEGER or REAL" }
> +!$omp parallel reduction (min:la1) ! { dg-error "OMP DECLARE REDUCTION\[^\n\r\]*not found for type" }
> !$omp end parallel
> -!$omp parallel reduction (max:a1) ! { dg-error "must be INTEGER or REAL" }
> +!$omp parallel reduction (max:a1) ! { dg-error "OMP DECLARE REDUCTION\[^\n\r\]*not found for type" }
> !$omp end parallel
> -!$omp parallel reduction (min:t1) ! { dg-error "must be INTEGER or REAL" }
> +!$omp parallel reduction (min:t1) ! { dg-error "OMP DECLARE REDUCTION\[^\n\r\]*not found for type" }
> !$omp end parallel
> -!$omp parallel reduction (max:ta1) ! { dg-error "must be INTEGER or REAL" }
> +!$omp parallel reduction (max:ta1) ! { dg-error "OMP DECLARE REDUCTION\[^\n\r\]*not found for type" }
> !$omp end parallel
> -!$omp parallel reduction (iand:r1) ! { dg-error "must be INTEGER" }
> +!$omp parallel reduction (iand:r1) ! { dg-error "OMP DECLARE REDUCTION\[^\n\r\]*not found for type" }
> !$omp end parallel
> -!$omp parallel reduction (ior:ra1) ! { dg-error "must be INTEGER" }
> +!$omp parallel reduction (ior:ra1) ! { dg-error "OMP DECLARE REDUCTION\[^\n\r\]*not found for type" }
> !$omp end parallel
> -!$omp parallel reduction (ieor:d1) ! { dg-error "must be INTEGER" }
> +!$omp parallel reduction (ieor:d1) ! { dg-error "OMP DECLARE REDUCTION\[^\n\r\]*not found for type" }
> !$omp end parallel
> -!$omp parallel reduction (ior:da1) ! { dg-error "must be INTEGER" }
> +!$omp parallel reduction (ior:da1) ! { dg-error "OMP DECLARE REDUCTION\[^\n\r\]*not found for type" }
> !$omp end parallel
> -!$omp parallel reduction (iand:c1) ! { dg-error "must be INTEGER" }
> +!$omp parallel reduction (iand:c1) ! { dg-error "OMP DECLARE REDUCTION\[^\n\r\]*not found for type" }
> !$omp end parallel
> -!$omp parallel reduction (ior:ca1) ! { dg-error "must be INTEGER" }
> +!$omp parallel reduction (ior:ca1) ! { dg-error "OMP DECLARE REDUCTION\[^\n\r\]*not found for type" }
> !$omp end parallel
> -!$omp parallel reduction (ieor:l1) ! { dg-error "must be INTEGER" }
> +!$omp parallel reduction (ieor:l1) ! { dg-error "OMP DECLARE REDUCTION\[^\n\r\]*not found for type" }
> !$omp end parallel
> -!$omp parallel reduction (iand:la1) ! { dg-error "must be INTEGER" }
> +!$omp parallel reduction (iand:la1) ! { dg-error "OMP DECLARE REDUCTION\[^\n\r\]*not found for type" }
> !$omp end parallel
> -!$omp parallel reduction (ior:a1) ! { dg-error "must be INTEGER" }
> +!$omp parallel reduction (ior:a1) ! { dg-error "OMP DECLARE REDUCTION\[^\n\r\]*not found for type" }
> !$omp end parallel
> -!$omp parallel reduction (ieor:t1) ! { dg-error "must be INTEGER" }
> +!$omp parallel reduction (ieor:t1) ! { dg-error "OMP DECLARE REDUCTION\[^\n\r\]*not found for type" }
> !$omp end parallel
> -!$omp parallel reduction (iand:ta1) ! { dg-error "must be INTEGER" }
> +!$omp parallel reduction (iand:ta1) ! { dg-error "OMP DECLARE REDUCTION\[^\n\r\]*not found for type" }
> !$omp end parallel
>
> end subroutine
> --- gcc/testsuite/gfortran.dg/gomp/reduction3.f90.jj 2014-05-30 20:33:49.692059296 +0200
> +++ gcc/testsuite/gfortran.dg/gomp/reduction3.f90 2014-06-02 10:36:19.828284369 +0200
> @@ -16,7 +16,7 @@ subroutine f1
> integer :: i, ior
> ior = 6
> i = 6
> -!$omp parallel reduction (ior:i) ! { dg-error "is not INTRINSIC procedure name" }
> +!$omp parallel reduction (ior:i) ! { dg-error "OMP DECLARE REDUCTION\[^\n\r\]*not found" }
> !$omp end parallel
> end subroutine f1
> subroutine f2
> @@ -27,7 +27,7 @@ subroutine f2
> end function
> end interface
> i = 6
> -!$omp parallel reduction (ior:i) ! { dg-error "is not INTRINSIC procedure name" }
> +!$omp parallel reduction (ior:i) ! { dg-error "OMP DECLARE REDUCTION\[^\n\r\]*not found" }
> i = ior (i, 3)
> !$omp end parallel
> end subroutine f2
> @@ -50,7 +50,7 @@ subroutine f5
> use mreduction3
> integer :: i
> i = 6
> -!$omp parallel reduction (ior:i) ! { dg-error "is not INTRINSIC procedure name" }
> +!$omp parallel reduction (ior:i) ! { dg-error "OMP DECLARE REDUCTION\[^\n\r\]*not found" }
> i = ior (i, 7)
> !$omp end parallel
> end subroutine f5
> @@ -58,7 +58,7 @@ subroutine f6
> use mreduction3
> integer :: i
> i = 6
> -!$omp parallel reduction (iand:i) ! { dg-error "is not INTRINSIC procedure name" }
> +!$omp parallel reduction (iand:i) ! { dg-error "OMP DECLARE REDUCTION\[^\n\r\]*not found" }
> i = iand (i, 18)
> !$omp end parallel
> end subroutine f6
> --- gcc/testsuite/gfortran.dg/gomp/udr1.f90.jj 2014-06-02 10:36:19.828284369 +0200
> +++ gcc/testsuite/gfortran.dg/gomp/udr1.f90 2014-06-02 10:36:19.828284369 +0200
> @@ -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
> --- gcc/testsuite/gfortran.dg/gomp/udr2.f90.jj 2014-06-02 10:36:19.828284369 +0200
> +++ gcc/testsuite/gfortran.dg/gomp/udr2.f90 2014-06-02 10:36:19.828284369 +0200
> @@ -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
> --- gcc/testsuite/gfortran.dg/gomp/udr3.f90.jj 2014-06-02 10:36:19.829284364 +0200
> +++ gcc/testsuite/gfortran.dg/gomp/udr3.f90 2014-06-02 14:37:59.818184325 +0200
> @@ -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
> --- gcc/testsuite/gfortran.dg/gomp/udr4.f90.jj 2014-06-02 10:36:19.829284364 +0200
> +++ gcc/testsuite/gfortran.dg/gomp/udr4.f90 2014-06-02 10:36:19.829284364 +0200
> @@ -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
> --- gcc/testsuite/gfortran.dg/gomp/udr5.f90.jj 2014-06-02 10:36:19.829284364 +0200
> +++ gcc/testsuite/gfortran.dg/gomp/udr5.f90 2014-06-02 10:36:19.829284364 +0200
> @@ -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
> --- gcc/testsuite/gfortran.dg/gomp/udr6.f90.jj 2014-06-02 10:49:02.674337338 +0200
> +++ gcc/testsuite/gfortran.dg/gomp/udr6.f90 2014-06-02 15:40:52.664740529 +0200
> @@ -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
> --- gcc/testsuite/gfortran.dg/gomp/udr7.f90.jj 2014-06-02 16:16:00.341213345 +0200
> +++ gcc/testsuite/gfortran.dg/gomp/udr7.f90 2014-06-02 16:23:52.389793001 +0200
> @@ -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
> --- libgomp/testsuite/libgomp.fortran/simd1.f90.jj 2014-05-30 20:33:46.020078093 +0200
> +++ libgomp/testsuite/libgomp.fortran/simd1.f90 2014-06-02 10:36:19.866284172 +0200
> @@ -2,22 +2,34 @@
> ! { dg-additional-options "-msse2" { target sse2_runtime } }
> ! { dg-additional-options "-mavx" { target avx_runtime } }
>
> - integer :: i, j, k, l, r, a(30)
> + type dt
> + integer :: x = 0
> + end type
> + type (dt) :: t
> + integer :: i, j, k, l, r, s, a(30)
> integer, target :: q(30)
> integer, pointer :: p(:)
> + !$omp declare reduction (foo : integer : &
> + !$omp & omp_out = omp_out + omp_in) initializer (omp_priv = 0)
> + !$omp declare reduction (+ : dt : omp_out%x = omp_out%x &
> + !$omp & + omp_in%x)
> a(:) = 1
> q(:) = 1
> p => q
> r = 0
> j = 10
> k = 20
> - !$omp simd safelen (8) reduction(+:r) linear(j, k : 2) &
> - !$omp& private (l) aligned(p : 4)
> + s = 0
> + !$omp simd safelen (8) reduction(+:r, t) linear(j, k : 2) &
> + !$omp& private (l) aligned(p : 4) reduction(foo:s)
> do i = 1, 30
> l = j + k + a(i) + p(i)
> r = r + l
> j = j + 2
> k = k + 2
> + s = s + l
> + t%x = t%x + l
> end do
> - if (r.ne.2700.or.j.ne.70.or.k.ne.80) call abort
> + if (r.ne.2700.or.j.ne.70.or.k.ne.80.or.s.ne.2700) call abort
> + if (t%x.ne.2700) call abort
> end
> --- libgomp/testsuite/libgomp.fortran/udr1.f90.jj 2014-06-02 10:36:19.867284167 +0200
> +++ libgomp/testsuite/libgomp.fortran/udr1.f90 2014-06-02 15:05:47.708571138 +0200
> @@ -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
> --- libgomp/testsuite/libgomp.fortran/udr2.f90.jj 2014-06-02 10:36:19.867284167 +0200
> +++ libgomp/testsuite/libgomp.fortran/udr2.f90 2014-06-02 15:06:43.745275544 +0200
> @@ -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
> --- libgomp/testsuite/libgomp.fortran/udr3.f90.jj 2014-06-02 10:36:19.867284167 +0200
> +++ libgomp/testsuite/libgomp.fortran/udr3.f90 2014-06-02 10:36:19.867284167 +0200
> @@ -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
> --- libgomp/testsuite/libgomp.fortran/udr4.f90.jj 2014-06-02 10:36:19.867284167 +0200
> +++ libgomp/testsuite/libgomp.fortran/udr4.f90 2014-06-02 10:36:19.867284167 +0200
> @@ -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
> --- libgomp/testsuite/libgomp.fortran/udr5.f90.jj 2014-06-02 10:36:19.867284167 +0200
> +++ libgomp/testsuite/libgomp.fortran/udr5.f90 2014-06-02 10:36:19.867284167 +0200
> @@ -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
> --- libgomp/testsuite/libgomp.fortran/udr6.f90.jj 2014-06-02 10:36:19.868284162 +0200
> +++ libgomp/testsuite/libgomp.fortran/udr6.f90 2014-06-02 10:36:19.868284162 +0200
> @@ -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
> --- libgomp/testsuite/libgomp.fortran/udr7.f90.jj 2014-06-02 10:36:19.868284162 +0200
> +++ libgomp/testsuite/libgomp.fortran/udr7.f90 2014-06-02 10:36:19.868284162 +0200
> @@ -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
> --- libgomp/testsuite/libgomp.fortran/udr8.f90.jj 2014-06-02 10:36:19.868284162 +0200
> +++ libgomp/testsuite/libgomp.fortran/udr8.f90 2014-06-02 10:36:19.868284162 +0200
> @@ -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
> --- libgomp/testsuite/libgomp.fortran/udr9.f90.jj 2014-06-02 10:36:19.868284162 +0200
> +++ libgomp/testsuite/libgomp.fortran/udr9.f90 2014-06-02 10:36:19.868284162 +0200
> @@ -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
> --- libgomp/testsuite/libgomp.fortran/udr10.f90.jj 2014-06-02 10:36:19.868284162 +0200
> +++ libgomp/testsuite/libgomp.fortran/udr10.f90 2014-06-02 10:36:19.868284162 +0200
> @@ -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
> --- libgomp/testsuite/libgomp.fortran/udr11.f90.jj 2014-06-02 14:51:41.765932756 +0200
> +++ libgomp/testsuite/libgomp.fortran/udr11.f90 2014-06-02 15:24:16.077880056 +0200
> @@ -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
>
> Jakub
--
The knack of flying is learning how to throw yourself at the ground and miss.
--Hitchhikers Guide to the Galaxy