LCOV - code coverage report
Current view: top level - gcc/fortran - parse.c (source / functions) Hit Total Coverage
Test: gcc.info Lines: 3232 3815 84.7 %
Date: 2020-03-28 11:57:23 Functions: 70 73 95.9 %
Legend: Lines: hit not hit | Branches: + taken - not taken # not executed Branches: 0 0 -

           Branch data     Line data    Source code
       1                 :            : /* Main parser.
       2                 :            :    Copyright (C) 2000-2020 Free Software Foundation, Inc.
       3                 :            :    Contributed by Andy Vaught
       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                 :            : #include "config.h"
      22                 :            : #include "system.h"
      23                 :            : #include "coretypes.h"
      24                 :            : #include "options.h"
      25                 :            : #include "gfortran.h"
      26                 :            : #include <setjmp.h>
      27                 :            : #include "match.h"
      28                 :            : #include "parse.h"
      29                 :            : 
      30                 :            : /* Current statement label.  Zero means no statement label.  Because new_st
      31                 :            :    can get wiped during statement matching, we have to keep it separate.  */
      32                 :            : 
      33                 :            : gfc_st_label *gfc_statement_label;
      34                 :            : 
      35                 :            : static locus label_locus;
      36                 :            : static jmp_buf eof_buf;
      37                 :            : 
      38                 :            : gfc_state_data *gfc_state_stack;
      39                 :            : static bool last_was_use_stmt = false;
      40                 :            : 
      41                 :            : /* TODO: Re-order functions to kill these forward decls.  */
      42                 :            : static void check_statement_label (gfc_statement);
      43                 :            : static void undo_new_statement (void);
      44                 :            : static void reject_statement (void);
      45                 :            : 
      46                 :            : 
      47                 :            : /* A sort of half-matching function.  We try to match the word on the
      48                 :            :    input with the passed string.  If this succeeds, we call the
      49                 :            :    keyword-dependent matching function that will match the rest of the
      50                 :            :    statement.  For single keywords, the matching subroutine is
      51                 :            :    gfc_match_eos().  */
      52                 :            : 
      53                 :            : static match
      54                 :   10410300 : match_word (const char *str, match (*subr) (void), locus *old_locus)
      55                 :            : {
      56                 :   10410300 :   match m;
      57                 :            : 
      58                 :    4451220 :   if (str != NULL)
      59                 :            :     {
      60                 :    4451220 :       m = gfc_match (str);
      61                 :    4451220 :       if (m != MATCH_YES)
      62                 :            :         return m;
      63                 :            :     }
      64                 :            : 
      65                 :     881848 :   m = (*subr) ();
      66                 :            : 
      67                 :    6840970 :   if (m != MATCH_YES)
      68                 :            :     {
      69                 :    5673870 :       gfc_current_locus = *old_locus;
      70                 :    5673870 :       reject_statement ();
      71                 :            :     }
      72                 :            : 
      73                 :            :   return m;
      74                 :            : }
      75                 :            : 
      76                 :            : 
      77                 :            : /* Like match_word, but if str is matched, set a flag that it
      78                 :            :    was matched.  */
      79                 :            : static match
      80                 :      59776 : match_word_omp_simd (const char *str, match (*subr) (void), locus *old_locus,
      81                 :            :                      bool *simd_matched)
      82                 :            : {
      83                 :      59776 :   match m;
      84                 :            : 
      85                 :      59776 :   if (str != NULL)
      86                 :            :     {
      87                 :      59776 :       m = gfc_match (str);
      88                 :      59776 :       if (m != MATCH_YES)
      89                 :            :         return m;
      90                 :       1767 :       *simd_matched = true;
      91                 :            :     }
      92                 :            : 
      93                 :       1767 :   m = (*subr) ();
      94                 :            : 
      95                 :       1767 :   if (m != MATCH_YES)
      96                 :            :     {
      97                 :         16 :       gfc_current_locus = *old_locus;
      98                 :         16 :       reject_statement ();
      99                 :            :     }
     100                 :            : 
     101                 :            :   return m;
     102                 :            : }
     103                 :            : 
     104                 :            : 
     105                 :            : /* Load symbols from all USE statements encountered in this scoping unit.  */
     106                 :            : 
     107                 :            : static void
     108                 :      11820 : use_modules (void)
     109                 :            : {
     110                 :      11820 :   gfc_error_buffer old_error;
     111                 :            : 
     112                 :      11820 :   gfc_push_error (&old_error);
     113                 :      11820 :   gfc_buffer_error (false);
     114                 :      11820 :   gfc_use_modules ();
     115                 :      11817 :   gfc_buffer_error (true);
     116                 :      11817 :   gfc_pop_error (&old_error);
     117                 :      11817 :   gfc_commit_symbols ();
     118                 :      11817 :   gfc_warning_check ();
     119                 :      11817 :   gfc_current_ns->old_equiv = gfc_current_ns->equiv;
     120                 :      11817 :   gfc_current_ns->old_data = gfc_current_ns->data;
     121                 :      11817 :   last_was_use_stmt = false;
     122                 :      11817 : }
     123                 :            : 
     124                 :            : 
     125                 :            : /* Figure out what the next statement is, (mostly) regardless of
     126                 :            :    proper ordering.  The do...while(0) is there to prevent if/else
     127                 :            :    ambiguity.  */
     128                 :            : 
     129                 :            : #define match(keyword, subr, st)                                \
     130                 :            :     do {                                                        \
     131                 :            :       if (match_word (keyword, subr, &old_locus) == MATCH_YES)      \
     132                 :            :         return st;                                              \
     133                 :            :       else                                                      \
     134                 :            :         undo_new_statement ();                                  \
     135                 :            :     } while (0)
     136                 :            : 
     137                 :            : 
     138                 :            : /* This is a specialist version of decode_statement that is used
     139                 :            :    for the specification statements in a function, whose
     140                 :            :    characteristics are deferred into the specification statements.
     141                 :            :    eg.:  INTEGER (king = mykind) foo ()
     142                 :            :          USE mymodule, ONLY mykind.....
     143                 :            :    The KIND parameter needs a return after USE or IMPORT, whereas
     144                 :            :    derived type declarations can occur anywhere, up the executable
     145                 :            :    block.  ST_GET_FCN_CHARACTERISTICS is returned when we have run
     146                 :            :    out of the correct kind of specification statements.  */
     147                 :            : static gfc_statement
     148                 :       4124 : decode_specification_statement (void)
     149                 :            : {
     150                 :       4124 :   gfc_statement st;
     151                 :       4124 :   locus old_locus;
     152                 :       4124 :   char c;
     153                 :            : 
     154                 :       4124 :   if (gfc_match_eos () == MATCH_YES)
     155                 :            :     return ST_NONE;
     156                 :            : 
     157                 :       4124 :   old_locus = gfc_current_locus;
     158                 :            : 
     159                 :       4124 :   if (match_word ("use", gfc_match_use, &old_locus) == MATCH_YES)
     160                 :            :     {
     161                 :        151 :       last_was_use_stmt = true;
     162                 :        151 :       return ST_USE;
     163                 :            :     }
     164                 :            :   else
     165                 :            :     {
     166                 :       3973 :       undo_new_statement ();
     167                 :       3973 :       if (last_was_use_stmt)
     168                 :        134 :         use_modules ();
     169                 :            :     }
     170                 :            : 
     171                 :       3973 :   match ("import", gfc_match_import, ST_IMPORT);
     172                 :            : 
     173                 :       3924 :   if (gfc_current_block ()->result->ts.type != BT_DERIVED)
     174                 :       3512 :     goto end_of_block;
     175                 :            : 
     176                 :        824 :   match (NULL, gfc_match_st_function, ST_STATEMENT_FUNCTION);
     177                 :        824 :   match (NULL, gfc_match_data_decl, ST_DATA_DECL);
     178                 :        500 :   match (NULL, gfc_match_enumerator_def, ST_ENUMERATOR);
     179                 :            : 
     180                 :            :   /* General statement matching: Instead of testing every possible
     181                 :            :      statement, we eliminate most possibilities by peeking at the
     182                 :            :      first character.  */
     183                 :            : 
     184                 :        250 :   c = gfc_peek_ascii_char ();
     185                 :            : 
     186                 :        250 :   switch (c)
     187                 :            :     {
     188                 :         55 :     case 'a':
     189                 :         55 :       match ("abstract% interface", gfc_match_abstract_interface,
     190                 :            :              ST_INTERFACE);
     191                 :         55 :       match ("allocatable", gfc_match_allocatable, ST_ATTR_DECL);
     192                 :         48 :       match ("asynchronous", gfc_match_asynchronous, ST_ATTR_DECL);
     193                 :         47 :       match ("automatic", gfc_match_automatic, ST_ATTR_DECL);
     194                 :         47 :       break;
     195                 :            : 
     196                 :          2 :     case 'b':
     197                 :          4 :       match (NULL, gfc_match_bind_c_stmt, ST_ATTR_DECL);
     198                 :          2 :       break;
     199                 :            : 
     200                 :         38 :     case 'c':
     201                 :         38 :       match ("codimension", gfc_match_codimension, ST_ATTR_DECL);
     202                 :         38 :       match ("contiguous", gfc_match_contiguous, ST_ATTR_DECL);
     203                 :         38 :       break;
     204                 :            : 
     205                 :          3 :     case 'd':
     206                 :          3 :       match ("data", gfc_match_data, ST_DATA);
     207                 :          3 :       match ("dimension", gfc_match_dimension, ST_ATTR_DECL);
     208                 :          2 :       break;
     209                 :            : 
     210                 :         55 :     case 'e':
     211                 :         55 :       match ("enum , bind ( c )", gfc_match_enum, ST_ENUM);
     212                 :         55 :       match ("entry% ", gfc_match_entry, ST_ENTRY);
     213                 :         55 :       match ("equivalence", gfc_match_equivalence, ST_EQUIVALENCE);
     214                 :         55 :       match ("external", gfc_match_external, ST_ATTR_DECL);
     215                 :         55 :       break;
     216                 :            : 
     217                 :         45 :     case 'f':
     218                 :         45 :       match ("format", gfc_match_format, ST_FORMAT);
     219                 :         45 :       break;
     220                 :            : 
     221                 :            :     case 'g':
     222                 :            :       break;
     223                 :            : 
     224                 :          8 :     case 'i':
     225                 :          8 :       match ("implicit", gfc_match_implicit, ST_IMPLICIT);
     226                 :          8 :       match ("implicit% none", gfc_match_implicit_none, ST_IMPLICIT_NONE);
     227                 :          7 :       match ("interface", gfc_match_interface, ST_INTERFACE);
     228                 :          7 :       match ("intent", gfc_match_intent, ST_ATTR_DECL);
     229                 :          7 :       match ("intrinsic", gfc_match_intrinsic, ST_ATTR_DECL);
     230                 :          7 :       break;
     231                 :            : 
     232                 :            :     case 'm':
     233                 :            :       break;
     234                 :            : 
     235                 :          7 :     case 'n':
     236                 :          7 :       match ("namelist", gfc_match_namelist, ST_NAMELIST);
     237                 :          7 :       break;
     238                 :            : 
     239                 :          0 :     case 'o':
     240                 :          0 :       match ("optional", gfc_match_optional, ST_ATTR_DECL);
     241                 :          0 :       break;
     242                 :            : 
     243                 :          6 :     case 'p':
     244                 :          6 :       match ("parameter", gfc_match_parameter, ST_PARAMETER);
     245                 :          6 :       match ("pointer", gfc_match_pointer, ST_ATTR_DECL);
     246                 :          6 :       if (gfc_match_private (&st) == MATCH_YES)
     247                 :          0 :         return st;
     248                 :          6 :       match ("procedure", gfc_match_procedure, ST_PROCEDURE);
     249                 :          6 :       if (gfc_match_public (&st) == MATCH_YES)
     250                 :          0 :         return st;
     251                 :          6 :       match ("protected", gfc_match_protected, ST_ATTR_DECL);
     252                 :          6 :       break;
     253                 :            : 
     254                 :            :     case 'r':
     255                 :            :       break;
     256                 :            : 
     257                 :          6 :     case 's':
     258                 :          6 :       match ("save", gfc_match_save, ST_ATTR_DECL);
     259                 :          6 :       match ("static", gfc_match_static, ST_ATTR_DECL);
     260                 :          6 :       match ("structure", gfc_match_structure_decl, ST_STRUCTURE_DECL);
     261                 :          6 :       break;
     262                 :            : 
     263                 :         18 :     case 't':
     264                 :         18 :       match ("target", gfc_match_target, ST_ATTR_DECL);
     265                 :         18 :       match ("type", gfc_match_derived_decl, ST_DERIVED_DECL);
     266                 :          8 :       break;
     267                 :            : 
     268                 :            :     case 'u':
     269                 :            :       break;
     270                 :            : 
     271                 :          1 :     case 'v':
     272                 :          1 :       match ("value", gfc_match_value, ST_ATTR_DECL);
     273                 :          1 :       match ("volatile", gfc_match_volatile, ST_ATTR_DECL);
     274                 :          0 :       break;
     275                 :            : 
     276                 :            :     case 'w':
     277                 :            :       break;
     278                 :            :     }
     279                 :            : 
     280                 :            :   /* This is not a specification statement.  See if any of the matchers
     281                 :            :      has stored an error message of some sort.  */
     282                 :            : 
     283                 :       3741 : end_of_block:
     284                 :       3741 :   gfc_clear_error ();
     285                 :       3741 :   gfc_buffer_error (false);
     286                 :       3741 :   gfc_current_locus = old_locus;
     287                 :            : 
     288                 :       3741 :   return ST_GET_FCN_CHARACTERISTICS;
     289                 :            : }
     290                 :            : 
     291                 :            : static bool in_specification_block;
     292                 :            : 
     293                 :            : /* This is the primary 'decode_statement'.  */
     294                 :            : static gfc_statement
     295                 :     833516 : decode_statement (void)
     296                 :            : {
     297                 :     833516 :   gfc_statement st;
     298                 :     833516 :   locus old_locus;
     299                 :     833516 :   match m = MATCH_NO;
     300                 :     833516 :   char c;
     301                 :            : 
     302                 :     833516 :   gfc_enforce_clean_symbol_state ();
     303                 :            : 
     304                 :     833516 :   gfc_clear_error ();   /* Clear any pending errors.  */
     305                 :     833516 :   gfc_clear_warning (); /* Clear any pending warnings.  */
     306                 :            : 
     307                 :     833516 :   gfc_matching_function = false;
     308                 :            : 
     309                 :     833516 :   if (gfc_match_eos () == MATCH_YES)
     310                 :            :     return ST_NONE;
     311                 :            : 
     312                 :     833502 :   if (gfc_current_state () == COMP_FUNCTION
     313                 :      57514 :         && gfc_current_block ()->result->ts.kind == -1)
     314                 :       4124 :     return decode_specification_statement ();
     315                 :            : 
     316                 :     829378 :   old_locus = gfc_current_locus;
     317                 :            : 
     318                 :     829378 :   c = gfc_peek_ascii_char ();
     319                 :            : 
     320                 :     829378 :   if (c == 'u')
     321                 :            :     {
     322                 :      15219 :       if (match_word ("use", gfc_match_use, &old_locus) == MATCH_YES)
     323                 :            :         {
     324                 :      13064 :           last_was_use_stmt = true;
     325                 :      13064 :           return ST_USE;
     326                 :            :         }
     327                 :            :       else
     328                 :       2155 :         undo_new_statement ();
     329                 :            :     }
     330                 :            : 
     331                 :     816314 :   if (last_was_use_stmt)
     332                 :      11456 :     use_modules ();
     333                 :            : 
     334                 :            :   /* Try matching a data declaration or function declaration. The
     335                 :            :       input "REALFUNCTIONA(N)" can mean several things in different
     336                 :            :       contexts, so it (and its relatives) get special treatment.  */
     337                 :            : 
     338                 :     816312 :   if (gfc_current_state () == COMP_NONE
     339                 :     816312 :       || gfc_current_state () == COMP_INTERFACE
     340                 :     762073 :       || gfc_current_state () == COMP_CONTAINS)
     341                 :            :     {
     342                 :      87297 :       gfc_matching_function = true;
     343                 :      87297 :       m = gfc_match_function_decl ();
     344                 :      87297 :       if (m == MATCH_YES)
     345                 :            :         return ST_FUNCTION;
     346                 :      74451 :       else if (m == MATCH_ERROR)
     347                 :       7228 :         reject_statement ();
     348                 :            :       else
     349                 :      67223 :         gfc_undo_symbols ();
     350                 :      74451 :       gfc_current_locus = old_locus;
     351                 :            :     }
     352                 :     803466 :   gfc_matching_function = false;
     353                 :            : 
     354                 :            :   /* Legacy parameter statements are ambiguous with assignments so try parameter
     355                 :            :      first.  */
     356                 :     803466 :   match ("parameter", gfc_match_parameter, ST_PARAMETER);
     357                 :            : 
     358                 :            :   /* Match statements whose error messages are meant to be overwritten
     359                 :            :      by something better.  */
     360                 :            : 
     361                 :    1603100 :   match (NULL, gfc_match_assignment, ST_ASSIGNMENT);
     362                 :    1334420 :   match (NULL, gfc_match_pointer_assignment, ST_POINTER_ASSIGNMENT);
     363                 :            : 
     364                 :     661557 :   if (in_specification_block)
     365                 :            :     {
     366                 :     282049 :       m = match_word (NULL, gfc_match_st_function, &old_locus);
     367                 :     282049 :       if (m == MATCH_YES)
     368                 :            :         return ST_STATEMENT_FUNCTION;
     369                 :            :     }
     370                 :            : 
     371                 :     661344 :   if (!(in_specification_block && m == MATCH_ERROR))
     372                 :            :     {
     373                 :    1322650 :       match (NULL, gfc_match_ptr_fcn_assign, ST_ASSIGNMENT);
     374                 :            :     }
     375                 :            : 
     376                 :    1322540 :   match (NULL, gfc_match_data_decl, ST_DATA_DECL);
     377                 :    1044950 :   match (NULL, gfc_match_enumerator_def, ST_ENUMERATOR);
     378                 :            : 
     379                 :            :   /* Try to match a subroutine statement, which has the same optional
     380                 :            :      prefixes that functions can have.  */
     381                 :            : 
     382                 :     522218 :   if (gfc_match_subroutine () == MATCH_YES)
     383                 :            :     return ST_SUBROUTINE;
     384                 :     495772 :   gfc_undo_symbols ();
     385                 :     495772 :   gfc_current_locus = old_locus;
     386                 :            : 
     387                 :     495772 :   if (gfc_match_submod_proc () == MATCH_YES)
     388                 :            :     {
     389                 :        135 :       if (gfc_new_block->attr.subroutine)
     390                 :            :         return ST_SUBROUTINE;
     391                 :         45 :       else if (gfc_new_block->attr.function)
     392                 :            :         return ST_FUNCTION;
     393                 :            :     }
     394                 :     495637 :   gfc_undo_symbols ();
     395                 :     495637 :   gfc_current_locus = old_locus;
     396                 :            : 
     397                 :            :   /* Check for the IF, DO, SELECT, WHERE, FORALL, CRITICAL, BLOCK and ASSOCIATE
     398                 :            :      statements, which might begin with a block label.  The match functions for
     399                 :            :      these statements are unusual in that their keyword is not seen before
     400                 :            :      the matcher is called.  */
     401                 :            : 
     402                 :     495637 :   if (gfc_match_if (&st) == MATCH_YES)
     403                 :     134867 :     return st;
     404                 :     360770 :   gfc_undo_symbols ();
     405                 :     360770 :   gfc_current_locus = old_locus;
     406                 :            : 
     407                 :     360770 :   if (gfc_match_where (&st) == MATCH_YES)
     408                 :        451 :     return st;
     409                 :     360319 :   gfc_undo_symbols ();
     410                 :     360319 :   gfc_current_locus = old_locus;
     411                 :            : 
     412                 :     360319 :   if (gfc_match_forall (&st) == MATCH_YES)
     413                 :       1948 :     return st;
     414                 :     358371 :   gfc_undo_symbols ();
     415                 :     358371 :   gfc_current_locus = old_locus;
     416                 :            : 
     417                 :            :   /* Try to match TYPE as an alias for PRINT.  */
     418                 :     358371 :   if (gfc_match_type (&st) == MATCH_YES)
     419                 :         19 :     return st;
     420                 :     358352 :   gfc_undo_symbols ();
     421                 :     358352 :   gfc_current_locus = old_locus;
     422                 :            : 
     423                 :     716704 :   match (NULL, gfc_match_do, ST_DO);
     424                 :     670482 :   match (NULL, gfc_match_block, ST_BLOCK);
     425                 :     669598 :   match (NULL, gfc_match_associate, ST_ASSOCIATE);
     426                 :     668324 :   match (NULL, gfc_match_critical, ST_CRITICAL);
     427                 :     668258 :   match (NULL, gfc_match_select, ST_SELECT_CASE);
     428                 :     667246 :   match (NULL, gfc_match_select_type, ST_SELECT_TYPE);
     429                 :     663466 :   match (NULL, gfc_match_select_rank, ST_SELECT_RANK);
     430                 :            : 
     431                 :            :   /* General statement matching: Instead of testing every possible
     432                 :            :      statement, we eliminate most possibilities by peeking at the
     433                 :            :      first character.  */
     434                 :            : 
     435                 :     331691 :   switch (c)
     436                 :            :     {
     437                 :      10106 :     case 'a':
     438                 :      10106 :       match ("abstract% interface", gfc_match_abstract_interface,
     439                 :            :              ST_INTERFACE);
     440                 :       9713 :       match ("allocate", gfc_match_allocate, ST_ALLOCATE);
     441                 :        336 :       match ("allocatable", gfc_match_allocatable, ST_ATTR_DECL);
     442                 :        293 :       match ("assign", gfc_match_assign, ST_LABEL_ASSIGNMENT);
     443                 :        144 :       match ("asynchronous", gfc_match_asynchronous, ST_ATTR_DECL);
     444                 :        138 :       match ("automatic", gfc_match_automatic, ST_ATTR_DECL);
     445                 :        131 :       break;
     446                 :            : 
     447                 :        584 :     case 'b':
     448                 :        584 :       match ("backspace", gfc_match_backspace, ST_BACKSPACE);
     449                 :        196 :       match ("block data", gfc_match_block_data, ST_BLOCK_DATA);
     450                 :        248 :       match (NULL, gfc_match_bind_c_stmt, ST_ATTR_DECL);
     451                 :         27 :       break;
     452                 :            : 
     453                 :      71226 :     case 'c':
     454                 :      71226 :       match ("call", gfc_match_call, ST_CALL);
     455                 :      22907 :       match ("change team", gfc_match_change_team, ST_CHANGE_TEAM);
     456                 :      22889 :       match ("close", gfc_match_close, ST_CLOSE);
     457                 :      19999 :       match ("continue", gfc_match_continue, ST_CONTINUE);
     458                 :      17242 :       match ("contiguous", gfc_match_contiguous, ST_ATTR_DECL);
     459                 :      17239 :       match ("cycle", gfc_match_cycle, ST_CYCLE);
     460                 :      17212 :       match ("case", gfc_match_case, ST_CASE);
     461                 :      15669 :       match ("common", gfc_match_common, ST_COMMON);
     462                 :      13728 :       match ("contains", gfc_match_eos, ST_CONTAINS);
     463                 :       1210 :       match ("class", gfc_match_class_is, ST_CLASS_IS);
     464                 :        195 :       match ("codimension", gfc_match_codimension, ST_ATTR_DECL);
     465                 :        188 :       break;
     466                 :            : 
     467                 :       6691 :     case 'd':
     468                 :       6691 :       match ("deallocate", gfc_match_deallocate, ST_DEALLOCATE);
     469                 :       2905 :       match ("data", gfc_match_data, ST_DATA);
     470                 :        645 :       match ("dimension", gfc_match_dimension, ST_ATTR_DECL);
     471                 :         67 :       break;
     472                 :            : 
     473                 :     129758 :     case 'e':
     474                 :     129758 :       match ("end file", gfc_match_endfile, ST_END_FILE);
     475                 :     129704 :       match ("end team", gfc_match_end_team, ST_END_TEAM);
     476                 :     129686 :       match ("exit", gfc_match_exit, ST_EXIT);
     477                 :     129400 :       match ("else", gfc_match_else, ST_ELSE);
     478                 :     126639 :       match ("else where", gfc_match_elsewhere, ST_ELSEWHERE);
     479                 :     126317 :       match ("else if", gfc_match_elseif, ST_ELSEIF);
     480                 :     125196 :       match ("error stop", gfc_match_error_stop, ST_ERROR_STOP);
     481                 :     125105 :       match ("enum , bind ( c )", gfc_match_enum, ST_ENUM);
     482                 :            : 
     483                 :     124947 :       if (gfc_match_end (&st) == MATCH_YES)
     484                 :     120688 :         return st;
     485                 :            : 
     486                 :       4259 :       match ("entry% ", gfc_match_entry, ST_ENTRY);
     487                 :       3570 :       match ("equivalence", gfc_match_equivalence, ST_EQUIVALENCE);
     488                 :       2557 :       match ("external", gfc_match_external, ST_ATTR_DECL);
     489                 :        290 :       match ("event post", gfc_match_event_post, ST_EVENT_POST);
     490                 :        267 :       match ("event wait", gfc_match_event_wait, ST_EVENT_WAIT);
     491                 :        251 :       break;
     492                 :            : 
     493                 :       1270 :     case 'f':
     494                 :       1270 :       match ("fail image", gfc_match_fail_image, ST_FAIL_IMAGE);
     495                 :       1266 :       match ("final", gfc_match_final_decl, ST_FINAL);
     496                 :       1102 :       match ("flush", gfc_match_flush, ST_FLUSH);
     497                 :       1031 :       match ("form team", gfc_match_form_team, ST_FORM_TEAM);
     498                 :       1007 :       match ("format", gfc_match_format, ST_FORMAT);
     499                 :         47 :       break;
     500                 :            : 
     501                 :       1429 :     case 'g':
     502                 :       1429 :       match ("generic", gfc_match_generic, ST_GENERIC);
     503                 :        670 :       match ("go to", gfc_match_goto, ST_GOTO);
     504                 :         10 :       break;
     505                 :            : 
     506                 :      27236 :     case 'i':
     507                 :      27236 :       match ("inquire", gfc_match_inquire, ST_INQUIRE);
     508                 :      26347 :       match ("implicit", gfc_match_implicit, ST_IMPLICIT);
     509                 :      25921 :       match ("implicit% none", gfc_match_implicit_none, ST_IMPLICIT_NONE);
     510                 :       9818 :       match ("import", gfc_match_import, ST_IMPORT);
     511                 :       7659 :       match ("interface", gfc_match_interface, ST_INTERFACE);
     512                 :       1877 :       match ("intent", gfc_match_intent, ST_ATTR_DECL);
     513                 :       1793 :       match ("intrinsic", gfc_match_intrinsic, ST_ATTR_DECL);
     514                 :        350 :       break;
     515                 :            : 
     516                 :         65 :     case 'l':
     517                 :         65 :       match ("lock", gfc_match_lock, ST_LOCK);
     518                 :         12 :       break;
     519                 :            : 
     520                 :       8645 :     case 'm':
     521                 :       8645 :       match ("map", gfc_match_map, ST_MAP);
     522                 :       8390 :       match ("module% procedure", gfc_match_modproc, ST_MODULE_PROC);
     523                 :       7193 :       match ("module", gfc_match_module, ST_MODULE);
     524                 :         23 :       break;
     525                 :            : 
     526                 :       1264 :     case 'n':
     527                 :       1264 :       match ("nullify", gfc_match_nullify, ST_NULLIFY);
     528                 :        931 :       match ("namelist", gfc_match_namelist, ST_NAMELIST);
     529                 :         16 :       break;
     530                 :            : 
     531                 :       3566 :     case 'o':
     532                 :       3566 :       match ("open", gfc_match_open, ST_OPEN);
     533                 :         98 :       match ("optional", gfc_match_optional, ST_ATTR_DECL);
     534                 :         66 :       break;
     535                 :            : 
     536                 :      26905 :     case 'p':
     537                 :      26905 :       match ("print", gfc_match_print, ST_WRITE);
     538                 :      22495 :       match ("pause", gfc_match_pause, ST_PAUSE);
     539                 :      22467 :       match ("pointer", gfc_match_pointer, ST_ATTR_DECL);
     540                 :      22015 :       if (gfc_match_private (&st) == MATCH_YES)
     541                 :       1057 :         return st;
     542                 :      20958 :       match ("procedure", gfc_match_procedure, ST_PROCEDURE);
     543                 :      15710 :       match ("program", gfc_match_program, ST_PROGRAM);
     544                 :       1056 :       if (gfc_match_public (&st) == MATCH_YES)
     545                 :        870 :         return st;
     546                 :        186 :       match ("protected", gfc_match_protected, ST_ATTR_DECL);
     547                 :        169 :       break;
     548                 :            : 
     549                 :       9298 :     case 'r':
     550                 :       9298 :       match ("rank", gfc_match_rank_is, ST_RANK);
     551                 :       9207 :       match ("read", gfc_match_read, ST_READ);
     552                 :       3577 :       match ("return", gfc_match_return, ST_RETURN);
     553                 :       2105 :       match ("rewind", gfc_match_rewind, ST_REWIND);
     554                 :        151 :       break;
     555                 :            : 
     556                 :       6583 :     case 's':
     557                 :       6583 :       match ("structure", gfc_match_structure_decl, ST_STRUCTURE_DECL);
     558                 :       6290 :       match ("sequence", gfc_match_eos, ST_SEQUENCE);
     559                 :       6046 :       match ("stop", gfc_match_stop, ST_STOP);
     560                 :       1250 :       match ("save", gfc_match_save, ST_ATTR_DECL);
     561                 :        993 :       match ("static", gfc_match_static, ST_ATTR_DECL);
     562                 :        992 :       match ("submodule", gfc_match_submodule, ST_SUBMODULE);
     563                 :        827 :       match ("sync all", gfc_match_sync_all, ST_SYNC_ALL);
     564                 :        235 :       match ("sync images", gfc_match_sync_images, ST_SYNC_IMAGES);
     565                 :        166 :       match ("sync memory", gfc_match_sync_memory, ST_SYNC_MEMORY);
     566                 :        107 :       match ("sync team", gfc_match_sync_team, ST_SYNC_TEAM);
     567                 :        107 :       break;
     568                 :            : 
     569                 :      11780 :     case 't':
     570                 :      11780 :       match ("target", gfc_match_target, ST_ATTR_DECL);
     571                 :      11733 :       match ("type", gfc_match_derived_decl, ST_DERIVED_DECL);
     572                 :       2285 :       match ("type is", gfc_match_type_is, ST_TYPE_IS);
     573                 :        109 :       break;
     574                 :            : 
     575                 :        198 :     case 'u':
     576                 :        198 :       match ("union", gfc_match_union, ST_UNION);
     577                 :         69 :       match ("unlock", gfc_match_unlock, ST_UNLOCK);
     578                 :         25 :       break;
     579                 :            : 
     580                 :        162 :     case 'v':
     581                 :        162 :       match ("value", gfc_match_value, ST_ATTR_DECL);
     582                 :         93 :       match ("volatile", gfc_match_volatile, ST_ATTR_DECL);
     583                 :         17 :       break;
     584                 :            : 
     585                 :      14886 :     case 'w':
     586                 :      14886 :       match ("wait", gfc_match_wait, ST_WAIT);
     587                 :      14828 :       match ("write", gfc_match_write, ST_WRITE);
     588                 :         61 :       break;
     589                 :            :     }
     590                 :            : 
     591                 :            :   /* All else has failed, so give up.  See if any of the matchers has
     592                 :            :      stored an error message of some sort.  Suppress the "Unclassifiable
     593                 :            :      statement" if a previous error message was emitted, e.g., by
     594                 :            :      gfc_error_now ().  */
     595                 :       1866 :   if (!gfc_error_check ())
     596                 :            :     {
     597                 :         46 :       int ecnt;
     598                 :         46 :       gfc_get_errors (NULL, &ecnt);
     599                 :         46 :       if (ecnt <= 0)
     600                 :         16 :         gfc_error_now ("Unclassifiable statement at %C");
     601                 :            :     }
     602                 :            : 
     603                 :       1863 :   reject_statement ();
     604                 :            : 
     605                 :       1863 :   gfc_error_recovery ();
     606                 :            : 
     607                 :       1863 :   return ST_NONE;
     608                 :            : }
     609                 :            : 
     610                 :            : /* Like match and if spec_only, goto do_spec_only without actually
     611                 :            :    matching.  */
     612                 :            : /* If the directive matched but the clauses failed, do not start
     613                 :            :    matching the next directive in the same switch statement. */
     614                 :            : #define matcha(keyword, subr, st)                               \
     615                 :            :     do {                                                        \
     616                 :            :       match m2;                                                 \
     617                 :            :       if (spec_only && gfc_match (keyword) == MATCH_YES)        \
     618                 :            :         goto do_spec_only;                                      \
     619                 :            :       else if ((m2 = match_word (keyword, subr, &old_locus))        \
     620                 :            :                == MATCH_YES)                                    \
     621                 :            :         return st;                                              \
     622                 :            :       else if (m2 == MATCH_ERROR)                               \
     623                 :            :         goto error_handling;                                    \
     624                 :            :       else                                                      \
     625                 :            :         undo_new_statement ();                                  \
     626                 :            :     } while (0)
     627                 :            : 
     628                 :            : static gfc_statement
     629                 :      16377 : decode_oacc_directive (void)
     630                 :            : {
     631                 :      16377 :   locus old_locus;
     632                 :      16377 :   char c;
     633                 :      16377 :   bool spec_only = false;
     634                 :            : 
     635                 :      16377 :   gfc_enforce_clean_symbol_state ();
     636                 :            : 
     637                 :      16377 :   gfc_clear_error ();   /* Clear any pending errors.  */
     638                 :      16377 :   gfc_clear_warning (); /* Clear any pending warnings.  */
     639                 :            : 
     640                 :      16377 :   gfc_matching_function = false;
     641                 :            : 
     642                 :      16377 :   if (gfc_pure (NULL))
     643                 :            :     {
     644                 :          4 :       gfc_error_now ("OpenACC directives at %C may not appear in PURE "
     645                 :            :                      "procedures");
     646                 :          4 :       gfc_error_recovery ();
     647                 :          4 :       return ST_NONE;
     648                 :            :     }
     649                 :            : 
     650                 :      16373 :   if (gfc_current_state () == COMP_FUNCTION
     651                 :        153 :       && gfc_current_block ()->result->ts.kind == -1)
     652                 :         33 :     spec_only = true;
     653                 :            : 
     654                 :      16373 :   gfc_unset_implicit_pure (NULL);
     655                 :            : 
     656                 :      16373 :   old_locus = gfc_current_locus;
     657                 :            : 
     658                 :            :   /* General OpenACC directive matching: Instead of testing every possible
     659                 :            :      statement, we eliminate most possibilities by peeking at the
     660                 :            :      first character.  */
     661                 :            : 
     662                 :      16373 :   c = gfc_peek_ascii_char ();
     663                 :            : 
     664                 :      16373 :   switch (c)
     665                 :            :     {
     666                 :        517 :     case 'a':
     667                 :        517 :       matcha ("atomic", gfc_match_oacc_atomic, ST_OACC_ATOMIC);
     668                 :          0 :       break;
     669                 :         74 :     case 'c':
     670                 :         74 :       matcha ("cache", gfc_match_oacc_cache, ST_OACC_CACHE);
     671                 :          0 :       break;
     672                 :        687 :     case 'd':
     673                 :        687 :       matcha ("data", gfc_match_oacc_data, ST_OACC_DATA);
     674                 :        136 :       match ("declare", gfc_match_oacc_declare, ST_OACC_DECLARE);
     675                 :         16 :       break;
     676                 :       6151 :     case 'e':
     677                 :       6151 :       matcha ("end atomic", gfc_match_omp_eos_error, ST_OACC_END_ATOMIC);
     678                 :       5659 :       matcha ("end data", gfc_match_omp_eos_error, ST_OACC_END_DATA);
     679                 :       5112 :       matcha ("end host_data", gfc_match_omp_eos_error, ST_OACC_END_HOST_DATA);
     680                 :       5052 :       matcha ("end kernels loop", gfc_match_omp_eos_error, ST_OACC_END_KERNELS_LOOP);
     681                 :       5029 :       matcha ("end kernels", gfc_match_omp_eos_error, ST_OACC_END_KERNELS);
     682                 :       4270 :       matcha ("end loop", gfc_match_omp_eos_error, ST_OACC_END_LOOP);
     683                 :       4264 :       matcha ("end parallel loop", gfc_match_omp_eos_error,
     684                 :            :               ST_OACC_END_PARALLEL_LOOP);
     685                 :       3347 :       matcha ("end parallel", gfc_match_omp_eos_error, ST_OACC_END_PARALLEL);
     686                 :        761 :       matcha ("end serial loop", gfc_match_omp_eos_error,
     687                 :            :               ST_OACC_END_SERIAL_LOOP);
     688                 :        761 :       matcha ("end serial", gfc_match_omp_eos_error, ST_OACC_END_SERIAL);
     689                 :        746 :       matcha ("enter data", gfc_match_oacc_enter_data, ST_OACC_ENTER_DATA);
     690                 :        353 :       matcha ("exit data", gfc_match_oacc_exit_data, ST_OACC_EXIT_DATA);
     691                 :          0 :       break;
     692                 :         65 :     case 'h':
     693                 :         65 :       matcha ("host_data", gfc_match_oacc_host_data, ST_OACC_HOST_DATA);
     694                 :          0 :       break;
     695                 :       3912 :     case 'p':
     696                 :       3912 :       matcha ("parallel loop", gfc_match_oacc_parallel_loop,
     697                 :            :               ST_OACC_PARALLEL_LOOP);
     698                 :       2612 :       matcha ("parallel", gfc_match_oacc_parallel, ST_OACC_PARALLEL);
     699                 :          0 :       break;
     700                 :        937 :     case 'k':
     701                 :        937 :       matcha ("kernels loop", gfc_match_oacc_kernels_loop,
     702                 :            :               ST_OACC_KERNELS_LOOP);
     703                 :        781 :       matcha ("kernels", gfc_match_oacc_kernels, ST_OACC_KERNELS);
     704                 :          0 :       break;
     705                 :       2986 :     case 'l':
     706                 :       2986 :       matcha ("loop", gfc_match_oacc_loop, ST_OACC_LOOP);
     707                 :          0 :       break;
     708                 :        305 :     case 'r':
     709                 :        305 :       match ("routine", gfc_match_oacc_routine, ST_OACC_ROUTINE);
     710                 :         55 :       break;
     711                 :         16 :     case 's':
     712                 :         16 :       matcha ("serial loop", gfc_match_oacc_serial_loop, ST_OACC_SERIAL_LOOP);
     713                 :         16 :       matcha ("serial", gfc_match_oacc_serial, ST_OACC_SERIAL);
     714                 :          1 :       break;
     715                 :        523 :     case 'u':
     716                 :        523 :       matcha ("update", gfc_match_oacc_update, ST_OACC_UPDATE);
     717                 :          0 :       break;
     718                 :        198 :     case 'w':
     719                 :        198 :       matcha ("wait", gfc_match_oacc_wait, ST_OACC_WAIT);
     720                 :          0 :       break;
     721                 :            :     }
     722                 :            : 
     723                 :            :   /* Directive not found or stored an error message.
     724                 :            :      Check and give up.  */
     725                 :            : 
     726                 :        268 :  error_handling:
     727                 :        268 :   if (gfc_error_check () == 0)
     728                 :          4 :     gfc_error_now ("Unclassifiable OpenACC directive at %C");
     729                 :            : 
     730                 :        268 :   reject_statement ();
     731                 :            : 
     732                 :        268 :   gfc_error_recovery ();
     733                 :            : 
     734                 :        268 :   return ST_NONE;
     735                 :            : 
     736                 :         10 :  do_spec_only:
     737                 :         10 :   reject_statement ();
     738                 :         10 :   gfc_clear_error ();
     739                 :         10 :   gfc_buffer_error (false);
     740                 :         10 :   gfc_current_locus = old_locus;
     741                 :         10 :   return ST_GET_FCN_CHARACTERISTICS;
     742                 :            : }
     743                 :            : 
     744                 :            : /* Like match, but set a flag simd_matched if keyword matched
     745                 :            :    and if spec_only, goto do_spec_only without actually matching.  */
     746                 :            : #define matchs(keyword, subr, st)                               \
     747                 :            :     do {                                                        \
     748                 :            :       match m2;                                                 \
     749                 :            :       if (spec_only && gfc_match (keyword) == MATCH_YES)        \
     750                 :            :         goto do_spec_only;                                      \
     751                 :            :       if ((m2 = match_word_omp_simd (keyword, subr, &old_locus,     \
     752                 :            :                                &simd_matched)) == MATCH_YES)        \
     753                 :            :         {                                                       \
     754                 :            :           ret = st;                                             \
     755                 :            :           goto finish;                                          \
     756                 :            :         }                                                       \
     757                 :            :       else if (m2 == MATCH_ERROR)                               \
     758                 :            :         goto error_handling;                                    \
     759                 :            :       else                                                      \
     760                 :            :         undo_new_statement ();                                  \
     761                 :            :     } while (0)
     762                 :            : 
     763                 :            : /* Like match, but don't match anything if not -fopenmp
     764                 :            :    and if spec_only, goto do_spec_only without actually matching.  */
     765                 :            : /* If the directive matched but the clauses failed, do not start
     766                 :            :    matching the next directive in the same switch statement. */
     767                 :            : #define matcho(keyword, subr, st)                               \
     768                 :            :     do {                                                        \
     769                 :            :       match m2;                                                 \
     770                 :            :       if (!flag_openmp)                                         \
     771                 :            :         ;                                                       \
     772                 :            :       else if (spec_only && gfc_match (keyword) == MATCH_YES)   \
     773                 :            :         goto do_spec_only;                                      \
     774                 :            :       else if ((m2 = match_word (keyword, subr, &old_locus))        \
     775                 :            :                == MATCH_YES)                                    \
     776                 :            :         {                                                       \
     777                 :            :           ret = st;                                             \
     778                 :            :           goto finish;                                          \
     779                 :            :         }                                                       \
     780                 :            :       else if (m2 == MATCH_ERROR)                               \
     781                 :            :         goto error_handling;                                    \
     782                 :            :       else                                                      \
     783                 :            :         undo_new_statement ();                                  \
     784                 :            :     } while (0)
     785                 :            : 
     786                 :            : /* Like match, but set a flag simd_matched if keyword matched.  */
     787                 :            : #define matchds(keyword, subr, st)                              \
     788                 :            :     do {                                                        \
     789                 :            :       match m2;                                                 \
     790                 :            :       if ((m2 = match_word_omp_simd (keyword, subr, &old_locus,     \
     791                 :            :                                &simd_matched)) == MATCH_YES)        \
     792                 :            :         {                                                       \
     793                 :            :           ret = st;                                             \
     794                 :            :           goto finish;                                          \
     795                 :            :         }                                                       \
     796                 :            :       else if (m2 == MATCH_ERROR)                               \
     797                 :            :         goto error_handling;                                    \
     798                 :            :       else                                                      \
     799                 :            :         undo_new_statement ();                                  \
     800                 :            :     } while (0)
     801                 :            : 
     802                 :            : /* Like match, but don't match anything if not -fopenmp.  */
     803                 :            : #define matchdo(keyword, subr, st)                              \
     804                 :            :     do {                                                        \
     805                 :            :       match m2;                                                 \
     806                 :            :       if (!flag_openmp)                                         \
     807                 :            :         ;                                                       \
     808                 :            :       else if ((m2 = match_word (keyword, subr, &old_locus))        \
     809                 :            :                == MATCH_YES)                                    \
     810                 :            :         {                                                       \
     811                 :            :           ret = st;                                             \
     812                 :            :           goto finish;                                          \
     813                 :            :         }                                                       \
     814                 :            :       else if (m2 == MATCH_ERROR)                               \
     815                 :            :         goto error_handling;                                    \
     816                 :            :       else                                                      \
     817                 :            :         undo_new_statement ();                                  \
     818                 :            :     } while (0)
     819                 :            : 
     820                 :            : static gfc_statement
     821                 :      17713 : decode_omp_directive (void)
     822                 :            : {
     823                 :      17713 :   locus old_locus;
     824                 :      17713 :   char c;
     825                 :      17713 :   bool simd_matched = false;
     826                 :      17713 :   bool spec_only = false;
     827                 :      17713 :   gfc_statement ret = ST_NONE;
     828                 :      17713 :   bool pure_ok = true;
     829                 :            : 
     830                 :      17713 :   gfc_enforce_clean_symbol_state ();
     831                 :            : 
     832                 :      17713 :   gfc_clear_error ();   /* Clear any pending errors.  */
     833                 :      17713 :   gfc_clear_warning (); /* Clear any pending warnings.  */
     834                 :            : 
     835                 :      17713 :   gfc_matching_function = false;
     836                 :            : 
     837                 :      17713 :   if (gfc_current_state () == COMP_FUNCTION
     838                 :        550 :       && gfc_current_block ()->result->ts.kind == -1)
     839                 :         95 :     spec_only = true;
     840                 :            : 
     841                 :      17713 :   old_locus = gfc_current_locus;
     842                 :            : 
     843                 :            :   /* General OpenMP directive matching: Instead of testing every possible
     844                 :            :      statement, we eliminate most possibilities by peeking at the
     845                 :            :      first character.  */
     846                 :            : 
     847                 :      17713 :   c = gfc_peek_ascii_char ();
     848                 :            : 
     849                 :            :   /* match is for directives that should be recognized only if
     850                 :            :      -fopenmp, matchs for directives that should be recognized
     851                 :            :      if either -fopenmp or -fopenmp-simd.
     852                 :            :      Handle only the directives allowed in PURE/ELEMENTAL procedures
     853                 :            :      first (those also shall not turn off implicit pure).  */
     854                 :      17713 :   switch (c)
     855                 :            :     {
     856                 :       1794 :     case 'd':
     857                 :       1794 :       matchds ("declare simd", gfc_match_omp_declare_simd,
     858                 :            :                ST_OMP_DECLARE_SIMD);
     859                 :       1643 :       matchdo ("declare target", gfc_match_omp_declare_target,
     860                 :            :                ST_OMP_DECLARE_TARGET);
     861                 :            :       break;
     862                 :       1006 :     case 's':
     863                 :       1006 :       matchs ("simd", gfc_match_omp_simd, ST_OMP_SIMD);
     864                 :        680 :       break;
     865                 :            :     }
     866                 :            : 
     867                 :      17063 :   pure_ok = false;
     868                 :      17063 :   if (flag_openmp && gfc_pure (NULL))
     869                 :            :     {
     870                 :          9 :       gfc_error_now ("OpenMP directives other than SIMD or DECLARE TARGET "
     871                 :            :                      "at %C may not appear in PURE or ELEMENTAL procedures");
     872                 :          9 :       gfc_error_recovery ();
     873                 :          9 :       return ST_NONE;
     874                 :            :     }
     875                 :            : 
     876                 :            :   /* match is for directives that should be recognized only if
     877                 :            :      -fopenmp, matchs for directives that should be recognized
     878                 :            :      if either -fopenmp or -fopenmp-simd.  */
     879                 :      17054 :   switch (c)
     880                 :            :     {
     881                 :       1125 :     case 'a':
     882                 :       1125 :       matcho ("atomic", gfc_match_omp_atomic, ST_OMP_ATOMIC);
     883                 :            :       break;
     884                 :        421 :     case 'b':
     885                 :        421 :       matcho ("barrier", gfc_match_omp_barrier, ST_OMP_BARRIER);
     886                 :            :       break;
     887                 :        211 :     case 'c':
     888                 :        211 :       matcho ("cancellation% point", gfc_match_omp_cancellation_point,
     889                 :            :               ST_OMP_CANCELLATION_POINT);
     890                 :        196 :       matcho ("cancel", gfc_match_omp_cancel, ST_OMP_CANCEL);
     891                 :         61 :       matcho ("critical", gfc_match_omp_critical, ST_OMP_CRITICAL);
     892                 :            :       break;
     893                 :       1468 :     case 'd':
     894                 :       1468 :       matchds ("declare reduction", gfc_match_omp_declare_reduction,
     895                 :            :                ST_OMP_DECLARE_REDUCTION);
     896                 :        937 :       matchs ("distribute parallel do simd",
     897                 :            :               gfc_match_omp_distribute_parallel_do_simd,
     898                 :            :               ST_OMP_DISTRIBUTE_PARALLEL_DO_SIMD);
     899                 :        925 :       matcho ("distribute parallel do", gfc_match_omp_distribute_parallel_do,
     900                 :            :               ST_OMP_DISTRIBUTE_PARALLEL_DO);
     901                 :        907 :       matchs ("distribute simd", gfc_match_omp_distribute_simd,
     902                 :            :               ST_OMP_DISTRIBUTE_SIMD);
     903                 :        895 :       matcho ("distribute", gfc_match_omp_distribute, ST_OMP_DISTRIBUTE);
     904                 :        880 :       matchs ("do simd", gfc_match_omp_do_simd, ST_OMP_DO_SIMD);
     905                 :        809 :       matcho ("do", gfc_match_omp_do, ST_OMP_DO);
     906                 :            :       break;
     907                 :       5544 :     case 'e':
     908                 :       5544 :       matcho ("end atomic", gfc_match_omp_eos_error, ST_OMP_END_ATOMIC);
     909                 :       5377 :       matcho ("end critical", gfc_match_omp_end_critical, ST_OMP_END_CRITICAL);
     910                 :       5321 :       matchs ("end distribute parallel do simd", gfc_match_omp_eos_error,
     911                 :            :               ST_OMP_END_DISTRIBUTE_PARALLEL_DO_SIMD);
     912                 :       5319 :       matcho ("end distribute parallel do", gfc_match_omp_eos_error,
     913                 :            :               ST_OMP_END_DISTRIBUTE_PARALLEL_DO);
     914                 :       5317 :       matchs ("end distribute simd", gfc_match_omp_eos_error,
     915                 :            :               ST_OMP_END_DISTRIBUTE_SIMD);
     916                 :       5315 :       matcho ("end distribute", gfc_match_omp_eos_error, ST_OMP_END_DISTRIBUTE);
     917                 :       5313 :       matchs ("end do simd", gfc_match_omp_end_nowait, ST_OMP_END_DO_SIMD);
     918                 :       5286 :       matcho ("end do", gfc_match_omp_end_nowait, ST_OMP_END_DO);
     919                 :       5063 :       matchs ("end simd", gfc_match_omp_eos_error, ST_OMP_END_SIMD);
     920                 :       5020 :       matcho ("end master", gfc_match_omp_eos_error, ST_OMP_END_MASTER);
     921                 :       4945 :       matchs ("end ordered", gfc_match_omp_eos_error, ST_OMP_END_ORDERED);
     922                 :       4774 :       matchs ("end parallel do simd", gfc_match_omp_eos_error,
     923                 :            :               ST_OMP_END_PARALLEL_DO_SIMD);
     924                 :       4747 :       matcho ("end parallel do", gfc_match_omp_eos_error, ST_OMP_END_PARALLEL_DO);
     925                 :       4591 :       matcho ("end parallel sections", gfc_match_omp_eos_error,
     926                 :            :               ST_OMP_END_PARALLEL_SECTIONS);
     927                 :       4543 :       matcho ("end parallel workshare", gfc_match_omp_eos_error,
     928                 :            :               ST_OMP_END_PARALLEL_WORKSHARE);
     929                 :       4494 :       matcho ("end parallel", gfc_match_omp_eos_error, ST_OMP_END_PARALLEL);
     930                 :       2912 :       matcho ("end sections", gfc_match_omp_end_nowait, ST_OMP_END_SECTIONS);
     931                 :       2880 :       matcho ("end single", gfc_match_omp_end_single, ST_OMP_END_SINGLE);
     932                 :       2433 :       matcho ("end target data", gfc_match_omp_eos_error, ST_OMP_END_TARGET_DATA);
     933                 :       1177 :       matchs ("end target parallel do simd", gfc_match_omp_eos_error,
     934                 :            :               ST_OMP_END_TARGET_PARALLEL_DO_SIMD);
     935                 :       1177 :       matcho ("end target parallel do", gfc_match_omp_eos_error,
     936                 :            :               ST_OMP_END_TARGET_PARALLEL_DO);
     937                 :       1177 :       matcho ("end target parallel", gfc_match_omp_eos_error,
     938                 :            :               ST_OMP_END_TARGET_PARALLEL);
     939                 :       1175 :       matchs ("end target simd", gfc_match_omp_eos_error, ST_OMP_END_TARGET_SIMD);
     940                 :       1169 :       matchs ("end target teams distribute parallel do simd",
     941                 :            :               gfc_match_omp_eos_error,
     942                 :            :               ST_OMP_END_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD);
     943                 :       1162 :       matcho ("end target teams distribute parallel do", gfc_match_omp_eos_error,
     944                 :            :               ST_OMP_END_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO);
     945                 :       1161 :       matchs ("end target teams distribute simd", gfc_match_omp_eos_error,
     946                 :            :               ST_OMP_END_TARGET_TEAMS_DISTRIBUTE_SIMD);
     947                 :       1160 :       matcho ("end target teams distribute", gfc_match_omp_eos_error,
     948                 :            :               ST_OMP_END_TARGET_TEAMS_DISTRIBUTE);
     949                 :       1159 :       matcho ("end target teams", gfc_match_omp_eos_error, ST_OMP_END_TARGET_TEAMS);
     950                 :       1122 :       matcho ("end target", gfc_match_omp_eos_error, ST_OMP_END_TARGET);
     951                 :        693 :       matcho ("end taskgroup", gfc_match_omp_eos_error, ST_OMP_END_TASKGROUP);
     952                 :        600 :       matchs ("end taskloop simd", gfc_match_omp_eos_error,
     953                 :            :               ST_OMP_END_TASKLOOP_SIMD);
     954                 :        599 :       matcho ("end taskloop", gfc_match_omp_eos_error, ST_OMP_END_TASKLOOP);
     955                 :        592 :       matcho ("end task", gfc_match_omp_eos_error, ST_OMP_END_TASK);
     956                 :         74 :       matchs ("end teams distribute parallel do simd", gfc_match_omp_eos_error,
     957                 :            :               ST_OMP_END_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD);
     958                 :         73 :       matcho ("end teams distribute parallel do", gfc_match_omp_eos_error,
     959                 :            :               ST_OMP_END_TEAMS_DISTRIBUTE_PARALLEL_DO);
     960                 :         72 :       matchs ("end teams distribute simd", gfc_match_omp_eos_error,
     961                 :            :               ST_OMP_END_TEAMS_DISTRIBUTE_SIMD);
     962                 :         71 :       matcho ("end teams distribute", gfc_match_omp_eos_error,
     963                 :            :               ST_OMP_END_TEAMS_DISTRIBUTE);
     964                 :         70 :       matcho ("end teams", gfc_match_omp_eos_error, ST_OMP_END_TEAMS);
     965                 :         51 :       matcho ("end workshare", gfc_match_omp_end_nowait,
     966                 :            :               ST_OMP_END_WORKSHARE);
     967                 :            :       break;
     968                 :         64 :     case 'f':
     969                 :         64 :       matcho ("flush", gfc_match_omp_flush, ST_OMP_FLUSH);
     970                 :            :       break;
     971                 :         76 :     case 'm':
     972                 :         76 :       matcho ("master", gfc_match_omp_master, ST_OMP_MASTER);
     973                 :            :       break;
     974                 :        446 :     case 'o':
     975                 :        446 :       if (gfc_match ("ordered depend (") == MATCH_YES)
     976                 :            :         {
     977                 :        275 :           gfc_current_locus = old_locus;
     978                 :        275 :           if (!flag_openmp)
     979                 :            :             break;
     980                 :        273 :           matcho ("ordered", gfc_match_omp_ordered_depend,
     981                 :            :                   ST_OMP_ORDERED_DEPEND);
     982                 :            :         }
     983                 :            :       else
     984                 :        171 :         matchs ("ordered", gfc_match_omp_ordered, ST_OMP_ORDERED);
     985                 :            :       break;
     986                 :       2566 :     case 'p':
     987                 :       2566 :       matchs ("parallel do simd", gfc_match_omp_parallel_do_simd,
     988                 :            :               ST_OMP_PARALLEL_DO_SIMD);
     989                 :       2414 :       matcho ("parallel do", gfc_match_omp_parallel_do, ST_OMP_PARALLEL_DO);
     990                 :       1692 :       matcho ("parallel sections", gfc_match_omp_parallel_sections,
     991                 :            :               ST_OMP_PARALLEL_SECTIONS);
     992                 :       1644 :       matcho ("parallel workshare", gfc_match_omp_parallel_workshare,
     993                 :            :               ST_OMP_PARALLEL_WORKSHARE);
     994                 :       1595 :       matcho ("parallel", gfc_match_omp_parallel, ST_OMP_PARALLEL);
     995                 :            :       break;
     996                 :        680 :     case 's':
     997                 :        680 :       matcho ("sections", gfc_match_omp_sections, ST_OMP_SECTIONS);
     998                 :        648 :       matcho ("section", gfc_match_omp_eos_error, ST_OMP_SECTION);
     999                 :        456 :       matcho ("single", gfc_match_omp_single, ST_OMP_SINGLE);
    1000                 :            :       break;
    1001                 :       4420 :     case 't':
    1002                 :       4420 :       matcho ("target data", gfc_match_omp_target_data, ST_OMP_TARGET_DATA);
    1003                 :       3161 :       matcho ("target enter data", gfc_match_omp_target_enter_data,
    1004                 :            :               ST_OMP_TARGET_ENTER_DATA);
    1005                 :       3152 :       matcho ("target exit data", gfc_match_omp_target_exit_data,
    1006                 :            :               ST_OMP_TARGET_EXIT_DATA);
    1007                 :       3151 :       matchs ("target parallel do simd", gfc_match_omp_target_parallel_do_simd,
    1008                 :            :               ST_OMP_TARGET_PARALLEL_DO_SIMD);
    1009                 :       3150 :       matcho ("target parallel do", gfc_match_omp_target_parallel_do,
    1010                 :            :               ST_OMP_TARGET_PARALLEL_DO);
    1011                 :       3149 :       matcho ("target parallel", gfc_match_omp_target_parallel,
    1012                 :            :               ST_OMP_TARGET_PARALLEL);
    1013                 :       3147 :       matchs ("target simd", gfc_match_omp_target_simd, ST_OMP_TARGET_SIMD);
    1014                 :       3134 :       matchs ("target teams distribute parallel do simd",
    1015                 :            :               gfc_match_omp_target_teams_distribute_parallel_do_simd,
    1016                 :            :               ST_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD);
    1017                 :       3120 :       matcho ("target teams distribute parallel do",
    1018                 :            :               gfc_match_omp_target_teams_distribute_parallel_do,
    1019                 :            :               ST_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO);
    1020                 :       3113 :       matchs ("target teams distribute simd",
    1021                 :            :               gfc_match_omp_target_teams_distribute_simd,
    1022                 :            :               ST_OMP_TARGET_TEAMS_DISTRIBUTE_SIMD);
    1023                 :       3109 :       matcho ("target teams distribute", gfc_match_omp_target_teams_distribute,
    1024                 :            :               ST_OMP_TARGET_TEAMS_DISTRIBUTE);
    1025                 :       3105 :       matcho ("target teams", gfc_match_omp_target_teams, ST_OMP_TARGET_TEAMS);
    1026                 :       3068 :       matcho ("target update", gfc_match_omp_target_update,
    1027                 :            :               ST_OMP_TARGET_UPDATE);
    1028                 :       1392 :       matcho ("target", gfc_match_omp_target, ST_OMP_TARGET);
    1029                 :        963 :       matcho ("taskgroup", gfc_match_omp_taskgroup, ST_OMP_TASKGROUP);
    1030                 :        870 :       matchs ("taskloop simd", gfc_match_omp_taskloop_simd,
    1031                 :            :               ST_OMP_TASKLOOP_SIMD);
    1032                 :        864 :       matcho ("taskloop", gfc_match_omp_taskloop, ST_OMP_TASKLOOP);
    1033                 :        844 :       matcho ("taskwait", gfc_match_omp_taskwait, ST_OMP_TASKWAIT);
    1034                 :        770 :       matcho ("taskyield", gfc_match_omp_taskyield, ST_OMP_TASKYIELD);
    1035                 :        761 :       matcho ("task", gfc_match_omp_task, ST_OMP_TASK);
    1036                 :        243 :       matchs ("teams distribute parallel do simd",
    1037                 :            :               gfc_match_omp_teams_distribute_parallel_do_simd,
    1038                 :            :               ST_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD);
    1039                 :        233 :       matcho ("teams distribute parallel do",
    1040                 :            :               gfc_match_omp_teams_distribute_parallel_do,
    1041                 :            :               ST_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO);
    1042                 :        228 :       matchs ("teams distribute simd", gfc_match_omp_teams_distribute_simd,
    1043                 :            :               ST_OMP_TEAMS_DISTRIBUTE_SIMD);
    1044                 :        224 :       matcho ("teams distribute", gfc_match_omp_teams_distribute,
    1045                 :            :               ST_OMP_TEAMS_DISTRIBUTE);
    1046                 :        220 :       matcho ("teams", gfc_match_omp_teams, ST_OMP_TEAMS);
    1047                 :        201 :       matchdo ("threadprivate", gfc_match_omp_threadprivate,
    1048                 :            :                ST_OMP_THREADPRIVATE);
    1049                 :            :       break;
    1050                 :         32 :     case 'w':
    1051                 :         32 :       matcho ("workshare", gfc_match_omp_workshare, ST_OMP_WORKSHARE);
    1052                 :            :       break;
    1053                 :            :     }
    1054                 :            : 
    1055                 :            :   /* All else has failed, so give up.  See if any of the matchers has
    1056                 :            :      stored an error message of some sort.  Don't error out if
    1057                 :            :      not -fopenmp and simd_matched is false, i.e. if a directive other
    1058                 :            :      than one marked with match has been seen.  */
    1059                 :            : 
    1060                 :          2 :  error_handling:
    1061                 :         92 :   if (flag_openmp || simd_matched)
    1062                 :            :     {
    1063                 :         37 :       if (!gfc_error_check ())
    1064                 :          9 :         gfc_error_now ("Unclassifiable OpenMP directive at %C");
    1065                 :            :     }
    1066                 :            : 
    1067                 :         92 :   reject_statement ();
    1068                 :            : 
    1069                 :         92 :   gfc_error_recovery ();
    1070                 :            : 
    1071                 :         92 :   return ST_NONE;
    1072                 :            : 
    1073                 :      17602 :  finish:
    1074                 :      17602 :   if (!pure_ok)
    1075                 :            :     {
    1076                 :      16957 :       gfc_unset_implicit_pure (NULL);
    1077                 :            : 
    1078                 :      16957 :       if (!flag_openmp && gfc_pure (NULL))
    1079                 :            :         {
    1080                 :          0 :           gfc_error_now ("OpenMP directives other than SIMD or DECLARE TARGET "
    1081                 :            :                          "at %C may not appear in PURE or ELEMENTAL "
    1082                 :            :                          "procedures");
    1083                 :          0 :           reject_statement ();
    1084                 :          0 :           gfc_error_recovery ();
    1085                 :          0 :           return ST_NONE;
    1086                 :            :         }
    1087                 :            :     }
    1088                 :            :   return ret;
    1089                 :            : 
    1090                 :         10 :  do_spec_only:
    1091                 :         10 :   reject_statement ();
    1092                 :         10 :   gfc_clear_error ();
    1093                 :         10 :   gfc_buffer_error (false);
    1094                 :         10 :   gfc_current_locus = old_locus;
    1095                 :         10 :   return ST_GET_FCN_CHARACTERISTICS;
    1096                 :            : }
    1097                 :            : 
    1098                 :            : static gfc_statement
    1099                 :     606591 : decode_gcc_attribute (void)
    1100                 :            : {
    1101                 :     606591 :   locus old_locus;
    1102                 :            : 
    1103                 :     606591 :   gfc_enforce_clean_symbol_state ();
    1104                 :            : 
    1105                 :     606591 :   gfc_clear_error ();   /* Clear any pending errors.  */
    1106                 :     606591 :   gfc_clear_warning (); /* Clear any pending warnings.  */
    1107                 :     606591 :   old_locus = gfc_current_locus;
    1108                 :            : 
    1109                 :     606591 :   match ("attributes", gfc_match_gcc_attributes, ST_ATTR_DECL);
    1110                 :     604162 :   match ("unroll", gfc_match_gcc_unroll, ST_NONE);
    1111                 :     604146 :   match ("builtin", gfc_match_gcc_builtin, ST_NONE);
    1112                 :          8 :   match ("ivdep", gfc_match_gcc_ivdep, ST_NONE);
    1113                 :          6 :   match ("vector", gfc_match_gcc_vector, ST_NONE);
    1114                 :          4 :   match ("novector", gfc_match_gcc_novector, ST_NONE);
    1115                 :            : 
    1116                 :            :   /* All else has failed, so give up.  See if any of the matchers has
    1117                 :            :      stored an error message of some sort.  */
    1118                 :            : 
    1119                 :          3 :   if (!gfc_error_check ())
    1120                 :            :     {
    1121                 :          1 :       if (pedantic)
    1122                 :          0 :         gfc_error_now ("Unclassifiable GCC directive at %C");
    1123                 :            :       else
    1124                 :          1 :         gfc_warning_now (0, "Unclassifiable GCC directive at %C, ignored");
    1125                 :            :     }
    1126                 :            : 
    1127                 :          3 :   reject_statement ();
    1128                 :            : 
    1129                 :          3 :   gfc_error_recovery ();
    1130                 :            : 
    1131                 :          3 :   return ST_NONE;
    1132                 :            : }
    1133                 :            : 
    1134                 :            : #undef match
    1135                 :            : 
    1136                 :            : /* Assert next length characters to be equal to token in free form.  */
    1137                 :            : 
    1138                 :            : static void
    1139                 :      33136 : verify_token_free (const char* token, int length, bool last_was_use_stmt)
    1140                 :            : {
    1141                 :      33136 :   int i;
    1142                 :      33136 :   char c;
    1143                 :            : 
    1144                 :      33136 :   c = gfc_next_ascii_char ();
    1145                 :     165482 :   for (i = 0; i < length; i++, c = gfc_next_ascii_char ())
    1146                 :     132346 :     gcc_assert (c == token[i]);
    1147                 :            : 
    1148                 :      33136 :   gcc_assert (gfc_is_whitespace(c));
    1149                 :      33136 :   gfc_gobble_whitespace ();
    1150                 :      33136 :   if (last_was_use_stmt)
    1151                 :         65 :     use_modules ();
    1152                 :      33136 : }
    1153                 :            : 
    1154                 :            : /* Get the next statement in free form source.  */
    1155                 :            : 
    1156                 :            : static gfc_statement
    1157                 :    1370470 : next_free (void)
    1158                 :            : {
    1159                 :    1370470 :   match m;
    1160                 :    1370470 :   int i, cnt, at_bol;
    1161                 :    1370470 :   char c;
    1162                 :            : 
    1163                 :    1370470 :   at_bol = gfc_at_bol ();
    1164                 :    1370470 :   gfc_gobble_whitespace ();
    1165                 :            : 
    1166                 :    1370470 :   c = gfc_peek_ascii_char ();
    1167                 :            : 
    1168                 :    1370470 :   if (ISDIGIT (c))
    1169                 :            :     {
    1170                 :       2139 :       char d;
    1171                 :            : 
    1172                 :            :       /* Found a statement label?  */
    1173                 :       2139 :       m = gfc_match_st_label (&gfc_statement_label);
    1174                 :            : 
    1175                 :       2139 :       d = gfc_peek_ascii_char ();
    1176                 :       2139 :       if (m != MATCH_YES || !gfc_is_whitespace (d))
    1177                 :            :         {
    1178                 :          4 :           gfc_match_small_literal_int (&i, &cnt);
    1179                 :            : 
    1180                 :          4 :           if (cnt > 5)
    1181                 :          1 :             gfc_error_now ("Too many digits in statement label at %C");
    1182                 :            : 
    1183                 :          4 :           if (i == 0)
    1184                 :          1 :             gfc_error_now ("Zero is not a valid statement label at %C");
    1185                 :            : 
    1186                 :          4 :           do
    1187                 :          4 :             c = gfc_next_ascii_char ();
    1188                 :          4 :           while (ISDIGIT(c));
    1189                 :            : 
    1190                 :          4 :           if (!gfc_is_whitespace (c))
    1191                 :          2 :             gfc_error_now ("Non-numeric character in statement label at %C");
    1192                 :            : 
    1193                 :          4 :           return ST_NONE;
    1194                 :            :         }
    1195                 :            :       else
    1196                 :            :         {
    1197                 :       2135 :           label_locus = gfc_current_locus;
    1198                 :            : 
    1199                 :       2135 :           gfc_gobble_whitespace ();
    1200                 :            : 
    1201                 :       2135 :           if (at_bol && gfc_peek_ascii_char () == ';')
    1202                 :            :             {
    1203                 :          2 :               gfc_error_now ("Semicolon at %C needs to be preceded by "
    1204                 :            :                              "statement");
    1205                 :          2 :               gfc_next_ascii_char (); /* Eat up the semicolon.  */
    1206                 :          2 :               return ST_NONE;
    1207                 :            :             }
    1208                 :            : 
    1209                 :       2133 :           if (gfc_match_eos () == MATCH_YES)
    1210                 :          2 :             gfc_error_now ("Statement label without statement at %L",
    1211                 :            :                            &label_locus);
    1212                 :            :         }
    1213                 :            :     }
    1214                 :    1368330 :   else if (c == '!')
    1215                 :            :     {
    1216                 :            :       /* Comments have already been skipped by the time we get here,
    1217                 :            :          except for GCC attributes and OpenMP/OpenACC directives.  */
    1218                 :            : 
    1219                 :     596095 :       gfc_next_ascii_char (); /* Eat up the exclamation sign.  */
    1220                 :     596095 :       c = gfc_peek_ascii_char ();
    1221                 :            : 
    1222                 :     596095 :       if (c == 'g')
    1223                 :            :         {
    1224                 :     562959 :           int i;
    1225                 :            : 
    1226                 :     562959 :           c = gfc_next_ascii_char ();
    1227                 :    2814800 :           for (i = 0; i < 4; i++, c = gfc_next_ascii_char ())
    1228                 :    2251840 :             gcc_assert (c == "gcc$"[i]);
    1229                 :            : 
    1230                 :     562959 :           gfc_gobble_whitespace ();
    1231                 :     562959 :           return decode_gcc_attribute ();
    1232                 :            : 
    1233                 :            :         }
    1234                 :      33136 :       else if (c == '$')
    1235                 :            :         {
    1236                 :            :           /* Since both OpenMP and OpenACC directives starts with
    1237                 :            :              !$ character sequence, we must check all flags combinations */
    1238                 :      33136 :           if ((flag_openmp || flag_openmp_simd)
    1239                 :      17569 :               && !flag_openacc)
    1240                 :            :             {
    1241                 :      17371 :               verify_token_free ("$omp", 4, last_was_use_stmt);
    1242                 :      17371 :               return decode_omp_directive ();
    1243                 :            :             }
    1244                 :      15765 :           else if ((flag_openmp || flag_openmp_simd)
    1245                 :        198 :                    && flag_openacc)
    1246                 :            :             {
    1247                 :        198 :               gfc_next_ascii_char (); /* Eat up dollar character */
    1248                 :        198 :               c = gfc_peek_ascii_char ();
    1249                 :            : 
    1250                 :        198 :               if (c == 'o')
    1251                 :            :                 {
    1252                 :         81 :                   verify_token_free ("omp", 3, last_was_use_stmt);
    1253                 :         81 :                   return decode_omp_directive ();
    1254                 :            :                 }
    1255                 :        117 :               else if (c == 'a')
    1256                 :            :                 {
    1257                 :        117 :                   verify_token_free ("acc", 3, last_was_use_stmt);
    1258                 :        117 :                   return decode_oacc_directive ();
    1259                 :            :                 }
    1260                 :            :             }
    1261                 :      15567 :           else if (flag_openacc)
    1262                 :            :             {
    1263                 :      15567 :               verify_token_free ("$acc", 4, last_was_use_stmt);
    1264                 :      15567 :               return decode_oacc_directive ();
    1265                 :            :             }
    1266                 :            :         }
    1267                 :          0 :       gcc_unreachable ();
    1268                 :            :     }
    1269                 :            : 
    1270                 :     774368 :   if (at_bol && c == ';')
    1271                 :            :     {
    1272                 :          4 :       if (!(gfc_option.allow_std & GFC_STD_F2008))
    1273                 :          2 :         gfc_error_now ("Fortran 2008: Semicolon at %C without preceding "
    1274                 :            :                        "statement");
    1275                 :          4 :       gfc_next_ascii_char (); /* Eat up the semicolon.  */
    1276                 :          4 :       return ST_NONE;
    1277                 :            :     }
    1278                 :            : 
    1279                 :     774364 :   return decode_statement ();
    1280                 :            : }
    1281                 :            : 
    1282                 :            : /* Assert next length characters to be equal to token in fixed form.  */
    1283                 :            : 
    1284                 :            : static bool
    1285                 :        954 : verify_token_fixed (const char *token, int length, bool last_was_use_stmt)
    1286                 :            : {
    1287                 :        954 :   int i;
    1288                 :        954 :   char c = gfc_next_char_literal (NONSTRING);
    1289                 :            : 
    1290                 :       3810 :   for (i = 0; i < length; i++, c = gfc_next_char_literal (NONSTRING))
    1291                 :       2856 :     gcc_assert ((char) gfc_wide_tolower (c) == token[i]);
    1292                 :            : 
    1293                 :        954 :   if (c != ' ' && c != '0')
    1294                 :            :     {
    1295                 :          0 :       gfc_buffer_error (false);
    1296                 :          0 :       gfc_error ("Bad continuation line at %C");
    1297                 :          0 :       return false;
    1298                 :            :     }
    1299                 :        954 :   if (last_was_use_stmt)
    1300                 :          0 :     use_modules ();
    1301                 :            : 
    1302                 :            :   return true;
    1303                 :            : }
    1304                 :            : 
    1305                 :            : /* Get the next statement in fixed-form source.  */
    1306                 :            : 
    1307                 :            : static gfc_statement
    1308                 :     103748 : next_fixed (void)
    1309                 :            : {
    1310                 :     103748 :   int label, digit_flag, i;
    1311                 :     103748 :   locus loc;
    1312                 :     103748 :   gfc_char_t c;
    1313                 :            : 
    1314                 :     103748 :   if (!gfc_at_bol ())
    1315                 :         41 :     return decode_statement ();
    1316                 :            : 
    1317                 :            :   /* Skip past the current label field, parsing a statement label if
    1318                 :            :      one is there.  This is a weird number parser, since the number is
    1319                 :            :      contained within five columns and can have any kind of embedded
    1320                 :            :      spaces.  We also check for characters that make the rest of the
    1321                 :            :      line a comment.  */
    1322                 :            : 
    1323                 :            :   label = 0;
    1324                 :            :   digit_flag = 0;
    1325                 :            : 
    1326                 :     399297 :   for (i = 0; i < 5; i++)
    1327                 :            :     {
    1328                 :     340179 :       c = gfc_next_char_literal (NONSTRING);
    1329                 :            : 
    1330                 :     340179 :       switch (c)
    1331                 :            :         {
    1332                 :            :         case ' ':
    1333                 :            :           break;
    1334                 :            : 
    1335                 :       6633 :         case '0':
    1336                 :       6633 :         case '1':
    1337                 :       6633 :         case '2':
    1338                 :       6633 :         case '3':
    1339                 :       6633 :         case '4':
    1340                 :       6633 :         case '5':
    1341                 :       6633 :         case '6':
    1342                 :       6633 :         case '7':
    1343                 :       6633 :         case '8':
    1344                 :       6633 :         case '9':
    1345                 :       6633 :           label = label * 10 + ((unsigned char) c - '0');
    1346                 :       6633 :           label_locus = gfc_current_locus;
    1347                 :       6633 :           digit_flag = 1;
    1348                 :       6633 :           break;
    1349                 :            : 
    1350                 :            :           /* Comments have already been skipped by the time we get
    1351                 :            :              here, except for GCC attributes and OpenMP directives.  */
    1352                 :            : 
    1353                 :      44586 :         case '*':
    1354                 :      44586 :           c = gfc_next_char_literal (NONSTRING);
    1355                 :            : 
    1356                 :      44586 :           if (TOLOWER (c) == 'g')
    1357                 :            :             {
    1358                 :     218160 :               for (i = 0; i < 4; i++, c = gfc_next_char_literal (NONSTRING))
    1359                 :     174528 :                 gcc_assert (TOLOWER (c) == "gcc$"[i]);
    1360                 :            : 
    1361                 :      43632 :               return decode_gcc_attribute ();
    1362                 :            :             }
    1363                 :        954 :           else if (c == '$')
    1364                 :            :             {
    1365                 :        954 :               if ((flag_openmp || flag_openmp_simd)
    1366                 :        264 :                   && !flag_openacc)
    1367                 :            :                 {
    1368                 :        258 :                   if (!verify_token_fixed ("omp", 3, last_was_use_stmt))
    1369                 :            :                     return ST_NONE;
    1370                 :        258 :                   return decode_omp_directive ();
    1371                 :            :                 }
    1372                 :        696 :               else if ((flag_openmp || flag_openmp_simd)
    1373                 :          6 :                        && flag_openacc)
    1374                 :            :                 {
    1375                 :          6 :                   c = gfc_next_char_literal(NONSTRING);
    1376                 :          6 :                   if (c == 'o' || c == 'O')
    1377                 :            :                     {
    1378                 :          3 :                       if (!verify_token_fixed ("mp", 2, last_was_use_stmt))
    1379                 :            :                         return ST_NONE;
    1380                 :          3 :                       return decode_omp_directive ();
    1381                 :            :                     }
    1382                 :          3 :                   else if (c == 'a' || c == 'A')
    1383                 :            :                     {
    1384                 :          3 :                       if (!verify_token_fixed ("cc", 2, last_was_use_stmt))
    1385                 :            :                         return ST_NONE;
    1386                 :          3 :                       return decode_oacc_directive ();
    1387                 :            :                     }
    1388                 :            :                 }
    1389                 :        690 :               else if (flag_openacc)
    1390                 :            :                 {
    1391                 :        690 :                   if (!verify_token_fixed ("acc", 3, last_was_use_stmt))
    1392                 :            :                     return ST_NONE;
    1393                 :        690 :                   return decode_oacc_directive ();
    1394                 :            :                 }
    1395                 :            :             }
    1396                 :          3 :           gcc_fallthrough ();
    1397                 :            : 
    1398                 :            :           /* Comments have already been skipped by the time we get
    1399                 :            :              here so don't bother checking for them.  */
    1400                 :            : 
    1401                 :          3 :         default:
    1402                 :          3 :           gfc_buffer_error (false);
    1403                 :          3 :           gfc_error ("Non-numeric character in statement label at %C");
    1404                 :          3 :           return ST_NONE;
    1405                 :            :         }
    1406                 :            :     }
    1407                 :            : 
    1408                 :      59118 :   if (digit_flag)
    1409                 :            :     {
    1410                 :       2439 :       if (label == 0)
    1411                 :          1 :         gfc_warning_now (0, "Zero is not a valid statement label at %C");
    1412                 :            :       else
    1413                 :            :         {
    1414                 :            :           /* We've found a valid statement label.  */
    1415                 :       2438 :           gfc_statement_label = gfc_get_st_label (label);
    1416                 :            :         }
    1417                 :            :     }
    1418                 :            : 
    1419                 :            :   /* Since this line starts a statement, it cannot be a continuation
    1420                 :            :      of a previous statement.  If we see something here besides a
    1421                 :            :      space or zero, it must be a bad continuation line.  */
    1422                 :            : 
    1423                 :      59118 :   c = gfc_next_char_literal (NONSTRING);
    1424                 :      59118 :   if (c == '\n')
    1425                 :          0 :     goto blank_line;
    1426                 :            : 
    1427                 :      59118 :   if (c != ' ' && c != '0')
    1428                 :            :     {
    1429                 :          0 :       gfc_buffer_error (false);
    1430                 :          0 :       gfc_error ("Bad continuation line at %C");
    1431                 :          0 :       return ST_NONE;
    1432                 :            :     }
    1433                 :            : 
    1434                 :            :   /* Now that we've taken care of the statement label columns, we have
    1435                 :            :      to make sure that the first nonblank character is not a '!'.  If
    1436                 :            :      it is, the rest of the line is a comment.  */
    1437                 :            : 
    1438                 :     157571 :   do
    1439                 :            :     {
    1440                 :     157571 :       loc = gfc_current_locus;
    1441                 :     157571 :       c = gfc_next_char_literal (NONSTRING);
    1442                 :            :     }
    1443                 :     157571 :   while (gfc_is_whitespace (c));
    1444                 :            : 
    1445                 :      59118 :   if (c == '!')
    1446                 :          0 :     goto blank_line;
    1447                 :      59118 :   gfc_current_locus = loc;
    1448                 :            : 
    1449                 :      59118 :   if (c == ';')
    1450                 :            :     {
    1451                 :          6 :       if (digit_flag)
    1452                 :          2 :         gfc_error_now ("Semicolon at %C needs to be preceded by statement");
    1453                 :          4 :       else if (!(gfc_option.allow_std & GFC_STD_F2008))
    1454                 :          2 :         gfc_error_now ("Fortran 2008: Semicolon at %C without preceding "
    1455                 :            :                        "statement");
    1456                 :          6 :       return ST_NONE;
    1457                 :            :     }
    1458                 :            : 
    1459                 :      59112 :   if (gfc_match_eos () == MATCH_YES)
    1460                 :          1 :     goto blank_line;
    1461                 :            : 
    1462                 :            :   /* At this point, we've got a nonblank statement to parse.  */
    1463                 :      59111 :   return decode_statement ();
    1464                 :            : 
    1465                 :          1 : blank_line:
    1466                 :          1 :   if (digit_flag)
    1467                 :          1 :     gfc_error_now ("Statement label without statement at %L", &label_locus);
    1468                 :            : 
    1469                 :          1 :   gfc_current_locus.lb->truncated = 0;
    1470                 :          1 :   gfc_advance_line ();
    1471                 :          1 :   return ST_NONE;
    1472                 :            : }
    1473                 :            : 
    1474                 :            : 
    1475                 :            : /* Return the next non-ST_NONE statement to the caller.  We also worry
    1476                 :            :    about including files and the ends of include files at this stage.  */
    1477                 :            : 
    1478                 :            : static gfc_statement
    1479                 :     892953 : next_statement (void)
    1480                 :            : {
    1481                 :     892953 :   gfc_statement st;
    1482                 :     892953 :   locus old_locus;
    1483                 :            : 
    1484                 :     892953 :   gfc_enforce_clean_symbol_state ();
    1485                 :            : 
    1486                 :     892953 :   gfc_new_block = NULL;
    1487                 :            : 
    1488                 :     892953 :   gfc_current_ns->old_equiv = gfc_current_ns->equiv;
    1489                 :     892953 :   gfc_current_ns->old_data = gfc_current_ns->data;
    1490                 :    1499390 :   for (;;)
    1491                 :            :     {
    1492                 :    1499390 :       gfc_statement_label = NULL;
    1493                 :    1499390 :       gfc_buffer_error (true);
    1494                 :            : 
    1495                 :    1499390 :       if (gfc_at_eol ())
    1496                 :    1451540 :         gfc_advance_line ();
    1497                 :            : 
    1498                 :    1499390 :       gfc_skip_comments ();
    1499                 :            : 
    1500                 :    1499390 :       if (gfc_at_end ())
    1501                 :            :         {
    1502                 :            :           st = ST_NONE;
    1503                 :            :           break;
    1504                 :            :         }
    1505                 :            : 
    1506                 :    1474220 :       if (gfc_define_undef_line ())
    1507                 :          8 :         continue;
    1508                 :            : 
    1509                 :    1474220 :       old_locus = gfc_current_locus;
    1510                 :            : 
    1511                 :    1474220 :       st = (gfc_current_form == FORM_FIXED) ? next_fixed () : next_free ();
    1512                 :            : 
    1513                 :    1474210 :       if (st != ST_NONE)
    1514                 :            :         break;
    1515                 :            :     }
    1516                 :            : 
    1517                 :     892945 :   gfc_buffer_error (false);
    1518                 :            : 
    1519                 :     892945 :   if (st == ST_GET_FCN_CHARACTERISTICS)
    1520                 :            :     {
    1521                 :       3761 :       if (gfc_statement_label != NULL)
    1522                 :            :         {
    1523                 :          3 :           gfc_free_st_label (gfc_statement_label);
    1524                 :          3 :           gfc_statement_label = NULL;
    1525                 :            :         }
    1526                 :       3761 :       gfc_current_locus = old_locus;
    1527                 :            :     }
    1528                 :            : 
    1529                 :     892945 :   if (st != ST_NONE)
    1530                 :     867777 :     check_statement_label (st);
    1531                 :            : 
    1532                 :     892945 :   return st;
    1533                 :            : }
    1534                 :            : 
    1535                 :            : 
    1536                 :            : /****************************** Parser ***********************************/
    1537                 :            : 
    1538                 :            : /* The parser subroutines are of type 'try' that fail if the file ends
    1539                 :            :    unexpectedly.  */
    1540                 :            : 
    1541                 :            : /* Macros that expand to case-labels for various classes of
    1542                 :            :    statements.  Start with executable statements that directly do
    1543                 :            :    things.  */
    1544                 :            : 
    1545                 :            : #define case_executable case ST_ALLOCATE: case ST_BACKSPACE: case ST_CALL: \
    1546                 :            :   case ST_CLOSE: case ST_CONTINUE: case ST_DEALLOCATE: case ST_END_FILE: \
    1547                 :            :   case ST_GOTO: case ST_INQUIRE: case ST_NULLIFY: case ST_OPEN: \
    1548                 :            :   case ST_READ: case ST_RETURN: case ST_REWIND: case ST_SIMPLE_IF: \
    1549                 :            :   case ST_PAUSE: case ST_STOP: case ST_WAIT: case ST_WRITE: \
    1550                 :            :   case ST_POINTER_ASSIGNMENT: case ST_EXIT: case ST_CYCLE: \
    1551                 :            :   case ST_ASSIGNMENT: case ST_ARITHMETIC_IF: case ST_WHERE: case ST_FORALL: \
    1552                 :            :   case ST_LABEL_ASSIGNMENT: case ST_FLUSH: case ST_OMP_FLUSH: \
    1553                 :            :   case ST_OMP_BARRIER: case ST_OMP_TASKWAIT: case ST_OMP_TASKYIELD: \
    1554                 :            :   case ST_OMP_CANCEL: case ST_OMP_CANCELLATION_POINT: \
    1555                 :            :   case ST_OMP_TARGET_UPDATE: case ST_OMP_TARGET_ENTER_DATA: \
    1556                 :            :   case ST_OMP_TARGET_EXIT_DATA: case ST_OMP_ORDERED_DEPEND: \
    1557                 :            :   case ST_ERROR_STOP: case ST_SYNC_ALL: \
    1558                 :            :   case ST_SYNC_IMAGES: case ST_SYNC_MEMORY: case ST_LOCK: case ST_UNLOCK: \
    1559                 :            :   case ST_FORM_TEAM: case ST_CHANGE_TEAM: \
    1560                 :            :   case ST_END_TEAM: case ST_SYNC_TEAM: \
    1561                 :            :   case ST_EVENT_POST: case ST_EVENT_WAIT: case ST_FAIL_IMAGE: \
    1562                 :            :   case ST_OACC_UPDATE: case ST_OACC_WAIT: case ST_OACC_CACHE: \
    1563                 :            :   case ST_OACC_ENTER_DATA: case ST_OACC_EXIT_DATA
    1564                 :            : 
    1565                 :            : /* Statements that mark other executable statements.  */
    1566                 :            : 
    1567                 :            : #define case_exec_markers case ST_DO: case ST_FORALL_BLOCK: \
    1568                 :            :   case ST_IF_BLOCK: case ST_BLOCK: case ST_ASSOCIATE: \
    1569                 :            :   case ST_WHERE_BLOCK: case ST_SELECT_CASE: case ST_SELECT_TYPE: \
    1570                 :            :   case ST_SELECT_RANK: case ST_OMP_PARALLEL: \
    1571                 :            :   case ST_OMP_PARALLEL_SECTIONS: case ST_OMP_SECTIONS: case ST_OMP_ORDERED: \
    1572                 :            :   case ST_OMP_CRITICAL: case ST_OMP_MASTER: case ST_OMP_SINGLE: \
    1573                 :            :   case ST_OMP_DO: case ST_OMP_PARALLEL_DO: case ST_OMP_ATOMIC: \
    1574                 :            :   case ST_OMP_WORKSHARE: case ST_OMP_PARALLEL_WORKSHARE: \
    1575                 :            :   case ST_OMP_TASK: case ST_OMP_TASKGROUP: case ST_OMP_SIMD: \
    1576                 :            :   case ST_OMP_DO_SIMD: case ST_OMP_PARALLEL_DO_SIMD: case ST_OMP_TARGET: \
    1577                 :            :   case ST_OMP_TARGET_DATA: case ST_OMP_TARGET_TEAMS: \
    1578                 :            :   case ST_OMP_TARGET_TEAMS_DISTRIBUTE: \
    1579                 :            :   case ST_OMP_TARGET_TEAMS_DISTRIBUTE_SIMD: \
    1580                 :            :   case ST_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO: \
    1581                 :            :   case ST_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD: \
    1582                 :            :   case ST_OMP_TEAMS: case ST_OMP_TEAMS_DISTRIBUTE: \
    1583                 :            :   case ST_OMP_TEAMS_DISTRIBUTE_SIMD: \
    1584                 :            :   case ST_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO: \
    1585                 :            :   case ST_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD: case ST_OMP_DISTRIBUTE: \
    1586                 :            :   case ST_OMP_DISTRIBUTE_SIMD: case ST_OMP_DISTRIBUTE_PARALLEL_DO: \
    1587                 :            :   case ST_OMP_DISTRIBUTE_PARALLEL_DO_SIMD: case ST_OMP_TARGET_PARALLEL: \
    1588                 :            :   case ST_OMP_TARGET_PARALLEL_DO: case ST_OMP_TARGET_PARALLEL_DO_SIMD: \
    1589                 :            :   case ST_OMP_TARGET_SIMD: case ST_OMP_TASKLOOP: case ST_OMP_TASKLOOP_SIMD: \
    1590                 :            :   case ST_CRITICAL: \
    1591                 :            :   case ST_OACC_PARALLEL_LOOP: case ST_OACC_PARALLEL: case ST_OACC_KERNELS: \
    1592                 :            :   case ST_OACC_DATA: case ST_OACC_HOST_DATA: case ST_OACC_LOOP: \
    1593                 :            :   case ST_OACC_KERNELS_LOOP: case ST_OACC_SERIAL_LOOP: case ST_OACC_SERIAL: \
    1594                 :            :   case ST_OACC_ATOMIC
    1595                 :            : 
    1596                 :            : /* Declaration statements */
    1597                 :            : 
    1598                 :            : #define case_decl case ST_ATTR_DECL: case ST_COMMON: case ST_DATA_DECL: \
    1599                 :            :   case ST_EQUIVALENCE: case ST_NAMELIST: case ST_STATEMENT_FUNCTION: \
    1600                 :            :   case ST_TYPE: case ST_INTERFACE: case ST_PROCEDURE: case ST_OACC_ROUTINE: \
    1601                 :            :   case ST_OACC_DECLARE
    1602                 :            : 
    1603                 :            : /* OpenMP declaration statements.  */
    1604                 :            : 
    1605                 :            : #define case_omp_decl case ST_OMP_THREADPRIVATE: case ST_OMP_DECLARE_SIMD: \
    1606                 :            :   case ST_OMP_DECLARE_TARGET: case ST_OMP_DECLARE_REDUCTION
    1607                 :            : 
    1608                 :            : /* Block end statements.  Errors associated with interchanging these
    1609                 :            :    are detected in gfc_match_end().  */
    1610                 :            : 
    1611                 :            : #define case_end case ST_END_BLOCK_DATA: case ST_END_FUNCTION: \
    1612                 :            :                  case ST_END_PROGRAM: case ST_END_SUBROUTINE: \
    1613                 :            :                  case ST_END_BLOCK: case ST_END_ASSOCIATE
    1614                 :            : 
    1615                 :            : 
    1616                 :            : /* Push a new state onto the stack.  */
    1617                 :            : 
    1618                 :            : static void
    1619                 :     152357 : push_state (gfc_state_data *p, gfc_compile_state new_state, gfc_symbol *sym)
    1620                 :            : {
    1621                 :     152357 :   p->state = new_state;
    1622                 :     152357 :   p->previous = gfc_state_stack;
    1623                 :     152357 :   p->sym = sym;
    1624                 :     152357 :   p->head = p->tail = NULL;
    1625                 :     152357 :   p->do_variable = NULL;
    1626                 :     152357 :   if (p->state != COMP_DO && p->state != COMP_DO_CONCURRENT)
    1627                 :     129246 :     p->ext.oacc_declare_clauses = NULL;
    1628                 :            : 
    1629                 :            :   /* If this the state of a construct like BLOCK, DO or IF, the corresponding
    1630                 :            :      construct statement was accepted right before pushing the state.  Thus,
    1631                 :            :      the construct's gfc_code is available as tail of the parent state.  */
    1632                 :     152357 :   gcc_assert (gfc_state_stack);
    1633                 :     152357 :   p->construct = gfc_state_stack->tail;
    1634                 :            : 
    1635                 :     152357 :   gfc_state_stack = p;
    1636                 :     152357 : }
    1637                 :            : 
    1638                 :            : 
    1639                 :            : /* Pop the current state.  */
    1640                 :            : static void
    1641                 :     152301 : pop_state (void)
    1642                 :            : {
    1643                 :     152301 :   gfc_state_stack = gfc_state_stack->previous;
    1644                 :      22069 : }
    1645                 :            : 
    1646                 :            : 
    1647                 :            : /* Try to find the given state in the state stack.  */
    1648                 :            : 
    1649                 :            : bool
    1650                 :    2621610 : gfc_find_state (gfc_compile_state state)
    1651                 :            : {
    1652                 :    2621610 :   gfc_state_data *p;
    1653                 :            : 
    1654                 :   10012400 :   for (p = gfc_state_stack; p; p = p->previous)
    1655                 :    7440520 :     if (p->state == state)
    1656                 :            :       break;
    1657                 :            : 
    1658                 :    2621610 :   return (p == NULL) ? false : true;
    1659                 :            : }
    1660                 :            : 
    1661                 :            : 
    1662                 :            : /* Starts a new level in the statement list.  */
    1663                 :            : 
    1664                 :            : static gfc_code *
    1665                 :      49333 : new_level (gfc_code *q)
    1666                 :            : {
    1667                 :      49333 :   gfc_code *p;
    1668                 :            : 
    1669                 :          0 :   p = q->block = gfc_get_code (EXEC_NOP);
    1670                 :            : 
    1671                 :      49333 :   gfc_state_stack->head = gfc_state_stack->tail = p;
    1672                 :            : 
    1673                 :      49333 :   return p;
    1674                 :            : }
    1675                 :            : 
    1676                 :            : 
    1677                 :            : /* Add the current new_st code structure and adds it to the current
    1678                 :            :    program unit.  As a side-effect, it zeroes the new_st.  */
    1679                 :            : 
    1680                 :            : static gfc_code *
    1681                 :     497875 : add_statement (void)
    1682                 :            : {
    1683                 :     497875 :   gfc_code *p;
    1684                 :            : 
    1685                 :     497875 :   p = XCNEW (gfc_code);
    1686                 :     497875 :   *p = new_st;
    1687                 :            : 
    1688                 :     497875 :   p->loc = gfc_current_locus;
    1689                 :            : 
    1690                 :     497875 :   if (gfc_state_stack->head == NULL)
    1691                 :      70634 :     gfc_state_stack->head = p;
    1692                 :            :   else
    1693                 :     427241 :     gfc_state_stack->tail->next = p;
    1694                 :            : 
    1695                 :     498155 :   while (p->next != NULL)
    1696                 :            :     p = p->next;
    1697                 :            : 
    1698                 :     497875 :   gfc_state_stack->tail = p;
    1699                 :            : 
    1700                 :     497875 :   gfc_clear_new_st ();
    1701                 :            : 
    1702                 :     497875 :   return p;
    1703                 :            : }
    1704                 :            : 
    1705                 :            : 
    1706                 :            : /* Frees everything associated with the current statement.  */
    1707                 :            : 
    1708                 :            : static void
    1709                 :   14702800 : undo_new_statement (void)
    1710                 :            : {
    1711                 :   14702800 :   gfc_free_statements (new_st.block);
    1712                 :   14702800 :   gfc_free_statements (new_st.next);
    1713                 :   14702800 :   gfc_free_statement (&new_st);
    1714                 :   14702800 :   gfc_clear_new_st ();
    1715                 :   14702800 : }
    1716                 :            : 
    1717                 :            : 
    1718                 :            : /* If the current statement has a statement label, make sure that it
    1719                 :            :    is allowed to, or should have one.  */
    1720                 :            : 
    1721                 :            : static void
    1722                 :     867777 : check_statement_label (gfc_statement st)
    1723                 :            : {
    1724                 :     867777 :   gfc_sl_type type;
    1725                 :            : 
    1726                 :     867777 :   if (gfc_statement_label == NULL)
    1727                 :            :     {
    1728                 :     863223 :       if (st == ST_FORMAT)
    1729                 :          0 :         gfc_error ("FORMAT statement at %L does not have a statement label",
    1730                 :            :                    &new_st.loc);
    1731                 :     863223 :       return;
    1732                 :            :     }
    1733                 :            : 
    1734                 :       4554 :   switch (st)
    1735                 :            :     {
    1736                 :       3587 :     case ST_END_PROGRAM:
    1737                 :       3587 :     case ST_END_FUNCTION:
    1738                 :       3587 :     case ST_END_SUBROUTINE:
    1739                 :       3587 :     case ST_ENDDO:
    1740                 :       3587 :     case ST_ENDIF:
    1741                 :       3587 :     case ST_END_SELECT:
    1742                 :       3587 :     case ST_END_CRITICAL:
    1743                 :       3587 :     case ST_END_BLOCK:
    1744                 :       3587 :     case ST_END_ASSOCIATE:
    1745                 :       3587 :     case_executable:
    1746                 :       3587 :     case_exec_markers:
    1747                 :       3587 :       if (st == ST_ENDDO || st == ST_CONTINUE)
    1748                 :            :         type = ST_LABEL_DO_TARGET;
    1749                 :            :       else
    1750                 :        921 :         type = ST_LABEL_TARGET;
    1751                 :            :       break;
    1752                 :            : 
    1753                 :            :     case ST_FORMAT:
    1754                 :            :       type = ST_LABEL_FORMAT;
    1755                 :            :       break;
    1756                 :            : 
    1757                 :            :       /* Statement labels are not restricted from appearing on a
    1758                 :            :          particular line.  However, there are plenty of situations
    1759                 :            :          where the resulting label can't be referenced.  */
    1760                 :            : 
    1761                 :          7 :     default:
    1762                 :          7 :       type = ST_LABEL_BAD_TARGET;
    1763                 :          7 :       break;
    1764                 :            :     }
    1765                 :            : 
    1766                 :       4554 :   gfc_define_st_label (gfc_statement_label, type, &label_locus);
    1767                 :            : 
    1768                 :       4554 :   new_st.here = gfc_statement_label;
    1769                 :            : }
    1770                 :            : 
    1771                 :            : 
    1772                 :            : /* Figures out what the enclosing program unit is.  This will be a
    1773                 :            :    function, subroutine, program, block data or module.  */
    1774                 :            : 
    1775                 :            : gfc_state_data *
    1776                 :     662579 : gfc_enclosing_unit (gfc_compile_state * result)
    1777                 :            : {
    1778                 :     662579 :   gfc_state_data *p;
    1779                 :            : 
    1780                 :     966210 :   for (p = gfc_state_stack; p; p = p->previous)
    1781                 :     931373 :     if (p->state == COMP_FUNCTION || p->state == COMP_SUBROUTINE
    1782                 :     931373 :         || p->state == COMP_MODULE || p->state == COMP_SUBMODULE
    1783                 :     638816 :         || p->state == COMP_BLOCK_DATA || p->state == COMP_PROGRAM)
    1784                 :            :       {
    1785                 :            : 
    1786                 :     627742 :         if (result != NULL)
    1787                 :       1738 :           *result = p->state;
    1788                 :     627742 :         return p;
    1789                 :            :       }
    1790                 :            : 
    1791                 :      34837 :   if (result != NULL)
    1792                 :          0 :     *result = COMP_PROGRAM;
    1793                 :            :   return NULL;
    1794                 :            : }
    1795                 :            : 
    1796                 :            : 
    1797                 :            : /* Translate a statement enum to a string.  */
    1798                 :            : 
    1799                 :            : const char *
    1800                 :      17198 : gfc_ascii_statement (gfc_statement st)
    1801                 :            : {
    1802                 :      17198 :   const char *p;
    1803                 :            : 
    1804                 :      17198 :   switch (st)
    1805                 :            :     {
    1806                 :          0 :     case ST_ARITHMETIC_IF:
    1807                 :          0 :       p = _("arithmetic IF");
    1808                 :          0 :       break;
    1809                 :            :     case ST_ALLOCATE:
    1810                 :            :       p = "ALLOCATE";
    1811                 :            :       break;
    1812                 :          0 :     case ST_ASSOCIATE:
    1813                 :          0 :       p = "ASSOCIATE";
    1814                 :          0 :       break;
    1815                 :          1 :     case ST_ATTR_DECL:
    1816                 :          1 :       p = _("attribute declaration");
    1817                 :          1 :       break;
    1818                 :          2 :     case ST_BACKSPACE:
    1819                 :          2 :       p = "BACKSPACE";
    1820                 :          2 :       break;
    1821                 :          0 :     case ST_BLOCK:
    1822                 :          0 :       p = "BLOCK";
    1823                 :          0 :       break;
    1824                 :          1 :     case ST_BLOCK_DATA:
    1825                 :          1 :       p = "BLOCK DATA";
    1826                 :          1 :       break;
    1827                 :          2 :     case ST_CALL:
    1828                 :          2 :       p = "CALL";
    1829                 :          2 :       break;
    1830                 :          0 :     case ST_CASE:
    1831                 :          0 :       p = "CASE";
    1832                 :          0 :       break;
    1833                 :          0 :     case ST_CLOSE:
    1834                 :          0 :       p = "CLOSE";
    1835                 :          0 :       break;
    1836                 :         17 :     case ST_COMMON:
    1837                 :         17 :       p = "COMMON";
    1838                 :         17 :       break;
    1839                 :          0 :     case ST_CONTINUE:
    1840                 :          0 :       p = "CONTINUE";
    1841                 :          0 :       break;
    1842                 :          2 :     case ST_CONTAINS:
    1843                 :          2 :       p = "CONTAINS";
    1844                 :          2 :       break;
    1845                 :          1 :     case ST_CRITICAL:
    1846                 :          1 :       p = "CRITICAL";
    1847                 :          1 :       break;
    1848                 :          4 :     case ST_CYCLE:
    1849                 :          4 :       p = "CYCLE";
    1850                 :          4 :       break;
    1851                 :         16 :     case ST_DATA_DECL:
    1852                 :         16 :       p = _("data declaration");
    1853                 :         16 :       break;
    1854                 :          6 :     case ST_DATA:
    1855                 :          6 :       p = "DATA";
    1856                 :          6 :       break;
    1857                 :          1 :     case ST_DEALLOCATE:
    1858                 :          1 :       p = "DEALLOCATE";
    1859                 :          1 :       break;
    1860                 :          1 :     case ST_MAP:
    1861                 :          1 :       p = "MAP";
    1862                 :          1 :       break;
    1863                 :          0 :     case ST_UNION:
    1864                 :          0 :       p = "UNION";
    1865                 :          0 :       break;
    1866                 :          1 :     case ST_STRUCTURE_DECL:
    1867                 :          1 :       p = "STRUCTURE";
    1868                 :          1 :       break;
    1869                 :          0 :     case ST_DERIVED_DECL:
    1870                 :          0 :       p = _("derived type declaration");
    1871                 :          0 :       break;
    1872                 :          0 :     case ST_DO:
    1873                 :          0 :       p = "DO";
    1874                 :          0 :       break;
    1875                 :          2 :     case ST_ELSE:
    1876                 :          2 :       p = "ELSE";
    1877                 :          2 :       break;
    1878                 :          0 :     case ST_ELSEIF:
    1879                 :          0 :       p = "ELSE IF";
    1880                 :          0 :       break;
    1881                 :          0 :     case ST_ELSEWHERE:
    1882                 :          0 :       p = "ELSEWHERE";
    1883                 :          0 :       break;
    1884                 :          1 :     case ST_EVENT_POST:
    1885                 :          1 :       p = "EVENT POST";
    1886                 :          1 :       break;
    1887                 :          0 :     case ST_EVENT_WAIT:
    1888                 :          0 :       p = "EVENT WAIT";
    1889                 :          0 :       break;
    1890                 :          2 :     case ST_FAIL_IMAGE:
    1891                 :          2 :       p = "FAIL IMAGE";
    1892                 :          2 :       break;
    1893                 :          0 :     case ST_CHANGE_TEAM:
    1894                 :          0 :       p = "CHANGE TEAM";
    1895                 :          0 :       break;
    1896                 :          0 :     case ST_END_TEAM:
    1897                 :          0 :       p = "END TEAM";
    1898                 :          0 :       break;
    1899                 :          0 :     case ST_FORM_TEAM:
    1900                 :          0 :       p = "FORM TEAM";
    1901                 :          0 :       break;
    1902                 :          0 :     case ST_SYNC_TEAM:
    1903                 :          0 :       p = "SYNC TEAM";
    1904                 :          0 :       break;
    1905                 :          4 :     case ST_END_ASSOCIATE:
    1906                 :          4 :       p = "END ASSOCIATE";
    1907                 :          4 :       break;
    1908                 :         10 :     case ST_END_BLOCK:
    1909                 :         10 :       p = "END BLOCK";
    1910                 :         10 :       break;
    1911                 :          1 :     case ST_END_BLOCK_DATA:
    1912                 :          1 :       p = "END BLOCK DATA";
    1913                 :          1 :       break;
    1914                 :          0 :     case ST_END_CRITICAL:
    1915                 :          0 :       p = "END CRITICAL";
    1916                 :          0 :       break;
    1917                 :          8 :     case ST_ENDDO:
    1918                 :          8 :       p = "END DO";
    1919                 :          8 :       break;
    1920                 :          2 :     case ST_END_FILE:
    1921                 :          2 :       p = "END FILE";
    1922                 :          2 :       break;
    1923                 :          2 :     case ST_END_FORALL:
    1924                 :          2 :       p = "END FORALL";
    1925                 :          2 :       break;
    1926                 :         70 :     case ST_END_FUNCTION:
    1927                 :         70 :       p = "END FUNCTION";
    1928                 :         70 :       break;
    1929                 :          3 :     case ST_ENDIF:
    1930                 :          3 :       p = "END IF";
    1931                 :          3 :       break;
    1932                 :         10 :     case ST_END_INTERFACE:
    1933                 :         10 :       p = "END INTERFACE";
    1934                 :         10 :       break;
    1935                 :         24 :     case ST_END_MODULE:
    1936                 :         24 :       p = "END MODULE";
    1937                 :         24 :       break;
    1938                 :          3 :     case ST_END_SUBMODULE:
    1939                 :          3 :       p = "END SUBMODULE";
    1940                 :          3 :       break;
    1941                 :         64 :     case ST_END_PROGRAM:
    1942                 :         64 :       p = "END PROGRAM";
    1943                 :         64 :       break;
    1944                 :          2 :     case ST_END_SELECT:
    1945                 :          2 :       p = "END SELECT";
    1946                 :          2 :       break;
    1947                 :        414 :     case ST_END_SUBROUTINE:
    1948                 :        414 :       p = "END SUBROUTINE";
    1949                 :        414 :       break;
    1950                 :          2 :     case ST_END_WHERE:
    1951                 :          2 :       p = "END WHERE";
    1952                 :          2 :       break;
    1953                 :          0 :     case ST_END_STRUCTURE:
    1954                 :          0 :       p = "END STRUCTURE";
    1955                 :          0 :       break;
    1956                 :          0 :     case ST_END_UNION:
    1957                 :          0 :       p = "END UNION";
    1958                 :          0 :       break;
    1959                 :          0 :     case ST_END_MAP:
    1960                 :          0 :       p = "END MAP";
    1961                 :          0 :       break;
    1962                 :          0 :     case ST_END_TYPE:
    1963                 :          0 :       p = "END TYPE";
    1964                 :          0 :       break;
    1965                 :          0 :     case ST_ENTRY:
    1966                 :          0 :       p = "ENTRY";
    1967                 :          0 :       break;
    1968                 :          1 :     case ST_EQUIVALENCE:
    1969                 :          1 :       p = "EQUIVALENCE";
    1970                 :          1 :       break;
    1971                 :          2 :     case ST_ERROR_STOP:
    1972                 :          2 :       p = "ERROR STOP";
    1973                 :          2 :       break;
    1974                 :         11 :     case ST_EXIT:
    1975                 :         11 :       p = "EXIT";
    1976                 :         11 :       break;
    1977                 :          2 :     case ST_FLUSH:
    1978                 :          2 :       p = "FLUSH";
    1979                 :          2 :       break;
    1980                 :          0 :     case ST_FORALL_BLOCK:       /* Fall through */
    1981                 :          0 :     case ST_FORALL:
    1982                 :          0 :       p = "FORALL";
    1983                 :          0 :       break;
    1984                 :          1 :     case ST_FORMAT:
    1985                 :          1 :       p = "FORMAT";
    1986                 :          1 :       break;
    1987                 :          0 :     case ST_FUNCTION:
    1988                 :          0 :       p = "FUNCTION";
    1989                 :          0 :       break;
    1990                 :          0 :     case ST_GENERIC:
    1991                 :          0 :       p = "GENERIC";
    1992                 :          0 :       break;
    1993                 :          0 :     case ST_GOTO:
    1994                 :          0 :       p = "GOTO";
    1995                 :          0 :       break;
    1996                 :          0 :     case ST_IF_BLOCK:
    1997                 :          0 :       p = _("block IF");
    1998                 :          0 :       break;
    1999                 :      16244 :     case ST_IMPLICIT:
    2000                 :      16244 :       p = "IMPLICIT";
    2001                 :      16244 :       break;
    2002                 :          3 :     case ST_IMPLICIT_NONE:
    2003                 :          3 :       p = "IMPLICIT NONE";
    2004                 :          3 :       break;
    2005                 :          0 :     case ST_IMPLIED_ENDDO:
    2006                 :          0 :       p = _("implied END DO");
    2007                 :          0 :       break;
    2008                 :          0 :     case ST_IMPORT:
    2009                 :          0 :       p = "IMPORT";
    2010                 :          0 :       break;
    2011                 :          0 :     case ST_INQUIRE:
    2012                 :          0 :       p = "INQUIRE";
    2013                 :          0 :       break;
    2014                 :          2 :     case ST_INTERFACE:
    2015                 :          2 :       p = "INTERFACE";
    2016                 :          2 :       break;
    2017                 :          1 :     case ST_LOCK:
    2018                 :          1 :       p = "LOCK";
    2019                 :          1 :       break;
    2020                 :          0 :     case ST_PARAMETER:
    2021                 :          0 :       p = "PARAMETER";
    2022                 :          0 :       break;
    2023                 :          0 :     case ST_PRIVATE:
    2024                 :          0 :       p = "PRIVATE";
    2025                 :          0 :       break;
    2026                 :          0 :     case ST_PUBLIC:
    2027                 :          0 :       p = "PUBLIC";
    2028                 :          0 :       break;
    2029                 :          1 :     case ST_MODULE:
    2030                 :          1 :       p = "MODULE";
    2031                 :          1 :       break;
    2032                 :          0 :     case ST_SUBMODULE:
    2033                 :          0 :       p = "SUBMODULE";
    2034                 :          0 :       break;
    2035                 :          0 :     case ST_PAUSE:
    2036                 :          0 :       p = "PAUSE";
    2037                 :          0 :       break;
    2038                 :          3 :     case ST_MODULE_PROC:
    2039                 :          3 :       p = "MODULE PROCEDURE";
    2040                 :          3 :       break;
    2041                 :          2 :     case ST_NAMELIST:
    2042                 :          2 :       p = "NAMELIST";
    2043                 :          2 :       break;
    2044                 :          0 :     case ST_NULLIFY:
    2045                 :          0 :       p = "NULLIFY";
    2046                 :          0 :       break;
    2047                 :          0 :     case ST_OPEN:
    2048                 :          0 :       p = "OPEN";
    2049                 :          0 :       break;
    2050                 :          1 :     case ST_PROGRAM:
    2051                 :          1 :       p = "PROGRAM";
    2052                 :          1 :       break;
    2053                 :          0 :     case ST_PROCEDURE:
    2054                 :          0 :       p = "PROCEDURE";
    2055                 :          0 :       break;
    2056                 :          0 :     case ST_READ:
    2057                 :          0 :       p = "READ";
    2058                 :          0 :       break;
    2059                 :          0 :     case ST_RETURN:
    2060                 :          0 :       p = "RETURN";
    2061                 :          0 :       break;
    2062                 :          2 :     case ST_REWIND:
    2063                 :          2 :       p = "REWIND";
    2064                 :          2 :       break;
    2065                 :          2 :     case ST_STOP:
    2066                 :          2 :       p = "STOP";
    2067                 :          2 :       break;
    2068                 :          1 :     case ST_SYNC_ALL:
    2069                 :          1 :       p = "SYNC ALL";
    2070                 :          1 :       break;
    2071                 :          1 :     case ST_SYNC_IMAGES:
    2072                 :          1 :       p = "SYNC IMAGES";
    2073                 :          1 :       break;
    2074                 :          0 :     case ST_SYNC_MEMORY:
    2075                 :          0 :       p = "SYNC MEMORY";
    2076                 :          0 :       break;
    2077                 :          0 :     case ST_SUBROUTINE:
    2078                 :          0 :       p = "SUBROUTINE";
    2079                 :          0 :       break;
    2080                 :          0 :     case ST_TYPE:
    2081                 :          0 :       p = "TYPE";
    2082                 :          0 :       break;
    2083                 :          0 :     case ST_UNLOCK:
    2084                 :          0 :       p = "UNLOCK";
    2085                 :          0 :       break;
    2086                 :          9 :     case ST_USE:
    2087                 :          9 :       p = "USE";
    2088                 :          9 :       break;
    2089                 :          0 :     case ST_WHERE_BLOCK:        /* Fall through */
    2090                 :          0 :     case ST_WHERE:
    2091                 :          0 :       p = "WHERE";
    2092                 :          0 :       break;
    2093                 :          0 :     case ST_WAIT:
    2094                 :          0 :       p = "WAIT";
    2095                 :          0 :       break;
    2096                 :          1 :     case ST_WRITE:
    2097                 :          1 :       p = "WRITE";
    2098                 :          1 :       break;
    2099                 :         11 :     case ST_ASSIGNMENT:
    2100                 :         11 :       p = _("assignment");
    2101                 :         11 :       break;
    2102                 :          0 :     case ST_POINTER_ASSIGNMENT:
    2103                 :          0 :       p = _("pointer assignment");
    2104                 :          0 :       break;
    2105                 :          0 :     case ST_SELECT_CASE:
    2106                 :          0 :       p = "SELECT CASE";
    2107                 :          0 :       break;
    2108                 :          0 :     case ST_SELECT_TYPE:
    2109                 :          0 :       p = "SELECT TYPE";
    2110                 :          0 :       break;
    2111                 :          0 :     case ST_SELECT_RANK:
    2112                 :          0 :       p = "SELECT RANK";
    2113                 :          0 :       break;
    2114                 :          0 :     case ST_TYPE_IS:
    2115                 :          0 :       p = "TYPE IS";
    2116                 :          0 :       break;
    2117                 :          0 :     case ST_CLASS_IS:
    2118                 :          0 :       p = "CLASS IS";
    2119                 :          0 :       break;
    2120                 :          0 :     case ST_RANK:
    2121                 :          0 :       p = "RANK";
    2122                 :          0 :       break;
    2123                 :          1 :     case ST_SEQUENCE:
    2124                 :          1 :       p = "SEQUENCE";
    2125                 :          1 :       break;
    2126                 :          0 :     case ST_SIMPLE_IF:
    2127                 :          0 :       p = _("simple IF");
    2128                 :          0 :       break;
    2129                 :          3 :     case ST_STATEMENT_FUNCTION:
    2130                 :          3 :       p = "STATEMENT FUNCTION";
    2131                 :          3 :       break;
    2132                 :          0 :     case ST_LABEL_ASSIGNMENT:
    2133                 :          0 :       p = "LABEL ASSIGNMENT";
    2134                 :          0 :       break;
    2135                 :          2 :     case ST_ENUM:
    2136                 :          2 :       p = "ENUM DEFINITION";
    2137                 :          2 :       break;
    2138                 :          0 :     case ST_ENUMERATOR:
    2139                 :          0 :       p = "ENUMERATOR DEFINITION";
    2140                 :          0 :       break;
    2141                 :          4 :     case ST_END_ENUM:
    2142                 :          4 :       p = "END ENUM";
    2143                 :          4 :       break;
    2144                 :          0 :     case ST_OACC_PARALLEL_LOOP:
    2145                 :          0 :       p = "!$ACC PARALLEL LOOP";
    2146                 :          0 :       break;
    2147                 :          2 :     case ST_OACC_END_PARALLEL_LOOP:
    2148                 :          2 :       p = "!$ACC END PARALLEL LOOP";
    2149                 :          2 :       break;
    2150                 :          2 :     case ST_OACC_PARALLEL:
    2151                 :          2 :       p = "!$ACC PARALLEL";
    2152                 :          2 :       break;
    2153                 :         36 :     case ST_OACC_END_PARALLEL:
    2154                 :         36 :       p = "!$ACC END PARALLEL";
    2155                 :         36 :       break;
    2156                 :         49 :     case ST_OACC_KERNELS:
    2157                 :         49 :       p = "!$ACC KERNELS";
    2158                 :         49 :       break;
    2159                 :         12 :     case ST_OACC_END_KERNELS:
    2160                 :         12 :       p = "!$ACC END KERNELS";
    2161                 :         12 :       break;
    2162                 :          0 :     case ST_OACC_KERNELS_LOOP:
    2163                 :          0 :       p = "!$ACC KERNELS LOOP";
    2164                 :          0 :       break;
    2165                 :          1 :     case ST_OACC_END_KERNELS_LOOP:
    2166                 :          1 :       p = "!$ACC END KERNELS LOOP";
    2167                 :          1 :       break;
    2168                 :          0 :     case ST_OACC_SERIAL_LOOP:
    2169                 :          0 :       p = "!$ACC SERIAL LOOP";
    2170                 :          0 :       break;
    2171                 :          0 :     case ST_OACC_END_SERIAL_LOOP:
    2172                 :          0 :       p = "!$ACC END SERIAL LOOP";
    2173                 :          0 :       break;
    2174                 :          0 :     case ST_OACC_SERIAL:
    2175                 :          0 :       p = "!$ACC SERIAL";
    2176                 :          0 :       break;
    2177                 :          3 :     case ST_OACC_END_SERIAL:
    2178                 :          3 :       p = "!$ACC END SERIAL";
    2179                 :          3 :       break;
    2180                 :          1 :     case ST_OACC_DATA:
    2181                 :          1 :       p = "!$ACC DATA";
    2182                 :          1 :       break;
    2183                 :          6 :     case ST_OACC_END_DATA:
    2184                 :          6 :       p = "!$ACC END DATA";
    2185                 :          6 :       break;
    2186                 :          0 :     case ST_OACC_HOST_DATA:
    2187                 :          0 :       p = "!$ACC HOST_DATA";
    2188                 :          0 :       break;
    2189                 :          1 :     case ST_OACC_END_HOST_DATA:
    2190                 :          1 :       p = "!$ACC END HOST_DATA";
    2191                 :          1 :       break;
    2192                 :          2 :     case ST_OACC_LOOP:
    2193                 :          2 :       p = "!$ACC LOOP";
    2194                 :          2 :       break;
    2195                 :          4 :     case ST_OACC_END_LOOP:
    2196                 :          4 :       p = "!$ACC END LOOP";
    2197                 :          4 :       break;
    2198                 :          0 :     case ST_OACC_DECLARE:
    2199                 :          0 :       p = "!$ACC DECLARE";
    2200                 :          0 :       break;
    2201                 :          1 :     case ST_OACC_UPDATE:
    2202                 :          1 :       p = "!$ACC UPDATE";
    2203                 :          1 :       break;
    2204                 :          1 :     case ST_OACC_WAIT:
    2205                 :          1 :       p = "!$ACC WAIT";
    2206                 :          1 :       break;
    2207                 :          1 :     case ST_OACC_CACHE:
    2208                 :          1 :       p = "!$ACC CACHE";
    2209                 :          1 :       break;
    2210                 :          1 :     case ST_OACC_ENTER_DATA:
    2211                 :          1 :       p = "!$ACC ENTER DATA";
    2212                 :          1 :       break;
    2213                 :          1 :     case ST_OACC_EXIT_DATA:
    2214                 :          1 :       p = "!$ACC EXIT DATA";
    2215                 :          1 :       break;
    2216                 :          4 :     case ST_OACC_ROUTINE:
    2217                 :          4 :       p = "!$ACC ROUTINE";
    2218                 :          4 :       break;
    2219                 :          0 :     case ST_OACC_ATOMIC:
    2220                 :          0 :       p = "!$ACC ATOMIC";
    2221                 :          0 :       break;
    2222                 :          0 :     case ST_OACC_END_ATOMIC:
    2223                 :          0 :       p = "!$ACC END ATOMIC";
    2224                 :          0 :       break;
    2225                 :          1 :     case ST_OMP_ATOMIC:
    2226                 :          1 :       p = "!$OMP ATOMIC";
    2227                 :          1 :       break;
    2228                 :          1 :     case ST_OMP_BARRIER:
    2229                 :          1 :       p = "!$OMP BARRIER";
    2230                 :          1 :       break;
    2231                 :          1 :     case ST_OMP_CANCEL:
    2232                 :          1 :       p = "!$OMP CANCEL";
    2233                 :          1 :       break;
    2234                 :          1 :     case ST_OMP_CANCELLATION_POINT:
    2235                 :          1 :       p = "!$OMP CANCELLATION POINT";
    2236                 :          1 :       break;
    2237                 :          1 :     case ST_OMP_CRITICAL:
    2238                 :          1 :       p = "!$OMP CRITICAL";
    2239                 :          1 :       break;
    2240                 :          1 :     case ST_OMP_DECLARE_REDUCTION:
    2241                 :          1 :       p = "!$OMP DECLARE REDUCTION";
    2242                 :          1 :       break;
    2243                 :          3 :     case ST_OMP_DECLARE_SIMD:
    2244                 :          3 :       p = "!$OMP DECLARE SIMD";
    2245                 :          3 :       break;
    2246                 :          2 :     case ST_OMP_DECLARE_TARGET:
    2247                 :          2 :       p = "!$OMP DECLARE TARGET";
    2248                 :          2 :       break;
    2249                 :          1 :     case ST_OMP_DISTRIBUTE:
    2250                 :          1 :       p = "!$OMP DISTRIBUTE";
    2251                 :          1 :       break;
    2252                 :          1 :     case ST_OMP_DISTRIBUTE_PARALLEL_DO:
    2253                 :          1 :       p = "!$OMP DISTRIBUTE PARALLEL DO";
    2254                 :          1 :       break;
    2255                 :          1 :     case ST_OMP_DISTRIBUTE_PARALLEL_DO_SIMD:
    2256                 :          1 :       p = "!$OMP DISTRIBUTE PARALLEL DO SIMD";
    2257                 :          1 :       break;
    2258                 :          1 :     case ST_OMP_DISTRIBUTE_SIMD:
    2259                 :          1 :       p = "!$OMP DISTRIBUTE SIMD";
    2260                 :          1 :       break;
    2261                 :          2 :     case ST_OMP_DO:
    2262                 :          2 :       p = "!$OMP DO";
    2263                 :          2 :       break;
    2264                 :          1 :     case ST_OMP_DO_SIMD:
    2265                 :          1 :       p = "!$OMP DO SIMD";
    2266                 :          1 :       break;
    2267                 :          0 :     case ST_OMP_END_ATOMIC:
    2268                 :          0 :       p = "!$OMP END ATOMIC";
    2269                 :          0 :       break;
    2270                 :          0 :     case ST_OMP_END_CRITICAL:
    2271                 :          0 :       p = "!$OMP END CRITICAL";
    2272                 :          0 :       break;
    2273                 :          0 :     case ST_OMP_END_DISTRIBUTE:
    2274                 :          0 :       p = "!$OMP END DISTRIBUTE";
    2275                 :          0 :       break;
    2276                 :          0 :     case ST_OMP_END_DISTRIBUTE_PARALLEL_DO:
    2277                 :          0 :       p = "!$OMP END DISTRIBUTE PARALLEL DO";
    2278                 :          0 :       break;
    2279                 :          0 :     case ST_OMP_END_DISTRIBUTE_PARALLEL_DO_SIMD:
    2280                 :          0 :       p = "!$OMP END DISTRIBUTE PARALLEL DO SIMD";
    2281                 :          0 :       break;
    2282                 :          0 :     case ST_OMP_END_DISTRIBUTE_SIMD:
    2283                 :          0 :       p = "!$OMP END DISTRIBUTE SIMD";
    2284                 :          0 :       break;
    2285                 :          1 :     case ST_OMP_END_DO:
    2286                 :          1 :       p = "!$OMP END DO";
    2287                 :          1 :       break;
    2288                 :          0 :     case ST_OMP_END_DO_SIMD:
    2289                 :          0 :       p = "!$OMP END DO SIMD";
    2290                 :          0 :       break;
    2291                 :          0 :     case ST_OMP_END_SIMD:
    2292                 :          0 :       p = "!$OMP END SIMD";
    2293                 :          0 :       break;
    2294                 :          0 :     case ST_OMP_END_MASTER:
    2295                 :          0 :       p = "!$OMP END MASTER";
    2296                 :          0 :       break;
    2297                 :          0 :     case ST_OMP_END_ORDERED:
    2298                 :          0 :       p = "!$OMP END ORDERED";
    2299                 :          0 :       break;
    2300                 :          8 :     case ST_OMP_END_PARALLEL:
    2301                 :          8 :       p = "!$OMP END PARALLEL";
    2302                 :          8 :       break;
    2303                 :          0 :     case ST_OMP_END_PARALLEL_DO:
    2304                 :          0 :       p = "!$OMP END PARALLEL DO";
    2305                 :          0 :       break;
    2306                 :          0 :     case ST_OMP_END_PARALLEL_DO_SIMD:
    2307                 :          0 :       p = "!$OMP END PARALLEL DO SIMD";
    2308                 :          0 :       break;
    2309                 :          0 :     case ST_OMP_END_PARALLEL_SECTIONS:
    2310                 :          0 :       p = "!$OMP END PARALLEL SECTIONS";
    2311                 :          0 :       break;
    2312                 :          0 :     case ST_OMP_END_PARALLEL_WORKSHARE:
    2313                 :          0 :       p = "!$OMP END PARALLEL WORKSHARE";
    2314                 :          0 :       break;
    2315                 :          0 :     case ST_OMP_END_SECTIONS:
    2316                 :          0 :       p = "!$OMP END SECTIONS";
    2317                 :          0 :       break;
    2318                 :          0 :     case ST_OMP_END_SINGLE:
    2319                 :          0 :       p = "!$OMP END SINGLE";
    2320                 :          0 :       break;
    2321                 :          0 :     case ST_OMP_END_TASK:
    2322                 :          0 :       p = "!$OMP END TASK";
    2323                 :          0 :       break;
    2324                 :          4 :     case ST_OMP_END_TARGET:
    2325                 :          4 :       p = "!$OMP END TARGET";
    2326                 :          4 :       break;
    2327                 :          0 :     case ST_OMP_END_TARGET_DATA:
    2328                 :          0 :       p = "!$OMP END TARGET DATA";
    2329                 :          0 :       break;
    2330                 :          0 :     case ST_OMP_END_TARGET_PARALLEL:
    2331                 :          0 :       p = "!$OMP END TARGET PARALLEL";
    2332                 :          0 :       break;
    2333                 :          0 :     case ST_OMP_END_TARGET_PARALLEL_DO:
    2334                 :          0 :       p = "!$OMP END TARGET PARALLEL DO";
    2335                 :          0 :       break;
    2336                 :          0 :     case ST_OMP_END_TARGET_PARALLEL_DO_SIMD:
    2337                 :          0 :       p = "!$OMP END TARGET PARALLEL DO SIMD";
    2338                 :          0 :       break;
    2339                 :          0 :     case ST_OMP_END_TARGET_SIMD:
    2340                 :          0 :       p = "!$OMP END TARGET SIMD";
    2341                 :          0 :       break;
    2342                 :          0 :     case ST_OMP_END_TARGET_TEAMS:
    2343                 :          0 :       p = "!$OMP END TARGET TEAMS";
    2344                 :          0 :       break;
    2345                 :          0 :     case ST_OMP_END_TARGET_TEAMS_DISTRIBUTE:
    2346                 :          0 :       p = "!$OMP END TARGET TEAMS DISTRIBUTE";
    2347                 :          0 :       break;
    2348                 :          0 :     case ST_OMP_END_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO:
    2349                 :          0 :       p = "!$OMP END TARGET TEAMS DISTRIBUTE PARALLEL DO";
    2350                 :          0 :       break;
    2351                 :          0 :     case ST_OMP_END_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD:
    2352                 :          0 :       p = "!$OMP END TARGET TEAMS DISTRIBUTE PARALLEL DO SIMD";
    2353                 :          0 :       break;
    2354                 :          0 :     case ST_OMP_END_TARGET_TEAMS_DISTRIBUTE_SIMD:
    2355                 :          0 :       p = "!$OMP END TARGET TEAMS DISTRIBUTE SIMD";
    2356                 :          0 :       break;
    2357                 :          0 :     case ST_OMP_END_TASKGROUP:
    2358                 :          0 :       p = "!$OMP END TASKGROUP";
    2359                 :          0 :       break;
    2360                 :          0 :     case ST_OMP_END_TASKLOOP:
    2361                 :          0 :       p = "!$OMP END TASKLOOP";
    2362                 :          0 :       break;
    2363                 :          0 :     case ST_OMP_END_TASKLOOP_SIMD:
    2364                 :          0 :       p = "!$OMP END TASKLOOP SIMD";
    2365                 :          0 :       break;
    2366                 :          0 :     case ST_OMP_END_TEAMS:
    2367                 :          0 :       p = "!$OMP END TEAMS";
    2368                 :          0 :       break;
    2369                 :          0 :     case ST_OMP_END_TEAMS_DISTRIBUTE:
    2370                 :          0 :       p = "!$OMP END TEAMS DISTRIBUTE";
    2371                 :          0 :       break;
    2372                 :          0 :     case ST_OMP_END_TEAMS_DISTRIBUTE_PARALLEL_DO:
    2373                 :          0 :       p = "!$OMP END TEAMS DISTRIBUTE PARALLEL DO";
    2374                 :          0 :       break;
    2375                 :          0 :     case ST_OMP_END_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD:
    2376                 :          0 :       p = "!$OMP END TEAMS DISTRIBUTE PARALLEL DO SIMD";
    2377                 :          0 :       break;
    2378                 :          0 :     case ST_OMP_END_TEAMS_DISTRIBUTE_SIMD:
    2379                 :          0 :       p = "!$OMP END TEAMS DISTRIBUTE SIMD";
    2380                 :          0 :       break;
    2381                 :          0 :     case ST_OMP_END_WORKSHARE:
    2382                 :          0 :       p = "!$OMP END WORKSHARE";
    2383                 :          0 :       break;
    2384                 :          1 :     case ST_OMP_FLUSH:
    2385                 :          1 :       p = "!$OMP FLUSH";
    2386                 :          1 :       break;
    2387                 :          1 :     case ST_OMP_MASTER:
    2388                 :          1 :       p = "!$OMP MASTER";
    2389                 :          1 :       break;
    2390                 :          1 :     case ST_OMP_ORDERED:
    2391                 :          1 :     case ST_OMP_ORDERED_DEPEND:
    2392                 :          1 :       p = "!$OMP ORDERED";
    2393                 :          1 :       break;
    2394                 :          5 :     case ST_OMP_PARALLEL:
    2395                 :          5 :       p = "!$OMP PARALLEL";
    2396                 :          5 :       break;
    2397                 :          6 :     case ST_OMP_PARALLEL_DO:
    2398                 :          6 :       p = "!$OMP PARALLEL DO";
    2399                 :          6 :       break;
    2400                 :          1 :     case ST_OMP_PARALLEL_DO_SIMD:
    2401                 :          1 :       p = "!$OMP PARALLEL DO SIMD";
    2402                 :          1 :       break;
    2403                 :          1 :     case ST_OMP_PARALLEL_SECTIONS:
    2404                 :          1 :       p = "!$OMP PARALLEL SECTIONS";
    2405                 :          1 :       break;
    2406                 :          1 :     case ST_OMP_PARALLEL_WORKSHARE:
    2407                 :          1 :       p = "!$OMP PARALLEL WORKSHARE";
    2408                 :          1 :       break;
    2409                 :          1 :     case ST_OMP_SECTIONS:
    2410                 :          1 :       p = "!$OMP SECTIONS";
    2411                 :          1 :       break;
    2412                 :          0 :     case ST_OMP_SECTION:
    2413                 :          0 :       p = "!$OMP SECTION";
    2414                 :          0 :       break;
    2415                 :          1 :     case ST_OMP_SIMD:
    2416                 :          1 :       p = "!$OMP SIMD";
    2417                 :          1 :       break;
    2418                 :          1 :     case ST_OMP_SINGLE:
    2419                 :          1 :       p = "!$OMP SINGLE";
    2420                 :          1 :       break;
    2421                 :          1 :     case ST_OMP_TARGET:
    2422                 :          1 :       p = "!$OMP TARGET";
    2423                 :          1 :       break;
    2424                 :          1 :     case ST_OMP_TARGET_DATA:
    2425                 :          1 :       p = "!$OMP TARGET DATA";
    2426                 :          1 :       break;
    2427                 :          1 :     case ST_OMP_TARGET_ENTER_DATA:
    2428                 :          1 :       p = "!$OMP TARGET ENTER DATA";
    2429                 :          1 :       break;
    2430                 :          1 :     case ST_OMP_TARGET_EXIT_DATA:
    2431                 :          1 :       p = "!$OMP TARGET EXIT DATA";
    2432                 :          1 :       break;
    2433                 :          1 :     case ST_OMP_TARGET_PARALLEL:
    2434                 :          1 :       p = "!$OMP TARGET PARALLEL";
    2435                 :          1 :       break;
    2436                 :          1 :     case ST_OMP_TARGET_PARALLEL_DO:
    2437                 :          1 :       p = "!$OMP TARGET PARALLEL DO";
    2438                 :          1 :       break;
    2439                 :          1 :     case ST_OMP_TARGET_PARALLEL_DO_SIMD:
    2440                 :          1 :       p = "!$OMP TARGET PARALLEL DO SIMD";
    2441                 :          1 :       break;
    2442                 :          1 :     case ST_OMP_TARGET_SIMD:
    2443                 :          1 :       p = "!$OMP TARGET SIMD";
    2444                 :          1 :       break;
    2445                 :          1 :     case ST_OMP_TARGET_TEAMS:
    2446                 :          1 :       p = "!$OMP TARGET TEAMS";
    2447                 :          1 :       break;
    2448                 :          1 :     case ST_OMP_TARGET_TEAMS_DISTRIBUTE:
    2449                 :          1 :       p = "!$OMP TARGET TEAMS DISTRIBUTE";
    2450                 :          1 :       break;
    2451                 :          1 :     case ST_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO:
    2452                 :          1 :       p = "!$OMP TARGET TEAMS DISTRIBUTE PARALLEL DO";
    2453                 :          1 :       break;
    2454                 :          1 :     case ST_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD:
    2455                 :          1 :       p = "!$OMP TARGET TEAMS DISTRIBUTE PARALLEL DO SIMD";
    2456                 :          1 :       break;
    2457                 :          1 :     case ST_OMP_TARGET_TEAMS_DISTRIBUTE_SIMD:
    2458                 :          1 :       p = "!$OMP TARGET TEAMS DISTRIBUTE SIMD";
    2459                 :          1 :       break;
    2460                 :          1 :     case ST_OMP_TARGET_UPDATE:
    2461                 :          1 :       p = "!$OMP TARGET UPDATE";
    2462                 :          1 :       break;
    2463                 :          1 :     case ST_OMP_TASK:
    2464                 :          1 :       p = "!$OMP TASK";
    2465                 :          1 :       break;
    2466                 :          1 :     case ST_OMP_TASKGROUP:
    2467                 :          1 :       p = "!$OMP TASKGROUP";
    2468                 :          1 :       break;
    2469                 :          1 :     case ST_OMP_TASKLOOP:
    2470                 :          1 :       p = "!$OMP TASKLOOP";
    2471                 :          1 :       break;
    2472                 :          1 :     case ST_OMP_TASKLOOP_SIMD:
    2473                 :          1 :       p = "!$OMP TASKLOOP SIMD";
    2474                 :          1 :       break;
    2475                 :          1 :     case ST_OMP_TASKWAIT:
    2476                 :          1 :       p = "!$OMP TASKWAIT";
    2477                 :          1 :       break;
    2478                 :          1 :     case ST_OMP_TASKYIELD:
    2479                 :          1 :       p = "!$OMP TASKYIELD";
    2480                 :          1 :       break;
    2481                 :          1 :     case ST_OMP_TEAMS:
    2482                 :          1 :       p = "!$OMP TEAMS";
    2483                 :          1 :       break;
    2484                 :          1 :     case ST_OMP_TEAMS_DISTRIBUTE:
    2485                 :          1 :       p = "!$OMP TEAMS DISTRIBUTE";
    2486                 :          1 :       break;
    2487                 :          1 :     case ST_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO:
    2488                 :          1 :       p = "!$OMP TEAMS DISTRIBUTE PARALLEL DO";
    2489                 :          1 :       break;
    2490                 :          1 :     case ST_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD:
    2491                 :          1 :       p = "!$OMP TEAMS DISTRIBUTE PARALLEL DO SIMD";
    2492                 :          1 :       break;
    2493                 :          1 :     case ST_OMP_TEAMS_DISTRIBUTE_SIMD:
    2494                 :          1 :       p = "!$OMP TEAMS DISTRIBUTE SIMD";
    2495                 :          1 :       break;
    2496                 :          1 :     case ST_OMP_THREADPRIVATE:
    2497                 :          1 :       p = "!$OMP THREADPRIVATE";
    2498                 :          1 :       break;
    2499                 :          1 :     case ST_OMP_WORKSHARE:
    2500                 :          1 :       p = "!$OMP WORKSHARE";
    2501                 :          1 :       break;
    2502                 :          0 :     default:
    2503                 :          0 :       gfc_internal_error ("gfc_ascii_statement(): Bad statement code");
    2504                 :            :     }
    2505                 :            : 
    2506                 :      17198 :   return p;
    2507                 :            : }
    2508                 :            : 
    2509                 :            : 
    2510                 :            : /* Create a symbol for the main program and assign it to ns->proc_name.  */
    2511                 :            : 
    2512                 :            : static void
    2513                 :      22291 : main_program_symbol (gfc_namespace *ns, const char *name)
    2514                 :            : {
    2515                 :      22291 :   gfc_symbol *main_program;
    2516                 :      22291 :   symbol_attribute attr;
    2517                 :            : 
    2518                 :      22291 :   gfc_get_symbol (name, ns, &main_program);
    2519                 :      22291 :   gfc_clear_attr (&attr);
    2520                 :      22291 :   attr.flavor = FL_PROGRAM;
    2521                 :      22291 :   attr.proc = PROC_UNKNOWN;
    2522                 :      22291 :   attr.subroutine = 1;
    2523                 :      22291 :   attr.access = ACCESS_PUBLIC;
    2524                 :      22291 :   attr.is_main_program = 1;
    2525                 :      22291 :   main_program->attr = attr;
    2526                 :      22291 :   main_program->declared_at = gfc_current_locus;
    2527                 :      22291 :   ns->proc_name = main_program;
    2528                 :      22291 :   gfc_commit_symbols ();
    2529                 :      22291 : }
    2530                 :            : 
    2531                 :            : 
    2532                 :            : /* Do whatever is necessary to accept the last statement.  */
    2533                 :            : 
    2534                 :            : static void
    2535                 :     847519 : accept_statement (gfc_statement st)
    2536                 :            : {
    2537                 :     847519 :   switch (st)
    2538                 :            :     {
    2539                 :            :     case ST_IMPLICIT_NONE:
    2540                 :            :     case ST_IMPLICIT:
    2541                 :            :       break;
    2542                 :            : 
    2543                 :      46759 :     case ST_FUNCTION:
    2544                 :      46759 :     case ST_SUBROUTINE:
    2545                 :      46759 :     case ST_MODULE:
    2546                 :      46759 :     case ST_SUBMODULE:
    2547                 :      46759 :       gfc_current_ns->proc_name = gfc_new_block;
    2548                 :      46759 :       break;
    2549                 :            : 
    2550                 :            :       /* If the statement is the end of a block, lay down a special code
    2551                 :            :          that allows a branch to the end of the block from within the
    2552                 :            :          construct.  IF and SELECT are treated differently from DO
    2553                 :            :          (where EXEC_NOP is added inside the loop) for two
    2554                 :            :          reasons:
    2555                 :            :          1. END DO has a meaning in the sense that after a GOTO to
    2556                 :            :             it, the loop counter must be increased.
    2557                 :            :          2. IF blocks and SELECT blocks can consist of multiple
    2558                 :            :             parallel blocks (IF ... ELSE IF ... ELSE ... END IF).
    2559                 :            :             Putting the label before the END IF would make the jump
    2560                 :            :             from, say, the ELSE IF block to the END IF illegal.  */
    2561                 :            : 
    2562                 :      12173 :     case ST_ENDIF:
    2563                 :      12173 :     case ST_END_SELECT:
    2564                 :      12173 :     case ST_END_CRITICAL:
    2565                 :      12173 :       if (gfc_statement_label != NULL)
    2566                 :            :         {
    2567                 :         43 :           new_st.op = EXEC_END_NESTED_BLOCK;
    2568                 :         43 :           add_statement ();
    2569                 :            :         }
    2570                 :            :       break;
    2571                 :            : 
    2572                 :            :       /* In the case of BLOCK and ASSOCIATE blocks, there cannot be more than
    2573                 :            :          one parallel block.  Thus, we add the special code to the nested block
    2574                 :            :          itself, instead of the parent one.  */
    2575                 :       1067 :     case ST_END_BLOCK:
    2576                 :       1067 :     case ST_END_ASSOCIATE:
    2577                 :       1067 :       if (gfc_statement_label != NULL)
    2578                 :            :         {
    2579                 :          2 :           new_st.op = EXEC_END_BLOCK;
    2580                 :          2 :           add_statement ();
    2581                 :            :         }
    2582                 :            :       break;
    2583                 :            : 
    2584                 :            :       /* The end-of-program unit statements do not get the special
    2585                 :            :          marker and require a statement of some sort if they are a
    2586                 :            :          branch target.  */
    2587                 :            : 
    2588                 :      53707 :     case ST_END_PROGRAM:
    2589                 :      53707 :     case ST_END_FUNCTION:
    2590                 :      53707 :     case ST_END_SUBROUTINE:
    2591                 :      53707 :       if (gfc_statement_label != NULL)
    2592                 :            :         {
    2593                 :         20 :           new_st.op = EXEC_RETURN;
    2594                 :         20 :           add_statement ();
    2595                 :            :         }
    2596                 :            :       else
    2597                 :            :         {
    2598                 :      53687 :           new_st.op = EXEC_END_PROCEDURE;
    2599                 :      53687 :           add_statement ();
    2600                 :            :         }
    2601                 :            : 
    2602                 :            :       break;
    2603                 :            : 
    2604                 :     433423 :     case ST_ENTRY:
    2605                 :     433423 :     case_executable:
    2606                 :     433423 :     case_exec_markers:
    2607                 :     433423 :       add_statement ();
    2608                 :     433423 :       break;
    2609                 :            : 
    2610                 :            :     default:
    2611                 :            :       break;
    2612                 :            :     }
    2613                 :            : 
    2614                 :     847519 :   gfc_commit_symbols ();
    2615                 :     847519 :   gfc_warning_check ();
    2616                 :     847519 :   gfc_clear_new_st ();
    2617                 :     847519 : }
    2618                 :            : 
    2619                 :            : 
    2620                 :            : /* Undo anything tentative that has been built for the current statement,
    2621                 :            :    except if a gfc_charlen structure has been added to current namespace's
    2622                 :            :    list of gfc_charlen structure.  */
    2623                 :            : 
    2624                 :            : static void
    2625                 :    5683650 : reject_statement (void)
    2626                 :            : {
    2627                 :    5683650 :   gfc_free_equiv_until (gfc_current_ns->equiv, gfc_current_ns->old_equiv);
    2628                 :    5683650 :   gfc_current_ns->equiv = gfc_current_ns->old_equiv;
    2629                 :            : 
    2630                 :    5683650 :   gfc_reject_data (gfc_current_ns);
    2631                 :            : 
    2632                 :    5683650 :   gfc_new_block = NULL;
    2633                 :    5683650 :   gfc_undo_symbols ();
    2634                 :    5683650 :   gfc_clear_warning ();
    2635                 :    5683650 :   undo_new_statement ();
    2636                 :    5683650 : }
    2637                 :            : 
    2638                 :            : 
    2639                 :            : /* Generic complaint about an out of order statement.  We also do
    2640                 :            :    whatever is necessary to clean up.  */
    2641                 :            : 
    2642                 :            : static void
    2643                 :        118 : unexpected_statement (gfc_statement st)
    2644                 :            : {
    2645                 :        118 :   gfc_error ("Unexpected %s statement at %C", gfc_ascii_statement (st));
    2646                 :            : 
    2647                 :        118 :   reject_statement ();
    2648                 :        118 : }
    2649                 :            : 
    2650                 :            : 
    2651                 :            : /* Given the next statement seen by the matcher, make sure that it is
    2652                 :            :    in proper order with the last.  This subroutine is initialized by
    2653                 :            :    calling it with an argument of ST_NONE.  If there is a problem, we
    2654                 :            :    issue an error and return false.  Otherwise we return true.
    2655                 :            : 
    2656                 :            :    Individual parsers need to verify that the statements seen are
    2657                 :            :    valid before calling here, i.e., ENTRY statements are not allowed in
    2658                 :            :    INTERFACE blocks.  The following diagram is taken from the standard:
    2659                 :            : 
    2660                 :            :             +---------------------------------------+
    2661                 :            :             | program  subroutine  function  module |
    2662                 :            :             +---------------------------------------+
    2663                 :            :             |            use               |
    2664                 :            :             +---------------------------------------+
    2665                 :            :             |            import         |
    2666                 :            :             +---------------------------------------+
    2667                 :            :             |   |       implicit none    |
    2668                 :            :             |   +-----------+------------------+
    2669                 :            :             |   | parameter |  implicit |
    2670                 :            :             |   +-----------+------------------+
    2671                 :            :             | format |     |  derived type    |
    2672                 :            :             | entry  | parameter |  interface       |
    2673                 :            :             |   |   data    |  specification   |
    2674                 :            :             |   |          |  statement func  |
    2675                 :            :             |   +-----------+------------------+
    2676                 :            :             |   |   data    |    executable    |
    2677                 :            :             +--------+-----------+------------------+
    2678                 :            :             |           contains               |
    2679                 :            :             +---------------------------------------+
    2680                 :            :             |      internal module/subprogram       |
    2681                 :            :             +---------------------------------------+
    2682                 :            :             |              end           |
    2683                 :            :             +---------------------------------------+
    2684                 :            : 
    2685                 :            : */
    2686                 :            : 
    2687                 :            : enum state_order
    2688                 :            : {
    2689                 :            :   ORDER_START,
    2690                 :            :   ORDER_USE,
    2691                 :            :   ORDER_IMPORT,
    2692                 :            :   ORDER_IMPLICIT_NONE,
    2693                 :            :   ORDER_IMPLICIT,
    2694                 :            :   ORDER_SPEC,
    2695                 :            :   ORDER_EXEC
    2696                 :            : };
    2697                 :            : 
    2698                 :            : typedef struct
    2699                 :            : {
    2700                 :            :   enum state_order state;
    2701                 :            :   gfc_statement last_statement;
    2702                 :            :   locus where;
    2703                 :            : }
    2704                 :            : st_state;
    2705                 :            : 
    2706                 :            : static bool
    2707                 :     285843 : verify_st_order (st_state *p, gfc_statement st, bool silent)
    2708                 :            : {
    2709                 :            : 
    2710                 :     285843 :   switch (st)
    2711                 :            :     {
    2712                 :      76667 :     case ST_NONE:
    2713                 :      76667 :       p->state = ORDER_START;
    2714                 :      76667 :       break;
    2715                 :            : 
    2716                 :      13363 :     case ST_USE:
    2717                 :      13363 :       if (p->state > ORDER_USE)
    2718                 :          0 :         goto order;
    2719                 :      13363 :       p->state = ORDER_USE;
    2720                 :      13363 :       break;
    2721                 :            : 
    2722                 :       2257 :     case ST_IMPORT:
    2723                 :       2257 :       if (p->state > ORDER_IMPORT)
    2724                 :          0 :         goto order;
    2725                 :       2257 :       p->state = ORDER_IMPORT;
    2726                 :       2257 :       break;
    2727                 :            : 
    2728                 :      16562 :     case ST_IMPLICIT_NONE:
    2729                 :      16562 :       if (p->state > ORDER_IMPLICIT)
    2730                 :          0 :         goto order;
    2731                 :            : 
    2732                 :            :       /* The '>' sign cannot be a '>=', because a FORMAT or ENTRY
    2733                 :            :          statement disqualifies a USE but not an IMPLICIT NONE.
    2734                 :            :          Duplicate IMPLICIT NONEs are caught when the implicit types
    2735                 :            :          are set.  */
    2736                 :            : 
    2737                 :      16562 :       p->state = ORDER_IMPLICIT_NONE;
    2738                 :      16562 :       break;
    2739                 :            : 
    2740                 :       7559 :     case ST_IMPLICIT:
    2741                 :       7559 :       if (p->state > ORDER_IMPLICIT)
    2742                 :       6324 :         goto order;
    2743                 :       1235 :       p->state = ORDER_IMPLICIT;
    2744                 :       1235 :       break;
    2745                 :            : 
    2746                 :        471 :     case ST_FORMAT:
    2747                 :        471 :     case ST_ENTRY:
    2748                 :        471 :       if (p->state < ORDER_IMPLICIT_NONE)
    2749                 :         74 :         p->state = ORDER_IMPLICIT_NONE;
    2750                 :            :       break;
    2751                 :            : 
    2752                 :       1915 :     case ST_PARAMETER:
    2753                 :       1915 :       if (p->state >= ORDER_EXEC)
    2754                 :          0 :         goto order;
    2755                 :       1915 :       if (p->state < ORDER_IMPLICIT)
    2756                 :         75 :         p->state = ORDER_IMPLICIT;
    2757                 :            :       break;
    2758                 :            : 
    2759                 :       2237 :     case ST_DATA:
    2760                 :       2237 :       if (p->state < ORDER_SPEC)
    2761                 :         16 :         p->state = ORDER_SPEC;
    2762                 :            :       break;
    2763                 :            : 
    2764                 :     163188 :     case ST_PUBLIC:
    2765                 :     163188 :     case ST_PRIVATE:
    2766                 :     163188 :     case ST_STRUCTURE_DECL:
    2767                 :     163188 :     case ST_DERIVED_DECL:
    2768                 :     163188 :     case_decl:
    2769                 :     163188 :       if (p->state >= ORDER_EXEC)
    2770                 :          0 :         goto order;
    2771                 :     163188 :       if (p->state < ORDER_SPEC)
    2772                 :      66407 :         p->state = ORDER_SPEC;
    2773                 :            :       break;
    2774                 :            : 
    2775                 :       1108 :     case_omp_decl:
    2776                 :            :       /* The OpenMP directives have to be somewhere in the specification
    2777                 :            :          part, but there are no further requirements on their ordering.
    2778                 :            :          Thus don't adjust p->state, just ignore them.  */
    2779                 :       1108 :       if (p->state >= ORDER_EXEC)
    2780                 :          0 :         goto order;
    2781                 :            :       break;
    2782                 :            : 
    2783                 :        512 :     case_executable:
    2784                 :        512 :     case_exec_markers:
    2785                 :        512 :       if (p->state < ORDER_EXEC)
    2786                 :        512 :         p->state = ORDER_EXEC;
    2787                 :            :       break;
    2788                 :            : 
    2789                 :            :     default:
    2790                 :            :       return false;
    2791                 :            :     }
    2792                 :            : 
    2793                 :            :   /* All is well, record the statement in case we need it next time.  */
    2794                 :     279515 :   p->where = gfc_current_locus;
    2795                 :     279515 :   p->last_statement = st;
    2796                 :     279515 :   return true;
    2797                 :            : 
    2798                 :       6324 : order:
    2799                 :       6324 :   if (!silent)
    2800                 :          1 :     gfc_error ("%s statement at %C cannot follow %s statement at %L",
    2801                 :            :                gfc_ascii_statement (st),
    2802                 :            :                gfc_ascii_statement (p->last_statement), &p->where);
    2803                 :            : 
    2804                 :            :   return false;
    2805                 :            : }
    2806                 :            : 
    2807                 :            : 
    2808                 :            : /* Handle an unexpected end of file.  This is a show-stopper...  */
    2809                 :            : 
    2810                 :            : static void unexpected_eof (void) ATTRIBUTE_NORETURN;
    2811                 :            : 
    2812                 :            : static void
    2813                 :         25 : unexpected_eof (void)
    2814                 :            : {
    2815                 :         25 :   gfc_state_data *p;
    2816                 :            : 
    2817                 :         25 :   gfc_error ("Unexpected end of file in %qs", gfc_source_file);
    2818                 :            : 
    2819                 :            :   /* Memory cleanup.  Move to "second to last".  */
    2820                 :         41 :   for (p = gfc_state_stack; p && p->previous && p->previous->previous;
    2821                 :            :        p = p->previous);
    2822                 :            : 
    2823                 :         25 :   gfc_current_ns->code = (p && p->previous) ? p->head : NULL;
    2824                 :         25 :   gfc_done_2 ();
    2825                 :            : 
    2826                 :         25 :   longjmp (eof_buf, 1);
    2827                 :            : 
    2828                 :            :   /* Avoids build error on systems where longjmp is not declared noreturn.  */
    2829                 :            :   gcc_unreachable ();
    2830                 :            : }
    2831                 :            : 
    2832                 :            : 
    2833                 :            : /* Parse the CONTAINS section of a derived type definition.  */
    2834                 :            : 
    2835                 :            : gfc_access gfc_typebound_default_access;
    2836                 :            : 
    2837                 :            : static bool
    2838                 :       1633 : parse_derived_contains (void)
    2839                 :            : {
    2840                 :       1633 :   gfc_state_data s;
    2841                 :       1633 :   bool seen_private = false;
    2842                 :       1633 :   bool seen_comps = false;
    2843                 :       1633 :   bool error_flag = false;
    2844                 :       1633 :   bool to_finish;
    2845                 :            : 
    2846                 :       1633 :   gcc_assert (gfc_current_state () == COMP_DERIVED);
    2847                 :       1633 :   gcc_assert (gfc_current_block ());
    2848                 :            : 
    2849                 :            :   /* Derived-types with SEQUENCE and/or BIND(C) must not have a CONTAINS
    2850                 :            :      section.  */
    2851                 :       1633 :   if (gfc_current_block ()->attr.sequence)
    2852                 :          1 :     gfc_error ("Derived-type %qs with SEQUENCE must not have a CONTAINS"
    2853                 :            :                " section at %C", gfc_current_block ()->name);
    2854                 :       1633 :   if (gfc_current_block ()->attr.is_bind_c)
    2855                 :          1 :     gfc_error ("Derived-type %qs with BIND(C) must not have a CONTAINS"
    2856                 :            :                " section at %C", gfc_current_block ()->name);
    2857                 :            : 
    2858                 :       1633 :   accept_statement (ST_CONTAINS);
    2859                 :       1633 :   push_state (&s, COMP_DERIVED_CONTAINS, NULL);
    2860                 :            : 
    2861                 :       1633 :   gfc_typebound_default_access = ACCESS_PUBLIC;
    2862                 :            : 
    2863                 :       1633 :   to_finish = false;
    2864                 :       6799 :   while (!to_finish)
    2865                 :            :     {
    2866                 :       5166 :       gfc_statement st;
    2867                 :       5166 :       st = next_statement ();
    2868                 :       5166 :       switch (st)
    2869                 :            :         {
    2870                 :          0 :         case ST_NONE:
    2871                 :          0 :           unexpected_eof ();
    2872                 :          1 :           break;
    2873                 :            : 
    2874                 :          1 :         case ST_DATA_DECL:
    2875                 :          1 :           gfc_error ("Components in TYPE at %C must precede CONTAINS");
    2876                 :          1 :           goto error;
    2877                 :            : 
    2878                 :       2582 :         case ST_PROCEDURE:
    2879                 :       2582 :           if (!gfc_notify_std (GFC_STD_F2003, "Type-bound procedure at %C"))
    2880                 :          0 :             goto error;
    2881                 :            : 
    2882                 :       2582 :           accept_statement (ST_PROCEDURE);
    2883                 :       2582 :           seen_comps = true;
    2884                 :       2582 :           break;
    2885                 :            : 
    2886                 :        759 :         case ST_GENERIC:
    2887                 :        759 :           if (!gfc_notify_std (GFC_STD_F2003, "GENERIC binding at %C"))
    2888                 :          0 :             goto error;
    2889                 :            : 
    2890                 :        759 :           accept_statement (ST_GENERIC);
    2891                 :        759 :           seen_comps = true;
    2892                 :        759 :           break;
    2893                 :            : 
    2894                 :        164 :         case ST_FINAL:
    2895                 :        164 :           if (!gfc_notify_std (GFC_STD_F2003, "FINAL procedure declaration"
    2896                 :            :                                " at %C"))
    2897                 :          1 :             goto error;
    2898                 :            : 
    2899                 :        163 :           accept_statement (ST_FINAL);
    2900                 :        163 :           seen_comps = true;
    2901                 :        163 :           break;
    2902                 :            : 
    2903                 :       1633 :         case ST_END_TYPE:
    2904                 :       1633 :           to_finish = true;
    2905                 :            : 
    2906                 :       1633 :           if (!seen_comps
    2907                 :       1633 :               && (!gfc_notify_std(GFC_STD_F2008, "Derived type definition "
    2908                 :            :                                   "at %C with empty CONTAINS section")))
    2909                 :          4 :             goto error;
    2910                 :            : 
    2911                 :            :           /* ST_END_TYPE is accepted by parse_derived after return.  */
    2912                 :            :           break;
    2913                 :            : 
    2914                 :         26 :         case ST_PRIVATE:
    2915                 :         26 :           if (!gfc_find_state (COMP_MODULE))
    2916                 :            :             {
    2917                 :          0 :               gfc_error ("PRIVATE statement in TYPE at %C must be inside "
    2918                 :            :                          "a MODULE");
    2919                 :          0 :               goto error;
    2920                 :            :             }
    2921                 :            : 
    2922                 :         26 :           if (seen_comps)
    2923                 :            :             {
    2924                 :          1 :               gfc_error ("PRIVATE statement at %C must precede procedure"
    2925                 :            :                          " bindings");
    2926                 :          1 :               goto error;
    2927                 :            :             }
    2928                 :            : 
    2929                 :         25 :           if (seen_private)
    2930                 :            :             {
    2931                 :          0 :               gfc_error ("Duplicate PRIVATE statement at %C");
    2932                 :          0 :               goto error;
    2933                 :            :             }
    2934                 :            : 
    2935                 :         25 :           accept_statement (ST_PRIVATE);
    2936                 :         25 :           gfc_typebound_default_access = ACCESS_PRIVATE;
    2937                 :         25 :           seen_private = true;
    2938                 :         25 :           break;
    2939                 :            : 
    2940                 :          0 :         case ST_SEQUENCE:
    2941                 :          0 :           gfc_error ("SEQUENCE statement at %C must precede CONTAINS");
    2942                 :          0 :           goto error;
    2943                 :            : 
    2944                 :          1 :         case ST_CONTAINS:
    2945                 :          1 :           gfc_error ("Already inside a CONTAINS block at %C");
    2946                 :          1 :           goto error;
    2947                 :            : 
    2948                 :          0 :         default:
    2949                 :          0 :           unexpected_statement (st);
    2950                 :          0 :           break;
    2951                 :            :         }
    2952                 :            : 
    2953                 :       5158 :       continue;
    2954                 :            : 
    2955                 :          8 : error:
    2956                 :          8 :       error_flag = true;
    2957                 :          8 :       reject_statement ();
    2958                 :       5158 :     }
    2959                 :            : 
    2960                 :       1633 :   pop_state ();
    2961                 :       1633 :   gcc_assert (gfc_current_state () == COMP_DERIVED);
    2962                 :            : 
    2963                 :       1633 :   return error_flag;
    2964                 :            : }
    2965                 :            : 
    2966                 :            : 
    2967                 :            : /* Set attributes for the parent symbol based on the attributes of a component
    2968                 :            :    and raise errors if conflicting attributes are found for the component.  */
    2969                 :            : 
    2970                 :            : static void
    2971                 :      15095 : check_component (gfc_symbol *sym, gfc_component *c, gfc_component **lockp,
    2972                 :            :     gfc_component **eventp)
    2973                 :            : {
    2974                 :      15095 :   bool coarray, lock_type, event_type, allocatable, pointer;
    2975                 :      15095 :   coarray = lock_type = event_type = allocatable = pointer = false;
    2976                 :      15095 :   gfc_component *lock_comp = NULL, *event_comp = NULL;
    2977                 :            : 
    2978                 :      15095 :   if (lockp) lock_comp = *lockp;
    2979                 :      15095 :   if (eventp) event_comp = *eventp;
    2980                 :            : 
    2981                 :            :   /* Look for allocatable components.  */
    2982                 :      15095 :   if (c->attr.allocatable
    2983                 :      12952 :       || (c->ts.type == BT_CLASS && c->attr.class_ok
    2984                 :      15692 :           && CLASS_DATA (c)->attr.allocatable)
    2985                 :      12601 :       || (c->ts.type == BT_DERIVED && !c->attr.pointer
    2986                 :       2374 :           && c->ts.u.derived->attr.alloc_comp))
    2987                 :            :     {
    2988                 :       2853 :       allocatable = true;
    2989                 :       2853 :       sym->attr.alloc_comp = 1;
    2990                 :            :     }
    2991                 :            : 
    2992                 :            :   /* Look for pointer components.  */
    2993                 :      15095 :   if (c->attr.pointer
    2994                 :      14208 :       || (c->ts.type == BT_CLASS && c->attr.class_ok
    2995                 :      15692 :           && CLASS_DATA (c)->attr.class_pointer)
    2996                 :      13962 :       || (c->ts.type == BT_DERIVED && c->ts.u.derived->attr.pointer_comp))
    2997                 :            :     {
    2998                 :       1294 :       pointer = true;
    2999                 :       1294 :       sym->attr.pointer_comp = 1;
    3000                 :            :     }
    3001                 :            : 
    3002                 :            :   /* Look for procedure pointer components.  */
    3003                 :      15095 :   if (c->attr.proc_pointer
    3004                 :      14724 :       || (c->ts.type == BT_DERIVED
    3005                 :      18378 :           && c->ts.u.derived->attr.proc_pointer_comp))
    3006                 :        448 :     sym->attr.proc_pointer_comp = 1;
    3007                 :            : 
    3008                 :            :   /* Looking for coarray components.  */
    3009                 :      15095 :   if (c->attr.codimension
    3010                 :      15029 :       || (c->ts.type == BT_CLASS && c->attr.class_ok
    3011                 :      15692 :           && CLASS_DATA (c)->attr.codimension))
    3012                 :            :     {
    3013                 :         87 :       coarray = true;
    3014                 :         87 :       sym->attr.coarray_comp = 1;
    3015                 :            :     }
    3016                 :            : 
    3017                 :      15095 :   if (c->ts.type == BT_DERIVED && c->ts.u.derived->attr.coarray_comp
    3018                 :         10 :       && !c->attr.pointer)
    3019                 :            :     {
    3020                 :          9 :       coarray = true;
    3021                 :          9 :       sym->attr.coarray_comp = 1;
    3022                 :            :     }
    3023                 :            : 
    3024                 :            :   /* Looking for lock_type components.  */
    3025                 :      15095 :   if ((c->ts.type == BT_DERIVED
    3026                 :       3290 :           && c->ts.u.derived->from_intmod == INTMOD_ISO_FORTRAN_ENV
    3027                 :       3290 :           && c->ts.u.derived->intmod_sym_id == ISOFORTRAN_LOCK_TYPE)
    3028                 :      15076 :       || (c->ts.type == BT_CLASS && c->attr.class_ok
    3029                 :        597 :           && CLASS_DATA (c)->ts.u.derived->from_intmod
    3030                 :            :              == INTMOD_ISO_FORTRAN_ENV
    3031                 :        597 :           && CLASS_DATA (c)->ts.u.derived->intmod_sym_id
    3032                 :            :              == ISOFORTRAN_LOCK_TYPE)
    3033                 :      15076 :       || (c->ts.type == BT_DERIVED && c->ts.u.derived->attr.lock_comp
    3034                 :          6 :           && !allocatable && !pointer))
    3035                 :            :     {
    3036                 :         22 :       lock_type = 1;
    3037                 :         22 :       lock_comp = c;
    3038                 :         22 :       sym->attr.lock_comp = 1;
    3039                 :            :     }
    3040                 :            : 
    3041                 :            :     /* Looking for event_type components.  */
    3042                 :      15095 :     if ((c->ts.type == BT_DERIVED
    3043                 :       3290 :             && c->ts.u.derived->from_intmod == INTMOD_ISO_FORTRAN_ENV
    3044                 :       3290 :             && c->ts.u.derived->intmod_sym_id == ISOFORTRAN_EVENT_TYPE)
    3045                 :      15095 :         || (c->ts.type == BT_CLASS && c->attr.class_ok
    3046                 :        597 :             && CLASS_DATA (c)->ts.u.derived->from_intmod
    3047                 :            :                == INTMOD_ISO_FORTRAN_ENV
    3048                 :        597 :             && CLASS_DATA (c)->ts.u.derived->intmod_sym_id
    3049                 :            :                == ISOFORTRAN_EVENT_TYPE)
    3050                 :      15095 :         || (c->ts.type == BT_DERIVED && c->ts.u.derived->attr.event_comp
    3051                 :          0 :             && !allocatable && !pointer))
    3052                 :            :       {
    3053                 :          0 :         event_type = 1;
    3054                 :          0 :         event_comp = c;
    3055                 :          0 :         sym->attr.event_comp = 1;
    3056                 :            :       }
    3057                 :            : 
    3058                 :            :   /* Check for F2008, C1302 - and recall that pointers may not be coarrays
    3059                 :            :      (5.3.14) and that subobjects of coarray are coarray themselves (2.4.7),
    3060                 :            :      unless there are nondirect [allocatable or pointer] components
    3061                 :            :      involved (cf. 1.3.33.1 and 1.3.33.3).  */
    3062                 :            : 
    3063                 :      15095 :   if (pointer && !coarray && lock_type)
    3064                 :          1 :     gfc_error ("Component %s at %L of type LOCK_TYPE must have a "
    3065                 :            :                "codimension or be a subcomponent of a coarray, "
    3066                 :            :                "which is not possible as the component has the "
    3067                 :            :                "pointer attribute", c->name, &c->loc);
    3068                 :      15094 :   else if (pointer && !coarray && c->ts.type == BT_DERIVED
    3069                 :        585 :            && c->ts.u.derived->attr.lock_comp)
    3070                 :          2 :     gfc_error ("Pointer component %s at %L has a noncoarray subcomponent "
    3071                 :            :                "of type LOCK_TYPE, which must have a codimension or be a "
    3072                 :            :                "subcomponent of a coarray", c->name, &c->loc);
    3073                 :            : 
    3074                 :      15095 :   if (lock_type && allocatable && !coarray)
    3075                 :          3 :     gfc_error ("Allocatable component %s at %L of type LOCK_TYPE must have "
    3076                 :            :                "a codimension", c->name, &c->loc);
    3077                 :      15092 :   else if (lock_type && allocatable && c->ts.type == BT_DERIVED
    3078                 :          5 :            && c->ts.u.derived->attr.lock_comp)
    3079                 :          0 :     gfc_error ("Allocatable component %s at %L must have a codimension as "
    3080                 :            :                "it has a noncoarray subcomponent of type LOCK_TYPE",
    3081                 :            :                c->name, &c->loc);
    3082                 :            : 
    3083                 :      15095 :   if (sym->attr.coarray_comp && !coarray && lock_type)
    3084                 :          1 :     gfc_error ("Noncoarray component %s at %L of type LOCK_TYPE or with "
    3085                 :            :                "subcomponent of type LOCK_TYPE must have a codimension or "
    3086                 :            :                "be a subcomponent of a coarray. (Variables of type %s may "
    3087                 :            :                "not have a codimension as already a coarray "
    3088                 :            :                "subcomponent exists)", c->name, &c->loc, sym->name);
    3089                 :            : 
    3090                 :      15095 :   if (sym->attr.lock_comp && coarray && !lock_type)
    3091                 :          1 :     gfc_error ("Noncoarray component %s at %L of type LOCK_TYPE or with "
    3092                 :            :                "subcomponent of type LOCK_TYPE must have a codimension or "
    3093                 :            :                "be a subcomponent of a coarray. (Variables of type %s may "
    3094                 :            :                "not have a codimension as %s at %L has a codimension or a "
    3095                 :            :                "coarray subcomponent)", lock_comp->name, &lock_comp->loc,
    3096                 :            :                sym->name, c->name, &c->loc);
    3097                 :            : 
    3098                 :            :   /* Similarly for EVENT TYPE.  */
    3099                 :            : 
    3100                 :      15095 :   if (pointer && !coarray && event_type)
    3101                 :          0 :     gfc_error ("Component %s at %L of type EVENT_TYPE must have a "
    3102                 :            :                "codimension or be a subcomponent of a coarray, "
    3103                 :            :                "which is not possible as the component has the "
    3104                 :            :                "pointer attribute", c->name, &c->loc);
    3105                 :      15095 :   else if (pointer && !coarray && c->ts.type == BT_DERIVED
    3106                 :        586 :            && c->ts.u.derived->attr.event_comp)
    3107                 :          0 :     gfc_error ("Pointer component %s at %L has a noncoarray subcomponent "
    3108                 :            :                "of type EVENT_TYPE, which must have a codimension or be a "
    3109                 :            :                "subcomponent of a coarray", c->name, &c->loc);
    3110                 :            : 
    3111                 :      15095 :   if (event_type && allocatable && !coarray)
    3112                 :          0 :     gfc_error ("Allocatable component %s at %L of type EVENT_TYPE must have "
    3113                 :            :                "a codimension", c->name, &c->loc);
    3114                 :      15095 :   else if (event_type && allocatable && c->ts.type == BT_DERIVED
    3115                 :          0 :            && c->ts.u.derived->attr.event_comp)
    3116                 :          0 :     gfc_error ("Allocatable component %s at %L must have a codimension as "
    3117                 :            :                "it has a noncoarray subcomponent of type EVENT_TYPE",
    3118                 :            :                c->name, &c->loc);
    3119                 :            : 
    3120                 :      15095 :   if (sym->attr.coarray_comp && !coarray && event_type)
    3121                 :          0 :     gfc_error ("Noncoarray component %s at %L of type EVENT_TYPE or with "
    3122                 :            :                "subcomponent of type EVENT_TYPE must have a codimension or "
    3123                 :            :                "be a subcomponent of a coarray. (Variables of type %s may "
    3124                 :            :                "not have a codimension as already a coarray "
    3125                 :            :                "subcomponent exists)", c->name, &c->loc, sym->name);
    3126                 :            : 
    3127                 :      15095 :   if (sym->attr.event_comp && coarray && !event_type)
    3128                 :          0 :     gfc_error ("Noncoarray component %s at %L of type EVENT_TYPE or with "
    3129                 :            :                "subcomponent of type EVENT_TYPE must have a codimension or "
    3130                 :            :                "be a subcomponent of a coarray. (Variables of type %s may "
    3131                 :            :                "not have a codimension as %s at %L has a codimension or a "
    3132                 :            :                "coarray subcomponent)", event_comp->name, &event_comp->loc,
    3133                 :            :                sym->name, c->name, &c->loc);
    3134                 :            : 
    3135                 :            :   /* Look for private components.  */
    3136                 :      15095 :   if (sym->component_access == ACCESS_PRIVATE
    3137                 :      14715 :       || c->attr.access == ACCESS_PRIVATE
    3138                 :      14620 :       || (c->ts.type == BT_DERIVED && c->ts.u.derived->attr.private_comp))
    3139                 :        724 :     sym->attr.private_comp = 1;
    3140                 :            : 
    3141                 :      15095 :   if (lockp) *lockp = lock_comp;
    3142                 :      15095 :   if (eventp) *eventp = event_comp;
    3143                 :      15095 : }
    3144                 :            : 
    3145                 :            : 
    3146                 :            : static void parse_struct_map (gfc_statement);
    3147                 :            : 
    3148                 :            : /* Parse a union component definition within a structure definition.  */
    3149                 :            : 
    3150                 :            : static void
    3151                 :        129 : parse_union (void)
    3152                 :            : {
    3153                 :        129 :   int compiling;
    3154                 :        129 :   gfc_statement st;
    3155                 :        129 :   gfc_state_data s;
    3156                 :        129 :   gfc_component *c, *lock_comp = NULL, *event_comp = NULL;
    3157                 :        129 :   gfc_symbol *un;
    3158                 :            : 
    3159                 :        129 :   accept_statement(ST_UNION);
    3160                 :        129 :   push_state (&s, COMP_UNION, gfc_new_block);
    3161                 :        129 :   un = gfc_new_block;
    3162                 :            : 
    3163                 :        129 :   compiling = 1;
    3164                 :            : 
    3165                 :        514 :   while (compiling)
    3166                 :            :     {
    3167                 :        385 :       st = next_statement ();
    3168                 :            :       /* Only MAP declarations valid within a union. */
    3169                 :        385 :       switch (st)
    3170                 :            :         {
    3171                 :          0 :         case ST_NONE:
    3172                 :          0 :           unexpected_eof ();
    3173                 :            : 
    3174                 :        254 :         case ST_MAP:
    3175                 :        254 :           accept_statement (ST_MAP);
    3176                 :        254 :           parse_struct_map (ST_MAP);
    3177                 :            :           /* Add a component to the union for each map. */
    3178                 :        254 :           if (!gfc_add_component (un, gfc_new_block->name, &c))
    3179                 :            :             {
    3180                 :          0 :               gfc_internal_error ("failed to create map component '%s'",
    3181                 :            :                   gfc_new_block->name);
    3182                 :            :               reject_statement ();
    3183                 :            :               return;
    3184                 :            :             }
    3185                 :        254 :           c->ts.type = BT_DERIVED;
    3186                 :        254 :           c->ts.u.derived = gfc_new_block;
    3187                 :            :           /* Normally components get their initialization expressions when they
    3188                 :            :              are created in decl.c (build_struct) so we can look through the
    3189                 :            :              flat component list for initializers during resolution. Unions and
    3190                 :            :              maps create components along with their type definitions so we
    3191                 :            :              have to generate initializers here. */
    3192                 :        254 :           c->initializer = gfc_default_initializer (&c->ts);
    3193                 :        254 :           break;
    3194                 :            : 
    3195                 :        129 :         case ST_END_UNION:
    3196                 :        129 :           compiling = 0;
    3197                 :        129 :           accept_statement (ST_END_UNION);
    3198                 :        129 :           break;
    3199                 :            : 
    3200                 :          2 :         default:
    3201                 :          2 :           unexpected_statement (st);
    3202                 :          2 :           break;
    3203                 :            :         }
    3204                 :            :     }
    3205                 :            : 
    3206                 :        383 :   for (c = un->components; c; c = c->next)
    3207                 :        254 :     check_component (un, c, &lock_comp, &event_comp);
    3208                 :            : 
    3209                 :            :   /* Add the union as a component in its parent structure.  */
    3210                 :        129 :   pop_state ();
    3211                 :        129 :   if (!gfc_add_component (gfc_current_block (), un->name, &c))
    3212                 :            :     {
    3213                 :          0 :       gfc_internal_error ("failed to create union component '%s'", un->name);
    3214                 :            :       reject_statement ();
    3215                 :            :       return;
    3216                 :            :     }
    3217                 :        129 :   c->ts.type = BT_UNION;
    3218                 :        129 :   c->ts.u.derived = un;
    3219                 :        129 :   c->initializer = gfc_default_initializer (&c->ts);
    3220                 :            : 
    3221                 :        129 :   un->attr.zero_comp = un->components == NULL;
    3222                 :            : }
    3223                 :            : 
    3224                 :            : 
    3225                 :            : /* Parse a STRUCTURE or MAP.  */
    3226                 :            : 
    3227                 :            : static void
    3228                 :        562 : parse_struct_map (gfc_statement block)
    3229                 :            : {
    3230                 :        562 :   int compiling_type;
    3231                 :        562 :   gfc_statement st;
    3232                 :        562 :   gfc_state_data s;
    3233                 :        562 :   gfc_symbol *sym;
    3234                 :        562 :   gfc_component *c, *lock_comp = NULL, *event_comp = NULL;
    3235                 :        562 :   gfc_compile_state comp;
    3236                 :        562 :   gfc_statement ends;
    3237                 :            : 
    3238                 :        562 :   if (block == ST_STRUCTURE_DECL)
    3239                 :            :     {
    3240                 :            :       comp = COMP_STRUCTURE;
    3241                 :            :       ends = ST_END_STRUCTURE;
    3242                 :            :     }
    3243                 :            :   else
    3244                 :            :     {
    3245                 :        254 :       gcc_assert (block == ST_MAP);
    3246                 :            :       comp = COMP_MAP;
    3247                 :            :       ends = ST_END_MAP;
    3248                 :            :     }
    3249                 :            : 
    3250                 :        562 :   accept_statement(block);
    3251                 :        562 :   push_state (&s, comp, gfc_new_block);
    3252                 :            : 
    3253                 :        562 :   gfc_new_block->component_access = ACCESS_PUBLIC;
    3254                 :        562 :   compiling_type = 1;
    3255                 :            : 
    3256                 :       2096 :   while (compiling_type)
    3257                 :            :     {
    3258                 :       1534 :       st = next_statement ();
    3259                 :       1534 :       switch (st)
    3260                 :            :         {
    3261                 :          0 :         case ST_NONE:
    3262                 :          0 :           unexpected_eof ();
    3263                 :            : 
    3264                 :            :         /* Nested structure declarations will be captured as ST_DATA_DECL.  */
    3265                 :          5 :         case ST_STRUCTURE_DECL:
    3266                 :            :           /* Let a more specific error make it to decode_statement().  */
    3267                 :          5 :           if (gfc_error_check () == 0)
    3268                 :          0 :             gfc_error ("Syntax error in nested structure declaration at %C");
    3269                 :          5 :           reject_statement ();
    3270                 :            :           /* Skip the rest of this statement.  */
    3271                 :          5 :           gfc_error_recovery ();
    3272                 :          5 :           break;
    3273                 :            : 
    3274                 :        129 :         case ST_UNION:
    3275                 :        129 :           accept_statement (ST_UNION);
    3276                 :        129 :           parse_union ();
    3277                 :        129 :           break;
    3278                 :            : 
    3279                 :        837 :         case ST_DATA_DECL:
    3280                 :            :           /* The data declaration was a nested/ad-hoc STRUCTURE field.  */
    3281                 :        837 :           accept_statement (ST_DATA_DECL);
    3282                 :        837 :           if (gfc_new_block && gfc_new_block != gfc_current_block ()
    3283                 :         21 :                             && gfc_new_block->attr.flavor == FL_STRUCT)
    3284                 :         21 :               parse_struct_map (ST_STRUCTURE_DECL);
    3285                 :            :           break;
    3286                 :            : 
    3287                 :        562 :         case ST_END_STRUCTURE:
    3288                 :        562 :         case ST_END_MAP:
    3289                 :        562 :           if (st == ends)
    3290                 :            :             {
    3291                 :        562 :               accept_statement (st);
    3292                 :        562 :               compiling_type = 0;
    3293                 :            :             }
    3294                 :            :           else
    3295                 :          0 :             unexpected_statement (st);
    3296                 :            :           break;
    3297                 :            : 
    3298                 :          1 :         default:
    3299                 :          1 :           unexpected_statement (st);
    3300                 :          1 :           break;
    3301                 :            :         }
    3302                 :            :     }
    3303                 :            : 
    3304                 :            :   /* Validate each component.  */
    3305                 :        562 :   sym = gfc_current_block ();
    3306                 :       1647 :   for (c = sym->components; c; c = c->next)
    3307                 :       1085 :     check_component (sym, c, &lock_comp, &event_comp);
    3308                 :            : 
    3309                 :        562 :   sym->attr.zero_comp = (sym->components == NULL);
    3310                 :            : 
    3311                 :            :   /* Allow parse_union to find this structure to add to its list of maps.  */
    3312                 :        562 :   if (block == ST_MAP)
    3313                 :        254 :     gfc_new_block = gfc_current_block ();
    3314                 :            : 
    3315                 :        562 :   pop_state ();
    3316                 :        562 : }
    3317                 :            : 
    3318                 :            : 
    3319                 :            : /* Parse a derived type.  */
    3320                 :            : 
    3321                 :            : static void
    3322                 :       9468 : parse_derived (void)
    3323                 :            : {
    3324                 :       9468 :   int compiling_type, seen_private, seen_sequence, seen_component;
    3325                 :       9468 :   gfc_statement st;
    3326                 :       9468 :   gfc_state_data s;
    3327                 :       9468 :   gfc_symbol *sym;
    3328                 :       9468 :   gfc_component *c, *lock_comp = NULL, *event_comp = NULL;
    3329                 :            : 
    3330                 :       9468 :   accept_statement (ST_DERIVED_DECL);
    3331                 :       9468 :   push_state (&s, COMP_DERIVED, gfc_new_block);
    3332                 :            : 
    3333                 :       9468 :   gfc_new_block->component_access = ACCESS_PUBLIC;
    3334                 :       9468 :   seen_private = 0;
    3335                 :       9468 :   seen_sequence = 0;
    3336                 :       9468 :   seen_component = 0;
    3337                 :            : 
    3338                 :       9468 :   compiling_type = 1;
    3339                 :            : 
    3340                 :      31417 :   while (compiling_type)
    3341                 :            :     {
    3342                 :      21949 :       st = next_statement ();
    3343                 :      21949 :       switch (st)
    3344                 :            :         {
    3345                 :          0 :         case ST_NONE:
    3346                 :          0 :           unexpected_eof ();
    3347                 :            : 
    3348                 :      11990 :         case ST_DATA_DECL:
    3349                 :      11990 :         case ST_PROCEDURE:
    3350                 :      11990 :           accept_statement (st);
    3351                 :      11990 :           seen_component = 1;
    3352                 :      11990 :           break;
    3353                 :            : 
    3354                 :          0 :         case ST_FINAL:
    3355                 :          0 :           gfc_error ("FINAL declaration at %C must be inside CONTAINS");
    3356                 :          0 :           break;
    3357                 :            : 
    3358                 :       9468 :         case ST_END_TYPE:
    3359                 :       9468 : endType:
    3360                 :       9468 :           compiling_type = 0;
    3361                 :            : 
    3362                 :       9468 :           if (!seen_component)
    3363                 :       1217 :             gfc_notify_std (GFC_STD_F2003, "Derived type "
    3364                 :            :                             "definition at %C without components");
    3365                 :            : 
    3366                 :       9468 :           accept_statement (ST_END_TYPE);
    3367                 :       9468 :           break;
    3368                 :            : 
    3369                 :        248 :         case ST_PRIVATE:
    3370                 :        248 :           if (!gfc_find_state (COMP_MODULE))
    3371                 :            :             {
    3372                 :          0 :               gfc_error ("PRIVATE statement in TYPE at %C must be inside "
    3373                 :            :                          "a MODULE");
    3374                 :          0 :               break;
    3375                 :            :             }
    3376                 :            : 
    3377                 :        248 :           if (seen_component)
    3378                 :            :             {
    3379                 :          0 :               gfc_error ("PRIVATE statement at %C must precede "
    3380                 :            :                          "structure components");
    3381                 :          0 :               break;
    3382                 :            :             }
    3383                 :            : 
    3384                 :        248 :           if (seen_private)
    3385                 :          0 :             gfc_error ("Duplicate PRIVATE statement at %C");
    3386                 :            : 
    3387                 :        248 :           s.sym->component_access = ACCESS_PRIVATE;
    3388                 :            : 
    3389                 :        248 :           accept_statement (ST_PRIVATE);
    3390                 :        248 :           seen_private = 1;
    3391                 :        248 :           break;
    3392                 :            : 
    3393                 :        243 :         case ST_SEQUENCE:
    3394                 :        243 :           if (seen_component)
    3395                 :            :             {
    3396                 :          0 :               gfc_error ("SEQUENCE statement at %C must precede "
    3397                 :            :                          "structure components");
    3398                 :          0 :               break;
    3399                 :            :             }
    3400                 :            : 
    3401                 :        243 :           if (gfc_current_block ()->attr.sequence)
    3402                 :          0 :             gfc_warning (0, "SEQUENCE attribute at %C already specified in "
    3403                 :            :                          "TYPE statement");
    3404                 :            : 
    3405                 :        243 :           if (seen_sequence)
    3406                 :            :             {
    3407                 :          0 :               gfc_error ("Duplicate SEQUENCE statement at %C");
    3408                 :            :             }
    3409                 :            : 
    3410                 :        243 :           seen_sequence = 1;
    3411                 :        243 :           gfc_add_sequence (&gfc_current_block ()->attr,
    3412                 :        243 :                             gfc_current_block ()->name, NULL);
    3413                 :        243 :           break;
    3414                 :            : 
    3415                 :       1633 :         case ST_CONTAINS:
    3416                 :       1633 :           gfc_notify_std (GFC_STD_F2003,
    3417                 :            :                           "CONTAINS block in derived type"
    3418                 :            :                           " definition at %C");
    3419                 :            : 
    3420                 :       1633 :           accept_statement (ST_CONTAINS);
    3421                 :       1633 :           parse_derived_contains ();
    3422                 :       1633 :           goto endType;
    3423                 :            : 
    3424                 :          0 :         default:
    3425                 :          0 :           unexpected_statement (st);
    3426                 :          0 :           break;
    3427                 :            :         }
    3428                 :            :     }
    3429                 :            : 
    3430                 :            :   /* need to verify that all fields of the derived type are
    3431                 :            :    * interoperable with C if the type is declared to be bind(c)
    3432                 :            :    */
    3433                 :       9468 :   sym = gfc_current_block ();
    3434                 :      23224 :   for (c = sym->components; c; c = c->next)
    3435                 :      13756 :     check_component (sym, c, &lock_comp, &event_comp);
    3436                 :            : 
    3437                 :       9468 :   if (!seen_component)
    3438                 :       1217 :     sym->attr.zero_comp = 1;
    3439                 :            : 
    3440                 :       9468 :   pop_state ();
    3441                 :       9468 : }
    3442                 :            : 
    3443                 :            : 
    3444                 :            : /* Parse an ENUM.  */
    3445                 :            : 
    3446                 :            : static void
    3447                 :        156 : parse_enum (void)
    3448                 :            : {
    3449                 :        156 :   gfc_statement st;
    3450                 :        156 :   int compiling_enum;
    3451                 :        156 :   gfc_state_data s;
    3452                 :        156 :   int seen_enumerator = 0;
    3453                 :            : 
    3454                 :        156 :   push_state (&s, COMP_ENUM, gfc_new_block);
    3455                 :            : 
    3456                 :        156 :   compiling_enum = 1;
    3457                 :            : 
    3458                 :        570 :   while (compiling_enum)
    3459                 :            :     {
    3460                 :        416 :       st = next_statement ();
    3461                 :        416 :       switch (st)
    3462                 :            :         {
    3463                 :          2 :         case ST_NONE:
    3464                 :          2 :           unexpected_eof ();
    3465                 :        256 :           break;
    3466                 :            : 
    3467                 :        256 :         case ST_ENUMERATOR:
    3468                 :        256 :           seen_enumerator = 1;
    3469                 :        256 :           accept_statement (st);
    3470                 :        256 :           break;
    3471                 :            : 
    3472                 :        154 :         case ST_END_ENUM:
    3473                 :        154 :           compiling_enum = 0;
    3474                 :        154 :           if (!seen_enumerator)
    3475                 :          3 :             gfc_error ("ENUM declaration at %C has no ENUMERATORS");
    3476                 :        154 :           accept_statement (st);
    3477                 :        154 :           break;
    3478                 :            : 
    3479                 :          4 :         default:
    3480                 :          4 :           gfc_free_enum_history ();
    3481                 :          4 :           unexpected_statement (st);
    3482                 :          4 :           break;
    3483                 :            :         }
    3484                 :            :     }
    3485                 :        154 :   pop_state ();
    3486                 :        154 : }
    3487                 :            : 
    3488                 :            : 
    3489                 :            : /* Parse an interface.  We must be able to deal with the possibility
    3490                 :            :    of recursive interfaces.  The parse_spec() subroutine is mutually
    3491                 :            :    recursive with parse_interface().  */
    3492                 :            : 
    3493                 :            : static gfc_statement parse_spec (gfc_statement);
    3494                 :            : 
    3495                 :            : static void
    3496                 :       6174 : parse_interface (void)
    3497                 :            : {
    3498                 :       6174 :   gfc_compile_state new_state = COMP_NONE, current_state;
    3499                 :       6174 :   gfc_symbol *prog_unit, *sym;
    3500                 :       6174 :   gfc_interface_info save;
    3501                 :       6174 :   gfc_state_data s1, s2;
    3502                 :       6174 :   gfc_statement st;
    3503                 :            : 
    3504                 :       6174 :   accept_statement (ST_INTERFACE);
    3505                 :            : 
    3506                 :       6174 :   current_interface.ns = gfc_current_ns;
    3507                 :       6174 :   save = current_interface;
    3508                 :            : 
    3509                 :      12348 :   sym = (current_interface.type == INTERFACE_GENERIC
    3510                 :       6174 :          || current_interface.type == INTERFACE_USER_OP)
    3511                 :       6174 :         ? gfc_new_block : NULL;
    3512                 :            : 
    3513                 :       6174 :   push_state (&s1, COMP_INTERFACE, sym);
    3514                 :       6174 :   current_state = COMP_NONE;
    3515                 :            : 
    3516                 :      16708 : loop:
    3517                 :      16708 :   gfc_current_ns = gfc_get_namespace (current_interface.ns, 0);
    3518                 :            : 
    3519                 :      16708 :   st = next_statement ();
    3520                 :      16708 :   switch (st)
    3521                 :            :     {
    3522                 :          2 :     case ST_NONE:
    3523                 :          2 :       unexpected_eof ();
    3524                 :            : 
    3525                 :       7985 :     case ST_SUBROUTINE:
    3526                 :       7985 :     case ST_FUNCTION:
    3527                 :       7985 :       if (st == ST_SUBROUTINE)
    3528                 :            :         new_state = COMP_SUBROUTINE;
    3529                 :       2930 :       else if (st == ST_FUNCTION)
    3530                 :       2930 :         new_state = COMP_FUNCTION;
    3531                 :       7985 :       if (gfc_new_block->attr.pointer)
    3532                 :            :         {
    3533                 :         31 :           gfc_new_block->attr.pointer = 0;
    3534                 :         31 :           gfc_new_block->attr.proc_pointer = 1;
    3535                 :            :         }
    3536                 :       7985 :       if (!gfc_add_explicit_interface (gfc_new_block, IFSRC_IFBODY,
    3537                 :            :                                        gfc_new_block->formal, NULL))
    3538                 :            :         {
    3539                 :          2 :           reject_statement ();
    3540                 :          2 :           gfc_free_namespace (gfc_current_ns);
    3541                 :          2 :           goto loop;
    3542                 :            :         }
    3543                 :            :       /* F2008 C1210 forbids the IMPORT statement in module procedure
    3544                 :            :          interface bodies and the flag is set to import symbols.  */
    3545                 :       7983 :       if (gfc_new_block->attr.module_procedure)
    3546                 :        297 :         gfc_current_ns->has_import_set = 1;
    3547                 :       7983 :       break;
    3548                 :            : 
    3549                 :       2547 :     case ST_PROCEDURE:
    3550                 :       2547 :     case ST_MODULE_PROC:        /* The module procedure matcher makes
    3551                 :            :                                    sure the context is correct.  */
    3552                 :       2547 :       accept_statement (st);
    3553                 :       2547 :       gfc_free_namespace (gfc_current_ns);
    3554                 :       2547 :       goto loop;
    3555                 :            : 
    3556                 :       6171 :     case ST_END_INTERFACE:
    3557                 :       6171 :       gfc_free_namespace (gfc_current_ns);
    3558                 :       6171 :       gfc_current_ns = current_interface.ns;
    3559                 :       6171 :       goto done;
    3560                 :            : 
    3561                 :          3 :     default:
    3562                 :          3 :       gfc_error ("Unexpected %s statement in INTERFACE block at %C",
    3563                 :            :                  gfc_ascii_statement (st));
    3564                 :          3 :       reject_statement ();
    3565                 :          3 :       gfc_free_namespace (gfc_current_ns);
    3566                 :          3 :       goto loop;
    3567                 :            :     }
    3568                 :            : 
    3569                 :            : 
    3570                 :            :   /* Make sure that the generic name has the right attribute.  */
    3571                 :       7983 :   if (current_interface.type == INTERFACE_GENERIC
    3572                 :       4263 :       && current_state == COMP_NONE)
    3573                 :            :     {
    3574                 :       2152 :       if (new_state == COMP_FUNCTION && sym)
    3575                 :        541 :         gfc_add_function (&sym->attr, sym->name, NULL);
    3576                 :       1611 :       else if (new_state == COMP_SUBROUTINE && sym)
    3577                 :       1610 :         gfc_add_subroutine (&sym->attr, sym->name, NULL);
    3578                 :            : 
    3579                 :            :       current_state = new_state;
    3580                 :            :     }
    3581                 :            : 
    3582                 :       7983 :   if (current_interface.type == INTERFACE_ABSTRACT)
    3583                 :            :     {
    3584                 :        410 :       gfc_add_abstract (&gfc_new_block->attr, &gfc_current_locus);
    3585                 :        410 :       if (gfc_is_intrinsic_typename (gfc_new_block->name))
    3586                 :          1 :         gfc_error ("Name %qs of ABSTRACT INTERFACE at %C "
    3587                 :            :                    "cannot be the same as an intrinsic type",
    3588                 :            :                    gfc_new_block->name);
    3589                 :            :     }
    3590                 :            : 
    3591                 :       7983 :   push_state (&s2, new_state, gfc_new_block);
    3592                 :       7983 :   accept_statement (st);
    3593                 :       7983 :   prog_unit = gfc_new_block;
    3594                 :       7983 :   prog_unit->formal_ns = gfc_current_ns;
    3595                 :       7983 :   if (prog_unit == prog_unit->formal_ns->proc_name
    3596                 :       7983 :       && prog_unit->ns != prog_unit->formal_ns)
    3597                 :       7983 :     prog_unit->refs++;
    3598                 :            : 
    3599                 :          0 : decl:
    3600                 :            :   /* Read data declaration statements.  */
    3601                 :       7984 :   st = parse_spec (ST_NONE);
    3602                 :       7983 :   in_specification_block = true;
    3603                 :            : 
    3604                 :            :   /* Since the interface block does not permit an IMPLICIT statement,
    3605                 :            :      the default type for the function or the result must be taken
    3606                 :            :      from the formal namespace.  */
    3607                 :       7983 :   if (new_state == COMP_FUNCTION)
    3608                 :            :     {
    3609                 :       2928 :         if (prog_unit->result == prog_unit
    3610                 :       2567 :               && prog_unit->ts.type == BT_UNKNOWN)
    3611                 :         38 :           gfc_set_default_type (prog_unit, 1, prog_unit->formal_ns);
    3612                 :       2890 :         else if (prog_unit->result != prog_unit
    3613                 :        361 :                    && prog_unit->result->ts.type == BT_UNKNOWN)
    3614                 :          9 :           gfc_set_default_type (prog_unit->result, 1,
    3615                 :            :                                 prog_unit->formal_ns);
    3616                 :            :     }
    3617                 :            : 
    3618                 :       7983 :   if (st != ST_END_SUBROUTINE && st != ST_END_FUNCTION)
    3619                 :            :     {
    3620                 :          1 :       gfc_error ("Unexpected %s statement at %C in INTERFACE body",
    3621                 :            :                  gfc_ascii_statement (st));
    3622                 :          1 :       reject_statement ();
    3623                 :          1 :       goto decl;
    3624                 :            :     }
    3625                 :            : 
    3626                 :            :   /* Add EXTERNAL attribute to function or subroutine.  */
    3627                 :       7982 :   if (current_interface.type != INTERFACE_ABSTRACT && !prog_unit->attr.dummy)
    3628                 :       7359 :     gfc_add_external (&prog_unit->attr, &gfc_current_locus);
    3629                 :            : 
    3630                 :       7982 :   current_interface = save;
    3631                 :       7982 :   gfc_add_interface (prog_unit);
    3632                 :       7982 :   pop_state ();
    3633                 :            : 
    3634                 :       7982 :   if (current_interface.ns
    3635                 :       7982 :         && current_interface.ns->proc_name
    3636                 :       7982 :         && strcmp (current_interface.ns->proc_name->name,
    3637                 :            :                    prog_unit->name) == 0)
    3638                 :          1 :     gfc_error ("INTERFACE procedure %qs at %L has the same name as the "
    3639                 :            :                "enclosing procedure", prog_unit->name,
    3640                 :            :                &current_interface.ns->proc_name->declared_at);
    3641                 :            : 
    3642                 :       7982 :   goto loop;
    3643                 :            : 
    3644                 :       6171 : done:
    3645                 :       6171 :   pop_state ();
    3646                 :       6171 : }
    3647                 :            : 
    3648                 :            : 
    3649                 :            : /* Associate function characteristics by going back to the function
    3650                 :            :    declaration and rematching the prefix.  */
    3651                 :            : 
    3652                 :            : static match
    3653                 :       3761 : match_deferred_characteristics (gfc_typespec * ts)
    3654                 :            : {
    3655                 :       3761 :   locus loc;
    3656                 :       3761 :   match m = MATCH_ERROR;
    3657                 :       3761 :   char name[GFC_MAX_SYMBOL_LEN + 1];
    3658                 :            : 
    3659                 :       3761 :   loc = gfc_current_locus;
    3660                 :            : 
    3661                 :       3761 :   gfc_current_locus = gfc_current_block ()->declared_at;
    3662                 :            : 
    3663                 :       3761 :   gfc_clear_error ();
    3664                 :       3761 :   gfc_buffer_error (true);
    3665                 :       3761 :   m = gfc_match_prefix (ts);
    3666                 :       3761 :   gfc_buffer_error (false);
    3667                 :            : 
    3668                 :       3761 :   if (ts->type == BT_DERIVED)
    3669                 :            :     {
    3670                 :        229 :       ts->kind = 0;
    3671                 :            : 
    3672                 :        229 :       if (!ts->u.derived)
    3673                 :          8 :         m = MATCH_ERROR;
    3674                 :            :     }
    3675                 :            : 
    3676                 :            :   /* Only permit one go at the characteristic association.  */
    3677                 :       3761 :   if (ts->kind == -1)
    3678                 :          1 :     ts->kind = 0;
    3679                 :            : 
    3680                 :            :   /* Set the function locus correctly.  If we have not found the
    3681                 :            :      function name, there is an error.  */
    3682                 :       3761 :   if (m == MATCH_YES
    3683                 :       3751 :       && gfc_match ("function% %n", name) == MATCH_YES
    3684                 :       7510 :       && strcmp (name, gfc_current_block ()->name) == 0)
    3685                 :            :     {
    3686                 :       3736 :       gfc_current_block ()->declared_at = gfc_current_locus;
    3687                 :       3736 :       gfc_commit_symbols ();
    3688                 :            :     }
    3689                 :            :   else
    3690                 :            :     {
    3691                 :         25 :       gfc_error_check ();
    3692                 :         25 :       gfc_undo_symbols ();
    3693                 :            :     }
    3694                 :            : 
    3695                 :       3761 :   gfc_current_locus =loc;
    3696                 :       3761 :   return m;
    3697                 :            : }
    3698                 :            : 
    3699                 :            : 
    3700                 :            : /* Check specification-expressions in the function result of the currently
    3701                 :            :    parsed block and ensure they are typed (give an IMPLICIT type if necessary).
    3702                 :            :    For return types specified in a FUNCTION prefix, the IMPLICIT rules of the
    3703                 :            :    scope are not yet parsed so this has to be delayed up to parse_spec.  */
    3704                 :            : 
    3705                 :            : static void
    3706                 :       6987 : check_function_result_typed (void)
    3707                 :            : {
    3708                 :       6987 :   gfc_typespec ts;
    3709                 :            : 
    3710                 :       6987 :   gcc_assert (gfc_current_state () == COMP_FUNCTION);
    3711                 :            : 
    3712                 :       6987 :   if (!gfc_current_ns->proc_name->result) return;
    3713                 :            : 
    3714                 :       6987 :   ts = gfc_current_ns->proc_name->result->ts;
    3715                 :            : 
    3716                 :            :   /* Check type-parameters, at the moment only CHARACTER lengths possible.  */
    3717                 :            :   /* TODO:  Extend when KIND type parameters are implemented.  */
    3718                 :       6987 :   if (ts.type == BT_CHARACTER && ts.u.cl && ts.u.cl->length)
    3719                 :        323 :     gfc_expr_check_typed (ts.u.cl->length, gfc_current_ns, true);
    3720                 :            : }
    3721                 :            : 
    3722                 :            : 
    3723                 :            : /* Parse a set of specification statements.  Returns the statement
    3724                 :            :    that doesn't fit.  */
    3725                 :            : 
    3726                 :            : static gfc_statement
    3727                 :      69563 : parse_spec (gfc_statement st)
    3728                 :            : {
    3729                 :      69563 :   st_state ss;
    3730                 :      69563 :   bool function_result_typed = false;
    3731                 :      69563 :   bool bad_characteristic = false;
    3732                 :      69563 :   gfc_typespec *ts;
    3733                 :            : 
    3734                 :      69563 :   in_specification_block = true;
    3735                 :            : 
    3736                 :      69563 :   verify_st_order (&ss, ST_NONE, false);
    3737                 :      69563 :   if (st == ST_NONE)
    3738                 :      61925 :     st = next_statement ();
    3739                 :            : 
    3740                 :            :   /* If we are not inside a function or don't have a result specified so far,
    3741                 :            :      do nothing special about it.  */
    3742                 :      69563 :   if (gfc_current_state () != COMP_FUNCTION)
    3743                 :            :     function_result_typed = true;
    3744                 :            :   else
    3745                 :            :     {
    3746                 :      12890 :       gfc_symbol* proc = gfc_current_ns->proc_name;
    3747                 :      12890 :       gcc_assert (proc);
    3748                 :            : 
    3749                 :      12890 :       if (proc->result->ts.type == BT_UNKNOWN)
    3750                 :       5899 :         function_result_typed = true;
    3751                 :            :     }
    3752                 :            : 
    3753                 :       6991 : loop:
    3754                 :            : 
    3755                 :            :   /* If we're inside a BLOCK construct, some statements are disallowed.
    3756                 :            :      Check this here.  Attribute declaration statements like INTENT, OPTIONAL
    3757                 :            :      or VALUE are also disallowed, but they don't have a particular ST_*
    3758                 :            :      key so we have to check for them individually in their matcher routine.  */
    3759                 :     268440 :   if (gfc_current_state () == COMP_BLOCK)
    3760                 :        986 :     switch (st)
    3761                 :            :       {
    3762                 :          5 :         case ST_IMPLICIT:
    3763                 :          5 :         case ST_IMPLICIT_NONE:
    3764                 :          5 :         case ST_NAMELIST:
    3765                 :          5 :         case ST_COMMON:
    3766                 :          5 :         case ST_EQUIVALENCE:
    3767                 :          5 :         case ST_STATEMENT_FUNCTION:
    3768                 :          5 :           gfc_error ("%s statement is not allowed inside of BLOCK at %C",
    3769                 :            :                      gfc_ascii_statement (st));
    3770                 :          5 :           reject_statement ();
    3771                 :          5 :           break;
    3772                 :            : 
    3773                 :            :         default:
    3774                 :            :           break;
    3775                 :            :       }
    3776                 :     267454 :   else if (gfc_current_state () == COMP_BLOCK_DATA)
    3777                 :            :     /* Fortran 2008, C1116.  */
    3778                 :        326 :     switch (st)
    3779                 :            :       {
    3780                 :            :         case ST_ATTR_DECL:
    3781                 :            :         case ST_COMMON:
    3782                 :            :         case ST_DATA:
    3783                 :            :         case ST_DATA_DECL:
    3784                 :            :         case ST_DERIVED_DECL:
    3785                 :            :         case ST_END_BLOCK_DATA:
    3786                 :            :         case ST_EQUIVALENCE:
    3787                 :            :         case ST_IMPLICIT:
    3788                 :            :         case ST_IMPLICIT_NONE:
    3789                 :            :         case ST_OMP_THREADPRIVATE:
    3790                 :            :         case ST_PARAMETER:
    3791                 :            :         case ST_STRUCTURE_DECL:
    3792                 :            :         case ST_TYPE:
    3793                 :            :         case ST_USE:
    3794                 :            :           break;
    3795                 :            : 
    3796                 :            :         case ST_NONE:
    3797                 :            :           break;
    3798                 :            : 
    3799                 :          5 :         default:
    3800                 :          5 :           gfc_error ("%s statement is not allowed inside of BLOCK DATA at %C",
    3801                 :            :                      gfc_ascii_statement (st));
    3802                 :          5 :           reject_statement ();
    3803                 :          5 :           break;
    3804                 :            :       }
    3805                 :            : 
    3806                 :            :   /* If we find a statement that cannot be followed by an IMPLICIT statement
    3807                 :            :      (and thus we can expect to see none any further), type the function result
    3808                 :            :      if it has not yet been typed.  Be careful not to give the END statement
    3809                 :            :      to verify_st_order!  */
    3810                 :     268440 :   if (!function_result_typed && st != ST_GET_FCN_CHARACTERISTICS)
    3811                 :            :     {
    3812                 :       7278 :       bool verify_now = false;
    3813                 :            : 
    3814                 :       7278 :       if (st == ST_END_FUNCTION || st == ST_CONTAINS)
    3815                 :            :         verify_now = true;
    3816                 :            :       else
    3817                 :            :         {
    3818                 :       7104 :           st_state dummyss;
    3819                 :       7104 :           verify_st_order (&dummyss, ST_NONE, false);
    3820                 :       7104 :           verify_st_order (&dummyss, st, false);
    3821                 :            : 
    3822                 :       7104 :           if (!verify_st_order (&dummyss, ST_IMPLICIT, true))
    3823                 :       6323 :             verify_now = true;
    3824                 :            :         }
    3825                 :            : 
    3826                 :       7104 :       if (verify_now)
    3827                 :            :         {
    3828                 :       6497 :           check_function_result_typed ();
    3829                 :       6497 :           function_result_typed = true;
    3830                 :            :         }
    3831                 :            :     }
    3832                 :            : 
    3833                 :     268440 :   switch (st)
    3834                 :            :     {
    3835                 :         11 :     case ST_NONE:
    3836                 :         11 :       unexpected_eof ();
    3837                 :            : 
    3838                 :      16527 :     case ST_IMPLICIT_NONE:
    3839                 :      16527 :     case ST_IMPLICIT:
    3840                 :      16527 :       if (!function_result_typed)
    3841                 :            :         {
    3842                 :        490 :           check_function_result_typed ();
    3843                 :        490 :           function_result_typed = true;
    3844                 :            :         }
    3845                 :      16527 :       goto declSt;
    3846                 :            : 
    3847                 :       2705 :     case ST_FORMAT:
    3848                 :       2705 :     case ST_ENTRY:
    3849                 :       2705 :     case ST_DATA:       /* Not allowed in interfaces */
    3850                 :       2705 :       if (gfc_current_state () == COMP_INTERFACE)
    3851                 :            :         break;
    3852                 :            : 
    3853                 :            :       /* Fall through */
    3854                 :            : 
    3855                 :     194968 :     case ST_USE:
    3856                 :     194968 :     case ST_IMPORT:
    3857                 :     194968 :     case ST_PARAMETER:
    3858                 :     194968 :     case ST_PUBLIC:
    3859                 :     194968 :     case ST_PRIVATE:
    3860                 :     194968 :     case ST_STRUCTURE_DECL:
    3861                 :     194968 :     case ST_DERIVED_DECL:
    3862                 :     194968 :     case_decl:
    3863                 :     194968 :     case_omp_decl:
    3864                 :       2705 : declSt:
    3865                 :     194968 :       if (!verify_st_order (&ss, st, false))
    3866                 :            :         {
    3867                 :          1 :           reject_statement ();
    3868                 :          1 :           st = next_statement ();
    3869                 :          1 :           goto loop;
    3870                 :            :         }
    3871                 :            : 
    3872                 :     194967 :       switch (st)
    3873                 :            :         {
    3874                 :       6174 :         case ST_INTERFACE:
    3875                 :       6174 :           parse_interface ();
    3876                 :       6174 :           break;
    3877                 :            : 
    3878                 :        287 :         case ST_STRUCTURE_DECL:
    3879                 :        287 :           parse_struct_map (ST_STRUCTURE_DECL);
    3880                 :        287 :           break;
    3881                 :            : 
    3882                 :       9468 :         case ST_DERIVED_DECL:
    3883                 :       9468 :           parse_derived ();
    3884                 :       9468 :           break;
    3885                 :            : 
    3886                 :        617 :         case ST_PUBLIC:
    3887                 :        617 :         case ST_PRIVATE:
    3888                 :        617 :           if (gfc_current_state () != COMP_MODULE)
    3889                 :            :             {
    3890                 :          0 :               gfc_error ("%s statement must appear in a MODULE",
    3891                 :            :                          gfc_ascii_statement (st));
    3892                 :          0 :               reject_statement ();
    3893                 :          0 :               break;
    3894                 :            :             }
    3895                 :            : 
    3896                 :        617 :           if (gfc_current_ns->default_access != ACCESS_UNKNOWN)
    3897                 :            :             {
    3898                 :          0 :               gfc_error ("%s statement at %C follows another accessibility "
    3899                 :            :                          "specification", gfc_ascii_statement (st));
    3900                 :          0 :               reject_statement ();
    3901                 :          0 :               break;
    3902                 :            :             }
    3903                 :            : 
    3904                 :       1234 :           gfc_current_ns->default_access = (st == ST_PUBLIC)
    3905                 :        617 :             ? ACCESS_PUBLIC : ACCESS_PRIVATE;
    3906                 :            : 
    3907                 :        617 :           break;
    3908                 :            : 
    3909                 :        213 :         case ST_STATEMENT_FUNCTION:
    3910                 :        213 :           if (gfc_current_state () == COMP_MODULE
    3911                 :        213 :               || gfc_current_state () == COMP_SUBMODULE)
    3912                 :            :             {
    3913                 :          1 :               unexpected_statement (st);
    3914                 :          1 :               break;
    3915                 :            :             }
    3916                 :            : 
    3917                 :            :         default:
    3918                 :            :           break;
    3919                 :            :         }
    3920                 :            : 
    3921                 :     194964 :       accept_statement (st);
    3922                 :     194964 :       st = next_statement ();
    3923                 :     194961 :       goto loop;
    3924                 :            : 
    3925                 :        156 :     case ST_ENUM:
    3926                 :        156 :       accept_statement (st);
    3927                 :        156 :       parse_enum();
    3928                 :        154 :       st = next_statement ();
    3929                 :        154 :       goto loop;
    3930                 :            : 
    3931                 :       3761 :     case ST_GET_FCN_CHARACTERISTICS:
    3932                 :            :       /* This statement triggers the association of a function's result
    3933                 :            :          characteristics.  */
    3934                 :       3761 :       ts = &gfc_current_block ()->result->ts;
    3935                 :       3761 :       if (match_deferred_characteristics (ts) != MATCH_YES)
    3936                 :         10 :         bad_characteristic = true;
    3937                 :            : 
    3938                 :       3761 :       st = next_statement ();
    3939                 :       3761 :       goto loop;
    3940                 :            : 
    3941                 :            :     default:
    3942                 :            :       break;
    3943                 :            :     }
    3944                 :            : 
    3945                 :            :   /* If match_deferred_characteristics failed, then there is an error.  */
    3946                 :      69544 :   if (bad_characteristic)
    3947                 :            :     {
    3948                 :         10 :       ts = &gfc_current_block ()->result->ts;
    3949                 :         10 :       if (ts->type != BT_DERIVED)
    3950                 :          2 :         gfc_error ("Bad kind expression for function %qs at %L",
    3951                 :            :                    gfc_current_block ()->name,
    3952                 :            :                    &gfc_current_block ()->declared_at);
    3953                 :            :       else
    3954                 :          8 :         gfc_error ("The type for function %qs at %L is not accessible",
    3955                 :            :                    gfc_current_block ()->name,
    3956                 :            :                    &gfc_current_block ()->declared_at);
    3957                 :            : 
    3958                 :         10 :       gfc_current_block ()->ts.kind = 0;
    3959                 :            :       /* Keep the derived type; if it's bad, it will be discovered later.  */
    3960                 :         10 :       if (!(ts->type == BT_DERIVED && ts->u.derived))
    3961                 :         10 :         ts->type = BT_UNKNOWN;
    3962                 :            :     }
    3963                 :            : 
    3964                 :      69544 :   in_specification_block = false;
    3965                 :            : 
    3966                 :      69544 :   return st;
    3967                 :            : }
    3968                 :            : 
    3969                 :            : 
    3970                 :            : /* Parse a WHERE block, (not a simple WHERE statement).  */
    3971                 :            : 
    3972                 :            : static void
    3973                 :        376 : parse_where_block (void)
    3974                 :            : {
    3975                 :        376 :   int seen_empty_else;
    3976                 :        376 :   gfc_code *top, *d;
    3977                 :        376 :   gfc_state_data s;
    3978                 :        376 :   gfc_statement st;
    3979                 :            : 
    3980                 :        376 :   accept_statement (ST_WHERE_BLOCK);
    3981                 :        376 :   top = gfc_state_stack->tail;
    3982                 :            : 
    3983                 :        376 :   push_state (&s, COMP_WHERE, gfc_new_block);
    3984                 :            : 
    3985                 :        376 :   d = add_statement ();
    3986                 :        376 :   d->expr1 = top->expr1;
    3987                 :        376 :   d->op = EXEC_WHERE;
    3988                 :            : 
    3989                 :        376 :   top->expr1 = NULL;
    3990                 :        376 :   top->block = d;
    3991                 :            : 
    3992                 :        376 :   seen_empty_else = 0;
    3993                 :            : 
    3994                 :       1377 :   do
    3995                 :            :     {
    3996                 :       1377 :       st = next_statement ();
    3997                 :       1377 :       switch (st)
    3998                 :            :         {
    3999                 :          0 :         case ST_NONE:
    4000                 :          0 :           unexpected_eof ();
    4001                 :            : 
    4002                 :         40 :         case ST_WHERE_BLOCK:
    4003                 :         40 :           parse_where_block ();
    4004                 :         40 :           break;
    4005                 :            : 
    4006                 :        639 :         case ST_ASSIGNMENT:
    4007                 :        639 :         case ST_WHERE:
    4008                 :        639 :           accept_statement (st);
    4009                 :        639 :           break;
    4010                 :            : 
    4011                 :        322 :         case ST_ELSEWHERE:
    4012                 :        322 :           if (seen_empty_else)
    4013                 :            :             {
    4014                 :          1 :               gfc_error ("ELSEWHERE statement at %C follows previous "
    4015                 :            :                          "unmasked ELSEWHERE");
    4016                 :          1 :               reject_statement ();
    4017                 :          1 :               break;
    4018                 :            :             }
    4019                 :            : 
    4020                 :        321 :           if (new_st.expr1 == NULL)
    4021                 :        138 :             seen_empty_else = 1;
    4022                 :            : 
    4023                 :        321 :           d = new_level (gfc_state_stack->head);
    4024                 :        321 :           d->op = EXEC_WHERE;
    4025                 :        321 :           d->expr1 = new_st.expr1;
    4026                 :            : 
    4027                 :        321 :           accept_statement (st);
    4028                 :            : 
    4029                 :        321 :           break;
    4030                 :            : 
    4031                 :        376 :         case ST_END_WHERE:
    4032                 :        376 :           accept_statement (st);
    4033                 :        376 :           break;
    4034                 :            : 
    4035                 :          0 :         default:
    4036                 :          0 :           gfc_error ("Unexpected %s statement in WHERE block at %C",
    4037                 :            :                      gfc_ascii_statement (st));
    4038                 :          0 :           reject_statement ();
    4039                 :          0 :           break;
    4040                 :            :         }
    4041                 :            :     }
    4042                 :       1377 :   while (st != ST_END_WHERE);
    4043                 :            : 
    4044                 :        376 :   pop_state ();
    4045                 :        376 : }
    4046                 :            : 
    4047                 :            : 
    4048                 :            : /* Parse a FORALL block (not a simple FORALL statement).  */
    4049                 :            : 
    4050                 :            : static void
    4051                 :        487 : parse_forall_block (void)
    4052                 :            : {
    4053                 :        487 :   gfc_code *top, *d;
    4054                 :        487 :   gfc_state_data s;
    4055                 :        487 :   gfc_statement st;
    4056                 :            : 
    4057                 :        487 :   accept_statement (ST_FORALL_BLOCK);
    4058                 :        487 :   top = gfc_state_stack->tail;
    4059                 :            : 
    4060                 :        487 :   push_state (&s, COMP_FORALL, gfc_new_block);
    4061                 :            : 
    4062                 :        487 :   d = add_statement ();
    4063                 :        487 :   d->op = EXEC_FORALL;
    4064                 :        487 :   top->block = d;
    4065                 :            : 
    4066                 :        987 :   do
    4067                 :            :     {
    4068                 :        987 :       st = next_statement ();
    4069                 :        987 :       switch (st)
    4070                 :            :         {
    4071                 :            : 
    4072                 :        371 :         case ST_ASSIGNMENT:
    4073                 :        371 :         case ST_POINTER_ASSIGNMENT:
    4074                 :        371 :         case ST_WHERE:
    4075                 :        371 :         case ST_FORALL:
    4076                 :        371 :           accept_statement (st);
    4077                 :        371 :           break;
    4078                 :            : 
    4079                 :         46 :         case ST_WHERE_BLOCK:
    4080                 :         46 :           parse_where_block ();
    4081                 :         46 :           break;
    4082                 :            : 
    4083                 :         83 :         case ST_FORALL_BLOCK:
    4084                 :         83 :           parse_forall_block ();
    4085                 :         83 :           break;
    4086                 :            : 
    4087                 :        487 :         case ST_END_FORALL:
    4088                 :        487 :           accept_statement (st);
    4089                 :        487 :           break;
    4090                 :            : 
    4091                 :          0 :         case ST_NONE:
    4092                 :          0 :           unexpected_eof ();
    4093                 :            : 
    4094                 :          0 :         default:
    4095                 :          0 :           gfc_error ("Unexpected %s statement in FORALL block at %C",
    4096                 :            :                      gfc_ascii_statement (st));
    4097                 :            : 
    4098                 :          0 :           reject_statement ();
    4099                 :          0 :           break;
    4100                 :            :         }
    4101                 :            :     }
    4102                 :        987 :   while (st != ST_END_FORALL);
    4103                 :            : 
    4104                 :        487 :   pop_state ();
    4105                 :        487 : }
    4106                 :            : 
    4107                 :            : 
    4108                 :            : static gfc_statement parse_executable (gfc_statement);
    4109                 :            : 
    4110                 :            : /* parse the statements of an IF-THEN-ELSEIF-ELSE-ENDIF block.  */
    4111                 :            : 
    4112                 :            : static void
    4113                 :       9705 : parse_if_block (void)
    4114                 :            : {
    4115                 :       9705 :   gfc_code *top, *d;
    4116                 :       9705 :   gfc_statement st;
    4117                 :       9705 :   locus else_locus;
    4118                 :       9705 :   gfc_state_data s;
    4119                 :       9705 :   int seen_else;
    4120                 :            : 
    4121                 :       9705 :   seen_else = 0;
    4122                 :       9705 :   accept_statement (ST_IF_BLOCK);
    4123                 :            : 
    4124                 :       9705 :   top = gfc_state_stack->tail;
    4125                 :       9705 :   push_state (&s, COMP_IF, gfc_new_block);
    4126                 :            : 
    4127                 :       9705 :   new_st.op = EXEC_IF;
    4128                 :       9705 :   d = add_statement ();
    4129                 :            : 
    4130                 :       9705 :   d->expr1 = top->expr1;
    4131                 :       9705 :   top->expr1 = NULL;
    4132                 :       9705 :   top->block = d;
    4133                 :            : 
    4134                 :      13587 :   do
    4135                 :            :     {
    4136                 :      13587 :       st = parse_executable (ST_NONE);
    4137                 :            : 
    4138                 :      13586 :       switch (st)
    4139                 :            :         {
    4140                 :          0 :         case ST_NONE:
    4141                 :          0 :           unexpected_eof ();
    4142                 :            : 
    4143                 :       1121 :         case ST_ELSEIF:
    4144                 :       1121 :           if (seen_else)
    4145                 :            :             {
    4146                 :          0 :               gfc_error ("ELSE IF statement at %C cannot follow ELSE "
    4147                 :            :                          "statement at %L", &else_locus);
    4148                 :            : 
    4149                 :          0 :               reject_statement ();
    4150                 :          0 :               break;
    4151                 :            :             }
    4152                 :            : 
    4153                 :       1121 :           d = new_level (gfc_state_stack->head);
    4154                 :       1121 :           d->op = EXEC_IF;
    4155                 :       1121 :           d->expr1 = new_st.expr1;
    4156                 :            : 
    4157                 :       1121 :           accept_statement (st);
    4158                 :            : 
    4159                 :       1121 :           break;
    4160                 :            : 
    4161                 :       2759 :         case ST_ELSE:
    4162                 :       2759 :           if (seen_else)
    4163                 :            :             {
    4164                 :          0 :               gfc_error ("Duplicate ELSE statements at %L and %C",
    4165                 :            :                          &else_locus);
    4166                 :          0 :               reject_statement ();
    4167                 :          0 :               break;
    4168                 :            :             }
    4169                 :            : 
    4170                 :       2759 :           seen_else = 1;
    4171                 :       2759 :           else_locus = gfc_current_locus;
    4172                 :            : 
    4173                 :       2759 :           d = new_level (gfc_state_stack->head);
    4174                 :       2759 :           d->op = EXEC_IF;
    4175                 :            : 
    4176                 :       2759 :           accept_statement (st);
    4177                 :            : 
    4178                 :       2759 :           break;
    4179                 :            : 
    4180                 :            :         case ST_ENDIF:
    4181                 :            :           break;
    4182                 :            : 
    4183                 :          2 :         default:
    4184                 :          2 :           unexpected_statement (st);
    4185                 :          2 :           break;
    4186                 :            :         }
    4187                 :            :     }
    4188                 :      13586 :   while (st != ST_ENDIF);
    4189                 :            : 
    4190                 :       9704 :   pop_state ();
    4191                 :       9704 :   accept_statement (st);
    4192                 :       9704 : }
    4193                 :            : 
    4194                 :            : 
    4195                 :            : /* Parse a SELECT block.  */
    4196                 :            : 
    4197                 :            : static void
    4198                 :        506 : parse_select_block (void)
    4199                 :            : {
    4200                 :        506 :   gfc_statement st;
    4201                 :        506 :   gfc_code *cp;
    4202                 :        506 :   gfc_state_data s;
    4203                 :            : 
    4204                 :        506 :   accept_statement (ST_SELECT_CASE);
    4205                 :            : 
    4206                 :        506 :   cp = gfc_state_stack->tail;
    4207                 :        506 :   push_state (&s, COMP_SELECT, gfc_new_block);
    4208                 :            : 
    4209                 :            :   /* Make sure that the next statement is a CASE or END SELECT.  */
    4210                 :        506 :   for (;;)
    4211                 :            :     {
    4212                 :        506 :       st = next_statement ();
    4213                 :        506 :       if (st == ST_NONE)
    4214                 :          0 :         unexpected_eof ();
    4215                 :        506 :       if (st == ST_END_SELECT)
    4216                 :            :         {
    4217                 :            :           /* Empty SELECT CASE is OK.  */
    4218                 :          6 :           accept_statement (st);
    4219                 :          6 :           pop_state ();
    4220                 :          6 :           return;
    4221                 :            :         }
    4222                 :        500 :       if (st == ST_CASE)
    4223                 :            :         break;
    4224                 :            : 
    4225                 :          0 :       gfc_error ("Expected a CASE or END SELECT statement following SELECT "
    4226                 :            :                  "CASE at %C");
    4227                 :            : 
    4228                 :          0 :       reject_statement ();
    4229                 :            :     }
    4230                 :            : 
    4231                 :            :   /* At this point, we've got a nonempty select block.  */
    4232                 :        500 :   cp = new_level (cp);
    4233                 :        500 :   *cp = new_st;
    4234                 :            : 
    4235                 :        500 :   accept_statement (st);
    4236                 :            : 
    4237                 :       1543 :   do
    4238                 :            :     {
    4239                 :       1543 :       st = parse_executable (ST_NONE);
    4240                 :       1543 :       switch (st)
    4241                 :            :         {
    4242                 :          0 :         case ST_NONE:
    4243                 :          0 :           unexpected_eof ();
    4244                 :            : 
    4245                 :       1043 :         case ST_CASE:
    4246                 :       1043 :           cp = new_level (gfc_state_stack->head);
    4247                 :       1043 :           *cp = new_st;
    4248                 :       1043 :           gfc_clear_new_st ();
    4249                 :            : 
    4250                 :       1043 :           accept_statement (st);
    4251                 :            :           /* Fall through */
    4252                 :            : 
    4253                 :            :         case ST_END_SELECT:
    4254                 :            :           break;
    4255                 :            : 
    4256                 :            :         /* Can't have an executable statement because of
    4257                 :            :            parse_executable().  */
    4258                 :          0 :         default:
    4259                 :          0 :           unexpected_statement (st);
    4260                 :          0 :           break;
    4261                 :            :         }
    4262                 :            :     }
    4263                 :       1543 :   while (st != ST_END_SELECT);
    4264                 :            : 
    4265                 :        500 :   pop_state ();
    4266                 :        500 :   accept_statement (st);
    4267                 :            : }
    4268                 :            : 
    4269                 :            : 
    4270                 :            : /* Pop the current selector from the SELECT TYPE stack.  */
    4271                 :            : 
    4272                 :            : static void
    4273                 :       1930 : select_type_pop (void)
    4274                 :            : {
    4275                 :       1930 :   gfc_select_type_stack *old = select_type_stack;
    4276                 :       1930 :   select_type_stack = old->prev;
    4277                 :       1930 :   free (old);
    4278                 :          0 : }
    4279                 :            : 
    4280                 :            : 
    4281                 :            : /* Parse a SELECT TYPE construct (F03:R821).  */
    4282                 :            : 
    4283                 :            : static void
    4284                 :       1889 : parse_select_type_block (void)
    4285                 :            : {
    4286                 :       1889 :   gfc_statement st;
    4287                 :       1889 :   gfc_code *cp;
    4288                 :       1889 :   gfc_state_data s;
    4289                 :            : 
    4290                 :       1889 :   gfc_current_ns = new_st.ext.block.ns;
    4291                 :       1889 :   accept_statement (ST_SELECT_TYPE);
    4292                 :            : 
    4293                 :       1889 :   cp = gfc_state_stack->tail;
    4294                 :       1889 :   push_state (&s, COMP_SELECT_TYPE, gfc_new_block);
    4295                 :            : 
    4296                 :            :   /* Make sure that the next statement is a TYPE IS, CLASS IS, CLASS DEFAULT
    4297                 :            :      or END SELECT.  */
    4298                 :       1897 :   for (;;)
    4299                 :            :     {
    4300                 :       1893 :       st = next_statement ();
    4301                 :       1893 :       if (st == ST_NONE)
    4302                 :          1 :         unexpected_eof ();
    4303                 :       1892 :       if (st == ST_END_SELECT)
    4304                 :            :         /* Empty SELECT CASE is OK.  */
    4305                 :         16 :         goto done;
    4306                 :       1876 :       if (st == ST_TYPE_IS || st == ST_CLASS_IS)
    4307                 :            :         break;
    4308                 :            : 
    4309                 :          4 :       gfc_error ("Expected TYPE IS, CLASS IS or END SELECT statement "
    4310                 :            :                  "following SELECT TYPE at %C");
    4311                 :            : 
    4312                 :          4 :       reject_statement ();
    4313                 :            :     }
    4314                 :            : 
    4315                 :            :   /* At this point, we've got a nonempty select block.  */
    4316                 :       1872 :   cp = new_level (cp);
    4317                 :       1872 :   *cp = new_st;
    4318                 :            : 
    4319                 :       1872 :   accept_statement (st);
    4320                 :            : 
    4321                 :       3191 :   do
    4322                 :            :     {
    4323                 :       3191 :       st = parse_executable (ST_NONE);
    4324                 :       3191 :       switch (st)
    4325                 :            :         {
    4326                 :          0 :         case ST_NONE:
    4327                 :          0 :           unexpected_eof ();
    4328                 :            : 
    4329                 :       1319 :         case ST_TYPE_IS:
    4330                 :       1319 :         case ST_CLASS_IS:
    4331                 :       1319 :           cp = new_level (gfc_state_stack->head);
    4332                 :       1319 :           *cp = new_st;
    4333                 :       1319 :           gfc_clear_new_st ();
    4334                 :            : 
    4335                 :       1319 :           accept_statement (st);
    4336                 :            :           /* Fall through */
    4337                 :            : 
    4338                 :            :         case ST_END_SELECT:
    4339                 :            :           break;
    4340                 :            : 
    4341                 :            :         /* Can't have an executable statement because of
    4342                 :            :            parse_executable().  */
    4343                 :          0 :         default:
    4344                 :          0 :           unexpected_statement (st);
    4345                 :          0 :           break;
    4346                 :            :         }
    4347                 :            :     }
    4348                 :       3191 :   while (st != ST_END_SELECT);
    4349                 :            : 
    4350                 :       1872 : done:
    4351                 :       1888 :   pop_state ();
    4352                 :       1888 :   accept_statement (st);
    4353                 :       1888 :   gfc_current_ns = gfc_current_ns->parent;
    4354                 :       1888 :   select_type_pop ();
    4355                 :       1888 : }
    4356                 :            : 
    4357                 :            : 
    4358                 :            : /* Parse a SELECT RANK construct.  */
    4359                 :            : 
    4360                 :            : static void
    4361                 :         42 : parse_select_rank_block (void)
    4362                 :            : {
    4363                 :         42 :   gfc_statement st;
    4364                 :         42 :   gfc_code *cp;
    4365                 :         42 :   gfc_state_data s;
    4366                 :            : 
    4367                 :         42 :   gfc_current_ns = new_st.ext.block.ns;
    4368                 :         42 :   accept_statement (ST_SELECT_RANK);
    4369                 :            : 
    4370                 :         42 :   cp = gfc_state_stack->tail;
    4371                 :         42 :   push_state (&s, COMP_SELECT_RANK, gfc_new_block);
    4372                 :            : 
    4373                 :            :   /* Make sure that the next statement is a RANK IS or RANK DEFAULT.  */
    4374                 :         48 :   for (;;)
    4375                 :            :     {
    4376                 :         45 :       st = next_statement ();
    4377                 :         45 :       if (st == ST_NONE)
    4378                 :          0 :         unexpected_eof ();
    4379                 :         45 :       if (st == ST_END_SELECT)
    4380                 :            :         /* Empty SELECT CASE is OK.  */
    4381                 :          1 :         goto done;
    4382                 :         44 :       if (st == ST_RANK)
    4383                 :            :         break;
    4384                 :            : 
    4385                 :          3 :       gfc_error ("Expected RANK or RANK DEFAULT "
    4386                 :            :                  "following SELECT RANK at %C");
    4387                 :            : 
    4388                 :          3 :       reject_statement ();
    4389                 :            :     }
    4390                 :            : 
    4391                 :            :   /* At this point, we've got a nonempty select block.  */
    4392                 :         41 :   cp = new_level (cp);
    4393                 :         41 :   *cp = new_st;
    4394                 :            : 
    4395                 :         41 :   accept_statement (st);
    4396                 :            : 
    4397                 :         91 :   do
    4398                 :            :     {
    4399                 :         91 :       st = parse_executable (ST_NONE);
    4400                 :         91 :       switch (st)
    4401                 :            :         {
    4402                 :          0 :         case ST_NONE:
    4403                 :          0 :           unexpected_eof ();
    4404                 :            : 
    4405                 :         50 :         case ST_RANK:
    4406                 :         50 :           cp = new_level (gfc_state_stack->head);
    4407                 :         50 :           *cp = new_st;
    4408                 :         50 :           gfc_clear_new_st ();
    4409                 :            : 
    4410                 :         50 :           accept_statement (st);
    4411                 :            :           /* Fall through */
    4412                 :            : 
    4413                 :            :         case ST_END_SELECT:
    4414                 :            :           break;
    4415                 :            : 
    4416                 :            :         /* Can't have an executable statement because of
    4417                 :            :            parse_executable().  */
    4418                 :          0 :         default:
    4419                 :          0 :           unexpected_statement (st);
    4420                 :          0 :           break;
    4421                 :            :         }
    4422                 :            :     }
    4423                 :         91 :   while (st != ST_END_SELECT);
    4424                 :            : 
    4425                 :         41 : done:
    4426                 :         42 :   pop_state ();
    4427                 :         42 :   accept_statement (st);
    4428                 :         42 :   gfc_current_ns = gfc_current_ns->parent;
    4429                 :         42 :   select_type_pop ();
    4430                 :         42 : }
    4431                 :            : 
    4432                 :            : 
    4433                 :            : /* Given a symbol, make sure it is not an iteration variable for a DO
    4434                 :            :    statement.  This subroutine is called when the symbol is seen in a
    4435                 :            :    context that causes it to become redefined.  If the symbol is an
    4436                 :            :    iterator, we generate an error message and return nonzero.  */
    4437                 :            : 
    4438                 :            : int
    4439                 :     190013 : gfc_check_do_variable (gfc_symtree *st)
    4440                 :            : {
    4441                 :     190013 :   gfc_state_data *s;
    4442                 :            : 
    4443                 :     792622 :   for (s=gfc_state_stack; s; s = s->previous)
    4444                 :     602616 :     if (s->do_variable == st)
    4445                 :            :       {
    4446                 :          7 :         gfc_error_now ("Variable %qs at %C cannot be redefined inside "
    4447                 :          7 :                        "loop beginning at %L", st->name, &s->head->loc);
    4448                 :          7 :         return 1;
    4449                 :            :       }
    4450                 :            : 
    4451                 :            :   return 0;
    4452                 :            : }
    4453                 :            : 
    4454                 :            : 
    4455                 :            : /* Checks to see if the current statement label closes an enddo.
    4456                 :            :    Returns 0 if not, 1 if closes an ENDDO correctly, or 2 (and issues
    4457                 :            :    an error) if it incorrectly closes an ENDDO.  */
    4458                 :            : 
    4459                 :            : static int
    4460                 :     547007 : check_do_closure (void)
    4461                 :            : {
    4462                 :     547007 :   gfc_state_data *p;
    4463                 :            : 
    4464                 :     547007 :   if (gfc_statement_label == NULL)
    4465                 :            :     return 0;
    4466                 :            : 
    4467                 :      15515 :   for (p = gfc_state_stack; p; p = p->previous)
    4468                 :      11951 :     if (p->state == COMP_DO || p->state == COMP_DO_CONCURRENT)
    4469                 :            :       break;
    4470                 :            : 
    4471                 :       6515 :   if (p == NULL)
    4472                 :            :     return 0;           /* No loops to close */
    4473                 :            : 
    4474                 :       2951 :   if (p->ext.end_do_label == gfc_statement_label)
    4475                 :            :     {
    4476                 :       2183 :       if (p == gfc_state_stack)
    4477                 :            :         return 1;
    4478                 :            : 
    4479                 :          1 :       gfc_error ("End of nonblock DO statement at %C is within another block");
    4480                 :          1 :       return 2;
    4481                 :            :     }
    4482                 :            : 
    4483                 :            :   /* At this point, the label doesn't terminate the innermost loop.
    4484                 :            :      Make sure it doesn't terminate another one.  */
    4485                 :       4358 :   for (; p; p = p->previous)
    4486                 :       3590 :     if ((p->state == COMP_DO || p->state == COMP_DO_CONCURRENT)
    4487                 :       1011 :         && p->ext.end_do_label == gfc_statement_label)
    4488                 :            :       {
    4489                 :          0 :         gfc_error ("End of nonblock DO statement at %C is interwoven "
    4490                 :            :                    "with another DO loop");
    4491                 :          0 :         return 2;
    4492                 :            :       }
    4493                 :            : 
    4494                 :            :   return 0;
    4495                 :            : }
    4496                 :            : 
    4497                 :            : 
    4498                 :            : /* Parse a series of contained program units.  */
    4499                 :            : 
    4500                 :            : static void parse_progunit (gfc_statement);
    4501                 :            : 
    4502                 :            : 
    4503                 :            : /* Parse a CRITICAL block.  */
    4504                 :            : 
    4505                 :            : static void
    4506                 :         33 : parse_critical_block (void)
    4507                 :            : {
    4508                 :         33 :   gfc_code *top, *d;
    4509                 :         33 :   gfc_state_data s, *sd;
    4510                 :         33 :   gfc_statement st;
    4511                 :            : 
    4512                 :        115 :   for (sd = gfc_state_stack; sd; sd = sd->previous)
    4513                 :         82 :     if (sd->state == COMP_OMP_STRUCTURED_BLOCK)
    4514                 :          2 :       gfc_error_now (is_oacc (sd)
    4515                 :            :                      ? G_("CRITICAL block inside of OpenACC region at %C")
    4516                 :            :                      : G_("CRITICAL block inside of OpenMP region at %C"));
    4517                 :            : 
    4518                 :         33 :   s.ext.end_do_label = new_st.label1;
    4519                 :            : 
    4520                 :         33 :   accept_statement (ST_CRITICAL);
    4521                 :         33 :   top = gfc_state_stack->tail;
    4522                 :            : 
    4523                 :         33 :   push_state (&s, COMP_CRITICAL, gfc_new_block);
    4524                 :            : 
    4525                 :         33 :   d = add_statement ();
    4526                 :         33 :   d->op = EXEC_CRITICAL;
    4527                 :         33 :   top->block = d;
    4528                 :            : 
    4529                 :         33 :   do
    4530                 :            :     {
    4531                 :         33 :       st = parse_executable (ST_NONE);
    4532                 :            : 
    4533                 :         33 :       switch (st)
    4534                 :            :         {
    4535                 :          0 :           case ST_NONE:
    4536                 :          0 :             unexpected_eof ();
    4537                 :         33 :             break;
    4538                 :            : 
    4539                 :         33 :           case ST_END_CRITICAL:
    4540                 :         33 :             if (s.ext.end_do_label != NULL
    4541                 :          0 :                 && s.ext.end_do_label != gfc_statement_label)
    4542                 :          0 :               gfc_error_now ("Statement label in END CRITICAL at %C does not "
    4543                 :            :                              "match CRITICAL label");
    4544                 :            : 
    4545                 :         33 :             if (gfc_statement_label != NULL)
    4546                 :            :               {
    4547                 :          1 :                 new_st.op = EXEC_NOP;
    4548                 :          1 :                 add_statement ();
    4549                 :            :               }
    4550                 :            :             break;
    4551                 :            : 
    4552                 :          0 :           default:
    4553                 :          0 :             unexpected_statement (st);
    4554                 :          0 :             break;
    4555                 :            :         }
    4556                 :            :     }
    4557                 :         33 :   while (st != ST_END_CRITICAL);
    4558                 :            : 
    4559                 :         33 :   pop_state ();
    4560                 :         33 :   accept_statement (st);
    4561                 :         33 : }
    4562                 :            : 
    4563                 :            : 
    4564                 :            : /* Set up the local namespace for a BLOCK construct.  */
    4565                 :            : 
    4566                 :            : gfc_namespace*
    4567                 :       7131 : gfc_build_block_ns (gfc_namespace *parent_ns)
    4568                 :            : {
    4569                 :       7131 :   gfc_namespace* my_ns;
    4570                 :       7131 :   static int numblock = 1;
    4571                 :            : 
    4572                 :       7131 :   my_ns = gfc_get_namespace (parent_ns, 1);
    4573                 :       7131 :   my_ns->construct_entities = 1;
    4574                 :            : 
    4575                 :            :   /* Give the BLOCK a symbol of flavor LABEL; this is later needed for correct
    4576                 :            :      code generation (so it must not be NULL).
    4577                 :            :      We set its recursive argument if our container procedure is recursive, so
    4578                 :            :      that local variables are accordingly placed on the stack when it
    4579                 :            :      will be necessary.  */
    4580                 :       7131 :   if (gfc_new_block)
    4581                 :        120 :     my_ns->proc_name = gfc_new_block;
    4582                 :            :   else
    4583                 :            :     {
    4584                 :       7011 :       bool t;
    4585                 :       7011 :       char buffer[20];  /* Enough to hold "block@2147483648\n".  */
    4586                 :            : 
    4587                 :       7011 :       snprintf(buffer, sizeof(buffer), "block@%d", numblock++);
    4588                 :       7011 :       gfc_get_symbol (buffer, my_ns, &my_ns->proc_name);
    4589                 :      14022 :       t = gfc_add_flavor (&my_ns->proc_name->attr, FL_LABEL,
    4590                 :       7011 :                           my_ns->proc_name->name, NULL);
    4591                 :       7011 :       gcc_assert (t);
    4592                 :       7011 :       gfc_commit_symbol (my_ns->proc_name);
    4593                 :            :     }
    4594                 :            : 
    4595                 :       7131 :   if (parent_ns->proc_name)
    4596                 :       7128 :     my_ns->proc_name->attr.recursive = parent_ns->proc_name->attr.recursive;
    4597                 :            : 
    4598                 :       7131 :   return my_ns;
    4599                 :            : }
    4600                 :            : 
    4601                 :            : 
    4602                 :            : /* Parse a BLOCK construct.  */
    4603                 :            : 
    4604                 :            : static void
    4605                 :        442 : parse_block_construct (void)
    4606                 :            : {
    4607                 :        442 :   gfc_namespace* my_ns;
    4608                 :        442 :   gfc_namespace* my_parent;
    4609                 :        442 :   gfc_state_data s;
    4610                 :            : 
    4611                 :        442 :   gfc_notify_std (GFC_STD_F2008, "BLOCK construct at %C");
    4612                 :            : 
    4613                 :        442 :   my_ns = gfc_build_block_ns (gfc_current_ns);
    4614                 :            : 
    4615                 :        442 :   new_st.op = EXEC_BLOCK;
    4616                 :        442 :   new_st.ext.block.ns = my_ns;
    4617                 :        442 :   new_st.ext.block.assoc = NULL;
    4618                 :        442 :   accept_statement (ST_BLOCK);
    4619                 :            : 
    4620                 :        442 :   push_state (&s, COMP_BLOCK, my_ns->proc_name);
    4621                 :        442 :   gfc_current_ns = my_ns;
    4622                 :        442 :   my_parent = my_ns->parent;
    4623                 :            : 
    4624                 :        442 :   parse_progunit (ST_NONE);
    4625                 :            : 
    4626                 :            :   /* Don't depend on the value of gfc_current_ns;  it might have been
    4627                 :            :      reset if the block had errors and was cleaned up.  */
    4628                 :        434 :   gfc_current_ns = my_parent;
    4629                 :            : 
    4630                 :        434 :   pop_state ();
    4631                 :        434 : }
    4632                 :            : 
    4633                 :            : 
    4634                 :            : /* Parse an ASSOCIATE construct.  This is essentially a BLOCK construct
    4635                 :            :    behind the scenes with compiler-generated variables.  */
    4636                 :            : 
    4637                 :            : static void
    4638                 :        637 : parse_associate (void)
    4639                 :            : {
    4640                 :        637 :   gfc_namespace* my_ns;
    4641                 :        637 :   gfc_state_data s;
    4642                 :        637 :   gfc_statement st;
    4643                 :        637 :   gfc_association_list* a;
    4644                 :            : 
    4645                 :        637 :   gfc_notify_std (GFC_STD_F2003, "ASSOCIATE construct at %C");
    4646                 :            : 
    4647                 :        637 :   my_ns = gfc_build_block_ns (gfc_current_ns);
    4648                 :            : 
    4649                 :        637 :   new_st.op = EXEC_BLOCK;
    4650                 :        637 :   new_st.ext.block.ns = my_ns;
    4651                 :        637 :   gcc_assert (new_st.ext.block.assoc);
    4652                 :            : 
    4653                 :            :   /* Add all associate-names as BLOCK variables.  Creating them is enough
    4654                 :            :      for now, they'll get their values during trans-* phase.  */
    4655                 :        637 :   gfc_current_ns = my_ns;
    4656                 :       1373 :   for (a = new_st.ext.block.assoc; a; a = a->next)
    4657                 :            :     {
    4658                 :        736 :       gfc_symbol* sym;
    4659                 :        736 :       gfc_ref *ref;
    4660                 :        736 :       gfc_array_ref *array_ref;
    4661                 :            : 
    4662                 :        736 :       if (gfc_get_sym_tree (a->name, NULL, &a->st, false))
    4663                 :          0 :         gcc_unreachable ();
    4664                 :            : 
    4665                 :        736 :       sym = a->st->n.sym;
    4666                 :        736 :       sym->attr.flavor = FL_VARIABLE;
    4667                 :        736 :       sym->assoc = a;
    4668                 :        736 :       sym->declared_at = a->where;
    4669                 :        736 :       gfc_set_sym_referenced (sym);
    4670                 :            : 
    4671                 :            :       /* Initialize the typespec.  It is not available in all cases,
    4672                 :            :          however, as it may only be set on the target during resolution.
    4673                 :            :          Still, sometimes it helps to have it right now -- especially
    4674                 :            :          for parsing component references on the associate-name
    4675                 :            :          in case of association to a derived-type.  */
    4676                 :        736 :       sym->ts = a->target->ts;
    4677                 :            : 
    4678                 :            :       /* Check if the target expression is array valued.  This cannot always
    4679                 :            :          be done by looking at target.rank, because that might not have been
    4680                 :            :          set yet.  Therefore traverse the chain of refs, looking for the last
    4681                 :            :          array ref and evaluate that.  */
    4682                 :        736 :       array_ref = NULL;
    4683                 :       1291 :       for (ref = a->target->ref; ref; ref = ref->next)
    4684                 :        555 :         if (ref->type == REF_ARRAY)
    4685                 :        339 :           array_ref = &ref->u.ar;
    4686                 :        736 :       if (array_ref || a->target->rank)
    4687                 :            :         {
    4688                 :        375 :           gfc_array_spec *as;
    4689                 :        375 :           int dim, rank = 0;
    4690                 :        375 :           if (array_ref)
    4691                 :            :             {
    4692                 :        302 :               a->rankguessed = 1;
    4693                 :            :               /* Count the dimension, that have a non-scalar extend.  */
    4694                 :        533 :               for (dim = 0; dim < array_ref->dimen; ++dim)
    4695                 :        231 :                 if (array_ref->dimen_type[dim] != DIMEN_ELEMENT
    4696                 :        231 :                     && !(array_ref->dimen_type[dim] == DIMEN_UNKNOWN
    4697                 :        107 :                          && array_ref->end[dim] == NULL
    4698                 :        107 :                          && array_ref->start[dim] != NULL))
    4699                 :        124 :                   ++rank;
    4700                 :            :             }
    4701                 :            :           else
    4702                 :         73 :             rank = a->target->rank;
    4703                 :            :           /* When the rank is greater than zero then sym will be an array.  */
    4704                 :        375 :           if (sym->ts.type == BT_CLASS && CLASS_DATA (sym))
    4705                 :            :             {
    4706                 :         54 :               if ((!CLASS_DATA (sym)->as && rank != 0)
    4707                 :         54 :                   || (CLASS_DATA (sym)->as
    4708                 :         48 :                       && CLASS_DATA (sym)->as->rank != rank))
    4709                 :            :                 {
    4710                 :            :                   /* Don't just (re-)set the attr and as in the sym.ts,
    4711                 :            :                      because this modifies the target's attr and as.  Copy the
    4712                 :            :                      data and do a build_class_symbol.  */
    4713                 :         36 :                   symbol_attribute attr = CLASS_DATA (a->target)->attr;
    4714                 :         36 :                   int corank = gfc_get_corank (a->target);
    4715                 :         36 :                   gfc_typespec type;
    4716                 :            : 
    4717                 :         36 :                   if (rank || corank)
    4718                 :            :                     {
    4719                 :          0 :                       as = gfc_get_array_spec ();
    4720                 :          0 :                       as->type = AS_DEFERRED;
    4721                 :          0 :                       as->rank = rank;
    4722                 :          0 :                       as->corank = corank;
    4723                 :          0 :                       attr.dimension = rank ? 1 : 0;
    4724                 :          0 :                       attr.codimension = corank ? 1 : 0;
    4725                 :            :                     }
    4726                 :            :                   else
    4727                 :            :                     {
    4728                 :         36 :                       as = NULL;
    4729                 :         36 :                       attr.dimension = attr.codimension = 0;
    4730                 :            :                     }
    4731                 :         36 :                   attr.class_ok = 0;
    4732                 :         36 :                   type = CLASS_DATA (sym)->ts;
    4733                 :         36 :                   if (!gfc_build_class_symbol (&type,
    4734                 :            :                                                &attr, &as))
    4735                 :          0 :                     gcc_unreachable ();
    4736                 :         36 :                   sym->ts = type;
    4737                 :         36 :                   sym->ts.type = BT_CLASS;
    4738                 :         36 :                   sym->attr.class_ok = 1;
    4739                 :            :                 }
    4740                 :            :               else
    4741                 :         18 :                 sym->attr.class_ok = 1;
    4742                 :            :             }
    4743                 :        321 :           else if ((!sym->as && rank != 0)
    4744                 :        164 :                    || (sym->as && sym->as->rank != rank))
    4745                 :            :             {
    4746                 :        157 :               as = gfc_get_array_spec ();
    4747                 :        157 :               as->type = AS_DEFERRED;
    4748                 :        157 :               as->rank = rank;
    4749                 :        157 :               as->corank = gfc_get_corank (a->target);
    4750                 :        157 :               sym->as = as;
    4751                 :        157 :               sym->attr.dimension = 1;
    4752                 :        157 :               if (as->corank)
    4753                 :          1 :                 sym->attr.codimension = 1;
    4754                 :            :             }
    4755                 :            :         }
    4756                 :            :     }
    4757                 :            : 
    4758                 :        637 :   accept_statement (ST_ASSOCIATE);
    4759                 :        637 :   push_state (&s, COMP_ASSOCIATE, my_ns->proc_name);
    4760                 :            : 
    4761                 :        638 : loop:
    4762                 :        638 :   st = parse_executable (ST_NONE);
    4763                 :        635 :   switch (st)
    4764                 :            :     {
    4765                 :          0 :     case ST_NONE:
    4766                 :          0 :       unexpected_eof ();
    4767                 :            : 
    4768                 :        634 :     case_end:
    4769                 :        634 :       accept_statement (st);
    4770                 :        634 :       my_ns->code = gfc_state_stack->head;
    4771                 :        634 :       break;
    4772                 :            : 
    4773                 :          1 :     default:
    4774                 :          1 :       unexpected_statement (st);
    4775                 :          1 :       goto loop;
    4776                 :            :     }
    4777                 :            : 
    4778                 :        634 :   gfc_current_ns = gfc_current_ns->parent;
    4779                 :        634 :   pop_state ();
    4780                 :        634 : }
    4781                 :            : 
    4782                 :            : 
    4783                 :            : /* Parse a DO loop.  Note that the ST_CYCLE and ST_EXIT statements are
    4784                 :            :    handled inside of parse_executable(), because they aren't really
    4785                 :            :    loop statements.  */
    4786                 :            : 
    4787                 :            : static void
    4788                 :      23111 : parse_do_block (void)
    4789                 :            : {
    4790                 :      23111 :   gfc_statement st;
    4791                 :      23111 :   gfc_code *top;
    4792                 :      23111 :   gfc_state_data s;
    4793                 :      23111 :   gfc_symtree *stree;
    4794                 :      23111 :   gfc_exec_op do_op;
    4795                 :            : 
    4796                 :      23111 :   do_op = new_st.op;
    4797                 :      23111 :   s.ext.end_do_label = new_st.label1;
    4798                 :            : 
    4799                 :      23111 :   if (new_st.ext.iterator != NULL)
    4800                 :            :     {
    4801                 :      22576 :       stree = new_st.ext.iterator->var->symtree;
    4802                 :      22576 :       if (directive_unroll != -1)
    4803                 :            :         {
    4804                 :         16 :           new_st.ext.iterator->unroll = directive_unroll;
    4805                 :         16 :           directive_unroll = -1;
    4806                 :            :         }
    4807                 :      22576 :       if (directive_ivdep)
    4808                 :            :         {
    4809                 :          2 :           new_st.ext.iterator->ivdep = directive_ivdep;
    4810                 :          2 :           directive_ivdep = false;
    4811                 :            :         }
    4812                 :      22576 :       if (directive_vector)
    4813                 :            :         {
    4814                 :          2 :           new_st.ext.iterator->vector = directive_vector;
    4815                 :          2 :           directive_vector = false;
    4816                 :            :         }
    4817                 :      22576 :       if (directive_novector)
    4818                 :            :         {
    4819                 :          1 :           new_st.ext.iterator->novector = directive_novector;
    4820                 :          1 :           directive_novector = false;
    4821                 :            :         }
    4822                 :            :     }
    4823                 :            :   else
    4824                 :            :     stree = NULL;
    4825                 :            : 
    4826                 :      23111 :   accept_statement (ST_DO);
    4827                 :            : 
    4828                 :      23111 :   top = gfc_state_stack->tail;
    4829                 :      46159 :   push_state (&s, do_op == EXEC_DO_CONCURRENT ? COMP_DO_CONCURRENT : COMP_DO,
    4830                 :            :               gfc_new_block);
    4831                 :            : 
    4832                 :      23111 :   s.do_variable = stree;
    4833                 :            : 
    4834                 :      23111 :   top->block = new_level (top);
    4835                 :      23111 :   top->block->op = EXEC_DO;
    4836                 :            : 
    4837                 :      23111 : loop:
    4838                 :      23111 :   st = parse_executable (ST_NONE);
    4839                 :            : 
    4840                 :      23109 :   switch (st)
    4841                 :            :     {
    4842                 :          0 :     case ST_NONE:
    4843                 :          0 :       unexpected_eof ();
    4844                 :            : 
    4845                 :      21010 :     case ST_ENDDO:
    4846                 :      21010 :       if (s.ext.end_do_label != NULL
    4847                 :         86 :           && s.ext.end_do_label != gfc_statement_label)
    4848                 :          1 :         gfc_error_now ("Statement label in ENDDO at %C doesn't match "
    4849                 :            :                        "DO label");
    4850                 :            : 
    4851                 :      21010 :       if (gfc_statement_label != NULL)
    4852                 :            :         {
    4853                 :         98 :           new_st.op = EXEC_NOP;
    4854                 :         98 :           add_statement ();
    4855                 :            :         }
    4856                 :            :       break;
    4857                 :            : 
    4858                 :       2099 :     case ST_IMPLIED_ENDDO:
    4859                 :            :      /* If the do-stmt of this DO construct has a do-construct-name,
    4860                 :            :         the corresponding end-do must be an end-do-stmt (with a matching
    4861                 :            :         name, but in that case we must have seen ST_ENDDO first).
    4862                 :            :         We only complain about this in pedantic mode.  */
    4863                 :       2099 :      if (gfc_current_block () != NULL)
    4864                 :          1 :         gfc_error_now ("Named block DO at %L requires matching ENDDO name",
    4865                 :            :                        &gfc_current_block()->declared_at);
    4866                 :            : 
    4867                 :            :       break;
    4868                 :            : 
    4869                 :          0 :     default:
    4870                 :          0 :       unexpected_statement (st);
    4871                 :          0 :       goto loop;
    4872                 :            :     }
    4873                 :            : 
    4874                 :      23109 :   pop_state ();
    4875                 :      23109 :   accept_statement (st);
    4876                 :      23109 : }
    4877                 :            : 
    4878                 :            : 
    4879                 :            : /* Parse the statements of OpenMP do/parallel do.  */
    4880                 :            : 
    4881                 :            : static gfc_statement
    4882                 :       2225 : parse_omp_do (gfc_statement omp_st)
    4883                 :            : {
    4884                 :       2225 :   gfc_statement st;
    4885                 :       2225 :   gfc_code *cp, *np;
    4886                 :       2225 :   gfc_state_data s;
    4887                 :            : 
    4888                 :       2225 :   accept_statement (omp_st);
    4889                 :            : 
    4890                 :       2225 :   cp = gfc_state_stack->tail;
    4891                 :       2225 :   push_state (&s, COMP_OMP_STRUCTURED_BLOCK, NULL);
    4892                 :       2225 :   np = new_level (cp);
    4893                 :       2225 :   np->op = cp->op;
    4894                 :       2225 :   np->block = NULL;
    4895                 :            : 
    4896                 :       2227 :   for (;;)
    4897                 :            :     {
    4898                 :       2226 :       st = next_statement ();
    4899                 :       2226 :       if (st == ST_NONE)
    4900                 :          0 :         unexpected_eof ();
    4901                 :       2226 :       else if (st == ST_DO)
    4902                 :            :         break;
    4903                 :            :       else
    4904                 :          1 :         unexpected_statement (st);
    4905                 :            :     }
    4906                 :            : 
    4907                 :       2225 :   parse_do_block ();
    4908                 :       2225 :   if (gfc_statement_label != NULL
    4909                 :         59 :       && gfc_state_stack->previous != NULL
    4910                 :         59 :       && gfc_state_stack->previous->state == COMP_DO
    4911                 :          2 :       && gfc_state_stack->previous->ext.end_do_label == gfc_statement_label)
    4912                 :            :     {
    4913                 :            :       /* In
    4914                 :            :          DO 100 I=1,10
    4915                 :            :            !$OMP DO
    4916                 :            :              DO J=1,10
    4917                 :            :              ...
    4918                 :            :              100 CONTINUE
    4919                 :            :          there should be no !$OMP END DO.  */
    4920                 :          2 :       pop_state ();
    4921                 :          2 :       return ST_IMPLIED_ENDDO;
    4922                 :            :     }
    4923                 :            : 
    4924                 :       2223 :   check_do_closure ();
    4925                 :       2223 :   pop_state ();
    4926                 :            : 
    4927                 :       2223 :   st = next_statement ();
    4928                 :       2223 :   gfc_statement omp_end_st = ST_OMP_END_DO;
    4929                 :       2223 :   switch (omp_st)
    4930                 :            :     {
    4931                 :            :     case ST_OMP_DISTRIBUTE: omp_end_st = ST_OMP_END_DISTRIBUTE; break;
    4932                 :         18 :     case ST_OMP_DISTRIBUTE_PARALLEL_DO:
    4933                 :         18 :       omp_end_st = ST_OMP_END_DISTRIBUTE_PARALLEL_DO;
    4934                 :         18 :       break;
    4935                 :         12 :     case ST_OMP_DISTRIBUTE_PARALLEL_DO_SIMD:
    4936                 :         12 :       omp_end_st = ST_OMP_END_DISTRIBUTE_PARALLEL_DO_SIMD;
    4937                 :         12 :       break;
    4938                 :         12 :     case ST_OMP_DISTRIBUTE_SIMD:
    4939                 :         12 :       omp_end_st = ST_OMP_END_DISTRIBUTE_SIMD;
    4940                 :         12 :       break;
    4941                 :        805 :     case ST_OMP_DO: omp_end_st = ST_OMP_END_DO; break;
    4942                 :         71 :     case ST_OMP_DO_SIMD: omp_end_st = ST_OMP_END_DO_SIMD; break;
    4943                 :        721 :     case ST_OMP_PARALLEL_DO: omp_end_st = ST_OMP_END_PARALLEL_DO; break;
    4944                 :        152 :     case ST_OMP_PARALLEL_DO_SIMD:
    4945                 :        152 :       omp_end_st = ST_OMP_END_PARALLEL_DO_SIMD;
    4946                 :        152 :       break;
    4947                 :        324 :     case ST_OMP_SIMD: omp_end_st = ST_OMP_END_SIMD; break;
    4948                 :          1 :     case ST_OMP_TARGET_PARALLEL_DO:
    4949                 :          1 :       omp_end_st = ST_OMP_END_TARGET_PARALLEL_DO;
    4950                 :          1 :       break;
    4951                 :          1 :     case ST_OMP_TARGET_PARALLEL_DO_SIMD:
    4952                 :          1 :       omp_end_st = ST_OMP_END_TARGET_PARALLEL_DO_SIMD;
    4953                 :          1 :       break;
    4954                 :         13 :     case ST_OMP_TARGET_SIMD: omp_end_st = ST_OMP_END_TARGET_SIMD; break;
    4955                 :          4 :     case ST_OMP_TARGET_TEAMS_DISTRIBUTE:
    4956                 :          4 :       omp_end_st = ST_OMP_END_TARGET_TEAMS_DISTRIBUTE;
    4957                 :          4 :       break;
    4958                 :          7 :     case ST_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO:
    4959                 :          7 :       omp_end_st = ST_OMP_END_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO;
    4960                 :          7 :       break;
    4961                 :         14 :     case ST_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD:
    4962                 :         14 :       omp_end_st = ST_OMP_END_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD;
    4963                 :         14 :       break;
    4964                 :          4 :     case ST_OMP_TARGET_TEAMS_DISTRIBUTE_SIMD:
    4965                 :          4 :       omp_end_st = ST_OMP_END_TARGET_TEAMS_DISTRIBUTE_SIMD;
    4966                 :          4 :       break;
    4967                 :         20 :     case ST_OMP_TASKLOOP: omp_end_st = ST_OMP_END_TASKLOOP; break;
    4968                 :          6 :     case ST_OMP_TASKLOOP_SIMD: omp_end_st = ST_OMP_END_TASKLOOP_SIMD; break;
    4969                 :          4 :     case ST_OMP_TEAMS_DISTRIBUTE:
    4970                 :          4 :       omp_end_st = ST_OMP_END_TEAMS_DISTRIBUTE;
    4971                 :          4 :       break;
    4972                 :          5 :     case ST_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO:
    4973                 :          5 :       omp_end_st = ST_OMP_END_TEAMS_DISTRIBUTE_PARALLEL_DO;
    4974                 :          5 :       break;
    4975                 :         10 :     case ST_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD:
    4976                 :         10 :       omp_end_st = ST_OMP_END_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD;
    4977                 :         10 :       break;
    4978                 :          4 :     case ST_OMP_TEAMS_DISTRIBUTE_SIMD:
    4979                 :          4 :       omp_end_st = ST_OMP_END_TEAMS_DISTRIBUTE_SIMD;
    4980                 :          4 :       break;
    4981                 :          0 :     default: gcc_unreachable ();
    4982                 :            :     }
    4983                 :       2223 :   if (st == omp_end_st)
    4984                 :            :     {
    4985                 :        511 :       if (new_st.op == EXEC_OMP_END_NOWAIT)
    4986                 :        249 :         cp->ext.omp_clauses->nowait |= new_st.ext.omp_bool;
    4987                 :            :       else
    4988                 :        262 :         gcc_assert (new_st.op == EXEC_NOP);
    4989                 :        511 :       gfc_clear_new_st ();
    4990                 :        511 :       gfc_commit_symbols ();
    4991                 :        511 :       gfc_warning_check ();
    4992                 :        511 :       st = next_statement ();
    4993                 :            :     }
    4994                 :            :   return st;
    4995                 :            : }
    4996                 :            : 
    4997                 :            : 
    4998                 :            : /* Parse the statements of OpenMP atomic directive.  */
    4999                 :            : 
    5000                 :            : static gfc_statement
    5001                 :       1640 : parse_omp_oacc_atomic (bool omp_p)
    5002                 :            : {
    5003                 :       1640 :   gfc_statement st, st_atomic, st_end_atomic;
    5004                 :       1640 :   gfc_code *cp, *np;
    5005                 :       1640 :   gfc_state_data s;
    5006                 :       1640 :   int count;
    5007                 :            : 
    5008                 :       1640 :   if (omp_p)
    5009                 :            :     {
    5010                 :            :       st_atomic = ST_OMP_ATOMIC;
    5011                 :            :       st_end_atomic = ST_OMP_END_ATOMIC;
    5012                 :            :     }
    5013                 :            :   else
    5014                 :            :     {
    5015                 :        517 :       st_atomic = ST_OACC_ATOMIC;
    5016                 :        517 :       st_end_atomic = ST_OACC_END_ATOMIC;
    5017                 :            :     }
    5018                 :       1640 :   accept_statement (st_atomic);
    5019                 :            : 
    5020                 :       1640 :   cp = gfc_state_stack->tail;
    5021                 :       1640 :   push_state (&s, COMP_OMP_STRUCTURED_BLOCK, NULL);
    5022                 :       1640 :   np = new_level (cp);
    5023                 :       1640 :   np->op = cp->op;
    5024                 :       1640 :   np->block = NULL;
    5025                 :       1640 :   np->ext.omp_atomic = cp->ext.omp_atomic;
    5026                 :       1640 :   count = 1 + ((cp->ext.omp_atomic & GFC_OMP_ATOMIC_MASK)
    5027                 :            :                == GFC_OMP_ATOMIC_CAPTURE);
    5028                 :            : 
    5029                 :       3667 :   while (count)
    5030                 :            :     {
    5031                 :       2027 :       st = next_statement ();
    5032                 :       2027 :       if (st == ST_NONE)
    5033                 :          0 :         unexpected_eof ();
    5034                 :       2027 :       else if (st == ST_ASSIGNMENT)
    5035                 :            :         {
    5036                 :       2027 :           accept_statement (st);
    5037                 :       2027 :           count--;
    5038                 :            :         }
    5039                 :            :       else
    5040                 :          0 :         unexpected_statement (st);
    5041                 :            :     }
    5042                 :            : 
    5043                 :       1640 :   pop_state ();
    5044                 :            : 
    5045                 :       1640 :   st = next_statement ();
    5046                 :       1640 :   if (st == st_end_atomic)
    5047                 :            :     {
    5048                 :        659 :       gfc_clear_new_st ();
    5049                 :        659 :       gfc_commit_symbols ();
    5050                 :        659 :       gfc_warning_check ();
    5051                 :        659 :       st = next_statement ();
    5052                 :            :     }
    5053                 :        981 :   else if ((cp->ext.omp_atomic & GFC_OMP_ATOMIC_MASK)
    5054                 :            :            == GFC_OMP_ATOMIC_CAPTURE)
    5055                 :          0 :     gfc_error ("Missing !$OMP END ATOMIC after !$OMP ATOMIC CAPTURE at %C");
    5056                 :       1640 :   return st;
    5057                 :            : }
    5058                 :            : 
    5059                 :            : 
    5060                 :            : /* Parse the statements of an OpenACC structured block.  */
    5061                 :            : 
    5062                 :            : static void
    5063                 :       3908 : parse_oacc_structured_block (gfc_statement acc_st)
    5064                 :            : {
    5065                 :       3908 :   gfc_statement st, acc_end_st;
    5066                 :       3908 :   gfc_code *cp, *np;
    5067                 :       3908 :   gfc_state_data s, *sd;
    5068                 :            : 
    5069                 :      13269 :   for (sd = gfc_state_stack; sd; sd = sd->previous)
    5070                 :       9361 :     if (sd->state == COMP_CRITICAL)
    5071                 :          1 :       gfc_error_now ("OpenACC directive inside of CRITICAL block at %C");
    5072                 :            : 
    5073                 :       3908 :   accept_statement (acc_st);
    5074                 :            : 
    5075                 :       3908 :   cp = gfc_state_stack->tail;
    5076                 :       3908 :   push_state (&s, COMP_OMP_STRUCTURED_BLOCK, NULL);
    5077                 :       3908 :   np = new_level (cp);
    5078                 :       3908 :   np->op = cp->op;
    5079                 :       3908 :   np->block = NULL;
    5080                 :       3908 :   switch (acc_st)
    5081                 :            :     {
    5082                 :            :     case ST_OACC_PARALLEL:
    5083                 :       3908 :       acc_end_st = ST_OACC_END_PARALLEL;
    5084                 :            :       break;
    5085                 :        747 :     case ST_OACC_KERNELS:
    5086                 :        747 :       acc_end_st = ST_OACC_END_KERNELS;
    5087                 :        747 :       break;
    5088                 :         12 :     case ST_OACC_SERIAL:
    5089                 :         12 :       acc_end_st = ST_OACC_END_SERIAL;
    5090                 :         12 :       break;
    5091                 :        541 :     case ST_OACC_DATA:
    5092                 :        541 :       acc_end_st = ST_OACC_END_DATA;
    5093                 :        541 :       break;
    5094                 :         59 :     case ST_OACC_HOST_DATA:
    5095                 :         59 :       acc_end_st = ST_OACC_END_HOST_DATA;
    5096                 :         59 :       break;
    5097                 :          0 :     default:
    5098                 :          0 :       gcc_unreachable ();
    5099                 :            :     }
    5100                 :            : 
    5101                 :       3908 :   do
    5102                 :            :     {
    5103                 :       3908 :       st = parse_executable (ST_NONE);
    5104                 :       3908 :       if (st == ST_NONE)
    5105                 :          0 :         unexpected_eof ();
    5106                 :       3908 :       else if (st != acc_end_st)
    5107                 :            :         {
    5108                 :          0 :           gfc_error ("Expecting %s at %C", gfc_ascii_statement (acc_end_st));
    5109                 :          0 :           reject_statement ();
    5110                 :            :         }
    5111                 :            :     }
    5112                 :       3908 :   while (st != acc_end_st);
    5113                 :            : 
    5114                 :       3908 :   gcc_assert (new_st.op == EXEC_NOP);
    5115                 :            : 
    5116                 :       3908 :   gfc_clear_new_st ();
    5117                 :       3908 :   gfc_commit_symbols ();
    5118                 :       3908 :   gfc_warning_check ();
    5119                 :       3908 :   pop_state ();
    5120                 :       3908 : }
    5121                 :            : 
    5122                 :            : /* Parse the statements of OpenACC 'loop', or combined compute 'loop'.  */
    5123                 :            : 
    5124                 :            : static gfc_statement
    5125                 :       4397 : parse_oacc_loop (gfc_statement acc_st)
    5126                 :            : {
    5127                 :       4397 :   gfc_statement st;
    5128                 :       4397 :   gfc_code *cp, *np;
    5129                 :       4397 :   gfc_state_data s, *sd;
    5130                 :            : 
    5131                 :      19619 :   for (sd = gfc_state_stack; sd; sd = sd->previous)
    5132                 :      15222 :     if (sd->state == COMP_CRITICAL)
    5133                 :          0 :       gfc_error_now ("OpenACC directive inside of CRITICAL block at %C");
    5134                 :            : 
    5135                 :       4397 :   accept_statement (acc_st);
    5136                 :            : 
    5137                 :       4397 :   cp = gfc_state_stack->tail;
    5138                 :       4397 :   push_state (&s, COMP_OMP_STRUCTURED_BLOCK, NULL);
    5139                 :       4397 :   np = new_level (cp);
    5140                 :       4397 :   np->op = cp->op;
    5141                 :       4397 :   np->block = NULL;
    5142                 :            : 
    5143                 :       4403 :   for (;;)
    5144                 :            :     {
    5145                 :       4400 :       st = next_statement ();
    5146                 :       4400 :       if (st == ST_NONE)
    5147                 :          0 :         unexpected_eof ();
    5148                 :       4400 :       else if (st == ST_DO)
    5149                 :            :         break;
    5150                 :            :       else
    5151                 :            :         {
    5152                 :          3 :           gfc_error ("Expected DO loop at %C");
    5153                 :          3 :           reject_statement ();
    5154                 :            :         }
    5155                 :            :     }
    5156                 :            : 
    5157                 :       4397 :   parse_do_block ();
    5158                 :       4397 :   if (gfc_statement_label != NULL
    5159                 :         80 :       && gfc_state_stack->previous != NULL
    5160                 :         80 :       && gfc_state_stack->previous->state == COMP_DO
    5161                 :          0 :       && gfc_state_stack->previous->ext.end_do_label == gfc_statement_label)
    5162                 :            :     {
    5163                 :          0 :       pop_state ();
    5164                 :          0 :       return ST_IMPLIED_ENDDO;
    5165                 :            :     }
    5166                 :            : 
    5167                 :       4397 :   check_do_closure ();
    5168                 :       4397 :   pop_state ();
    5169                 :            : 
    5170                 :       4397 :   st = next_statement ();
    5171                 :       4397 :   if (st == ST_OACC_END_LOOP)
    5172                 :          2 :     gfc_warning (0, "Redundant !$ACC END LOOP at %C");
    5173                 :       4397 :   if ((acc_st == ST_OACC_PARALLEL_LOOP && st == ST_OACC_END_PARALLEL_LOOP) ||
    5174                 :       3482 :       (acc_st == ST_OACC_KERNELS_LOOP && st == ST_OACC_END_KERNELS_LOOP) ||
    5175                 :       3460 :       (acc_st == ST_OACC_SERIAL_LOOP && st == ST_OACC_END_SERIAL_LOOP) ||
    5176                 :       3460 :       (acc_st == ST_OACC_LOOP && st == ST_OACC_END_LOOP))
    5177                 :            :     {
    5178                 :        939 :       gcc_assert (new_st.op == EXEC_NOP);
    5179                 :        939 :       gfc_clear_new_st ();
    5180                 :        939 :       gfc_commit_symbols ();
    5181                 :        939 :       gfc_warning_check ();
    5182                 :        939 :       st = next_statement ();
    5183                 :            :     }
    5184                 :            :   return st;
    5185                 :            : }
    5186                 :            : 
    5187                 :            : 
    5188                 :            : /* Parse the statements of an OpenMP structured block.  */
    5189                 :            : 
    5190                 :            : static void
    5191                 :       4834 : parse_omp_structured_block (gfc_statement omp_st, bool workshare_stmts_only)
    5192                 :            : {
    5193                 :       4834 :   gfc_statement st, omp_end_st;
    5194                 :       4834 :   gfc_code *cp, *np;
    5195                 :       4834 :   gfc_state_data s;
    5196                 :            : 
    5197                 :       4834 :   accept_statement (omp_st);
    5198                 :            : 
    5199                 :       4834 :   cp = gfc_state_stack->tail;
    5200                 :       4834 :   push_state (&s, COMP_OMP_STRUCTURED_BLOCK, NULL);
    5201                 :       4834 :   np = new_level (cp);
    5202                 :       4834 :   np->op = cp->op;
    5203                 :       4834 :   np->block = NULL;
    5204                 :            : 
    5205                 :       4834 :   switch (omp_st)
    5206                 :            :     {
    5207                 :            :     case ST_OMP_PARALLEL:
    5208                 :       4834 :       omp_end_st = ST_OMP_END_PARALLEL;
    5209                 :            :       break;
    5210                 :         48 :     case ST_OMP_PARALLEL_SECTIONS:
    5211                 :         48 :       omp_end_st = ST_OMP_END_PARALLEL_SECTIONS;
    5212                 :         48 :       break;
    5213                 :         32 :     case ST_OMP_SECTIONS:
    5214                 :         32 :       omp_end_st = ST_OMP_END_SECTIONS;
    5215                 :         32 :       break;
    5216                 :        171 :     case ST_OMP_ORDERED:
    5217                 :        171 :       omp_end_st = ST_OMP_END_ORDERED;
    5218                 :        171 :       break;
    5219                 :         56 :     case ST_OMP_CRITICAL:
    5220                 :         56 :       omp_end_st = ST_OMP_END_CRITICAL;
    5221                 :         56 :       break;
    5222                 :         75 :     case ST_OMP_MASTER:
    5223                 :         75 :       omp_end_st = ST_OMP_END_MASTER;
    5224                 :         75 :       break;
    5225                 :        447 :     case ST_OMP_SINGLE:
    5226                 :        447 :       omp_end_st = ST_OMP_END_SINGLE;
    5227                 :        447 :       break;
    5228                 :        425 :     case ST_OMP_TARGET:
    5229                 :        425 :       omp_end_st = ST_OMP_END_TARGET;
    5230                 :        425 :       break;
    5231                 :       1256 :     case ST_OMP_TARGET_DATA:
    5232                 :       1256 :       omp_end_st = ST_OMP_END_TARGET_DATA;
    5233                 :       1256 :       break;
    5234                 :          2 :     case ST_OMP_TARGET_PARALLEL:
    5235                 :          2 :       omp_end_st = ST_OMP_END_TARGET_PARALLEL;
    5236                 :          2 :       break;
    5237                 :         37 :     case ST_OMP_TARGET_TEAMS:
    5238                 :         37 :       omp_end_st = ST_OMP_END_TARGET_TEAMS;
    5239                 :         37 :       break;
    5240                 :          0 :     case ST_OMP_TARGET_TEAMS_DISTRIBUTE:
    5241                 :          0 :       omp_end_st = ST_OMP_END_TARGET_TEAMS_DISTRIBUTE;
    5242                 :          0 :       break;
    5243                 :          0 :     case ST_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO:
    5244                 :          0 :       omp_end_st = ST_OMP_END_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO;
    5245                 :          0 :       break;
    5246                 :          0 :     case ST_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD:
    5247                 :          0 :       omp_end_st = ST_OMP_END_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD;
    5248                 :          0 :       break;
    5249                 :          0 :     case ST_OMP_TARGET_TEAMS_DISTRIBUTE_SIMD:
    5250                 :          0 :       omp_end_st = ST_OMP_END_TARGET_TEAMS_DISTRIBUTE_SIMD;
    5251                 :          0 :       break;
    5252                 :        518 :     case ST_OMP_TASK:
    5253                 :        518 :       omp_end_st = ST_OMP_END_TASK;
    5254                 :        518 :       break;
    5255                 :         93 :     case ST_OMP_TASKGROUP:
    5256                 :         93 :       omp_end_st = ST_OMP_END_TASKGROUP;
    5257                 :         93 :       break;
    5258                 :         19 :     case ST_OMP_TEAMS:
    5259                 :         19 :       omp_end_st = ST_OMP_END_TEAMS;
    5260                 :         19 :       break;
    5261                 :          0 :     case ST_OMP_TEAMS_DISTRIBUTE:
    5262                 :          0 :       omp_end_st = ST_OMP_END_TEAMS_DISTRIBUTE;
    5263                 :          0 :       break;
    5264                 :          0 :     case ST_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO:
    5265                 :          0 :       omp_end_st = ST_OMP_END_TEAMS_DISTRIBUTE_PARALLEL_DO;
    5266                 :          0 :       break;
    5267                 :          0 :     case ST_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD:
    5268                 :          0 :       omp_end_st = ST_OMP_END_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD;
    5269                 :          0 :       break;
    5270                 :          0 :     case ST_OMP_TEAMS_DISTRIBUTE_SIMD:
    5271                 :          0 :       omp_end_st = ST_OMP_END_TEAMS_DISTRIBUTE_SIMD;
    5272                 :          0 :       break;
    5273                 :          0 :     case ST_OMP_DISTRIBUTE:
    5274                 :          0 :       omp_end_st = ST_OMP_END_DISTRIBUTE;
    5275                 :          0 :       break;
    5276                 :          0 :     case ST_OMP_DISTRIBUTE_PARALLEL_DO:
    5277                 :          0 :       omp_end_st = ST_OMP_END_DISTRIBUTE_PARALLEL_DO;
    5278                 :          0 :       break;
    5279                 :          0 :     case ST_OMP_DISTRIBUTE_PARALLEL_DO_SIMD:
    5280                 :          0 :       omp_end_st = ST_OMP_END_DISTRIBUTE_PARALLEL_DO_SIMD;
    5281                 :          0 :       break;
    5282                 :          0 :     case ST_OMP_DISTRIBUTE_SIMD:
    5283                 :          0 :       omp_end_st = ST_OMP_END_DISTRIBUTE_SIMD;
    5284                 :          0 :       break;
    5285                 :         31 :     case ST_OMP_WORKSHARE:
    5286                 :         31 :       omp_end_st = ST_OMP_END_WORKSHARE;
    5287                 :         31 :       break;
    5288                 :         49 :     case ST_OMP_PARALLEL_WORKSHARE:
    5289                 :         49 :       omp_end_st = ST_OMP_END_PARALLEL_WORKSHARE;
    5290                 :         49 :       break;
    5291                 :          0 :     default:
    5292                 :          0 :       gcc_unreachable ();
    5293                 :            :     }
    5294                 :            : 
    5295                 :       5028 :   do
    5296                 :            :     {
    5297                 :       5028 :       if (workshare_stmts_only)
    5298                 :            :         {
    5299                 :            :           /* Inside of !$omp workshare, only
    5300                 :            :              scalar assignments
    5301                 :            :              array assignments
    5302                 :            :              where statements and constructs
    5303                 :            :              forall statements and constructs
    5304                 :            :              !$omp atomic
    5305                 :            :              !$omp critical
    5306                 :            :              !$omp parallel
    5307                 :            :              are allowed.  For !$omp critical these
    5308                 :            :              restrictions apply recursively.  */
    5309                 :         94 :           bool cycle = true;
    5310                 :            : 
    5311                 :         94 :           st = next_statement ();
    5312                 :        306 :           for (;;)
    5313                 :            :             {
    5314                 :        306 :               switch (st)
    5315                 :            :                 {
    5316                 :          0 :                 case ST_NONE:
    5317                 :          0 :                   unexpected_eof ();
    5318                 :            : 
    5319                 :        160 :                 case ST_ASSIGNMENT:
    5320                 :        160 :                 case ST_WHERE:
    5321                 :        160 :                 case ST_FORALL:
    5322                 :        160 :                   accept_statement (st);
    5323                 :        160 :                   break;
    5324                 :            : 
    5325                 :          6 :                 case ST_WHERE_BLOCK:
    5326                 :          6 :                   parse_where_block ();
    5327                 :          6 :                   break;
    5328                 :            : 
    5329                 :         12 :                 case ST_FORALL_BLOCK:
    5330                 :         12 :                   parse_forall_block ();
    5331                 :         12 :                   break;
    5332                 :            : 
    5333                 :         12 :                 case ST_OMP_PARALLEL:
    5334                 :         12 :                 case ST_OMP_PARALLEL_SECTIONS:
    5335                 :         12 :                   parse_omp_structured_block (st, false);
    5336                 :         12 :                   break;
    5337                 :            : 
    5338                 :         13 :                 case ST_OMP_PARALLEL_WORKSHARE:
    5339                 :         13 :                 case ST_OMP_CRITICAL:
    5340                 :         13 :                   parse_omp_structured_block (st, true);
    5341                 :         13 :                   break;
    5342                 :            : 
    5343                 :          1 :                 case ST_OMP_PARALLEL_DO:
    5344                 :          1 :                 case ST_OMP_PARALLEL_DO_SIMD:
    5345                 :          1 :                   st = parse_omp_do (st);
    5346                 :          1 :                   continue;
    5347                 :            : 
    5348                 :          8 :                 case ST_OMP_ATOMIC:
    5349                 :          8 :                   st = parse_omp_oacc_atomic (true);
    5350                 :          8 :                   continue;
    5351                 :            : 
    5352                 :            :                 default:
    5353                 :            :                   cycle = false;
    5354                 :            :                   break;
    5355                 :            :                 }
    5356                 :            : 
    5357                 :        203 :               if (!cycle)
    5358                 :            :                 break;
    5359                 :            : 
    5360                 :        203 :               st = next_statement ();
    5361                 :            :             }
    5362                 :            :         }
    5363                 :            :       else
    5364                 :       4934 :         st = parse_executable (ST_NONE);
    5365                 :       5026 :       if (st == ST_NONE)
    5366                 :          0 :         unexpected_eof ();
    5367                 :       5026 :       else if (st == ST_OMP_SECTION
    5368                 :        192 :                && (omp_st == ST_OMP_SECTIONS
    5369                 :        192 :                    || omp_st == ST_OMP_PARALLEL_SECTIONS))
    5370                 :            :         {
    5371                 :        192 :           np = new_level (np);
    5372                 :        192 :           np->op = cp->op;
    5373                 :        192 :           np->block = NULL;
    5374                 :            :         }
    5375                 :       4834 :       else if (st != omp_end_st)
    5376                 :          2 :         unexpected_statement (st);
    5377                 :            :     }
    5378                 :       5026 :   while (st != omp_end_st);
    5379                 :            : 
    5380                 :       4832 :   switch (new_st.op)
    5381                 :            :     {
    5382                 :         95 :     case EXEC_OMP_END_NOWAIT:
    5383                 :         95 :       cp->ext.omp_clauses->nowait |= new_st.ext.omp_bool;
    5384                 :         95 :       break;
    5385                 :         56 :     case EXEC_OMP_END_CRITICAL:
    5386                 :         56 :       if (((cp->ext.omp_clauses == NULL) ^ (new_st.ext.omp_name == NULL))
    5387                 :         56 :           || (new_st.ext.omp_name != NULL
    5388                 :         23 :               && strcmp (cp->ext.omp_clauses->critical_name,
    5389                 :            :                          new_st.ext.omp_name) != 0))
    5390                 :          0 :         gfc_error ("Name after !$omp critical and !$omp end critical does "
    5391                 :            :                    "not match at %C");
    5392                 :         56 :       free (CONST_CAST (char *, new_st.ext.omp_name));
    5393                 :         56 :       new_st.ext.omp_name = NULL;
    5394                 :         56 :       break;
    5395                 :        414 :     case EXEC_OMP_END_SINGLE:
    5396                 :        414 :       cp->ext.omp_clauses->lists[OMP_LIST_COPYPRIVATE]
    5397                 :        414 :         = new_st.ext.omp_clauses->lists[OMP_LIST_COPYPRIVATE];
    5398                 :        414 :       new_st.ext.omp_clauses->lists[OMP_LIST_COPYPRIVATE] = NULL;
    5399                 :        414 :       gfc_free_omp_clauses (new_st.ext.omp_clauses);
    5400                 :        414 :       break;
    5401                 :            :     case EXEC_NOP:
    5402                 :            :       break;
    5403                 :          0 :     default:
    5404                 :          0 :       gcc_unreachable ();
    5405                 :            :     }
    5406                 :            : 
    5407                 :       4832 :   gfc_clear_new_st ();
    5408                 :       4832 :   gfc_commit_symbols ();
    5409                 :       4832 :   gfc_warning_check ();
    5410                 :       4832 :   pop_state ();
    5411                 :       4832 : }
    5412                 :            : 
    5413                 :            : 
    5414                 :            : /* Accept a series of executable statements.  We return the first
    5415                 :            :    statement that doesn't fit to the caller.  Any block statements are
    5416                 :            :    passed on to the correct handler, which usually passes the buck
    5417                 :            :    right back here.  */
    5418                 :            : 
    5419                 :            : static gfc_statement
    5420                 :     102119 : parse_executable (gfc_statement st)
    5421                 :            : {
    5422                 :     102119 :   int close_flag;
    5423                 :            : 
    5424                 :     102119 :   if (st == ST_NONE)
    5425                 :      51036 :     st = next_statement ();
    5426                 :            : 
    5427                 :     523900 :   for (;;)
    5428                 :            :     {
    5429                 :     523900 :       close_flag = check_do_closure ();
    5430                 :     523900 :       if (close_flag)
    5431                 :       1649 :         switch (st)
    5432                 :            :           {
    5433                 :          0 :           case ST_GOTO:
    5434                 :          0 :           case ST_END_PROGRAM:
    5435                 :          0 :           case ST_RETURN:
    5436                 :          0 :           case ST_EXIT:
    5437                 :          0 :           case ST_END_FUNCTION:
    5438                 :          0 :           case ST_CYCLE:
    5439                 :          0 :           case ST_PAUSE:
    5440                 :          0 :           case ST_STOP:
    5441                 :          0 :           case ST_ERROR_STOP:
    5442                 :          0 :           case ST_END_SUBROUTINE:
    5443                 :            : 
    5444                 :          0 :           case ST_DO:
    5445                 :          0 :           case ST_FORALL:
    5446                 :          0 :           case ST_WHERE:
    5447                 :          0 :           case ST_SELECT_CASE:
    5448                 :          0 :             gfc_error ("%s statement at %C cannot terminate a non-block "
    5449                 :            :                        "DO loop", gfc_ascii_statement (st));
    5450                 :          0 :             break;
    5451                 :            : 
    5452                 :            :           default:
    5453                 :            :             break;
    5454                 :            :           }
    5455                 :            : 
    5456                 :     523900 :       switch (st)
    5457                 :            :         {
    5458                 :          8 :         case ST_NONE:
    5459                 :          8 :           unexpected_eof ();
    5460                 :            : 
    5461                 :         23 :         case ST_DATA:
    5462                 :         23 :           gfc_notify_std (GFC_STD_F95_OBS, "DATA statement at %C after the "
    5463                 :            :                           "first executable statement");
    5464                 :            :           /* Fall through.  */
    5465                 :            : 
    5466                 :     376509 :         case ST_FORMAT:
    5467                 :     376509 :         case ST_ENTRY:
    5468                 :     376509 :         case_executable:
    5469                 :     376509 :           accept_statement (st);
    5470                 :     376509 :           if (close_flag == 1)
    5471                 :            :             return ST_IMPLIED_ENDDO;
    5472                 :            :           break;
    5473                 :            : 
    5474                 :        442 :         case ST_BLOCK:
    5475                 :        442 :           parse_block_construct ();
    5476                 :        442 :           break;
    5477                 :            : 
    5478                 :        637 :         case ST_ASSOCIATE:
    5479                 :        637 :           parse_associate ();
    5480                 :        637 :           break;
    5481                 :            : 
    5482                 :       9705 :         case ST_IF_BLOCK:
    5483                 :       9705 :           parse_if_block ();
    5484                 :       9705 :           break;
    5485                 :            : 
    5486                 :        506 :         case ST_SELECT_CASE:
    5487                 :        506 :           parse_select_block ();
    5488                 :        506 :           break;
    5489                 :            : 
    5490                 :       1889 :         case ST_SELECT_TYPE:
    5491                 :       1889 :           parse_select_type_block ();
    5492                 :       1889 :           break;
    5493                 :            : 
    5494                 :         42 :         case ST_SELECT_RANK:
    5495                 :         42 :           parse_select_rank_block ();
    5496                 :         42 :           break;
    5497                 :            : 
    5498                 :      16489 :         case ST_DO:
    5499                 :      16489 :           parse_do_block ();
    5500                 :      16487 :           if (check_do_closure () == 1)
    5501                 :            :             return ST_IMPLIED_ENDDO;
    5502                 :            :           break;
    5503                 :            : 
    5504                 :         33 :         case ST_CRITICAL:
    5505                 :         33 :           parse_critical_block ();
    5506                 :         33 :           break;
    5507                 :            : 
    5508                 :        284 :         case ST_WHERE_BLOCK:
    5509                 :        284 :           parse_where_block ();
    5510                 :        284 :           break;
    5511                 :            : 
    5512                 :        392 :         case ST_FORALL_BLOCK:
    5513                 :        392 :           parse_forall_block ();
    5514                 :        392 :           break;
    5515                 :            : 
    5516                 :       4397 :         case ST_OACC_PARALLEL_LOOP:
    5517                 :       4397 :         case ST_OACC_KERNELS_LOOP:
    5518                 :       4397 :         case ST_OACC_SERIAL_LOOP:
    5519                 :       4397 :         case ST_OACC_LOOP:
    5520                 :       4397 :           st = parse_oacc_loop (st);
    5521                 :       4397 :           if (st == ST_IMPLIED_ENDDO)
    5522                 :            :             return st;
    5523                 :       4397 :           continue;
    5524                 :            : 
    5525                 :       3908 :         case ST_OACC_PARALLEL:
    5526                 :       3908 :         case ST_OACC_KERNELS:
    5527                 :       3908 :         case ST_OACC_SERIAL:
    5528                 :       3908 :         case ST_OACC_DATA:
    5529                 :       3908 :         case ST_OACC_HOST_DATA:
    5530                 :       3908 :           parse_oacc_structured_block (st);
    5531                 :       3908 :           break;
    5532                 :            : 
    5533                 :       4729 :         case ST_OMP_PARALLEL:
    5534                 :       4729 :         case ST_OMP_PARALLEL_SECTIONS:
    5535                 :       4729 :         case ST_OMP_SECTIONS:
    5536                 :       4729 :         case ST_OMP_ORDERED:
    5537                 :       4729 :         case ST_OMP_CRITICAL:
    5538                 :       4729 :         case ST_OMP_MASTER:
    5539                 :       4729 :         case ST_OMP_SINGLE:
    5540                 :       4729 :         case ST_OMP_TARGET:
    5541                 :       4729 :         case ST_OMP_TARGET_DATA:
    5542                 :       4729 :         case ST_OMP_TARGET_PARALLEL:
    5543                 :       4729 :         case ST_OMP_TARGET_TEAMS:
    5544                 :       4729 :         case ST_OMP_TEAMS:
    5545                 :       4729 :         case ST_OMP_TASK:
    5546                 :       4729 :         case ST_OMP_TASKGROUP:
    5547                 :       4729 :           parse_omp_structured_block (st, false);
    5548                 :       4729 :           break;
    5549                 :            : 
    5550                 :         80 :         case ST_OMP_WORKSHARE:
    5551                 :         80 :         case ST_OMP_PARALLEL_WORKSHARE:
    5552                 :         80 :           parse_omp_structured_block (st, true);
    5553                 :         80 :           break;
    5554                 :            : 
    5555                 :       2224 :         case ST_OMP_DISTRIBUTE:
    5556                 :       2224 :         case ST_OMP_DISTRIBUTE_PARALLEL_DO:
    5557                 :       2224 :         case ST_OMP_DISTRIBUTE_PARALLEL_DO_SIMD:
    5558                 :       2224 :         case ST_OMP_DISTRIBUTE_SIMD:
    5559                 :       2224 :         case ST_OMP_DO:
    5560                 :       2224 :         case ST_OMP_DO_SIMD:
    5561                 :       2224 :         case ST_OMP_PARALLEL_DO:
    5562                 :       2224 :         case ST_OMP_PARALLEL_DO_SIMD:
    5563                 :       2224 :         case ST_OMP_SIMD:
    5564                 :       2224 :         case ST_OMP_TARGET_PARALLEL_DO:
    5565                 :       2224 :         case ST_OMP_TARGET_PARALLEL_DO_SIMD:
    5566                 :       2224 :         case ST_OMP_TARGET_SIMD:
    5567                 :       2224 :         case ST_OMP_TARGET_TEAMS_DISTRIBUTE:
    5568                 :       2224 :         case ST_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO:
    5569                 :       2224 :         case ST_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD:
    5570                 :       2224 :         case ST_OMP_TARGET_TEAMS_DISTRIBUTE_SIMD:
    5571                 :       2224 :         case ST_OMP_TASKLOOP:
    5572                 :       2224 :         case ST_OMP_TASKLOOP_SIMD:
    5573                 :       2224 :         case ST_OMP_TEAMS_DISTRIBUTE:
    5574                 :       2224 :         case ST_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO:
    5575                 :       2224 :         case ST_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD:
    5576                 :       2224 :         case ST_OMP_TEAMS_DISTRIBUTE_SIMD:
    5577                 :       2224 :           st = parse_omp_do (st);
    5578                 :       2224 :           if (st == ST_IMPLIED_ENDDO)
    5579                 :            :             return st;
    5580                 :       2222 :           continue;
    5581                 :            : 
    5582                 :        517 :         case ST_OACC_ATOMIC:
    5583                 :        517 :           st = parse_omp_oacc_atomic (false);
    5584                 :        517 :           continue;
    5585                 :            : 
    5586                 :       1115 :         case ST_OMP_ATOMIC:
    5587                 :       1115 :           st = parse_omp_oacc_atomic (true);
    5588                 :       1115 :           continue;
    5589                 :            : 
    5590                 :            :         default:
    5591                 :            :           return st;
    5592                 :            :         }
    5593                 :            : 
    5594                 :     413531 :       if (directive_unroll != -1)
    5595                 :          1 :         gfc_error ("%<GCC unroll%> directive not at the start of a loop at %C");
    5596                 :            : 
    5597                 :     413531 :       if (directive_ivdep)
    5598                 :          0 :         gfc_error ("%<GCC ivdep%> directive not at the start of a loop at %C");
    5599                 :            : 
    5600                 :     413531 :       if (directive_vector)
    5601                 :          0 :         gfc_error ("%<GCC vector%> directive not at the start of a loop at %C");
    5602                 :            : 
    5603                 :     413531 :       if (directive_novector)
    5604                 :          0 :         gfc_error ("%<GCC novector%> "
    5605                 :            :                    "directive not at the start of a loop at %C");
    5606                 :            : 
    5607                 :     413531 :       st = next_statement ();
    5608                 :            :     }
    5609                 :            : }
    5610                 :            : 
    5611                 :            : 
    5612                 :            : /* Fix the symbols for sibling functions.  These are incorrectly added to
    5613                 :            :    the child namespace as the parser didn't know about this procedure.  */
    5614                 :            : 
    5615                 :            : static void
    5616                 :      89981 : gfc_fixup_sibling_symbols (gfc_symbol *sym, gfc_namespace *siblings)
    5617                 :            : {
    5618                 :      89981 :   gfc_namespace *ns;
    5619                 :      89981 :   gfc_symtree *st;
    5620                 :      89981 :   gfc_symbol *old_sym;
    5621                 :            : 
    5622                 :     157688 :   for (ns = siblings; ns; ns = ns->sibling)
    5623                 :            :     {
    5624                 :      67707 :       st = gfc_find_symtree (ns->sym_root, sym->name);
    5625                 :            : 
    5626                 :      67707 :       if (!st || (st->n.sym->attr.dummy && ns == st->n.sym->ns))
    5627                 :      43948 :         goto fixup_contained;
    5628                 :            : 
    5629                 :      23759 :       if ((st->n.sym->attr.flavor == FL_DERIVED
    5630                 :          0 :            && sym->attr.generic && sym->attr.function)
    5631                 :      23759 :           ||(sym->attr.flavor == FL_DERIVED
    5632                 :          0 :              && st->n.sym->attr.generic && st->n.sym->attr.function))
    5633                 :          0 :         goto fixup_contained;
    5634                 :            : 
    5635                 :      23759 :       old_sym = st->n.sym;
    5636                 :      23759 :       if (old_sym->ns == ns
    5637                 :       1681 :             && !old_sym->attr.contained
    5638                 :            : 
    5639                 :            :             /* By 14.6.1.3, host association should be excluded
    5640                 :            :                for the following.  */
    5641                 :       3186 :             && !(old_sym->attr.external
    5642                 :       1672 :                   || (old_sym->ts.type != BT_UNKNOWN
    5643                 :       1813 :                         && !old_sym->attr.implicit_type)
    5644                 :       1531 :                   || old_sym->attr.flavor == FL_PARAMETER
    5645                 :            :                   || old_sym->attr.use_assoc
    5646                 :            :                   || old_sym->attr.in_common
    5647                 :            :                   || old_sym->attr.in_equivalence
    5648                 :            :                   || old_sym->attr.data
    5649                 :            :                   || old_sym->attr.dummy
    5650                 :            :                   || old_sym->attr.result
    5651                 :            :                   || old_sym->attr.dimension
    5652                 :            :                   || old_sym->attr.allocatable
    5653                 :            :                   || old_sym->attr.intrinsic
    5654                 :       1531 :                   || old_sym->attr.generic
    5655                 :       1516 :                   || old_sym->attr.flavor == FL_NAMELIST
    5656                 :       1515 :                   || old_sym->attr.flavor == FL_LABEL
    5657                 :       1514 :                   || old_sym->attr.proc == PROC_ST_FUNCTION))
    5658                 :            :         {
    5659                 :            :           /* Replace it with the symbol from the parent namespace.  */
    5660                 :       1514 :           st->n.sym = sym;
    5661                 :       1514 :           sym->refs++;
    5662                 :            : 
    5663                 :       1514 :           gfc_release_symbol (old_sym);
    5664                 :            :         }
    5665                 :            : 
    5666                 :      22245 : fixup_contained:
    5667                 :            :       /* Do the same for any contained procedures.  */
    5668                 :      67707 :       gfc_fixup_sibling_symbols (sym, ns->contained);
    5669                 :            :     }
    5670                 :      89981 : }
    5671                 :            : 
    5672                 :            : static void
    5673                 :      10882 : parse_contained (int module)
    5674                 :            : {
    5675                 :      10882 :   gfc_namespace *ns, *parent_ns, *tmp;
    5676                 :      10882 :   gfc_state_data s1, s2;
    5677                 :      10882 :   gfc_statement st;
    5678                 :      10882 :   gfc_symbol *sym;
    5679                 :      10882 :   gfc_entry_list *el;
    5680                 :      10882 :   locus old_loc;
    5681                 :      10882 :   int contains_statements = 0;
    5682                 :      10882 :   int seen_error = 0;
    5683                 :            : 
    5684                 :      10882 :   push_state (&s1, COMP_CONTAINS, NULL);
    5685                 :      10882 :   parent_ns = gfc_current_ns;
    5686                 :            : 
    5687                 :      32951 :   do
    5688                 :            :     {
    5689                 :      32951 :       gfc_current_ns = gfc_get_namespace (parent_ns, 1);
    5690                 :            : 
    5691                 :      32951 :       gfc_current_ns->sibling = parent_ns->contained;
    5692                 :      32951 :       parent_ns->contained = gfc_current_ns;
    5693                 :            : 
    5694                 :      32974 :  next:
    5695                 :            :       /* Process the next available statement.  We come here if we got an error
    5696                 :            :          and rejected the last statement.  */
    5697                 :      32974 :       old_loc = gfc_current_locus;
    5698                 :      32974 :       st = next_statement ();
    5699                 :            : 
    5700                 :      32973 :       switch (st)
    5701                 :            :         {
    5702                 :          1 :         case ST_NONE:
    5703                 :          1 :           unexpected_eof ();
    5704                 :            : 
    5705                 :      22069 :         case ST_FUNCTION:
    5706                 :      22069 :         case ST_SUBROUTINE:
    5707                 :      22069 :           contains_statements = 1;
    5708                 :      22069 :           accept_statement (st);
    5709                 :            : 
    5710                 :      36742 :           push_state (&s2,
    5711                 :            :                       (st == ST_FUNCTION) ? COMP_FUNCTION : COMP_SUBROUTINE,
    5712                 :            :                       gfc_new_block);
    5713                 :            : 
    5714                 :            :           /* For internal procedures, create/update the symbol in the
    5715                 :            :              parent namespace.  */
    5716                 :            : 
    5717                 :      22069 :           if (!module)
    5718                 :            :             {
    5719                 :      11014 :               if (gfc_get_symbol (gfc_new_block->name, parent_ns, &sym))
    5720                 :          0 :                 gfc_error ("Contained procedure %qs at %C is already "
    5721                 :            :                            "ambiguous", gfc_new_block->name);
    5722                 :            :               else
    5723                 :            :                 {
    5724                 :      11014 :                   if (gfc_add_procedure (&sym->attr, PROC_INTERNAL,
    5725                 :            :                                          sym->name,
    5726                 :      11014 :                                          &gfc_new_block->declared_at))
    5727                 :            :                     {
    5728                 :      11014 :                       if (st == ST_FUNCTION)
    5729                 :       3481 :                         gfc_add_function (&sym->attr, sym->name,
    5730                 :       3481 :                                           &gfc_new_block->declared_at);
    5731                 :            :                       else
    5732                 :       7533 :                         gfc_add_subroutine (&sym->attr, sym->name,
    5733                 :       7533 :                                             &gfc_new_block->declared_at);
    5734                 :            :                     }
    5735                 :            :                 }
    5736                 :            : 
    5737                 :      11014 :               gfc_commit_symbols ();
    5738                 :            :             }
    5739                 :            :           else
    5740                 :      11055 :             sym = gfc_new_block;
    5741                 :            : 
    5742                 :            :           /* Mark this as a contained function, so it isn't replaced
    5743                 :            :              by other module functions.  */
    5744                 :      22069 :           sym->attr.contained = 1;
    5745                 :            : 
    5746                 :            :           /* Set implicit_pure so that it can be reset if any of the
    5747                 :            :              tests for purity fail.  This is used for some optimisation
    5748                 :            :              during translation.  */
    5749                 :      22069 :           if (!sym->attr.pure)
    5750                 :      20434 :             sym->attr.implicit_pure = 1;
    5751                 :            : 
    5752                 :      22069 :           parse_progunit (ST_NONE);
    5753                 :            : 
    5754                 :            :           /* Fix up any sibling functions that refer to this one.  */
    5755                 :      22069 :           gfc_fixup_sibling_symbols (sym, gfc_current_ns);
    5756                 :            :           /* Or refer to any of its alternate entry points.  */
    5757                 :      22274 :           for (el = gfc_current_ns->entries; el; el = el->next)
    5758                 :        205 :             gfc_fixup_sibling_symbols (el->sym, gfc_current_ns);
    5759                 :            : 
    5760                 :      22069 :           gfc_current_ns->code = s2.head;
    5761                 :      22069 :           gfc_current_ns = parent_ns;
    5762                 :            : 
    5763                 :      22069 :           pop_state ();
    5764                 :            :           break;
    5765                 :            : 
    5766                 :            :         /* These statements are associated with the end of the host unit.  */
    5767                 :      10880 :         case ST_END_FUNCTION:
    5768                 :      10880 :         case ST_END_MODULE:
    5769                 :      10880 :         case ST_END_SUBMODULE:
    5770                 :      10880 :         case ST_END_PROGRAM:
    5771                 :      10880 :         case ST_END_SUBROUTINE:
    5772                 :      10880 :           accept_statement (st);
    5773                 :      10880 :           gfc_current_ns->code = s1.head;
    5774                 :      10880 :           break;
    5775                 :            : 
    5776                 :         23 :         default:
    5777                 :         23 :           gfc_error ("Unexpected %s statement in CONTAINS section at %C",
    5778                 :            :                      gfc_ascii_statement (st));
    5779                 :         23 :           reject_statement ();
    5780                 :         23 :           seen_error = 1;
    5781                 :         23 :           goto next;
    5782                 :      32949 :           break;
    5783                 :            :         }
    5784                 :            :     }
    5785                 :      32949 :   while (st != ST_END_FUNCTION && st != ST_END_SUBROUTINE
    5786                 :      32351 :          && st != ST_END_MODULE && st != ST_END_SUBMODULE
    5787                 :      59854 :          && st != ST_END_PROGRAM);
    5788                 :            : 
    5789                 :            :   /* The first namespace in the list is guaranteed to not have
    5790                 :            :      anything (worthwhile) in it.  */
    5791                 :      10880 :   tmp = gfc_current_ns;
    5792                 :      10880 :   gfc_current_ns = parent_ns;
    5793                 :      10880 :   if (seen_error && tmp->refs > 1)
    5794                 :          0 :     gfc_free_namespace (tmp);
    5795                 :            : 
    5796                 :      10880 :   ns = gfc_current_ns->contained;
    5797                 :      10880 :   gfc_current_ns->contained = ns->sibling;
    5798                 :      10880 :   gfc_free_namespace (ns);
    5799                 :            : 
    5800                 :      10880 :   pop_state ();
    5801                 :      10880 :   if (!contains_statements)
    5802                 :         59 :     gfc_notify_std (GFC_STD_F2008, "CONTAINS statement without "
    5803                 :            :                     "FUNCTION or SUBROUTINE statement at %L", &old_loc);
    5804                 :      10880 : }
    5805                 :            : 
    5806                 :            : 
    5807                 :            : /* The result variable in a MODULE PROCEDURE needs to be created and
    5808                 :            :     its characteristics copied from the interface since it is neither
    5809                 :            :     declared in the procedure declaration nor in the specification
    5810                 :            :     part.  */
    5811                 :            : 
    5812                 :            : static void
    5813                 :         45 : get_modproc_result (void)
    5814                 :            : {
    5815                 :         45 :   gfc_symbol *proc;
    5816                 :         45 :   if (gfc_state_stack->previous
    5817                 :         45 :       && gfc_state_stack->previous->state == COMP_CONTAINS
    5818                 :         45 :       && gfc_state_stack->previous->previous->state == COMP_SUBMODULE)
    5819                 :            :     {
    5820                 :         39 :       proc = gfc_current_ns->proc_name ? gfc_current_ns->proc_name : NULL;
    5821                 :         39 :       if (proc != NULL
    5822                 :         39 :           && proc->attr.function
    5823                 :         39 :           && proc->tlink
    5824                 :         39 :           && proc->tlink->result
    5825                 :         39 :           && proc->tlink->result != proc->tlink)
    5826                 :            :         {
    5827                 :         15 :           gfc_copy_dummy_sym (&proc->result, proc->tlink->result, 1);
    5828                 :         15 :           gfc_set_sym_referenced (proc->result);
    5829                 :         15 :           proc->result->attr.if_source = IFSRC_DECL;
    5830                 :         15 :           gfc_commit_symbol (proc->result);
    5831                 :            :         }
    5832                 :            :     }
    5833                 :         45 : }
    5834                 :            : 
    5835                 :            : 
    5836                 :            : /* Parse a PROGRAM, SUBROUTINE, FUNCTION unit or BLOCK construct.  */
    5837                 :            : 
    5838                 :            : static void
    5839                 :      54175 : parse_progunit (gfc_statement st)
    5840                 :            : {
    5841                 :      54175 :   gfc_state_data *p;
    5842                 :      54175 :   int n;
    5843                 :            : 
    5844                 :      54175 :   gfc_adjust_builtins ();
    5845                 :            : 
    5846                 :      54175 :   if (gfc_new_block
    5847                 :      54175 :       && gfc_new_block->abr_modproc_decl
    5848                 :        135 :       && gfc_new_block->attr.function)
    5849                 :         45 :     get_modproc_result ();
    5850                 :            : 
    5851                 :      54175 :   st = parse_spec (st);
    5852                 :      54159 :   switch (st)
    5853                 :            :     {
    5854                 :          0 :     case ST_NONE:
    5855                 :          0 :       unexpected_eof ();
    5856                 :            : 
    5857                 :        147 :     case ST_CONTAINS:
    5858                 :            :       /* This is not allowed within BLOCK!  */
    5859                 :        147 :       if (gfc_current_state () != COMP_BLOCK)
    5860                 :        146 :         goto contains;
    5861                 :            :       break;
    5862                 :            : 
    5863                 :       3034 :     case_end:
    5864                 :       3034 :       accept_statement (st);
    5865                 :       3034 :       goto done;
    5866                 :            : 
    5867                 :            :     default:
    5868                 :            :       break;
    5869                 :            :     }
    5870                 :            : 
    5871                 :      50979 :   if (gfc_current_state () == COMP_FUNCTION)
    5872                 :       9517 :     gfc_check_function_type (gfc_current_ns);
    5873                 :            : 
    5874                 :      41462 : loop:
    5875                 :      51187 :   for (;;)
    5876                 :            :     {
    5877                 :      51083 :       st = parse_executable (st);
    5878                 :            : 
    5879                 :      51065 :       switch (st)
    5880                 :            :         {
    5881                 :          0 :         case ST_NONE:
    5882                 :          0 :           unexpected_eof ();
    5883                 :            : 
    5884                 :       5291 :         case ST_CONTAINS:
    5885                 :            :           /* This is not allowed within BLOCK!  */
    5886                 :       5291 :           if (gfc_current_state () != COMP_BLOCK)
    5887                 :       5289 :             goto contains;
    5888                 :            :           break;
    5889                 :            : 
    5890                 :      45672 :         case_end:
    5891                 :      45672 :           accept_statement (st);
    5892                 :      45672 :           goto done;
    5893                 :            : 
    5894                 :            :         default:
    5895                 :            :           break;
    5896                 :            :         }
    5897                 :            : 
    5898                 :        104 :       unexpected_statement (st);
    5899                 :        104 :       reject_statement ();
    5900                 :        104 :       st = next_statement ();
    5901                 :            :     }
    5902                 :            : 
    5903                 :       5435 : contains:
    5904                 :       5435 :   n = 0;
    5905                 :            : 
    5906                 :      16677 :   for (p = gfc_state_stack; p; p = p->previous)
    5907                 :      11242 :     if (p->state == COMP_CONTAINS)
    5908                 :        186 :       n++;
    5909                 :            : 
    5910                 :       5435 :   if (gfc_find_state (COMP_MODULE) == true
    5911                 :       5435 :       || gfc_find_state (COMP_SUBMODULE) == true)
    5912                 :        186 :     n--;
    5913                 :            : 
    5914                 :       5435 :   if (n > 0)
    5915                 :            :     {
    5916                 :          0 :       gfc_error ("CONTAINS statement at %C is already in a contained "
    5917                 :            :                  "program unit");
    5918                 :          0 :       reject_statement ();
    5919                 :          0 :       st = next_statement ();
    5920                 :          0 :       goto loop;
    5921                 :            :     }
    5922                 :            : 
    5923                 :       5435 :   parse_contained (0);
    5924                 :            : 
    5925                 :      54140 : done:
    5926                 :      54140 :   gfc_current_ns->code = gfc_state_stack->head;
    5927                 :      54140 : }
    5928                 :            : 
    5929                 :            : 
    5930                 :            : /* Come here to complain about a global symbol already in use as
    5931                 :            :    something else.  */
    5932                 :            : 
    5933                 :            : void
    5934                 :         16 : gfc_global_used (gfc_gsymbol *sym, locus *where)
    5935                 :            : {
    5936                 :         16 :   const char *name;
    5937                 :            : 
    5938                 :         16 :   if (where == NULL)
    5939                 :          0 :     where = &gfc_current_locus;
    5940                 :            : 
    5941                 :         16 :   switch(sym->type)
    5942                 :            :     {
    5943                 :            :     case GSYM_PROGRAM:
    5944                 :            :       name = "PROGRAM";
    5945                 :            :       break;
    5946                 :          2 :     case GSYM_FUNCTION:
    5947                 :          2 :       name = "FUNCTION";
    5948                 :          2 :       break;
    5949                 :          8 :     case GSYM_SUBROUTINE:
    5950                 :          8 :       name = "SUBROUTINE";
    5951                 :          8 :       break;
    5952                 :          3 :     case GSYM_COMMON:
    5953                 :          3 :       name = "COMMON";
    5954                 :          3 :       break;
    5955                 :          0 :     case GSYM_BLOCK_DATA:
    5956                 :          0 :       name = "BLOCK DATA";
    5957                 :          0 :       break;
    5958                 :          1 :     case GSYM_MODULE:
    5959                 :          1 :       name = "MODULE";
    5960                 :          1 :       break;
    5961                 :            :     default:
    5962                 :            :       name = NULL;
    5963                 :            :     }
    5964                 :            : 
    5965                 :         15 :   if (name)
    5966                 :            :     {
    5967                 :         15 :       if (sym->binding_label)
    5968                 :          2 :         gfc_error ("Global binding name %qs at %L is already being used "
    5969                 :            :                    "as a %s at %L", sym->binding_label, where, name,
    5970                 :            :                    &sym->where);
    5971                 :            :       else
    5972                 :         13 :         gfc_error ("Global name %qs at %L is already being used as "
    5973                 :            :                    "a %s at %L", sym->name, where, name, &sym->where);
    5974                 :            :     }
    5975                 :            :   else
    5976                 :            :     {
    5977                 :          1 :       if (sym->binding_label)
    5978                 :          1 :         gfc_error ("Global binding name %qs at %L is already being used "
    5979                 :            :                    "at %L", sym->binding_label, where, &sym->where);
    5980                 :            :       else
    5981                 :          0 :         gfc_error ("Global name %qs at %L is already being used at %L",
    5982                 :            :                    sym->name, where, &sym->where);
    5983                 :            :     }
    5984                 :         16 : }
    5985                 :            : 
    5986                 :            : 
    5987                 :            : /* Parse a block data program unit.  */
    5988                 :            : 
    5989                 :            : static void
    5990                 :         71 : parse_block_data (void)
    5991                 :            : {
    5992                 :         71 :   gfc_statement st;
    5993                 :         71 :   static locus blank_locus;
    5994                 :         71 :   static int blank_block=0;
    5995                 :         71 :   gfc_gsymbol *s;
    5996                 :            : 
    5997                 :         71 :   gfc_current_ns->proc_name = gfc_new_block;
    5998                 :         71 :   gfc_current_ns->is_block_data = 1;
    5999                 :            : 
    6000                 :         71 :   if (gfc_new_block == NULL)
    6001                 :            :     {
    6002                 :         40 :       if (blank_block)
    6003                 :          0 :        gfc_error ("Blank BLOCK DATA at %C conflicts with "
    6004                 :            :                   "prior BLOCK DATA at %L", &blank_locus);
    6005                 :            :       else
    6006                 :            :        {
    6007                 :         40 :          blank_block = 1;
    6008                 :         40 :          blank_locus = gfc_current_locus;
    6009                 :            :        }
    6010                 :            :     }
    6011                 :            :   else
    6012                 :            :     {
    6013                 :         31 :       s = gfc_get_gsymbol (gfc_new_block->name, false);
    6014                 :         31 :       if (s->defined
    6015                 :         31 :           || (s->type != GSYM_UNKNOWN && s->type != GSYM_BLOCK_DATA))
    6016                 :          0 :        gfc_global_used (s, &gfc_new_block->declared_at);
    6017                 :            :       else
    6018                 :            :        {
    6019                 :         31 :          s->type = GSYM_BLOCK_DATA;
    6020                 :         31 :          s->where = gfc_new_block->declared_at;
    6021                 :         31 :          s->defined = 1;
    6022                 :            :        }
    6023                 :            :     }
    6024                 :            : 
    6025                 :         71 :   st = parse_spec (ST_NONE);
    6026                 :            : 
    6027                 :         71 :   while (st != ST_END_BLOCK_DATA)
    6028                 :            :     {
    6029                 :          1 :       gfc_error ("Unexpected %s statement in BLOCK DATA at %C",
    6030                 :            :                  gfc_ascii_statement (st));
    6031                 :          1 :       reject_statement ();
    6032                 :          1 :       st = next_statement ();
    6033                 :            :     }
    6034                 :         70 : }
    6035                 :            : 
    6036                 :            : 
    6037                 :            : /* Following the association of the ancestor (sub)module symbols, they
    6038                 :            :    must be set host rather than use associated and all must be public.
    6039                 :            :    They are flagged up by 'used_in_submodule' so that they can be set
    6040                 :            :    DECL_EXTERNAL in trans_decl.c(gfc_finish_var_decl).  Otherwise the
    6041                 :            :    linker chokes on multiple symbol definitions.  */
    6042                 :            : 
    6043                 :            : static void
    6044                 :       1594 : set_syms_host_assoc (gfc_symbol *sym)
    6045                 :            : {
    6046                 :       1594 :   gfc_component *c;
    6047                 :       1594 :   const char dot[2] = ".";
    6048                 :            :   /* Symbols take the form module.submodule_ or module.name_. */
    6049                 :       1594 :   char parent1[2 * GFC_MAX_SYMBOL_LEN + 2];
    6050                 :       1594 :   char parent2[2 * GFC_MAX_SYMBOL_LEN + 2];
    6051                 :            : 
    6052                 :       1594 :   if (sym == NULL)
    6053                 :          0 :     return;
    6054                 :            : 
    6055                 :       1594 :   if (sym->attr.module_procedure)
    6056                 :        464 :     sym->attr.external = 0;
    6057                 :            : 
    6058                 :       1594 :   sym->attr.use_assoc = 0;
    6059                 :       1594 :   sym->attr.host_assoc = 1;
    6060                 :       1594 :   sym->attr.used_in_submodule =1;
    6061                 :            : 
    6062                 :       1594 :   if (sym->attr.flavor == FL_DERIVED)
    6063                 :            :     {
    6064                 :            :       /* Derived types with PRIVATE components that are declared in
    6065                 :            :          modules other than the parent module must not be changed to be
    6066                 :            :          PUBLIC. The 'use-assoc' attribute must be reset so that the
    6067                 :            :          test in symbol.c(gfc_find_component) works correctly. This is
    6068                 :            :          not necessary for PRIVATE symbols since they are not read from
    6069                 :            :          the module.  */
    6070                 :        259 :       memset(parent1, '\0', sizeof(parent1));
    6071                 :        259 :       memset(parent2, '\0', sizeof(parent2));
    6072                 :        259 :       strcpy (parent1, gfc_new_block->name);
    6073                 :        259 :       strcpy (parent2, sym->module);
    6074                 :        259 :       if (strcmp (strtok (parent1, dot), strtok (parent2, dot)) == 0)
    6075                 :            :         {
    6076                 :       1179 :           for (c = sym->components; c; c = c->next)
    6077                 :        946 :             c->attr.access = ACCESS_PUBLIC;
    6078                 :            :         }
    6079                 :            :       else
    6080                 :            :         {
    6081                 :         26 :           sym->attr.use_assoc = 1;
    6082                 :         26 :           sym->attr.host_assoc = 0;
    6083                 :            :         }
    6084                 :            :     }
    6085                 :            : }
    6086                 :            : 
    6087                 :            : /* Parse a module subprogram.  */
    6088                 :            : 
    6089                 :            : static void
    6090                 :       7334 : parse_module (void)
    6091                 :            : {
    6092                 :       7334 :   gfc_statement st;
    6093                 :       7334 :   gfc_gsymbol *s;
    6094                 :       7334 :   bool error;
    6095                 :            : 
    6096                 :       7334 :   s = gfc_get_gsymbol (gfc_new_block->name, false);
    6097                 :       7334 :   if (s->defined || (s->type != GSYM_UNKNOWN && s->type != GSYM_MODULE))
    6098                 :          1 :     gfc_global_used (s, &gfc_new_block->declared_at);
    6099                 :            :   else
    6100                 :            :     {
    6101                 :       7333 :       s->type = GSYM_MODULE;
    6102                 :       7333 :       s->where = gfc_new_block->declared_at;
    6103                 :       7333 :       s->defined = 1;
    6104                 :            :     }
    6105                 :            : 
    6106                 :            :   /* Something is nulling the module_list after this point. This is good
    6107                 :            :      since it allows us to 'USE' the parent modules that the submodule
    6108                 :            :      inherits and to set (most) of the symbols as host associated.  */
    6109                 :       7334 :   if (gfc_current_state () == COMP_SUBMODULE)
    6110                 :            :     {
    6111                 :        165 :       use_modules ();
    6112                 :        164 :       gfc_traverse_ns (gfc_current_ns, set_syms_host_assoc);
    6113                 :            :     }
    6114                 :            : 
    6115                 :       7333 :   st = parse_spec (ST_NONE);
    6116                 :            : 
    6117                 :       7333 :   error = false;
    6118                 :       7333 : loop:
    6119                 :       7333 :   switch (st)
    6120                 :            :     {
    6121                 :          0 :     case ST_NONE:
    6122                 :          0 :       unexpected_eof ();
    6123                 :            : 
    6124                 :       5447 :     case ST_CONTAINS:
    6125                 :       5447 :       parse_contained (1);
    6126                 :       5447 :       break;
    6127                 :            : 
    6128                 :       1885 :     case ST_END_MODULE:
    6129                 :       1885 :     case ST_END_SUBMODULE:
    6130                 :       1885 :       accept_statement (st);
    6131                 :       1885 :       break;
    6132                 :            : 
    6133                 :          1 :     default:
    6134                 :          1 :       gfc_error ("Unexpected %s statement in MODULE at %C",
    6135                 :            :                  gfc_ascii_statement (st));
    6136                 :            : 
    6137                 :          1 :       error = true;
    6138                 :          1 :       reject_statement ();
    6139                 :          1 :       st = next_statement ();
    6140                 :          1 :       goto loop;
    6141                 :            :     }
    6142                 :            : 
    6143                 :            :   /* Make sure not to free the namespace twice on error.  */
    6144                 :       7331 :   if (!error)
    6145                 :       7330 :     s->ns = gfc_current_ns;
    6146                 :       7331 : }
    6147                 :            : 
    6148                 :            : 
    6149                 :            : /* Add a procedure name to the global symbol table.  */
    6150                 :            : 
    6151                 :            : static void
    6152                 :       9373 : add_global_procedure (bool sub)
    6153                 :            : {
    6154                 :       9373 :   gfc_gsymbol *s;
    6155                 :            : 
    6156                 :            :   /* Only in Fortran 2003: For procedures with a binding label also the Fortran
    6157                 :            :      name is a global identifier.  */
    6158                 :       9373 :   if (!gfc_new_block->binding_label || gfc_notification_std (GFC_STD_F2008))
    6159                 :            :     {
    6160                 :       9297 :       s = gfc_get_gsymbol (gfc_new_block->name, false);
    6161                 :            : 
    6162                 :       9297 :       if (s->defined
    6163                 :       9295 :           || (s->type != GSYM_UNKNOWN
    6164                 :         99 :               && s->type != (sub ? GSYM_SUBROUTINE : GSYM_FUNCTION)))
    6165                 :            :         {
    6166                 :          2 :           gfc_global_used (s, &gfc_new_block->declared_at);
    6167                 :            :           /* Silence follow-up errors.  */
    6168                 :          2 :           gfc_new_block->binding_label = NULL;
    6169                 :            :         }
    6170                 :            :       else
    6171                 :            :         {
    6172                 :       9295 :           s->type = sub ? GSYM_SUBROUTINE : GSYM_FUNCTION;
    6173                 :       9295 :           s->sym_name = gfc_new_block->name;
    6174                 :       9295 :           s->where = gfc_new_block->declared_at;
    6175                 :       9295 :           s->defined = 1;
    6176                 :       9295 :           s->ns = gfc_current_ns;
    6177                 :            :         }
    6178                 :            :     }
    6179                 :            : 
    6180                 :            :   /* Don't add the symbol multiple times.  */
    6181                 :       9373 :   if (gfc_new_block->binding_label
    6182                 :       9373 :       && (!gfc_notification_std (GFC_STD_F2008)
    6183                 :          9 :           || strcmp (gfc_new_block->name, gfc_new_block->binding_label) != 0))
    6184                 :            :     {
    6185                 :         77 :       s = gfc_get_gsymbol (gfc_new_block->binding_label, true);
    6186                 :            : 
    6187                 :         77 :       if (s->defined
    6188                 :         74 :           || (s->type != GSYM_UNKNOWN
    6189                 :          4 :               && s->type != (sub ? GSYM_SUBROUTINE : GSYM_FUNCTION)))
    6190                 :            :         {
    6191                 :          3 :           gfc_global_used (s, &gfc_new_block->declared_at);
    6192                 :            :           /* Silence follow-up errors.  */
    6193                 :          3 :           gfc_new_block->binding_label = NULL;
    6194                 :            :         }
    6195                 :            :       else
    6196                 :            :         {
    6197                 :         74 :           s->type = sub ? GSYM_SUBROUTINE : GSYM_FUNCTION;
    6198                 :         74 :           s->sym_name = gfc_new_block->name;
    6199                 :         74 :           s->binding_label = gfc_new_block->binding_label;
    6200                 :         74 :           s->where = gfc_new_block->declared_at;
    6201                 :         74 :           s->defined = 1;
    6202                 :         74 :           s->ns = gfc_current_ns;
    6203                 :            :         }
    6204                 :            :     }
    6205                 :       9373 : }
    6206                 :            : 
    6207                 :            : 
    6208                 :            : /* Add a program to the global symbol table.  */
    6209                 :            : 
    6210                 :            : static void
    6211                 :      14653 : add_global_program (void)
    6212                 :            : {
    6213                 :      14653 :   gfc_gsymbol *s;
    6214                 :            : 
    6215                 :      14653 :   if (gfc_new_block == NULL)
    6216                 :            :     return;
    6217                 :      14653 :   s = gfc_get_gsymbol (gfc_new_block->name, false);
    6218                 :            : 
    6219                 :      14653 :   if (s->defined || (s->type != GSYM_UNKNOWN && s->type != GSYM_PROGRAM))
    6220                 :          0 :     gfc_global_used (s, &gfc_new_block->declared_at);
    6221                 :            :   else
    6222                 :            :     {
    6223                 :      14653 :       s->type = GSYM_PROGRAM;
    6224                 :      14653 :       s->where = gfc_new_block->declared_at;
    6225                 :      14653 :       s->defined = 1;
    6226                 :      14653 :       s->ns = gfc_current_ns;
    6227                 :            :     }
    6228                 :            : }
    6229                 :            : 
    6230                 :            : 
    6231                 :            : /* Resolve all the program units.  */
    6232                 :            : static void
    6233                 :      25143 : resolve_all_program_units (gfc_namespace *gfc_global_ns_list)
    6234                 :            : {
    6235                 :      25143 :   gfc_derived_types = NULL;
    6236                 :      25143 :   gfc_current_ns = gfc_global_ns_list;
    6237                 :      61689 :   for (; gfc_current_ns; gfc_current_ns = gfc_current_ns->sibling)
    6238                 :            :     {
    6239                 :      36548 :       if (gfc_current_ns->proc_name
    6240                 :      36548 :           && gfc_current_ns->proc_name->attr.flavor == FL_MODULE)
    6241                 :       7324 :         continue; /* Already resolved.  */
    6242                 :            : 
    6243                 :      29224 :       if (gfc_current_ns->proc_name)
    6244                 :      29224 :         gfc_current_locus = gfc_current_ns->proc_name->declared_at;
    6245                 :      29224 :       gfc_resolve (gfc_current_ns);
    6246                 :      29222 :       gfc_current_ns->derived_types = gfc_derived_types;
    6247                 :      29222 :       gfc_derived_types = NULL;
    6248                 :            :     }
    6249                 :      25141 : }
    6250                 :            : 
    6251                 :            : 
    6252                 :            : static void
    6253                 :     122631 : clean_up_modules (gfc_gsymbol *gsym)
    6254                 :            : {
    6255                 :     122631 :   if (gsym == NULL)
    6256                 :            :     return;
    6257                 :            : 
    6258                 :      48745 :   clean_up_modules (gsym->left);
    6259                 :      48745 :   clean_up_modules (gsym->right);
    6260                 :            : 
    6261                 :      48745 :   if (gsym->type != GSYM_MODULE || !gsym->ns)
    6262                 :            :     return;
    6263                 :            : 
    6264                 :       7461 :   gfc_current_ns = gsym->ns;
    6265                 :       7461 :   gfc_derived_types = gfc_current_ns->derived_types;
    6266                 :       7461 :   gfc_done_2 ();
    6267                 :       7461 :   gsym->ns = NULL;
    6268                 :       7461 :   return;
    6269                 :            : }
    6270                 :            : 
    6271                 :            : 
    6272                 :            : /* Translate all the program units. This could be in a different order
    6273                 :            :    to resolution if there are forward references in the file.  */
    6274                 :            : static void
    6275                 :      25141 : translate_all_program_units (gfc_namespace *gfc_global_ns_list)
    6276                 :            : {
    6277                 :      25141 :   int errors;
    6278                 :            : 
    6279                 :      25141 :   gfc_current_ns = gfc_global_ns_list;
    6280                 :      25141 :   gfc_get_errors (NULL, &errors);
    6281                 :            : 
    6282                 :            :   /* We first translate all modules to make sure that later parts
    6283                 :            :      of the program can use the decl. Then we translate the nonmodules.  */
    6284                 :            : 
    6285                 :      61533 :   for (; !errors && gfc_current_ns; gfc_current_ns = gfc_current_ns->sibling)
    6286                 :            :     {
    6287                 :      36392 :       if (!gfc_current_ns->proc_name
    6288                 :      36392 :           || gfc_current_ns->proc_name->attr.flavor != FL_MODULE)
    6289                 :      29676 :         continue;
    6290                 :            : 
    6291                 :       6716 :       gfc_current_locus = gfc_current_ns->proc_name->declared_at;
    6292                 :       6716 :       gfc_derived_types = gfc_current_ns->derived_types;
    6293                 :       6716 :       gfc_generate_module_code (gfc_current_ns);
    6294                 :       6716 :       gfc_current_ns->translated = 1;
    6295                 :            :     }
    6296                 :            : 
    6297                 :      25141 :   gfc_current_ns = gfc_global_ns_list;
    6298                 :      61533 :   for (; !errors && gfc_current_ns; gfc_current_ns = gfc_current_ns->sibling)
    6299                 :            :     {
    6300                 :      36392 :       if (gfc_current_ns->proc_name
    6301                 :      36392 :           && gfc_current_ns->proc_name->attr.flavor == FL_MODULE)
    6302                 :       6716 :         continue;
    6303                 :            : 
    6304                 :      29676 :       gfc_current_locus = gfc_current_ns->proc_name->declared_at;
    6305                 :      29676 :       gfc_derived_types = gfc_current_ns->derived_types;
    6306                 :      29676 :       gfc_generate_code (gfc_current_ns);
    6307                 :      29676 :       gfc_current_ns->translated = 1;
    6308                 :            :     }
    6309                 :            : 
    6310                 :            :   /* Clean up all the namespaces after translation.  */
    6311                 :      25141 :   gfc_current_ns = gfc_global_ns_list;
    6312                 :      64096 :   for (;gfc_current_ns;)
    6313                 :            :     {
    6314                 :      38955 :       gfc_namespace *ns;
    6315                 :            : 
    6316                 :      38955 :       if (gfc_current_ns->proc_name
    6317                 :      38955 :           && gfc_current_ns->proc_name->attr.flavor == FL_MODULE)
    6318                 :            :         {
    6319                 :       7324 :           gfc_current_ns = gfc_current_ns->sibling;
    6320                 :       7324 :           continue;
    6321                 :            :         }
    6322                 :            : 
    6323                 :      31631 :       ns = gfc_current_ns->sibling;
    6324                 :      31631 :       gfc_derived_types = gfc_current_ns->derived_types;
    6325                 :      31631 :       gfc_done_2 ();
    6326                 :      31631 :       gfc_current_ns = ns;
    6327                 :            :     }
    6328                 :            : 
    6329                 :      25141 :   clean_up_modules (gfc_gsym_root);
    6330                 :      25141 : }
    6331                 :            : 
    6332                 :            : 
    6333                 :            : /* Top level parser.  */
    6334                 :            : 
    6335                 :            : bool
    6336                 :      25178 : gfc_parse_file (void)
    6337                 :            : {
    6338                 :      25178 :   int seen_program, errors_before, errors;
    6339                 :      25178 :   gfc_state_data top, s;
    6340                 :      25178 :   gfc_statement st;
    6341                 :      25178 :   locus prog_locus;
    6342                 :      25178 :   gfc_namespace *next;
    6343                 :            : 
    6344                 :      25178 :   gfc_start_source_files ();
    6345                 :            : 
    6346                 :      25178 :   top.state = COMP_NONE;
    6347                 :      25178 :   top.sym = NULL;
    6348                 :      25178 :   top.previous = NULL;
    6349                 :      25178 :   top.head = top.tail = NULL;
    6350                 :      25178 :   top.do_variable = NULL;
    6351                 :            : 
    6352                 :      25178 :   gfc_state_stack = &top;
    6353                 :            : 
    6354                 :      25178 :   gfc_clear_new_st ();
    6355                 :            : 
    6356                 :      25178 :   gfc_statement_label = NULL;
    6357                 :            : 
    6358                 :      25203 :   if (setjmp (eof_buf))
    6359                 :            :     return false;       /* Come here on unexpected EOF */
    6360                 :            : 
    6361                 :            :   /* Prepare the global namespace that will contain the
    6362                 :            :      program units.  */
    6363                 :      25178 :   gfc_global_ns_list = next = NULL;
    6364                 :            : 
    6365                 :      25178 :   seen_program = 0;
    6366                 :      25178 :   errors_before = 0;
    6367                 :            : 
    6368                 :            :   /* Exit early for empty files.  */
    6369                 :      25178 :   if (gfc_at_eof ())
    6370                 :          0 :     goto done;
    6371                 :            : 
    6372                 :      25178 :   in_specification_block = true;
    6373                 :      64216 : loop:
    6374                 :      64216 :   gfc_init_2 ();
    6375                 :      64216 :   st = next_statement ();
    6376                 :      64213 :   switch (st)
    6377                 :            :     {
    6378                 :      25143 :     case ST_NONE:
    6379                 :      25143 :       gfc_done_2 ();
    6380                 :      25143 :       goto done;
    6381                 :            : 
    6382                 :      14653 :     case ST_PROGRAM:
    6383                 :      14653 :       if (seen_program)
    6384                 :          0 :         goto duplicate_main;
    6385                 :      14653 :       seen_program = 1;
    6386                 :      14653 :       prog_locus = gfc_current_locus;
    6387                 :            : 
    6388                 :      14653 :       push_state (&s, COMP_PROGRAM, gfc_new_block);
    6389                 :      14653 :       main_program_symbol (gfc_current_ns, gfc_new_block->name);
    6390                 :      14653 :       accept_statement (st);
    6391                 :      14653 :       add_global_program ();
    6392                 :      14653 :       parse_progunit (ST_NONE);
    6393                 :      14637 :       goto prog_units;
    6394                 :            : 
    6395                 :       6808 :     case ST_SUBROUTINE:
    6396                 :       6808 :       add_global_procedure (true);
    6397                 :       6808 :       push_state (&s, COMP_SUBROUTINE, gfc_new_block);
    6398                 :       6808 :       accept_statement (st);
    6399                 :       6808 :       parse_progunit (ST_NONE);
    6400                 :       6806 :       goto prog_units;
    6401                 :            : 
    6402                 :       2565 :     case ST_FUNCTION:
    6403                 :       2565 :       add_global_procedure (false);
    6404                 :       2565 :       push_state (&s, COMP_FUNCTION, gfc_new_block);
    6405                 :       2565 :       accept_statement (st);
    6406                 :       2565 :       parse_progunit (ST_NONE);
    6407                 :       2565 :       goto prog_units;
    6408                 :            : 
    6409                 :         71 :     case ST_BLOCK_DATA:
    6410                 :         71 :       push_state (&s, COMP_BLOCK_DATA, gfc_new_block);
    6411                 :         71 :       accept_statement (st);
    6412                 :         71 :       parse_block_data ();
    6413                 :            :       break;
    6414                 :            : 
    6415                 :       7169 :     case ST_MODULE:
    6416                 :       7169 :       push_state (&s, COMP_MODULE, gfc_new_block);
    6417                 :       7169 :       accept_statement (st);
    6418                 :            : 
    6419                 :       7169 :       gfc_get_errors (NULL, &errors_before);
    6420                 :       7169 :       parse_module ();
    6421                 :            :       break;
    6422                 :            : 
    6423                 :        165 :     case ST_SUBMODULE:
    6424                 :        165 :       push_state (&s, COMP_SUBMODULE, gfc_new_block);
    6425                 :        165 :       accept_statement (st);
    6426                 :            : 
    6427                 :        165 :       gfc_get_errors (NULL, &errors_before);
    6428                 :        165 :       parse_module ();
    6429                 :            :       break;
    6430                 :            : 
    6431                 :            :     /* Anything else starts a nameless main program block.  */
    6432                 :       7639 :     default:
    6433                 :       7639 :       if (seen_program)
    6434                 :          1 :         goto duplicate_main;
    6435                 :       7638 :       seen_program = 1;
    6436                 :       7638 :       prog_locus = gfc_current_locus;
    6437                 :            : 
    6438                 :       7638 :       push_state (&s, COMP_PROGRAM, gfc_new_block);
    6439                 :       7638 :       main_program_symbol (gfc_current_ns, "MAIN__");
    6440                 :       7638 :       parse_progunit (st);
    6441                 :       7629 :       goto prog_units;
    6442                 :            :     }
    6443                 :            : 
    6444                 :            :   /* Handle the non-program units.  */
    6445                 :       7401 :   gfc_current_ns->code = s.head;
    6446                 :            : 
    6447                 :       7401 :   gfc_resolve (gfc_current_ns);
    6448                 :            : 
    6449                 :            :   /* Dump the parse tree if requested.  */
    6450                 :       7401 :   if (flag_dump_fortran_original)
    6451                 :          0 :     gfc_dump_parse_tree (gfc_current_ns, stdout);
    6452                 :            : 
    6453                 :       7401 :   gfc_get_errors (NULL, &errors);
    6454                 :       7401 :   if (s.state == COMP_MODULE || s.state == COMP_SUBMODULE)
    6455                 :            :     {
    6456                 :       7331 :       gfc_dump_module (s.sym->name, errors_before == errors);
    6457                 :       7331 :       gfc_current_ns->derived_types = gfc_derived_types;
    6458                 :       7331 :       gfc_derived_types = NULL;
    6459                 :       7331 :       goto prog_units;
    6460                 :            :     }
    6461                 :            :   else
    6462                 :            :     {
    6463                 :         70 :       if (errors == 0)
    6464                 :         65 :         gfc_generate_code (gfc_current_ns);
    6465                 :         70 :       pop_state ();
    6466                 :         70 :       gfc_done_2 ();
    6467                 :            :     }
    6468                 :            : 
    6469                 :         70 :   goto loop;
    6470                 :            : 
    6471                 :      38968 : prog_units:
    6472                 :            :   /* The main program and non-contained procedures are put
    6473                 :            :      in the global namespace list, so that they can be processed
    6474                 :            :      later and all their interfaces resolved.  */
    6475                 :      38968 :   gfc_current_ns->code = s.head;
    6476                 :      38968 :   if (next)
    6477                 :            :     {
    6478                 :      13861 :       for (; next->sibling; next = next->sibling)
    6479                 :            :         ;
    6480                 :      13850 :       next->sibling = gfc_current_ns;
    6481                 :            :     }
    6482                 :            :   else
    6483                 :      25118 :     gfc_global_ns_list = gfc_current_ns;
    6484                 :            : 
    6485                 :      38968 :   next = gfc_current_ns;
    6486                 :            : 
    6487                 :      38968 :   pop_state ();
    6488                 :      38968 :   goto loop;
    6489                 :            : 
    6490                 :      25143 : done:
    6491                 :            :   /* Do the resolution.  */
    6492                 :      25143 :   resolve_all_program_units (gfc_global_ns_list);
    6493                 :            : 
    6494                 :            : 
    6495                 :            :   /* Fixup for external procedures.  */
    6496                 :      64096 :   for (gfc_current_ns = gfc_global_ns_list; gfc_current_ns;
    6497                 :      38955 :        gfc_current_ns = gfc_current_ns->sibling)
    6498                 :      38955 :     gfc_check_externals (gfc_current_ns);
    6499                 :            : 
    6500                 :            :   /* Do the parse tree dump.  */
    6501                 :      25141 :   gfc_current_ns = flag_dump_fortran_original ? gfc_global_ns_list : NULL;
    6502                 :            : 
    6503                 :      25173 :   for (; gfc_current_ns; gfc_current_ns = gfc_current_ns->sibling)
    6504                 :         32 :     if (!gfc_current_ns->proc_name
    6505                 :         32 :         || gfc_current_ns->proc_name->attr.flavor != FL_MODULE)
    6506                 :            :       {
    6507                 :         32 :         gfc_dump_parse_tree (gfc_current_ns, stdout);
    6508                 :         32 :         fputs ("------------------------------------------\n\n", stdout);
    6509                 :            :       }
    6510                 :            : 
    6511                 :            :   /* Dump C prototypes.  */
    6512                 :      25141 :   if (flag_c_prototypes || flag_c_prototypes_external)
    6513                 :            :     {
    6514                 :          0 :       fprintf (stdout,
    6515                 :            :                "#include <stddef.h>\n"
    6516                 :            :                "#ifdef __cplusplus\n"
    6517                 :            :                "#include <complex>\n"
    6518                 :            :                "#define __GFORTRAN_FLOAT_COMPLEX std::complex<float>\n"
    6519                 :            :                "#define __GFORTRAN_DOUBLE_COMPLEX std::complex<double>\n"
    6520                 :            :                "#define __GFORTRAN_LONG_DOUBLE_COMPLEX std::complex<long double>\n"
    6521                 :            :                "extern \"C\" {\n"
    6522                 :            :                "#else\n"
    6523                 :            :                "#define __GFORTRAN_FLOAT_COMPLEX float _Complex\n"
    6524                 :            :                "#define __GFORTRAN_DOUBLE_COMPLEX double _Complex\n"
    6525                 :            :                "#define __GFORTRAN_LONG_DOUBLE_COMPLEX long double _Complex\n"
    6526                 :            :                "#endif\n\n");
    6527                 :            :     }
    6528                 :            : 
    6529                 :            :   /* First dump BIND(C) prototypes.  */
    6530                 :      25141 :   if (flag_c_prototypes)
    6531                 :            :     {
    6532                 :          0 :       for (gfc_current_ns = gfc_global_ns_list; gfc_current_ns;
    6533                 :          0 :            gfc_current_ns = gfc_current_ns->sibling)
    6534                 :          0 :         gfc_dump_c_prototypes (gfc_current_ns, stdout);
    6535                 :            :     }
    6536                 :            : 
    6537                 :            :   /* Dump external prototypes.  */
    6538                 :      25141 :   if (flag_c_prototypes_external)
    6539                 :          0 :     gfc_dump_external_c_prototypes (stdout);
    6540                 :            : 
    6541                 :      25141 :   if (flag_c_prototypes || flag_c_prototypes_external)
    6542                 :          0 :     fprintf (stdout, "\n#ifdef __cplusplus\n}\n#endif\n");
    6543                 :            : 
    6544                 :            :   /* Do the translation.  */
    6545                 :      25141 :   translate_all_program_units (gfc_global_ns_list);
    6546                 :            : 
    6547                 :            :   /* Dump the global symbol ist.  We only do this here because part
    6548                 :            :      of it is generated after mangling the identifiers in
    6549                 :            :      trans-decl.c.  */
    6550                 :            : 
    6551                 :      25141 :   if (flag_dump_fortran_global)
    6552                 :          0 :     gfc_dump_global_symbols (stdout);
    6553                 :            : 
    6554                 :      25141 :   gfc_end_source_files ();
    6555                 :            :   return true;
    6556                 :            : 
    6557                 :          1 : duplicate_main:
    6558                 :            :   /* If we see a duplicate main program, shut down.  If the second
    6559                 :            :      instance is an implied main program, i.e. data decls or executable
    6560                 :            :      statements, we're in for lots of errors.  */
    6561                 :          1 :   gfc_error ("Two main PROGRAMs at %L and %C", &prog_locus);
    6562                 :          1 :   reject_statement ();
    6563                 :          1 :   gfc_done_2 ();
    6564                 :            :   return true;
    6565                 :            : }
    6566                 :            : 
    6567                 :            : /* Return true if this state data represents an OpenACC region.  */
    6568                 :            : bool
    6569                 :          5 : is_oacc (gfc_state_data *sd)
    6570                 :            : {
    6571                 :          5 :   switch (sd->construct->op)
    6572                 :            :     {
    6573                 :            :     case EXEC_OACC_PARALLEL_LOOP:
    6574                 :            :     case EXEC_OACC_PARALLEL:
    6575                 :            :     case EXEC_OACC_KERNELS_LOOP:
    6576                 :            :     case EXEC_OACC_KERNELS:
    6577                 :            :     case EXEC_OACC_SERIAL_LOOP:
    6578                 :            :     case EXEC_OACC_SERIAL:
    6579                 :            :     case EXEC_OACC_DATA:
    6580                 :            :     case EXEC_OACC_HOST_DATA:
    6581                 :            :     case EXEC_OACC_LOOP:
    6582                 :            :     case EXEC_OACC_UPDATE:
    6583                 :            :     case EXEC_OACC_WAIT:
    6584                 :            :     case EXEC_OACC_CACHE:
    6585                 :            :     case EXEC_OACC_ENTER_DATA:
    6586                 :            :     case EXEC_OACC_EXIT_DATA:
    6587                 :            :     case EXEC_OACC_ATOMIC:
    6588                 :            :     case EXEC_OACC_ROUTINE:
    6589                 :            :       return true;
    6590                 :            : 
    6591                 :          3 :     default:
    6592                 :          3 :       return false;
    6593                 :            :     }
    6594                 :            : }

Generated by: LCOV version 1.0

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 --enable-host-shared. GCC test suite is run with the built compiler.