match gfc_match_interface (void) { char name[GFC_MAX_SYMBOL_LEN + 1]; interface_type type; gfc_symbol *sym; gfc_intrinsic_op operator; match m; m = gfc_match_space (); if (gfc_match_generic_spec (&type, name, &operator) == MATCH_ERROR) return MATCH_ERROR; /* If we're not looking at the end of the statement now, or if this is not a nameless interface but we did not see a space, punt. */ if (gfc_match_eos () != MATCH_YES || (type != INTERFACE_NAMELESS && m != MATCH_YES)) { gfc_error ("Syntax error: Trailing garbage in INTERFACE statement at %C"); return MATCH_ERROR; } current_interface.type = type; switch (type) { case INTERFACE_GENERIC: if (gfc_get_symbol (name, NULL, &sym)) return MATCH_ERROR; if (!sym->attr.generic && gfc_add_generic (&sym->attr, sym->name, NULL) == FAILURE) return MATCH_ERROR; current_interface.sym = gfc_new_block = sym; break; case INTERFACE_USER_OP: current_interface.uop = gfc_get_uop (name); break; case INTERFACE_INTRINSIC_OP: current_interface.op = operator; break; case INTERFACE_NAMELESS: break; } return MATCH_YES; }
match gfc_match_end_interface (void) { char name[GFC_MAX_SYMBOL_LEN + 1]; interface_type type; gfc_intrinsic_op operator; match m; m = gfc_match_space (); if (gfc_match_generic_spec (&type, name, &operator) == MATCH_ERROR) return MATCH_ERROR; /* If we're not looking at the end of the statement now, or if this is not a nameless interface but we did not see a space, punt. */ if (gfc_match_eos () != MATCH_YES || (type != INTERFACE_NAMELESS && m != MATCH_YES)) { gfc_error ("Syntax error: Trailing garbage in END INTERFACE statement at %C"); return MATCH_ERROR; } m = MATCH_YES; switch (current_interface.type) { case INTERFACE_NAMELESS: if (type != current_interface.type) { gfc_error ("Expected a nameless interface at %C"); m = MATCH_ERROR; } break; case INTERFACE_INTRINSIC_OP: if (type != current_interface.type || operator != current_interface.op) { if (current_interface.op == INTRINSIC_ASSIGN) gfc_error ("Expected 'END INTERFACE ASSIGNMENT (=)' at %C"); else gfc_error ("Expecting 'END INTERFACE OPERATOR (%s)' at %C", gfc_op2string (current_interface.op)); m = MATCH_ERROR; } break; case INTERFACE_USER_OP: /* Comparing the symbol node names is OK because only use-associated symbols can be renamed. */ if (type != current_interface.type || strcmp (current_interface.sym->name, name) != 0) { gfc_error ("Expecting 'END INTERFACE OPERATOR (.%s.)' at %C", current_interface.sym->name); m = MATCH_ERROR; } break; case INTERFACE_GENERIC: if (type != current_interface.type || strcmp (current_interface.sym->name, name) != 0) { gfc_error ("Expecting 'END INTERFACE %s' at %C", current_interface.sym->name); m = MATCH_ERROR; } break; } return m; }
static match gfc_match_omp_clauses (gfc_omp_clauses **cp, int mask) { gfc_omp_clauses *c = gfc_get_omp_clauses (); locus old_loc; bool needs_space = true, first = true; *cp = NULL; while (1) { if ((first || gfc_match_char (',') != MATCH_YES) && (needs_space && gfc_match_space () != MATCH_YES)) break; needs_space = false; first = false; gfc_gobble_whitespace (); if ((mask & OMP_CLAUSE_IF) && c->if_expr == NULL && gfc_match ("if ( %e )", &c->if_expr) == MATCH_YES) continue; if ((mask & OMP_CLAUSE_NUM_THREADS) && c->num_threads == NULL && gfc_match ("num_threads ( %e )", &c->num_threads) == MATCH_YES) continue; if ((mask & OMP_CLAUSE_PRIVATE) && gfc_match_omp_variable_list ("private (", &c->lists[OMP_LIST_PRIVATE], true) == MATCH_YES) continue; if ((mask & OMP_CLAUSE_FIRSTPRIVATE) && gfc_match_omp_variable_list ("firstprivate (", &c->lists[OMP_LIST_FIRSTPRIVATE], true) == MATCH_YES) continue; if ((mask & OMP_CLAUSE_LASTPRIVATE) && gfc_match_omp_variable_list ("lastprivate (", &c->lists[OMP_LIST_LASTPRIVATE], true) == MATCH_YES) continue; if ((mask & OMP_CLAUSE_COPYPRIVATE) && gfc_match_omp_variable_list ("copyprivate (", &c->lists[OMP_LIST_COPYPRIVATE], true) == MATCH_YES) continue; if ((mask & OMP_CLAUSE_SHARED) && gfc_match_omp_variable_list ("shared (", &c->lists[OMP_LIST_SHARED], true) == MATCH_YES) continue; if ((mask & OMP_CLAUSE_COPYIN) && gfc_match_omp_variable_list ("copyin (", &c->lists[OMP_LIST_COPYIN], true) == MATCH_YES) continue; old_loc = gfc_current_locus; if ((mask & OMP_CLAUSE_REDUCTION) && gfc_match ("reduction ( ") == MATCH_YES) { int reduction = OMP_LIST_NUM; char buffer[GFC_MAX_SYMBOL_LEN + 1]; if (gfc_match_char ('+') == MATCH_YES) reduction = OMP_LIST_PLUS; else if (gfc_match_char ('*') == MATCH_YES) reduction = OMP_LIST_MULT; else if (gfc_match_char ('-') == MATCH_YES) reduction = OMP_LIST_SUB; else if (gfc_match (".and.") == MATCH_YES) reduction = OMP_LIST_AND; else if (gfc_match (".or.") == MATCH_YES) reduction = OMP_LIST_OR; else if (gfc_match (".eqv.") == MATCH_YES) reduction = OMP_LIST_EQV; else if (gfc_match (".neqv.") == MATCH_YES) reduction = OMP_LIST_NEQV; 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) { gfc_error_now ("%s is not INTRINSIC procedure name " "at %C", buffer); sym = NULL; } else n = sym->name; } if (strcmp (n, "max") == 0) reduction = OMP_LIST_MAX; else if (strcmp (n, "min") == 0) reduction = OMP_LIST_MIN; else if (strcmp (n, "iand") == 0) reduction = OMP_LIST_IAND; else if (strcmp (n, "ior") == 0) reduction = OMP_LIST_IOR; else if (strcmp (n, "ieor") == 0) reduction = OMP_LIST_IEOR; if (reduction != OMP_LIST_NUM && sym != NULL && ! sym->attr.intrinsic && ! sym->attr.use_assoc && ((sym->attr.flavor == FL_UNKNOWN && gfc_add_flavor (&sym->attr, FL_PROCEDURE, sym->name, NULL) == FAILURE) || gfc_add_intrinsic (&sym->attr, NULL) == FAILURE)) { gfc_free_omp_clauses (c); return MATCH_ERROR; } } if (reduction != OMP_LIST_NUM && gfc_match_omp_variable_list (" :", &c->lists[reduction], false) == MATCH_YES) continue; else gfc_current_locus = old_loc; } if ((mask & OMP_CLAUSE_DEFAULT) && c->default_sharing == OMP_DEFAULT_UNKNOWN) { if (gfc_match ("default ( shared )") == MATCH_YES) c->default_sharing = OMP_DEFAULT_SHARED; else if (gfc_match ("default ( private )") == MATCH_YES) c->default_sharing = OMP_DEFAULT_PRIVATE; else if (gfc_match ("default ( none )") == MATCH_YES) c->default_sharing = OMP_DEFAULT_NONE; else if (gfc_match ("default ( firstprivate )") == MATCH_YES) c->default_sharing = OMP_DEFAULT_FIRSTPRIVATE; if (c->default_sharing != OMP_DEFAULT_UNKNOWN) continue; } old_loc = gfc_current_locus; if ((mask & OMP_CLAUSE_SCHEDULE) && c->sched_kind == OMP_SCHED_NONE && gfc_match ("schedule ( ") == MATCH_YES) { if (gfc_match ("static") == MATCH_YES) c->sched_kind = OMP_SCHED_STATIC; else if (gfc_match ("dynamic") == MATCH_YES) c->sched_kind = OMP_SCHED_DYNAMIC; else if (gfc_match ("guided") == MATCH_YES) c->sched_kind = OMP_SCHED_GUIDED; else if (gfc_match ("runtime") == MATCH_YES) c->sched_kind = OMP_SCHED_RUNTIME; else if (gfc_match ("auto") == MATCH_YES) c->sched_kind = OMP_SCHED_AUTO; if (c->sched_kind != OMP_SCHED_NONE) { match m = MATCH_NO; if (c->sched_kind != OMP_SCHED_RUNTIME && c->sched_kind != OMP_SCHED_AUTO) m = gfc_match (" , %e )", &c->chunk_size); if (m != MATCH_YES) m = gfc_match_char (')'); if (m != MATCH_YES) c->sched_kind = OMP_SCHED_NONE; } if (c->sched_kind != OMP_SCHED_NONE) continue; else gfc_current_locus = old_loc; } if ((mask & OMP_CLAUSE_ORDERED) && !c->ordered && gfc_match ("ordered") == MATCH_YES) { c->ordered = needs_space = true; continue; } if ((mask & OMP_CLAUSE_UNTIED) && !c->untied && gfc_match ("untied") == MATCH_YES) { c->untied = needs_space = true; continue; } if ((mask & OMP_CLAUSE_COLLAPSE) && !c->collapse) { gfc_expr *cexpr = NULL; match m = gfc_match ("collapse ( %e )", &cexpr); if (m == MATCH_YES) { int collapse; const char *p = gfc_extract_int (cexpr, &collapse); if (p) { gfc_error_now (p); collapse = 1; } else if (collapse <= 0) { gfc_error_now ("COLLAPSE clause argument not" " constant positive integer at %C"); collapse = 1; } c->collapse = collapse; gfc_free_expr (cexpr); continue; } } break; } if (gfc_match_omp_eos () != MATCH_YES) { gfc_free_omp_clauses (c); return MATCH_ERROR; } *cp = c; return MATCH_YES; }