+/* reduction ( reduction-modifier, reduction-operator : variable-list )
+ in_reduction ( reduction-operator : variable-list )
+ task_reduction ( reduction-operator : variable-list ) */
+
+static match
+gfc_match_omp_clause_reduction (char pc, gfc_omp_clauses *c, bool openacc,
+ bool allow_derived)
+{
+ if (pc == 'r' && gfc_match ("reduction ( ") != MATCH_YES)
+ return MATCH_NO;
+ else if (pc == 'i' && gfc_match ("in_reduction ( ") != MATCH_YES)
+ return MATCH_NO;
+ else if (pc == 't' && gfc_match ("task_reduction ( ") != MATCH_YES)
+ return MATCH_NO;
+
+ locus old_loc = gfc_current_locus;
+ int list_idx = 0;
+
+ if (pc == 'r' && !openacc)
+ {
+ if (gfc_match ("inscan") == MATCH_YES)
+ list_idx = OMP_LIST_REDUCTION_INSCAN;
+ else if (gfc_match ("task") == MATCH_YES)
+ list_idx = OMP_LIST_REDUCTION_TASK;
+ else if (gfc_match ("default") == MATCH_YES)
+ list_idx = OMP_LIST_REDUCTION;
+ if (list_idx != 0 && gfc_match (", ") != MATCH_YES)
+ {
+ gfc_error ("Comma expected at %C");
+ gfc_current_locus = old_loc;
+ return MATCH_NO;
+ }
+ if (list_idx == 0)
+ list_idx = OMP_LIST_REDUCTION;
+ }
+ else if (pc == 'i')
+ list_idx = OMP_LIST_IN_REDUCTION;
+ else if (pc == 't')
+ list_idx = OMP_LIST_TASK_REDUCTION;
+ else
+ list_idx = OMP_LIST_REDUCTION;
+
+ gfc_omp_reduction_op rop = OMP_REDUCTION_NONE;
+ char buffer[GFC_MAX_SYMBOL_LEN + 3];
+ if (gfc_match_char ('+') == MATCH_YES)
+ rop = OMP_REDUCTION_PLUS;
+ else if (gfc_match_char ('*') == MATCH_YES)
+ rop = OMP_REDUCTION_TIMES;
+ else if (gfc_match_char ('-') == MATCH_YES)
+ rop = OMP_REDUCTION_MINUS;
+ else if (gfc_match (".and.") == MATCH_YES)
+ rop = OMP_REDUCTION_AND;
+ else if (gfc_match (".or.") == MATCH_YES)
+ rop = OMP_REDUCTION_OR;
+ else if (gfc_match (".eqv.") == MATCH_YES)
+ rop = OMP_REDUCTION_EQV;
+ else if (gfc_match (".neqv.") == MATCH_YES)
+ 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;
+ const char *n = buffer;
+
+ gfc_find_symbol (buffer, 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)
+ {
+ sym = NULL;
+ n = NULL;
+ }
+ else
+ n = sym->name;
+ }
+ if (n == NULL)
+ rop = OMP_REDUCTION_NONE;
+ else if (strcmp (n, "max") == 0)
+ rop = OMP_REDUCTION_MAX;
+ else if (strcmp (n, "min") == 0)
+ rop = OMP_REDUCTION_MIN;
+ else if (strcmp (n, "iand") == 0)
+ rop = OMP_REDUCTION_IAND;
+ else if (strcmp (n, "ior") == 0)
+ rop = OMP_REDUCTION_IOR;
+ else if (strcmp (n, "ieor") == 0)
+ 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_intrinsic (&sym->attr, NULL)))
+ rop = OMP_REDUCTION_NONE;
+ }
+ else
+ buffer[0] = '\0';
+ gfc_omp_udr *udr = (buffer[0] ? gfc_find_omp_udr (gfc_current_ns, buffer, NULL)
+ : NULL);
+ gfc_omp_namelist **head = NULL;
+ if (rop == OMP_REDUCTION_NONE && udr)
+ rop = OMP_REDUCTION_USER;
+
+ if (gfc_match_omp_variable_list (" :", &c->lists[list_idx], false, NULL,
+ &head, openacc, allow_derived) != MATCH_YES)
+ {
+ gfc_current_locus = old_loc;
+ return MATCH_NO;
+ }
+ gfc_omp_namelist *n;
+ if (rop == OMP_REDUCTION_NONE)
+ {
+ n = *head;
+ *head = NULL;
+ gfc_error_now ("!$OMP DECLARE REDUCTION %s not found at %L",
+ buffer, &old_loc);
+ gfc_free_omp_namelist (n);
+ }
+ else
+ for (n = *head; n; n = n->next)
+ {
+ n->u.reduction_op = rop;
+ if (udr)
+ {
+ n->udr = gfc_get_omp_namelist_udr ();
+ n->udr->udr = udr;
+ }
+ }
+ return MATCH_YES;
+}
+