LCOV - code coverage report
Current view: top level - gcc/fortran - openmp.cc (source / functions) Coverage Total Hit
Test: gcc.info Lines: 93.1 % 7231 6732
Test Date: 2025-04-19 15:48:17 Functions: 97.7 % 217 212
Legend: Lines: hit not hit | Branches: + taken - not taken # not executed Branches: - 0 0

             Branch data     Line data    Source code
       1                 :             : /* OpenMP directive matching and resolving.
       2                 :             :    Copyright (C) 2005-2025 Free Software Foundation, Inc.
       3                 :             :    Contributed by Jakub Jelinek
       4                 :             : 
       5                 :             : This file is part of GCC.
       6                 :             : 
       7                 :             : GCC is free software; you can redistribute it and/or modify it under
       8                 :             : the terms of the GNU General Public License as published by the Free
       9                 :             : Software Foundation; either version 3, or (at your option) any later
      10                 :             : version.
      11                 :             : 
      12                 :             : GCC is distributed in the hope that it will be useful, but WITHOUT ANY
      13                 :             : WARRANTY; without even the implied warranty of MERCHANTABILITY or
      14                 :             : FITNESS FOR A PARTICULAR PURPOSE.  See the GNU General Public License
      15                 :             : for more details.
      16                 :             : 
      17                 :             : You should have received a copy of the GNU General Public License
      18                 :             : along with GCC; see the file COPYING3.  If not see
      19                 :             : <http://www.gnu.org/licenses/>.  */
      20                 :             : 
      21                 :             : #define INCLUDE_VECTOR
      22                 :             : #define INCLUDE_STRING
      23                 :             : #include "config.h"
      24                 :             : #include "system.h"
      25                 :             : #include "coretypes.h"
      26                 :             : #include "options.h"
      27                 :             : #include "gfortran.h"
      28                 :             : #include "arith.h"
      29                 :             : #include "match.h"
      30                 :             : #include "parse.h"
      31                 :             : #include "constructor.h"
      32                 :             : #include "diagnostic.h"
      33                 :             : #include "gomp-constants.h"
      34                 :             : #include "target-memory.h"  /* For gfc_encode_character.  */
      35                 :             : #include "bitmap.h"
      36                 :             : #include "omp-api.h"  /* For omp_runtime_api_procname.  */
      37                 :             : 
      38                 :             : location_t gfc_get_location (locus *);
      39                 :             : 
      40                 :             : static gfc_statement omp_code_to_statement (gfc_code *);
      41                 :             : 
      42                 :             : enum gfc_omp_directive_kind {
      43                 :             :   GFC_OMP_DIR_DECLARATIVE,
      44                 :             :   GFC_OMP_DIR_EXECUTABLE,
      45                 :             :   GFC_OMP_DIR_INFORMATIONAL,
      46                 :             :   GFC_OMP_DIR_META,
      47                 :             :   GFC_OMP_DIR_SUBSIDIARY,
      48                 :             :   GFC_OMP_DIR_UTILITY
      49                 :             : };
      50                 :             : 
      51                 :             : struct gfc_omp_directive {
      52                 :             :   const char *name;
      53                 :             :   enum gfc_omp_directive_kind kind;
      54                 :             :   gfc_statement st;
      55                 :             : };
      56                 :             : 
      57                 :             : /* Alphabetically sorted OpenMP clauses, except that longer strings are before
      58                 :             :    substrings; excludes combined/composite directives. See note for "ordered"
      59                 :             :    and "nothing".  */
      60                 :             : 
      61                 :             : static const struct gfc_omp_directive gfc_omp_directives[] = {
      62                 :             :   {"allocate", GFC_OMP_DIR_DECLARATIVE, ST_OMP_ALLOCATE},
      63                 :             :   {"allocators", GFC_OMP_DIR_EXECUTABLE, ST_OMP_ALLOCATORS},
      64                 :             :   {"assumes", GFC_OMP_DIR_INFORMATIONAL, ST_OMP_ASSUMES},
      65                 :             :   {"assume", GFC_OMP_DIR_INFORMATIONAL, ST_OMP_ASSUME},
      66                 :             :   {"atomic", GFC_OMP_DIR_EXECUTABLE, ST_OMP_ATOMIC},
      67                 :             :   {"barrier", GFC_OMP_DIR_EXECUTABLE, ST_OMP_BARRIER},
      68                 :             :   {"cancellation point", GFC_OMP_DIR_EXECUTABLE, ST_OMP_CANCELLATION_POINT},
      69                 :             :   {"cancel", GFC_OMP_DIR_EXECUTABLE, ST_OMP_CANCEL},
      70                 :             :   {"critical", GFC_OMP_DIR_EXECUTABLE, ST_OMP_CRITICAL},
      71                 :             :   /* {"declare mapper", GFC_OMP_DIR_DECLARATIVE, ST_OMP_DECLARE_MAPPER}, */
      72                 :             :   {"declare reduction", GFC_OMP_DIR_DECLARATIVE, ST_OMP_DECLARE_REDUCTION},
      73                 :             :   {"declare simd", GFC_OMP_DIR_DECLARATIVE, ST_OMP_DECLARE_SIMD},
      74                 :             :   {"declare target", GFC_OMP_DIR_DECLARATIVE, ST_OMP_DECLARE_TARGET},
      75                 :             :   {"declare variant", GFC_OMP_DIR_DECLARATIVE, ST_OMP_DECLARE_VARIANT},
      76                 :             :   {"depobj", GFC_OMP_DIR_EXECUTABLE, ST_OMP_DEPOBJ},
      77                 :             :   {"dispatch", GFC_OMP_DIR_EXECUTABLE, ST_OMP_DISPATCH},
      78                 :             :   {"distribute", GFC_OMP_DIR_EXECUTABLE, ST_OMP_DISTRIBUTE},
      79                 :             :   {"do", GFC_OMP_DIR_EXECUTABLE, ST_OMP_DO},
      80                 :             :   /* "error" becomes GFC_OMP_DIR_EXECUTABLE with at(execution) */
      81                 :             :   {"error", GFC_OMP_DIR_UTILITY, ST_OMP_ERROR},
      82                 :             :   {"flush", GFC_OMP_DIR_EXECUTABLE, ST_OMP_FLUSH},
      83                 :             :   {"interop", GFC_OMP_DIR_EXECUTABLE, ST_OMP_INTEROP},
      84                 :             :   {"loop", GFC_OMP_DIR_EXECUTABLE, ST_OMP_LOOP},
      85                 :             :   {"masked", GFC_OMP_DIR_EXECUTABLE, ST_OMP_MASKED},
      86                 :             :   {"metadirective", GFC_OMP_DIR_META, ST_OMP_METADIRECTIVE},
      87                 :             :   /* Note: gfc_match_omp_nothing returns ST_NONE.  */
      88                 :             :   {"nothing", GFC_OMP_DIR_UTILITY, ST_OMP_NOTHING},
      89                 :             :   /* Special case; for now map to the first one.
      90                 :             :      ordered-blockassoc = ST_OMP_ORDERED
      91                 :             :      ordered-standalone = ST_OMP_ORDERED_DEPEND + depend/doacross.  */
      92                 :             :   {"ordered", GFC_OMP_DIR_EXECUTABLE, ST_OMP_ORDERED},
      93                 :             :   {"parallel", GFC_OMP_DIR_EXECUTABLE, ST_OMP_PARALLEL},
      94                 :             :   {"requires", GFC_OMP_DIR_INFORMATIONAL, ST_OMP_REQUIRES},
      95                 :             :   {"scan", GFC_OMP_DIR_SUBSIDIARY, ST_OMP_SCAN},
      96                 :             :   {"scope", GFC_OMP_DIR_EXECUTABLE, ST_OMP_SCOPE},
      97                 :             :   {"sections", GFC_OMP_DIR_EXECUTABLE, ST_OMP_SECTIONS},
      98                 :             :   {"section", GFC_OMP_DIR_SUBSIDIARY, ST_OMP_SECTION},
      99                 :             :   {"simd", GFC_OMP_DIR_EXECUTABLE, ST_OMP_SIMD},
     100                 :             :   {"single", GFC_OMP_DIR_EXECUTABLE, ST_OMP_SINGLE},
     101                 :             :   {"target data", GFC_OMP_DIR_EXECUTABLE, ST_OMP_TARGET_DATA},
     102                 :             :   {"target enter data", GFC_OMP_DIR_EXECUTABLE, ST_OMP_TARGET_ENTER_DATA},
     103                 :             :   {"target exit data", GFC_OMP_DIR_EXECUTABLE, ST_OMP_TARGET_EXIT_DATA},
     104                 :             :   {"target update", GFC_OMP_DIR_EXECUTABLE, ST_OMP_TARGET_UPDATE},
     105                 :             :   {"target", GFC_OMP_DIR_EXECUTABLE, ST_OMP_TARGET},
     106                 :             :   {"taskloop", GFC_OMP_DIR_EXECUTABLE, ST_OMP_TASKLOOP},
     107                 :             :   {"taskwait", GFC_OMP_DIR_EXECUTABLE, ST_OMP_TASKWAIT},
     108                 :             :   {"taskyield", GFC_OMP_DIR_EXECUTABLE, ST_OMP_TASKYIELD},
     109                 :             :   {"task", GFC_OMP_DIR_EXECUTABLE, ST_OMP_TASK},
     110                 :             :   {"teams", GFC_OMP_DIR_EXECUTABLE, ST_OMP_TEAMS},
     111                 :             :   {"threadprivate", GFC_OMP_DIR_DECLARATIVE, ST_OMP_THREADPRIVATE},
     112                 :             :   {"tile", GFC_OMP_DIR_EXECUTABLE, ST_OMP_TILE},
     113                 :             :   {"unroll", GFC_OMP_DIR_EXECUTABLE, ST_OMP_UNROLL},
     114                 :             :   {"workshare", GFC_OMP_DIR_EXECUTABLE, ST_OMP_WORKSHARE},
     115                 :             : };
     116                 :             : 
     117                 :             : 
     118                 :             : /* Match an end of OpenMP directive.  End of OpenMP directive is optional
     119                 :             :    whitespace, followed by '\n' or comment '!'.  In the special case where a
     120                 :             :    context selector is being matched, match against ')' instead.  */
     121                 :             : 
     122                 :             : static match
     123                 :       53653 : gfc_match_omp_eos (void)
     124                 :             : {
     125                 :       53653 :   locus old_loc;
     126                 :       53653 :   char c;
     127                 :             : 
     128                 :       53653 :   old_loc = gfc_current_locus;
     129                 :       53653 :   gfc_gobble_whitespace ();
     130                 :             : 
     131                 :       53653 :   if (gfc_matching_omp_context_selector)
     132                 :             :     {
     133                 :         240 :       if (gfc_peek_ascii_char () == ')')
     134                 :             :         return MATCH_YES;
     135                 :             :     }
     136                 :             :   else
     137                 :             :     {
     138                 :       53413 :       c = gfc_next_ascii_char ();
     139                 :       53413 :       switch (c)
     140                 :             :         {
     141                 :           0 :         case '!':
     142                 :           0 :           do
     143                 :           0 :             c = gfc_next_ascii_char ();
     144                 :           0 :           while (c != '\n');
     145                 :             :           /* Fall through */
     146                 :             : 
     147                 :       51834 :         case '\n':
     148                 :       51834 :           return MATCH_YES;
     149                 :             :         }
     150                 :             :     }
     151                 :             : 
     152                 :        1580 :   gfc_current_locus = old_loc;
     153                 :        1580 :   return MATCH_NO;
     154                 :             : }
     155                 :             : 
     156                 :             : match
     157                 :       13091 : gfc_match_omp_eos_error (void)
     158                 :             : {
     159                 :       13091 :   if (gfc_match_omp_eos() == MATCH_YES)
     160                 :             :     return MATCH_YES;
     161                 :             : 
     162                 :          35 :   gfc_error ("Unexpected junk at %C");
     163                 :          35 :   return MATCH_ERROR;
     164                 :             : }
     165                 :             : 
     166                 :             : 
     167                 :             : /* Free an omp_clauses structure.  */
     168                 :             : 
     169                 :             : void
     170                 :       60036 : gfc_free_omp_clauses (gfc_omp_clauses *c)
     171                 :             : {
     172                 :       60036 :   int i;
     173                 :       60036 :   if (c == NULL)
     174                 :             :     return;
     175                 :             : 
     176                 :       33649 :   gfc_free_expr (c->if_expr);
     177                 :      403788 :   for (i = 0; i < OMP_IF_LAST; i++)
     178                 :      336490 :     gfc_free_expr (c->if_exprs[i]);
     179                 :       33649 :   gfc_free_expr (c->self_expr);
     180                 :       33649 :   gfc_free_expr (c->final_expr);
     181                 :       33649 :   gfc_free_expr (c->num_threads);
     182                 :       33649 :   gfc_free_expr (c->chunk_size);
     183                 :       33649 :   gfc_free_expr (c->safelen_expr);
     184                 :       33649 :   gfc_free_expr (c->simdlen_expr);
     185                 :       33649 :   gfc_free_expr (c->num_teams_lower);
     186                 :       33649 :   gfc_free_expr (c->num_teams_upper);
     187                 :       33649 :   gfc_free_expr (c->device);
     188                 :       33649 :   gfc_free_expr (c->thread_limit);
     189                 :       33649 :   gfc_free_expr (c->dist_chunk_size);
     190                 :       33649 :   gfc_free_expr (c->grainsize);
     191                 :       33649 :   gfc_free_expr (c->hint);
     192                 :       33649 :   gfc_free_expr (c->num_tasks);
     193                 :       33649 :   gfc_free_expr (c->priority);
     194                 :       33649 :   gfc_free_expr (c->detach);
     195                 :       33649 :   gfc_free_expr (c->novariants);
     196                 :       33649 :   gfc_free_expr (c->nocontext);
     197                 :       33649 :   gfc_free_expr (c->async_expr);
     198                 :       33649 :   gfc_free_expr (c->gang_num_expr);
     199                 :       33649 :   gfc_free_expr (c->gang_static_expr);
     200                 :       33649 :   gfc_free_expr (c->worker_expr);
     201                 :       33649 :   gfc_free_expr (c->vector_expr);
     202                 :       33649 :   gfc_free_expr (c->num_gangs_expr);
     203                 :       33649 :   gfc_free_expr (c->num_workers_expr);
     204                 :       33649 :   gfc_free_expr (c->vector_length_expr);
     205                 :     1345960 :   for (i = 0; i < OMP_LIST_NUM; i++)
     206                 :     1278662 :     gfc_free_omp_namelist (c->lists[i],
     207                 :     1278662 :                            i == OMP_LIST_AFFINITY || i == OMP_LIST_DEPEND,
     208                 :             :                            i == OMP_LIST_ALLOCATE,
     209                 :             :                            i == OMP_LIST_USES_ALLOCATORS,
     210                 :             :                            i == OMP_LIST_INIT);
     211                 :       33649 :   gfc_free_expr_list (c->wait_list);
     212                 :       33649 :   gfc_free_expr_list (c->tile_list);
     213                 :       33649 :   gfc_free_expr_list (c->sizes_list);
     214                 :       33649 :   free (CONST_CAST (char *, c->critical_name));
     215                 :       33649 :   if (c->assume)
     216                 :             :     {
     217                 :          20 :       free (c->assume->absent);
     218                 :          20 :       free (c->assume->contains);
     219                 :          20 :       gfc_free_expr_list (c->assume->holds);
     220                 :          20 :       free (c->assume);
     221                 :             :     }
     222                 :       33649 :   free (c);
     223                 :             : }
     224                 :             : 
     225                 :             : /* Free oacc_declare structures.  */
     226                 :             : 
     227                 :             : void
     228                 :          74 : gfc_free_oacc_declare_clauses (struct gfc_oacc_declare *oc)
     229                 :             : {
     230                 :          74 :   struct gfc_oacc_declare *decl = oc;
     231                 :             : 
     232                 :          74 :   do
     233                 :             :     {
     234                 :          74 :       struct gfc_oacc_declare *next;
     235                 :             : 
     236                 :          74 :       next = decl->next;
     237                 :          74 :       gfc_free_omp_clauses (decl->clauses);
     238                 :          74 :       free (decl);
     239                 :          74 :       decl = next;
     240                 :             :     }
     241                 :          74 :   while (decl);
     242                 :          74 : }
     243                 :             : 
     244                 :             : /* Free expression list. */
     245                 :             : void
     246                 :      101746 : gfc_free_expr_list (gfc_expr_list *list)
     247                 :             : {
     248                 :      101746 :   gfc_expr_list *n;
     249                 :             : 
     250                 :      103141 :   for (; list; list = n)
     251                 :             :     {
     252                 :        1395 :       n = list->next;
     253                 :        1395 :       free (list);
     254                 :             :     }
     255                 :      101746 : }
     256                 :             : 
     257                 :             : /* Free an !$omp declare simd construct list.  */
     258                 :             : 
     259                 :             : void
     260                 :         236 : gfc_free_omp_declare_simd (gfc_omp_declare_simd *ods)
     261                 :             : {
     262                 :         236 :   if (ods)
     263                 :             :     {
     264                 :         236 :       gfc_free_omp_clauses (ods->clauses);
     265                 :         236 :       free (ods);
     266                 :             :     }
     267                 :         236 : }
     268                 :             : 
     269                 :             : void
     270                 :      492880 : gfc_free_omp_declare_simd_list (gfc_omp_declare_simd *list)
     271                 :             : {
     272                 :      493116 :   while (list)
     273                 :             :     {
     274                 :         236 :       gfc_omp_declare_simd *current = list;
     275                 :         236 :       list = list->next;
     276                 :         236 :       gfc_free_omp_declare_simd (current);
     277                 :             :     }
     278                 :      492880 : }
     279                 :             : 
     280                 :             : static void
     281                 :         699 : gfc_free_omp_trait_property_list (gfc_omp_trait_property *list)
     282                 :             : {
     283                 :        1090 :   while (list)
     284                 :             :     {
     285                 :         391 :       gfc_omp_trait_property *current = list;
     286                 :         391 :       list = list->next;
     287                 :         391 :       switch (current->property_kind)
     288                 :             :         {
     289                 :          25 :         case OMP_TRAIT_PROPERTY_ID:
     290                 :          25 :           free (current->name);
     291                 :          25 :           break;
     292                 :         266 :         case OMP_TRAIT_PROPERTY_NAME_LIST:
     293                 :         266 :           if (current->is_name)
     294                 :         168 :             free (current->name);
     295                 :             :           break;
     296                 :          15 :         case OMP_TRAIT_PROPERTY_CLAUSE_LIST:
     297                 :          15 :           gfc_free_omp_clauses (current->clauses);
     298                 :          15 :           break;
     299                 :             :         default:
     300                 :             :           break;
     301                 :             :         }
     302                 :         391 :       free (current);
     303                 :             :     }
     304                 :         699 : }
     305                 :             : 
     306                 :             : static void
     307                 :         571 : gfc_free_omp_selector_list (gfc_omp_selector *list)
     308                 :             : {
     309                 :        1270 :   while (list)
     310                 :             :     {
     311                 :         699 :       gfc_omp_selector *current = list;
     312                 :         699 :       list = list->next;
     313                 :         699 :       gfc_free_omp_trait_property_list (current->properties);
     314                 :         699 :       free (current);
     315                 :             :     }
     316                 :         571 : }
     317                 :             : 
     318                 :             : static void
     319                 :         620 : gfc_free_omp_set_selector_list (gfc_omp_set_selector *list)
     320                 :             : {
     321                 :        1191 :   while (list)
     322                 :             :     {
     323                 :         571 :       gfc_omp_set_selector *current = list;
     324                 :         571 :       list = list->next;
     325                 :         571 :       gfc_free_omp_selector_list (current->trait_selectors);
     326                 :         571 :       free (current);
     327                 :             :     }
     328                 :         620 : }
     329                 :             : 
     330                 :             : /* Free an !$omp declare variant construct list.  */
     331                 :             : 
     332                 :             : void
     333                 :      492880 : gfc_free_omp_declare_variant_list (gfc_omp_declare_variant *list)
     334                 :             : {
     335                 :      493330 :   while (list)
     336                 :             :     {
     337                 :         450 :       gfc_omp_declare_variant *current = list;
     338                 :         450 :       list = list->next;
     339                 :         450 :       gfc_free_omp_set_selector_list (current->set_selectors);
     340                 :         450 :       gfc_free_omp_namelist (current->adjust_args_list, false, false, false,
     341                 :             :                              false);
     342                 :         450 :       free (current);
     343                 :             :     }
     344                 :      492880 : }
     345                 :             : 
     346                 :             : /* Free an !$omp declare reduction.  */
     347                 :             : 
     348                 :             : void
     349                 :        1118 : gfc_free_omp_udr (gfc_omp_udr *omp_udr)
     350                 :             : {
     351                 :        1118 :   if (omp_udr)
     352                 :             :     {
     353                 :         607 :       gfc_free_omp_udr (omp_udr->next);
     354                 :         607 :       gfc_free_namespace (omp_udr->combiner_ns);
     355                 :         607 :       if (omp_udr->initializer_ns)
     356                 :         377 :         gfc_free_namespace (omp_udr->initializer_ns);
     357                 :         607 :       free (omp_udr);
     358                 :             :     }
     359                 :        1118 : }
     360                 :             : 
     361                 :             : /* Free variants of an !$omp metadirective construct.  */
     362                 :             : 
     363                 :             : void
     364                 :          83 : gfc_free_omp_variants (gfc_omp_variant *variant)
     365                 :             : {
     366                 :         253 :   while (variant)
     367                 :             :     {
     368                 :         170 :       gfc_omp_variant *next_variant = variant->next;
     369                 :         170 :       gfc_free_omp_set_selector_list (variant->selectors);
     370                 :         170 :       free (variant);
     371                 :         170 :       variant = next_variant;
     372                 :             :     }
     373                 :          83 : }
     374                 :             : 
     375                 :             : static gfc_omp_udr *
     376                 :        4706 : gfc_find_omp_udr (gfc_namespace *ns, const char *name, gfc_typespec *ts)
     377                 :             : {
     378                 :        4706 :   gfc_symtree *st;
     379                 :             : 
     380                 :        4706 :   if (ns == NULL)
     381                 :         467 :     ns = gfc_current_ns;
     382                 :        5652 :   do
     383                 :             :     {
     384                 :        5652 :       gfc_omp_udr *omp_udr;
     385                 :             : 
     386                 :        5652 :       st = gfc_find_symtree (ns->omp_udr_root, name);
     387                 :        5652 :       if (st != NULL)
     388                 :             :         {
     389                 :         934 :           for (omp_udr = st->n.omp_udr; omp_udr; omp_udr = omp_udr->next)
     390                 :         934 :             if (ts == NULL)
     391                 :             :               return omp_udr;
     392                 :         567 :             else if (gfc_compare_types (&omp_udr->ts, ts))
     393                 :             :               {
     394                 :         479 :                 if (ts->type == BT_CHARACTER)
     395                 :             :                   {
     396                 :          60 :                     if (omp_udr->ts.u.cl->length == NULL)
     397                 :             :                       return omp_udr;
     398                 :          36 :                     if (ts->u.cl->length == NULL)
     399                 :           0 :                       continue;
     400                 :          36 :                     if (gfc_compare_expr (omp_udr->ts.u.cl->length,
     401                 :             :                                           ts->u.cl->length,
     402                 :             :                                           INTRINSIC_EQ) != 0)
     403                 :          12 :                       continue;
     404                 :             :                   }
     405                 :         443 :                 return omp_udr;
     406                 :             :               }
     407                 :             :         }
     408                 :             : 
     409                 :             :       /* Don't escape an interface block.  */
     410                 :        4818 :       if (ns && !ns->has_import_set
     411                 :        4818 :           && ns->proc_name && ns->proc_name->attr.if_source == IFSRC_IFBODY)
     412                 :             :         break;
     413                 :             : 
     414                 :        4818 :       ns = ns->parent;
     415                 :             :     }
     416                 :        4818 :   while (ns != NULL);
     417                 :             : 
     418                 :             :   return NULL;
     419                 :             : }
     420                 :             : 
     421                 :             : 
     422                 :             : /* Match a variable/common block list and construct a namelist from it;
     423                 :             :    if has_all_memory != NULL, *has_all_memory is set and omp_all_memory
     424                 :             :    yields a list->sym NULL entry. */
     425                 :             : 
     426                 :             : static match
     427                 :       30308 : gfc_match_omp_variable_list (const char *str, gfc_omp_namelist **list,
     428                 :             :                              bool allow_common, bool *end_colon = NULL,
     429                 :             :                              gfc_omp_namelist ***headp = NULL,
     430                 :             :                              bool allow_sections = false,
     431                 :             :                              bool allow_derived = false,
     432                 :             :                              bool *has_all_memory = NULL,
     433                 :             :                              bool reject_common_vars = false,
     434                 :             :                              bool reverse_order = false)
     435                 :             : {
     436                 :       30308 :   gfc_omp_namelist *head, *tail, *p;
     437                 :       30308 :   locus old_loc, cur_loc;
     438                 :       30308 :   char n[GFC_MAX_SYMBOL_LEN+1];
     439                 :       30308 :   gfc_symbol *sym;
     440                 :       30308 :   match m;
     441                 :       30308 :   gfc_symtree *st;
     442                 :             : 
     443                 :       30308 :   head = tail = NULL;
     444                 :             : 
     445                 :       30308 :   old_loc = gfc_current_locus;
     446                 :       30308 :   if (has_all_memory)
     447                 :         701 :     *has_all_memory = false;
     448                 :       30308 :   m = gfc_match (str);
     449                 :       30308 :   if (m != MATCH_YES)
     450                 :             :     return m;
     451                 :             : 
     452                 :       36736 :   for (;;)
     453                 :             :     {
     454                 :       36736 :       gfc_gobble_whitespace ();
     455                 :       36736 :       cur_loc = gfc_current_locus;
     456                 :             : 
     457                 :       36736 :       m = gfc_match_name (n);
     458                 :       36736 :       if (m == MATCH_YES && strcmp (n, "omp_all_memory") == 0)
     459                 :             :         {
     460                 :          23 :           locus loc = gfc_get_location_range (NULL, 0, &cur_loc, 1,
     461                 :             :                                               &gfc_current_locus);
     462                 :          23 :           if (!has_all_memory)
     463                 :             :             {
     464                 :           2 :               gfc_error ("%<omp_all_memory%> at %L not permitted in this "
     465                 :             :                          "clause", &loc);
     466                 :           2 :               goto cleanup;
     467                 :             :             }
     468                 :          21 :           *has_all_memory = true;
     469                 :          21 :           p = gfc_get_omp_namelist ();
     470                 :          21 :           if (head == NULL)
     471                 :             :             head = tail = p;
     472                 :             :           else
     473                 :             :             {
     474                 :           3 :               tail->next = p;
     475                 :           3 :               tail = tail->next;
     476                 :             :             }
     477                 :          21 :           tail->where = loc;
     478                 :          21 :           goto next_item;
     479                 :             :         }
     480                 :       36507 :       if (m == MATCH_YES)
     481                 :             :         {
     482                 :       36507 :           gfc_symtree *st;
     483                 :       36507 :           if ((m = gfc_get_ha_sym_tree (n, &st) ? MATCH_ERROR : MATCH_YES)
     484                 :             :               == MATCH_YES)
     485                 :       36507 :             sym = st->n.sym;
     486                 :             :         }
     487                 :       36713 :       switch (m)
     488                 :             :         {
     489                 :       36507 :         case MATCH_YES:
     490                 :       36507 :           gfc_expr *expr;
     491                 :       36507 :           expr = NULL;
     492                 :       36507 :           gfc_gobble_whitespace ();
     493                 :       22083 :           if ((allow_sections && gfc_peek_ascii_char () == '(')
     494                 :       54504 :               || (allow_derived && gfc_peek_ascii_char () == '%'))
     495                 :             :             {
     496                 :        5911 :               gfc_current_locus = cur_loc;
     497                 :        5911 :               m = gfc_match_variable (&expr, 0);
     498                 :        5911 :               switch (m)
     499                 :             :                 {
     500                 :           4 :                 case MATCH_ERROR:
     501                 :          12 :                   goto cleanup;
     502                 :           0 :                 case MATCH_NO:
     503                 :           0 :                   goto syntax;
     504                 :        5907 :                 default:
     505                 :        5907 :                   break;
     506                 :             :                 }
     507                 :        5907 :               if (gfc_is_coindexed (expr))
     508                 :             :                 {
     509                 :           5 :                   gfc_error ("List item shall not be coindexed at %L",
     510                 :           5 :                              &expr->where);
     511                 :           5 :                   goto cleanup;
     512                 :             :                 }
     513                 :             :             }
     514                 :       36498 :           gfc_set_sym_referenced (sym);
     515                 :       36498 :           p = gfc_get_omp_namelist ();
     516                 :       36498 :           if (head == NULL)
     517                 :             :             head = tail = p;
     518                 :        9828 :           else if (reverse_order)
     519                 :             :             {
     520                 :          57 :               p->next = head;
     521                 :          57 :               head = p;
     522                 :             :             }
     523                 :             :           else
     524                 :             :             {
     525                 :        9771 :               tail->next = p;
     526                 :        9771 :               tail = tail->next;
     527                 :             :             }
     528                 :       36498 :           p->sym = sym;
     529                 :       36498 :           p->expr = expr;
     530                 :       36498 :           p->where = gfc_get_location_range (NULL, 0, &cur_loc, 1,
     531                 :             :                                              &gfc_current_locus);
     532                 :       36498 :           if (reject_common_vars && sym->attr.in_common)
     533                 :             :             {
     534                 :           3 :               gcc_assert (allow_common);
     535                 :           3 :               gfc_error ("%qs at %L is part of the common block %</%s/%> and "
     536                 :             :                          "may only be specificed implicitly via the named "
     537                 :             :                          "common block", sym->name, &cur_loc,
     538                 :           3 :                          sym->common_head->name);
     539                 :           3 :               goto cleanup;
     540                 :             :             }
     541                 :       36495 :           goto next_item;
     542                 :         206 :         case MATCH_NO:
     543                 :         206 :           break;
     544                 :           0 :         case MATCH_ERROR:
     545                 :           0 :           goto cleanup;
     546                 :             :         }
     547                 :             : 
     548                 :         206 :       if (!allow_common)
     549                 :          10 :         goto syntax;
     550                 :             : 
     551                 :         196 :       m = gfc_match ("/ %n /", n);
     552                 :         196 :       if (m == MATCH_ERROR)
     553                 :           0 :         goto cleanup;
     554                 :         196 :       if (m == MATCH_NO)
     555                 :          19 :         goto syntax;
     556                 :             : 
     557                 :         177 :       cur_loc = gfc_get_location_range (NULL, 0, &cur_loc, 1,
     558                 :             :                                         &gfc_current_locus);
     559                 :         177 :       st = gfc_find_symtree (gfc_current_ns->common_root, n);
     560                 :         177 :       if (st == NULL)
     561                 :             :         {
     562                 :           2 :           gfc_error ("COMMON block %</%s/%> not found at %L", n, &cur_loc);
     563                 :           2 :           goto cleanup;
     564                 :             :         }
     565                 :         628 :       for (sym = st->n.common->head; sym; sym = sym->common_next)
     566                 :             :         {
     567                 :         453 :           gfc_set_sym_referenced (sym);
     568                 :         453 :           p = gfc_get_omp_namelist ();
     569                 :         453 :           if (head == NULL)
     570                 :             :             head = tail = p;
     571                 :         325 :           else if (reverse_order)
     572                 :             :             {
     573                 :           0 :               p->next = head;
     574                 :           0 :               head = p;
     575                 :             :             }
     576                 :             :           else
     577                 :             :             {
     578                 :         325 :               tail->next = p;
     579                 :         325 :               tail = tail->next;
     580                 :             :             }
     581                 :         453 :           p->sym = sym;
     582                 :         453 :           p->where = cur_loc;
     583                 :             :         }
     584                 :             : 
     585                 :         175 :     next_item:
     586                 :       36691 :       if (end_colon && gfc_match_char (':') == MATCH_YES)
     587                 :             :         {
     588                 :         790 :           *end_colon = true;
     589                 :         790 :           break;
     590                 :             :         }
     591                 :       35901 :       if (gfc_match_char (')') == MATCH_YES)
     592                 :             :         break;
     593                 :        9897 :       if (gfc_match_char (',') != MATCH_YES)
     594                 :          19 :         goto syntax;
     595                 :             :     }
     596                 :             : 
     597                 :       36201 :   while (*list)
     598                 :        9407 :     list = &(*list)->next;
     599                 :             : 
     600                 :       26794 :   *list = head;
     601                 :       26794 :   if (headp)
     602                 :       21124 :     *headp = list;
     603                 :             :   return MATCH_YES;
     604                 :             : 
     605                 :          48 : syntax:
     606                 :          48 :   gfc_error ("Syntax error in OpenMP variable list at %C");
     607                 :             : 
     608                 :          64 : cleanup:
     609                 :          64 :   gfc_free_omp_namelist (head, false, false, false, false);
     610                 :          64 :   gfc_current_locus = old_loc;
     611                 :          64 :   return MATCH_ERROR;
     612                 :             : }
     613                 :             : 
     614                 :             : /* Match a variable/procedure/common block list and construct a namelist
     615                 :             :    from it.  */
     616                 :             : 
     617                 :             : static match
     618                 :         311 : gfc_match_omp_to_link (const char *str, gfc_omp_namelist **list)
     619                 :             : {
     620                 :         311 :   gfc_omp_namelist *head, *tail, *p;
     621                 :         311 :   locus old_loc, cur_loc;
     622                 :         311 :   char n[GFC_MAX_SYMBOL_LEN+1];
     623                 :         311 :   gfc_symbol *sym;
     624                 :         311 :   match m;
     625                 :         311 :   gfc_symtree *st;
     626                 :             : 
     627                 :         311 :   head = tail = NULL;
     628                 :             : 
     629                 :         311 :   old_loc = gfc_current_locus;
     630                 :             : 
     631                 :         311 :   m = gfc_match (str);
     632                 :         311 :   if (m != MATCH_YES)
     633                 :             :     return m;
     634                 :             : 
     635                 :         505 :   for (;;)
     636                 :             :     {
     637                 :         505 :       cur_loc = gfc_current_locus;
     638                 :         505 :       m = gfc_match_symbol (&sym, 1);
     639                 :         505 :       switch (m)
     640                 :             :         {
     641                 :         480 :         case MATCH_YES:
     642                 :         480 :           p = gfc_get_omp_namelist ();
     643                 :         480 :           if (head == NULL)
     644                 :             :             head = tail = p;
     645                 :             :           else
     646                 :             :             {
     647                 :         191 :               tail->next = p;
     648                 :         191 :               tail = tail->next;
     649                 :             :             }
     650                 :         480 :           tail->sym = sym;
     651                 :         480 :           tail->where = cur_loc;
     652                 :         480 :           goto next_item;
     653                 :             :         case MATCH_NO:
     654                 :             :           break;
     655                 :           0 :         case MATCH_ERROR:
     656                 :           0 :           goto cleanup;
     657                 :             :         }
     658                 :             : 
     659                 :          25 :       m = gfc_match (" / %n /", n);
     660                 :          25 :       if (m == MATCH_ERROR)
     661                 :           0 :         goto cleanup;
     662                 :          25 :       if (m == MATCH_NO)
     663                 :           0 :         goto syntax;
     664                 :             : 
     665                 :          25 :       st = gfc_find_symtree (gfc_current_ns->common_root, n);
     666                 :          25 :       if (st == NULL)
     667                 :             :         {
     668                 :           0 :           gfc_error ("COMMON block /%s/ not found at %C", n);
     669                 :           0 :           goto cleanup;
     670                 :             :         }
     671                 :          25 :       p = gfc_get_omp_namelist ();
     672                 :          25 :       if (head == NULL)
     673                 :             :         head = tail = p;
     674                 :             :       else
     675                 :             :         {
     676                 :           3 :           tail->next = p;
     677                 :           3 :           tail = tail->next;
     678                 :             :         }
     679                 :          25 :       tail->u.common = st->n.common;
     680                 :          25 :       tail->where = cur_loc;
     681                 :             : 
     682                 :         505 :     next_item:
     683                 :         505 :       if (gfc_match_char (')') == MATCH_YES)
     684                 :             :         break;
     685                 :         194 :       if (gfc_match_char (',') != MATCH_YES)
     686                 :           0 :         goto syntax;
     687                 :             :     }
     688                 :             : 
     689                 :         322 :   while (*list)
     690                 :          11 :     list = &(*list)->next;
     691                 :             : 
     692                 :         311 :   *list = head;
     693                 :         311 :   return MATCH_YES;
     694                 :             : 
     695                 :           0 : syntax:
     696                 :           0 :   gfc_error ("Syntax error in OpenMP variable list at %C");
     697                 :             : 
     698                 :           0 : cleanup:
     699                 :           0 :   gfc_free_omp_namelist (head, false, false, false, false);
     700                 :           0 :   gfc_current_locus = old_loc;
     701                 :           0 :   return MATCH_ERROR;
     702                 :             : }
     703                 :             : 
     704                 :             : /* Match detach(event-handle).  */
     705                 :             : 
     706                 :             : static match
     707                 :         126 : gfc_match_omp_detach (gfc_expr **expr)
     708                 :             : {
     709                 :         126 :   locus old_loc = gfc_current_locus;
     710                 :             : 
     711                 :         126 :   if (gfc_match ("detach ( ") != MATCH_YES)
     712                 :           0 :     goto syntax_error;
     713                 :             : 
     714                 :         126 :   if (gfc_match_variable (expr, 0) != MATCH_YES)
     715                 :           0 :     goto syntax_error;
     716                 :             : 
     717                 :         126 :   if (gfc_match_char (')') != MATCH_YES)
     718                 :           0 :     goto syntax_error;
     719                 :             : 
     720                 :             :   return MATCH_YES;
     721                 :             : 
     722                 :           0 : syntax_error:
     723                 :           0 :    gfc_error ("Syntax error in OpenMP detach clause at %C");
     724                 :           0 :    gfc_current_locus = old_loc;
     725                 :           0 :    return MATCH_ERROR;
     726                 :             : 
     727                 :             : }
     728                 :             : 
     729                 :             : /* Match doacross(sink : ...) construct a namelist from it;
     730                 :             :    if depend is true, match legacy 'depend(sink : ...)'.  */
     731                 :             : 
     732                 :             : static match
     733                 :         240 : gfc_match_omp_doacross_sink (gfc_omp_namelist **list, bool depend)
     734                 :             : {
     735                 :         240 :   char n[GFC_MAX_SYMBOL_LEN+1];
     736                 :         240 :   gfc_omp_namelist *head, *tail, *p;
     737                 :         240 :   locus old_loc, cur_loc;
     738                 :         240 :   gfc_symbol *sym;
     739                 :             : 
     740                 :         240 :   head = tail = NULL;
     741                 :             : 
     742                 :         240 :   old_loc = gfc_current_locus;
     743                 :             : 
     744                 :        2230 :   for (;;)
     745                 :             :     {
     746                 :        1235 :       gfc_gobble_whitespace ();
     747                 :        1235 :       cur_loc = gfc_current_locus;
     748                 :             : 
     749                 :        1235 :       if (gfc_match_name (n) != MATCH_YES)
     750                 :           1 :         goto syntax;
     751                 :        1234 :       locus loc = gfc_get_location_range (NULL, 0, &cur_loc, 1,
     752                 :             :                                           &gfc_current_locus);
     753                 :        1234 :       if (UNLIKELY (strcmp (n, "omp_all_memory") == 0))
     754                 :             :         {
     755                 :           1 :           gfc_error ("%<omp_all_memory%> used with dependence-type "
     756                 :             :                      "other than OUT or INOUT at %L", &loc);
     757                 :           1 :           goto cleanup;
     758                 :             :         }
     759                 :        1233 :       sym = NULL;
     760                 :        1233 :       if (!(strcmp (n, "omp_cur_iteration") == 0))
     761                 :             :         {
     762                 :        1228 :           gfc_symtree *st;
     763                 :        1228 :           if (gfc_get_ha_sym_tree (n, &st))
     764                 :           0 :             goto syntax;
     765                 :        1228 :           sym = st->n.sym;
     766                 :        1228 :           gfc_set_sym_referenced (sym);
     767                 :             :         }
     768                 :        1233 :       p = gfc_get_omp_namelist ();
     769                 :        1233 :       if (head == NULL)
     770                 :             :         {
     771                 :         238 :           head = tail = p;
     772                 :         252 :           head->u.depend_doacross_op = (depend ? OMP_DEPEND_SINK_FIRST
     773                 :             :                                                : OMP_DOACROSS_SINK_FIRST);
     774                 :             :         }
     775                 :             :       else
     776                 :             :         {
     777                 :         995 :           tail->next = p;
     778                 :         995 :           tail = tail->next;
     779                 :         995 :           tail->u.depend_doacross_op = OMP_DOACROSS_SINK;
     780                 :             :         }
     781                 :        1233 :       tail->sym = sym;
     782                 :        1233 :       tail->expr = NULL;
     783                 :        1233 :       tail->where = loc;
     784                 :        1233 :       if (gfc_match_char ('+') == MATCH_YES)
     785                 :             :         {
     786                 :         154 :           if (gfc_match_literal_constant (&tail->expr, 0) != MATCH_YES)
     787                 :           0 :             goto syntax;
     788                 :             :         }
     789                 :        1079 :       else if (gfc_match_char ('-') == MATCH_YES)
     790                 :             :         {
     791                 :         418 :           if (gfc_match_literal_constant (&tail->expr, 0) != MATCH_YES)
     792                 :           1 :             goto syntax;
     793                 :         417 :           tail->expr = gfc_uminus (tail->expr);
     794                 :             :         }
     795                 :        1232 :       if (gfc_match_char (')') == MATCH_YES)
     796                 :             :         break;
     797                 :         995 :       if (gfc_match_char (',') != MATCH_YES)
     798                 :           0 :         goto syntax;
     799                 :         995 :     }
     800                 :             : 
     801                 :        1029 :   while (*list)
     802                 :         792 :     list = &(*list)->next;
     803                 :             : 
     804                 :         237 :   *list = head;
     805                 :         237 :   return MATCH_YES;
     806                 :             : 
     807                 :           2 : syntax:
     808                 :           2 :   gfc_error ("Syntax error in OpenMP SINK dependence-type list at %C");
     809                 :             : 
     810                 :           3 : cleanup:
     811                 :           3 :   gfc_free_omp_namelist (head, false, false, false, false);
     812                 :           3 :   gfc_current_locus = old_loc;
     813                 :           3 :   return MATCH_ERROR;
     814                 :             : }
     815                 :             : 
     816                 :             : static match
     817                 :         813 : match_omp_oacc_expr_list (const char *str, gfc_expr_list **list,
     818                 :             :                           bool allow_asterisk, bool is_omp)
     819                 :             : {
     820                 :         813 :   gfc_expr_list *head, *tail, *p;
     821                 :         813 :   locus old_loc;
     822                 :         813 :   gfc_expr *expr;
     823                 :         813 :   match m;
     824                 :             : 
     825                 :         813 :   head = tail = NULL;
     826                 :             : 
     827                 :         813 :   old_loc = gfc_current_locus;
     828                 :             : 
     829                 :         813 :   m = gfc_match (str);
     830                 :         813 :   if (m != MATCH_YES)
     831                 :             :     return m;
     832                 :             : 
     833                 :        1024 :   for (;;)
     834                 :             :     {
     835                 :        1024 :       m = gfc_match_expr (&expr);
     836                 :        1024 :       if (m == MATCH_YES || allow_asterisk)
     837                 :             :         {
     838                 :        1012 :           p = gfc_get_expr_list ();
     839                 :        1012 :           if (head == NULL)
     840                 :             :             head = tail = p;
     841                 :             :           else
     842                 :             :             {
     843                 :         335 :               tail->next = p;
     844                 :         335 :               tail = tail->next;
     845                 :             :             }
     846                 :        1012 :           if (m == MATCH_YES)
     847                 :         879 :             tail->expr = expr;
     848                 :         133 :           else if (gfc_match (" *") != MATCH_YES)
     849                 :          18 :             goto syntax;
     850                 :         994 :           goto next_item;
     851                 :             :         }
     852                 :          12 :       if (m == MATCH_ERROR)
     853                 :           0 :         goto cleanup;
     854                 :          12 :       goto syntax;
     855                 :             : 
     856                 :         994 :     next_item:
     857                 :         994 :       if (gfc_match_char (')') == MATCH_YES)
     858                 :             :         break;
     859                 :         346 :       if (gfc_match_char (',') != MATCH_YES)
     860                 :           6 :         goto syntax;
     861                 :             :     }
     862                 :             : 
     863                 :         654 :   while (*list)
     864                 :           6 :     list = &(*list)->next;
     865                 :             : 
     866                 :         648 :   *list = head;
     867                 :         648 :   return MATCH_YES;
     868                 :             : 
     869                 :          36 : syntax:
     870                 :          36 :   if (is_omp)
     871                 :           7 :     gfc_error ("Syntax error in OpenMP expression list at %C");
     872                 :             :   else
     873                 :          29 :     gfc_error ("Syntax error in OpenACC expression list at %C");
     874                 :             : 
     875                 :          36 : cleanup:
     876                 :          36 :   gfc_free_expr_list (head);
     877                 :          36 :   gfc_current_locus = old_loc;
     878                 :          36 :   return MATCH_ERROR;
     879                 :             : }
     880                 :             : 
     881                 :             : static match
     882                 :        3055 : match_oacc_clause_gwv (gfc_omp_clauses *cp, unsigned gwv)
     883                 :             : {
     884                 :        3055 :   match ret = MATCH_YES;
     885                 :             : 
     886                 :        3055 :   if (gfc_match (" ( ") != MATCH_YES)
     887                 :             :     return MATCH_NO;
     888                 :             : 
     889                 :         470 :   if (gwv == GOMP_DIM_GANG)
     890                 :             :     {
     891                 :             :         /* The gang clause accepts two optional arguments, num and static.
     892                 :             :          The num argument may either be explicit (num: <val>) or
     893                 :             :          implicit without (<val> without num:).  */
     894                 :             : 
     895                 :         457 :       while (ret == MATCH_YES)
     896                 :             :         {
     897                 :         236 :           if (gfc_match (" static :") == MATCH_YES)
     898                 :             :             {
     899                 :         114 :               if (cp->gang_static)
     900                 :             :                 return MATCH_ERROR;
     901                 :             :               else
     902                 :         113 :                 cp->gang_static = true;
     903                 :         113 :               if (gfc_match_char ('*') == MATCH_YES)
     904                 :          18 :                 cp->gang_static_expr = NULL;
     905                 :          95 :               else if (gfc_match (" %e ", &cp->gang_static_expr) != MATCH_YES)
     906                 :             :                 return MATCH_ERROR;
     907                 :             :             }
     908                 :             :           else
     909                 :             :             {
     910                 :         122 :               if (cp->gang_num_expr)
     911                 :             :                 return MATCH_ERROR;
     912                 :             : 
     913                 :             :               /* The 'num' argument is optional.  */
     914                 :         121 :               gfc_match (" num :");
     915                 :             : 
     916                 :         121 :               if (gfc_match (" %e ", &cp->gang_num_expr) != MATCH_YES)
     917                 :             :                 return MATCH_ERROR;
     918                 :             :             }
     919                 :             : 
     920                 :         231 :           ret = gfc_match (" , ");
     921                 :             :         }
     922                 :             :     }
     923                 :         244 :   else if (gwv == GOMP_DIM_WORKER)
     924                 :             :     {
     925                 :             :       /* The 'num' argument is optional.  */
     926                 :         107 :       gfc_match (" num :");
     927                 :             : 
     928                 :         107 :       if (gfc_match (" %e ", &cp->worker_expr) != MATCH_YES)
     929                 :             :         return MATCH_ERROR;
     930                 :             :     }
     931                 :         137 :   else if (gwv == GOMP_DIM_VECTOR)
     932                 :             :     {
     933                 :             :       /* The 'length' argument is optional.  */
     934                 :         137 :       gfc_match (" length :");
     935                 :             : 
     936                 :         137 :       if (gfc_match (" %e ", &cp->vector_expr) != MATCH_YES)
     937                 :             :         return MATCH_ERROR;
     938                 :             :     }
     939                 :             :   else
     940                 :           0 :     gfc_fatal_error ("Unexpected OpenACC parallelism.");
     941                 :             : 
     942                 :         459 :   return gfc_match (" )");
     943                 :             : }
     944                 :             : 
     945                 :             : static match
     946                 :           8 : gfc_match_oacc_clause_link (const char *str, gfc_omp_namelist **list)
     947                 :             : {
     948                 :           8 :   gfc_omp_namelist *head = NULL;
     949                 :           8 :   gfc_omp_namelist *tail, *p;
     950                 :           8 :   locus old_loc;
     951                 :           8 :   char n[GFC_MAX_SYMBOL_LEN+1];
     952                 :           8 :   gfc_symbol *sym;
     953                 :           8 :   match m;
     954                 :           8 :   gfc_symtree *st;
     955                 :             : 
     956                 :           8 :   old_loc = gfc_current_locus;
     957                 :             : 
     958                 :           8 :   m = gfc_match (str);
     959                 :           8 :   if (m != MATCH_YES)
     960                 :             :     return m;
     961                 :             : 
     962                 :           8 :   m = gfc_match (" (");
     963                 :             : 
     964                 :          14 :   for (;;)
     965                 :             :     {
     966                 :          14 :       m = gfc_match_symbol (&sym, 0);
     967                 :          14 :       switch (m)
     968                 :             :         {
     969                 :           8 :         case MATCH_YES:
     970                 :           8 :           if (sym->attr.in_common)
     971                 :             :             {
     972                 :           2 :               gfc_error_now ("Variable at %C is an element of a COMMON block");
     973                 :           2 :               goto cleanup;
     974                 :             :             }
     975                 :           6 :           gfc_set_sym_referenced (sym);
     976                 :           6 :           p = gfc_get_omp_namelist ();
     977                 :           6 :           if (head == NULL)
     978                 :             :             head = tail = p;
     979                 :             :           else
     980                 :             :             {
     981                 :           4 :               tail->next = p;
     982                 :           4 :               tail = tail->next;
     983                 :             :             }
     984                 :           6 :           tail->sym = sym;
     985                 :           6 :           tail->expr = NULL;
     986                 :           6 :           tail->where = gfc_current_locus;
     987                 :           6 :           goto next_item;
     988                 :             :         case MATCH_NO:
     989                 :             :           break;
     990                 :             : 
     991                 :           0 :         case MATCH_ERROR:
     992                 :           0 :           goto cleanup;
     993                 :             :         }
     994                 :             : 
     995                 :           6 :       m = gfc_match (" / %n /", n);
     996                 :           6 :       if (m == MATCH_ERROR)
     997                 :           0 :         goto cleanup;
     998                 :           6 :       if (m == MATCH_NO || n[0] == '\0')
     999                 :           0 :         goto syntax;
    1000                 :             : 
    1001                 :           6 :       st = gfc_find_symtree (gfc_current_ns->common_root, n);
    1002                 :           6 :       if (st == NULL)
    1003                 :             :         {
    1004                 :           1 :           gfc_error ("COMMON block /%s/ not found at %C", n);
    1005                 :           1 :           goto cleanup;
    1006                 :             :         }
    1007                 :             : 
    1008                 :          20 :       for (sym = st->n.common->head; sym; sym = sym->common_next)
    1009                 :             :         {
    1010                 :          15 :           gfc_set_sym_referenced (sym);
    1011                 :          15 :           p = gfc_get_omp_namelist ();
    1012                 :          15 :           if (head == NULL)
    1013                 :             :             head = tail = p;
    1014                 :             :           else
    1015                 :             :             {
    1016                 :          12 :               tail->next = p;
    1017                 :          12 :               tail = tail->next;
    1018                 :             :             }
    1019                 :          15 :           tail->sym = sym;
    1020                 :          15 :           tail->where = gfc_current_locus;
    1021                 :             :         }
    1022                 :             : 
    1023                 :           5 :     next_item:
    1024                 :          11 :       if (gfc_match_char (')') == MATCH_YES)
    1025                 :             :         break;
    1026                 :           6 :       if (gfc_match_char (',') != MATCH_YES)
    1027                 :           0 :         goto syntax;
    1028                 :             :     }
    1029                 :             : 
    1030                 :           5 :   if (gfc_match_omp_eos () != MATCH_YES)
    1031                 :             :     {
    1032                 :           1 :       gfc_error ("Unexpected junk after !$ACC DECLARE at %C");
    1033                 :           1 :       goto cleanup;
    1034                 :             :     }
    1035                 :             : 
    1036                 :           4 :   while (*list)
    1037                 :           0 :     list = &(*list)->next;
    1038                 :           4 :   *list = head;
    1039                 :           4 :   return MATCH_YES;
    1040                 :             : 
    1041                 :           0 : syntax:
    1042                 :           0 :   gfc_error ("Syntax error in !$ACC DECLARE list at %C");
    1043                 :             : 
    1044                 :           4 : cleanup:
    1045                 :           4 :   gfc_current_locus = old_loc;
    1046                 :           4 :   return MATCH_ERROR;
    1047                 :             : }
    1048                 :             : 
    1049                 :             : /* OpenMP clauses.  */
    1050                 :             : enum omp_mask1
    1051                 :             : {
    1052                 :             :   OMP_CLAUSE_PRIVATE,
    1053                 :             :   OMP_CLAUSE_FIRSTPRIVATE,
    1054                 :             :   OMP_CLAUSE_LASTPRIVATE,
    1055                 :             :   OMP_CLAUSE_COPYPRIVATE,
    1056                 :             :   OMP_CLAUSE_SHARED,
    1057                 :             :   OMP_CLAUSE_COPYIN,
    1058                 :             :   OMP_CLAUSE_REDUCTION,
    1059                 :             :   OMP_CLAUSE_IN_REDUCTION,
    1060                 :             :   OMP_CLAUSE_TASK_REDUCTION,
    1061                 :             :   OMP_CLAUSE_IF,
    1062                 :             :   OMP_CLAUSE_NUM_THREADS,
    1063                 :             :   OMP_CLAUSE_SCHEDULE,
    1064                 :             :   OMP_CLAUSE_DEFAULT,
    1065                 :             :   OMP_CLAUSE_ORDER,
    1066                 :             :   OMP_CLAUSE_ORDERED,
    1067                 :             :   OMP_CLAUSE_COLLAPSE,
    1068                 :             :   OMP_CLAUSE_UNTIED,
    1069                 :             :   OMP_CLAUSE_FINAL,
    1070                 :             :   OMP_CLAUSE_MERGEABLE,
    1071                 :             :   OMP_CLAUSE_ALIGNED,
    1072                 :             :   OMP_CLAUSE_DEPEND,
    1073                 :             :   OMP_CLAUSE_INBRANCH,
    1074                 :             :   OMP_CLAUSE_LINEAR,
    1075                 :             :   OMP_CLAUSE_NOTINBRANCH,
    1076                 :             :   OMP_CLAUSE_PROC_BIND,
    1077                 :             :   OMP_CLAUSE_SAFELEN,
    1078                 :             :   OMP_CLAUSE_SIMDLEN,
    1079                 :             :   OMP_CLAUSE_UNIFORM,
    1080                 :             :   OMP_CLAUSE_DEVICE,
    1081                 :             :   OMP_CLAUSE_MAP,
    1082                 :             :   OMP_CLAUSE_TO,
    1083                 :             :   OMP_CLAUSE_FROM,
    1084                 :             :   OMP_CLAUSE_NUM_TEAMS,
    1085                 :             :   OMP_CLAUSE_THREAD_LIMIT,
    1086                 :             :   OMP_CLAUSE_DIST_SCHEDULE,
    1087                 :             :   OMP_CLAUSE_DEFAULTMAP,
    1088                 :             :   OMP_CLAUSE_GRAINSIZE,
    1089                 :             :   OMP_CLAUSE_HINT,
    1090                 :             :   OMP_CLAUSE_IS_DEVICE_PTR,
    1091                 :             :   OMP_CLAUSE_LINK,
    1092                 :             :   OMP_CLAUSE_NOGROUP,
    1093                 :             :   OMP_CLAUSE_NOTEMPORAL,
    1094                 :             :   OMP_CLAUSE_NUM_TASKS,
    1095                 :             :   OMP_CLAUSE_PRIORITY,
    1096                 :             :   OMP_CLAUSE_SIMD,
    1097                 :             :   OMP_CLAUSE_THREADS,
    1098                 :             :   OMP_CLAUSE_USE_DEVICE_PTR,
    1099                 :             :   OMP_CLAUSE_USE_DEVICE_ADDR,  /* OpenMP 5.0.  */
    1100                 :             :   OMP_CLAUSE_DEVICE_TYPE,  /* OpenMP 5.0.  */
    1101                 :             :   OMP_CLAUSE_ATOMIC,  /* OpenMP 5.0.  */
    1102                 :             :   OMP_CLAUSE_CAPTURE,  /* OpenMP 5.0.  */
    1103                 :             :   OMP_CLAUSE_MEMORDER,  /* OpenMP 5.0.  */
    1104                 :             :   OMP_CLAUSE_DETACH,  /* OpenMP 5.0.  */
    1105                 :             :   OMP_CLAUSE_AFFINITY,  /* OpenMP 5.0.  */
    1106                 :             :   OMP_CLAUSE_ALLOCATE,  /* OpenMP 5.0.  */
    1107                 :             :   OMP_CLAUSE_BIND,  /* OpenMP 5.0.  */
    1108                 :             :   OMP_CLAUSE_FILTER,  /* OpenMP 5.1.  */
    1109                 :             :   OMP_CLAUSE_AT,  /* OpenMP 5.1.  */
    1110                 :             :   OMP_CLAUSE_MESSAGE,  /* OpenMP 5.1.  */
    1111                 :             :   OMP_CLAUSE_SEVERITY,  /* OpenMP 5.1.  */
    1112                 :             :   OMP_CLAUSE_COMPARE,  /* OpenMP 5.1.  */
    1113                 :             :   OMP_CLAUSE_FAIL,  /* OpenMP 5.1.  */
    1114                 :             :   OMP_CLAUSE_WEAK,  /* OpenMP 5.1.  */
    1115                 :             :   OMP_CLAUSE_NOWAIT,
    1116                 :             :   /* This must come last.  */
    1117                 :             :   OMP_MASK1_LAST
    1118                 :             : };
    1119                 :             : 
    1120                 :             : /* More OpenMP clauses and OpenACC 2.0+ specific clauses. */
    1121                 :             : enum omp_mask2
    1122                 :             : {
    1123                 :             :   OMP_CLAUSE_ASYNC,
    1124                 :             :   OMP_CLAUSE_NUM_GANGS,
    1125                 :             :   OMP_CLAUSE_NUM_WORKERS,
    1126                 :             :   OMP_CLAUSE_VECTOR_LENGTH,
    1127                 :             :   OMP_CLAUSE_COPY,
    1128                 :             :   OMP_CLAUSE_COPYOUT,
    1129                 :             :   OMP_CLAUSE_CREATE,
    1130                 :             :   OMP_CLAUSE_NO_CREATE,
    1131                 :             :   OMP_CLAUSE_PRESENT,
    1132                 :             :   OMP_CLAUSE_DEVICEPTR,
    1133                 :             :   OMP_CLAUSE_GANG,
    1134                 :             :   OMP_CLAUSE_WORKER,
    1135                 :             :   OMP_CLAUSE_VECTOR,
    1136                 :             :   OMP_CLAUSE_SEQ,
    1137                 :             :   OMP_CLAUSE_INDEPENDENT,
    1138                 :             :   OMP_CLAUSE_USE_DEVICE,
    1139                 :             :   OMP_CLAUSE_DEVICE_RESIDENT,
    1140                 :             :   OMP_CLAUSE_SELF,
    1141                 :             :   OMP_CLAUSE_HOST,
    1142                 :             :   OMP_CLAUSE_WAIT,
    1143                 :             :   OMP_CLAUSE_DELETE,
    1144                 :             :   OMP_CLAUSE_AUTO,
    1145                 :             :   OMP_CLAUSE_TILE,
    1146                 :             :   OMP_CLAUSE_IF_PRESENT,
    1147                 :             :   OMP_CLAUSE_FINALIZE,
    1148                 :             :   OMP_CLAUSE_ATTACH,
    1149                 :             :   OMP_CLAUSE_NOHOST,
    1150                 :             :   OMP_CLAUSE_HAS_DEVICE_ADDR,  /* OpenMP 5.1  */
    1151                 :             :   OMP_CLAUSE_ENTER, /* OpenMP 5.2 */
    1152                 :             :   OMP_CLAUSE_DOACROSS, /* OpenMP 5.2 */
    1153                 :             :   OMP_CLAUSE_ASSUMPTIONS, /* OpenMP 5.1. */
    1154                 :             :   OMP_CLAUSE_USES_ALLOCATORS, /* OpenMP 5.0  */
    1155                 :             :   OMP_CLAUSE_INDIRECT, /* OpenMP 5.1  */
    1156                 :             :   OMP_CLAUSE_FULL,  /* OpenMP 5.1.  */
    1157                 :             :   OMP_CLAUSE_PARTIAL,  /* OpenMP 5.1.  */
    1158                 :             :   OMP_CLAUSE_SIZES,  /* OpenMP 5.1.  */
    1159                 :             :   OMP_CLAUSE_INIT,  /* OpenMP 5.1.  */
    1160                 :             :   OMP_CLAUSE_DESTROY,  /* OpenMP 5.1.  */
    1161                 :             :   OMP_CLAUSE_USE,  /* OpenMP 5.1.  */
    1162                 :             :   OMP_CLAUSE_NOVARIANTS, /* OpenMP 5.1  */
    1163                 :             :   OMP_CLAUSE_NOCONTEXT, /* OpenMP 5.1  */
    1164                 :             :   OMP_CLAUSE_INTEROP, /* OpenMP 5.1  */
    1165                 :             :   /* This must come last.  */
    1166                 :             :   OMP_MASK2_LAST
    1167                 :             : };
    1168                 :             : 
    1169                 :             : struct omp_inv_mask;
    1170                 :             : 
    1171                 :             : /* Customized bitset for up to 128-bits.
    1172                 :             :    The two enums above provide bit numbers to use, and which of the
    1173                 :             :    two enums it is determines which of the two mask fields is used.
    1174                 :             :    Supported operations are defining a mask, like:
    1175                 :             :    #define XXX_CLAUSES \
    1176                 :             :      (omp_mask (OMP_CLAUSE_XXX) | OMP_CLAUSE_YYY | OMP_CLAUSE_ZZZ)
    1177                 :             :    oring such bitsets together or removing selected bits:
    1178                 :             :    (XXX_CLAUSES | YYY_CLAUSES) & ~(omp_mask (OMP_CLAUSE_VVV))
    1179                 :             :    and testing individual bits:
    1180                 :             :    if (mask & OMP_CLAUSE_UUU)  */
    1181                 :             : 
    1182                 :             : struct omp_mask {
    1183                 :             :   const uint64_t mask1;
    1184                 :             :   const uint64_t mask2;
    1185                 :             :   inline omp_mask ();
    1186                 :             :   inline omp_mask (omp_mask1);
    1187                 :             :   inline omp_mask (omp_mask2);
    1188                 :             :   inline omp_mask (uint64_t, uint64_t);
    1189                 :             :   inline omp_mask operator| (omp_mask1) const;
    1190                 :             :   inline omp_mask operator| (omp_mask2) const;
    1191                 :             :   inline omp_mask operator| (omp_mask) const;
    1192                 :             :   inline omp_mask operator& (const omp_inv_mask &) const;
    1193                 :             :   inline bool operator& (omp_mask1) const;
    1194                 :             :   inline bool operator& (omp_mask2) const;
    1195                 :             :   inline omp_inv_mask operator~ () const;
    1196                 :             : };
    1197                 :             : 
    1198                 :             : struct omp_inv_mask : public omp_mask {
    1199                 :             :   inline omp_inv_mask (const omp_mask &);
    1200                 :             : };
    1201                 :             : 
    1202                 :             : omp_mask::omp_mask () : mask1 (0), mask2 (0)
    1203                 :             : {
    1204                 :             : }
    1205                 :             : 
    1206                 :       31348 : omp_mask::omp_mask (omp_mask1 m) : mask1 (((uint64_t) 1) << m), mask2 (0)
    1207                 :             : {
    1208                 :             : }
    1209                 :             : 
    1210                 :        2163 : omp_mask::omp_mask (omp_mask2 m) : mask1 (0), mask2 (((uint64_t) 1) << m)
    1211                 :             : {
    1212                 :             : }
    1213                 :             : 
    1214                 :       32069 : omp_mask::omp_mask (uint64_t m1, uint64_t m2) : mask1 (m1), mask2 (m2)
    1215                 :             : {
    1216                 :             : }
    1217                 :             : 
    1218                 :             : omp_mask
    1219                 :       31118 : omp_mask::operator| (omp_mask1 m) const
    1220                 :             : {
    1221                 :       31118 :   return omp_mask (mask1 | (((uint64_t) 1) << m), mask2);
    1222                 :             : }
    1223                 :             : 
    1224                 :             : omp_mask
    1225                 :       16287 : omp_mask::operator| (omp_mask2 m) const
    1226                 :             : {
    1227                 :       16287 :   return omp_mask (mask1, mask2 | (((uint64_t) 1) << m));
    1228                 :             : }
    1229                 :             : 
    1230                 :             : omp_mask
    1231                 :        4336 : omp_mask::operator| (omp_mask m) const
    1232                 :             : {
    1233                 :        4336 :   return omp_mask (mask1 | m.mask1, mask2 | m.mask2);
    1234                 :             : }
    1235                 :             : 
    1236                 :             : omp_mask
    1237                 :        1998 : omp_mask::operator& (const omp_inv_mask &m) const
    1238                 :             : {
    1239                 :        1998 :   return omp_mask (mask1 & ~m.mask1, mask2 & ~m.mask2);
    1240                 :             : }
    1241                 :             : 
    1242                 :             : bool
    1243                 :      122388 : omp_mask::operator& (omp_mask1 m) const
    1244                 :             : {
    1245                 :      122388 :   return (mask1 & (((uint64_t) 1) << m)) != 0;
    1246                 :             : }
    1247                 :             : 
    1248                 :             : bool
    1249                 :       85881 : omp_mask::operator& (omp_mask2 m) const
    1250                 :             : {
    1251                 :       85881 :   return (mask2 & (((uint64_t) 1) << m)) != 0;
    1252                 :             : }
    1253                 :             : 
    1254                 :             : omp_inv_mask
    1255                 :        1998 : omp_mask::operator~ () const
    1256                 :             : {
    1257                 :        1998 :   return omp_inv_mask (*this);
    1258                 :             : }
    1259                 :             : 
    1260                 :        1998 : omp_inv_mask::omp_inv_mask (const omp_mask &m) : omp_mask (m)
    1261                 :             : {
    1262                 :             : }
    1263                 :             : 
    1264                 :             : /* Helper function for OpenACC and OpenMP clauses involving memory
    1265                 :             :    mapping.  */
    1266                 :             : 
    1267                 :             : static bool
    1268                 :        5502 : gfc_match_omp_map_clause (gfc_omp_namelist **list, gfc_omp_map_op map_op,
    1269                 :             :                           bool allow_common, bool allow_derived)
    1270                 :             : {
    1271                 :        5502 :   gfc_omp_namelist **head = NULL;
    1272                 :        5502 :   if (gfc_match_omp_variable_list ("", list, allow_common, NULL, &head, true,
    1273                 :             :                                    allow_derived)
    1274                 :             :       == MATCH_YES)
    1275                 :             :     {
    1276                 :        5493 :       gfc_omp_namelist *n;
    1277                 :       13289 :       for (n = *head; n; n = n->next)
    1278                 :        7796 :         n->u.map.op = map_op;
    1279                 :             :       return true;
    1280                 :             :     }
    1281                 :             : 
    1282                 :             :   return false;
    1283                 :             : }
    1284                 :             : 
    1285                 :             : static match
    1286                 :        1105 : gfc_match_iterator (gfc_namespace **ns, bool permit_var)
    1287                 :             : {
    1288                 :        1105 :   locus old_loc = gfc_current_locus;
    1289                 :             : 
    1290                 :        1105 :   if (gfc_match ("iterator ( ") != MATCH_YES)
    1291                 :             :     return MATCH_NO;
    1292                 :             : 
    1293                 :          77 :   gfc_typespec ts;
    1294                 :          77 :   gfc_symbol *last = NULL;
    1295                 :          77 :   gfc_expr *begin, *end, *step;
    1296                 :          77 :   *ns = gfc_build_block_ns (gfc_current_ns);
    1297                 :          83 :   char name[GFC_MAX_SYMBOL_LEN + 1];
    1298                 :          89 :   while (true)
    1299                 :             :     {
    1300                 :          83 :       locus prev_loc = gfc_current_locus;
    1301                 :          83 :       if (gfc_match_type_spec (&ts) == MATCH_YES
    1302                 :          83 :           && gfc_match (" :: ") == MATCH_YES)
    1303                 :             :         {
    1304                 :           5 :           if (ts.type != BT_INTEGER)
    1305                 :             :             {
    1306                 :           2 :               gfc_error ("Expected INTEGER type at %L", &prev_loc);
    1307                 :           5 :               return MATCH_ERROR;
    1308                 :             :             }
    1309                 :             :           permit_var = false;
    1310                 :             :         }
    1311                 :             :       else
    1312                 :             :         {
    1313                 :          78 :           ts.type = BT_INTEGER;
    1314                 :          78 :           ts.kind = gfc_default_integer_kind;
    1315                 :          78 :           gfc_current_locus = prev_loc;
    1316                 :             :         }
    1317                 :          81 :       prev_loc = gfc_current_locus;
    1318                 :          81 :       if (gfc_match_name (name) != MATCH_YES)
    1319                 :             :         {
    1320                 :           4 :           gfc_error ("Expected identifier at %C");
    1321                 :           4 :           goto failed;
    1322                 :             :         }
    1323                 :          77 :       if (gfc_find_symtree ((*ns)->sym_root, name))
    1324                 :             :         {
    1325                 :           2 :           gfc_error ("Same identifier %qs specified again at %C", name);
    1326                 :           2 :           goto failed;
    1327                 :             :         }
    1328                 :             : 
    1329                 :          75 :       gfc_symbol *sym = gfc_new_symbol (name, *ns);
    1330                 :          75 :       if (last)
    1331                 :           4 :         last->tlink = sym;
    1332                 :             :       else
    1333                 :          71 :         (*ns)->omp_affinity_iterators = sym;
    1334                 :          75 :       last = sym;
    1335                 :          75 :       sym->declared_at = prev_loc;
    1336                 :          75 :       sym->ts = ts;
    1337                 :          75 :       sym->attr.flavor = FL_VARIABLE;
    1338                 :          75 :       sym->attr.artificial = 1;
    1339                 :          75 :       sym->attr.referenced = 1;
    1340                 :          75 :       sym->refs++;
    1341                 :          75 :       gfc_symtree *st = gfc_new_symtree (&(*ns)->sym_root, name);
    1342                 :          75 :       st->n.sym = sym;
    1343                 :             : 
    1344                 :          75 :       prev_loc = gfc_current_locus;
    1345                 :          75 :       if (gfc_match (" = ") != MATCH_YES)
    1346                 :           3 :         goto failed;
    1347                 :          72 :       permit_var = false;
    1348                 :          72 :       begin = end = step = NULL;
    1349                 :          72 :       if (gfc_match ("%e : ", &begin) != MATCH_YES
    1350                 :          72 :           || gfc_match ("%e ", &end) != MATCH_YES)
    1351                 :             :         {
    1352                 :           3 :           gfc_error ("Expected range-specification at %C");
    1353                 :           3 :           gfc_free_expr (begin);
    1354                 :           3 :           gfc_free_expr (end);
    1355                 :           3 :           return MATCH_ERROR;
    1356                 :             :         }
    1357                 :          69 :       if (':' == gfc_peek_ascii_char ())
    1358                 :             :         {
    1359                 :          23 :           if (gfc_match (": %e ", &step) != MATCH_YES)
    1360                 :             :             {
    1361                 :           5 :               gfc_free_expr (begin);
    1362                 :           5 :               gfc_free_expr (end);
    1363                 :           5 :               gfc_free_expr (step);
    1364                 :           5 :               goto failed;
    1365                 :             :             }
    1366                 :             :         }
    1367                 :             : 
    1368                 :          64 :       gfc_expr *e = gfc_get_expr ();
    1369                 :          64 :       e->where = prev_loc;
    1370                 :          64 :       e->expr_type = EXPR_ARRAY;
    1371                 :          64 :       e->ts = ts;
    1372                 :          64 :       e->rank = 1;
    1373                 :          64 :       e->shape = gfc_get_shape (1);
    1374                 :         110 :       mpz_init_set_ui (e->shape[0], step ? 3 : 2);
    1375                 :          64 :       gfc_constructor_append_expr (&e->value.constructor, begin, &begin->where);
    1376                 :          64 :       gfc_constructor_append_expr (&e->value.constructor, end, &end->where);
    1377                 :          64 :       if (step)
    1378                 :          18 :         gfc_constructor_append_expr (&e->value.constructor, step, &step->where);
    1379                 :          64 :       sym->value = e;
    1380                 :             : 
    1381                 :          64 :       if (gfc_match (") ") == MATCH_YES)
    1382                 :             :         break;
    1383                 :           6 :       if (gfc_match (", ") != MATCH_YES)
    1384                 :           0 :         goto failed;
    1385                 :           6 :     }
    1386                 :          58 :   return MATCH_YES;
    1387                 :             : 
    1388                 :          14 : failed:
    1389                 :          14 :   gfc_namespace *prev_ns = NULL;
    1390                 :          14 :   for (gfc_namespace *it = gfc_current_ns->contained; it; it = it->sibling)
    1391                 :             :     {
    1392                 :           0 :       if (it == *ns)
    1393                 :             :         {
    1394                 :           0 :           if (prev_ns)
    1395                 :           0 :             prev_ns->sibling = it->sibling;
    1396                 :             :           else
    1397                 :           0 :             gfc_current_ns->contained = it->sibling;
    1398                 :           0 :           gfc_free_namespace (it);
    1399                 :           0 :           break;
    1400                 :             :         }
    1401                 :           0 :       prev_ns = it;
    1402                 :             :     }
    1403                 :          14 :   *ns = NULL;
    1404                 :          14 :   if (!permit_var)
    1405                 :             :     return MATCH_ERROR;
    1406                 :           4 :   gfc_current_locus = old_loc;
    1407                 :           4 :   return MATCH_NO;
    1408                 :             : }
    1409                 :             : 
    1410                 :             : /* Match target update's to/from( [present:] var-list).  */
    1411                 :             : 
    1412                 :             : static match
    1413                 :        1715 : gfc_match_motion_var_list (const char *str, gfc_omp_namelist **list,
    1414                 :             :                            gfc_omp_namelist ***headp)
    1415                 :             : {
    1416                 :        1715 :   match m = gfc_match (str);
    1417                 :        1715 :   if (m != MATCH_YES)
    1418                 :             :     return m;
    1419                 :             : 
    1420                 :        1715 :   match m_present = gfc_match (" present : ");
    1421                 :             : 
    1422                 :        1715 :   m = gfc_match_omp_variable_list ("", list, false, NULL, headp, true, true);
    1423                 :        1715 :   if (m != MATCH_YES)
    1424                 :             :     return m;
    1425                 :        1715 :   if (m_present == MATCH_YES)
    1426                 :             :     {
    1427                 :           5 :       gfc_omp_namelist *n;
    1428                 :          10 :       for (n = **headp; n; n = n->next)
    1429                 :           5 :         n->u.present_modifier = true;
    1430                 :             :     }
    1431                 :             :   return MATCH_YES;
    1432                 :             : }
    1433                 :             : 
    1434                 :             : /* reduction ( reduction-modifier, reduction-operator : variable-list )
    1435                 :             :    in_reduction ( reduction-operator : variable-list )
    1436                 :             :    task_reduction ( reduction-operator : variable-list )  */
    1437                 :             : 
    1438                 :             : static match
    1439                 :        4350 : gfc_match_omp_clause_reduction (char pc, gfc_omp_clauses *c, bool openacc,
    1440                 :             :                                 bool allow_derived, bool openmp_target = false)
    1441                 :             : {
    1442                 :        4350 :   if (pc == 'r' && gfc_match ("reduction ( ") != MATCH_YES)
    1443                 :             :     return MATCH_NO;
    1444                 :        4350 :   else if (pc == 'i' && gfc_match ("in_reduction ( ") != MATCH_YES)
    1445                 :             :     return MATCH_NO;
    1446                 :        4241 :   else if (pc == 't' && gfc_match ("task_reduction ( ") != MATCH_YES)
    1447                 :             :     return MATCH_NO;
    1448                 :             : 
    1449                 :        4241 :   locus old_loc = gfc_current_locus;
    1450                 :        4241 :   int list_idx = 0;
    1451                 :             : 
    1452                 :        4241 :   if (pc == 'r' && !openacc)
    1453                 :             :     {
    1454                 :        2114 :       if (gfc_match ("inscan") == MATCH_YES)
    1455                 :             :         list_idx = OMP_LIST_REDUCTION_INSCAN;
    1456                 :        2044 :       else if (gfc_match ("task") == MATCH_YES)
    1457                 :             :         list_idx = OMP_LIST_REDUCTION_TASK;
    1458                 :        1940 :       else if (gfc_match ("default") == MATCH_YES)
    1459                 :             :         list_idx = OMP_LIST_REDUCTION;
    1460                 :         230 :       if (list_idx != 0 && gfc_match (", ") != MATCH_YES)
    1461                 :             :         {
    1462                 :           1 :           gfc_error ("Comma expected at %C");
    1463                 :           1 :           gfc_current_locus = old_loc;
    1464                 :           1 :           return MATCH_NO;
    1465                 :             :         }
    1466                 :        2113 :       if (list_idx == 0)
    1467                 :        3828 :         list_idx = OMP_LIST_REDUCTION;
    1468                 :             :     }
    1469                 :        2127 :   else if (pc == 'i')
    1470                 :             :     list_idx = OMP_LIST_IN_REDUCTION;
    1471                 :        2009 :   else if (pc == 't')
    1472                 :             :     list_idx = OMP_LIST_TASK_REDUCTION;
    1473                 :             :   else
    1474                 :        3828 :     list_idx = OMP_LIST_REDUCTION;
    1475                 :             : 
    1476                 :        4240 :   gfc_omp_reduction_op rop = OMP_REDUCTION_NONE;
    1477                 :        4240 :   char buffer[GFC_MAX_SYMBOL_LEN + 3];
    1478                 :        4240 :   if (gfc_match_char ('+') == MATCH_YES)
    1479                 :             :     rop = OMP_REDUCTION_PLUS;
    1480                 :        2222 :   else if (gfc_match_char ('*') == MATCH_YES)
    1481                 :             :     rop = OMP_REDUCTION_TIMES;
    1482                 :        1990 :   else if (gfc_match_char ('-') == MATCH_YES)
    1483                 :             :     rop = OMP_REDUCTION_MINUS;
    1484                 :        1820 :   else if (gfc_match (".and.") == MATCH_YES)
    1485                 :             :     rop = OMP_REDUCTION_AND;
    1486                 :        1714 :   else if (gfc_match (".or.") == MATCH_YES)
    1487                 :             :     rop = OMP_REDUCTION_OR;
    1488                 :         929 :   else if (gfc_match (".eqv.") == MATCH_YES)
    1489                 :             :     rop = OMP_REDUCTION_EQV;
    1490                 :         831 :   else if (gfc_match (".neqv.") == MATCH_YES)
    1491                 :             :     rop = OMP_REDUCTION_NEQV;
    1492                 :         736 :   if (rop != OMP_REDUCTION_NONE)
    1493                 :        3504 :     snprintf (buffer, sizeof buffer, "operator %s",
    1494                 :             :               gfc_op2string ((gfc_intrinsic_op) rop));
    1495                 :         736 :   else if (gfc_match_defined_op_name (buffer + 1, 1) == MATCH_YES)
    1496                 :             :     {
    1497                 :          38 :       buffer[0] = '.';
    1498                 :          38 :       strcat (buffer, ".");
    1499                 :             :     }
    1500                 :         698 :   else if (gfc_match_name (buffer) == MATCH_YES)
    1501                 :             :     {
    1502                 :         697 :       gfc_symbol *sym;
    1503                 :         697 :       const char *n = buffer;
    1504                 :             : 
    1505                 :         697 :       gfc_find_symbol (buffer, NULL, 1, &sym);
    1506                 :         697 :       if (sym != NULL)
    1507                 :             :         {
    1508                 :         216 :           if (sym->attr.intrinsic)
    1509                 :         139 :             n = sym->name;
    1510                 :          77 :           else if ((sym->attr.flavor != FL_UNKNOWN
    1511                 :          75 :                     && sym->attr.flavor != FL_PROCEDURE)
    1512                 :             :                    || sym->attr.external
    1513                 :          75 :                    || sym->attr.generic
    1514                 :          64 :                    || sym->attr.entry
    1515                 :             :                    || sym->attr.result
    1516                 :             :                    || sym->attr.dummy
    1517                 :             :                    || sym->attr.subroutine
    1518                 :             :                    || sym->attr.pointer
    1519                 :          64 :                    || sym->attr.target
    1520                 :             :                    || sym->attr.cray_pointer
    1521                 :          63 :                    || sym->attr.cray_pointee
    1522                 :          63 :                    || (sym->attr.proc != PROC_UNKNOWN
    1523                 :           1 :                        && sym->attr.proc != PROC_INTRINSIC)
    1524                 :          62 :                    || sym->attr.if_source != IFSRC_UNKNOWN
    1525                 :          62 :                    || sym == sym->ns->proc_name)
    1526                 :             :                 {
    1527                 :             :                   sym = NULL;
    1528                 :             :                   n = NULL;
    1529                 :             :                 }
    1530                 :             :               else
    1531                 :          62 :                 n = sym->name;
    1532                 :             :             }
    1533                 :         201 :           if (n == NULL)
    1534                 :             :             rop = OMP_REDUCTION_NONE;
    1535                 :         682 :           else if (strcmp (n, "max") == 0)
    1536                 :             :             rop = OMP_REDUCTION_MAX;
    1537                 :         517 :           else if (strcmp (n, "min") == 0)
    1538                 :             :             rop = OMP_REDUCTION_MIN;
    1539                 :         376 :           else if (strcmp (n, "iand") == 0)
    1540                 :             :             rop = OMP_REDUCTION_IAND;
    1541                 :         321 :           else if (strcmp (n, "ior") == 0)
    1542                 :             :             rop = OMP_REDUCTION_IOR;
    1543                 :         255 :           else if (strcmp (n, "ieor") == 0)
    1544                 :             :             rop = OMP_REDUCTION_IEOR;
    1545                 :             :           if (rop != OMP_REDUCTION_NONE
    1546                 :         477 :               && sym != NULL
    1547                 :             :               && ! sym->attr.intrinsic
    1548                 :         200 :               && ! sym->attr.use_assoc
    1549                 :          61 :               && ((sym->attr.flavor == FL_UNKNOWN
    1550                 :           2 :                    && !gfc_add_flavor (&sym->attr, FL_PROCEDURE,
    1551                 :             :                                               sym->name, NULL))
    1552                 :          61 :                   || !gfc_add_intrinsic (&sym->attr, NULL)))
    1553                 :             :             rop = OMP_REDUCTION_NONE;
    1554                 :             :     }
    1555                 :             :   else
    1556                 :           1 :     buffer[0] = '\0';
    1557                 :        4240 :   gfc_omp_udr *udr = (buffer[0] ? gfc_find_omp_udr (gfc_current_ns, buffer, NULL)
    1558                 :        4240 :                                 : NULL);
    1559                 :        4240 :   gfc_omp_namelist **head = NULL;
    1560                 :        4240 :   if (rop == OMP_REDUCTION_NONE && udr)
    1561                 :         250 :     rop = OMP_REDUCTION_USER;
    1562                 :             : 
    1563                 :        4240 :   if (gfc_match_omp_variable_list (" :", &c->lists[list_idx], false, NULL,
    1564                 :             :                                    &head, openacc, allow_derived) != MATCH_YES)
    1565                 :             :     {
    1566                 :           9 :       gfc_current_locus = old_loc;
    1567                 :           9 :       return MATCH_NO;
    1568                 :             :     }
    1569                 :        4231 :   gfc_omp_namelist *n;
    1570                 :        4231 :   if (rop == OMP_REDUCTION_NONE)
    1571                 :             :     {
    1572                 :           6 :       n = *head;
    1573                 :           6 :       *head = NULL;
    1574                 :           6 :       gfc_error_now ("!$OMP DECLARE REDUCTION %s not found at %L",
    1575                 :             :                      buffer, &old_loc);
    1576                 :           6 :       gfc_free_omp_namelist (n, false, false, false, false);
    1577                 :             :     }
    1578                 :             :   else
    1579                 :        9102 :     for (n = *head; n; n = n->next)
    1580                 :             :       {
    1581                 :        4877 :         n->u.reduction_op = rop;
    1582                 :        4877 :         if (udr)
    1583                 :             :           {
    1584                 :         473 :             n->u2.udr = gfc_get_omp_namelist_udr ();
    1585                 :         473 :             n->u2.udr->udr = udr;
    1586                 :             :           }
    1587                 :        4877 :         if (openmp_target && list_idx == OMP_LIST_IN_REDUCTION)
    1588                 :             :           {
    1589                 :          40 :             gfc_omp_namelist *p = gfc_get_omp_namelist (), **tl;
    1590                 :          40 :             p->sym = n->sym;
    1591                 :          40 :             p->where = n->where;
    1592                 :          40 :             p->u.map.op = OMP_MAP_ALWAYS_TOFROM;
    1593                 :             : 
    1594                 :          40 :             tl = &c->lists[OMP_LIST_MAP];
    1595                 :          52 :             while (*tl)
    1596                 :          12 :               tl = &((*tl)->next);
    1597                 :          40 :             *tl = p;
    1598                 :          40 :             p->next = NULL;
    1599                 :             :           }
    1600                 :             :      }
    1601                 :             :   return MATCH_YES;
    1602                 :             : }
    1603                 :             : 
    1604                 :             : static match
    1605                 :          39 : gfc_omp_absent_contains_clause (gfc_omp_assumptions **assume, bool is_absent)
    1606                 :             : {
    1607                 :          39 :   if (*assume == NULL)
    1608                 :          14 :     *assume = gfc_get_omp_assumptions ();
    1609                 :          61 :   do
    1610                 :             :     {
    1611                 :          50 :       gfc_statement st = ST_NONE;
    1612                 :          50 :       gfc_gobble_whitespace ();
    1613                 :          50 :       locus old_loc = gfc_current_locus;
    1614                 :          50 :       char c = gfc_peek_ascii_char ();
    1615                 :          50 :       enum gfc_omp_directive_kind kind
    1616                 :             :         = GFC_OMP_DIR_DECLARATIVE; /* Silence warning. */
    1617                 :        1490 :       for (size_t i = 0; i < ARRAY_SIZE (gfc_omp_directives); i++)
    1618                 :             :         {
    1619                 :        1490 :           if (gfc_omp_directives[i].name[0] > c)
    1620                 :             :             break;
    1621                 :        1440 :           if (gfc_omp_directives[i].name[0] != c)
    1622                 :        1101 :             continue;
    1623                 :         339 :           if (gfc_match (gfc_omp_directives[i].name) == MATCH_YES)
    1624                 :             :             {
    1625                 :          50 :               st = gfc_omp_directives[i].st;
    1626                 :          50 :               kind = gfc_omp_directives[i].kind;
    1627                 :             :             }
    1628                 :             :         }
    1629                 :          50 :       gfc_gobble_whitespace ();
    1630                 :          50 :       c = gfc_peek_ascii_char ();
    1631                 :          50 :       if (st == ST_NONE || (c != ',' && c != ')'))
    1632                 :             :         {
    1633                 :           0 :           if (st == ST_NONE)
    1634                 :           0 :             gfc_error ("Unknown directive at %L", &old_loc);
    1635                 :             :           else
    1636                 :           0 :             gfc_error ("Invalid combined or composite directive at %L",
    1637                 :             :                        &old_loc);
    1638                 :           3 :           return MATCH_ERROR;
    1639                 :             :         }
    1640                 :          50 :       if (kind == GFC_OMP_DIR_DECLARATIVE
    1641                 :          50 :           || kind == GFC_OMP_DIR_INFORMATIONAL
    1642                 :             :           || kind == GFC_OMP_DIR_META)
    1643                 :             :         {
    1644                 :           3 :           gfc_error ("Invalid %qs directive at %L in %s clause: declarative, "
    1645                 :             :                      "informational, and meta directives not permitted",
    1646                 :             :                      gfc_ascii_statement (st, true), &old_loc,
    1647                 :             :                      is_absent ? "ABSENT" : "CONTAINS");
    1648                 :           3 :           return MATCH_ERROR;
    1649                 :             :         }
    1650                 :          47 :       if (is_absent)
    1651                 :             :         {
    1652                 :             :           /* Use exponential allocation; equivalent to pow2p(x). */
    1653                 :          33 :           int i = (*assume)->n_absent;
    1654                 :          33 :           int size = ((i == 0) ? 4
    1655                 :          10 :                       : pow2p_hwi (i) == 1 ? i*2 : 0);
    1656                 :           8 :           if (size != 0)
    1657                 :          31 :             (*assume)->absent = XRESIZEVEC (gfc_statement,
    1658                 :             :                                             (*assume)->absent, size);
    1659                 :          33 :           (*assume)->absent[(*assume)->n_absent++] = st;
    1660                 :             :         }
    1661                 :             :       else
    1662                 :             :         {
    1663                 :          14 :           int i = (*assume)->n_contains;
    1664                 :          14 :           int size = ((i == 0) ? 4
    1665                 :           4 :                       : pow2p_hwi (i) == 1 ? i*2 : 0);
    1666                 :           4 :           if (size != 0)
    1667                 :          14 :             (*assume)->contains = XRESIZEVEC (gfc_statement,
    1668                 :             :                                               (*assume)->contains, size);
    1669                 :          14 :           (*assume)->contains[(*assume)->n_contains++] = st;
    1670                 :             :         }
    1671                 :          47 :       gfc_gobble_whitespace ();
    1672                 :          47 :       if (gfc_match(",") == MATCH_YES)
    1673                 :          11 :         continue;
    1674                 :          36 :       if (gfc_match(")") == MATCH_YES)
    1675                 :             :         break;
    1676                 :           0 :       gfc_error ("Expected %<,%> or %<)%> at %C");
    1677                 :           0 :       return MATCH_ERROR;
    1678                 :             :     }
    1679                 :             :   while (true);
    1680                 :             : 
    1681                 :          36 :   return MATCH_YES;
    1682                 :             : }
    1683                 :             : 
    1684                 :             : /* Check 'check' argument for duplicated statements in absent and/or contains
    1685                 :             :    clauses. If 'merge', merge them from check to 'merge'.  */
    1686                 :             : 
    1687                 :             : static match
    1688                 :          42 : omp_verify_merge_absent_contains (gfc_statement st, gfc_omp_assumptions *check,
    1689                 :             :                                   gfc_omp_assumptions *merge, locus *loc)
    1690                 :             : {
    1691                 :          42 :   if (check == NULL)
    1692                 :             :     return MATCH_YES;
    1693                 :          42 :   bitmap_head absent_head, contains_head;
    1694                 :          42 :   bitmap_obstack_initialize (NULL);
    1695                 :          42 :   bitmap_initialize (&absent_head, &bitmap_default_obstack);
    1696                 :          42 :   bitmap_initialize (&contains_head, &bitmap_default_obstack);
    1697                 :             : 
    1698                 :          42 :   match m = MATCH_YES;
    1699                 :          75 :   for (int i = 0; i < check->n_absent; i++)
    1700                 :          33 :     if (!bitmap_set_bit (&absent_head, check->absent[i]))
    1701                 :             :       {
    1702                 :           2 :         gfc_error ("%qs directive mentioned multiple times in %s clause in %s "
    1703                 :             :                    "directive at %L",
    1704                 :           2 :                    gfc_ascii_statement (check->absent[i], true),
    1705                 :             :                    "ABSENT", gfc_ascii_statement (st), loc);
    1706                 :           2 :         m = MATCH_ERROR;
    1707                 :             :       }
    1708                 :          56 :   for (int i = 0; i < check->n_contains; i++)
    1709                 :             :     {
    1710                 :          14 :       if (!bitmap_set_bit (&contains_head, check->contains[i]))
    1711                 :             :         {
    1712                 :           2 :           gfc_error ("%qs directive mentioned multiple times in %s clause in %s "
    1713                 :             :                      "directive at %L",
    1714                 :           2 :                      gfc_ascii_statement (check->contains[i], true),
    1715                 :             :                      "CONTAINS", gfc_ascii_statement (st), loc);
    1716                 :           2 :           m = MATCH_ERROR;
    1717                 :             :         }
    1718                 :          14 :       if (bitmap_bit_p (&absent_head, check->contains[i]))
    1719                 :             :         {
    1720                 :           2 :           gfc_error ("%qs directive mentioned both times in ABSENT and CONTAINS "
    1721                 :             :                      "clauses in %s directive at %L",
    1722                 :           2 :                      gfc_ascii_statement (check->absent[i], true),
    1723                 :             :                      gfc_ascii_statement (st), loc);
    1724                 :           2 :           m = MATCH_ERROR;
    1725                 :             :         }
    1726                 :             :     }
    1727                 :             : 
    1728                 :          42 :   if (m == MATCH_ERROR)
    1729                 :             :     return MATCH_ERROR;
    1730                 :          36 :   if (merge == NULL)
    1731                 :             :     return MATCH_YES;
    1732                 :           2 :   if (merge->absent == NULL && check->absent)
    1733                 :             :     {
    1734                 :           1 :       merge->n_absent = check->n_absent;
    1735                 :           1 :       merge->absent = check->absent;
    1736                 :           1 :       check->absent = NULL;
    1737                 :             :     }
    1738                 :           1 :   else if (merge->absent && check->absent)
    1739                 :             :     {
    1740                 :           0 :       check->absent = XRESIZEVEC (gfc_statement, check->absent,
    1741                 :             :                                   merge->n_absent + check->n_absent);
    1742                 :           0 :       for (int i = 0; i < merge->n_absent; i++)
    1743                 :           0 :         if (!bitmap_bit_p (&absent_head, merge->absent[i]))
    1744                 :           0 :           check->absent[check->n_absent++] = merge->absent[i];
    1745                 :           0 :       free (merge->absent);
    1746                 :           0 :       merge->absent = check->absent;
    1747                 :           0 :       merge->n_absent = check->n_absent;
    1748                 :           0 :       check->absent = NULL;
    1749                 :             :     }
    1750                 :           2 :   if (merge->contains == NULL && check->contains)
    1751                 :             :     {
    1752                 :           0 :       merge->n_contains = check->n_contains;
    1753                 :           0 :       merge->contains = check->contains;
    1754                 :           0 :       check->contains = NULL;
    1755                 :             :     }
    1756                 :           2 :   else if (merge->contains && check->contains)
    1757                 :             :     {
    1758                 :           0 :       check->contains = XRESIZEVEC (gfc_statement, check->contains,
    1759                 :             :                                     merge->n_contains + check->n_contains);
    1760                 :           0 :       for (int i = 0; i < merge->n_contains; i++)
    1761                 :           0 :         if (!bitmap_bit_p (&contains_head, merge->contains[i]))
    1762                 :           0 :           check->contains[check->n_contains++] = merge->contains[i];
    1763                 :           0 :       free (merge->contains);
    1764                 :           0 :       merge->contains = check->contains;
    1765                 :           0 :       merge->n_contains = check->n_contains;
    1766                 :           0 :       check->contains = NULL;
    1767                 :             :     }
    1768                 :             :   return MATCH_YES;
    1769                 :             : }
    1770                 :             : 
    1771                 :             : /* OpenMP 5.0
    1772                 :             :    uses_allocators ( allocator-list )
    1773                 :             : 
    1774                 :             :    allocator:
    1775                 :             :      predefined-allocator
    1776                 :             :      variable ( traits-array )
    1777                 :             : 
    1778                 :             :    OpenMP 5.2:
    1779                 :             :    uses_allocators ( [modifier-list :] allocator-list )
    1780                 :             : 
    1781                 :             :    allocator:
    1782                 :             :      variable or predefined-allocator
    1783                 :             :    modifier:
    1784                 :             :      traits ( traits-array )
    1785                 :             :      memspace ( mem-space-handle )  */
    1786                 :             : 
    1787                 :             : static match
    1788                 :          47 : gfc_match_omp_clause_uses_allocators (gfc_omp_clauses *c)
    1789                 :             : {
    1790                 :          47 :   gfc_symbol *memspace_sym = NULL;
    1791                 :          47 :   gfc_symbol *traits_sym = NULL;
    1792                 :          47 :   gfc_omp_namelist *head = NULL;
    1793                 :          47 :   gfc_omp_namelist *p, *tail, **list;
    1794                 :          47 :   int ntraits, nmemspace;
    1795                 :          47 :   bool has_modifiers;
    1796                 :          47 :   locus old_loc, cur_loc;
    1797                 :             : 
    1798                 :          47 :   gfc_gobble_whitespace ();
    1799                 :          47 :   old_loc = gfc_current_locus;
    1800                 :          47 :   ntraits = nmemspace = 0;
    1801                 :          77 :   do
    1802                 :             :     {
    1803                 :          62 :       cur_loc = gfc_current_locus;
    1804                 :          62 :       if (gfc_match ("traits ( %S ) ", &traits_sym) == MATCH_YES)
    1805                 :          21 :         ntraits++;
    1806                 :          41 :       else if (gfc_match ("memspace ( %S ) ", &memspace_sym) == MATCH_YES)
    1807                 :          21 :         nmemspace++;
    1808                 :          62 :       if (ntraits > 1 || nmemspace > 1)
    1809                 :             :         {
    1810                 :           2 :           gfc_error ("Duplicate %s modifier at %L in USES_ALLOCATORS clause",
    1811                 :             :                      ntraits > 1 ? "TRAITS" : "MEMSPACE", &cur_loc);
    1812                 :           2 :           return MATCH_ERROR;
    1813                 :             :         }
    1814                 :          60 :       if (gfc_match (", ") == MATCH_YES)
    1815                 :          15 :         continue;
    1816                 :          45 :       if (gfc_match (": ") != MATCH_YES)
    1817                 :             :         {
    1818                 :             :           /* Assume no modifier. */
    1819                 :          22 :           memspace_sym = traits_sym = NULL;
    1820                 :          22 :           gfc_current_locus = old_loc;
    1821                 :          22 :           break;
    1822                 :             :         }
    1823                 :             :       break;
    1824                 :             :     } while (true);
    1825                 :             : 
    1826                 :          68 :   has_modifiers = traits_sym != NULL || memspace_sym != NULL;
    1827                 :         127 :   do
    1828                 :             :     {
    1829                 :          86 :       p = gfc_get_omp_namelist ();
    1830                 :          86 :       p->where = gfc_current_locus;
    1831                 :          86 :       if (head == NULL)
    1832                 :             :         head = tail = p;
    1833                 :             :       else
    1834                 :             :         {
    1835                 :          41 :           tail->next = p;
    1836                 :          41 :           tail = tail->next;
    1837                 :             :         }
    1838                 :          86 :       if (gfc_match ("%S ", &p->sym) != MATCH_YES)
    1839                 :           0 :         goto error;
    1840                 :          86 :       if (!has_modifiers)
    1841                 :          58 :         gfc_match ("( %S ) ", &p->u2.traits_sym);
    1842                 :          28 :       else if (gfc_peek_ascii_char () == '(')
    1843                 :             :         {
    1844                 :           0 :           gfc_error ("Unexpected %<(%> at %C");
    1845                 :           0 :           goto error;
    1846                 :             :         }
    1847                 :             :       else
    1848                 :             :         {
    1849                 :          28 :           p->u.memspace_sym = memspace_sym;
    1850                 :          28 :           p->u2.traits_sym = traits_sym;
    1851                 :             :         }
    1852                 :          86 :       if (gfc_match (", ") == MATCH_YES)
    1853                 :          41 :         continue;
    1854                 :          45 :       if (gfc_match (") ") == MATCH_YES)
    1855                 :             :         break;
    1856                 :           2 :       goto error;
    1857                 :             :     } while (true);
    1858                 :             : 
    1859                 :          43 :   list = &c->lists[OMP_LIST_USES_ALLOCATORS];
    1860                 :          48 :   while (*list)
    1861                 :           5 :     list = &(*list)->next;
    1862                 :          43 :   *list = head;
    1863                 :             : 
    1864                 :          43 :   return MATCH_YES;
    1865                 :             : 
    1866                 :           2 : error:
    1867                 :           2 :   gfc_free_omp_namelist (head, false, false, true, false);
    1868                 :           2 :   return MATCH_ERROR;
    1869                 :             : }
    1870                 :             : 
    1871                 :             : 
    1872                 :             : /* Match the 'prefer_type' modifier of the interop 'init' clause:
    1873                 :             :    with either OpenMP 5.1's
    1874                 :             :      prefer_type ( <const-int-expr|string literal> [, ...]
    1875                 :             :    or
    1876                 :             :      prefer_type ( '{' <fr(...) | attr (...)>, ...] '}' [, '{' ... '}' ] )
    1877                 :             :    where 'fr' takes a constant expression or a string literal
    1878                 :             :    and 'attr takes a list of string literals, starting with 'ompx_')
    1879                 :             : 
    1880                 :             :    For the foreign runtime identifiers, string values are converted to
    1881                 :             :    their integer value; unknown string or integer values are set to
    1882                 :             :    GOMP_INTEROP_IFR_KNOWN.
    1883                 :             : 
    1884                 :             :    Data format:
    1885                 :             :     For the foreign runtime identifiers, string values are converted to
    1886                 :             :     their integer value; unknown string or integer values are set to 0.
    1887                 :             : 
    1888                 :             :     Each item (a) GOMP_INTEROP_IFR_SEPARATOR
    1889                 :             :               (b) for any 'fr', its integer value.
    1890                 :             :                   Note: Spec only permits 1 'fr' entry (6.0; changed after TR13)
    1891                 :             :               (c) GOMP_INTEROP_IFR_SEPARATOR
    1892                 :             :               (d) list of \0-terminated non-empty strings for 'attr'
    1893                 :             :               (e) '\0'
    1894                 :             :     Tailing '\0'.  */
    1895                 :             : 
    1896                 :             : static match
    1897                 :          82 : gfc_match_omp_prefer_type (char **type_str, int *type_str_len)
    1898                 :             : {
    1899                 :          82 :   gfc_expr *e;
    1900                 :          82 :   std::string type_string, attr_string;
    1901                 :             :   /* New syntax.  */
    1902                 :          82 :   if (gfc_peek_ascii_char () == '{')
    1903                 :         115 :     do
    1904                 :             :       {
    1905                 :          85 :         attr_string.clear ();
    1906                 :          85 :         type_string += (char) GOMP_INTEROP_IFR_SEPARATOR;
    1907                 :          85 :         if (gfc_match ("{ ") != MATCH_YES)
    1908                 :             :           {
    1909                 :           1 :             gfc_error ("Expected %<{%> at %C");
    1910                 :           1 :             return MATCH_ERROR;
    1911                 :             :           }
    1912                 :             :         bool fr_found = false;
    1913                 :         148 :         do
    1914                 :             :           {
    1915                 :         116 :             if (gfc_match ("fr ( ") == MATCH_YES)
    1916                 :             :               {
    1917                 :          62 :                 if (fr_found)
    1918                 :             :                   {
    1919                 :           1 :                     gfc_error ("Duplicated %<fr%> preference-selector-name "
    1920                 :             :                                "at %C");
    1921                 :           1 :                     return MATCH_ERROR;
    1922                 :             :                   }
    1923                 :          61 :                 fr_found = true;
    1924                 :          61 :                 do
    1925                 :             :                   {
    1926                 :          61 :                     bool found_literal = false;
    1927                 :          61 :                     match m = MATCH_YES;
    1928                 :          61 :                     if (gfc_match_literal_constant (&e, false) == MATCH_YES)
    1929                 :             :                       found_literal = true;
    1930                 :             :                     else
    1931                 :          12 :                       m = gfc_match_expr (&e);
    1932                 :          12 :                     if (m != MATCH_YES
    1933                 :          61 :                         || !gfc_resolve_expr (e)
    1934                 :          61 :                         || e->rank != 0
    1935                 :          60 :                         || e->expr_type != EXPR_CONSTANT
    1936                 :          59 :                         || (e->ts.type != BT_INTEGER
    1937                 :          43 :                             && (!found_literal || e->ts.type != BT_CHARACTER))
    1938                 :          58 :                         || (e->ts.type == BT_INTEGER
    1939                 :          16 :                             && !mpz_fits_sint_p (e->value.integer))
    1940                 :          70 :                         || (e->ts.type == BT_CHARACTER
    1941                 :          42 :                             && (e->ts.kind != gfc_default_character_kind
    1942                 :          41 :                         || e->value.character.length == 0)))
    1943                 :             :                       {
    1944                 :           5 :                         gfc_error ("Expected constant scalar integer expression"
    1945                 :             :                                    " or non-empty default-kind character "
    1946                 :           5 :                                    "literal at %L", &e->where);
    1947                 :           5 :                         gfc_free_expr (e);
    1948                 :           5 :                         return MATCH_ERROR;
    1949                 :             :                       }
    1950                 :          56 :                     gfc_gobble_whitespace ();
    1951                 :          56 :                     int val;
    1952                 :          56 :                     if (e->ts.type == BT_INTEGER)
    1953                 :             :                       {
    1954                 :          16 :                         val = mpz_get_si (e->value.integer);
    1955                 :          16 :                         if (val < 1 || val > GOMP_INTEROP_IFR_LAST)
    1956                 :             :                           {
    1957                 :           0 :                             gfc_warning_now (OPT_Wopenmp,
    1958                 :             :                                              "Unknown foreign runtime "
    1959                 :             :                                              "identifier %qd at %L",
    1960                 :             :                                              val, &e->where);
    1961                 :           0 :                             val = GOMP_INTEROP_IFR_UNKNOWN;
    1962                 :             :                           }
    1963                 :             :                       }
    1964                 :             :                     else
    1965                 :             :                       {
    1966                 :          40 :                         char *str = XALLOCAVEC (char,
    1967                 :             :                                                 e->value.character.length+1);
    1968                 :         229 :                         for (int i = 0; i < e->value.character.length + 1; i++)
    1969                 :         189 :                           str[i] = e->value.character.string[i];
    1970                 :          40 :                         if (memchr (str, '\0', e->value.character.length) != 0)
    1971                 :             :                           {
    1972                 :           0 :                             gfc_error ("Unexpected null character in character "
    1973                 :             :                                        "literal at %L", &e->where);
    1974                 :           0 :                             return MATCH_ERROR;
    1975                 :             :                           }
    1976                 :          40 :                         val = omp_get_fr_id_from_name (str);
    1977                 :          40 :                         if (val == GOMP_INTEROP_IFR_UNKNOWN)
    1978                 :           2 :                           gfc_warning_now (OPT_Wopenmp,
    1979                 :             :                                            "Unknown foreign runtime identifier "
    1980                 :           2 :                                            "%qs at %L", str, &e->where);
    1981                 :             :                       }
    1982                 :             : 
    1983                 :          56 :                     type_string += (char) val;
    1984                 :          56 :                     if (gfc_match (") ") == MATCH_YES)
    1985                 :             :                       break;
    1986                 :           4 :                     gfc_error ("Expected %<)%> at %C");
    1987                 :           4 :                     return MATCH_ERROR;
    1988                 :             :                   }
    1989                 :             :                 while (true);
    1990                 :             :               }
    1991                 :          54 :             else if (gfc_match ("attr ( ") == MATCH_YES)
    1992                 :             :               {
    1993                 :          60 :                 do
    1994                 :             :                   {
    1995                 :          57 :                     if (gfc_match_literal_constant (&e, false) != MATCH_YES
    1996                 :          56 :                         || !gfc_resolve_expr (e)
    1997                 :          56 :                         || e->expr_type != EXPR_CONSTANT
    1998                 :          56 :                         || e->rank != 0
    1999                 :          56 :                         || e->ts.type != BT_CHARACTER
    2000                 :         113 :                         || e->ts.kind != gfc_default_character_kind)
    2001                 :             :                       {
    2002                 :           1 :                         gfc_error ("Expected default-kind character literal "
    2003                 :           1 :                                    "at %L", &e->where);
    2004                 :           1 :                         gfc_free_expr (e);
    2005                 :           1 :                         return MATCH_ERROR;
    2006                 :             :                       }
    2007                 :          56 :                     gfc_gobble_whitespace ();
    2008                 :          56 :                     char *str = XALLOCAVEC (char, e->value.character.length+1);
    2009                 :         564 :                     for (int i = 0; i < e->value.character.length + 1; i++)
    2010                 :         508 :                       str[i] = e->value.character.string[i];
    2011                 :          56 :                     if (!startswith (str, "ompx_"))
    2012                 :             :                       {
    2013                 :           1 :                         gfc_error ("Character literal at %L must start with "
    2014                 :             :                                    "%<ompx_%>", &e->where);
    2015                 :           1 :                         gfc_free_expr (e);
    2016                 :           1 :                         return MATCH_ERROR;
    2017                 :             :                       }
    2018                 :          55 :                     if (memchr (str, '\0', e->value.character.length) != 0
    2019                 :          55 :                         || memchr (str, ',', e->value.character.length) != 0)
    2020                 :             :                       {
    2021                 :           1 :                         gfc_error ("Unexpected null or %<,%> character in "
    2022                 :             :                                    "character literal at %L", &e->where);
    2023                 :           1 :                         return MATCH_ERROR;
    2024                 :             :                       }
    2025                 :          54 :                     attr_string += str;
    2026                 :          54 :                     attr_string += '\0';
    2027                 :          54 :                     if (gfc_match (", ") == MATCH_YES)
    2028                 :           3 :                       continue;
    2029                 :          51 :                     if (gfc_match (") ") == MATCH_YES)
    2030                 :             :                       break;
    2031                 :           0 :                     gfc_error ("Expected %<,%> or %<)%> at %C");
    2032                 :           0 :                     return MATCH_ERROR;
    2033                 :           3 :                   }
    2034                 :             :                 while (true);
    2035                 :             :               }
    2036                 :             :             else
    2037                 :             :               {
    2038                 :           0 :                 gfc_error ("Expected %<fr(%> or %<attr(%> at %C");
    2039                 :           0 :                 return MATCH_ERROR;
    2040                 :             :               }
    2041                 :         103 :             if (gfc_match (", ") == MATCH_YES)
    2042                 :          32 :               continue;
    2043                 :          71 :             if (gfc_match ("} ") == MATCH_YES)
    2044                 :             :               break;
    2045                 :           2 :             gfc_error ("Expected %<,%> or %<}%> at %C");
    2046                 :           2 :             return MATCH_ERROR;
    2047                 :          32 :           }
    2048                 :             :         while (true);
    2049                 :          69 :         type_string += (char) GOMP_INTEROP_IFR_SEPARATOR;
    2050                 :          69 :         type_string += attr_string;
    2051                 :          69 :         type_string += '\0';
    2052                 :          69 :         if (gfc_match (", ") == MATCH_YES)
    2053                 :          30 :           continue;
    2054                 :          39 :         if (gfc_match (") ") == MATCH_YES)
    2055                 :             :           break;
    2056                 :           1 :         gfc_error ("Expected %<,%> or %<)%> at %C");
    2057                 :           1 :         return MATCH_ERROR;
    2058                 :          30 :       }
    2059                 :             :     while (true);
    2060                 :             :   else
    2061                 :          75 :     do
    2062                 :             :       {
    2063                 :          51 :         type_string += (char) GOMP_INTEROP_IFR_SEPARATOR;
    2064                 :          51 :         bool found_literal = false;
    2065                 :          51 :         match m = MATCH_YES;
    2066                 :          51 :         if (gfc_match_literal_constant (&e, false) == MATCH_YES)
    2067                 :             :           found_literal = true;
    2068                 :             :         else
    2069                 :          19 :           m = gfc_match_expr (&e);
    2070                 :          19 :         if (m != MATCH_YES
    2071                 :          51 :             || !gfc_resolve_expr (e)
    2072                 :          51 :             || e->rank != 0
    2073                 :          50 :             || e->expr_type != EXPR_CONSTANT
    2074                 :          49 :             || (e->ts.type != BT_INTEGER
    2075                 :          28 :                 && (!found_literal || e->ts.type != BT_CHARACTER))
    2076                 :          48 :             || (e->ts.type == BT_INTEGER
    2077                 :          21 :                 && !mpz_fits_sint_p (e->value.integer))
    2078                 :          67 :             || (e->ts.type == BT_CHARACTER
    2079                 :          27 :                 && (e->ts.kind != gfc_default_character_kind
    2080                 :          27 :                     || e->value.character.length == 0)))
    2081                 :             :           {
    2082                 :           3 :             gfc_error ("Expected constant scalar integer expression or "
    2083                 :           3 :                        "non-empty default-kind character literal at %L", &e->where);
    2084                 :           3 :             gfc_free_expr (e);
    2085                 :           3 :             return MATCH_ERROR;
    2086                 :             :           }
    2087                 :          48 :         gfc_gobble_whitespace ();
    2088                 :          48 :         int val;
    2089                 :          48 :         if (e->ts.type == BT_INTEGER)
    2090                 :             :           {
    2091                 :          21 :             val = mpz_get_si (e->value.integer);
    2092                 :          21 :             if (val < 1 || val > GOMP_INTEROP_IFR_LAST)
    2093                 :             :               {
    2094                 :           3 :                 gfc_warning_now (OPT_Wopenmp,
    2095                 :             :                                  "Unknown foreign runtime identifier %qd at %L",
    2096                 :             :                                  val, &e->where);
    2097                 :           3 :                 val = 0;
    2098                 :             :               }
    2099                 :             :           }
    2100                 :             :         else
    2101                 :             :           {
    2102                 :          27 :             char *str = XALLOCAVEC (char, e->value.character.length+1);
    2103                 :         169 :             for (int i = 0; i < e->value.character.length + 1; i++)
    2104                 :         142 :               str[i] = e->value.character.string[i];
    2105                 :          27 :             if (memchr (str, '\0', e->value.character.length) != 0)
    2106                 :             :               {
    2107                 :           0 :                 gfc_error ("Unexpected null character in character "
    2108                 :             :                            "literal at %L", &e->where);
    2109                 :           0 :                 return MATCH_ERROR;
    2110                 :             :               }
    2111                 :          27 :             val = omp_get_fr_id_from_name (str);
    2112                 :          27 :             if (val == GOMP_INTEROP_IFR_UNKNOWN)
    2113                 :           5 :               gfc_warning_now (OPT_Wopenmp,
    2114                 :             :                                "Unknown foreign runtime identifier %qs at %L",
    2115                 :           5 :                                str, &e->where);
    2116                 :             :           }
    2117                 :          48 :         type_string += (char) val;
    2118                 :          48 :         type_string += (char) GOMP_INTEROP_IFR_SEPARATOR;
    2119                 :          48 :         type_string += '\0';
    2120                 :          48 :         gfc_free_expr (e);
    2121                 :          48 :         if (gfc_match (", ") == MATCH_YES)
    2122                 :          24 :           continue;
    2123                 :          24 :         if (gfc_match (") ") == MATCH_YES)
    2124                 :             :           break;
    2125                 :           2 :         gfc_error ("Expected %<,%> or %<)%> at %C");
    2126                 :           2 :         return MATCH_ERROR;
    2127                 :          24 :       }
    2128                 :             :     while (true);
    2129                 :          60 :   type_string += '\0';
    2130                 :          60 :   *type_str_len = type_string.length();
    2131                 :          60 :   *type_str = XNEWVEC (char, type_string.length ());
    2132                 :          60 :   memcpy (*type_str, type_string.data (), type_string.length ());
    2133                 :          60 :   return MATCH_YES;
    2134                 :          82 : }
    2135                 :             : 
    2136                 :             : 
    2137                 :             : /* Match OpenMP 5.1's 'init'-clause modifiers, used by the 'init' clause of
    2138                 :             :    the 'interop' directive and the 'append_args' directive of 'declare variant'.
    2139                 :             :      [prefer_type(...)][,][<target|targetsync>, ...])
    2140                 :             : 
    2141                 :             :    If is_init_clause, the modifier parsing ends with a ':'.
    2142                 :             :    If not is_init_clause (i.e. append_args), the parsing ends with ')'.  */
    2143                 :             : 
    2144                 :             : static match
    2145                 :         164 : gfc_parser_omp_clause_init_modifiers (bool &target, bool &targetsync,
    2146                 :             :                                       char **type_str, int &type_str_len,
    2147                 :             :                                       bool is_init_clause)
    2148                 :             : {
    2149                 :         164 :   target = false;
    2150                 :         164 :   targetsync = false;
    2151                 :         164 :   *type_str = NULL;
    2152                 :         164 :   type_str_len = 0;
    2153                 :         286 :   match m;
    2154                 :             : 
    2155                 :         286 :   do
    2156                 :             :     {
    2157                 :         286 :       if (gfc_match ("prefer_type ( ") == MATCH_YES)
    2158                 :             :         {
    2159                 :          83 :           if (*type_str)
    2160                 :             :             {
    2161                 :           1 :               gfc_error ("Duplicate %<prefer_type%> modifier at %C");
    2162                 :           1 :               return MATCH_ERROR;
    2163                 :             :             }
    2164                 :          82 :           m = gfc_match_omp_prefer_type (type_str, &type_str_len);
    2165                 :          82 :           if (m != MATCH_YES)
    2166                 :             :             return m;
    2167                 :          60 :           if (gfc_match (", ") == MATCH_YES)
    2168                 :          14 :             continue;
    2169                 :          46 :           if (is_init_clause)
    2170                 :             :             {
    2171                 :          24 :               if (gfc_match (": ") == MATCH_YES)
    2172                 :             :                 break;
    2173                 :           0 :               gfc_error ("Expected %<,%> or %<:%> at %C");
    2174                 :             :             }
    2175                 :             :           else
    2176                 :             :             {
    2177                 :          22 :               if (gfc_match (") ") == MATCH_YES)
    2178                 :             :                 break;
    2179                 :           0 :               gfc_error ("Expected %<,%> or %<)%> at %C");
    2180                 :             :             }
    2181                 :           0 :           return MATCH_ERROR;
    2182                 :             :         }
    2183                 :             : 
    2184                 :         203 :       if (gfc_match ("prefer_type ") == MATCH_YES)
    2185                 :             :         {
    2186                 :           2 :           gfc_error ("Expected %<(%> after %<prefer_type%> at %C");
    2187                 :           2 :           return MATCH_ERROR;
    2188                 :             :         }
    2189                 :             : 
    2190                 :         201 :       if (gfc_match ("targetsync ") == MATCH_YES)
    2191                 :             :         {
    2192                 :          57 :           if (targetsync)
    2193                 :             :             {
    2194                 :           3 :               gfc_error ("Duplicate %<targetsync%> at %C");
    2195                 :           3 :               return MATCH_ERROR;
    2196                 :             :             }
    2197                 :          54 :           targetsync = true;
    2198                 :          54 :           if (gfc_match (", ") == MATCH_YES)
    2199                 :          13 :             continue;
    2200                 :          41 :           if (!is_init_clause)
    2201                 :             :             {
    2202                 :          23 :               if (gfc_match (") ") == MATCH_YES)
    2203                 :             :                 break;
    2204                 :           0 :               gfc_error ("Expected %<,%> or %<)%> at %C");
    2205                 :           0 :               return MATCH_ERROR;
    2206                 :             :             }
    2207                 :          18 :           if (gfc_match (": ") == MATCH_YES)
    2208                 :             :             break;
    2209                 :           1 :           gfc_error ("Expected %<,%> or %<:%> at %C");
    2210                 :           1 :           return MATCH_ERROR;
    2211                 :             :         }
    2212                 :         144 :       if (gfc_match ("target ") == MATCH_YES)
    2213                 :             :         {
    2214                 :         135 :           if (target)
    2215                 :             :             {
    2216                 :           3 :               gfc_error ("Duplicate %<target%> at %C");
    2217                 :           3 :               return MATCH_ERROR;
    2218                 :             :             }
    2219                 :         132 :           target = true;
    2220                 :         132 :           if (gfc_match (", ") == MATCH_YES)
    2221                 :          95 :             continue;
    2222                 :          37 :           if (!is_init_clause)
    2223                 :             :             {
    2224                 :          11 :               if (gfc_match (") ") == MATCH_YES)
    2225                 :             :                 break;
    2226                 :           0 :               gfc_error ("Expected %<,%> or %<)%> at %C");
    2227                 :           0 :               return MATCH_ERROR;
    2228                 :             :             }
    2229                 :          26 :           if (gfc_match (": ") == MATCH_YES)
    2230                 :             :             break;
    2231                 :           1 :           gfc_error ("Expected %<,%> or %<:%> at %C");
    2232                 :           1 :           return MATCH_ERROR;
    2233                 :             :         }
    2234                 :           9 :       gfc_error ("Expected %<prefer_type%>, %<target%>, or %<targetsync%> "
    2235                 :             :                  "at %C");
    2236                 :           9 :       return MATCH_ERROR;
    2237                 :             :     }
    2238                 :             :   while (true);
    2239                 :             : 
    2240                 :         122 :   if (!target && !targetsync)
    2241                 :             :     {
    2242                 :           4 :       gfc_error ("Missing required %<target%> and/or %<targetsync%> "
    2243                 :             :                  "modifier at %C");
    2244                 :           4 :       return MATCH_ERROR;
    2245                 :             :     }
    2246                 :             :   return MATCH_YES;
    2247                 :             : }
    2248                 :             : 
    2249                 :             : /* Match OpenMP 5.1's 'init' clause for 'interop' objects:
    2250                 :             :    init([prefer_type(...)][,][<target|targetsync>, ...] :] interop-obj-list)  */
    2251                 :             : 
    2252                 :             : static match
    2253                 :         108 : gfc_match_omp_init (gfc_omp_namelist **list)
    2254                 :             : {
    2255                 :         108 :   bool target, targetsync;
    2256                 :         108 :   char *type_str = NULL;
    2257                 :         108 :   int type_str_len;
    2258                 :         108 :   if (gfc_parser_omp_clause_init_modifiers (target, targetsync, &type_str,
    2259                 :             :                                             type_str_len, true) == MATCH_ERROR)
    2260                 :             :     return MATCH_ERROR;
    2261                 :             : 
    2262                 :          64 :   gfc_omp_namelist **head = NULL;
    2263                 :          64 :   if (gfc_match_omp_variable_list ("", list, false, NULL, &head) != MATCH_YES)
    2264                 :             :     return MATCH_ERROR;
    2265                 :         147 :   for (gfc_omp_namelist *n = *head; n; n = n->next)
    2266                 :             :     {
    2267                 :          84 :       n->u.init.target = target;
    2268                 :          84 :       n->u.init.targetsync = targetsync;
    2269                 :          84 :       n->u.init.len = type_str_len;
    2270                 :          84 :       n->u2.init_interop = type_str;
    2271                 :             :     }
    2272                 :             :   return MATCH_YES;
    2273                 :             : }
    2274                 :             : 
    2275                 :             : 
    2276                 :             : /* Match with duplicate check. Matches 'name'. If expr != NULL, it
    2277                 :             :    then matches '(expr)', otherwise, if open_parens is true,
    2278                 :             :    it matches a ' ( ' after 'name'.
    2279                 :             :    dupl_message requires '%qs %L' - and is used by
    2280                 :             :    gfc_match_dupl_memorder and gfc_match_dupl_atomic.  */
    2281                 :             : 
    2282                 :             : static match
    2283                 :       21889 : gfc_match_dupl_check (bool not_dupl, const char *name, bool open_parens = false,
    2284                 :             :                       gfc_expr **expr = NULL, const char *dupl_msg = NULL)
    2285                 :             : {
    2286                 :       21889 :   match m;
    2287                 :       21889 :   locus old_loc = gfc_current_locus;
    2288                 :       21889 :   if ((m = gfc_match (name)) != MATCH_YES)
    2289                 :             :     return m;
    2290                 :       17121 :   if (!not_dupl)
    2291                 :             :     {
    2292                 :          42 :       if (dupl_msg)
    2293                 :           2 :         gfc_error (dupl_msg, name, &old_loc);
    2294                 :             :       else
    2295                 :          40 :         gfc_error ("Duplicated %qs clause at %L", name, &old_loc);
    2296                 :          42 :       return MATCH_ERROR;
    2297                 :             :     }
    2298                 :       17079 :   if (open_parens || expr)
    2299                 :             :     {
    2300                 :        8980 :       if (gfc_match (" ( ") != MATCH_YES)
    2301                 :             :         {
    2302                 :          26 :           gfc_error ("Expected %<(%> after %qs at %C", name);
    2303                 :          26 :           return MATCH_ERROR;
    2304                 :             :         }
    2305                 :        8954 :       if (expr)
    2306                 :             :         {
    2307                 :        4305 :           if (gfc_match ("%e )", expr) != MATCH_YES)
    2308                 :             :             {
    2309                 :           9 :               gfc_error ("Invalid expression after %<%s(%> at %C", name);
    2310                 :           9 :               return MATCH_ERROR;
    2311                 :             :             }
    2312                 :             :         }
    2313                 :             :     }
    2314                 :             :   return MATCH_YES;
    2315                 :             : }
    2316                 :             : 
    2317                 :             : static match
    2318                 :         211 : gfc_match_dupl_memorder (bool not_dupl, const char *name)
    2319                 :             : {
    2320                 :           0 :   return gfc_match_dupl_check (not_dupl, name, false, NULL,
    2321                 :             :                                "Duplicated memory-order clause: unexpected %s "
    2322                 :           0 :                                "clause at %L");
    2323                 :             : }
    2324                 :             : 
    2325                 :             : static match
    2326                 :        1175 : gfc_match_dupl_atomic (bool not_dupl, const char *name)
    2327                 :             : {
    2328                 :           0 :   return gfc_match_dupl_check (not_dupl, name, false, NULL,
    2329                 :             :                                "Duplicated atomic clause: unexpected %s "
    2330                 :           0 :                                "clause at %L");
    2331                 :             : }
    2332                 :             : 
    2333                 :             : /* Match OpenMP and OpenACC directive clauses. MASK is a bitmask of
    2334                 :             :    clauses that are allowed for a particular directive.  */
    2335                 :             : 
    2336                 :             : static match
    2337                 :       33511 : gfc_match_omp_clauses (gfc_omp_clauses **cp, const omp_mask mask,
    2338                 :             :                        bool first = true, bool needs_space = true,
    2339                 :             :                        bool openacc = false, bool openmp_target = false)
    2340                 :             : {
    2341                 :       33511 :   bool error = false;
    2342                 :       33511 :   gfc_omp_clauses *c = gfc_get_omp_clauses ();
    2343                 :       33511 :   locus old_loc;
    2344                 :             :   /* Determine whether we're dealing with an OpenACC directive that permits
    2345                 :             :      derived type member accesses.  This in particular disallows
    2346                 :             :      "!$acc declare" from using such accesses, because it's not clear if/how
    2347                 :             :      that should work.  */
    2348                 :       33511 :   bool allow_derived = (openacc
    2349                 :       33511 :                         && ((mask & OMP_CLAUSE_ATTACH)
    2350                 :        5889 :                             || (mask & OMP_CLAUSE_DETACH)));
    2351                 :             : 
    2352                 :       33511 :   gcc_checking_assert (OMP_MASK1_LAST <= 64 && OMP_MASK2_LAST <= 64);
    2353                 :       33511 :   *cp = NULL;
    2354                 :      122893 :   while (1)
    2355                 :             :     {
    2356                 :       78202 :       match m = MATCH_NO;
    2357                 :       58376 :       if ((first || (m = gfc_match_char (',')) != MATCH_YES)
    2358                 :      136232 :           && (needs_space && gfc_match_space () != MATCH_YES))
    2359                 :             :         break;
    2360                 :       70273 :       needs_space = false;
    2361                 :       70273 :       first = false;
    2362                 :       70273 :       gfc_gobble_whitespace ();
    2363                 :       70273 :       bool end_colon;
    2364                 :       70273 :       gfc_omp_namelist **head;
    2365                 :       70273 :       old_loc = gfc_current_locus;
    2366                 :       70273 :       char pc = gfc_peek_ascii_char ();
    2367                 :       70273 :       if (pc == '\n' && m == MATCH_YES)
    2368                 :             :         {
    2369                 :           1 :           gfc_error ("Clause expected at %C after trailing comma");
    2370                 :           1 :           goto error;
    2371                 :             :         }
    2372                 :       70272 :       switch (pc)
    2373                 :             :         {
    2374                 :        1252 :         case 'a':
    2375                 :        1252 :           end_colon = false;
    2376                 :        1252 :           head = NULL;
    2377                 :        1276 :           if ((mask & OMP_CLAUSE_ASSUMPTIONS)
    2378                 :        1252 :               && gfc_match ("absent ( ") == MATCH_YES)
    2379                 :             :             {
    2380                 :          27 :               if (gfc_omp_absent_contains_clause (&c->assume, true)
    2381                 :             :                   != MATCH_YES)
    2382                 :           3 :                 goto error;
    2383                 :          24 :               continue;
    2384                 :             :             }
    2385                 :        1225 :           if ((mask & OMP_CLAUSE_ALIGNED)
    2386                 :        1225 :               && gfc_match_omp_variable_list ("aligned (",
    2387                 :             :                                               &c->lists[OMP_LIST_ALIGNED],
    2388                 :             :                                               false, &end_colon,
    2389                 :             :                                               &head) == MATCH_YES)
    2390                 :             :             {
    2391                 :         112 :               gfc_expr *alignment = NULL;
    2392                 :         112 :               gfc_omp_namelist *n;
    2393                 :             : 
    2394                 :         112 :               if (end_colon && gfc_match (" %e )", &alignment) != MATCH_YES)
    2395                 :             :                 {
    2396                 :           0 :                   gfc_free_omp_namelist (*head, false, false, false, false);
    2397                 :           0 :                   gfc_current_locus = old_loc;
    2398                 :           0 :                   *head = NULL;
    2399                 :           0 :                   break;
    2400                 :             :                 }
    2401                 :         268 :               for (n = *head; n; n = n->next)
    2402                 :         156 :                 if (n->next && alignment)
    2403                 :          42 :                   n->expr = gfc_copy_expr (alignment);
    2404                 :             :                 else
    2405                 :         114 :                   n->expr = alignment;
    2406                 :         112 :               continue;
    2407                 :         112 :             }
    2408                 :        1123 :           if ((mask & OMP_CLAUSE_MEMORDER)
    2409                 :        1130 :               && (m = gfc_match_dupl_memorder ((c->memorder
    2410                 :          17 :                                                 == OMP_MEMORDER_UNSET),
    2411                 :             :                                                "acq_rel")) != MATCH_NO)
    2412                 :             :             {
    2413                 :          10 :               if (m == MATCH_ERROR)
    2414                 :           0 :                 goto error;
    2415                 :          10 :               c->memorder = OMP_MEMORDER_ACQ_REL;
    2416                 :          10 :               needs_space = true;
    2417                 :          10 :               continue;
    2418                 :             :             }
    2419                 :        1110 :           if ((mask & OMP_CLAUSE_MEMORDER)
    2420                 :        1110 :               && (m = gfc_match_dupl_memorder ((c->memorder
    2421                 :           7 :                                                 == OMP_MEMORDER_UNSET),
    2422                 :             :                                                "acquire")) != MATCH_NO)
    2423                 :             :             {
    2424                 :           7 :               if (m == MATCH_ERROR)
    2425                 :           0 :                 goto error;
    2426                 :           7 :               c->memorder = OMP_MEMORDER_ACQUIRE;
    2427                 :           7 :               needs_space = true;
    2428                 :           7 :               continue;
    2429                 :             :             }
    2430                 :        1096 :           if ((mask & OMP_CLAUSE_AFFINITY)
    2431                 :        1096 :               && gfc_match ("affinity ( ") == MATCH_YES)
    2432                 :             :             {
    2433                 :          41 :               gfc_namespace *ns_iter = NULL, *ns_curr = gfc_current_ns;
    2434                 :          41 :               m = gfc_match_iterator (&ns_iter, true);
    2435                 :          41 :               if (m == MATCH_ERROR)
    2436                 :             :                 break;
    2437                 :          31 :               if (m == MATCH_YES && gfc_match (" : ") != MATCH_YES)
    2438                 :             :                 {
    2439                 :           1 :                   gfc_error ("Expected %<:%> at %C");
    2440                 :           1 :                   break;
    2441                 :             :                 }
    2442                 :          30 :               if (ns_iter)
    2443                 :          18 :                 gfc_current_ns = ns_iter;
    2444                 :          30 :               head = NULL;
    2445                 :          30 :               m = gfc_match_omp_variable_list ("", &c->lists[OMP_LIST_AFFINITY],
    2446                 :             :                                                false, NULL, &head, true);
    2447                 :          30 :               gfc_current_ns = ns_curr;
    2448                 :          30 :               if (m == MATCH_ERROR)
    2449                 :             :                 break;
    2450                 :          27 :               if (ns_iter)
    2451                 :             :                 {
    2452                 :          45 :                   for (gfc_omp_namelist *n = *head; n; n = n->next)
    2453                 :             :                     {
    2454                 :          27 :                       n->u2.ns = ns_iter;
    2455                 :          27 :                       ns_iter->refs++;
    2456                 :             :                     }
    2457                 :             :                 }
    2458                 :          27 :               continue;
    2459                 :          27 :             }
    2460                 :        1055 :           if ((mask & OMP_CLAUSE_ALLOCATE)
    2461                 :        1055 :               && gfc_match ("allocate ( ") == MATCH_YES)
    2462                 :             :             {
    2463                 :         235 :               gfc_expr *allocator = NULL;
    2464                 :         235 :               gfc_expr *align = NULL;
    2465                 :         235 :               old_loc = gfc_current_locus;
    2466                 :         235 :               if ((m = gfc_match ("allocator ( %e )", &allocator)) == MATCH_YES)
    2467                 :           6 :                 gfc_match (" , align ( %e )", &align);
    2468                 :         229 :               else if ((m = gfc_match ("align ( %e )", &align)) == MATCH_YES)
    2469                 :          29 :                 gfc_match (" , allocator ( %e )", &allocator);
    2470                 :             : 
    2471                 :         235 :               if (m == MATCH_YES)
    2472                 :             :                 {
    2473                 :          35 :                   if (gfc_match (" : ") != MATCH_YES)
    2474                 :             :                     {
    2475                 :           5 :                       gfc_error ("Expected %<:%> at %C");
    2476                 :           8 :                       goto error;
    2477                 :             :                     }
    2478                 :             :                 }
    2479                 :             :               else
    2480                 :             :                 {
    2481                 :         200 :                   m = gfc_match_expr (&allocator);
    2482                 :         200 :                   if (m == MATCH_YES && gfc_match (" : ") != MATCH_YES)
    2483                 :             :                     {
    2484                 :             :                        /* If no ":" then there is no allocator, we backtrack
    2485                 :             :                           and read the variable list.  */
    2486                 :         101 :                       gfc_free_expr (allocator);
    2487                 :         101 :                       allocator = NULL;
    2488                 :         101 :                       gfc_current_locus = old_loc;
    2489                 :             :                     }
    2490                 :             :                 }
    2491                 :         230 :               gfc_omp_namelist **head = NULL;
    2492                 :         230 :               m = gfc_match_omp_variable_list ("", &c->lists[OMP_LIST_ALLOCATE],
    2493                 :             :                                                true, NULL, &head);
    2494                 :             : 
    2495                 :         230 :               if (m != MATCH_YES)
    2496                 :             :                 {
    2497                 :           3 :                   gfc_free_expr (allocator);
    2498                 :           3 :                   gfc_free_expr (align);
    2499                 :           3 :                   gfc_error ("Expected variable list at %C");
    2500                 :           3 :                   goto error;
    2501                 :             :                 }
    2502                 :             : 
    2503                 :         630 :               for (gfc_omp_namelist *n = *head; n; n = n->next)
    2504                 :             :                 {
    2505                 :         403 :                   n->u2.allocator = allocator;
    2506                 :         403 :                   n->u.align = (align) ? gfc_copy_expr (align) : NULL;
    2507                 :             :                 }
    2508                 :         227 :               gfc_free_expr (align);
    2509                 :         227 :               continue;
    2510                 :         227 :             }
    2511                 :         878 :           if ((mask & OMP_CLAUSE_AT)
    2512                 :         820 :               && (m = gfc_match_dupl_check (c->at == OMP_AT_UNSET, "at", true))
    2513                 :             :                  != MATCH_NO)
    2514                 :             :             {
    2515                 :          64 :               if (m == MATCH_ERROR)
    2516                 :           2 :                 goto error;
    2517                 :          62 :               if (gfc_match ("compilation )") == MATCH_YES)
    2518                 :          14 :                 c->at = OMP_AT_COMPILATION;
    2519                 :          48 :               else if (gfc_match ("execution )") == MATCH_YES)
    2520                 :          44 :                 c->at = OMP_AT_EXECUTION;
    2521                 :             :               else
    2522                 :             :                 {
    2523                 :           4 :                   gfc_error ("Expected COMPILATION or EXECUTION in AT clause "
    2524                 :             :                              "at %C");
    2525                 :           4 :                   goto error;
    2526                 :             :                 }
    2527                 :          58 :               continue;
    2528                 :             :             }
    2529                 :        1388 :           if ((mask & OMP_CLAUSE_ASYNC)
    2530                 :         756 :               && (m = gfc_match_dupl_check (!c->async, "async")) != MATCH_NO)
    2531                 :             :             {
    2532                 :         632 :               if (m == MATCH_ERROR)
    2533                 :           0 :                 goto error;
    2534                 :         632 :               c->async = true;
    2535                 :         632 :               m = gfc_match (" ( %e )", &c->async_expr);
    2536                 :         632 :               if (m == MATCH_ERROR)
    2537                 :             :                 {
    2538                 :           0 :                   gfc_current_locus = old_loc;
    2539                 :           0 :                   break;
    2540                 :             :                 }
    2541                 :         632 :               else if (m == MATCH_NO)
    2542                 :             :                 {
    2543                 :         132 :                   c->async_expr
    2544                 :         132 :                     = gfc_get_constant_expr (BT_INTEGER,
    2545                 :             :                                              gfc_default_integer_kind,
    2546                 :             :                                              &gfc_current_locus);
    2547                 :         132 :                   mpz_set_si (c->async_expr->value.integer, GOMP_ASYNC_NOVAL);
    2548                 :         132 :                   needs_space = true;
    2549                 :             :                 }
    2550                 :         632 :               continue;
    2551                 :             :             }
    2552                 :         187 :           if ((mask & OMP_CLAUSE_AUTO)
    2553                 :         124 :               && (m = gfc_match_dupl_check (!c->par_auto, "auto"))
    2554                 :             :                  != MATCH_NO)
    2555                 :             :             {
    2556                 :          63 :               if (m == MATCH_ERROR)
    2557                 :           0 :                 goto error;
    2558                 :          63 :               c->par_auto = true;
    2559                 :          63 :               needs_space = true;
    2560                 :          63 :               continue;
    2561                 :             :             }
    2562                 :         120 :           if ((mask & OMP_CLAUSE_ATTACH)
    2563                 :          59 :               && gfc_match ("attach ( ") == MATCH_YES
    2564                 :         120 :               && gfc_match_omp_map_clause (&c->lists[OMP_LIST_MAP],
    2565                 :             :                                            OMP_MAP_ATTACH, false,
    2566                 :             :                                            allow_derived))
    2567                 :          59 :             continue;
    2568                 :             :           break;
    2569                 :          36 :         case 'b':
    2570                 :          70 :           if ((mask & OMP_CLAUSE_BIND)
    2571                 :          36 :               && (m = gfc_match_dupl_check (c->bind == OMP_BIND_UNSET, "bind",
    2572                 :             :                                             true)) != MATCH_NO)
    2573                 :             :             {
    2574                 :          36 :               if (m == MATCH_ERROR)
    2575                 :           1 :                 goto error;
    2576                 :          35 :               if (gfc_match ("teams )") == MATCH_YES)
    2577                 :          11 :                 c->bind = OMP_BIND_TEAMS;
    2578                 :          24 :               else if (gfc_match ("parallel )") == MATCH_YES)
    2579                 :          15 :                 c->bind = OMP_BIND_PARALLEL;
    2580                 :           9 :               else if (gfc_match ("thread )") == MATCH_YES)
    2581                 :           8 :                 c->bind = OMP_BIND_THREAD;
    2582                 :             :               else
    2583                 :             :                 {
    2584                 :           1 :                   gfc_error ("Expected TEAMS, PARALLEL or THREAD as binding in "
    2585                 :             :                              "BIND at %C");
    2586                 :           1 :                   break;
    2587                 :             :                 }
    2588                 :          34 :               continue;
    2589                 :             :             }
    2590                 :             :           break;
    2591                 :        7061 :         case 'c':
    2592                 :        7334 :           if ((mask & OMP_CLAUSE_CAPTURE)
    2593                 :        7061 :               && (m = gfc_match_dupl_check (!c->capture, "capture"))
    2594                 :             :                  != MATCH_NO)
    2595                 :             :             {
    2596                 :         274 :               if (m == MATCH_ERROR)
    2597                 :           1 :                 goto error;
    2598                 :         273 :               c->capture = true;
    2599                 :         273 :               needs_space = true;
    2600                 :         273 :               continue;
    2601                 :             :             }
    2602                 :        6787 :           if (mask & OMP_CLAUSE_COLLAPSE)
    2603                 :             :             {
    2604                 :        1985 :               gfc_expr *cexpr = NULL;
    2605                 :        1985 :               if ((m = gfc_match_dupl_check (!c->collapse, "collapse", true,
    2606                 :             :                                              &cexpr)) != MATCH_NO)
    2607                 :             :               {
    2608                 :        1495 :                 int collapse;
    2609                 :        1495 :                 if (m == MATCH_ERROR)
    2610                 :           0 :                   goto error;
    2611                 :        1495 :                 if (gfc_extract_int (cexpr, &collapse, -1))
    2612                 :           4 :                   collapse = 1;
    2613                 :        1491 :                 else if (collapse <= 0)
    2614                 :             :                   {
    2615                 :           8 :                     gfc_error_now ("COLLAPSE clause argument not constant "
    2616                 :             :                                    "positive integer at %C");
    2617                 :           8 :                     collapse = 1;
    2618                 :             :                   }
    2619                 :        1495 :                 gfc_free_expr (cexpr);
    2620                 :        1495 :                 c->collapse = collapse;
    2621                 :        1495 :                 continue;
    2622                 :        1495 :               }
    2623                 :             :             }
    2624                 :        5458 :           if ((mask & OMP_CLAUSE_COMPARE)
    2625                 :        5292 :               && (m = gfc_match_dupl_check (!c->compare, "compare"))
    2626                 :             :                  != MATCH_NO)
    2627                 :             :             {
    2628                 :         167 :               if (m == MATCH_ERROR)
    2629                 :           1 :                 goto error;
    2630                 :         166 :               c->compare = true;
    2631                 :         166 :               needs_space = true;
    2632                 :         166 :               continue;
    2633                 :             :             }
    2634                 :        5137 :           if ((mask & OMP_CLAUSE_ASSUMPTIONS)
    2635                 :        5125 :               && gfc_match ("contains ( ") == MATCH_YES)
    2636                 :             :             {
    2637                 :          12 :               if (gfc_omp_absent_contains_clause (&c->assume, false)
    2638                 :             :                   != MATCH_YES)
    2639                 :           0 :                 goto error;
    2640                 :          12 :               continue;
    2641                 :             :             }
    2642                 :        7224 :           if ((mask & OMP_CLAUSE_COPY)
    2643                 :        3712 :               && gfc_match ("copy ( ") == MATCH_YES
    2644                 :        7225 :               && gfc_match_omp_map_clause (&c->lists[OMP_LIST_MAP],
    2645                 :             :                                            OMP_MAP_TOFROM, true,
    2646                 :             :                                            allow_derived))
    2647                 :        2111 :             continue;
    2648                 :        3002 :           if (mask & OMP_CLAUSE_COPYIN)
    2649                 :             :             {
    2650                 :        2604 :               if (openacc)
    2651                 :             :                 {
    2652                 :        2505 :                   if (gfc_match ("copyin ( ") == MATCH_YES)
    2653                 :             :                     {
    2654                 :        1436 :                       bool readonly = gfc_match ("readonly : ") == MATCH_YES;
    2655                 :        1436 :                       head = NULL;
    2656                 :        1436 :                       if (gfc_match_omp_variable_list ("",
    2657                 :             :                                                        &c->lists[OMP_LIST_MAP],
    2658                 :             :                                                        true, NULL, &head, true,
    2659                 :             :                                                        allow_derived)
    2660                 :             :                           == MATCH_YES)
    2661                 :             :                         {
    2662                 :        1430 :                           gfc_omp_namelist *n;
    2663                 :        3280 :                           for (n = *head; n; n = n->next)
    2664                 :             :                             {
    2665                 :        1850 :                               n->u.map.op = OMP_MAP_TO;
    2666                 :        1850 :                               n->u.map.readonly = readonly;
    2667                 :             :                             }
    2668                 :        1430 :                           continue;
    2669                 :        1430 :                         }
    2670                 :             :                     }
    2671                 :             :                 }
    2672                 :          99 :               else if (gfc_match_omp_variable_list ("copyin (",
    2673                 :             :                                                     &c->lists[OMP_LIST_COPYIN],
    2674                 :             :                                                     true) == MATCH_YES)
    2675                 :          97 :                 continue;
    2676                 :             :             }
    2677                 :        2536 :           if ((mask & OMP_CLAUSE_COPYOUT)
    2678                 :        1206 :               && gfc_match ("copyout ( ") == MATCH_YES
    2679                 :        2536 :               && gfc_match_omp_map_clause (&c->lists[OMP_LIST_MAP],
    2680                 :             :                                            OMP_MAP_FROM, true, allow_derived))
    2681                 :        1061 :             continue;
    2682                 :         498 :           if ((mask & OMP_CLAUSE_COPYPRIVATE)
    2683                 :         414 :               && gfc_match_omp_variable_list ("copyprivate (",
    2684                 :             :                                               &c->lists[OMP_LIST_COPYPRIVATE],
    2685                 :             :                                               true) == MATCH_YES)
    2686                 :          84 :             continue;
    2687                 :         651 :           if ((mask & OMP_CLAUSE_CREATE)
    2688                 :         328 :               && gfc_match ("create ( ") == MATCH_YES
    2689                 :         651 :               && gfc_match_omp_map_clause (&c->lists[OMP_LIST_MAP],
    2690                 :             :                                            OMP_MAP_ALLOC, true, allow_derived))
    2691                 :         321 :             continue;
    2692                 :             :           break;
    2693                 :        3614 :         case 'd':
    2694                 :        3614 :           if ((mask & OMP_CLAUSE_DEFAULTMAP)
    2695                 :        3614 :               && gfc_match ("defaultmap ( ") == MATCH_YES)
    2696                 :             :             {
    2697                 :         177 :               enum gfc_omp_defaultmap behavior;
    2698                 :         177 :               gfc_omp_defaultmap_category category
    2699                 :             :                 = OMP_DEFAULTMAP_CAT_UNCATEGORIZED;
    2700                 :         177 :               if (gfc_match ("alloc ") == MATCH_YES)
    2701                 :             :                 behavior = OMP_DEFAULTMAP_ALLOC;
    2702                 :         171 :               else if (gfc_match ("tofrom ") == MATCH_YES)
    2703                 :             :                 behavior = OMP_DEFAULTMAP_TOFROM;
    2704                 :         139 :               else if (gfc_match ("to ") == MATCH_YES)
    2705                 :             :                 behavior = OMP_DEFAULTMAP_TO;
    2706                 :         129 :               else if (gfc_match ("from ") == MATCH_YES)
    2707                 :             :                 behavior = OMP_DEFAULTMAP_FROM;
    2708                 :         126 :               else if (gfc_match ("firstprivate ") == MATCH_YES)
    2709                 :             :                 behavior = OMP_DEFAULTMAP_FIRSTPRIVATE;
    2710                 :          91 :               else if (gfc_match ("present ") == MATCH_YES)
    2711                 :             :                 behavior = OMP_DEFAULTMAP_PRESENT;
    2712                 :          87 :               else if (gfc_match ("none ") == MATCH_YES)
    2713                 :             :                 behavior = OMP_DEFAULTMAP_NONE;
    2714                 :          10 :               else if (gfc_match ("default ") == MATCH_YES)
    2715                 :             :                 behavior = OMP_DEFAULTMAP_DEFAULT;
    2716                 :             :               else
    2717                 :             :                 {
    2718                 :           1 :                   gfc_error ("Expected ALLOC, TO, FROM, TOFROM, FIRSTPRIVATE, "
    2719                 :             :                              "PRESENT, NONE or DEFAULT at %C");
    2720                 :           1 :                   break;
    2721                 :             :                 }
    2722                 :         176 :               if (')' == gfc_peek_ascii_char ())
    2723                 :             :                 ;
    2724                 :         102 :               else if (gfc_match (": ") != MATCH_YES)
    2725                 :             :                 break;
    2726                 :             :               else
    2727                 :             :                 {
    2728                 :         102 :                   if (gfc_match ("scalar ") == MATCH_YES)
    2729                 :             :                     category = OMP_DEFAULTMAP_CAT_SCALAR;
    2730                 :          67 :                   else if (gfc_match ("aggregate ") == MATCH_YES)
    2731                 :             :                     category = OMP_DEFAULTMAP_CAT_AGGREGATE;
    2732                 :          43 :                   else if (gfc_match ("allocatable ") == MATCH_YES)
    2733                 :             :                     category = OMP_DEFAULTMAP_CAT_ALLOCATABLE;
    2734                 :          31 :                   else if (gfc_match ("pointer ") == MATCH_YES)
    2735                 :             :                     category = OMP_DEFAULTMAP_CAT_POINTER;
    2736                 :          14 :                   else if (gfc_match ("all ") == MATCH_YES)
    2737                 :             :                     category = OMP_DEFAULTMAP_CAT_ALL;
    2738                 :             :                   else
    2739                 :             :                     {
    2740                 :           1 :                       gfc_error ("Expected SCALAR, AGGREGATE, ALLOCATABLE, "
    2741                 :             :                                  "POINTER or ALL at %C");
    2742                 :           1 :                       break;
    2743                 :             :                     }
    2744                 :             :                 }
    2745                 :        1172 :               for (int i = 0; i < OMP_DEFAULTMAP_CAT_NUM; ++i)
    2746                 :             :                 {
    2747                 :        1010 :                   if (i != category
    2748                 :        1010 :                       && category != OMP_DEFAULTMAP_CAT_UNCATEGORIZED
    2749                 :         486 :                       && category != OMP_DEFAULTMAP_CAT_ALL
    2750                 :         486 :                       && i != OMP_DEFAULTMAP_CAT_UNCATEGORIZED
    2751                 :         341 :                       && i != OMP_DEFAULTMAP_CAT_ALL)
    2752                 :         254 :                     continue;
    2753                 :         756 :                   if (c->defaultmap[i] != OMP_DEFAULTMAP_UNSET)
    2754                 :             :                     {
    2755                 :          13 :                       const char *pcategory = NULL;
    2756                 :          13 :                       switch (i)
    2757                 :             :                         {
    2758                 :             :                         case OMP_DEFAULTMAP_CAT_UNCATEGORIZED: break;
    2759                 :             :                         case OMP_DEFAULTMAP_CAT_ALL: pcategory = "ALL"; break;
    2760                 :           1 :                         case OMP_DEFAULTMAP_CAT_SCALAR: pcategory = "SCALAR"; break;
    2761                 :           2 :                         case OMP_DEFAULTMAP_CAT_AGGREGATE:
    2762                 :           2 :                           pcategory = "AGGREGATE";
    2763                 :           2 :                           break;
    2764                 :           1 :                         case OMP_DEFAULTMAP_CAT_ALLOCATABLE:
    2765                 :           1 :                           pcategory = "ALLOCATABLE";
    2766                 :           1 :                           break;
    2767                 :           2 :                         case OMP_DEFAULTMAP_CAT_POINTER:
    2768                 :           2 :                           pcategory = "POINTER";
    2769                 :           2 :                           break;
    2770                 :             :                         default: gcc_unreachable ();
    2771                 :             :                         }
    2772                 :           6 :                      if (i == OMP_DEFAULTMAP_CAT_UNCATEGORIZED)
    2773                 :           4 :                       gfc_error ("DEFAULTMAP at %C but prior DEFAULTMAP with "
    2774                 :             :                                  "unspecified category");
    2775                 :             :                      else
    2776                 :           9 :                       gfc_error ("DEFAULTMAP at %C but prior DEFAULTMAP for "
    2777                 :             :                                  "category %s", pcategory);
    2778                 :          13 :                      goto error;
    2779                 :             :                     }
    2780                 :             :                 }
    2781                 :         162 :               c->defaultmap[category] = behavior;
    2782                 :         162 :               if (gfc_match (")") != MATCH_YES)
    2783                 :             :                 break;
    2784                 :         162 :               continue;
    2785                 :         162 :             }
    2786                 :        4392 :           if ((mask & OMP_CLAUSE_DEFAULT)
    2787                 :        3437 :               && (m = gfc_match_dupl_check (c->default_sharing
    2788                 :             :                                             == OMP_DEFAULT_UNKNOWN, "default",
    2789                 :             :                                             true)) != MATCH_NO)
    2790                 :             :             {
    2791                 :        1000 :               if (m == MATCH_ERROR)
    2792                 :           6 :                 goto error;
    2793                 :         994 :               if (gfc_match ("none") == MATCH_YES)
    2794                 :         584 :                 c->default_sharing = OMP_DEFAULT_NONE;
    2795                 :         410 :               else if (openacc)
    2796                 :             :                 {
    2797                 :         225 :                   if (gfc_match ("present") == MATCH_YES)
    2798                 :         195 :                     c->default_sharing = OMP_DEFAULT_PRESENT;
    2799                 :             :                 }
    2800                 :             :               else
    2801                 :             :                 {
    2802                 :         185 :                   if (gfc_match ("firstprivate") == MATCH_YES)
    2803                 :           8 :                     c->default_sharing = OMP_DEFAULT_FIRSTPRIVATE;
    2804                 :         177 :                   else if (gfc_match ("private") == MATCH_YES)
    2805                 :          24 :                     c->default_sharing = OMP_DEFAULT_PRIVATE;
    2806                 :         153 :                   else if (gfc_match ("shared") == MATCH_YES)
    2807                 :         153 :                     c->default_sharing = OMP_DEFAULT_SHARED;
    2808                 :             :                 }
    2809                 :         994 :               if (c->default_sharing == OMP_DEFAULT_UNKNOWN)
    2810                 :             :                 {
    2811                 :          30 :                   if (openacc)
    2812                 :          30 :                     gfc_error ("Expected NONE or PRESENT in DEFAULT clause "
    2813                 :             :                                "at %C");
    2814                 :             :                   else
    2815                 :           0 :                     gfc_error ("Expected NONE, FIRSTPRIVATE, PRIVATE or SHARED "
    2816                 :             :                                "in DEFAULT clause at %C");
    2817                 :          30 :                   goto error;
    2818                 :             :                 }
    2819                 :         964 :               if (gfc_match (" )") != MATCH_YES)
    2820                 :           9 :                 goto error;
    2821                 :         955 :               continue;
    2822                 :             :             }
    2823                 :        2725 :           if ((mask & OMP_CLAUSE_DELETE)
    2824                 :         323 :               && gfc_match ("delete ( ") == MATCH_YES
    2825                 :        2725 :               && gfc_match_omp_map_clause (&c->lists[OMP_LIST_MAP],
    2826                 :             :                                            OMP_MAP_RELEASE, true,
    2827                 :             :                                            allow_derived))
    2828                 :         288 :             continue;
    2829                 :             :           /* DOACROSS: match 'doacross' and 'depend' with sink/source.
    2830                 :             :              DEPEND: match 'depend' but not sink/source.  */
    2831                 :        2149 :           m = MATCH_NO;
    2832                 :        2149 :           if (((mask & OMP_CLAUSE_DOACROSS)
    2833                 :         381 :                && gfc_match ("doacross ( ") == MATCH_YES)
    2834                 :        2503 :               || (((mask & OMP_CLAUSE_DEPEND) || (mask & OMP_CLAUSE_DOACROSS))
    2835                 :        1552 :                   && (m = gfc_match ("depend ( ")) == MATCH_YES))
    2836                 :             :             {
    2837                 :        1091 :               bool has_omp_all_memory;
    2838                 :        1091 :               bool is_depend = m == MATCH_YES;
    2839                 :        1091 :               gfc_namespace *ns_iter = NULL, *ns_curr = gfc_current_ns;
    2840                 :        1091 :               match m_it = MATCH_NO;
    2841                 :        1091 :               if (is_depend)
    2842                 :        1064 :                 m_it = gfc_match_iterator (&ns_iter, false);
    2843                 :        1064 :               if (m_it == MATCH_ERROR)
    2844                 :             :                 break;
    2845                 :        1086 :               if (m_it == MATCH_YES && gfc_match (" , ") != MATCH_YES)
    2846                 :             :                 break;
    2847                 :        1086 :               m = MATCH_YES;
    2848                 :        1086 :               gfc_omp_depend_doacross_op depend_op = OMP_DEPEND_OUT;
    2849                 :        1086 :               if (gfc_match ("inoutset") == MATCH_YES)
    2850                 :             :                 depend_op = OMP_DEPEND_INOUTSET;
    2851                 :        1074 :               else if (gfc_match ("inout") == MATCH_YES)
    2852                 :             :                 depend_op = OMP_DEPEND_INOUT;
    2853                 :         983 :               else if (gfc_match ("in") == MATCH_YES)
    2854                 :             :                 depend_op = OMP_DEPEND_IN;
    2855                 :         697 :               else if (gfc_match ("out") == MATCH_YES)
    2856                 :             :                 depend_op = OMP_DEPEND_OUT;
    2857                 :         437 :               else if (gfc_match ("mutexinoutset") == MATCH_YES)
    2858                 :             :                 depend_op = OMP_DEPEND_MUTEXINOUTSET;
    2859                 :         419 :               else if (gfc_match ("depobj") == MATCH_YES)
    2860                 :             :                 depend_op = OMP_DEPEND_DEPOBJ;
    2861                 :         385 :               else if (gfc_match ("source") == MATCH_YES)
    2862                 :             :                 {
    2863                 :         142 :                   if (m_it == MATCH_YES)
    2864                 :             :                     {
    2865                 :           1 :                       gfc_error ("ITERATOR may not be combined with SOURCE "
    2866                 :             :                                  "at %C");
    2867                 :          17 :                       goto error;
    2868                 :             :                     }
    2869                 :         141 :                   if (!(mask & OMP_CLAUSE_DOACROSS))
    2870                 :             :                     {
    2871                 :           1 :                       gfc_error ("SOURCE at %C not permitted as dependence-type"
    2872                 :             :                                  " for this directive");
    2873                 :           1 :                       goto error;
    2874                 :             :                     }
    2875                 :         140 :                   if (c->doacross_source)
    2876                 :             :                     {
    2877                 :           0 :                       gfc_error ("Duplicated clause with SOURCE dependence-type"
    2878                 :             :                                  " at %C");
    2879                 :           0 :                       goto error;
    2880                 :             :                     }
    2881                 :         140 :                   gfc_gobble_whitespace ();
    2882                 :         140 :                   m = gfc_match (": ");
    2883                 :         140 :                   if (m != MATCH_YES && !is_depend)
    2884                 :             :                     {
    2885                 :           1 :                       gfc_error ("Expected %<:%> at %C");
    2886                 :           1 :                       goto error;
    2887                 :             :                     }
    2888                 :         139 :                   if (gfc_match (")") != MATCH_YES
    2889                 :         145 :                       && !(m == MATCH_YES
    2890                 :           6 :                            && gfc_match ("omp_cur_iteration )") == MATCH_YES))
    2891                 :             :                     {
    2892                 :           2 :                       gfc_error ("Expected %<)%> or %<omp_cur_iteration)%> "
    2893                 :             :                                  "at %C");
    2894                 :           2 :                       goto error;
    2895                 :             :                     }
    2896                 :         137 :                   c->doacross_source = true;
    2897                 :         137 :                   c->depend_source = is_depend;
    2898                 :        1069 :                   continue;
    2899                 :             :                 }
    2900                 :         243 :               else if (gfc_match ("sink ") == MATCH_YES)
    2901                 :             :                 {
    2902                 :         243 :                   if (!(mask & OMP_CLAUSE_DOACROSS))
    2903                 :             :                     {
    2904                 :           2 :                       gfc_error ("SINK at %C not permitted as dependence-type "
    2905                 :             :                                  "for this directive");
    2906                 :           2 :                       goto error;
    2907                 :             :                     }
    2908                 :         241 :                   if (gfc_match (": ") != MATCH_YES)
    2909                 :             :                     {
    2910                 :           1 :                       gfc_error ("Expected %<:%> at %C");
    2911                 :           1 :                       goto error;
    2912                 :             :                     }
    2913                 :         240 :                   if (m_it == MATCH_YES)
    2914                 :             :                     {
    2915                 :           0 :                       gfc_error ("ITERATOR may not be combined with SINK "
    2916                 :             :                                  "at %C");
    2917                 :           0 :                       goto error;
    2918                 :             :                     }
    2919                 :         240 :                   m = gfc_match_omp_doacross_sink (&c->lists[OMP_LIST_DEPEND],
    2920                 :             :                                                    is_depend);
    2921                 :         240 :                   if (m == MATCH_YES)
    2922                 :         237 :                     continue;
    2923                 :           3 :                   goto error;
    2924                 :             :                 }
    2925                 :             :               else
    2926                 :             :                 m = MATCH_NO;
    2927                 :         701 :               if (!(mask & OMP_CLAUSE_DEPEND))
    2928                 :             :                 {
    2929                 :           0 :                   gfc_error ("Expected dependence-type SINK or SOURCE at %C");
    2930                 :           0 :                   goto error;
    2931                 :             :                 }
    2932                 :         701 :               head = NULL;
    2933                 :         701 :               if (ns_iter)
    2934                 :          37 :                 gfc_current_ns = ns_iter;
    2935                 :         701 :               if (m == MATCH_YES)
    2936                 :         701 :                 m = gfc_match_omp_variable_list (" : ",
    2937                 :             :                                                  &c->lists[OMP_LIST_DEPEND],
    2938                 :             :                                                  false, NULL, &head, true,
    2939                 :             :                                                  false, &has_omp_all_memory);
    2940                 :         701 :               if (m != MATCH_YES)
    2941                 :           2 :                 goto error;
    2942                 :         699 :               gfc_current_ns = ns_curr;
    2943                 :         699 :               if (has_omp_all_memory && depend_op != OMP_DEPEND_INOUT
    2944                 :          21 :                   && depend_op != OMP_DEPEND_OUT)
    2945                 :             :                 {
    2946                 :           4 :                   gfc_error ("%<omp_all_memory%> used with DEPEND kind "
    2947                 :             :                              "other than OUT or INOUT at %C");
    2948                 :           4 :                   goto error;
    2949                 :             :                 }
    2950                 :         695 :               gfc_omp_namelist *n;
    2951                 :        1421 :               for (n = *head; n; n = n->next)
    2952                 :             :                 {
    2953                 :         726 :                   n->u.depend_doacross_op = depend_op;
    2954                 :         726 :                   n->u2.ns = ns_iter;
    2955                 :         726 :                   if (ns_iter)
    2956                 :          36 :                     ns_iter->refs++;
    2957                 :             :                 }
    2958                 :         695 :               continue;
    2959                 :         695 :             }
    2960                 :        1079 :           if ((mask & OMP_CLAUSE_DESTROY)
    2961                 :        1058 :               && gfc_match_omp_variable_list ("destroy (",
    2962                 :             :                                               &c->lists[OMP_LIST_DESTROY],
    2963                 :             :                                               true) == MATCH_YES)
    2964                 :          21 :             continue;
    2965                 :        1163 :           if ((mask & OMP_CLAUSE_DETACH)
    2966                 :         162 :               && !openacc
    2967                 :         127 :               && !c->detach
    2968                 :        1163 :               && gfc_match_omp_detach (&c->detach) == MATCH_YES)
    2969                 :         126 :             continue;
    2970                 :         946 :           if ((mask & OMP_CLAUSE_DETACH)
    2971                 :          36 :               && openacc
    2972                 :          35 :               && gfc_match ("detach ( ") == MATCH_YES
    2973                 :         946 :               && gfc_match_omp_map_clause (&c->lists[OMP_LIST_MAP],
    2974                 :             :                                            OMP_MAP_DETACH, false,
    2975                 :             :                                            allow_derived))
    2976                 :          35 :             continue;
    2977                 :         876 :           if ((mask & OMP_CLAUSE_DEVICE)
    2978                 :         669 :               && !openacc
    2979                 :        1231 :               && ((m = gfc_match_dupl_check (!c->device, "device", true))
    2980                 :             :                   != MATCH_NO))
    2981                 :             :             {
    2982                 :         328 :               if (m == MATCH_ERROR)
    2983                 :           0 :                 goto error;
    2984                 :         328 :               c->ancestor = false;
    2985                 :         328 :               if (gfc_match ("device_num : ") == MATCH_YES)
    2986                 :             :                 {
    2987                 :          18 :                   if (gfc_match ("%e )", &c->device) != MATCH_YES)
    2988                 :             :                     {
    2989                 :           1 :                       gfc_error ("Expected integer expression at %C");
    2990                 :           1 :                       break;
    2991                 :             :                     }
    2992                 :             :                 }
    2993                 :         310 :               else if (gfc_match ("ancestor : ") == MATCH_YES)
    2994                 :             :                 {
    2995                 :          45 :                   bool has_requires = false;
    2996                 :          45 :                   c->ancestor = true;
    2997                 :          82 :                   for (gfc_namespace *ns = gfc_current_ns; ns; ns = ns->parent)
    2998                 :          80 :                     if (ns->omp_requires & OMP_REQ_REVERSE_OFFLOAD)
    2999                 :             :                       {
    3000                 :             :                         has_requires = true;
    3001                 :             :                         break;
    3002                 :             :                       }
    3003                 :          45 :                   if (!has_requires)
    3004                 :             :                     {
    3005                 :           2 :                       gfc_error ("%<ancestor%> device modifier not "
    3006                 :             :                                  "preceded by %<requires%> directive "
    3007                 :             :                                  "with %<reverse_offload%> clause at %C");
    3008                 :           5 :                       break;
    3009                 :             :                     }
    3010                 :          43 :                   locus old_loc2 = gfc_current_locus;
    3011                 :          43 :                   if (gfc_match ("%e )", &c->device) == MATCH_YES)
    3012                 :             :                     {
    3013                 :          43 :                       int device = 0;
    3014                 :          43 :                       if (!gfc_extract_int (c->device, &device) && device != 1)
    3015                 :             :                       {
    3016                 :           1 :                         gfc_current_locus = old_loc2;
    3017                 :           1 :                         gfc_error ("the %<device%> clause expression must "
    3018                 :             :                                    "evaluate to %<1%> at %C");
    3019                 :           1 :                         break;
    3020                 :             :                       }
    3021                 :             :                     }
    3022                 :             :                   else
    3023                 :             :                     {
    3024                 :           0 :                       gfc_error ("Expected integer expression at %C");
    3025                 :           0 :                       break;
    3026                 :             :                     }
    3027                 :             :                 }
    3028                 :         265 :               else if (gfc_match ("%e )", &c->device) != MATCH_YES)
    3029                 :             :                 {
    3030                 :          13 :                   gfc_error ("Expected integer expression or a single device-"
    3031                 :             :                               "modifier %<device_num%> or %<ancestor%> at %C");
    3032                 :          13 :                   break;
    3033                 :             :                 }
    3034                 :         311 :               continue;
    3035                 :         311 :             }
    3036                 :         860 :           if ((mask & OMP_CLAUSE_DEVICE)
    3037                 :         341 :               && openacc
    3038                 :         314 :               && gfc_match ("device ( ") == MATCH_YES
    3039                 :         861 :               && gfc_match_omp_map_clause (&c->lists[OMP_LIST_MAP],
    3040                 :             :                                            OMP_MAP_FORCE_TO, true,
    3041                 :             :                                            /* allow_derived = */ true))
    3042                 :         312 :             continue;
    3043                 :         269 :           if ((mask & OMP_CLAUSE_DEVICEPTR)
    3044                 :          83 :               && gfc_match ("deviceptr ( ") == MATCH_YES
    3045                 :         271 :               && gfc_match_omp_map_clause (&c->lists[OMP_LIST_MAP],
    3046                 :             :                                            OMP_MAP_FORCE_DEVICEPTR, false,
    3047                 :             :                                            allow_derived))
    3048                 :          33 :             continue;
    3049                 :         253 :           if ((mask & OMP_CLAUSE_DEVICE_TYPE)
    3050                 :         203 :               && gfc_match ("device_type ( ") == MATCH_YES)
    3051                 :             :             {
    3052                 :          51 :               if (gfc_match ("host") == MATCH_YES)
    3053                 :          17 :                 c->device_type = OMP_DEVICE_TYPE_HOST;
    3054                 :          34 :               else if (gfc_match ("nohost") == MATCH_YES)
    3055                 :          17 :                 c->device_type = OMP_DEVICE_TYPE_NOHOST;
    3056                 :          17 :               else if (gfc_match ("any") == MATCH_YES)
    3057                 :          16 :                 c->device_type = OMP_DEVICE_TYPE_ANY;
    3058                 :             :               else
    3059                 :             :                 {
    3060                 :           1 :                   gfc_error ("Expected HOST, NOHOST or ANY at %C");
    3061                 :           1 :                   break;
    3062                 :             :                 }
    3063                 :          50 :               if (gfc_match (" )") != MATCH_YES)
    3064                 :             :                 break;
    3065                 :          50 :               continue;
    3066                 :             :             }
    3067                 :         199 :           if ((mask & OMP_CLAUSE_DEVICE_RESIDENT)
    3068                 :         200 :               && gfc_match_omp_variable_list
    3069                 :          48 :                    ("device_resident (",
    3070                 :             :                     &c->lists[OMP_LIST_DEVICE_RESIDENT], true) == MATCH_YES)
    3071                 :          47 :             continue;
    3072                 :         105 :           if ((mask & OMP_CLAUSE_DIST_SCHEDULE)
    3073                 :          97 :               && c->dist_sched_kind == OMP_SCHED_NONE
    3074                 :         202 :               && gfc_match ("dist_schedule ( static") == MATCH_YES)
    3075                 :             :             {
    3076                 :          97 :               m = MATCH_NO;
    3077                 :          97 :               c->dist_sched_kind = OMP_SCHED_STATIC;
    3078                 :          97 :               m = gfc_match (" , %e )", &c->dist_chunk_size);
    3079                 :          97 :               if (m != MATCH_YES)
    3080                 :          14 :                 m = gfc_match_char (')');
    3081                 :          14 :               if (m != MATCH_YES)
    3082                 :             :                 {
    3083                 :           0 :                   c->dist_sched_kind = OMP_SCHED_NONE;
    3084                 :           0 :                   gfc_current_locus = old_loc;
    3085                 :             :                 }
    3086                 :             :               else
    3087                 :          97 :                 continue;
    3088                 :             :             }
    3089                 :             :           break;
    3090                 :          82 :         case 'e':
    3091                 :          82 :           if ((mask & OMP_CLAUSE_ENTER))
    3092                 :             :             {
    3093                 :          82 :               m = gfc_match_omp_to_link ("enter (", &c->lists[OMP_LIST_ENTER]);
    3094                 :          82 :               if (m == MATCH_ERROR)
    3095                 :           0 :                 goto error;
    3096                 :          82 :               if (m == MATCH_YES)
    3097                 :          82 :                 continue;
    3098                 :             :             }
    3099                 :             :           break;
    3100                 :        2220 :         case 'f':
    3101                 :        2269 :           if ((mask & OMP_CLAUSE_FAIL)
    3102                 :        2220 :               && (m = gfc_match_dupl_check (c->fail == OMP_MEMORDER_UNSET,
    3103                 :             :                                             "fail", true)) != MATCH_NO)
    3104                 :             :             {
    3105                 :          58 :               if (m == MATCH_ERROR)
    3106                 :           3 :                 goto error;
    3107                 :          55 :               if (gfc_match ("seq_cst") == MATCH_YES)
    3108                 :           6 :                 c->fail = OMP_MEMORDER_SEQ_CST;
    3109                 :          49 :               else if (gfc_match ("acquire") == MATCH_YES)
    3110                 :          14 :                 c->fail = OMP_MEMORDER_ACQUIRE;
    3111                 :          35 :               else if (gfc_match ("relaxed") == MATCH_YES)
    3112                 :          30 :                 c->fail = OMP_MEMORDER_RELAXED;
    3113                 :             :               else
    3114                 :             :                 {
    3115                 :           5 :                   gfc_error ("Expected SEQ_CST, ACQUIRE or RELAXED at %C");
    3116                 :           5 :                   break;
    3117                 :             :                 }
    3118                 :          50 :               if (gfc_match (" )") != MATCH_YES)
    3119                 :           1 :                 goto error;
    3120                 :          49 :               continue;
    3121                 :             :             }
    3122                 :        2205 :           if ((mask & OMP_CLAUSE_FILTER)
    3123                 :        2162 :               && (m = gfc_match_dupl_check (!c->filter, "filter", true,
    3124                 :             :                                             &c->filter)) != MATCH_NO)
    3125                 :             :             {
    3126                 :          44 :               if (m == MATCH_ERROR)
    3127                 :           1 :                 goto error;
    3128                 :          43 :               continue;
    3129                 :             :             }
    3130                 :        2182 :           if ((mask & OMP_CLAUSE_FINAL)
    3131                 :        2118 :               && (m = gfc_match_dupl_check (!c->final_expr, "final", true,
    3132                 :             :                                             &c->final_expr)) != MATCH_NO)
    3133                 :             :             {
    3134                 :          64 :               if (m == MATCH_ERROR)
    3135                 :           0 :                 goto error;
    3136                 :          64 :               continue;
    3137                 :             :             }
    3138                 :        2072 :           if ((mask & OMP_CLAUSE_FINALIZE)
    3139                 :        2054 :               && (m = gfc_match_dupl_check (!c->finalize, "finalize"))
    3140                 :             :                  != MATCH_NO)
    3141                 :             :             {
    3142                 :          18 :               if (m == MATCH_ERROR)
    3143                 :           0 :                 goto error;
    3144                 :          18 :               c->finalize = true;
    3145                 :          18 :               needs_space = true;
    3146                 :          18 :               continue;
    3147                 :             :             }
    3148                 :        2996 :           if ((mask & OMP_CLAUSE_FIRSTPRIVATE)
    3149                 :        2036 :               && gfc_match_omp_variable_list ("firstprivate (",
    3150                 :             :                                               &c->lists[OMP_LIST_FIRSTPRIVATE],
    3151                 :             :                                               true) == MATCH_YES)
    3152                 :         960 :             continue;
    3153                 :        2075 :           if ((mask & OMP_CLAUSE_FROM)
    3154                 :        1076 :               && gfc_match_motion_var_list ("from (", &c->lists[OMP_LIST_FROM],
    3155                 :             :                                              &head) == MATCH_YES)
    3156                 :         999 :             continue;
    3157                 :         142 :           if ((mask & OMP_CLAUSE_FULL)
    3158                 :          77 :               && (m = gfc_match_dupl_check (!c->full, "full")) != MATCH_NO)
    3159                 :             :             {
    3160                 :          65 :               if (m == MATCH_ERROR)
    3161                 :           0 :                 goto error;
    3162                 :          65 :               c->full = needs_space = true;
    3163                 :          65 :               continue;
    3164                 :             :             }
    3165                 :             :           break;
    3166                 :        1230 :         case 'g':
    3167                 :        2421 :           if ((mask & OMP_CLAUSE_GANG)
    3168                 :        1230 :               && (m = gfc_match_dupl_check (!c->gang, "gang")) != MATCH_NO)
    3169                 :             :             {
    3170                 :        1196 :               if (m == MATCH_ERROR)
    3171                 :           0 :                 goto error;
    3172                 :        1196 :               c->gang = true;
    3173                 :        1196 :               m = match_oacc_clause_gwv (c, GOMP_DIM_GANG);
    3174                 :        1196 :               if (m == MATCH_ERROR)
    3175                 :             :                 {
    3176                 :           5 :                   gfc_current_locus = old_loc;
    3177                 :           5 :                   break;
    3178                 :             :                 }
    3179                 :        1191 :               else if (m == MATCH_NO)
    3180                 :         972 :                 needs_space = true;
    3181                 :        1191 :               continue;
    3182                 :             :             }
    3183                 :          68 :           if ((mask & OMP_CLAUSE_GRAINSIZE)
    3184                 :          34 :               && (m = gfc_match_dupl_check (!c->grainsize, "grainsize", true))
    3185                 :             :                  != MATCH_NO)
    3186                 :             :             {
    3187                 :          34 :               if (m == MATCH_ERROR)
    3188                 :           0 :                 goto error;
    3189                 :          34 :               if (gfc_match ("strict : ") == MATCH_YES)
    3190                 :           1 :                 c->grainsize_strict = true;
    3191                 :          34 :               if (gfc_match (" %e )", &c->grainsize) != MATCH_YES)
    3192                 :           0 :                 goto error;
    3193                 :          34 :               continue;
    3194                 :             :             }
    3195                 :             :           break;
    3196                 :         452 :         case 'h':
    3197                 :         488 :           if ((mask & OMP_CLAUSE_HAS_DEVICE_ADDR)
    3198                 :         488 :               && gfc_match_omp_variable_list
    3199                 :          36 :                    ("has_device_addr (", &c->lists[OMP_LIST_HAS_DEVICE_ADDR],
    3200                 :             :                     false, NULL, NULL, true) == MATCH_YES)
    3201                 :          36 :             continue;
    3202                 :         459 :           if ((mask & OMP_CLAUSE_HINT)
    3203                 :         416 :               && (m = gfc_match_dupl_check (!c->hint, "hint", true, &c->hint))
    3204                 :             :                  != MATCH_NO)
    3205                 :             :             {
    3206                 :          43 :               if (m == MATCH_ERROR)
    3207                 :           0 :                 goto error;
    3208                 :          43 :               continue;
    3209                 :             :             }
    3210                 :         373 :           if ((mask & OMP_CLAUSE_ASSUMPTIONS)
    3211                 :         373 :               && gfc_match ("holds ( ") == MATCH_YES)
    3212                 :             :             {
    3213                 :          18 :               gfc_expr *e;
    3214                 :          18 :               if (gfc_match ("%e )", &e) != MATCH_YES)
    3215                 :           0 :                 goto error;
    3216                 :          18 :               if (c->assume == NULL)
    3217                 :          11 :                 c->assume = gfc_get_omp_assumptions ();
    3218                 :          18 :               gfc_expr_list *el = XCNEW (gfc_expr_list);
    3219                 :          18 :               el->expr = e;
    3220                 :          18 :               el->next = c->assume->holds;
    3221                 :          18 :               c->assume->holds = el;
    3222                 :          18 :               continue;
    3223                 :          18 :             }
    3224                 :         709 :           if ((mask & OMP_CLAUSE_HOST)
    3225                 :         355 :               && gfc_match ("host ( ") == MATCH_YES
    3226                 :         710 :               && gfc_match_omp_map_clause (&c->lists[OMP_LIST_MAP],
    3227                 :             :                                            OMP_MAP_FORCE_FROM, true,
    3228                 :             :                                            /* allow_derived = */ true))
    3229                 :         354 :             continue;
    3230                 :             :           break;
    3231                 :        2107 :         case 'i':
    3232                 :        2130 :           if ((mask & OMP_CLAUSE_IF_PRESENT)
    3233                 :        2107 :               && (m = gfc_match_dupl_check (!c->if_present, "if_present"))
    3234                 :             :                  != MATCH_NO)
    3235                 :             :             {
    3236                 :          23 :               if (m == MATCH_ERROR)
    3237                 :           0 :                 goto error;
    3238                 :          23 :               c->if_present = true;
    3239                 :          23 :               needs_space = true;
    3240                 :          23 :               continue;
    3241                 :             :             }
    3242                 :        2084 :           if ((mask & OMP_CLAUSE_IF)
    3243                 :        2084 :               && (m = gfc_match_dupl_check (!c->if_expr, "if", true))
    3244                 :             :                  != MATCH_NO)
    3245                 :             :             {
    3246                 :        1344 :               if (m == MATCH_ERROR)
    3247                 :          18 :                 goto error;
    3248                 :        1326 :               if (!openacc)
    3249                 :             :                 {
    3250                 :             :                   /* This should match the enum gfc_omp_if_kind order.  */
    3251                 :             :                   static const char *ifs[OMP_IF_LAST] = {
    3252                 :             :                     "cancel : %e )",
    3253                 :             :                     "parallel : %e )",
    3254                 :             :                     "simd : %e )",
    3255                 :             :                     "task : %e )",
    3256                 :             :                     "taskloop : %e )",
    3257                 :             :                     "target : %e )",
    3258                 :             :                     "target data : %e )",
    3259                 :             :                     "target update : %e )",
    3260                 :             :                     "target enter data : %e )",
    3261                 :             :                     "target exit data : %e )" };
    3262                 :             :                   int i;
    3263                 :        4808 :                   for (i = 0; i < OMP_IF_LAST; i++)
    3264                 :        4413 :                     if (c->if_exprs[i] == NULL
    3265                 :        4413 :                         && gfc_match (ifs[i], &c->if_exprs[i]) == MATCH_YES)
    3266                 :             :                       break;
    3267                 :         533 :                   if (i < OMP_IF_LAST)
    3268                 :         138 :                     continue;
    3269                 :             :                 }
    3270                 :        1188 :               if (gfc_match (" %e )", &c->if_expr) == MATCH_YES)
    3271                 :        1183 :                 continue;
    3272                 :           5 :               goto error;
    3273                 :             :             }
    3274                 :         857 :           if ((mask & OMP_CLAUSE_IN_REDUCTION)
    3275                 :         740 :               && gfc_match_omp_clause_reduction (pc, c, openacc, allow_derived,
    3276                 :             :                                                  openmp_target) == MATCH_YES)
    3277                 :         117 :             continue;
    3278                 :         648 :           if ((mask & OMP_CLAUSE_INBRANCH)
    3279                 :         623 :               && (m = gfc_match_dupl_check (!c->inbranch && !c->notinbranch,
    3280                 :             :                                             "inbranch")) != MATCH_NO)
    3281                 :             :             {
    3282                 :          25 :               if (m == MATCH_ERROR)
    3283                 :           0 :                 goto error;
    3284                 :          25 :               c->inbranch = needs_space = true;
    3285                 :          25 :               continue;
    3286                 :             :             }
    3287                 :         840 :           if ((mask & OMP_CLAUSE_INDEPENDENT)
    3288                 :         598 :               && (m = gfc_match_dupl_check (!c->independent, "independent"))
    3289                 :             :                  != MATCH_NO)
    3290                 :             :             {
    3291                 :         242 :               if (m == MATCH_ERROR)
    3292                 :           0 :                 goto error;
    3293                 :         242 :               c->independent = true;
    3294                 :         242 :               needs_space = true;
    3295                 :         242 :               continue;
    3296                 :             :             }
    3297                 :         356 :           if ((mask & OMP_CLAUSE_INDIRECT)
    3298                 :         356 :               && (m = gfc_match_dupl_check (!c->indirect, "indirect"))
    3299                 :             :                   != MATCH_NO)
    3300                 :             :             {
    3301                 :          61 :               if (m == MATCH_ERROR)
    3302                 :           5 :                 goto error;
    3303                 :          60 :               gfc_expr *indirect_expr = NULL;
    3304                 :          60 :               m = gfc_match (" ( %e )", &indirect_expr);
    3305                 :          60 :               if (m == MATCH_YES)
    3306                 :             :                 {
    3307                 :          13 :                   if (!gfc_resolve_expr (indirect_expr)
    3308                 :          13 :                       || indirect_expr->ts.type != BT_LOGICAL
    3309                 :          23 :                       || indirect_expr->expr_type != EXPR_CONSTANT)
    3310                 :             :                     {
    3311                 :           4 :                       gfc_error ("INDIRECT clause at %C requires a constant "
    3312                 :             :                                  "logical expression");
    3313                 :           4 :                       gfc_free_expr (indirect_expr);
    3314                 :           4 :                       goto error;
    3315                 :             :                     }
    3316                 :           9 :                   c->indirect = indirect_expr->value.logical;
    3317                 :           9 :                   gfc_free_expr (indirect_expr);
    3318                 :             :                 }
    3319                 :             :               else
    3320                 :          47 :                 c->indirect = 1;
    3321                 :          56 :               continue;
    3322                 :          56 :             }
    3323                 :         295 :           if ((mask & OMP_CLAUSE_INIT)
    3324                 :         295 :               && gfc_match ("init ( ") == MATCH_YES)
    3325                 :             :             {
    3326                 :         108 :               m = gfc_match_omp_init (&c->lists[OMP_LIST_INIT]);
    3327                 :         108 :               if (m == MATCH_YES)
    3328                 :          63 :                 continue;
    3329                 :          45 :               goto error;
    3330                 :             :             }
    3331                 :         187 :           if ((mask & OMP_CLAUSE_INTEROP)
    3332                 :         187 :               && (m = gfc_match_dupl_check (!c->lists[OMP_LIST_INTEROP],
    3333                 :             :                                             "interop", true)) != MATCH_NO)
    3334                 :             :             {
    3335                 :             :               /* Note: the interop objects are saved in reverse order to match
    3336                 :             :                  the order in C/C++.  */
    3337                 :         125 :               if (m == MATCH_YES
    3338                 :          63 :                   && (gfc_match_omp_variable_list ("",
    3339                 :             :                                                    &c->lists[OMP_LIST_INTEROP],
    3340                 :             :                                                    false, NULL, NULL, false,
    3341                 :             :                                                    false, NULL, false, true)
    3342                 :             :                       == MATCH_YES))
    3343                 :          62 :                 continue;
    3344                 :           1 :               goto error;
    3345                 :             :             }
    3346                 :         241 :           if ((mask & OMP_CLAUSE_IS_DEVICE_PTR)
    3347                 :         241 :               && gfc_match_omp_variable_list
    3348                 :         117 :                    ("is_device_ptr (",
    3349                 :             :                     &c->lists[OMP_LIST_IS_DEVICE_PTR], false) == MATCH_YES)
    3350                 :         117 :             continue;
    3351                 :             :           break;
    3352                 :        2314 :         case 'l':
    3353                 :        2314 :           if ((mask & OMP_CLAUSE_LASTPRIVATE)
    3354                 :        2314 :               && gfc_match ("lastprivate ( ") == MATCH_YES)
    3355                 :             :             {
    3356                 :        1431 :               bool conditional = gfc_match ("conditional : ") == MATCH_YES;
    3357                 :        1431 :               head = NULL;
    3358                 :        1431 :               if (gfc_match_omp_variable_list ("",
    3359                 :             :                                                &c->lists[OMP_LIST_LASTPRIVATE],
    3360                 :             :                                                false, NULL, &head) == MATCH_YES)
    3361                 :             :                 {
    3362                 :        1431 :                   gfc_omp_namelist *n;
    3363                 :        3737 :                   for (n = *head; n; n = n->next)
    3364                 :        2306 :                     n->u.lastprivate_conditional = conditional;
    3365                 :        1431 :                   continue;
    3366                 :        1431 :                 }
    3367                 :           0 :               gfc_current_locus = old_loc;
    3368                 :           0 :               break;
    3369                 :             :             }
    3370                 :         883 :           end_colon = false;
    3371                 :         883 :           head = NULL;
    3372                 :         883 :           if ((mask & OMP_CLAUSE_LINEAR)
    3373                 :         883 :               && gfc_match ("linear (") == MATCH_YES)
    3374                 :             :             {
    3375                 :         835 :               bool old_linear_modifier = false;
    3376                 :         835 :               gfc_omp_linear_op linear_op = OMP_LINEAR_DEFAULT;
    3377                 :         835 :               gfc_expr *step = NULL;
    3378                 :             : 
    3379                 :         835 :               if (gfc_match_omp_variable_list (" ref (",
    3380                 :             :                                                &c->lists[OMP_LIST_LINEAR],
    3381                 :             :                                                false, NULL, &head)
    3382                 :             :                   == MATCH_YES)
    3383                 :             :                 {
    3384                 :             :                   linear_op = OMP_LINEAR_REF;
    3385                 :             :                   old_linear_modifier = true;
    3386                 :             :                 }
    3387                 :         806 :               else if (gfc_match_omp_variable_list (" val (",
    3388                 :             :                                                     &c->lists[OMP_LIST_LINEAR],
    3389                 :             :                                                     false, NULL, &head)
    3390                 :             :                        == MATCH_YES)
    3391                 :             :                 {
    3392                 :             :                   linear_op = OMP_LINEAR_VAL;
    3393                 :             :                   old_linear_modifier = true;
    3394                 :             :                 }
    3395                 :         794 :               else if (gfc_match_omp_variable_list (" uval (",
    3396                 :             :                                                     &c->lists[OMP_LIST_LINEAR],
    3397                 :             :                                                     false, NULL, &head)
    3398                 :             :                        == MATCH_YES)
    3399                 :             :                 {
    3400                 :             :                   linear_op = OMP_LINEAR_UVAL;
    3401                 :             :                   old_linear_modifier = true;
    3402                 :             :                 }
    3403                 :         784 :               else if (gfc_match_omp_variable_list ("",
    3404                 :             :                                                     &c->lists[OMP_LIST_LINEAR],
    3405                 :             :                                                     false, &end_colon, &head)
    3406                 :             :                        == MATCH_YES)
    3407                 :             :                 linear_op = OMP_LINEAR_DEFAULT;
    3408                 :             :               else
    3409                 :             :                 {
    3410                 :           2 :                   gfc_current_locus = old_loc;
    3411                 :           2 :                   break;
    3412                 :             :                 }
    3413                 :             :               if (linear_op != OMP_LINEAR_DEFAULT)
    3414                 :             :                 {
    3415                 :          51 :                   if (gfc_match (" :") == MATCH_YES)
    3416                 :          31 :                     end_colon = true;
    3417                 :          20 :                   else if (gfc_match (" )") != MATCH_YES)
    3418                 :             :                     {
    3419                 :           0 :                       gfc_free_omp_namelist (*head, false, false, false, false);
    3420                 :           0 :                       gfc_current_locus = old_loc;
    3421                 :           0 :                       *head = NULL;
    3422                 :           0 :                       break;
    3423                 :             :                     }
    3424                 :             :                 }
    3425                 :         833 :               gfc_gobble_whitespace ();
    3426                 :         833 :               if (old_linear_modifier && end_colon)
    3427                 :             :                 {
    3428                 :          31 :                   if (gfc_match (" %e )", &step) != MATCH_YES)
    3429                 :             :                     {
    3430                 :           1 :                       gfc_free_omp_namelist (*head, false, false, false, false);
    3431                 :           1 :                       gfc_current_locus = old_loc;
    3432                 :           1 :                       *head = NULL;
    3433                 :           5 :                       goto error;
    3434                 :             :                     }
    3435                 :             :                 }
    3436                 :         802 :               else if (end_colon)
    3437                 :             :                 {
    3438                 :         710 :                   bool has_error = false;
    3439                 :             :                   bool has_modifiers = false;
    3440                 :             :                   bool has_step = false;
    3441                 :         710 :                   bool duplicate_step = false;
    3442                 :         710 :                   bool duplicate_mod = false;
    3443                 :         710 :                   while (true)
    3444                 :             :                     {
    3445                 :         710 :                       old_loc = gfc_current_locus;
    3446                 :         710 :                       bool close_paren = gfc_match ("val )") == MATCH_YES;
    3447                 :         710 :                       if (close_paren || gfc_match ("val , ") == MATCH_YES)
    3448                 :             :                         {
    3449                 :          16 :                           if (linear_op != OMP_LINEAR_DEFAULT)
    3450                 :             :                             {
    3451                 :             :                               duplicate_mod = true;
    3452                 :             :                               break;
    3453                 :             :                             }
    3454                 :          15 :                           linear_op = OMP_LINEAR_VAL;
    3455                 :          15 :                           has_modifiers = true;
    3456                 :          15 :                           if (close_paren)
    3457                 :             :                             break;
    3458                 :          10 :                           continue;
    3459                 :             :                         }
    3460                 :         694 :                       close_paren = gfc_match ("uval )") == MATCH_YES;
    3461                 :         694 :                       if (close_paren || gfc_match ("uval , ") == MATCH_YES)
    3462                 :             :                         {
    3463                 :           6 :                           if (linear_op != OMP_LINEAR_DEFAULT)
    3464                 :             :                             {
    3465                 :             :                               duplicate_mod = true;
    3466                 :             :                               break;
    3467                 :             :                             }
    3468                 :           6 :                           linear_op = OMP_LINEAR_UVAL;
    3469                 :           6 :                           has_modifiers = true;
    3470                 :           6 :                           if (close_paren)
    3471                 :             :                             break;
    3472                 :           2 :                           continue;
    3473                 :             :                         }
    3474                 :         688 :                       close_paren = gfc_match ("ref )") == MATCH_YES;
    3475                 :         688 :                       if (close_paren || gfc_match ("ref , ") == MATCH_YES)
    3476                 :             :                         {
    3477                 :          15 :                           if (linear_op != OMP_LINEAR_DEFAULT)
    3478                 :             :                             {
    3479                 :             :                               duplicate_mod = true;
    3480                 :             :                               break;
    3481                 :             :                             }
    3482                 :          14 :                           linear_op = OMP_LINEAR_REF;
    3483                 :          14 :                           has_modifiers = true;
    3484                 :          14 :                           if (close_paren)
    3485                 :             :                             break;
    3486                 :           7 :                           continue;
    3487                 :             :                         }
    3488                 :         673 :                       close_paren = (gfc_match ("step ( %e ) )", &step)
    3489                 :             :                                      == MATCH_YES);
    3490                 :         684 :                       if (close_paren
    3491                 :         673 :                           || gfc_match ("step ( %e ) , ", &step) == MATCH_YES)
    3492                 :             :                         {
    3493                 :          38 :                           if (has_step)
    3494                 :             :                             {
    3495                 :             :                               duplicate_step = true;
    3496                 :             :                               break;
    3497                 :             :                             }
    3498                 :          37 :                           has_modifiers = has_step = true;
    3499                 :          37 :                           if (close_paren)
    3500                 :             :                             break;
    3501                 :          11 :                           continue;
    3502                 :             :                         }
    3503                 :         635 :                       if (!has_modifiers
    3504                 :         635 :                           && gfc_match ("%e )", &step) == MATCH_YES)
    3505                 :             :                         {
    3506                 :         635 :                           if ((step->expr_type == EXPR_FUNCTION
    3507                 :         634 :                                 || step->expr_type == EXPR_VARIABLE)
    3508                 :          31 :                               && strcmp (step->symtree->name, "step") == 0)
    3509                 :             :                             {
    3510                 :           1 :                               gfc_current_locus = old_loc;
    3511                 :           1 :                               gfc_match ("step (");
    3512                 :           1 :                               has_error = true;
    3513                 :             :                             }
    3514                 :             :                           break;
    3515                 :             :                         }
    3516                 :             :                       has_error = true;
    3517                 :             :                       break;
    3518                 :             :                     }
    3519                 :          46 :                   if (duplicate_mod || duplicate_step)
    3520                 :             :                     {
    3521                 :           3 :                       gfc_error ("Multiple %qs modifiers specified at %C",
    3522                 :             :                                  duplicate_mod ? "linear" : "step");
    3523                 :           3 :                       has_error = true;
    3524                 :             :                     }
    3525                 :         680 :                   if (has_error)
    3526                 :             :                     {
    3527                 :           4 :                       gfc_free_omp_namelist (*head, false, false, false, false);
    3528                 :           4 :                       *head = NULL;
    3529                 :           4 :                       goto error;
    3530                 :             :                     }
    3531                 :             :                 }
    3532                 :         828 :               if (step == NULL)
    3533                 :             :                 {
    3534                 :         129 :                   step = gfc_get_constant_expr (BT_INTEGER,
    3535                 :             :                                                 gfc_default_integer_kind,
    3536                 :             :                                                 &old_loc);
    3537                 :         129 :                   mpz_set_si (step->value.integer, 1);
    3538                 :             :                 }
    3539                 :         828 :               (*head)->expr = step;
    3540                 :         828 :               if (linear_op != OMP_LINEAR_DEFAULT || old_linear_modifier)
    3541                 :         176 :                 for (gfc_omp_namelist *n = *head; n; n = n->next)
    3542                 :             :                   {
    3543                 :          94 :                     n->u.linear.op = linear_op;
    3544                 :          94 :                     n->u.linear.old_modifier = old_linear_modifier;
    3545                 :             :                   }
    3546                 :         828 :               continue;
    3547                 :         828 :             }
    3548                 :          52 :           if ((mask & OMP_CLAUSE_LINK)
    3549                 :          48 :               && openacc
    3550                 :          56 :               && (gfc_match_oacc_clause_link ("link (",
    3551                 :             :                                               &c->lists[OMP_LIST_LINK])
    3552                 :             :                   == MATCH_YES))
    3553                 :           4 :             continue;
    3554                 :          84 :           else if ((mask & OMP_CLAUSE_LINK)
    3555                 :          44 :                    && !openacc
    3556                 :          84 :                    && (gfc_match_omp_to_link ("link (",
    3557                 :             :                                               &c->lists[OMP_LIST_LINK])
    3558                 :             :                        == MATCH_YES))
    3559                 :          40 :             continue;
    3560                 :             :           break;
    3561                 :        4876 :         case 'm':
    3562                 :        4876 :           if ((mask & OMP_CLAUSE_MAP)
    3563                 :        4876 :               && gfc_match ("map ( ") == MATCH_YES)
    3564                 :             :             {
    3565                 :        4784 :               locus old_loc2 = gfc_current_locus;
    3566                 :        4784 :               int always_modifier = 0;
    3567                 :        4784 :               int close_modifier = 0;
    3568                 :        4784 :               int present_modifier = 0;
    3569                 :        4784 :               locus second_always_locus = old_loc2;
    3570                 :        4784 :               locus second_close_locus = old_loc2;
    3571                 :        4784 :               locus second_present_locus = old_loc2;
    3572                 :             : 
    3573                 :        5294 :               for (;;)
    3574                 :             :                 {
    3575                 :        5039 :                   locus current_locus = gfc_current_locus;
    3576                 :        5039 :                   if (gfc_match ("always ") == MATCH_YES)
    3577                 :             :                     {
    3578                 :         139 :                       if (always_modifier++ == 1)
    3579                 :           5 :                         second_always_locus = current_locus;
    3580                 :             :                     }
    3581                 :        4900 :                   else if (gfc_match ("close ") == MATCH_YES)
    3582                 :             :                     {
    3583                 :          65 :                       if (close_modifier++ == 1)
    3584                 :           5 :                         second_close_locus = current_locus;
    3585                 :             :                     }
    3586                 :        4835 :                   else if (gfc_match ("present ") == MATCH_YES)
    3587                 :             :                     {
    3588                 :          51 :                       if (present_modifier++ == 1)
    3589                 :           4 :                         second_present_locus = current_locus;
    3590                 :             :                     }
    3591                 :             :                   else
    3592                 :             :                     break;
    3593                 :         255 :                   gfc_match (", ");
    3594                 :         255 :                 }
    3595                 :             : 
    3596                 :        4784 :               gfc_omp_map_op map_op = OMP_MAP_TOFROM;
    3597                 :        4784 :               int always_present_modifier
    3598                 :        4784 :                 = always_modifier && present_modifier;
    3599                 :             : 
    3600                 :        4784 :               if (gfc_match ("alloc : ") == MATCH_YES)
    3601                 :         535 :                 map_op = (present_modifier ? OMP_MAP_PRESENT_ALLOC
    3602                 :             :                           : OMP_MAP_ALLOC);
    3603                 :        4249 :               else if (gfc_match ("tofrom : ") == MATCH_YES)
    3604                 :         831 :                 map_op = (always_present_modifier ? OMP_MAP_ALWAYS_PRESENT_TOFROM
    3605                 :         827 :                           : present_modifier ? OMP_MAP_PRESENT_TOFROM
    3606                 :         823 :                           : always_modifier ? OMP_MAP_ALWAYS_TOFROM
    3607                 :             :                           : OMP_MAP_TOFROM);
    3608                 :        3418 :               else if (gfc_match ("to : ") == MATCH_YES)
    3609                 :        1550 :                 map_op = (always_present_modifier ? OMP_MAP_ALWAYS_PRESENT_TO
    3610                 :        1546 :                           : present_modifier ? OMP_MAP_PRESENT_TO
    3611                 :        1535 :                           : always_modifier ? OMP_MAP_ALWAYS_TO
    3612                 :             :                           : OMP_MAP_TO);
    3613                 :        1868 :               else if (gfc_match ("from : ") == MATCH_YES)
    3614                 :        1423 :                 map_op = (always_present_modifier ? OMP_MAP_ALWAYS_PRESENT_FROM
    3615                 :        1419 :                           : present_modifier ? OMP_MAP_PRESENT_FROM
    3616                 :        1415 :                           : always_modifier ? OMP_MAP_ALWAYS_FROM
    3617                 :             :                           : OMP_MAP_FROM);
    3618                 :         445 :               else if (gfc_match ("release : ") == MATCH_YES)
    3619                 :             :                 map_op = OMP_MAP_RELEASE;
    3620                 :         428 :               else if (gfc_match ("delete : ") == MATCH_YES)
    3621                 :             :                 map_op = OMP_MAP_DELETE;
    3622                 :             :               else
    3623                 :             :                 {
    3624                 :         381 :                   gfc_current_locus = old_loc2;
    3625                 :         381 :                   always_modifier = 0;
    3626                 :         381 :                   close_modifier = 0;
    3627                 :             :                 }
    3628                 :             : 
    3629                 :        1117 :               if (always_modifier > 1)
    3630                 :             :                 {
    3631                 :           5 :                   gfc_error ("too many %<always%> modifiers at %L",
    3632                 :             :                              &second_always_locus);
    3633                 :          21 :                   break;
    3634                 :             :                 }
    3635                 :        4779 :               if (close_modifier > 1)
    3636                 :             :                 {
    3637                 :           4 :                   gfc_error ("too many %<close%> modifiers at %L",
    3638                 :             :                              &second_close_locus);
    3639                 :           4 :                   break;
    3640                 :             :                 }
    3641                 :        4775 :               if (present_modifier > 1)
    3642                 :             :                 {
    3643                 :           4 :                   gfc_error ("too many %<present%> modifiers at %L",
    3644                 :             :                              &second_present_locus);
    3645                 :           4 :                   break;
    3646                 :             :                 }
    3647                 :             : 
    3648                 :        4771 :               head = NULL;
    3649                 :        4771 :               if (gfc_match_omp_variable_list ("", &c->lists[OMP_LIST_MAP],
    3650                 :             :                                                false, NULL, &head,
    3651                 :             :                                                true, true) == MATCH_YES)
    3652                 :             :                 {
    3653                 :        4768 :                   gfc_omp_namelist *n;
    3654                 :       10934 :                   for (n = *head; n; n = n->next)
    3655                 :        6166 :                     n->u.map.op = map_op;
    3656                 :        4768 :                   continue;
    3657                 :        4768 :                 }
    3658                 :           3 :               gfc_current_locus = old_loc;
    3659                 :           3 :               break;
    3660                 :             :             }
    3661                 :         126 :           if ((mask & OMP_CLAUSE_MERGEABLE)
    3662                 :          92 :               && (m = gfc_match_dupl_check (!c->mergeable, "mergeable"))
    3663                 :             :                  != MATCH_NO)
    3664                 :             :             {
    3665                 :          34 :               if (m == MATCH_ERROR)
    3666                 :           0 :                 goto error;
    3667                 :          34 :               c->mergeable = needs_space = true;
    3668                 :          34 :               continue;
    3669                 :             :             }
    3670                 :         111 :           if ((mask & OMP_CLAUSE_MESSAGE)
    3671                 :          58 :               && (m = gfc_match_dupl_check (!c->message, "message", true,
    3672                 :             :                  &c->message)) != MATCH_NO)
    3673                 :             :             {
    3674                 :          58 :               if (m == MATCH_ERROR)
    3675                 :           5 :                 goto error;
    3676                 :          53 :               continue;
    3677                 :             :             }
    3678                 :             :           break;
    3679                 :        2890 :         case 'n':
    3680                 :        2942 :           if ((mask & OMP_CLAUSE_NO_CREATE)
    3681                 :        1343 :               && gfc_match ("no_create ( ") == MATCH_YES
    3682                 :        2942 :               && gfc_match_omp_map_clause (&c->lists[OMP_LIST_MAP],
    3683                 :             :                                            OMP_MAP_IF_PRESENT, true,
    3684                 :             :                                            allow_derived))
    3685                 :          52 :             continue;
    3686                 :        2850 :           if ((mask & OMP_CLAUSE_ASSUMPTIONS)
    3687                 :        2858 :               && (m = gfc_match_dupl_check (!c->assume
    3688                 :          20 :                                             || !c->assume->no_openmp_routines,
    3689                 :             :                                             "no_openmp_routines")) == MATCH_YES)
    3690                 :             :             {
    3691                 :          12 :               if (m == MATCH_ERROR)
    3692                 :             :                 goto error;
    3693                 :          12 :               if (c->assume == NULL)
    3694                 :          12 :                 c->assume = gfc_get_omp_assumptions ();
    3695                 :          12 :               c->assume->no_openmp_routines = needs_space = true;
    3696                 :          12 :               continue;
    3697                 :             :             }
    3698                 :        2828 :           if ((mask & OMP_CLAUSE_ASSUMPTIONS)
    3699                 :        2834 :               && (m = gfc_match_dupl_check (!c->assume || !c->assume->no_openmp,
    3700                 :             :                                             "no_openmp")) == MATCH_YES)
    3701                 :             :             {
    3702                 :           2 :               if (m == MATCH_ERROR)
    3703                 :             :                 goto error;
    3704                 :           2 :               if (c->assume == NULL)
    3705                 :           2 :                 c->assume = gfc_get_omp_assumptions ();
    3706                 :           2 :               c->assume->no_openmp = needs_space = true;
    3707                 :           2 :               continue;
    3708                 :             :             }
    3709                 :        2830 :           if ((mask & OMP_CLAUSE_ASSUMPTIONS)
    3710                 :        2830 :               && (m = gfc_match_dupl_check (!c->assume
    3711                 :           6 :                                             || !c->assume->no_parallelism,
    3712                 :             :                                             "no_parallelism")) == MATCH_YES)
    3713                 :             :             {
    3714                 :           6 :               if (m == MATCH_ERROR)
    3715                 :             :                 goto error;
    3716                 :           6 :               if (c->assume == NULL)
    3717                 :           6 :                 c->assume = gfc_get_omp_assumptions ();
    3718                 :           6 :               c->assume->no_parallelism = needs_space = true;
    3719                 :           6 :               continue;
    3720                 :             :             }
    3721                 :             : 
    3722                 :        2828 :           if ((mask & OMP_CLAUSE_NOVARIANTS)
    3723                 :        2818 :               && (m = gfc_match_dupl_check (!c->novariants, "novariants", true,
    3724                 :             :                                             &c->novariants))
    3725                 :             :                    != MATCH_NO)
    3726                 :             :             {
    3727                 :          12 :               if (m == MATCH_ERROR)
    3728                 :           2 :                 goto error;
    3729                 :          10 :               continue;
    3730                 :             :             }
    3731                 :        2819 :           if ((mask & OMP_CLAUSE_NOCONTEXT)
    3732                 :        2806 :               && (m = gfc_match_dupl_check (!c->nocontext, "nocontext", true,
    3733                 :             :                                             &c->nocontext))
    3734                 :             :                    != MATCH_NO)
    3735                 :             :             {
    3736                 :          15 :               if (m == MATCH_ERROR)
    3737                 :           2 :                 goto error;
    3738                 :          13 :               continue;
    3739                 :             :             }
    3740                 :        2805 :           if ((mask & OMP_CLAUSE_NOGROUP)
    3741                 :        2791 :               && (m = gfc_match_dupl_check (!c->nogroup, "nogroup"))
    3742                 :             :                  != MATCH_NO)
    3743                 :             :             {
    3744                 :          14 :               if (m == MATCH_ERROR)
    3745                 :           0 :                 goto error;
    3746                 :          14 :               c->nogroup = needs_space = true;
    3747                 :          14 :               continue;
    3748                 :             :             }
    3749                 :        2927 :           if ((mask & OMP_CLAUSE_NOHOST)
    3750                 :        2777 :               && (m = gfc_match_dupl_check (!c->nohost, "nohost")) != MATCH_NO)
    3751                 :             :             {
    3752                 :         151 :               if (m == MATCH_ERROR)
    3753                 :           1 :                 goto error;
    3754                 :         150 :               c->nohost = needs_space = true;
    3755                 :         150 :               continue;
    3756                 :             :             }
    3757                 :        2668 :           if ((mask & OMP_CLAUSE_NOTEMPORAL)
    3758                 :        2626 :               && gfc_match_omp_variable_list ("nontemporal (",
    3759                 :             :                                               &c->lists[OMP_LIST_NONTEMPORAL],
    3760                 :             :                                               true) == MATCH_YES)
    3761                 :          42 :             continue;
    3762                 :        2608 :           if ((mask & OMP_CLAUSE_NOTINBRANCH)
    3763                 :        2584 :               && (m = gfc_match_dupl_check (!c->notinbranch && !c->inbranch,
    3764                 :             :                                             "notinbranch")) != MATCH_NO)
    3765                 :             :             {
    3766                 :          25 :               if (m == MATCH_ERROR)
    3767                 :           1 :                 goto error;
    3768                 :          24 :               c->notinbranch = needs_space = true;
    3769                 :          24 :               continue;
    3770                 :             :             }
    3771                 :        2686 :           if ((mask & OMP_CLAUSE_NOWAIT)
    3772                 :        2559 :               && (m = gfc_match_dupl_check (!c->nowait, "nowait")) != MATCH_NO)
    3773                 :             :             {
    3774                 :         130 :               if (m == MATCH_ERROR)
    3775                 :           3 :                 goto error;
    3776                 :         127 :               c->nowait = needs_space = true;
    3777                 :         127 :               continue;
    3778                 :             :             }
    3779                 :        3111 :           if ((mask & OMP_CLAUSE_NUM_GANGS)
    3780                 :        2429 :               && (m = gfc_match_dupl_check (!c->num_gangs_expr, "num_gangs",
    3781                 :             :                                             true)) != MATCH_NO)
    3782                 :             :             {
    3783                 :         686 :               if (m == MATCH_ERROR)
    3784                 :           2 :                 goto error;
    3785                 :         684 :               if (gfc_match (" %e )", &c->num_gangs_expr) != MATCH_YES)
    3786                 :           2 :                 goto error;
    3787                 :         682 :               continue;
    3788                 :             :             }
    3789                 :        1769 :           if ((mask & OMP_CLAUSE_NUM_TASKS)
    3790                 :        1743 :               && (m = gfc_match_dupl_check (!c->num_tasks, "num_tasks", true))
    3791                 :             :                  != MATCH_NO)
    3792                 :             :             {
    3793                 :          26 :               if (m == MATCH_ERROR)
    3794                 :           0 :                 goto error;
    3795                 :          26 :               if (gfc_match ("strict : ") == MATCH_YES)
    3796                 :           1 :                 c->num_tasks_strict = true;
    3797                 :          26 :               if (gfc_match (" %e )", &c->num_tasks) != MATCH_YES)
    3798                 :           0 :                 goto error;
    3799                 :          26 :               continue;
    3800                 :             :             }
    3801                 :        1844 :           if ((mask & OMP_CLAUSE_NUM_TEAMS)
    3802                 :        1717 :               && (m = gfc_match_dupl_check (!c->num_teams_upper, "num_teams",
    3803                 :             :                                             true)) != MATCH_NO)
    3804                 :             :             {
    3805                 :         127 :               if (m == MATCH_ERROR)
    3806                 :           0 :                 goto error;
    3807                 :         127 :               if (gfc_match ("%e ", &c->num_teams_upper) != MATCH_YES)
    3808                 :           0 :                 goto error;
    3809                 :         127 :               if (gfc_peek_ascii_char () == ':')
    3810                 :             :                 {
    3811                 :          21 :                   c->num_teams_lower = c->num_teams_upper;
    3812                 :          21 :                   c->num_teams_upper = NULL;
    3813                 :          21 :                   if (gfc_match (": %e ", &c->num_teams_upper) != MATCH_YES)
    3814                 :           0 :                     goto error;
    3815                 :             :                 }
    3816                 :         127 :               if (gfc_match (") ") != MATCH_YES)
    3817                 :           0 :                 goto error;
    3818                 :         127 :               continue;
    3819                 :             :             }
    3820                 :        2540 :           if ((mask & OMP_CLAUSE_NUM_THREADS)
    3821                 :        1590 :               && (m = gfc_match_dupl_check (!c->num_threads, "num_threads", true,
    3822                 :             :                                             &c->num_threads)) != MATCH_NO)
    3823                 :             :             {
    3824                 :         950 :               if (m == MATCH_ERROR)
    3825                 :           0 :                 goto error;
    3826                 :         950 :               continue;
    3827                 :             :             }
    3828                 :        1239 :           if ((mask & OMP_CLAUSE_NUM_WORKERS)
    3829                 :         640 :               && (m = gfc_match_dupl_check (!c->num_workers_expr, "num_workers",
    3830                 :             :                                             true, &c->num_workers_expr))
    3831                 :             :                  != MATCH_NO)
    3832                 :             :             {
    3833                 :         603 :               if (m == MATCH_ERROR)
    3834                 :           4 :                 goto error;
    3835                 :         599 :               continue;
    3836                 :             :             }
    3837                 :             :           break;
    3838                 :         589 :         case 'o':
    3839                 :         823 :           if ((mask & OMP_CLAUSE_ORDER)
    3840                 :         589 :               && (m = gfc_match_dupl_check (!c->order_concurrent, "order ("))
    3841                 :             :                  != MATCH_NO)
    3842                 :             :             {
    3843                 :         245 :               if (m == MATCH_ERROR)
    3844                 :           8 :                 goto error;
    3845                 :         237 :               if (gfc_match (" reproducible : concurrent )") == MATCH_YES)
    3846                 :          55 :                 c->order_reproducible = true;
    3847                 :         182 :               else if (gfc_match (" concurrent )") == MATCH_YES)
    3848                 :             :                 ;
    3849                 :          50 :               else if (gfc_match (" unconstrained : concurrent )") == MATCH_YES)
    3850                 :          47 :                 c->order_unconstrained = true;
    3851                 :             :               else
    3852                 :             :                 {
    3853                 :           3 :                   gfc_error ("Expected ORDER(CONCURRENT) at %C "
    3854                 :             :                              "with optional %<reproducible%> or "
    3855                 :             :                              "%<unconstrained%> modifier");
    3856                 :           3 :                   goto error;
    3857                 :             :                 }
    3858                 :         234 :               c->order_concurrent = true;
    3859                 :         234 :               continue;
    3860                 :             :             }
    3861                 :         344 :           if ((mask & OMP_CLAUSE_ORDERED)
    3862                 :         344 :               && (m = gfc_match_dupl_check (!c->ordered, "ordered"))
    3863                 :             :                  != MATCH_NO)
    3864                 :             :             {
    3865                 :         341 :               if (m == MATCH_ERROR)
    3866                 :           0 :                 goto error;
    3867                 :         341 :               gfc_expr *cexpr = NULL;
    3868                 :         341 :               m = gfc_match (" ( %e )", &cexpr);
    3869                 :             : 
    3870                 :         341 :               c->ordered = true;
    3871                 :         341 :               if (m == MATCH_YES)
    3872                 :             :                 {
    3873                 :         142 :                   int ordered = 0;
    3874                 :         142 :                   if (gfc_extract_int (cexpr, &ordered, -1))
    3875                 :           0 :                     ordered = 0;
    3876                 :         142 :                   else if (ordered <= 0)
    3877                 :             :                     {
    3878                 :           0 :                       gfc_error_now ("ORDERED clause argument not"
    3879                 :             :                                      " constant positive integer at %C");
    3880                 :           0 :                       ordered = 0;
    3881                 :             :                     }
    3882                 :         142 :                   c->orderedc = ordered;
    3883                 :         142 :                   gfc_free_expr (cexpr);
    3884                 :         142 :                   continue;
    3885                 :         142 :                 }
    3886                 :             : 
    3887                 :         199 :               needs_space = true;
    3888                 :         199 :               continue;
    3889                 :         199 :             }
    3890                 :             :           break;
    3891                 :        3075 :         case 'p':
    3892                 :        3075 :           if (mask & OMP_CLAUSE_PARTIAL)
    3893                 :             :             {
    3894                 :         276 :               if ((m = gfc_match_dupl_check (!c->partial, "partial"))
    3895                 :             :                   != MATCH_NO)
    3896                 :             :                 {
    3897                 :         276 :                   int expr;
    3898                 :         276 :                   if (m == MATCH_ERROR)
    3899                 :           0 :                     goto error;
    3900                 :             : 
    3901                 :         276 :                   c->partial = -1;
    3902                 :             : 
    3903                 :         276 :                   gfc_expr *cexpr = NULL;
    3904                 :         276 :                   m = gfc_match (" ( %e )", &cexpr);
    3905                 :         276 :                   if (m == MATCH_NO)
    3906                 :             :                     ;
    3907                 :         251 :                   else if (m == MATCH_YES
    3908                 :         251 :                            && !gfc_extract_int (cexpr, &expr, -1)
    3909                 :         502 :                            && expr > 0)
    3910                 :         247 :                     c->partial = expr;
    3911                 :             :                   else
    3912                 :           4 :                     gfc_error_now ("PARTIAL clause argument not constant "
    3913                 :             :                                    "positive integer at %C");
    3914                 :         276 :                   gfc_free_expr (cexpr);
    3915                 :         276 :                   continue;
    3916                 :         276 :                 }
    3917                 :             :             }
    3918                 :        2868 :           if ((mask & OMP_CLAUSE_COPY)
    3919                 :         875 :               && gfc_match ("pcopy ( ") == MATCH_YES
    3920                 :        2869 :               && gfc_match_omp_map_clause (&c->lists[OMP_LIST_MAP],
    3921                 :             :                                            OMP_MAP_TOFROM, true, allow_derived))
    3922                 :          69 :             continue;
    3923                 :        2804 :           if ((mask & OMP_CLAUSE_COPYIN)
    3924                 :        1902 :               && gfc_match ("pcopyin ( ") == MATCH_YES
    3925                 :        2804 :               && gfc_match_omp_map_clause (&c->lists[OMP_LIST_MAP],
    3926                 :             :                                            OMP_MAP_TO, true, allow_derived))
    3927                 :          74 :             continue;
    3928                 :        2729 :           if ((mask & OMP_CLAUSE_COPYOUT)
    3929                 :         733 :               && gfc_match ("pcopyout ( ") == MATCH_YES
    3930                 :        2729 :               && gfc_match_omp_map_clause (&c->lists[OMP_LIST_MAP],
    3931                 :             :                                            OMP_MAP_FROM, true, allow_derived))
    3932                 :          73 :             continue;
    3933                 :        2598 :           if ((mask & OMP_CLAUSE_CREATE)
    3934                 :         670 :               && gfc_match ("pcreate ( ") == MATCH_YES
    3935                 :        2598 :               && gfc_match_omp_map_clause (&c->lists[OMP_LIST_MAP],
    3936                 :             :                                            OMP_MAP_ALLOC, true, allow_derived))
    3937                 :          15 :             continue;
    3938                 :        2984 :           if ((mask & OMP_CLAUSE_PRESENT)
    3939                 :         645 :               && gfc_match ("present ( ") == MATCH_YES
    3940                 :        2986 :               && gfc_match_omp_map_clause (&c->lists[OMP_LIST_MAP],
    3941                 :             :                                            OMP_MAP_FORCE_PRESENT, false,
    3942                 :             :                                            allow_derived))
    3943                 :         416 :             continue;
    3944                 :        2175 :           if ((mask & OMP_CLAUSE_COPY)
    3945                 :         229 :               && gfc_match ("present_or_copy ( ") == MATCH_YES
    3946                 :        2175 :               && gfc_match_omp_map_clause (&c->lists[OMP_LIST_MAP],
    3947                 :             :                                            OMP_MAP_TOFROM, true,
    3948                 :             :                                            allow_derived))
    3949                 :          23 :             continue;
    3950                 :        2169 :           if ((mask & OMP_CLAUSE_COPYIN)
    3951                 :        1301 :               && gfc_match ("present_or_copyin ( ") == MATCH_YES
    3952                 :        2169 :               && gfc_match_omp_map_clause (&c->lists[OMP_LIST_MAP],
    3953                 :             :                                            OMP_MAP_TO, true, allow_derived))
    3954                 :          40 :             continue;
    3955                 :        2124 :           if ((mask & OMP_CLAUSE_COPYOUT)
    3956                 :         171 :               && gfc_match ("present_or_copyout ( ") == MATCH_YES
    3957                 :        2124 :               && gfc_match_omp_map_clause (&c->lists[OMP_LIST_MAP],
    3958                 :             :                                            OMP_MAP_FROM, true, allow_derived))
    3959                 :          35 :             continue;
    3960                 :        2082 :           if ((mask & OMP_CLAUSE_CREATE)
    3961                 :         141 :               && gfc_match ("present_or_create ( ") == MATCH_YES
    3962                 :        2082 :               && gfc_match_omp_map_clause (&c->lists[OMP_LIST_MAP],
    3963                 :             :                                            OMP_MAP_ALLOC, true, allow_derived))
    3964                 :          28 :             continue;
    3965                 :        2060 :           if ((mask & OMP_CLAUSE_PRIORITY)
    3966                 :        2026 :               && (m = gfc_match_dupl_check (!c->priority, "priority", true,
    3967                 :             :                                             &c->priority)) != MATCH_NO)
    3968                 :             :             {
    3969                 :          34 :               if (m == MATCH_ERROR)
    3970                 :           0 :                 goto error;
    3971                 :          34 :               continue;
    3972                 :             :             }
    3973                 :        3907 :           if ((mask & OMP_CLAUSE_PRIVATE)
    3974                 :        1992 :               && gfc_match_omp_variable_list ("private (",
    3975                 :             :                                               &c->lists[OMP_LIST_PRIVATE],
    3976                 :             :                                               true) == MATCH_YES)
    3977                 :        1915 :             continue;
    3978                 :         141 :           if ((mask & OMP_CLAUSE_PROC_BIND)
    3979                 :         141 :               && (m = gfc_match_dupl_check ((c->proc_bind
    3980                 :          64 :                                              == OMP_PROC_BIND_UNKNOWN),
    3981                 :             :                                             "proc_bind", true)) != MATCH_NO)
    3982                 :             :             {
    3983                 :          64 :               if (m == MATCH_ERROR)
    3984                 :           0 :                 goto error;
    3985                 :          64 :               if (gfc_match ("primary )") == MATCH_YES)
    3986                 :           1 :                 c->proc_bind = OMP_PROC_BIND_PRIMARY;
    3987                 :          63 :               else if (gfc_match ("master )") == MATCH_YES)
    3988                 :           9 :                 c->proc_bind = OMP_PROC_BIND_MASTER;
    3989                 :          54 :               else if (gfc_match ("spread )") == MATCH_YES)
    3990                 :          53 :                 c->proc_bind = OMP_PROC_BIND_SPREAD;
    3991                 :           1 :               else if (gfc_match ("close )") == MATCH_YES)
    3992                 :           1 :                 c->proc_bind = OMP_PROC_BIND_CLOSE;
    3993                 :             :               else
    3994                 :           0 :                 goto error;
    3995                 :          64 :               continue;
    3996                 :             :             }
    3997                 :             :           break;
    3998                 :        4576 :         case 'r':
    3999                 :        5066 :           if ((mask & OMP_CLAUSE_ATOMIC)
    4000                 :        4576 :               && (m = gfc_match_dupl_atomic ((c->atomic_op
    4001                 :             :                                               == GFC_OMP_ATOMIC_UNSET),
    4002                 :             :                                              "read")) != MATCH_NO)
    4003                 :             :             {
    4004                 :         490 :               if (m == MATCH_ERROR)
    4005                 :           0 :                 goto error;
    4006                 :         490 :               c->atomic_op = GFC_OMP_ATOMIC_READ;
    4007                 :         490 :               needs_space = true;
    4008                 :         490 :               continue;
    4009                 :             :             }
    4010                 :        8135 :           if ((mask & OMP_CLAUSE_REDUCTION)
    4011                 :        4086 :               && gfc_match_omp_clause_reduction (pc, c, openacc,
    4012                 :             :                                                  allow_derived) == MATCH_YES)
    4013                 :        4049 :             continue;
    4014                 :          47 :           if ((mask & OMP_CLAUSE_MEMORDER)
    4015                 :          65 :               && (m = gfc_match_dupl_memorder ((c->memorder
    4016                 :          28 :                                                 == OMP_MEMORDER_UNSET),
    4017                 :             :                                                "relaxed")) != MATCH_NO)
    4018                 :             :             {
    4019                 :          10 :               if (m == MATCH_ERROR)
    4020                 :           0 :                 goto error;
    4021                 :          10 :               c->memorder = OMP_MEMORDER_RELAXED;
    4022                 :          10 :               needs_space = true;
    4023                 :          10 :               continue;
    4024                 :             :             }
    4025                 :          44 :           if ((mask & OMP_CLAUSE_MEMORDER)
    4026                 :          45 :               && (m = gfc_match_dupl_memorder ((c->memorder
    4027                 :          18 :                                                 == OMP_MEMORDER_UNSET),
    4028                 :             :                                                "release")) != MATCH_NO)
    4029                 :             :             {
    4030                 :          18 :               if (m == MATCH_ERROR)
    4031                 :           1 :                 goto error;
    4032                 :          17 :               c->memorder = OMP_MEMORDER_RELEASE;
    4033                 :          17 :               needs_space = true;
    4034                 :          17 :               continue;
    4035                 :             :             }
    4036                 :             :           break;
    4037                 :        3023 :         case 's':
    4038                 :        3116 :           if ((mask & OMP_CLAUSE_SAFELEN)
    4039                 :        3023 :               && (m = gfc_match_dupl_check (!c->safelen_expr, "safelen",
    4040                 :             :                                             true, &c->safelen_expr))
    4041                 :             :                  != MATCH_NO)
    4042                 :             :             {
    4043                 :          93 :               if (m == MATCH_ERROR)
    4044                 :           0 :                 goto error;
    4045                 :          93 :               continue;
    4046                 :             :             }
    4047                 :        2930 :           if ((mask & OMP_CLAUSE_SCHEDULE)
    4048                 :        2930 :               && (m = gfc_match_dupl_check (c->sched_kind == OMP_SCHED_NONE,
    4049                 :             :                                             "schedule", true)) != MATCH_NO)
    4050                 :             :             {
    4051                 :         809 :               if (m == MATCH_ERROR)
    4052                 :           0 :                 goto error;
    4053                 :         809 :               int nmodifiers = 0;
    4054                 :         809 :               locus old_loc2 = gfc_current_locus;
    4055                 :         827 :               do
    4056                 :             :                 {
    4057                 :         818 :                   if (gfc_match ("simd") == MATCH_YES)
    4058                 :             :                     {
    4059                 :          18 :                       c->sched_simd = true;
    4060                 :          18 :                       nmodifiers++;
    4061                 :             :                     }
    4062                 :         800 :                   else if (gfc_match ("monotonic") == MATCH_YES)
    4063                 :             :                     {
    4064                 :          30 :                       c->sched_monotonic = true;
    4065                 :          30 :                       nmodifiers++;
    4066                 :             :                     }
    4067                 :         770 :                   else if (gfc_match ("nonmonotonic") == MATCH_YES)
    4068                 :             :                     {
    4069                 :          35 :                       c->sched_nonmonotonic = true;
    4070                 :          35 :                       nmodifiers++;
    4071                 :             :                     }
    4072                 :             :                   else
    4073                 :             :                     {
    4074                 :         735 :                       if (nmodifiers)
    4075                 :           0 :                         gfc_current_locus = old_loc2;
    4076                 :             :                       break;
    4077                 :             :                     }
    4078                 :          92 :                   if (nmodifiers == 1
    4079                 :          83 :                       && gfc_match (" , ") == MATCH_YES)
    4080                 :           9 :                     continue;
    4081                 :          74 :                   else if (gfc_match (" : ") == MATCH_YES)
    4082                 :             :                     break;
    4083                 :           0 :                   gfc_current_locus = old_loc2;
    4084                 :           0 :                   break;
    4085                 :             :                 }
    4086                 :             :               while (1);
    4087                 :         809 :               if (gfc_match ("static") == MATCH_YES)
    4088                 :         425 :                 c->sched_kind = OMP_SCHED_STATIC;
    4089                 :         384 :               else if (gfc_match ("dynamic") == MATCH_YES)
    4090                 :         164 :                 c->sched_kind = OMP_SCHED_DYNAMIC;
    4091                 :         220 :               else if (gfc_match ("guided") == MATCH_YES)
    4092                 :         127 :                 c->sched_kind = OMP_SCHED_GUIDED;
    4093                 :          93 :               else if (gfc_match ("runtime") == MATCH_YES)
    4094                 :          85 :                 c->sched_kind = OMP_SCHED_RUNTIME;
    4095                 :           8 :               else if (gfc_match ("auto") == MATCH_YES)
    4096                 :           8 :                 c->sched_kind = OMP_SCHED_AUTO;
    4097                 :         809 :               if (c->sched_kind != OMP_SCHED_NONE)
    4098                 :             :                 {
    4099                 :         809 :                   m = MATCH_NO;
    4100                 :         809 :                   if (c->sched_kind != OMP_SCHED_RUNTIME
    4101                 :         809 :                       && c->sched_kind != OMP_SCHED_AUTO)
    4102                 :         716 :                     m = gfc_match (" , %e )", &c->chunk_size);
    4103                 :         716 :                   if (m != MATCH_YES)
    4104                 :         299 :                     m = gfc_match_char (')');
    4105                 :         299 :                   if (m != MATCH_YES)
    4106                 :           0 :                     c->sched_kind = OMP_SCHED_NONE;
    4107                 :             :                 }
    4108                 :         809 :               if (c->sched_kind != OMP_SCHED_NONE)
    4109                 :         809 :                 continue;
    4110                 :             :               else
    4111                 :           0 :                 gfc_current_locus = old_loc;
    4112                 :             :             }
    4113                 :        2304 :           if ((mask & OMP_CLAUSE_SELF)
    4114                 :         335 :               && !(mask & OMP_CLAUSE_HOST) /* OpenACC compute construct */
    4115                 :        2361 :               && (m = gfc_match_dupl_check (!c->self_expr, "self"))
    4116                 :             :                   != MATCH_NO)
    4117                 :             :             {
    4118                 :         186 :               if (m == MATCH_ERROR)
    4119                 :           3 :                 goto error;
    4120                 :         183 :               m = gfc_match (" ( %e )", &c->self_expr);
    4121                 :         183 :               if (m == MATCH_ERROR)
    4122                 :             :                 {
    4123                 :           0 :                   gfc_current_locus = old_loc;
    4124                 :           0 :                   break;
    4125                 :             :                 }
    4126                 :         183 :               else if (m == MATCH_NO)
    4127                 :             :                 {
    4128                 :           9 :                   c->self_expr = gfc_get_logical_expr (gfc_default_logical_kind,
    4129                 :             :                                                        NULL, true);
    4130                 :           9 :                   needs_space = true;
    4131                 :             :                 }
    4132                 :         183 :               continue;
    4133                 :             :             }
    4134                 :        2029 :           if ((mask & OMP_CLAUSE_SELF)
    4135                 :         149 :               && (mask & OMP_CLAUSE_HOST) /* OpenACC 'update' directive */
    4136                 :          95 :               && gfc_match ("self ( ") == MATCH_YES
    4137                 :        2030 :               && gfc_match_omp_map_clause (&c->lists[OMP_LIST_MAP],
    4138                 :             :                                            OMP_MAP_FORCE_FROM, true,
    4139                 :             :                                            /* allow_derived = */ true))
    4140                 :          94 :             continue;
    4141                 :        2189 :           if ((mask & OMP_CLAUSE_SEQ)
    4142                 :        1841 :               && (m = gfc_match_dupl_check (!c->seq, "seq")) != MATCH_NO)
    4143                 :             :             {
    4144                 :         348 :               if (m == MATCH_ERROR)
    4145                 :           0 :                 goto error;
    4146                 :         348 :               c->seq = true;
    4147                 :         348 :               needs_space = true;
    4148                 :         348 :               continue;
    4149                 :             :             }
    4150                 :        1634 :           if ((mask & OMP_CLAUSE_MEMORDER)
    4151                 :        1634 :               && (m = gfc_match_dupl_memorder ((c->memorder
    4152                 :         141 :                                                 == OMP_MEMORDER_UNSET),
    4153                 :             :                                                "seq_cst")) != MATCH_NO)
    4154                 :             :             {
    4155                 :         141 :               if (m == MATCH_ERROR)
    4156                 :           0 :                 goto error;
    4157                 :         141 :               c->memorder = OMP_MEMORDER_SEQ_CST;
    4158                 :         141 :               needs_space = true;
    4159                 :         141 :               continue;
    4160                 :             :             }
    4161                 :        2315 :           if ((mask & OMP_CLAUSE_SHARED)
    4162                 :        1352 :               && gfc_match_omp_variable_list ("shared (",
    4163                 :             :                                               &c->lists[OMP_LIST_SHARED],
    4164                 :             :                                               true) == MATCH_YES)
    4165                 :         963 :             continue;
    4166                 :         507 :           if ((mask & OMP_CLAUSE_SIMDLEN)
    4167                 :         389 :               && (m = gfc_match_dupl_check (!c->simdlen_expr, "simdlen", true,
    4168                 :             :                                             &c->simdlen_expr)) != MATCH_NO)
    4169                 :             :             {
    4170                 :         118 :               if (m == MATCH_ERROR)
    4171                 :           0 :                 goto error;
    4172                 :         118 :               continue;
    4173                 :             :             }
    4174                 :         293 :           if ((mask & OMP_CLAUSE_SIMD)
    4175                 :         271 :               && (m = gfc_match_dupl_check (!c->simd, "simd")) != MATCH_NO)
    4176                 :             :             {
    4177                 :          22 :               if (m == MATCH_ERROR)
    4178                 :           0 :                 goto error;
    4179                 :          22 :               c->simd = needs_space = true;
    4180                 :          22 :               continue;
    4181                 :             :             }
    4182                 :         288 :           if ((mask & OMP_CLAUSE_SEVERITY)
    4183                 :         249 :               && (m = gfc_match_dupl_check (!c->severity, "severity", true))
    4184                 :             :                  != MATCH_NO)
    4185                 :             :             {
    4186                 :          45 :               if (m == MATCH_ERROR)
    4187                 :           2 :                 goto error;
    4188                 :          43 :               if (gfc_match ("fatal )") == MATCH_YES)
    4189                 :          10 :                 c->severity = OMP_SEVERITY_FATAL;
    4190                 :          33 :               else if (gfc_match ("warning )") == MATCH_YES)
    4191                 :          29 :                 c->severity = OMP_SEVERITY_WARNING;
    4192                 :             :               else
    4193                 :             :                 {
    4194                 :           4 :                   gfc_error ("Expected FATAL or WARNING in SEVERITY clause "
    4195                 :             :                              "at %C");
    4196                 :           4 :                   goto error;
    4197                 :             :                 }
    4198                 :          39 :               continue;
    4199                 :             :             }
    4200                 :         204 :           if ((mask & OMP_CLAUSE_SIZES)
    4201                 :         204 :               && ((m = gfc_match_dupl_check (!c->sizes_list, "sizes"))
    4202                 :             :                   != MATCH_NO))
    4203                 :             :             {
    4204                 :         203 :               if (m == MATCH_ERROR)
    4205                 :           0 :                 goto error;
    4206                 :         203 :               m = match_omp_oacc_expr_list (" (", &c->sizes_list, false, true);
    4207                 :         203 :               if (m == MATCH_ERROR)
    4208                 :           7 :                 goto error;
    4209                 :         196 :               if (m == MATCH_YES)
    4210                 :         195 :                 continue;
    4211                 :           1 :               gfc_error ("Expected %<(%> after %qs at %C", "sizes");
    4212                 :           1 :               goto error;
    4213                 :             :             }
    4214                 :             :           break;
    4215                 :        1196 :         case 't':
    4216                 :        1261 :           if ((mask & OMP_CLAUSE_TASK_REDUCTION)
    4217                 :        1196 :               && gfc_match_omp_clause_reduction (pc, c, openacc,
    4218                 :             :                                                  allow_derived) == MATCH_YES)
    4219                 :          65 :             continue;
    4220                 :        1203 :           if ((mask & OMP_CLAUSE_THREAD_LIMIT)
    4221                 :        1131 :               && (m = gfc_match_dupl_check (!c->thread_limit, "thread_limit",
    4222                 :             :                                             true, &c->thread_limit))
    4223                 :             :                  != MATCH_NO)
    4224                 :             :             {
    4225                 :          72 :               if (m == MATCH_ERROR)
    4226                 :           0 :                 goto error;
    4227                 :          72 :               continue;
    4228                 :             :             }
    4229                 :        1072 :           if ((mask & OMP_CLAUSE_THREADS)
    4230                 :        1059 :               && (m = gfc_match_dupl_check (!c->threads, "threads"))
    4231                 :             :                  != MATCH_NO)
    4232                 :             :             {
    4233                 :          13 :               if (m == MATCH_ERROR)
    4234                 :           0 :                 goto error;
    4235                 :          13 :               c->threads = needs_space = true;
    4236                 :          13 :               continue;
    4237                 :             :             }
    4238                 :        1243 :           if ((mask & OMP_CLAUSE_TILE)
    4239                 :         221 :               && !c->tile_list
    4240                 :        1267 :               && match_omp_oacc_expr_list ("tile (", &c->tile_list,
    4241                 :             :                                            true, false) == MATCH_YES)
    4242                 :         197 :             continue;
    4243                 :         849 :           if ((mask & OMP_CLAUSE_TO) && (mask & OMP_CLAUSE_LINK))
    4244                 :             :             {
    4245                 :             :               /* Declare target: 'to' is an alias for 'enter';
    4246                 :             :                  'to' is deprecated since 5.2.  */
    4247                 :         109 :               m = gfc_match_omp_to_link ("to (", &c->lists[OMP_LIST_TO]);
    4248                 :         109 :               if (m == MATCH_ERROR)
    4249                 :           0 :                 goto error;
    4250                 :         109 :               if (m == MATCH_YES)
    4251                 :         109 :                 continue;
    4252                 :             :             }
    4253                 :        1456 :           else if ((mask & OMP_CLAUSE_TO)
    4254                 :         740 :                    && gfc_match_motion_var_list ("to (", &c->lists[OMP_LIST_TO],
    4255                 :             :                                                  &head) == MATCH_YES)
    4256                 :         716 :             continue;
    4257                 :             :           break;
    4258                 :        1507 :         case 'u':
    4259                 :        1565 :           if ((mask & OMP_CLAUSE_UNIFORM)
    4260                 :        1507 :               && gfc_match_omp_variable_list ("uniform (",
    4261                 :             :                                               &c->lists[OMP_LIST_UNIFORM],
    4262                 :             :                                               false) == MATCH_YES)
    4263                 :          58 :             continue;
    4264                 :        1590 :           if ((mask & OMP_CLAUSE_UNTIED)
    4265                 :        1449 :               && (m = gfc_match_dupl_check (!c->untied, "untied")) != MATCH_NO)
    4266                 :             :             {
    4267                 :         141 :               if (m == MATCH_ERROR)
    4268                 :           0 :                 goto error;
    4269                 :         141 :               c->untied = needs_space = true;
    4270                 :         141 :               continue;
    4271                 :             :             }
    4272                 :        1552 :           if ((mask & OMP_CLAUSE_ATOMIC)
    4273                 :        1308 :               && (m = gfc_match_dupl_atomic ((c->atomic_op
    4274                 :             :                                               == GFC_OMP_ATOMIC_UNSET),
    4275                 :             :                                              "update")) != MATCH_NO)
    4276                 :             :             {
    4277                 :         245 :               if (m == MATCH_ERROR)
    4278                 :           1 :                 goto error;
    4279                 :         244 :               c->atomic_op = GFC_OMP_ATOMIC_UPDATE;
    4280                 :         244 :               needs_space = true;
    4281                 :         244 :               continue;
    4282                 :             :             }
    4283                 :        1085 :           if ((mask & OMP_CLAUSE_USE)
    4284                 :        1063 :               && gfc_match_omp_variable_list ("use (",
    4285                 :             :                                               &c->lists[OMP_LIST_USE],
    4286                 :             :                                               true) == MATCH_YES)
    4287                 :          22 :             continue;
    4288                 :        1101 :           if ((mask & OMP_CLAUSE_USE_DEVICE)
    4289                 :        1041 :               && gfc_match_omp_variable_list ("use_device (",
    4290                 :             :                                               &c->lists[OMP_LIST_USE_DEVICE],
    4291                 :             :                                               true) == MATCH_YES)
    4292                 :          60 :             continue;
    4293                 :        1144 :           if ((mask & OMP_CLAUSE_USE_DEVICE_PTR)
    4294                 :        1909 :               && gfc_match_omp_variable_list
    4295                 :         928 :                    ("use_device_ptr (",
    4296                 :             :                     &c->lists[OMP_LIST_USE_DEVICE_PTR], false) == MATCH_YES)
    4297                 :         163 :             continue;
    4298                 :        1583 :           if ((mask & OMP_CLAUSE_USE_DEVICE_ADDR)
    4299                 :        1583 :               && gfc_match_omp_variable_list
    4300                 :         765 :                    ("use_device_addr (", &c->lists[OMP_LIST_USE_DEVICE_ADDR],
    4301                 :             :                     false, NULL, NULL, true) == MATCH_YES)
    4302                 :         765 :             continue;
    4303                 :          96 :           if ((mask & OMP_CLAUSE_USES_ALLOCATORS)
    4304                 :          53 :               && (gfc_match ("uses_allocators ( ") == MATCH_YES))
    4305                 :             :             {
    4306                 :          47 :               if (gfc_match_omp_clause_uses_allocators (c) != MATCH_YES)
    4307                 :           4 :                 goto error;
    4308                 :          43 :               continue;
    4309                 :             :             }
    4310                 :             :           break;
    4311                 :        1570 :         case 'v':
    4312                 :             :           /* VECTOR_LENGTH must be matched before VECTOR, because the latter
    4313                 :             :              doesn't unconditionally match '('.  */
    4314                 :        2139 :           if ((mask & OMP_CLAUSE_VECTOR_LENGTH)
    4315                 :        1570 :               && (m = gfc_match_dupl_check (!c->vector_length_expr,
    4316                 :             :                                             "vector_length", true,
    4317                 :             :                                             &c->vector_length_expr))
    4318                 :             :                  != MATCH_NO)
    4319                 :             :             {
    4320                 :         573 :               if (m == MATCH_ERROR)
    4321                 :           4 :                 goto error;
    4322                 :         569 :               continue;
    4323                 :             :             }
    4324                 :        1989 :           if ((mask & OMP_CLAUSE_VECTOR)
    4325                 :         997 :               && (m = gfc_match_dupl_check (!c->vector, "vector")) != MATCH_NO)
    4326                 :             :             {
    4327                 :         995 :               if (m == MATCH_ERROR)
    4328                 :           0 :                 goto error;
    4329                 :         995 :               c->vector = true;
    4330                 :         995 :               m = match_oacc_clause_gwv (c, GOMP_DIM_VECTOR);
    4331                 :         995 :               if (m == MATCH_ERROR)
    4332                 :           3 :                 goto error;
    4333                 :         992 :               if (m == MATCH_NO)
    4334                 :         860 :                 needs_space = true;
    4335                 :         992 :               continue;
    4336                 :             :             }
    4337                 :             :           break;
    4338                 :        1482 :         case 'w':
    4339                 :        1482 :           if ((mask & OMP_CLAUSE_WAIT)
    4340                 :        1482 :               && gfc_match ("wait") == MATCH_YES)
    4341                 :             :             {
    4342                 :         192 :               m = match_omp_oacc_expr_list (" (", &c->wait_list, false, false);
    4343                 :         192 :               if (m == MATCH_ERROR)
    4344                 :           9 :                 goto error;
    4345                 :         183 :               else if (m == MATCH_NO)
    4346                 :             :                 {
    4347                 :          47 :                   gfc_expr *expr
    4348                 :          47 :                     = gfc_get_constant_expr (BT_INTEGER,
    4349                 :             :                                              gfc_default_integer_kind,
    4350                 :             :                                              &gfc_current_locus);
    4351                 :          47 :                   mpz_set_si (expr->value.integer, GOMP_ASYNC_NOVAL);
    4352                 :          47 :                   gfc_expr_list **expr_list = &c->wait_list;
    4353                 :          56 :                   while (*expr_list)
    4354                 :           9 :                     expr_list = &(*expr_list)->next;
    4355                 :          47 :                   *expr_list = gfc_get_expr_list ();
    4356                 :          47 :                   (*expr_list)->expr = expr;
    4357                 :          47 :                   needs_space = true;
    4358                 :             :                 }
    4359                 :         183 :               continue;
    4360                 :         183 :             }
    4361                 :        1303 :           if ((mask & OMP_CLAUSE_WEAK)
    4362                 :        1290 :               && (m = gfc_match_dupl_check (!c->weak, "weak"))
    4363                 :             :                  != MATCH_NO)
    4364                 :             :             {
    4365                 :          14 :               if (m == MATCH_ERROR)
    4366                 :           1 :                 goto error;
    4367                 :          13 :               c->weak = true;
    4368                 :          13 :               needs_space = true;
    4369                 :          13 :               continue;
    4370                 :             :             }
    4371                 :        2137 :           if ((mask & OMP_CLAUSE_WORKER)
    4372                 :        1276 :               && (m = gfc_match_dupl_check (!c->worker, "worker")) != MATCH_NO)
    4373                 :             :             {
    4374                 :         864 :               if (m == MATCH_ERROR)
    4375                 :           0 :                 goto error;
    4376                 :         864 :               c->worker = true;
    4377                 :         864 :               m = match_oacc_clause_gwv (c, GOMP_DIM_WORKER);
    4378                 :         864 :               if (m == MATCH_ERROR)
    4379                 :           3 :                 goto error;
    4380                 :         861 :               else if (m == MATCH_NO)
    4381                 :         760 :                 needs_space = true;
    4382                 :         861 :               continue;
    4383                 :             :             }
    4384                 :         824 :           if ((mask & OMP_CLAUSE_ATOMIC)
    4385                 :         412 :               && (m = gfc_match_dupl_atomic ((c->atomic_op
    4386                 :             :                                               == GFC_OMP_ATOMIC_UNSET),
    4387                 :             :                                              "write")) != MATCH_NO)
    4388                 :             :             {
    4389                 :         412 :               if (m == MATCH_ERROR)
    4390                 :           0 :                 goto error;
    4391                 :         412 :               c->atomic_op = GFC_OMP_ATOMIC_WRITE;
    4392                 :         412 :               needs_space = true;
    4393                 :         412 :               continue;
    4394                 :             :             }
    4395                 :             :           break;
    4396                 :             :         }
    4397                 :             :       break;
    4398                 :       44691 :     }
    4399                 :             : 
    4400                 :       33511 : end:
    4401                 :       33255 :   if (error || gfc_match_omp_eos () != MATCH_YES)
    4402                 :             :     {
    4403                 :         517 :       if (!gfc_error_flag_test ())
    4404                 :         131 :         gfc_error ("Failed to match clause at %C");
    4405                 :         517 :       gfc_free_omp_clauses (c);
    4406                 :         517 :       return MATCH_ERROR;
    4407                 :             :     }
    4408                 :             : 
    4409                 :       32994 :   *cp = c;
    4410                 :       32994 :   return MATCH_YES;
    4411                 :             : 
    4412                 :         256 : error:
    4413                 :         256 :   error = true;
    4414                 :         256 :   goto end;
    4415                 :             : }
    4416                 :             : 
    4417                 :             : 
    4418                 :             : #define OACC_PARALLEL_CLAUSES \
    4419                 :             :   (omp_mask (OMP_CLAUSE_IF) | OMP_CLAUSE_ASYNC | OMP_CLAUSE_NUM_GANGS         \
    4420                 :             :    | OMP_CLAUSE_NUM_WORKERS | OMP_CLAUSE_VECTOR_LENGTH | OMP_CLAUSE_REDUCTION \
    4421                 :             :    | OMP_CLAUSE_COPY | OMP_CLAUSE_COPYIN | OMP_CLAUSE_COPYOUT                 \
    4422                 :             :    | OMP_CLAUSE_CREATE | OMP_CLAUSE_NO_CREATE | OMP_CLAUSE_PRESENT            \
    4423                 :             :    | OMP_CLAUSE_DEVICEPTR | OMP_CLAUSE_PRIVATE | OMP_CLAUSE_FIRSTPRIVATE      \
    4424                 :             :    | OMP_CLAUSE_DEFAULT | OMP_CLAUSE_WAIT | OMP_CLAUSE_ATTACH                 \
    4425                 :             :    | OMP_CLAUSE_SELF)
    4426                 :             : #define OACC_KERNELS_CLAUSES \
    4427                 :             :   (omp_mask (OMP_CLAUSE_IF) | OMP_CLAUSE_ASYNC | OMP_CLAUSE_NUM_GANGS         \
    4428                 :             :    | OMP_CLAUSE_NUM_WORKERS | OMP_CLAUSE_VECTOR_LENGTH | OMP_CLAUSE_DEVICEPTR \
    4429                 :             :    | OMP_CLAUSE_COPY | OMP_CLAUSE_COPYIN | OMP_CLAUSE_COPYOUT                 \
    4430                 :             :    | OMP_CLAUSE_CREATE | OMP_CLAUSE_NO_CREATE | OMP_CLAUSE_PRESENT            \
    4431                 :             :    | OMP_CLAUSE_DEFAULT | OMP_CLAUSE_WAIT | OMP_CLAUSE_ATTACH                 \
    4432                 :             :    | OMP_CLAUSE_SELF)
    4433                 :             : #define OACC_SERIAL_CLAUSES \
    4434                 :             :   (omp_mask (OMP_CLAUSE_IF) | OMP_CLAUSE_ASYNC | OMP_CLAUSE_REDUCTION         \
    4435                 :             :    | OMP_CLAUSE_COPY | OMP_CLAUSE_COPYIN | OMP_CLAUSE_COPYOUT                 \
    4436                 :             :    | OMP_CLAUSE_CREATE | OMP_CLAUSE_NO_CREATE | OMP_CLAUSE_PRESENT            \
    4437                 :             :    | OMP_CLAUSE_DEVICEPTR | OMP_CLAUSE_PRIVATE | OMP_CLAUSE_FIRSTPRIVATE      \
    4438                 :             :    | OMP_CLAUSE_DEFAULT | OMP_CLAUSE_WAIT | OMP_CLAUSE_ATTACH                 \
    4439                 :             :    | OMP_CLAUSE_SELF)
    4440                 :             : #define OACC_DATA_CLAUSES \
    4441                 :             :   (omp_mask (OMP_CLAUSE_IF) | OMP_CLAUSE_DEVICEPTR  | OMP_CLAUSE_COPY         \
    4442                 :             :    | OMP_CLAUSE_COPYIN | OMP_CLAUSE_COPYOUT | OMP_CLAUSE_CREATE               \
    4443                 :             :    | OMP_CLAUSE_NO_CREATE | OMP_CLAUSE_PRESENT | OMP_CLAUSE_ATTACH            \
    4444                 :             :    | OMP_CLAUSE_DEFAULT)
    4445                 :             : #define OACC_LOOP_CLAUSES \
    4446                 :             :   (omp_mask (OMP_CLAUSE_COLLAPSE) | OMP_CLAUSE_GANG | OMP_CLAUSE_WORKER       \
    4447                 :             :    | OMP_CLAUSE_VECTOR | OMP_CLAUSE_SEQ | OMP_CLAUSE_INDEPENDENT              \
    4448                 :             :    | OMP_CLAUSE_PRIVATE | OMP_CLAUSE_REDUCTION | OMP_CLAUSE_AUTO              \
    4449                 :             :    | OMP_CLAUSE_TILE)
    4450                 :             : #define OACC_PARALLEL_LOOP_CLAUSES \
    4451                 :             :   (OACC_LOOP_CLAUSES | OACC_PARALLEL_CLAUSES)
    4452                 :             : #define OACC_KERNELS_LOOP_CLAUSES \
    4453                 :             :   (OACC_LOOP_CLAUSES | OACC_KERNELS_CLAUSES)
    4454                 :             : #define OACC_SERIAL_LOOP_CLAUSES \
    4455                 :             :   (OACC_LOOP_CLAUSES | OACC_SERIAL_CLAUSES)
    4456                 :             : #define OACC_HOST_DATA_CLAUSES \
    4457                 :             :   (omp_mask (OMP_CLAUSE_USE_DEVICE)                                           \
    4458                 :             :    | OMP_CLAUSE_IF                                                            \
    4459                 :             :    | OMP_CLAUSE_IF_PRESENT)
    4460                 :             : #define OACC_DECLARE_CLAUSES \
    4461                 :             :   (omp_mask (OMP_CLAUSE_COPY) | OMP_CLAUSE_COPYIN | OMP_CLAUSE_COPYOUT        \
    4462                 :             :    | OMP_CLAUSE_CREATE | OMP_CLAUSE_DEVICEPTR | OMP_CLAUSE_DEVICE_RESIDENT    \
    4463                 :             :    | OMP_CLAUSE_PRESENT                       \
    4464                 :             :    | OMP_CLAUSE_LINK)
    4465                 :             : #define OACC_UPDATE_CLAUSES                                             \
    4466                 :             :   (omp_mask (OMP_CLAUSE_IF) | OMP_CLAUSE_ASYNC | OMP_CLAUSE_HOST              \
    4467                 :             :    | OMP_CLAUSE_DEVICE | OMP_CLAUSE_WAIT | OMP_CLAUSE_IF_PRESENT              \
    4468                 :             :    | OMP_CLAUSE_SELF)
    4469                 :             : #define OACC_ENTER_DATA_CLAUSES \
    4470                 :             :   (omp_mask (OMP_CLAUSE_IF) | OMP_CLAUSE_ASYNC | OMP_CLAUSE_WAIT              \
    4471                 :             :    | OMP_CLAUSE_COPYIN | OMP_CLAUSE_CREATE | OMP_CLAUSE_ATTACH)
    4472                 :             : #define OACC_EXIT_DATA_CLAUSES \
    4473                 :             :   (omp_mask (OMP_CLAUSE_IF) | OMP_CLAUSE_ASYNC | OMP_CLAUSE_WAIT              \
    4474                 :             :    | OMP_CLAUSE_COPYOUT | OMP_CLAUSE_DELETE | OMP_CLAUSE_FINALIZE             \
    4475                 :             :    | OMP_CLAUSE_DETACH)
    4476                 :             : #define OACC_WAIT_CLAUSES \
    4477                 :             :   omp_mask (OMP_CLAUSE_ASYNC)
    4478                 :             : #define OACC_ROUTINE_CLAUSES \
    4479                 :             :   (omp_mask (OMP_CLAUSE_GANG) | OMP_CLAUSE_WORKER | OMP_CLAUSE_VECTOR         \
    4480                 :             :    | OMP_CLAUSE_SEQ                                                           \
    4481                 :             :    | OMP_CLAUSE_NOHOST)
    4482                 :             : 
    4483                 :             : 
    4484                 :             : static match
    4485                 :       11730 : match_acc (gfc_exec_op op, const omp_mask mask)
    4486                 :             : {
    4487                 :       11730 :   gfc_omp_clauses *c;
    4488                 :       11730 :   if (gfc_match_omp_clauses (&c, mask, false, false, true) != MATCH_YES)
    4489                 :             :     return MATCH_ERROR;
    4490                 :       11525 :   new_st.op = op;
    4491                 :       11525 :   new_st.ext.omp_clauses = c;
    4492                 :       11525 :   return MATCH_YES;
    4493                 :             : }
    4494                 :             : 
    4495                 :             : match
    4496                 :        1378 : gfc_match_oacc_parallel_loop (void)
    4497                 :             : {
    4498                 :        1378 :   return match_acc (EXEC_OACC_PARALLEL_LOOP, OACC_PARALLEL_LOOP_CLAUSES);
    4499                 :             : }
    4500                 :             : 
    4501                 :             : 
    4502                 :             : match
    4503                 :        2970 : gfc_match_oacc_parallel (void)
    4504                 :             : {
    4505                 :        2970 :   return match_acc (EXEC_OACC_PARALLEL, OACC_PARALLEL_CLAUSES);
    4506                 :             : }
    4507                 :             : 
    4508                 :             : 
    4509                 :             : match
    4510                 :         129 : gfc_match_oacc_kernels_loop (void)
    4511                 :             : {
    4512                 :         129 :   return match_acc (EXEC_OACC_KERNELS_LOOP, OACC_KERNELS_LOOP_CLAUSES);
    4513                 :             : }
    4514                 :             : 
    4515                 :             : 
    4516                 :             : match
    4517                 :         904 : gfc_match_oacc_kernels (void)
    4518                 :             : {
    4519                 :         904 :   return match_acc (EXEC_OACC_KERNELS, OACC_KERNELS_CLAUSES);
    4520                 :             : }
    4521                 :             : 
    4522                 :             : 
    4523                 :             : match
    4524                 :         230 : gfc_match_oacc_serial_loop (void)
    4525                 :             : {
    4526                 :         230 :   return match_acc (EXEC_OACC_SERIAL_LOOP, OACC_SERIAL_LOOP_CLAUSES);
    4527                 :             : }
    4528                 :             : 
    4529                 :             : 
    4530                 :             : match
    4531                 :         344 : gfc_match_oacc_serial (void)
    4532                 :             : {
    4533                 :         344 :   return match_acc (EXEC_OACC_SERIAL, OACC_SERIAL_CLAUSES);
    4534                 :             : }
    4535                 :             : 
    4536                 :             : 
    4537                 :             : match
    4538                 :         689 : gfc_match_oacc_data (void)
    4539                 :             : {
    4540                 :         689 :   return match_acc (EXEC_OACC_DATA, OACC_DATA_CLAUSES);
    4541                 :             : }
    4542                 :             : 
    4543                 :             : 
    4544                 :             : match
    4545                 :          65 : gfc_match_oacc_host_data (void)
    4546                 :             : {
    4547                 :          65 :   return match_acc (EXEC_OACC_HOST_DATA, OACC_HOST_DATA_CLAUSES);
    4548                 :             : }
    4549                 :             : 
    4550                 :             : 
    4551                 :             : match
    4552                 :        3582 : gfc_match_oacc_loop (void)
    4553                 :             : {
    4554                 :        3582 :   return match_acc (EXEC_OACC_LOOP, OACC_LOOP_CLAUSES);
    4555                 :             : }
    4556                 :             : 
    4557                 :             : 
    4558                 :             : match
    4559                 :         173 : gfc_match_oacc_declare (void)
    4560                 :             : {
    4561                 :         173 :   gfc_omp_clauses *c;
    4562                 :         173 :   gfc_omp_namelist *n;
    4563                 :         173 :   gfc_namespace *ns = gfc_current_ns;
    4564                 :         173 :   gfc_oacc_declare *new_oc;
    4565                 :         173 :   bool module_var = false;
    4566                 :         173 :   locus where = gfc_current_locus;
    4567                 :             : 
    4568                 :         173 :   if (gfc_match_omp_clauses (&c, OACC_DECLARE_CLAUSES, false, false, true)
    4569                 :             :       != MATCH_YES)
    4570                 :             :     return MATCH_ERROR;
    4571                 :             : 
    4572                 :         256 :   for (n = c->lists[OMP_LIST_DEVICE_RESIDENT]; n != NULL; n = n->next)
    4573                 :          89 :     n->sym->attr.oacc_declare_device_resident = 1;
    4574                 :             : 
    4575                 :         187 :   for (n = c->lists[OMP_LIST_LINK]; n != NULL; n = n->next)
    4576                 :          20 :     n->sym->attr.oacc_declare_link = 1;
    4577                 :             : 
    4578                 :         302 :   for (n = c->lists[OMP_LIST_MAP]; n != NULL; n = n->next)
    4579                 :             :     {
    4580                 :         145 :       gfc_symbol *s = n->sym;
    4581                 :             : 
    4582                 :         145 :       if (gfc_current_ns->proc_name
    4583                 :         145 :           && gfc_current_ns->proc_name->attr.flavor == FL_MODULE)
    4584                 :             :         {
    4585                 :          48 :           if (n->u.map.op != OMP_MAP_ALLOC && n->u.map.op != OMP_MAP_TO)
    4586                 :             :             {
    4587                 :           6 :               gfc_error ("Invalid clause in module with !$ACC DECLARE at %L",
    4588                 :             :                          &where);
    4589                 :           6 :               return MATCH_ERROR;
    4590                 :             :             }
    4591                 :             : 
    4592                 :             :           module_var = true;
    4593                 :             :         }
    4594                 :             : 
    4595                 :         139 :       if (s->attr.use_assoc)
    4596                 :             :         {
    4597                 :           0 :           gfc_error ("Variable is USE-associated with !$ACC DECLARE at %L",
    4598                 :             :                      &where);
    4599                 :           0 :           return MATCH_ERROR;
    4600                 :             :         }
    4601                 :             : 
    4602                 :         139 :       if ((s->result == s && s->ns->contained != gfc_current_ns)
    4603                 :         139 :           || ((s->attr.flavor == FL_UNKNOWN || s->attr.flavor == FL_VARIABLE)
    4604                 :         129 :               && s->ns != gfc_current_ns))
    4605                 :             :         {
    4606                 :           2 :           gfc_error ("Variable %qs shall be declared in the same scoping unit "
    4607                 :             :                      "as !$ACC DECLARE at %L", s->name, &where);
    4608                 :           2 :           return MATCH_ERROR;
    4609                 :             :         }
    4610                 :             : 
    4611                 :         137 :       if ((s->attr.dimension || s->attr.codimension)
    4612                 :          73 :           && s->attr.dummy && s->as->type != AS_EXPLICIT)
    4613                 :             :         {
    4614                 :           2 :           gfc_error ("Assumed-size dummy array with !$ACC DECLARE at %L",
    4615                 :             :                      &where);
    4616                 :           2 :           return MATCH_ERROR;
    4617                 :             :         }
    4618                 :             : 
    4619                 :         135 :       switch (n->u.map.op)
    4620                 :             :         {
    4621                 :          49 :           case OMP_MAP_FORCE_ALLOC:
    4622                 :          49 :           case OMP_MAP_ALLOC:
    4623                 :          49 :             s->attr.oacc_declare_create = 1;
    4624                 :          49 :             break;
    4625                 :             : 
    4626                 :          52 :           case OMP_MAP_FORCE_TO:
    4627                 :          52 :           case OMP_MAP_TO:
    4628                 :          52 :             s->attr.oacc_declare_copyin = 1;
    4629                 :          52 :             break;
    4630                 :             : 
    4631                 :           1 :           case OMP_MAP_FORCE_DEVICEPTR:
    4632                 :           1 :             s->attr.oacc_declare_deviceptr = 1;
    4633                 :           1 :             break;
    4634                 :             : 
    4635                 :             :           default:
    4636                 :             :             break;
    4637                 :             :         }
    4638                 :             :     }
    4639                 :             : 
    4640                 :         157 :   new_oc = gfc_get_oacc_declare ();
    4641                 :         157 :   new_oc->next = ns->oacc_declare;
    4642                 :         157 :   new_oc->module_var = module_var;
    4643                 :         157 :   new_oc->clauses = c;
    4644                 :         157 :   new_oc->loc = gfc_current_locus;
    4645                 :         157 :   ns->oacc_declare = new_oc;
    4646                 :             : 
    4647                 :         157 :   return MATCH_YES;
    4648                 :             : }
    4649                 :             : 
    4650                 :             : 
    4651                 :             : match
    4652                 :         760 : gfc_match_oacc_update (void)
    4653                 :             : {
    4654                 :         760 :   gfc_omp_clauses *c;
    4655                 :         760 :   locus here = gfc_current_locus;
    4656                 :             : 
    4657                 :         760 :   if (gfc_match_omp_clauses (&c, OACC_UPDATE_CLAUSES, false, false, true)
    4658                 :             :       != MATCH_YES)
    4659                 :             :     return MATCH_ERROR;
    4660                 :             : 
    4661                 :         756 :   if (!c->lists[OMP_LIST_MAP])
    4662                 :             :     {
    4663                 :           1 :       gfc_error ("%<acc update%> must contain at least one "
    4664                 :             :                  "%<device%> or %<host%> or %<self%> clause at %L", &here);
    4665                 :           1 :       return MATCH_ERROR;
    4666                 :             :     }
    4667                 :             : 
    4668                 :         755 :   new_st.op = EXEC_OACC_UPDATE;
    4669                 :         755 :   new_st.ext.omp_clauses = c;
    4670                 :         755 :   return MATCH_YES;
    4671                 :             : }
    4672                 :             : 
    4673                 :             : 
    4674                 :             : match
    4675                 :         857 : gfc_match_oacc_enter_data (void)
    4676                 :             : {
    4677                 :         857 :   return match_acc (EXEC_OACC_ENTER_DATA, OACC_ENTER_DATA_CLAUSES);
    4678                 :             : }
    4679                 :             : 
    4680                 :             : 
    4681                 :             : match
    4682                 :         582 : gfc_match_oacc_exit_data (void)
    4683                 :             : {
    4684                 :         582 :   return match_acc (EXEC_OACC_EXIT_DATA, OACC_EXIT_DATA_CLAUSES);
    4685                 :             : }
    4686                 :             : 
    4687                 :             : 
    4688                 :             : match
    4689                 :         197 : gfc_match_oacc_wait (void)
    4690                 :             : {
    4691                 :         197 :   gfc_omp_clauses *c = gfc_get_omp_clauses ();
    4692                 :         197 :   gfc_expr_list *wait_list = NULL, *el;
    4693                 :         197 :   bool space = true;
    4694                 :         197 :   match m;
    4695                 :             : 
    4696                 :         197 :   m = match_omp_oacc_expr_list (" (", &wait_list, true, false);
    4697                 :         197 :   if (m == MATCH_ERROR)
    4698                 :             :     return m;
    4699                 :         191 :   else if (m == MATCH_YES)
    4700                 :         120 :     space = false;
    4701                 :             : 
    4702                 :         191 :   if (gfc_match_omp_clauses (&c, OACC_WAIT_CLAUSES, space, space, true)
    4703                 :             :       == MATCH_ERROR)
    4704                 :             :     return MATCH_ERROR;
    4705                 :             : 
    4706                 :         178 :   if (wait_list)
    4707                 :         249 :     for (el = wait_list; el; el = el->next)
    4708                 :             :       {
    4709                 :         134 :         if (el->expr == NULL)
    4710                 :             :           {
    4711                 :           2 :             gfc_error ("Invalid argument to !$ACC WAIT at %C");
    4712                 :           2 :             return MATCH_ERROR;
    4713                 :             :           }
    4714                 :             : 
    4715                 :         132 :         if (!gfc_resolve_expr (el->expr)
    4716                 :         132 :             || el->expr->ts.type != BT_INTEGER || el->expr->rank != 0)
    4717                 :             :           {
    4718                 :           3 :             gfc_error ("WAIT clause at %L requires a scalar INTEGER expression",
    4719                 :           3 :                        &el->expr->where);
    4720                 :             : 
    4721                 :           3 :             return MATCH_ERROR;
    4722                 :             :           }
    4723                 :             :       }
    4724                 :         173 :   c->wait_list = wait_list;
    4725                 :         173 :   new_st.op = EXEC_OACC_WAIT;
    4726                 :         173 :   new_st.ext.omp_clauses = c;
    4727                 :         173 :   return MATCH_YES;
    4728                 :             : }
    4729                 :             : 
    4730                 :             : 
    4731                 :             : match
    4732                 :          97 : gfc_match_oacc_cache (void)
    4733                 :             : {
    4734                 :          97 :   bool readonly = false;
    4735                 :          97 :   gfc_omp_clauses *c = gfc_get_omp_clauses ();
    4736                 :             :   /* The OpenACC cache directive explicitly only allows "array elements or
    4737                 :             :      subarrays", which we're currently not checking here.  Either check this
    4738                 :             :      after the call of gfc_match_omp_variable_list, or add something like a
    4739                 :             :      only_sections variant next to its allow_sections parameter.  */
    4740                 :          97 :   match m = gfc_match (" ( ");
    4741                 :          97 :   if (m != MATCH_YES)
    4742                 :             :     {
    4743                 :           0 :       gfc_free_omp_clauses(c);
    4744                 :           0 :       return m;
    4745                 :             :     }
    4746                 :             : 
    4747                 :          97 :   if (gfc_match ("readonly : ") == MATCH_YES)
    4748                 :           8 :     readonly = true;
    4749                 :             : 
    4750                 :          97 :   gfc_omp_namelist **head = NULL;
    4751                 :          97 :   m = gfc_match_omp_variable_list ("", &c->lists[OMP_LIST_CACHE], true,
    4752                 :             :                                    NULL, &head, true);
    4753                 :          97 :   if (m != MATCH_YES)
    4754                 :             :     {
    4755                 :           2 :       gfc_free_omp_clauses(c);
    4756                 :           2 :       return m;
    4757                 :             :     }
    4758                 :             : 
    4759                 :          95 :   if (readonly)
    4760                 :          24 :     for (gfc_omp_namelist *n = *head; n; n = n->next)
    4761                 :          16 :       n->u.map.readonly = true;
    4762                 :             : 
    4763                 :          95 :   if (gfc_current_state() != COMP_DO
    4764                 :          56 :       && gfc_current_state() != COMP_DO_CONCURRENT)
    4765                 :             :     {
    4766                 :           2 :       gfc_error ("ACC CACHE directive must be inside of loop %C");
    4767                 :           2 :       gfc_free_omp_clauses(c);
    4768                 :           2 :       return MATCH_ERROR;
    4769                 :             :     }
    4770                 :             : 
    4771                 :          93 :   new_st.op = EXEC_OACC_CACHE;
    4772                 :          93 :   new_st.ext.omp_clauses = c;
    4773                 :          93 :   return MATCH_YES;
    4774                 :             : }
    4775                 :             : 
    4776                 :             : /* Determine the OpenACC 'routine' directive's level of parallelism.  */
    4777                 :             : 
    4778                 :             : static oacc_routine_lop
    4779                 :         733 : gfc_oacc_routine_lop (gfc_omp_clauses *clauses)
    4780                 :             : {
    4781                 :         733 :   oacc_routine_lop ret = OACC_ROUTINE_LOP_SEQ;
    4782                 :             : 
    4783                 :         733 :   if (clauses)
    4784                 :             :     {
    4785                 :         584 :       unsigned n_lop_clauses = 0;
    4786                 :             : 
    4787                 :         584 :       if (clauses->gang)
    4788                 :             :         {
    4789                 :         164 :           ++n_lop_clauses;
    4790                 :         164 :           ret = OACC_ROUTINE_LOP_GANG;
    4791                 :             :         }
    4792                 :         584 :       if (clauses->worker)
    4793                 :             :         {
    4794                 :         114 :           ++n_lop_clauses;
    4795                 :         114 :           ret = OACC_ROUTINE_LOP_WORKER;
    4796                 :             :         }
    4797                 :         584 :       if (clauses->vector)
    4798                 :             :         {
    4799                 :         116 :           ++n_lop_clauses;
    4800                 :         116 :           ret = OACC_ROUTINE_LOP_VECTOR;
    4801                 :             :         }
    4802                 :         584 :       if (clauses->seq)
    4803                 :             :         {
    4804                 :         206 :           ++n_lop_clauses;
    4805                 :         206 :           ret = OACC_ROUTINE_LOP_SEQ;
    4806                 :             :         }
    4807                 :             : 
    4808                 :         584 :       if (n_lop_clauses > 1)
    4809                 :          47 :         ret = OACC_ROUTINE_LOP_ERROR;
    4810                 :             :     }
    4811                 :             : 
    4812                 :         733 :   return ret;
    4813                 :             : }
    4814                 :             : 
    4815                 :             : match
    4816                 :         697 : gfc_match_oacc_routine (void)
    4817                 :             : {
    4818                 :         697 :   locus old_loc;
    4819                 :         697 :   match m;
    4820                 :         697 :   gfc_intrinsic_sym *isym = NULL;
    4821                 :         697 :   gfc_symbol *sym = NULL;
    4822                 :         697 :   gfc_omp_clauses *c = NULL;
    4823                 :         697 :   gfc_oacc_routine_name *n = NULL;
    4824                 :         697 :   oacc_routine_lop lop = OACC_ROUTINE_LOP_NONE;
    4825                 :         697 :   bool nohost;
    4826                 :             : 
    4827                 :         697 :   old_loc = gfc_current_locus;
    4828                 :             : 
    4829                 :         697 :   m = gfc_match (" (");
    4830                 :             : 
    4831                 :         697 :   if (gfc_current_ns->proc_name
    4832                 :         695 :       && gfc_current_ns->proc_name->attr.if_source == IFSRC_IFBODY
    4833                 :          90 :       && m == MATCH_YES)
    4834                 :             :     {
    4835                 :           3 :       gfc_error ("Only the !$ACC ROUTINE form without "
    4836                 :             :                  "list is allowed in interface block at %C");
    4837                 :           3 :       goto cleanup;
    4838                 :             :     }
    4839                 :             : 
    4840                 :         607 :   if (m == MATCH_YES)
    4841                 :             :     {
    4842                 :         295 :       char buffer[GFC_MAX_SYMBOL_LEN + 1];
    4843                 :             : 
    4844                 :         295 :       m = gfc_match_name (buffer);
    4845                 :         295 :       if (m == MATCH_YES)
    4846                 :             :         {
    4847                 :         294 :           gfc_symtree *st = NULL;
    4848                 :             : 
    4849                 :             :           /* First look for an intrinsic symbol.  */
    4850                 :         294 :           isym = gfc_find_function (buffer);
    4851                 :         294 :           if (!isym)
    4852                 :         294 :             isym = gfc_find_subroutine (buffer);
    4853                 :             :           /* If no intrinsic symbol found, search the current namespace.  */
    4854                 :         294 :           if (!isym)
    4855                 :         276 :             st = gfc_find_symtree (gfc_current_ns->sym_root, buffer);
    4856                 :         276 :           if (st)
    4857                 :             :             {
    4858                 :         270 :               sym = st->n.sym;
    4859                 :             :               /* If the name in a 'routine' directive refers to the containing
    4860                 :             :                  subroutine or function, then make sure that we'll later handle
    4861                 :             :                  this accordingly.  */
    4862                 :         270 :               if (gfc_current_ns->proc_name != NULL
    4863                 :         270 :                   && strcmp (sym->name, gfc_current_ns->proc_name->name) == 0)
    4864                 :         294 :                 sym = NULL;
    4865                 :             :             }
    4866                 :             : 
    4867                 :         294 :           if (isym == NULL && st == NULL)
    4868                 :             :             {
    4869                 :           6 :               gfc_error ("Invalid NAME %qs in !$ACC ROUTINE ( NAME ) at %C",
    4870                 :             :                          buffer);
    4871                 :           6 :               gfc_current_locus = old_loc;
    4872                 :           9 :               return MATCH_ERROR;
    4873                 :             :             }
    4874                 :             :         }
    4875                 :             :       else
    4876                 :             :         {
    4877                 :           1 :           gfc_error ("Syntax error in !$ACC ROUTINE ( NAME ) at %C");
    4878                 :           1 :           gfc_current_locus = old_loc;
    4879                 :           1 :           return MATCH_ERROR;
    4880                 :             :         }
    4881                 :             : 
    4882                 :         288 :       if (gfc_match_char (')') != MATCH_YES)
    4883                 :             :         {
    4884                 :           2 :           gfc_error ("Syntax error in !$ACC ROUTINE ( NAME ) at %C, expecting"
    4885                 :             :                      " %<)%> after NAME");
    4886                 :           2 :           gfc_current_locus = old_loc;
    4887                 :           2 :           return MATCH_ERROR;
    4888                 :             :         }
    4889                 :             :     }
    4890                 :             : 
    4891                 :         685 :   if (gfc_match_omp_eos () != MATCH_YES
    4892                 :         685 :       && (gfc_match_omp_clauses (&c, OACC_ROUTINE_CLAUSES, false, false, true)
    4893                 :             :           != MATCH_YES))
    4894                 :             :     return MATCH_ERROR;
    4895                 :             : 
    4896                 :         682 :   lop = gfc_oacc_routine_lop (c);
    4897                 :         682 :   if (lop == OACC_ROUTINE_LOP_ERROR)
    4898                 :             :     {
    4899                 :          47 :       gfc_error ("Multiple loop axes specified for routine at %C");
    4900                 :          47 :       goto cleanup;
    4901                 :             :     }
    4902                 :         635 :   nohost = c ? c->nohost : false;
    4903                 :             : 
    4904                 :         635 :   if (isym != NULL)
    4905                 :             :     {
    4906                 :             :       /* Diagnose any OpenACC 'routine' directive that doesn't match the
    4907                 :             :          (implicit) one with a 'seq' clause.  */
    4908                 :          16 :       if (c && (c->gang || c->worker || c->vector))
    4909                 :             :         {
    4910                 :          10 :           gfc_error ("Intrinsic symbol specified in !$ACC ROUTINE ( NAME )"
    4911                 :             :                      " at %C marked with incompatible GANG, WORKER, or VECTOR"
    4912                 :             :                      " clause");
    4913                 :          10 :           goto cleanup;
    4914                 :             :         }
    4915                 :             :       /* ..., and no 'nohost' clause.  */
    4916                 :           6 :       if (nohost)
    4917                 :             :         {
    4918                 :           2 :           gfc_error ("Intrinsic symbol specified in !$ACC ROUTINE ( NAME )"
    4919                 :             :                      " at %C marked with incompatible NOHOST clause");
    4920                 :           2 :           goto cleanup;
    4921                 :             :         }
    4922                 :             :     }
    4923                 :         619 :   else if (sym != NULL)
    4924                 :             :     {
    4925                 :         151 :       bool add = true;
    4926                 :             : 
    4927                 :             :       /* For a repeated OpenACC 'routine' directive, diagnose if it doesn't
    4928                 :             :          match the first one.  */
    4929                 :         151 :       for (gfc_oacc_routine_name *n_p = gfc_current_ns->oacc_routine_names;
    4930                 :         346 :            n_p;
    4931                 :         195 :            n_p = n_p->next)
    4932                 :         235 :         if (n_p->sym == sym)
    4933                 :             :           {
    4934                 :          51 :             add = false;
    4935                 :          51 :             bool nohost_p = n_p->clauses ? n_p->clauses->nohost : false;
    4936                 :          51 :             if (lop != gfc_oacc_routine_lop (n_p->clauses)
    4937                 :          51 :                 || nohost != nohost_p)
    4938                 :             :               {
    4939                 :          40 :                 gfc_error ("!$ACC ROUTINE already applied at %C");
    4940                 :          40 :                 goto cleanup;
    4941                 :             :               }
    4942                 :             :           }
    4943                 :             : 
    4944                 :         111 :       if (add)
    4945                 :             :         {
    4946                 :         100 :           sym->attr.oacc_routine_lop = lop;
    4947                 :         100 :           sym->attr.oacc_routine_nohost = nohost;
    4948                 :             : 
    4949                 :         100 :           n = gfc_get_oacc_routine_name ();
    4950                 :         100 :           n->sym = sym;
    4951                 :         100 :           n->clauses = c;
    4952                 :         100 :           n->next = gfc_current_ns->oacc_routine_names;
    4953                 :         100 :           n->loc = old_loc;
    4954                 :         100 :           gfc_current_ns->oacc_routine_names = n;
    4955                 :             :         }
    4956                 :             :     }
    4957                 :         468 :   else if (gfc_current_ns->proc_name)
    4958                 :             :     {
    4959                 :             :       /* For a repeated OpenACC 'routine' directive, diagnose if it doesn't
    4960                 :             :          match the first one.  */
    4961                 :         467 :       oacc_routine_lop lop_p = gfc_current_ns->proc_name->attr.oacc_routine_lop;
    4962                 :         467 :       bool nohost_p = gfc_current_ns->proc_name->attr.oacc_routine_nohost;
    4963                 :         467 :       if (lop_p != OACC_ROUTINE_LOP_NONE
    4964                 :          86 :           && (lop != lop_p
    4965                 :          86 :               || nohost != nohost_p))
    4966                 :             :         {
    4967                 :          56 :           gfc_error ("!$ACC ROUTINE already applied at %C");
    4968                 :          56 :           goto cleanup;
    4969                 :             :         }
    4970                 :             : 
    4971                 :         411 :       if (!gfc_add_omp_declare_target (&gfc_current_ns->proc_name->attr,
    4972                 :             :                                        gfc_current_ns->proc_name->name,
    4973                 :             :                                        &old_loc))
    4974                 :           1 :         goto cleanup;
    4975                 :         410 :       gfc_current_ns->proc_name->attr.oacc_routine_lop = lop;
    4976                 :         410 :       gfc_current_ns->proc_name->attr.oacc_routine_nohost = nohost;
    4977                 :             :     }
    4978                 :             :   else
    4979                 :             :     /* Something has gone wrong, possibly a syntax error.  */
    4980                 :           1 :     goto cleanup;
    4981                 :             : 
    4982                 :         525 :   if (gfc_pure (NULL) && c && (c->gang || c->worker || c->vector))
    4983                 :             :     {
    4984                 :           6 :       gfc_error ("!$ACC ROUTINE with GANG, WORKER, or VECTOR clause is not "
    4985                 :             :                  "permitted in PURE procedure at %C");
    4986                 :           6 :       goto cleanup;
    4987                 :             :     }
    4988                 :             : 
    4989                 :             : 
    4990                 :         519 :   if (n)
    4991                 :         100 :     n->clauses = c;
    4992                 :         419 :   else if (gfc_current_ns->oacc_routine)
    4993                 :           0 :     gfc_current_ns->oacc_routine_clauses = c;
    4994                 :             : 
    4995                 :         519 :   new_st.op = EXEC_OACC_ROUTINE;
    4996                 :         519 :   new_st.ext.omp_clauses = c;
    4997                 :         519 :   return MATCH_YES;
    4998                 :             : 
    4999                 :         166 : cleanup:
    5000                 :         166 :   gfc_current_locus = old_loc;
    5001                 :         166 :   return MATCH_ERROR;
    5002                 :             : }
    5003                 :             : 
    5004                 :             : 
    5005                 :             : #define OMP_PARALLEL_CLAUSES \
    5006                 :             :   (omp_mask (OMP_CLAUSE_PRIVATE) | OMP_CLAUSE_FIRSTPRIVATE              \
    5007                 :             :    | OMP_CLAUSE_SHARED | OMP_CLAUSE_COPYIN | OMP_CLAUSE_REDUCTION       \
    5008                 :             :    | OMP_CLAUSE_IF | OMP_CLAUSE_NUM_THREADS | OMP_CLAUSE_DEFAULT        \
    5009                 :             :    | OMP_CLAUSE_PROC_BIND | OMP_CLAUSE_ALLOCATE)
    5010                 :             : #define OMP_DECLARE_SIMD_CLAUSES \
    5011                 :             :   (omp_mask (OMP_CLAUSE_SIMDLEN) | OMP_CLAUSE_LINEAR                    \
    5012                 :             :    | OMP_CLAUSE_UNIFORM | OMP_CLAUSE_ALIGNED | OMP_CLAUSE_INBRANCH      \
    5013                 :             :    | OMP_CLAUSE_NOTINBRANCH)
    5014                 :             : #define OMP_DO_CLAUSES \
    5015                 :             :   (omp_mask (OMP_CLAUSE_PRIVATE) | OMP_CLAUSE_FIRSTPRIVATE              \
    5016                 :             :    | OMP_CLAUSE_LASTPRIVATE | OMP_CLAUSE_REDUCTION                      \
    5017                 :             :    | OMP_CLAUSE_SCHEDULE | OMP_CLAUSE_ORDERED | OMP_CLAUSE_COLLAPSE     \
    5018                 :             :    | OMP_CLAUSE_LINEAR | OMP_CLAUSE_ORDER | OMP_CLAUSE_ALLOCATE         \
    5019                 :             :    | OMP_CLAUSE_NOWAIT)
    5020                 :             : #define OMP_LOOP_CLAUSES \
    5021                 :             :   (omp_mask (OMP_CLAUSE_BIND) | OMP_CLAUSE_COLLAPSE | OMP_CLAUSE_ORDER  \
    5022                 :             :    | OMP_CLAUSE_PRIVATE | OMP_CLAUSE_LASTPRIVATE | OMP_CLAUSE_REDUCTION)
    5023                 :             : 
    5024                 :             : #define OMP_SCOPE_CLAUSES \
    5025                 :             :   (omp_mask (OMP_CLAUSE_PRIVATE) |OMP_CLAUSE_FIRSTPRIVATE               \
    5026                 :             :    | OMP_CLAUSE_REDUCTION | OMP_CLAUSE_ALLOCATE | OMP_CLAUSE_NOWAIT)
    5027                 :             : #define OMP_SECTIONS_CLAUSES \
    5028                 :             :   (omp_mask (OMP_CLAUSE_PRIVATE) | OMP_CLAUSE_FIRSTPRIVATE              \
    5029                 :             :    | OMP_CLAUSE_LASTPRIVATE | OMP_CLAUSE_REDUCTION                      \
    5030                 :             :    | OMP_CLAUSE_ALLOCATE | OMP_CLAUSE_NOWAIT)
    5031                 :             : #define OMP_SIMD_CLAUSES \
    5032                 :             :   (omp_mask (OMP_CLAUSE_PRIVATE) | OMP_CLAUSE_LASTPRIVATE               \
    5033                 :             :    | OMP_CLAUSE_REDUCTION | OMP_CLAUSE_COLLAPSE | OMP_CLAUSE_SAFELEN    \
    5034                 :             :    | OMP_CLAUSE_LINEAR | OMP_CLAUSE_ALIGNED | OMP_CLAUSE_SIMDLEN        \
    5035                 :             :    | OMP_CLAUSE_IF | OMP_CLAUSE_ORDER | OMP_CLAUSE_NOTEMPORAL)
    5036                 :             : #define OMP_TASK_CLAUSES \
    5037                 :             :   (omp_mask (OMP_CLAUSE_PRIVATE) | OMP_CLAUSE_FIRSTPRIVATE              \
    5038                 :             :    | OMP_CLAUSE_SHARED | OMP_CLAUSE_IF | OMP_CLAUSE_DEFAULT             \
    5039                 :             :    | OMP_CLAUSE_UNTIED | OMP_CLAUSE_FINAL | OMP_CLAUSE_MERGEABLE        \
    5040                 :             :    | OMP_CLAUSE_DEPEND | OMP_CLAUSE_PRIORITY | OMP_CLAUSE_IN_REDUCTION  \
    5041                 :             :    | OMP_CLAUSE_DETACH | OMP_CLAUSE_AFFINITY | OMP_CLAUSE_ALLOCATE)
    5042                 :             : #define OMP_TASKLOOP_CLAUSES \
    5043                 :             :   (omp_mask (OMP_CLAUSE_PRIVATE) | OMP_CLAUSE_FIRSTPRIVATE              \
    5044                 :             :    | OMP_CLAUSE_LASTPRIVATE | OMP_CLAUSE_SHARED | OMP_CLAUSE_IF         \
    5045                 :             :    | OMP_CLAUSE_DEFAULT | OMP_CLAUSE_UNTIED | OMP_CLAUSE_FINAL          \
    5046                 :             :    | OMP_CLAUSE_MERGEABLE | OMP_CLAUSE_PRIORITY | OMP_CLAUSE_GRAINSIZE  \
    5047                 :             :    | OMP_CLAUSE_NUM_TASKS | OMP_CLAUSE_COLLAPSE | OMP_CLAUSE_NOGROUP    \
    5048                 :             :    | OMP_CLAUSE_REDUCTION | OMP_CLAUSE_IN_REDUCTION | OMP_CLAUSE_ALLOCATE)
    5049                 :             : #define OMP_TASKGROUP_CLAUSES \
    5050                 :             :   (omp_mask (OMP_CLAUSE_TASK_REDUCTION) | OMP_CLAUSE_ALLOCATE)
    5051                 :             : #define OMP_TARGET_CLAUSES \
    5052                 :             :   (omp_mask (OMP_CLAUSE_DEVICE) | OMP_CLAUSE_MAP | OMP_CLAUSE_IF        \
    5053                 :             :    | OMP_CLAUSE_DEPEND | OMP_CLAUSE_NOWAIT | OMP_CLAUSE_PRIVATE         \
    5054                 :             :    | OMP_CLAUSE_FIRSTPRIVATE | OMP_CLAUSE_DEFAULTMAP                    \
    5055                 :             :    | OMP_CLAUSE_IS_DEVICE_PTR | OMP_CLAUSE_IN_REDUCTION                 \
    5056                 :             :    | OMP_CLAUSE_THREAD_LIMIT | OMP_CLAUSE_ALLOCATE                      \
    5057                 :             :    | OMP_CLAUSE_HAS_DEVICE_ADDR | OMP_CLAUSE_USES_ALLOCATORS)
    5058                 :             : #define OMP_TARGET_DATA_CLAUSES \
    5059                 :             :   (omp_mask (OMP_CLAUSE_DEVICE) | OMP_CLAUSE_MAP | OMP_CLAUSE_IF        \
    5060                 :             :    | OMP_CLAUSE_USE_DEVICE_PTR | OMP_CLAUSE_USE_DEVICE_ADDR)
    5061                 :             : #define OMP_TARGET_ENTER_DATA_CLAUSES \
    5062                 :             :   (omp_mask (OMP_CLAUSE_DEVICE) | OMP_CLAUSE_MAP | OMP_CLAUSE_IF        \
    5063                 :             :    | OMP_CLAUSE_DEPEND | OMP_CLAUSE_NOWAIT)
    5064                 :             : #define OMP_TARGET_EXIT_DATA_CLAUSES \
    5065                 :             :   (omp_mask (OMP_CLAUSE_DEVICE) | OMP_CLAUSE_MAP | OMP_CLAUSE_IF        \
    5066                 :             :    | OMP_CLAUSE_DEPEND | OMP_CLAUSE_NOWAIT)
    5067                 :             : #define OMP_TARGET_UPDATE_CLAUSES \
    5068                 :             :   (omp_mask (OMP_CLAUSE_DEVICE) | OMP_CLAUSE_IF | OMP_CLAUSE_TO         \
    5069                 :             :    | OMP_CLAUSE_FROM | OMP_CLAUSE_DEPEND | OMP_CLAUSE_NOWAIT)
    5070                 :             : #define OMP_TEAMS_CLAUSES \
    5071                 :             :   (omp_mask (OMP_CLAUSE_NUM_TEAMS) | OMP_CLAUSE_THREAD_LIMIT            \
    5072                 :             :    | OMP_CLAUSE_DEFAULT | OMP_CLAUSE_PRIVATE | OMP_CLAUSE_FIRSTPRIVATE  \
    5073                 :             :    | OMP_CLAUSE_SHARED | OMP_CLAUSE_REDUCTION | OMP_CLAUSE_ALLOCATE)
    5074                 :             : #define OMP_DISTRIBUTE_CLAUSES \
    5075                 :             :   (omp_mask (OMP_CLAUSE_PRIVATE) | OMP_CLAUSE_FIRSTPRIVATE              \
    5076                 :             :    | OMP_CLAUSE_LASTPRIVATE | OMP_CLAUSE_COLLAPSE | OMP_CLAUSE_DIST_SCHEDULE \
    5077                 :             :    | OMP_CLAUSE_ORDER | OMP_CLAUSE_ALLOCATE)
    5078                 :             : #define OMP_SINGLE_CLAUSES \
    5079                 :             :   (omp_mask (OMP_CLAUSE_PRIVATE) | OMP_CLAUSE_FIRSTPRIVATE              \
    5080                 :             :    | OMP_CLAUSE_ALLOCATE | OMP_CLAUSE_NOWAIT | OMP_CLAUSE_COPYPRIVATE)
    5081                 :             : #define OMP_ORDERED_CLAUSES \
    5082                 :             :   (omp_mask (OMP_CLAUSE_THREADS) | OMP_CLAUSE_SIMD)
    5083                 :             : #define OMP_DECLARE_TARGET_CLAUSES \
    5084                 :             :   (omp_mask (OMP_CLAUSE_ENTER) | OMP_CLAUSE_LINK | OMP_CLAUSE_DEVICE_TYPE \
    5085                 :             :    | OMP_CLAUSE_TO | OMP_CLAUSE_INDIRECT)
    5086                 :             : #define OMP_ATOMIC_CLAUSES \
    5087                 :             :   (omp_mask (OMP_CLAUSE_ATOMIC) | OMP_CLAUSE_CAPTURE | OMP_CLAUSE_HINT  \
    5088                 :             :    | OMP_CLAUSE_MEMORDER | OMP_CLAUSE_COMPARE | OMP_CLAUSE_FAIL         \
    5089                 :             :    | OMP_CLAUSE_WEAK)
    5090                 :             : #define OMP_MASKED_CLAUSES \
    5091                 :             :   (omp_mask (OMP_CLAUSE_FILTER))
    5092                 :             : #define OMP_ERROR_CLAUSES \
    5093                 :             :   (omp_mask (OMP_CLAUSE_AT) | OMP_CLAUSE_MESSAGE | OMP_CLAUSE_SEVERITY)
    5094                 :             : #define OMP_WORKSHARE_CLAUSES \
    5095                 :             :   omp_mask (OMP_CLAUSE_NOWAIT)
    5096                 :             : #define OMP_UNROLL_CLAUSES \
    5097                 :             :   (omp_mask (OMP_CLAUSE_FULL) | OMP_CLAUSE_PARTIAL)
    5098                 :             : #define OMP_TILE_CLAUSES \
    5099                 :             :   (omp_mask (OMP_CLAUSE_SIZES))
    5100                 :             : #define OMP_ALLOCATORS_CLAUSES \
    5101                 :             :   omp_mask (OMP_CLAUSE_ALLOCATE)
    5102                 :             : #define OMP_INTEROP_CLAUSES \
    5103                 :             :   (omp_mask (OMP_CLAUSE_DEPEND) | OMP_CLAUSE_NOWAIT | OMP_CLAUSE_DEVICE \
    5104                 :             :    | OMP_CLAUSE_INIT | OMP_CLAUSE_DESTROY | OMP_CLAUSE_USE)
    5105                 :             : #define OMP_DISPATCH_CLAUSES                                                   \
    5106                 :             :   (omp_mask (OMP_CLAUSE_DEVICE) | OMP_CLAUSE_DEPEND | OMP_CLAUSE_NOVARIANTS    \
    5107                 :             :    | OMP_CLAUSE_NOCONTEXT | OMP_CLAUSE_IS_DEVICE_PTR | OMP_CLAUSE_NOWAIT       \
    5108                 :             :    | OMP_CLAUSE_HAS_DEVICE_ADDR | OMP_CLAUSE_INTEROP)
    5109                 :             : 
    5110                 :             : 
    5111                 :             : static match
    5112                 :       16342 : match_omp (gfc_exec_op op, const omp_mask mask)
    5113                 :             : {
    5114                 :       16342 :   gfc_omp_clauses *c;
    5115                 :       16342 :   if (gfc_match_omp_clauses (&c, mask, true, true, false,
    5116                 :             :                              op == EXEC_OMP_TARGET) != MATCH_YES)
    5117                 :             :     return MATCH_ERROR;
    5118                 :       16096 :   new_st.op = op;
    5119                 :       16096 :   new_st.ext.omp_clauses = c;
    5120                 :       16096 :   return MATCH_YES;
    5121                 :             : }
    5122                 :             : 
    5123                 :             : /* Handles both declarative and (deprecated) executable ALLOCATE directive;
    5124                 :             :    accepts optional list (for executable) and common blocks.
    5125                 :             :    If no variables have been provided, the single omp namelist has sym == NULL.
    5126                 :             : 
    5127                 :             :    Note that the executable ALLOCATE directive permits structure elements only
    5128                 :             :    in OpenMP 5.0 and 5.1 but not longer in 5.2.  See also the comment on the
    5129                 :             :    'omp allocators' directive below. The accidental change was reverted for
    5130                 :             :    OpenMP TR12, permitting them again. See also gfc_match_omp_allocators.
    5131                 :             : 
    5132                 :             :    Hence, structure elements are rejected for now, also to make resolving
    5133                 :             :    OMP_LIST_ALLOCATE simpler (check for duplicates, same symbol in
    5134                 :             :    Fortran allocate stmt).  TODO: Permit structure elements.  */
    5135                 :             : 
    5136                 :             : match
    5137                 :         183 : gfc_match_omp_allocate (void)
    5138                 :             : {
    5139                 :         183 :   match m;
    5140                 :         183 :   bool first = true;
    5141                 :         183 :   gfc_omp_namelist *vars = NULL;
    5142                 :         183 :   gfc_expr *align = NULL;
    5143                 :         183 :   gfc_expr *allocator = NULL;
    5144                 :         183 :   locus loc = gfc_current_locus;
    5145                 :             : 
    5146                 :         183 :   m = gfc_match_omp_variable_list (" (", &vars, true, NULL, NULL, true, true,
    5147                 :             :                                    NULL, true);
    5148                 :             : 
    5149                 :         183 :   if (m == MATCH_ERROR)
    5150                 :             :     return m;
    5151                 :             : 
    5152                 :         320 :   while (true)
    5153                 :             :     {
    5154                 :         320 :       gfc_gobble_whitespace ();
    5155                 :         320 :       if (gfc_match_omp_eos () == MATCH_YES)
    5156                 :             :         break;
    5157                 :         143 :       if (!first)
    5158                 :          27 :         gfc_match (", ");
    5159                 :         143 :       first = false;
    5160                 :         143 :       if ((m = gfc_match_dupl_check (!align, "align", true, &align))
    5161                 :             :           != MATCH_NO)
    5162                 :             :         {
    5163                 :          61 :           if (m == MATCH_ERROR)
    5164                 :           1 :             goto error;
    5165                 :          60 :           continue;
    5166                 :             :         }
    5167                 :          82 :       if ((m = gfc_match_dupl_check (!allocator, "allocator",
    5168                 :             :                                      true, &allocator)) != MATCH_NO)
    5169                 :             :         {
    5170                 :          81 :           if (m == MATCH_ERROR)
    5171                 :           1 :             goto error;
    5172                 :          80 :           continue;
    5173                 :             :         }
    5174                 :           1 :       gfc_error ("Expected ALIGN or ALLOCATOR clause at %C");
    5175                 :           1 :       return MATCH_ERROR;
    5176                 :             :     }
    5177                 :         359 :   for (gfc_omp_namelist *n = vars; n; n = n->next)
    5178                 :         185 :     if (n->expr)
    5179                 :             :       {
    5180                 :           3 :         if ((n->expr->ref && n->expr->ref->type == REF_COMPONENT)
    5181                 :           3 :             || (n->expr->ref->next && n->expr->ref->type == REF_COMPONENT))
    5182                 :           1 :           gfc_error ("Sorry, structure-element list item at %L in ALLOCATE "
    5183                 :             :                      "directive is not yet supported", &n->expr->where);
    5184                 :             :         else
    5185                 :           2 :           gfc_error ("Unexpected expression as list item at %L in ALLOCATE "
    5186                 :             :                      "directive", &n->expr->where);
    5187                 :             : 
    5188                 :           3 :         gfc_free_omp_namelist (vars, false, true, false, false);
    5189                 :           3 :         goto error;
    5190                 :             :       }
    5191                 :             : 
    5192                 :         174 :   new_st.op = EXEC_OMP_ALLOCATE;
    5193                 :         174 :   new_st.ext.omp_clauses = gfc_get_omp_clauses ();
    5194                 :         174 :   if (vars == NULL)
    5195                 :             :     {
    5196                 :          27 :       vars = gfc_get_omp_namelist ();
    5197                 :          27 :       vars->where = loc;
    5198                 :          27 :       vars->u.align = align;
    5199                 :          27 :       vars->u2.allocator = allocator;
    5200                 :          27 :       new_st.ext.omp_clauses->lists[OMP_LIST_ALLOCATE] = vars;
    5201                 :             :     }
    5202                 :             :   else
    5203                 :             :     {
    5204                 :         147 :       new_st.ext.omp_clauses->lists[OMP_LIST_ALLOCATE] = vars;
    5205                 :         329 :       for (; vars; vars = vars->next)
    5206                 :             :         {
    5207                 :         182 :           vars->u.align = (align) ? gfc_copy_expr (align) : NULL;
    5208                 :         182 :           vars->u2.allocator = allocator;
    5209                 :             :         }
    5210                 :         147 :       gfc_free_expr (align);
    5211                 :             :     }
    5212                 :             :   return MATCH_YES;
    5213                 :             : 
    5214                 :           5 : error:
    5215                 :           5 :   gfc_free_expr (align);
    5216                 :           5 :   gfc_free_expr (allocator);
    5217                 :           5 :   return MATCH_ERROR;
    5218                 :             : }
    5219                 :             : 
    5220                 :             : /* In line with OpenMP 5.2 derived-type components are rejected.
    5221                 :             :    See also comment before gfc_match_omp_allocate.  */
    5222                 :             : 
    5223                 :             : match
    5224                 :          25 : gfc_match_omp_allocators (void)
    5225                 :             : {
    5226                 :          25 :   return match_omp (EXEC_OMP_ALLOCATORS, OMP_ALLOCATORS_CLAUSES);
    5227                 :             : }
    5228                 :             : 
    5229                 :             : 
    5230                 :             : match
    5231                 :          19 : gfc_match_omp_assume (void)
    5232                 :             : {
    5233                 :          19 :   gfc_omp_clauses *c;
    5234                 :          19 :   locus loc = gfc_current_locus;
    5235                 :          19 :   if ((gfc_match_omp_clauses (&c, omp_mask (OMP_CLAUSE_ASSUMPTIONS))
    5236                 :             :        != MATCH_YES)
    5237                 :          19 :       || (omp_verify_merge_absent_contains (ST_OMP_ASSUME, c->assume, NULL,
    5238                 :             :                                             &loc) != MATCH_YES))
    5239                 :           4 :     return MATCH_ERROR;
    5240                 :          15 :   new_st.op = EXEC_OMP_ASSUME;
    5241                 :          15 :   new_st.ext.omp_clauses = c;
    5242                 :          15 :   return MATCH_YES;
    5243                 :             : }
    5244                 :             : 
    5245                 :             : 
    5246                 :             : match
    5247                 :          28 : gfc_match_omp_assumes (void)
    5248                 :             : {
    5249                 :          28 :   gfc_omp_clauses *c;
    5250                 :          28 :   locus loc = gfc_current_locus;
    5251                 :          28 :   if (!gfc_current_ns->proc_name
    5252                 :          27 :       || (gfc_current_ns->proc_name->attr.flavor != FL_MODULE
    5253                 :             :           && !gfc_current_ns->proc_name->attr.subroutine
    5254                 :          23 :           && !gfc_current_ns->proc_name->attr.function))
    5255                 :             :     {
    5256                 :           2 :       gfc_error ("!$OMP ASSUMES at %C must be in the specification part of a "
    5257                 :             :                  "subprogram or module");
    5258                 :           2 :       return MATCH_ERROR;
    5259                 :             :     }
    5260                 :          26 :   if ((gfc_match_omp_clauses (&c, omp_mask (OMP_CLAUSE_ASSUMPTIONS))
    5261                 :             :        != MATCH_YES)
    5262                 :          26 :       || (omp_verify_merge_absent_contains (ST_OMP_ASSUMES, c->assume,
    5263                 :             :                                             gfc_current_ns->omp_assumes, &loc)
    5264                 :             :           != MATCH_YES))
    5265                 :           5 :     return MATCH_ERROR;
    5266                 :          21 :   if (gfc_current_ns->omp_assumes == NULL)
    5267                 :             :     {
    5268                 :          19 :       gfc_current_ns->omp_assumes = c->assume;
    5269                 :          19 :       c->assume = NULL;
    5270                 :             :     }
    5271                 :           2 :   else if (gfc_current_ns->omp_assumes && c->assume)
    5272                 :             :     {
    5273                 :           2 :       gfc_current_ns->omp_assumes->no_openmp |= c->assume->no_openmp;
    5274                 :           2 :       gfc_current_ns->omp_assumes->no_openmp_routines
    5275                 :           2 :         |= c->assume->no_openmp_routines;
    5276                 :           2 :       gfc_current_ns->omp_assumes->no_parallelism |= c->assume->no_parallelism;
    5277                 :           2 :       if (gfc_current_ns->omp_assumes->holds && c->assume->holds)
    5278                 :             :         {
    5279                 :             :           gfc_expr_list *el = gfc_current_ns->omp_assumes->holds;
    5280                 :           1 :           for ( ; el->next ; el = el->next)
    5281                 :             :             ;
    5282                 :           1 :           el->next = c->assume->holds;
    5283                 :           1 :         }
    5284                 :           1 :       else if (c->assume->holds)
    5285                 :           0 :         gfc_current_ns->omp_assumes->holds = c->assume->holds;
    5286                 :           2 :       c->assume->holds = NULL;
    5287                 :             :     }
    5288                 :          21 :   gfc_free_omp_clauses (c);
    5289                 :          21 :   return MATCH_YES;
    5290                 :             : }
    5291                 :             : 
    5292                 :             : 
    5293                 :             : match
    5294                 :         162 : gfc_match_omp_critical (void)
    5295                 :             : {
    5296                 :         162 :   char n[GFC_MAX_SYMBOL_LEN+1];
    5297                 :         162 :   gfc_omp_clauses *c = NULL;
    5298                 :             : 
    5299                 :         162 :   if (gfc_match (" ( %n )", n) != MATCH_YES)
    5300                 :         115 :     n[0] = '\0';
    5301                 :             : 
    5302                 :         162 :   if (gfc_match_omp_clauses (&c, omp_mask (OMP_CLAUSE_HINT),
    5303                 :         162 :                              /* first = */ n[0] == '\0') != MATCH_YES)
    5304                 :             :     return MATCH_ERROR;
    5305                 :             : 
    5306                 :         160 :   new_st.op = EXEC_OMP_CRITICAL;
    5307                 :         160 :   new_st.ext.omp_clauses = c;
    5308                 :         160 :   if (n[0])
    5309                 :          47 :     c->critical_name = xstrdup (n);
    5310                 :             :   return MATCH_YES;
    5311                 :             : }
    5312                 :             : 
    5313                 :             : 
    5314                 :             : match
    5315                 :         160 : gfc_match_omp_end_critical (void)
    5316                 :             : {
    5317                 :         160 :   char n[GFC_MAX_SYMBOL_LEN+1];
    5318                 :             : 
    5319                 :         160 :   if (gfc_match (" ( %n )", n) != MATCH_YES)
    5320                 :         113 :     n[0] = '\0';
    5321                 :         160 :   if (gfc_match_omp_eos () != MATCH_YES)
    5322                 :             :     {
    5323                 :           1 :       gfc_error ("Unexpected junk after $OMP CRITICAL statement at %C");
    5324                 :           1 :       return MATCH_ERROR;
    5325                 :             :     }
    5326                 :             : 
    5327                 :         159 :   new_st.op = EXEC_OMP_END_CRITICAL;
    5328                 :         159 :   new_st.ext.omp_name = n[0] ? xstrdup (n) : NULL;
    5329                 :         159 :   return MATCH_YES;
    5330                 :             : }
    5331                 :             : 
    5332                 :             : /* depobj(depobj) depend(dep-type:loc)|destroy|update(dep-type)
    5333                 :             :    dep-type = in/out/inout/mutexinoutset/depobj/source/sink
    5334                 :             :    depend: !source, !sink
    5335                 :             :    update: !source, !sink, !depobj
    5336                 :             :    locator = exactly one list item  .*/
    5337                 :             : match
    5338                 :         123 : gfc_match_omp_depobj (void)
    5339                 :             : {
    5340                 :         123 :   gfc_omp_clauses *c = NULL;
    5341                 :         123 :   gfc_expr *depobj;
    5342                 :             : 
    5343                 :         123 :   if (gfc_match (" ( %v ) ", &depobj) != MATCH_YES)
    5344                 :             :     {
    5345                 :           2 :       gfc_error ("Expected %<( depobj )%> at %C");
    5346                 :           2 :       return MATCH_ERROR;
    5347                 :             :     }
    5348                 :         121 :   if (gfc_match ("update ( ") == MATCH_YES)
    5349                 :             :     {
    5350                 :          12 :       c = gfc_get_omp_clauses ();
    5351                 :          12 :       if (gfc_match ("inoutset )") == MATCH_YES)
    5352                 :           2 :         c->depobj_update = OMP_DEPEND_INOUTSET;
    5353                 :          10 :       else if (gfc_match ("inout )") == MATCH_YES)
    5354                 :           1 :         c->depobj_update = OMP_DEPEND_INOUT;
    5355                 :           9 :       else if (gfc_match ("in )") == MATCH_YES)
    5356                 :           2 :         c->depobj_update = OMP_DEPEND_IN;
    5357                 :           7 :       else if (gfc_match ("out )") == MATCH_YES)
    5358                 :           2 :         c->depobj_update = OMP_DEPEND_OUT;
    5359                 :           5 :       else if (gfc_match ("mutexinoutset )") == MATCH_YES)
    5360                 :           2 :         c->depobj_update = OMP_DEPEND_MUTEXINOUTSET;
    5361                 :             :       else
    5362                 :             :         {
    5363                 :           3 :           gfc_error ("Expected IN, OUT, INOUT, INOUTSET or MUTEXINOUTSET "
    5364                 :             :                      "followed by %<)%> at %C");
    5365                 :           3 :           goto error;
    5366                 :             :         }
    5367                 :             :     }
    5368                 :         109 :   else if (gfc_match ("destroy ") == MATCH_YES)
    5369                 :             :     {
    5370                 :          15 :       gfc_expr *destroyobj = NULL;
    5371                 :          15 :       c = gfc_get_omp_clauses ();
    5372                 :          15 :       c->destroy = true;
    5373                 :             : 
    5374                 :          15 :       if (gfc_match (" ( %v ) ", &destroyobj) == MATCH_YES)
    5375                 :             :         {
    5376                 :           3 :           if (destroyobj->symtree != depobj->symtree)
    5377                 :           2 :             gfc_warning (OPT_Wopenmp, "The same depend object should be used as"
    5378                 :             :                          " DEPOBJ argument at %L and as DESTROY argument at %L",
    5379                 :             :                          &depobj->where, &destroyobj->where);
    5380                 :           3 :           gfc_free_expr (destroyobj);
    5381                 :             :         }
    5382                 :             :     }
    5383                 :          94 :   else if (gfc_match_omp_clauses (&c, omp_mask (OMP_CLAUSE_DEPEND), true, false)
    5384                 :             :            != MATCH_YES)
    5385                 :           2 :     goto error;
    5386                 :             : 
    5387                 :         116 :   if (c->depobj_update == OMP_DEPEND_UNSET && !c->destroy)
    5388                 :             :     {
    5389                 :          92 :       if (!c->doacross_source && !c->lists[OMP_LIST_DEPEND])
    5390                 :             :         {
    5391                 :           1 :           gfc_error ("Expected DEPEND, UPDATE, or DESTROY clause at %C");
    5392                 :           1 :           goto error;
    5393                 :             :         }
    5394                 :          91 :       if (c->lists[OMP_LIST_DEPEND]->u.depend_doacross_op == OMP_DEPEND_DEPOBJ)
    5395                 :             :         {
    5396                 :           1 :           gfc_error ("DEPEND clause at %L of OMP DEPOBJ construct shall not "
    5397                 :             :                      "have dependence-type DEPOBJ",
    5398                 :             :                      c->lists[OMP_LIST_DEPEND]
    5399                 :             :                      ? &c->lists[OMP_LIST_DEPEND]->where : &gfc_current_locus);
    5400                 :           1 :           goto error;
    5401                 :             :         }
    5402                 :          90 :       if (c->lists[OMP_LIST_DEPEND]->next)
    5403                 :             :         {
    5404                 :           1 :           gfc_error ("DEPEND clause at %L of OMP DEPOBJ construct shall have "
    5405                 :             :                      "only a single locator",
    5406                 :             :                      &c->lists[OMP_LIST_DEPEND]->next->where);
    5407                 :           1 :           goto error;
    5408                 :             :         }
    5409                 :             :     }
    5410                 :             : 
    5411                 :         113 :   c->depobj = depobj;
    5412                 :         113 :   new_st.op = EXEC_OMP_DEPOBJ;
    5413                 :         113 :   new_st.ext.omp_clauses = c;
    5414                 :         113 :   return MATCH_YES;
    5415                 :             : 
    5416                 :           8 : error:
    5417                 :           8 :   gfc_free_expr (depobj);
    5418                 :           8 :   gfc_free_omp_clauses (c);
    5419                 :           8 :   return MATCH_ERROR;
    5420                 :             : }
    5421                 :             : 
    5422                 :             : match
    5423                 :         160 : gfc_match_omp_dispatch (void)
    5424                 :             : {
    5425                 :         160 :   return match_omp (EXEC_OMP_DISPATCH, OMP_DISPATCH_CLAUSES);
    5426                 :             : }
    5427                 :             : 
    5428                 :             : match
    5429                 :          57 : gfc_match_omp_distribute (void)
    5430                 :             : {
    5431                 :          57 :   return match_omp (EXEC_OMP_DISTRIBUTE, OMP_DISTRIBUTE_CLAUSES);
    5432                 :             : }
    5433                 :             : 
    5434                 :             : 
    5435                 :             : match
    5436                 :          44 : gfc_match_omp_distribute_parallel_do (void)
    5437                 :             : {
    5438                 :          44 :   return match_omp (EXEC_OMP_DISTRIBUTE_PARALLEL_DO,
    5439                 :          44 :                     (OMP_DISTRIBUTE_CLAUSES | OMP_PARALLEL_CLAUSES
    5440                 :          44 :                      | OMP_DO_CLAUSES)
    5441                 :          44 :                     & ~(omp_mask (OMP_CLAUSE_ORDERED)
    5442                 :          44 :                         | OMP_CLAUSE_LINEAR | OMP_CLAUSE_NOWAIT));
    5443                 :             : }
    5444                 :             : 
    5445                 :             : 
    5446                 :             : match
    5447                 :          34 : gfc_match_omp_distribute_parallel_do_simd (void)
    5448                 :             : {
    5449                 :          34 :   return match_omp (EXEC_OMP_DISTRIBUTE_PARALLEL_DO_SIMD,
    5450                 :          34 :                     (OMP_DISTRIBUTE_CLAUSES | OMP_PARALLEL_CLAUSES
    5451                 :          34 :                      | OMP_DO_CLAUSES | OMP_SIMD_CLAUSES)
    5452                 :          34 :                     & ~(omp_mask (OMP_CLAUSE_ORDERED) | OMP_CLAUSE_NOWAIT));
    5453                 :             : }
    5454                 :             : 
    5455                 :             : 
    5456                 :             : match
    5457                 :          52 : gfc_match_omp_distribute_simd (void)
    5458                 :             : {
    5459                 :          52 :   return match_omp (EXEC_OMP_DISTRIBUTE_SIMD,
    5460                 :          52 :                     OMP_DISTRIBUTE_CLAUSES | OMP_SIMD_CLAUSES);
    5461                 :             : }
    5462                 :             : 
    5463                 :             : 
    5464                 :             : match
    5465                 :        1246 : gfc_match_omp_do (void)
    5466                 :             : {
    5467                 :        1246 :   return match_omp (EXEC_OMP_DO, OMP_DO_CLAUSES);
    5468                 :             : }
    5469                 :             : 
    5470                 :             : 
    5471                 :             : match
    5472                 :         137 : gfc_match_omp_do_simd (void)
    5473                 :             : {
    5474                 :         137 :   return match_omp (EXEC_OMP_DO_SIMD, OMP_DO_CLAUSES | OMP_SIMD_CLAUSES);
    5475                 :             : }
    5476                 :             : 
    5477                 :             : 
    5478                 :             : match
    5479                 :          70 : gfc_match_omp_loop (void)
    5480                 :             : {
    5481                 :          70 :   return match_omp (EXEC_OMP_LOOP, OMP_LOOP_CLAUSES);
    5482                 :             : }
    5483                 :             : 
    5484                 :             : 
    5485                 :             : match
    5486                 :          35 : gfc_match_omp_teams_loop (void)
    5487                 :             : {
    5488                 :          35 :   return match_omp (EXEC_OMP_TEAMS_LOOP, OMP_TEAMS_CLAUSES | OMP_LOOP_CLAUSES);
    5489                 :             : }
    5490                 :             : 
    5491                 :             : 
    5492                 :             : match
    5493                 :          17 : gfc_match_omp_target_teams_loop (void)
    5494                 :             : {
    5495                 :          17 :   return match_omp (EXEC_OMP_TARGET_TEAMS_LOOP,
    5496                 :          17 :                     OMP_TARGET_CLAUSES | OMP_TEAMS_CLAUSES | OMP_LOOP_CLAUSES);
    5497                 :             : }
    5498                 :             : 
    5499                 :             : 
    5500                 :             : match
    5501                 :          31 : gfc_match_omp_parallel_loop (void)
    5502                 :             : {
    5503                 :          31 :   return match_omp (EXEC_OMP_PARALLEL_LOOP,
    5504                 :          31 :                     OMP_PARALLEL_CLAUSES | OMP_LOOP_CLAUSES);
    5505                 :             : }
    5506                 :             : 
    5507                 :             : 
    5508                 :             : match
    5509                 :          16 : gfc_match_omp_target_parallel_loop (void)
    5510                 :             : {
    5511                 :          16 :   return match_omp (EXEC_OMP_TARGET_PARALLEL_LOOP,
    5512                 :          16 :                     (OMP_TARGET_CLAUSES | OMP_PARALLEL_CLAUSES
    5513                 :          16 :                      | OMP_LOOP_CLAUSES));
    5514                 :             : }
    5515                 :             : 
    5516                 :             : 
    5517                 :             : match
    5518                 :          99 : gfc_match_omp_error (void)
    5519                 :             : {
    5520                 :          99 :   locus loc = gfc_current_locus;
    5521                 :          99 :   match m = match_omp (EXEC_OMP_ERROR, OMP_ERROR_CLAUSES);
    5522                 :          99 :   if (m != MATCH_YES)
    5523                 :             :     return m;
    5524                 :             : 
    5525                 :          80 :   gfc_omp_clauses *c = new_st.ext.omp_clauses;
    5526                 :          80 :   if (c->severity == OMP_SEVERITY_UNSET)
    5527                 :          43 :     c->severity = OMP_SEVERITY_FATAL;
    5528                 :          80 :   if (new_st.ext.omp_clauses->at == OMP_AT_EXECUTION)
    5529                 :             :     return MATCH_YES;
    5530                 :          36 :   if (c->message
    5531                 :          36 :       && (!gfc_resolve_expr (c->message)
    5532                 :          16 :           || c->message->ts.type != BT_CHARACTER
    5533                 :          14 :           || c->message->ts.kind != gfc_default_character_kind
    5534                 :          13 :           || c->message->rank != 0))
    5535                 :             :     {
    5536                 :           4 :       gfc_error ("MESSAGE clause at %L requires a scalar default-kind "
    5537                 :             :                    "CHARACTER expression",
    5538                 :           4 :                  &new_st.ext.omp_clauses->message->where);
    5539                 :           4 :       return MATCH_ERROR;
    5540                 :             :     }
    5541                 :          32 :   if (c->message && !gfc_is_constant_expr (c->message))
    5542                 :             :     {
    5543                 :           2 :       gfc_error ("Constant character expression required in MESSAGE clause "
    5544                 :           2 :                  "at %L", &new_st.ext.omp_clauses->message->where);
    5545                 :           2 :       return MATCH_ERROR;
    5546                 :             :     }
    5547                 :          30 :   if (c->message)
    5548                 :             :     {
    5549                 :          10 :       const char *msg = G_("$OMP ERROR encountered at %L: %s");
    5550                 :          10 :       gcc_assert (c->message->expr_type == EXPR_CONSTANT);
    5551                 :          10 :       gfc_charlen_t slen = c->message->value.character.length;
    5552                 :          10 :       int i = gfc_validate_kind (BT_CHARACTER, gfc_default_character_kind,
    5553                 :             :                                  false);
    5554                 :          10 :       size_t size = slen * gfc_character_kinds[i].bit_size / 8;
    5555                 :          10 :       unsigned char *s = XCNEWVAR (unsigned char, size + 1);
    5556                 :          10 :       gfc_encode_character (gfc_default_character_kind, slen,
    5557                 :          10 :                             c->message->value.character.string,
    5558                 :             :                             (unsigned char *) s, size);
    5559                 :          10 :       s[size] = '\0';
    5560                 :          10 :       if (c->severity == OMP_SEVERITY_WARNING)
    5561                 :           6 :         gfc_warning_now (0, msg, &loc, s);
    5562                 :             :       else
    5563                 :           4 :         gfc_error_now (msg, &loc, s);
    5564                 :          10 :       free (s);
    5565                 :             :     }
    5566                 :             :   else
    5567                 :             :     {
    5568                 :          20 :       const char *msg = G_("$OMP ERROR encountered at %L");
    5569                 :          20 :       if (c->severity == OMP_SEVERITY_WARNING)
    5570                 :           7 :         gfc_warning_now (0, msg, &loc);
    5571                 :             :       else
    5572                 :          13 :         gfc_error_now (msg, &loc);
    5573                 :             :     }
    5574                 :             :   return MATCH_YES;
    5575                 :             : }
    5576                 :             : 
    5577                 :             : match
    5578                 :          86 : gfc_match_omp_flush (void)
    5579                 :             : {
    5580                 :          86 :   gfc_omp_namelist *list = NULL;
    5581                 :          86 :   gfc_omp_clauses *c = NULL;
    5582                 :          86 :   gfc_gobble_whitespace ();
    5583                 :          86 :   enum gfc_omp_memorder mo = OMP_MEMORDER_UNSET;
    5584                 :          86 :   if (gfc_match_omp_eos () == MATCH_NO && gfc_peek_ascii_char () != '(')
    5585                 :             :     {
    5586                 :          14 :       if (gfc_match ("seq_cst") == MATCH_YES)
    5587                 :             :         mo = OMP_MEMORDER_SEQ_CST;
    5588                 :          11 :       else if (gfc_match ("acq_rel") == MATCH_YES)
    5589                 :             :         mo = OMP_MEMORDER_ACQ_REL;
    5590                 :           8 :       else if (gfc_match ("release") == MATCH_YES)
    5591                 :             :         mo = OMP_MEMORDER_RELEASE;
    5592                 :           5 :       else if (gfc_match ("acquire") == MATCH_YES)
    5593                 :             :         mo = OMP_MEMORDER_ACQUIRE;
    5594                 :             :       else
    5595                 :             :         {
    5596                 :           2 :           gfc_error ("Expected SEQ_CST, AQC_REL, RELEASE, or ACQUIRE at %C");
    5597                 :           2 :           return MATCH_ERROR;
    5598                 :             :         }
    5599                 :          12 :       c = gfc_get_omp_clauses ();
    5600                 :          12 :       c->memorder = mo;
    5601                 :             :     }
    5602                 :          84 :   gfc_match_omp_variable_list (" (", &list, true);
    5603                 :          84 :   if (list && mo != OMP_MEMORDER_UNSET)
    5604                 :             :     {
    5605                 :           4 :       gfc_error ("List specified together with memory order clause in FLUSH "
    5606                 :             :                  "directive at %C");
    5607                 :           4 :       gfc_free_omp_namelist (list, false, false, false, false);
    5608                 :           4 :       gfc_free_omp_clauses (c);
    5609                 :           4 :       return MATCH_ERROR;
    5610                 :             :     }
    5611                 :          80 :   if (gfc_match_omp_eos () != MATCH_YES)
    5612                 :             :     {
    5613                 :           0 :       gfc_error ("Unexpected junk after $OMP FLUSH statement at %C");
    5614                 :           0 :       gfc_free_omp_namelist (list, false, false, false, false);
    5615                 :           0 :       gfc_free_omp_clauses (c);
    5616                 :           0 :       return MATCH_ERROR;
    5617                 :             :     }
    5618                 :          80 :   new_st.op = EXEC_OMP_FLUSH;
    5619                 :          80 :   new_st.ext.omp_namelist = list;
    5620                 :          80 :   new_st.ext.omp_clauses = c;
    5621                 :          80 :   return MATCH_YES;
    5622                 :             : }
    5623                 :             : 
    5624                 :             : 
    5625                 :             : match
    5626                 :         188 : gfc_match_omp_declare_simd (void)
    5627                 :             : {
    5628                 :         188 :   locus where = gfc_current_locus;
    5629                 :         188 :   gfc_symbol *proc_name;
    5630                 :         188 :   gfc_omp_clauses *c;
    5631                 :         188 :   gfc_omp_declare_simd *ods;
    5632                 :         188 :   bool needs_space = false;
    5633                 :             : 
    5634                 :         188 :   switch (gfc_match (" ( "))
    5635                 :             :     {
    5636                 :         144 :     case MATCH_YES:
    5637                 :         144 :       if (gfc_match_symbol (&proc_name, /* host assoc = */ true) != MATCH_YES
    5638                 :         144 :           || gfc_match (" ) ") != MATCH_YES)
    5639                 :           0 :         return MATCH_ERROR;
    5640                 :             :       break;
    5641                 :          44 :     case MATCH_NO: proc_name = NULL; needs_space = true; break;
    5642                 :             :     case MATCH_ERROR: return MATCH_ERROR;
    5643                 :             :     }
    5644                 :             : 
    5645                 :         188 :   if (gfc_match_omp_clauses (&c, OMP_DECLARE_SIMD_CLAUSES, true,
    5646                 :             :                              needs_space) != MATCH_YES)
    5647                 :             :     return MATCH_ERROR;
    5648                 :             : 
    5649                 :         183 :   if (gfc_current_ns->is_block_data)
    5650                 :             :     {
    5651                 :           1 :       gfc_free_omp_clauses (c);
    5652                 :           1 :       return MATCH_YES;
    5653                 :             :     }
    5654                 :             : 
    5655                 :         182 :   ods = gfc_get_omp_declare_simd ();
    5656                 :         182 :   ods->where = where;
    5657                 :         182 :   ods->proc_name = proc_name;
    5658                 :         182 :   ods->clauses = c;
    5659                 :         182 :   ods->next = gfc_current_ns->omp_declare_simd;
    5660                 :         182 :   gfc_current_ns->omp_declare_simd = ods;
    5661                 :         182 :   return MATCH_YES;
    5662                 :             : }
    5663                 :             : 
    5664                 :             : 
    5665                 :             : static bool
    5666                 :         877 : match_udr_expr (gfc_symtree *omp_sym1, gfc_symtree *omp_sym2)
    5667                 :             : {
    5668                 :         877 :   match m;
    5669                 :         877 :   locus old_loc = gfc_current_locus;
    5670                 :         877 :   char sname[GFC_MAX_SYMBOL_LEN + 1];
    5671                 :         877 :   gfc_symbol *sym;
    5672                 :         877 :   gfc_namespace *ns = gfc_current_ns;
    5673                 :         877 :   gfc_expr *lvalue = NULL, *rvalue = NULL;
    5674                 :         877 :   gfc_symtree *st;
    5675                 :         877 :   gfc_actual_arglist *arglist;
    5676                 :             : 
    5677                 :         877 :   m = gfc_match (" %v =", &lvalue);
    5678                 :         877 :   if (m != MATCH_YES)
    5679                 :         200 :     gfc_current_locus = old_loc;
    5680                 :             :   else
    5681                 :             :     {
    5682                 :         677 :       m = gfc_match (" %e )", &rvalue);
    5683                 :         677 :       if (m == MATCH_YES)
    5684                 :             :         {
    5685                 :         675 :           ns->code = gfc_get_code (EXEC_ASSIGN);
    5686                 :         675 :           ns->code->expr1 = lvalue;
    5687                 :         675 :           ns->code->expr2 = rvalue;
    5688                 :         675 :           ns->code->loc = old_loc;
    5689                 :         675 :           return true;
    5690                 :             :         }
    5691                 :             : 
    5692                 :           2 :       gfc_current_locus = old_loc;
    5693                 :           2 :       gfc_free_expr (lvalue);
    5694                 :             :     }
    5695                 :             : 
    5696                 :         202 :   m = gfc_match (" %n", sname);
    5697                 :         202 :   if (m != MATCH_YES)
    5698                 :             :     return false;
    5699                 :             : 
    5700                 :         202 :   if (strcmp (sname, omp_sym1->name) == 0
    5701                 :         200 :       || strcmp (sname, omp_sym2->name) == 0)
    5702                 :             :     return false;
    5703                 :             : 
    5704                 :         200 :   gfc_current_ns = ns->parent;
    5705                 :         200 :   if (gfc_get_ha_sym_tree (sname, &st))
    5706                 :             :     return false;
    5707                 :             : 
    5708                 :         200 :   sym = st->n.sym;
    5709                 :         200 :   if (sym->attr.flavor != FL_PROCEDURE
    5710                 :          72 :       && sym->attr.flavor != FL_UNKNOWN)
    5711                 :             :     return false;
    5712                 :             : 
    5713                 :         199 :   if (!sym->attr.generic
    5714                 :             :       && !sym->attr.subroutine
    5715                 :         199 :       && !sym->attr.function)
    5716                 :             :     {
    5717                 :          71 :       if (!(sym->attr.external && !sym->attr.referenced))
    5718                 :             :         {
    5719                 :             :           /* ...create a symbol in this scope...  */
    5720                 :          71 :           if (sym->ns != gfc_current_ns
    5721                 :          71 :               && gfc_get_sym_tree (sname, NULL, &st, false) == 1)
    5722                 :             :             return false;
    5723                 :             : 
    5724                 :          71 :           if (sym != st->n.sym)
    5725                 :          71 :             sym = st->n.sym;
    5726                 :             :         }
    5727                 :             : 
    5728                 :             :       /* ...and then to try to make the symbol into a subroutine.  */
    5729                 :          71 :       if (!gfc_add_subroutine (&sym->attr, sym->name, NULL))
    5730                 :             :         return false;
    5731                 :             :     }
    5732                 :             : 
    5733                 :         199 :   gfc_set_sym_referenced (sym);
    5734                 :         199 :   gfc_gobble_whitespace ();
    5735                 :         199 :   if (gfc_peek_ascii_char () != '(')
    5736                 :             :     return false;
    5737                 :             : 
    5738                 :         195 :   gfc_current_ns = ns;
    5739                 :         195 :   m = gfc_match_actual_arglist (1, &arglist);
    5740                 :         195 :   if (m != MATCH_YES)
    5741                 :             :     return false;
    5742                 :             : 
    5743                 :         195 :   if (gfc_match_char (')') != MATCH_YES)
    5744                 :             :     return false;
    5745                 :             : 
    5746                 :         195 :   ns->code = gfc_get_code (EXEC_CALL);
    5747                 :         195 :   ns->code->symtree = st;
    5748                 :         195 :   ns->code->ext.actual = arglist;
    5749                 :         195 :   ns->code->loc = old_loc;
    5750                 :         195 :   return true;
    5751                 :             : }
    5752                 :             : 
    5753                 :             : static bool
    5754                 :        1156 : gfc_omp_udr_predef (gfc_omp_reduction_op rop, const char *name,
    5755                 :             :                     gfc_typespec *ts, const char **n)
    5756                 :             : {
    5757                 :        1156 :   if (!gfc_numeric_ts (ts) && ts->type != BT_LOGICAL)
    5758                 :             :     return false;
    5759                 :             : 
    5760                 :         648 :   switch (rop)
    5761                 :             :     {
    5762                 :          21 :     case OMP_REDUCTION_PLUS:
    5763                 :          21 :     case OMP_REDUCTION_MINUS:
    5764                 :          21 :     case OMP_REDUCTION_TIMES:
    5765                 :          21 :       return ts->type != BT_LOGICAL;
    5766                 :           8 :     case OMP_REDUCTION_AND:
    5767                 :           8 :     case OMP_REDUCTION_OR:
    5768                 :           8 :     case OMP_REDUCTION_EQV:
    5769                 :           8 :     case OMP_REDUCTION_NEQV:
    5770                 :           8 :       return ts->type == BT_LOGICAL;
    5771                 :         618 :     case OMP_REDUCTION_USER:
    5772                 :         618 :       if (name[0] != '.' && (ts->type == BT_INTEGER || ts->type == BT_REAL))
    5773                 :             :         {
    5774                 :         546 :           gfc_symbol *sym;
    5775                 :             : 
    5776                 :         546 :           gfc_find_symbol (name, NULL, 1, &sym);
    5777                 :         546 :           if (sym != NULL)
    5778                 :             :             {
    5779                 :          93 :               if (sym->attr.intrinsic)
    5780                 :           0 :                 *n = sym->name;
    5781                 :          93 :               else if ((sym->attr.flavor != FL_UNKNOWN
    5782                 :          81 :                         && sym->attr.flavor != FL_PROCEDURE)
    5783                 :             :                        || sym->attr.external
    5784                 :          69 :                        || sym->attr.generic
    5785                 :          54 :                        || sym->attr.entry
    5786                 :             :                        || sym->attr.result
    5787                 :             :                        || sym->attr.dummy
    5788                 :             :                        || sym->attr.subroutine
    5789                 :             :                        || sym->attr.pointer
    5790                 :          54 :                        || sym->attr.target
    5791                 :             :                        || sym->attr.cray_pointer
    5792                 :          50 :                        || sym->attr.cray_pointee
    5793                 :          50 :                        || (sym->attr.proc != PROC_UNKNOWN
    5794                 :           0 :                            && sym->attr.proc != PROC_INTRINSIC)
    5795                 :          50 :                        || sym->attr.if_source != IFSRC_UNKNOWN
    5796                 :          50 :                        || sym == sym->ns->proc_name)
    5797                 :          43 :                 *n = NULL;
    5798                 :             :               else
    5799                 :          50 :                 *n = sym->name;
    5800                 :             :             }
    5801                 :             :           else
    5802                 :         453 :             *n = name;
    5803                 :         546 :           if (*n
    5804                 :         503 :               && (strcmp (*n, "max") == 0 || strcmp (*n, "min") == 0))
    5805                 :          54 :             return true;
    5806                 :         510 :           else if (*n
    5807                 :         467 :                    && ts->type == BT_INTEGER
    5808                 :         383 :                    && (strcmp (*n, "iand") == 0
    5809                 :         377 :                        || strcmp (*n, "ior") == 0
    5810                 :         371 :                        || strcmp (*n, "ieor") == 0))
    5811                 :             :             return true;
    5812                 :             :         }
    5813                 :             :       break;
    5814                 :             :     default:
    5815                 :             :       break;
    5816                 :             :     }
    5817                 :             :   return false;
    5818                 :             : }
    5819                 :             : 
    5820                 :             : gfc_omp_udr *
    5821                 :         639 : gfc_omp_udr_find (gfc_symtree *st, gfc_typespec *ts)
    5822                 :             : {
    5823                 :         639 :   gfc_omp_udr *omp_udr;
    5824                 :             : 
    5825                 :         639 :   if (st == NULL)
    5826                 :             :     return NULL;
    5827                 :             : 
    5828                 :         250 :   for (omp_udr = st->n.omp_udr; omp_udr; omp_udr = omp_udr->next)
    5829                 :         154 :     if (omp_udr->ts.type == ts->type
    5830                 :          89 :         || ((omp_udr->ts.type == BT_DERIVED || omp_udr->ts.type == BT_CLASS)
    5831                 :           0 :             && (ts->type == BT_DERIVED || ts->type == BT_CLASS)))
    5832                 :             :       {
    5833                 :          65 :         if (omp_udr->ts.type == BT_DERIVED || omp_udr->ts.type == BT_CLASS)
    5834                 :             :           {
    5835                 :          12 :             if (strcmp (omp_udr->ts.u.derived->name, ts->u.derived->name) == 0)
    5836                 :             :               return omp_udr;
    5837                 :             :           }
    5838                 :          53 :         else if (omp_udr->ts.kind == ts->kind)
    5839                 :             :           {
    5840                 :          19 :             if (omp_udr->ts.type == BT_CHARACTER)
    5841                 :             :               {
    5842                 :          17 :                 if (omp_udr->ts.u.cl->length == NULL
    5843                 :          15 :                     || ts->u.cl->length == NULL)
    5844                 :             :                   return omp_udr;
    5845                 :          15 :                 if (omp_udr->ts.u.cl->length->expr_type != EXPR_CONSTANT)
    5846                 :             :                   return omp_udr;
    5847                 :          15 :                 if (ts->u.cl->length->expr_type != EXPR_CONSTANT)
    5848                 :             :                   return omp_udr;
    5849                 :          15 :                 if (omp_udr->ts.u.cl->length->ts.type != BT_INTEGER)
    5850                 :             :                   return omp_udr;
    5851                 :          15 :                 if (ts->u.cl->length->ts.type != BT_INTEGER)
    5852                 :             :                   return omp_udr;
    5853                 :          15 :                 if (gfc_compare_expr (omp_udr->ts.u.cl->length,
    5854                 :             :                                       ts->u.cl->length, INTRINSIC_EQ) != 0)
    5855                 :          15 :                   continue;
    5856                 :             :               }
    5857                 :           2 :             return omp_udr;
    5858                 :             :           }
    5859                 :             :       }
    5860                 :             :   return NULL;
    5861                 :             : }
    5862                 :             : 
    5863                 :             : match
    5864                 :         532 : gfc_match_omp_declare_reduction (void)
    5865                 :             : {
    5866                 :         532 :   match m;
    5867                 :         532 :   gfc_intrinsic_op op;
    5868                 :         532 :   char name[GFC_MAX_SYMBOL_LEN + 3];
    5869                 :         532 :   auto_vec<gfc_typespec, 5> tss;
    5870                 :         532 :   gfc_typespec ts;
    5871                 :         532 :   unsigned int i;
    5872                 :         532 :   gfc_symtree *st;
    5873                 :         532 :   locus where = gfc_current_locus;
    5874                 :         532 :   locus end_loc = gfc_current_locus;
    5875                 :         532 :   bool end_loc_set = false;
    5876                 :         532 :   gfc_omp_reduction_op rop = OMP_REDUCTION_NONE;
    5877                 :             : 
    5878                 :         532 :   if (gfc_match_char ('(') != MATCH_YES)
    5879                 :             :     return MATCH_ERROR;
    5880                 :             : 
    5881                 :         530 :   m = gfc_match (" %o : ", &op);
    5882                 :         530 :   if (m == MATCH_ERROR)
    5883                 :             :     return MATCH_ERROR;
    5884                 :         530 :   if (m == MATCH_YES)
    5885                 :             :     {
    5886                 :         117 :       snprintf (name, sizeof name, "operator %s", gfc_op2string (op));
    5887                 :         117 :       rop = (gfc_omp_reduction_op) op;
    5888                 :             :     }
    5889                 :             :   else
    5890                 :             :     {
    5891                 :         413 :       m = gfc_match_defined_op_name (name + 1, 1);
    5892                 :         413 :       if (m == MATCH_ERROR)
    5893                 :             :         return MATCH_ERROR;
    5894                 :         413 :       if (m == MATCH_YES)
    5895                 :             :         {
    5896                 :          41 :           name[0] = '.';
    5897                 :          41 :           strcat (name, ".");
    5898                 :          41 :           if (gfc_match (" : ") != MATCH_YES)
    5899                 :             :             return MATCH_ERROR;
    5900                 :             :         }
    5901                 :             :       else
    5902                 :             :         {
    5903                 :         372 :           if (gfc_match (" %n : ", name) != MATCH_YES)
    5904                 :             :             return MATCH_ERROR;
    5905                 :             :         }
    5906                 :             :       rop = OMP_REDUCTION_USER;
    5907                 :             :     }
    5908                 :             : 
    5909                 :         529 :   m = gfc_match_type_spec (&ts);
    5910                 :         529 :   if (m != MATCH_YES)
    5911                 :             :     return MATCH_ERROR;
    5912                 :             :   /* Treat len=: the same as len=*.  */
    5913                 :         528 :   if (ts.type == BT_CHARACTER)
    5914                 :          61 :     ts.deferred = false;
    5915                 :         528 :   tss.safe_push (ts);
    5916                 :             : 
    5917                 :        1093 :   while (gfc_match_char (',') == MATCH_YES)
    5918                 :             :     {
    5919                 :          37 :       m = gfc_match_type_spec (&ts);
    5920                 :          37 :       if (m != MATCH_YES)
    5921                 :             :         return MATCH_ERROR;
    5922                 :          37 :       tss.safe_push (ts);
    5923                 :             :     }
    5924                 :         528 :   if (gfc_match_char (':') != MATCH_YES)
    5925                 :             :     return MATCH_ERROR;
    5926                 :             : 
    5927                 :         527 :   st = gfc_find_symtree (gfc_current_ns->omp_udr_root, name);
    5928                 :        1084 :   for (i = 0; i < tss.length (); i++)
    5929                 :             :     {
    5930                 :         564 :       gfc_symtree *omp_out, *omp_in;
    5931                 :         564 :       gfc_symtree *omp_priv = NULL, *omp_orig = NULL;
    5932                 :         564 :       gfc_namespace *combiner_ns, *initializer_ns = NULL;
    5933                 :         564 :       gfc_omp_udr *prev_udr, *omp_udr;
    5934                 :         564 :       const char *predef_name = NULL;
    5935                 :             : 
    5936                 :         564 :       omp_udr = gfc_get_omp_udr ();
    5937                 :         564 :       omp_udr->name = gfc_get_string ("%s", name);
    5938                 :         564 :       omp_udr->rop = rop;
    5939                 :         564 :       omp_udr->ts = tss[i];
    5940                 :         564 :       omp_udr->where = where;
    5941                 :             : 
    5942                 :         564 :       gfc_current_ns = combiner_ns = gfc_get_namespace (gfc_current_ns, 1);
    5943                 :         564 :       combiner_ns->proc_name = combiner_ns->parent->proc_name;
    5944                 :             : 
    5945                 :         564 :       gfc_get_sym_tree ("omp_out", combiner_ns, &omp_out, false);
    5946                 :         564 :       gfc_get_sym_tree ("omp_in", combiner_ns, &omp_in, false);
    5947                 :         564 :       combiner_ns->omp_udr_ns = 1;
    5948                 :         564 :       omp_out->n.sym->ts = tss[i];
    5949                 :         564 :       omp_in->n.sym->ts = tss[i];
    5950                 :         564 :       omp_out->n.sym->attr.omp_udr_artificial_var = 1;
    5951                 :         564 :       omp_in->n.sym->attr.omp_udr_artificial_var = 1;
    5952                 :         564 :       omp_out->n.sym->attr.flavor = FL_VARIABLE;
    5953                 :         564 :       omp_in->n.sym->attr.flavor = FL_VARIABLE;
    5954                 :         564 :       gfc_commit_symbols ();
    5955                 :         564 :       omp_udr->combiner_ns = combiner_ns;
    5956                 :         564 :       omp_udr->omp_out = omp_out->n.sym;
    5957                 :         564 :       omp_udr->omp_in = omp_in->n.sym;
    5958                 :             : 
    5959                 :         564 :       locus old_loc = gfc_current_locus;
    5960                 :             : 
    5961                 :         564 :       if (!match_udr_expr (omp_out, omp_in))
    5962                 :             :         {
    5963                 :           4 :          syntax:
    5964                 :           7 :           gfc_current_locus = old_loc;
    5965                 :           7 :           gfc_current_ns = combiner_ns->parent;
    5966                 :           7 :           gfc_undo_symbols ();
    5967                 :           7 :           gfc_free_omp_udr (omp_udr);
    5968                 :           7 :           return MATCH_ERROR;
    5969                 :             :         }
    5970                 :             : 
    5971                 :         560 :       if (gfc_match (" initializer ( ") == MATCH_YES)
    5972                 :             :         {
    5973                 :         313 :           gfc_current_ns = combiner_ns->parent;
    5974                 :         313 :           initializer_ns = gfc_get_namespace (gfc_current_ns, 1);
    5975                 :         313 :           gfc_current_ns = initializer_ns;
    5976                 :         313 :           initializer_ns->proc_name = initializer_ns->parent->proc_name;
    5977                 :             : 
    5978                 :         313 :           gfc_get_sym_tree ("omp_priv", initializer_ns, &omp_priv, false);
    5979                 :         313 :           gfc_get_sym_tree ("omp_orig", initializer_ns, &omp_orig, false);
    5980                 :         313 :           initializer_ns->omp_udr_ns = 1;
    5981                 :         313 :           omp_priv->n.sym->ts = tss[i];
    5982                 :         313 :           omp_orig->n.sym->ts = tss[i];
    5983                 :         313 :           omp_priv->n.sym->attr.omp_udr_artificial_var = 1;
    5984                 :         313 :           omp_orig->n.sym->attr.omp_udr_artificial_var = 1;
    5985                 :         313 :           omp_priv->n.sym->attr.flavor = FL_VARIABLE;
    5986                 :         313 :           omp_orig->n.sym->attr.flavor = FL_VARIABLE;
    5987                 :         313 :           gfc_commit_symbols ();
    5988                 :         313 :           omp_udr->initializer_ns = initializer_ns;
    5989                 :         313 :           omp_udr->omp_priv = omp_priv->n.sym;
    5990                 :         313 :           omp_udr->omp_orig = omp_orig->n.sym;
    5991                 :             : 
    5992                 :         313 :           if (!match_udr_expr (omp_priv, omp_orig))
    5993                 :           3 :             goto syntax;
    5994                 :             :         }
    5995                 :             : 
    5996                 :         557 :       gfc_current_ns = combiner_ns->parent;
    5997                 :         557 :       if (!end_loc_set)
    5998                 :             :         {
    5999                 :         520 :           end_loc_set = true;
    6000                 :         520 :           end_loc = gfc_current_locus;
    6001                 :             :         }
    6002                 :         557 :       gfc_current_locus = old_loc;
    6003                 :             : 
    6004                 :         557 :       prev_udr = gfc_omp_udr_find (st, &tss[i]);
    6005                 :         557 :       if (gfc_omp_udr_predef (rop, name, &tss[i], &predef_name)
    6006                 :             :           /* Don't error on !$omp declare reduction (min : integer : ...)
    6007                 :             :              just yet, there could be integer :: min afterwards,
    6008                 :             :              making it valid.  When the UDR is resolved, we'll get
    6009                 :             :              to it again.  */
    6010                 :         557 :           && (rop != OMP_REDUCTION_USER || name[0] == '.'))
    6011                 :             :         {
    6012                 :          29 :           if (predef_name)
    6013                 :           0 :             gfc_error_now ("Redefinition of predefined %s "
    6014                 :             :                            "!$OMP DECLARE REDUCTION at %L",
    6015                 :             :                            predef_name, &where);
    6016                 :             :           else
    6017                 :          29 :             gfc_error_now ("Redefinition of predefined "
    6018                 :             :                            "!$OMP DECLARE REDUCTION at %L", &where);
    6019                 :             :         }
    6020                 :         528 :       else if (prev_udr)
    6021                 :             :         {
    6022                 :           6 :           gfc_error_now ("Redefinition of !$OMP DECLARE REDUCTION at %L",
    6023                 :             :                          &where);
    6024                 :           6 :           gfc_error_now ("Previous !$OMP DECLARE REDUCTION at %L",
    6025                 :             :                          &prev_udr->where);
    6026                 :             :         }
    6027                 :         522 :       else if (st)
    6028                 :             :         {
    6029                 :          96 :           omp_udr->next = st->n.omp_udr;
    6030                 :          96 :           st->n.omp_udr = omp_udr;
    6031                 :             :         }
    6032                 :             :       else
    6033                 :             :         {
    6034                 :         426 :           st = gfc_new_symtree (&gfc_current_ns->omp_udr_root, name);
    6035                 :         426 :           st->n.omp_udr = omp_udr;
    6036                 :             :         }
    6037                 :             :     }
    6038                 :             : 
    6039                 :         520 :   if (end_loc_set)
    6040                 :             :     {
    6041                 :         520 :       gfc_current_locus = end_loc;
    6042                 :         520 :       if (gfc_match_omp_eos () != MATCH_YES)
    6043                 :             :         {
    6044                 :           1 :           gfc_error ("Unexpected junk after !$OMP DECLARE REDUCTION at %C");
    6045                 :           1 :           gfc_current_locus = where;
    6046                 :           1 :           return MATCH_ERROR;
    6047                 :             :         }
    6048                 :             : 
    6049                 :             :       return MATCH_YES;
    6050                 :             :     }
    6051                 :           0 :   gfc_clear_error ();
    6052                 :           0 :   return MATCH_ERROR;
    6053                 :         532 : }
    6054                 :             : 
    6055                 :             : 
    6056                 :             : match
    6057                 :         440 : gfc_match_omp_declare_target (void)
    6058                 :             : {
    6059                 :         440 :   locus old_loc;
    6060                 :         440 :   match m;
    6061                 :         440 :   gfc_omp_clauses *c = NULL;
    6062                 :         440 :   int list;
    6063                 :         440 :   gfc_omp_namelist *n;
    6064                 :         440 :   gfc_symbol *s;
    6065                 :             : 
    6066                 :         440 :   old_loc = gfc_current_locus;
    6067                 :             : 
    6068                 :         440 :   if (gfc_current_ns->proc_name
    6069                 :         440 :       && gfc_match_omp_eos () == MATCH_YES)
    6070                 :             :     {
    6071                 :         138 :       if (!gfc_add_omp_declare_target (&gfc_current_ns->proc_name->attr,
    6072                 :         138 :                                        gfc_current_ns->proc_name->name,
    6073                 :             :                                        &old_loc))
    6074                 :           0 :         goto cleanup;
    6075                 :             :       return MATCH_YES;
    6076                 :             :     }
    6077                 :             : 
    6078                 :         302 :   if (gfc_current_ns->proc_name
    6079                 :         302 :       && gfc_current_ns->proc_name->attr.if_source == IFSRC_IFBODY)
    6080                 :             :     {
    6081                 :           2 :       gfc_error ("Only the !$OMP DECLARE TARGET form without "
    6082                 :             :                  "clauses is allowed in interface block at %C");
    6083                 :           2 :       goto cleanup;
    6084                 :             :     }
    6085                 :             : 
    6086                 :         300 :   m = gfc_match (" (");
    6087                 :         300 :   if (m == MATCH_YES)
    6088                 :             :     {
    6089                 :          80 :       c = gfc_get_omp_clauses ();
    6090                 :          80 :       gfc_current_locus = old_loc;
    6091                 :          80 :       m = gfc_match_omp_to_link (" (", &c->lists[OMP_LIST_ENTER]);
    6092                 :          80 :       if (m != MATCH_YES)
    6093                 :           0 :         goto syntax;
    6094                 :          80 :       if (gfc_match_omp_eos () != MATCH_YES)
    6095                 :             :         {
    6096                 :           0 :           gfc_error ("Unexpected junk after !$OMP DECLARE TARGET at %C");
    6097                 :           0 :           goto cleanup;
    6098                 :             :         }
    6099                 :             :     }
    6100                 :         220 :   else if (gfc_match_omp_clauses (&c, OMP_DECLARE_TARGET_CLAUSES) != MATCH_YES)
    6101                 :             :     return MATCH_ERROR;
    6102                 :             : 
    6103                 :         294 :   gfc_buffer_error (false);
    6104                 :             : 
    6105                 :         294 :   static const int to_enter_link_lists[]
    6106                 :             :     = { OMP_LIST_TO, OMP_LIST_ENTER, OMP_LIST_LINK };
    6107                 :        1176 :   for (size_t listn = 0; listn < ARRAY_SIZE (to_enter_link_lists)
    6108                 :        1176 :                          && (list = to_enter_link_lists[listn], true); ++listn)
    6109                 :        1383 :     for (n = c->lists[list]; n; n = n->next)
    6110                 :         501 :       if (n->sym)
    6111                 :         476 :         n->sym->mark = 0;
    6112                 :          25 :       else if (n->u.common->head)
    6113                 :          25 :         n->u.common->head->mark = 0;
    6114                 :             : 
    6115                 :         882 :   for (size_t listn = 0; listn < ARRAY_SIZE (to_enter_link_lists)
    6116                 :        1176 :                          && (list = to_enter_link_lists[listn], true); ++listn)
    6117                 :        1383 :     for (n = c->lists[list]; n; n = n->next)
    6118                 :         501 :       if (n->sym)
    6119                 :             :         {
    6120                 :         476 :           if (n->sym->attr.in_common)
    6121                 :           1 :             gfc_error_now ("OMP DECLARE TARGET variable at %L is an "
    6122                 :             :                            "element of a COMMON block", &n->where);
    6123                 :         475 :           else if (n->sym->mark)
    6124                 :           9 :             gfc_error_now ("Variable at %L mentioned multiple times in "
    6125                 :             :                            "clauses of the same OMP DECLARE TARGET directive",
    6126                 :             :                            &n->where);
    6127                 :         466 :           else if (n->sym->attr.omp_declare_target
    6128                 :         466 :                    && n->sym->attr.omp_declare_target_link
    6129                 :           9 :                    && list != OMP_LIST_LINK)
    6130                 :           1 :             gfc_error_now ("OMP DECLARE TARGET variable at %L previously "
    6131                 :             :                            "mentioned in LINK clause and later in %s clause",
    6132                 :             :                            &n->where, list == OMP_LIST_TO ? "TO" : "ENTER");
    6133                 :         465 :           else if (n->sym->attr.omp_declare_target
    6134                 :             :                    && !n->sym->attr.omp_declare_target_link
    6135                 :          14 :                    && list == OMP_LIST_LINK)
    6136                 :           1 :             gfc_error_now ("OMP DECLARE TARGET variable at %L previously "
    6137                 :             :                            "mentioned in TO or ENTER clause and later in "
    6138                 :             :                            "LINK clause", &n->where);
    6139                 :         464 :           else if (gfc_add_omp_declare_target (&n->sym->attr, n->sym->name,
    6140                 :             :                                                &n->sym->declared_at))
    6141                 :             :             {
    6142                 :         458 :               if (list == OMP_LIST_LINK)
    6143                 :          25 :                 gfc_add_omp_declare_target_link (&n->sym->attr, n->sym->name,
    6144                 :          25 :                                                  &n->sym->declared_at);
    6145                 :             :             }
    6146                 :         476 :           if (c->device_type != OMP_DEVICE_TYPE_UNSET)
    6147                 :             :             {
    6148                 :          43 :               if (n->sym->attr.omp_device_type != OMP_DEVICE_TYPE_UNSET
    6149                 :          17 :                   && n->sym->attr.omp_device_type != c->device_type)
    6150                 :          13 :                 gfc_error_now ("List item %qs at %L set in previous OMP DECLARE "
    6151                 :             :                                "TARGET directive to a different DEVICE_TYPE",
    6152                 :             :                                n->sym->name, &n->where);
    6153                 :          43 :               n->sym->attr.omp_device_type = c->device_type;
    6154                 :             :             }
    6155                 :         476 :           if (c->indirect)
    6156                 :             :             {
    6157                 :          50 :               if (n->sym->attr.omp_device_type != OMP_DEVICE_TYPE_UNSET
    6158                 :           1 :                   && n->sym->attr.omp_device_type != OMP_DEVICE_TYPE_ANY)
    6159                 :           1 :                 gfc_error_now ("DEVICE_TYPE must be ANY when used with "
    6160                 :             :                                "INDIRECT at %L", &n->where);
    6161                 :          50 :               n->sym->attr.omp_declare_target_indirect = c->indirect;
    6162                 :             :             }
    6163                 :             : 
    6164                 :         476 :           n->sym->mark = 1;
    6165                 :             :         }
    6166                 :          25 :       else if (n->u.common->omp_declare_target
    6167                 :          25 :                && n->u.common->omp_declare_target_link
    6168                 :           6 :                && list != OMP_LIST_LINK)
    6169                 :           2 :         gfc_error_now ("OMP DECLARE TARGET COMMON at %L previously "
    6170                 :             :                        "mentioned in LINK clause and later in %s clause",
    6171                 :             :                        &n->where, list == OMP_LIST_TO ? "TO" : "ENTER");
    6172                 :          24 :       else if (n->u.common->omp_declare_target
    6173                 :             :                && !n->u.common->omp_declare_target_link
    6174                 :           6 :                && list == OMP_LIST_LINK)
    6175                 :           1 :         gfc_error_now ("OMP DECLARE TARGET COMMON at %L previously "
    6176                 :             :                        "mentioned in TO or ENTER clause and later in "
    6177                 :             :                        "LINK clause", &n->where);
    6178                 :          23 :       else if (n->u.common->head && n->u.common->head->mark)
    6179                 :           4 :         gfc_error_now ("COMMON at %L mentioned multiple times in "
    6180                 :             :                        "clauses of the same OMP DECLARE TARGET directive",
    6181                 :             :                        &n->where);
    6182                 :             :       else
    6183                 :             :         {
    6184                 :          19 :           n->u.common->omp_declare_target = 1;
    6185                 :          19 :           n->u.common->omp_declare_target_link = (list == OMP_LIST_LINK);
    6186                 :          19 :           if (n->u.common->omp_device_type != OMP_DEVICE_TYPE_UNSET
    6187                 :           0 :               && n->u.common->omp_device_type != c->device_type)
    6188                 :           0 :             gfc_error_now ("COMMON at %L set in previous OMP DECLARE "
    6189                 :             :                            "TARGET directive to a different DEVICE_TYPE",
    6190                 :             :                            &n->where);
    6191                 :          19 :           n->u.common->omp_device_type = c->device_type;
    6192                 :             : 
    6193                 :          59 :           for (s = n->u.common->head; s; s = s->common_next)
    6194                 :             :             {
    6195                 :          40 :               s->mark = 1;
    6196                 :          40 :               if (gfc_add_omp_declare_target (&s->attr, s->name,
    6197                 :             :                                               &s->declared_at))
    6198                 :             :                 {
    6199                 :          40 :                   if (list == OMP_LIST_LINK)
    6200                 :          21 :                     gfc_add_omp_declare_target_link (&s->attr, s->name,
    6201                 :             :                                                      &s->declared_at);
    6202                 :             :                 }
    6203                 :          40 :               if (s->attr.omp_device_type != OMP_DEVICE_TYPE_UNSET
    6204                 :           0 :                   && s->attr.omp_device_type != c->device_type)
    6205                 :           0 :                 gfc_error_now ("List item %qs at %L set in previous OMP DECLARE"
    6206                 :             :                                " TARGET directive to a different DEVICE_TYPE",
    6207                 :             :                                s->name, &n->where);
    6208                 :          40 :               s->attr.omp_device_type = c->device_type;
    6209                 :             : 
    6210                 :          40 :               if (c->indirect
    6211                 :           0 :                   && s->attr.omp_device_type != OMP_DEVICE_TYPE_UNSET
    6212                 :           0 :                   && s->attr.omp_device_type != OMP_DEVICE_TYPE_ANY)
    6213                 :           0 :                 gfc_error_now ("DEVICE_TYPE must be ANY when used with "
    6214                 :             :                                "INDIRECT at %L", &n->where);
    6215                 :          40 :               s->attr.omp_declare_target_indirect = c->indirect;
    6216                 :             :             }
    6217                 :             :         }
    6218                 :         294 :   if ((c->device_type || c->indirect)
    6219                 :          99 :       && !c->lists[OMP_LIST_ENTER]
    6220                 :          87 :       && !c->lists[OMP_LIST_TO]
    6221                 :          19 :       && !c->lists[OMP_LIST_LINK])
    6222                 :           2 :     gfc_warning_now (OPT_Wopenmp,
    6223                 :             :                      "OMP DECLARE TARGET directive at %L with only "
    6224                 :             :                      "DEVICE_TYPE or INDIRECT clauses is ignored",
    6225                 :             :                      &old_loc);
    6226                 :             : 
    6227                 :         294 :   gfc_buffer_error (true);
    6228                 :             : 
    6229                 :         294 :   if (c)
    6230                 :         294 :     gfc_free_omp_clauses (c);
    6231                 :         294 :   return MATCH_YES;
    6232                 :             : 
    6233                 :           0 : syntax:
    6234                 :           0 :   gfc_error ("Syntax error in !$OMP DECLARE TARGET list at %C");
    6235                 :             : 
    6236                 :           2 : cleanup:
    6237                 :           2 :   gfc_current_locus = old_loc;
    6238                 :           2 :   if (c)
    6239                 :           0 :     gfc_free_omp_clauses (c);
    6240                 :             :   return MATCH_ERROR;
    6241                 :             : }
    6242                 :             : 
    6243                 :             : /* Skip over and ignore trait-property-extensions.
    6244                 :             : 
    6245                 :             :    trait-property-extension :
    6246                 :             :      trait-property-name
    6247                 :             :      identifier (trait-property-extension[, trait-property-extension[, ...]])
    6248                 :             :      constant integer expression
    6249                 :             :  */
    6250                 :             : 
    6251                 :             : static match gfc_ignore_trait_property_extension_list (void);
    6252                 :             : 
    6253                 :             : static match
    6254                 :           7 : gfc_ignore_trait_property_extension (void)
    6255                 :             : {
    6256                 :           7 :   char buf[GFC_MAX_SYMBOL_LEN + 1];
    6257                 :           7 :   gfc_expr *expr;
    6258                 :             : 
    6259                 :             :   /* Identifier form of trait-property name, possibly followed by
    6260                 :             :      a list of (recursive) trait-property-extensions.  */
    6261                 :           7 :   if (gfc_match_name (buf) == MATCH_YES)
    6262                 :             :     {
    6263                 :           0 :       if (gfc_match (" (") == MATCH_YES)
    6264                 :           0 :         return gfc_ignore_trait_property_extension_list ();
    6265                 :             :       return MATCH_YES;
    6266                 :             :     }
    6267                 :             : 
    6268                 :             :   /* Literal constant.  */
    6269                 :           7 :   if (gfc_match_literal_constant (&expr, 0) == MATCH_YES)
    6270                 :             :     return MATCH_YES;
    6271                 :             : 
    6272                 :             :   /* FIXME: constant integer expressions.  */
    6273                 :           0 :   gfc_error ("Expected trait-property-extension at %C");
    6274                 :           0 :   return MATCH_ERROR;
    6275                 :             : }
    6276                 :             : 
    6277                 :             : static match
    6278                 :           5 : gfc_ignore_trait_property_extension_list (void)
    6279                 :             : {
    6280                 :           9 :   while (1)
    6281                 :             :     {
    6282                 :           7 :       if (gfc_ignore_trait_property_extension () != MATCH_YES)
    6283                 :             :         return MATCH_ERROR;
    6284                 :           7 :       if (gfc_match (" ,") == MATCH_YES)
    6285                 :           2 :         continue;
    6286                 :           5 :       if (gfc_match (" )") == MATCH_YES)
    6287                 :             :         return MATCH_YES;
    6288                 :           0 :       gfc_error ("expected %<)%> at %C");
    6289                 :           0 :       return MATCH_ERROR;
    6290                 :             :     }
    6291                 :             : }
    6292                 :             : 
    6293                 :             : 
    6294                 :             : match
    6295                 :         110 : gfc_match_omp_interop (void)
    6296                 :             : {
    6297                 :         110 :   return match_omp (EXEC_OMP_INTEROP, OMP_INTEROP_CLAUSES);
    6298                 :             : }
    6299                 :             : 
    6300                 :             : 
    6301                 :             : /* OpenMP 5.0:
    6302                 :             : 
    6303                 :             :    trait-selector:
    6304                 :             :      trait-selector-name[([trait-score:]trait-property[,trait-property[,...]])]
    6305                 :             : 
    6306                 :             :    trait-score:
    6307                 :             :      score(score-expression)  */
    6308                 :             : 
    6309                 :             : match
    6310                 :         605 : gfc_match_omp_context_selector (gfc_omp_set_selector *oss,
    6311                 :             :                                 bool metadirective_p)
    6312                 :             : {
    6313                 :         743 :   do
    6314                 :             :     {
    6315                 :         743 :       char selector[GFC_MAX_SYMBOL_LEN + 1];
    6316                 :             : 
    6317                 :         743 :       if (gfc_match_name (selector) != MATCH_YES)
    6318                 :             :         {
    6319                 :           2 :           gfc_error ("expected trait selector name at %C");
    6320                 :          44 :           return MATCH_ERROR;
    6321                 :             :         }
    6322                 :             : 
    6323                 :         741 :       gfc_omp_selector *os = gfc_get_omp_selector ();
    6324                 :         741 :       if (oss->code == OMP_TRAIT_SET_CONSTRUCT
    6325                 :         331 :           && !strcmp (selector, "do"))
    6326                 :          46 :         os->code = OMP_TRAIT_CONSTRUCT_FOR;
    6327                 :         695 :       else if (oss->code == OMP_TRAIT_SET_CONSTRUCT
    6328                 :         285 :                && !strcmp (selector, "for"))
    6329                 :           1 :         os->code = OMP_TRAIT_INVALID;
    6330                 :             :       else
    6331                 :         694 :         os->code = omp_lookup_ts_code (oss->code, selector);
    6332                 :         741 :       os->next = oss->trait_selectors;
    6333                 :         741 :       oss->trait_selectors = os;
    6334                 :             : 
    6335                 :         741 :       if (os->code == OMP_TRAIT_INVALID)
    6336                 :             :         {
    6337                 :          18 :           gfc_warning (OPT_Wopenmp,
    6338                 :             :                        "unknown selector %qs for context selector set %qs "
    6339                 :             :                        "at %C",
    6340                 :          18 :                        selector, omp_tss_map[oss->code]);
    6341                 :          18 :           if (gfc_match (" (") == MATCH_YES
    6342                 :          18 :               && gfc_ignore_trait_property_extension_list () != MATCH_YES)
    6343                 :             :             return MATCH_ERROR;
    6344                 :          18 :           if (gfc_match (" ,") == MATCH_YES)
    6345                 :           1 :             continue;
    6346                 :         561 :           break;
    6347                 :             :         }
    6348                 :             : 
    6349                 :         723 :       enum omp_tp_type property_kind = omp_ts_map[os->code].tp_type;
    6350                 :         723 :       bool allow_score = omp_ts_map[os->code].allow_score;
    6351                 :             : 
    6352                 :         723 :       if (gfc_match (" (") == MATCH_YES)
    6353                 :             :         {
    6354                 :         403 :           if (property_kind == OMP_TRAIT_PROPERTY_NONE)
    6355                 :             :             {
    6356                 :           6 :               gfc_error ("selector %qs does not accept any properties at %C",
    6357                 :             :                          selector);
    6358                 :           6 :               return MATCH_ERROR;
    6359                 :             :             }
    6360                 :             : 
    6361                 :         397 :           if (gfc_match (" score") == MATCH_YES)
    6362                 :             :             {
    6363                 :          63 :               if (!allow_score)
    6364                 :             :                 {
    6365                 :          10 :                   gfc_error ("%<score%> cannot be specified in traits "
    6366                 :             :                              "in the %qs trait-selector-set at %C",
    6367                 :          10 :                              omp_tss_map[oss->code]);
    6368                 :          10 :                   return MATCH_ERROR;
    6369                 :             :                 }
    6370                 :          53 :               if (gfc_match (" (") != MATCH_YES)
    6371                 :             :                 {
    6372                 :           0 :                   gfc_error ("expected %<(%> at %C");
    6373                 :           0 :                   return MATCH_ERROR;
    6374                 :             :                 }
    6375                 :          53 :               if (gfc_match_expr (&os->score) != MATCH_YES
    6376                 :          52 :                   || !gfc_resolve_expr (os->score)
    6377                 :          52 :                   || os->score->ts.type != BT_INTEGER
    6378                 :         105 :                   || os->score->rank != 0)
    6379                 :             :                 {
    6380                 :           1 :                   gfc_error ("%<score%> argument must be constant integer "
    6381                 :             :                              "expression at %C");
    6382                 :           1 :                   return MATCH_ERROR;
    6383                 :             :                 }
    6384                 :             : 
    6385                 :          52 :               if (os->score->expr_type == EXPR_CONSTANT
    6386                 :          52 :                   && mpz_sgn (os->score->value.integer) < 0)
    6387                 :             :                 {
    6388                 :           1 :                   gfc_error ("%<score%> argument must be non-negative at %C");
    6389                 :           1 :                   return MATCH_ERROR;
    6390                 :             :                 }
    6391                 :             : 
    6392                 :          51 :               if (gfc_match (" )") != MATCH_YES)
    6393                 :             :                 {
    6394                 :           0 :                   gfc_error ("expected %<)%> at %C");
    6395                 :           0 :                   return MATCH_ERROR;
    6396                 :             :                 }
    6397                 :             : 
    6398                 :          51 :               if (gfc_match (" :") != MATCH_YES)
    6399                 :             :                 {
    6400                 :           0 :                   gfc_error ("expected : at %C");
    6401                 :           0 :                   return MATCH_ERROR;
    6402                 :             :                 }
    6403                 :             :             }
    6404                 :             : 
    6405                 :         385 :           gfc_omp_trait_property *otp = gfc_get_omp_trait_property ();
    6406                 :         385 :           otp->property_kind = property_kind;
    6407                 :         385 :           otp->next = os->properties;
    6408                 :         385 :           os->properties = otp;
    6409                 :             : 
    6410                 :         385 :           switch (property_kind)
    6411                 :             :             {
    6412                 :          25 :             case OMP_TRAIT_PROPERTY_ID:
    6413                 :          25 :               {
    6414                 :          25 :                 char buf[GFC_MAX_SYMBOL_LEN + 1];
    6415                 :          25 :                 if (gfc_match_name (buf) == MATCH_YES)
    6416                 :             :                   {
    6417                 :          24 :                     otp->name = XNEWVEC (char, strlen (buf) + 1);
    6418                 :          24 :                     strcpy (otp->name, buf);
    6419                 :             :                   }
    6420                 :             :                 else
    6421                 :             :                   {
    6422                 :           1 :                     gfc_error ("expected identifier at %C");
    6423                 :           1 :                     return MATCH_ERROR;
    6424                 :             :                   }
    6425                 :             :               }
    6426                 :          24 :               break;
    6427                 :         290 :             case OMP_TRAIT_PROPERTY_NAME_LIST:
    6428                 :         343 :               do
    6429                 :             :                 {
    6430                 :         290 :                   char buf[GFC_MAX_SYMBOL_LEN + 1];
    6431                 :         290 :                   if (gfc_match_name (buf) == MATCH_YES)
    6432                 :             :                     {
    6433                 :         170 :                       otp->name = XNEWVEC (char, strlen (buf) + 1);
    6434                 :         170 :                       strcpy (otp->name, buf);
    6435                 :         170 :                       otp->is_name = true;
    6436                 :             :                     }
    6437                 :         120 :                   else if (gfc_match_literal_constant (&otp->expr, 0)
    6438                 :             :                            != MATCH_YES
    6439                 :         120 :                            || otp->expr->ts.type != BT_CHARACTER)
    6440                 :             :                     {
    6441                 :           5 :                       gfc_error ("expected identifier or string literal "
    6442                 :             :                                  "at %C");
    6443                 :           5 :                       return MATCH_ERROR;
    6444                 :             :                     }
    6445                 :             : 
    6446                 :         285 :                   if (gfc_match (" ,") == MATCH_YES)
    6447                 :             :                     {
    6448                 :          53 :                       otp = gfc_get_omp_trait_property ();
    6449                 :          53 :                       otp->property_kind = property_kind;
    6450                 :          53 :                       otp->next = os->properties;
    6451                 :          53 :                       os->properties = otp;
    6452                 :             :                     }
    6453                 :             :                   else
    6454                 :             :                     break;
    6455                 :          53 :                 }
    6456                 :             :               while (1);
    6457                 :         232 :               break;
    6458                 :         108 :             case OMP_TRAIT_PROPERTY_DEV_NUM_EXPR:
    6459                 :         108 :             case OMP_TRAIT_PROPERTY_BOOL_EXPR:
    6460                 :         108 :               if (gfc_match_expr (&otp->expr) != MATCH_YES)
    6461                 :             :                 {
    6462                 :           3 :                   gfc_error ("expected expression at %C");
    6463                 :           3 :                   return MATCH_ERROR;
    6464                 :             :                 }
    6465                 :         105 :               if (!gfc_resolve_expr (otp->expr)
    6466                 :         104 :                   || (property_kind == OMP_TRAIT_PROPERTY_BOOL_EXPR
    6467                 :          87 :                       && otp->expr->ts.type != BT_LOGICAL)
    6468                 :         103 :                   || (property_kind == OMP_TRAIT_PROPERTY_DEV_NUM_EXPR
    6469                 :          17 :                       && otp->expr->ts.type != BT_INTEGER)
    6470                 :         103 :                   || otp->expr->rank != 0
    6471                 :         208 :                   || (!metadirective_p
    6472                 :          45 :                       && otp->expr->expr_type != EXPR_CONSTANT))
    6473                 :             :                 {
    6474                 :           3 :                   if (metadirective_p)
    6475                 :             :                     {
    6476                 :           0 :                       if (property_kind == OMP_TRAIT_PROPERTY_BOOL_EXPR)
    6477                 :           0 :                         gfc_error ("property must be a "
    6478                 :             :                                    "logical expression at %L",
    6479                 :           0 :                                    &otp->expr->where);
    6480                 :             :                       else
    6481                 :           0 :                         gfc_error ("property must be an "
    6482                 :             :                                    "integer expression at %L",
    6483                 :           0 :                                    &otp->expr->where);
    6484                 :             :                     }
    6485                 :             :                   else
    6486                 :             :                     {
    6487                 :           3 :                       if (property_kind == OMP_TRAIT_PROPERTY_BOOL_EXPR)
    6488                 :           2 :                         gfc_error ("property must be a constant "
    6489                 :             :                                    "logical expression at %L",
    6490                 :           2 :                                    &otp->expr->where);
    6491                 :             :                       else
    6492                 :           1 :                         gfc_error ("property must be a constant "
    6493                 :             :                                    "integer expression at %L",
    6494                 :           1 :                                    &otp->expr->where);
    6495                 :             :                     }
    6496                 :           3 :                   return MATCH_ERROR;
    6497                 :             :                 }
    6498                 :             :               /* Device number must be conforming, which includes
    6499                 :             :                  omp_initial_device (-1) and omp_invalid_device (-4).  */
    6500                 :         102 :               if (property_kind == OMP_TRAIT_PROPERTY_DEV_NUM_EXPR
    6501                 :          17 :                   && otp->expr->expr_type == EXPR_CONSTANT
    6502                 :           8 :                   && mpz_sgn (otp->expr->value.integer) < 0
    6503                 :           6 :                   && mpz_cmp_si (otp->expr->value.integer, -1) != 0
    6504                 :           2 :                   && mpz_cmp_si (otp->expr->value.integer, -4) != 0)
    6505                 :             :                 {
    6506                 :           1 :                   gfc_error ("property must be a conforming device number "
    6507                 :             :                              "at %C");
    6508                 :           1 :                   return MATCH_ERROR;
    6509                 :             :                 }
    6510                 :             :               break;
    6511                 :          15 :             case OMP_TRAIT_PROPERTY_CLAUSE_LIST:
    6512                 :          15 :               {
    6513                 :          15 :                 if (os->code == OMP_TRAIT_CONSTRUCT_SIMD)
    6514                 :             :                   {
    6515                 :          15 :                     gfc_matching_omp_context_selector = true;
    6516                 :          15 :                     if (gfc_match_omp_clauses (&otp->clauses,
    6517                 :          15 :                                                OMP_DECLARE_SIMD_CLAUSES,
    6518                 :             :                                                true, false, false)
    6519                 :             :                         != MATCH_YES)
    6520                 :             :                       {
    6521                 :           1 :                         gfc_matching_omp_context_selector = false;
    6522                 :           1 :                         gfc_error ("expected simd clause at %C");
    6523                 :           1 :                         return MATCH_ERROR;
    6524                 :             :                       }
    6525                 :          14 :                     gfc_matching_omp_context_selector = false;
    6526                 :             :                   }
    6527                 :           0 :                 else if (os->code == OMP_TRAIT_IMPLEMENTATION_REQUIRES)
    6528                 :             :                   {
    6529                 :             :                     /* FIXME: The "requires" selector was added in OpenMP 5.1.
    6530                 :             :                        Currently only the now-deprecated syntax
    6531                 :             :                        from OpenMP 5.0 is supported.
    6532                 :             :                        TODO: When implementing, update modules.cc as well.  */
    6533                 :           0 :                     sorry_at (gfc_get_location (&gfc_current_locus),
    6534                 :             :                               "%<requires%> selector is not supported yet");
    6535                 :           0 :                     return MATCH_ERROR;
    6536                 :             :                   }
    6537                 :             :                 else
    6538                 :           0 :                   gcc_unreachable ();
    6539                 :          14 :                 break;
    6540                 :             :               }
    6541                 :           0 :             default:
    6542                 :           0 :               gcc_unreachable ();
    6543                 :             :             }
    6544                 :             : 
    6545                 :         371 :           if (gfc_match (" )") != MATCH_YES)
    6546                 :             :             {
    6547                 :           2 :               gfc_error ("expected %<)%> at %C");
    6548                 :           2 :               return MATCH_ERROR;
    6549                 :             :             }
    6550                 :             :         }
    6551                 :         320 :       else if (property_kind != OMP_TRAIT_PROPERTY_NONE
    6552                 :         320 :                && property_kind != OMP_TRAIT_PROPERTY_CLAUSE_LIST
    6553                 :           8 :                && property_kind != OMP_TRAIT_PROPERTY_EXTENSION)
    6554                 :             :         {
    6555                 :           8 :           if (gfc_match (" (") != MATCH_YES)
    6556                 :             :             {
    6557                 :           8 :               gfc_error ("expected %<(%> at %C");
    6558                 :           8 :               return MATCH_ERROR;
    6559                 :             :             }
    6560                 :             :         }
    6561                 :             : 
    6562                 :         681 :       if (gfc_match (" ,") != MATCH_YES)
    6563                 :             :         break;
    6564                 :             :     }
    6565                 :             :   while (1);
    6566                 :             : 
    6567                 :         561 :   return MATCH_YES;
    6568                 :             : }
    6569                 :             : 
    6570                 :             : /* OpenMP 5.0:
    6571                 :             : 
    6572                 :             :    trait-set-selector[,trait-set-selector[,...]]
    6573                 :             : 
    6574                 :             :    trait-set-selector:
    6575                 :             :      trait-set-selector-name = { trait-selector[, trait-selector[, ...]] }
    6576                 :             : 
    6577                 :             :    trait-set-selector-name:
    6578                 :             :      constructor
    6579                 :             :      device
    6580                 :             :      implementation
    6581                 :             :      user  */
    6582                 :             : 
    6583                 :             : match
    6584                 :         547 : gfc_match_omp_context_selector_specification (gfc_omp_set_selector **oss_head,
    6585                 :             :                                               bool metadirective_p)
    6586                 :             : {
    6587                 :         679 :   do
    6588                 :             :     {
    6589                 :         613 :       match m;
    6590                 :         613 :       char buf[GFC_MAX_SYMBOL_LEN + 1];
    6591                 :         613 :       enum omp_tss_code set = OMP_TRAIT_SET_INVALID;
    6592                 :             : 
    6593                 :         613 :       m = gfc_match_name (buf);
    6594                 :         613 :       if (m == MATCH_YES)
    6595                 :         611 :         set = omp_lookup_tss_code (buf);
    6596                 :             : 
    6597                 :         611 :       if (set == OMP_TRAIT_SET_INVALID)
    6598                 :             :         {
    6599                 :           5 :           gfc_error ("expected context selector set name at %C");
    6600                 :          52 :           return MATCH_ERROR;
    6601                 :             :         }
    6602                 :             : 
    6603                 :         608 :       m = gfc_match (" =");
    6604                 :         608 :       if (m != MATCH_YES)
    6605                 :             :         {
    6606                 :           1 :           gfc_error ("expected %<=%> at %C");
    6607                 :           1 :           return MATCH_ERROR;
    6608                 :             :         }
    6609                 :             : 
    6610                 :         607 :       m = gfc_match (" {");
    6611                 :         607 :       if (m != MATCH_YES)
    6612                 :             :         {
    6613                 :           2 :           gfc_error ("expected %<{%> at %C");
    6614                 :           2 :           return MATCH_ERROR;
    6615                 :             :         }
    6616                 :             : 
    6617                 :         605 :       gfc_omp_set_selector *oss = gfc_get_omp_set_selector ();
    6618                 :         605 :       oss->next = *oss_head;
    6619                 :         605 :       oss->code = set;
    6620                 :         605 :       *oss_head = oss;
    6621                 :             : 
    6622                 :         605 :       if (gfc_match_omp_context_selector (oss, metadirective_p) != MATCH_YES)
    6623                 :             :         return MATCH_ERROR;
    6624                 :             : 
    6625                 :         561 :       m = gfc_match (" }");
    6626                 :         561 :       if (m != MATCH_YES)
    6627                 :             :         {
    6628                 :           0 :           gfc_error ("expected %<}%> at %C");
    6629                 :           0 :           return MATCH_ERROR;
    6630                 :             :         }
    6631                 :             : 
    6632                 :         561 :       m = gfc_match (" ,");
    6633                 :         561 :       if (m != MATCH_YES)
    6634                 :             :         break;
    6635                 :          66 :     }
    6636                 :             :   while (1);
    6637                 :             : 
    6638                 :         495 :   return MATCH_YES;
    6639                 :             : }
    6640                 :             : 
    6641                 :             : 
    6642                 :             : match
    6643                 :         415 : gfc_match_omp_declare_variant (void)
    6644                 :             : {
    6645                 :         415 :   char buf[GFC_MAX_SYMBOL_LEN + 1];
    6646                 :             : 
    6647                 :         415 :   if (gfc_match (" (") != MATCH_YES)
    6648                 :             :     {
    6649                 :           2 :       gfc_error ("expected %<(%> at %C");
    6650                 :           2 :       return MATCH_ERROR;
    6651                 :             :     }
    6652                 :             : 
    6653                 :         413 :   gfc_symtree *base_proc_st, *variant_proc_st;
    6654                 :         413 :   if (gfc_match_name (buf) != MATCH_YES)
    6655                 :             :     {
    6656                 :           2 :       gfc_error ("expected name at %C");
    6657                 :           2 :       return MATCH_ERROR;
    6658                 :             :     }
    6659                 :             : 
    6660                 :         411 :   if (gfc_get_ha_sym_tree (buf, &base_proc_st))
    6661                 :             :     return MATCH_ERROR;
    6662                 :             : 
    6663                 :         411 :   if (gfc_match (" :") == MATCH_YES)
    6664                 :             :     {
    6665                 :          15 :       if (gfc_match_name (buf) != MATCH_YES)
    6666                 :             :         {
    6667                 :           0 :           gfc_error ("expected variant name at %C");
    6668                 :           0 :           return MATCH_ERROR;
    6669                 :             :         }
    6670                 :             : 
    6671                 :          15 :       if (gfc_get_ha_sym_tree (buf, &variant_proc_st))
    6672                 :             :         return MATCH_ERROR;
    6673                 :             :     }
    6674                 :             :   else
    6675                 :             :     {
    6676                 :             :       /* Base procedure not specified.  */
    6677                 :         396 :       variant_proc_st = base_proc_st;
    6678                 :         396 :       base_proc_st = NULL;
    6679                 :             :     }
    6680                 :             : 
    6681                 :         411 :   gfc_omp_declare_variant *odv;
    6682                 :         411 :   odv = gfc_get_omp_declare_variant ();
    6683                 :         411 :   odv->where = gfc_current_locus;
    6684                 :         411 :   odv->variant_proc_symtree = variant_proc_st;
    6685                 :         411 :   odv->adjust_args_list = NULL;
    6686                 :         411 :   odv->base_proc_symtree = base_proc_st;
    6687                 :         411 :   odv->next = NULL;
    6688                 :         411 :   odv->error_p = false;
    6689                 :             : 
    6690                 :             :   /* Add the new declare variant to the end of the list.  */
    6691                 :         411 :   gfc_omp_declare_variant **prev_next = &gfc_current_ns->omp_declare_variant;
    6692                 :         551 :   while (*prev_next)
    6693                 :         140 :     prev_next = &((*prev_next)->next);
    6694                 :         411 :   *prev_next = odv;
    6695                 :             : 
    6696                 :         411 :   if (gfc_match (" )") != MATCH_YES)
    6697                 :             :     {
    6698                 :           0 :       gfc_error ("expected %<)%> at %C");
    6699                 :           0 :       return MATCH_ERROR;
    6700                 :             :     }
    6701                 :             : 
    6702                 :         411 :   bool has_match = false, has_adjust_args = false, has_append_args = false;
    6703                 :         411 :   bool error_p = false;
    6704                 :         411 :   locus adjust_args_loc;
    6705                 :         411 :   locus append_args_loc;
    6706                 :             : 
    6707                 :         411 :   gfc_gobble_whitespace ();
    6708                 :         411 :   gfc_match_char (',');
    6709                 :         629 :   for (;;)
    6710                 :             :     {
    6711                 :         520 :       gfc_gobble_whitespace ();
    6712                 :             : 
    6713                 :         520 :       enum clause
    6714                 :             :       {
    6715                 :             :         clause_match,
    6716                 :             :         clause_adjust_args,
    6717                 :             :         clause_append_args
    6718                 :             :       } ccode;
    6719                 :             : 
    6720                 :         520 :       if (gfc_match ("match") == MATCH_YES)
    6721                 :             :         ccode = clause_match;
    6722                 :         119 :       else if (gfc_match ("adjust_args") == MATCH_YES)
    6723                 :             :         {
    6724                 :          81 :           ccode = clause_adjust_args;
    6725                 :          81 :           adjust_args_loc = gfc_current_locus;
    6726                 :             :         }
    6727                 :          38 :       else if (gfc_match ("append_args") == MATCH_YES)
    6728                 :             :         {
    6729                 :          32 :           ccode = clause_append_args;
    6730                 :          32 :           append_args_loc = gfc_current_locus;
    6731                 :             :         }
    6732                 :             :       else
    6733                 :             :         {
    6734                 :             :           error_p = true;
    6735                 :             :           break;
    6736                 :             :         }
    6737                 :             : 
    6738                 :         514 :       if (gfc_match (" ( ") != MATCH_YES)
    6739                 :             :         {
    6740                 :           1 :           gfc_error ("expected %<(%> at %C");
    6741                 :           1 :           return MATCH_ERROR;
    6742                 :             :         }
    6743                 :             : 
    6744                 :         513 :       if (ccode == clause_match)
    6745                 :             :         {
    6746                 :         400 :           if (has_match)
    6747                 :             :             {
    6748                 :           1 :               gfc_error ("%qs clause at %L specified more than once",
    6749                 :             :                          "match", &gfc_current_locus);
    6750                 :           1 :               return MATCH_ERROR;
    6751                 :             :             }
    6752                 :         399 :           has_match = true;
    6753                 :         399 :           if (gfc_match_omp_context_selector_specification (&odv->set_selectors,
    6754                 :             :                                                             false)
    6755                 :             :               != MATCH_YES)
    6756                 :             :             return MATCH_ERROR;
    6757                 :         354 :           if (gfc_match (" )") != MATCH_YES)
    6758                 :             :             {
    6759                 :           0 :               gfc_error ("expected %<)%> at %C");
    6760                 :           0 :               return MATCH_ERROR;
    6761                 :             :             }
    6762                 :             :         }
    6763                 :         113 :       else if (ccode == clause_adjust_args)
    6764                 :             :         {
    6765                 :          81 :           has_adjust_args = true;
    6766                 :          81 :           bool need_device_ptr_p = false;
    6767                 :          81 :           bool need_device_addr_p = false;
    6768                 :          81 :           if (gfc_match ("nothing ") == MATCH_YES)
    6769                 :             :             ;
    6770                 :          58 :           else if (gfc_match ("need_device_ptr ") == MATCH_YES)
    6771                 :             :             need_device_ptr_p = true;
    6772                 :           9 :           else if (gfc_match ("need_device_addr ") == MATCH_YES)
    6773                 :             :             need_device_addr_p = true;
    6774                 :             :           else
    6775                 :             :             {
    6776                 :           2 :               gfc_error ("expected %<nothing%>, %<need_device_ptr%> or "
    6777                 :             :                          "%<need_device_addr%> at %C");
    6778                 :           2 :               return MATCH_ERROR;
    6779                 :             :             }
    6780                 :          79 :           if (gfc_match (": ") != MATCH_YES)
    6781                 :             :             {
    6782                 :           1 :               gfc_error ("expected %<:%> at %C");
    6783                 :           1 :               return MATCH_ERROR;
    6784                 :             :             }
    6785                 :             :           gfc_omp_namelist *tail = NULL;
    6786                 :             :           bool need_range = false, have_range = false;
    6787                 :         125 :           while (true)
    6788                 :             :             {
    6789                 :         125 :               gfc_omp_namelist *p = gfc_get_omp_namelist ();
    6790                 :         125 :               p->where = gfc_current_locus;
    6791                 :         125 :               p->u.adj_args.need_ptr = need_device_ptr_p;
    6792                 :         125 :               p->u.adj_args.need_addr = need_device_addr_p;
    6793                 :         125 :               if (tail)
    6794                 :             :                 {
    6795                 :          47 :                   tail->next = p;
    6796                 :          47 :                   tail = tail->next;
    6797                 :             :                 }
    6798                 :             :               else
    6799                 :             :                 {
    6800                 :          78 :                   gfc_omp_namelist **q = &odv->adjust_args_list;
    6801                 :          78 :                   if (*q)
    6802                 :             :                     {
    6803                 :          50 :                       for (; (*q)->next; q = &(*q)->next)
    6804                 :             :                         ;
    6805                 :          28 :                       (*q)->next = p;
    6806                 :             :                     }
    6807                 :             :                   else
    6808                 :          50 :                     *q = p;
    6809                 :             :                   tail = p;
    6810                 :             :                 }
    6811                 :         125 :               if (gfc_match (": ") == MATCH_YES)
    6812                 :             :                 {
    6813                 :           2 :                   if (have_range)
    6814                 :             :                     {
    6815                 :           0 :                       gfc_error ("unexpected %<:%> at %C");
    6816                 :           2 :                       return MATCH_ERROR;
    6817                 :             :                     }
    6818                 :           2 :                   p->u.adj_args.range_start = have_range = true;
    6819                 :           2 :                   need_range = false;
    6820                 :          49 :                   continue;
    6821                 :             :                 }
    6822                 :         123 :               if (have_range && gfc_match (", ") == MATCH_YES)
    6823                 :             :                 {
    6824                 :           1 :                  have_range = false;
    6825                 :           1 :                  continue;
    6826                 :             :                 }
    6827                 :         122 :               if (have_range && gfc_match (") ") == MATCH_YES)
    6828                 :             :                 break;
    6829                 :         121 :               locus saved_loc = gfc_current_locus;
    6830                 :             : 
    6831                 :             :               /* Without ranges, only arg names or integer literals permitted;
    6832                 :             :                  handle literals here as gfc_match_expr simplifies the expr.  */
    6833                 :         121 :               if (gfc_match_literal_constant (&p->expr, true) == MATCH_YES)
    6834                 :             :                 {
    6835                 :          17 :                   gfc_gobble_whitespace ();
    6836                 :          17 :                   char c = gfc_peek_ascii_char ();
    6837                 :          17 :                   if (c != ')' && c != ',' && c != ':')
    6838                 :             :                     {
    6839                 :           1 :                       gfc_free_expr (p->expr);
    6840                 :           1 :                       p->expr = NULL;
    6841                 :           1 :                       gfc_current_locus = saved_loc;
    6842                 :             :                     }
    6843                 :             :                 }
    6844                 :         121 :               if (!p->expr && gfc_match ("omp_num_args") == MATCH_YES)
    6845                 :             :                 {
    6846                 :           6 :                   if (!have_range)
    6847                 :           3 :                     p->u.adj_args.range_start = need_range = true;
    6848                 :             :                   else
    6849                 :             :                     need_range = false;
    6850                 :             : 
    6851                 :           6 :                   locus saved_loc2 = gfc_current_locus;
    6852                 :           6 :                   gfc_gobble_whitespace ();
    6853                 :           6 :                   char c = gfc_peek_ascii_char ();
    6854                 :           6 :                   if (c == '+' || c == '-')
    6855                 :             :                     {
    6856                 :           5 :                       if (gfc_match ("+ %e", &p->expr) == MATCH_YES)
    6857                 :           1 :                         p->u.adj_args.omp_num_args_plus = true;
    6858                 :           4 :                       else if (gfc_match ("- %e", &p->expr) == MATCH_YES)
    6859                 :           4 :                         p->u.adj_args.omp_num_args_minus = true;
    6860                 :           0 :                       else if (!gfc_error_check ())
    6861                 :             :                         {
    6862                 :           0 :                           gfc_error ("expected constant integer expression "
    6863                 :             :                                      "at %C");
    6864                 :           0 :                           p->u.adj_args.error_p = true;
    6865                 :           0 :                           return MATCH_ERROR;
    6866                 :             :                         }
    6867                 :           5 :                       p->where = gfc_get_location_range (&saved_loc, 1,
    6868                 :             :                                                          &saved_loc, 1,
    6869                 :             :                                                          &gfc_current_locus);
    6870                 :             :                     }
    6871                 :             :                   else
    6872                 :             :                     {
    6873                 :           1 :                       p->where = gfc_get_location_range (&saved_loc, 1,
    6874                 :             :                                                          &saved_loc, 1,
    6875                 :             :                                                          &saved_loc2);
    6876                 :           1 :                       p->u.adj_args.omp_num_args_plus = true;
    6877                 :             :                     }
    6878                 :             :                 }
    6879                 :         115 :               else if (!p->expr)
    6880                 :             :                 {
    6881                 :          99 :                   match m = gfc_match_expr (&p->expr);
    6882                 :          99 :                   if (m != MATCH_YES)
    6883                 :             :                     {
    6884                 :           1 :                       gfc_error ("expected dummy parameter name, "
    6885                 :             :                                  "%<omp_num_args%> or constant positive integer"
    6886                 :             :                                  " at %C");
    6887                 :           1 :                       p->u.adj_args.error_p = true;
    6888                 :           1 :                       return MATCH_ERROR;
    6889                 :             :                     }
    6890                 :          98 :                   if (p->expr->expr_type == EXPR_CONSTANT && !have_range)
    6891                 :          98 :                     need_range = true;  /* Constant expr but not literal.  */
    6892                 :          98 :                   p->where = p->expr->where;
    6893                 :             :                 }
    6894                 :             :               else
    6895                 :          16 :                 p->where = p->expr->where;
    6896                 :         120 :               gfc_gobble_whitespace ();
    6897                 :         120 :               match m = gfc_match (": ");
    6898                 :         120 :               if (need_range && m != MATCH_YES)
    6899                 :             :                 {
    6900                 :           1 :                   gfc_error ("expected %<:%> at %C");
    6901                 :           1 :                   return MATCH_ERROR;
    6902                 :             :                 }
    6903                 :         119 :               if (m == MATCH_YES)
    6904                 :             :                 {
    6905                 :           6 :                   p->u.adj_args.range_start = have_range = true;
    6906                 :           6 :                   need_range = false;
    6907                 :           6 :                   continue;
    6908                 :             :                 }
    6909                 :         113 :               need_range = have_range = false;
    6910                 :         113 :               if (gfc_match (", ") == MATCH_YES)
    6911                 :          38 :                 continue;
    6912                 :          75 :               if (gfc_match (") ") == MATCH_YES)
    6913                 :             :                 break;
    6914                 :             :             }
    6915                 :             :         }
    6916                 :          32 :       else if (ccode == clause_append_args)
    6917                 :             :         {
    6918                 :          32 :           if (has_append_args)
    6919                 :             :             {
    6920                 :           1 :               gfc_error ("%qs clause at %L specified more than once",
    6921                 :             :                          "append_args", &gfc_current_locus);
    6922                 :           1 :               return MATCH_ERROR;
    6923                 :             :             }
    6924                 :          56 :           has_append_args = true;
    6925                 :             :           gfc_omp_namelist *append_args_last = NULL;
    6926                 :          81 :           do
    6927                 :             :             {
    6928                 :          56 :               gfc_gobble_whitespace ();
    6929                 :          56 :               if (gfc_match ("interop ") != MATCH_YES)
    6930                 :             :                 {
    6931                 :           0 :                   gfc_error ("expected %<interop%> at %C");
    6932                 :           3 :                   return MATCH_ERROR;
    6933                 :             :                 }
    6934                 :          56 :               if (gfc_match ("( ") != MATCH_YES)
    6935                 :             :                 {
    6936                 :           0 :                   gfc_error ("expected %<(%> at %C");
    6937                 :           0 :                   return MATCH_ERROR;
    6938                 :             :                 }
    6939                 :             : 
    6940                 :          56 :               bool target, targetsync;
    6941                 :          56 :               char *type_str = NULL;
    6942                 :          56 :               int type_str_len;
    6943                 :          56 :               locus loc = gfc_current_locus;
    6944                 :          56 :               if (gfc_parser_omp_clause_init_modifiers (target, targetsync,
    6945                 :             :                                                         &type_str, type_str_len,
    6946                 :             :                                                         false) == MATCH_ERROR)
    6947                 :             :                 return MATCH_ERROR;
    6948                 :             : 
    6949                 :          54 :               gfc_omp_namelist *n = gfc_get_omp_namelist();
    6950                 :          54 :               n->where = loc;
    6951                 :          54 :               n->u.init.target = target;
    6952                 :          54 :               n->u.init.targetsync = targetsync;
    6953                 :          54 :               n->u.init.len = type_str_len;
    6954                 :          54 :               n->u2.init_interop = type_str;
    6955                 :          54 :               if (odv->append_args_list)
    6956                 :             :                 {
    6957                 :          25 :                   append_args_last->next = n;
    6958                 :          25 :                   append_args_last = n;
    6959                 :             :                 }
    6960                 :             :               else
    6961                 :          29 :                 append_args_last = odv->append_args_list = n;
    6962                 :             : 
    6963                 :          54 :               gfc_gobble_whitespace ();
    6964                 :          54 :               if (gfc_match_char (',') == MATCH_YES)
    6965                 :          25 :                 continue;
    6966                 :          29 :               if (gfc_match_char (')') == MATCH_YES)
    6967                 :             :                 break;
    6968                 :           1 :               gfc_error ("Expected %<,%> or %<)%> at %C");
    6969                 :           1 :               return MATCH_ERROR;
    6970                 :             :             }
    6971                 :             :           while (true);
    6972                 :             :         }
    6973                 :         458 :       gfc_gobble_whitespace ();
    6974                 :         458 :       if (gfc_match_omp_eos () == MATCH_YES)
    6975                 :             :         break;
    6976                 :         109 :       gfc_match_char (',');
    6977                 :         109 :     }
    6978                 :             : 
    6979                 :         355 :   if (error_p || (!has_match && !has_adjust_args && !has_append_args))
    6980                 :             :     {
    6981                 :           6 :       gfc_error ("expected %<match%>, %<adjust_args%> or %<append_args%> at %C");
    6982                 :           6 :       return MATCH_ERROR;
    6983                 :             :     }
    6984                 :             : 
    6985                 :         349 :   if ((has_adjust_args || has_append_args) && !has_match)
    6986                 :             :     {
    6987                 :           3 :       gfc_error ("the %qs clause at %L can only be specified if the "
    6988                 :             :                  "%<dispatch%> selector of the construct selector set appears "
    6989                 :             :                  "in the %<match%> clause",
    6990                 :             :                  has_adjust_args ? "adjust_args" : "append_args",
    6991                 :             :                  has_adjust_args ?  &adjust_args_loc : &append_args_loc);
    6992                 :           3 :       return MATCH_ERROR;
    6993                 :             :     }
    6994                 :             : 
    6995                 :             :   return MATCH_YES;
    6996                 :             : }
    6997                 :             : 
    6998                 :             : 
    6999                 :             : static match
    7000                 :         135 : match_omp_metadirective (bool begin_p)
    7001                 :             : {
    7002                 :         135 :   locus old_loc = gfc_current_locus;
    7003                 :         135 :   gfc_omp_variant *variants_head;
    7004                 :         135 :   gfc_omp_variant **next_variant = &variants_head;
    7005                 :         135 :   bool default_seen = false;
    7006                 :             : 
    7007                 :             :   /* Parse the context selectors.  */
    7008                 :         573 :   for (;;)
    7009                 :             :     {
    7010                 :         354 :       bool default_p = false;
    7011                 :         354 :       gfc_omp_set_selector *selectors = NULL;
    7012                 :             : 
    7013                 :         354 :       gfc_gobble_whitespace ();
    7014                 :         354 :       if (gfc_match_eos () == MATCH_YES)
    7015                 :             :         break;
    7016                 :         237 :       gfc_match_char (',');
    7017                 :         237 :       gfc_gobble_whitespace ();
    7018                 :             : 
    7019                 :         237 :       locus variant_locus = gfc_current_locus;
    7020                 :             : 
    7021                 :         237 :       if (gfc_match (" default ( ") == MATCH_YES)
    7022                 :             :         default_p = true;
    7023                 :         156 :       else if (gfc_match (" otherwise ( ") == MATCH_YES)
    7024                 :             :         default_p = true;
    7025                 :         150 :       else if (gfc_match (" when ( ") != MATCH_YES)
    7026                 :             :         {
    7027                 :           1 :           gfc_error ("expected %<when%>, %<otherwise%>, or %<default%> at %C");
    7028                 :           1 :           gfc_current_locus = old_loc;
    7029                 :          18 :           return MATCH_ERROR;
    7030                 :             :         }
    7031                 :             : 
    7032                 :          87 :       if (default_p && default_seen)
    7033                 :             :         {
    7034                 :           3 :           gfc_error ("too many %<otherwise%> or %<default%> clauses "
    7035                 :             :                      "in %<metadirective%> at %C");
    7036                 :           3 :           gfc_current_locus = old_loc;
    7037                 :           3 :           return MATCH_ERROR;
    7038                 :             :         }
    7039                 :         233 :       else if (default_seen)
    7040                 :             :         {
    7041                 :           1 :           gfc_error ("%<otherwise%> or %<default%> clause "
    7042                 :             :                      "must appear last in %<metadirective%> at %C");
    7043                 :           1 :           gfc_current_locus = old_loc;
    7044                 :           1 :           return MATCH_ERROR;
    7045                 :             :         }
    7046                 :             : 
    7047                 :         232 :       if (!default_p)
    7048                 :             :         {
    7049                 :         148 :           if (gfc_match_omp_context_selector_specification (&selectors, true)
    7050                 :             :               != MATCH_YES)
    7051                 :             :             return MATCH_ERROR;
    7052                 :             : 
    7053                 :         141 :           if (gfc_match (" : ") != MATCH_YES)
    7054                 :             :             {
    7055                 :           1 :               gfc_error ("expected %<:%> at %C");
    7056                 :           1 :               gfc_current_locus = old_loc;
    7057                 :           1 :               return MATCH_ERROR;
    7058                 :             :             }
    7059                 :             : 
    7060                 :         140 :           gfc_commit_symbols ();
    7061                 :             :         }
    7062                 :             : 
    7063                 :         224 :       gfc_matching_omp_context_selector = true;
    7064                 :         224 :       gfc_statement directive = match_omp_directive ();
    7065                 :         224 :       gfc_matching_omp_context_selector = false;
    7066                 :             : 
    7067                 :         224 :       if (is_omp_declarative_stmt (directive))
    7068                 :           0 :         sorry_at (gfc_get_location (&gfc_current_locus),
    7069                 :             :                   "declarative directive variants are not supported");
    7070                 :             : 
    7071                 :         224 :       if (gfc_error_flag_test ())
    7072                 :             :         {
    7073                 :           2 :           gfc_current_locus = old_loc;
    7074                 :           2 :           return MATCH_ERROR;
    7075                 :             :         }
    7076                 :             : 
    7077                 :         222 :       if (gfc_match (" )") != MATCH_YES)
    7078                 :             :         {
    7079                 :           0 :           gfc_error ("Expected %<)%> at %C");
    7080                 :           0 :           gfc_current_locus = old_loc;
    7081                 :           0 :           return MATCH_ERROR;
    7082                 :             :         }
    7083                 :             : 
    7084                 :         222 :       gfc_commit_symbols ();
    7085                 :             : 
    7086                 :         222 :       if (begin_p
    7087                 :         222 :           && directive != ST_NONE
    7088                 :         222 :           && gfc_omp_end_stmt (directive) == ST_NONE)
    7089                 :             :         {
    7090                 :           3 :           gfc_error ("variant directive used in OMP BEGIN METADIRECTIVE "
    7091                 :             :                      "at %C must have a corresponding end directive");
    7092                 :           3 :           gfc_current_locus = old_loc;
    7093                 :           3 :           return MATCH_ERROR;
    7094                 :             :         }
    7095                 :             : 
    7096                 :         219 :       if (default_p)
    7097                 :             :         default_seen = true;
    7098                 :             : 
    7099                 :         219 :       gfc_omp_variant *omv = gfc_get_omp_variant ();
    7100                 :         219 :       omv->selectors = selectors;
    7101                 :         219 :       omv->stmt = directive;
    7102                 :         219 :       omv->where = variant_locus;
    7103                 :             : 
    7104                 :         219 :       if (directive == ST_NONE)
    7105                 :             :         {
    7106                 :             :           /* The directive was a 'nothing' directive.  */
    7107                 :          15 :           omv->code = gfc_get_code (EXEC_CONTINUE);
    7108                 :          15 :           omv->code->ext.omp_clauses = NULL;
    7109                 :             :         }
    7110                 :             :       else
    7111                 :             :         {
    7112                 :         204 :           omv->code = gfc_get_code (new_st.op);
    7113                 :         204 :           omv->code->ext.omp_clauses = new_st.ext.omp_clauses;
    7114                 :             :           /* Prevent the OpenMP clauses from being freed via NEW_ST.  */
    7115                 :         204 :           new_st.ext.omp_clauses = NULL;
    7116                 :             :         }
    7117                 :             : 
    7118                 :         219 :       *next_variant = omv;
    7119                 :         219 :       next_variant = &omv->next;
    7120                 :         219 :     }
    7121                 :             : 
    7122                 :         117 :   if (gfc_match_omp_eos () != MATCH_YES)
    7123                 :             :     {
    7124                 :           0 :       gfc_error ("Unexpected junk after OMP METADIRECTIVE at %C");
    7125                 :           0 :       gfc_current_locus = old_loc;
    7126                 :           0 :       return MATCH_ERROR;
    7127                 :             :     }
    7128                 :             : 
    7129                 :             :   /* Add a 'default (nothing)' clause if no default is explicitly given.  */
    7130                 :         117 :   if (!default_seen)
    7131                 :             :     {
    7132                 :          42 :       gfc_omp_variant *omv = gfc_get_omp_variant ();
    7133                 :          42 :       omv->stmt = ST_NONE;
    7134                 :          42 :       omv->code = gfc_get_code (EXEC_CONTINUE);
    7135                 :          42 :       omv->code->ext.omp_clauses = NULL;
    7136                 :          42 :       omv->where = old_loc;
    7137                 :          42 :       omv->selectors = NULL;
    7138                 :             : 
    7139                 :          42 :       *next_variant = omv;
    7140                 :          42 :       next_variant = &omv->next;
    7141                 :             :     }
    7142                 :             : 
    7143                 :         117 :   new_st.op = EXEC_OMP_METADIRECTIVE;
    7144                 :         117 :   new_st.ext.omp_variants = variants_head;
    7145                 :             : 
    7146                 :         117 :   return MATCH_YES;
    7147                 :             : }
    7148                 :             : 
    7149                 :             : match
    7150                 :          31 : gfc_match_omp_begin_metadirective (void)
    7151                 :             : {
    7152                 :          31 :   return match_omp_metadirective (true);
    7153                 :             : }
    7154                 :             : 
    7155                 :             : match
    7156                 :         104 : gfc_match_omp_metadirective (void)
    7157                 :             : {
    7158                 :         104 :   return match_omp_metadirective (false);
    7159                 :             : }
    7160                 :             : 
    7161                 :             : match
    7162                 :         204 : gfc_match_omp_threadprivate (void)
    7163                 :             : {
    7164                 :         204 :   locus old_loc;
    7165                 :         204 :   char n[GFC_MAX_SYMBOL_LEN+1];
    7166                 :         204 :   gfc_symbol *sym;
    7167                 :         204 :   match m;
    7168                 :         204 :   gfc_symtree *st;
    7169                 :             : 
    7170                 :         204 :   old_loc = gfc_current_locus;
    7171                 :             : 
    7172                 :         204 :   m = gfc_match (" (");
    7173                 :         204 :   if (m != MATCH_YES)
    7174                 :             :     return m;
    7175                 :             : 
    7176                 :         246 :   for (;;)
    7177                 :             :     {
    7178                 :         246 :       m = gfc_match_symbol (&sym, 0);
    7179                 :         246 :       switch (m)
    7180                 :             :         {
    7181                 :         175 :         case MATCH_YES:
    7182                 :         175 :           if (sym->attr.in_common)
    7183                 :           0 :             gfc_error_now ("Threadprivate variable at %C is an element of "
    7184                 :             :                            "a COMMON block");
    7185                 :         175 :           else if (!gfc_add_threadprivate (&sym->attr, sym->name, &sym->declared_at))
    7186                 :           1 :             goto cleanup;
    7187                 :         174 :           goto next_item;
    7188                 :             :         case MATCH_NO:
    7189                 :             :           break;
    7190                 :           0 :         case MATCH_ERROR:
    7191                 :           0 :           goto cleanup;
    7192                 :             :         }
    7193                 :             : 
    7194                 :          71 :       m = gfc_match (" / %n /", n);
    7195                 :          71 :       if (m == MATCH_ERROR)
    7196                 :           0 :         goto cleanup;
    7197                 :          71 :       if (m == MATCH_NO || n[0] == '\0')
    7198                 :           0 :         goto syntax;
    7199                 :             : 
    7200                 :          71 :       st = gfc_find_symtree (gfc_current_ns->common_root, n);
    7201                 :          71 :       if (st == NULL)
    7202                 :             :         {
    7203                 :           2 :           gfc_error ("COMMON block /%s/ not found at %C", n);
    7204                 :           2 :           goto cleanup;
    7205                 :             :         }
    7206                 :          69 :       st->n.common->threadprivate = 1;
    7207                 :         176 :       for (sym = st->n.common->head; sym; sym = sym->common_next)
    7208                 :         107 :         if (!gfc_add_threadprivate (&sym->attr, sym->name, &sym->declared_at))
    7209                 :           0 :           goto cleanup;
    7210                 :             : 
    7211                 :          69 :     next_item:
    7212                 :         243 :       if (gfc_match_char (')') == MATCH_YES)
    7213                 :             :         break;
    7214                 :          42 :       if (gfc_match_char (',') != MATCH_YES)
    7215                 :           0 :         goto syntax;
    7216                 :             :     }
    7217                 :             : 
    7218                 :         201 :   if (gfc_match_omp_eos () != MATCH_YES)
    7219                 :             :     {
    7220                 :           0 :       gfc_error ("Unexpected junk after OMP THREADPRIVATE at %C");
    7221                 :           0 :       goto cleanup;
    7222                 :             :     }
    7223                 :             : 
    7224                 :             :   return MATCH_YES;
    7225                 :             : 
    7226                 :           0 : syntax:
    7227                 :           0 :   gfc_error ("Syntax error in !$OMP THREADPRIVATE list at %C");
    7228                 :             : 
    7229                 :           3 : cleanup:
    7230                 :           3 :   gfc_current_locus = old_loc;
    7231                 :           3 :   return MATCH_ERROR;
    7232                 :             : }
    7233                 :             : 
    7234                 :             : 
    7235                 :             : match
    7236                 :        2124 : gfc_match_omp_parallel (void)
    7237                 :             : {
    7238                 :        2124 :   return match_omp (EXEC_OMP_PARALLEL, OMP_PARALLEL_CLAUSES);
    7239                 :             : }
    7240                 :             : 
    7241                 :             : 
    7242                 :             : match
    7243                 :        1186 : gfc_match_omp_parallel_do (void)
    7244                 :             : {
    7245                 :        1186 :   return match_omp (EXEC_OMP_PARALLEL_DO,
    7246                 :        1186 :                     (OMP_PARALLEL_CLAUSES | OMP_DO_CLAUSES)
    7247                 :        1186 :                     & ~(omp_mask (OMP_CLAUSE_NOWAIT)));
    7248                 :             : }
    7249                 :             : 
    7250                 :             : 
    7251                 :             : match
    7252                 :         298 : gfc_match_omp_parallel_do_simd (void)
    7253                 :             : {
    7254                 :         298 :   return match_omp (EXEC_OMP_PARALLEL_DO_SIMD,
    7255                 :         298 :                     (OMP_PARALLEL_CLAUSES | OMP_DO_CLAUSES | OMP_SIMD_CLAUSES)
    7256                 :         298 :                     & ~(omp_mask (OMP_CLAUSE_NOWAIT)));
    7257                 :             : }
    7258                 :             : 
    7259                 :             : 
    7260                 :             : match
    7261                 :          14 : gfc_match_omp_parallel_masked (void)
    7262                 :             : {
    7263                 :          14 :   return match_omp (EXEC_OMP_PARALLEL_MASKED,
    7264                 :          14 :                     OMP_PARALLEL_CLAUSES | OMP_MASKED_CLAUSES);
    7265                 :             : }
    7266                 :             : 
    7267                 :             : match
    7268                 :          10 : gfc_match_omp_parallel_masked_taskloop (void)
    7269                 :             : {
    7270                 :          10 :   return match_omp (EXEC_OMP_PARALLEL_MASKED_TASKLOOP,
    7271                 :          10 :                     (OMP_PARALLEL_CLAUSES | OMP_MASKED_CLAUSES
    7272                 :          10 :                      | OMP_TASKLOOP_CLAUSES)
    7273                 :          10 :                     & ~(omp_mask (OMP_CLAUSE_IN_REDUCTION)));
    7274                 :             : }
    7275                 :             : 
    7276                 :             : match
    7277                 :          13 : gfc_match_omp_parallel_masked_taskloop_simd (void)
    7278                 :             : {
    7279                 :          13 :   return match_omp (EXEC_OMP_PARALLEL_MASKED_TASKLOOP_SIMD,
    7280                 :          13 :                     (OMP_PARALLEL_CLAUSES | OMP_MASKED_CLAUSES
    7281                 :          13 :                      | OMP_TASKLOOP_CLAUSES | OMP_SIMD_CLAUSES)
    7282                 :          13 :                     & ~(omp_mask (OMP_CLAUSE_IN_REDUCTION)));
    7283                 :             : }
    7284                 :             : 
    7285                 :             : match
    7286                 :          14 : gfc_match_omp_parallel_master (void)
    7287                 :             : {
    7288                 :          14 :   return match_omp (EXEC_OMP_PARALLEL_MASTER, OMP_PARALLEL_CLAUSES);
    7289                 :             : }
    7290                 :             : 
    7291                 :             : match
    7292                 :          15 : gfc_match_omp_parallel_master_taskloop (void)
    7293                 :             : {
    7294                 :          15 :   return match_omp (EXEC_OMP_PARALLEL_MASTER_TASKLOOP,
    7295                 :          15 :                     (OMP_PARALLEL_CLAUSES | OMP_TASKLOOP_CLAUSES)
    7296                 :          15 :                     & ~(omp_mask (OMP_CLAUSE_IN_REDUCTION)));
    7297                 :             : }
    7298                 :             : 
    7299                 :             : match
    7300                 :          21 : gfc_match_omp_parallel_master_taskloop_simd (void)
    7301                 :             : {
    7302                 :          21 :   return match_omp (EXEC_OMP_PARALLEL_MASTER_TASKLOOP_SIMD,
    7303                 :          21 :                     (OMP_PARALLEL_CLAUSES | OMP_TASKLOOP_CLAUSES
    7304                 :          21 :                      | OMP_SIMD_CLAUSES)
    7305                 :          21 :                     & ~(omp_mask (OMP_CLAUSE_IN_REDUCTION)));
    7306                 :             : }
    7307                 :             : 
    7308                 :             : match
    7309                 :          59 : gfc_match_omp_parallel_sections (void)
    7310                 :             : {
    7311                 :          59 :   return match_omp (EXEC_OMP_PARALLEL_SECTIONS,
    7312                 :          59 :                     (OMP_PARALLEL_CLAUSES | OMP_SECTIONS_CLAUSES)
    7313                 :          59 :                     & ~(omp_mask (OMP_CLAUSE_NOWAIT)));
    7314                 :             : }
    7315                 :             : 
    7316                 :             : 
    7317                 :             : match
    7318                 :          56 : gfc_match_omp_parallel_workshare (void)
    7319                 :             : {
    7320                 :          56 :   return match_omp (EXEC_OMP_PARALLEL_WORKSHARE, OMP_PARALLEL_CLAUSES);
    7321                 :             : }
    7322                 :             : 
    7323                 :             : void
    7324                 :       47156 : gfc_check_omp_requires (gfc_namespace *ns, int ref_omp_requires)
    7325                 :             : {
    7326                 :       47156 :   const char *msg = G_("Program unit at %L has OpenMP device "
    7327                 :             :                        "constructs/routines but does not set !$OMP REQUIRES %s "
    7328                 :             :                        "but other program units do");
    7329                 :       47156 :   if (ns->omp_target_seen
    7330                 :        1110 :       && (ns->omp_requires & OMP_REQ_TARGET_MASK)
    7331                 :        1110 :          != (ref_omp_requires & OMP_REQ_TARGET_MASK))
    7332                 :             :     {
    7333                 :           6 :       gcc_assert (ns->proc_name);
    7334                 :           6 :       if ((ref_omp_requires & OMP_REQ_REVERSE_OFFLOAD)
    7335                 :           5 :           && !(ns->omp_requires & OMP_REQ_REVERSE_OFFLOAD))
    7336                 :           4 :         gfc_error (msg, &ns->proc_name->declared_at, "REVERSE_OFFLOAD");
    7337                 :           6 :       if ((ref_omp_requires & OMP_REQ_UNIFIED_ADDRESS)
    7338                 :           1 :           && !(ns->omp_requires & OMP_REQ_UNIFIED_ADDRESS))
    7339                 :           1 :         gfc_error (msg, &ns->proc_name->declared_at, "UNIFIED_ADDRESS");
    7340                 :           6 :       if ((ref_omp_requires & OMP_REQ_UNIFIED_SHARED_MEMORY)
    7341                 :           4 :           && !(ns->omp_requires & OMP_REQ_UNIFIED_SHARED_MEMORY))
    7342                 :           2 :         gfc_error (msg, &ns->proc_name->declared_at, "UNIFIED_SHARED_MEMORY");
    7343                 :           6 :       if ((ref_omp_requires & OMP_REQ_SELF_MAPS)
    7344                 :           1 :           && !(ns->omp_requires & OMP_REQ_UNIFIED_SHARED_MEMORY))
    7345                 :           1 :         gfc_error (msg, &ns->proc_name->declared_at, "SELF_MAPS");
    7346                 :             :     }
    7347                 :       47156 : }
    7348                 :             : 
    7349                 :             : bool
    7350                 :         122 : gfc_omp_requires_add_clause (gfc_omp_requires_kind clause,
    7351                 :             :                              const char *clause_name, locus *loc,
    7352                 :             :                              const char *module_name)
    7353                 :             : {
    7354                 :         122 :   gfc_namespace *prog_unit = gfc_current_ns;
    7355                 :         146 :   while (prog_unit->parent)
    7356                 :             :     {
    7357                 :          25 :       if (gfc_state_stack->previous
    7358                 :          25 :           && gfc_state_stack->previous->state == COMP_INTERFACE)
    7359                 :             :         break;
    7360                 :             :       prog_unit = prog_unit->parent;
    7361                 :             :     }
    7362                 :             : 
    7363                 :             :   /* Requires added after use.  */
    7364                 :         122 :   if (prog_unit->omp_target_seen
    7365                 :          24 :       && (clause & OMP_REQ_TARGET_MASK)
    7366                 :          24 :       && !(prog_unit->omp_requires & clause))
    7367                 :             :     {
    7368                 :           0 :       if (module_name)
    7369                 :           0 :         gfc_error ("!$OMP REQUIRES clause %qs specified via module %qs use "
    7370                 :             :                    "at %L comes after using a device construct/routine",
    7371                 :             :                    clause_name, module_name, loc);
    7372                 :             :       else
    7373                 :           0 :         gfc_error ("!$OMP REQUIRES clause %qs specified at %L comes after "
    7374                 :             :                    "using a device construct/routine", clause_name, loc);
    7375                 :           0 :       return false;
    7376                 :             :     }
    7377                 :             : 
    7378                 :             :   /* Overriding atomic_default_mem_order clause value.  */
    7379                 :         122 :   if ((clause & OMP_REQ_ATOMIC_MEM_ORDER_MASK)
    7380                 :          34 :       && (prog_unit->omp_requires & OMP_REQ_ATOMIC_MEM_ORDER_MASK)
    7381                 :           6 :       && (prog_unit->omp_requires & OMP_REQ_ATOMIC_MEM_ORDER_MASK)
    7382                 :           6 :          != (int) clause)
    7383                 :             :     {
    7384                 :           3 :       const char *other;
    7385                 :           3 :       switch (prog_unit->omp_requires & OMP_REQ_ATOMIC_MEM_ORDER_MASK)
    7386                 :             :         {
    7387                 :             :         case OMP_REQ_ATOMIC_MEM_ORDER_SEQ_CST: other = "seq_cst"; break;
    7388                 :           0 :         case OMP_REQ_ATOMIC_MEM_ORDER_ACQ_REL: other = "acq_rel"; break;
    7389                 :           1 :         case OMP_REQ_ATOMIC_MEM_ORDER_ACQUIRE: other = "acquire"; break;
    7390                 :           1 :         case OMP_REQ_ATOMIC_MEM_ORDER_RELAXED: other = "relaxed"; break;
    7391                 :           0 :         case OMP_REQ_ATOMIC_MEM_ORDER_RELEASE: other = "release"; break;
    7392                 :           0 :         default: gcc_unreachable ();
    7393                 :             :         }
    7394                 :             : 
    7395                 :           3 :       if (module_name)
    7396                 :           0 :         gfc_error ("!$OMP REQUIRES clause %<atomic_default_mem_order(%s)%> "
    7397                 :             :                    "specified via module %qs use at %L overrides a previous "
    7398                 :             :                    "%<atomic_default_mem_order(%s)%> (which might be through "
    7399                 :             :                    "using a module)", clause_name, module_name, loc, other);
    7400                 :             :       else
    7401                 :           3 :         gfc_error ("!$OMP REQUIRES clause %<atomic_default_mem_order(%s)%> "
    7402                 :             :                    "specified at %L overrides a previous "
    7403                 :             :                    "%<atomic_default_mem_order(%s)%> (which might be through "
    7404                 :             :                    "using a module)", clause_name, loc, other);
    7405                 :           3 :       return false;
    7406                 :             :     }
    7407                 :             : 
    7408                 :             :   /* Requires via module not at program-unit level and not repeating clause.  */
    7409                 :         119 :   if (prog_unit != gfc_current_ns && !(prog_unit->omp_requires & clause))
    7410                 :             :     {
    7411                 :           0 :       if (clause & OMP_REQ_ATOMIC_MEM_ORDER_MASK)
    7412                 :           0 :         gfc_error ("!$OMP REQUIRES clause %<atomic_default_mem_order(%s)%> "
    7413                 :             :                    "specified via module %qs use at %L but same clause is "
    7414                 :             :                    "not specified for the program unit", clause_name,
    7415                 :             :                    module_name, loc);
    7416                 :             :       else
    7417                 :           0 :         gfc_error ("!$OMP REQUIRES clause %qs specified via module %qs use at "
    7418                 :             :                    "%L but same clause is not specified for the program unit",
    7419                 :             :                    clause_name, module_name, loc);
    7420                 :           0 :       return false;
    7421                 :             :     }
    7422                 :             : 
    7423                 :         119 :   if (!gfc_state_stack->previous
    7424                 :         111 :       || gfc_state_stack->previous->state != COMP_INTERFACE)
    7425                 :         118 :     prog_unit->omp_requires |= clause;
    7426                 :             :   return true;
    7427                 :             : }
    7428                 :             : 
    7429                 :             : match
    7430                 :          93 : gfc_match_omp_requires (void)
    7431                 :             : {
    7432                 :          93 :   static const char *clauses[] = {"reverse_offload",
    7433                 :             :                                   "unified_address",
    7434                 :             :                                   "unified_shared_memory",
    7435                 :             :                                   "self_maps",
    7436                 :             :                                   "dynamic_allocators",
    7437                 :             :                                   "atomic_default"};
    7438                 :          93 :   const char *clause = NULL;
    7439                 :          93 :   int requires_clauses = 0;
    7440                 :          93 :   bool first = true;
    7441                 :          93 :   locus old_loc;
    7442                 :             : 
    7443                 :          93 :   if (gfc_current_ns->parent
    7444                 :           7 :       && (!gfc_state_stack->previous
    7445                 :           7 :           || gfc_state_stack->previous->state != COMP_INTERFACE))
    7446                 :             :     {
    7447                 :           6 :       gfc_error ("!$OMP REQUIRES at %C must appear in the specification part "
    7448                 :             :                  "of a program unit");
    7449                 :           6 :       return MATCH_ERROR;
    7450                 :             :     }
    7451                 :             : 
    7452                 :         261 :   while (true)
    7453                 :             :     {
    7454                 :         174 :       old_loc = gfc_current_locus;
    7455                 :         174 :       gfc_omp_requires_kind requires_clause;
    7456                 :          87 :       if ((first || gfc_match_char (',') != MATCH_YES)
    7457                 :         174 :           && (first && gfc_match_space () != MATCH_YES))
    7458                 :           0 :         goto error;
    7459                 :         174 :       first = false;
    7460                 :         174 :       gfc_gobble_whitespace ();
    7461                 :         174 :       old_loc = gfc_current_locus;
    7462                 :             : 
    7463                 :         174 :       if (gfc_match_omp_eos () != MATCH_NO)
    7464                 :             :         break;
    7465                 :          98 :       if (gfc_match (clauses[0]) == MATCH_YES)
    7466                 :             :         {
    7467                 :          34 :           clause = clauses[0];
    7468                 :          34 :           requires_clause = OMP_REQ_REVERSE_OFFLOAD;
    7469                 :          34 :           if (requires_clauses & OMP_REQ_REVERSE_OFFLOAD)
    7470                 :           1 :             goto duplicate_clause;
    7471                 :             :         }
    7472                 :          64 :       else if (gfc_match (clauses[1]) == MATCH_YES)
    7473                 :             :         {
    7474                 :           9 :           clause = clauses[1];
    7475                 :           9 :           requires_clause = OMP_REQ_UNIFIED_ADDRESS;
    7476                 :           9 :           if (requires_clauses & OMP_REQ_UNIFIED_ADDRESS)
    7477                 :           1 :             goto duplicate_clause;
    7478                 :             :         }
    7479                 :          55 :       else if (gfc_match (clauses[2]) == MATCH_YES)
    7480                 :             :         {
    7481                 :          14 :           clause = clauses[2];
    7482                 :          14 :           requires_clause = OMP_REQ_UNIFIED_SHARED_MEMORY;
    7483                 :          14 :           if (requires_clauses & OMP_REQ_UNIFIED_SHARED_MEMORY)
    7484                 :           1 :             goto duplicate_clause;
    7485                 :             :         }
    7486                 :          41 :       else if (gfc_match (clauses[3]) == MATCH_YES)
    7487                 :             :         {
    7488                 :           2 :           clause = clauses[3];
    7489                 :           2 :           requires_clause = OMP_REQ_SELF_MAPS;
    7490                 :           2 :           if (requires_clauses & OMP_REQ_SELF_MAPS)
    7491                 :           0 :             goto duplicate_clause;
    7492                 :             :         }
    7493                 :          39 :       else if (gfc_match (clauses[4]) == MATCH_YES)
    7494                 :             :         {
    7495                 :           7 :           clause = clauses[4];
    7496                 :           7 :           requires_clause = OMP_REQ_DYNAMIC_ALLOCATORS;
    7497                 :           7 :           if (requires_clauses & OMP_REQ_DYNAMIC_ALLOCATORS)
    7498                 :           1 :             goto duplicate_clause;
    7499                 :             :         }
    7500                 :          32 :       else if (gfc_match ("atomic_default_mem_order (") == MATCH_YES)
    7501                 :             :         {
    7502                 :          31 :           clause = clauses[5];
    7503                 :          31 :           if (requires_clauses & OMP_REQ_ATOMIC_MEM_ORDER_MASK)
    7504                 :           1 :             goto duplicate_clause;
    7505                 :          30 :           if (gfc_match (" seq_cst )") == MATCH_YES)
    7506                 :             :             {
    7507                 :             :               clause = "seq_cst";
    7508                 :             :               requires_clause = OMP_REQ_ATOMIC_MEM_ORDER_SEQ_CST;
    7509                 :             :             }
    7510                 :          18 :           else if (gfc_match (" acq_rel )") == MATCH_YES)
    7511                 :             :             {
    7512                 :             :               clause = "acq_rel";
    7513                 :             :               requires_clause = OMP_REQ_ATOMIC_MEM_ORDER_ACQ_REL;
    7514                 :             :             }
    7515                 :          12 :           else if (gfc_match (" acquire )") == MATCH_YES)
    7516                 :             :             {
    7517                 :             :               clause = "acquire";
    7518                 :             :               requires_clause = OMP_REQ_ATOMIC_MEM_ORDER_ACQUIRE;
    7519                 :             :             }
    7520                 :           9 :           else if (gfc_match (" relaxed )") == MATCH_YES)
    7521                 :             :             {
    7522                 :             :               clause = "relaxed";
    7523                 :             :               requires_clause = OMP_REQ_ATOMIC_MEM_ORDER_RELAXED;
    7524                 :             :             }
    7525                 :           5 :           else if (gfc_match (" release )") == MATCH_YES)
    7526                 :             :             {
    7527                 :             :               clause = "release";
    7528                 :             :               requires_clause = OMP_REQ_ATOMIC_MEM_ORDER_RELEASE;
    7529                 :             :             }
    7530                 :             :           else
    7531                 :             :             {
    7532                 :           2 :               gfc_error ("Expected ACQ_REL, ACQUIRE, RELAXED, RELEASE or "
    7533                 :             :                          "SEQ_CST for ATOMIC_DEFAULT_MEM_ORDER clause at %C");
    7534                 :           2 :               goto error;
    7535                 :             :             }
    7536                 :             :         }
    7537                 :             :       else
    7538                 :           1 :         goto error;
    7539                 :             : 
    7540                 :          90 :       if (!gfc_omp_requires_add_clause (requires_clause, clause, &old_loc, NULL))
    7541                 :           3 :         goto error;
    7542                 :          87 :       requires_clauses |= requires_clause;
    7543                 :          87 :     }
    7544                 :             : 
    7545                 :          76 :   if (requires_clauses == 0)
    7546                 :             :     {
    7547                 :           1 :       if (!gfc_error_flag_test ())
    7548                 :           1 :         gfc_error ("Clause expected at %C");
    7549                 :           1 :       goto error;
    7550                 :             :     }
    7551                 :             :   return MATCH_YES;
    7552                 :             : 
    7553                 :           5 : duplicate_clause:
    7554                 :           5 :   gfc_error ("%qs clause at %L specified more than once", clause, &old_loc);
    7555                 :          12 : error:
    7556                 :          12 :   if (!gfc_error_flag_test ())
    7557                 :           1 :     gfc_error ("Expected UNIFIED_ADDRESS, UNIFIED_SHARED_MEMORY, SELF_MAPS, "
    7558                 :             :                "DYNAMIC_ALLOCATORS, REVERSE_OFFLOAD, or "
    7559                 :             :                "ATOMIC_DEFAULT_MEM_ORDER clause at %L", &old_loc);
    7560                 :             :   return MATCH_ERROR;
    7561                 :             : }
    7562                 :             : 
    7563                 :             : 
    7564                 :             : match
    7565                 :          51 : gfc_match_omp_scan (void)
    7566                 :             : {
    7567                 :          51 :   bool incl;
    7568                 :          51 :   gfc_omp_clauses *c = gfc_get_omp_clauses ();
    7569                 :          51 :   gfc_gobble_whitespace ();
    7570                 :          51 :   if ((incl = (gfc_match ("inclusive") == MATCH_YES))
    7571                 :          51 :       || gfc_match ("exclusive") == MATCH_YES)
    7572                 :             :     {
    7573                 :          70 :       if (gfc_match_omp_variable_list (" (", &c->lists[incl ? OMP_LIST_SCAN_IN
    7574                 :             :                                                             : OMP_LIST_SCAN_EX],
    7575                 :             :                                        false) != MATCH_YES)
    7576                 :             :         {
    7577                 :           0 :           gfc_free_omp_clauses (c);
    7578                 :           0 :           return MATCH_ERROR;
    7579                 :             :         }
    7580                 :             :     }
    7581                 :             :   else
    7582                 :             :     {
    7583                 :           1 :       gfc_error ("Expected INCLUSIVE or EXCLUSIVE clause at %C");
    7584                 :           1 :       gfc_free_omp_clauses (c);
    7585                 :           1 :       return MATCH_ERROR;
    7586                 :             :     }
    7587                 :          50 :   if (gfc_match_omp_eos () != MATCH_YES)
    7588                 :             :     {
    7589                 :           1 :       gfc_error ("Unexpected junk after !$OMP SCAN at %C");
    7590                 :           1 :       gfc_free_omp_clauses (c);
    7591                 :           1 :       return MATCH_ERROR;
    7592                 :             :     }
    7593                 :             : 
    7594                 :          49 :   new_st.op = EXEC_OMP_SCAN;
    7595                 :          49 :   new_st.ext.omp_clauses = c;
    7596                 :          49 :   return MATCH_YES;
    7597                 :             : }
    7598                 :             : 
    7599                 :             : 
    7600                 :             : match
    7601                 :          58 : gfc_match_omp_scope (void)
    7602                 :             : {
    7603                 :          58 :   return match_omp (EXEC_OMP_SCOPE, OMP_SCOPE_CLAUSES);
    7604                 :             : }
    7605                 :             : 
    7606                 :             : 
    7607                 :             : match
    7608                 :          82 : gfc_match_omp_sections (void)
    7609                 :             : {
    7610                 :          82 :   return match_omp (EXEC_OMP_SECTIONS, OMP_SECTIONS_CLAUSES);
    7611                 :             : }
    7612                 :             : 
    7613                 :             : 
    7614                 :             : match
    7615                 :         772 : gfc_match_omp_simd (void)
    7616                 :             : {
    7617                 :         772 :   return match_omp (EXEC_OMP_SIMD, OMP_SIMD_CLAUSES);
    7618                 :             : }
    7619                 :             : 
    7620                 :             : 
    7621                 :             : match
    7622                 :         569 : gfc_match_omp_single (void)
    7623                 :             : {
    7624                 :         569 :   return match_omp (EXEC_OMP_SINGLE, OMP_SINGLE_CLAUSES);
    7625                 :             : }
    7626                 :             : 
    7627                 :             : 
    7628                 :             : match
    7629                 :        1787 : gfc_match_omp_target (void)
    7630                 :             : {
    7631                 :        1787 :   return match_omp (EXEC_OMP_TARGET, OMP_TARGET_CLAUSES);
    7632                 :             : }
    7633                 :             : 
    7634                 :             : 
    7635                 :             : match
    7636                 :        1398 : gfc_match_omp_target_data (void)
    7637                 :             : {
    7638                 :        1398 :   return match_omp (EXEC_OMP_TARGET_DATA, OMP_TARGET_DATA_CLAUSES);
    7639                 :             : }
    7640                 :             : 
    7641                 :             : 
    7642                 :             : match
    7643                 :         311 : gfc_match_omp_target_enter_data (void)
    7644                 :             : {
    7645                 :         311 :   return match_omp (EXEC_OMP_TARGET_ENTER_DATA, OMP_TARGET_ENTER_DATA_CLAUSES);
    7646                 :             : }
    7647                 :             : 
    7648                 :             : 
    7649                 :             : match
    7650                 :         227 : gfc_match_omp_target_exit_data (void)
    7651                 :             : {
    7652                 :         227 :   return match_omp (EXEC_OMP_TARGET_EXIT_DATA, OMP_TARGET_EXIT_DATA_CLAUSES);
    7653                 :             : }
    7654                 :             : 
    7655                 :             : 
    7656                 :             : match
    7657                 :          24 : gfc_match_omp_target_parallel (void)
    7658                 :             : {
    7659                 :          24 :   return match_omp (EXEC_OMP_TARGET_PARALLEL,
    7660                 :          24 :                     (OMP_TARGET_CLAUSES | OMP_PARALLEL_CLAUSES)
    7661                 :          24 :                     & ~(omp_mask (OMP_CLAUSE_COPYIN)));
    7662                 :             : }
    7663                 :             : 
    7664                 :             : 
    7665                 :             : match
    7666                 :          80 : gfc_match_omp_target_parallel_do (void)
    7667                 :             : {
    7668                 :          80 :   return match_omp (EXEC_OMP_TARGET_PARALLEL_DO,
    7669                 :          80 :                     (OMP_TARGET_CLAUSES | OMP_PARALLEL_CLAUSES
    7670                 :          80 :                      | OMP_DO_CLAUSES) & ~(omp_mask (OMP_CLAUSE_COPYIN)));
    7671                 :             : }
    7672                 :             : 
    7673                 :             : 
    7674                 :             : match
    7675                 :          19 : gfc_match_omp_target_parallel_do_simd (void)
    7676                 :             : {
    7677                 :          19 :   return match_omp (EXEC_OMP_TARGET_PARALLEL_DO_SIMD,
    7678                 :          19 :                     (OMP_TARGET_CLAUSES | OMP_PARALLEL_CLAUSES | OMP_DO_CLAUSES
    7679                 :          19 :                      | OMP_SIMD_CLAUSES) & ~(omp_mask (OMP_CLAUSE_COPYIN)));
    7680                 :             : }
    7681                 :             : 
    7682                 :             : 
    7683                 :             : match
    7684                 :          34 : gfc_match_omp_target_simd (void)
    7685                 :             : {
    7686                 :          34 :   return match_omp (EXEC_OMP_TARGET_SIMD,
    7687                 :          34 :                     OMP_TARGET_CLAUSES | OMP_SIMD_CLAUSES);
    7688                 :             : }
    7689                 :             : 
    7690                 :             : 
    7691                 :             : match
    7692                 :          72 : gfc_match_omp_target_teams (void)
    7693                 :             : {
    7694                 :          72 :   return match_omp (EXEC_OMP_TARGET_TEAMS,
    7695                 :          72 :                     OMP_TARGET_CLAUSES | OMP_TEAMS_CLAUSES);
    7696                 :             : }
    7697                 :             : 
    7698                 :             : 
    7699                 :             : match
    7700                 :          19 : gfc_match_omp_target_teams_distribute (void)
    7701                 :             : {
    7702                 :          19 :   return match_omp (EXEC_OMP_TARGET_TEAMS_DISTRIBUTE,
    7703                 :          19 :                     OMP_TARGET_CLAUSES | OMP_TEAMS_CLAUSES
    7704                 :          19 :                     | OMP_DISTRIBUTE_CLAUSES);
    7705                 :             : }
    7706                 :             : 
    7707                 :             : 
    7708                 :             : match
    7709                 :          60 : gfc_match_omp_target_teams_distribute_parallel_do (void)
    7710                 :             : {
    7711                 :          60 :   return match_omp (EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO,
    7712                 :          60 :                     (OMP_TARGET_CLAUSES | OMP_TEAMS_CLAUSES
    7713                 :          60 :                      | OMP_DISTRIBUTE_CLAUSES | OMP_PARALLEL_CLAUSES
    7714                 :          60 :                      | OMP_DO_CLAUSES)
    7715                 :          60 :                     & ~(omp_mask (OMP_CLAUSE_ORDERED))
    7716                 :          60 :                     & ~(omp_mask (OMP_CLAUSE_LINEAR)));
    7717                 :             : }
    7718                 :             : 
    7719                 :             : 
    7720                 :             : match
    7721                 :          34 : gfc_match_omp_target_teams_distribute_parallel_do_simd (void)
    7722                 :             : {
    7723                 :          34 :   return match_omp (EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD,
    7724                 :          34 :                     (OMP_TARGET_CLAUSES | OMP_TEAMS_CLAUSES
    7725                 :          34 :                      | OMP_DISTRIBUTE_CLAUSES | OMP_PARALLEL_CLAUSES
    7726                 :          34 :                      | OMP_DO_CLAUSES | OMP_SIMD_CLAUSES)
    7727                 :          34 :                     & ~(omp_mask (OMP_CLAUSE_ORDERED)));
    7728                 :             : }
    7729                 :             : 
    7730                 :             : 
    7731                 :             : match
    7732                 :          21 : gfc_match_omp_target_teams_distribute_simd (void)
    7733                 :             : {
    7734                 :          21 :   return match_omp (EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_SIMD,
    7735                 :          21 :                     OMP_TARGET_CLAUSES | OMP_TEAMS_CLAUSES
    7736                 :          21 :                     | OMP_DISTRIBUTE_CLAUSES | OMP_SIMD_CLAUSES);
    7737                 :             : }
    7738                 :             : 
    7739                 :             : 
    7740                 :             : match
    7741                 :        1704 : gfc_match_omp_target_update (void)
    7742                 :             : {
    7743                 :        1704 :   return match_omp (EXEC_OMP_TARGET_UPDATE, OMP_TARGET_UPDATE_CLAUSES);
    7744                 :             : }
    7745                 :             : 
    7746                 :             : 
    7747                 :             : match
    7748                 :        1180 : gfc_match_omp_task (void)
    7749                 :             : {
    7750                 :        1180 :   return match_omp (EXEC_OMP_TASK, OMP_TASK_CLAUSES);
    7751                 :             : }
    7752                 :             : 
    7753                 :             : 
    7754                 :             : match
    7755                 :          72 : gfc_match_omp_taskloop (void)
    7756                 :             : {
    7757                 :          72 :   return match_omp (EXEC_OMP_TASKLOOP, OMP_TASKLOOP_CLAUSES);
    7758                 :             : }
    7759                 :             : 
    7760                 :             : 
    7761                 :             : match
    7762                 :          40 : gfc_match_omp_taskloop_simd (void)
    7763                 :             : {
    7764                 :          40 :   return match_omp (EXEC_OMP_TASKLOOP_SIMD,
    7765                 :          40 :                     OMP_TASKLOOP_CLAUSES | OMP_SIMD_CLAUSES);
    7766                 :             : }
    7767                 :             : 
    7768                 :             : 
    7769                 :             : match
    7770                 :         144 : gfc_match_omp_taskwait (void)
    7771                 :             : {
    7772                 :         144 :   if (gfc_match_omp_eos () == MATCH_YES)
    7773                 :             :     {
    7774                 :         132 :       new_st.op = EXEC_OMP_TASKWAIT;
    7775                 :         132 :       new_st.ext.omp_clauses = NULL;
    7776                 :         132 :       return MATCH_YES;
    7777                 :             :     }
    7778                 :          12 :   return match_omp (EXEC_OMP_TASKWAIT,
    7779                 :          12 :                     omp_mask (OMP_CLAUSE_DEPEND) | OMP_CLAUSE_NOWAIT);
    7780                 :             : }
    7781                 :             : 
    7782                 :             : 
    7783                 :             : match
    7784                 :          10 : gfc_match_omp_taskyield (void)
    7785                 :             : {
    7786                 :          10 :   if (gfc_match_omp_eos () != MATCH_YES)
    7787                 :             :     {
    7788                 :           0 :       gfc_error ("Unexpected junk after TASKYIELD clause at %C");
    7789                 :           0 :       return MATCH_ERROR;
    7790                 :             :     }
    7791                 :          10 :   new_st.op = EXEC_OMP_TASKYIELD;
    7792                 :          10 :   new_st.ext.omp_clauses = NULL;
    7793                 :          10 :   return MATCH_YES;
    7794                 :             : }
    7795                 :             : 
    7796                 :             : 
    7797                 :             : match
    7798                 :         150 : gfc_match_omp_teams (void)
    7799                 :             : {
    7800                 :         150 :   return match_omp (EXEC_OMP_TEAMS, OMP_TEAMS_CLAUSES);
    7801                 :             : }
    7802                 :             : 
    7803                 :             : 
    7804                 :             : match
    7805                 :          22 : gfc_match_omp_teams_distribute (void)
    7806                 :             : {
    7807                 :          22 :   return match_omp (EXEC_OMP_TEAMS_DISTRIBUTE,
    7808                 :          22 :                     OMP_TEAMS_CLAUSES | OMP_DISTRIBUTE_CLAUSES);
    7809                 :             : }
    7810                 :             : 
    7811                 :             : 
    7812                 :             : match
    7813                 :          39 : gfc_match_omp_teams_distribute_parallel_do (void)
    7814                 :             : {
    7815                 :          39 :   return match_omp (EXEC_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO,
    7816                 :          39 :                     (OMP_TEAMS_CLAUSES | OMP_DISTRIBUTE_CLAUSES
    7817                 :          39 :                      | OMP_PARALLEL_CLAUSES | OMP_DO_CLAUSES)
    7818                 :          39 :                     & ~(omp_mask (OMP_CLAUSE_ORDERED)
    7819                 :          39 :                         | OMP_CLAUSE_LINEAR | OMP_CLAUSE_NOWAIT));
    7820                 :             : }
    7821                 :             : 
    7822                 :             : 
    7823                 :             : match
    7824                 :          62 : gfc_match_omp_teams_distribute_parallel_do_simd (void)
    7825                 :             : {
    7826                 :          62 :   return match_omp (EXEC_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD,
    7827                 :          62 :                     (OMP_TEAMS_CLAUSES | OMP_DISTRIBUTE_CLAUSES
    7828                 :          62 :                      | OMP_PARALLEL_CLAUSES | OMP_DO_CLAUSES
    7829                 :          62 :                      | OMP_SIMD_CLAUSES)
    7830                 :          62 :                     & ~(omp_mask (OMP_CLAUSE_ORDERED) | OMP_CLAUSE_NOWAIT));
    7831                 :             : }
    7832                 :             : 
    7833                 :             : 
    7834                 :             : match
    7835                 :          44 : gfc_match_omp_teams_distribute_simd (void)
    7836                 :             : {
    7837                 :          44 :   return match_omp (EXEC_OMP_TEAMS_DISTRIBUTE_SIMD,
    7838                 :          44 :                     OMP_TEAMS_CLAUSES | OMP_DISTRIBUTE_CLAUSES
    7839                 :          44 :                     | OMP_SIMD_CLAUSES);
    7840                 :             : }
    7841                 :             : 
    7842                 :             : match
    7843                 :         203 : gfc_match_omp_tile (void)
    7844                 :             : {
    7845                 :         203 :   return match_omp (EXEC_OMP_TILE, OMP_TILE_CLAUSES);
    7846                 :             : }
    7847                 :             : 
    7848                 :             : match
    7849                 :         415 : gfc_match_omp_unroll (void)
    7850                 :             : {
    7851                 :         415 :   return match_omp (EXEC_OMP_UNROLL, OMP_UNROLL_CLAUSES);
    7852                 :             : }
    7853                 :             : 
    7854                 :             : match
    7855                 :          39 : gfc_match_omp_workshare (void)
    7856                 :             : {
    7857                 :          39 :   return match_omp (EXEC_OMP_WORKSHARE, OMP_WORKSHARE_CLAUSES);
    7858                 :             : }
    7859                 :             : 
    7860                 :             : 
    7861                 :             : match
    7862                 :          49 : gfc_match_omp_masked (void)
    7863                 :             : {
    7864                 :          49 :   return match_omp (EXEC_OMP_MASKED, OMP_MASKED_CLAUSES);
    7865                 :             : }
    7866                 :             : 
    7867                 :             : match
    7868                 :          10 : gfc_match_omp_masked_taskloop (void)
    7869                 :             : {
    7870                 :          10 :   return match_omp (EXEC_OMP_MASKED_TASKLOOP,
    7871                 :          10 :                     OMP_MASKED_CLAUSES | OMP_TASKLOOP_CLAUSES);
    7872                 :             : }
    7873                 :             : 
    7874                 :             : match
    7875                 :          15 : gfc_match_omp_masked_taskloop_simd (void)
    7876                 :             : {
    7877                 :          15 :   return match_omp (EXEC_OMP_MASKED_TASKLOOP_SIMD,
    7878                 :          15 :                     (OMP_MASKED_CLAUSES | OMP_TASKLOOP_CLAUSES
    7879                 :          15 :                      | OMP_SIMD_CLAUSES));
    7880                 :             : }
    7881                 :             : 
    7882                 :             : match
    7883                 :         110 : gfc_match_omp_master (void)
    7884                 :             : {
    7885                 :         110 :   if (gfc_match_omp_eos () != MATCH_YES)
    7886                 :             :     {
    7887                 :           1 :       gfc_error ("Unexpected junk after $OMP MASTER statement at %C");
    7888                 :           1 :       return MATCH_ERROR;
    7889                 :             :     }
    7890                 :         109 :   new_st.op = EXEC_OMP_MASTER;
    7891                 :         109 :   new_st.ext.omp_clauses = NULL;
    7892                 :         109 :   return MATCH_YES;
    7893                 :             : }
    7894                 :             : 
    7895                 :             : match
    7896                 :          16 : gfc_match_omp_master_taskloop (void)
    7897                 :             : {
    7898                 :          16 :   return match_omp (EXEC_OMP_MASTER_TASKLOOP, OMP_TASKLOOP_CLAUSES);
    7899                 :             : }
    7900                 :             : 
    7901                 :             : match
    7902                 :          22 : gfc_match_omp_master_taskloop_simd (void)
    7903                 :             : {
    7904                 :          22 :   return match_omp (EXEC_OMP_MASTER_TASKLOOP_SIMD,
    7905                 :          22 :                     OMP_TASKLOOP_CLAUSES | OMP_SIMD_CLAUSES);
    7906                 :             : }
    7907                 :             : 
    7908                 :             : match
    7909                 :         235 : gfc_match_omp_ordered (void)
    7910                 :             : {
    7911                 :         235 :   return match_omp (EXEC_OMP_ORDERED, OMP_ORDERED_CLAUSES);
    7912                 :             : }
    7913                 :             : 
    7914                 :             : match
    7915                 :          23 : gfc_match_omp_nothing (void)
    7916                 :             : {
    7917                 :          23 :   if (gfc_match_omp_eos () != MATCH_YES)
    7918                 :             :     {
    7919                 :           1 :       gfc_error ("Unexpected junk after $OMP NOTHING statement at %C");
    7920                 :           1 :       return MATCH_ERROR;
    7921                 :             :     }
    7922                 :             :   /* Will use ST_NONE; therefore, no EXEC_OMP_ is needed.  */
    7923                 :             :   return MATCH_YES;
    7924                 :             : }
    7925                 :             : 
    7926                 :             : match
    7927                 :         315 : gfc_match_omp_ordered_depend (void)
    7928                 :             : {
    7929                 :         315 :   return match_omp (EXEC_OMP_ORDERED, omp_mask (OMP_CLAUSE_DOACROSS));
    7930                 :             : }
    7931                 :             : 
    7932                 :             : 
    7933                 :             : /* omp atomic [clause-list]
    7934                 :             :    - atomic-clause:  read | write | update
    7935                 :             :    - capture
    7936                 :             :    - memory-order-clause: seq_cst | acq_rel | release | acquire | relaxed
    7937                 :             :    - hint(hint-expr)
    7938                 :             :    - OpenMP 5.1: compare | fail (seq_cst | acquire | relaxed ) | weak
    7939                 :             : */
    7940                 :             : 
    7941                 :             : match
    7942                 :        2171 : gfc_match_omp_atomic (void)
    7943                 :             : {
    7944                 :        2171 :   gfc_omp_clauses *c;
    7945                 :        2171 :   locus loc = gfc_current_locus;
    7946                 :             : 
    7947                 :        2171 :   if (gfc_match_omp_clauses (&c, OMP_ATOMIC_CLAUSES, true, true) != MATCH_YES)
    7948                 :             :     return MATCH_ERROR;
    7949                 :             : 
    7950                 :        2153 :   if (c->atomic_op == GFC_OMP_ATOMIC_UNSET)
    7951                 :        1011 :     c->atomic_op = GFC_OMP_ATOMIC_UPDATE;
    7952                 :             : 
    7953                 :        2153 :   if (c->capture && c->atomic_op != GFC_OMP_ATOMIC_UPDATE)
    7954                 :           3 :     gfc_error ("!$OMP ATOMIC at %L with %s clause is incompatible with "
    7955                 :             :                "READ or WRITE", &loc, "CAPTURE");
    7956                 :        2153 :   if (c->compare && c->atomic_op != GFC_OMP_ATOMIC_UPDATE)
    7957                 :           3 :     gfc_error ("!$OMP ATOMIC at %L with %s clause is incompatible with "
    7958                 :             :                "READ or WRITE", &loc, "COMPARE");
    7959                 :        2153 :   if (c->fail != OMP_MEMORDER_UNSET && c->atomic_op != GFC_OMP_ATOMIC_UPDATE)
    7960                 :           2 :     gfc_error ("!$OMP ATOMIC at %L with %s clause is incompatible with "
    7961                 :             :                "READ or WRITE", &loc, "FAIL");
    7962                 :        2153 :   if (c->weak && !c->compare)
    7963                 :             :     {
    7964                 :           5 :       gfc_error ("!$OMP ATOMIC at %L with %s clause requires %s clause", &loc,
    7965                 :             :                  "WEAK", "COMPARE");
    7966                 :           5 :       c->weak = false;
    7967                 :             :     }
    7968                 :             : 
    7969                 :        2153 :   if (c->memorder == OMP_MEMORDER_UNSET)
    7970                 :             :     {
    7971                 :        1969 :       gfc_namespace *prog_unit = gfc_current_ns;
    7972                 :        2525 :       while (prog_unit->parent)
    7973                 :             :         prog_unit = prog_unit->parent;
    7974                 :        1969 :       switch (prog_unit->omp_requires & OMP_REQ_ATOMIC_MEM_ORDER_MASK)
    7975                 :             :         {
    7976                 :        1936 :         case 0:
    7977                 :        1936 :         case OMP_REQ_ATOMIC_MEM_ORDER_RELAXED:
    7978                 :        1936 :           c->memorder = OMP_MEMORDER_RELAXED;
    7979                 :        1936 :           break;
    7980                 :           7 :         case OMP_REQ_ATOMIC_MEM_ORDER_SEQ_CST:
    7981                 :           7 :           c->memorder = OMP_MEMORDER_SEQ_CST;
    7982                 :           7 :           break;
    7983                 :          16 :         case OMP_REQ_ATOMIC_MEM_ORDER_ACQ_REL:
    7984                 :          16 :           if (c->capture)
    7985                 :           5 :             c->memorder = OMP_MEMORDER_ACQ_REL;
    7986                 :          11 :           else if (c->atomic_op == GFC_OMP_ATOMIC_READ)
    7987                 :           3 :             c->memorder = OMP_MEMORDER_ACQUIRE;
    7988                 :             :           else
    7989                 :           8 :             c->memorder = OMP_MEMORDER_RELEASE;
    7990                 :             :           break;
    7991                 :           5 :         case OMP_REQ_ATOMIC_MEM_ORDER_ACQUIRE:
    7992                 :           5 :           if (c->atomic_op == GFC_OMP_ATOMIC_WRITE)
    7993                 :             :             {
    7994                 :           1 :               gfc_error ("!$OMP ATOMIC WRITE at %L incompatible with "
    7995                 :             :                          "ACQUIRES clause implicitly provided by a "
    7996                 :             :                          "REQUIRES directive", &loc);
    7997                 :           1 :               c->memorder = OMP_MEMORDER_SEQ_CST;
    7998                 :             :             }
    7999                 :             :           else
    8000                 :           4 :             c->memorder = OMP_MEMORDER_ACQUIRE;
    8001                 :             :           break;
    8002                 :           5 :         case OMP_REQ_ATOMIC_MEM_ORDER_RELEASE:
    8003                 :           5 :           if (c->atomic_op == GFC_OMP_ATOMIC_READ)
    8004                 :             :             {
    8005                 :           1 :               gfc_error ("!$OMP ATOMIC READ at %L incompatible with "
    8006                 :             :                          "RELEASE clause implicitly provided by a "
    8007                 :             :                          "REQUIRES directive", &loc);
    8008                 :           1 :               c->memorder = OMP_MEMORDER_SEQ_CST;
    8009                 :             :             }
    8010                 :             :           else
    8011                 :           4 :             c->memorder = OMP_MEMORDER_RELEASE;
    8012                 :             :           break;
    8013                 :           0 :         default:
    8014                 :           0 :           gcc_unreachable ();
    8015                 :             :         }
    8016                 :             :     }
    8017                 :             :   else
    8018                 :         184 :     switch (c->atomic_op)
    8019                 :             :       {
    8020                 :          29 :       case GFC_OMP_ATOMIC_READ:
    8021                 :          29 :         if (c->memorder == OMP_MEMORDER_RELEASE)
    8022                 :             :           {
    8023                 :           1 :             gfc_error ("!$OMP ATOMIC READ at %L incompatible with "
    8024                 :             :                        "RELEASE clause", &loc);
    8025                 :           1 :             c->memorder = OMP_MEMORDER_SEQ_CST;
    8026                 :             :           }
    8027                 :          28 :         else if (c->memorder == OMP_MEMORDER_ACQ_REL)
    8028                 :           1 :           c->memorder = OMP_MEMORDER_ACQUIRE;
    8029                 :             :         break;
    8030                 :          35 :       case GFC_OMP_ATOMIC_WRITE:
    8031                 :          35 :         if (c->memorder == OMP_MEMORDER_ACQUIRE)
    8032                 :             :           {
    8033                 :           1 :             gfc_error ("!$OMP ATOMIC WRITE at %L incompatible with "
    8034                 :             :                        "ACQUIRE clause", &loc);
    8035                 :           1 :             c->memorder = OMP_MEMORDER_SEQ_CST;
    8036                 :             :           }
    8037                 :          34 :         else if (c->memorder == OMP_MEMORDER_ACQ_REL)
    8038                 :           1 :           c->memorder = OMP_MEMORDER_RELEASE;
    8039                 :             :         break;
    8040                 :             :       default:
    8041                 :             :         break;
    8042                 :             :       }
    8043                 :        2153 :   gfc_error_check ();
    8044                 :        2153 :   new_st.ext.omp_clauses = c;
    8045                 :        2153 :   new_st.op = EXEC_OMP_ATOMIC;
    8046                 :        2153 :   return MATCH_YES;
    8047                 :             : }
    8048                 :             : 
    8049                 :             : 
    8050                 :             : /* acc atomic [ read | write | update | capture]  */
    8051                 :             : 
    8052                 :             : match
    8053                 :         552 : gfc_match_oacc_atomic (void)
    8054                 :             : {
    8055                 :         552 :   gfc_omp_clauses *c = gfc_get_omp_clauses ();
    8056                 :         552 :   c->atomic_op = GFC_OMP_ATOMIC_UPDATE;
    8057                 :         552 :   c->memorder = OMP_MEMORDER_RELAXED;
    8058                 :         552 :   gfc_gobble_whitespace ();
    8059                 :         552 :   if (gfc_match ("update") == MATCH_YES)
    8060                 :             :     ;
    8061                 :         373 :   else if (gfc_match ("read") == MATCH_YES)
    8062                 :          17 :     c->atomic_op = GFC_OMP_ATOMIC_READ;
    8063                 :         356 :   else if (gfc_match ("write") == MATCH_YES)
    8064                 :          13 :     c->atomic_op = GFC_OMP_ATOMIC_WRITE;
    8065                 :         343 :   else if (gfc_match ("capture") == MATCH_YES)
    8066                 :         319 :     c->capture = true;
    8067                 :         552 :   gfc_gobble_whitespace ();
    8068                 :         552 :   if (gfc_match_omp_eos () != MATCH_YES)
    8069                 :             :     {
    8070                 :           9 :       gfc_error ("Unexpected junk after !$ACC ATOMIC statement at %C");
    8071                 :           9 :       gfc_free_omp_clauses (c);
    8072                 :           9 :       return MATCH_ERROR;
    8073                 :             :     }
    8074                 :         543 :   new_st.ext.omp_clauses = c;
    8075                 :         543 :   new_st.op = EXEC_OACC_ATOMIC;
    8076                 :         543 :   return MATCH_YES;
    8077                 :             : }
    8078                 :             : 
    8079                 :             : 
    8080                 :             : match
    8081                 :         613 : gfc_match_omp_barrier (void)
    8082                 :             : {
    8083                 :         613 :   if (gfc_match_omp_eos () != MATCH_YES)
    8084                 :             :     {
    8085                 :           0 :       gfc_error ("Unexpected junk after $OMP BARRIER statement at %C");
    8086                 :           0 :       return MATCH_ERROR;
    8087                 :             :     }
    8088                 :         613 :   new_st.op = EXEC_OMP_BARRIER;
    8089                 :         613 :   new_st.ext.omp_clauses = NULL;
    8090                 :         613 :   return MATCH_YES;
    8091                 :             : }
    8092                 :             : 
    8093                 :             : 
    8094                 :             : match
    8095                 :         188 : gfc_match_omp_taskgroup (void)
    8096                 :             : {
    8097                 :         188 :   return match_omp (EXEC_OMP_TASKGROUP, OMP_TASKGROUP_CLAUSES);
    8098                 :             : }
    8099                 :             : 
    8100                 :             : 
    8101                 :             : static enum gfc_omp_cancel_kind
    8102                 :         494 : gfc_match_omp_cancel_kind (void)
    8103                 :             : {
    8104                 :         494 :   if (gfc_match_space () != MATCH_YES)
    8105                 :             :     return OMP_CANCEL_UNKNOWN;
    8106                 :         492 :   if (gfc_match ("parallel") == MATCH_YES)
    8107                 :             :     return OMP_CANCEL_PARALLEL;
    8108                 :         352 :   if (gfc_match ("sections") == MATCH_YES)
    8109                 :             :     return OMP_CANCEL_SECTIONS;
    8110                 :         253 :   if (gfc_match ("do") == MATCH_YES)
    8111                 :             :     return OMP_CANCEL_DO;
    8112                 :         123 :   if (gfc_match ("taskgroup") == MATCH_YES)
    8113                 :             :     return OMP_CANCEL_TASKGROUP;
    8114                 :             :   return OMP_CANCEL_UNKNOWN;
    8115                 :             : }
    8116                 :             : 
    8117                 :             : 
    8118                 :             : match
    8119                 :         321 : gfc_match_omp_cancel (void)
    8120                 :             : {
    8121                 :         321 :   gfc_omp_clauses *c;
    8122                 :         321 :   enum gfc_omp_cancel_kind kind = gfc_match_omp_cancel_kind ();
    8123                 :         321 :   if (kind == OMP_CANCEL_UNKNOWN)
    8124                 :             :     return MATCH_ERROR;
    8125                 :         319 :   if (gfc_match_omp_clauses (&c, omp_mask (OMP_CLAUSE_IF), false) != MATCH_YES)
    8126                 :             :     return MATCH_ERROR;
    8127                 :         316 :   c->cancel = kind;
    8128                 :         316 :   new_st.op = EXEC_OMP_CANCEL;
    8129                 :         316 :   new_st.ext.omp_clauses = c;
    8130                 :         316 :   return MATCH_YES;
    8131                 :             : }
    8132                 :             : 
    8133                 :             : 
    8134                 :             : match
    8135                 :         173 : gfc_match_omp_cancellation_point (void)
    8136                 :             : {
    8137                 :         173 :   gfc_omp_clauses *c;
    8138                 :         173 :   enum gfc_omp_cancel_kind kind = gfc_match_omp_cancel_kind ();
    8139                 :         173 :   if (kind == OMP_CANCEL_UNKNOWN)
    8140                 :             :     {
    8141                 :           2 :       gfc_error ("Expected construct-type PARALLEL, SECTIONS, DO or TASKGROUP "
    8142                 :             :                  "in $OMP CANCELLATION POINT statement at %C");
    8143                 :           2 :       return MATCH_ERROR;
    8144                 :             :     }
    8145                 :         171 :   if (gfc_match_omp_eos () != MATCH_YES)
    8146                 :             :     {
    8147                 :           0 :       gfc_error ("Unexpected junk after $OMP CANCELLATION POINT statement "
    8148                 :             :                  "at %C");
    8149                 :           0 :       return MATCH_ERROR;
    8150                 :             :     }
    8151                 :         171 :   c = gfc_get_omp_clauses ();
    8152                 :         171 :   c->cancel = kind;
    8153                 :         171 :   new_st.op = EXEC_OMP_CANCELLATION_POINT;
    8154                 :         171 :   new_st.ext.omp_clauses = c;
    8155                 :         171 :   return MATCH_YES;
    8156                 :             : }
    8157                 :             : 
    8158                 :             : 
    8159                 :             : match
    8160                 :        2308 : gfc_match_omp_end_nowait (void)
    8161                 :             : {
    8162                 :        2308 :   bool nowait = false;
    8163                 :        2308 :   if (gfc_match ("% nowait") == MATCH_YES)
    8164                 :         258 :     nowait = true;
    8165                 :        2308 :   if (gfc_match_omp_eos () != MATCH_YES)
    8166                 :             :     {
    8167                 :           4 :       if (nowait)
    8168                 :           3 :         gfc_error ("Unexpected junk after NOWAIT clause at %C");
    8169                 :             :       else
    8170                 :           1 :         gfc_error ("Unexpected junk at %C");
    8171                 :           4 :       return MATCH_ERROR;
    8172                 :             :     }
    8173                 :        2304 :   new_st.op = EXEC_OMP_END_NOWAIT;
    8174                 :        2304 :   new_st.ext.omp_bool = nowait;
    8175                 :        2304 :   return MATCH_YES;
    8176                 :             : }
    8177                 :             : 
    8178                 :             : 
    8179                 :             : match
    8180                 :         565 : gfc_match_omp_end_single (void)
    8181                 :             : {
    8182                 :         565 :   gfc_omp_clauses *c;
    8183                 :         565 :   if (gfc_match_omp_clauses (&c, omp_mask (OMP_CLAUSE_COPYPRIVATE)
    8184                 :             :                                            | OMP_CLAUSE_NOWAIT) != MATCH_YES)
    8185                 :             :     return MATCH_ERROR;
    8186                 :         565 :   new_st.op = EXEC_OMP_END_SINGLE;
    8187                 :         565 :   new_st.ext.omp_clauses = c;
    8188                 :         565 :   return MATCH_YES;
    8189                 :             : }
    8190                 :             : 
    8191                 :             : 
    8192                 :             : static bool
    8193                 :       36836 : oacc_is_loop (gfc_code *code)
    8194                 :             : {
    8195                 :       36836 :   return code->op == EXEC_OACC_PARALLEL_LOOP
    8196                 :             :          || code->op == EXEC_OACC_KERNELS_LOOP
    8197                 :       19810 :          || code->op == EXEC_OACC_SERIAL_LOOP
    8198                 :       13428 :          || code->op == EXEC_OACC_LOOP;
    8199                 :             : }
    8200                 :             : 
    8201                 :             : static void
    8202                 :        5664 : resolve_scalar_int_expr (gfc_expr *expr, const char *clause)
    8203                 :             : {
    8204                 :        5664 :   if (!gfc_resolve_expr (expr)
    8205                 :        5664 :       || expr->ts.type != BT_INTEGER
    8206                 :       11258 :       || expr->rank != 0)
    8207                 :          87 :     gfc_error ("%s clause at %L requires a scalar INTEGER expression",
    8208                 :             :                clause, &expr->where);
    8209                 :        5664 : }
    8210                 :             : 
    8211                 :             : static void
    8212                 :        3928 : resolve_positive_int_expr (gfc_expr *expr, const char *clause)
    8213                 :             : {
    8214                 :        3928 :   resolve_scalar_int_expr (expr, clause);
    8215                 :        3928 :   if (expr->expr_type == EXPR_CONSTANT
    8216                 :        3507 :       && expr->ts.type == BT_INTEGER
    8217                 :        3474 :       && mpz_sgn (expr->value.integer) <= 0)
    8218                 :          54 :     gfc_warning ((flag_openmp || flag_openmp_simd) ? OPT_Wopenmp : 0,
    8219                 :             :                  "INTEGER expression of %s clause at %L must be positive",
    8220                 :             :                  clause, &expr->where);
    8221                 :        3928 : }
    8222                 :             : 
    8223                 :             : static void
    8224                 :          76 : resolve_nonnegative_int_expr (gfc_expr *expr, const char *clause)
    8225                 :             : {
    8226                 :          76 :   resolve_scalar_int_expr (expr, clause);
    8227                 :          76 :   if (expr->expr_type == EXPR_CONSTANT
    8228                 :           8 :       && expr->ts.type == BT_INTEGER
    8229                 :           7 :       && mpz_sgn (expr->value.integer) < 0)
    8230                 :           2 :     gfc_warning ((flag_openmp || flag_openmp_simd) ? OPT_Wopenmp : 0,
    8231                 :             :                  "INTEGER expression of %s clause at %L must be non-negative",
    8232                 :             :                  clause, &expr->where);
    8233                 :          76 : }
    8234                 :             : 
    8235                 :             : /* Emits error when symbol is pointer, cray pointer or cray pointee
    8236                 :             :    of derived of polymorphic type.  */
    8237                 :             : 
    8238                 :             : static void
    8239                 :          98 : check_symbol_not_pointer (gfc_symbol *sym, locus loc, const char *name)
    8240                 :             : {
    8241                 :          98 :   if (sym->ts.type == BT_DERIVED && sym->attr.cray_pointer)
    8242                 :           0 :     gfc_error ("Cray pointer object %qs of derived type in %s clause at %L",
    8243                 :             :                sym->name, name, &loc);
    8244                 :          98 :   if (sym->ts.type == BT_DERIVED && sym->attr.cray_pointee)
    8245                 :           0 :     gfc_error ("Cray pointee object %qs of derived type in %s clause at %L",
    8246                 :             :                sym->name, name, &loc);
    8247                 :             : 
    8248                 :          98 :   if ((sym->ts.type == BT_ASSUMED && sym->attr.pointer)
    8249                 :          98 :       || (sym->ts.type == BT_CLASS && CLASS_DATA (sym)
    8250                 :           0 :           && CLASS_DATA (sym)->attr.pointer))
    8251                 :           0 :     gfc_error ("POINTER object %qs of polymorphic type in %s clause at %L",
    8252                 :             :                sym->name, name, &loc);
    8253                 :          98 :   if ((sym->ts.type == BT_ASSUMED && sym->attr.cray_pointer)
    8254                 :          98 :       || (sym->ts.type == BT_CLASS && CLASS_DATA (sym)
    8255                 :           0 :           && CLASS_DATA (sym)->attr.cray_pointer))
    8256                 :           0 :     gfc_error ("Cray pointer object %qs of polymorphic type in %s clause at %L",
    8257                 :             :                sym->name, name, &loc);
    8258                 :          98 :   if ((sym->ts.type == BT_ASSUMED && sym->attr.cray_pointee)
    8259                 :          98 :       || (sym->ts.type == BT_CLASS && CLASS_DATA (sym)
    8260                 :           0 :           && CLASS_DATA (sym)->attr.cray_pointee))
    8261                 :           0 :     gfc_error ("Cray pointee object %qs of polymorphic type in %s clause at %L",
    8262                 :             :                sym->name, name, &loc);
    8263                 :          98 : }
    8264                 :             : 
    8265                 :             : /* Emits error when symbol represents assumed size/rank array.  */
    8266                 :             : 
    8267                 :             : static void
    8268                 :       14718 : check_array_not_assumed (gfc_symbol *sym, locus loc, const char *name)
    8269                 :             : {
    8270                 :       14718 :   if (sym->as && sym->as->type == AS_ASSUMED_SIZE)
    8271                 :          13 :     gfc_error ("Assumed size array %qs in %s clause at %L",
    8272                 :             :                sym->name, name, &loc);
    8273                 :       14718 :   if (sym->as && sym->as->type == AS_ASSUMED_RANK)
    8274                 :          11 :     gfc_error ("Assumed rank array %qs in %s clause at %L",
    8275                 :             :                sym->name, name, &loc);
    8276                 :       14718 : }
    8277                 :             : 
    8278                 :             : static void
    8279                 :        5742 : resolve_oacc_data_clauses (gfc_symbol *sym, locus loc, const char *name)
    8280                 :             : {
    8281                 :           0 :   check_array_not_assumed (sym, loc, name);
    8282                 :           0 : }
    8283                 :             : 
    8284                 :             : static void
    8285                 :          59 : resolve_oacc_deviceptr_clause (gfc_symbol *sym, locus loc, const char *name)
    8286                 :             : {
    8287                 :          59 :   if (sym->attr.pointer
    8288                 :          58 :       || (sym->ts.type == BT_CLASS && CLASS_DATA (sym)
    8289                 :           0 :           && CLASS_DATA (sym)->attr.class_pointer))
    8290                 :           1 :     gfc_error ("POINTER object %qs in %s clause at %L",
    8291                 :             :                sym->name, name, &loc);
    8292                 :          59 :   if (sym->attr.cray_pointer
    8293                 :          57 :       || (sym->ts.type == BT_CLASS && CLASS_DATA (sym)
    8294                 :           0 :           && CLASS_DATA (sym)->attr.cray_pointer))
    8295                 :           2 :     gfc_error ("Cray pointer object %qs in %s clause at %L",
    8296                 :             :                sym->name, name, &loc);
    8297                 :          59 :   if (sym->attr.cray_pointee
    8298                 :          57 :       || (sym->ts.type == BT_CLASS && CLASS_DATA (sym)
    8299                 :           0 :           && CLASS_DATA (sym)->attr.cray_pointee))
    8300                 :           2 :     gfc_error ("Cray pointee object %qs in %s clause at %L",
    8301                 :             :                sym->name, name, &loc);
    8302                 :          59 :   if (sym->attr.allocatable
    8303                 :          58 :       || (sym->ts.type == BT_CLASS && CLASS_DATA (sym)
    8304                 :           0 :           && CLASS_DATA (sym)->attr.allocatable))
    8305                 :           1 :     gfc_error ("ALLOCATABLE object %qs in %s clause at %L",
    8306                 :             :                sym->name, name, &loc);
    8307                 :          59 :   if (sym->attr.value)
    8308                 :           1 :     gfc_error ("VALUE object %qs in %s clause at %L",
    8309                 :             :                sym->name, name, &loc);
    8310                 :          59 :   check_array_not_assumed (sym, loc, name);
    8311                 :          59 : }
    8312                 :             : 
    8313                 :             : 
    8314                 :             : struct resolve_omp_udr_callback_data
    8315                 :             : {
    8316                 :             :   gfc_symbol *sym1, *sym2;
    8317                 :             : };
    8318                 :             : 
    8319                 :             : 
    8320                 :             : static int
    8321                 :        1413 : resolve_omp_udr_callback (gfc_expr **e, int *, void *data)
    8322                 :             : {
    8323                 :        1413 :   struct resolve_omp_udr_callback_data *rcd
    8324                 :             :     = (struct resolve_omp_udr_callback_data *) data;
    8325                 :        1413 :   if ((*e)->expr_type == EXPR_VARIABLE
    8326                 :         801 :       && ((*e)->symtree->n.sym == rcd->sym1
    8327                 :         255 :           || (*e)->symtree->n.sym == rcd->sym2))
    8328                 :             :     {
    8329                 :         801 :       gfc_ref *ref = gfc_get_ref ();
    8330                 :         801 :       ref->type = REF_ARRAY;
    8331                 :         801 :       ref->u.ar.where = (*e)->where;
    8332                 :         801 :       ref->u.ar.as = (*e)->symtree->n.sym->as;
    8333                 :         801 :       ref->u.ar.type = AR_FULL;
    8334                 :         801 :       ref->u.ar.dimen = 0;
    8335                 :         801 :       ref->next = (*e)->ref;
    8336                 :         801 :       (*e)->ref = ref;
    8337                 :             :     }
    8338                 :        1413 :   return 0;
    8339                 :             : }
    8340                 :             : 
    8341                 :             : 
    8342                 :             : static int
    8343                 :        2990 : resolve_omp_udr_callback2 (gfc_expr **e, int *, void *)
    8344                 :             : {
    8345                 :        2990 :   if ((*e)->expr_type == EXPR_FUNCTION
    8346                 :         360 :       && (*e)->value.function.isym == NULL)
    8347                 :             :     {
    8348                 :         174 :       gfc_symbol *sym = (*e)->symtree->n.sym;
    8349                 :         174 :       if (!sym->attr.intrinsic
    8350                 :         174 :           && sym->attr.if_source == IFSRC_UNKNOWN)
    8351                 :           4 :         gfc_error ("Implicitly declared function %s used in "
    8352                 :             :                    "!$OMP DECLARE REDUCTION at %L", sym->name, &(*e)->where);
    8353                 :             :     }
    8354                 :        2990 :   return 0;
    8355                 :             : }
    8356                 :             : 
    8357                 :             : 
    8358                 :             : static gfc_code *
    8359                 :         797 : resolve_omp_udr_clause (gfc_omp_namelist *n, gfc_namespace *ns,
    8360                 :             :                         gfc_symbol *sym1, gfc_symbol *sym2)
    8361                 :             : {
    8362                 :         797 :   gfc_code *copy;
    8363                 :         797 :   gfc_symbol sym1_copy, sym2_copy;
    8364                 :             : 
    8365                 :         797 :   if (ns->code->op == EXEC_ASSIGN)
    8366                 :             :     {
    8367                 :         625 :       copy = gfc_get_code (EXEC_ASSIGN);
    8368                 :         625 :       copy->expr1 = gfc_copy_expr (ns->code->expr1);
    8369                 :         625 :       copy->expr2 = gfc_copy_expr (ns->code->expr2);
    8370                 :             :     }
    8371                 :             :   else
    8372                 :             :     {
    8373                 :         172 :       copy = gfc_get_code (EXEC_CALL);
    8374                 :         172 :       copy->symtree = ns->code->symtree;
    8375                 :         172 :       copy->ext.actual = gfc_copy_actual_arglist (ns->code->ext.actual);
    8376                 :             :     }
    8377                 :         797 :   copy->loc = ns->code->loc;
    8378                 :         797 :   sym1_copy = *sym1;
    8379                 :         797 :   sym2_copy = *sym2;
    8380                 :         797 :   *sym1 = *n->sym;
    8381                 :         797 :   *sym2 = *n->sym;
    8382                 :         797 :   sym1->name = sym1_copy.name;
    8383                 :         797 :   sym2->name = sym2_copy.name;
    8384                 :         797 :   ns->proc_name = ns->parent->proc_name;
    8385                 :         797 :   if (n->sym->attr.dimension)
    8386                 :             :     {
    8387                 :         348 :       struct resolve_omp_udr_callback_data rcd;
    8388                 :         348 :       rcd.sym1 = sym1;
    8389                 :         348 :       rcd.sym2 = sym2;
    8390                 :         348 :       gfc_code_walker (&copy, gfc_dummy_code_callback,
    8391                 :             :                        resolve_omp_udr_callback, &rcd);
    8392                 :             :     }
    8393                 :         797 :   gfc_resolve_code (copy, gfc_current_ns);
    8394                 :         797 :   if (copy->op == EXEC_CALL && copy->resolved_isym == NULL)
    8395                 :             :     {
    8396                 :         172 :       gfc_symbol *sym = copy->resolved_sym;
    8397                 :         172 :       if (sym
    8398                 :         170 :           && !sym->attr.intrinsic
    8399                 :         170 :           && sym->attr.if_source == IFSRC_UNKNOWN)
    8400                 :           4 :         gfc_error ("Implicitly declared subroutine %s used in "
    8401                 :             :                    "!$OMP DECLARE REDUCTION at %L", sym->name,
    8402                 :             :                    &copy->loc);
    8403                 :             :     }
    8404                 :         797 :   gfc_code_walker (&copy, gfc_dummy_code_callback,
    8405                 :             :                    resolve_omp_udr_callback2, NULL);
    8406                 :         797 :   *sym1 = sym1_copy;
    8407                 :         797 :   *sym2 = sym2_copy;
    8408                 :         797 :   return copy;
    8409                 :             : }
    8410                 :             : 
    8411                 :             : /* Assume that a constant expression in the range 1 (omp_default_mem_alloc)
    8412                 :             :    to 8 (omp_thread_mem_alloc) range, or 200 (ompx_gnu_pinned_mem_alloc) is
    8413                 :             :    fine.  The original symbol name is already lost during matching via
    8414                 :             :    gfc_match_expr.  */
    8415                 :             : static bool
    8416                 :          42 : is_predefined_allocator (gfc_expr *expr)
    8417                 :             : {
    8418                 :          42 :   return (gfc_resolve_expr (expr)
    8419                 :          41 :           && expr->rank == 0
    8420                 :          36 :           && expr->ts.type == BT_INTEGER
    8421                 :          31 :           && expr->ts.kind == gfc_c_intptr_kind
    8422                 :          26 :           && expr->expr_type == EXPR_CONSTANT
    8423                 :          63 :           && ((mpz_sgn (expr->value.integer) > 0
    8424                 :          19 :                && mpz_cmp_si (expr->value.integer,
    8425                 :             :                               GOMP_OMP_PREDEF_ALLOC_MAX) <= 0)
    8426                 :           4 :               || (mpz_cmp_si (expr->value.integer,
    8427                 :             :                               GOMP_OMPX_PREDEF_ALLOC_MIN) >= 0
    8428                 :           1 :                   && mpz_cmp_si (expr->value.integer,
    8429                 :          42 :                                  GOMP_OMPX_PREDEF_ALLOC_MAX) <= 0)));
    8430                 :             : }
    8431                 :             : 
    8432                 :             : /* Resolve declarative ALLOCATE statement. Note: Common block vars only appear
    8433                 :             :    as /block/ not individual, which is ensured during parsing.  */
    8434                 :             : 
    8435                 :             : void
    8436                 :          55 : gfc_resolve_omp_allocate (gfc_namespace *ns, gfc_omp_namelist *list)
    8437                 :             : {
    8438                 :         183 :   for (gfc_omp_namelist *n = list; n; n = n->next)
    8439                 :             :     {
    8440                 :         128 :       if (n->sym->attr.result || n->sym->result == n->sym)
    8441                 :             :         {
    8442                 :           1 :           gfc_error ("Unexpected function-result variable %qs at %L in "
    8443                 :             :                      "declarative !$OMP ALLOCATE", n->sym->name, &n->where);
    8444                 :          31 :           continue;
    8445                 :             :         }
    8446                 :         127 :       if (ns->omp_allocate->sym->attr.proc_pointer)
    8447                 :             :         {
    8448                 :           0 :           gfc_error ("Procedure pointer %qs not supported with !$OMP "
    8449                 :             :                      "ALLOCATE at %L", n->sym->name, &n->where);
    8450                 :           0 :           continue;
    8451                 :             :         }
    8452                 :         127 :       if (n->sym->attr.flavor != FL_VARIABLE)
    8453                 :             :         {
    8454                 :           3 :           gfc_error ("Argument %qs at %L to declarative !$OMP ALLOCATE "
    8455                 :             :                      "directive must be a variable", n->sym->name,
    8456                 :             :                      &n->where);
    8457                 :           3 :           continue;
    8458                 :             :         }
    8459                 :         124 :       if (ns != n->sym->ns || n->sym->attr.use_assoc || n->sym->attr.imported)
    8460                 :             :         {
    8461                 :           8 :           gfc_error ("Argument %qs at %L to declarative !$OMP ALLOCATE shall be"
    8462                 :             :                      " in the same scope as the variable declaration",
    8463                 :             :                      n->sym->name, &n->where);
    8464                 :           8 :           continue;
    8465                 :             :         }
    8466                 :         116 :       if (n->sym->attr.dummy)
    8467                 :             :         {
    8468                 :           3 :           gfc_error ("Unexpected dummy argument %qs as argument at %L to "
    8469                 :             :                      "declarative !$OMP ALLOCATE", n->sym->name, &n->where);
    8470                 :           3 :           continue;
    8471                 :             :         }
    8472                 :         113 :       if (n->sym->attr.codimension)
    8473                 :             :         {
    8474                 :           0 :           gfc_error ("Unexpected coarray argument %qs as argument at %L to "
    8475                 :             :                      "declarative !$OMP ALLOCATE", n->sym->name, &n->where);
    8476                 :           0 :           continue;
    8477                 :             :         }
    8478                 :         113 :       if (n->sym->attr.omp_allocate)
    8479                 :             :         {
    8480                 :           5 :           if (n->sym->attr.in_common)
    8481                 :             :             {
    8482                 :           1 :               gfc_error ("Duplicated common block %</%s/%> in !$OMP ALLOCATE "
    8483                 :           1 :                          "at %L", n->sym->common_head->name, &n->where);
    8484                 :           3 :               while (n->next && n->next->sym
    8485                 :           4 :                      && n->sym->common_head == n->next->sym->common_head)
    8486                 :             :                 n = n->next;
    8487                 :             :             }
    8488                 :             :           else
    8489                 :           4 :             gfc_error ("Duplicated variable %qs in !$OMP ALLOCATE at %L",
    8490                 :             :                        n->sym->name, &n->where);
    8491                 :           5 :           continue;
    8492                 :             :         }
    8493                 :             :       /* For 'equivalence(a,b)', a 'union_type {<type> a,b} equiv.0' is created
    8494                 :             :          with a value expression for 'a' as 'equiv.0.a' (likewise for b); while
    8495                 :             :          this can be handled, EQUIVALENCE is marked as obsolescent since Fortran
    8496                 :             :          2018 and also not widely used.  However, it could be supported,
    8497                 :             :          if needed. */
    8498                 :         108 :       if (n->sym->attr.in_equivalence)
    8499                 :             :         {
    8500                 :           2 :           gfc_error ("Sorry, EQUIVALENCE object %qs not supported with !$OMP "
    8501                 :             :                      "ALLOCATE at %L", n->sym->name, &n->where);
    8502                 :           2 :           continue;
    8503                 :             :         }
    8504                 :             :       /* Similar for Cray pointer/pointee - they could be implemented but as
    8505                 :             :          common vendor extension but nowadays rarely used and requiring
    8506                 :             :          -fcray-pointer, there is no need to support them.  */
    8507                 :         106 :       if (n->sym->attr.cray_pointer || n->sym->attr.cray_pointee)
    8508                 :             :         {
    8509                 :           2 :           gfc_error ("Sorry, Cray pointers and pointees such as %qs are not "
    8510                 :             :                      "supported with !$OMP ALLOCATE at %L",
    8511                 :             :                      n->sym->name, &n->where);
    8512                 :           2 :           continue;
    8513                 :             :         }
    8514                 :         104 :       n->sym->attr.omp_allocate = 1;
    8515                 :         104 :       if ((n->sym->ts.type == BT_CLASS && n->sym->attr.class_ok
    8516                 :           0 :            && CLASS_DATA (n->sym)->attr.allocatable)
    8517                 :         104 :           || (n->sym->ts.type != BT_CLASS && n->sym->attr.allocatable))
    8518                 :           1 :         gfc_error ("Unexpected allocatable variable %qs at %L in declarative "
    8519                 :             :                    "!$OMP ALLOCATE directive", n->sym->name, &n->where);
    8520                 :         103 :       else if ((n->sym->ts.type == BT_CLASS && n->sym->attr.class_ok
    8521                 :           0 :                 && CLASS_DATA (n->sym)->attr.class_pointer)
    8522                 :         103 :                || (n->sym->ts.type != BT_CLASS && n->sym->attr.pointer))
    8523                 :           1 :         gfc_error ("Unexpected pointer variable %qs at %L in declarative "
    8524                 :             :                    "!$OMP ALLOCATE directive", n->sym->name, &n->where);
    8525                 :         104 :       HOST_WIDE_INT alignment = 0;
    8526                 :         110 :       if (n->u.align
    8527                 :         104 :           && (!gfc_resolve_expr (n->u.align)
    8528                 :          27 :               || n->u.align->ts.type != BT_INTEGER
    8529                 :          26 :               || n->u.align->rank != 0
    8530                 :          24 :               || n->u.align->expr_type != EXPR_CONSTANT
    8531                 :          23 :               || gfc_extract_hwi (n->u.align, &alignment)
    8532                 :          23 :               || !pow2p_hwi (alignment)))
    8533                 :             :         {
    8534                 :           6 :           gfc_error ("ALIGN requires a scalar positive constant integer "
    8535                 :             :                      "alignment expression at %L that is a power of two",
    8536                 :           6 :                      &n->u.align->where);
    8537                 :           6 :           while (n->sym->attr.in_common && n->next && n->next->sym
    8538                 :           6 :                  && n->sym->common_head == n->next->sym->common_head)
    8539                 :             :             n = n->next;
    8540                 :           6 :           continue;
    8541                 :             :         }
    8542                 :          98 :       if (n->sym->attr.in_common || n->sym->attr.save || n->sym->ns->save_all
    8543                 :          55 :           || (n->sym->ns->proc_name
    8544                 :          55 :               && (n->sym->ns->proc_name->attr.flavor == FL_PROGRAM
    8545                 :          55 :                   || n->sym->ns->proc_name->attr.flavor == FL_MODULE)))
    8546                 :             :         {
    8547                 :          43 :           bool com = n->sym->attr.in_common;
    8548                 :          43 :           if (!n->u2.allocator)
    8549                 :           1 :             gfc_error ("An ALLOCATOR clause is required as the list item "
    8550                 :             :                        "%<%s%s%s%> at %L has the SAVE attribute", com ? "/" : "",
    8551                 :           0 :                        com ? n->sym->common_head->name : n->sym->name,
    8552                 :             :                        com ? "/" : "", &n->where);
    8553                 :          42 :           else if (!is_predefined_allocator (n->u2.allocator))
    8554                 :          24 :             gfc_error ("Predefined allocator required in ALLOCATOR clause at %L"
    8555                 :             :                        " as the list item %<%s%s%s%> at %L has the SAVE attribute",
    8556                 :          24 :                        &n->u2.allocator->where, com ? "/" : "",
    8557                 :          24 :                        com ? n->sym->common_head->name : n->sym->name,
    8558                 :             :                        com ? "/" : "", &n->where);
    8559                 :          19 :           while (n->sym->attr.in_common && n->next && n->next->sym
    8560                 :          64 :                  && n->sym->common_head == n->next->sym->common_head)
    8561                 :             :             n = n->next;
    8562                 :             :         }
    8563                 :          55 :       else if (n->u2.allocator
    8564                 :          55 :           && (!gfc_resolve_expr (n->u2.allocator)
    8565                 :          20 :               || n->u2.allocator->ts.type != BT_INTEGER
    8566                 :          19 :               || n->u2.allocator->rank != 0
    8567                 :          18 :               || n->u2.allocator->ts.kind != gfc_c_intptr_kind))
    8568                 :           3 :         gfc_error ("Expected integer expression of the "
    8569                 :             :                    "%<omp_allocator_handle_kind%> kind at %L",
    8570                 :           3 :                    &n->u2.allocator->where);
    8571                 :             :     }
    8572                 :          55 : }
    8573                 :             : 
    8574                 :             : /* Resolve ASSUME's and ASSUMES' assumption clauses.  Note that absent/contains
    8575                 :             :    is handled during parse time in omp_verify_merge_absent_contains.   */
    8576                 :             : 
    8577                 :             : void
    8578                 :          28 : gfc_resolve_omp_assumptions (gfc_omp_assumptions *assume)
    8579                 :             : {
    8580                 :          44 :   for (gfc_expr_list *el = assume->holds; el; el = el->next)
    8581                 :          16 :     if (!gfc_resolve_expr (el->expr)
    8582                 :          16 :         || el->expr->ts.type != BT_LOGICAL
    8583                 :          30 :         || el->expr->rank != 0)
    8584                 :           4 :       gfc_error ("HOLDS expression at %L must be a scalar logical expression",
    8585                 :           4 :                  &el->expr->where);
    8586                 :          28 : }
    8587                 :             : 
    8588                 :             : 
    8589                 :             : /* OpenMP directive resolving routines.  */
    8590                 :             : 
    8591                 :             : static void
    8592                 :       31620 : resolve_omp_clauses (gfc_code *code, gfc_omp_clauses *omp_clauses,
    8593                 :             :                      gfc_namespace *ns, bool openacc = false)
    8594                 :             : {
    8595                 :       31620 :   gfc_omp_namelist *n, *last;
    8596                 :       31620 :   gfc_expr_list *el;
    8597                 :       31620 :   int list;
    8598                 :       31620 :   int ifc;
    8599                 :       31620 :   bool if_without_mod = false;
    8600                 :       31620 :   gfc_omp_linear_op linear_op = OMP_LINEAR_DEFAULT;
    8601                 :       31620 :   static const char *clause_names[]
    8602                 :             :     = { "PRIVATE", "FIRSTPRIVATE", "LASTPRIVATE", "COPYPRIVATE", "SHARED",
    8603                 :             :         "COPYIN", "UNIFORM", "AFFINITY", "ALIGNED", "LINEAR", "DEPEND", "MAP",
    8604                 :             :         "TO", "FROM", "INCLUSIVE", "EXCLUSIVE",
    8605                 :             :         "REDUCTION", "REDUCTION" /*inscan*/, "REDUCTION" /*task*/,
    8606                 :             :         "IN_REDUCTION", "TASK_REDUCTION",
    8607                 :             :         "DEVICE_RESIDENT", "LINK", "USE_DEVICE",
    8608                 :             :         "CACHE", "IS_DEVICE_PTR", "USE_DEVICE_PTR", "USE_DEVICE_ADDR",
    8609                 :             :         "NONTEMPORAL", "ALLOCATE", "HAS_DEVICE_ADDR", "ENTER",
    8610                 :             :         "USES_ALLOCATORS", "INIT", "USE", "DESTROY", "INTEROP", "ADJUST_ARGS" };
    8611                 :       31620 :   STATIC_ASSERT (ARRAY_SIZE (clause_names) == OMP_LIST_NUM);
    8612                 :             : 
    8613                 :       31620 :   if (omp_clauses == NULL)
    8614                 :             :     return;
    8615                 :             : 
    8616                 :       31620 :   if (ns == NULL)
    8617                 :       31199 :     ns = gfc_current_ns;
    8618                 :             : 
    8619                 :       31620 :   if (omp_clauses->orderedc && omp_clauses->orderedc < omp_clauses->collapse)
    8620                 :           0 :     gfc_error ("ORDERED clause parameter is less than COLLAPSE at %L",
    8621                 :             :                &code->loc);
    8622                 :       31620 :   if (omp_clauses->order_concurrent && omp_clauses->ordered)
    8623                 :           4 :     gfc_error ("ORDER clause must not be used together with ORDERED at %L",
    8624                 :             :                &code->loc);
    8625                 :       31620 :   if (omp_clauses->if_expr)
    8626                 :             :     {
    8627                 :        1175 :       gfc_expr *expr = omp_clauses->if_expr;
    8628                 :        1175 :       if (!gfc_resolve_expr (expr)
    8629                 :        1175 :           || expr->ts.type != BT_LOGICAL || expr->rank != 0)
    8630                 :          16 :         gfc_error ("IF clause at %L requires a scalar LOGICAL expression",
    8631                 :             :                    &expr->where);
    8632                 :             :       if_without_mod = true;
    8633                 :             :     }
    8634                 :      347820 :   for (ifc = 0; ifc < OMP_IF_LAST; ifc++)
    8635                 :      316200 :     if (omp_clauses->if_exprs[ifc])
    8636                 :             :       {
    8637                 :         137 :         gfc_expr *expr = omp_clauses->if_exprs[ifc];
    8638                 :         137 :         bool ok = true;
    8639                 :         137 :         if (!gfc_resolve_expr (expr)
    8640                 :         137 :             || expr->ts.type != BT_LOGICAL || expr->rank != 0)
    8641                 :           0 :           gfc_error ("IF clause at %L requires a scalar LOGICAL expression",
    8642                 :             :                      &expr->where);
    8643                 :         137 :         else if (if_without_mod)
    8644                 :             :           {
    8645                 :           1 :             gfc_error ("IF clause without modifier at %L used together with "
    8646                 :             :                        "IF clauses with modifiers",
    8647                 :           1 :                        &omp_clauses->if_expr->where);
    8648                 :           1 :             if_without_mod = false;
    8649                 :             :           }
    8650                 :             :         else
    8651                 :         136 :           switch (code->op)
    8652                 :             :             {
    8653                 :          13 :             case EXEC_OMP_CANCEL:
    8654                 :          13 :               ok = ifc == OMP_IF_CANCEL;
    8655                 :          13 :               break;
    8656                 :             : 
    8657                 :          16 :             case EXEC_OMP_PARALLEL:
    8658                 :          16 :             case EXEC_OMP_PARALLEL_DO:
    8659                 :          16 :             case EXEC_OMP_PARALLEL_LOOP:
    8660                 :          16 :             case EXEC_OMP_PARALLEL_MASKED:
    8661                 :          16 :             case EXEC_OMP_PARALLEL_MASTER:
    8662                 :          16 :             case EXEC_OMP_PARALLEL_SECTIONS:
    8663                 :          16 :             case EXEC_OMP_PARALLEL_WORKSHARE:
    8664                 :          16 :             case EXEC_OMP_DISTRIBUTE_PARALLEL_DO:
    8665                 :          16 :             case EXEC_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO:
    8666                 :          16 :               ok = ifc == OMP_IF_PARALLEL;
    8667                 :          16 :               break;
    8668                 :             : 
    8669                 :          28 :             case EXEC_OMP_PARALLEL_DO_SIMD:
    8670                 :          28 :             case EXEC_OMP_DISTRIBUTE_PARALLEL_DO_SIMD:
    8671                 :          28 :             case EXEC_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD:
    8672                 :          28 :               ok = ifc == OMP_IF_PARALLEL || ifc == OMP_IF_SIMD;
    8673                 :          28 :               break;
    8674                 :             : 
    8675                 :           8 :             case EXEC_OMP_PARALLEL_MASKED_TASKLOOP:
    8676                 :           8 :             case EXEC_OMP_PARALLEL_MASTER_TASKLOOP:
    8677                 :           8 :               ok = ifc == OMP_IF_PARALLEL || ifc == OMP_IF_TASKLOOP;
    8678                 :           8 :               break;
    8679                 :             : 
    8680                 :          12 :             case EXEC_OMP_PARALLEL_MASKED_TASKLOOP_SIMD:
    8681                 :          12 :             case EXEC_OMP_PARALLEL_MASTER_TASKLOOP_SIMD:
    8682                 :          12 :               ok = (ifc == OMP_IF_PARALLEL
    8683                 :          12 :                     || ifc == OMP_IF_TASKLOOP
    8684                 :             :                     || ifc == OMP_IF_SIMD);
    8685                 :             :               break;
    8686                 :             : 
    8687                 :           0 :             case EXEC_OMP_SIMD:
    8688                 :           0 :             case EXEC_OMP_DO_SIMD:
    8689                 :           0 :             case EXEC_OMP_DISTRIBUTE_SIMD:
    8690                 :           0 :             case EXEC_OMP_TEAMS_DISTRIBUTE_SIMD:
    8691                 :           0 :               ok = ifc == OMP_IF_SIMD;
    8692                 :           0 :               break;
    8693                 :             : 
    8694                 :           1 :             case EXEC_OMP_TASK:
    8695                 :           1 :               ok = ifc == OMP_IF_TASK;
    8696                 :           1 :               break;
    8697                 :             : 
    8698                 :           5 :             case EXEC_OMP_TASKLOOP:
    8699                 :           5 :             case EXEC_OMP_MASKED_TASKLOOP:
    8700                 :           5 :             case EXEC_OMP_MASTER_TASKLOOP:
    8701                 :           5 :               ok = ifc == OMP_IF_TASKLOOP;
    8702                 :           5 :               break;
    8703                 :             : 
    8704                 :          20 :             case EXEC_OMP_TASKLOOP_SIMD:
    8705                 :          20 :             case EXEC_OMP_MASKED_TASKLOOP_SIMD:
    8706                 :          20 :             case EXEC_OMP_MASTER_TASKLOOP_SIMD:
    8707                 :          20 :               ok = ifc == OMP_IF_TASKLOOP || ifc == OMP_IF_SIMD;
    8708                 :          20 :               break;
    8709                 :             : 
    8710                 :           5 :             case EXEC_OMP_TARGET:
    8711                 :           5 :             case EXEC_OMP_TARGET_TEAMS:
    8712                 :           5 :             case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE:
    8713                 :           5 :             case EXEC_OMP_TARGET_TEAMS_LOOP:
    8714                 :           5 :               ok = ifc == OMP_IF_TARGET;
    8715                 :           5 :               break;
    8716                 :             : 
    8717                 :           4 :             case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_SIMD:
    8718                 :           4 :             case EXEC_OMP_TARGET_SIMD:
    8719                 :           4 :               ok = ifc == OMP_IF_TARGET || ifc == OMP_IF_SIMD;
    8720                 :           4 :               break;
    8721                 :             : 
    8722                 :           1 :             case EXEC_OMP_TARGET_DATA:
    8723                 :           1 :               ok = ifc == OMP_IF_TARGET_DATA;
    8724                 :           1 :               break;
    8725                 :             : 
    8726                 :           1 :             case EXEC_OMP_TARGET_UPDATE:
    8727                 :           1 :               ok = ifc == OMP_IF_TARGET_UPDATE;
    8728                 :           1 :               break;
    8729                 :             : 
    8730                 :           1 :             case EXEC_OMP_TARGET_ENTER_DATA:
    8731                 :           1 :               ok = ifc == OMP_IF_TARGET_ENTER_DATA;
    8732                 :           1 :               break;
    8733                 :             : 
    8734                 :           1 :             case EXEC_OMP_TARGET_EXIT_DATA:
    8735                 :           1 :               ok = ifc == OMP_IF_TARGET_EXIT_DATA;
    8736                 :           1 :               break;
    8737                 :             : 
    8738                 :          10 :             case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO:
    8739                 :          10 :             case EXEC_OMP_TARGET_PARALLEL:
    8740                 :          10 :             case EXEC_OMP_TARGET_PARALLEL_DO:
    8741                 :          10 :             case EXEC_OMP_TARGET_PARALLEL_LOOP:
    8742                 :          10 :               ok = ifc == OMP_IF_TARGET || ifc == OMP_IF_PARALLEL;
    8743                 :          10 :               break;
    8744                 :             : 
    8745                 :          10 :             case EXEC_OMP_TARGET_PARALLEL_DO_SIMD:
    8746                 :          10 :             case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD:
    8747                 :          10 :               ok = (ifc == OMP_IF_TARGET
    8748                 :          10 :                     || ifc == OMP_IF_PARALLEL
    8749                 :             :                     || ifc == OMP_IF_SIMD);
    8750                 :             :               break;
    8751                 :             : 
    8752                 :             :             default:
    8753                 :             :               ok = false;
    8754                 :             :               break;
    8755                 :             :           }
    8756                 :         115 :         if (!ok)
    8757                 :             :           {
    8758                 :           2 :             static const char *ifs[] = {
    8759                 :             :               "CANCEL",
    8760                 :             :               "PARALLEL",
    8761                 :             :               "SIMD",
    8762                 :             :               "TASK",
    8763                 :             :               "TASKLOOP",
    8764                 :             :               "TARGET",
    8765                 :             :               "TARGET DATA",
    8766                 :             :               "TARGET UPDATE",
    8767                 :             :               "TARGET ENTER DATA",
    8768                 :             :               "TARGET EXIT DATA"
    8769                 :             :             };
    8770                 :           2 :             gfc_error ("IF clause modifier %s at %L not appropriate for "
    8771                 :             :                        "the current OpenMP construct", ifs[ifc], &expr->where);
    8772                 :             :           }
    8773                 :             :       }
    8774                 :             : 
    8775                 :       31620 :   if (omp_clauses->self_expr)
    8776                 :             :     {
    8777                 :         177 :       gfc_expr *expr = omp_clauses->self_expr;
    8778                 :         177 :       if (!gfc_resolve_expr (expr)
    8779                 :         177 :           || expr->ts.type != BT_LOGICAL || expr->rank != 0)
    8780                 :           6 :         gfc_error ("SELF clause at %L requires a scalar LOGICAL expression",
    8781                 :             :                    &expr->where);
    8782                 :             :     }
    8783                 :             : 
    8784                 :       31620 :   if (omp_clauses->final_expr)
    8785                 :             :     {
    8786                 :          64 :       gfc_expr *expr = omp_clauses->final_expr;
    8787                 :          64 :       if (!gfc_resolve_expr (expr)
    8788                 :          64 :           || expr->ts.type != BT_LOGICAL || expr->rank != 0)
    8789                 :           0 :         gfc_error ("FINAL clause at %L requires a scalar LOGICAL expression",
    8790                 :             :                    &expr->where);
    8791                 :             :     }
    8792                 :       31620 :   if (omp_clauses->novariants)
    8793                 :             :     {
    8794                 :           9 :       gfc_expr *expr = omp_clauses->novariants;
    8795                 :          18 :       if (!gfc_resolve_expr (expr) || expr->ts.type != BT_LOGICAL
    8796                 :          17 :           || expr->rank != 0)
    8797                 :           1 :         gfc_error (
    8798                 :             :           "NOVARIANTS clause at %L requires a scalar LOGICAL expression",
    8799                 :             :           &expr->where);
    8800                 :       31620 :       if_without_mod = true;
    8801                 :             :     }
    8802                 :       31620 :   if (omp_clauses->nocontext)
    8803                 :             :     {
    8804                 :          12 :       gfc_expr *expr = omp_clauses->nocontext;
    8805                 :          24 :       if (!gfc_resolve_expr (expr) || expr->ts.type != BT_LOGICAL
    8806                 :          23 :           || expr->rank != 0)
    8807                 :           1 :         gfc_error (
    8808                 :             :           "NOCONTEXT clause at %L requires a scalar LOGICAL expression",
    8809                 :             :           &expr->where);
    8810                 :       31620 :       if_without_mod = true;
    8811                 :             :     }
    8812                 :       31620 :   if (omp_clauses->num_threads)
    8813                 :         950 :     resolve_positive_int_expr (omp_clauses->num_threads, "NUM_THREADS");
    8814                 :       31620 :   if (omp_clauses->chunk_size)
    8815                 :             :     {
    8816                 :         510 :       gfc_expr *expr = omp_clauses->chunk_size;
    8817                 :         510 :       if (!gfc_resolve_expr (expr)
    8818                 :         510 :           || expr->ts.type != BT_INTEGER || expr->rank != 0)
    8819                 :           0 :         gfc_error ("SCHEDULE clause's chunk_size at %L requires "
    8820                 :             :                    "a scalar INTEGER expression", &expr->where);
    8821                 :         510 :       else if (expr->expr_type == EXPR_CONSTANT
    8822                 :             :                && expr->ts.type == BT_INTEGER
    8823                 :         485 :                && mpz_sgn (expr->value.integer) <= 0)
    8824                 :           2 :         gfc_warning (OPT_Wopenmp, "INTEGER expression of SCHEDULE clause's "
    8825                 :             :                      "chunk_size at %L must be positive", &expr->where);
    8826                 :             :     }
    8827                 :       31620 :   if (omp_clauses->sched_kind != OMP_SCHED_NONE
    8828                 :         891 :       && omp_clauses->sched_nonmonotonic)
    8829                 :             :     {
    8830                 :          34 :       if (omp_clauses->sched_monotonic)
    8831                 :           2 :         gfc_error ("Both MONOTONIC and NONMONOTONIC schedule modifiers "
    8832                 :             :                    "specified at %L", &code->loc);
    8833                 :          32 :       else if (omp_clauses->ordered)
    8834                 :           4 :         gfc_error ("NONMONOTONIC schedule modifier specified with ORDERED "
    8835                 :             :                    "clause at %L", &code->loc);
    8836                 :             :     }
    8837                 :             : 
    8838                 :       31620 :   if (omp_clauses->depobj
    8839                 :       31620 :       && (!gfc_resolve_expr (omp_clauses->depobj)
    8840                 :         113 :           || omp_clauses->depobj->ts.type != BT_INTEGER
    8841                 :         112 :           || omp_clauses->depobj->ts.kind != 2 * gfc_index_integer_kind
    8842                 :         111 :           || omp_clauses->depobj->rank != 0))
    8843                 :           4 :     gfc_error ("DEPOBJ in DEPOBJ construct at %L shall be a scalar integer "
    8844                 :           4 :                "of OMP_DEPEND_KIND kind", &omp_clauses->depobj->where);
    8845                 :             : 
    8846                 :             :   /* Check that no symbol appears on multiple clauses, except that
    8847                 :             :      a symbol can appear on both firstprivate and lastprivate.  */
    8848                 :     1233180 :   for (list = 0; list < OMP_LIST_NUM; list++)
    8849                 :     1245659 :     for (n = omp_clauses->lists[list]; n; n = n->next)
    8850                 :             :       {
    8851                 :       44099 :         if (!n->sym)  /* omp_all_memory.  */
    8852                 :          47 :           continue;
    8853                 :       44052 :         n->sym->mark = 0;
    8854                 :       44052 :         n->sym->comp_mark = 0;
    8855                 :       44052 :         n->sym->data_mark = 0;
    8856                 :       44052 :         n->sym->dev_mark = 0;
    8857                 :       44052 :         n->sym->gen_mark = 0;
    8858                 :       44052 :         n->sym->reduc_mark = 0;
    8859                 :       44052 :         if (n->sym->attr.flavor == FL_VARIABLE
    8860                 :         253 :             || n->sym->attr.proc_pointer
    8861                 :         212 :             || (!code && (!n->sym->attr.dummy || n->sym->ns != ns)))
    8862                 :             :           {
    8863                 :       43840 :             if (!code && (!n->sym->attr.dummy || n->sym->ns != ns))
    8864                 :           0 :               gfc_error ("Variable %qs is not a dummy argument at %L",
    8865                 :             :                          n->sym->name, &n->where);
    8866                 :       43840 :             continue;
    8867                 :             :           }
    8868                 :         212 :         if (n->sym->attr.flavor == FL_PROCEDURE
    8869                 :         147 :             && n->sym->result == n->sym
    8870                 :         132 :             && n->sym->attr.function)
    8871                 :             :           {
    8872                 :         132 :             if (ns->proc_name == n->sym
    8873                 :          44 :                 || (ns->parent && ns->parent->proc_name == n->sym))
    8874                 :          95 :               continue;
    8875                 :          37 :             if (ns->proc_name->attr.entry_master)
    8876                 :             :               {
    8877                 :          32 :                 gfc_entry_list *el = ns->entries;
    8878                 :          51 :                 for (; el; el = el->next)
    8879                 :          51 :                   if (el->sym == n->sym)
    8880                 :             :                     break;
    8881                 :          32 :                 if (el)
    8882                 :          32 :                   continue;
    8883                 :             :               }
    8884                 :           5 :             if (ns->parent
    8885                 :           3 :                 && ns->parent->proc_name->attr.entry_master)
    8886                 :             :               {
    8887                 :           2 :                 gfc_entry_list *el = ns->parent->entries;
    8888                 :           3 :                 for (; el; el = el->next)
    8889                 :           3 :                   if (el->sym == n->sym)
    8890                 :             :                     break;
    8891                 :           2 :                 if (el)
    8892                 :           2 :                   continue;
    8893                 :             :               }
    8894                 :             :           }
    8895                 :          83 :         if (list == OMP_LIST_MAP
    8896                 :          13 :             && n->sym->attr.flavor == FL_PARAMETER)
    8897                 :             :           {
    8898                 :           7 :             if (openacc)
    8899                 :           5 :               gfc_error ("Object %qs is not a variable at %L; parameters"
    8900                 :             :                          " cannot be and need not be copied", n->sym->name,
    8901                 :             :                          &n->where);
    8902                 :             :             else
    8903                 :           2 :               gfc_error ("Object %qs is not a variable at %L; parameters"
    8904                 :             :                          " cannot be and need not be mapped", n->sym->name,
    8905                 :             :                          &n->where);
    8906                 :             :           }
    8907                 :          76 :         else if (list != OMP_LIST_USES_ALLOCATORS)
    8908                 :          37 :           gfc_error ("Object %qs is not a variable at %L", n->sym->name,
    8909                 :             :                      &n->where);
    8910                 :             :       }
    8911                 :       31620 :   if (omp_clauses->lists[OMP_LIST_REDUCTION_INSCAN])
    8912                 :             :     {
    8913                 :          69 :       locus *loc = &omp_clauses->lists[OMP_LIST_REDUCTION_INSCAN]->where;
    8914                 :          69 :       if (code->op != EXEC_OMP_DO
    8915                 :             :           && code->op != EXEC_OMP_SIMD
    8916                 :             :           && code->op != EXEC_OMP_DO_SIMD
    8917                 :             :           && code->op != EXEC_OMP_PARALLEL_DO
    8918                 :             :           && code->op != EXEC_OMP_PARALLEL_DO_SIMD)
    8919                 :          23 :         gfc_error ("%<inscan%> REDUCTION clause on construct other than DO, "
    8920                 :             :                    "SIMD, DO SIMD, PARALLEL DO, PARALLEL DO SIMD at %L",
    8921                 :             :                    loc);
    8922                 :          69 :       if (omp_clauses->ordered)
    8923                 :           2 :         gfc_error ("ORDERED clause specified together with %<inscan%> "
    8924                 :             :                    "REDUCTION clause at %L", loc);
    8925                 :          69 :       if (omp_clauses->sched_kind != OMP_SCHED_NONE)
    8926                 :           3 :         gfc_error ("SCHEDULE clause specified together with %<inscan%> "
    8927                 :             :                    "REDUCTION clause at %L", loc);
    8928                 :             :     }
    8929                 :             : 
    8930                 :     1233180 :   for (list = 0; list < OMP_LIST_NUM; list++)
    8931                 :     1201560 :     if (list != OMP_LIST_FIRSTPRIVATE
    8932                 :     1201560 :         && list != OMP_LIST_LASTPRIVATE
    8933                 :     1201560 :         && list != OMP_LIST_ALIGNED
    8934                 :     1106700 :         && list != OMP_LIST_DEPEND
    8935                 :     1106700 :         && list != OMP_LIST_FROM
    8936                 :     1043460 :         && list != OMP_LIST_TO
    8937                 :     1043460 :         && list != OMP_LIST_INTEROP
    8938                 :      980220 :         && (list != OMP_LIST_REDUCTION || !openacc)
    8939                 :      967675 :         && list != OMP_LIST_ALLOCATE)
    8940                 :      969476 :       for (n = omp_clauses->lists[list]; n; n = n->next)
    8941                 :             :         {
    8942                 :       33421 :           bool component_ref_p = false;
    8943                 :             : 
    8944                 :             :           /* Allow multiple components of the same (e.g. derived-type)
    8945                 :             :              variable here.  Duplicate components are detected elsewhere.  */
    8946                 :       33421 :           if (n->expr && n->expr->expr_type == EXPR_VARIABLE)
    8947                 :       13429 :             for (gfc_ref *ref = n->expr->ref; ref; ref = ref->next)
    8948                 :        7832 :               if (ref->type == REF_COMPONENT)
    8949                 :        2328 :                 component_ref_p = true;
    8950                 :       33421 :           if ((list == OMP_LIST_IS_DEVICE_PTR
    8951                 :       33421 :                || list == OMP_LIST_HAS_DEVICE_ADDR)
    8952                 :         298 :               && !component_ref_p)
    8953                 :             :             {
    8954                 :         298 :               if (n->sym->gen_mark
    8955                 :             :                   || n->sym->dev_mark
    8956                 :             :                   || n->sym->reduc_mark
    8957                 :         298 :                   || n->sym->mark)
    8958                 :           5 :                 gfc_error ("Symbol %qs present on multiple clauses at %L",
    8959                 :             :                            n->sym->name, &n->where);
    8960                 :             :               else
    8961                 :         293 :                 n->sym->dev_mark = 1;
    8962                 :             :             }
    8963                 :       33123 :           else if ((list == OMP_LIST_USE_DEVICE_PTR
    8964                 :       33123 :                     || list == OMP_LIST_USE_DEVICE_ADDR
    8965                 :       33123 :                     || list == OMP_LIST_PRIVATE
    8966                 :             :                     || list == OMP_LIST_SHARED)
    8967                 :       12774 :                    && !component_ref_p)
    8968                 :             :             {
    8969                 :       12774 :               if (n->sym->gen_mark || n->sym->dev_mark || n->sym->reduc_mark)
    8970                 :          13 :                 gfc_error ("Symbol %qs present on multiple clauses at %L",
    8971                 :             :                            n->sym->name, &n->where);
    8972                 :             :               else
    8973                 :             :                 {
    8974                 :       12761 :                   n->sym->gen_mark = 1;
    8975                 :             :                   /* Set both generic and device bits if we have
    8976                 :             :                      use_device_*(x) or shared(x).  This allows us to diagnose
    8977                 :             :                      "map(x) private(x)" below.  */
    8978                 :       12761 :                   if (list != OMP_LIST_PRIVATE)
    8979                 :        3438 :                     n->sym->dev_mark = 1;
    8980                 :             :                 }
    8981                 :             :             }
    8982                 :       20349 :           else if ((list == OMP_LIST_REDUCTION
    8983                 :       20349 :                     || list == OMP_LIST_REDUCTION_TASK
    8984                 :       17898 :                     || list == OMP_LIST_REDUCTION_INSCAN
    8985                 :       17898 :                     || list == OMP_LIST_IN_REDUCTION
    8986                 :       17685 :                     || list == OMP_LIST_TASK_REDUCTION)
    8987                 :        2664 :                    && !component_ref_p)
    8988                 :             :             {
    8989                 :             :               /* Attempts to mix reduction types are diagnosed below.  */
    8990                 :        2664 :               if (n->sym->gen_mark || n->sym->dev_mark)
    8991                 :           2 :                 gfc_error ("Symbol %qs present on multiple clauses at %L",
    8992                 :             :                            n->sym->name, &n->where);
    8993                 :        2664 :               n->sym->reduc_mark = 1;
    8994                 :             :             }
    8995                 :       17685 :           else if ((!component_ref_p && n->sym->comp_mark)
    8996                 :        2049 :                    || (component_ref_p && n->sym->mark))
    8997                 :             :             {
    8998                 :          28 :               if (openacc)
    8999                 :           3 :                 gfc_error ("Symbol %qs has mixed component and non-component "
    9000                 :           3 :                            "accesses at %L", n->sym->name, &n->where);
    9001                 :             :             }
    9002                 :       17657 :           else if (n->sym->mark)
    9003                 :          88 :             gfc_error ("Symbol %qs present on multiple clauses at %L",
    9004                 :             :                        n->sym->name, &n->where);
    9005                 :             :           else
    9006                 :             :             {
    9007                 :       17569 :               if (component_ref_p)
    9008                 :        2022 :                 n->sym->comp_mark = 1;
    9009                 :             :               else
    9010                 :       15547 :                 n->sym->mark = 1;
    9011                 :             :             }
    9012                 :             :         }
    9013                 :             : 
    9014                 :       31620 :   if (code
    9015                 :       31402 :       && code->op == EXEC_OMP_INTEROP
    9016                 :          63 :       && omp_clauses->lists[OMP_LIST_DEPEND])
    9017                 :             :     {
    9018                 :          12 :       if (!omp_clauses->lists[OMP_LIST_INIT]
    9019                 :           5 :           && !omp_clauses->lists[OMP_LIST_USE]
    9020                 :           1 :           && !omp_clauses->lists[OMP_LIST_DESTROY])
    9021                 :             :         {
    9022                 :           1 :           gfc_error ("DEPEND clause at %L requires action clause with "
    9023                 :             :                      "%<targetsync%> interop-type",
    9024                 :             :                      &omp_clauses->lists[OMP_LIST_DEPEND]->where);
    9025                 :             :         }
    9026                 :          22 :       for (n = omp_clauses->lists[OMP_LIST_INIT]; n; n = n->next)
    9027                 :          12 :         if (!n->u.init.targetsync)
    9028                 :             :           {
    9029                 :           2 :             gfc_error ("DEPEND clause at %L requires %<targetsync%> "
    9030                 :             :                        "interop-type, lacking it for %qs at %L",
    9031                 :           2 :                        &omp_clauses->lists[OMP_LIST_DEPEND]->where,
    9032                 :           2 :                        n->sym->name, &n->where);
    9033                 :           2 :             break;
    9034                 :             :           }
    9035                 :             :     }
    9036                 :       31402 :   if (code && (code->op == EXEC_OMP_INTEROP || code->op == EXEC_OMP_DISPATCH))
    9037                 :        1085 :     for (list = OMP_LIST_INIT; list <= OMP_LIST_INTEROP; list++)
    9038                 :        1123 :       for (n = omp_clauses->lists[list]; n; n = n->next)
    9039                 :             :         {
    9040                 :         255 :           if (n->sym->ts.type != BT_INTEGER
    9041                 :         252 :               || n->sym->ts.kind != gfc_index_integer_kind
    9042                 :         248 :               || n->sym->attr.dimension
    9043                 :         243 :               || n->sym->attr.flavor != FL_VARIABLE)
    9044                 :          16 :             gfc_error ("%qs at %L in %qs clause must be a scalar integer "
    9045                 :             :                        "variable of %<omp_interop_kind%> kind", n->sym->name,
    9046                 :             :                        &n->where, clause_names[list]);
    9047                 :         255 :           if (list != OMP_LIST_USE && list != OMP_LIST_INTEROP
    9048                 :         109 :               && n->sym->attr.intent == INTENT_IN)
    9049                 :           2 :             gfc_error ("%qs at %L in %qs clause must be definable",
    9050                 :             :                        n->sym->name, &n->where, clause_names[list]);
    9051                 :             :         }
    9052                 :             : 
    9053                 :             :   /* Detect specifically the case where we have "map(x) private(x)" and raise
    9054                 :             :      an error.  If we have "...simd" combined directives though, the "private"
    9055                 :             :      applies to the simd part, so this is permitted though.  */
    9056                 :       40951 :   for (n = omp_clauses->lists[OMP_LIST_PRIVATE]; n; n = n->next)
    9057                 :        9331 :     if (n->sym->mark
    9058                 :             :         && n->sym->gen_mark
    9059                 :             :         && !n->sym->dev_mark
    9060                 :        9331 :         && !n->sym->reduc_mark
    9061                 :           5 :         && code->op != EXEC_OMP_TARGET_SIMD
    9062                 :             :         && code->op != EXEC_OMP_TARGET_PARALLEL_DO_SIMD
    9063                 :             :         && code->op != EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_SIMD
    9064                 :             :         && code->op != EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD)
    9065                 :           1 :       gfc_error ("Symbol %qs present on multiple clauses at %L",
    9066                 :             :                  n->sym->name, &n->where);
    9067                 :             : 
    9068                 :             :   gcc_assert (OMP_LIST_LASTPRIVATE == OMP_LIST_FIRSTPRIVATE + 1);
    9069                 :       94860 :   for (list = OMP_LIST_FIRSTPRIVATE; list <= OMP_LIST_LASTPRIVATE; list++)
    9070                 :       67315 :     for (n = omp_clauses->lists[list]; n; n = n->next)
    9071                 :        4075 :       if (n->sym->data_mark || n->sym->gen_mark || n->sym->dev_mark)
    9072                 :             :         {
    9073                 :           9 :           gfc_error ("Symbol %qs present on multiple clauses at %L",
    9074                 :             :                      n->sym->name, &n->where);
    9075                 :           9 :           n->sym->data_mark = n->sym->gen_mark = n->sym->dev_mark = 0;
    9076                 :             :         }
    9077                 :        4066 :       else if (n->sym->mark
    9078                 :          16 :                && code->op != EXEC_OMP_TARGET_TEAMS
    9079                 :             :                && code->op != EXEC_OMP_TARGET_TEAMS_DISTRIBUTE
    9080                 :             :                && code->op != EXEC_OMP_TARGET_TEAMS_LOOP
    9081                 :             :                && code->op != EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_SIMD
    9082                 :             :                && code->op != EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO
    9083                 :             :                && code->op != EXEC_OMP_TARGET_PARALLEL
    9084                 :             :                && code->op != EXEC_OMP_TARGET_PARALLEL_DO
    9085                 :             :                && code->op != EXEC_OMP_TARGET_PARALLEL_LOOP
    9086                 :             :                && code->op != EXEC_OMP_TARGET_PARALLEL_DO_SIMD
    9087                 :             :                && code->op != EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD)
    9088                 :           5 :         gfc_error ("Symbol %qs present on both data and map clauses "
    9089                 :             :                    "at %L", n->sym->name, &n->where);
    9090                 :             : 
    9091                 :       33389 :   for (n = omp_clauses->lists[OMP_LIST_FIRSTPRIVATE]; n; n = n->next)
    9092                 :             :     {
    9093                 :        1769 :       if (n->sym->data_mark || n->sym->gen_mark || n->sym->dev_mark)
    9094                 :           7 :         gfc_error ("Symbol %qs present on multiple clauses at %L",
    9095                 :             :                    n->sym->name, &n->where);
    9096                 :             :       else
    9097                 :        1762 :         n->sym->data_mark = 1;
    9098                 :             :     }
    9099                 :       33926 :   for (n = omp_clauses->lists[OMP_LIST_LASTPRIVATE]; n; n = n->next)
    9100                 :        2306 :     n->sym->data_mark = 0;
    9101                 :             : 
    9102                 :       33926 :   for (n = omp_clauses->lists[OMP_LIST_LASTPRIVATE]; n; n = n->next)
    9103                 :             :     {
    9104                 :        2306 :       if (n->sym->data_mark || n->sym->gen_mark || n->sym->dev_mark)
    9105                 :           0 :         gfc_error ("Symbol %qs present on multiple clauses at %L",
    9106                 :             :                    n->sym->name, &n->where);
    9107                 :             :       else
    9108                 :        2306 :         n->sym->data_mark = 1;
    9109                 :             :     }
    9110                 :             : 
    9111                 :       31770 :   for (n = omp_clauses->lists[OMP_LIST_ALIGNED]; n; n = n->next)
    9112                 :         150 :     n->sym->mark = 0;
    9113                 :             : 
    9114                 :       31770 :   for (n = omp_clauses->lists[OMP_LIST_ALIGNED]; n; n = n->next)
    9115                 :             :     {
    9116                 :         150 :       if (n->sym->mark)
    9117                 :           0 :         gfc_error ("Symbol %qs present on multiple clauses at %L",
    9118                 :             :                    n->sym->name, &n->where);
    9119                 :             :       else
    9120                 :         150 :         n->sym->mark = 1;
    9121                 :             :     }
    9122                 :             : 
    9123                 :       31620 :   if (omp_clauses->lists[OMP_LIST_ALLOCATE])
    9124                 :             :     {
    9125                 :         690 :       for (n = omp_clauses->lists[OMP_LIST_ALLOCATE]; n; n = n->next)
    9126                 :             :         {
    9127                 :         459 :           if (n->u2.allocator
    9128                 :         459 :               && (!gfc_resolve_expr (n->u2.allocator)
    9129                 :         235 :                   || n->u2.allocator->ts.type != BT_INTEGER
    9130                 :         233 :                   || n->u2.allocator->rank != 0
    9131                 :         232 :                   || n->u2.allocator->ts.kind != gfc_c_intptr_kind))
    9132                 :             :             {
    9133                 :           8 :               gfc_error ("Expected integer expression of the "
    9134                 :             :                          "%<omp_allocator_handle_kind%> kind at %L",
    9135                 :           8 :                          &n->u2.allocator->where);
    9136                 :          28 :               break;
    9137                 :             :             }
    9138                 :         451 :           if (!n->u.align)
    9139                 :         393 :             continue;
    9140                 :          58 :           HOST_WIDE_INT alignment = 0;
    9141                 :          58 :           if (!gfc_resolve_expr (n->u.align)
    9142                 :          58 :               || n->u.align->ts.type != BT_INTEGER
    9143                 :          55 :               || n->u.align->rank != 0
    9144                 :          52 :               || n->u.align->expr_type != EXPR_CONSTANT
    9145                 :          49 :               || gfc_extract_hwi (n->u.align, &alignment)
    9146                 :          49 :               || alignment <= 0
    9147                 :         107 :               || !pow2p_hwi (alignment))
    9148                 :             :             {
    9149                 :          12 :               gfc_error ("ALIGN requires a scalar positive constant integer "
    9150                 :             :                          "alignment expression at %L that is a power of two",
    9151                 :          12 :                          &n->u.align->where);
    9152                 :          12 :               break;
    9153                 :             :             }
    9154                 :             :         }
    9155                 :             : 
    9156                 :             :       /* Check for 2 things here.
    9157                 :             :          1.  There is no duplication of variable in allocate clause.
    9158                 :             :          2.  Variable in allocate clause are also present in some
    9159                 :             :              privatization clase (non-composite case).  */
    9160                 :         710 :       for (n = omp_clauses->lists[OMP_LIST_ALLOCATE]; n; n = n->next)
    9161                 :         459 :         if (n->sym)
    9162                 :         433 :           n->sym->mark = 0;
    9163                 :             : 
    9164                 :             :       gfc_omp_namelist *prev = NULL;
    9165                 :         710 :       for (n = omp_clauses->lists[OMP_LIST_ALLOCATE]; n; )
    9166                 :             :         {
    9167                 :         459 :           if (n->sym == NULL)
    9168                 :             :             {
    9169                 :          26 :               n = n->next;
    9170                 :          26 :               continue;
    9171                 :             :             }
    9172                 :         433 :           if (n->sym->mark == 1)
    9173                 :             :             {
    9174                 :           3 :               gfc_warning (OPT_Wopenmp, "%qs appears more than once in "
    9175                 :             :                            "%<allocate%> at %L" , n->sym->name, &n->where);
    9176                 :             :               /* We have already seen this variable so it is a duplicate.
    9177                 :             :                  Remove it.  */
    9178                 :           3 :               if (prev != NULL && prev->next == n)
    9179                 :             :                 {
    9180                 :           3 :                   prev->next = n->next;
    9181                 :           3 :                   n->next = NULL;
    9182                 :           3 :                   gfc_free_omp_namelist (n, false, true, false, false);
    9183                 :           3 :                   n = prev->next;
    9184                 :             :                 }
    9185                 :           3 :               continue;
    9186                 :             :             }
    9187                 :         430 :           n->sym->mark = 1;
    9188                 :         430 :           prev = n;
    9189                 :         430 :           n = n->next;
    9190                 :             :         }
    9191                 :             : 
    9192                 :             :       /* Non-composite constructs.  */
    9193                 :         251 :       if (code && code->op < EXEC_OMP_DO_SIMD)
    9194                 :             :         {
    9195                 :        4524 :           for (list = 0; list < OMP_LIST_NUM; list++)
    9196                 :        4408 :             switch (list)
    9197                 :             :             {
    9198                 :        1044 :               case OMP_LIST_PRIVATE:
    9199                 :        1044 :               case OMP_LIST_FIRSTPRIVATE:
    9200                 :        1044 :               case OMP_LIST_LASTPRIVATE:
    9201                 :        1044 :               case OMP_LIST_REDUCTION:
    9202                 :        1044 :               case OMP_LIST_REDUCTION_INSCAN:
    9203                 :        1044 :               case OMP_LIST_REDUCTION_TASK:
    9204                 :        1044 :               case OMP_LIST_IN_REDUCTION:
    9205                 :        1044 :               case OMP_LIST_TASK_REDUCTION:
    9206                 :        1044 :               case OMP_LIST_LINEAR:
    9207                 :        1337 :                 for (n = omp_clauses->lists[list]; n; n = n->next)
    9208                 :         293 :                   n->sym->mark = 0;
    9209                 :             :                 break;
    9210                 :             :               default:
    9211                 :             :                 break;
    9212                 :             :             }
    9213                 :             : 
    9214                 :         401 :           for (n = omp_clauses->lists[OMP_LIST_ALLOCATE]; n; n = n->next)
    9215                 :         285 :             if (n->sym->mark == 1)
    9216                 :           4 :               gfc_error ("%qs specified in %<allocate%> clause at %L but not "
    9217                 :             :                          "in an explicit privatization clause",
    9218                 :             :                          n->sym->name, &n->where);
    9219                 :             :         }
    9220                 :             :       if (code
    9221                 :         251 :           && (code->op == EXEC_OMP_ALLOCATORS || code->op == EXEC_OMP_ALLOCATE)
    9222                 :          69 :           && code->block
    9223                 :          68 :           && code->block->next
    9224                 :          67 :           && code->block->next->op == EXEC_ALLOCATE)
    9225                 :             :         {
    9226                 :          64 :           gfc_alloc *a;
    9227                 :          64 :           gfc_omp_namelist *n_null = NULL;
    9228                 :          64 :           bool missing_allocator = false;
    9229                 :          64 :           gfc_symbol *missing_allocator_sym = NULL;
    9230                 :         153 :           for (n = omp_clauses->lists[OMP_LIST_ALLOCATE]; n; n = n->next)
    9231                 :             :             {
    9232                 :          89 :               if (n->u2.allocator == NULL)
    9233                 :             :                 {
    9234                 :          76 :                   if (!missing_allocator_sym)
    9235                 :          58 :                     missing_allocator_sym = n->sym;
    9236                 :             :                   missing_allocator = true;
    9237                 :             :                 }
    9238                 :          89 :               if (n->sym == NULL)
    9239                 :             :                 {
    9240                 :          26 :                   n_null = n;
    9241                 :          26 :                   continue;
    9242                 :             :                 }
    9243                 :          63 :               if (n->sym->attr.codimension)
    9244                 :           2 :                 gfc_error ("Unexpected coarray %qs in %<allocate%> at %L",
    9245                 :             :                            n->sym->name, &n->where);
    9246                 :          99 :               for (a = code->block->next->ext.alloc.list; a; a = a->next)
    9247                 :          97 :                 if (a->expr->expr_type == EXPR_VARIABLE
    9248                 :          97 :                     && a->expr->symtree->n.sym == n->sym)
    9249                 :             :                   {
    9250                 :          61 :                     gfc_ref *ref;
    9251                 :          74 :                     for (ref = a->expr->ref; ref; ref = ref->next)
    9252                 :          13 :                       if (ref->type == REF_COMPONENT)
    9253                 :             :                         break;
    9254                 :             :                     if (ref == NULL)
    9255                 :             :                       break;
    9256                 :             :                   }
    9257                 :          63 :               if (a == NULL)
    9258                 :           2 :                 gfc_error ("%qs specified in %<allocate%> at %L but not "
    9259                 :             :                            "in the associated ALLOCATE statement",
    9260                 :           2 :                            n->sym->name, &n->where);
    9261                 :             :             }
    9262                 :             :           /* If there is an ALLOCATE directive without list argument, a
    9263                 :             :              namelist with its allocator/align clauses and n->sym = NULL is
    9264                 :             :              created during parsing; here, we add all not otherwise specified
    9265                 :             :              items from the Fortran allocate to that list.
    9266                 :             :              For an ALLOCATORS directive, not listed items use the normal
    9267                 :             :              Fortran way.
    9268                 :             :              The behavior of an ALLOCATE directive that does not list all
    9269                 :             :              arguments but there is no directive without list argument is not
    9270                 :             :              well specified.  Thus, we reject such code below. In OpenMP 5.2
    9271                 :             :              the executable ALLOCATE directive is deprecated and in 6.0
    9272                 :             :              deleted such that no spec clarification is to be expected.  */
    9273                 :         117 :           for (a = code->block->next->ext.alloc.list; a; a = a->next)
    9274                 :          85 :             if (a->expr->expr_type == EXPR_VARIABLE)
    9275                 :             :               {
    9276                 :         150 :                 for (n = omp_clauses->lists[OMP_LIST_ALLOCATE]; n; n = n->next)
    9277                 :         118 :                   if (a->expr->symtree->n.sym == n->sym)
    9278                 :             :                     {
    9279                 :          53 :                       gfc_ref *ref;
    9280                 :          64 :                       for (ref = a->expr->ref; ref; ref = ref->next)
    9281                 :          11 :                         if (ref->type == REF_COMPONENT)
    9282                 :             :                           break;
    9283                 :             :                       if (ref == NULL)
    9284                 :             :                         break;
    9285                 :             :                     }
    9286                 :          85 :                 if (n == NULL && n_null == NULL)
    9287                 :             :                   {
    9288                 :             :                     /* OK for ALLOCATORS but for ALLOCATE: Unspecified whether
    9289                 :             :                        that should use the default allocator of OpenMP or the
    9290                 :             :                        Fortran allocator. Thus, just reject it.  */
    9291                 :           7 :                     if (code->op == EXEC_OMP_ALLOCATE)
    9292                 :           1 :                       gfc_error ("%qs listed in %<allocate%> statement at %L "
    9293                 :             :                                  "but it is neither explicitly in listed in "
    9294                 :             :                                  "the %<!$OMP ALLOCATE%> directive nor exists"
    9295                 :             :                                  " a directive without argument list",
    9296                 :           1 :                                  a->expr->symtree->n.sym->name,
    9297                 :             :                                  &a->expr->where);
    9298                 :             :                     break;
    9299                 :             :                   }
    9300                 :          78 :                 if (n == NULL)
    9301                 :             :                   {
    9302                 :          25 :                     if (a->expr->symtree->n.sym->attr.codimension)
    9303                 :           1 :                       gfc_error ("Unexpected coarray %qs in %<allocate%> at "
    9304                 :             :                                  "%L, implicitly listed in %<!$OMP ALLOCATE%>"
    9305                 :             :                                  " at %L", a->expr->symtree->n.sym->name,
    9306                 :             :                                  &a->expr->where, &n_null->where);
    9307                 :             :                     break;
    9308                 :             :                   }
    9309                 :             :             }
    9310                 :          64 :           gfc_namespace *prog_unit = ns;
    9311                 :          82 :           while (prog_unit->parent)
    9312                 :             :             prog_unit = prog_unit->parent;
    9313                 :             :           gfc_namespace *fn_ns = ns;
    9314                 :          66 :           while (fn_ns)
    9315                 :             :             {
    9316                 :          65 :               if (ns->proc_name
    9317                 :          65 :                   && (ns->proc_name->attr.subroutine
    9318                 :          65 :                       || ns->proc_name->attr.function))
    9319                 :             :                 break;
    9320                 :           2 :               fn_ns = fn_ns->parent;
    9321                 :             :             }
    9322                 :          64 :           if (missing_allocator
    9323                 :          57 :               && !(prog_unit->omp_requires & OMP_REQ_DYNAMIC_ALLOCATORS)
    9324                 :          57 :               && ((fn_ns && fn_ns->proc_name->attr.omp_declare_target)
    9325                 :          54 :                   || omp_clauses->contained_in_target_construct))
    9326                 :             :             {
    9327                 :           6 :               if (code->op == EXEC_OMP_ALLOCATORS)
    9328                 :           2 :                 gfc_error ("ALLOCATORS directive at %L inside a target region "
    9329                 :             :                            "must specify an ALLOCATOR modifier for %qs",
    9330                 :             :                            &code->loc, missing_allocator_sym->name);
    9331                 :           4 :               else if (missing_allocator_sym)
    9332                 :           2 :                 gfc_error ("ALLOCATE directive at %L inside a target region "
    9333                 :             :                            "must specify an ALLOCATOR clause for %qs",
    9334                 :             :                            &code->loc, missing_allocator_sym->name);
    9335                 :             :               else
    9336                 :           2 :                 gfc_error ("ALLOCATE directive at %L inside a target region "
    9337                 :             :                            "must specify an ALLOCATOR clause", &code->loc);
    9338                 :             :             }
    9339                 :             : 
    9340                 :             :         }
    9341                 :             :     }
    9342                 :             : 
    9343                 :             :   /* OpenACC reductions.  */
    9344                 :       31620 :   if (openacc)
    9345                 :             :     {
    9346                 :       14681 :       for (n = omp_clauses->lists[OMP_LIST_REDUCTION]; n; n = n->next)
    9347                 :        2136 :         n->sym->mark = 0;
    9348                 :             : 
    9349                 :       14681 :       for (n = omp_clauses->lists[OMP_LIST_REDUCTION]; n; n = n->next)
    9350                 :             :         {
    9351                 :        2136 :           if (n->sym->mark)
    9352                 :           0 :             gfc_error ("Symbol %qs present on multiple clauses at %L",
    9353                 :             :                        n->sym->name, &n->where);
    9354                 :             :           else
    9355                 :        2136 :             n->sym->mark = 1;
    9356                 :             : 
    9357                 :             :           /* OpenACC does not support reductions on arrays.  */
    9358                 :        2136 :           if (n->sym->as)
    9359                 :          71 :             gfc_error ("Array %qs is not permitted in reduction at %L",
    9360                 :             :                        n->sym->name, &n->where);
    9361                 :             :         }
    9362                 :             :     }
    9363                 :             : 
    9364                 :       32374 :   for (n = omp_clauses->lists[OMP_LIST_TO]; n; n = n->next)
    9365                 :         754 :     n->sym->mark = 0;
    9366                 :       32651 :   for (n = omp_clauses->lists[OMP_LIST_FROM]; n; n = n->next)
    9367                 :        1031 :     if (n->expr == NULL)
    9368                 :        1015 :       n->sym->mark = 1;
    9369                 :       32374 :   for (n = omp_clauses->lists[OMP_LIST_TO]; n; n = n->next)
    9370                 :             :     {
    9371                 :         754 :       if (n->expr == NULL && n->sym->mark)
    9372                 :           0 :         gfc_error ("Symbol %qs present on both FROM and TO clauses at %L",
    9373                 :             :                    n->sym->name, &n->where);
    9374                 :             :       else
    9375                 :         754 :         n->sym->mark = 1;
    9376                 :             :     }
    9377                 :             : 
    9378                 :             :   bool has_inscan = false, has_notinscan = false;
    9379                 :     1233180 :   for (list = 0; list < OMP_LIST_NUM; list++)
    9380                 :     1201560 :     if ((n = omp_clauses->lists[list]) != NULL)
    9381                 :             :       {
    9382                 :       28377 :         const char *name = clause_names[list];
    9383                 :             : 
    9384                 :       28377 :         switch (list)
    9385                 :             :           {
    9386                 :             :           case OMP_LIST_COPYIN:
    9387                 :         267 :             for (; n != NULL; n = n->next)
    9388                 :             :               {
    9389                 :         170 :                 if (!n->sym->attr.threadprivate)
    9390                 :           0 :                   gfc_error ("Non-THREADPRIVATE object %qs in COPYIN clause"
    9391                 :             :                              " at %L", n->sym->name, &n->where);
    9392                 :             :               }
    9393                 :             :             break;
    9394                 :          83 :           case OMP_LIST_COPYPRIVATE:
    9395                 :          83 :             if (omp_clauses->nowait)
    9396                 :           6 :               gfc_error ("NOWAIT clause must not be used with COPYPRIVATE "
    9397                 :             :                          "clause at %L", &n->where);
    9398                 :         376 :             for (; n != NULL; n = n->next)
    9399                 :             :               {
    9400                 :         293 :                 if (n->sym->as && n->sym->as->type == AS_ASSUMED_SIZE)
    9401                 :           0 :                   gfc_error ("Assumed size array %qs in COPYPRIVATE clause "
    9402                 :             :                              "at %L", n->sym->name, &n->where);
    9403                 :         293 :                 if (n->sym->attr.pointer && n->sym->attr.intent == INTENT_IN)
    9404                 :           1 :                   gfc_error ("INTENT(IN) POINTER %qs in COPYPRIVATE clause "
    9405                 :             :                              "at %L", n->sym->name, &n->where);
    9406                 :             :               }
    9407                 :             :             break;
    9408                 :             :           case OMP_LIST_SHARED:
    9409                 :        2574 :             for (; n != NULL; n = n->next)
    9410                 :             :               {
    9411                 :        1624 :                 if (n->sym->attr.threadprivate)
    9412                 :           0 :                   gfc_error ("THREADPRIVATE object %qs in SHARED clause at "
    9413                 :             :                              "%L", n->sym->name, &n->where);
    9414                 :        1624 :                 if (n->sym->attr.cray_pointee)
    9415                 :           1 :                   gfc_error ("Cray pointee %qs in SHARED clause at %L",
    9416                 :             :                             n->sym->name, &n->where);
    9417                 :        1624 :                 if (n->sym->attr.associate_var)
    9418                 :           8 :                   gfc_error ("Associate name %qs in SHARED clause at %L",
    9419                 :           8 :                              n->sym->attr.select_type_temporary
    9420                 :           4 :                              ? n->sym->assoc->target->symtree->n.sym->name
    9421                 :             :                              : n->sym->name, &n->where);
    9422                 :        1624 :                 if (omp_clauses->detach
    9423                 :           1 :                     && n->sym == omp_clauses->detach->symtree->n.sym)
    9424                 :           1 :                   gfc_error ("DETACH event handle %qs in SHARED clause at %L",
    9425                 :             :                              n->sym->name, &n->where);
    9426                 :             :               }
    9427                 :             :             break;
    9428                 :             :           case OMP_LIST_ALIGNED:
    9429                 :         256 :             for (; n != NULL; n = n->next)
    9430                 :             :               {
    9431                 :         150 :                 if (!n->sym->attr.pointer
    9432                 :         150 :                     && !n->sym->attr.allocatable
    9433                 :          30 :                     && !n->sym->attr.cray_pointer
    9434                 :          18 :                     && (n->sym->ts.type != BT_DERIVED
    9435                 :          18 :                         || (n->sym->ts.u.derived->from_intmod
    9436                 :             :                             != INTMOD_ISO_C_BINDING)
    9437                 :          18 :                         || (n->sym->ts.u.derived->intmod_sym_id
    9438                 :             :                             != ISOCBINDING_PTR)))
    9439                 :           0 :                   gfc_error ("%qs in ALIGNED clause must be POINTER, "
    9440                 :             :                              "ALLOCATABLE, Cray pointer or C_PTR at %L",
    9441                 :             :                              n->sym->name, &n->where);
    9442                 :         150 :                 else if (n->expr)
    9443                 :             :                   {
    9444                 :         147 :                     if (!gfc_resolve_expr (n->expr)
    9445                 :         147 :                         || n->expr->ts.type != BT_INTEGER
    9446                 :         146 :                         || n->expr->rank != 0
    9447                 :         146 :                         || n->expr->expr_type != EXPR_CONSTANT
    9448                 :         292 :                         || mpz_sgn (n->expr->value.integer) <= 0)
    9449                 :           4 :                       gfc_error ("%qs in ALIGNED clause at %L requires a scalar"
    9450                 :             :                                  " positive constant integer alignment "
    9451                 :           4 :                                  "expression", n->sym->name, &n->where);
    9452                 :             :                   }
    9453                 :             :               }
    9454                 :             :             break;
    9455                 :             :           case OMP_LIST_AFFINITY:
    9456                 :             :           case OMP_LIST_DEPEND:
    9457                 :             :           case OMP_LIST_MAP:
    9458                 :             :           case OMP_LIST_TO:
    9459                 :             :           case OMP_LIST_FROM:
    9460                 :             :           case OMP_LIST_CACHE:
    9461                 :       31119 :             for (; n != NULL; n = n->next)
    9462                 :             :               {
    9463                 :       19555 :                 if ((list == OMP_LIST_DEPEND || list == OMP_LIST_AFFINITY)
    9464                 :        1990 :                     && n->u2.ns && !n->u2.ns->resolved)
    9465                 :             :                   {
    9466                 :          53 :                     n->u2.ns->resolved = 1;
    9467                 :          53 :                     for (gfc_symbol *sym = n->u2.ns->omp_affinity_iterators;
    9468                 :         110 :                          sym; sym = sym->tlink)
    9469                 :             :                       {
    9470                 :          57 :                         gfc_constructor *c;
    9471                 :          57 :                         c = gfc_constructor_first (sym->value->value.constructor);
    9472                 :          57 :                         if (!gfc_resolve_expr (c->expr)
    9473                 :          57 :                             || c->expr->ts.type != BT_INTEGER
    9474                 :         112 :                             || c->expr->rank != 0)
    9475                 :           2 :                           gfc_error ("Scalar integer expression for range begin"
    9476                 :           2 :                                      " expected at %L", &c->expr->where);
    9477                 :          57 :                         c = gfc_constructor_next (c);
    9478                 :          57 :                         if (!gfc_resolve_expr (c->expr)
    9479                 :          57 :                             || c->expr->ts.type != BT_INTEGER
    9480                 :         112 :                             || c->expr->rank != 0)
    9481                 :           2 :                           gfc_error ("Scalar integer expression for range end "
    9482                 :           2 :                                      "expected at %L", &c->expr->where);
    9483                 :          57 :                         c = gfc_constructor_next (c);
    9484                 :          57 :                         if (c && (!gfc_resolve_expr (c->expr)
    9485                 :          16 :                                   || c->expr->ts.type != BT_INTEGER
    9486                 :          14 :                                   || c->expr->rank != 0))
    9487                 :           2 :                           gfc_error ("Scalar integer expression for range step "
    9488                 :           2 :                                      "expected at %L", &c->expr->where);
    9489                 :          55 :                         else if (c
    9490                 :          14 :                                  && c->expr->expr_type == EXPR_CONSTANT
    9491                 :          12 :                                  && mpz_cmp_si (c->expr->value.integer, 0) == 0)
    9492                 :           2 :                           gfc_error ("Nonzero range step expected at %L",
    9493                 :             :                                      &c->expr->where);
    9494                 :             :                       }
    9495                 :             :                   }
    9496                 :             : 
    9497                 :        1990 :                 if (list == OMP_LIST_DEPEND)
    9498                 :             :                   {
    9499                 :        3187 :                     if (n->u.depend_doacross_op == OMP_DEPEND_SINK_FIRST
    9500                 :             :                         || n->u.depend_doacross_op == OMP_DOACROSS_SINK_FIRST
    9501                 :        1955 :                         || n->u.depend_doacross_op == OMP_DOACROSS_SINK)
    9502                 :             :                       {
    9503                 :        1232 :                         if (omp_clauses->doacross_source)
    9504                 :             :                           {
    9505                 :           0 :                             gfc_error ("Dependence-type SINK used together with"
    9506                 :             :                                        " SOURCE on the same construct at %L",
    9507                 :             :                                        &n->where);
    9508                 :           0 :                             omp_clauses->doacross_source = false;
    9509                 :             :                           }
    9510                 :        1232 :                         else if (n->expr)
    9511                 :             :                           {
    9512                 :         571 :                             if (!gfc_resolve_expr (n->expr)
    9513                 :         571 :                                 || n->expr->ts.type != BT_INTEGER
    9514                 :        1142 :                                 || n->expr->rank != 0)
    9515                 :           0 :                               gfc_error ("SINK addend not a constant integer "
    9516                 :             :                                          "at %L", &n->where);
    9517                 :             :                           }
    9518                 :        1232 :                         if (n->sym == NULL
    9519                 :           4 :                             && (n->expr == NULL
    9520                 :           3 :                                 || mpz_cmp_si (n->expr->value.integer, -1) != 0))
    9521                 :           2 :                           gfc_error ("omp_cur_iteration at %L requires %<-1%> "
    9522                 :             :                                      "as logical offset", &n->where);
    9523                 :        1232 :                         continue;
    9524                 :             :                       }
    9525                 :         723 :                     else if (n->u.depend_doacross_op == OMP_DEPEND_DEPOBJ
    9526                 :          35 :                              && !n->expr
    9527                 :          22 :                              && (n->sym->ts.type != BT_INTEGER
    9528                 :          22 :                                  || n->sym->ts.kind
    9529                 :          22 :                                     != 2 * gfc_index_integer_kind
    9530                 :          22 :                                  || n->sym->attr.dimension))
    9531                 :           0 :                       gfc_error ("Locator %qs at %L in DEPEND clause of depobj "
    9532                 :             :                                  "type shall be a scalar integer of "
    9533                 :             :                                  "OMP_DEPEND_KIND kind", n->sym->name,
    9534                 :             :                                  &n->where);
    9535                 :         723 :                     else if (n->u.depend_doacross_op == OMP_DEPEND_DEPOBJ
    9536                 :          35 :                              && n->expr
    9537                 :         736 :                              && (!gfc_resolve_expr (n->expr)
    9538                 :          13 :                                  || n->expr->ts.type != BT_INTEGER
    9539                 :          13 :                                  || n->expr->ts.kind
    9540                 :          13 :                                     != 2 * gfc_index_integer_kind
    9541                 :          13 :                                  || n->expr->rank != 0))
    9542                 :           0 :                       gfc_error ("Locator at %L in DEPEND clause of depobj "
    9543                 :             :                                  "type shall be a scalar integer of "
    9544                 :           0 :                                  "OMP_DEPEND_KIND kind", &n->expr->where);
    9545                 :             :                   }
    9546                 :       18323 :                 gfc_ref *lastref = NULL, *lastslice = NULL;
    9547                 :       18323 :                 bool resolved = false;
    9548                 :       18323 :                 if (n->expr)
    9549                 :             :                   {
    9550                 :        5843 :                     lastref = n->expr->ref;
    9551                 :        5843 :                     resolved = gfc_resolve_expr (n->expr);
    9552                 :             : 
    9553                 :             :                     /* Look through component refs to find last array
    9554                 :             :                        reference.  */
    9555                 :        5843 :                     if (resolved)
    9556                 :             :                       {
    9557                 :       13917 :                         for (gfc_ref *ref = n->expr->ref; ref; ref = ref->next)
    9558                 :        8092 :                           if (ref->type == REF_COMPONENT
    9559                 :             :                               || ref->type == REF_SUBSTRING
    9560                 :        8092 :                               || ref->type == REF_INQUIRY)
    9561                 :             :                             lastref = ref;
    9562                 :        5718 :                           else if (ref->type == REF_ARRAY)
    9563                 :             :                             {
    9564                 :       11889 :                               for (int i = 0; i < ref->u.ar.dimen; i++)
    9565                 :        6171 :                                 if (ref->u.ar.dimen_type[i] == DIMEN_RANGE)
    9566                 :        5389 :                                   lastslice = ref;
    9567                 :             : 
    9568                 :             :                               lastref = ref;
    9569                 :             :                             }
    9570                 :             : 
    9571                 :             :                         /* The "!$acc cache" directive allows rectangular
    9572                 :             :                            subarrays to be specified, with some restrictions
    9573                 :             :                            on the form of bounds (not implemented).
    9574                 :             :                            Only raise an error here if we're really sure the
    9575                 :             :                            array isn't contiguous.  An expression such as
    9576                 :             :                            arr(-n:n,-n:n) could be contiguous even if it looks
    9577                 :             :                            like it may not be.  */
    9578                 :        5825 :                         if (code->op != EXEC_OACC_UPDATE
    9579                 :        5043 :                             && list != OMP_LIST_CACHE
    9580                 :        5043 :                             && list != OMP_LIST_DEPEND
    9581                 :        4727 :                             && !gfc_is_simply_contiguous (n->expr, false, true)
    9582                 :        1389 :                             && gfc_is_not_contiguous (n->expr)
    9583                 :        5838 :                             && !(lastslice
    9584                 :          13 :                                  && (lastslice->next
    9585                 :           3 :                                      || lastslice->type != REF_ARRAY)))
    9586                 :           3 :                           gfc_error ("Array is not contiguous at %L",
    9587                 :             :                                      &n->where);
    9588                 :             :                       }
    9589                 :             :                   }
    9590                 :       18323 :                 if (openacc
    9591                 :       18323 :                     && list == OMP_LIST_MAP
    9592                 :        9457 :                     && (n->u.map.op == OMP_MAP_ATTACH
    9593                 :        9391 :                         || n->u.map.op == OMP_MAP_DETACH))
    9594                 :             :                   {
    9595                 :         109 :                     symbol_attribute attr;
    9596                 :         109 :                     if (n->expr)
    9597                 :          99 :                       attr = gfc_expr_attr (n->expr);
    9598                 :             :                     else
    9599                 :          10 :                       attr = n->sym->attr;
    9600                 :         109 :                     if (!attr.pointer && !attr.allocatable)
    9601                 :           7 :                       gfc_error ("%qs clause argument must be ALLOCATABLE or "
    9602                 :             :                                  "a POINTER at %L",
    9603                 :           7 :                                  (n->u.map.op == OMP_MAP_ATTACH) ? "attach"
    9604                 :             :                                  : "detach", &n->where);
    9605                 :             :                   }
    9606                 :       18323 :                 if (lastref
    9607                 :       12492 :                     || (n->expr
    9608                 :          12 :                         && (!resolved || n->expr->expr_type != EXPR_VARIABLE)))
    9609                 :             :                   {
    9610                 :        5843 :                     if (!lastslice
    9611                 :        5843 :                         && lastref
    9612                 :         867 :                         && lastref->type == REF_SUBSTRING)
    9613                 :          11 :                       gfc_error ("Unexpected substring reference in %s clause "
    9614                 :             :                                  "at %L", name, &n->where);
    9615                 :        5832 :                     else if (!lastslice
    9616                 :             :                              && lastref
    9617                 :         856 :                              && lastref->type == REF_INQUIRY)
    9618                 :             :                       {
    9619                 :          12 :                         gcc_assert (lastref->u.i == INQUIRY_RE
    9620                 :             :                                     || lastref->u.i == INQUIRY_IM);
    9621                 :          12 :                         gfc_error ("Unexpected complex-parts designator "
    9622                 :             :                                    "reference in %s clause at %L",
    9623                 :             :                                    name, &n->where);
    9624                 :             :                       }
    9625                 :        5820 :                     else if (!resolved
    9626                 :        5802 :                              || n->expr->expr_type != EXPR_VARIABLE
    9627                 :        5790 :                              || (lastslice
    9628                 :        4964 :                                  && (lastslice->next
    9629                 :        4948 :                                      || lastslice->type != REF_ARRAY)))
    9630                 :          46 :                       gfc_error ("%qs in %s clause at %L is not a proper "
    9631                 :          46 :                                  "array section", n->sym->name, name,
    9632                 :             :                                  &n->where);
    9633                 :             :                     else if (lastslice)
    9634                 :             :                       {
    9635                 :             :                         int i;
    9636                 :             :                         gfc_array_ref *ar = &lastslice->u.ar;
    9637                 :       10334 :                         for (i = 0; i < ar->dimen; i++)
    9638                 :        5387 :                           if (ar->stride[i] && code->op != EXEC_OACC_UPDATE)
    9639                 :             :                             {
    9640                 :           1 :                               gfc_error ("Stride should not be specified for "
    9641                 :             :                                          "array section in %s clause at %L",
    9642                 :             :                                          name, &n->where);
    9643                 :           1 :                               break;
    9644                 :             :                             }
    9645                 :        5386 :                           else if (ar->dimen_type[i] != DIMEN_ELEMENT
    9646                 :        5386 :                                    && ar->dimen_type[i] != DIMEN_RANGE)
    9647                 :             :                             {
    9648                 :           0 :                               gfc_error ("%qs in %s clause at %L is not a "
    9649                 :             :                                          "proper array section",
    9650                 :           0 :                                          n->sym->name, name, &n->where);
    9651                 :           0 :                               break;
    9652                 :             :                             }
    9653                 :        5386 :                           else if ((list == OMP_LIST_DEPEND
    9654                 :             :                                     || list == OMP_LIST_AFFINITY)
    9655                 :         160 :                                    && ar->start[i]
    9656                 :         133 :                                    && ar->start[i]->expr_type == EXPR_CONSTANT
    9657                 :          97 :                                    && ar->end[i]
    9658                 :          72 :                                    && ar->end[i]->expr_type == EXPR_CONSTANT
    9659                 :          72 :                                    && mpz_cmp (ar->start[i]->value.integer,
    9660                 :          72 :                                                ar->end[i]->value.integer) > 0)
    9661                 :             :                             {
    9662                 :           0 :                               gfc_error ("%qs in %s clause at %L is a "
    9663                 :             :                                          "zero size array section",
    9664                 :           0 :                                          n->sym->name,
    9665                 :             :                                          list == OMP_LIST_DEPEND
    9666                 :             :                                          ? "DEPEND" : "AFFINITY", &n->where);
    9667                 :           0 :                               break;
    9668                 :             :                             }
    9669                 :             :                       }
    9670                 :             :                   }
    9671                 :       12480 :                 else if (openacc)
    9672                 :             :                   {
    9673                 :        5801 :                     if (list == OMP_LIST_MAP
    9674                 :        5786 :                         && n->u.map.op == OMP_MAP_FORCE_DEVICEPTR)
    9675                 :          59 :                       resolve_oacc_deviceptr_clause (n->sym, n->where, name);
    9676                 :             :                     else
    9677                 :        5742 :                       resolve_oacc_data_clauses (n->sym, n->where, name);
    9678                 :             :                   }
    9679                 :        6679 :                 else if (list != OMP_LIST_DEPEND
    9680                 :        6187 :                          && n->sym->as
    9681                 :        2969 :                          && n->sym->as->type == AS_ASSUMED_SIZE)
    9682                 :           5 :                   gfc_error ("Assumed size array %qs in %s clause at %L",
    9683                 :             :                              n->sym->name, name, &n->where);
    9684                 :       18323 :                 if (list == OMP_LIST_MAP && !openacc)
    9685                 :        6222 :                   switch (code->op)
    9686                 :             :                     {
    9687                 :        5523 :                     case EXEC_OMP_TARGET:
    9688                 :        5523 :                     case EXEC_OMP_TARGET_PARALLEL:
    9689                 :        5523 :                     case EXEC_OMP_TARGET_PARALLEL_DO:
    9690                 :        5523 :                     case EXEC_OMP_TARGET_PARALLEL_DO_SIMD:
    9691                 :        5523 :                     case EXEC_OMP_TARGET_PARALLEL_LOOP:
    9692                 :        5523 :                     case EXEC_OMP_TARGET_SIMD:
    9693                 :        5523 :                     case EXEC_OMP_TARGET_TEAMS:
    9694                 :        5523 :                     case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE:
    9695                 :        5523 :                     case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO:
    9696                 :        5523 :                     case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD:
    9697                 :        5523 :                     case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_SIMD:
    9698                 :        5523 :                     case EXEC_OMP_TARGET_TEAMS_LOOP:
    9699                 :        5523 :                     case EXEC_OMP_TARGET_DATA:
    9700                 :        5523 :                       switch (n->u.map.op)
    9701                 :             :                         {
    9702                 :             :                         case OMP_MAP_TO:
    9703                 :             :                         case OMP_MAP_ALWAYS_TO:
    9704                 :             :                         case OMP_MAP_PRESENT_TO:
    9705                 :             :                         case OMP_MAP_ALWAYS_PRESENT_TO:
    9706                 :             :                         case OMP_MAP_FROM:
    9707                 :             :                         case OMP_MAP_ALWAYS_FROM:
    9708                 :             :                         case OMP_MAP_PRESENT_FROM:
    9709                 :             :                         case OMP_MAP_ALWAYS_PRESENT_FROM:
    9710                 :             :                         case OMP_MAP_TOFROM:
    9711                 :             :                         case OMP_MAP_ALWAYS_TOFROM:
    9712                 :             :                         case OMP_MAP_PRESENT_TOFROM:
    9713                 :             :                         case OMP_MAP_ALWAYS_PRESENT_TOFROM:
    9714                 :             :                         case OMP_MAP_ALLOC:
    9715                 :             :                         case OMP_MAP_PRESENT_ALLOC:
    9716                 :             :                           break;
    9717                 :           2 :                         default:
    9718                 :           2 :                           gfc_error ("TARGET%s with map-type other than TO, "
    9719                 :             :                                      "FROM, TOFROM, or ALLOC on MAP clause "
    9720                 :             :                                      "at %L",
    9721                 :             :                                      code->op == EXEC_OMP_TARGET_DATA
    9722                 :             :                                      ? " DATA" : "", &n->where);
    9723                 :           2 :                           break;
    9724                 :             :                         }
    9725                 :             :                       break;
    9726                 :         408 :                     case EXEC_OMP_TARGET_ENTER_DATA:
    9727                 :         408 :                       switch (n->u.map.op)
    9728                 :             :                         {
    9729                 :             :                         case OMP_MAP_TO:
    9730                 :             :                         case OMP_MAP_ALWAYS_TO:
    9731                 :             :                         case OMP_MAP_PRESENT_TO:
    9732                 :             :                         case OMP_MAP_ALWAYS_PRESENT_TO:
    9733                 :             :                         case OMP_MAP_ALLOC:
    9734                 :             :                         case OMP_MAP_PRESENT_ALLOC:
    9735                 :             :                           break;
    9736                 :          57 :                         case OMP_MAP_TOFROM:
    9737                 :          57 :                           n->u.map.op = OMP_MAP_TO;
    9738                 :          57 :                           break;
    9739                 :           3 :                         case OMP_MAP_ALWAYS_TOFROM:
    9740                 :           3 :                           n->u.map.op = OMP_MAP_ALWAYS_TO;
    9741                 :           3 :                           break;
    9742                 :           2 :                         case OMP_MAP_PRESENT_TOFROM:
    9743                 :           2 :                           n->u.map.op = OMP_MAP_PRESENT_TO;
    9744                 :           2 :                           break;
    9745                 :           2 :                         case OMP_MAP_ALWAYS_PRESENT_TOFROM:
    9746                 :           2 :                           n->u.map.op = OMP_MAP_ALWAYS_PRESENT_TO;
    9747                 :           2 :                           break;
    9748                 :           2 :                         default:
    9749                 :           2 :                           gfc_error ("TARGET ENTER DATA with map-type other "
    9750                 :             :                                      "than TO, TOFROM or ALLOC on MAP clause "
    9751                 :             :                                      "at %L", &n->where);
    9752                 :           2 :                           break;
    9753                 :             :                         }
    9754                 :             :                       break;
    9755                 :         291 :                     case EXEC_OMP_TARGET_EXIT_DATA:
    9756                 :         291 :                       switch (n->u.map.op)
    9757                 :             :                         {
    9758                 :             :                         case OMP_MAP_FROM:
    9759                 :             :                         case OMP_MAP_ALWAYS_FROM:
    9760                 :             :                         case OMP_MAP_PRESENT_FROM:
    9761                 :             :                         case OMP_MAP_ALWAYS_PRESENT_FROM:
    9762                 :             :                         case OMP_MAP_RELEASE:
    9763                 :             :                         case OMP_MAP_DELETE:
    9764                 :             :                           break;
    9765                 :          15 :                         case OMP_MAP_TOFROM:
    9766                 :          15 :                           n->u.map.op = OMP_MAP_FROM;
    9767                 :          15 :                           break;
    9768                 :           1 :                         case OMP_MAP_ALWAYS_TOFROM:
    9769                 :           1 :                           n->u.map.op = OMP_MAP_ALWAYS_FROM;
    9770                 :           1 :                           break;
    9771                 :           0 :                         case OMP_MAP_PRESENT_TOFROM:
    9772                 :           0 :                           n->u.map.op = OMP_MAP_PRESENT_FROM;
    9773                 :           0 :                           break;
    9774                 :           0 :                         case OMP_MAP_ALWAYS_PRESENT_TOFROM:
    9775                 :           0 :                           n->u.map.op = OMP_MAP_ALWAYS_PRESENT_FROM;
    9776                 :           0 :                           break;
    9777                 :           2 :                         default:
    9778                 :           2 :                           gfc_error ("TARGET EXIT DATA with map-type other "
    9779                 :             :                                      "than FROM, TOFROM, RELEASE, or DELETE on "
    9780                 :             :                                      "MAP clause at %L", &n->where);
    9781                 :           2 :                           break;
    9782                 :             :                         }
    9783                 :             :                       break;
    9784                 :             :                     default:
    9785                 :             :                       break;
    9786                 :             :                     }
    9787                 :             :               }
    9788                 :             : 
    9789                 :       11564 :             if (list != OMP_LIST_DEPEND)
    9790                 :       28325 :               for (n = omp_clauses->lists[list]; n != NULL; n = n->next)
    9791                 :             :                 {
    9792                 :       17600 :                   n->sym->attr.referenced = 1;
    9793                 :       17600 :                   if (n->sym->attr.threadprivate)
    9794                 :           1 :                     gfc_error ("THREADPRIVATE object %qs in %s clause at %L",
    9795                 :             :                                n->sym->name, name, &n->where);
    9796                 :       17600 :                   if (n->sym->attr.cray_pointee)
    9797                 :          14 :                     gfc_error ("Cray pointee %qs in %s clause at %L",
    9798                 :             :                                n->sym->name, name, &n->where);
    9799                 :             :                 }
    9800                 :             :             break;
    9801                 :             :           case OMP_LIST_IS_DEVICE_PTR:
    9802                 :             :             last = NULL;
    9803                 :         371 :             for (n = omp_clauses->lists[list]; n != NULL; )
    9804                 :             :               {
    9805                 :         254 :                 if ((n->sym->ts.type != BT_DERIVED
    9806                 :          68 :                      || !n->sym->ts.u.derived->ts.is_iso_c
    9807                 :          68 :                      || (n->sym->ts.u.derived->intmod_sym_id
    9808                 :             :                          != ISOCBINDING_PTR))
    9809                 :         187 :                     && code->op == EXEC_OMP_DISPATCH)
    9810                 :             :                   /* Non-TARGET (i.e. DISPATCH) requires a C_PTR.  */
    9811                 :           3 :                   gfc_error ("List item %qs in %s clause at %L must be of "
    9812                 :             :                              "TYPE(C_PTR)", n->sym->name, name, &n->where);
    9813                 :         251 :                 else if (n->sym->ts.type != BT_DERIVED
    9814                 :          67 :                          || !n->sym->ts.u.derived->ts.is_iso_c
    9815                 :          67 :                          || (n->sym->ts.u.derived->intmod_sym_id
    9816                 :             :                              != ISOCBINDING_PTR))
    9817                 :             :                   {
    9818                 :             :                     /* For TARGET, non-C_PTR are deprecated and handled as
    9819                 :             :                        has_device_addr.  */
    9820                 :         184 :                     gfc_omp_namelist *n2 = n;
    9821                 :         184 :                     n = n->next;
    9822                 :         184 :                     if (last)
    9823                 :           0 :                       last->next = n;
    9824                 :             :                     else
    9825                 :         184 :                       omp_clauses->lists[list] = n;
    9826                 :         184 :                     n2->next = omp_clauses->lists[OMP_LIST_HAS_DEVICE_ADDR];
    9827                 :         184 :                     omp_clauses->lists[OMP_LIST_HAS_DEVICE_ADDR] = n2;
    9828                 :         184 :                     continue;
    9829                 :         184 :                   }
    9830                 :          70 :                 last = n;
    9831                 :          70 :                 n = n->next;
    9832                 :             :               }
    9833                 :             :             break;
    9834                 :             :           case OMP_LIST_HAS_DEVICE_ADDR:
    9835                 :             :           case OMP_LIST_USE_DEVICE_ADDR:
    9836                 :             :             break;
    9837                 :             :           case OMP_LIST_USE_DEVICE_PTR:
    9838                 :             :             /* Non-C_PTR are deprecated and handled as use_device_ADDR.  */
    9839                 :             :             last = NULL;
    9840                 :         475 :             for (n = omp_clauses->lists[list]; n != NULL; )
    9841                 :             :               {
    9842                 :         312 :                 gfc_omp_namelist *n2 = n;
    9843                 :         312 :                 if (n->sym->ts.type != BT_DERIVED
    9844                 :          18 :                     || !n->sym->ts.u.derived->ts.is_iso_c)
    9845                 :             :                   {
    9846                 :         294 :                     n = n->next;
    9847                 :         294 :                     if (last)
    9848                 :           0 :                       last->next = n;
    9849                 :             :                     else
    9850                 :         294 :                       omp_clauses->lists[list] = n;
    9851                 :         294 :                     n2->next = omp_clauses->lists[OMP_LIST_USE_DEVICE_ADDR];
    9852                 :         294 :                     omp_clauses->lists[OMP_LIST_USE_DEVICE_ADDR] = n2;
    9853                 :         294 :                     continue;
    9854                 :             :                   }
    9855                 :          18 :                 last = n;
    9856                 :          18 :                 n = n->next;
    9857                 :             :               }
    9858                 :             :             break;
    9859                 :          39 :           case OMP_LIST_USES_ALLOCATORS:
    9860                 :          39 :             {
    9861                 :          39 :               if (n != NULL
    9862                 :          39 :                   && n->u.memspace_sym
    9863                 :          13 :                   && (n->u.memspace_sym->attr.flavor != FL_PARAMETER
    9864                 :          12 :                       || n->u.memspace_sym->ts.type != BT_INTEGER
    9865                 :          12 :                       || n->u.memspace_sym->ts.kind != gfc_c_intptr_kind
    9866                 :          12 :                       || n->u.memspace_sym->attr.dimension
    9867                 :          12 :                       || (!startswith (n->u.memspace_sym->name, "omp_")
    9868                 :           0 :                           && !startswith (n->u.memspace_sym->name, "ompx_"))
    9869                 :          12 :                       || !endswith (n->u.memspace_sym->name, "_mem_space")))
    9870                 :           2 :                 gfc_error ("Memspace %qs at %L in USES_ALLOCATORS must be "
    9871                 :             :                            "a predefined memory space",
    9872                 :             :                            n->u.memspace_sym->name, &n->where);
    9873                 :         117 :               for (; n != NULL; n = n->next)
    9874                 :             :                 {
    9875                 :          84 :                   if (n->sym->ts.type != BT_INTEGER
    9876                 :          84 :                       || n->sym->ts.kind != gfc_c_intptr_kind
    9877                 :          83 :                       || n->sym->attr.dimension)
    9878                 :           2 :                     gfc_error ("Allocator %qs at %L in USES_ALLOCATORS must "
    9879                 :             :                                "be a scalar integer of kind "
    9880                 :             :                                "%<omp_allocator_handle_kind%>", n->sym->name,
    9881                 :             :                                &n->where);
    9882                 :          82 :                   else if (n->sym->attr.flavor != FL_VARIABLE
    9883                 :          82 :                            && ((!startswith (n->sym->name, "omp_")
    9884                 :           0 :                                 && !startswith (n->sym->name, "ompx_"))
    9885                 :          39 :                                || !endswith (n->sym->name, "_mem_alloc")))
    9886                 :           1 :                     gfc_error ("Allocator %qs at %L in USES_ALLOCATORS must "
    9887                 :             :                                "either a variable or a predefined allocator",
    9888                 :             :                                n->sym->name, &n->where);
    9889                 :          81 :                   else if ((n->u.memspace_sym || n->u2.traits_sym)
    9890                 :          42 :                            && n->sym->attr.flavor != FL_VARIABLE)
    9891                 :           3 :                     gfc_error ("A memory space or traits array may not be "
    9892                 :             :                                "specified for predefined allocator %qs at %L",
    9893                 :             :                                n->sym->name, &n->where);
    9894                 :          84 :                   if (n->u2.traits_sym
    9895                 :          37 :                       && (n->u2.traits_sym->attr.flavor != FL_PARAMETER
    9896                 :          35 :                           || !n->u2.traits_sym->attr.dimension
    9897                 :          33 :                           || n->u2.traits_sym->as->rank != 1
    9898                 :          33 :                           || n->u2.traits_sym->ts.type != BT_DERIVED
    9899                 :          31 :                           || strcmp (n->u2.traits_sym->ts.u.derived->name,
    9900                 :             :                                      "omp_alloctrait") != 0))
    9901                 :             :                     {
    9902                 :           6 :                       gfc_error ("Traits array %qs in USES_ALLOCATORS %L must "
    9903                 :             :                                  "be a one-dimensional named constant array of "
    9904                 :             :                                  "type %<omp_alloctrait%>",
    9905                 :             :                                  n->u2.traits_sym->name, &n->where);
    9906                 :           6 :                       break;
    9907                 :             :                     }
    9908                 :             :                 }
    9909                 :             :               break;
    9910                 :             :             }
    9911                 :             :           default:
    9912                 :       34319 :             for (; n != NULL; n = n->next)
    9913                 :             :               {
    9914                 :       20103 :                 if (n->sym == NULL)
    9915                 :             :                   {
    9916                 :          26 :                     gcc_assert (code->op == EXEC_OMP_ALLOCATORS
    9917                 :             :                                 || code->op == EXEC_OMP_ALLOCATE);
    9918                 :          26 :                     continue;
    9919                 :             :                   }
    9920                 :       20077 :                 bool bad = false;
    9921                 :       20077 :                 bool is_reduction = (list == OMP_LIST_REDUCTION
    9922                 :             :                                      || list == OMP_LIST_REDUCTION_INSCAN
    9923                 :             :                                      || list == OMP_LIST_REDUCTION_TASK
    9924                 :             :                                      || list == OMP_LIST_IN_REDUCTION
    9925                 :       20077 :                                      || list == OMP_LIST_TASK_REDUCTION);
    9926                 :       20077 :                 if (list == OMP_LIST_REDUCTION_INSCAN)
    9927                 :             :                   has_inscan = true;
    9928                 :       20005 :                 else if (is_reduction)
    9929                 :        4728 :                   has_notinscan = true;
    9930                 :       20077 :                 if (has_inscan && has_notinscan && is_reduction)
    9931                 :             :                   {
    9932                 :           3 :                     gfc_error ("%<inscan%> and non-%<inscan%> %<reduction%> "
    9933                 :             :                                "clauses on the same construct at %L",
    9934                 :             :                                &n->where);
    9935                 :           3 :                     break;
    9936                 :             :                   }
    9937                 :       20074 :                 if (n->sym->attr.threadprivate)
    9938                 :           1 :                   gfc_error ("THREADPRIVATE object %qs in %s clause at %L",
    9939                 :             :                              n->sym->name, name, &n->where);
    9940                 :       20074 :                 if (n->sym->attr.cray_pointee)
    9941                 :          14 :                   gfc_error ("Cray pointee %qs in %s clause at %L",
    9942                 :             :                             n->sym->name, name, &n->where);
    9943                 :       20074 :                 if (n->sym->attr.associate_var)
    9944                 :          22 :                   gfc_error ("Associate name %qs in %s clause at %L",
    9945                 :          22 :                              n->sym->attr.select_type_temporary
    9946                 :           4 :                              ? n->sym->assoc->target->symtree->n.sym->name
    9947                 :             :                              : n->sym->name, name, &n->where);
    9948                 :       20074 :                 if (list != OMP_LIST_PRIVATE && is_reduction)
    9949                 :             :                   {
    9950                 :        4797 :                     if (n->sym->attr.proc_pointer)
    9951                 :           1 :                       gfc_error ("Procedure pointer %qs in %s clause at %L",
    9952                 :             :                                  n->sym->name, name, &n->where);
    9953                 :        4797 :                     if (n->sym->attr.pointer)
    9954                 :           3 :                       gfc_error ("POINTER object %qs in %s clause at %L",
    9955                 :             :                                  n->sym->name, name, &n->where);
    9956                 :        4797 :                     if (n->sym->attr.cray_pointer)
    9957                 :           5 :                       gfc_error ("Cray pointer %qs in %s clause at %L",
    9958                 :             :                                  n->sym->name, name, &n->where);
    9959                 :             :                   }
    9960                 :       20074 :                 if (code
    9961                 :       20074 :                     && (oacc_is_loop (code)
    9962                 :             :                         || code->op == EXEC_OACC_PARALLEL
    9963                 :             :                         || code->op == EXEC_OACC_SERIAL))
    9964                 :        8730 :                   check_array_not_assumed (n->sym, n->where, name);
    9965                 :       11344 :                 else if (list != OMP_LIST_UNIFORM
    9966                 :       11227 :                          && n->sym->as && n->sym->as->type == AS_ASSUMED_SIZE)
    9967                 :           2 :                   gfc_error ("Assumed size array %qs in %s clause at %L",
    9968                 :             :                              n->sym->name, name, &n->where);
    9969                 :       20074 :                 if (n->sym->attr.in_namelist && !is_reduction)
    9970                 :           0 :                   gfc_error ("Variable %qs in %s clause is used in "
    9971                 :             :                              "NAMELIST statement at %L",
    9972                 :             :                              n->sym->name, name, &n->where);
    9973                 :       20074 :                 if (n->sym->attr.pointer && n->sym->attr.intent == INTENT_IN)
    9974                 :           3 :                   switch (list)
    9975                 :             :                     {
    9976                 :           3 :                     case OMP_LIST_PRIVATE:
    9977                 :           3 :                     case OMP_LIST_LASTPRIVATE:
    9978                 :           3 :                     case OMP_LIST_LINEAR:
    9979                 :             :                     /* case OMP_LIST_REDUCTION: */
    9980                 :           3 :                       gfc_error ("INTENT(IN) POINTER %qs in %s clause at %L",
    9981                 :             :                                  n->sym->name, name, &n->where);
    9982                 :           3 :                       break;
    9983                 :             :                     default:
    9984                 :             :                       break;
    9985                 :             :                     }
    9986                 :       20074 :                 if (omp_clauses->detach
    9987                 :           3 :                     && (list == OMP_LIST_PRIVATE
    9988                 :             :                         || list == OMP_LIST_FIRSTPRIVATE
    9989                 :             :                         || list == OMP_LIST_LASTPRIVATE)
    9990                 :           3 :                     && n->sym == omp_clauses->detach->symtree->n.sym)
    9991                 :           1 :                   gfc_error ("DETACH event handle %qs in %s clause at %L",
    9992                 :             :                              n->sym->name, name, &n->where);
    9993                 :             : 
    9994                 :       20074 :                 if (!openacc
    9995                 :       20074 :                     && (list == OMP_LIST_PRIVATE
    9996                 :       20074 :                         || list == OMP_LIST_FIRSTPRIVATE)
    9997                 :        4506 :                     && ((n->sym->ts.type == BT_DERIVED
    9998                 :         142 :                          && n->sym->ts.u.derived->attr.alloc_comp)
    9999                 :        4396 :                         || n->sym->ts.type == BT_CLASS))
   10000                 :         158 :                   switch (code->op)
   10001                 :             :                     {
   10002                 :           8 :                     case EXEC_OMP_TARGET:
   10003                 :           8 :                     case EXEC_OMP_TARGET_PARALLEL:
   10004                 :           8 :                     case EXEC_OMP_TARGET_PARALLEL_DO:
   10005                 :           8 :                     case EXEC_OMP_TARGET_PARALLEL_DO_SIMD:
   10006                 :           8 :                     case EXEC_OMP_TARGET_PARALLEL_LOOP:
   10007                 :           8 :                     case EXEC_OMP_TARGET_SIMD:
   10008                 :           8 :                     case EXEC_OMP_TARGET_TEAMS:
   10009                 :           8 :                     case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE:
   10010                 :           8 :                     case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO:
   10011                 :           8 :                     case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD:
   10012                 :           8 :                     case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_SIMD:
   10013                 :           8 :                     case EXEC_OMP_TARGET_TEAMS_LOOP:
   10014                 :           8 :                       if (n->sym->ts.type == BT_DERIVED
   10015                 :           2 :                           && n->sym->ts.u.derived->attr.alloc_comp)
   10016                 :           3 :                         gfc_error ("Sorry, list item %qs at %L with allocatable"
   10017                 :             :                                    " components is not yet supported in %s "
   10018                 :             :                                    "clause", n->sym->name, &n->where,
   10019                 :             :                                    list == OMP_LIST_PRIVATE ? "PRIVATE"
   10020                 :             :                                                             : "FIRSTPRIVATE");
   10021                 :             :                       else
   10022                 :           9 :                         gfc_error ("Polymorphic list item %qs at %L in %s "
   10023                 :             :                                    "clause has unspecified behavior and "
   10024                 :             :                                    "unsupported", n->sym->name, &n->where,
   10025                 :             :                                    list == OMP_LIST_PRIVATE ? "PRIVATE"
   10026                 :             :                                                             : "FIRSTPRIVATE");
   10027                 :             :                       break;
   10028                 :             :                     default:
   10029                 :             :                       break;
   10030                 :             :                     }
   10031                 :             : 
   10032                 :       20074 :                 switch (list)
   10033                 :             :                   {
   10034                 :         103 :                   case OMP_LIST_REDUCTION_TASK:
   10035                 :         103 :                     if (code
   10036                 :         103 :                         && (code->op == EXEC_OMP_LOOP
   10037                 :             :                             || code->op == EXEC_OMP_TASKLOOP
   10038                 :             :                             || code->op == EXEC_OMP_TASKLOOP_SIMD
   10039                 :             :                             || code->op == EXEC_OMP_MASKED_TASKLOOP
   10040                 :             :                             || code->op == EXEC_OMP_MASKED_TASKLOOP_SIMD
   10041                 :             :                             || code->op == EXEC_OMP_MASTER_TASKLOOP
   10042                 :             :                             || code->op == EXEC_OMP_MASTER_TASKLOOP_SIMD
   10043                 :             :                             || code->op == EXEC_OMP_PARALLEL_LOOP
   10044                 :             :                             || code->op == EXEC_OMP_PARALLEL_MASKED_TASKLOOP
   10045                 :             :                             || code->op == EXEC_OMP_PARALLEL_MASKED_TASKLOOP_SIMD
   10046                 :             :                             || code->op == EXEC_OMP_PARALLEL_MASTER_TASKLOOP
   10047                 :             :                             || code->op == EXEC_OMP_PARALLEL_MASTER_TASKLOOP_SIMD
   10048                 :             :                             || code->op == EXEC_OMP_TARGET_PARALLEL_LOOP
   10049                 :             :                             || code->op == EXEC_OMP_TARGET_TEAMS_LOOP
   10050                 :             :                             || code->op == EXEC_OMP_TEAMS
   10051                 :             :                             || code->op == EXEC_OMP_TEAMS_DISTRIBUTE
   10052                 :             :                             || code->op == EXEC_OMP_TEAMS_LOOP))
   10053                 :             :                       {
   10054                 :          17 :                         gfc_error ("Only DEFAULT permitted as reduction-"
   10055                 :             :                                    "modifier in REDUCTION clause at %L",
   10056                 :             :                                    &n->where);
   10057                 :          17 :                         break;
   10058                 :             :                       }
   10059                 :        4780 :                     gcc_fallthrough ();
   10060                 :        4780 :                   case OMP_LIST_REDUCTION:
   10061                 :        4780 :                   case OMP_LIST_IN_REDUCTION:
   10062                 :        4780 :                   case OMP_LIST_TASK_REDUCTION:
   10063                 :        4780 :                   case OMP_LIST_REDUCTION_INSCAN:
   10064                 :        4780 :                     switch (n->u.reduction_op)
   10065                 :             :                       {
   10066                 :        2646 :                       case OMP_REDUCTION_PLUS:
   10067                 :        2646 :                       case OMP_REDUCTION_TIMES:
   10068                 :        2646 :                       case OMP_REDUCTION_MINUS:
   10069                 :        2646 :                         if (!gfc_numeric_ts (&n->sym->ts))
   10070                 :             :                           bad = true;
   10071                 :             :                         break;
   10072                 :        1112 :                       case OMP_REDUCTION_AND:
   10073                 :        1112 :                       case OMP_REDUCTION_OR:
   10074                 :        1112 :                       case OMP_REDUCTION_EQV:
   10075                 :        1112 :                       case OMP_REDUCTION_NEQV:
   10076                 :        1112 :                         if (n->sym->ts.type != BT_LOGICAL)
   10077                 :             :                           bad = true;
   10078                 :             :                         break;
   10079                 :         480 :                       case OMP_REDUCTION_MAX:
   10080                 :         480 :                       case OMP_REDUCTION_MIN:
   10081                 :         480 :                         if (n->sym->ts.type != BT_INTEGER
   10082                 :         212 :                             && n->sym->ts.type != BT_REAL)
   10083                 :             :                           bad = true;
   10084                 :             :                         break;
   10085                 :         192 :                       case OMP_REDUCTION_IAND:
   10086                 :         192 :                       case OMP_REDUCTION_IOR:
   10087                 :         192 :                       case OMP_REDUCTION_IEOR:
   10088                 :         192 :                         if (n->sym->ts.type != BT_INTEGER)
   10089                 :             :                           bad = true;
   10090                 :             :                         break;
   10091                 :             :                       case OMP_REDUCTION_USER:
   10092                 :             :                         bad = true;
   10093                 :             :                         break;
   10094                 :             :                       default:
   10095                 :             :                         break;
   10096                 :             :                       }
   10097                 :             :                     if (!bad)
   10098                 :        4209 :                       n->u2.udr = NULL;
   10099                 :             :                     else
   10100                 :             :                       {
   10101                 :         571 :                         const char *udr_name = NULL;
   10102                 :         571 :                         if (n->u2.udr)
   10103                 :             :                           {
   10104                 :         467 :                             udr_name = n->u2.udr->udr->name;
   10105                 :         467 :                             n->u2.udr->udr
   10106                 :         934 :                               = gfc_find_omp_udr (NULL, udr_name,
   10107                 :         467 :                                                   &n->sym->ts);
   10108                 :         467 :                             if (n->u2.udr->udr == NULL)
   10109                 :             :                               {
   10110                 :           0 :                                 free (n->u2.udr);
   10111                 :           0 :                                 n->u2.udr = NULL;
   10112                 :             :                               }
   10113                 :             :                           }
   10114                 :         571 :                         if (n->u2.udr == NULL)
   10115                 :             :                           {
   10116                 :         104 :                             if (udr_name == NULL)
   10117                 :         104 :                               switch (n->u.reduction_op)
   10118                 :             :                                 {
   10119                 :          50 :                                 case OMP_REDUCTION_PLUS:
   10120                 :          50 :                                 case OMP_REDUCTION_TIMES:
   10121                 :          50 :                                 case OMP_REDUCTION_MINUS:
   10122                 :          50 :                                 case OMP_REDUCTION_AND:
   10123                 :          50 :                                 case OMP_REDUCTION_OR:
   10124                 :          50 :                                 case OMP_REDUCTION_EQV:
   10125                 :          50 :                                 case OMP_REDUCTION_NEQV:
   10126                 :          50 :                                   udr_name = gfc_op2string ((gfc_intrinsic_op)
   10127                 :             :                                                             n->u.reduction_op);
   10128                 :          50 :                                   break;
   10129                 :             :                                 case OMP_REDUCTION_MAX:
   10130                 :             :                                   udr_name = "max";
   10131                 :             :                                   break;
   10132                 :           9 :                                 case OMP_REDUCTION_MIN:
   10133                 :           9 :                                   udr_name = "min";
   10134                 :           9 :                                   break;
   10135                 :          12 :                                 case OMP_REDUCTION_IAND:
   10136                 :          12 :                                   udr_name = "iand";
   10137                 :          12 :                                   break;
   10138                 :          12 :                                 case OMP_REDUCTION_IOR:
   10139                 :          12 :                                   udr_name = "ior";
   10140                 :          12 :                                   break;
   10141                 :           9 :                                 case OMP_REDUCTION_IEOR:
   10142                 :           9 :                                   udr_name = "ieor";
   10143                 :           9 :                                   break;
   10144                 :           0 :                                 default:
   10145                 :           0 :                                   gcc_unreachable ();
   10146                 :             :                                 }
   10147                 :         104 :                             gfc_error ("!$OMP DECLARE REDUCTION %s not found "
   10148                 :             :                                        "for type %s at %L", udr_name,
   10149                 :         104 :                                        gfc_typename (&n->sym->ts), &n->where);
   10150                 :             :                           }
   10151                 :             :                         else
   10152                 :             :                           {
   10153                 :         467 :                             gfc_omp_udr *udr = n->u2.udr->udr;
   10154                 :         467 :                             n->u.reduction_op = OMP_REDUCTION_USER;
   10155                 :         467 :                             n->u2.udr->combiner
   10156                 :         467 :                               = resolve_omp_udr_clause (n, udr->combiner_ns,
   10157                 :             :                                                         udr->omp_out,
   10158                 :             :                                                         udr->omp_in);
   10159                 :         467 :                             if (udr->initializer_ns)
   10160                 :         330 :                               n->u2.udr->initializer
   10161                 :         330 :                                 = resolve_omp_udr_clause (n,
   10162                 :             :                                                           udr->initializer_ns,
   10163                 :             :                                                           udr->omp_priv,
   10164                 :             :                                                           udr->omp_orig);
   10165                 :             :                           }
   10166                 :             :                       }
   10167                 :             :                     break;
   10168                 :         873 :                   case OMP_LIST_LINEAR:
   10169                 :         873 :                     if (code
   10170                 :         726 :                         && n->u.linear.op != OMP_LINEAR_DEFAULT
   10171                 :          23 :                         && n->u.linear.op != linear_op)
   10172                 :             :                       {
   10173                 :          23 :                         if (n->u.linear.old_modifier)
   10174                 :             :                           {
   10175                 :           9 :                             gfc_error ("LINEAR clause modifier used on DO or "
   10176                 :             :                                        "SIMD construct at %L", &n->where);
   10177                 :           9 :                             linear_op = n->u.linear.op;
   10178                 :             :                           }
   10179                 :          14 :                         else if (n->u.linear.op != OMP_LINEAR_VAL)
   10180                 :             :                           {
   10181                 :           6 :                             gfc_error ("LINEAR clause modifier other than VAL "
   10182                 :             :                                        "used on DO or SIMD construct at %L",
   10183                 :             :                                        &n->where);
   10184                 :           6 :                             linear_op = n->u.linear.op;
   10185                 :             :                           }
   10186                 :             :                       }
   10187                 :         850 :                     else if (n->u.linear.op != OMP_LINEAR_REF
   10188                 :         800 :                              && n->sym->ts.type != BT_INTEGER)
   10189                 :           1 :                       gfc_error ("LINEAR variable %qs must be INTEGER "
   10190                 :             :                                  "at %L", n->sym->name, &n->where);
   10191                 :         849 :                     else if ((n->u.linear.op == OMP_LINEAR_REF
   10192                 :         799 :                               || n->u.linear.op == OMP_LINEAR_UVAL)
   10193                 :          61 :                              && n->sym->attr.value)
   10194                 :           0 :                       gfc_error ("LINEAR dummy argument %qs with VALUE "
   10195                 :             :                                  "attribute with %s modifier at %L",
   10196                 :             :                                  n->sym->name,
   10197                 :             :                                  n->u.linear.op == OMP_LINEAR_REF
   10198                 :             :                                  ? "REF" : "UVAL", &n->where);
   10199                 :         849 :                     else if (n->expr)
   10200                 :             :                       {
   10201                 :         830 :                         gfc_expr *expr = n->expr;
   10202                 :         830 :                         if (!gfc_resolve_expr (expr)
   10203                 :         830 :                             || expr->ts.type != BT_INTEGER
   10204                 :        1660 :                             || expr->rank != 0)
   10205                 :           0 :                           gfc_error ("%qs in LINEAR clause at %L requires "
   10206                 :             :                                      "a scalar integer linear-step expression",
   10207                 :           0 :                                      n->sym->name, &n->where);
   10208                 :         830 :                         else if (!code && expr->expr_type != EXPR_CONSTANT)
   10209                 :             :                           {
   10210                 :          11 :                             if (expr->expr_type == EXPR_VARIABLE
   10211                 :           7 :                                 && expr->symtree->n.sym->attr.dummy
   10212                 :           6 :                                 && expr->symtree->n.sym->ns == ns)
   10213                 :             :                               {
   10214                 :           6 :                                 gfc_omp_namelist *n2;
   10215                 :           6 :                                 for (n2 = omp_clauses->lists[OMP_LIST_UNIFORM];
   10216                 :           6 :                                      n2; n2 = n2->next)
   10217                 :           6 :                                   if (n2->sym == expr->symtree->n.sym)
   10218                 :             :                                     break;
   10219                 :           6 :                                 if (n2)
   10220                 :             :                                   break;
   10221                 :             :                               }
   10222                 :           5 :                             gfc_error ("%qs in LINEAR clause at %L requires "
   10223                 :             :                                        "a constant integer linear-step "
   10224                 :             :                                        "expression or dummy argument "
   10225                 :             :                                        "specified in UNIFORM clause",
   10226                 :           5 :                                        n->sym->name, &n->where);
   10227                 :             :                           }
   10228                 :             :                       }
   10229                 :             :                     break;
   10230                 :             :                   /* Workaround for PR middle-end/26316, nothing really needs
   10231                 :             :                      to be done here for OMP_LIST_PRIVATE.  */
   10232                 :        9331 :                   case OMP_LIST_PRIVATE:
   10233                 :        9331 :                     gcc_assert (code && code->op != EXEC_NOP);
   10234                 :             :                     break;
   10235                 :          98 :                   case OMP_LIST_USE_DEVICE:
   10236                 :          98 :                       if (n->sym->attr.allocatable
   10237                 :          98 :                           || (n->sym->ts.type == BT_CLASS && CLASS_DATA (n->sym)
   10238                 :           0 :                               && CLASS_DATA (n->sym)->attr.allocatable))
   10239                 :           0 :                         gfc_error ("ALLOCATABLE object %qs in %s clause at %L",
   10240                 :             :                                    n->sym->name, name, &n->where);
   10241                 :          98 :                       if (n->sym->ts.type == BT_CLASS
   10242                 :           0 :                           && CLASS_DATA (n->sym)
   10243                 :           0 :                           && CLASS_DATA (n->sym)->attr.class_pointer)
   10244                 :           0 :                         gfc_error ("POINTER object %qs of polymorphic type in "
   10245                 :             :                                    "%s clause at %L", n->sym->name, name,
   10246                 :             :                                    &n->where);
   10247                 :          98 :                       if (n->sym->attr.cray_pointer)
   10248                 :           2 :                         gfc_error ("Cray pointer object %qs in %s clause at %L",
   10249                 :             :                                    n->sym->name, name, &n->where);
   10250                 :          96 :                       else if (n->sym->attr.cray_pointee)
   10251                 :           2 :                         gfc_error ("Cray pointee object %qs in %s clause at %L",
   10252                 :             :                                    n->sym->name, name, &n->where);
   10253                 :          94 :                       else if (n->sym->attr.flavor == FL_VARIABLE
   10254                 :          93 :                                && !n->sym->as
   10255                 :          54 :                                && !n->sym->attr.pointer)
   10256                 :          13 :                         gfc_error ("%s clause variable %qs at %L is neither "
   10257                 :             :                                    "a POINTER nor an array", name,
   10258                 :             :                                    n->sym->name, &n->where);
   10259                 :             :                       /* FALLTHRU */
   10260                 :          98 :                   case OMP_LIST_DEVICE_RESIDENT:
   10261                 :          98 :                     check_symbol_not_pointer (n->sym, n->where, name);
   10262                 :          98 :                     check_array_not_assumed (n->sym, n->where, name);
   10263                 :          98 :                     break;
   10264                 :             :                   default:
   10265                 :             :                     break;
   10266                 :             :                   }
   10267                 :             :               }
   10268                 :             :             break;
   10269                 :             :           }
   10270                 :             :       }
   10271                 :             :   /* OpenMP 5.1: use_device_ptr acts like use_device_addr, except for
   10272                 :             :      type(c_ptr).  */
   10273                 :       31620 :   if (omp_clauses->lists[OMP_LIST_USE_DEVICE_PTR])
   10274                 :             :     {
   10275                 :           9 :       gfc_omp_namelist *n_prev, *n_next, *n_addr;
   10276                 :           9 :       n_addr = omp_clauses->lists[OMP_LIST_USE_DEVICE_ADDR];
   10277                 :          28 :       for (; n_addr && n_addr->next; n_addr = n_addr->next)
   10278                 :             :         ;
   10279                 :             :       n_prev = NULL;
   10280                 :             :       n = omp_clauses->lists[OMP_LIST_USE_DEVICE_PTR];
   10281                 :          27 :       while (n)
   10282                 :             :         {
   10283                 :          18 :           n_next = n->next;
   10284                 :          18 :           if (n->sym->ts.type != BT_DERIVED
   10285                 :          18 :               || n->sym->ts.u.derived->ts.f90_type != BT_VOID)
   10286                 :             :             {
   10287                 :           0 :               n->next = NULL;
   10288                 :           0 :               if (n_addr)
   10289                 :           0 :                 n_addr->next = n;
   10290                 :             :               else
   10291                 :           0 :                 omp_clauses->lists[OMP_LIST_USE_DEVICE_ADDR] = n;
   10292                 :           0 :               n_addr = n;
   10293                 :           0 :               if (n_prev)
   10294                 :           0 :                 n_prev->next = n_next;
   10295                 :             :               else
   10296                 :           0 :                 omp_clauses->lists[OMP_LIST_USE_DEVICE_PTR] = n_next;
   10297                 :             :             }
   10298                 :             :           else
   10299                 :             :             n_prev = n;
   10300                 :             :           n = n_next;
   10301                 :             :         }
   10302                 :             :     }
   10303                 :       31620 :   if (omp_clauses->safelen_expr)
   10304                 :          93 :     resolve_positive_int_expr (omp_clauses->safelen_expr, "SAFELEN");
   10305                 :       31620 :   if (omp_clauses->simdlen_expr)
   10306                 :         123 :     resolve_positive_int_expr (omp_clauses->simdlen_expr, "SIMDLEN");
   10307                 :       31620 :   if (omp_clauses->num_teams_lower)
   10308                 :          21 :     resolve_positive_int_expr (omp_clauses->num_teams_lower, "NUM_TEAMS");
   10309                 :       31620 :   if (omp_clauses->num_teams_upper)
   10310                 :         127 :     resolve_positive_int_expr (omp_clauses->num_teams_upper, "NUM_TEAMS");
   10311                 :       31620 :   if (omp_clauses->num_teams_lower
   10312                 :          21 :       && omp_clauses->num_teams_lower->expr_type == EXPR_CONSTANT
   10313                 :           7 :       && omp_clauses->num_teams_upper->expr_type == EXPR_CONSTANT
   10314                 :           7 :       && mpz_cmp (omp_clauses->num_teams_lower->value.integer,
   10315                 :           7 :                   omp_clauses->num_teams_upper->value.integer) > 0)
   10316                 :           2 :     gfc_warning (OPT_Wopenmp, "NUM_TEAMS lower bound at %L larger than upper "
   10317                 :             :                  "bound at %L", &omp_clauses->num_teams_lower->where,
   10318                 :             :                  &omp_clauses->num_teams_upper->where);
   10319                 :       31620 :   if (omp_clauses->device)
   10320                 :         310 :     resolve_scalar_int_expr (omp_clauses->device, "DEVICE");
   10321                 :       31620 :   if (omp_clauses->filter)
   10322                 :          42 :     resolve_nonnegative_int_expr (omp_clauses->filter, "FILTER");
   10323                 :       31620 :   if (omp_clauses->hint)
   10324                 :             :     {
   10325                 :          42 :       resolve_scalar_int_expr (omp_clauses->hint, "HINT");
   10326                 :          42 :     if (omp_clauses->hint->ts.type != BT_INTEGER
   10327                 :          40 :         || omp_clauses->hint->expr_type != EXPR_CONSTANT
   10328                 :          38 :         || mpz_sgn (omp_clauses->hint->value.integer) < 0)
   10329                 :           5 :       gfc_error ("Value of HINT clause at %L shall be a valid "
   10330                 :             :                  "constant hint expression", &omp_clauses->hint->where);
   10331                 :             :     }
   10332                 :       31620 :   if (omp_clauses->priority)
   10333                 :          34 :     resolve_nonnegative_int_expr (omp_clauses->priority, "PRIORITY");
   10334                 :       31620 :   if (omp_clauses->dist_chunk_size)
   10335                 :             :     {
   10336                 :          83 :       gfc_expr *expr = omp_clauses->dist_chunk_size;
   10337                 :          83 :       if (!gfc_resolve_expr (expr)
   10338                 :          83 :           || expr->ts.type != BT_INTEGER || expr->rank != 0)
   10339                 :           0 :         gfc_error ("DIST_SCHEDULE clause's chunk_size at %L requires "
   10340                 :             :                    "a scalar INTEGER expression", &expr->where);
   10341                 :             :     }
   10342                 :       31620 :   if (omp_clauses->thread_limit)
   10343                 :          72 :     resolve_positive_int_expr (omp_clauses->thread_limit, "THREAD_LIMIT");
   10344                 :       31620 :   if (omp_clauses->grainsize)
   10345                 :          34 :     resolve_positive_int_expr (omp_clauses->grainsize, "GRAINSIZE");
   10346                 :       31620 :   if (omp_clauses->num_tasks)
   10347                 :          26 :     resolve_positive_int_expr (omp_clauses->num_tasks, "NUM_TASKS");
   10348                 :       31620 :   if (omp_clauses->grainsize && omp_clauses->num_tasks)
   10349                 :           1 :     gfc_error ("%<GRAINSIZE%> clause at %L must not be used together with "
   10350                 :             :                "%<NUM_TASKS%> clause", &omp_clauses->grainsize->where);
   10351                 :       31620 :   if (omp_clauses->lists[OMP_LIST_REDUCTION] && omp_clauses->nogroup)
   10352                 :           1 :     gfc_error ("%<REDUCTION%> clause at %L must not be used together with "
   10353                 :             :                "%<NOGROUP%> clause",
   10354                 :             :                &omp_clauses->lists[OMP_LIST_REDUCTION]->where);
   10355                 :       31620 :   if (omp_clauses->full && omp_clauses->partial)
   10356                 :           0 :     gfc_error ("%<FULL%> clause at %C must not be used together with "
   10357                 :             :                "%<PARTIAL%> clause");
   10358                 :       31620 :   if (omp_clauses->async)
   10359                 :         598 :     if (omp_clauses->async_expr)
   10360                 :         598 :       resolve_scalar_int_expr (omp_clauses->async_expr, "ASYNC");
   10361                 :       31620 :   if (omp_clauses->num_gangs_expr)
   10362                 :         682 :     resolve_positive_int_expr (omp_clauses->num_gangs_expr, "NUM_GANGS");
   10363                 :       31620 :   if (omp_clauses->num_workers_expr)
   10364                 :         599 :     resolve_positive_int_expr (omp_clauses->num_workers_expr, "NUM_WORKERS");
   10365                 :       31620 :   if (omp_clauses->vector_length_expr)
   10366                 :         569 :     resolve_positive_int_expr (omp_clauses->vector_length_expr,
   10367                 :             :                                "VECTOR_LENGTH");
   10368                 :       31620 :   if (omp_clauses->gang_num_expr)
   10369                 :         114 :     resolve_positive_int_expr (omp_clauses->gang_num_expr, "GANG");
   10370                 :       31620 :   if (omp_clauses->gang_static_expr)
   10371                 :          94 :     resolve_positive_int_expr (omp_clauses->gang_static_expr, "GANG");
   10372                 :       31620 :   if (omp_clauses->worker_expr)
   10373                 :         101 :     resolve_positive_int_expr (omp_clauses->worker_expr, "WORKER");
   10374                 :       31620 :   if (omp_clauses->vector_expr)
   10375                 :         132 :     resolve_positive_int_expr (omp_clauses->vector_expr, "VECTOR");
   10376                 :       31953 :   for (el = omp_clauses->wait_list; el; el = el->next)
   10377                 :         333 :     resolve_scalar_int_expr (el->expr, "WAIT");
   10378                 :       31620 :   if (omp_clauses->collapse && omp_clauses->tile_list)
   10379                 :           4 :     gfc_error ("Incompatible use of TILE and COLLAPSE at %L", &code->loc);
   10380                 :       31620 :   if (omp_clauses->message)
   10381                 :             :     {
   10382                 :          45 :       gfc_expr *expr = omp_clauses->message;
   10383                 :          45 :       if (!gfc_resolve_expr (expr)
   10384                 :          45 :           || expr->ts.kind != gfc_default_character_kind
   10385                 :          87 :           || expr->ts.type != BT_CHARACTER || expr->rank != 0)
   10386                 :           4 :         gfc_error ("MESSAGE clause at %L requires a scalar default-kind "
   10387                 :             :                    "CHARACTER expression", &expr->where);
   10388                 :             :     }
   10389                 :       31620 :   if (!openacc
   10390                 :       31620 :       && code
   10391                 :       18857 :       && omp_clauses->lists[OMP_LIST_MAP] == NULL
   10392                 :       15658 :       && omp_clauses->lists[OMP_LIST_USE_DEVICE_PTR] == NULL
   10393                 :       15655 :       && omp_clauses->lists[OMP_LIST_USE_DEVICE_ADDR] == NULL)
   10394                 :             :     {
   10395                 :       15632 :       const char *p = NULL;
   10396                 :       15632 :       switch (code->op)
   10397                 :             :         {
   10398                 :           1 :         case EXEC_OMP_TARGET_ENTER_DATA: p = "TARGET ENTER DATA"; break;
   10399                 :           1 :         case EXEC_OMP_TARGET_EXIT_DATA: p = "TARGET EXIT DATA"; break;
   10400                 :             :         default: break;
   10401                 :             :         }
   10402                 :       15632 :       if (code->op == EXEC_OMP_TARGET_DATA)
   10403                 :           1 :         gfc_error ("TARGET DATA must contain at least one MAP, USE_DEVICE_PTR, "
   10404                 :             :                    "or USE_DEVICE_ADDR clause at %L", &code->loc);
   10405                 :       15631 :       else if (p)
   10406                 :           2 :         gfc_error ("%s must contain at least one MAP clause at %L",
   10407                 :             :                    p, &code->loc);
   10408                 :             :     }
   10409                 :       31620 :   if (omp_clauses->sizes_list)
   10410                 :             :     {
   10411                 :             :       gfc_expr_list *el;
   10412                 :         572 :       for (el = omp_clauses->sizes_list; el; el = el->next)
   10413                 :             :         {
   10414                 :         377 :           resolve_scalar_int_expr (el->expr, "SIZES");
   10415                 :         377 :           if (el->expr->expr_type != EXPR_CONSTANT)
   10416                 :           1 :             gfc_error ("SIZES requires constant expression at %L",
   10417                 :             :                        &el->expr->where);
   10418                 :         376 :           else if (el->expr->expr_type == EXPR_CONSTANT
   10419                 :         376 :                    && el->expr->ts.type == BT_INTEGER
   10420                 :         376 :                    && mpz_sgn (el->expr->value.integer) <= 0)
   10421                 :           2 :             gfc_error ("INTEGER expression of %s clause at %L must be "
   10422                 :             :                        "positive", "SIZES", &el->expr->where);
   10423                 :             :         }
   10424                 :             :     }
   10425                 :             : 
   10426                 :       31620 :   if (!openacc && omp_clauses->detach)
   10427                 :             :     {
   10428                 :         125 :       if (!gfc_resolve_expr (omp_clauses->detach)
   10429                 :         125 :           || omp_clauses->detach->ts.type != BT_INTEGER
   10430                 :         124 :           || omp_clauses->detach->ts.kind != gfc_c_intptr_kind
   10431                 :         248 :           || omp_clauses->detach->rank != 0)
   10432                 :           3 :         gfc_error ("%qs at %L should be a scalar of type "
   10433                 :             :                    "integer(kind=omp_event_handle_kind)",
   10434                 :           3 :                    omp_clauses->detach->symtree->n.sym->name,
   10435                 :           3 :                    &omp_clauses->detach->where);
   10436                 :         122 :       else if (omp_clauses->detach->symtree->n.sym->attr.dimension > 0)
   10437                 :           1 :         gfc_error ("The event handle at %L must not be an array element",
   10438                 :             :                    &omp_clauses->detach->where);
   10439                 :         121 :       else if (omp_clauses->detach->symtree->n.sym->ts.type == BT_DERIVED
   10440                 :         120 :                || omp_clauses->detach->symtree->n.sym->ts.type == BT_CLASS)
   10441                 :           1 :         gfc_error ("The event handle at %L must not be part of "
   10442                 :             :                    "a derived type or class", &omp_clauses->detach->where);
   10443                 :             : 
   10444                 :         125 :       if (omp_clauses->mergeable)
   10445                 :           2 :         gfc_error ("%<DETACH%> clause at %L must not be used together with "
   10446                 :           2 :                    "%<MERGEABLE%> clause", &omp_clauses->detach->where);
   10447                 :             :     }
   10448                 :             : 
   10449                 :       12545 :   if (openacc
   10450                 :       12545 :       && code->op == EXEC_OACC_HOST_DATA
   10451                 :          60 :       && omp_clauses->lists[OMP_LIST_USE_DEVICE] == NULL)
   10452                 :           1 :     gfc_error ("%<host_data%> construct at %L requires %<use_device%> clause",
   10453                 :             :                &code->loc);
   10454                 :             : 
   10455                 :       31620 :   if (omp_clauses->assume)
   10456                 :          15 :     gfc_resolve_omp_assumptions (omp_clauses->assume);
   10457                 :             : }
   10458                 :             : 
   10459                 :             : 
   10460                 :             : /* Return true if SYM is ever referenced in EXPR except in the SE node.  */
   10461                 :             : 
   10462                 :             : static bool
   10463                 :        4991 : expr_references_sym (gfc_expr *e, gfc_symbol *s, gfc_expr *se)
   10464                 :             : {
   10465                 :        6617 :   gfc_actual_arglist *arg;
   10466                 :        6617 :   if (e == NULL || e == se)
   10467                 :             :     return false;
   10468                 :        5366 :   switch (e->expr_type)
   10469                 :             :     {
   10470                 :        3120 :     case EXPR_CONSTANT:
   10471                 :        3120 :     case EXPR_NULL:
   10472                 :        3120 :     case EXPR_VARIABLE:
   10473                 :        3120 :     case EXPR_STRUCTURE:
   10474                 :        3120 :     case EXPR_ARRAY:
   10475                 :        3120 :       if (e->symtree != NULL
   10476                 :        1152 :           && e->symtree->n.sym == s)
   10477                 :             :         return true;
   10478                 :             :       return false;
   10479                 :           0 :     case EXPR_SUBSTRING:
   10480                 :           0 :       if (e->ref != NULL
   10481                 :           0 :           && (expr_references_sym (e->ref->u.ss.start, s, se)
   10482                 :           0 :               || expr_references_sym (e->ref->u.ss.end, s, se)))
   10483                 :           0 :         return true;
   10484                 :             :       return false;
   10485                 :        1735 :     case EXPR_OP:
   10486                 :        1735 :       if (expr_references_sym (e->value.op.op2, s, se))
   10487                 :             :         return true;
   10488                 :        1626 :       return expr_references_sym (e->value.op.op1, s, se);
   10489                 :         511 :     case EXPR_FUNCTION:
   10490                 :         896 :       for (arg = e->value.function.actual; arg; arg = arg->next)
   10491                 :         586 :         if (expr_references_sym (arg->expr, s, se))
   10492                 :             :           return true;
   10493                 :             :       return false;
   10494                 :           0 :     default:
   10495                 :           0 :       gcc_unreachable ();
   10496                 :             :     }
   10497                 :             : }
   10498                 :             : 
   10499                 :             : 
   10500                 :             : /* If EXPR is a conversion function that widens the type
   10501                 :             :    if WIDENING is true or narrows the type if NARROW is true,
   10502                 :             :    return the inner expression, otherwise return NULL.  */
   10503                 :             : 
   10504                 :             : static gfc_expr *
   10505                 :        5911 : is_conversion (gfc_expr *expr, bool narrowing, bool widening)
   10506                 :             : {
   10507                 :        5911 :   gfc_typespec *ts1, *ts2;
   10508                 :             : 
   10509                 :        5911 :   if (expr->expr_type != EXPR_FUNCTION
   10510                 :         917 :       || expr->value.function.isym == NULL
   10511                 :         894 :       || expr->value.function.esym != NULL
   10512                 :         894 :       || expr->value.function.isym->id != GFC_ISYM_CONVERSION
   10513                 :         388 :       || (!narrowing && !widening))
   10514                 :             :     return NULL;
   10515                 :             : 
   10516                 :         388 :   if (narrowing && widening)
   10517                 :         267 :     return expr->value.function.actual->expr;
   10518                 :             : 
   10519                 :         121 :   if (widening)
   10520                 :             :     {
   10521                 :         121 :       ts1 = &expr->ts;
   10522                 :         121 :       ts2 = &expr->value.function.actual->expr->ts;
   10523                 :             :     }
   10524                 :             :   else
   10525                 :             :     {
   10526                 :           0 :       ts1 = &expr->value.function.actual->expr->ts;
   10527                 :           0 :       ts2 = &expr->ts;
   10528                 :             :     }
   10529                 :             : 
   10530                 :         121 :   if (ts1->type > ts2->type
   10531                 :          49 :       || (ts1->type == ts2->type && ts1->kind > ts2->kind))
   10532                 :         121 :     return expr->value.function.actual->expr;
   10533                 :             : 
   10534                 :             :   return NULL;
   10535                 :             : }
   10536                 :             : 
   10537                 :             : static bool
   10538                 :        6855 : is_scalar_intrinsic_expr (gfc_expr *expr, bool must_be_var, bool conv_ok)
   10539                 :             : {
   10540                 :        6855 :   if (must_be_var
   10541                 :        4020 :       && (expr->expr_type != EXPR_VARIABLE || !expr->symtree))
   10542                 :             :     {
   10543                 :          37 :       if (!conv_ok)
   10544                 :             :         return false;
   10545                 :          37 :       gfc_expr *conv = is_conversion (expr, true, true);
   10546                 :          37 :       if (!conv)
   10547                 :             :         return false;
   10548                 :          36 :       if (conv->expr_type != EXPR_VARIABLE || !conv->symtree)
   10549                 :             :         return false;
   10550                 :             :     }
   10551                 :        6852 :   return (expr->rank == 0
   10552                 :        6848 :           && !gfc_is_coindexed (expr)
   10553                 :       13700 :           && (expr->ts.type == BT_INTEGER
   10554                 :             :               || expr->ts.type == BT_REAL
   10555                 :             :               || expr->ts.type == BT_COMPLEX
   10556                 :             :               || expr->ts.type == BT_LOGICAL));
   10557                 :             : }
   10558                 :             : 
   10559                 :             : static void
   10560                 :        2697 : resolve_omp_atomic (gfc_code *code)
   10561                 :             : {
   10562                 :        2697 :   gfc_code *atomic_code = code->block;
   10563                 :        2697 :   gfc_symbol *var;
   10564                 :        2697 :   gfc_expr *stmt_expr2, *capt_expr2;
   10565                 :        2697 :   gfc_omp_atomic_op aop
   10566                 :        2697 :     = (gfc_omp_atomic_op) (atomic_code->ext.omp_clauses->atomic_op
   10567                 :             :                            & GFC_OMP_ATOMIC_MASK);
   10568                 :        2697 :   gfc_code *stmt = NULL, *capture_stmt = NULL, *tailing_stmt = NULL;
   10569                 :        2697 :   gfc_expr *comp_cond = NULL;
   10570                 :        2697 :   locus *loc = NULL;
   10571                 :             : 
   10572                 :        2697 :   code = code->block->next;
   10573                 :             :   /* resolve_blocks asserts this is initially EXEC_ASSIGN or EXEC_IF
   10574                 :             :      If it changed to EXEC_NOP, assume an error has been emitted already.  */
   10575                 :        2697 :   if (code->op == EXEC_NOP)
   10576                 :             :     return;
   10577                 :             : 
   10578                 :        2696 :   if (atomic_code->ext.omp_clauses->compare
   10579                 :        2696 :       && atomic_code->ext.omp_clauses->capture)
   10580                 :             :     {
   10581                 :             :       /* Must be either "if (x == e) then; x = d; else; v = x; end if"
   10582                 :             :          or "v = expr" followed/preceded by
   10583                 :             :          "if (x == e) then; x = d; end if" or "if (x == e) x = d".  */
   10584                 :         103 :       gfc_code *next = code;
   10585                 :         103 :       if (code->op == EXEC_ASSIGN)
   10586                 :             :         {
   10587                 :          19 :           capture_stmt = code;
   10588                 :          19 :           next = code->next;
   10589                 :             :         }
   10590                 :         103 :       if (next->op == EXEC_IF
   10591                 :         103 :           && next->block
   10592                 :         103 :           && next->block->op == EXEC_IF
   10593                 :         103 :           && next->block->next
   10594                 :         102 :           && next->block->next->op == EXEC_ASSIGN)
   10595                 :             :         {
   10596                 :         102 :           comp_cond = next->block->expr1;
   10597                 :         102 :           stmt = next->block->next;
   10598                 :         102 :           if (stmt->next)
   10599                 :             :             {
   10600                 :           0 :               loc = &stmt->loc;
   10601                 :           0 :               goto unexpected;
   10602                 :             :             }
   10603                 :             :         }
   10604                 :           1 :       else if (capture_stmt)
   10605                 :             :         {
   10606                 :           0 :           gfc_error ("Expected IF at %L in atomic compare capture",
   10607                 :             :                      &next->loc);
   10608                 :           0 :           return;
   10609                 :             :         }
   10610                 :         103 :       if (stmt && !capture_stmt && next->block->block)
   10611                 :             :         {
   10612                 :          64 :           if (next->block->block->expr1)
   10613                 :             :             {
   10614                 :           0 :               gfc_error ("Expected ELSE at %L in atomic compare capture",
   10615                 :             :                          &next->block->block->expr1->where);
   10616                 :           0 :               return;
   10617                 :             :             }
   10618                 :          64 :           if (!code->block->block->next
   10619                 :          64 :               || code->block->block->next->op != EXEC_ASSIGN)
   10620                 :             :             {
   10621                 :           0 :               loc = (code->block->block->next ? &code->block->block->next->loc
   10622                 :             :                                               : &code->block->block->loc);
   10623                 :           0 :               goto unexpected;
   10624                 :             :             }
   10625                 :          64 :           capture_stmt = code->block->block->next;
   10626                 :          64 :           if (capture_stmt->next)
   10627                 :             :             {
   10628                 :           0 :               loc = &capture_stmt->next->loc;
   10629                 :           0 :               goto unexpected;
   10630                 :             :             }
   10631                 :             :         }
   10632                 :         103 :       if (stmt && !capture_stmt && next->next->op == EXEC_ASSIGN)
   10633                 :             :         capture_stmt = next->next;
   10634                 :          84 :       else if (!capture_stmt)
   10635                 :             :         {
   10636                 :           1 :           loc = &code->loc;
   10637                 :           1 :           goto unexpected;
   10638                 :             :         }
   10639                 :             :     }
   10640                 :        2593 :   else if (atomic_code->ext.omp_clauses->compare)
   10641                 :             :     {
   10642                 :             :       /* Must be: "if (x == e) then; x = d; end if" or "if (x == e) x = d".  */
   10643                 :          53 :       if (code->op == EXEC_IF
   10644                 :          53 :           && code->block
   10645                 :          53 :           && code->block->op == EXEC_IF
   10646                 :          53 :           && code->block->next
   10647                 :          51 :           && code->block->next->op == EXEC_ASSIGN)
   10648                 :             :         {
   10649                 :          51 :           comp_cond = code->block->expr1;
   10650                 :          51 :           stmt = code->block->next;
   10651                 :          51 :           if (stmt->next || code->block->block)
   10652                 :             :             {
   10653                 :           0 :               loc = stmt->next ? &stmt->next->loc : &code->block->block->loc;
   10654                 :           0 :               goto unexpected;
   10655                 :             :             }
   10656                 :             :         }
   10657                 :             :       else
   10658                 :             :         {
   10659                 :           2 :           loc = &code->loc;
   10660                 :           2 :           goto unexpected;
   10661                 :             :         }
   10662                 :             :     }
   10663                 :        2540 :   else if (atomic_code->ext.omp_clauses->capture)
   10664                 :             :     {
   10665                 :             :       /* Must be: "v = x" followed/preceded by "x = ...". */
   10666                 :         489 :       if (code->op != EXEC_ASSIGN)
   10667                 :           0 :         goto unexpected;
   10668                 :         489 :       if (code->next->op != EXEC_ASSIGN)
   10669                 :             :         {
   10670                 :           0 :           loc = &code->next->loc;
   10671                 :           0 :           goto unexpected;
   10672                 :             :         }
   10673                 :         489 :       gfc_expr *expr2, *expr2_next;
   10674                 :         489 :       expr2 = is_conversion (code->expr2, true, true);
   10675                 :         489 :       if (expr2 == NULL)
   10676                 :         447 :         expr2 = code->expr2;
   10677                 :         489 :       expr2_next = is_conversion (code->next->expr2, true, true);
   10678                 :         489 :       if (expr2_next == NULL)
   10679                 :         478 :         expr2_next = code->next->expr2;
   10680                 :         489 :       if (code->expr1->expr_type == EXPR_VARIABLE
   10681                 :         489 :           && code->next->expr1->expr_type == EXPR_VARIABLE
   10682                 :         489 :           && expr2->expr_type == EXPR_VARIABLE
   10683                 :         243 :           && expr2_next->expr_type == EXPR_VARIABLE)
   10684                 :             :         {
   10685                 :           1 :           if (code->expr1->symtree->n.sym == expr2_next->symtree->n.sym)
   10686                 :             :             {
   10687                 :             :               stmt = code;
   10688                 :             :               capture_stmt = code->next;
   10689                 :             :             }
   10690                 :             :           else
   10691                 :             :             {
   10692                 :         242 :               capture_stmt = code;
   10693                 :         242 :               stmt = code->next;
   10694                 :             :             }
   10695                 :             :         }
   10696                 :         488 :       else if (expr2->expr_type == EXPR_VARIABLE)
   10697                 :             :         {
   10698                 :             :           capture_stmt = code;
   10699                 :             :           stmt = code->next;
   10700                 :             :         }
   10701                 :             :       else
   10702                 :             :         {
   10703                 :         489 :           stmt = code;
   10704                 :         489 :           capture_stmt = code->next;
   10705                 :             :         }
   10706                 :             :       /* Shall be NULL but can happen for invalid code. */
   10707                 :         489 :       tailing_stmt = code->next->next;
   10708                 :             :     }
   10709                 :             :   else
   10710                 :             :     {
   10711                 :             :       /* x = ... */
   10712                 :        2051 :       stmt = code;
   10713                 :        2051 :       if (!atomic_code->ext.omp_clauses->compare && stmt->op != EXEC_ASSIGN)
   10714                 :           1 :         goto unexpected;
   10715                 :             :       /* Shall be NULL but can happen for invalid code. */
   10716                 :        2050 :       tailing_stmt = code->next;
   10717                 :             :     }
   10718                 :             : 
   10719                 :        2692 :   if (comp_cond)
   10720                 :             :     {
   10721                 :         153 :       if (comp_cond->expr_type != EXPR_OP
   10722                 :         153 :           || (comp_cond->value.op.op != INTRINSIC_EQ
   10723                 :             :               && comp_cond->value.op.op != INTRINSIC_EQ_OS
   10724                 :             :               && comp_cond->value.op.op != INTRINSIC_EQV))
   10725                 :             :         {
   10726                 :           0 :           gfc_error ("Expected %<==%>, %<.EQ.%> or %<.EQV.%> atomic comparison "
   10727                 :             :                      "expression at %L", &comp_cond->where);
   10728                 :           0 :           return;
   10729                 :             :         }
   10730                 :         153 :       if (!is_scalar_intrinsic_expr (comp_cond->value.op.op1, true, true))
   10731                 :             :         {
   10732                 :           1 :           gfc_error ("Expected scalar intrinsic variable at %L in atomic "
   10733                 :           1 :                      "comparison", &comp_cond->value.op.op1->where);
   10734                 :           1 :           return;
   10735                 :             :         }
   10736                 :         152 :       if (!gfc_resolve_expr (comp_cond->value.op.op2))
   10737                 :             :         return;
   10738                 :         152 :       if (!is_scalar_intrinsic_expr (comp_cond->value.op.op2, false, false))
   10739                 :             :         {
   10740                 :           0 :           gfc_error ("Expected scalar intrinsic expression at %L in atomic "
   10741                 :           0 :                      "comparison", &comp_cond->value.op.op1->where);
   10742                 :           0 :           return;
   10743                 :             :         }
   10744                 :             :     }
   10745                 :             : 
   10746                 :        2691 :   if (!is_scalar_intrinsic_expr (stmt->expr1, true, false))
   10747                 :             :     {
   10748                 :           4 :       gfc_error ("!$OMP ATOMIC statement must set a scalar variable of "
   10749                 :           4 :                  "intrinsic type at %L", &stmt->expr1->where);
   10750                 :           4 :       return;
   10751                 :             :     }
   10752                 :             : 
   10753                 :        2687 :   if (!gfc_resolve_expr (stmt->expr2))
   10754                 :             :     return;
   10755                 :        2683 :   if (!is_scalar_intrinsic_expr (stmt->expr2, false, false))
   10756                 :             :     {
   10757                 :           0 :       gfc_error ("!$OMP ATOMIC statement must assign an expression of "
   10758                 :           0 :                  "intrinsic type at %L", &stmt->expr2->where);
   10759                 :           0 :       return;
   10760                 :             :     }
   10761                 :             : 
   10762                 :        2683 :   if (gfc_expr_attr (stmt->expr1).allocatable)
   10763                 :             :     {
   10764                 :           0 :       gfc_error ("!$OMP ATOMIC with ALLOCATABLE variable at %L",
   10765                 :           0 :                  &stmt->expr1->where);
   10766                 :           0 :       return;
   10767                 :             :     }
   10768                 :             : 
   10769                 :             :   /* Should be diagnosed above already. */
   10770                 :        2683 :   gcc_assert (tailing_stmt == NULL);
   10771                 :             : 
   10772                 :        2683 :   var = stmt->expr1->symtree->n.sym;
   10773                 :        2683 :   stmt_expr2 = is_conversion (stmt->expr2, true, true);
   10774                 :        2683 :   if (stmt_expr2 == NULL)
   10775                 :        2527 :     stmt_expr2 = stmt->expr2;
   10776                 :             : 
   10777                 :        2683 :   switch (aop)
   10778                 :             :     {
   10779                 :         503 :     case GFC_OMP_ATOMIC_READ:
   10780                 :         503 :       if (stmt_expr2->expr_type != EXPR_VARIABLE)
   10781                 :           0 :         gfc_error ("!$OMP ATOMIC READ statement must read from a scalar "
   10782                 :             :                    "variable of intrinsic type at %L", &stmt_expr2->where);
   10783                 :             :       return;
   10784                 :         421 :     case GFC_OMP_ATOMIC_WRITE:
   10785                 :         421 :       if (expr_references_sym (stmt_expr2, var, NULL))
   10786                 :           0 :         gfc_error ("expr in !$OMP ATOMIC WRITE assignment var = expr "
   10787                 :             :                    "must be scalar and cannot reference var at %L",
   10788                 :             :                    &stmt_expr2->where);
   10789                 :             :       return;
   10790                 :        1759 :     default:
   10791                 :        1759 :       break;
   10792                 :             :     }
   10793                 :             : 
   10794                 :        1759 :   if (atomic_code->ext.omp_clauses->capture)
   10795                 :             :     {
   10796                 :         588 :       if (!is_scalar_intrinsic_expr (capture_stmt->expr1, true, false))
   10797                 :             :         {
   10798                 :           0 :           gfc_error ("!$OMP ATOMIC capture-statement must set a scalar "
   10799                 :             :                      "variable of intrinsic type at %L",
   10800                 :           0 :                      &capture_stmt->expr1->where);
   10801                 :           0 :           return;
   10802                 :             :         }
   10803                 :             : 
   10804                 :         588 :       if (!is_scalar_intrinsic_expr (capture_stmt->expr2, true, true))
   10805                 :             :         {
   10806                 :           2 :           gfc_error ("!$OMP ATOMIC capture-statement requires a scalar variable"
   10807                 :           2 :                      " of intrinsic type at %L", &capture_stmt->expr2->where);
   10808                 :           2 :           return;
   10809                 :             :         }
   10810                 :         586 :       capt_expr2 = is_conversion (capture_stmt->expr2, true, true);
   10811                 :         586 :       if (capt_expr2 == NULL)
   10812                 :         564 :         capt_expr2 = capture_stmt->expr2;
   10813                 :             : 
   10814                 :         586 :       if (capt_expr2->symtree->n.sym != var)
   10815                 :             :         {
   10816                 :           1 :           gfc_error ("!$OMP ATOMIC CAPTURE capture statement reads from "
   10817                 :             :                      "different variable than update statement writes "
   10818                 :             :                      "into at %L", &capture_stmt->expr2->where);
   10819                 :           1 :               return;
   10820                 :             :         }
   10821                 :             :     }
   10822                 :             : 
   10823                 :        1756 :   if (atomic_code->ext.omp_clauses->compare)
   10824                 :             :     {
   10825                 :         149 :       gfc_expr *var_expr;
   10826                 :         149 :       if (comp_cond->value.op.op1->expr_type == EXPR_VARIABLE)
   10827                 :             :         var_expr = comp_cond->value.op.op1;
   10828                 :             :       else
   10829                 :          12 :         var_expr = comp_cond->value.op.op1->value.function.actual->expr;
   10830                 :         149 :       if (var_expr->symtree->n.sym != var)
   10831                 :             :         {
   10832                 :           2 :           gfc_error ("For !$OMP ATOMIC COMPARE, the first operand in comparison"
   10833                 :             :                      " at %L must be the variable %qs that the update statement"
   10834                 :             :                      " writes into at %L", &var_expr->where, var->name,
   10835                 :           2 :                      &stmt->expr1->where);
   10836                 :           2 :           return;
   10837                 :             :         }
   10838                 :         147 :       if (stmt_expr2->rank != 0 || expr_references_sym (stmt_expr2, var, NULL))
   10839                 :             :         {
   10840                 :           1 :           gfc_error ("expr in !$OMP ATOMIC COMPARE assignment var = expr "
   10841                 :             :                      "must be scalar and cannot reference var at %L",
   10842                 :             :                      &stmt_expr2->where);
   10843                 :           1 :           return;
   10844                 :             :         }
   10845                 :             :     }
   10846                 :        1607 :   else if (atomic_code->ext.omp_clauses->capture
   10847                 :        1607 :            && !expr_references_sym (stmt_expr2, var, NULL))
   10848                 :          22 :     atomic_code->ext.omp_clauses->atomic_op
   10849                 :          22 :       = (gfc_omp_atomic_op) (atomic_code->ext.omp_clauses->atomic_op
   10850                 :             :                              | GFC_OMP_ATOMIC_SWAP);
   10851                 :        1585 :   else if (stmt_expr2->expr_type == EXPR_OP)
   10852                 :             :     {
   10853                 :        1229 :       gfc_expr *v = NULL, *e, *c;
   10854                 :        1229 :       gfc_intrinsic_op op = stmt_expr2->value.op.op;
   10855                 :        1229 :       gfc_intrinsic_op alt_op = INTRINSIC_NONE;
   10856                 :             : 
   10857                 :        1229 :       if (atomic_code->ext.omp_clauses->fail != OMP_MEMORDER_UNSET)
   10858                 :           3 :         gfc_error ("!$OMP ATOMIC UPDATE at %L with FAIL clause requires either"
   10859                 :             :                    " the COMPARE clause or using the intrinsic MIN/MAX "
   10860                 :             :                    "procedure", &atomic_code->loc);
   10861                 :        1229 :       switch (op)
   10862                 :             :         {
   10863                 :         742 :         case INTRINSIC_PLUS:
   10864                 :         742 :           alt_op = INTRINSIC_MINUS;
   10865                 :         742 :           break;
   10866                 :          94 :         case INTRINSIC_TIMES:
   10867                 :          94 :           alt_op = INTRINSIC_DIVIDE;
   10868                 :          94 :           break;
   10869                 :         120 :         case INTRINSIC_MINUS:
   10870                 :         120 :           alt_op = INTRINSIC_PLUS;
   10871                 :         120 :           break;
   10872                 :          94 :         case INTRINSIC_DIVIDE:
   10873                 :          94 :           alt_op = INTRINSIC_TIMES;
   10874                 :          94 :           break;
   10875                 :             :         case INTRINSIC_AND:
   10876                 :             :         case INTRINSIC_OR:
   10877                 :             :           break;
   10878                 :          43 :         case INTRINSIC_EQV:
   10879                 :          43 :           alt_op = INTRINSIC_NEQV;
   10880                 :          43 :           break;
   10881                 :          43 :         case INTRINSIC_NEQV:
   10882                 :          43 :           alt_op = INTRINSIC_EQV;
   10883                 :          43 :           break;
   10884                 :           1 :         default:
   10885                 :           1 :           gfc_error ("!$OMP ATOMIC assignment operator must be binary "
   10886                 :             :                      "+, *, -, /, .AND., .OR., .EQV. or .NEQV. at %L",
   10887                 :             :                      &stmt_expr2->where);
   10888                 :           1 :           return;
   10889                 :             :         }
   10890                 :             : 
   10891                 :             :       /* Check for var = var op expr resp. var = expr op var where
   10892                 :             :          expr doesn't reference var and var op expr is mathematically
   10893                 :             :          equivalent to var op (expr) resp. expr op var equivalent to
   10894                 :             :          (expr) op var.  We rely here on the fact that the matcher
   10895                 :             :          for x op1 y op2 z where op1 and op2 have equal precedence
   10896                 :             :          returns (x op1 y) op2 z.  */
   10897                 :        1228 :       e = stmt_expr2->value.op.op2;
   10898                 :        1228 :       if (e->expr_type == EXPR_VARIABLE
   10899                 :         288 :           && e->symtree != NULL
   10900                 :         288 :           && e->symtree->n.sym == var)
   10901                 :             :         v = e;
   10902                 :         999 :       else if ((c = is_conversion (e, false, true)) != NULL
   10903                 :          48 :                && c->expr_type == EXPR_VARIABLE
   10904                 :          48 :                && c->symtree != NULL
   10905                 :        1047 :                && c->symtree->n.sym == var)
   10906                 :             :         v = c;
   10907                 :             :       else
   10908                 :             :         {
   10909                 :         951 :           gfc_expr **p = NULL, **q;
   10910                 :        1049 :           for (q = &stmt_expr2->value.op.op1; (e = *q) != NULL; )
   10911                 :        1049 :             if (e->expr_type == EXPR_VARIABLE
   10912                 :         948 :                 && e->symtree != NULL
   10913                 :         948 :                 && e->symtree->n.sym == var)
   10914                 :             :               {
   10915                 :             :                 v = e;
   10916                 :             :                 break;
   10917                 :             :               }
   10918                 :         101 :             else if ((c = is_conversion (e, false, true)) != NULL)
   10919                 :          60 :               q = &e->value.function.actual->expr;
   10920                 :          41 :             else if (e->expr_type != EXPR_OP
   10921                 :          41 :                      || (e->value.op.op != op
   10922                 :          15 :                          && e->value.op.op != alt_op)
   10923                 :          38 :                      || e->rank != 0)
   10924                 :             :               break;
   10925                 :             :             else
   10926                 :             :               {
   10927                 :          38 :                 p = q;
   10928                 :          38 :                 q = &e->value.op.op1;
   10929                 :             :               }
   10930                 :             : 
   10931                 :         951 :           if (v == NULL)
   10932                 :             :             {
   10933                 :           3 :               gfc_error ("!$OMP ATOMIC assignment must be var = var op expr "
   10934                 :             :                          "or var = expr op var at %L", &stmt_expr2->where);
   10935                 :           3 :               return;
   10936                 :             :             }
   10937                 :             : 
   10938                 :         948 :           if (p != NULL)
   10939                 :             :             {
   10940                 :          38 :               e = *p;
   10941                 :          38 :               switch (e->value.op.op)
   10942                 :             :                 {
   10943                 :           8 :                 case INTRINSIC_MINUS:
   10944                 :           8 :                 case INTRINSIC_DIVIDE:
   10945                 :           8 :                 case INTRINSIC_EQV:
   10946                 :           8 :                 case INTRINSIC_NEQV:
   10947                 :           8 :                   gfc_error ("!$OMP ATOMIC var = var op expr not "
   10948                 :             :                              "mathematically equivalent to var = var op "
   10949                 :             :                              "(expr) at %L", &stmt_expr2->where);
   10950                 :           8 :                   break;
   10951                 :             :                 default:
   10952                 :             :                   break;
   10953                 :             :                 }
   10954                 :             : 
   10955                 :             :               /* Canonicalize into var = var op (expr).  */
   10956                 :          38 :               *p = e->value.op.op2;
   10957                 :          38 :               e->value.op.op2 = stmt_expr2;
   10958                 :          38 :               e->ts = stmt_expr2->ts;
   10959                 :          38 :               if (stmt->expr2 == stmt_expr2)
   10960                 :          26 :                 stmt->expr2 = stmt_expr2 = e;
   10961                 :             :               else
   10962                 :          12 :                 stmt->expr2->value.function.actual->expr = stmt_expr2 = e;
   10963                 :             : 
   10964                 :          38 :               if (!gfc_compare_types (&stmt_expr2->value.op.op1->ts,
   10965                 :             :                                       &stmt_expr2->ts))
   10966                 :             :                 {
   10967                 :          24 :                   for (p = &stmt_expr2->value.op.op1; *p != v;
   10968                 :          12 :                        p = &(*p)->value.function.actual->expr)
   10969                 :             :                     ;
   10970                 :          12 :                   *p = NULL;
   10971                 :          12 :                   gfc_free_expr (stmt_expr2->value.op.op1);
   10972                 :          12 :                   stmt_expr2->value.op.op1 = v;
   10973                 :          12 :                   gfc_convert_type (v, &stmt_expr2->ts, 2);
   10974                 :             :                 }
   10975                 :             :             }
   10976                 :             :         }
   10977                 :             : 
   10978                 :        1225 :       if (e->rank != 0 || expr_references_sym (stmt->expr2, var, v))
   10979                 :             :         {
   10980                 :           1 :           gfc_error ("expr in !$OMP ATOMIC assignment var = var op expr "
   10981                 :             :                      "must be scalar and cannot reference var at %L",
   10982                 :             :                      &stmt_expr2->where);
   10983                 :           1 :           return;
   10984                 :             :         }
   10985                 :             :     }
   10986                 :         356 :   else if (stmt_expr2->expr_type == EXPR_FUNCTION
   10987                 :         355 :            && stmt_expr2->value.function.isym != NULL
   10988                 :         355 :            && stmt_expr2->value.function.esym == NULL
   10989                 :         355 :            && stmt_expr2->value.function.actual != NULL
   10990                 :         355 :            && stmt_expr2->value.function.actual->next != NULL)
   10991                 :             :     {
   10992                 :         355 :       gfc_actual_arglist *arg, *var_arg;
   10993                 :             : 
   10994                 :         355 :       switch (stmt_expr2->value.function.isym->id)
   10995                 :             :         {
   10996                 :             :         case GFC_ISYM_MIN:
   10997                 :             :         case GFC_ISYM_MAX:
   10998                 :             :           break;
   10999                 :         147 :         case GFC_ISYM_IAND:
   11000                 :         147 :         case GFC_ISYM_IOR:
   11001                 :         147 :         case GFC_ISYM_IEOR:
   11002                 :         147 :           if (stmt_expr2->value.function.actual->next->next != NULL)
   11003                 :             :             {
   11004                 :           0 :               gfc_error ("!$OMP ATOMIC assignment intrinsic IAND, IOR "
   11005                 :             :                          "or IEOR must have two arguments at %L",
   11006                 :             :                          &stmt_expr2->where);
   11007                 :           0 :               return;
   11008                 :             :             }
   11009                 :             :           break;
   11010                 :           1 :         default:
   11011                 :           1 :           gfc_error ("!$OMP ATOMIC assignment intrinsic must be "
   11012                 :             :                      "MIN, MAX, IAND, IOR or IEOR at %L",
   11013                 :             :                      &stmt_expr2->where);
   11014                 :           1 :           return;
   11015                 :             :         }
   11016                 :             : 
   11017                 :             :       var_arg = NULL;
   11018                 :        1088 :       for (arg = stmt_expr2->value.function.actual; arg; arg = arg->next)
   11019                 :             :         {
   11020                 :         741 :           gfc_expr *e = NULL;
   11021                 :         741 :           if (arg == stmt_expr2->value.function.actual
   11022                 :         387 :               || (var_arg == NULL && arg->next == NULL))
   11023                 :             :             {
   11024                 :         527 :               e = is_conversion (arg->expr, false, true);
   11025                 :         527 :               if (!e)
   11026                 :         514 :                 e = arg->expr;
   11027                 :         527 :               if (e->expr_type == EXPR_VARIABLE
   11028                 :         453 :                   && e->symtree != NULL
   11029                 :         453 :                   && e->symtree->n.sym == var)
   11030                 :         741 :                 var_arg = arg;
   11031                 :             :             }
   11032                 :         741 :           if ((!var_arg || !e) && expr_references_sym (arg->expr, var, NULL))
   11033                 :             :             {
   11034                 :           7 :               gfc_error ("!$OMP ATOMIC intrinsic arguments except one must "
   11035                 :             :                          "not reference %qs at %L",
   11036                 :             :                          var->name, &arg->expr->where);
   11037                 :           7 :               return;
   11038                 :             :             }
   11039                 :         734 :           if (arg->expr->rank != 0)
   11040                 :             :             {
   11041                 :           0 :               gfc_error ("!$OMP ATOMIC intrinsic arguments must be scalar "
   11042                 :             :                          "at %L", &arg->expr->where);
   11043                 :           0 :               return;
   11044                 :             :             }
   11045                 :             :         }
   11046                 :             : 
   11047                 :         347 :       if (var_arg == NULL)
   11048                 :             :         {
   11049                 :           1 :           gfc_error ("First or last !$OMP ATOMIC intrinsic argument must "
   11050                 :             :                      "be %qs at %L", var->name, &stmt_expr2->where);
   11051                 :           1 :           return;
   11052                 :             :         }
   11053                 :             : 
   11054                 :         346 :       if (var_arg != stmt_expr2->value.function.actual)
   11055                 :             :         {
   11056                 :             :           /* Canonicalize, so that var comes first.  */
   11057                 :         172 :           gcc_assert (var_arg->next == NULL);
   11058                 :             :           for (arg = stmt_expr2->value.function.actual;
   11059                 :         185 :                arg->next != var_arg; arg = arg->next)
   11060                 :             :             ;
   11061                 :         172 :           var_arg->next = stmt_expr2->value.function.actual;
   11062                 :         172 :           stmt_expr2->value.function.actual = var_arg;
   11063                 :         172 :           arg->next = NULL;
   11064                 :             :         }
   11065                 :             :     }
   11066                 :             :   else
   11067                 :           1 :     gfc_error ("!$OMP ATOMIC assignment must have an operator or "
   11068                 :             :                "intrinsic on right hand side at %L", &stmt_expr2->where);
   11069                 :             :   return;
   11070                 :             : 
   11071                 :           4 : unexpected:
   11072                 :           4 :   gfc_error ("unexpected !$OMP ATOMIC expression at %L",
   11073                 :             :              loc ? loc : &code->loc);
   11074                 :           4 :   return;
   11075                 :             : }
   11076                 :             : 
   11077                 :             : 
   11078                 :             : static struct fortran_omp_context
   11079                 :             : {
   11080                 :             :   gfc_code *code;
   11081                 :             :   hash_set<gfc_symbol *> *sharing_clauses;
   11082                 :             :   hash_set<gfc_symbol *> *private_iterators;
   11083                 :             :   struct fortran_omp_context *previous;
   11084                 :             :   bool is_openmp;
   11085                 :             : } *omp_current_ctx;
   11086                 :             : static gfc_code *omp_current_do_code;
   11087                 :             : static int omp_current_do_collapse;
   11088                 :             : 
   11089                 :             : /* Forward declaration for mutually recursive functions.  */
   11090                 :             : static gfc_code *
   11091                 :             : find_nested_loop_in_block (gfc_code *block);
   11092                 :             : 
   11093                 :             : /* Return the first nested DO loop in CHAIN, or NULL if there
   11094                 :             :    isn't one.  Does no error checking on intervening code.  */
   11095                 :             : 
   11096                 :             : static gfc_code *
   11097                 :       27378 : find_nested_loop_in_chain (gfc_code *chain)
   11098                 :             : {
   11099                 :       27378 :   gfc_code *code;
   11100                 :             : 
   11101                 :       27378 :   if (!chain)
   11102                 :             :     return NULL;
   11103                 :             : 
   11104                 :       31519 :   for (code = chain; code; code = code->next)
   11105                 :       31098 :     switch (code->op)
   11106                 :             :       {
   11107                 :             :       case EXEC_DO:
   11108                 :             :       case EXEC_OMP_TILE:
   11109                 :             :       case EXEC_OMP_UNROLL:
   11110                 :             :         return code;
   11111                 :         612 :       case EXEC_BLOCK:
   11112                 :         612 :         if (gfc_code *c = find_nested_loop_in_block (code))
   11113                 :             :           return c;
   11114                 :             :         break;
   11115                 :             :       default:
   11116                 :             :         break;
   11117                 :             :       }
   11118                 :             :   return NULL;
   11119                 :             : }
   11120                 :             : 
   11121                 :             : /* Return the first nested DO loop in BLOCK, or NULL if there
   11122                 :             :    isn't one.  Does no error checking on intervening code.  */
   11123                 :             : static gfc_code *
   11124                 :         930 : find_nested_loop_in_block (gfc_code *block)
   11125                 :             : {
   11126                 :         930 :   gfc_namespace *ns;
   11127                 :         930 :   gcc_assert (block->op == EXEC_BLOCK);
   11128                 :         930 :   ns = block->ext.block.ns;
   11129                 :         930 :   gcc_assert (ns);
   11130                 :         930 :   return find_nested_loop_in_chain (ns->code);
   11131                 :             : }
   11132                 :             : 
   11133                 :             : void
   11134                 :        5366 : gfc_resolve_omp_do_blocks (gfc_code *code, gfc_namespace *ns)
   11135                 :             : {
   11136                 :        5366 :   if (code->block->next && code->block->next->op == EXEC_DO)
   11137                 :             :     {
   11138                 :        5013 :       int i;
   11139                 :             : 
   11140                 :        5013 :       omp_current_do_code = code->block->next;
   11141                 :        5013 :       if (code->ext.omp_clauses->orderedc)
   11142                 :         140 :         omp_current_do_collapse = code->ext.omp_clauses->orderedc;
   11143                 :        4873 :       else if (code->ext.omp_clauses->collapse)
   11144                 :        1106 :         omp_current_do_collapse = code->ext.omp_clauses->collapse;
   11145                 :        3767 :       else if (code->ext.omp_clauses->sizes_list)
   11146                 :         175 :         omp_current_do_collapse
   11147                 :         175 :           = gfc_expr_list_len (code->ext.omp_clauses->sizes_list);
   11148                 :             :       else
   11149                 :        3592 :         omp_current_do_collapse = 1;
   11150                 :        5013 :       if (code->ext.omp_clauses->lists[OMP_LIST_REDUCTION_INSCAN])
   11151                 :             :         {
   11152                 :             :           /* Checking that there is a matching EXEC_OMP_SCAN in the
   11153                 :             :              innermost body cannot be deferred to resolve_omp_do because
   11154                 :             :              we process directives nested in the loop before we get
   11155                 :             :              there.  */
   11156                 :          60 :           locus *loc
   11157                 :             :             = &code->ext.omp_clauses->lists[OMP_LIST_REDUCTION_INSCAN]->where;
   11158                 :          60 :           gfc_code *c;
   11159                 :             : 
   11160                 :          80 :           for (i = 1, c = omp_current_do_code;
   11161                 :          80 :                i < omp_current_do_collapse; i++)
   11162                 :             :             {
   11163                 :          22 :               c = find_nested_loop_in_chain (c->block->next);
   11164                 :          22 :               if (!c || c->op != EXEC_DO || c->block == NULL)
   11165                 :             :                 break;
   11166                 :             :             }
   11167                 :             : 
   11168                 :             :           /* Skip this if we don't have enough nested loops.  That
   11169                 :             :              problem will be diagnosed elsewhere.  */
   11170                 :          60 :           if (c && c->op == EXEC_DO)
   11171                 :             :             {
   11172                 :          58 :               gfc_code *block = c->block ? c->block->next : NULL;
   11173                 :          58 :               if (block && block->op != EXEC_OMP_SCAN)
   11174                 :          54 :                 while (block && block->next
   11175                 :          54 :                        && block->next->op != EXEC_OMP_SCAN)
   11176                 :             :                   block = block->next;
   11177                 :          43 :               if (!block
   11178                 :          46 :                   || (block->op != EXEC_OMP_SCAN
   11179                 :          43 :                       && (!block->next || block->next->op != EXEC_OMP_SCAN)))
   11180                 :          19 :                 gfc_error ("With INSCAN at %L, expected loop body with "
   11181                 :             :                            "!$OMP SCAN between two "
   11182                 :             :                            "structured block sequences", loc);
   11183                 :             :               else
   11184                 :             :                 {
   11185                 :          39 :                   if (block->op == EXEC_OMP_SCAN)
   11186                 :           3 :                     gfc_warning (OPT_Wopenmp,
   11187                 :             :                                  "!$OMP SCAN at %L with zero executable "
   11188                 :             :                                  "statements in preceding structured block "
   11189                 :             :                                  "sequence", &block->loc);
   11190                 :          39 :                   if ((block->op == EXEC_OMP_SCAN && !block->next)
   11191                 :          38 :                       || (block->next && block->next->op == EXEC_OMP_SCAN
   11192                 :          36 :                           && !block->next->next))
   11193                 :           3 :                     gfc_warning (OPT_Wopenmp,
   11194                 :             :                                  "!$OMP SCAN at %L with zero executable "
   11195                 :             :                                  "statements in succeeding structured block "
   11196                 :             :                                  "sequence", block->op == EXEC_OMP_SCAN
   11197                 :           1 :                                  ? &block->loc : &block->next->loc);
   11198                 :             :                 }
   11199                 :          58 :               if (block && block->op != EXEC_OMP_SCAN)
   11200                 :          43 :                 block = block->next;
   11201                 :          46 :               if (block && block->op == EXEC_OMP_SCAN)
   11202                 :             :                 /* Mark 'omp scan' as checked; flag will be unset later.  */
   11203                 :          39 :                 block->ext.omp_clauses->if_present = true;
   11204                 :             :             }
   11205                 :             :         }
   11206                 :             :     }
   11207                 :        5366 :   gfc_resolve_blocks (code->block, ns);
   11208                 :        5366 :   omp_current_do_collapse = 0;
   11209                 :        5366 :   omp_current_do_code = NULL;
   11210                 :        5366 : }
   11211                 :             : 
   11212                 :             : 
   11213                 :             : void
   11214                 :        5958 : gfc_resolve_omp_parallel_blocks (gfc_code *code, gfc_namespace *ns)
   11215                 :             : {
   11216                 :        5958 :   struct fortran_omp_context ctx;
   11217                 :        5958 :   gfc_omp_clauses *omp_clauses = code->ext.omp_clauses;
   11218                 :        5958 :   gfc_omp_namelist *n;
   11219                 :        5958 :   int list;
   11220                 :             : 
   11221                 :        5958 :   ctx.code = code;
   11222                 :        5958 :   ctx.sharing_clauses = new hash_set<gfc_symbol *>;
   11223                 :        5958 :   ctx.private_iterators = new hash_set<gfc_symbol *>;
   11224                 :        5958 :   ctx.previous = omp_current_ctx;
   11225                 :        5958 :   ctx.is_openmp = true;
   11226                 :        5958 :   omp_current_ctx = &ctx;
   11227                 :             : 
   11228                 :      232362 :   for (list = 0; list < OMP_LIST_NUM; list++)
   11229                 :      226404 :     switch (list)
   11230                 :             :       {
   11231                 :       59580 :       case OMP_LIST_SHARED:
   11232                 :       59580 :       case OMP_LIST_PRIVATE:
   11233                 :       59580 :       case OMP_LIST_FIRSTPRIVATE:
   11234                 :       59580 :       case OMP_LIST_LASTPRIVATE:
   11235                 :       59580 :       case OMP_LIST_REDUCTION:
   11236                 :       59580 :       case OMP_LIST_REDUCTION_INSCAN:
   11237                 :       59580 :       case OMP_LIST_REDUCTION_TASK:
   11238                 :       59580 :       case OMP_LIST_IN_REDUCTION:
   11239                 :       59580 :       case OMP_LIST_TASK_REDUCTION:
   11240                 :       59580 :       case OMP_LIST_LINEAR:
   11241                 :       68476 :         for (n = omp_clauses->lists[list]; n; n = n->next)
   11242                 :        8896 :           ctx.sharing_clauses->add (n->sym);
   11243                 :             :         break;
   11244                 :             :       default:
   11245                 :             :         break;
   11246                 :             :       }
   11247                 :             : 
   11248                 :        5958 :   switch (code->op)
   11249                 :             :     {
   11250                 :        2327 :     case EXEC_OMP_DISTRIBUTE_PARALLEL_DO:
   11251                 :        2327 :     case EXEC_OMP_DISTRIBUTE_PARALLEL_DO_SIMD:
   11252                 :        2327 :     case EXEC_OMP_MASKED_TASKLOOP:
   11253                 :        2327 :     case EXEC_OMP_MASKED_TASKLOOP_SIMD:
   11254                 :        2327 :     case EXEC_OMP_MASTER_TASKLOOP:
   11255                 :        2327 :     case EXEC_OMP_MASTER_TASKLOOP_SIMD:
   11256                 :        2327 :     case EXEC_OMP_PARALLEL_DO:
   11257                 :        2327 :     case EXEC_OMP_PARALLEL_DO_SIMD:
   11258                 :        2327 :     case EXEC_OMP_PARALLEL_LOOP:
   11259                 :        2327 :     case EXEC_OMP_PARALLEL_MASKED_TASKLOOP:
   11260                 :        2327 :     case EXEC_OMP_PARALLEL_MASKED_TASKLOOP_SIMD:
   11261                 :        2327 :     case EXEC_OMP_PARALLEL_MASTER_TASKLOOP:
   11262                 :        2327 :     case EXEC_OMP_PARALLEL_MASTER_TASKLOOP_SIMD:
   11263                 :        2327 :     case EXEC_OMP_TARGET_PARALLEL_DO:
   11264                 :        2327 :     case EXEC_OMP_TARGET_PARALLEL_DO_SIMD:
   11265                 :        2327 :     case EXEC_OMP_TARGET_PARALLEL_LOOP:
   11266                 :        2327 :     case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE:
   11267                 :        2327 :     case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO:
   11268                 :        2327 :     case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD:
   11269                 :        2327 :     case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_SIMD:
   11270                 :        2327 :     case EXEC_OMP_TARGET_TEAMS_LOOP:
   11271                 :        2327 :     case EXEC_OMP_TASKLOOP:
   11272                 :        2327 :     case EXEC_OMP_TASKLOOP_SIMD:
   11273                 :        2327 :     case EXEC_OMP_TEAMS_DISTRIBUTE:
   11274                 :        2327 :     case EXEC_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO:
   11275                 :        2327 :     case EXEC_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD:
   11276                 :        2327 :     case EXEC_OMP_TEAMS_DISTRIBUTE_SIMD:
   11277                 :        2327 :     case EXEC_OMP_TEAMS_LOOP:
   11278                 :        2327 :       gfc_resolve_omp_do_blocks (code, ns);
   11279                 :        2327 :       break;
   11280                 :        3631 :     default:
   11281                 :        3631 :       gfc_resolve_blocks (code->block, ns);
   11282                 :             :     }
   11283                 :             : 
   11284                 :        5958 :   omp_current_ctx = ctx.previous;
   11285                 :       11916 :   delete ctx.sharing_clauses;
   11286                 :       11916 :   delete ctx.private_iterators;
   11287                 :        5958 : }
   11288                 :             : 
   11289                 :             : 
   11290                 :             : /* Save and clear openmp.cc private state.  */
   11291                 :             : 
   11292                 :             : void
   11293                 :      271943 : gfc_omp_save_and_clear_state (struct gfc_omp_saved_state *state)
   11294                 :             : {
   11295                 :      271943 :   state->ptrs[0] = omp_current_ctx;
   11296                 :      271943 :   state->ptrs[1] = omp_current_do_code;
   11297                 :      271943 :   state->ints[0] = omp_current_do_collapse;
   11298                 :      271943 :   omp_current_ctx = NULL;
   11299                 :      271943 :   omp_current_do_code = NULL;
   11300                 :      271943 :   omp_current_do_collapse = 0;
   11301                 :      271943 : }
   11302                 :             : 
   11303                 :             : 
   11304                 :             : /* Restore openmp.cc private state from the saved state.  */
   11305                 :             : 
   11306                 :             : void
   11307                 :      271942 : gfc_omp_restore_state (struct gfc_omp_saved_state *state)
   11308                 :             : {
   11309                 :      271942 :   omp_current_ctx = (struct fortran_omp_context *) state->ptrs[0];
   11310                 :      271942 :   omp_current_do_code = (gfc_code *) state->ptrs[1];
   11311                 :      271942 :   omp_current_do_collapse = state->ints[0];
   11312                 :      271942 : }
   11313                 :             : 
   11314                 :             : 
   11315                 :             : /* Note a DO iterator variable.  This is special in !$omp parallel
   11316                 :             :    construct, where they are predetermined private.  */
   11317                 :             : 
   11318                 :             : void
   11319                 :       32276 : gfc_resolve_do_iterator (gfc_code *code, gfc_symbol *sym, bool add_clause)
   11320                 :             : {
   11321                 :       32276 :   if (omp_current_ctx == NULL)
   11322                 :             :     return;
   11323                 :             : 
   11324                 :       13020 :   int i = omp_current_do_collapse;
   11325                 :       13020 :   gfc_code *c = omp_current_do_code;
   11326                 :             : 
   11327                 :       13020 :   if (sym->attr.threadprivate)
   11328                 :             :     return;
   11329                 :             : 
   11330                 :             :   /* !$omp do and !$omp parallel do iteration variable is predetermined
   11331                 :             :      private just in the !$omp do resp. !$omp parallel do construct,
   11332                 :             :      with no implications for the outer parallel constructs.  */
   11333                 :             : 
   11334                 :       17840 :   while (i-- >= 1 && c)
   11335                 :             :     {
   11336                 :        9435 :       if (code == c)
   11337                 :             :         return;
   11338                 :        4820 :       c = find_nested_loop_in_chain (c->block->next);
   11339                 :        4820 :       if (c && (c->op == EXEC_OMP_TILE || c->op == EXEC_OMP_UNROLL))
   11340                 :             :         return;
   11341                 :             :     }
   11342                 :             : 
   11343                 :             :   /* An openacc context may represent a data clause.  Abort if so.  */
   11344                 :        8405 :   if (!omp_current_ctx->is_openmp && !oacc_is_loop (omp_current_ctx->code))
   11345                 :             :     return;
   11346                 :             : 
   11347                 :        7429 :   if (omp_current_ctx->sharing_clauses->contains (sym))
   11348                 :             :     return;
   11349                 :             : 
   11350                 :        6430 :   if (! omp_current_ctx->private_iterators->add (sym) && add_clause)
   11351                 :             :     {
   11352                 :        6257 :       gfc_omp_clauses *omp_clauses = omp_current_ctx->code->ext.omp_clauses;
   11353                 :        6257 :       gfc_omp_namelist *p;
   11354                 :             : 
   11355                 :        6257 :       p = gfc_get_omp_namelist ();
   11356                 :        6257 :       p->sym = sym;
   11357                 :        6257 :       p->where = omp_current_ctx->code->loc;
   11358                 :        6257 :       p->next = omp_clauses->lists[OMP_LIST_PRIVATE];
   11359                 :        6257 :       omp_clauses->lists[OMP_LIST_PRIVATE] = p;
   11360                 :             :     }
   11361                 :             : }
   11362                 :             : 
   11363                 :             : static void
   11364                 :         667 : handle_local_var (gfc_symbol *sym)
   11365                 :             : {
   11366                 :         667 :   if (sym->attr.flavor != FL_VARIABLE
   11367                 :         161 :       || sym->as != NULL
   11368                 :         129 :       || (sym->ts.type != BT_INTEGER && sym->ts.type != BT_REAL))
   11369                 :             :     return;
   11370                 :          66 :   gfc_resolve_do_iterator (sym->ns->code, sym, false);
   11371                 :             : }
   11372                 :             : 
   11373                 :             : void
   11374                 :      315870 : gfc_resolve_omp_local_vars (gfc_namespace *ns)
   11375                 :             : {
   11376                 :      315870 :   if (omp_current_ctx)
   11377                 :         444 :     gfc_traverse_ns (ns, handle_local_var);
   11378                 :      315870 : }
   11379                 :             : 
   11380                 :             : 
   11381                 :             : /* Error checking on intervening code uses a code walker.  */
   11382                 :             : 
   11383                 :             : struct icode_error_state
   11384                 :             : {
   11385                 :             :   const char *name;
   11386                 :             :   bool errorp;
   11387                 :             :   gfc_code *nested;
   11388                 :             :   gfc_code *next;
   11389                 :             : };
   11390                 :             : 
   11391                 :             : static int
   11392                 :         944 : icode_code_error_callback (gfc_code **codep,
   11393                 :             :                            int *walk_subtrees ATTRIBUTE_UNUSED, void *opaque)
   11394                 :             : {
   11395                 :         944 :   gfc_code *code = *codep;
   11396                 :         944 :   icode_error_state *state = (icode_error_state *)opaque;
   11397                 :             : 
   11398                 :             :   /* gfc_code_walker walks down CODE's next chain as well as
   11399                 :             :      walking things that are actually nested in CODE.  We need to
   11400                 :             :      special-case traversal of outer blocks, so stop immediately if we
   11401                 :             :      are heading down such a next chain.  */
   11402                 :         944 :   if (code == state->next)
   11403                 :             :     return 1;
   11404                 :             : 
   11405                 :         649 :   switch (code->op)
   11406                 :             :     {
   11407                 :           1 :     case EXEC_DO:
   11408                 :           1 :     case EXEC_DO_WHILE:
   11409                 :           1 :     case EXEC_DO_CONCURRENT:
   11410                 :           1 :       gfc_error ("%s cannot contain loop in intervening code at %L",
   11411                 :             :                  state->name, &code->loc);
   11412                 :           1 :       state->errorp = true;
   11413                 :           1 :       break;
   11414                 :           0 :     case EXEC_CYCLE:
   11415                 :           0 :     case EXEC_EXIT:
   11416                 :             :       /* Errors have already been diagnosed in match_exit_cycle.  */
   11417                 :           0 :       state->errorp = true;
   11418                 :           0 :       break;
   11419                 :           1 :     case EXEC_OMP_CRITICAL:
   11420                 :           1 :     case EXEC_OMP_DO:
   11421                 :           1 :     case EXEC_OMP_FLUSH:
   11422                 :           1 :     case EXEC_OMP_MASTER:
   11423                 :           1 :     case EXEC_OMP_ORDERED:
   11424                 :           1 :     case EXEC_OMP_PARALLEL:
   11425                 :           1 :     case EXEC_OMP_PARALLEL_DO:
   11426                 :           1 :     case EXEC_OMP_PARALLEL_SECTIONS:
   11427                 :           1 :     case EXEC_OMP_PARALLEL_WORKSHARE:
   11428                 :           1 :     case EXEC_OMP_SECTIONS:
   11429                 :           1 :     case EXEC_OMP_SINGLE:
   11430                 :           1 :     case EXEC_OMP_WORKSHARE:
   11431                 :           1 :     case EXEC_OMP_ATOMIC:
   11432                 :           1 :     case EXEC_OMP_BARRIER:
   11433                 :           1 :     case EXEC_OMP_END_NOWAIT:
   11434                 :           1 :     case EXEC_OMP_END_SINGLE:
   11435                 :           1 :     case EXEC_OMP_TASK:
   11436                 :           1 :     case EXEC_OMP_TASKWAIT:
   11437                 :           1 :     case EXEC_OMP_TASKYIELD:
   11438                 :           1 :     case EXEC_OMP_CANCEL:
   11439                 :           1 :     case EXEC_OMP_CANCELLATION_POINT:
   11440                 :           1 :     case EXEC_OMP_TASKGROUP:
   11441                 :           1 :     case EXEC_OMP_SIMD:
   11442                 :           1 :     case EXEC_OMP_DO_SIMD:
   11443                 :           1 :     case EXEC_OMP_PARALLEL_DO_SIMD:
   11444                 :           1 :     case EXEC_OMP_TARGET:
   11445                 :           1 :     case EXEC_OMP_TARGET_DATA:
   11446                 :           1 :     case EXEC_OMP_TEAMS:
   11447                 :           1 :     case EXEC_OMP_DISTRIBUTE:
   11448                 :           1 :     case EXEC_OMP_DISTRIBUTE_SIMD:
   11449                 :           1 :     case EXEC_OMP_DISTRIBUTE_PARALLEL_DO:
   11450                 :           1 :     case EXEC_OMP_DISTRIBUTE_PARALLEL_DO_SIMD:
   11451                 :           1 :     case EXEC_OMP_TARGET_TEAMS:
   11452                 :           1 :     case EXEC_OMP_TEAMS_DISTRIBUTE:
   11453                 :           1 :     case EXEC_OMP_TEAMS_DISTRIBUTE_SIMD:
   11454                 :           1 :     case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE:
   11455                 :           1 :     case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_SIMD:
   11456                 :           1 :     case EXEC_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO:
   11457                 :           1 :     case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO:
   11458                 :           1 :     case EXEC_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD:
   11459                 :           1 :     case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD:
   11460                 :           1 :     case EXEC_OMP_TARGET_UPDATE:
   11461                 :           1 :     case EXEC_OMP_END_CRITICAL:
   11462                 :           1 :     case EXEC_OMP_TARGET_ENTER_DATA:
   11463                 :           1 :     case EXEC_OMP_TARGET_EXIT_DATA:
   11464                 :           1 :     case EXEC_OMP_TARGET_PARALLEL:
   11465                 :           1 :     case EXEC_OMP_TARGET_PARALLEL_DO:
   11466                 :           1 :     case EXEC_OMP_TARGET_PARALLEL_DO_SIMD:
   11467                 :           1 :     case EXEC_OMP_TARGET_SIMD:
   11468                 :           1 :     case EXEC_OMP_TASKLOOP:
   11469                 :           1 :     case EXEC_OMP_TASKLOOP_SIMD:
   11470                 :           1 :     case EXEC_OMP_SCAN:
   11471                 :           1 :     case EXEC_OMP_DEPOBJ:
   11472                 :           1 :     case EXEC_OMP_PARALLEL_MASTER:
   11473                 :           1 :     case EXEC_OMP_PARALLEL_MASTER_TASKLOOP:
   11474                 :           1 :     case EXEC_OMP_PARALLEL_MASTER_TASKLOOP_SIMD:
   11475                 :           1 :     case EXEC_OMP_MASTER_TASKLOOP:
   11476                 :           1 :     case EXEC_OMP_MASTER_TASKLOOP_SIMD:
   11477                 :           1 :     case EXEC_OMP_LOOP:
   11478                 :           1 :     case EXEC_OMP_PARALLEL_LOOP:
   11479                 :           1 :     case EXEC_OMP_TEAMS_LOOP:
   11480                 :           1 :     case EXEC_OMP_TARGET_PARALLEL_LOOP:
   11481                 :           1 :     case EXEC_OMP_TARGET_TEAMS_LOOP:
   11482                 :           1 :     case EXEC_OMP_MASKED:
   11483                 :           1 :     case EXEC_OMP_PARALLEL_MASKED:
   11484                 :           1 :     case EXEC_OMP_PARALLEL_MASKED_TASKLOOP:
   11485                 :           1 :     case EXEC_OMP_PARALLEL_MASKED_TASKLOOP_SIMD:
   11486                 :           1 :     case EXEC_OMP_MASKED_TASKLOOP:
   11487                 :           1 :     case EXEC_OMP_MASKED_TASKLOOP_SIMD:
   11488                 :           1 :     case EXEC_OMP_SCOPE:
   11489                 :           1 :     case EXEC_OMP_ERROR:
   11490                 :           1 :     case EXEC_OMP_DISPATCH:
   11491                 :           1 :       gfc_error ("%s cannot contain OpenMP directive in intervening code "
   11492                 :             :                  "at %L",
   11493                 :             :                  state->name, &code->loc);
   11494                 :           1 :       state->errorp = true;
   11495                 :           1 :       break;
   11496                 :         477 :     case EXEC_CALL:
   11497                 :             :       /* Per OpenMP 5.2, the "omp_" prefix is reserved, so we don't have to
   11498                 :             :          consider the possibility that some locally-bound definition
   11499                 :             :          overrides the runtime routine.  */
   11500                 :         477 :       if (code->resolved_sym
   11501                 :         477 :           && omp_runtime_api_procname (code->resolved_sym->name))
   11502                 :             :         {
   11503                 :           1 :           gfc_error ("%s cannot contain OpenMP API call in intervening code "
   11504                 :             :                      "at %L",
   11505                 :             :                  state->name, &code->loc);
   11506                 :           1 :           state->errorp = true;
   11507                 :             :         }
   11508                 :             :       break;
   11509                 :             :     default:
   11510                 :             :       break;
   11511                 :             :     }
   11512                 :             :   return 0;
   11513                 :             : }
   11514                 :             : 
   11515                 :             : static int
   11516                 :        1074 : icode_expr_error_callback (gfc_expr **expr,
   11517                 :             :                            int *walk_subtrees ATTRIBUTE_UNUSED, void *opaque)
   11518                 :             : {
   11519                 :        1074 :   icode_error_state *state = (icode_error_state *)opaque;
   11520                 :             : 
   11521                 :        1074 :   switch ((*expr)->expr_type)
   11522                 :             :     {
   11523                 :             :       /* As for EXPR_CALL with "omp_"-prefixed symbols.  */
   11524                 :           1 :     case EXPR_FUNCTION:
   11525                 :           1 :       {
   11526                 :           1 :         gfc_symbol *sym = (*expr)->value.function.esym;
   11527                 :           1 :         if (sym && omp_runtime_api_procname (sym->name))
   11528                 :             :           {
   11529                 :           1 :             gfc_error ("%s cannot contain OpenMP API call in intervening code "
   11530                 :             :                        "at %L",
   11531                 :           1 :                        state->name, &((*expr)->where));
   11532                 :           1 :             state->errorp = true;
   11533                 :             :           }
   11534                 :             :         }
   11535                 :             : 
   11536                 :             :       break;
   11537                 :             :     default:
   11538                 :             :       break;
   11539                 :             :     }
   11540                 :             : 
   11541                 :             :   /* FIXME: The description of canonical loop form in the OpenMP standard
   11542                 :             :      also says "array expressions" are not permitted in intervening code.
   11543                 :             :      That term is not defined in either the OpenMP spec or the Fortran
   11544                 :             :      standard, although the latter uses it informally to refer to any
   11545                 :             :      expression that is not scalar-valued.  It is also apparently not the
   11546                 :             :      thing GCC internally calls EXPR_ARRAY.  It seems the intent of the
   11547                 :             :      OpenMP restriction is to disallow elemental operations/intrinsics
   11548                 :             :      (including things that are not expressions, like assignment
   11549                 :             :      statements) that generate implicit loops over array operands
   11550                 :             :      (even if the result is a scalar), but even if the spec said
   11551                 :             :      that there is no list of all the cases that would be forbidden.
   11552                 :             :      This is OpenMP issue 3326.  */
   11553                 :             : 
   11554                 :        1074 :   return 0;
   11555                 :             : }
   11556                 :             : 
   11557                 :             : static void
   11558                 :         270 : diagnose_intervening_code_errors_1 (gfc_code *chain,
   11559                 :             :                                     struct icode_error_state *state)
   11560                 :             : {
   11561                 :         270 :   gfc_code *code;
   11562                 :        1089 :   for (code = chain; code; code = code->next)
   11563                 :             :     {
   11564                 :         819 :       if (code == state->nested)
   11565                 :             :         /* Do not walk the nested loop or its body, we are only
   11566                 :             :            interested in intervening code.  */
   11567                 :             :         ;
   11568                 :         639 :       else if (code->op == EXEC_BLOCK
   11569                 :         639 :                && find_nested_loop_in_block (code) == state->nested)
   11570                 :             :         /* This block contains the nested loop, recurse on its
   11571                 :             :            statements.  */
   11572                 :             :         {
   11573                 :          90 :           gfc_namespace* ns = code->ext.block.ns;
   11574                 :          90 :           diagnose_intervening_code_errors_1 (ns->code, state);
   11575                 :             :         }
   11576                 :             :       else
   11577                 :             :         /* Treat the whole statement as a unit.  */
   11578                 :             :         {
   11579                 :         549 :           gfc_code *temp = state->next;
   11580                 :         549 :           state->next = code->next;
   11581                 :         549 :           gfc_code_walker (&code, icode_code_error_callback,
   11582                 :             :                            icode_expr_error_callback, state);
   11583                 :         549 :           state->next = temp;
   11584                 :             :         }
   11585                 :             :     }
   11586                 :         270 : }
   11587                 :             : 
   11588                 :             : /* Diagnose intervening code errors in BLOCK with nested loop NESTED.
   11589                 :             :    NAME is the user-friendly name of the OMP directive, used for error
   11590                 :             :    messages.  Returns true if any error was found.  */
   11591                 :             : static bool
   11592                 :         180 : diagnose_intervening_code_errors (gfc_code *chain, const char *name,
   11593                 :             :                                   gfc_code *nested)
   11594                 :             : {
   11595                 :         180 :   struct icode_error_state state;
   11596                 :         180 :   state.name = name;
   11597                 :         180 :   state.errorp = false;
   11598                 :         180 :   state.nested = nested;
   11599                 :         180 :   state.next = NULL;
   11600                 :           0 :   diagnose_intervening_code_errors_1 (chain, &state);
   11601                 :         180 :   return state.errorp;
   11602                 :             : }
   11603                 :             : 
   11604                 :             : /* Helper function for restructure_intervening_code:  wrap CHAIN in
   11605                 :             :    a marker to indicate that it is a structured block sequence.  That
   11606                 :             :    information will be used later on (in omp-low.cc) for error checking.  */
   11607                 :             : static gfc_code *
   11608                 :         455 : make_structured_block (gfc_code *chain)
   11609                 :             : {
   11610                 :         455 :   gcc_assert (chain);
   11611                 :         455 :   gfc_namespace *ns = gfc_build_block_ns (gfc_current_ns);
   11612                 :         455 :   gfc_code *result = gfc_get_code (EXEC_BLOCK);
   11613                 :         455 :   result->op = EXEC_BLOCK;
   11614                 :         455 :   result->ext.block.ns = ns;
   11615                 :         455 :   result->ext.block.assoc = NULL;
   11616                 :         455 :   result->loc = chain->loc;
   11617                 :         455 :   ns->omp_structured_block = 1;
   11618                 :         455 :   ns->code = chain;
   11619                 :         455 :   return result;
   11620                 :             : }
   11621                 :             : 
   11622                 :             : /* Push intervening code surrounding a loop, including nested scopes,
   11623                 :             :    into the body of the loop.  CHAINP is the pointer to the head of
   11624                 :             :    the next-chain to scan, OUTER_LOOP is the EXEC_DO for the next outer
   11625                 :             :    loop level, and COLLAPSE is the number of nested loops we need to
   11626                 :             :    process.
   11627                 :             :    Note that CHAINP may point at outer_loop->block->next when we
   11628                 :             :    are scanning the body of a loop, but if there is an intervening block
   11629                 :             :    CHAINP points into the block's chain rather than its enclosing outer
   11630                 :             :    loop.  This is why OUTER_LOOP is passed separately.  */
   11631                 :             : static gfc_code *
   11632                 :        7102 : restructure_intervening_code (gfc_code **chainp, gfc_code *outer_loop,
   11633                 :             :                               int count)
   11634                 :             : {
   11635                 :        7102 :   gfc_code *code;
   11636                 :        7102 :   gfc_code *head = *chainp;
   11637                 :        7102 :   gfc_code *tail = NULL;
   11638                 :        7102 :   gfc_code *innermost_loop = NULL;
   11639                 :             : 
   11640                 :        7365 :   for (code = *chainp; code; code = code->next, chainp = &(*chainp)->next)
   11641                 :             :     {
   11642                 :        7365 :       if (code->op == EXEC_DO)
   11643                 :             :         {
   11644                 :             :           /* Cut CODE free from its chain, leaving the ends dangling.  */
   11645                 :        7018 :           *chainp = NULL;
   11646                 :        7018 :           tail = code->next;
   11647                 :        7018 :           code->next = NULL;
   11648                 :             : 
   11649                 :        7018 :           if (count == 1)
   11650                 :             :             innermost_loop = code;
   11651                 :             :           else
   11652                 :        2075 :             innermost_loop
   11653                 :        2075 :               = restructure_intervening_code (&code->block->next,
   11654                 :             :                                               code, count - 1);
   11655                 :             :           break;
   11656                 :             :         }
   11657                 :         347 :       else if (code->op == EXEC_BLOCK
   11658                 :         347 :                && find_nested_loop_in_block (code))
   11659                 :             :         {
   11660                 :          84 :           gfc_namespace *ns = code->ext.block.ns;
   11661                 :             : 
   11662                 :             :           /* Cut CODE free from its chain, leaving the ends dangling.  */
   11663                 :          84 :           *chainp = NULL;
   11664                 :          84 :           tail = code->next;
   11665                 :          84 :           code->next = NULL;
   11666                 :             : 
   11667                 :          84 :           innermost_loop
   11668                 :          84 :             = restructure_intervening_code (&ns->code, outer_loop,
   11669                 :             :                                             count);
   11670                 :             : 
   11671                 :             :           /* At this point we have already pulled out the nested loop and
   11672                 :             :              pointed outer_loop at it, and moved the intervening code that
   11673                 :             :              was previously in the block into the body of innermost_loop.
   11674                 :             :              Now we want to move the BLOCK itself so it wraps the entire
   11675                 :             :              current body of innermost_loop.  */
   11676                 :          84 :           ns->code = innermost_loop->block->next;
   11677                 :          84 :           innermost_loop->block->next = code;
   11678                 :          84 :           break;
   11679                 :             :         }
   11680                 :             :     }
   11681                 :             : 
   11682                 :        2159 :   gcc_assert (innermost_loop);
   11683                 :             : 
   11684                 :             :   /* Now we have split the intervening code into two parts:
   11685                 :             :      head is the start of the part before the loop/block, terminating
   11686                 :             :      at *chainp, and tail is the part after it.  Mark each part as
   11687                 :             :      a structured block sequence, and splice the two parts around the
   11688                 :             :      existing body of the innermost loop.  */
   11689                 :        7102 :   if (head != code)
   11690                 :             :     {
   11691                 :         221 :       gfc_code *block = make_structured_block (head);
   11692                 :         221 :       if (innermost_loop->block->next)
   11693                 :         220 :         gfc_append_code (block, innermost_loop->block->next);
   11694                 :         221 :       innermost_loop->block->next = block;
   11695                 :             :     }
   11696                 :        7102 :   if (tail)
   11697                 :             :     {
   11698                 :         234 :       gfc_code *block = make_structured_block (tail);
   11699                 :         234 :       if (innermost_loop->block->next)
   11700                 :         232 :         gfc_append_code (innermost_loop->block->next, block);
   11701                 :             :       else
   11702                 :           2 :         innermost_loop->block->next = block;
   11703                 :             :     }
   11704                 :             : 
   11705                 :             :   /* For loops, finally splice CODE into OUTER_LOOP.  We already handled
   11706                 :             :      relinking EXEC_BLOCK above.  */
   11707                 :        7102 :   if (code->op == EXEC_DO && outer_loop)
   11708                 :        7018 :     outer_loop->block->next = code;
   11709                 :             : 
   11710                 :        7102 :   return innermost_loop;
   11711                 :             : }
   11712                 :             : 
   11713                 :             : /* CODE is an OMP loop construct.  Return true if VAR matches an iteration
   11714                 :             :    variable outer to level DEPTH.  */
   11715                 :             : static bool
   11716                 :        8013 : is_outer_iteration_variable (gfc_code *code, int depth, gfc_symbol *var)
   11717                 :             : {
   11718                 :        8013 :   int i;
   11719                 :        8013 :   gfc_code *do_code = code;
   11720                 :             : 
   11721                 :       12524 :   for (i = 1; i < depth; i++)
   11722                 :             :     {
   11723                 :        5012 :       do_code = find_nested_loop_in_chain (do_code->block->next);
   11724                 :        5012 :       gcc_assert (do_code);
   11725                 :        5012 :       if (do_code->op == EXEC_OMP_TILE || do_code->op == EXEC_OMP_UNROLL)
   11726                 :             :         {
   11727                 :          51 :           --i;
   11728                 :          51 :           continue;
   11729                 :             :         }
   11730                 :        4961 :       gfc_symbol *ivar = do_code->ext.iterator->var->symtree->n.sym;
   11731                 :        4961 :       if (var == ivar)
   11732                 :             :         return true;
   11733                 :             :     }
   11734                 :             :   return false;
   11735                 :             : }
   11736                 :             : 
   11737                 :             : /* Forward declaration for recursive functions.  */
   11738                 :             : static gfc_code *
   11739                 :             : check_nested_loop_in_block (gfc_code *block, gfc_expr *expr, gfc_symbol *sym,
   11740                 :             :                             bool *bad);
   11741                 :             : 
   11742                 :             : /* Like find_nested_loop_in_chain, but additionally check that EXPR
   11743                 :             :    does not reference any variables bound in intervening EXEC_BLOCKs
   11744                 :             :    and that SYM is not bound in such intervening blocks.  Either EXPR or SYM
   11745                 :             :    may be null.  Sets *BAD to true if either test fails.  */
   11746                 :             : static gfc_code *
   11747                 :       47821 : check_nested_loop_in_chain (gfc_code *chain, gfc_expr *expr, gfc_symbol *sym,
   11748                 :             :                             bool *bad)
   11749                 :             : {
   11750                 :       51417 :   for (gfc_code *code = chain; code; code = code->next)
   11751                 :             :     {
   11752                 :       51129 :       if (code->op == EXEC_DO)
   11753                 :             :         return code;
   11754                 :        4115 :       else if (code->op == EXEC_OMP_TILE || code->op == EXEC_OMP_UNROLL)
   11755                 :        1682 :         return check_nested_loop_in_chain (code->block->next, expr, sym, bad);
   11756                 :        2433 :       else if (code->op == EXEC_BLOCK)
   11757                 :             :         {
   11758                 :         807 :           gfc_code *c = check_nested_loop_in_block (code, expr, sym, bad);
   11759                 :         807 :           if (c)
   11760                 :             :             return c;
   11761                 :             :         }
   11762                 :             :     }
   11763                 :             :   return NULL;
   11764                 :             : }
   11765                 :             : 
   11766                 :             : /* Code walker for block symtrees.  It doesn't take any kind of state
   11767                 :             :    argument, so use a static variable.  */
   11768                 :             : static struct check_nested_loop_in_block_state_t {
   11769                 :             :   gfc_expr *expr;
   11770                 :             :   gfc_symbol *sym;
   11771                 :             :   bool *bad;
   11772                 :             : } check_nested_loop_in_block_state;
   11773                 :             : 
   11774                 :             : static void
   11775                 :         766 : check_nested_loop_in_block_symbol (gfc_symbol *sym)
   11776                 :             : {
   11777                 :         766 :   if (sym == check_nested_loop_in_block_state.sym
   11778                 :         766 :       || (check_nested_loop_in_block_state.expr
   11779                 :         567 :           && gfc_find_sym_in_expr (sym,
   11780                 :             :                                    check_nested_loop_in_block_state.expr)))
   11781                 :           5 :     *check_nested_loop_in_block_state.bad = true;
   11782                 :         766 : }
   11783                 :             : 
   11784                 :             : /* Return the first nested DO loop in BLOCK, or NULL if there
   11785                 :             :    isn't one.  Set *BAD to true if EXPR references any variables in BLOCK, or
   11786                 :             :    SYM is bound in BLOCK.  Either EXPR or SYM may be null.  */
   11787                 :             : static gfc_code *
   11788                 :         807 : check_nested_loop_in_block (gfc_code *block, gfc_expr *expr,
   11789                 :             :                             gfc_symbol *sym, bool *bad)
   11790                 :             : {
   11791                 :         807 :   gfc_namespace *ns;
   11792                 :         807 :   gcc_assert (block->op == EXEC_BLOCK);
   11793                 :         807 :   ns = block->ext.block.ns;
   11794                 :         807 :   gcc_assert (ns);
   11795                 :             : 
   11796                 :             :   /* Skip the check if this block doesn't contain the nested loop, or
   11797                 :             :      if we already know it's bad.  */
   11798                 :         807 :   gfc_code *result = check_nested_loop_in_chain (ns->code, expr, sym, bad);
   11799                 :         807 :   if (result && !*bad)
   11800                 :             :     {
   11801                 :         519 :       check_nested_loop_in_block_state.expr = expr;
   11802                 :         519 :       check_nested_loop_in_block_state.sym = sym;
   11803                 :         519 :       check_nested_loop_in_block_state.bad = bad;
   11804                 :         519 :       gfc_traverse_ns (ns, check_nested_loop_in_block_symbol);
   11805                 :         519 :       check_nested_loop_in_block_state.expr = NULL;
   11806                 :         519 :       check_nested_loop_in_block_state.sym = NULL;
   11807                 :         519 :       check_nested_loop_in_block_state.bad = NULL;
   11808                 :             :     }
   11809                 :         807 :   return result;
   11810                 :             : }
   11811                 :             : 
   11812                 :             : /* CODE is an OMP loop construct.  Return true if EXPR references
   11813                 :             :    any variables bound in intervening code, to level DEPTH.  */
   11814                 :             : static bool
   11815                 :       22507 : expr_uses_intervening_var (gfc_code *code, int depth, gfc_expr *expr)
   11816                 :             : {
   11817                 :       22507 :   int i;
   11818                 :       22507 :   gfc_code *do_code = code;
   11819                 :             : 
   11820                 :       57745 :   for (i = 0; i < depth; i++)
   11821                 :             :     {
   11822                 :       35241 :       bool bad = false;
   11823                 :       35241 :       do_code = check_nested_loop_in_chain (do_code->block->next,
   11824                 :             :                                             expr, NULL, &bad);
   11825                 :       35241 :       if (bad)
   11826                 :           3 :         return true;
   11827                 :             :     }
   11828                 :             :   return false;
   11829                 :             : }
   11830                 :             : 
   11831                 :             : /* CODE is an OMP loop construct.  Return true if SYM is bound in
   11832                 :             :    intervening code, to level DEPTH.  */
   11833                 :             : static bool
   11834                 :        7512 : is_intervening_var (gfc_code *code, int depth, gfc_symbol *sym)
   11835                 :             : {
   11836                 :        7512 :   int i;
   11837                 :        7512 :   gfc_code *do_code = code;
   11838                 :             : 
   11839                 :       19283 :   for (i = 0; i < depth; i++)
   11840                 :             :     {
   11841                 :       11773 :       bool bad = false;
   11842                 :       11773 :       do_code = check_nested_loop_in_chain (do_code->block->next,
   11843                 :             :                                             NULL, sym, &bad);
   11844                 :       11773 :       if (bad)
   11845                 :           2 :         return true;
   11846                 :             :     }
   11847                 :             :   return false;
   11848                 :             : }
   11849                 :             : 
   11850                 :             : /* CODE is an OMP loop construct.  Return true if EXPR does not reference
   11851                 :             :    any iteration variables outer to level DEPTH.  */
   11852                 :             : static bool
   11853                 :       23586 : expr_is_invariant (gfc_code *code, int depth, gfc_expr *expr)
   11854                 :             : {
   11855                 :       23586 :   int i;
   11856                 :       23586 :   gfc_code *do_code = code;
   11857                 :             : 
   11858                 :       36860 :   for (i = 1; i < depth; i++)
   11859                 :             :     {
   11860                 :       14340 :       do_code = find_nested_loop_in_chain (do_code->block->next);
   11861                 :       14340 :       gcc_assert (do_code);
   11862                 :       14340 :       if (do_code->op == EXEC_OMP_TILE || do_code->op == EXEC_OMP_UNROLL)
   11863                 :             :         {
   11864                 :         136 :           --i;
   11865                 :         136 :           continue;
   11866                 :             :         }
   11867                 :       14204 :       gfc_symbol *ivar = do_code->ext.iterator->var->symtree->n.sym;
   11868                 :       14204 :       if (gfc_find_sym_in_expr (ivar, expr))
   11869                 :             :         return false;
   11870                 :             :     }
   11871                 :             :   return true;
   11872                 :             : }
   11873                 :             : 
   11874                 :             : /* CODE is an OMP loop construct.  Return true if EXPR matches one of the
   11875                 :             :    canonical forms for a bound expression.  It may include references to
   11876                 :             :    an iteration variable outer to level DEPTH; set OUTER_VARP if so.  */
   11877                 :             : static bool
   11878                 :       15015 : bound_expr_is_canonical (gfc_code *code, int depth, gfc_expr *expr,
   11879                 :             :                          gfc_symbol **outer_varp)
   11880                 :             : {
   11881                 :       15015 :   gfc_expr *expr2 = NULL;
   11882                 :             : 
   11883                 :             :   /* Rectangular case.  */
   11884                 :       15015 :   if (depth == 0 || expr_is_invariant (code, depth, expr))
   11885                 :       14447 :     return true;
   11886                 :             : 
   11887                 :             :   /* Any simple variable that didn't pass expr_is_invariant must be
   11888                 :             :      an outer_var.  */
   11889                 :         568 :   if (expr->expr_type == EXPR_VARIABLE && expr->rank == 0)
   11890                 :             :     {
   11891                 :          63 :       *outer_varp = expr->symtree->n.sym;
   11892                 :          63 :       return true;
   11893                 :             :     }
   11894                 :             : 
   11895                 :             :   /* All other permitted forms are binary operators.  */
   11896                 :         505 :   if (expr->expr_type != EXPR_OP)
   11897                 :             :     return false;
   11898                 :             : 
   11899                 :             :   /* Check for plus/minus a loop invariant expr.  */
   11900                 :         503 :   if (expr->value.op.op == INTRINSIC_PLUS
   11901                 :         503 :       || expr->value.op.op == INTRINSIC_MINUS)
   11902                 :             :     {
   11903                 :         483 :       if (expr_is_invariant (code, depth, expr->value.op.op1))
   11904                 :          48 :         expr2 = expr->value.op.op2;
   11905                 :         435 :       else if (expr_is_invariant (code, depth, expr->value.op.op2))
   11906                 :         434 :         expr2 = expr->value.op.op1;
   11907                 :             :       else
   11908                 :             :         return false;
   11909                 :             :     }
   11910                 :             :   else
   11911                 :             :     expr2 = expr;
   11912                 :             : 
   11913                 :             :   /* Check for a product with a loop-invariant expr.  */
   11914                 :         502 :   if (expr2->expr_type == EXPR_OP
   11915                 :          96 :       && expr2->value.op.op == INTRINSIC_TIMES)
   11916                 :             :     {
   11917                 :          96 :       if (expr_is_invariant (code, depth, expr2->value.op.op1))
   11918                 :          40 :         expr2 = expr2->value.op.op2;
   11919                 :          56 :       else if (expr_is_invariant (code, depth, expr2->value.op.op2))
   11920                 :          53 :         expr2 = expr2->value.op.op1;
   11921                 :             :       else
   11922                 :             :         return false;
   11923                 :             :     }
   11924                 :             : 
   11925                 :             :   /* What's left must be a reference to an outer loop variable.  */
   11926                 :         499 :   if (expr2->expr_type == EXPR_VARIABLE
   11927                 :         499 :       && expr2->rank == 0
   11928                 :         998 :       && is_outer_iteration_variable (code, depth, expr2->symtree->n.sym))
   11929                 :             :     {
   11930                 :         499 :       *outer_varp = expr2->symtree->n.sym;
   11931                 :         499 :       return true;
   11932                 :             :     }
   11933                 :             : 
   11934                 :             :   return false;
   11935                 :             : }
   11936                 :             : 
   11937                 :             : static void
   11938                 :        5366 : resolve_omp_do (gfc_code *code)
   11939                 :             : {
   11940                 :        5366 :   gfc_code *do_code, *next;
   11941                 :        5366 :   int list, i, count, non_generated_count;
   11942                 :        5366 :   gfc_omp_namelist *n;
   11943                 :        5366 :   gfc_symbol *dovar;
   11944                 :        5366 :   const char *name;
   11945                 :        5366 :   bool is_simd = false;
   11946                 :        5366 :   bool errorp = false;
   11947                 :        5366 :   bool perfect_nesting_errorp = false;
   11948                 :        5366 :   bool imperfect = false;
   11949                 :             : 
   11950                 :        5366 :   switch (code->op)
   11951                 :             :     {
   11952                 :             :     case EXEC_OMP_DISTRIBUTE: name = "!$OMP DISTRIBUTE"; break;
   11953                 :          49 :     case EXEC_OMP_DISTRIBUTE_PARALLEL_DO:
   11954                 :          49 :       name = "!$OMP DISTRIBUTE PARALLEL DO";
   11955                 :          49 :       break;
   11956                 :          32 :     case EXEC_OMP_DISTRIBUTE_PARALLEL_DO_SIMD:
   11957                 :          32 :       name = "!$OMP DISTRIBUTE PARALLEL DO SIMD";
   11958                 :          32 :       is_simd = true;
   11959                 :          32 :       break;
   11960                 :          50 :     case EXEC_OMP_DISTRIBUTE_SIMD:
   11961                 :          50 :       name = "!$OMP DISTRIBUTE SIMD";
   11962                 :          50 :       is_simd = true;
   11963                 :          50 :       break;
   11964                 :        1329 :     case EXEC_OMP_DO: name = "!$OMP DO"; break;
   11965                 :         134 :     case EXEC_OMP_DO_SIMD: name = "!$OMP DO SIMD"; is_simd = true; break;
   11966                 :          64 :     case EXEC_OMP_LOOP: name = "!$OMP LOOP"; break;
   11967                 :        1200 :     case EXEC_OMP_PARALLEL_DO: name = "!$OMP PARALLEL DO"; break;
   11968                 :         304 :     case EXEC_OMP_PARALLEL_DO_SIMD:
   11969                 :         304 :       name = "!$OMP PARALLEL DO SIMD";
   11970                 :         304 :       is_simd = true;
   11971                 :         304 :       break;
   11972                 :          46 :     case EXEC_OMP_PARALLEL_LOOP: name = "!$OMP PARALLEL LOOP"; break;
   11973                 :           7 :     case EXEC_OMP_PARALLEL_MASKED_TASKLOOP:
   11974                 :           7 :       name = "!$OMP PARALLEL MASKED TASKLOOP";
   11975                 :           7 :       break;
   11976                 :          10 :     case EXEC_OMP_PARALLEL_MASKED_TASKLOOP_SIMD:
   11977                 :          10 :       name = "!$OMP PARALLEL MASKED TASKLOOP SIMD";
   11978                 :          10 :       is_simd = true;
   11979                 :          10 :       break;
   11980                 :          12 :     case EXEC_OMP_PARALLEL_MASTER_TASKLOOP:
   11981                 :          12 :       name = "!$OMP PARALLEL MASTER TASKLOOP";
   11982                 :          12 :       break;
   11983                 :          18 :     case EXEC_OMP_PARALLEL_MASTER_TASKLOOP_SIMD:
   11984                 :          18 :       name = "!$OMP PARALLEL MASTER TASKLOOP SIMD";
   11985                 :          18 :       is_simd = true;
   11986                 :          18 :       break;
   11987                 :           8 :     case EXEC_OMP_MASKED_TASKLOOP: name = "!$OMP MASKED TASKLOOP"; break;
   11988                 :          13 :     case EXEC_OMP_MASKED_TASKLOOP_SIMD:
   11989                 :          13 :       name = "!$OMP MASKED TASKLOOP SIMD";
   11990                 :          13 :       is_simd = true;
   11991                 :          13 :       break;
   11992                 :          14 :     case EXEC_OMP_MASTER_TASKLOOP: name = "!$OMP MASTER TASKLOOP"; break;
   11993                 :          20 :     case EXEC_OMP_MASTER_TASKLOOP_SIMD:
   11994                 :          20 :       name = "!$OMP MASTER TASKLOOP SIMD";
   11995                 :          20 :       is_simd = true;
   11996                 :          20 :       break;
   11997                 :         765 :     case EXEC_OMP_SIMD: name = "!$OMP SIMD"; is_simd = true; break;
   11998                 :          86 :     case EXEC_OMP_TARGET_PARALLEL_DO: name = "!$OMP TARGET PARALLEL DO"; break;
   11999                 :          19 :     case EXEC_OMP_TARGET_PARALLEL_DO_SIMD:
   12000                 :          19 :       name = "!$OMP TARGET PARALLEL DO SIMD";
   12001                 :          19 :       is_simd = true;
   12002                 :          19 :       break;
   12003                 :          16 :     case EXEC_OMP_TARGET_PARALLEL_LOOP:
   12004                 :          16 :       name = "!$OMP TARGET PARALLEL LOOP";
   12005                 :          16 :       break;
   12006                 :          33 :     case EXEC_OMP_TARGET_SIMD:
   12007                 :          33 :       name = "!$OMP TARGET SIMD";
   12008                 :          33 :       is_simd = true;
   12009                 :          33 :       break;
   12010                 :          20 :     case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE:
   12011                 :          20 :       name = "!$OMP TARGET TEAMS DISTRIBUTE";
   12012                 :          20 :       break;
   12013                 :          67 :     case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO:
   12014                 :          67 :       name = "!$OMP TARGET TEAMS DISTRIBUTE PARALLEL DO";
   12015                 :          67 :       break;
   12016                 :          35 :     case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD:
   12017                 :          35 :       name = "!$OMP TARGET TEAMS DISTRIBUTE PARALLEL DO SIMD";
   12018                 :          35 :       is_simd = true;
   12019                 :          35 :       break;
   12020                 :          20 :     case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_SIMD:
   12021                 :          20 :       name = "!$OMP TARGET TEAMS DISTRIBUTE SIMD";
   12022                 :          20 :       is_simd = true;
   12023                 :          20 :       break;
   12024                 :          17 :     case EXEC_OMP_TARGET_TEAMS_LOOP: name = "!$OMP TARGET TEAMS LOOP"; break;
   12025                 :          69 :     case EXEC_OMP_TASKLOOP: name = "!$OMP TASKLOOP"; break;
   12026                 :          38 :     case EXEC_OMP_TASKLOOP_SIMD:
   12027                 :          38 :       name = "!$OMP TASKLOOP SIMD";
   12028                 :          38 :       is_simd = true;
   12029                 :          38 :       break;
   12030                 :          20 :     case EXEC_OMP_TEAMS_DISTRIBUTE: name = "!$OMP TEAMS DISTRIBUTE"; break;
   12031                 :          37 :     case EXEC_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO:
   12032                 :          37 :       name = "!$OMP TEAMS DISTRIBUTE PARALLEL DO";
   12033                 :          37 :       break;
   12034                 :          60 :     case EXEC_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD:
   12035                 :          60 :       name = "!$OMP TEAMS DISTRIBUTE PARALLEL DO SIMD";
   12036                 :          60 :       is_simd = true;
   12037                 :          60 :       break;
   12038                 :          42 :     case EXEC_OMP_TEAMS_DISTRIBUTE_SIMD:
   12039                 :          42 :       name = "!$OMP TEAMS DISTRIBUTE SIMD";
   12040                 :          42 :       is_simd = true;
   12041                 :          42 :       break;
   12042                 :          48 :     case EXEC_OMP_TEAMS_LOOP: name = "!$OMP TEAMS LOOP"; break;
   12043                 :         195 :     case EXEC_OMP_TILE: name = "!$OMP TILE"; break;
   12044                 :         415 :     case EXEC_OMP_UNROLL: name = "!$OMP UNROLL"; break;
   12045                 :           0 :     default: gcc_unreachable ();
   12046                 :             :     }
   12047                 :             : 
   12048                 :        5366 :   if (code->ext.omp_clauses)
   12049                 :        5366 :     resolve_omp_clauses (code, code->ext.omp_clauses, NULL);
   12050                 :             : 
   12051                 :        5366 :   if (code->op == EXEC_OMP_TILE && code->ext.omp_clauses->sizes_list == NULL)
   12052                 :           0 :     gfc_error ("SIZES clause is required on !$OMP TILE construct at %L",
   12053                 :             :                &code->loc);
   12054                 :             : 
   12055                 :        5366 :   do_code = code->block->next;
   12056                 :        5366 :   if (code->ext.omp_clauses->orderedc)
   12057                 :             :     count = code->ext.omp_clauses->orderedc;
   12058                 :        5224 :   else if (code->ext.omp_clauses->sizes_list)
   12059                 :         195 :     count = gfc_expr_list_len (code->ext.omp_clauses->sizes_list);
   12060                 :             :   else
   12061                 :             :     {
   12062                 :        5029 :       count = code->ext.omp_clauses->collapse;
   12063                 :        5029 :       if (count <= 0)
   12064                 :             :         count = 1;
   12065                 :             :     }
   12066                 :             : 
   12067                 :        5366 :   non_generated_count = count;
   12068                 :             :   /* While the spec defines the loop nest depth independently of the COLLAPSE
   12069                 :             :      clause, in practice the middle end only pays attention to the COLLAPSE
   12070                 :             :      depth and treats any further inner loops as the final-loop-body.  So
   12071                 :             :      here we also check canonical loop nest form only for the number of
   12072                 :             :      outer loops specified by the COLLAPSE clause too.  */
   12073                 :        7990 :   for (i = 1; i <= count; i++)
   12074                 :             :     {
   12075                 :        7990 :       gfc_symbol *start_var = NULL, *end_var = NULL;
   12076                 :             :       /* Parse errors are not recoverable.  */
   12077                 :        7990 :       if (do_code->op == EXEC_DO_WHILE)
   12078                 :             :         {
   12079                 :           6 :           gfc_error ("%s cannot be a DO WHILE or DO without loop control "
   12080                 :             :                      "at %L", name, &do_code->loc);
   12081                 :         106 :           goto fail;
   12082                 :             :         }
   12083                 :        7984 :       if (do_code->op == EXEC_DO_CONCURRENT)
   12084                 :             :         {
   12085                 :           4 :           gfc_error ("%s cannot be a DO CONCURRENT loop at %L", name,
   12086                 :             :                      &do_code->loc);
   12087                 :           4 :           goto fail;
   12088                 :             :         }
   12089                 :        7980 :       if (do_code->op == EXEC_OMP_TILE || do_code->op == EXEC_OMP_UNROLL)
   12090                 :             :         {
   12091                 :         466 :           if (do_code->op == EXEC_OMP_UNROLL)
   12092                 :             :             {
   12093                 :         308 :               if (!do_code->ext.omp_clauses->partial)
   12094                 :             :                 {
   12095                 :          53 :                   gfc_error ("Generated loop of UNROLL construct at %L "
   12096                 :             :                              "without PARTIAL clause does not have "
   12097                 :             :                              "canonical form", &do_code->loc);
   12098                 :          53 :                   goto fail;
   12099                 :             :                 }
   12100                 :         255 :               else if (i != count)
   12101                 :             :                 {
   12102                 :           5 :                   gfc_error ("UNROLL construct at %L with PARTIAL clause "
   12103                 :             :                              "generates just one loop with canonical form "
   12104                 :             :                              "but %d loops are needed",
   12105                 :           5 :                              &do_code->loc, count - i + 1);
   12106                 :           5 :                   goto fail;
   12107                 :             :                 }
   12108                 :             :             }
   12109                 :         158 :           else if (do_code->op == EXEC_OMP_TILE)
   12110                 :             :             {
   12111                 :         158 :               if (do_code->ext.omp_clauses->sizes_list == NULL)
   12112                 :             :                 /* This should have been diagnosed earlier already.  */
   12113                 :           0 :                 return;
   12114                 :         158 :               int l = gfc_expr_list_len (do_code->ext.omp_clauses->sizes_list);
   12115                 :         158 :               if (count - i + 1 > l)
   12116                 :             :                 {
   12117                 :          14 :                   gfc_error ("TILE construct at %L generates %d loops "
   12118                 :             :                              "with canonical form but %d loops are needed",
   12119                 :             :                              &do_code->loc, l, count - i + 1);
   12120                 :          14 :                   goto fail;
   12121                 :             :                 }
   12122                 :             :             }
   12123                 :         394 :           if (do_code->ext.omp_clauses && do_code->ext.omp_clauses->erroneous)
   12124                 :          17 :             goto fail;
   12125                 :         377 :           if (imperfect && !perfect_nesting_errorp)
   12126                 :             :             {
   12127                 :           4 :               sorry_at (gfc_get_location (&do_code->loc),
   12128                 :             :                         "Imperfectly nested loop using generated loops");
   12129                 :           4 :               errorp = true;
   12130                 :             :             }
   12131                 :         377 :           if (non_generated_count == count)
   12132                 :         329 :             non_generated_count = i - 1;
   12133                 :         377 :           --i;
   12134                 :         377 :           do_code = do_code->block->next;
   12135                 :         377 :           continue;
   12136                 :         377 :         }
   12137                 :        7514 :       gcc_assert (do_code->op == EXEC_DO);
   12138                 :        7514 :       if (do_code->ext.iterator->var->ts.type != BT_INTEGER)
   12139                 :             :         {
   12140                 :           3 :           gfc_error ("%s iteration variable must be of type integer at %L",
   12141                 :             :                      name, &do_code->loc);
   12142                 :           3 :           errorp = true;
   12143                 :             :         }
   12144                 :        7514 :       dovar = do_code->ext.iterator->var->symtree->n.sym;
   12145                 :        7514 :       if (dovar->attr.threadprivate)
   12146                 :             :         {
   12147                 :           0 :           gfc_error ("%s iteration variable must not be THREADPRIVATE "
   12148                 :             :                      "at %L", name, &do_code->loc);
   12149                 :           0 :           errorp = true;
   12150                 :             :         }
   12151                 :        7514 :       if (code->ext.omp_clauses)
   12152                 :      293046 :         for (list = 0; list < OMP_LIST_NUM; list++)
   12153                 :       94050 :           if (!is_simd || code->ext.omp_clauses->collapse > 1
   12154                 :      285532 :               ? (list != OMP_LIST_PRIVATE && list != OMP_LIST_LASTPRIVATE
   12155                 :      246088 :                   && list != OMP_LIST_ALLOCATE)
   12156                 :       39444 :               : (list != OMP_LIST_PRIVATE && list != OMP_LIST_LASTPRIVATE
   12157                 :       39444 :                  && list != OMP_LIST_ALLOCATE && list != OMP_LIST_LINEAR))
   12158                 :      266319 :             for (n = code->ext.omp_clauses->lists[list]; n; n = n->next)
   12159                 :        4367 :               if (dovar == n->sym)
   12160                 :             :                 {
   12161                 :           5 :                   if (!is_simd || code->ext.omp_clauses->collapse > 1)
   12162                 :           4 :                     gfc_error ("%s iteration variable present on clause "
   12163                 :             :                                "other than PRIVATE, LASTPRIVATE or "
   12164                 :             :                                "ALLOCATE at %L", name, &do_code->loc);
   12165                 :             :                   else
   12166                 :           1 :                     gfc_error ("%s iteration variable present on clause "
   12167                 :             :                                "other than PRIVATE, LASTPRIVATE, ALLOCATE or "
   12168                 :             :                                "LINEAR at %L", name, &do_code->loc);
   12169                 :             :                   errorp = true;
   12170                 :             :                 }
   12171                 :        7514 :       if (is_outer_iteration_variable (code, i, dovar))
   12172                 :             :         {
   12173                 :           2 :           gfc_error ("%s iteration variable used in more than one loop at %L",
   12174                 :             :                      name, &do_code->loc);
   12175                 :           2 :           errorp = true;
   12176                 :             :         }
   12177                 :        7512 :       else if (is_intervening_var (code, i, dovar))
   12178                 :             :         {
   12179                 :           2 :           gfc_error ("%s iteration variable at %L is bound in "
   12180                 :             :                      "intervening code",
   12181                 :             :                      name, &do_code->loc);
   12182                 :           2 :           errorp = true;
   12183                 :             :         }
   12184                 :        7510 :       else if (!bound_expr_is_canonical (code, i,
   12185                 :        7510 :                                          do_code->ext.iterator->start,
   12186                 :             :                                          &start_var))
   12187                 :             :         {
   12188                 :           4 :           gfc_error ("%s loop start expression not in canonical form at %L",
   12189                 :             :                      name, &do_code->loc);
   12190                 :           4 :           errorp = true;
   12191                 :             :         }
   12192                 :        7506 :       else if (expr_uses_intervening_var (code, i,
   12193                 :        7506 :                                           do_code->ext.iterator->start))
   12194                 :             :         {
   12195                 :           1 :           gfc_error ("%s loop start expression at %L uses variable bound in "
   12196                 :             :                      "intervening code",
   12197                 :             :                      name, &do_code->loc);
   12198                 :           1 :           errorp = true;
   12199                 :             :         }
   12200                 :        7505 :       else if (!bound_expr_is_canonical (code, i,
   12201                 :        7505 :                                          do_code->ext.iterator->end,
   12202                 :             :                                          &end_var))
   12203                 :             :         {
   12204                 :           2 :           gfc_error ("%s loop end expression not in canonical form at %L",
   12205                 :             :                      name, &do_code->loc);
   12206                 :           2 :           errorp = true;
   12207                 :             :         }
   12208                 :        7503 :       else if (expr_uses_intervening_var (code, i,
   12209                 :        7503 :                                           do_code->ext.iterator->end))
   12210                 :             :         {
   12211                 :           1 :           gfc_error ("%s loop end expression at %L uses variable bound in "
   12212                 :             :                      "intervening code",
   12213                 :             :                      name, &do_code->loc);
   12214                 :           1 :           errorp = true;
   12215                 :             :         }
   12216                 :        7502 :       else if (start_var && end_var && start_var != end_var)
   12217                 :             :         {
   12218                 :           1 :           gfc_error ("%s loop bounds reference different "
   12219                 :             :                      "iteration variables at %L", name, &do_code->loc);
   12220                 :           1 :           errorp = true;
   12221                 :             :         }
   12222                 :        7501 :       else if (!expr_is_invariant (code, i, do_code->ext.iterator->step))
   12223                 :             :         {
   12224                 :           3 :           gfc_error ("%s loop increment not in canonical form at %L",
   12225                 :             :                      name, &do_code->loc);
   12226                 :           3 :           errorp = true;
   12227                 :             :         }
   12228                 :        7498 :       else if (expr_uses_intervening_var (code, i,
   12229                 :        7498 :                                           do_code->ext.iterator->step))
   12230                 :             :         {
   12231                 :           1 :           gfc_error ("%s loop increment expression at %L uses variable "
   12232                 :             :                      "bound in intervening code",
   12233                 :             :                      name, &do_code->loc);
   12234                 :           1 :           errorp = true;
   12235                 :             :         }
   12236                 :        7514 :       if (start_var || end_var)
   12237                 :             :         {
   12238                 :         528 :           code->ext.omp_clauses->non_rectangular = 1;
   12239                 :         528 :           if (i > non_generated_count)
   12240                 :             :             {
   12241                 :           3 :               sorry_at (gfc_get_location (&do_code->loc),
   12242                 :             :                         "Non-rectangular loops from generated loops "
   12243                 :             :                         "unsupported");
   12244                 :           3 :               errorp = true;
   12245                 :             :             }
   12246                 :             :         }
   12247                 :             : 
   12248                 :             :       /* Only parse loop body into nested loop and intervening code if
   12249                 :             :          there are supposed to be more loops in the nest to collapse.  */
   12250                 :        7514 :       if (i == count)
   12251                 :             :         break;
   12252                 :             : 
   12253                 :        2254 :       next = find_nested_loop_in_chain (do_code->block->next);
   12254                 :             : 
   12255                 :        2254 :       if (!next)
   12256                 :             :         {
   12257                 :             :           /* Parse error, can't recover from this.  */
   12258                 :           7 :           gfc_error ("not enough DO loops for collapsed %s (level %d) at %L",
   12259                 :             :                      name, i, &code->loc);
   12260                 :           7 :           goto fail;
   12261                 :             :         }
   12262                 :        2247 :       else if (next != do_code->block->next || next->next)
   12263                 :             :         /* Imperfectly nested loop found.  */
   12264                 :             :         {
   12265                 :             :           /* Only diagnose violation of imperfect nesting constraints once.  */
   12266                 :         180 :           if (!perfect_nesting_errorp)
   12267                 :             :             {
   12268                 :         179 :               if (code->ext.omp_clauses->orderedc)
   12269                 :             :                 {
   12270                 :           3 :                   gfc_error ("%s inner loops must be perfectly nested with "
   12271                 :             :                              "ORDERED clause at %L",
   12272                 :             :                              name, &code->loc);
   12273                 :           3 :                   perfect_nesting_errorp = true;
   12274                 :             :                 }
   12275                 :         176 :               else if (code->ext.omp_clauses->lists[OMP_LIST_REDUCTION_INSCAN])
   12276                 :             :                 {
   12277                 :           2 :                   gfc_error ("%s inner loops must be perfectly nested with "
   12278                 :             :                              "REDUCTION INSCAN clause at %L",
   12279                 :             :                              name, &code->loc);
   12280                 :           2 :                   perfect_nesting_errorp = true;
   12281                 :             :                 }
   12282                 :         174 :               else if (code->op == EXEC_OMP_TILE)
   12283                 :             :                 {
   12284                 :           8 :                   gfc_error ("%s inner loops must be perfectly nested at %L",
   12285                 :             :                              name, &code->loc);
   12286                 :           8 :                   perfect_nesting_errorp = true;
   12287                 :             :                 }
   12288                 :          13 :               if (perfect_nesting_errorp)
   12289                 :             :                 errorp = true;
   12290                 :             :             }
   12291                 :         180 :           if (diagnose_intervening_code_errors (do_code->block->next,
   12292                 :             :                                                 name, next))
   12293                 :           4 :             errorp = true;
   12294                 :             :           imperfect = true;
   12295                 :             :         }
   12296                 :        2247 :       do_code = next;
   12297                 :             :     }
   12298                 :             : 
   12299                 :             :   /* Give up now if we found any constraint violations.  */
   12300                 :        5260 :   if (errorp)
   12301                 :             :     {
   12302                 :          47 :     fail:
   12303                 :         153 :       if (code->ext.omp_clauses)
   12304                 :         153 :         code->ext.omp_clauses->erroneous = 1;
   12305                 :         153 :       return;
   12306                 :             :     }
   12307                 :             : 
   12308                 :        5213 :   if (non_generated_count)
   12309                 :        4943 :     restructure_intervening_code (&code->block->next, code,
   12310                 :             :                                   non_generated_count);
   12311                 :             : }
   12312                 :             : 
   12313                 :             : static void
   12314                 :         109 : resolve_omp_metadirective (gfc_code *code, gfc_namespace *ns)
   12315                 :             : {
   12316                 :         109 :   gfc_omp_variant *variant = code->ext.omp_variants;
   12317                 :             : 
   12318                 :         359 :   while (variant)
   12319                 :             :     {
   12320                 :         250 :       gfc_code *variant_code = variant->code;
   12321                 :         250 :       gfc_resolve_code (variant_code, ns);
   12322                 :         250 :       variant = variant->next;
   12323                 :             :     }
   12324                 :         109 : }
   12325                 :             : 
   12326                 :             : 
   12327                 :             : static gfc_statement
   12328                 :          63 : omp_code_to_statement (gfc_code *code)
   12329                 :             : {
   12330                 :          63 :   switch (code->op)
   12331                 :             :     {
   12332                 :             :     case EXEC_OMP_PARALLEL:
   12333                 :             :       return ST_OMP_PARALLEL;
   12334                 :           0 :     case EXEC_OMP_PARALLEL_MASKED:
   12335                 :           0 :       return ST_OMP_PARALLEL_MASKED;
   12336                 :           0 :     case EXEC_OMP_PARALLEL_MASKED_TASKLOOP:
   12337                 :           0 :       return ST_OMP_PARALLEL_MASKED_TASKLOOP;
   12338                 :           0 :     case EXEC_OMP_PARALLEL_MASKED_TASKLOOP_SIMD:
   12339                 :           0 :       return ST_OMP_PARALLEL_MASKED_TASKLOOP_SIMD;
   12340                 :           0 :     case EXEC_OMP_PARALLEL_MASTER:
   12341                 :           0 :       return ST_OMP_PARALLEL_MASTER;
   12342                 :           0 :     case EXEC_OMP_PARALLEL_MASTER_TASKLOOP:
   12343                 :           0 :       return ST_OMP_PARALLEL_MASTER_TASKLOOP;
   12344                 :           0 :     case EXEC_OMP_PARALLEL_MASTER_TASKLOOP_SIMD:
   12345                 :           0 :       return ST_OMP_PARALLEL_MASTER_TASKLOOP_SIMD;
   12346                 :           1 :     case EXEC_OMP_PARALLEL_SECTIONS:
   12347                 :           1 :       return ST_OMP_PARALLEL_SECTIONS;
   12348                 :           1 :     case EXEC_OMP_SECTIONS:
   12349                 :           1 :       return ST_OMP_SECTIONS;
   12350                 :           1 :     case EXEC_OMP_ORDERED:
   12351                 :           1 :       return ST_OMP_ORDERED;
   12352                 :           1 :     case EXEC_OMP_CRITICAL:
   12353                 :           1 :       return ST_OMP_CRITICAL;
   12354                 :           0 :     case EXEC_OMP_MASKED:
   12355                 :           0 :       return ST_OMP_MASKED;
   12356                 :           0 :     case EXEC_OMP_MASKED_TASKLOOP:
   12357                 :           0 :       return ST_OMP_MASKED_TASKLOOP;
   12358                 :           0 :     case EXEC_OMP_MASKED_TASKLOOP_SIMD:
   12359                 :           0 :       return ST_OMP_MASKED_TASKLOOP_SIMD;
   12360                 :           1 :     case EXEC_OMP_MASTER:
   12361                 :           1 :       return ST_OMP_MASTER;
   12362                 :           0 :     case EXEC_OMP_MASTER_TASKLOOP:
   12363                 :           0 :       return ST_OMP_MASTER_TASKLOOP;
   12364                 :           0 :     case EXEC_OMP_MASTER_TASKLOOP_SIMD:
   12365                 :           0 :       return ST_OMP_MASTER_TASKLOOP_SIMD;
   12366                 :           1 :     case EXEC_OMP_SINGLE:
   12367                 :           1 :       return ST_OMP_SINGLE;
   12368                 :           1 :     case EXEC_OMP_TASK:
   12369                 :           1 :       return ST_OMP_TASK;
   12370                 :           1 :     case EXEC_OMP_WORKSHARE:
   12371                 :           1 :       return ST_OMP_WORKSHARE;
   12372                 :           1 :     case EXEC_OMP_PARALLEL_WORKSHARE:
   12373                 :           1 :       return ST_OMP_PARALLEL_WORKSHARE;
   12374                 :           3 :     case EXEC_OMP_DO:
   12375                 :           3 :       return ST_OMP_DO;
   12376                 :           0 :     case EXEC_OMP_LOOP:
   12377                 :           0 :       return ST_OMP_LOOP;
   12378                 :           0 :     case EXEC_OMP_ALLOCATE:
   12379                 :           0 :       return ST_OMP_ALLOCATE_EXEC;
   12380                 :           0 :     case EXEC_OMP_ALLOCATORS:
   12381                 :           0 :       return ST_OMP_ALLOCATORS;
   12382                 :           0 :     case EXEC_OMP_ASSUME:
   12383                 :           0 :       return ST_OMP_ASSUME;
   12384                 :           1 :     case EXEC_OMP_ATOMIC:
   12385                 :           1 :       return ST_OMP_ATOMIC;
   12386                 :           1 :     case EXEC_OMP_BARRIER:
   12387                 :           1 :       return ST_OMP_BARRIER;
   12388                 :           1 :     case EXEC_OMP_CANCEL:
   12389                 :           1 :       return ST_OMP_CANCEL;
   12390                 :           1 :     case EXEC_OMP_CANCELLATION_POINT:
   12391                 :           1 :       return ST_OMP_CANCELLATION_POINT;
   12392                 :           0 :     case EXEC_OMP_ERROR:
   12393                 :           0 :       return ST_OMP_ERROR;
   12394                 :           1 :     case EXEC_OMP_FLUSH:
   12395                 :           1 :       return ST_OMP_FLUSH;
   12396                 :           0 :     case EXEC_OMP_INTEROP:
   12397                 :           0 :       return ST_OMP_INTEROP;
   12398                 :           1 :     case EXEC_OMP_DISTRIBUTE:
   12399                 :           1 :       return ST_OMP_DISTRIBUTE;
   12400                 :           1 :     case EXEC_OMP_DISTRIBUTE_PARALLEL_DO:
   12401                 :           1 :       return ST_OMP_DISTRIBUTE_PARALLEL_DO;
   12402                 :           1 :     case EXEC_OMP_DISTRIBUTE_PARALLEL_DO_SIMD:
   12403                 :           1 :       return ST_OMP_DISTRIBUTE_PARALLEL_DO_SIMD;
   12404                 :           1 :     case EXEC_OMP_DISTRIBUTE_SIMD:
   12405                 :           1 :       return ST_OMP_DISTRIBUTE_SIMD;
   12406                 :           1 :     case EXEC_OMP_DO_SIMD:
   12407                 :           1 :       return ST_OMP_DO_SIMD;
   12408                 :           0 :     case EXEC_OMP_SCAN:
   12409                 :           0 :       return ST_OMP_SCAN;
   12410                 :           0 :     case EXEC_OMP_SCOPE:
   12411                 :           0 :       return ST_OMP_SCOPE;
   12412                 :           1 :     case EXEC_OMP_SIMD:
   12413                 :           1 :       return ST_OMP_SIMD;
   12414                 :           1 :     case EXEC_OMP_TARGET:
   12415                 :           1 :       return ST_OMP_TARGET;
   12416                 :           1 :     case EXEC_OMP_TARGET_DATA:
   12417                 :           1 :       return ST_OMP_TARGET_DATA;
   12418                 :           1 :     case EXEC_OMP_TARGET_ENTER_DATA:
   12419                 :           1 :       return ST_OMP_TARGET_ENTER_DATA;
   12420                 :           1 :     case EXEC_OMP_TARGET_EXIT_DATA:
   12421                 :           1 :       return ST_OMP_TARGET_EXIT_DATA;
   12422                 :           1 :     case EXEC_OMP_TARGET_PARALLEL:
   12423                 :           1 :       return ST_OMP_TARGET_PARALLEL;
   12424                 :           1 :     case EXEC_OMP_TARGET_PARALLEL_DO:
   12425                 :           1 :       return ST_OMP_TARGET_PARALLEL_DO;
   12426                 :           1 :     case EXEC_OMP_TARGET_PARALLEL_DO_SIMD:
   12427                 :           1 :       return ST_OMP_TARGET_PARALLEL_DO_SIMD;
   12428                 :           0 :     case EXEC_OMP_TARGET_PARALLEL_LOOP:
   12429                 :           0 :       return ST_OMP_TARGET_PARALLEL_LOOP;
   12430                 :           1 :     case EXEC_OMP_TARGET_SIMD:
   12431                 :           1 :       return ST_OMP_TARGET_SIMD;
   12432                 :           1 :     case EXEC_OMP_TARGET_TEAMS:
   12433                 :           1 :       return ST_OMP_TARGET_TEAMS;
   12434                 :           1 :     case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE:
   12435                 :           1 :       return ST_OMP_TARGET_TEAMS_DISTRIBUTE;
   12436                 :           1 :     case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO:
   12437                 :           1 :       return ST_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO;
   12438                 :           1 :     case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD:
   12439                 :           1 :       return ST_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD;
   12440                 :           1 :     case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_SIMD:
   12441                 :           1 :       return ST_OMP_TARGET_TEAMS_DISTRIBUTE_SIMD;
   12442                 :           0 :     case EXEC_OMP_TARGET_TEAMS_LOOP:
   12443                 :           0 :       return ST_OMP_TARGET_TEAMS_LOOP;
   12444                 :           1 :     case EXEC_OMP_TARGET_UPDATE:
   12445                 :           1 :       return ST_OMP_TARGET_UPDATE;
   12446                 :           1 :     case EXEC_OMP_TASKGROUP:
   12447                 :           1 :       return ST_OMP_TASKGROUP;
   12448                 :           1 :     case EXEC_OMP_TASKLOOP:
   12449                 :           1 :       return ST_OMP_TASKLOOP;
   12450                 :           1 :     case EXEC_OMP_TASKLOOP_SIMD:
   12451                 :           1 :       return ST_OMP_TASKLOOP_SIMD;
   12452                 :           1 :     case EXEC_OMP_TASKWAIT:
   12453                 :           1 :       return ST_OMP_TASKWAIT;
   12454                 :           1 :     case EXEC_OMP_TASKYIELD:
   12455                 :           1 :       return ST_OMP_TASKYIELD;
   12456                 :           1 :     case EXEC_OMP_TEAMS:
   12457                 :           1 :       return ST_OMP_TEAMS;
   12458                 :           1 :     case EXEC_OMP_TEAMS_DISTRIBUTE:
   12459                 :           1 :       return ST_OMP_TEAMS_DISTRIBUTE;
   12460                 :           1 :     case EXEC_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO:
   12461                 :           1 :       return ST_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO;
   12462                 :           1 :     case EXEC_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD:
   12463                 :           1 :       return ST_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD;
   12464                 :           1 :     case EXEC_OMP_TEAMS_DISTRIBUTE_SIMD:
   12465                 :           1 :       return ST_OMP_TEAMS_DISTRIBUTE_SIMD;
   12466                 :           0 :     case EXEC_OMP_TEAMS_LOOP:
   12467                 :           0 :       return ST_OMP_TEAMS_LOOP;
   12468                 :           6 :     case EXEC_OMP_PARALLEL_DO:
   12469                 :           6 :       return ST_OMP_PARALLEL_DO;
   12470                 :           1 :     case EXEC_OMP_PARALLEL_DO_SIMD:
   12471                 :           1 :       return ST_OMP_PARALLEL_DO_SIMD;
   12472                 :           0 :     case EXEC_OMP_PARALLEL_LOOP:
   12473                 :           0 :       return ST_OMP_PARALLEL_LOOP;
   12474                 :           1 :     case EXEC_OMP_DEPOBJ:
   12475                 :           1 :       return ST_OMP_DEPOBJ;
   12476                 :           0 :     case EXEC_OMP_TILE:
   12477                 :           0 :       return ST_OMP_TILE;
   12478                 :           0 :     case EXEC_OMP_UNROLL:
   12479                 :           0 :       return ST_OMP_UNROLL;
   12480                 :           0 :     case EXEC_OMP_DISPATCH:
   12481                 :           0 :       return ST_OMP_DISPATCH;
   12482                 :           0 :     default:
   12483                 :           0 :       gcc_unreachable ();
   12484                 :             :     }
   12485                 :             : }
   12486                 :             : 
   12487                 :             : static gfc_statement
   12488                 :          63 : oacc_code_to_statement (gfc_code *code)
   12489                 :             : {
   12490                 :          63 :   switch (code->op)
   12491                 :             :     {
   12492                 :             :     case EXEC_OACC_PARALLEL:
   12493                 :             :       return ST_OACC_PARALLEL;
   12494                 :             :     case EXEC_OACC_KERNELS:
   12495                 :             :       return ST_OACC_KERNELS;
   12496                 :             :     case EXEC_OACC_SERIAL:
   12497                 :             :       return ST_OACC_SERIAL;
   12498                 :             :     case EXEC_OACC_DATA:
   12499                 :             :       return ST_OACC_DATA;
   12500                 :             :     case EXEC_OACC_HOST_DATA:
   12501                 :             :       return ST_OACC_HOST_DATA;
   12502                 :             :     case EXEC_OACC_PARALLEL_LOOP:
   12503                 :             :       return ST_OACC_PARALLEL_LOOP;
   12504                 :             :     case EXEC_OACC_KERNELS_LOOP:
   12505                 :             :       return ST_OACC_KERNELS_LOOP;
   12506                 :             :     case EXEC_OACC_SERIAL_LOOP:
   12507                 :             :       return ST_OACC_SERIAL_LOOP;
   12508                 :             :     case EXEC_OACC_LOOP:
   12509                 :             :       return ST_OACC_LOOP;
   12510                 :             :     case EXEC_OACC_ATOMIC:
   12511                 :             :       return ST_OACC_ATOMIC;
   12512                 :             :     case EXEC_OACC_ROUTINE:
   12513                 :             :       return ST_OACC_ROUTINE;
   12514                 :             :     case EXEC_OACC_UPDATE:
   12515                 :             :       return ST_OACC_UPDATE;
   12516                 :             :     case EXEC_OACC_WAIT:
   12517                 :             :       return ST_OACC_WAIT;
   12518                 :             :     case EXEC_OACC_CACHE:
   12519                 :             :       return ST_OACC_CACHE;
   12520                 :             :     case EXEC_OACC_ENTER_DATA:
   12521                 :             :       return ST_OACC_ENTER_DATA;
   12522                 :             :     case EXEC_OACC_EXIT_DATA:
   12523                 :             :       return ST_OACC_EXIT_DATA;
   12524                 :             :     case EXEC_OACC_DECLARE:
   12525                 :             :       return ST_OACC_DECLARE;
   12526                 :           0 :     default:
   12527                 :           0 :       gcc_unreachable ();
   12528                 :             :     }
   12529                 :             : }
   12530                 :             : 
   12531                 :             : static void
   12532                 :       13088 : resolve_oacc_directive_inside_omp_region (gfc_code *code)
   12533                 :             : {
   12534                 :       13088 :   if (omp_current_ctx != NULL && omp_current_ctx->is_openmp)
   12535                 :             :     {
   12536                 :          11 :       gfc_statement st = omp_code_to_statement (omp_current_ctx->code);
   12537                 :          11 :       gfc_statement oacc_st = oacc_code_to_statement (code);
   12538                 :          11 :       gfc_error ("The %s directive cannot be specified within "
   12539                 :             :                  "a %s region at %L", gfc_ascii_statement (oacc_st),
   12540                 :             :                  gfc_ascii_statement (st), &code->loc);
   12541                 :             :     }
   12542                 :       13088 : }
   12543                 :             : 
   12544                 :             : static void
   12545                 :       20265 : resolve_omp_directive_inside_oacc_region (gfc_code *code)
   12546                 :             : {
   12547                 :       20265 :   if (omp_current_ctx != NULL && !omp_current_ctx->is_openmp)
   12548                 :             :     {
   12549                 :          52 :       gfc_statement st = oacc_code_to_statement (omp_current_ctx->code);
   12550                 :          52 :       gfc_statement omp_st = omp_code_to_statement (code);
   12551                 :          52 :       gfc_error ("The %s directive cannot be specified within "
   12552                 :             :                  "a %s region at %L", gfc_ascii_statement (omp_st),
   12553                 :             :                  gfc_ascii_statement (st), &code->loc);
   12554                 :             :     }
   12555                 :       20265 : }
   12556                 :             : 
   12557                 :             : 
   12558                 :             : static void
   12559                 :        5269 : resolve_oacc_nested_loops (gfc_code *code, gfc_code* do_code, int collapse,
   12560                 :             :                           const char *clause)
   12561                 :             : {
   12562                 :        5269 :   gfc_symbol *dovar;
   12563                 :        5269 :   gfc_code *c;
   12564                 :        5269 :   int i;
   12565                 :             : 
   12566                 :        5789 :   for (i = 1; i <= collapse; i++)
   12567                 :             :     {
   12568                 :        5789 :       if (do_code->op == EXEC_DO_WHILE)
   12569                 :             :         {
   12570                 :          10 :           gfc_error ("!$ACC LOOP cannot be a DO WHILE or DO without loop control "
   12571                 :             :                      "at %L", &do_code->loc);
   12572                 :          10 :           break;
   12573                 :             :         }
   12574                 :        5779 :       if (do_code->op == EXEC_DO_CONCURRENT)
   12575                 :             :         {
   12576                 :           3 :           gfc_error ("!$ACC LOOP cannot be a DO CONCURRENT loop at %L",
   12577                 :             :                      &do_code->loc);
   12578                 :           3 :           break;
   12579                 :             :         }
   12580                 :        5776 :       gcc_assert (do_code->op == EXEC_DO);
   12581                 :        5776 :       if (do_code->ext.iterator->var->ts.type != BT_INTEGER)
   12582                 :           6 :         gfc_error ("!$ACC LOOP iteration variable must be of type integer at %L",
   12583                 :             :                    &do_code->loc);
   12584                 :        5776 :       dovar = do_code->ext.iterator->var->symtree->n.sym;
   12585                 :        5776 :       if (i > 1)
   12586                 :             :         {
   12587                 :         518 :           gfc_code *do_code2 = code->block->next;
   12588                 :         518 :           int j;
   12589                 :             : 
   12590                 :        1218 :           for (j = 1; j < i; j++)
   12591                 :             :             {
   12592                 :         710 :               gfc_symbol *ivar = do_code2->ext.iterator->var->symtree->n.sym;
   12593                 :         710 :               if (dovar == ivar
   12594                 :         710 :                   || gfc_find_sym_in_expr (ivar, do_code->ext.iterator->start)
   12595                 :         701 :                   || gfc_find_sym_in_expr (ivar, do_code->ext.iterator->end)
   12596                 :        1410 :                   || gfc_find_sym_in_expr (ivar, do_code->ext.iterator->step))
   12597                 :             :                 {
   12598                 :          10 :                   gfc_error ("!$ACC LOOP %s loops don't form rectangular "
   12599                 :             :                              "iteration space at %L", clause, &do_code->loc);
   12600                 :          10 :                   break;
   12601                 :             :                 }
   12602                 :         700 :               do_code2 = do_code2->block->next;
   12603                 :             :             }
   12604                 :             :         }
   12605                 :        5776 :       if (i == collapse)
   12606                 :             :         break;
   12607                 :         577 :       for (c = do_code->next; c; c = c->next)
   12608                 :          48 :         if (c->op != EXEC_NOP && c->op != EXEC_CONTINUE)
   12609                 :             :           {
   12610                 :           0 :             gfc_error ("%s !$ACC LOOP loops not perfectly nested at %L",
   12611                 :             :                        clause, &c->loc);
   12612                 :           0 :             break;
   12613                 :             :           }
   12614                 :         529 :       if (c)
   12615                 :             :         break;
   12616                 :         529 :       do_code = do_code->block;
   12617                 :         529 :       if (do_code->op != EXEC_DO && do_code->op != EXEC_DO_WHILE
   12618                 :           0 :           && do_code->op != EXEC_DO_CONCURRENT)
   12619                 :             :         {
   12620                 :           0 :           gfc_error ("not enough DO loops for %s !$ACC LOOP at %L",
   12621                 :             :                      clause, &code->loc);
   12622                 :           0 :           break;
   12623                 :             :         }
   12624                 :         529 :       do_code = do_code->next;
   12625                 :         529 :       if (do_code == NULL
   12626                 :         522 :           || (do_code->op != EXEC_DO && do_code->op != EXEC_DO_WHILE
   12627                 :           2 :               && do_code->op != EXEC_DO_CONCURRENT))
   12628                 :             :         {
   12629                 :           9 :           gfc_error ("not enough DO loops for %s !$ACC LOOP at %L",
   12630                 :             :                      clause, &code->loc);
   12631                 :           9 :           break;
   12632                 :             :         }
   12633                 :             :     }
   12634                 :        5269 : }
   12635                 :             : 
   12636                 :             : 
   12637                 :             : static void
   12638                 :       10095 : resolve_oacc_loop_blocks (gfc_code *code)
   12639                 :             : {
   12640                 :       10095 :   if (!oacc_is_loop (code))
   12641                 :             :     return;
   12642                 :             : 
   12643                 :        5269 :   if (code->ext.omp_clauses->tile_list && code->ext.omp_clauses->gang
   12644                 :         197 :       && code->ext.omp_clauses->worker && code->ext.omp_clauses->vector)
   12645                 :           0 :     gfc_error ("Tiled loop cannot be parallelized across gangs, workers and "
   12646                 :             :                "vectors at the same time at %L", &code->loc);
   12647                 :             : 
   12648                 :        5269 :   if (code->ext.omp_clauses->tile_list)
   12649                 :             :     {
   12650                 :             :       gfc_expr_list *el;
   12651                 :         501 :       for (el = code->ext.omp_clauses->tile_list; el; el = el->next)
   12652                 :             :         {
   12653                 :         304 :           if (el->expr == NULL)
   12654                 :             :             {
   12655                 :             :               /* NULL expressions are used to represent '*' arguments.
   12656                 :             :                  Convert those to a 0 expressions.  */
   12657                 :         113 :               el->expr = gfc_get_constant_expr (BT_INTEGER,
   12658                 :             :                                                 gfc_default_integer_kind,
   12659                 :             :                                                 &code->loc);
   12660                 :         113 :               mpz_set_si (el->expr->value.integer, 0);
   12661                 :             :             }
   12662                 :             :           else
   12663                 :             :             {
   12664                 :         191 :               resolve_positive_int_expr (el->expr, "TILE");
   12665                 :         191 :               if (el->expr->expr_type != EXPR_CONSTANT)
   12666                 :          14 :                 gfc_error ("TILE requires constant expression at %L",
   12667                 :             :                            &code->loc);
   12668                 :             :             }
   12669                 :             :         }
   12670                 :             :     }
   12671                 :             : }
   12672                 :             : 
   12673                 :             : 
   12674                 :             : void
   12675                 :       10095 : gfc_resolve_oacc_blocks (gfc_code *code, gfc_namespace *ns)
   12676                 :             : {
   12677                 :       10095 :   fortran_omp_context ctx;
   12678                 :       10095 :   gfc_omp_clauses *omp_clauses = code->ext.omp_clauses;
   12679                 :       10095 :   gfc_omp_namelist *n;
   12680                 :       10095 :   int list;
   12681                 :             : 
   12682                 :       10095 :   resolve_oacc_loop_blocks (code);
   12683                 :             : 
   12684                 :       10095 :   ctx.code = code;
   12685                 :       10095 :   ctx.sharing_clauses = new hash_set<gfc_symbol *>;
   12686                 :       10095 :   ctx.private_iterators = new hash_set<gfc_symbol *>;
   12687                 :       10095 :   ctx.previous = omp_current_ctx;
   12688                 :       10095 :   ctx.is_openmp = false;
   12689                 :       10095 :   omp_current_ctx = &ctx;
   12690                 :             : 
   12691                 :      393705 :   for (list = 0; list < OMP_LIST_NUM; list++)
   12692                 :      383610 :     switch (list)
   12693                 :             :       {
   12694                 :       10095 :       case OMP_LIST_PRIVATE:
   12695                 :       10682 :         for (n = omp_clauses->lists[list]; n; n = n->next)
   12696                 :         587 :           ctx.sharing_clauses->add (n->sym);
   12697                 :             :         break;
   12698                 :             :       default:
   12699                 :             :         break;
   12700                 :             :       }
   12701                 :             : 
   12702                 :       10095 :   gfc_resolve_blocks (code->block, ns);
   12703                 :             : 
   12704                 :       10095 :   omp_current_ctx = ctx.previous;
   12705                 :       20190 :   delete ctx.sharing_clauses;
   12706                 :       20190 :   delete ctx.private_iterators;
   12707                 :       10095 : }
   12708                 :             : 
   12709                 :             : 
   12710                 :             : static void
   12711                 :        5269 : resolve_oacc_loop (gfc_code *code)
   12712                 :             : {
   12713                 :        5269 :   gfc_code *do_code;
   12714                 :        5269 :   int collapse;
   12715                 :             : 
   12716                 :        5269 :   if (code->ext.omp_clauses)
   12717                 :        5269 :     resolve_omp_clauses (code, code->ext.omp_clauses, NULL, true);
   12718                 :             : 
   12719                 :        5269 :   do_code = code->block->next;
   12720                 :        5269 :   collapse = code->ext.omp_clauses->collapse;
   12721                 :             : 
   12722                 :             :   /* Both collapsed and tiled loops are lowered the same way, but are not
   12723                 :             :      compatible.  In gfc_trans_omp_do, the tile is prioritized.  */
   12724                 :        5269 :   if (code->ext.omp_clauses->tile_list)
   12725                 :             :     {
   12726                 :             :       int num = 0;
   12727                 :             :       gfc_expr_list *el;
   12728                 :         501 :       for (el = code->ext.omp_clauses->tile_list; el; el = el->next)
   12729                 :         304 :         ++num;
   12730                 :         197 :       resolve_oacc_nested_loops (code, code->block->next, num, "tiled");
   12731                 :         197 :       return;
   12732                 :             :     }
   12733                 :             : 
   12734                 :        5072 :   if (collapse <= 0)
   12735                 :             :     collapse = 1;
   12736                 :        5072 :   resolve_oacc_nested_loops (code, do_code, collapse, "collapsed");
   12737                 :             : }
   12738                 :             : 
   12739                 :             : void
   12740                 :      315870 : gfc_resolve_oacc_declare (gfc_namespace *ns)
   12741                 :             : {
   12742                 :      315870 :   int list;
   12743                 :      315870 :   gfc_omp_namelist *n;
   12744                 :      315870 :   gfc_oacc_declare *oc;
   12745                 :             : 
   12746                 :      315870 :   if (ns->oacc_declare == NULL)
   12747                 :             :     return;
   12748                 :             : 
   12749                 :         280 :   for (oc = ns->oacc_declare; oc; oc = oc->next)
   12750                 :             :     {
   12751                 :        6123 :       for (list = 0; list < OMP_LIST_NUM; list++)
   12752                 :        6210 :         for (n = oc->clauses->lists[list]; n; n = n->next)
   12753                 :             :           {
   12754                 :         244 :             n->sym->mark = 0;
   12755                 :         244 :             if (n->sym->attr.flavor != FL_VARIABLE
   12756                 :          11 :                 && (n->sym->attr.flavor != FL_PROCEDURE
   12757                 :           8 :                     || n->sym->result != n->sym))
   12758                 :             :               {
   12759                 :           9 :                 gfc_error ("Object %qs is not a variable at %L",
   12760                 :             :                            n->sym->name, &oc->loc);
   12761                 :           9 :                 continue;
   12762                 :             :               }
   12763                 :             : 
   12764                 :         235 :             if (n->expr && n->expr->ref->type == REF_ARRAY)
   12765                 :             :               {
   12766                 :           1 :                 gfc_error ("Array sections: %qs not allowed in"
   12767                 :             :                            " !$ACC DECLARE at %L", n->sym->name, &oc->loc);
   12768                 :           1 :                 continue;
   12769                 :             :               }
   12770                 :             :           }
   12771                 :             : 
   12772                 :         246 :       for (n = oc->clauses->lists[OMP_LIST_DEVICE_RESIDENT]; n; n = n->next)
   12773                 :          89 :         check_array_not_assumed (n->sym, oc->loc, "DEVICE_RESIDENT");
   12774                 :             :     }
   12775                 :             : 
   12776                 :         280 :   for (oc = ns->oacc_declare; oc; oc = oc->next)
   12777                 :             :     {
   12778                 :        6123 :       for (list = 0; list < OMP_LIST_NUM; list++)
   12779                 :        6210 :         for (n = oc->clauses->lists[list]; n; n = n->next)
   12780                 :             :           {
   12781                 :         244 :             if (n->sym->mark)
   12782                 :             :               {
   12783                 :           8 :                 gfc_error ("Symbol %qs present on multiple clauses at %L",
   12784                 :             :                            n->sym->name, &oc->loc);
   12785                 :           8 :                 continue;
   12786                 :             :               }
   12787                 :             :             else
   12788                 :         236 :               n->sym->mark = 1;
   12789                 :             :           }
   12790                 :             :     }
   12791                 :             : 
   12792                 :         280 :   for (oc = ns->oacc_declare; oc; oc = oc->next)
   12793                 :             :     {
   12794                 :        6123 :       for (list = 0; list < OMP_LIST_NUM; list++)
   12795                 :        6210 :         for (n = oc->clauses->lists[list]; n; n = n->next)
   12796                 :         244 :           n->sym->mark = 0;
   12797                 :             :     }
   12798                 :             : }
   12799                 :             : 
   12800                 :             : 
   12801                 :             : void
   12802                 :      315870 : gfc_resolve_oacc_routines (gfc_namespace *ns)
   12803                 :             : {
   12804                 :      315870 :   for (gfc_oacc_routine_name *orn = ns->oacc_routine_names;
   12805                 :      315970 :        orn;
   12806                 :         100 :        orn = orn->next)
   12807                 :             :     {
   12808                 :         100 :       gfc_symbol *sym = orn->sym;
   12809                 :         107 :       if (!sym->attr.external
   12810                 :             :           && !sym->attr.function
   12811                 :         100 :           && !sym->attr.subroutine)
   12812                 :             :         {
   12813                 :           7 :           gfc_error ("NAME %qs does not refer to a subroutine or function"
   12814                 :             :                      " in !$ACC ROUTINE ( NAME ) at %L", sym->name, &orn->loc);
   12815                 :           7 :           continue;
   12816                 :             :         }
   12817                 :          93 :       if (!gfc_add_omp_declare_target (&sym->attr, sym->name, &orn->loc))
   12818                 :             :         {
   12819                 :          20 :           gfc_error ("NAME %qs invalid"
   12820                 :             :                      " in !$ACC ROUTINE ( NAME ) at %L", sym->name, &orn->loc);
   12821                 :          20 :           continue;
   12822                 :             :         }
   12823                 :             :     }
   12824                 :      315870 : }
   12825                 :             : 
   12826                 :             : 
   12827                 :             : void
   12828                 :       13088 : gfc_resolve_oacc_directive (gfc_code *code, gfc_namespace *ns ATTRIBUTE_UNUSED)
   12829                 :             : {
   12830                 :       13088 :   resolve_oacc_directive_inside_omp_region (code);
   12831                 :             : 
   12832                 :       13088 :   switch (code->op)
   12833                 :             :     {
   12834                 :        7276 :     case EXEC_OACC_PARALLEL:
   12835                 :        7276 :     case EXEC_OACC_KERNELS:
   12836                 :        7276 :     case EXEC_OACC_SERIAL:
   12837                 :        7276 :     case EXEC_OACC_DATA:
   12838                 :        7276 :     case EXEC_OACC_HOST_DATA:
   12839                 :        7276 :     case EXEC_OACC_UPDATE:
   12840                 :        7276 :     case EXEC_OACC_ENTER_DATA:
   12841                 :        7276 :     case EXEC_OACC_EXIT_DATA:
   12842                 :        7276 :     case EXEC_OACC_WAIT:
   12843                 :        7276 :     case EXEC_OACC_CACHE:
   12844                 :        7276 :       resolve_omp_clauses (code, code->ext.omp_clauses, NULL, true);
   12845                 :        7276 :       break;
   12846                 :        5269 :     case EXEC_OACC_PARALLEL_LOOP:
   12847                 :        5269 :     case EXEC_OACC_KERNELS_LOOP:
   12848                 :        5269 :     case EXEC_OACC_SERIAL_LOOP:
   12849                 :        5269 :     case EXEC_OACC_LOOP:
   12850                 :        5269 :       resolve_oacc_loop (code);
   12851                 :        5269 :       break;
   12852                 :         543 :     case EXEC_OACC_ATOMIC:
   12853                 :         543 :       resolve_omp_atomic (code);
   12854                 :         543 :       break;
   12855                 :             :     default:
   12856                 :             :       break;
   12857                 :             :     }
   12858                 :       13088 : }
   12859                 :             : 
   12860                 :             : 
   12861                 :             : static void
   12862                 :        1732 : resolve_omp_target (gfc_code *code)
   12863                 :             : {
   12864                 :             : #define GFC_IS_TEAMS_CONSTRUCT(op)                      \
   12865                 :             :   (op == EXEC_OMP_TEAMS                                 \
   12866                 :             :    || op == EXEC_OMP_TEAMS_DISTRIBUTE                   \
   12867                 :             :    || op == EXEC_OMP_TEAMS_DISTRIBUTE_SIMD              \
   12868                 :             :    || op == EXEC_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO       \
   12869                 :             :    || op == EXEC_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD  \
   12870                 :             :    || op == EXEC_OMP_TEAMS_LOOP)
   12871                 :             : 
   12872                 :        1732 :   if (!code->ext.omp_clauses->contains_teams_construct)
   12873                 :             :     return;
   12874                 :         203 :   gfc_code *c = code->block->next;
   12875                 :         203 :   if (c->op == EXEC_BLOCK)
   12876                 :          30 :     c = c->ext.block.ns->code;
   12877                 :         203 :   if (code->ext.omp_clauses->target_first_st_is_teams_or_meta)
   12878                 :             :     {
   12879                 :         192 :       if (c->op == EXEC_OMP_METADIRECTIVE)
   12880                 :             :         {
   12881                 :          15 :           struct gfc_omp_variant *mc
   12882                 :             :             = c->ext.omp_variants;
   12883                 :             :           /* All mc->(next...->)code should be identical with regards
   12884                 :             :              to the diagnostic below.  */
   12885                 :          16 :           do
   12886                 :             :             {
   12887                 :          16 :               if (mc->stmt != ST_NONE
   12888                 :          15 :                   && GFC_IS_TEAMS_CONSTRUCT (mc->code->op))
   12889                 :             :                 {
   12890                 :          14 :                   if (c->next == NULL && mc->code->next == NULL)
   12891                 :             :                     return;
   12892                 :             :                   c = mc->code;
   12893                 :             :                   break;
   12894                 :             :                 }
   12895                 :           2 :               mc = mc->next;
   12896                 :             :             }
   12897                 :           2 :           while (mc);
   12898                 :             :         }
   12899                 :         177 :       else if (GFC_IS_TEAMS_CONSTRUCT (c->op) && c->next == NULL)
   12900                 :             :         return;
   12901                 :             :     }
   12902                 :             : 
   12903                 :          31 :   while (c && !GFC_IS_TEAMS_CONSTRUCT (c->op))
   12904                 :           8 :     c = c->next;
   12905                 :          23 :   if (c)
   12906                 :          19 :     gfc_error ("!$OMP TARGET region at %L with a nested TEAMS at %L may not "
   12907                 :             :                "contain any other statement, declaration or directive outside "
   12908                 :             :                "of the single TEAMS construct", &c->loc, &code->loc);
   12909                 :             :   else
   12910                 :           4 :     gfc_error ("!$OMP TARGET region at %L with a nested TEAMS may not "
   12911                 :             :                "contain any other statement, declaration or directive outside "
   12912                 :             :                "of the single TEAMS construct", &code->loc);
   12913                 :             : #undef GFC_IS_TEAMS_CONSTRUCT
   12914                 :             : }
   12915                 :             : 
   12916                 :             : static void
   12917                 :         154 : resolve_omp_dispatch (gfc_code *code)
   12918                 :             : {
   12919                 :         154 :   gfc_code *next = code->block->next;
   12920                 :         154 :   if (next == NULL)
   12921                 :             :     return;
   12922                 :             : 
   12923                 :         151 :   gfc_exec_op op = next->op;
   12924                 :         151 :   gcc_assert (op == EXEC_CALL || op == EXEC_ASSIGN);
   12925                 :         151 :   if (op != EXEC_CALL
   12926                 :          74 :       && (op != EXEC_ASSIGN || next->expr2->expr_type != EXPR_FUNCTION))
   12927                 :           3 :     gfc_error (
   12928                 :             :       "%<OMP DISPATCH%> directive at %L must be followed by a procedure "
   12929                 :             :       "call with optional assignment",
   12930                 :             :       &code->loc);
   12931                 :             : 
   12932                 :          77 :   if ((op == EXEC_CALL && next->resolved_sym != NULL
   12933                 :          76 :        && next->resolved_sym->attr.proc_pointer)
   12934                 :         150 :       || (op == EXEC_ASSIGN && gfc_expr_attr (next->expr2).proc_pointer))
   12935                 :           1 :     gfc_error ("%<OMP DISPATCH%> directive at %L cannot be followed by a "
   12936                 :             :                "procedure pointer",
   12937                 :             :                &code->loc);
   12938                 :             : }
   12939                 :             : 
   12940                 :             : /* Resolve OpenMP directive clauses and check various requirements
   12941                 :             :    of each directive.  */
   12942                 :             : 
   12943                 :             : void
   12944                 :       20265 : gfc_resolve_omp_directive (gfc_code *code, gfc_namespace *ns)
   12945                 :             : {
   12946                 :       20265 :   resolve_omp_directive_inside_oacc_region (code);
   12947                 :             : 
   12948                 :       20265 :   if (code->op != EXEC_OMP_ATOMIC)
   12949                 :       18111 :     gfc_maybe_initialize_eh ();
   12950                 :             : 
   12951                 :       20265 :   switch (code->op)
   12952                 :             :     {
   12953                 :        5366 :     case EXEC_OMP_DISTRIBUTE:
   12954                 :        5366 :     case EXEC_OMP_DISTRIBUTE_PARALLEL_DO:
   12955                 :        5366 :     case EXEC_OMP_DISTRIBUTE_PARALLEL_DO_SIMD:
   12956                 :        5366 :     case EXEC_OMP_DISTRIBUTE_SIMD:
   12957                 :        5366 :     case EXEC_OMP_DO:
   12958                 :        5366 :     case EXEC_OMP_DO_SIMD:
   12959                 :        5366 :     case EXEC_OMP_LOOP:
   12960                 :        5366 :     case EXEC_OMP_PARALLEL_DO:
   12961                 :        5366 :     case EXEC_OMP_PARALLEL_DO_SIMD:
   12962                 :        5366 :     case EXEC_OMP_PARALLEL_LOOP:
   12963                 :        5366 :     case EXEC_OMP_PARALLEL_MASKED_TASKLOOP:
   12964                 :        5366 :     case EXEC_OMP_PARALLEL_MASKED_TASKLOOP_SIMD:
   12965                 :        5366 :     case EXEC_OMP_PARALLEL_MASTER_TASKLOOP:
   12966                 :        5366 :     case EXEC_OMP_PARALLEL_MASTER_TASKLOOP_SIMD:
   12967                 :        5366 :     case EXEC_OMP_MASKED_TASKLOOP:
   12968                 :        5366 :     case EXEC_OMP_MASKED_TASKLOOP_SIMD:
   12969                 :        5366 :     case EXEC_OMP_MASTER_TASKLOOP:
   12970                 :        5366 :     case EXEC_OMP_MASTER_TASKLOOP_SIMD:
   12971                 :        5366 :     case EXEC_OMP_SIMD:
   12972                 :        5366 :     case EXEC_OMP_TARGET_PARALLEL_DO:
   12973                 :        5366 :     case EXEC_OMP_TARGET_PARALLEL_DO_SIMD:
   12974                 :        5366 :     case EXEC_OMP_TARGET_PARALLEL_LOOP:
   12975                 :        5366 :     case EXEC_OMP_TARGET_SIMD:
   12976                 :        5366 :     case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE:
   12977                 :        5366 :     case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO:
   12978                 :        5366 :     case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD:
   12979                 :        5366 :     case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_SIMD:
   12980                 :        5366 :     case EXEC_OMP_TARGET_TEAMS_LOOP:
   12981                 :        5366 :     case EXEC_OMP_TASKLOOP:
   12982                 :        5366 :     case EXEC_OMP_TASKLOOP_SIMD:
   12983                 :        5366 :     case EXEC_OMP_TEAMS_DISTRIBUTE:
   12984                 :        5366 :     case EXEC_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO:
   12985                 :        5366 :     case EXEC_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD:
   12986                 :        5366 :     case EXEC_OMP_TEAMS_DISTRIBUTE_SIMD:
   12987                 :        5366 :     case EXEC_OMP_TEAMS_LOOP:
   12988                 :        5366 :     case EXEC_OMP_TILE:
   12989                 :        5366 :     case EXEC_OMP_UNROLL:
   12990                 :        5366 :       resolve_omp_do (code);
   12991                 :        5366 :       break;
   12992                 :        1732 :     case EXEC_OMP_TARGET:
   12993                 :        1732 :       resolve_omp_target (code);
   12994                 :        9403 :       gcc_fallthrough ();
   12995                 :        9403 :     case EXEC_OMP_ALLOCATE:
   12996                 :        9403 :     case EXEC_OMP_ALLOCATORS:
   12997                 :        9403 :     case EXEC_OMP_ASSUME:
   12998                 :        9403 :     case EXEC_OMP_CANCEL:
   12999                 :        9403 :     case EXEC_OMP_ERROR:
   13000                 :        9403 :     case EXEC_OMP_INTEROP:
   13001                 :        9403 :     case EXEC_OMP_MASKED:
   13002                 :        9403 :     case EXEC_OMP_ORDERED:
   13003                 :        9403 :     case EXEC_OMP_PARALLEL_WORKSHARE:
   13004                 :        9403 :     case EXEC_OMP_PARALLEL:
   13005                 :        9403 :     case EXEC_OMP_PARALLEL_MASKED:
   13006                 :        9403 :     case EXEC_OMP_PARALLEL_MASTER:
   13007                 :        9403 :     case EXEC_OMP_PARALLEL_SECTIONS:
   13008                 :        9403 :     case EXEC_OMP_SCOPE:
   13009                 :        9403 :     case EXEC_OMP_SECTIONS:
   13010                 :        9403 :     case EXEC_OMP_SINGLE:
   13011                 :        9403 :     case EXEC_OMP_TARGET_DATA:
   13012                 :        9403 :     case EXEC_OMP_TARGET_ENTER_DATA:
   13013                 :        9403 :     case EXEC_OMP_TARGET_EXIT_DATA:
   13014                 :        9403 :     case EXEC_OMP_TARGET_PARALLEL:
   13015                 :        9403 :     case EXEC_OMP_TARGET_TEAMS:
   13016                 :        9403 :     case EXEC_OMP_TASK:
   13017                 :        9403 :     case EXEC_OMP_TASKWAIT:
   13018                 :        9403 :     case EXEC_OMP_TEAMS:
   13019                 :        9403 :     case EXEC_OMP_WORKSHARE:
   13020                 :        9403 :     case EXEC_OMP_DEPOBJ:
   13021                 :        9403 :       if (code->ext.omp_clauses)
   13022                 :        9271 :         resolve_omp_clauses (code, code->ext.omp_clauses, NULL);
   13023                 :             :       break;
   13024                 :        1704 :     case EXEC_OMP_TARGET_UPDATE:
   13025                 :        1704 :       if (code->ext.omp_clauses)
   13026                 :        1704 :         resolve_omp_clauses (code, code->ext.omp_clauses, NULL);
   13027                 :        1704 :       if (code->ext.omp_clauses == NULL
   13028                 :        1704 :           || (code->ext.omp_clauses->lists[OMP_LIST_TO] == NULL
   13029                 :         992 :               && code->ext.omp_clauses->lists[OMP_LIST_FROM] == NULL))
   13030                 :           0 :         gfc_error ("OMP TARGET UPDATE at %L requires at least one TO or "
   13031                 :             :                    "FROM clause", &code->loc);
   13032                 :             :       break;
   13033                 :        2154 :     case EXEC_OMP_ATOMIC:
   13034                 :        2154 :       resolve_omp_clauses (code, code->block->ext.omp_clauses, NULL);
   13035                 :        2154 :       resolve_omp_atomic (code);
   13036                 :        2154 :       break;
   13037                 :         159 :     case EXEC_OMP_CRITICAL:
   13038                 :         159 :       resolve_omp_clauses (code, code->ext.omp_clauses, NULL);
   13039                 :         159 :       if (!code->ext.omp_clauses->critical_name
   13040                 :         112 :           && code->ext.omp_clauses->hint
   13041                 :           3 :           && code->ext.omp_clauses->hint->ts.type == BT_INTEGER
   13042                 :           3 :           && code->ext.omp_clauses->hint->expr_type == EXPR_CONSTANT
   13043                 :           3 :           && mpz_sgn (code->ext.omp_clauses->hint->value.integer) != 0)
   13044                 :           1 :         gfc_error ("OMP CRITICAL at %L with HINT clause requires a NAME, "
   13045                 :             :                    "except when omp_sync_hint_none is used", &code->loc);
   13046                 :             :       break;
   13047                 :          49 :     case EXEC_OMP_SCAN:
   13048                 :             :       /* Flag is only used to checking, hence, it is unset afterwards.  */
   13049                 :          49 :       if (!code->ext.omp_clauses->if_present)
   13050                 :          10 :         gfc_error ("Unexpected !$OMP SCAN at %L outside loop construct with "
   13051                 :             :                    "%<inscan%> REDUCTION clause", &code->loc);
   13052                 :          49 :       code->ext.omp_clauses->if_present = false;
   13053                 :          49 :       resolve_omp_clauses (code, code->ext.omp_clauses, ns);
   13054                 :          49 :       break;
   13055                 :         154 :     case EXEC_OMP_DISPATCH:
   13056                 :         154 :       if (code->ext.omp_clauses)
   13057                 :         154 :         resolve_omp_clauses (code, code->ext.omp_clauses, ns);
   13058                 :         154 :       resolve_omp_dispatch (code);
   13059                 :         154 :       break;
   13060                 :         109 :     case EXEC_OMP_METADIRECTIVE:
   13061                 :         109 :       resolve_omp_metadirective (code, ns);
   13062                 :         109 :       break;
   13063                 :             :     default:
   13064                 :             :       break;
   13065                 :             :     }
   13066                 :       20265 : }
   13067                 :             : 
   13068                 :             : /* Resolve !$omp declare {variant|simd} constructs in NS.
   13069                 :             :    Note that !$omp declare target is resolved in resolve_symbol.  */
   13070                 :             : 
   13071                 :             : void
   13072                 :      326171 : gfc_resolve_omp_declare (gfc_namespace *ns)
   13073                 :             : {
   13074                 :      326171 :   gfc_omp_declare_simd *ods;
   13075                 :      326407 :   for (ods = ns->omp_declare_simd; ods; ods = ods->next)
   13076                 :             :     {
   13077                 :         236 :       if (ods->proc_name != NULL
   13078                 :         196 :           && ods->proc_name != ns->proc_name)
   13079                 :           6 :         gfc_error ("!$OMP DECLARE SIMD should refer to containing procedure "
   13080                 :             :                    "%qs at %L", ns->proc_name->name, &ods->where);
   13081                 :         236 :       if (ods->clauses)
   13082                 :         218 :         resolve_omp_clauses (NULL, ods->clauses, ns);
   13083                 :             :     }
   13084                 :             : 
   13085                 :      326171 :   gfc_omp_declare_variant *odv;
   13086                 :      326171 :   gfc_omp_namelist *range_begin = NULL;
   13087                 :      326621 :   for (odv = ns->omp_declare_variant; odv; odv = odv->next)
   13088                 :         653 :     for (gfc_omp_namelist *n = odv->adjust_args_list; n != NULL; n = n->next)
   13089                 :             :       {
   13090                 :         203 :         if ((n->expr == NULL
   13091                 :           6 :              && (range_begin
   13092                 :           4 :                  || n->u.adj_args.range_start
   13093                 :           1 :                  || n->u.adj_args.omp_num_args_plus
   13094                 :           1 :                  || n->u.adj_args.omp_num_args_minus))
   13095                 :         198 :             || n->u.adj_args.error_p)
   13096                 :             :           {
   13097                 :             :           }
   13098                 :         197 :         else if (range_begin
   13099                 :         191 :                  || n->u.adj_args.range_start
   13100                 :         186 :                  || n->u.adj_args.omp_num_args_plus
   13101                 :         186 :                  || n->u.adj_args.omp_num_args_minus)
   13102                 :             :           {
   13103                 :          11 :             if (!n->expr
   13104                 :          11 :                 || !gfc_resolve_expr (n->expr)
   13105                 :          11 :                 || n->expr->expr_type != EXPR_CONSTANT
   13106                 :          10 :                 || n->expr->ts.type != BT_INTEGER
   13107                 :          10 :                 || n->expr->rank != 0
   13108                 :          10 :                 || mpz_sgn (n->expr->value.integer) < 0
   13109                 :          20 :                 || ((n->u.adj_args.omp_num_args_plus
   13110                 :           8 :                      || n->u.adj_args.omp_num_args_minus)
   13111                 :           5 :                     && mpz_sgn (n->expr->value.integer) == 0))
   13112                 :             :               {
   13113                 :           2 :                 if (n->u.adj_args.omp_num_args_plus
   13114                 :           2 :                     || n->u.adj_args.omp_num_args_minus)
   13115                 :           0 :                   gfc_error ("Expected constant non-negative scalar integer "
   13116                 :             :                              "offset expression at %L", &n->where);
   13117                 :             :                 else
   13118                 :           2 :                   gfc_error ("For range-based %<adjust_args%>, a constant "
   13119                 :             :                              "positive scalar integer expression is required "
   13120                 :             :                              "at %L", &n->where);
   13121                 :             :               }
   13122                 :             :           }
   13123                 :         186 :         else if (n->expr
   13124                 :         186 :                  && n->expr->expr_type == EXPR_CONSTANT
   13125                 :          21 :                  && n->expr->ts.type == BT_INTEGER
   13126                 :          20 :                  && mpz_sgn (n->expr->value.integer) > 0)
   13127                 :             :           {
   13128                 :             :           }
   13129                 :         166 :         else if (!n->expr
   13130                 :         166 :                  || !gfc_resolve_expr (n->expr)
   13131                 :         331 :                  || n->expr->expr_type != EXPR_VARIABLE)
   13132                 :           2 :           gfc_error ("Expected dummy parameter name or a positive integer "
   13133                 :             :                      "at %L", &n->where);
   13134                 :         164 :         else if (n->expr->expr_type == EXPR_VARIABLE)
   13135                 :         164 :           n->sym = n->expr->symtree->n.sym;
   13136                 :             : 
   13137                 :         211 :         range_begin = n->u.adj_args.range_start ? n : NULL;
   13138                 :             :       }
   13139                 :      326171 : }
   13140                 :             : 
   13141                 :             : struct omp_udr_callback_data
   13142                 :             : {
   13143                 :             :   gfc_omp_udr *omp_udr;
   13144                 :             :   bool is_initializer;
   13145                 :             : };
   13146                 :             : 
   13147                 :             : static int
   13148                 :        3598 : omp_udr_callback (gfc_expr **e, int *walk_subtrees ATTRIBUTE_UNUSED,
   13149                 :             :                   void *data)
   13150                 :             : {
   13151                 :        3598 :   struct omp_udr_callback_data *cd = (struct omp_udr_callback_data *) data;
   13152                 :        3598 :   if ((*e)->expr_type == EXPR_VARIABLE)
   13153                 :             :     {
   13154                 :        2203 :       if (cd->is_initializer)
   13155                 :             :         {
   13156                 :         535 :           if ((*e)->symtree->n.sym != cd->omp_udr->omp_priv
   13157                 :         140 :               && (*e)->symtree->n.sym != cd->omp_udr->omp_orig)
   13158                 :           4 :             gfc_error ("Variable other than OMP_PRIV or OMP_ORIG used in "
   13159                 :             :                        "INITIALIZER clause of !$OMP DECLARE REDUCTION at %L",
   13160                 :             :                        &(*e)->where);
   13161                 :             :         }
   13162                 :             :       else
   13163                 :             :         {
   13164                 :        1668 :           if ((*e)->symtree->n.sym != cd->omp_udr->omp_out
   13165                 :         597 :               && (*e)->symtree->n.sym != cd->omp_udr->omp_in)
   13166                 :           6 :             gfc_error ("Variable other than OMP_OUT or OMP_IN used in "
   13167                 :             :                        "combiner of !$OMP DECLARE REDUCTION at %L",
   13168                 :             :                        &(*e)->where);
   13169                 :             :         }
   13170                 :             :     }
   13171                 :        3598 :   return 0;
   13172                 :             : }
   13173                 :             : 
   13174                 :             : /* Resolve !$omp declare reduction constructs.  */
   13175                 :             : 
   13176                 :             : static void
   13177                 :         600 : gfc_resolve_omp_udr (gfc_omp_udr *omp_udr)
   13178                 :             : {
   13179                 :         600 :   gfc_actual_arglist *a;
   13180                 :         600 :   const char *predef_name = NULL;
   13181                 :             : 
   13182                 :         600 :   switch (omp_udr->rop)
   13183                 :             :     {
   13184                 :         599 :     case OMP_REDUCTION_PLUS:
   13185                 :         599 :     case OMP_REDUCTION_TIMES:
   13186                 :         599 :     case OMP_REDUCTION_MINUS:
   13187                 :         599 :     case OMP_REDUCTION_AND:
   13188                 :         599 :     case OMP_REDUCTION_OR:
   13189                 :         599 :     case OMP_REDUCTION_EQV:
   13190                 :         599 :     case OMP_REDUCTION_NEQV:
   13191                 :         599 :     case OMP_REDUCTION_MAX:
   13192                 :         599 :     case OMP_REDUCTION_USER:
   13193                 :         599 :       break;
   13194                 :           1 :     default:
   13195                 :           1 :       gfc_error ("Invalid operator for !$OMP DECLARE REDUCTION %s at %L",
   13196                 :             :                  omp_udr->name, &omp_udr->where);
   13197                 :          22 :       return;
   13198                 :             :     }
   13199                 :             : 
   13200                 :         599 :   if (gfc_omp_udr_predef (omp_udr->rop, omp_udr->name,
   13201                 :             :                           &omp_udr->ts, &predef_name))
   13202                 :             :     {
   13203                 :          18 :       if (predef_name)
   13204                 :          18 :         gfc_error_now ("Redefinition of predefined %s "
   13205                 :             :                        "!$OMP DECLARE REDUCTION at %L",
   13206                 :             :                        predef_name, &omp_udr->where);
   13207                 :             :       else
   13208                 :           0 :         gfc_error_now ("Redefinition of predefined "
   13209                 :             :                        "!$OMP DECLARE REDUCTION at %L", &omp_udr->where);
   13210                 :          18 :       return;
   13211                 :             :     }
   13212                 :             : 
   13213                 :         581 :   if (omp_udr->ts.type == BT_CHARACTER
   13214                 :          62 :       && omp_udr->ts.u.cl->length
   13215                 :          32 :       && omp_udr->ts.u.cl->length->expr_type != EXPR_CONSTANT)
   13216                 :             :     {
   13217                 :           1 :       gfc_error ("CHARACTER length in !$OMP DECLARE REDUCTION %s not "
   13218                 :             :                  "constant at %L", omp_udr->name, &omp_udr->where);
   13219                 :           1 :       return;
   13220                 :             :     }
   13221                 :             : 
   13222                 :         580 :   struct omp_udr_callback_data cd;
   13223                 :         580 :   cd.omp_udr = omp_udr;
   13224                 :         580 :   cd.is_initializer = false;
   13225                 :         580 :   gfc_code_walker (&omp_udr->combiner_ns->code, gfc_dummy_code_callback,
   13226                 :             :                    omp_udr_callback, &cd);
   13227                 :         580 :   if (omp_udr->combiner_ns->code->op == EXEC_CALL)
   13228                 :             :     {
   13229                 :         346 :       for (a = omp_udr->combiner_ns->code->ext.actual; a; a = a->next)
   13230                 :         237 :         if (a->expr == NULL)
   13231                 :             :           break;
   13232                 :         110 :       if (a)
   13233                 :           1 :         gfc_error ("Subroutine call with alternate returns in combiner "
   13234                 :             :                    "of !$OMP DECLARE REDUCTION at %L",
   13235                 :             :                    &omp_udr->combiner_ns->code->loc);
   13236                 :             :     }
   13237                 :         580 :   if (omp_udr->initializer_ns)
   13238                 :             :     {
   13239                 :         373 :       cd.is_initializer = true;
   13240                 :         373 :       gfc_code_walker (&omp_udr->initializer_ns->code, gfc_dummy_code_callback,
   13241                 :             :                        omp_udr_callback, &cd);
   13242                 :         373 :       if (omp_udr->initializer_ns->code->op == EXEC_CALL)
   13243                 :             :         {
   13244                 :         377 :           for (a = omp_udr->initializer_ns->code->ext.actual; a; a = a->next)
   13245                 :         243 :             if (a->expr == NULL)
   13246                 :             :               break;
   13247                 :         135 :           if (a)
   13248                 :           1 :             gfc_error ("Subroutine call with alternate returns in "
   13249                 :             :                        "INITIALIZER clause of !$OMP DECLARE REDUCTION "
   13250                 :             :                        "at %L", &omp_udr->initializer_ns->code->loc);
   13251                 :         136 :           for (a = omp_udr->initializer_ns->code->ext.actual; a; a = a->next)
   13252                 :         135 :             if (a->expr
   13253                 :         135 :                 && a->expr->expr_type == EXPR_VARIABLE
   13254                 :         135 :                 && a->expr->symtree->n.sym == omp_udr->omp_priv
   13255                 :         134 :                 && a->expr->ref == NULL)
   13256                 :             :               break;
   13257                 :         135 :           if (a == NULL)
   13258                 :           1 :             gfc_error ("One of actual subroutine arguments in INITIALIZER "
   13259                 :             :                        "clause of !$OMP DECLARE REDUCTION must be OMP_PRIV "
   13260                 :             :                        "at %L", &omp_udr->initializer_ns->code->loc);
   13261                 :             :         }
   13262                 :             :     }
   13263                 :         207 :   else if (omp_udr->ts.type == BT_DERIVED
   13264                 :         207 :            && !gfc_has_default_initializer (omp_udr->ts.u.derived))
   13265                 :             :     {
   13266                 :           1 :       gfc_error ("Missing INITIALIZER clause for !$OMP DECLARE REDUCTION "
   13267                 :             :                  "of derived type without default initializer at %L",
   13268                 :             :                  &omp_udr->where);
   13269                 :           1 :       return;
   13270                 :             :     }
   13271                 :             : }
   13272                 :             : 
   13273                 :             : void
   13274                 :      327179 : gfc_resolve_omp_udrs (gfc_symtree *st)
   13275                 :             : {
   13276                 :      327179 :   gfc_omp_udr *omp_udr;
   13277                 :             : 
   13278                 :      327179 :   if (st == NULL)
   13279                 :             :     return;
   13280                 :         504 :   gfc_resolve_omp_udrs (st->left);
   13281                 :         504 :   gfc_resolve_omp_udrs (st->right);
   13282                 :        1104 :   for (omp_udr = st->n.omp_udr; omp_udr; omp_udr = omp_udr->next)
   13283                 :         600 :     gfc_resolve_omp_udr (omp_udr);
   13284                 :             : }
        

Generated by: LCOV version 2.1-beta

LCOV profile is generated on x86_64 machine using following configure options: configure --disable-bootstrap --enable-coverage=opt --enable-languages=c,c++,fortran,go,jit,lto,rust,m2 --enable-host-shared. GCC test suite is run with the built compiler.